Merge lp:~jontai/openvista-gtm-integration/phase1-alpha2-release-prep into lp:openvista-gtm-integration

[Jon Tai]

=== added file 'ChangeLog'
--- ChangeLog	1970-01-01 00:00:00 +0000
+++ ChangeLog	2009-06-08 17:00:39 +0000
@@ -0,0 +1,187 @@
+0.8.1
+===
+
+   55 Jonathan Tai	2009-06-08 [merge]
+      Prep for 0.8.1 (phase 1 alpha 2) release
+
+   54 Jonathan Tai	2009-06-05 [merge]
+      Merge bug 384019 - ERROR SETTING RIGHT MARGIN TO ZERO
+
+   53 Jonathan Tai	2009-06-03 [merge]
+      Merge bug 383367 - ovimport creates temporary directory in routines directory when importing routines from tmp directory
+
+   52 Jonathan Tai	2009-06-02 [merge]
+      Merge bug 378919 - System status routine
+
+   51 Jonathan Tai	2009-06-02 [merge]
+      Merge bug 381117 - GT.M/Unix version of ORDER^%ZOSV out of sync with Cache version
+
+   50 Jonathan Tai	2009-06-02 [merge]
+      Merge bug 380753 - HFS device always busy
+
+   49 Jonathan Tai	2009-06-01 [merge]
+      Merge bug 381113 - ZISFGUX is not necessary
+
+   48 Jonathan Tai	2009-05-29 [merge]
+      Merge bug 381424 - Printing from CPRS only Prints Header
+
+   47 Jonathan Tai	2009-05-21 [merge]
+      Merge bug 370652 - UNLOCK^MSCZJOBU doesn't need a second argument
+
+   46 Jeff Apple	2009-05-20 [merge]
+      Merge bug378746
+        correct return codes and error messages
+
+   45 Jonathan Tai	2009-05-20 [merge]
+      Merge bug 378140 - gtmsignal is installed with incorrect owner
+
+   44 Jeff Apple	2009-05-19
+      Fix spelling error in help
+
+   43 Jonathan Tai	2009-05-13 [merge]
+      Merge bug 375029 - ovimport doesn't create group-writable routine files if source files aren't group-writable
+
+
+0.8
+===
+
+   42 Jonathan Tai	2009-05-01 [merge]
+      Merge Joel's build
+
+   41 Jonathan Tai	2009-05-01 [merge]
+      Add routines present in Joel's build, but missing from bzr 
+
+   40 Jeff Apple	2009-05-01 [merge]
+      Merge changes under bug 368789
+
+   39 Jeff Apple	2009-04-29 [merge]
+      Merge bug323482
+       Fix compile errors
+
+   38 Jonathan Tai	2009-04-29 [merge]
+      Merge bug 369369 - ovimport imports globals.zwr into routines directory when the zip files are extracted into the same directory
+
+   37 Jonathan Tai	2009-04-28 [merge]
+      Merge bug 326193 - System Status/Job Exam not working in GTM
+
+   36 Jonathan Tai	2009-04-27 [merge]
+      Merge bug 365395 - ovimport routine copy performance
+
+   35 Jonathan Tai	2009-04-25 [merge]
+      Merge bug 366576 - Unable to remove openvista-webdav-config package if removing httpd
+
+   34 Jeff Apple	2009-04-24
+      Add author in comment
+
+   33 Jeff Apple	2009-04-24 [merge]
+      Merge bug 332088
+       lpr printing from gtm in unix
+
+   32 Jeff Apple	2009-04-24 [merge]
+      Merge bug355710
+       Unprotected SSVN in XPDR
+
+   31 Jeff Apple	2009-04-24 [merge]
+      Merge bug 333538
+       Error Trap display intermittent problems - fixed
+
+   30 Jonathan Tai	2009-04-23 [merge]
+      Merge bug 365777 - Tied account script to run MSCOVCI
+
+   29 Jonathan Tai	2009-04-23 [merge]
+      Merge bug 365404 - bash completion should skip over lost+found directory
+
+   28 Jonathan Tai	2009-04-23 [merge]
+      Merge bug 365393 - ovinstanceadd should create "images" symlink pointing to webdav root
+
+   27 Jonathan Tai	2009-04-22 [merge]
+      Merge bug 365370 - libopenvista.so needs to have textrel_shlib_t 
+
+   26 Jeff Apple	2009-04-23 [merge]
+      Add missing TCPIP and library changes
+
+   25 Jonathan Tai	2009-04-22 [merge]
+      Merge bug 363162 - Send M errors back instead of disconnecting clients
+
+   24 Jonathan Tai	2009-04-21 [merge]
+      Merge release-packaging branch: new COPYING and README files, new build script, adds a -V flag to all commands that displays AGPL info, new ovswitchjournals utility, new openvista-webdav-config package to automatically configure webdav; adds webdav support to ovinstanceadd/ovinstancedel
+
+   23 Jonathan Tai	2009-04-20 [merge]
+      Merge bug 326435 - Linux commands should come with man pages
+
+   22 Jeff Apple	2009-04-18 [merge]
+      Merge bug 357216
+       Set $ZTRAP so that an error doesn't just hang
+
+   21 Jonathan Tai	2009-04-18 [merge]
+      Merge bug 363215 - ovrestore doesn't set permissions properly
+
+   20 Jonathan Tai	2009-04-18 [merge]
+      Merge bug 361519 - Provide startup/shutdown hooks
+
+   19 Jeff Apple	2009-04-17 [merge]
+      Merged bug 360615
+       Enhance DEL^ZOSV2GTM to fix bugs and for more intelligent deletion
+
+   18 Jeff Apple	2009-04-17 [merge]
+      Merged bug 359421
+       Shut down HL7 listener when TaskMan tells it to
+
+   17 Jeff Apple	2009-04-17 [merge]
+      Merged changes for bug 359318 and bug 318003
+       Set var so GETPEER^ZOSVGUX will work
+       Use C callouts to keep listening socket open
+
+   16 Jeff Apple	2009-04-17 [merge]
+      Merge bug 322031
+      Make VistaLink work with GT.M
+
+   15 Jonathan Tai	2009-04-17 [merge]
+      Merge bug 362001 - Utility to restore backups
+
+   14 Jonathan Tai	2009-04-15 [merge]
+      Merge bug 361512 - Run mupip backup and routine consistency check in parallel
+
+   13 Jonathan Tai	2009-04-15 [merge]
+      Merge scripts-work branch into mainline.
+
+   12 Jeff Apple	2009-04-14 [merge]
+      Merge bug 360710 - Enhance ZTMGRSET to better handle a $ZROutine search path
+
+   11 Jeff Apple	2009-04-14 [merge]
+      Merge bug 360290 - Enhance RTNDIR^ZOSVGUX() to handle more forms of $ZROutines
+
+   10 Jeff Apple	2009-04-13 [merge]
+      Merge for bug 322986 - logging when dropping to programmer mode
+
+    9 Jeff Apple	2009-04-13 [merge]
+      Merged branch bug359418
+      Allow GTM to run a multithreaded HL7 server
+
+    8 Jeff Apple	2009-04-13
+      Comments
+
+    7 Jeff Apple	2009-04-13 [merge]
+      Merge from bug321745
+      Decrease polling ttime on socket reads for GTM
+
+    6 Jeff Apple	2009-04-10
+      Unmodified sources
+
+    5 Jeff Apple	2009-04-10 [merge]
+      Merged branch bug336102 : Check for error on HL7 socket read
+
+    4 Jonathan Tai	2009-04-06 [merge]
+      Merge gtm-packaging branch into mainline.  This branch includes the zprompt work and some script and packaging fixes
+
+    3 Jonathan Tai	2009-02-25 [merge]
+      Merge xc-packaging branch into mainline.  This branch includes the tcpip work and the PAM auth work.
+
+    2 Jonathan Tai	2009-02-12 [merge]
+      Merge scripts+packaging branch into mainline to lay the foundation for other work.
+
+    1 Jon	2009-01-16
+      Initial import into bzr.
+      
+      Created directory structure; added README and COPYING files.
+
 
