Merge lp:~jontai/openvista-gtm-integration/bug532393 into lp:openvista-gtm-integration

[Jon Tai]

This code has been running at a customer site for a little over a week now. I think the approach is cleaner and works a lot better than our previous approach, which didn't cover the HL7 client code at all!

The patch could be simpler still if we just turned on I/O error trapping in %ZISTCP, but that would affect *ALL* code in OpenVista that used sockets, not just HL7, so this is a bit more conservative.

[jeff.apple (jeff-apple)]

Looks good.

Where did the new files, HLSTCP2-3, come from, and why weren't they needed before?

I'm having trouble finding the IOERROR device parameter documentation. The online GTM programmers documentation seems old and difficult to search/use now.

review: Approve

[Jon Tai (jontai)]

HLSTCP2-4 contain the HL7 client code. Actually, that's not entirely accurate, because the "server" code calls HLCSTCP2 to send ACKs, and the "client" code calls HLCSTCP1 to read ACKs. We probably never looked at that other code before because they didn't cause problems for us. I made the modifications to these routines because I caught an outbound interface spinning in a loop when the receiving side hung up. The READBLK code was calling the "server" error handler in HLCSTCP1, which wasn't setting the right flag variables for the interface to stop/reset. Now we set the error handler correctly at the top-level entry points (wherever existing S $ET=... calls were being made), so if you call READBLK^HLCSTCP1 from the client code to read an ACK, the error handler is set to the client error handler; if you call it from the server code to read an incoming message, the error handler is set to the server handler.

See http://mirrors.medsphere.org/pub/tinco.pair.com/bhaskar/gtm/doc/books/pg/UNIX_manual/use_device_params.html for the IOERROR device parameter documentation. (Scroll down to IOERROR.)

