Merge lp:~joel-sher/openvista-gtm-integration/kidsbuild into lp:openvista-gtm-integration

[JSHER]

[JSHER (joel-sher)]

review: Approve

=== added directory 'kids'
=== added file 'kids/MSCZJOB_6.KID'
--- kids/MSCZJOB_6.KID	1970-01-01 00:00:00 +0000
+++ kids/MSCZJOB_6.KID	2009-04-17 17:48:03 +0000
@@ -0,0 +1,6098 @@
+KIDS Distribution saved on Apr 17, 2009@10:21:46
+GTM CHANGES
+**KIDS**:MSCZJOB*0.1*6^
+
+**INSTALL NAME**
+MSCZJOB*0.1*6
+"BLD",6833,0)
+MSCZJOB*0.1*6^^0^3090417^y
+"BLD",6833,1,0)
+^^1^1^3070625^
+"BLD",6833,1,1,0)
+SYSTEM STATUS AND JOBEXAM FOR GT.M
+"BLD",6833,4,0)
+^9.64PA^^
+"BLD",6833,6.3)
+30
+"BLD",6833,"KRN",0)
+^9.67PA^8989.52^19
+"BLD",6833,"KRN",.4,0)
+.4
+"BLD",6833,"KRN",.401,0)
+.401
+"BLD",6833,"KRN",.402,0)
+.402
+"BLD",6833,"KRN",.403,0)
+.403
+"BLD",6833,"KRN",.403,"NM",0)
+^9.68A^2^2
+"BLD",6833,"KRN",.403,"NM",1,0)
+MSCZJOBEXAM    FILE #3.081^3.081^0
+"BLD",6833,"KRN",.403,"NM",2,0)
+MSCZLOCK    FILE #3.081^3.081^0
+"BLD",6833,"KRN",.403,"NM","B","MSCZJOBEXAM    FILE #3.081",1)
+
+"BLD",6833,"KRN",.403,"NM","B","MSCZLOCK    FILE #3.081",2)
+
+"BLD",6833,"KRN",.5,0)
+.5
+"BLD",6833,"KRN",.84,0)
+.84
+"BLD",6833,"KRN",3.6,0)
+3.6
+"BLD",6833,"KRN",3.8,0)
+3.8
+"BLD",6833,"KRN",9.2,0)
+9.2
+"BLD",6833,"KRN",9.8,0)
+9.8
+"BLD",6833,"KRN",9.8,"NM",0)
+^9.68A^25^19
+"BLD",6833,"KRN",9.8,"NM",1,0)
+MSCZJOB^^0^B12797960
+"BLD",6833,"KRN",9.8,"NM",4,0)
+MSCZJOBU^^0^B3546679
+"BLD",6833,"KRN",9.8,"NM",5,0)
+ZIS4GTM^^0^B18414491
+"BLD",6833,"KRN",9.8,"NM",7,0)
+XTER1A^^0^B29045171
+"BLD",6833,"KRN",9.8,"NM",8,0)
+ZU^^0^B9872646
+"BLD",6833,"KRN",9.8,"NM",11,0)
+ZCD^^0^B5581
+"BLD",6833,"KRN",9.8,"NM",13,0)
+ZOSV2GTM^^0^B6700455
+"BLD",6833,"KRN",9.8,"NM",14,0)
+ZOSFGUX^^0^B22117954
+"BLD",6833,"KRN",9.8,"NM",15,0)
+ZISHGUX^^0^B37875330
+"BLD",6833,"KRN",9.8,"NM",16,0)
+HLCSTCP1^^0^B29662559
+"BLD",6833,"KRN",9.8,"NM",17,0)
+HLCSTCP^^0^B32199902
+"BLD",6833,"KRN",9.8,"NM",18,0)
+HLCSLNCH^^0^B37355917
+"BLD",6833,"KRN",9.8,"NM",19,0)
+XOBVLL^^0^B18038185
+"BLD",6833,"KRN",9.8,"NM",20,0)
+XOBVRH^^0^B13028891
+"BLD",6833,"KRN",9.8,"NM",21,0)
+XOBVSKT^^0^B19778790
+"BLD",6833,"KRN",9.8,"NM",22,0)
+XOBVTCPL^^0^B13529543
+"BLD",6833,"KRN",9.8,"NM",23,0)
+XWBTCPM^^0^B56160723
+"BLD",6833,"KRN",9.8,"NM",24,0)
+ZTMGRSET^^0^B48490586
+"BLD",6833,"KRN",9.8,"NM",25,0)
+ZISTCPS^^0^B18372148
+"BLD",6833,"KRN",9.8,"NM","B","HLCSLNCH",18)
+
+"BLD",6833,"KRN",9.8,"NM","B","HLCSTCP",17)
+
+"BLD",6833,"KRN",9.8,"NM","B","HLCSTCP1",16)
+
+"BLD",6833,"KRN",9.8,"NM","B","MSCZJOB",1)
+
+"BLD",6833,"KRN",9.8,"NM","B","MSCZJOBU",4)
+
+"BLD",6833,"KRN",9.8,"NM","B","XOBVLL",19)
+
+"BLD",6833,"KRN",9.8,"NM","B","XOBVRH",20)
+
+"BLD",6833,"KRN",9.8,"NM","B","XOBVSKT",21)
+
+"BLD",6833,"KRN",9.8,"NM","B","XOBVTCPL",22)
+
+"BLD",6833,"KRN",9.8,"NM","B","XTER1A",7)
+
+"BLD",6833,"KRN",9.8,"NM","B","XWBTCPM",23)
+
+"BLD",6833,"KRN",9.8,"NM","B","ZCD",11)
+
+"BLD",6833,"KRN",9.8,"NM","B","ZIS4GTM",5)
+
+"BLD",6833,"KRN",9.8,"NM","B","ZISHGUX",15)
+
+"BLD",6833,"KRN",9.8,"NM","B","ZISTCPS",25)
+
+"BLD",6833,"KRN",9.8,"NM","B","ZOSFGUX",14)
+
+"BLD",6833,"KRN",9.8,"NM","B","ZOSV2GTM",13)
+
+"BLD",6833,"KRN",9.8,"NM","B","ZTMGRSET",24)
+
+"BLD",6833,"KRN",9.8,"NM","B","ZU",8)
+
+"BLD",6833,"KRN",19,0)
+19
+"BLD",6833,"KRN",19,"NM",0)
+^9.68A^2^2
+"BLD",6833,"KRN",19,"NM",1,0)
+MSCZJOB^^0
+"BLD",6833,"KRN",19,"NM",2,0)
+MSCZLOCK^^0
+"BLD",6833,"KRN",19,"NM","B","MSCZJOB",1)
+
+"BLD",6833,"KRN",19,"NM","B","MSCZLOCK",2)
+
+"BLD",6833,"KRN",19.1,0)
+19.1
+"BLD",6833,"KRN",101,0)
+101
+"BLD",6833,"KRN",409.61,0)
+409.61
+"BLD",6833,"KRN",771,0)
+771
+"BLD",6833,"KRN",870,0)
+870
+"BLD",6833,"KRN",8989.51,0)
+8989.51
+"BLD",6833,"KRN",8989.52,0)
+8989.52
+"BLD",6833,"KRN",8994,0)
+8994
+"BLD",6833,"KRN","B",.4,.4)
+
+"BLD",6833,"KRN","B",.401,.401)
+
+"BLD",6833,"KRN","B",.402,.402)
+
+"BLD",6833,"KRN","B",.403,.403)
+
+"BLD",6833,"KRN","B",.5,.5)
+
+"BLD",6833,"KRN","B",.84,.84)
+
+"BLD",6833,"KRN","B",3.6,3.6)
+
+"BLD",6833,"KRN","B",3.8,3.8)
+
+"BLD",6833,"KRN","B",9.2,9.2)
+
+"BLD",6833,"KRN","B",9.8,9.8)
+
+"BLD",6833,"KRN","B",19,19)
+
+"BLD",6833,"KRN","B",19.1,19.1)
+
+"BLD",6833,"KRN","B",101,101)
+
+"BLD",6833,"KRN","B",409.61,409.61)
+
+"BLD",6833,"KRN","B",771,771)
+
+"BLD",6833,"KRN","B",870,870)
+
+"BLD",6833,"KRN","B",8989.51,8989.51)
+
+"BLD",6833,"KRN","B",8989.52,8989.52)
+
+"BLD",6833,"KRN","B",8994,8994)
+
+"BLD",6833,"MSC")
+/home/jsher/MSCZJOB_6.KID
+"BLD",6833,"MSCOM")
+LOCKS ON SEPARATE PAGE, UNLOCK AND KILL IN GTM
+"KRN",.403,116,-1)
+0^1
+"KRN",.403,116,0)
+MSCZJOBEXAM^ ^@^^3070530.1755^^^3.081^0^1^1
+"KRN",.403,116,12)
+
+"KRN",.403,116,21)
+
+"KRN",.403,116,40,0)
+^.4031I^3^3
+"KRN",.403,116,40,1,0)
+1^^1,1^^^1^17,80
+"KRN",.403,116,40,1,1)
+Page 1
+"KRN",.403,116,40,1,40,0)
+^.4032IP^427^2
+"KRN",.403,116,40,1,40,426,0)
+MSCZJOBEXAM^4^3,2^e
+"KRN",.403,116,40,1,40,426,2)
+13^^u^^1
+"KRN",.403,116,40,1,40,426,"COMP MUL")
+D COMPMUL^MSCZJOB
+"KRN",.403,116,40,1,40,426,"COMP MUL PTR")
+
+"KRN",.403,116,40,1,40,427,0)
+MSCZJOBEXAM HDR^1^1,2^d
+"KRN",.403,116,40,2,0)
+2^^1,1^^^1^18,79
+"KRN",.403,116,40,2,1)
+Page 2
+"KRN",.403,116,40,2,40,0)
+^.4032IP^431^3
+"KRN",.403,116,40,2,40,428,0)
+MSCZJOBEXAM 2^1^1,1^e
+"KRN",.403,116,40,2,40,429,0)
+MSCZJOBVARS^3^8,3^e
+"KRN",.403,116,40,2,40,429,2)
+9^^f^^1
+"KRN",.403,116,40,2,40,429,"COMP MUL")
+D COMPVARS^MSCZJOB
+"KRN",.403,116,40,2,40,431,0)
+MSCZJOBSTACK^4^3,3^e
+"KRN",.403,116,40,2,40,431,2)
+3^
+"KRN",.403,116,40,2,40,431,"COMP MUL")
+D COMPSTK^MSCZJOB
+"KRN",.403,116,40,3,0)
+3^^4,4^^^1^15,70
+"KRN",.403,116,40,3,1)
+Page 3
+"KRN",.403,116,40,3,40,0)
+^.4032IP^430^1
+"KRN",.403,116,40,3,40,430,0)
+MSCZJOBLOCKS^1^2,3^e
+"KRN",.403,116,40,3,40,430,2)
+6^
+"KRN",.403,116,40,3,40,430,"COMP MUL")
+D COMPLKS^MSCZJOB
+"KRN",.403,116,21400)
+1
+"KRN",.403,117,-1)
+0^2
+"KRN",.403,117,0)
+MSCZLOCK^ ^@^^3070530.1755^^^3.081^0^1^1
+"KRN",.403,117,40,0)
+^.4031I^1^1
+"KRN",.403,117,40,1,0)
+1^^1,1^^^0^17,80
+"KRN",.403,117,40,1,1)
+Page 1
+"KRN",.403,117,40,1,40,0)
+^.4032IP^433^2
+"KRN",.403,117,40,1,40,432,0)
+MSCZLOCKEXAM^4^3,2^e
+"KRN",.403,117,40,1,40,432,2)
+13^^u^^1
+"KRN",.403,117,40,1,40,432,"COMP MUL")
+D COMPLK^MSCZJOB
+"KRN",.403,117,40,1,40,433,0)
+MSCZJOBLOCK HDR^1^1,1^d
+"KRN",.404,426,0)
+MSCZJOBEXAM^3.081
+"KRN",.404,426,40,0)
+^.4044I^5^5
+"KRN",.404,426,40,1,0)
+1^^2^^JOB NUMBER
+"KRN",.404,426,40,1,2)
+1,2^6
+"KRN",.404,426,40,1,3)
+!M
+"KRN",.404,426,40,1,3.1)
+S Y=$$JOB^MSCZJOB(D0) S:Y=$J Y=Y_"*"
+"KRN",.404,426,40,1,4)
+^^^2
+"KRN",.404,426,40,1,10)
+S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U)
+"KRN",.404,426,40,1,20)
+F
+"KRN",.404,426,40,2,0)
+2^^2^^DEVICE
+"KRN",.404,426,40,2,2)
+1,9^23
+"KRN",.404,426,40,2,3)
+!M
+"KRN",.404,426,40,2,3.1)
+S Y=$$DEV^MSCZJOB(D0)
+"KRN",.404,426,40,2,4)
+^^^1
+"KRN",.404,426,40,2,20)
+F
+"KRN",.404,426,40,3,0)
+4^^2^^NAMESPACE
+"KRN",.404,426,40,3,2)
+1,48^11
+"KRN",.404,426,40,3,3)
+!M
+"KRN",.404,426,40,3,3.1)
+S Y=$$NSP^MSCZJOB(D0)
+"KRN",.404,426,40,3,4)
+^^^1
+"KRN",.404,426,40,3,20)
+F
+"KRN",.404,426,40,4,0)
+5^^2^^ROUTINE
+"KRN",.404,426,40,4,2)
+1,60^18
+"KRN",.404,426,40,4,3)
+!M
+"KRN",.404,426,40,4,3.1)
+S Y=$$ROUTINE^MSCZJOB(D0)
+"KRN",.404,426,40,4,4)
+^^^1
+"KRN",.404,426,40,4,20)
+F^U
+"KRN",.404,426,40,5,0)
+3^^2^^USER
+"KRN",.404,426,40,5,2)
+1,33^14
+"KRN",.404,426,40,5,3)
+!M
+"KRN",.404,426,40,5,3.1)
+S Y=$$USER^MSCZJOB(D0)
+"KRN",.404,426,40,5,4)
+^^^1
+"KRN",.404,426,40,5,20)
+F
+"KRN",.404,427,0)
+MSCZJOBEXAM HDR^3.081^
+"KRN",.404,427,40,0)
+^.4044I^2^2
+"KRN",.404,427,40,1,0)
+1^Process Device                  User           Namespace   Routine      ^1
+"KRN",.404,427,40,1,2)
+^^2,1
+"KRN",.404,427,40,2,0)
+2^!M^1
+"KRN",.404,427,40,2,.1)
+S Y=$$GET1^DIQ(8989.3,1,.01)
+"KRN",.404,427,40,2,2)
+^^1,28
+"KRN",.404,428,0)
+MSCZJOBEXAM 2^3.081
+"KRN",.404,428,40,0)
+^.4044I^7^7
+"KRN",.404,428,40,1,0)
+1^Job^2^^JOB NUMBER
+"KRN",.404,428,40,1,2)
+2,8^6^2,3
+"KRN",.404,428,40,1,3)
+!M
+"KRN",.404,428,40,1,3.1)
+S Y=$$JOB^MSCZJOB(MSCJOBD0)
+"KRN",.404,428,40,1,20)
+N
+"KRN",.404,428,40,2,0)
+2^NSpace^2^^NAMESPACE
+"KRN",.404,428,40,2,2)
+2,24^11^2,16
+"KRN",.404,428,40,2,3)
+!M
+"KRN",.404,428,40,2,3.1)
+S Y=$$NSP^MSCZJOB(MSCJOBD0)
+"KRN",.404,428,40,2,4)
+^^^2
+"KRN",.404,428,40,2,20)
+F
+"KRN",.404,428,40,3,0)
+3^Routine^2
+"KRN",.404,428,40,3,2)
+2,46^16^2,37
+"KRN",.404,428,40,3,3)
+!M
+"KRN",.404,428,40,3,3.1)
+S Y=$$ROUTINE^MSCZJOB(MSCJOBD0)
+"KRN",.404,428,40,3,4)
+^^^2
+"KRN",.404,428,40,3,20)
+F^U
+"KRN",.404,428,40,4,0)
+4^^2^^USER
+"KRN",.404,428,40,4,2)
+2,63^14
+"KRN",.404,428,40,4,3)
+!M
+"KRN",.404,428,40,4,3.1)
+S Y=$$USER^MSCZJOB(MSCJOBD0)
+"KRN",.404,428,40,4,4)
+^^^2
+"KRN",.404,428,40,4,20)
+F
+"KRN",.404,428,40,5,0)
+5^Device^2^^DEVICE
+"KRN",.404,428,40,5,2)
+3,24^38^3,16
+"KRN",.404,428,40,5,3)
+!M
+"KRN",.404,428,40,5,3.1)
+S Y=$$DEV^MSCZJOB(MSCJOBD0)
+"KRN",.404,428,40,5,4)
+^^^1
+"KRN",.404,428,40,5,20)
+F^U
+"KRN",.404,428,40,6,0)
+4.4^LOCKs^2^^LOCKS
+"KRN",.404,428,40,6,2)
+3,10^3^3,3
+"KRN",.404,428,40,6,3)
+!M
+"KRN",.404,428,40,6,3.1)
+S Y=$$LOCKS^MSCZJOB
+"KRN",.404,428,40,6,10)
+S DDSSTACK=3
+"KRN",.404,428,40,6,20)
+N
+"KRN",.404,428,40,7,0)
+6^KILL JOB?^2^^KILL
+"KRN",.404,428,40,7,2)
+3,74^3^3,63
+"KRN",.404,428,40,7,13)
+N X,Y I DDSEXT="YES" D KILL^MSCZJOB(MSCJOBID)
+"KRN",.404,428,40,7,20)
+Y
+"KRN",.404,429,0)
+MSCZJOBVARS^3.081
+"KRN",.404,429,40,0)
+^.4044I^3^3
+"KRN",.404,429,40,1,0)
+1^^2^^VARIABLE NAME
+"KRN",.404,429,40,1,2)
+1,1^24
+"KRN",.404,429,40,1,3)
+!M
+"KRN",.404,429,40,1,3.1)
+S Y=$P(@MSC@(MSCJOBID,"V",D0),"=")
+"KRN",.404,429,40,1,4)
+^^^2
+"KRN",.404,429,40,1,20)
+F
+"KRN",.404,429,40,2,0)
+2^^2^^VALUE OF VARIABLE
+"KRN",.404,429,40,2,2)
+1,28^48
+"KRN",.404,429,40,2,3)
+!M
+"KRN",.404,429,40,2,3.1)
+S Y=$P(@MSC@(MSCJOBID,"V",D0),"=",2,999)
+"KRN",.404,429,40,2,4)
+^^^2
+"KRN",.404,429,40,2,20)
+F^U
+"KRN",.404,429,40,3,0)
+1.5^=^1
+"KRN",.404,429,40,3,2)
+^^1,26
+"KRN",.404,430,0)
+MSCZJOBLOCKS^3.081^
+"KRN",.404,430,40,0)
+^.4044I^2^2
+"KRN",.404,430,40,1,0)
+1^^2^^LOCKS
+"KRN",.404,430,40,1,2)
+2,1^47
+"KRN",.404,430,40,1,3)
+!M
+"KRN",.404,430,40,1,3.1)
+S Y=@MSC@(MSCJOBID,"L",D0)
+"KRN",.404,430,40,1,4)
+^^^2
+"KRN",.404,430,40,1,20)
+F^U
+"KRN",.404,430,40,2,0)
+2^UNLOCK?^2^^UNLOCK
+"KRN",.404,430,40,2,2)
+2,58^3^2,49^1
+"KRN",.404,430,40,2,13)
+I DDSEXT="YES" D UNLOCK^MSCZJOB(D0)
+"KRN",.404,430,40,2,20)
+Y
+"KRN",.404,431,0)
+MSCZJOBSTACK^3.081
+"KRN",.404,431,40,0)
+^.4044I^1^1
+"KRN",.404,431,40,1,0)
+1^^2^^STACK
+"KRN",.404,431,40,1,2)
+2,1^75
+"KRN",.404,431,40,1,3)
+!M
+"KRN",.404,431,40,1,3.1)
+S Y=$$STACK^MSCZJOB(D0)
+"KRN",.404,431,40,1,4)
+^^^2
+"KRN",.404,431,40,1,20)
+F^U
+"KRN",.404,432,0)
+MSCZLOCKEXAM^3.081
+"KRN",.404,432,40,0)
+^.4044I^5^5
+"KRN",.404,432,40,1,0)
+1^^2^^JOB NUMBER
+"KRN",.404,432,40,1,2)
+1,2^6
+"KRN",.404,432,40,1,3)
+!M
+"KRN",.404,432,40,1,3.1)
+S Y=$P($G(MSCZLK(D0)),U,5) S:Y=$J Y=Y_"*"
+"KRN",.404,432,40,1,4)
+^^^2
+"KRN",.404,432,40,1,10)
+S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U)
+"KRN",.404,432,40,1,20)
+F
+"KRN",.404,432,40,2,0)
+2^^2^^LOCK
+"KRN",.404,432,40,2,2)
+1,9^23
+"KRN",.404,432,40,2,3)
+!M
+"KRN",.404,432,40,2,3.1)
+S Y=$TR($P($G(MSCZLK(D0)),U),"~")
+"KRN",.404,432,40,2,4)
+^^^1
+"KRN",.404,432,40,2,20)
+F
+"KRN",.404,432,40,3,0)
+4^^2^^ROUTINE
+"KRN",.404,432,40,3,2)
+1,48^25
+"KRN",.404,432,40,3,3)
+!M
+"KRN",.404,432,40,3,3.1)
+S Y=$TR($P($G(MSCZLK(D0)),U,3),$C(126),U)
+"KRN",.404,432,40,3,4)
+^^^1
+"KRN",.404,432,40,3,20)
+F^U
+"KRN",.404,432,40,4,0)
+5^^2^^UNLOCK
+"KRN",.404,432,40,4,2)
+1,76^3
+"KRN",.404,432,40,4,3)
+!M
+"KRN",.404,432,40,4,4)
+^^^0
+"KRN",.404,432,40,4,13)
+I DDSEXT="YES" D UNL^MSCZJOB(D0)
+"KRN",.404,432,40,4,20)
+Y^U
+"KRN",.404,432,40,5,0)
+3^^2^^USER
+"KRN",.404,432,40,5,2)
+1,33^14
+"KRN",.404,432,40,5,3)
+!M
+"KRN",.404,432,40,5,3.1)
+S Y=$P($G(MSCZLK(D0)),U,2)
+"KRN",.404,432,40,5,4)
+^^^1
+"KRN",.404,432,40,5,20)
+F
+"KRN",.404,433,0)
+MSCZJOBLOCK HDR^3.081
+"KRN",.404,433,40,0)
+^.4044I^2^2
+"KRN",.404,433,40,1,0)
+1^Process  Lock                    User           Routine                   Unlock^1
+"KRN",.404,433,40,1,2)
+^^2,1
+"KRN",.404,433,40,2,0)
+2^!M^1
+"KRN",.404,433,40,2,.1)
+S Y=$$GET1^DIQ(8989.3,1,.01)
+"KRN",.404,433,40,2,2)
+^^1,28
+"KRN",19,13155,-1)
+0^1
+"KRN",19,13155,0)
+MSCZJOB^JOB EXAMINE^^R^^^^^^^^
+"KRN",19,13155,1,0)
+^^1^1^3070623^
+"KRN",19,13155,1,1,0)
+DESIGNED FOR GT.M
+"KRN",19,13155,25)
+MSCZJOB
+"KRN",19,13155,"U")
+JOB EXAMINE
+"KRN",19,13162,-1)
+0^2
+"KRN",19,13162,0)
+MSCZLOCK^LOCK EXAMINE^^R^^^^^^^^
+"KRN",19,13162,1,0)
+^^1^1^3070623^
+"KRN",19,13162,1,1,0)
+DESIGNED FOR GT.M
+"KRN",19,13162,25)
+LOCK^MSCZJOB
+"KRN",19,13162,"U")
+LOCK EXAMINE
+"MBREQ")
+0
+"ORD",8,.403)
+.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,"",%)
+"ORD",8,.403,0)
+FORM
+"ORD",18,19)
+19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
+"ORD",18,19,0)
+OPTION
+"QUES","XPF1",0)
+Y
+"QUES","XPF1","??")
+^D REP^XPDH
+"QUES","XPF1","A")
+Shall I write over your |FLAG| File
+"QUES","XPF1","B")
+YES
+"QUES","XPF1","M")
+D XPF1^XPDIQ
+"QUES","XPF2",0)
+Y
+"QUES","XPF2","??")
+^D DTA^XPDH
+"QUES","XPF2","A")
+Want my data |FLAG| yours
+"QUES","XPF2","B")
+YES
+"QUES","XPF2","M")
+D XPF2^XPDIQ
+"QUES","XPI1",0)
+YO
+"QUES","XPI1","??")
+^D INHIBIT^XPDH
+"QUES","XPI1","A")
+Want KIDS to INHIBIT LOGONs during the install
+"QUES","XPI1","B")
+YES
+"QUES","XPI1","M")
+D XPI1^XPDIQ
+"QUES","XPM1",0)
+PO^VA(200,:EM
+"QUES","XPM1","??")
+^D MG^XPDH
+"QUES","XPM1","A")
+Enter the Coordinator for Mail Group '|FLAG|'
+"QUES","XPM1","B")
+
+"QUES","XPM1","M")
+D XPM1^XPDIQ
+"QUES","XPO1",0)
+Y
+"QUES","XPO1","??")
+^D MENU^XPDH
+"QUES","XPO1","A")
+Want KIDS to Rebuild Menu Trees Upon Completion of Install
+"QUES","XPO1","B")
+YES
+"QUES","XPO1","M")
+D XPO1^XPDIQ
+"QUES","XPZ1",0)
+Y
+"QUES","XPZ1","??")
+^D OPT^XPDH
+"QUES","XPZ1","A")
+Want to DISABLE Scheduled Options, Menu Options, and Protocols
+"QUES","XPZ1","B")
+YES
+"QUES","XPZ1","M")
+D XPZ1^XPDIQ
+"QUES","XPZ2",0)
+Y
+"QUES","XPZ2","??")
+^D RTN^XPDH
+"QUES","XPZ2","A")
+Want to MOVE routines to other CPUs
+"QUES","XPZ2","B")
+NO
+"QUES","XPZ2","M")
+D XPZ2^XPDIQ
+"RTN")
+19
+"RTN","HLCSLNCH")
+0^18^B37355917
+"RTN","HLCSLNCH",1,0)
+HLCSLNCH ;ALB/MTC/JC MSC/JDA - START AND STOP THE LLP ;12/31/2003  17:37
+"RTN","HLCSLNCH",2,0)
+ ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,MSC**;Oct 13, 1995
+"RTN","HLCSLNCH",3,0)
+ ;
+"RTN","HLCSLNCH",4,0)
+ ;This program is callable from a menu
+"RTN","HLCSLNCH",5,0)
+ ;It allows the user to Start and Stop the Lower Layer
+"RTN","HLCSLNCH",6,0)
+ ;Protocol in the Background or in the foreground
+"RTN","HLCSLNCH",7,0)
+ ;
+"RTN","HLCSLNCH",8,0)
+ ;Required or Optional INPUT PARAMETERS
+"RTN","HLCSLNCH",9,0)
+ ;             None
+"RTN","HLCSLNCH",10,0)
+ ;
+"RTN","HLCSLNCH",11,0)
+ ;
+"RTN","HLCSLNCH",12,0)
+ ;Output variables
+"RTN","HLCSLNCH",13,0)
+ ;             HLDP=IEN of Logical Link in file #870
+"RTN","HLCSLNCH",14,0)
+ ;(optional)HLTRACE=if SET it launches the LLP in the Foreground
+"RTN","HLCSLNCH",15,0)
+ ;(optional)   ZTSK=if defined LLP was launched in the
+"RTN","HLCSLNCH",16,0)
+ ;background
+"RTN","HLCSLNCH",17,0)
+ ;
+"RTN","HLCSLNCH",18,0)
+ ;
+"RTN","HLCSLNCH",19,0)
+START ; Start up the lower level protocol
+"RTN","HLCSLNCH",20,0)
+ N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE
+"RTN","HLCSLNCH",21,0)
+ N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC
+"RTN","HLCSLNCH",22,0)
+ W !!,"This option is used to launch the lower level protocol for the"
+"RTN","HLCSLNCH",23,0)
+ W !,"appropriate device.  Please select the node with which you want"
+"RTN","HLCSLNCH",24,0)
+ W !,"to communicate",!
+"RTN","HLCSLNCH",25,0)
+ S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ
+"RTN","HLCSLNCH",26,0)
+ S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0)
+"RTN","HLCSLNCH",27,0)
+ ;-- check if parameter have been setup
+"RTN","HLCSLNCH",28,0)
+ ;-- check for LLP type
+"RTN","HLCSLNCH",29,0)
+ I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
+"RTN","HLCSLNCH",30,0)
+ ;-- get TCP information
+"RTN","HLCSLNCH",31,0)
+ S HLPARM4=$G(^HLCS(870,HLDP,400))
+"RTN","HLCSLNCH",32,0)
+ ;-- get routine (background job for LLP)
+"RTN","HLCSLNCH",33,0)
+ S HLBGR=$G(^HLCS(869.1,HLTYPTR,100))
+"RTN","HLCSLNCH",34,0)
+ ;-- get environment check routine (HLQUIT should be defined in fails)
+"RTN","HLCSLNCH",35,0)
+ S HLENV=$G(^HLCS(869.1,HLTYPTR,200))
+"RTN","HLCSLNCH",36,0)
+ ;
+"RTN","HLCSLNCH",37,0)
+ I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ
+"RTN","HLCSLNCH",38,0)
+ ;
+"RTN","HLCSLNCH",39,0)
+ ;-- execute environment check routine if HLQUIT is defined then terminate
+"RTN","HLCSLNCH",40,0)
+ I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ
+"RTN","HLCSLNCH",41,0)
+ ;Multi-Servers, only enable the link if not OpenM
+"RTN","HLCSLNCH",42,0)
+ I $P(HLPARM4,U,3)="M",$$NOTMULTI D  G STARTQ
+"RTN","HLCSLNCH",43,0)
+ . 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."
+"RTN","HLCSLNCH",44,0)
+ . Q
+"RTN","HLCSLNCH",45,0)
+ ;
+"RTN","HLCSLNCH",46,0)
+ 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"
+"RTN","HLCSLNCH",47,0)
+ I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"."
+"RTN","HLCSLNCH",48,0)
+ 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 !"
+"RTN","HLCSLNCH",49,0)
+ I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D  G STARTQ
+"RTN","HLCSLNCH",50,0)
+ . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
+"RTN","HLCSLNCH",51,0)
+ I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  G STARTQ
+"RTN","HLCSLNCH",52,0)
+ .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
+"RTN","HLCSLNCH",53,0)
+ .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
+"RTN","HLCSLNCH",54,0)
+ .N HLJ,X
+"RTN","HLCSLNCH",55,0)
+ .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
+"RTN","HLCSLNCH",56,0)
+ .L +^HLCS(870,HLDP,0):2
+"RTN","HLCSLNCH",57,0)
+ .E  W !,$C(7),"Unable to enable this LLP !" Q
+"RTN","HLCSLNCH",58,0)
+ .S X="HLJ(870,"""_HLDP_","")"
+"RTN","HLCSLNCH",59,0)
+ .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
+"RTN","HLCSLNCH",60,0)
+ .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109
+"RTN","HLCSLNCH",61,0)
+ .L -^HLCS(870,HLDP,0)
+"RTN","HLCSLNCH",62,0)
+ .W !,"This LLP has been enabled!"
+"RTN","HLCSLNCH",63,0)
+ .Q
+"RTN","HLCSLNCH",64,0)
+ 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.",!
+"RTN","HLCSLNCH",65,0)
+ ;
+"RTN","HLCSLNCH",66,0)
+ W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT"
+"RTN","HLCSLNCH",67,0)
+ S DIR("A")="Method for running the receiver"
+"RTN","HLCSLNCH",68,0)
+ S DIR("B")="B"
+"RTN","HLCSLNCH",69,0)
+ S DIR("?",1)="Enter F for Foreground (and trace)"
+"RTN","HLCSLNCH",70,0)
+ S DIR("?",2)="      B for Background (normal) or"
+"RTN","HLCSLNCH",71,0)
+ S DIR("?")="      Q to quit without starting the receiver"
+"RTN","HLCSLNCH",72,0)
+ D ^DIR K DIR
+"RTN","HLCSLNCH",73,0)
+ Q:(Y=U)!(Y="Q")
+"RTN","HLCSLNCH",74,0)
+ ;
+"RTN","HLCSLNCH",75,0)
+ S HLX=$G(^HLCS(870,HLDP,0))
+"RTN","HLCSLNCH",76,0)
+ ;-- foreground
+"RTN","HLCSLNCH",77,0)
+ I Y="F" S HLTRACE=1 D  G STARTQ
+"RTN","HLCSLNCH",78,0)
+ . X HLBGR
+"RTN","HLCSLNCH",79,0)
+ ;-- background
+"RTN","HLCSLNCH",80,0)
+ I Y="B" D  G STARTQ
+"RTN","HLCSLNCH",81,0)
+ . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H
+"RTN","HLCSLNCH",82,0)
+ . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
+"RTN","HLCSLNCH",83,0)
+ . D ^%ZTLOAD
+"RTN","HLCSLNCH",84,0)
+ . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.")
+"RTN","HLCSLNCH",85,0)
+ ;
+"RTN","HLCSLNCH",86,0)
+ Q
+"RTN","HLCSLNCH",87,0)
+ ;
+"RTN","HLCSLNCH",88,0)
+ ;
+"RTN","HLCSLNCH",89,0)
+STARTQ ;
+"RTN","HLCSLNCH",90,0)
+ 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."
+"RTN","HLCSLNCH",91,0)
+ Q
+"RTN","HLCSLNCH",92,0)
+ ;
+"RTN","HLCSLNCH",93,0)
+STOP ; Shut down a lower level protocol..
+"RTN","HLCSLNCH",94,0)
+ N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y
+"RTN","HLCSLNCH",95,0)
+ W !!,"This option is used to shut down the lower level protocol for the"
+"RTN","HLCSLNCH",96,0)
+ W !,"appropriate device.  Please select the link which you would"
+"RTN","HLCSLNCH",97,0)
+ W !,"like to shutdown.",!
+"RTN","HLCSLNCH",98,0)
+ S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0
+"RTN","HLCSLNCH",99,0)
+ S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400))
+"RTN","HLCSLNCH",100,0)
+ I $P(HLPARM4,U,3)="M",$$NOTMULTI D  Q
+"RTN","HLCSLNCH",101,0)
+ . 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."
+"RTN","HLCSLNCH",102,0)
+ . Q
+"RTN","HLCSLNCH",103,0)
+ ;
+"RTN","HLCSLNCH",104,0)
+ I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q
+"RTN","HLCSLNCH",105,0)
+ I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"."
+"RTN","HLCSLNCH",106,0)
+STP1 ;
+"RTN","HLCSLNCH",107,0)
+ W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR
+"RTN","HLCSLNCH",108,0)
+ I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q
+"RTN","HLCSLNCH",109,0)
+S ;
+"RTN","HLCSLNCH",110,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSLNCH",111,0)
+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown
+"RTN","HLCSLNCH",112,0)
+ S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
+"RTN","HLCSLNCH",113,0)
+ I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown"
+"RTN","HLCSLNCH",114,0)
+ D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109
+"RTN","HLCSLNCH",115,0)
+ I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
+"RTN","HLCSLNCH",116,0)
+ . ;pass task number to stop listener
+"RTN","HLCSLNCH",117,0)
+ . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
+"RTN","HLCSLNCH",118,0)
+ . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+"RTN","HLCSLNCH",119,0)
+ . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
+"RTN","HLCSLNCH",120,0)
+ . U IO W "**STOP**"
+"RTN","HLCSLNCH",121,0)
+ . W !
+"RTN","HLCSLNCH",122,0)
+ . D CLOSE^%ZISTCP
+"RTN","HLCSLNCH",123,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSLNCH",124,0)
+ W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
+"RTN","HLCSLNCH",125,0)
+ Q
+"RTN","HLCSLNCH",126,0)
+ ;
+"RTN","HLCSLNCH",127,0)
+NOTMULTI() ; Returns 1 if implementation can't run multithreaded listener
+"RTN","HLCSLNCH",128,0)
+ Q:^%ZOSF("OS")["GT.M" 0
+"RTN","HLCSLNCH",129,0)
+ Q $S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS")
+"RTN","HLCSLNCH",130,0)
+STOPQ Q
+"RTN","HLCSTCP")
+0^17^B32199902
+"RTN","HLCSTCP",1,0)
+HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE MSC/JDA- (TCP/IP) MLLP ;12/31/2003  18:03
+"RTN","HLCSTCP",2,0)
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,MSC**;Oct 13, 1995
+"RTN","HLCSTCP",3,0)
+ ;
+"RTN","HLCSTCP",4,0)
+ ; This is an implementation of the HL7 Minimal Lower Layer Protocol
+"RTN","HLCSTCP",5,0)
+ ;
+"RTN","HLCSTCP",6,0)
+ ;taskman entry/startup option, HLDP defined in menu entry,
+"RTN","HLCSTCP",7,0)
+ Q:'$D(HLDP)
+"RTN","HLCSTCP",8,0)
+ N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+"RTN","HLCSTCP",9,0)
+ ;HLCSOUT= 1-error
+"RTN","HLCSTCP",10,0)
+ I '$$INIT D EXITS("Init Error") Q
+"RTN","HLCSTCP",11,0)
+ ; Start the client
+"RTN","HLCSTCP",12,0)
+ I $G(HLTCPCS)="C" D  Q
+"RTN","HLCSTCP",13,0)
+ . ; identify process for ^%SY
+"RTN","HLCSTCP",14,0)
+ . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
+"RTN","HLCSTCP",15,0)
+ . D ST1
+"RTN","HLCSTCP",16,0)
+ . F  D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
+"RTN","HLCSTCP",17,0)
+ . I $G(HLCSOUT)=1 D MON("Error") H 1 Q
+"RTN","HLCSTCP",18,0)
+ . I $G(HLCSOUT)=2 D EXITS("Inactive") Q
+"RTN","HLCSTCP",19,0)
+ . D EXITS("Shutdown")
+"RTN","HLCSTCP",20,0)
+ ;
+"RTN","HLCSTCP",21,0)
+ ; identify process for ^%SY
+"RTN","HLCSTCP",22,0)
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+"RTN","HLCSTCP",23,0)
+ ;HLCSFAIL=1 port failed to open
+"RTN","HLCSTCP",24,0)
+ S HLCSFAIL=1
+"RTN","HLCSTCP",25,0)
+ ;single threaded listener
+"RTN","HLCSTCP",26,0)
+ I $G(HLTCPCS)="S" D  Q
+"RTN","HLCSTCP",27,0)
+ . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")")
+"RTN","HLCSTCP",28,0)
+ . ;couldn't open listener port
+"RTN","HLCSTCP",29,0)
+ . I HLCSFAIL D EXITS("Openfail") Q
+"RTN","HLCSTCP",30,0)
+ ;
+"RTN","HLCSTCP",31,0)
+ ;multi-threaded listener (OpenM or GT.M)
+"RTN","HLCSTCP",32,0)
+ I $G(HLTCPCS)="M",(^%ZOSF("OS")["OpenM")!(^%ZOSF("OS")["GT.M") D  Q
+"RTN","HLCSTCP",33,0)
+ . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")")
+"RTN","HLCSTCP",34,0)
+ Q
+"RTN","HLCSTCP",35,0)
+ ;
+"RTN","HLCSTCP",36,0)
+SERVER(HLDP) ; single server using Taskman
+"RTN","HLCSTCP",37,0)
+ S HLCSFAIL=0
+"RTN","HLCSTCP",38,0)
+ I '$$INIT D EXITS("Init error") Q
+"RTN","HLCSTCP",39,0)
+ D ^HLCSTCP1
+"RTN","HLCSTCP",40,0)
+ I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
+"RTN","HLCSTCP",41,0)
+ Q:$G(HLCSOUT)=1
+"RTN","HLCSTCP",42,0)
+ D MON("Idle")
+"RTN","HLCSTCP",43,0)
+ Q
+"RTN","HLCSTCP",44,0)
+ ;
+"RTN","HLCSTCP",45,0)
+SERVERS(HLDP) ; Multi-threaded server using Taskman
+"RTN","HLCSTCP",46,0)
+ I '$$INIT D EXITS("Init error") Q
+"RTN","HLCSTCP",47,0)
+ G LISTEN
+"RTN","HLCSTCP",48,0)
+ ;
+"RTN","HLCSTCP",49,0)
+ ;multiple process servers, called from an external utility
+"RTN","HLCSTCP",50,0)
+MSM ;MSM entry point, called from User-Defined Services
+"RTN","HLCSTCP",51,0)
+ ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
+"RTN","HLCSTCP",52,0)
+ ;HL7 Multi-Threaded SERVER
+"RTN","HLCSTCP",53,0)
+ S (IO,IO(0))=$P
+"RTN","HLCSTCP",54,0)
+ G LISTEN
+"RTN","HLCSTCP",55,0)
+ ;
+"RTN","HLCSTCP",56,0)
+CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
+"RTN","HLCSTCP",57,0)
+ ;listener,  % = HLDP
+"RTN","HLCSTCP",58,0)
+ I $G(%)="" D ^%ZTER Q
+"RTN","HLCSTCP",59,0)
+ S (IO,IO(0))="SYS$NET",HLDP=%
+"RTN","HLCSTCP",60,0)
+ ; **Cache'/VMS specific code**
+"RTN","HLCSTCP",61,0)
+ O IO::5 E  D MON("Openfail") Q
+"RTN","HLCSTCP",62,0)
+ X "U IO:(::""-M"")" ;Packet mode like DSM
+"RTN","HLCSTCP",63,0)
+ D LISTEN C IO Q
+"RTN","HLCSTCP",64,0)
+ ;
+"RTN","HLCSTCP",65,0)
+EN ;vms ucx entry point, called from HLSEVEN.COM file,
+"RTN","HLCSTCP",66,0)
+ ;listener,  % = device^HLDP
+"RTN","HLCSTCP",67,0)
+ I $G(%)="" D ^%ZTER Q
+"RTN","HLCSTCP",68,0)
+ S (IO,IO(0))="SYS$NET",HLDP=$P(%,"^",2)
+"RTN","HLCSTCP",69,0)
+ ; **VMS specific code, need to share device**
+"RTN","HLCSTCP",70,0)
+ X "O IO:(TCPDEV):60" E  D MON("Openfail") Q
+"RTN","HLCSTCP",71,0)
+LISTEN ;
+"RTN","HLCSTCP",72,0)
+ N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+"RTN","HLCSTCP",73,0)
+ I '$$INIT D ^%ZTER Q
+"RTN","HLCSTCP",74,0)
+ ; identify process for ^%SY
+"RTN","HLCSTCP",75,0)
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+"RTN","HLCSTCP",76,0)
+ ;HLLSTN used to identify a listener to tag MON
+"RTN","HLCSTCP",77,0)
+ S HLLSTN=1
+"RTN","HLCSTCP",78,0)
+ ;increment job count, run server
+"RTN","HLCSTCP",79,0)
+ D UPDT(1),^HLCSTCP1,EXITM
+"RTN","HLCSTCP",80,0)
+ Q
+"RTN","HLCSTCP",81,0)
+ ;
+"RTN","HLCSTCP",82,0)
+DCOPEN(HLDP) ;open direct connect - called from HLMA2
+"RTN","HLCSTCP",83,0)
+ Q:'$$INIT 0
+"RTN","HLCSTCP",84,0)
+ Q:HLTCPADD=""!(HLTCPORT="") 0
+"RTN","HLCSTCP",85,0)
+ Q:'$$OPEN^HLCSTCP2 0
+"RTN","HLCSTCP",86,0)
+ Q 1
+"RTN","HLCSTCP",87,0)
+ ;
+"RTN","HLCSTCP",88,0)
+INIT() ; Initialize Variables
+"RTN","HLCSTCP",89,0)
+ ; HLDP should be set to the IEN or name of Logical Link, file 870
+"RTN","HLCSTCP",90,0)
+ S HLOS=$P($G(^%ZOSF("OS")),"^")
+"RTN","HLCSTCP",91,0)
+ N DA,DIQUIET,DR,TMP,X,Y
+"RTN","HLCSTCP",92,0)
+ S DIQUIET=1
+"RTN","HLCSTCP",93,0)
+ D DT^DICRW
+"RTN","HLCSTCP",94,0)
+ I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
+"RTN","HLCSTCP",95,0)
+ S DA=HLDP
+"RTN","HLCSTCP",96,0)
+ S DR="200.02;200.021;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05"
+"RTN","HLCSTCP",97,0)
+ D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
+"RTN","HLCSTCP",98,0)
+ ;
+"RTN","HLCSTCP",99,0)
+ I $D(TMP("DIERR")) QUIT 0
+"RTN","HLCSTCP",100,0)
+ ; -- re-transmit attempts
+"RTN","HLCSTCP",101,0)
+ S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
+"RTN","HLCSTCP",102,0)
+ ; -- exceed re-transmit action
+"RTN","HLCSTCP",103,0)
+ S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
+"RTN","HLCSTCP",104,0)
+ ; -- block size
+"RTN","HLCSTCP",105,0)
+ S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
+"RTN","HLCSTCP",106,0)
+ ; -- read timeout
+"RTN","HLCSTCP",107,0)
+ S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
+"RTN","HLCSTCP",108,0)
+ ; -- ack timeout
+"RTN","HLCSTCP",109,0)
+ S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
+"RTN","HLCSTCP",110,0)
+ ; -- uni-directional wait
+"RTN","HLCSTCP",111,0)
+ S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
+"RTN","HLCSTCP",112,0)
+ ; -- tcp address
+"RTN","HLCSTCP",113,0)
+ S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
+"RTN","HLCSTCP",114,0)
+ ; -- tcp port
+"RTN","HLCSTCP",115,0)
+ S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
+"RTN","HLCSTCP",116,0)
+ ; -- tcp/ip service type
+"RTN","HLCSTCP",117,0)
+ S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
+"RTN","HLCSTCP",118,0)
+ ; -- link persistence
+"RTN","HLCSTCP",119,0)
+ S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
+"RTN","HLCSTCP",120,0)
+ ; -- retention
+"RTN","HLCSTCP",121,0)
+ S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
+"RTN","HLCSTCP",122,0)
+ ;
+"RTN","HLCSTCP",123,0)
+ ; -- set defaults in case something's not set
+"RTN","HLCSTCP",124,0)
+ S:HLDREAD=0 HLDREAD=10
+"RTN","HLCSTCP",125,0)
+ S:HLDBACK=0 HLDBACK=60
+"RTN","HLCSTCP",126,0)
+ S:HLDBSIZE=0 HLDBSIZE=245
+"RTN","HLCSTCP",127,0)
+ S:HLDRETR=0 HLDRETR=5
+"RTN","HLCSTCP",128,0)
+ S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
+"RTN","HLCSTCP",129,0)
+ ;
+"RTN","HLCSTCP",130,0)
+ Q 1
+"RTN","HLCSTCP",131,0)
+ ;
+"RTN","HLCSTCP",132,0)
+ST1 ;record startup in 870 for single server
+"RTN","HLCSTCP",133,0)
+ ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
+"RTN","HLCSTCP",134,0)
+ ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
+"RTN","HLCSTCP",135,0)
+ N HLJ,X
+"RTN","HLCSTCP",136,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",137,0)
+ S X="HLJ(870,"""_HLDP_","")"
+"RTN","HLCSTCP",138,0)
+ S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
+"RTN","HLCSTCP",139,0)
+ I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
+"RTN","HLCSTCP",140,0)
+ E  S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
+"RTN","HLCSTCP",141,0)
+ I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
+"RTN","HLCSTCP",142,0)
+ S:$G(ZTSK) @X@(11)=ZTSK
+"RTN","HLCSTCP",143,0)
+ D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",144,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",145,0)
+ Q
+"RTN","HLCSTCP",146,0)
+ ;
+"RTN","HLCSTCP",147,0)
+MON(Y) ;Display current state & check for shutdown
+"RTN","HLCSTCP",148,0)
+ ;don't display for multiple server
+"RTN","HLCSTCP",149,0)
+ Q:$G(HLLSTN)
+"RTN","HLCSTCP",150,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",151,0)
+ S $P(^HLCS(870,HLDP,0),U,5)=Y
+"RTN","HLCSTCP",152,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",153,0)
+ Q:'$D(HLTRACE)
+"RTN","HLCSTCP",154,0)
+ N X U IO(0)
+"RTN","HLCSTCP",155,0)
+ W !,"IN State: ",Y
+"RTN","HLCSTCP",156,0)
+ I '$$STOP D
+"RTN","HLCSTCP",157,0)
+ . R !,"Type Q to Quit: ",X#1:1
+"RTN","HLCSTCP",158,0)
+ . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
+"RTN","HLCSTCP",159,0)
+ U IO
+"RTN","HLCSTCP",160,0)
+ Q
+"RTN","HLCSTCP",161,0)
+UPDT(Y) ;update job count for multiple servers,X=1 increment
+"RTN","HLCSTCP",162,0)
+ N HLJ,X
+"RTN","HLCSTCP",163,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",164,0)
+ S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
+"RTN","HLCSTCP",165,0)
+ ;if incrementing, set the Device Type field to Multi-Server
+"RTN","HLCSTCP",166,0)
+ I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",167,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",168,0)
+ Q
+"RTN","HLCSTCP",169,0)
+STOP() ;stop flag set
+"RTN","HLCSTCP",170,0)
+ N X
+"RTN","HLCSTCP",171,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",172,0)
+ S X=+$P(^HLCS(870,HLDP,0),U,15)
+"RTN","HLCSTCP",173,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",174,0)
+ Q X
+"RTN","HLCSTCP",175,0)
+ ;
+"RTN","HLCSTCP",176,0)
+LLCNT(DP,Y,Z) ;update Logical Link counters
+"RTN","HLCSTCP",177,0)
+ ;DP=ien of Logical Link in file 870
+"RTN","HLCSTCP",178,0)
+ ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
+"RTN","HLCSTCP",179,0)
+ ;Z: ""=add to counter, 1=subtract from counter
+"RTN","HLCSTCP",180,0)
+ Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
+"RTN","HLCSTCP",181,0)
+ N P,X
+"RTN","HLCSTCP",182,0)
+ S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
+"RTN","HLCSTCP",183,0)
+ F  L +^HLCS(870,DP,P):2 Q:$T
+"RTN","HLCSTCP",184,0)
+ S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+"RTN","HLCSTCP",185,0)
+ L -^HLCS(870,DP,P)
+"RTN","HLCSTCP",186,0)
+ Q
+"RTN","HLCSTCP",187,0)
+SDFLD ; set Shutdown? field to yes
+"RTN","HLCSTCP",188,0)
+ Q:'$G(HLDP)
+"RTN","HLCSTCP",189,0)
+ N HLJ,X
+"RTN","HLCSTCP",190,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",191,0)
+ ;14=Shutdown LLP?
+"RTN","HLCSTCP",192,0)
+ S HLJ(870,HLDP_",",14)=1
+"RTN","HLCSTCP",193,0)
+ D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",194,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",195,0)
+ Q
+"RTN","HLCSTCP",196,0)
+ ;
+"RTN","HLCSTCP",197,0)
+EXITS(Y) ; Single service shutdown and cleans up
+"RTN","HLCSTCP",198,0)
+ N HLJ,X
+"RTN","HLCSTCP",199,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",200,0)
+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number
+"RTN","HLCSTCP",201,0)
+ S X="HLJ(870,"""_HLDP_","")"
+"RTN","HLCSTCP",202,0)
+ S @X@(4)=Y,@X@(11)="@"
+"RTN","HLCSTCP",203,0)
+ S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
+"RTN","HLCSTCP",204,0)
+ D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
+"RTN","HLCSTCP",205,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",206,0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+"RTN","HLCSTCP",207,0)
+ Q
+"RTN","HLCSTCP",208,0)
+ ;
+"RTN","HLCSTCP",209,0)
+EXITM ;Multiple service shutdown and clean up
+"RTN","HLCSTCP",210,0)
+ D UPDT(0)
+"RTN","HLCSTCP",211,0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+"RTN","HLCSTCP",212,0)
+ Q
+"RTN","HLCSTCP1")
+0^16^B29662559
+"RTN","HLCSTCP1",1,0)
+HLCSTCP1 ;SFIRMFO/RSD MSC/JDA - BI-DIRECTIONAL TCP ;11/21/2001  17:09
+"RTN","HLCSTCP1",2,0)
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,MSC**;JUL 17,1995
+"RTN","HLCSTCP1",3,0)
+ ;Receiver
+"RTN","HLCSTCP1",4,0)
+ ;connection is initiated by sender and listener accepts connection
+"RTN","HLCSTCP1",5,0)
+ ;and calls this routine
+"RTN","HLCSTCP1",6,0)
+ ;
+"RTN","HLCSTCP1",7,0)
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
+"RTN","HLCSTCP1",8,0)
+ N HLMIEN,HLASTMSG
+"RTN","HLCSTCP1",9,0)
+ D MON^HLCSTCP("Open")
+"RTN","HLCSTCP1",10,0)
+ K ^TMP("HLCSTCP",$J,0)
+"RTN","HLCSTCP1",11,0)
+ S HLMIEN=0,HLASTMSG=""
+"RTN","HLCSTCP1",12,0)
+ F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3
+"RTN","HLCSTCP1",13,0)
+ . S HLMIEN=$$READ
+"RTN","HLCSTCP1",14,0)
+ . Q:'HLMIEN
+"RTN","HLCSTCP1",15,0)
+ . D PROCESS
+"RTN","HLCSTCP1",16,0)
+ Q
+"RTN","HLCSTCP1",17,0)
+ ;
+"RTN","HLCSTCP1",18,0)
+PROCESS ;check message and reply
+"RTN","HLCSTCP1",19,0)
+ ;HLDP=LL in 870, update monitor, received msg.
+"RTN","HLCSTCP1",20,0)
+ N HLTCP,HLTCPI,HLTCPO
+"RTN","HLCSTCP1",21,0)
+ S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
+"RTN","HLCSTCP1",22,0)
+ ;update monitor, msg. received
+"RTN","HLCSTCP1",23,0)
+ D LLCNT^HLCSTCP(HLDP,1)
+"RTN","HLCSTCP1",24,0)
+ D NEW^HLTP3(HLMIEN)
+"RTN","HLCSTCP1",25,0)
+ ;update monitor, msg. processed
+"RTN","HLCSTCP1",26,0)
+ D LLCNT^HLCSTCP(HLDP,2)
+"RTN","HLCSTCP1",27,0)
+ Q
+"RTN","HLCSTCP1",28,0)
+ ;
+"RTN","HLCSTCP1",29,0)
+READ() ;read 1 message, returns ien in 773^ien in 772 for message
+"RTN","HLCSTCP1",30,0)
+ D MON^HLCSTCP("Reading")
+"RTN","HLCSTCP1",31,0)
+ N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
+"RTN","HLCSTCP1",32,0)
+ ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator
+"RTN","HLCSTCP1",33,0)
+ S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
+"RTN","HLCSTCP1",34,0)
+ ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
+"RTN","HLCSTCP1",35,0)
+ ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack
+"RTN","HLCSTCP1",36,0)
+ S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
+"RTN","HLCSTCP1",37,0)
+ K ^TMP("HLCSTCP",$J,0)
+"RTN","HLCSTCP1",38,0)
+ F  D RDBLK Q:HLRDOUT
+"RTN","HLCSTCP1",39,0)
+ ;save any excess for next time
+"RTN","HLCSTCP1",40,0)
+ S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX
+"RTN","HLCSTCP1",41,0)
+ I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
+"RTN","HLCSTCP1",42,0)
+ Q HLIND1
+"RTN","HLCSTCP1",43,0)
+ ;
+"RTN","HLCSTCP1",44,0)
+RDBLK S HLDB=HLDBSIZE-$L(HLX)
+"RTN","HLCSTCP1",45,0)
+ U IO D:$D ERROR R X#HLDB:HLDREAD ; MSC/JDA added check against $d
+"RTN","HLCSTCP1",46,0)
+ ; timedout or error, check ack timeout, clean up
+"RTN","HLCSTCP1",47,0)
+ I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
+"RTN","HLCSTCP1",48,0)
+ ;data stream: <sb>dddd<cr><eb><cr>
+"RTN","HLCSTCP1",49,0)
+ ;add incoming line to what wasn't processed in last read
+"RTN","HLCSTCP1",50,0)
+ S HLX=$G(HLX)_X
+"RTN","HLCSTCP1",51,0)
+ ; look for segment= <CR>
+"RTN","HLCSTCP1",52,0)
+ F  Q:HLX'[HLRS  D  Q:HLRDOUT
+"RTN","HLCSTCP1",53,0)
+ . ; Get the first piece, save the rest of the line
+"RTN","HLCSTCP1",54,0)
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
+"RTN","HLCSTCP1",55,0)
+ . ; check for start block, Quit if no ien
+"RTN","HLCSTCP1",56,0)
+ . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D  Q
+"RTN","HLCSTCP1",57,0)
+ .. D:HLMSG(HLINE,0)[HLDSTRT
+"RTN","HLCSTCP1",58,0)
+ ... S X=$L(HLMSG(HLINE,0),HLDSTRT)
+"RTN","HLCSTCP1",59,0)
+ ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
+"RTN","HLCSTCP1",60,0)
+ ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
+"RTN","HLCSTCP1",61,0)
+ ... D RESET:(HLINE>1)
+"RTN","HLCSTCP1",62,0)
+ .. ;ping message
+"RTN","HLCSTCP1",63,0)
+ .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
+"RTN","HLCSTCP1",64,0)
+ .. ; get next ien to store
+"RTN","HLCSTCP1",65,0)
+ .. D MIEN
+"RTN","HLCSTCP1",66,0)
+ .. K HLMSG
+"RTN","HLCSTCP1",67,0)
+ .. S (HLINE,HLHDR)=0
+"RTN","HLCSTCP1",68,0)
+ . ; check for end block; HLMSG(HLINE) = <eb><cr>
+"RTN","HLCSTCP1",69,0)
+ . I HLMSG(HLINE,0)[HLDEND D
+"RTN","HLCSTCP1",70,0)
+ .. ;no msg. ien
+"RTN","HLCSTCP1",71,0)
+ .. Q:'HLIND1
+"RTN","HLCSTCP1",72,0)
+ .. ; Kill just the last line
+"RTN","HLCSTCP1",73,0)
+ .. K HLMSG(HLINE,0) S HLINE=HLINE-1
+"RTN","HLCSTCP1",74,0)
+ .. ; move into 772
+"RTN","HLCSTCP1",75,0)
+ .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
+"RTN","HLCSTCP1",76,0)
+ .. ;mark that end block has been received
+"RTN","HLCSTCP1",77,0)
+ .. ;HLIND1=ien in 773^ien in 772^1 if end block was received
+"RTN","HLCSTCP1",78,0)
+ .. S $P(HLIND1,U,3)=1
+"RTN","HLCSTCP1",79,0)
+ .. ;reset variables for next message
+"RTN","HLCSTCP1",80,0)
+ .. D CLEAN
+"RTN","HLCSTCP1",81,0)
+ . ;add blank line for carriage return
+"RTN","HLCSTCP1",82,0)
+ . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
+"RTN","HLCSTCP1",83,0)
+ Q:HLRDOUT
+"RTN","HLCSTCP1",84,0)
+ ;If the line is long and no <CR> move it into the array. 
+"RTN","HLCSTCP1",85,0)
+ I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D  Q
+"RTN","HLCSTCP1",86,0)
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
+"RTN","HLCSTCP1",87,0)
+ ;have start block but no record seperator
+"RTN","HLCSTCP1",88,0)
+ I HLX[HLDSTRT D  Q
+"RTN","HLCSTCP1",89,0)
+ . ;check for more than 1 start block
+"RTN","HLCSTCP1",90,0)
+ . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
+"RTN","HLCSTCP1",91,0)
+ . S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
+"RTN","HLCSTCP1",92,0)
+ . D RESET:(HLHDR&(HLINE>1))
+"RTN","HLCSTCP1",93,0)
+ ;if no ien, then we don't have start block, reset
+"RTN","HLCSTCP1",94,0)
+ I 'HLIND1 D CLEAN Q
+"RTN","HLCSTCP1",95,0)
+ ; big message-merge from local to global every 100 lines
+"RTN","HLCSTCP1",96,0)
+ I (HLINE-$O(HLMSG(0)))>100 D
+"RTN","HLCSTCP1",97,0)
+ . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
+"RTN","HLCSTCP1",98,0)
+ . ; reset working array
+"RTN","HLCSTCP1",99,0)
+ . K HLMSG
+"RTN","HLCSTCP1",100,0)
+ Q
+"RTN","HLCSTCP1",101,0)
+ ;
+"RTN","HLCSTCP1",102,0)
+SAVE(SRC,DEST) ;save into global & set top node
+"RTN","HLCSTCP1",103,0)
+ ;SRC=source array (passed by ref.), DEST=destination global
+"RTN","HLCSTCP1",104,0)
+ M @DEST=SRC
+"RTN","HLCSTCP1",105,0)
+ S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
+"RTN","HLCSTCP1",106,0)
+ Q
+"RTN","HLCSTCP1",107,0)
+ ;
+"RTN","HLCSTCP1",108,0)
+DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
+"RTN","HLCSTCP1",109,0)
+ N DIK,DA
+"RTN","HLCSTCP1",110,0)
+ S DA=+HLMAMT,DIK="^HLMA("
+"RTN","HLCSTCP1",111,0)
+ D ^DIK
+"RTN","HLCSTCP1",112,0)
+ S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
+"RTN","HLCSTCP1",113,0)
+ D ^DIK
+"RTN","HLCSTCP1",114,0)
+ Q
+"RTN","HLCSTCP1",115,0)
+MIEN ; sets HLIND1=ien in 773^ien in 772 for message
+"RTN","HLCSTCP1",116,0)
+ N HLMID,X
+"RTN","HLCSTCP1",117,0)
+ I HLIND1 D
+"RTN","HLCSTCP1",118,0)
+ . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
+"RTN","HLCSTCP1",119,0)
+ . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
+"RTN","HLCSTCP1",120,0)
+ ;msg. id is 10th of MSH & 11th for BSH or FSH
+"RTN","HLCSTCP1",121,0)
+ S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
+"RTN","HLCSTCP1",122,0)
+ ;if HLIND1 is set, kill old message, use HLIND1 for new
+"RTN","HLCSTCP1",123,0)
+ ;message, it means we never got end block for 1st msg.
+"RTN","HLCSTCP1",124,0)
+ I HLIND1 D  Q
+"RTN","HLCSTCP1",125,0)
+ . ;get pointer to 772, kill header
+"RTN","HLCSTCP1",126,0)
+ . K ^HLMA(+HLIND1,"MSH")
+"RTN","HLCSTCP1",127,0)
+ . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
+"RTN","HLCSTCP1",128,0)
+ . S X=$$MAID^HLTF(+HLIND1,HLMID)
+"RTN","HLCSTCP1",129,0)
+ . D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+"RTN","HLCSTCP1",130,0)
+ . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
+"RTN","HLCSTCP1",131,0)
+ D TCP^HLTF(.HLMID,.X,.HLDT)
+"RTN","HLCSTCP1",132,0)
+ I 'X D  Q
+"RTN","HLCSTCP1",133,0)
+ . ;error - record and reset array
+"RTN","HLCSTCP1",134,0)
+ . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
+"RTN","HLCSTCP1",135,0)
+ . D CLEAN K HLLSTN
+"RTN","HLCSTCP1",136,0)
+ . ;error 100=LLP Could not Enqueue the Message, reset array
+"RTN","HLCSTCP1",137,0)
+ . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
+"RTN","HLCSTCP1",138,0)
+ ;HLIND1=ien in 773^ien in 772
+"RTN","HLCSTCP1",139,0)
+ S HLIND1=X_U_+$G(^HLMA(X,0))
+"RTN","HLCSTCP1",140,0)
+ ;save MSH into 773
+"RTN","HLCSTCP1",141,0)
+ D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+"RTN","HLCSTCP1",142,0)
+ Q
+"RTN","HLCSTCP1",143,0)
+ ;
+"RTN","HLCSTCP1",144,0)
+PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
+"RTN","HLCSTCP1",145,0)
+ N FS,I,L,L1,L2,X,Y
+"RTN","HLCSTCP1",146,0)
+ S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
+"RTN","HLCSTCP1",147,0)
+ F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D  Q:$L(X)!'$D(MSH(I,0))
+"RTN","HLCSTCP1",148,0)
+ . S:L1=1 L=L+1
+"RTN","HLCSTCP1",149,0)
+ . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
+"RTN","HLCSTCP1",150,0)
+ . S L2=Y,Y=L
+"RTN","HLCSTCP1",151,0)
+ Q X
+"RTN","HLCSTCP1",152,0)
+ ;
+"RTN","HLCSTCP1",153,0)
+PING ;process PING message
+"RTN","HLCSTCP1",154,0)
+ S X=HLMSG(1,0)
+"RTN","HLCSTCP1",155,0)
+ I X[HLDEND U IO W X,!
+"RTN","HLCSTCP1",156,0)
+CLEAN ;reset var. for next message
+"RTN","HLCSTCP1",157,0)
+ K HLMSG
+"RTN","HLCSTCP1",158,0)
+ S HLINE=0,HLRDOUT=1
+"RTN","HLCSTCP1",159,0)
+ Q
+"RTN","HLCSTCP1",160,0)
+ ;
+"RTN","HLCSTCP1",161,0)
+ERROR ; Error trap for disconnect error and return back to the read loop.
+"RTN","HLCSTCP1",162,0)
+ S $ETRAP="D UNWIND^%ZTER"
+"RTN","HLCSTCP1",163,0)
+ I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
+"RTN","HLCSTCP1",164,0)
+ I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
+"RTN","HLCSTCP1",165,0)
+ S HLCSOUT=1 D ^%ZTER,CC("Error")
+"RTN","HLCSTCP1",166,0)
+ D UNWIND^%ZTER
+"RTN","HLCSTCP1",167,0)
+ Q
+"RTN","HLCSTCP1",168,0)
+ ;
+"RTN","HLCSTCP1",169,0)
+CC(X) ;cleanup and close
+"RTN","HLCSTCP1",170,0)
+ D MON^HLCSTCP(X)
+"RTN","HLCSTCP1",171,0)
+ H 2
+"RTN","HLCSTCP1",172,0)
+ Q
+"RTN","HLCSTCP1",173,0)
+RESET ;reset info as a result of no end block
+"RTN","HLCSTCP1",174,0)
+ N %
+"RTN","HLCSTCP1",175,0)
+ S HLMSG(1,0)=HLMSG(HLINE,0)
+"RTN","HLCSTCP1",176,0)
+ F %=2:1:HLINE K HLMSG(%,0)
+"RTN","HLCSTCP1",177,0)
+ S HLINE=1
+"RTN","HLCSTCP1",178,0)
+ Q
+"RTN","MSCZJOB")
+0^1^B12797960
+"RTN","MSCZJOB",1,0)
+MSCZJOB ;GFT/MSC;28JAN2009
+"RTN","MSCZJOB",2,0)
+ ;;8.0;KERNEL;**MSC**
+"RTN","MSCZJOB",3,0)
+ W !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+"RTN","MSCZJOB",4,0)
+ N MSC
+"RTN","MSCZJOB",5,0)
+DDS ;
+"RTN","MSCZJOB",6,0)
+ S DDSFILE=3.081,DR="[MSCZJOBEXAM]",DDSPARM="S"
+"RTN","MSCZJOB",7,0)
+ D ^DDS Q
+"RTN","MSCZJOB",8,0)
+ ;
+"RTN","MSCZJOB",9,0)
+UNLOCK(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
+"RTN","MSCZJOB",10,0)
+ N X,R S R=$G(@MSC@(MSCJOBID,"L",D0)) I R'["^" Q  ;CAN'T SEE IT
+"RTN","MSCZJOB",11,0)
+ S R=$P(R,"~",2),R="^"_$S(R'["(":$P(R," "),1:$P(R,")")_")"),X="L "_R D ^DIM Q:'$D(X)  ;GOOD SYNTAX?
+"RTN","MSCZJOB",12,0)
+ D UNLOCK^MSCZJOBU(R,MSCJOBID)
+"RTN","MSCZJOB",13,0)
+ Q
+"RTN","MSCZJOB",14,0)
+ ;
+"RTN","MSCZJOB",15,0)
+ ;
+"RTN","MSCZJOB",16,0)
+KILL(J) ;FROM FIELD
+"RTN","MSCZJOB",17,0)
+ D KILL^MSCZJOBU(J)
+"RTN","MSCZJOB",18,0)
+ Q
+"RTN","MSCZJOB",19,0)
+ ;
+"RTN","MSCZJOB",20,0)
+ ;
+"RTN","MSCZJOB",21,0)
+ ;
+"RTN","MSCZJOB",22,0)
+ ;
+"RTN","MSCZJOB",23,0)
+COMPMUL ;COMPUTED MULTIPLE FOR MSCZJOBEXAM BLOCK
+"RTN","MSCZJOB",24,0)
+ N X,D0,J
+"RTN","MSCZJOB",25,0)
+ S MSC="^TMP(""MSCZJOB"")" D POLL
+"RTN","MSCZJOB",26,0)
+ F D0=0:0 S D0=$O(MSCZJOB(D0)) Q:'D0  D
+"RTN","MSCZJOB",27,0)
+ .S MSCZJOB(D0)=MSCZJOB(D0)_U_$$DEV(D0)_U_$$USER(D0)_U_$$NSP(D0)_U_U_U_U_U_$$ROUTINE(D0)
+"RTN","MSCZJOB",28,0)
+ .S X=MSCZJOB(D0) X DICMX
+"RTN","MSCZJOB",29,0)
+ Q
+"RTN","MSCZJOB",30,0)
+JOB(D0) Q $P(MSCZJOB(D0),U) ;***
+"RTN","MSCZJOB",31,0)
+DEV(D0) Q $$FIND(D0,"I","$PRINCIPAL")
+"RTN","MSCZJOB",32,0)
+NSP(D0) N N D  Q N
+"RTN","MSCZJOB",33,0)
+ .N L,P S N=$$FIND(D0,"I","$ZGBLDIR"),L=$L(N,"/") I L<2 Q
+"RTN","MSCZJOB",34,0)
+ .F L=L-1:-1:2 S P=$P(N,"/",L) I P'[".",P'["globals" Q
+"RTN","MSCZJOB",35,0)
+ .S P=1 I $P(N,"/")="" S P=2
+"RTN","MSCZJOB",36,0)
+ .S N=$P(N,"/",P,L)
+"RTN","MSCZJOB",37,0)
+USER(D0) Q $P($G(^VA(200,+$$FIND(D0,"V","DUZ"),0)),U)
+"RTN","MSCZJOB",38,0)
+ROUTINE(D0) Q $$FIND(D0,"V","%ZPOS")
+"RTN","MSCZJOB",39,0)
+ ;
+"RTN","MSCZJOB",40,0)
+FIND(D0,ARR,KEY) N I,J,X S X="",J=+MSCZJOB(D0)
+"RTN","MSCZJOB",41,0)
+ F I=0:0 S I=$O(@MSC@(J,ARR,I)) Q:'I  I $P(^(I),KEY_"=")="" S X=$TR($P(^(I),"=",2),"""") Q
+"RTN","MSCZJOB",42,0)
+ Q X
+"RTN","MSCZJOB",43,0)
+ ;
+"RTN","MSCZJOB",44,0)
+ ;
+"RTN","MSCZJOB",45,0)
+ ;
+"RTN","MSCZJOB",46,0)
+ ;
+"RTN","MSCZJOB",47,0)
+ ;
+"RTN","MSCZJOB",48,0)
+COMPSTK ;COMPUTED MULTIPLE FOR MSCZJOBSTACK BLOCK
+"RTN","MSCZJOB",49,0)
+ S MSC="^TMP(""MSCZJOB"")" K @MSC@(MSCJOBID) D POLL1
+"RTN","MSCZJOB",50,0)
+ N D0,J S J=MSCJOBID
+"RTN","MSCZJOB",51,0)
+ F D0=1:1:$O(@MSC@(J,"S",""),-1)  S X="" X DICMX
+"RTN","MSCZJOB",52,0)
+ Q
+"RTN","MSCZJOB",53,0)
+ ;
+"RTN","MSCZJOB",54,0)
+STACK(D0) N X S X=$G(@MSC@(MSCJOBID,"S",D0))
+"RTN","MSCZJOB",55,0)
+ Q X
+"RTN","MSCZJOB",56,0)
+ ;
+"RTN","MSCZJOB",57,0)
+ ;
+"RTN","MSCZJOB",58,0)
+COMPVARS ;COMPUTED MULTIPLE FOR MSCZJOBVARS BLOCK
+"RTN","MSCZJOB",59,0)
+ S MSC="^TMP(""MSCZJOB"")" K @MSC@(MSCJOBID) D POLL1
+"RTN","MSCZJOB",60,0)
+ N D0,J S J=MSCJOBID
+"RTN","MSCZJOB",61,0)
+ F D0=1:1:$O(@MSC@(J,"V",""),-1)  S X="" X DICMX
+"RTN","MSCZJOB",62,0)
+ Q
+"RTN","MSCZJOB",63,0)
+ ;
+"RTN","MSCZJOB",64,0)
+ ;
+"RTN","MSCZJOB",65,0)
+COMPLKS ;COMPUTED MULTIPLE FOR MSCZJOBLOCKS BLOCK
+"RTN","MSCZJOB",66,0)
+ S MSC="^TMP(""MSCZJOB"")" D POLL1
+"RTN","MSCZJOB",67,0)
+ N D0
+"RTN","MSCZJOB",68,0)
+ F D0=1:1:$$LOCKS  S X="" X DICMX
+"RTN","MSCZJOB",69,0)
+ Q
+"RTN","MSCZJOB",70,0)
+ ;
+"RTN","MSCZJOB",71,0)
+LOCKS() Q +$O(@MSC@(MSCJOBID,"L",""),-1)
+"RTN","MSCZJOB",72,0)
+ ;
+"RTN","MSCZJOB",73,0)
+ ;
+"RTN","MSCZJOB",74,0)
+POLL K MSCZJOB ;D HLP^DDSUTL("   POLLING JOBS.....") 
+"RTN","MSCZJOB",75,0)
+ I $G(^%ZOSF("OS"))["GT.M" D
+"RTN","MSCZJOB",76,0)
+ .K @MSC
+"RTN","MSCZJOB",77,0)
+ .D INTRPT^MSCZJOBU("*") ;SETS UP ^TMP
+"RTN","MSCZJOB",78,0)
+ .N MSCA,I D PIDS^MSCZJOBU(.MSCA)
+"RTN","MSCZJOB",79,0)
+ .S MSCA="" F I=1:1 S MSCA=$O(MSCA(MSCA)) Q:'MSCA  S MSCZJOB(I)=MSCA ;SETS UP LOCAL ARRAY
+"RTN","MSCZJOB",80,0)
+ .H 1 ;WAIT FOR POLLING
+"RTN","MSCZJOB",81,0)
+ D TEST
+"RTN","MSCZJOB",82,0)
+ Q
+"RTN","MSCZJOB",83,0)
+ ;
+"RTN","MSCZJOB",84,0)
+POLL1 Q:'$G(MSCJOBID)
+"RTN","MSCZJOB",85,0)
+ I $G(^%ZOSF("OS"))["GT.M" D
+"RTN","MSCZJOB",86,0)
+ .K @MSC@(MSCJOBID)
+"RTN","MSCZJOB",87,0)
+ .D INTRPT^MSCZJOBU(MSCJOBID) ;SETS UP ^TMP(MSCZJOB)
+"RTN","MSCZJOB",88,0)
+ .H 1 ;WAIT FOR POLLING
+"RTN","MSCZJOB",89,0)
+ D TEST
+"RTN","MSCZJOB",90,0)
+ Q
+"RTN","MSCZJOB",91,0)
+ ;
+"RTN","MSCZJOB",92,0)
+ ;
+"RTN","MSCZJOB",93,0)
+ ;
+"RTN","MSCZJOB",94,0)
+ ;
+"RTN","MSCZJOB",95,0)
+TEST Q
+"RTN","MSCZJOB",96,0)
+COMPLK ;COMPUTED MULTIPLE FOR MSCZLOCK BLOCK
+"RTN","MSCZJOB",97,0)
+ N X,D0,J
+"RTN","MSCZJOB",98,0)
+ S MSC="^TMP(""MSCZJOB"")" D POLL S D0=0
+"RTN","MSCZJOB",99,0)
+ F K=0:0 S K=$O(MSCZJOB(K)) Q:'K  D
+"RTN","MSCZJOB",100,0)
+ .F J=0:0 S J=$O(^TMP("MSCZJOB",MSCZJOB(K),"L",J)) Q:'J  S A=$TR(^(J),U,"~") D
+"RTN","MSCZJOB",101,0)
+ ..S D0=D0+1,MSCZLK(D0)=$P(A,"LOCK ",2,9)_U_$$USER(K)_U_$TR($$ROUTINE(K),U,"~")_"^^"_MSCZJOB(K)
+"RTN","MSCZJOB",102,0)
+ ..S X=MSCZLK(D0) X DICMX
+"RTN","MSCZJOB",103,0)
+ Q
+"RTN","MSCZJOB",104,0)
+LOCK ;		;
+"RTN","MSCZJOB",105,0)
+ S DDSFILE=3.081,DR="[MSCZLOCK]",DDSPARM="S"
+"RTN","MSCZJOB",106,0)
+ D ^DDS Q
+"RTN","MSCZJOB",107,0)
+UNL(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
+"RTN","MSCZJOB",108,0)
+ N X,R S R=$P($G(MSCZLK(D0)),U),P=$P($G(MSCZLK(D0)),U,5) ;I R'["^" Q  ;CAN'T SEE IT
+"RTN","MSCZJOB",109,0)
+ S R=$P(R,"~",2),R="^"_$S(R'["(":$P(R," "),1:$P(R,")")_")"),X="L "_R D ^DIM Q:'$D(X)  ;GOOD SYNTAX?
+"RTN","MSCZJOB",110,0)
+ D UNLOCK^MSCZJOBU(R,P)
+"RTN","MSCZJOBU")
+0^4^B3546679
+"RTN","MSCZJOBU",1,0)
+MSCZJOBU ;RHL/MSC;26JUNE2007
+"RTN","MSCZJOBU",2,0)
+ ;;8.0;KERNEL;**MSC**
+"RTN","MSCZJOBU",3,0)
+ ;
+"RTN","MSCZJOBU",4,0)
+ ;  JOB EXAM UTILITIES FOR GT.M
+"RTN","MSCZJOBU",5,0)
+ Q
+"RTN","MSCZJOBU",6,0)
+PIDS(XARY) ; GET ARRAY OF ALL MUMPS PROCESS
+"RTN","MSCZJOBU",7,0)
+ ;  XARY PASSED BY REFERENCE
+"RTN","MSCZJOBU",8,0)
+ ;  RETURNS XARY(PID)=""
+"RTN","MSCZJOBU",9,0)
+ ;  NOTE:  Unix PID=$J for all mumps processes.
+"RTN","MSCZJOBU",10,0)
+ ;
+"RTN","MSCZJOBU",11,0)
+ N %FILE
+"RTN","MSCZJOBU",12,0)
+ S %FILE="/tmp/msczjob"_$J_".tmp"
+"RTN","MSCZJOBU",13,0)
+ ZSYSTEM "ps --no-headers -o pid= -C mumps>"_%FILE
+"RTN","MSCZJOBU",14,0)
+ O %FILE::0 Q:'$T
+"RTN","MSCZJOBU",15,0)
+ ;
+"RTN","MSCZJOBU",16,0)
+ N %I S %I=$I
+"RTN","MSCZJOBU",17,0)
+ N %J ; $JOB
+"RTN","MSCZJOBU",18,0)
+ N %LINE
+"RTN","MSCZJOBU",19,0)
+ N U S U="^"
+"RTN","MSCZJOBU",20,0)
+ F  U %FILE R %LINE U %I Q:%LINE=""  D
+"RTN","MSCZJOBU",21,0)
+ . Q:$P(%LINE,U)="PID"  ; header line
+"RTN","MSCZJOBU",22,0)
+ . S %J=$P(%LINE,U)
+"RTN","MSCZJOBU",23,0)
+ . F  Q:$E(%J,1)'=" "  S %J=$E(%J,2,999)
+"RTN","MSCZJOBU",24,0)
+ . S XARY(%J)=""
+"RTN","MSCZJOBU",25,0)
+ ;
+"RTN","MSCZJOBU",26,0)
+ C %FILE:DELETE
+"RTN","MSCZJOBU",27,0)
+ ;ZSYSTEM "rm "_$P(%FILE,".",1)_"*"
+"RTN","MSCZJOBU",28,0)
+ Q
+"RTN","MSCZJOBU",29,0)
+ ;
+"RTN","MSCZJOBU",30,0)
+ ;
+"RTN","MSCZJOBU",31,0)
+INTRPT(PID) ; SEND mupip intrpt to each process.
+"RTN","MSCZJOBU",32,0)
+        ; WHICH CAUSES THE $ZINTERRUPT CODE TO BE EXECUTED.
+"RTN","MSCZJOBU",33,0)
+ ;  PID PASSED BY VALUE
+"RTN","MSCZJOBU",34,0)
+ ;  PID CAN BE A SINGLE PID, I.E. $J
+"RTN","MSCZJOBU",35,0)
+ ;  PID CAN BE A "*" WHICH SENDS AN INTERRUPT TO ALL MUMPS PROCESSES
+"RTN","MSCZJOBU",36,0)
+ ;
+"RTN","MSCZJOBU",37,0)
+ Q:$G(PID)=""
+"RTN","MSCZJOBU",38,0)
+ ;
+"RTN","MSCZJOBU",39,0)
+ I PID="*" D  Q  ; ALL PIDS
+"RTN","MSCZJOBU",40,0)
+ . N ARRAY
+"RTN","MSCZJOBU",41,0)
+ . D PIDS(.ARRAY)
+"RTN","MSCZJOBU",42,0)
+ . N %J S %J=""
+"RTN","MSCZJOBU",43,0)
+ . F  S %J=$O(ARRAY(%J)) Q:%J=""  D 
+"RTN","MSCZJOBU",44,0)
+ . . S A="test1",c="mupip intrpt "_%J_" > /dev/null"
+"RTN","MSCZJOBU",45,0)
+ . . OPEN A:(COMM="mupip intrpt "_%J)::"PIPE" U A C A
+"RTN","MSCZJOBU",46,0)
+ . . ;ZSYSTEM "mupip intrpt "_%J_" > /dev/null"
+"RTN","MSCZJOBU",47,0)
+ ;
+"RTN","MSCZJOBU",48,0)
+ ;  JUST 1 PID
+"RTN","MSCZJOBU",49,0)
+ Q:PID'?1N.N
+"RTN","MSCZJOBU",50,0)
+ S A="test1"
+"RTN","MSCZJOBU",51,0)
+ OPEN A:(COMM="mupip intrpt "_PID)::"PIPE" U A C A
+"RTN","MSCZJOBU",52,0)
+ ;ZSYSTEM "mupip intrpt "_PID_" > /dev/null"
+"RTN","MSCZJOBU",53,0)
+ Q
+"RTN","MSCZJOBU",54,0)
+ ;
+"RTN","MSCZJOBU",55,0)
+KILL(PID) ; Send PID to mupip to kill process
+"RTN","MSCZJOBU",56,0)
+ Q:PID'?1N.N
+"RTN","MSCZJOBU",57,0)
+ X "ZSYSTEM ""mupip stop ""_PID_"" > /dev/null"""
+"RTN","MSCZJOBU",58,0)
+ Q
+"RTN","MSCZJOBU",59,0)
+ ;
+"RTN","MSCZJOBU",60,0)
+UNLOCK(NODE,PROC) ; Use lke to remove lock on NODE.
+"RTN","MSCZJOBU",61,0)
+ N X
+"RTN","MSCZJOBU",62,0)
+ S X="lke clear -lock="""_NODE_""" -nointeractive -output=/dev/null"
+"RTN","MSCZJOBU",63,0)
+ ZSYSTEM X
+"RTN","MSCZJOBU",64,0)
+ Q
+"RTN","XOBVLL")
+0^19^B18038185
+"RTN","XOBVLL",1,0)
+XOBVLL ;; mjk/alb MSC/JDA - VistALink Listen and Spawn Code ; 07/27/2002  13:00
+"RTN","XOBVLL",2,0)
+ ;;1.5;VistALink;**MSC**;Sep 09, 2005
+"RTN","XOBVLL",3,0)
+ ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
+"RTN","XOBVLL",4,0)
+ ;
+"RTN","XOBVLL",5,0)
+ QUIT
+"RTN","XOBVLL",6,0)
+ ;
+"RTN","XOBVLL",7,0)
+ ; ***deprecated*** tag ; Use START^XOBVTCP instead
+"RTN","XOBVLL",8,0)
+START(SOCKET) ; -- start listener
+"RTN","XOBVLL",9,0)
+ DO START^XOBVTCP(SOCKET)
+"RTN","XOBVLL",10,0)
+ QUIT
+"RTN","XOBVLL",11,0)
+ ;
+"RTN","XOBVLL",12,0)
+ ; ***deprecated*** tag ; Use UCX^XOBVTCP instead
+"RTN","XOBVLL",13,0)
+UCX ; -- VMS TCPIP (UCX) multi-thread entry point
+"RTN","XOBVLL",14,0)
+ ; -- Called from VistALink .com files
+"RTN","XOBVLL",15,0)
+ GOTO UCX^XOBVTCP
+"RTN","XOBVLL",16,0)
+ ;
+"RTN","XOBVLL",17,0)
+SPAWN ; -- spawned process
+"RTN","XOBVLL",18,0)
+ NEW X,XOBSTOP,XOBPORT,XOBHDLR,XOBLASTR
+"RTN","XOBVLL",19,0)
+ ;
+"RTN","XOBVLL",20,0)
+ SET XOBSTOP=0
+"RTN","XOBVLL",21,0)
+ SET XOBPORT=IO
+"RTN","XOBVLL",22,0)
+ SET U="^"
+"RTN","XOBVLL",23,0)
+ ;
+"RTN","XOBVLL",24,0)
+ ; -- initialize timestamp for last time request made (used for debugging)
+"RTN","XOBVLL",25,0)
+ SET XOBLASTR=0
+"RTN","XOBVLL",26,0)
+ ;
+"RTN","XOBVLL",27,0)
+ ; -- set error trap
+"RTN","XOBVLL",28,0)
+ ;Set up the error trap
+"RTN","XOBVLL",29,0)
+ SET $ETRAP="DO ^%ZTER HALT"
+"RTN","XOBVLL",30,0)
+ ;
+"RTN","XOBVLL",31,0)
+ ; -- attempt to share the license; must have TCP port open first
+"RTN","XOBVLL",32,0)
+ USE XOBPORT IF $TEXT(SHARELIC^%ZOSV)'="" DO SHARELIC^%ZOSV(1)
+"RTN","XOBVLL",33,0)
+ ;
+"RTN","XOBVLL",34,0)
+ ; -- start RUM for VistALink Handler
+"RTN","XOBVLL",35,0)
+ DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
+"RTN","XOBVLL",36,0)
+ ;
+"RTN","XOBVLL",37,0)
+ SET:^%ZOSF("OS")["GT.M" X=$$GTM^XOBVRH(.XOBHDLR)
+"RTN","XOBVLL",38,0)
+ ; -- cache/initialize startup request handlers 
+"RTN","XOBVLL",39,0)
+ SET:^%ZOSF("OS")["OpenM" X=$$CACHE^XOBVRH(.XOBHDLR)
+"RTN","XOBVLL",40,0)
+ IF 'X DO RMERR^XOBVRM(184001,$PIECE(X,U,2)) QUIT
+"RTN","XOBVLL",41,0)
+ ;
+"RTN","XOBVLL",42,0)
+ ; -- initialize tcp processing variables
+"RTN","XOBVLL",43,0)
+ DO INIT^XOBVSKT
+"RTN","XOBVLL",44,0)
+ ;
+"RTN","XOBVLL",45,0)
+ ; -- change job name if possible
+"RTN","XOBVLL",46,0)
+ DO SETNM^%ZOSV("VLink_"_$$CNV^XLFUTL($J,16))
+"RTN","XOBVLL",47,0)
+ ;
+"RTN","XOBVLL",48,0)
+ ; -- loop until told to stop
+"RTN","XOBVLL",49,0)
+ FOR  DO NXTCALL QUIT:XOBSTOP
+"RTN","XOBVLL",50,0)
+ ;
+"RTN","XOBVLL",51,0)
+ ; -- final/clean tcp processing variables
+"RTN","XOBVLL",52,0)
+ DO FINAL^XOBVSKT
+"RTN","XOBVLL",53,0)
+ ;
+"RTN","XOBVLL",54,0)
+ ; -- stop RUM for VistALink Handler
+"RTN","XOBVLL",55,0)
+ DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,2)
+"RTN","XOBVLL",56,0)
+ ;
+"RTN","XOBVLL",57,0)
+ QUIT
+"RTN","XOBVLL",58,0)
+ ;
+"RTN","XOBVLL",59,0)
+NXTCALL ; -- do next call
+"RTN","XOBVLL",60,0)
+ NEW X,XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBOK,XOBRL,XOBDATA
+"RTN","XOBVLL",61,0)
+ ;
+"RTN","XOBVLL",62,0)
+ ; -- set up error trap
+"RTN","XOBVLL",63,0)
+ NEW $ESTACK SET $ETRAP="DO SYSERR^XOBVLL"
+"RTN","XOBVLL",64,0)
+ ;
+"RTN","XOBVLL",65,0)
+ ; -- setup environment variables
+"RTN","XOBVLL",66,0)
+ NEW DIQUIET SET DIQUIET=1
+"RTN","XOBVLL",67,0)
+ SET U="^",DTIME=$GET(DTIME,900),DT=$$DT^XLFDT()
+"RTN","XOBVLL",68,0)
+ ;
+"RTN","XOBVLL",69,0)
+ ; -- initialize 'current' request handler to empty string
+"RTN","XOBVLL",70,0)
+ SET XOBHDLR=""
+"RTN","XOBVLL",71,0)
+ ;
+"RTN","XOBVLL",72,0)
+ ; -- # of chars to get on first read / read 11 for Broker initial read
+"RTN","XOBVLL",73,0)
+ SET XOBREAD=11
+"RTN","XOBVLL",74,0)
+ ;
+"RTN","XOBVLL",75,0)
+ ; -- get J2SE heartbet rate for timeout plus network latency factor
+"RTN","XOBVLL",76,0)
+ SET XOBTO=$$GETRATE^XOBVLIB()+$$GETDELTA^XOBVLIB()
+"RTN","XOBVLL",77,0)
+ ;
+"RTN","XOBVLL",78,0)
+ ; -- get J2EE timeout value for app serv environment
+"RTN","XOBVLL",79,0)
+ IF $GET(XOBSYS("ENV"))="j2ee" SET XOBTO=$$GETASTO^XOBVLIB()
+"RTN","XOBVLL",80,0)
+ ;
+"RTN","XOBVLL",81,0)
+ ; -- set first read flag
+"RTN","XOBVLL",82,0)
+ SET XOBFIRST=1
+"RTN","XOBVLL",83,0)
+ ;
+"RTN","XOBVLL",84,0)
+ ; -- setup intake global
+"RTN","XOBVLL",85,0)
+ SET XOBROOT=$NAME(^TMP("XOBVLL",$JOB))
+"RTN","XOBVLL",86,0)
+ KILL @XOBROOT
+"RTN","XOBVLL",87,0)
+ ;
+"RTN","XOBVLL",88,0)
+ ; -- read from socket port
+"RTN","XOBVLL",89,0)
+ USE XOBPORT
+"RTN","XOBVLL",90,0)
+ SET XOBOK=$$READ^XOBVSKT(XOBROOT,.XOBREAD,.XOBTO,.XOBFIRST,.XOBSTOP,.XOBDATA,.XOBHDLR)
+"RTN","XOBVLL",91,0)
+ ;
+"RTN","XOBVLL",92,0)
+ ; -- timed out ; cleanup user and exit
+"RTN","XOBVLL",93,0)
+ IF 'XOBOK!(XOBSTOP) DO  GOTO NXTCALLQ
+"RTN","XOBVLL",94,0)
+ . IF $GET(DUZ) DO CLEAN^XOBSCAV1
+"RTN","XOBVLL",95,0)
+ . SET XOBSTOP=1
+"RTN","XOBVLL",96,0)
+ ;
+"RTN","XOBVLL",97,0)
+ ; -- need null device
+"RTN","XOBVLL",98,0)
+ IF '$DATA(XOBNULL) DO ERROR(181002,$$EZBLD^DIALOG(181002),XOBPORT) SET XOBSTOP=1 GOTO NXTCALLQ
+"RTN","XOBVLL",99,0)
+ ;
+"RTN","XOBVLL",100,0)
+ ; -- call request manager                   
+"RTN","XOBVLL",101,0)
+ SET XOBOK=$$EN^XOBVRM(XOBROOT,.XOBDATA,.XOBHDLR)
+"RTN","XOBVLL",102,0)
+ ; -- timestamp last time request made
+"RTN","XOBVLL",103,0)
+ SET XOBLASTR=$$NOW^XLFDT()
+"RTN","XOBVLL",104,0)
+ ; -- cleanup intake global
+"RTN","XOBVLL",105,0)
+ KILL @XOBROOT
+"RTN","XOBVLL",106,0)
+ ;
+"RTN","XOBVLL",107,0)
+NXTCALLQ ; -- exit
+"RTN","XOBVLL",108,0)
+ QUIT
+"RTN","XOBVLL",109,0)
+ ;
+"RTN","XOBVLL",110,0)
+ ; ----------------------------------------------------------------------------------
+"RTN","XOBVLL",111,0)
+ ;                                System Error Handler
+"RTN","XOBVLL",112,0)
+ ; ----------------------------------------------------------------------------------
+"RTN","XOBVLL",113,0)
+SYSERR ; -- send system error message
+"RTN","XOBVLL",114,0)
+ ; -- If we get an error in the error handler just Halt
+"RTN","XOBVLL",115,0)
+ SET $ETRAP="D ^%ZTER HALT"
+"RTN","XOBVLL",116,0)
+ ;
+"RTN","XOBVLL",117,0)
+ DO ERROR(181001,$$EZBLD^DIALOG(181001,$$EC^%ZOSV),XOBPORT)      ; -- Get the error code
+"RTN","XOBVLL",118,0)
+ QUIT
+"RTN","XOBVLL",119,0)
+ ;
+"RTN","XOBVLL",120,0)
+ERROR(XOBEC,XOBMSG,XOBPORT) ; -- send error message
+"RTN","XOBVLL",121,0)
+ NEW XOBDAT
+"RTN","XOBVLL",122,0)
+ ;
+"RTN","XOBVLL",123,0)
+ ; -- If we get an error in the error handler just Halt
+"RTN","XOBVLL",124,0)
+ SET $ETRAP="D ^%ZTER HALT"
+"RTN","XOBVLL",125,0)
+ ;
+"RTN","XOBVLL",126,0)
+ ; -- set up error info
+"RTN","XOBVLL",127,0)
+ SET XOBDAT("MESSAGE TYPE")=3
+"RTN","XOBVLL",128,0)
+ SET XOBDAT("ERRORS",1,"CODE")=XOBEC
+"RTN","XOBVLL",129,0)
+ SET XOBDAT("ERRORS",1,"ERROR TYPE")="system"
+"RTN","XOBVLL",130,0)
+ SET XOBDAT("ERRORS",1,"FAULT STRING")="System Error"
+"RTN","XOBVLL",131,0)
+ SET XOBDAT("ERRORS",1,"CDATA")=1
+"RTN","XOBVLL",132,0)
+ SET XOBDAT("ERRORS",1,"MESSAGE",1)=XOBMSG
+"RTN","XOBVLL",133,0)
+ ;
+"RTN","XOBVLL",134,0)
+ ; -- if serious error, save error info, logout, and halt
+"RTN","XOBVLL",135,0)
+ IF XOBMSG["<READ>"!(XOBMSG["<WRITE>")!(XOBMSG["<SYSTEM>")!(XOBMSG["READERR")!(XOBMSG["WRITERR")!(XOBMSG["SYSERR") DO  HALT
+"RTN","XOBVLL",136,0)
+ . DO ^%ZTER
+"RTN","XOBVLL",137,0)
+ . IF $GET(DUZ) DO CLEAN^XOBSCAV1
+"RTN","XOBVLL",138,0)
+ ;
+"RTN","XOBVLL",139,0)
+ ; -- send error back to client
+"RTN","XOBVLL",140,0)
+ USE XOBPORT
+"RTN","XOBVLL",141,0)
+ DO ERROR^XOBVLIB(.XOBDAT)
+"RTN","XOBVLL",142,0)
+ ;
+"RTN","XOBVLL",143,0)
+ ; -- just quit if no slots are available or logins are disabled
+"RTN","XOBVLL",144,0)
+ IF (XOBEC=181003)!(XOBEC=181004) QUIT
+"RTN","XOBVLL",145,0)
+ ;
+"RTN","XOBVLL",146,0)
+ ; -- need to make sure any locks are released since code aborted ungracefully
+"RTN","XOBVLL",147,0)
+ LOCK
+"RTN","XOBVLL",148,0)
+ ;
+"RTN","XOBVLL",149,0)
+ ; -- Save off the error
+"RTN","XOBVLL",150,0)
+ DO ^%ZTER
+"RTN","XOBVLL",151,0)
+ ;
+"RTN","XOBVLL",152,0)
+ ; -- go back to listening
+"RTN","XOBVLL",153,0)
+ SET $ETRAP="Q:($ESTACK&'$QUIT)  Q:$ESTACK -9 S $ECODE="""" DO KILL^XOBVLL G NXTCALLQ^XOBVLL",$ECODE=",U99,"
+"RTN","XOBVLL",154,0)
+ QUIT
+"RTN","XOBVLL",155,0)
+ ;
+"RTN","XOBVLL",156,0)
+KILL ; -- new VistALink variables and then do big KILL
+"RTN","XOBVLL",157,0)
+ NEW XOBPORT,XOBSTOP,XOBNULL,XOBOS,XOBSYS,XOBHDLR,XOBOK
+"RTN","XOBVLL",158,0)
+ DO KILL^XUSCLEAN
+"RTN","XOBVLL",159,0)
+ QUIT
+"RTN","XOBVLL",160,0)
+ ;
+"RTN","XOBVRH")
+0^20^B13028891
+"RTN","XOBVRH",1,0)
+XOBVRH ;mjk/alb SC/JDA - VistaLink Request Handler Utilities ; 07/27/2002  13:00
+"RTN","XOBVRH",2,0)
+ ;;1.5;VistALink;**MSC**;Sep 09, 2005
+"RTN","XOBVRH",3,0)
+ ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
+"RTN","XOBVRH",4,0)
+ ;
+"RTN","XOBVRH",5,0)
+ QUIT
+"RTN","XOBVRH",6,0)
+ ;
+"RTN","XOBVRH",7,0)
+ ; ------------------------------------------------------------------
+"RTN","XOBVRH",8,0)
+ ;                       Message Type Handler Utilities
+"RTN","XOBVRH",9,0)
+ ; ------------------------------------------------------------------
+"RTN","XOBVRH",10,0)
+ ; 
+"RTN","XOBVRH",11,0)
+ ; -- set up msg type info using message name
+"RTN","XOBVRH",12,0)
+MSGNAME(XOBMSG,XOBHDLR) ; -- set up msg type info
+"RTN","XOBVRH",13,0)
+ QUIT $$SETMSG(XOBMSG,"NAME",.XOBHDLR)
+"RTN","XOBVRH",14,0)
+ ;
+"RTN","XOBVRH",15,0)
+ ; -- set up msg type info using message type
+"RTN","XOBVRH",16,0)
+MSGTYPE(XOBMSG,XOBHDLR) ; -- set up msg type info
+"RTN","XOBVRH",17,0)
+ QUIT $$SETMSG(XOBMSG,"MSGTYPE",.XOBHDLR)
+"RTN","XOBVRH",18,0)
+ ;
+"RTN","XOBVRH",19,0)
+ ; -- set up msg type info using proprietary string
+"RTN","XOBVRH",20,0)
+MSGSINK(XOBMSG,XOBHDLR) ; -- set up msg type info
+"RTN","XOBVRH",21,0)
+ QUIT $$SETMSG(XOBMSG,"D",.XOBHDLR)
+"RTN","XOBVRH",22,0)
+ ;
+"RTN","XOBVRH",23,0)
+CACHE(XOBHDLR) ; -- cache req handlers
+"RTN","XOBVRH",24,0)
+ NEW TYPE,TYPE0,XOBOK
+"RTN","XOBVRH",25,0)
+ SET TYPE=0
+"RTN","XOBVRH",26,0)
+ SET XOBOK=1
+"RTN","XOBVRH",27,0)
+ ;
+"RTN","XOBVRH",28,0)
+ ; -- load request handler info
+"RTN","XOBVRH",29,0)
+ FOR  SET TYPE=$ORDER(^XOB(18.05,"AS",1,TYPE)) QUIT:'TYPE  DO  QUIT:'XOBOK
+"RTN","XOBVRH",30,0)
+ . SET TYPE0=$GET(^XOB(18.05,TYPE,0))
+"RTN","XOBVRH",31,0)
+ . DO SET(TYPE,TYPE0,.XOBHDLR)
+"RTN","XOBVRH",32,0)
+ . SET XOBOK=$GET(XOBHDLR(TYPE))
+"RTN","XOBVRH",33,0)
+ . IF 'XOBOK SET XOBOK=XOBOK_U_$GET(XOBHDLR,"ERROR")
+"RTN","XOBVRH",34,0)
+ QUIT XOBOK
+"RTN","XOBVRH",35,0)
+ ;
+"RTN","XOBVRH",36,0)
+ ;
+"RTN","XOBVRH",37,0)
+GTM(XOBHDLR) ; -- GT.M req handlers
+"RTN","XOBVRH",38,0)
+ Q $$CACHE(.XOBHDLR) ; Same as Cache until something different is needed
+"RTN","XOBVRH",39,0)
+ ;
+"RTN","XOBVRH",40,0)
+ ;  -- set up msg type info
+"RTN","XOBVRH",41,0)
+SETMSG(XOBMSG,XOBXREF,XOBHDLR) ;
+"RTN","XOBVRH",42,0)
+ NEW TYPE,TYPEO
+"RTN","XOBVRH",43,0)
+ KILL XOBHDLR(0)
+"RTN","XOBVRH",44,0)
+ ;
+"RTN","XOBVRH",45,0)
+ ; -- already cached?
+"RTN","XOBVRH",46,0)
+ SET TYPE=$ORDER(XOBHDLR(XOBXREF,XOBMSG,""))
+"RTN","XOBVRH",47,0)
+ IF TYPE QUIT TYPE
+"RTN","XOBVRH",48,0)
+ ;
+"RTN","XOBVRH",49,0)
+ ; -- load req handler
+"RTN","XOBVRH",50,0)
+ SET TYPE=+$ORDER(^XOB(18.05,XOBXREF,XOBMSG,""))
+"RTN","XOBVRH",51,0)
+ IF TYPE DO
+"RTN","XOBVRH",52,0)
+ . SET TYPE0=$GET(^XOB(18.05,TYPE,0))
+"RTN","XOBVRH",53,0)
+ . DO SET(.TYPE,.TYPE0,.XOBHDLR)
+"RTN","XOBVRH",54,0)
+ IF 'TYPE DO
+"RTN","XOBVRH",55,0)
+ . SET XOBHDLR(0)=0
+"RTN","XOBVRH",56,0)
+ . SET XOBHDLR(0,"ERROR")="No message type defined"
+"RTN","XOBVRH",57,0)
+ QUIT TYPE
+"RTN","XOBVRH",58,0)
+ ;
+"RTN","XOBVRH",59,0)
+SET(TYPE,TYPE0,XOBHDLR) ; -- set nodes
+"RTN","XOBVRH",60,0)
+ NEW IRTN,XOBICBK
+"RTN","XOBVRH",61,0)
+ KILL XOBHDLR(TYPE)
+"RTN","XOBVRH",62,0)
+ SET IRTN=$$IRTN(TYPE0)
+"RTN","XOBVRH",63,0)
+ IF IRTN="" DO  GOTO SETQ
+"RTN","XOBVRH",64,0)
+ . SET XOBHDLR(TYPE)=0
+"RTN","XOBVRH",65,0)
+ . IF TYPE0="" SET XOBHDLR(TYPE,"ERROR")="No entry for message type ["_TYPE_"]" QUIT
+"RTN","XOBVRH",66,0)
+ . IF IRTN="" SET XOBHDLR(TYPE,"ERROR")="Invalid interface routine specified ["_$PIECE(TYPE0,U,5)_"]" QUIT
+"RTN","XOBVRH",67,0)
+ ;
+"RTN","XOBVRH",68,0)
+ SET XOBHDLR(TYPE)=1
+"RTN","XOBVRH",69,0)
+ SET XOBHDLR(TYPE,"AUTHENTICATE")=+$PIECE(TYPE0,U,4)
+"RTN","XOBVRH",70,0)
+ SET XOBHDLR(TYPE,"REQHDLR")="DO REQHDLR^"_IRTN_"(.XOBDATA)"
+"RTN","XOBVRH",71,0)
+ SET XOBHDLR(TYPE,"READER")="DO READER^"_IRTN_"(.XOBX,.XOBDATA)"
+"RTN","XOBVRH",72,0)
+ IF $PIECE(TYPE0,U,1)]"" SET XOBHDLR("NAME",$PIECE(TYPE0,U,1),TYPE)=""
+"RTN","XOBVRH",73,0)
+ IF $PIECE(TYPE0,U,2)]"" SET XOBHDLR("MSGTYPE",$PIECE(TYPE0,U,2),TYPE)=""
+"RTN","XOBVRH",74,0)
+ IF $PIECE(TYPE0,U,7)]"" SET XOBHDLR("D",$PIECE(TYPE0,U,7),TYPE)=""
+"RTN","XOBVRH",75,0)
+ ;
+"RTN","XOBVRH",76,0)
+ ; -- set up SAX callbacks
+"RTN","XOBVRH",77,0)
+ SET XOBHDLR(TYPE,"CB","ELEST")="QUIT"
+"RTN","XOBVRH",78,0)
+ SET XOBHDLR(TYPE,"CB","ELEND")="QUIT"
+"RTN","XOBVRH",79,0)
+ SET XOBHDLR(TYPE,"CB","CHR")="QUIT"
+"RTN","XOBVRH",80,0)
+ ;
+"RTN","XOBVRH",81,0)
+ XECUTE "DO CALLBACK^"_IRTN_"(.XOBICBK)"
+"RTN","XOBVRH",82,0)
+ IF $DATA(XOBICBK("STARTELEMENT")) SET XOBHDLR(TYPE,"CB","ELEST")="DO "_XOBICBK("STARTELEMENT")_"(.ELE,.ATR)"
+"RTN","XOBVRH",83,0)
+ IF $DATA(XOBICBK("ENDELEMENT")) SET XOBHDLR(TYPE,"CB","ELEND")="DO "_XOBICBK("ENDELEMENT")_"(.ELE)"
+"RTN","XOBVRH",84,0)
+ IF $DATA(XOBICBK("CHARACTERS")) SET XOBHDLR(TYPE,"CB","CHR")="DO "_XOBICBK("CHARACTERS")_"(.TXT)"
+"RTN","XOBVRH",85,0)
+SETQ ;
+"RTN","XOBVRH",86,0)
+ QUIT
+"RTN","XOBVRH",87,0)
+ ;
+"RTN","XOBVRH",88,0)
+ ; -- get interface routine and test for existence
+"RTN","XOBVRH",89,0)
+IRTN(XOBTYPE0) ;
+"RTN","XOBVRH",90,0)
+ NEW X,RTN
+"RTN","XOBVRH",91,0)
+ SET RTN=""
+"RTN","XOBVRH",92,0)
+ SET X=$PIECE(XOBTYPE0,"^",5)
+"RTN","XOBVRH",93,0)
+ IF X]"" DO
+"RTN","XOBVRH",94,0)
+ . XECUTE ^%ZOSF("TEST")
+"RTN","XOBVRH",95,0)
+ . IF $TEST SET RTN=X
+"RTN","XOBVRH",96,0)
+ QUIT RTN
+"RTN","XOBVRH",97,0)
+ ;
+"RTN","XOBVSKT")
+0^21^B19778790
+"RTN","XOBVSKT",1,0)
+XOBVSKT ;; mjk/alb MSC/JDA- VistaLink Socket Methods ; 07/27/2002  13:00
+"RTN","XOBVSKT",2,0)
+ ;;1.5;VistALink;**MSC**;Sep 09, 2005
+"RTN","XOBVSKT",3,0)
+ ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
+"RTN","XOBVSKT",4,0)
+ ;
+"RTN","XOBVSKT",5,0)
+ QUIT
+"RTN","XOBVSKT",6,0)
+ ;
+"RTN","XOBVSKT",7,0)
+ ; ------------------------------------------------------------------------------------
+"RTN","XOBVSKT",8,0)
+ ;                          Methods for Read fromto TCP/IP Socket
+"RTN","XOBVSKT",9,0)
+ ; ------------------------------------------------------------------------------------
+"RTN","XOBVSKT",10,0)
+READ(XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBSTOP,XOBDATA,XOBHDLR) ;
+"RTN","XOBVSKT",11,0)
+ NEW X,EOT,OUT,STR,LINE,PIECES,DONE,TOFLAG,XOBCNT,XOBLEN,XOBBH,XOBEH,BS,ES,XOBOK,XOBX
+"RTN","XOBVSKT",12,0)
+ ;
+"RTN","XOBVSKT",13,0)
+ SET STR="",EOT=$CHAR(4),DONE=0,LINE=0,XOBOK=1
+"RTN","XOBVSKT",14,0)
+ ;
+"RTN","XOBVSKT",15,0)
+ ; -- READ tcp stream to global buffer | main calling tag NXTCALL^XOBVLL
+"RTN","XOBVSKT",16,0)
+ FOR  READ XOBX#XOBREAD:XOBTO SET TOFLAG=$TEST DO:XOBFIRST CHK DO:'XOBSTOP!('DONE)  QUIT:DONE
+"RTN","XOBVSKT",17,0)
+ . ;
+"RTN","XOBVSKT",18,0)
+ . ; -- if length of (new intake + current) is too large for buffer then store current
+"RTN","XOBVSKT",19,0)
+ . IF $LENGTH(STR)+$LENGTH(XOBX)>400 DO ADD(STR) SET STR=""
+"RTN","XOBVSKT",20,0)
+ . SET STR=STR_XOBX
+"RTN","XOBVSKT",21,0)
+ . ;
+"RTN","XOBVSKT",22,0)
+ . ; -- add node at each line-feed character
+"RTN","XOBVSKT",23,0)
+ . ; COMMENTED OUT: Not needed anymore, and has side effect of stripping out line feeds in input
+"RTN","XOBVSKT",24,0)
+ . ;                array-type parameter values (in XML mode)
+"RTN","XOBVSKT",25,0)
+ . ; FOR  QUIT:STR'[$CHAR(10)  DO ADD($PIECE(STR,$CHAR(10))) SET STR=$PIECE(STR,$CHAR(10),2,999)
+"RTN","XOBVSKT",26,0)
+ . ;
+"RTN","XOBVSKT",27,0)
+ . ; -- if end-of-text marker found then wrap up and quit
+"RTN","XOBVSKT",28,0)
+ . IF STR[EOT SET STR=$PIECE(STR,EOT) DO ADD(STR) SET DONE=1 QUIT
+"RTN","XOBVSKT",29,0)
+ . ; 
+"RTN","XOBVSKT",30,0)
+ . ; -- M XML parser cannot handle an element name split across nodes
+"RTN","XOBVSKT",31,0)
+ . SET PIECES=$LENGTH(STR,">")
+"RTN","XOBVSKT",32,0)
+ . IF PIECES>1 DO ADD($PIECE(STR,">",1,PIECES-1)_">") SET STR=$PIECE(STR,">",PIECES,999)
+"RTN","XOBVSKT",33,0)
+ ;
+"RTN","XOBVSKT",34,0)
+ QUIT XOBOK
+"RTN","XOBVSKT",35,0)
+ ;
+"RTN","XOBVSKT",36,0)
+ADD(TXT) ; -- add new intake line
+"RTN","XOBVSKT",37,0)
+ SET LINE=LINE+1
+"RTN","XOBVSKT",38,0)
+ SET @XOBROOT@(LINE)=TXT
+"RTN","XOBVSKT",39,0)
+ QUIT
+"RTN","XOBVSKT",40,0)
+ ;
+"RTN","XOBVSKT",41,0)
+CHK ; -- check if first read and change timeout and chars to read
+"RTN","XOBVSKT",42,0)
+ SET XOBFIRST=0
+"RTN","XOBVSKT",43,0)
+ ;
+"RTN","XOBVSKT",44,0)
+ ; -- abort if time out occurred and nothing was read
+"RTN","XOBVSKT",45,0)
+ IF 'TOFLAG,$GET(XOBX)="" SET XOBSTOP=1,DONE=1,XOBOK=0 QUIT
+"RTN","XOBVSKT",46,0)
+ ;
+"RTN","XOBVSKT",47,0)
+ ; -- intercept for transport sinks
+"RTN","XOBVSKT",48,0)
+ IF $EXTRACT(XOBX)'="<" DO SINK
+"RTN","XOBVSKT",49,0)
+ ;
+"RTN","XOBVSKT",50,0)
+ ; -- set up for subsequent reads
+"RTN","XOBVSKT",51,0)
+ SET XOBREAD=200,XOBTO=1
+"RTN","XOBVSKT",52,0)
+ QUIT
+"RTN","XOBVSKT",53,0)
+ ;
+"RTN","XOBVSKT",54,0)
+ ; ------------------------------------------------------------------------------------
+"RTN","XOBVSKT",55,0)
+ ;                      Execute Proprietary Format Reader
+"RTN","XOBVSKT",56,0)
+ ; ------------------------------------------------------------------------------------
+"RTN","XOBVSKT",57,0)
+SINK ;
+"RTN","XOBVSKT",58,0)
+ ; -- get size of sink indicator >> then get sink indicator >> load req handler
+"RTN","XOBVSKT",59,0)
+ SET XOBHDLR=$$MSGSINK^XOBVRH($$GETSTR(+$$GETSTR(2,.XOBX),.XOBX),.XOBHDLR)
+"RTN","XOBVSKT",60,0)
+ ;
+"RTN","XOBVSKT",61,0)
+ ; -- execute proprietary stream reader
+"RTN","XOBVSKT",62,0)
+ IF $GET(XOBHDLR(XOBHDLR)) XECUTE $GET(XOBHDLR(XOBHDLR,"READER"))
+"RTN","XOBVSKT",63,0)
+ ;
+"RTN","XOBVSKT",64,0)
+ SET DONE=1
+"RTN","XOBVSKT",65,0)
+ QUIT
+"RTN","XOBVSKT",66,0)
+ ;
+"RTN","XOBVSKT",67,0)
+ ; -- get string of length LEN from stream buffer
+"RTN","XOBVSKT",68,0)
+GETSTR(LEN,XOBUF) ;
+"RTN","XOBVSKT",69,0)
+ NEW X
+"RTN","XOBVSKT",70,0)
+ FOR  QUIT:($LENGTH(XOBUF)'<LEN)  DO RMORE(LEN-$LENGTH(XOBUF),.XOBUF)
+"RTN","XOBVSKT",71,0)
+ SET X=$EXTRACT(XOBUF,1,LEN)
+"RTN","XOBVSKT",72,0)
+ SET XOBUF=$EXTRACT(XOBUF,LEN+1,999)
+"RTN","XOBVSKT",73,0)
+ QUIT X
+"RTN","XOBVSKT",74,0)
+ ;
+"RTN","XOBVSKT",75,0)
+ ; -- read more from stream buffer but only needed amount
+"RTN","XOBVSKT",76,0)
+RMORE(LEN,XOBUF) ;
+"RTN","XOBVSKT",77,0)
+ NEW X
+"RTN","XOBVSKT",78,0)
+ READ X#LEN:1 SET XOBUF=XOBUF_X
+"RTN","XOBVSKT",79,0)
+ QUIT
+"RTN","XOBVSKT",80,0)
+ ;
+"RTN","XOBVSKT",81,0)
+ ; ------------------------------------------------------------------------------------
+"RTN","XOBVSKT",82,0)
+ ;                      Methods for Openning and Closing Socket
+"RTN","XOBVSKT",83,0)
+ ; ------------------------------------------------------------------------------------
+"RTN","XOBVSKT",84,0)
+OPEN(XOBPARMS) ; -- Open tcp/ip socket
+"RTN","XOBVSKT",85,0)
+ NEW I,POP
+"RTN","XOBVSKT",86,0)
+ SET POP=1
+"RTN","XOBVSKT",87,0)
+ ;
+"RTN","XOBVSKT",88,0)
+ ; -- set up os var
+"RTN","XOBVSKT",89,0)
+ DO OS
+"RTN","XOBVSKT",90,0)
+ ;
+"RTN","XOBVSKT",91,0)
+ ; -- preserve client io
+"RTN","XOBVSKT",92,0)
+ DO SAVDEV^%ZISUTL("XOB CLIENT")
+"RTN","XOBVSKT",93,0)
+ ;
+"RTN","XOBVSKT",94,0)
+ FOR I=1:1:XOBPARMS("RETRIES") DO CALL^%ZISTCP(XOBPARMS("ADDRESS"),XOBPARMS("PORT")) QUIT:'POP
+"RTN","XOBVSKT",95,0)
+ ; -- device open
+"RTN","XOBVSKT",96,0)
+ IF 'POP USE IO QUIT 1
+"RTN","XOBVSKT",97,0)
+ ; -- device not open
+"RTN","XOBVSKT",98,0)
+ QUIT 0
+"RTN","XOBVSKT",99,0)
+ ;
+"RTN","XOBVSKT",100,0)
+CLOSE(XOBPARMS) ; -- close tcp/ip socket
+"RTN","XOBVSKT",101,0)
+ ; -- tell server to Stop() connection if close message is needed to close
+"RTN","XOBVSKT",102,0)
+ IF $GET(XOBPARMS("CLOSE MESSAGE"))]"" DO
+"RTN","XOBVSKT",103,0)
+ . DO PRE
+"RTN","XOBVSKT",104,0)
+ . DO WRITE($$XMLHDR^XOBVLIB()_XOBPARMS("CLOSE MESSAGE"))
+"RTN","XOBVSKT",105,0)
+ . DO POST
+"RTN","XOBVSKT",106,0)
+ ;
+"RTN","XOBVSKT",107,0)
+ DO FINAL
+"RTN","XOBVSKT",108,0)
+ DO CLOSE^%ZISTCP
+"RTN","XOBVSKT",109,0)
+ DO USE^%ZISUTL("XOB CLIENT")
+"RTN","XOBVSKT",110,0)
+ DO RMDEV^%ZISUTL("XOB CLIENT")
+"RTN","XOBVSKT",111,0)
+ QUIT
+"RTN","XOBVSKT",112,0)
+ ;
+"RTN","XOBVSKT",113,0)
+INIT ; -- set up variables needed in tcp/ip processing
+"RTN","XOBVSKT",114,0)
+ KILL XOBNULL
+"RTN","XOBVSKT",115,0)
+ ;
+"RTN","XOBVSKT",116,0)
+ ; -- setup os var
+"RTN","XOBVSKT",117,0)
+ DO OS
+"RTN","XOBVSKT",118,0)
+ ;
+"RTN","XOBVSKT",119,0)
+ ; -- set RPC Broker os variable (so $$BROKER^XWBLIB returns true)
+"RTN","XOBVSKT",120,0)
+ SET XWBOS=XOBOS
+"RTN","XOBVSKT",121,0)
+ ;
+"RTN","XOBVSKT",122,0)
+ ; -- setup null device called "NULL"
+"RTN","XOBVSKT",123,0)
+ SET %ZIS="0H",IOP="NULL" DO ^%ZIS
+"RTN","XOBVSKT",124,0)
+ IF 'POP DO
+"RTN","XOBVSKT",125,0)
+ . SET XOBNULL=IO
+"RTN","XOBVSKT",126,0)
+ . DO SAVDEV^%ZISUTL("XOBNULL")
+"RTN","XOBVSKT",127,0)
+ QUIT
+"RTN","XOBVSKT",128,0)
+ ;
+"RTN","XOBVSKT",129,0)
+OS ; -- os var
+"RTN","XOBVSKT",130,0)
+ SET XOBOS=$SELECT(^%ZOSF("OS")["OpenM":"OpenM",^("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["MSM":"MSM",1:"")
+"RTN","XOBVSKT",131,0)
+ QUIT
+"RTN","XOBVSKT",132,0)
+ ;
+"RTN","XOBVSKT",133,0)
+FINAL ; -- kill variables used in tcp/ip processing
+"RTN","XOBVSKT",134,0)
+ ;
+"RTN","XOBVSKT",135,0)
+ ; -- close null device
+"RTN","XOBVSKT",136,0)
+ IF $DATA(XOBNULL) DO
+"RTN","XOBVSKT",137,0)
+ . DO USE^%ZISUTL("XOBNULL")
+"RTN","XOBVSKT",138,0)
+ . DO CLOSE^%ZISUTL("XOBNULL")
+"RTN","XOBVSKT",139,0)
+ . KILL XOBNULL
+"RTN","XOBVSKT",140,0)
+ ;
+"RTN","XOBVSKT",141,0)
+ KILL XOBOS,XWBOS
+"RTN","XOBVSKT",142,0)
+ ;
+"RTN","XOBVSKT",143,0)
+ QUIT
+"RTN","XOBVSKT",144,0)
+ ;
+"RTN","XOBVSKT",145,0)
+ ; ------------------------------------------------------------------------------------
+"RTN","XOBVSKT",146,0)
+ ;                          Methods for Writing to TCP/IP Socket
+"RTN","XOBVSKT",147,0)
+ ; ------------------------------------------------------------------------------------
+"RTN","XOBVSKT",148,0)
+PRE ; -- prepare socket for writing
+"RTN","XOBVSKT",149,0)
+ SET $X=0
+"RTN","XOBVSKT",150,0)
+ QUIT
+"RTN","XOBVSKT",151,0)
+ ;
+"RTN","XOBVSKT",152,0)
+WRITE(STR) ; -- Write a data string to socket
+"RTN","XOBVSKT",153,0)
+ IF XOBOS="MSM" WRITE STR QUIT
+"RTN","XOBVSKT",154,0)
+ ; 
+"RTN","XOBVSKT",155,0)
+ ; -- handle a short string
+"RTN","XOBVSKT",156,0)
+ IF $LENGTH(STR)<511 DO:($X+$LENGTH(STR))>511 FLUSH WRITE STR QUIT
+"RTN","XOBVSKT",157,0)
+ ;
+"RTN","XOBVSKT",158,0)
+ ; -- handle a long string
+"RTN","XOBVSKT",159,0)
+ DO FLUSH
+"RTN","XOBVSKT",160,0)
+ FOR  QUIT:'$LENGTH(STR)  WRITE $EXTRACT(STR,1,511) DO FLUSH SET STR=$EXTRACT(STR,512,99999)
+"RTN","XOBVSKT",161,0)
+ ;
+"RTN","XOBVSKT",162,0)
+ QUIT
+"RTN","XOBVSKT",163,0)
+ ;
+"RTN","XOBVSKT",164,0)
+POST ; -- send eot and flush socket buffer
+"RTN","XOBVSKT",165,0)
+ DO WRITE($CHAR(4))
+"RTN","XOBVSKT",166,0)
+ DO FLUSH
+"RTN","XOBVSKT",167,0)
+ QUIT
+"RTN","XOBVSKT",168,0)
+ ;
+"RTN","XOBVSKT",169,0)
+FLUSH ; flush buffer
+"RTN","XOBVSKT",170,0)
+ IF XOBOS="OpenM" WRITE ! QUIT
+"RTN","XOBVSKT",171,0)
+ IF XOBOS="DSM" WRITE:$X>0 ! QUIT
+"RTN","XOBVSKT",172,0)
+ IF XOBOS="GTM" WRITE # QUIT
+"RTN","XOBVSKT",173,0)
+ QUIT
+"RTN","XOBVSKT",174,0)
+ ;
+"RTN","XOBVTCPL")
+0^22^B13529543
+"RTN","XOBVTCPL",1,0)
+XOBVTCPL ;; mjk/alb MSC/JDA - VistALink TCP/IP Listener (Cache NT) ; 07/27/2002  13:00
+"RTN","XOBVTCPL",2,0)
+ ;;1.5;VistALink;**MSC**;Sep 09, 2005
+"RTN","XOBVTCPL",3,0)
+ ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
+"RTN","XOBVTCPL",4,0)
+ ;
+"RTN","XOBVTCPL",5,0)
+ QUIT
+"RTN","XOBVTCPL",6,0)
+ ;
+"RTN","XOBVTCPL",7,0)
+ ; -- Important: Should always be JOBed using START^XOBVTCP
+"RTN","XOBVTCPL",8,0)
+LISTENER(XOBPORT,XOBCFG) ; -- Start Listener
+"RTN","XOBVTCPL",9,0)
+ ;
+"RTN","XOBVTCPL",10,0)
+ N OS
+"RTN","XOBVTCPL",11,0)
+ S OS=$$GETOS^XOBVTCP()
+"RTN","XOBVTCPL",12,0)
+ ; -- quit if not Cache for NT or GT.M
+"RTN","XOBVTCPL",13,0)
+ IF (OS'="OpenM-NT")&(OS'["GT.M") QUIT
+"RTN","XOBVTCPL",14,0)
+ ;
+"RTN","XOBVTCPL",15,0)
+ NEW $ETRAP,$ESTACK SET $ETRAP="D ^%ZTER HALT"
+"RTN","XOBVTCPL",16,0)
+ ;
+"RTN","XOBVTCPL",17,0)
+ NEW X,POP,XOBDA,U,DTIME,DT,XOBIO
+"RTN","XOBVTCPL",18,0)
+ SET U="^",DTIME=900,DT=$$DT^XLFDT()
+"RTN","XOBVTCPL",19,0)
+ IF $GET(DUZ)="" NEW DUZ SET DUZ=.5,DUZ(0)="@"
+"RTN","XOBVTCPL",20,0)
+ ;
+"RTN","XOBVTCPL",21,0)
+ ; -- only start if not already started
+"RTN","XOBVTCPL",22,0)
+ IF $$LOCK^XOBVTCP(XOBPORT) DO
+"RTN","XOBVTCPL",23,0)
+ . IF $$OPEN(.XOBIO,XOBPORT,OS) DO
+"RTN","XOBVTCPL",24,0)
+ . . ; -- listener started and now stopping
+"RTN","XOBVTCPL",25,0)
+ . . SET IO=XOBIO
+"RTN","XOBVTCPL",26,0)
+ . . DO CLOSE^%ZISTCP
+"RTN","XOBVTCPL",27,0)
+ . . ; -- update status to 'stopped'
+"RTN","XOBVTCPL",28,0)
+ . . DO UPDATE^XOBVTCP(XOBPORT,4,$GET(XOBCFG))
+"RTN","XOBVTCPL",29,0)
+ . ELSE  DO
+"RTN","XOBVTCPL",30,0)
+ . . ; -- listener failed to start
+"RTN","XOBVTCPL",31,0)
+ . . ; -- update status to 'failed'
+"RTN","XOBVTCPL",32,0)
+ . . DO UPDATE^XOBVTCP(XOBPORT,5,$GET(XOBCFG))
+"RTN","XOBVTCPL",33,0)
+ . ;
+"RTN","XOBVTCPL",34,0)
+ . DO UNLOCK^XOBVTCP(XOBPORT)
+"RTN","XOBVTCPL",35,0)
+ QUIT
+"RTN","XOBVTCPL",36,0)
+ ;
+"RTN","XOBVTCPL",37,0)
+ ; -- open/start listener port
+"RTN","XOBVTCPL",38,0)
+OPEN(XOBIO,XOBPORT,OS) ;
+"RTN","XOBVTCPL",39,0)
+ Q $S(OS="OpenM-NT":$$OPENM(.XOBIO,XOBPORT),OS["GT.M":$$OPENGTM(.XOBIO,XOBPORT),1:0)
+"RTN","XOBVTCPL",40,0)
+ ;
+"RTN","XOBVTCPL",41,0)
+ ; -- open/start listener port on Cache
+"RTN","XOBVTCPL",42,0)
+OPENM(XOBIO,XOBPORT) ;
+"RTN","XOBVTCPL",43,0)
+ NEW XOBBOX,%ZA
+"RTN","XOBVTCPL",44,0)
+ SET XOBBOX=+$$GETBOX^XOBVTCP()
+"RTN","XOBVTCPL",45,0)
+ SET XOBIO="|TCP|"_XOBPORT
+"RTN","XOBVTCPL",46,0)
+ X "OPEN XOBIO:(:XOBPORT:""AT""):30"
+"RTN","XOBVTCPL",47,0)
+ ;
+"RTN","XOBVTCPL",48,0)
+ ; -- if listener port could not be openned then gracefully quit
+"RTN","XOBVTCPL",49,0)
+ ;    (other namespace using port maybe?)
+"RTN","XOBVTCPL",50,0)
+ IF '$TEST QUIT 0
+"RTN","XOBVTCPL",51,0)
+ ;
+"RTN","XOBVTCPL",52,0)
+ ; -- indicate listener is 'running'
+"RTN","XOBVTCPL",53,0)
+ DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG))
+"RTN","XOBVTCPL",54,0)
+ ; -- read & spawn loop
+"RTN","XOBVTCPL",55,0)
+ FOR  DO  QUIT:$$EXIT(XOBBOX,XOBPORT)
+"RTN","XOBVTCPL",56,0)
+ . USE XOBIO
+"RTN","XOBVTCPL",57,0)
+ . READ *X:60 IF '$TEST QUIT
+"RTN","XOBVTCPL",58,0)
+ . X "JOB CHILD^XOBVTCPL():(:4:XOBIO:XOBIO):10" SET %ZA=$ZA
+"RTN","XOBVTCPL",59,0)
+ . IF %ZA\8196#2=1 WRITE *-2 ;Job failed to clear bit
+"RTN","XOBVTCPL",60,0)
+ QUIT 1
+"RTN","XOBVTCPL",61,0)
+ ;
+"RTN","XOBVTCPL",62,0)
+ ; -- open/start listener port on GT.M
+"RTN","XOBVTCPL",63,0)
+OPENGTM(XOBIO,XOBPORT) ;
+"RTN","XOBVTCPL",64,0)
+ NEW XOBBOX
+"RTN","XOBVTCPL",65,0)
+ SET XOBBOX=+$$GETBOX^XOBVTCP()
+"RTN","XOBVTCPL",66,0)
+ SET XOBIO="|TCP|"_XOBPORT_"|"_$J
+"RTN","XOBVTCPL",67,0)
+ OPEN XOBIO:(ZLISTEN=XOBPORT_":TCP":ATTACH="LISTENER"):5:"SOCKET"
+"RTN","XOBVTCPL",68,0)
+ ;
+"RTN","XOBVTCPL",69,0)
+ ; -- if listener port could not be openned then gracefully quit
+"RTN","XOBVTCPL",70,0)
+ ;    (other namespace using port maybe?)
+"RTN","XOBVTCPL",71,0)
+ IF '$TEST QUIT 0
+"RTN","XOBVTCPL",72,0)
+ ;
+"RTN","XOBVTCPL",73,0)
+ ; -- indicate listener is 'running'
+"RTN","XOBVTCPL",74,0)
+ DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG))
+"RTN","XOBVTCPL",75,0)
+ D LISTEN^ZISTCPS(XOBPORT,"CHILD^XOBVTCPL","EXIT^XOBVTCPL("_XOBBOX_","_XOBPORT_")")
+"RTN","XOBVTCPL",76,0)
+ ;
+"RTN","XOBVTCPL",77,0)
+CHILD ;Child process
+"RTN","XOBVTCPL",78,0)
+ NEW XOBEC
+"RTN","XOBVTCPL",79,0)
+ SET $ETRAP="D ^%ZTER L  HALT"
+"RTN","XOBVTCPL",80,0)
+ SET IO=$PRINCIPAL ;Reset IO to be $P
+"RTN","XOBVTCPL",81,0)
+ IF $$GETOS^XOBVTCP()["OpenM" X "USE IO:(::""-M"")" ;Packet mode like DSM
+"RTN","XOBVTCPL",82,0)
+ ; -- do quit to save a stack level
+"RTN","XOBVTCPL",83,0)
+ SET XOBEC=$$NEWOK()
+"RTN","XOBVTCPL",84,0)
+ IF XOBEC DO LOGINERR(XOBEC,IO)
+"RTN","XOBVTCPL",85,0)
+ IF 'XOBEC DO VAR,SPAWN^XOBVLL
+"RTN","XOBVTCPL",86,0)
+ QUIT
+"RTN","XOBVTCPL",87,0)
+ ;
+"RTN","XOBVTCPL",88,0)
+VAR ;Setup IO variables
+"RTN","XOBVTCPL",89,0)
+ SET IO(0)=IO,IO(1,IO)="",POP=0
+"RTN","XOBVTCPL",90,0)
+ SET IOT="TCP",IOF="#",IOST="P-TCP",IOST(0)=0
+"RTN","XOBVTCPL",91,0)
+ QUIT
+"RTN","XOBVTCPL",92,0)
+ ;
+"RTN","XOBVTCPL",93,0)
+NEWOK() ;Is it OK to start a new process
+"RTN","XOBVTCPL",94,0)
+ NEW XQVOL,XUVOL,X,XOBCODE,Y
+"RTN","XOBVTCPL",95,0)
+ SET U="^"
+"RTN","XOBVTCPL",96,0)
+ DO GETENV^%ZOSV SET XQVOL=$PIECE(Y,U,2)
+"RTN","XOBVTCPL",97,0)
+ SET X=$$FIND1^DIC(8989.304,",1,","BX",XQVOL,"","",""),XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
+"RTN","XOBVTCPL",98,0)
+ SET XOBCODE=$$INHIBIT^XUSRB()
+"RTN","XOBVTCPL",99,0)
+ IF XOBCODE=1 QUIT 181004
+"RTN","XOBVTCPL",100,0)
+ IF XOBCODE=2 QUIT 181003
+"RTN","XOBVTCPL",101,0)
+ QUIT 0
+"RTN","XOBVTCPL",102,0)
+ ;
+"RTN","XOBVTCPL",103,0)
+ ; -- process error
+"RTN","XOBVTCPL",104,0)
+LOGINERR(XOBEC,XOBPORT) ;
+"RTN","XOBVTCPL",105,0)
+ DO ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT)
+"RTN","XOBVTCPL",106,0)
+ ;
+"RTN","XOBVTCPL",107,0)
+ ; -- give client time to process stream
+"RTN","XOBVTCPL",108,0)
+ HANG 2
+"RTN","XOBVTCPL",109,0)
+ QUIT
+"RTN","XOBVTCPL",110,0)
+ ;
+"RTN","XOBVTCPL",111,0)
+EXIT(XOBBOX,XOBPORT) ;
+"RTN","XOBVTCPL",112,0)
+ ; -- is status 'stopping'
+"RTN","XOBVTCPL",113,0)
+ SET ZISQUIT=$PIECE($GET(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3
+"RTN","XOBVTCPL",114,0)
+ Q ZISQUIT
+"RTN","XOBVTCPL",115,0)
+ ;
+"RTN","XOBVTCPL",116,0)
+GETLOGID(XOBBOX,XOBPORT) ;
+"RTN","XOBVTCPL",117,0)
+ QUIT +$ORDER(^XOB(18.04,"C",XOBBOX,XOBPORT,""))
+"RTN","XOBVTCPL",118,0)
+ ;
+"RTN","XTER1A")
+0^7^B29045171
+"RTN","XTER1A",1,0)
+XTER1A ;ISC-SF.SEA/JLI - VA error reporting ;28MAR2006
+"RTN","XTER1A",2,0)
+ ;;8.0;KERNEL;**63,112,120,MSC,IHS**;Jul 10, 1995
+"RTN","XTER1A",3,0)
+ ;
+"RTN","XTER1A",4,0)
+TWO ;
+"RTN","XTER1A",5,0)
+ S XTNUM=2
+"RTN","XTER1A",6,0)
+ONE ;
+"RTN","XTER1A",7,0)
+ S:'$D(XTNUM) XTNUM=1
+"RTN","XTER1A",8,0)
+ S:'$D(XTNDATE) XTNDATE=$H-1 I '$D(ZTQUEUED) S XTNDAT1=$$HTFM^XLFDT(XTNDATE),XTNDAT2=XTNDAT1 G INT^XTER1A1
+"RTN","XTER1A",9,0)
+ K ^TMP($J,"XTER1A") D LISTN,LIST
+"RTN","XTER1A",10,0)
+EXIT K XTNUM,XTNDATE,XTERN,XTERX,X,N,N1,Y,C,XTOUT,Z,I,XTER1AX,XTER1AN,XTER1AN1,%XTZDAT,%XTZNUM,XTMES,XTDV1,XTMES,XTPRNT
+"RTN","XTER1A",11,0)
+ Q
+"RTN","XTER1A",12,0)
+LISTN ;
+"RTN","XTER1A",13,0)
+ 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
+"RTN","XTER1A",14,0)
+ .S N1=0 F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N=""  S N1=N I ^(N)=X Q
+"RTN","XTER1A",15,0)
+ .I N="" S ^TMP($J,"XTER1A",XTERX,N1+1)=X,^(N1+1,"CNT")=1,^(1)=XTNDATE_U_XTERN
+"RTN","XTER1A",16,0)
+ .E  S ^("CNT")=^TMP($J,"XTER1A",XTERX,N,"CNT")+1 I ^("CNT")'>XTNUM S Y=^("CNT"),^(Y)=XTNDATE_U_XTERN
+"RTN","XTER1A",17,0)
+ .Q
+"RTN","XTER1A",18,0)
+ Q
+"RTN","XTER1A",19,0)
+LIST ;
+"RTN","XTER1A",20,0)
+ S XTERX="",C=0,XTOUT=0 K ^TMP($J,"XTER")
+"RTN","XTER1A",21,0)
+ 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
+"RTN","XTER1A",22,0)
+ .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)_"  "
+"RTN","XTER1A",23,0)
+ .F I=1:60 S Y=$E(X,I,I+59) Q:Y=""  S C=C+1,^TMP($J,"XTER",C)=Z_Y,Z="         "
+"RTN","XTER1A",24,0)
+ 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
+"RTN","XTER1A",25,0)
+ .F XTER1AN1=0:0 S XTER1AN1=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN,XTER1AN1)) Q:XTER1AN1'>0  S X=^(XTER1AN1) D
+"RTN","XTER1A",26,0)
+ ..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
+"RTN","XTER1A",27,0)
+ D:IO=""&$D(^TMP($J,"XTER")) MESSG D:IO'="" WRITER
+"RTN","XTER1A",28,0)
+ K ^TMP($J,"XTER") S C=0 I IO'="" U IO D ^%ZISC
+"RTN","XTER1A",29,0)
+ Q
+"RTN","XTER1A",30,0)
+ ;
+"RTN","XTER1A",31,0)
+MESG N DWPK,DWLW,DIC K ^TMP($J,"XTER"),^TMP($J,"XTER1")
+"RTN","XTER1A",32,0)
+ W @IOF,!!,"Enter any comments to precede the error listing:"
+"RTN","XTER1A",33,0)
+ S DWPK=1,DWLW=75,DIC="^TMP($J,""XTER1""," D EN^DIWE
+"RTN","XTER1A",34,0)
+ 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)
+"RTN","XTER1A",35,0)
+ S XTMES=1,XTDV1=0 D WRT^XTER1 D:C>0 MESSG
+"RTN","XTER1A",36,0)
+ S C=0 K XTMES,^TMP($J,"XTER"),^TMP($J,"XTER1")
+"RTN","XTER1A",37,0)
+ G XTERR^XTER
+"RTN","XTER1A",38,0)
+ ;
+"RTN","XTER1A",39,0)
+PRNT K ^TMP($J,"XTER"),ZTIO
+"RTN","XTER1A",40,0)
+ S C=0,%ZIS="MQ" D ^%ZIS I POP D HOME^%ZIS G WRT^XTER1
+"RTN","XTER1A",41,0)
+ I $D(IO("Q")) D  S XTX="" G XTERR^XTER
+"RTN","XTER1A",42,0)
+ . K IO("Q") S ZTRTN="DQPRNT^XTER1A",ZTSAVE("%XTZDAT")="",ZTSAVE("%XTZNUM")="",ZTDESC="XTER1A-PRINT OF ERROR" D ^%ZTLOAD K ZTSK D HOME^%ZIS
+"RTN","XTER1A",43,0)
+ ;
+"RTN","XTER1A",44,0)
+DQPRNT S XTPRNT=1,XTOUT=0 D WRT^XTER1 U IO D:C>0 WRITER
+"RTN","XTER1A",45,0)
+ K ^TMP($J,"XTER"),XTX,XTPRNT S C=0 D ^%ZISC I $D(ZTQUEUED) Q
+"RTN","XTER1A",46,0)
+ G XTERR^XTER
+"RTN","XTER1A",47,0)
+ ;
+"RTN","XTER1A",48,0)
+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
+"RTN","XTER1A",49,0)
+ .I $E(%1,1,6)="|PAGE|" W @IOF S %1=$E(%1,7,$L(%1)) Q:%1=""
+"RTN","XTER1A",50,0)
+ .I $E(%1,1,4)="@IOF" W @IOF S %1=$E(%1,5,$L(%1)) Q:%1=""
+"RTN","XTER1A",51,0)
+ .W !,%1
+"RTN","XTER1A",52,0)
+ K %,%1
+"RTN","XTER1A",53,0)
+ Q
+"RTN","XTER1A",54,0)
+MESSG S XMY(DUZ)="",XMDUZ=.5 I '$D(ZTQUEUED) K XMY,XMDUZ
+"RTN","XTER1A",55,0)
+ 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)
+"RTN","XTER1A",56,0)
+ D ^XMD K XMY,XMTEXT,XMSUB
+"RTN","XTER1A",57,0)
+ Q
+"RTN","XTER1A",58,0)
+ ;
+"RTN","XTER1A",59,0)
+MORE Q:$G(XTMES)  N DIR,DTOUT,DIRUT,DUOUT
+"RTN","XTER1A",60,0)
+ S XTOUT=0,XTX="" D WRITER K ^TMP($J,"XTER") S C=0
+"RTN","XTER1A",61,0)
+ I '$D(ZTQUEUED),'$G(XTPRNT),$G(IOST)["C-" D
+"RTN","XTER1A",62,0)
+ . S:($D(X)#2) XTMORE=X S DIR(0)="FO^0:50",DIR("A")="     Enter '^' to quit listing, <RETURN> to continue..."
+"RTN","XTER1A",63,0)
+ . D ^DIR K DIR S:$D(DTOUT) X="^" S XTX=X S:$D(XTMORE) X=XTMORE K XTMORE
+"RTN","XTER1A",64,0)
+ I $D(XTX),$E(XTX)="^" S XTOUT=1 Q
+"RTN","XTER1A",65,0)
+ I $G(XTPRNT) W @IOF
+"RTN","XTER1A",66,0)
+ Q
+"RTN","XTER1A",67,0)
+ ;
+"RTN","XTER1A",68,0)
+LST S X=" ",XTQ="" N XTXT,XBLNK S $P(XBLNK," ",80)=" "
+"RTN","XTER1A",69,0)
+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=""
+"RTN","XTER1A",70,0)
+ F  S XTS=$O(^TMP($J,"XTERSCR",XTS)) Q:XTS=""  I XTP[XTS,XTD S XTD=XTD+1 G T1
+"RTN","XTER1A",71,0)
+ ;
+"RTN","XTER1A",72,0)
+ I '(X#20) S %XTERRX=X D MORE Q:XTOUT  Q:XTX>0  D T3 S X=%XTERRX
+"RTN","XTER1A",73,0)
+ 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)_" "
+"RTN","XTER1A",74,0)
+ I ^%ZTER(1,%XTZDAT,1,X,"ZE")'["," S XTXT=$J(X,3)_")  "_^("ZE")
+"RTN","XTER1A",75,0)
+ 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)
+"RTN","XTER1A",76,0)
+ S X=%XTZNUM S XTXT=$S($L(XTXT)>34:XTXT,1:$E(XTXT_XBLNK,1,34))_%
+"RTN","XTER1A",77,0)
+ I $D(^%ZTER(1,%XTZDAT,1,X,"J")) S XTXT=XTXT_" ["_$P($P(^("J"),U,4),",")_"]" ;_" "_$J($P(^("J"),U,5),7)
+"RTN","XTER1A",78,0)
+ D IHSXQY0 ;***IHS
+"RTN","XTER1A",79,0)
+ W !,$E(XTXT,1,79)
+"RTN","XTER1A",80,0)
+COMMENT I $D(^DD(3.0751,21400)) D  ;**MSC/GFT
+"RTN","XTER1A",81,0)
+ .N DIC,DIQ,DR,DA,Y,S,DK,D0,D1
+"RTN","XTER1A",82,0)
+ .S DIC="^%ZTER(1,"_%XTZDAT_",1,",DIQ(0)="A",DR=21400,DA=X,DA(1)=%XTZDAT
+"RTN","XTER1A",83,0)
+ .I $D(@(DIC_DA_",21400)")) N X D EN^DIQ
+"RTN","XTER1A",84,0)
+ G T1
+"RTN","XTER1A",85,0)
+T2 I XTD W !! I XTD-1 W XTD-1," screened error",$S(XTD-1>1:"s",1:""),!
+"RTN","XTER1A",86,0)
+ ;D MORE
+"RTN","XTER1A",87,0)
+ Q
+"RTN","XTER1A",88,0)
+T3 W !!,?11,"$ZE",?41,"Time",?49,"UCI,VOL",?61,"$J",?69,"$I",!
+"RTN","XTER1A",89,0)
+ Q
+"RTN","XTER1A",90,0)
+INTRACT ;
+"RTN","XTER1A",91,0)
+ G INTRACT^XTER1A1
+"RTN","XTER1A",92,0)
+ ;
+"RTN","XTER1A",93,0)
+ ;
+"RTN","XTER1A",94,0)
+ ;
+"RTN","XTER1A",95,0)
+ ;
+"RTN","XTER1A",96,0)
+IHSXQY0 ;IHS/ANMC/LJF 5/20/99 find option name
+"RTN","XTER1A",97,0)
+ NEW IHS,FOUND,STR
+"RTN","XTER1A",98,0)
+ S (FOUND,IHS)=0,STR=""
+"RTN","XTER1A",99,0)
+ F  S IHS=$O(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS)) Q:'IHS  Q:FOUND  D
+"RTN","XTER1A",100,0)
+ .I $G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,0))="DUZ" D  Q
+"RTN","XTER1A",101,0)
+ ..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 STR=$P($G(^[$S(^%ZOSF("OS")["GT.M":$ZGB,1:Y)]VA(200,D,0)),",")_": "
+"RTN","XTER1A",102,0)
+ . Q:$G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,0))'="XQY0"
+"RTN","XTER1A",103,0)
+ . S STR=STR_$P($G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,"D")),U)
+"RTN","XTER1A",104,0)
+ . S STR=$E(STR,1,26)_$$REPEAT^XLFSTR(" ",(26-$L(STR))),FOUND=1
+"RTN","XTER1A",105,0)
+ S XTXT=XTXT_"  "_$G(STR)
+"RTN","XTER1A",106,0)
+ Q
+"RTN","XWBTCPM")
+0^23^B56160723
+"RTN","XWBTCPM",1,0)
+XWBTCPM ;ISF/RWF MSC/JDA - BROKER TCP/IP PROCESS HANDLER ;01/04/2006  62562.56228
+"RTN","XWBTCPM",2,0)
+ ;;1.1;RPC BROKER;**35,43,MSC**;Mar 28, 1997
+"RTN","XWBTCPM",3,0)
+ ;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF
+"RTN","XWBTCPM",4,0)
+ ;Changed to be started by UCX or %ZISTCPS
+"RTN","XWBTCPM",5,0)
+ ;
+"RTN","XWBTCPM",6,0)
+ ;MSC/JDA 04/13/09 - Added MOREREADTIME to GT.M init
+"RTN","XWBTCPM",7,0)
+ ;
+"RTN","XWBTCPM",8,0)
+DSM ;DSM called from ucx, % passed in with device.
+"RTN","XWBTCPM",9,0)
+ D ESET
+"RTN","XWBTCPM",10,0)
+ ;Open the device
+"RTN","XWBTCPM",11,0)
+ S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open
+"RTN","XWBTCPM",12,0)
+ ;Go find the connection type
+"RTN","XWBTCPM",13,0)
+ U XWBTDEV
+"RTN","XWBTCPM",14,0)
+ G CONNTYPE
+"RTN","XWBTCPM",15,0)
+ ;
+"RTN","XWBTCPM",16,0)
+CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file
+"RTN","XWBTCPM",17,0)
+ D ESET
+"RTN","XWBTCPM",18,0)
+ S XWBTDEV="SYS$NET"
+"RTN","XWBTCPM",19,0)
+ ; **Cache'/VMS specific code**
+"RTN","XWBTCPM",20,0)
+ O XWBTDEV::5
+"RTN","XWBTCPM",21,0)
+ X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM
+"RTN","XWBTCPM",22,0)
+ G CONNTYPE
+"RTN","XWBTCPM",23,0)
+ ;
+"RTN","XWBTCPM",24,0)
+NT ;entry from ZISTCPS
+"RTN","XWBTCPM",25,0)
+ ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code")
+"RTN","XWBTCPM",26,0)
+ D ESET
+"RTN","XWBTCPM",27,0)
+ S XWBTDEV=IO
+"RTN","XWBTCPM",28,0)
+ G CONNTYPE
+"RTN","XWBTCPM",29,0)
+ ;
+"RTN","XWBTCPM",30,0)
+GTMUCX(%) ;From ucx ZFOO
+"RTN","XWBTCPM",31,0)
+ ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO
+"RTN","XWBTCPM",32,0)
+ D ESET
+"RTN","XWBTCPM",33,0)
+ ;GTM specific code
+"RTN","XWBTCPM",34,0)
+ S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+"RTN","XWBTCPM",35,0)
+ S XWBTDEV=% X "O %:(RECORDSIZE=512)"
+"RTN","XWBTCPM",36,0)
+ G CONNTYPE
+"RTN","XWBTCPM",37,0)
+ ;
+"RTN","XWBTCPM",38,0)
+GTMLNX ;From Linux xinetd script
+"RTN","XWBTCPM",39,0)
+ D ESET
+"RTN","XWBTCPM",40,0)
+ ;GTM specific code
+"RTN","XWBTCPM",41,0)
+ S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+"RTN","XWBTCPM",42,0)
+ S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter)"
+"RTN","XWBTCPM",43,0)
+ S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
+"RTN","XWBTCPM",44,0)
+ G CONNTYPE
+"RTN","XWBTCPM",45,0)
+ ;
+"RTN","XWBTCPM",46,0)
+ESET ;Set inital error trap
+"RTN","XWBTCPM",47,0)
+ S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
+"RTN","XWBTCPM",48,0)
+ Q
+"RTN","XWBTCPM",49,0)
+ ;Find the type of connection and jump to the processing routine.
+"RTN","XWBTCPM",50,0)
+CONNTYPE ;
+"RTN","XWBTCPM",51,0)
+ N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE
+"RTN","XWBTCPM",52,0)
+ N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT
+"RTN","XWBTCPM",53,0)
+ N SOCK,TYPE
+"RTN","XWBTCPM",54,0)
+ D INIT
+"RTN","XWBTCPM",55,0)
+ S XWB=$$BREAD^XWBRW(5,XWBTIME)
+"RTN","XWBTCPM",56,0)
+ D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="<?xml":"M2M",1:"Unk"))
+"RTN","XWBTCPM",57,0)
+ I XWB["[XWB]" G NEW
+"RTN","XWBTCPM",58,0)
+ I XWB["{XWB}" G OLD^XWBTCPM1
+"RTN","XWBTCPM",59,0)
+ I XWB["<?xml" G M2M
+"RTN","XWBTCPM",60,0)
+ I $L($T(OTH^XWBTCPM2)) D OTH^XWBTCPM2 ;See if a special code.
+"RTN","XWBTCPM",61,0)
+ D LOG("Prefix not known: "_XWB)
+"RTN","XWBTCPM",62,0)
+ Q
+"RTN","XWBTCPM",63,0)
+ ;
+"RTN","XWBTCPM",64,0)
+NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
+"RTN","XWBTCPM",65,0)
+ N X,Y,J,XWBVOL
+"RTN","XWBTCPM",66,0)
+ D GETENV^%ZOSV S XWBVOL=$P(Y,"^",2)
+"RTN","XWBTCPM",67,0)
+ 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")
+"RTN","XWBTCPM",68,0)
+ I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS?
+"RTN","XWBTCPM",69,0)
+ I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0
+"RTN","XWBTCPM",70,0)
+ Q 1
+"RTN","XWBTCPM",71,0)
+ ;
+"RTN","XWBTCPM",72,0)
+M2M ;M2M Broker
+"RTN","XWBTCPM",73,0)
+ S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL
+"RTN","XWBTCPM",74,0)
+ Q
+"RTN","XWBTCPM",75,0)
+ ;
+"RTN","XWBTCPM",76,0)
+NEW ;New broker
+"RTN","XWBTCPM",77,0)
+ S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108
+"RTN","XWBTCPM",78,0)
+ D SETTIME(1) ;Setup for sign-on timeout
+"RTN","XWBTCPM",79,0)
+ U XWBTDEV D
+"RTN","XWBTCPM",80,0)
+ . N XWB,ERR,NATIP,I
+"RTN","XWBTCPM",81,0)
+ . S ERR=$$PRSP^XWBPRS
+"RTN","XWBTCPM",82,0)
+ . S ERR=$$PRSM^XWBPRS
+"RTN","XWBTCPM",83,0)
+ . S MSG=$G(XWB(4,"CMD")) ;Build connect msg.
+"RTN","XWBTCPM",84,0)
+ . S I="" F  S I=$O(XWB(5,"P",I)) Q:I=""  S MSG=MSG_U_XWB(5,"P",I)
+"RTN","XWBTCPM",85,0)
+ . ;Get the peer and save that IP.
+"RTN","XWBTCPM",86,0)
+ . S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2)
+"RTN","XWBTCPM",87,0)
+ . I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP
+"RTN","XWBTCPM",88,0)
+ . Q
+"RTN","XWBTCPM",89,0)
+ S X=$$NEWJOB() D:'X LOG("No New Connects")
+"RTN","XWBTCPM",90,0)
+ I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q
+"RTN","XWBTCPM",91,0)
+ D QSND^XWBRW("accept"),LOG("accept") ;Ack
+"RTN","XWBTCPM",92,0)
+ S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4)
+"RTN","XWBTCPM",93,0)
+ S XWBTIP=$G(IO("IP"))
+"RTN","XWBTCPM",94,0)
+ ;start RUM for Broker Handler XWB*1.1*5
+"RTN","XWBTCPM",95,0)
+ D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
+"RTN","XWBTCPM",96,0)
+ ;GTM
+"RTN","XWBTCPM",97,0)
+ I $G(XWBT("PCNT")) D
+"RTN","XWBTCPM",98,0)
+ . S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0
+"RTN","XWBTCPM",99,0)
+ . D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X)
+"RTN","XWBTCPM",100,0)
+ ;We don't use a callback
+"RTN","XWBTCPM",101,0)
+ K XWB,CON,LEN,MSG ;Clean up
+"RTN","XWBTCPM",102,0)
+ ;Attempt to share license, Must have TCP port open first.
+"RTN","XWBTCPM",103,0)
+ U XWBTDEV ;D SHARELIC^%ZOSV(1)
+"RTN","XWBTCPM",104,0)
+ ;setup null device "NULL"
+"RTN","XWBTCPM",105,0)
+ S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER,EXIT Q
+"RTN","XWBTCPM",106,0)
+ D SAVDEV^%ZISUTL("XWBNULL")
+"RTN","XWBTCPM",107,0)
+ ;change process name
+"RTN","XWBTCPM",108,0)
+ D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV)
+"RTN","XWBTCPM",109,0)
+ ;
+"RTN","XWBTCPM",110,0)
+RESTART ;The error trap returns to here
+"RTN","XWBTCPM",111,0)
+ N $ESTACK S $ETRAP="D ETRAP^XWBTCPM"
+"RTN","XWBTCPM",112,0)
+ S DT=$$DT^XLFDT,DTIME=30
+"RTN","XWBTCPM",113,0)
+ U XWBTDEV D MAIN
+"RTN","XWBTCPM",114,0)
+ D LOG("Exit: "_XWBTBUF)
+"RTN","XWBTCPM",115,0)
+ ;Turn off the error trap for the exit
+"RTN","XWBTCPM",116,0)
+ S $ETRAP=""
+"RTN","XWBTCPM",117,0)
+ D EXIT ;Logout
+"RTN","XWBTCPM",118,0)
+ K XWBR,XWBARY
+"RTN","XWBTCPM",119,0)
+ ;stop RUM for handler XWB*1.1*5
+"RTN","XWBTCPM",120,0)
+ D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2)
+"RTN","XWBTCPM",121,0)
+ D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL")
+"RTN","XWBTCPM",122,0)
+ ;Close in the calling script
+"RTN","XWBTCPM",123,0)
+ K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF
+"RTN","XWBTCPM",124,0)
+ Q
+"RTN","XWBTCPM",125,0)
+ ;
+"RTN","XWBTCPM",126,0)
+MAIN ; -- main message processing loop. debug at MAIN+1
+"RTN","XWBTCPM",127,0)
+ F  D  Q:XWBTBUF="#BYE#"
+"RTN","XWBTCPM",128,0)
+ . ;Setup
+"RTN","XWBTCPM",129,0)
+ . S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF=""
+"RTN","XWBTCPM",130,0)
+ . K XWBR,XWBARY,XWBPRT
+"RTN","XWBTCPM",131,0)
+ . ; -- read client request
+"RTN","XWBTCPM",132,0)
+ . S XR=$$BREAD^XWBRW(1,XWBTIME,1)
+"RTN","XWBTCPM",133,0)
+ . I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q
+"RTN","XWBTCPM",134,0)
+ . S XR=XR_$$BREAD^XWBRW(4)
+"RTN","XWBTCPM",135,0)
+ . I XR="#BYE#" D  Q  ;Check for exit
+"RTN","XWBTCPM",136,0)
+ . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#"
+"RTN","XWBTCPM",137,0)
+ . . Q
+"RTN","XWBTCPM",138,0)
+ . S TYPE=(XR="[XWB]")  ;check HDR
+"RTN","XWBTCPM",139,0)
+ . I 'TYPE D LOG("Bad Header: "_XR) Q
+"RTN","XWBTCPM",140,0)
+ . D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC
+"RTN","XWBTCPM",141,0)
+ . IF XWBTCMD="#BYE#" D  Q
+"RTN","XWBTCPM",142,0)
+ . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD
+"RTN","XWBTCPM",143,0)
+ . . Q
+"RTN","XWBTCPM",144,0)
+ . U XWBTDEV
+"RTN","XWBTCPM",145,0)
+ . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE)
+"RTN","XWBTCPM",146,0)
+ . ;I $G(XWBPRT) D RETURN^XWBPRS2 Q  ;New msg return
+"RTN","XWBTCPM",147,0)
+ . I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer
+"RTN","XWBTCPM",148,0)
+ Q  ;End Of Main
+"RTN","XWBTCPM",149,0)
+ ;
+"RTN","XWBTCPM",150,0)
+ ;
+"RTN","XWBTCPM",151,0)
+ETRAP ; -- on trapped error, send error info to client
+"RTN","XWBTCPM",152,0)
+ N XWBERC,XWBERR
+"RTN","XWBTCPM",153,0)
+ ;Change trapping during trap.
+"RTN","XWBTCPM",154,0)
+ S $ETRAP="D ^%ZTER,EXIT^XWBTCPM HALT"
+"RTN","XWBTCPM",155,0)
+ S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M  ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
+"RTN","XWBTCPM",156,0)
+ I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server"
+"RTN","XWBTCPM",157,0)
+ D ^%ZTER ;%ZTER clears $ZE and $ZCODE
+"RTN","XWBTCPM",158,0)
+ D LOG("In ETRAP: "_XWBERC) ;Log
+"RTN","XWBTCPM",159,0)
+ I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F") D EXIT HALT
+"RTN","XWBTCPM",160,0)
+ U XWBTDEV
+"RTN","XWBTCPM",161,0)
+ I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0)
+"RTN","XWBTCPM",162,0)
+ E  L  ;Clear Locks
+"RTN","XWBTCPM",163,0)
+ ;I XWBOS'="DSM" D
+"RTN","XWBTCPM",164,0)
+ S XWBPTYPE=1 ;So SNDERR won't check XWBR
+"RTN","XWBTCPM",165,0)
+ ;D SNDERR^XWBRW,WRITE^XWBRW($C(24)_XWBERR_$C(4))
+"RTN","XWBTCPM",166,0)
+ D ESND^XWBRW($C(24)_XWBERR_$C(4))
+"RTN","XWBTCPM",167,0)
+ S $ETRAP="Q:($ESTACK&'$QUIT)  Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99,"
+"RTN","XWBTCPM",168,0)
+ Q
+"RTN","XWBTCPM",169,0)
+ ;
+"RTN","XWBTCPM",170,0)
+CLEANP ;Clean up the partion
+"RTN","XWBTCPM",171,0)
+ N XWBTDEV,XWBNULL D KILL^XUSCLEAN
+"RTN","XWBTCPM",172,0)
+ Q
+"RTN","XWBTCPM",173,0)
+ ;
+"RTN","XWBTCPM",174,0)
+STYPE(X,WRAP) ;For backward compatability only
+"RTN","XWBTCPM",175,0)
+ I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
+"RTN","XWBTCPM",176,0)
+ Q $$RTRNFMT^XWBLIB(X)
+"RTN","XWBTCPM",177,0)
+ ;
+"RTN","XWBTCPM",178,0)
+BREAD(L,T) ;read tcp buffer, L is length
+"RTN","XWBTCPM",179,0)
+ Q $$BREAD^XWBRW(L,$G(T))
+"RTN","XWBTCPM",180,0)
+ ;
+"RTN","XWBTCPM",181,0)
+CHPRN(N) ;change process name
+"RTN","XWBTCPM",182,0)
+ ;Change process name to N
+"RTN","XWBTCPM",183,0)
+ D SETNM^%ZOSV($E(N,1,15))
+"RTN","XWBTCPM",184,0)
+ Q
+"RTN","XWBTCPM",185,0)
+ ;
+"RTN","XWBTCPM",186,0)
+SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on
+"RTN","XWBTCPM",187,0)
+ S XWBTIME=$S($G(%):90,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=2
+"RTN","XWBTCPM",188,0)
+ I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000)
+"RTN","XWBTCPM",189,0)
+ Q
+"RTN","XWBTCPM",190,0)
+TIMEOUT ;Do this on MAIN  loop timeout
+"RTN","XWBTCPM",191,0)
+ I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q
+"RTN","XWBTCPM",192,0)
+ ;Sign-on timeout
+"RTN","XWBTCPM",193,0)
+ S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2
+"RTN","XWBTCPM",194,0)
+ D SND^XWBRW
+"RTN","XWBTCPM",195,0)
+ Q
+"RTN","XWBTCPM",196,0)
+ ;
+"RTN","XWBTCPM",197,0)
+OS() ;Return the OS
+"RTN","XWBTCPM",198,0)
+ Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",^("OS")["GT.M":"GTM",1:"MSM")
+"RTN","XWBTCPM",199,0)
+ ;
+"RTN","XWBTCPM",200,0)
+INIT ;Setup
+"RTN","XWBTCPM",201,0)
+ S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF=""
+"RTN","XWBTCPM",202,0)
+ S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG")
+"RTN","XWBTCPM",203,0)
+ S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!")
+"RTN","XWBTCPM",204,0)
+ X:$D(XWBTDEV)&(XWBOS="GTM") "U XWBTDEV:(MOREREADTIME=999)"
+"RTN","XWBTCPM",205,0)
+ S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1
+"RTN","XWBTCPM",206,0)
+ D LOGSTART^XWBDLOG("XWBTCPM")
+"RTN","XWBTCPM",207,0)
+ Q
+"RTN","XWBTCPM",208,0)
+ ;
+"RTN","XWBTCPM",209,0)
+DEBUG ;Entry point for debug, Build a server to get the connect
+"RTN","XWBTCPM",210,0)
+ ;DSM sample;ZDEBUG ON S $ZB(1)="SERV+1^XWBTCPM:1",$ZB="ETRAP+1^XWBTCPM:1"
+"RTN","XWBTCPM",211,0)
+ W !,"Before running this entry point set your debugger to stop at"
+"RTN","XWBTCPM",212,0)
+ W !,"the place you want to debug. Some spots to use:"
+"RTN","XWBTCPM",213,0)
+ W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",!
+"RTN","XWBTCPM",214,0)
+ W !,"or location of your choice.",!
+"RTN","XWBTCPM",215,0)
+ W !,"IP Socket to Listen on: " R SOCK:300 Q:'$T!(SOCK["^")
+"RTN","XWBTCPM",216,0)
+ ;Use %ZISTCP to do a single server
+"RTN","XWBTCPM",217,0)
+ D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM")
+"RTN","XWBTCPM",218,0)
+ U $P W !,"Done"
+"RTN","XWBTCPM",219,0)
+ Q
+"RTN","XWBTCPM",220,0)
+SERV ;Callback from the server
+"RTN","XWBTCPM",221,0)
+ S XWBTDEV=IO,XWBTIME(1)=3600 D INIT
+"RTN","XWBTCPM",222,0)
+ S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5
+"RTN","XWBTCPM",223,0)
+ D NEW
+"RTN","XWBTCPM",224,0)
+ S IO("C")=1 ;Cause the Listenr to stop
+"RTN","XWBTCPM",225,0)
+ Q
+"RTN","XWBTCPM",226,0)
+ ;
+"RTN","XWBTCPM",227,0)
+EXIT ;Close out
+"RTN","XWBTCPM",228,0)
+ I $G(DUZ) D LOGOUT^XUSRB
+"RTN","XWBTCPM",229,0)
+ I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1)
+"RTN","XWBTCPM",230,0)
+ Q
+"RTN","XWBTCPM",231,0)
+ ;
+"RTN","XWBTCPM",232,0)
+LOG(MSG) ;Record Debug Info
+"RTN","XWBTCPM",233,0)
+ D:$G(XWBDEBUG) LOG^XWBDLOG(MSG)
+"RTN","XWBTCPM",234,0)
+ Q
+"RTN","XWBTCPM",235,0)
+ ;
+"RTN","ZCD")
+0^11^B5581
+"RTN","ZCD",1,0)
+ZCD ; MSC/JKT ; "Namespace" utilities for GT.M/Unix ; 01/30/2009
+"RTN","ZCD",2,0)
+ ;
+"RTN","ZCD",3,0)
+ ; This routine assumes that your global directory file exists one 
+"RTN","ZCD",4,0)
+ ; directory below the root of the instance, e.g., 
+"RTN","ZCD",5,0)
+ ;
+"RTN","ZCD",6,0)
+ ; /opt/openvista/instance/globals/mumps.gld
+"RTN","ZCD",7,0)
+ ;
+"RTN","ZCD",8,0)
+ ; or
+"RTN","ZCD",9,0)
+ ;
+"RTN","ZCD",10,0)
+ ; /home/vista/instance/g/default.gld
+"RTN","ZCD",11,0)
+ ;
+"RTN","ZCD",12,0)
+ ; The actual file name of the global directory file and the actual name
+"RTN","ZCD",13,0)
+ ; of the parent directory are never checked, so their names do not 
+"RTN","ZCD",14,0)
+ ; matter.
+"RTN","ZCD",15,0)
+ G CD
+"RTN","ZCD",16,0)
+ ;
+"RTN","ZCD",17,0)
+CURRENT()
+"RTN","ZCD",18,0)
+ ; return the name of the current OpenVista instance
+"RTN","ZCD",19,0)
+ Q $P($ZG,"/",$L($ZG,"/")-2)
+"RTN","ZCD",20,0)
+ ;
+"RTN","ZCD",21,0)
+PATH()
+"RTN","ZCD",22,0)
+ ; return the path to the current OpenVista instance
+"RTN","ZCD",23,0)
+ N I,X S X=""
+"RTN","ZCD",24,0)
+ S X=$P($ZG,"/",1,$L($ZG,"/")-2)
+"RTN","ZCD",25,0)
+ Q X
+"RTN","ZCD",26,0)
+ ;
+"RTN","ZCD",27,0)
+ROOT()
+"RTN","ZCD",28,0)
+ ; return the path where all OpenVista instances live
+"RTN","ZCD",29,0)
+ N I,X S X=""
+"RTN","ZCD",30,0)
+ S X=$P($ZG,"/",1,$L($ZG,"/")-3)
+"RTN","ZCD",31,0)
+ Q X
+"RTN","ZCD",32,0)
+ ;
+"RTN","ZCD",33,0)
+LIST()
+"RTN","ZCD",34,0)
+ ; returns an array (Y) of OpenVista instances on this system
+"RTN","ZCD",35,0)
+ ;
+"RTN","ZCD",36,0)
+ ; FIXME: a "user friendly" version of this list should screen out the 
+"RTN","ZCD",37,0)
+ ;        current instance name and any instances that the current user 
+"RTN","ZCD",38,0)
+ ;        should not be allowed to switch to (they must have access 
+"RTN","ZCD",39,0)
+ ;        code and primary menu option in the target instance to switch)
+"RTN","ZCD",40,0)
+ ;
+"RTN","ZCD",41,0)
+ ; FIXME: this routine currently requires GT.M V5.3003 because it uses 
+"RTN","ZCD",42,0)
+ ;        PIPE I/O.  We many want to make it compatible with older 
+"RTN","ZCD",43,0)
+ ;        versions of GT.M by falling back to using temporary files, 
+"RTN","ZCD",44,0)
+ ;        but on versions of GT.M V5.3003 and later, we definitely want 
+"RTN","ZCD",45,0)
+ ;        to use PIPEs to avoid temporary files moving forward.
+"RTN","ZCD",46,0)
+ N P,I,X
+"RTN","ZCD",47,0)
+ S P="ls"
+"RTN","ZCD",48,0)
+ O P:(COMMAND="ls --color=none -1 "_$$ROOT():READONLY)::"PIPE"
+"RTN","ZCD",49,0)
+ U P
+"RTN","ZCD",50,0)
+ F I=1:1 R X Q:X=""  S Y(I)=X,Y("B",X)=""
+"RTN","ZCD",51,0)
+ U $P 
+"RTN","ZCD",52,0)
+ C P
+"RTN","ZCD",53,0)
+ Q
+"RTN","ZCD",54,0)
+ ;
+"RTN","ZCD",55,0)
+GTMPATH(INSTANCE)
+"RTN","ZCD",56,0)
+ ; return the path to the version of GT.M this instance uses
+"RTN","ZCD",57,0)
+ ;
+"RTN","ZCD",58,0)
+ ; FIXME: handle the case when INSTANCE is bogus
+"RTN","ZCD",59,0)
+ ; 
+"RTN","ZCD",60,0)
+ N P,X
+"RTN","ZCD",61,0)
+ S P="readlink"
+"RTN","ZCD",62,0)
+ O P:(COMMAND="readlink "_$$ROOT()_"/"_INSTANCE_"/gtm":READONLY)::"PIPE"
+"RTN","ZCD",63,0)
+ U P
+"RTN","ZCD",64,0)
+ R X
+"RTN","ZCD",65,0)
+ U $P
+"RTN","ZCD",66,0)
+ C P
+"RTN","ZCD",67,0)
+ Q X
+"RTN","ZCD",68,0)
+ ;
+"RTN","ZCD",69,0)
+SWITCH(INSTANCE)
+"RTN","ZCD",70,0)
+ ; switch to another OpenVista instance by setting $ZG and $ZRO
+"RTN","ZCD",71,0)
+ ;
+"RTN","ZCD",72,0)
+ ; there are several ways to do this; try them in order until 
+"RTN","ZCD",73,0)
+ ; one succeeds
+"RTN","ZCD",74,0)
+ ;
+"RTN","ZCD",75,0)
+ ; FIXME: we may want to allow this entry point to be called using DO
+"RTN","ZCD",76,0)
+ Q:$$SWITCH1(INSTANCE) 1
+"RTN","ZCD",77,0)
+ Q:$$SWITCH2(INSTANCE) 1
+"RTN","ZCD",78,0)
+ Q:$$SWITCH3(INSTANCE) 1
+"RTN","ZCD",79,0)
+ Q 0
+"RTN","ZCD",80,0)
+ ;
+"RTN","ZCD",81,0)
+SWITCH1(INSTANCE)
+"RTN","ZCD",82,0)
+ ; private entry point
+"RTN","ZCD",83,0)
+ ;
+"RTN","ZCD",84,0)
+ ; look for new values of $ZG and $ZRO in env directory of 
+"RTN","ZCD",85,0)
+ ; target instance
+"RTN","ZCD",86,0)
+ N ZG,ZRO,G,RO
+"RTN","ZCD",87,0)
+ ;
+"RTN","ZCD",88,0)
+ ; FIXME: if file does not exist or is unreadable (permission 
+"RTN","ZCD",89,0)
+ ;        denied), Q 0
+"RTN","ZCD",90,0)
+ ;S G=$$ROOT()_"/"_INSTANCE_"/env/gtmgbldir"
+"RTN","ZCD",91,0)
+ ;O G:READONLY U G R ZG U $P C G
+"RTN","ZCD",92,0)
+ N I,A S A="/"_$$CURRENT()_"/",ZG=""
+"RTN","ZCD",93,0)
+ F I=1:1:$L($ZG,A) S ZG=ZG_$P($ZG,A,I)_$S(I=$L($ZG,A):"",1:"/"_INSTANCE_"/")
+"RTN","ZCD",94,0)
+ ;
+"RTN","ZCD",95,0)
+ ; FIXME: if file does not exist or is unreadable (permission 
+"RTN","ZCD",96,0)
+ ;        denied), Q 0
+"RTN","ZCD",97,0)
+ ;S RO=$$ROOT()_"/"_INSTANCE_"/env/gtmroutines"
+"RTN","ZCD",98,0)
+ ;O RO:READONLY U RO R ZRO U $P C RO
+"RTN","ZCD",99,0)
+ S ZRO=""
+"RTN","ZCD",100,0)
+ F I=1:1:$L($ZRO,A) S ZRO=ZRO_$P($ZRO,A,I)_$S(I=$L($ZRO,A):"",1:"/"_INSTANCE_"/")
+"RTN","ZCD",101,0)
+ ;
+"RTN","ZCD",102,0)
+ S $ZG=ZG,$ZRO=ZRO
+"RTN","ZCD",103,0)
+ ;
+"RTN","ZCD",104,0)
+ ;zlink the buffer
+"RTN","ZCD",105,0)
+ X "Q"
+"RTN","ZCD",106,0)
+ N I
+"RTN","ZCD",107,0)
+ S I=$view("rtnnext","")
+"RTN","ZCD",108,0)
+NEXT F  S I=$VIEW("rtnnext",I) Q:I=""  I I'="GTM$DMOD" D
+"RTN","ZCD",109,0)
+ .I I="ZCD" Q
+"RTN","ZCD",110,0)
+ .I $E(I)="%" Q:($E(I,2)'="Z")
+"RTN","ZCD",111,0)
+ .K %ZR S A=$TR(I,"%","_") D SILENT^%RSEL(A) I $D(%ZR(A)) N $ET S $ET="G NEXT^ZCD" ZLINK A_".m" Q
+"RTN","ZCD",112,0)
+ .N DIE,X,B S X=I,B(1,0)=I_" ;",B(2,0)=" ZMESSAGE 150374338:$PIECE($ZPOSITION,""^"",2)",B(3,0)=" QUIT"
+"RTN","ZCD",113,0)
+ .S DIE="B(",XCN=0 N I D SAVE(X)
+"RTN","ZCD",114,0)
+ ; FIXME: do we need to set $ZINTERRUPT and $PATH?
+"RTN","ZCD",115,0)
+ Q 1
+"RTN","ZCD",116,0)
+ ;
+"RTN","ZCD",117,0)
+SWITCH2(INSTANCE)
+"RTN","ZCD",118,0)
+ ; private entry point
+"RTN","ZCD",119,0)
+ ;
+"RTN","ZCD",120,0)
+ ; look for new values of $ZG and $ZRO in env file of target instance
+"RTN","ZCD",121,0)
+ ;
+"RTN","ZCD",122,0)
+ ; if the env file does not exist or is unreadable (permission denied) 
+"RTN","ZCD",123,0)
+ ; or unparsable, Q 0 without setting $ZG and $ZRO
+"RTN","ZCD",124,0)
+ ;
+"RTN","ZCD",125,0)
+ ; FIXME: implement this
+"RTN","ZCD",126,0)
+ ;
+"RTN","ZCD",127,0)
+ ; FIXME: do we need to set $ZINTERRUPT and $PATH?
+"RTN","ZCD",128,0)
+ Q 0
+"RTN","ZCD",129,0)
+ ;
+"RTN","ZCD",130,0)
+SWITCH3(INSTANCE)
+"RTN","ZCD",131,0)
+ ; private entry point
+"RTN","ZCD",132,0)
+ ;
+"RTN","ZCD",133,0)
+ ; get new values of $ZG and $ZRO by replacing $$PATH() with 
+"RTN","ZCD",134,0)
+ ; $$ROOT()_"/"_INSTANCE.  Q 0 without setting $ZG and $ZRO if the 
+"RTN","ZCD",135,0)
+ ; resulting paths don't actually exist or we do not have permission to
+"RTN","ZCD",136,0)
+ ; access them
+"RTN","ZCD",137,0)
+ ;
+"RTN","ZCD",138,0)
+ ; FIXME: implement this
+"RTN","ZCD",139,0)
+ ;
+"RTN","ZCD",140,0)
+ ; FIXME: do we need to set $ZINTERRUPT and $PATH?
+"RTN","ZCD",141,0)
+ Q 0
+"RTN","ZCD",142,0)
+ ;
+"RTN","ZCD",143,0)
+CD ;Interactive
+"RTN","ZCD",144,0)
+ N Y,DIR
+"RTN","ZCD",145,0)
+ R !,"Namespace: ",DIR
+"RTN","ZCD",146,0)
+ I DIR["^"!(DIR="") Q
+"RTN","ZCD",147,0)
+ D LIST()
+"RTN","ZCD",148,0)
+ I DIR["?" G HELP
+"RTN","ZCD",149,0)
+ I '$D(Y("B",DIR)) W !,"Invalid Namespace" G CD
+"RTN","ZCD",150,0)
+ I $$GTMPATH($$CURRENT())'=$$GTMPATH(DIR) W !,"Inconsistent GTM versions",! G CD
+"RTN","ZCD",151,0)
+ S A=$$SWITCH1(DIR)
+"RTN","ZCD",152,0)
+ S $ZPROMPT=DIR_">"
+"RTN","ZCD",153,0)
+ Q
+"RTN","ZCD",154,0)
+HELP N A S A=""
+"RTN","ZCD",155,0)
+ F  S A=$O(Y("B",A)) Q:A=""  W !,A
+"RTN","ZCD",156,0)
+ W ! G CD
+"RTN","ZCD",157,0)
+ Q
+"RTN","ZCD",158,0)
+SAVE(RN) ;Save a routine
+"RTN","ZCD",159,0)
+ N %,%F,%I,%N,SP,$ETRAP
+"RTN","ZCD",160,0)
+ S $ETRAP="S $ECODE="""" Q"
+"RTN","ZCD",161,0)
+ S %I=$I,SP=" ",%F="/tmp/"_$J_"/"_RN_".m"
+"RTN","ZCD",162,0)
+ ZSYSTEM "mkdir /tmp/"_$J
+"RTN","ZCD",163,0)
+ O %F:(newversion:noreadonly:blocksize=2048:recordsize=2044) U %F
+"RTN","ZCD",164,0)
+ F  S XCN=$O(@(DIE_XCN_")")) Q:XCN'>0  S %=@(DIE_XCN_",0)") Q:$E(%,1)="$"  I $E(%)'=";" W $P(%,SP)_$C(9)_$P(%,SP,2,99999),!
+"RTN","ZCD",165,0)
+ C %F ;S %N=$$NULL
+"RTN","ZCD",166,0)
+ S ZR=$ZRO,$ZRO=$ZRO_" /tmp/"_$J_"/"
+"RTN","ZCD",167,0)
+ ZLINK RN
+"RTN","ZCD",168,0)
+ ZSYSTEM "rm -r /tmp/"_$J
+"RTN","ZCD",169,0)
+ S $ZRO=ZR
+"RTN","ZCD",170,0)
+ ;C %N
+"RTN","ZCD",171,0)
+ U %I
+"RTN","ZCD",172,0)
+ Q
+"RTN","ZIS4GTM")
+0^5^B18414491
+"RTN","ZIS4GTM",1,0)
+%ZIS4 ;SFISC/AC,RWF,MVB - DEVICE HANDLER SPECIFIC CODE (GT.M 4.3 for Unix/VMS) ;29 Jan 2003 2:59 pm
+"RTN","ZIS4GTM",2,0)
+ ;;8.0;KERNEL;**275**;Jul 10, 1995;
+"RTN","ZIS4GTM",3,0)
+ ;
+"RTN","ZIS4GTM",4,0)
+OPEN G OPN2:$D(IO(1,IO))
+"RTN","ZIS4GTM",5,0)
+ S POP=0 D OP1 G NOPEN:'$D(IO(1,IO))
+"RTN","ZIS4GTM",6,0)
+OPN2 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"")
+"RTN","ZIS4GTM",7,0)
+ Q
+"RTN","ZIS4GTM",8,0)
+NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q
+"RTN","ZIS4GTM",9,0)
+ I '$D(IOP) W *7,"  [BUSY]" W "  ...  RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
+"RTN","ZIS4GTM",10,0)
+ S POP=1 Q
+"RTN","ZIS4GTM",11,0)
+ Q
+"RTN","ZIS4GTM",12,0)
+OP1 S X="OPNERR^%ZIS4",@^%ZOSF("TRAP"),$ZE=""
+"RTN","ZIS4GTM",13,0)
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+"RTN","ZIS4GTM",14,0)
+ O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
+"RTN","ZIS4GTM",15,0)
+ Q
+"RTN","ZIS4GTM",16,0)
+OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q
+"RTN","ZIS4GTM",17,0)
+ ;
+"RTN","ZIS4GTM",18,0)
+O D:%IS["L" ZIO
+"RTN","ZIS4GTM",19,0)
+LCKGBL ;Lock Global
+"RTN","ZIS4GTM",20,0)
+ 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
+"RTN","ZIS4GTM",21,0)
+ I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX
+"RTN","ZIS4GTM",22,0)
+OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
+"RTN","ZIS4GTM",23,0)
+ I %ZTYPE="CHAN",IO["::""TASK="!(IO["SYS$NET") D ODECNET Q:POP  G OXECUTE^%ZIS6
+"RTN","ZIS4GTM",24,0)
+ S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
+"RTN","ZIS4GTM",25,0)
+ N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
+"RTN","ZIS4GTM",26,0)
+ S %A=%_$E(":",%A]"")_%A
+"RTN","ZIS4GTM",27,0)
+ D O1 I POP D  Q
+"RTN","ZIS4GTM",28,0)
+ .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q
+"RTN","ZIS4GTM",29,0)
+ .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
+"RTN","ZIS4GTM",30,0)
+ ;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)	 
+"RTN","ZIS4GTM",31,0)
+ U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91)
+"RTN","ZIS4GTM",32,0)
+ I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
+"RTN","ZIS4GTM",33,0)
+ ;U:%IS'[0 IO(0)
+"RTN","ZIS4GTM",34,0)
+ G OXECUTE^%ZIS6:IO'["lpr"
+"RTN","ZIS4GTM",35,0)
+ Q
+"RTN","ZIS4GTM",36,0)
+ ;
+"RTN","ZIS4GTM",37,0)
+O1 ;N $ES,$ET S $ET="G OPNERR^%ZIS4"
+"RTN","ZIS4GTM",38,0)
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+"RTN","ZIS4GTM",39,0)
+ I %A["lpr" S IO="lpr",%A="IO:(COMMAND="_$P(%A,":")_":WRITEONLY)::""PIPE"""
+"RTN","ZIS4GTM",40,0)
+ O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK
+"RTN","ZIS4GTM",41,0)
+ S IO("ERROR")="" Q
+"RTN","ZIS4GTM",42,0)
+ ;
+"RTN","ZIS4GTM",43,0)
+ ;Need to find out how to get IP address
+"RTN","ZIS4GTM",44,0)
+ZIO N %,%1 S (%,%1)=$ZIO
+"RTN","ZIS4GTM",45,0)
+ I $ZV["VMS",%["_TNA" D
+"RTN","ZIS4GTM",46,0)
+ . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM")
+"RTN","ZIS4GTM",47,0)
+ . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ")
+"RTN","ZIS4GTM",48,0)
+ I $ZV'["VMS" D
+"RTN","ZIS4GTM",49,0)
+ . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO
+"RTN","ZIS4GTM",50,0)
+ S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":")
+"RTN","ZIS4GTM",51,0)
+ Q
+"RTN","ZIS4GTM",52,0)
+ ;
+"RTN","ZIS4GTM",53,0)
+ODECNET Q  ; fill me in later
+"RTN","ZIS4GTM",54,0)
+SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name.
+"RTN","ZIS4GTM",55,0)
+ I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N
+"RTN","ZIS4GTM",56,0)
+ I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N
+"RTN","ZIS4GTM",57,0)
+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"))
+"RTN","ZIS4GTM",58,0)
+ G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC
+"RTN","ZIS4GTM",59,0)
+ 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)=""
+"RTN","ZIS4GTM",60,0)
+DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#"
+"RTN","ZIS4GTM",61,0)
+ I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS
+"RTN","ZIS4GTM",62,0)
+OK K %ZDA,%ZFN Q
+"RTN","ZIS4GTM",63,0)
+N K %ZDA,%ZFN,IO("DOC") S POP=1 Q
+"RTN","ZIS4GTM",64,0)
+SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
+"RTN","ZIS4GTM",65,0)
+SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP")
+"RTN","ZIS4GTM",66,0)
+ O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q
+"RTN","ZIS4GTM",67,0)
+SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q
+"RTN","ZIS4GTM",68,0)
+CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
+"RTN","ZIS4GTM",69,0)
+ S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP")
+"RTN","ZIS4GTM",70,0)
+ S %Z1=+$G(^XTV(8989.3,1,"SPL"))
+"RTN","ZIS4GTM",71,0)
+ F %=0:0 R %X#255:5 Q:$ZA<0  S %2=%X D CL2 G:%Z1<% SPLEX
+"RTN","ZIS4GTM",72,0)
+SPLEOF I $ZE'["ENDO" Q  ;Send error up
+"RTN","ZIS4GTM",73,0)
+SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
+"RTN","ZIS4GTM",74,0)
+ ;
+"RTN","ZIS4GTM",75,0)
+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
+"RTN","ZIS4GTM",76,0)
+ I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q
+"RTN","ZIS4GTM",77,0)
+ S ^XMBS(3.519,XS,2,%,0)=%2 Q
+"RTN","ZIS4GTM",78,0)
+ ;
+"RTN","ZIS4GTM",79,0)
+HFS G HFS^%ZISF
+"RTN","ZIS4GTM",80,0)
+REWMT(IO,IOPAR) ;Rewind Magtape
+"RTN","ZIS4GTM",81,0)
+ S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
+"RTN","ZIS4GTM",82,0)
+ U IO W *5
+"RTN","ZIS4GTM",83,0)
+ Q 1
+"RTN","ZIS4GTM",84,0)
+REWSDP(IO,IOPAR) ;Rewind SDP
+"RTN","ZIS4GTM",85,0)
+ G REW1
+"RTN","ZIS4GTM",86,0)
+REWHFS(IO,IOPAR) ;Rewind Host File.
+"RTN","ZIS4GTM",87,0)
+REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP")
+"RTN","ZIS4GTM",88,0)
+ U IO:(REWIND)
+"RTN","ZIS4GTM",89,0)
+ Q 1
+"RTN","ZIS4GTM",90,0)
+REWERR ;Error encountered
+"RTN","ZIS4GTM",91,0)
+ Q 0
+"RTN","ZISHGUX")
+0^15^B37875330
+"RTN","ZISHGUX",1,0)
+%ZISH ;ISF/AC,RWF - GT.M for UNIX Host file Control ;01/04/2005  08:13
+"RTN","ZISHGUX",2,0)
+ ;;8.0;KERNEL;**275,306**;Jul 10, 1995;
+"RTN","ZISHGUX",3,0)
+ ; for GT.M for Unix/VMS, version 4.3
+"RTN","ZISHGUX",4,0)
+ ;
+"RTN","ZISHGUX",5,0)
+OPENERR ;
+"RTN","ZISHGUX",6,0)
+ Q 0
+"RTN","ZISHGUX",7,0)
+ ;
+"RTN","ZISHGUX",8,0)
+OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open file
+"RTN","ZISHGUX",9,0)
+ ;D OPEN^%ZISH([handlename],[directory],filename,[accessmode],[recsize])
+"RTN","ZISHGUX",10,0)
+ ;X1=handle name
+"RTN","ZISHGUX",11,0)
+ ;X2=directory, X3=filename, X4=access mode
+"RTN","ZISHGUX",12,0)
+ ;X5=new file max record size, X6=Subtype
+"RTN","ZISHGUX",13,0)
+ ;
+"RTN","ZISHGUX",14,0)
+ N %,%1,%2,%IO,%I2,%P,%T,X,Y,$ETRAP
+"RTN","ZISHGUX",15,0)
+ S $ETRAP="D OPNERR^%ZISH"
+"RTN","ZISHGUX",16,0)
+ S U="^",X2=$$DEFDIR($G(X2)),X4=$$UP^XLFSTR(X4)
+"RTN","ZISHGUX",17,0)
+ S Y=$S(X4["A":"append",X4["R":"readonly",X4["W":"newversion",1:"readonly")
+"RTN","ZISHGUX",18,0)
+ S Y=Y_$S(X4["B":":fixed:nowrap:recordsize=512",$G(X5)&(X4["W"):":WIDTH="_+X5,1:"")
+"RTN","ZISHGUX",19,0)
+ S:$E(Y)=":" Y=$E(Y,2,999) S %IO=X2_X3,%I2="%IO:"_$S($L(Y):"("_Y_")",1:"")_":3"
+"RTN","ZISHGUX",20,0)
+ O @%I2 S %T=$T
+"RTN","ZISHGUX",21,0)
+ I '%T S POP=1 Q
+"RTN","ZISHGUX",22,0)
+ S IO=%IO,IO(1,IO)="",IOT="HFS",POP=0 D SUBTYPE^%ZIS3($G(X6))
+"RTN","ZISHGUX",23,0)
+ I $G(X1)]"" D SAVDEV^%ZISUTL(X1)
+"RTN","ZISHGUX",24,0)
+ U IO U $P ;Enable use of $ZA to test EOF condition.
+"RTN","ZISHGUX",25,0)
+ Q
+"RTN","ZISHGUX",26,0)
+OPNERR ;error on open
+"RTN","ZISHGUX",27,0)
+ S POP=1,$ECODE=""
+"RTN","ZISHGUX",28,0)
+ U:$G(%P)]"" %P
+"RTN","ZISHGUX",29,0)
+ Q
+"RTN","ZISHGUX",30,0)
+ ;
+"RTN","ZISHGUX",31,0)
+CLOSE(X) ;SR. Close HFS device not opened by %ZIS.
+"RTN","ZISHGUX",32,0)
+ ;X1=Handle name, IO=device
+"RTN","ZISHGUX",33,0)
+ I IO]"" C IO K IO(1,IO)
+"RTN","ZISHGUX",34,0)
+ I $G(X)]"" D RMDEV^%ZISUTL(X)
+"RTN","ZISHGUX",35,0)
+ D HOME^%ZIS
+"RTN","ZISHGUX",36,0)
+ Q
+"RTN","ZISHGUX",37,0)
+DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s)
+"RTN","ZISHGUX",38,0)
+ ;S Y=$$DEL^%ZISH("dir path",$NA(array))
+"RTN","ZISHGUX",39,0)
+ N %ZISH,%ZISHLGR,%ZX,X,%ZXDEL
+"RTN","ZISHGUX",40,0)
+ S %ZX1=$$DEFDIR($G(%ZX1)),%ZXDEL=1,%ZISH=""
+"RTN","ZISHGUX",41,0)
+ F  S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH=""  D
+"RTN","ZISHGUX",42,0)
+ . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
+"RTN","ZISHGUX",43,0)
+ . I %ZISH["*" S %ZXDEL=0 Q  ; Wild card not allowed.
+"RTN","ZISHGUX",44,0)
+ . S %ZX=$ZSEARCH(%ZX1_%ZISH)
+"RTN","ZISHGUX",45,0)
+ . Q:%ZX']""           ; File doesn't exist - not an error, just quit.
+"RTN","ZISHGUX",46,0)
+ . O %ZX:READONLY:0
+"RTN","ZISHGUX",47,0)
+ . I '$T S %ZXDEL=0 Q  ; Can't open it.
+"RTN","ZISHGUX",48,0)
+ . C %ZX:DELETE
+"RTN","ZISHGUX",49,0)
+ . I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful.
+"RTN","ZISHGUX",50,0)
+ Q %ZXDEL
+"RTN","ZISHGUX",51,0)
+DELERR ;Trap any $ETRAP error, unwind and return.
+"RTN","ZISHGUX",52,0)
+ S $ETRAP="D UNWIND^%ZTER"
+"RTN","ZISHGUX",53,0)
+ S %ZXDEL=0
+"RTN","ZISHGUX",54,0)
+ D UNWIND^%ZTER
+"RTN","ZISHGUX",55,0)
+ Q
+"RTN","ZISHGUX",56,0)
+ ;
+"RTN","ZISHGUX",57,0)
+LIST(DIR,LIST,RETURN) ;ef,SR. Set local array holding fl names
+"RTN","ZISHGUX",58,0)
+ ;S Y=$$LIST^ZISH("/dir/","list_root","return_root")
+"RTN","ZISHGUX",59,0)
+ ;list_root can have XX("A*"), XX("test.com")...
+"RTN","ZISHGUX",60,0)
+ ;Both arrays passed as $NA values (closed roots).
+"RTN","ZISHGUX",61,0)
+ ;N %IO,%X,%ZISH,%ZISH1,%ZISHIO,%ZX,POP,X,%ZISHDL1,%ZISHDL2,%ZISHDN1,%ZISHDN2
+"RTN","ZISHGUX",62,0)
+ ;N $ETRAP,$ESTACK S $ETRAP="G LSTEOF^%ZISH",%ZX1=$$DEFDIR($G(%ZX1))
+"RTN","ZISHGUX",63,0)
+ ;S %IO=$I,%ZISHDN1="_ZISH"_$J_".TMPA",%ZISHDN2="ZISH"_$J_".TMPB"
+"RTN","ZISHGUX",64,0)
+ ;%ZISHDL1=%ZX1_%ZISHDN1,%ZISHDL2=%ZX1_%ZISHDN2
+"RTN","ZISHGUX",65,0)
+ ;S $ZT="G SPAWNERR^%ZISH"
+"RTN","ZISHGUX",66,0)
+ ;Init %ZISHDL1, %ZISHDL2 by deleteing them
+"RTN","ZISHGUX",67,0)
+ ;I $ZSEARCH(%ZISHDL1)["ZISH" ZSYSTEM "rm "_%ZISHDL1
+"RTN","ZISHGUX",68,0)
+ ;I $ZSEARCH(%ZISHDL2)["ZISH" ZSYSTEM "rm "_%ZISHDL2_";*"
+"RTN","ZISHGUX",69,0)
+ ;Get fls, Build listing in %ZISHDL1 with ls
+"RTN","ZISHGUX",70,0)
+ S %ZISH1=0,%ZISH=""
+"RTN","ZISHGUX",71,0)
+ N WANT,GLOB,NAME  S WANT="",DIR=$$DEFDIR($G(DIR))  F  S WANT=$O(@LIST@(WANT)) Q:WANT=""  D  
+"RTN","ZISHGUX",72,0)
+ . S GLOB=DIR_WANT,NAME=""
+"RTN","ZISHGUX",73,0)
+ . F  S NAME=$ZSEARCH(GLOB) Q:NAME=""  S @RETURN@($P(NAME,DIR,2))=""
+"RTN","ZISHGUX",74,0)
+ Q $Q(@RETURN)]""
+"RTN","ZISHGUX",75,0)
+LSTEOF S $ZT=""
+"RTN","ZISHGUX",76,0)
+ I $L(%IO) U:$D(IO(1,%IO)) IO
+"RTN","ZISHGUX",77,0)
+ ;C %ZISHDL1 ;:DELETE
+"RTN","ZISHGUX",78,0)
+ ;I $L($ZSEARCH(%ZISHDL2)) ZSYSTEM "DEL "_%ZISHDL2
+"RTN","ZISHGUX",79,0)
+ ;I $L($ZSEARCH(%ZISHDL1)) ZSYSTEM "DEL "_%ZISHDL1_";*"
+"RTN","ZISHGUX",80,0)
+ S $ECODE=""
+"RTN","ZISHGUX",81,0)
+ Q ($Q(@%ZX3)]"")
+"RTN","ZISHGUX",82,0)
+ ;
+"RTN","ZISHGUX",83,0)
+LIST1(%ZX,%ZD) ;Get one part of the list
+"RTN","ZISHGUX",84,0)
+ N $ET,$ES S $ET="D LSTERR^%ZISH"
+"RTN","ZISHGUX",85,0)
+ ;ZSYSTEM "ls -1 "_%ZX_" > "_%ZISHDL1
+"RTN","ZISHGUX",86,0)
+ ;O %ZISHDL1:readonly:1 U %ZISHDL1
+"RTN","ZISHGUX",87,0)
+ ;F  R %X:1 Q:$ZEOF  S @%ZX3@(%X)=""
+"RTN","ZISHGUX",88,0)
+ ;C %ZISHDL1:DELETE
+"RTN","ZISHGUX",89,0)
+ N %ZY,%ZI,%ZJ
+"RTN","ZISHGUX",90,0)
+ S %ZY=$ZSEARCH("*.X") ;Clear vector
+"RTN","ZISHGUX",91,0)
+ S %ZY=$P(%ZX,"*")
+"RTN","ZISHGUX",92,0)
+ F  S %ZI=$ZSEARCH(%ZX) Q:'$L(%ZI)!(%ZI'[%ZY)  S %ZJ=$P(%ZI,%ZD,2),@%ZX3@(%ZJ)=""
+"RTN","ZISHGUX",93,0)
+ Q 1
+"RTN","ZISHGUX",94,0)
+LSTERR ;Error in list
+"RTN","ZISHGUX",95,0)
+ I $ZSEARCH(%ZISHDL2)["ZISH" ZSYSTEM "DEL "_%ZISHDL2_";*"
+"RTN","ZISHGUX",96,0)
+ Q 0
+"RTN","ZISHGUX",97,0)
+ ;
+"RTN","ZISHGUX",98,0)
+SPAWNERR ;TRAP ERROR OF SPAWN
+"RTN","ZISHGUX",99,0)
+ O %ZISHDL1:READONLY:1 I $T C %ZISHDL1:DELETE
+"RTN","ZISHGUX",100,0)
+ S $ECODE=""
+"RTN","ZISHGUX",101,0)
+ Q 0
+"RTN","ZISHGUX",102,0)
+ ;
+"RTN","ZISHGUX",103,0)
+MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl
+"RTN","ZISHGUX",104,0)
+ ;S Y=$$MV^ZISH("/dir/","fl","/dir/","fl")
+"RTN","ZISHGUX",105,0)
+ N X,Y,%ZISHDL1
+"RTN","ZISHGUX",106,0)
+ S %ZISHDL1="ZISH"_$J_".TMPA",X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1))
+"RTN","ZISHGUX",107,0)
+ S $ZT="SPAWNERR^%ZISH"
+"RTN","ZISHGUX",108,0)
+ ;Pbv or qit
+"RTN","ZISHGUX",109,0)
+ I (X2="")!(Y2="") Q 0
+"RTN","ZISHGUX",110,0)
+ ZSYSTEM "mv "_X1_X2_" "_Y1_Y2 ;Use system command
+"RTN","ZISHGUX",111,0)
+ S Y=$ZSEARCH(Y1_Y2)
+"RTN","ZISHGUX",112,0)
+ Q $L(Y)>0
+"RTN","ZISHGUX",113,0)
+ ;
+"RTN","ZISHGUX",114,0)
+PWD() ;ef,SR. Print working directory
+"RTN","ZISHGUX",115,0)
+ N Y
+"RTN","ZISHGUX",116,0)
+ S Y=$$DEFDIR("")
+"RTN","ZISHGUX",117,0)
+ S:Y="" Y=$ZDIR
+"RTN","ZISHGUX",118,0)
+ Q Y
+"RTN","ZISHGUX",119,0)
+ ;
+"RTN","ZISHGUX",120,0)
+DEFDIR(DF) ;ef. Default Dir and frmt
+"RTN","ZISHGUX",121,0)
+ S DF=$G(DF) Q:DF="." "" ;Special way to get current dir.
+"RTN","ZISHGUX",122,0)
+ S:DF="" DF=$G(^XTV(8989.3,1,"DEV"))
+"RTN","ZISHGUX",123,0)
+ ;Check syntax, VMS needs : or [ ]
+"RTN","ZISHGUX",124,0)
+ I ^%ZOSF("OS")["VMS" D  Q DF ;***EXIT FOR VMS/GTM
+"RTN","ZISHGUX",125,0)
+ . N P1,P2
+"RTN","ZISHGUX",126,0)
+ . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
+"RTN","ZISHGUX",127,0)
+ . E  S P1="",P2=DF
+"RTN","ZISHGUX",128,0)
+ . I P1="",P2["$" S DF=P2 Q  ;Assume a logical
+"RTN","ZISHGUX",129,0)
+ . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]"
+"RTN","ZISHGUX",130,0)
+ . S DF=P1_P2
+"RTN","ZISHGUX",131,0)
+ . Q
+"RTN","ZISHGUX",132,0)
+ ;
+"RTN","ZISHGUX",133,0)
+ ;Check syntax, Unix check leading & trailing "/"
+"RTN","ZISHGUX",134,0)
+ I "./"'[$E(DF) S DF="/"_DF
+"RTN","ZISHGUX",135,0)
+ I $E(DF,$L(DF))'="/" S DF=DF_"/"
+"RTN","ZISHGUX",136,0)
+ Q DF
+"RTN","ZISHGUX",137,0)
+STATUS() ;ef,SR. Return EOF status
+"RTN","ZISHGUX",138,0)
+ U $I
+"RTN","ZISHGUX",139,0)
+ Q $ZEOF
+"RTN","ZISHGUX",140,0)
+ ;
+"RTN","ZISHGUX",141,0)
+EOF(X) ;Eof flag, Pass in $ZA
+"RTN","ZISHGUX",142,0)
+ Q X
+"RTN","ZISHGUX",143,0)
+QL(X) ;Qlfrs
+"RTN","ZISHGUX",144,0)
+ Q:X=""
+"RTN","ZISHGUX",145,0)
+ S:$E(X)'="-" X="-"_X
+"RTN","ZISHGUX",146,0)
+ Q
+"RTN","ZISHGUX",147,0)
+FL(X) ;Fl len
+"RTN","ZISHGUX",148,0)
+ N ZOSHP1,ZOSHP2
+"RTN","ZISHGUX",149,0)
+ S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2)
+"RTN","ZISHGUX",150,0)
+ I $L(ZOSHP1)>14 S X=4 Q
+"RTN","ZISHGUX",151,0)
+ I $L(ZOSHP2)>8 S X=4 Q
+"RTN","ZISHGUX",152,0)
+ Q
+"RTN","ZISHGUX",153,0)
+ ;
+"RTN","ZISHGUX",154,0)
+MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref.
+"RTN","ZISHGUX",155,0)
+ ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB
+"RTN","ZISHGUX",156,0)
+ N I,F,MX
+"RTN","ZISHGUX",157,0)
+ S OVF=$G(OVF,"%ZISHOF")
+"RTN","ZISHGUX",158,0)
+ S %ZISHI=$$QS^DDBRAP(HF,IX),MX=$$QL^DDBRAP(HF) ;
+"RTN","ZISHGUX",159,0)
+ S F=$NA(@HF,IX-1) ;Get first part
+"RTN","ZISHGUX",160,0)
+ I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1
+"RTN","ZISHGUX",161,0)
+ I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root
+"RTN","ZISHGUX",162,0)
+ S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow
+"RTN","ZISHGUX",163,0)
+ F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$$QS^DDBRAP(HF,I)
+"RTN","ZISHGUX",164,0)
+ S %ZISHF=%ZISHF_")"
+"RTN","ZISHGUX",165,0)
+ Q
+"RTN","ZISHGUX",166,0)
+FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global
+"RTN","ZISHGUX",167,0)
+ ;p1=host file directory
+"RTN","ZISHGUX",168,0)
+ ;p2=host file name
+"RTN","ZISHGUX",169,0)
+ ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT
+"RTN","ZISHGUX",170,0)
+ ;p4=INCREMENT SUBSCRIPT
+"RTN","ZISHGUX",171,0)
+ ;p5=Overflow subscript, defaults to "OVF"
+"RTN","ZISHGUX",172,0)
+ N %ZA,%ZB,%ZC,%ZL,X,%OVFCNT,%CONT
+"RTN","ZISHGUX",173,0)
+ N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY,POP,%ZISUB,%EXIT
+"RTN","ZISHGUX",174,0)
+ S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF")
+"RTN","ZISHGUX",175,0)
+ D MAKEREF(%ZX3,%ZX4,"%ZISHOF")
+"RTN","ZISHGUX",176,0)
+ D OPEN^%ZISH(,%ZX1,%ZX2,"R")
+"RTN","ZISHGUX",177,0)
+ I POP Q 0
+"RTN","ZISHGUX",178,0)
+ N $ETRAP S %EXIT=0,$ETRAP="S %ZA=1,%EXIT=1,$ECODE="""" Q"
+"RTN","ZISHGUX",179,0)
+ U IO F  K %XX D READNXT(.%XX) Q:$$EOF(%ZA)  D
+"RTN","ZISHGUX",180,0)
+ . S @%ZISHF=%XX
+"RTN","ZISHGUX",181,0)
+ . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT))  S @%ZISHO=%XX(%OVFCNT)
+"RTN","ZISHGUX",182,0)
+ . S %ZISHI=%ZISHI+1
+"RTN","ZISHGUX",183,0)
+ . Q
+"RTN","ZISHGUX",184,0)
+ D CLOSE() ;Normal exit
+"RTN","ZISHGUX",185,0)
+ Q '%EXIT
+"RTN","ZISHGUX",186,0)
+ ;
+"RTN","ZISHGUX",187,0)
+ERREOF D CLOSE() ;Got error Reading file
+"RTN","ZISHGUX",188,0)
+ Q 0
+"RTN","ZISHGUX",189,0)
+ ;
+"RTN","ZISHGUX",190,0)
+READNXT(REC) ;
+"RTN","ZISHGUX",191,0)
+ N T,I,X,%
+"RTN","ZISHGUX",192,0)
+ U IO R X:2 S %ZA=$ZEOF,REC=$E(X,1,255)
+"RTN","ZISHGUX",193,0)
+ Q:$L(X)<256
+"RTN","ZISHGUX",194,0)
+ S %=256 F I=1:1 Q:$L(X)<%  S REC(I)=$E(X,%,%+254),%=%+255
+"RTN","ZISHGUX",195,0)
+ Q
+"RTN","ZISHGUX",196,0)
+GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file.
+"RTN","ZISHGUX",197,0)
+ ;Previously name LOAD
+"RTN","ZISHGUX",198,0)
+ ;p1=$NAME of global reference
+"RTN","ZISHGUX",199,0)
+ ;p2=incrementing subscript
+"RTN","ZISHGUX",200,0)
+ ;p3=host file directory
+"RTN","ZISHGUX",201,0)
+ ;p4=host file name
+"RTN","ZISHGUX",202,0)
+ N %ZISHY,%ZISHLGR,%ZISHOX
+"RTN","ZISHGUX",203,0)
+ S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"W")
+"RTN","ZISHGUX",204,0)
+ Q %ZISHY
+"RTN","ZISHGUX",205,0)
+ ;
+"RTN","ZISHGUX",206,0)
+GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file.
+"RTN","ZISHGUX",207,0)
+ ;
+"RTN","ZISHGUX",208,0)
+ ;p1=$NAME of global reference
+"RTN","ZISHGUX",209,0)
+ ;p2=incrementing subscript
+"RTN","ZISHGUX",210,0)
+ ;p3=host file directory
+"RTN","ZISHGUX",211,0)
+ ;p4=host file name
+"RTN","ZISHGUX",212,0)
+ N %ZISHY
+"RTN","ZISHGUX",213,0)
+ S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"A")
+"RTN","ZISHGUX",214,0)
+ Q %ZISHY
+"RTN","ZISHGUX",215,0)
+ ;
+"RTN","ZISHGUX",216,0)
+MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;
+"RTN","ZISHGUX",217,0)
+ ;p1=$NAME of global reference
+"RTN","ZISHGUX",218,0)
+ ;p2=incrementing subscript
+"RTN","ZISHGUX",219,0)
+ ;p3=host file directory
+"RTN","ZISHGUX",220,0)
+ ;p4=host file name
+"RTN","ZISHGUX",221,0)
+ N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHS,%ZISHOX,IO,%ZX,Y
+"RTN","ZISHGUX",222,0)
+ D MAKEREF(%ZX1,%ZX2)
+"RTN","ZISHGUX",223,0)
+ D OPEN^%ZISH(,%ZX3,%ZX4,%ZX5) ;Default dir set in open
+"RTN","ZISHGUX",224,0)
+ I POP Q 0
+"RTN","ZISHGUX",225,0)
+ N X
+"RTN","ZISHGUX",226,0)
+ N $ETRAP S $ETRAP="",X="ERREOF^%ZISH",@^%ZOSF("TRAP")
+"RTN","ZISHGUX",227,0)
+ F  Q:'($D(@%ZISHF)#2)  S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,!
+"RTN","ZISHGUX",228,0)
+ D CLOSE() ;Normal Exit
+"RTN","ZISHGUX",229,0)
+ Q 1
+"RTN","ZISHGUX",230,0)
+ ;
+"RTN","ZISTCPS")
+0^25^B18372148
+"RTN","ZISTCPS",1,0)
+%ZISTCPS ;ISF/RWF MSC/JDA - DEVICE HANDLER TCP/IP SERVER CALLS ;06/20/2005  09:11
+"RTN","ZISTCPS",2,0)
+ ;;8.0;KERNEL;**78,118,127,225,275,388,JDA**;Jul 10, 1995
+"RTN","ZISTCPS",3,0)
+ Q
+"RTN","ZISTCPS",4,0)
+ ;
+"RTN","ZISTCPS",5,0)
+CLOSE ;Close and reset
+"RTN","ZISTCPS",6,0)
+ G CLOSE^%ZISTCP
+"RTN","ZISTCPS",7,0)
+ Q
+"RTN","ZISTCPS",8,0)
+ ;
+"RTN","ZISTCPS",9,0)
+ ;In ZRULE, set ZISQUIT=1 to quit
+"RTN","ZISTCPS",10,0)
+LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, start routine
+"RTN","ZISTCPS",11,0)
+ N %A,ZISOS,X,NIO,EXIT
+"RTN","ZISTCPS",12,0)
+ N $ES,$ET S $ETRAP="D OPNERR^%ZISTCPS"
+"RTN","ZISTCPS",13,0)
+ S ZISOS=^%ZOSF("OS"),ZRULE=$G(ZRULE)
+"RTN","ZISTCPS",14,0)
+ S POP=1
+"RTN","ZISTCPS",15,0)
+ D GETENV^%ZOSV S U="^",XUENV=Y,XQVOL=$P(Y,U,2)
+"RTN","ZISTCPS",16,0)
+ S POP=1 D LONT:ZISOS["OpenM",LGTM:ZISOS["GT.M"
+"RTN","ZISTCPS",17,0)
+ I 'POP C NIO ;Close port
+"RTN","ZISTCPS",18,0)
+ Q
+"RTN","ZISTCPS",19,0)
+ ;
+"RTN","ZISTCPS",20,0)
+ ;
+"RTN","ZISTCPS",21,0)
+LONT ;Open port in Accept mode with standard terminators.
+"RTN","ZISTCPS",22,0)
+ N %ZA,NEWCHAR
+"RTN","ZISTCPS",23,0)
+ S NIO="|TCP|"_SOCK,EXIT=0
+"RTN","ZISTCPS",24,0)
+ ;(adr:sock:term:ibuf:obuf:queue)
+"RTN","ZISTCPS",25,0)
+ O NIO:(:SOCK:"AT"::512:512:10):30 Q:'$T  S POP=0 U NIO
+"RTN","ZISTCPS",26,0)
+ ;Wait on read for a connect
+"RTN","ZISTCPS",27,0)
+LONT2 F  U NIO R *NEWCHAR:30 S EXIT=$$EXIT Q:$T!EXIT
+"RTN","ZISTCPS",28,0)
+ I EXIT C NIO Q
+"RTN","ZISTCPS",29,0)
+ ;JOB params (:Concurrent Server bit:principal input:principal output)
+"RTN","ZISTCPS",30,0)
+ J CHILDONT^%ZISTCPS(NIO,RTN):(:16::):10 S %ZA=$ZA
+"RTN","ZISTCPS",31,0)
+ I %ZA\8196#2=1 W *-2 ;Job failed to clear bit
+"RTN","ZISTCPS",32,0)
+ G LONT2
+"RTN","ZISTCPS",33,0)
+ ;
+"RTN","ZISTCPS",34,0)
+CHILDONT(IO,RTN) ;Child process for OpenM
+"RTN","ZISTCPS",35,0)
+ S $ETRAP="D ^%ZTER L  HALT",IO=$ZU(53)
+"RTN","ZISTCPS",36,0)
+ U IO:(::"-M") ;Work like DSM
+"RTN","ZISTCPS",37,0)
+ S NEWJOB=$$NEWOK
+"RTN","ZISTCPS",38,0)
+ I 'NEWJOB W "421 Service temporarily down.",$C(13,10),!
+"RTN","ZISTCPS",39,0)
+ I NEWJOB K NEWJOB D VAR,@RTN
+"RTN","ZISTCPS",40,0)
+ HALT
+"RTN","ZISTCPS",41,0)
+ ;
+"RTN","ZISTCPS",42,0)
+VAR ;Setup IO variables
+"RTN","ZISTCPS",43,0)
+ S IO(0)=IO,IO(1,IO)="",POP=0
+"RTN","ZISTCPS",44,0)
+ S IOT="TCP",IOST="P-TCP",IOST(0)=0
+"RTN","ZISTCPS",45,0)
+ S IOF=$$FLUSHCHR^%ZISTCP
+"RTN","ZISTCPS",46,0)
+ S ^XUTL("XQ",$J,0)=$$DT^XLFDT
+"RTN","ZISTCPS",47,0)
+ Q
+"RTN","ZISTCPS",48,0)
+NEWOK() ;Is it OK to start a new process
+"RTN","ZISTCPS",49,0)
+ I $G(^%ZIS(14.5,"LOGON",^%ZOSF("VOL"))) Q 0
+"RTN","ZISTCPS",50,0)
+ I $$AVJ^%ZOSV()<3 Q 0
+"RTN","ZISTCPS",51,0)
+ Q 1
+"RTN","ZISTCPS",52,0)
+OPNERR ;
+"RTN","ZISTCPS",53,0)
+ S POP=1,EXIT=1,IO("ERROR")=$ECODE,$ECODE=""
+"RTN","ZISTCPS",54,0)
+ Q
+"RTN","ZISTCPS",55,0)
+EXIT() ;See if time to exit
+"RTN","ZISTCPS",56,0)
+ I $$S^%ZTLOAD Q 1
+"RTN","ZISTCPS",57,0)
+ N ZISQUIT S ZISQUIT=0
+"RTN","ZISTCPS",58,0)