~derek-name/openvista-gtm-integration/replication-testing
» Revision
130
: kids/MSC_GTM_INTEG_15.KID
« back to all changes in this revision
Viewing changes to kids/MSC_GTM_INTEG_15.KID
- browse files at revision 130
- compare with another revision
- download diff
- download tarball
- view history from revision 130
- Committer: Jonathan Tai
- Date: 2010-04-29 03:04:49 UTC
- mfrom: (129.1.2 bug571450)
- Revision ID: jon.tai@medsphere.com-20100429030449-aigd2yfd87hrxoox
Merge bug 571450 - Update ZTMGRSET
- files added:
- kids/MSC_GTM_INTEG_15.KID
- files modified:
- mumps/ZTMGRSET.m
added
removed
kids/MSC_GTM_INTEG_15.KID
1
KIDS Distribution saved on Apr 28, 2010@14:41:20
2
VERSION 15 - UPDATE ZTMGRSET
3
**KIDS**:MSC GTM INTEGRATION*1.0*15^
4
5
**INSTALL NAME**
6
MSC GTM INTEGRATION*1.0*15
7
"BLD",7026,0)
8
MSC GTM INTEGRATION*1.0*15^^0^3100428^y
9
"BLD",7026,1,0)
10
^^1^1^3090611^
11
"BLD",7026,1,1,0)
12
SYSTEM STATUS AND JOBEXAM FOR GT.M
13
"BLD",7026,4,0)
14
^9.64PA^^
15
"BLD",7026,6.3)
16
56
17
"BLD",7026,"INIT")
18
19
"BLD",7026,"KRN",0)
20
^9.67PA^8989.52^19
21
"BLD",7026,"KRN",.4,0)
22
.4
23
"BLD",7026,"KRN",.401,0)
24
.401
25
"BLD",7026,"KRN",.402,0)
26
.402
27
"BLD",7026,"KRN",.403,0)
28
.403
29
"BLD",7026,"KRN",.403,"NM",0)
30
^9.68A^2^2
31
"BLD",7026,"KRN",.403,"NM",1,0)
32
MSCZJOBEXAM FILE #3.081^3.081^0
33
"BLD",7026,"KRN",.403,"NM",2,0)
34
MSCZLOCK FILE #3.081^3.081^0
35
"BLD",7026,"KRN",.403,"NM","B","MSCZJOBEXAM FILE #3.081",1)
36
37
"BLD",7026,"KRN",.403,"NM","B","MSCZLOCK FILE #3.081",2)
38
39
"BLD",7026,"KRN",.5,0)
40
.5
41
"BLD",7026,"KRN",.84,0)
42
.84
43
"BLD",7026,"KRN",3.6,0)
44
3.6
45
"BLD",7026,"KRN",3.8,0)
46
3.8
47
"BLD",7026,"KRN",9.2,0)
48
9.2
49
"BLD",7026,"KRN",9.2,"NM",0)
50
^9.68A^^
51
"BLD",7026,"KRN",9.8,0)
52
9.8
53
"BLD",7026,"KRN",9.8,"NM",0)
54
^9.68A^55^47
55
"BLD",7026,"KRN",9.8,"NM",1,0)
56
MSCZJOB^^0^B12965530
57
"BLD",7026,"KRN",9.8,"NM",4,0)
58
MSCZJOBU^^0^B9589351
59
"BLD",7026,"KRN",9.8,"NM",5,0)
60
ZIS4GTM^^0^B18512871
61
"BLD",7026,"KRN",9.8,"NM",7,0)
62
XTER1A^^0^B29100251
63
"BLD",7026,"KRN",9.8,"NM",8,0)
64
ZUGTM^^0^B10012519
65
"BLD",7026,"KRN",9.8,"NM",11,0)
66
ZCD^^0^B27561610
67
"BLD",7026,"KRN",9.8,"NM",13,0)
68
ZOSV2GTM^^0^B7713680
69
"BLD",7026,"KRN",9.8,"NM",14,0)
70
ZOSFGUX^^0^B22502126
71
"BLD",7026,"KRN",9.8,"NM",15,0)
72
ZISHGUX^^0^B36911880
73
"BLD",7026,"KRN",9.8,"NM",16,0)
74
HLCSTCP1^^0^B34257905
75
"BLD",7026,"KRN",9.8,"NM",17,0)
76
HLCSTCP^^0^B32647785
77
"BLD",7026,"KRN",9.8,"NM",18,0)
78
HLCSLNCH^^0^B37119958
79
"BLD",7026,"KRN",9.8,"NM",19,0)
80
XOBVLL^^0^B18012967
81
"BLD",7026,"KRN",9.8,"NM",20,0)
82
XOBVRH^^0^B13028891
83
"BLD",7026,"KRN",9.8,"NM",21,0)
84
XOBVSKT^^0^B19755798
85
"BLD",7026,"KRN",9.8,"NM",22,0)
86
XOBVTCPL^^0^B13492271
87
"BLD",7026,"KRN",9.8,"NM",23,0)
88
XWBTCPM^^0^B56922128
89
"BLD",7026,"KRN",9.8,"NM",24,0)
90
ZTMGRSET^^0^B57539605
91
"BLD",7026,"KRN",9.8,"NM",25,0)
92
ZISTCPS^^0^B18299533
93
"BLD",7026,"KRN",9.8,"NM",26,0)
94
XPDR^^0^B52133395
95
"BLD",7026,"KRN",9.8,"NM",27,0)
96
ZISFGUX^^1^
97
"BLD",7026,"KRN",9.8,"NM",28,0)
98
ZTER^^0^B39678986
99
"BLD",7026,"KRN",9.8,"NM",29,0)
100
ZSTARTGUX^^0^B140233
101
"BLD",7026,"KRN",9.8,"NM",31,0)
102
MSCXUS3A^^0^B9453784
103
"BLD",7026,"KRN",9.8,"NM",32,0)
104
RORHL7A^^0^B35660209
105
"BLD",7026,"KRN",9.8,"NM",33,0)
106
ZOSVGUX^^0^B1197142
107
"BLD",7026,"KRN",9.8,"NM",34,0)
108
DGMSTAPI^^0^B48539163
109
"BLD",7026,"KRN",9.8,"NM",35,0)
110
GMRCA2^^0^B10634
111
"BLD",7026,"KRN",9.8,"NM",36,0)
112
MAGDMEDL^^0^B3132920
113
"BLD",7026,"KRN",9.8,"NM",37,0)
114
PRCSEA^^0^B66865498
115
"BLD",7026,"KRN",9.8,"NM",38,0)
116
PSBOMH1^^0^B71152392
117
"BLD",7026,"KRN",9.8,"NM",39,0)
118
PSBRPC2^^0^B44967923
119
"BLD",7026,"KRN",9.8,"NM",40,0)
120
PXRMTMED^^0^B9342039
121
"BLD",7026,"KRN",9.8,"NM",41,0)
122
VALMW3^^0^B21033865
123
"BLD",7026,"KRN",9.8,"NM",42,0)
124
XQALSUR1^^0^B29675685
125
"BLD",7026,"KRN",9.8,"NM",43,0)
126
XUMF5AU^^0^B76801793
127
"BLD",7026,"KRN",9.8,"NM",44,0)
128
ZSTOPGUX^^0^B148072
129
"BLD",7026,"KRN",9.8,"NM",46,0)
130
MSCZJOBS^^0^B5731054
131
"BLD",7026,"KRN",9.8,"NM",47,0)
132
ZOSVONT^^0^B23474671
133
"BLD",7026,"KRN",9.8,"NM",48,0)
134
ZISFGTM^^0^B9317180
135
"BLD",7026,"KRN",9.8,"NM",49,0)
136
ZSSGUX^^0^B47435
137
"BLD",7026,"KRN",9.8,"NM",50,0)
138
XWBRW^^0^B8699412
139
"BLD",7026,"KRN",9.8,"NM",51,0)
140
XWBSEC^^0^B5872236
141
"BLD",7026,"KRN",9.8,"NM",52,0)
142
HLZTCP^^0^B44973921
143
"BLD",7026,"KRN",9.8,"NM",53,0)
144
HLCSTCP2^^0^B62380874
145
"BLD",7026,"KRN",9.8,"NM",54,0)
146
HLCSTCP3^^0^B4155616
147
"BLD",7026,"KRN",9.8,"NM",55,0)
148
HLCSTCP4^^0^B3608309
149
"BLD",7026,"KRN",9.8,"NM","B","DGMSTAPI",34)
150
151
"BLD",7026,"KRN",9.8,"NM","B","GMRCA2",35)
152
153
"BLD",7026,"KRN",9.8,"NM","B","HLCSLNCH",18)
154
155
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP",17)
156
157
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP1",16)
158
159
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP2",53)
160
161
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP3",54)
162
163
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP4",55)
164
165
"BLD",7026,"KRN",9.8,"NM","B","HLZTCP",52)
166
167
"BLD",7026,"KRN",9.8,"NM","B","MAGDMEDL",36)
168
169
"BLD",7026,"KRN",9.8,"NM","B","MSCXUS3A",31)
170
171
"BLD",7026,"KRN",9.8,"NM","B","MSCZJOB",1)
172
173
"BLD",7026,"KRN",9.8,"NM","B","MSCZJOBS",46)
174
175
"BLD",7026,"KRN",9.8,"NM","B","MSCZJOBU",4)
176
177
"BLD",7026,"KRN",9.8,"NM","B","PRCSEA",37)
178
179
"BLD",7026,"KRN",9.8,"NM","B","PSBOMH1",38)
180
181
"BLD",7026,"KRN",9.8,"NM","B","PSBRPC2",39)
182
183
"BLD",7026,"KRN",9.8,"NM","B","PXRMTMED",40)
184
185
"BLD",7026,"KRN",9.8,"NM","B","RORHL7A",32)
186
187
"BLD",7026,"KRN",9.8,"NM","B","VALMW3",41)
188
189
"BLD",7026,"KRN",9.8,"NM","B","XOBVLL",19)
190
191
"BLD",7026,"KRN",9.8,"NM","B","XOBVRH",20)
192
193
"BLD",7026,"KRN",9.8,"NM","B","XOBVSKT",21)
194
195
"BLD",7026,"KRN",9.8,"NM","B","XOBVTCPL",22)
196
197
"BLD",7026,"KRN",9.8,"NM","B","XPDR",26)
198
199
"BLD",7026,"KRN",9.8,"NM","B","XQALSUR1",42)
200
201
"BLD",7026,"KRN",9.8,"NM","B","XTER1A",7)
202
203
"BLD",7026,"KRN",9.8,"NM","B","XUMF5AU",43)
204
205
"BLD",7026,"KRN",9.8,"NM","B","XWBRW",50)
206
207
"BLD",7026,"KRN",9.8,"NM","B","XWBSEC",51)
208
209
"BLD",7026,"KRN",9.8,"NM","B","XWBTCPM",23)
210
211
"BLD",7026,"KRN",9.8,"NM","B","ZCD",11)
212
213
"BLD",7026,"KRN",9.8,"NM","B","ZIS4GTM",5)
214
215
"BLD",7026,"KRN",9.8,"NM","B","ZISFGTM",48)
216
217
"BLD",7026,"KRN",9.8,"NM","B","ZISFGUX",27)
218
219
"BLD",7026,"KRN",9.8,"NM","B","ZISHGUX",15)
220
221
"BLD",7026,"KRN",9.8,"NM","B","ZISTCPS",25)
222
223
"BLD",7026,"KRN",9.8,"NM","B","ZOSFGUX",14)
224
225
"BLD",7026,"KRN",9.8,"NM","B","ZOSV2GTM",13)
226
227
"BLD",7026,"KRN",9.8,"NM","B","ZOSVGUX",33)
228
229
"BLD",7026,"KRN",9.8,"NM","B","ZOSVONT",47)
230
231
"BLD",7026,"KRN",9.8,"NM","B","ZSSGUX",49)
232
233
"BLD",7026,"KRN",9.8,"NM","B","ZSTARTGUX",29)
234
235
"BLD",7026,"KRN",9.8,"NM","B","ZSTOPGUX",44)
236
237
"BLD",7026,"KRN",9.8,"NM","B","ZTER",28)
238
239
"BLD",7026,"KRN",9.8,"NM","B","ZTMGRSET",24)
240
241
"BLD",7026,"KRN",9.8,"NM","B","ZUGTM",8)
242
243
"BLD",7026,"KRN",19,0)
244
19
245
"BLD",7026,"KRN",19,"NM",0)
246
^9.68A^2^2
247
"BLD",7026,"KRN",19,"NM",1,0)
248
MSCZJOB^^0
249
"BLD",7026,"KRN",19,"NM",2,0)
250
MSCZLOCK^^0
251
"BLD",7026,"KRN",19,"NM","B","MSCZJOB",1)
252
253
"BLD",7026,"KRN",19,"NM","B","MSCZLOCK",2)
254
255
"BLD",7026,"KRN",19.1,0)
256
19.1
257
"BLD",7026,"KRN",101,0)
258
101
259
"BLD",7026,"KRN",409.61,0)
260
409.61
261
"BLD",7026,"KRN",771,0)
262
771
263
"BLD",7026,"KRN",870,0)
264
870
265
"BLD",7026,"KRN",8989.51,0)
266
8989.51
267
"BLD",7026,"KRN",8989.52,0)
268
8989.52
269
"BLD",7026,"KRN",8994,0)
270
8994
271
"BLD",7026,"KRN","B",.4,.4)
272
273
"BLD",7026,"KRN","B",.401,.401)
274
275
"BLD",7026,"KRN","B",.402,.402)
276
277
"BLD",7026,"KRN","B",.403,.403)
278
279
"BLD",7026,"KRN","B",.5,.5)
280
281
"BLD",7026,"KRN","B",.84,.84)
282
283
"BLD",7026,"KRN","B",3.6,3.6)
284
285
"BLD",7026,"KRN","B",3.8,3.8)
286
287
"BLD",7026,"KRN","B",9.2,9.2)
288
289
"BLD",7026,"KRN","B",9.8,9.8)
290
291
"BLD",7026,"KRN","B",19,19)
292
293
"BLD",7026,"KRN","B",19.1,19.1)
294
295
"BLD",7026,"KRN","B",101,101)
296
297
"BLD",7026,"KRN","B",409.61,409.61)
298
299
"BLD",7026,"KRN","B",771,771)
300
301
"BLD",7026,"KRN","B",870,870)
302
303
"BLD",7026,"KRN","B",8989.51,8989.51)
304
305
"BLD",7026,"KRN","B",8989.52,8989.52)
306
307
"BLD",7026,"KRN","B",8994,8994)
308
309
"BLD",7026,"MSC")
310
/home/jon/MSC_GTM_INTEG_15.KID
311
"BLD",7026,"MSCOM")
312
VERSION 15 - UPDATE ZTMGRSET
313
"BLD",7026,"PRE")
314
MSCGUX53
315
"BLD",7026,"QUES",0)
316
^9.62^^
317
"KRN",.403,121,-1)
318
0^1
319
"KRN",.403,121,0)
320
MSCZJOBEXAM^ ^@^^3070530.1755^^^3.081^0^1^1
321
"KRN",.403,121,12)
322
323
"KRN",.403,121,21)
324
325
"KRN",.403,121,40,0)
326
^.4031I^3^3
327
"KRN",.403,121,40,1,0)
328
1^^1,1^^^1^17,80
329
"KRN",.403,121,40,1,1)
330
Page 1
331
"KRN",.403,121,40,1,40,0)
332
^.4032IP^433^2
333
"KRN",.403,121,40,1,40,432,0)
334
MSCZJOBEXAM^4^3,2^e
335
"KRN",.403,121,40,1,40,432,2)
336
13^^u^^1
337
"KRN",.403,121,40,1,40,432,"COMP MUL")
338
D COMPMUL^MSCZJOB
339
"KRN",.403,121,40,1,40,432,"COMP MUL PTR")
340
341
"KRN",.403,121,40,1,40,433,0)
342
MSCZJOBEXAM HDR^1^1,2^d
343
"KRN",.403,121,40,2,0)
344
2^^1,1^^^1^18,79
345
"KRN",.403,121,40,2,1)
346
Page 2
347
"KRN",.403,121,40,2,40,0)
348
^.4032IP^437^3
349
"KRN",.403,121,40,2,40,434,0)
350
MSCZJOBEXAM 2^1^1,1^e
351
"KRN",.403,121,40,2,40,435,0)
352
MSCZJOBVARS^3^8,3^e
353
"KRN",.403,121,40,2,40,435,2)
354
9^^f^^1
355
"KRN",.403,121,40,2,40,435,"COMP MUL")
356
D COMPVARS^MSCZJOB
357
"KRN",.403,121,40,2,40,437,0)
358
MSCZJOBSTACK^4^3,3^e
359
"KRN",.403,121,40,2,40,437,2)
360
3^
361
"KRN",.403,121,40,2,40,437,"COMP MUL")
362
D COMPSTK^MSCZJOB
363
"KRN",.403,121,40,3,0)
364
3^^4,4^^^1^15,70
365
"KRN",.403,121,40,3,1)
366
Page 3
367
"KRN",.403,121,40,3,40,0)
368
^.4032IP^436^1
369
"KRN",.403,121,40,3,40,436,0)
370
MSCZJOBLOCKS^1^2,3^e
371
"KRN",.403,121,40,3,40,436,2)
372
6^
373
"KRN",.403,121,40,3,40,436,"COMP MUL")
374
D COMPLKS^MSCZJOB
375
"KRN",.403,121,21400)
376
1
377
"KRN",.403,122,-1)
378
0^2
379
"KRN",.403,122,0)
380
MSCZLOCK^ ^@^^3070530.1755^^^3.081^0^1^1
381
"KRN",.403,122,40,0)
382
^.4031I^1^1
383
"KRN",.403,122,40,1,0)
384
1^^1,1^^^0^17,80
385
"KRN",.403,122,40,1,1)
386
Page 1
387
"KRN",.403,122,40,1,40,0)
388
^.4032IP^439^2
389
"KRN",.403,122,40,1,40,438,0)
390
MSCZLOCKEXAM^4^3,2^e
391
"KRN",.403,122,40,1,40,438,2)
392
13^^u^^1
393
"KRN",.403,122,40,1,40,438,"COMP MUL")
394
D COMPLK^MSCZJOB
395
"KRN",.403,122,40,1,40,439,0)
396
MSCZJOBLOCK HDR^1^1,1^d
397
"KRN",.404,432,0)
398
MSCZJOBEXAM^3.081
399
"KRN",.404,432,40,0)
400
^.4044I^5^5
401
"KRN",.404,432,40,1,0)
402
1^^2^^JOB NUMBER
403
"KRN",.404,432,40,1,2)
404
1,2^6
405
"KRN",.404,432,40,1,3)
406
!M
407
"KRN",.404,432,40,1,3.1)
408
S Y=$$JOB^MSCZJOB(D0) S:Y=$J Y=Y_"*"
409
"KRN",.404,432,40,1,4)
410
^^^2
411
"KRN",.404,432,40,1,10)
412
S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U)
413
"KRN",.404,432,40,1,20)
414
F
415
"KRN",.404,432,40,2,0)
416
2^^2^^DEVICE
417
"KRN",.404,432,40,2,2)
418
1,9^23
419
"KRN",.404,432,40,2,3)
420
!M
421
"KRN",.404,432,40,2,3.1)
422
S Y=$$DEV^MSCZJOB(D0)
423
"KRN",.404,432,40,2,4)
424
^^^1
425
"KRN",.404,432,40,2,20)
426
F
427
"KRN",.404,432,40,3,0)
428
4^^2^^NAMESPACE
429
"KRN",.404,432,40,3,2)
430
1,48^11
431
"KRN",.404,432,40,3,3)
432
!M
433
"KRN",.404,432,40,3,3.1)
434
S Y=$$NSP^MSCZJOB(D0)
435
"KRN",.404,432,40,3,4)
436
^^^1
437
"KRN",.404,432,40,3,20)
438
F
439
"KRN",.404,432,40,4,0)
440
5^^2^^ROUTINE
441
"KRN",.404,432,40,4,2)
442
1,60^18
443
"KRN",.404,432,40,4,3)
444
!M
445
"KRN",.404,432,40,4,3.1)
446
S Y=$$ROUTINE^MSCZJOB(D0)
447
"KRN",.404,432,40,4,4)
448
^^^1
449
"KRN",.404,432,40,4,20)
450
F^U
451
"KRN",.404,432,40,5,0)
452
3^^2^^USER
453
"KRN",.404,432,40,5,2)
454
1,33^14
455
"KRN",.404,432,40,5,3)
456
!M
457
"KRN",.404,432,40,5,3.1)
458
S Y=$$USER^MSCZJOB(D0)
459
"KRN",.404,432,40,5,4)
460
^^^1
461
"KRN",.404,432,40,5,20)
462
F
463
"KRN",.404,433,0)
464
MSCZJOBEXAM HDR^3.081^
465
"KRN",.404,433,40,0)
466
^.4044I^2^2
467
"KRN",.404,433,40,1,0)
468
1^Process Device User Namespace Routine ^1
469
"KRN",.404,433,40,1,2)
470
^^2,1
471
"KRN",.404,433,40,2,0)
472
2^!M^1
473
"KRN",.404,433,40,2,.1)
474
S Y=$$GET1^DIQ(8989.3,1,.01)
475
"KRN",.404,433,40,2,2)
476
^^1,28
477
"KRN",.404,434,0)
478
MSCZJOBEXAM 2^3.081
479
"KRN",.404,434,40,0)
480
^.4044I^7^7
481
"KRN",.404,434,40,1,0)
482
1^Job^2^^JOB NUMBER
483
"KRN",.404,434,40,1,2)
484
2,8^6^2,3
485
"KRN",.404,434,40,1,3)
486
!M
487
"KRN",.404,434,40,1,3.1)
488
S Y=$$JOB^MSCZJOB(MSCJOBD0)
489
"KRN",.404,434,40,1,20)
490
N
491
"KRN",.404,434,40,2,0)
492
2^NSpace^2^^NAMESPACE
493
"KRN",.404,434,40,2,2)
494
2,24^11^2,16
495
"KRN",.404,434,40,2,3)
496
!M
497
"KRN",.404,434,40,2,3.1)
498
S Y=$$NSP^MSCZJOB(MSCJOBD0)
499
"KRN",.404,434,40,2,4)
500
^^^2
501
"KRN",.404,434,40,2,20)
502
F
503
"KRN",.404,434,40,3,0)
504
3^Routine^2
505
"KRN",.404,434,40,3,2)
506
2,46^16^2,37
507
"KRN",.404,434,40,3,3)
508
!M
509
"KRN",.404,434,40,3,3.1)
510
S Y=$$ROUTINE^MSCZJOB(MSCJOBD0)
511
"KRN",.404,434,40,3,4)
512
^^^2
513
"KRN",.404,434,40,3,20)
514
F^U
515
"KRN",.404,434,40,4,0)
516
4^^2^^USER
517
"KRN",.404,434,40,4,2)
518
2,63^14
519
"KRN",.404,434,40,4,3)
520
!M
521
"KRN",.404,434,40,4,3.1)
522
S Y=$$USER^MSCZJOB(MSCJOBD0)
523
"KRN",.404,434,40,4,4)
524
^^^2
525
"KRN",.404,434,40,4,20)
526
F
527
"KRN",.404,434,40,5,0)
528
5^Device^2^^DEVICE
529
"KRN",.404,434,40,5,2)
530
3,24^38^3,16
531
"KRN",.404,434,40,5,3)
532
!M
533
"KRN",.404,434,40,5,3.1)
534
S Y=$$DEV^MSCZJOB(MSCJOBD0)
535
"KRN",.404,434,40,5,4)
536
^^^1
537
"KRN",.404,434,40,5,20)
538
F^U
539
"KRN",.404,434,40,6,0)
540
4.4^LOCKs^2^^LOCKS
541
"KRN",.404,434,40,6,2)
542
3,10^3^3,3
543
"KRN",.404,434,40,6,3)
544
!M
545
"KRN",.404,434,40,6,3.1)
546
S Y=$$LOCKS^MSCZJOB
547
"KRN",.404,434,40,6,10)
548
S DDSSTACK=3
549
"KRN",.404,434,40,6,20)
550
N
551
"KRN",.404,434,40,7,0)
552
6^KILL JOB?^2^^KILL
553
"KRN",.404,434,40,7,2)
554
3,74^3^3,63
555
"KRN",.404,434,40,7,13)
556
N X,Y I DDSEXT="YES" D KILL^MSCZJOB(MSCJOBID)
557
"KRN",.404,434,40,7,20)
558
Y
559
"KRN",.404,435,0)
560
MSCZJOBVARS^3.081
561
"KRN",.404,435,40,0)
562
^.4044I^3^3
563
"KRN",.404,435,40,1,0)
564
1^^2^^VARIABLE NAME
565
"KRN",.404,435,40,1,2)
566
1,1^24
567
"KRN",.404,435,40,1,3)
568
!M
569
"KRN",.404,435,40,1,3.1)
570
S Y=$P(@MSC@(MSCJOBID,"V",D0),"=")
571
"KRN",.404,435,40,1,4)
572
^^^2
573
"KRN",.404,435,40,1,20)
574
F
575
"KRN",.404,435,40,2,0)
576
2^^2^^VALUE OF VARIABLE
577
"KRN",.404,435,40,2,2)
578
1,28^48
579
"KRN",.404,435,40,2,3)
580
!M
581
"KRN",.404,435,40,2,3.1)
582
S Y=$P(@MSC@(MSCJOBID,"V",D0),"=",2,999)
583
"KRN",.404,435,40,2,4)
584
^^^2
585
"KRN",.404,435,40,2,20)
586
F^U
587
"KRN",.404,435,40,3,0)
588
1.5^=^1
589
"KRN",.404,435,40,3,2)
590
^^1,26
591
"KRN",.404,436,0)
592
MSCZJOBLOCKS^3.081^
593
"KRN",.404,436,40,0)
594
^.4044I^2^2
595
"KRN",.404,436,40,1,0)
596
1^^2^^LOCKS
597
"KRN",.404,436,40,1,2)
598
2,1^47
599
"KRN",.404,436,40,1,3)
600
!M
601
"KRN",.404,436,40,1,3.1)
602
S Y=@MSC@(MSCJOBID,"L",D0)
603
"KRN",.404,436,40,1,4)
604
^^^2
605
"KRN",.404,436,40,1,20)
606
F^U
607
"KRN",.404,436,40,2,0)
608
2^UNLOCK?^2^^UNLOCK
609
"KRN",.404,436,40,2,2)
610
2,58^3^2,49^1
611
"KRN",.404,436,40,2,13)
612
I DDSEXT="YES" D UNLOCK^MSCZJOB(D0)
613
"KRN",.404,436,40,2,20)
614
Y
615
"KRN",.404,437,0)
616
MSCZJOBSTACK^3.081
617
"KRN",.404,437,40,0)
618
^.4044I^1^1
619
"KRN",.404,437,40,1,0)
620
1^^2^^STACK
621
"KRN",.404,437,40,1,2)
622
2,1^75
623
"KRN",.404,437,40,1,3)
624
!M
625
"KRN",.404,437,40,1,3.1)
626
S Y=$$STACK^MSCZJOB(D0)
627
"KRN",.404,437,40,1,4)
628
^^^2
629
"KRN",.404,437,40,1,20)
630
F^U
631
"KRN",.404,438,0)
632
MSCZLOCKEXAM^3.081
633
"KRN",.404,438,40,0)
634
^.4044I^5^5
635
"KRN",.404,438,40,1,0)
636
1^^2^^JOB NUMBER
637
"KRN",.404,438,40,1,2)
638
1,2^6
639
"KRN",.404,438,40,1,3)
640
!M
641
"KRN",.404,438,40,1,3.1)
642
S Y=$P($G(MSCZLK(D0)),U,5) S:Y=$J Y=Y_"*"
643
"KRN",.404,438,40,1,4)
644
^^^2
645
"KRN",.404,438,40,1,10)
646
S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U)
647
"KRN",.404,438,40,1,20)
648
F
649
"KRN",.404,438,40,2,0)
650
2^^2^^LOCK
651
"KRN",.404,438,40,2,2)
652
1,9^23
653
"KRN",.404,438,40,2,3)
654
!M
655
"KRN",.404,438,40,2,3.1)
656
S Y=$TR($P($G(MSCZLK(D0)),U),"~")
657
"KRN",.404,438,40,2,4)
658
^^^1
659
"KRN",.404,438,40,2,20)
660
F
661
"KRN",.404,438,40,3,0)
662
4^^2^^ROUTINE
663
"KRN",.404,438,40,3,2)
664
1,48^25
665
"KRN",.404,438,40,3,3)
666
!M
667
"KRN",.404,438,40,3,3.1)
668
S Y=$TR($P($G(MSCZLK(D0)),U,3),$C(126),U)
669
"KRN",.404,438,40,3,4)
670
^^^1
671
"KRN",.404,438,40,3,20)
672
F^U
673
"KRN",.404,438,40,4,0)
674
5^^2^^UNLOCK
675
"KRN",.404,438,40,4,2)
676
1,76^3
677
"KRN",.404,438,40,4,3)
678
!M
679
"KRN",.404,438,40,4,4)
680
^^^0
681
"KRN",.404,438,40,4,13)
682
I DDSEXT="YES" D UNL^MSCZJOB(D0)
683
"KRN",.404,438,40,4,20)
684
Y^U
685
"KRN",.404,438,40,5,0)
686
3^^2^^USER
687
"KRN",.404,438,40,5,2)
688
1,33^14
689
"KRN",.404,438,40,5,3)
690
!M
691
"KRN",.404,438,40,5,3.1)
692
S Y=$P($G(MSCZLK(D0)),U,2)
693
"KRN",.404,438,40,5,4)
694
^^^1
695
"KRN",.404,438,40,5,20)
696
F
697
"KRN",.404,439,0)
698
MSCZJOBLOCK HDR^3.081
699
"KRN",.404,439,40,0)
700
^.4044I^2^2
701
"KRN",.404,439,40,1,0)
702
1^Process Lock User Routine Unlock^1
703
"KRN",.404,439,40,1,2)
704
^^2,1
705
"KRN",.404,439,40,2,0)
706
2^!M^1
707
"KRN",.404,439,40,2,.1)
708
S Y=$$GET1^DIQ(8989.3,1,.01)
709
"KRN",.404,439,40,2,2)
710
^^1,28
711
"KRN",19,14339,-1)
712
0^1
713
"KRN",19,14339,0)
714
MSCZJOB^JOB EXAMINE^^R^^^^^^^^
715
"KRN",19,14339,1,0)
716
^^1^1^3070623^
717
"KRN",19,14339,1,1,0)
718
DESIGNED FOR GT.M
719
"KRN",19,14339,25)
720
MSCZJOB
721
"KRN",19,14339,"U")
722
JOB EXAMINE
723
"KRN",19,14340,-1)
724
0^2
725
"KRN",19,14340,0)
726
MSCZLOCK^LOCK EXAMINE^^R^^^^^^^^
727
"KRN",19,14340,1,0)
728
^^1^1^3070623^
729
"KRN",19,14340,1,1,0)
730
DESIGNED FOR GT.M
731
"KRN",19,14340,25)
732
LOCK^MSCZJOB
733
"KRN",19,14340,"U")
734
LOCK EXAMINE
735
"MBREQ")
736
0
737
"ORD",0,9.8)
738
9.8;;1;RTNF^XPDTA;RTNE^XPDTA
739
"ORD",0,9.8,0)
740
ROUTINE
741
"ORD",8,.403)
742
.403;8;;;EDEOUT^DIFROMSO(.403,DA,"",XPDA);FPRE^DIFROMSI(.403,"",XPDA);EPRE^DIFROMSI(.403,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.403,DA,"",XPDA);DEL^DIFROMSK(.403,"",%)
743
"ORD",8,.403,0)
744
FORM
745
"ORD",18,19)
746
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
747
"ORD",18,19,0)
748
OPTION
749
"PRE")
750
MSCGUX53
751
"QUES","XPF1",0)
752
Y
753
"QUES","XPF1","??")
754
^D REP^XPDH
755
"QUES","XPF1","A")
756
Shall I write over your |FLAG| File
757
"QUES","XPF1","B")
758
YES
759
"QUES","XPF1","M")
760
D XPF1^XPDIQ
761
"QUES","XPF2",0)
762
Y
763
"QUES","XPF2","??")
764
^D DTA^XPDH
765
"QUES","XPF2","A")
766
Want my data |FLAG| yours
767
"QUES","XPF2","B")
768
YES
769
"QUES","XPF2","M")
770
D XPF2^XPDIQ
771
"QUES","XPI1",0)
772
YO
773
"QUES","XPI1","??")
774
^D INHIBIT^XPDH
775
"QUES","XPI1","A")
776
Want KIDS to INHIBIT LOGONs during the install
777
"QUES","XPI1","B")
778
NO
779
"QUES","XPI1","M")
780
D XPI1^XPDIQ
781
"QUES","XPM1",0)
782
PO^VA(200,:EM
783
"QUES","XPM1","??")
784
^D MG^XPDH
785
"QUES","XPM1","A")
786
Enter the Coordinator for Mail Group '|FLAG|'
787
"QUES","XPM1","B")
788
789
"QUES","XPM1","M")
790
D XPM1^XPDIQ
791
"QUES","XPO1",0)
792
Y
793
"QUES","XPO1","??")
794
^D MENU^XPDH
795
"QUES","XPO1","A")
796
Want KIDS to Rebuild Menu Trees Upon Completion of Install
797
"QUES","XPO1","B")
798
NO
799
"QUES","XPO1","M")
800
D XPO1^XPDIQ
801
"QUES","XPZ1",0)
802
Y
803
"QUES","XPZ1","??")
804
^D OPT^XPDH
805
"QUES","XPZ1","A")
806
Want to DISABLE Scheduled Options, Menu Options, and Protocols
807
"QUES","XPZ1","B")
808
NO
809
"QUES","XPZ1","M")
810
D XPZ1^XPDIQ
811
"QUES","XPZ2",0)
812
Y
813
"QUES","XPZ2","??")
814
^D RTN^XPDH
815
"QUES","XPZ2","A")
816
Want to MOVE routines to other CPUs
817
"QUES","XPZ2","B")
818
NO
819
"QUES","XPZ2","M")
820
D XPZ2^XPDIQ
821
"RTN")
822
48
823
"RTN","DGMSTAPI")
824
0^34^B48539163
825
"RTN","DGMSTAPI",1,0)
826
DGMSTAPI ;ALB/SCK,MSC/JDA - API's for Military Sexual Trauma ;29APR2009
827
"RTN","DGMSTAPI",2,0)
828
;;5.3;Registration;**195,243,308,353,379,443,700,JDA**;Aug 13, 1993
829
"RTN","DGMSTAPI",3,0)
830
Q
831
"RTN","DGMSTAPI",4,0)
832
;
833
"RTN","DGMSTAPI",5,0)
834
GETSTAT(DFN,DGDATE) ; Retrieves the current MST status for a patient
835
"RTN","DGMSTAPI",6,0)
836
;
837
"RTN","DGMSTAPI",7,0)
838
; Input
839
"RTN","DGMSTAPI",8,0)
840
; DFN - IEN of patient in the PATIENT File (#2)
841
"RTN","DGMSTAPI",9,0)
842
; DGDATE - Date for status lookup [OPTIONAL]
843
"RTN","DGMSTAPI",10,0)
844
;
845
"RTN","DGMSTAPI",11,0)
846
; Output
847
"RTN","DGMSTAPI",12,0)
848
; DGMST - Format will depend on result of lookup
849
"RTN","DGMSTAPI",13,0)
850
;
851
"RTN","DGMSTAPI",14,0)
852
; If an entry is found then:
853
"RTN","DGMSTAPI",15,0)
854
; DGMST returns a 7 piece data string, caret(^)-delimited:
855
"RTN","DGMSTAPI",16,0)
856
; $P(1) = IEN of entry in MST HISTORY File (#29.11)
857
"RTN","DGMSTAPI",17,0)
858
; $P(2) = Internal value of MST Status ("Y,N,D,U")
859
"RTN","DGMSTAPI",18,0)
860
; $P(3) = Date of status change
861
"RTN","DGMSTAPI",19,0)
862
; $P(4) = IEN of provider making determination, file (#200)
863
"RTN","DGMSTAPI",20,0)
864
; $P(5) = IEN of user who entered status, file (#200)
865
"RTN","DGMSTAPI",21,0)
866
; $P(6) = External format of MST Status
867
"RTN","DGMSTAPI",22,0)
868
; $P(7) = IEN pointer of the INSTITUTION file (#4)
869
"RTN","DGMSTAPI",23,0)
870
;
871
"RTN","DGMSTAPI",24,0)
872
; If no MST History is found, then:
873
"RTN","DGMSTAPI",25,0)
874
; DGMST = 0^U
875
"RTN","DGMSTAPI",26,0)
876
; "U" = (Unknown)
877
"RTN","DGMSTAPI",27,0)
878
; If an error occured in the GETS^DIQ lookup, then:
879
"RTN","DGMSTAPI",28,0)
880
; DGMST = -1^^Error Code IEN
881
"RTN","DGMSTAPI",29,0)
882
; (returned by GETS^DIQ call)
883
"RTN","DGMSTAPI",30,0)
884
;
885
"RTN","DGMSTAPI",31,0)
886
; Get most recent MST status entry for the patient from file using
887
"RTN","DGMSTAPI",32,0)
888
; reverse $Order on the "APDT" x-ref.
889
"RTN","DGMSTAPI",33,0)
890
;
891
"RTN","DGMSTAPI",34,0)
892
N DGMST,DGIEN,DGFDA,DGMSG
893
"RTN","DGMSTAPI",35,0)
894
S DFN=$G(DFN)
895
"RTN","DGMSTAPI",36,0)
896
I '+DFN!('$D(^DPT(DFN,0))) D G STATQ
897
"RTN","DGMSTAPI",37,0)
898
. S DGMST="-1"
899
"RTN","DGMSTAPI",38,0)
900
I '$D(^DGMS(29.11,"APDT",DFN)) D G STATQ
901
"RTN","DGMSTAPI",39,0)
902
.S DGMST="0^U"
903
"RTN","DGMSTAPI",40,0)
904
S DGDATE=$S(+$G(DGDATE)>0:DGDATE,1:$$NOW^XLFDT)
905
"RTN","DGMSTAPI",41,0)
906
I '$D(^DGMS(29.11,"APDT",DFN,DGDATE)) S DGDATE=$$DATE(DFN,DGDATE)
907
"RTN","DGMSTAPI",42,0)
908
I '+DGDATE D G STATQ
909
"RTN","DGMSTAPI",43,0)
910
. S DGMST="0^U"
911
"RTN","DGMSTAPI",44,0)
912
S DGIEN=""
913
"RTN","DGMSTAPI",45,0)
914
S DGIEN=+$O(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1)
915
"RTN","DGMSTAPI",46,0)
916
;
917
"RTN","DGMSTAPI",47,0)
918
; Check for valid ien, if entry missing, return Unknown
919
"RTN","DGMSTAPI",48,0)
920
I +DGIEN'>0 D G STATQ
921
"RTN","DGMSTAPI",49,0)
922
. S DGMST="0^U"
923
"RTN","DGMSTAPI",50,0)
924
;
925
"RTN","DGMSTAPI",51,0)
926
; Retrieve data
927
"RTN","DGMSTAPI",52,0)
928
D GETS^DIQ(29.11,+DGIEN_",","*","IE","DGFDA","DGMSG")
929
"RTN","DGMSTAPI",53,0)
930
; check for errors
931
"RTN","DGMSTAPI",54,0)
932
I $D(DGMSG) D G STATQ
933
"RTN","DGMSTAPI",55,0)
934
.S DGMST="-1^^"_$G(DGMSG("DIERR",1))
935
"RTN","DGMSTAPI",56,0)
936
;
937
"RTN","DGMSTAPI",57,0)
938
S DGMST=DGIEN_U_$G(DGFDA(29.11,+DGIEN_",",3,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",.01,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",4,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",5,"I"))
939
"RTN","DGMSTAPI",58,0)
940
S DGMST=DGMST_U_$G(DGFDA(29.11,+DGIEN_",",3,"E"))
941
"RTN","DGMSTAPI",59,0)
942
S DGMST=DGMST_U_$S($G(DGFDA(29.11,+DGIEN_",",6,"I"))]"":$G(DGFDA(29.11,+DGIEN_",",6,"I")),1:$$SITE)
943
"RTN","DGMSTAPI",60,0)
944
;
945
"RTN","DGMSTAPI",61,0)
946
STATQ Q $G(DGMST)
947
"RTN","DGMSTAPI",62,0)
948
;
949
"RTN","DGMSTAPI",63,0)
950
NEWSTAT(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGXMIT) ; MST HISTORY (#29.11) filer
951
"RTN","DGMSTAPI",64,0)
952
; Callpoint to create a new MST HISTORY FILE (#29.11) entry.
953
"RTN","DGMSTAPI",65,0)
954
; Will also queue HL7 message for HEC database updates.
955
"RTN","DGMSTAPI",66,0)
956
;
957
"RTN","DGMSTAPI",67,0)
958
; Input
959
"RTN","DGMSTAPI",68,0)
960
; DFN - Patients DFN
961
"RTN","DGMSTAPI",69,0)
962
; DGSTAT - MST Status code, "Y,N,D,U"
963
"RTN","DGMSTAPI",70,0)
964
; DGDATE - Date of MST status change [default=NOW]
965
"RTN","DGMSTAPI",71,0)
966
; DGPROV - IEN of Provider making determination, file (#200)
967
"RTN","DGMSTAPI",72,0)
968
; DGSITE - IEN pointer of the INSTITUTION file (#4)
969
"RTN","DGMSTAPI",73,0)
970
; DGXMIT - HL7 transmit flag [OPTIONAL]
971
"RTN","DGMSTAPI",74,0)
972
; 0=don't queue a message
973
"RTN","DGMSTAPI",75,0)
974
; 1=queue a message [default])
975
"RTN","DGMSTAPI",76,0)
976
;
977
"RTN","DGMSTAPI",77,0)
978
; Output
979
"RTN","DGMSTAPI",78,0)
980
; DGRSLT - Returns IEN of file (#29.11) entry if successful
981
"RTN","DGMSTAPI",79,0)
982
;
983
"RTN","DGMSTAPI",80,0)
984
; If no patient was defined, then:
985
"RTN","DGMSTAPI",81,0)
986
; DGRSLT = -1^No patient defined
987
"RTN","DGMSTAPI",82,0)
988
;
989
"RTN","DGMSTAPI",83,0)
990
; If an error occured in the GETS^DIQ lookup, then:
991
"RTN","DGMSTAPI",84,0)
992
; DGMST = -1^^Error Code IEN
993
"RTN","DGMSTAPI",85,0)
994
; (returned by GETS^DIQ call)
995
"RTN","DGMSTAPI",86,0)
996
;
997
"RTN","DGMSTAPI",87,0)
998
N DGFDA,DGMSG,DGERR,DGRSLT,MSTIEN
999
"RTN","DGMSTAPI",88,0)
1000
S DFN=$G(DFN)
1001
"RTN","DGMSTAPI",89,0)
1002
I DFN']""!('$D(^DPT(DFN,0))) D G NEWQ
1003
"RTN","DGMSTAPI",90,0)
1004
. S DGRSLT="-1^No patient defined"
1005
"RTN","DGMSTAPI",91,0)
1006
;
1007
"RTN","DGMSTAPI",92,0)
1008
S DGSTAT=$S($G(DGSTAT)]"":DGSTAT,1:"U")
1009
"RTN","DGMSTAPI",93,0)
1010
S DGDATE=$G(DGDATE)
1011
"RTN","DGMSTAPI",94,0)
1012
S DGPROV=$G(DGPROV)
1013
"RTN","DGMSTAPI",95,0)
1014
S DGSITE=$G(DGSITE)
1015
"RTN","DGMSTAPI",96,0)
1016
S DGXMIT=$S($G(DGXMIT)=0:DGXMIT,1:1)
1017
"RTN","DGMSTAPI",97,0)
1018
S DGDATE=$S(+DGDATE>0:DGDATE,1:$$NOW^XLFDT)
1019
"RTN","DGMSTAPI",98,0)
1020
S DGSITE=$S(+DGSITE>0:DGSITE,1:$$SITE)
1021
"RTN","DGMSTAPI",99,0)
1022
;
1023
"RTN","DGMSTAPI",100,0)
1024
I '$$CHANGE(DFN,DGSTAT,DGDATE) D G NEWQ
1025
"RTN","DGMSTAPI",101,0)
1026
. S DGRSLT="0"
1027
"RTN","DGMSTAPI",102,0)
1028
;
1029
"RTN","DGMSTAPI",103,0)
1030
I '$$VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,.DGERR) D G NEWQ
1031
"RTN","DGMSTAPI",104,0)
1032
. S DGRSLT="-1^"_DGERR
1033
"RTN","DGMSTAPI",105,0)
1034
;
1035
"RTN","DGMSTAPI",106,0)
1036
S DGFDA(1,29.11,"+1,",.01)=DGDATE
1037
"RTN","DGMSTAPI",107,0)
1038
S DGFDA(1,29.11,"+1,",2)=DFN
1039
"RTN","DGMSTAPI",108,0)
1040
S DGFDA(1,29.11,"+1,",3)=DGSTAT
1041
"RTN","DGMSTAPI",109,0)
1042
S DGFDA(1,29.11,"+1,",4)=DGPROV
1043
"RTN","DGMSTAPI",110,0)
1044
S DGFDA(1,29.11,"+1,",5)=DUZ
1045
"RTN","DGMSTAPI",111,0)
1046
S DGFDA(1,29.11,"+1,",6)=DGSITE
1047
"RTN","DGMSTAPI",112,0)
1048
;
1049
"RTN","DGMSTAPI",113,0)
1050
D UPDATE^DIE("","DGFDA(1)","MSTIEN","DGERR")
1051
"RTN","DGMSTAPI",114,0)
1052
I $D(DGERR) D G NEWQ
1053
"RTN","DGMSTAPI",115,0)
1054
. S DGRSLT="-1^"_$G(DGERR("DIERR",1))
1055
"RTN","DGMSTAPI",116,0)
1056
;
1057
"RTN","DGMSTAPI",117,0)
1058
S DGRSLT=+MSTIEN(1)
1059
"RTN","DGMSTAPI",118,0)
1060
;
1061
"RTN","DGMSTAPI",119,0)
1062
; Callpoint to queue an entry that will trigger a HEC
1063
"RTN","DGMSTAPI",120,0)
1064
; Enrollment Full Data Transmission (ORF/ORU~ZO7) HL7 message.
1065
"RTN","DGMSTAPI",121,0)
1066
; The HL7 message will contain the following three MST data elments
1067
"RTN","DGMSTAPI",122,0)
1068
; as part of the VA-Specific Eligibility ZEL segment:
1069
"RTN","DGMSTAPI",123,0)
1070
; (23) - MST STATUS
1071
"RTN","DGMSTAPI",124,0)
1072
; (24) - DATE MST STATUS CHANGED
1073
"RTN","DGMSTAPI",125,0)
1074
; (25) - SITE DETERMINING MST STATUS
1075
"RTN","DGMSTAPI",126,0)
1076
;
1077
"RTN","DGMSTAPI",127,0)
1078
I DGXMIT D
1079
"RTN","DGMSTAPI",128,0)
1080
. D SEND^DGMSTL1(DFN,"Z07")
1081
"RTN","DGMSTAPI",129,0)
1082
;
1083
"RTN","DGMSTAPI",130,0)
1084
NEWQ Q $G(DGRSLT)
1085
"RTN","DGMSTAPI",131,0)
1086
;
1087
"RTN","DGMSTAPI",132,0)
1088
DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in.
1089
"RTN","DGMSTAPI",133,0)
1090
; This call is not to be used except from inside the DG MST List
1091
"RTN","DGMSTAPI",134,0)
1092
; Manager interface.
1093
"RTN","DGMSTAPI",135,0)
1094
;
1095
"RTN","DGMSTAPI",136,0)
1096
; Input
1097
"RTN","DGMSTAPI",137,0)
1098
; MSTIEN - IEN of the entry in the MST HISTORY File (#29.11)
1099
"RTN","DGMSTAPI",138,0)
1100
;
1101
"RTN","DGMSTAPI",139,0)
1102
; Output
1103
"RTN","DGMSTAPI",140,0)
1104
; If no IEN passed in, return -1
1105
"RTN","DGMSTAPI",141,0)
1106
; otherwise return 1
1107
"RTN","DGMSTAPI",142,0)
1108
;
1109
"RTN","DGMSTAPI",143,0)
1110
Q:'$G(MSTIEN) "-1^No entry to delete"
1111
"RTN","DGMSTAPI",144,0)
1112
;
1113
"RTN","DGMSTAPI",145,0)
1114
N DA,XD
1115
"RTN","DGMSTAPI",146,0)
1116
S DA=+$G(MSTIEN)
1117
"RTN","DGMSTAPI",147,0)
1118
S DIK="^DGMS(29.11,"
1119
"RTN","DGMSTAPI",148,0)
1120
D ^DIK K DIK
1121
"RTN","DGMSTAPI",149,0)
1122
Q 1
1123
"RTN","DGMSTAPI",150,0)
1124
;
1125
"RTN","DGMSTAPI",151,0)
1126
NAME(DA) ; Returns name from the VA NEW PERSON File using DIQ call
1127
"RTN","DGMSTAPI",152,0)
1128
;
1129
"RTN","DGMSTAPI",153,0)
1130
N DGNAME,DGPROV,DIQ,DR,DIC
1131
"RTN","DGMSTAPI",154,0)
1132
I $G(DA)="" G NAMEQ
1133
"RTN","DGMSTAPI",155,0)
1134
S DIC=200,DR=".01",DIQ="DGPROV"
1135
"RTN","DGMSTAPI",156,0)
1136
D EN^DIQ1
1137
"RTN","DGMSTAPI",157,0)
1138
S DGNAME=$G(DGPROV(200,DA,.01))
1139
"RTN","DGMSTAPI",158,0)
1140
NAMEQ Q $G(DGNAME)
1141
"RTN","DGMSTAPI",159,0)
1142
;
1143
"RTN","DGMSTAPI",160,0)
1144
CHANGE(DFN,DGSTAT,DGDATE) ;Did the Status OR Date change?
1145
"RTN","DGMSTAPI",161,0)
1146
; Input
1147
"RTN","DGMSTAPI",162,0)
1148
; DFN - Patients DFN
1149
"RTN","DGMSTAPI",163,0)
1150
; DGSTAT - MST Status code, "Y,N,D,U"
1151
"RTN","DGMSTAPI",164,0)
1152
; DGDATE - Date of MST Status Change (FM format)
1153
"RTN","DGMSTAPI",165,0)
1154
;
1155
"RTN","DGMSTAPI",166,0)
1156
; Output
1157
"RTN","DGMSTAPI",167,0)
1158
; Returns 0 if no status change
1159
"RTN","DGMSTAPI",168,0)
1160
; 1 if status changed
1161
"RTN","DGMSTAPI",169,0)
1162
;
1163
"RTN","DGMSTAPI",170,0)
1164
N DGCHG,DGMST
1165
"RTN","DGMSTAPI",171,0)
1166
S DGCHG=0
1167
"RTN","DGMSTAPI",172,0)
1168
I +$G(DFN)'>0!('$D(^DPT(DFN,0))) G CHNGQ
1169
"RTN","DGMSTAPI",173,0)
1170
S DGSTAT=$G(DGSTAT)
1171
"RTN","DGMSTAPI",174,0)
1172
I DGSTAT'?1A!("YNDU"'[DGSTAT) G CHNGQ
1173
"RTN","DGMSTAPI",175,0)
1174
S DGDATE=$G(DGDATE)
1175
"RTN","DGMSTAPI",176,0)
1176
I DGDATE="" G CHNGQ
1177
"RTN","DGMSTAPI",177,0)
1178
S DGMST=$$GETSTAT(DFN),DGMST=$G(DGMST)
1179
"RTN","DGMSTAPI",178,0)
1180
I +DGMST<1!($P(DGMST,U,2)'=$G(DGSTAT))!($P(DGMST,U,3)'=$G(DGDATE)) S DGCHG=1
1181
"RTN","DGMSTAPI",179,0)
1182
CHNGQ Q DGCHG
1183
"RTN","DGMSTAPI",180,0)
1184
;
1185
"RTN","DGMSTAPI",181,0)
1186
SITE(DGSITE) ;Convert a station number into a pointer to the
1187
"RTN","DGMSTAPI",182,0)
1188
; INSTITUTION file (#4). If called with a null parameter then
1189
"RTN","DGMSTAPI",183,0)
1190
; the pointer to the INSTITUTION file (#4) of the primary site
1191
"RTN","DGMSTAPI",184,0)
1192
; will be returned.
1193
"RTN","DGMSTAPI",185,0)
1194
;
1195
"RTN","DGMSTAPI",186,0)
1196
; Input
1197
"RTN","DGMSTAPI",187,0)
1198
; DGSITE - Station number (optional)
1199
"RTN","DGMSTAPI",188,0)
1200
;
1201
"RTN","DGMSTAPI",189,0)
1202
; Output
1203
"RTN","DGMSTAPI",190,0)
1204
; Return Site IEN to INSTITUTION file (#4)
1205
"RTN","DGMSTAPI",191,0)
1206
;
1207
"RTN","DGMSTAPI",192,0)
1208
S DGSITE=$G(DGSITE)
1209
"RTN","DGMSTAPI",193,0)
1210
I DGSITE]"",$D(^DIC(4,"D",DGSITE)) D
1211
"RTN","DGMSTAPI",194,0)
1212
. S DGSITE=$O(^DIC(4,"D",DGSITE,0))
1213
"RTN","DGMSTAPI",195,0)
1214
E D
1215
"RTN","DGMSTAPI",196,0)
1216
. S DGSITE=$P($$SITE^VASITE,U)
1217
"RTN","DGMSTAPI",197,0)
1218
I +DGSITE'>0 S DGSITE=""
1219
"RTN","DGMSTAPI",198,0)
1220
Q DGSITE
1221
"RTN","DGMSTAPI",199,0)
1222
;
1223
"RTN","DGMSTAPI",200,0)
1224
DATE(DFN,DGDT) ;Determine 'current' MST date
1225
"RTN","DGMSTAPI",201,0)
1226
;
1227
"RTN","DGMSTAPI",202,0)
1228
; Input
1229
"RTN","DGMSTAPI",203,0)
1230
; DFN - Patient's DFN
1231
"RTN","DGMSTAPI",204,0)
1232
; DGDT - FileMan format date
1233
"RTN","DGMSTAPI",205,0)
1234
;
1235
"RTN","DGMSTAPI",206,0)
1236
; Output
1237
"RTN","DGMSTAPI",207,0)
1238
; Return MST effective date
1239
"RTN","DGMSTAPI",208,0)
1240
;
1241
"RTN","DGMSTAPI",209,0)
1242
N DGMSTDT
1243
"RTN","DGMSTAPI",210,0)
1244
S DFN=$G(DFN)
1245
"RTN","DGMSTAPI",211,0)
1246
I '+DFN D G DATEQ
1247
"RTN","DGMSTAPI",212,0)
1248
. S DGMSTDT=""
1249
"RTN","DGMSTAPI",213,0)
1250
S DGDT=$S(+$G(DGDT)>0:DGDT,1:$$NOW^XLFDT)
1251
"RTN","DGMSTAPI",214,0)
1252
I $P(DGDT,".",2)="" S DGDT=DGDT_".999999"
1253
"RTN","DGMSTAPI",215,0)
1254
S DGMSTDT=$O(^DGMS(29.11,"APDT",DFN,DGDT),-1)
1255
"RTN","DGMSTAPI",216,0)
1256
DATEQ Q DGMSTDT
1257
"RTN","DGMSTAPI",217,0)
1258
;
1259
"RTN","DGMSTAPI",218,0)
1260
VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGERR) ;Validate fields before filing
1261
"RTN","DGMSTAPI",219,0)
1262
; Input:
1263
"RTN","DGMSTAPI",220,0)
1264
; DFN - [REQUIRED] - ien of Patient
1265
"RTN","DGMSTAPI",221,0)
1266
; DGSTAT - [REQUIRED] - MST Status code, "Y,N,D,U"
1267
"RTN","DGMSTAPI",222,0)
1268
; DGDATE - [REQUIRED] - Date of MST status change[FileMan Internal]
1269
"RTN","DGMSTAPI",223,0)
1270
; DGPROV - [optional] - IEN of Provider making determination
1271
"RTN","DGMSTAPI",224,0)
1272
; DGSITE - [optional] - IEN pointer of the INSTITUTION file
1273
"RTN","DGMSTAPI",225,0)
1274
; DGERR - [optional] - error parameter passed by reference
1275
"RTN","DGMSTAPI",226,0)
1276
; Output:
1277
"RTN","DGMSTAPI",227,0)
1278
; Function Value - Returns 1 - if validation checks passed
1279
"RTN","DGMSTAPI",228,0)
1280
; 0 - if validation checks failed
1281
"RTN","DGMSTAPI",229,0)
1282
; DGERR - an error message if validation checks fail
1283
"RTN","DGMSTAPI",230,0)
1284
; init variables
1285
"RTN","DGMSTAPI",231,0)
1286
N I,DGFILE,DGFLD,DGMSG,DGSTR,DGVAL,DGVAR,DGX,VALID
1287
"RTN","DGMSTAPI",232,0)
1288
S DGFILE=29.11,VALID=1,DGMSG=" IS REQUIRED"
1289
"RTN","DGMSTAPI",233,0)
1290
; Quit DO block if invalid condition found
1291
"RTN","DGMSTAPI",234,0)
1292
; Check for [REQUIRED] fields
1293
"RTN","DGMSTAPI",235,0)
1294
D
1295
"RTN","DGMSTAPI",236,0)
1296
. I DFN="" D MSG(DGFILE,2,DGMSG,.DGERR) Q ;pat ien
1297
"RTN","DGMSTAPI",237,0)
1298
. I DGSTAT="" D MSG(DGFILE,3,DGMSG,.DGERR) Q ;mst status code
1299
"RTN","DGMSTAPI",238,0)
1300
. I DGDATE="" D MSG(DGFILE,.01,DGMSG,.DGERR) Q ;dt chg status
1301
"RTN","DGMSTAPI",239,0)
1302
.;
1303
"RTN","DGMSTAPI",240,0)
1304
.; Check for valid FIELD values
1305
"RTN","DGMSTAPI",241,0)
1306
. S DGMSG=" IS NOT VALID"
1307
"RTN","DGMSTAPI",242,0)
1308
.; need to strip off the 'seconds' to pass the CHK^DIE() call...
1309
"RTN","DGMSTAPI",243,0)
1310
. I DGDATE["." N DGSECS S DGSECS=$E($P(DGDATE,".",2),5,6) I DGSECS'="" I DGSECS<0!(DGSECS>60) D MSG(DGFILE,.01,DGMSG,.DGERR) Q
1311
"RTN","DGMSTAPI",244,0)
1312
. N DGDATEX S DGDATEX=DGDATE
1313
"RTN","DGMSTAPI",245,0)
1314
. I DGDATEX["." S DGDATEX=$P(DGDATEX,".")_"."_$E($P(DGDATEX,".",2),1,4)
1315
"RTN","DGMSTAPI",246,0)
1316
. I $E($P(DGDATEX,".",2),1,4)="0000" S DGDATEX=$P(DGDATEX,".")_".1"
1317
"RTN","DGMSTAPI",247,0)
1318
. S DGSTR=".01;DGDATEX^2;DFN^3;DGSTAT^4;DGPROV^5;DUZ^6;DGSITE"
1319
"RTN","DGMSTAPI",248,0)
1320
.;
1321
"RTN","DGMSTAPI",249,0)
1322
. F I=1:1:$L(DGSTR,U) S DGX=$P(DGSTR,U,I) Q:DGX="" D Q:'VALID
1323
"RTN","DGMSTAPI",250,0)
1324
.. S DGFLD=$P(DGX,";"),DGVAR=$P(DGX,";",2),DGVAL=@DGVAR
1325
"RTN","DGMSTAPI",251,0)
1326
.. Q:DGVAL=""
1327
"RTN","DGMSTAPI",252,0)
1328
.. S VALID=$$TESTVAL(DGFILE,DGFLD,DGVAL)
1329
"RTN","DGMSTAPI",253,0)
1330
.. D:'VALID MSG(DGFILE,DGFLD,DGMSG,.DGERR)
1331
"RTN","DGMSTAPI",254,0)
1332
Q VALID
1333
"RTN","DGMSTAPI",255,0)
1334
;
1335
"RTN","DGMSTAPI",256,0)
1336
MSG(DGFIL,DGFLD,DGMSG,DGERR) ; error message setup
1337
"RTN","DGMSTAPI",257,0)
1338
; Input:
1339
"RTN","DGMSTAPI",258,0)
1340
; DGFIL - file number
1341
"RTN","DGMSTAPI",259,0)
1342
; DGFLD - field number of file
1343
"RTN","DGMSTAPI",260,0)
1344
; DGMSG - message type verbiage - " IS REQUIRED" or " IS NOT VALID"
1345
"RTN","DGMSTAPI",261,0)
1346
; DGERR - error parameter passed by reference
1347
"RTN","DGMSTAPI",262,0)
1348
; Output:
1349
"RTN","DGMSTAPI",263,0)
1350
; DGERR - error message
1351
"RTN","DGMSTAPI",264,0)
1352
S DGERR=$$GET1^DID(DGFIL,DGFLD,,"LABEL")_DGMSG
1353
"RTN","DGMSTAPI",265,0)
1354
Q
1355
"RTN","DGMSTAPI",266,0)
1356
;
1357
"RTN","DGMSTAPI",267,0)
1358
TESTVAL(DGFIL,DGFLD,DGVAL) ; Determine if a field value is valid.
1359
"RTN","DGMSTAPI",268,0)
1360
; Input:
1361
"RTN","DGMSTAPI",269,0)
1362
; DGFIL - file number
1363
"RTN","DGMSTAPI",270,0)
1364
; DGFLD - field number of file
1365
"RTN","DGMSTAPI",271,0)
1366
; DGVAL - field value to be validated
1367
"RTN","DGMSTAPI",272,0)
1368
; Output:
1369
"RTN","DGMSTAPI",273,0)
1370
; Function value: Returns 1 if field is valid
1371
"RTN","DGMSTAPI",274,0)
1372
; 0 if validation fails
1373
"RTN","DGMSTAPI",275,0)
1374
N DGVALEX,DGRSLT,VALID
1375
"RTN","DGMSTAPI",276,0)
1376
S VALID=1
1377
"RTN","DGMSTAPI",277,0)
1378
I DGVAL'="" D
1379
"RTN","DGMSTAPI",278,0)
1380
. S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
1381
"RTN","DGMSTAPI",279,0)
1382
. I DGVALEX="" S VALID=0 Q ; no external value, not valid
1383
"RTN","DGMSTAPI",280,0)
1384
. I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'="POINTER" D
1385
"RTN","DGMSTAPI",281,0)
1386
.. D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0
1387
"RTN","DGMSTAPI",282,0)
1388
Q VALID
1389
"RTN","GMRCA2")
1390
0^35^B10634
1391
"RTN","GMRCA2",1,0)
1392
GMRCA2 ;SLC/KCM,DLT,MSC/JDA - Select prompt for processing actions ;27APR2009
1393
"RTN","GMRCA2",2,0)
1394
;;3.0;CONSULT/REQUEST TRACKING;**1,4,MSC**;DEC 27, 1997
1395
"RTN","GMRCA2",3,0)
1396
SELECT(GMRCO) ; Select the consult to process
1397
"RTN","GMRCA2",4,0)
1398
;This utility checks the GMRCO variable against the selection list
1399
"RTN","GMRCA2",5,0)
1400
; Input variable used:
1401
"RTN","GMRCA2",6,0)
1402
; BLK, LNCT, GMRCO
1403
"RTN","GMRCA2",7,0)
1404
; GMRC("NMBR")
1405
"RTN","GMRCA2",8,0)
1406
; Output variables returned:
1407
"RTN","GMRCA2",9,0)
1408
; GMRCQUT=1 if no consult was selected
1409
"RTN","GMRCA2",10,0)
1410
; GMRCQUT is not defined on return when selection made
1411
"RTN","GMRCA2",11,0)
1412
; GMRCO= consult selected from list
1413
"RTN","GMRCA2",12,0)
1414
START
1415
"RTN","GMRCA2",13,0)
1416
K GMRCQUT,GMRCSEL
1417
"RTN","GMRCA2",14,0)
1418
N GMRCAGN
1419
"RTN","GMRCA2",15,0)
1420
I '$L($G(GMRCO)) D Q:$D(GMRCQUT) G:$D(GMRCAGN) START
1421
"RTN","GMRCA2",16,0)
1422
.;use the highlighted number if defined
1423
"RTN","GMRCA2",17,0)
1424
.I $D(GMRC("NMBR")) S GMRCSEL=GMRC("NMBR")
1425
"RTN","GMRCA2",18,0)
1426
.I '$D(GMRCSEL),$D(LNCT),LNCT=1 S GMRCSEL=LNCT
1427
"RTN","GMRCA2",19,0)
1428
.I $S('+$G(GMRCSEL):1,+GMRCSEL<1:1,+GMRCSEL>BLK:1,GMRCSEL="":1,1:0) K GMRCSEL D:+$G(GMRC("NMBR")) AGAIN^GMRCSLMV(GMRC("NMBR")) K GMRC("NMBR")
1429
"RTN","GMRCA2",20,0)
1430
.I '+$G(GMRCSEL) D SEL I $S($D(DTOUT):1,$D(DIROUT):1,$D(GMRCQUT):1,'+GMRCSEL:1,1:0) K GMRCSEL S GMRCQUT=1 Q
1431
"RTN","GMRCA2",21,0)
1432
.I $S(+GMRCSEL<1:1,GMRCSEL>BLK:1,1:0) W !,"Select a consult listed in the number range 1 to "_BLK S GMRCAGN=1 Q
1433
"RTN","GMRCA2",22,0)
1434
.S GMRCO=$O(^TMP("GMRCR",$J,"CS","AD",GMRCSEL,GMRCSEL,0))
1435
"RTN","GMRCA2",23,0)
1436
.I '+GMRCO D
1437
"RTN","GMRCA2",24,0)
1438
.. S GMRCQUT=1
1439
"RTN","GMRCA2",25,0)
1440
.. W !,$C(7),"Select a consult by entering its listed number between 1 and "_LNCT_"."
1441
"RTN","GMRCA2",26,0)
1442
.. K GMRCO,GMRCSEL
1443
"RTN","GMRCA2",27,0)
1444
. Q
1445
"RTN","GMRCA2",28,0)
1446
Q
1447
"RTN","GMRCA2",29,0)
1448
;
1449
"RTN","GMRCA2",30,0)
1450
SEL ;Select order number(s) exit: GMRCSEL
1451
"RTN","GMRCA2",31,0)
1452
I $D(GMRC("NMBR")) S GMRCSEL=GMRC("NMBR") Q
1453
"RTN","GMRCA2",32,0)
1454
I '$D(^TMP("GMRCR",$J,"CS","AD")) W !,"No orders to select.",! S GMRCQUT=1,GMRCSEL="" Q
1455
"RTN","GMRCA2",33,0)
1456
I '$O(^TMP("GMRCR",$J,"CS","AD")),BLK=1 S GMRCSEL=BLK Q
1457
"RTN","GMRCA2",34,0)
1458
S GMRCSEL="" W !,"CHOOSE No. 1-",BLK,": " R X:DTIME S:X="^^" DIROUT=1 I '$T!(X["^") S (DTOUT,GMRCQUT)=1 Q
1459
"RTN","GMRCA2",35,0)
1460
I X["?" D SELHELP G SEL
1461
"RTN","GMRCA2",36,0)
1462
I X="" S GMRCQUT=1 Q
1463
"RTN","GMRCA2",37,0)
1464
I X'?.3N W $C(7)," ?? Enter the number from the far left of the list." G SEL
1465
"RTN","GMRCA2",38,0)
1466
I $S(X>BLK:1,X<1:1,1:0) D SELHELP G SEL
1467
"RTN","GMRCA2",39,0)
1468
S GMRCSEL=X
1469
"RTN","GMRCA2",40,0)
1470
Q
1471
"RTN","GMRCA2",41,0)
1472
SELHELP ;Help to select a valid entry
1473
"RTN","GMRCA2",42,0)
1474
W !,"Select a request by typing the number from the left column and pressing <ENTER>.",!
1475
"RTN","GMRCA2",43,0)
1476
Q
1477
"RTN","GMRCA2",44,0)
1478
UP ;Convert lower to upper case entry: X exit: X
1479
"RTN","GMRCA2",45,0)
1480
F %=1:1:$L(X) I $E(X,%)?1L S X=$E(X,1,%-1)_$C($A(X,%)-32)_$E(X,%+1,99)
1481
"RTN","GMRCA2",46,0)
1482
Q
1483
"RTN","HLCSLNCH")
1484
0^18^B37119958
1485
"RTN","HLCSLNCH",1,0)
1486
HLCSLNCH ;ALB/MTC/JC MSC/JDA - START AND STOP THE LLP ;31JUL2009
1487
"RTN","HLCSLNCH",2,0)
1488
;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,MSC**;Oct 13, 1995
1489
"RTN","HLCSLNCH",3,0)
1490
;
1491
"RTN","HLCSLNCH",4,0)
1492
;This program is callable from a menu
1493
"RTN","HLCSLNCH",5,0)
1494
;It allows the user to Start and Stop the Lower Layer
1495
"RTN","HLCSLNCH",6,0)
1496
;Protocol in the Background or in the foreground
1497
"RTN","HLCSLNCH",7,0)
1498
;
1499
"RTN","HLCSLNCH",8,0)
1500
;Required or Optional INPUT PARAMETERS
1501
"RTN","HLCSLNCH",9,0)
1502
; None
1503
"RTN","HLCSLNCH",10,0)
1504
;
1505
"RTN","HLCSLNCH",11,0)
1506
;
1507
"RTN","HLCSLNCH",12,0)
1508
;Output variables
1509
"RTN","HLCSLNCH",13,0)
1510
; HLDP=IEN of Logical Link in file #870
1511
"RTN","HLCSLNCH",14,0)
1512
;(optional)HLTRACE=if SET it launches the LLP in the Foreground
1513
"RTN","HLCSLNCH",15,0)
1514
;(optional) ZTSK=if defined LLP was launched in the
1515
"RTN","HLCSLNCH",16,0)
1516
;background
1517
"RTN","HLCSLNCH",17,0)
1518
;
1519
"RTN","HLCSLNCH",18,0)
1520
;
1521
"RTN","HLCSLNCH",19,0)
1522
START ; Start up the lower level protocol
1523
"RTN","HLCSLNCH",20,0)
1524
N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE
1525
"RTN","HLCSLNCH",21,0)
1526
N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC
1527
"RTN","HLCSLNCH",22,0)
1528
W !!,"This option is used to launch the lower level protocol for the"
1529
"RTN","HLCSLNCH",23,0)
1530
W !,"appropriate device. Please select the node with which you want"
1531
"RTN","HLCSLNCH",24,0)
1532
W !,"to communicate",!
1533
"RTN","HLCSLNCH",25,0)
1534
S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ
1535
"RTN","HLCSLNCH",26,0)
1536
S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0)
1537
"RTN","HLCSLNCH",27,0)
1538
;-- check if parameter have been setup
1539
"RTN","HLCSLNCH",28,0)
1540
;-- check for LLP type
1541
"RTN","HLCSLNCH",29,0)
1542
I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
1543
"RTN","HLCSLNCH",30,0)
1544
;-- get TCP information
1545
"RTN","HLCSLNCH",31,0)
1546
S HLPARM4=$G(^HLCS(870,HLDP,400))
1547
"RTN","HLCSLNCH",32,0)
1548
;-- get routine (background job for LLP)
1549
"RTN","HLCSLNCH",33,0)
1550
S HLBGR=$G(^HLCS(869.1,HLTYPTR,100))
1551
"RTN","HLCSLNCH",34,0)
1552
;-- get environment check routine (HLQUIT should be defined in fails)
1553
"RTN","HLCSLNCH",35,0)
1554
S HLENV=$G(^HLCS(869.1,HLTYPTR,200))
1555
"RTN","HLCSLNCH",36,0)
1556
;
1557
"RTN","HLCSLNCH",37,0)
1558
I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ
1559
"RTN","HLCSLNCH",38,0)
1560
;
1561
"RTN","HLCSLNCH",39,0)
1562
;-- execute environment check routine if HLQUIT is defined then terminate
1563
"RTN","HLCSLNCH",40,0)
1564
I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ
1565
"RTN","HLCSLNCH",41,0)
1566
;Multi-Servers, only enable the link if not OpenM
1567
"RTN","HLCSLNCH",42,0)
1568
I $P(HLPARM4,U,3)="M",$$NOTMULTI D G STARTQ
1569
"RTN","HLCSLNCH",43,0)
1570
. W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP."
1571
"RTN","HLCSLNCH",44,0)
1572
. Q
1573
"RTN","HLCSLNCH",45,0)
1574
;
1575
"RTN","HLCSLNCH",46,0)
1576
I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error"
1577
"RTN","HLCSLNCH",47,0)
1578
I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"."
1579
"RTN","HLCSLNCH",48,0)
1580
I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
1581
"RTN","HLCSLNCH",49,0)
1582
I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D G STARTQ
1583
"RTN","HLCSLNCH",50,0)
1584
. W !,$C(7),"NOTE: The lower level protocol for this application is already running."
1585
"RTN","HLCSLNCH",51,0)
1586
I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D G STARTQ
1587
"RTN","HLCSLNCH",52,0)
1588
.;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
1589
"RTN","HLCSLNCH",53,0)
1590
.;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
1591
"RTN","HLCSLNCH",54,0)
1592
.N HLJ,X
1593
"RTN","HLCSLNCH",55,0)
1594
.I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
1595
"RTN","HLCSLNCH",56,0)
1596
.L +^HLCS(870,HLDP,0):2
1597
"RTN","HLCSLNCH",57,0)
1598
.E W !,$C(7),"Unable to enable this LLP !" Q
1599
"RTN","HLCSLNCH",58,0)
1600
.S X="HLJ(870,"""_HLDP_","")"
1601
"RTN","HLCSLNCH",59,0)
1602
.S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
1603
"RTN","HLCSLNCH",60,0)
1604
.D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109
1605
"RTN","HLCSLNCH",61,0)
1606
.L -^HLCS(870,HLDP,0)
1607
"RTN","HLCSLNCH",62,0)
1608
.W !,"This LLP has been enabled!"
1609
"RTN","HLCSLNCH",63,0)
1610
.Q
1611
"RTN","HLCSLNCH",64,0)
1612
I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",!
1613
"RTN","HLCSLNCH",65,0)
1614
;
1615
"RTN","HLCSLNCH",66,0)
1616
W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT"
1617
"RTN","HLCSLNCH",67,0)
1618
S DIR("A")="Method for running the receiver"
1619
"RTN","HLCSLNCH",68,0)
1620
S DIR("B")="B"
1621
"RTN","HLCSLNCH",69,0)
1622
S DIR("?",1)="Enter F for Foreground (and trace)"
1623
"RTN","HLCSLNCH",70,0)
1624
S DIR("?",2)=" B for Background (normal) or"
1625
"RTN","HLCSLNCH",71,0)
1626
S DIR("?")=" Q to quit without starting the receiver"
1627
"RTN","HLCSLNCH",72,0)
1628
D ^DIR K DIR
1629
"RTN","HLCSLNCH",73,0)
1630
Q:(Y=U)!(Y="Q")
1631
"RTN","HLCSLNCH",74,0)
1632
;
1633
"RTN","HLCSLNCH",75,0)
1634
S HLX=$G(^HLCS(870,HLDP,0))
1635
"RTN","HLCSLNCH",76,0)
1636
;-- foreground
1637
"RTN","HLCSLNCH",77,0)
1638
I Y="F" S HLTRACE=1 D G STARTQ
1639
"RTN","HLCSLNCH",78,0)
1640
. X HLBGR
1641
"RTN","HLCSLNCH",79,0)
1642
;-- background
1643
"RTN","HLCSLNCH",80,0)
1644
I Y="B" D G STARTQ
1645
"RTN","HLCSLNCH",81,0)
1646
. S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H
1647
"RTN","HLCSLNCH",82,0)
1648
. S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
1649
"RTN","HLCSLNCH",83,0)
1650
. D ^%ZTLOAD
1651
"RTN","HLCSLNCH",84,0)
1652
. W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.")
1653
"RTN","HLCSLNCH",85,0)
1654
;
1655
"RTN","HLCSLNCH",86,0)
1656
Q
1657
"RTN","HLCSLNCH",87,0)
1658
;
1659
"RTN","HLCSLNCH",88,0)
1660
;
1661
"RTN","HLCSLNCH",89,0)
1662
STARTQ ;
1663
"RTN","HLCSLNCH",90,0)
1664
I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running."
1665
"RTN","HLCSLNCH",91,0)
1666
Q
1667
"RTN","HLCSLNCH",92,0)
1668
;
1669
"RTN","HLCSLNCH",93,0)
1670
STOP ; Shut down a lower level protocol..
1671
"RTN","HLCSLNCH",94,0)
1672
N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y
1673
"RTN","HLCSLNCH",95,0)
1674
W !!,"This option is used to shut down the lower level protocol for the"
1675
"RTN","HLCSLNCH",96,0)
1676
W !,"appropriate device. Please select the link which you would"
1677
"RTN","HLCSLNCH",97,0)
1678
W !,"like to shutdown.",!
1679
"RTN","HLCSLNCH",98,0)
1680
S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0
1681
"RTN","HLCSLNCH",99,0)
1682
S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400))
1683
"RTN","HLCSLNCH",100,0)
1684
I $P(HLPARM4,U,3)="M",$$NOTMULTI D Q
1685
"RTN","HLCSLNCH",101,0)
1686
. W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP."
1687
"RTN","HLCSLNCH",102,0)
1688
. Q
1689
"RTN","HLCSLNCH",103,0)
1690
;
1691
"RTN","HLCSLNCH",104,0)
1692
I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q
1693
"RTN","HLCSLNCH",105,0)
1694
I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"."
1695
"RTN","HLCSLNCH",106,0)
1696
STP1 ;
1697
"RTN","HLCSLNCH",107,0)
1698
W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR
1699
"RTN","HLCSLNCH",108,0)
1700
I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q
1701
"RTN","HLCSLNCH",109,0)
1702
S ;
1703
"RTN","HLCSLNCH",110,0)
1704
F L +^HLCS(870,HLDP,0):2 Q:$T
1705
"RTN","HLCSLNCH",111,0)
1706
;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown
1707
"RTN","HLCSLNCH",112,0)
1708
S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
1709
"RTN","HLCSLNCH",113,0)
1710
I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown"
1711
"RTN","HLCSLNCH",114,0)
1712
D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109
1713
"RTN","HLCSLNCH",115,0)
1714
S $ETRAP=""
1715
"RTN","HLCSLNCH",116,0)
1716
I ($P(HLPARM4,U,3)="M"&'$$NOTMULTI())!($P(HLPARM4,U,3)="S") D
1717
"RTN","HLCSLNCH",117,0)
1718
. ;pass task number to stop listener
1719
"RTN","HLCSLNCH",118,0)
1720
. S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
1721
"RTN","HLCSLNCH",119,0)
1722
. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
1723
"RTN","HLCSLNCH",120,0)
1724
. I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
1725
"RTN","HLCSLNCH",121,0)
1726
. U IO W "**STOP**"
1727
"RTN","HLCSLNCH",122,0)
1728
. W !
1729
"RTN","HLCSLNCH",123,0)
1730
. D CLOSE^%ZISTCP
1731
"RTN","HLCSLNCH",124,0)
1732
L -^HLCS(870,HLDP,0)
1733
"RTN","HLCSLNCH",125,0)
1734
W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
1735
"RTN","HLCSLNCH",126,0)
1736
Q
1737
"RTN","HLCSLNCH",127,0)
1738
;
1739
"RTN","HLCSLNCH",128,0)
1740
NOTMULTI() ; Returns 1 if implementation can't run multithreaded listener
1741
"RTN","HLCSLNCH",129,0)
1742
Q:^%ZOSF("OS")["GT.M" 0
1743
"RTN","HLCSLNCH",130,0)
1744
Q $S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS")
1745
"RTN","HLCSLNCH",131,0)
1746
STOPQ Q
1747
"RTN","HLCSTCP")
1748
0^17^B32647785
1749
"RTN","HLCSTCP",1,0)
1750
HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE MSC/JDS - (TCP/IP) MLLP ;25NOV2009
1751
"RTN","HLCSTCP",2,0)
1752
;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,MSC**;Oct 13, 1995
1753
"RTN","HLCSTCP",3,0)
1754
;
1755
"RTN","HLCSTCP",4,0)
1756
; This is an implementation of the HL7 Minimal Lower Layer Protocol
1757
"RTN","HLCSTCP",5,0)
1758
;
1759
"RTN","HLCSTCP",6,0)
1760
;taskman entry/startup option, HLDP defined in menu entry,
1761
"RTN","HLCSTCP",7,0)
1762
Q:'$D(HLDP)
1763
"RTN","HLCSTCP",8,0)
1764
N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
1765
"RTN","HLCSTCP",9,0)
1766
;HLCSOUT= 1-error
1767
"RTN","HLCSTCP",10,0)
1768
I '$$INIT D EXITS("Init Error") Q
1769
"RTN","HLCSTCP",11,0)
1770
; Start the client
1771
"RTN","HLCSTCP",12,0)
1772
I $G(HLTCPCS)="C" D Q
1773
"RTN","HLCSTCP",13,0)
1774
. ; identify process for ^%SY
1775
"RTN","HLCSTCP",14,0)
1776
. D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
1777
"RTN","HLCSTCP",15,0)
1778
. D ST1
1779
"RTN","HLCSTCP",16,0)
1780
. F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
1781
"RTN","HLCSTCP",17,0)
1782
. I $G(HLCSOUT)=1 D MON("Error") H 1 Q
1783
"RTN","HLCSTCP",18,0)
1784
. I $G(HLCSOUT)=2 D EXITS("Inactive") Q
1785
"RTN","HLCSTCP",19,0)
1786
. D EXITS("Shutdown")
1787
"RTN","HLCSTCP",20,0)
1788
;
1789
"RTN","HLCSTCP",21,0)
1790
; identify process for ^%SY
1791
"RTN","HLCSTCP",22,0)
1792
D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
1793
"RTN","HLCSTCP",23,0)
1794
;HLCSFAIL=1 port failed to open
1795
"RTN","HLCSTCP",24,0)
1796
S HLCSFAIL=1
1797
"RTN","HLCSTCP",25,0)
1798
;single threaded listener
1799
"RTN","HLCSTCP",26,0)
1800
I $G(HLTCPCS)="S" D Q
1801
"RTN","HLCSTCP",27,0)
1802
. D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")")
1803
"RTN","HLCSTCP",28,0)
1804
. ;couldn't open listener port
1805
"RTN","HLCSTCP",29,0)
1806
. I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
1807
"RTN","HLCSTCP",30,0)
1808
. I HLCSFAIL D EXITS("Openfail") Q
1809
"RTN","HLCSTCP",31,0)
1810
;
1811
"RTN","HLCSTCP",32,0)
1812
;multi-threaded listener (OpenM or GT.M)
1813
"RTN","HLCSTCP",33,0)
1814
I $G(HLTCPCS)="M",(^%ZOSF("OS")["OpenM")!(^%ZOSF("OS")["GT.M") D Q
1815
"RTN","HLCSTCP",34,0)
1816
. D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")")
1817
"RTN","HLCSTCP",35,0)
1818
Q
1819
"RTN","HLCSTCP",36,0)
1820
;
1821
"RTN","HLCSTCP",37,0)
1822
SERVER(HLDP) ; single server using Taskman
1823
"RTN","HLCSTCP",38,0)
1824
S HLCSFAIL=0
1825
"RTN","HLCSTCP",39,0)
1826
I '$$INIT D EXITS("Init error") Q
1827
"RTN","HLCSTCP",40,0)
1828
D ^HLCSTCP1
1829
"RTN","HLCSTCP",41,0)
1830
I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
1831
"RTN","HLCSTCP",42,0)
1832
Q:$G(HLCSOUT)=1
1833
"RTN","HLCSTCP",43,0)
1834
D MON("Idle")
1835
"RTN","HLCSTCP",44,0)
1836
Q
1837
"RTN","HLCSTCP",45,0)
1838
;
1839
"RTN","HLCSTCP",46,0)
1840
SERVERS(HLDP) ; Multi-threaded server using Taskman
1841
"RTN","HLCSTCP",47,0)
1842
I '$$INIT D EXITS("Init error") Q
1843
"RTN","HLCSTCP",48,0)
1844
G LISTEN
1845
"RTN","HLCSTCP",49,0)
1846
;
1847
"RTN","HLCSTCP",50,0)
1848
;multiple process servers, called from an external utility
1849
"RTN","HLCSTCP",51,0)
1850
MSM ;MSM entry point, called from User-Defined Services
1851
"RTN","HLCSTCP",52,0)
1852
;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
1853
"RTN","HLCSTCP",53,0)
1854
;HL7 Multi-Threaded SERVER
1855
"RTN","HLCSTCP",54,0)
1856
S (IO,IO(0))=$P
1857
"RTN","HLCSTCP",55,0)
1858
G LISTEN
1859
"RTN","HLCSTCP",56,0)
1860
;
1861
"RTN","HLCSTCP",57,0)
1862
CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
1863
"RTN","HLCSTCP",58,0)
1864
;listener, % = HLDP
1865
"RTN","HLCSTCP",59,0)
1866
I $G(%)="" D ^%ZTER Q
1867
"RTN","HLCSTCP",60,0)
1868
S (IO,IO(0))="SYS$NET",HLDP=%
1869
"RTN","HLCSTCP",61,0)
1870
; **Cache'/VMS specific code**
1871
"RTN","HLCSTCP",62,0)
1872
O IO::5 E D MON("Openfail") Q
1873
"RTN","HLCSTCP",63,0)
1874
X "U IO:(::""-M"")" ;Packet mode like DSM
1875
"RTN","HLCSTCP",64,0)
1876
D LISTEN C IO Q
1877
"RTN","HLCSTCP",65,0)
1878
;
1879
"RTN","HLCSTCP",66,0)
1880
EN ;vms ucx entry point, called from HLSEVEN.COM file,
1881
"RTN","HLCSTCP",67,0)
1882
;listener, % = device^HLDP
1883
"RTN","HLCSTCP",68,0)
1884
I $G(%)="" D ^%ZTER Q
1885
"RTN","HLCSTCP",69,0)
1886
S (IO,IO(0))="SYS$NET",HLDP=$P(%,"^",2)
1887
"RTN","HLCSTCP",70,0)
1888
; **VMS specific code, need to share device**
1889
"RTN","HLCSTCP",71,0)
1890
X "O IO:(TCPDEV):60" E D MON("Openfail") Q
1891
"RTN","HLCSTCP",72,0)
1892
LISTEN ;
1893
"RTN","HLCSTCP",73,0)
1894
N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
1895
"RTN","HLCSTCP",74,0)
1896
I '$$INIT D ^%ZTER Q
1897
"RTN","HLCSTCP",75,0)
1898
; identify process for ^%SY
1899
"RTN","HLCSTCP",76,0)
1900
D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
1901
"RTN","HLCSTCP",77,0)
1902
;HLLSTN used to identify a listener to tag MON
1903
"RTN","HLCSTCP",78,0)
1904
S HLLSTN=1
1905
"RTN","HLCSTCP",79,0)
1906
;increment job count, run server
1907
"RTN","HLCSTCP",80,0)
1908
D UPDT(1),^HLCSTCP1,EXITM
1909
"RTN","HLCSTCP",81,0)
1910
Q
1911
"RTN","HLCSTCP",82,0)
1912
;
1913
"RTN","HLCSTCP",83,0)
1914
DCOPEN(HLDP) ;open direct connect - called from HLMA2
1915
"RTN","HLCSTCP",84,0)
1916
Q:'$$INIT 0
1917
"RTN","HLCSTCP",85,0)
1918
Q:HLTCPADD=""!(HLTCPORT="") 0
1919
"RTN","HLCSTCP",86,0)
1920
Q:'$$OPEN^HLCSTCP2 0
1921
"RTN","HLCSTCP",87,0)
1922
Q 1
1923
"RTN","HLCSTCP",88,0)
1924
;
1925
"RTN","HLCSTCP",89,0)
1926
INIT() ; Initialize Variables
1927
"RTN","HLCSTCP",90,0)
1928
; HLDP should be set to the IEN or name of Logical Link, file 870
1929
"RTN","HLCSTCP",91,0)
1930
S HLOS=$P($G(^%ZOSF("OS")),"^")
1931
"RTN","HLCSTCP",92,0)
1932
N DA,DIQUIET,DR,TMP,X,Y
1933
"RTN","HLCSTCP",93,0)
1934
S DIQUIET=1
1935
"RTN","HLCSTCP",94,0)
1936
D DT^DICRW
1937
"RTN","HLCSTCP",95,0)
1938
I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
1939
"RTN","HLCSTCP",96,0)
1940
S DA=HLDP
1941
"RTN","HLCSTCP",97,0)
1942
S DR="200.02;200.021;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05"
1943
"RTN","HLCSTCP",98,0)
1944
D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
1945
"RTN","HLCSTCP",99,0)
1946
;
1947
"RTN","HLCSTCP",100,0)
1948
I $D(TMP("DIERR")) QUIT 0
1949
"RTN","HLCSTCP",101,0)
1950
; -- re-transmit attempts
1951
"RTN","HLCSTCP",102,0)
1952
S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
1953
"RTN","HLCSTCP",103,0)
1954
; -- exceed re-transmit action
1955
"RTN","HLCSTCP",104,0)
1956
S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
1957
"RTN","HLCSTCP",105,0)
1958
; -- block size
1959
"RTN","HLCSTCP",106,0)
1960
S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
1961
"RTN","HLCSTCP",107,0)
1962
; -- read timeout
1963
"RTN","HLCSTCP",108,0)
1964
S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
1965
"RTN","HLCSTCP",109,0)
1966
; -- ack timeout
1967
"RTN","HLCSTCP",110,0)
1968
S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
1969
"RTN","HLCSTCP",111,0)
1970
; -- uni-directional wait
1971
"RTN","HLCSTCP",112,0)
1972
S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
1973
"RTN","HLCSTCP",113,0)
1974
; -- tcp address
1975
"RTN","HLCSTCP",114,0)
1976
S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
1977
"RTN","HLCSTCP",115,0)
1978
; -- tcp port
1979
"RTN","HLCSTCP",116,0)
1980
S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
1981
"RTN","HLCSTCP",117,0)
1982
; -- tcp/ip service type
1983
"RTN","HLCSTCP",118,0)
1984
S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
1985
"RTN","HLCSTCP",119,0)
1986
; -- link persistence
1987
"RTN","HLCSTCP",120,0)
1988
S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
1989
"RTN","HLCSTCP",121,0)
1990
; -- retention
1991
"RTN","HLCSTCP",122,0)
1992
S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
1993
"RTN","HLCSTCP",123,0)
1994
;
1995
"RTN","HLCSTCP",124,0)
1996
; -- set defaults in case something's not set
1997
"RTN","HLCSTCP",125,0)
1998
S:HLDREAD=0 HLDREAD=10
1999
"RTN","HLCSTCP",126,0)
2000
S:HLDBACK=0 HLDBACK=60
2001
"RTN","HLCSTCP",127,0)
2002
S:HLDBSIZE=0 HLDBSIZE=245
2003
"RTN","HLCSTCP",128,0)
2004
S:HLDRETR=0 HLDRETR=5
2005
"RTN","HLCSTCP",129,0)
2006
S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
2007
"RTN","HLCSTCP",130,0)
2008
;
2009
"RTN","HLCSTCP",131,0)
2010
Q 1
2011
"RTN","HLCSTCP",132,0)
2012
;
2013
"RTN","HLCSTCP",133,0)
2014
ST1 ;record startup in 870 for single server
2015
"RTN","HLCSTCP",134,0)
2016
;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
2017
"RTN","HLCSTCP",135,0)
2018
;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
2019
"RTN","HLCSTCP",136,0)
2020
N HLJ,X
2021
"RTN","HLCSTCP",137,0)
2022
F L +^HLCS(870,HLDP,0):2 Q:$T
2023
"RTN","HLCSTCP",138,0)
2024
S X="HLJ(870,"""_HLDP_","")"
2025
"RTN","HLCSTCP",139,0)
2026
S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
2027
"RTN","HLCSTCP",140,0)
2028
I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
2029
"RTN","HLCSTCP",141,0)
2030
E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
2031
"RTN","HLCSTCP",142,0)
2032
I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
2033
"RTN","HLCSTCP",143,0)
2034
S:$G(ZTSK) @X@(11)=ZTSK
2035
"RTN","HLCSTCP",144,0)
2036
D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
2037
"RTN","HLCSTCP",145,0)
2038
L -^HLCS(870,HLDP,0)
2039
"RTN","HLCSTCP",146,0)
2040
Q
2041
"RTN","HLCSTCP",147,0)
2042
;
2043
"RTN","HLCSTCP",148,0)
2044
MON(Y) ;Display current state & check for shutdown
2045
"RTN","HLCSTCP",149,0)
2046
;don't display for multiple server
2047
"RTN","HLCSTCP",150,0)
2048
Q:$G(HLLSTN)
2049
"RTN","HLCSTCP",151,0)
2050
F L +^HLCS(870,HLDP,0):2 Q:$T
2051
"RTN","HLCSTCP",152,0)
2052
S $P(^HLCS(870,HLDP,0),U,5)=Y
2053
"RTN","HLCSTCP",153,0)
2054
L -^HLCS(870,HLDP,0)
2055
"RTN","HLCSTCP",154,0)
2056
Q:'$D(HLTRACE)
2057
"RTN","HLCSTCP",155,0)
2058
N X U IO(0)
2059
"RTN","HLCSTCP",156,0)
2060
W !,"IN State: ",Y
2061
"RTN","HLCSTCP",157,0)
2062
I '$$STOP D
2063
"RTN","HLCSTCP",158,0)
2064
. R !,"Type Q to Quit: ",X#1:1
2065
"RTN","HLCSTCP",159,0)
2066
. I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
2067
"RTN","HLCSTCP",160,0)
2068
U IO
2069
"RTN","HLCSTCP",161,0)
2070
Q
2071
"RTN","HLCSTCP",162,0)
2072
UPDT(Y) ;update job count for multiple servers,X=1 increment
2073
"RTN","HLCSTCP",163,0)
2074
N HLJ,X
2075
"RTN","HLCSTCP",164,0)
2076
F L +^HLCS(870,HLDP,0):2 Q:$T
2077
"RTN","HLCSTCP",165,0)
2078
S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
2079
"RTN","HLCSTCP",166,0)
2080
;if incrementing, set the Device Type field to Multi-Server
2081
"RTN","HLCSTCP",167,0)
2082
I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109
2083
"RTN","HLCSTCP",168,0)
2084
L -^HLCS(870,HLDP,0)
2085
"RTN","HLCSTCP",169,0)
2086
Q
2087
"RTN","HLCSTCP",170,0)
2088
STOP() ;stop flag set
2089
"RTN","HLCSTCP",171,0)
2090
N X
2091
"RTN","HLCSTCP",172,0)
2092
F L +^HLCS(870,HLDP,0):2 Q:$T
2093
"RTN","HLCSTCP",173,0)
2094
S X=+$P(^HLCS(870,HLDP,0),U,15)
2095
"RTN","HLCSTCP",174,0)
2096
L -^HLCS(870,HLDP,0)
2097
"RTN","HLCSTCP",175,0)
2098
Q X
2099
"RTN","HLCSTCP",176,0)
2100
;
2101
"RTN","HLCSTCP",177,0)
2102
LLCNT(DP,Y,Z) ;update Logical Link counters
2103
"RTN","HLCSTCP",178,0)
2104
;DP=ien of Logical Link in file 870
2105
"RTN","HLCSTCP",179,0)
2106
;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
2107
"RTN","HLCSTCP",180,0)
2108
;Z: ""=add to counter, 1=subtract from counter
2109
"RTN","HLCSTCP",181,0)
2110
Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
2111
"RTN","HLCSTCP",182,0)
2112
N P,X
2113
"RTN","HLCSTCP",183,0)
2114
S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
2115
"RTN","HLCSTCP",184,0)
2116
F L +^HLCS(870,DP,P):2 Q:$T
2117
"RTN","HLCSTCP",185,0)
2118
S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
2119
"RTN","HLCSTCP",186,0)
2120
L -^HLCS(870,DP,P)
2121
"RTN","HLCSTCP",187,0)
2122
Q
2123
"RTN","HLCSTCP",188,0)
2124
SDFLD ; set Shutdown? field to yes
2125
"RTN","HLCSTCP",189,0)
2126
Q:'$G(HLDP)
2127
"RTN","HLCSTCP",190,0)
2128
N HLJ,X
2129
"RTN","HLCSTCP",191,0)
2130
F L +^HLCS(870,HLDP,0):2 Q:$T
2131
"RTN","HLCSTCP",192,0)
2132
;14=Shutdown LLP?
2133
"RTN","HLCSTCP",193,0)
2134
S HLJ(870,HLDP_",",14)=1
2135
"RTN","HLCSTCP",194,0)
2136
D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
2137
"RTN","HLCSTCP",195,0)
2138
L -^HLCS(870,HLDP,0)
2139
"RTN","HLCSTCP",196,0)
2140
Q
2141
"RTN","HLCSTCP",197,0)
2142
;
2143
"RTN","HLCSTCP",198,0)
2144
EXITS(Y) ; Single service shutdown and cleans up
2145
"RTN","HLCSTCP",199,0)
2146
N HLJ,X
2147
"RTN","HLCSTCP",200,0)
2148
F L +^HLCS(870,HLDP,0):2 Q:$T
2149
"RTN","HLCSTCP",201,0)
2150
;4=status,10=Time Stopped,9=Time Started,11=Task Number
2151
"RTN","HLCSTCP",202,0)
2152
S X="HLJ(870,"""_HLDP_","")"
2153
"RTN","HLCSTCP",203,0)
2154
S @X@(4)=Y,@X@(11)="@"
2155
"RTN","HLCSTCP",204,0)
2156
S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
2157
"RTN","HLCSTCP",205,0)
2158
D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
2159
"RTN","HLCSTCP",206,0)
2160
L -^HLCS(870,HLDP,0)
2161
"RTN","HLCSTCP",207,0)
2162
I $D(ZTQUEUED) S ZTREQ="@"
2163
"RTN","HLCSTCP",208,0)
2164
Q
2165
"RTN","HLCSTCP",209,0)
2166
;
2167
"RTN","HLCSTCP",210,0)
2168
EXITM ;Multiple service shutdown and clean up
2169
"RTN","HLCSTCP",211,0)
2170
D UPDT(0)
2171
"RTN","HLCSTCP",212,0)
2172
I $D(ZTQUEUED) S ZTREQ="@"
2173
"RTN","HLCSTCP",213,0)
2174
Q
2175
"RTN","HLCSTCP1")
2176
0^16^B34257905
2177
"RTN","HLCSTCP1",1,0)
2178
HLCSTCP1 ;SFIRMFO/RSD MSC/JDA,JKT,JDS - BI-DIRECTIONAL TCP ; 25 Mar 2010 10:12 AM
2179
"RTN","HLCSTCP1",2,0)
2180
;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,MSC**;JUL 17,1995
2181
"RTN","HLCSTCP1",3,0)
2182
;Receiver
2183
"RTN","HLCSTCP1",4,0)
2184
;connection is initiated by sender and listener accepts connection
2185
"RTN","HLCSTCP1",5,0)
2186
;and calls this routine
2187
"RTN","HLCSTCP1",6,0)
2188
;
2189
"RTN","HLCSTCP1",7,0)
2190
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
2191
"RTN","HLCSTCP1",8,0)
2192
I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP1"")" ;turn on error trapping on GT.M
2193
"RTN","HLCSTCP1",9,0)
2194
N HLMIEN,HLASTMSG
2195
"RTN","HLCSTCP1",10,0)
2196
D MON^HLCSTCP("Open")
2197
"RTN","HLCSTCP1",11,0)
2198
K ^TMP("HLCSTCP",$J,0)
2199
"RTN","HLCSTCP1",12,0)
2200
S HLMIEN=0,HLASTMSG=""
2201
"RTN","HLCSTCP1",13,0)
2202
F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3
2203
"RTN","HLCSTCP1",14,0)
2204
. S HLMIEN=$$READ
2205
"RTN","HLCSTCP1",15,0)
2206
. Q:'HLMIEN
2207
"RTN","HLCSTCP1",16,0)
2208
. D PROCESS
2209
"RTN","HLCSTCP1",17,0)
2210
Q
2211
"RTN","HLCSTCP1",18,0)
2212
;
2213
"RTN","HLCSTCP1",19,0)
2214
PROCESS ;check message and reply
2215
"RTN","HLCSTCP1",20,0)
2216
;HLDP=LL in 870, update monitor, received msg.
2217
"RTN","HLCSTCP1",21,0)
2218
N HLTCP,HLTCPI,HLTCPO
2219
"RTN","HLCSTCP1",22,0)
2220
S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
2221
"RTN","HLCSTCP1",23,0)
2222
;update monitor, msg. received
2223
"RTN","HLCSTCP1",24,0)
2224
D LLCNT^HLCSTCP(HLDP,1)
2225
"RTN","HLCSTCP1",25,0)
2226
D NEW^HLTP3(HLMIEN)
2227
"RTN","HLCSTCP1",26,0)
2228
;update monitor, msg. processed
2229
"RTN","HLCSTCP1",27,0)
2230
D LLCNT^HLCSTCP(HLDP,2)
2231
"RTN","HLCSTCP1",28,0)
2232
Q
2233
"RTN","HLCSTCP1",29,0)
2234
;
2235
"RTN","HLCSTCP1",30,0)
2236
READ() ;read 1 message, returns ien in 773^ien in 772 for message
2237
"RTN","HLCSTCP1",31,0)
2238
D MON^HLCSTCP("Reading")
2239
"RTN","HLCSTCP1",32,0)
2240
N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
2241
"RTN","HLCSTCP1",33,0)
2242
;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator
2243
"RTN","HLCSTCP1",34,0)
2244
S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
2245
"RTN","HLCSTCP1",35,0)
2246
;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
2247
"RTN","HLCSTCP1",36,0)
2248
;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack
2249
"RTN","HLCSTCP1",37,0)
2250
S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
2251
"RTN","HLCSTCP1",38,0)
2252
K ^TMP("HLCSTCP",$J,0)
2253
"RTN","HLCSTCP1",39,0)
2254
F D RDBLK Q:HLRDOUT
2255
"RTN","HLCSTCP1",40,0)
2256
;save any excess for next time
2257
"RTN","HLCSTCP1",41,0)
2258
S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX
2259
"RTN","HLCSTCP1",42,0)
2260
I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
2261
"RTN","HLCSTCP1",43,0)
2262
Q HLIND1
2263
"RTN","HLCSTCP1",44,0)
2264
;
2265
"RTN","HLCSTCP1",45,0)
2266
RDBLK S HLDB=HLDBSIZE-$L(HLX)
2267
"RTN","HLCSTCP1",46,0)
2268
U IO
2269
"RTN","HLCSTCP1",47,0)
2270
; set DELIMITER flag on GT.M to ensure we return from READ command as soon as we get a complete HL7 message
2271
"RTN","HLCSTCP1",48,0)
2272
I HLOS["GT.M" X "U IO:(DELIMITER=HLRS_HLDEND_HLRS)"
2273
"RTN","HLCSTCP1",49,0)
2274
N T R X#HLDB:HLDREAD S T=$T ;save $TEST for check below
2275
"RTN","HLCSTCP1",50,0)
2276
; $KEY=delimiter if READ terminated on delimiter; remove DELIMITER flag after READ so we don't affect writes
2277
"RTN","HLCSTCP1",51,0)
2278
I HLOS["GT.M" X "S X=X_$KEY U IO:(NODELIMITER)"
2279
"RTN","HLCSTCP1",52,0)
2280
; timedout or error, check ack timeout, clean up
2281
"RTN","HLCSTCP1",53,0)
2282
I 'T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
2283
"RTN","HLCSTCP1",54,0)
2284
;data stream: <sb>dddd<cr><eb><cr>
2285
"RTN","HLCSTCP1",55,0)
2286
;add incoming line to what wasn't processed in last read
2287
"RTN","HLCSTCP1",56,0)
2288
S HLX=$G(HLX)_X
2289
"RTN","HLCSTCP1",57,0)
2290
I (($E(HLX,HLDBSIZE)=HLDEND)!($E(HLX,HLDBSIZE+1)=HLDEND))&(HLX'[HLRS) S HLX=HLX_HLRS ;jds intermittent problem
2291
"RTN","HLCSTCP1",58,0)
2292
; look for segment= <CR>
2293
"RTN","HLCSTCP1",59,0)
2294
F Q:HLX'[HLRS D Q:HLRDOUT
2295
"RTN","HLCSTCP1",60,0)
2296
. ; Get the first piece, save the rest of the line
2297
"RTN","HLCSTCP1",61,0)
2298
. S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
2299
"RTN","HLCSTCP1",62,0)
2300
. ; check for start block, Quit if no ien
2301
"RTN","HLCSTCP1",63,0)
2302
. I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q
2303
"RTN","HLCSTCP1",64,0)
2304
.. D:HLMSG(HLINE,0)[HLDSTRT
2305
"RTN","HLCSTCP1",65,0)
2306
... S X=$L(HLMSG(HLINE,0),HLDSTRT)
2307
"RTN","HLCSTCP1",66,0)
2308
... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
2309
"RTN","HLCSTCP1",67,0)
2310
... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
2311
"RTN","HLCSTCP1",68,0)
2312
... D RESET:(HLINE>1)
2313
"RTN","HLCSTCP1",69,0)
2314
.. ;ping message
2315
"RTN","HLCSTCP1",70,0)
2316
.. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
2317
"RTN","HLCSTCP1",71,0)
2318
.. ; get next ien to store
2319
"RTN","HLCSTCP1",72,0)
2320
.. D MIEN
2321
"RTN","HLCSTCP1",73,0)
2322
.. K HLMSG
2323
"RTN","HLCSTCP1",74,0)
2324
.. S (HLINE,HLHDR)=0
2325
"RTN","HLCSTCP1",75,0)
2326
. ; check for end block; HLMSG(HLINE) = <eb><cr>
2327
"RTN","HLCSTCP1",76,0)
2328
. I HLMSG(HLINE,0)[HLDEND D
2329
"RTN","HLCSTCP1",77,0)
2330
.. ;no msg. ien
2331
"RTN","HLCSTCP1",78,0)
2332
.. Q:'HLIND1
2333
"RTN","HLCSTCP1",79,0)
2334
.. ; Kill just the last line
2335
"RTN","HLCSTCP1",80,0)
2336
.. K HLMSG(HLINE,0) S HLINE=HLINE-1
2337
"RTN","HLCSTCP1",81,0)
2338
.. ; move into 772
2339
"RTN","HLCSTCP1",82,0)
2340
.. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
2341
"RTN","HLCSTCP1",83,0)
2342
.. ;mark that end block has been received
2343
"RTN","HLCSTCP1",84,0)
2344
.. ;HLIND1=ien in 773^ien in 772^1 if end block was received
2345
"RTN","HLCSTCP1",85,0)
2346
.. S $P(HLIND1,U,3)=1
2347
"RTN","HLCSTCP1",86,0)
2348
.. ;reset variables for next message
2349
"RTN","HLCSTCP1",87,0)
2350
.. D CLEAN
2351
"RTN","HLCSTCP1",88,0)
2352
. ;add blank line for carriage return
2353
"RTN","HLCSTCP1",89,0)
2354
. I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
2355
"RTN","HLCSTCP1",90,0)
2356
Q:HLRDOUT
2357
"RTN","HLCSTCP1",91,0)
2358
;If the line is long and no <CR> move it into the array.
2359
"RTN","HLCSTCP1",92,0)
2360
I ($L(HLX)'<HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q
2361
"RTN","HLCSTCP1",93,0)
2362
. S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
2363
"RTN","HLCSTCP1",94,0)
2364
;have start block but no record seperator
2365
"RTN","HLCSTCP1",95,0)
2366
I HLX[HLDSTRT D Q
2367
"RTN","HLCSTCP1",96,0)
2368
. ;check for more than 1 start block
2369
"RTN","HLCSTCP1",97,0)
2370
. S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
2371
"RTN","HLCSTCP1",98,0)
2372
. S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
2373
"RTN","HLCSTCP1",99,0)
2374
. D RESET:(HLHDR&(HLINE>1))
2375
"RTN","HLCSTCP1",100,0)
2376
;if no ien, then we don't have start block, reset
2377
"RTN","HLCSTCP1",101,0)
2378
I 'HLIND1 D CLEAN Q
2379
"RTN","HLCSTCP1",102,0)
2380
; big message-merge from local to global every 100 lines
2381
"RTN","HLCSTCP1",103,0)
2382
I (HLINE-$O(HLMSG(0)))>100 D
2383
"RTN","HLCSTCP1",104,0)
2384
. M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
2385
"RTN","HLCSTCP1",105,0)
2386
. ; reset working array
2387
"RTN","HLCSTCP1",106,0)
2388
. K HLMSG
2389
"RTN","HLCSTCP1",107,0)
2390
Q
2391
"RTN","HLCSTCP1",108,0)
2392
;
2393
"RTN","HLCSTCP1",109,0)
2394
SAVE(SRC,DEST) ;save into global & set top node
2395
"RTN","HLCSTCP1",110,0)
2396
;SRC=source array (passed by ref.), DEST=destination global
2397
"RTN","HLCSTCP1",111,0)
2398
M @DEST=SRC
2399
"RTN","HLCSTCP1",112,0)
2400
S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
2401
"RTN","HLCSTCP1",113,0)
2402
Q
2403
"RTN","HLCSTCP1",114,0)
2404
;
2405
"RTN","HLCSTCP1",115,0)
2406
DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
2407
"RTN","HLCSTCP1",116,0)
2408
N DIK,DA
2409
"RTN","HLCSTCP1",117,0)
2410
S DA=+HLMAMT,DIK="^HLMA("
2411
"RTN","HLCSTCP1",118,0)
2412
D ^DIK
2413
"RTN","HLCSTCP1",119,0)
2414
S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
2415
"RTN","HLCSTCP1",120,0)
2416
D ^DIK
2417
"RTN","HLCSTCP1",121,0)
2418
Q
2419
"RTN","HLCSTCP1",122,0)
2420
MIEN ; sets HLIND1=ien in 773^ien in 772 for message
2421
"RTN","HLCSTCP1",123,0)
2422
N HLMID,X
2423
"RTN","HLCSTCP1",124,0)
2424
I HLIND1 D
2425
"RTN","HLCSTCP1",125,0)
2426
. S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
2427
"RTN","HLCSTCP1",126,0)
2428
. S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
2429
"RTN","HLCSTCP1",127,0)
2430
;msg. id is 10th of MSH & 11th for BSH or FSH
2431
"RTN","HLCSTCP1",128,0)
2432
S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
2433
"RTN","HLCSTCP1",129,0)
2434
;if HLIND1 is set, kill old message, use HLIND1 for new
2435
"RTN","HLCSTCP1",130,0)
2436
;message, it means we never got end block for 1st msg.
2437
"RTN","HLCSTCP1",131,0)
2438
I HLIND1 D Q
2439
"RTN","HLCSTCP1",132,0)
2440
. ;get pointer to 772, kill header
2441
"RTN","HLCSTCP1",133,0)
2442
. K ^HLMA(+HLIND1,"MSH")
2443
"RTN","HLCSTCP1",134,0)
2444
. I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
2445
"RTN","HLCSTCP1",135,0)
2446
. S X=$$MAID^HLTF(+HLIND1,HLMID)
2447
"RTN","HLCSTCP1",136,0)
2448
. D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
2449
"RTN","HLCSTCP1",137,0)
2450
. S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
2451
"RTN","HLCSTCP1",138,0)
2452
D TCP^HLTF(.HLMID,.X,.HLDT)
2453
"RTN","HLCSTCP1",139,0)
2454
I 'X D Q
2455
"RTN","HLCSTCP1",140,0)
2456
. ;error - record and reset array
2457
"RTN","HLCSTCP1",141,0)
2458
. ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
2459
"RTN","HLCSTCP1",142,0)
2460
. D CLEAN K HLLSTN
2461
"RTN","HLCSTCP1",143,0)
2462
. ;error 100=LLP Could not Enqueue the Message, reset array
2463
"RTN","HLCSTCP1",144,0)
2464
. D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
2465
"RTN","HLCSTCP1",145,0)
2466
;HLIND1=ien in 773^ien in 772
2467
"RTN","HLCSTCP1",146,0)
2468
S HLIND1=X_U_+$G(^HLMA(X,0))
2469
"RTN","HLCSTCP1",147,0)
2470
;save MSH into 773
2471
"RTN","HLCSTCP1",148,0)
2472
D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
2473
"RTN","HLCSTCP1",149,0)
2474
Q
2475
"RTN","HLCSTCP1",150,0)
2476
;
2477
"RTN","HLCSTCP1",151,0)
2478
PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
2479
"RTN","HLCSTCP1",152,0)
2480
N FS,I,L,L1,L2,X,Y
2481
"RTN","HLCSTCP1",153,0)
2482
S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
2483
"RTN","HLCSTCP1",154,0)
2484
F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0))
2485
"RTN","HLCSTCP1",155,0)
2486
. S:L1=1 L=L+1
2487
"RTN","HLCSTCP1",156,0)
2488
. S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
2489
"RTN","HLCSTCP1",157,0)
2490
. S L2=Y,Y=L
2491
"RTN","HLCSTCP1",158,0)
2492
Q X
2493
"RTN","HLCSTCP1",159,0)
2494
;
2495
"RTN","HLCSTCP1",160,0)
2496
PING ;process PING message
2497
"RTN","HLCSTCP1",161,0)
2498
S X=HLMSG(1,0)
2499
"RTN","HLCSTCP1",162,0)
2500
I X[HLDEND U IO W X,!
2501
"RTN","HLCSTCP1",163,0)
2502
CLEAN ;reset var. for next message
2503
"RTN","HLCSTCP1",164,0)
2504
K HLMSG
2505
"RTN","HLCSTCP1",165,0)
2506
S HLINE=0,HLRDOUT=1
2507
"RTN","HLCSTCP1",166,0)
2508
Q
2509
"RTN","HLCSTCP1",167,0)
2510
;
2511
"RTN","HLCSTCP1",168,0)
2512
ERROR ; Error trap for disconnect error and return back to the read loop.
2513
"RTN","HLCSTCP1",169,0)
2514
S $ETRAP="D UNWIND^%ZTER"
2515
"RTN","HLCSTCP1",170,0)
2516
; make sure GT.M-specific DELIMITER flag is removed, and turn off error trapping -- we're already handling the error
2517
"RTN","HLCSTCP1",171,0)
2518
I HLOS["GT.M" X "U IO:(NODELIMITER:IOERROR="""":EXCEPT="""")"
2519
"RTN","HLCSTCP1",172,0)
2520
I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN")!($$EC^%ZOSV["IOEOF") D UNWIND^%ZTER Q
2521
"RTN","HLCSTCP1",173,0)
2522
I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
2523
"RTN","HLCSTCP1",174,0)
2524
S HLCSOUT=1 D ^%ZTER,CC("Error")
2525
"RTN","HLCSTCP1",175,0)
2526
D UNWIND^%ZTER
2527
"RTN","HLCSTCP1",176,0)
2528
Q
2529
"RTN","HLCSTCP1",177,0)
2530
;
2531
"RTN","HLCSTCP1",178,0)
2532
CC(X) ;cleanup and close
2533
"RTN","HLCSTCP1",179,0)
2534
D MON^HLCSTCP(X)
2535
"RTN","HLCSTCP1",180,0)
2536
H 2
2537
"RTN","HLCSTCP1",181,0)
2538
Q
2539
"RTN","HLCSTCP1",182,0)
2540
RESET ;reset info as a result of no end block
2541
"RTN","HLCSTCP1",183,0)
2542
N %
2543
"RTN","HLCSTCP1",184,0)
2544
S HLMSG(1,0)=HLMSG(HLINE,0)
2545
"RTN","HLCSTCP1",185,0)
2546
F %=2:1:HLINE K HLMSG(%,0)
2547
"RTN","HLCSTCP1",186,0)
2548
S HLINE=1
2549
"RTN","HLCSTCP1",187,0)
2550
Q
2551
"RTN","HLCSTCP2")
2552
0^53^B62380874
2553
"RTN","HLCSTCP2",1,0)
2554
HLCSTCP2 ;SFIRMFO/RSD MSC/JKT - BI-DIRECTIONAL TCP ;02/25/2010 11:08
2555
"RTN","HLCSTCP2",2,0)
2556
;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,MSC**;Oct 13,1995
2557
"RTN","HLCSTCP2",3,0)
2558
;Sender
2559
"RTN","HLCSTCP2",4,0)
2560
;Request connection, send outbound message(s) delimited by MLLP
2561
"RTN","HLCSTCP2",5,0)
2562
;Input : HLDP=Logical Link to use
2563
"RTN","HLCSTCP2",6,0)
2564
; Set up error trap
2565
"RTN","HLCSTCP2",7,0)
2566
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
2567
"RTN","HLCSTCP2",8,0)
2568
I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP2"")" ;turn on error trapping on GT.M
2569
"RTN","HLCSTCP2",9,0)
2570
N HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP
2571
"RTN","HLCSTCP2",10,0)
2572
;HLRETRY=number of retranmission for this link,HLRETMG=alert sent
2573
"RTN","HLCSTCP2",11,0)
2574
S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0
2575
"RTN","HLCSTCP2",12,0)
2576
;persistent conection, open connection first, HLPORT=open port
2577
"RTN","HLCSTCP2",13,0)
2578
I $G(HLTCPLNK)["Y" F Q:$$OPEN G EXIT:$$STOP^HLCSTCP H 1
2579
"RTN","HLCSTCP2",14,0)
2580
F D QUE Q:$$STOP^HLCSTCP D:'HLMSG Q:$G(HLCSOUT)
2581
"RTN","HLCSTCP2",15,0)
2582
. ;no messages to send
2583
"RTN","HLCSTCP2",16,0)
2584
. D MON^HLCSTCP("Idle") H 3
2585
"RTN","HLCSTCP2",17,0)
2586
. ;persistent connection, no retention
2587
"RTN","HLCSTCP2",18,0)
2588
. Q:$G(HLTCPLNK)["Y"
2589
"RTN","HLCSTCP2",19,0)
2590
. D MON^HLCSTCP("Retention")
2591
"RTN","HLCSTCP2",20,0)
2592
. N % I 0
2593
"RTN","HLCSTCP2",21,0)
2594
. ;if message comes in or ask to stop
2595
"RTN","HLCSTCP2",22,0)
2596
. F %=1:1:HLTCPRET H 1 I $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0)) Q
2597
"RTN","HLCSTCP2",23,0)
2598
. E S HLCSOUT=2 Q
2599
"RTN","HLCSTCP2",24,0)
2600
. Q:$$STOP^HLCSTCP
2601
"RTN","HLCSTCP2",25,0)
2602
. D MON^HLCSTCP("Idle")
2603
"RTN","HLCSTCP2",26,0)
2604
;Close port
2605
"RTN","HLCSTCP2",27,0)
2606
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
2607
"RTN","HLCSTCP2",28,0)
2608
EXIT Q
2609
"RTN","HLCSTCP2",29,0)
2610
;
2611
"RTN","HLCSTCP2",30,0)
2612
QUE ; -- Check "OUT" queue for processing IF there is a message do it
2613
"RTN","HLCSTCP2",31,0)
2614
; and then check the link if it open or not
2615
"RTN","HLCSTCP2",32,0)
2616
N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
2617
"RTN","HLCSTCP2",33,0)
2618
D MON^HLCSTCP("Check out")
2619
"RTN","HLCSTCP2",34,0)
2620
;HLMSG=next msg, set at tag DONE
2621
"RTN","HLCSTCP2",35,0)
2622
I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG
2623
"RTN","HLCSTCP2",36,0)
2624
;
2625
"RTN","HLCSTCP2",37,0)
2626
;**109**
2627
"RTN","HLCSTCP2",38,0)
2628
;Temporarily lock ^HLMA to flush buffer and ensure edits are complete
2629
"RTN","HLCSTCP2",39,0)
2630
;L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q
2631
"RTN","HLCSTCP2",40,0)
2632
;L -^HLMA(HLMSG)
2633
"RTN","HLCSTCP2",41,0)
2634
;
2635
"RTN","HLCSTCP2",42,0)
2636
S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP=""
2637
"RTN","HLCSTCP2",43,0)
2638
;don't have message text or MSH, kill x-ref and decrement 'to send'
2639
"RTN","HLCSTCP2",44,0)
2640
I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
2641
"RTN","HLCSTCP2",45,0)
2642
;update msg status to 'being transmitted'; if cancelled decrement link and quit
2643
"RTN","HLCSTCP2",46,0)
2644
I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
2645
"RTN","HLCSTCP2",47,0)
2646
;number of retransmissions for message
2647
"RTN","HLCSTCP2",48,0)
2648
S HLRETRM=+$P(^HLMA(HLMSG,"P"),U,5)
2649
"RTN","HLCSTCP2",49,0)
2650
;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown
2651
"RTN","HLCSTCP2",50,0)
2652
;quit if restart or shutdown, link is going down
2653
"RTN","HLCSTCP2",51,0)
2654
I HLRETRY>HLDRETR D Q:"I"'[HLRETRA
2655
"RTN","HLCSTCP2",52,0)
2656
. D MON^HLCSTCP("Error")
2657
"RTN","HLCSTCP2",53,0)
2658
. ;only 1 alert per link up time, don't send if restart
2659
"RTN","HLCSTCP2",54,0)
2660
. D:'HLRETMG&(HLRETRA'="R")
2661
"RTN","HLCSTCP2",55,0)
2662
.. ;send alert
2663
"RTN","HLCSTCP2",56,0)
2664
.. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
2665
"RTN","HLCSTCP2",57,0)
2666
.. ;get mailgroup from file 869.3
2667
"RTN","HLCSTCP2",58,0)
2668
.. S HLRETMG=1,Z=$P($$PARAM^HLCS2,U,8) Q:Z=""
2669
"RTN","HLCSTCP2",59,0)
2670
.. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" HL7 LL "_$P(^HLCS(870,HLDP,0),U)_" exceeded retries. LL will "_$S(HLRETRA="S":"shutdown.",HLRETRA="R":"restart.",1:"keep trying.")
2671
"RTN","HLCSTCP2",60,0)
2672
.. D SETUP^XQALERT
2673
"RTN","HLCSTCP2",61,0)
2674
. ;quit if action is ignore
2675
"RTN","HLCSTCP2",62,0)
2676
. Q:"I"[HLRETRA
2677
"RTN","HLCSTCP2",63,0)
2678
. ;this will shutdown this link
2679
"RTN","HLCSTCP2",64,0)
2680
. S HLCSOUT=1
2681
"RTN","HLCSTCP2",65,0)
2682
. ;action is shutdown, set shutdown flag so LM won't restart
2683
"RTN","HLCSTCP2",66,0)
2684
. S:HLRETRA="S" $P(^HLCS(870,HLDP,0),U,15)=1
2685
"RTN","HLCSTCP2",67,0)
2686
. D STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param")
2687
"RTN","HLCSTCP2",68,0)
2688
I '$$OPEN Q
2689
"RTN","HLCSTCP2",69,0)
2690
D MON^HLCSTCP("Send")
2691
"RTN","HLCSTCP2",70,0)
2692
; -- data passed in global array, success=1
2693
"RTN","HLCSTCP2",71,0)
2694
I $$WRITE(HLMSG)<0 Q
2695
"RTN","HLCSTCP2",72,0)
2696
S (HLTCP,HLTCPI)=HLMSG,HLRETRY=HLRETRY+1,HLRETRM=HLRETRM+1
2697
"RTN","HLCSTCP2",73,0)
2698
;update status to awaiting response, decrement link if cancelled
2699
"RTN","HLCSTCP2",74,0)
2700
I '$$CHKMSG(1.7) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
2701
"RTN","HLCSTCP2",75,0)
2702
;set transmission count, get ACKTIMEOUT override
2703
"RTN","HLCSTCP2",76,0)
2704
S $P(^HLMA(HLMSG,"P"),U,5)=HLRETRM I $P(^("P"),U,7) S HLN("ACKTIME")=+$P(^("P"),U,7)
2705
"RTN","HLCSTCP2",77,0)
2706
;get header of message just sent
2707
"RTN","HLCSTCP2",78,0)
2708
K HLJ M HLJ=^HLMA(HLMSG,"MSH")
2709
"RTN","HLCSTCP2",79,0)
2710
;first component of sending app.
2711
"RTN","HLCSTCP2",80,0)
2712
S HLN("ECH")=$$P^HLTPCK2(.HLJ,2),HLN("SAN")=$P($$P^HLTPCK2(.HLJ,3),$E(HLN("ECH")))
2713
"RTN","HLCSTCP2",81,0)
2714
;msg type, msg. id, commit ack, and app. ack parameter
2715
"RTN","HLCSTCP2",82,0)
2716
S HLN("TYPE")=$$P^HLTPCK2(.HLJ,1),HLN("MID")=$$P^HLTPCK2(.HLJ,10),HLN("ACAT")=$$P^HLTPCK2(.HLJ,15),HLN("APAT")=$$P^HLTPCK2(.HLJ,16)
2717
"RTN","HLCSTCP2",83,0)
2718
;MSA segment, message is a response, can't have an a. ack.
2719
"RTN","HLCSTCP2",84,0)
2720
S Z=$$MSA^HLTP3(+^HLMA(HLMSG,0)) I Z]"" S:HLN("ACAT")="" HLN("ACAT")="NE" S HLN("APAT")="NE"
2721
"RTN","HLCSTCP2",85,0)
2722
;for batch/file with commit ack, reset c. ack and a. ack variables
2723
"RTN","HLCSTCP2",86,0)
2724
I "BHS,FHS"[HLN("TYPE") S Z=$E(HLJ(1,0),5),X=$$P^HLTPCK2(.HLJ,9),HLN("ACAT")=$P(X,Z,5),HLN("APAT")=$P(X,Z,6),HLN("MID")=$$P^HLTPCK2(.HLJ,11)
2725
"RTN","HLCSTCP2",87,0)
2726
;get event protocol
2727
"RTN","HLCSTCP2",88,0)
2728
S HLN("EID")=+$P(^HLMA(HLMSG,0),U,8),X=$G(^ORD(101,HLN("EID"),770))
2729
"RTN","HLCSTCP2",89,0)
2730
;set link counter to msg sent
2731
"RTN","HLCSTCP2",90,0)
2732
D LLCNT^HLCSTCP(HLDP,4)
2733
"RTN","HLCSTCP2",91,0)
2734
;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT
2735
"RTN","HLCSTCP2",92,0)
2736
I HLN("ACAT")="NE",HLN("APAT")="NE" D Q
2737
"RTN","HLCSTCP2",93,0)
2738
.D DONE(3)
2739
"RTN","HLCSTCP2",94,0)
2740
.;
2741
"RTN","HLCSTCP2",95,0)
2742
.;
2743
"RTN","HLCSTCP2",96,0)
2744
.H $G(HLDWAIT)
2745
"RTN","HLCSTCP2",97,0)
2746
;
2747
"RTN","HLCSTCP2",98,0)
2748
;do structure is to stack error
2749
"RTN","HLCSTCP2",99,0)
2750
D
2751
"RTN","HLCSTCP2",100,0)
2752
. N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
2753
"RTN","HLCSTCP2",101,0)
2754
. I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G RDERR^HLCSTCP2"")" ;change I/O error trap
2755
"RTN","HLCSTCP2",102,0)
2756
. ;HL*1.6*87: Read acknowledgement.
2757
"RTN","HLCSTCP2",103,0)
2758
. ;Loop to re-read from buffer when receiving incorrect ack.
2759
"RTN","HLCSTCP2",104,0)
2760
. F D Q:'+$G(HLREREAD)
2761
"RTN","HLCSTCP2",105,0)
2762
.. S HLREREAD=1
2763
"RTN","HLCSTCP2",106,0)
2764
.. ;override ack timeout
2765
"RTN","HLCSTCP2",107,0)
2766
.. I $G(HLN("ACKTIME")) N HLDBACK S HLDBACK=HLN("ACKTIME")
2767
"RTN","HLCSTCP2",108,0)
2768
.. ;check for response, quit if no-response, msg will be resent
2769
"RTN","HLCSTCP2",109,0)
2770
.. ;HLRESP=ien 773^ien 772 for response message
2771
"RTN","HLCSTCP2",110,0)
2772
.. S HLRESP=$$READ^HLCSTCP1()
2773
"RTN","HLCSTCP2",111,0)
2774
.. ;if no response, decrement counter and quit
2775
"RTN","HLCSTCP2",112,0)
2776
.. I 'HLRESP D LLCNT^HLCSTCP(HLDP,4,1) S HLREREAD="0^No Response" Q
2777
"RTN","HLCSTCP2",113,0)
2778
.. ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error
2779
"RTN","HLCSTCP2",114,0)
2780
.. S X=$$RSP^HLTP31(HLRESP,.HLN)
2781
"RTN","HLCSTCP2",115,0)
2782
.. ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app)
2783
"RTN","HLCSTCP2",116,0)
2784
.. Q:'X
2785
"RTN","HLCSTCP2",117,0)
2786
.. ;commit ack - done
2787
"RTN","HLCSTCP2",118,0)
2788
.. I X=1 D S HLREREAD="0^Commit Ack" Q
2789
"RTN","HLCSTCP2",119,0)
2790
... ;don't need app. ack, set status to complete
2791
"RTN","HLCSTCP2",120,0)
2792
... I "NE"[HLN("APAT") D Q
2793
"RTN","HLCSTCP2",121,0)
2794
....D DONE(3)
2795
"RTN","HLCSTCP2",122,0)
2796
....;
2797
"RTN","HLCSTCP2",123,0)
2798
... ;response is deferred, set status to awaiting ack
2799
"RTN","HLCSTCP2",124,0)
2800
... D DONE(2)
2801
"RTN","HLCSTCP2",125,0)
2802
...;
2803
"RTN","HLCSTCP2",126,0)
2804
.. ;Error, HLRESLT=error number^error message from HLTP3
2805
"RTN","HLCSTCP2",127,0)
2806
.. I X=4 D Q
2807
"RTN","HLCSTCP2",128,0)
2808
... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2))
2809
"RTN","HLCSTCP2",129,0)
2810
...;
2811
"RTN","HLCSTCP2",130,0)
2812
... S HLREREAD="0^Error"
2813
"RTN","HLCSTCP2",131,0)
2814
.. ;app ack was successful
2815
"RTN","HLCSTCP2",132,0)
2816
.. D DONE(3) S HLREREAD="0^App Ack"
2817
"RTN","HLCSTCP2",133,0)
2818
..;
2819
"RTN","HLCSTCP2",134,0)
2820
Q
2821
"RTN","HLCSTCP2",135,0)
2822
;
2823
"RTN","HLCSTCP2",136,0)
2824
DCSEND ;direct connect
2825
"RTN","HLCSTCP2",137,0)
2826
; Set up error trap
2827
"RTN","HLCSTCP2",138,0)
2828
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
2829
"RTN","HLCSTCP2",139,0)
2830
I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP2"")" ;turn on error trapping on GT.M
2831
"RTN","HLCSTCP2",140,0)
2832
;override ack timeout
2833
"RTN","HLCSTCP2",141,0)
2834
I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME")
2835
"RTN","HLCSTCP2",142,0)
2836
I $$WRITE(HLMSG)<0 D:$G(HLERROR)]"" Q ;HL*1.6*77
2837
"RTN","HLCSTCP2",143,0)
2838
. D STATUS^HLTF0(HLMSG,4,$P(HLERROR,"^"),$P(HLERROR,"^",2),1) ;HL*1.6*77
2839
"RTN","HLCSTCP2",144,0)
2840
. D LLCNT^HLCSTCP(HLDP,3,1)
2841
"RTN","HLCSTCP2",145,0)
2842
D LLCNT^HLCSTCP(HLDP,4)
2843
"RTN","HLCSTCP2",146,0)
2844
;do structure is to stack error
2845
"RTN","HLCSTCP2",147,0)
2846
D
2847
"RTN","HLCSTCP2",148,0)
2848
. N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
2849
"RTN","HLCSTCP2",149,0)
2850
. I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G RDERR^HLCSTCP2"")" ;change I/O error trap
2851
"RTN","HLCSTCP2",150,0)
2852
. ;HLRESP=ien 773^ien 772 for response message
2853
"RTN","HLCSTCP2",151,0)
2854
. S HLRESP=$$READ^HLCSTCP1()
2855
"RTN","HLCSTCP2",152,0)
2856
;
2857
"RTN","HLCSTCP2",153,0)
2858
D DONE(3):$G(HLRESP),DONE(4,108,$S($G(HLERROR)]"":$P(HLERROR,"^",2),1:"No response")):'$G(HLRESP)
2859
"RTN","HLCSTCP2",154,0)
2860
I $G(HLERROR)']"" D
2861
"RTN","HLCSTCP2",155,0)
2862
.D MON^HLCSTCP("Idle")
2863
"RTN","HLCSTCP2",156,0)
2864
.I '$G(HLRESP) S HLERROR="108^No response"
2865
"RTN","HLCSTCP2",157,0)
2866
;Close port
2867
"RTN","HLCSTCP2",158,0)
2868
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
2869
"RTN","HLCSTCP2",159,0)
2870
Q
2871
"RTN","HLCSTCP2",160,0)
2872
;
2873
"RTN","HLCSTCP2",161,0)
2874
DONE(ST,ERR,ERRMSG) ;set status to complete
2875
"RTN","HLCSTCP2",162,0)
2876
;ST=status, ERR=error ien, ERRMSG=error msg
2877
"RTN","HLCSTCP2",163,0)
2878
D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1)
2879
"RTN","HLCSTCP2",164,0)
2880
;
2881
"RTN","HLCSTCP2",165,0)
2882
;**109**
2883
"RTN","HLCSTCP2",166,0)
2884
D DEQUE^HLCSREP(HLDP,"O",HLMSG)
2885
"RTN","HLCSTCP2",167,0)
2886
;
2887
"RTN","HLCSTCP2",168,0)
2888
;check for more msg.
2889
"RTN","HLCSTCP2",169,0)
2890
I $G(HLPRIO)'="I" S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0
2891
"RTN","HLCSTCP2",170,0)
2892
Q
2893
"RTN","HLCSTCP2",171,0)
2894
;
2895
"RTN","HLCSTCP2",172,0)
2896
CHKMSG(HLI) ;check status of message and update if not cancelled
2897
"RTN","HLCSTCP2",173,0)
2898
;input: HLI=new status, HLMSG=ien of msg in 773
2899
"RTN","HLCSTCP2",174,0)
2900
;returns 1=msg was updated, 0=msg has been canceled
2901
"RTN","HLCSTCP2",175,0)
2902
N X
2903
"RTN","HLCSTCP2",176,0)
2904
;
2905
"RTN","HLCSTCP2",177,0)
2906
;**109**
2907
"RTN","HLCSTCP2",178,0)
2908
;F L +^HLMA(HLMSG,"P"):1 Q:$T H 1
2909
"RTN","HLCSTCP2",179,0)
2910
;
2911
"RTN","HLCSTCP2",180,0)
2912
;
2913
"RTN","HLCSTCP2",181,0)
2914
; New HL*1.6*77 code starting here...
2915
"RTN","HLCSTCP2",182,0)
2916
I '$D(^HLMA(HLMSG,"P")) D Q 0
2917
"RTN","HLCSTCP2",183,0)
2918
. S HLERROR="2^Missing status field"
2919
"RTN","HLCSTCP2",184,0)
2920
. D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1)
2921
"RTN","HLCSTCP2",185,0)
2922
.;
2923
"RTN","HLCSTCP2",186,0)
2924
.;**109**
2925
"RTN","HLCSTCP2",187,0)
2926
. D DEQUE^HLCSREP(HLDP,"O",HLMSG)
2927
"RTN","HLCSTCP2",188,0)
2928
.;L -^HLMA(HLMSG,"P")
2929
"RTN","HLCSTCP2",189,0)
2930
;**end 109**
2931
"RTN","HLCSTCP2",190,0)
2932
;
2933
"RTN","HLCSTCP2",191,0)
2934
; End of HL*1.6*77 modifications
2935
"RTN","HLCSTCP2",192,0)
2936
;
2937
"RTN","HLCSTCP2",193,0)
2938
;get status, quit if msg was cancelled
2939
"RTN","HLCSTCP2",194,0)
2940
;
2941
"RTN","HLCSTCP2",195,0)
2942
;**109**
2943
"RTN","HLCSTCP2",196,0)
2944
;S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0
2945
"RTN","HLCSTCP2",197,0)
2946
S X=+^HLMA(HLMSG,"P") Q:X=3 0
2947
"RTN","HLCSTCP2",198,0)
2948
;
2949
"RTN","HLCSTCP2",199,0)
2950
;update status if it is different
2951
"RTN","HLCSTCP2",200,0)
2952
I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI)
2953
"RTN","HLCSTCP2",201,0)
2954
;
2955
"RTN","HLCSTCP2",202,0)
2956
;**109**
2957
"RTN","HLCSTCP2",203,0)
2958
;L -^HLMA(HLMSG,"P")
2959
"RTN","HLCSTCP2",204,0)
2960
;
2961
"RTN","HLCSTCP2",205,0)
2962
Q 1
2963
"RTN","HLCSTCP2",206,0)
2964
;
2965
"RTN","HLCSTCP2",207,0)
2966
WRITE(HLDA) ; write message in HL7 format
2967
"RTN","HLCSTCP2",208,0)
2968
; HLDA - ien of message in 773
2969
"RTN","HLCSTCP2",209,0)
2970
; - start block $C(11)
2971
"RTN","HLCSTCP2",210,0)
2972
; - end block $C(28)
2973
"RTN","HLCSTCP2",211,0)
2974
; - record separator $C(13)
2975
"RTN","HLCSTCP2",212,0)
2976
;Output(s): 1 - Successful
2977
"RTN","HLCSTCP2",213,0)
2978
; -1 - Unsuccessful
2979
"RTN","HLCSTCP2",214,0)
2980
;
2981
"RTN","HLCSTCP2",215,0)
2982
N HLDA2,HLAR,HLI,LINENO,X
2983
"RTN","HLCSTCP2",216,0)
2984
;set error trap, used when called from HLTP3
2985
"RTN","HLCSTCP2",217,0)
2986
;
2987
"RTN","HLCSTCP2",218,0)
2988
; New HL*1.6*77 code starts here...
2989
"RTN","HLCSTCP2",219,0)
2990
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
2991
"RTN","HLCSTCP2",220,0)
2992
I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP2"")" ;turn on error trapping on GT.M
2993
"RTN","HLCSTCP2",221,0)
2994
I $G(^HLMA(HLDA,0))'>0 D Q -1
2995
"RTN","HLCSTCP2",222,0)
2996
. S HLERROR="2^Message Text pointer missing"
2997
"RTN","HLCSTCP2",223,0)
2998
S HLDA2=+$G(^HLMA(HLDA,0))
2999
"RTN","HLCSTCP2",224,0)
3000
; End of HL*1.6*77 modifications...
3001
"RTN","HLCSTCP2",225,0)
3002
;
3003
"RTN","HLCSTCP2",226,0)
3004
Q:'$G(^HLMA(HLDA,0)) -1 ;HL*1.6*77
3005
"RTN","HLCSTCP2",227,0)
3006
; header is in ^HLMA(, message is in ^HL(772,
3007
"RTN","HLCSTCP2",228,0)
3008
S LINENO=1,HLI=0,HLAR="^HLMA(HLDA,""MSH"")"
3009
"RTN","HLCSTCP2",229,0)
3010
U IO
3011
"RTN","HLCSTCP2",230,0)
3012
D W $C(13) S HLAR="^HL(772,HLDA2,""IN"")",HLI=0 D
3013
"RTN","HLCSTCP2",231,0)
3014
. F S HLI=$O(@HLAR@(HLI)) Q:'HLI S X=$G(^(HLI,0)) D
3015
"RTN","HLCSTCP2",232,0)
3016
.. ;first line, need start block char.
3017
"RTN","HLCSTCP2",233,0)
3018
.. S:LINENO=1 X=$C(11)_X
3019
"RTN","HLCSTCP2",234,0)
3020
.. I X]"" W X,!
3021
"RTN","HLCSTCP2",235,0)
3022
.. ;send CR for blank lines
3023
"RTN","HLCSTCP2",236,0)
3024
.. I X="" W $C(13)
3025
"RTN","HLCSTCP2",237,0)
3026
.. S LINENO=LINENO+1
3027
"RTN","HLCSTCP2",238,0)
3028
; Sends end block for this message
3029
"RTN","HLCSTCP2",239,0)
3030
S X=$C(28)_$C(13)
3031
"RTN","HLCSTCP2",240,0)
3032
U IO W X,!
3033
"RTN","HLCSTCP2",241,0)
3034
Q 1
3035
"RTN","HLCSTCP2",242,0)
3036
;
3037
"RTN","HLCSTCP2",243,0)
3038
OPEN() ; -- Open TCP/IP device (Client)
3039
"RTN","HLCSTCP2",244,0)
3040
;HLPORT=port, defined only if port is open
3041
"RTN","HLCSTCP2",245,0)
3042
;HLPORTA=number of attempted opens
3043
"RTN","HLCSTCP2",246,0)
3044
I $D(HLPORT) S IO=HLPORT D Q 1
3045
"RTN","HLCSTCP2",247,0)
3046
. U IO
3047
"RTN","HLCSTCP2",248,0)
3048
. I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache'
3049
"RTN","HLCSTCP2",249,0)
3050
N HLDOM,HLI,HLIP,HLPORTA
3051
"RTN","HLCSTCP2",250,0)
3052
G OPENA^HLCSTCP3
3053
"RTN","HLCSTCP2",251,0)
3054
;
3055
"RTN","HLCSTCP2",252,0)
3056
RDERR D RDERR^HLCSTCP4 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
3057
"RTN","HLCSTCP2",253,0)
3058
ERROR D ERROR^HLCSTCP4 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
3059
"RTN","HLCSTCP2",254,0)
3060
;
3061
"RTN","HLCSTCP2",255,0)
3062
CC(X) ;cleanup and close
3063
"RTN","HLCSTCP2",256,0)
3064
D MON^HLCSTCP(X)
3065
"RTN","HLCSTCP2",257,0)
3066
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
3067
"RTN","HLCSTCP2",258,0)
3068
H 2
3069
"RTN","HLCSTCP2",259,0)
3070
Q
3071
"RTN","HLCSTCP3")
3072
0^54^B4155616
3073
"RTN","HLCSTCP3",1,0)
3074
HLCSTCP3 ;SFIRMFO/RSD MSC/JKT - BI-DIRECTIONAL TCP ;02/25/2010 11:08
3075
"RTN","HLCSTCP3",2,0)
3076
;;1.6;HEALTH LEVEL SEVEN;**76,77,MSC**;JUL 17, 1995
3077
"RTN","HLCSTCP3",3,0)
3078
;
3079
"RTN","HLCSTCP3",4,0)
3080
OPENA I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
3081
"RTN","HLCSTCP3",5,0)
3082
D MON^HLCSTCP("Open")
3083
"RTN","HLCSTCP3",6,0)
3084
S POP=1
3085
"RTN","HLCSTCP3",7,0)
3086
F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
3087
"RTN","HLCSTCP3",8,0)
3088
;set # of opens back in msg
3089
"RTN","HLCSTCP3",9,0)
3090
I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
3091
"RTN","HLCSTCP3",10,0)
3092
;device open
3093
"RTN","HLCSTCP3",11,0)
3094
I 'POP S HLPORT=IO D Q $S($G(HLERROR)]"":0,1:1)
3095
"RTN","HLCSTCP3",12,0)
3096
. N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" ;HL*1.6*77
3097
"RTN","HLCSTCP3",13,0)
3098
. I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP2"")" ;turn on error trapping on GT.M
3099
"RTN","HLCSTCP3",14,0)
3100
. ;if address came from DNS, set back into LL
3101
"RTN","HLCSTCP3",15,0)
3102
. I $D(HLIP) S $P(^HLCS(870,HLDP,400),U)=HLTCPADD
3103
"RTN","HLCSTCP3",16,0)
3104
. ; write and read to check if still open
3105
"RTN","HLCSTCP3",17,0)
3106
. Q:HLOS'["OpenM" X "U IO:(::""-M"")" ; must be Cache/NT + use packet mode
3107
"RTN","HLCSTCP3",18,0)
3108
. Q:$P(^HLCS(870,HLDP,400),U,7)'="Y" ; must want to SAY HELO
3109
"RTN","HLCSTCP3",19,0)
3110
. U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1
3111
"RTN","HLCSTCP3",20,0)
3112
;openfail-try DNS lookup
3113
"RTN","HLCSTCP3",21,0)
3114
I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
3115
"RTN","HLCSTCP3",22,0)
3116
;HLIP=ip add. from DNS call, get first one and try open again
3117
"RTN","HLCSTCP3",23,0)
3118
I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA
3119
"RTN","HLCSTCP3",24,0)
3120
;open error
3121
"RTN","HLCSTCP3",25,0)
3122
D CC^HLCSTCP2("Openfail") H 3
3123
"RTN","HLCSTCP3",26,0)
3124
Q 0
3125
"RTN","HLCSTCP3",27,0)
3126
;
3127
"RTN","HLCSTCP3",28,0)
3128
;following code was removed, site's complained of to many alerts
3129
"RTN","HLCSTCP3",29,0)
3130
;couldn't open, send 1 alert
3131
"RTN","HLCSTCP3",30,0)
3132
;I '$G(HLPORTA) D
3133
"RTN","HLCSTCP3",31,0)
3134
;. ;send alert
3135
"RTN","HLCSTCP3",32,0)
3136
;. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
3137
"RTN","HLCSTCP3",33,0)
3138
;. ;get mailgroup from file 869.3
3139
"RTN","HLCSTCP3",34,0)
3140
;. S Z=$P($$PARAM^HLCS2,U,8),HLPORTA="" Q:Z=""
3141
"RTN","HLCSTCP3",35,0)
3142
;. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" Logical Link "_$P(^HLCS(870,HLDP,0),U)_" exceeded Open Retries."
3143
"RTN","HLCSTCP3",36,0)
3144
;. D SETUP^XQALERT
3145
"RTN","HLCSTCP3",37,0)
3146
;open error
3147
"RTN","HLCSTCP3",38,0)
3148
;D CC("Openfail") H 3
3149
"RTN","HLCSTCP3",39,0)
3150
;Q 0
3151
"RTN","HLCSTCP3",40,0)
3152
;
3153
"RTN","HLCSTCP3",41,0)
3154
;
3155
"RTN","HLCSTCP3",42,0)
3156
DNS ;VA domains must have "med" inserted.
3157
"RTN","HLCSTCP3",43,0)
3158
;All domains must use port 5000 and are prepended with "HL7"
3159
"RTN","HLCSTCP3",44,0)
3160
;non-VA DNS lookups will succeed if site uses port 5000 and
3161
"RTN","HLCSTCP3",45,0)
3162
;configure their local DNS with "HL7.yourdomain.com" and entries
3163
"RTN","HLCSTCP3",46,0)
3164
;are created in the logical link file and domain file.
3165
"RTN","HLCSTCP3",47,0)
3166
D MON^HLCSTCP("DNS Lkup")
3167
"RTN","HLCSTCP3",48,0)
3168
I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV"
3169
"RTN","HLCSTCP3",49,0)
3170
I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
3171
"RTN","HLCSTCP3",50,0)
3172
I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
3173
"RTN","HLCSTCP3",51,0)
3174
S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
3175
"RTN","HLCSTCP3",52,0)
3176
K:HLIP="" HLIP
3177
"RTN","HLCSTCP3",53,0)
3178
Q
3179
"RTN","HLCSTCP3",54,0)
3180
;
3181
"RTN","HLCSTCP4")
3182
0^55^B3608309
3183
"RTN","HLCSTCP4",1,0)
3184
HLCSTCP4 ;SFIRMFO/RSD - MSC/JKT BI-DIRECTIONAL TCP ;02/25/2010 11:08
3185
"RTN","HLCSTCP4",2,0)
3186
;;1.6;HEALTH LEVEL SEVEN;**109,MSC**;Oct 13,1995
3187
"RTN","HLCSTCP4",3,0)
3188
;
3189
"RTN","HLCSTCP4",4,0)
3190
; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
3191
"RTN","HLCSTCP4",5,0)
3192
;
3193
"RTN","HLCSTCP4",6,0)
3194
RDERR ; Error during read process, decrement counter
3195
"RTN","HLCSTCP4",7,0)
3196
D LLCNT^HLCSTCP(HLDP,4,1)
3197
"RTN","HLCSTCP4",8,0)
3198
ERROR ; Error trap
3199
"RTN","HLCSTCP4",9,0)
3200
; OPEN ERROR-retry.
3201
"RTN","HLCSTCP4",10,0)
3202
; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
3203
"RTN","HLCSTCP4",11,0)
3204
;
3205
"RTN","HLCSTCP4",12,0)
3206
;**109**
3207
"RTN","HLCSTCP4",13,0)
3208
;I $G(HLMSG) L -^HLMA(HLMSG)
3209
"RTN","HLCSTCP4",14,0)
3210
;
3211
"RTN","HLCSTCP4",15,0)
3212
S $ETRAP="D UNWIND^%ZTER"
3213
"RTN","HLCSTCP4",16,0)
3214
I HLOS["GT.M" X "U IO:(IOERROR="""":EXCEPT="""")" ;turn off error trapping -- we're already handling the error
3215
"RTN","HLCSTCP4",17,0)
3216
I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q
3217
"RTN","HLCSTCP4",18,0)
3218
I $$EC^%ZOSV["WRITE" D Q ;HL*1.6*77 modifications start here
3219
"RTN","HLCSTCP4",19,0)
3220
. D CC^HLCSTCP2("Wr-err")
3221
"RTN","HLCSTCP4",20,0)
3222
. S:$G(HLPRIO)="I" HLERROR="108^Write Error"
3223
"RTN","HLCSTCP4",21,0)
3224
. D UNWIND^%ZTER ;HL*1.6*77 modifications end here
3225
"RTN","HLCSTCP4",22,0)
3226
I $$EC^%ZOSV["READ"!($$EC^%ZOSV["IOEOF") D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
3227
"RTN","HLCSTCP4",23,0)
3228
S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
3229
"RTN","HLCSTCP4",24,0)
3230
S:$G(HLPRIO)="I" HLERROR="9^Error"
3231
"RTN","HLCSTCP4",25,0)
3232
D UNWIND^%ZTER
3233
"RTN","HLCSTCP4",26,0)
3234
Q
3235
"RTN","HLCSTCP4",27,0)
3236
;
3237
"RTN","HLZTCP")
3238
0^52^B44973921
3239
"RTN","HLZTCP",1,0)
3240
HLZTCP ;MILW/JMC MSC/JKT - HL7 TCP/IP Hybrid Lower Level Protocol Receiver/Sender ;28OCT2009
3241
"RTN","HLZTCP",2,0)
3242
;;1.5;HEALTH LEVEL SEVEN;**MSC**;JUL 09, 1993
3243
"RTN","HLZTCP",3,0)
3244
;
3245
"RTN","HLZTCP",4,0)
3246
INIT ;Initialize Variables
3247
"RTN","HLZTCP",5,0)
3248
N HLZIO,HLZOS,HLZSTATE
3249
"RTN","HLZTCP",6,0)
3250
S HLZOS=$G(^%ZOSF("OS"))
3251
"RTN","HLZTCP",7,0)
3252
;
3253
"RTN","HLZTCP",8,0)
3254
I $D(ZTQUEUED) S ZTREQ="@"
3255
"RTN","HLZTCP",9,0)
3256
;
3257
"RTN","HLZTCP",10,0)
3258
I $$NEWERR^%ZTER N $ETRAP S $ETRAP=""
3259
"RTN","HLZTCP",11,0)
3260
S X="ERR^HLZTCP",@^%ZOSF("TRAP")
3261
"RTN","HLZTCP",12,0)
3262
;
3263
"RTN","HLZTCP",13,0)
3264
I '$D(HLION) D Q:POP
3265
"RTN","HLZTCP",14,0)
3266
. D HOME^%ZIS
3267
"RTN","HLZTCP",15,0)
3268
. I POP Q
3269
"RTN","HLZTCP",16,0)
3270
. S HLION=$S(ION']"":"UNKNOWN",1:ION)
3271
"RTN","HLZTCP",17,0)
3272
;
3273
"RTN","HLZTCP",18,0)
3274
S HLZIO(0)=IO
3275
"RTN","HLZTCP",19,0)
3276
;
3277
"RTN","HLZTCP",20,0)
3278
; Figure out type of connection: 1=Server, 2=Client.
3279
"RTN","HLZTCP",21,0)
3280
I HLZOS["DSM" S HLZTCP=$S(IOPAR["ADDRESS":2,1:1)
3281
"RTN","HLZTCP",22,0)
3282
I HLZOS["OpenM" D
3283
"RTN","HLZTCP",23,0)
3284
. N IP
3285
"RTN","HLZTCP",24,0)
3286
. S IP=$P(IOPAR,"""",2) ; Extract IP address
3287
"RTN","HLZTCP",25,0)
3288
. S HLZTCP=$S(IP?1.3N1P1.3N1P1.3N1P1.3N:2,1:1)
3289
"RTN","HLZTCP",26,0)
3290
;
3291
"RTN","HLZTCP",27,0)
3292
; IOPAR is not available to us because of the way we're setting up devices on
3293
"RTN","HLZTCP",28,0)
3294
; GT.M. This routine is only called from a few places, and always in "Client"
3295
"RTN","HLZTCP",29,0)
3296
; mode, so hard code a return value of 2. This entire routine should be
3297
"RTN","HLZTCP",30,0)
3298
; abandoned in the future, so it's an acceptable workaround for now.
3299
"RTN","HLZTCP",31,0)
3300
; See https://code.launchpad.net/~jontai/openvista-gtm-integration/bug430855/+merge/14088
3301
"RTN","HLZTCP",32,0)
3302
I HLZOS["GT.M" S HLZTCP=2
3303
"RTN","HLZTCP",33,0)
3304
;
3305
"RTN","HLZTCP",34,0)
3306
S IOP="NULL DEVICE" D ^%ZIS
3307
"RTN","HLZTCP",35,0)
3308
I POP G EXIT
3309
"RTN","HLZTCP",36,0)
3310
S HLZIO=IO K IOP
3311
"RTN","HLZTCP",37,0)
3312
;
3313
"RTN","HLZTCP",38,0)
3314
S HLTIME=$$NOW^XLFDT
3315
"RTN","HLZTCP",39,0)
3316
;
3317
"RTN","HLZTCP",40,0)
3318
U HLZIO(0)
3319
"RTN","HLZTCP",41,0)
3320
; If TCP client, send a "space" to initiate connection.
3321
"RTN","HLZTCP",42,0)
3322
I HLZTCP=2 W " ",!
3323
"RTN","HLZTCP",43,0)
3324
;
3325
"RTN","HLZTCP",44,0)
3326
K %,%H,%I,X
3327
"RTN","HLZTCP",45,0)
3328
S DTIME=$P($G(HLNDAP0),"^",9),HLTRIES=$P($G(HLNDAP0),"^",5)
3329
"RTN","HLZTCP",46,0)
3330
S:DTIME'>0 DTIME=60 S:HLTRIES'>0 HLTRIES=3
3331
"RTN","HLZTCP",47,0)
3332
S HLLPC=^%ZOSF("LPC")
3333
"RTN","HLZTCP",48,0)
3334
;
3335
"RTN","HLZTCP",49,0)
3336
LOOP ; Infinite loop to check for HL7 messages to send/receive
3337
"RTN","HLZTCP",50,0)
3338
F D I $$S^%ZTLOAD S ZTSTOP=1 Q
3339
"RTN","HLZTCP",51,0)
3340
. S HLLOG=$S($D(^HL(770,"ALOG",HLION)):1,1:0)
3341
"RTN","HLZTCP",52,0)
3342
. D CHKREC,CHKSEND
3343
"RTN","HLZTCP",53,0)
3344
EXIT Q
3345
"RTN","HLZTCP",54,0)
3346
;
3347
"RTN","HLZTCP",55,0)
3348
ERR ; Trap error
3349
"RTN","HLZTCP",56,0)
3350
; Reset current device to "NULL DEVICE".
3351
"RTN","HLZTCP",57,0)
3352
U HLZIO
3353
"RTN","HLZTCP",58,0)
3354
; Reschedule task.
3355
"RTN","HLZTCP",59,0)
3356
I $$EC^%ZOSV["WRITE"!($$EC^%ZOSV["READ") D
3357
"RTN","HLZTCP",60,0)
3358
. N ZTDTH,ZTSK
3359
"RTN","HLZTCP",61,0)
3360
. S ZTSK=ZTQUEUED,ZTDTH="60S",ZTREQ=""
3361
"RTN","HLZTCP",62,0)
3362
. D REQ^%ZTLOAD ; Requeue task in 60 seconds.
3363
"RTN","HLZTCP",63,0)
3364
K HLL(1),^TMP("HLR",$J),^TMP("HLS",$J)
3365
"RTN","HLZTCP",64,0)
3366
Q
3367
"RTN","HLZTCP",65,0)
3368
;
3369
"RTN","HLZTCP",66,0)
3370
CHKREC ; Check if there are HL7 messages to receive
3371
"RTN","HLZTCP",67,0)
3372
; Set flag to receive state.
3373
"RTN","HLZTCP",68,0)
3374
S HLZSTATE="recv"
3375
"RTN","HLZTCP",69,0)
3376
D REC
3377
"RTN","HLZTCP",70,0)
3378
; Received "NAK" message don't know what it goes to.
3379
"RTN","HLZTCP",71,0)
3380
I $G(HLZNAK) K HLERR Q
3381
"RTN","HLZTCP",72,0)
3382
I '$D(HLDTOUT),'HLERR D SENDNAK G CHKREC
3383
"RTN","HLZTCP",73,0)
3384
I '$D(HLDTOUT) U HLZIO K HLERR D ^HLCHK
3385
"RTN","HLZTCP",74,0)
3386
U HLZIO
3387
"RTN","HLZTCP",75,0)
3388
Q
3389
"RTN","HLZTCP",76,0)
3390
;
3391
"RTN","HLZTCP",77,0)
3392
CHKSEND ; Check if there are HL7 messages to send
3393
"RTN","HLZTCP",78,0)
3394
; Set flag to send state.
3395
"RTN","HLZTCP",79,0)
3396
S HLZSTATE="send"
3397
"RTN","HLZTCP",80,0)
3398
Q:'$D(HLNDAP)
3399
"RTN","HLZTCP",81,0)
3400
I '$D(HLNDAP0) S HLNDAP0=$G(^HL(770,HLNDAP,0))
3401
"RTN","HLZTCP",82,0)
3402
S HLDA=+$O(^HL(772,"AC","O",+$P(HLNDAP0,U,12),0)) G:'HLDA EX
3403
"RTN","HLZTCP",83,0)
3404
S HLDA0=$G(^HL(772,HLDA,0)) G:HLDA0']"" EX
3405
"RTN","HLZTCP",84,0)
3406
S HLXMZ=+$P(HLDA0,"^",5)
3407
"RTN","HLZTCP",85,0)
3408
I 'HLXMZ D G EX
3409
"RTN","HLZTCP",86,0)
3410
. D STATUS^HLTF0(HLDA,4,"","No pointer to Message file(#3.9)")
3411
"RTN","HLZTCP",87,0)
3412
I '$D(^XMB(3.9,HLXMZ)) D G EX
3413
"RTN","HLZTCP",88,0)
3414
. D STATUS^HLTF0(HLDA,4,"","No message found at #"_HLXMZ_" in Message file(#3.9)")
3415
"RTN","HLZTCP",89,0)
3416
I '$O(^XMB(3.9,HLXMZ,2,0)) D G EX
3417
"RTN","HLZTCP",90,0)
3418
. D STATUS^HLTF0(HLDA,4,"","No message contents at #"_HLXMZ_" in Message file(#3.9)")
3419
"RTN","HLZTCP",91,0)
3420
S (HLI,HLTRIED)=0,HLSDT=+HLDA0
3421
"RTN","HLZTCP",92,0)
3422
F HLJ=1:1 S HLI=$O(^XMB(3.9,HLXMZ,2,HLI)) Q:HLI'>0 S ^TMP("HLS",$J,HLSDT,HLJ)=$G(^XMB(3.9,HLXMZ,2,HLI,0))
3423
"RTN","HLZTCP",93,0)
3424
CS1 S HLTRIED=HLTRIED+1
3425
"RTN","HLZTCP",94,0)
3426
K ^TMP("HLR",$J),HLSDATA
3427
"RTN","HLZTCP",95,0)
3428
D SEND
3429
"RTN","HLZTCP",96,0)
3430
; Set flag to awaiting acknowledgement state.
3431
"RTN","HLZTCP",97,0)
3432
S HLZSTATE="awaiting ack"
3433
"RTN","HLZTCP",98,0)
3434
D REC
3435
"RTN","HLZTCP",99,0)
3436
I HLTRIED'=HLTRIES G CS1:$D(HLDTOUT) G CS1:HLZNAK
3437
"RTN","HLZTCP",100,0)
3438
G EX:$D(HLDTOUT)
3439
"RTN","HLZTCP",101,0)
3440
I HLZNAK D G EX
3441
"RTN","HLZTCP",102,0)
3442
. S HLAC=4,HLMSG="Lower Level Protocol Error - "_$S($E(HLL(1))="X":"Checksum",1:"Character Count")_" Did Not Match"
3443
"RTN","HLZTCP",103,0)
3444
. D STATUS^HLTF0(HLDA,HLAC,HLMSG)
3445
"RTN","HLZTCP",104,0)
3446
I $S('$D(HLL(1)):1,"BHS,MSH"'[$E(HLL(1),1,3):1,1:0) D G EX
3447
"RTN","HLZTCP",105,0)
3448
. S HLAC=4,HLMSG="Application Level error - Header Segment Missing"
3449
"RTN","HLZTCP",106,0)
3450
. D STATUS^HLTF0(HLDA,HLAC,HLMSG)
3451
"RTN","HLZTCP",107,0)
3452
K HLXMZ
3453
"RTN","HLZTCP",108,0)
3454
U HLZIO
3455
"RTN","HLZTCP",109,0)
3456
D CHK^HLCHK,IN^HLTF(HLMTN,HLMID,HLTIME)
3457
"RTN","HLZTCP",110,0)
3458
;
3459
"RTN","HLZTCP",111,0)
3460
EX K HLAC,HLDA,HLDA0,HLERR,HLMSG,HLI,HLJ,HLSDATA,HLSDT,HLTRIED
3461
"RTN","HLZTCP",112,0)
3462
K ^TMP("HLS",$J),^TMP("HLR",$J)
3463
"RTN","HLZTCP",113,0)
3464
Q
3465
"RTN","HLZTCP",114,0)
3466
;
3467
"RTN","HLZTCP",115,0)
3468
CSUM ;Calculate Checksum
3469
"RTN","HLZTCP",116,0)
3470
S HLC1=HLC1+$L(X),X=X_HLC2 X HLLPC S HLC2=$C(Y)
3471
"RTN","HLZTCP",117,0)
3472
Q
3473
"RTN","HLZTCP",118,0)
3474
;
3475
"RTN","HLZTCP",119,0)
3476
REC ;Receive a Message
3477
"RTN","HLZTCP",120,0)
3478
S %=$$NOW^XLFDT
3479
"RTN","HLZTCP",121,0)
3480
I HLTIME<% S HLTIME=%
3481
"RTN","HLZTCP",122,0)
3482
E S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
3483
"RTN","HLZTCP",123,0)
3484
I HLLOG F Q:'$D(^TMP("HL",HLION,HLTIME)) S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
3485
"RTN","HLZTCP",124,0)
3486
K HLL,^TMP("HLR",$J)
3487
"RTN","HLZTCP",125,0)
3488
S (HLC2,X0)="",(HLC1,HLI,HLK,HLZEB,HLZNAK)=0
3489
"RTN","HLZTCP",126,0)
3490
U HLZIO(0)
3491
"RTN","HLZTCP",127,0)
3492
F R X1#1:DTIME Q:X1=$C(11) I '$T S HLDTOUT=1 Q
3493
"RTN","HLZTCP",128,0)
3494
; Did not find "Start of block" character.
3495
"RTN","HLZTCP",129,0)
3496
I X1'=$C(11) Q
3497
"RTN","HLZTCP",130,0)
3498
S X0=X1,HLZLEN=1
3499
"RTN","HLZTCP",131,0)
3500
REC1 U HLZIO(0) K HLDTOUT
3501
"RTN","HLZTCP",132,0)
3502
R X1#1:DTIME I '$T S HLDTOUT=1
3503
"RTN","HLZTCP",133,0)
3504
; Timed out and buffer empty.
3505
"RTN","HLZTCP",134,0)
3506
I $G(HLDTOUT),'$L(X1) Q
3507
"RTN","HLZTCP",135,0)
3508
;
3509
"RTN","HLZTCP",136,0)
3510
S X0=X0_X1,HLZLEN=HLZLEN+1
3511
"RTN","HLZTCP",137,0)
3512
; Set "NAK" block type flag.
3513
"RTN","HLZTCP",138,0)
3514
I X1="N",HLZLEN=2 S HLZNAK=1
3515
"RTN","HLZTCP",139,0)
3516
; Set "End Block" flag.
3517
"RTN","HLZTCP",140,0)
3518
I X1=$C(28) S HLZEB=1
3519
"RTN","HLZTCP",141,0)
3520
I X1'=$C(13) G REC1
3521
"RTN","HLZTCP",142,0)
3522
I HLZEB,HLZNAK D RECNAK Q
3523
"RTN","HLZTCP",143,0)
3524
;
3525
"RTN","HLZTCP",144,0)
3526
; Process "End Block" if not a "NAK" record.
3527
"RTN","HLZTCP",145,0)
3528
I HLZEB S HLC=+$E(X0,6,8),HLB=+$E(X0,1,5),X0=""
3529
"RTN","HLZTCP",146,0)
3530
I $L(X0) D
3531
"RTN","HLZTCP",147,0)
3532
. I HLLOG D ;Record Incoming Transmission in Log
3533
"RTN","HLZTCP",148,0)
3534
. . S HLII=X0 S:$P(X0,$E(X0,5))="MSH" $P(X0,$E(X0,5),8)=""
3535
"RTN","HLZTCP",149,0)
3536
. . S HLI=HLI+1,^TMP("HL",HLION,HLTIME,"REC",HLI)=$TR(X0,$C(11,13)),X0=HLII
3537
"RTN","HLZTCP",150,0)
3538
. I HLK,HLK'>2 S HLL(HLK)=$TR(X0,$C(11,13))
3539
"RTN","HLZTCP",151,0)
3540
. I HLK S ^TMP("HLR",$J,HLTIME,HLK)=$TR(X0,$C(11,13))
3541
"RTN","HLZTCP",152,0)
3542
. S HLK=HLK+1,X=X0 D CSUM
3543
"RTN","HLZTCP",153,0)
3544
. S X0=""
3545
"RTN","HLZTCP",154,0)
3546
I 'HLZEB G REC1
3547
"RTN","HLZTCP",155,0)
3548
S X=HLC2 X HLLPC S HLCSUM=Y,HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
3549
"RTN","HLZTCP",156,0)
3550
I HLLOG S ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
3551
"RTN","HLZTCP",157,0)
3552
Q
3553
"RTN","HLZTCP",158,0)
3554
;
3555
"RTN","HLZTCP",159,0)
3556
RECNAK ; Process Received "NAK" message.
3557
"RTN","HLZTCP",160,0)
3558
S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
3559
"RTN","HLZTCP",161,0)
3560
S HLC=+$E(X0,7,9),HLB=+$E(X0,2,6),X=$E(X0,1) D CSUM
3561
"RTN","HLZTCP",162,0)
3562
S X=HLC2 X HLLPC S HLCSUM=Y,HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
3563
"RTN","HLZTCP",163,0)
3564
S HLL(1)=$TR(X0,$C(11,13,28)),^TMP("HLR",$J,HLTIME,1)=HLL(1)
3565
"RTN","HLZTCP",164,0)
3566
I HLLOG D
3567
"RTN","HLZTCP",165,0)
3568
. S ^TMP("HL",HLION,HLTIME,"REC",1)=HLL(1)
3569
"RTN","HLZTCP",166,0)
3570
. S ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
3571
"RTN","HLZTCP",167,0)
3572
Q
3573
"RTN","HLZTCP",168,0)
3574
;
3575
"RTN","HLZTCP",169,0)
3576
SEND ;Send a Message
3577
"RTN","HLZTCP",170,0)
3578
N X,Y
3579
"RTN","HLZTCP",171,0)
3580
S %=$$NOW^XLFDT
3581
"RTN","HLZTCP",172,0)
3582
I HLTIME<% S HLTIME=%
3583
"RTN","HLZTCP",173,0)
3584
E S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
3585
"RTN","HLZTCP",174,0)
3586
I HLLOG F Q:'$D(^TMP("HL",HLION,HLTIME)) S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
3587
"RTN","HLZTCP",175,0)
3588
S (HLI,HLC1)=0,HLC2=""
3589
"RTN","HLZTCP",176,0)
3590
D WRITE($C(11)_"D21"_$C(13))
3591
"RTN","HLZTCP",177,0)
3592
I '$D(HLSDT) F S HLI=$O(HLSDATA(HLI)) Q:HLI="" D WRITE(HLSDATA(HLI)_$C(13))
3593
"RTN","HLZTCP",178,0)
3594
I $D(HLSDT) F S HLI=$O(^TMP("HLS",$J,HLSDT,HLI)) Q:HLI="" S HLSDATA=^(HLI) D WRITE(HLSDATA_$C(13))
3595
"RTN","HLZTCP",179,0)
3596
D FLUSH
3597
"RTN","HLZTCP",180,0)
3598
Q
3599
"RTN","HLZTCP",181,0)
3600
;
3601
"RTN","HLZTCP",182,0)
3602
SENDNAK ; Send a "NAK" message.
3603
"RTN","HLZTCP",183,0)
3604
S (HLC1,HLI)=0,HLC2="",HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
3605
"RTN","HLZTCP",184,0)
3606
D WRITE($C(11)_"N21"_$C(13)_HLERR)
3607
"RTN","HLZTCP",185,0)
3608
D FLUSH
3609
"RTN","HLZTCP",186,0)
3610
K HLSDATA,HLERR
3611
"RTN","HLZTCP",187,0)
3612
Q
3613
"RTN","HLZTCP",188,0)
3614
;
3615
"RTN","HLZTCP",189,0)
3616
WRITE(X) ; Write data in buffer.
3617
"RTN","HLZTCP",190,0)
3618
U HLZIO(0)
3619
"RTN","HLZTCP",191,0)
3620
W X,!
3621
"RTN","HLZTCP",192,0)
3622
I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND",HLI)=$TR(X,$C(11,13))
3623
"RTN","HLZTCP",193,0)
3624
D CSUM
3625
"RTN","HLZTCP",194,0)
3626
Q
3627
"RTN","HLZTCP",195,0)
3628
;
3629
"RTN","HLZTCP",196,0)
3630
FLUSH ; Write checksum and flush buffer.
3631
"RTN","HLZTCP",197,0)
3632
S X=HLC2 X HLLPC S X=$E("0000",1,(5-$L(HLC1)))_HLC1_$E("00",1,(3-$L(Y)))_Y_$C(28)_$C(13)
3633
"RTN","HLZTCP",198,0)
3634
U HLZIO(0)
3635
"RTN","HLZTCP",199,0)
3636
; Do final write for this block and flush buffer.
3637
"RTN","HLZTCP",200,0)
3638
W X,!
3639
"RTN","HLZTCP",201,0)
3640
I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND","CKS")=$TR(X,$C(11,13,28))
3641
"RTN","HLZTCP",202,0)
3642
Q
3643
"RTN","MAGDMEDL")
3644
0^36^B3132920
3645
"RTN","MAGDMEDL",1,0)
3646
MAGDMEDL ;WOIFO/LB,MSC/JDA - Routine to look up entries in the Medicine files ;27APR2009
3647
"RTN","MAGDMEDL",2,0)
3648
;;3.0;IMAGING;**MSC**;Mar 01, 2002
3649
"RTN","MAGDMEDL",3,0)
3650
;; +---------------------------------------------------------------+
3651
"RTN","MAGDMEDL",4,0)
3652
;; | Property of the US Government. |
3653
"RTN","MAGDMEDL",5,0)
3654
;; | No permission to copy or redistribute this software is given. |
3655
"RTN","MAGDMEDL",6,0)
3656
;; | Use of unreleased versions of this software requires the user |
3657
"RTN","MAGDMEDL",7,0)
3658
;; | to execute a written test agreement with the VistA Imaging |
3659
"RTN","MAGDMEDL",8,0)
3660
;; | Development Office of the Department of Veterans Affairs, |
3661
"RTN","MAGDMEDL",9,0)
3662
;; | telephone (301) 734-0100. |
3663
"RTN","MAGDMEDL",10,0)
3664
;; | |
3665
"RTN","MAGDMEDL",11,0)
3666
;; | The Food and Drug Administration classifies this software as |
3667
"RTN","MAGDMEDL",12,0)
3668
;; | a medical device. As such, it may not be changed in any way. |
3669
"RTN","MAGDMEDL",13,0)
3670
;; | Modifications to this software may result in an adulterated |
3671
"RTN","MAGDMEDL",14,0)
3672
;; | medical device under 21CFR820, the use of which is considered |
3673
"RTN","MAGDMEDL",15,0)
3674
;; | to be a violation of US Federal Statutes. |
3675
"RTN","MAGDMEDL",16,0)
3676
;; +---------------------------------------------------------------+
3677
"RTN","MAGDMEDL",17,0)
3678
;;
3679
"RTN","MAGDMEDL",18,0)
3680
Q
3681
"RTN","MAGDMEDL",19,0)
3682
SELECT(ITEM,ARRAY) ;
3683
"RTN","MAGDMEDL",20,0)
3684
;
3685
"RTN","MAGDMEDL",21,0)
3686
SELECT2
3687
"RTN","MAGDMEDL",22,0)
3688
N CNT,DIR,DIROUT,DIRUT,ENTRY
3689
"RTN","MAGDMEDL",23,0)
3690
S CNT=+ARRAY
3691
"RTN","MAGDMEDL",24,0)
3692
I 'CNT Q 0
3693
"RTN","MAGDMEDL",25,0)
3694
S DIR(0)="NO^1:"_CNT,DIR("A")="Select a Medicine Procedure"
3695
"RTN","MAGDMEDL",26,0)
3696
S DIR("T")=600 D ^DIR
3697
"RTN","MAGDMEDL",27,0)
3698
I $D(DIRUT)!($D(DIROUT)) Q 0
3699
"RTN","MAGDMEDL",28,0)
3700
S ENTRY=+Y
3701
"RTN","MAGDMEDL",29,0)
3702
I '$D(ARRAY(ENTRY)) D G SELECT2
3703
"RTN","MAGDMEDL",30,0)
3704
. W !,"Please select an entry or use '^' to exit"
3705
"RTN","MAGDMEDL",31,0)
3706
W !,"You have selected ",$P(ARRAY(ENTRY),"^"),"."
3707
"RTN","MAGDMEDL",32,0)
3708
Q $P(ARRAY(ENTRY),"^",2)
3709
"RTN","MAGDMEDL",33,0)
3710
;
3711
"RTN","MAGDMEDL",34,0)
3712
LOOP(ARRAY,MAGPAT,SUB,CASEDT) ;
3713
"RTN","MAGDMEDL",35,0)
3714
; MAGPAT = patient's dfn
3715
"RTN","MAGDMEDL",36,0)
3716
; SUB = Medicine specialty
3717
"RTN","MAGDMEDL",37,0)
3718
; CASEDT = case date
3719
"RTN","MAGDMEDL",38,0)
3720
; array(0)= 1 or 0 ^ # entries found ^ message text
3721
"RTN","MAGDMEDL",39,0)
3722
; array(#)= formatted out dislay without delimeters
3723
"RTN","MAGDMEDL",40,0)
3724
; array(#,1) = internal stored values
3725
"RTN","MAGDMEDL",41,0)
3726
; Variable MAGDIMG
3727
"RTN","MAGDMEDL",42,0)
3728
S ARRAY(0)="0^^No entries found"
3729
"RTN","MAGDMEDL",43,0)
3730
Q:'MAGPAT
3731
"RTN","MAGDMEDL",44,0)
3732
Q:'$D(MAGMC)#10 ;Array should be available.
3733
"RTN","MAGDMEDL",45,0)
3734
N BEG,CDT,CNT,DATA,DIOCM,EN,END,IMG,IMAGEPTR,MAGDIMG,PATIENT,PATNME,PRCNM,SSN,THEDT,X1,X2,X
3735
"RTN","MAGDMEDL",46,0)
3736
N IEN,II,IOUT,MAGMC,MEDFILE
3737
"RTN","MAGDMEDL",47,0)
3738
Q:'$$FIND1^DIC(2,,"A",MAGPAT,"","")
3739
"RTN","MAGDMEDL",48,0)
3740
S PATNME=$P(^DPT(MAGPAT,0),"^"),SSN=$P(^(0),"^",9)
3741
"RTN","MAGDMEDL",49,0)
3742
S PATIENT=PATNME_" "_SSN
3743
"RTN","MAGDMEDL",50,0)
3744
I 'CASEDT S CASEDT=DT
3745
"RTN","MAGDMEDL",51,0)
3746
S X1=CASEDT,X2=-3 D C^%DTC S BEG=X
3747
"RTN","MAGDMEDL",52,0)
3748
S END=CASEDT+.9999
3749
"RTN","MAGDMEDL",53,0)
3750
S CNT=0,CDT=BEG-.001
3751
"RTN","MAGDMEDL",54,0)
3752
F S CDT=$O(MAGMC(MAGPAT,SUB,CDT)) Q:'CDT!(CDT>END) D
3753
"RTN","MAGDMEDL",55,0)
3754
. S EN=0 F S EN=$O(MAGMC(MAGPAT,SUB,CDT,EN)) Q:'EN D
3755
"RTN","MAGDMEDL",56,0)
3756
. . S DATA=MAGMC(MAGPAT,SUB,CDT,EN)
3757
"RTN","MAGDMEDL",57,0)
3758
. . S PRCNM=$P(DATA,"^",2),PRC=SUB
3759
"RTN","MAGDMEDL",58,0)
3760
. . S THEDT=$P(DATA,"^"),IEN=$P(DATA,"^",5)
3761
"RTN","MAGDMEDL",59,0)
3762
. . I $D(MAGMC(MAGPAT,SUB,CDT,EN,2005)) S (IOUT,II)=0 D
3763
"RTN","MAGDMEDL",60,0)
3764
. . . F S II=$O(MAGMC(MAGPAT,SUB,CDT,EN,2005,II)) Q:'II!IOUT D
3765
"RTN","MAGDMEDL",61,0)
3766
. . . . S IMAGEPTR=MAGMC(MAGPAT,SUB,CDT,EN,2005,II)
3767
"RTN","MAGDMEDL",62,0)
3768
. . . . I '$D(^MAG(2005,IMAGEPTR)) S IMAGEPTR="" Q
3769
"RTN","MAGDMEDL",63,0)
3770
. . . . I '$D(^MAG(2005,IMAGEPTR,"PACS")) S IMAGEPTR="",IOUT=1
3771
"RTN","MAGDMEDL",64,0)
3772
. . S MEDFILE=$P(DATA,"^",4),MEDFILE=$P(MEDFILE,"MCAR(",2)
3773
"RTN","MAGDMEDL",65,0)
3774
. . S DICOM="" D DICOMID^MAGDMEDI(.DICOM,MEDFILE,IEN,PRC,MAGPAT)
3775
"RTN","MAGDMEDL",66,0)
3776
. . I DICOM'="" D
3777
"RTN","MAGDMEDL",67,0)
3778
. . . S DICOM=$P(DICOM,":",2)
3779
"RTN","MAGDMEDL",68,0)
3780
. . . S CNT=CNT+1
3781
"RTN","MAGDMEDL",69,0)
3782
. . . S ARRAY(CNT)=DICOM_" "_PRCNM_", "_THEDT_" "_PATIENT
3783
"RTN","MAGDMEDL",70,0)
3784
. . . S ARRAY(CNT,1)=DICOM_"^"_PATNME_"^"_SSN_"^"_EN_"^"_PRCNM_"^"_PRC_"^"_$G(IMAGEPTR)_"^"_MEDFILE
3785
"RTN","MAGDMEDL",71,0)
3786
I CNT S ARRAY(0)="1^"_CNT_"^Medicine file entries for "_PATIENT
3787
"RTN","MAGDMEDL",72,0)
3788
Q
3789
"RTN","MAGDMEDL",73,0)
3790
DISPLAY(ARRAY) ;
3791
"RTN","MAGDMEDL",74,0)
3792
; Call routine needs to pass array in the following sequence
3793
"RTN","MAGDMEDL",75,0)
3794
; ARRAY(0)= 1 or 0 ^ #entries ^ message
3795
"RTN","MAGDMEDL",76,0)
3796
; ARRAY(#)= Formatted output to be displayed.
3797
"RTN","MAGDMEDL",77,0)
3798
; Will set the RES variable for selected entry.
3799
"RTN","MAGDMEDL",78,0)
3800
I '$D(ARRAY(0)) Q 0
3801
"RTN","MAGDMEDL",79,0)
3802
; If only one entry return the subscript variable.
3803
"RTN","MAGDMEDL",80,0)
3804
I $P(ARRAY(0),"^",2)=1 Q 1
3805
"RTN","MAGDMEDL",81,0)
3806
I $P(ARRAY(0),"^")'=1 Q 0
3807
"RTN","MAGDMEDL",82,0)
3808
N ENTRY,ITEM,ITEMS,MSG,OUT,OUTPUT,RES
3809
"RTN","MAGDMEDL",83,0)
3810
S RES=0,MSG=$P(ARRAY(0),"^",3)
3811
"RTN","MAGDMEDL",84,0)
3812
S IOF="#,$C(27,91,72,27,91,74,8,8,8,8)",IO=0,IOSL=24,POP=0
3813
"RTN","MAGDMEDL",85,0)
3814
D HEAD
3815
"RTN","MAGDMEDL",86,0)
3816
S (ENTRY,OUT)=0,ITEMS=$P(ARRAY(0),"^",2)
3817
"RTN","MAGDMEDL",87,0)
3818
F S ENTRY=$O(ARRAY(ENTRY)) Q:'ENTRY!OUT D
3819
"RTN","MAGDMEDL",88,0)
3820
. S OUTPUT=$G(ARRAY(ENTRY))
3821
"RTN","MAGDMEDL",89,0)
3822
. D:$Y+3>IOSL HEAD D LINE
3823
"RTN","MAGDMEDL",90,0)
3824
. D:$Y+3>IOSL ASKQ
3825
"RTN","MAGDMEDL",91,0)
3826
I 'OUT D ASKQ S RES=ITEM
3827
"RTN","MAGDMEDL",92,0)
3828
Q RES
3829
"RTN","MAGDMEDL",93,0)
3830
HEAD ;
3831
"RTN","MAGDMEDL",94,0)
3832
W:$Y+3>IOSL @IOF W !,MSG
3833
"RTN","MAGDMEDL",95,0)
3834
Q
3835
"RTN","MAGDMEDL",96,0)
3836
LINE ;
3837
"RTN","MAGDMEDL",97,0)
3838
W !,ENTRY,".) "_OUTPUT
3839
"RTN","MAGDMEDL",98,0)
3840
Q
3841
"RTN","MAGDMEDL",99,0)
3842
ASKQ ;
3843
"RTN","MAGDMEDL",100,0)
3844
N X,Y,DIR
3845
"RTN","MAGDMEDL",101,0)
3846
S DIR(0)="L^1:"_$S('ENTRY:ITEMS,1:ENTRY)
3847
"RTN","MAGDMEDL",102,0)
3848
S DIR("T")=600,DIR("A")="Select an entry: " D ^DIR
3849
"RTN","MAGDMEDL",103,0)
3850
S ITEM=+Y
3851
"RTN","MAGDMEDL",104,0)
3852
Q:$D(DIRUT)!($D(DIROUT))
3853
"RTN","MAGDMEDL",105,0)
3854
Q:'ITEM
3855
"RTN","MAGDMEDL",106,0)
3856
I '$D(ARRAY(ITEM)) W !,"Please select an entry or '^' to exit" G ASKQ
3857
"RTN","MAGDMEDL",107,0)
3858
W !,"You have selected ",$P($G(ARRAY(ITEM)),"^")
3859
"RTN","MAGDMEDL",108,0)
3860
S OUT=1
3861
"RTN","MAGDMEDL",109,0)
3862
Q
3863
"RTN","MAGDMEDL",110,0)
3864
ASKMORE() ;
3865
"RTN","MAGDMEDL",111,0)
3866
N DIR,DATE,X,XX,Y
3867
"RTN","MAGDMEDL",112,0)
3868
Q:'$D(MAGPAT)
3869
"RTN","MAGDMEDL",113,0)
3870
Q:'$D(SUB)
3871
"RTN","MAGDMEDL",114,0)
3872
S DIR(0)="Y",DIR("B")="NO"
3873
"RTN","MAGDMEDL",115,0)
3874
S DIR("A")="Search further"
3875
"RTN","MAGDMEDL",116,0)
3876
D ^DIR K DIR
3877
"RTN","MAGDMEDL",117,0)
3878
I 'Y Q 0
3879
"RTN","MAGDMEDL",118,0)
3880
W !,"Search will include 3 days prior to the day specified."
3881
"RTN","MAGDMEDL",119,0)
3882
S DIR(0)="D^::EXP" D ^DIR
3883
"RTN","MAGDMEDL",120,0)
3884
; Y2K compliance all calls to %DT must have either past or future date
3885
"RTN","MAGDMEDL",121,0)
3886
I 'Y Q 0
3887
"RTN","MAGDMEDL",122,0)
3888
S DATE=Y
3889
"RTN","MAGDMEDL",123,0)
3890
D LOOP(.XX,MAGPAT,SUB,DATE)
3891
"RTN","MAGDMEDL",124,0)
3892
I $D(XX(0)),$P(XX(0),"^")=0 D Q 0
3893
"RTN","MAGDMEDL",125,0)
3894
. W "No entries found."
3895
"RTN","MAGDMEDL",126,0)
3896
Q 1
3897
"RTN","MSCGUX53")
3898
0^^B360592
3899
"RTN","MSCGUX53",1,0)
3900
MSCGUX53 ;MSC/JDS - ENVIRONMENT CHECK ; ; 29 Apr 2009 1:47 PM
3901
"RTN","MSCGUX53",2,0)
3902
;;**MSC**;
3903
"RTN","MSCGUX53",3,0)
3904
I $G(^%ZOSF("OS"))'["GT.M" Q ;Not GTM
3905
"RTN","MSCGUX53",4,0)
3906
I $P($ZV,"V",2)<5.3 D MESS^XPDUL("GT.M version must be 5.3 or Greater") S XPDABORT=2
3907
"RTN","MSCGUX53",5,0)
3908
3909
"RTN","MSCGUX53",6,0)
3910
3911
"RTN","MSCGUX53",7,0)
3912
3913
"RTN","MSCXUS3A")
3914
0^31^B9453784
3915
"RTN","MSCXUS3A",1,0)
3916
MSCXUS3A ;SF-ISC/STAFF MSC/JDS,JKT - CHANGE UCI'S ;1DEC2009
3917
"RTN","MSCXUS3A",2,0)
3918
;;8.0;KERNEL;**13,282,MSC**;Jul 10, 1995
3919
"RTN","MSCXUS3A",3,0)
3920
Q
3921
"RTN","MSCXUS3A",4,0)
3922
;PICK A UCI TO SWITCH TO
3923
"RTN","MSCXUS3A",5,0)
3924
SWITCH ;Allow users that have the UCI fIeld In there NP fIle to swItch UCI's.
3925
"RTN","MSCXUS3A",6,0)
3926
W !!,"Switch UCI's optIon.",!
3927
"RTN","MSCXUS3A",7,0)
3928
;I $$PROGMODE^%ZOSV() W !,$C(7),"No switching UCI's In Programmer Mode." Q
3929
"RTN","MSCXUS3A",8,0)
3930
N DIR,X,Y,PGM,%UCI,DEF,L,USERNAME
3931
"RTN","MSCXUS3A",9,0)
3932
S DEF="ZU" ;DEF is default routine to swItch to.
3933
"RTN","MSCXUS3A",10,0)
3934
UCI Q:'$G(DUZ) S USERNAME=$P($G(^VA(200,DUZ,0)),U) Q:USERNAME=""
3935
"RTN","MSCXUS3A",11,0)
3936
S DIR(0)="S^"_$$NSP(USERNAME) I DIR(0)'[";" W "YOU AREN'T A USER IN ANY OTHER NAMESPACE" Q
3937
"RTN","MSCXUS3A",12,0)
3938
S DIR("A")="Select NAMESPACE"
3939
"RTN","MSCXUS3A",13,0)
3940
D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) Q
3941
"RTN","MSCXUS3A",14,0)
3942
SAME I X="" Q ;Didn't select anythIng.
3943
"RTN","MSCXUS3A",15,0)
3944
;D PM
3945
"RTN","MSCXUS3A",16,0)
3946
S (MSCX,X,%UCI)=Y(0) X ^%ZOSF("UCICHECK") I 0[Y G BAD
3947
"RTN","MSCXUS3A",17,0)
3948
I ^%ZOSF("OS")["GT.M" D
3949
"RTN","MSCXUS3A",18,0)
3950
. N %ZG,%ZRO
3951
"RTN","MSCXUS3A",19,0)
3952
. D NEWZGZRO^ZCD(Y(0))
3953
"RTN","MSCXUS3A",20,0)
3954
. S (X,%UCI)=%ZG
3955
"RTN","MSCXUS3A",21,0)
3956
K XQY0 S Y=$O(^[%UCI]VA(200,"B",USERNAME,0))
3957
"RTN","MSCXUS3A",22,0)
3958
I Y S DIR=$P($G(^[%UCI]VA(200,Y,201)),U)
3959
"RTN","MSCXUS3A",23,0)
3960
I DIR,$P($G(^[%UCI]DIC(19,DIR,0)),U,4)="M" S DUZ=Y,XQY=DIR,(DEF,PGM)="M^XQ" G NXT
3961
"RTN","MSCXUS3A",24,0)
3962
BAD W !,"UCI not found!" D SHOW G UCI
3963
"RTN","MSCXUS3A",25,0)
3964
;
3965
"RTN","MSCXUS3A",26,0)
3966
NXT ;Here we go.
3967
"RTN","MSCXUS3A",27,0)
3968
D C^XUSCLEAN K ^XUTL("XQ",$J),^XUTL($J),^TMP($J),^UTILITY($J)
3969
"RTN","MSCXUS3A",28,0)
3970
I $G(^%ZOSF("OS"))["GT.M" S A=$$SWITCH^ZCD(MSCX) K ^XUTL("XQ",$J),^UTILITY($J) S ^XUTL("XQ",$J,"T")=0,^("XQM")=XQY,XQTT=0 G @(PGM) Q
3971
"RTN","MSCXUS3A",29,0)
3972
K DA G GO^%MSCXUCI
3973
"RTN","MSCXUS3A",30,0)
3974
;
3975
"RTN","MSCXUS3A",31,0)
3976
;
3977
"RTN","MSCXUS3A",32,0)
3978
SHOW W ! S I=0,UC="",X=$S($D(^VA(200,DUZ,201)):+^(201),1:0)
3979
"RTN","MSCXUS3A",33,0)
3980
W !,"Enter ^ to return to your current menu, or select from:"
3981
"RTN","MSCXUS3A",34,0)
3982
F I=0:0 S I=$O(^VA(200,DUZ,.2,I)) Q:I'>0 D
3983
"RTN","MSCXUS3A",35,0)
3984
. W !,?5 S UC=$G(^VA(200,DUZ,.2,I,0)),X=$P(UC,U,1),UC=$P(UC,U,2,99)
3985
"RTN","MSCXUS3A",36,0)
3986
. I UC'[":" W I
3987
"RTN","MSCXUS3A",37,0)
3988
. D PM W ?10,X X ^%ZOSF("UCICHECK") I 0[Y W " -- Not currently a valId UCI!",$C(7) Q
3989
"RTN","MSCXUS3A",38,0)
3990
. W:UC]"" ":"_UC
3991
"RTN","MSCXUS3A",39,0)
3992
. Q
3993
"RTN","MSCXUS3A",40,0)
3994
Q
3995
"RTN","MSCXUS3A",41,0)
3996
;
3997
"RTN","MSCXUS3A",42,0)
3998
PM I X="PROD"!(X="MGR") S X=^%ZOSF(X)
3999
"RTN","MSCXUS3A",43,0)
4000
Q
4001
"RTN","MSCXUS3A",44,0)
4002
;
4003
"RTN","MSCXUS3A",45,0)
4004
;
4005
"RTN","MSCXUS3A",46,0)
4006
;
4007
"RTN","MSCXUS3A",47,0)
4008
NSP(USERNAME) ;LIST OTHER NAMESPACES WHERE THIS USER IS
4009
"RTN","MSCXUS3A",48,0)
4010
N X,L,I,Y
4011
"RTN","MSCXUS3A",49,0)
4012
X ^%ZOSF("UCI") S Y=$P(Y,",") I ^%ZOSF("OS")["GT.M" Q $$GTMNSP
4013
"RTN","MSCXUS3A",50,0)
4014
X "F I=1:1:$zu(90,0) s L($zu(90,2,0,I))=""""" ;***CACHE-SPECIFIC FROM %NSP
4015
"RTN","MSCXUS3A",51,0)
4016
S (I,L,X)="" F S I=$O(L(I)) Q:I="" I I'=Y D ;NOT THE CURRENT ONE
4017
"RTN","MSCXUS3A",52,0)
4018
.N DUZ S DUZ=$O(^[I]VA(200,"B",USERNAME,0)) Q:'DUZ
4019
"RTN","MSCXUS3A",53,0)
4020
.I $P($G(^[I]VA(200,DUZ,0)),U,3)=""!'$G(^(201)) Q ;THEY MUST HAVE ACCESS CODE AND PRIMARY MENU OPTION OVER THERE
4021
"RTN","MSCXUS3A",54,0)
4022
.S L=L+1,X=X_L_":"_I_";"
4023
"RTN","MSCXUS3A",55,0)
4024
Q X
4025
"RTN","MSCXUS3A",56,0)
4026
GTMNSP() ;
4027
"RTN","MSCXUS3A",57,0)
4028
N CURRENT S CURRENT=Y N Y
4029
"RTN","MSCXUS3A",58,0)
4030
D LIST^ZCD
4031
"RTN","MSCXUS3A",59,0)
4032
S (I,L,X)="" F S I=$O(Y(I)) Q:'I S A=Y(I) I A'=CURRENT D ;NOT THE CURRENT ONE
4033
"RTN","MSCXUS3A",60,0)
4034
.S A=$P($ZG,"/"_$$CURRENT^ZCD_"/")_"/"_A_"/"_$P($ZG,"/"_$$CURRENT^ZCD_"/",2)
4035
"RTN","MSCXUS3A",61,0)
4036
.N DUZ S DUZ=$O(^[A]VA(200,"B",USERNAME,0)) Q:'DUZ
4037
"RTN","MSCXUS3A",62,0)
4038
.I $P($G(^[A]VA(200,DUZ,0)),U,3)=""!'$G(^(201)) Q ;THEY MUST HAVE ACCESS CODE AND PRIMARY MENU OPTION OVER THERE
4039
"RTN","MSCXUS3A",63,0)
4040
.S L=L+1,X=X_L_":"_Y(I)_";"
4041
"RTN","MSCXUS3A",64,0)
4042
Q X
4043
"RTN","MSCZJOB")
4044
0^1^B12965530
4045
"RTN","MSCZJOB",1,0)
4046
MSCZJOB ;GFT,JDS,JKT/MSC;29OCT2009
4047
"RTN","MSCZJOB",2,0)
4048
;;8.0;KERNEL;**MSC**
4049
"RTN","MSCZJOB",3,0)
4050
W !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4051
"RTN","MSCZJOB",4,0)
4052
N MSC
4053
"RTN","MSCZJOB",5,0)
4054
DDS ;
4055
"RTN","MSCZJOB",6,0)
4056
S DDSFILE=3.081,DR="[MSCZJOBEXAM]",DDSPARM="S"
4057
"RTN","MSCZJOB",7,0)
4058
D ^DDS K ^TMP("MSCZJOB1",$J) Q
4059
"RTN","MSCZJOB",8,0)
4060
;
4061
"RTN","MSCZJOB",9,0)
4062
UNLOCK(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
4063
"RTN","MSCZJOB",10,0)
4064
N X,R,N S R=$G(@MSC@(MSCJOBID,"L",D0)) I R'["^" Q ;CAN'T SEE IT
4065
"RTN","MSCZJOB",11,0)
4066
S R=$P(R," ",2),X="L "_R D ^DIM Q:'$D(X)
4067
"RTN","MSCZJOB",12,0)
4068
S N=$$NSP(MSCJOBD0)
4069
"RTN","MSCZJOB",13,0)
4070
D UNLOCK^MSCZJOBU(R,N)
4071
"RTN","MSCZJOB",14,0)
4072
Q
4073
"RTN","MSCZJOB",15,0)
4074
;
4075
"RTN","MSCZJOB",16,0)
4076
KILL(J) ;FROM FIELD
4077
"RTN","MSCZJOB",17,0)
4078
D KILL^MSCZJOBU(J)
4079
"RTN","MSCZJOB",18,0)
4080
Q
4081
"RTN","MSCZJOB",19,0)
4082
;
4083
"RTN","MSCZJOB",20,0)
4084
COMPMUL ;COMPUTED MULTIPLE FOR MSCZJOBEXAM BLOCK
4085
"RTN","MSCZJOB",21,0)
4086
N X,D0,J
4087
"RTN","MSCZJOB",22,0)
4088
S MSC="^TMP(""MSCZJOB1"",$J)" D POLL
4089
"RTN","MSCZJOB",23,0)
4090
D JOBEXAM^MSCZJOBU(MSC)
4091
"RTN","MSCZJOB",24,0)
4092
F D0=0:0 S D0=$O(MSCZJOB(D0)) Q:'D0 D
4093
"RTN","MSCZJOB",25,0)
4094
.S MSCZJOB(D0)=MSCZJOB(D0)_U_$$DEV(D0)_U_$$USER(D0)_U_$$NSP(D0)_U_U_U_U_U_$$ROUTINE(D0)
4095
"RTN","MSCZJOB",26,0)
4096
.S X=MSCZJOB(D0) X DICMX
4097
"RTN","MSCZJOB",27,0)
4098
Q
4099
"RTN","MSCZJOB",28,0)
4100
JOB(D0) Q $P(MSCZJOB(D0),U) ;***
4101
"RTN","MSCZJOB",29,0)
4102
DEV(D0) Q $$FIND(D0,"I","$PRINCIPAL")
4103
"RTN","MSCZJOB",30,0)
4104
NSP(D0) N N D Q N
4105
"RTN","MSCZJOB",31,0)
4106
.N L,P S N=$$FIND(D0,"I","$ZGBLDIR"),L=$L(N,"/") I L<2 Q
4107
"RTN","MSCZJOB",32,0)
4108
.F L=L-1:-1:2 S P=$P(N,"/",L) I P'[".",P'["globals" Q
4109
"RTN","MSCZJOB",33,0)
4110
.S P=1 I $P(N,"/")="" S P=2
4111
"RTN","MSCZJOB",34,0)
4112
.S N=$P(N,"/",L)
4113
"RTN","MSCZJOB",35,0)
4114
USER(D0) Q $P($G(^VA(200,+$$FIND(D0,"V","DUZ"),0)),U)
4115
"RTN","MSCZJOB",36,0)
4116
ROUTINE(D0) Q $$FIND(D0,"V","%ZPOS")
4117
"RTN","MSCZJOB",37,0)
4118
;
4119
"RTN","MSCZJOB",38,0)
4120
FIND(D0,ARR,KEY) N I,J,X S X="",J=+MSCZJOB(D0)
4121
"RTN","MSCZJOB",39,0)
4122
F I=0:0 S I=$O(@MSC@(J,ARR,I)) Q:'I I $P(^(I),KEY_"=")="" S X=$TR($P(^(I),"=",2),"""") Q
4123
"RTN","MSCZJOB",40,0)
4124
Q X
4125
"RTN","MSCZJOB",41,0)
4126
;
4127
"RTN","MSCZJOB",42,0)
4128
COMPSTK ;COMPUTED MULTIPLE FOR MSCZJOBSTACK BLOCK
4129
"RTN","MSCZJOB",43,0)
4130
S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC@(MSCJOBID) D POLL1
4131
"RTN","MSCZJOB",44,0)
4132
D JOBEXAM^MSCZJOBU(MSC,MSCJOBID)
4133
"RTN","MSCZJOB",45,0)
4134
N D0,J S J=MSCJOBID
4135
"RTN","MSCZJOB",46,0)
4136
F D0=1:1:$O(@MSC@(J,"S",""),-1) S X="" X DICMX
4137
"RTN","MSCZJOB",47,0)
4138
Q
4139
"RTN","MSCZJOB",48,0)
4140
;
4141
"RTN","MSCZJOB",49,0)
4142
STACK(D0) N X S X=$G(@MSC@(MSCJOBID,"S",D0))
4143
"RTN","MSCZJOB",50,0)
4144
Q X
4145
"RTN","MSCZJOB",51,0)
4146
;
4147
"RTN","MSCZJOB",52,0)
4148
COMPVARS ;COMPUTED MULTIPLE FOR MSCZJOBVARS BLOCK
4149
"RTN","MSCZJOB",53,0)
4150
S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC@(MSCJOBID) D POLL1
4151
"RTN","MSCZJOB",54,0)
4152
D JOBEXAM^MSCZJOBU(MSC,MSCJOBID)
4153
"RTN","MSCZJOB",55,0)
4154
N D0,J S J=MSCJOBID
4155
"RTN","MSCZJOB",56,0)
4156
F D0=1:1:$O(@MSC@(J,"V",""),-1) S X="" X DICMX
4157
"RTN","MSCZJOB",57,0)
4158
Q
4159
"RTN","MSCZJOB",58,0)
4160
;
4161
"RTN","MSCZJOB",59,0)
4162
COMPLKS ;COMPUTED MULTIPLE FOR MSCZJOBLOCKS BLOCK
4163
"RTN","MSCZJOB",60,0)
4164
S MSC="^TMP(""MSCZJOB1"",$J)" D POLL1
4165
"RTN","MSCZJOB",61,0)
4166
D JOBEXAM^MSCZJOBU(MSC,MSCJOBID)
4167
"RTN","MSCZJOB",62,0)
4168
N D0
4169
"RTN","MSCZJOB",63,0)
4170
F D0=1:1:$$LOCKS S X="" X DICMX
4171
"RTN","MSCZJOB",64,0)
4172
Q
4173
"RTN","MSCZJOB",65,0)
4174
;
4175
"RTN","MSCZJOB",66,0)
4176
LOCKS() Q +$O(@MSC@(MSCJOBID,"L",""),-1)
4177
"RTN","MSCZJOB",67,0)
4178
;
4179
"RTN","MSCZJOB",68,0)
4180
POLL K MSCZJOB ;D HLP^DDSUTL(" POLLING JOBS.....")
4181
"RTN","MSCZJOB",69,0)
4182
I $G(^%ZOSF("OS"))["GT.M" D
4183
"RTN","MSCZJOB",70,0)
4184
.K @MSC
4185
"RTN","MSCZJOB",71,0)
4186
.D INTRPT^MSCZJOBU("*") ;SETS UP ^TMP
4187
"RTN","MSCZJOB",72,0)
4188
.N MSCA,I D PIDS^MSCZJOBU(.MSCA)
4189
"RTN","MSCZJOB",73,0)
4190
.S MSCA="" F I=1:1 S MSCA=$O(MSCA(MSCA)) Q:'MSCA S MSCZJOB(I)=MSCA ;SETS UP LOCAL ARRAY
4191
"RTN","MSCZJOB",74,0)
4192
.H 1 ;WAIT FOR POLLING
4193
"RTN","MSCZJOB",75,0)
4194
D TEST
4195
"RTN","MSCZJOB",76,0)
4196
Q
4197
"RTN","MSCZJOB",77,0)
4198
;
4199
"RTN","MSCZJOB",78,0)
4200
POLL1 Q:'$G(MSCJOBID)
4201
"RTN","MSCZJOB",79,0)
4202
I $G(^%ZOSF("OS"))["GT.M" D
4203
"RTN","MSCZJOB",80,0)
4204
.K @MSC@(MSCJOBID)
4205
"RTN","MSCZJOB",81,0)
4206
.D INTRPT^MSCZJOBU(MSCJOBID) ;SETS UP ^TMP(MSCZJOB)
4207
"RTN","MSCZJOB",82,0)
4208
.H 1 ;WAIT FOR POLLING
4209
"RTN","MSCZJOB",83,0)
4210
D TEST
4211
"RTN","MSCZJOB",84,0)
4212
Q
4213
"RTN","MSCZJOB",85,0)
4214
;
4215
"RTN","MSCZJOB",86,0)
4216
TEST Q
4217
"RTN","MSCZJOB",87,0)
4218
COMPLK ;COMPUTED MULTIPLE FOR MSCZLOCK BLOCK
4219
"RTN","MSCZJOB",88,0)
4220
N X,D0,J
4221
"RTN","MSCZJOB",89,0)
4222
S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC D POLL,JOBEXAM^MSCZJOBU(MSC) S D0=0
4223
"RTN","MSCZJOB",90,0)
4224
F K=0:0 S K=$O(MSCZJOB(K)) Q:'K D
4225
"RTN","MSCZJOB",91,0)
4226
.F J=0:0 S J=$O(^TMP("MSCZJOB1",$J,MSCZJOB(K),"L",J)) Q:'J S A=$TR(^(J),U,"~") D
4227
"RTN","MSCZJOB",92,0)
4228
..S D0=D0+1,MSCZLK(D0)=$P(A,"LOCK ",2,9)_U_$$USER(K)_U_$TR($$ROUTINE(K),U,"~")_"^^"_MSCZJOB(K)
4229
"RTN","MSCZJOB",93,0)
4230
..S X=MSCZLK(D0) X DICMX
4231
"RTN","MSCZJOB",94,0)
4232
Q
4233
"RTN","MSCZJOB",95,0)
4234
LOCK ;
4235
"RTN","MSCZJOB",96,0)
4236
S DDSFILE=3.081,DR="[MSCZLOCK]",DDSPARM="S"
4237
"RTN","MSCZJOB",97,0)
4238
D ^DDS Q
4239
"RTN","MSCZJOB",98,0)
4240
UNL(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
4241
"RTN","MSCZJOB",99,0)
4242
N X,R,N S R=$P($G(MSCZLK(D0)),U),P=$P($G(MSCZLK(D0)),U,5) ;I R'["^" Q ;CAN'T SEE IT
4243
"RTN","MSCZJOB",100,0)
4244
S R=$P(R,"~",2),R="^"_$S(R'["(":$P(R," "),1:$P(R,")")_")"),X="L "_R D ^DIM Q:'$D(X) ;GOOD SYNTAX?
4245
"RTN","MSCZJOB",101,0)
4246
S N=$$NSP(D0)
4247
"RTN","MSCZJOB",102,0)
4248
D UNLOCK^MSCZJOBU(R,N)
4249
"RTN","MSCZJOBS")
4250
0^46^B5731054
4251
"RTN","MSCZJOBS",1,0)
4252
MSCZJOBS ;JKT/MSC - OpenVista System status ;24AUG2009
4253
"RTN","MSCZJOBS",2,0)
4254
;;8.0;KERNEL;**MSC**
4255
"RTN","MSCZJOBS",3,0)
4256
;
4257
"RTN","MSCZJOBS",4,0)
4258
ALL D SS() Q
4259
"RTN","MSCZJOBS",5,0)
4260
THIS D SS(1) Q
4261
"RTN","MSCZJOBS",6,0)
4262
;
4263
"RTN","MSCZJOBS",7,0)
4264
SS(THIS) ;Print GT.M mumps processes
4265
"RTN","MSCZJOBS",8,0)
4266
; If THIS is true, only print processes associated with the current
4267
"RTN","MSCZJOBS",9,0)
4268
; OpenVista instance
4269
"RTN","MSCZJOBS",10,0)
4270
;
4271
"RTN","MSCZJOBS",11,0)
4272
Q:$G(^%ZOSF("OS"))'["GT.M"
4273
"RTN","MSCZJOBS",12,0)
4274
;
4275
"RTN","MSCZJOBS",13,0)
4276
D INTRPT^MSCZJOBU("*") H .5
4277
"RTN","MSCZJOBS",14,0)
4278
;
4279
"RTN","MSCZJOBS",15,0)
4280
N DATETIME S DATETIME=$$HTE^XLFDT($H)
4281
"RTN","MSCZJOBS",16,0)
4282
W #!,?28,"OpenVista System Status"
4283
"RTN","MSCZJOBS",17,0)
4284
W !,?(40-($L(DATETIME)/2)\1),DATETIME
4285
"RTN","MSCZJOBS",18,0)
4286
W !!,?1,"PID/$J",?9,"%CPU",?15,"Device",?32,"Instance",?42,"Routine",?52,"User",?66,"Identity"
4287
"RTN","MSCZJOBS",19,0)
4288
;
4289
"RTN","MSCZJOBS",20,0)
4290
N MSC S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC
4291
"RTN","MSCZJOBS",21,0)
4292
D JOBEXAM^MSCZJOBU(MSC)
4293
"RTN","MSCZJOBS",22,0)
4294
N PID S PID=""
4295
"RTN","MSCZJOBS",23,0)
4296
F S PID=$O(@MSC@(PID)) Q:PID="" D
4297
"RTN","MSCZJOBS",24,0)
4298
. I $G(THIS) Q:$$INSTANCE(PID)'=$$CURRENT^ZCD()
4299
"RTN","MSCZJOBS",25,0)
4300
. W !,$$PID(PID)
4301
"RTN","MSCZJOBS",26,0)
4302
. W ?9,$$PCPU(PID)
4303
"RTN","MSCZJOBS",27,0)
4304
. W ?15,$$DEVICE(PID)
4305
"RTN","MSCZJOBS",28,0)
4306
. W ?32,$$INSTANCE(PID)
4307
"RTN","MSCZJOBS",29,0)
4308
. W ?42,$$ROUTINE(PID)
4309
"RTN","MSCZJOBS",30,0)
4310
. W ?52,$$USER(PID)
4311
"RTN","MSCZJOBS",31,0)
4312
. W ?66,$$IDENT(PID)
4313
"RTN","MSCZJOBS",32,0)
4314
K @MSC
4315
"RTN","MSCZJOBS",33,0)
4316
;
4317
"RTN","MSCZJOBS",34,0)
4318
W !! ZSY "uptime"
4319
"RTN","MSCZJOBS",35,0)
4320
Q
4321
"RTN","MSCZJOBS",36,0)
4322
;
4323
"RTN","MSCZJOBS",37,0)
4324
PID(PID) ;Return process ID formatted for display
4325
"RTN","MSCZJOBS",38,0)
4326
Q $J(PID,7)_$S($J=PID:"*",1:"")
4327
"RTN","MSCZJOBS",39,0)
4328
;
4329
"RTN","MSCZJOBS",40,0)
4330
PCPU(PID) ;Return CPU usage
4331
"RTN","MSCZJOBS",41,0)
4332
Q $J($G(@MSC@(PID,"PCPU")),4)
4333
"RTN","MSCZJOBS",42,0)
4334
;
4335
"RTN","MSCZJOBS",43,0)
4336
DEVICE(PID) ;Return device
4337
"RTN","MSCZJOBS",44,0)
4338
N PRI S PRI=$$FIND(PID,"I","$PRINCIPAL")
4339
"RTN","MSCZJOBS",45,0)
4340
Q:PRI'="0" PRI ; FIXME: this could probably be more general
4341
"RTN","MSCZJOBS",46,0)
4342
;
4343
"RTN","MSCZJOBS",47,0)
4344
; look at devices for sockets
4345
"RTN","MSCZJOBS",48,0)
4346
N SOCK S SOCK=$$FIND(PID,"D"," SOCKET[0]")
4347
"RTN","MSCZJOBS",49,0)
4348
I $P(SOCK," ",3)="LISTENING" Q $P($P(SOCK," PORT=",2)," ")_",LISTENING"
4349
"RTN","MSCZJOBS",50,0)
4350
I $P(SOCK," ",3)="CONNECTED" Q $P($P($P(SOCK," LOCAL=",2)," "),"@",2)_",CONNECTED"
4351
"RTN","MSCZJOBS",51,0)
4352
Q ""
4353
"RTN","MSCZJOBS",52,0)
4354
;
4355
"RTN","MSCZJOBS",53,0)
4356
INSTANCE(PID) ;Return name of OpenVista instance
4357
"RTN","MSCZJOBS",54,0)
4358
N ZG S ZG=$$FIND(PID,"I","$ZGBLDIR")
4359
"RTN","MSCZJOBS",55,0)
4360
Q $P(ZG,"/",$L(ZG,"/")-2)
4361
"RTN","MSCZJOBS",56,0)
4362
;
4363
"RTN","MSCZJOBS",57,0)
4364
ROUTINE(PID) ;Return routine
4365
"RTN","MSCZJOBS",58,0)
4366
Q $P($$FIND(PID,"V","%ZPOS"),"^",2)
4367
"RTN","MSCZJOBS",59,0)
4368
;
4369
"RTN","MSCZJOBS",60,0)
4370
USER(PID) ;Return Linux user
4371
"RTN","MSCZJOBS",61,0)
4372
Q $G(@MSC@(PID,"USER"))
4373
"RTN","MSCZJOBS",62,0)
4374
;
4375
"RTN","MSCZJOBS",63,0)
4376
IDENT(PID) ;Return OpenVista user
4377
"RTN","MSCZJOBS",64,0)
4378
N DUZ S DUZ=+$$FIND(PID,"V","DUZ")
4379
"RTN","MSCZJOBS",65,0)
4380
N ZG S ZG=$$FIND(PID,"I","$ZGBLDIR")
4381
"RTN","MSCZJOBS",66,0)
4382
Q $P($G(^|ZG|VA(200,DUZ,0)),"^")
4383
"RTN","MSCZJOBS",67,0)
4384
;
4385
"RTN","MSCZJOBS",68,0)
4386
FIND(PID,ARR,KEY) ;Return the value of a key in one of the ZSHOW arrays
4387
"RTN","MSCZJOBS",69,0)
4388
N I,X S I="",X=""
4389
"RTN","MSCZJOBS",70,0)
4390
F S I=$O(@MSC@(PID,ARR,I)) Q:'I I $P(@MSC@(PID,ARR,I),KEY_"=")="" S X=$TR($P(@MSC@(PID,ARR,I),"=",2,999),"""") Q
4391
"RTN","MSCZJOBS",71,0)
4392
Q X
4393
"RTN","MSCZJOBU")
4394
0^4^B9589351
4395
"RTN","MSCZJOBU",1,0)
4396
MSCZJOBU ;RHL,JDS,JKT/MSC;29OCT2009
4397
"RTN","MSCZJOBU",2,0)
4398
;;8.0;KERNEL;**MSC**
4399
"RTN","MSCZJOBU",3,0)
4400
;
4401
"RTN","MSCZJOBU",4,0)
4402
; JOB EXAM UTILITIES FOR GT.M
4403
"RTN","MSCZJOBU",5,0)
4404
Q
4405
"RTN","MSCZJOBU",6,0)
4406
PIDS(XARY) ; GET ARRAY OF ALL MUMPS PROCESS
4407
"RTN","MSCZJOBU",7,0)
4408
; XARY PASSED BY REFERENCE
4409
"RTN","MSCZJOBU",8,0)
4410
; RETURNS XARY(PID)=""
4411
"RTN","MSCZJOBU",9,0)
4412
; NOTE: Unix PID=$J for all mumps processes.
4413
"RTN","MSCZJOBU",10,0)
4414
;
4415
"RTN","MSCZJOBU",11,0)
4416
N DEV
4417
"RTN","MSCZJOBU",12,0)
4418
S DEV="psdev"
4419
"RTN","MSCZJOBU",13,0)
4420
OPEN DEV:(COMM="ps -o pid=,pcpu=,user= -C mumps":READONLY)::"PIPE"
4421
"RTN","MSCZJOBU",14,0)
4422
N %I S %I=$I
4423
"RTN","MSCZJOBU",15,0)
4424
U DEV
4425
"RTN","MSCZJOBU",16,0)
4426
;
4427
"RTN","MSCZJOBU",17,0)
4428
N LINE,PID,PCPU,USER
4429
"RTN","MSCZJOBU",18,0)
4430
F R LINE Q:LINE="" D
4431
"RTN","MSCZJOBU",19,0)
4432
. S PID=$E(LINE,1,5) F Q:$E(PID,1)'=" " S PID=$E(PID,2,999) ; strip leading spaces
4433
"RTN","MSCZJOBU",20,0)
4434
. S PCPU=$E(LINE,6,10) F Q:$E(PCPU,1)'=" " S PCPU=$E(PCPU,2,999) ; strip leading spaces
4435
"RTN","MSCZJOBU",21,0)
4436
. S USER=$E(LINE,12,999)
4437
"RTN","MSCZJOBU",22,0)
4438
. S XARY(PID)=""
4439
"RTN","MSCZJOBU",23,0)
4440
. S XARY(PID,"PCPU")=PCPU
4441
"RTN","MSCZJOBU",24,0)
4442
. S XARY(PID,"USER")=USER
4443
"RTN","MSCZJOBU",25,0)
4444
;
4445
"RTN","MSCZJOBU",26,0)
4446
U %I
4447
"RTN","MSCZJOBU",27,0)
4448
C DEV
4449
"RTN","MSCZJOBU",28,0)
4450
Q
4451
"RTN","MSCZJOBU",29,0)
4452
;
4453
"RTN","MSCZJOBU",30,0)
4454
JOBEXAM(XARY,ONEPID) ; GET ARRAY OF JOB EXAM DATA FOR ALL MUMPS PROCESSES
4455
"RTN","MSCZJOBU",31,0)
4456
; XARY is the name of a variable (or global) to merge job exam data into
4457
"RTN","MSCZJOBU",32,0)
4458
;
4459
"RTN","MSCZJOBU",33,0)
4460
; get a list of all OpenVista instances and look up their $ZG values
4461
"RTN","MSCZJOBU",34,0)
4462
N Y D LIST^ZCD
4463
"RTN","MSCZJOBU",35,0)
4464
N INSTANCE S INSTANCE=""
4465
"RTN","MSCZJOBU",36,0)
4466
F S INSTANCE=$O(Y("B",INSTANCE)) Q:INSTANCE="" D
4467
"RTN","MSCZJOBU",37,0)
4468
. N %ZG,%ZRO D NEWZGZRO^ZCD(INSTANCE)
4469
"RTN","MSCZJOBU",38,0)
4470
. S Y("B",INSTANCE)=%ZG
4471
"RTN","MSCZJOBU",39,0)
4472
;
4473
"RTN","MSCZJOBU",40,0)
4474
; get a list of all mumps processes
4475
"RTN","MSCZJOBU",41,0)
4476
N PIDS D PIDS(.PIDS)
4477
"RTN","MSCZJOBU",42,0)
4478
N PID S PID=""
4479
"RTN","MSCZJOBU",43,0)
4480
;
4481
"RTN","MSCZJOBU",44,0)
4482
; clean up data in ^TMP("MSCZJOB") for processes that no longer exist
4483
"RTN","MSCZJOBU",45,0)
4484
F S INSTANCE=$O(Y("B",INSTANCE)) Q:INSTANCE="" D
4485
"RTN","MSCZJOBU",46,0)
4486
. F S PID=$O(^|Y("B",INSTANCE)|TMP("MSCZJOB",PID)) Q:PID="" D
4487
"RTN","MSCZJOBU",47,0)
4488
. . I '$D(PIDS(PID)) K ^|Y("B",INSTANCE)|TMP("MSCZJOB",PID)
4489
"RTN","MSCZJOBU",48,0)
4490
;
4491
"RTN","MSCZJOBU",49,0)
4492
; consolidate data from ^TMP("MSCZJOB") into XARY
4493
"RTN","MSCZJOBU",50,0)
4494
I $G(ONEPID) D GETJOB(ONEPID) Q
4495
"RTN","MSCZJOBU",51,0)
4496
F S PID=$O(PIDS(PID)) Q:PID="" D GETJOB(PID)
4497
"RTN","MSCZJOBU",52,0)
4498
Q
4499
"RTN","MSCZJOBU",53,0)
4500
GETJOB(PID) ; private, to be called from JOBEXAM only
4501
"RTN","MSCZJOBU",54,0)
4502
; search each OpenVista instance for the latest job exam data
4503
"RTN","MSCZJOBU",55,0)
4504
; for PID and merge it into XARY
4505
"RTN","MSCZJOBU",56,0)
4506
N SORTDATE
4507
"RTN","MSCZJOBU",57,0)
4508
F S INSTANCE=$O(Y("B",INSTANCE)) Q:INSTANCE="" D
4509
"RTN","MSCZJOBU",58,0)
4510
. N H S H=$G(^|Y("B",INSTANCE)|TMP("MSCZJOB",PID,0)) Q:H=""
4511
"RTN","MSCZJOBU",59,0)
4512
. S SORTDATE($$SEC^XLFDT(H))=INSTANCE
4513
"RTN","MSCZJOBU",60,0)
4514
N MAXDATE S MAXDATE=$O(SORTDATE(""),-1) Q:MAXDATE=""
4515
"RTN","MSCZJOBU",61,0)
4516
M @XARY@(PID)=^|Y("B",SORTDATE(MAXDATE))|TMP("MSCZJOB",PID)
4517
"RTN","MSCZJOBU",62,0)
4518
S @XARY@(PID,"PCPU")=PIDS(PID,"PCPU")
4519
"RTN","MSCZJOBU",63,0)
4520
S @XARY@(PID,"USER")=PIDS(PID,"USER")
4521
"RTN","MSCZJOBU",64,0)
4522
Q
4523
"RTN","MSCZJOBU",65,0)
4524
;
4525
"RTN","MSCZJOBU",66,0)
4526
INTRPT(PID) ; SEND mupip intrpt to process with PID
4527
"RTN","MSCZJOBU",67,0)
4528
; WHICH CAUSES THE $ZINTERRUPT CODE TO BE EXECUTED.
4529
"RTN","MSCZJOBU",68,0)
4530
; PID PASSED BY VALUE
4531
"RTN","MSCZJOBU",69,0)
4532
; PID CAN BE A SINGLE PID, I.E. $J
4533
"RTN","MSCZJOBU",70,0)
4534
; PID CAN BE A "*" WHICH SENDS AN INTERRUPT TO ALL MUMPS PROCESSES
4535
"RTN","MSCZJOBU",71,0)
4536
;
4537
"RTN","MSCZJOBU",72,0)
4538
Q:$G(PID)'?1N.N&($G(PID)'="*")
4539
"RTN","MSCZJOBU",73,0)
4540
;
4541
"RTN","MSCZJOBU",74,0)
4542
N CMD,DEV
4543
"RTN","MSCZJOBU",75,0)
4544
S CMD="gtmsignal -q "_$S(PID="*":"-a",1:PID)
4545
"RTN","MSCZJOBU",76,0)
4546
S DEV="gtmsignaldev"
4547
"RTN","MSCZJOBU",77,0)
4548
OPEN DEV:(COMM=CMD:READONLY)::"PIPE" U DEV C DEV
4549
"RTN","MSCZJOBU",78,0)
4550
Q
4551
"RTN","MSCZJOBU",79,0)
4552
;
4553
"RTN","MSCZJOBU",80,0)
4554
KILL(PID) ; Send mupip stop to process with PID
4555
"RTN","MSCZJOBU",81,0)
4556
; PID PASSED BY VALUE
4557
"RTN","MSCZJOBU",82,0)
4558
; PID CAN BE A SINGLE PID, I.E. $J
4559
"RTN","MSCZJOBU",83,0)
4560
;
4561
"RTN","MSCZJOBU",84,0)
4562
Q:$G(PID)'?1N.N
4563
"RTN","MSCZJOBU",85,0)
4564
;
4565
"RTN","MSCZJOBU",86,0)
4566
N DEV
4567
"RTN","MSCZJOBU",87,0)
4568
S DEV="gtmsignaldev"
4569
"RTN","MSCZJOBU",88,0)
4570
OPEN DEV:(COMM="gtmsignal -q -s "_PID:READONLY)::"PIPE" U DEV C DEV
4571
"RTN","MSCZJOBU",89,0)
4572
Q
4573
"RTN","MSCZJOBU",90,0)
4574
;
4575
"RTN","MSCZJOBU",91,0)
4576
UNLOCK(NODE,INSTANCE) ; Use lke to remove lock on NODE.
4577
"RTN","MSCZJOBU",92,0)
4578
N %ZG,%ZRO
4579
"RTN","MSCZJOBU",93,0)
4580
D:$G(INSTANCE)'="" NEWZGZRO^ZCD(INSTANCE)
4581
"RTN","MSCZJOBU",94,0)
4582
N CMD,DEV
4583
"RTN","MSCZJOBU",95,0)
4584
S CMD="lke clear -lock="""_NODE_""" -nointeractive -output=/dev/null"
4585
"RTN","MSCZJOBU",96,0)
4586
S:$G(%ZG)'="" CMD="gtmgbldir="""_%ZG_""" "_CMD
4587
"RTN","MSCZJOBU",97,0)
4588
S DEV="lkedev"
4589
"RTN","MSCZJOBU",98,0)
4590
OPEN DEV:(SHELL="/bin/sh":COMM=CMD:READONLY)::"PIPE" U DEV C DEV
4591
"RTN","MSCZJOBU",99,0)
4592
Q
4593
"RTN","PRCSEA")
4594
0^37^B66865498
4595
"RTN","PRCSEA",1,0)
4596
PRCSEA ;WISC/SAW/DXH/BM/SC/DAP,MSC/JDA - CONTROL POINT ACTIVITY EDITS ;27APR2009
4597
"RTN","PRCSEA",2,0)
4598
V ;;5.1;IFCAP;**81,MSC**;Oct 20, 2000
4599
"RTN","PRCSEA",3,0)
4600
;Per VHA Directive 10-93-142, this routine should not be modified.
4601
"RTN","PRCSEA",4,0)
4602
;
4603
"RTN","PRCSEA",5,0)
4604
;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code
4605
"RTN","PRCSEA",6,0)
4606
;to update Audit file (#414.02), and send update message to
4607
"RTN","PRCSEA",7,0)
4608
;DynaMed thru a call to rtn PRCVTCA.
4609
"RTN","PRCSEA",8,0)
4610
;
4611
"RTN","PRCSEA",9,0)
4612
ENRS ;ENTER REQ
4613
"RTN","PRCSEA",10,0)
4614
S PRCSK=1,X3="H"
4615
"RTN","PRCSEA",11,0)
4616
D EN1F^PRCSUT(1) ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197
4617
"RTN","PRCSEA",12,0)
4618
G W2:'$D(PRC("SITE")),EXIT:Y<0 ; unauthorized user or '^' entered
4619
"RTN","PRCSEA",13,0)
4620
D W6 ; display help on transaction# format
4621
"RTN","PRCSEA",14,0)
4622
ENRS0 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="AELQ",D="H"
4623
"RTN","PRCSEA",15,0)
4624
S DIC("A")="Select TRANSACTION: "
4625
"RTN","PRCSEA",16,0)
4626
S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$D(^PRCS(410,""H"",$P(^(0),U,3),+Y)),^(+Y)=DUZ!(^(+Y)="""")" ; only requests authored by user or unauthored will display on partial match
4627
"RTN","PRCSEA",17,0)
4628
D ^PRCSDIC ; lookup & preliminary validity checking
4629
"RTN","PRCSEA",18,0)
4630
K DLAYGO,DIC("A"),DIC("S")
4631
"RTN","PRCSEA",19,0)
4632
G:Y<0 EXIT
4633
"RTN","PRCSEA",20,0)
4634
I $P(Y,U,3)'=1 W $C(7)," Must be a new entry." G ENRS0
4635
"RTN","PRCSEA",21,0)
4636
;*81 Check site parameter to see if issue books are allowed
4637
"RTN","PRCSEA",22,0)
4638
D CKPRM^PRCSEB
4639
"RTN","PRCSEA",23,0)
4640
W !!,PRCVY,!
4641
"RTN","PRCSEA",24,0)
4642
S (PDA,T1,DA)=+Y
4643
"RTN","PRCSEA",25,0)
4644
L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...try a different transaction number or try later" G ENRS0
4645
"RTN","PRCSEA",26,0)
4646
S T(2)=$P(Y,U,2)
4647
"RTN","PRCSEA",27,0)
4648
D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data in new txn (nodes 0,3,6,11 of file 410)
4649
"RTN","PRCSEA",28,0)
4650
S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by)
4651
"RTN","PRCSEA",29,0)
4652
S $P(^PRCS(410,DA,7),"^")=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) ; requestor default
4653
"RTN","PRCSEA",30,0)
4654
I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP,^PRCS(410,"AO",PRCSIP,DA)="" ; PRCSIP was set up in PRCSUT & is inventory distribution point
4655
"RTN","PRCSEA",31,0)
4656
S PRCS="" ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM
4657
"RTN","PRCSEA",32,0)
4658
I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1
4659
"RTN","PRCSEA",33,0)
4660
TYPE ;
4661
"RTN","PRCSEA",34,0)
4662
W !!,"This transaction is assigned temporary transaction number: ",T(2)
4663
"RTN","PRCSEA",35,0)
4664
S DIC("A")="FORM TYPE: ",DIC="^PRCS(410.5,",DIC(0)="AEQZ"
4665
"RTN","PRCSEA",36,0)
4666
S DIC("S")=PRCVX ; only allow selection of 2237's
4667
"RTN","PRCSEA",37,0)
4668
D ^DIC
4669
"RTN","PRCSEA",38,0)
4670
S DA=PDA
4671
"RTN","PRCSEA",39,0)
4672
;if user didn't enter a form type, go ask whether to backout and act
4673
"RTN","PRCSEA",40,0)
4674
;accordingly: go let them re-enter a form type or exit
4675
"RTN","PRCSEA",41,0)
4676
I Y<0 G:'$$BACKOUT(T(2),DA) TYPE L -^PRCS(420,DA) G EXIT
4677
"RTN","PRCSEA",42,0)
4678
;
4679
"RTN","PRCSEA",43,0)
4680
I Y<2 W "??" G TYPE
4681
"RTN","PRCSEA",44,0)
4682
K PRCVX,PRCVY
4683
"RTN","PRCSEA",45,0)
4684
S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y ; form type
4685
"RTN","PRCSEA",46,0)
4686
; if CP is not automated (file 420), user's response will be overwritten with non-recuring (type 2). Although user's selection is changed 'behind the scenes',
4687
"RTN","PRCSEA",47,0)
4688
; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated.
4689
"RTN","PRCSEA",48,0)
4690
S:'PRCS&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2
4691
"RTN","PRCSEA",49,0)
4692
K PRCSERR ; flag denoting item info is missing
4693
"RTN","PRCSEA",50,0)
4694
S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
4695
"RTN","PRCSEA",51,0)
4696
S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
4697
"RTN","PRCSEA",52,0)
4698
EN1 K DTOUT,DUOUT,Y
4699
"RTN","PRCSEA",53,0)
4700
D ^DIE
4701
"RTN","PRCSEA",54,0)
4702
S DA=PDA
4703
"RTN","PRCSEA",55,0)
4704
I $D(Y)!($D(DTOUT)) D DOR L -^PRCS(410,DA) G EXIT
4705
"RTN","PRCSEA",56,0)
4706
D RL^PRCSUT1 ; sets up 'IT' & '10' nodes
4707
"RTN","PRCSEA",57,0)
4708
D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 ; missing required field ('item')
4709
"RTN","PRCSEA",58,0)
4710
D DOR ; populate date of request field if it is nil
4711
"RTN","PRCSEA",59,0)
4712
L -^PRCS(410,DA)
4713
"RTN","PRCSEA",60,0)
4714
S T="enter" D W5 G EXIT:%'=1
4715
"RTN","PRCSEA",61,0)
4716
W !! K PRCS("SUB")
4717
"RTN","PRCSEA",62,0)
4718
G ENRS
4719
"RTN","PRCSEA",63,0)
4720
;
4721
"RTN","PRCSEA",64,0)
4722
EDRS ;EDIT REQ
4723
"RTN","PRCSEA",65,0)
4724
; following line commented out by PRC*5*140 - user responses not used to limit selection of txn and sometimes resulted in bad info being set into the selected txn
4725
"RTN","PRCSEA",66,0)
4726
; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197
4727
"RTN","PRCSEA",67,0)
4728
; if the above line is reactivated, programmer should note that the transaction selected may not be of the same FY,QRTR,sta, subst, and CP specified by the user
4729
"RTN","PRCSEA",68,0)
4730
D W6 ; format doc for txn#
4731
"RTN","PRCSEA",69,0)
4732
S X3="H" S DIC="^PRCS(410,",DIC(0)="AEQ",D="H"
4733
"RTN","PRCSEA",70,0)
4734
S DIC("A")="Select TRANSACTION: "
4735
"RTN","PRCSEA",71,0)
4736
S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$P(^(0),U,4)'=1,^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or unauthored & cannot be a 1358
4737
"RTN","PRCSEA",72,0)
4738
D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S")
4739
"RTN","PRCSEA",73,0)
4740
S (PDA,DA,T1)=+Y
4741
"RTN","PRCSEA",74,0)
4742
L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G EDRS
4743
"RTN","PRCSEA",75,0)
4744
; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option
4745
"RTN","PRCSEA",76,0)
4746
; D EN2B^PRCSUT3
4747
"RTN","PRCSEA",77,0)
4748
S PRC("SITE")=+$P(^PRCS(410,PDA,0),"^",5)
4749
"RTN","PRCSEA",78,0)
4750
S PRC("CP")=$P(^PRCS(410,PDA,3),"^")
4751
"RTN","PRCSEA",79,0)
4752
I $P(^PRCS(410,PDA,0),"^",6)="" D ; prc*5*197
4753
"RTN","PRCSEA",80,0)
4754
. N PRCSIP D IP^PRCSUT
4755
"RTN","PRCSEA",81,0)
4756
. I $D(PRCSIP) S $P(^PRC(410,DA,0),U,6)=PRCSIP
4757
"RTN","PRCSEA",82,0)
4758
S X=+$P(^PRCS(410,DA,0),"^",4) I X<1 D FORM
4759
"RTN","PRCSEA",83,0)
4760
;*81 Check site parameter to see if Issue Books are allowed
4761
"RTN","PRCSEA",84,0)
4762
D CKPRM
4763
"RTN","PRCSEA",85,0)
4764
I PRCVD=1 S PRCVZ=1
4765
"RTN","PRCSEA",86,0)
4766
I PRCVD'=1 S PRCVZ=0
4767
"RTN","PRCSEA",87,0)
4768
W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),!
4769
"RTN","PRCSEA",88,0)
4770
I PRCVZ=1,X=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP issue book order." S T="edit" D W5 G:%'=1 EXIT W !! K PRCS("SUB") G EDRS
4771
"RTN","PRCSEA",89,0)
4772
;
4773
"RTN","PRCSEA",90,0)
4774
S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
4775
"RTN","PRCSEA",91,0)
4776
;P182--Modified next 3 lines to use new templates if supply fund FCP
4777
"RTN","PRCSEA",92,0)
4778
S (DR,PRCSDR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
4779
"RTN","PRCSEA",93,0)
4780
ED1 K DTOUT,DUOUT,Y
4781
"RTN","PRCSEA",94,0)
4782
D ^DIE
4783
"RTN","PRCSEA",95,0)
4784
S DA=PDA
4785
"RTN","PRCSEA",96,0)
4786
I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT
4787
"RTN","PRCSEA",97,0)
4788
D RL^PRCSUT1
4789
"RTN","PRCSEA",98,0)
4790
D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1
4791
"RTN","PRCSEA",99,0)
4792
K PRCSERR S $P(^PRCS(410,DA,14),"^")=DUZ
4793
"RTN","PRCSEA",100,0)
4794
L -^PRCS(410,DA)
4795
"RTN","PRCSEA",101,0)
4796
S T="edit" D W5 G EXIT:%'=1
4797
"RTN","PRCSEA",102,0)
4798
W !! K PRCS("SUB")
4799
"RTN","PRCSEA",103,0)
4800
G EDRS
4801
"RTN","PRCSEA",104,0)
4802
;
4803
"RTN","PRCSEA",105,0)
4804
CT ;CANCEL A (PERMANENT) TRANS
4805
"RTN","PRCSEA",106,0)
4806
D EN3^PRCSUT
4807
"RTN","PRCSEA",107,0)
4808
G W2:'$D(PRC("SITE")),EXIT:Y<0
4809
"RTN","PRCSEA",108,0)
4810
S DIC="^PRCS(410,",DIC(0)="AEMQ"
4811
"RTN","PRCSEA",109,0)
4812
;S DIC("S")="I $P(^(0),""^"",4)=.5!($S('$D(^(7)):1,1:$P(^(7),""^"",6)="""")) I +^(0)>0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
4813
"RTN","PRCSEA",110,0)
4814
S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
4815
"RTN","PRCSEA",111,0)
4816
S DIC("A")="Select TRANSACTION: "
4817
"RTN","PRCSEA",112,0)
4818
D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A")
4819
"RTN","PRCSEA",113,0)
4820
CT1 W !,"Cancel this transaction" S %=2 D YN^DICN G CT1:%=0,EXIT:%'=1
4821
"RTN","PRCSEA",114,0)
4822
S DA=+Y
4823
"RTN","PRCSEA",115,0)
4824
L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G CT
4825
"RTN","PRCSEA",116,0)
4826
S T=$P(^PRCS(410,DA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0
4827
"RTN","PRCSEA",117,0)
4828
K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),DA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
4829
"RTN","PRCSEA",118,0)
4830
K ZX
4831
"RTN","PRCSEA",119,0)
4832
I $D(^PRCS(410,DA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0
4833
"RTN","PRCSEA",120,0)
4834
I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX
4835
"RTN","PRCSEA",121,0)
4836
I $D(^PRCS(410,DA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,DA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=DA,DA=N D TRANK^PRCSEZZ S DA=DA(1)
4837
"RTN","PRCSEA",122,0)
4838
D ERS410^PRC0G(DA_"^C")
4839
"RTN","PRCSEA",123,0)
4840
W !,"Enter comments for this cancellation",!
4841
"RTN","PRCSEA",124,0)
4842
S DIE=DIC,DR=60
4843
"RTN","PRCSEA",125,0)
4844
D ^DIE
4845
"RTN","PRCSEA",126,0)
4846
;PRC*5.1*81 if DM trx, update Audit file and send msg to DM
4847
"RTN","PRCSEA",127,0)
4848
D EN^PRCVTCA(DA)
4849
"RTN","PRCSEA",128,0)
4850
L -^PRCS(410,DA)
4851
"RTN","PRCSEA",129,0)
4852
I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK
4853
"RTN","PRCSEA",130,0)
4854
S T="cancel" D W4 G EXIT:%'=1
4855
"RTN","PRCSEA",131,0)
4856
W !! G CT
4857
"RTN","PRCSEA",132,0)
4858
;
4859
"RTN","PRCSEA",133,0)
4860
DT ;DELETE A (TEMPORARY) TRANS
4861
"RTN","PRCSEA",134,0)
4862
S X3="H"
4863
"RTN","PRCSEA",135,0)
4864
D W6 ; format doc for txn#
4865
"RTN","PRCSEA",136,0)
4866
S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H"
4867
"RTN","PRCSEA",137,0)
4868
S DIC("S")="S W=$P(^(0),""^"",5),W(1)=+^(3) I '^(0),$P(^(0),""^"",3)'="""",^PRCS(410,""H"",$P(^(0),""^"",3),+Y)=DUZ!(^(+Y)="""")!($D(^PRC(420,""A"",DUZ,W,W(1),1)))!($D(^(2)))"
4869
"RTN","PRCSEA",138,0)
4870
D ^PRCSDIC G EXIT:Y<0
4871
"RTN","PRCSEA",139,0)
4872
K DIC("S"),DIC("A")
4873
"RTN","PRCSEA",140,0)
4874
S DA=+Y
4875
"RTN","PRCSEA",141,0)
4876
L +^PRCS(410,DA):5 I $T=0 W !,"File is being accessed...please try later" G DT
4877
"RTN","PRCSEA",142,0)
4878
DT1 W !,"Delete this transaction" S %=2 D YN^DICN G DT1:%=0,EXIT:%'=1
4879
"RTN","PRCSEA",143,0)
4880
;The following line was commented out in patch 182; should NOT manually
4881
"RTN","PRCSEA",144,0)
4882
;change or reset last assigned IEN # in node zero.
4883
"RTN","PRCSEA",145,0)
4884
;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC
4885
"RTN","PRCSEA",146,0)
4886
S DIK=DIC
4887
"RTN","PRCSEA",147,0)
4888
W !,"Okay....."
4889
"RTN","PRCSEA",148,0)
4890
D ^DIK K DIK
4891
"RTN","PRCSEA",149,0)
4892
L -^PRCS(410,DA)
4893
"RTN","PRCSEA",150,0)
4894
;The following line was commented out in patch 182; should NOT manually
4895
"RTN","PRCSEA",151,0)
4896
;change or reset last assigned IEN # in node zero.
4897
"RTN","PRCSEA",152,0)
4898
;S $P(^PRCS(410,0),U,3)=PRCSDA
4899
"RTN","PRCSEA",153,0)
4900
K PRCSDA
4901
"RTN","PRCSEA",154,0)
4902
W "It's deleted"
4903
"RTN","PRCSEA",155,0)
4904
S T="delete" D W4 G EXIT:%'=1
4905
"RTN","PRCSEA",156,0)
4906
W !! G DT
4907
"RTN","PRCSEA",157,0)
4908
;
4909
"RTN","PRCSEA",158,0)
4910
;
4911
"RTN","PRCSEA",159,0)
4912
DOR ; Date of Request
4913
"RTN","PRCSEA",160,0)
4914
I $D(^PRCS(410,DA,1)),$P(^PRCS(410,DA,1),"^")'="" Q
4915
"RTN","PRCSEA",161,0)
4916
S %DT="X",X="T" D ^%DT S $P(^PRCS(410,DA,1),"^")=Y
4917
"RTN","PRCSEA",162,0)
4918
Q
4919
"RTN","PRCSEA",163,0)
4920
FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed
4921
"RTN","PRCSEA",164,0)
4922
D CKPRM
4923
"RTN","PRCSEA",165,0)
4924
I PRCVD=1 S PRCVX1="I Y>1&(Y<5)",PRCVY1="The Issue Book and NO FORM type are not valid in this option."
4925
"RTN","PRCSEA",166,0)
4926
I PRCVD'=1 S PRCVX1="I Y>1",PRCVY1="The NO FORM type is not valid in this option."
4927
"RTN","PRCSEA",167,0)
4928
W !,PRCVY1,!
4929
"RTN","PRCSEA",168,0)
4930
W !,"Please enter another form type",!
4931
"RTN","PRCSEA",169,0)
4932
S PRCSDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ"
4933
"RTN","PRCSEA",170,0)
4934
S DIC("S")=PRCVX1
4935
"RTN","PRCSEA",171,0)
4936
D ^DIC
4937
"RTN","PRCSEA",172,0)
4938
S:Y=-1 Y=2
4939
"RTN","PRCSEA",173,0)
4940
S DA=PRCSDAA,$P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y
4941
"RTN","PRCSEA",174,0)
4942
K DIC,PRCVX1,PRCVY1,PRCVD
4943
"RTN","PRCSEA",175,0)
4944
Q
4945
"RTN","PRCSEA",176,0)
4946
;
4947
"RTN","PRCSEA",177,0)
4948
;Allow user the option of re entering a form type. If they decline,
4949
"RTN","PRCSEA",178,0)
4950
;kill off the transaction and return 1; else return 0
4951
"RTN","PRCSEA",179,0)
4952
BACKOUT(TRNNAME,TRNDA) ;
4953
"RTN","PRCSEA",180,0)
4954
N DIK,Y,%,DA
4955
"RTN","PRCSEA",181,0)
4956
F D Q:%'=0
4957
"RTN","PRCSEA",182,0)
4958
. W !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$C(7)
4959
"RTN","PRCSEA",183,0)
4960
. W !,"Are you sure you want to delete this transaction" S %=2 D YN^DICN
4961
"RTN","PRCSEA",184,0)
4962
. Q
4963
"RTN","PRCSEA",185,0)
4964
I %=2 Q 0
4965
"RTN","PRCSEA",186,0)
4966
S DIK="^PRCS(410,",DA=TRNDA
4967
"RTN","PRCSEA",187,0)
4968
D ^DIK
4969
"RTN","PRCSEA",188,0)
4970
Q 1
4971
"RTN","PRCSEA",189,0)
4972
;
4973
"RTN","PRCSEA",190,0)
4974
W2 W !!,"You are not an authorized control point user.",!,"Contact control point official" R X:5 G EXIT
4975
"RTN","PRCSEA",191,0)
4976
W3 Q ; can this subroutine be deleted? commented out in patch PRC*5*140
4977
"RTN","PRCSEA",192,0)
4978
W !!,"This transaction is assigned temporary transaction number: ",X Q
4979
"RTN","PRCSEA",193,0)
4980
W4 W !!,"Would you like to ",T," another transaction" S %=2 D YN^DICN G W4:%=0 Q
4981
"RTN","PRCSEA",194,0)
4982
W5 W !!,"Would you like to ",T," another request" S %=1 D YN^DICN G W5:%=0 Q
4983
"RTN","PRCSEA",195,0)
4984
W6 W !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",! Q
4985
"RTN","PRCSEA",196,0)
4986
;*81 Site parameter pull
4987
"RTN","PRCSEA",197,0)
4988
CKPRM S PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
4989
"RTN","PRCSEA",198,0)
4990
Q
4991
"RTN","PRCSEA",199,0)
4992
;
4993
"RTN","PRCSEA",200,0)
4994
EXIT K %,C,D,DA,DIC,DIE,DR,PRCS,PDA,PRCSL,T,X,Y,Z,T1,X3,TYPE,PRCVZ
4995
"RTN","PRCSEA",201,0)
4996
I $D(PRCSERR) K PRCSERR
4997
"RTN","PRCSEA",202,0)
4998
Q
4999
"RTN","PSBOMH1")
5000
0^38^B71152392
5001
"RTN","PSBOMH1",1,0)
5002
PSBOMH1 ;BIRMINGHAM/EFC,MSC/JDA - MAH ;27APR2009
5003
"RTN","PSBOMH1",2,0)
5004
;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,MSC**;Mar 2004
5005
"RTN","PSBOMH1",3,0)
5006
;
5007
"RTN","PSBOMH1",4,0)
5008
; Reference/IA
5009
"RTN","PSBOMH1",5,0)
5010
; ^DILF/2054
5011
"RTN","PSBOMH1",6,0)
5012
; File 200/10060
5013
"RTN","PSBOMH1",7,0)
5014
;
5015
"RTN","PSBOMH1",8,0)
5016
EN ;
5017
"RTN","PSBOMH1",9,0)
5018
; Load administrations
5019
"RTN","PSBOMH1",10,0)
5020
S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
5021
"RTN","PSBOMH1",11,0)
5022
K PSBTSA
5023
"RTN","PSBOMH1",12,0)
5024
F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D
5025
"RTN","PSBOMH1",13,0)
5026
.F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN)
5027
"RTN","PSBOMH1",14,0)
5028
..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt
5029
"RTN","PSBOMH1",15,0)
5030
..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven
5031
"RTN","PSBOMH1",16,0)
5032
..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
5033
"RTN","PSBOMH1",17,0)
5034
..; Continuous
5035
"RTN","PSBOMH1",18,0)
5036
..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
5037
"RTN","PSBOMH1",19,0)
5038
...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
5039
"RTN","PSBOMH1",20,0)
5040
...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBMR) D D CLEAN^PSBVT Q ;chck IV audit
5041
"RTN","PSBOMH1",21,0)
5042
....S PSBSIEN=PSBIEN
5043
"RTN","PSBOMH1",22,0)
5044
....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
5045
"RTN","PSBOMH1",23,0)
5046
....S PSBIEN=PSBSIEN K PSBSIEN
5047
"RTN","PSBOMH1",24,0)
5048
....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
5049
"RTN","PSBOMH1",25,0)
5050
....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT
5051
"RTN","PSBOMH1",26,0)
5052
....I X="" K PSBAUD Q
5053
"RTN","PSBOMH1",27,0)
5054
....I '$D(PSBAUD(X)) K PSBAUD Q
5055
"RTN","PSBOMH1",28,0)
5056
....S PSBS=$P(PSBAUD(X),U,3)
5057
"RTN","PSBOMH1",29,0)
5058
....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
5059
"RTN","PSBOMH1",30,0)
5060
....I PSBS="NOT GIVEN" Q
5061
"RTN","PSBOMH1",31,0)
5062
....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
5063
"RTN","PSBOMH1",32,0)
5064
....D PSBSTIV^PSBOMH2
5065
"RTN","PSBOMH1",33,0)
5066
....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
5067
"RTN","PSBOMH1",34,0)
5068
....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
5069
"RTN","PSBOMH1",35,0)
5070
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
5071
"RTN","PSBOMH1",36,0)
5072
....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
5073
"RTN","PSBOMH1",37,0)
5074
....D PSBOUT($P((X),"^",1),$P((X),"^",2))
5075
"RTN","PSBOMH1",38,0)
5076
....K PSBAUD
5077
"RTN","PSBOMH1",39,0)
5078
...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
5079
"RTN","PSBOMH1",40,0)
5080
...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
5081
"RTN","PSBOMH1",41,0)
5082
...I PSBINIT="" S PSBINIT=99
5083
"RTN","PSBOMH1",42,0)
5084
...;get instrc info - audt log
5085
"RTN","PSBOMH1",43,0)
5086
...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
5087
"RTN","PSBOMH1",44,0)
5088
....D INSTR^PSBOMH
5089
"RTN","PSBOMH1",45,0)
5090
....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
5091
"RTN","PSBOMH1",46,0)
5092
...I PSBINIT[99 S PSBINIT=""
5093
"RTN","PSBOMH1",47,0)
5094
...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A")
5095
"RTN","PSBOMH1",48,0)
5096
...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B")
5097
"RTN","PSBOMH1",49,0)
5098
...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
5099
"RTN","PSBOMH1",50,0)
5100
....D DDAUD
5101
"RTN","PSBOMH1",51,0)
5102
....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D
5103
"RTN","PSBOMH1",52,0)
5104
.....S PSBS=$P(PSBTAR(I),U,3)
5105
"RTN","PSBOMH1",53,0)
5106
.....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given
5107
"RTN","PSBOMH1",54,0)
5108
.....I PSBS="NOT GIVEN" Q
5109
"RTN","PSBOMH1",55,0)
5110
.....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
5111
"RTN","PSBOMH1",56,0)
5112
.....D PSBCTAR^PSBOMH2
5113
"RTN","PSBOMH1",57,0)
5114
.....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
5115
"RTN","PSBOMH1",58,0)
5116
...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
5117
"RTN","PSBOMH1",59,0)
5118
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
5119
"RTN","PSBOMH1",60,0)
5120
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
5121
"RTN","PSBOMH1",61,0)
5122
...D PSBOUT($P((X),"^",1),$P((X),"^",2))
5123
"RTN","PSBOMH1",62,0)
5124
...Q
5125
"RTN","PSBOMH1",63,0)
5126
..; 1-Time On Call or PRN
5127
"RTN","PSBOMH1",64,0)
5128
..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
5129
"RTN","PSBOMH1",65,0)
5130
...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
5131
"RTN","PSBOMH1",66,0)
5132
...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
5133
"RTN","PSBOMH1",67,0)
5134
...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
5135
"RTN","PSBOMH1",68,0)
5136
...I PSBINIT="" S PSBINIT=99
5137
"RTN","PSBOMH1",69,0)
5138
...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
5139
"RTN","PSBOMH1",70,0)
5140
...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D
5141
"RTN","PSBOMH1",71,0)
5142
....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
5143
"RTN","PSBOMH1",72,0)
5144
....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
5145
"RTN","PSBOMH1",73,0)
5146
...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
5147
"RTN","PSBOMH1",74,0)
5148
....D INSTR^PSBOMH
5149
"RTN","PSBOMH1",75,0)
5150
....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
5151
"RTN","PSBOMH1",76,0)
5152
...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT)
5153
"RTN","PSBOMH1",77,0)
5154
...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
5155
"RTN","PSBOMH1",78,0)
5156
...I PSBINIT[99 S PSBINIT=""
5157
"RTN","PSBOMH1",79,0)
5158
...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
5159
"RTN","PSBOMH1",80,0)
5160
....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: <No PRN Results On File>"
5161
"RTN","PSBOMH1",81,0)
5162
....E D
5163
"RTN","PSBOMH1",82,0)
5164
.....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
5165
"RTN","PSBOMH1",83,0)
5166
.....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
5167
"RTN","PSBOMH1",84,0)
5168
.....I PSBINIT="" S PSBINIT=99
5169
"RTN","PSBOMH1",85,0)
5170
.....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
5171
"RTN","PSBOMH1",86,0)
5172
......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
5173
"RTN","PSBOMH1",87,0)
5174
......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
5175
"RTN","PSBOMH1",88,0)
5176
.....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
5177
"RTN","PSBOMH1",89,0)
5178
......D:$D(^PSB(53.79,PSBIEN,.9,0))
5179
"RTN","PSBOMH1",90,0)
5180
.......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1
5181
"RTN","PSBOMH1",91,0)
5182
........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
5183
"RTN","PSBOMH1",92,0)
5184
.........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
5185
"RTN","PSBOMH1",93,0)
5186
.........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
5187
"RTN","PSBOMH1",94,0)
5188
.....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
5189
"RTN","PSBOMH1",95,0)
5190
.....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
5191
"RTN","PSBOMH1",96,0)
5192
.....I PSBINIT[99 S PSBINIT=""
5193
"RTN","PSBOMH1",97,0)
5194
...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
5195
"RTN","PSBOMH1",98,0)
5196
...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
5197
"RTN","PSBOMH1",99,0)
5198
...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
5199
"RTN","PSBOMH1",100,0)
5200
...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
5201
"RTN","PSBOMH1",101,0)
5202
...I $G(PSBLINE2)]"" D
5203
"RTN","PSBOMH1",102,0)
5204
....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW
5205
"RTN","PSBOMH1",103,0)
5206
....I $L(PSBLINE2)>90 D
5207
"RTN","PSBOMH1",104,0)
5208
.....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
5209
"RTN","PSBOMH1",105,0)
5210
.....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,161)
5211
"RTN","PSBOMH1",106,0)
5212
.....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW
5213
"RTN","PSBOMH1",107,0)
5214
.....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW
5215
"RTN","PSBOMH1",108,0)
5216
Q
5217
"RTN","PSBOMH1",109,0)
5218
;
5219
"RTN","PSBOMH1",110,0)
5220
DDAUD ; audits for dispen drugs
5221
"RTN","PSBOMH1",111,0)
5222
;
5223
"RTN","PSBOMH1",112,0)
5224
M PSBMLA=^PSB(53.79,PSBIEN)
5225
"RTN","PSBOMH1",113,0)
5226
S PSBGA="" I $D(PSBMLA(.9,0)) D
5227
"RTN","PSBOMH1",114,0)
5228
.F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
5229
"RTN","PSBOMH1",115,0)
5230
..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
5231
"RTN","PSBOMH1",116,0)
5232
..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
5233
"RTN","PSBOMH1",117,0)
5234
..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
5235
"RTN","PSBOMH1",118,0)
5236
..S PSBGA=1
5237
"RTN","PSBOMH1",119,0)
5238
.F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
5239
"RTN","PSBOMH1",120,0)
5240
..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
5241
"RTN","PSBOMH1",121,0)
5242
..S PSBGA=1
5243
"RTN","PSBOMH1",122,0)
5244
I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
5245
"RTN","PSBOMH1",123,0)
5246
S PSBQRY="PSBTMP",PSBCNT=1 F S PSBPQRY=PSBQRY S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
5247
"RTN","PSBOMH1",124,0)
5248
.I PSBPQRY="PSBTMP" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action
5249
"RTN","PSBOMH1",125,0)
5250
.I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment
5251
"RTN","PSBOMH1",126,0)
5252
.I $QS(PSBQRY,2)="C",$E($P(@PSBPQRY,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBPQRY,U,2)=$P(@PSBQRY,U,2) D Q
5253
"RTN","PSBOMH1",127,0)
5254
..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
5255
"RTN","PSBOMH1",128,0)
5256
.S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
5257
"RTN","PSBOMH1",129,0)
5258
Q
5259
"RTN","PSBOMH1",130,0)
5260
;
5261
"RTN","PSBOMH1",131,0)
5262
PSBOUT(PSBTET,PSBOT1) ;
5263
"RTN","PSBOMH1",132,0)
5264
I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1)
5265
"RTN","PSBOMH1",133,0)
5266
S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
5267
"RTN","PSBOMH1",134,0)
5268
S PSBXA1=0
5269
"RTN","PSBOMH1",135,0)
5270
F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*"
5271
"RTN","PSBOMH1",136,0)
5272
.I $L(PSBXA1)<4 D
5273
"RTN","PSBOMH1",137,0)
5274
..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D
5275
"RTN","PSBOMH1",138,0)
5276
...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
5277
"RTN","PSBOMH1",139,0)
5278
...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D
5279
"RTN","PSBOMH1",140,0)
5280
....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
5281
"RTN","PSBOMH1",141,0)
5282
....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
5283
"RTN","PSBOMH1",142,0)
5284
I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
5285
"RTN","PSBOMH1",143,0)
5286
.S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
5287
"RTN","PSBOMH1",144,0)
5288
I $G(PSBNAME)="" D
5289
"RTN","PSBOMH1",145,0)
5290
. S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
5291
"RTN","PSBOMH1",146,0)
5292
I $G(PSBOT1)]""&($G(PSBNAME)]"") S ^TMP("PSB",$J,"LEGEND",PSBOT1,PSBNAME)="" ;MSC
5293
"RTN","PSBOMH1",147,0)
5294
Q
5295
"RTN","PSBOMH1",148,0)
5296
;
5297
"RTN","PSBRPC2")
5298
0^39^B44967923
5299
"RTN","PSBRPC2",1,0)
5300
PSBRPC2 ;BIRMINGHAM/EFC,MSC/JDA - BCMA RPC BROKER CALLS ;27APR2009
5301
"RTN","PSBRPC2",2,0)
5302
;;3.0;BAR CODE MED ADMIN;**6,3,16,MSC**;Mar 2004
5303
"RTN","PSBRPC2",3,0)
5304
;
5305
"RTN","PSBRPC2",4,0)
5306
; Reference/IA
5307
"RTN","PSBRPC2",5,0)
5308
; File 50/221
5309
"RTN","PSBRPC2",6,0)
5310
; File 52.6/436
5311
"RTN","PSBRPC2",7,0)
5312
; File 52.7/437
5313
"RTN","PSBRPC2",8,0)
5314
; File 200/10060
5315
"RTN","PSBRPC2",9,0)
5316
;
5317
"RTN","PSBRPC2",10,0)
5318
GETOHIST(RESULTS,DFN,PSBORD) ;
5319
"RTN","PSBRPC2",11,0)
5320
S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0
5321
"RTN","PSBRPC2",12,0)
5322
S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
5323
"RTN","PSBRPC2",13,0)
5324
D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
5325
"RTN","PSBRPC2",14,0)
5326
D EN^PSBPOIV(DFN,PSBORD)
5327
"RTN","PSBRPC2",15,0)
5328
S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D
5329
"RTN","PSBRPC2",16,0)
5330
.S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
5331
"RTN","PSBRPC2",17,0)
5332
.I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; only want the infusing bag on a dc'ed order
5333
"RTN","PSBRPC2",18,0)
5334
.I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" S PSBOSTS="E" Q ; only want the infusing bag on an expired order
5335
"RTN","PSBRPC2",19,0)
5336
.I $P(PSBUIDS,U,2)'="" D Q ; get orders from med log (53.79)
5337
"RTN","PSBRPC2",20,0)
5338
..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
5339
"RTN","PSBRPC2",21,0)
5340
..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
5341
"RTN","PSBRPC2",22,0)
5342
..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
5343
"RTN","PSBRPC2",23,0)
5344
..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
5345
"RTN","PSBRPC2",24,0)
5346
..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
5347
"RTN","PSBRPC2",25,0)
5348
..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
5349
"RTN","PSBRPC2",26,0)
5350
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
5351
"RTN","PSBRPC2",27,0)
5352
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
5353
"RTN","PSBRPC2",28,0)
5354
..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
5355
"RTN","PSBRPC2",29,0)
5356
.I $P(PSBUIDS,U,1)="I" Q ; IV parameters say bag is invalid
5357
"RTN","PSBRPC2",30,0)
5358
.I $P(PSBUIDS,U,8)'="",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; label has been reprinted/distroyed etc. - bag is not infusing or stopped
5359
"RTN","PSBRPC2",31,0)
5360
.S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
5361
"RTN","PSBRPC2",32,0)
5362
.S PSBUIDP=$P(PSBUIDS,U,10,999)
5363
"RTN","PSBRPC2",33,0)
5364
.F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY="" D
5365
"RTN","PSBRPC2",34,0)
5366
..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
5367
"RTN","PSBRPC2",35,0)
5368
..I $P(PSBMEDTY,";",1)="ADD" F Z=1:1 S PSBAD=$G(PSBADA(Z)) Q:PSBAD="" I $P(PSBADA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBADA(Z) Q
5369
"RTN","PSBRPC2",36,0)
5370
..I $P(PSBMEDTY,";",1)="SOL" F Z=1:1 S PSBSOL=$G(PSBSOLA(Z)) Q:PSBSOL="" I $P(PSBSOLA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBSOLA(Z) Q
5371
"RTN","PSBRPC2",37,0)
5372
.D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
5373
"RTN","PSBRPC2",38,0)
5374
.S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
5375
"RTN","PSBRPC2",39,0)
5376
F II=1:1 S I=$P(PSBONXS,U,II) Q:I="" D ; get ward stocks
5377
"RTN","PSBRPC2",40,0)
5378
.S PSBUID="" F S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID="" D
5379
"RTN","PSBRPC2",41,0)
5380
..I PSBUID'["WS" Q ; not a ward stock
5381
"RTN","PSBRPC2",42,0)
5382
..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
5383
"RTN","PSBRPC2",43,0)
5384
..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
5385
"RTN","PSBRPC2",44,0)
5386
..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
5387
"RTN","PSBRPC2",45,0)
5388
..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q ; want "not completed" on DC'ed orders
5389
"RTN","PSBRPC2",46,0)
5390
..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
5391
"RTN","PSBRPC2",47,0)
5392
..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
5393
"RTN","PSBRPC2",48,0)
5394
..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
5395
"RTN","PSBRPC2",49,0)
5396
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
5397
"RTN","PSBRPC2",50,0)
5398
..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
5399
"RTN","PSBRPC2",51,0)
5400
..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
5401
"RTN","PSBRPC2",52,0)
5402
S ^TMP("PSB",$J,0)=PSB
5403
"RTN","PSBRPC2",53,0)
5404
K ^TMP("PSBAR",$J)
5405
"RTN","PSBRPC2",54,0)
5406
Q
5407
"RTN","PSBRPC2",55,0)
5408
;
5409
"RTN","PSBRPC2",56,0)
5410
BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
5411
"RTN","PSBRPC2",57,0)
5412
I '$G(DFN)!PSBUID S DFN=+PSBUID ;**GFT/MSC
5413
"RTN","PSBRPC2",58,0)
5414
S (PSBIEN,X)="" F S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X="" S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
5415
"RTN","PSBRPC2",59,0)
5416
I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
5417
"RTN","PSBRPC2",60,0)
5418
M PSBMLA=^PSB(53.79,PSBIEN)
5419
"RTN","PSBRPC2",61,0)
5420
S X=$P(^PSB(53.79,PSBIEN,0),U,9)
5421
"RTN","PSBRPC2",62,0)
5422
S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION")
5423
"RTN","PSBRPC2",63,0)
5424
; comments
5425
"RTN","PSBRPC2",64,0)
5426
S PSBX="0" F S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX="" S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1)
5427
"RTN","PSBRPC2",65,0)
5428
; audit
5429
"RTN","PSBRPC2",66,0)
5430
S PSBGA="" I $D(PSBMLA(.9,0)) D
5431
"RTN","PSBRPC2",67,0)
5432
.S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
5433
"RTN","PSBRPC2",68,0)
5434
..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
5435
"RTN","PSBRPC2",69,0)
5436
..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
5437
"RTN","PSBRPC2",70,0)
5438
..S PSBGA=1
5439
"RTN","PSBRPC2",71,0)
5440
.S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
5441
"RTN","PSBRPC2",72,0)
5442
..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
5443
"RTN","PSBRPC2",73,0)
5444
..S PSBGA=1
5445
"RTN","PSBRPC2",74,0)
5446
I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC
5447
"RTN","PSBRPC2",75,0)
5448
S PSBQRY="PSBTMP",PSBCNT=1 F S PSBPQRY=PSBQRY S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
5449
"RTN","PSBRPC2",76,0)
5450
.I PSBPQRY="PSBTMP" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no previous action
5451
"RTN","PSBRPC2",77,0)
5452
.I $QS(PSBPQRY,2)="C" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; previous line is a comment
5453
"RTN","PSBRPC2",78,0)
5454
.I $QS(PSBQRY,2)="C",$E($P(@PSBPQRY,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBPQRY,U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q
5455
"RTN","PSBRPC2",79,0)
5456
.S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
5457
"RTN","PSBRPC2",80,0)
5458
S RESULTS(0)=PSBCNT-1
5459
"RTN","PSBRPC2",81,0)
5460
K PSBMLA,PSBIEN,PSBTMP,PSBQRY
5461
"RTN","PSBRPC2",82,0)
5462
Q
5463
"RTN","PSBRPC2",83,0)
5464
;
5465
"RTN","PSBRPC2",84,0)
5466
INITIAL(PSBDUZ) ;
5467
"RTN","PSBRPC2",85,0)
5468
Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
5469
"RTN","PSBRPC2",86,0)
5470
SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
5471
"RTN","PSBRPC2",87,0)
5472
;
5473
"RTN","PSBRPC2",88,0)
5474
; RPC: PSB SCANMED
5475
"RTN","PSBRPC2",89,0)
5476
;
5477
"RTN","PSBRPC2",90,0)
5478
; Description:
5479
"RTN","PSBRPC2",91,0)
5480
; Does a lookup on file 50 returns -1 on invalid lookup or
5481
"RTN","PSBRPC2",92,0)
5482
; IEN^DrugName on success
5483
"RTN","PSBRPC2",93,0)
5484
;
5485
"RTN","PSBRPC2",94,0)
5486
D NOW^%DTC S PSBDT=%
5487
"RTN","PSBRPC2",95,0)
5488
S PSBCNT=0
5489
"RTN","PSBRPC2",96,0)
5490
I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
5491
"RTN","PSBRPC2",97,0)
5492
S RESULTS(PSBCNT)=1
5493
"RTN","PSBRPC2",98,0)
5494
S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
5495
"RTN","PSBRPC2",99,0)
5496
I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11)
5497
"RTN","PSBRPC2",100,0)
5498
I PSBTAB="UDTAB" D Q
5499
"RTN","PSBRPC2",101,0)
5500
.S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
5501
"RTN","PSBRPC2",102,0)
5502
.I X<1 Q
5503
"RTN","PSBRPC2",103,0)
5504
.E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
5505
"RTN","PSBRPC2",104,0)
5506
;
5507
"RTN","PSBRPC2",105,0)
5508
; IV/IVPB ward stock scan
5509
"RTN","PSBRPC2",106,0)
5510
;
5511
"RTN","PSBRPC2",107,0)
5512
S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
5513
"RTN","PSBRPC2",108,0)
5514
S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
5515
"RTN","PSBRPC2",109,0)
5516
I $D(^PSDRUG("A527",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X="" D
5517
"RTN","PSBRPC2",110,0)
5518
.S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
5519
"RTN","PSBRPC2",111,0)
5520
.S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
5521
"RTN","PSBRPC2",112,0)
5522
I $D(^PSDRUG("A526",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X="" D
5523
"RTN","PSBRPC2",113,0)
5524
.S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
5525
"RTN","PSBRPC2",114,0)
5526
.S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
5527
"RTN","PSBRPC2",115,0)
5528
;
5529
"RTN","PSBRPC2",116,0)
5530
I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
5531
"RTN","PSBRPC2",117,0)
5532
Q
5533
"RTN","PSBRPC2",118,0)
5534
;
5535
"RTN","PXRMTMED")
5536
0^40^B9342039
5537
"RTN","PXRMTMED",1,0)
5538
PXRMTMED ; SLC/PKR/PJH,MSC/JKT - Edit a reminder term. ;04/05/2010
5539
"RTN","PXRMTMED",2,0)
5540
;;2.0;CLINICAL REMINDERS;**1,MSC**;Feb 04, 2005
5541
"RTN","PXRMTMED",3,0)
5542
;
5543
"RTN","PXRMTMED",4,0)
5544
;=======================================================
5545
"RTN","PXRMTMED",5,0)
5546
N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y
5547
"RTN","PXRMTMED",6,0)
5548
GETNAME ;Get the name of the term to edit.
5549
"RTN","PXRMTMED",7,0)
5550
K DA,DIC,DLAYGO,DTOUT,DUOUT,Y
5551
"RTN","PXRMTMED",8,0)
5552
S DIC="^PXRMD(811.5,"
5553
"RTN","PXRMTMED",9,0)
5554
S DIC(0)="AEMQL"
5555
"RTN","PXRMTMED",10,0)
5556
S DIC("A")="Select Reminder Term: "
5557
"RTN","PXRMTMED",11,0)
5558
S DLAYGO=811.5
5559
"RTN","PXRMTMED",12,0)
5560
;Set the starting place for additions.
5561
"RTN","PXRMTMED",13,0)
5562
D SETSTART^PXRMCOPY(DIC)
5563
"RTN","PXRMTMED",14,0)
5564
W !
5565
"RTN","PXRMTMED",15,0)
5566
D ^DIC
5567
"RTN","PXRMTMED",16,0)
5568
I ($D(DTOUT))!($D(DUOUT)) Q
5569
"RTN","PXRMTMED",17,0)
5570
I Y=-1 G END
5571
"RTN","PXRMTMED",18,0)
5572
S DA=$P(Y,U,1)
5573
"RTN","PXRMTMED",19,0)
5574
S CS1=$$FILE^PXRMEXCS(811.5,DA)
5575
"RTN","PXRMTMED",20,0)
5576
D EDIT(DIC,DA)
5577
"RTN","PXRMTMED",21,0)
5578
I $G(DA)="" G GETNAME
5579
"RTN","PXRMTMED",22,0)
5580
S CS2=$$FILE^PXRMEXCS(811.5,DA)
5581
"RTN","PXRMTMED",23,0)
5582
I CS2=0 G GETNAME
5583
"RTN","PXRMTMED",24,0)
5584
I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
5585
"RTN","PXRMTMED",25,0)
5586
G GETNAME
5587
"RTN","PXRMTMED",26,0)
5588
END ;
5589
"RTN","PXRMTMED",27,0)
5590
Q
5591
"RTN","PXRMTMED",28,0)
5592
;
5593
"RTN","PXRMTMED",29,0)
5594
;=======================================================
5595
"RTN","PXRMTMED",30,0)
5596
EDIT(ROOT,DA) ;
5597
"RTN","PXRMTMED",31,0)
5598
N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y
5599
"RTN","PXRMTMED",32,0)
5600
;PXRMTMD is set by a xref on the .01 as a flag that the entire
5601
"RTN","PXRMTMED",33,0)
5602
;entry is being deleted.
5603
"RTN","PXRMTMED",34,0)
5604
S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1)
5605
"RTN","PXRMTMED",35,0)
5606
S DIE=ROOT
5607
"RTN","PXRMTMED",36,0)
5608
I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D
5609
"RTN","PXRMTMED",37,0)
5610
. S DR=".01"
5611
"RTN","PXRMTMED",38,0)
5612
. D ^DIE
5613
"RTN","PXRMTMED",39,0)
5614
. I $G(DA)'="" D CLASS(DA,DIE)
5615
"RTN","PXRMTMED",40,0)
5616
I $G(DA)="" Q
5617
"RTN","PXRMTMED",41,0)
5618
S TCONT=1
5619
"RTN","PXRMTMED",42,0)
5620
F D FINDING(DIE,DA) Q:TCONT=0
5621
"RTN","PXRMTMED",43,0)
5622
Q
5623
"RTN","PXRMTMED",44,0)
5624
;
5625
"RTN","PXRMTMED",45,0)
5626
;=======================================================
5627
"RTN","PXRMTMED",46,0)
5628
FINDING(DIE,DA,LIST) ;
5629
"RTN","PXRMTMED",47,0)
5630
N CFIEN,GLOB,IEN,LIST,NODE,WPIEN
5631
"RTN","PXRMTMED",48,0)
5632
N DEF,DEF1,DEF2,STATUS
5633
"RTN","PXRMTMED",49,0)
5634
S STATUS=0
5635
"RTN","PXRMTMED",50,0)
5636
D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)
5637
"RTN","PXRMTMED",51,0)
5638
S NODE="^PXRMD(811.5)"
5639
"RTN","PXRMTMED",52,0)
5640
D LIST^PXRMREDT(NODE,DA,.LIST)
5641
"RTN","PXRMTMED",53,0)
5642
D DSPALL^PXRMREDF("T",NODE,DA,.LIST)
5643
"RTN","PXRMTMED",54,0)
5644
S DA(1)=DA
5645
"RTN","PXRMTMED",55,0)
5646
S IEN=DA
5647
"RTN","PXRMTMED",56,0)
5648
S DIC=DIE_DA(1)_",20,"
5649
"RTN","PXRMTMED",57,0)
5650
S DIC(0)="QEAL"
5651
"RTN","PXRMTMED",58,0)
5652
S DIC("A")="Select Finding: "
5653
"RTN","PXRMTMED",59,0)
5654
D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q
5655
"RTN","PXRMTMED",60,0)
5656
S DIE=DIC
5657
"RTN","PXRMTMED",61,0)
5658
S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
5659
"RTN","PXRMTMED",62,0)
5660
I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D
5661
"RTN","PXRMTMED",63,0)
5662
.I $D(^PXRMD(811.4,CFIEN,1))>0 D
5663
"RTN","PXRMTMED",64,0)
5664
..W !!,"Computed Finding Description:" S WPIEN=0
5665
"RTN","PXRMTMED",65,0)
5666
..F S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0 D
5667
"RTN","PXRMTMED",66,0)
5668
...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
5669
"RTN","PXRMTMED",67,0)
5670
.E W !!,"No description defined for this computed finding"
5671
"RTN","PXRMTMED",68,0)
5672
.W !
5673
"RTN","PXRMTMED",69,0)
5674
W !,"Editing Finding Number: "_$G(DA)
5675
"RTN","PXRMTMED",70,0)
5676
;Finding record fields
5677
"RTN","PXRMTMED",71,0)
5678
S DR=".01;9;12;17"
5679
"RTN","PXRMTMED",72,0)
5680
S DR=DR_";14;15;18"
5681
"RTN","PXRMTMED",73,0)
5682
I GLOB="PXRMD(811.4," S DR=DR_";26"
5683
"RTN","PXRMTMED",74,0)
5684
;Taxonomy - use inactive problems
5685
"RTN","PXRMTMED",75,0)
5686
I GLOB="PXD(811.2," S DR=DR_";10",STATUS=1
5687
"RTN","PXRMTMED",76,0)
5688
;Health Factor - within category rank
5689
"RTN","PXRMTMED",77,0)
5690
I GLOB="AUTTHF(" S DR=DR_";11"
5691
"RTN","PXRMTMED",78,0)
5692
;Mental Health - scale
5693
"RTN","PXRMTMED",79,0)
5694
I GLOB="YTT(601," S DR=DR_";13"
5695
"RTN","PXRMTMED",80,0)
5696
I GLOB="RAMIS(71,"!(GLOB="ORD(101.43,") S DR=DR_";16",STATUS=1
5697
"RTN","PXRMTMED",81,0)
5698
;Rx Type
5699
"RTN","PXRMTMED",82,0)
5700
I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16",STATUS=1
5701
"RTN","PXRMTMED",83,0)
5702
;Condition
5703
"RTN","PXRMTMED",84,0)
5704
;
5705
"RTN","PXRMTMED",85,0)
5706
;Edit finding record
5707
"RTN","PXRMTMED",86,0)
5708
D ^DIE
5709
"RTN","PXRMTMED",87,0)
5710
I STATUS=1,$D(DA)>0 D STATUS^PXRMSTA1(.DA,"T")
5711
"RTN","PXRMTMED",88,0)
5712
S $P(^PXRMD(811.5,IEN,20,0),U,3)=0
5713
"RTN","PXRMTMED",89,0)
5714
Q
5715
"RTN","PXRMTMED",90,0)
5716
;
5717
"RTN","PXRMTMED",91,0)
5718
;=======================================================
5719
"RTN","PXRMTMED",92,0)
5720
CLASS(DA,DIE) ;
5721
"RTN","PXRMTMED",93,0)
5722
N DR,RESULT,X,Y
5723
"RTN","PXRMTMED",94,0)
5724
RETRY W !
5725
"RTN","PXRMTMED",95,0)
5726
S DR="100" D ^DIE I $D(Y) Q
5727
"RTN","PXRMTMED",96,0)
5728
;Sponsor
5729
"RTN","PXRMTMED",97,0)
5730
S DR="101" D ^DIE I $D(Y) Q
5731
"RTN","PXRMTMED",98,0)
5732
;Make sure Class and Sponsor Class are in synch.
5733
"RTN","PXRMTMED",99,0)
5734
S RESULT=$$VSPONSOR^PXRMINTR(X) I RESULT=0 G RETRY
5735
"RTN","PXRMTMED",100,0)
5736
;Review date, Usage
5737
"RTN","PXRMTMED",101,0)
5738
S DR="102;1" D ^DIE I $D(Y) Q
5739
"RTN","PXRMTMED",102,0)
5740
Q
5741
"RTN","PXRMTMED",103,0)
5742
;
5743
"RTN","RORHL7A")
5744
0^32^B35660209
5745
"RTN","RORHL7A",1,0)
5746
RORHL7A ;HCIOFO/SG MSC/JDS- HL7 UTILITIES ;30APR2009
5747
"RTN","RORHL7A",2,0)
5748
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
5749
"RTN","RORHL7A",3,0)
5750
;
5751
"RTN","RORHL7A",4,0)
5752
Q
5753
"RTN","RORHL7A",5,0)
5754
;
5755
"RTN","RORHL7A",6,0)
5756
;***** ADDS THE SEGMENT TO THE HL7 MESSAGE BUFFER
5757
"RTN","RORHL7A",7,0)
5758
;
5759
"RTN","RORHL7A",8,0)
5760
; SEG Complete HL7 segment
5761
"RTN","RORHL7A",9,0)
5762
;
5763
"RTN","RORHL7A",10,0)
5764
; The ADDSEGC^RORHL7A procedure adds the HL7 segment to the HL7
5765
"RTN","RORHL7A",11,0)
5766
; message buffer defined by the ROREXT("HL7BUF") parameter
5767
"RTN","RORHL7A",12,0)
5768
; (the ^TMP("HLS",$J), by default). The <TAB>, <CR> and <LF>
5769
"RTN","RORHL7A",13,0)
5770
; characters are replaced with spaces. Long segments are split
5771
"RTN","RORHL7A",14,0)
5772
; among sub-nodes of the main segment node in the destination
5773
"RTN","RORHL7A",15,0)
5774
; buffer.
5775
"RTN","RORHL7A",16,0)
5776
;
5777
"RTN","RORHL7A",17,0)
5778
; The RORHL array and some nodes of the ROREXT array must be
5779
"RTN","RORHL7A",18,0)
5780
; initialized (either by the $$INIT^RORHL7 or manually) before
5781
"RTN","RORHL7A",19,0)
5782
; calling this procedure.
5783
"RTN","RORHL7A",20,0)
5784
;
5785
"RTN","RORHL7A",21,0)
5786
ADDSEGC(SEG) ;
5787
"RTN","RORHL7A",22,0)
5788
N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL
5789
"RTN","RORHL7A",23,0)
5790
S NODE=ROREXT("HL7BUF"),PTR=$G(ROREXT("HL7PTR"))+1
5791
"RTN","RORHL7A",24,0)
5792
S HLFS=RORHL("FS"),HLECH=RORHL("ECH")
5793
"RTN","RORHL7A",25,0)
5794
Q:$P(SEG,HLFS)="" ; Segment Name
5795
"RTN","RORHL7A",26,0)
5796
;--- Assign the Set ID if necessary
5797
"RTN","RORHL7A",27,0)
5798
S SID=$$SETID($P(SEG,HLFS))
5799
"RTN","RORHL7A",28,0)
5800
S:SID>0 $P(SEG,HLFS,2)=SID
5801
"RTN","RORHL7A",29,0)
5802
;--- Remove empty trailing fields
5803
"RTN","RORHL7A",30,0)
5804
S I2=$L(SEG,HLFS)
5805
"RTN","RORHL7A",31,0)
5806
F I1=I2:-1:1 Q:$TR($P(SEG,HLFS,I1),HLECH)'=""
5807
"RTN","RORHL7A",32,0)
5808
S:I1<I2 $P(SEG,HLFS,I1+1,I2)=""
5809
"RTN","RORHL7A",33,0)
5810
;--- Store the segment
5811
"RTN","RORHL7A",34,0)
5812
S SL=$L(SEG),MAXLEN=245 K @NODE@(PTR)
5813
"RTN","RORHL7A",35,0)
5814
S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13)," ")
5815
"RTN","RORHL7A",36,0)
5816
S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+SL+1
5817
"RTN","RORHL7A",37,0)
5818
;--- Split the segment into sub-nodes if necessary
5819
"RTN","RORHL7A",38,0)
5820
D:SL>MAXLEN
5821
"RTN","RORHL7A",39,0)
5822
. S I2=MAXLEN
5823
"RTN","RORHL7A",40,0)
5824
. F PTR1=1:1 S I1=I2+1,I2=I1+MAXLEN-1 Q:I1>SL D
5825
"RTN","RORHL7A",41,0)
5826
. . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13)," ")
5827
"RTN","RORHL7A",42,0)
5828
;--- Save the pointer
5829
"RTN","RORHL7A",43,0)
5830
S ROREXT("HL7PTR")=PTR
5831
"RTN","RORHL7A",44,0)
5832
Q
5833
"RTN","RORHL7A",45,0)
5834
;
5835
"RTN","RORHL7A",46,0)
5836
;***** ASSEMBLES THE SEGMENT AND ADDS IT TO THE HL7 MESSAGE BUFFER
5837
"RTN","RORHL7A",47,0)
5838
;
5839
"RTN","RORHL7A",48,0)
5840
; .FIELDS Reference to a local variable where the HL7
5841
"RTN","RORHL7A",49,0)
5842
; fields are stored
5843
"RTN","RORHL7A",50,0)
5844
;
5845
"RTN","RORHL7A",51,0)
5846
; FIELDS(
5847
"RTN","RORHL7A",52,0)
5848
; 0) Segment name
5849
"RTN","RORHL7A",53,0)
5850
; I, Field value
5851
"RTN","RORHL7A",54,0)
5852
; i) Continuation of the value if it is
5853
"RTN","RORHL7A",55,0)
5854
; ... longer than than 245 characters
5855
"RTN","RORHL7A",56,0)
5856
;
5857
"RTN","RORHL7A",57,0)
5858
; The ADDSEGF^RORHL7A procedure assembles the HL7 segment from
5859
"RTN","RORHL7A",58,0)
5860
; provided field values and adds it to the HL7 message buffer
5861
"RTN","RORHL7A",59,0)
5862
; defined by the ROREXT("HL7BUF") node (the ^TMP("HLS",$J), by
5863
"RTN","RORHL7A",60,0)
5864
; default). The <TAB>, <CR> and <LF> characters are replaced with
5865
"RTN","RORHL7A",61,0)
5866
; spaces. Long segments are split among sub-nodes of the main
5867
"RTN","RORHL7A",62,0)
5868
; segment node in the destination buffer.
5869
"RTN","RORHL7A",63,0)
5870
;
5871
"RTN","RORHL7A",64,0)
5872
; The RORHL array and some nodes of the ROREXT array must be
5873
"RTN","RORHL7A",65,0)
5874
; initialized (either by the $$INIT^RORHL7 or manually) before
5875
"RTN","RORHL7A",66,0)
5876
; calling this procedure.
5877
"RTN","RORHL7A",67,0)
5878
;
5879
"RTN","RORHL7A",68,0)
5880
ADDSEGF(FIELDS) ;
5881
"RTN","RORHL7A",69,0)
5882
; RORBUF Temporary buffer for the segment construction
5883
"RTN","RORHL7A",70,0)
5884
; RORIS Current continuation subscript in the HL7 buffer
5885
"RTN","RORHL7A",71,0)
5886
; RORNODE Closed root of the HL7 message buffer
5887
"RTN","RORHL7A",72,0)
5888
; RORPTR Current subscript in the HL7 message buffer
5889
"RTN","RORHL7A",73,0)
5890
; RORSL Number of characters that can be appended to the
5891
"RTN","RORHL7A",74,0)
5892
; RORBUF before it has to be emptied into the HL7
5893
"RTN","RORHL7A",75,0)
5894
; message buffer
5895
"RTN","RORHL7A",76,0)
5896
;
5897
"RTN","RORHL7A",77,0)
5898
N FLD,I,LASTFLD,RORBUF,RORIS,RORNODE,RORPTR,RORSL
5899
"RTN","RORHL7A",78,0)
5900
Q:$G(FIELDS(0))="" ; Segment Name
5901
"RTN","RORHL7A",79,0)
5902
S RORNODE=ROREXT("HL7BUF"),RORPTR=$G(ROREXT("HL7PTR"))+1
5903
"RTN","RORHL7A",80,0)
5904
S HLFS=RORHL("FS"),HLECH=RORHL("ECH")
5905
"RTN","RORHL7A",81,0)
5906
;--- Assign the Set ID if necessary
5907
"RTN","RORHL7A",82,0)
5908
S I=$$SETID(FIELDS(0))
5909
"RTN","RORHL7A",83,0)
5910
S:I>0 FIELDS(1)=I
5911
"RTN","RORHL7A",84,0)
5912
;--- Remove empty trailing fields
5913
"RTN","RORHL7A",85,0)
5914
S I=$NA(FIELDS)
5915
"RTN","RORHL7A",86,0)
5916
N A,CNT F S I=$Q(@I) Q:I="" S CNT=$G(CNT)+1,A(CNT)=I I $TR(@I,HLECH)'="" K A,CNT
5917
"RTN","RORHL7A",87,0)
5918
F I=1:1 Q:'$D(A(I)) K @A(I)
5919
"RTN","RORHL7A",88,0)
5920
;--- Initialize construction variables
5921
"RTN","RORHL7A",89,0)
5922
S RORBUF=FIELDS(0),I=$L(RORBUF)
5923
"RTN","RORHL7A",90,0)
5924
S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+I+1
5925
"RTN","RORHL7A",91,0)
5926
S RORIS=0,RORSL=245-I
5927
"RTN","RORHL7A",92,0)
5928
;--- Append the fields and store the segment
5929
"RTN","RORHL7A",93,0)
5930
S LASTFLD=+$O(FIELDS(" "),-1)
5931
"RTN","RORHL7A",94,0)
5932
F FLD=1:1:LASTFLD D
5933
"RTN","RORHL7A",95,0)
5934
. D APPEND(HLFS_$G(FIELDS(FLD)))
5935
"RTN","RORHL7A",96,0)
5936
. ;--- Process the field continuation nodes
5937
"RTN","RORHL7A",97,0)
5938
. S I=""
5939
"RTN","RORHL7A",98,0)
5940
. F S I=$O(FIELDS(FLD,I)) Q:I="" D APPEND(FIELDS(FLD,I))
5941
"RTN","RORHL7A",99,0)
5942
;--- Flush the buffer if necessary
5943
"RTN","RORHL7A",100,0)
5944
D:RORBUF'=""
5945
"RTN","RORHL7A",101,0)
5946
. I 'RORIS S @RORNODE@(RORPTR)=RORBUF Q
5947
"RTN","RORHL7A",102,0)
5948
. S @RORNODE@(RORPTR,RORIS)=RORBUF
5949
"RTN","RORHL7A",103,0)
5950
S ROREXT("HL7PTR")=RORPTR
5951
"RTN","RORHL7A",104,0)
5952
Q
5953
"RTN","RORHL7A",105,0)
5954
;
5955
"RTN","RORHL7A",106,0)
5956
;***** APPENDS THE FIELD VALUE TO THE HL7 SEGMENT
5957
"RTN","RORHL7A",107,0)
5958
;
5959
"RTN","RORHL7A",108,0)
5960
; VAL Value of the field (or its part)
5961
"RTN","RORHL7A",109,0)
5962
;
5963
"RTN","RORHL7A",110,0)
5964
; This is an internal function. Do not call it directly.
5965
"RTN","RORHL7A",111,0)
5966
;
5967
"RTN","RORHL7A",112,0)
5968
APPEND(VAL) ;
5969
"RTN","RORHL7A",113,0)
5970
N BASE,L
5971
"RTN","RORHL7A",114,0)
5972
S VAL=$TR(VAL,$C(9,10,13)," "),L=$L(VAL)
5973
"RTN","RORHL7A",115,0)
5974
S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+L
5975
"RTN","RORHL7A",116,0)
5976
I L'>RORSL S RORBUF=RORBUF_VAL,RORSL=RORSL-L Q
5977
"RTN","RORHL7A",117,0)
5978
;---
5979
"RTN","RORHL7A",118,0)
5980
S RORBUF=RORBUF_$E(VAL,1,RORSL),L=L-RORSL
5981
"RTN","RORHL7A",119,0)
5982
S BASE=1
5983
"RTN","RORHL7A",120,0)
5984
F D Q:L'>0
5985
"RTN","RORHL7A",121,0)
5986
. I 'RORIS S @RORNODE@(RORPTR)=RORBUF
5987
"RTN","RORHL7A",122,0)
5988
. E S @RORNODE@(RORPTR,RORIS)=RORBUF
5989
"RTN","RORHL7A",123,0)
5990
. S BASE=BASE+RORSL,RORIS=RORIS+1,RORSL=245
5991
"RTN","RORHL7A",124,0)
5992
. S RORBUF=$E(VAL,BASE,BASE+RORSL-1),L=L-RORSL
5993
"RTN","RORHL7A",125,0)
5994
S RORSL=-L
5995
"RTN","RORHL7A",126,0)
5996
Q
5997
"RTN","RORHL7A",127,0)
5998
;
5999
"RTN","RORHL7A",128,0)
6000
;***** RETURNS THE BHS SEGMENT
6001
"RTN","RORHL7A",129,0)
6002
;
6003
"RTN","RORHL7A",130,0)
6004
; BID Batch message ID
6005
"RTN","RORHL7A",131,0)
6006
;
6007
"RTN","RORHL7A",132,0)
6008
; [BDT] Batch message creation time in internal FileMan
6009
"RTN","RORHL7A",133,0)
6010
; format (NOW by default)
6011
"RTN","RORHL7A",134,0)
6012
;
6013
"RTN","RORHL7A",135,0)
6014
; [COMMENT] Optional comment
6015
"RTN","RORHL7A",136,0)
6016
;
6017
"RTN","RORHL7A",137,0)
6018
; The RORHL local variable must be initialized by the $$INIT^RORHL7
6019
"RTN","RORHL7A",138,0)
6020
; function before calling this entry point.
6021
"RTN","RORHL7A",139,0)
6022
;
6023
"RTN","RORHL7A",140,0)
6024
BHS(BID,BDT,COMMENT) ;
6025
"RTN","RORHL7A",141,0)
6026
N CS,SEG,TMP
6027
"RTN","RORHL7A",142,0)
6028
D BHS^HLFNC3(.RORHL,BID,.SEG)
6029
"RTN","RORHL7A",143,0)
6030
Q:$G(SEG)="" ""
6031
"RTN","RORHL7A",144,0)
6032
S HLFS=RORHL("FS"),HLECH=RORHL("ECH"),CS=$E(HLECH,1)
6033
"RTN","RORHL7A",145,0)
6034
;--- Post-processing
6035
"RTN","RORHL7A",146,0)
6036
S SEG=SEG_$G(SEG(1))
6037
"RTN","RORHL7A",147,0)
6038
S:$G(BDT)'>0 BDT=$$NOW^XLFDT
6039
"RTN","RORHL7A",148,0)
6040
S TMP=$E($P($$SITE^VASITE,U,3),1,3)
6041
"RTN","RORHL7A",149,0)
6042
S $P(SEG,HLFS,4)=TMP_CS_$G(^XMB("NETNAME"))_CS_"DNS"
6043
"RTN","RORHL7A",150,0)
6044
S $P(SEG,HLFS,5)="ROR AAC"
6045
"RTN","RORHL7A",151,0)
6046
S $P(SEG,HLFS,7)=$$FMTHL7^XLFDT(BDT)
6047
"RTN","RORHL7A",152,0)
6048
S TMP=$P(SEG,HLFS,9)
6049
"RTN","RORHL7A",153,0)
6050
S $P(TMP,CS,3)=$P(TMP,CS,3)_$E(HLECH,2)_$G(RORHL("ETN"))
6051
"RTN","RORHL7A",154,0)
6052
S $P(SEG,HLFS,9)=TMP
6053
"RTN","RORHL7A",155,0)
6054
S $P(SEG,HLFS,10)=$G(COMMENT)
6055
"RTN","RORHL7A",156,0)
6056
Q SEG
6057
"RTN","RORHL7A",157,0)
6058
;
6059
"RTN","RORHL7A",158,0)
6060
;***** RETURNS BTS SEGMENT
6061
"RTN","RORHL7A",159,0)
6062
;
6063
"RTN","RORHL7A",160,0)
6064
; MSGCNT Batch message count
6065
"RTN","RORHL7A",161,0)
6066
; [COMMENT] Batch comment
6067
"RTN","RORHL7A",162,0)
6068
;
6069
"RTN","RORHL7A",163,0)
6070
; The RORHL variable must be initialized by the INIT^HLFNC2 before
6071
"RTN","RORHL7A",164,0)
6072
; calling this entry point
6073
"RTN","RORHL7A",165,0)
6074
;
6075
"RTN","RORHL7A",166,0)
6076
BTS(MSGCNT,COMMENT) ;
6077
"RTN","RORHL7A",167,0)
6078
Q "BTS"_RORHL("FS")_MSGCNT_RORHL("FS")_$G(COMMENT)
6079
"RTN","RORHL7A",168,0)
6080
;
6081
"RTN","RORHL7A",169,0)
6082
;***** LOADS THE HL7 FIELD (OR ITS PART) TO THE BUFFER
6083
"RTN","RORHL7A",170,0)
6084
;
6085
"RTN","RORHL7A",171,0)
6086
; VAL Value of the field (or its part)
6087
"RTN","RORHL7A",172,0)
6088
;
6089
"RTN","RORHL7A",173,0)
6090
; FLD Number of the field in the segment (piece number)
6091
"RTN","RORHL7A",174,0)
6092
;
6093
"RTN","RORHL7A",175,0)
6094
FIELD(VAL,FLD) ;
6095
"RTN","RORHL7A",176,0)
6096
N BASE,L
6097
"RTN","RORHL7A",177,0)
6098
S:FLD>RORFLD RORFLD=FLD,RORIS=0,RORSL=245
6099
"RTN","RORHL7A",178,0)
6100
S L=$L(VAL),BASE=1
6101
"RTN","RORHL7A",179,0)
6102
F RORIS=RORIS:1 D Q:L'>0
6103
"RTN","RORHL7A",180,0)
6104
. I 'RORIS S RORSEG(RORFLD)=$G(RORSEG(RORFLD))_$E(VAL,BASE,BASE+RORSL-1)
6105
"RTN","RORHL7A",181,0)
6106
. E S RORSEG(RORFLD,RORIS)=$G(RORSEG(RORFLD,RORIS))_$E(VAL,BASE,BASE+RORSL-1)
6107
"RTN","RORHL7A",182,0)
6108
. S BASE=BASE+RORSL,L=L-RORSL,RORSL=245
6109
"RTN","RORHL7A",183,0)
6110
S RORSL=-L
6111
"RTN","RORHL7A",184,0)
6112
Q
6113
"RTN","RORHL7A",185,0)
6114
;
6115
"RTN","RORHL7A",186,0)
6116
;***** LOADS THE HL7 SEGMENT INTO THE RPOVIDED BUFFER
6117
"RTN","RORHL7A",187,0)
6118
;
6119
"RTN","RORHL7A",188,0)
6120
; .RORSEG Reference to a local variable where the HL7
6121
"RTN","RORHL7A",189,0)
6122
; fields will be stored. The fields are stored
6123
"RTN","RORHL7A",190,0)
6124
; in the following format:
6125
"RTN","RORHL7A",191,0)
6126
;
6127
"RTN","RORHL7A",192,0)
6128
; RORSEG(FldNum)=FldVal
6129
"RTN","RORHL7A",193,0)
6130
;
6131
"RTN","RORHL7A",194,0)
6132
; If the value is longer that 245 characters then
6133
"RTN","RORHL7A",195,0)
6134
; the continuation nodes are created:
6135
"RTN","RORHL7A",196,0)
6136
;
6137
"RTN","RORHL7A",197,0)
6138
; RORSEG(FldNum,#)=FldValCont
6139
"RTN","RORHL7A",198,0)
6140
;
6141
"RTN","RORHL7A",199,0)
6142
; ROR8SRC Closed root of the source buffer containing
6143
"RTN","RORHL7A",200,0)
6144
; the HL7 segment
6145
"RTN","RORHL7A",201,0)
6146
;
6147
"RTN","RORHL7A",202,0)
6148
LOADSEG(RORSEG,ROR8SRC) ;
6149
"RTN","RORHL7A",203,0)
6150
N BUF,FLD,I,IFL,NFL,RORFLD,RORIS,RORSL
6151
"RTN","RORHL7A",204,0)
6152
S HLFS=RORHL("FS") K RORSEG
6153
"RTN","RORHL7A",205,0)
6154
;--- Process the main segment
6155
"RTN","RORHL7A",206,0)
6156
S BUF=$G(@ROR8SRC),NFL=$L(BUF,HLFS)
6157
"RTN","RORHL7A",207,0)
6158
F IFL=1:1:NFL S RORSEG(IFL-1)=$P(BUF,HLFS,IFL)
6159
"RTN","RORHL7A",208,0)
6160
Q:$D(@ROR8SRC)<10
6161
"RTN","RORHL7A",209,0)
6162
;--- Process the sub-segments
6163
"RTN","RORHL7A",210,0)
6164
S (FLD,RORFLD)=NFL-1,RORIS=0,RORSL=245-$L(RORSEG(FLD))
6165
"RTN","RORHL7A",211,0)
6166
S I=""
6167
"RTN","RORHL7A",212,0)
6168
F S I=$O(@ROR8SRC@(I)) Q:I="" D
6169
"RTN","RORHL7A",213,0)
6170
. S BUF=@ROR8SRC@(I),NFL=$L(BUF,HLFS)
6171
"RTN","RORHL7A",214,0)
6172
. D FIELD($P(BUF,HLFS),FLD)
6173
"RTN","RORHL7A",215,0)
6174
. F IFL=2:1:NFL S FLD=FLD+1 D FIELD($P(BUF,HLFS,IFL),FLD)
6175
"RTN","RORHL7A",216,0)
6176
Q
6177
"RTN","RORHL7A",217,0)
6178
;
6179
"RTN","RORHL7A",218,0)
6180
;***** RETURNS TEXT EXPLANATIONS OF THE HL7 MESSAGE STATUS
6181
"RTN","RORHL7A",219,0)
6182
;
6183
"RTN","RORHL7A",220,0)
6184
; MSGST Status value returned by the $$MSGSTAT^HLUTIL
6185
"RTN","RORHL7A",221,0)
6186
;
6187
"RTN","RORHL7A",222,0)
6188
MSGSTXT(MSGST) ;
6189
"RTN","RORHL7A",223,0)
6190
N ST S ST=+MSGST
6191
"RTN","RORHL7A",224,0)
6192
Q:'ST "Message does not exist"
6193
"RTN","RORHL7A",225,0)
6194
Q:ST=1 "Waiting in queue"
6195
"RTN","RORHL7A",226,0)
6196
Q:ST=1.5 "Opening connection"
6197
"RTN","RORHL7A",227,0)
6198
Q:ST=1.7 "Awaiting response"
6199
"RTN","RORHL7A",228,0)
6200
Q:ST=2 "Awaiting application ack"
6201
"RTN","RORHL7A",229,0)
6202
Q:ST=3 "Successfully completed"
6203
"RTN","RORHL7A",230,0)
6204
Q:ST=4 "Error"
6205
"RTN","RORHL7A",231,0)
6206
Q:ST=8 "Being generated"
6207
"RTN","RORHL7A",232,0)
6208
Q:ST=9 "Awaiting processing"
6209
"RTN","RORHL7A",233,0)
6210
Q "Unknown"
6211
"RTN","RORHL7A",234,0)
6212
;
6213
"RTN","RORHL7A",235,0)
6214
;***** ASSIGNS THE 'SET ID'
6215
"RTN","RORHL7A",236,0)
6216
;
6217
"RTN","RORHL7A",237,0)
6218
; SEGNAME Name of the HL7 segment
6219
"RTN","RORHL7A",238,0)
6220
; [DISINC] Disable increment of the Set ID
6221
"RTN","RORHL7A",239,0)
6222
;
6223
"RTN","RORHL7A",240,0)
6224
; Return Values:
6225
"RTN","RORHL7A",241,0)
6226
; "" Not required for this segment
6227
"RTN","RORHL7A",242,0)
6228
; >0 Value for the Set ID field
6229
"RTN","RORHL7A",243,0)
6230
;
6231
"RTN","RORHL7A",244,0)
6232
SETID(SEGNAME,DISINC) ;
6233
"RTN","RORHL7A",245,0)
6234
N SETID
6235
"RTN","RORHL7A",246,0)
6236
Q:$G(SEGNAME)="" ""
6237
"RTN","RORHL7A",247,0)
6238
S SETID=+$G(ROREXT("HL7SID",SEGNAME))
6239
"RTN","RORHL7A",248,0)
6240
Q:SETID'>0 ""
6241
"RTN","RORHL7A",249,0)
6242
S:'$G(DISINC) ROREXT("HL7SID",SEGNAME)=SETID+1
6243
"RTN","RORHL7A",250,0)
6244
Q SETID
6245
"RTN","VALMW3")
6246
0^41^B21033865
6247
"RTN","VALMW3",1,0)
6248
VALMW3 ; ALB/MJK,MSC/JDA - Create transport routines for LM;27APR2009
6249
"RTN","VALMW3",2,0)
6250
;;1;List Manager;**MSC**;Aug 13, 1993
6251
"RTN","VALMW3",3,0)
6252
;
6253
"RTN","VALMW3",4,0)
6254
EN ; -- exporter main entry point
6255
"RTN","VALMW3",5,0)
6256
N VALMSYS,VALMNS,VALMROU,VALMAX
6257
"RTN","VALMW3",6,0)
6258
S U="^",DTIME=600 K ^UTILITY($J)
6259
"RTN","VALMW3",7,0)
6260
D HOME^%ZIS
6261
"RTN","VALMW3",8,0)
6262
W @IOF,!?20,"*** List Template Export Utility ***"
6263
"RTN","VALMW3",9,0)
6264
I '$$DUZ() G ENQ
6265
"RTN","VALMW3",10,0)
6266
S VALMSYS=$$OS() I VALMSYS="" G ENQ
6267
"RTN","VALMW3",11,0)
6268
S VALMNS=$$NS() I VALMNS="" G ENQ
6269
"RTN","VALMW3",12,0)
6270
S VALMROU=$$ROU(.VALMNS) I VALMROU="" G ENQ
6271
"RTN","VALMW3",13,0)
6272
S VALMAX=$$MAX() I 'VALMAX G ENQ
6273
"RTN","VALMW3",14,0)
6274
W !!!,">>> Exporting LIST TEMPLATES with namespace '"_VALMNS_"'."
6275
"RTN","VALMW3",15,0)
6276
D BLD,FILE(.VALMROU)
6277
"RTN","VALMW3",16,0)
6278
ENQ Q
6279
"RTN","VALMW3",17,0)
6280
;
6281
"RTN","VALMW3",18,0)
6282
;
6283
"RTN","VALMW3",19,0)
6284
DUZ() ; -- check duz and duz(0)
6285
"RTN","VALMW3",20,0)
6286
I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) D
6287
"RTN","VALMW3",21,0)
6288
.W !,"PROGRAMMER ACCESS REQUIRED",!
6289
"RTN","VALMW3",22,0)
6290
.S Y=0
6291
"RTN","VALMW3",23,0)
6292
E S Y=1
6293
"RTN","VALMW3",24,0)
6294
Q Y
6295
"RTN","VALMW3",25,0)
6296
;
6297
"RTN","VALMW3",26,0)
6298
OS() ; -- get os #
6299
"RTN","VALMW3",27,0)
6300
I $D(^%ZOSF("OS"))#2 D
6301
"RTN","VALMW3",28,0)
6302
.S Y=+$P(^("OS"),"^",2)
6303
"RTN","VALMW3",29,0)
6304
E S Y=0
6305
"RTN","VALMW3",30,0)
6306
Q Y
6307
"RTN","VALMW3",31,0)
6308
;
6309
"RTN","VALMW3",32,0)
6310
NS() ; -- ask for namespace
6311
"RTN","VALMW3",33,0)
6312
NS1 S VALMNS=""
6313
"RTN","VALMW3",34,0)
6314
W !!,">>> Enter the Name of the Package (2-4 characters): "
6315
"RTN","VALMW3",35,0)
6316
R X:$S($D(DTIME):DTIME,1:60) G NSQ:"^"[X
6317
"RTN","VALMW3",36,0)
6318
I X'?1U1.NU!($L(X)>4) D NS^VALMW5 G NS1
6319
"RTN","VALMW3",37,0)
6320
S VALMNS="",DIC="^DIC(9.4,",DIC(0)="EZ",D="C" D IX^DIC
6321
"RTN","VALMW3",38,0)
6322
I Y>0 S SDPK=+Y,VALMNS=$P(Y(0),U,2)
6323
"RTN","VALMW3",39,0)
6324
S:Y<1!(VALMNS="") VALMNS=$$ADHOC(X)
6325
"RTN","VALMW3",40,0)
6326
NSQ Q VALMNS
6327
"RTN","VALMW3",41,0)
6328
;
6329
"RTN","VALMW3",42,0)
6330
ROU(VALMNS) ; -- ask for export routine name
6331
"RTN","VALMW3",43,0)
6332
N ROU,DIR,X,Q
6333
"RTN","VALMW3",44,0)
6334
ROU1 S VALMROU=""
6335
"RTN","VALMW3",45,0)
6336
W ! S:$G(VALMNS)]"" DIR("B")=VALMNS_"L"
6337
"RTN","VALMW3",46,0)
6338
S DIR("A")=">>> Enter Routine Name",DIR(0)="F^2:6^" D ^DIR K DIR
6339
"RTN","VALMW3",47,0)
6340
G ROUQ:"^"[Y S VALMROU=Y
6341
"RTN","VALMW3",48,0)
6342
W !!,"I am going to create a series of '",VALMROU,"*' routines."
6343
"RTN","VALMW3",49,0)
6344
I $D(^%ZOSF("TEST"))#2 X ^("TEST") I W *7,!,"but '"_VALMROU_"' is ALREADY ON FILE!" S Q=1
6345
"RTN","VALMW3",50,0)
6346
W !,"Is that OK" D YN^DICN
6347
"RTN","VALMW3",51,0)
6348
I %<0!(%=2) S:%=2 VALMROU="" G ROUQ
6349
"RTN","VALMW3",52,0)
6350
I '% D ROU^VALMW5 G ROU1
6351
"RTN","VALMW3",53,0)
6352
ROUQ Q VALMROU
6353
"RTN","VALMW3",54,0)
6354
;
6355
"RTN","VALMW3",55,0)
6356
MAX() ; -- ask for max size of routines
6357
"RTN","VALMW3",56,0)
6358
N Y
6359
"RTN","VALMW3",57,0)
6360
MAX1 S Y=""
6361
"RTN","VALMW3",58,0)
6362
W !!,">>> MAXIMUM ROUTINE SIZE(BYTES): ",^DD("ROU"),"// "
6363
"RTN","VALMW3",59,0)
6364
R Y:$S($D(DTIME):DTIME,1:60) I '$T G MAXQ
6365
"RTN","VALMW3",60,0)
6366
S:Y="" Y=^DD("ROU")
6367
"RTN","VALMW3",61,0)
6368
I Y[U S Y="" G MAXQ
6369
"RTN","VALMW3",62,0)
6370
I Y\1'=Y!(Y<2000)!(Y>9999) D MAX^VALMW5 G MAX1
6371
"RTN","VALMW3",63,0)
6372
MAXQ Q Y
6373
"RTN","VALMW3",64,0)
6374
;
6375
"RTN","VALMW3",65,0)
6376
ADHOC(X) ; -- pick any namespace
6377
"RTN","VALMW3",66,0)
6378
L W !!,"Package "_X_" not found"
6379
"RTN","VALMW3",67,0)
6380
W !,"Please enter the package namespace you wish to export: "
6381
"RTN","VALMW3",68,0)
6382
R X:300
6383
"RTN","VALMW3",69,0)
6384
I '$T!(X="")!(X'?1A.E) S X="" G LQ
6385
"RTN","VALMW3",70,0)
6386
I $L(X)>4 W !,"Namespace too long" G L
6387
"RTN","VALMW3",71,0)
6388
LQ Q X
6389
"RTN","VALMW3",72,0)
6390
;
6391
"RTN","VALMW3",73,0)
6392
BLD ; -- build utility
6393
"RTN","VALMW3",74,0)
6394
N VALMLN,VALMX,VALMNAME,VALM,VALMGLB
6395
"RTN","VALMW3",75,0)
6396
S VALMLN=0,VALMX=VALMNS
6397
"RTN","VALMW3",76,0)
6398
F S VALMX=$O(^SD(409.61,"B",VALMX)) Q:VALMX=""!($E(VALMX,1,$L(VALMNS))'=VALMNS) S VALM=+$O(^(VALMX,0)) I $D(^SD(409.61,VALM,0)),$P(^(0),U,7) S VALMNAME=$P(^(0),U) D
6399
"RTN","VALMW3",77,0)
6400
.W !?5,"o ",VALMNAME
6401
"RTN","VALMW3",78,0)
6402
.D SET(" W !,""'"_VALMNAME_"' List Template...""")
6403
"RTN","VALMW3",79,0)
6404
.D SET(" S DA=$O(^SD(409.61,""B"","""_VALMNAME_""",0)),DIK=""^SD(409.61,"" D ^DIK:DA")
6405
"RTN","VALMW3",80,0)
6406
.D SET(" K DO,DD S DIC(0)=""L"",DIC=""^SD(409.61,"",X="""_VALMNAME_""" D FILE^DICN S VALM=+Y")
6407
"RTN","VALMW3",81,0)
6408
.D SET(" I VALM>0 D")
6409
"RTN","VALMW3",82,0)
6410
.;
6411
"RTN","VALMW3",83,0)
6412
.S VALMGLB="^SD(409.61,"_VALM_",",X=VALMGLB_"-1)"
6413
"RTN","VALMW3",84,0)
6414
.F S X=$Q(@X) Q:$E(X,1,$L(VALMGLB))'=VALMGLB D:X'[",""B""," SET(" .S ^SD(409.61,VALM,"_$P(X,VALMGLB,2,99)_"="""_$$QUOTE(@X)_"""")
6415
"RTN","VALMW3",85,0)
6416
.;
6417
"RTN","VALMW3",86,0)
6418
.D SET(" .S DA=VALM,DIK=""^SD(409.61,"" D IX1^DIK K DA,DIK")
6419
"RTN","VALMW3",87,0)
6420
.D SET(" .W ""Filed.""")
6421
"RTN","VALMW3",88,0)
6422
.D SET(" ;")
6423
"RTN","VALMW3",89,0)
6424
D SET(" K DIC,DIK,VALM,X,DA Q")
6425
"RTN","VALMW3",90,0)
6426
Q3 Q
6427
"RTN","VALMW3",91,0)
6428
;
6429
"RTN","VALMW3",92,0)
6430
SET(X) ; -- set line utility
6431
"RTN","VALMW3",93,0)
6432
S VALMLN=VALMLN+1,^UTILITY($J,VALMLN,0)=X W "."
6433
"RTN","VALMW3",94,0)
6434
Q
6435
"RTN","VALMW3",95,0)
6436
;
6437
"RTN","VALMW3",96,0)
6438
QUOTE(X) ; -- add double quotes
6439
"RTN","VALMW3",97,0)
6440
N P,L
6441
"RTN","VALMW3",98,0)
6442
S P=1,L=$L(X)
6443
"RTN","VALMW3",99,0)
6444
F S P=$F(X,"""",P) Q:'P!(P>(L+1)) S X=$E(X,1,P-1)_""""_$E(X,P,L),L=L+1,P=P+1
6445
"RTN","VALMW3",100,0)
6446
Q X
6447
"RTN","VALMW3",101,0)
6448
;
6449
"RTN","VALMW3",102,0)
6450
FILE(VALMROU) ; -- file routines
6451
"RTN","VALMW3",103,0)
6452
N %H,VALMDATE,VALMNUM,VALMLN
6453
"RTN","VALMW3",104,0)
6454
S %H=+$H D YX^%DTC
6455
"RTN","VALMW3",105,0)
6456
S VALMDATE=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)
6457
"RTN","VALMW3",106,0)
6458
S VALMNUM="",VALMLN=0
6459
"RTN","VALMW3",107,0)
6460
F D SAVE(.VALMROU,.VALMNUM,.VALMLN,.VALMDATE) Q:VALMLN="" S VALMNUM=VALMNUM+1
6461
"RTN","VALMW3",108,0)
6462
Q
6463
"RTN","VALMW3",109,0)
6464
;
6465
"RTN","VALMW3",110,0)
6466
SAVE(VALMROU,VALMNUM,VALMLN,VALMDATE) ; -- save to routine
6467
"RTN","VALMW3",111,0)
6468
N LINE,SIZE
6469
"RTN","VALMW3",112,0)
6470
K ^UTILITY($J,0) S ^(0,1)=VALMROU_VALMNUM_" ; List Template Exporter ; "_VALMDATE,^(1.1)=" ;; ;",SIZE=0
6471
"RTN","VALMW3",113,0)
6472
F LINE=2:1 S VALMLN=$O(^UTILITY($J,VALMLN)) Q:VALMLN="" S ^UTILITY($J,0,LINE)=^(VALMLN,0),SIZE=$L(^(LINE))+SIZE I $E(^(LINE),1,2)'=" .",SIZE+700>VALMAX Q
6473
"RTN","VALMW3",114,0)
6474
I VALMLN,$O(^UTILITY($J,VALMLN)) S ^UTILITY($J,0,LINE+1)=" G ^"_VALMROU_(VALMNUM+1)
6475
"RTN","VALMW3",115,0)
6476
S X=VALMROU_VALMNUM X ^DD("OS",VALMSYS,"ZS") W !,X_" has been filed..."
6477
"RTN","VALMW3",116,0)
6478
Q
6479
"RTN","VALMW3",117,0)
6480
;
6481
"RTN","XOBVLL")
6482
0^19^B18012967
6483
"RTN","XOBVLL",1,0)
6484
XOBVLL ;; mjk/alb MSC/JDA - VistALink Listen and Spawn Code ;13APR2009
6485
"RTN","XOBVLL",2,0)
6486
;;1.5;VistALink;**MSC**;Sep 09, 2005
6487
"RTN","XOBVLL",3,0)
6488
;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
6489
"RTN","XOBVLL",4,0)
6490
;
6491
"RTN","XOBVLL",5,0)
6492
QUIT
6493
"RTN","XOBVLL",6,0)
6494
;
6495
"RTN","XOBVLL",7,0)
6496
; ***deprecated*** tag ; Use START^XOBVTCP instead
6497
"RTN","XOBVLL",8,0)
6498
START(SOCKET) ; -- start listener
6499
"RTN","XOBVLL",9,0)
6500
DO START^XOBVTCP(SOCKET)
6501
"RTN","XOBVLL",10,0)
6502
QUIT
6503
"RTN","XOBVLL",11,0)
6504
;
6505
"RTN","XOBVLL",12,0)
6506
; ***deprecated*** tag ; Use UCX^XOBVTCP instead
6507
"RTN","XOBVLL",13,0)
6508
UCX ; -- VMS TCPIP (UCX) multi-thread entry point
6509
"RTN","XOBVLL",14,0)
6510
; -- Called from VistALink .com files
6511
"RTN","XOBVLL",15,0)
6512
GOTO UCX^XOBVTCP
6513
"RTN","XOBVLL",16,0)
6514
;
6515
"RTN","XOBVLL",17,0)
6516
SPAWN ; -- spawned process
6517
"RTN","XOBVLL",18,0)
6518
NEW X,XOBSTOP,XOBPORT,XOBHDLR,XOBLASTR
6519
"RTN","XOBVLL",19,0)
6520
;
6521
"RTN","XOBVLL",20,0)
6522
SET XOBSTOP=0
6523
"RTN","XOBVLL",21,0)
6524
SET XOBPORT=IO
6525
"RTN","XOBVLL",22,0)
6526
SET U="^"
6527
"RTN","XOBVLL",23,0)
6528
;
6529
"RTN","XOBVLL",24,0)
6530
; -- initialize timestamp for last time request made (used for debugging)
6531
"RTN","XOBVLL",25,0)
6532
SET XOBLASTR=0
6533
"RTN","XOBVLL",26,0)
6534
;
6535
"RTN","XOBVLL",27,0)
6536
; -- set error trap
6537
"RTN","XOBVLL",28,0)
6538
;Set up the error trap
6539
"RTN","XOBVLL",29,0)
6540
SET $ETRAP="DO ^%ZTER HALT"
6541
"RTN","XOBVLL",30,0)
6542
;
6543
"RTN","XOBVLL",31,0)
6544
; -- attempt to share the license; must have TCP port open first
6545
"RTN","XOBVLL",32,0)
6546
USE XOBPORT IF $TEXT(SHARELIC^%ZOSV)'="" DO SHARELIC^%ZOSV(1)
6547
"RTN","XOBVLL",33,0)
6548
;
6549
"RTN","XOBVLL",34,0)
6550
; -- start RUM for VistALink Handler
6551
"RTN","XOBVLL",35,0)
6552
DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
6553
"RTN","XOBVLL",36,0)
6554
;
6555
"RTN","XOBVLL",37,0)
6556
SET:^%ZOSF("OS")["GT.M" X=$$GTM^XOBVRH(.XOBHDLR)
6557
"RTN","XOBVLL",38,0)
6558
; -- cache/initialize startup request handlers
6559
"RTN","XOBVLL",39,0)
6560
SET:^%ZOSF("OS")["OpenM" X=$$CACHE^XOBVRH(.XOBHDLR)
6561
"RTN","XOBVLL",40,0)
6562
IF 'X DO RMERR^XOBVRM(184001,$PIECE(X,U,2)) QUIT
6563
"RTN","XOBVLL",41,0)
6564
;
6565
"RTN","XOBVLL",42,0)
6566
; -- initialize tcp processing variables
6567
"RTN","XOBVLL",43,0)
6568
DO INIT^XOBVSKT
6569
"RTN","XOBVLL",44,0)
6570
;
6571
"RTN","XOBVLL",45,0)
6572
; -- change job name if possible
6573
"RTN","XOBVLL",46,0)
6574
DO SETNM^%ZOSV("VLink_"_$$CNV^XLFUTL($J,16))
6575
"RTN","XOBVLL",47,0)
6576
;
6577
"RTN","XOBVLL",48,0)
6578
; -- loop until told to stop
6579
"RTN","XOBVLL",49,0)
6580
FOR DO NXTCALL QUIT:XOBSTOP
6581
"RTN","XOBVLL",50,0)
6582
;
6583
"RTN","XOBVLL",51,0)
6584
; -- final/clean tcp processing variables
6585
"RTN","XOBVLL",52,0)
6586
DO FINAL^XOBVSKT
6587
"RTN","XOBVLL",53,0)
6588
;
6589
"RTN","XOBVLL",54,0)
6590
; -- stop RUM for VistALink Handler
6591
"RTN","XOBVLL",55,0)
6592
DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,2)
6593
"RTN","XOBVLL",56,0)
6594
;
6595
"RTN","XOBVLL",57,0)
6596
QUIT
6597
"RTN","XOBVLL",58,0)
6598
;
6599
"RTN","XOBVLL",59,0)
6600
NXTCALL ; -- do next call
6601
"RTN","XOBVLL",60,0)
6602
NEW X,XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBOK,XOBRL,XOBDATA
6603
"RTN","XOBVLL",61,0)
6604
;
6605
"RTN","XOBVLL",62,0)
6606
; -- set up error trap
6607
"RTN","XOBVLL",63,0)
6608
NEW $ESTACK SET $ETRAP="DO SYSERR^XOBVLL"
6609
"RTN","XOBVLL",64,0)
6610
;
6611
"RTN","XOBVLL",65,0)
6612
; -- setup environment variables
6613
"RTN","XOBVLL",66,0)
6614
NEW DIQUIET SET DIQUIET=1
6615
"RTN","XOBVLL",67,0)
6616
SET U="^",DTIME=$GET(DTIME,900),DT=$$DT^XLFDT()
6617
"RTN","XOBVLL",68,0)
6618
;
6619
"RTN","XOBVLL",69,0)
6620
; -- initialize 'current' request handler to empty string
6621
"RTN","XOBVLL",70,0)
6622
SET XOBHDLR=""
6623
"RTN","XOBVLL",71,0)
6624
;
6625
"RTN","XOBVLL",72,0)
6626
; -- # of chars to get on first read / read 11 for Broker initial read
6627
"RTN","XOBVLL",73,0)
6628
SET XOBREAD=11
6629
"RTN","XOBVLL",74,0)
6630
;
6631
"RTN","XOBVLL",75,0)
6632
; -- get J2SE heartbet rate for timeout plus network latency factor
6633
"RTN","XOBVLL",76,0)
6634
SET XOBTO=$$GETRATE^XOBVLIB()+$$GETDELTA^XOBVLIB()
6635
"RTN","XOBVLL",77,0)
6636
;
6637
"RTN","XOBVLL",78,0)
6638
; -- get J2EE timeout value for app serv environment
6639
"RTN","XOBVLL",79,0)
6640
IF $GET(XOBSYS("ENV"))="j2ee" SET XOBTO=$$GETASTO^XOBVLIB()
6641
"RTN","XOBVLL",80,0)
6642
;
6643
"RTN","XOBVLL",81,0)
6644
; -- set first read flag
6645
"RTN","XOBVLL",82,0)
6646
SET XOBFIRST=1
6647
"RTN","XOBVLL",83,0)
6648
;
6649
"RTN","XOBVLL",84,0)
6650
; -- setup intake global
6651
"RTN","XOBVLL",85,0)
6652
SET XOBROOT=$NAME(^TMP("XOBVLL",$JOB))
6653
"RTN","XOBVLL",86,0)
6654
KILL @XOBROOT
6655
"RTN","XOBVLL",87,0)
6656
;
6657
"RTN","XOBVLL",88,0)
6658
; -- read from socket port
6659
"RTN","XOBVLL",89,0)
6660
USE XOBPORT
6661
"RTN","XOBVLL",90,0)
6662
SET XOBOK=$$READ^XOBVSKT(XOBROOT,.XOBREAD,.XOBTO,.XOBFIRST,.XOBSTOP,.XOBDATA,.XOBHDLR)
6663
"RTN","XOBVLL",91,0)
6664
;
6665
"RTN","XOBVLL",92,0)
6666
; -- timed out ; cleanup user and exit
6667
"RTN","XOBVLL",93,0)
6668
IF 'XOBOK!(XOBSTOP) DO GOTO NXTCALLQ
6669
"RTN","XOBVLL",94,0)
6670
. IF $GET(DUZ) DO CLEAN^XOBSCAV1
6671
"RTN","XOBVLL",95,0)
6672
. SET XOBSTOP=1
6673
"RTN","XOBVLL",96,0)
6674
;
6675
"RTN","XOBVLL",97,0)
6676
; -- need null device
6677
"RTN","XOBVLL",98,0)
6678
IF '$DATA(XOBNULL) DO ERROR(181002,$$EZBLD^DIALOG(181002),XOBPORT) SET XOBSTOP=1 GOTO NXTCALLQ
6679
"RTN","XOBVLL",99,0)
6680
;
6681
"RTN","XOBVLL",100,0)
6682
; -- call request manager
6683
"RTN","XOBVLL",101,0)
6684
SET XOBOK=$$EN^XOBVRM(XOBROOT,.XOBDATA,.XOBHDLR)
6685
"RTN","XOBVLL",102,0)
6686
; -- timestamp last time request made
6687
"RTN","XOBVLL",103,0)
6688
SET XOBLASTR=$$NOW^XLFDT()
6689
"RTN","XOBVLL",104,0)
6690
; -- cleanup intake global
6691
"RTN","XOBVLL",105,0)
6692
KILL @XOBROOT
6693
"RTN","XOBVLL",106,0)
6694
;
6695
"RTN","XOBVLL",107,0)
6696
NXTCALLQ ; -- exit
6697
"RTN","XOBVLL",108,0)
6698
QUIT
6699
"RTN","XOBVLL",109,0)
6700
;
6701
"RTN","XOBVLL",110,0)
6702
; ----------------------------------------------------------------------------------
6703
"RTN","XOBVLL",111,0)
6704
; System Error Handler
6705
"RTN","XOBVLL",112,0)
6706
; ----------------------------------------------------------------------------------
6707
"RTN","XOBVLL",113,0)
6708
SYSERR ; -- send system error message
6709
"RTN","XOBVLL",114,0)
6710
; -- If we get an error in the error handler just Halt
6711
"RTN","XOBVLL",115,0)
6712
SET $ETRAP="D ^%ZTER HALT"
6713
"RTN","XOBVLL",116,0)
6714
;
6715
"RTN","XOBVLL",117,0)
6716
DO ERROR(181001,$$EZBLD^DIALOG(181001,$$EC^%ZOSV),XOBPORT) ; -- Get the error code
6717
"RTN","XOBVLL",118,0)
6718
QUIT
6719
"RTN","XOBVLL",119,0)
6720
;
6721
"RTN","XOBVLL",120,0)
6722
ERROR(XOBEC,XOBMSG,XOBPORT) ; -- send error message
6723
"RTN","XOBVLL",121,0)
6724
NEW XOBDAT
6725
"RTN","XOBVLL",122,0)
6726
;
6727
"RTN","XOBVLL",123,0)
6728
; -- If we get an error in the error handler just Halt
6729
"RTN","XOBVLL",124,0)
6730
SET $ETRAP="D ^%ZTER HALT"
6731
"RTN","XOBVLL",125,0)
6732
;
6733
"RTN","XOBVLL",126,0)
6734
; -- set up error info
6735
"RTN","XOBVLL",127,0)
6736
SET XOBDAT("MESSAGE TYPE")=3
6737
"RTN","XOBVLL",128,0)
6738
SET XOBDAT("ERRORS",1,"CODE")=XOBEC
6739
"RTN","XOBVLL",129,0)
6740
SET XOBDAT("ERRORS",1,"ERROR TYPE")="system"
6741
"RTN","XOBVLL",130,0)
6742
SET XOBDAT("ERRORS",1,"FAULT STRING")="System Error"
6743
"RTN","XOBVLL",131,0)
6744
SET XOBDAT("ERRORS",1,"CDATA")=1
6745
"RTN","XOBVLL",132,0)
6746
SET XOBDAT("ERRORS",1,"MESSAGE",1)=XOBMSG
6747
"RTN","XOBVLL",133,0)
6748
;
6749
"RTN","XOBVLL",134,0)
6750
; -- if serious error, save error info, logout, and halt
6751
"RTN","XOBVLL",135,0)
6752
IF XOBMSG["<READ>"!(XOBMSG["<WRITE>")!(XOBMSG["<SYSTEM>")!(XOBMSG["READERR")!(XOBMSG["WRITERR")!(XOBMSG["SYSERR") DO HALT
6753
"RTN","XOBVLL",136,0)
6754
. DO ^%ZTER
6755
"RTN","XOBVLL",137,0)
6756
. IF $GET(DUZ) DO CLEAN^XOBSCAV1
6757
"RTN","XOBVLL",138,0)
6758
;
6759
"RTN","XOBVLL",139,0)
6760
; -- send error back to client
6761
"RTN","XOBVLL",140,0)
6762
USE XOBPORT
6763
"RTN","XOBVLL",141,0)
6764
DO ERROR^XOBVLIB(.XOBDAT)
6765
"RTN","XOBVLL",142,0)
6766
;
6767
"RTN","XOBVLL",143,0)
6768
; -- just quit if no slots are available or logins are disabled
6769
"RTN","XOBVLL",144,0)
6770
IF (XOBEC=181003)!(XOBEC=181004) QUIT
6771
"RTN","XOBVLL",145,0)
6772
;
6773
"RTN","XOBVLL",146,0)
6774
; -- need to make sure any locks are released since code aborted ungracefully
6775
"RTN","XOBVLL",147,0)
6776
LOCK
6777
"RTN","XOBVLL",148,0)
6778
;
6779
"RTN","XOBVLL",149,0)
6780
; -- Save off the error
6781
"RTN","XOBVLL",150,0)
6782
DO ^%ZTER
6783
"RTN","XOBVLL",151,0)
6784
;
6785
"RTN","XOBVLL",152,0)
6786
; -- go back to listening
6787
"RTN","XOBVLL",153,0)
6788
SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" DO KILL^XOBVLL G NXTCALLQ^XOBVLL",$ECODE=",U99,"
6789
"RTN","XOBVLL",154,0)
6790
QUIT
6791
"RTN","XOBVLL",155,0)
6792
;
6793
"RTN","XOBVLL",156,0)
6794
KILL ; -- new VistALink variables and then do big KILL
6795
"RTN","XOBVLL",157,0)
6796
NEW XOBPORT,XOBSTOP,XOBNULL,XOBOS,XOBSYS,XOBHDLR,XOBOK
6797
"RTN","XOBVLL",158,0)
6798
DO KILL^XUSCLEAN
6799
"RTN","XOBVLL",159,0)
6800
QUIT
6801
"RTN","XOBVLL",160,0)
6802
;
6803
"RTN","XOBVRH")
6804
0^20^B13028891
6805
"RTN","XOBVRH",1,0)
6806
XOBVRH ;mjk/alb SC/JDA - VistaLink Request Handler Utilities ;13APR2009
6807
"RTN","XOBVRH",2,0)
6808
;;1.5;VistALink;**MSC**;Sep 09, 2005
6809
"RTN","XOBVRH",3,0)
6810
;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
6811
"RTN","XOBVRH",4,0)
6812
;
6813
"RTN","XOBVRH",5,0)
6814
QUIT
6815
"RTN","XOBVRH",6,0)
6816
;
6817
"RTN","XOBVRH",7,0)
6818
; ------------------------------------------------------------------
6819
"RTN","XOBVRH",8,0)
6820
; Message Type Handler Utilities
6821
"RTN","XOBVRH",9,0)
6822
; ------------------------------------------------------------------
6823
"RTN","XOBVRH",10,0)
6824
;
6825
"RTN","XOBVRH",11,0)
6826
; -- set up msg type info using message name
6827
"RTN","XOBVRH",12,0)
6828
MSGNAME(XOBMSG,XOBHDLR) ; -- set up msg type info
6829
"RTN","XOBVRH",13,0)
6830
QUIT $$SETMSG(XOBMSG,"NAME",.XOBHDLR)
6831
"RTN","XOBVRH",14,0)
6832
;
6833
"RTN","XOBVRH",15,0)
6834
; -- set up msg type info using message type
6835
"RTN","XOBVRH",16,0)
6836
MSGTYPE(XOBMSG,XOBHDLR) ; -- set up msg type info
6837
"RTN","XOBVRH",17,0)
6838
QUIT $$SETMSG(XOBMSG,"MSGTYPE",.XOBHDLR)
6839
"RTN","XOBVRH",18,0)
6840
;
6841
"RTN","XOBVRH",19,0)
6842
; -- set up msg type info using proprietary string
6843
"RTN","XOBVRH",20,0)
6844
MSGSINK(XOBMSG,XOBHDLR) ; -- set up msg type info
6845
"RTN","XOBVRH",21,0)
6846
QUIT $$SETMSG(XOBMSG,"D",.XOBHDLR)
6847
"RTN","XOBVRH",22,0)
6848
;
6849
"RTN","XOBVRH",23,0)
6850
CACHE(XOBHDLR) ; -- cache req handlers
6851
"RTN","XOBVRH",24,0)
6852
NEW TYPE,TYPE0,XOBOK
6853
"RTN","XOBVRH",25,0)
6854
SET TYPE=0
6855
"RTN","XOBVRH",26,0)
6856
SET XOBOK=1
6857
"RTN","XOBVRH",27,0)
6858
;
6859
"RTN","XOBVRH",28,0)
6860
; -- load request handler info
6861
"RTN","XOBVRH",29,0)
6862
FOR SET TYPE=$ORDER(^XOB(18.05,"AS",1,TYPE)) QUIT:'TYPE DO QUIT:'XOBOK
6863
"RTN","XOBVRH",30,0)
6864
. SET TYPE0=$GET(^XOB(18.05,TYPE,0))
6865
"RTN","XOBVRH",31,0)
6866
. DO SET(TYPE,TYPE0,.XOBHDLR)
6867
"RTN","XOBVRH",32,0)
6868
. SET XOBOK=$GET(XOBHDLR(TYPE))
6869
"RTN","XOBVRH",33,0)
6870
. IF 'XOBOK SET XOBOK=XOBOK_U_$GET(XOBHDLR,"ERROR")
6871
"RTN","XOBVRH",34,0)
6872
QUIT XOBOK
6873
"RTN","XOBVRH",35,0)
6874
;
6875
"RTN","XOBVRH",36,0)
6876
;
6877
"RTN","XOBVRH",37,0)
6878
GTM(XOBHDLR) ; -- GT.M req handlers
6879
"RTN","XOBVRH",38,0)
6880
Q $$CACHE(.XOBHDLR) ; Same as Cache until something different is needed
6881
"RTN","XOBVRH",39,0)
6882
;
6883
"RTN","XOBVRH",40,0)
6884
; -- set up msg type info
6885
"RTN","XOBVRH",41,0)
6886
SETMSG(XOBMSG,XOBXREF,XOBHDLR) ;
6887
"RTN","XOBVRH",42,0)
6888
NEW TYPE,TYPEO
6889
"RTN","XOBVRH",43,0)
6890
KILL XOBHDLR(0)
6891
"RTN","XOBVRH",44,0)
6892
;
6893
"RTN","XOBVRH",45,0)
6894
; -- already cached?
6895
"RTN","XOBVRH",46,0)
6896
SET TYPE=$ORDER(XOBHDLR(XOBXREF,XOBMSG,""))
6897
"RTN","XOBVRH",47,0)
6898
IF TYPE QUIT TYPE
6899
"RTN","XOBVRH",48,0)
6900
;
6901
"RTN","XOBVRH",49,0)
6902
; -- load req handler
6903
"RTN","XOBVRH",50,0)
6904
SET TYPE=+$ORDER(^XOB(18.05,XOBXREF,XOBMSG,""))
6905
"RTN","XOBVRH",51,0)
6906
IF TYPE DO
6907
"RTN","XOBVRH",52,0)
6908
. SET TYPE0=$GET(^XOB(18.05,TYPE,0))
6909
"RTN","XOBVRH",53,0)
6910
. DO SET(.TYPE,.TYPE0,.XOBHDLR)
6911
"RTN","XOBVRH",54,0)
6912
IF 'TYPE DO
6913
"RTN","XOBVRH",55,0)
6914
. SET XOBHDLR(0)=0
6915
"RTN","XOBVRH",56,0)
6916
. SET XOBHDLR(0,"ERROR")="No message type defined"
6917
"RTN","XOBVRH",57,0)
6918
QUIT TYPE
6919
"RTN","XOBVRH",58,0)
6920
;
6921
"RTN","XOBVRH",59,0)
6922
SET(TYPE,TYPE0,XOBHDLR) ; -- set nodes
6923
"RTN","XOBVRH",60,0)
6924
NEW IRTN,XOBICBK
6925
"RTN","XOBVRH",61,0)
6926
KILL XOBHDLR(TYPE)
6927
"RTN","XOBVRH",62,0)
6928
SET IRTN=$$IRTN(TYPE0)
6929
"RTN","XOBVRH",63,0)
6930
IF IRTN="" DO GOTO SETQ
6931
"RTN","XOBVRH",64,0)
6932
. SET XOBHDLR(TYPE)=0
6933
"RTN","XOBVRH",65,0)
6934
. IF TYPE0="" SET XOBHDLR(TYPE,"ERROR")="No entry for message type ["_TYPE_"]" QUIT
6935
"RTN","XOBVRH",66,0)
6936
. IF IRTN="" SET XOBHDLR(TYPE,"ERROR")="Invalid interface routine specified ["_$PIECE(TYPE0,U,5)_"]" QUIT
6937
"RTN","XOBVRH",67,0)
6938
;
6939
"RTN","XOBVRH",68,0)
6940
SET XOBHDLR(TYPE)=1
6941
"RTN","XOBVRH",69,0)
6942
SET XOBHDLR(TYPE,"AUTHENTICATE")=+$PIECE(TYPE0,U,4)
6943
"RTN","XOBVRH",70,0)
6944
SET XOBHDLR(TYPE,"REQHDLR")="DO REQHDLR^"_IRTN_"(.XOBDATA)"
6945
"RTN","XOBVRH",71,0)
6946
SET XOBHDLR(TYPE,"READER")="DO READER^"_IRTN_"(.XOBX,.XOBDATA)"
6947
"RTN","XOBVRH",72,0)
6948
IF $PIECE(TYPE0,U,1)]"" SET XOBHDLR("NAME",$PIECE(TYPE0,U,1),TYPE)=""
6949
"RTN","XOBVRH",73,0)
6950
IF $PIECE(TYPE0,U,2)]"" SET XOBHDLR("MSGTYPE",$PIECE(TYPE0,U,2),TYPE)=""
6951
"RTN","XOBVRH",74,0)
6952
IF $PIECE(TYPE0,U,7)]"" SET XOBHDLR("D",$PIECE(TYPE0,U,7),TYPE)=""
6953
"RTN","XOBVRH",75,0)
6954
;
6955
"RTN","XOBVRH",76,0)
6956
; -- set up SAX callbacks
6957
"RTN","XOBVRH",77,0)
6958
SET XOBHDLR(TYPE,"CB","ELEST")="QUIT"
6959
"RTN","XOBVRH",78,0)
6960
SET XOBHDLR(TYPE,"CB","ELEND")="QUIT"
6961
"RTN","XOBVRH",79,0)
6962
SET XOBHDLR(TYPE,"CB","CHR")="QUIT"
6963
"RTN","XOBVRH",80,0)
6964
;
6965
"RTN","XOBVRH",81,0)
6966
XECUTE "DO CALLBACK^"_IRTN_"(.XOBICBK)"
6967
"RTN","XOBVRH",82,0)
6968
IF $DATA(XOBICBK("STARTELEMENT")) SET XOBHDLR(TYPE,"CB","ELEST")="DO "_XOBICBK("STARTELEMENT")_"(.ELE,.ATR)"
6969
"RTN","XOBVRH",83,0)
6970
IF $DATA(XOBICBK("ENDELEMENT")) SET XOBHDLR(TYPE,"CB","ELEND")="DO "_XOBICBK("ENDELEMENT")_"(.ELE)"
6971
"RTN","XOBVRH",84,0)
6972
IF $DATA(XOBICBK("CHARACTERS")) SET XOBHDLR(TYPE,"CB","CHR")="DO "_XOBICBK("CHARACTERS")_"(.TXT)"
6973
"RTN","XOBVRH",85,0)
6974
SETQ ;
6975
"RTN","XOBVRH",86,0)
6976
QUIT
6977
"RTN","XOBVRH",87,0)
6978
;
6979
"RTN","XOBVRH",88,0)
6980
; -- get interface routine and test for existence
6981
"RTN","XOBVRH",89,0)
6982
IRTN(XOBTYPE0) ;
6983
"RTN","XOBVRH",90,0)
6984
NEW X,RTN
6985
"RTN","XOBVRH",91,0)
6986
SET RTN=""
6987
"RTN","XOBVRH",92,0)
6988
SET X=$PIECE(XOBTYPE0,"^",5)
6989
"RTN","XOBVRH",93,0)
6990
IF X]"" DO
6991
"RTN","XOBVRH",94,0)
6992
. XECUTE ^%ZOSF("TEST")
6993
"RTN","XOBVRH",95,0)
6994
. IF $TEST SET RTN=X
6995
"RTN","XOBVRH",96,0)
6996
QUIT RTN
6997
"RTN","XOBVRH",97,0)
6998
;
6999
"RTN","XOBVSKT")
7000
0^21^B19755798
7001
"RTN","XOBVSKT",1,0)
7002
XOBVSKT ;; mjk/alb MSC/JDA- VistaLink Socket Methods ;13APR2009
7003
"RTN","XOBVSKT",2,0)
7004
;;1.5;VistALink;**MSC**;Sep 09, 2005
7005
"RTN","XOBVSKT",3,0)
7006
;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
7007
"RTN","XOBVSKT",4,0)
7008
;
7009
"RTN","XOBVSKT",5,0)
7010
QUIT
7011
"RTN","XOBVSKT",6,0)
7012
;
7013
"RTN","XOBVSKT",7,0)
7014
; ------------------------------------------------------------------------------------
7015
"RTN","XOBVSKT",8,0)
7016
; Methods for Read fromto TCP/IP Socket
7017
"RTN","XOBVSKT",9,0)
7018
; ------------------------------------------------------------------------------------
7019
"RTN","XOBVSKT",10,0)
7020
READ(XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBSTOP,XOBDATA,XOBHDLR) ;
7021
"RTN","XOBVSKT",11,0)
7022
NEW X,EOT,OUT,STR,LINE,PIECES,DONE,TOFLAG,XOBCNT,XOBLEN,XOBBH,XOBEH,BS,ES,XOBOK,XOBX
7023
"RTN","XOBVSKT",12,0)
7024
;
7025
"RTN","XOBVSKT",13,0)
7026
SET STR="",EOT=$CHAR(4),DONE=0,LINE=0,XOBOK=1
7027
"RTN","XOBVSKT",14,0)
7028
;
7029
"RTN","XOBVSKT",15,0)
7030
; -- READ tcp stream to global buffer | main calling tag NXTCALL^XOBVLL
7031
"RTN","XOBVSKT",16,0)
7032
FOR READ XOBX#XOBREAD:XOBTO SET TOFLAG=$TEST DO:XOBFIRST CHK DO:'XOBSTOP!('DONE) QUIT:DONE
7033
"RTN","XOBVSKT",17,0)
7034
. ;
7035
"RTN","XOBVSKT",18,0)
7036
. ; -- if length of (new intake + current) is too large for buffer then store current
7037
"RTN","XOBVSKT",19,0)
7038
. IF $LENGTH(STR)+$LENGTH(XOBX)>400 DO ADD(STR) SET STR=""
7039
"RTN","XOBVSKT",20,0)
7040
. SET STR=STR_XOBX
7041
"RTN","XOBVSKT",21,0)
7042
. ;
7043
"RTN","XOBVSKT",22,0)
7044
. ; -- add node at each line-feed character
7045
"RTN","XOBVSKT",23,0)
7046
. ; COMMENTED OUT: Not needed anymore, and has side effect of stripping out line feeds in input
7047
"RTN","XOBVSKT",24,0)
7048
. ; array-type parameter values (in XML mode)
7049
"RTN","XOBVSKT",25,0)
7050
. ; FOR QUIT:STR'[$CHAR(10) DO ADD($PIECE(STR,$CHAR(10))) SET STR=$PIECE(STR,$CHAR(10),2,999)
7051
"RTN","XOBVSKT",26,0)
7052
. ;
7053
"RTN","XOBVSKT",27,0)
7054
. ; -- if end-of-text marker found then wrap up and quit
7055
"RTN","XOBVSKT",28,0)
7056
. IF STR[EOT SET STR=$PIECE(STR,EOT) DO ADD(STR) SET DONE=1 QUIT
7057
"RTN","XOBVSKT",29,0)
7058
. ;
7059
"RTN","XOBVSKT",30,0)
7060
. ; -- M XML parser cannot handle an element name split across nodes
7061
"RTN","XOBVSKT",31,0)
7062
. SET PIECES=$LENGTH(STR,">")
7063
"RTN","XOBVSKT",32,0)
7064
. IF PIECES>1 DO ADD($PIECE(STR,">",1,PIECES-1)_">") SET STR=$PIECE(STR,">",PIECES,999)
7065
"RTN","XOBVSKT",33,0)
7066
;
7067
"RTN","XOBVSKT",34,0)
7068
QUIT XOBOK
7069
"RTN","XOBVSKT",35,0)
7070
;
7071
"RTN","XOBVSKT",36,0)
7072
ADD(TXT) ; -- add new intake line
7073
"RTN","XOBVSKT",37,0)
7074
SET LINE=LINE+1
7075
"RTN","XOBVSKT",38,0)
7076
SET @XOBROOT@(LINE)=TXT
7077
"RTN","XOBVSKT",39,0)
7078
QUIT
7079
"RTN","XOBVSKT",40,0)
7080
;
7081
"RTN","XOBVSKT",41,0)
7082
CHK ; -- check if first read and change timeout and chars to read
7083
"RTN","XOBVSKT",42,0)
7084
SET XOBFIRST=0
7085
"RTN","XOBVSKT",43,0)
7086
;
7087
"RTN","XOBVSKT",44,0)
7088
; -- abort if time out occurred and nothing was read
7089
"RTN","XOBVSKT",45,0)
7090
IF 'TOFLAG,$GET(XOBX)="" SET XOBSTOP=1,DONE=1,XOBOK=0 QUIT
7091
"RTN","XOBVSKT",46,0)
7092
;
7093
"RTN","XOBVSKT",47,0)
7094
; -- intercept for transport sinks
7095
"RTN","XOBVSKT",48,0)
7096
IF $EXTRACT(XOBX)'="<" DO SINK
7097
"RTN","XOBVSKT",49,0)
7098
;
7099
"RTN","XOBVSKT",50,0)
7100
; -- set up for subsequent reads
7101
"RTN","XOBVSKT",51,0)
7102
SET XOBREAD=200,XOBTO=1
7103
"RTN","XOBVSKT",52,0)
7104
QUIT
7105
"RTN","XOBVSKT",53,0)
7106
;
7107
"RTN","XOBVSKT",54,0)
7108
; ------------------------------------------------------------------------------------
7109
"RTN","XOBVSKT",55,0)
7110
; Execute Proprietary Format Reader
7111
"RTN","XOBVSKT",56,0)
7112
; ------------------------------------------------------------------------------------
7113
"RTN","XOBVSKT",57,0)
7114
SINK ;
7115
"RTN","XOBVSKT",58,0)
7116
; -- get size of sink indicator >> then get sink indicator >> load req handler
7117
"RTN","XOBVSKT",59,0)
7118
SET XOBHDLR=$$MSGSINK^XOBVRH($$GETSTR(+$$GETSTR(2,.XOBX),.XOBX),.XOBHDLR)
7119
"RTN","XOBVSKT",60,0)
7120
;
7121
"RTN","XOBVSKT",61,0)
7122
; -- execute proprietary stream reader
7123
"RTN","XOBVSKT",62,0)
7124
IF $GET(XOBHDLR(XOBHDLR)) XECUTE $GET(XOBHDLR(XOBHDLR,"READER"))
7125
"RTN","XOBVSKT",63,0)
7126
;
7127
"RTN","XOBVSKT",64,0)
7128
SET DONE=1
7129
"RTN","XOBVSKT",65,0)
7130
QUIT
7131
"RTN","XOBVSKT",66,0)
7132
;
7133
"RTN","XOBVSKT",67,0)
7134
; -- get string of length LEN from stream buffer
7135
"RTN","XOBVSKT",68,0)
7136
GETSTR(LEN,XOBUF) ;
7137
"RTN","XOBVSKT",69,0)
7138
NEW X
7139
"RTN","XOBVSKT",70,0)
7140
FOR QUIT:($LENGTH(XOBUF)'<LEN) DO RMORE(LEN-$LENGTH(XOBUF),.XOBUF)
7141
"RTN","XOBVSKT",71,0)
7142
SET X=$EXTRACT(XOBUF,1,LEN)
7143
"RTN","XOBVSKT",72,0)
7144
SET XOBUF=$EXTRACT(XOBUF,LEN+1,999)
7145
"RTN","XOBVSKT",73,0)
7146
QUIT X
7147
"RTN","XOBVSKT",74,0)
7148
;
7149
"RTN","XOBVSKT",75,0)
7150
; -- read more from stream buffer but only needed amount
7151
"RTN","XOBVSKT",76,0)
7152
RMORE(LEN,XOBUF) ;
7153
"RTN","XOBVSKT",77,0)
7154
NEW X
7155
"RTN","XOBVSKT",78,0)
7156
READ X#LEN:1 SET XOBUF=XOBUF_X
7157
"RTN","XOBVSKT",79,0)
7158
QUIT
7159
"RTN","XOBVSKT",80,0)
7160
;
7161
"RTN","XOBVSKT",81,0)
7162
; ------------------------------------------------------------------------------------
7163
"RTN","XOBVSKT",82,0)
7164
; Methods for Openning and Closing Socket
7165
"RTN","XOBVSKT",83,0)
7166
; ------------------------------------------------------------------------------------
7167
"RTN","XOBVSKT",84,0)
7168
OPEN(XOBPARMS) ; -- Open tcp/ip socket
7169
"RTN","XOBVSKT",85,0)
7170
NEW I,POP
7171
"RTN","XOBVSKT",86,0)
7172
SET POP=1
7173
"RTN","XOBVSKT",87,0)
7174
;
7175
"RTN","XOBVSKT",88,0)
7176
; -- set up os var
7177
"RTN","XOBVSKT",89,0)
7178
DO OS
7179
"RTN","XOBVSKT",90,0)
7180
;
7181
"RTN","XOBVSKT",91,0)
7182
; -- preserve client io
7183
"RTN","XOBVSKT",92,0)
7184
DO SAVDEV^%ZISUTL("XOB CLIENT")
7185
"RTN","XOBVSKT",93,0)
7186
;
7187
"RTN","XOBVSKT",94,0)
7188
FOR I=1:1:XOBPARMS("RETRIES") DO CALL^%ZISTCP(XOBPARMS("ADDRESS"),XOBPARMS("PORT")) QUIT:'POP
7189
"RTN","XOBVSKT",95,0)
7190
; -- device open
7191
"RTN","XOBVSKT",96,0)
7192
IF 'POP USE IO QUIT 1
7193
"RTN","XOBVSKT",97,0)
7194
; -- device not open
7195
"RTN","XOBVSKT",98,0)
7196
QUIT 0
7197
"RTN","XOBVSKT",99,0)
7198
;
7199
"RTN","XOBVSKT",100,0)
7200
CLOSE(XOBPARMS) ; -- close tcp/ip socket
7201
"RTN","XOBVSKT",101,0)
7202
; -- tell server to Stop() connection if close message is needed to close
7203
"RTN","XOBVSKT",102,0)
7204
IF $GET(XOBPARMS("CLOSE MESSAGE"))]"" DO
7205
"RTN","XOBVSKT",103,0)
7206
. DO PRE
7207
"RTN","XOBVSKT",104,0)
7208
. DO WRITE($$XMLHDR^XOBVLIB()_XOBPARMS("CLOSE MESSAGE"))
7209
"RTN","XOBVSKT",105,0)
7210
. DO POST
7211
"RTN","XOBVSKT",106,0)
7212
;
7213
"RTN","XOBVSKT",107,0)
7214
DO FINAL
7215
"RTN","XOBVSKT",108,0)
7216
DO CLOSE^%ZISTCP
7217
"RTN","XOBVSKT",109,0)
7218
DO USE^%ZISUTL("XOB CLIENT")
7219
"RTN","XOBVSKT",110,0)
7220
DO RMDEV^%ZISUTL("XOB CLIENT")
7221
"RTN","XOBVSKT",111,0)
7222
QUIT
7223
"RTN","XOBVSKT",112,0)
7224
;
7225
"RTN","XOBVSKT",113,0)
7226
INIT ; -- set up variables needed in tcp/ip processing
7227
"RTN","XOBVSKT",114,0)
7228
KILL XOBNULL
7229
"RTN","XOBVSKT",115,0)
7230
;
7231
"RTN","XOBVSKT",116,0)
7232
; -- setup os var
7233
"RTN","XOBVSKT",117,0)
7234
DO OS
7235
"RTN","XOBVSKT",118,0)
7236
;
7237
"RTN","XOBVSKT",119,0)
7238
; -- set RPC Broker os variable (so $$BROKER^XWBLIB returns true)
7239
"RTN","XOBVSKT",120,0)
7240
SET XWBOS=XOBOS
7241
"RTN","XOBVSKT",121,0)
7242
;
7243
"RTN","XOBVSKT",122,0)
7244
; -- setup null device called "NULL"
7245
"RTN","XOBVSKT",123,0)
7246
SET %ZIS="0H",IOP="NULL" DO ^%ZIS
7247
"RTN","XOBVSKT",124,0)
7248
IF 'POP DO
7249
"RTN","XOBVSKT",125,0)
7250
. SET XOBNULL=IO
7251
"RTN","XOBVSKT",126,0)
7252
. DO SAVDEV^%ZISUTL("XOBNULL")
7253
"RTN","XOBVSKT",127,0)
7254
QUIT
7255
"RTN","XOBVSKT",128,0)
7256
;
7257
"RTN","XOBVSKT",129,0)
7258
OS ; -- os var
7259
"RTN","XOBVSKT",130,0)
7260
SET XOBOS=$SELECT(^%ZOSF("OS")["OpenM":"OpenM",^("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["MSM":"MSM",1:"")
7261
"RTN","XOBVSKT",131,0)
7262
QUIT
7263
"RTN","XOBVSKT",132,0)
7264
;
7265
"RTN","XOBVSKT",133,0)
7266
FINAL ; -- kill variables used in tcp/ip processing
7267
"RTN","XOBVSKT",134,0)
7268
;
7269
"RTN","XOBVSKT",135,0)
7270
; -- close null device
7271
"RTN","XOBVSKT",136,0)
7272
IF $DATA(XOBNULL) DO
7273
"RTN","XOBVSKT",137,0)
7274
. DO USE^%ZISUTL("XOBNULL")
7275
"RTN","XOBVSKT",138,0)
7276
. DO CLOSE^%ZISUTL("XOBNULL")
7277
"RTN","XOBVSKT",139,0)
7278
. KILL XOBNULL
7279
"RTN","XOBVSKT",140,0)
7280
;
7281
"RTN","XOBVSKT",141,0)
7282
KILL XOBOS,XWBOS
7283
"RTN","XOBVSKT",142,0)
7284
;
7285
"RTN","XOBVSKT",143,0)
7286
QUIT
7287
"RTN","XOBVSKT",144,0)
7288
;
7289
"RTN","XOBVSKT",145,0)
7290
; ------------------------------------------------------------------------------------
7291
"RTN","XOBVSKT",146,0)
7292
; Methods for Writing to TCP/IP Socket
7293
"RTN","XOBVSKT",147,0)
7294
; ------------------------------------------------------------------------------------
7295
"RTN","XOBVSKT",148,0)
7296
PRE ; -- prepare socket for writing
7297
"RTN","XOBVSKT",149,0)
7298
SET $X=0
7299
"RTN","XOBVSKT",150,0)
7300
QUIT
7301
"RTN","XOBVSKT",151,0)
7302
;
7303
"RTN","XOBVSKT",152,0)
7304
WRITE(STR) ; -- Write a data string to socket
7305
"RTN","XOBVSKT",153,0)
7306
IF XOBOS="MSM" WRITE STR QUIT
7307
"RTN","XOBVSKT",154,0)
7308
;
7309
"RTN","XOBVSKT",155,0)
7310
; -- handle a short string
7311
"RTN","XOBVSKT",156,0)
7312
IF $LENGTH(STR)<511 DO:($X+$LENGTH(STR))>511 FLUSH WRITE STR QUIT
7313
"RTN","XOBVSKT",157,0)
7314
;
7315
"RTN","XOBVSKT",158,0)
7316
; -- handle a long string
7317
"RTN","XOBVSKT",159,0)
7318
DO FLUSH
7319
"RTN","XOBVSKT",160,0)
7320
FOR QUIT:'$LENGTH(STR) WRITE $EXTRACT(STR,1,511) DO FLUSH SET STR=$EXTRACT(STR,512,99999)
7321
"RTN","XOBVSKT",161,0)
7322
;
7323
"RTN","XOBVSKT",162,0)
7324
QUIT
7325
"RTN","XOBVSKT",163,0)
7326
;
7327
"RTN","XOBVSKT",164,0)
7328
POST ; -- send eot and flush socket buffer
7329
"RTN","XOBVSKT",165,0)
7330
DO WRITE($CHAR(4))
7331
"RTN","XOBVSKT",166,0)
7332
DO FLUSH
7333
"RTN","XOBVSKT",167,0)
7334
QUIT
7335
"RTN","XOBVSKT",168,0)
7336
;
7337
"RTN","XOBVSKT",169,0)
7338
FLUSH ; flush buffer
7339
"RTN","XOBVSKT",170,0)
7340
IF XOBOS="OpenM" WRITE ! QUIT
7341
"RTN","XOBVSKT",171,0)
7342
IF XOBOS="DSM" WRITE:$X>0 ! QUIT
7343
"RTN","XOBVSKT",172,0)
7344
IF XOBOS="GTM" WRITE # QUIT
7345
"RTN","XOBVSKT",173,0)
7346
QUIT
7347
"RTN","XOBVSKT",174,0)
7348
;
7349
"RTN","XOBVTCPL")
7350
0^22^B13492271
7351
"RTN","XOBVTCPL",1,0)
7352
XOBVTCPL ;; mjk/alb MSC/JDA - VistALink TCP/IP Listener (Cache NT) ;18JUN2009
7353
"RTN","XOBVTCPL",2,0)
7354
;;1.5;VistALink;**MSC**;Sep 09, 2005
7355
"RTN","XOBVTCPL",3,0)
7356
;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
7357
"RTN","XOBVTCPL",4,0)
7358
;
7359
"RTN","XOBVTCPL",5,0)
7360
QUIT
7361
"RTN","XOBVTCPL",6,0)
7362
;
7363
"RTN","XOBVTCPL",7,0)
7364
; -- Important: Should always be JOBed using START^XOBVTCP
7365
"RTN","XOBVTCPL",8,0)
7366
LISTENER(XOBPORT,XOBCFG) ; -- Start Listener
7367
"RTN","XOBVTCPL",9,0)
7368
;
7369
"RTN","XOBVTCPL",10,0)
7370
N OS
7371
"RTN","XOBVTCPL",11,0)
7372
S OS=$$GETOS^XOBVTCP()
7373
"RTN","XOBVTCPL",12,0)
7374
; -- quit if not Cache for NT or GT.M
7375
"RTN","XOBVTCPL",13,0)
7376
IF (OS'="OpenM-NT")&(OS'["GT.M") QUIT
7377
"RTN","XOBVTCPL",14,0)
7378
;
7379
"RTN","XOBVTCPL",15,0)
7380
NEW $ETRAP,$ESTACK SET $ETRAP="D ^%ZTER HALT"
7381
"RTN","XOBVTCPL",16,0)
7382
;
7383
"RTN","XOBVTCPL",17,0)
7384
NEW X,POP,XOBDA,U,DTIME,DT,XOBIO
7385
"RTN","XOBVTCPL",18,0)
7386
SET U="^",DTIME=900,DT=$$DT^XLFDT()
7387
"RTN","XOBVTCPL",19,0)
7388
IF $GET(DUZ)="" NEW DUZ SET DUZ=.5,DUZ(0)="@"
7389
"RTN","XOBVTCPL",20,0)
7390
;
7391
"RTN","XOBVTCPL",21,0)
7392
; -- only start if not already started
7393
"RTN","XOBVTCPL",22,0)
7394
IF $$LOCK^XOBVTCP(XOBPORT) DO
7395
"RTN","XOBVTCPL",23,0)
7396
. IF $$OPEN(.XOBIO,XOBPORT,OS) DO
7397
"RTN","XOBVTCPL",24,0)
7398
. . ; -- listener started and now stopping
7399
"RTN","XOBVTCPL",25,0)
7400
. . SET IO=XOBIO
7401
"RTN","XOBVTCPL",26,0)
7402
. . DO CLOSE^%ZISTCP
7403
"RTN","XOBVTCPL",27,0)
7404
. . ; -- update status to 'stopped'
7405
"RTN","XOBVTCPL",28,0)
7406
. . DO UPDATE^XOBVTCP(XOBPORT,4,$GET(XOBCFG))
7407
"RTN","XOBVTCPL",29,0)
7408
. ELSE DO
7409
"RTN","XOBVTCPL",30,0)
7410
. . ; -- listener failed to start
7411
"RTN","XOBVTCPL",31,0)
7412
. . ; -- update status to 'failed'
7413
"RTN","XOBVTCPL",32,0)
7414
. . DO UPDATE^XOBVTCP(XOBPORT,5,$GET(XOBCFG))
7415
"RTN","XOBVTCPL",33,0)
7416
. ;
7417
"RTN","XOBVTCPL",34,0)
7418
. DO UNLOCK^XOBVTCP(XOBPORT)
7419
"RTN","XOBVTCPL",35,0)
7420
QUIT
7421
"RTN","XOBVTCPL",36,0)
7422
;
7423
"RTN","XOBVTCPL",37,0)
7424
; -- open/start listener port
7425
"RTN","XOBVTCPL",38,0)
7426
OPEN(XOBIO,XOBPORT,OS) ;
7427
"RTN","XOBVTCPL",39,0)
7428
Q $S(OS="OpenM-NT":$$OPENM(.XOBIO,XOBPORT),OS["GT.M":$$OPENGTM(.XOBIO,XOBPORT),1:0)
7429
"RTN","XOBVTCPL",40,0)
7430
;
7431
"RTN","XOBVTCPL",41,0)
7432
; -- open/start listener port on Cache
7433
"RTN","XOBVTCPL",42,0)
7434
OPENM(XOBIO,XOBPORT) ;
7435
"RTN","XOBVTCPL",43,0)
7436
NEW XOBBOX,%ZA
7437
"RTN","XOBVTCPL",44,0)
7438
SET XOBBOX=+$$GETBOX^XOBVTCP()
7439
"RTN","XOBVTCPL",45,0)
7440
SET XOBIO="|TCP|"_XOBPORT
7441
"RTN","XOBVTCPL",46,0)
7442
X "OPEN XOBIO:(:XOBPORT:""AT""):30"
7443
"RTN","XOBVTCPL",47,0)
7444
;
7445
"RTN","XOBVTCPL",48,0)
7446
; -- if listener port could not be openned then gracefully quit
7447
"RTN","XOBVTCPL",49,0)
7448
; (other namespace using port maybe?)
7449
"RTN","XOBVTCPL",50,0)
7450
IF '$TEST QUIT 0
7451
"RTN","XOBVTCPL",51,0)
7452
;
7453
"RTN","XOBVTCPL",52,0)
7454
; -- indicate listener is 'running'
7455
"RTN","XOBVTCPL",53,0)
7456
DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG))
7457
"RTN","XOBVTCPL",54,0)
7458
; -- read & spawn loop
7459
"RTN","XOBVTCPL",55,0)
7460
FOR DO QUIT:$$EXIT(XOBBOX,XOBPORT)
7461
"RTN","XOBVTCPL",56,0)
7462
. USE XOBIO
7463
"RTN","XOBVTCPL",57,0)
7464
. READ *X:60 IF '$TEST QUIT
7465
"RTN","XOBVTCPL",58,0)
7466
. X "JOB CHILD^XOBVTCPL:(:4:XOBIO:XOBIO):10" SET %ZA=$ZA
7467
"RTN","XOBVTCPL",59,0)
7468
. IF %ZA\8196#2=1 WRITE *-2 ;Job failed to clear bit
7469
"RTN","XOBVTCPL",60,0)
7470
QUIT 1
7471
"RTN","XOBVTCPL",61,0)
7472
;
7473
"RTN","XOBVTCPL",62,0)
7474
; -- open/start listener port on GT.M
7475
"RTN","XOBVTCPL",63,0)
7476
OPENGTM(XOBIO,XOBPORT) ;
7477
"RTN","XOBVTCPL",64,0)
7478
NEW XOBBOX
7479
"RTN","XOBVTCPL",65,0)
7480
SET XOBBOX=+$$GETBOX^XOBVTCP()
7481
"RTN","XOBVTCPL",66,0)
7482
SET XOBIO="|TCP|"_XOBPORT_"|"_$J
7483
"RTN","XOBVTCPL",67,0)
7484
OPEN XOBIO:(ZLISTEN=XOBPORT_":TCP":ATTACH="LISTENER"):5:"SOCKET"
7485
"RTN","XOBVTCPL",68,0)
7486
;
7487
"RTN","XOBVTCPL",69,0)
7488
; -- if listener port could not be openned then gracefully quit
7489
"RTN","XOBVTCPL",70,0)
7490
; (other namespace using port maybe?)
7491
"RTN","XOBVTCPL",71,0)
7492
IF '$TEST QUIT 0
7493
"RTN","XOBVTCPL",72,0)
7494
;
7495
"RTN","XOBVTCPL",73,0)
7496
; -- indicate listener is 'running'
7497
"RTN","XOBVTCPL",74,0)
7498
DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG))
7499
"RTN","XOBVTCPL",75,0)
7500
D LISTEN^ZISTCPS(XOBPORT,"CHILD^XOBVTCPL","EXIT^XOBVTCPL("_XOBBOX_","_XOBPORT_")")
7501
"RTN","XOBVTCPL",76,0)
7502
;
7503
"RTN","XOBVTCPL",77,0)
7504
CHILD ;Child process
7505
"RTN","XOBVTCPL",78,0)
7506
NEW XOBEC
7507
"RTN","XOBVTCPL",79,0)
7508
SET $ETRAP="D ^%ZTER L HALT"
7509
"RTN","XOBVTCPL",80,0)
7510
SET IO=$PRINCIPAL ;Reset IO to be $P
7511
"RTN","XOBVTCPL",81,0)
7512
IF $$GETOS^XOBVTCP()["OpenM" X "USE IO:(::""-M"")" ;Packet mode like DSM
7513
"RTN","XOBVTCPL",82,0)
7514
; -- do quit to save a stack level
7515
"RTN","XOBVTCPL",83,0)
7516
SET XOBEC=$$NEWOK()
7517
"RTN","XOBVTCPL",84,0)
7518
IF XOBEC DO LOGINERR(XOBEC,IO)
7519
"RTN","XOBVTCPL",85,0)
7520
IF 'XOBEC DO VAR,SPAWN^XOBVLL
7521
"RTN","XOBVTCPL",86,0)
7522
QUIT
7523
"RTN","XOBVTCPL",87,0)
7524
;
7525
"RTN","XOBVTCPL",88,0)
7526
VAR ;Setup IO variables
7527
"RTN","XOBVTCPL",89,0)
7528
SET IO(0)=IO,IO(1,IO)="",POP=0
7529
"RTN","XOBVTCPL",90,0)
7530
SET IOT="TCP",IOF="#",IOST="P-TCP",IOST(0)=0
7531
"RTN","XOBVTCPL",91,0)
7532
QUIT
7533
"RTN","XOBVTCPL",92,0)
7534
;
7535
"RTN","XOBVTCPL",93,0)
7536
NEWOK() ;Is it OK to start a new process
7537
"RTN","XOBVTCPL",94,0)
7538
NEW XQVOL,XUVOL,X,XOBCODE,Y
7539
"RTN","XOBVTCPL",95,0)
7540
SET U="^"
7541
"RTN","XOBVTCPL",96,0)
7542
DO GETENV^%ZOSV SET XQVOL=$PIECE(Y,U,2)
7543
"RTN","XOBVTCPL",97,0)
7544
SET X=$$FIND1^DIC(8989.304,",1,","BX",XQVOL,"","",""),XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
7545
"RTN","XOBVTCPL",98,0)
7546
SET XOBCODE=$$INHIBIT^XUSRB()
7547
"RTN","XOBVTCPL",99,0)
7548
IF XOBCODE=1 QUIT 181004
7549
"RTN","XOBVTCPL",100,0)
7550
IF XOBCODE=2 QUIT 181003
7551
"RTN","XOBVTCPL",101,0)
7552
QUIT 0
7553
"RTN","XOBVTCPL",102,0)
7554
;
7555
"RTN","XOBVTCPL",103,0)
7556
; -- process error
7557
"RTN","XOBVTCPL",104,0)
7558
LOGINERR(XOBEC,XOBPORT) ;
7559
"RTN","XOBVTCPL",105,0)
7560
DO ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT)
7561
"RTN","XOBVTCPL",106,0)
7562
;
7563
"RTN","XOBVTCPL",107,0)
7564
; -- give client time to process stream
7565
"RTN","XOBVTCPL",108,0)
7566
HANG 2
7567
"RTN","XOBVTCPL",109,0)
7568
QUIT
7569
"RTN","XOBVTCPL",110,0)
7570
;
7571
"RTN","XOBVTCPL",111,0)
7572
EXIT(XOBBOX,XOBPORT) ;
7573
"RTN","XOBVTCPL",112,0)
7574
; -- is status 'stopping'
7575
"RTN","XOBVTCPL",113,0)
7576
SET ZISQUIT=$PIECE($GET(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3
7577
"RTN","XOBVTCPL",114,0)
7578
Q ZISQUIT
7579
"RTN","XOBVTCPL",115,0)
7580
;
7581
"RTN","XOBVTCPL",116,0)
7582
GETLOGID(XOBBOX,XOBPORT) ;
7583
"RTN","XOBVTCPL",117,0)
7584
QUIT +$ORDER(^XOB(18.04,"C",XOBBOX,XOBPORT,""))
7585
"RTN","XOBVTCPL",118,0)
7586
;
7587
"RTN","XPDR")
7588
0^26^B52133395
7589
"RTN","XPDR",1,0)
7590
XPDR ;SFISC/RSD MSC/JDS - Routine File Edit ;24APR2009
7591
"RTN","XPDR",2,0)
7592
;;8.0;KERNEL;**1,2,44,MSC**;Jul 10, 1995
7593
"RTN","XPDR",3,0)
7594
Q
7595
"RTN","XPDR",4,0)
7596
UPDT ;update routine file
7597
"RTN","XPDR",5,0)
7598
N DIR,DIRUT,XPD,XPDI,XPDJ,XPDN,X,X1,Y,Y1,% W !
7599
"RTN","XPDR",6,0)
7600
W ! S DIR(0)="FO^1:9^K:X'?.1""-""1U.7UNP X",DIR("A")="Routine Namespace",DIR("?")="Enter 1 to 8 characters, preceed with ""-"" to exclude namespace"
7601
"RTN","XPDR",7,0)
7602
;XPDN(0=excluded names or 1=include names, namespace)=""
7603
"RTN","XPDR",8,0)
7604
F D ^DIR Q:$D(DIRUT) S X=$E(Y,$L(Y))="*",%=$E(Y)="-",XPDN('%,$E(Y,%+1,$L(Y)-X))=""
7605
"RTN","XPDR",9,0)
7606
Q:'$D(XPDN)!$D(DTOUT)!$D(DUOUT)
7607
"RTN","XPDR",10,0)
7608
W !!,"NAMESPACE INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------"
7609
"RTN","XPDR",11,0)
7610
S (X,Y)="",(X1,Y1)=1
7611
"RTN","XPDR",12,0)
7612
F D W !?11,X,?35,Y Q:'X1&'Y1
7613
"RTN","XPDR",13,0)
7614
.S:X1 X=$O(XPDN(1,X)),X1=X]"" S:Y1 Y=$O(XPDN(0,Y)),Y1=Y]""
7615
"RTN","XPDR",14,0)
7616
K DIR S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
7617
"RTN","XPDR",15,0)
7618
Q:'Y!$D(DIRUT) W !
7619
"RTN","XPDR",16,0)
7620
S DIR(0)="Y",DIR("A")="Want me to clean up the Routine File before updating",DIR("?")="YES means you want to go throught the Routine file and delete any routine name that no longer exists on the system."
7621
"RTN","XPDR",17,0)
7622
D ^DIR
7623
"RTN","XPDR",18,0)
7624
Q:$D(DIRUT) D WAIT^DICD,DELRTN:Y
7625
"RTN","XPDR",19,0)
7626
;loop thru include list XPDN(1,XPDI)
7627
"RTN","XPDR",20,0)
7628
N ISGTM S ISGTM=$G(^%ZOSF("OS"))["GT.M"
7629
"RTN","XPDR",21,0)
7630
S XPDI="" F S XPDI=$O(XPDN(1,XPDI)) Q:XPDI="" D
7631
"RTN","XPDR",22,0)
7632
.D:ISGTM SILENT^%RSEL("*") S XPDJ=XPDI D:$$ROUT(1,ISGTM,XPDJ) F S XPDJ=$$ROUT(0,ISGTM,XPDJ) Q:XPDJ=""!($P(XPDJ,XPDI)]"") D
7633
"RTN","XPDR",23,0)
7634
..;if name XPDJ is in the exclude list, XPDN(0,XPDJ) or in Routine file, quit
7635
"RTN","XPDR",24,0)
7636
..Q:$D(XPDN(0,XPDJ))!$O(^DIC(9.8,"B",XPDJ,0))
7637
"RTN","XPDR",25,0)
7638
..;check if XPDJ is refered in the namespace by checking the subscript
7639
"RTN","XPDR",26,0)
7640
..;before XPDJ, if sub exist and $P(XPDJ,sub)="" then it is part of the
7641
"RTN","XPDR",27,0)
7642
..;namespace, quit
7643
"RTN","XPDR",28,0)
7644
..S %=$O(XPDN(0,XPDJ),-1) I $L(%),$P(XPDJ,%)="" Q
7645
"RTN","XPDR",29,0)
7646
..N XPD S XPD(9.8,"+1,",.01)=XPDJ,XPD(9.8,"+1,",1)="R"
7647
"RTN","XPDR",30,0)
7648
..D ADD^DICA("","XPD")
7649
"RTN","XPDR",31,0)
7650
W " ...Done.",!
7651
"RTN","XPDR",32,0)
7652
Q
7653
"RTN","XPDR",33,0)
7654
ROUT(D,ISGTM,VALUE) ;
7655
"RTN","XPDR",34,0)
7656
I D,ISGTM Q $D(%ZR(VALUE))
7657
"RTN","XPDR",35,0)
7658
I ISGTM Q $O(%ZR(VALUE))
7659
"RTN","XPDR",36,0)
7660
N A I D X "S X=$D(^$R(VALUE))" Q A
7661
"RTN","XPDR",37,0)
7662
X "S A=$O(^$R(VALUE))" Q A
7663
"RTN","XPDR",38,0)
7664
VER ;verify Routine file
7665
"RTN","XPDR",39,0)
7666
N DIR,DIRUT,X,Y
7667
"RTN","XPDR",40,0)
7668
W !,"I will delete all entries in the Routine File in which",!,"the Routine no longer exist on this system!",!
7669
"RTN","XPDR",41,0)
7670
S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
7671
"RTN","XPDR",42,0)
7672
Q:'Y!$D(DIRUT) D DELRTN
7673
"RTN","XPDR",43,0)
7674
W " ...Done.",!
7675
"RTN","XPDR",44,0)
7676
Q
7677
"RTN","XPDR",45,0)
7678
DELRTN ;delete routine file entries
7679
"RTN","XPDR",46,0)
7680
N DA,DIK,Y
7681
"RTN","XPDR",47,0)
7682
S DIK="^DIC(9.8,",DA=0
7683
"RTN","XPDR",48,0)
7684
F S DA=$O(^DIC(9.8,DA)) Q:'DA S Y=$G(^(DA,0)) I $P(Y,U,2)="R",$T(^@$P(Y,U))="" D ^DIK
7685
"RTN","XPDR",49,0)
7686
Q
7687
"RTN","XPDR",50,0)
7688
PURGE ;purge file
7689
"RTN","XPDR",51,0)
7690
N DA,DIK,DIR,DIRUT,X,XPD,XPDF,XPDI,XPDJ,XPDL,XPDN,XPDPG,XPDS,XPDUL,Y,Z
7691
"RTN","XPDR",52,0)
7692
S DIR("?")="Enter the file you want to purge the data from.",DIR(0)="SM^B:Build;I:Install;ALL:Build & Install",DIR("A")="Purge from what file(s)"
7693
"RTN","XPDR",53,0)
7694
D ^DIR Q:$D(DIRUT)
7695
"RTN","XPDR",54,0)
7696
S XPDF=$S(Y="I":9.7,1:9.6) S:Y="ALL" XPDF(1)=9.7
7697
"RTN","XPDR",55,0)
7698
K DIR S DIR("?")="Enter the number of Versions to keep in the file, for each package",DIR(0)="N^0:100:0",DIR("A")="Versions to Retain",DIR("B")=1
7699
"RTN","XPDR",56,0)
7700
D ^DIR Q:$D(DIRUT) S XPDN=Y
7701
"RTN","XPDR",57,0)
7702
K DIR
7703
"RTN","XPDR",58,0)
7704
S DIR(0)="FO^3:30",DIR("?")="^D PURGEH^XPDR",DIR("A")="Package Name",DIR("B")="ALL"
7705
"RTN","XPDR",59,0)
7706
F D ^DIR Q:$D(DIRUT) S XPD(X)="" Q:X="ALL" K DIR("B") S DIR("A")="Another Package Name"
7707
"RTN","XPDR",60,0)
7708
Q:'$D(XPD)
7709
"RTN","XPDR",61,0)
7710
;if they want all, make sure all is the only one
7711
"RTN","XPDR",62,0)
7712
I $D(XPD("ALL")) K XPD S XPD("ALL")=""
7713
"RTN","XPDR",63,0)
7714
;XPDF(1) is defined if doing both files, do purge twice
7715
"RTN","XPDR",64,0)
7716
K ^TMP($J) D PURGE1(XPDF),PURGE1($G(XPDF(1))):$D(XPDF(1))
7717
"RTN","XPDR",65,0)
7718
I '$D(^TMP($J)) W !!,"No match found" Q
7719
"RTN","XPDR",66,0)
7720
K XPD,DIR
7721
"RTN","XPDR",67,0)
7722
S DIR(0)="E",$P(XPDUL,"-",IOM)=""
7723
"RTN","XPDR",68,0)
7724
;if ALL, reset XPDF to next file and Do, then reset back to 9.6
7725
"RTN","XPDR",69,0)
7726
D I $D(XPDF(1)) D ^DIR I Y S XPDF=XPDF(1) D S XPDF=9.6
7727
"RTN","XPDR",70,0)
7728
.S XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS),XPDPG=1,Y=1
7729
"RTN","XPDR",71,0)
7730
.W @IOF D HDR
7731
"RTN","XPDR",72,0)
7732
.;loop thru ^TMP($J,file,package) & show list, quit if user "^"
7733
"RTN","XPDR",73,0)
7734
.F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D Q:'Y
7735
"RTN","XPDR",74,0)
7736
..S Z=@XPD W $P(Z,"^"),$S($P(Z,"^",3):" (duplicates)",1:""),! Q:$Y<(IOSL-4)
7737
"RTN","XPDR",75,0)
7738
..D ^DIR Q:'Y
7739
"RTN","XPDR",76,0)
7740
..S XPDPG=XPDPG+1 W @IOF D HDR
7741
"RTN","XPDR",77,0)
7742
S DIR(0)="Y",DIR("A")="OK to DELETE these entries",DIR("B")="NO"
7743
"RTN","XPDR",78,0)
7744
W !! D ^DIR
7745
"RTN","XPDR",79,0)
7746
I $D(DIRUT)!'Y W !!,"Nothing Purged" Q
7747
"RTN","XPDR",80,0)
7748
;loop thru and delete
7749
"RTN","XPDR",81,0)
7750
D I $D(XPDF(1)) S XPDF=XPDF(1) D
7751
"RTN","XPDR",82,0)
7752
.S DIK="^XPD("_XPDF_",",XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS)
7753
"RTN","XPDR",83,0)
7754
.F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D
7755
"RTN","XPDR",84,0)
7756
..S XPDI=@XPD F XPDJ=2:1 S DA=$P(XPDI,"^",XPDJ) Q:'DA D ^DIK
7757
"RTN","XPDR",85,0)
7758
Q
7759
"RTN","XPDR",86,0)
7760
;
7761
"RTN","XPDR",87,0)
7762
PURGE1(XPDF) ;XPDF=file #
7763
"RTN","XPDR",88,0)
7764
N XPDFL,XPDI,XPDJ,XPDP,XPDV,Y,Z
7765
"RTN","XPDR",89,0)
7766
W "."
7767
"RTN","XPDR",90,0)
7768
;if All, loop thru B x-ref
7769
"RTN","XPDR",91,0)
7770
I $D(XPD("ALL")) D
7771
"RTN","XPDR",92,0)
7772
.S XPDI=""
7773
"RTN","XPDR",93,0)
7774
.F S XPDI=$O(^XPD(XPDF,"B",XPDI)) Q:XPDI="" D
7775
"RTN","XPDR",94,0)
7776
..S X=$$PKG^XPDUTL(XPDI) D PURGE2(X)
7777
"RTN","XPDR",95,0)
7778
..W "."
7779
"RTN","XPDR",96,0)
7780
E S XPDI="" F S XPDI=$O(XPD(XPDI)) Q:XPDI="" D
7781
"RTN","XPDR",97,0)
7782
.D PURGE2(XPDI)
7783
"RTN","XPDR",98,0)
7784
.W "."
7785
"RTN","XPDR",99,0)
7786
;loop thru each package, XPDP=package name
7787
"RTN","XPDR",100,0)
7788
S XPDP="" F S XPDP=$O(^TMP($J,XPDF,XPDP)) Q:XPDP="" D
7789
"RTN","XPDR",101,0)
7790
.S XPDV="",XPDL=XPDN
7791
"RTN","XPDR",102,0)
7792
.;the last is the most recent, XPDN = number to retain, XPDV=version
7793
"RTN","XPDR",103,0)
7794
.;XPDS=type (T/V/Z)
7795
"RTN","XPDR",104,0)
7796
.F S XPDV=$O(^TMP($J,XPDF,XPDP,XPDV),-1),XPDS="" Q:'XPDV!'XPDL F S XPDS=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS),-1) Q:XPDS=""!'XPDL D
7797
"RTN","XPDR",105,0)
7798
..S Y="" F S Y=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y),-1) Q:Y=""!'XPDL D
7799
"RTN","XPDR",106,0)
7800
...I $D(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y))#2 K ^(Y) S XPDL=XPDL-1 Q
7801
"RTN","XPDR",107,0)
7802
...S Z="" F S Z=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y,Z),-1) Q:Z=""!'XPDL K ^(Z) S XPDL=XPDL-1
7803
"RTN","XPDR",108,0)
7804
Q
7805
"RTN","XPDR",109,0)
7806
;
7807
"RTN","XPDR",110,0)
7808
PURGE2(XPDX) ;XPDX=package name
7809
"RTN","XPDR",111,0)
7810
;XPDFL=1 this is not a patch, quit when we find a patch during loop
7811
"RTN","XPDR",112,0)
7812
S XPDS=XPDX,XPDL=$L(XPDX),XPDFL=XPDX'["*"
7813
"RTN","XPDR",113,0)
7814
;loop and find matches
7815
"RTN","XPDR",114,0)
7816
D F S XPDS=$O(^XPD(XPDF,"B",XPDS)) Q:XPDS=""!($E(XPDS,1,XPDL)'=XPDX)!($S(XPDFL:XPDS["*",1:0)) D
7817
"RTN","XPDR",115,0)
7818
.S Y=$O(^XPD(XPDF,"B",XPDS,0)) Q:'Y
7819
"RTN","XPDR",116,0)
7820
.Q:'$D(^XPD(XPDF,Y,0)) S Z=^(0),Y=XPDS_"^"_Y
7821
"RTN","XPDR",117,0)
7822
.;can't delete Installs that status isn't 'Install Completed'
7823
"RTN","XPDR",118,0)
7824
.I XPDF=9.7 Q:$P(Z,U,9)<3
7825
"RTN","XPDR",119,0)
7826
.S XPDV=$$VER^XPDUTL(XPDS)
7827
"RTN","XPDR",120,0)
7828
.;TMP($J,file,package name,version,"*","T/V/Z",num,patch)=NAME^DA^duplicat DAs
7829
"RTN","XPDR",121,0)
7830
.I XPDS["*" D Q
7831
"RTN","XPDR",122,0)
7832
..I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*Z",0,+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7833
"RTN","XPDR",123,0)
7834
..I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*T",+$P(XPDV,"T",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7835
"RTN","XPDR",124,0)
7836
..I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*V",+$P(XPDV,"V",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7837
"RTN","XPDR",125,0)
7838
..S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*",+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2))
7839
"RTN","XPDR",126,0)
7840
.;TMP($J,file,package name,version,"Z",0)=NAME^DA^duplicate DAs
7841
"RTN","XPDR",127,0)
7842
.I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"Z",0)=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7843
"RTN","XPDR",128,0)
7844
.;TMP($J,file,package name,version,"T/V",num)=NAME^DA^dup DAs
7845
"RTN","XPDR",129,0)
7846
.I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"T",+$P(XPDV,"T",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7847
"RTN","XPDR",130,0)
7848
.I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"V",+$P(XPDV,"V",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7849
"RTN","XPDR",131,0)
7850
Q
7851
"RTN","XPDR",132,0)
7852
PURGEH ;executable help from DIR call at PURGE+8
7853
"RTN","XPDR",133,0)
7854
W:$E(DIR("A"),1)="P" !,"Enter 'ALL' to purge all packages, or"
7855
"RTN","XPDR",134,0)
7856
W !,"Enter the name of the Package you want to Purge.",!," i.e. KERNEL 8.0 will purge version 8.0Tx and 8.0Vx",!," XU*8.0 will purge all patches for 8.0",!
7857
"RTN","XPDR",135,0)
7858
N DIR,X,Y
7859
"RTN","XPDR",136,0)
7860
S DIR(0)="Y",DIR("A")="Want to see the "_$S(XPDF=9.7:"Install File",$D(XPDF(1)):"Build & Install Files",1:"Build File")_" List",DIR("B")="Y"
7861
"RTN","XPDR",137,0)
7862
D ^DIR Q:'Y!$D(DIRUT)
7863
"RTN","XPDR",138,0)
7864
D PURGEH1("^XPD(9.6,"):XPDF=9.6,PURGEH1("^XPD(9.7,"):XPDF=9.7!$D(XPDF(1))
7865
"RTN","XPDR",139,0)
7866
Q
7867
"RTN","XPDR",140,0)
7868
;
7869
"RTN","XPDR",141,0)
7870
DUP(Z,Z1) ;find duplicate, Z=NAME, Z1=last ien
7871
"RTN","XPDR",142,0)
7872
;returns Y=DA^dup DA^dup DA...
7873
"RTN","XPDR",143,0)
7874
N Y S Y=""
7875
"RTN","XPDR",144,0)
7876
F S Z1=$O(^XPD(XPDF,"B",Z,Z1)) Q:'Z1 S Y=Y_"^"_Z1
7877
"RTN","XPDR",145,0)
7878
Q Y
7879
"RTN","XPDR",146,0)
7880
;
7881
"RTN","XPDR",147,0)
7882
PURGEH1(DIC) ;
7883
"RTN","XPDR",148,0)
7884
W !!,$S(DIC[9.6:"BUILD ",1:"INSTALL ")_"File"
7885
"RTN","XPDR",149,0)
7886
S DIC(0)="QE",X="??" D ^DIC
7887
"RTN","XPDR",150,0)
7888
Q
7889
"RTN","XPDR",151,0)
7890
;
7891
"RTN","XPDR",152,0)
7892
HDR W !,"Package(s) in ",$S(XPDF=9.7:"INSTALL",1:"BUILD")," File, "
7893
"RTN","XPDR",153,0)
7894
I XPDN W "Retain last ",$S(XPDN=1:"version",1:XPDN_" versions")
7895
"RTN","XPDR",154,0)
7896
E W "Don't retain any versions"
7897
"RTN","XPDR",155,0)
7898
W ?70,"PAGE ",XPDPG,!,XPDUL,!
7899
"RTN","XPDR",156,0)
7900
Q
7901
"RTN","XQALSUR1")
7902
0^42^B29675685
7903
"RTN","XQALSUR1",1,0)
7904
XQALSUR1 ;ISC-SF.SEA/JLI,MSC/JDA - SURROGATES FOR ALERTS ;27APR2009
7905
"RTN","XQALSUR1",2,0)
7906
;;8.0;KERNEL;**366,MSC**;Jul 10, 1995
7907
"RTN","XQALSUR1",3,0)
7908
Q
7909
"RTN","XQALSUR1",4,0)
7910
;
7911
"RTN","XQALSUR1",5,0)
7912
RETURN(XQAUSER) ; P366 - return alerts to the user
7913
"RTN","XQALSUR1",6,0)
7914
N XQAI,X0,XQASTRT,XQASURO,XQAEND
7915
"RTN","XQALSUR1",7,0)
7916
; identify periods in the surrogate multiple that haven't been returned
7917
"RTN","XQALSUR1",8,0)
7918
F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D
7919
"RTN","XQALSUR1",9,0)
7920
. S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3)
7921
"RTN","XQALSUR1",10,0)
7922
. ; and clear the flag indicating we need to restore these alerts
7923
"RTN","XQALSUR1",11,0)
7924
. N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA")
7925
"RTN","XQALSUR1",12,0)
7926
. ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient)
7927
"RTN","XQALSUR1",13,0)
7928
. D PUSHBACK(XQAUSER,XQASTRT,XQAEND)
7929
"RTN","XQALSUR1",14,0)
7930
. Q
7931
"RTN","XQALSUR1",15,0)
7932
Q
7933
"RTN","XQALSUR1",16,0)
7934
;
7935
"RTN","XQALSUR1",17,0)
7936
PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them
7937
"RTN","XQALSUR1",18,0)
7938
N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP
7939
"RTN","XQALSUR1",19,0)
7940
S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT")
7941
"RTN","XQALSUR1",20,0)
7942
F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0 Q:XQADT>XQAEND F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0 D
7943
"RTN","XQALSUR1",21,0)
7944
. S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0
7945
"RTN","XQALSUR1",22,0)
7946
. N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U)
7947
"RTN","XQALSUR1",23,0)
7948
. F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 D
7949
"RTN","XQALSUR1",24,0)
7950
. . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate
7951
"RTN","XQALSUR1",25,0)
7952
. . Q
7953
"RTN","XQALSUR1",26,0)
7954
. I 'XNOSURO D
7955
"RTN","XQALSUR1",27,0)
7956
. . N XQA,XQACMNT,XQALTYPE
7957
"RTN","XQALSUR1",28,0)
7958
. . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE"
7959
"RTN","XQALSUR1",29,0)
7960
. . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT)
7961
"RTN","XQALSUR1",30,0)
7962
. . Q
7963
"RTN","XQALSUR1",31,0)
7964
. ; walk through each of those it was sent to as a surrogate for XQAUSER
7965
"RTN","XQALSUR1",32,0)
7966
. F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D
7967
"RTN","XQALSUR1",33,0)
7968
. . ; and identify each time they were considered a recipient of the alert
7969
"RTN","XQALSUR1",34,0)
7970
. . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D Q:XNOSURO
7971
"RTN","XQALSUR1",35,0)
7972
. . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well
7973
"RTN","XQALSUR1",36,0)
7974
. . . ; walk through the SURROGATE FOR entries for this user
7975
"RTN","XQALSUR1",37,0)
7976
. . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0 S X30=^(XQAOTH,0) D Q:XNOSURO
7977
"RTN","XQALSUR1",38,0)
7978
. . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned
7979
"RTN","XQALSUR1",39,0)
7980
. . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert
7981
"RTN","XQALSUR1",40,0)
7982
. . . . Q
7983
"RTN","XQALSUR1",41,0)
7984
. . . Q
7985
"RTN","XQALSUR1",42,0)
7986
. . I 'XNOSURO D
7987
"RTN","XQALSUR1",43,0)
7988
. . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL
7989
"RTN","XQALSUR1",44,0)
7990
. . . Q
7991
"RTN","XQALSUR1",45,0)
7992
. . Q
7993
"RTN","XQALSUR1",46,0)
7994
. Q
7995
"RTN","XQALSUR1",47,0)
7996
Q
7997
"RTN","XQALSUR1",48,0)
7998
;
7999
"RTN","XQALSUR1",49,0)
8000
SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST
8001
"RTN","XQALSUR1",50,0)
8002
; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST)
8003
"RTN","XQALSUR1",51,0)
8004
;
8005
"RTN","XQALSUR1",52,0)
8006
; returns XQALIST=count
8007
"RTN","XQALSUR1",53,0)
8008
; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME
8009
"RTN","XQALSUR1",54,0)
8010
; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406
8011
"RTN","XQALSUR1",55,0)
8012
;
8013
"RTN","XQALSUR1",56,0)
8014
N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU
8015
"RTN","XQALSUR1",57,0)
8016
D CHEKSUBS^XQALSUR2(XQAUSER)
8017
"RTN","XQALSUR1",58,0)
8018
S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER)
8019
"RTN","XQALSUR1",59,0)
8020
S XQANOW=$$NOW^XLFDT(),XQALCNT=0
8021
"RTN","XQALSUR1",60,0)
8022
S XQADATE="" F S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0 S XQAIEN="" F S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0 D
8023
"RTN","XQALSUR1",61,0)
8024
. S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q
8025
"RTN","XQALSUR1",62,0)
8026
. S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND
8027
"RTN","XQALSUR1",63,0)
8028
. Q
8029
"RTN","XQALSUR1",64,0)
8030
; now rearrange by earliest to last
8031
"RTN","XQALSUR1",65,0)
8032
K XQALIST S XQALIST=0
8033
"RTN","XQALSUR1",66,0)
8034
S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D
8035
"RTN","XQALSUR1",67,0)
8036
. ; if end date not specified, and start date follows, set end date to next start date
8037
"RTN","XQALSUR1",68,0)
8038
. I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3)
8039
"RTN","XQALSUR1",69,0)
8040
. S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT)
8041
"RTN","XQALSUR1",70,0)
8042
. Q
8043
"RTN","XQALSUR1",71,0)
8044
Q
8045
"RTN","XQALSUR1",72,0)
8046
;
8047
"RTN","XQALSUR1",73,0)
8048
DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy
8049
"RTN","XQALSUR1",74,0)
8050
N XQALNEXT,XQALIST,I,XQALAST
8051
"RTN","XQALSUR1",75,0)
8052
I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!"
8053
"RTN","XQALSUR1",76,0)
8054
S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D
8055
"RTN","XQALSUR1",77,0)
8056
. F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q
8057
"RTN","XQALSUR1",78,0)
8058
. Q
8059
"RTN","XQALSUR1",79,0)
8060
Q XQALSURO
8061
"RTN","XQALSUR1",80,0)
8062
;
8063
"RTN","XQALSUR1",81,0)
8064
DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated
8065
"RTN","XQALSUR1",82,0)
8066
N XQALY,XQA0,XQALIEN,XQALS
8067
"RTN","XQALSUR1",83,0)
8068
S XQALY="" I XQALEND'>0 S XQALEND=4000101
8069
"RTN","XQALSUR1",84,0)
8070
F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'<XQALEND D
8071
"RTN","XQALSUR1",85,0)
8072
. F XQALIEN=0:0 S XQALIEN=$O(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN)) Q:XQALIEN'>0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2)
8073
"RTN","XQALSUR1",86,0)
8074
. Q
8075
"RTN","XQALSUR1",87,0)
8076
Q XQALY
8077
"RTN","XQALSUR1",88,0)
8078
;
8079
"RTN","XQALSUR1",89,0)
8080
SURRO1(XQAUSER) ;
8081
"RTN","XQALSUR1",90,0)
8082
SURRO1G
8083
"RTN","XQALSUR1",91,0)
8084
N XQALSURO,XQALSTRT,XQALEND
8085
"RTN","XQALSUR1",92,0)
8086
D CHKREMV^XQALSURO
8087
"RTN","XQALSUR1",93,0)
8088
SURRO11 ;
8089
"RTN","XQALSUR1",94,0)
8090
S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q
8091
"RTN","XQALSUR1",95,0)
8092
I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO1G
8093
"RTN","XQALSUR1",96,0)
8094
S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q
8095
"RTN","XQALSUR1",97,0)
8096
S XQALEND=+$$ENDDLG() I XQALEND<0 Q
8097
"RTN","XQALSUR1",98,0)
8098
D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND)
8099
"RTN","XQALSUR1",99,0)
8100
G SURRO11 ;
8101
"RTN","XQALSUR1",100,0)
8102
Q
8103
"RTN","XQALSUR1",101,0)
8104
;
8105
"RTN","XQALSUR1",102,0)
8106
; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
8107
"RTN","XQALSUR1",103,0)
8108
REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship
8109
"RTN","XQALSUR1",104,0)
8110
I $G(XQAUSER)'>0 Q
8111
"RTN","XQALSUR1",105,0)
8112
S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT)
8113
"RTN","XQALSUR1",106,0)
8114
N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0
8115
"RTN","XQALSUR1",107,0)
8116
; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN)
8117
"RTN","XQALSUR1",108,0)
8118
D CHEKSUBS^XQALSUR2(XQAUSER)
8119
"RTN","XQALSUR1",109,0)
8120
S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1
8121
"RTN","XQALSUR1",110,0)
8122
S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1
8123
"RTN","XQALSUR1",111,0)
8124
S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4)
8125
"RTN","XQALSUR1",112,0)
8126
S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D
8127
"RTN","XQALSUR1",113,0)
8128
. S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND)
8129
"RTN","XQALSUR1",114,0)
8130
. Q
8131
"RTN","XQALSUR1",115,0)
8132
S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary.
8133
"RTN","XQALSUR1",116,0)
8134
Q
8135
"RTN","XQALSUR1",117,0)
8136
;
8137
"RTN","XQALSUR1",118,0)
8138
DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ;
8139
"RTN","XQALSUR1",119,0)
8140
N XQALNOW,XQALFM
8141
"RTN","XQALSUR1",120,0)
8142
; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN)
8143
"RTN","XQALSUR1",121,0)
8144
S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER
8145
"RTN","XQALSUR1",122,0)
8146
I XQALXREF>0 D
8147
"RTN","XQALSUR1",123,0)
8148
. S XQALNOW=$$NOW^XLFDT()
8149
"RTN","XQALSUR1",124,0)
8150
. I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now
8151
"RTN","XQALSUR1",125,0)
8152
. I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now
8153
"RTN","XQALSUR1",126,0)
8154
. I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1
8155
"RTN","XQALSUR1",127,0)
8156
. Q
8157
"RTN","XQALSUR1",128,0)
8158
I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D
8159
"RTN","XQALSUR1",129,0)
8160
. S XQALFM(8992,XQAUSER,.02)="@"
8161
"RTN","XQALSUR1",130,0)
8162
. S XQALFM(8992,XQAUSER,.03)="@"
8163
"RTN","XQALSUR1",131,0)
8164
. S XQALFM(8992,XQAUSER,.04)="@"
8165
"RTN","XQALSUR1",132,0)
8166
. Q
8167
"RTN","XQALSUR1",133,0)
8168
I $D(XQALFM) D FILE^DIE("","XQALFM")
8169
"RTN","XQALSUR1",134,0)
8170
I XQALSURO>0,'$D(XQATEST) D
8171
"RTN","XQALSUR1",135,0)
8172
. N XQAMESG,XMSUB,XMTEXT
8173
"RTN","XQALSUR1",136,0)
8174
. S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for"
8175
"RTN","XQALSUR1",137,0)
8176
. S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")."
8177
"RTN","XQALSUR1",138,0)
8178
. S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient"
8179
"RTN","XQALSUR1",139,0)
8180
. D SENDMESG^XQALSURO
8181
"RTN","XQALSUR1",140,0)
8182
. Q
8183
"RTN","XQALSUR1",141,0)
8184
Q
8185
"RTN","XQALSUR1",142,0)
8186
;
8187
"RTN","XQALSUR1",143,0)
8188
NEWDLG() ; new surrogate dialog
8189
"RTN","XQALSUR1",144,0)
8190
N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO"
8191
"RTN","XQALSUR1",145,0)
8192
S Y=$$ASKDIR(.DIR) I 'Y Q 0
8193
"RTN","XQALSUR1",146,0)
8194
;
8195
"RTN","XQALSUR1",147,0)
8196
S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366
8197
"RTN","XQALSUR1",148,0)
8198
I Y>0 W " ",$P(Y,U,2)
8199
"RTN","XQALSUR1",149,0)
8200
Q +Y
8201
"RTN","XQALSUR1",150,0)
8202
;
8203
"RTN","XQALSUR1",151,0)
8204
STRTDLG() ; new surrogate start date/time dialog
8205
"RTN","XQALSUR1",152,0)
8206
N DIR
8207
"RTN","XQALSUR1",153,0)
8208
S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427
8209
"RTN","XQALSUR1",154,0)
8210
S DIR("A",1)="",DIR("A",2)=""
8211
"RTN","XQALSUR1",155,0)
8212
S DIR("A",3)="if no date/time is entered, alerts will start going to"
8213
"RTN","XQALSUR1",156,0)
8214
S DIR("A",4)="the SURROGATE immediately."
8215
"RTN","XQALSUR1",157,0)
8216
Q +$$ASKDIR(.DIR)
8217
"RTN","XQALSUR1",158,0)
8218
;
8219
"RTN","XQALSUR1",159,0)
8220
ENDDLG() ; new surrogate end date/time dialog
8221
"RTN","XQALSUR1",160,0)
8222
N DIR
8223
"RTN","XQALSUR1",161,0)
8224
S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427
8225
"RTN","XQALSUR1",162,0)
8226
S DIR("A",1)="",DIR("A",2)=""
8227
"RTN","XQALSUR1",163,0)
8228
S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE"
8229
"RTN","XQALSUR1",164,0)
8230
S DIR("A",4)="to terminate alerts going to the SURROGATE"
8231
"RTN","XQALSUR1",165,0)
8232
Q +$$ASKDIR(.DIR)
8233
"RTN","XQALSUR1",166,0)
8234
;
8235
"RTN","XQALSUR1",167,0)
8236
ASKDIR(DIR) ;
8237
"RTN","XQALSUR1",168,0)
8238
N Y,DTOUT,DUOUT
8239
"RTN","XQALSUR1",169,0)
8240
D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1
8241
"RTN","XQALSUR1",170,0)
8242
Q Y
8243
"RTN","XTER1A")
8244
0^7^B29100251
8245
"RTN","XTER1A",1,0)
8246
XTER1A ;ISC-SF.SEA/JLI MSC/JDS- VA error reporting ;24APR2009
8247
"RTN","XTER1A",2,0)
8248
;;8.0;KERNEL;**63,112,120,MSC,IHS**;Jul 10, 1995
8249
"RTN","XTER1A",3,0)
8250
;
8251
"RTN","XTER1A",4,0)
8252
TWO ;
8253
"RTN","XTER1A",5,0)
8254
S XTNUM=2
8255
"RTN","XTER1A",6,0)
8256
ONE ;
8257
"RTN","XTER1A",7,0)
8258
S:'$D(XTNUM) XTNUM=1
8259
"RTN","XTER1A",8,0)
8260
S:'$D(XTNDATE) XTNDATE=$H-1 I '$D(ZTQUEUED) S XTNDAT1=$$HTFM^XLFDT(XTNDATE),XTNDAT2=XTNDAT1 G INT^XTER1A1
8261
"RTN","XTER1A",9,0)
8262
K ^TMP($J,"XTER1A") D LISTN,LIST
8263
"RTN","XTER1A",10,0)
8264
EXIT K XTNUM,XTNDATE,XTERN,XTERX,X,N,N1,Y,C,XTOUT,Z,I,XTER1AX,XTER1AN,XTER1AN1,%XTZDAT,%XTZNUM,XTMES,XTDV1,XTMES,XTPRNT
8265
"RTN","XTER1A",11,0)
8266
Q
8267
"RTN","XTER1A",12,0)
8268
LISTN ;
8269
"RTN","XTER1A",13,0)
8270
F XTERN=0:0 S XTERN=$O(^%ZTER(1,XTNDATE,1,XTERN)) Q:XTERN'>0 I $D(^(XTERN,"ZE")) S XTERX=$E(^("ZE"),1,30),X=^("ZE") D
8271
"RTN","XTER1A",14,0)
8272
.S N1=0 F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N="" S N1=N I ^(N)=X Q
8273
"RTN","XTER1A",15,0)
8274
.I N="" S ^TMP($J,"XTER1A",XTERX,N1+1)=X,^(N1+1,"CNT")=1,^(1)=XTNDATE_U_XTERN
8275
"RTN","XTER1A",16,0)
8276
.E S ^("CNT")=^TMP($J,"XTER1A",XTERX,N,"CNT")+1 I ^("CNT")'>XTNUM S Y=^("CNT"),^(Y)=XTNDATE_U_XTERN
8277
"RTN","XTER1A",17,0)
8278
.Q
8279
"RTN","XTER1A",18,0)
8280
Q
8281
"RTN","XTER1A",19,0)
8282
LIST ;
8283
"RTN","XTER1A",20,0)
8284
S XTERX="",C=0,XTOUT=0 K ^TMP($J,"XTER")
8285
"RTN","XTER1A",21,0)
8286
F S XTERX=$O(^TMP($J,"XTER1A",XTERX)) Q:XTERX="" F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N'>0 D
8287
"RTN","XTER1A",22,0)
8288
.S X=^TMP($J,"XTER1A",XTERX,N) S C=C+1,^TMP($J,"XTER",C)="",C=C+1,^(C)="",Z=$J(^TMP($J,"XTER1A",XTERX,N,"CNT"),8)_" "
8289
"RTN","XTER1A",23,0)
8290
.F I=1:60 S Y=$E(X,I,I+59) Q:Y="" S C=C+1,^TMP($J,"XTER",C)=Z_Y,Z=" "
8291
"RTN","XTER1A",24,0)
8292
S XTER1AX="" F S XTER1AX=$O(^TMP($J,"XTER1A",XTER1AX)) Q:XTER1AX="" F XTER1AN=0:0 S XTER1AN=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN)) Q:XTER1AN'>0 D
8293
"RTN","XTER1A",25,0)
8294
.F XTER1AN1=0:0 S XTER1AN1=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN,XTER1AN1)) Q:XTER1AN1'>0 S X=^(XTER1AN1) D
8295
"RTN","XTER1A",26,0)
8296
..S C=C+1,^TMP($J,"XTER",C)="|PAGE|" S %XTZDAT=+X,%XTZNUM=$P(X,U,2),XTDV1=0 S XTMES=1 D WRT^XTER1
8297
"RTN","XTER1A",27,0)
8298
D:IO=""&$D(^TMP($J,"XTER")) MESSG D:IO'="" WRITER
8299
"RTN","XTER1A",28,0)
8300
K ^TMP($J,"XTER") S C=0 I IO'="" U IO D ^%ZISC
8301
"RTN","XTER1A",29,0)
8302
Q
8303
"RTN","XTER1A",30,0)
8304
;
8305
"RTN","XTER1A",31,0)
8306
MESG N DWPK,DWLW,DIC K ^TMP($J,"XTER"),^TMP($J,"XTER1")
8307
"RTN","XTER1A",32,0)
8308
W @IOF,!!,"Enter any comments to precede the error listing:"
8309
"RTN","XTER1A",33,0)
8310
S DWPK=1,DWLW=75,DIC="^TMP($J,""XTER1""," D EN^DIWE
8311
"RTN","XTER1A",34,0)
8312
S C=0 W ! F I=0:0 S I=$O(^TMP($J,"XTER1",I)) Q:I'>0 S C=I,^TMP($J,"XTER",I)=^TMP($J,"XTER1",I,0)
8313
"RTN","XTER1A",35,0)
8314
S XTMES=1,XTDV1=0 D WRT^XTER1 D:C>0 MESSG
8315
"RTN","XTER1A",36,0)
8316
S C=0 K XTMES,^TMP($J,"XTER"),^TMP($J,"XTER1")
8317
"RTN","XTER1A",37,0)
8318
G XTERR^XTER
8319
"RTN","XTER1A",38,0)
8320
;
8321
"RTN","XTER1A",39,0)
8322
PRNT K ^TMP($J,"XTER"),ZTIO
8323
"RTN","XTER1A",40,0)
8324
S C=0,%ZIS="MQ" D ^%ZIS I POP D HOME^%ZIS G WRT^XTER1
8325
"RTN","XTER1A",41,0)
8326
I $D(IO("Q")) D S XTX="" G XTERR^XTER
8327
"RTN","XTER1A",42,0)
8328
. K IO("Q") S ZTRTN="DQPRNT^XTER1A",ZTSAVE("%XTZDAT")="",ZTSAVE("%XTZNUM")="",ZTDESC="XTER1A-PRINT OF ERROR" D ^%ZTLOAD K ZTSK D HOME^%ZIS
8329
"RTN","XTER1A",43,0)
8330
;
8331
"RTN","XTER1A",44,0)
8332
DQPRNT S XTPRNT=1,XTOUT=0 D WRT^XTER1 U IO D:C>0 WRITER
8333
"RTN","XTER1A",45,0)
8334
K ^TMP($J,"XTER"),XTX,XTPRNT S C=0 D ^%ZISC I $D(ZTQUEUED) Q
8335
"RTN","XTER1A",46,0)
8336
G XTERR^XTER
8337
"RTN","XTER1A",47,0)
8338
;
8339
"RTN","XTER1A",48,0)
8340
WRITER F %=0:0 S %=$O(^TMP($J,"XTER",%)) Q:%'>0 W:((IOSL-$Y)'>4&$G(XTPRNT)) @IOF S %1=$S($D(^(%))=1:^(%),1:^(%,0)) D
8341
"RTN","XTER1A",49,0)
8342
.I $E(%1,1,6)="|PAGE|" W @IOF S %1=$E(%1,7,$L(%1)) Q:%1=""
8343
"RTN","XTER1A",50,0)
8344
.I $E(%1,1,4)="@IOF" W @IOF S %1=$E(%1,5,$L(%1)) Q:%1=""
8345
"RTN","XTER1A",51,0)
8346
.W !,%1
8347
"RTN","XTER1A",52,0)
8348
K %,%1
8349
"RTN","XTER1A",53,0)
8350
Q
8351
"RTN","XTER1A",54,0)
8352
MESSG S XMY(DUZ)="",XMDUZ=.5 I '$D(ZTQUEUED) K XMY,XMDUZ
8353
"RTN","XTER1A",55,0)
8354
S XMTEXT="^TMP($J,""XTER"",",XMSUB="ERROR - "_$E(%XTZE,1,40) F Q:XMSUB'[U S XMSUB=$P(XMSUB,U)_"~U~"_$P(XMSUB,U,2,99)
8355
"RTN","XTER1A",56,0)
8356
D ^XMD K XMY,XMTEXT,XMSUB
8357
"RTN","XTER1A",57,0)
8358
Q
8359
"RTN","XTER1A",58,0)
8360
;
8361
"RTN","XTER1A",59,0)
8362
MORE Q:$G(XTMES) N DIR,DTOUT,DIRUT,DUOUT
8363
"RTN","XTER1A",60,0)
8364
S XTOUT=0,XTX="" D WRITER K ^TMP($J,"XTER") S C=0
8365
"RTN","XTER1A",61,0)
8366
I '$D(ZTQUEUED),'$G(XTPRNT),$G(IOST)["C-" D
8367
"RTN","XTER1A",62,0)
8368
. S:($D(X)#2) XTMORE=X S DIR(0)="FO^0:50",DIR("A")=" Enter '^' to quit listing, <RETURN> to continue..."
8369
"RTN","XTER1A",63,0)
8370
. D ^DIR K DIR S:$D(DTOUT) X="^" S XTX=X S:$D(XTMORE) X=XTMORE K XTMORE
8371
"RTN","XTER1A",64,0)
8372
I $D(XTX),$E(XTX)="^" S XTOUT=1 Q
8373
"RTN","XTER1A",65,0)
8374
I $G(XTPRNT) W @IOF
8375
"RTN","XTER1A",66,0)
8376
Q
8377
"RTN","XTER1A",67,0)
8378
;
8379
"RTN","XTER1A",68,0)
8380
LST S X=" ",XTQ="" N XTXT,XBLNK S $P(XBLNK," ",80)=" "
8381
"RTN","XTER1A",69,0)
8382
T1 S X=$O(^%ZTER(1,%XTZDAT,1,X),-1) R XTQ:0 Q:XTQ'="" G T2:X'>0,T1:'($D(^(X,"ZE"))#2) S XTP=^("ZE"),XTS=""
8383
"RTN","XTER1A",70,0)
8384
F S XTS=$O(^TMP($J,"XTERSCR",XTS)) Q:XTS="" I XTP[XTS,XTD S XTD=XTD+1 G T1
8385
"RTN","XTER1A",71,0)
8386
;
8387
"RTN","XTER1A",72,0)
8388
I '(X#20) S %XTERRX=X D MORE Q:XTOUT Q:XTX>0 D T3 S X=%XTERRX
8389
"RTN","XTER1A",73,0)
8390
I ^%ZTER(1,%XTZDAT,1,X,"ZE")["," S %XTERR=$P($P(^("ZE"),",",4),"-",4),%XTERR=$P($P(^("ZE"),",",2),"-",3)_$S(%XTERR="":"",1:"(")_%XTERR_$S(%XTERR="":"",1:")") S XTXT=$J(X,3)_") "_"<"_%XTERR_">"_$P(^("ZE"),",",1)_" "
8391
"RTN","XTER1A",74,0)
8392
I ^%ZTER(1,%XTZDAT,1,X,"ZE")'["," S XTXT=$J(X,3)_") "_^("ZE")
8393
"RTN","XTER1A",75,0)
8394
S %XTZNUM=X,%="" I $D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"H")) S %H=^("H") D YMD^%DTC S %=$P(%,".",2)_"000000",%=$E(%,1,2)_":"_$E(%,3,4)_":"_$E(%,5,6)
8395
"RTN","XTER1A",76,0)
8396
S X=%XTZNUM S XTXT=$S($L(XTXT)>34:XTXT,1:$E(XTXT_XBLNK,1,34))_%
8397
"RTN","XTER1A",77,0)
8398
I $D(^%ZTER(1,%XTZDAT,1,X,"J")) S XTXT=XTXT_" ["_$P($P(^("J"),U,4),",")_"]" ;_" "_$J($P(^("J"),U,5),7)
8399
"RTN","XTER1A",78,0)
8400
D IHSXQY0 ;***IHS
8401
"RTN","XTER1A",79,0)
8402
W !,$E(XTXT,1,79)
8403
"RTN","XTER1A",80,0)
8404
COMMENT I $D(^DD(3.0751,21400)) D ;**MSC/GFT
8405
"RTN","XTER1A",81,0)
8406
.N DIC,DIQ,DR,DA,Y,S,DK,D0,D1
8407
"RTN","XTER1A",82,0)
8408
.S DIC="^%ZTER(1,"_%XTZDAT_",1,",DIQ(0)="A",DR=21400,DA=X,DA(1)=%XTZDAT
8409
"RTN","XTER1A",83,0)
8410
.I $D(@(DIC_DA_",21400)")) N X D EN^DIQ
8411
"RTN","XTER1A",84,0)
8412
G T1
8413
"RTN","XTER1A",85,0)
8414
T2 I XTD W !! I XTD-1 W XTD-1," screened error",$S(XTD-1>1:"s",1:""),!
8415
"RTN","XTER1A",86,0)
8416
;D MORE
8417
"RTN","XTER1A",87,0)
8418
Q
8419
"RTN","XTER1A",88,0)
8420
T3 W !!,?11,"$ZE",?41,"Time",?49,"UCI,VOL",?61,"$J",?69,"$I",!
8421
"RTN","XTER1A",89,0)
8422
Q
8423
"RTN","XTER1A",90,0)
8424
INTRACT ;
8425
"RTN","XTER1A",91,0)
8426
G INTRACT^XTER1A1
8427
"RTN","XTER1A",92,0)
8428
;
8429
"RTN","XTER1A",93,0)
8430
;
8431
"RTN","XTER1A",94,0)
8432
;
8433
"RTN","XTER1A",95,0)
8434
;
8435
"RTN","XTER1A",96,0)
8436
IHSXQY0 ;IHS/ANMC/LJF 5/20/99 find option name
8437
"RTN","XTER1A",97,0)
8438
NEW IHS,FOUND,STR
8439
"RTN","XTER1A",98,0)
8440
S (FOUND,IHS)=0,STR=""
8441
"RTN","XTER1A",99,0)
8442
F S IHS=$O(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS)) Q:'IHS Q:FOUND D
8443
"RTN","XTER1A",100,0)
8444
.I $G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,0))="DUZ" D Q
8445
"RTN","XTER1A",101,0)
8446
..N D,Y S D=$G(^("D")) I D S Y=$P($G(^%ZTER(1,%XTZDAT,1,X,"J")),U,4),Y=$$UCICHECK^%ZOSV(Y) I $L(Y)>2 S Y=$$NAMESP(Y),STR=$P($G(^[Y]VA(200,D,0)),",")_": "
8447
"RTN","XTER1A",102,0)
8448
. Q:$G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,0))'="XQY0"
8449
"RTN","XTER1A",103,0)
8450
. S STR=STR_$P($G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,"D")),U)
8451
"RTN","XTER1A",104,0)
8452
. S STR=$E(STR,1,26)_$$REPEAT^XLFSTR(" ",(26-$L(STR))),FOUND=1
8453
"RTN","XTER1A",105,0)
8454
S XTXT=XTXT_" "_$G(STR)
8455
"RTN","XTER1A",106,0)
8456
Q
8457
"RTN","XTER1A",107,0)
8458
NAMESP(Y) ;
8459
"RTN","XTER1A",108,0)
8460
I ^%ZOSF("OS")'["GT.M" Q Y
8461
"RTN","XTER1A",109,0)
8462
Q $ZGB
8463
"RTN","XUMF5AU")
8464
0^43^B76801793
8465
"RTN","XUMF5AU",1,0)
8466
XUMF5AU ;ISS/PAVEL,MSC/JDA - XUMF5 MD5 Hash API ;27APR2009
8467
"RTN","XUMF5AU",2,0)
8468
;;8.0;KERNEL;**383,MSC**;July 10, 1995
8469
"RTN","XUMF5AU",3,0)
8470
;
8471
"RTN","XUMF5AU",4,0)
8472
;MD5 based on info from 4.005 SORT BY VUID;;original name was 'VESOUHSH' ; Secure hash functions
8473
"RTN","XUMF5AU",5,0)
8474
;;(c) Copyright 1994 - 2004, ESI Technology Corp, Natick MA
8475
"RTN","XUMF5AU",6,0)
8476
;; This source code contains the intellectual property of its copyright holder(s),
8477
"RTN","XUMF5AU",7,0)
8478
;; and is made available under a license. If you are not familiar with the terms
8479
"RTN","XUMF5AU",8,0)
8480
;; of the license, please refer to the license.txt file that is a part of the
8481
"RTN","XUMF5AU",9,0)
8482
;; distribution kit.
8483
"RTN","XUMF5AU",10,0)
8484
;; This is a routine version where Variables and Commands set to be Upercase. Pavel
8485
"RTN","XUMF5AU",11,0)
8486
;
8487
"RTN","XUMF5AU",12,0)
8488
Q
8489
"RTN","XUMF5AU",13,0)
8490
;;**************************************************
8491
"RTN","XUMF5AU",14,0)
8492
;;MD5 'R'egular portion of the code. This will handle
8493
"RTN","XUMF5AU",15,0)
8494
;; one string at a time.
8495
"RTN","XUMF5AU",16,0)
8496
;;**************************************************
8497
"RTN","XUMF5AU",17,0)
8498
MD5R(STR) ; Construct a 128-bit MD5 hash of the input.
8499
"RTN","XUMF5AU",18,0)
8500
N TWOTO
8501
"RTN","XUMF5AU",19,0)
8502
N A,B,C,D
8503
"RTN","XUMF5AU",20,0)
8504
N AA,BB,CC,DD
8505
"RTN","XUMF5AU",21,0)
8506
D INITR
8507
"RTN","XUMF5AU",22,0)
8508
PAD1R ; Pad str out to 56 bytes mod 64
8509
"RTN","XUMF5AU",23,0)
8510
; Padding is a 1 bit followed by all zero bits
8511
"RTN","XUMF5AU",24,0)
8512
N LEN,MOD,NPAD,PAD
8513
"RTN","XUMF5AU",25,0)
8514
S LEN=$L(STR),MOD=LEN#64
8515
"RTN","XUMF5AU",26,0)
8516
S NPAD=$S(MOD<56:56-MOD,1:120-MOD)
8517
"RTN","XUMF5AU",27,0)
8518
S PAD=$C(128)
8519
"RTN","XUMF5AU",28,0)
8520
S:NPAD>1 $P(PAD,$C(0),NPAD)=""
8521
"RTN","XUMF5AU",29,0)
8522
S STR=STR_PAD
8523
"RTN","XUMF5AU",30,0)
8524
PAD2R ; Append length in bits as 64-bit integer, little endian
8525
"RTN","XUMF5AU",31,0)
8526
S LEN=LEN*8
8527
"RTN","XUMF5AU",32,0)
8528
S STR=STR_$$UI64BIT(LEN)
8529
"RTN","XUMF5AU",33,0)
8530
PROCESSR ; Main processing and transformation loop
8531
"RTN","XUMF5AU",34,0)
8532
N J,POS,N,I
8533
"RTN","XUMF5AU",35,0)
8534
N X ; X(J) is a 4-byte word from a 64-byte block
8535
"RTN","XUMF5AU",36,0)
8536
S N=$L(STR)/64 ; Number of 64-byte blocks
8537
"RTN","XUMF5AU",37,0)
8538
F I=0:1:N-1 D
8539
"RTN","XUMF5AU",38,0)
8540
. F J=0:1:15 S POS=(64*I)+(4*J),X(J)=$E(STR,POS+1,POS+4)
8541
"RTN","XUMF5AU",39,0)
8542
. D SAVE
8543
"RTN","XUMF5AU",40,0)
8544
. D ROUND1
8545
"RTN","XUMF5AU",41,0)
8546
. D ROUND2
8547
"RTN","XUMF5AU",42,0)
8548
. D ROUND3
8549
"RTN","XUMF5AU",43,0)
8550
. D ROUND4
8551
"RTN","XUMF5AU",44,0)
8552
. D INCR
8553
"RTN","XUMF5AU",45,0)
8554
K X
8555
"RTN","XUMF5AU",46,0)
8556
Q A_B_C_D
8557
"RTN","XUMF5AU",47,0)
8558
;
8559
"RTN","XUMF5AU",48,0)
8560
INITR ; Initialization
8561
"RTN","XUMF5AU",49,0)
8562
; Set up array of powers of two for rotation
8563
"RTN","XUMF5AU",50,0)
8564
N I,N
8565
"RTN","XUMF5AU",51,0)
8566
S N=1
8567
"RTN","XUMF5AU",52,0)
8568
F I=0:1:31 S TWOTO(I)=N,N=N+N
8569
"RTN","XUMF5AU",53,0)
8570
; Initialize 4-byte buffers A,B,C,D
8571
"RTN","XUMF5AU",54,0)
8572
S A=$C(1,35,69,103)
8573
"RTN","XUMF5AU",55,0)
8574
S B=$C(137,171,205,239)
8575
"RTN","XUMF5AU",56,0)
8576
S C=$C(254,220,186,152)
8577
"RTN","XUMF5AU",57,0)
8578
S D=$C(118,84,50,16)
8579
"RTN","XUMF5AU",58,0)
8580
Q
8581
"RTN","XUMF5AU",59,0)
8582
;
8583
"RTN","XUMF5AU",60,0)
8584
;;**************************************************
8585
"RTN","XUMF5AU",61,0)
8586
;;MD5 'E'nhanced portion of the code. This will handle
8587
"RTN","XUMF5AU",62,0)
8588
;; multiple strings and produce a value for them all
8589
"RTN","XUMF5AU",63,0)
8590
;; as if they were submitted as one long string.
8591
"RTN","XUMF5AU",64,0)
8592
;;**************************************************
8593
"RTN","XUMF5AU",65,0)
8594
MD5E(ABCD,STR,PP,LL) ; Construct a 128-bit MD5 hash of the input.
8595
"RTN","XUMF5AU",66,0)
8596
N TWOTO
8597
"RTN","XUMF5AU",67,0)
8598
N A,B,C,D
8599
"RTN","XUMF5AU",68,0)
8600
N AA,BB,CC,DD
8601
"RTN","XUMF5AU",69,0)
8602
D INITE(ABCD)
8603
"RTN","XUMF5AU",70,0)
8604
PAD1E ; Pad str out to 56 bytes mod 64
8605
"RTN","XUMF5AU",71,0)
8606
; Padding is a 1 bit followed by all zero bits
8607
"RTN","XUMF5AU",72,0)
8608
; PP = 1 Don't pad with $C(128) !!! Pavel Set to 1 if this is not last string !!
8609
"RTN","XUMF5AU",73,0)
8610
; Set to 0 if this is last string !!
8611
"RTN","XUMF5AU",74,0)
8612
; LL = Lenght passed form outside for pading of little endian Pavel !!! -
8613
"RTN","XUMF5AU",75,0)
8614
; Seting lenght if this is last value othervise computed lenght used...
8615
"RTN","XUMF5AU",76,0)
8616
N LEN,MOD,NPAD,PAD
8617
"RTN","XUMF5AU",77,0)
8618
S LEN=$L(STR),MOD=LEN#64
8619
"RTN","XUMF5AU",78,0)
8620
S:$G(LL) LEN=LL ;Pavel
8621
"RTN","XUMF5AU",79,0)
8622
S NPAD=$S(MOD<56:56-MOD,1:120-MOD)
8623
"RTN","XUMF5AU",80,0)
8624
S PAD=$C(128)
8625
"RTN","XUMF5AU",81,0)
8626
S:NPAD>1 $P(PAD,$C(0),NPAD)=""
8627
"RTN","XUMF5AU",82,0)
8628
S:'$G(PP) STR=STR_PAD ;Pavel
8629
"RTN","XUMF5AU",83,0)
8630
;S STR=STR_PAD
8631
"RTN","XUMF5AU",84,0)
8632
PAD2E ; Append length in bits as 64-bit integer, little endian
8633
"RTN","XUMF5AU",85,0)
8634
S LEN=LEN*8
8635
"RTN","XUMF5AU",86,0)
8636
S STR=STR_$$UI64BIT(LEN)
8637
"RTN","XUMF5AU",87,0)
8638
PROCESSE ; Main processing and transformation loop
8639
"RTN","XUMF5AU",88,0)
8640
N J,POS,N,I
8641
"RTN","XUMF5AU",89,0)
8642
N X ; X(J) is a 4-byte word from a 64-byte block
8643
"RTN","XUMF5AU",90,0)
8644
;S N=$L(STR)/64 ; Number of 64-byte blocks
8645
"RTN","XUMF5AU",91,0)
8646
S N=$L(STR)\64 ; Number of 64-byte blocks
8647
"RTN","XUMF5AU",92,0)
8648
F I=0:1:N-1 D
8649
"RTN","XUMF5AU",93,0)
8650
. F J=0:1:15 S POS=(64*I)+(4*J),X(J)=$E(STR,POS+1,POS+4)
8651
"RTN","XUMF5AU",94,0)
8652
. D SAVE
8653
"RTN","XUMF5AU",95,0)
8654
. D ROUND1
8655
"RTN","XUMF5AU",96,0)
8656
. D ROUND2
8657
"RTN","XUMF5AU",97,0)
8658
. D ROUND3
8659
"RTN","XUMF5AU",98,0)
8660
. D ROUND4
8661
"RTN","XUMF5AU",99,0)
8662
. D INCR
8663
"RTN","XUMF5AU",100,0)
8664
. ;W !,I," ABCD=",$$MAIN^XUMF5BYT($$HEX(A_B_C_D)),!
8665
"RTN","XUMF5AU",101,0)
8666
K X
8667
"RTN","XUMF5AU",102,0)
8668
Q A_B_C_D
8669
"RTN","XUMF5AU",103,0)
8670
;
8671
"RTN","XUMF5AU",104,0)
8672
INITE(LASTABCD) ; Initialization
8673
"RTN","XUMF5AU",105,0)
8674
; Set up array of powers of two for rotation
8675
"RTN","XUMF5AU",106,0)
8676
N I,N,L
8677
"RTN","XUMF5AU",107,0)
8678
S N=1
8679
"RTN","XUMF5AU",108,0)
8680
F I=0:1:31 S TWOTO(I)=N,N=N+N
8681
"RTN","XUMF5AU",109,0)
8682
; Initialize 4-byte buffers A,B,C,D
8683
"RTN","XUMF5AU",110,0)
8684
S A=$E(LASTABCD,1,4)
8685
"RTN","XUMF5AU",111,0)
8686
S B=$E(LASTABCD,5,8)
8687
"RTN","XUMF5AU",112,0)
8688
S C=$E(LASTABCD,9,12)
8689
"RTN","XUMF5AU",113,0)
8690
S D=$E(LASTABCD,13,16)
8691
"RTN","XUMF5AU",114,0)
8692
Q
8693
"RTN","XUMF5AU",115,0)
8694
;
8695
"RTN","XUMF5AU",116,0)
8696
;;**************************************************
8697
"RTN","XUMF5AU",117,0)
8698
;;This is where common code starts, used by both
8699
"RTN","XUMF5AU",118,0)
8700
;; Regular and Enhanced portions of this routine.
8701
"RTN","XUMF5AU",119,0)
8702
;;**************************************************
8703
"RTN","XUMF5AU",120,0)
8704
SAVE ; Save buffers
8705
"RTN","XUMF5AU",121,0)
8706
S AA=A,BB=B,CC=C,DD=D
8707
"RTN","XUMF5AU",122,0)
8708
Q
8709
"RTN","XUMF5AU",123,0)
8710
;
8711
"RTN","XUMF5AU",124,0)
8712
ROUND1 ; First round of transformation
8713
"RTN","XUMF5AU",125,0)
8714
D SUB(.A,B,C,D,X(0),7,3614090360,1)
8715
"RTN","XUMF5AU",126,0)
8716
D SUB(.D,A,B,C,X(1),12,3905402710,1)
8717
"RTN","XUMF5AU",127,0)
8718
D SUB(.C,D,A,B,X(2),17,606105819,1)
8719
"RTN","XUMF5AU",128,0)
8720
D SUB(.B,C,D,A,X(3),22,3250441966,1)
8721
"RTN","XUMF5AU",129,0)
8722
D SUB(.A,B,C,D,X(4),7,4118548399,1)
8723
"RTN","XUMF5AU",130,0)
8724
D SUB(.D,A,B,C,X(5),12,1200080426,1)
8725
"RTN","XUMF5AU",131,0)
8726
D SUB(.C,D,A,B,X(6),17,2821735955,1)
8727
"RTN","XUMF5AU",132,0)
8728
D SUB(.B,C,D,A,X(7),22,4249261313,1)
8729
"RTN","XUMF5AU",133,0)
8730
D SUB(.A,B,C,D,X(8),7,1770035416,1)
8731
"RTN","XUMF5AU",134,0)
8732
D SUB(.D,A,B,C,X(9),12,2336552879,1)
8733
"RTN","XUMF5AU",135,0)
8734
D SUB(.C,D,A,B,X(10),17,4294925233,1)
8735
"RTN","XUMF5AU",136,0)
8736
D SUB(.B,C,D,A,X(11),22,2304563134,1)
8737
"RTN","XUMF5AU",137,0)
8738
D SUB(.A,B,C,D,X(12),7,1804603682,1)
8739
"RTN","XUMF5AU",138,0)
8740
D SUB(.D,A,B,C,X(13),12,4254626195,1)
8741
"RTN","XUMF5AU",139,0)
8742
D SUB(.C,D,A,B,X(14),17,2792965006,1)
8743
"RTN","XUMF5AU",140,0)
8744
D SUB(.B,C,D,A,X(15),22,1236535329,1)
8745
"RTN","XUMF5AU",141,0)
8746
Q
8747
"RTN","XUMF5AU",142,0)
8748
;
8749
"RTN","XUMF5AU",143,0)
8750
ROUND2 ; Second round of transformation
8751
"RTN","XUMF5AU",144,0)
8752
D SUB(.A,B,C,D,X(1),5,4129170786,2)
8753
"RTN","XUMF5AU",145,0)
8754
D SUB(.D,A,B,C,X(6),9,3225465664,2)
8755
"RTN","XUMF5AU",146,0)
8756
D SUB(.C,D,A,B,X(11),14,643717713,2)
8757
"RTN","XUMF5AU",147,0)
8758
D SUB(.B,C,D,A,X(0),20,3921069994,2)
8759
"RTN","XUMF5AU",148,0)
8760
D SUB(.A,B,C,D,X(5),5,3593408605,2)
8761
"RTN","XUMF5AU",149,0)
8762
D SUB(.D,A,B,C,X(10),9,38016083,2)
8763
"RTN","XUMF5AU",150,0)
8764
D SUB(.C,D,A,B,X(15),14,3634488961,2)
8765
"RTN","XUMF5AU",151,0)
8766
D SUB(.B,C,D,A,X(4),20,3889429448,2)
8767
"RTN","XUMF5AU",152,0)
8768
D SUB(.A,B,C,D,X(9),5,568446438,2)
8769
"RTN","XUMF5AU",153,0)
8770
D SUB(.D,A,B,C,X(14),9,3275163606,2)
8771
"RTN","XUMF5AU",154,0)
8772
D SUB(.C,D,A,B,X(3),14,4107603335,2)
8773
"RTN","XUMF5AU",155,0)
8774
D SUB(.B,C,D,A,X(8),20,1163531501,2)
8775
"RTN","XUMF5AU",156,0)
8776
D SUB(.A,B,C,D,X(13),5,2850285829,2)
8777
"RTN","XUMF5AU",157,0)
8778
D SUB(.D,A,B,C,X(2),9,4243563512,2)
8779
"RTN","XUMF5AU",158,0)
8780
D SUB(.C,D,A,B,X(7),14,1735328473,2)
8781
"RTN","XUMF5AU",159,0)
8782
D SUB(.B,C,D,A,X(12),20,2368359562,2)
8783
"RTN","XUMF5AU",160,0)
8784
Q
8785
"RTN","XUMF5AU",161,0)
8786
;
8787
"RTN","XUMF5AU",162,0)
8788
ROUND3 ; Third round of transformation
8789
"RTN","XUMF5AU",163,0)
8790
D SUB(.A,B,C,D,X(5),4,4294588738,3)
8791
"RTN","XUMF5AU",164,0)
8792
D SUB(.D,A,B,C,X(8),11,2272392833,3)
8793
"RTN","XUMF5AU",165,0)
8794
D SUB(.C,D,A,B,X(11),16,1839030562,3)
8795
"RTN","XUMF5AU",166,0)
8796
D SUB(.B,C,D,A,X(14),23,4259657740,3)
8797
"RTN","XUMF5AU",167,0)
8798
D SUB(.A,B,C,D,X(1),4,2763975236,3)
8799
"RTN","XUMF5AU",168,0)
8800
D SUB(.D,A,B,C,X(4),11,1272893353,3)
8801
"RTN","XUMF5AU",169,0)
8802
D SUB(.C,D,A,B,X(7),16,4139469664,3)
8803
"RTN","XUMF5AU",170,0)
8804
D SUB(.B,C,D,A,X(10),23,3200236656,3)
8805
"RTN","XUMF5AU",171,0)
8806
D SUB(.A,B,C,D,X(13),4,681279174,3)
8807
"RTN","XUMF5AU",172,0)
8808
D SUB(.D,A,B,C,X(0),11,3936430074,3)
8809
"RTN","XUMF5AU",173,0)
8810
D SUB(.C,D,A,B,X(3),16,3572445317,3)
8811
"RTN","XUMF5AU",174,0)
8812
D SUB(.B,C,D,A,X(6),23,76029189,3)
8813
"RTN","XUMF5AU",175,0)
8814
D SUB(.A,B,C,D,X(9),4,3654602809,3)
8815
"RTN","XUMF5AU",176,0)
8816
D SUB(.D,A,B,C,X(12),11,3873151461,3)
8817
"RTN","XUMF5AU",177,0)
8818
D SUB(.C,D,A,B,X(15),16,530742520,3)
8819
"RTN","XUMF5AU",178,0)
8820
D SUB(.B,C,D,A,X(2),23,3299628645,3)
8821
"RTN","XUMF5AU",179,0)
8822
Q
8823
"RTN","XUMF5AU",180,0)
8824
;
8825
"RTN","XUMF5AU",181,0)
8826
ROUND4 ; Fourth round of transformation
8827
"RTN","XUMF5AU",182,0)
8828
D SUB(.A,B,C,D,X(0),6,4096336452,4)
8829
"RTN","XUMF5AU",183,0)
8830
D SUB(.D,A,B,C,X(7),10,1126891415,4)
8831
"RTN","XUMF5AU",184,0)
8832
D SUB(.C,D,A,B,X(14),15,2878612391,4)
8833
"RTN","XUMF5AU",185,0)
8834
D SUB(.B,C,D,A,X(5),21,4237533241,4)
8835
"RTN","XUMF5AU",186,0)
8836
D SUB(.A,B,C,D,X(12),6,1700485571,4)
8837
"RTN","XUMF5AU",187,0)
8838
D SUB(.D,A,B,C,X(3),10,2399980690,4)
8839
"RTN","XUMF5AU",188,0)
8840
D SUB(.C,D,A,B,X(10),15,4293915773,4)
8841
"RTN","XUMF5AU",189,0)
8842
D SUB(.B,C,D,A,X(1),21,2240044497,4)
8843
"RTN","XUMF5AU",190,0)
8844
D SUB(.A,B,C,D,X(8),6,1873313359,4)
8845
"RTN","XUMF5AU",191,0)
8846
D SUB(.D,A,B,C,X(15),10,4264355552,4)
8847
"RTN","XUMF5AU",192,0)
8848
D SUB(.C,D,A,B,X(6),15,2734768916,4)
8849
"RTN","XUMF5AU",193,0)
8850
D SUB(.B,C,D,A,X(13),21,1309151649,4)
8851
"RTN","XUMF5AU",194,0)
8852
D SUB(.A,B,C,D,X(4),6,4149444226,4)
8853
"RTN","XUMF5AU",195,0)
8854
D SUB(.D,A,B,C,X(11),10,3174756917,4)
8855
"RTN","XUMF5AU",196,0)
8856
D SUB(.C,D,A,B,X(2),15,718787259,4)
8857
"RTN","XUMF5AU",197,0)
8858
D SUB(.B,C,D,A,X(9),21,3951481745,4)
8859
"RTN","XUMF5AU",198,0)
8860
Q
8861
"RTN","XUMF5AU",199,0)
8862
INCR ;
8863
"RTN","XUMF5AU",200,0)
8864
S A=$$ADD(A,AA)
8865
"RTN","XUMF5AU",201,0)
8866
S B=$$ADD(B,BB)
8867
"RTN","XUMF5AU",202,0)
8868
S C=$$ADD(C,CC)
8869
"RTN","XUMF5AU",203,0)
8870
S D=$$ADD(D,DD)
8871
"RTN","XUMF5AU",204,0)
8872
Q
8873
"RTN","XUMF5AU",205,0)
8874
;
8875
"RTN","XUMF5AU",206,0)
8876
; Auxiliary functions
8877
"RTN","XUMF5AU",207,0)
8878
;
8879
"RTN","XUMF5AU",208,0)
8880
SUB(A,B,C,D,X,S,AC,FN) ; FN is 1 (F), 2 (G), 3 (H) or 4 (I)
8881
"RTN","XUMF5AU",209,0)
8882
N INT,COMB,CMD,DO
8883
"RTN","XUMF5AU",210,0)
8884
S INT=$$UINT32(A)
8885
"RTN","XUMF5AU",211,0)
8886
S DO="COMB"_FN
8887
"RTN","XUMF5AU",212,0)
8888
D @DO
8889
"RTN","XUMF5AU",213,0)
8890
S INT=$$ADDIW(INT,COMB)
8891
"RTN","XUMF5AU",214,0)
8892
S INT=$$ADDIW(INT,X)
8893
"RTN","XUMF5AU",215,0)
8894
S INT=$$ADDII(INT,AC)
8895
"RTN","XUMF5AU",216,0)
8896
S INT=$$ROTLI(INT,S)
8897
"RTN","XUMF5AU",217,0)
8898
S INT=$$ADDIW(INT,B)
8899
"RTN","XUMF5AU",218,0)
8900
S A=$$UI32BIT(INT)
8901
"RTN","XUMF5AU",219,0)
8902
Q
8903
"RTN","XUMF5AU",220,0)
8904
COMB ; Choose F, G, H or I
8905
"RTN","XUMF5AU",221,0)
8906
COMB1 S COMB=$$OR($$AND(B,C),$$AND($$NOT(B),D)) Q ; F
8907
"RTN","XUMF5AU",222,0)
8908
COMB2 S COMB=$$OR($$AND(B,D),$$AND(C,$$NOT(D))) Q ; G
8909
"RTN","XUMF5AU",223,0)
8910
COMB3 S COMB=$$XOR($$XOR(B,C),D) Q ; H
8911
"RTN","XUMF5AU",224,0)
8912
COMB4 S COMB=$$XOR(C,$$OR(B,$$NOT(D))) Q ; I
8913
"RTN","XUMF5AU",225,0)
8914
Q
8915
"RTN","XUMF5AU",226,0)
8916
;
8917
"RTN","XUMF5AU",227,0)
8918
; Boolean functions assume args are 4-character strings
8919
"RTN","XUMF5AU",228,0)
8920
;
8921
"RTN","XUMF5AU",229,0)
8922
AND(X,Y) ;
8923
"RTN","XUMF5AU",230,0)
8924
I ^%ZOSF("OS")["GT.M" Q $ZBITAND(X,Y)
8925
"RTN","XUMF5AU",231,0)
8926
Q $ZBOOLEAN(X,Y,1) ;;EOCONDCD;CACHE
8927
"RTN","XUMF5AU",232,0)
8928
Q X ; Placeholder for other M implementations
8929
"RTN","XUMF5AU",233,0)
8930
;
8931
"RTN","XUMF5AU",234,0)
8932
OR(X,Y) ;
8933
"RTN","XUMF5AU",235,0)
8934
I ^%ZOSF("OS")["GT.M" Q $ZBITOR(X,Y)
8935
"RTN","XUMF5AU",236,0)
8936
Q $ZBOOLEAN(X,Y,7) ;;EOCONDCD;CACHE
8937
"RTN","XUMF5AU",237,0)
8938
Q X ; Placeholder for other M implementations
8939
"RTN","XUMF5AU",238,0)
8940
;
8941
"RTN","XUMF5AU",239,0)
8942
XOR(X,Y) ;
8943
"RTN","XUMF5AU",240,0)
8944
I ^%ZOSF("OS")["GT.M" Q $ZBITXOR(X,Y)
8945
"RTN","XUMF5AU",241,0)
8946
Q $ZBOOLEAN(X,Y,6) ;;EOCONDCD;CACHE
8947
"RTN","XUMF5AU",242,0)
8948
Q X ; Placeholder for other M implementations
8949
"RTN","XUMF5AU",243,0)
8950
;
8951
"RTN","XUMF5AU",244,0)
8952
NOT(X) ;
8953
"RTN","XUMF5AU",245,0)
8954
I ^%ZOSF("OS")["GT.M" Q $ZBITNOT(X)
8955
"RTN","XUMF5AU",246,0)
8956
Q $ZBOOLEAN(X,X,12) ;;EOCONDCD;CACHE
8957
"RTN","XUMF5AU",247,0)
8958
Q X ; Placeholder for other M implementations
8959
"RTN","XUMF5AU",248,0)
8960
;
8961
"RTN","XUMF5AU",249,0)
8962
; Functions to add and rotate 32-bit words
8963
"RTN","XUMF5AU",250,0)
8964
; X and Y are 4-character strings
8965
"RTN","XUMF5AU",251,0)
8966
; m, n and s are integers
8967
"RTN","XUMF5AU",252,0)
8968
; ADD and ROTL return 4-character strings
8969
"RTN","XUMF5AU",253,0)
8970
; ADDIW, ADDII and ROTLI return integers
8971
"RTN","XUMF5AU",254,0)
8972
;
8973
"RTN","XUMF5AU",255,0)
8974
ADD(X,Y) ; modulo 2**32
8975
"RTN","XUMF5AU",256,0)
8976
Q $$UI32BIT($$UINT32(X)+$$UINT32(Y)#4294967296)
8977
"RTN","XUMF5AU",257,0)
8978
;
8979
"RTN","XUMF5AU",258,0)
8980
ADDIW(M,Y) ; modulo 2**32
8981
"RTN","XUMF5AU",259,0)
8982
Q M+$$UINT32(Y)#4294967296
8983
"RTN","XUMF5AU",260,0)
8984
;
8985
"RTN","XUMF5AU",261,0)
8986
ADDII(M,N) ; modulo 2**32
8987
"RTN","XUMF5AU",262,0)
8988
Q M+N#4294967296
8989
"RTN","XUMF5AU",263,0)
8990
;
8991
"RTN","XUMF5AU",264,0)
8992
ROTL(X,S) ; rotate left by s bits
8993
"RTN","XUMF5AU",265,0)
8994
N INT,RIGHT,SWAP
8995
"RTN","XUMF5AU",266,0)
8996
S INT=$$UINT32(X)
8997
"RTN","XUMF5AU",267,0)
8998
S RIGHT=INT#TWOTO(32-S)
8999
"RTN","XUMF5AU",268,0)
9000
S SWAP=RIGHT*TWOTO(S)+(INT\TWOTO(32-S))
9001
"RTN","XUMF5AU",269,0)
9002
Q $$UI32BIT(SWAP)
9003
"RTN","XUMF5AU",270,0)
9004
;
9005
"RTN","XUMF5AU",271,0)
9006
ROTLI(N,S) ; rotate left by s bits
9007
"RTN","XUMF5AU",272,0)
9008
N RIGHT,SWAP
9009
"RTN","XUMF5AU",273,0)
9010
S RIGHT=N#TWOTO(32-S)
9011
"RTN","XUMF5AU",274,0)
9012
S SWAP=RIGHT*TWOTO(S)+(N\TWOTO(32-S))
9013
"RTN","XUMF5AU",275,0)
9014
Q SWAP
9015
"RTN","XUMF5AU",276,0)
9016
;
9017
"RTN","XUMF5AU",277,0)
9018
; Utility functions
9019
"RTN","XUMF5AU",278,0)
9020
;
9021
"RTN","XUMF5AU",279,0)
9022
UI64BIT(N) ; Convert unsigned integer to 64-bit form, little endian
9023
"RTN","XUMF5AU",280,0)
9024
; code from CORBA ULONGLONG marshaling
9025
"RTN","XUMF5AU",281,0)
9026
N D,X,I
9027
"RTN","XUMF5AU",282,0)
9028
S D=""
9029
"RTN","XUMF5AU",283,0)
9030
F I=7:-1:1 D
9031
"RTN","XUMF5AU",284,0)
9032
. S X=0
9033
"RTN","XUMF5AU",285,0)
9034
. F Q:(N<(256**I)) S X=X+1,N=N-(256**I)
9035
"RTN","XUMF5AU",286,0)
9036
. S X(I)=X
9037
"RTN","XUMF5AU",287,0)
9038
S D=D_$C(N)
9039
"RTN","XUMF5AU",288,0)
9040
F I=1:1:7 S D=D_$C(X(I))
9041
"RTN","XUMF5AU",289,0)
9042
Q D
9043
"RTN","XUMF5AU",290,0)
9044
;
9045
"RTN","XUMF5AU",291,0)
9046
UI32BIT(N) ; Convert unsigned integer to 32-bit form, little endian
9047
"RTN","XUMF5AU",292,0)
9048
; code from CORBA ULONG marshaling
9049
"RTN","XUMF5AU",293,0)
9050
Q $C(N#256,(N\256#256),(N\(65536)#256),(N\(16777216)#256))
9051
"RTN","XUMF5AU",294,0)
9052
;
9053
"RTN","XUMF5AU",295,0)
9054
UINT32(STR) ; Get integer value from bits of 4-character string
9055
"RTN","XUMF5AU",296,0)
9056
; code from CORBA ULONG unmarshaling
9057
"RTN","XUMF5AU",297,0)
9058
Q $A(STR,1)+(256*$A(STR,2))+(65536*$A(STR,3))+(16777216*$A(STR,4))
9059
"RTN","XUMF5AU",298,0)
9060
;
9061
"RTN","XUMF5AU",299,0)
9062
HEX(STR) ; Printable hex representation of characters in string
9063
"RTN","XUMF5AU",300,0)
9064
N DIGITS,RET,I,J,BYTE,OFFSET
9065
"RTN","XUMF5AU",301,0)
9066
S DIGITS="0123456789abcdef"
9067
"RTN","XUMF5AU",302,0)
9068
S RET=""
9069
"RTN","XUMF5AU",303,0)
9070
S OFFSET=$L(STR)#4
9071
"RTN","XUMF5AU",304,0)
9072
S:OFFSET STR=STR_$E($C(0,0,0),1,4-OFFSET) ; PAD
9073
"RTN","XUMF5AU",305,0)
9074
F I=0:4:$L(STR)-4 F J=4:-1:1 D ; Reverse byte order in each word
9075
"RTN","XUMF5AU",306,0)
9076
. S BYTE=$A(STR,I+J)
9077
"RTN","XUMF5AU",307,0)
9078
. S RET=RET_$E(DIGITS,1+(BYTE\16)) ; High nibble
9079
"RTN","XUMF5AU",308,0)
9080
. S RET=RET_$E(DIGITS,1+(BYTE#16)) ; Low nibble
9081
"RTN","XUMF5AU",309,0)
9082
Q RET
9083
"RTN","XUMF5AU",310,0)
9084
;
9085
"RTN","XUMF5AU",311,0)
9086
CHR2OCT(STR) ; convert hex string to decimal byte values
9087
"RTN","XUMF5AU",312,0)
9088
N RET,I,BYTE,HIGH,LOW
9089
"RTN","XUMF5AU",313,0)
9090
S RET=""
9091
"RTN","XUMF5AU",314,0)
9092
F I=1:2:$L(STR) D
9093
"RTN","XUMF5AU",315,0)
9094
. S BYTE=$E(STR,I,I+1)
9095
"RTN","XUMF5AU",316,0)
9096
. Q:BYTE'?2NL
9097
"RTN","XUMF5AU",317,0)
9098
. S HIGH=$$CHAR1($E(BYTE,1))
9099
"RTN","XUMF5AU",318,0)
9100
. S LOW=$$CHAR1($E(BYTE,2))
9101
"RTN","XUMF5AU",319,0)
9102
. S RET=RET_(16*HIGH+LOW)_" "
9103
"RTN","XUMF5AU",320,0)
9104
Q RET
9105
"RTN","XUMF5AU",321,0)
9106
;
9107
"RTN","XUMF5AU",322,0)
9108
CHAR1(DIGIT) ; convert one char to its hex value
9109
"RTN","XUMF5AU",323,0)
9110
N X
9111
"RTN","XUMF5AU",324,0)
9112
S X=$F("0123456789abcdef",DIGIT)
9113
"RTN","XUMF5AU",325,0)
9114
Q:X=0 0
9115
"RTN","XUMF5AU",326,0)
9116
Q X-2
9117
"RTN","XWBRW")
9118
0^50^B8699412
9119
"RTN","XWBRW",1,0)
9120
XWBRW ;ISF/RWF,MSC/JDA - Read/Write for Broker TCP ;06AUG2009
9121
"RTN","XWBRW",2,0)
9122
;;1.1;RPC BROKER;**35,MSC**;Mar 28, 1997
9123
"RTN","XWBRW",3,0)
9124
Q
9125
"RTN","XWBRW",4,0)
9126
;
9127
"RTN","XWBRW",5,0)
9128
;XWBRBUF is global
9129
"RTN","XWBRW",6,0)
9130
;SE is a flag to skip error for short read. From PRSB+41^XWBBRK
9131
"RTN","XWBRW",7,0)
9132
BREAD(L,TO,SE) ;read tcp buffer, L is length, TO is timeout
9133
"RTN","XWBRW",8,0)
9134
N R,S,DONE,C
9135
"RTN","XWBRW",9,0)
9136
I L'>0 Q ""
9137
"RTN","XWBRW",10,0)
9138
I $L(XWBRBUF)'<L S R=$E(XWBRBUF,1,L),XWBRBUF=$E(XWBRBUF,L+1,999999) Q R
9139
"RTN","XWBRW",11,0)
9140
S R="",DONE=0,L=+L,C=0
9141
"RTN","XWBRW",12,0)
9142
S TO=$S($G(TO)>0:TO,$G(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1
9143
"RTN","XWBRW",13,0)
9144
U XWBTDEV
9145
"RTN","XWBRW",14,0)
9146
F D Q:DONE
9147
"RTN","XWBRW",15,0)
9148
. S S=L-$L(R),R=R_$E(XWBRBUF,1,S),XWBRBUF=$E(XWBRBUF,S+1,999999)
9149
"RTN","XWBRW",16,0)
9150
. I ($L(R)=L)!(R[$C(4))!(C>TO) S DONE=1 Q
9151
"RTN","XWBRW",17,0)
9152
. R XWBRBUF#S:2 S:'$T C=C+1 S:$L(XWBRBUF) C=0
9153
"RTN","XWBRW",18,0)
9154
. I $D D LOG^XWBDLOG("Device error: "_$D) S DONE=1
9155
"RTN","XWBRW",19,0)
9156
. I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG("rd: "_$E(XWBRBUF,1,252))
9157
"RTN","XWBRW",20,0)
9158
. Q
9159
"RTN","XWBRW",21,0)
9160
I $L(R)<L,'$G(SE) S $ECODE=",U411," ;Throw Error, Did not read full length
9161
"RTN","XWBRW",22,0)
9162
Q R
9163
"RTN","XWBRW",23,0)
9164
;
9165
"RTN","XWBRW",24,0)
9166
QSND(XWBR) ;Quick send
9167
"RTN","XWBRW",25,0)
9168
S XWBPTYPE=1,XWBERROR="",XWBSEC="" D SND
9169
"RTN","XWBRW",26,0)
9170
Q
9171
"RTN","XWBRW",27,0)
9172
;
9173
"RTN","XWBRW",28,0)
9174
ESND(XWBR) ;Send from ETRAP
9175
"RTN","XWBRW",29,0)
9176
S XWBPTYPE=1 D SND
9177
"RTN","XWBRW",30,0)
9178
Q
9179
"RTN","XWBRW",31,0)
9180
;
9181
"RTN","XWBRW",32,0)
9182
SND ; Send a responce
9183
"RTN","XWBRW",33,0)
9184
N XWBSBUF S XWBSBUF=""
9185
"RTN","XWBRW",34,0)
9186
U XWBTDEV
9187
"RTN","XWBRW",35,0)
9188
;
9189
"RTN","XWBRW",36,0)
9190
D SNDERR ;Send any error info
9191
"RTN","XWBRW",37,0)
9192
D SNDDATA ;Send the data
9193
"RTN","XWBRW",38,0)
9194
;D WRITE($C(4)) ;EOT
9195
"RTN","XWBRW",39,0)
9196
D WRITE($C(4)),WBF
9197
"RTN","XWBRW",40,0)
9198
Q
9199
"RTN","XWBRW",41,0)
9200
;
9201
"RTN","XWBRW",42,0)
9202
SNDDATA ;Send the data part
9203
"RTN","XWBRW",43,0)
9204
N I,D
9205
"RTN","XWBRW",44,0)
9206
; -- single value
9207
"RTN","XWBRW",45,0)
9208
I XWBPTYPE=1 D WRITE($G(XWBR)) Q
9209
"RTN","XWBRW",46,0)
9210
; -- table delimited by CR+LF
9211
"RTN","XWBRW",47,0)
9212
I XWBPTYPE=2 D Q
9213
"RTN","XWBRW",48,0)
9214
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)),WRITE($C(13,10))
9215
"RTN","XWBRW",49,0)
9216
; -- word processing
9217
"RTN","XWBRW",50,0)
9218
I XWBPTYPE=3 D Q
9219
"RTN","XWBRW",51,0)
9220
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)) D:XWBWRAP WRITE($C(13,10))
9221
"RTN","XWBRW",52,0)
9222
; -- global array
9223
"RTN","XWBRW",53,0)
9224
I XWBPTYPE=4 D Q
9225
"RTN","XWBRW",54,0)
9226
. I $E($G(XWBR))'="^" Q
9227
"RTN","XWBRW",55,0)
9228
. S I=$G(XWBR) Q:I="" S T=$E(I,1,$L(I)-1)
9229
"RTN","XWBRW",56,0)
9230
. ;Only send root node if non-null.
9231
"RTN","XWBRW",57,0)
9232
. I $D(@I)>10 S D=@I I $L(D) D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
9233
"RTN","XWBRW",58,0)
9234
. F S I=$Q(@I) Q:I=""!(I'[T) S D=@I D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
9235
"RTN","XWBRW",59,0)
9236
. I $D(@XWBR) K @XWBR
9237
"RTN","XWBRW",60,0)
9238
; -- global instance
9239
"RTN","XWBRW",61,0)
9240
I XWBPTYPE=5 D Q
9241
"RTN","XWBRW",62,0)
9242
. I $E($G(XWBR))'="^" Q
9243
"RTN","XWBRW",63,0)
9244
. S XWBR=$G(@XWBR) D WRITE(XWBR) Q
9245
"RTN","XWBRW",64,0)
9246
; -- variable length records only good upto 255 char)
9247
"RTN","XWBRW",65,0)
9248
I XWBPTYPE=6 D
9249
"RTN","XWBRW",66,0)
9250
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE($C($L(XWBR(I)))),WRITE(XWBR(I))
9251
"RTN","XWBRW",67,0)
9252
Q
9253
"RTN","XWBRW",68,0)
9254
;
9255
"RTN","XWBRW",69,0)
9256
SNDERR ;send error information
9257
"RTN","XWBRW",70,0)
9258
;XWBSEC is the security packet, XWBERROR is application packet
9259
"RTN","XWBRW",71,0)
9260
N X
9261
"RTN","XWBRW",72,0)
9262
S $X=0 ;Start with zero
9263
"RTN","XWBRW",73,0)
9264
S X=$E($G(XWBSEC),1,255)
9265
"RTN","XWBRW",74,0)
9266
D WRITE($C($L(X))_X)
9267
"RTN","XWBRW",75,0)
9268
S X=$E($G(XWBERROR),1,255)
9269
"RTN","XWBRW",76,0)
9270
D WRITE($C($L(X))_X)
9271
"RTN","XWBRW",77,0)
9272
S XWBERROR="",XWBSEC="" ;clears parameters
9273
"RTN","XWBRW",78,0)
9274
Q
9275
"RTN","XWBRW",79,0)
9276
;
9277
"RTN","XWBRW",80,0)
9278
WRITE(STR) ;Write a data string
9279
"RTN","XWBRW",81,0)
9280
; send data for DSM (requires buffer flush (!) every 511 chars)
9281
"RTN","XWBRW",82,0)
9282
;IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM) next line
9283
"RTN","XWBRW",83,0)
9284
F Q:'$L(STR) D
9285
"RTN","XWBRW",84,0)
9286
. I $L(XWBSBUF)+$L(STR)>240 D WBF
9287
"RTN","XWBRW",85,0)
9288
. S XWBSBUF=XWBSBUF_$E(STR,1,255),STR=$E(STR,256,99999)
9289
"RTN","XWBRW",86,0)
9290
Q
9291
"RTN","XWBRW",87,0)
9292
WBF ;Write Buffer Flush
9293
"RTN","XWBRW",88,0)
9294
Q:'$L(XWBSBUF)
9295
"RTN","XWBRW",89,0)
9296
I $G(XWBDEBUG)>2,$L(XWBSBUF) D LOG^XWBDLOG("wrt ("_$L(XWBSBUF)_"): "_$E(XWBSBUF,1,247))
9297
"RTN","XWBRW",90,0)
9298
W XWBSBUF,@XWBT("BF")
9299
"RTN","XWBRW",91,0)
9300
S XWBSBUF=""
9301
"RTN","XWBRW",92,0)
9302
Q
9303
"RTN","XWBSEC")
9304
0^51^B5872236
9305
"RTN","XWBSEC",1,0)
9306
XWBSEC ;SFISC/VYD,MSC/JDA - RPC BROKER ;06AUG2009
9307
"RTN","XWBSEC",2,0)
9308
;;1.1;RPC BROKER;**3,6,10,35,MSC**;Mar 28, 1997
9309
"RTN","XWBSEC",3,0)
9310
CHKPRMIT(XWBRP) ;checks to see if remote procedure is permited to run
9311
"RTN","XWBSEC",4,0)
9312
;Input: XWBRP - Remote procedure to check
9313
"RTN","XWBSEC",5,0)
9314
Q:$$KCHK^XUSRB("XUPROGMODE")
9315
"RTN","XWBSEC",6,0)
9316
N ERR,XWBPRMIT,XWBALLOW
9317
"RTN","XWBSEC",7,0)
9318
S U="^",XWBSEC="" ;Return XWBSEC="" if OK to run RPC
9319
"RTN","XWBSEC",8,0)
9320
;
9321
"RTN","XWBSEC",9,0)
9322
;In the beginning, when no DUZ is defined and no context exist, setup
9323
"RTN","XWBSEC",10,0)
9324
;default signon context
9325
"RTN","XWBSEC",11,0)
9326
I '$G(DUZ) S DUZ=0,XQY0="XUS SIGNON" D CRCONTXT(.ERR,$$ENCRYP^XUSRB1(XQY0)) ;set up default context
9327
"RTN","XWBSEC",12,0)
9328
;
9329
"RTN","XWBSEC",13,0)
9330
;These RPC's are allowed in any context, so we can just quit
9331
"RTN","XWBSEC",14,0)
9332
I "^XWB IM HERE^XWB CREATE CONTEXT^XWB RPC LIST^XWB IS RPC AVAILABLE^XUS GET USER INFO^XUS GET TOKEN^"[(U_XWBRP_U) Q
9333
"RTN","XWBSEC",15,0)
9334
;VistAlink RPC's that are always allowed.
9335
"RTN","XWBSEC",16,0)
9336
I "^XUS KAAJEE GET USER INFO^XUS KAAJEE LOGOUT^"[(U_XWBRP_U) Q
9337
"RTN","XWBSEC",17,0)
9338
;
9339
"RTN","XWBSEC",18,0)
9340
;If in Signon context, only allow XUS and XWB rpc's
9341
"RTN","XWBSEC",19,0)
9342
I $G(XQY0)="XUS SIGNON","^XUS^XWB^"'[(U_$E(XWBRP,1,3)_U) S XWBSEC="Application context has not been created!" Q
9343
"RTN","XWBSEC",20,0)
9344
;XQCS allows all users access to the XUS SIGNON context.
9345
"RTN","XWBSEC",21,0)
9346
;Also to any context in the XUCOMMAND menu.
9347
"RTN","XWBSEC",22,0)
9348
;
9349
"RTN","XWBSEC",23,0)
9350
I $G(XQY0)'="" D ;1.1*6. XQY0="" after XUS SIGNON context deleted.
9351
"RTN","XWBSEC",24,0)
9352
. S XWBALLOW=$$CHK^XQCS(DUZ,$P(XQY0,U),XWBRP) ;do the check
9353
"RTN","XWBSEC",25,0)
9354
. S:'XWBALLOW XWBSEC=XWBALLOW
9355
"RTN","XWBSEC",26,0)
9356
E S XWBSEC="Application context has not been created!"
9357
"RTN","XWBSEC",27,0)
9358
Q
9359
"RTN","XWBSEC",28,0)
9360
;
9361
"RTN","XWBSEC",29,0)
9362
;
9363
"RTN","XWBSEC",30,0)
9364
CRCONTXT(RESULT,OPTION) ;creates context for the passed in option
9365
"RTN","XWBSEC",31,0)
9366
K XQY0,XQY N XWB1,XABPGMOD,XWBPGMOD S RESULT=0
9367
"RTN","XWBSEC",32,0)
9368
S OPTION=$$DECRYP^XUSRB1(OPTION) ;S:OPTION="" OPTION="\"
9369
"RTN","XWBSEC",33,0)
9370
I OPTION="" S XQY=0,XQY0="",RESULT=1 K ^TMP("XQCS",$J) Q ;delete context if "" passed in.
9371
"RTN","XWBSEC",34,0)
9372
S XWB1=$$OPTLK^XQCS(OPTION)
9373
"RTN","XWBSEC",35,0)
9374
I XWB1="" S (XWBSEC,RESULT)="The context '"_OPTION_"' does not exist on server." Q ;P10
9375
"RTN","XWBSEC",36,0)
9376
S RESULT=$$CHK^XQCS(DUZ,XWB1)
9377
"RTN","XWBSEC",37,0)
9378
;Access or programmer
9379
"RTN","XWBSEC",38,0)
9380
S XWBPGMOD=$$KCHK^XUSRB("XUPROGMODE")
9381
"RTN","XWBSEC",39,0)
9382
I RESULT!XWBPGMOD S XQY0=OPTION,XQY=XWB1,RESULT=1
9383
"RTN","XWBSEC",40,0)
9384
E S XWBSEC=RESULT
9385
"RTN","XWBSEC",41,0)
9386
Q
9387
"RTN","XWBSEC",42,0)
9388
;
9389
"RTN","XWBSEC",43,0)
9390
;
9391
"RTN","XWBSEC",44,0)
9392
STATE(%) ;Return a state value
9393
"RTN","XWBSEC",45,0)
9394
Q:'$L($G(%)) $G(XWBSTATE)
9395
"RTN","XWBSEC",46,0)
9396
Q $G(XWBSTATE(%))
9397
"RTN","XWBSEC",47,0)
9398
;
9399
"RTN","XWBSEC",48,0)
9400
;
9401
"RTN","XWBSEC",49,0)
9402
SET(%,VALUE) ;Set the state variable
9403
"RTN","XWBSEC",50,0)
9404
I $G(%)="" S XWBSTATE=VALUE
9405
"RTN","XWBSEC",51,0)
9406
S XWBSTATE(%)=VALUE
9407
"RTN","XWBSEC",52,0)
9408
Q
9409
"RTN","XWBSEC",53,0)
9410
KILL(%) ;Kill state variable
9411
"RTN","XWBSEC",54,0)
9412
I $L($G(%)) K XWBSTATE(%)
9413
"RTN","XWBSEC",55,0)
9414
Q
9415
"RTN","XWBTCPM")
9416
0^23^B56922128
9417
"RTN","XWBTCPM",1,0)
9418
XWBTCPM ;ISF/RWF MSC/JDA - BROKER TCP/IP PROCESS HANDLER ;13APR2009
9419
"RTN","XWBTCPM",2,0)
9420
;;1.1;RPC BROKER;**35,43,MSC**;Mar 28, 1997
9421
"RTN","XWBTCPM",3,0)
9422
;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF
9423
"RTN","XWBTCPM",4,0)
9424
;Changed to be started by UCX or %ZISTCPS
9425
"RTN","XWBTCPM",5,0)
9426
;
9427
"RTN","XWBTCPM",6,0)
9428
;MSC/JDA 04/13/09 - Added MOREREADTIME to GT.M init
9429
"RTN","XWBTCPM",7,0)
9430
;
9431
"RTN","XWBTCPM",8,0)
9432
DSM ;DSM called from ucx, % passed in with device.
9433
"RTN","XWBTCPM",9,0)
9434
D ESET
9435
"RTN","XWBTCPM",10,0)
9436
;Open the device
9437
"RTN","XWBTCPM",11,0)
9438
S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
9439
"RTN","XWBTCPM",12,0)
9440
;Go find the connection type
9441
"RTN","XWBTCPM",13,0)
9442
U XWBTDEV
9443
"RTN","XWBTCPM",14,0)
9444
G CONNTYPE
9445
"RTN","XWBTCPM",15,0)
9446
;
9447
"RTN","XWBTCPM",16,0)
9448
CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
9449
"RTN","XWBTCPM",17,0)
9450
D ESET
9451
"RTN","XWBTCPM",18,0)
9452
S XWBTDEV="SYS$NET"
9453
"RTN","XWBTCPM",19,0)
9454
; **Cache'/VMS specific code**
9455
"RTN","XWBTCPM",20,0)
9456
O XWBTDEV::5
9457
"RTN","XWBTCPM",21,0)
9458
X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
9459
"RTN","XWBTCPM",22,0)
9460
G CONNTYPE
9461
"RTN","XWBTCPM",23,0)
9462
;
9463
"RTN","XWBTCPM",24,0)
9464
NT ;entry from ZISTCPS
9465
"RTN","XWBTCPM",25,0)
9466
;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
9467
"RTN","XWBTCPM",26,0)
9468
D ESET
9469
"RTN","XWBTCPM",27,0)
9470
S XWBTDEV=IO
9471
"RTN","XWBTCPM",28,0)
9472
G CONNTYPE
9473
"RTN","XWBTCPM",29,0)
9474
;
9475
"RTN","XWBTCPM",30,0)
9476
GTMUCX(%) ;From ucx ZFOO
9477
"RTN","XWBTCPM",31,0)
9478
;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
9479
"RTN","XWBTCPM",32,0)
9480
D ESET
9481
"RTN","XWBTCPM",33,0)
9482
S $ZTRAP=""
9483
"RTN","XWBTCPM",34,0)
9484
;GTM specific code
9485
"RTN","XWBTCPM",35,0)
9486
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
9487
"RTN","XWBTCPM",36,0)
9488
S XWBTDEV=% X "O %:(RECORDSIZE=512)"
9489
"RTN","XWBTCPM",37,0)
9490
G CONNTYPE
9491
"RTN","XWBTCPM",38,0)
9492
;
9493
"RTN","XWBTCPM",39,0)
9494
GTMLNX ;From Linux xinetd script
9495
"RTN","XWBTCPM",40,0)
9496
D ESET
9497
"RTN","XWBTCPM",41,0)
9498
S $ZTRAP=""
9499
"RTN","XWBTCPM",42,0)
9500
;GTM specific code
9501
"RTN","XWBTCPM",43,0)
9502
S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
9503
"RTN","XWBTCPM",44,0)
9504
S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter)"
9505
"RTN","XWBTCPM",45,0)
9506
S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
9507
"RTN","XWBTCPM",46,0)
9508
G CONNTYPE
9509
"RTN","XWBTCPM",47,0)
9510
;
9511
"RTN","XWBTCPM",48,0)
9512
ESET ;Set inital error trap
9513
"RTN","XWBTCPM",49,0)
9514
S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
9515
"RTN","XWBTCPM",50,0)
9516
Q
9517
"RTN","XWBTCPM",51,0)
9518
;Find the type of connection and jump to the processing routine.
9519
"RTN","XWBTCPM",52,0)
9520
CONNTYPE ;
9521
"RTN","XWBTCPM",53,0)
9522
N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
9523
"RTN","XWBTCPM",54,0)
9524
N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
9525
"RTN","XWBTCPM",55,0)
9526
N SOCK,TYPE
9527
"RTN","XWBTCPM",56,0)
9528
D INIT
9529
"RTN","XWBTCPM",57,0)
9530
S XWB=$$BREAD^XWBRW(5,XWBTIME)
9531
"RTN","XWBTCPM",58,0)
9532
D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",1:"Unk"))
9533
"RTN","XWBTCPM",59,0)
9534
I XWB["[XWB]" G NEW
9535
"RTN","XWBTCPM",60,0)
9536
I XWB["{XWB}" G OLD^XWBTCPM1
9537
"RTN","XWBTCPM",61,0)
9538
I XWB["<?xml" G M2M
9539
"RTN","XWBTCPM",62,0)
9540
I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
9541
"RTN","XWBTCPM",63,0)
9542
D LOG("Prefix not known: "_XWB)
9543
"RTN","XWBTCPM",64,0)
9544
Q
9545
"RTN","XWBTCPM",65,0)
9546
;
9547
"RTN","XWBTCPM",66,0)
9548
NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
9549
"RTN","XWBTCPM",67,0)
9550
N X,Y,J,XWBVOL
9551
"RTN","XWBTCPM",68,0)
9552
D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
9553
"RTN","XWBTCPM",69,0)
9554
S X=$O(^XTV(8989.3,1,4,"B",XWBVOL,0)),J=$S(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1")
9555
"RTN","XWBTCPM",70,0)
9556
I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
9557
"RTN","XWBTCPM",71,0)
9558
I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
9559
"RTN","XWBTCPM",72,0)
9560
Q 1
9561
"RTN","XWBTCPM",73,0)
9562
;
9563
"RTN","XWBTCPM",74,0)
9564
M2M ;M2M Broker
9565
"RTN","XWBTCPM",75,0)
9566
S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
9567
"RTN","XWBTCPM",76,0)
9568
Q
9569
"RTN","XWBTCPM",77,0)
9570
;
9571
"RTN","XWBTCPM",78,0)
9572
NEW ;New broker
9573
"RTN","XWBTCPM",79,0)
9574
S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
9575
"RTN","XWBTCPM",80,0)
9576
D SETTIME(1) ;Setup for sign-on timeout
9577
"RTN","XWBTCPM",81,0)
9578
U XWBTDEV D
9579
"RTN","XWBTCPM",82,0)
9580
. N XWB,ERR,NATIP,I
9581
"RTN","XWBTCPM",83,0)
9582
. S ERR=$$PRSP^XWBPRS
9583
"RTN","XWBTCPM",84,0)
9584
. S ERR=$$PRSM^XWBPRS
9585
"RTN","XWBTCPM",85,0)
9586
. S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
9587
"RTN","XWBTCPM",86,0)
9588
. S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I)
9589
"RTN","XWBTCPM",87,0)
9590
. ;Get the peer and save that IP.
9591
"RTN","XWBTCPM",88,0)
9592
. S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
9593
"RTN","XWBTCPM",89,0)
9594
. I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
9595
"RTN","XWBTCPM",90,0)
9596
. Q
9597
"RTN","XWBTCPM",91,0)
9598
S X=$$NEWJOB() D:'X LOG("No New Connects")
9599
"RTN","XWBTCPM",92,0)
9600
I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
9601
"RTN","XWBTCPM",93,0)
9602
D QSND^XWBRW("accept"),LOG("accept") ;Ack
9603
"RTN","XWBTCPM",94,0)
9604
S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
9605
"RTN","XWBTCPM",95,0)
9606
S XWBTIP=$G(IO("IP"))
9607
"RTN","XWBTCPM",96,0)
9608
;start RUM for Broker Handler XWB*1.1*5
9609
"RTN","XWBTCPM",97,0)
9610
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
9611
"RTN","XWBTCPM",98,0)
9612
;GTM
9613
"RTN","XWBTCPM",99,0)
9614
I $G(XWBT("PCNT")) D
9615
"RTN","XWBTCPM",100,0)
9616
. S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
9617
"RTN","XWBTCPM",101,0)
9618
. D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
9619
"RTN","XWBTCPM",102,0)
9620
;We don't use a callback
9621
"RTN","XWBTCPM",103,0)
9622
K XWB,CON,LEN,MSG ;Clean up
9623
"RTN","XWBTCPM",104,0)
9624
;Attempt to share license, Must have TCP port open first.
9625
"RTN","XWBTCPM",105,0)
9626
U XWBTDEV ;D SHARELIC^%ZOSV(1)
9627
"RTN","XWBTCPM",106,0)
9628
;setup null device "NULL"
9629
"RTN","XWBTCPM",107,0)
9630
S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER,EXIT Q
9631
"RTN","XWBTCPM",108,0)
9632
D SAVDEV^%ZISUTL("XWBNULL")
9633
"RTN","XWBTCPM",109,0)
9634
;change process name
9635
"RTN","XWBTCPM",110,0)
9636
D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
9637
"RTN","XWBTCPM",111,0)
9638
;
9639
"RTN","XWBTCPM",112,0)
9640
RESTART ;The error trap returns to here
9641
"RTN","XWBTCPM",113,0)
9642
N $ESTACK S $ETRAP="D ETRAP^XWBTCPM"
9643
"RTN","XWBTCPM",114,0)
9644
S DT=$$DT^XLFDT,DTIME=30
9645
"RTN","XWBTCPM",115,0)
9646
U XWBTDEV D MAIN
9647
"RTN","XWBTCPM",116,0)
9648
D LOG("Exit: "_XWBTBUF)
9649
"RTN","XWBTCPM",117,0)
9650
;Turn off the error trap for the exit
9651
"RTN","XWBTCPM",118,0)
9652
S $ETRAP=""
9653
"RTN","XWBTCPM",119,0)
9654
D EXIT ;Logout
9655
"RTN","XWBTCPM",120,0)
9656
K XWBR,XWBARY
9657
"RTN","XWBTCPM",121,0)
9658
;stop RUM for handler XWB*1.1*5
9659
"RTN","XWBTCPM",122,0)
9660
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
9661
"RTN","XWBTCPM",123,0)
9662
D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
9663
"RTN","XWBTCPM",124,0)
9664
;Close in the calling script
9665
"RTN","XWBTCPM",125,0)
9666
K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
9667
"RTN","XWBTCPM",126,0)
9668
Q
9669
"RTN","XWBTCPM",127,0)
9670
;
9671
"RTN","XWBTCPM",128,0)
9672
MAIN ; -- main message processing loop. debug at MAIN+1
9673
"RTN","XWBTCPM",129,0)
9674
F D Q:XWBTBUF="#BYE#"
9675
"RTN","XWBTCPM",130,0)
9676
. ;Setup
9677
"RTN","XWBTCPM",131,0)
9678
. S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
9679
"RTN","XWBTCPM",132,0)
9680
. K XWBR,XWBARY,XWBPRT
9681
"RTN","XWBTCPM",133,0)
9682
. ; -- read client request
9683
"RTN","XWBTCPM",134,0)
9684
. S XR=$$BREAD^XWBRW(1,XWBTIME,1)
9685
"RTN","XWBTCPM",135,0)
9686
. I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
9687
"RTN","XWBTCPM",136,0)
9688
. S XR=XR_$$BREAD^XWBRW(4)
9689
"RTN","XWBTCPM",137,0)
9690
. I XR="#BYE#" D Q ;Check for exit
9691
"RTN","XWBTCPM",138,0)
9692
. . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
9693
"RTN","XWBTCPM",139,0)
9694
. . Q
9695
"RTN","XWBTCPM",140,0)
9696
. S TYPE=(XR="[XWB]") ;check HDR
9697
"RTN","XWBTCPM",141,0)
9698
. I 'TYPE D LOG("Bad Header: "_XR) Q
9699
"RTN","XWBTCPM",142,0)
9700
. D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
9701
"RTN","XWBTCPM",143,0)
9702
. IF XWBTCMD="#BYE#" D Q
9703
"RTN","XWBTCPM",144,0)
9704
. . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
9705
"RTN","XWBTCPM",145,0)
9706
. . Q
9707
"RTN","XWBTCPM",146,0)
9708
. U XWBTDEV
9709
"RTN","XWBTCPM",147,0)
9710
. S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
9711
"RTN","XWBTCPM",148,0)
9712
. ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return
9713
"RTN","XWBTCPM",149,0)
9714
. I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
9715
"RTN","XWBTCPM",150,0)
9716
Q ;End Of Main
9717
"RTN","XWBTCPM",151,0)
9718
;
9719
"RTN","XWBTCPM",152,0)
9720
;
9721
"RTN","XWBTCPM",153,0)
9722
ETRAP ; -- on trapped error, send error info to client
9723
"RTN","XWBTCPM",154,0)
9724
N XWBERC,XWBERR
9725
"RTN","XWBTCPM",155,0)
9726
;Change trapping during trap.
9727
"RTN","XWBTCPM",156,0)
9728
S $ETRAP="D ^%ZTER,EXIT^XWBTCPM HALT"
9729
"RTN","XWBTCPM",157,0)
9730
S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
9731
"RTN","XWBTCPM",158,0)
9732
I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
9733
"RTN","XWBTCPM",159,0)
9734
D ^%ZTER ;%ZTER clears $ZE and $ZCODE
9735
"RTN","XWBTCPM",160,0)
9736
D LOG("In ETRAP: "_XWBERC) ;Log
9737
"RTN","XWBTCPM",161,0)
9738
I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F") D EXIT HALT
9739
"RTN","XWBTCPM",162,0)
9740
U XWBTDEV
9741
"RTN","XWBTCPM",163,0)
9742
I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0)
9743
"RTN","XWBTCPM",164,0)
9744
E L ;Clear Locks
9745
"RTN","XWBTCPM",165,0)
9746
;I XWBOS'="DSM" D
9747
"RTN","XWBTCPM",166,0)
9748
S XWBPTYPE=1 ;So SNDERR won't check XWBR
9749
"RTN","XWBTCPM",167,0)
9750
;D SNDERR^XWBRW,WRITE^XWBRW($C(24)_XWBERR_$C(4))
9751
"RTN","XWBTCPM",168,0)
9752
D ESND^XWBRW($C(24)_XWBERR_$C(4))
9753
"RTN","XWBTCPM",169,0)
9754
S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
9755
"RTN","XWBTCPM",170,0)
9756
Q
9757
"RTN","XWBTCPM",171,0)
9758
;
9759
"RTN","XWBTCPM",172,0)
9760
CLEANP ;Clean up the partion
9761
"RTN","XWBTCPM",173,0)
9762
N XWBTDEV,XWBNULL D KILL^XUSCLEAN
9763
"RTN","XWBTCPM",174,0)
9764
Q
9765
"RTN","XWBTCPM",175,0)
9766
;
9767
"RTN","XWBTCPM",176,0)
9768
STYPE(X,WRAP) ;For backward compatability only
9769
"RTN","XWBTCPM",177,0)
9770
I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
9771
"RTN","XWBTCPM",178,0)
9772
Q $$RTRNFMT^XWBLIB(X)
9773
"RTN","XWBTCPM",179,0)
9774
;
9775
"RTN","XWBTCPM",180,0)
9776
BREAD(L,T) ;read tcp buffer, L is length
9777
"RTN","XWBTCPM",181,0)
9778
Q $$BREAD^XWBRW(L,$G(T))
9779
"RTN","XWBTCPM",182,0)
9780
;
9781
"RTN","XWBTCPM",183,0)
9782
CHPRN(N) ;change process name
9783
"RTN","XWBTCPM",184,0)
9784
;Change process name to N
9785
"RTN","XWBTCPM",185,0)
9786
D SETNM^%ZOSV($E(N,1,15))
9787
"RTN","XWBTCPM",186,0)
9788
Q
9789
"RTN","XWBTCPM",187,0)
9790
;
9791
"RTN","XWBTCPM",188,0)
9792
SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
9793
"RTN","XWBTCPM",189,0)
9794
S XWBTIME=$S($G(%):90,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=2
9795
"RTN","XWBTCPM",190,0)
9796
I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
9797
"RTN","XWBTCPM",191,0)
9798
Q
9799
"RTN","XWBTCPM",192,0)
9800
TIMEOUT ;Do this on MAIN loop timeout
9801
"RTN","XWBTCPM",193,0)
9802
I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
9803
"RTN","XWBTCPM",194,0)
9804
;Sign-on timeout
9805
"RTN","XWBTCPM",195,0)
9806
S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
9807
"RTN","XWBTCPM",196,0)
9808
D SND^XWBRW
9809
"RTN","XWBTCPM",197,0)
9810
Q
9811
"RTN","XWBTCPM",198,0)
9812
;
9813
"RTN","XWBTCPM",199,0)
9814
OS() ;Return the OS
9815
"RTN","XWBTCPM",200,0)
9816
Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",^("OS")["GT.M":"GTM",1:"MSM")
9817
"RTN","XWBTCPM",201,0)
9818
;
9819
"RTN","XWBTCPM",202,0)
9820
INIT ;Setup
9821
"RTN","XWBTCPM",203,0)
9822
S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
9823
"RTN","XWBTCPM",204,0)
9824
S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
9825
"RTN","XWBTCPM",205,0)
9826
S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
9827
"RTN","XWBTCPM",206,0)
9828
X:$D(XWBTDEV)&(XWBOS="GTM") "U XWBTDEV:(MOREREADTIME=999)"
9829
"RTN","XWBTCPM",207,0)
9830
S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
9831
"RTN","XWBTCPM",208,0)
9832
D LOGSTART^XWBDLOG("XWBTCPM")
9833
"RTN","XWBTCPM",209,0)
9834
Q
9835
"RTN","XWBTCPM",210,0)
9836
;
9837
"RTN","XWBTCPM",211,0)
9838
DEBUG ;Entry point for debug, Build a server to get the connect
9839
"RTN","XWBTCPM",212,0)
9840
;DSM sample;ZDEBUG ON S $ZB(1)="SERV+1^XWBTCPM:1",$ZB="ETRAP+1^XWBTCPM:1"
9841
"RTN","XWBTCPM",213,0)
9842
W !,"Before running this entry point set your debugger to stop at"
9843
"RTN","XWBTCPM",214,0)
9844
W !,"the place you want to debug. Some spots to use:"
9845
"RTN","XWBTCPM",215,0)
9846
W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
9847
"RTN","XWBTCPM",216,0)
9848
W !,"or location of your choice.",!
9849
"RTN","XWBTCPM",217,0)
9850
W !,"IP Socket to Listen on: " R SOCK:300 Q:'$T!(SOCK["^")
9851
"RTN","XWBTCPM",218,0)
9852
;Use %ZISTCP to do a single server
9853
"RTN","XWBTCPM",219,0)
9854
D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
9855
"RTN","XWBTCPM",220,0)
9856
U $P W !,"Done"
9857
"RTN","XWBTCPM",221,0)
9858
Q
9859
"RTN","XWBTCPM",222,0)
9860
SERV ;Callback from the server
9861
"RTN","XWBTCPM",223,0)
9862
S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
9863
"RTN","XWBTCPM",224,0)
9864
S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
9865
"RTN","XWBTCPM",225,0)
9866
D NEW
9867
"RTN","XWBTCPM",226,0)
9868
S IO("C")=1 ;Cause the Listenr to stop
9869
"RTN","XWBTCPM",227,0)
9870
Q
9871
"RTN","XWBTCPM",228,0)
9872
;
9873
"RTN","XWBTCPM",229,0)
9874
EXIT ;Close out
9875
"RTN","XWBTCPM",230,0)
9876
I $G(DUZ) D LOGOUT^XUSRB
9877
"RTN","XWBTCPM",231,0)
9878
I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
9879
"RTN","XWBTCPM",232,0)
9880
Q
9881
"RTN","XWBTCPM",233,0)
9882
;
9883
"RTN","XWBTCPM",234,0)
9884
LOG(MSG) ;Record Debug Info
9885
"RTN","XWBTCPM",235,0)
9886
D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
9887
"RTN","XWBTCPM",236,0)
9888
Q
9889
"RTN","XWBTCPM",237,0)
9890
;
9891
"RTN","ZCD")
9892
0^11^B27561610
9893
"RTN","ZCD",1,0)
9894
ZCD ; MSC/JKT,JDS ; "Namespace" utilities for GT.M/Unix ; 5DEC2009
9895
"RTN","ZCD",2,0)
9896
;;8.0;KERNEL;**MSC**;April 21 2009
9897
"RTN","ZCD",3,0)
9898
; This routine assumes that your global directory file exists one
9899
"RTN","ZCD",4,0)
9900
; directory below the root of the instance, e.g.,
9901
"RTN","ZCD",5,0)
9902
;
9903
"RTN","ZCD",6,0)
9904
; /opt/openvista/instance/globals/mumps.gld
9905
"RTN","ZCD",7,0)
9906
;
9907
"RTN","ZCD",8,0)
9908
; or
9909
"RTN","ZCD",9,0)
9910
;
9911
"RTN","ZCD",10,0)
9912
; /home/vista/instance/g/default.gld
9913
"RTN","ZCD",11,0)
9914
;
9915
"RTN","ZCD",12,0)
9916
; The actual file name of the global directory file and the actual name
9917
"RTN","ZCD",13,0)
9918
; of the parent directory are never checked, so their names do not
9919
"RTN","ZCD",14,0)
9920
; matter.
9921
"RTN","ZCD",15,0)
9922
;
9923
"RTN","ZCD",16,0)
9924
CD ; interactive
9925
"RTN","ZCD",17,0)
9926
N Y,DIR
9927
"RTN","ZCD",18,0)
9928
S:'$D(DTIME) DTIME=300
9929
"RTN","ZCD",19,0)
9930
R !,"Namespace: ",DIR:DTIME
9931
"RTN","ZCD",20,0)
9932
I DIR["^"!(DIR="") Q
9933
"RTN","ZCD",21,0)
9934
D LIST
9935
"RTN","ZCD",22,0)
9936
I DIR["?" G HELP
9937
"RTN","ZCD",23,0)
9938
I '$D(Y("B",DIR)) W !,"Invalid Namespace" G CD
9939
"RTN","ZCD",24,0)
9940
I $$GTMPATH($$CURRENT())'=$$GTMPATH(DIR) W !,"Inconsistent GTM versions",! G CD
9941
"RTN","ZCD",25,0)
9942
S A=$$SWITCH(DIR)
9943
"RTN","ZCD",26,0)
9944
Q
9945
"RTN","ZCD",27,0)
9946
;
9947
"RTN","ZCD",28,0)
9948
HELP N A S A=""
9949
"RTN","ZCD",29,0)
9950
F S A=$O(Y("B",A)) Q:A="" W !,A
9951
"RTN","ZCD",30,0)
9952
W ! G CD
9953
"RTN","ZCD",31,0)
9954
Q
9955
"RTN","ZCD",32,0)
9956
;
9957
"RTN","ZCD",33,0)
9958
ROOT() ; return path where all OpenVista instances live
9959
"RTN","ZCD",34,0)
9960
Q $P($ZG,"/",1,$L($ZG,"/")-3)
9961
"RTN","ZCD",35,0)
9962
;
9963
"RTN","ZCD",36,0)
9964
CURRENT() ; return name of the current OpenVista instance
9965
"RTN","ZCD",37,0)
9966
Q $P($ZG,"/",$L($ZG,"/")-2)
9967
"RTN","ZCD",38,0)
9968
;
9969
"RTN","ZCD",39,0)
9970
PATH(INSTANCE) ; return path to an OpenVista instance
9971
"RTN","ZCD",40,0)
9972
Q $$ROOT()_"/"_INSTANCE
9973
"RTN","ZCD",41,0)
9974
;
9975
"RTN","ZCD",42,0)
9976
GTMPATH(INSTANCE) ; return the path to the version of GT.M this instance uses
9977
"RTN","ZCD",43,0)
9978
N %PATH,%PIPE,%I
9979
"RTN","ZCD",44,0)
9980
S %I=$I
9981
"RTN","ZCD",45,0)
9982
S %PIPE="ovgetvar"
9983
"RTN","ZCD",46,0)
9984
O %PIPE:(COMMAND="ovgetvar "_INSTANCE_" gtm_path 2> /dev/null":READONLY)::"PIPE" U %PIPE
9985
"RTN","ZCD",47,0)
9986
R %PATH
9987
"RTN","ZCD",48,0)
9988
C %PIPE
9989
"RTN","ZCD",49,0)
9990
I %PATH'="" U %I Q %PATH
9991
"RTN","ZCD",50,0)
9992
S %PIPE="readlink"
9993
"RTN","ZCD",51,0)
9994
O %PIPE:(COMMAND="readlink "_$$PATH(INSTANCE)_"/gtm":READONLY)::"PIPE" U %PIPE
9995
"RTN","ZCD",52,0)
9996
R %PATH
9997
"RTN","ZCD",53,0)
9998
C %PIPE
9999
"RTN","ZCD",54,0)
10000
U %I Q %PATH
10001
"RTN","ZCD",55,0)
10002
;
10003
"RTN","ZCD",56,0)
10004
LIST ; return an array (Y) of OpenVista instances on this system
10005
"RTN","ZCD",57,0)
10006
N %PIPE,%I S %PIPE="ls",%I=$I
10007
"RTN","ZCD",58,0)
10008
O %PIPE:(COMMAND="ls --color=none -1 "_$$ROOT():READONLY)::"PIPE" U %PIPE
10009
"RTN","ZCD",59,0)
10010
N I,%NAME K Y
10011
"RTN","ZCD",60,0)
10012
F I=1:1 R %NAME Q:%NAME="" I $$GTMPATH(%NAME)'="" S Y(I)=%NAME,Y("B",%NAME)=""
10013
"RTN","ZCD",61,0)
10014
U %I
10015
"RTN","ZCD",62,0)
10016
C %PIPE
10017
"RTN","ZCD",63,0)
10018
Q
10019
"RTN","ZCD",64,0)
10020
;
10021
"RTN","ZCD",65,0)
10022
SWITCH(INSTANCE) ; switch to another OpenVista instance
10023
"RTN","ZCD",66,0)
10024
N %ZG,%ZRO D NEWZGZRO(INSTANCE) I %ZG="",%ZRO="" Q 0
10025
"RTN","ZCD",67,0)
10026
;
10027
"RTN","ZCD",68,0)
10028
N %TEMPDIR S %TEMPDIR=$$MKTEMP() S $ZG=%ZG,$ZRO=%ZRO_" "_%TEMPDIR
10029
"RTN","ZCD",69,0)
10030
N X,Y S X=INSTANCE X ^%ZOSF("UPPERCASE") S $ZPROMPT=Y_">"
10031
"RTN","ZCD",70,0)
10032
;
10033
"RTN","ZCD",71,0)
10034
; re-ZLINK routines that have been loaded in our current image
10035
"RTN","ZCD",72,0)
10036
X "Q" ; equivalent to ZGOTO so that you can recompile a routine you are using
10037
"RTN","ZCD",73,0)
10038
N %ROUTINE,%FILENAME S %ROUTINE=""
10039
"RTN","ZCD",74,0)
10040
NEXT F S %ROUTINE=$VIEW("rtnnext",%ROUTINE) Q:%ROUTINE="" D
10041
"RTN","ZCD",75,0)
10042
. I "^GTM$DMOD^ZCD^MSCXUS3A^XQ1^XUP^%MSCXUCI^%ZMSCXUCI^"[("^"_%ROUTINE_"^") Q ;do not try to recompile these
10043
"RTN","ZCD",76,0)
10044
. ;
10045
"RTN","ZCD",77,0)
10046
. ; The only % routines that we ship start with %Z; other % routines are allocated to the
10047
"RTN","ZCD",78,0)
10048
. ; vendor (GTM) and do not need to be recompiled (and may only have object code)
10049
"RTN","ZCD",79,0)
10050
. Q:$E(%ROUTINE)="%"&($E(%ROUTINE,2)'="Z")
10051
"RTN","ZCD",80,0)
10052
. ;
10053
"RTN","ZCD",81,0)
10054
. ; If the routine exists in the target instance, ZLINK it. This replaces the
10055
"RTN","ZCD",82,0)
10056
. ; old version in our current image with the new version from the target instance.
10057
"RTN","ZCD",83,0)
10058
. ; If the routine does not exist in the target instance, we have to "kill" the routine
10059
"RTN","ZCD",84,0)
10060
. ; in our current image by creating a dummy routine that throws a GTM-E-FILENOTFND error
10061
"RTN","ZCD",85,0)
10062
. ; and ZLINKing the dummy routine. See http://groups.google.com/group/Hardhats/msg/a213981e1503db79
10063
"RTN","ZCD",86,0)
10064
. S %FILENAME=$TR(%ROUTINE,"%","_")_".m"
10065
"RTN","ZCD",87,0)
10066
. K %ZR D SILENT^%RSEL(%ROUTINE) I '$D(%ZR(%ROUTINE)) D WRITEROU(%TEMPDIR_"/"_%FILENAME,%ROUTINE)
10067
"RTN","ZCD",88,0)
10068
. ZLINK %FILENAME
10069
"RTN","ZCD",89,0)
10070
;
10071
"RTN","ZCD",90,0)
10072
; cleanup and return
10073
"RTN","ZCD",91,0)
10074
S $ZRO=%ZRO ; remove temporary directory from $ZRO
10075
"RTN","ZCD",92,0)
10076
ZSY "rm -rf "_%TEMPDIR
10077
"RTN","ZCD",93,0)
10078
Q:'$Q
10079
"RTN","ZCD",94,0)
10080
Q 1
10081
"RTN","ZCD",95,0)
10082
;
10083
"RTN","ZCD",96,0)
10084
NEWZGZRO(INSTANCE) ; determine new values of $ZG and $ZRO
10085
"RTN","ZCD",97,0)
10086
S %ZG="",%ZRO=""
10087
"RTN","ZCD",98,0)
10088
;
10089
"RTN","ZCD",99,0)
10090
; don't allow switching if GT.M versions aren't the same
10091
"RTN","ZCD",100,0)
10092
Q:$$GTMPATH($$CURRENT())'=$$GTMPATH(INSTANCE)
10093
"RTN","ZCD",101,0)
10094
;
10095
"RTN","ZCD",102,0)
10096
; there are several ways to determine new values of $ZG and $ZRO
10097
"RTN","ZCD",103,0)
10098
; try each method until one succeeds
10099
"RTN","ZCD",104,0)
10100
N %METHOD F %METHOD="ENV","CAT","REP" D @("SWITCH"_%METHOD)(INSTANCE) Q:%ZG'=""&(%ZRO'="")
10101
"RTN","ZCD",105,0)
10102
Q
10103
"RTN","ZCD",106,0)
10104
;
10105
"RTN","ZCD",107,0)
10106
SWITCHENV(INSTANCE) ; private entry point
10107
"RTN","ZCD",108,0)
10108
; set new $ZG and $ZRO by parsing env file in target instance
10109
"RTN","ZCD",109,0)
10110
;
10111
"RTN","ZCD",110,0)
10112
N %PIPE,%I
10113
"RTN","ZCD",111,0)
10114
S %I=$I
10115
"RTN","ZCD",112,0)
10116
S %PIPE="ovgetvar_gtmgbldir"
10117
"RTN","ZCD",113,0)
10118
O %PIPE:(COMMAND="ovgetvar "_INSTANCE_" gtmgbldir 2> /dev/null":READONLY)::"PIPE" U %PIPE
10119
"RTN","ZCD",114,0)
10120
R %ZG
10121
"RTN","ZCD",115,0)
10122
C %PIPE
10123
"RTN","ZCD",116,0)
10124
S %PIPE="ovgetvar_gtmroutines"
10125
"RTN","ZCD",117,0)
10126
O %PIPE:(COMMAND="ovgetvar "_INSTANCE_" gtmroutines 2> /dev/null":READONLY)::"PIPE" U %PIPE
10127
"RTN","ZCD",118,0)
10128
R %ZRO
10129
"RTN","ZCD",119,0)
10130
C %PIPE
10131
"RTN","ZCD",120,0)
10132
U %I
10133
"RTN","ZCD",121,0)
10134
;
10135
"RTN","ZCD",122,0)
10136
; FIXME: check that %ZG actually exists and that all pieces of %ZRO exist
10137
"RTN","ZCD",123,0)
10138
Q
10139
"RTN","ZCD",124,0)
10140
;
10141
"RTN","ZCD",125,0)
10142
SWITCHCAT(INSTANCE) ; private entry point
10143
"RTN","ZCD",126,0)
10144
; set new $ZG and $ZRO by concatenating conventional names to $$ROOT.
10145
"RTN","ZCD",127,0)
10146
; NOTE: this code makes assumptions about the directory layout of the
10147
"RTN","ZCD",128,0)
10148
; OpenVista instance.
10149
"RTN","ZCD",129,0)
10150
;
10151
"RTN","ZCD",130,0)
10152
S %ZG=$$PATH(INSTANCE)_"/globals/mumps.gld"
10153
"RTN","ZCD",131,0)
10154
S %ZRO=$$PATH(INSTANCE)_"/objects("_$$PATH(INSTANCE)_"/routines) "_$$PATH(INSTANCE)_"/gtm"
10155
"RTN","ZCD",132,0)
10156
;
10157
"RTN","ZCD",133,0)
10158
; FIXME: check that %ZG actually exists and that all pieces of %ZRO exist
10159
"RTN","ZCD",134,0)
10160
Q
10161
"RTN","ZCD",135,0)
10162
;
10163
"RTN","ZCD",136,0)
10164
SWITCHREP(INSTANCE) ; private entry point
10165
"RTN","ZCD",137,0)
10166
; set new $ZG and $ZRO by replacing $$PATH($$CURRENT()) with $$PATH(INSTANCE)
10167
"RTN","ZCD",138,0)
10168
;
10169
"RTN","ZCD",139,0)
10170
; FIXME: implement this
10171
"RTN","ZCD",140,0)
10172
Q
10173
"RTN","ZCD",141,0)
10174
;
10175
"RTN","ZCD",142,0)
10176
MKTEMP() ; create a secure temporary directory, returns path to new directory
10177
"RTN","ZCD",143,0)
10178
N %PIPE,%I S %PIPE="mktemp",%I=$I
10179
"RTN","ZCD",144,0)
10180
O %PIPE:(COMMAND="mktemp -d -t .zcd.XXXXXXXXXX":READONLY)::"PIPE" U %PIPE
10181
"RTN","ZCD",145,0)
10182
N %TEMPDIR R %TEMPDIR
10183
"RTN","ZCD",146,0)
10184
U %I
10185
"RTN","ZCD",147,0)
10186
C %PIPE
10187
"RTN","ZCD",148,0)
10188
Q %TEMPDIR
10189
"RTN","ZCD",149,0)
10190
;
10191
"RTN","ZCD",150,0)
10192
WRITEROU(PATH,ROUTINE) ; write out dummy routine
10193
"RTN","ZCD",151,0)
10194
N %I S %I=$I
10195
"RTN","ZCD",152,0)
10196
O PATH:(NEWVERSION:NOREADONLY:VARIABLE) U PATH
10197
"RTN","ZCD",153,0)
10198
W ROUTINE,!
10199
"RTN","ZCD",154,0)
10200
W " ZMESSAGE 150374338:$PIECE($ZPOSITION,""^"",2)",!
10201
"RTN","ZCD",155,0)
10202
W " QUIT",!
10203
"RTN","ZCD",156,0)
10204
U %I
10205
"RTN","ZCD",157,0)
10206
C PATH
10207
"RTN","ZCD",158,0)
10208
Q
10209
"RTN","ZIS4GTM")
10210
0^5^B18512871
10211
"RTN","ZIS4GTM",1,0)
10212
%ZIS4 ;SFISC/AC,RWF,MVB MSC/JDS - DEVICE HANDLER SPECIFIC CODE (GT.M 4.3 for Unix/VMS) ;28MAY2009
10213
"RTN","ZIS4GTM",2,0)
10214
;;8.0;KERNEL;**275,MSC**;Jul 10, 1995;
10215
"RTN","ZIS4GTM",3,0)
10216
;
10217
"RTN","ZIS4GTM",4,0)
10218
OPEN G OPN2:$D(IO(1,IO))
10219
"RTN","ZIS4GTM",5,0)
10220
S POP=0 D OP1 G NOPEN:'$D(IO(1,IO))
10221
"RTN","ZIS4GTM",6,0)
10222
OPN2 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"")
10223
"RTN","ZIS4GTM",7,0)
10224
Q
10225
"RTN","ZIS4GTM",8,0)
10226
NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q
10227
"RTN","ZIS4GTM",9,0)
10228
I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
10229
"RTN","ZIS4GTM",10,0)
10230
S POP=1 Q
10231
"RTN","ZIS4GTM",11,0)
10232
Q
10233
"RTN","ZIS4GTM",12,0)
10234
OP1 S X="OPNERR^%ZIS4",@^%ZOSF("TRAP"),$ZE=""
10235
"RTN","ZIS4GTM",13,0)
10236
L:$D(%ZISLOCK) +@%ZISLOCK:60
10237
"RTN","ZIS4GTM",14,0)
10238
O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
10239
"RTN","ZIS4GTM",15,0)
10240
Q
10241
"RTN","ZIS4GTM",16,0)
10242
OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q
10243
"RTN","ZIS4GTM",17,0)
10244
;
10245
"RTN","ZIS4GTM",18,0)
10246
O D:%IS["L" ZIO
10247
"RTN","ZIS4GTM",19,0)
10248
LCKGBL ;Lock Global
10249
"RTN","ZIS4GTM",20,0)
10250
I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
10251
"RTN","ZIS4GTM",21,0)
10252
I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX
10253
"RTN","ZIS4GTM",22,0)
10254
OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
10255
"RTN","ZIS4GTM",23,0)
10256
I %ZTYPE="CHAN",IO["::""TASK="!(IO["SYS$NET") D ODECNET Q:POP G OXECUTE^%ZIS6
10257
"RTN","ZIS4GTM",24,0)
10258
S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
10259
"RTN","ZIS4GTM",25,0)
10260
N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
10261
"RTN","ZIS4GTM",26,0)
10262
S %A=%_$E(":",%A]"")_%A
10263
"RTN","ZIS4GTM",27,0)
10264
D O1 I POP D Q
10265
"RTN","ZIS4GTM",28,0)
10266
.I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q
10267
"RTN","ZIS4GTM",29,0)
10268
.W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
10269
"RTN","ZIS4GTM",30,0)
10270
;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
10271
"RTN","ZIS4GTM",31,0)
10272
U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
10273
"RTN","ZIS4GTM",32,0)
10274
I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
10275
"RTN","ZIS4GTM",33,0)
10276
;U:%IS'[0 IO(0)
10277
"RTN","ZIS4GTM",34,0)
10278
G OXECUTE^%ZIS6
10279
"RTN","ZIS4GTM",35,0)
10280
Q
10281
"RTN","ZIS4GTM",36,0)
10282
;
10283
"RTN","ZIS4GTM",37,0)
10284
O1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
10285
"RTN","ZIS4GTM",38,0)
10286
L:$D(%ZISLOCK) +@%ZISLOCK:60
10287
"RTN","ZIS4GTM",39,0)
10288
I %A["lpr" S IO="lpr",%A="IO:(COMMAND="_$P(%A,":")_":WRITEONLY)::""PIPE"""
10289
"RTN","ZIS4GTM",40,0)
10290
O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK
10291
"RTN","ZIS4GTM",41,0)
10292
S IO("ERROR")="" Q
10293
"RTN","ZIS4GTM",42,0)
10294
;
10295
"RTN","ZIS4GTM",43,0)
10296
;Need to find out how to get IP address
10297
"RTN","ZIS4GTM",44,0)
10298
ZIO N %,%1 S (%,%1)=$ZIO
10299
"RTN","ZIS4GTM",45,0)
10300
I $ZV["VMS",%["_TNA" D
10301
"RTN","ZIS4GTM",46,0)
10302
. X "S (%,%1)=$ZGETDVI($I,""TT_ACCPORNAM"")"
10303
"RTN","ZIS4GTM",47,0)
10304
. S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ")
10305
"RTN","ZIS4GTM",48,0)
10306
I $ZV'["VMS" D
10307
"RTN","ZIS4GTM",49,0)
10308
. S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO
10309
"RTN","ZIS4GTM",50,0)
10310
S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":")
10311
"RTN","ZIS4GTM",51,0)
10312
Q
10313
"RTN","ZIS4GTM",52,0)
10314
;
10315
"RTN","ZIS4GTM",53,0)
10316
ODECNET Q ; fill me in later
10317
"RTN","ZIS4GTM",54,0)
10318
SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name.
10319
"RTN","ZIS4GTM",55,0)
10320
I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N
10321
"RTN","ZIS4GTM",56,0)
10322
I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N
10323
"RTN","ZIS4GTM",57,0)
10324
R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
10325
"RTN","ZIS4GTM",58,0)
10326
G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC
10327
"RTN","ZIS4GTM",59,0)
10328
S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)=""
10329
"RTN","ZIS4GTM",60,0)
10330
DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#"
10331
"RTN","ZIS4GTM",61,0)
10332
I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
10333
"RTN","ZIS4GTM",62,0)
10334
OK K %ZDA,%ZFN Q
10335
"RTN","ZIS4GTM",63,0)
10336
N K %ZDA,%ZFN,IO("DOC") S POP=1 Q
10337
"RTN","ZIS4GTM",64,0)
10338
SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
10339
"RTN","ZIS4GTM",65,0)
10340
SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP")
10341
"RTN","ZIS4GTM",66,0)
10342
O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q
10343
"RTN","ZIS4GTM",67,0)
10344
SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q
10345
"RTN","ZIS4GTM",68,0)
10346
CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
10347
"RTN","ZIS4GTM",69,0)
10348
S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP")
10349
"RTN","ZIS4GTM",70,0)
10350
S %Z1=+$G(^XTV(8989.3,1,"SPL"))
10351
"RTN","ZIS4GTM",71,0)
10352
F %=0:0 R %X#255:5 Q:$ZA<0 S %2=%X D CL2 G:%Z1<% SPLEX
10353
"RTN","ZIS4GTM",72,0)
10354
SPLEOF I $ZE'["ENDO" Q ;Send error up
10355
"RTN","ZIS4GTM",73,0)
10356
SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
10357
"RTN","ZIS4GTM",74,0)
10358
;
10359
"RTN","ZIS4GTM",75,0)
10360
CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q
10361
"RTN","ZIS4GTM",76,0)
10362
I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q
10363
"RTN","ZIS4GTM",77,0)
10364
S ^XMBS(3.519,XS,2,%,0)=%2 Q
10365
"RTN","ZIS4GTM",78,0)
10366
;
10367
"RTN","ZIS4GTM",79,0)
10368
HFS G HFS^%ZISF
10369
"RTN","ZIS4GTM",80,0)
10370
REWMT(IO,IOPAR) ;Rewind Magtape
10371
"RTN","ZIS4GTM",81,0)
10372
S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
10373
"RTN","ZIS4GTM",82,0)
10374
U IO W *5
10375
"RTN","ZIS4GTM",83,0)
10376
Q 1
10377
"RTN","ZIS4GTM",84,0)
10378
REWSDP(IO,IOPAR) ;Rewind SDP
10379
"RTN","ZIS4GTM",85,0)
10380
G REW1
10381
"RTN","ZIS4GTM",86,0)
10382
REWHFS(IO,IOPAR) ;Rewind Host File.
10383
"RTN","ZIS4GTM",87,0)
10384
REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
10385
"RTN","ZIS4GTM",88,0)
10386
U IO:(REWIND)
10387
"RTN","ZIS4GTM",89,0)
10388
Q 1
10389
"RTN","ZIS4GTM",90,0)
10390
REWERR ;Error encountered
10391
"RTN","ZIS4GTM",91,0)
10392
Q 0
10393
"RTN","ZISFGTM")
10394
0^48^B9317180
10395
"RTN","ZISFGTM",1,0)
10396
%ZISF ;SFISC/AC MSC/JKT - HOST FILES FOR GT.M on Unix/VMS ;27MAY2009
10397
"RTN","ZISFGTM",2,0)
10398
;;8.0;KERNEL;**275**;Jul 10, 1995
10399
"RTN","ZISFGTM",3,0)
10400
HFS ;Host File Server
10401
"RTN","ZISFGTM",4,0)
10402
Q:$D(IOP)&$D(%IS("HFSIO"))&$D(%IS("IOPAR"))
10403
"RTN","ZISFGTM",5,0)
10404
I $D(%ZIS("HFSNAME")) S IO=%ZIS("HFSNAME"),%X=IO ;
10405
"RTN","ZISFGTM",6,0)
10406
E D ASKHFS
10407
"RTN","ZISFGTM",7,0)
10408
S:$D(%ZISOPAR) %ZISOPAR=$$MODE(%ZISOPAR) ;Force conversion to long format, e.g., (NEWVERSION:NOREADONLY:VARIABLE)
10409
"RTN","ZISFGTM",8,0)
10410
H S:$D(%ZIS("HFSMODE")) %ZISOPAR=$$MODE(%ZIS("HFSMODE"))
10411
"RTN","ZISFGTM",9,0)
10412
H1 I $D(IO("Q"))!(%IS["Z") S IO("HFSIO")=""
10413
"RTN","ZISFGTM",10,0)
10414
S IO=$S(%X]"":%X,1:IO),IO=$$CHKNM(IO) ;See that we have a directory
10415
"RTN","ZISFGTM",11,0)
10416
S:$D(IO("HFSIO")) IO("HFSIO")=IO
10417
"RTN","ZISFGTM",12,0)
10418
W:'$D(IOP)&$D(%ZIS("HFSNAME")) " HOST FILE TO USE: "_%ZIS("HFSNAME"),!
10419
"RTN","ZISFGTM",13,0)
10420
D ASKPAR^%ZIS6,SETPAR^%ZIS3
10421
"RTN","ZISFGTM",14,0)
10422
HFSIOO I '$D(IOP),%ZTYPE="HFS",'$D(%ZIS("HFSMODE")),'$P(^%ZIS(1,%E,0),"^",4),%ZISOPAR="",$D(^%ZIS(1,%E,1)),$P(^(1),"^",6) W ?45,"INPUT/OUTPUT OPERATION: R//"
10423
"RTN","ZISFGTM",15,0)
10424
Q:'$T D SBR^%ZIS1 I $D(DTOUT)!$D(DFOUT)!$D(DUOUT) S POP=1 Q
10425
"RTN","ZISFGTM",16,0)
10426
D HOPT:%X="?"!'$$CHECK(%X),HOPT1:%X="??" G HFSIOO:%X="?"!'$$CHECK(%X)
10427
"RTN","ZISFGTM",17,0)
10428
S:%X]"" %ZISOPAR="("""_%X_""")" Q
10429
"RTN","ZISFGTM",18,0)
10430
;
10431
"RTN","ZISFGTM",19,0)
10432
CHECK(X) ;Check that we have valid option
10433
"RTN","ZISFGTM",20,0)
10434
Q $L(X)=1&("ANRW"[X)
10435
"RTN","ZISFGTM",21,0)
10436
;
10437
"RTN","ZISFGTM",22,0)
10438
ASKHFS ;---Ask host file name here---
10439
"RTN","ZISFGTM",23,0)
10440
I $D(%IS("B","HFS"))#2,%IS("B","HFS")]"" D
10441
"RTN","ZISFGTM",24,0)
10442
.S IO=%IS("B","HFS") ;Set default host file name
10443
"RTN","ZISFGTM",25,0)
10444
S %X='$P($G(^%ZIS(1,%E,1)),"^",5)
10445
"RTN","ZISFGTM",26,0)
10446
S:'%X %X=""
10447
"RTN","ZISFGTM",27,0)
10448
I $D(IOP)!%X!$D(%ZIS("HFSNAME")) S %X="" Q
10449
"RTN","ZISFGTM",28,0)
10450
ASKAGN W !,"HOST FILE NAME: "_IO_"//" D SBR^%ZIS1
10451
"RTN","ZISFGTM",29,0)
10452
I %X?1."?".E W !,"ENTER HOST FILE NAME" G ASKAGN
10453
"RTN","ZISFGTM",30,0)
10454
S:$D(DTOUT)!$D(DUOUT) POP=1
10455
"RTN","ZISFGTM",31,0)
10456
Q
10457
"RTN","ZISFGTM",32,0)
10458
CHKNM(H) ;Check the HFS name
10459
"RTN","ZISFGTM",33,0)
10460
N N S N=H
10461
"RTN","ZISFGTM",34,0)
10462
I $ZV["VMS" D
10463
"RTN","ZISFGTM",35,0)
10464
. I (H'[":")&(H'["[") S N=$$DEFDIR^%ZISH("")_H
10465
"RTN","ZISFGTM",36,0)
10466
E D
10467
"RTN","ZISFGTM",37,0)
10468
. I (H'["/") S N=$$DEFDIR^%ZISH("")_H
10469
"RTN","ZISFGTM",38,0)
10470
Q N
10471
"RTN","ZISFGTM",39,0)
10472
;
10473
"RTN","ZISFGTM",40,0)
10474
MODE(X) ;Return %ZISOPAR
10475
"RTN","ZISFGTM",41,0)
10476
Q:$E(X)="(" X ;Already in long format
10477
"RTN","ZISFGTM",42,0)
10478
;
10479
"RTN","ZISFGTM",43,0)
10480
;Strip out invalid codes
10481
"RTN","ZISFGTM",44,0)
10482
N % F %=1:1:$L(X) I "ANRW"'[$E(X,%) S $E(X,%)=" "
10483
"RTN","ZISFGTM",45,0)
10484
S X=$TR(X," ")
10485
"RTN","ZISFGTM",46,0)
10486
;
10487
"RTN","ZISFGTM",47,0)
10488
;Reduce redundant multi-letter combinations to single-letter codes
10489
"RTN","ZISFGTM",48,0)
10490
I X["N"&(X["W") S X=$TR(X,"W")
10491
"RTN","ZISFGTM",49,0)
10492
I X["A"&(X["W") S X=$TR(X,"W")
10493
"RTN","ZISFGTM",50,0)
10494
;
10495
"RTN","ZISFGTM",51,0)
10496
;Take the last code in the string, e.g., if X="AN", the "N" will take effect
10497
"RTN","ZISFGTM",52,0)
10498
S X=$E(X,$L(X))
10499
"RTN","ZISFGTM",53,0)
10500
;
10501
"RTN","ZISFGTM",54,0)
10502
;Translate code into long format
10503
"RTN","ZISFGTM",55,0)
10504
Q $S(X="N":"(NEWVERSION:NOREADONLY:VARIABLE)",X="W":"(NEWVERSION:NOREADONLY:VARIABLE)",X="A":"(APPEND:NOREADONLY:VARIABLE)",1:"(READONLY:VARIABLE)")
10505
"RTN","ZISFGTM",56,0)
10506
;
10507
"RTN","ZISFGTM",57,0)
10508
HOPT W !,"You may enter a code that represents one of",!,"the following host file input/ouput operation:"
10509
"RTN","ZISFGTM",58,0)
10510
W !?16,"R = READ ACCESS",!?16,"W = WRITE ACCESS",!?16,"N = NEWVERSION",!?16,"A = APPEND"
10511
"RTN","ZISFGTM",59,0)
10512
Q
10513
"RTN","ZISFGTM",60,0)
10514
HOPT1 S %ZISI=$O(^DIC(9.2,"B","XUHFSPARAM-GUX",0)) Q:'%ZISI Q:'$D(^DIC(9.2,+%ZISI,0)) Q:$P(^(0),"^",1)'="XUHFSPARAM-GUX"
10515
"RTN","ZISFGTM",61,0)
10516
Q:$D(^DIC(9.2,+%ZISI,1))'>9 F %X=0:0 S %X=$O(^DIC(9.2,+%ZISI,1,%X)) Q:%X'>0 I $D(^(%X,0)) W !,^(0)
10517
"RTN","ZISFGTM",62,0)
10518
W ! S %X="??" Q
10519
"RTN","ZISFGUX")
10520
1^27
10521
"RTN","ZISHGUX")
10522
0^15^B36911880
10523
"RTN","ZISHGUX",1,0)
10524
%ZISH ;ISF/AC,RWF MSC/JDS- GT.M for UNIX Host file Control ;01MAY2009
10525
"RTN","ZISHGUX",2,0)
10526
;;8.0;KERNEL;**275,306,MSC**;Jul 10, 1995;
10527
"RTN","ZISHGUX",3,0)
10528
; for GT.M for Unix/VMS, version 4.3
10529
"RTN","ZISHGUX",4,0)
10530
;
10531
"RTN","ZISHGUX",5,0)
10532
OPENERR ;
10533
"RTN","ZISHGUX",6,0)
10534
Q 0
10535
"RTN","ZISHGUX",7,0)
10536
;
10537
"RTN","ZISHGUX",8,0)
10538
OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open file
10539
"RTN","ZISHGUX",9,0)
10540
;D OPEN^%ZISH([handlename],[directory],filename,[accessmode],[recsize])
10541
"RTN","ZISHGUX",10,0)
10542
;X1=handle name
10543
"RTN","ZISHGUX",11,0)
10544
;X2=directory, X3=filename, X4=access mode
10545
"RTN","ZISHGUX",12,0)
10546
;X5=new file max record size, X6=Subtype
10547
"RTN","ZISHGUX",13,0)
10548
;
10549
"RTN","ZISHGUX",14,0)
10550
N %,%1,%2,%IO,%I2,%P,%T,X,Y,$ETRAP
10551
"RTN","ZISHGUX",15,0)
10552
S $ETRAP="D OPNERR^%ZISH"
10553
"RTN","ZISHGUX",16,0)
10554
S U="^",X2=$$DEFDIR($G(X2)),X4=$$UP^XLFSTR(X4)
10555
"RTN","ZISHGUX",17,0)
10556
S Y=$S(X4["A":"append",X4["R":"readonly",X4["W":"newversion",1:"readonly")
10557
"RTN","ZISHGUX",18,0)
10558
S Y=Y_$S(X4["B":":fixed:nowrap:recordsize=512",$G(X5)&(X4["W"):":WIDTH="_+X5,1:"")
10559
"RTN","ZISHGUX",19,0)
10560
S:$E(Y)=":" Y=$E(Y,2,999) S %IO=X2_X3,%I2="%IO:"_$S($L(Y):"("_Y_")",1:"")_":3"
10561
"RTN","ZISHGUX",20,0)
10562
O @%I2 S %T=$T
10563
"RTN","ZISHGUX",21,0)
10564
I '%T S POP=1 Q
10565
"RTN","ZISHGUX",22,0)
10566
S IO=%IO,IO(1,IO)="",IOT="HFS",POP=0 D SUBTYPE^%ZIS3($G(X6))
10567
"RTN","ZISHGUX",23,0)
10568
I $G(X1)]"" D SAVDEV^%ZISUTL(X1)
10569
"RTN","ZISHGUX",24,0)
10570
U IO U $P ;Enable use of $ZA to test EOF condition.
10571
"RTN","ZISHGUX",25,0)
10572
Q
10573
"RTN","ZISHGUX",26,0)
10574
OPNERR ;error on open
10575
"RTN","ZISHGUX",27,0)
10576
S POP=1,$ECODE=""
10577
"RTN","ZISHGUX",28,0)
10578
U:$G(%P)]"" %P
10579
"RTN","ZISHGUX",29,0)
10580
Q
10581
"RTN","ZISHGUX",30,0)
10582
;
10583
"RTN","ZISHGUX",31,0)
10584
CLOSE(X) ;SR. Close HFS device not opened by %ZIS.
10585
"RTN","ZISHGUX",32,0)
10586
;X1=Handle name, IO=device
10587
"RTN","ZISHGUX",33,0)
10588
I IO]"" C IO K IO(1,IO)
10589
"RTN","ZISHGUX",34,0)
10590
I $G(X)]"" D RMDEV^%ZISUTL(X)
10591
"RTN","ZISHGUX",35,0)
10592
D HOME^%ZIS
10593
"RTN","ZISHGUX",36,0)
10594
Q
10595
"RTN","ZISHGUX",37,0)
10596
DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s)
10597
"RTN","ZISHGUX",38,0)
10598
;S Y=$$DEL^%ZISH("dir path",$NA(array))
10599
"RTN","ZISHGUX",39,0)
10600
N %ZISH,%ZISHLGR,%ZX,X,%ZXDEL
10601
"RTN","ZISHGUX",40,0)
10602
S %ZX1=$$DEFDIR($G(%ZX1)),%ZXDEL=1,%ZISH=""
10603
"RTN","ZISHGUX",41,0)
10604
F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D
10605
"RTN","ZISHGUX",42,0)
10606
. N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
10607
"RTN","ZISHGUX",43,0)
10608
. I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed.
10609
"RTN","ZISHGUX",44,0)
10610
. S %ZX=$ZSEARCH(%ZX1_%ZISH)
10611
"RTN","ZISHGUX",45,0)
10612
. Q:%ZX']"" ; File doesn't exist - not an error, just quit.
10613
"RTN","ZISHGUX",46,0)
10614
. O %ZX:READONLY:0
10615
"RTN","ZISHGUX",47,0)
10616
. I '$T S %ZXDEL=0 Q ; Can't open it.
10617
"RTN","ZISHGUX",48,0)
10618
. C %ZX:DELETE
10619
"RTN","ZISHGUX",49,0)
10620
. I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful.
10621
"RTN","ZISHGUX",50,0)
10622
Q %ZXDEL
10623
"RTN","ZISHGUX",51,0)
10624
DELERR ;Trap any $ETRAP error, unwind and return.
10625
"RTN","ZISHGUX",52,0)
10626
S $ETRAP="D UNWIND^%ZTER"
10627
"RTN","ZISHGUX",53,0)
10628
S %ZXDEL=0
10629
"RTN","ZISHGUX",54,0)
10630
D UNWIND^%ZTER
10631
"RTN","ZISHGUX",55,0)
10632
Q
10633
"RTN","ZISHGUX",56,0)
10634
;
10635
"RTN","ZISHGUX",57,0)
10636
LIST(DIR,LIST,RETURN) ;ef,SR. Set local array holding fl names
10637
"RTN","ZISHGUX",58,0)
10638
;S Y=$$LIST^ZISH("/dir/","list_root","return_root")
10639
"RTN","ZISHGUX",59,0)
10640
;list_root can have XX("A*"), XX("test.com")...
10641
"RTN","ZISHGUX",60,0)
10642
;Both arrays passed as $NA values (closed roots).
10643
"RTN","ZISHGUX",61,0)
10644
;Init %ZISHDL1, %ZISHDL2 by deleteing them
10645
"RTN","ZISHGUX",62,0)
10646
;I $ZSEARCH(%ZISHDL1)["ZISH" ZSYSTEM "rm "_%ZISHDL1
10647
"RTN","ZISHGUX",63,0)
10648
;I $ZSEARCH(%ZISHDL2)["ZISH" ZSYSTEM "rm "_%ZISHDL2_";*"
10649
"RTN","ZISHGUX",64,0)
10650
;Get fls, Build listing in %ZISHDL1 with ls
10651
"RTN","ZISHGUX",65,0)
10652
S %ZISH1=0,%ZISH=""
10653
"RTN","ZISHGUX",66,0)
10654
N WANT,GLOB,NAME S WANT="",DIR=$$DEFDIR($G(DIR)) F S WANT=$O(@LIST@(WANT)) Q:WANT="" D
10655
"RTN","ZISHGUX",67,0)
10656
. S GLOB=DIR_WANT,NAME=""
10657
"RTN","ZISHGUX",68,0)
10658
. F S NAME=$ZSEARCH(GLOB) Q:NAME="" S @RETURN@($P(NAME,DIR,2))=""
10659
"RTN","ZISHGUX",69,0)
10660
Q $Q(@RETURN)]""
10661
"RTN","ZISHGUX",70,0)
10662
LSTEOF S $ZT=""
10663
"RTN","ZISHGUX",71,0)
10664
I $L(%IO) U:$D(IO(1,%IO)) IO
10665
"RTN","ZISHGUX",72,0)
10666
;C %ZISHDL1 ;:DELETE
10667
"RTN","ZISHGUX",73,0)
10668
;I $L($ZSEARCH(%ZISHDL2)) ZSYSTEM "DEL "_%ZISHDL2
10669
"RTN","ZISHGUX",74,0)
10670
;I $L($ZSEARCH(%ZISHDL1)) ZSYSTEM "DEL "_%ZISHDL1_";*"
10671
"RTN","ZISHGUX",75,0)
10672
S $ECODE=""
10673
"RTN","ZISHGUX",76,0)
10674
Q ($Q(@%ZX3)]"")
10675
"RTN","ZISHGUX",77,0)
10676
;
10677
"RTN","ZISHGUX",78,0)
10678
LIST1(%ZX,%ZD) ;Get one part of the list
10679
"RTN","ZISHGUX",79,0)
10680
N $ET,$ES S $ET="D LSTERR^%ZISH"
10681
"RTN","ZISHGUX",80,0)
10682
;ZSYSTEM "ls -1 "_%ZX_" > "_%ZISHDL1
10683
"RTN","ZISHGUX",81,0)
10684
;O %ZISHDL1:readonly:1 U %ZISHDL1
10685
"RTN","ZISHGUX",82,0)
10686
;F R %X:1 Q:$ZEOF S @%ZX3@(%X)=""
10687
"RTN","ZISHGUX",83,0)
10688
;C %ZISHDL1:DELETE
10689
"RTN","ZISHGUX",84,0)
10690
N %ZY,%ZI,%ZJ
10691
"RTN","ZISHGUX",85,0)
10692
S %ZY=$ZSEARCH("*.X") ;Clear vector
10693
"RTN","ZISHGUX",86,0)
10694
S %ZY=$P(%ZX,"*")
10695
"RTN","ZISHGUX",87,0)
10696
F S %ZI=$ZSEARCH(%ZX) Q:'$L(%ZI)!(%ZI'[%ZY) S %ZJ=$P(%ZI,%ZD,2),@%ZX3@(%ZJ)=""
10697
"RTN","ZISHGUX",88,0)
10698
Q 1
10699
"RTN","ZISHGUX",89,0)
10700
LSTERR ;Error in list
10701
"RTN","ZISHGUX",90,0)
10702
I $ZSEARCH(%ZISHDL2)["ZISH" ZSYSTEM "DEL "_%ZISHDL2_";*"
10703
"RTN","ZISHGUX",91,0)
10704
Q 0
10705
"RTN","ZISHGUX",92,0)
10706
;
10707
"RTN","ZISHGUX",93,0)
10708
SPAWNERR ;TRAP ERROR OF SPAWN
10709
"RTN","ZISHGUX",94,0)
10710
O %ZISHDL1:READONLY:1 I $T C %ZISHDL1:DELETE
10711
"RTN","ZISHGUX",95,0)
10712
S $ECODE=""
10713
"RTN","ZISHGUX",96,0)
10714
Q 0
10715
"RTN","ZISHGUX",97,0)
10716
;
10717
"RTN","ZISHGUX",98,0)
10718
MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl
10719
"RTN","ZISHGUX",99,0)
10720
;S Y=$$MV^ZISH("/dir/","fl","/dir/","fl")
10721
"RTN","ZISHGUX",100,0)
10722
N X,Y,%ZISHDL1
10723
"RTN","ZISHGUX",101,0)
10724
S %ZISHDL1="ZISH"_$J_".TMPA",X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1))
10725
"RTN","ZISHGUX",102,0)
10726
S $ZT="SPAWNERR^%ZISH"
10727
"RTN","ZISHGUX",103,0)
10728
;Pbv or qit
10729
"RTN","ZISHGUX",104,0)
10730
I (X2="")!(Y2="") Q 0
10731
"RTN","ZISHGUX",105,0)
10732
ZSYSTEM "mv "_X1_X2_" "_Y1_Y2 ;Use system command
10733
"RTN","ZISHGUX",106,0)
10734
S Y=$ZSEARCH(Y1_Y2)
10735
"RTN","ZISHGUX",107,0)
10736
Q $L(Y)>0
10737
"RTN","ZISHGUX",108,0)
10738
;
10739
"RTN","ZISHGUX",109,0)
10740
PWD() ;ef,SR. Print working directory
10741
"RTN","ZISHGUX",110,0)
10742
N Y
10743
"RTN","ZISHGUX",111,0)
10744
S Y=$$DEFDIR("")
10745
"RTN","ZISHGUX",112,0)
10746
S:Y="" Y=$ZDIR
10747
"RTN","ZISHGUX",113,0)
10748
Q Y
10749
"RTN","ZISHGUX",114,0)
10750
;
10751
"RTN","ZISHGUX",115,0)
10752
DEFDIR(DF) ;ef. Default Dir and frmt
10753
"RTN","ZISHGUX",116,0)
10754
S DF=$G(DF) Q:DF="." "" ;Special way to get current dir.
10755
"RTN","ZISHGUX",117,0)
10756
S:DF="" DF=$G(^XTV(8989.3,1,"DEV"))
10757
"RTN","ZISHGUX",118,0)
10758
;Check syntax, VMS needs : or [ ]
10759
"RTN","ZISHGUX",119,0)
10760
I ^%ZOSF("OS")["VMS" D Q DF ;***EXIT FOR VMS/GTM
10761
"RTN","ZISHGUX",120,0)
10762
. N P1,P2
10763
"RTN","ZISHGUX",121,0)
10764
. I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
10765
"RTN","ZISHGUX",122,0)
10766
. E S P1="",P2=DF
10767
"RTN","ZISHGUX",123,0)
10768
. I P1="",P2["$" S DF=P2 Q ;Assume a logical
10769
"RTN","ZISHGUX",124,0)
10770
. I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]"
10771
"RTN","ZISHGUX",125,0)
10772
. S DF=P1_P2
10773
"RTN","ZISHGUX",126,0)
10774
. Q
10775
"RTN","ZISHGUX",127,0)
10776
;
10777
"RTN","ZISHGUX",128,0)
10778
;Check syntax, Unix check leading & trailing "/"
10779
"RTN","ZISHGUX",129,0)
10780
I "./"'[$E(DF) S DF="/"_DF
10781
"RTN","ZISHGUX",130,0)
10782
I $E(DF,$L(DF))'="/" S DF=DF_"/"
10783
"RTN","ZISHGUX",131,0)
10784
Q DF
10785
"RTN","ZISHGUX",132,0)
10786
STATUS() ;ef,SR. Return EOF status
10787
"RTN","ZISHGUX",133,0)
10788
U $I
10789
"RTN","ZISHGUX",134,0)
10790
Q $ZEOF
10791
"RTN","ZISHGUX",135,0)
10792
;
10793
"RTN","ZISHGUX",136,0)
10794
EOF(X) ;Eof flag, Pass in $ZA
10795
"RTN","ZISHGUX",137,0)
10796
Q X
10797
"RTN","ZISHGUX",138,0)
10798
QL(X) ;Qlfrs
10799
"RTN","ZISHGUX",139,0)
10800
Q:X=""
10801
"RTN","ZISHGUX",140,0)
10802
S:$E(X)'="-" X="-"_X
10803
"RTN","ZISHGUX",141,0)
10804
Q
10805
"RTN","ZISHGUX",142,0)
10806
FL(X) ;Fl len
10807
"RTN","ZISHGUX",143,0)
10808
N ZOSHP1,ZOSHP2
10809
"RTN","ZISHGUX",144,0)
10810
S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2)
10811
"RTN","ZISHGUX",145,0)
10812
I $L(ZOSHP1)>14 S X=4 Q
10813
"RTN","ZISHGUX",146,0)
10814
I $L(ZOSHP2)>8 S X=4 Q
10815
"RTN","ZISHGUX",147,0)
10816
Q
10817
"RTN","ZISHGUX",148,0)
10818
;
10819
"RTN","ZISHGUX",149,0)
10820
MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref.
10821
"RTN","ZISHGUX",150,0)
10822
;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB
10823
"RTN","ZISHGUX",151,0)
10824
N I,F,MX
10825
"RTN","ZISHGUX",152,0)
10826
S OVF=$G(OVF,"%ZISHOF")
10827
"RTN","ZISHGUX",153,0)
10828
S %ZISHI=$$QS^DDBRAP(HF,IX),MX=$$QL^DDBRAP(HF) ;
10829
"RTN","ZISHGUX",154,0)
10830
S F=$NA(@HF,IX-1) ;Get first part
10831
"RTN","ZISHGUX",155,0)
10832
I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1
10833
"RTN","ZISHGUX",156,0)
10834
I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root
10835
"RTN","ZISHGUX",157,0)
10836
S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow
10837
"RTN","ZISHGUX",158,0)
10838
F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$$QS^DDBRAP(HF,I)
10839
"RTN","ZISHGUX",159,0)
10840
S %ZISHF=%ZISHF_")"
10841
"RTN","ZISHGUX",160,0)
10842
Q
10843
"RTN","ZISHGUX",161,0)
10844
FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global
10845
"RTN","ZISHGUX",162,0)
10846
;p1=host file directory
10847
"RTN","ZISHGUX",163,0)
10848
;p2=host file name
10849
"RTN","ZISHGUX",164,0)
10850
;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT
10851
"RTN","ZISHGUX",165,0)
10852
;p4=INCREMENT SUBSCRIPT
10853
"RTN","ZISHGUX",166,0)
10854
;p5=Overflow subscript, defaults to "OVF"
10855
"RTN","ZISHGUX",167,0)
10856
N %ZA,%ZB,%ZC,%ZL,X,%OVFCNT,%CONT
10857
"RTN","ZISHGUX",168,0)
10858
N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY,POP,%ZISUB,%EXIT
10859
"RTN","ZISHGUX",169,0)
10860
S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF")
10861
"RTN","ZISHGUX",170,0)
10862
D MAKEREF(%ZX3,%ZX4,"%ZISHOF")
10863
"RTN","ZISHGUX",171,0)
10864
D OPEN^%ZISH(,%ZX1,%ZX2,"R")
10865
"RTN","ZISHGUX",172,0)
10866
I POP Q 0
10867
"RTN","ZISHGUX",173,0)
10868
N $ETRAP S %EXIT=0,$ETRAP="S %ZA=1,%EXIT=1,$ECODE="""" Q"
10869
"RTN","ZISHGUX",174,0)
10870
U IO F K %XX D READNXT(.%XX) Q:$$EOF(%ZA) D
10871
"RTN","ZISHGUX",175,0)
10872
. S @%ZISHF=%XX
10873
"RTN","ZISHGUX",176,0)
10874
. I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT)
10875
"RTN","ZISHGUX",177,0)
10876
. S %ZISHI=%ZISHI+1
10877
"RTN","ZISHGUX",178,0)
10878
. Q
10879
"RTN","ZISHGUX",179,0)
10880
D CLOSE() ;Normal exit
10881
"RTN","ZISHGUX",180,0)
10882
Q '%EXIT
10883
"RTN","ZISHGUX",181,0)
10884
;
10885
"RTN","ZISHGUX",182,0)
10886
ERREOF D CLOSE() ;Got error Reading file
10887
"RTN","ZISHGUX",183,0)
10888
Q 0
10889
"RTN","ZISHGUX",184,0)
10890
;
10891
"RTN","ZISHGUX",185,0)
10892
READNXT(REC) ;
10893
"RTN","ZISHGUX",186,0)
10894
N T,I,X,%
10895
"RTN","ZISHGUX",187,0)
10896
U IO R X:2 S %ZA=$ZEOF,REC=$E(X,1,255)
10897
"RTN","ZISHGUX",188,0)
10898
Q:$L(X)<256
10899
"RTN","ZISHGUX",189,0)
10900
S %=256 F I=1:1 Q:$L(X)<% S REC(I)=$E(X,%,%+254),%=%+255
10901
"RTN","ZISHGUX",190,0)
10902
Q
10903
"RTN","ZISHGUX",191,0)
10904
GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file.
10905
"RTN","ZISHGUX",192,0)
10906
;Previously name LOAD
10907
"RTN","ZISHGUX",193,0)
10908
;p1=$NAME of global reference
10909
"RTN","ZISHGUX",194,0)
10910
;p2=incrementing subscript
10911
"RTN","ZISHGUX",195,0)
10912
;p3=host file directory
10913
"RTN","ZISHGUX",196,0)
10914
;p4=host file name
10915
"RTN","ZISHGUX",197,0)
10916
N %ZISHY,%ZISHLGR,%ZISHOX
10917
"RTN","ZISHGUX",198,0)
10918
S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"W")
10919
"RTN","ZISHGUX",199,0)
10920
Q %ZISHY
10921
"RTN","ZISHGUX",200,0)
10922
;
10923
"RTN","ZISHGUX",201,0)
10924
GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file.
10925
"RTN","ZISHGUX",202,0)
10926
;
10927
"RTN","ZISHGUX",203,0)
10928
;p1=$NAME of global reference
10929
"RTN","ZISHGUX",204,0)
10930
;p2=incrementing subscript
10931
"RTN","ZISHGUX",205,0)
10932
;p3=host file directory
10933
"RTN","ZISHGUX",206,0)
10934
;p4=host file name
10935
"RTN","ZISHGUX",207,0)
10936
N %ZISHY
10937
"RTN","ZISHGUX",208,0)
10938
S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"A")
10939
"RTN","ZISHGUX",209,0)
10940
Q %ZISHY
10941
"RTN","ZISHGUX",210,0)
10942
;
10943
"RTN","ZISHGUX",211,0)
10944
MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;
10945
"RTN","ZISHGUX",212,0)
10946
;p1=$NAME of global reference
10947
"RTN","ZISHGUX",213,0)
10948
;p2=incrementing subscript
10949
"RTN","ZISHGUX",214,0)
10950
;p3=host file directory
10951
"RTN","ZISHGUX",215,0)
10952
;p4=host file name
10953
"RTN","ZISHGUX",216,0)
10954
N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHS,%ZISHOX,IO,%ZX,Y
10955
"RTN","ZISHGUX",217,0)
10956
D MAKEREF(%ZX1,%ZX2)
10957
"RTN","ZISHGUX",218,0)
10958
D OPEN^%ZISH(,%ZX3,%ZX4,%ZX5) ;Default dir set in open
10959
"RTN","ZISHGUX",219,0)
10960
I POP Q 0
10961
"RTN","ZISHGUX",220,0)
10962
N X
10963
"RTN","ZISHGUX",221,0)
10964
N $ETRAP S $ETRAP="",X="ERREOF^%ZISH",@^%ZOSF("TRAP")
10965
"RTN","ZISHGUX",222,0)
10966
F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,!
10967
"RTN","ZISHGUX",223,0)
10968
D CLOSE() ;Normal Exit
10969
"RTN","ZISHGUX",224,0)
10970
Q 1
10971
"RTN","ZISHGUX",225,0)
10972
;
10973
"RTN","ZISTCPS")
10974
0^25^B18299533
10975
"RTN","ZISTCPS",1,0)
10976
%ZISTCPS ;ISF/RWF MSC/JDA - DEVICE HANDLER TCP/IP SERVER CALLS ;22APR2009
10977
"RTN","ZISTCPS",2,0)
10978
;;8.0;KERNEL;**78,118,127,225,275,388,MSC**;Jul 10, 1995
10979
"RTN","ZISTCPS",3,0)
10980
Q
10981
"RTN","ZISTCPS",4,0)
10982
;
10983
"RTN","ZISTCPS",5,0)
10984
CLOSE ;Close and reset
10985
"RTN","ZISTCPS",6,0)
10986
G CLOSE^%ZISTCP
10987
"RTN","ZISTCPS",7,0)
10988
Q
10989
"RTN","ZISTCPS",8,0)
10990
;
10991
"RTN","ZISTCPS",9,0)
10992
;In ZRULE, set ZISQUIT=1 to quit
10993
"RTN","ZISTCPS",10,0)
10994
LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, start routine
10995
"RTN","ZISTCPS",11,0)
10996
N %A,ZISOS,X,NIO,EXIT
10997
"RTN","ZISTCPS",12,0)
10998
N $ES,$ET S $ETRAP="D OPNERR^%ZISTCPS"
10999
"RTN","ZISTCPS",13,0)
11000
S ZISOS=^%ZOSF("OS"),ZRULE=$G(ZRULE)
11001
"RTN","ZISTCPS",14,0)
11002
S POP=1
11003
"RTN","ZISTCPS",15,0)
11004
D GETENV^%ZOSV S U="^",XUENV=Y,XQVOL=$P(Y,U,2)
11005
"RTN","ZISTCPS",16,0)
11006
S POP=1 D LONT:ZISOS["OpenM",LGTM:ZISOS["GT.M"
11007
"RTN","ZISTCPS",17,0)
11008
I 'POP C NIO ;Close port
11009
"RTN","ZISTCPS",18,0)
11010
Q
11011
"RTN","ZISTCPS",19,0)
11012
;
11013
"RTN","ZISTCPS",20,0)
11014
;
11015
"RTN","ZISTCPS",21,0)
11016
LONT ;Open port in Accept mode with standard terminators.
11017
"RTN","ZISTCPS",22,0)
11018
N %ZA,NEWCHAR
11019
"RTN","ZISTCPS",23,0)
11020
S NIO="|TCP|"_SOCK,EXIT=0
11021
"RTN","ZISTCPS",24,0)
11022
;(adr:sock:term:ibuf:obuf:queue)
11023
"RTN","ZISTCPS",25,0)
11024
O NIO:(:SOCK:"AT"::512:512:10):30 Q:'$T S POP=0 U NIO
11025
"RTN","ZISTCPS",26,0)
11026
;Wait on read for a connect
11027
"RTN","ZISTCPS",27,0)
11028
LONT2 F U NIO R *NEWCHAR:30 S EXIT=$$EXIT Q:$T!EXIT
11029
"RTN","ZISTCPS",28,0)
11030
I EXIT C NIO Q
11031
"RTN","ZISTCPS",29,0)
11032
;JOB params (:Concurrent Server bit:principal input:principal output)
11033
"RTN","ZISTCPS",30,0)
11034
J CHILDONT^%ZISTCPS(NIO,RTN):(:16::):10 S %ZA=$ZA
11035
"RTN","ZISTCPS",31,0)
11036
I %ZA\8196#2=1 W *-2 ;Job failed to clear bit
11037
"RTN","ZISTCPS",32,0)
11038
G LONT2
11039
"RTN","ZISTCPS",33,0)
11040
;
11041
"RTN","ZISTCPS",34,0)
11042
CHILDONT(IO,RTN) ;Child process for OpenM
11043
"RTN","ZISTCPS",35,0)
11044
S $ETRAP="D ^%ZTER L HALT",IO=$ZU(53)
11045
"RTN","ZISTCPS",36,0)
11046
U IO:(::"-M") ;Work like DSM
11047
"RTN","ZISTCPS",37,0)
11048
S NEWJOB=$$NEWOK
11049
"RTN","ZISTCPS",38,0)
11050
I 'NEWJOB W "421 Service temporarily down.",$C(13,10),!
11051
"RTN","ZISTCPS",39,0)
11052
I NEWJOB K NEWJOB D VAR,@RTN
11053
"RTN","ZISTCPS",40,0)
11054
HALT
11055
"RTN","ZISTCPS",41,0)
11056
;
11057
"RTN","ZISTCPS",42,0)
11058
VAR ;Setup IO variables
11059
"RTN","ZISTCPS",43,0)
11060
S IO(0)=IO,IO(1,IO)="",POP=0
11061
"RTN","ZISTCPS",44,0)
11062
S IOT="TCP",IOST="P-TCP",IOST(0)=0
11063
"RTN","ZISTCPS",45,0)
11064
S IOF=$$FLUSHCHR^%ZISTCP
11065
"RTN","ZISTCPS",46,0)
11066
S ^XUTL("XQ",$J,0)=$$DT^XLFDT
11067
"RTN","ZISTCPS",47,0)
11068
Q
11069
"RTN","ZISTCPS",48,0)
11070
NEWOK() ;Is it OK to start a new process
11071
"RTN","ZISTCPS",49,0)
11072
I $G(^%ZIS(14.5,"LOGON",^%ZOSF("VOL"))) Q 0
11073
"RTN","ZISTCPS",50,0)
11074
I $$AVJ^%ZOSV()<3 Q 0
11075
"RTN","ZISTCPS",51,0)
11076
Q 1
11077
"RTN","ZISTCPS",52,0)
11078
OPNERR ;
11079
"RTN","ZISTCPS",53,0)
11080
S POP=1,EXIT=1,IO("ERROR")=$ECODE,$ECODE=""
11081
"RTN","ZISTCPS",54,0)
11082
Q
11083
"RTN","ZISTCPS",55,0)
11084
EXIT() ;See if time to exit
11085
"RTN","ZISTCPS",56,0)
11086
I $$S^%ZTLOAD Q 1
11087
"RTN","ZISTCPS",57,0)
11088
N ZISQUIT S ZISQUIT=0
11089
"RTN","ZISTCPS",58,0)
11090
I $L(ZRULE) X ZRULE I $G(ZISQUIT) Q 1
11091
"RTN","ZISTCPS",59,0)
11092
Q 0
11093
"RTN","ZISTCPS",60,0)
11094
;
11095
"RTN","ZISTCPS",61,0)
11096
LGTM ;GT.M multi thread server
11097
"RTN","ZISTCPS",62,0)
11098
N %A K ^TMP("ZISTCP",$J)
11099
"RTN","ZISTCPS",63,0)
11100
S $ZINTERRUPT="I $$JOBEXAM^ZU($ZPOSITION)"
11101
"RTN","ZISTCPS",64,0)
11102
S NIO="SCK$"_$S($J>86400:$J,1:84600+$J) ;Construct a dummy, but "unique" devicename for job
11103
"RTN","ZISTCPS",65,0)
11104
D LOG("Open for Listen "_NIO)
11105
"RTN","ZISTCPS",66,0)
11106
;Open the device
11107
"RTN","ZISTCPS",67,0)
11108
O NIO:(ZLISTEN=SOCK_":TCP":ATTACH="listener"):30:"SOCKET"
11109
"RTN","ZISTCPS",68,0)
11110
I '$T D LOG("Can't Open Socket: "_SOCK) Q
11111
"RTN","ZISTCPS",69,0)
11112
U NIO S NIO("ZISTCP",0)=$KEY D LOG("Have port.")
11113
"RTN","ZISTCPS",70,0)
11114
;Start Listening
11115
"RTN","ZISTCPS",71,0)
11116
W /LISTEN(1) S NIO("ZISTCP",1)=$KEY D LOG("Start Listening. "_NIO("ZISTCP",1))
11117
"RTN","ZISTCPS",72,0)
11118
N ZC,ZR,IDX,DESC
11119
"RTN","ZISTCPS",73,0)
11120
S ZC="ZSHOW ""D"":ZR"
11121
"RTN","ZISTCPS",74,0)
11122
;Wait for connection
11123
"RTN","ZISTCPS",75,0)
11124
LG2 S %A=0,EXIT=0 F D Q:%A!EXIT
11125
"RTN","ZISTCPS",76,0)
11126
. U NIO:(SOCKET="listener")
11127
"RTN","ZISTCPS",77,0)
11128
. W /WAIT(30) ;Wait for connect
11129
"RTN","ZISTCPS",78,0)
11130
. I $P($KEY,"|",1)="CONNECT" S NIO("ZISTCP",2)=$KEY,%A=1
11131
"RTN","ZISTCPS",79,0)
11132
. S EXIT=$$EXIT
11133
"RTN","ZISTCPS",80,0)
11134
. Q
11135
"RTN","ZISTCPS",81,0)
11136
I EXIT C NIO Q
11137
"RTN","ZISTCPS",82,0)
11138
;
11139
"RTN","ZISTCPS",83,0)
11140
S NIO("SOCK")=$P($G(NIO("ZISTCP",2)),"|",2)
11141
"RTN","ZISTCPS",84,0)
11142
D LOG("Got connection on "_NIO("SOCK"))
11143
"RTN","ZISTCPS",85,0)
11144
I '$$NEWOK D G LG2
11145
"RTN","ZISTCPS",86,0)
11146
. U NIO:(SOCKET=NIO("SOCK")) W "421 Service temporarily down.",$C(13,10),#
11147
"RTN","ZISTCPS",87,0)
11148
. C NIO:(SOCKET=NIO("SOCK")) K NIO("ZISTCP",2)
11149
"RTN","ZISTCPS",88,0)
11150
. Q
11151
"RTN","ZISTCPS",89,0)
11152
;Find file descriptor
11153
"RTN","ZISTCPS",90,0)
11154
X ZC
11155
"RTN","ZISTCPS",91,0)
11156
S DESC="" F IDX=1:1:$O(ZR("D",""),-1) S:ZR("D",IDX)[NIO("SOCK") DESC=$P($P(ZR("D",IDX),"DESC=",2)," ",1) Q:DESC'=""
11157
"RTN","ZISTCPS",92,0)
11158
I DESC="" D LOG("Can not find file descriptor!") G LG2
11159
"RTN","ZISTCPS",93,0)
11160
;spawn child process
11161
"RTN","ZISTCPS",94,0)
11162
S SPAWNID=$&openvista.gtmserver(DESC,"GTMLNCH^%ZISTCPS")
11163
"RTN","ZISTCPS",95,0)
11164
L +^TMP("ZISTCPS",SPAWNID)
11165
"RTN","ZISTCPS",96,0)
11166
S ^TMP("ZISTCPS",SPAWNID)=RTN
11167
"RTN","ZISTCPS",97,0)
11168
L -^TMP("ZISTCPS",SPAWNID)
11169
"RTN","ZISTCPS",98,0)
11170
D LOG("Spawned child "_SPAWNID)
11171
"RTN","ZISTCPS",99,0)
11172
;Close the client socket since the child now has it
11173
"RTN","ZISTCPS",100,0)
11174
C NIO:(SOCKET=NIO("SOCK"))
11175
"RTN","ZISTCPS",101,0)
11176
G LG2
11177
"RTN","ZISTCPS",102,0)
11178
Q
11179
"RTN","ZISTCPS",103,0)
11180
;
11181
"RTN","ZISTCPS",104,0)
11182
GTMLNCH ;Run gt.m job for this connection.
11183
"RTN","ZISTCPS",105,0)
11184
N RTN S RTN=""
11185
"RTN","ZISTCPS",106,0)
11186
S IO("GTM-IP")=$P($K,"|",3)
11187
"RTN","ZISTCPS",107,0)
11188
F D Q:RTN'="" ; Loop until we get entry point
11189
"RTN","ZISTCPS",108,0)
11190
. L +^TMP("ZISTCPS",$J) ; Get lock that tells us data is ready
11191
"RTN","ZISTCPS",109,0)
11192
. S RTN=$G(^TMP("ZISTCPS",$J)) ; Get entry point
11193
"RTN","ZISTCPS",110,0)
11194
. L -^TMP("ZISTCPS",$J) ; release entry point lock
11195
"RTN","ZISTCPS",111,0)
11196
. H:RTN="" 1 ; We did not get a entry point, so wait a second for server to populate
11197
"RTN","ZISTCPS",112,0)
11198
. Q
11199
"RTN","ZISTCPS",113,0)
11200
K ^TMP("ZISTCPS",$J)
11201
"RTN","ZISTCPS",114,0)
11202
N NIO,SOCK,ZISOS,EXIT,XQVOL,$ETRAP
11203
"RTN","ZISTCPS",115,0)
11204
S U="^",$ETRAP="D ^%ZTER L HALT"
11205
"RTN","ZISTCPS",116,0)
11206
S (IO,IO(0))=$P,IO(1,IO)=""
11207
"RTN","ZISTCPS",117,0)
11208
D VAR,@RTN
11209
"RTN","ZISTCPS",118,0)
11210
Q
11211
"RTN","ZISTCPS",119,0)
11212
;
11213
"RTN","ZISTCPS",120,0)
11214
LOG(MSG) ;LOG STATUS
11215
"RTN","ZISTCPS",121,0)
11216
N CNT
11217
"RTN","ZISTCPS",122,0)
11218
S CNT=$G(^TMP("ZISTCP",$J))+1,^TMP("ZISTCP",$J)=CNT,^($J,CNT)=MSG
11219
"RTN","ZISTCPS",123,0)
11220
Q
11221
"RTN","ZISTCPS",124,0)
11222
;
11223
"RTN","ZOSFGUX")
11224
0^14^B22502126
11225
"RTN","ZOSFGUX",1,0)
11226
ZOSFGUX ;SFISC/MVB,PUG/TOAD MSC/JDS,JKT,JDA- ZOSF Table for GT.M for Unix ;22OCT2009
11227
"RTN","ZOSFGUX",2,0)
11228
;;8.0;KERNEL;**275,MSC**;Jul 10, 1995
11229
"RTN","ZOSFGUX",3,0)
11230
;; for GT.M for Unix, version 4.3
11231
"RTN","ZOSFGUX",4,0)
11232
;
11233
"RTN","ZOSFGUX",5,0)
11234
S %Y=1,DTIME=$G(DTIME,600)
11235
"RTN","ZOSFGUX",6,0)
11236
K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF")
11237
"RTN","ZOSFGUX",7,0)
11238
I '$D(^%ZOSF("VOL")) S ^%ZOSF("VOL")="ROU"
11239
"RTN","ZOSFGUX",8,0)
11240
K ZO F I="MGR","PROD","VOL","TMP" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I)
11241
"RTN","ZOSFGUX",9,0)
11242
F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z="" S X=$P($T(Z+1+I),";;",2,99) S:Z="OS" $P(^%ZOSF(Z),"^")=X I Z'="OS" S ^%ZOSF(Z)=$S($D(ZO(Z)):ZO(Z),1:X)
11243
"RTN","ZOSFGUX",10,0)
11244
;
11245
"RTN","ZOSFGUX",11,0)
11246
OS S ^%ZOSF("OS")="GT.M (Unix)^19"
11247
"RTN","ZOSFGUX",12,0)
11248
;
11249
"RTN","ZOSFGUX",13,0)
11250
MGR W !,"NAME OF MANAGER'S UCI,VOLUME SET: "_^%ZOSF("MGR")_"// " R X:DTIME I X]"" X ^("UCICHECK") G MGR:0[Y S ^%ZOSF("MGR")=X
11251
"RTN","ZOSFGUX",14,0)
11252
PROD ;
11253
"RTN","ZOSFGUX",15,0)
11254
W !,"The value of PRODUCTION will be used in the GETENV api."
11255
"RTN","ZOSFGUX",16,0)
11256
W !,"PRODUCTION (SIGN-ON) UCI,VOLUME SET: "_^%ZOSF("PROD")_"// " R X:DTIME I X]"" X ^("UCICHECK") G PROD:0[Y S ^%ZOSF("PROD")=X
11257
"RTN","ZOSFGUX",17,0)
11258
;See that VOL and PROD agree.
11259
"RTN","ZOSFGUX",18,0)
11260
I ^%ZOSF("PROD")'[^%ZOSF("VOL") S ^%ZOSF("VOL")=$P(^%ZOSF("PROD"),",",2)
11261
"RTN","ZOSFGUX",19,0)
11262
VOL W !,"The VOLUME name must match the one in PRODUCTION."
11263
"RTN","ZOSFGUX",20,0)
11264
W !,"NAME OF VOLUME SET: "_^%ZOSF("VOL")_"//" R X:DTIME
11265
"RTN","ZOSFGUX",21,0)
11266
I X]"" D I X'?3U W "MUST BE 3 Upper case." G VOL
11267
"RTN","ZOSFGUX",22,0)
11268
. I ^%ZOSF("PROD")'[X W !,"Must match PRODUCTION"
11269
"RTN","ZOSFGUX",23,0)
11270
. S:X?3U ^%ZOSF("VOL")=X
11271
"RTN","ZOSFGUX",24,0)
11272
TMP ;Get the temp directory
11273
"RTN","ZOSFGUX",25,0)
11274
W !,"The temp directory for the system: '"_^%ZOSF("TMP")_"'//"
11275
"RTN","ZOSFGUX",26,0)
11276
R X:DTIME I $L(X),X'?1"/".E G TMP
11277
"RTN","ZOSFGUX",27,0)
11278
I $L(X) S ^%ZOSF("TMP")=X
11279
"RTN","ZOSFGUX",28,0)
11280
W !,"^%ZOSF setup"
11281
"RTN","ZOSFGUX",29,0)
11282
Q
11283
"RTN","ZOSFGUX",30,0)
11284
;
11285
"RTN","ZOSFGUX",31,0)
11286
Z ;
11287
"RTN","ZOSFGUX",32,0)
11288
;;ACTJ
11289
"RTN","ZOSFGUX",33,0)
11290
;;S Y=$$ACTJ^%ZOSV()
11291
"RTN","ZOSFGUX",34,0)
11292
;;AVJ
11293
"RTN","ZOSFGUX",35,0)
11294
;;S Y=$$AVJ^%ZOSV()
11295
"RTN","ZOSFGUX",36,0)
11296
;;BRK
11297
"RTN","ZOSFGUX",37,0)
11298
;;U $I:(CENABLE)
11299
"RTN","ZOSFGUX",38,0)
11300
;;DEL
11301
"RTN","ZOSFGUX",39,0)
11302
;;N %RD,%OD S %RD=$P($S($ZRO["(":$P($P($ZRO,"(",2),")"),1:$ZRO)," ")_"/",%OD=$S($ZRO["(":$P($ZRO,"(",1)_"/",1:%RD) ZSYSTEM "rm -f "_%RD_X_".m" ZSYSTEM "rm -f "_%OD_X_".o"
11303
"RTN","ZOSFGUX",40,0)
11304
;;EOFF
11305
"RTN","ZOSFGUX",41,0)
11306
;;U $I:(NOECHO)
11307
"RTN","ZOSFGUX",42,0)
11308
;;EON
11309
"RTN","ZOSFGUX",43,0)
11310
;;U $I:(ECHO)
11311
"RTN","ZOSFGUX",44,0)
11312
;;EOT
11313
"RTN","ZOSFGUX",45,0)
11314
;;S Y=$ZA\1024#2 ; <=====
11315
"RTN","ZOSFGUX",46,0)
11316
;;ERRTN
11317
"RTN","ZOSFGUX",47,0)
11318
;;^%ZTER
11319
"RTN","ZOSFGUX",48,0)
11320
;;ETRP
11321
"RTN","ZOSFGUX",49,0)
11322
;;Q
11323
"RTN","ZOSFGUX",50,0)
11324
;;GD
11325
"RTN","ZOSFGUX",51,0)
11326
;;G ^%GD
11327
"RTN","ZOSFGUX",52,0)
11328
;;$INC
11329
"RTN","ZOSFGUX",53,0)
11330
;;0
11331
"RTN","ZOSFGUX",54,0)
11332
;;JOBPARAM
11333
"RTN","ZOSFGUX",55,0)
11334
;;G JOBPAR^%ZOSV
11335
"RTN","ZOSFGUX",56,0)
11336
;;LABOFF
11337
"RTN","ZOSFGUX",57,0)
11338
;;U IO:(NOECHO) ; <=====
11339
"RTN","ZOSFGUX",58,0)
11340
;;LOAD
11341
"RTN","ZOSFGUX",59,0)
11342
;;D LOAD^%ZOSV2(X) ;S %N=0 F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N^@X) Q:$L(%)=0 S @(DIF_XCNP_",0)")=%
11343
"RTN","ZOSFGUX",60,0)
11344
;;LPC
11345
"RTN","ZOSFGUX",61,0)
11346
;;N R,I S R=$ZBITSTR(8,0) F I=1:1:$L(X) S R=$ZBITXOR(R,$C(0)_$E(X,I)) S Y=$A(R,2)
11347
"RTN","ZOSFGUX",62,0)
11348
;;MAGTAPE
11349
"RTN","ZOSFGUX",63,0)
11350
;;S %MT("BS")="*1",%MT("FS")="*2",%MT("WTM")="*3",%MT("WB")="*4",%MT("REW")="*5",%MT("RB")="*6",%MT("REL")="*7",%MT("WHL")="*8",%MT("WEL")="*9" ; <=====
11351
"RTN","ZOSFGUX",64,0)
11352
;;MAXSIZ
11353
"RTN","ZOSFGUX",65,0)
11354
;;Q
11355
"RTN","ZOSFGUX",66,0)
11356
;;MGR
11357
"RTN","ZOSFGUX",67,0)
11358
;;VAH,ROU
11359
"RTN","ZOSFGUX",68,0)
11360
;;MTBOT
11361
"RTN","ZOSFGUX",69,0)
11362
;;S Y=$ZA\32#2 ; <=====
11363
"RTN","ZOSFGUX",70,0)
11364
;;MTERR
11365
"RTN","ZOSFGUX",71,0)
11366
;;S Y=$ZA\32768#2 ; <=====
11367
"RTN","ZOSFGUX",72,0)
11368
;;MTONLINE
11369
"RTN","ZOSFGUX",73,0)
11370
;;S Y=$ZA\64#2 ; <=====
11371
"RTN","ZOSFGUX",74,0)
11372
;;MTWPROT
11373
"RTN","ZOSFGUX",75,0)
11374
;;S Y=$ZA\4#2 ; <=====
11375
"RTN","ZOSFGUX",76,0)
11376
;;NBRK
11377
"RTN","ZOSFGUX",77,0)
11378
;;U $I:(NOCENABLE)
11379
"RTN","ZOSFGUX",78,0)
11380
;;NO-PASSALL
11381
"RTN","ZOSFGUX",79,0)
11382
;;U $I:(NOPASSTHRU)
11383
"RTN","ZOSFGUX",80,0)
11384
;;NO-TYPE-AHEAD
11385
"RTN","ZOSFGUX",81,0)
11386
;;U $I:(NOTYPEAHEAD)
11387
"RTN","ZOSFGUX",82,0)
11388
;;PASSALL
11389
"RTN","ZOSFGUX",83,0)
11390
;;U $I:(PASSTHRU)
11391
"RTN","ZOSFGUX",84,0)
11392
;;PRIINQ
11393
"RTN","ZOSFGUX",85,0)
11394
;;S Y=$$PRIINQ^%ZOSV()
11395
"RTN","ZOSFGUX",86,0)
11396
;;PRIORITY
11397
"RTN","ZOSFGUX",87,0)
11398
;;Q ;G PRIORITY^%ZOSV
11399
"RTN","ZOSFGUX",88,0)
11400
;;PROD
11401
"RTN","ZOSFGUX",89,0)
11402
;;VAH,ROU
11403
"RTN","ZOSFGUX",90,0)
11404
;;PROGMODE
11405
"RTN","ZOSFGUX",91,0)
11406
;;S Y=$$PROGMODE^%ZOSV()
11407
"RTN","ZOSFGUX",92,0)
11408
;;RD
11409
"RTN","ZOSFGUX",93,0)
11410
;;G ^%RD
11411
"RTN","ZOSFGUX",94,0)
11412
;;RESJOB
11413
"RTN","ZOSFGUX",95,0)
11414
;;Q:'$D(DUZ) Q:'$D(^XUSEC("XUMGR",+DUZ)) N XQZ S XQZ="^FORCEX[MGR]" D DO^%XUCI ; <=====
11415
"RTN","ZOSFGUX",96,0)
11416
;;RM
11417
"RTN","ZOSFGUX",97,0)
11418
;;U $I:WIDTH=$S('X:9999,1:X)
11419
"RTN","ZOSFGUX",98,0)
11420
;;RSEL
11421
"RTN","ZOSFGUX",99,0)
11422
;;K ^UTILITY($J) D ^%RSEL S X="" X "F S X=$O(%ZR(X)) Q:X="""" S ^UTILITY($J,X)=""""" K %ZR
11423
"RTN","ZOSFGUX",100,0)
11424
;;RSUM
11425
"RTN","ZOSFGUX",101,0)
11426
;;S Y=0 F %=1,3:1 S %1=$T(+%^@X),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
11427
"RTN","ZOSFGUX",102,0)
11428
;;SS
11429
"RTN","ZOSFGUX",103,0)
11430
;;D ^%SS
11431
"RTN","ZOSFGUX",104,0)
11432
;;SAVE
11433
"RTN","ZOSFGUX",105,0)
11434
;;D SAVE^%ZOSV2(X) ;N %I,%F S %I=$I,%F=$P($S($ZRO["(":$P($P($ZRO,"(",2),")"),1:$ZRO)," ")_"/"_X_".m" O %F:(NEWVERSION) U %F X "F S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN S %=@(DIE_XCN_"",0)"") Q:$E(%,1)=""$"" I $E(%)'="";"" W %,!" C %F U %I
11435
"RTN","ZOSFGUX",106,0)
11436
;;SIZE
11437
"RTN","ZOSFGUX",107,0)
11438
;;S Y=0 F I=1:1 S %=$T(+I) Q:%="" S Y=Y+$L(%)+2 ; <=====
11439
"RTN","ZOSFGUX",108,0)
11440
;;TEST
11441
"RTN","ZOSFGUX",109,0)
11442
;;I X]"",$T(^@X)]""
11443
"RTN","ZOSFGUX",110,0)
11444
;;TMK
11445
"RTN","ZOSFGUX",111,0)
11446
;;S Y=$ZA\16384#2
11447
"RTN","ZOSFGUX",112,0)
11448
;;TMP
11449
"RTN","ZOSFGUX",113,0)
11450
;;/tmp/
11451
"RTN","ZOSFGUX",114,0)
11452
;;TRAP
11453
"RTN","ZOSFGUX",115,0)
11454
;;$ZT="G "_X
11455
"RTN","ZOSFGUX",116,0)
11456
;;TRMOFF
11457
"RTN","ZOSFGUX",117,0)
11458
;;U $I:(TERMINATOR="")
11459
"RTN","ZOSFGUX",118,0)
11460
;;TRMON
11461
"RTN","ZOSFGUX",119,0)
11462
;;U $I:(TERMINATOR=$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127))
11463
"RTN","ZOSFGUX",120,0)
11464
;;TRMRD
11465
"RTN","ZOSFGUX",121,0)
11466
;;S Y=$A($ZB)
11467
"RTN","ZOSFGUX",122,0)
11468
;;TYPE-AHEAD
11469
"RTN","ZOSFGUX",123,0)
11470
;;U $I:(TYPEAHEAD)
11471
"RTN","ZOSFGUX",124,0)
11472
;;UCI
11473
"RTN","ZOSFGUX",125,0)
11474
;;S Y=^%ZOSF("PROD")
11475
"RTN","ZOSFGUX",126,0)
11476
;;UCICHECK
11477
"RTN","ZOSFGUX",127,0)
11478
;;S Y=1
11479
"RTN","ZOSFGUX",128,0)
11480
;;UPPERCASE
11481
"RTN","ZOSFGUX",129,0)
11482
;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
11483
"RTN","ZOSFGUX",130,0)
11484
;;XY
11485
"RTN","ZOSFGUX",131,0)
11486
;;S $X=DX,$Y=DY ; <=====
11487
"RTN","ZOSFGUX",132,0)
11488
;;VOL
11489
"RTN","ZOSFGUX",133,0)
11490
;;ROU
11491
"RTN","ZOSFGUX",134,0)
11492
;;ZD
11493
"RTN","ZOSFGUX",135,0)
11494
;;S Y=$$HTE^XLFDT(X,2) I $L($P(Y,"/"))=1 S Y=0_Y
11495
"RTN","ZOSV2GTM")
11496
0^13^B7713680
11497
"RTN","ZOSV2GTM",1,0)
11498
%ZOSV2 ;ISF/RWF MSC/JDS,JKT - More GT.M support routines ;2DEC2009
11499
"RTN","ZOSV2GTM",2,0)
11500
;;8.0;KERNEL;**275,MSC**;Jul 10, 1995
11501
"RTN","ZOSV2GTM",3,0)
11502
Q
11503
"RTN","ZOSV2GTM",4,0)
11504
;SAVE: DIE open array reference.
11505
"RTN","ZOSV2GTM",5,0)
11506
; XCN is the starting value to $O from.
11507
"RTN","ZOSV2GTM",6,0)
11508
SAVE(RN) ;Save a routine
11509
"RTN","ZOSV2GTM",7,0)
11510
N %,%F,%I,%N,SP,$ETRAP,%S
11511
"RTN","ZOSV2GTM",8,0)
11512
S $ETRAP="S $ECODE="""" Q"
11513
"RTN","ZOSV2GTM",9,0)
11514
S %I=$I,SP=" ",%F=$$RTNDIR^%ZOSV()_RN_".m"
11515
"RTN","ZOSV2GTM",10,0)
11516
O %F:(newversion:noreadonly:blocksize=2048:recordsize=2044) U %F
11517
"RTN","ZOSV2GTM",11,0)
11518
N Q,ZS,I S Q=+$G(XCN) F I=0,1 S Q=$O(@(DIE_Q_")")) Q:Q="" S Q=DIE_Q_")",Q=$Q(@Q) Q:Q'["0)" S Q=$O(@(DIE_$QS(Q,$L(DIE,",")+1)_")")) Q:Q="" S:I ZS=1
11519
"RTN","ZOSV2GTM",12,0)
11520
F S XCN=$O(@(DIE_+$G(XCN)_")")) Q:XCN'>0 S %=@(DIE_XCN_$S($G(ZS):",0",1:"")_")") Q:$E(%,1)="$" I $E(%)'=";" W $P(%,SP)_$C(9)_$P(%,SP,2,99999),!
11521
"RTN","ZOSV2GTM",13,0)
11522
C %F ;S %N=$$NULL
11523
"RTN","ZOSV2GTM",14,0)
11524
;C %N
11525
"RTN","ZOSV2GTM",15,0)
11526
U %I
11527
"RTN","ZOSV2GTM",16,0)
11528
ZLINK RN
11529
"RTN","ZOSV2GTM",17,0)
11530
Q
11531
"RTN","ZOSV2GTM",18,0)
11532
NULL() ;Open and use null to hide talking. Return open name
11533
"RTN","ZOSV2GTM",19,0)
11534
;Doesn't work for compile errors
11535
"RTN","ZOSV2GTM",20,0)
11536
N %N S %N=$S($ZV["VMS":"NLA0:",1:"/dev/null")
11537
"RTN","ZOSV2GTM",21,0)
11538
O %N U %N
11539
"RTN","ZOSV2GTM",22,0)
11540
Q %N
11541
"RTN","ZOSV2GTM",23,0)
11542
;
11543
"RTN","ZOSV2GTM",24,0)
11544
DEL(RN) ;Delete a routine file, both source and object.
11545
"RTN","ZOSV2GTM",25,0)
11546
; Since the actual routine may be somewhere in a search path, and may be shared
11547
"RTN","ZOSV2GTM",26,0)
11548
; with other environments, this places a routine in the first source directory in
11549
"RTN","ZOSV2GTM",27,0)
11550
; the search path, which, if executed, generates an error to the effect that the
11551
"RTN","ZOSV2GTM",28,0)
11552
; called routine doesn't exist (i.e., it's a way to effect a deletion without
11553
"RTN","ZOSV2GTM",29,0)
11554
; actually deleting the routine).
11555
"RTN","ZOSV2GTM",30,0)
11556
N %N,%DIR,%I,$ETRAP,%F,%O,%S
11557
"RTN","ZOSV2GTM",31,0)
11558
S $ETRAP="S $ECODE="""" Q"
11559
"RTN","ZOSV2GTM",32,0)
11560
D SILENT^%RSEL(RN) S %S=%ZR(RN) ; %S now has the directory of the source
11561
"RTN","ZOSV2GTM",33,0)
11562
D SILENT^%RSEL(RN,"OBJ") S %O=%ZR(RN) ; %O now has the directory of the object
11563
"RTN","ZOSV2GTM",34,0)
11564
S %DIR=$$RTNDIR^%ZOSV ; %DIR now has the first source directory in $ZRO
11565
"RTN","ZOSV2GTM",35,0)
11566
S %N=$TR(RN,"%","_") ; %N now has the file name for RN (sans extension)
11567
"RTN","ZOSV2GTM",36,0)
11568
I $ZPARSE(%S)'=$ZPARSE(%DIR) D
11569
"RTN","ZOSV2GTM",37,0)
11570
.S %I=$I,%F=%DIR_%N_".m"
11571
"RTN","ZOSV2GTM",38,0)
11572
.O %F:(NEWVERSION) U %F W " ZM 150374338:$P($ZPOS,""^"",2) Q",! U %I C %F
11573
"RTN","ZOSV2GTM",39,0)
11574
E ZSY "rm -f "_%S_%N_".m "_%S_%N_".o"
11575
"RTN","ZOSV2GTM",40,0)
11576
Q
11577
"RTN","ZOSV2GTM",41,0)
11578
;LOAD: DIF open array to receive the routine lines.
11579
"RTN","ZOSV2GTM",42,0)
11580
; XCNP The starting index -1.
11581
"RTN","ZOSV2GTM",43,0)
11582
LOAD(RN) ;Load a routine
11583
"RTN","ZOSV2GTM",44,0)
11584
N %
11585
"RTN","ZOSV2GTM",45,0)
11586
S %N=0 F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N^@RN) Q:$L(%)=0 S @(DIF_XCNP_",0)")=%
11587
"RTN","ZOSV2GTM",46,0)
11588
Q
11589
"RTN","ZOSV2GTM",47,0)
11590
;
11591
"RTN","ZOSV2GTM",48,0)
11592
LOAD2(RN) ;Load a routine
11593
"RTN","ZOSV2GTM",49,0)
11594
N %,%1,%F,%N,$ETRAP
11595
"RTN","ZOSV2GTM",50,0)
11596
S %I=$I,%F=$$RTNDIR^%ZOSV()_$TR(RN,"%","_")_".m"
11597
"RTN","ZOSV2GTM",51,0)
11598
O %F:(readonly):1 Q:'$T U %F
11599
"RTN","ZOSV2GTM",52,0)
11600
F XCNP=XCNP+1:1 R %1:1 Q:'$T!$ZEOF S @(DIF_XCNP_",0)")=$TR(%1,$C(9)," ")
11601
"RTN","ZOSV2GTM",53,0)
11602
C %F I $L(%I) U %I
11603
"RTN","ZOSV2GTM",54,0)
11604
Q
11605
"RTN","ZOSV2GTM",55,0)
11606
;
11607
"RTN","ZOSV2GTM",56,0)
11608
RSUM(RN) ;Calculate a RSUM value
11609
"RTN","ZOSV2GTM",57,0)
11610
N %,DIF,XCNP,%N,Y,$ETRAP K ^TMP("RSUM",$J)
11611
"RTN","ZOSV2GTM",58,0)
11612
S $ETRAP="S $ECODE="""" Q"
11613
"RTN","ZOSV2GTM",59,0)
11614
S Y=0,DIF="^TMP(""RSUM"",$J,",XCNP=0 D LOAD2(RN)
11615
"RTN","ZOSV2GTM",60,0)
11616
F %=1,3:1 S %1=$G(^TMP("RSUM",$J,%,0)),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
11617
"RTN","ZOSV2GTM",61,0)
11618
K ^TMP("RSUM",$J)
11619
"RTN","ZOSV2GTM",62,0)
11620
Q Y
11621
"RTN","ZOSV2GTM",63,0)
11622
;
11623
"RTN","ZOSV2GTM",64,0)
11624
TEST(RN) ;Special GT.M Test to see if routine is here.
11625
"RTN","ZOSV2GTM",65,0)
11626
D SILENT^%RSEL(RN)
11627
"RTN","ZOSV2GTM",66,0)
11628
Q $G(%ZR(RN))
11629
"RTN","ZOSV2GTM",67,0)
11630
11631
"RTN","ZOSVGUX")
11632
0^33^B1197142
11633
"RTN","ZOSVGUX",1,0)
11634
%ZOSV ;SFISC/AC,PUG/TOAD,HOU/DHW,MSC/JDA/JKT - View commands & special functions. ;19OCT2009
11635
"RTN","ZOSVGUX",2,0)
11636
;;8.0;KERNEL;**275,MSC**;Jul 10, 1995
11637
"RTN","ZOSVGUX",3,0)
11638
;
11639
"RTN","ZOSVGUX",4,0)
11640
ACTJ() ; # active jobs
11641
"RTN","ZOSVGUX",5,0)
11642
Q $G(^XUTL("XUSYS",0))
11643
"RTN","ZOSVGUX",6,0)
11644
;This would also work
11645
"RTN","ZOSVGUX",7,0)
11646
N %FILE S %FILE=$$TEMP_"zosv_actj_"_$J_".tmp"
11647
"RTN","ZOSVGUX",8,0)
11648
ZSYSTEM "ps cef -C mumps|wc>"_%FILE
11649
"RTN","ZOSVGUX",9,0)
11650
N %I S %I=$I
11651
"RTN","ZOSVGUX",10,0)
11652
O %FILE
11653
"RTN","ZOSVGUX",11,0)
11654
U %FILE R Y U %I
11655
"RTN","ZOSVGUX",12,0)
11656
C %FILE:DELETE
11657
"RTN","ZOSVGUX",13,0)
11658
F Q:$E(Y)'=" " S $E(Y)=""
11659
"RTN","ZOSVGUX",14,0)
11660
S Y=Y-1
11661
"RTN","ZOSVGUX",15,0)
11662
Q Y
11663
"RTN","ZOSVGUX",16,0)
11664
;
11665
"RTN","ZOSVGUX",17,0)
11666
RTNDIR() ; primary routine source directory
11667
"RTN","ZOSVGUX",18,0)
11668
; If $ZRO is a single directory, e.g., xxx, returns that directory, e.g., xxx/
11669
"RTN","ZOSVGUX",19,0)
11670
; If $ZRO is of the form xxx yyy ... returns xxx/
11671
"RTN","ZOSVGUX",20,0)
11672
; If $ZRO is of the form www(xxx) ... or www(xxx yyy) ... returns xxx/
11673
"RTN","ZOSVGUX",21,0)
11674
Q $P($S(($F($ZRO_" "," ")>$F($ZRO,"("))&$F($ZRO,"("):$P($P($ZRO,")"),"(",2),1:$ZRO)," ")_"/" ;
11675
"RTN","ZOSVGUX",22,0)
11676
TEMP() ; Return path to temp directory
11677
"RTN","ZOSVGUX",23,0)
11678
;N %TEMP S %TEMP=$P($$RTNDIR," "),%TEMP=$P(%TEMP,"/",1,$L(%TEMP,"/")-2)_"/t/"
11679
"RTN","ZOSVGUX",24,0)
11680
Q $G(^%ZOSF("TMP"),"/tmp/")
11681
"RTN","ZOSVGUX",25,0)
11682
;
11683
"RTN","ZOSVGUX",26,0)
11684
AVJ() ; # available jobs
11685
"RTN","ZOSVGUX",27,0)
11686
Q $G(^%ZTSCH("MAXJOBS"),1000)-$$ACTJ
11687
"RTN","ZOSVGUX",28,0)
11688
;
11689
"RTN","ZOSVGUX",29,0)
11690
PASSALL ;
11691
"RTN","ZOSVGUX",30,0)
11692
U $I:(PASTHRU) Q ; <=====
11693
"RTN","ZOSVGUX",31,0)
11694
NOPASS ;
11695
"RTN","ZOSVGUX",32,0)
11696
U $I:(NOPASTHRU) Q ; <=====
11697
"RTN","ZOSVGUX",33,0)
11698
;
11699
"RTN","ZOSVGUX",34,0)
11700
GETPEER() ;Get the IP address of a connection peer
11701
"RTN","ZOSVGUX",35,0)
11702
Q $S($L($G(IO("GTM-IP"))):IO("GTM-IP"),1:"")
11703
"RTN","ZOSVGUX",36,0)
11704
;
11705
"RTN","ZOSVGUX",37,0)
11706
LOG(MSG,PRIORITY,TAG)
11707
"RTN","ZOSVGUX",38,0)
11708
NEW CMD,A
11709
"RTN","ZOSVGUX",39,0)
11710
S CMD="logger"
11711
"RTN","ZOSVGUX",40,0)
11712
S:$G(PRIORITY)'="" CMD=CMD_" -p "_PRIORITY
11713
"RTN","ZOSVGUX",41,0)
11714
S:$G(TAG)'="" CMD=CMD_" -t "_TAG
11715
"RTN","ZOSVGUX",42,0)
11716
S CMD=CMD_" -- "_MSG
11717
"RTN","ZOSVGUX",43,0)
11718
S A="LOGDEV" OPEN A:(COMM=CMD)::"PIPE" U A C A
11719
"RTN","ZOSVGUX",44,0)
11720
Q
11721
"RTN","ZOSVGUX",45,0)
11722
PRGMODE ; <=====
11723
"RTN","ZOSVGUX",46,0)
11724
N USER,ISOK,LOGTEXT,RDIR
11725
"RTN","ZOSVGUX",47,0)
11726
S ISOK=$$AUTH(.USER)
11727
"RTN","ZOSVGUX",48,0)
11728
Q:USER="^"
11729
"RTN","ZOSVGUX",49,0)
11730
S RDIR=$$RTNDIR^%ZOSV
11731
"RTN","ZOSVGUX",50,0)
11732
S LOGTEXT=$S(ISOK:"Granted",1:"Denied")_" programmer mode in "
11733
"RTN","ZOSVGUX",51,0)
11734
S LOGTEXT=LOGTEXT_$P(RDIR,"/",$L(RDIR,"/")-2) ; instance
11735
"RTN","ZOSVGUX",52,0)
11736
S LOGTEXT=LOGTEXT_" to "_USER ; Unix acct name
11737
"RTN","ZOSVGUX",53,0)
11738
S LOGTEXT=LOGTEXT_" from "_$P($ZTRNLNM("SSH_CLIENT")," ",1) ; remote loc
11739
"RTN","ZOSVGUX",54,0)
11740
S LOGTEXT=LOGTEXT_" logged in as "_$$GET1^DIQ(200,DUZ,.01) ; VistA user
11741
"RTN","ZOSVGUX",55,0)
11742
D LOG(LOGTEXT,"authpriv.info","OpenVista")
11743
"RTN","ZOSVGUX",56,0)
11744
I 'ISOK W "??",*7 Q
11745
"RTN","ZOSVGUX",57,0)
11746
K XMB,XMTEXT,XMY S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$L($T(^XMB)) D BYE^XUSCLEAN K ZTPAC,X,XMB
11747
"RTN","ZOSVGUX",58,0)
11748
;D UCI S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI
11749
"RTN","ZOSVGUX",59,0)
11750
F BREAK
11751
"RTN","ZOSVGUX",60,0)
11752
HALT
11753
"RTN","ZOSVGUX",61,0)
11754
;
11755
"RTN","ZOSVGUX",62,0)
11756
PROGMODE() ; <=====
11757
"RTN","ZOSVGUX",63,0)
11758
Q 1 ; until we fix this, we're never in application mode
11759
"RTN","ZOSVGUX",64,0)
11760
;
11761
"RTN","ZOSVGUX",65,0)
11762
AUTH(USER) ;
11763
"RTN","ZOSVGUX",66,0)
11764
N PASS
11765
"RTN","ZOSVGUX",67,0)
11766
N IDDEV S IDDEV="id",OLDIO=$IO
11767
"RTN","ZOSVGUX",68,0)
11768
O IDDEV:(COMMAND="id -un":READONLY)::"PIPE" U IDDEV R USER C IDDEV U OLDIO
11769
"RTN","ZOSVGUX",69,0)
11770
Q:USER'="openvista" 1
11771
"RTN","ZOSVGUX",70,0)
11772
D INITKB^XGF()
11773
"RTN","ZOSVGUX",71,0)
11774
W !,"System user name: "
11775
"RTN","ZOSVGUX",72,0)
11776
S USER=$$READ^XGF() Q:USER="^" 0
11777
"RTN","ZOSVGUX",73,0)
11778
X ^%ZOSF("EOFF")
11779
"RTN","ZOSVGUX",74,0)
11780
W !,"System password: "
11781
"RTN","ZOSVGUX",75,0)
11782
S PASS=$$READ^XGF()
11783
"RTN","ZOSVGUX",76,0)
11784
X ^%ZOSF("EON") I PASS="^" S USER="^" Q 0
11785
"RTN","ZOSVGUX",77,0)
11786
W !
11787
"RTN","ZOSVGUX",78,0)
11788
N DEV,OLDIO,STATUS
11789
"RTN","ZOSVGUX",79,0)
11790
S DEV="ovauth",OLDIO=$IO,STATUS="Problem opening pipe"
11791
"RTN","ZOSVGUX",80,0)
11792
O DEV:(COMMAND="/sbin/ovauth "_USER:PARSE:INDEPENDENT:EXCEPTION="G AUTHDONE")::"PIPE"
11793
"RTN","ZOSVGUX",81,0)
11794
U DEV W PASS R STATUS
11795
"RTN","ZOSVGUX",82,0)
11796
AUTHDONE
11797
"RTN","ZOSVGUX",83,0)
11798
U OLDIO
11799
"RTN","ZOSVGUX",84,0)
11800
C DEV
11801
"RTN","ZOSVGUX",85,0)
11802
; W STATUS,! ; Comment this back in to see what went wrong
11803
"RTN","ZOSVGUX",86,0)
11804
Q STATUS="OK"
11805
"RTN","ZOSVGUX",87,0)
11806
UCI ;
11807
"RTN","ZOSVGUX",88,0)
11808
S Y=^%ZOSF("PROD") Q
11809
"RTN","ZOSVGUX",89,0)
11810
;
11811
"RTN","ZOSVGUX",90,0)
11812
UCICHECK(X) ;
11813
"RTN","ZOSVGUX",91,0)
11814
Q X
11815
"RTN","ZOSVGUX",92,0)
11816
;
11817
"RTN","ZOSVGUX",93,0)
11818
JOBPAR ; <=====
11819
"RTN","ZOSVGUX",94,0)
11820
; See if X points to a valid Job. Return its UCI.
11821
"RTN","ZOSVGUX",95,0)
11822
; FIXME: currently returns "VAH,ROU" instead of the real UCI (or "" if X is not
11823
"RTN","ZOSVGUX",96,0)
11824
; the $J of a mumps process)
11825
"RTN","ZOSVGUX",97,0)
11826
S Y=$$RETURN("ps c -p "_X_" | tail -1")
11827
"RTN","ZOSVGUX",98,0)
11828
F Q:$E(Y)'=" " S $E(Y)=""
11829
"RTN","ZOSVGUX",99,0)
11830
I +Y=X,$E(Y,$L(Y)-4,$L(Y))="mumps" S Y="VAH,ROU"
11831
"RTN","ZOSVGUX",100,0)
11832
E S Y=""
11833
"RTN","ZOSVGUX",101,0)
11834
Q
11835
"RTN","ZOSVGUX",102,0)
11836
;
11837
"RTN","ZOSVGUX",103,0)
11838
PRIORITY ; <=====
11839
"RTN","ZOSVGUX",104,0)
11840
K Y ; Wally has this disabled in general, but I'd like to bring it back
11841
"RTN","ZOSVGUX",105,0)
11842
Q
11843
"RTN","ZOSVGUX",106,0)
11844
;
11845
"RTN","ZOSVGUX",107,0)
11846
PRIINQ() ; <=====
11847
"RTN","ZOSVGUX",108,0)
11848
Q 5 ; for now, we're always middle of the road
11849
"RTN","ZOSVGUX",109,0)
11850
;
11851
"RTN","ZOSVGUX",110,0)
11852
BAUD S X="UNKNOWN" Q
11853
"RTN","ZOSVGUX",111,0)
11854
;
11855
"RTN","ZOSVGUX",112,0)
11856
LGR() ; Last global reference ($REFERENCE)
11857
"RTN","ZOSVGUX",113,0)
11858
Q $R
11859
"RTN","ZOSVGUX",114,0)
11860
;
11861
"RTN","ZOSVGUX",115,0)
11862
EC() ; Error Code: returning $ZS in format more like $ZE from DSM
11863
"RTN","ZOSVGUX",116,0)
11864
N %ZE
11865
"RTN","ZOSVGUX",117,0)
11866
I $ZS="" S %ZE=""
11867
"RTN","ZOSVGUX",118,0)
11868
S %ZE=$P($ZS,",",2)_","_$P($ZS,",",4)_","_$P($ZS,",")_",-"_$P($ZS,",",3)
11869
"RTN","ZOSVGUX",119,0)
11870
Q %ZE
11871
"RTN","ZOSVGUX",120,0)
11872
;
11873
"RTN","ZOSVGUX",121,0)
11874
DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
11875
"RTN","ZOSVGUX",122,0)
11876
S Y="%" F S Y=$O(@Y) Q:Y="" D ;code from DEC
11877
"RTN","ZOSVGUX",123,0)
11878
. I $D(@Y)#2 S @(X_"Y)="_Y)
11879
"RTN","ZOSVGUX",124,0)
11880
. I $D(@Y)>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
11881
"RTN","ZOSVGUX",125,0)
11882
K %X,%Y,Y Q
11883
"RTN","ZOSVGUX",126,0)
11884
;
11885
"RTN","ZOSVGUX",127,0)
11886
ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X
11887
"RTN","ZOSVGUX",128,0)
11888
I Y="*" D DOLRO Q
11889
"RTN","ZOSVGUX",129,0)
11890
S (Y,Y1)=$P(Y,"*",1) I $D(@Y)=0 F %=0:0 S Y=$O(@Y) Q:Y=""!(Y[Y1)
11891
"RTN","ZOSVGUX",130,0)
11892
Q:Y="" S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
11893
"RTN","ZOSVGUX",131,0)
11894
F %=0:0 S Y=$O(@Y) Q:Y=""!(Y'[Y1) S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
11895
"RTN","ZOSVGUX",132,0)
11896
K %,X,Y,Y1
11897
"RTN","ZOSVGUX",133,0)
11898
Q
11899
"RTN","ZOSVGUX",134,0)
11900
;
11901
"RTN","ZOSVGUX",135,0)
11902
PARSIZ ;
11903
"RTN","ZOSVGUX",136,0)
11904
S X=3 Q
11905
"RTN","ZOSVGUX",137,0)
11906
;
11907
"RTN","ZOSVGUX",138,0)
11908
NOLOG ;
11909
"RTN","ZOSVGUX",139,0)
11910
S Y=0 Q
11911
"RTN","ZOSVGUX",140,0)
11912
;
11913
"RTN","ZOSVGUX",141,0)
11914
GETENV ;Get environment Return Y='UCI^VOL^NODE^BOX LOOKUP'
11915
"RTN","ZOSVGUX",142,0)
11916
; see https://bugs.launchpad.net/openvista-gtm-integration/+bug/422885
11917
"RTN","ZOSVGUX",143,0)
11918
N %HOST,%V S %V=^%ZOSF("PROD"),%HOST=$$RETURN("hostname -s")
11919
"RTN","ZOSVGUX",144,0)
11920
N %CLUSTER S %CLUSTER=$G(^%ZOSF("CLUSTER")) I %CLUSTER="" S %CLUSTER=%HOST
11921
"RTN","ZOSVGUX",145,0)
11922
S Y=$TR(%V,",","^")_"^"_%HOST_"^"_$P(%V,",",2)_":"_%CLUSTER
11923
"RTN","ZOSVGUX",146,0)
11924
Q
11925
"RTN","ZOSVGUX",147,0)
11926
;
11927
"RTN","ZOSVGUX",148,0)
11928
VERSION(X) ;return OS version, X=1 - return OS
11929
"RTN","ZOSVGUX",149,0)
11930
Q $S($G(X):$P($ZV," V"),1:+$P($ZV," V",2))
11931
"RTN","ZOSVGUX",150,0)
11932
;
11933
"RTN","ZOSVGUX",151,0)
11934
SETNM(X) ;Set name, Trap dup's, Fall into SETENV
11935
"RTN","ZOSVGUX",152,0)
11936
N $ETRAP S $ETRAP="S $ECODE="""" Q"
11937
"RTN","ZOSVGUX",153,0)
11938
;
11939
"RTN","ZOSVGUX",154,0)
11940
SETENV ;Set environment X='PROCESS NAME^ '
11941
"RTN","ZOSVGUX",155,0)
11942
S ^XUTL("XUSYS",$J,0)=$H,^("NM")=X ; workaround
11943
"RTN","ZOSVGUX",156,0)
11944
Q
11945
"RTN","ZOSVGUX",157,0)
11946
;
11947
"RTN","ZOSVGUX",158,0)
11948
SID() ;System ID
11949
"RTN","ZOSVGUX",159,0)
11950
N J1,T S T="~"
11951
"RTN","ZOSVGUX",160,0)
11952
S J1(1)=$ZROUTINES,J1(1)=$P(J1(1)," ")
11953
"RTN","ZOSVGUX",161,0)
11954
S J1(2)=$ZGBLDIR
11955
"RTN","ZOSVGUX",162,0)
11956
Q "1~"_J1(1)_T_J1(2)
11957
"RTN","ZOSVGUX",163,0)
11958
;
11959
"RTN","ZOSVGUX",164,0)
11960
T0 ; start RT clock <=====
11961
"RTN","ZOSVGUX",165,0)
11962
Q ; we don't have $ZH on GT.M
11963
"RTN","ZOSVGUX",166,0)
11964
;
11965
"RTN","ZOSVGUX",167,0)
11966
T1 ; store RT datum w/ZHDIF <=====
11967
"RTN","ZOSVGUX",168,0)
11968
Q ; we don't have $ZH on GT.M
11969
"RTN","ZOSVGUX",169,0)
11970
;
11971
"RTN","ZOSVGUX",170,0)
11972
ZHDIF ;Display dif of two $ZH's <=====
11973
"RTN","ZOSVGUX",171,0)
11974
W !," CPU=",$J($P(%ZH1,",")-$P(%ZH0,","),6,2)
11975
"RTN","ZOSVGUX",172,0)
11976
W ?14," ET=",$J($P(%ZH1,",",2)-$P(%ZH0,",",2),6,1)
11977
"RTN","ZOSVGUX",173,0)
11978
W ?27," DIO=",$J($P(%ZH1,",",7)-$P(%ZH0,",",7),5)
11979
"RTN","ZOSVGUX",174,0)
11980
W ?40," BIO=",$J($P(%ZH1,",",8)-$P(%ZH0,",",8),5),! ; so far this won't be called
11981
"RTN","ZOSVGUX",175,0)
11982
Q
11983
"RTN","ZOSVGUX",176,0)
11984
;
11985
"RTN","ZOSVGUX",177,0)
11986
;Code moved to %ZOSVKR, Comment out if needed.
11987
"RTN","ZOSVGUX",178,0)
11988
LOGRSRC(OPT,TYPE,STATUS) ;record resource usage in ^XTMP("KMPR"
11989
"RTN","ZOSVGUX",179,0)
11990
Q:'$G(^%ZTSCH("LOGRSRC")) ; quit if RUM not turned on.
11991
"RTN","ZOSVGUX",180,0)
11992
; call to RUM routine.
11993
"RTN","ZOSVGUX",181,0)
11994
D RU^%ZOSVKR($G(OPT),$G(TYPE),$G(STATUS))
11995
"RTN","ZOSVGUX",182,0)
11996
Q
11997
"RTN","ZOSVGUX",183,0)
11998
;
11999
"RTN","ZOSVGUX",184,0)
12000
SETTRM(X) ;Turn on specified terminators.
12001
"RTN","ZOSVGUX",185,0)
12002
U $I:(TERM=X)
12003
"RTN","ZOSVGUX",186,0)
12004
Q 1
12005
"RTN","ZOSVGUX",187,0)
12006
;
12007
"RTN","ZOSVGUX",188,0)
12008
DEVOK ;
12009
"RTN","ZOSVGUX",189,0)
12010
;use lsof (list open files)
12011
"RTN","ZOSVGUX",190,0)
12012
; given a device name in X
12013
"RTN","ZOSVGUX",191,0)
12014
;INPUT: X=Device $I, X1=IOT -- X1 needed for resources
12015
"RTN","ZOSVGUX",192,0)
12016
;OUTPUT: Y=0 if available, Y=job # if owned
12017
"RTN","ZOSVGUX",193,0)
12018
; Y=-1 if device does not exists.
12019
"RTN","ZOSVGUX",194,0)
12020
; return Y=0 if not owned, Y=$J of owning job, Y=999 if dev cycling
12021
"RTN","ZOSVGUX",195,0)
12022
;
12023
"RTN","ZOSVGUX",196,0)
12024
I $G(X1)="RES" G RESOK^%ZIS6
12025
"RTN","ZOSVGUX",197,0)
12026
S Y=0
12027
"RTN","ZOSVGUX",198,0)
12028
Q ;Let ZIS deal with it.
12029
"RTN","ZOSVGUX",199,0)
12030
;
12031
"RTN","ZOSVGUX",200,0)
12032
N %FILE S %FILE=$$TEMP_"zosv_devok_"_$J_".tmp"
12033
"RTN","ZOSVGUX",201,0)
12034
ZSYSTEM "/usr/sbin/lsof -F Pc "_X_" >"_%FILE
12035
"RTN","ZOSVGUX",202,0)
12036
N %I,%X,%Y S %I=$I
12037
"RTN","ZOSVGUX",203,0)
12038
O %FILE
12039
"RTN","ZOSVGUX",204,0)
12040
N %I,%X,%Y S %I=$I
12041
"RTN","ZOSVGUX",205,0)
12042
U %FILE
12043
"RTN","ZOSVGUX",206,0)
12044
F %Y=0:1 R %X Q:%X="" Q:%X["lsof: status error" D
12045
"RTN","ZOSVGUX",207,0)
12046
. S %Y(%Y\2,$S($E(%X)="p":"PID",$E(%X)="c":"CMD",1:"?"))=$E(%X,2,$L(%X))
12047
"RTN","ZOSVGUX",208,0)
12048
U %I
12049
"RTN","ZOSVGUX",209,0)
12050
C %FILE:(DELETE)
12051
"RTN","ZOSVGUX",210,0)
12052
I %X["lsof: status error" S Y=-1 Q
12053
"RTN","ZOSVGUX",211,0)
12054
S %X="",Y=0
12055
"RTN","ZOSVGUX",212,0)
12056
F S %X=$O(%Y(%X)) Q:%X="" I %Y(%X,"CMD")="mumps" S Y=%Y(%X,"PID") Q
12057
"RTN","ZOSVGUX",213,0)
12058
Q
12059
"RTN","ZOSVGUX",214,0)
12060
;
12061
"RTN","ZOSVGUX",215,0)
12062
PIDOPN ; give a list of of all JOBS that have the current device open
12063
"RTN","ZOSVGUX",216,0)
12064
; returns comma separated in Y
12065
"RTN","ZOSVGUX",217,0)
12066
N %PIPE S %PIPE="lsof"
12067
"RTN","ZOSVGUX",218,0)
12068
O %PIPE:(COMMAND="lsof -F Pc "_$I:READONLY)::"PIPE"
12069
"RTN","ZOSVGUX",219,0)
12070
N %I,%X,%Y S %I=$I
12071
"RTN","ZOSVGUX",220,0)
12072
U %PIPE
12073
"RTN","ZOSVGUX",221,0)
12074
F %Y=0:1 R %X Q:%X="" S %Y(%Y\2,$S($E(%X)="p":"PID",$E(%X)="c":"CMD",1:"?"))=$E(%X,2,$L(%X))
12075
"RTN","ZOSVGUX",222,0)
12076
U %I
12077
"RTN","ZOSVGUX",223,0)
12078
C %PIPE
12079
"RTN","ZOSVGUX",224,0)
12080
S (Y,%X)="" F S %X=$O(%Y(%X)) Q:%X="" I %Y(%X,"CMD")="mumps" S Y=Y_","_%Y(%X,"PID")
12081
"RTN","ZOSVGUX",225,0)
12082
S $E(Y)=""
12083
"RTN","ZOSVGUX",226,0)
12084
Q
12085
"RTN","ZOSVGUX",227,0)
12086
;
12087
"RTN","ZOSVGUX",228,0)
12088
DEVOPN ;List of Devices opened
12089
"RTN","ZOSVGUX",229,0)
12090
;Returns variable Y. Y=Devices owned separated by a comma
12091
"RTN","ZOSVGUX",230,0)
12092
N %D,%I
12093
"RTN","ZOSVGUX",231,0)
12094
S Y=""
12095
"RTN","ZOSVGUX",232,0)
12096
ZSHOW "D":%D
12097
"RTN","ZOSVGUX",233,0)
12098
S %I="" F S %I=$O(%D("D",%I)) Q:%I="" S Y=Y_","_$P(%D("D",%I)," OPEN ")
12099
"RTN","ZOSVGUX",234,0)
12100
S $E(Y)=""
12101
"RTN","ZOSVGUX",235,0)
12102
Q
12103
"RTN","ZOSVGUX",236,0)
12104
;
12105
"RTN","ZOSVGUX",237,0)
12106
RETURN(%COMMAND) ; ** Private Entry Point: execute a shell command & return the resulting value **
12107
"RTN","ZOSVGUX",238,0)
12108
;
12109
"RTN","ZOSVGUX",239,0)
12110
; %COMMAND is the string value of the Linux command
12111
"RTN","ZOSVGUX",240,0)
12112
N %PIPE,%VALUE
12113
"RTN","ZOSVGUX",241,0)
12114
S %PIPE="pipe"
12115
"RTN","ZOSVGUX",242,0)
12116
O %PIPE:(COMMAND=%COMMAND:READONLY)::"PIPE" U %PIPE R %VALUE C %PIPE
12117
"RTN","ZOSVGUX",243,0)
12118
QUIT %VALUE ; return value
12119
"RTN","ZOSVGUX",244,0)
12120
;
12121
"RTN","ZOSVGUX",245,0)
12122
;
12123
"RTN","ZOSVGUX",246,0)
12124
STRIPCR(%DIRECTORY) ; ** Private Entry Point: strip extraneous CR from end of lines of all
12125
"RTN","ZOSVGUX",247,0)
12126
; routines in %DIRECTORY Linux directory
12127
"RTN","ZOSVGUX",248,0)
12128
;
12129
"RTN","ZOSVGUX",249,0)
12130
ZSYSTEM "perl -pi -e 's/\r\n$/\n/' "_%DIRECTORY_"[A-K]*.m"
12131
"RTN","ZOSVGUX",250,0)
12132
ZSYSTEM "perl -pi -e 's/\r\n$/\n/' "_%DIRECTORY_"[L-S]*.m"
12133
"RTN","ZOSVGUX",251,0)
12134
ZSYSTEM "perl -pi -e 's/\r\n$/\n/' "_%DIRECTORY_"[T-z]*.m"
12135
"RTN","ZOSVGUX",252,0)
12136
ZSYSTEM "perl -pi -e 's/\r\n$/\n/' "_%DIRECTORY_"[_]*.m"
12137
"RTN","ZOSVGUX",253,0)
12138
Q
12139
"RTN","ZOSVGUX",254,0)
12140
;
12141
"RTN","ZOSVONT")
12142
0^47^B23474671
12143
"RTN","ZOSVONT",1,0)
12144
%ZOSV ;SFISC/AC MSC/REC/JKT - $View commands for Open M for NT. ;1JUN2009
12145
"RTN","ZOSVONT",2,0)
12146
;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,MSC**;Jul 10, 1995;Build 3
12147
"RTN","ZOSVONT",3,0)
12148
ACTJ() ;# Active jobs
12149
"RTN","ZOSVONT",4,0)
12150
N %,V,Y S V=$$VERSION()
12151
"RTN","ZOSVONT",5,0)
12152
I V<5 D Q Y
12153
"RTN","ZOSVONT",6,0)
12154
. S %=0 F Y=0:1 S %=$ZJ(%) Q:%=""
12155
"RTN","ZOSVONT",7,0)
12156
S Y=$system.License.LUConsumed()
12157
"RTN","ZOSVONT",8,0)
12158
Q Y
12159
"RTN","ZOSVONT",9,0)
12160
AVJ() ;# available jobs
12161
"RTN","ZOSVONT",10,0)
12162
N %,AVJ,ZOSV,port,t,x,v,maxpid,lmflim,$ET
12163
"RTN","ZOSVONT",11,0)
12164
S v=+$$VERSION()
12165
"RTN","ZOSVONT",12,0)
12166
;Cache 3 and 4
12167
"RTN","ZOSVONT",13,0)
12168
;maxpid: from %SS
12169
"RTN","ZOSVONT",14,0)
12170
I v<5 D Q AVJ
12171
"RTN","ZOSVONT",15,0)
12172
. S $ET="",maxpid=$v($zu(40,2,118),-2,4)
12173
"RTN","ZOSVONT",16,0)
12174
. X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S lmflim=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info
12175
"RTN","ZOSVONT",17,0)
12176
. ;Add together the enterprise and division licenses avaliable
12177
"RTN","ZOSVONT",18,0)
12178
. S x=$P(lmflim,";",2)+$P($P(lmflim,"|",2),";",2)
12179
"RTN","ZOSVONT",19,0)
12180
. S t=+lmflim+$P(lmflim,"|",2) ;Check the license total
12181
"RTN","ZOSVONT",20,0)
12182
. S AVJ=$S(t<maxpid:x,1:maxpid-$$ACTJ) ;Return the smaller of license or pid
12183
"RTN","ZOSVONT",21,0)
12184
;To get available jobs from Cache 5.0
12185
"RTN","ZOSVONT",22,0)
12186
I v'<5 D Q AVJ
12187
"RTN","ZOSVONT",23,0)
12188
. X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S AVJ=$system.License.LUAvailable(),%=$ZU(5,ZOSV)"
12189
"RTN","ZOSVONT",24,0)
12190
;Return fixed value not known version
12191
"RTN","ZOSVONT",25,0)
12192
Q 15
12193
"RTN","ZOSVONT",26,0)
12194
;
12195
"RTN","ZOSVONT",27,0)
12196
PRIINQ() ;
12197
"RTN","ZOSVONT",28,0)
12198
Q 8
12199
"RTN","ZOSVONT",29,0)
12200
;
12201
"RTN","ZOSVONT",30,0)
12202
UCI ;Current UCI
12203
"RTN","ZOSVONT",31,0)
12204
S Y=$ZU(5)_","_^%ZOSF("VOL") Q
12205
"RTN","ZOSVONT",32,0)
12206
;
12207
"RTN","ZOSVONT",33,0)
12208
UCICHECK(X) ;Check if valid UCI
12209
"RTN","ZOSVONT",34,0)
12210
N Y,%
12211
"RTN","ZOSVONT",35,0)
12212
S %=$P(X,",",1),Y=0 I $ZU(90,10,%) S Y=%
12213
"RTN","ZOSVONT",36,0)
12214
Q Y
12215
"RTN","ZOSVONT",37,0)
12216
;
12217
"RTN","ZOSVONT",38,0)
12218
GETPEER() ;Get the PEER tcp/ip address
12219
"RTN","ZOSVONT",39,0)
12220
N PEER,NL,$ET S NL="",$ET="S $EC=NL Q NL",PEER=""
12221
"RTN","ZOSVONT",40,0)
12222
I $$OS="VMS" S PEER=$ZF("TRNLNM","VISTA$IP")
12223
"RTN","ZOSVONT",41,0)
12224
I '$L(PEER) S PEER=$ZU(111,0) S:$L(PEER) PEER=$A(PEER,1)_"."_$A(PEER,2)_"."_$A(PEER,3)_"."_$A(PEER,4)
12225
"RTN","ZOSVONT",42,0)
12226
Q PEER
12227
"RTN","ZOSVONT",43,0)
12228
;
12229
"RTN","ZOSVONT",44,0)
12230
SHARELIC(TYPE) ;See if can share a C/S license
12231
"RTN","ZOSVONT",45,0)
12232
;Type is 1 for C/S and 0 for Telnet
12233
"RTN","ZOSVONT",46,0)
12234
N %,%N,%2,UID,%V,$ET S $ET="S $EC="""" Q",%V=$$VERSION()
12235
"RTN","ZOSVONT",47,0)
12236
I %V<3.1 X:TYPE "S %N=$ZU(5),%2=$ZU(5,""%SYS""),%2=$$GetLic^LMFCLI,%N=$ZU(5,%N)" Q
12237
"RTN","ZOSVONT",48,0)
12238
I %V<5 S:TYPE %=$$GetCSLic^%LICENSE S:'TYPE %=$$ShareLic^%LICENSE
12239
"RTN","ZOSVONT",49,0)
12240
;Per Sandy Waal 10/18/2003: With Cache' 5.0, your telnet and IP connections are now handled properly.
12241
"RTN","ZOSVONT",50,0)
12242
I %V'<5 S %V=%V
12243
"RTN","ZOSVONT",51,0)
12244
S $EC=""
12245
"RTN","ZOSVONT",52,0)
12246
Q
12247
"RTN","ZOSVONT",53,0)
12248
JOBPAR ;See if X points to a valid Job. Return its UCI.
12249
"RTN","ZOSVONT",54,0)
12250
N ZJ S Y="",$ZT="JOBX"
12251
"RTN","ZOSVONT",55,0)
12252
Q:'$D(^$JOB(X)) S Y=$V(-1,X),Y=$P(Y,"^",14)_","_^%ZOSF("VOL")
12253
"RTN","ZOSVONT",56,0)
12254
JOBX Q
12255
"RTN","ZOSVONT",57,0)
12256
;
12257
"RTN","ZOSVONT",58,0)
12258
NOLOG ;
12259
"RTN","ZOSVONT",59,0)
12260
S Y="$V(0,-2,4)\4096#2" Q
12261
"RTN","ZOSVONT",60,0)
12262
;
12263
"RTN","ZOSVONT",61,0)
12264
PROGMODE() ;Check if in PROG mode
12265
"RTN","ZOSVONT",62,0)
12266
Q $ZJ#2
12267
"RTN","ZOSVONT",63,0)
12268
;
12269
"RTN","ZOSVONT",64,0)
12270
PRGMODE ;
12271
"RTN","ZOSVONT",65,0)
12272
W ! S ZTPAC=$S('$D(^VA(200,+DUZ,.1)):"",1:$P(^(.1),U,5)),XUVOL=^%ZOSF("VOL")
12273
"RTN","ZOSVONT",66,0)
12274
S X="" X ^%ZOSF("EOFF") R:ZTPAC]"" !,"PAC: ",X:60 D LC^XUS X ^%ZOSF("EON") I X'=ZTPAC W "??"_$C(7) Q
12275
"RTN","ZOSVONT",67,0)
12276
S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$L($T(^XMB)) D BYE^XUSCLEAN K ZTPAC,X,XMB
12277
"RTN","ZOSVONT",68,0)
12278
D UCI S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI D ^%PMODE U $I:(:"+B+C+R") S $ZT="" Q
12279
"RTN","ZOSVONT",69,0)
12280
Q
12281
"RTN","ZOSVONT",70,0)
12282
LGR() S $ZT="LGRX^%ZOSV"
12283
"RTN","ZOSVONT",71,0)
12284
Q $ZR ;Last Global ref.
12285
"RTN","ZOSVONT",72,0)
12286
LGRX Q ""
12287
"RTN","ZOSVONT",73,0)
12288
;
12289
"RTN","ZOSVONT",74,0)
12290
EC() Q $ZE ;Error code
12291
"RTN","ZOSVONT",75,0)
12292
;
12293
"RTN","ZOSVONT",76,0)
12294
DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
12295
"RTN","ZOSVONT",77,0)
12296
S Y="%" F %=0:0 S Y=$O(@Y) Q:Y="" S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
12297
"RTN","ZOSVONT",78,0)
12298
Q
12299
"RTN","ZOSVONT",79,0)
12300
;
12301
"RTN","ZOSVONT",80,0)
12302
ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X
12303
"RTN","ZOSVONT",81,0)
12304
I Y="*" D DOLRO Q
12305
"RTN","ZOSVONT",82,0)
12306
S (Y,Y1)=$P(Y,"*",1) I $D(@Y)=0 F %=0:0 S Y=$O(@Y) Q:Y=""!(Y[Y1)
12307
"RTN","ZOSVONT",83,0)
12308
Q:Y="" S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
12309
"RTN","ZOSVONT",84,0)
12310
F %=0:0 S Y=$O(@Y) Q:Y=""!(Y'[Y1) S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR
12311
"RTN","ZOSVONT",85,0)
12312
K %,X,Y,Y1
12313
"RTN","ZOSVONT",86,0)
12314
Q
12315
"RTN","ZOSVONT",87,0)
12316
;
12317
"RTN","ZOSVONT",88,0)
12318
PARSIZ ;
12319
"RTN","ZOSVONT",89,0)
12320
S X=3
12321
"RTN","ZOSVONT",90,0)
12322
Q
12323
"RTN","ZOSVONT",91,0)
12324
;
12325
"RTN","ZOSVONT",92,0)
12326
DEVOPN ;List of Devices opened
12327
"RTN","ZOSVONT",93,0)
12328
;Returns variable Y. Y=Devices owned separated by a comma
12329
"RTN","ZOSVONT",94,0)
12330
Q
12331
"RTN","ZOSVONT",95,0)
12332
DEVOK ;
12333
"RTN","ZOSVONT",96,0)
12334
S Y=0,X1=$G(X1) Q:X=2 Q:(X1="HFS")!(X1="SPL")!(X1="MT")!(X1="CHAN") ;Quit w/ OK for HFS, Spool, MT, TCP/IP
12335
"RTN","ZOSVONT",97,0)
12336
G:X1="RES" RESOK^%ZIS6
12337
"RTN","ZOSVONT",98,0)
12338
N $ET S $ET="D OPNERR Q"
12339
"RTN","ZOSVONT",99,0)
12340
O X::$S($D(%ZISTO):%ZISTO,1:0) E S Y=999 Q ;G NOPN
12341
"RTN","ZOSVONT",100,0)
12342
S Y=0 I '$D(%ZISCHK)!($G(%ZIS)["T") C X Q
12343
"RTN","ZOSVONT",101,0)
12344
S:X]"" IO(1,X)="" Q
12345
"RTN","ZOSVONT",102,0)
12346
Q
12347
"RTN","ZOSVONT",103,0)
12348
NOPN ;
12349
"RTN","ZOSVONT",104,0)
12350
N ZJ S $ZT="NJ"
12351
"RTN","ZOSVONT",105,0)
12352
S ZJ="" F %=0:0 S ZJ=$ZJ(ZJ) Q:'ZJ D NOPN1 Q:'ZJ
12353
"RTN","ZOSVONT",106,0)
12354
Q
12355
"RTN","ZOSVONT",107,0)
12356
NOPN1 S Y=$V(-1,ZJ) I $P(Y,"^",3)[X_","!($P(Y,"^",3)[X_"*,") S Y=ZJ,ZJ="" Q
12357
"RTN","ZOSVONT",108,0)
12358
Q
12359
"RTN","ZOSVONT",109,0)
12360
NJ Q ;NOJOB ERROR
12361
"RTN","ZOSVONT",110,0)
12362
OPNERR S $EC="",Y=-1 Q
12363
"RTN","ZOSVONT",111,0)
12364
;
12365
"RTN","ZOSVONT",112,0)
12366
GETENV ;Get environment (UCI^VOL^NODE^BOX:VOLUME)
12367
"RTN","ZOSVONT",113,0)
12368
N %,%1 S %=$$VERSION,%1=$ZU(86),%1=$S(%<3.1:$P(%1,"*",3),1:$P(%1,"*",2))
12369
"RTN","ZOSVONT",114,0)
12370
D UCI S Y=$P(Y,",")_"^"_^%ZOSF("VOL")_"^"_$ZU(110)_"^"_^%ZOSF("VOL")_":"_%1
12371
"RTN","ZOSVONT",115,0)
12372
Q
12373
"RTN","ZOSVONT",116,0)
12374
VERSION(X) ;return Cache version, X=1 - return full name
12375
"RTN","ZOSVONT",117,0)
12376
Q $S($G(X):$P($ZV,")")_")",1:$P($P($ZV,") ",2),"("))
12377
"RTN","ZOSVONT",118,0)
12378
;
12379
"RTN","ZOSVONT",119,0)
12380
OS() ;Return the OS NT, VMS, Unix
12381
"RTN","ZOSVONT",120,0)
12382
; MSC/REC mod the next line to look for windows
12383
"RTN","ZOSVONT",121,0)
12384
Q $S($ZV["VMS":"VMS",$ZV["NT":"NT",$ZV["UNIX":"UNIX",$$UP^XLFSTR($ZV)["WINDOWS":"NT",1:"UNK")
12385
"RTN","ZOSVONT",122,0)
12386
;
12387
"RTN","ZOSVONT",123,0)
12388
SETNM(X) ;Set name, Fall into SETENV
12389
"RTN","ZOSVONT",124,0)
12390
SETENV ;Set environment
12391
"RTN","ZOSVONT",125,0)
12392
N Q,$ET,$ES S $ET="S $EC="""" Q"
12393
"RTN","ZOSVONT",126,0)
12394
I $$OS="VMS" S Q=$ZF("SETPRN",$E(X,1,15))
12395
"RTN","ZOSVONT",127,0)
12396
Q
12397
"RTN","ZOSVONT",128,0)
12398
;
12399
"RTN","ZOSVONT",129,0)
12400
SID() ;System ID Ver 1
12401
"RTN","ZOSVONT",130,0)
12402
N J1,T S T="~"
12403
"RTN","ZOSVONT",131,0)
12404
S J1(1)=$ZU(86) ;Node specific
12405
"RTN","ZOSVONT",132,0)
12406
S J1(2)=$ZU(5)_T_$ZU(12,"") ;namespace~directory
12407
"RTN","ZOSVONT",133,0)
12408
; Q "1~"_J1(1)_T_J1(2)
12409
"RTN","ZOSVONT",134,0)
12410
Q "1~"_J1(2)
12411
"RTN","ZOSVONT",135,0)
12412
;
12413
"RTN","ZOSVONT",136,0)
12414
HFSREW(IO,IOPAR) ;Rewind Host File.
12415
"RTN","ZOSVONT",137,0)
12416
S $ZT="HFSRWERR"
12417
"RTN","ZOSVONT",138,0)
12418
C IO O @(""""_IO_""""_$S(IOPAR]"":":"_IOPAR_":1",1:":1")) I '$T Q 0
12419
"RTN","ZOSVONT",139,0)
12420
Q 1
12421
"RTN","ZOSVONT",140,0)
12422
HFSRWERR ;Error encountered
12423
"RTN","ZOSVONT",141,0)
12424
Q 0
12425
"RTN","ZOSVONT",142,0)
12426
LOGRSRC(OPT,TYPE,STATUS) ;record resource usage in ^XTMP("KMPR"
12427
"RTN","ZOSVONT",143,0)
12428
Q:'$G(^%ZTSCH("LOGRSRC")) ; quit if RUM not turned on.
12429
"RTN","ZOSVONT",144,0)
12430
; call to RUM routine.
12431
"RTN","ZOSVONT",145,0)
12432
D RU^%ZOSVKR($G(OPT),$G(TYPE),$G(STATUS))
12433
"RTN","ZOSVONT",146,0)
12434
Q
12435
"RTN","ZOSVONT",147,0)
12436
SETTRM(X) ;Turn on specified terminators.
12437
"RTN","ZOSVONT",148,0)
12438
U $I:(:"+T":X)
12439
"RTN","ZOSVONT",149,0)
12440
Q 1
12441
"RTN","ZOSVONT",150,0)
12442
;
12443
"RTN","ZOSVONT",151,0)
12444
T0 ; start RT clock
12445
"RTN","ZOSVONT",152,0)
12446
S XRT0=$H Q
12447
"RTN","ZOSVONT",153,0)
12448
T1 ; store RT datum
12449
"RTN","ZOSVONT",154,0)
12450
S ^%ZRTL(3,XRTL,+$H,XRTN,$P($H,",",2))=XRT0 K XRT0 Q
12451
"RTN","ZSSGUX")
12452
0^49^B47435
12453
"RTN","ZSSGUX",1,0)
12454
%SS ;JKT/MSC - OpenVista System status ;27MAY2009
12455
"RTN","ZSSGUX",2,0)
12456
;;8.0;KERNEL;**MSC**
12457
"RTN","ZSSGUX",3,0)
12458
;
12459
"RTN","ZSSGUX",4,0)
12460
ALL D ALL^MSCZJOBS Q
12461
"RTN","ZSSGUX",5,0)
12462
THIS D THIS^MSCZJOBS Q
12463
"RTN","ZSTARTGUX")
12464
0^29^B140233
12465
"RTN","ZSTARTGUX",1,0)
12466
ZSTART ;MSC/JKT - SYSTEM STARTUP HOOK ;04/17/2009 18:41
12467
"RTN","ZSTARTGUX",2,0)
12468
;;1.0;;**MSC**;Apr 17, 2009
12469
"RTN","ZSTARTGUX",3,0)
12470
;save as ZSTART in GTM
12471
"RTN","ZSTARTGUX",4,0)
12472
;
12473
"RTN","ZSTARTGUX",5,0)
12474
D TASKMAN
12475
"RTN","ZSTARTGUX",6,0)
12476
;D RPC
12477
"RTN","ZSTARTGUX",7,0)
12478
;D MAILMAN
12479
"RTN","ZSTARTGUX",8,0)
12480
Q
12481
"RTN","ZSTARTGUX",9,0)
12482
;
12483
"RTN","ZSTARTGUX",10,0)
12484
TASKMAN ;Start TaskMan
12485
"RTN","ZSTARTGUX",11,0)
12486
D ZTM^ZTMKU
12487
"RTN","ZSTARTGUX",12,0)
12488
I %ZTY=0 D START^ZTMB
12489
"RTN","ZSTARTGUX",13,0)
12490
Q
12491
"RTN","ZSTARTGUX",14,0)
12492
;
12493
"RTN","ZSTARTGUX",15,0)
12494
RPC ;Start the RPC Broker
12495
"RTN","ZSTARTGUX",16,0)
12496
D RESTART^XWBTCP
12497
"RTN","ZSTARTGUX",17,0)
12498
Q
12499
"RTN","ZSTARTGUX",18,0)
12500
;
12501
"RTN","ZSTARTGUX",19,0)
12502
MAILMAN ;Start Mailman
12503
"RTN","ZSTARTGUX",20,0)
12504
J ^XMRONT
12505
"RTN","ZSTOPGUX")
12506
0^44^B148072
12507
"RTN","ZSTOPGUX",1,0)
12508
ZSTOP ;MSC/JKT - SYSTEM SHUTDOWN HOOK ;04/17/2009 18:44
12509
"RTN","ZSTOPGUX",2,0)
12510
;;1.0;;**MSC**;Apr 17, 2009
12511
"RTN","ZSTOPGUX",3,0)
12512
;
12513
"RTN","ZSTOPGUX",4,0)
12514
D RPC
12515
"RTN","ZSTOPGUX",5,0)
12516
D TASKMAN
12517
"RTN","ZSTOPGUX",6,0)
12518
Q
12519
"RTN","ZSTOPGUX",7,0)
12520
;
12521
"RTN","ZSTOPGUX",8,0)
12522
TASKMAN ;Stop TaskMan
12523
"RTN","ZSTOPGUX",9,0)
12524
; STOP^ZTMKU is interactive, so we duplicate some of the code here
12525
"RTN","ZSTOPGUX",10,0)
12526
D GROUP^ZTMKU("SMAN(NODE)")
12527
"RTN","ZSTOPGUX",11,0)
12528
D GROUP^ZTMKU("SSUB(NODE)")
12529
"RTN","ZSTOPGUX",12,0)
12530
Q
12531
"RTN","ZSTOPGUX",13,0)
12532
;
12533
"RTN","ZSTOPGUX",14,0)
12534
RPC ;Stop the RPC Broker
12535
"RTN","ZSTOPGUX",15,0)
12536
D STOPALL^XWBTCP
12537
"RTN","ZSTOPGUX",16,0)
12538
Q
12539
"RTN","ZSTOPGUX",17,0)
12540
;
12541
"RTN","ZTER")
12542
0^28^B39678986
12543
"RTN","ZTER",1,0)
12544
%ZTER ; ISC-SF.SEA/JLI MSC/RHL/JDS - KERNEL ERROR TRAP TO LOG ERRORS ;01MAY2009
12545
"RTN","ZTER",2,0)
12546
;;8.0;KERNEL;**8,18,32,24,36,63,73,79,86,112,118,162,275,392,MSC**;JUL 10, 1995;Build 5
12547
"RTN","ZTER",3,0)
12548
S ^TMP("$ZE",$J,1)=$$LGR^%ZOSV
12549
"RTN","ZTER",4,0)
12550
S ^TMP("$ZE",$J,0)=$$EC^%ZOSV ;$S(^%ZOSF("OS")["GT.M":$ZS,1:$ZE)
12551
"RTN","ZTER",5,0)
12552
S ^TMP("$ZE",$J,2)=$ETRAP,$ETRAP="D ERR^%ZTER"
12553
"RTN","ZTER",6,0)
12554
I (^TMP("$ZE",$J,0)["-ALLOC,")!(^TMP("$ZE",$J,0)["<STORE>")!(^TMP("$ZE",$J,0)["-MEMORY") D
12555
"RTN","ZTER",7,0)
12556
. I '$D(XUALLOC) D
12557
"RTN","ZTER",8,0)
12558
. . K (%ZTERLGR,DUZ,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,DA,D0,DI,DIC,DIE)
12559
"RTN","ZTER",9,0)
12560
. S %ZTER12A="ALLOC"
12561
"RTN","ZTER",10,0)
12562
K XUALLOC
12563
"RTN","ZTER",11,0)
12564
S %ZTERZE=^TMP("$ZE",$J,0),%ZT("^XUTL(""XQ"",$J)")="" S:'$D(%ZTERLGR) %ZTERLGR=^TMP("$ZE",$J,1)
12565
"RTN","ZTER",12,0)
12566
G:$$SCREEN(%ZTERZE,1) EXIT ;Let site screen errors, count don't show
12567
"RTN","ZTER",13,0)
12568
;Get a record.
12569
"RTN","ZTER",14,0)
12570
S %ZTERH1=+$H L +^%ZTER(1,%ZTERH1,0):15
12571
"RTN","ZTER",15,0)
12572
S %ZTER11N=$P($G(^%ZTER(1,%ZTERH1,0)),"^",2)+1,^%ZTER(1,%ZTERH1,0)=%ZTERH1_"^"_%ZTER11N,^(1,0)="^3.0751^"_%ZTER11N_"^"_%ZTER11N
12573
"RTN","ZTER",16,0)
12574
I %ZTER11N=1 S ^%ZTER(1,0)=$P(^%ZTER(1,0),"^",1,2)_"^"_%ZTERH1_"^"_($P(^%ZTER(1,0),"^",4)+1)
12575
"RTN","ZTER",17,0)
12576
L -^%ZTER(1,%ZTERH1,0)
12577
"RTN","ZTER",18,0)
12578
S %ZTERRT=$NA(^%ZTER(1,%ZTERH1,1,%ZTER11N))
12579
"RTN","ZTER",19,0)
12580
S @%ZTERRT@(0)=%ZTER11N,^("ZE")=%ZTERZE S:$D(%ZTERLGR) ^("GR")=%ZTERLGR K %ZTERLGR
12581
"RTN","ZTER",20,0)
12582
K %ZTER11B
12583
"RTN","ZTER",21,0)
12584
;Get $ZB
12585
"RTN","ZTER",22,0)
12586
I ^%ZOSF("OS")["DSM"!(^%ZOSF("OS")["GT.M") D
12587
"RTN","ZTER",23,0)
12588
. Q:'$L($ZB) ; rhl/medsphere 20070518
12589
"RTN","ZTER",24,0)
12590
. F %ZTER11I=1:1:$L($ZB) S %ZTER11A=$E($ZB,%ZTER11I),%ZTER11B=$G(%ZTER11B)_$S(%ZTER11A?1C:$A(%ZTER11A),1:%ZTER11A)_","
12591
"RTN","ZTER",25,0)
12592
. S %ZTER11B=$E(%ZTER11B,1,$L(%ZTER11B)-1)
12593
"RTN","ZTER",26,0)
12594
. Q
12595
"RTN","ZTER",27,0)
12596
S:'$D(%ZTER11B) %ZTER11B=$ZB
12597
"RTN","ZTER",28,0)
12598
S %ZTER11I="" I $D(^%ZOSF("UCI")) K %ZTER11A S:$D(Y) %ZTER11A="" S:($D(Y)#2) %ZTER11A=Y X ^%ZOSF("UCI") S %ZTER11I=Y K:'$D(%ZTER11A) Y S:$D(%ZTER11A) Y=%ZTER11A
12599
"RTN","ZTER",29,0)
12600
S @%ZTERRT@("H")=$H,^("J")=$J_"^^^"_%ZTER11I_"^"_$J
12601
"RTN","ZTER",30,0)
12602
S @%ZTERRT@("I")=$I_"^"_$ZA_"^"_%ZTER11B_"^"_$G(IO("ZIO"))_"^"_$X_"^"_$Y_"^"_$P
12603
"RTN","ZTER",31,0)
12604
S %ZTERROR=$$ETXT
12605
"RTN","ZTER",32,0)
12606
S %ZTERCNT=0
12607
"RTN","ZTER",33,0)
12608
D STACK^%ZTER1 ;Save Special Variables
12609
"RTN","ZTER",34,0)
12610
D SAVE("$X $Y",$X_" "_$Y)
12611
"RTN","ZTER",35,0)
12612
I ^%ZOSF("OS")["OpenM" D
12613
"RTN","ZTER",36,0)
12614
. X "D SAVE(""$ZU(56,2)"",$ZU(56,2))"
12615
"RTN","ZTER",37,0)
12616
. I $ZV["VMS" S $P(@%ZTERRT@("J"),"^",2,3)=$ZF("GETJPI",$J,"PRCNAM")_"^"_$ZF("GETJPI",$J,"USERNAME")
12617
"RTN","ZTER",38,0)
12618
D SAVE("$ZV",$ZV)
12619
"RTN","ZTER",39,0)
12620
;End Special Variables
12621
"RTN","ZTER",40,0)
12622
I ^%ZOSF("OS")["VAX DSM" K %ZTER11A,%ZTER11B D VXD^%ZTER1 I 1
12623
"RTN","ZTER",41,0)
12624
E D
12625
"RTN","ZTER",42,0)
12626
. S %ZTERVAR="%" D:$D(%) VAR:$D(%)#2,SUBS:$D(%)>9
12627
"RTN","ZTER",43,0)
12628
. F %ZTER11Z=0:0 S %ZTERVAR=$O(@%ZTERVAR) Q:%ZTERVAR="" D VAR:$D(@%ZTERVAR)#2,SUBS:$D(@%ZTERVAR)>9
12629
"RTN","ZTER",44,0)
12630
D GLOB
12631
"RTN","ZTER",45,0)
12632
S:%ZTERCNT>0 @%ZTERRT@("ZV",0)="^3.0752^"_%ZTERCNT_"^"_%ZTERCNT
12633
"RTN","ZTER",46,0)
12634
S:'$D(^%ZTER(1,"B",%ZTERH1)) ^(%ZTERH1,%ZTERH1)=""
12635
"RTN","ZTER",47,0)
12636
S ^%ZTER(1,%ZTERH1,1,"B",%ZTER11N,%ZTER11N)=""
12637
"RTN","ZTER",48,0)
12638
LIN ;Find the line of the error
12639
"RTN","ZTER",49,0)
12640
S %ZTERY=$P(%ZTERZE,","),%ZTERX=$P(%ZTERY,"^") S:%ZTERX[">" %ZTERX=$P(%ZTERX,">",2)
12641
"RTN","ZTER",50,0)
12642
I %ZTERX'="" D
12643
"RTN","ZTER",51,0)
12644
. N X,XCNP,DIF K ^TMP($J,"XTER1")
12645
"RTN","ZTER",52,0)
12646
. S X=$P($P(%ZTERY,"^",2),":") Q:X="" X ^%ZOSF("TEST") Q:'$T
12647
"RTN","ZTER",53,0)
12648
. S XCNP=0,DIF="^TMP($J,""XTER1""," X ^%ZOSF("LOAD") S %ZTERY=$P(%ZTERX,"+",1)
12649
"RTN","ZTER",54,0)
12650
. I %ZTERY'="" F X=0:0 S X=$O(^TMP($J,"XTER1",X)) Q:X'>0 I $P(^(X,0)," ")=%ZTERY S X=X+$P(%ZTERX,"+",2),%ZTZLIN=$G(^TMP($J,"XTER1",X,0)) Q
12651
"RTN","ZTER",55,0)
12652
. I %ZTERY="" S X=+$P(%ZTERX,"+",2) Q:X'>0 S %ZTZLIN=$G(^TMP($J,"XTER1",X,0))
12653
"RTN","ZTER",56,0)
12654
K ^TMP($J,"XTER1")
12655
"RTN","ZTER",57,0)
12656
S:$D(%ZTZLIN) @%ZTERRT@("LINE")=%ZTZLIN K %ZTZLIN
12657
"RTN","ZTER",58,0)
12658
I %ZTERROR'="",$D(^%ZTER(2,"B",%ZTERROR)) S %ZTERROR=%ZTERROR_"^"_$P(^%ZTER(2,+$O(^(%ZTERROR,0)),0),"^",2)
12659
"RTN","ZTER",59,0)
12660
EXIT ;
12661
"RTN","ZTER",60,0)
12662
I $G(%ZTER12A)["ALLOC" HALT ;Don't allow job to go on.
12663
"RTN","ZTER",61,0)
12664
S $EC="",$ET=$G(^TMP("$ZE",$J,2))
12665
"RTN","ZTER",62,0)
12666
K ^TMP("$ZE",$J)
12667
"RTN","ZTER",63,0)
12668
K %ZTER11A,%ZTER11B,%ZTERCNT,%ZTER11S,%ZTER11Z,%ZTERVAP,%ZTERVAR,%ZTERSUB,%ZTER11I,%ZTER11D,%ZTER11L,%ZTER11Q,%,%ZTER111,%ZTER112,%ZTER11N
12669
"RTN","ZTER",64,0)
12670
K %ZTERRT,%ZTERH1
12671
"RTN","ZTER",65,0)
12672
Q
12673
"RTN","ZTER",66,0)
12674
;
12675
"RTN","ZTER",67,0)
12676
VAR I "%ZTER"'=$E(%ZTERVAR,1,5) D SAVE(%ZTERVAR,@%ZTERVAR) Q
12677
"RTN","ZTER",68,0)
12678
S %ZTERCNT=%ZTERCNT+1,@%ZTERRT@("ZV",%ZTERCNT,0)=%ZTERVAR D
12679
"RTN","ZTER",69,0)
12680
. I $L(@%ZTERVAR)'>255 S @%ZTERRT@("ZV",%ZTERCNT,"D")=@%ZTERVAR Q
12681
"RTN","ZTER",70,0)
12682
. S @%ZTERRT@("ZV",%ZTERCNT,"D")=" **** VALUE IS GREATER THAN 255 CHARACTERS (SEE SUBNODES FOR DATA) *** "
12683
"RTN","ZTER",71,0)
12684
. N %ZTER11,%ZTER12
12685
"RTN","ZTER",72,0)
12686
. F %ZTER11=1:1 S %ZTER12=$E(@%ZTERVAR,1,245) Q:%ZTER12="" S @%ZTERVAR=$E(@%ZTERVAR,246,$L(@%ZTERVAR)),@%ZTERRT@("ZV",%ZTERCNT,"D",%ZTER11)=%ZTER12
12687
"RTN","ZTER",73,0)
12688
. Q
12689
"RTN","ZTER",74,0)
12690
Q
12691
"RTN","ZTER",75,0)
12692
;
12693
"RTN","ZTER",76,0)
12694
SAVE(%n,%v) ;Save name and value into global, use special variables
12695
"RTN","ZTER",77,0)
12696
S %ZTERCNT=%ZTERCNT+1,@%ZTERRT@("ZV",%ZTERCNT,0)=%n
12697
"RTN","ZTER",78,0)
12698
I $L(%v)<256 S @%ZTERRT@("ZV",%ZTERCNT,"D")=%v Q
12699
"RTN","ZTER",79,0)
12700
;Variable too long for global node
12701
"RTN","ZTER",80,0)
12702
S @%ZTERRT@("ZV",%ZTERCNT,"D")=$E(%v,1,255),^("L")=$L(%v)
12703
"RTN","ZTER",81,0)
12704
N %i S %v=$E(%v,256,$L(%v))
12705
"RTN","ZTER",82,0)
12706
F %i=1:1 Q:'$L(%v) S @%ZTERRT@("ZV",%ZTERCNT,"D",%i)=$E(%v,1,255),%v=$E(%v,256,$L(%v))
12707
"RTN","ZTER",83,0)
12708
Q
12709
"RTN","ZTER",84,0)
12710
;
12711
"RTN","ZTER",85,0)
12712
SUBS S %ZTER11S="" Q:"%ZT("=$E(%ZTERVAR,1,4) Q:",%ZTER11S,%ZTER11L,"[(","_%ZTERVAR_",") S %ZTERVAP=%ZTERVAR_"(",%ZTERSUB="%ZTER11S)"
12713
"RTN","ZTER",86,0)
12714
;
12715
"RTN","ZTER",87,0)
12716
S %ZTER11S=%ZTERVAR
12717
"RTN","ZTER",88,0)
12718
F S %ZTER11S=$Q(@%ZTER11S) Q:%ZTER11S="" D SAVE(%ZTER11S,@%ZTER11S)
12719
"RTN","ZTER",89,0)
12720
Q
12721
"RTN","ZTER",90,0)
12722
;
12723
"RTN","ZTER",91,0)
12724
GLOB ; save off a list of global subtrees, %ZT is passed in subscripted by name
12725
"RTN","ZTER",92,0)
12726
; %ZTERCNT passed in to count the nodes we traverse
12727
"RTN","ZTER",93,0)
12728
; %ZTERNOD the nodes through which we $QUERY
12729
"RTN","ZTER",94,0)
12730
; %ZTERNAM the names of the global subtrees we're saving
12731
"RTN","ZTER",95,0)
12732
; %ZTEROPN is %ZTERNAM, evaluated, without close paren for $PIECEing
12733
"RTN","ZTER",96,0)
12734
N %ZTERNOD,%ZTERNAM,%ZTEROPN
12735
"RTN","ZTER",97,0)
12736
S %ZTERNAM="" ; the names of the global subtrees we're saving
12737
"RTN","ZTER",98,0)
12738
F S %ZTERNAM=$O(%ZT(%ZTERNAM)) Q:%ZTERNAM="" D
12739
"RTN","ZTER",99,0)
12740
. S %ZTERNOD=$NA(@%ZTERNAM) ; fully evaluate all the subscripts (incl. $J)
12741
"RTN","ZTER",100,0)
12742
. S %ZTEROPN=$E(%ZTERNOD,1,$L(%ZTERNOD)-1) ; save %ZTERNOD w/o close paren
12743
"RTN","ZTER",101,0)
12744
. ;S %ZTERSUB=$QL(%ZTERNOD) ; how many subscripts in the subtree root's name
12745
"RTN","ZTER",102,0)
12746
. F S %ZTERNOD=$Q(@%ZTERNOD) Q:%ZTERNOD="" Q:%ZTERNOD'[%ZTEROPN D ; traverse subtree
12747
"RTN","ZTER",103,0)
12748
. . S %ZTERCNT=%ZTERCNT+1 ; count each node
12749
"RTN","ZTER",104,0)
12750
. . S @%ZTERRT@("ZV",%ZTERCNT,0)=$P(%ZTERNAM,")")_$P(%ZTERNOD,%ZTEROPN,2) ; unevaluated name
12751
"RTN","ZTER",105,0)
12752
. . S @%ZTERRT@("ZV",%ZTERCNT,"D")=$G(@%ZTERNOD) ; value of node
12753
"RTN","ZTER",106,0)
12754
Q
12755
"RTN","ZTER",107,0)
12756
;
12757
"RTN","ZTER",108,0)
12758
ETXT() ;Return the Text of the error
12759
"RTN","ZTER",109,0)
12760
Q $S(%ZTERZE["%DSM-E":$P($P(%ZTERZE,"%DSM-E-",2),","),1:$P($P(%ZTERZE,"<",2),">"))
12761
"RTN","ZTER",110,0)
12762
;
12763
"RTN","ZTER",111,0)
12764
ERR ;Handle an error in %ZTER
12765
"RTN","ZTER",112,0)
12766
I $D(%ZTERH1),$D(%ZTER11N) S ^%ZTER(1,%ZTERH1,1,%ZTER11N,"ZE2")="%ZTER error: "_$ECODE
12767
"RTN","ZTER",113,0)
12768
;Should ^TMP("$ZE",$J) be killed here
12769
"RTN","ZTER",114,0)
12770
HALT
12771
"RTN","ZTER",115,0)
12772
;
12773
"RTN","ZTER",116,0)
12774
SCREEN(ERR,%ZT3) ;Screen out certain errors.
12775
"RTN","ZTER",117,0)
12776
N %ZTE,%ZTI,%ZTJ S:'$D(ERR) ERR=$$EC^%ZOSV
12777
"RTN","ZTER",118,0)
12778
S %ZTE="",%ZTI=0
12779
"RTN","ZTER",119,0)
12780
F %ZTJ=2,1 D Q:%ZTI>0
12781
"RTN","ZTER",120,0)
12782
. F %ZTI=0:0 S %ZTI=$O(^%ZTER(2,"AC",%ZTJ,%ZTI)) Q:%ZTI="" S %ZTE=$S($G(^%ZTER(2,%ZTI,2))]"":^(2),1:$P(^(0),"^")) Q:ERR[%ZTE
12783
"RTN","ZTER",121,0)
12784
. Q
12785
"RTN","ZTER",122,0)
12786
;Next see if we should count the error
12787
"RTN","ZTER",123,0)
12788
I %ZTI>0 S %ZTE=$G(^%ZTER(2,%ZTI,0)) D Q $P(%ZTE,"^",3)=2 ;See if we skip the recording of the error.
12789
"RTN","ZTER",124,0)
12790
. Q:(%ZTJ=1)&('$G(%ZT3))
12791
"RTN","ZTER",125,0)
12792
. I $P(%ZTE,"^",4) L +^%ZTER(2,%ZTI) S ^(3)=$G(^%ZTER(2,%ZTI,3))+1 L -^%ZTER(2,%ZTI)
12793
"RTN","ZTER",126,0)
12794
. Q
12795
"RTN","ZTER",127,0)
12796
Q 0 ;record error
12797
"RTN","ZTER",128,0)
12798
;
12799
"RTN","ZTER",129,0)
12800
UNWIND ;Unwind stack for new error trap. Called by app code.
12801
"RTN","ZTER",130,0)
12802
S $ECODE="" S $ETRAP="D UNW^%ZTER Q:'$QUIT Q -9" S $ECODE=",U1,"
12803
"RTN","ZTER",131,0)
12804
UNW Q:$ESTACK>1 S $ECODE="" Q
12805
"RTN","ZTER",132,0)
12806
;
12807
"RTN","ZTER",133,0)
12808
NEWERR() ;Does this OS support the M95 error trapping
12809
"RTN","ZTER",134,0)
12810
Q 1 ;All current M system now support 95 error trapping
12811
"RTN","ZTER",135,0)
12812
N % S %=$G(^%ZOSF("OS")) Q:%="" 0
12813
"RTN","ZTER",136,0)
12814
I %["VAX DSM" Q 1
12815
"RTN","ZTER",137,0)
12816
I %["GT.M" Q 1
12817
"RTN","ZTER",138,0)
12818
I %["MSM",$P($ZV,"Version ",2)'<4.3 Q 1
12819
"RTN","ZTER",139,0)
12820
I %["OpenM" Q 1 ;For version >7.0 or NexGen or Cache
12821
"RTN","ZTER",140,0)
12822
Q 0
12823
"RTN","ZTER",141,0)
12824
ABORT ;Pop the stack all the way.
12825
"RTN","ZTER",142,0)
12826
S $ETRAP="Q:$ST>1 S $ECODE="""" Q"
12827
"RTN","ZTER",143,0)
12828
Q
12829
"RTN","ZTMGRSET")
12830
0^24^B57539605
12831
"RTN","ZTMGRSET",1,0)
12832
ZTMGRSET ;SF/RWF,PUG/TOAD,MSC/JDA/JDS/JKT - SET UP THE MGR ACCOUNT FOR THE SYSTEM ;23APR2010
12833
"RTN","ZTMGRSET",2,0)
12834
;;8.0;KERNEL;**34,36,69,94,121,127,136,191,275,MSC,MSC9466**;JUL 10, 1995;
12835
"RTN","ZTMGRSET",3,0)
12836
;
12837
"RTN","ZTMGRSET",4,0)
12838
N %D,%S,I,OSMAX,U,X,X1,X2,Y,Z1,Z2,ZTOS,ZTMODE,SCR
12839
"RTN","ZTMGRSET",5,0)
12840
S ZTMODE=0
12841
"RTN","ZTMGRSET",6,0)
12842
A W !!,"ZTMGRSET Version ",$P($T(+2),";",3)," ",$P($T(+2),";",5)
12843
"RTN","ZTMGRSET",7,0)
12844
W !,"HELLO! I exist to assist you in correctly initializing the current account."
12845
"RTN","ZTMGRSET",8,0)
12846
I $D(^%ZOSF("UCI")) X ^%ZOSF("UCI") I Y'["MG" W $C(7),!!,"THIS MAY NOT BE THE MANAGER UCI.",!," I think it is ",Y,". Should I continue anyway? N//" R X:120 G A:"YNyn"'[$E(X) Q:"Nn"[$E(X)
12847
"RTN","ZTMGRSET",9,0)
12848
S ZTOS=$$OS() I ZTOS'>0 W !,"Can't determine the OS type. Exiting ZTMGRSET." Q
12849
"RTN","ZTMGRSET",10,0)
12850
I ZTMODE D I (PCNM<1)!(PCNM>999) W !,"Need a Patch number to load." Q
12851
"RTN","ZTMGRSET",11,0)
12852
. R !!,"Patch number to load: ",PCNM:120 Q:(PCNM<1)!(PCNM>999)
12853
"RTN","ZTMGRSET",12,0)
12854
. S SCR="I $P($T(+2^@X),"";"",5)?.E1P1"_$C(34)_PCNM_$C(34)_"1P.E"
12855
"RTN","ZTMGRSET",13,0)
12856
;
12857
"RTN","ZTMGRSET",14,0)
12858
K ^%ZOSF("MASTER"),^("SIGNOFF") ;Remove old nodes.
12859
"RTN","ZTMGRSET",15,0)
12860
DOIT W !!,"I will now rename a group of routines specific to your operating system."
12861
"RTN","ZTMGRSET",16,0)
12862
D @ZTOS,ALL,GLOBALS:'ZTMODE W !,"ALL DONE"
12863
"RTN","ZTMGRSET",17,0)
12864
Q
12865
"RTN","ZTMGRSET",18,0)
12866
;
12867
"RTN","ZTMGRSET",19,0)
12868
RELOAD ;Reload any patched routines
12869
"RTN","ZTMGRSET",20,0)
12870
N %D,%S,I,OSMAX,U,X,X1,X2,Y,Z1,Z2,ZTOS,ZTMODE,SCR
12871
"RTN","ZTMGRSET",21,0)
12872
S ZTMODE=1 G A
12873
"RTN","ZTMGRSET",22,0)
12874
Q
12875
"RTN","ZTMGRSET",23,0)
12876
;
12877
"RTN","ZTMGRSET",24,0)
12878
OS() ;Select the OS
12879
"RTN","ZTMGRSET",25,0)
12880
N Y,X1,X
12881
"RTN","ZTMGRSET",26,0)
12882
S U="^",SCR="I 1" F I=1:1:20 S X=$T(@I) Q:X="" S OSMAX=I
12883
"RTN","ZTMGRSET",27,0)
12884
B S Y=0,ZTOS=0 I $D(^%ZOSF("OS")) D
12885
"RTN","ZTMGRSET",28,0)
12886
. S X1=$P(^%ZOSF("OS"),U),ZTOS=$$OSNUM W !,"I think you are using ",X1
12887
"RTN","ZTMGRSET",29,0)
12888
W !,"Which MUMPS system should I install?",!
12889
"RTN","ZTMGRSET",30,0)
12890
F I=1:1:OSMAX W !,I," = ",$P($T(@I),";",3)
12891
"RTN","ZTMGRSET",31,0)
12892
W !,"System: " W:ZTOS ZTOS,"//"
12893
"RTN","ZTMGRSET",32,0)
12894
R X:300 S:X="" X=ZTOS
12895
"RTN","ZTMGRSET",33,0)
12896
I X<1!(X>OSMAX) W !,"NOT A VALID CHOICE" Q:X[U 0 G B
12897
"RTN","ZTMGRSET",34,0)
12898
Q X
12899
"RTN","ZTMGRSET",35,0)
12900
;
12901
"RTN","ZTMGRSET",36,0)
12902
OSNUM() ;Return the OS number
12903
"RTN","ZTMGRSET",37,0)
12904
N I,X1,X2,Y S Y=0,X1=$P($G(^%ZOSF("OS")),"^")
12905
"RTN","ZTMGRSET",38,0)
12906
F I=1:1 S X2=$T(@I) Q:X2="" I X2[X1 S Y=I Q
12907
"RTN","ZTMGRSET",39,0)
12908
Q Y
12909
"RTN","ZTMGRSET",40,0)
12910
;
12911
"RTN","ZTMGRSET",41,0)
12912
ALL W !!,"Now to load routines common to all systems."
12913
"RTN","ZTMGRSET",42,0)
12914
D TM,ETRAP,DEV,OTHER,FM
12915
"RTN","ZTMGRSET",43,0)
12916
I ZTOS=7!(ZTOS=8) D
12917
"RTN","ZTMGRSET",44,0)
12918
. S ^%ZE="D ^ZE"
12919
"RTN","ZTMGRSET",45,0)
12920
E D ;With ZLoad, ZSave, ZInsert
12921
"RTN","ZTMGRSET",46,0)
12922
. W !,"Installing ^%Z editor"
12923
"RTN","ZTMGRSET",47,0)
12924
. D ^ZTEDIT
12925
"RTN","ZTMGRSET",48,0)
12926
I 'ZTMODE W !,"Setting ^%ZIS('C')" K ^%ZIS("C") S ^%ZIS("C")="G ^%ZISC"
12927
"RTN","ZTMGRSET",49,0)
12928
Q
12929
"RTN","ZTMGRSET",50,0)
12930
;
12931
"RTN","ZTMGRSET",51,0)
12932
TM ;Taskman
12933
"RTN","ZTMGRSET",52,0)
12934
S %S="ZTLOAD^ZTLOAD1^ZTLOAD2^ZTLOAD3^ZTLOAD4^ZTLOAD5^ZTLOAD6^ZTLOAD7"
12935
"RTN","ZTMGRSET",53,0)
12936
S %D="%ZTLOAD^%ZTLOAD1^%ZTLOAD2^%ZTLOAD3^%ZTLOAD4^%ZTLOAD5^%ZTLOAD6^%ZTLOAD7"
12937
"RTN","ZTMGRSET",54,0)
12938
D MOVE
12939
"RTN","ZTMGRSET",55,0)
12940
S %S="ZTM^ZTM0^ZTM1^ZTM2^ZTM3^ZTM4^ZTM5^ZTM6"
12941
"RTN","ZTMGRSET",56,0)
12942
S %D="%ZTM^%ZTM0^%ZTM1^%ZTM2^%ZTM3^%ZTM4^%ZTM5^%ZTM6"
12943
"RTN","ZTMGRSET",57,0)
12944
D MOVE
12945
"RTN","ZTMGRSET",58,0)
12946
S %S="ZTMS^ZTMS0^ZTMS1^ZTMS2^ZTMS3^ZTMS4^ZTMS5^ZTMS7^ZTMSH"
12947
"RTN","ZTMGRSET",59,0)
12948
;I ZTOS=7!(ZTOS=8) S $P(%S,U,1)="ZTMSGTM"
12949
"RTN","ZTMGRSET",60,0)
12950
S %D="%ZTMS^%ZTMS0^%ZTMS1^%ZTMS2^%ZTMS3^%ZTMS4^%ZTMS5^%ZTMS7^%ZTMSH"
12951
"RTN","ZTMGRSET",61,0)
12952
D MOVE
12953
"RTN","ZTMGRSET",62,0)
12954
Q
12955
"RTN","ZTMGRSET",63,0)
12956
FM ;Rename the FileMan routines
12957
"RTN","ZTMGRSET",64,0)
12958
I ZTMODE=1 Q ;Only ask on full install
12959
"RTN","ZTMGRSET",65,0)
12960
R !,"Want to rename the FileMan routines: No//",X:600 Q:"Yy"'[$E(X_"N")
12961
"RTN","ZTMGRSET",66,0)
12962
S %S="DIDT^DIDTC^DIRCR",%D="%DT^%DTC^%RCR"
12963
"RTN","ZTMGRSET",67,0)
12964
D MOVE
12965
"RTN","ZTMGRSET",68,0)
12966
Q
12967
"RTN","ZTMGRSET",69,0)
12968
;
12969
"RTN","ZTMGRSET",70,0)
12970
ETRAP ;Error Trap
12971
"RTN","ZTMGRSET",71,0)
12972
S %S="ZTER^ZTER1",%D="%ZTER^%ZTER1"
12973
"RTN","ZTMGRSET",72,0)
12974
D MOVE
12975
"RTN","ZTMGRSET",73,0)
12976
Q
12977
"RTN","ZTMGRSET",74,0)
12978
OTHER S %S="ZTPP^ZTP1^ZTPTCH^ZTRDEL^ZTMOVE"
12979
"RTN","ZTMGRSET",75,0)
12980
S %D="%ZTPP^%ZTP1^%ZTPTCH^%ZTRDEL^%ZTMOVE"
12981
"RTN","ZTMGRSET",76,0)
12982
D MOVE
12983
"RTN","ZTMGRSET",77,0)
12984
Q
12985
"RTN","ZTMGRSET",78,0)
12986
DEV S %S="ZIS^ZIS1^ZIS2^ZIS3^ZIS5^ZIS6^ZIS7^ZISC^ZISP^ZISS^ZISS1^ZISS2^ZISTCP^ZISUTL"
12987
"RTN","ZTMGRSET",79,0)
12988
S %D="%ZIS^%ZIS1^%ZIS2^%ZIS3^%ZIS5^%ZIS6^%ZIS7^%ZISC^%ZISP^%ZISS^%ZISS1^%ZISS2^%ZISTCP^%ZISUTL"
12989
"RTN","ZTMGRSET",80,0)
12990
D MOVE
12991
"RTN","ZTMGRSET",81,0)
12992
Q
12993
"RTN","ZTMGRSET",82,0)
12994
RUM ;Build the routines for Capacity Management (CM)
12995
"RTN","ZTMGRSET",83,0)
12996
S %S=""
12997
"RTN","ZTMGRSET",84,0)
12998
I ZTOS=1 S %S="ZOSVKRV^ZOSVKSVE^ZOSVKSVS^ZOSVKSD" ;DSM
12999
"RTN","ZTMGRSET",85,0)
13000
I ZTOS=2 S %S="ZOSVKRM^ZOSVKSME^ZOSVKSMS^ZOSVKSD" ;MSM
13001
"RTN","ZTMGRSET",86,0)
13002
I ZTOS=3 S %S="ZOSVKRO^ZOSVKSOE^ZOSVKSOS^ZOSVKSD" ;OpenM
13003
"RTN","ZTMGRSET",87,0)
13004
I ZTOS=7!(ZTOS=8) S %S="ZOSVKRG^ZOSVKSGE^ZOSVKSGS^ZOSVKSD" ;GT.M
13005
"RTN","ZTMGRSET",88,0)
13006
S %D="%ZOSVKR^%ZOSVKSE^%ZOSVKSS^%ZOSVKSD"
13007
"RTN","ZTMGRSET",89,0)
13008
D MOVE
13009
"RTN","ZTMGRSET",90,0)
13010
Q
13011
"RTN","ZTMGRSET",91,0)
13012
ZOSF(X) ;
13013
"RTN","ZTMGRSET",92,0)
13014
X SCR I $T W ! D @(U_X) W !
13015
"RTN","ZTMGRSET",93,0)
13016
Q
13017
"RTN","ZTMGRSET",94,0)
13018
1 ;;VAX DSM(V6), VAX DSM(V7)
13019
"RTN","ZTMGRSET",95,0)
13020
S %S="ZOSVVXD^ZTBKCVXD^ZIS4VXD^ZISFVXD^ZISHVXD^XUCIVXD^ZISETVXD"
13021
"RTN","ZTMGRSET",96,0)
13022
D DES,MOVE
13023
"RTN","ZTMGRSET",97,0)
13024
S %S="ZOSV2VXD^ZTMDCL",%D="%ZOSV2^%ZTMDCL"
13025
"RTN","ZTMGRSET",98,0)
13026
D MOVE,RUM,ZOSF("ZOSFVXD")
13027
"RTN","ZTMGRSET",99,0)
13028
Q
13029
"RTN","ZTMGRSET",100,0)
13030
2 ;;MSM-PC/PLUS, MSM for NT or UNIX
13031
"RTN","ZTMGRSET",101,0)
13032
W !,"- Use autostart to do ZTMB don't resave as STUSER."
13033
"RTN","ZTMGRSET",102,0)
13034
S %S="ZOSVMSM^ZTBKCMSM^ZIS4MSM^ZISFMSM^ZISHMSM^XUCIMSM^ZISETMSM"
13035
"RTN","ZTMGRSET",103,0)
13036
D DES,MOVE
13037
"RTN","ZTMGRSET",104,0)
13038
S %S="ZOSV2MSM",%D="%ZOSV2"
13039
"RTN","ZTMGRSET",105,0)
13040
D MOVE,RUM,ZOSF("ZOSFMSM")
13041
"RTN","ZTMGRSET",106,0)
13042
I $$VERSION^%ZOSV(1)["UNIX" S %S="ZISHMSU",%D="%ZISH" D MOVE
13043
"RTN","ZTMGRSET",107,0)
13044
Q
13045
"RTN","ZTMGRSET",108,0)
13046
3 ;;OpenM for NT, Cache/NT, Cache/VMS
13047
"RTN","ZTMGRSET",109,0)
13048
S %S="ZOSVONT^^ZIS4ONT^ZISFONT^ZISHONT^XUCIONT"
13049
"RTN","ZTMGRSET",110,0)
13050
D DES,MOVE
13051
"RTN","ZTMGRSET",111,0)
13052
S %S="ZISTCPS",%D="%ZISTCPS"
13053
"RTN","ZTMGRSET",112,0)
13054
D MOVE,RUM,ZOSF("ZOSFONT")
13055
"RTN","ZTMGRSET",113,0)
13056
Q
13057
"RTN","ZTMGRSET",114,0)
13058
4 ;;Datatree, DTM-PC, DT-MAX
13059
"RTN","ZTMGRSET",115,0)
13060
S %S="ZOSVDTM^ZTBKCDTM^ZIS4DTM^ZISFDTM^ZISHDTM^XUCIDTM^ZISETDTM"
13061
"RTN","ZTMGRSET",116,0)
13062
D DES,MOVE
13063
"RTN","ZTMGRSET",117,0)
13064
S %S="ZOSV1DTM^ZTMB",%D="%ZOSV1^%ustart"
13065
"RTN","ZTMGRSET",118,0)
13066
D MOVE,ZOSF("ZOSFDTM")
13067
"RTN","ZTMGRSET",119,0)
13068
Q
13069
"RTN","ZTMGRSET",120,0)
13070
5 ;;MVX,ISM VAX
13071
"RTN","ZTMGRSET",121,0)
13072
S %S="ZOSVMSQ^ZTBKCMSQ^ZIS4MSQ^ZISFMSQ^ZISHMSQ^XUCIMSQ^ZISETMSQ"
13073
"RTN","ZTMGRSET",122,0)
13074
D DES,MOVE
13075
"RTN","ZTMGRSET",123,0)
13076
S %S="ZTMB",%D="ZSTU"
13077
"RTN","ZTMGRSET",124,0)
13078
D MOVE,ZOSF("ZOSFMSQ")
13079
"RTN","ZTMGRSET",125,0)
13080
Q
13081
"RTN","ZTMGRSET",126,0)
13082
6 ;;ISM (UNIX, Open VMS)
13083
"RTN","ZTMGRSET",127,0)
13084
S %S="ZOSVIS2^^ZIS4IS2^ZISFIS2^ZISHIS2^XUCIIS2^ZISETIS2"
13085
"RTN","ZTMGRSET",128,0)
13086
D DES,MOVE
13087
"RTN","ZTMGRSET",129,0)
13088
S %S="ZTMB",%D="ZSTU"
13089
"RTN","ZTMGRSET",130,0)
13090
D MOVE,ZOSF("ZOSFIS2")
13091
"RTN","ZTMGRSET",131,0)
13092
Q
13093
"RTN","ZTMGRSET",132,0)
13094
7 ;;GT.M (VMS)
13095
"RTN","ZTMGRSET",133,0)
13096
S %S="ZOSVGTM^ZTBKCGTM^ZIS4GTM^ZISFGTM^ZISHGTM^XUCIGTM^ZISETGTM"
13097
"RTN","ZTMGRSET",134,0)
13098
D DES,MOVE
13099
"RTN","ZTMGRSET",135,0)
13100
S %S="ZOSV2GTM^ZISTCPS",%D="%ZOSV2^%ZISTCPS"
13101
"RTN","ZTMGRSET",136,0)
13102
D MOVE,ZOSF("ZOSFGTM")
13103
"RTN","ZTMGRSET",137,0)
13104
Q
13105
"RTN","ZTMGRSET",138,0)
13106
8 ;;GT.M (Unix)
13107
"RTN","ZTMGRSET",139,0)
13108
S %S="ZOSVGUX^ZBBKCGUZ^ZIS4GTM^ZISFGTM^ZISHGUX^XUCIGTM^ZISETUP" ;ZISETGUX^ZTBKCGUX
13109
"RTN","ZTMGRSET",140,0)
13110
D DES,MOVE
13111
"RTN","ZTMGRSET",141,0)
13112
S %S="ZOSV2GTM^ZISTCPS^ZSSGUX",%D="%ZOSV2^%ZISTCPS^%SS"
13113
"RTN","ZTMGRSET",142,0)
13114
D MOVE,ZOSF("ZOSFGUX")
13115
"RTN","ZTMGRSET",143,0)
13116
D POSTGTM
13117
"RTN","ZTMGRSET",144,0)
13118
Q
13119
"RTN","ZTMGRSET",145,0)
13120
10 ;;NOT SUPPORTED
13121
"RTN","ZTMGRSET",146,0)
13122
Q
13123
"RTN","ZTMGRSET",147,0)
13124
MOVE ; rename % routines
13125
"RTN","ZTMGRSET",148,0)
13126
N %,X,Y
13127
"RTN","ZTMGRSET",149,0)
13128
F %=1:1:$L(%D,"^") D
13129
"RTN","ZTMGRSET",150,0)
13130
. S X=$P(%S,U,%) ; from
13131
"RTN","ZTMGRSET",151,0)
13132
. S Y=$P(%D,U,%) ; to
13133
"RTN","ZTMGRSET",152,0)
13134
. W !,"Routine: ",X
13135
"RTN","ZTMGRSET",153,0)
13136
. Q:X="" Q:Y="" I $T(^@X)="" W ?20," Missing" Q
13137
"RTN","ZTMGRSET",154,0)
13138
. X SCR Q:'$T
13139
"RTN","ZTMGRSET",155,0)
13140
. W ?20," Loaded, "
13141
"RTN","ZTMGRSET",156,0)
13142
. D COPY(X,Y)
13143
"RTN","ZTMGRSET",157,0)
13144
. W ?20,"Saved as ",Y
13145
"RTN","ZTMGRSET",158,0)
13146
Q
13147
"RTN","ZTMGRSET",159,0)
13148
;
13149
"RTN","ZTMGRSET",160,0)
13150
COPY(FROM,TO) ;
13151
"RTN","ZTMGRSET",161,0)
13152
I ZTOS'=7,ZTOS'=8 D Q
13153
"RTN","ZTMGRSET",162,0)
13154
.N SAME,%,T S SAME=1
13155
"RTN","ZTMGRSET",163,0)
13156
.F %=1:1 S T=$T(+%^@FROM) Q:T="" I $T(+%^@TO)'=T S SAME=0 Q ;FIND IF ROUTINE IS ON FILE IN EXACTLY THIS FORM!!
13157
"RTN","ZTMGRSET",164,0)
13158
.I $T(+%^@TO)]"" S SAME=0
13159
"RTN","ZTMGRSET",165,0)
13160
.I 'SAME X "ZL @FROM ZS @TO"
13161
"RTN","ZTMGRSET",166,0)
13162
;For GT.M below
13163
"RTN","ZTMGRSET",167,0)
13164
S TO=$TR(TO,"%","_")
13165
"RTN","ZTMGRSET",168,0)
13166
N PATH,SRC,DST,COPY
13167
"RTN","ZTMGRSET",169,0)
13168
S PATH=$$R
13169
"RTN","ZTMGRSET",170,0)
13170
N %ZR D SILENT^%RSEL(FROM) S SRC=%ZR(FROM)_FROM_".m"
13171
"RTN","ZTMGRSET",171,0)
13172
S DST=PATH_TO_".m"
13173
"RTN","ZTMGRSET",172,0)
13174
S COPY=$S(ZTOS=7:"COPY",1:"cp")
13175
"RTN","ZTMGRSET",173,0)
13176
ZSYSTEM COPY_" "_SRC_" "_DST
13177
"RTN","ZTMGRSET",174,0)
13178
ZLINK TO
13179
"RTN","ZTMGRSET",175,0)
13180
Q
13181
"RTN","ZTMGRSET",176,0)
13182
;
13183
"RTN","ZTMGRSET",177,0)
13184
R() ; routine directory for GT.M
13185
"RTN","ZTMGRSET",178,0)
13186
I ZTOS=7 Q $P($ZRO,",")
13187
"RTN","ZTMGRSET",179,0)
13188
I ZTOS=8 Q $$RTNDIR^ZOSVGUX
13189
"RTN","ZTMGRSET",180,0)
13190
E Q ""
13191
"RTN","ZTMGRSET",181,0)
13192
;
13193
"RTN","ZTMGRSET",182,0)
13194
DES S %D="%ZOSV^%ZTBKC1^%ZIS4^%ZISF^%ZISH^%XUCI^ZISETUP" Q
13195
"RTN","ZTMGRSET",183,0)
13196
;
13197
"RTN","ZTMGRSET",184,0)
13198
GLOBALS ;Set node zero of file #3.05 & #3.07
13199
"RTN","ZTMGRSET",185,0)
13200
W !!,"Now, I will check your % globals."
13201
"RTN","ZTMGRSET",186,0)
13202
W ".........."
13203
"RTN","ZTMGRSET",187,0)
13204
F %="^%ZIS","^%ZISL","^%ZTER","^%ZUA" S:'$D(@%) @%=""
13205
"RTN","ZTMGRSET",188,0)
13206
S:$D(^%ZTSK(0))[0 ^%ZTSK(-1)=100,^%ZTSCH=""
13207
"RTN","ZTMGRSET",189,0)
13208
S Z1=$G(^%ZTSK(-1),-1),Z2=$G(^%ZTSK(0))
13209
"RTN","ZTMGRSET",190,0)
13210
I Z1'=$P(Z2,"^",3) S:Z1'>0 ^%ZTSK(-1)=+Z2 S ^%ZTSK(0)="TASK'S^14.4^"_^%ZTSK(-1)
13211
"RTN","ZTMGRSET",191,0)
13212
S:$D(^%ZUA(3.05,0))[0 ^%ZUA(3.05,0)="FAILED ACCESS ATTEMPTS LOG^3.05^^"
13213
"RTN","ZTMGRSET",192,0)
13214
S:$D(^%ZUA(3.07,0))[0 ^%ZUA(3.07,0)="PROGRAMMER MODE LOG^3.07^^"
13215
"RTN","ZTMGRSET",193,0)
13216
Q
13217
"RTN","ZTMGRSET",194,0)
13218
NAME ;Setup the static names for this system
13219
"RTN","ZTMGRSET",195,0)
13220
MGR W !,"NAME OF MANAGER'S UCI,VOLUME SET: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:0[Y S ^%ZOSF("MGR")=X
13221
"RTN","ZTMGRSET",196,0)
13222
PROD W !,"PRODUCTION (SIGN-ON) UCI,VOLUME SET: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:0[Y S ^%ZOSF("PROD")=X
13223
"RTN","ZTMGRSET",197,0)
13224
VOL W !,"NAME OF VOLUME SET: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?3U ^%ZOSF("VOL")=X I X'?3U W "MUST BE 3 Upper case." G VOL
13225
"RTN","ZTMGRSET",198,0)
13226
W ! Q
13227
"RTN","ZTMGRSET",199,0)
13228
POSTGTM ;postinit for GTM
13229
"RTN","ZTMGRSET",200,0)
13230
S ZTOS=8
13231
"RTN","ZTMGRSET",201,0)
13232
F ROU="ZSTART","ZSTOP" D
13233
"RTN","ZTMGRSET",202,0)
13234
.S ZSTRT=$T(@(U_ROU))
13235
"RTN","ZTMGRSET",203,0)
13236
.I ZSTRT="" D BMES^XPDUTL("You do not currently have a "_ROU_" routine")
13237
"RTN","ZTMGRSET",204,0)
13238
.I ZSTRT'="" D BMES^XPDUTL(ZSTRT),BMES^XPDUTL("This is your current "_ROU)
13239
"RTN","ZTMGRSET",205,0)
13240
.D BMES^XPDUTL("Do you wish to save "_ROU_"GUX as "_ROU) S %=2 D YN^DICN
13241
"RTN","ZTMGRSET",206,0)
13242
.I %=1 D COPY(ROU_"GUX",ROU)
13243
"RTN","ZUGTM")
13244
0^8^B10012519
13245
"RTN","ZUGTM",1,0)
13246
ZU ;SF/JLI,RWF MSC/JDS,JKT- For GT.M, TIE ALL TERMINALS TO THIS ROUTINE!! ;25JUN2009
13247
"RTN","ZUGTM",2,0)
13248
;;8.0;KERNEL;**275,MSC**;Jul 10, 1995
13249
"RTN","ZUGTM",3,0)
13250
; for GT.M for VMS & Unix, version 4.3
13251
"RTN","ZUGTM",4,0)
13252
;
13253
"RTN","ZUGTM",5,0)
13254
;The env var ZINTRRUPT should be set to catch all interrupts.
13255
"RTN","ZUGTM",6,0)
13256
EN ;See that escape processing is off, Conflict with Screenman
13257
"RTN","ZUGTM",7,0)
13258
U $P:(NOCENABLE:NOESCAPE)
13259
"RTN","ZUGTM",8,0)
13260
D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGIN$")
13261
"RTN","ZUGTM",9,0)
13262
N $ESTACK,$ETRAP S $ETRAP="D ERR^ZU Q:$QUIT -9 Q"
13263
"RTN","ZUGTM",10,0)
13264
S $ZINTERRUPT="I $$JOBEXAM^ZU($ZPOSITION)"
13265
"RTN","ZUGTM",11,0)
13266
D COUNT^XUSCNT(1)
13267
"RTN","ZUGTM",12,0)
13268
G ^XUS
13269
"RTN","ZUGTM",13,0)
13270
;
13271
"RTN","ZUGTM",14,0)
13272
G ;Entry point for GUI device.
13273
"RTN","ZUGTM",15,0)
13274
Q
13275
"RTN","ZUGTM",16,0)
13276
;
13277
"RTN","ZUGTM",17,0)
13278
ERR ;Come here on error
13279
"RTN","ZUGTM",18,0)
13280
; handle stack overflow errors specially
13281
"RTN","ZUGTM",19,0)
13282
I $P($ZS,",",3)["STACKOFLOW" S $ET="Q:$ST>"_($ST-8)_" D ERR2^ZU" Q
13283
"RTN","ZUGTM",20,0)
13284
;
13285
"RTN","ZUGTM",21,0)
13286
ERR2 S $ETRAP="D UNWIND^ZU" L U $P:NOCENABLE
13287
"RTN","ZUGTM",22,0)
13288
;
13289
"RTN","ZUGTM",23,0)
13290
Q:$ECODE["<PROG>"
13291
"RTN","ZUGTM",24,0)
13292
I $P($ZS,",",2,3)["^XUS1A:2, %GTM-E-IOWRITERR" G HALT
13293
"RTN","ZUGTM",25,0)
13294
;
13295
"RTN","ZUGTM",26,0)
13296
I $G(IO)]"",$D(IO(1,IO)),$E($G(IOST))="P" D
13297
"RTN","ZUGTM",27,0)
13298
. U IO
13299
"RTN","ZUGTM",28,0)
13300
. W @$S($D(IOF):IOF,1:"#")
13301
"RTN","ZUGTM",29,0)
13302
I $G(IO(0))]"" D
13303
"RTN","ZUGTM",30,0)
13304
. U IO(0)
13305
"RTN","ZUGTM",31,0)
13306
. W !!,"RECORDING THAT AN ERROR OCCURRED ---"
13307
"RTN","ZUGTM",32,0)
13308
. W !!?15,"Sorry 'bout that"
13309
"RTN","ZUGTM",33,0)
13310
. W !,*7
13311
"RTN","ZUGTM",34,0)
13312
. W !?10,"$STACK=",$STACK," $ECODE=",$ECODE
13313
"RTN","ZUGTM",35,0)
13314
. W !?10,"$ZSTATUS=",$ZSTATUS
13315
"RTN","ZUGTM",36,0)
13316
;
13317
"RTN","ZUGTM",37,0)
13318
D ^%ZTER K %ZT S XUERF="" ; Capture symbol table first!
13319
"RTN","ZUGTM",38,0)
13320
;
13321
"RTN","ZUGTM",39,0)
13322
I $G(DUZ)'>0 G HALT
13323
"RTN","ZUGTM",40,0)
13324
;
13325
"RTN","ZUGTM",41,0)
13326
CTRLC I $D(IO)=11 U IO(0) C:IO'=IO(0) IO S IO=IO(0)
13327
"RTN","ZUGTM",42,0)
13328
W:$P($ZS,",",3)["-CTRLC" !,"--Interrupt Acknowledged",!
13329
"RTN","ZUGTM",43,0)
13330
D KILL1^XUSCLEAN ;Clean up symbol table
13331
"RTN","ZUGTM",44,0)
13332
S $ECODE=",<<POP>>,"
13333
"RTN","ZUGTM",45,0)
13334
Q
13335
"RTN","ZUGTM",46,0)
13336
;
13337
"RTN","ZUGTM",47,0)
13338
UNWIND ;Unwind the stack
13339
"RTN","ZUGTM",48,0)
13340
Q:$ESTACK>1 G CONT:$ECODE["<<HALT>>",CTRLC2:$ECODE["<<POP>>"
13341
"RTN","ZUGTM",49,0)
13342
S $ECODE=""
13343
"RTN","ZUGTM",50,0)
13344
Q
13345
"RTN","ZUGTM",51,0)
13346
;
13347
"RTN","ZUGTM",52,0)
13348
CTRLC2 S $ECODE="" G:$G(^XUTL("XQ",$J,"T"))<2 ^XUSCLEAN
13349
"RTN","ZUGTM",53,0)
13350
S ^XUTL("XQ",$J,"T")=1,XQY=$G(^(1)),XQY0=$P(XQY,"^",2,99)
13351
"RTN","ZUGTM",54,0)
13352
G:$P(XQY0,"^",4)'="M" CTRLC2
13353
"RTN","ZUGTM",55,0)
13354
S XQPSM=$P(XQY,"^",1),XQY=+XQPSM,XQPSM=$P(XQPSM,XQY,2,3)
13355
"RTN","ZUGTM",56,0)
13356
G:'XQY ^XUSCLEAN
13357
"RTN","ZUGTM",57,0)
13358
S $ECODE="",$ETRAP="D ERR^ZU Q:$QUIT 0 Q"
13359
"RTN","ZUGTM",58,0)
13360
U $P:NOESCAPE G M1^XQ
13361
"RTN","ZUGTM",59,0)
13362
;
13363
"RTN","ZUGTM",60,0)
13364
HALT I $D(^XUTL("XQ",$J)) D:$G(DUZ)>0 BYE^XUSCLEAN
13365
"RTN","ZUGTM",61,0)
13366
D COUNT^XUSCNT(-1)
13367
"RTN","ZUGTM",62,0)
13368
I '$ESTACK G CONT
13369
"RTN","ZUGTM",63,0)
13370
S $ETRAP="D UNWIND^ZU" ;Set new trap
13371
"RTN","ZUGTM",64,0)
13372
S $ECODE=",<<HALT>>," ;Cause error to unwind stack
13373
"RTN","ZUGTM",65,0)
13374
D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGOUT$")
13375
"RTN","ZUGTM",66,0)
13376
Q
13377
"RTN","ZUGTM",67,0)
13378
CONT ;
13379
"RTN","ZUGTM",68,0)
13380
S $ECODE="",$ETRAP=""
13381
"RTN","ZUGTM",69,0)
13382
D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGOUT$")
13383
"RTN","ZUGTM",70,0)
13384
I $D(XQXFLG("HALT")) HALT
13385
"RTN","ZUGTM",71,0)
13386
I ($PRINCIPAL["_TNA") HALT ;Check for TelNet
13387
"RTN","ZUGTM",72,0)
13388
S X="Waiting "_($J#1000000) D SETENV^%ZOSV ;Change VMS name
13389
"RTN","ZUGTM",73,0)
13390
;For sites that want to retain the connection, uncomment the next line
13391
"RTN","ZUGTM",74,0)
13392
;U $P:NOCENABLE R !,"Enter return to continue: ",X:600 S:'$T X="^" G:X'="^" ^ZU
13393
"RTN","ZUGTM",75,0)
13394
HALT
13395
"RTN","ZUGTM",76,0)
13396
;
13397
"RTN","ZUGTM",77,0)
13398
JOBEXAM(%ZPOS) ;
13399
"RTN","ZUGTM",78,0)
13400
N %reference S %reference=$REFERENCE
13401
"RTN","ZUGTM",79,0)
13402
S ^XUTL("XUSYS",$J,0)=$H,^XUTL("XUSYS",$J,"INTERRUPT")=$G(%ZPOS)
13403
"RTN","ZUGTM",80,0)
13404
K ^XUTL("XUSYS",$J,"JE")
13405
"RTN","ZUGTM",81,0)
13406
I $G(^XUTL("XUSYS","COMMAND"))'="EXAM" ZSHOW "SD":^XUTL("XUSYS",$J,"JE")
13407
"RTN","ZUGTM",82,0)
13408
I $G(^XUTL("XUSYS","COMMAND"))="EXAM" ZSHOW "*":^XUTL("XUSYS",$J,"JE")
13409
"RTN","ZUGTM",83,0)
13410
I $G(^XUTL("XUSYS",$J,"CMD"))="HALT" ;To do.
13411
"RTN","ZUGTM",84,0)
13412
S ^TMP("MSCZJOB",$J,0)=$H
13413
"RTN","ZUGTM",85,0)
13414
ZSHOW "*":^TMP("MSCZJOB",$J)
13415
"RTN","ZUGTM",86,0)
13416
Q 1
13417
"RTN","ZUGTM",87,0)
13418
;
13419
"VER")
13420
8.0^22.0
13421
**END**
13422
**END**
Loggerhead is a web-based interface for Breezy
Version: 2.0.1