=== added file 'kids/MSC_GTM_INTEG_12.KID'
--- kids/MSC_GTM_INTEG_12.KID	1970-01-01 00:00:00 +0000
+++ kids/MSC_GTM_INTEG_12.KID	2010-03-05 03:58:17 +0000
@@ -0,0 +1,13416 @@
+KIDS Distribution saved on Mar 04, 2010@19:52:47
+VERSION 12 - HL7 IMPROVEMENTS
+**KIDS**:MSC GTM INTEGRATION*1.0*12^
+
+**INSTALL NAME**
+MSC GTM INTEGRATION*1.0*12
+"BLD",7026,0)
+MSC GTM INTEGRATION*1.0*12^^0^3100304^y
+"BLD",7026,1,0)
+^^1^1^3090611^
+"BLD",7026,1,1,0)
+SYSTEM STATUS AND JOBEXAM FOR GT.M
+"BLD",7026,4,0)
+^9.64PA^^
+"BLD",7026,6.3)
+52
+"BLD",7026,"INIT")
+
+"BLD",7026,"KRN",0)
+^9.67PA^8989.52^19
+"BLD",7026,"KRN",.4,0)
+.4
+"BLD",7026,"KRN",.401,0)
+.401
+"BLD",7026,"KRN",.402,0)
+.402
+"BLD",7026,"KRN",.403,0)
+.403
+"BLD",7026,"KRN",.403,"NM",0)
+^9.68A^2^2
+"BLD",7026,"KRN",.403,"NM",1,0)
+MSCZJOBEXAM    FILE #3.081^3.081^0
+"BLD",7026,"KRN",.403,"NM",2,0)
+MSCZLOCK    FILE #3.081^3.081^0
+"BLD",7026,"KRN",.403,"NM","B","MSCZJOBEXAM    FILE #3.081",1)
+
+"BLD",7026,"KRN",.403,"NM","B","MSCZLOCK    FILE #3.081",2)
+
+"BLD",7026,"KRN",.5,0)
+.5
+"BLD",7026,"KRN",.84,0)
+.84
+"BLD",7026,"KRN",3.6,0)
+3.6
+"BLD",7026,"KRN",3.8,0)
+3.8
+"BLD",7026,"KRN",9.2,0)
+9.2
+"BLD",7026,"KRN",9.2,"NM",0)
+^9.68A^^
+"BLD",7026,"KRN",9.8,0)
+9.8
+"BLD",7026,"KRN",9.8,"NM",0)
+^9.68A^55^47
+"BLD",7026,"KRN",9.8,"NM",1,0)
+MSCZJOB^^0^B12965530
+"BLD",7026,"KRN",9.8,"NM",4,0)
+MSCZJOBU^^0^B9589351
+"BLD",7026,"KRN",9.8,"NM",5,0)
+ZIS4GTM^^0^B18512871
+"BLD",7026,"KRN",9.8,"NM",7,0)
+XTER1A^^0^B29100251
+"BLD",7026,"KRN",9.8,"NM",8,0)
+ZUGTM^^0^B10012519
+"BLD",7026,"KRN",9.8,"NM",11,0)
+ZCD^^0^B27561610
+"BLD",7026,"KRN",9.8,"NM",13,0)
+ZOSV2GTM^^0^B7713680
+"BLD",7026,"KRN",9.8,"NM",14,0)
+ZOSFGUX^^0^B22502126
+"BLD",7026,"KRN",9.8,"NM",15,0)
+ZISHGUX^^0^B36911880
+"BLD",7026,"KRN",9.8,"NM",16,0)
+HLCSTCP1^^0^B33066751
+"BLD",7026,"KRN",9.8,"NM",17,0)
+HLCSTCP^^0^B32647785
+"BLD",7026,"KRN",9.8,"NM",18,0)
+HLCSLNCH^^0^B37119958
+"BLD",7026,"KRN",9.8,"NM",19,0)
+XOBVLL^^0^B18012967
+"BLD",7026,"KRN",9.8,"NM",20,0)
+XOBVRH^^0^B13028891
+"BLD",7026,"KRN",9.8,"NM",21,0)
+XOBVSKT^^0^B19755798
+"BLD",7026,"KRN",9.8,"NM",22,0)
+XOBVTCPL^^0^B13492271
+"BLD",7026,"KRN",9.8,"NM",23,0)
+XWBTCPM^^0^B56922128
+"BLD",7026,"KRN",9.8,"NM",24,0)
+ZTMGRSET^^0^B55040199
+"BLD",7026,"KRN",9.8,"NM",25,0)
+ZISTCPS^^0^B18299533
+"BLD",7026,"KRN",9.8,"NM",26,0)
+XPDR^^0^B52133395
+"BLD",7026,"KRN",9.8,"NM",27,0)
+ZISFGUX^^1^
+"BLD",7026,"KRN",9.8,"NM",28,0)
+ZTER^^0^B39678986
+"BLD",7026,"KRN",9.8,"NM",29,0)
+ZSTARTGUX^^0^B140233
+"BLD",7026,"KRN",9.8,"NM",31,0)
+MSCXUS3A^^0^B9453784
+"BLD",7026,"KRN",9.8,"NM",32,0)
+RORHL7A^^0^B35660209
+"BLD",7026,"KRN",9.8,"NM",33,0)
+ZOSVGUX^^0^B1197142
+"BLD",7026,"KRN",9.8,"NM",34,0)
+DGMSTAPI^^0^B48539163
+"BLD",7026,"KRN",9.8,"NM",35,0)
+GMRCA2^^0^B10634
+"BLD",7026,"KRN",9.8,"NM",36,0)
+MAGDMEDL^^0^B3132920
+"BLD",7026,"KRN",9.8,"NM",37,0)
+PRCSEA^^0^B66865498
+"BLD",7026,"KRN",9.8,"NM",38,0)
+PSBOMH1^^0^B71152392
+"BLD",7026,"KRN",9.8,"NM",39,0)
+PSBRPC2^^0^B44967923
+"BLD",7026,"KRN",9.8,"NM",40,0)
+PXRMTMED^^0^B9970277
+"BLD",7026,"KRN",9.8,"NM",41,0)
+VALMW3^^0^B21033865
+"BLD",7026,"KRN",9.8,"NM",42,0)
+XQALSUR1^^0^B29675685
+"BLD",7026,"KRN",9.8,"NM",43,0)
+XUMF5AU^^0^B76801793
+"BLD",7026,"KRN",9.8,"NM",44,0)
+ZSTOPGUX^^0^B148072
+"BLD",7026,"KRN",9.8,"NM",46,0)
+MSCZJOBS^^0^B5731054
+"BLD",7026,"KRN",9.8,"NM",47,0)
+ZOSVONT^^0^B23474671
+"BLD",7026,"KRN",9.8,"NM",48,0)
+ZISFGTM^^0^B9317180
+"BLD",7026,"KRN",9.8,"NM",49,0)
+ZSSGUX^^0^B47435
+"BLD",7026,"KRN",9.8,"NM",50,0)
+XWBRW^^0^B8699412
+"BLD",7026,"KRN",9.8,"NM",51,0)
+XWBSEC^^0^B5872236
+"BLD",7026,"KRN",9.8,"NM",52,0)
+HLZTCP^^0^B44973921
+"BLD",7026,"KRN",9.8,"NM",53,0)
+HLCSTCP2^^0^B62380874
+"BLD",7026,"KRN",9.8,"NM",54,0)
+HLCSTCP3^^0^B4155616
+"BLD",7026,"KRN",9.8,"NM",55,0)
+HLCSTCP4^^0^B3608309
+"BLD",7026,"KRN",9.8,"NM","B","DGMSTAPI",34)
+
+"BLD",7026,"KRN",9.8,"NM","B","GMRCA2",35)
+
+"BLD",7026,"KRN",9.8,"NM","B","HLCSLNCH",18)
+
+"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP",17)
+
+"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP1",16)
+
+"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP2",53)
+
+"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP3",54)
+
+"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP4",55)
+
+"BLD",7026,"KRN",9.8,"NM","B","HLZTCP",52)
+
+"BLD",7026,"KRN",9.8,"NM","B","MAGDMEDL",36)
+
+"BLD",7026,"KRN",9.8,"NM","B","MSCXUS3A",31)
+
+"BLD",7026,"KRN",9.8,"NM","B","MSCZJOB",1)
+
+"BLD",7026,"KRN",9.8,"NM","B","MSCZJOBS",46)
+
+"BLD",7026,"KRN",9.8,"NM","B","MSCZJOBU",4)
+
+"BLD",7026,"KRN",9.8,"NM","B","PRCSEA",37)
+
+"BLD",7026,"KRN",9.8,"NM","B","PSBOMH1",38)
+
+"BLD",7026,"KRN",9.8,"NM","B","PSBRPC2",39)
+
+"BLD",7026,"KRN",9.8,"NM","B","PXRMTMED",40)
+
+"BLD",7026,"KRN",9.8,"NM","B","RORHL7A",32)
+
+"BLD",7026,"KRN",9.8,"NM","B","VALMW3",41)
+
+"BLD",7026,"KRN",9.8,"NM","B","XOBVLL",19)
+
+"BLD",7026,"KRN",9.8,"NM","B","XOBVRH",20)
+
+"BLD",7026,"KRN",9.8,"NM","B","XOBVSKT",21)
+
+"BLD",7026,"KRN",9.8,"NM","B","XOBVTCPL",22)
+
+"BLD",7026,"KRN",9.8,"NM","B","XPDR",26)
+
+"BLD",7026,"KRN",9.8,"NM","B","XQALSUR1",42)
+
+"BLD",7026,"KRN",9.8,"NM","B","XTER1A",7)
+
+"BLD",7026,"KRN",9.8,"NM","B","XUMF5AU",43)
+
+"BLD",7026,"KRN",9.8,"NM","B","XWBRW",50)
+
+"BLD",7026,"KRN",9.8,"NM","B","XWBSEC",51)
+
+"BLD",7026,"KRN",9.8,"NM","B","XWBTCPM",23)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZCD",11)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZIS4GTM",5)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZISFGTM",48)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZISFGUX",27)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZISHGUX",15)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZISTCPS",25)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZOSFGUX",14)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZOSV2GTM",13)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZOSVGUX",33)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZOSVONT",47)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZSSGUX",49)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZSTARTGUX",29)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZSTOPGUX",44)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZTER",28)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZTMGRSET",24)
+
+"BLD",7026,"KRN",9.8,"NM","B","ZUGTM",8)
+
+"BLD",7026,"KRN",19,0)
+19
+"BLD",7026,"KRN",19,"NM",0)
+^9.68A^2^2
+"BLD",7026,"KRN",19,"NM",1,0)
+MSCZJOB^^0
+"BLD",7026,"KRN",19,"NM",2,0)
+MSCZLOCK^^0
+"BLD",7026,"KRN",19,"NM","B","MSCZJOB",1)
+
+"BLD",7026,"KRN",19,"NM","B","MSCZLOCK",2)
+
+"BLD",7026,"KRN",19.1,0)
+19.1
+"BLD",7026,"KRN",101,0)
+101
+"BLD",7026,"KRN",409.61,0)
+409.61
+"BLD",7026,"KRN",771,0)
+771
+"BLD",7026,"KRN",870,0)
+870
+"BLD",7026,"KRN",8989.51,0)
+8989.51
+"BLD",7026,"KRN",8989.52,0)
+8989.52
+"BLD",7026,"KRN",8994,0)
+8994
+"BLD",7026,"KRN","B",.4,.4)
+
+"BLD",7026,"KRN","B",.401,.401)
+
+"BLD",7026,"KRN","B",.402,.402)
+
+"BLD",7026,"KRN","B",.403,.403)
+
+"BLD",7026,"KRN","B",.5,.5)
+
+"BLD",7026,"KRN","B",.84,.84)
+
+"BLD",7026,"KRN","B",3.6,3.6)
+
+"BLD",7026,"KRN","B",3.8,3.8)
+
+"BLD",7026,"KRN","B",9.2,9.2)
+
+"BLD",7026,"KRN","B",9.8,9.8)
+
+"BLD",7026,"KRN","B",19,19)
+
+"BLD",7026,"KRN","B",19.1,19.1)
+
+"BLD",7026,"KRN","B",101,101)
+
+"BLD",7026,"KRN","B",409.61,409.61)
+
+"BLD",7026,"KRN","B",771,771)
+
+"BLD",7026,"KRN","B",870,870)
+
+"BLD",7026,"KRN","B",8989.51,8989.51)
+
+"BLD",7026,"KRN","B",8989.52,8989.52)
+
+"BLD",7026,"KRN","B",8994,8994)
+
+"BLD",7026,"MSC")
+/home/jon/MSC_GTM_INTEG_12.KID
+"BLD",7026,"MSCOM")
+VERSION 12 - HL7 IMPROVEMENTS
+"BLD",7026,"PRE")
+MSCGUX53
+"BLD",7026,"QUES",0)
+^9.62^^
+"KRN",.403,121,-1)
+0^1
+"KRN",.403,121,0)
+MSCZJOBEXAM^ ^@^^3070530.1755^^^3.081^0^1^1
+"KRN",.403,121,12)
+
+"KRN",.403,121,21)
+
+"KRN",.403,121,40,0)
+^.4031I^3^3
+"KRN",.403,121,40,1,0)
+1^^1,1^^^1^17,80
+"KRN",.403,121,40,1,1)
+Page 1
+"KRN",.403,121,40,1,40,0)
+^.4032IP^433^2
+"KRN",.403,121,40,1,40,432,0)
+MSCZJOBEXAM^4^3,2^e
+"KRN",.403,121,40,1,40,432,2)
+13^^u^^1
+"KRN",.403,121,40,1,40,432,"COMP MUL")
+D COMPMUL^MSCZJOB
+"KRN",.403,121,40,1,40,432,"COMP MUL PTR")
+
+"KRN",.403,121,40,1,40,433,0)
+MSCZJOBEXAM HDR^1^1,2^d
+"KRN",.403,121,40,2,0)
+2^^1,1^^^1^18,79
+"KRN",.403,121,40,2,1)
+Page 2
+"KRN",.403,121,40,2,40,0)
+^.4032IP^437^3
+"KRN",.403,121,40,2,40,434,0)
+MSCZJOBEXAM 2^1^1,1^e
+"KRN",.403,121,40,2,40,435,0)
+MSCZJOBVARS^3^8,3^e
+"KRN",.403,121,40,2,40,435,2)
+9^^f^^1
+"KRN",.403,121,40,2,40,435,"COMP MUL")
+D COMPVARS^MSCZJOB
+"KRN",.403,121,40,2,40,437,0)
+MSCZJOBSTACK^4^3,3^e
+"KRN",.403,121,40,2,40,437,2)
+3^
+"KRN",.403,121,40,2,40,437,"COMP MUL")
+D COMPSTK^MSCZJOB
+"KRN",.403,121,40,3,0)
+3^^4,4^^^1^15,70
+"KRN",.403,121,40,3,1)
+Page 3
+"KRN",.403,121,40,3,40,0)
+^.4032IP^436^1
+"KRN",.403,121,40,3,40,436,0)
+MSCZJOBLOCKS^1^2,3^e
+"KRN",.403,121,40,3,40,436,2)
+6^
+"KRN",.403,121,40,3,40,436,"COMP MUL")
+D COMPLKS^MSCZJOB
+"KRN",.403,121,21400)
+1
+"KRN",.403,122,-1)
+0^2
+"KRN",.403,122,0)
+MSCZLOCK^ ^@^^3070530.1755^^^3.081^0^1^1
+"KRN",.403,122,40,0)
+^.4031I^1^1
+"KRN",.403,122,40,1,0)
+1^^1,1^^^0^17,80
+"KRN",.403,122,40,1,1)
+Page 1
+"KRN",.403,122,40,1,40,0)
+^.4032IP^439^2
+"KRN",.403,122,40,1,40,438,0)
+MSCZLOCKEXAM^4^3,2^e
+"KRN",.403,122,40,1,40,438,2)
+13^^u^^1
+"KRN",.403,122,40,1,40,438,"COMP MUL")
+D COMPLK^MSCZJOB
+"KRN",.403,122,40,1,40,439,0)
+MSCZJOBLOCK HDR^1^1,1^d
+"KRN",.404,432,0)
+MSCZJOBEXAM^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=$$JOB^MSCZJOB(D0) 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^^DEVICE
+"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=$$DEV^MSCZJOB(D0)
+"KRN",.404,432,40,2,4)
+^^^1
+"KRN",.404,432,40,2,20)
+F
+"KRN",.404,432,40,3,0)
+4^^2^^NAMESPACE
+"KRN",.404,432,40,3,2)
+1,48^11
+"KRN",.404,432,40,3,3)
+!M
+"KRN",.404,432,40,3,3.1)
+S Y=$$NSP^MSCZJOB(D0)
+"KRN",.404,432,40,3,4)
+^^^1
+"KRN",.404,432,40,3,20)
+F
+"KRN",.404,432,40,4,0)
+5^^2^^ROUTINE
+"KRN",.404,432,40,4,2)
+1,60^18
+"KRN",.404,432,40,4,3)
+!M
+"KRN",.404,432,40,4,3.1)
+S Y=$$ROUTINE^MSCZJOB(D0)
+"KRN",.404,432,40,4,4)
+^^^1
+"KRN",.404,432,40,4,20)
+F^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=$$USER^MSCZJOB(D0)
+"KRN",.404,432,40,5,4)
+^^^1
+"KRN",.404,432,40,5,20)
+F
+"KRN",.404,433,0)
+MSCZJOBEXAM HDR^3.081^
+"KRN",.404,433,40,0)
+^.4044I^2^2
+"KRN",.404,433,40,1,0)
+1^Process Device                  User           Namespace   Routine      ^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",.404,434,0)
+MSCZJOBEXAM 2^3.081
+"KRN",.404,434,40,0)
+^.4044I^7^7
+"KRN",.404,434,40,1,0)
+1^Job^2^^JOB NUMBER
+"KRN",.404,434,40,1,2)
+2,8^6^2,3
+"KRN",.404,434,40,1,3)
+!M
+"KRN",.404,434,40,1,3.1)
+S Y=$$JOB^MSCZJOB(MSCJOBD0)
+"KRN",.404,434,40,1,20)
+N
+"KRN",.404,434,40,2,0)
+2^NSpace^2^^NAMESPACE
+"KRN",.404,434,40,2,2)
+2,24^11^2,16
+"KRN",.404,434,40,2,3)
+!M
+"KRN",.404,434,40,2,3.1)
+S Y=$$NSP^MSCZJOB(MSCJOBD0)
+"KRN",.404,434,40,2,4)
+^^^2
+"KRN",.404,434,40,2,20)
+F
+"KRN",.404,434,40,3,0)
+3^Routine^2
+"KRN",.404,434,40,3,2)
+2,46^16^2,37
+"KRN",.404,434,40,3,3)
+!M
+"KRN",.404,434,40,3,3.1)
+S Y=$$ROUTINE^MSCZJOB(MSCJOBD0)
+"KRN",.404,434,40,3,4)
+^^^2
+"KRN",.404,434,40,3,20)
+F^U
+"KRN",.404,434,40,4,0)
+4^^2^^USER
+"KRN",.404,434,40,4,2)
+2,63^14
+"KRN",.404,434,40,4,3)
+!M
+"KRN",.404,434,40,4,3.1)
+S Y=$$USER^MSCZJOB(MSCJOBD0)
+"KRN",.404,434,40,4,4)
+^^^2
+"KRN",.404,434,40,4,20)
+F
+"KRN",.404,434,40,5,0)
+5^Device^2^^DEVICE
+"KRN",.404,434,40,5,2)
+3,24^38^3,16
+"KRN",.404,434,40,5,3)
+!M
+"KRN",.404,434,40,5,3.1)
+S Y=$$DEV^MSCZJOB(MSCJOBD0)
+"KRN",.404,434,40,5,4)
+^^^1
+"KRN",.404,434,40,5,20)
+F^U
+"KRN",.404,434,40,6,0)
+4.4^LOCKs^2^^LOCKS
+"KRN",.404,434,40,6,2)
+3,10^3^3,3
+"KRN",.404,434,40,6,3)
+!M
+"KRN",.404,434,40,6,3.1)
+S Y=$$LOCKS^MSCZJOB
+"KRN",.404,434,40,6,10)
+S DDSSTACK=3
+"KRN",.404,434,40,6,20)
+N
+"KRN",.404,434,40,7,0)
+6^KILL JOB?^2^^KILL
+"KRN",.404,434,40,7,2)
+3,74^3^3,63
+"KRN",.404,434,40,7,13)
+N X,Y I DDSEXT="YES" D KILL^MSCZJOB(MSCJOBID)
+"KRN",.404,434,40,7,20)
+Y
+"KRN",.404,435,0)
+MSCZJOBVARS^3.081
+"KRN",.404,435,40,0)
+^.4044I^3^3
+"KRN",.404,435,40,1,0)
+1^^2^^VARIABLE NAME
+"KRN",.404,435,40,1,2)
+1,1^24
+"KRN",.404,435,40,1,3)
+!M
+"KRN",.404,435,40,1,3.1)
+S Y=$P(@MSC@(MSCJOBID,"V",D0),"=")
+"KRN",.404,435,40,1,4)
+^^^2
+"KRN",.404,435,40,1,20)
+F
+"KRN",.404,435,40,2,0)
+2^^2^^VALUE OF VARIABLE
+"KRN",.404,435,40,2,2)
+1,28^48
+"KRN",.404,435,40,2,3)
+!M
+"KRN",.404,435,40,2,3.1)
+S Y=$P(@MSC@(MSCJOBID,"V",D0),"=",2,999)
+"KRN",.404,435,40,2,4)
+^^^2
+"KRN",.404,435,40,2,20)
+F^U
+"KRN",.404,435,40,3,0)
+1.5^=^1
+"KRN",.404,435,40,3,2)
+^^1,26
+"KRN",.404,436,0)
+MSCZJOBLOCKS^3.081^
+"KRN",.404,436,40,0)
+^.4044I^2^2
+"KRN",.404,436,40,1,0)
+1^^2^^LOCKS
+"KRN",.404,436,40,1,2)
+2,1^47
+"KRN",.404,436,40,1,3)
+!M
+"KRN",.404,436,40,1,3.1)
+S Y=@MSC@(MSCJOBID,"L",D0)
+"KRN",.404,436,40,1,4)
+^^^2
+"KRN",.404,436,40,1,20)
+F^U
+"KRN",.404,436,40,2,0)
+2^UNLOCK?^2^^UNLOCK
+"KRN",.404,436,40,2,2)
+2,58^3^2,49^1
+"KRN",.404,436,40,2,13)
+I DDSEXT="YES" D UNLOCK^MSCZJOB(D0)
+"KRN",.404,436,40,2,20)
+Y
+"KRN",.404,437,0)
+MSCZJOBSTACK^3.081
+"KRN",.404,437,40,0)
+^.4044I^1^1
+"KRN",.404,437,40,1,0)
+1^^2^^STACK
+"KRN",.404,437,40,1,2)
+2,1^75
+"KRN",.404,437,40,1,3)
+!M
+"KRN",.404,437,40,1,3.1)
+S Y=$$STACK^MSCZJOB(D0)
+"KRN",.404,437,40,1,4)
+^^^2
+"KRN",.404,437,40,1,20)
+F^U
+"KRN",.404,438,0)
+MSCZLOCKEXAM^3.081
+"KRN",.404,438,40,0)
+^.4044I^5^5
+"KRN",.404,438,40,1,0)
+1^^2^^JOB NUMBER
+"KRN",.404,438,40,1,2)
+1,2^6
+"KRN",.404,438,40,1,3)
+!M
+"KRN",.404,438,40,1,3.1)
+S Y=$P($G(MSCZLK(D0)),U,5) S:Y=$J Y=Y_"*"
+"KRN",.404,438,40,1,4)
+^^^2
+"KRN",.404,438,40,1,10)
+S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U)
+"KRN",.404,438,40,1,20)
+F
+"KRN",.404,438,40,2,0)
+2^^2^^LOCK
+"KRN",.404,438,40,2,2)
+1,9^23
+"KRN",.404,438,40,2,3)
+!M
+"KRN",.404,438,40,2,3.1)
+S Y=$TR($P($G(MSCZLK(D0)),U),"~")
+"KRN",.404,438,40,2,4)
+^^^1
+"KRN",.404,438,40,2,20)
+F
+"KRN",.404,438,40,3,0)
+4^^2^^ROUTINE
+"KRN",.404,438,40,3,2)
+1,48^25
+"KRN",.404,438,40,3,3)
+!M
+"KRN",.404,438,40,3,3.1)
+S Y=$TR($P($G(MSCZLK(D0)),U,3),$C(126),U)
+"KRN",.404,438,40,3,4)
+^^^1
+"KRN",.404,438,40,3,20)
+F^U
+"KRN",.404,438,40,4,0)
+5^^2^^UNLOCK
+"KRN",.404,438,40,4,2)
+1,76^3
+"KRN",.404,438,40,4,3)
+!M
+"KRN",.404,438,40,4,4)
+^^^0
+"KRN",.404,438,40,4,13)
+I DDSEXT="YES" D UNL^MSCZJOB(D0)
+"KRN",.404,438,40,4,20)
+Y^U
+"KRN",.404,438,40,5,0)
+3^^2^^USER
+"KRN",.404,438,40,5,2)
+1,33^14
+"KRN",.404,438,40,5,3)
+!M
+"KRN",.404,438,40,5,3.1)
+S Y=$P($G(MSCZLK(D0)),U,2)
+"KRN",.404,438,40,5,4)
+^^^1
+"KRN",.404,438,40,5,20)
+F
+"KRN",.404,439,0)
+MSCZJOBLOCK HDR^3.081
+"KRN",.404,439,40,0)
+^.4044I^2^2
+"KRN",.404,439,40,1,0)
+1^Process  Lock                    User           Routine                   Unlock^1
+"KRN",.404,439,40,1,2)
+^^2,1
+"KRN",.404,439,40,2,0)
+2^!M^1
+"KRN",.404,439,40,2,.1)
+S Y=$$GET1^DIQ(8989.3,1,.01)
+"KRN",.404,439,40,2,2)
+^^1,28
+"KRN",19,14339,-1)
+0^1
+"KRN",19,14339,0)
+MSCZJOB^JOB EXAMINE^^R^^^^^^^^
+"KRN",19,14339,1,0)
+^^1^1^3070623^
+"KRN",19,14339,1,1,0)
+DESIGNED FOR GT.M
+"KRN",19,14339,25)
+MSCZJOB
+"KRN",19,14339,"U")
+JOB EXAMINE
+"KRN",19,14340,-1)
+0^2
+"KRN",19,14340,0)
+MSCZLOCK^LOCK EXAMINE^^R^^^^^^^^
+"KRN",19,14340,1,0)
+^^1^1^3070623^
+"KRN",19,14340,1,1,0)
+DESIGNED FOR GT.M
+"KRN",19,14340,25)
+LOCK^MSCZJOB
+"KRN",19,14340,"U")
+LOCK EXAMINE
+"MBREQ")
+0
+"ORD",0,9.8)
+9.8;;1;RTNF^XPDTA;RTNE^XPDTA
+"ORD",0,9.8,0)
+ROUTINE
+"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
+"PRE")
+MSCGUX53
+"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")
+NO
+"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")
+NO
+"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")
+NO
+"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")
+48
+"RTN","DGMSTAPI")
+0^34^B48539163
+"RTN","DGMSTAPI",1,0)
+DGMSTAPI ;ALB/SCK,MSC/JDA - API's for Military Sexual Trauma ;29APR2009
+"RTN","DGMSTAPI",2,0)
+ ;;5.3;Registration;**195,243,308,353,379,443,700,JDA**;Aug 13, 1993
+"RTN","DGMSTAPI",3,0)
+ Q
+"RTN","DGMSTAPI",4,0)
+ ;
+"RTN","DGMSTAPI",5,0)
+GETSTAT(DFN,DGDATE) ;  Retrieves the current MST status for a patient
+"RTN","DGMSTAPI",6,0)
+ ;
+"RTN","DGMSTAPI",7,0)
+ ;  Input
+"RTN","DGMSTAPI",8,0)
+ ;    DFN  - IEN of patient in the PATIENT File (#2)
+"RTN","DGMSTAPI",9,0)
+ ;    DGDATE - Date for status lookup [OPTIONAL]
+"RTN","DGMSTAPI",10,0)
+ ;
+"RTN","DGMSTAPI",11,0)
+ ;  Output
+"RTN","DGMSTAPI",12,0)
+ ;    DGMST - Format will depend on result of lookup
+"RTN","DGMSTAPI",13,0)
+ ;
+"RTN","DGMSTAPI",14,0)
+ ;    If an entry is found then:
+"RTN","DGMSTAPI",15,0)
+ ;       DGMST returns a 7 piece data string, caret(^)-delimited:
+"RTN","DGMSTAPI",16,0)
+ ;        $P(1) = IEN of entry in MST HISTORY File (#29.11)
+"RTN","DGMSTAPI",17,0)
+ ;        $P(2) = Internal value of MST Status ("Y,N,D,U")
+"RTN","DGMSTAPI",18,0)
+ ;        $P(3) = Date of status change
+"RTN","DGMSTAPI",19,0)
+ ;        $P(4) = IEN of provider making determination, file (#200)
+"RTN","DGMSTAPI",20,0)
+ ;        $P(5) = IEN of user who entered status, file (#200)
+"RTN","DGMSTAPI",21,0)
+ ;        $P(6) = External format of MST Status
+"RTN","DGMSTAPI",22,0)
+ ;        $P(7) = IEN pointer of the INSTITUTION file (#4)
+"RTN","DGMSTAPI",23,0)
+ ;
+"RTN","DGMSTAPI",24,0)
+ ;    If no MST History is found, then:
+"RTN","DGMSTAPI",25,0)
+ ;       DGMST = 0^U
+"RTN","DGMSTAPI",26,0)
+ ;                "U" = (Unknown)
+"RTN","DGMSTAPI",27,0)
+ ;    If an error occured in the GETS^DIQ lookup, then:
+"RTN","DGMSTAPI",28,0)
+ ;       DGMST = -1^^Error Code IEN
+"RTN","DGMSTAPI",29,0)
+ ;                   (returned by GETS^DIQ call)
+"RTN","DGMSTAPI",30,0)
+ ;
+"RTN","DGMSTAPI",31,0)
+ ; Get most recent MST status entry for the patient from file using
+"RTN","DGMSTAPI",32,0)
+ ;  reverse $Order on the "APDT" x-ref.
+"RTN","DGMSTAPI",33,0)
+ ;
+"RTN","DGMSTAPI",34,0)
+ N DGMST,DGIEN,DGFDA,DGMSG
+"RTN","DGMSTAPI",35,0)
+ S DFN=$G(DFN)
+"RTN","DGMSTAPI",36,0)
+ I '+DFN!('$D(^DPT(DFN,0))) D  G STATQ
+"RTN","DGMSTAPI",37,0)
+ . S DGMST="-1"
+"RTN","DGMSTAPI",38,0)
+ I '$D(^DGMS(29.11,"APDT",DFN))  D  G STATQ
+"RTN","DGMSTAPI",39,0)
+ .S DGMST="0^U"
+"RTN","DGMSTAPI",40,0)
+ S DGDATE=$S(+$G(DGDATE)>0:DGDATE,1:$$NOW^XLFDT)
+"RTN","DGMSTAPI",41,0)
+ I '$D(^DGMS(29.11,"APDT",DFN,DGDATE)) S DGDATE=$$DATE(DFN,DGDATE)
+"RTN","DGMSTAPI",42,0)
+ I '+DGDATE D  G STATQ
+"RTN","DGMSTAPI",43,0)
+ . S DGMST="0^U"
+"RTN","DGMSTAPI",44,0)
+ S DGIEN=""
+"RTN","DGMSTAPI",45,0)
+ S DGIEN=+$O(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1)
+"RTN","DGMSTAPI",46,0)
+ ;
+"RTN","DGMSTAPI",47,0)
+ ; Check for valid ien, if entry missing, return Unknown
+"RTN","DGMSTAPI",48,0)
+ I +DGIEN'>0 D  G STATQ
+"RTN","DGMSTAPI",49,0)
+ . S DGMST="0^U"
+"RTN","DGMSTAPI",50,0)
+ ;
+"RTN","DGMSTAPI",51,0)
+ ; Retrieve data
+"RTN","DGMSTAPI",52,0)
+ D GETS^DIQ(29.11,+DGIEN_",","*","IE","DGFDA","DGMSG")
+"RTN","DGMSTAPI",53,0)
+ ; check for errors
+"RTN","DGMSTAPI",54,0)
+ I $D(DGMSG) D  G STATQ
+"RTN","DGMSTAPI",55,0)
+ .S DGMST="-1^^"_$G(DGMSG("DIERR",1))
+"RTN","DGMSTAPI",56,0)
+ ;
+"RTN","DGMSTAPI",57,0)
+ S DGMST=DGIEN_U_$G(DGFDA(29.11,+DGIEN_",",3,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",.01,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",4,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",5,"I"))
+"RTN","DGMSTAPI",58,0)
+ S DGMST=DGMST_U_$G(DGFDA(29.11,+DGIEN_",",3,"E"))
+"RTN","DGMSTAPI",59,0)
+ S DGMST=DGMST_U_$S($G(DGFDA(29.11,+DGIEN_",",6,"I"))]"":$G(DGFDA(29.11,+DGIEN_",",6,"I")),1:$$SITE)
+"RTN","DGMSTAPI",60,0)
+ ;
+"RTN","DGMSTAPI",61,0)
+STATQ Q $G(DGMST)
+"RTN","DGMSTAPI",62,0)
+ ;
+"RTN","DGMSTAPI",63,0)
+NEWSTAT(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGXMIT) ; MST HISTORY (#29.11) filer
+"RTN","DGMSTAPI",64,0)
+ ; Callpoint to create a new MST HISTORY FILE (#29.11) entry.
+"RTN","DGMSTAPI",65,0)
+ ; Will also queue HL7 message for HEC database updates.
+"RTN","DGMSTAPI",66,0)
+ ;
+"RTN","DGMSTAPI",67,0)
+ ;  Input
+"RTN","DGMSTAPI",68,0)
+ ;    DFN    - Patients DFN
+"RTN","DGMSTAPI",69,0)
+ ;    DGSTAT - MST Status code, "Y,N,D,U"
+"RTN","DGMSTAPI",70,0)
+ ;    DGDATE - Date of MST status change  [default=NOW]
+"RTN","DGMSTAPI",71,0)
+ ;    DGPROV - IEN of Provider making determination, file (#200)
+"RTN","DGMSTAPI",72,0)
+ ;    DGSITE - IEN pointer of the INSTITUTION file (#4)
+"RTN","DGMSTAPI",73,0)
+ ;    DGXMIT - HL7 transmit flag [OPTIONAL]
+"RTN","DGMSTAPI",74,0)
+ ;              0=don't queue a message
+"RTN","DGMSTAPI",75,0)
+ ;              1=queue a message [default])
+"RTN","DGMSTAPI",76,0)
+ ;
+"RTN","DGMSTAPI",77,0)
+ ;  Output
+"RTN","DGMSTAPI",78,0)
+ ;    DGRSLT - Returns IEN of file (#29.11) entry if successful
+"RTN","DGMSTAPI",79,0)
+ ;
+"RTN","DGMSTAPI",80,0)
+ ;    If no patient was defined, then:
+"RTN","DGMSTAPI",81,0)
+ ;       DGRSLT = -1^No patient defined
+"RTN","DGMSTAPI",82,0)
+ ;
+"RTN","DGMSTAPI",83,0)
+ ;    If an error occured in the GETS^DIQ lookup, then:
+"RTN","DGMSTAPI",84,0)
+ ;       DGMST = -1^^Error Code IEN
+"RTN","DGMSTAPI",85,0)
+ ;                   (returned by GETS^DIQ call)
+"RTN","DGMSTAPI",86,0)
+ ;
+"RTN","DGMSTAPI",87,0)
+ N DGFDA,DGMSG,DGERR,DGRSLT,MSTIEN
+"RTN","DGMSTAPI",88,0)
+ S DFN=$G(DFN)
+"RTN","DGMSTAPI",89,0)
+ I DFN']""!('$D(^DPT(DFN,0))) D  G NEWQ
+"RTN","DGMSTAPI",90,0)
+ . S DGRSLT="-1^No patient defined"
+"RTN","DGMSTAPI",91,0)
+ ;
+"RTN","DGMSTAPI",92,0)
+ S DGSTAT=$S($G(DGSTAT)]"":DGSTAT,1:"U")
+"RTN","DGMSTAPI",93,0)
+ S DGDATE=$G(DGDATE)
+"RTN","DGMSTAPI",94,0)
+ S DGPROV=$G(DGPROV)
+"RTN","DGMSTAPI",95,0)
+ S DGSITE=$G(DGSITE)
+"RTN","DGMSTAPI",96,0)
+ S DGXMIT=$S($G(DGXMIT)=0:DGXMIT,1:1)
+"RTN","DGMSTAPI",97,0)
+ S DGDATE=$S(+DGDATE>0:DGDATE,1:$$NOW^XLFDT)
+"RTN","DGMSTAPI",98,0)
+ S DGSITE=$S(+DGSITE>0:DGSITE,1:$$SITE)
+"RTN","DGMSTAPI",99,0)
+ ;
+"RTN","DGMSTAPI",100,0)
+ I '$$CHANGE(DFN,DGSTAT,DGDATE) D  G NEWQ
+"RTN","DGMSTAPI",101,0)
+ . S DGRSLT="0"
+"RTN","DGMSTAPI",102,0)
+ ;
+"RTN","DGMSTAPI",103,0)
+ I '$$VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,.DGERR) D  G NEWQ
+"RTN","DGMSTAPI",104,0)
+ . S DGRSLT="-1^"_DGERR
+"RTN","DGMSTAPI",105,0)
+ ;
+"RTN","DGMSTAPI",106,0)
+ S DGFDA(1,29.11,"+1,",.01)=DGDATE
+"RTN","DGMSTAPI",107,0)
+ S DGFDA(1,29.11,"+1,",2)=DFN
+"RTN","DGMSTAPI",108,0)
+ S DGFDA(1,29.11,"+1,",3)=DGSTAT
+"RTN","DGMSTAPI",109,0)
+ S DGFDA(1,29.11,"+1,",4)=DGPROV
+"RTN","DGMSTAPI",110,0)
+ S DGFDA(1,29.11,"+1,",5)=DUZ
+"RTN","DGMSTAPI",111,0)
+ S DGFDA(1,29.11,"+1,",6)=DGSITE
+"RTN","DGMSTAPI",112,0)
+ ;
+"RTN","DGMSTAPI",113,0)
+ D UPDATE^DIE("","DGFDA(1)","MSTIEN","DGERR")
+"RTN","DGMSTAPI",114,0)
+ I $D(DGERR) D  G NEWQ
+"RTN","DGMSTAPI",115,0)
+ . S DGRSLT="-1^"_$G(DGERR("DIERR",1))
+"RTN","DGMSTAPI",116,0)
+ ;
+"RTN","DGMSTAPI",117,0)
+ S DGRSLT=+MSTIEN(1)
+"RTN","DGMSTAPI",118,0)
+ ;
+"RTN","DGMSTAPI",119,0)
+ ; Callpoint to queue an entry that will trigger a HEC
+"RTN","DGMSTAPI",120,0)
+ ;  Enrollment Full Data Transmission (ORF/ORU~ZO7) HL7 message.
+"RTN","DGMSTAPI",121,0)
+ ; The HL7 message will contain the following three MST data elments
+"RTN","DGMSTAPI",122,0)
+ ;  as part of the VA-Specific Eligibility ZEL segment:
+"RTN","DGMSTAPI",123,0)
+ ;   (23) - MST STATUS
+"RTN","DGMSTAPI",124,0)
+ ;   (24) - DATE MST STATUS CHANGED
+"RTN","DGMSTAPI",125,0)
+ ;   (25) - SITE DETERMINING MST STATUS
+"RTN","DGMSTAPI",126,0)
+ ;
+"RTN","DGMSTAPI",127,0)
+ I DGXMIT D
+"RTN","DGMSTAPI",128,0)
+ . D SEND^DGMSTL1(DFN,"Z07")
+"RTN","DGMSTAPI",129,0)
+ ;
+"RTN","DGMSTAPI",130,0)
+NEWQ Q $G(DGRSLT)
+"RTN","DGMSTAPI",131,0)
+ ;
+"RTN","DGMSTAPI",132,0)
+DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in.  
+"RTN","DGMSTAPI",133,0)
+ ; This call is not to be used except from inside the DG MST List
+"RTN","DGMSTAPI",134,0)
+ ; Manager interface.  
+"RTN","DGMSTAPI",135,0)
+ ;
+"RTN","DGMSTAPI",136,0)
+ ; Input
+"RTN","DGMSTAPI",137,0)
+ ;    MSTIEN   - IEN of the entry in the MST HISTORY File (#29.11)
+"RTN","DGMSTAPI",138,0)
+ ;
+"RTN","DGMSTAPI",139,0)
+ ; Output
+"RTN","DGMSTAPI",140,0)
+ ;    If no IEN passed in, return -1
+"RTN","DGMSTAPI",141,0)
+ ;    otherwise return 1
+"RTN","DGMSTAPI",142,0)
+ ;
+"RTN","DGMSTAPI",143,0)
+ Q:'$G(MSTIEN) "-1^No entry to delete"
+"RTN","DGMSTAPI",144,0)
+ ;
+"RTN","DGMSTAPI",145,0)
+ N DA,XD
+"RTN","DGMSTAPI",146,0)
+ S DA=+$G(MSTIEN)
+"RTN","DGMSTAPI",147,0)
+ S DIK="^DGMS(29.11,"
+"RTN","DGMSTAPI",148,0)
+ D ^DIK K DIK
+"RTN","DGMSTAPI",149,0)
+ Q 1
+"RTN","DGMSTAPI",150,0)
+ ;
+"RTN","DGMSTAPI",151,0)
+NAME(DA) ; Returns name from the VA NEW PERSON File using DIQ call
+"RTN","DGMSTAPI",152,0)
+ ;
+"RTN","DGMSTAPI",153,0)
+ N DGNAME,DGPROV,DIQ,DR,DIC
+"RTN","DGMSTAPI",154,0)
+ I $G(DA)="" G NAMEQ
+"RTN","DGMSTAPI",155,0)
+ S DIC=200,DR=".01",DIQ="DGPROV"
+"RTN","DGMSTAPI",156,0)
+ D EN^DIQ1
+"RTN","DGMSTAPI",157,0)
+ S DGNAME=$G(DGPROV(200,DA,.01))
+"RTN","DGMSTAPI",158,0)
+NAMEQ Q $G(DGNAME)
+"RTN","DGMSTAPI",159,0)
+ ;
+"RTN","DGMSTAPI",160,0)
+CHANGE(DFN,DGSTAT,DGDATE) ;Did the Status OR Date change?
+"RTN","DGMSTAPI",161,0)
+ ;  Input
+"RTN","DGMSTAPI",162,0)
+ ;      DFN    - Patients DFN
+"RTN","DGMSTAPI",163,0)
+ ;      DGSTAT - MST Status code, "Y,N,D,U"
+"RTN","DGMSTAPI",164,0)
+ ;      DGDATE - Date of MST Status Change (FM format)
+"RTN","DGMSTAPI",165,0)
+ ;
+"RTN","DGMSTAPI",166,0)
+ ;  Output
+"RTN","DGMSTAPI",167,0)
+ ;      Returns 0 if no status change
+"RTN","DGMSTAPI",168,0)
+ ;              1 if status changed
+"RTN","DGMSTAPI",169,0)
+ ;
+"RTN","DGMSTAPI",170,0)
+ N DGCHG,DGMST
+"RTN","DGMSTAPI",171,0)
+ S DGCHG=0
+"RTN","DGMSTAPI",172,0)
+ I +$G(DFN)'>0!('$D(^DPT(DFN,0))) G CHNGQ
+"RTN","DGMSTAPI",173,0)
+ S DGSTAT=$G(DGSTAT)
+"RTN","DGMSTAPI",174,0)
+ I DGSTAT'?1A!("YNDU"'[DGSTAT) G CHNGQ
+"RTN","DGMSTAPI",175,0)
+ S DGDATE=$G(DGDATE)
+"RTN","DGMSTAPI",176,0)
+ I DGDATE="" G CHNGQ
+"RTN","DGMSTAPI",177,0)
+ S DGMST=$$GETSTAT(DFN),DGMST=$G(DGMST)
+"RTN","DGMSTAPI",178,0)
+ I +DGMST<1!($P(DGMST,U,2)'=$G(DGSTAT))!($P(DGMST,U,3)'=$G(DGDATE)) S DGCHG=1
+"RTN","DGMSTAPI",179,0)
+CHNGQ Q DGCHG
+"RTN","DGMSTAPI",180,0)
+ ;
+"RTN","DGMSTAPI",181,0)
+SITE(DGSITE) ;Convert a station number into a pointer to the
+"RTN","DGMSTAPI",182,0)
+ ; INSTITUTION file (#4).  If called with a null parameter then
+"RTN","DGMSTAPI",183,0)
+ ; the pointer to the INSTITUTION file (#4) of the primary site
+"RTN","DGMSTAPI",184,0)
+ ; will be returned.
+"RTN","DGMSTAPI",185,0)
+ ;
+"RTN","DGMSTAPI",186,0)
+ ;  Input
+"RTN","DGMSTAPI",187,0)
+ ;    DGSITE - Station number (optional)
+"RTN","DGMSTAPI",188,0)
+ ;
+"RTN","DGMSTAPI",189,0)
+ ;  Output
+"RTN","DGMSTAPI",190,0)
+ ;    Return Site IEN to INSTITUTION file (#4)
+"RTN","DGMSTAPI",191,0)
+ ;
+"RTN","DGMSTAPI",192,0)
+ S DGSITE=$G(DGSITE)
+"RTN","DGMSTAPI",193,0)
+ I DGSITE]"",$D(^DIC(4,"D",DGSITE)) D
+"RTN","DGMSTAPI",194,0)
+ . S DGSITE=$O(^DIC(4,"D",DGSITE,0))
+"RTN","DGMSTAPI",195,0)
+ E  D
+"RTN","DGMSTAPI",196,0)
+ . S DGSITE=$P($$SITE^VASITE,U)
+"RTN","DGMSTAPI",197,0)
+ I +DGSITE'>0 S DGSITE=""
+"RTN","DGMSTAPI",198,0)
+ Q DGSITE
+"RTN","DGMSTAPI",199,0)
+ ;
+"RTN","DGMSTAPI",200,0)
+DATE(DFN,DGDT) ;Determine 'current' MST date
+"RTN","DGMSTAPI",201,0)
+ ; 
+"RTN","DGMSTAPI",202,0)
+ ;  Input
+"RTN","DGMSTAPI",203,0)
+ ;    DFN  - Patient's DFN
+"RTN","DGMSTAPI",204,0)
+ ;    DGDT - FileMan format date
+"RTN","DGMSTAPI",205,0)
+ ;
+"RTN","DGMSTAPI",206,0)
+ ;  Output
+"RTN","DGMSTAPI",207,0)
+ ;    Return MST effective date
+"RTN","DGMSTAPI",208,0)
+ ;
+"RTN","DGMSTAPI",209,0)
+ N DGMSTDT
+"RTN","DGMSTAPI",210,0)
+ S DFN=$G(DFN)
+"RTN","DGMSTAPI",211,0)
+ I '+DFN D  G DATEQ
+"RTN","DGMSTAPI",212,0)
+ . S DGMSTDT=""
+"RTN","DGMSTAPI",213,0)
+ S DGDT=$S(+$G(DGDT)>0:DGDT,1:$$NOW^XLFDT)
+"RTN","DGMSTAPI",214,0)
+ I $P(DGDT,".",2)="" S DGDT=DGDT_".999999"
+"RTN","DGMSTAPI",215,0)
+ S DGMSTDT=$O(^DGMS(29.11,"APDT",DFN,DGDT),-1)
+"RTN","DGMSTAPI",216,0)
+DATEQ Q DGMSTDT
+"RTN","DGMSTAPI",217,0)
+ ;
+"RTN","DGMSTAPI",218,0)
+VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGERR) ;Validate fields before filing
+"RTN","DGMSTAPI",219,0)
+ ; Input:
+"RTN","DGMSTAPI",220,0)
+ ;      DFN - [REQUIRED] - ien of Patient
+"RTN","DGMSTAPI",221,0)
+ ;   DGSTAT - [REQUIRED] - MST Status code, "Y,N,D,U"
+"RTN","DGMSTAPI",222,0)
+ ;   DGDATE - [REQUIRED] - Date of MST status change[FileMan Internal]
+"RTN","DGMSTAPI",223,0)
+ ;   DGPROV - [optional] - IEN of Provider making determination
+"RTN","DGMSTAPI",224,0)
+ ;   DGSITE - [optional] - IEN pointer of the INSTITUTION file
+"RTN","DGMSTAPI",225,0)
+ ;    DGERR - [optional] - error parameter passed by reference
+"RTN","DGMSTAPI",226,0)
+ ; Output:
+"RTN","DGMSTAPI",227,0)
+ ;   Function Value - Returns 1 - if validation checks passed
+"RTN","DGMSTAPI",228,0)
+ ;                            0 - if validation checks failed
+"RTN","DGMSTAPI",229,0)
+ ;            DGERR - an error message if validation checks fail
+"RTN","DGMSTAPI",230,0)
+ ; init variables
+"RTN","DGMSTAPI",231,0)
+ N I,DGFILE,DGFLD,DGMSG,DGSTR,DGVAL,DGVAR,DGX,VALID
+"RTN","DGMSTAPI",232,0)
+ S DGFILE=29.11,VALID=1,DGMSG=" IS REQUIRED"
+"RTN","DGMSTAPI",233,0)
+ ; Quit DO block if invalid condition found
+"RTN","DGMSTAPI",234,0)
+ ; Check for [REQUIRED] fields
+"RTN","DGMSTAPI",235,0)
+ D
+"RTN","DGMSTAPI",236,0)
+ . I DFN="" D MSG(DGFILE,2,DGMSG,.DGERR) Q        ;pat ien
+"RTN","DGMSTAPI",237,0)
+ . I DGSTAT="" D MSG(DGFILE,3,DGMSG,.DGERR) Q     ;mst status code
+"RTN","DGMSTAPI",238,0)
+ . I DGDATE="" D MSG(DGFILE,.01,DGMSG,.DGERR) Q   ;dt chg status
+"RTN","DGMSTAPI",239,0)
+ .;
+"RTN","DGMSTAPI",240,0)
+ .; Check for valid FIELD values
+"RTN","DGMSTAPI",241,0)
+ . S DGMSG=" IS NOT VALID"
+"RTN","DGMSTAPI",242,0)
+ .; need to strip off the 'seconds' to pass the CHK^DIE() call...
+"RTN","DGMSTAPI",243,0)
+ . I DGDATE["." N DGSECS S DGSECS=$E($P(DGDATE,".",2),5,6) I DGSECS'="" I DGSECS<0!(DGSECS>60) D MSG(DGFILE,.01,DGMSG,.DGERR) Q
+"RTN","DGMSTAPI",244,0)
+ . N DGDATEX S DGDATEX=DGDATE
+"RTN","DGMSTAPI",245,0)
+ . I DGDATEX["." S DGDATEX=$P(DGDATEX,".")_"."_$E($P(DGDATEX,".",2),1,4)
+"RTN","DGMSTAPI",246,0)
+ . I $E($P(DGDATEX,".",2),1,4)="0000" S DGDATEX=$P(DGDATEX,".")_".1"
+"RTN","DGMSTAPI",247,0)
+ . S DGSTR=".01;DGDATEX^2;DFN^3;DGSTAT^4;DGPROV^5;DUZ^6;DGSITE"
+"RTN","DGMSTAPI",248,0)
+ .;
+"RTN","DGMSTAPI",249,0)
+ . F I=1:1:$L(DGSTR,U) S DGX=$P(DGSTR,U,I) Q:DGX=""  D  Q:'VALID
+"RTN","DGMSTAPI",250,0)
+ .. S DGFLD=$P(DGX,";"),DGVAR=$P(DGX,";",2),DGVAL=@DGVAR
+"RTN","DGMSTAPI",251,0)
+ .. Q:DGVAL=""
+"RTN","DGMSTAPI",252,0)
+ .. S VALID=$$TESTVAL(DGFILE,DGFLD,DGVAL)
+"RTN","DGMSTAPI",253,0)
+ .. D:'VALID MSG(DGFILE,DGFLD,DGMSG,.DGERR)
+"RTN","DGMSTAPI",254,0)
+ Q VALID
+"RTN","DGMSTAPI",255,0)
+ ;
+"RTN","DGMSTAPI",256,0)
+MSG(DGFIL,DGFLD,DGMSG,DGERR) ; error message setup
+"RTN","DGMSTAPI",257,0)
+ ; Input:
+"RTN","DGMSTAPI",258,0)
+ ;   DGFIL - file number
+"RTN","DGMSTAPI",259,0)
+ ;   DGFLD - field number of file
+"RTN","DGMSTAPI",260,0)
+ ;   DGMSG - message type verbiage - " IS REQUIRED" or " IS NOT VALID"
+"RTN","DGMSTAPI",261,0)
+ ;   DGERR - error parameter passed by reference
+"RTN","DGMSTAPI",262,0)
+ ; Output:
+"RTN","DGMSTAPI",263,0)
+ ;   DGERR - error message
+"RTN","DGMSTAPI",264,0)
+ S DGERR=$$GET1^DID(DGFIL,DGFLD,,"LABEL")_DGMSG
+"RTN","DGMSTAPI",265,0)
+ Q
+"RTN","DGMSTAPI",266,0)
+ ;
+"RTN","DGMSTAPI",267,0)
+TESTVAL(DGFIL,DGFLD,DGVAL) ; Determine if a field value is valid.
+"RTN","DGMSTAPI",268,0)
+ ; Input:
+"RTN","DGMSTAPI",269,0)
+ ;   DGFIL - file number
+"RTN","DGMSTAPI",270,0)
+ ;   DGFLD - field number of file
+"RTN","DGMSTAPI",271,0)
+ ;   DGVAL - field value to be validated
+"RTN","DGMSTAPI",272,0)
+ ; Output:
+"RTN","DGMSTAPI",273,0)
+ ;   Function value: Returns 1 if field is valid
+"RTN","DGMSTAPI",274,0)
+ ;                           0 if validation fails
+"RTN","DGMSTAPI",275,0)
+ N DGVALEX,DGRSLT,VALID
+"RTN","DGMSTAPI",276,0)
+ S VALID=1
+"RTN","DGMSTAPI",277,0)
+ I DGVAL'="" D
+"RTN","DGMSTAPI",278,0)
+ . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
+"RTN","DGMSTAPI",279,0)
+ . I DGVALEX="" S VALID=0 Q   ; no external value, not valid
+"RTN","DGMSTAPI",280,0)
+ . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'="POINTER" D
+"RTN","DGMSTAPI",281,0)
+ .. D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0
+"RTN","DGMSTAPI",282,0)
+ Q VALID
+"RTN","GMRCA2")
+0^35^B10634
+"RTN","GMRCA2",1,0)
+GMRCA2 ;SLC/KCM,DLT,MSC/JDA - Select prompt for processing actions ;27APR2009
+"RTN","GMRCA2",2,0)
+ ;;3.0;CONSULT/REQUEST TRACKING;**1,4,MSC**;DEC 27, 1997
+"RTN","GMRCA2",3,0)
+SELECT(GMRCO) ; Select the consult to process
+"RTN","GMRCA2",4,0)
+ ;This utility checks the GMRCO variable against the selection list
+"RTN","GMRCA2",5,0)
+ ;  Input variable used:
+"RTN","GMRCA2",6,0)
+ ;          BLK, LNCT, GMRCO
+"RTN","GMRCA2",7,0)
+ ;          GMRC("NMBR")
+"RTN","GMRCA2",8,0)
+ ;  Output variables returned:
+"RTN","GMRCA2",9,0)
+ ;          GMRCQUT=1 if no consult was selected
+"RTN","GMRCA2",10,0)
+ ;          GMRCQUT is not defined on return when selection made
+"RTN","GMRCA2",11,0)
+ ;          GMRCO=    consult selected from list
+"RTN","GMRCA2",12,0)
+START
+"RTN","GMRCA2",13,0)
+ K GMRCQUT,GMRCSEL
+"RTN","GMRCA2",14,0)
+ N GMRCAGN
+"RTN","GMRCA2",15,0)
+ I '$L($G(GMRCO)) D  Q:$D(GMRCQUT)  G:$D(GMRCAGN) START
+"RTN","GMRCA2",16,0)
+ .;use the highlighted number if defined
+"RTN","GMRCA2",17,0)
+ .I $D(GMRC("NMBR")) S GMRCSEL=GMRC("NMBR")
+"RTN","GMRCA2",18,0)
+ .I '$D(GMRCSEL),$D(LNCT),LNCT=1 S GMRCSEL=LNCT
+"RTN","GMRCA2",19,0)
+ .I $S('+$G(GMRCSEL):1,+GMRCSEL<1:1,+GMRCSEL>BLK:1,GMRCSEL="":1,1:0) K GMRCSEL D:+$G(GMRC("NMBR")) AGAIN^GMRCSLMV(GMRC("NMBR")) K GMRC("NMBR")
+"RTN","GMRCA2",20,0)
+ .I '+$G(GMRCSEL) D SEL I $S($D(DTOUT):1,$D(DIROUT):1,$D(GMRCQUT):1,'+GMRCSEL:1,1:0) K GMRCSEL S GMRCQUT=1 Q
+"RTN","GMRCA2",21,0)
+ .I $S(+GMRCSEL<1:1,GMRCSEL>BLK:1,1:0) W !,"Select a consult listed in the number range 1 to "_BLK S GMRCAGN=1 Q
+"RTN","GMRCA2",22,0)
+ .S GMRCO=$O(^TMP("GMRCR",$J,"CS","AD",GMRCSEL,GMRCSEL,0))
+"RTN","GMRCA2",23,0)
+ .I '+GMRCO D
+"RTN","GMRCA2",24,0)
+ .. S GMRCQUT=1
+"RTN","GMRCA2",25,0)
+ .. W !,$C(7),"Select a consult by entering its listed number between 1 and "_LNCT_"."
+"RTN","GMRCA2",26,0)
+ .. K GMRCO,GMRCSEL
+"RTN","GMRCA2",27,0)
+ . Q
+"RTN","GMRCA2",28,0)
+ Q
+"RTN","GMRCA2",29,0)
+ ;
+"RTN","GMRCA2",30,0)
+SEL ;Select order number(s)   exit: GMRCSEL
+"RTN","GMRCA2",31,0)
+ I $D(GMRC("NMBR")) S GMRCSEL=GMRC("NMBR") Q
+"RTN","GMRCA2",32,0)
+ I '$D(^TMP("GMRCR",$J,"CS","AD")) W !,"No orders to select.",! S GMRCQUT=1,GMRCSEL="" Q
+"RTN","GMRCA2",33,0)
+ I '$O(^TMP("GMRCR",$J,"CS","AD")),BLK=1 S GMRCSEL=BLK Q
+"RTN","GMRCA2",34,0)
+ S GMRCSEL="" W !,"CHOOSE No. 1-",BLK,": " R X:DTIME S:X="^^" DIROUT=1 I '$T!(X["^") S (DTOUT,GMRCQUT)=1 Q
+"RTN","GMRCA2",35,0)
+ I X["?" D SELHELP G SEL
+"RTN","GMRCA2",36,0)
+ I X="" S GMRCQUT=1 Q
+"RTN","GMRCA2",37,0)
+ I X'?.3N W $C(7)," ??  Enter the number from the far left of the list." G SEL
+"RTN","GMRCA2",38,0)
+ I $S(X>BLK:1,X<1:1,1:0) D SELHELP G SEL
+"RTN","GMRCA2",39,0)
+ S GMRCSEL=X
+"RTN","GMRCA2",40,0)
+ Q
+"RTN","GMRCA2",41,0)
+SELHELP ;Help to select a valid entry
+"RTN","GMRCA2",42,0)
+ W !,"Select a request by typing the number from the left column and pressing <ENTER>.",!
+"RTN","GMRCA2",43,0)
+ Q
+"RTN","GMRCA2",44,0)
+UP ;Convert lower to upper case   entry: X   exit: X
+"RTN","GMRCA2",45,0)
+ F %=1:1:$L(X) I $E(X,%)?1L S X=$E(X,1,%-1)_$C($A(X,%)-32)_$E(X,%+1,99)
+"RTN","GMRCA2",46,0)
+ Q
+"RTN","HLCSLNCH")
+0^18^B37119958
+"RTN","HLCSLNCH",1,0)
+HLCSLNCH ;ALB/MTC/JC MSC/JDA - START AND STOP THE LLP ;31JUL2009
+"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)
+ S $ETRAP=""
+"RTN","HLCSLNCH",116,0)
+ I ($P(HLPARM4,U,3)="M"&'$$NOTMULTI())!($P(HLPARM4,U,3)="S") D
+"RTN","HLCSLNCH",117,0)
+ . ;pass task number to stop listener
+"RTN","HLCSLNCH",118,0)
+ . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
+"RTN","HLCSLNCH",119,0)
+ . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+"RTN","HLCSLNCH",120,0)
+ . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
+"RTN","HLCSLNCH",121,0)
+ . U IO W "**STOP**"
+"RTN","HLCSLNCH",122,0)
+ . W !
+"RTN","HLCSLNCH",123,0)
+ . D CLOSE^%ZISTCP
+"RTN","HLCSLNCH",124,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSLNCH",125,0)
+ W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
+"RTN","HLCSLNCH",126,0)
+ Q
+"RTN","HLCSLNCH",127,0)
+ ;
+"RTN","HLCSLNCH",128,0)
+NOTMULTI() ; Returns 1 if implementation can't run multithreaded listener
+"RTN","HLCSLNCH",129,0)
+ Q:^%ZOSF("OS")["GT.M" 0
+"RTN","HLCSLNCH",130,0)
+ Q $S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS")
+"RTN","HLCSLNCH",131,0)
+STOPQ Q
+"RTN","HLCSTCP")
+0^17^B32647785
+"RTN","HLCSTCP",1,0)
+HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE MSC/JDS - (TCP/IP) MLLP ;25NOV2009
+"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 $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
+"RTN","HLCSTCP",30,0)
+ . I HLCSFAIL D EXITS("Openfail") Q
+"RTN","HLCSTCP",31,0)
+ ;
+"RTN","HLCSTCP",32,0)
+ ;multi-threaded listener (OpenM or GT.M)
+"RTN","HLCSTCP",33,0)
+ I $G(HLTCPCS)="M",(^%ZOSF("OS")["OpenM")!(^%ZOSF("OS")["GT.M") D  Q
+"RTN","HLCSTCP",34,0)
+ . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")")
+"RTN","HLCSTCP",35,0)
+ Q
+"RTN","HLCSTCP",36,0)
+ ;
+"RTN","HLCSTCP",37,0)
+SERVER(HLDP) ; single server using Taskman
+"RTN","HLCSTCP",38,0)
+ S HLCSFAIL=0
+"RTN","HLCSTCP",39,0)
+ I '$$INIT D EXITS("Init error") Q
+"RTN","HLCSTCP",40,0)
+ D ^HLCSTCP1
+"RTN","HLCSTCP",41,0)
+ I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
+"RTN","HLCSTCP",42,0)
+ Q:$G(HLCSOUT)=1
+"RTN","HLCSTCP",43,0)
+ D MON("Idle")
+"RTN","HLCSTCP",44,0)
+ Q
+"RTN","HLCSTCP",45,0)
+ ;
+"RTN","HLCSTCP",46,0)
+SERVERS(HLDP) ; Multi-threaded server using Taskman
+"RTN","HLCSTCP",47,0)
+ I '$$INIT D EXITS("Init error") Q
+"RTN","HLCSTCP",48,0)
+ G LISTEN
+"RTN","HLCSTCP",49,0)
+ ;
+"RTN","HLCSTCP",50,0)
+ ;multiple process servers, called from an external utility
+"RTN","HLCSTCP",51,0)
+MSM ;MSM entry point, called from User-Defined Services
+"RTN","HLCSTCP",52,0)
+ ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
+"RTN","HLCSTCP",53,0)
+ ;HL7 Multi-Threaded SERVER
+"RTN","HLCSTCP",54,0)
+ S (IO,IO(0))=$P
+"RTN","HLCSTCP",55,0)
+ G LISTEN
+"RTN","HLCSTCP",56,0)
+ ;
+"RTN","HLCSTCP",57,0)
+CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
+"RTN","HLCSTCP",58,0)
+ ;listener,  % = HLDP
+"RTN","HLCSTCP",59,0)
+ I $G(%)="" D ^%ZTER Q
+"RTN","HLCSTCP",60,0)
+ S (IO,IO(0))="SYS$NET",HLDP=%
+"RTN","HLCSTCP",61,0)
+ ; **Cache'/VMS specific code**
+"RTN","HLCSTCP",62,0)
+ O IO::5 E  D MON("Openfail") Q
+"RTN","HLCSTCP",63,0)
+ X "U IO:(::""-M"")" ;Packet mode like DSM
+"RTN","HLCSTCP",64,0)
+ D LISTEN C IO Q
+"RTN","HLCSTCP",65,0)
+ ;
+"RTN","HLCSTCP",66,0)
+EN ;vms ucx entry point, called from HLSEVEN.COM file,
+"RTN","HLCSTCP",67,0)
+ ;listener,  % = device^HLDP
+"RTN","HLCSTCP",68,0)
+ I $G(%)="" D ^%ZTER Q
+"RTN","HLCSTCP",69,0)
+ S (IO,IO(0))="SYS$NET",HLDP=$P(%,"^",2)
+"RTN","HLCSTCP",70,0)
+ ; **VMS specific code, need to share device**
+"RTN","HLCSTCP",71,0)
+ X "O IO:(TCPDEV):60" E  D MON("Openfail") Q
+"RTN","HLCSTCP",72,0)
+LISTEN ;
+"RTN","HLCSTCP",73,0)
+ N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+"RTN","HLCSTCP",74,0)
+ I '$$INIT D ^%ZTER Q
+"RTN","HLCSTCP",75,0)
+ ; identify process for ^%SY
+"RTN","HLCSTCP",76,0)
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+"RTN","HLCSTCP",77,0)
+ ;HLLSTN used to identify a listener to tag MON
+"RTN","HLCSTCP",78,0)
+ S HLLSTN=1
+"RTN","HLCSTCP",79,0)
+ ;increment job count, run server
+"RTN","HLCSTCP",80,0)
+ D UPDT(1),^HLCSTCP1,EXITM
+"RTN","HLCSTCP",81,0)
+ Q
+"RTN","HLCSTCP",82,0)
+ ;
+"RTN","HLCSTCP",83,0)
+DCOPEN(HLDP) ;open direct connect - called from HLMA2
+"RTN","HLCSTCP",84,0)
+ Q:'$$INIT 0
+"RTN","HLCSTCP",85,0)
+ Q:HLTCPADD=""!(HLTCPORT="") 0
+"RTN","HLCSTCP",86,0)
+ Q:'$$OPEN^HLCSTCP2 0
+"RTN","HLCSTCP",87,0)
+ Q 1
+"RTN","HLCSTCP",88,0)
+ ;
+"RTN","HLCSTCP",89,0)
+INIT() ; Initialize Variables
+"RTN","HLCSTCP",90,0)
+ ; HLDP should be set to the IEN or name of Logical Link, file 870
+"RTN","HLCSTCP",91,0)
+ S HLOS=$P($G(^%ZOSF("OS")),"^")
+"RTN","HLCSTCP",92,0)
+ N DA,DIQUIET,DR,TMP,X,Y
+"RTN","HLCSTCP",93,0)
+ S DIQUIET=1
+"RTN","HLCSTCP",94,0)
+ D DT^DICRW
+"RTN","HLCSTCP",95,0)
+ I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
+"RTN","HLCSTCP",96,0)
+ S DA=HLDP
+"RTN","HLCSTCP",97,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",98,0)
+ D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
+"RTN","HLCSTCP",99,0)
+ ;
+"RTN","HLCSTCP",100,0)
+ I $D(TMP("DIERR")) QUIT 0
+"RTN","HLCSTCP",101,0)
+ ; -- re-transmit attempts
+"RTN","HLCSTCP",102,0)
+ S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
+"RTN","HLCSTCP",103,0)
+ ; -- exceed re-transmit action
+"RTN","HLCSTCP",104,0)
+ S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
+"RTN","HLCSTCP",105,0)
+ ; -- block size
+"RTN","HLCSTCP",106,0)
+ S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
+"RTN","HLCSTCP",107,0)
+ ; -- read timeout
+"RTN","HLCSTCP",108,0)
+ S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
+"RTN","HLCSTCP",109,0)
+ ; -- ack timeout
+"RTN","HLCSTCP",110,0)
+ S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
+"RTN","HLCSTCP",111,0)
+ ; -- uni-directional wait
+"RTN","HLCSTCP",112,0)
+ S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
+"RTN","HLCSTCP",113,0)
+ ; -- tcp address
+"RTN","HLCSTCP",114,0)
+ S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
+"RTN","HLCSTCP",115,0)
+ ; -- tcp port
+"RTN","HLCSTCP",116,0)
+ S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
+"RTN","HLCSTCP",117,0)
+ ; -- tcp/ip service type
+"RTN","HLCSTCP",118,0)
+ S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
+"RTN","HLCSTCP",119,0)
+ ; -- link persistence
+"RTN","HLCSTCP",120,0)
+ S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
+"RTN","HLCSTCP",121,0)
+ ; -- retention
+"RTN","HLCSTCP",122,0)
+ S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
+"RTN","HLCSTCP",123,0)
+ ;
+"RTN","HLCSTCP",124,0)
+ ; -- set defaults in case something's not set
+"RTN","HLCSTCP",125,0)
+ S:HLDREAD=0 HLDREAD=10
+"RTN","HLCSTCP",126,0)
+ S:HLDBACK=0 HLDBACK=60
+"RTN","HLCSTCP",127,0)
+ S:HLDBSIZE=0 HLDBSIZE=245
+"RTN","HLCSTCP",128,0)
+ S:HLDRETR=0 HLDRETR=5
+"RTN","HLCSTCP",129,0)
+ S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
+"RTN","HLCSTCP",130,0)
+ ;
+"RTN","HLCSTCP",131,0)
+ Q 1
+"RTN","HLCSTCP",132,0)
+ ;
+"RTN","HLCSTCP",133,0)
+ST1 ;record startup in 870 for single server
+"RTN","HLCSTCP",134,0)
+ ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
+"RTN","HLCSTCP",135,0)
+ ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
+"RTN","HLCSTCP",136,0)
+ N HLJ,X
+"RTN","HLCSTCP",137,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",138,0)
+ S X="HLJ(870,"""_HLDP_","")"
+"RTN","HLCSTCP",139,0)
+ S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
+"RTN","HLCSTCP",140,0)
+ I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
+"RTN","HLCSTCP",141,0)
+ E  S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
+"RTN","HLCSTCP",142,0)
+ I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
+"RTN","HLCSTCP",143,0)
+ S:$G(ZTSK) @X@(11)=ZTSK
+"RTN","HLCSTCP",144,0)
+ D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",145,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",146,0)
+ Q
+"RTN","HLCSTCP",147,0)
+ ;
+"RTN","HLCSTCP",148,0)
+MON(Y) ;Display current state & check for shutdown
+"RTN","HLCSTCP",149,0)
+ ;don't display for multiple server
+"RTN","HLCSTCP",150,0)
+ Q:$G(HLLSTN)
+"RTN","HLCSTCP",151,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",152,0)
+ S $P(^HLCS(870,HLDP,0),U,5)=Y
+"RTN","HLCSTCP",153,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",154,0)
+ Q:'$D(HLTRACE)
+"RTN","HLCSTCP",155,0)
+ N X U IO(0)
+"RTN","HLCSTCP",156,0)
+ W !,"IN State: ",Y
+"RTN","HLCSTCP",157,0)
+ I '$$STOP D
+"RTN","HLCSTCP",158,0)
+ . R !,"Type Q to Quit: ",X#1:1
+"RTN","HLCSTCP",159,0)
+ . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
+"RTN","HLCSTCP",160,0)
+ U IO
+"RTN","HLCSTCP",161,0)
+ Q
+"RTN","HLCSTCP",162,0)
+UPDT(Y) ;update job count for multiple servers,X=1 increment
+"RTN","HLCSTCP",163,0)
+ N HLJ,X
+"RTN","HLCSTCP",164,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",165,0)
+ S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
+"RTN","HLCSTCP",166,0)
+ ;if incrementing, set the Device Type field to Multi-Server
+"RTN","HLCSTCP",167,0)
+ I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",168,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",169,0)
+ Q
+"RTN","HLCSTCP",170,0)
+STOP() ;stop flag set
+"RTN","HLCSTCP",171,0)
+ N X
+"RTN","HLCSTCP",172,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",173,0)
+ S X=+$P(^HLCS(870,HLDP,0),U,15)
+"RTN","HLCSTCP",174,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",175,0)
+ Q X
+"RTN","HLCSTCP",176,0)
+ ;
+"RTN","HLCSTCP",177,0)
+LLCNT(DP,Y,Z) ;update Logical Link counters
+"RTN","HLCSTCP",178,0)
+ ;DP=ien of Logical Link in file 870
+"RTN","HLCSTCP",179,0)
+ ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
+"RTN","HLCSTCP",180,0)
+ ;Z: ""=add to counter, 1=subtract from counter
+"RTN","HLCSTCP",181,0)
+ Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
+"RTN","HLCSTCP",182,0)
+ N P,X
+"RTN","HLCSTCP",183,0)
+ S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
+"RTN","HLCSTCP",184,0)
+ F  L +^HLCS(870,DP,P):2 Q:$T
+"RTN","HLCSTCP",185,0)
+ S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+"RTN","HLCSTCP",186,0)
+ L -^HLCS(870,DP,P)
+"RTN","HLCSTCP",187,0)
+ Q
+"RTN","HLCSTCP",188,0)
+SDFLD ; set Shutdown? field to yes
+"RTN","HLCSTCP",189,0)
+ Q:'$G(HLDP)
+"RTN","HLCSTCP",190,0)
+ N HLJ,X
+"RTN","HLCSTCP",191,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",192,0)
+ ;14=Shutdown LLP?
+"RTN","HLCSTCP",193,0)
+ S HLJ(870,HLDP_",",14)=1
+"RTN","HLCSTCP",194,0)
+ D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",195,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",196,0)
+ Q
+"RTN","HLCSTCP",197,0)
+ ;
+"RTN","HLCSTCP",198,0)
+EXITS(Y) ; Single service shutdown and cleans up
+"RTN","HLCSTCP",199,0)
+ N HLJ,X
+"RTN","HLCSTCP",200,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",201,0)
+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number
+"RTN","HLCSTCP",202,0)
+ S X="HLJ(870,"""_HLDP_","")"
+"RTN","HLCSTCP",203,0)
+ S @X@(4)=Y,@X@(11)="@"
+"RTN","HLCSTCP",204,0)
+ S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
+"RTN","HLCSTCP",205,0)
+ D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
+"RTN","HLCSTCP",206,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",207,0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+"RTN","HLCSTCP",208,0)
+ Q
+"RTN","HLCSTCP",209,0)
+ ;
+"RTN","HLCSTCP",210,0)
+EXITM ;Multiple service shutdown and clean up
+"RTN","HLCSTCP",211,0)
+ D UPDT(0)
+"RTN","HLCSTCP",212,0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+"RTN","HLCSTCP",213,0)
+ Q
+"RTN","HLCSTCP1")
+0^16^B33066751
+"RTN","HLCSTCP1",1,0)
+HLCSTCP1 ;SFIRMFO/RSD MSC/JDA,JKT - BI-DIRECTIONAL TCP ;25FEB2010
+"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)
+ I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP1"")" ;turn on error trapping on GT.M
+"RTN","HLCSTCP1",9,0)
+ N HLMIEN,HLASTMSG
+"RTN","HLCSTCP1",10,0)
+ D MON^HLCSTCP("Open")
+"RTN","HLCSTCP1",11,0)
+ K ^TMP("HLCSTCP",$J,0)
+"RTN","HLCSTCP1",12,0)
+ S HLMIEN=0,HLASTMSG=""
+"RTN","HLCSTCP1",13,0)
+ F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3
+"RTN","HLCSTCP1",14,0)
+ . S HLMIEN=$$READ
+"RTN","HLCSTCP1",15,0)
+ . Q:'HLMIEN
+"RTN","HLCSTCP1",16,0)
+ . D PROCESS
+"RTN","HLCSTCP1",17,0)
+ Q
+"RTN","HLCSTCP1",18,0)
+ ;
+"RTN","HLCSTCP1",19,0)
+PROCESS ;check message and reply
+"RTN","HLCSTCP1",20,0)
+ ;HLDP=LL in 870, update monitor, received msg.
+"RTN","HLCSTCP1",21,0)
+ N HLTCP,HLTCPI,HLTCPO
+"RTN","HLCSTCP1",22,0)
+ S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
+"RTN","HLCSTCP1",23,0)
+ ;update monitor, msg. received
+"RTN","HLCSTCP1",24,0)
+ D LLCNT^HLCSTCP(HLDP,1)
+"RTN","HLCSTCP1",25,0)
+ D NEW^HLTP3(HLMIEN)
+"RTN","HLCSTCP1",26,0)
+ ;update monitor, msg. processed
+"RTN","HLCSTCP1",27,0)
+ D LLCNT^HLCSTCP(HLDP,2)
+"RTN","HLCSTCP1",28,0)
+ Q
+"RTN","HLCSTCP1",29,0)
+ ;
+"RTN","HLCSTCP1",30,0)
+READ() ;read 1 message, returns ien in 773^ien in 772 for message
+"RTN","HLCSTCP1",31,0)
+ D MON^HLCSTCP("Reading")
+"RTN","HLCSTCP1",32,0)
+ N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
+"RTN","HLCSTCP1",33,0)
+ ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator
+"RTN","HLCSTCP1",34,0)
+ S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
+"RTN","HLCSTCP1",35,0)
+ ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
+"RTN","HLCSTCP1",36,0)
+ ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack
+"RTN","HLCSTCP1",37,0)
+ S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
+"RTN","HLCSTCP1",38,0)
+ K ^TMP("HLCSTCP",$J,0)
+"RTN","HLCSTCP1",39,0)
+ F  D RDBLK Q:HLRDOUT
+"RTN","HLCSTCP1",40,0)
+ ;save any excess for next time
+"RTN","HLCSTCP1",41,0)
+ S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX
+"RTN","HLCSTCP1",42,0)
+ I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
+"RTN","HLCSTCP1",43,0)
+ Q HLIND1
+"RTN","HLCSTCP1",44,0)
+ ;
+"RTN","HLCSTCP1",45,0)
+RDBLK S HLDB=HLDBSIZE-$L(HLX)
+"RTN","HLCSTCP1",46,0)
+ U IO
+"RTN","HLCSTCP1",47,0)
+ ; set DELIMITER flag on GT.M to ensure we return from READ command as soon as we get a complete HL7 message
+"RTN","HLCSTCP1",48,0)
+ I HLOS["GT.M" X "U IO:(DELIMITER=HLRS_HLDEND_HLRS)"
+"RTN","HLCSTCP1",49,0)
+ N T R X#HLDB:HLDREAD S T=$T ;save $TEST for check below
+"RTN","HLCSTCP1",50,0)
+ ; $KEY=delimiter if READ terminated on delimiter; remove DELIMITER flag after READ so we don't affect writes
+"RTN","HLCSTCP1",51,0)
+ I HLOS["GT.M" X "S X=X_$KEY U IO:(NODELIMITER)"
+"RTN","HLCSTCP1",52,0)
+ ; timedout or error, check ack timeout, clean up
+"RTN","HLCSTCP1",53,0)
+ I 'T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
+"RTN","HLCSTCP1",54,0)
+ ;data stream: <sb>dddd<cr><eb><cr>
+"RTN","HLCSTCP1",55,0)
+ ;add incoming line to what wasn't processed in last read
+"RTN","HLCSTCP1",56,0)
+ S HLX=$G(HLX)_X
+"RTN","HLCSTCP1",57,0)
+ ; look for segment= <CR>
+"RTN","HLCSTCP1",58,0)
+ F  Q:HLX'[HLRS  D  Q:HLRDOUT
+"RTN","HLCSTCP1",59,0)
+ . ; Get the first piece, save the rest of the line
+"RTN","HLCSTCP1",60,0)
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
+"RTN","HLCSTCP1",61,0)
+ . ; check for start block, Quit if no ien
+"RTN","HLCSTCP1",62,0)
+ . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D  Q
+"RTN","HLCSTCP1",63,0)
+ .. D:HLMSG(HLINE,0)[HLDSTRT
+"RTN","HLCSTCP1",64,0)
+ ... S X=$L(HLMSG(HLINE,0),HLDSTRT)
+"RTN","HLCSTCP1",65,0)
+ ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
+"RTN","HLCSTCP1",66,0)
+ ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
+"RTN","HLCSTCP1",67,0)
+ ... D RESET:(HLINE>1)
+"RTN","HLCSTCP1",68,0)
+ .. ;ping message
+"RTN","HLCSTCP1",69,0)
+ .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
+"RTN","HLCSTCP1",70,0)
+ .. ; get next ien to store
+"RTN","HLCSTCP1",71,0)
+ .. D MIEN
+"RTN","HLCSTCP1",72,0)
+ .. K HLMSG
+"RTN","HLCSTCP1",73,0)
+ .. S (HLINE,HLHDR)=0
+"RTN","HLCSTCP1",74,0)
+ . ; check for end block; HLMSG(HLINE) = <eb><cr>
+"RTN","HLCSTCP1",75,0)
+ . I HLMSG(HLINE,0)[HLDEND D
+"RTN","HLCSTCP1",76,0)
+ .. ;no msg. ien
+"RTN","HLCSTCP1",77,0)
+ .. Q:'HLIND1
+"RTN","HLCSTCP1",78,0)
+ .. ; Kill just the last line
+"RTN","HLCSTCP1",79,0)
+ .. K HLMSG(HLINE,0) S HLINE=HLINE-1
+"RTN","HLCSTCP1",80,0)
+ .. ; move into 772
+"RTN","HLCSTCP1",81,0)
+ .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
+"RTN","HLCSTCP1",82,0)
+ .. ;mark that end block has been received
+"RTN","HLCSTCP1",83,0)
+ .. ;HLIND1=ien in 773^ien in 772^1 if end block was received
+"RTN","HLCSTCP1",84,0)
+ .. S $P(HLIND1,U,3)=1
+"RTN","HLCSTCP1",85,0)
+ .. ;reset variables for next message
+"RTN","HLCSTCP1",86,0)
+ .. D CLEAN
+"RTN","HLCSTCP1",87,0)
+ . ;add blank line for carriage return
+"RTN","HLCSTCP1",88,0)
+ . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
+"RTN","HLCSTCP1",89,0)
+ Q:HLRDOUT
+"RTN","HLCSTCP1",90,0)
+ ;If the line is long and no <CR> move it into the array. 
+"RTN","HLCSTCP1",91,0)
+ I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D  Q
+"RTN","HLCSTCP1",92,0)
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
+"RTN","HLCSTCP1",93,0)
+ ;have start block but no record seperator
+"RTN","HLCSTCP1",94,0)
+ I HLX[HLDSTRT D  Q
+"RTN","HLCSTCP1",95,0)
+ . ;check for more than 1 start block
+"RTN","HLCSTCP1",96,0)
+ . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
+"RTN","HLCSTCP1",97,0)
+ . S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
+"RTN","HLCSTCP1",98,0)
+ . D RESET:(HLHDR&(HLINE>1))
+"RTN","HLCSTCP1",99,0)
+ ;if no ien, then we don't have start block, reset
+"RTN","HLCSTCP1",100,0)
+ I 'HLIND1 D CLEAN Q
+"RTN","HLCSTCP1",101,0)
+ ; big message-merge from local to global every 100 lines
+"RTN","HLCSTCP1",102,0)
+ I (HLINE-$O(HLMSG(0)))>100 D
+"RTN","HLCSTCP1",103,0)
+ . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
+"RTN","HLCSTCP1",104,0)
+ . ; reset working array
+"RTN","HLCSTCP1",105,0)
+ . K HLMSG
+"RTN","HLCSTCP1",106,0)
+ Q
+"RTN","HLCSTCP1",107,0)
+ ;
+"RTN","HLCSTCP1",108,0)
+SAVE(SRC,DEST) ;save into global & set top node
+"RTN","HLCSTCP1",109,0)
+ ;SRC=source array (passed by ref.), DEST=destination global
+"RTN","HLCSTCP1",110,0)
+ M @DEST=SRC
+"RTN","HLCSTCP1",111,0)
+ S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
+"RTN","HLCSTCP1",112,0)
+ Q
+"RTN","HLCSTCP1",113,0)
+ ;
+"RTN","HLCSTCP1",114,0)
+DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
+"RTN","HLCSTCP1",115,0)
+ N DIK,DA
+"RTN","HLCSTCP1",116,0)
+ S DA=+HLMAMT,DIK="^HLMA("
+"RTN","HLCSTCP1",117,0)
+ D ^DIK
+"RTN","HLCSTCP1",118,0)
+ S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
+"RTN","HLCSTCP1",119,0)
+ D ^DIK
+"RTN","HLCSTCP1",120,0)
+ Q
+"RTN","HLCSTCP1",121,0)
+MIEN ; sets HLIND1=ien in 773^ien in 772 for message
+"RTN","HLCSTCP1",122,0)
+ N HLMID,X
+"RTN","HLCSTCP1",123,0)
+ I HLIND1 D
+"RTN","HLCSTCP1",124,0)
+ . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
+"RTN","HLCSTCP1",125,0)
+ . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
+"RTN","HLCSTCP1",126,0)
+ ;msg. id is 10th of MSH & 11th for BSH or FSH
+"RTN","HLCSTCP1",127,0)
+ S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
+"RTN","HLCSTCP1",128,0)
+ ;if HLIND1 is set, kill old message, use HLIND1 for new
+"RTN","HLCSTCP1",129,0)
+ ;message, it means we never got end block for 1st msg.
+"RTN","HLCSTCP1",130,0)
+ I HLIND1 D  Q
+"RTN","HLCSTCP1",131,0)
+ . ;get pointer to 772, kill header
+"RTN","HLCSTCP1",132,0)
+ . K ^HLMA(+HLIND1,"MSH")
+"RTN","HLCSTCP1",133,0)
+ . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
+"RTN","HLCSTCP1",134,0)
+ . S X=$$MAID^HLTF(+HLIND1,HLMID)
+"RTN","HLCSTCP1",135,0)
+ . D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+"RTN","HLCSTCP1",136,0)
+ . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
+"RTN","HLCSTCP1",137,0)
+ D TCP^HLTF(.HLMID,.X,.HLDT)
+"RTN","HLCSTCP1",138,0)
+ I 'X D  Q
+"RTN","HLCSTCP1",139,0)
+ . ;error - record and reset array
+"RTN","HLCSTCP1",140,0)
+ . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
+"RTN","HLCSTCP1",141,0)
+ . D CLEAN K HLLSTN
+"RTN","HLCSTCP1",142,0)
+ . ;error 100=LLP Could not Enqueue the Message, reset array
+"RTN","HLCSTCP1",143,0)
+ . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
+"RTN","HLCSTCP1",144,0)
+ ;HLIND1=ien in 773^ien in 772
+"RTN","HLCSTCP1",145,0)
+ S HLIND1=X_U_+$G(^HLMA(X,0))
+"RTN","HLCSTCP1",146,0)
+ ;save MSH into 773
+"RTN","HLCSTCP1",147,0)
+ D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+"RTN","HLCSTCP1",148,0)
+ Q
+"RTN","HLCSTCP1",149,0)
+ ;
+"RTN","HLCSTCP1",150,0)
+PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
+"RTN","HLCSTCP1",151,0)
+ N FS,I,L,L1,L2,X,Y
+"RTN","HLCSTCP1",152,0)
+ S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
+"RTN","HLCSTCP1",153,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",154,0)
+ . S:L1=1 L=L+1
+"RTN","HLCSTCP1",155,0)
+ . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
+"RTN","HLCSTCP1",156,0)
+ . S L2=Y,Y=L
+"RTN","HLCSTCP1",157,0)
+ Q X
+"RTN","HLCSTCP1",158,0)
+ ;
+"RTN","HLCSTCP1",159,0)
+PING ;process PING message
+"RTN","HLCSTCP1",160,0)
+ S X=HLMSG(1,0)
+"RTN","HLCSTCP1",161,0)
+ I X[HLDEND U IO W X,!
+"RTN","HLCSTCP1",162,0)
+CLEAN ;reset var. for next message
+"RTN","HLCSTCP1",163,0)
+ K HLMSG
+"RTN","HLCSTCP1",164,0)
+ S HLINE=0,HLRDOUT=1
+"RTN","HLCSTCP1",165,0)
+ Q
+"RTN","HLCSTCP1",166,0)
+ ;
+"RTN","HLCSTCP1",167,0)
+ERROR ; Error trap for disconnect error and return back to the read loop.
+"RTN","HLCSTCP1",168,0)
+ S $ETRAP="D UNWIND^%ZTER"
+"RTN","HLCSTCP1",169,0)
+ ; make sure GT.M-specific DELIMITER flag is removed, and turn off error trapping -- we're already handling the error
+"RTN","HLCSTCP1",170,0)
+ I HLOS["GT.M" X "U IO:(NODELIMITER:IOERROR="""":EXCEPT="""")"
+"RTN","HLCSTCP1",171,0)
+ I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN")!($$EC^%ZOSV["IOEOF") D UNWIND^%ZTER Q
+"RTN","HLCSTCP1",172,0)
+ I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
+"RTN","HLCSTCP1",173,0)
+ S HLCSOUT=1 D ^%ZTER,CC("Error")
+"RTN","HLCSTCP1",174,0)
+ D UNWIND^%ZTER
+"RTN","HLCSTCP1",175,0)
+ Q
+"RTN","HLCSTCP1",176,0)
+ ;
+"RTN","HLCSTCP1",177,0)
+CC(X) ;cleanup and close
+"RTN","HLCSTCP1",178,0)
+ D MON^HLCSTCP(X)
+"RTN","HLCSTCP1",179,0)
+ H 2
+"RTN","HLCSTCP1",180,0)
+ Q
+"RTN","HLCSTCP1",181,0)
+RESET ;reset info as a result of no end block
+"RTN","HLCSTCP1",182,0)
+ N %
+"RTN","HLCSTCP1",183,0)
+ S HLMSG(1,0)=HLMSG(HLINE,0)
+"RTN","HLCSTCP1",184,0)
+ F %=2:1:HLINE K HLMSG(%,0)
+"RTN","HLCSTCP1",185,0)
+ S HLINE=1
+"RTN","HLCSTCP1",186,0)
+ Q
+"RTN","HLCSTCP2")
+0^53^B62380874
+"RTN","HLCSTCP2",1,0)
+HLCSTCP2 ;SFIRMFO/RSD MSC/JKT - BI-DIRECTIONAL TCP ;02/25/2010  11:08
+"RTN","HLCSTCP2",2,0)
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,MSC**;Oct 13,1995
+"RTN","HLCSTCP2",3,0)
+ ;Sender
+"RTN","HLCSTCP2",4,0)
+ ;Request connection, send outbound message(s) delimited by MLLP
+"RTN","HLCSTCP2",5,0)
+ ;Input : HLDP=Logical Link to use
+"RTN","HLCSTCP2",6,0)
+ ; Set up error trap
+"RTN","HLCSTCP2",7,0)
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+"RTN","HLCSTCP2",8,0)
+ I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP2"")" ;turn on error trapping on GT.M
+"RTN","HLCSTCP2",9,0)
+ N HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP
+"RTN","HLCSTCP2",10,0)
+ ;HLRETRY=number of retranmission for this link,HLRETMG=alert sent
+"RTN","HLCSTCP2",11,0)
+ S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0
+"RTN","HLCSTCP2",12,0)
+ ;persistent conection, open connection first, HLPORT=open port
+"RTN","HLCSTCP2",13,0)
+ I $G(HLTCPLNK)["Y" F  Q:$$OPEN  G EXIT:$$STOP^HLCSTCP H 1
+"RTN","HLCSTCP2",14,0)
+ F  D QUE Q:$$STOP^HLCSTCP  D:'HLMSG  Q:$G(HLCSOUT)
+"RTN","HLCSTCP2",15,0)
+ . ;no messages to send
+"RTN","HLCSTCP2",16,0)
+ . D MON^HLCSTCP("Idle") H 3
+"RTN","HLCSTCP2",17,0)
+ . ;persistent connection, no retention
+"RTN","HLCSTCP2",18,0)
+ . Q:$G(HLTCPLNK)["Y"
+"RTN","HLCSTCP2",19,0)
+ . D MON^HLCSTCP("Retention")
+"RTN","HLCSTCP2",20,0)
+ . N % I 0
+"RTN","HLCSTCP2",21,0)
+ . ;if message comes in or ask to stop
+"RTN","HLCSTCP2",22,0)
+ . F %=1:1:HLTCPRET H 1 I $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0)) Q
+"RTN","HLCSTCP2",23,0)
+ . E  S HLCSOUT=2 Q
+"RTN","HLCSTCP2",24,0)
+ . Q:$$STOP^HLCSTCP
+"RTN","HLCSTCP2",25,0)
+ . D MON^HLCSTCP("Idle")
+"RTN","HLCSTCP2",26,0)
+ ;Close port
+"RTN","HLCSTCP2",27,0)
+ I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+"RTN","HLCSTCP2",28,0)
+EXIT Q
+"RTN","HLCSTCP2",29,0)
+ ;
+"RTN","HLCSTCP2",30,0)
+QUE ; -- Check "OUT" queue for processing IF there is a message do it
+"RTN","HLCSTCP2",31,0)
+ ; and then check the link if it open or not
+"RTN","HLCSTCP2",32,0)
+ N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
+"RTN","HLCSTCP2",33,0)
+ D MON^HLCSTCP("Check out")
+"RTN","HLCSTCP2",34,0)
+ ;HLMSG=next msg, set at tag DONE
+"RTN","HLCSTCP2",35,0)
+ I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG
+"RTN","HLCSTCP2",36,0)
+ ;
+"RTN","HLCSTCP2",37,0)
+ ;**109**
+"RTN","HLCSTCP2",38,0)
+ ;Temporarily lock ^HLMA to flush buffer and ensure edits are complete
+"RTN","HLCSTCP2",39,0)
+ ;L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q
+"RTN","HLCSTCP2",40,0)
+ ;L -^HLMA(HLMSG)
+"RTN","HLCSTCP2",41,0)
+ ;
+"RTN","HLCSTCP2",42,0)
+ S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP=""
+"RTN","HLCSTCP2",43,0)
+ ;don't have message text or MSH, kill x-ref and decrement 'to send'
+"RTN","HLCSTCP2",44,0)
+ I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+"RTN","HLCSTCP2",45,0)
+ ;update msg status to 'being transmitted'; if cancelled decrement link and quit
+"RTN","HLCSTCP2",46,0)
+ I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+"RTN","HLCSTCP2",47,0)
+ ;number of retransmissions for message
+"RTN","HLCSTCP2",48,0)
+ S HLRETRM=+$P(^HLMA(HLMSG,"P"),U,5)
+"RTN","HLCSTCP2",49,0)
+ ;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown
+"RTN","HLCSTCP2",50,0)
+ ;quit if restart or shutdown, link is going down
+"RTN","HLCSTCP2",51,0)
+ I HLRETRY>HLDRETR D  Q:"I"'[HLRETRA
+"RTN","HLCSTCP2",52,0)
+ . D MON^HLCSTCP("Error")
+"RTN","HLCSTCP2",53,0)
+ . ;only 1 alert per link up time, don't send if restart
+"RTN","HLCSTCP2",54,0)
+ . D:'HLRETMG&(HLRETRA'="R")
+"RTN","HLCSTCP2",55,0)
+ .. ;send alert
+"RTN","HLCSTCP2",56,0)
+ .. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+"RTN","HLCSTCP2",57,0)
+ .. ;get mailgroup from file 869.3
+"RTN","HLCSTCP2",58,0)
+ .. S HLRETMG=1,Z=$P($$PARAM^HLCS2,U,8) Q:Z=""
+"RTN","HLCSTCP2",59,0)
+ .. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" HL7 LL "_$P(^HLCS(870,HLDP,0),U)_" exceeded retries. LL will "_$S(HLRETRA="S":"shutdown.",HLRETRA="R":"restart.",1:"keep trying.")
+"RTN","HLCSTCP2",60,0)
+ .. D SETUP^XQALERT
+"RTN","HLCSTCP2",61,0)
+ . ;quit if action is ignore
+"RTN","HLCSTCP2",62,0)
+ . Q:"I"[HLRETRA
+"RTN","HLCSTCP2",63,0)
+ . ;this will shutdown this link
+"RTN","HLCSTCP2",64,0)
+ . S HLCSOUT=1
+"RTN","HLCSTCP2",65,0)
+ . ;action is shutdown, set shutdown flag so LM won't restart
+"RTN","HLCSTCP2",66,0)
+ . S:HLRETRA="S" $P(^HLCS(870,HLDP,0),U,15)=1
+"RTN","HLCSTCP2",67,0)
+ . D STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param")
+"RTN","HLCSTCP2",68,0)
+ I '$$OPEN Q
+"RTN","HLCSTCP2",69,0)
+ D MON^HLCSTCP("Send")
+"RTN","HLCSTCP2",70,0)
+ ; -- data passed in global array, success=1
+"RTN","HLCSTCP2",71,0)
+ I $$WRITE(HLMSG)<0 Q
+"RTN","HLCSTCP2",72,0)
+ S (HLTCP,HLTCPI)=HLMSG,HLRETRY=HLRETRY+1,HLRETRM=HLRETRM+1
+"RTN","HLCSTCP2",73,0)
+ ;update status to awaiting response, decrement link if cancelled
+"RTN","HLCSTCP2",74,0)
+ I '$$CHKMSG(1.7) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
+"RTN","HLCSTCP2",75,0)
+ ;set transmission count, get ACKTIMEOUT override
+"RTN","HLCSTCP2",76,0)
+ S $P(^HLMA(HLMSG,"P"),U,5)=HLRETRM I $P(^("P"),U,7) S HLN("ACKTIME")=+$P(^("P"),U,7)
+"RTN","HLCSTCP2",77,0)
+ ;get header of message just sent
+"RTN","HLCSTCP2",78,0)
+ K HLJ M HLJ=^HLMA(HLMSG,"MSH")
+"RTN","HLCSTCP2",79,0)
+ ;first component of sending app.
+"RTN","HLCSTCP2",80,0)
+ S HLN("ECH")=$$P^HLTPCK2(.HLJ,2),HLN("SAN")=$P($$P^HLTPCK2(.HLJ,3),$E(HLN("ECH")))
+"RTN","HLCSTCP2",81,0)
+ ;msg type, msg. id, commit ack, and app. ack parameter
+"RTN","HLCSTCP2",82,0)
+ S HLN("TYPE")=$$P^HLTPCK2(.HLJ,1),HLN("MID")=$$P^HLTPCK2(.HLJ,10),HLN("ACAT")=$$P^HLTPCK2(.HLJ,15),HLN("APAT")=$$P^HLTPCK2(.HLJ,16)
+"RTN","HLCSTCP2",83,0)
+ ;MSA segment, message is a response, can't have an a. ack.
+"RTN","HLCSTCP2",84,0)
+ S Z=$$MSA^HLTP3(+^HLMA(HLMSG,0)) I Z]"" S:HLN("ACAT")="" HLN("ACAT")="NE" S HLN("APAT")="NE"
+"RTN","HLCSTCP2",85,0)
+ ;for batch/file with commit ack, reset c. ack and a. ack variables
+"RTN","HLCSTCP2",86,0)
+ I "BHS,FHS"[HLN("TYPE") S Z=$E(HLJ(1,0),5),X=$$P^HLTPCK2(.HLJ,9),HLN("ACAT")=$P(X,Z,5),HLN("APAT")=$P(X,Z,6),HLN("MID")=$$P^HLTPCK2(.HLJ,11)
+"RTN","HLCSTCP2",87,0)
+ ;get event protocol
+"RTN","HLCSTCP2",88,0)
+ S HLN("EID")=+$P(^HLMA(HLMSG,0),U,8),X=$G(^ORD(101,HLN("EID"),770))
+"RTN","HLCSTCP2",89,0)
+ ;set link counter to msg sent
+"RTN","HLCSTCP2",90,0)
+ D LLCNT^HLCSTCP(HLDP,4)
+"RTN","HLCSTCP2",91,0)
+ ;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT
+"RTN","HLCSTCP2",92,0)
+ I HLN("ACAT")="NE",HLN("APAT")="NE" D  Q
+"RTN","HLCSTCP2",93,0)
+ .D DONE(3)
+"RTN","HLCSTCP2",94,0)
+ .;
+"RTN","HLCSTCP2",95,0)
+ .;
+"RTN","HLCSTCP2",96,0)
+ .H $G(HLDWAIT)
+"RTN","HLCSTCP2",97,0)
+ ;
+"RTN","HLCSTCP2",98,0)
+ ;do structure is to stack error
+"RTN","HLCSTCP2",99,0)
+ D
+"RTN","HLCSTCP2",100,0)
+ . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
+"RTN","HLCSTCP2",101,0)
+ . I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G RDERR^HLCSTCP2"")" ;change I/O error trap
+"RTN","HLCSTCP2",102,0)
+ . ;HL*1.6*87: Read acknowledgement.  
+"RTN","HLCSTCP2",103,0)
+ . ;Loop to re-read from buffer when receiving incorrect ack.
+"RTN","HLCSTCP2",104,0)
+ . F  D  Q:'+$G(HLREREAD)
+"RTN","HLCSTCP2",105,0)
+ .. S HLREREAD=1
+"RTN","HLCSTCP2",106,0)
+ .. ;override ack timeout
+"RTN","HLCSTCP2",107,0)
+ .. I $G(HLN("ACKTIME")) N HLDBACK S HLDBACK=HLN("ACKTIME")
+"RTN","HLCSTCP2",108,0)
+ .. ;check for response, quit if no-response, msg will be resent
+"RTN","HLCSTCP2",109,0)
+ .. ;HLRESP=ien 773^ien 772 for response message
+"RTN","HLCSTCP2",110,0)
+ .. S HLRESP=$$READ^HLCSTCP1()
+"RTN","HLCSTCP2",111,0)
+ .. ;if no response, decrement counter and quit
+"RTN","HLCSTCP2",112,0)
+ .. I 'HLRESP D LLCNT^HLCSTCP(HLDP,4,1) S HLREREAD="0^No Response" Q
+"RTN","HLCSTCP2",113,0)
+ .. ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error
+"RTN","HLCSTCP2",114,0)
+ .. S X=$$RSP^HLTP31(HLRESP,.HLN)
+"RTN","HLCSTCP2",115,0)
+ .. ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app)
+"RTN","HLCSTCP2",116,0)
+ .. Q:'X 
+"RTN","HLCSTCP2",117,0)
+ .. ;commit ack - done
+"RTN","HLCSTCP2",118,0)
+ .. I X=1 D  S HLREREAD="0^Commit Ack" Q
+"RTN","HLCSTCP2",119,0)
+ ... ;don't need app. ack, set status to complete
+"RTN","HLCSTCP2",120,0)
+ ... I "NE"[HLN("APAT") D  Q
+"RTN","HLCSTCP2",121,0)
+ ....D DONE(3)
+"RTN","HLCSTCP2",122,0)
+ ....;
+"RTN","HLCSTCP2",123,0)
+ ... ;response is deferred, set status to awaiting ack
+"RTN","HLCSTCP2",124,0)
+ ... D DONE(2)
+"RTN","HLCSTCP2",125,0)
+ ...;
+"RTN","HLCSTCP2",126,0)
+ .. ;Error, HLRESLT=error number^error message from HLTP3
+"RTN","HLCSTCP2",127,0)
+ .. I X=4 D  Q
+"RTN","HLCSTCP2",128,0)
+ ... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2))
+"RTN","HLCSTCP2",129,0)
+ ...;
+"RTN","HLCSTCP2",130,0)
+ ... S HLREREAD="0^Error"
+"RTN","HLCSTCP2",131,0)
+ .. ;app ack was successful
+"RTN","HLCSTCP2",132,0)
+ .. D DONE(3) S HLREREAD="0^App Ack"
+"RTN","HLCSTCP2",133,0)
+ ..;
+"RTN","HLCSTCP2",134,0)
+ Q
+"RTN","HLCSTCP2",135,0)
+ ;
+"RTN","HLCSTCP2",136,0)
+DCSEND ;direct connect
+"RTN","HLCSTCP2",137,0)
+ ; Set up error trap
+"RTN","HLCSTCP2",138,0)
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+"RTN","HLCSTCP2",139,0)
+ I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP2"")" ;turn on error trapping on GT.M
+"RTN","HLCSTCP2",140,0)
+ ;override ack timeout
+"RTN","HLCSTCP2",141,0)
+ I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME")
+"RTN","HLCSTCP2",142,0)
+ I $$WRITE(HLMSG)<0 D:$G(HLERROR)]""  Q  ;HL*1.6*77
+"RTN","HLCSTCP2",143,0)
+ .  D STATUS^HLTF0(HLMSG,4,$P(HLERROR,"^"),$P(HLERROR,"^",2),1) ;HL*1.6*77
+"RTN","HLCSTCP2",144,0)
+ .  D LLCNT^HLCSTCP(HLDP,3,1)
+"RTN","HLCSTCP2",145,0)
+ D LLCNT^HLCSTCP(HLDP,4)
+"RTN","HLCSTCP2",146,0)
+ ;do structure is to stack error
+"RTN","HLCSTCP2",147,0)
+ D
+"RTN","HLCSTCP2",148,0)
+ . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
+"RTN","HLCSTCP2",149,0)
+ . I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G RDERR^HLCSTCP2"")" ;change I/O error trap
+"RTN","HLCSTCP2",150,0)
+ . ;HLRESP=ien 773^ien 772 for response message
+"RTN","HLCSTCP2",151,0)
+ . S HLRESP=$$READ^HLCSTCP1()
+"RTN","HLCSTCP2",152,0)
+ ;
+"RTN","HLCSTCP2",153,0)
+ D DONE(3):$G(HLRESP),DONE(4,108,$S($G(HLERROR)]"":$P(HLERROR,"^",2),1:"No response")):'$G(HLRESP)
+"RTN","HLCSTCP2",154,0)
+ I $G(HLERROR)']"" D
+"RTN","HLCSTCP2",155,0)
+ .D MON^HLCSTCP("Idle")
+"RTN","HLCSTCP2",156,0)
+ .I '$G(HLRESP) S HLERROR="108^No response"
+"RTN","HLCSTCP2",157,0)
+ ;Close port
+"RTN","HLCSTCP2",158,0)
+ I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+"RTN","HLCSTCP2",159,0)
+ Q
+"RTN","HLCSTCP2",160,0)
+ ;
+"RTN","HLCSTCP2",161,0)
+DONE(ST,ERR,ERRMSG) ;set status to complete
+"RTN","HLCSTCP2",162,0)
+ ;ST=status, ERR=error ien, ERRMSG=error msg
+"RTN","HLCSTCP2",163,0)
+ D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1)
+"RTN","HLCSTCP2",164,0)
+ ;
+"RTN","HLCSTCP2",165,0)
+ ;**109**
+"RTN","HLCSTCP2",166,0)
+ D DEQUE^HLCSREP(HLDP,"O",HLMSG)
+"RTN","HLCSTCP2",167,0)
+ ;
+"RTN","HLCSTCP2",168,0)
+ ;check for more msg.
+"RTN","HLCSTCP2",169,0)
+ I $G(HLPRIO)'="I" S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0
+"RTN","HLCSTCP2",170,0)
+ Q
+"RTN","HLCSTCP2",171,0)
+ ;
+"RTN","HLCSTCP2",172,0)
+CHKMSG(HLI) ;check status of message and update if not cancelled
+"RTN","HLCSTCP2",173,0)
+ ;input: HLI=new status, HLMSG=ien of msg in 773
+"RTN","HLCSTCP2",174,0)
+ ;returns 1=msg was updated, 0=msg has been canceled
+"RTN","HLCSTCP2",175,0)
+ N X
+"RTN","HLCSTCP2",176,0)
+ ;
+"RTN","HLCSTCP2",177,0)
+ ;**109**
+"RTN","HLCSTCP2",178,0)
+ ;F  L +^HLMA(HLMSG,"P"):1 Q:$T  H 1
+"RTN","HLCSTCP2",179,0)
+ ;
+"RTN","HLCSTCP2",180,0)
+ ;
+"RTN","HLCSTCP2",181,0)
+ ; New HL*1.6*77 code starting here...
+"RTN","HLCSTCP2",182,0)
+ I '$D(^HLMA(HLMSG,"P")) D  Q 0
+"RTN","HLCSTCP2",183,0)
+ .  S HLERROR="2^Missing status field"
+"RTN","HLCSTCP2",184,0)
+ .  D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1)
+"RTN","HLCSTCP2",185,0)
+ .;
+"RTN","HLCSTCP2",186,0)
+ .;**109**
+"RTN","HLCSTCP2",187,0)
+ . D DEQUE^HLCSREP(HLDP,"O",HLMSG)
+"RTN","HLCSTCP2",188,0)
+ .;L -^HLMA(HLMSG,"P")
+"RTN","HLCSTCP2",189,0)
+ ;**end 109**
+"RTN","HLCSTCP2",190,0)
+ ;
+"RTN","HLCSTCP2",191,0)
+ ; End of HL*1.6*77 modifications
+"RTN","HLCSTCP2",192,0)
+ ;
+"RTN","HLCSTCP2",193,0)
+ ;get status, quit if msg was cancelled
+"RTN","HLCSTCP2",194,0)
+ ;
+"RTN","HLCSTCP2",195,0)
+ ;**109**
+"RTN","HLCSTCP2",196,0)
+ ;S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0
+"RTN","HLCSTCP2",197,0)
+ S X=+^HLMA(HLMSG,"P") Q:X=3 0
+"RTN","HLCSTCP2",198,0)
+ ;
+"RTN","HLCSTCP2",199,0)
+ ;update status if it is different
+"RTN","HLCSTCP2",200,0)
+ I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI)
+"RTN","HLCSTCP2",201,0)
+ ;
+"RTN","HLCSTCP2",202,0)
+ ;**109**
+"RTN","HLCSTCP2",203,0)
+ ;L -^HLMA(HLMSG,"P")
+"RTN","HLCSTCP2",204,0)
+ ;
+"RTN","HLCSTCP2",205,0)
+ Q 1
+"RTN","HLCSTCP2",206,0)
+ ;
+"RTN","HLCSTCP2",207,0)
+WRITE(HLDA) ; write message in HL7 format
+"RTN","HLCSTCP2",208,0)
+ ;  HLDA       - ien of message in 773
+"RTN","HLCSTCP2",209,0)
+ ;             - start block $C(11)
+"RTN","HLCSTCP2",210,0)
+ ;             - end block $C(28)
+"RTN","HLCSTCP2",211,0)
+ ;             - record separator $C(13)
+"RTN","HLCSTCP2",212,0)
+ ;Output(s): 1 - Successful
+"RTN","HLCSTCP2",213,0)
+ ;           -1 - Unsuccessful
+"RTN","HLCSTCP2",214,0)
+ ;
+"RTN","HLCSTCP2",215,0)
+ N HLDA2,HLAR,HLI,LINENO,X
+"RTN","HLCSTCP2",216,0)
+ ;set error trap, used when called from HLTP3
+"RTN","HLCSTCP2",217,0)
+ ;
+"RTN","HLCSTCP2",218,0)
+ ; New HL*1.6*77 code starts here...
+"RTN","HLCSTCP2",219,0)
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
+"RTN","HLCSTCP2",220,0)
+ I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP2"")" ;turn on error trapping on GT.M
+"RTN","HLCSTCP2",221,0)
+ I $G(^HLMA(HLDA,0))'>0 D  Q -1
+"RTN","HLCSTCP2",222,0)
+ .  S HLERROR="2^Message Text pointer missing"
+"RTN","HLCSTCP2",223,0)
+ S HLDA2=+$G(^HLMA(HLDA,0))
+"RTN","HLCSTCP2",224,0)
+ ; End of HL*1.6*77 modifications...
+"RTN","HLCSTCP2",225,0)
+ ;
+"RTN","HLCSTCP2",226,0)
+ Q:'$G(^HLMA(HLDA,0)) -1 ;HL*1.6*77
+"RTN","HLCSTCP2",227,0)
+ ; header is in ^HLMA(, message is in ^HL(772,
+"RTN","HLCSTCP2",228,0)
+ S LINENO=1,HLI=0,HLAR="^HLMA(HLDA,""MSH"")"
+"RTN","HLCSTCP2",229,0)
+ U IO
+"RTN","HLCSTCP2",230,0)
+ D  W $C(13) S HLAR="^HL(772,HLDA2,""IN"")",HLI=0 D
+"RTN","HLCSTCP2",231,0)
+ . F  S HLI=$O(@HLAR@(HLI)) Q:'HLI  S X=$G(^(HLI,0)) D
+"RTN","HLCSTCP2",232,0)
+ .. ;first line, need start block char.
+"RTN","HLCSTCP2",233,0)
+ .. S:LINENO=1 X=$C(11)_X
+"RTN","HLCSTCP2",234,0)
+ .. I X]"" W X,!
+"RTN","HLCSTCP2",235,0)
+ .. ;send CR for blank lines
+"RTN","HLCSTCP2",236,0)
+ .. I X="" W $C(13)
+"RTN","HLCSTCP2",237,0)
+ .. S LINENO=LINENO+1
+"RTN","HLCSTCP2",238,0)
+ ; Sends end block for this message
+"RTN","HLCSTCP2",239,0)
+ S X=$C(28)_$C(13)
+"RTN","HLCSTCP2",240,0)
+ U IO W X,!
+"RTN","HLCSTCP2",241,0)
+ Q 1
+"RTN","HLCSTCP2",242,0)
+ ;
+"RTN","HLCSTCP2",243,0)
+OPEN() ; -- Open TCP/IP device (Client)
+"RTN","HLCSTCP2",244,0)
+ ;HLPORT=port, defined only if port is open
+"RTN","HLCSTCP2",245,0)
+ ;HLPORTA=number of attempted opens
+"RTN","HLCSTCP2",246,0)
+ I $D(HLPORT) S IO=HLPORT D  Q 1
+"RTN","HLCSTCP2",247,0)
+ . U IO
+"RTN","HLCSTCP2",248,0)
+ . I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache'
+"RTN","HLCSTCP2",249,0)
+ N HLDOM,HLI,HLIP,HLPORTA
+"RTN","HLCSTCP2",250,0)
+ G OPENA^HLCSTCP3
+"RTN","HLCSTCP2",251,0)
+ ;
+"RTN","HLCSTCP2",252,0)
+RDERR D RDERR^HLCSTCP4 Q  ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
+"RTN","HLCSTCP2",253,0)
+ERROR D ERROR^HLCSTCP4 Q  ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
+"RTN","HLCSTCP2",254,0)
+ ;
+"RTN","HLCSTCP2",255,0)
+CC(X) ;cleanup and close
+"RTN","HLCSTCP2",256,0)
+ D MON^HLCSTCP(X)
+"RTN","HLCSTCP2",257,0)
+ I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+"RTN","HLCSTCP2",258,0)
+ H 2
+"RTN","HLCSTCP2",259,0)
+ Q
+"RTN","HLCSTCP3")
+0^54^B4155616
+"RTN","HLCSTCP3",1,0)
+HLCSTCP3 ;SFIRMFO/RSD MSC/JKT - BI-DIRECTIONAL TCP ;02/25/2010  11:08
+"RTN","HLCSTCP3",2,0)
+ ;;1.6;HEALTH LEVEL SEVEN;**76,77,MSC**;JUL 17, 1995
+"RTN","HLCSTCP3",3,0)
+ ;
+"RTN","HLCSTCP3",4,0)
+OPENA I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
+"RTN","HLCSTCP3",5,0)
+ D MON^HLCSTCP("Open")
+"RTN","HLCSTCP3",6,0)
+ S POP=1
+"RTN","HLCSTCP3",7,0)
+ F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
+"RTN","HLCSTCP3",8,0)
+ ;set # of opens back in msg
+"RTN","HLCSTCP3",9,0)
+ I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
+"RTN","HLCSTCP3",10,0)
+ ;device open
+"RTN","HLCSTCP3",11,0)
+ I 'POP S HLPORT=IO D  Q $S($G(HLERROR)]"":0,1:1)
+"RTN","HLCSTCP3",12,0)
+ . N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" ;HL*1.6*77
+"RTN","HLCSTCP3",13,0)
+ . I HLOS["GT.M" X "U IO:(IOERROR=""TRAP"":EXCEPT=""G ERROR^HLCSTCP2"")" ;turn on error trapping on GT.M
+"RTN","HLCSTCP3",14,0)
+ . ;if address came from DNS, set back into LL
+"RTN","HLCSTCP3",15,0)
+ . I $D(HLIP) S $P(^HLCS(870,HLDP,400),U)=HLTCPADD
+"RTN","HLCSTCP3",16,0)
+ . ; write and read to check if still open
+"RTN","HLCSTCP3",17,0)
+ . Q:HLOS'["OpenM"  X "U IO:(::""-M"")" ; must be Cache/NT + use packet mode
+"RTN","HLCSTCP3",18,0)
+ . Q:$P(^HLCS(870,HLDP,400),U,7)'="Y"  ; must want to SAY HELO
+"RTN","HLCSTCP3",19,0)
+ . U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1
+"RTN","HLCSTCP3",20,0)
+ ;openfail-try DNS lookup
+"RTN","HLCSTCP3",21,0)
+ I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
+"RTN","HLCSTCP3",22,0)
+ ;HLIP=ip add. from DNS call, get first one and try open again
+"RTN","HLCSTCP3",23,0)
+ I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA
+"RTN","HLCSTCP3",24,0)
+ ;open error
+"RTN","HLCSTCP3",25,0)
+ D CC^HLCSTCP2("Openfail") H 3
+"RTN","HLCSTCP3",26,0)
+ Q 0
+"RTN","HLCSTCP3",27,0)
+ ;
+"RTN","HLCSTCP3",28,0)
+ ;following code was removed, site's complained of to many alerts
+"RTN","HLCSTCP3",29,0)
+ ;couldn't open, send 1 alert
+"RTN","HLCSTCP3",30,0)
+ ;I '$G(HLPORTA) D
+"RTN","HLCSTCP3",31,0)
+ ;. ;send alert
+"RTN","HLCSTCP3",32,0)
+ ;. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
+"RTN","HLCSTCP3",33,0)
+ ;. ;get mailgroup from file 869.3
+"RTN","HLCSTCP3",34,0)
+ ;. S Z=$P($$PARAM^HLCS2,U,8),HLPORTA="" Q:Z=""
+"RTN","HLCSTCP3",35,0)
+ ;. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" Logical Link "_$P(^HLCS(870,HLDP,0),U)_" exceeded Open Retries."
+"RTN","HLCSTCP3",36,0)
+ ;. D SETUP^XQALERT
+"RTN","HLCSTCP3",37,0)
+ ;open error
+"RTN","HLCSTCP3",38,0)
+ ;D CC("Openfail") H 3
+"RTN","HLCSTCP3",39,0)
+ ;Q 0
+"RTN","HLCSTCP3",40,0)
+ ;
+"RTN","HLCSTCP3",41,0)
+ ;
+"RTN","HLCSTCP3",42,0)
+DNS ;VA domains must have "med" inserted.
+"RTN","HLCSTCP3",43,0)
+ ;All domains must use port 5000 and are prepended with "HL7"
+"RTN","HLCSTCP3",44,0)
+ ;non-VA DNS lookups will succeed if site uses port 5000 and 
+"RTN","HLCSTCP3",45,0)
+ ;configure their local DNS with "HL7.yourdomain.com" and entries
+"RTN","HLCSTCP3",46,0)
+ ;are created in the logical link file and domain file.
+"RTN","HLCSTCP3",47,0)
+ D MON^HLCSTCP("DNS Lkup")
+"RTN","HLCSTCP3",48,0)
+ I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV"
+"RTN","HLCSTCP3",49,0)
+ I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
+"RTN","HLCSTCP3",50,0)
+ I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
+"RTN","HLCSTCP3",51,0)
+ S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
+"RTN","HLCSTCP3",52,0)
+ K:HLIP="" HLIP
+"RTN","HLCSTCP3",53,0)
+ Q
+"RTN","HLCSTCP3",54,0)
+ ;
+"RTN","HLCSTCP4")
+0^55^B3608309
+"RTN","HLCSTCP4",1,0)
+HLCSTCP4 ;SFIRMFO/RSD - MSC/JKT BI-DIRECTIONAL TCP ;02/25/2010  11:08
+"RTN","HLCSTCP4",2,0)
+ ;;1.6;HEALTH LEVEL SEVEN;**109,MSC**;Oct 13,1995
+"RTN","HLCSTCP4",3,0)
+ ;
+"RTN","HLCSTCP4",4,0)
+ ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
+"RTN","HLCSTCP4",5,0)
+ ;
+"RTN","HLCSTCP4",6,0)
+RDERR ; Error during read process, decrement counter
+"RTN","HLCSTCP4",7,0)
+ D LLCNT^HLCSTCP(HLDP,4,1)
+"RTN","HLCSTCP4",8,0)
+ERROR ; Error trap
+"RTN","HLCSTCP4",9,0)
+ ; OPEN ERROR-retry.
+"RTN","HLCSTCP4",10,0)
+ ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
+"RTN","HLCSTCP4",11,0)
+ ;
+"RTN","HLCSTCP4",12,0)
+ ;**109**
+"RTN","HLCSTCP4",13,0)
+ ;I $G(HLMSG) L -^HLMA(HLMSG)
+"RTN","HLCSTCP4",14,0)
+ ;
+"RTN","HLCSTCP4",15,0)
+ S $ETRAP="D UNWIND^%ZTER"
+"RTN","HLCSTCP4",16,0)
+ I HLOS["GT.M" X "U IO:(IOERROR="""":EXCEPT="""")" ;turn off error trapping -- we're already handling the error
+"RTN","HLCSTCP4",17,0)
+ I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q
+"RTN","HLCSTCP4",18,0)
+ I $$EC^%ZOSV["WRITE" D  Q  ;HL*1.6*77 modifications start here
+"RTN","HLCSTCP4",19,0)
+ .  D CC^HLCSTCP2("Wr-err")
+"RTN","HLCSTCP4",20,0)
+ .  S:$G(HLPRIO)="I" HLERROR="108^Write Error"
+"RTN","HLCSTCP4",21,0)
+ .  D UNWIND^%ZTER ;HL*1.6*77 modifications end here
+"RTN","HLCSTCP4",22,0)
+ I $$EC^%ZOSV["READ"!($$EC^%ZOSV["IOEOF") D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
+"RTN","HLCSTCP4",23,0)
+ S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
+"RTN","HLCSTCP4",24,0)
+ S:$G(HLPRIO)="I" HLERROR="9^Error"
+"RTN","HLCSTCP4",25,0)
+ D UNWIND^%ZTER
+"RTN","HLCSTCP4",26,0)
+ Q
+"RTN","HLCSTCP4",27,0)
+ ;
+"RTN","HLZTCP")
+0^52^B44973921
+"RTN","HLZTCP",1,0)
+HLZTCP ;MILW/JMC MSC/JKT - HL7 TCP/IP Hybrid Lower Level Protocol Receiver/Sender ;28OCT2009
+"RTN","HLZTCP",2,0)
+ ;;1.5;HEALTH LEVEL SEVEN;**MSC**;JUL 09, 1993
+"RTN","HLZTCP",3,0)
+ ;
+"RTN","HLZTCP",4,0)
+INIT ;Initialize Variables
+"RTN","HLZTCP",5,0)
+ N HLZIO,HLZOS,HLZSTATE
+"RTN","HLZTCP",6,0)
+ S HLZOS=$G(^%ZOSF("OS"))
+"RTN","HLZTCP",7,0)
+ ;
+"RTN","HLZTCP",8,0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+"RTN","HLZTCP",9,0)
+ ;
+"RTN","HLZTCP",10,0)
+ I $$NEWERR^%ZTER N $ETRAP S $ETRAP=""
+"RTN","HLZTCP",11,0)
+ S X="ERR^HLZTCP",@^%ZOSF("TRAP")
+"RTN","HLZTCP",12,0)
+ ;
+"RTN","HLZTCP",13,0)
+ I '$D(HLION) D  Q:POP
+"RTN","HLZTCP",14,0)
+ . D HOME^%ZIS
+"RTN","HLZTCP",15,0)
+ . I POP Q
+"RTN","HLZTCP",16,0)
+ . S HLION=$S(ION']"":"UNKNOWN",1:ION)
+"RTN","HLZTCP",17,0)
+ ;
+"RTN","HLZTCP",18,0)
+ S HLZIO(0)=IO
+"RTN","HLZTCP",19,0)
+ ;
+"RTN","HLZTCP",20,0)
+ ; Figure out type of connection: 1=Server, 2=Client.
+"RTN","HLZTCP",21,0)
+ I HLZOS["DSM" S HLZTCP=$S(IOPAR["ADDRESS":2,1:1)
+"RTN","HLZTCP",22,0)
+ I HLZOS["OpenM" D
+"RTN","HLZTCP",23,0)
+ . N IP
+"RTN","HLZTCP",24,0)
+ . S IP=$P(IOPAR,"""",2) ; Extract IP address
+"RTN","HLZTCP",25,0)
+ . S HLZTCP=$S(IP?1.3N1P1.3N1P1.3N1P1.3N:2,1:1)
+"RTN","HLZTCP",26,0)
+ ;
+"RTN","HLZTCP",27,0)
+ ; IOPAR is not available to us because of the way we're setting up devices on
+"RTN","HLZTCP",28,0)
+ ; GT.M.  This routine is only called from a few places, and always in "Client"
+"RTN","HLZTCP",29,0)
+ ; mode, so hard code a return value of 2.  This entire routine should be
+"RTN","HLZTCP",30,0)
+ ; abandoned in the future, so it's an acceptable workaround for now.
+"RTN","HLZTCP",31,0)
+ ; See https://code.launchpad.net/~jontai/openvista-gtm-integration/bug430855/+merge/14088
+"RTN","HLZTCP",32,0)
+ I HLZOS["GT.M" S HLZTCP=2
+"RTN","HLZTCP",33,0)
+ ;
+"RTN","HLZTCP",34,0)
+ S IOP="NULL DEVICE" D ^%ZIS
+"RTN","HLZTCP",35,0)
+ I POP G EXIT
+"RTN","HLZTCP",36,0)
+ S HLZIO=IO K IOP
+"RTN","HLZTCP",37,0)
+ ;
+"RTN","HLZTCP",38,0)
+ S HLTIME=$$NOW^XLFDT
+"RTN","HLZTCP",39,0)
+ ;
+"RTN","HLZTCP",40,0)
+ U HLZIO(0)
+"RTN","HLZTCP",41,0)
+ ; If TCP client, send a "space" to initiate connection.
+"RTN","HLZTCP",42,0)
+ I HLZTCP=2 W " ",!
+"RTN","HLZTCP",43,0)
+ ;
+"RTN","HLZTCP",44,0)
+ K %,%H,%I,X
+"RTN","HLZTCP",45,0)
+ S DTIME=$P($G(HLNDAP0),"^",9),HLTRIES=$P($G(HLNDAP0),"^",5)
+"RTN","HLZTCP",46,0)
+ S:DTIME'>0 DTIME=60 S:HLTRIES'>0 HLTRIES=3
+"RTN","HLZTCP",47,0)
+ S HLLPC=^%ZOSF("LPC")
+"RTN","HLZTCP",48,0)
+ ;
+"RTN","HLZTCP",49,0)
+LOOP ; Infinite loop to check for HL7 messages to send/receive
+"RTN","HLZTCP",50,0)
+ F  D  I $$S^%ZTLOAD S ZTSTOP=1 Q
+"RTN","HLZTCP",51,0)
+ . S HLLOG=$S($D(^HL(770,"ALOG",HLION)):1,1:0)
+"RTN","HLZTCP",52,0)
+ . D CHKREC,CHKSEND
+"RTN","HLZTCP",53,0)
+EXIT Q
+"RTN","HLZTCP",54,0)
+ ;
+"RTN","HLZTCP",55,0)
+ERR ; Trap error
+"RTN","HLZTCP",56,0)
+ ; Reset current device to "NULL DEVICE".
+"RTN","HLZTCP",57,0)
+ U HLZIO
+"RTN","HLZTCP",58,0)
+ ; Reschedule task.
+"RTN","HLZTCP",59,0)
+ I $$EC^%ZOSV["WRITE"!($$EC^%ZOSV["READ") D
+"RTN","HLZTCP",60,0)
+ . N ZTDTH,ZTSK
+"RTN","HLZTCP",61,0)
+ . S ZTSK=ZTQUEUED,ZTDTH="60S",ZTREQ=""
+"RTN","HLZTCP",62,0)
+ . D REQ^%ZTLOAD ; Requeue task in 60 seconds.
+"RTN","HLZTCP",63,0)
+ K HLL(1),^TMP("HLR",$J),^TMP("HLS",$J)
+"RTN","HLZTCP",64,0)
+ Q
+"RTN","HLZTCP",65,0)
+ ;
+"RTN","HLZTCP",66,0)
+CHKREC ; Check if there are HL7 messages to receive
+"RTN","HLZTCP",67,0)
+ ; Set flag to receive state.
+"RTN","HLZTCP",68,0)
+ S HLZSTATE="recv"
+"RTN","HLZTCP",69,0)
+ D REC
+"RTN","HLZTCP",70,0)
+ ; Received "NAK" message don't know what it goes to.
+"RTN","HLZTCP",71,0)
+ I $G(HLZNAK) K HLERR Q
+"RTN","HLZTCP",72,0)
+ I '$D(HLDTOUT),'HLERR D SENDNAK G CHKREC
+"RTN","HLZTCP",73,0)
+ I '$D(HLDTOUT) U HLZIO K HLERR D ^HLCHK
+"RTN","HLZTCP",74,0)
+ U HLZIO
+"RTN","HLZTCP",75,0)
+ Q
+"RTN","HLZTCP",76,0)
+ ;
+"RTN","HLZTCP",77,0)
+CHKSEND ; Check if there are HL7 messages to send
+"RTN","HLZTCP",78,0)
+ ; Set flag to send state.
+"RTN","HLZTCP",79,0)
+ S HLZSTATE="send"
+"RTN","HLZTCP",80,0)
+ Q:'$D(HLNDAP)
+"RTN","HLZTCP",81,0)
+ I '$D(HLNDAP0) S HLNDAP0=$G(^HL(770,HLNDAP,0))
+"RTN","HLZTCP",82,0)
+ S HLDA=+$O(^HL(772,"AC","O",+$P(HLNDAP0,U,12),0)) G:'HLDA EX
+"RTN","HLZTCP",83,0)
+ S HLDA0=$G(^HL(772,HLDA,0)) G:HLDA0']"" EX
+"RTN","HLZTCP",84,0)
+ S HLXMZ=+$P(HLDA0,"^",5)
+"RTN","HLZTCP",85,0)
+ I 'HLXMZ D  G EX
+"RTN","HLZTCP",86,0)
+ . D STATUS^HLTF0(HLDA,4,"","No pointer to Message file(#3.9)")
+"RTN","HLZTCP",87,0)
+ I '$D(^XMB(3.9,HLXMZ)) D  G EX
+"RTN","HLZTCP",88,0)
+ . D STATUS^HLTF0(HLDA,4,"","No message found at #"_HLXMZ_" in Message file(#3.9)")
+"RTN","HLZTCP",89,0)
+ I '$O(^XMB(3.9,HLXMZ,2,0)) D  G EX
+"RTN","HLZTCP",90,0)
+ . D STATUS^HLTF0(HLDA,4,"","No message contents at #"_HLXMZ_" in Message file(#3.9)")
+"RTN","HLZTCP",91,0)
+ S (HLI,HLTRIED)=0,HLSDT=+HLDA0
+"RTN","HLZTCP",92,0)
+ F HLJ=1:1 S HLI=$O(^XMB(3.9,HLXMZ,2,HLI)) Q:HLI'>0  S ^TMP("HLS",$J,HLSDT,HLJ)=$G(^XMB(3.9,HLXMZ,2,HLI,0))
+"RTN","HLZTCP",93,0)
+CS1 S HLTRIED=HLTRIED+1
+"RTN","HLZTCP",94,0)
+ K ^TMP("HLR",$J),HLSDATA
+"RTN","HLZTCP",95,0)
+ D SEND
+"RTN","HLZTCP",96,0)
+ ; Set flag to awaiting acknowledgement state.
+"RTN","HLZTCP",97,0)
+ S HLZSTATE="awaiting ack"
+"RTN","HLZTCP",98,0)
+ D REC
+"RTN","HLZTCP",99,0)
+ I HLTRIED'=HLTRIES G CS1:$D(HLDTOUT) G CS1:HLZNAK
+"RTN","HLZTCP",100,0)
+ G EX:$D(HLDTOUT)
+"RTN","HLZTCP",101,0)
+ I HLZNAK D  G EX
+"RTN","HLZTCP",102,0)
+ . S HLAC=4,HLMSG="Lower Level Protocol Error - "_$S($E(HLL(1))="X":"Checksum",1:"Character Count")_" Did Not Match"
+"RTN","HLZTCP",103,0)
+ . D STATUS^HLTF0(HLDA,HLAC,HLMSG)
+"RTN","HLZTCP",104,0)
+ I $S('$D(HLL(1)):1,"BHS,MSH"'[$E(HLL(1),1,3):1,1:0) D  G EX
+"RTN","HLZTCP",105,0)
+ . S HLAC=4,HLMSG="Application Level error - Header Segment Missing"
+"RTN","HLZTCP",106,0)
+ . D STATUS^HLTF0(HLDA,HLAC,HLMSG)
+"RTN","HLZTCP",107,0)
+ K HLXMZ
+"RTN","HLZTCP",108,0)
+ U HLZIO
+"RTN","HLZTCP",109,0)
+ D CHK^HLCHK,IN^HLTF(HLMTN,HLMID,HLTIME)
+"RTN","HLZTCP",110,0)
+ ;
+"RTN","HLZTCP",111,0)
+EX K HLAC,HLDA,HLDA0,HLERR,HLMSG,HLI,HLJ,HLSDATA,HLSDT,HLTRIED
+"RTN","HLZTCP",112,0)
+ K ^TMP("HLS",$J),^TMP("HLR",$J)
+"RTN","HLZTCP",113,0)
+ Q
+"RTN","HLZTCP",114,0)
+ ;
+"RTN","HLZTCP",115,0)
+CSUM ;Calculate Checksum
+"RTN","HLZTCP",116,0)
+ S HLC1=HLC1+$L(X),X=X_HLC2 X HLLPC S HLC2=$C(Y)
+"RTN","HLZTCP",117,0)
+ Q
+"RTN","HLZTCP",118,0)
+ ;
+"RTN","HLZTCP",119,0)
+REC ;Receive a Message
+"RTN","HLZTCP",120,0)
+ S %=$$NOW^XLFDT
+"RTN","HLZTCP",121,0)
+ I HLTIME<% S HLTIME=%
+"RTN","HLZTCP",122,0)
+ E  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+"RTN","HLZTCP",123,0)
+ I HLLOG F  Q:'$D(^TMP("HL",HLION,HLTIME))  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+"RTN","HLZTCP",124,0)
+ K HLL,^TMP("HLR",$J)
+"RTN","HLZTCP",125,0)
+ S (HLC2,X0)="",(HLC1,HLI,HLK,HLZEB,HLZNAK)=0
+"RTN","HLZTCP",126,0)
+ U HLZIO(0)
+"RTN","HLZTCP",127,0)
+ F  R X1#1:DTIME Q:X1=$C(11)  I '$T S HLDTOUT=1 Q
+"RTN","HLZTCP",128,0)
+ ; Did not find "Start of block" character.
+"RTN","HLZTCP",129,0)
+ I X1'=$C(11) Q
+"RTN","HLZTCP",130,0)
+ S X0=X1,HLZLEN=1
+"RTN","HLZTCP",131,0)
+REC1 U HLZIO(0) K HLDTOUT
+"RTN","HLZTCP",132,0)
+ R X1#1:DTIME I '$T S HLDTOUT=1
+"RTN","HLZTCP",133,0)
+ ; Timed out and buffer empty.
+"RTN","HLZTCP",134,0)
+ I $G(HLDTOUT),'$L(X1) Q
+"RTN","HLZTCP",135,0)
+ ;
+"RTN","HLZTCP",136,0)
+ S X0=X0_X1,HLZLEN=HLZLEN+1
+"RTN","HLZTCP",137,0)
+ ; Set "NAK" block type flag.
+"RTN","HLZTCP",138,0)
+ I X1="N",HLZLEN=2 S HLZNAK=1
+"RTN","HLZTCP",139,0)
+ ; Set "End Block" flag.
+"RTN","HLZTCP",140,0)
+ I X1=$C(28) S HLZEB=1
+"RTN","HLZTCP",141,0)
+ I X1'=$C(13) G REC1
+"RTN","HLZTCP",142,0)
+ I HLZEB,HLZNAK D RECNAK Q
+"RTN","HLZTCP",143,0)
+ ;
+"RTN","HLZTCP",144,0)
+ ; Process "End Block" if not a "NAK" record.
+"RTN","HLZTCP",145,0)
+ I HLZEB S HLC=+$E(X0,6,8),HLB=+$E(X0,1,5),X0=""
+"RTN","HLZTCP",146,0)
+ I $L(X0) D
+"RTN","HLZTCP",147,0)
+ . I HLLOG D  ;Record Incoming Transmission in Log
+"RTN","HLZTCP",148,0)
+ . . S HLII=X0 S:$P(X0,$E(X0,5))="MSH" $P(X0,$E(X0,5),8)=""
+"RTN","HLZTCP",149,0)
+ . . S HLI=HLI+1,^TMP("HL",HLION,HLTIME,"REC",HLI)=$TR(X0,$C(11,13)),X0=HLII
+"RTN","HLZTCP",150,0)
+ . I HLK,HLK'>2 S HLL(HLK)=$TR(X0,$C(11,13))
+"RTN","HLZTCP",151,0)
+ . I HLK S ^TMP("HLR",$J,HLTIME,HLK)=$TR(X0,$C(11,13))
+"RTN","HLZTCP",152,0)
+ . S HLK=HLK+1,X=X0 D CSUM
+"RTN","HLZTCP",153,0)
+ . S X0=""
+"RTN","HLZTCP",154,0)
+ I 'HLZEB G REC1
+"RTN","HLZTCP",155,0)
+ S X=HLC2 X HLLPC S HLCSUM=Y,HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
+"RTN","HLZTCP",156,0)
+ I HLLOG S ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
+"RTN","HLZTCP",157,0)
+ Q
+"RTN","HLZTCP",158,0)
+ ;
+"RTN","HLZTCP",159,0)
+RECNAK ; Process Received "NAK" message.
+"RTN","HLZTCP",160,0)
+ S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+"RTN","HLZTCP",161,0)
+ S HLC=+$E(X0,7,9),HLB=+$E(X0,2,6),X=$E(X0,1) D CSUM
+"RTN","HLZTCP",162,0)
+ S X=HLC2 X HLLPC S HLCSUM=Y,HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
+"RTN","HLZTCP",163,0)
+ S HLL(1)=$TR(X0,$C(11,13,28)),^TMP("HLR",$J,HLTIME,1)=HLL(1)
+"RTN","HLZTCP",164,0)
+ I HLLOG D
+"RTN","HLZTCP",165,0)
+ . S ^TMP("HL",HLION,HLTIME,"REC",1)=HLL(1)
+"RTN","HLZTCP",166,0)
+ . S ^TMP("HL",HLION,HLTIME,"REC","CKS")="Our checksum="_HLCSUM_"/Their checksum="_HLC_"^Our character count="_HLC1_"/Their character count="_HLB
+"RTN","HLZTCP",167,0)
+ Q
+"RTN","HLZTCP",168,0)
+ ;
+"RTN","HLZTCP",169,0)
+SEND ;Send a Message
+"RTN","HLZTCP",170,0)
+ N X,Y
+"RTN","HLZTCP",171,0)
+ S %=$$NOW^XLFDT
+"RTN","HLZTCP",172,0)
+ I HLTIME<% S HLTIME=%
+"RTN","HLZTCP",173,0)
+ E  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+"RTN","HLZTCP",174,0)
+ I HLLOG F  Q:'$D(^TMP("HL",HLION,HLTIME))  S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+"RTN","HLZTCP",175,0)
+ S (HLI,HLC1)=0,HLC2=""
+"RTN","HLZTCP",176,0)
+ D WRITE($C(11)_"D21"_$C(13))
+"RTN","HLZTCP",177,0)
+ I '$D(HLSDT) F  S HLI=$O(HLSDATA(HLI)) Q:HLI=""  D WRITE(HLSDATA(HLI)_$C(13))
+"RTN","HLZTCP",178,0)
+ I $D(HLSDT) F  S HLI=$O(^TMP("HLS",$J,HLSDT,HLI)) Q:HLI=""  S HLSDATA=^(HLI) D WRITE(HLSDATA_$C(13))
+"RTN","HLZTCP",179,0)
+ D FLUSH
+"RTN","HLZTCP",180,0)
+ Q
+"RTN","HLZTCP",181,0)
+ ;
+"RTN","HLZTCP",182,0)
+SENDNAK ; Send a "NAK" message.
+"RTN","HLZTCP",183,0)
+ S (HLC1,HLI)=0,HLC2="",HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
+"RTN","HLZTCP",184,0)
+ D WRITE($C(11)_"N21"_$C(13)_HLERR)
+"RTN","HLZTCP",185,0)
+ D FLUSH
+"RTN","HLZTCP",186,0)
+ K HLSDATA,HLERR
+"RTN","HLZTCP",187,0)
+ Q
+"RTN","HLZTCP",188,0)
+ ;
+"RTN","HLZTCP",189,0)
+WRITE(X) ; Write data in buffer.
+"RTN","HLZTCP",190,0)
+ U HLZIO(0)
+"RTN","HLZTCP",191,0)
+ W X,!
+"RTN","HLZTCP",192,0)
+ I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND",HLI)=$TR(X,$C(11,13))
+"RTN","HLZTCP",193,0)
+ D CSUM
+"RTN","HLZTCP",194,0)
+ Q
+"RTN","HLZTCP",195,0)
+ ;
+"RTN","HLZTCP",196,0)
+FLUSH ; Write checksum and flush buffer.
+"RTN","HLZTCP",197,0)
+ S X=HLC2 X HLLPC S X=$E("0000",1,(5-$L(HLC1)))_HLC1_$E("00",1,(3-$L(Y)))_Y_$C(28)_$C(13)
+"RTN","HLZTCP",198,0)
+ U HLZIO(0)
+"RTN","HLZTCP",199,0)
+ ; Do final write for this block and flush buffer.
+"RTN","HLZTCP",200,0)
+ W X,!
+"RTN","HLZTCP",201,0)
+ I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND","CKS")=$TR(X,$C(11,13,28))
+"RTN","HLZTCP",202,0)
+ Q
+"RTN","MAGDMEDL")
+0^36^B3132920
+"RTN","MAGDMEDL",1,0)
+MAGDMEDL ;WOIFO/LB,MSC/JDA - Routine to look up entries in the Medicine files ;27APR2009
+"RTN","MAGDMEDL",2,0)
+ ;;3.0;IMAGING;**MSC**;Mar 01, 2002
+"RTN","MAGDMEDL",3,0)
+ ;; +---------------------------------------------------------------+
+"RTN","MAGDMEDL",4,0)
+ ;; | Property of the US Government.                                |
+"RTN","MAGDMEDL",5,0)
+ ;; | No permission to copy or redistribute this software is given. |
+"RTN","MAGDMEDL",6,0)
+ ;; | Use of unreleased versions of this software requires the user |
+"RTN","MAGDMEDL",7,0)
+ ;; | to execute a written test agreement with the VistA Imaging    |
+"RTN","MAGDMEDL",8,0)
+ ;; | Development Office of the Department of Veterans Affairs,     |
+"RTN","MAGDMEDL",9,0)
+ ;; | telephone [phone].                                     |
+"RTN","MAGDMEDL",10,0)
+ ;; |                                                               |
+"RTN","MAGDMEDL",11,0)
+ ;; | The Food and Drug Administration classifies this software as  |
+"RTN","MAGDMEDL",12,0)
+ ;; | a medical device.  As such, it may not be changed in any way. |
+"RTN","MAGDMEDL",13,0)
+ ;; | Modifications to this software may result in an adulterated   |
+"RTN","MAGDMEDL",14,0)
+ ;; | medical device under 21CFR820, the use of which is considered |
+"RTN","MAGDMEDL",15,0)
+ ;; | to be a violation of US Federal Statutes.                     |
+"RTN","MAGDMEDL",16,0)
+ ;; +---------------------------------------------------------------+
+"RTN","MAGDMEDL",17,0)
+ ;;
+"RTN","MAGDMEDL",18,0)
+ Q
+"RTN","MAGDMEDL",19,0)
+SELECT(ITEM,ARRAY) ;
+"RTN","MAGDMEDL",20,0)
+ ;
+"RTN","MAGDMEDL",21,0)
+SELECT2
+"RTN","MAGDMEDL",22,0)
+ N CNT,DIR,DIROUT,DIRUT,ENTRY
+"RTN","MAGDMEDL",23,0)
+ S CNT=+ARRAY
+"RTN","MAGDMEDL",24,0)
+ I 'CNT Q 0
+"RTN","MAGDMEDL",25,0)
+ S DIR(0)="NO^1:"_CNT,DIR("A")="Select a Medicine Procedure"
+"RTN","MAGDMEDL",26,0)
+ S DIR("T")=600 D ^DIR
+"RTN","MAGDMEDL",27,0)
+ I $D(DIRUT)!($D(DIROUT)) Q 0
+"RTN","MAGDMEDL",28,0)
+ S ENTRY=+Y
+"RTN","MAGDMEDL",29,0)
+ I '$D(ARRAY(ENTRY)) D  G SELECT2
+"RTN","MAGDMEDL",30,0)
+ . W !,"Please select an entry or use '^' to exit"
+"RTN","MAGDMEDL",31,0)
+ W !,"You have selected ",$P(ARRAY(ENTRY),"^"),"."
+"RTN","MAGDMEDL",32,0)
+ Q $P(ARRAY(ENTRY),"^",2)
+"RTN","MAGDMEDL",33,0)
+ ;
+"RTN","MAGDMEDL",34,0)
+LOOP(ARRAY,MAGPAT,SUB,CASEDT) ;
+"RTN","MAGDMEDL",35,0)
+ ; MAGPAT = patient's dfn
+"RTN","MAGDMEDL",36,0)
+ ; SUB = Medicine specialty
+"RTN","MAGDMEDL",37,0)
+ ; CASEDT = case date
+"RTN","MAGDMEDL",38,0)
+ ;  array(0)= 1 or 0 ^ # entries found ^ message text
+"RTN","MAGDMEDL",39,0)
+ ;  array(#)= formatted out dislay without delimeters
+"RTN","MAGDMEDL",40,0)
+ ;  array(#,1) = internal stored values
+"RTN","MAGDMEDL",41,0)
+ ; Variable MAGDIMG
+"RTN","MAGDMEDL",42,0)
+ S ARRAY(0)="0^^No entries found"
+"RTN","MAGDMEDL",43,0)
+ Q:'MAGPAT
+"RTN","MAGDMEDL",44,0)
+ Q:'$D(MAGMC)#10   ;Array should be available.
+"RTN","MAGDMEDL",45,0)
+ N BEG,CDT,CNT,DATA,DIOCM,EN,END,IMG,IMAGEPTR,MAGDIMG,PATIENT,PATNME,PRCNM,SSN,THEDT,X1,X2,X
+"RTN","MAGDMEDL",46,0)
+ N IEN,II,IOUT,MAGMC,MEDFILE
+"RTN","MAGDMEDL",47,0)
+ Q:'$$FIND1^DIC(2,,"A",MAGPAT,"","")
+"RTN","MAGDMEDL",48,0)
+ S PATNME=$P(^DPT(MAGPAT,0),"^"),SSN=$P(^(0),"^",9)
+"RTN","MAGDMEDL",49,0)
+ S PATIENT=PATNME_" "_SSN
+"RTN","MAGDMEDL",50,0)
+ I 'CASEDT S CASEDT=DT
+"RTN","MAGDMEDL",51,0)
+ S X1=CASEDT,X2=-3 D C^%DTC S BEG=X
+"RTN","MAGDMEDL",52,0)
+ S END=CASEDT+.9999
+"RTN","MAGDMEDL",53,0)
+ S CNT=0,CDT=BEG-.001
+"RTN","MAGDMEDL",54,0)
+ F  S CDT=$O(MAGMC(MAGPAT,SUB,CDT)) Q:'CDT!(CDT>END)  D
+"RTN","MAGDMEDL",55,0)
+ . S EN=0 F  S EN=$O(MAGMC(MAGPAT,SUB,CDT,EN)) Q:'EN  D
+"RTN","MAGDMEDL",56,0)
+ . . S DATA=MAGMC(MAGPAT,SUB,CDT,EN)
+"RTN","MAGDMEDL",57,0)
+ . . S PRCNM=$P(DATA,"^",2),PRC=SUB
+"RTN","MAGDMEDL",58,0)
+ . . S THEDT=$P(DATA,"^"),IEN=$P(DATA,"^",5)
+"RTN","MAGDMEDL",59,0)
+ . . I $D(MAGMC(MAGPAT,SUB,CDT,EN,2005)) S (IOUT,II)=0 D
+"RTN","MAGDMEDL",60,0)
+ . . . F  S II=$O(MAGMC(MAGPAT,SUB,CDT,EN,2005,II)) Q:'II!IOUT  D
+"RTN","MAGDMEDL",61,0)
+ . . . . S IMAGEPTR=MAGMC(MAGPAT,SUB,CDT,EN,2005,II)
+"RTN","MAGDMEDL",62,0)
+ . . . . I '$D(^MAG(2005,IMAGEPTR)) S IMAGEPTR="" Q
+"RTN","MAGDMEDL",63,0)
+ . . . . I '$D(^MAG(2005,IMAGEPTR,"PACS"))  S IMAGEPTR="",IOUT=1
+"RTN","MAGDMEDL",64,0)
+ . . S MEDFILE=$P(DATA,"^",4),MEDFILE=$P(MEDFILE,"MCAR(",2)
+"RTN","MAGDMEDL",65,0)
+ . . S DICOM="" D DICOMID^MAGDMEDI(.DICOM,MEDFILE,IEN,PRC,MAGPAT)
+"RTN","MAGDMEDL",66,0)
+ . . I DICOM'="" D
+"RTN","MAGDMEDL",67,0)
+ . . . S DICOM=$P(DICOM,":",2)
+"RTN","MAGDMEDL",68,0)
+ . . . S CNT=CNT+1
+"RTN","MAGDMEDL",69,0)
+ . . . S ARRAY(CNT)=DICOM_" "_PRCNM_", "_THEDT_" "_PATIENT
+"RTN","MAGDMEDL",70,0)
+ . . . S ARRAY(CNT,1)=DICOM_"^"_PATNME_"^"_SSN_"^"_EN_"^"_PRCNM_"^"_PRC_"^"_$G(IMAGEPTR)_"^"_MEDFILE
+"RTN","MAGDMEDL",71,0)
+ I CNT S ARRAY(0)="1^"_CNT_"^Medicine file entries for "_PATIENT
+"RTN","MAGDMEDL",72,0)
+ Q
+"RTN","MAGDMEDL",73,0)
+DISPLAY(ARRAY) ;
+"RTN","MAGDMEDL",74,0)
+ ; Call routine needs to pass array in the following sequence
+"RTN","MAGDMEDL",75,0)
+ ; ARRAY(0)= 1 or 0 ^ #entries ^ message
+"RTN","MAGDMEDL",76,0)
+ ; ARRAY(#)=  Formatted output to be displayed.
+"RTN","MAGDMEDL",77,0)
+ ; Will set the RES variable for selected entry.
+"RTN","MAGDMEDL",78,0)
+ I '$D(ARRAY(0)) Q 0
+"RTN","MAGDMEDL",79,0)
+ ; If only one entry return the subscript variable.
+"RTN","MAGDMEDL",80,0)
+ I $P(ARRAY(0),"^",2)=1 Q 1
+"RTN","MAGDMEDL",81,0)
+ I $P(ARRAY(0),"^")'=1 Q 0
+"RTN","MAGDMEDL",82,0)
+ N ENTRY,ITEM,ITEMS,MSG,OUT,OUTPUT,RES
+"RTN","MAGDMEDL",83,0)
+ S RES=0,MSG=$P(ARRAY(0),"^",3)
+"RTN","MAGDMEDL",84,0)
+ S IOF="#,$C(27,91,72,27,91,74,8,8,8,8)",IO=0,IOSL=24,POP=0
+"RTN","MAGDMEDL",85,0)
+ D HEAD
+"RTN","MAGDMEDL",86,0)
+ S (ENTRY,OUT)=0,ITEMS=$P(ARRAY(0),"^",2)
+"RTN","MAGDMEDL",87,0)
+ F  S ENTRY=$O(ARRAY(ENTRY)) Q:'ENTRY!OUT  D
+"RTN","MAGDMEDL",88,0)
+ . S OUTPUT=$G(ARRAY(ENTRY))
+"RTN","MAGDMEDL",89,0)
+ . D:$Y+3>IOSL HEAD D LINE
+"RTN","MAGDMEDL",90,0)
+ . D:$Y+3>IOSL ASKQ
+"RTN","MAGDMEDL",91,0)
+ I 'OUT D ASKQ S RES=ITEM
+"RTN","MAGDMEDL",92,0)
+ Q RES
+"RTN","MAGDMEDL",93,0)
+HEAD ;
+"RTN","MAGDMEDL",94,0)
+ W:$Y+3>IOSL @IOF W !,MSG
+"RTN","MAGDMEDL",95,0)
+ Q
+"RTN","MAGDMEDL",96,0)
+LINE ;
+"RTN","MAGDMEDL",97,0)
+ W !,ENTRY,".) "_OUTPUT
+"RTN","MAGDMEDL",98,0)
+ Q
+"RTN","MAGDMEDL",99,0)
+ASKQ ;
+"RTN","MAGDMEDL",100,0)
+ N X,Y,DIR
+"RTN","MAGDMEDL",101,0)
+ S DIR(0)="L^1:"_$S('ENTRY:ITEMS,1:ENTRY)
+"RTN","MAGDMEDL",102,0)
+ S DIR("T")=600,DIR("A")="Select an entry: " D ^DIR
+"RTN","MAGDMEDL",103,0)
+ S ITEM=+Y
+"RTN","MAGDMEDL",104,0)
+ Q:$D(DIRUT)!($D(DIROUT))
+"RTN","MAGDMEDL",105,0)
+ Q:'ITEM
+"RTN","MAGDMEDL",106,0)
+ I '$D(ARRAY(ITEM)) W !,"Please select an entry or '^' to exit" G ASKQ
+"RTN","MAGDMEDL",107,0)
+ W !,"You have selected ",$P($G(ARRAY(ITEM)),"^")
+"RTN","MAGDMEDL",108,0)
+ S OUT=1
+"RTN","MAGDMEDL",109,0)
+ Q
+"RTN","MAGDMEDL",110,0)
+ASKMORE() ;
+"RTN","MAGDMEDL",111,0)
+ N DIR,DATE,X,XX,Y
+"RTN","MAGDMEDL",112,0)
+ Q:'$D(MAGPAT)
+"RTN","MAGDMEDL",113,0)
+ Q:'$D(SUB)
+"RTN","MAGDMEDL",114,0)
+ S DIR(0)="Y",DIR("B")="NO"
+"RTN","MAGDMEDL",115,0)
+ S DIR("A")="Search further"
+"RTN","MAGDMEDL",116,0)
+ D ^DIR K DIR
+"RTN","MAGDMEDL",117,0)
+ I 'Y Q 0
+"RTN","MAGDMEDL",118,0)
+ W !,"Search will include 3 days prior to the day specified."
+"RTN","MAGDMEDL",119,0)
+ S DIR(0)="D^::EXP" D ^DIR
+"RTN","MAGDMEDL",120,0)
+ ; Y2K compliance all calls to %DT must have either past or future date
+"RTN","MAGDMEDL",121,0)
+ I 'Y Q 0
+"RTN","MAGDMEDL",122,0)
+ S DATE=Y
+"RTN","MAGDMEDL",123,0)
+ D LOOP(.XX,MAGPAT,SUB,DATE)
+"RTN","MAGDMEDL",124,0)
+ I $D(XX(0)),$P(XX(0),"^")=0 D  Q 0
+"RTN","MAGDMEDL",125,0)
+ . W "No entries found."
+"RTN","MAGDMEDL",126,0)
+ Q 1
+"RTN","MSCGUX53")
+0^^B360592
+"RTN","MSCGUX53",1,0)
+MSCGUX53 ;MSC/JDS - ENVIRONMENT CHECK	; ; 29 Apr 2009  1:47 PM
+"RTN","MSCGUX53",2,0)
+ ;;**MSC**;
+"RTN","MSCGUX53",3,0)
+ I $G(^%ZOSF("OS"))'["GT.M" Q    ;Not GTM
+"RTN","MSCGUX53",4,0)
+ I $P($ZV,"V",2)<5.3 D MESS^XPDUL("GT.M version must be 5.3 or Greater") S XPDABORT=2
+"RTN","MSCGUX53",5,0)
+ 
+"RTN","MSCGUX53",6,0)
+ 
+"RTN","MSCGUX53",7,0)
+ 
+"RTN","MSCXUS3A")
+0^31^B9453784
+"RTN","MSCXUS3A",1,0)
+MSCXUS3A ;SF-ISC/STAFF MSC/JDS,JKT - CHANGE UCI'S ;1DEC2009
+"RTN","MSCXUS3A",2,0)
+ ;;8.0;KERNEL;**13,282,MSC**;Jul 10, 1995
+"RTN","MSCXUS3A",3,0)
+ Q
+"RTN","MSCXUS3A",4,0)
+ ;PICK A UCI TO SWITCH TO
+"RTN","MSCXUS3A",5,0)
+SWITCH ;Allow users that have the UCI fIeld In there NP fIle to swItch UCI's.
+"RTN","MSCXUS3A",6,0)
+ W !!,"Switch UCI's optIon.",!
+"RTN","MSCXUS3A",7,0)
+ ;I $$PROGMODE^%ZOSV() W !,$C(7),"No switching UCI's In Programmer Mode." Q
+"RTN","MSCXUS3A",8,0)
+ N DIR,X,Y,PGM,%UCI,DEF,L,USERNAME
+"RTN","MSCXUS3A",9,0)
+ S DEF="ZU" ;DEF is default routine to swItch to.
+"RTN","MSCXUS3A",10,0)
+UCI Q:'$G(DUZ)  S USERNAME=$P($G(^VA(200,DUZ,0)),U) Q:USERNAME=""
+"RTN","MSCXUS3A",11,0)
+ S DIR(0)="S^"_$$NSP(USERNAME) I DIR(0)'[";" W "YOU AREN'T A USER IN ANY OTHER NAMESPACE" Q
+"RTN","MSCXUS3A",12,0)
+ S DIR("A")="Select NAMESPACE"
+"RTN","MSCXUS3A",13,0)
+ D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) Q
+"RTN","MSCXUS3A",14,0)
+SAME I X="" Q  ;Didn't select anythIng.
+"RTN","MSCXUS3A",15,0)
+ ;D PM
+"RTN","MSCXUS3A",16,0)
+ S (MSCX,X,%UCI)=Y(0) X ^%ZOSF("UCICHECK") I 0[Y G BAD
+"RTN","MSCXUS3A",17,0)
+ I ^%ZOSF("OS")["GT.M" D
+"RTN","MSCXUS3A",18,0)
+ . N %ZG,%ZRO
+"RTN","MSCXUS3A",19,0)
+ . D NEWZGZRO^ZCD(Y(0))
+"RTN","MSCXUS3A",20,0)
+ . S (X,%UCI)=%ZG
+"RTN","MSCXUS3A",21,0)
+ K XQY0 S Y=$O(^[%UCI]VA(200,"B",USERNAME,0))
+"RTN","MSCXUS3A",22,0)
+ I Y S DIR=$P($G(^[%UCI]VA(200,Y,201)),U)
+"RTN","MSCXUS3A",23,0)
+ I DIR,$P($G(^[%UCI]DIC(19,DIR,0)),U,4)="M" S DUZ=Y,XQY=DIR,(DEF,PGM)="M^XQ" G NXT
+"RTN","MSCXUS3A",24,0)
+BAD W !,"UCI not found!" D SHOW G UCI
+"RTN","MSCXUS3A",25,0)
+ ;
+"RTN","MSCXUS3A",26,0)
+NXT ;Here we go.
+"RTN","MSCXUS3A",27,0)
+ D C^XUSCLEAN K ^XUTL("XQ",$J),^XUTL($J),^TMP($J),^UTILITY($J)
+"RTN","MSCXUS3A",28,0)
+ I $G(^%ZOSF("OS"))["GT.M" S A=$$SWITCH^ZCD(MSCX) K ^XUTL("XQ",$J),^UTILITY($J) S ^XUTL("XQ",$J,"T")=0,^("XQM")=XQY,XQTT=0 G @(PGM) Q
+"RTN","MSCXUS3A",29,0)
+ K DA G GO^%MSCXUCI
+"RTN","MSCXUS3A",30,0)
+ ;
+"RTN","MSCXUS3A",31,0)
+ ;
+"RTN","MSCXUS3A",32,0)
+SHOW W ! S I=0,UC="",X=$S($D(^VA(200,DUZ,201)):+^(201),1:0)
+"RTN","MSCXUS3A",33,0)
+ W !,"Enter ^ to return to your current menu, or select from:"
+"RTN","MSCXUS3A",34,0)
+ F I=0:0 S I=$O(^VA(200,DUZ,.2,I)) Q:I'>0  D
+"RTN","MSCXUS3A",35,0)
+ . W !,?5 S UC=$G(^VA(200,DUZ,.2,I,0)),X=$P(UC,U,1),UC=$P(UC,U,2,99)
+"RTN","MSCXUS3A",36,0)
+ . I UC'[":" W I
+"RTN","MSCXUS3A",37,0)
+ . D PM W ?10,X X ^%ZOSF("UCICHECK") I 0[Y W " -- Not currently a valId  UCI!",$C(7) Q
+"RTN","MSCXUS3A",38,0)
+ . W:UC]"" ":"_UC
+"RTN","MSCXUS3A",39,0)
+ . Q
+"RTN","MSCXUS3A",40,0)
+ Q
+"RTN","MSCXUS3A",41,0)
+ ;
+"RTN","MSCXUS3A",42,0)
+PM I X="PROD"!(X="MGR") S X=^%ZOSF(X)
+"RTN","MSCXUS3A",43,0)
+ Q
+"RTN","MSCXUS3A",44,0)
+ ;
+"RTN","MSCXUS3A",45,0)
+ ;
+"RTN","MSCXUS3A",46,0)
+ ;
+"RTN","MSCXUS3A",47,0)
+NSP(USERNAME) ;LIST OTHER NAMESPACES WHERE THIS USER IS
+"RTN","MSCXUS3A",48,0)
+ N X,L,I,Y
+"RTN","MSCXUS3A",49,0)
+ X ^%ZOSF("UCI") S Y=$P(Y,",") I ^%ZOSF("OS")["GT.M" Q $$GTMNSP
+"RTN","MSCXUS3A",50,0)
+ X "F I=1:1:$zu(90,0) s L($zu(90,2,0,I))=""""" ;***CACHE-SPECIFIC   FROM %NSP
+"RTN","MSCXUS3A",51,0)
+ S (I,L,X)="" F  S I=$O(L(I)) Q:I=""  I I'=Y D  ;NOT THE CURRENT ONE
+"RTN","MSCXUS3A",52,0)
+ .N DUZ S DUZ=$O(^[I]VA(200,"B",USERNAME,0)) Q:'DUZ
+"RTN","MSCXUS3A",53,0)
+ .I $P($G(^[I]VA(200,DUZ,0)),U,3)=""!'$G(^(201)) Q  ;THEY MUST HAVE ACCESS CODE AND PRIMARY MENU OPTION OVER THERE
+"RTN","MSCXUS3A",54,0)
+ .S L=L+1,X=X_L_":"_I_";"
+"RTN","MSCXUS3A",55,0)
+ Q X
+"RTN","MSCXUS3A",56,0)
+GTMNSP() ;
+"RTN","MSCXUS3A",57,0)
+ N CURRENT S CURRENT=Y N Y
+"RTN","MSCXUS3A",58,0)
+ D LIST^ZCD
+"RTN","MSCXUS3A",59,0)
+ S (I,L,X)="" F  S I=$O(Y(I)) Q:'I  S A=Y(I) I A'=CURRENT D  ;NOT THE CURRENT ONE
+"RTN","MSCXUS3A",60,0)
+ .S A=$P($ZG,"/"_$$CURRENT^ZCD_"/")_"/"_A_"/"_$P($ZG,"/"_$$CURRENT^ZCD_"/",2)
+"RTN","MSCXUS3A",61,0)
+ .N DUZ S DUZ=$O(^[A]VA(200,"B",USERNAME,0)) Q:'DUZ
+"RTN","MSCXUS3A",62,0)
+ .I $P($G(^[A]VA(200,DUZ,0)),U,3)=""!'$G(^(201)) Q  ;THEY MUST HAVE ACCESS CODE AND PRIMARY MENU OPTION OVER THERE
+"RTN","MSCXUS3A",63,0)
+ .S L=L+1,X=X_L_":"_Y(I)_";"
+"RTN","MSCXUS3A",64,0)
+ Q X
+"RTN","MSCZJOB")
+0^1^B12965530
+"RTN","MSCZJOB",1,0)
+MSCZJOB ;GFT,JDS,JKT/MSC;29OCT2009
+"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 K ^TMP("MSCZJOB1",$J) 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,N S R=$G(@MSC@(MSCJOBID,"L",D0)) I R'["^" Q  ;CAN'T SEE IT
+"RTN","MSCZJOB",11,0)
+ S R=$P(R," ",2),X="L "_R D ^DIM Q:'$D(X)
+"RTN","MSCZJOB",12,0)
+ S N=$$NSP(MSCJOBD0)
+"RTN","MSCZJOB",13,0)
+ D UNLOCK^MSCZJOBU(R,N)
+"RTN","MSCZJOB",14,0)
+ Q
+"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)
+COMPMUL ;COMPUTED MULTIPLE FOR MSCZJOBEXAM BLOCK
+"RTN","MSCZJOB",21,0)
+ N X,D0,J
+"RTN","MSCZJOB",22,0)
+ S MSC="^TMP(""MSCZJOB1"",$J)" D POLL
+"RTN","MSCZJOB",23,0)
+ D JOBEXAM^MSCZJOBU(MSC)
+"RTN","MSCZJOB",24,0)
+ F D0=0:0 S D0=$O(MSCZJOB(D0)) Q:'D0  D
+"RTN","MSCZJOB",25,0)
+ .S MSCZJOB(D0)=MSCZJOB(D0)_U_$$DEV(D0)_U_$$USER(D0)_U_$$NSP(D0)_U_U_U_U_U_$$ROUTINE(D0)
+"RTN","MSCZJOB",26,0)
+ .S X=MSCZJOB(D0) X DICMX
+"RTN","MSCZJOB",27,0)
+ Q
+"RTN","MSCZJOB",28,0)
+JOB(D0) Q $P(MSCZJOB(D0),U) ;***
+"RTN","MSCZJOB",29,0)
+DEV(D0) Q $$FIND(D0,"I","$PRINCIPAL")
+"RTN","MSCZJOB",30,0)
+NSP(D0) N N D  Q N
+"RTN","MSCZJOB",31,0)
+ .N L,P S N=$$FIND(D0,"I","$ZGBLDIR"),L=$L(N,"/") I L<2 Q
+"RTN","MSCZJOB",32,0)
+ .F L=L-1:-1:2 S P=$P(N,"/",L) I P'[".",P'["globals" Q
+"RTN","MSCZJOB",33,0)
+ .S P=1 I $P(N,"/")="" S P=2
+"RTN","MSCZJOB",34,0)
+ .S N=$P(N,"/",L)
+"RTN","MSCZJOB",35,0)
+USER(D0) Q $P($G(^VA(200,+$$FIND(D0,"V","DUZ"),0)),U)
+"RTN","MSCZJOB",36,0)
+ROUTINE(D0) Q $$FIND(D0,"V","%ZPOS")
+"RTN","MSCZJOB",37,0)
+ ;
+"RTN","MSCZJOB",38,0)
+FIND(D0,ARR,KEY) N I,J,X S X="",J=+MSCZJOB(D0)
+"RTN","MSCZJOB",39,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",40,0)
+ Q X
+"RTN","MSCZJOB",41,0)
+ ;
+"RTN","MSCZJOB",42,0)
+COMPSTK ;COMPUTED MULTIPLE FOR MSCZJOBSTACK BLOCK
+"RTN","MSCZJOB",43,0)
+ S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC@(MSCJOBID) D POLL1
+"RTN","MSCZJOB",44,0)
+ D JOBEXAM^MSCZJOBU(MSC,MSCJOBID)
+"RTN","MSCZJOB",45,0)
+ N D0,J S J=MSCJOBID
+"RTN","MSCZJOB",46,0)
+ F D0=1:1:$O(@MSC@(J,"S",""),-1)  S X="" X DICMX
+"RTN","MSCZJOB",47,0)
+ Q
+"RTN","MSCZJOB",48,0)
+ ;
+"RTN","MSCZJOB",49,0)
+STACK(D0) N X S X=$G(@MSC@(MSCJOBID,"S",D0))
+"RTN","MSCZJOB",50,0)
+ Q X
+"RTN","MSCZJOB",51,0)
+ ;
+"RTN","MSCZJOB",52,0)
+COMPVARS ;COMPUTED MULTIPLE FOR MSCZJOBVARS BLOCK
+"RTN","MSCZJOB",53,0)
+ S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC@(MSCJOBID) D POLL1
+"RTN","MSCZJOB",54,0)
+ D JOBEXAM^MSCZJOBU(MSC,MSCJOBID)
+"RTN","MSCZJOB",55,0)
+ N D0,J S J=MSCJOBID
+"RTN","MSCZJOB",56,0)
+ F D0=1:1:$O(@MSC@(J,"V",""),-1)  S X="" X DICMX
+"RTN","MSCZJOB",57,0)
+ Q
+"RTN","MSCZJOB",58,0)
+ ;
+"RTN","MSCZJOB",59,0)
+COMPLKS ;COMPUTED MULTIPLE FOR MSCZJOBLOCKS BLOCK
+"RTN","MSCZJOB",60,0)
+ S MSC="^TMP(""MSCZJOB1"",$J)" D POLL1
+"RTN","MSCZJOB",61,0)
+ D JOBEXAM^MSCZJOBU(MSC,MSCJOBID)
+"RTN","MSCZJOB",62,0)
+ N D0
+"RTN","MSCZJOB",63,0)
+ F D0=1:1:$$LOCKS  S X="" X DICMX
+"RTN","MSCZJOB",64,0)
+ Q
+"RTN","MSCZJOB",65,0)
+ ;
+"RTN","MSCZJOB",66,0)
+LOCKS() Q +$O(@MSC@(MSCJOBID,"L",""),-1)
+"RTN","MSCZJOB",67,0)
+ ;
+"RTN","MSCZJOB",68,0)
+POLL K MSCZJOB ;D HLP^DDSUTL("   POLLING JOBS.....") 
+"RTN","MSCZJOB",69,0)
+ I $G(^%ZOSF("OS"))["GT.M" D
+"RTN","MSCZJOB",70,0)
+ .K @MSC
+"RTN","MSCZJOB",71,0)
+ .D INTRPT^MSCZJOBU("*") ;SETS UP ^TMP
+"RTN","MSCZJOB",72,0)
+ .N MSCA,I D PIDS^MSCZJOBU(.MSCA)
+"RTN","MSCZJOB",73,0)
+ .S MSCA="" F I=1:1 S MSCA=$O(MSCA(MSCA)) Q:'MSCA  S MSCZJOB(I)=MSCA ;SETS UP LOCAL ARRAY
+"RTN","MSCZJOB",74,0)
+ .H 1 ;WAIT FOR POLLING
+"RTN","MSCZJOB",75,0)
+ D TEST
+"RTN","MSCZJOB",76,0)
+ Q
+"RTN","MSCZJOB",77,0)
+ ;
+"RTN","MSCZJOB",78,0)
+POLL1 Q:'$G(MSCJOBID)
+"RTN","MSCZJOB",79,0)
+ I $G(^%ZOSF("OS"))["GT.M" D
+"RTN","MSCZJOB",80,0)
+ .K @MSC@(MSCJOBID)
+"RTN","MSCZJOB",81,0)
+ .D INTRPT^MSCZJOBU(MSCJOBID) ;SETS UP ^TMP(MSCZJOB)
+"RTN","MSCZJOB",82,0)
+ .H 1 ;WAIT FOR POLLING
+"RTN","MSCZJOB",83,0)
+ D TEST
+"RTN","MSCZJOB",84,0)
+ Q
+"RTN","MSCZJOB",85,0)
+ ;
+"RTN","MSCZJOB",86,0)
+TEST Q
+"RTN","MSCZJOB",87,0)
+COMPLK ;COMPUTED MULTIPLE FOR MSCZLOCK BLOCK
+"RTN","MSCZJOB",88,0)
+ N X,D0,J
+"RTN","MSCZJOB",89,0)
+ S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC D POLL,JOBEXAM^MSCZJOBU(MSC) S D0=0
+"RTN","MSCZJOB",90,0)
+ F K=0:0 S K=$O(MSCZJOB(K)) Q:'K  D
+"RTN","MSCZJOB",91,0)
+ .F J=0:0 S J=$O(^TMP("MSCZJOB1",$J,MSCZJOB(K),"L",J)) Q:'J  S A=$TR(^(J),U,"~") D
+"RTN","MSCZJOB",92,0)
+ ..S D0=D0+1,MSCZLK(D0)=$P(A,"LOCK ",2,9)_U_$$USER(K)_U_$TR($$ROUTINE(K),U,"~")_"^^"_MSCZJOB(K)
+"RTN","MSCZJOB",93,0)
+ ..S X=MSCZLK(D0) X DICMX
+"RTN","MSCZJOB",94,0)
+ Q
+"RTN","MSCZJOB",95,0)
+LOCK ;
+"RTN","MSCZJOB",96,0)
+ S DDSFILE=3.081,DR="[MSCZLOCK]",DDSPARM="S"
+"RTN","MSCZJOB",97,0)
+ D ^DDS Q
+"RTN","MSCZJOB",98,0)
+UNL(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
+"RTN","MSCZJOB",99,0)
+ N X,R,N S R=$P($G(MSCZLK(D0)),U),P=$P($G(MSCZLK(D0)),U,5) ;I R'["^" Q  ;CAN'T SEE IT
+"RTN","MSCZJOB",100,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",101,0)
+ S N=$$NSP(D0)
+"RTN","MSCZJOB",102,0)
+ D UNLOCK^MSCZJOBU(R,N)
+"RTN","MSCZJOBS")
+0^46^B5731054
+"RTN","MSCZJOBS",1,0)
+MSCZJOBS ;JKT/MSC - OpenVista System status ;24AUG2009
+"RTN","MSCZJOBS",2,0)
+ ;;8.0;KERNEL;**MSC**
+"RTN","MSCZJOBS",3,0)
+ ;
+"RTN","MSCZJOBS",4,0)
+ALL D SS() Q
+"RTN","MSCZJOBS",5,0)
+THIS D SS(1) Q
+"RTN","MSCZJOBS",6,0)
+ ;
+"RTN","MSCZJOBS",7,0)
+SS(THIS) ;Print GT.M mumps processes
+"RTN","MSCZJOBS",8,0)
+ ; If THIS is true, only print processes associated with the current
+"RTN","MSCZJOBS",9,0)
+ ; OpenVista instance
+"RTN","MSCZJOBS",10,0)
+ ;
+"RTN","MSCZJOBS",11,0)
+ Q:$G(^%ZOSF("OS"))'["GT.M"
+"RTN","MSCZJOBS",12,0)
+ ;
+"RTN","MSCZJOBS",13,0)
+ D INTRPT^MSCZJOBU("*") H .5
+"RTN","MSCZJOBS",14,0)
+ ;
+"RTN","MSCZJOBS",15,0)
+ N DATETIME S DATETIME=$$HTE^XLFDT($H)
+"RTN","MSCZJOBS",16,0)
+ W #!,?28,"OpenVista System Status"
+"RTN","MSCZJOBS",17,0)
+ W !,?(40-($L(DATETIME)/2)\1),DATETIME
+"RTN","MSCZJOBS",18,0)
+ W !!,?1,"PID/$J",?9,"%CPU",?15,"Device",?32,"Instance",?42,"Routine",?52,"User",?66,"Identity"
+"RTN","MSCZJOBS",19,0)
+ ;
+"RTN","MSCZJOBS",20,0)
+ N MSC S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC
+"RTN","MSCZJOBS",21,0)
+ D JOBEXAM^MSCZJOBU(MSC)
+"RTN","MSCZJOBS",22,0)
+ N PID S PID=""
+"RTN","MSCZJOBS",23,0)
+ F  S PID=$O(@MSC@(PID)) Q:PID=""  D
+"RTN","MSCZJOBS",24,0)
+ . I $G(THIS) Q:$$INSTANCE(PID)'=$$CURRENT^ZCD()
+"RTN","MSCZJOBS",25,0)
+ . W !,$$PID(PID)
+"RTN","MSCZJOBS",26,0)
+ . W ?9,$$PCPU(PID)
+"RTN","MSCZJOBS",27,0)
+ . W ?15,$$DEVICE(PID)
+"RTN","MSCZJOBS",28,0)
+ . W ?32,$$INSTANCE(PID)
+"RTN","MSCZJOBS",29,0)
+ . W ?42,$$ROUTINE(PID)
+"RTN","MSCZJOBS",30,0)
+ . W ?52,$$USER(PID)
+"RTN","MSCZJOBS",31,0)
+ . W ?66,$$IDENT(PID)
+"RTN","MSCZJOBS",32,0)
+ K @MSC
+"RTN","MSCZJOBS",33,0)
+ ;
+"RTN","MSCZJOBS",34,0)
+ W !! ZSY "uptime"
+"RTN","MSCZJOBS",35,0)
+ Q
+"RTN","MSCZJOBS",36,0)
+ ;
+"RTN","MSCZJOBS",37,0)
+PID(PID) ;Return process ID formatted for display
+"RTN","MSCZJOBS",38,0)
+ Q $J(PID,7)_$S($J=PID:"*",1:"")
+"RTN","MSCZJOBS",39,0)
+ ;
+"RTN","MSCZJOBS",40,0)
+PCPU(PID) ;Return CPU usage
+"RTN","MSCZJOBS",41,0)
+ Q $J($G(@MSC@(PID,"PCPU")),4)
+"RTN","MSCZJOBS",42,0)
+ ;
+"RTN","MSCZJOBS",43,0)
+DEVICE(PID) ;Return device
+"RTN","MSCZJOBS",44,0)
+ N PRI S PRI=$$FIND(PID,"I","$PRINCIPAL")
+"RTN","MSCZJOBS",45,0)
+ Q:PRI'="0" PRI ; FIXME: this could probably be more general
+"RTN","MSCZJOBS",46,0)
+ ;
+"RTN","MSCZJOBS",47,0)
+ ; look at devices for sockets
+"RTN","MSCZJOBS",48,0)
+ N SOCK S SOCK=$$FIND(PID,"D","        SOCKET[0]")
+"RTN","MSCZJOBS",49,0)
+ I $P(SOCK," ",3)="LISTENING" Q $P($P(SOCK," PORT=",2)," ")_",LISTENING"
+"RTN","MSCZJOBS",50,0)
+ I $P(SOCK," ",3)="CONNECTED" Q $P($P($P(SOCK," LOCAL=",2)," "),"@",2)_",CONNECTED"
+"RTN","MSCZJOBS",51,0)
+ Q ""
+"RTN","MSCZJOBS",52,0)
+ ;
+"RTN","MSCZJOBS",53,0)
+INSTANCE(PID) ;Return name of OpenVista instance
+"RTN","MSCZJOBS",54,0)
+ N ZG S ZG=$$FIND(PID,"I","$ZGBLDIR")
+"RTN","MSCZJOBS",55,0)
+ Q $P(ZG,"/",$L(ZG,"/")-2)
+"RTN","MSCZJOBS",56,0)
+ ;
+"RTN","MSCZJOBS",57,0)
+ROUTINE(PID) ;Return routine
+"RTN","MSCZJOBS",58,0)
+ Q $P($$FIND(PID,"V","%ZPOS"),"^",2)
+"RTN","MSCZJOBS",59,0)
+ ;
+"RTN","MSCZJOBS",60,0)
+USER(PID) ;Return Linux user
+"RTN","MSCZJOBS",61,0)
+ Q $G(@MSC@(PID,"USER"))
+"RTN","MSCZJOBS",62,0)
+ ;
+"RTN","MSCZJOBS",63,0)
+IDENT(PID) ;Return OpenVista user
+"RTN","MSCZJOBS",64,0)
+ N DUZ S DUZ=+$$FIND(PID,"V","DUZ")
+"RTN","MSCZJOBS",65,0)
+ N ZG S ZG=$$FIND(PID,"I","$ZGBLDIR")
+"RTN","MSCZJOBS",66,0)
+ Q $P($G(^|ZG|VA(200,DUZ,0)),"^")
+"RTN","MSCZJOBS",67,0)
+ ;
+"RTN","MSCZJOBS",68,0)
+FIND(PID,ARR,KEY) ;Return the value of a key in one of the ZSHOW arrays
+"RTN","MSCZJOBS",69,0)
+ N I,X S I="",X=""
+"RTN","MSCZJOBS",70,0)
+ F  S I=$O(@MSC@(PID,ARR,I)) Q:'I  I $P(@MSC@(PID,ARR,I),KEY_"=")="" S X=$TR($P(@MSC@(PID,ARR,I),"=",2,999),"""") Q
+"RTN","MSCZJOBS",71,0)
+ Q X
+"RTN","MSCZJOBU")
+0^4^B9589351
+"RTN","MSCZJOBU",1,0)
+MSCZJOBU ;RHL,JDS,JKT/MSC;29OCT2009
+"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 DEV
+"RTN","MSCZJOBU",12,0)
+ S DEV="psdev"
+"RTN","MSCZJOBU",13,0)
+ OPEN DEV:(COMM="ps -o pid=,pcpu=,user= -C mumps":READONLY)::"PIPE"
+"RTN","MSCZJOBU",14,0)
+ N %I S %I=$I
+"RTN","MSCZJOBU",15,0)
+ U DEV
+"RTN","MSCZJOBU",16,0)
+ ;
+"RTN","MSCZJOBU",17,0)
+ N LINE,PID,PCPU,USER
+"RTN","MSCZJOBU",18,0)
+ F  R LINE Q:LINE=""  D
+"RTN","MSCZJOBU",19,0)
+ . S PID=$E(LINE,1,5) F  Q:$E(PID,1)'=" "  S PID=$E(PID,2,999) ; strip leading spaces
+"RTN","MSCZJOBU",20,0)
+ . S PCPU=$E(LINE,6,10) F  Q:$E(PCPU,1)'=" "  S PCPU=$E(PCPU,2,999) ; strip leading spaces
+"RTN","MSCZJOBU",21,0)
+ . S USER=$E(LINE,12,999)
+"RTN","MSCZJOBU",22,0)
+ . S XARY(PID)=""
+"RTN","MSCZJOBU",23,0)
+ . S XARY(PID,"PCPU")=PCPU
+"RTN","MSCZJOBU",24,0)
+ . S XARY(PID,"USER")=USER
+"RTN","MSCZJOBU",25,0)
+ ;
+"RTN","MSCZJOBU",26,0)
+ U %I
+"RTN","MSCZJOBU",27,0)
+ C DEV
+"RTN","MSCZJOBU",28,0)
+ Q
+"RTN","MSCZJOBU",29,0)
+ ;
+"RTN","MSCZJOBU",30,0)
+JOBEXAM(XARY,ONEPID) ; GET ARRAY OF JOB EXAM DATA FOR ALL MUMPS PROCESSES
+"RTN","MSCZJOBU",31,0)
+ ;  XARY is the name of a variable (or global) to merge job exam data into
+"RTN","MSCZJOBU",32,0)
+ ;
+"RTN","MSCZJOBU",33,0)
+ ; get a list of all OpenVista instances and look up their $ZG values
+"RTN","MSCZJOBU",34,0)
+ N Y D LIST^ZCD
+"RTN","MSCZJOBU",35,0)
+ N INSTANCE S INSTANCE=""
+"RTN","MSCZJOBU",36,0)
+ F  S INSTANCE=$O(Y("B",INSTANCE)) Q:INSTANCE=""  D
+"RTN","MSCZJOBU",37,0)
+ . N %ZG,%ZRO D NEWZGZRO^ZCD(INSTANCE)
+"RTN","MSCZJOBU",38,0)
+ . S Y("B",INSTANCE)=%ZG
+"RTN","MSCZJOBU",39,0)
+ ;
+"RTN","MSCZJOBU",40,0)
+ ; get a list of all mumps processes
+"RTN","MSCZJOBU",41,0)
+ N PIDS D PIDS(.PIDS)
+"RTN","MSCZJOBU",42,0)
+ N PID S PID=""
+"RTN","MSCZJOBU",43,0)
+ ;
+"RTN","MSCZJOBU",44,0)
+ ; clean up data in ^TMP("MSCZJOB") for processes that no longer exist
+"RTN","MSCZJOBU",45,0)
+ F  S INSTANCE=$O(Y("B",INSTANCE)) Q:INSTANCE=""  D
+"RTN","MSCZJOBU",46,0)
+ . F  S PID=$O(^|Y("B",INSTANCE)|TMP("MSCZJOB",PID)) Q:PID=""  D
+"RTN","MSCZJOBU",47,0)
+ . . I '$D(PIDS(PID)) K ^|Y("B",INSTANCE)|TMP("MSCZJOB",PID)
+"RTN","MSCZJOBU",48,0)
+ ;
+"RTN","MSCZJOBU",49,0)
+ ; consolidate data from ^TMP("MSCZJOB") into XARY
+"RTN","MSCZJOBU",50,0)
+ I $G(ONEPID) D GETJOB(ONEPID) Q
+"RTN","MSCZJOBU",51,0)
+ F  S PID=$O(PIDS(PID)) Q:PID=""  D GETJOB(PID)
+"RTN","MSCZJOBU",52,0)
+ Q
+"RTN","MSCZJOBU",53,0)
+GETJOB(PID) ; private, to be called from JOBEXAM only
+"RTN","MSCZJOBU",54,0)
+ ; search each OpenVista instance for the latest job exam data 
+"RTN","MSCZJOBU",55,0)
+ ; for PID and merge it into XARY
+"RTN","MSCZJOBU",56,0)
+ N SORTDATE
+"RTN","MSCZJOBU",57,0)
+ F  S INSTANCE=$O(Y("B",INSTANCE)) Q:INSTANCE=""  D
+"RTN","MSCZJOBU",58,0)
+ . N H S H=$G(^|Y("B",INSTANCE)|TMP("MSCZJOB",PID,0)) Q:H=""
+"RTN","MSCZJOBU",59,0)
+ . S SORTDATE($$SEC^XLFDT(H))=INSTANCE
+"RTN","MSCZJOBU",60,0)
+ N MAXDATE S MAXDATE=$O(SORTDATE(""),-1) Q:MAXDATE=""
+"RTN","MSCZJOBU",61,0)
+ M @XARY@(PID)=^|Y("B",SORTDATE(MAXDATE))|TMP("MSCZJOB",PID)
+"RTN","MSCZJOBU",62,0)
+ S @XARY@(PID,"PCPU")=PIDS(PID,"PCPU")
+"RTN","MSCZJOBU",63,0)
+ S @XARY@(PID,"USER")=PIDS(PID,"USER")
+"RTN","MSCZJOBU",64,0)
+ Q
+"RTN","MSCZJOBU",65,0)
+ ;
+"RTN","MSCZJOBU",66,0)
+INTRPT(PID) ; SEND mupip intrpt to process with PID
+"RTN","MSCZJOBU",67,0)
+ ;  WHICH CAUSES THE $ZINTERRUPT CODE TO BE EXECUTED.
+"RTN","MSCZJOBU",68,0)
+ ;  PID PASSED BY VALUE
+"RTN","MSCZJOBU",69,0)
+ ;  PID CAN BE A SINGLE PID, I.E. $J
+"RTN","MSCZJOBU",70,0)
+ ;  PID CAN BE A "*" WHICH SENDS AN INTERRUPT TO ALL MUMPS PROCESSES
+"RTN","MSCZJOBU",71,0)
+ ;
+"RTN","MSCZJOBU",72,0)
+ Q:$G(PID)'?1N.N&($G(PID)'="*")
+"RTN","MSCZJOBU",73,0)
+ ;
+"RTN","MSCZJOBU",74,0)
+ N CMD,DEV
+"RTN","MSCZJOBU",75,0)
+ S CMD="gtmsignal -q "_$S(PID="*":"-a",1:PID)
+"RTN","MSCZJOBU",76,0)
+ S DEV="gtmsignaldev"
+"RTN","MSCZJOBU",77,0)
+ OPEN DEV:(COMM=CMD:READONLY)::"PIPE" U DEV C DEV
+"RTN","MSCZJOBU",78,0)
+ Q
+"RTN","MSCZJOBU",79,0)
+ ;
+"RTN","MSCZJOBU",80,0)
+KILL(PID) ; Send mupip stop to process with PID
+"RTN","MSCZJOBU",81,0)
+ ;  PID PASSED BY VALUE
+"RTN","MSCZJOBU",82,0)
+ ;  PID CAN BE A SINGLE PID, I.E. $J
+"RTN","MSCZJOBU",83,0)
+ ;
+"RTN","MSCZJOBU",84,0)
+ Q:$G(PID)'?1N.N
+"RTN","MSCZJOBU",85,0)
+ ;
+"RTN","MSCZJOBU",86,0)
+ N DEV
+"RTN","MSCZJOBU",87,0)
+ S DEV="gtmsignaldev"
+"RTN","MSCZJOBU",88,0)
+ OPEN DEV:(COMM="gtmsignal -q -s "_PID:READONLY)::"PIPE" U DEV C DEV
+"RTN","MSCZJOBU",89,0)
+ Q
+"RTN","MSCZJOBU",90,0)
+ ;
+"RTN","MSCZJOBU",91,0)
+UNLOCK(NODE,INSTANCE) ; Use lke to remove lock on NODE.
+"RTN","MSCZJOBU",92,0)
+ N %ZG,%ZRO
+"RTN","MSCZJOBU",93,0)
+ D:$G(INSTANCE)'="" NEWZGZRO^ZCD(INSTANCE)
+"RTN","MSCZJOBU",94,0)
+ N CMD,DEV
+"RTN","MSCZJOBU",95,0)
+ S CMD="lke clear -lock="""_NODE_""" -nointeractive -output=/dev/null"
+"RTN","MSCZJOBU",96,0)
+ S:$G(%ZG)'="" CMD="gtmgbldir="""_%ZG_""" "_CMD
+"RTN","MSCZJOBU",97,0)
+ S DEV="lkedev"
+"RTN","MSCZJOBU",98,0)
+ OPEN DEV:(SHELL="/bin/sh":COMM=CMD:READONLY)::"PIPE" U DEV C DEV
+"RTN","MSCZJOBU",99,0)
+ Q
+"RTN","PRCSEA")
+0^37^B66865498
+"RTN","PRCSEA",1,0)
+PRCSEA ;WISC/SAW/DXH/BM/SC/DAP,MSC/JDA - CONTROL POINT ACTIVITY EDITS ;27APR2009
+"RTN","PRCSEA",2,0)
+V ;;5.1;IFCAP;**81,MSC**;Oct 20, 2000
+"RTN","PRCSEA",3,0)
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
+"RTN","PRCSEA",4,0)
+ ;
+"RTN","PRCSEA",5,0)
+ ;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code 
+"RTN","PRCSEA",6,0)
+ ;to update Audit file (#414.02), and send update message to 
+"RTN","PRCSEA",7,0)
+ ;DynaMed thru a call to rtn PRCVTCA.
+"RTN","PRCSEA",8,0)
+ ;
+"RTN","PRCSEA",9,0)
+ENRS ;ENTER REQ
+"RTN","PRCSEA",10,0)
+ S PRCSK=1,X3="H"
+"RTN","PRCSEA",11,0)
+ D EN1F^PRCSUT(1) ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197
+"RTN","PRCSEA",12,0)
+ G W2:'$D(PRC("SITE")),EXIT:Y<0 ; unauthorized user or '^' entered
+"RTN","PRCSEA",13,0)
+ D W6 ; display help on transaction# format
+"RTN","PRCSEA",14,0)
+ENRS0 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="AELQ",D="H"
+"RTN","PRCSEA",15,0)
+ S DIC("A")="Select TRANSACTION: "
+"RTN","PRCSEA",16,0)
+ S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$D(^PRCS(410,""H"",$P(^(0),U,3),+Y)),^(+Y)=DUZ!(^(+Y)="""")" ; only requests authored by user or unauthored will display on partial match
+"RTN","PRCSEA",17,0)
+ D ^PRCSDIC ; lookup & preliminary validity checking
+"RTN","PRCSEA",18,0)
+ K DLAYGO,DIC("A"),DIC("S")
+"RTN","PRCSEA",19,0)
+ G:Y<0 EXIT
+"RTN","PRCSEA",20,0)
+ I $P(Y,U,3)'=1 W $C(7),"   Must be a new entry." G ENRS0
+"RTN","PRCSEA",21,0)
+ ;*81 Check site parameter to see if issue books are allowed
+"RTN","PRCSEA",22,0)
+ D CKPRM^PRCSEB
+"RTN","PRCSEA",23,0)
+ W !!,PRCVY,!
+"RTN","PRCSEA",24,0)
+ S (PDA,T1,DA)=+Y
+"RTN","PRCSEA",25,0)
+ L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...try a different transaction number or try later" G ENRS0
+"RTN","PRCSEA",26,0)
+ S T(2)=$P(Y,U,2)
+"RTN","PRCSEA",27,0)
+ D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data in new txn (nodes 0,3,6,11 of file 410)
+"RTN","PRCSEA",28,0)
+ S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by)
+"RTN","PRCSEA",29,0)
+ S $P(^PRCS(410,DA,7),"^")=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) ; requestor default
+"RTN","PRCSEA",30,0)
+ I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP,^PRCS(410,"AO",PRCSIP,DA)="" ; PRCSIP was set up in PRCSUT & is inventory distribution point
+"RTN","PRCSEA",31,0)
+ S PRCS="" ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM
+"RTN","PRCSEA",32,0)
+ I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1
+"RTN","PRCSEA",33,0)
+TYPE ;
+"RTN","PRCSEA",34,0)
+ W !!,"This transaction is assigned temporary transaction number: ",T(2)
+"RTN","PRCSEA",35,0)
+ S DIC("A")="FORM TYPE: ",DIC="^PRCS(410.5,",DIC(0)="AEQZ"
+"RTN","PRCSEA",36,0)
+ S DIC("S")=PRCVX ; only allow selection of 2237's
+"RTN","PRCSEA",37,0)
+ D ^DIC
+"RTN","PRCSEA",38,0)
+ S DA=PDA
+"RTN","PRCSEA",39,0)
+ ;if user didn't enter a form type, go ask whether to backout and act
+"RTN","PRCSEA",40,0)
+ ;accordingly: go let them re-enter a form type or exit
+"RTN","PRCSEA",41,0)
+ I Y<0 G:'$$BACKOUT(T(2),DA) TYPE L -^PRCS(420,DA) G EXIT
+"RTN","PRCSEA",42,0)
+ ;
+"RTN","PRCSEA",43,0)
+ I Y<2 W "??" G TYPE
+"RTN","PRCSEA",44,0)
+ K PRCVX,PRCVY
+"RTN","PRCSEA",45,0)
+ S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y ; form type
+"RTN","PRCSEA",46,0)
+ ; if CP is not automated (file 420), user's response will be overwritten with non-recuring (type 2). Although user's selection is changed 'behind the scenes', 
+"RTN","PRCSEA",47,0)
+ ; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated.
+"RTN","PRCSEA",48,0)
+ S:'PRCS&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2
+"RTN","PRCSEA",49,0)
+ K PRCSERR ; flag denoting item info is missing
+"RTN","PRCSEA",50,0)
+ S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
+"RTN","PRCSEA",51,0)
+ S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
+"RTN","PRCSEA",52,0)
+EN1 K DTOUT,DUOUT,Y
+"RTN","PRCSEA",53,0)
+ D ^DIE
+"RTN","PRCSEA",54,0)
+ S DA=PDA
+"RTN","PRCSEA",55,0)
+ I $D(Y)!($D(DTOUT)) D DOR L -^PRCS(410,DA) G EXIT
+"RTN","PRCSEA",56,0)
+ D RL^PRCSUT1 ; sets up 'IT' & '10' nodes
+"RTN","PRCSEA",57,0)
+ D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 ; missing required field ('item')
+"RTN","PRCSEA",58,0)
+ D DOR ; populate date of request field if it is nil
+"RTN","PRCSEA",59,0)
+ L -^PRCS(410,DA)
+"RTN","PRCSEA",60,0)
+ S T="enter" D W5 G EXIT:%'=1
+"RTN","PRCSEA",61,0)
+ W !! K PRCS("SUB")
+"RTN","PRCSEA",62,0)
+ G ENRS
+"RTN","PRCSEA",63,0)
+ ;
+"RTN","PRCSEA",64,0)
+EDRS ;EDIT REQ
+"RTN","PRCSEA",65,0)
+ ; following line commented out by PRC*5*140 - user responses not used to limit selection of txn and sometimes resulted in bad info being set into the selected txn
+"RTN","PRCSEA",66,0)
+ ; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197
+"RTN","PRCSEA",67,0)
+ ; if the above line is reactivated, programmer should note that the transaction selected may not be of the same FY,QRTR,sta, subst, and CP specified by the user
+"RTN","PRCSEA",68,0)
+ D W6 ; format doc for txn#
+"RTN","PRCSEA",69,0)
+ S X3="H" S DIC="^PRCS(410,",DIC(0)="AEQ",D="H"
+"RTN","PRCSEA",70,0)
+ S DIC("A")="Select TRANSACTION: "
+"RTN","PRCSEA",71,0)
+ S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$P(^(0),U,4)'=1,^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or unauthored & cannot be a 1358
+"RTN","PRCSEA",72,0)
+ D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S")
+"RTN","PRCSEA",73,0)
+ S (PDA,DA,T1)=+Y
+"RTN","PRCSEA",74,0)
+ L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G EDRS
+"RTN","PRCSEA",75,0)
+ ; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option
+"RTN","PRCSEA",76,0)
+ ; D EN2B^PRCSUT3
+"RTN","PRCSEA",77,0)
+ S PRC("SITE")=+$P(^PRCS(410,PDA,0),"^",5)
+"RTN","PRCSEA",78,0)
+ S PRC("CP")=$P(^PRCS(410,PDA,3),"^")
+"RTN","PRCSEA",79,0)
+ I $P(^PRCS(410,PDA,0),"^",6)="" D  ; prc*5*197
+"RTN","PRCSEA",80,0)
+ . N PRCSIP D IP^PRCSUT
+"RTN","PRCSEA",81,0)
+ . I $D(PRCSIP) S $P(^PRC(410,DA,0),U,6)=PRCSIP
+"RTN","PRCSEA",82,0)
+ S X=+$P(^PRCS(410,DA,0),"^",4) I X<1 D FORM
+"RTN","PRCSEA",83,0)
+ ;*81 Check site parameter to see if Issue Books are allowed
+"RTN","PRCSEA",84,0)
+ D CKPRM
+"RTN","PRCSEA",85,0)
+ I PRCVD=1 S PRCVZ=1
+"RTN","PRCSEA",86,0)
+ I PRCVD'=1 S PRCVZ=0
+"RTN","PRCSEA",87,0)
+ W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),!
+"RTN","PRCSEA",88,0)
+ I PRCVZ=1,X=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP issue book order." S T="edit" D W5 G:%'=1 EXIT W !! K PRCS("SUB") G EDRS
+"RTN","PRCSEA",89,0)
+ ;
+"RTN","PRCSEA",90,0)
+ S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
+"RTN","PRCSEA",91,0)
+ ;P182--Modified next 3 lines to use new templates if supply fund FCP
+"RTN","PRCSEA",92,0)
+ S (DR,PRCSDR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
+"RTN","PRCSEA",93,0)
+ED1 K DTOUT,DUOUT,Y
+"RTN","PRCSEA",94,0)
+ D ^DIE
+"RTN","PRCSEA",95,0)
+ S DA=PDA
+"RTN","PRCSEA",96,0)
+ I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT
+"RTN","PRCSEA",97,0)
+ D RL^PRCSUT1
+"RTN","PRCSEA",98,0)
+ D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1
+"RTN","PRCSEA",99,0)
+ K PRCSERR S $P(^PRCS(410,DA,14),"^")=DUZ
+"RTN","PRCSEA",100,0)
+ L -^PRCS(410,DA)
+"RTN","PRCSEA",101,0)
+ S T="edit" D W5 G EXIT:%'=1
+"RTN","PRCSEA",102,0)
+ W !! K PRCS("SUB")
+"RTN","PRCSEA",103,0)
+ G EDRS
+"RTN","PRCSEA",104,0)
+ ;
+"RTN","PRCSEA",105,0)
+CT ;CANCEL A (PERMANENT) TRANS
+"RTN","PRCSEA",106,0)
+ D EN3^PRCSUT
+"RTN","PRCSEA",107,0)
+ G W2:'$D(PRC("SITE")),EXIT:Y<0
+"RTN","PRCSEA",108,0)
+ S DIC="^PRCS(410,",DIC(0)="AEMQ"
+"RTN","PRCSEA",109,0)
+ ;S DIC("S")="I $P(^(0),""^"",4)=.5!($S('$D(^(7)):1,1:$P(^(7),""^"",6)="""")) I +^(0)>0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+"RTN","PRCSEA",110,0)
+ S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+"RTN","PRCSEA",111,0)
+ S DIC("A")="Select TRANSACTION: "
+"RTN","PRCSEA",112,0)
+ D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A")
+"RTN","PRCSEA",113,0)
+CT1 W !,"Cancel this transaction" S %=2 D YN^DICN G CT1:%=0,EXIT:%'=1
+"RTN","PRCSEA",114,0)
+ S DA=+Y
+"RTN","PRCSEA",115,0)
+ L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G CT
+"RTN","PRCSEA",116,0)
+ S T=$P(^PRCS(410,DA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0
+"RTN","PRCSEA",117,0)
+ K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),DA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
+"RTN","PRCSEA",118,0)
+ K ZX
+"RTN","PRCSEA",119,0)
+ I $D(^PRCS(410,DA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0
+"RTN","PRCSEA",120,0)
+ I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX
+"RTN","PRCSEA",121,0)
+ I $D(^PRCS(410,DA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,DA,12,N)) Q:N'>0  S X=$P(^(N,0),"^",2) I X S DA(1)=DA,DA=N D TRANK^PRCSEZZ S DA=DA(1)
+"RTN","PRCSEA",122,0)
+ D ERS410^PRC0G(DA_"^C")
+"RTN","PRCSEA",123,0)
+ W !,"Enter comments for this cancellation",!
+"RTN","PRCSEA",124,0)
+ S DIE=DIC,DR=60
+"RTN","PRCSEA",125,0)
+ D ^DIE
+"RTN","PRCSEA",126,0)
+ ;PRC*5.1*81 if DM trx, update Audit file and send msg to DM
+"RTN","PRCSEA",127,0)
+ D EN^PRCVTCA(DA)
+"RTN","PRCSEA",128,0)
+ L -^PRCS(410,DA)
+"RTN","PRCSEA",129,0)
+ I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK
+"RTN","PRCSEA",130,0)
+ S T="cancel" D W4 G EXIT:%'=1
+"RTN","PRCSEA",131,0)
+ W !! G CT
+"RTN","PRCSEA",132,0)
+ ;
+"RTN","PRCSEA",133,0)
+DT ;DELETE A (TEMPORARY) TRANS
+"RTN","PRCSEA",134,0)
+ S X3="H"
+"RTN","PRCSEA",135,0)
+ D W6 ; format doc for txn#
+"RTN","PRCSEA",136,0)
+ S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H"
+"RTN","PRCSEA",137,0)
+ S DIC("S")="S W=$P(^(0),""^"",5),W(1)=+^(3) I '^(0),$P(^(0),""^"",3)'="""",^PRCS(410,""H"",$P(^(0),""^"",3),+Y)=DUZ!(^(+Y)="""")!($D(^PRC(420,""A"",DUZ,W,W(1),1)))!($D(^(2)))"
+"RTN","PRCSEA",138,0)
+ D ^PRCSDIC G EXIT:Y<0
+"RTN","PRCSEA",139,0)
+ K DIC("S"),DIC("A")
+"RTN","PRCSEA",140,0)
+ S DA=+Y
+"RTN","PRCSEA",141,0)
+ L +^PRCS(410,DA):5 I $T=0 W !,"File is being accessed...please try later" G DT
+"RTN","PRCSEA",142,0)
+DT1 W !,"Delete this transaction" S %=2 D YN^DICN G DT1:%=0,EXIT:%'=1
+"RTN","PRCSEA",143,0)
+ ;The following line was commented out in patch 182; should NOT manually
+"RTN","PRCSEA",144,0)
+ ;change or reset last assigned IEN # in node zero.
+"RTN","PRCSEA",145,0)
+ ;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC
+"RTN","PRCSEA",146,0)
+ S DIK=DIC
+"RTN","PRCSEA",147,0)
+ W !,"Okay....."
+"RTN","PRCSEA",148,0)
+ D ^DIK K DIK
+"RTN","PRCSEA",149,0)
+ L -^PRCS(410,DA)
+"RTN","PRCSEA",150,0)
+ ;The following line was commented out in patch 182; should NOT manually
+"RTN","PRCSEA",151,0)
+ ;change or reset last assigned IEN # in node zero.
+"RTN","PRCSEA",152,0)
+ ;S $P(^PRCS(410,0),U,3)=PRCSDA
+"RTN","PRCSEA",153,0)
+ K PRCSDA
+"RTN","PRCSEA",154,0)
+ W "It's deleted"
+"RTN","PRCSEA",155,0)
+ S T="delete" D W4 G EXIT:%'=1
+"RTN","PRCSEA",156,0)
+ W !! G DT
+"RTN","PRCSEA",157,0)
+ ;
+"RTN","PRCSEA",158,0)
+ ;
+"RTN","PRCSEA",159,0)
+DOR ; Date of Request
+"RTN","PRCSEA",160,0)
+ I $D(^PRCS(410,DA,1)),$P(^PRCS(410,DA,1),"^")'="" Q
+"RTN","PRCSEA",161,0)
+ S %DT="X",X="T" D ^%DT S $P(^PRCS(410,DA,1),"^")=Y
+"RTN","PRCSEA",162,0)
+ Q
+"RTN","PRCSEA",163,0)
+FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed
+"RTN","PRCSEA",164,0)
+ D CKPRM
+"RTN","PRCSEA",165,0)
+ I PRCVD=1 S PRCVX1="I Y>1&(Y<5)",PRCVY1="The Issue Book and NO FORM type are not valid in this option."
+"RTN","PRCSEA",166,0)
+ I PRCVD'=1 S PRCVX1="I Y>1",PRCVY1="The NO FORM type is not valid in this option."
+"RTN","PRCSEA",167,0)
+ W !,PRCVY1,!
+"RTN","PRCSEA",168,0)
+ W !,"Please enter another form type",!
+"RTN","PRCSEA",169,0)
+ S PRCSDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ"
+"RTN","PRCSEA",170,0)
+ S DIC("S")=PRCVX1
+"RTN","PRCSEA",171,0)
+ D ^DIC
+"RTN","PRCSEA",172,0)
+ S:Y=-1 Y=2
+"RTN","PRCSEA",173,0)
+ S DA=PRCSDAA,$P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y
+"RTN","PRCSEA",174,0)
+ K DIC,PRCVX1,PRCVY1,PRCVD
+"RTN","PRCSEA",175,0)
+ Q
+"RTN","PRCSEA",176,0)
+ ;
+"RTN","PRCSEA",177,0)
+ ;Allow user the option of re entering a form type.  If they decline,
+"RTN","PRCSEA",178,0)
+ ;kill off the transaction and return 1; else return 0
+"RTN","PRCSEA",179,0)
+BACKOUT(TRNNAME,TRNDA) ;
+"RTN","PRCSEA",180,0)
+ N DIK,Y,%,DA
+"RTN","PRCSEA",181,0)
+ F  D  Q:%'=0
+"RTN","PRCSEA",182,0)
+ . W !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$C(7)
+"RTN","PRCSEA",183,0)
+ . W !,"Are you sure you want to delete this transaction" S %=2 D YN^DICN
+"RTN","PRCSEA",184,0)
+ . Q
+"RTN","PRCSEA",185,0)
+ I %=2 Q 0
+"RTN","PRCSEA",186,0)
+ S DIK="^PRCS(410,",DA=TRNDA
+"RTN","PRCSEA",187,0)
+ D ^DIK
+"RTN","PRCSEA",188,0)
+ Q 1
+"RTN","PRCSEA",189,0)
+ ;
+"RTN","PRCSEA",190,0)
+W2 W !!,"You are not an authorized control point user.",!,"Contact control point official" R X:5 G EXIT
+"RTN","PRCSEA",191,0)
+W3 Q  ; can this subroutine be deleted? commented out in patch PRC*5*140
+"RTN","PRCSEA",192,0)
+ W !!,"This transaction is assigned temporary transaction number: ",X Q
+"RTN","PRCSEA",193,0)
+W4 W !!,"Would you like to ",T," another transaction" S %=2 D YN^DICN G W4:%=0 Q
+"RTN","PRCSEA",194,0)
+W5 W !!,"Would you like to ",T," another request" S %=1 D YN^DICN G W5:%=0 Q
+"RTN","PRCSEA",195,0)
+W6 W !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",! Q
+"RTN","PRCSEA",196,0)
+ ;*81 Site parameter pull 
+"RTN","PRCSEA",197,0)
+CKPRM S PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
+"RTN","PRCSEA",198,0)
+ Q
+"RTN","PRCSEA",199,0)
+ ;
+"RTN","PRCSEA",200,0)
+EXIT K %,C,D,DA,DIC,DIE,DR,PRCS,PDA,PRCSL,T,X,Y,Z,T1,X3,TYPE,PRCVZ
+"RTN","PRCSEA",201,0)
+ I $D(PRCSERR) K PRCSERR
+"RTN","PRCSEA",202,0)
+ Q