1
KIDS Distribution saved on Apr 28, 2010@14:41:20
2
VERSION 15 - UPDATE ZTMGRSET
3
**KIDS**:MSC GTM INTEGRATION*1.0*15^
6
MSC GTM INTEGRATION*1.0*15
8
MSC GTM INTEGRATION*1.0*15^^0^3100428^y
12
SYSTEM STATUS AND JOBEXAM FOR GT.M
21
"BLD",7026,"KRN",.4,0)
23
"BLD",7026,"KRN",.401,0)
25
"BLD",7026,"KRN",.402,0)
27
"BLD",7026,"KRN",.403,0)
29
"BLD",7026,"KRN",.403,"NM",0)
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)
37
"BLD",7026,"KRN",.403,"NM","B","MSCZLOCK FILE #3.081",2)
39
"BLD",7026,"KRN",.5,0)
41
"BLD",7026,"KRN",.84,0)
43
"BLD",7026,"KRN",3.6,0)
45
"BLD",7026,"KRN",3.8,0)
47
"BLD",7026,"KRN",9.2,0)
49
"BLD",7026,"KRN",9.2,"NM",0)
51
"BLD",7026,"KRN",9.8,0)
53
"BLD",7026,"KRN",9.8,"NM",0)
55
"BLD",7026,"KRN",9.8,"NM",1,0)
57
"BLD",7026,"KRN",9.8,"NM",4,0)
59
"BLD",7026,"KRN",9.8,"NM",5,0)
61
"BLD",7026,"KRN",9.8,"NM",7,0)
63
"BLD",7026,"KRN",9.8,"NM",8,0)
65
"BLD",7026,"KRN",9.8,"NM",11,0)
67
"BLD",7026,"KRN",9.8,"NM",13,0)
69
"BLD",7026,"KRN",9.8,"NM",14,0)
71
"BLD",7026,"KRN",9.8,"NM",15,0)
73
"BLD",7026,"KRN",9.8,"NM",16,0)
75
"BLD",7026,"KRN",9.8,"NM",17,0)
77
"BLD",7026,"KRN",9.8,"NM",18,0)
79
"BLD",7026,"KRN",9.8,"NM",19,0)
81
"BLD",7026,"KRN",9.8,"NM",20,0)
83
"BLD",7026,"KRN",9.8,"NM",21,0)
85
"BLD",7026,"KRN",9.8,"NM",22,0)
87
"BLD",7026,"KRN",9.8,"NM",23,0)
89
"BLD",7026,"KRN",9.8,"NM",24,0)
91
"BLD",7026,"KRN",9.8,"NM",25,0)
93
"BLD",7026,"KRN",9.8,"NM",26,0)
95
"BLD",7026,"KRN",9.8,"NM",27,0)
97
"BLD",7026,"KRN",9.8,"NM",28,0)
99
"BLD",7026,"KRN",9.8,"NM",29,0)
101
"BLD",7026,"KRN",9.8,"NM",31,0)
103
"BLD",7026,"KRN",9.8,"NM",32,0)
105
"BLD",7026,"KRN",9.8,"NM",33,0)
107
"BLD",7026,"KRN",9.8,"NM",34,0)
108
DGMSTAPI^^0^B48539163
109
"BLD",7026,"KRN",9.8,"NM",35,0)
111
"BLD",7026,"KRN",9.8,"NM",36,0)
113
"BLD",7026,"KRN",9.8,"NM",37,0)
115
"BLD",7026,"KRN",9.8,"NM",38,0)
117
"BLD",7026,"KRN",9.8,"NM",39,0)
119
"BLD",7026,"KRN",9.8,"NM",40,0)
121
"BLD",7026,"KRN",9.8,"NM",41,0)
123
"BLD",7026,"KRN",9.8,"NM",42,0)
124
XQALSUR1^^0^B29675685
125
"BLD",7026,"KRN",9.8,"NM",43,0)
127
"BLD",7026,"KRN",9.8,"NM",44,0)
129
"BLD",7026,"KRN",9.8,"NM",46,0)
131
"BLD",7026,"KRN",9.8,"NM",47,0)
133
"BLD",7026,"KRN",9.8,"NM",48,0)
135
"BLD",7026,"KRN",9.8,"NM",49,0)
137
"BLD",7026,"KRN",9.8,"NM",50,0)
139
"BLD",7026,"KRN",9.8,"NM",51,0)
141
"BLD",7026,"KRN",9.8,"NM",52,0)
143
"BLD",7026,"KRN",9.8,"NM",53,0)
144
HLCSTCP2^^0^B62380874
145
"BLD",7026,"KRN",9.8,"NM",54,0)
147
"BLD",7026,"KRN",9.8,"NM",55,0)
149
"BLD",7026,"KRN",9.8,"NM","B","DGMSTAPI",34)
151
"BLD",7026,"KRN",9.8,"NM","B","GMRCA2",35)
153
"BLD",7026,"KRN",9.8,"NM","B","HLCSLNCH",18)
155
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP",17)
157
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP1",16)
159
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP2",53)
161
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP3",54)
163
"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP4",55)
165
"BLD",7026,"KRN",9.8,"NM","B","HLZTCP",52)
167
"BLD",7026,"KRN",9.8,"NM","B","MAGDMEDL",36)
169
"BLD",7026,"KRN",9.8,"NM","B","MSCXUS3A",31)
171
"BLD",7026,"KRN",9.8,"NM","B","MSCZJOB",1)
173
"BLD",7026,"KRN",9.8,"NM","B","MSCZJOBS",46)
175
"BLD",7026,"KRN",9.8,"NM","B","MSCZJOBU",4)
177
"BLD",7026,"KRN",9.8,"NM","B","PRCSEA",37)
179
"BLD",7026,"KRN",9.8,"NM","B","PSBOMH1",38)
181
"BLD",7026,"KRN",9.8,"NM","B","PSBRPC2",39)
183
"BLD",7026,"KRN",9.8,"NM","B","PXRMTMED",40)
185
"BLD",7026,"KRN",9.8,"NM","B","RORHL7A",32)
187
"BLD",7026,"KRN",9.8,"NM","B","VALMW3",41)
189
"BLD",7026,"KRN",9.8,"NM","B","XOBVLL",19)
191
"BLD",7026,"KRN",9.8,"NM","B","XOBVRH",20)
193
"BLD",7026,"KRN",9.8,"NM","B","XOBVSKT",21)
195
"BLD",7026,"KRN",9.8,"NM","B","XOBVTCPL",22)
197
"BLD",7026,"KRN",9.8,"NM","B","XPDR",26)
199
"BLD",7026,"KRN",9.8,"NM","B","XQALSUR1",42)
201
"BLD",7026,"KRN",9.8,"NM","B","XTER1A",7)
203
"BLD",7026,"KRN",9.8,"NM","B","XUMF5AU",43)
205
"BLD",7026,"KRN",9.8,"NM","B","XWBRW",50)
207
"BLD",7026,"KRN",9.8,"NM","B","XWBSEC",51)
209
"BLD",7026,"KRN",9.8,"NM","B","XWBTCPM",23)
211
"BLD",7026,"KRN",9.8,"NM","B","ZCD",11)
213
"BLD",7026,"KRN",9.8,"NM","B","ZIS4GTM",5)
215
"BLD",7026,"KRN",9.8,"NM","B","ZISFGTM",48)
217
"BLD",7026,"KRN",9.8,"NM","B","ZISFGUX",27)
219
"BLD",7026,"KRN",9.8,"NM","B","ZISHGUX",15)
221
"BLD",7026,"KRN",9.8,"NM","B","ZISTCPS",25)
223
"BLD",7026,"KRN",9.8,"NM","B","ZOSFGUX",14)
225
"BLD",7026,"KRN",9.8,"NM","B","ZOSV2GTM",13)
227
"BLD",7026,"KRN",9.8,"NM","B","ZOSVGUX",33)
229
"BLD",7026,"KRN",9.8,"NM","B","ZOSVONT",47)
231
"BLD",7026,"KRN",9.8,"NM","B","ZSSGUX",49)
233
"BLD",7026,"KRN",9.8,"NM","B","ZSTARTGUX",29)
235
"BLD",7026,"KRN",9.8,"NM","B","ZSTOPGUX",44)
237
"BLD",7026,"KRN",9.8,"NM","B","ZTER",28)
239
"BLD",7026,"KRN",9.8,"NM","B","ZTMGRSET",24)
241
"BLD",7026,"KRN",9.8,"NM","B","ZUGTM",8)
243
"BLD",7026,"KRN",19,0)
245
"BLD",7026,"KRN",19,"NM",0)
247
"BLD",7026,"KRN",19,"NM",1,0)
249
"BLD",7026,"KRN",19,"NM",2,0)
251
"BLD",7026,"KRN",19,"NM","B","MSCZJOB",1)
253
"BLD",7026,"KRN",19,"NM","B","MSCZLOCK",2)
255
"BLD",7026,"KRN",19.1,0)
257
"BLD",7026,"KRN",101,0)
259
"BLD",7026,"KRN",409.61,0)
261
"BLD",7026,"KRN",771,0)
263
"BLD",7026,"KRN",870,0)
265
"BLD",7026,"KRN",8989.51,0)
267
"BLD",7026,"KRN",8989.52,0)
269
"BLD",7026,"KRN",8994,0)
271
"BLD",7026,"KRN","B",.4,.4)
273
"BLD",7026,"KRN","B",.401,.401)
275
"BLD",7026,"KRN","B",.402,.402)
277
"BLD",7026,"KRN","B",.403,.403)
279
"BLD",7026,"KRN","B",.5,.5)
281
"BLD",7026,"KRN","B",.84,.84)
283
"BLD",7026,"KRN","B",3.6,3.6)
285
"BLD",7026,"KRN","B",3.8,3.8)
287
"BLD",7026,"KRN","B",9.2,9.2)
289
"BLD",7026,"KRN","B",9.8,9.8)
291
"BLD",7026,"KRN","B",19,19)
293
"BLD",7026,"KRN","B",19.1,19.1)
295
"BLD",7026,"KRN","B",101,101)
297
"BLD",7026,"KRN","B",409.61,409.61)
299
"BLD",7026,"KRN","B",771,771)
301
"BLD",7026,"KRN","B",870,870)
303
"BLD",7026,"KRN","B",8989.51,8989.51)
305
"BLD",7026,"KRN","B",8989.52,8989.52)
307
"BLD",7026,"KRN","B",8994,8994)
310
/home/jon/MSC_GTM_INTEG_15.KID
312
VERSION 15 - UPDATE ZTMGRSET
320
MSCZJOBEXAM^ ^@^^3070530.1755^^^3.081^0^1^1
327
"KRN",.403,121,40,1,0)
329
"KRN",.403,121,40,1,1)
331
"KRN",.403,121,40,1,40,0)
333
"KRN",.403,121,40,1,40,432,0)
335
"KRN",.403,121,40,1,40,432,2)
337
"KRN",.403,121,40,1,40,432,"COMP MUL")
339
"KRN",.403,121,40,1,40,432,"COMP MUL PTR")
341
"KRN",.403,121,40,1,40,433,0)
342
MSCZJOBEXAM HDR^1^1,2^d
343
"KRN",.403,121,40,2,0)
345
"KRN",.403,121,40,2,1)
347
"KRN",.403,121,40,2,40,0)
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)
353
"KRN",.403,121,40,2,40,435,2)
355
"KRN",.403,121,40,2,40,435,"COMP MUL")
357
"KRN",.403,121,40,2,40,437,0)
359
"KRN",.403,121,40,2,40,437,2)
361
"KRN",.403,121,40,2,40,437,"COMP MUL")
363
"KRN",.403,121,40,3,0)
365
"KRN",.403,121,40,3,1)
367
"KRN",.403,121,40,3,40,0)
369
"KRN",.403,121,40,3,40,436,0)
371
"KRN",.403,121,40,3,40,436,2)
373
"KRN",.403,121,40,3,40,436,"COMP MUL")
375
"KRN",.403,121,21400)
380
MSCZLOCK^ ^@^^3070530.1755^^^3.081^0^1^1
383
"KRN",.403,122,40,1,0)
385
"KRN",.403,122,40,1,1)
387
"KRN",.403,122,40,1,40,0)
389
"KRN",.403,122,40,1,40,438,0)
391
"KRN",.403,122,40,1,40,438,2)
393
"KRN",.403,122,40,1,40,438,"COMP MUL")
395
"KRN",.403,122,40,1,40,439,0)
396
MSCZJOBLOCK HDR^1^1,1^d
401
"KRN",.404,432,40,1,0)
403
"KRN",.404,432,40,1,2)
405
"KRN",.404,432,40,1,3)
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)
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)
415
"KRN",.404,432,40,2,0)
417
"KRN",.404,432,40,2,2)
419
"KRN",.404,432,40,2,3)
421
"KRN",.404,432,40,2,3.1)
422
S Y=$$DEV^MSCZJOB(D0)
423
"KRN",.404,432,40,2,4)
425
"KRN",.404,432,40,2,20)
427
"KRN",.404,432,40,3,0)
429
"KRN",.404,432,40,3,2)
431
"KRN",.404,432,40,3,3)
433
"KRN",.404,432,40,3,3.1)
434
S Y=$$NSP^MSCZJOB(D0)
435
"KRN",.404,432,40,3,4)
437
"KRN",.404,432,40,3,20)
439
"KRN",.404,432,40,4,0)
441
"KRN",.404,432,40,4,2)
443
"KRN",.404,432,40,4,3)
445
"KRN",.404,432,40,4,3.1)
446
S Y=$$ROUTINE^MSCZJOB(D0)
447
"KRN",.404,432,40,4,4)
449
"KRN",.404,432,40,4,20)
451
"KRN",.404,432,40,5,0)
453
"KRN",.404,432,40,5,2)
455
"KRN",.404,432,40,5,3)
457
"KRN",.404,432,40,5,3.1)
458
S Y=$$USER^MSCZJOB(D0)
459
"KRN",.404,432,40,5,4)
461
"KRN",.404,432,40,5,20)
464
MSCZJOBEXAM HDR^3.081^
467
"KRN",.404,433,40,1,0)
468
1^Process Device User Namespace Routine ^1
469
"KRN",.404,433,40,1,2)
471
"KRN",.404,433,40,2,0)
473
"KRN",.404,433,40,2,.1)
474
S Y=$$GET1^DIQ(8989.3,1,.01)
475
"KRN",.404,433,40,2,2)
481
"KRN",.404,434,40,1,0)
483
"KRN",.404,434,40,1,2)
485
"KRN",.404,434,40,1,3)
487
"KRN",.404,434,40,1,3.1)
488
S Y=$$JOB^MSCZJOB(MSCJOBD0)
489
"KRN",.404,434,40,1,20)
491
"KRN",.404,434,40,2,0)
492
2^NSpace^2^^NAMESPACE
493
"KRN",.404,434,40,2,2)
495
"KRN",.404,434,40,2,3)
497
"KRN",.404,434,40,2,3.1)
498
S Y=$$NSP^MSCZJOB(MSCJOBD0)
499
"KRN",.404,434,40,2,4)
501
"KRN",.404,434,40,2,20)
503
"KRN",.404,434,40,3,0)
505
"KRN",.404,434,40,3,2)
507
"KRN",.404,434,40,3,3)
509
"KRN",.404,434,40,3,3.1)
510
S Y=$$ROUTINE^MSCZJOB(MSCJOBD0)
511
"KRN",.404,434,40,3,4)
513
"KRN",.404,434,40,3,20)
515
"KRN",.404,434,40,4,0)
517
"KRN",.404,434,40,4,2)
519
"KRN",.404,434,40,4,3)
521
"KRN",.404,434,40,4,3.1)
522
S Y=$$USER^MSCZJOB(MSCJOBD0)
523
"KRN",.404,434,40,4,4)
525
"KRN",.404,434,40,4,20)
527
"KRN",.404,434,40,5,0)
529
"KRN",.404,434,40,5,2)
531
"KRN",.404,434,40,5,3)
533
"KRN",.404,434,40,5,3.1)
534
S Y=$$DEV^MSCZJOB(MSCJOBD0)
535
"KRN",.404,434,40,5,4)
537
"KRN",.404,434,40,5,20)
539
"KRN",.404,434,40,6,0)
541
"KRN",.404,434,40,6,2)
543
"KRN",.404,434,40,6,3)
545
"KRN",.404,434,40,6,3.1)
547
"KRN",.404,434,40,6,10)
549
"KRN",.404,434,40,6,20)
551
"KRN",.404,434,40,7,0)
553
"KRN",.404,434,40,7,2)
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)
563
"KRN",.404,435,40,1,0)
565
"KRN",.404,435,40,1,2)
567
"KRN",.404,435,40,1,3)
569
"KRN",.404,435,40,1,3.1)
570
S Y=$P(@MSC@(MSCJOBID,"V",D0),"=")
571
"KRN",.404,435,40,1,4)
573
"KRN",.404,435,40,1,20)
575
"KRN",.404,435,40,2,0)
576
2^^2^^VALUE OF VARIABLE
577
"KRN",.404,435,40,2,2)
579
"KRN",.404,435,40,2,3)
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)
585
"KRN",.404,435,40,2,20)
587
"KRN",.404,435,40,3,0)
589
"KRN",.404,435,40,3,2)
595
"KRN",.404,436,40,1,0)
597
"KRN",.404,436,40,1,2)
599
"KRN",.404,436,40,1,3)
601
"KRN",.404,436,40,1,3.1)
602
S Y=@MSC@(MSCJOBID,"L",D0)
603
"KRN",.404,436,40,1,4)
605
"KRN",.404,436,40,1,20)
607
"KRN",.404,436,40,2,0)
609
"KRN",.404,436,40,2,2)
611
"KRN",.404,436,40,2,13)
612
I DDSEXT="YES" D UNLOCK^MSCZJOB(D0)
613
"KRN",.404,436,40,2,20)
619
"KRN",.404,437,40,1,0)
621
"KRN",.404,437,40,1,2)
623
"KRN",.404,437,40,1,3)
625
"KRN",.404,437,40,1,3.1)
626
S Y=$$STACK^MSCZJOB(D0)
627
"KRN",.404,437,40,1,4)
629
"KRN",.404,437,40,1,20)
635
"KRN",.404,438,40,1,0)
637
"KRN",.404,438,40,1,2)
639
"KRN",.404,438,40,1,3)
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)
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)
649
"KRN",.404,438,40,2,0)
651
"KRN",.404,438,40,2,2)
653
"KRN",.404,438,40,2,3)
655
"KRN",.404,438,40,2,3.1)
656
S Y=$TR($P($G(MSCZLK(D0)),U),"~")
657
"KRN",.404,438,40,2,4)
659
"KRN",.404,438,40,2,20)
661
"KRN",.404,438,40,3,0)
663
"KRN",.404,438,40,3,2)
665
"KRN",.404,438,40,3,3)
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)
671
"KRN",.404,438,40,3,20)
673
"KRN",.404,438,40,4,0)
675
"KRN",.404,438,40,4,2)
677
"KRN",.404,438,40,4,3)
679
"KRN",.404,438,40,4,4)
681
"KRN",.404,438,40,4,13)
682
I DDSEXT="YES" D UNL^MSCZJOB(D0)
683
"KRN",.404,438,40,4,20)
685
"KRN",.404,438,40,5,0)
687
"KRN",.404,438,40,5,2)
689
"KRN",.404,438,40,5,3)
691
"KRN",.404,438,40,5,3.1)
692
S Y=$P($G(MSCZLK(D0)),U,2)
693
"KRN",.404,438,40,5,4)
695
"KRN",.404,438,40,5,20)
698
MSCZJOBLOCK HDR^3.081
701
"KRN",.404,439,40,1,0)
702
1^Process Lock User Routine Unlock^1
703
"KRN",.404,439,40,1,2)
705
"KRN",.404,439,40,2,0)
707
"KRN",.404,439,40,2,.1)
708
S Y=$$GET1^DIQ(8989.3,1,.01)
709
"KRN",.404,439,40,2,2)
714
MSCZJOB^JOB EXAMINE^^R^^^^^^^^
717
"KRN",19,14339,1,1,0)
726
MSCZLOCK^LOCK EXAMINE^^R^^^^^^^^
729
"KRN",19,14340,1,1,0)
738
9.8;;1;RTNF^XPDTA;RTNE^XPDTA
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,"",%)
746
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
756
Shall I write over your |FLAG| File
766
Want my data |FLAG| yours
776
Want KIDS to INHIBIT LOGONs during the install
786
Enter the Coordinator for Mail Group '|FLAG|'
796
Want KIDS to Rebuild Menu Trees Upon Completion of Install
806
Want to DISABLE Scheduled Options, Menu Options, and Protocols
816
Want to MOVE routines to other CPUs
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)
831
"RTN","DGMSTAPI",4,0)
833
"RTN","DGMSTAPI",5,0)
834
GETSTAT(DFN,DGDATE) ; Retrieves the current MST status for a patient
835
"RTN","DGMSTAPI",6,0)
837
"RTN","DGMSTAPI",7,0)
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)
845
"RTN","DGMSTAPI",11,0)
847
"RTN","DGMSTAPI",12,0)
848
; DGMST - Format will depend on result of lookup
849
"RTN","DGMSTAPI",13,0)
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)
871
"RTN","DGMSTAPI",24,0)
872
; If no MST History is found, then:
873
"RTN","DGMSTAPI",25,0)
875
"RTN","DGMSTAPI",26,0)
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)
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)
891
"RTN","DGMSTAPI",34,0)
892
N DGMST,DGIEN,DGFDA,DGMSG
893
"RTN","DGMSTAPI",35,0)
895
"RTN","DGMSTAPI",36,0)
896
I '+DFN!('$D(^DPT(DFN,0))) D G STATQ
897
"RTN","DGMSTAPI",37,0)
899
"RTN","DGMSTAPI",38,0)
900
I '$D(^DGMS(29.11,"APDT",DFN)) D G STATQ
901
"RTN","DGMSTAPI",39,0)
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)
909
"RTN","DGMSTAPI",43,0)
911
"RTN","DGMSTAPI",44,0)
913
"RTN","DGMSTAPI",45,0)
914
S DGIEN=+$O(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1)
915
"RTN","DGMSTAPI",46,0)
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)
923
"RTN","DGMSTAPI",50,0)
925
"RTN","DGMSTAPI",51,0)
927
"RTN","DGMSTAPI",52,0)
928
D GETS^DIQ(29.11,+DGIEN_",","*","IE","DGFDA","DGMSG")
929
"RTN","DGMSTAPI",53,0)
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)
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)
945
"RTN","DGMSTAPI",61,0)
947
"RTN","DGMSTAPI",62,0)
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)
957
"RTN","DGMSTAPI",67,0)
959
"RTN","DGMSTAPI",68,0)
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)
977
"RTN","DGMSTAPI",77,0)
979
"RTN","DGMSTAPI",78,0)
980
; DGRSLT - Returns IEN of file (#29.11) entry if successful
981
"RTN","DGMSTAPI",79,0)
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)
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)
997
"RTN","DGMSTAPI",87,0)
998
N DGFDA,DGMSG,DGERR,DGRSLT,MSTIEN
999
"RTN","DGMSTAPI",88,0)
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)
1007
"RTN","DGMSTAPI",92,0)
1008
S DGSTAT=$S($G(DGSTAT)]"":DGSTAT,1:"U")
1009
"RTN","DGMSTAPI",93,0)
1011
"RTN","DGMSTAPI",94,0)
1013
"RTN","DGMSTAPI",95,0)
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)
1023
"RTN","DGMSTAPI",100,0)
1024
I '$$CHANGE(DFN,DGSTAT,DGDATE) D G NEWQ
1025
"RTN","DGMSTAPI",101,0)
1027
"RTN","DGMSTAPI",102,0)
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)
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)
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)
1057
"RTN","DGMSTAPI",117,0)
1059
"RTN","DGMSTAPI",118,0)
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)
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)
1077
"RTN","DGMSTAPI",127,0)
1079
"RTN","DGMSTAPI",128,0)
1080
. D SEND^DGMSTL1(DFN,"Z07")
1081
"RTN","DGMSTAPI",129,0)
1083
"RTN","DGMSTAPI",130,0)
1085
"RTN","DGMSTAPI",131,0)
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)
1095
"RTN","DGMSTAPI",136,0)
1097
"RTN","DGMSTAPI",137,0)
1098
; MSTIEN - IEN of the entry in the MST HISTORY File (#29.11)
1099
"RTN","DGMSTAPI",138,0)
1101
"RTN","DGMSTAPI",139,0)
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)
1109
"RTN","DGMSTAPI",143,0)
1110
Q:'$G(MSTIEN) "-1^No entry to delete"
1111
"RTN","DGMSTAPI",144,0)
1113
"RTN","DGMSTAPI",145,0)
1115
"RTN","DGMSTAPI",146,0)
1117
"RTN","DGMSTAPI",147,0)
1118
S DIK="^DGMS(29.11,"
1119
"RTN","DGMSTAPI",148,0)
1121
"RTN","DGMSTAPI",149,0)
1123
"RTN","DGMSTAPI",150,0)
1125
"RTN","DGMSTAPI",151,0)
1126
NAME(DA) ; Returns name from the VA NEW PERSON File using DIQ call
1127
"RTN","DGMSTAPI",152,0)
1129
"RTN","DGMSTAPI",153,0)
1130
N DGNAME,DGPROV,DIQ,DR,DIC
1131
"RTN","DGMSTAPI",154,0)
1133
"RTN","DGMSTAPI",155,0)
1134
S DIC=200,DR=".01",DIQ="DGPROV"
1135
"RTN","DGMSTAPI",156,0)
1137
"RTN","DGMSTAPI",157,0)
1138
S DGNAME=$G(DGPROV(200,DA,.01))
1139
"RTN","DGMSTAPI",158,0)
1141
"RTN","DGMSTAPI",159,0)
1143
"RTN","DGMSTAPI",160,0)
1144
CHANGE(DFN,DGSTAT,DGDATE) ;Did the Status OR Date change?
1145
"RTN","DGMSTAPI",161,0)
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)
1155
"RTN","DGMSTAPI",166,0)
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)
1163
"RTN","DGMSTAPI",170,0)
1165
"RTN","DGMSTAPI",171,0)
1167
"RTN","DGMSTAPI",172,0)
1168
I +$G(DFN)'>0!('$D(^DPT(DFN,0))) G CHNGQ
1169
"RTN","DGMSTAPI",173,0)
1171
"RTN","DGMSTAPI",174,0)
1172
I DGSTAT'?1A!("YNDU"'[DGSTAT) G CHNGQ
1173
"RTN","DGMSTAPI",175,0)
1175
"RTN","DGMSTAPI",176,0)
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)
1183
"RTN","DGMSTAPI",180,0)
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)
1193
"RTN","DGMSTAPI",185,0)
1195
"RTN","DGMSTAPI",186,0)
1197
"RTN","DGMSTAPI",187,0)
1198
; DGSITE - Station number (optional)
1199
"RTN","DGMSTAPI",188,0)
1201
"RTN","DGMSTAPI",189,0)
1203
"RTN","DGMSTAPI",190,0)
1204
; Return Site IEN to INSTITUTION file (#4)
1205
"RTN","DGMSTAPI",191,0)
1207
"RTN","DGMSTAPI",192,0)
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)
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)
1221
"RTN","DGMSTAPI",199,0)
1223
"RTN","DGMSTAPI",200,0)
1224
DATE(DFN,DGDT) ;Determine 'current' MST date
1225
"RTN","DGMSTAPI",201,0)
1227
"RTN","DGMSTAPI",202,0)
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)
1235
"RTN","DGMSTAPI",206,0)
1237
"RTN","DGMSTAPI",207,0)
1238
; Return MST effective date
1239
"RTN","DGMSTAPI",208,0)
1241
"RTN","DGMSTAPI",209,0)
1243
"RTN","DGMSTAPI",210,0)
1245
"RTN","DGMSTAPI",211,0)
1247
"RTN","DGMSTAPI",212,0)
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)
1257
"RTN","DGMSTAPI",217,0)
1259
"RTN","DGMSTAPI",218,0)
1260
VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGERR) ;Validate fields before filing
1261
"RTN","DGMSTAPI",219,0)
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)
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)
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)
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)
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)
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)
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)
1333
"RTN","DGMSTAPI",255,0)
1335
"RTN","DGMSTAPI",256,0)
1336
MSG(DGFIL,DGFLD,DGMSG,DGERR) ; error message setup
1337
"RTN","DGMSTAPI",257,0)
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)
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)
1355
"RTN","DGMSTAPI",266,0)
1357
"RTN","DGMSTAPI",267,0)
1358
TESTVAL(DGFIL,DGFLD,DGVAL) ; Determine if a field value is valid.
1359
"RTN","DGMSTAPI",268,0)
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)
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)
1377
"RTN","DGMSTAPI",277,0)
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)
1392
GMRCA2 ;SLC/KCM,DLT,MSC/JDA - Select prompt for processing actions ;27APR2009
1394
;;3.0;CONSULT/REQUEST TRACKING;**1,4,MSC**;DEC 27, 1997
1396
SELECT(GMRCO) ; Select the consult to process
1398
;This utility checks the GMRCO variable against the selection list
1400
; Input variable used:
1406
; Output variables returned:
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)
1415
"RTN","GMRCA2",13,0)
1417
"RTN","GMRCA2",14,0)
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)
1437
"RTN","GMRCA2",24,0)
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)
1443
"RTN","GMRCA2",27,0)
1445
"RTN","GMRCA2",28,0)
1447
"RTN","GMRCA2",29,0)
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)
1469
"RTN","GMRCA2",40,0)
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)
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)
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)
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)
1499
"RTN","HLCSLNCH",8,0)
1500
;Required or Optional INPUT PARAMETERS
1501
"RTN","HLCSLNCH",9,0)
1503
"RTN","HLCSLNCH",10,0)
1505
"RTN","HLCSLNCH",11,0)
1507
"RTN","HLCSLNCH",12,0)
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)
1517
"RTN","HLCSLNCH",17,0)
1519
"RTN","HLCSLNCH",18,0)
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)
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)
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)
1573
"RTN","HLCSLNCH",45,0)
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)
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)
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)
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)
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)
1629
"RTN","HLCSLNCH",73,0)
1631
"RTN","HLCSLNCH",74,0)
1633
"RTN","HLCSLNCH",75,0)
1634
S HLX=$G(^HLCS(870,HLDP,0))
1635
"RTN","HLCSLNCH",76,0)
1637
"RTN","HLCSLNCH",77,0)
1638
I Y="F" S HLTRACE=1 D G STARTQ
1639
"RTN","HLCSLNCH",78,0)
1641
"RTN","HLCSLNCH",79,0)
1643
"RTN","HLCSLNCH",80,0)
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)
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)
1655
"RTN","HLCSLNCH",86,0)
1657
"RTN","HLCSLNCH",87,0)
1659
"RTN","HLCSLNCH",88,0)
1661
"RTN","HLCSLNCH",89,0)
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)
1667
"RTN","HLCSLNCH",92,0)
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)
1689
"RTN","HLCSLNCH",103,0)
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)
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)
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)
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)
1727
"RTN","HLCSLNCH",122,0)
1729
"RTN","HLCSLNCH",123,0)
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)
1737
"RTN","HLCSLNCH",127,0)
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)
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)
1755
"RTN","HLCSTCP",4,0)
1756
; This is an implementation of the HL7 Minimal Lower Layer Protocol
1757
"RTN","HLCSTCP",5,0)
1759
"RTN","HLCSTCP",6,0)
1760
;taskman entry/startup option, HLDP defined in menu entry,
1761
"RTN","HLCSTCP",7,0)
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)
1767
"RTN","HLCSTCP",10,0)
1768
I '$$INIT D EXITS("Init Error") Q
1769
"RTN","HLCSTCP",11,0)
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)
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)
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)
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)
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)
1819
"RTN","HLCSTCP",36,0)
1821
"RTN","HLCSTCP",37,0)
1822
SERVER(HLDP) ; single server using Taskman
1823
"RTN","HLCSTCP",38,0)
1825
"RTN","HLCSTCP",39,0)
1826
I '$$INIT D EXITS("Init error") Q
1827
"RTN","HLCSTCP",40,0)
1829
"RTN","HLCSTCP",41,0)
1830
I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
1831
"RTN","HLCSTCP",42,0)
1833
"RTN","HLCSTCP",43,0)
1835
"RTN","HLCSTCP",44,0)
1837
"RTN","HLCSTCP",45,0)
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)
1845
"RTN","HLCSTCP",49,0)
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)
1857
"RTN","HLCSTCP",55,0)
1859
"RTN","HLCSTCP",56,0)
1861
"RTN","HLCSTCP",57,0)
1862
CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
1863
"RTN","HLCSTCP",58,0)
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)
1877
"RTN","HLCSTCP",65,0)
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)
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)
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)
1911
"RTN","HLCSTCP",82,0)
1913
"RTN","HLCSTCP",83,0)
1914
DCOPEN(HLDP) ;open direct connect - called from HLMA2
1915
"RTN","HLCSTCP",84,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)
1923
"RTN","HLCSTCP",88,0)
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)
1935
"RTN","HLCSTCP",94,0)
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)
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)
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)
1959
"RTN","HLCSTCP",106,0)
1960
S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
1961
"RTN","HLCSTCP",107,0)
1963
"RTN","HLCSTCP",108,0)
1964
S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
1965
"RTN","HLCSTCP",109,0)
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)
1975
"RTN","HLCSTCP",114,0)
1976
S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
1977
"RTN","HLCSTCP",115,0)
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)
1991
"RTN","HLCSTCP",122,0)
1992
S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
1993
"RTN","HLCSTCP",123,0)
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)
2009
"RTN","HLCSTCP",131,0)
2011
"RTN","HLCSTCP",132,0)
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)
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)
2041
"RTN","HLCSTCP",147,0)
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)
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)
2057
"RTN","HLCSTCP",155,0)
2059
"RTN","HLCSTCP",156,0)
2061
"RTN","HLCSTCP",157,0)
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)
2069
"RTN","HLCSTCP",161,0)
2071
"RTN","HLCSTCP",162,0)
2072
UPDT(Y) ;update job count for multiple servers,X=1 increment
2073
"RTN","HLCSTCP",163,0)
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)
2087
"RTN","HLCSTCP",170,0)
2088
STOP() ;stop flag set
2089
"RTN","HLCSTCP",171,0)
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)
2099
"RTN","HLCSTCP",176,0)
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)
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)
2121
"RTN","HLCSTCP",187,0)
2123
"RTN","HLCSTCP",188,0)
2124
SDFLD ; set Shutdown? field to yes
2125
"RTN","HLCSTCP",189,0)
2127
"RTN","HLCSTCP",190,0)
2129
"RTN","HLCSTCP",191,0)
2130
F L +^HLCS(870,HLDP,0):2 Q:$T
2131
"RTN","HLCSTCP",192,0)
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)
2141
"RTN","HLCSTCP",197,0)
2143
"RTN","HLCSTCP",198,0)
2144
EXITS(Y) ; Single service shutdown and cleans up
2145
"RTN","HLCSTCP",199,0)
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)
2165
"RTN","HLCSTCP",209,0)
2167
"RTN","HLCSTCP",210,0)
2168
EXITM ;Multiple service shutdown and clean up
2169
"RTN","HLCSTCP",211,0)
2171
"RTN","HLCSTCP",212,0)
2172
I $D(ZTQUEUED) S ZTREQ="@"
2173
"RTN","HLCSTCP",213,0)
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)
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)
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)
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)
2205
"RTN","HLCSTCP1",15,0)
2207
"RTN","HLCSTCP1",16,0)
2209
"RTN","HLCSTCP1",17,0)
2211
"RTN","HLCSTCP1",18,0)
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)
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)
2233
"RTN","HLCSTCP1",29,0)
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)
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)
2263
"RTN","HLCSTCP1",44,0)
2265
"RTN","HLCSTCP1",45,0)
2266
RDBLK S HLDB=HLDBSIZE-$L(HLX)
2267
"RTN","HLCSTCP1",46,0)
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)
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)
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)
2321
"RTN","HLCSTCP1",73,0)
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)
2331
"RTN","HLCSTCP1",78,0)
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)
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)
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)
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)
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)
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)
2389
"RTN","HLCSTCP1",107,0)
2391
"RTN","HLCSTCP1",108,0)
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)
2399
"RTN","HLCSTCP1",112,0)
2400
S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
2401
"RTN","HLCSTCP1",113,0)
2403
"RTN","HLCSTCP1",114,0)
2405
"RTN","HLCSTCP1",115,0)
2406
DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
2407
"RTN","HLCSTCP1",116,0)
2409
"RTN","HLCSTCP1",117,0)
2410
S DA=+HLMAMT,DIK="^HLMA("
2411
"RTN","HLCSTCP1",118,0)
2413
"RTN","HLCSTCP1",119,0)
2414
S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
2415
"RTN","HLCSTCP1",120,0)
2417
"RTN","HLCSTCP1",121,0)
2419
"RTN","HLCSTCP1",122,0)
2420
MIEN ; sets HLIND1=ien in 773^ien in 772 for message
2421
"RTN","HLCSTCP1",123,0)
2423
"RTN","HLCSTCP1",124,0)
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)
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)
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)
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)
2471
"RTN","HLCSTCP1",148,0)
2472
D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
2473
"RTN","HLCSTCP1",149,0)
2475
"RTN","HLCSTCP1",150,0)
2477
"RTN","HLCSTCP1",151,0)
2478
PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
2479
"RTN","HLCSTCP1",152,0)
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)
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)
2491
"RTN","HLCSTCP1",158,0)
2493
"RTN","HLCSTCP1",159,0)
2495
"RTN","HLCSTCP1",160,0)
2496
PING ;process PING message
2497
"RTN","HLCSTCP1",161,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)
2505
"RTN","HLCSTCP1",165,0)
2507
"RTN","HLCSTCP1",166,0)
2509
"RTN","HLCSTCP1",167,0)
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)
2527
"RTN","HLCSTCP1",176,0)
2529
"RTN","HLCSTCP1",177,0)
2531
"RTN","HLCSTCP1",178,0)
2532
CC(X) ;cleanup and close
2533
"RTN","HLCSTCP1",179,0)
2535
"RTN","HLCSTCP1",180,0)
2537
"RTN","HLCSTCP1",181,0)
2539
"RTN","HLCSTCP1",182,0)
2540
RESET ;reset info as a result of no end block
2541
"RTN","HLCSTCP1",183,0)
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)
2549
"RTN","HLCSTCP1",187,0)
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)
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)
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)
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)
2599
"RTN","HLCSTCP2",24,0)
2601
"RTN","HLCSTCP2",25,0)
2602
. D MON^HLCSTCP("Idle")
2603
"RTN","HLCSTCP2",26,0)
2605
"RTN","HLCSTCP2",27,0)
2606
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
2607
"RTN","HLCSTCP2",28,0)
2609
"RTN","HLCSTCP2",29,0)
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)
2625
"RTN","HLCSTCP2",37,0)
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)
2633
"RTN","HLCSTCP2",41,0)
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)
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)
2673
"RTN","HLCSTCP2",61,0)
2674
. ;quit if action is ignore
2675
"RTN","HLCSTCP2",62,0)
2677
"RTN","HLCSTCP2",63,0)
2678
. ;this will shutdown this link
2679
"RTN","HLCSTCP2",64,0)
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)
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)
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)
2739
"RTN","HLCSTCP2",94,0)
2741
"RTN","HLCSTCP2",95,0)
2743
"RTN","HLCSTCP2",96,0)
2745
"RTN","HLCSTCP2",97,0)
2747
"RTN","HLCSTCP2",98,0)
2748
;do structure is to stack error
2749
"RTN","HLCSTCP2",99,0)
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)
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)
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)
2795
"RTN","HLCSTCP2",122,0)
2797
"RTN","HLCSTCP2",123,0)
2798
... ;response is deferred, set status to awaiting ack
2799
"RTN","HLCSTCP2",124,0)
2801
"RTN","HLCSTCP2",125,0)
2803
"RTN","HLCSTCP2",126,0)
2804
.. ;Error, HLRESLT=error number^error message from HLTP3
2805
"RTN","HLCSTCP2",127,0)
2807
"RTN","HLCSTCP2",128,0)
2808
... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2))
2809
"RTN","HLCSTCP2",129,0)
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)
2819
"RTN","HLCSTCP2",134,0)
2821
"RTN","HLCSTCP2",135,0)
2823
"RTN","HLCSTCP2",136,0)
2824
DCSEND ;direct connect
2825
"RTN","HLCSTCP2",137,0)
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)
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)
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)
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)
2867
"RTN","HLCSTCP2",158,0)
2868
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
2869
"RTN","HLCSTCP2",159,0)
2871
"RTN","HLCSTCP2",160,0)
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)
2881
"RTN","HLCSTCP2",165,0)
2883
"RTN","HLCSTCP2",166,0)
2884
D DEQUE^HLCSREP(HLDP,"O",HLMSG)
2885
"RTN","HLCSTCP2",167,0)
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)
2893
"RTN","HLCSTCP2",171,0)
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)
2903
"RTN","HLCSTCP2",176,0)
2905
"RTN","HLCSTCP2",177,0)
2907
"RTN","HLCSTCP2",178,0)
2908
;F L +^HLMA(HLMSG,"P"):1 Q:$T H 1
2909
"RTN","HLCSTCP2",179,0)
2911
"RTN","HLCSTCP2",180,0)
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)
2923
"RTN","HLCSTCP2",186,0)
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)
2931
"RTN","HLCSTCP2",190,0)
2933
"RTN","HLCSTCP2",191,0)
2934
; End of HL*1.6*77 modifications
2935
"RTN","HLCSTCP2",192,0)
2937
"RTN","HLCSTCP2",193,0)
2938
;get status, quit if msg was cancelled
2939
"RTN","HLCSTCP2",194,0)
2941
"RTN","HLCSTCP2",195,0)
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)
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)
2955
"RTN","HLCSTCP2",202,0)
2957
"RTN","HLCSTCP2",203,0)
2958
;L -^HLMA(HLMSG,"P")
2959
"RTN","HLCSTCP2",204,0)
2961
"RTN","HLCSTCP2",205,0)
2963
"RTN","HLCSTCP2",206,0)
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)
2979
"RTN","HLCSTCP2",214,0)
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)
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)
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)
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)
3021
"RTN","HLCSTCP2",235,0)
3022
.. ;send CR for blank lines
3023
"RTN","HLCSTCP2",236,0)
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)
3031
"RTN","HLCSTCP2",240,0)
3033
"RTN","HLCSTCP2",241,0)
3035
"RTN","HLCSTCP2",242,0)
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)
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)
3053
"RTN","HLCSTCP2",251,0)
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)
3061
"RTN","HLCSTCP2",255,0)
3062
CC(X) ;cleanup and close
3063
"RTN","HLCSTCP2",256,0)
3065
"RTN","HLCSTCP2",257,0)
3066
I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
3067
"RTN","HLCSTCP2",258,0)
3069
"RTN","HLCSTCP2",259,0)
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)
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)
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)
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)
3121
"RTN","HLCSTCP3",25,0)
3122
D CC^HLCSTCP2("Openfail") H 3
3123
"RTN","HLCSTCP3",26,0)
3125
"RTN","HLCSTCP3",27,0)
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)
3133
"RTN","HLCSTCP3",31,0)
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)
3145
"RTN","HLCSTCP3",37,0)
3147
"RTN","HLCSTCP3",38,0)
3148
;D CC("Openfail") H 3
3149
"RTN","HLCSTCP3",39,0)
3151
"RTN","HLCSTCP3",40,0)
3153
"RTN","HLCSTCP3",41,0)
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)
3177
"RTN","HLCSTCP3",53,0)
3179
"RTN","HLCSTCP3",54,0)
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)
3189
"RTN","HLCSTCP4",4,0)
3190
; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
3191
"RTN","HLCSTCP4",5,0)
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)
3199
"RTN","HLCSTCP4",9,0)
3201
"RTN","HLCSTCP4",10,0)
3202
; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
3203
"RTN","HLCSTCP4",11,0)
3205
"RTN","HLCSTCP4",12,0)
3207
"RTN","HLCSTCP4",13,0)
3208
;I $G(HLMSG) L -^HLMA(HLMSG)
3209
"RTN","HLCSTCP4",14,0)
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)
3233
"RTN","HLCSTCP4",26,0)
3235
"RTN","HLCSTCP4",27,0)
3240
HLZTCP ;MILW/JMC MSC/JKT - HL7 TCP/IP Hybrid Lower Level Protocol Receiver/Sender ;28OCT2009
3242
;;1.5;HEALTH LEVEL SEVEN;**MSC**;JUL 09, 1993
3246
INIT ;Initialize Variables
3248
N HLZIO,HLZOS,HLZSTATE
3250
S HLZOS=$G(^%ZOSF("OS"))
3254
I $D(ZTQUEUED) S ZTREQ="@"
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)
3263
"RTN","HLZTCP",13,0)
3264
I '$D(HLION) D Q:POP
3265
"RTN","HLZTCP",14,0)
3267
"RTN","HLZTCP",15,0)
3269
"RTN","HLZTCP",16,0)
3270
. S HLION=$S(ION']"":"UNKNOWN",1:ION)
3271
"RTN","HLZTCP",17,0)
3273
"RTN","HLZTCP",18,0)
3275
"RTN","HLZTCP",19,0)
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)
3283
"RTN","HLZTCP",23,0)
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)
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)
3305
"RTN","HLZTCP",34,0)
3306
S IOP="NULL DEVICE" D ^%ZIS
3307
"RTN","HLZTCP",35,0)
3309
"RTN","HLZTCP",36,0)
3311
"RTN","HLZTCP",37,0)
3313
"RTN","HLZTCP",38,0)
3314
S HLTIME=$$NOW^XLFDT
3315
"RTN","HLZTCP",39,0)
3317
"RTN","HLZTCP",40,0)
3319
"RTN","HLZTCP",41,0)
3320
; If TCP client, send a "space" to initiate connection.
3321
"RTN","HLZTCP",42,0)
3323
"RTN","HLZTCP",43,0)
3325
"RTN","HLZTCP",44,0)
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)
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)
3343
"RTN","HLZTCP",53,0)
3345
"RTN","HLZTCP",54,0)
3347
"RTN","HLZTCP",55,0)
3349
"RTN","HLZTCP",56,0)
3350
; Reset current device to "NULL DEVICE".
3351
"RTN","HLZTCP",57,0)
3353
"RTN","HLZTCP",58,0)
3355
"RTN","HLZTCP",59,0)
3356
I $$EC^%ZOSV["WRITE"!($$EC^%ZOSV["READ") D
3357
"RTN","HLZTCP",60,0)
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)
3367
"RTN","HLZTCP",65,0)
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)
3375
"RTN","HLZTCP",69,0)
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)
3387
"RTN","HLZTCP",75,0)
3389
"RTN","HLZTCP",76,0)
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)
3397
"RTN","HLZTCP",80,0)
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)
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)
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)
3435
"RTN","HLZTCP",99,0)
3436
I HLTRIED'=HLTRIES G CS1:$D(HLDTOUT) G CS1:HLZNAK
3437
"RTN","HLZTCP",100,0)
3439
"RTN","HLZTCP",101,0)
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)
3453
"RTN","HLZTCP",108,0)
3455
"RTN","HLZTCP",109,0)
3456
D CHK^HLCHK,IN^HLTF(HLMTN,HLMID,HLTIME)
3457
"RTN","HLZTCP",110,0)
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)
3465
"RTN","HLZTCP",114,0)
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)
3473
"RTN","HLZTCP",118,0)
3475
"RTN","HLZTCP",119,0)
3476
REC ;Receive a Message
3477
"RTN","HLZTCP",120,0)
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)
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)
3497
"RTN","HLZTCP",130,0)
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)
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)
3521
"RTN","HLZTCP",142,0)
3522
I HLZEB,HLZNAK D RECNAK Q
3523
"RTN","HLZTCP",143,0)
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)
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)
3545
"RTN","HLZTCP",154,0)
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)
3553
"RTN","HLZTCP",158,0)
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)
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)
3573
"RTN","HLZTCP",168,0)
3575
"RTN","HLZTCP",169,0)
3576
SEND ;Send a Message
3577
"RTN","HLZTCP",170,0)
3579
"RTN","HLZTCP",171,0)
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)
3597
"RTN","HLZTCP",180,0)
3599
"RTN","HLZTCP",181,0)
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)
3609
"RTN","HLZTCP",186,0)
3611
"RTN","HLZTCP",187,0)
3613
"RTN","HLZTCP",188,0)
3615
"RTN","HLZTCP",189,0)
3616
WRITE(X) ; Write data in buffer.
3617
"RTN","HLZTCP",190,0)
3619
"RTN","HLZTCP",191,0)
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)
3625
"RTN","HLZTCP",194,0)
3627
"RTN","HLZTCP",195,0)
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)
3635
"RTN","HLZTCP",199,0)
3636
; Do final write for this block and flush buffer.
3637
"RTN","HLZTCP",200,0)
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)
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)
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)
3679
"RTN","MAGDMEDL",18,0)
3681
"RTN","MAGDMEDL",19,0)
3682
SELECT(ITEM,ARRAY) ;
3683
"RTN","MAGDMEDL",20,0)
3685
"RTN","MAGDMEDL",21,0)
3687
"RTN","MAGDMEDL",22,0)
3688
N CNT,DIR,DIROUT,DIRUT,ENTRY
3689
"RTN","MAGDMEDL",23,0)
3691
"RTN","MAGDMEDL",24,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)
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)
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)
3727
"RTN","MAGDMEDL",42,0)
3728
S ARRAY(0)="0^^No entries found"
3729
"RTN","MAGDMEDL",43,0)
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)
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)
3777
"RTN","MAGDMEDL",67,0)
3778
. . . S DICOM=$P(DICOM,":",2)
3779
"RTN","MAGDMEDL",68,0)
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)
3789
"RTN","MAGDMEDL",73,0)
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)
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)
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)
3825
"RTN","MAGDMEDL",91,0)
3826
I 'OUT D ASKQ S RES=ITEM
3827
"RTN","MAGDMEDL",92,0)
3829
"RTN","MAGDMEDL",93,0)
3831
"RTN","MAGDMEDL",94,0)
3832
W:$Y+3>IOSL @IOF W !,MSG
3833
"RTN","MAGDMEDL",95,0)
3835
"RTN","MAGDMEDL",96,0)
3837
"RTN","MAGDMEDL",97,0)
3838
W !,ENTRY,".) "_OUTPUT
3839
"RTN","MAGDMEDL",98,0)
3841
"RTN","MAGDMEDL",99,0)
3843
"RTN","MAGDMEDL",100,0)
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)
3851
"RTN","MAGDMEDL",104,0)
3852
Q:$D(DIRUT)!($D(DIROUT))
3853
"RTN","MAGDMEDL",105,0)
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)
3861
"RTN","MAGDMEDL",109,0)
3863
"RTN","MAGDMEDL",110,0)
3865
"RTN","MAGDMEDL",111,0)
3867
"RTN","MAGDMEDL",112,0)
3869
"RTN","MAGDMEDL",113,0)
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)
3877
"RTN","MAGDMEDL",117,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)
3887
"RTN","MAGDMEDL",122,0)
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)
3899
"RTN","MSCGUX53",1,0)
3900
MSCGUX53 ;MSC/JDS - ENVIRONMENT CHECK ; ; 29 Apr 2009 1:47 PM
3901
"RTN","MSCGUX53",2,0)
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)
3909
"RTN","MSCGUX53",6,0)
3911
"RTN","MSCGUX53",7,0)
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)
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)
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)
3951
"RTN","MSCXUS3A",19,0)
3952
. D NEWZGZRO^ZCD(Y(0))
3953
"RTN","MSCXUS3A",20,0)
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)
3965
"RTN","MSCXUS3A",26,0)
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)
3973
"RTN","MSCXUS3A",30,0)
3975
"RTN","MSCXUS3A",31,0)
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)
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)
3991
"RTN","MSCXUS3A",39,0)
3993
"RTN","MSCXUS3A",40,0)
3995
"RTN","MSCXUS3A",41,0)
3997
"RTN","MSCXUS3A",42,0)
3998
PM I X="PROD"!(X="MGR") S X=^%ZOSF(X)
3999
"RTN","MSCXUS3A",43,0)
4001
"RTN","MSCXUS3A",44,0)
4003
"RTN","MSCXUS3A",45,0)
4005
"RTN","MSCXUS3A",46,0)
4007
"RTN","MSCXUS3A",47,0)
4008
NSP(USERNAME) ;LIST OTHER NAMESPACES WHERE THIS USER IS
4009
"RTN","MSCXUS3A",48,0)
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)
4025
"RTN","MSCXUS3A",56,0)
4027
"RTN","MSCXUS3A",57,0)
4028
N CURRENT S CURRENT=Y N Y
4029
"RTN","MSCXUS3A",58,0)
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)
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)
4053
"RTN","MSCZJOB",5,0)
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)
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)
4069
"RTN","MSCZJOB",13,0)
4070
D UNLOCK^MSCZJOBU(R,N)
4071
"RTN","MSCZJOB",14,0)
4073
"RTN","MSCZJOB",15,0)
4075
"RTN","MSCZJOB",16,0)
4077
"RTN","MSCZJOB",17,0)
4079
"RTN","MSCZJOB",18,0)
4081
"RTN","MSCZJOB",19,0)
4083
"RTN","MSCZJOB",20,0)
4084
COMPMUL ;COMPUTED MULTIPLE FOR MSCZJOBEXAM BLOCK
4085
"RTN","MSCZJOB",21,0)
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)
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)
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)
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)
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)
4125
"RTN","MSCZJOB",41,0)
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)
4135
"RTN","MSCZJOB",46,0)
4136
F D0=1:1:$O(@MSC@(J,"S",""),-1) S X="" X DICMX
4137
"RTN","MSCZJOB",47,0)
4139
"RTN","MSCZJOB",48,0)
4141
"RTN","MSCZJOB",49,0)
4142
STACK(D0) N X S X=$G(@MSC@(MSCJOBID,"S",D0))
4143
"RTN","MSCZJOB",50,0)
4145
"RTN","MSCZJOB",51,0)
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)
4155
"RTN","MSCZJOB",56,0)
4156
F D0=1:1:$O(@MSC@(J,"V",""),-1) S X="" X DICMX
4157
"RTN","MSCZJOB",57,0)
4159
"RTN","MSCZJOB",58,0)
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)
4169
"RTN","MSCZJOB",63,0)
4170
F D0=1:1:$$LOCKS S X="" X DICMX
4171
"RTN","MSCZJOB",64,0)
4173
"RTN","MSCZJOB",65,0)
4175
"RTN","MSCZJOB",66,0)
4176
LOCKS() Q +$O(@MSC@(MSCJOBID,"L",""),-1)
4177
"RTN","MSCZJOB",67,0)
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)
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)
4195
"RTN","MSCZJOB",76,0)
4197
"RTN","MSCZJOB",77,0)
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)
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)
4211
"RTN","MSCZJOB",84,0)
4213
"RTN","MSCZJOB",85,0)
4215
"RTN","MSCZJOB",86,0)
4217
"RTN","MSCZJOB",87,0)
4218
COMPLK ;COMPUTED MULTIPLE FOR MSCZLOCK BLOCK
4219
"RTN","MSCZJOB",88,0)
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)
4233
"RTN","MSCZJOB",95,0)
4235
"RTN","MSCZJOB",96,0)
4236
S DDSFILE=3.081,DR="[MSCZLOCK]",DDSPARM="S"
4237
"RTN","MSCZJOB",97,0)
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)
4247
"RTN","MSCZJOB",102,0)
4248
D UNLOCK^MSCZJOBU(R,N)
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)
4257
"RTN","MSCZJOBS",4,0)
4259
"RTN","MSCZJOBS",5,0)
4261
"RTN","MSCZJOBS",6,0)
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)
4271
"RTN","MSCZJOBS",11,0)
4272
Q:$G(^%ZOSF("OS"))'["GT.M"
4273
"RTN","MSCZJOBS",12,0)
4275
"RTN","MSCZJOBS",13,0)
4276
D INTRPT^MSCZJOBU("*") H .5
4277
"RTN","MSCZJOBS",14,0)
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)
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)
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)
4301
"RTN","MSCZJOBS",26,0)
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)
4311
"RTN","MSCZJOBS",31,0)
4312
. W ?66,$$IDENT(PID)
4313
"RTN","MSCZJOBS",32,0)
4315
"RTN","MSCZJOBS",33,0)
4317
"RTN","MSCZJOBS",34,0)
4319
"RTN","MSCZJOBS",35,0)
4321
"RTN","MSCZJOBS",36,0)
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)
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)
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)
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)
4353
"RTN","MSCZJOBS",52,0)
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)
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)
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)
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)
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)
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)
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)
4401
"RTN","MSCZJOBU",4,0)
4402
; JOB EXAM UTILITIES FOR GT.M
4403
"RTN","MSCZJOBU",5,0)
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)
4415
"RTN","MSCZJOBU",11,0)
4417
"RTN","MSCZJOBU",12,0)
4419
"RTN","MSCZJOBU",13,0)
4420
OPEN DEV:(COMM="ps -o pid=,pcpu=,user= -C mumps":READONLY)::"PIPE"
4421
"RTN","MSCZJOBU",14,0)
4423
"RTN","MSCZJOBU",15,0)
4425
"RTN","MSCZJOBU",16,0)
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)
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)
4445
"RTN","MSCZJOBU",26,0)
4447
"RTN","MSCZJOBU",27,0)
4449
"RTN","MSCZJOBU",28,0)
4451
"RTN","MSCZJOBU",29,0)
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)
4459
"RTN","MSCZJOBU",33,0)
4460
; get a list of all OpenVista instances and look up their $ZG values
4461
"RTN","MSCZJOBU",34,0)
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)
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)
4479
"RTN","MSCZJOBU",43,0)
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)
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)
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)
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)
4523
"RTN","MSCZJOBU",65,0)
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)
4537
"RTN","MSCZJOBU",72,0)
4538
Q:$G(PID)'?1N.N&($G(PID)'="*")
4539
"RTN","MSCZJOBU",73,0)
4541
"RTN","MSCZJOBU",74,0)
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)
4551
"RTN","MSCZJOBU",79,0)
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)
4561
"RTN","MSCZJOBU",84,0)
4563
"RTN","MSCZJOBU",85,0)
4565
"RTN","MSCZJOBU",86,0)
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)
4573
"RTN","MSCZJOBU",90,0)
4575
"RTN","MSCZJOBU",91,0)
4576
UNLOCK(NODE,INSTANCE) ; Use lke to remove lock on NODE.
4577
"RTN","MSCZJOBU",92,0)
4579
"RTN","MSCZJOBU",93,0)
4580
D:$G(INSTANCE)'="" NEWZGZRO^ZCD(INSTANCE)
4581
"RTN","MSCZJOBU",94,0)
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)
4589
"RTN","MSCZJOBU",98,0)
4590
OPEN DEV:(SHELL="/bin/sh":COMM=CMD:READONLY)::"PIPE" U DEV C DEV
4591
"RTN","MSCZJOBU",99,0)
4596
PRCSEA ;WISC/SAW/DXH/BM/SC/DAP,MSC/JDA - CONTROL POINT ACTIVITY EDITS ;27APR2009
4598
V ;;5.1;IFCAP;**81,MSC**;Oct 20, 2000
4600
;Per VHA Directive 10-93-142, this routine should not be modified.
4604
;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code
4606
;to update Audit file (#414.02), and send update message to
4608
;DynaMed thru a call to rtn PRCVTCA.
4613
"RTN","PRCSEA",10,0)
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)
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)
4639
"RTN","PRCSEA",23,0)
4641
"RTN","PRCSEA",24,0)
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)
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)
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)
4669
"RTN","PRCSEA",38,0)
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)
4679
"RTN","PRCSEA",43,0)
4681
"RTN","PRCSEA",44,0)
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)
4699
"RTN","PRCSEA",53,0)
4701
"RTN","PRCSEA",54,0)
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)
4713
"RTN","PRCSEA",60,0)
4714
S T="enter" D W5 G EXIT:%'=1
4715
"RTN","PRCSEA",61,0)
4717
"RTN","PRCSEA",62,0)
4719
"RTN","PRCSEA",63,0)
4721
"RTN","PRCSEA",64,0)
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)
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)
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)
4763
"RTN","PRCSEA",85,0)
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)
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)
4781
"RTN","PRCSEA",94,0)
4783
"RTN","PRCSEA",95,0)
4785
"RTN","PRCSEA",96,0)
4786
I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT
4787
"RTN","PRCSEA",97,0)
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)
4795
"RTN","PRCSEA",101,0)
4796
S T="edit" D W5 G EXIT:%'=1
4797
"RTN","PRCSEA",102,0)
4799
"RTN","PRCSEA",103,0)
4801
"RTN","PRCSEA",104,0)
4803
"RTN","PRCSEA",105,0)
4804
CT ;CANCEL A (PERMANENT) TRANS
4805
"RTN","PRCSEA",106,0)
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)
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)
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)
4843
"RTN","PRCSEA",125,0)
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)
4849
"RTN","PRCSEA",128,0)
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)
4857
"RTN","PRCSEA",132,0)
4859
"RTN","PRCSEA",133,0)
4860
DT ;DELETE A (TEMPORARY) TRANS
4861
"RTN","PRCSEA",134,0)
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)
4873
"RTN","PRCSEA",140,0)
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)
4887
"RTN","PRCSEA",147,0)
4889
"RTN","PRCSEA",148,0)
4891
"RTN","PRCSEA",149,0)
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)
4901
"RTN","PRCSEA",154,0)
4903
"RTN","PRCSEA",155,0)
4904
S T="delete" D W4 G EXIT:%'=1
4905
"RTN","PRCSEA",156,0)
4907
"RTN","PRCSEA",157,0)
4909
"RTN","PRCSEA",158,0)
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)
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)
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)
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)
4935
"RTN","PRCSEA",171,0)
4937
"RTN","PRCSEA",172,0)
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)
4945
"RTN","PRCSEA",176,0)
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)
4955
"RTN","PRCSEA",181,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)
4963
"RTN","PRCSEA",185,0)
4965
"RTN","PRCSEA",186,0)
4966
S DIK="^PRCS(410,",DA=TRNDA
4967
"RTN","PRCSEA",187,0)
4969
"RTN","PRCSEA",188,0)
4971
"RTN","PRCSEA",189,0)
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)
4991
"RTN","PRCSEA",199,0)
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)
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)
5007
"RTN","PSBOMH1",4,0)
5009
"RTN","PSBOMH1",5,0)
5011
"RTN","PSBOMH1",6,0)
5013
"RTN","PSBOMH1",7,0)
5015
"RTN","PSBOMH1",8,0)
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)
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)
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)
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)
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)
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)
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)
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)
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)
5217
"RTN","PSBOMH1",109,0)
5219
"RTN","PSBOMH1",110,0)
5220
DDAUD ; audits for dispen drugs
5221
"RTN","PSBOMH1",111,0)
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)
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)
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)
5259
"RTN","PSBOMH1",130,0)
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)
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)
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)
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)
5295
"RTN","PSBOMH1",148,0)
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)
5305
"RTN","PSBRPC2",4,0)
5307
"RTN","PSBRPC2",5,0)
5309
"RTN","PSBRPC2",6,0)
5311
"RTN","PSBRPC2",7,0)
5313
"RTN","PSBRPC2",8,0)
5315
"RTN","PSBRPC2",9,0)
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)
5405
"RTN","PSBRPC2",54,0)
5407
"RTN","PSBRPC2",55,0)
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)
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)
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)
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)
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)
5463
"RTN","PSBRPC2",83,0)
5465
"RTN","PSBRPC2",84,0)
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)
5473
"RTN","PSBRPC2",88,0)
5475
"RTN","PSBRPC2",89,0)
5477
"RTN","PSBRPC2",90,0)
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)
5485
"RTN","PSBRPC2",94,0)
5486
D NOW^%DTC S PSBDT=%
5487
"RTN","PSBRPC2",95,0)
5489
"RTN","PSBRPC2",96,0)
5490
I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
5491
"RTN","PSBRPC2",97,0)
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)
5503
"RTN","PSBRPC2",103,0)
5504
.E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
5505
"RTN","PSBRPC2",104,0)
5507
"RTN","PSBRPC2",105,0)
5508
; IV/IVPB ward stock scan
5509
"RTN","PSBRPC2",106,0)
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)
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)
5533
"RTN","PSBRPC2",118,0)
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)
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)
5555
"RTN","PXRMTMED",10,0)
5556
S DIC("A")="Select Reminder Term: "
5557
"RTN","PXRMTMED",11,0)
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)
5565
"RTN","PXRMTMED",15,0)
5567
"RTN","PXRMTMED",16,0)
5568
I ($D(DTOUT))!($D(DUOUT)) Q
5569
"RTN","PXRMTMED",17,0)
5571
"RTN","PXRMTMED",18,0)
5573
"RTN","PXRMTMED",19,0)
5574
S CS1=$$FILE^PXRMEXCS(811.5,DA)
5575
"RTN","PXRMTMED",20,0)
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)
5583
"RTN","PXRMTMED",24,0)
5584
I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
5585
"RTN","PXRMTMED",25,0)
5587
"RTN","PXRMTMED",26,0)
5589
"RTN","PXRMTMED",27,0)
5591
"RTN","PXRMTMED",28,0)
5593
"RTN","PXRMTMED",29,0)
5594
;=======================================================
5595
"RTN","PXRMTMED",30,0)
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)
5607
"RTN","PXRMTMED",36,0)
5608
I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D
5609
"RTN","PXRMTMED",37,0)
5611
"RTN","PXRMTMED",38,0)
5613
"RTN","PXRMTMED",39,0)
5614
. I $G(DA)'="" D CLASS(DA,DIE)
5615
"RTN","PXRMTMED",40,0)
5617
"RTN","PXRMTMED",41,0)
5619
"RTN","PXRMTMED",42,0)
5620
F D FINDING(DIE,DA) Q:TCONT=0
5621
"RTN","PXRMTMED",43,0)
5623
"RTN","PXRMTMED",44,0)
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)
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)
5645
"RTN","PXRMTMED",55,0)
5647
"RTN","PXRMTMED",56,0)
5648
S DIC=DIE_DA(1)_",20,"
5649
"RTN","PXRMTMED",57,0)
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)
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)
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)
5679
"RTN","PXRMTMED",72,0)
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)
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)
5703
"RTN","PXRMTMED",84,0)
5705
"RTN","PXRMTMED",85,0)
5706
;Edit finding record
5707
"RTN","PXRMTMED",86,0)
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)
5715
"RTN","PXRMTMED",90,0)
5717
"RTN","PXRMTMED",91,0)
5718
;=======================================================
5719
"RTN","PXRMTMED",92,0)
5721
"RTN","PXRMTMED",93,0)
5723
"RTN","PXRMTMED",94,0)
5725
"RTN","PXRMTMED",95,0)
5726
S DR="100" D ^DIE I $D(Y) Q
5727
"RTN","PXRMTMED",96,0)
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)
5737
"RTN","PXRMTMED",101,0)
5738
S DR="102;1" D ^DIE I $D(Y) Q
5739
"RTN","PXRMTMED",102,0)
5741
"RTN","PXRMTMED",103,0)
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)
5751
"RTN","RORHL7A",4,0)
5753
"RTN","RORHL7A",5,0)
5755
"RTN","RORHL7A",6,0)
5756
;***** ADDS THE SEGMENT TO THE HL7 MESSAGE BUFFER
5757
"RTN","RORHL7A",7,0)
5759
"RTN","RORHL7A",8,0)
5760
; SEG Complete HL7 segment
5761
"RTN","RORHL7A",9,0)
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)
5775
"RTN","RORHL7A",16,0)
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)
5785
"RTN","RORHL7A",21,0)
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)
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)
5821
"RTN","RORHL7A",39,0)
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)
5833
"RTN","RORHL7A",45,0)
5835
"RTN","RORHL7A",46,0)
5836
;***** ASSEMBLES THE SEGMENT AND ADDS IT TO THE HL7 MESSAGE BUFFER
5837
"RTN","RORHL7A",47,0)
5839
"RTN","RORHL7A",48,0)
5840
; .FIELDS Reference to a local variable where the HL7
5841
"RTN","RORHL7A",49,0)
5843
"RTN","RORHL7A",50,0)
5845
"RTN","RORHL7A",51,0)
5847
"RTN","RORHL7A",52,0)
5849
"RTN","RORHL7A",53,0)
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)
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)
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)
5879
"RTN","RORHL7A",68,0)
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)
5895
"RTN","RORHL7A",76,0)
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)
5911
"RTN","RORHL7A",84,0)
5912
;--- Remove empty trailing fields
5913
"RTN","RORHL7A",85,0)
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)
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)
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)
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)
5953
"RTN","RORHL7A",105,0)
5955
"RTN","RORHL7A",106,0)
5956
;***** APPENDS THE FIELD VALUE TO THE HL7 SEGMENT
5957
"RTN","RORHL7A",107,0)
5959
"RTN","RORHL7A",108,0)
5960
; VAL Value of the field (or its part)
5961
"RTN","RORHL7A",109,0)
5963
"RTN","RORHL7A",110,0)
5964
; This is an internal function. Do not call it directly.
5965
"RTN","RORHL7A",111,0)
5967
"RTN","RORHL7A",112,0)
5969
"RTN","RORHL7A",113,0)
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)
5979
"RTN","RORHL7A",118,0)
5980
S RORBUF=RORBUF_$E(VAL,1,RORSL),L=L-RORSL
5981
"RTN","RORHL7A",119,0)
5983
"RTN","RORHL7A",120,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)
5995
"RTN","RORHL7A",126,0)
5997
"RTN","RORHL7A",127,0)
5999
"RTN","RORHL7A",128,0)
6000
;***** RETURNS THE BHS SEGMENT
6001
"RTN","RORHL7A",129,0)
6003
"RTN","RORHL7A",130,0)
6004
; BID Batch message ID
6005
"RTN","RORHL7A",131,0)
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)
6013
"RTN","RORHL7A",135,0)
6014
; [COMMENT] Optional comment
6015
"RTN","RORHL7A",136,0)
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)
6023
"RTN","RORHL7A",140,0)
6024
BHS(BID,BDT,COMMENT) ;
6025
"RTN","RORHL7A",141,0)
6027
"RTN","RORHL7A",142,0)
6028
D BHS^HLFNC3(.RORHL,BID,.SEG)
6029
"RTN","RORHL7A",143,0)
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)
6057
"RTN","RORHL7A",157,0)
6059
"RTN","RORHL7A",158,0)
6060
;***** RETURNS BTS SEGMENT
6061
"RTN","RORHL7A",159,0)
6063
"RTN","RORHL7A",160,0)
6064
; MSGCNT Batch message count
6065
"RTN","RORHL7A",161,0)
6066
; [COMMENT] Batch comment
6067
"RTN","RORHL7A",162,0)
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)
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)
6081
"RTN","RORHL7A",169,0)
6082
;***** LOADS THE HL7 FIELD (OR ITS PART) TO THE BUFFER
6083
"RTN","RORHL7A",170,0)
6085
"RTN","RORHL7A",171,0)
6086
; VAL Value of the field (or its part)
6087
"RTN","RORHL7A",172,0)
6089
"RTN","RORHL7A",173,0)
6090
; FLD Number of the field in the segment (piece number)
6091
"RTN","RORHL7A",174,0)
6093
"RTN","RORHL7A",175,0)
6095
"RTN","RORHL7A",176,0)
6097
"RTN","RORHL7A",177,0)
6098
S:FLD>RORFLD RORFLD=FLD,RORIS=0,RORSL=245
6099
"RTN","RORHL7A",178,0)
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)
6111
"RTN","RORHL7A",184,0)
6113
"RTN","RORHL7A",185,0)
6115
"RTN","RORHL7A",186,0)
6116
;***** LOADS THE HL7 SEGMENT INTO THE RPOVIDED BUFFER
6117
"RTN","RORHL7A",187,0)
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)
6127
"RTN","RORHL7A",192,0)
6128
; RORSEG(FldNum)=FldVal
6129
"RTN","RORHL7A",193,0)
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)
6137
"RTN","RORHL7A",197,0)
6138
; RORSEG(FldNum,#)=FldValCont
6139
"RTN","RORHL7A",198,0)
6141
"RTN","RORHL7A",199,0)
6142
; ROR8SRC Closed root of the source buffer containing
6143
"RTN","RORHL7A",200,0)
6145
"RTN","RORHL7A",201,0)
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)
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)
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)
6177
"RTN","RORHL7A",217,0)
6179
"RTN","RORHL7A",218,0)
6180
;***** RETURNS TEXT EXPLANATIONS OF THE HL7 MESSAGE STATUS
6181
"RTN","RORHL7A",219,0)
6183
"RTN","RORHL7A",220,0)
6184
; MSGST Status value returned by the $$MSGSTAT^HLUTIL
6185
"RTN","RORHL7A",221,0)
6187
"RTN","RORHL7A",222,0)
6189
"RTN","RORHL7A",223,0)
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)
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)
6211
"RTN","RORHL7A",234,0)
6213
"RTN","RORHL7A",235,0)
6214
;***** ASSIGNS THE 'SET ID'
6215
"RTN","RORHL7A",236,0)
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)
6223
"RTN","RORHL7A",240,0)
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)
6231
"RTN","RORHL7A",244,0)
6232
SETID(SEGNAME,DISINC) ;
6233
"RTN","RORHL7A",245,0)
6235
"RTN","RORHL7A",246,0)
6237
"RTN","RORHL7A",247,0)
6238
S SETID=+$G(ROREXT("HL7SID",SEGNAME))
6239
"RTN","RORHL7A",248,0)
6241
"RTN","RORHL7A",249,0)
6242
S:'$G(DISINC) ROREXT("HL7SID",SEGNAME)=SETID+1
6243
"RTN","RORHL7A",250,0)
6248
VALMW3 ; ALB/MJK,MSC/JDA - Create transport routines for LM;27APR2009
6250
;;1;List Manager;**MSC**;Aug 13, 1993
6254
EN ; -- exporter main entry point
6256
N VALMSYS,VALMNS,VALMROU,VALMAX
6258
S U="^",DTIME=600 K ^UTILITY($J)
6262
W @IOF,!?20,"*** List Template Export Utility ***"
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)
6279
"RTN","VALMW3",17,0)
6281
"RTN","VALMW3",18,0)
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)
6291
"RTN","VALMW3",23,0)
6293
"RTN","VALMW3",24,0)
6295
"RTN","VALMW3",25,0)
6297
"RTN","VALMW3",26,0)
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)
6305
"RTN","VALMW3",30,0)
6307
"RTN","VALMW3",31,0)
6309
"RTN","VALMW3",32,0)
6310
NS() ; -- ask for namespace
6311
"RTN","VALMW3",33,0)
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)
6327
"RTN","VALMW3",41,0)
6329
"RTN","VALMW3",42,0)
6330
ROU(VALMNS) ; -- ask for export routine name
6331
"RTN","VALMW3",43,0)
6333
"RTN","VALMW3",44,0)
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)
6353
"RTN","VALMW3",54,0)
6355
"RTN","VALMW3",55,0)
6356
MAX() ; -- ask for max size of routines
6357
"RTN","VALMW3",56,0)
6359
"RTN","VALMW3",57,0)
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)
6367
"RTN","VALMW3",61,0)
6369
"RTN","VALMW3",62,0)
6370
I Y\1'=Y!(Y<2000)!(Y>9999) D MAX^VALMW5 G MAX1
6371
"RTN","VALMW3",63,0)
6373
"RTN","VALMW3",64,0)
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)
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)
6389
"RTN","VALMW3",72,0)
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)
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)
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)
6423
"RTN","VALMW3",89,0)
6424
D SET(" K DIC,DIK,VALM,X,DA Q")
6425
"RTN","VALMW3",90,0)
6427
"RTN","VALMW3",91,0)
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)
6435
"RTN","VALMW3",95,0)
6437
"RTN","VALMW3",96,0)
6438
QUOTE(X) ; -- add double quotes
6439
"RTN","VALMW3",97,0)
6441
"RTN","VALMW3",98,0)
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)
6447
"RTN","VALMW3",101,0)
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)
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)
6463
"RTN","VALMW3",109,0)
6465
"RTN","VALMW3",110,0)
6466
SAVE(VALMROU,VALMNUM,VALMLN,VALMDATE) ; -- save to routine
6467
"RTN","VALMW3",111,0)
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)
6479
"RTN","VALMW3",117,0)
6484
XOBVLL ;; mjk/alb MSC/JDA - VistALink Listen and Spawn Code ;13APR2009
6486
;;1.5;VistALink;**MSC**;Sep 09, 2005
6488
;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
6496
; ***deprecated*** tag ; Use START^XOBVTCP instead
6498
START(SOCKET) ; -- start listener
6500
DO START^XOBVTCP(SOCKET)
6501
"RTN","XOBVLL",10,0)
6503
"RTN","XOBVLL",11,0)
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)
6513
"RTN","XOBVLL",16,0)
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)
6521
"RTN","XOBVLL",20,0)
6523
"RTN","XOBVLL",21,0)
6525
"RTN","XOBVLL",22,0)
6527
"RTN","XOBVLL",23,0)
6529
"RTN","XOBVLL",24,0)
6530
; -- initialize timestamp for last time request made (used for debugging)
6531
"RTN","XOBVLL",25,0)
6533
"RTN","XOBVLL",26,0)
6535
"RTN","XOBVLL",27,0)
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)
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)
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)
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)
6565
"RTN","XOBVLL",42,0)
6566
; -- initialize tcp processing variables
6567
"RTN","XOBVLL",43,0)
6569
"RTN","XOBVLL",44,0)
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)
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)
6583
"RTN","XOBVLL",51,0)
6584
; -- final/clean tcp processing variables
6585
"RTN","XOBVLL",52,0)
6587
"RTN","XOBVLL",53,0)
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)
6595
"RTN","XOBVLL",57,0)
6597
"RTN","XOBVLL",58,0)
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)
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)
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)
6619
"RTN","XOBVLL",69,0)
6620
; -- initialize 'current' request handler to empty string
6621
"RTN","XOBVLL",70,0)
6623
"RTN","XOBVLL",71,0)
6625
"RTN","XOBVLL",72,0)
6626
; -- # of chars to get on first read / read 11 for Broker initial read
6627
"RTN","XOBVLL",73,0)
6629
"RTN","XOBVLL",74,0)
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)
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)
6643
"RTN","XOBVLL",81,0)
6644
; -- set first read flag
6645
"RTN","XOBVLL",82,0)
6647
"RTN","XOBVLL",83,0)
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)
6655
"RTN","XOBVLL",87,0)
6657
"RTN","XOBVLL",88,0)
6658
; -- read from socket port
6659
"RTN","XOBVLL",89,0)
6661
"RTN","XOBVLL",90,0)
6662
SET XOBOK=$$READ^XOBVSKT(XOBROOT,.XOBREAD,.XOBTO,.XOBFIRST,.XOBSTOP,.XOBDATA,.XOBHDLR)
6663
"RTN","XOBVLL",91,0)
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)
6673
"RTN","XOBVLL",96,0)
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)
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)
6693
"RTN","XOBVLL",106,0)
6695
"RTN","XOBVLL",107,0)
6697
"RTN","XOBVLL",108,0)
6699
"RTN","XOBVLL",109,0)
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)
6715
"RTN","XOBVLL",117,0)
6716
DO ERROR(181001,$$EZBLD^DIALOG(181001,$$EC^%ZOSV),XOBPORT) ; -- Get the error code
6717
"RTN","XOBVLL",118,0)
6719
"RTN","XOBVLL",119,0)
6721
"RTN","XOBVLL",120,0)
6722
ERROR(XOBEC,XOBMSG,XOBPORT) ; -- send error message
6723
"RTN","XOBVLL",121,0)
6725
"RTN","XOBVLL",122,0)
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)
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)
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)
6755
"RTN","XOBVLL",137,0)
6756
. IF $GET(DUZ) DO CLEAN^XOBSCAV1
6757
"RTN","XOBVLL",138,0)
6759
"RTN","XOBVLL",139,0)
6760
; -- send error back to client
6761
"RTN","XOBVLL",140,0)
6763
"RTN","XOBVLL",141,0)
6764
DO ERROR^XOBVLIB(.XOBDAT)
6765
"RTN","XOBVLL",142,0)
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)
6773
"RTN","XOBVLL",146,0)
6774
; -- need to make sure any locks are released since code aborted ungracefully
6775
"RTN","XOBVLL",147,0)
6777
"RTN","XOBVLL",148,0)
6779
"RTN","XOBVLL",149,0)
6780
; -- Save off the error
6781
"RTN","XOBVLL",150,0)
6783
"RTN","XOBVLL",151,0)
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)
6791
"RTN","XOBVLL",155,0)
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)
6799
"RTN","XOBVLL",159,0)
6801
"RTN","XOBVLL",160,0)
6806
XOBVRH ;mjk/alb SC/JDA - VistaLink Request Handler Utilities ;13APR2009
6808
;;1.5;VistALink;**MSC**;Sep 09, 2005
6810
;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
6818
; ------------------------------------------------------------------
6820
; Message Type Handler Utilities
6822
; ------------------------------------------------------------------
6823
"RTN","XOBVRH",10,0)
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)
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)
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)
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)
6855
"RTN","XOBVRH",26,0)
6857
"RTN","XOBVRH",27,0)
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)
6873
"RTN","XOBVRH",35,0)
6875
"RTN","XOBVRH",36,0)
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)
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)
6889
"RTN","XOBVRH",43,0)
6891
"RTN","XOBVRH",44,0)
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)
6899
"RTN","XOBVRH",48,0)
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)
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)
6913
"RTN","XOBVRH",55,0)
6915
"RTN","XOBVRH",56,0)
6916
. SET XOBHDLR(0,"ERROR")="No message type defined"
6917
"RTN","XOBVRH",57,0)
6919
"RTN","XOBVRH",58,0)
6921
"RTN","XOBVRH",59,0)
6922
SET(TYPE,TYPE0,XOBHDLR) ; -- set nodes
6923
"RTN","XOBVRH",60,0)
6925
"RTN","XOBVRH",61,0)
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)
6939
"RTN","XOBVRH",68,0)
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)
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)
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)
6975
"RTN","XOBVRH",86,0)
6977
"RTN","XOBVRH",87,0)
6979
"RTN","XOBVRH",88,0)
6980
; -- get interface routine and test for existence
6981
"RTN","XOBVRH",89,0)
6983
"RTN","XOBVRH",90,0)
6985
"RTN","XOBVRH",91,0)
6987
"RTN","XOBVRH",92,0)
6988
SET X=$PIECE(XOBTYPE0,"^",5)
6989
"RTN","XOBVRH",93,0)
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)
6997
"RTN","XOBVRH",97,0)
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)
7009
"RTN","XOBVSKT",5,0)
7011
"RTN","XOBVSKT",6,0)
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)
7025
"RTN","XOBVSKT",13,0)
7026
SET STR="",EOT=$CHAR(4),DONE=0,LINE=0,XOBOK=1
7027
"RTN","XOBVSKT",14,0)
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)
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)
7041
"RTN","XOBVSKT",21,0)
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)
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)
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)
7067
"RTN","XOBVSKT",34,0)
7069
"RTN","XOBVSKT",35,0)
7071
"RTN","XOBVSKT",36,0)
7072
ADD(TXT) ; -- add new intake line
7073
"RTN","XOBVSKT",37,0)
7075
"RTN","XOBVSKT",38,0)
7076
SET @XOBROOT@(LINE)=TXT
7077
"RTN","XOBVSKT",39,0)
7079
"RTN","XOBVSKT",40,0)
7081
"RTN","XOBVSKT",41,0)
7082
CHK ; -- check if first read and change timeout and chars to read
7083
"RTN","XOBVSKT",42,0)
7085
"RTN","XOBVSKT",43,0)
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)
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)
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)
7105
"RTN","XOBVSKT",53,0)
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)
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)
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)
7127
"RTN","XOBVSKT",64,0)
7129
"RTN","XOBVSKT",65,0)
7131
"RTN","XOBVSKT",66,0)
7133
"RTN","XOBVSKT",67,0)
7134
; -- get string of length LEN from stream buffer
7135
"RTN","XOBVSKT",68,0)
7137
"RTN","XOBVSKT",69,0)
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)
7147
"RTN","XOBVSKT",74,0)
7149
"RTN","XOBVSKT",75,0)
7150
; -- read more from stream buffer but only needed amount
7151
"RTN","XOBVSKT",76,0)
7153
"RTN","XOBVSKT",77,0)
7155
"RTN","XOBVSKT",78,0)
7156
READ X#LEN:1 SET XOBUF=XOBUF_X
7157
"RTN","XOBVSKT",79,0)
7159
"RTN","XOBVSKT",80,0)
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)
7171
"RTN","XOBVSKT",86,0)
7173
"RTN","XOBVSKT",87,0)
7175
"RTN","XOBVSKT",88,0)
7177
"RTN","XOBVSKT",89,0)
7179
"RTN","XOBVSKT",90,0)
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)
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)
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)
7197
"RTN","XOBVSKT",99,0)
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)
7207
"RTN","XOBVSKT",104,0)
7208
. DO WRITE($$XMLHDR^XOBVLIB()_XOBPARMS("CLOSE MESSAGE"))
7209
"RTN","XOBVSKT",105,0)
7211
"RTN","XOBVSKT",106,0)
7213
"RTN","XOBVSKT",107,0)
7215
"RTN","XOBVSKT",108,0)
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)
7223
"RTN","XOBVSKT",112,0)
7225
"RTN","XOBVSKT",113,0)
7226
INIT ; -- set up variables needed in tcp/ip processing
7227
"RTN","XOBVSKT",114,0)
7229
"RTN","XOBVSKT",115,0)
7231
"RTN","XOBVSKT",116,0)
7233
"RTN","XOBVSKT",117,0)
7235
"RTN","XOBVSKT",118,0)
7237
"RTN","XOBVSKT",119,0)
7238
; -- set RPC Broker os variable (so $$BROKER^XWBLIB returns true)
7239
"RTN","XOBVSKT",120,0)
7241
"RTN","XOBVSKT",121,0)
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)
7249
"RTN","XOBVSKT",125,0)
7251
"RTN","XOBVSKT",126,0)
7252
. DO SAVDEV^%ZISUTL("XOBNULL")
7253
"RTN","XOBVSKT",127,0)
7255
"RTN","XOBVSKT",128,0)
7257
"RTN","XOBVSKT",129,0)
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)
7263
"RTN","XOBVSKT",132,0)
7265
"RTN","XOBVSKT",133,0)
7266
FINAL ; -- kill variables used in tcp/ip processing
7267
"RTN","XOBVSKT",134,0)
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)
7279
"RTN","XOBVSKT",140,0)
7281
"RTN","XOBVSKT",141,0)
7283
"RTN","XOBVSKT",142,0)
7285
"RTN","XOBVSKT",143,0)
7287
"RTN","XOBVSKT",144,0)
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)
7299
"RTN","XOBVSKT",150,0)
7301
"RTN","XOBVSKT",151,0)
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)
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)
7315
"RTN","XOBVSKT",158,0)
7316
; -- handle a long string
7317
"RTN","XOBVSKT",159,0)
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)
7323
"RTN","XOBVSKT",162,0)
7325
"RTN","XOBVSKT",163,0)
7327
"RTN","XOBVSKT",164,0)
7328
POST ; -- send eot and flush socket buffer
7329
"RTN","XOBVSKT",165,0)
7331
"RTN","XOBVSKT",166,0)
7333
"RTN","XOBVSKT",167,0)
7335
"RTN","XOBVSKT",168,0)
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)
7347
"RTN","XOBVSKT",174,0)
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)
7359
"RTN","XOBVTCPL",5,0)
7361
"RTN","XOBVTCPL",6,0)
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)
7369
"RTN","XOBVTCPL",10,0)
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)
7379
"RTN","XOBVTCPL",15,0)
7380
NEW $ETRAP,$ESTACK SET $ETRAP="D ^%ZTER HALT"
7381
"RTN","XOBVTCPL",16,0)
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)
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)
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)
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)
7417
"RTN","XOBVTCPL",34,0)
7418
. DO UNLOCK^XOBVTCP(XOBPORT)
7419
"RTN","XOBVTCPL",35,0)
7421
"RTN","XOBVTCPL",36,0)
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)
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)
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)
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)
7451
"RTN","XOBVTCPL",51,0)
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)
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)
7471
"RTN","XOBVTCPL",61,0)
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)
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)
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)
7493
"RTN","XOBVTCPL",72,0)
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)
7503
"RTN","XOBVTCPL",77,0)
7504
CHILD ;Child process
7505
"RTN","XOBVTCPL",78,0)
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)
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)
7523
"RTN","XOBVTCPL",87,0)
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)
7533
"RTN","XOBVTCPL",92,0)
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)
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)
7553
"RTN","XOBVTCPL",102,0)
7555
"RTN","XOBVTCPL",103,0)
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)
7563
"RTN","XOBVTCPL",107,0)
7564
; -- give client time to process stream
7565
"RTN","XOBVTCPL",108,0)
7567
"RTN","XOBVTCPL",109,0)
7569
"RTN","XOBVTCPL",110,0)
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)
7579
"RTN","XOBVTCPL",115,0)
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)
7590
XPDR ;SFISC/RSD MSC/JDS - Routine File Edit ;24APR2009
7592
;;8.0;KERNEL;**1,2,44,MSC**;Jul 10, 1995
7596
UPDT ;update routine file
7598
N DIR,DIRUT,XPD,XPDI,XPDJ,XPDN,X,X1,Y,Y1,% W !
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"
7602
;XPDN(0=excluded names or 1=include names, namespace)=""
7604
F D ^DIR Q:$D(DIRUT) S X=$E(Y,$L(Y))="*",%=$E(Y)="-",XPDN('%,$E(Y,%+1,$L(Y)-X))=""
7606
Q:'$D(XPDN)!$D(DTOUT)!$D(DUOUT)
7608
W !!,"NAMESPACE INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------"
7610
S (X,Y)="",(X1,Y1)=1
7612
F D W !?11,X,?35,Y Q:'X1&'Y1
7614
.S:X1 X=$O(XPDN(1,X)),X1=X]"" S:Y1 Y=$O(XPDN(0,Y)),Y1=Y]""
7616
K DIR S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
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."
7624
Q:$D(DIRUT) D WAIT^DICD,DELRTN:Y
7626
;loop thru include list XPDN(1,XPDI)
7628
N ISGTM S ISGTM=$G(^%ZOSF("OS"))["GT.M"
7630
S XPDI="" F S XPDI=$O(XPDN(1,XPDI)) Q:XPDI="" D
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
7634
..;if name XPDJ is in the exclude list, XPDN(0,XPDJ) or in Routine file, quit
7636
..Q:$D(XPDN(0,XPDJ))!$O(^DIC(9.8,"B",XPDJ,0))
7638
..;check if XPDJ is refered in the namespace by checking the subscript
7640
..;before XPDJ, if sub exist and $P(XPDJ,sub)="" then it is part of the
7644
..S %=$O(XPDN(0,XPDJ),-1) I $L(%),$P(XPDJ,%)="" Q
7646
..N XPD S XPD(9.8,"+1,",.01)=XPDJ,XPD(9.8,"+1,",1)="R"
7648
..D ADD^DICA("","XPD")
7654
ROUT(D,ISGTM,VALUE) ;
7656
I D,ISGTM Q $D(%ZR(VALUE))
7658
I ISGTM Q $O(%ZR(VALUE))
7660
N A I D X "S X=$D(^$R(VALUE))" Q A
7662
X "S A=$O(^$R(VALUE))" Q A
7664
VER ;verify Routine file
7668
W !,"I will delete all entries in the Routine File in which",!,"the Routine no longer exist on this system!",!
7670
S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
7672
Q:'Y!$D(DIRUT) D DELRTN
7678
DELRTN ;delete routine file entries
7682
S DIK="^DIC(9.8,",DA=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
7690
N DA,DIK,DIR,DIRUT,X,XPD,XPDF,XPDI,XPDJ,XPDL,XPDN,XPDPG,XPDS,XPDUL,Y,Z
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)"
7696
S XPDF=$S(Y="I":9.7,1:9.6) S:Y="ALL" XPDF(1)=9.7
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
7700
D ^DIR Q:$D(DIRUT) S XPDN=Y
7704
S DIR(0)="FO^3:30",DIR("?")="^D PURGEH^XPDR",DIR("A")="Package Name",DIR("B")="ALL"
7706
F D ^DIR Q:$D(DIRUT) S XPD(X)="" Q:X="ALL" K DIR("B") S DIR("A")="Another Package Name"
7710
;if they want all, make sure all is the only one
7712
I $D(XPD("ALL")) K XPD S XPD("ALL")=""
7714
;XPDF(1) is defined if doing both files, do purge twice
7716
K ^TMP($J) D PURGE1(XPDF),PURGE1($G(XPDF(1))):$D(XPDF(1))
7718
I '$D(^TMP($J)) W !!,"No match found" Q
7722
S DIR(0)="E",$P(XPDUL,"-",IOM)=""
7724
;if ALL, reset XPDF to next file and Do, then reset back to 9.6
7726
D I $D(XPDF(1)) D ^DIR I Y S XPDF=XPDF(1) D S XPDF=9.6
7728
.S XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS),XPDPG=1,Y=1
7732
.;loop thru ^TMP($J,file,package) & show list, quit if user "^"
7734
.F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D Q:'Y
7736
..S Z=@XPD W $P(Z,"^"),$S($P(Z,"^",3):" (duplicates)",1:""),! Q:$Y<(IOSL-4)
7740
..S XPDPG=XPDPG+1 W @IOF D HDR
7742
S DIR(0)="Y",DIR("A")="OK to DELETE these entries",DIR("B")="NO"
7746
I $D(DIRUT)!'Y W !!,"Nothing Purged" Q
7748
;loop thru and delete
7750
D I $D(XPDF(1)) S XPDF=XPDF(1) D
7752
.S DIK="^XPD("_XPDF_",",XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS)
7754
.F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D
7756
..S XPDI=@XPD F XPDJ=2:1 S DA=$P(XPDI,"^",XPDJ) Q:'DA D ^DIK
7762
PURGE1(XPDF) ;XPDF=file #
7764
N XPDFL,XPDI,XPDJ,XPDP,XPDV,Y,Z
7768
;if All, loop thru B x-ref
7774
.F S XPDI=$O(^XPD(XPDF,"B",XPDI)) Q:XPDI="" D
7776
..S X=$$PKG^XPDUTL(XPDI) D PURGE2(X)
7780
E S XPDI="" F S XPDI=$O(XPD(XPDI)) Q:XPDI="" D
7786
;loop thru each package, XPDP=package name
7788
S XPDP="" F S XPDP=$O(^TMP($J,XPDF,XPDP)) Q:XPDP="" D
7790
.S XPDV="",XPDL=XPDN
7792
.;the last is the most recent, XPDN = number to retain, XPDV=version
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
7798
..S Y="" F S Y=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y),-1) Q:Y=""!'XPDL D
7800
...I $D(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y))#2 K ^(Y) S XPDL=XPDL-1 Q
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
7808
PURGE2(XPDX) ;XPDX=package name
7810
;XPDFL=1 this is not a patch, quit when we find a patch during loop
7812
S XPDS=XPDX,XPDL=$L(XPDX),XPDFL=XPDX'["*"
7814
;loop and find matches
7816
D F S XPDS=$O(^XPD(XPDF,"B",XPDS)) Q:XPDS=""!($E(XPDS,1,XPDL)'=XPDX)!($S(XPDFL:XPDS["*",1:0)) D
7818
.S Y=$O(^XPD(XPDF,"B",XPDS,0)) Q:'Y
7820
.Q:'$D(^XPD(XPDF,Y,0)) S Z=^(0),Y=XPDS_"^"_Y
7822
.;can't delete Installs that status isn't 'Install Completed'
7824
.I XPDF=9.7 Q:$P(Z,U,9)<3
7826
.S XPDV=$$VER^XPDUTL(XPDS)
7828
.;TMP($J,file,package name,version,"*","T/V/Z",num,patch)=NAME^DA^duplicat DAs
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
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
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
7838
..S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*",+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2))
7840
.;TMP($J,file,package name,version,"Z",0)=NAME^DA^duplicate DAs
7842
.I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"Z",0)=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7844
.;TMP($J,file,package name,version,"T/V",num)=NAME^DA^dup DAs
7846
.I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"T",+$P(XPDV,"T",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7848
.I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"V",+$P(XPDV,"V",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
7852
PURGEH ;executable help from DIR call at PURGE+8
7854
W:$E(DIR("A"),1)="P" !,"Enter 'ALL' to purge all packages, or"
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",!
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"
7862
D ^DIR Q:'Y!$D(DIRUT)
7864
D PURGEH1("^XPD(9.6,"):XPDF=9.6,PURGEH1("^XPD(9.7,"):XPDF=9.7!$D(XPDF(1))
7870
DUP(Z,Z1) ;find duplicate, Z=NAME, Z1=last ien
7872
;returns Y=DA^dup DA^dup DA...
7876
F S Z1=$O(^XPD(XPDF,"B",Z,Z1)) Q:'Z1 S Y=Y_"^"_Z1
7884
W !!,$S(DIC[9.6:"BUILD ",1:"INSTALL ")_"File"
7886
S DIC(0)="QE",X="??" D ^DIC
7892
HDR W !,"Package(s) in ",$S(XPDF=9.7:"INSTALL",1:"BUILD")," File, "
7894
I XPDN W "Retain last ",$S(XPDN=1:"version",1:XPDN_" versions")
7896
E W "Don't retain any versions"
7898
W ?70,"PAGE ",XPDPG,!,XPDUL,!
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)
7909
"RTN","XQALSUR1",4,0)
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)
7931
"RTN","XQALSUR1",15,0)
7933
"RTN","XQALSUR1",16,0)
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)
7953
"RTN","XQALSUR1",26,0)
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)
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)
7983
"RTN","XQALSUR1",41,0)
7985
"RTN","XQALSUR1",42,0)
7987
"RTN","XQALSUR1",43,0)
7988
. . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL
7989
"RTN","XQALSUR1",44,0)
7991
"RTN","XQALSUR1",45,0)
7993
"RTN","XQALSUR1",46,0)
7995
"RTN","XQALSUR1",47,0)
7997
"RTN","XQALSUR1",48,0)
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)
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)
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)
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)
8043
"RTN","XQALSUR1",71,0)
8045
"RTN","XQALSUR1",72,0)
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)
8059
"RTN","XQALSUR1",79,0)
8061
"RTN","XQALSUR1",80,0)
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)
8075
"RTN","XQALSUR1",87,0)
8077
"RTN","XQALSUR1",88,0)
8079
"RTN","XQALSUR1",89,0)
8081
"RTN","XQALSUR1",90,0)
8083
"RTN","XQALSUR1",91,0)
8084
N XQALSURO,XQALSTRT,XQALEND
8085
"RTN","XQALSUR1",92,0)
8087
"RTN","XQALSUR1",93,0)
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)
8101
"RTN","XQALSUR1",100,0)
8103
"RTN","XQALSUR1",101,0)
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)
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)
8131
"RTN","XQALSUR1",115,0)
8132
S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary.
8133
"RTN","XQALSUR1",116,0)
8135
"RTN","XQALSUR1",117,0)
8137
"RTN","XQALSUR1",118,0)
8138
DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ;
8139
"RTN","XQALSUR1",119,0)
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)
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)
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)
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)
8183
"RTN","XQALSUR1",141,0)
8185
"RTN","XQALSUR1",142,0)
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)
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)
8201
"RTN","XQALSUR1",150,0)
8203
"RTN","XQALSUR1",151,0)
8204
STRTDLG() ; new surrogate start date/time dialog
8205
"RTN","XQALSUR1",152,0)
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)
8217
"RTN","XQALSUR1",158,0)
8219
"RTN","XQALSUR1",159,0)
8220
ENDDLG() ; new surrogate end date/time dialog
8221
"RTN","XQALSUR1",160,0)
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)
8233
"RTN","XQALSUR1",166,0)
8235
"RTN","XQALSUR1",167,0)
8237
"RTN","XQALSUR1",168,0)
8239
"RTN","XQALSUR1",169,0)
8240
D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1
8241
"RTN","XQALSUR1",170,0)
8246
XTER1A ;ISC-SF.SEA/JLI MSC/JDS- VA error reporting ;24APR2009
8248
;;8.0;KERNEL;**63,112,120,MSC,IHS**;Jul 10, 1995
8258
S:'$D(XTNUM) XTNUM=1
8260
S:'$D(XTNDATE) XTNDATE=$H-1 I '$D(ZTQUEUED) S XTNDAT1=$$HTFM^XLFDT(XTNDATE),XTNDAT2=XTNDAT1 G INT^XTER1A1
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)
8267
"RTN","XTER1A",12,0)
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)
8279
"RTN","XTER1A",18,0)
8281
"RTN","XTER1A",19,0)
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)
8303
"RTN","XTER1A",30,0)
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)
8319
"RTN","XTER1A",38,0)
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)
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)
8337
"RTN","XTER1A",47,0)
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)
8347
"RTN","XTER1A",52,0)
8349
"RTN","XTER1A",53,0)
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)
8359
"RTN","XTER1A",58,0)
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)
8375
"RTN","XTER1A",66,0)
8377
"RTN","XTER1A",67,0)
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)
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)
8401
"RTN","XTER1A",79,0)
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)
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)
8417
"RTN","XTER1A",87,0)
8419
"RTN","XTER1A",88,0)
8420
T3 W !!,?11,"$ZE",?41,"Time",?49,"UCI,VOL",?61,"$J",?69,"$I",!
8421
"RTN","XTER1A",89,0)
8423
"RTN","XTER1A",90,0)
8425
"RTN","XTER1A",91,0)
8427
"RTN","XTER1A",92,0)
8429
"RTN","XTER1A",93,0)
8431
"RTN","XTER1A",94,0)
8433
"RTN","XTER1A",95,0)
8435
"RTN","XTER1A",96,0)
8436
IHSXQY0 ;IHS/ANMC/LJF 5/20/99 find option name
8437
"RTN","XTER1A",97,0)
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)
8457
"RTN","XTER1A",107,0)
8459
"RTN","XTER1A",108,0)
8460
I ^%ZOSF("OS")'["GT.M" Q Y
8461
"RTN","XTER1A",109,0)
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)
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)
8487
"RTN","XUMF5AU",12,0)
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)
8501
"RTN","XUMF5AU",19,0)
8503
"RTN","XUMF5AU",20,0)
8505
"RTN","XUMF5AU",21,0)
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)
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)
8519
"RTN","XUMF5AU",28,0)
8520
S:NPAD>1 $P(PAD,$C(0),NPAD)=""
8521
"RTN","XUMF5AU",29,0)
8523
"RTN","XUMF5AU",30,0)
8524
PAD2R ; Append length in bits as 64-bit integer, little endian
8525
"RTN","XUMF5AU",31,0)
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)
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)
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)
8543
"RTN","XUMF5AU",40,0)
8545
"RTN","XUMF5AU",41,0)
8547
"RTN","XUMF5AU",42,0)
8549
"RTN","XUMF5AU",43,0)
8551
"RTN","XUMF5AU",44,0)
8553
"RTN","XUMF5AU",45,0)
8555
"RTN","XUMF5AU",46,0)
8557
"RTN","XUMF5AU",47,0)
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)
8565
"RTN","XUMF5AU",51,0)
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)
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)
8581
"RTN","XUMF5AU",59,0)
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)
8597
"RTN","XUMF5AU",67,0)
8599
"RTN","XUMF5AU",68,0)
8601
"RTN","XUMF5AU",69,0)
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)
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)
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)
8631
"RTN","XUMF5AU",84,0)
8632
PAD2E ; Append length in bits as 64-bit integer, little endian
8633
"RTN","XUMF5AU",85,0)
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)
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)
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)
8653
"RTN","XUMF5AU",95,0)
8655
"RTN","XUMF5AU",96,0)
8657
"RTN","XUMF5AU",97,0)
8659
"RTN","XUMF5AU",98,0)
8661
"RTN","XUMF5AU",99,0)
8663
"RTN","XUMF5AU",100,0)
8664
. ;W !,I," ABCD=",$$MAIN^XUMF5BYT($$HEX(A_B_C_D)),!
8665
"RTN","XUMF5AU",101,0)
8667
"RTN","XUMF5AU",102,0)
8669
"RTN","XUMF5AU",103,0)
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)
8677
"RTN","XUMF5AU",107,0)
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)
8693
"RTN","XUMF5AU",115,0)
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)
8705
"RTN","XUMF5AU",121,0)
8706
S AA=A,BB=B,CC=C,DD=D
8707
"RTN","XUMF5AU",122,0)
8709
"RTN","XUMF5AU",123,0)
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)
8747
"RTN","XUMF5AU",142,0)
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)
8785
"RTN","XUMF5AU",161,0)
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)
8823
"RTN","XUMF5AU",180,0)
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)
8861
"RTN","XUMF5AU",199,0)
8863
"RTN","XUMF5AU",200,0)
8865
"RTN","XUMF5AU",201,0)
8867
"RTN","XUMF5AU",202,0)
8869
"RTN","XUMF5AU",203,0)
8871
"RTN","XUMF5AU",204,0)
8873
"RTN","XUMF5AU",205,0)
8875
"RTN","XUMF5AU",206,0)
8876
; Auxiliary functions
8877
"RTN","XUMF5AU",207,0)
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)
8883
"RTN","XUMF5AU",210,0)
8885
"RTN","XUMF5AU",211,0)
8887
"RTN","XUMF5AU",212,0)
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)
8901
"RTN","XUMF5AU",219,0)
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)
8915
"RTN","XUMF5AU",226,0)
8917
"RTN","XUMF5AU",227,0)
8918
; Boolean functions assume args are 4-character strings
8919
"RTN","XUMF5AU",228,0)
8921
"RTN","XUMF5AU",229,0)
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)
8931
"RTN","XUMF5AU",234,0)
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)
8941
"RTN","XUMF5AU",239,0)
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)
8951
"RTN","XUMF5AU",244,0)
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)
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)
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)
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)
8985
"RTN","XUMF5AU",261,0)
8986
ADDII(M,N) ; modulo 2**32
8987
"RTN","XUMF5AU",262,0)
8989
"RTN","XUMF5AU",263,0)
8991
"RTN","XUMF5AU",264,0)
8992
ROTL(X,S) ; rotate left by s bits
8993
"RTN","XUMF5AU",265,0)
8995
"RTN","XUMF5AU",266,0)
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)
9003
"RTN","XUMF5AU",270,0)
9005
"RTN","XUMF5AU",271,0)
9006
ROTLI(N,S) ; rotate left by s bits
9007
"RTN","XUMF5AU",272,0)
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)
9015
"RTN","XUMF5AU",276,0)
9017
"RTN","XUMF5AU",277,0)
9019
"RTN","XUMF5AU",278,0)
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)
9027
"RTN","XUMF5AU",282,0)
9029
"RTN","XUMF5AU",283,0)
9031
"RTN","XUMF5AU",284,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)
9037
"RTN","XUMF5AU",287,0)
9039
"RTN","XUMF5AU",288,0)
9040
F I=1:1:7 S D=D_$C(X(I))
9041
"RTN","XUMF5AU",289,0)
9043
"RTN","XUMF5AU",290,0)
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)
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)
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)
9069
"RTN","XUMF5AU",303,0)
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)
9083
"RTN","XUMF5AU",310,0)
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)
9091
"RTN","XUMF5AU",314,0)
9093
"RTN","XUMF5AU",315,0)
9094
. S BYTE=$E(STR,I,I+1)
9095
"RTN","XUMF5AU",316,0)
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)
9105
"RTN","XUMF5AU",321,0)
9107
"RTN","XUMF5AU",322,0)
9108
CHAR1(DIGIT) ; convert one char to its hex value
9109
"RTN","XUMF5AU",323,0)
9111
"RTN","XUMF5AU",324,0)
9112
S X=$F("0123456789abcdef",DIGIT)
9113
"RTN","XUMF5AU",325,0)
9115
"RTN","XUMF5AU",326,0)
9120
XWBRW ;ISF/RWF,MSC/JDA - Read/Write for Broker TCP ;06AUG2009
9122
;;1.1;RPC BROKER;**35,MSC**;Mar 28, 1997
9130
;SE is a flag to skip error for short read. From PRSB+41^XWBBRK
9132
BREAD(L,TO,SE) ;read tcp buffer, L is length, TO is timeout
9138
I $L(XWBRBUF)'<L S R=$E(XWBRBUF,1,L),XWBRBUF=$E(XWBRBUF,L+1,999999) Q R
9140
S R="",DONE=0,L=+L,C=0
9142
S TO=$S($G(TO)>0:TO,$G(XWBTIME(1))>0:XWBTIME(1),1:60)/2+1
9148
. S S=L-$L(R),R=R_$E(XWBRBUF,1,S),XWBRBUF=$E(XWBRBUF,S+1,999999)
9150
. I ($L(R)=L)!(R[$C(4))!(C>TO) S DONE=1 Q
9152
. R XWBRBUF#S:2 S:'$T C=C+1 S:$L(XWBRBUF) C=0
9154
. I $D D LOG^XWBDLOG("Device error: "_$D) S DONE=1
9156
. I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG("rd: "_$E(XWBRBUF,1,252))
9160
I $L(R)<L,'$G(SE) S $ECODE=",U411," ;Throw Error, Did not read full length
9166
QSND(XWBR) ;Quick send
9168
S XWBPTYPE=1,XWBERROR="",XWBSEC="" D SND
9174
ESND(XWBR) ;Send from ETRAP
9182
SND ; Send a responce
9184
N XWBSBUF S XWBSBUF=""
9190
D SNDERR ;Send any error info
9192
D SNDDATA ;Send the data
9194
;D WRITE($C(4)) ;EOT
9202
SNDDATA ;Send the data part
9208
I XWBPTYPE=1 D WRITE($G(XWBR)) Q
9210
; -- table delimited by CR+LF
9214
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)),WRITE($C(13,10))
9216
; -- word processing
9220
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE(XWBR(I)) D:XWBWRAP WRITE($C(13,10))
9226
. I $E($G(XWBR))'="^" Q
9228
. S I=$G(XWBR) Q:I="" S T=$E(I,1,$L(I)-1)
9230
. ;Only send root node if non-null.
9232
. I $D(@I)>10 S D=@I I $L(D) D WRITE(D),WRITE($C(13,10)):XWBWRAP&(D'=$C(13,10))
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))
9236
. I $D(@XWBR) K @XWBR
9238
; -- global instance
9242
. I $E($G(XWBR))'="^" Q
9244
. S XWBR=$G(@XWBR) D WRITE(XWBR) Q
9246
; -- variable length records only good upto 255 char)
9250
. S I="" F S I=$O(XWBR(I)) Q:I="" D WRITE($C($L(XWBR(I)))),WRITE(XWBR(I))
9256
SNDERR ;send error information
9258
;XWBSEC is the security packet, XWBERROR is application packet
9262
S $X=0 ;Start with zero
9264
S X=$E($G(XWBSEC),1,255)
9266
D WRITE($C($L(X))_X)
9268
S X=$E($G(XWBERROR),1,255)
9270
D WRITE($C($L(X))_X)
9272
S XWBERROR="",XWBSEC="" ;clears parameters
9278
WRITE(STR) ;Write a data string
9280
; send data for DSM (requires buffer flush (!) every 511 chars)
9282
;IF XWBOS="DSM"!(XWBOS="UNIX")!(XWBOS="OpenM) next line
9286
. I $L(XWBSBUF)+$L(STR)>240 D WBF
9288
. S XWBSBUF=XWBSBUF_$E(STR,1,255),STR=$E(STR,256,99999)
9292
WBF ;Write Buffer Flush
9296
I $G(XWBDEBUG)>2,$L(XWBSBUF) D LOG^XWBDLOG("wrt ("_$L(XWBSBUF)_"): "_$E(XWBSBUF,1,247))
9298
W XWBSBUF,@XWBT("BF")
9306
XWBSEC ;SFISC/VYD,MSC/JDA - RPC BROKER ;06AUG2009
9308
;;1.1;RPC BROKER;**3,6,10,35,MSC**;Mar 28, 1997
9310
CHKPRMIT(XWBRP) ;checks to see if remote procedure is permited to run
9312
;Input: XWBRP - Remote procedure to check
9314
Q:$$KCHK^XUSRB("XUPROGMODE")
9316
N ERR,XWBPRMIT,XWBALLOW
9318
S U="^",XWBSEC="" ;Return XWBSEC="" if OK to run RPC
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)
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)
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)
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)
9359
"RTN","XWBSEC",28,0)
9361
"RTN","XWBSEC",29,0)
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)
9385
"RTN","XWBSEC",41,0)
9387
"RTN","XWBSEC",42,0)
9389
"RTN","XWBSEC",43,0)
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)
9397
"RTN","XWBSEC",47,0)
9399
"RTN","XWBSEC",48,0)
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)
9407
"RTN","XWBSEC",52,0)
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)
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)
9427
"RTN","XWBTCPM",6,0)
9428
;MSC/JDA 04/13/09 - Added MOREREADTIME to GT.M init
9429
"RTN","XWBTCPM",7,0)
9431
"RTN","XWBTCPM",8,0)
9432
DSM ;DSM called from ucx, % passed in with device.
9433
"RTN","XWBTCPM",9,0)
9435
"RTN","XWBTCPM",10,0)
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)
9443
"RTN","XWBTCPM",14,0)
9445
"RTN","XWBTCPM",15,0)
9447
"RTN","XWBTCPM",16,0)
9448
CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
9449
"RTN","XWBTCPM",17,0)
9451
"RTN","XWBTCPM",18,0)
9453
"RTN","XWBTCPM",19,0)
9454
; **Cache'/VMS specific code**
9455
"RTN","XWBTCPM",20,0)
9457
"RTN","XWBTCPM",21,0)
9458
X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
9459
"RTN","XWBTCPM",22,0)
9461
"RTN","XWBTCPM",23,0)
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)
9469
"RTN","XWBTCPM",27,0)
9471
"RTN","XWBTCPM",28,0)
9473
"RTN","XWBTCPM",29,0)
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)
9481
"RTN","XWBTCPM",33,0)
9483
"RTN","XWBTCPM",34,0)
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)
9491
"RTN","XWBTCPM",38,0)
9493
"RTN","XWBTCPM",39,0)
9494
GTMLNX ;From Linux xinetd script
9495
"RTN","XWBTCPM",40,0)
9497
"RTN","XWBTCPM",41,0)
9499
"RTN","XWBTCPM",42,0)
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)
9509
"RTN","XWBTCPM",47,0)
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)
9517
"RTN","XWBTCPM",51,0)
9518
;Find the type of connection and jump to the processing routine.
9519
"RTN","XWBTCPM",52,0)
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)
9527
"RTN","XWBTCPM",56,0)
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)
9535
"RTN","XWBTCPM",60,0)
9536
I XWB["{XWB}" G OLD^XWBTCPM1
9537
"RTN","XWBTCPM",61,0)
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)
9545
"RTN","XWBTCPM",65,0)
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)
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)
9561
"RTN","XWBTCPM",73,0)
9563
"RTN","XWBTCPM",74,0)
9565
"RTN","XWBTCPM",75,0)
9566
S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
9567
"RTN","XWBTCPM",76,0)
9569
"RTN","XWBTCPM",77,0)
9571
"RTN","XWBTCPM",78,0)
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)
9579
"RTN","XWBTCPM",82,0)
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)
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)
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)
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)
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)
9653
"RTN","XWBTCPM",119,0)
9655
"RTN","XWBTCPM",120,0)
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)
9669
"RTN","XWBTCPM",127,0)
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)
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)
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)
9707
"RTN","XWBTCPM",146,0)
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)
9717
"RTN","XWBTCPM",151,0)
9719
"RTN","XWBTCPM",152,0)
9721
"RTN","XWBTCPM",153,0)
9722
ETRAP ; -- on trapped error, send error info to client
9723
"RTN","XWBTCPM",154,0)
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)
9741
"RTN","XWBTCPM",163,0)
9742
I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0)
9743
"RTN","XWBTCPM",164,0)
9745
"RTN","XWBTCPM",165,0)
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)
9757
"RTN","XWBTCPM",171,0)
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)
9765
"RTN","XWBTCPM",175,0)
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)
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)
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)
9789
"RTN","XWBTCPM",187,0)
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)
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)
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)
9809
"RTN","XWBTCPM",197,0)
9811
"RTN","XWBTCPM",198,0)
9813
"RTN","XWBTCPM",199,0)
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)
9819
"RTN","XWBTCPM",202,0)
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)
9835
"RTN","XWBTCPM",210,0)
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)
9857
"RTN","XWBTCPM",221,0)
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)
9867
"RTN","XWBTCPM",226,0)
9868
S IO("C")=1 ;Cause the Listenr to stop
9869
"RTN","XWBTCPM",227,0)
9871
"RTN","XWBTCPM",228,0)
9873
"RTN","XWBTCPM",229,0)
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)
9881
"RTN","XWBTCPM",233,0)
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)
9889
"RTN","XWBTCPM",237,0)
9894
ZCD ; MSC/JKT,JDS ; "Namespace" utilities for GT.M/Unix ; 5DEC2009
9896
;;8.0;KERNEL;**MSC**;April 21 2009
9898
; This routine assumes that your global directory file exists one
9900
; directory below the root of the instance, e.g.,
9904
; /opt/openvista/instance/globals/mumps.gld
9912
; /home/vista/instance/g/default.gld
9916
; The actual file name of the global directory file and the actual name
9918
; of the parent directory are never checked, so their names do not
9928
S:'$D(DTIME) DTIME=300
9930
R !,"Namespace: ",DIR:DTIME
9932
I DIR["^"!(DIR="") Q
9938
I '$D(Y("B",DIR)) W !,"Invalid Namespace" G CD
9940
I $$GTMPATH($$CURRENT())'=$$GTMPATH(DIR) W !,"Inconsistent GTM versions",! G CD
9950
F S A=$O(Y("B",A)) Q:A="" W !,A
9958
ROOT() ; return path where all OpenVista instances live
9960
Q $P($ZG,"/",1,$L($ZG,"/")-3)
9964
CURRENT() ; return name of the current OpenVista instance
9966
Q $P($ZG,"/",$L($ZG,"/")-2)
9970
PATH(INSTANCE) ; return path to an OpenVista instance
9972
Q $$ROOT()_"/"_INSTANCE
9976
GTMPATH(INSTANCE) ; return the path to the version of GT.M this instance uses
9984
O %PIPE:(COMMAND="ovgetvar "_INSTANCE_" gtm_path 2> /dev/null":READONLY)::"PIPE" U %PIPE
9990
I %PATH'="" U %I Q %PATH
9994
O %PIPE:(COMMAND="readlink "_$$PATH(INSTANCE)_"/gtm":READONLY)::"PIPE" U %PIPE
10004
LIST ; return an array (Y) of OpenVista instances on this system
10006
N %PIPE,%I S %PIPE="ls",%I=$I
10008
O %PIPE:(COMMAND="ls --color=none -1 "_$$ROOT():READONLY)::"PIPE" U %PIPE
10012
F I=1:1 R %NAME Q:%NAME="" I $$GTMPATH(%NAME)'="" S Y(I)=%NAME,Y("B",%NAME)=""
10022
SWITCH(INSTANCE) ; switch to another OpenVista instance
10024
N %ZG,%ZRO D NEWZGZRO(INSTANCE) I %ZG="",%ZRO="" Q 0
10028
N %TEMPDIR S %TEMPDIR=$$MKTEMP() S $ZG=%ZG,$ZRO=%ZRO_" "_%TEMPDIR
10030
N X,Y S X=INSTANCE X ^%ZOSF("UPPERCASE") S $ZPROMPT=Y_">"
10034
; re-ZLINK routines that have been loaded in our current image
10036
X "Q" ; equivalent to ZGOTO so that you can recompile a routine you are using
10038
N %ROUTINE,%FILENAME S %ROUTINE=""
10040
NEXT F S %ROUTINE=$VIEW("rtnnext",%ROUTINE) Q:%ROUTINE="" D
10042
. I "^GTM$DMOD^ZCD^MSCXUS3A^XQ1^XUP^%MSCXUCI^%ZMSCXUCI^"[("^"_%ROUTINE_"^") Q ;do not try to recompile these
10046
. ; The only % routines that we ship start with %Z; other % routines are allocated to the
10048
. ; vendor (GTM) and do not need to be recompiled (and may only have object code)
10050
. Q:$E(%ROUTINE)="%"&($E(%ROUTINE,2)'="Z")
10054
. ; If the routine exists in the target instance, ZLINK it. This replaces the
10056
. ; old version in our current image with the new version from the target instance.
10058
. ; If the routine does not exist in the target instance, we have to "kill" the routine
10060
. ; in our current image by creating a dummy routine that throws a GTM-E-FILENOTFND error
10062
. ; and ZLINKing the dummy routine. See http://groups.google.com/group/Hardhats/msg/a213981e1503db79
10064
. S %FILENAME=$TR(%ROUTINE,"%","_")_".m"
10066
. K %ZR D SILENT^%RSEL(%ROUTINE) I '$D(%ZR(%ROUTINE)) D WRITEROU(%TEMPDIR_"/"_%FILENAME,%ROUTINE)
10072
; cleanup and return
10074
S $ZRO=%ZRO ; remove temporary directory from $ZRO
10076
ZSY "rm -rf "_%TEMPDIR
10084
NEWZGZRO(INSTANCE) ; determine new values of $ZG and $ZRO
10090
; don't allow switching if GT.M versions aren't the same
10092
Q:$$GTMPATH($$CURRENT())'=$$GTMPATH(INSTANCE)
10096
; there are several ways to determine new values of $ZG and $ZRO
10098
; try each method until one succeeds
10100
N %METHOD F %METHOD="ENV","CAT","REP" D @("SWITCH"_%METHOD)(INSTANCE) Q:%ZG'=""&(%ZRO'="")
10106
SWITCHENV(INSTANCE) ; private entry point
10108
; set new $ZG and $ZRO by parsing env file in target instance
10116
S %PIPE="ovgetvar_gtmgbldir"
10118
O %PIPE:(COMMAND="ovgetvar "_INSTANCE_" gtmgbldir 2> /dev/null":READONLY)::"PIPE" U %PIPE
10124
S %PIPE="ovgetvar_gtmroutines"
10126
O %PIPE:(COMMAND="ovgetvar "_INSTANCE_" gtmroutines 2> /dev/null":READONLY)::"PIPE" U %PIPE
10136
; FIXME: check that %ZG actually exists and that all pieces of %ZRO exist
10142
SWITCHCAT(INSTANCE) ; private entry point
10144
; set new $ZG and $ZRO by concatenating conventional names to $$ROOT.
10146
; NOTE: this code makes assumptions about the directory layout of the
10148
; OpenVista instance.
10152
S %ZG=$$PATH(INSTANCE)_"/globals/mumps.gld"
10154
S %ZRO=$$PATH(INSTANCE)_"/objects("_$$PATH(INSTANCE)_"/routines) "_$$PATH(INSTANCE)_"/gtm"
10158
; FIXME: check that %ZG actually exists and that all pieces of %ZRO exist
10164
SWITCHREP(INSTANCE) ; private entry point
10166
; set new $ZG and $ZRO by replacing $$PATH($$CURRENT()) with $$PATH(INSTANCE)
10170
; FIXME: implement this
10176
MKTEMP() ; create a secure temporary directory, returns path to new directory
10178
N %PIPE,%I S %PIPE="mktemp",%I=$I
10180
O %PIPE:(COMMAND="mktemp -d -t .zcd.XXXXXXXXXX":READONLY)::"PIPE" U %PIPE
10182
N %TEMPDIR R %TEMPDIR
10192
WRITEROU(PATH,ROUTINE) ; write out dummy routine
10196
O PATH:(NEWVERSION:NOREADONLY:VARIABLE) U PATH
10200
W " ZMESSAGE 150374338:$PIECE($ZPOSITION,""^"",2)",!
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)
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)
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)
10231
"RTN","ZIS4GTM",11,0)
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)
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)
10245
"RTN","ZIS4GTM",18,0)
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)
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)
10277
"RTN","ZIS4GTM",34,0)
10279
"RTN","ZIS4GTM",35,0)
10281
"RTN","ZIS4GTM",36,0)
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)
10293
"RTN","ZIS4GTM",42,0)
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)
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)
10313
"RTN","ZIS4GTM",52,0)
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)
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)
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)
10367
"RTN","ZIS4GTM",79,0)
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)
10375
"RTN","ZIS4GTM",83,0)
10377
"RTN","ZIS4GTM",84,0)
10378
REWSDP(IO,IOPAR) ;Rewind SDP
10379
"RTN","ZIS4GTM",85,0)
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)
10387
"RTN","ZIS4GTM",89,0)
10389
"RTN","ZIS4GTM",90,0)
10390
REWERR ;Error encountered
10391
"RTN","ZIS4GTM",91,0)
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)
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)
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)
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)
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)
10457
"RTN","ZISFGTM",32,0)
10458
CHKNM(H) ;Check the HFS name
10459
"RTN","ZISFGTM",33,0)
10461
"RTN","ZISFGTM",34,0)
10463
"RTN","ZISFGTM",35,0)
10464
. I (H'[":")&(H'["[") S N=$$DEFDIR^%ZISH("")_H
10465
"RTN","ZISFGTM",36,0)
10467
"RTN","ZISFGTM",37,0)
10468
. I (H'["/") S N=$$DEFDIR^%ZISH("")_H
10469
"RTN","ZISFGTM",38,0)
10471
"RTN","ZISFGTM",39,0)
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)
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)
10485
"RTN","ZISFGTM",46,0)
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)
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)
10499
"RTN","ZISFGTM",53,0)
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)
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)
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)
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)
10531
"RTN","ZISHGUX",5,0)
10533
"RTN","ZISHGUX",6,0)
10535
"RTN","ZISHGUX",7,0)
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)
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)
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)
10563
"RTN","ZISHGUX",21,0)
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)
10573
"RTN","ZISHGUX",26,0)
10574
OPNERR ;error on open
10575
"RTN","ZISHGUX",27,0)
10577
"RTN","ZISHGUX",28,0)
10579
"RTN","ZISHGUX",29,0)
10581
"RTN","ZISHGUX",30,0)
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)
10593
"RTN","ZISHGUX",36,0)
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)
10615
"RTN","ZISHGUX",47,0)
10616
. I '$T S %ZXDEL=0 Q ; Can't open it.
10617
"RTN","ZISHGUX",48,0)
10619
"RTN","ZISHGUX",49,0)
10620
. I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful.
10621
"RTN","ZISHGUX",50,0)
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)
10629
"RTN","ZISHGUX",54,0)
10631
"RTN","ZISHGUX",55,0)
10633
"RTN","ZISHGUX",56,0)
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)
10661
"RTN","ZISHGUX",70,0)
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)
10673
"RTN","ZISHGUX",76,0)
10675
"RTN","ZISHGUX",77,0)
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)
10689
"RTN","ZISHGUX",84,0)
10691
"RTN","ZISHGUX",85,0)
10692
S %ZY=$ZSEARCH("*.X") ;Clear vector
10693
"RTN","ZISHGUX",86,0)
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)
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)
10705
"RTN","ZISHGUX",92,0)
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)
10713
"RTN","ZISHGUX",96,0)
10715
"RTN","ZISHGUX",97,0)
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)
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)
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)
10737
"RTN","ZISHGUX",108,0)
10739
"RTN","ZISHGUX",109,0)
10740
PWD() ;ef,SR. Print working directory
10741
"RTN","ZISHGUX",110,0)
10743
"RTN","ZISHGUX",111,0)
10745
"RTN","ZISHGUX",112,0)
10747
"RTN","ZISHGUX",113,0)
10749
"RTN","ZISHGUX",114,0)
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)
10763
"RTN","ZISHGUX",121,0)
10764
. I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
10765
"RTN","ZISHGUX",122,0)
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)
10773
"RTN","ZISHGUX",126,0)
10775
"RTN","ZISHGUX",127,0)
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)
10785
"RTN","ZISHGUX",132,0)
10786
STATUS() ;ef,SR. Return EOF status
10787
"RTN","ZISHGUX",133,0)
10789
"RTN","ZISHGUX",134,0)
10791
"RTN","ZISHGUX",135,0)
10793
"RTN","ZISHGUX",136,0)
10794
EOF(X) ;Eof flag, Pass in $ZA
10795
"RTN","ZISHGUX",137,0)
10797
"RTN","ZISHGUX",138,0)
10799
"RTN","ZISHGUX",139,0)
10801
"RTN","ZISHGUX",140,0)
10802
S:$E(X)'="-" X="-"_X
10803
"RTN","ZISHGUX",141,0)
10805
"RTN","ZISHGUX",142,0)
10807
"RTN","ZISHGUX",143,0)
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)
10817
"RTN","ZISHGUX",148,0)
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)
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)
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)
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)
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)
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)
10879
"RTN","ZISHGUX",179,0)
10880
D CLOSE() ;Normal exit
10881
"RTN","ZISHGUX",180,0)
10883
"RTN","ZISHGUX",181,0)
10885
"RTN","ZISHGUX",182,0)
10886
ERREOF D CLOSE() ;Got error Reading file
10887
"RTN","ZISHGUX",183,0)
10889
"RTN","ZISHGUX",184,0)
10891
"RTN","ZISHGUX",185,0)
10893
"RTN","ZISHGUX",186,0)
10895
"RTN","ZISHGUX",187,0)
10896
U IO R X:2 S %ZA=$ZEOF,REC=$E(X,1,255)
10897
"RTN","ZISHGUX",188,0)
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)
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)
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)
10921
"RTN","ZISHGUX",200,0)
10923
"RTN","ZISHGUX",201,0)
10924
GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file.
10925
"RTN","ZISHGUX",202,0)
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)
10935
"RTN","ZISHGUX",207,0)
10937
"RTN","ZISHGUX",208,0)
10938
S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"A")
10939
"RTN","ZISHGUX",209,0)
10941
"RTN","ZISHGUX",210,0)
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)
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)
10961
"RTN","ZISHGUX",220,0)
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)
10971
"RTN","ZISHGUX",225,0)
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)
10981
"RTN","ZISTCPS",4,0)
10983
"RTN","ZISTCPS",5,0)
10984
CLOSE ;Close and reset
10985
"RTN","ZISTCPS",6,0)
10987
"RTN","ZISTCPS",7,0)
10989
"RTN","ZISTCPS",8,0)
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)
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)
11011
"RTN","ZISTCPS",19,0)
11013
"RTN","ZISTCPS",20,0)
11015
"RTN","ZISTCPS",21,0)
11016
LONT ;Open port in Accept mode with standard terminators.
11017
"RTN","ZISTCPS",22,0)
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)
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)
11039
"RTN","ZISTCPS",33,0)
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)
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)
11055
"RTN","ZISTCPS",41,0)
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)
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)
11077
"RTN","ZISTCPS",52,0)
11079
"RTN","ZISTCPS",53,0)
11080
S POP=1,EXIT=1,IO("ERROR")=$ECODE,$ECODE=""
11081
"RTN","ZISTCPS",54,0)
11083
"RTN","ZISTCPS",55,0)
11084
EXIT() ;See if time to exit
11085
"RTN","ZISTCPS",56,0)
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)
11093
"RTN","ZISTCPS",60,0)
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)
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)
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)
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)
11133
"RTN","ZISTCPS",80,0)
11135
"RTN","ZISTCPS",81,0)
11137
"RTN","ZISTCPS",82,0)
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)
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)
11151
"RTN","ZISTCPS",89,0)
11152
;Find file descriptor
11153
"RTN","ZISTCPS",90,0)
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)
11177
"RTN","ZISTCPS",102,0)
11179
"RTN","ZISTCPS",103,0)
11181
"RTN","ZISTCPS",104,0)
11182
GTMLNCH ;Run gt.m job for this connection.
11183
"RTN","ZISTCPS",105,0)
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)
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)
11209
"RTN","ZISTCPS",118,0)
11211
"RTN","ZISTCPS",119,0)
11213
"RTN","ZISTCPS",120,0)
11214
LOG(MSG) ;LOG STATUS
11215
"RTN","ZISTCPS",121,0)
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)
11221
"RTN","ZISTCPS",124,0)
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)
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)
11245
"RTN","ZOSFGUX",11,0)
11246
OS S ^%ZOSF("OS")="GT.M (Unix)^19"
11247
"RTN","ZOSFGUX",12,0)
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)
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)
11281
"RTN","ZOSFGUX",29,0)
11283
"RTN","ZOSFGUX",30,0)
11285
"RTN","ZOSFGUX",31,0)
11287
"RTN","ZOSFGUX",32,0)
11289
"RTN","ZOSFGUX",33,0)
11290
;;S Y=$$ACTJ^%ZOSV()
11291
"RTN","ZOSFGUX",34,0)
11293
"RTN","ZOSFGUX",35,0)
11294
;;S Y=$$AVJ^%ZOSV()
11295
"RTN","ZOSFGUX",36,0)
11297
"RTN","ZOSFGUX",37,0)
11299
"RTN","ZOSFGUX",38,0)
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)
11305
"RTN","ZOSFGUX",41,0)
11307
"RTN","ZOSFGUX",42,0)
11309
"RTN","ZOSFGUX",43,0)
11311
"RTN","ZOSFGUX",44,0)
11313
"RTN","ZOSFGUX",45,0)
11314
;;S Y=$ZA\1024#2 ; <=====
11315
"RTN","ZOSFGUX",46,0)
11317
"RTN","ZOSFGUX",47,0)
11319
"RTN","ZOSFGUX",48,0)
11321
"RTN","ZOSFGUX",49,0)
11323
"RTN","ZOSFGUX",50,0)
11325
"RTN","ZOSFGUX",51,0)
11327
"RTN","ZOSFGUX",52,0)
11329
"RTN","ZOSFGUX",53,0)
11331
"RTN","ZOSFGUX",54,0)
11333
"RTN","ZOSFGUX",55,0)
11335
"RTN","ZOSFGUX",56,0)
11337
"RTN","ZOSFGUX",57,0)
11338
;;U IO:(NOECHO) ; <=====
11339
"RTN","ZOSFGUX",58,0)
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)
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)
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)
11353
"RTN","ZOSFGUX",65,0)
11355
"RTN","ZOSFGUX",66,0)
11357
"RTN","ZOSFGUX",67,0)
11359
"RTN","ZOSFGUX",68,0)
11361
"RTN","ZOSFGUX",69,0)
11362
;;S Y=$ZA\32#2 ; <=====
11363
"RTN","ZOSFGUX",70,0)
11365
"RTN","ZOSFGUX",71,0)
11366
;;S Y=$ZA\32768#2 ; <=====
11367
"RTN","ZOSFGUX",72,0)
11369
"RTN","ZOSFGUX",73,0)
11370
;;S Y=$ZA\64#2 ; <=====
11371
"RTN","ZOSFGUX",74,0)
11373
"RTN","ZOSFGUX",75,0)
11374
;;S Y=$ZA\4#2 ; <=====
11375
"RTN","ZOSFGUX",76,0)
11377
"RTN","ZOSFGUX",77,0)
11379
"RTN","ZOSFGUX",78,0)
11381
"RTN","ZOSFGUX",79,0)
11382
;;U $I:(NOPASSTHRU)
11383
"RTN","ZOSFGUX",80,0)
11385
"RTN","ZOSFGUX",81,0)
11386
;;U $I:(NOTYPEAHEAD)
11387
"RTN","ZOSFGUX",82,0)
11389
"RTN","ZOSFGUX",83,0)
11391
"RTN","ZOSFGUX",84,0)
11393
"RTN","ZOSFGUX",85,0)
11394
;;S Y=$$PRIINQ^%ZOSV()
11395
"RTN","ZOSFGUX",86,0)
11397
"RTN","ZOSFGUX",87,0)
11398
;;Q ;G PRIORITY^%ZOSV
11399
"RTN","ZOSFGUX",88,0)
11401
"RTN","ZOSFGUX",89,0)
11403
"RTN","ZOSFGUX",90,0)
11405
"RTN","ZOSFGUX",91,0)
11406
;;S Y=$$PROGMODE^%ZOSV()
11407
"RTN","ZOSFGUX",92,0)
11409
"RTN","ZOSFGUX",93,0)
11411
"RTN","ZOSFGUX",94,0)
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)
11417
"RTN","ZOSFGUX",97,0)
11418
;;U $I:WIDTH=$S('X:9999,1:X)
11419
"RTN","ZOSFGUX",98,0)
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)
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)
11429
"RTN","ZOSFGUX",103,0)
11431
"RTN","ZOSFGUX",104,0)
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)
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)
11441
"RTN","ZOSFGUX",109,0)
11442
;;I X]"",$T(^@X)]""
11443
"RTN","ZOSFGUX",110,0)
11445
"RTN","ZOSFGUX",111,0)
11447
"RTN","ZOSFGUX",112,0)
11449
"RTN","ZOSFGUX",113,0)
11451
"RTN","ZOSFGUX",114,0)
11453
"RTN","ZOSFGUX",115,0)
11455
"RTN","ZOSFGUX",116,0)
11457
"RTN","ZOSFGUX",117,0)
11458
;;U $I:(TERMINATOR="")
11459
"RTN","ZOSFGUX",118,0)
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)
11465
"RTN","ZOSFGUX",121,0)
11467
"RTN","ZOSFGUX",122,0)
11469
"RTN","ZOSFGUX",123,0)
11471
"RTN","ZOSFGUX",124,0)
11473
"RTN","ZOSFGUX",125,0)
11474
;;S Y=^%ZOSF("PROD")
11475
"RTN","ZOSFGUX",126,0)
11477
"RTN","ZOSFGUX",127,0)
11479
"RTN","ZOSFGUX",128,0)
11481
"RTN","ZOSFGUX",129,0)
11482
;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
11483
"RTN","ZOSFGUX",130,0)
11485
"RTN","ZOSFGUX",131,0)
11486
;;S $X=DX,$Y=DY ; <=====
11487
"RTN","ZOSFGUX",132,0)
11489
"RTN","ZOSFGUX",133,0)
11491
"RTN","ZOSFGUX",134,0)
11493
"RTN","ZOSFGUX",135,0)
11494
;;S Y=$$HTE^XLFDT(X,2) I $L($P(Y,"/"))=1 S Y=0_Y
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)
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)
11523
"RTN","ZOSV2GTM",14,0)
11525
"RTN","ZOSV2GTM",15,0)
11527
"RTN","ZOSV2GTM",16,0)
11529
"RTN","ZOSV2GTM",17,0)
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)
11539
"RTN","ZOSV2GTM",22,0)
11541
"RTN","ZOSV2GTM",23,0)
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)
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)
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)
11589
"RTN","ZOSV2GTM",47,0)
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)
11603
"RTN","ZOSV2GTM",54,0)
11605
"RTN","ZOSV2GTM",55,0)
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)
11619
"RTN","ZOSV2GTM",62,0)
11621
"RTN","ZOSV2GTM",63,0)
11623
"RTN","ZOSV2GTM",64,0)
11624
TEST(RN) ;Special GT.M Test to see if routine is here.
11625
"RTN","ZOSV2GTM",65,0)
11627
"RTN","ZOSV2GTM",66,0)
11629
"RTN","ZOSV2GTM",67,0)
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)
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)
11651
"RTN","ZOSVGUX",10,0)
11653
"RTN","ZOSVGUX",11,0)
11655
"RTN","ZOSVGUX",12,0)
11657
"RTN","ZOSVGUX",13,0)
11658
F Q:$E(Y)'=" " S $E(Y)=""
11659
"RTN","ZOSVGUX",14,0)
11661
"RTN","ZOSVGUX",15,0)
11663
"RTN","ZOSVGUX",16,0)
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)
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)
11689
"RTN","ZOSVGUX",29,0)
11691
"RTN","ZOSVGUX",30,0)
11692
U $I:(PASTHRU) Q ; <=====
11693
"RTN","ZOSVGUX",31,0)
11695
"RTN","ZOSVGUX",32,0)
11696
U $I:(NOPASTHRU) Q ; <=====
11697
"RTN","ZOSVGUX",33,0)
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)
11705
"RTN","ZOSVGUX",37,0)
11706
LOG(MSG,PRIORITY,TAG)
11707
"RTN","ZOSVGUX",38,0)
11709
"RTN","ZOSVGUX",39,0)
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)
11721
"RTN","ZOSVGUX",45,0)
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)
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)
11751
"RTN","ZOSVGUX",60,0)
11753
"RTN","ZOSVGUX",61,0)
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)
11761
"RTN","ZOSVGUX",65,0)
11763
"RTN","ZOSVGUX",66,0)
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)
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)
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)
11787
"RTN","ZOSVGUX",78,0)
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)
11797
"RTN","ZOSVGUX",83,0)
11799
"RTN","ZOSVGUX",84,0)
11801
"RTN","ZOSVGUX",85,0)
11802
; W STATUS,! ; Comment this back in to see what went wrong
11803
"RTN","ZOSVGUX",86,0)
11805
"RTN","ZOSVGUX",87,0)
11807
"RTN","ZOSVGUX",88,0)
11808
S Y=^%ZOSF("PROD") Q
11809
"RTN","ZOSVGUX",89,0)
11811
"RTN","ZOSVGUX",90,0)
11813
"RTN","ZOSVGUX",91,0)
11815
"RTN","ZOSVGUX",92,0)
11817
"RTN","ZOSVGUX",93,0)
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)
11833
"RTN","ZOSVGUX",101,0)
11835
"RTN","ZOSVGUX",102,0)
11837
"RTN","ZOSVGUX",103,0)
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)
11843
"RTN","ZOSVGUX",106,0)
11845
"RTN","ZOSVGUX",107,0)
11847
"RTN","ZOSVGUX",108,0)
11848
Q 5 ; for now, we're always middle of the road
11849
"RTN","ZOSVGUX",109,0)
11851
"RTN","ZOSVGUX",110,0)
11852
BAUD S X="UNKNOWN" Q
11853
"RTN","ZOSVGUX",111,0)
11855
"RTN","ZOSVGUX",112,0)
11856
LGR() ; Last global reference ($REFERENCE)
11857
"RTN","ZOSVGUX",113,0)
11859
"RTN","ZOSVGUX",114,0)
11861
"RTN","ZOSVGUX",115,0)
11862
EC() ; Error Code: returning $ZS in format more like $ZE from DSM
11863
"RTN","ZOSVGUX",116,0)
11865
"RTN","ZOSVGUX",117,0)
11867
"RTN","ZOSVGUX",118,0)
11868
S %ZE=$P($ZS,",",2)_","_$P($ZS,",",4)_","_$P($ZS,",")_",-"_$P($ZS,",",3)
11869
"RTN","ZOSVGUX",119,0)
11871
"RTN","ZOSVGUX",120,0)
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)
11883
"RTN","ZOSVGUX",126,0)
11885
"RTN","ZOSVGUX",127,0)
11886
ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X
11887
"RTN","ZOSVGUX",128,0)
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)
11897
"RTN","ZOSVGUX",133,0)
11899
"RTN","ZOSVGUX",134,0)
11901
"RTN","ZOSVGUX",135,0)
11903
"RTN","ZOSVGUX",136,0)
11905
"RTN","ZOSVGUX",137,0)
11907
"RTN","ZOSVGUX",138,0)
11909
"RTN","ZOSVGUX",139,0)
11911
"RTN","ZOSVGUX",140,0)
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)
11925
"RTN","ZOSVGUX",147,0)
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)
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)
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)
11945
"RTN","ZOSVGUX",157,0)
11947
"RTN","ZOSVGUX",158,0)
11949
"RTN","ZOSVGUX",159,0)
11951
"RTN","ZOSVGUX",160,0)
11952
S J1(1)=$ZROUTINES,J1(1)=$P(J1(1)," ")
11953
"RTN","ZOSVGUX",161,0)
11955
"RTN","ZOSVGUX",162,0)
11956
Q "1~"_J1(1)_T_J1(2)
11957
"RTN","ZOSVGUX",163,0)
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)
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)
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)
11983
"RTN","ZOSVGUX",176,0)
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)
11997
"RTN","ZOSVGUX",183,0)
11999
"RTN","ZOSVGUX",184,0)
12000
SETTRM(X) ;Turn on specified terminators.
12001
"RTN","ZOSVGUX",185,0)
12003
"RTN","ZOSVGUX",186,0)
12005
"RTN","ZOSVGUX",187,0)
12007
"RTN","ZOSVGUX",188,0)
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)
12023
"RTN","ZOSVGUX",196,0)
12024
I $G(X1)="RES" G RESOK^%ZIS6
12025
"RTN","ZOSVGUX",197,0)
12027
"RTN","ZOSVGUX",198,0)
12028
Q ;Let ZIS deal with it.
12029
"RTN","ZOSVGUX",199,0)
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)
12037
"RTN","ZOSVGUX",203,0)
12039
"RTN","ZOSVGUX",204,0)
12041
"RTN","ZOSVGUX",205,0)
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)
12049
"RTN","ZOSVGUX",209,0)
12051
"RTN","ZOSVGUX",210,0)
12052
I %X["lsof: status error" S Y=-1 Q
12053
"RTN","ZOSVGUX",211,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)
12059
"RTN","ZOSVGUX",214,0)
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)
12071
"RTN","ZOSVGUX",220,0)
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)
12077
"RTN","ZOSVGUX",223,0)
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)
12083
"RTN","ZOSVGUX",226,0)
12085
"RTN","ZOSVGUX",227,0)
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)
12093
"RTN","ZOSVGUX",231,0)
12095
"RTN","ZOSVGUX",232,0)
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)
12101
"RTN","ZOSVGUX",235,0)
12103
"RTN","ZOSVGUX",236,0)
12105
"RTN","ZOSVGUX",237,0)
12106
RETURN(%COMMAND) ; ** Private Entry Point: execute a shell command & return the resulting value **
12107
"RTN","ZOSVGUX",238,0)
12109
"RTN","ZOSVGUX",239,0)
12110
; %COMMAND is the string value of the Linux command
12111
"RTN","ZOSVGUX",240,0)
12113
"RTN","ZOSVGUX",241,0)
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)
12121
"RTN","ZOSVGUX",245,0)
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)
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)
12139
"RTN","ZOSVGUX",254,0)
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)
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)
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)
12165
"RTN","ZOSVONT",12,0)
12167
"RTN","ZOSVONT",13,0)
12169
"RTN","ZOSVONT",14,0)
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)
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)
12193
"RTN","ZOSVONT",26,0)
12195
"RTN","ZOSVONT",27,0)
12197
"RTN","ZOSVONT",28,0)
12199
"RTN","ZOSVONT",29,0)
12201
"RTN","ZOSVONT",30,0)
12203
"RTN","ZOSVONT",31,0)
12204
S Y=$ZU(5)_","_^%ZOSF("VOL") Q
12205
"RTN","ZOSVONT",32,0)
12207
"RTN","ZOSVONT",33,0)
12208
UCICHECK(X) ;Check if valid UCI
12209
"RTN","ZOSVONT",34,0)
12211
"RTN","ZOSVONT",35,0)
12212
S %=$P(X,",",1),Y=0 I $ZU(90,10,%) S Y=%
12213
"RTN","ZOSVONT",36,0)
12215
"RTN","ZOSVONT",37,0)
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)
12227
"RTN","ZOSVONT",43,0)
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)
12243
"RTN","ZOSVONT",51,0)
12245
"RTN","ZOSVONT",52,0)
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)
12255
"RTN","ZOSVONT",57,0)
12257
"RTN","ZOSVONT",58,0)
12259
"RTN","ZOSVONT",59,0)
12260
S Y="$V(0,-2,4)\4096#2" Q
12261
"RTN","ZOSVONT",60,0)
12263
"RTN","ZOSVONT",61,0)
12264
PROGMODE() ;Check if in PROG mode
12265
"RTN","ZOSVONT",62,0)
12267
"RTN","ZOSVONT",63,0)
12269
"RTN","ZOSVONT",64,0)
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)
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)
12287
"RTN","ZOSVONT",73,0)
12289
"RTN","ZOSVONT",74,0)
12290
EC() Q $ZE ;Error code
12291
"RTN","ZOSVONT",75,0)
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)
12299
"RTN","ZOSVONT",79,0)
12301
"RTN","ZOSVONT",80,0)
12302
ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X
12303
"RTN","ZOSVONT",81,0)
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)
12313
"RTN","ZOSVONT",86,0)
12315
"RTN","ZOSVONT",87,0)
12317
"RTN","ZOSVONT",88,0)
12319
"RTN","ZOSVONT",89,0)
12321
"RTN","ZOSVONT",90,0)
12323
"RTN","ZOSVONT",91,0)
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)
12331
"RTN","ZOSVONT",95,0)
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)
12347
"RTN","ZOSVONT",103,0)
12349
"RTN","ZOSVONT",104,0)
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)
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)
12359
"RTN","ZOSVONT",109,0)
12361
"RTN","ZOSVONT",110,0)
12362
OPNERR S $EC="",Y=-1 Q
12363
"RTN","ZOSVONT",111,0)
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)
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)
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)
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)
12397
"RTN","ZOSVONT",128,0)
12399
"RTN","ZOSVONT",129,0)
12400
SID() ;System ID Ver 1
12401
"RTN","ZOSVONT",130,0)
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)
12411
"RTN","ZOSVONT",135,0)
12413
"RTN","ZOSVONT",136,0)
12414
HFSREW(IO,IOPAR) ;Rewind Host File.
12415
"RTN","ZOSVONT",137,0)
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)
12421
"RTN","ZOSVONT",140,0)
12422
HFSRWERR ;Error encountered
12423
"RTN","ZOSVONT",141,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)
12435
"RTN","ZOSVONT",147,0)
12436
SETTRM(X) ;Turn on specified terminators.
12437
"RTN","ZOSVONT",148,0)
12439
"RTN","ZOSVONT",149,0)
12441
"RTN","ZOSVONT",150,0)
12443
"RTN","ZOSVONT",151,0)
12444
T0 ; start RT clock
12445
"RTN","ZOSVONT",152,0)
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
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)
12459
"RTN","ZSSGUX",4,0)
12460
ALL D ALL^MSCZJOBS Q
12461
"RTN","ZSSGUX",5,0)
12462
THIS D THIS^MSCZJOBS Q
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)
12473
"RTN","ZSTARTGUX",5,0)
12475
"RTN","ZSTARTGUX",6,0)
12477
"RTN","ZSTARTGUX",7,0)
12479
"RTN","ZSTARTGUX",8,0)
12481
"RTN","ZSTARTGUX",9,0)
12483
"RTN","ZSTARTGUX",10,0)
12484
TASKMAN ;Start TaskMan
12485
"RTN","ZSTARTGUX",11,0)
12487
"RTN","ZSTARTGUX",12,0)
12488
I %ZTY=0 D START^ZTMB
12489
"RTN","ZSTARTGUX",13,0)
12491
"RTN","ZSTARTGUX",14,0)
12493
"RTN","ZSTARTGUX",15,0)
12494
RPC ;Start the RPC Broker
12495
"RTN","ZSTARTGUX",16,0)
12497
"RTN","ZSTARTGUX",17,0)
12499
"RTN","ZSTARTGUX",18,0)
12501
"RTN","ZSTARTGUX",19,0)
12502
MAILMAN ;Start Mailman
12503
"RTN","ZSTARTGUX",20,0)
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)
12513
"RTN","ZSTOPGUX",4,0)
12515
"RTN","ZSTOPGUX",5,0)
12517
"RTN","ZSTOPGUX",6,0)
12519
"RTN","ZSTOPGUX",7,0)
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)
12531
"RTN","ZSTOPGUX",13,0)
12533
"RTN","ZSTOPGUX",14,0)
12534
RPC ;Stop the RPC Broker
12535
"RTN","ZSTOPGUX",15,0)
12537
"RTN","ZSTOPGUX",16,0)
12539
"RTN","ZSTOPGUX",17,0)
12544
%ZTER ; ISC-SF.SEA/JLI MSC/RHL/JDS - KERNEL ERROR TRAP TO LOG ERRORS ;01MAY2009
12546
;;8.0;KERNEL;**8,18,32,24,36,63,73,79,86,112,118,162,275,392,MSC**;JUL 10, 1995;Build 5
12548
S ^TMP("$ZE",$J,1)=$$LGR^%ZOSV
12550
S ^TMP("$ZE",$J,0)=$$EC^%ZOSV ;$S(^%ZOSF("OS")["GT.M":$ZS,1:$ZE)
12552
S ^TMP("$ZE",$J,2)=$ETRAP,$ETRAP="D ERR^%ZTER"
12554
I (^TMP("$ZE",$J,0)["-ALLOC,")!(^TMP("$ZE",$J,0)["<STORE>")!(^TMP("$ZE",$J,0)["-MEMORY") D
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)
12560
. S %ZTER12A="ALLOC"
12564
S %ZTERZE=^TMP("$ZE",$J,0),%ZT("^XUTL(""XQ"",$J)")="" S:'$D(%ZTERLGR) %ZTERLGR=^TMP("$ZE",$J,1)
12566
G:$$SCREEN(%ZTERZE,1) EXIT ;Let site screen errors, count don't show
12570
S %ZTERH1=+$H L +^%ZTER(1,%ZTERH1,0):15
12572
S %ZTER11N=$P($G(^%ZTER(1,%ZTERH1,0)),"^",2)+1,^%ZTER(1,%ZTERH1,0)=%ZTERH1_"^"_%ZTER11N,^(1,0)="^3.0751^"_%ZTER11N_"^"_%ZTER11N
12574
I %ZTER11N=1 S ^%ZTER(1,0)=$P(^%ZTER(1,0),"^",1,2)_"^"_%ZTERH1_"^"_($P(^%ZTER(1,0),"^",4)+1)
12576
L -^%ZTER(1,%ZTERH1,0)
12578
S %ZTERRT=$NA(^%ZTER(1,%ZTERH1,1,%ZTER11N))
12580
S @%ZTERRT@(0)=%ZTER11N,^("ZE")=%ZTERZE S:$D(%ZTERLGR) ^("GR")=%ZTERLGR K %ZTERLGR
12586
I ^%ZOSF("OS")["DSM"!(^%ZOSF("OS")["GT.M") D
12588
. Q:'$L($ZB) ; rhl/medsphere 20070518
12590
. F %ZTER11I=1:1:$L($ZB) S %ZTER11A=$E($ZB,%ZTER11I),%ZTER11B=$G(%ZTER11B)_$S(%ZTER11A?1C:$A(%ZTER11A),1:%ZTER11A)_","
12592
. S %ZTER11B=$E(%ZTER11B,1,$L(%ZTER11B)-1)
12596
S:'$D(%ZTER11B) %ZTER11B=$ZB
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
12600
S @%ZTERRT@("H")=$H,^("J")=$J_"^^^"_%ZTER11I_"^"_$J
12602
S @%ZTERRT@("I")=$I_"^"_$ZA_"^"_%ZTER11B_"^"_$G(IO("ZIO"))_"^"_$X_"^"_$Y_"^"_$P
12608
D STACK^%ZTER1 ;Save Special Variables
12610
D SAVE("$X $Y",$X_" "_$Y)
12612
I ^%ZOSF("OS")["OpenM" D
12614
. X "D SAVE(""$ZU(56,2)"",$ZU(56,2))"
12616
. I $ZV["VMS" S $P(@%ZTERRT@("J"),"^",2,3)=$ZF("GETJPI",$J,"PRCNAM")_"^"_$ZF("GETJPI",$J,"USERNAME")
12620
;End Special Variables
12622
I ^%ZOSF("OS")["VAX DSM" K %ZTER11A,%ZTER11B D VXD^%ZTER1 I 1
12626
. S %ZTERVAR="%" D:$D(%) VAR:$D(%)#2,SUBS:$D(%)>9
12628
. F %ZTER11Z=0:0 S %ZTERVAR=$O(@%ZTERVAR) Q:%ZTERVAR="" D VAR:$D(@%ZTERVAR)#2,SUBS:$D(@%ZTERVAR)>9
12632
S:%ZTERCNT>0 @%ZTERRT@("ZV",0)="^3.0752^"_%ZTERCNT_"^"_%ZTERCNT
12634
S:'$D(^%ZTER(1,"B",%ZTERH1)) ^(%ZTERH1,%ZTERH1)=""
12636
S ^%ZTER(1,%ZTERH1,1,"B",%ZTER11N,%ZTER11N)=""
12638
LIN ;Find the line of the error
12640
S %ZTERY=$P(%ZTERZE,","),%ZTERX=$P(%ZTERY,"^") S:%ZTERX[">" %ZTERX=$P(%ZTERX,">",2)
12644
. N X,XCNP,DIF K ^TMP($J,"XTER1")
12646
. S X=$P($P(%ZTERY,"^",2),":") Q:X="" X ^%ZOSF("TEST") Q:'$T
12648
. S XCNP=0,DIF="^TMP($J,""XTER1""," X ^%ZOSF("LOAD") S %ZTERY=$P(%ZTERX,"+",1)
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
12652
. I %ZTERY="" S X=+$P(%ZTERX,"+",2) Q:X'>0 S %ZTZLIN=$G(^TMP($J,"XTER1",X,0))
12656
S:$D(%ZTZLIN) @%ZTERRT@("LINE")=%ZTZLIN K %ZTZLIN
12658
I %ZTERROR'="",$D(^%ZTER(2,"B",%ZTERROR)) S %ZTERROR=%ZTERROR_"^"_$P(^%ZTER(2,+$O(^(%ZTERROR,0)),0),"^",2)
12662
I $G(%ZTER12A)["ALLOC" HALT ;Don't allow job to go on.
12664
S $EC="",$ET=$G(^TMP("$ZE",$J,2))
12668
K %ZTER11A,%ZTER11B,%ZTERCNT,%ZTER11S,%ZTER11Z,%ZTERVAP,%ZTERVAR,%ZTERSUB,%ZTER11I,%ZTER11D,%ZTER11L,%ZTER11Q,%,%ZTER111,%ZTER112,%ZTER11N
12676
VAR I "%ZTER"'=$E(%ZTERVAR,1,5) D SAVE(%ZTERVAR,@%ZTERVAR) Q
12678
S %ZTERCNT=%ZTERCNT+1,@%ZTERRT@("ZV",%ZTERCNT,0)=%ZTERVAR D
12680
. I $L(@%ZTERVAR)'>255 S @%ZTERRT@("ZV",%ZTERCNT,"D")=@%ZTERVAR Q
12682
. S @%ZTERRT@("ZV",%ZTERCNT,"D")=" **** VALUE IS GREATER THAN 255 CHARACTERS (SEE SUBNODES FOR DATA) *** "
12684
. N %ZTER11,%ZTER12
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
12694
SAVE(%n,%v) ;Save name and value into global, use special variables
12696
S %ZTERCNT=%ZTERCNT+1,@%ZTERRT@("ZV",%ZTERCNT,0)=%n
12698
I $L(%v)<256 S @%ZTERRT@("ZV",%ZTERCNT,"D")=%v Q
12700
;Variable too long for global node
12702
S @%ZTERRT@("ZV",%ZTERCNT,"D")=$E(%v,1,255),^("L")=$L(%v)
12704
N %i S %v=$E(%v,256,$L(%v))
12706
F %i=1:1 Q:'$L(%v) S @%ZTERRT@("ZV",%ZTERCNT,"D",%i)=$E(%v,1,255),%v=$E(%v,256,$L(%v))
12712
SUBS S %ZTER11S="" Q:"%ZT("=$E(%ZTERVAR,1,4) Q:",%ZTER11S,%ZTER11L,"[(","_%ZTERVAR_",") S %ZTERVAP=%ZTERVAR_"(",%ZTERSUB="%ZTER11S)"
12716
S %ZTER11S=%ZTERVAR
12718
F S %ZTER11S=$Q(@%ZTER11S) Q:%ZTER11S="" D SAVE(%ZTER11S,@%ZTER11S)
12724
GLOB ; save off a list of global subtrees, %ZT is passed in subscripted by name
12726
; %ZTERCNT passed in to count the nodes we traverse
12728
; %ZTERNOD the nodes through which we $QUERY
12730
; %ZTERNAM the names of the global subtrees we're saving
12732
; %ZTEROPN is %ZTERNAM, evaluated, without close paren for $PIECEing
12734
N %ZTERNOD,%ZTERNAM,%ZTEROPN
12736
S %ZTERNAM="" ; the names of the global subtrees we're saving
12738
F S %ZTERNAM=$O(%ZT(%ZTERNAM)) Q:%ZTERNAM="" D
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)
12755
"RTN","ZTER",107,0)
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)
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)
12771
"RTN","ZTER",115,0)
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)
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)
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)
12795
"RTN","ZTER",127,0)
12797
"RTN","ZTER",128,0)
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)
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)
12815
"RTN","ZTER",137,0)
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)
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)
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)
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)
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)
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)
12865
"RTN","ZTMGRSET",18,0)
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)
12873
"RTN","ZTMGRSET",22,0)
12875
"RTN","ZTMGRSET",23,0)
12877
"RTN","ZTMGRSET",24,0)
12878
OS() ;Select the OS
12879
"RTN","ZTMGRSET",25,0)
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)
12899
"RTN","ZTMGRSET",35,0)
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)
12909
"RTN","ZTMGRSET",40,0)
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)
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)
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)
12929
"RTN","ZTMGRSET",50,0)
12931
"RTN","ZTMGRSET",51,0)
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)
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)
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)
12953
"RTN","ZTMGRSET",62,0)
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)
12965
"RTN","ZTMGRSET",68,0)
12967
"RTN","ZTMGRSET",69,0)
12969
"RTN","ZTMGRSET",70,0)
12971
"RTN","ZTMGRSET",71,0)
12972
S %S="ZTER^ZTER1",%D="%ZTER^%ZTER1"
12973
"RTN","ZTMGRSET",72,0)
12975
"RTN","ZTMGRSET",73,0)
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)
12983
"RTN","ZTMGRSET",77,0)
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)
12991
"RTN","ZTMGRSET",81,0)
12993
"RTN","ZTMGRSET",82,0)
12994
RUM ;Build the routines for Capacity Management (CM)
12995
"RTN","ZTMGRSET",83,0)
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)
13009
"RTN","ZTMGRSET",90,0)
13011
"RTN","ZTMGRSET",91,0)
13013
"RTN","ZTMGRSET",92,0)
13014
X SCR I $T W ! D @(U_X) W !
13015
"RTN","ZTMGRSET",93,0)
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)
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)
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)
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)
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)
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)
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)
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)
13069
"RTN","ZTMGRSET",120,0)
13071
"RTN","ZTMGRSET",121,0)
13072
S %S="ZOSVMSQ^ZTBKCMSQ^ZIS4MSQ^ZISFMSQ^ZISHMSQ^XUCIMSQ^ZISETMSQ"
13073
"RTN","ZTMGRSET",122,0)
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)
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)
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)
13093
"RTN","ZTMGRSET",132,0)
13095
"RTN","ZTMGRSET",133,0)
13096
S %S="ZOSVGTM^ZTBKCGTM^ZIS4GTM^ZISFGTM^ZISHGTM^XUCIGTM^ZISETGTM"
13097
"RTN","ZTMGRSET",134,0)
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)
13105
"RTN","ZTMGRSET",138,0)
13107
"RTN","ZTMGRSET",139,0)
13108
S %S="ZOSVGUX^ZBBKCGUZ^ZIS4GTM^ZISFGTM^ZISHGUX^XUCIGTM^ZISETUP" ;ZISETGUX^ZTBKCGUX
13109
"RTN","ZTMGRSET",140,0)
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)
13117
"RTN","ZTMGRSET",144,0)
13119
"RTN","ZTMGRSET",145,0)
13121
"RTN","ZTMGRSET",146,0)
13123
"RTN","ZTMGRSET",147,0)
13124
MOVE ; rename % routines
13125
"RTN","ZTMGRSET",148,0)
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)
13139
"RTN","ZTMGRSET",155,0)
13140
. W ?20," Loaded, "
13141
"RTN","ZTMGRSET",156,0)
13143
"RTN","ZTMGRSET",157,0)
13144
. W ?20,"Saved as ",Y
13145
"RTN","ZTMGRSET",158,0)
13147
"RTN","ZTMGRSET",159,0)
13149
"RTN","ZTMGRSET",160,0)
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)
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)
13169
"RTN","ZTMGRSET",170,0)
13170
N %ZR D SILENT^%RSEL(FROM) S SRC=%ZR(FROM)_FROM_".m"
13171
"RTN","ZTMGRSET",171,0)
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)
13179
"RTN","ZTMGRSET",175,0)
13181
"RTN","ZTMGRSET",176,0)
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)
13191
"RTN","ZTMGRSET",181,0)
13193
"RTN","ZTMGRSET",182,0)
13194
DES S %D="%ZOSV^%ZTBKC1^%ZIS4^%ZISF^%ZISH^%XUCI^ZISETUP" Q
13195
"RTN","ZTMGRSET",183,0)
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)
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)
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)
13227
"RTN","ZTMGRSET",199,0)
13228
POSTGTM ;postinit for GTM
13229
"RTN","ZTMGRSET",200,0)
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)
13246
ZU ;SF/JLI,RWF MSC/JDS,JKT- For GT.M, TIE ALL TERMINALS TO THIS ROUTINE!! ;25JUN2009
13248
;;8.0;KERNEL;**275,MSC**;Jul 10, 1995
13250
; for GT.M for VMS & Unix, version 4.3
13254
;The env var ZINTRRUPT should be set to catch all interrupts.
13256
EN ;See that escape processing is off, Conflict with Screenman
13258
U $P:(NOCENABLE:NOESCAPE)
13260
D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGIN$")
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)
13267
"RTN","ZUGTM",12,0)
13269
"RTN","ZUGTM",13,0)
13271
"RTN","ZUGTM",14,0)
13272
G ;Entry point for GUI device.
13273
"RTN","ZUGTM",15,0)
13275
"RTN","ZUGTM",16,0)
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)
13285
"RTN","ZUGTM",21,0)
13286
ERR2 S $ETRAP="D UNWIND^ZU" L U $P:NOCENABLE
13287
"RTN","ZUGTM",22,0)
13289
"RTN","ZUGTM",23,0)
13291
"RTN","ZUGTM",24,0)
13292
I $P($ZS,",",2,3)["^XUS1A:2, %GTM-E-IOWRITERR" G HALT
13293
"RTN","ZUGTM",25,0)
13295
"RTN","ZUGTM",26,0)
13296
I $G(IO)]"",$D(IO(1,IO)),$E($G(IOST))="P" D
13297
"RTN","ZUGTM",27,0)
13299
"RTN","ZUGTM",28,0)
13300
. W @$S($D(IOF):IOF,1:"#")
13301
"RTN","ZUGTM",29,0)
13303
"RTN","ZUGTM",30,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)
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)
13317
"RTN","ZUGTM",37,0)
13318
D ^%ZTER K %ZT S XUERF="" ; Capture symbol table first!
13319
"RTN","ZUGTM",38,0)
13321
"RTN","ZUGTM",39,0)
13322
I $G(DUZ)'>0 G HALT
13323
"RTN","ZUGTM",40,0)
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)
13335
"RTN","ZUGTM",46,0)
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)
13343
"RTN","ZUGTM",50,0)
13345
"RTN","ZUGTM",51,0)
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)
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)
13363
"RTN","ZUGTM",60,0)
13364
HALT I $D(^XUTL("XQ",$J)) D:$G(DUZ)>0 BYE^XUSCLEAN
13365
"RTN","ZUGTM",61,0)
13367
"RTN","ZUGTM",62,0)
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)
13377
"RTN","ZUGTM",67,0)
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)
13395
"RTN","ZUGTM",76,0)
13397
"RTN","ZUGTM",77,0)
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)
13417
"RTN","ZUGTM",87,0)