=== modified file 'NEWS'
--- NEWS	2009-04-18 08:46:59 +0000
+++ NEWS	2009-06-05 19:50:04 +0000
@@ -1,3 +1,9 @@
+0.8.1
+===
+
+This release fixes bugs in ovimport, gtmsignal, the HFS device, and other
+kernel routines.  A new %SS system status routine was added.
+
 
 0.8
 ===
 
=== added file 'docs/release-checklist.txt'
--- docs/release-checklist.txt	1970-01-01 00:00:00 +0000
+++ docs/release-checklist.txt	2009-06-08 16:58:39 +0000
@@ -0,0 +1,11 @@
+Release Checklist
+===
+
+ [ ] Branch mainline after all "real" changes are in
+ [ ] Create new KIDS build, copy to kids directory and bzr add it
+ [ ] Bump revision numbers in all scripts
+ [ ] Bump revision numbers in any updated RPM spec files
+ [ ] Update NEWS
+ [ ] Update ChangeLog (include future merge of release prep branch into mainline)
+ [ ] Merge release prep branch into mainline
+
 
=== added file 'kids/MSC_GTM_INTEG_2.KID'
--- kids/MSC_GTM_INTEG_2.KID	1970-01-01 00:00:00 +0000
+++ kids/MSC_GTM_INTEG_2.KID	2009-06-08 16:54:50 +0000
@@ -0,0 +1,11858 @@
+KIDS Distribution saved on Jun 08, 2009@09:49:02
+VERSION 2 GTM
+**KIDS**:MSC GTM INTEGRATION*1.0*2^
+
+**INSTALL NAME**
+MSC GTM INTEGRATION*1.0*2
+"BLD",7026,0)
+MSC GTM INTEGRATION*1.0*2^^0^3090608^y
+"BLD",7026,1,0)
+^^1^1^3090605^
+"BLD",7026,1,1,0)
+SYSTEM STATUS AND JOBEXAM FOR GT.M
+"BLD",7026,4,0)
+^9.64PA^^
+"BLD",7026,6.3)
+36
+"BLD",7026,"INIT")
+POSTGTM^ZTMGRSET
+"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)
+ZU^^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^B54320203
+"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","ZU",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_2.KID
+"BLD",7026,"MSCOM")
+VERSION 2 GTM
+"BLD",7026,"PRE")
+MSCGUX53
+"INIT")
+POSTGTM^ZTMGRSET
+"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)