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

[JSHER]

[Jon Tai (jontai)]

review: Approve

=== added file 'kids/MSC_GTM_INTEG_4.KID'
--- kids/MSC_GTM_INTEG_4.KID	1970-01-01 00:00:00 +0000
+++ kids/MSC_GTM_INTEG_4.KID	2009-06-17 16:16:33 +0000
@@ -0,0 +1,11860 @@
+KIDS Distribution saved on Jun 11, 2009@07:53:11
+VERSION 4 GTM, REMOVE POSTINIT
+**KIDS**:MSC GTM INTEGRATION*1.0*4^
+
+**INSTALL NAME**
+MSC GTM INTEGRATION*1.0*4
+"BLD",7026,0)
+MSC GTM INTEGRATION*1.0*4^^0^3090611^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)
+40
+"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^49^41
+"BLD",7026,"KRN",9.8,"NM",1,0)
+MSCZJOB^^0^B11312416
+"BLD",7026,"KRN",9.8,"NM",4,0)
+MSCZJOBU^^0^B2386063
+"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^B9857255
+"BLD",7026,"KRN",9.8,"NM",11,0)
+ZCD^^0^B16830436
+"BLD",7026,"KRN",9.8,"NM",13,0)
+ZOSV2GTM^^0^B6700455
+"BLD",7026,"KRN",9.8,"NM",14,0)
+ZOSFGUX^^0^B22118461
+"BLD",7026,"KRN",9.8,"NM",15,0)
+ZISHGUX^^0^B36911880
+"BLD",7026,"KRN",9.8,"NM",16,0)
+HLCSTCP1^^0^B29662559
+"BLD",7026,"KRN",9.8,"NM",17,0)
+HLCSTCP^^0^B32434118
+"BLD",7026,"KRN",9.8,"NM",18,0)
+HLCSLNCH^^0^B37355917
+"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^B13502099
+"BLD",7026,"KRN",9.8,"NM",23,0)
+XWBTCPM^^0^B56922128
+"BLD",7026,"KRN",9.8,"NM",24,0)
+ZTMGRSET^^0^B54537333
+"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^B8005003
+"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^B3252583
+"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","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","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","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/jsher/MSC_GTM_INTEG_4.KID
+"BLD",7026,"MSCOM")
+VERSION 4 GTM, REMOVE POSTINIT
+"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")
+42
+"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^B37355917
+"RTN","HLCSLNCH",1,0)
+HLCSLNCH ;ALB/MTC/JC MSC/JDA - START AND STOP THE LLP ;13APR2009
+"RTN","HLCSLNCH",2,0)
+ ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,MSC**;Oct 13, 1995
+"RTN","HLCSLNCH",3,0)
+ ;
+"RTN","HLCSLNCH",4,0)
+ ;This program is callable from a menu
+"RTN","HLCSLNCH",5,0)
+ ;It allows the user to Start and Stop the Lower Layer
+"RTN","HLCSLNCH",6,0)
+ ;Protocol in the Background or in the foreground
+"RTN","HLCSLNCH",7,0)
+ ;
+"RTN","HLCSLNCH",8,0)
+ ;Required or Optional INPUT PARAMETERS
+"RTN","HLCSLNCH",9,0)
+ ;             None
+"RTN","HLCSLNCH",10,0)
+ ;
+"RTN","HLCSLNCH",11,0)
+ ;
+"RTN","HLCSLNCH",12,0)
+ ;Output variables
+"RTN","HLCSLNCH",13,0)
+ ;             HLDP=IEN of Logical Link in file #870
+"RTN","HLCSLNCH",14,0)
+ ;(optional)HLTRACE=if SET it launches the LLP in the Foreground
+"RTN","HLCSLNCH",15,0)
+ ;(optional)   ZTSK=if defined LLP was launched in the
+"RTN","HLCSLNCH",16,0)
+ ;background
+"RTN","HLCSLNCH",17,0)
+ ;
+"RTN","HLCSLNCH",18,0)
+ ;
+"RTN","HLCSLNCH",19,0)
+START ; Start up the lower level protocol
+"RTN","HLCSLNCH",20,0)
+ N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE
+"RTN","HLCSLNCH",21,0)
+ N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC
+"RTN","HLCSLNCH",22,0)
+ W !!,"This option is used to launch the lower level protocol for the"
+"RTN","HLCSLNCH",23,0)
+ W !,"appropriate device.  Please select the node with which you want"
+"RTN","HLCSLNCH",24,0)
+ W !,"to communicate",!
+"RTN","HLCSLNCH",25,0)
+ S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ
+"RTN","HLCSLNCH",26,0)
+ S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0)
+"RTN","HLCSLNCH",27,0)
+ ;-- check if parameter have been setup
+"RTN","HLCSLNCH",28,0)
+ ;-- check for LLP type
+"RTN","HLCSLNCH",29,0)
+ I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
+"RTN","HLCSLNCH",30,0)
+ ;-- get TCP information
+"RTN","HLCSLNCH",31,0)
+ S HLPARM4=$G(^HLCS(870,HLDP,400))
+"RTN","HLCSLNCH",32,0)
+ ;-- get routine (background job for LLP)
+"RTN","HLCSLNCH",33,0)
+ S HLBGR=$G(^HLCS(869.1,HLTYPTR,100))
+"RTN","HLCSLNCH",34,0)
+ ;-- get environment check routine (HLQUIT should be defined in fails)
+"RTN","HLCSLNCH",35,0)
+ S HLENV=$G(^HLCS(869.1,HLTYPTR,200))
+"RTN","HLCSLNCH",36,0)
+ ;
+"RTN","HLCSLNCH",37,0)
+ I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ
+"RTN","HLCSLNCH",38,0)
+ ;
+"RTN","HLCSLNCH",39,0)
+ ;-- execute environment check routine if HLQUIT is defined then terminate
+"RTN","HLCSLNCH",40,0)
+ I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ
+"RTN","HLCSLNCH",41,0)
+ ;Multi-Servers, only enable the link if not OpenM
+"RTN","HLCSLNCH",42,0)
+ I $P(HLPARM4,U,3)="M",$$NOTMULTI D  G STARTQ
+"RTN","HLCSLNCH",43,0)
+ . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP."
+"RTN","HLCSLNCH",44,0)
+ . Q
+"RTN","HLCSLNCH",45,0)
+ ;
+"RTN","HLCSLNCH",46,0)
+ I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error"
+"RTN","HLCSLNCH",47,0)
+ I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"."
+"RTN","HLCSLNCH",48,0)
+ I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
+"RTN","HLCSLNCH",49,0)
+ I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D  G STARTQ
+"RTN","HLCSLNCH",50,0)
+ . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
+"RTN","HLCSLNCH",51,0)
+ I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  G STARTQ
+"RTN","HLCSLNCH",52,0)
+ .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
+"RTN","HLCSLNCH",53,0)
+ .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
+"RTN","HLCSLNCH",54,0)
+ .N HLJ,X
+"RTN","HLCSLNCH",55,0)
+ .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
+"RTN","HLCSLNCH",56,0)
+ .L +^HLCS(870,HLDP,0):2
+"RTN","HLCSLNCH",57,0)
+ .E  W !,$C(7),"Unable to enable this LLP !" Q
+"RTN","HLCSLNCH",58,0)
+ .S X="HLJ(870,"""_HLDP_","")"
+"RTN","HLCSLNCH",59,0)
+ .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
+"RTN","HLCSLNCH",60,0)
+ .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109
+"RTN","HLCSLNCH",61,0)
+ .L -^HLCS(870,HLDP,0)
+"RTN","HLCSLNCH",62,0)
+ .W !,"This LLP has been enabled!"
+"RTN","HLCSLNCH",63,0)
+ .Q
+"RTN","HLCSLNCH",64,0)
+ I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",!
+"RTN","HLCSLNCH",65,0)
+ ;
+"RTN","HLCSLNCH",66,0)
+ W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT"
+"RTN","HLCSLNCH",67,0)
+ S DIR("A")="Method for running the receiver"
+"RTN","HLCSLNCH",68,0)
+ S DIR("B")="B"
+"RTN","HLCSLNCH",69,0)
+ S DIR("?",1)="Enter F for Foreground (and trace)"
+"RTN","HLCSLNCH",70,0)
+ S DIR("?",2)="      B for Background (normal) or"
+"RTN","HLCSLNCH",71,0)
+ S DIR("?")="      Q to quit without starting the receiver"
+"RTN","HLCSLNCH",72,0)
+ D ^DIR K DIR
+"RTN","HLCSLNCH",73,0)
+ Q:(Y=U)!(Y="Q")
+"RTN","HLCSLNCH",74,0)
+ ;
+"RTN","HLCSLNCH",75,0)
+ S HLX=$G(^HLCS(870,HLDP,0))
+"RTN","HLCSLNCH",76,0)
+ ;-- foreground
+"RTN","HLCSLNCH",77,0)
+ I Y="F" S HLTRACE=1 D  G STARTQ
+"RTN","HLCSLNCH",78,0)
+ . X HLBGR
+"RTN","HLCSLNCH",79,0)
+ ;-- background
+"RTN","HLCSLNCH",80,0)
+ I Y="B" D  G STARTQ
+"RTN","HLCSLNCH",81,0)
+ . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H
+"RTN","HLCSLNCH",82,0)
+ . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
+"RTN","HLCSLNCH",83,0)
+ . D ^%ZTLOAD
+"RTN","HLCSLNCH",84,0)
+ . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.")
+"RTN","HLCSLNCH",85,0)
+ ;
+"RTN","HLCSLNCH",86,0)
+ Q
+"RTN","HLCSLNCH",87,0)
+ ;
+"RTN","HLCSLNCH",88,0)
+ ;
+"RTN","HLCSLNCH",89,0)
+STARTQ ;
+"RTN","HLCSLNCH",90,0)
+ I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running."
+"RTN","HLCSLNCH",91,0)
+ Q
+"RTN","HLCSLNCH",92,0)
+ ;
+"RTN","HLCSLNCH",93,0)
+STOP ; Shut down a lower level protocol..
+"RTN","HLCSLNCH",94,0)
+ N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y
+"RTN","HLCSLNCH",95,0)
+ W !!,"This option is used to shut down the lower level protocol for the"
+"RTN","HLCSLNCH",96,0)
+ W !,"appropriate device.  Please select the link which you would"
+"RTN","HLCSLNCH",97,0)
+ W !,"like to shutdown.",!
+"RTN","HLCSLNCH",98,0)
+ S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0
+"RTN","HLCSLNCH",99,0)
+ S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400))
+"RTN","HLCSLNCH",100,0)
+ I $P(HLPARM4,U,3)="M",$$NOTMULTI D  Q
+"RTN","HLCSLNCH",101,0)
+ . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP."
+"RTN","HLCSLNCH",102,0)
+ . Q
+"RTN","HLCSLNCH",103,0)
+ ;
+"RTN","HLCSLNCH",104,0)
+ I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q
+"RTN","HLCSLNCH",105,0)
+ I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"."
+"RTN","HLCSLNCH",106,0)
+STP1 ;
+"RTN","HLCSLNCH",107,0)
+ W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR
+"RTN","HLCSLNCH",108,0)
+ I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q
+"RTN","HLCSLNCH",109,0)
+S ;
+"RTN","HLCSLNCH",110,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSLNCH",111,0)
+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown
+"RTN","HLCSLNCH",112,0)
+ S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
+"RTN","HLCSLNCH",113,0)
+ I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown"
+"RTN","HLCSLNCH",114,0)
+ D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109
+"RTN","HLCSLNCH",115,0)
+ I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
+"RTN","HLCSLNCH",116,0)
+ . ;pass task number to stop listener
+"RTN","HLCSLNCH",117,0)
+ . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
+"RTN","HLCSLNCH",118,0)
+ . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+"RTN","HLCSLNCH",119,0)
+ . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
+"RTN","HLCSLNCH",120,0)
+ . U IO W "**STOP**"
+"RTN","HLCSLNCH",121,0)
+ . W !
+"RTN","HLCSLNCH",122,0)
+ . D CLOSE^%ZISTCP
+"RTN","HLCSLNCH",123,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSLNCH",124,0)
+ W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
+"RTN","HLCSLNCH",125,0)
+ Q
+"RTN","HLCSLNCH",126,0)
+ ;
+"RTN","HLCSLNCH",127,0)
+NOTMULTI() ; Returns 1 if implementation can't run multithreaded listener
+"RTN","HLCSLNCH",128,0)
+ Q:^%ZOSF("OS")["GT.M" 0
+"RTN","HLCSLNCH",129,0)
+ Q $S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS")
+"RTN","HLCSLNCH",130,0)
+STOPQ Q
+"RTN","HLCSTCP")
+0^17^B32434118
+"RTN","HLCSTCP",1,0)
+HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE MSC/JDA - (TCP/IP) MLLP ;13APR2009
+"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_""")","S ZISQUIT=$$STOP^HLCSTCP()")
+"RTN","HLCSTCP",28,0)
+ . ;couldn't open listener port
+"RTN","HLCSTCP",29,0)
+ . I HLCSFAIL D EXITS("Openfail") Q
+"RTN","HLCSTCP",30,0)
+ ;
+"RTN","HLCSTCP",31,0)
+ ;multi-threaded listener (OpenM or GT.M)
+"RTN","HLCSTCP",32,0)
+ I $G(HLTCPCS)="M",(^%ZOSF("OS")["OpenM")!(^%ZOSF("OS")["GT.M") D  Q
+"RTN","HLCSTCP",33,0)
+ . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")")
+"RTN","HLCSTCP",34,0)
+ Q
+"RTN","HLCSTCP",35,0)
+ ;
+"RTN","HLCSTCP",36,0)
+SERVER(HLDP) ; single server using Taskman
+"RTN","HLCSTCP",37,0)
+ S HLCSFAIL=0
+"RTN","HLCSTCP",38,0)
+ I '$$INIT D EXITS("Init error") Q
+"RTN","HLCSTCP",39,0)
+ D ^HLCSTCP1
+"RTN","HLCSTCP",40,0)
+ I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
+"RTN","HLCSTCP",41,0)
+ Q:$G(HLCSOUT)=1
+"RTN","HLCSTCP",42,0)
+ D MON("Idle")
+"RTN","HLCSTCP",43,0)
+ Q
+"RTN","HLCSTCP",44,0)
+ ;
+"RTN","HLCSTCP",45,0)
+SERVERS(HLDP) ; Multi-threaded server using Taskman
+"RTN","HLCSTCP",46,0)
+ I '$$INIT D EXITS("Init error") Q
+"RTN","HLCSTCP",47,0)
+ G LISTEN
+"RTN","HLCSTCP",48,0)
+ ;
+"RTN","HLCSTCP",49,0)
+ ;multiple process servers, called from an external utility
+"RTN","HLCSTCP",50,0)
+MSM ;MSM entry point, called from User-Defined Services
+"RTN","HLCSTCP",51,0)
+ ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
+"RTN","HLCSTCP",52,0)
+ ;HL7 Multi-Threaded SERVER
+"RTN","HLCSTCP",53,0)
+ S (IO,IO(0))=$P
+"RTN","HLCSTCP",54,0)
+ G LISTEN
+"RTN","HLCSTCP",55,0)
+ ;
+"RTN","HLCSTCP",56,0)
+CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
+"RTN","HLCSTCP",57,0)
+ ;listener,  % = HLDP
+"RTN","HLCSTCP",58,0)
+ I $G(%)="" D ^%ZTER Q
+"RTN","HLCSTCP",59,0)
+ S (IO,IO(0))="SYS$NET",HLDP=%
+"RTN","HLCSTCP",60,0)
+ ; **Cache'/VMS specific code**
+"RTN","HLCSTCP",61,0)
+ O IO::5 E  D MON("Openfail") Q
+"RTN","HLCSTCP",62,0)
+ X "U IO:(::""-M"")" ;Packet mode like DSM
+"RTN","HLCSTCP",63,0)
+ D LISTEN C IO Q
+"RTN","HLCSTCP",64,0)
+ ;
+"RTN","HLCSTCP",65,0)
+EN ;vms ucx entry point, called from HLSEVEN.COM file,
+"RTN","HLCSTCP",66,0)
+ ;listener,  % = device^HLDP
+"RTN","HLCSTCP",67,0)
+ I $G(%)="" D ^%ZTER Q
+"RTN","HLCSTCP",68,0)
+ S (IO,IO(0))="SYS$NET",HLDP=$P(%,"^",2)
+"RTN","HLCSTCP",69,0)
+ ; **VMS specific code, need to share device**
+"RTN","HLCSTCP",70,0)
+ X "O IO:(TCPDEV):60" E  D MON("Openfail") Q
+"RTN","HLCSTCP",71,0)
+LISTEN ;
+"RTN","HLCSTCP",72,0)
+ N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
+"RTN","HLCSTCP",73,0)
+ I '$$INIT D ^%ZTER Q
+"RTN","HLCSTCP",74,0)
+ ; identify process for ^%SY
+"RTN","HLCSTCP",75,0)
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+"RTN","HLCSTCP",76,0)
+ ;HLLSTN used to identify a listener to tag MON
+"RTN","HLCSTCP",77,0)
+ S HLLSTN=1
+"RTN","HLCSTCP",78,0)
+ ;increment job count, run server
+"RTN","HLCSTCP",79,0)
+ D UPDT(1),^HLCSTCP1,EXITM
+"RTN","HLCSTCP",80,0)
+ Q
+"RTN","HLCSTCP",81,0)
+ ;
+"RTN","HLCSTCP",82,0)
+DCOPEN(HLDP) ;open direct connect - called from HLMA2
+"RTN","HLCSTCP",83,0)
+ Q:'$$INIT 0
+"RTN","HLCSTCP",84,0)
+ Q:HLTCPADD=""!(HLTCPORT="") 0
+"RTN","HLCSTCP",85,0)
+ Q:'$$OPEN^HLCSTCP2 0
+"RTN","HLCSTCP",86,0)
+ Q 1
+"RTN","HLCSTCP",87,0)
+ ;
+"RTN","HLCSTCP",88,0)
+INIT() ; Initialize Variables
+"RTN","HLCSTCP",89,0)
+ ; HLDP should be set to the IEN or name of Logical Link, file 870
+"RTN","HLCSTCP",90,0)
+ S HLOS=$P($G(^%ZOSF("OS")),"^")
+"RTN","HLCSTCP",91,0)
+ N DA,DIQUIET,DR,TMP,X,Y
+"RTN","HLCSTCP",92,0)
+ S DIQUIET=1
+"RTN","HLCSTCP",93,0)
+ D DT^DICRW
+"RTN","HLCSTCP",94,0)
+ I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
+"RTN","HLCSTCP",95,0)
+ S DA=HLDP
+"RTN","HLCSTCP",96,0)
+ S DR="200.02;200.021;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05"
+"RTN","HLCSTCP",97,0)
+ D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
+"RTN","HLCSTCP",98,0)
+ ;
+"RTN","HLCSTCP",99,0)
+ I $D(TMP("DIERR")) QUIT 0
+"RTN","HLCSTCP",100,0)
+ ; -- re-transmit attempts
+"RTN","HLCSTCP",101,0)
+ S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
+"RTN","HLCSTCP",102,0)
+ ; -- exceed re-transmit action
+"RTN","HLCSTCP",103,0)
+ S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
+"RTN","HLCSTCP",104,0)
+ ; -- block size
+"RTN","HLCSTCP",105,0)
+ S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
+"RTN","HLCSTCP",106,0)
+ ; -- read timeout
+"RTN","HLCSTCP",107,0)
+ S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
+"RTN","HLCSTCP",108,0)
+ ; -- ack timeout
+"RTN","HLCSTCP",109,0)
+ S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
+"RTN","HLCSTCP",110,0)
+ ; -- uni-directional wait
+"RTN","HLCSTCP",111,0)
+ S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
+"RTN","HLCSTCP",112,0)
+ ; -- tcp address
+"RTN","HLCSTCP",113,0)
+ S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
+"RTN","HLCSTCP",114,0)
+ ; -- tcp port
+"RTN","HLCSTCP",115,0)
+ S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
+"RTN","HLCSTCP",116,0)
+ ; -- tcp/ip service type
+"RTN","HLCSTCP",117,0)
+ S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
+"RTN","HLCSTCP",118,0)
+ ; -- link persistence
+"RTN","HLCSTCP",119,0)
+ S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
+"RTN","HLCSTCP",120,0)
+ ; -- retention
+"RTN","HLCSTCP",121,0)
+ S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
+"RTN","HLCSTCP",122,0)
+ ;
+"RTN","HLCSTCP",123,0)
+ ; -- set defaults in case something's not set
+"RTN","HLCSTCP",124,0)
+ S:HLDREAD=0 HLDREAD=10
+"RTN","HLCSTCP",125,0)
+ S:HLDBACK=0 HLDBACK=60
+"RTN","HLCSTCP",126,0)
+ S:HLDBSIZE=0 HLDBSIZE=245
+"RTN","HLCSTCP",127,0)
+ S:HLDRETR=0 HLDRETR=5
+"RTN","HLCSTCP",128,0)
+ S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
+"RTN","HLCSTCP",129,0)
+ ;
+"RTN","HLCSTCP",130,0)
+ Q 1
+"RTN","HLCSTCP",131,0)
+ ;
+"RTN","HLCSTCP",132,0)
+ST1 ;record startup in 870 for single server
+"RTN","HLCSTCP",133,0)
+ ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
+"RTN","HLCSTCP",134,0)
+ ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
+"RTN","HLCSTCP",135,0)
+ N HLJ,X
+"RTN","HLCSTCP",136,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",137,0)
+ S X="HLJ(870,"""_HLDP_","")"
+"RTN","HLCSTCP",138,0)
+ S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
+"RTN","HLCSTCP",139,0)
+ I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
+"RTN","HLCSTCP",140,0)
+ E  S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
+"RTN","HLCSTCP",141,0)
+ I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
+"RTN","HLCSTCP",142,0)
+ S:$G(ZTSK) @X@(11)=ZTSK
+"RTN","HLCSTCP",143,0)
+ D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",144,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",145,0)
+ Q
+"RTN","HLCSTCP",146,0)
+ ;
+"RTN","HLCSTCP",147,0)
+MON(Y) ;Display current state & check for shutdown
+"RTN","HLCSTCP",148,0)
+ ;don't display for multiple server
+"RTN","HLCSTCP",149,0)
+ Q:$G(HLLSTN)
+"RTN","HLCSTCP",150,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",151,0)
+ S $P(^HLCS(870,HLDP,0),U,5)=Y
+"RTN","HLCSTCP",152,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",153,0)
+ Q:'$D(HLTRACE)
+"RTN","HLCSTCP",154,0)
+ N X U IO(0)
+"RTN","HLCSTCP",155,0)
+ W !,"IN State: ",Y
+"RTN","HLCSTCP",156,0)
+ I '$$STOP D
+"RTN","HLCSTCP",157,0)
+ . R !,"Type Q to Quit: ",X#1:1
+"RTN","HLCSTCP",158,0)
+ . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
+"RTN","HLCSTCP",159,0)
+ U IO
+"RTN","HLCSTCP",160,0)
+ Q
+"RTN","HLCSTCP",161,0)
+UPDT(Y) ;update job count for multiple servers,X=1 increment
+"RTN","HLCSTCP",162,0)
+ N HLJ,X
+"RTN","HLCSTCP",163,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",164,0)
+ S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
+"RTN","HLCSTCP",165,0)
+ ;if incrementing, set the Device Type field to Multi-Server
+"RTN","HLCSTCP",166,0)
+ I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",167,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",168,0)
+ Q
+"RTN","HLCSTCP",169,0)
+STOP() ;stop flag set
+"RTN","HLCSTCP",170,0)
+ N X
+"RTN","HLCSTCP",171,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",172,0)
+ S X=+$P(^HLCS(870,HLDP,0),U,15)
+"RTN","HLCSTCP",173,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",174,0)
+ Q X
+"RTN","HLCSTCP",175,0)
+ ;
+"RTN","HLCSTCP",176,0)
+LLCNT(DP,Y,Z) ;update Logical Link counters
+"RTN","HLCSTCP",177,0)
+ ;DP=ien of Logical Link in file 870
+"RTN","HLCSTCP",178,0)
+ ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
+"RTN","HLCSTCP",179,0)
+ ;Z: ""=add to counter, 1=subtract from counter
+"RTN","HLCSTCP",180,0)
+ Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
+"RTN","HLCSTCP",181,0)
+ N P,X
+"RTN","HLCSTCP",182,0)
+ S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
+"RTN","HLCSTCP",183,0)
+ F  L +^HLCS(870,DP,P):2 Q:$T
+"RTN","HLCSTCP",184,0)
+ S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+"RTN","HLCSTCP",185,0)
+ L -^HLCS(870,DP,P)
+"RTN","HLCSTCP",186,0)
+ Q
+"RTN","HLCSTCP",187,0)
+SDFLD ; set Shutdown? field to yes
+"RTN","HLCSTCP",188,0)
+ Q:'$G(HLDP)
+"RTN","HLCSTCP",189,0)
+ N HLJ,X
+"RTN","HLCSTCP",190,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",191,0)
+ ;14=Shutdown LLP?
+"RTN","HLCSTCP",192,0)
+ S HLJ(870,HLDP_",",14)=1
+"RTN","HLCSTCP",193,0)
+ D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
+"RTN","HLCSTCP",194,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",195,0)
+ Q
+"RTN","HLCSTCP",196,0)
+ ;
+"RTN","HLCSTCP",197,0)
+EXITS(Y) ; Single service shutdown and cleans up
+"RTN","HLCSTCP",198,0)
+ N HLJ,X
+"RTN","HLCSTCP",199,0)
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+"RTN","HLCSTCP",200,0)
+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number
+"RTN","HLCSTCP",201,0)
+ S X="HLJ(870,"""_HLDP_","")"
+"RTN","HLCSTCP",202,0)
+ S @X@(4)=Y,@X@(11)="@"
+"RTN","HLCSTCP",203,0)
+ S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
+"RTN","HLCSTCP",204,0)
+ D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
+"RTN","HLCSTCP",205,0)
+ L -^HLCS(870,HLDP,0)
+"RTN","HLCSTCP",206,0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+"RTN","HLCSTCP",207,0)
+ Q
+"RTN","HLCSTCP",208,0)
+ ;
+"RTN","HLCSTCP",209,0)
+EXITM ;Multiple service shutdown and clean up
+"RTN","HLCSTCP",210,0)
+ D UPDT(0)
+"RTN","HLCSTCP",211,0)
+ I $D(ZTQUEUED) S ZTREQ="@"
+"RTN","HLCSTCP",212,0)
+ Q
+"RTN","HLCSTCP1")
+0^16^B29662559
+"RTN","HLCSTCP1",1,0)
+HLCSTCP1 ;SFIRMFO/RSD MSC/JDA - BI-DIRECTIONAL TCP ;13APR2009
+"RTN","HLCSTCP1",2,0)
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,MSC**;JUL 17,1995
+"RTN","HLCSTCP1",3,0)
+ ;Receiver
+"RTN","HLCSTCP1",4,0)
+ ;connection is initiated by sender and listener accepts connection
+"RTN","HLCSTCP1",5,0)
+ ;and calls this routine
+"RTN","HLCSTCP1",6,0)
+ ;
+"RTN","HLCSTCP1",7,0)
+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
+"RTN","HLCSTCP1",8,0)
+ N HLMIEN,HLASTMSG
+"RTN","HLCSTCP1",9,0)
+ D MON^HLCSTCP("Open")
+"RTN","HLCSTCP1",10,0)
+ K ^TMP("HLCSTCP",$J,0)
+"RTN","HLCSTCP1",11,0)
+ S HLMIEN=0,HLASTMSG=""
+"RTN","HLCSTCP1",12,0)
+ F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3
+"RTN","HLCSTCP1",13,0)
+ . S HLMIEN=$$READ
+"RTN","HLCSTCP1",14,0)
+ . Q:'HLMIEN
+"RTN","HLCSTCP1",15,0)
+ . D PROCESS
+"RTN","HLCSTCP1",16,0)
+ Q
+"RTN","HLCSTCP1",17,0)
+ ;
+"RTN","HLCSTCP1",18,0)
+PROCESS ;check message and reply
+"RTN","HLCSTCP1",19,0)
+ ;HLDP=LL in 870, update monitor, received msg.
+"RTN","HLCSTCP1",20,0)
+ N HLTCP,HLTCPI,HLTCPO
+"RTN","HLCSTCP1",21,0)
+ S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
+"RTN","HLCSTCP1",22,0)
+ ;update monitor, msg. received
+"RTN","HLCSTCP1",23,0)
+ D LLCNT^HLCSTCP(HLDP,1)
+"RTN","HLCSTCP1",24,0)
+ D NEW^HLTP3(HLMIEN)
+"RTN","HLCSTCP1",25,0)
+ ;update monitor, msg. processed
+"RTN","HLCSTCP1",26,0)
+ D LLCNT^HLCSTCP(HLDP,2)
+"RTN","HLCSTCP1",27,0)
+ Q
+"RTN","HLCSTCP1",28,0)
+ ;
+"RTN","HLCSTCP1",29,0)
+READ() ;read 1 message, returns ien in 773^ien in 772 for message
+"RTN","HLCSTCP1",30,0)
+ D MON^HLCSTCP("Reading")
+"RTN","HLCSTCP1",31,0)
+ N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
+"RTN","HLCSTCP1",32,0)
+ ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator
+"RTN","HLCSTCP1",33,0)
+ S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
+"RTN","HLCSTCP1",34,0)
+ ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
+"RTN","HLCSTCP1",35,0)
+ ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack
+"RTN","HLCSTCP1",36,0)
+ S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
+"RTN","HLCSTCP1",37,0)
+ K ^TMP("HLCSTCP",$J,0)
+"RTN","HLCSTCP1",38,0)
+ F  D RDBLK Q:HLRDOUT
+"RTN","HLCSTCP1",39,0)
+ ;save any excess for next time
+"RTN","HLCSTCP1",40,0)
+ S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX
+"RTN","HLCSTCP1",41,0)
+ I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
+"RTN","HLCSTCP1",42,0)
+ Q HLIND1
+"RTN","HLCSTCP1",43,0)
+ ;
+"RTN","HLCSTCP1",44,0)
+RDBLK S HLDB=HLDBSIZE-$L(HLX)
+"RTN","HLCSTCP1",45,0)
+ U IO D:$D ERROR R X#HLDB:HLDREAD ; MSC/JDA added check against $d
+"RTN","HLCSTCP1",46,0)
+ ; timedout or error, check ack timeout, clean up
+"RTN","HLCSTCP1",47,0)
+ I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
+"RTN","HLCSTCP1",48,0)
+ ;data stream: <sb>dddd<cr><eb><cr>
+"RTN","HLCSTCP1",49,0)
+ ;add incoming line to what wasn't processed in last read
+"RTN","HLCSTCP1",50,0)
+ S HLX=$G(HLX)_X
+"RTN","HLCSTCP1",51,0)
+ ; look for segment= <CR>
+"RTN","HLCSTCP1",52,0)
+ F  Q:HLX'[HLRS  D  Q:HLRDOUT
+"RTN","HLCSTCP1",53,0)
+ . ; Get the first piece, save the rest of the line
+"RTN","HLCSTCP1",54,0)
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
+"RTN","HLCSTCP1",55,0)
+ . ; check for start block, Quit if no ien
+"RTN","HLCSTCP1",56,0)
+ . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D  Q
+"RTN","HLCSTCP1",57,0)
+ .. D:HLMSG(HLINE,0)[HLDSTRT
+"RTN","HLCSTCP1",58,0)
+ ... S X=$L(HLMSG(HLINE,0),HLDSTRT)
+"RTN","HLCSTCP1",59,0)
+ ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
+"RTN","HLCSTCP1",60,0)
+ ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
+"RTN","HLCSTCP1",61,0)
+ ... D RESET:(HLINE>1)
+"RTN","HLCSTCP1",62,0)
+ .. ;ping message
+"RTN","HLCSTCP1",63,0)
+ .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
+"RTN","HLCSTCP1",64,0)
+ .. ; get next ien to store
+"RTN","HLCSTCP1",65,0)
+ .. D MIEN
+"RTN","HLCSTCP1",66,0)
+ .. K HLMSG
+"RTN","HLCSTCP1",67,0)
+ .. S (HLINE,HLHDR)=0
+"RTN","HLCSTCP1",68,0)
+ . ; check for end block; HLMSG(HLINE) = <eb><cr>
+"RTN","HLCSTCP1",69,0)
+ . I HLMSG(HLINE,0)[HLDEND D
+"RTN","HLCSTCP1",70,0)
+ .. ;no msg. ien
+"RTN","HLCSTCP1",71,0)
+ .. Q:'HLIND1
+"RTN","HLCSTCP1",72,0)
+ .. ; Kill just the last line
+"RTN","HLCSTCP1",73,0)
+ .. K HLMSG(HLINE,0) S HLINE=HLINE-1
+"RTN","HLCSTCP1",74,0)
+ .. ; move into 772
+"RTN","HLCSTCP1",75,0)
+ .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
+"RTN","HLCSTCP1",76,0)
+ .. ;mark that end block has been received
+"RTN","HLCSTCP1",77,0)
+ .. ;HLIND1=ien in 773^ien in 772^1 if end block was received
+"RTN","HLCSTCP1",78,0)
+ .. S $P(HLIND1,U,3)=1
+"RTN","HLCSTCP1",79,0)
+ .. ;reset variables for next message
+"RTN","HLCSTCP1",80,0)
+ .. D CLEAN
+"RTN","HLCSTCP1",81,0)
+ . ;add blank line for carriage return
+"RTN","HLCSTCP1",82,0)
+ . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
+"RTN","HLCSTCP1",83,0)
+ Q:HLRDOUT
+"RTN","HLCSTCP1",84,0)
+ ;If the line is long and no <CR> move it into the array. 
+"RTN","HLCSTCP1",85,0)
+ I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D  Q
+"RTN","HLCSTCP1",86,0)
+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
+"RTN","HLCSTCP1",87,0)
+ ;have start block but no record seperator
+"RTN","HLCSTCP1",88,0)
+ I HLX[HLDSTRT D  Q
+"RTN","HLCSTCP1",89,0)
+ . ;check for more than 1 start block
+"RTN","HLCSTCP1",90,0)
+ . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
+"RTN","HLCSTCP1",91,0)
+ . S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
+"RTN","HLCSTCP1",92,0)
+ . D RESET:(HLHDR&(HLINE>1))
+"RTN","HLCSTCP1",93,0)
+ ;if no ien, then we don't have start block, reset
+"RTN","HLCSTCP1",94,0)
+ I 'HLIND1 D CLEAN Q
+"RTN","HLCSTCP1",95,0)
+ ; big message-merge from local to global every 100 lines
+"RTN","HLCSTCP1",96,0)
+ I (HLINE-$O(HLMSG(0)))>100 D
+"RTN","HLCSTCP1",97,0)
+ . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
+"RTN","HLCSTCP1",98,0)
+ . ; reset working array
+"RTN","HLCSTCP1",99,0)
+ . K HLMSG
+"RTN","HLCSTCP1",100,0)
+ Q
+"RTN","HLCSTCP1",101,0)
+ ;
+"RTN","HLCSTCP1",102,0)
+SAVE(SRC,DEST) ;save into global & set top node
+"RTN","HLCSTCP1",103,0)
+ ;SRC=source array (passed by ref.), DEST=destination global
+"RTN","HLCSTCP1",104,0)
+ M @DEST=SRC
+"RTN","HLCSTCP1",105,0)
+ S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
+"RTN","HLCSTCP1",106,0)
+ Q
+"RTN","HLCSTCP1",107,0)
+ ;
+"RTN","HLCSTCP1",108,0)
+DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
+"RTN","HLCSTCP1",109,0)
+ N DIK,DA
+"RTN","HLCSTCP1",110,0)
+ S DA=+HLMAMT,DIK="^HLMA("
+"RTN","HLCSTCP1",111,0)
+ D ^DIK
+"RTN","HLCSTCP1",112,0)
+ S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
+"RTN","HLCSTCP1",113,0)
+ D ^DIK
+"RTN","HLCSTCP1",114,0)
+ Q
+"RTN","HLCSTCP1",115,0)
+MIEN ; sets HLIND1=ien in 773^ien in 772 for message
+"RTN","HLCSTCP1",116,0)
+ N HLMID,X
+"RTN","HLCSTCP1",117,0)
+ I HLIND1 D
+"RTN","HLCSTCP1",118,0)
+ . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
+"RTN","HLCSTCP1",119,0)
+ . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
+"RTN","HLCSTCP1",120,0)
+ ;msg. id is 10th of MSH & 11th for BSH or FSH
+"RTN","HLCSTCP1",121,0)
+ S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
+"RTN","HLCSTCP1",122,0)
+ ;if HLIND1 is set, kill old message, use HLIND1 for new
+"RTN","HLCSTCP1",123,0)
+ ;message, it means we never got end block for 1st msg.
+"RTN","HLCSTCP1",124,0)
+ I HLIND1 D  Q
+"RTN","HLCSTCP1",125,0)
+ . ;get pointer to 772, kill header
+"RTN","HLCSTCP1",126,0)
+ . K ^HLMA(+HLIND1,"MSH")
+"RTN","HLCSTCP1",127,0)
+ . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
+"RTN","HLCSTCP1",128,0)
+ . S X=$$MAID^HLTF(+HLIND1,HLMID)
+"RTN","HLCSTCP1",129,0)
+ . D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+"RTN","HLCSTCP1",130,0)
+ . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
+"RTN","HLCSTCP1",131,0)
+ D TCP^HLTF(.HLMID,.X,.HLDT)
+"RTN","HLCSTCP1",132,0)
+ I 'X D  Q
+"RTN","HLCSTCP1",133,0)
+ . ;error - record and reset array
+"RTN","HLCSTCP1",134,0)
+ . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
+"RTN","HLCSTCP1",135,0)
+ . D CLEAN K HLLSTN
+"RTN","HLCSTCP1",136,0)
+ . ;error 100=LLP Could not Enqueue the Message, reset array
+"RTN","HLCSTCP1",137,0)
+ . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
+"RTN","HLCSTCP1",138,0)
+ ;HLIND1=ien in 773^ien in 772
+"RTN","HLCSTCP1",139,0)
+ S HLIND1=X_U_+$G(^HLMA(X,0))
+"RTN","HLCSTCP1",140,0)
+ ;save MSH into 773
+"RTN","HLCSTCP1",141,0)
+ D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
+"RTN","HLCSTCP1",142,0)
+ Q
+"RTN","HLCSTCP1",143,0)
+ ;
+"RTN","HLCSTCP1",144,0)
+PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
+"RTN","HLCSTCP1",145,0)
+ N FS,I,L,L1,L2,X,Y
+"RTN","HLCSTCP1",146,0)
+ S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
+"RTN","HLCSTCP1",147,0)
+ F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D  Q:$L(X)!'$D(MSH(I,0))
+"RTN","HLCSTCP1",148,0)
+ . S:L1=1 L=L+1
+"RTN","HLCSTCP1",149,0)
+ . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
+"RTN","HLCSTCP1",150,0)
+ . S L2=Y,Y=L
+"RTN","HLCSTCP1",151,0)
+ Q X
+"RTN","HLCSTCP1",152,0)
+ ;
+"RTN","HLCSTCP1",153,0)
+PING ;process PING message
+"RTN","HLCSTCP1",154,0)
+ S X=HLMSG(1,0)
+"RTN","HLCSTCP1",155,0)
+ I X[HLDEND U IO W X,!
+"RTN","HLCSTCP1",156,0)
+CLEAN ;reset var. for next message
+"RTN","HLCSTCP1",157,0)
+ K HLMSG
+"RTN","HLCSTCP1",158,0)
+ S HLINE=0,HLRDOUT=1
+"RTN","HLCSTCP1",159,0)
+ Q
+"RTN","HLCSTCP1",160,0)
+ ;
+"RTN","HLCSTCP1",161,0)
+ERROR ; Error trap for disconnect error and return back to the read loop.
+"RTN","HLCSTCP1",162,0)
+ S $ETRAP="D UNWIND^%ZTER"
+"RTN","HLCSTCP1",163,0)
+ I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
+"RTN","HLCSTCP1",164,0)
+ I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
+"RTN","HLCSTCP1",165,0)
+ S HLCSOUT=1 D ^%ZTER,CC("Error")
+"RTN","HLCSTCP1",166,0)
+ D UNWIND^%ZTER
+"RTN","HLCSTCP1",167,0)
+ Q
+"RTN","HLCSTCP1",168,0)
+ ;
+"RTN","HLCSTCP1",169,0)
+CC(X) ;cleanup and close
+"RTN","HLCSTCP1",170,0)
+ D MON^HLCSTCP(X)
+"RTN","HLCSTCP1",171,0)
+ H 2
+"RTN","HLCSTCP1",172,0)
+ Q
+"RTN","HLCSTCP1",173,0)
+RESET ;reset info as a result of no end block
+"RTN","HLCSTCP1",174,0)
+ N %
+"RTN","HLCSTCP1",175,0)
+ S HLMSG(1,0)=HLMSG(HLINE,0)
+"RTN","HLCSTCP1",176,0)
+ F %=2:1:HLINE K HLMSG(%,0)
+"RTN","HLCSTCP1",177,0)
+ S HLINE=1
+"RTN","HLCSTCP1",178,0)
+ Q
+"RTN","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^B8005003
+"RTN","MSCXUS3A",1,0)
+MSCXUS3A ;SF-ISC/STAFF MSC/JDS - CHANGE UCI'S ;30APR2009
+"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 (X,%UCI)=Y(0) X ^%ZOSF("UCICHECK") I 0[Y G BAD
+"RTN","MSCXUS3A",17,0)
+ K XQY0 S Y=$O(^[%UCI]VA(200,"B",USERNAME,0))
+"RTN","MSCXUS3A",18,0)
+ I Y S DIR=$P($G(^[%UCI]VA(200,Y,201)),U)
+"RTN","MSCXUS3A",19,0)
+ I DIR,$P($G(^[%UCI]DIC(19,DIR,0)),U,4)="M" S DUZ=Y,XQY=DIR,(DEF,PGM)="%MSCXUCI" G NXT
+"RTN","MSCXUS3A",20,0)
+BAD W !,"UCI not found!" D SHOW G UCI
+"RTN","MSCXUS3A",21,0)
+ ;
+"RTN","MSCXUS3A",22,0)
+NXT ;Here we go.
+"RTN","MSCXUS3A",23,0)
+ D C^XUSCLEAN K ^XUTL("XQ",$J),^XUTL($J),^TMP($J),^UTILITY($J)
+"RTN","MSCXUS3A",24,0)
+ K DA G GO^%MSCXUCI
+"RTN","MSCXUS3A",25,0)
+ ;
+"RTN","MSCXUS3A",26,0)
+ ;
+"RTN","MSCXUS3A",27,0)
+SHOW W ! S I=0,UC="",X=$S($D(^VA(200,DUZ,201)):+^(201),1:0)
+"RTN","MSCXUS3A",28,0)
+ W !,"Enter ^ to return to your current menu, or select from:"
+"RTN","MSCXUS3A",29,0)
+ F I=0:0 S I=$O(^VA(200,DUZ,.2,I)) Q:I'>0  D
+"RTN","MSCXUS3A",30,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",31,0)
+ . I UC'[":" W I
+"RTN","MSCXUS3A",32,0)
+ . D PM W ?10,X X ^%ZOSF("UCICHECK") I 0[Y W " -- Not currently a valId  UCI!",$C(7) Q
+"RTN","MSCXUS3A",33,0)
+ . W:UC]"" ":"_UC
+"RTN","MSCXUS3A",34,0)
+ . Q
+"RTN","MSCXUS3A",35,0)
+ Q
+"RTN","MSCXUS3A",36,0)
+ ;
+"RTN","MSCXUS3A",37,0)
+PM I X="PROD"!(X="MGR") S X=^%ZOSF(X)
+"RTN","MSCXUS3A",38,0)
+ Q
+"RTN","MSCXUS3A",39,0)
+ ;
+"RTN","MSCXUS3A",40,0)
+ ;
+"RTN","MSCXUS3A",41,0)
+ ;
+"RTN","MSCXUS3A",42,0)
+NSP(USERNAME) ;LIST OTHER NAMESPACES WHERE THIS USER IS
+"RTN","MSCXUS3A",43,0)
+ N X,L,I,Y
+"RTN","MSCXUS3A",44,0)
+ X ^%ZOSF("UCI") S Y=$P(Y,",") I ^%ZOSF("OS")["GT.M" G GTMNSP
+"RTN","MSCXUS3A",45,0)
+ f I=1:1:$zu(90,0) s L($zu(90,2,0,I))="" ;***CACHE-SPECIFIC   FROM %NSP
+"RTN","MSCXUS3A",46,0)
+ S (I,L,X)="" F  S I=$O(L(I)) Q:I=""  I I'=Y D  ;NOT THE CURRENT ONE
+"RTN","MSCXUS3A",47,0)
+ .N DUZ S DUZ=$O(^[I]VA(200,"B",USERNAME,0)) Q:'DUZ
+"RTN","MSCXUS3A",48,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",49,0)
+ .S L=L+1,X=X_L_":"_I_";"
+"RTN","MSCXUS3A",50,0)
+ Q X
+"RTN","MSCXUS3A",51,0)
+GTMNSP ;
+"RTN","MSCXUS3A",52,0)
+ N CURRENT S CURRENT=Y
+"RTN","MSCXUS3A",53,0)
+ D LIST^ZCD()
+"RTN","MSCXUS3A",54,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",55,0)
+ .S A=$P($ZG,"/"_$$CURRENT^ZCD_"/")_"/"_A_"/"_$P($ZG,"/"_$$CURRENT^ZCD_"/",2)
+"RTN","MSCXUS3A",56,0)
+ .N DUZ S DUZ=$O(^[A]VA(200,"B",USERNAME,0)) Q:'DUZ
+"RTN","MSCXUS3A",57,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",58,0)
+ .S L=L+1,X=X_L_":"_A_";"
+"RTN","MSCXUS3A",59,0)
+ Q X
+"RTN","MSCZJOB")
+0^1^B11312416
+"RTN","MSCZJOB",1,0)
+MSCZJOB ;GFT,JDS/MSC;1 MAY 2009
+"RTN","MSCZJOB",2,0)
+ ;;8.0;KERNEL;**MSC**
+"RTN","MSCZJOB",3,0)
+ W !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+"RTN","MSCZJOB",4,0)
+ N MSC
+"RTN","MSCZJOB",5,0)
+DDS ;
+"RTN","MSCZJOB",6,0)
+ S DDSFILE=3.081,DR="[MSCZJOBEXAM]",DDSPARM="S"
+"RTN","MSCZJOB",7,0)
+ D ^DDS Q
+"RTN","MSCZJOB",8,0)
+ ;
+"RTN","MSCZJOB",9,0)
+UNLOCK(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
+"RTN","MSCZJOB",10,0)
+ N X,R S R=$G(@MSC@(MSCJOBID,"L",D0)) I R'["^" Q  ;CAN'T SEE IT
+"RTN","MSCZJOB",11,0)
+ S R=$P(R," ",2),X="L "_R D ^DIM Q:'$D(X)
+"RTN","MSCZJOB",12,0)
+ D UNLOCK^MSCZJOBU(R)
+"RTN","MSCZJOB",13,0)
+ Q
+"RTN","MSCZJOB",14,0)
+ ;
+"RTN","MSCZJOB",15,0)
+KILL(J) ;FROM FIELD
+"RTN","MSCZJOB",16,0)
+ D KILL^MSCZJOBU(J)
+"RTN","MSCZJOB",17,0)
+ Q
+"RTN","MSCZJOB",18,0)
+ ;
+"RTN","MSCZJOB",19,0)
+COMPMUL ;COMPUTED MULTIPLE FOR MSCZJOBEXAM BLOCK
+"RTN","MSCZJOB",20,0)
+ N X,D0,J
+"RTN","MSCZJOB",21,0)
+ S MSC="^TMP(""MSCZJOB"")" D POLL
+"RTN","MSCZJOB",22,0)
+ F D0=0:0 S D0=$O(MSCZJOB(D0)) Q:'D0  D
+"RTN","MSCZJOB",23,0)
+ .S MSCZJOB(D0)=MSCZJOB(D0)_U_$$DEV(D0)_U_$$USER(D0)_U_$$NSP(D0)_U_U_U_U_U_$$ROUTINE(D0)
+"RTN","MSCZJOB",24,0)
+ .S X=MSCZJOB(D0) X DICMX
+"RTN","MSCZJOB",25,0)
+ Q
+"RTN","MSCZJOB",26,0)
+JOB(D0) Q $P(MSCZJOB(D0),U) ;***
+"RTN","MSCZJOB",27,0)
+DEV(D0) Q $$FIND(D0,"I","$PRINCIPAL")
+"RTN","MSCZJOB",28,0)
+NSP(D0) N N D  Q N
+"RTN","MSCZJOB",29,0)
+ .N L,P S N=$$FIND(D0,"I","$ZGBLDIR"),L=$L(N,"/") I L<2 Q
+"RTN","MSCZJOB",30,0)
+ .F L=L-1:-1:2 S P=$P(N,"/",L) I P'[".",P'["globals" Q
+"RTN","MSCZJOB",31,0)
+ .S P=1 I $P(N,"/")="" S P=2
+"RTN","MSCZJOB",32,0)
+ .S N=$P(N,"/",P,L)
+"RTN","MSCZJOB",33,0)
+USER(D0) Q $P($G(^VA(200,+$$FIND(D0,"V","DUZ"),0)),U)
+"RTN","MSCZJOB",34,0)
+ROUTINE(D0) Q $$FIND(D0,"V","%ZPOS")
+"RTN","MSCZJOB",35,0)
+ ;
+"RTN","MSCZJOB",36,0)
+FIND(D0,ARR,KEY) N I,J,X S X="",J=+MSCZJOB(D0)
+"RTN","MSCZJOB",37,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",38,0)
+ Q X
+"RTN","MSCZJOB",39,0)
+ ;
+"RTN","MSCZJOB",40,0)
+COMPSTK ;COMPUTED MULTIPLE FOR MSCZJOBSTACK BLOCK
+"RTN","MSCZJOB",41,0)
+ S MSC="^TMP(""MSCZJOB"")" K @MSC@(MSCJOBID) D POLL1
+"RTN","MSCZJOB",42,0)
+ N D0,J S J=MSCJOBID
+"RTN","MSCZJOB",43,0)
+ F D0=1:1:$O(@MSC@(J,"S",""),-1)  S X="" X DICMX
+"RTN","MSCZJOB",44,0)
+ Q
+"RTN","MSCZJOB",45,0)
+ ;
+"RTN","MSCZJOB",46,0)
+STACK(D0) N X S X=$G(@MSC@(MSCJOBID,"S",D0))
+"RTN","MSCZJOB",47,0)
+ Q X
+"RTN","MSCZJOB",48,0)
+ ;
+"RTN","MSCZJOB",49,0)
+COMPVARS ;COMPUTED MULTIPLE FOR MSCZJOBVARS BLOCK
+"RTN","MSCZJOB",50,0)
+ S MSC="^TMP(""MSCZJOB"")" K @MSC@(MSCJOBID) D POLL1
+"RTN","MSCZJOB",51,0)
+ N D0,J S J=MSCJOBID
+"RTN","MSCZJOB",52,0)
+ F D0=1:1:$O(@MSC@(J,"V",""),-1)  S X="" X DICMX
+"RTN","MSCZJOB",53,0)
+ Q
+"RTN","MSCZJOB",54,0)
+ ;
+"RTN","MSCZJOB",55,0)
+COMPLKS ;COMPUTED MULTIPLE FOR MSCZJOBLOCKS BLOCK
+"RTN","MSCZJOB",56,0)
+ S MSC="^TMP(""MSCZJOB"")" D POLL1
+"RTN","MSCZJOB",57,0)
+ N D0
+"RTN","MSCZJOB",58,0)
+ F D0=1:1:$$LOCKS  S X="" X DICMX
+"RTN","MSCZJOB",59,0)
+ Q
+"RTN","MSCZJOB",60,0)
+ ;
+"RTN","MSCZJOB",61,0)
+LOCKS() Q +$O(@MSC@(MSCJOBID,"L",""),-1)
+"RTN","MSCZJOB",62,0)
+ ;
+"RTN","MSCZJOB",63,0)
+POLL K MSCZJOB ;D HLP^DDSUTL("   POLLING JOBS.....") 
+"RTN","MSCZJOB",64,0)
+ I $G(^%ZOSF("OS"))["GT.M" D
+"RTN","MSCZJOB",65,0)
+ .K @MSC
+"RTN","MSCZJOB",66,0)
+ .D INTRPT^MSCZJOBU("*") ;SETS UP ^TMP
+"RTN","MSCZJOB",67,0)
+ .N MSCA,I D PIDS^MSCZJOBU(.MSCA)
+"RTN","MSCZJOB",68,0)
+ .S MSCA="" F I=1:1 S MSCA=$O(MSCA(MSCA)) Q:'MSCA  S MSCZJOB(I)=MSCA ;SETS UP LOCAL ARRAY
+"RTN","MSCZJOB",69,0)
+ .H 1 ;WAIT FOR POLLING
+"RTN","MSCZJOB",70,0)
+ D TEST
+"RTN","MSCZJOB",71,0)
+ Q
+"RTN","MSCZJOB",72,0)
+ ;
+"RTN","MSCZJOB",73,0)
+POLL1 Q:'$G(MSCJOBID)
+"RTN","MSCZJOB",74,0)
+ I $G(^%ZOSF("OS"))["GT.M" D
+"RTN","MSCZJOB",75,0)
+ .K @MSC@(MSCJOBID)
+"RTN","MSCZJOB",76,0)
+ .D INTRPT^MSCZJOBU(MSCJOBID) ;SETS UP ^TMP(MSCZJOB)
+"RTN","MSCZJOB",77,0)
+ .H 1 ;WAIT FOR POLLING
+"RTN","MSCZJOB",78,0)
+ D TEST
+"RTN","MSCZJOB",79,0)
+ Q
+"RTN","MSCZJOB",80,0)
+ ;
+"RTN","MSCZJOB",81,0)
+TEST Q
+"RTN","MSCZJOB",82,0)
+COMPLK ;COMPUTED MULTIPLE FOR MSCZLOCK BLOCK
+"RTN","MSCZJOB",83,0)
+ N X,D0,J
+"RTN","MSCZJOB",84,0)
+ S MSC="^TMP(""MSCZJOB"")" D POLL S D0=0
+"RTN","MSCZJOB",85,0)
+ F K=0:0 S K=$O(MSCZJOB(K)) Q:'K  D
+"RTN","MSCZJOB",86,0)
+ .F J=0:0 S J=$O(^TMP("MSCZJOB",MSCZJOB(K),"L",J)) Q:'J  S A=$TR(^(J),U,"~") D
+"RTN","MSCZJOB",87,0)
+ ..S D0=D0+1,MSCZLK(D0)=$P(A,"LOCK ",2,9)_U_$$USER(K)_U_$TR($$ROUTINE(K),U,"~")_"^^"_MSCZJOB(K)
+"RTN","MSCZJOB",88,0)
+ ..S X=MSCZLK(D0) X DICMX
+"RTN","MSCZJOB",89,0)
+ Q
+"RTN","MSCZJOB",90,0)
+LOCK ;
+"RTN","MSCZJOB",91,0)
+ S DDSFILE=3.081,DR="[MSCZLOCK]",DDSPARM="S"
+"RTN","MSCZJOB",92,0)
+ D ^DDS Q
+"RTN","MSCZJOB",93,0)
+UNL(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
+"RTN","MSCZJOB",94,0)
+ N X,R S R=$P($G(MSCZLK(D0)),U),P=$P($G(MSCZLK(D0)),U,5) ;I R'["^" Q  ;CAN'T SEE IT
+"RTN","MSCZJOB",95,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",96,0)
+ D UNLOCK^MSCZJOBU(R)
+"RTN","MSCZJOBS")
+0^46^B3252583
+"RTN","MSCZJOBS",1,0)
+MSCZJOBS ;JKT/MSC - OpenVista System status ;27MAY2009
+"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 #!,?22,"OpenVista System Status"
+"RTN","MSCZJOBS",17,0)
+ W !,?(34-($L(DATETIME)/2)\1),DATETIME
+"RTN","MSCZJOBS",18,0)
+ W !!,?1,"Process",?12,"Device",?30,"Instance",?42,"Routine",?56,"User"
+"RTN","MSCZJOBS",19,0)
+ ;
+"RTN","MSCZJOBS",20,0)
+ N PID S PID=""
+"RTN","MSCZJOBS",21,0)
+ D PIDS^MSCZJOBU(.PID)
+"RTN","MSCZJOBS",22,0)
+ F  S PID=$O(PID(PID)) Q:PID=""  D
+"RTN","MSCZJOBS",23,0)
+ . I $G(THIS) Q:$$INSTANCE(PID)'=$$CURRENT^ZCD()
+"RTN","MSCZJOBS",24,0)
+ . W !,$$PID(PID)
+"RTN","MSCZJOBS",25,0)
+ . W ?12,$$DEVICE(PID)
+"RTN","MSCZJOBS",26,0)
+ . W ?30,$$INSTANCE(PID)
+"RTN","MSCZJOBS",27,0)
+ . W ?42,$$ROUTINE(PID)
+"RTN","MSCZJOBS",28,0)
+ . W ?56,$$USER(PID)
+"RTN","MSCZJOBS",29,0)
+ ;
+"RTN","MSCZJOBS",30,0)
+ W !! ZSY "uptime"
+"RTN","MSCZJOBS",31,0)
+ Q
+"RTN","MSCZJOBS",32,0)
+ ;
+"RTN","MSCZJOBS",33,0)
+PID(PID) ;Return process ID formatted for display
+"RTN","MSCZJOBS",34,0)
+ Q $J(PID,8)_$S($J=PID:"*",1:"")
+"RTN","MSCZJOBS",35,0)
+ ;
+"RTN","MSCZJOBS",36,0)
+DEVICE(PID) ;Return device
+"RTN","MSCZJOBS",37,0)
+ Q $$FIND("^TMP(""MSCZJOB"")",PID,"I","$PRINCIPAL")
+"RTN","MSCZJOBS",38,0)
+ ;
+"RTN","MSCZJOBS",39,0)
+INSTANCE(PID) ;Return name of OpenVista instance
+"RTN","MSCZJOBS",40,0)
+ N ZG S ZG=$$FIND("^TMP(""MSCZJOB"")",PID,"I","$ZGBLDIR")
+"RTN","MSCZJOBS",41,0)
+ Q $P(ZG,"/",$L(ZG,"/")-2)
+"RTN","MSCZJOBS",42,0)
+ ;
+"RTN","MSCZJOBS",43,0)
+ROUTINE(PID) ;Return routine
+"RTN","MSCZJOBS",44,0)
+ Q $P($$FIND("^TMP(""MSCZJOB"")",PID,"V","%ZPOS"),"^",2)
+"RTN","MSCZJOBS",45,0)
+ ;
+"RTN","MSCZJOBS",46,0)
+USER(PID) ;Return OpenVista user
+"RTN","MSCZJOBS",47,0)
+ N DUZ S DUZ=+$$FIND("^TMP(""MSCZJOB"")",PID,"V","DUZ")
+"RTN","MSCZJOBS",48,0)
+ ; FIXME: this code is looking up the name of the person in *this* 
+"RTN","MSCZJOBS",49,0)
+ ; instance, which assumes that ^VA(200) is the same across databases
+"RTN","MSCZJOBS",50,0)
+ Q $P($G(^VA(200,DUZ,0)),"^")
+"RTN","MSCZJOBS",51,0)
+ ;
+"RTN","MSCZJOBS",52,0)
+FIND(NODE,PID,ARR,KEY) ;Return the value of a key in one of the ZSHOW arrays
+"RTN","MSCZJOBS",53,0)
+ N I,X S I="",X=""
+"RTN","MSCZJOBS",54,0)
+        F  S I=$O(@NODE@(PID,ARR,I)) Q:'I  I $P(^(I),KEY_"=")="" S X=$TR($P(^(I),"=",2),"""") Q
+"RTN","MSCZJOBS",55,0)
+ Q X
+"RTN","MSCZJOBU")
+0^4^B2386063
+"RTN","MSCZJOBU",1,0)
+MSCZJOBU ;RHL,JDS,JKT/MSC;20MAY2009
+"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= -C mumps")::"PIPE" U DEV
+"RTN","MSCZJOBU",14,0)
+ ;
+"RTN","MSCZJOBU",15,0)
+ N %I S %I=$I
+"RTN","MSCZJOBU",16,0)
+ N %J ; $JOB
+"RTN","MSCZJOBU",17,0)
+ F  U DEV R %J U %I Q:%J=""  D
+"RTN","MSCZJOBU",18,0)
+ . F  Q:$E(%J,1)'=" "  S %J=$E(%J,2,999) ; strip leading spaces
+"RTN","MSCZJOBU",19,0)
+ . S XARY(%J)=""
+"RTN","MSCZJOBU",20,0)
+ ;
+"RTN","MSCZJOBU",21,0)
+ C DEV
+"RTN","MSCZJOBU",22,0)
+ Q
+"RTN","MSCZJOBU",23,0)
+ ;
+"RTN","MSCZJOBU",24,0)
+INTRPT(PID) ; SEND mupip intrpt to process with PID
+"RTN","MSCZJOBU",25,0)
+ ;  WHICH CAUSES THE $ZINTERRUPT CODE TO BE EXECUTED.
+"RTN","MSCZJOBU",26,0)
+ ;  PID PASSED BY VALUE
+"RTN","MSCZJOBU",27,0)
+ ;  PID CAN BE A SINGLE PID, I.E. $J
+"RTN","MSCZJOBU",28,0)
+ ;  PID CAN BE A "*" WHICH SENDS AN INTERRUPT TO ALL MUMPS PROCESSES
+"RTN","MSCZJOBU",29,0)
+ ;
+"RTN","MSCZJOBU",30,0)
+ Q:$G(PID)'?1N.N&($G(PID)'="*")
+"RTN","MSCZJOBU",31,0)
+ ;
+"RTN","MSCZJOBU",32,0)
+ N CMD,DEV
+"RTN","MSCZJOBU",33,0)
+ S CMD="gtmsignal -q "_$S(PID="*":"-a",1:PID)
+"RTN","MSCZJOBU",34,0)
+ S DEV="gtmsignaldev"
+"RTN","MSCZJOBU",35,0)
+ OPEN DEV:(COMM=CMD)::"PIPE" U DEV C DEV
+"RTN","MSCZJOBU",36,0)
+ Q
+"RTN","MSCZJOBU",37,0)
+ ;
+"RTN","MSCZJOBU",38,0)
+KILL(PID) ; Send mupip stop to process with PID
+"RTN","MSCZJOBU",39,0)
+ ;  PID PASSED BY VALUE
+"RTN","MSCZJOBU",40,0)
+ ;  PID CAN BE A SINGLE PID, I.E. $J
+"RTN","MSCZJOBU",41,0)
+ ;
+"RTN","MSCZJOBU",42,0)
+ Q:$G(PID)'?1N.N
+"RTN","MSCZJOBU",43,0)
+ ;
+"RTN","MSCZJOBU",44,0)
+ N DEV
+"RTN","MSCZJOBU",45,0)
+ S DEV="gtmsignaldev"
+"RTN","MSCZJOBU",46,0)
+ OPEN DEV:(COMM="gtmsignal -q -s "_PID)::"PIPE" U DEV C DEV
+"RTN","MSCZJOBU",47,0)
+ Q
+"RTN","MSCZJOBU",48,0)
+ ;
+"RTN","MSCZJOBU",49,0)
+UNLOCK(NODE) ; Use lke to remove lock on NODE.
+"RTN","MSCZJOBU",50,0)
+ N CMD,DEV
+"RTN","MSCZJOBU",51,0)
+ S CMD="lke clear -lock="""_NODE_""" -nointeractive -output=/dev/null"
+"RTN","MSCZJOBU",52,0)
+ S DEV="lkedev"
+"RTN","MSCZJOBU",53,0)
+ OPEN DEV:(COMM=CMD)::"PIPE" U DEV C DEV
+"RTN","MSCZJOBU",54,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
+"RTN","PSBOMH1")
+0^38^B71152392
+"RTN","PSBOMH1",1,0)
+PSBOMH1 ;BIRMINGHAM/EFC,MSC/JDA - MAH ;27APR2009
+"RTN","PSBOMH1",2,0)
+ ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,MSC**;Mar 2004
+"RTN","PSBOMH1",3,0)
+ ;
+"RTN","PSBOMH1",4,0)
+ ; Reference/IA
+"RTN","PSBOMH1",5,0)
+ ; ^DILF/2054
+"RTN","PSBOMH1",6,0)
+ ; File 200/10060
+"RTN","PSBOMH1",7,0)
+ ;
+"RTN","PSBOMH1",8,0)
+EN ;
+"RTN","PSBOMH1",9,0)
+ ; Load administrations
+"RTN","PSBOMH1",10,0)
+ S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
+"RTN","PSBOMH1",11,0)
+ K PSBTSA
+"RTN","PSBOMH1",12,0)
+ F  S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP)  D
+"RTN","PSBOMH1",13,0)
+ .F  S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN  Q:'$D(^PSB(53.79,PSBIEN))  L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D  L -^PSB(53.79,PSBIEN)
+"RTN","PSBOMH1",14,0)
+ ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6)  ; Bad IEN -no evnt dt
+"RTN","PSBOMH1",15,0)
+ ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"  ;NGiven
+"RTN","PSBOMH1",16,0)
+ ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
+"RTN","PSBOMH1",17,0)
+ ..; Continuous
+"RTN","PSBOMH1",18,0)
+ ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
+"RTN","PSBOMH1",19,0)
+ ...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
+"RTN","PSBOMH1",20,0)
+ ...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBMR) D  D CLEAN^PSBVT Q  ;chck IV audit
+"RTN","PSBOMH1",21,0)
+ ....S PSBSIEN=PSBIEN
+"RTN","PSBOMH1",22,0)
+ ....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
+"RTN","PSBOMH1",23,0)
+ ....S PSBIEN=PSBSIEN K PSBSIEN
+"RTN","PSBOMH1",24,0)
+ ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
+"RTN","PSBOMH1",25,0)
+ ....S X=0 F  S X=$O(PSBAUD(X)) Q:X=""  Q:$P(PSBAUD(X),U,1)=PSBDT
+"RTN","PSBOMH1",26,0)
+ ....I X="" K PSBAUD Q
+"RTN","PSBOMH1",27,0)
+ ....I '$D(PSBAUD(X)) K PSBAUD Q
+"RTN","PSBOMH1",28,0)
+ ....S PSBS=$P(PSBAUD(X),U,3)
+"RTN","PSBOMH1",29,0)
+ ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
+"RTN","PSBOMH1",30,0)
+ ....I PSBS="NOT GIVEN" Q
+"RTN","PSBOMH1",31,0)
+ ....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
+"RTN","PSBOMH1",32,0)
+ ....D PSBSTIV^PSBOMH2
+"RTN","PSBOMH1",33,0)
+ ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
+"RTN","PSBOMH1",34,0)
+ ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
+"RTN","PSBOMH1",35,0)
+ ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
+"RTN","PSBOMH1",36,0)
+ ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
+"RTN","PSBOMH1",37,0)
+ ....D PSBOUT($P((X),"^",1),$P((X),"^",2))
+"RTN","PSBOMH1",38,0)
+ ....K PSBAUD
+"RTN","PSBOMH1",39,0)
+ ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
+"RTN","PSBOMH1",40,0)
+ ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
+"RTN","PSBOMH1",41,0)
+ ...I PSBINIT="" S PSBINIT=99
+"RTN","PSBOMH1",42,0)
+ ...;get instrc info - audt log
+"RTN","PSBOMH1",43,0)
+ ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
+"RTN","PSBOMH1",44,0)
+ ....D INSTR^PSBOMH
+"RTN","PSBOMH1",45,0)
+ ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
+"RTN","PSBOMH1",46,0)
+ ...I PSBINIT[99 S PSBINIT=""
+"RTN","PSBOMH1",47,0)
+ ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("A")
+"RTN","PSBOMH1",48,0)
+ ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6)  D PSBCK1^PSBOMH2("B")
+"RTN","PSBOMH1",49,0)
+ ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
+"RTN","PSBOMH1",50,0)
+ ....D DDAUD
+"RTN","PSBOMH1",51,0)
+ ....S I="" F  S I=$O(PSBTAR(I),-1) Q:I=""  I $P(PSBTAR(I),U,1)=PSBDT D
+"RTN","PSBOMH1",52,0)
+ .....S PSBS=$P(PSBTAR(I),U,3)
+"RTN","PSBOMH1",53,0)
+ .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q  ; canceled - not given
+"RTN","PSBOMH1",54,0)
+ .....I PSBS="NOT GIVEN" Q
+"RTN","PSBOMH1",55,0)
+ .....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
+"RTN","PSBOMH1",56,0)
+ .....D PSBCTAR^PSBOMH2
+"RTN","PSBOMH1",57,0)
+ .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
+"RTN","PSBOMH1",58,0)
+ ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
+"RTN","PSBOMH1",59,0)
+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
+"RTN","PSBOMH1",60,0)
+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
+"RTN","PSBOMH1",61,0)
+ ...D PSBOUT($P((X),"^",1),$P((X),"^",2))
+"RTN","PSBOMH1",62,0)
+ ...Q
+"RTN","PSBOMH1",63,0)
+ ..; 1-Time On Call or PRN
+"RTN","PSBOMH1",64,0)
+ ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
+"RTN","PSBOMH1",65,0)
+ ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
+"RTN","PSBOMH1",66,0)
+ ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
+"RTN","PSBOMH1",67,0)
+ ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
+"RTN","PSBOMH1",68,0)
+ ...I PSBINIT="" S PSBINIT=99
+"RTN","PSBOMH1",69,0)
+ ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
+"RTN","PSBOMH1",70,0)
+ ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED"  D
+"RTN","PSBOMH1",71,0)
+ ....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA=""  I PSBXA?1.3N  S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
+"RTN","PSBOMH1",72,0)
+ ....F S=1:1 Q:PSBM<1  S PSBM=PSBZ-S  I (PSBM>0) I (PSBT(PSBM)["GIVEN")  S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
+"RTN","PSBOMH1",73,0)
+ ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
+"RTN","PSBOMH1",74,0)
+ ....D INSTR^PSBOMH
+"RTN","PSBOMH1",75,0)
+ ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
+"RTN","PSBOMH1",76,0)
+ ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D PSBOUT(PSBDT,PSBINIT)
+"RTN","PSBOMH1",77,0)
+ ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_"            "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
+"RTN","PSBOMH1",78,0)
+ ...I PSBINIT[99 S PSBINIT=""
+"RTN","PSBOMH1",79,0)
+ ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
+"RTN","PSBOMH1",80,0)
+ ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2="  Results: <No PRN Results On File>"
+"RTN","PSBOMH1",81,0)
+ ....E  D
+"RTN","PSBOMH1",82,0)
+ .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
+"RTN","PSBOMH1",83,0)
+ .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
+"RTN","PSBOMH1",84,0)
+ .....I PSBINIT="" S PSBINIT=99
+"RTN","PSBOMH1",85,0)
+ .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
+"RTN","PSBOMH1",86,0)
+ ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+"RTN","PSBOMH1",87,0)
+ ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
+"RTN","PSBOMH1",88,0)
+ .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,".")))  D
+"RTN","PSBOMH1",89,0)
+ ......D:$D(^PSB(53.79,PSBIEN,.9,0))
+"RTN","PSBOMH1",90,0)
+ .......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F  S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0  D  Q:PSBFG=1
+"RTN","PSBOMH1",91,0)
+ ........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
+"RTN","PSBOMH1",92,0)
+ .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_"  "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+"RTN","PSBOMH1",93,0)
+ .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
+"RTN","PSBOMH1",94,0)
+ .....S PSBLINE2="  Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
+"RTN","PSBOMH1",95,0)
+ .....S PSBRTXTW="     Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
+"RTN","PSBOMH1",96,0)
+ .....I PSBINIT[99 S PSBINIT=""
+"RTN","PSBOMH1",97,0)
+ ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
+"RTN","PSBOMH1",98,0)
+ ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
+"RTN","PSBOMH1",99,0)
+ ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
+"RTN","PSBOMH1",100,0)
+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
+"RTN","PSBOMH1",101,0)
+ ...I $G(PSBLINE2)]"" D
+"RTN","PSBOMH1",102,0)
+ ....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)="      "_PSBRTXTW
+"RTN","PSBOMH1",103,0)
+ ....I $L(PSBLINE2)>90 D
+"RTN","PSBOMH1",104,0)
+ .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
+"RTN","PSBOMH1",105,0)
+ .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)="           "_$E(PSBLINE2,91,161)
+"RTN","PSBOMH1",106,0)
+ .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)="      "_PSBRTXTW
+"RTN","PSBOMH1",107,0)
+ .....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)="     "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)="     "_PSBRTXTW
+"RTN","PSBOMH1",108,0)
+ Q
+"RTN","PSBOMH1",109,0)
+ ;
+"RTN","PSBOMH1",110,0)
+DDAUD ;  audits for dispen drugs
+"RTN","PSBOMH1",111,0)
+ ;
+"RTN","PSBOMH1",112,0)
+ M PSBMLA=^PSB(53.79,PSBIEN)
+"RTN","PSBOMH1",113,0)
+ S PSBGA="" I $D(PSBMLA(.9,0)) D
+"RTN","PSBOMH1",114,0)
+ .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D  Q
+"RTN","PSBOMH1",115,0)
+ ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
+"RTN","PSBOMH1",116,0)
+ ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
+"RTN","PSBOMH1",117,0)
+ ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
+"RTN","PSBOMH1",118,0)
+ ..S PSBGA=1
+"RTN","PSBOMH1",119,0)
+ .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX))  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
+"RTN","PSBOMH1",120,0)
+ ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
+"RTN","PSBOMH1",121,0)
+ ..S PSBGA=1
+"RTN","PSBOMH1",122,0)
+ I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
+"RTN","PSBOMH1",123,0)
+ S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBPQRY=PSBQRY S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
+"RTN","PSBOMH1",124,0)
+ .I PSBPQRY="PSBTMP" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no prev action
+"RTN","PSBOMH1",125,0)
+ .I $QS(PSBPQRY,2)="C"  S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; prev line = comment
+"RTN","PSBOMH1",126,0)
+ .I $QS(PSBQRY,2)="C",$E($P(@PSBPQRY,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBPQRY,U,2)=$P(@PSBQRY,U,2) D  Q
+"RTN","PSBOMH1",127,0)
+ ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
+"RTN","PSBOMH1",128,0)
+ .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
+"RTN","PSBOMH1",129,0)
+ Q
+"RTN","PSBOMH1",130,0)
+ ;
+"RTN","PSBOMH1",131,0)
+PSBOUT(PSBTET,PSBOT1) ;
+"RTN","PSBOMH1",132,0)
+ I '$D(^PSB(53.79,PSBIEN,.9,0))  D PSBENT^PSBOMH2(PSBOT1)
+"RTN","PSBOMH1",133,0)
+ S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
+"RTN","PSBOMH1",134,0)
+ S PSBXA1=0
+"RTN","PSBOMH1",135,0)
+ F  S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0  I PSBXA1'=0  D  Q:$G(PSBOT1)["*"
+"RTN","PSBOMH1",136,0)
+ .I $L(PSBXA1)<4  D
+"RTN","PSBOMH1",137,0)
+ ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET  D
+"RTN","PSBOMH1",138,0)
+ ...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
+"RTN","PSBOMH1",139,0)
+ ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct"  D
+"RTN","PSBOMH1",140,0)
+ ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
+"RTN","PSBOMH1",141,0)
+ ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
+"RTN","PSBOMH1",142,0)
+ I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
+"RTN","PSBOMH1",143,0)
+ .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
+"RTN","PSBOMH1",144,0)
+ I $G(PSBNAME)="" D
+"RTN","PSBOMH1",145,0)
+ . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
+"RTN","PSBOMH1",146,0)
+ I $G(PSBOT1)]""&($G(PSBNAME)]"") S ^TMP("PSB",$J,"LEGEND",PSBOT1,PSBNAME)="" ;MSC
+"RTN","PSBOMH1",147,0)
+ Q
+"RTN","PSBOMH1",148,0)
+ ;
+"RTN","PSBRPC2")
+0^39^B44967923
+"RTN","PSBRPC2",1,0)
+PSBRPC2 ;BIRMINGHAM/EFC,MSC/JDA - BCMA RPC BROKER CALLS ;27APR2009
+"RTN","PSBRPC2",2,0)
+ ;;3.0;BAR CODE MED ADMIN;**6,3,16,MSC**;Mar 2004
+"RTN","PSBRPC2",3,0)
+ ;
+"RTN","PSBRPC2",4,0)
+ ; Reference/IA
+"RTN","PSBRPC2",5,0)
+ ; File 50/221
+"RTN","PSBRPC2",6,0)
+ ; File 52.6/436
+"RTN","PSBRPC2",7,0)
+ ; File 52.7/437
+"RTN","PSBRPC2",8,0)
+ ; File 200/10060
+"RTN","PSBRPC2",9,0)
+ ;
+"RTN","PSBRPC2",10,0)
+GETOHIST(RESULTS,DFN,PSBORD) ;
+"RTN","PSBRPC2",11,0)
+ S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0
+"RTN","PSBRPC2",12,0)
+ S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
+"RTN","PSBRPC2",13,0)
+ D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
+"RTN","PSBRPC2",14,0)
+ D EN^PSBPOIV(DFN,PSBORD)
+"RTN","PSBRPC2",15,0)
+ S PSBUID=DFN_"V"_99999 F  S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID=""  D
+"RTN","PSBRPC2",16,0)
+ .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
+"RTN","PSBRPC2",17,0)
+ .I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q   ; only want the infusing bag on a dc'ed order
+"RTN","PSBRPC2",18,0)
+ .I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" S PSBOSTS="E" Q  ; only want the infusing bag on an expired order
+"RTN","PSBRPC2",19,0)
+ .I $P(PSBUIDS,U,2)'="" D  Q  ; get orders from med log (53.79)
+"RTN","PSBRPC2",20,0)
+ ..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
+"RTN","PSBRPC2",21,0)
+ ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
+"RTN","PSBRPC2",22,0)
+ ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
+"RTN","PSBRPC2",23,0)
+ ..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
+"RTN","PSBRPC2",24,0)
+ ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
+"RTN","PSBRPC2",25,0)
+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
+"RTN","PSBRPC2",26,0)
+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
+"RTN","PSBRPC2",27,0)
+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
+"RTN","PSBRPC2",28,0)
+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
+"RTN","PSBRPC2",29,0)
+ .I $P(PSBUIDS,U,1)="I" Q  ; IV parameters say bag is invalid
+"RTN","PSBRPC2",30,0)
+ .I $P(PSBUIDS,U,8)'="",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q  ; label has been reprinted/distroyed etc. - bag is not infusing or stopped
+"RTN","PSBRPC2",31,0)
+ .S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
+"RTN","PSBRPC2",32,0)
+ .S PSBUIDP=$P(PSBUIDS,U,10,999)
+"RTN","PSBRPC2",33,0)
+ .F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY=""  D
+"RTN","PSBRPC2",34,0)
+ ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
+"RTN","PSBRPC2",35,0)
+ ..I $P(PSBMEDTY,";",1)="ADD" F Z=1:1 S PSBAD=$G(PSBADA(Z)) Q:PSBAD=""  I $P(PSBADA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBADA(Z) Q
+"RTN","PSBRPC2",36,0)
+ ..I $P(PSBMEDTY,";",1)="SOL" F Z=1:1 S PSBSOL=$G(PSBSOLA(Z)) Q:PSBSOL=""  I $P(PSBSOLA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBSOLA(Z) Q
+"RTN","PSBRPC2",37,0)
+ .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
+"RTN","PSBRPC2",38,0)
+ .S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
+"RTN","PSBRPC2",39,0)
+ F II=1:1 S I=$P(PSBONXS,U,II) Q:I=""  D  ; get ward stocks
+"RTN","PSBRPC2",40,0)
+ .S PSBUID="" F  S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID=""  D
+"RTN","PSBRPC2",41,0)
+ ..I PSBUID'["WS" Q  ; not a ward stock
+"RTN","PSBRPC2",42,0)
+ ..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
+"RTN","PSBRPC2",43,0)
+ ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
+"RTN","PSBRPC2",44,0)
+ ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
+"RTN","PSBRPC2",45,0)
+ ..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q  ; want "not completed" on DC'ed orders
+"RTN","PSBRPC2",46,0)
+ ..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
+"RTN","PSBRPC2",47,0)
+ ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
+"RTN","PSBRPC2",48,0)
+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
+"RTN","PSBRPC2",49,0)
+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
+"RTN","PSBRPC2",50,0)
+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0))  S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
+"RTN","PSBRPC2",51,0)
+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
+"RTN","PSBRPC2",52,0)
+ S ^TMP("PSB",$J,0)=PSB
+"RTN","PSBRPC2",53,0)
+ K ^TMP("PSBAR",$J)
+"RTN","PSBRPC2",54,0)
+ Q
+"RTN","PSBRPC2",55,0)
+ ;
+"RTN","PSBRPC2",56,0)
+BAGDTL(RESULTS,PSBUID,PSBORD)  ; bag detail
+"RTN","PSBRPC2",57,0)
+ I '$G(DFN)!PSBUID S DFN=+PSBUID ;**GFT/MSC
+"RTN","PSBRPC2",58,0)
+ S (PSBIEN,X)="" F  S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X=""  S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
+"RTN","PSBRPC2",59,0)
+ I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
+"RTN","PSBRPC2",60,0)
+ M PSBMLA=^PSB(53.79,PSBIEN)
+"RTN","PSBRPC2",61,0)
+ S X=$P(^PSB(53.79,PSBIEN,0),U,9)
+"RTN","PSBRPC2",62,0)
+ S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION")
+"RTN","PSBRPC2",63,0)
+ ; comments
+"RTN","PSBRPC2",64,0)
+ S PSBX="0" F  S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX=""  S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1)
+"RTN","PSBRPC2",65,0)
+ ; audit
+"RTN","PSBRPC2",66,0)
+ S PSBGA="" I $D(PSBMLA(.9,0)) D
+"RTN","PSBRPC2",67,0)
+ .S PSBX="0" F  S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX=""  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D  Q
+"RTN","PSBRPC2",68,0)
+ ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
+"RTN","PSBRPC2",69,0)
+ ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
+"RTN","PSBRPC2",70,0)
+ ..S PSBGA=1
+"RTN","PSBRPC2",71,0)
+ .S PSBX="0" F  S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX=""  I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS"))  D
+"RTN","PSBRPC2",72,0)
+ ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
+"RTN","PSBRPC2",73,0)
+ ..S PSBGA=1
+"RTN","PSBRPC2",74,0)
+ I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC
+"RTN","PSBRPC2",75,0)
+ S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBPQRY=PSBQRY S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
+"RTN","PSBRPC2",76,0)
+ .I PSBPQRY="PSBTMP" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no previous action
+"RTN","PSBRPC2",77,0)
+ .I $QS(PSBPQRY,2)="C"  S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; previous line is a comment
+"RTN","PSBRPC2",78,0)
+ .I $QS(PSBQRY,2)="C",$E($P(@PSBPQRY,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBPQRY,U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q
+"RTN","PSBRPC2",79,0)
+ .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
+"RTN","PSBRPC2",80,0)
+ S RESULTS(0)=PSBCNT-1
+"RTN","PSBRPC2",81,0)
+ K PSBMLA,PSBIEN,PSBTMP,PSBQRY
+"RTN","PSBRPC2",82,0)
+ Q
+"RTN","PSBRPC2",83,0)
+ ;
+"RTN","PSBRPC2",84,0)
+INITIAL(PSBDUZ) ;
+"RTN","PSBRPC2",85,0)
+ Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
+"RTN","PSBRPC2",86,0)
+SCANMED(RESULTS,PSBDIEN,PSBTAB)  ; Lookup Medication
+"RTN","PSBRPC2",87,0)
+ ;
+"RTN","PSBRPC2",88,0)
+ ; RPC: PSB SCANMED
+"RTN","PSBRPC2",89,0)
+ ;
+"RTN","PSBRPC2",90,0)
+ ; Description:
+"RTN","PSBRPC2",91,0)
+ ; Does a lookup on file 50 returns -1 on invalid lookup or
+"RTN","PSBRPC2",92,0)
+ ; IEN^DrugName on success
+"RTN","PSBRPC2",93,0)
+ ;
+"RTN","PSBRPC2",94,0)
+ D NOW^%DTC S PSBDT=%
+"RTN","PSBRPC2",95,0)
+ S PSBCNT=0
+"RTN","PSBRPC2",96,0)
+ I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
+"RTN","PSBRPC2",97,0)
+ S RESULTS(PSBCNT)=1
+"RTN","PSBRPC2",98,0)
+ S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
+"RTN","PSBRPC2",99,0)
+ I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11)
+"RTN","PSBRPC2",100,0)
+ I PSBTAB="UDTAB" D  Q
+"RTN","PSBRPC2",101,0)
+ .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
+"RTN","PSBRPC2",102,0)
+ .I X<1 Q
+"RTN","PSBRPC2",103,0)
+ .E  S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
+"RTN","PSBRPC2",104,0)
+ ;
+"RTN","PSBRPC2",105,0)
+ ; IV/IVPB ward stock scan
+"RTN","PSBRPC2",106,0)
+ ;
+"RTN","PSBRPC2",107,0)
+ S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
+"RTN","PSBRPC2",108,0)
+ S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
+"RTN","PSBRPC2",109,0)
+ I $D(^PSDRUG("A527",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X=""  D
+"RTN","PSBRPC2",110,0)
+ .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
+"RTN","PSBRPC2",111,0)
+ .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
+"RTN","PSBRPC2",112,0)
+ I $D(^PSDRUG("A526",PSBDIEN)) S X="" F  S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X=""  D
+"RTN","PSBRPC2",113,0)
+ .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
+"RTN","PSBRPC2",114,0)
+ .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
+"RTN","PSBRPC2",115,0)
+ ;
+"RTN","PSBRPC2",116,0)
+ I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
+"RTN","PSBRPC2",117,0)
+ Q
+"RTN","PSBRPC2",118,0)
+ ;
+"RTN","PXRMTMED")
+0^40^B9970277
+"RTN","PXRMTMED",1,0)
+PXRMTMED ; SLC/PKR/PJH,MSC/JDA - Edit a reminder term. ;27APR2009
+"RTN","PXRMTMED",2,0)
+ ;;2.0;CLINICAL REMINDERS;**1,MSC**;Feb 04, 2005
+"RTN","PXRMTMED",3,0)
+ ;
+"RTN","PXRMTMED",4,0)
+ ;=======================================================
+"RTN","PXRMTMED",5,0)
+ N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y
+"RTN","PXRMTMED",6,0)
+GETNAME ;Get the name of the term to edit.
+"RTN","PXRMTMED",7,0)
+ K DA,DIC,DLAYGO,DTOUT,DUOUT,Y
+"RTN","PXRMTMED",8,0)
+ S DIC="^PXRMD(811.5,"
+"RTN","PXRMTMED",9,0)
+ S DIC(0)="AEMQL"
+"RTN","PXRMTMED",10,0)
+ S DIC("A")="Select Reminder Term: "
+"RTN","PXRMTMED",11,0)
+ S DLAYGO=811.5
+"RTN","PXRMTMED",12,0)
+ ;Set the starting place for additions.
+"RTN","PXRMTMED",13,0)
+ D SETSTART^PXRMCOPY(DIC)
+"RTN","PXRMTMED",14,0)
+ W !
+"RTN","PXRMTMED",15,0)
+ D ^DIC
+"RTN","PXRMTMED",16,0)
+ I ($D(DTOUT))!($D(DUOUT)) Q
+"RTN","PXRMTMED",17,0)
+ I Y=-1 G END
+"RTN","PXRMTMED",18,0)
+ S DA=$P(Y,U,1)
+"RTN","PXRMTMED",19,0)
+ S CS1=$$FILE^PXRMEXCS(811.5,DA)
+"RTN","PXRMTMED",20,0)
+ D EDIT(DIC,DA)
+"RTN","PXRMTMED",21,0)
+ I $G(DA)="" G GETNAME
+"RTN","PXRMTMED",22,0)
+ S CS2=$$FILE^PXRMEXCS(811.5,DA)
+"RTN","PXRMTMED",23,0)
+ I CS2=0 G GETNAME
+"RTN","PXRMTMED",24,0)
+ I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
+"RTN","PXRMTMED",25,0)
+ G GETNAME
+"RTN","PXRMTMED",26,0)
+END ;
+"RTN","PXRMTMED",27,0)
+ Q
+"RTN","PXRMTMED",28,0)
+ ;
+"RTN","PXRMTMED",29,0)
+ ;=======================================================
+"RTN","PXRMTMED",30,0)
+EDIT(ROOT,DA) ;
+"RTN","PXRMTMED",31,0)
+ N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y
+"RTN","PXRMTMED",32,0)
+ ;PXRMTMD is set by a xref on the .01 as a flag that the entire
+"RTN","PXRMTMED",33,0)
+ ;entry is being deleted.
+"RTN","PXRMTMED",34,0)
+ S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1)
+"RTN","PXRMTMED",35,0)
+ S DIE=ROOT
+"RTN","PXRMTMED",36,0)
+ I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D
+"RTN","PXRMTMED",37,0)
+ . S DR=".01"
+"RTN","PXRMTMED",38,0)
+ . D ^DIE
+"RTN","PXRMTMED",39,0)
+ . I $G(DA)'="" D CLASS(DA,DIE)
+"RTN","PXRMTMED",40,0)
+ I $G(DA)="" Q
+"RTN","PXRMTMED",41,0)
+ S TCONT=1
+"RTN","PXRMTMED",42,0)
+ F  D FINDING(DIE,DA)  Q:TCONT=0
+"RTN","PXRMTMED",43,0)
+ Q
+"RTN","PXRMTMED",44,0)
+ ;
+"RTN","PXRMTMED",45,0)
+ ;=======================================================
+"RTN","PXRMTMED",46,0)
+FINDING(DIE,DA,LIST) ;
+"RTN","PXRMTMED",47,0)
+ N CFIEN,GLOB,IEN,LIST,NODE,WPIEN
+"RTN","PXRMTMED",48,0)
+ N DEF,DEF1,DEF2,STATUS
+"RTN","PXRMTMED",49,0)
+ S STATUS=0
+"RTN","PXRMTMED",50,0)
+ D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)
+"RTN","PXRMTMED",51,0)
+ S NODE="^PXRMD(811.5)"
+"RTN","PXRMTMED",52,0)
+ D LIST^PXRMREDT(NODE,DA,.LIST)
+"RTN","PXRMTMED",53,0)
+ D DSPALL^PXRMREDF("T",NODE,DA,.LIST)
+"RTN","PXRMTMED",54,0)
+ S DA(1)=DA
+"RTN","PXRMTMED",55,0)
+ S IEN=DA
+"RTN","PXRMTMED",56,0)
+ S DIC=DIE_DA(1)_",20,"
+"RTN","PXRMTMED",57,0)
+ S DIC(0)="QEAL"
+"RTN","PXRMTMED",58,0)
+ S DIC("A")="Select Finding: "
+"RTN","PXRMTMED",59,0)
+ D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q
+"RTN","PXRMTMED",60,0)
+ S DIE=DIC
+"RTN","PXRMTMED",61,0)
+ S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
+"RTN","PXRMTMED",62,0)
+ I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D
+"RTN","PXRMTMED",63,0)
+ .I $D(^PXRMD(811.4,CFIEN,1))>0 D
+"RTN","PXRMTMED",64,0)
+ ..W !!,"Computed Finding Description:" S WPIEN=0
+"RTN","PXRMTMED",65,0)
+ ..F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
+"RTN","PXRMTMED",66,0)
+ ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
+"RTN","PXRMTMED",67,0)
+ .E  W !!,"No description defined for this computed finding"
+"RTN","PXRMTMED",68,0)
+ .W !
+"RTN","PXRMTMED",69,0)
+ W !,"Editing Finding Number: "_$G(DA)
+"RTN","PXRMTMED",70,0)
+ ;Finding record fields
+"RTN","PXRMTMED",71,0)
+ S DR=".01;9;12;17"
+"RTN","PXRMTMED",72,0)
+ S DR=DR_";14;15;18"
+"RTN","PXRMTMED",73,0)
+ I GLOB="PXRMD(811.4," S DR=DR_";26"
+"RTN","PXRMTMED",74,0)
+ ;Taxonomy - use inactive problems
+"RTN","PXRMTMED",75,0)
+ I GLOB="PXD(811.2," S DR=DR_";10",STATUS=1
+"RTN","PXRMTMED",76,0)
+ ;Health Factor - within category rank
+"RTN","PXRMTMED",77,0)
+ I GLOB="AUTTHF(" S DR=DR_";11"
+"RTN","PXRMTMED",78,0)
+ ;Mental Health - scale
+"RTN","PXRMTMED",79,0)
+ I GLOB="YTT(601," S DR=DR_";13"
+"RTN","PXRMTMED",80,0)
+ I GLOB="RAMIS(71,"!(GLOB="ORD(101.43,") S DR=DR_";16",STATUS=1
+"RTN","PXRMTMED",81,0)
+ ;Rx Type
+"RTN","PXRMTMED",82,0)
+ I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16",STATUS=1
+"RTN","PXRMTMED",83,0)
+ ;Condition
+"RTN","PXRMTMED",84,0)
+ ;
+"RTN","PXRMTMED",85,0)
+ ;Edit finding record
+"RTN","PXRMTMED",86,0)
+ D ^DIE
+"RTN","PXRMTMED",87,0)
+ I STATUS=1,$D(DA)>0 D STATUS^PXRMSTA1(.DA,"T")
+"RTN","PXRMTMED",88,0)
+ S $P(^PXRMD(811.5,IEN,20,0),U,3)=0
+"RTN","PXRMTMED",89,0)
+ Q
+"RTN","PXRMTMED",90,0)
+ ;
+"RTN","PXRMTMED",91,0)
+ ;=======================================================
+"RTN","PXRMTMED",92,0)
+CLASS(DA,DIE) ;
+"RTN","PXRMTMED",93,0)
+ F  D  Q:RESULT'=0
+"RTN","PXRMTMED",94,0)
+ . N DR,RESULT,X,Y
+"RTN","PXRMTMED",95,0)
+ . W !
+"RTN","PXRMTMED",96,0)
+ . S DR="100" D ^DIE I $D(Y) Q
+"RTN","PXRMTMED",97,0)
+ . ;Sponsor
+"RTN","PXRMTMED",98,0)
+ . S DR="101" D ^DIE I $D(Y) Q
+"RTN","PXRMTMED",99,0)
+ . ;Make sure Class and Sponsor Class are in synch.
+"RTN","PXRMTMED",100,0)
+ . S RESULT=$$VSPONSOR^PXRMINTR(X)
+"RTN","PXRMTMED",101,0)
+ . Q
+"RTN","PXRMTMED",102,0)
+ ;Review date, Usage
+"RTN","PXRMTMED",103,0)
+ S DR="102;1" D ^DIE I $D(Y) Q
+"RTN","PXRMTMED",104,0)
+ Q
+"RTN","PXRMTMED",105,0)
+ ;
+"RTN","RORHL7A")
+0^32^B35660209
+"RTN","RORHL7A",1,0)
+RORHL7A ;HCIOFO/SG MSC/JDS- HL7 UTILITIES ;30APR2009
+"RTN","RORHL7A",2,0)
+ ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
+"RTN","RORHL7A",3,0)
+ ;
+"RTN","RORHL7A",4,0)
+ Q
+"RTN","RORHL7A",5,0)
+ ;
+"RTN","RORHL7A",6,0)
+ ;***** ADDS THE SEGMENT TO THE HL7 MESSAGE BUFFER
+"RTN","RORHL7A",7,0)
+ ;
+"RTN","RORHL7A",8,0)
+ ; SEG           Complete HL7 segment
+"RTN","RORHL7A",9,0)
+ ;
+"RTN","RORHL7A",10,0)
+ ; The ADDSEGC^RORHL7A procedure adds the HL7 segment to the HL7
+"RTN","RORHL7A",11,0)
+ ; message buffer defined by the ROREXT("HL7BUF") parameter
+"RTN","RORHL7A",12,0)
+ ; (the ^TMP("HLS",$J), by default). The <TAB>, <CR> and <LF>
+"RTN","RORHL7A",13,0)
+ ; characters are replaced with spaces. Long segments are split
+"RTN","RORHL7A",14,0)
+ ; among sub-nodes of the main segment node in the destination
+"RTN","RORHL7A",15,0)
+ ; buffer.
+"RTN","RORHL7A",16,0)
+ ;
+"RTN","RORHL7A",17,0)
+ ; The RORHL array and some nodes of the ROREXT array must be
+"RTN","RORHL7A",18,0)
+ ; initialized (either by the $$INIT^RORHL7 or manually) before
+"RTN","RORHL7A",19,0)
+ ; calling this procedure.
+"RTN","RORHL7A",20,0)
+ ;
+"RTN","RORHL7A",21,0)
+ADDSEGC(SEG) ;
+"RTN","RORHL7A",22,0)
+ N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL
+"RTN","RORHL7A",23,0)
+ S NODE=ROREXT("HL7BUF"),PTR=$G(ROREXT("HL7PTR"))+1
+"RTN","RORHL7A",24,0)
+ S HLFS=RORHL("FS"),HLECH=RORHL("ECH")
+"RTN","RORHL7A",25,0)
+ Q:$P(SEG,HLFS)=""  ; Segment Name
+"RTN","RORHL7A",26,0)
+ ;--- Assign the Set ID if necessary
+"RTN","RORHL7A",27,0)
+ S SID=$$SETID($P(SEG,HLFS))
+"RTN","RORHL7A",28,0)
+ S:SID>0 $P(SEG,HLFS,2)=SID
+"RTN","RORHL7A",29,0)
+ ;--- Remove empty trailing fields
+"RTN","RORHL7A",30,0)
+ S I2=$L(SEG,HLFS)
+"RTN","RORHL7A",31,0)
+ F I1=I2:-1:1  Q:$TR($P(SEG,HLFS,I1),HLECH)'=""
+"RTN","RORHL7A",32,0)
+ S:I1<I2 $P(SEG,HLFS,I1+1,I2)=""
+"RTN","RORHL7A",33,0)
+ ;--- Store the segment
+"RTN","RORHL7A",34,0)
+ S SL=$L(SEG),MAXLEN=245  K @NODE@(PTR)
+"RTN","RORHL7A",35,0)
+ S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13),"   ")
+"RTN","RORHL7A",36,0)
+ S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+SL+1
+"RTN","RORHL7A",37,0)
+ ;--- Split the segment into sub-nodes if necessary
+"RTN","RORHL7A",38,0)
+ D:SL>MAXLEN
+"RTN","RORHL7A",39,0)
+ . S I2=MAXLEN
+"RTN","RORHL7A",40,0)
+ . F PTR1=1:1  S I1=I2+1,I2=I1+MAXLEN-1  Q:I1>SL  D
+"RTN","RORHL7A",41,0)
+ . . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13),"   ")
+"RTN","RORHL7A",42,0)
+ ;--- Save the pointer
+"RTN","RORHL7A",43,0)
+ S ROREXT("HL7PTR")=PTR
+"RTN","RORHL7A",44,0)
+ Q
+"RTN","RORHL7A",45,0)
+ ;
+"RTN","RORHL7A",46,0)
+ ;***** ASSEMBLES THE SEGMENT AND ADDS IT TO THE HL7 MESSAGE BUFFER
+"RTN","RORHL7A",47,0)
+ ;
+"RTN","RORHL7A",48,0)
+ ; .FIELDS       Reference to a local variable where the HL7
+"RTN","RORHL7A",49,0)
+ ;               fields are stored
+"RTN","RORHL7A",50,0)
+ ;
+"RTN","RORHL7A",51,0)
+ ;  FIELDS(
+"RTN","RORHL7A",52,0)
+ ;    0)         Segment name
+"RTN","RORHL7A",53,0)
+ ;    I,         Field value
+"RTN","RORHL7A",54,0)
+ ;      i)       Continuation of the value if it is
+"RTN","RORHL7A",55,0)
+ ;    ...        longer than than 245 characters
+"RTN","RORHL7A",56,0)
+ ;
+"RTN","RORHL7A",57,0)
+ ; The ADDSEGF^RORHL7A procedure assembles the HL7 segment from
+"RTN","RORHL7A",58,0)
+ ; provided field values and adds it to the HL7 message buffer
+"RTN","RORHL7A",59,0)
+ ; defined by the ROREXT("HL7BUF") node (the ^TMP("HLS",$J), by
+"RTN","RORHL7A",60,0)
+ ; default). The <TAB>, <CR> and <LF> characters are replaced with
+"RTN","RORHL7A",61,0)
+ ; spaces. Long segments are split among sub-nodes of the main
+"RTN","RORHL7A",62,0)
+ ; segment node in the destination buffer.
+"RTN","RORHL7A",63,0)
+ ;
+"RTN","RORHL7A",64,0)
+ ; The RORHL array and some nodes of the ROREXT array must be
+"RTN","RORHL7A",65,0)
+ ; initialized (either by the $$INIT^RORHL7 or manually) before
+"RTN","RORHL7A",66,0)
+ ; calling this procedure.
+"RTN","RORHL7A",67,0)
+ ;
+"RTN","RORHL7A",68,0)
+ADDSEGF(FIELDS) ;
+"RTN","RORHL7A",69,0)
+ ; RORBUF        Temporary buffer for the segment construction
+"RTN","RORHL7A",70,0)
+ ; RORIS         Current continuation subscript in the HL7 buffer
+"RTN","RORHL7A",71,0)
+ ; RORNODE       Closed root of the HL7 message buffer
+"RTN","RORHL7A",72,0)
+ ; RORPTR        Current subscript in the HL7 message buffer
+"RTN","RORHL7A",73,0)
+ ; RORSL         Number of characters that can be appended to the
+"RTN","RORHL7A",74,0)
+ ;               RORBUF before it has to be emptied into the HL7
+"RTN","RORHL7A",75,0)
+ ;               message buffer
+"RTN","RORHL7A",76,0)
+ ;
+"RTN","RORHL7A",77,0)
+ N FLD,I,LASTFLD,RORBUF,RORIS,RORNODE,RORPTR,RORSL
+"RTN","RORHL7A",78,0)
+ Q:$G(FIELDS(0))=""  ; Segment Name
+"RTN","RORHL7A",79,0)
+ S RORNODE=ROREXT("HL7BUF"),RORPTR=$G(ROREXT("HL7PTR"))+1
+"RTN","RORHL7A",80,0)
+ S HLFS=RORHL("FS"),HLECH=RORHL("ECH")
+"RTN","RORHL7A",81,0)
+ ;--- Assign the Set ID if necessary
+"RTN","RORHL7A",82,0)
+ S I=$$SETID(FIELDS(0))
+"RTN","RORHL7A",83,0)
+ S:I>0 FIELDS(1)=I
+"RTN","RORHL7A",84,0)
+ ;--- Remove empty trailing fields
+"RTN","RORHL7A",85,0)
+ S I=$NA(FIELDS)
+"RTN","RORHL7A",86,0)
+ N A,CNT F  S I=$Q(@I)  Q:I=""  S CNT=$G(CNT)+1,A(CNT)=I I $TR(@I,HLECH)'=""  K A,CNT
+"RTN","RORHL7A",87,0)
+ F I=1:1 Q:'$D(A(I))  K @A(I)
+"RTN","RORHL7A",88,0)
+ ;--- Initialize construction variables
+"RTN","RORHL7A",89,0)
+ S RORBUF=FIELDS(0),I=$L(RORBUF)
+"RTN","RORHL7A",90,0)
+ S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+I+1
+"RTN","RORHL7A",91,0)
+ S RORIS=0,RORSL=245-I
+"RTN","RORHL7A",92,0)
+ ;--- Append the fields and store the segment
+"RTN","RORHL7A",93,0)
+ S LASTFLD=+$O(FIELDS(" "),-1)
+"RTN","RORHL7A",94,0)
+ F FLD=1:1:LASTFLD  D
+"RTN","RORHL7A",95,0)
+ . D APPEND(HLFS_$G(FIELDS(FLD)))
+"RTN","RORHL7A",96,0)
+ . ;--- Process the field continuation nodes
+"RTN","RORHL7A",97,0)
+ . S I=""
+"RTN","RORHL7A",98,0)
+ . F  S I=$O(FIELDS(FLD,I))  Q:I=""  D APPEND(FIELDS(FLD,I))
+"RTN","RORHL7A",99,0)
+ ;--- Flush the buffer if necessary
+"RTN","RORHL7A",100,0)
+ D:RORBUF'=""
+"RTN","RORHL7A",101,0)
+ . I 'RORIS  S @RORNODE@(RORPTR)=RORBUF  Q
+"RTN","RORHL7A",102,0)
+ . S @RORNODE@(RORPTR,RORIS)=RORBUF
+"RTN","RORHL7A",103,0)
+ S ROREXT("HL7PTR")=RORPTR
+"RTN","RORHL7A",104,0)
+ Q
+"RTN","RORHL7A",105,0)
+ ;
+"RTN","RORHL7A",106,0)
+ ;***** APPENDS THE FIELD VALUE TO THE HL7 SEGMENT
+"RTN","RORHL7A",107,0)
+ ;
+"RTN","RORHL7A",108,0)
+ ; VAL           Value of the field (or its part)
+"RTN","RORHL7A",109,0)
+ ;
+"RTN","RORHL7A",110,0)
+ ; This is an internal function. Do not call it directly.
+"RTN","RORHL7A",111,0)
+ ;
+"RTN","RORHL7A",112,0)
+APPEND(VAL) ;
+"RTN","RORHL7A",113,0)
+ N BASE,L
+"RTN","RORHL7A",114,0)
+ S VAL=$TR(VAL,$C(9,10,13),"   "),L=$L(VAL)
+"RTN","RORHL7A",115,0)
+ S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+L
+"RTN","RORHL7A",116,0)
+ I L'>RORSL  S RORBUF=RORBUF_VAL,RORSL=RORSL-L  Q
+"RTN","RORHL7A",117,0)
+ ;---
+"RTN","RORHL7A",118,0)
+ S RORBUF=RORBUF_$E(VAL,1,RORSL),L=L-RORSL
+"RTN","RORHL7A",119,0)
+ S BASE=1
+"RTN","RORHL7A",120,0)
+ F  D  Q:L'>0
+"RTN","RORHL7A",121,0)
+ . I 'RORIS  S @RORNODE@(RORPTR)=RORBUF
+"RTN","RORHL7A",122,0)
+ . E  S @RORNODE@(RORPTR,RORIS)=RORBUF
+"RTN","RORHL7A",123,0)
+ . S BASE=BASE+RORSL,RORIS=RORIS+1,RORSL=245
+"RTN","RORHL7A",124,0)
+ . S RORBUF=$E(VAL,BASE,BASE+RORSL-1),L=L-RORSL
+"RTN","RORHL7A",125,0)
+ S RORSL=-L
+"RTN","RORHL7A",126,0)
+ Q
+"RTN","RORHL7A",127,0)
+ ;
+"RTN","RORHL7A",128,0)
+ ;***** RETURNS THE BHS SEGMENT
+"RTN","RORHL7A",129,0)
+ ;
+"RTN","RORHL7A",130,0)
+ ; BID           Batch message ID
+"RTN","RORHL7A",131,0)
+ ;
+"RTN","RORHL7A",132,0)
+ ; [BDT]         Batch message creation time in internal FileMan
+"RTN","RORHL7A",133,0)
+ ;               format (NOW by default)
+"RTN","RORHL7A",134,0)
+ ;
+"RTN","RORHL7A",135,0)
+ ; [COMMENT]     Optional comment
+"RTN","RORHL7A",136,0)
+ ;
+"RTN","RORHL7A",137,0)
+ ; The RORHL local variable must be initialized by the $$INIT^RORHL7
+"RTN","RORHL7A",138,0)
+ ; function before calling this entry point.
+"RTN","RORHL7A",139,0)
+ ;
+"RTN","RORHL7A",140,0)
+BHS(BID,BDT,COMMENT) ;
+"RTN","RORHL7A",141,0)
+ N CS,SEG,TMP
+"RTN","RORHL7A",142,0)
+ D BHS^HLFNC3(.RORHL,BID,.SEG)
+"RTN","RORHL7A",143,0)
+ Q:$G(SEG)="" ""
+"RTN","RORHL7A",144,0)
+ S HLFS=RORHL("FS"),HLECH=RORHL("ECH"),CS=$E(HLECH,1)
+"RTN","RORHL7A",145,0)
+ ;--- Post-processing
+"RTN","RORHL7A",146,0)
+ S SEG=SEG_$G(SEG(1))
+"RTN","RORHL7A",147,0)
+ S:$G(BDT)'>0 BDT=$$NOW^XLFDT
+"RTN","RORHL7A",148,0)
+ S TMP=$E($P($$SITE^VASITE,U,3),1,3)
+"RTN","RORHL7A",149,0)
+ S $P(SEG,HLFS,4)=TMP_CS_$G(^XMB("NETNAME"))_CS_"DNS"
+"RTN","RORHL7A",150,0)
+ S $P(SEG,HLFS,5)="ROR AAC"
+"RTN","RORHL7A",151,0)
+ S $P(SEG,HLFS,7)=$$FMTHL7^XLFDT(BDT)
+"RTN","RORHL7A",152,0)
+ S TMP=$P(SEG,HLFS,9)
+"RTN","RORHL7A",153,0)
+ S $P(TMP,CS,3)=$P(TMP,CS,3)_$E(HLECH,2)_$G(RORHL("ETN"))
+"RTN","RORHL7A",154,0)
+ S $P(SEG,HLFS,9)=TMP
+"RTN","RORHL7A",155,0)
+ S $P(SEG,HLFS,10)=$G(COMMENT)
+"RTN","RORHL7A",156,0)
+ Q SEG
+"RTN","RORHL7A",157,0)
+ ;
+"RTN","RORHL7A",158,0)
+ ;***** RETURNS BTS SEGMENT
+"RTN","RORHL7A",159,0)
+ ;
+"RTN","RORHL7A",160,0)
+ ; MSGCNT        Batch message count
+"RTN","RORHL7A",161,0)
+ ; [COMMENT]     Batch comment
+"RTN","RORHL7A",162,0)
+ ;
+"RTN","RORHL7A",163,0)
+ ; The RORHL variable must be initialized by the INIT^HLFNC2 before
+"RTN","RORHL7A",164,0)
+ ; calling this entry point
+"RTN","RORHL7A",165,0)
+ ;
+"RTN","RORHL7A",166,0)
+BTS(MSGCNT,COMMENT) ;
+"RTN","RORHL7A",167,0)
+ Q "BTS"_RORHL("FS")_MSGCNT_RORHL("FS")_$G(COMMENT)
+"RTN","RORHL7A",168,0)
+ ;
+"RTN","RORHL7A",169,0)
+ ;***** LOADS THE HL7 FIELD (OR ITS PART) TO THE BUFFER
+"RTN","RORHL7A",170,0)
+ ;
+"RTN","RORHL7A",171,0)
+ ; VAL           Value of the field (or its part)
+"RTN","RORHL7A",172,0)
+ ;
+"RTN","RORHL7A",173,0)
+ ; FLD           Number of the field in the segment (piece number)
+"RTN","RORHL7A",174,0)
+ ;
+"RTN","RORHL7A",175,0)
+FIELD(VAL,FLD) ;
+"RTN","RORHL7A",176,0)
+ N BASE,L
+"RTN","RORHL7A",177,0)
+ S:FLD>RORFLD RORFLD=FLD,RORIS=0,RORSL=245
+"RTN","RORHL7A",178,0)
+ S L=$L(VAL),BASE=1
+"RTN","RORHL7A",179,0)
+ F RORIS=RORIS:1  D  Q:L'>0
+"RTN","RORHL7A",180,0)
+ . I 'RORIS  S RORSEG(RORFLD)=$G(RORSEG(RORFLD))_$E(VAL,BASE,BASE+RORSL-1)
+"RTN","RORHL7A",181,0)
+ . E  S RORSEG(RORFLD,RORIS)=$G(RORSEG(RORFLD,RORIS))_$E(VAL,BASE,BASE+RORSL-1)
+"RTN","RORHL7A",182,0)
+ . S BASE=BASE+RORSL,L=L-RORSL,RORSL=245
+"RTN","RORHL7A",183,0)
+ S RORSL=-L
+"RTN","RORHL7A",184,0)
+ Q
+"RTN","RORHL7A",185,0)
+ ;
+"RTN","RORHL7A",186,0)
+ ;***** LOADS THE HL7 SEGMENT INTO THE RPOVIDED BUFFER
+"RTN","RORHL7A",187,0)
+ ;
+"RTN","RORHL7A",188,0)
+ ; .RORSEG       Reference to a local variable where the HL7
+"RTN","RORHL7A",189,0)
+ ;               fields will be stored. The fields are stored
+"RTN","RORHL7A",190,0)
+ ;               in the following format:
+"RTN","RORHL7A",191,0)
+ ;
+"RTN","RORHL7A",192,0)
+ ;                 RORSEG(FldNum)=FldVal
+"RTN","RORHL7A",193,0)
+ ;
+"RTN","RORHL7A",194,0)
+ ;               If the value is longer that 245 characters then
+"RTN","RORHL7A",195,0)
+ ;               the continuation nodes are created:
+"RTN","RORHL7A",196,0)
+ ;
+"RTN","RORHL7A",197,0)
+ ;                 RORSEG(FldNum,#)=FldValCont
+"RTN","RORHL7A",198,0)
+ ;
+"RTN","RORHL7A",199,0)
+ ; ROR8SRC       Closed root of the source buffer containing
+"RTN","RORHL7A",200,0)
+ ;               the HL7 segment
+"RTN","RORHL7A",201,0)
+ ;
+"RTN","RORHL7A",202,0)
+LOADSEG(RORSEG,ROR8SRC) ;
+"RTN","RORHL7A",203,0)
+ N BUF,FLD,I,IFL,NFL,RORFLD,RORIS,RORSL
+"RTN","RORHL7A",204,0)
+ S HLFS=RORHL("FS")  K RORSEG
+"RTN","RORHL7A",205,0)
+ ;--- Process the main segment
+"RTN","RORHL7A",206,0)
+ S BUF=$G(@ROR8SRC),NFL=$L(BUF,HLFS)
+"RTN","RORHL7A",207,0)
+ F IFL=1:1:NFL  S RORSEG(IFL-1)=$P(BUF,HLFS,IFL)
+"RTN","RORHL7A",208,0)
+ Q:$D(@ROR8SRC)<10
+"RTN","RORHL7A",209,0)
+ ;--- Process the sub-segments
+"RTN","RORHL7A",210,0)
+ S (FLD,RORFLD)=NFL-1,RORIS=0,RORSL=245-$L(RORSEG(FLD))
+"RTN","RORHL7A",211,0)
+ S I=""
+"RTN","RORHL7A",212,0)
+ F  S I=$O(@ROR8SRC@(I))  Q:I=""  D
+"RTN","RORHL7A",213,0)
+ . S BUF=@ROR8SRC@(I),NFL=$L(BUF,HLFS)
+"RTN","RORHL7A",214,0)
+ . D FIELD($P(BUF,HLFS),FLD)
+"RTN","RORHL7A",215,0)
+ . F IFL=2:1:NFL  S FLD=FLD+1  D FIELD($P(BUF,HLFS,IFL),FLD)
+"RTN","RORHL7A",216,0)
+ Q
+"RTN","RORHL7A",217,0)
+ ;
+"RTN","RORHL7A",218,0)
+ ;***** RETURNS TEXT EXPLANATIONS OF THE HL7 MESSAGE STATUS
+"RTN","RORHL7A",219,0)
+ ;
+"RTN","RORHL7A",220,0)
+ ; MSGST         Status value returned by the $$MSGSTAT^HLUTIL
+"RTN","RORHL7A",221,0)
+ ;
+"RTN","RORHL7A",222,0)
+MSGSTXT(MSGST) ;
+"RTN","RORHL7A",223,0)
+ N ST  S ST=+MSGST
+"RTN","RORHL7A",224,0)
+ Q:'ST "Message does not exist"
+"RTN","RORHL7A",225,0)
+ Q:ST=1 "Waiting in queue"
+"RTN","RORHL7A",226,0)
+ Q:ST=1.5 "Opening connection"
+"RTN","RORHL7A",227,0)
+ Q:ST=1.7 "Awaiting response"
+"RTN","RORHL7A",228,0)
+ Q:ST=2 "Awaiting application ack"
+"RTN","RORHL7A",229,0)
+ Q:ST=3 "Successfully completed"
+"RTN","RORHL7A",230,0)
+ Q:ST=4 "Error"
+"RTN","RORHL7A",231,0)
+ Q:ST=8 "Being generated"
+"RTN","RORHL7A",232,0)
+ Q:ST=9 "Awaiting processing"
+"RTN","RORHL7A",233,0)
+ Q "Unknown"
+"RTN","RORHL7A",234,0)
+ ;
+"RTN","RORHL7A",235,0)
+ ;***** ASSIGNS THE 'SET ID'
+"RTN","RORHL7A",236,0)
+ ;
+"RTN","RORHL7A",237,0)
+ ; SEGNAME       Name of the HL7 segment
+"RTN","RORHL7A",238,0)
+ ; [DISINC]      Disable increment of the Set ID
+"RTN","RORHL7A",239,0)
+ ;
+"RTN","RORHL7A",240,0)
+ ; Return Values:
+"RTN","RORHL7A",241,0)
+ ;        ""  Not required for this segment
+"RTN","RORHL7A",242,0)
+ ;        >0  Value for the Set ID field
+"RTN","RORHL7A",243,0)
+ ;
+"RTN","RORHL7A",244,0)
+SETID(SEGNAME,DISINC) ;
+"RTN","RORHL7A",245,0)
+ N SETID
+"RTN","RORHL7A",246,0)
+ Q:$G(SEGNAME)="" ""
+"RTN","RORHL7A",247,0)
+ S SETID=+$G(ROREXT("HL7SID",SEGNAME))
+"RTN","RORHL7A",248,0)
+ Q:SETID'>0 ""
+"RTN","RORHL7A",249,0)
+ S:'$G(DISINC) ROREXT("HL7SID",SEGNAME)=SETID+1
+"RTN","RORHL7A",250,0)
+ Q SETID
+"RTN","VALMW3")
+0^41^B21033865
+"RTN","VALMW3",1,0)
+VALMW3 ; ALB/MJK,MSC/JDA - Create transport routines for LM;27APR2009
+"RTN","VALMW3",2,0)
+ ;;1;List Manager;**MSC**;Aug 13, 1993
+"RTN","VALMW3",3,0)
+ ;
+"RTN","VALMW3",4,0)
+EN ; -- exporter main entry point
+"RTN","VALMW3",5,0)
+ N VALMSYS,VALMNS,VALMROU,VALMAX
+"RTN","VALMW3",6,0)
+ S U="^",DTIME=600 K ^UTILITY($J)
+"RTN","VALMW3",7,0)
+ D HOME^%ZIS
+"RTN","VALMW3",8,0)
+ W @IOF,!?20,"*** List Template Export Utility ***"
+"RTN","VALMW3",9,0)
+ I '$$DUZ() G ENQ
+"RTN","VALMW3",10,0)
+ S VALMSYS=$$OS() I VALMSYS="" G ENQ
+"RTN","VALMW3",11,0)
+ S VALMNS=$$NS() I VALMNS="" G ENQ
+"RTN","VALMW3",12,0)
+ S VALMROU=$$ROU(.VALMNS) I VALMROU="" G ENQ
+"RTN","VALMW3",13,0)
+ S VALMAX=$$MAX() I 'VALMAX G ENQ
+"RTN","VALMW3",14,0)
+ W !!!,">>> Exporting LIST TEMPLATES with namespace '"_VALMNS_"'."