18. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 2/19/2019 12:21:04 PM Central Standard Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

18.1 Files compared

# Location File Last Modified
1 C:\AraxisMergeCompare\Pri_un\EPIP combined\PSJ_5.0_332-PSO_7.0_492-PSS_1.0_216 PSJ_5.0_332.KID Tue Feb 12 16:40:59 2019 UTC
2 C:\AraxisMergeCompare\Pri_re\EPIP combined\PSJ_5.0_332-PSO_7.0_492-PSS_1.0_216 PSJ_5.0_332.KID Tue Feb 12 18:40:48 2019 UTC

18.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 2 11906
Changed 1 2
Inserted 0 0
Removed 0 0

18.3 Comparison options

Whitespace
Character case Differences in character case are significant
Line endings Differences in line endings (CR and LF characters) are ignored
CR/LF characters Not shown in the comparison detail

18.4 Active regular expressions

No regular expressions were active.

18.5 Comparison detail

  1   Packman Ma il Message :
  2   ========== ========== =
  3  
  4   $END TXT
  5   $KID PSJ*5 .0*332
  6   **INSTALL  NAME**
  7   PSJ*5.0*33 2
  8   "BLD",9866 ,0)
  9   PSJ*5.0*33 2^INPATIEN T MEDICATI ONS^0^3190 204^y
  10   "BLD",9866 ,1,0)
  11   ^^11^11^31 81004^^
  12   "BLD",9866 ,1,1,0)
  13   PSJ*5.0*33 2 is a cob ined build  with PSO* 7.0*492 an d PSS*1.0* 217.  This  
  14   "BLD",9866 ,1,2,0)
  15   combined b uild addre sses the f ollowing N SR's:
  16   "BLD",9866 ,1,3,0)
  17    
  18   "BLD",9866 ,1,4,0)
  19        20170 313
  20   "BLD",9866 ,1,5,0)
  21        20170 315
  22   "BLD",9866 ,1,6,0)
  23        20150 709
  24   "BLD",9866 ,1,7,0)
  25        20150 308
  26   "BLD",9866 ,1,8,0)
  27        20140 904
  28   "BLD",9866 ,1,9,0)
  29        20150 905
  30   "BLD",9866 ,1,10,0)
  31        20150 421
  32   "BLD",9866 ,1,11,0)
  33        20160 804
  34   "BLD",9866 ,4,0)
  35   ^9.64PA^59 .5^1
  36   "BLD",9866 ,4,59.5,0)
  37   59.5
  38   "BLD",9866 ,4,59.5,2, 0)
  39   ^9.641^59. 5^1
  40   "BLD",9866 ,4,59.5,2, 59.5,0)
  41   IV ROOM  ( File-top l evel)
  42   "BLD",9866 ,4,59.5,2, 59.5,1,0)
  43   ^9.6411^.1 07^1
  44   "BLD",9866 ,4,59.5,2, 59.5,1,.10 7,0)
  45   HEADER LAB EL
  46   "BLD",9866 ,4,59.5,22 2)
  47   y^y^p^^^^n ^^n
  48   "BLD",9866 ,4,59.5,22 4)
  49  
  50   "BLD",9866 ,4,"APDD", 59.5,59.5)
  51  
  52   "BLD",9866 ,4,"APDD", 59.5,59.5, .107)
  53  
  54   "BLD",9866 ,4,"B",59. 5,59.5)
  55  
  56   "BLD",9866 ,6.3)
  57   8
  58   "BLD",9866 ,"ABPKG")
  59   n
  60   "BLD",9866 ,"INID")
  61   ^
  62   "BLD",9866 ,"INIT")
  63  
  64   "BLD",9866 ,"KRN",0)
  65   ^9.67PA^77 9.2^20
  66   "BLD",9866 ,"KRN",.4, 0)
  67   .4
  68   "BLD",9866 ,"KRN",.40 1,0)
  69   .401
  70   "BLD",9866 ,"KRN",.40 2,0)
  71   .402
  72   "BLD",9866 ,"KRN",.40 3,0)
  73   .403
  74   "BLD",9866 ,"KRN",.5, 0)
  75   .5
  76   "BLD",9866 ,"KRN",.84 ,0)
  77   .84
  78   "BLD",9866 ,"KRN",3.6 ,0)
  79   3.6
  80   "BLD",9866 ,"KRN",3.8 ,0)
  81   3.8
  82   "BLD",9866 ,"KRN",9.2 ,0)
  83   9.2
  84   "BLD",9866 ,"KRN",9.8 ,0)
  85   9.8
  86   "BLD",9866 ,"KRN",9.8 ,"NM",0)
  87   ^9.68A^26^ 22
  88   "BLD",9866 ,"KRN",9.8 ,"NM",1,0)
  89   PSGPER0^^0 ^B35728238
  90   "BLD",9866 ,"KRN",9.8 ,"NM",2,0)
  91   PSGPER2^^0 ^B31133994
  92   "BLD",9866 ,"KRN",9.8 ,"NM",3,0)
  93   PSGPEN^^0^ B59188020
  94   "BLD",9866 ,"KRN",9.8 ,"NM",6,0)
  95   PSIVLBL1^^ 0^B4557405 5
  96   "BLD",9866 ,"KRN",9.8 ,"NM",7,0)
  97   PSIVLBRP^^ 0^B1956974 7
  98   "BLD",9866 ,"KRN",9.8 ,"NM",8,0)
  99   PSJDIN^^0^ B46714111
  100   "BLD",9866 ,"KRN",9.8 ,"NM",10,0 )
  101   PSGPER^^0^ B21024384
  102   "BLD",9866 ,"KRN",9.8 ,"NM",11,0 )
  103   PSGIEN^^0^ B2583050
  104   "BLD",9866 ,"KRN",9.8 ,"NM",12,0 )
  105   PSIVHYPR^^ 0^B4637520 7
  106   "BLD",9866 ,"KRN",9.8 ,"NM",13,0 )
  107   PSIVHYPL^^ 0^B4897182 3
  108   "BLD",9866 ,"KRN",9.8 ,"NM",14,0 )
  109   PSIVLABL^^ 0^B4482821 9
  110   "BLD",9866 ,"KRN",9.8 ,"NM",16,0 )
  111   PSGZEBL^^0 ^B26551662
  112   "BLD",9866 ,"KRN",9.8 ,"NM",17,0 )
  113   PSGFILED^^ 0^B2843875 2
  114   "BLD",9866 ,"KRN",9.8 ,"NM",18,0 )
  115   PSGZEB1^^0 ^B395705
  116   "BLD",9866 ,"KRN",9.8 ,"NM",19,0 )
  117   PSGZEB2^^0 ^B168513
  118   "BLD",9866 ,"KRN",9.8 ,"NM",20,0 )
  119   PSGBOX1^^0 ^B1887534
  120   "BLD",9866 ,"KRN",9.8 ,"NM",21,0 )
  121   PSGBOX5^^0 ^B26184006
  122   "BLD",9866 ,"KRN",9.8 ,"NM",22,0 )
  123   PSGBOX6^^0 ^B19745461
  124   "BLD",9866 ,"KRN",9.8 ,"NM",23,0 )
  125   PSGBOX7^^0 ^B21697273 6
  126   "BLD",9866 ,"KRN",9.8 ,"NM",24,0 )
  127   PSGBOX9^^0 ^B14433212
  128   "BLD",9866 ,"KRN",9.8 ,"NM",25,0 )
  129   PSIVLABR^^ 0^B4009744 6
  130   "BLD",9866 ,"KRN",9.8 ,"NM",26,0 )
  131   PSIVORLB^^ 0^B1653118 2
  132   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGBOX1", 20)
  133  
  134   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGBOX5", 21)
  135  
  136   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGBOX6", 22)
  137  
  138   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGBOX7", 23)
  139  
  140   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGBOX9", 24)
  141  
  142   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGFILED" ,17)
  143  
  144   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGIEN",1 1)
  145  
  146   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGPEN",3 )
  147  
  148   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGPER",1 0)
  149  
  150   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGPER0", 1)
  151  
  152   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGPER2", 2)
  153  
  154   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGZEB1", 18)
  155  
  156   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGZEB2", 19)
  157  
  158   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSGZEBL", 16)
  159  
  160   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSIVHYPL" ,13)
  161  
  162   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSIVHYPR" ,12)
  163  
  164   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSIVLABL" ,14)
  165  
  166   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSIVLABR" ,25)
  167  
  168   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSIVLBL1" ,6)
  169  
  170   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSIVLBRP" ,7)
  171  
  172   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSIVORLB" ,26)
  173  
  174   "BLD",9866 ,"KRN",9.8 ,"NM","B", "PSJDIN",8 )
  175  
  176   "BLD",9866 ,"KRN",19, 0)
  177   19
  178   "BLD",9866 ,"KRN",19, "NM",0)
  179   ^9.68A^4^3
  180   "BLD",9866 ,"KRN",19, "NM",2,0)
  181   PSGBOX SWI SS LOG SEN D PL^^0
  182   "BLD",9866 ,"KRN",19, "NM",3,0)
  183   PSGBOX SWI SS LOG SFT P RETX^^0
  184   "BLD",9866 ,"KRN",19, "NM",4,0)
  185   PSGBOX SWI SS LOG MAI N^^0
  186   "BLD",9866 ,"KRN",19, "NM","B"," PSGBOX SWI SS LOG MAI N",4)
  187  
  188   "BLD",9866 ,"KRN",19, "NM","B"," PSGBOX SWI SS LOG SEN D PL",2)
  189  
  190   "BLD",9866 ,"KRN",19, "NM","B"," PSGBOX SWI SS LOG SFT P RETX",3)
  191  
  192   "BLD",9866 ,"KRN",19. 1,0)
  193   19.1
  194   "BLD",9866 ,"KRN",19. 1,"NM",0)
  195   ^9.68A^^
  196   "BLD",9866 ,"KRN",101 ,0)
  197   101
  198   "BLD",9866 ,"KRN",409 .61,0)
  199   409.61
  200   "BLD",9866 ,"KRN",771 ,0)
  201   771
  202   "BLD",9866 ,"KRN",779 .2,0)
  203   779.2
  204   "BLD",9866 ,"KRN",870 ,0)
  205   870
  206   "BLD",9866 ,"KRN",898 9.51,0)
  207   8989.51
  208   "BLD",9866 ,"KRN",898 9.51,"NM", 0)
  209   ^9.68A^6^4
  210   "BLD",9866 ,"KRN",898 9.51,"NM", 3,0)
  211   PSG PRE-EX  REPORT ZE BRA LABELS ^^0
  212   "BLD",9866 ,"KRN",898 9.51,"NM", 4,0)
  213   PSG BOX FI RST DOSE I NT ON^^0
  214   "BLD",9866 ,"KRN",898 9.51,"NM", 5,0)
  215   PSG BOX SF TP CFG NAM E^^0
  216   "BLD",9866 ,"KRN",898 9.51,"NM", 6,0)
  217   PSG BOX SF TP SAVE FI LE^^0
  218   "BLD",9866 ,"KRN",898 9.51,"NM", "B","PSG B OX FIRST D OSE INT ON ",4)
  219  
  220   "BLD",9866 ,"KRN",898 9.51,"NM", "B","PSG B OX SFTP CF G NAME",5)
  221  
  222   "BLD",9866 ,"KRN",898 9.51,"NM", "B","PSG B OX SFTP SA VE FILE",6 )
  223  
  224   "BLD",9866 ,"KRN",898 9.51,"NM", "B","PSG P RE-EX REPO RT ZEBRA L ABELS",3)
  225  
  226   "BLD",9866 ,"KRN",898 9.52,0)
  227   8989.52
  228   "BLD",9866 ,"KRN",898 9.52,"NM", 0)
  229   ^9.68A^1^1
  230   "BLD",9866 ,"KRN",898 9.52,"NM", 1,0)
  231   PSG KERNEL  PARAMETER S^^0
  232   "BLD",9866 ,"KRN",898 9.52,"NM", "B","PSG K ERNEL PARA METERS",1)
  233  
  234   "BLD",9866 ,"KRN",899 4,0)
  235   8994
  236   "BLD",9866 ,"KRN",899 4,"NM",0)
  237   ^9.68A^^
  238   "BLD",9866 ,"KRN","B" ,.4,.4)
  239  
  240   "BLD",9866 ,"KRN","B" ,.401,.401 )
  241  
  242   "BLD",9866 ,"KRN","B" ,.402,.402 )
  243  
  244   "BLD",9866 ,"KRN","B" ,.403,.403 )
  245  
  246   "BLD",9866 ,"KRN","B" ,.5,.5)
  247  
  248   "BLD",9866 ,"KRN","B" ,.84,.84)
  249  
  250   "BLD",9866 ,"KRN","B" ,3.6,3.6)
  251  
  252   "BLD",9866 ,"KRN","B" ,3.8,3.8)
  253  
  254   "BLD",9866 ,"KRN","B" ,9.2,9.2)
  255  
  256   "BLD",9866 ,"KRN","B" ,9.8,9.8)
  257  
  258   "BLD",9866 ,"KRN","B" ,19,19)
  259  
  260   "BLD",9866 ,"KRN","B" ,19.1,19.1 )
  261  
  262   "BLD",9866 ,"KRN","B" ,101,101)
  263  
  264   "BLD",9866 ,"KRN","B" ,409.61,40 9.61)
  265  
  266   "BLD",9866 ,"KRN","B" ,771,771)
  267  
  268   "BLD",9866 ,"KRN","B" ,779.2,779 .2)
  269  
  270   "BLD",9866 ,"KRN","B" ,870,870)
  271  
  272   "BLD",9866 ,"KRN","B" ,8989.51,8 989.51)
  273  
  274   "BLD",9866 ,"KRN","B" ,8989.52,8 989.52)
  275  
  276   "BLD",9866 ,"KRN","B" ,8994,8994 )
  277  
  278   "BLD",9866 ,"QUES",0)
  279   ^9.62^^
  280   "BLD",9866 ,"REQB",0)
  281   ^9.611^2^2
  282   "BLD",9866 ,"REQB",1, 0)
  283   PSJ*5.0*35 7^1
  284   "BLD",9866 ,"REQB",2, 0)
  285   PSS*1.0*21 6^1
  286   "BLD",9866 ,"REQB","B ","PSJ*5.0 *357",1)
  287  
  288   "BLD",9866 ,"REQB","B ","PSS*1.0 *216",2)
  289  
  290   "FIA",59.5 )
  291   IV ROOM
  292   "FIA",59.5 ,0)
  293   ^PS(59.5,
  294   "FIA",59.5 ,0,0)
  295   59.5
  296   "FIA",59.5 ,0,1)
  297   y^y^p^^^^n ^^n
  298   "FIA",59.5 ,0,10)
  299  
  300   "FIA",59.5 ,0,11)
  301  
  302   "FIA",59.5 ,0,"RLRO")
  303  
  304   "FIA",59.5 ,0,"VR")
  305   5.0^PSJ
  306   "FIA",59.5 ,59.5)
  307   1
  308   "FIA",59.5 ,59.5,.107 )
  309  
  310   "KRN",19,2 922120,-1)
  311   0^3
  312   "KRN",19,2 922120,0)
  313   PSGBOX SWI SS LOG SFT P RETX^Ret ransmit Fa iled SFTP  Background  Job^^R^^^ ^^^^^
  314   "KRN",19,2 922120,1,0 )
  315   ^19.06^4^4 ^3180920^^
  316   "KRN",19,2 922120,1,1 ,0)
  317   This optio n should b e queued t o run ever y five min utes.  It  monitors
  318   "KRN",19,2 922120,1,2 ,0)
  319   ^XTMP("PSG BOX7_QUEUE ") and wil l try to r etransmit  any file i n there.
  320   "KRN",19,2 922120,1,3 ,0)
  321   Once the f ile is suc cessfully  transmitte d, then it  is delete d from
  322   "KRN",19,2 922120,1,4 ,0)
  323   the queue.
  324   "KRN",19,2 922120,25)
  325   TQMON^PSGB OX9
  326   "KRN",19,2 922120,200 .9)
  327   y
  328   "KRN",19,2 922120,"U" )
  329   RETRANSMIT  FAILED SF TP BACKGRO
  330   "KRN",19,2 922121,-1)
  331   0^4
  332   "KRN",19,2 922121,0)
  333   PSGBOX SWI SS LOG MAI N^SWISS IN TERFACE LO G^^M^^^^^^ ^^
  334   "KRN",19,2 922121,1,0 )
  335   ^19.06^1^1 ^3181015^^ ^
  336   "KRN",19,2 922121,1,1 ,0)
  337   Main menu  for Swiss  Log dispen se interfa ce.
  338   "KRN",19,2 922121,10, 0)
  339   ^19.01IP^2 ^2
  340   "KRN",19,2 922121,99)
  341   64869,4532 5
  342   "KRN",19,2 922121,99. 1)
  343   62700,1750 2
  344   "KRN",19,2 922121,"U" )
  345   SWISS INTE RFACE LOG
  346   "KRN",19,2 922123,-1)
  347   0^2
  348   "KRN",19,2 922123,0)
  349   PSGBOX SWI SS LOG SEN D PL^Send  Pick List  to Swiss L og^^R^^^^^ ^^^
  350   "KRN",19,2 922123,1,0 )
  351   ^19.06^1^1 ^3180809^^
  352   "KRN",19,2 922123,1,1 ,0)
  353   This will  transmit a  pick list  to Swiss  Log.
  354   "KRN",19,2 922123,25)
  355   PSGBOX5
  356   "KRN",19,2 922123,"U" )
  357   SEND PICK  LIST TO SW ISS LOG
  358   "KRN",8989 .51,905,-1 )
  359   0^3
  360   "KRN",8989 .51,905,0)
  361   PSG PRE-EX  REPORT ZE BRA LABELS ^Pre-excha nge report  ZEBRA lab els^1^Divi sion^PRE-E XCHANGE 
  362   REPORT ZEB RA LABELS? ^0
  363   "KRN",8989 .51,905,1)
  364   Y^0:NO,1:Y ES^Enter Y es to use  the Zebra  Label prin ter for pr e-exchange  labels, N o to skip.
  365   "KRN",8989 .51,905,6)
  366   P^4^Select  the divis ion which  you log in to.
  367   "KRN",8989 .51,905,20 ,0)
  368   ^8989.512^ 3^3^318103 1^^^^
  369   "KRN",8989 .51,905,20 ,1,0)
  370   This param eter allow s a Zebra  Label Prin ter to be  used for p rinting 
  371   "KRN",8989 .51,905,20 ,2,0)
  372   Pre-Exchan ge Report  labels.  I f set to N o, this pa rameter wi ll print 
  373   "KRN",8989 .51,905,20 ,3,0)
  374   the report  to an 8-1 /2 x 11" s heet of pa per.
  375   "KRN",8989 .51,905,30 ,0)
  376   ^8989.513I ^2^2
  377   "KRN",8989 .51,905,30 ,1,0)
  378   10^4.2
  379   "KRN",8989 .51,905,30 ,2,0)
  380   1^4
  381   "KRN",8989 .51,920,0)
  382   PSG BOX FA IL QUE EXP IRY TIME^B oxPicker I nterface Q ueue entry  expiry^^^ Time in se conds
  383   "KRN",8989 .51,920,1)
  384   N^0:14400^ Value in s econds bef ore an ent ry in the  failed que ue expires .
  385   "KRN",8989 .51,920,20 ,0)
  386   ^^9^9^3180 809^
  387   "KRN",8989 .51,920,20 ,1,0)
  388   This is th e number o f seconds  an entry i n the fail ed queue w ill stay
  389   "KRN",8989 .51,920,20 ,2,0)
  390   until the  entry is c onsidered  expired.   Tasked opt ion PSGBOX 5 SWISS
  391   "KRN",8989 .51,920,20 ,3,0)
  392   LOG SFTP R ETX will a ttempt to  retransmit  any entri es in the  failed
  393   "KRN",8989 .51,920,20 ,4,0)
  394   queue as l ong as the  entry has  not expir ed.  Expir ation time  is
  395   "KRN",8989 .51,920,20 ,5,0)
  396   counted fr om the tim e the entr y was firs t added to  the queue .
  397   "KRN",8989 .51,920,20 ,6,0)
  398    
  399   "KRN",8989 .51,920,20 ,7,0)
  400   A time of  0 (zero) w ill disabl e the fail ed queue.
  401   "KRN",8989 .51,920,20 ,8,0)
  402    
  403   "KRN",8989 .51,920,20 ,9,0)
  404   Maximum ti me is 14,4 00 seconds  (4 hours) .
  405   "KRN",8989 .51,920,30 ,0)
  406   ^8989.513I ^1^1
  407   "KRN",8989 .51,920,30 ,1,0)
  408   10^4.2
  409   "KRN",8989 .51,921,-1 )
  410   0^4
  411   "KRN",8989 .51,921,0)
  412   PSG BOX FI RST DOSE I NT ON^BoxP icker Firs t Dose Int erface Swi tch^0^^(A) ctive or ( I)nactive?
  413   "KRN",8989 .51,921,1)
  414   S^0:Inacti ve;1:Activ e^Enter A  to send fi rst dose t o ADM.
  415   "KRN",8989 .51,921,20 ,0)
  416   ^8989.512^ 2^2^318082 8^^^
  417   "KRN",8989 .51,921,20 ,1,0)
  418   Triggers t he interfa ce to send  first dos e orders t o the Auto mated
  419   "KRN",8989 .51,921,20 ,2,0)
  420   Dispensing  Machine i n XML form at.
  421   "KRN",8989 .51,921,30 ,0)
  422   ^8989.513I ^1^1
  423   "KRN",8989 .51,921,30 ,1,0)
  424   10^4.2
  425   "KRN",8989 .51,922,-1 )
  426   0^5
  427   "KRN",8989 .51,922,0)
  428   PSG BOX SF TP CFG NAM E^Swiss Lo g SFTP Con figuration  Name^^^Co nfiguratio n Name
  429   "KRN",8989 .51,922,1)
  430   F^3:20^Ent er the nam e of the S FTP config uration. 
  431   "KRN",8989 .51,922,20 ,0)
  432   ^^2^2^3180 814^
  433   "KRN",8989 .51,922,20 ,1,0)
  434   The name o f the SFTP  configura tion in or der to tra nsmit orde rs from Vi sta
  435   "KRN",8989 .51,922,20 ,2,0)
  436   to Swiss L og.
  437   "KRN",8989 .51,922,30 ,0)
  438   ^8989.513I ^1^1
  439   "KRN",8989 .51,922,30 ,1,0)
  440   10^4.2
  441   "KRN",8989 .51,923,-1 )
  442   0^6
  443   "KRN",8989 .51,923,0)
  444   PSG BOX SF TP SAVE FI LE^Swiss L og Save Tx 'd File^^^ Save after  successfu l transmis sion
  445   "KRN",8989 .51,923,1)
  446   S^0:NO;1:Y ES^Determi nes if a f ile should  be saved  after tran smission.
  447   "KRN",8989 .51,923,20 ,0)
  448   ^^19^19^31 80828^
  449   "KRN",8989 .51,923,20 ,1,0)
  450   This deter mines whet her the SF TP'd file  should be  automatica lly saved
  451   "KRN",8989 .51,923,20 ,2,0)
  452   after tran smission.   Set this  to YES to  save the f ile; set t o NO to de lete
  453   "KRN",8989 .51,923,20 ,3,0)
  454   the file. 
  455   "KRN",8989 .51,923,20 ,4,0)
  456    
  457   "KRN",8989 .51,923,20 ,5,0)
  458   During SFT P, the ord er to be t ransmitted  is placed  on the ho st file sy stem
  459   "KRN",8989 .51,923,20 ,6,0)
  460   in the cur rent worki ng directo ry defined  by the Ke rnel site  parameters
  461   "KRN",8989 .51,923,20 ,7,0)
  462   ($$PWD^%ZI SH).  Afte r transmis sion, this  parameter  determine s if the f ile
  463   "KRN",8989 .51,923,20 ,8,0)
  464   should be  saved or n ot.  By de fault, suc cessfully  transmitte d files wi ll
  465   "KRN",8989 .51,923,20 ,9,0)
  466   automatica lly be del eted.
  467   "KRN",8989 .51,923,20 ,10,0)
  468    
  469   "KRN",8989 .51,923,20 ,11,0)
  470   If the par ameter PSO  BOX FAIL  QUE EXPIRY  TIME is g reater tha n 0 (zero) ,
  471   "KRN",8989 .51,923,20 ,12,0)
  472   and a file  fails to  transmit,  then the f ailed file  is automa tically
  473   "KRN",8989 .51,923,20 ,13,0)
  474   retained u ntil proce ssed by th e failed q ueued job.
  475   "KRN",8989 .51,923,20 ,14,0)
  476    
  477   "KRN",8989 .51,923,20 ,15,0)
  478   If you are  troublesh ooting thi s interfac e, then yo u may wish  to 
  479   "KRN",8989 .51,923,20 ,16,0)
  480   change thi s paramete r to YES u ntil the p roblem is  resolved.   This 
  481   "KRN",8989 .51,923,20 ,17,0)
  482   way, you c an examine  all the o rders hand led by thi s interfac e.  Once t he
  483   "KRN",8989 .51,923,20 ,18,0)
  484   problem is  resolved,  you will  need to ch ange this  parameter  to NO and  then
  485   "KRN",8989 .51,923,20 ,19,0)
  486   also manua lly delete  any files  that were  created b y this int erface.
  487   "KRN",8989 .51,923,30 ,0)
  488   ^8989.513I ^1^1
  489   "KRN",8989 .51,923,30 ,1,0)
  490   10^4.2
  491   "KRN",8989 .51,936,0)
  492   PSG ATC SE TUP PROMPT ^Dispense  Drug ATC s etup promp t^0^^Multi ple ATCs t o setup?^0
  493   "KRN",8989 .51,936,1)
  494   S^0:No;1:Y es^Enter 1  for Yes,  0 for No
  495   "KRN",8989 .51,936,6)
  496   ^
  497   "KRN",8989 .51,936,20 ,0)
  498   ^8989.512^ 5^5^318122 6^^^^
  499   "KRN",8989 .51,936,20 ,1,0)
  500   This param eter allow s each sit e to set u p the defa ult prompt  for setti ng 
  501   "KRN",8989 .51,936,20 ,2,0)
  502   the DISPEN SE DRUG/AT C SET UP o ption when  selecting  Multiple  or One ATC .  
  503   "KRN",8989 .51,936,20 ,3,0)
  504   A value of  M allows  setting up  multiple  ATCs when  defining i t with a 
  505   "KRN",8989 .51,936,20 ,4,0)
  506   Dispense D rug. Conve rsely, O a llows the  set up of  one ATC fo r dispense  
  507   "KRN",8989 .51,936,20 ,5,0)
  508   drugs.
  509   "KRN",8989 .51,936,30 ,0)
  510   ^8989.513I ^3^1
  511   "KRN",8989 .51,936,30 ,3,0)
  512   1^4.2
  513   "KRN",8989 .52,127,-1 )
  514   0^1
  515   "KRN",8989 .52,127,0)
  516   PSG KERNEL  PARAMETER S^UNIT DOS E KERNEL P ARAMETERS
  517   "KRN",8989 .52,127,10 ,0)
  518   ^8989.521I A^7^6
  519   "KRN",8989 .52,127,10 ,2,0)
  520   1^PSG ATC  SETUP PROM PT
  521   "KRN",8989 .52,127,10 ,3,0)
  522   2^PSG BOX  FIRST DOSE  INT ON
  523   "KRN",8989 .52,127,10 ,4,0)
  524   3^PSG BOX  SFTP CFG N AME
  525   "KRN",8989 .52,127,10 ,5,0)
  526   4^PSG BOX  SFTP SAVE  FILE
  527   "KRN",8989 .52,127,10 ,6,0)
  528   5^PSG BOX  FAIL QUE E XPIRY TIME
  529   "KRN",8989 .52,127,10 ,7,0)
  530   6^PSG PRE- EX REPORT  ZEBRA LABE LS
  531   "MBREQ")
  532   0
  533   "ORD",18,1 9)
  534   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  535   "ORD",18,1 9,0)
  536   OPTION
  537   "ORD",20,8 989.51)
  538   8989.51;20 ;;;PAR1E1^ XPDTA2;PAR 1F1^XPDIA3 ;PAR1E1^XP DIA3;PAR1F 2^XPDIA3;; PAR1DEL^XP DIA3(%)
  539   "ORD",20,8 989.51,0)
  540   PARAMETER  DEFINITION
  541   "ORD",21,8 989.52)
  542   8989.52;21 ;1;;PAR2E1 ^XPDTA2;PA R2F1^XPDIA 3;PAR2E1^X PDIA3;PAR2 F2^XPDIA3; ;PAR2DEL^X PDIA3(%)
  543   "ORD",21,8 989.52,0)
  544   PARAMETER  TEMPLATE
  545   "PKG",221, -1)
  546   1^1
  547   "PKG",221, 0)
  548   INPATIENT  MEDICATION S^PSJ^UNIT  DOSE AND  IVS
  549   "PKG",221, 22,0)
  550   ^9.49I^1^1
  551   "PKG",221, 22,1,0)
  552   5.0^297121 5^2981113^ 1
  553   "PKG",221, 22,1,"PAH" ,1,0)
  554   332^319020 4^52073644 7
  555   "PKG",221, 22,1,"PAH" ,1,1,0)
  556   ^^11^11^31 90204
  557   "PKG",221, 22,1,"PAH" ,1,1,1,0)
  558   PSJ*5.0*33 2 is a cob ined build  with PSO* 7.0*492 an d PSS*1.0* 217.  This  
  559   "PKG",221, 22,1,"PAH" ,1,1,2,0)
  560   combined b uild addre sses the f ollowing N SR's:
  561   "PKG",221, 22,1,"PAH" ,1,1,3,0)
  562    
  563   "PKG",221, 22,1,"PAH" ,1,1,4,0)
  564        20170 313
  565   "PKG",221, 22,1,"PAH" ,1,1,5,0)
  566        20170 315
  567   "PKG",221, 22,1,"PAH" ,1,1,6,0)
  568        20150 709
  569   "PKG",221, 22,1,"PAH" ,1,1,7,0)
  570        20150 308
  571   "PKG",221, 22,1,"PAH" ,1,1,8,0)
  572        20140 904
  573   "PKG",221, 22,1,"PAH" ,1,1,9,0)
  574        20150 905
  575   "PKG",221, 22,1,"PAH" ,1,1,10,0)
  576        20150 421
  577   "PKG",221, 22,1,"PAH" ,1,1,11,0)
  578        20160 804
  579   "QUES","XP F1",0)
  580   Y
  581   "QUES","XP F1","??")
  582   ^D REP^XPD H
  583   "QUES","XP F1","A")
  584   Shall I wr ite over y our |FLAG|  File
  585   "QUES","XP F1","B")
  586   YES
  587   "QUES","XP F1","M")
  588   D XPF1^XPD IQ
  589   "QUES","XP F2",0)
  590   Y
  591   "QUES","XP F2","??")
  592   ^D DTA^XPD H
  593   "QUES","XP F2","A")
  594   Want my da ta |FLAG|  yours
  595   "QUES","XP F2","B")
  596   YES
  597   "QUES","XP F2","M")
  598   D XPF2^XPD IQ
  599   "QUES","XP I1",0)
  600   YO
  601   "QUES","XP I1","??")
  602   ^D INHIBIT ^XPDH
  603   "QUES","XP I1","A")
  604   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  605   "QUES","XP I1","B")
  606   NO
  607   "QUES","XP I1","M")
  608   D XPI1^XPD IQ
  609   "QUES","XP M1",0)
  610   PO^VA(200, :EM
  611   "QUES","XP M1","??")
  612   ^D MG^XPDH
  613   "QUES","XP M1","A")
  614   Enter the  Coordinato r for Mail  Group '|F LAG|'
  615   "QUES","XP M1","B")
  616  
  617   "QUES","XP M1","M")
  618   D XPM1^XPD IQ
  619   "QUES","XP O1",0)
  620   Y
  621   "QUES","XP O1","??")
  622   ^D MENU^XP DH
  623   "QUES","XP O1","A")
  624   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  625   "QUES","XP O1","B")
  626   NO
  627   "QUES","XP O1","M")
  628   D XPO1^XPD IQ
  629   "QUES","XP Z1",0)
  630   Y
  631   "QUES","XP Z1","??")
  632   ^D OPT^XPD H
  633   "QUES","XP Z1","A")
  634   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  635   "QUES","XP Z1","B")
  636   NO
  637   "QUES","XP Z1","M")
  638   D XPZ1^XPD IQ
  639   "QUES","XP Z2",0)
  640   Y
  641   "QUES","XP Z2","??")
  642   ^D RTN^XPD H
  643   "QUES","XP Z2","A")
  644   Want to MO VE routine s to other  CPUs
  645   "QUES","XP Z2","B")
  646   NO
  647   "QUES","XP Z2","M")
  648   D XPZ2^XPD IQ
  649   "RTN")
  650   22
  651   "RTN","PSG BOX1")
  652   0^20^B1887 534^n/a
  653   "RTN","PSG BOX1",1,0)
  654   PSGBOX1 ;E PIP/WLC -  USER INTER FACE FOR P RE-EXCHANG E TRANSMIS SIONS; 29  Nov 2018   12:12 PM ;  
  655   15 Jan 201 9  8:55 AM
  656   "RTN","PSG BOX1",2,0)
  657    ;;5.0;INP ATIENT MED ICATIONS;* *332**;16  DEC 97;Bui ld 8
  658   "RTN","PSG BOX1",3,0)
  659    ;
  660   "RTN","PSG BOX1",4,0)
  661   ORDSAVE(PS GBDFN,PSGB ORDN,PSGBP XDS) ;Call ed from PS GPEN to sa ve order w ith pre-ex ch activit y
  662   "RTN","PSG BOX1",5,0)
  663    N 
  664   PSGBDTRC,P SGBII,PSGB NODE,PSGBF DA,PSGBIEN ,PSGBIENS, PSGBIENR,P SGBLOGN,PS GBOREF,PSG BFDTX,
  665   Y,X,%
  666   "RTN","PSG BOX1",6,0)
  667    Q:'PSGBDF N
  668   "RTN","PSG BOX1",7,0)
  669    Q:'PSGBOR DN
  670   "RTN","PSG BOX1",8,0)
  671    I '$$ORDA CT(PSGBDFN ,+PSGBORDN ) Q
  672   "RTN","PSG BOX1",9,0)
  673    ;
  674   "RTN","PSG BOX1",10,0 )
  675    D ORDFDQ( PSGBDFN,PS GBORDN) ;q ueue off j ob to ENFD ^PSGBOX7
  676   "RTN","PSG BOX1",11,0 )
  677    Q
  678   "RTN","PSG BOX1",12,0 )
  679    ;
  680   "RTN","PSG BOX1",13,0 )
  681   ORDACT(PSG BDFN,PSGBO RDN) ;Retu rn 1 if or der is act ive
  682   "RTN","PSG BOX1",14,0 )
  683    ; ICR # 4 826 - ^PSS 55 API
  684   "RTN","PSG BOX1",15,0 )
  685    N PSGBACT V,PSGBSTOP ,PSGBOSTS
  686   "RTN","PSG BOX1",16,0 )
  687    S PSGBACT V=0
  688   "RTN","PSG BOX1",17,0 )
  689    D PSS431^ PSS55(PSGB DFN,PSGBOR DN,,,"RET" )
  690   "RTN","PSG BOX1",18,0 )
  691    S PSGBOST S=$G(^TMP( $J,"RET",P SGBORDN,28 ))
  692   "RTN","PSG BOX1",19,0 )
  693    D PSS433^ PSS55(PSGB DFN,"RET1" )
  694   "RTN","PSG BOX1",20,0 )
  695    S PSGBSTO P=$G(^TMP( $J,"RET1", PSGBORDN,3 4))
  696   "RTN","PSG BOX1",21,0 )
  697    I 
  698   $S($P(PSGB OSTS,U,1)= "A":1,$P(P SGBOSTS,U, 1)="R":1,$ P(PSGBOSTS ,U,1)="RE" :1,1:0),(P SGBSTOP'<$ $NO
  699   W^XLFDT) S  PSGBACTV= 1
  700   "RTN","PSG BOX1",22,0 )
  701    Q PSGBACT V
  702   "RTN","PSG BOX1",23,0 )
  703    ;
  704   "RTN","PSG BOX1",24,0 )
  705   ORDFDQ(PSB DFN,PSBORD N) ;Queue  off first  dose job
  706   "RTN","PSG BOX1",25,0 )
  707    ;N ZTIO,Z TDESC,ZTRT N,ZTSAVE,Z TDTH,ZTSK, IOP
  708   "RTN","PSG BOX1",26,0 )
  709    ;S ZTIO=" "
  710   "RTN","PSG BOX1",27,0 )
  711    ;S ZTDESC ="FIRST DO SE TRANSMI SSION REAL  TIME"
  712   "RTN","PSG BOX1",28,0 )
  713    ;S ZTRTN= "ENQFD^PSG BOX7"
  714   "RTN","PSG BOX1",29,0 )
  715    ;S ZTDTH= $$NOW^XLFD T
  716   "RTN","PSG BOX1",30,0 )
  717    ;F PSGBII ="PSGBDFN" ,"PSGBORDN " S ZTSAVE (PSGBII)=" "
  718   "RTN","PSG BOX1",31,0 )
  719    ;D ^%ZTLO AD
  720   "RTN","PSG BOX1",32,0 )
  721    D ENQFD^P SGBOX7 Q
  722   "RTN","PSG BOX1",33,0 )
  723    ;
  724   "RTN","PSG BOX5")
  725   0^21^B2618 4006^n/a
  726   "RTN","PSG BOX5",1,0)
  727   PSGBOX5 ;E PIP/WLC -  SEND PICK  LIST MENU  ENTRY POIN T; 29 Nov  2018  12:1 8 PM ; 29  Nov 2018   12:51 
  728   PM
  729   "RTN","PSG BOX5",2,0)
  730    ;;5.0;INP ATIENT MED ICATIONS;* *332**;16  DEC 97;Bui ld 8
  731   "RTN","PSG BOX5",3,0)
  732    ;Cloned f rom PSGTAP  with patc h 10 and m odified as  follows:
  733   "RTN","PSG BOX5",4,0)
  734    ;- Send t o a differ ent interf ace routin e dependin g upon dev ice select ed
  735   "RTN","PSG BOX5",5,0)
  736    ;- Select ion of dif ferent dev ice if sen t previous ly
  737   "RTN","PSG BOX5",6,0)
  738    ;PSGTAP ; BIR/CML3-S END PICK L IST TO TRA VENOL'S AT C 212 (DRI VER) ; 05  May 98 / 1 0:25 AM
  739   "RTN","PSG BOX5",7,0)
  740    ;;5.0; IN PATIENT ME DICATIONS  ;**10**;16  DEC 97
  741   "RTN","PSG BOX5",8,0)
  742    ;
  743   "RTN","PSG BOX5",9,0)
  744   EN ;
  745   "RTN","PSG BOX5",10,0 )
  746    D ENCV^PS GSETU I $D (XQUIT) Q
  747   "RTN","PSG BOX5",11,0 )
  748    ;
  749   "RTN","PSG BOX5",12,0 )
  750   ASK ;
  751   "RTN","PSG BOX5",13,0 )
  752    R !!,"Sel ect WARD G ROUP or PI CK LIST: " ,X:DTIME W :'$T $C(7)  S:'$T X=" ^" G:"^"[X  OUT I X=+ X D NL 
  753   G:'$D(X) A SK I Y D E N1 G ASK
  754   "RTN","PSG BOX5",14,0 )
  755    I X?1."?"  W !!?2,"S elect a Wa rd Group f or which a  pick list  has been  run that y ou wish to  send",!," to the 
  756   ATC.",!?2, "You may a lso direct ly select  a Pick Lis t by numbe r, which p rints in t he upper", !,"left co rner of 
  757   each pick  list." G A SK
  758   "RTN","PSG BOX5",15,0 )
  759    K DIC S D IC="^PS(57 .5,",DIC(0 )="EIMQZ", DIC("S")=" I $P(^(0), ""^"",2)=" "P""" D ^D IC K DIC I  Y S 
  760   PSGPLWG=+Y ,PSGPLGF=" A" D AD I  $D(X) F  D  ^PSGPLG Q :'PSGPLG   D EN1 Q:OK
  761   "RTN","PSG BOX5",16,0 )
  762    G ASK
  763   "RTN","PSG BOX5",17,0 )
  764    ;
  765   "RTN","PSG BOX5",18,0 )
  766   OUT ;
  767   "RTN","PSG BOX5",19,0 )
  768    D ENKV^PS GSETU K 
  769   A,BLKS,C,D ,DAT,DIC,G ,I1,I2,ND, O,P,PID,PL ,PN,PND,PS GIOP,PSGPL G,PSGPLGF, PSGPLWG,PS GPLWGN,PSG S
  770   PD,Q,QUIT, R,S,ST,T,T M,W
  771   "RTN","PSG BOX5",20,0 )
  772    Q
  773   "RTN","PSG BOX5",21,0 )
  774    ;
  775   "RTN","PSG BOX5",22,0 )
  776   EN1 ;
  777   "RTN","PSG BOX5",23,0 )
  778    S OK=0 I  '$$LOCK^PS GPLUTL(PSG PLG,"PSGTA P") W $C(7 ),!!,"This  PICK LIST  is curren tly being  accessed 
  779   by another  task." Q
  780   "RTN","PSG BOX5",24,0 )
  781    I $P($G(^ PS(53.5,PS GPLG,0))," ^",12) S P SGID=$P(^( 0),"^",12) ,PSGOD=$$E NDTC^PSGMI (PSGID) D   I Y<1 
  782   D EN2 Q
  783   "RTN","PSG BOX5",25,0 )
  784    .;Replace  ATC with  generic te rm
  785   "RTN","PSG BOX5",26,0 )
  786    .;W !! S  DIR(0)="Y^ A",DIR("A" )="Pick Li st #"_PSGP LG_" was q ueued to t he ATC for  "_PSGOD_" .  Send 
  787   again",DIR ("B")="N"  D ^DIR K D IR
  788   "RTN","PSG BOX5",27,0 )
  789    .W !! S D IR(0)="Y^A ",DIR("A") ="Pick Lis t #"_PSGPL G_" was qu eued to th e dispensi ng machine  for 
  790   "_PSGOD_".   Send aga in",DIR("B ")="N" D ^ DIR K DIR
  791   "RTN","PSG BOX5",28,0 )
  792    S X=$G(^P S(53.5,PSG PLG,0)),Y= $O(^(0))=" ",X=$P(X," ^",11)&'$P (X,"^",9), %=1
  793   "RTN","PSG BOX5",29,0 )
  794    I X!Y W $ C(7) F  W  !!,"THIS P ICK LIST H AS NO",$S( Y:" DATA." ,1:"T RUN  TO COMPLET ION."),!," Do you 
  795   wish to co ntinue" S  %=2 D YN^D ICN G:% EN 2 W !!?2," Enter 'YES ' to send  this pick  list to th e ATC.  En ter 
  796   'NO' (or ' ^') to not ",!,"send  it."
  797   "RTN","PSG BOX5",30,0 )
  798    ;Call loc al queuing  routine
  799   "RTN","PSG BOX5",31,0 )
  800    G:%'=1 EN 2
  801   "RTN","PSG BOX5",32,0 )
  802    D QSFTP
  803   "RTN","PSG BOX5",33,0 )
  804    Q
  805   "RTN","PSG BOX5",34,0 )
  806    G:%'=1 EN 2 K %ZIS S  %ZIS="NQ" ,PSGION=IO N,IOP="`"_ PSGIOP_";2 55" D ^%ZI S I POP S  IOP=PSGION  D 
  807   ^%ZIS K IO P W $C(7), !!?10,"THE  ATC MACHI NE IS NOT  FOUND!" G  EN2
  808   "RTN","PSG BOX5",35,0 )
  809    S PSGTAPR =0 I $D(^P S(53.55,PS GPLG,0)),$ P(^(0),"^" ,2),$O(^(1 ,0)) F  W  !!,"This p ick list h ad been 
  810   previously  started,  but did no t run to c ompletion. ",!,"Do yo u want to  restart it  where it  left off"  S %=0 D 
  811   YN^DICN I  1 Q:%  D
  812   "RTN","PSG BOX5",36,0 )
  813    .W !!?2," Enter 'YES ' to resta rt the pic k list fro m where it  previousl y stopped.   Enter",! ,"'NO' to  start this  
  814   pick list  from the b eginning."  W:%Y'?1." ?" "  (A r esponse is  required. )"
  815   "RTN","PSG BOX5",37,0 )
  816    I  G:%<0  EN2 S PSGT APR=%=1
  817   "RTN","PSG BOX5",38,0 )
  818    S X=0,X=$ O(^PS(59.7 ,X)),PSGTI R=$S($P($G (^(X,26)), "^",2)=1:" ENQ^PSGTAP 1",1:"ENQ^ PSGTAP0")
  819   "RTN","PSG BOX5",39,0 )
  820    K PSGTID, ZTSAVE S Z TDESC="PIC K LIST TO 
  821   ATC",(ZTSA VE("PSGPLG "),ZTSAVE( "PSGSPD"), ZTSAVE("PS GTAPR"),ZT SAVE("PSGP LWG"))="" 
  822   ENTSK^PSGT I
  823   "RTN","PSG BOX5",40,0 )
  824    I $D(ZTSK ) W "...SE NT!" S OK= 1 I $D(ZTS K("D"))#2  S %H=ZTSK( "D") D YMD ^%DTC S 
  825   $P(^PS(53. 5,PSGPLG,0 ),"^",12)= X+%
  826   "RTN","PSG BOX5",41,0 )
  827    ;
  828   "RTN","PSG BOX5",42,0 )
  829   EN2 ;
  830   "RTN","PSG BOX5",43,0 )
  831    I $D(PSGP LG) D UNLO CK^PSGPLUT L(PSGPLG," PSGTAP")
  832   "RTN","PSG BOX5",44,0 )
  833    Q
  834   "RTN","PSG BOX5",45,0 )
  835    ;
  836   "RTN","PSG BOX5",46,0 )
  837   NL ; numer ic look-up
  838   "RTN","PSG BOX5",47,0 )
  839    S Y=$G(^P S(53.5,X,0 )) I $S('Y :1,'$P(Y," ^",2):1,1: '$D(^PS(53 .5,"AB",$P (Y,"^",2), +$P(Y,"^", 3),X))) S  Y=0 Q
  840   "RTN","PSG BOX5",48,0 )
  841    S 
  842   PSGPLG=X,X =^PS(53.5, PSGPLG,0), Y=$$ENDTC^ PSGMI($P(X ,"^",3)),P SGPLWG=$P( X,"^",2),P SGPLWGN=$S
  843   ('$D(^PS(5 7.5,PSGPLW G,0)):PSGP LWG_";PS(5 7.5,",$P(^ (0),"^")]" ":$P(^(0), "^"),1:PSG PLWG_";PS( 57.5,"),
  844   PSGOD=$$EN DTC^PSGMI( $P(X,"^",4 ))
  845   "RTN","PSG BOX5",49,0 )
  846    W !?5,"Wa rd Group:  ",PSGPLWGN ,!?5,Y,"   thru  ",PS GOD
  847   "RTN","PSG BOX5",50,0 )
  848    ;
  849   "RTN","PSG BOX5",51,0 )
  850   AD ; ATC d evice
  851   "RTN","PSG BOX5",52,0 )
  852    S X=$G(^P S(57.5,PSG PLWG,3))
  853   "RTN","PSG BOX5",53,0 )
  854    Q
  855   "RTN","PSG BOX5",54,0 )
  856    S X=$G(^P S(57.5,PSG PLWG,3)) I  $P(X,"^", 3)="" W $C (7),!!?3," THIS WARD  GROUP DOES  NOT HAVE  AN 
  857   ATC DEVICE  DESIGNATE D FOR IT."  K X
  858   "RTN","PSG BOX5",55,0 )
  859    S:$D(X) P SGIOP=$P(X ,"^",3),PS GSPD=$P(X, "^",2),Y=1  Q
  860   "RTN","PSG BOX5",56,0 )
  861    ;
  862   "RTN","PSG BOX5",57,0 )
  863   QSFTP ;Que ue for SFT P
  864   "RTN","PSG BOX5",58,0 )
  865    N ZTIO,PS GTAPR,ZTSA VE,ZTDESC, ZTRTN,ZTSK ,PSGBRDEV, IOP
  866   "RTN","PSG BOX5",59,0 )
  867    K %ZIS
  868   "RTN","PSG BOX5",60,0 )
  869    S ZTIO=""
  870   "RTN","PSG BOX5",61,0 )
  871    S PSGBRDE V=+$$FIND1 ^DIC(3.5,, "X","PSGBO X SFTP RES OURCE")
  872   "RTN","PSG BOX5",62,0 )
  873    I +PSGBRD EV S ZTIO= "`"_PSGBRD EV
  874   "RTN","PSG BOX5",63,0 )
  875    S PSGTAPR =0
  876   "RTN","PSG BOX5",64,0 )
  877    S ZTDESC= "PICK LIST  TO SWISSL OG"
  878   "RTN","PSG BOX5",65,0 )
  879    S ZTRTN=" ENQ^PSGBOX 6"
  880   "RTN","PSG BOX5",66,0 )
  881    S (ZTSAVE ("PSGPLG") ,ZTSAVE("P SGSPD"),ZT SAVE("PSGT APR"),ZTSA VE("PSGPLW G"))=""
  882   "RTN","PSG BOX5",67,0 )
  883    D ^%ZTLOA D
  884   "RTN","PSG BOX5",68,0 )
  885    I $D(ZTSK ) W "...TA SK "_ZTSK_ " SENT!" S  OK=1 I $D (ZTSK("D") )#2 S %H=Z TSK("D") D  YMD^%DTC 
  886   $P(^PS(53. 5,PSGPLG,0 ),"^",12)= X+%
  887   "RTN","PSG BOX5",69,0 )
  888    G EN2
  889   "RTN","PSG BOX6")
  890   0^22^B1974 5461^n/a
  891   "RTN","PSG BOX6",1,0)
  892   PSGBOX6 ;E PIP/WLC -  SEND PICK  LIST TO SW ISS LOG ;  29 Nov 201 8  1:06 PM
  893   "RTN","PSG BOX6",2,0)
  894    ;;5.0;INP ATIENT MED ICATIONS;* *332**;DEC  16,1997;B uild 8
  895   "RTN","PSG BOX6",3,0)
  896   S1 ;
  897   "RTN","PSG BOX6",4,0)
  898    W $C(48)  F Q=1:1:75  R *X:$S(Q <15:1,1:5)  G:X=49 S1  I X=48 Q
  899   "RTN","PSG BOX6",5,0)
  900    E  S QUIT =1 Q
  901   "RTN","PSG BOX6",6,0)
  902    W A F Q=1 :1:75 R *X :$S(Q<15:1 ,1:5) G:X= 49 S1 I X= 48 Q
  903   "RTN","PSG BOX6",7,0)
  904    S:'$T QUI T=1 Q
  905   "RTN","PSG BOX6",8,0)
  906    ;
  907   "RTN","PSG BOX6",9,0)
  908   S2 ;
  909   "RTN","PSG BOX6",10,0 )
  910    W $C(48)  F Q=1:1:75  R X:$S(Q< 15:1,1:5)  G:$A(X)=49  S2 I $A(X )=48 Q
  911   "RTN","PSG BOX6",11,0 )
  912    E  S QUIT =1 Q
  913   "RTN","PSG BOX6",12,0 )
  914    W A F Q=1 :1:75 R X: $S(Q<15:1, 1:5) G:$A( X)=49 S2 I  $A(X)=48  Q
  915   "RTN","PSG BOX6",13,0 )
  916    S:'$T QUI T=1 Q
  917   "RTN","PSG BOX6",14,0 )
  918    Q
  919   "RTN","PSG BOX6",15,0 )
  920    ;
  921   "RTN","PSG BOX6",16,0 )
  922   ENQ ;
  923   "RTN","PSG BOX6",17,0 )
  924    N ATCFF,D NUNIT
  925   "RTN","PSG BOX6",18,0 )
  926    F  Q:$$LO CK^PSGPLUT L(PSGPLG," PSGTAP")
  927   "RTN","PSG BOX6",19,0 )
  928    F  L +^PS (53.55,PSG PLG):1 Q:$ T
  929   "RTN","PSG BOX6",20,0 )
  930    D NOW^%DT C S %=%_"0 0000000000 00",DAT=$E (%,4,5)_$E (%,6,7)_$E (%,2,3)_$E (%,9,10)_$ E(%,11,12)  I 
  931   PSGPLG<0 S  QUIT=0 G  QUIT
  932   "RTN","PSG BOX6",21,0 )
  933    I PSGTAPR  S ND=$P($ G(^PS(53.5 5,PSGPLG,0 )),"^",2)  I ND,$O(^( 1,0)) G QU IT
  934   "RTN","PSG BOX6",22,0 )
  935    I $D(^PS( 53.55,PSGP LG)) S DIK ="^PS(53.5 5,",DA=PSG PLG D ^DIK
  936   "RTN","PSG BOX6",23,0 )
  937    S (DINUM, X)=PSGPLG, DIC="^PS(5 3.55,",DIC (0)="L" K  DD,DO D FI LE^DICN I  Y'>0 S QUI T=0 G QUIT
  938   "RTN","PSG BOX6",24,0 )
  939    S ^PS(53. 55,PSGPLG, 1,0)="^53. 56A",BLKS= "                        
  940   ",G=PSGPLG ,(DD,PSGOR D,PSJJORD, ND,P,R,S,T ,W,O,D)=""
  941   "RTN","PSG BOX6",25,0 )
  942    S ATCFF=+ $P($G(^PS( 59.7,1,26) ),"^",7)
  943   "RTN","PSG BOX6",26,0 )
  944    F  S T=$O (^PS(53.5, "AC",G,T))  Q:T=""  F   S W=$O(^ PS(53.5,"A C",G,T,W))  Q:W=""  F   S 
  945   R=$O(^PS(5 3.5,"AC",G ,T,W,R)) Q :R=""  F   S P=$O(^PS (53.5,"AC" ,G,T,W,R,P )) Q:P=""   D  ;
  946   "RTN","PSG BOX6",27,0 )
  947    .S (DFN,P SGP)=+$P(P ,"^",2) D  PID^VADPT 
  948   PND=$S($D( ^DPT(PSGP, 0)):^(0),1 :0),PL=$E( $S($D(^(.1 )):^(.1),1 :"N/F")_BL KS,1,12),P N=$E($P(PN D,"^")_B
  949   LKS,1,20), PID=$E(VA( "PID")_BLK S,1,12),S= "A"
  950   "RTN","PSG BOX6",28,0 )
  951    .F  S S=$ O(^PS(53.5 ,"AC",G,T, W,R,P,S))  Q:"Z"[S  F   S PSGORD =$O(^PS(53 .5,"AC",G, T,W,R,P,S, PSGORD)) 
  952   Q:PSGORD=" "  S O=$P( PSGORD,"^" ,2) D
  953   "RTN","PSG BOX6",29,0 )
  954    ..S ON=+$ G(^PS(53.5 ,G,1,PSGP, 1,O,0)) F   S DD=$O(^ PS(53.5,"A C",G,T,W,R ,P,S,PSGOR D,DD)) Q:D D=""  S 
  955   D=+$P(DD," ^",2),C=$G (^PS(53.5, G,1,PSGP,1 ,O,1,D,0)) ,D=$P(C,"^ "),C=$S($P (C,"^",3)] "":+$P(C," ^",3),1:$P (
  956   C,"^",2))  I C>0,C?1. 3N D  ;
  957   "RTN","PSG BOX6",30,0 )
  958    ...S DN=$ G(^PS(55,P SGP,5,ON,1 ,D,0))
  959   "RTN","PSG BOX6",31,0 )
  960    ...S DNUN IT=$P(DN," ^",2) I DN UNIT#1,ATC FF,+DNUNIT  S DNUNIT= (DNUNIT\1) +1
  961   "RTN","PSG BOX6",32,0 )
  962    ...;I DN, '(DNUNIT#1 ),$S('$P(D N,"^",3):1 ,1:DT<$P(D N,"^",3))  S A=$P($G( ^PSDRUG(+D N,8.5)),"^ ",2) I 
  963   A]"",$D(^( 212,"AC",P SGPLWG)) D   ;origina l
  964   "RTN","PSG BOX6",33,0 )
  965    ...I DN,' (DNUNIT#1) ,$S('$P(DN ,"^",3):1, 1:DT<$P(DN ,"^",3)) S  A=$P($G(^ PSDRUG(+DN ,8.5)),"^" ,2) I A]""  
  966   D  ;new
  967   "RTN","PSG BOX6",34,0 )
  968    ....S A=$ E(A_BLKS,1 ,15) I C>9 9 F ND=ND+ 1:1 S ^PS( 53.55,PSGP LG,1,ND,0) =PN_PID_PL _"BAT"_A_"
  969   ^099",C=C- 99 Q:C<100
  970   "RTN","PSG BOX6",35,0 )
  971    ....Q:C<1   S:$L(C)< 3 C=$E("00 0",1,3-$L( C))_C S 
  972   ND=ND+1,^P S(53.55,PS GPLG,1,ND, 0)=PN_PID_ PL_"BAT"_A _"1 ^"_C Q   ;origina l
  973   "RTN","PSG BOX6",36,0 )
  974    N PSGBTXE R,PSGBGCNT
  975   "RTN","PSG BOX6",37,0 )
  976    D BINIT^P SGBOX7(.PS GBGCNT)
  977   "RTN","PSG BOX6",38,0 )
  978    S T=""
  979   "RTN","PSG BOX6",39,0 )
  980    F  S T=$O (^PS(53.5, "AC",G,T))  Q:T=""  S  W="" F  S  W=$O(^PS( 53.5,"AC", G,T,W)) Q: W=""  S R= "" F  S 
  981   R=$O(^PS(5 3.5,"AC",G ,T,W,R)) Q :R=""  S P ="" F  S P =$O(^PS(53 .5,"AC",G, T,W,R,P))  Q:P=""  D   ; 
  982   "RTN","PSG BOX6",40,0 )
  983    .S (DFN,P SGP)=+$P(P ,"^",2)
  984   "RTN","PSG BOX6",41,0 )
  985    .S S=""
  986   "RTN","PSG BOX6",42,0 )
  987    .F  S S=$ O(^PS(53.5 ,"AC",G,T, W,R,P,S))  Q:"Z"[S  S  PSGORD=""  F  S 
  988   PSGORD=$O( ^PS(53.5," AC",G,T,W, R,P,S,PSGO RD)) Q:PSG ORD=""  S  O=$P(PSGOR D,"^",2) D
  989   "RTN","PSG BOX6",43,0 )
  990    ..S ON=+$ G(^PS(53.5 ,G,1,PSGP, 1,O,0))
  991   "RTN","PSG BOX6",44,0 )
  992    ..S DD=""   ;R1/APC  Need to re set DD or  else will  skip order s with sam e OI
  993   "RTN","PSG BOX6",45,0 )
  994    ..K PSGBD DRG
  995   "RTN","PSG BOX6",46,0 )
  996    ..;Only d o the firs t non-zero  dispense  drug since  PSGBOX7 w ill build  labels for  all dispe nse drugs  in the 
  997   order
  998   "RTN","PSG BOX6",47,0 )
  999    ..F  S DD =$O(^PS(53 .5,"AC",G, T,W,R,P,S, PSGORD,DD) ) Q:DD=""   S 
  1000   D=+$P(DD," ^",2),C=$G (^PS(53.5, G,1,PSGP,1 ,O,1,D,0)) ,D=$P(C,"^ "),C=$S($P (C,"^",3)] "":+$P(C," ^",3),1:$P (
  1001   C,"^",2))  I C>0,C?1. 3N D  ;
  1002   "RTN","PSG BOX6",48,0 )
  1003    ...;D BLD ORD^PSGBOX 7(.PSGBGCN T,DFN,ON," CART",+C_U _$P(D,U,1) )
  1004   "RTN","PSG BOX6",49,0 )
  1005    ...S DN=$ G(^PS(55,P SGP,5,ON,1 ,D,0))
  1006   "RTN","PSG BOX6",50,0 )
  1007    ...Q:'$P( DN,U,1)
  1008   "RTN","PSG BOX6",51,0 )
  1009    ...Q:$S(' $P(DN,"^", 3):0,1:$P( DN,"^",3)' >DT)
  1010   "RTN","PSG BOX6",52,0 )
  1011    ...S PSGB DDRG($P(DN ,U,1))=C ; W !,P,"~", PSGORD,"~" ,DD,"~",C, "*"
  1012   "RTN","PSG BOX6",53,0 )
  1013    ..I $O(PS GBDDRG(0))  D BLDORD^ PSGBOX7(.P SGBGCNT,DF N,ON,"CART ",$NA(PSGB DDRG))
  1014   "RTN","PSG BOX6",54,0 )
  1015    D BCLOSE^ PSGBOX7(.P SGBGCNT)
  1016   "RTN","PSG BOX6",55,0 )
  1017    S PSGBTXE R=$$BSEND^ PSGBOX7("C ART")
  1018   "RTN","PSG BOX6",56,0 )
  1019    D BCLEAN^ PSGBOX7
  1020   "RTN","PSG BOX6",57,0 )
  1021    I +PSGBTX ER D MMERR PL^PSGBOX7 (PSGPLG,PS GPLWG,PSGB TXER)
  1022   "RTN","PSG BOX6",58,0 )
  1023    S QUIT=$O (^PS(53.55 ,PSGPLG,1, 0)) G:'QUI T QUIT S ^ (0)="^53.5 6A^"_ND_"^ "_ND,ND=0
  1024   "RTN","PSG BOX6",59,0 )
  1025    ;
  1026   "RTN","PSG BOX6",60,0 )
  1027   QUIT ;
  1028   "RTN","PSG BOX6",61,0 )
  1029    I 'QUIT S  DIK="^PS( 53.55,",DA =PSGPLG D  ^DIK
  1030   "RTN","PSG BOX6",62,0 )
  1031    L -^PS(53 .55,PSGPLG )
  1032   "RTN","PSG BOX6",63,0 )
  1033    D UNLOCK^ PSGPLUTL(P SGPLG,"PSG TAP") D ^% ZISC Q
  1034   "RTN","PSG BOX7")
  1035   0^23^B2169 72736^n/a
  1036   "RTN","PSG BOX7",1,0)
  1037   PSGBOX7 ;E PIP/WLC -  GATHER ORD ER PARTS,  FORMAT XML  ; 29 Nov  2018  1:06  PM
  1038   "RTN","PSG BOX7",2,0)
  1039    ;;5.0;INP ATIENT MED ICATIONS;* *332**;DEC  16, 1997; Build 8
  1040   "RTN","PSG BOX7",3,0)
  1041    ; IA#     Usage       Component
  1042   "RTN","PSG BOX7",4,0)
  1043    ; ------- ---------- ----------
  1044   "RTN","PSG BOX7",5,0)
  1045    ; 4826    Supported   PSS431^PS S55, PSS43 2^PSS55
  1046   "RTN","PSG BOX7",6,0)
  1047    ; 10061   Supported   DEM^VADPT , IN5^VADP T
  1048   "RTN","PSG BOX7",7,0)
  1049    ; 10070   Supported  XMD
  1050   "RTN","PSG BOX7",8,0)
  1051    ; Unsuppp orted DRGD ISP^PSJLMU T1
  1052   "RTN","PSG BOX7",9,0)
  1053    ; Unsuppo rted $$ENM RN^PSGMI
  1054   "RTN","PSG BOX7",10,0 )
  1055    ;
  1056   "RTN","PSG BOX7",11,0 )
  1057   ENQFD ;Fir st dose or ders queue d entry po int
  1058   "RTN","PSG BOX7",12,0 )
  1059    N PSGBERR N,PSGBGCNT
  1060   "RTN","PSG BOX7",13,0 )
  1061    Q:'$G(PSG BDFN)
  1062   "RTN","PSG BOX7",14,0 )
  1063    Q:'$G(PSG BORDN) 
  1064   "RTN","PSG BOX7",15,0 )
  1065    D BINIT(. PSGBGCNT)
  1066   "RTN","PSG BOX7",16,0 )
  1067    D BLDORD( .PSGBGCNT, PSGBDFN,PS GBORDN,"FD ","")
  1068   "RTN","PSG BOX7",17,0 )
  1069    D BCLOSE( .PSGBGCNT)
  1070   "RTN","PSG BOX7",18,0 )
  1071    S PSGBERR N=$$BSEND( "FD")
  1072   "RTN","PSG BOX7",19,0 )
  1073    D BCLEAN
  1074   "RTN","PSG BOX7",20,0 )
  1075    I PSGBERR N D MMERRF D(PSGBDFN, PSGBORDN,P SGBERRN)
  1076   "RTN","PSG BOX7",21,0 )
  1077    Q
  1078   "RTN","PSG BOX7",22,0 )
  1079    ;
  1080   "RTN","PSG BOX7",23,0 )
  1081   ENEUD(PSGB DFN,PSGBOR DN,PSGBEUD ) ;Extra u nits dispe nsed, call ed from PS GBOX8
  1082   "RTN","PSG BOX7",24,0 )
  1083    N ZTIO,ZT SAVE,ZTDES C,ZTRTN,ZT SK,PSGBII, PSGBRDEV,I OP
  1084   "RTN","PSG BOX7",25,0 )
  1085    Q:PSGBORD N'["U"  ;o nly unit d ose
  1086   "RTN","PSG BOX7",26,0 )
  1087    S PSGBORD N=+PSGBORD N
  1088   "RTN","PSG BOX7",27,0 )
  1089    K %ZIS
  1090   "RTN","PSG BOX7",28,0 )
  1091    S ZTIO=""
  1092   "RTN","PSG BOX7",29,0 )
  1093    S PSGBRDE V=+$$FIND1 ^DIC(3.5,, "X","PSGBO X SFTP RES OURCE")
  1094   "RTN","PSG BOX7",30,0 )
  1095    I +PSGBRD EV S ZTIO= "`"_PSGBRD EV
  1096   "RTN","PSG BOX7",31,0 )
  1097    S ZTDESC= "EXTRA UNI TS DISPENS ED TO SWIS SLOG"
  1098   "RTN","PSG BOX7",32,0 )
  1099    S ZTRTN=" ENQEUD^PSG BOX7"
  1100   "RTN","PSG BOX7",33,0 )
  1101    F PSGBII= "PSGBDFN", "PSGBORDN" ,"PSGBEUD"  S ZTSAVE( PSGBII)=""
  1102   "RTN","PSG BOX7",34,0 )
  1103    D ^%ZTLOA D
  1104   "RTN","PSG BOX7",35,0 )
  1105    I '$D(ZTS K) W "...E xtra units  task FAIL ED!"
  1106   "RTN","PSG BOX7",36,0 )
  1107    Q
  1108   "RTN","PSG BOX7",37,0 )
  1109    ;
  1110   "RTN","PSG BOX7",38,0 )
  1111   ENQEUD ;Qu eued entry  point for  extra uni ts dispens ed
  1112   "RTN","PSG BOX7",39,0 )
  1113    N PSGBERR N,PSGBGCNT
  1114   "RTN","PSG BOX7",40,0 )
  1115    Q:'$G(PSG BDFN)
  1116   "RTN","PSG BOX7",41,0 )
  1117    Q:'$G(PSG BORDN) 
  1118   "RTN","PSG BOX7",42,0 )
  1119    Q:'$G(PSG BEUD)
  1120   "RTN","PSG BOX7",43,0 )
  1121    D BINIT(. PSGBGCNT)
  1122   "RTN","PSG BOX7",44,0 )
  1123    D BLDORD( .PSGBGCNT, PSGBDFN,PS GBORDN,"EU D",PSGBEUD )
  1124   "RTN","PSG BOX7",45,0 )
  1125    D BCLOSE( .PSGBGCNT)
  1126   "RTN","PSG BOX7",46,0 )
  1127    S PSGBERR N=$$BSEND( "EUD")
  1128   "RTN","PSG BOX7",47,0 )
  1129    D BCLEAN
  1130   "RTN","PSG BOX7",48,0 )
  1131    I PSGBERR N D MMERRF D(PSGBDFN, PSGBORDN,P SGBERRN)
  1132   "RTN","PSG BOX7",49,0 )
  1133    Q
  1134   "RTN","PSG BOX7",50,0 )
  1135    ;
  1136   "RTN","PSG BOX7",51,0 )
  1137   BINIT(PSGB GCNT) ;Ini tialize ba tch interf ace
  1138   "RTN","PSG BOX7",52,0 )
  1139    S PSGBGCN T=0
  1140   "RTN","PSG BOX7",53,0 )
  1141    K ^TMP("P SGBOX7",$J ,"TRANS")
  1142   "RTN","PSG BOX7",54,0 )
  1143    D SETNODE (.PSGBGCNT ,"<batch>" )
  1144   "RTN","PSG BOX7",55,0 )
  1145    Q
  1146   "RTN","PSG BOX7",56,0 )
  1147    ;
  1148   "RTN","PSG BOX7",57,0 )
  1149   BCLOSE(PSG BGCNT) ;Cl ose a batc h
  1150   "RTN","PSG BOX7",58,0 )
  1151    D SETNODE (.PSGBGCNT ,"</batch> ")
  1152   "RTN","PSG BOX7",59,0 )
  1153    Q
  1154   "RTN","PSG BOX7",60,0 )
  1155    ;
  1156   "RTN","PSG BOX7",61,0 )
  1157   BSEND(PSGB URGY) ;Sen d batch
  1158   "RTN","PSG BOX7",62,0 )
  1159    N PSGBNOW ,PSGBPREF, PSGBX,PSGB FILE,PSGBD ELA,PSGBSF TP,PSGBEDI R,PSGBFNUM ,PSGBSAVF
  1160   "RTN","PSG BOX7",63,0 )
  1161    ;Don't se nd empty b atches
  1162   "RTN","PSG BOX7",64,0 )
  1163    I $O(^TMP ("PSGBOX7" ,$J,"TRANS ","A"),-1) <3 Q 0
  1164   "RTN","PSG BOX7",65,0 )
  1165    S PSGBFNU M=$$FILECT R
  1166   "RTN","PSG BOX7",66,0 )
  1167    S PSGBFNU M=$E("0000 0"_PSGBFNU M,$L(PSGBF NUM),6+$L( PSGBFNUM))
  1168   "RTN","PSG BOX7",67,0 )
  1169    S PSGBNOW =$P($H,"," ,1)
  1170   "RTN","PSG BOX7",68,0 )
  1171    S PSGBNOW =+$E(DT,4) _$E(DT,5)_ $E(DT,6)_$ E(DT,7)
  1172   "RTN","PSG BOX7",69,0 )
  1173    S 
  1174   PSGBPREF=$ S(PSGBURGY ="CART":"C ART",PSGBU RGY="FD":" FDOS",PSGB URGY="EUD" :"FDOS",1: "UNKN
  1175   ")
  1176   "RTN","PSG BOX7",70,0 )
  1177    S PSGBFIL E=PSGBPREF _PSGBNOW_P SGBFNUM_$J _".TXT"
  1178   "RTN","PSG BOX7",71,0 )
  1179    S PSGBEDI R=$$PWD^%Z ISH
  1180   "RTN","PSG BOX7",72,0 )
  1181    S PSGBX=$ $GTF^%ZISH ($NA(^TMP( "PSGBOX7", $J,"TRANS" ,1)),4,PSG BEDIR,PSGB FILE)
  1182   "RTN","PSG BOX7",73,0 )
  1183    I 'PSGBX  Q "70;Crea tion of tr ansmission  file fail ed"
  1184   "RTN","PSG BOX7",74,0 )
  1185    S PSGBSFT P=$$SFTP^P SGBOX9(PSG BFILE)
  1186   "RTN","PSG BOX7",75,0 )
  1187    I +PSGBSF TP D TQADD ^PSGBOX9(P SGBFILE)
  1188   "RTN","PSG BOX7",76,0 )
  1189    S PSGBSAV F=$$GET^XP AR("SYS"," PSG BOX SF TP SAVE FI LE",1,"I")
  1190   "RTN","PSG BOX7",77,0 )
  1191    I 'PSGBSF TP,'PSGBSA VF D
  1192   "RTN","PSG BOX7",78,0 )
  1193    .K PSGBDE LA
  1194   "RTN","PSG BOX7",79,0 )
  1195    .S PSGBDE LA(PSGBFIL E)=""
  1196   "RTN","PSG BOX7",80,0 )
  1197    .S PSGBX= $$DEL^%ZIS H(PSGBEDIR ,$NA(PSGBD ELA))
  1198   "RTN","PSG BOX7",81,0 )
  1199    Q PSGBSFT P
  1200   "RTN","PSG BOX7",82,0 )
  1201    ;
  1202   "RTN","PSG BOX7",83,0 )
  1203   FILECTR()  ;Get count er
  1204   "RTN","PSG BOX7",84,0 )
  1205    N PSGBCT, PSGBENDT
  1206   "RTN","PSG BOX7",85,0 )
  1207    L +^XTMP( "PSGBOX7_F ILECOUNTER ",0):5
  1208   "RTN","PSG BOX7",86,0 )
  1209    I '$T Q $ P($H,",",2 )
  1210   "RTN","PSG BOX7",87,0 )
  1211    S PSGBEND T=$P($G(^X TMP("PSGBO X7_FILECOU NTER",0)), U,1)
  1212   "RTN","PSG BOX7",88,0 )
  1213    ;Reset co unter ever y day
  1214   "RTN","PSG BOX7",89,0 )
  1215    I PSGBEND T'>DT D
  1216   "RTN","PSG BOX7",90,0 )
  1217    .S ^XTMP( "PSGBOX7_F ILECOUNTER ",0)=$$FMA DD^XLFDT(D T,1)_U_DT
  1218   "RTN","PSG BOX7",91,0 )
  1219    .S ^XTMP( "PSGBOX7_F ILECOUNTER ","COUNT") =0
  1220   "RTN","PSG BOX7",92,0 )
  1221    S PSGBCT= $G(^XTMP(" PSGBOX7_FI LECOUNTER" ,"COUNT"))
  1222   "RTN","PSG BOX7",93,0 )
  1223    S PSGBCT= PSGBCT+1
  1224   "RTN","PSG BOX7",94,0 )
  1225    S ^XTMP(" PSGBOX7_FI LECOUNTER" ,"COUNT")= PSGBCT
  1226   "RTN","PSG BOX7",95,0 )
  1227    L -^XTMP( "PSGBOX7_F ILECOUNTER ",0)
  1228   "RTN","PSG BOX7",96,0 )
  1229    Q PSGBCT
  1230   "RTN","PSG BOX7",97,0 )
  1231    ;
  1232   "RTN","PSG BOX7",98,0 )
  1233   BCLEAN ;Cl ean up bat ch interfa ce
  1234   "RTN","PSG BOX7",99,0 )
  1235    ;K ^TMP(" PSGBOX7",$ J,"TRANS")
  1236   "RTN","PSG BOX7",100, 0)
  1237    Q
  1238   "RTN","PSG BOX7",101, 0)
  1239    ;
  1240   "RTN","PSG BOX7",102, 0)
  1241   BLDORD(PSG BGCNT,PSGB DFN,PSGBOR DN,PSGBURG Y,PSGBPLUN ) ;Build o ne order's  XML messa ge
  1242   "RTN","PSG BOX7",103, 0)
  1243    N PSGBII, PSGBCTLB,P SGBRXFO
  1244   "RTN","PSG BOX7",104, 0)
  1245    K PSGBRXF O
  1246   "RTN","PSG BOX7",105, 0)
  1247    S PSGBCTL B=0
  1248   "RTN","PSG BOX7",106, 0)
  1249    I PSGBURG Y="CART" D  RXINFO($N A(PSGBRXFO ),PSGBDFN, PSGBORDN,P SGBURGY,$N A(@PSGBPLU N))
  1250   "RTN","PSG BOX7",107, 0)
  1251    I PSGBURG Y'="CART"  D RXINFO($ NA(PSGBRXF O),PSGBDFN ,PSGBORDN, PSGBURGY)
  1252   "RTN","PSG BOX7",108, 0)
  1253    Q:$$RXSKI P($NA(PSGB RXFO(PSGBO RDN)),PSGB URGY)>9
  1254   "RTN","PSG BOX7",109, 0)
  1255    S PSGBII= 0
  1256   "RTN","PSG BOX7",110, 0)
  1257    F  S PSGB II=$O(PSGB RXFO(PSGBO RDN,"DDRG" ,PSGBII))  Q:'PSGBII   D
  1258   "RTN","PSG BOX7",111, 0)
  1259    .I +PSGBR XFO(PSGBOR DN,"DDIA", PSGBII),DT >PSGBRXFO( "DDIA",PSG BII) D  Q   ;No inact ive
  1260   "RTN","PSG BOX7",112, 0)
  1261    ..S PSGBR XFO(PSGBOR DN,"DDCT") =PSGBRXFO( PSGBORDN," DDCT")-1
  1262   "RTN","PSG BOX7",113, 0)
  1263    .I +$$ISC S(PSGBRXFO (PSGBORDN, "DDSH",PSG BII)) D  Q   ;No cont rolled sub stances
  1264   "RTN","PSG BOX7",114, 0)
  1265    ..S PSGBR XFO(PSGBOR DN,"DDCT") =PSGBRXFO( PSGBORDN," DDCT")-1
  1266   "RTN","PSG BOX7",115, 0)
  1267    .S PSGBCT LB=PSGBCTL B+1
  1268   "RTN","PSG BOX7",116, 0)
  1269    .D BLDHEA D(.PSGBGCN T,PSGBCTLB ,PSGBURGY, PSGBII)
  1270   "RTN","PSG BOX7",117, 0)
  1271    .D BLDDIS P(.PSGBGCN T,PSGBII,P SGBURGY)
  1272   "RTN","PSG BOX7",118, 0)
  1273    .D SETNOD E(.PSGBGCN T,"</order info>",,,1 )
  1274   "RTN","PSG BOX7",119, 0)
  1275    Q
  1276   "RTN","PSG BOX7",120, 0)
  1277    ;
  1278   "RTN","PSG BOX7",121, 0)
  1279   BLDHEAD(PS GBGCNT,PSG BLBNU,PSGB URGY,PSGBD DRGI) ;Bui ld everyth ing but di spense dru g
  1280   "RTN","PSG BOX7",122, 0)
  1281    N PSGBII, PSGBTMPX,P SGBLBNM
  1282   "RTN","PSG BOX7",123, 0)
  1283    D SETNODE (.PSGBGCNT ,"<orderin fo>",,,1)
  1284   "RTN","PSG BOX7",124, 0)
  1285    ;
  1286   "RTN","PSG BOX7",125, 0)
  1287    D SETNODE (.PSGBGCNT ,"<patient >",,,2)
  1288   "RTN","PSG BOX7",126, 0)
  1289    D SETNODE (.PSGBGCNT ,"<name>", $P(PSGBRXF O(PSGBORDN ,"PATN"),U ,2),"</nam e>",3)
  1290   "RTN","PSG BOX7",127, 0)
  1291    D SETNODE (.PSGBGCNT ,"<ssn>",$ P(PSGBRXFO (PSGBORDN, "PID"),U,1 ),"</ssn>" ,3)
  1292   "RTN","PSG BOX7",128, 0)
  1293    D 
  1294   SETNODE(.P SGBGCNT,"< last4>",$E ($P(PSGBRX FO(PSGBORD N,"PATN"), U,2),1)_$P ($P(PSGBRX FO(PSGBO
  1295   RDN,"PID") ,U,2),"-", 3),"</last 4>",3)
  1296   "RTN","PSG BOX7",129, 0)
  1297    D SETNODE (.PSGBGCNT ,"</patien t>",,,2)
  1298   "RTN","PSG BOX7",130, 0)
  1299    ;
  1300   "RTN","PSG BOX7",131, 0)
  1301    D SETNODE (.PSGBGCNT ,"<locatio n>",,,2)
  1302   "RTN","PSG BOX7",132, 0)
  1303    D SETNODE (.PSGBGCNT ,"<ward>", $P(PSGBRXF O(PSGBORDN ,"WGRP"),U ,2),"</war d>",3)
  1304   "RTN","PSG BOX7",133, 0)
  1305    D SETNODE (.PSGBGCNT ,"<roombed >",$P(PSGB RXFO(PSGBO RDN,"RMBD" ),U,2),"</ roombed>", 3)
  1306   "RTN","PSG BOX7",134, 0)
  1307    D SETNODE (.PSGBGCNT ,"</locati on>",,,2)
  1308   "RTN","PSG BOX7",135, 0)
  1309    ;
  1310   "RTN","PSG BOX7",136, 0)
  1311    D SETNODE (.PSGBGCNT ,"<ordernu mber>",PSG BRXFO(PSGB ORDN,"ORDN "),"</orde rnumber>", 2)
  1312   "RTN","PSG BOX7",137, 0)
  1313    ;
  1314   "RTN","PSG BOX7",138, 0)
  1315    D SETNODE (.PSGBGCNT ,"<dosage> ",PSGBRXFO (PSGBORDN, "DOSE"),"< /dosage>", 2)
  1316   "RTN","PSG BOX7",139, 0)
  1317    S PSGBTMP X=$$ENMRN^ PSGMI($P(P SGBRXFO(PS GBORDN,"RO UT"),U,1))
  1318   "RTN","PSG BOX7",140, 0)
  1319    D SETNODE (.PSGBGCNT ,"<route>" ,PSGBTMPX, "</route>" ,2)
  1320   "RTN","PSG BOX7",141, 0)
  1321    D SETNODE (.PSGBGCNT ,"<schedul e>",$P(PSG BRXFO(PSGB ORDN,"SCH" ),U,1),"</ schedule>" ,2)
  1322   "RTN","PSG BOX7",142, 0)
  1323    ;
  1324   "RTN","PSG BOX7",143, 0)
  1325    D 
  1326   SETNODE(.P SGBGCNT,"< schedulety pe>",$P(PS GBRXFO(PSG BORDN,"SCH T"),U,1)," </schedule type>",2)
  1327   "RTN","PSG BOX7",144, 0)
  1328    D SETNODE (.PSGBGCNT ,"<adminti me>",PSGBR XFO(PSGBOR DN,"ADTM") ,"</admint ime>",2)
  1329   "RTN","PSG BOX7",145, 0)
  1330    S PSGBTMP X=$$DTC($P (PSGBRXFO( PSGBORDN," DTBG"),U,1 ),2)
  1331   "RTN","PSG BOX7",146, 0)
  1332    D SETNODE (.PSGBGCNT ,"<startti me>",PSGBT MPX,"</sta rttime>",2 )
  1333   "RTN","PSG BOX7",147, 0)
  1334    S PSGBTMP X=$$DTC($P (PSGBRXFO( PSGBORDN," DTED"),U,1 ),2)
  1335   "RTN","PSG BOX7",148, 0)
  1336    D SETNODE (.PSGBGCNT ,"<stoptim e>",PSGBTM PX,"</stop time>",2)
  1337   "RTN","PSG BOX7",149, 0)
  1338    S PSGBII= 0
  1339   "RTN","PSG BOX7",150, 0)
  1340    F  S PSGB II=$O(PSGB RXFO(PSGBO RDN,"SIG", PSGBII)) Q :'PSGBII   D
  1341   "RTN","PSG BOX7",151, 0)
  1342    .D SETNOD E(.PSGBGCN T,"<sig>", PSGBRXFO(P SGBORDN,"S IG",PSGBII ),"</sig>" ,2)
  1343   "RTN","PSG BOX7",152, 0)
  1344    D SETNODE (.PSGBGCNT ,"<priorit y>",PSGBRX FO(PSGBORD N,"PRIO"), "</priorit y>",2)
  1345   "RTN","PSG BOX7",153, 0)
  1346    D 
  1347   SETNODE(.P SGBGCNT,"< urgency>", $S(PSGBURG Y="CART":" cart",PSGB URGY="FD": "firstdose ",PSGBURG
  1348   Y="EUD":"f irstdose", 1:""),"</u rgency>",2 )
  1349   "RTN","PSG BOX7",154, 0)
  1350    ;
  1351   "RTN","PSG BOX7",155, 0)
  1352    S PSGBII= 0
  1353   "RTN","PSG BOX7",156, 0)
  1354    F  S PSGB II=$O(PSGB RXFO(PSGBO RDN,"SPIN" ,PSGBII))  Q:'PSGBII   D
  1355   "RTN","PSG BOX7",157, 0)
  1356    .D 
  1357   SETNODE(.P SGBGCNT,"< specialins tructions> ",PSGBRXFO (PSGBORDN, "SPIN",PSG BII),"</sp ecialinstr uctio
  1358   ns>",2)
  1359   "RTN","PSG BOX7",158, 0)
  1360    ;
  1361   "RTN","PSG BOX7",159, 0)
  1362    ;Add labe l counter  if more th an 1 dispe nse drug
  1363   "RTN","PSG BOX7",160, 0)
  1364    I PSGBRXF O(PSGBORDN ,"DDCT")>1  D
  1365   "RTN","PSG BOX7",161, 0)
  1366    .S PSGBLB NM="Label"
  1367   "RTN","PSG BOX7",162, 0)
  1368    .I $P(PSG BRXFO(PSGB ORDN,"DDRG ",PSGBDDRG I),U,1)["F " S PSGBLB NM="Fract"
  1369   "RTN","PSG BOX7",163, 0)
  1370    .D SETNOD E(.PSGBGCN T,"<labeli nfo>","~~~ ~ "_PSGBLB NM_" "_PSG BLBNU_" of  
  1371   "_PSGBRXFO (PSGBORDN, "DDCT")_"  ~~~~","</l abelinfo>" ,2)
  1372   "RTN","PSG BOX7",164, 0)
  1373    ;Add frac tional msg  for singl e labels
  1374   "RTN","PSG BOX7",165, 0)
  1375    I PSGBRXF O(PSGBORDN ,"DDCT")=1  D
  1376   "RTN","PSG BOX7",166, 0)
  1377    .Q:$P(PSG BRXFO(PSGB ORDN,"DDRG ",PSGBDDRG I),U,1)'[" F"
  1378   "RTN","PSG BOX7",167, 0)
  1379    .D SETNOD E(.PSGBGCN T,"<labeli nfo>","~~~ ~ Fraction al ~~~~"," </labelinf o>",2)
  1380   "RTN","PSG BOX7",168, 0)
  1381    Q
  1382   "RTN","PSG BOX7",169, 0)
  1383    ;
  1384   "RTN","PSG BOX7",170, 0)
  1385   BLDDISP(PS GBGCNT,PSG BDDRGI,PSG BURGY) ;Bu ild dispen se drug XM L
  1386   "RTN","PSG BOX7",171, 0)
  1387    D SETNODE (.PSGBGCNT ,"<dispens edrug>",,, 2)
  1388   "RTN","PSG BOX7",172, 0)
  1389    D SETNODE (.PSGBGCNT ,"<name>", $P(PSGBRXF O(PSGBORDN ,"DDRG",PS GBDDRGI),U ,2),"</nam e>",3)
  1390   "RTN","PSG BOX7",173, 0)
  1391    I PSGBURG Y="CART" D
  1392   "RTN","PSG BOX7",174, 0)
  1393    .D SETNOD E(.PSGBGCN T,"<quanti ty>",PSGBR XFO(PSGBOR DN,"DDUN", PSGBDDRGI) ,"</quanti ty>",3)
  1394   "RTN","PSG BOX7",175, 0)
  1395    I (PSGBUR GY="FD")!( PSGBURGY=" EUD") D
  1396   "RTN","PSG BOX7",176, 0)
  1397    .D SETNOD E(.PSGBGCN T,"<quanti ty>",PSGBR XFO(PSGBOR DN,"DDPX", PSGBDDRGI) ,"</quanti ty>",3)
  1398   "RTN","PSG BOX7",177, 0)
  1399    D SETNODE (.PSGBGCNT ,"<ien>",$ P(PSGBRXFO (PSGBORDN, "DDRG",PSG BDDRGI),U, 1),"</ien> ",3)
  1400   "RTN","PSG BOX7",178, 0)
  1401    D SETNODE (.PSGBGCNT ,"</dispen sedrug>",, ,2)
  1402   "RTN","PSG BOX7",179, 0)
  1403    Q
  1404   "RTN","PSG BOX7",180, 0)
  1405    ;
  1406   "RTN","PSG BOX7",181, 0)
  1407   RXINFO(PSG BINFO,PSGB DFN,PSGBOR DN,PSGBURG Y,PSGBPLUN ) ;Order i nfo
  1408   "RTN","PSG BOX7",182, 0)
  1409    N 
  1410   DFN,VADM,V AIP,PSGBII ,PSGBDDCT, PSGBSIG,PS GBADMS,PSG BDDUP,PSGB DRGI,PSGBW GRP,PSGBWR DB,
  1411   PSGBLGRP,P SGBSPHD,PS GBLINC
  1412   "RTN","PSG BOX7",183, 0)
  1413    ;Init 
  1414   "RTN","PSG BOX7",184, 0)
  1415    F 
  1416   PSGBII="OR DN","PATN" ,"SCHT","S TAT","SCH" ,"SCHT","R OUT","PID" ,"WARD","R MBD","WGRP ","DTBG","
  1417   DTED","PID ","ADTM"," DDCT","SIG " S @PSGBI NFO@(PSGBO RDN,PSGBII )=""
  1418   "RTN","PSG BOX7",185, 0)
  1419    ;
  1420   "RTN","PSG BOX7",186, 0)
  1421    K ^TMP($J ,"PSGBORDN ")
  1422   "RTN","PSG BOX7",187, 0)
  1423    D PSS431^ PSS55(PSGB DFN,PSGBOR DN,,,"PSGB ORDN")
  1424   "RTN","PSG BOX7",188, 0)
  1425    S @PSGBIN FO@(PSGBOR DN,"ORDN") =PSGBORDN
  1426   "RTN","PSG BOX7",189, 0)
  1427    S @PSGBIN FO@(PSGBOR DN,"PATN") =^TMP($J," PSGBORDN", PSGBORDN,. 5)
  1428   "RTN","PSG BOX7",190, 0)
  1429    S @PSGBIN FO@(PSGBOR DN,"SCHT") =^TMP($J," PSGBORDN", PSGBORDN,7 )
  1430   "RTN","PSG BOX7",191, 0)
  1431    S @PSGBIN FO@(PSGBOR DN,"STAT") =^TMP($J," PSGBORDN", PSGBORDN,2 8)
  1432   "RTN","PSG BOX7",192, 0)
  1433    S @PSGBIN FO@(PSGBOR DN,"ROUT") =^TMP($J," PSGBORDN", PSGBORDN,3 )
  1434   "RTN","PSG BOX7",193, 0)
  1435    ;
  1436   "RTN","PSG BOX7",194, 0)
  1437    S PSGBDDC T=0
  1438   "RTN","PSG BOX7",195, 0)
  1439    S PSGBII= 0 F  S PSG BII=$O(^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBII) ) Q:'PSGBI I  D
  1440   "RTN","PSG BOX7",196, 0)
  1441    .I PSGBUR GY="CART"  D
  1442   "RTN","PSG BOX7",197, 0)
  1443    ..S PSGBD RGI=$P(^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBII, .01),U,1)
  1444   "RTN","PSG BOX7",198, 0)
  1445    ..Q:'$G(@ PSGBPLUN@( PSGBDRGI))
  1446   "RTN","PSG BOX7",199, 0)
  1447    ..;Conver t number o f pick lis t units to  number of  cart admi nistration s
  1448   "RTN","PSG BOX7",200, 0)
  1449    ..S PSGBD DUP=^TMP($ J,"PSGBORD N",PSGBORD N,"DDRUG", PSGBII,.02 ) ;units p er dose
  1450   "RTN","PSG BOX7",201, 0)
  1451    ..I PSGBD DUP#1,+PSG BDDUP S PS GBDDUP=(PS GBDDUP\1)+ 1 ;round u p
  1452   "RTN","PSG BOX7",202, 0)
  1453    ..;S PSGB ADMS=$S(+$ G(PSGBPLUN ):PSGBPLUN \PSGBDDUP, 1:1) ;numb er of admi nistration s
  1454   "RTN","PSG BOX7",203, 0)
  1455    ..S PSGBA DMS=$S('PS GBDDUP:0,1 :@PSGBPLUN @(PSGBDRGI )\PSGBDDUP )
  1456   "RTN","PSG BOX7",204, 0)
  1457    ..;S:'$G( PSGBADMS)  PSGBADMS=1
  1458   "RTN","PSG BOX7",205, 0)
  1459    ..;Whole  tablets
  1460   "RTN","PSG BOX7",206, 0)
  1461    ..I +(^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBII, .02)\1) D
  1462   "RTN","PSG BOX7",207, 0)
  1463    ...D RXIN FODD(.PSGB DDCT,PSGBI I)
  1464   "RTN","PSG BOX7",208, 0)
  1465    ...S 
  1466   @PSGBINFO@ (PSGBORDN, "DDUN",PSG BDDCT)=@PS GBINFO@(PS GBORDN,"DD UN",PSGBDD CT)\1*PSG
  1467   BADMS ;Who le tablets
  1468   "RTN","PSG BOX7",209, 0)
  1469    ..;Fracti onal table ts
  1470   "RTN","PSG BOX7",210, 0)
  1471    ..I +(^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBII, .02)#1) D
  1472   "RTN","PSG BOX7",211, 0)
  1473    ...D RXIN FODD(.PSGB DDCT,PSGBI I)
  1474   "RTN","PSG BOX7",212, 0)
  1475    ...S @PSG BINFO@(PSG BORDN,"DDU N",PSGBDDC T)=PSGBADM S
  1476   "RTN","PSG BOX7",213, 0)
  1477    ...S 
  1478   $P(@PSGBIN FO@(PSGBOR DN,"DDRG", PSGBDDCT), U,1)=$P(@P SGBINFO@(P SGBORDN,"D DRG",PSGBD D
  1479   CT),U,1)_" F"
  1480   "RTN","PSG BOX7",214, 0)
  1481    .;
  1482   "RTN","PSG BOX7",215, 0)
  1483    .I (PSGBU RGY="FD")  D
  1484   "RTN","PSG BOX7",216, 0)
  1485    ..;Conver t number o f units to  number of  pre-excha nge admini strations
  1486   "RTN","PSG BOX7",217, 0)
  1487    ..S PSGBD DUP=^TMP($ J,"PSGBORD N",PSGBORD N,"DDRUG", PSGBII,.02 ) ;units p er dose
  1488   "RTN","PSG BOX7",218, 0)
  1489    ..I PSGBD DUP#1,+PSG BDDUP S PS GBDDUP=(PS GBDDUP\1)+ 1 ;round u p
  1490   "RTN","PSG BOX7",219, 0)
  1491    ..I 'PSGB DDUP S PSG BADMS=0
  1492   "RTN","PSG BOX7",220, 0)
  1493    ..E  D
  1494   "RTN","PSG BOX7",221, 0)
  1495    ...I PSGB URGY="FD"  S PSGBADMS =^TMP($J," PSGBORDN", PSGBORDN," DDRUG",PSG BII,.09)\P SGBDDUP
  1496   "RTN","PSG BOX7",222, 0)
  1497    ...;I PSG BURGY="EUD " S 
  1498   PSGBADMS=^ TMP($J,"PS GBORDN",PS GBORDN,"DD RUG",PSGBI I,.11)\PSG BDDUP
  1499   "RTN","PSG BOX7",223, 0)
  1500    ..;Whole  tablets
  1501   "RTN","PSG BOX7",224, 0)
  1502    ..I +(^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBII, .02)\1) D
  1503   "RTN","PSG BOX7",225, 0)
  1504    ...D RXIN FODD(.PSGB DDCT,PSGBI I)
  1505   "RTN","PSG BOX7",226, 0)
  1506    ...S 
  1507   @PSGBINFO@ (PSGBORDN, "DDPX",PSG BDDCT)=@PS GBINFO@(PS GBORDN,"DD UN",PSGBDD CT)\1*PSG
  1508   BADMS ;Who le tablets
  1509   "RTN","PSG BOX7",227, 0)
  1510    ..;Fracti onal table ts
  1511   "RTN","PSG BOX7",228, 0)
  1512    ..I +(^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBII, .02)#1) D
  1513   "RTN","PSG BOX7",229, 0)
  1514    ...D RXIN FODD(.PSGB DDCT,PSGBI I)
  1515   "RTN","PSG BOX7",230, 0)
  1516    ...S @PSG BINFO@(PSG BORDN,"DDP X",PSGBDDC T)=PSGBADM S
  1517   "RTN","PSG BOX7",231, 0)
  1518    ...S 
  1519   $P(@PSGBIN FO@(PSGBOR DN,"DDRG", PSGBDDCT), U,1)=$P(@P SGBINFO@(P SGBORDN,"D DRG",PSGBD D
  1520   CT),U,1)_" F"
  1521   "RTN","PSG BOX7",232, 0)
  1522    .;
  1523   "RTN","PSG BOX7",233, 0)
  1524    .I PSGBUR GY="EUD" D
  1525   "RTN","PSG BOX7",234, 0)
  1526    ..Q:'^TMP ($J,"PSGBO RDN",PSGBO RDN,"DDRUG ",PSGBII,. 11)
  1527   "RTN","PSG BOX7",235, 0)
  1528    ..D RXINF ODD(.PSGBD DCT,PSGBII )
  1529   "RTN","PSG BOX7",236, 0)
  1530    ..S 
  1531   @PSGBINFO@ (PSGBORDN, "DDPX",PSG BDDCT)=^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBII, .11)
  1532   "RTN","PSG BOX7",237, 0)
  1533    ;
  1534   "RTN","PSG BOX7",238, 0)
  1535    S @PSGBIN FO@(PSGBOR DN,"DDCT") =PSGBDDCT
  1536   "RTN","PSG BOX7",239, 0)
  1537    ;
  1538   "RTN","PSG BOX7",240, 0)
  1539    K ^TMP($J ,"PSGBORDN ")
  1540   "RTN","PSG BOX7",241, 0)
  1541    D PSS432^ PSS55(PSGB DFN,PSGBOR DN,"PSGBOR DN")
  1542   "RTN","PSG BOX7",242, 0)
  1543    S @PSGBIN FO@(PSGBOR DN,"SCH")= ^TMP($J,"P SGBORDN",P SGBORDN,26 )
  1544   "RTN","PSG BOX7",243, 0)
  1545    ;
  1546   "RTN","PSG BOX7",244, 0)
  1547    ;Fields n ot availab le by DBIA
  1548   "RTN","PSG BOX7",245, 0)
  1549    S @PSGBIN FO@(PSGBOR DN,"DTBG") =$$GET1^DI Q(55.06,PS GBORDN_"," _PSGBDFN_" ,",10,"I")
  1550   "RTN","PSG BOX7",246, 0)
  1551    S @PSGBIN FO@(PSGBOR DN,"DTED") =$$GET1^DI Q(55.06,PS GBORDN_"," _PSGBDFN_" ,",34,"I")
  1552   "RTN","PSG BOX7",247, 0)
  1553    S @PSGBIN FO@(PSGBOR DN,"ADTM") =$$GET1^DI Q(55.06,PS GBORDN_"," _PSGBDFN_" ,",41,"I")
  1554   "RTN","PSG BOX7",248, 0)
  1555    S @PSGBIN FO@(PSGBOR DN,"DOSE") =$$GET1^DI Q(55.06,PS GBORDN_"," _PSGBDFN_" ,",109,"I" )
  1556   "RTN","PSG BOX7",249, 0)
  1557    S @PSGBIN FO@(PSGBOR DN,"PRIO") =$$GET1^DI Q(55.06,PS GBORDN_"," _PSGBDFN_" ,",.24)
  1558   "RTN","PSG BOX7",250, 0)
  1559    I @PSGBIN FO@(PSGBOR DN,"PRIO") ="" S @PSG BINFO@(PSG BORDN,"PRI O")="ROUTI NE"
  1560   "RTN","PSG BOX7",251, 0)
  1561    S @PSGBIN FO@(PSGBOR DN,"SPIN", 1)=$$GET1^ DIQ(55.06, PSGBORDN_" ,"_PSGBDFN _",",8,"I" )
  1562   "RTN","PSG BOX7",252, 0)
  1563    ;
  1564   "RTN","PSG BOX7",253, 0)
  1565    S DFN=PSG BDFN
  1566   "RTN","PSG BOX7",254, 0)
  1567    D DEM^VAD PT
  1568   "RTN","PSG BOX7",255, 0)
  1569    S @PSGBIN FO@(PSGBOR DN,"PID")= VADM(2)
  1570   "RTN","PSG BOX7",256, 0)
  1571    S VAIP("D ")=$$NOW^X LFDT ;6/20  11:35AM
  1572   "RTN","PSG BOX7",257, 0)
  1573    D IN5^VAD PT
  1574   "RTN","PSG BOX7",258, 0)
  1575    S @PSGBIN FO@(PSGBOR DN,"WARD") =VAIP(5)
  1576   "RTN","PSG BOX7",259, 0)
  1577    S @PSGBIN FO@(PSGBOR DN,"RMBD") =VAIP(6)
  1578   "RTN","PSG BOX7",260, 0)
  1579    ;Convert  ward name  to base na me
  1580   "RTN","PSG BOX7",261, 0)
  1581    I +VAIP(5 ) D
  1582   "RTN","PSG BOX7",262, 0)
  1583    .S PSGBWR DB=$P($P(V AIP(5),U,2 ),")",1)_$ S($P(VAIP( 5),U,2)[") ":")",1:"" )
  1584   "RTN","PSG BOX7",263, 0)
  1585    .S @PSGBI NFO@(PSGBO RDN,"RMBD" )=$P(VAIP( 6),U,1)_U_ PSGBWRDB_"  "_$P(VAIP (6),U,2)
  1586   "RTN","PSG BOX7",264, 0)
  1587    ;
  1588   "RTN","PSG BOX7",265, 0)
  1589    ;Ward gro up
  1590   "RTN","PSG BOX7",266, 0)
  1591    S @PSGBIN FO@(PSGBOR DN,"WGRP") =""
  1592   "RTN","PSG BOX7",267, 0)
  1593    S PSGBWGR P=$$FIND1^ DIC(57.5," ","QX",+VA IP(5),"AB" )
  1594   "RTN","PSG BOX7",268, 0)
  1595    I +PSGBWG RP S 
  1596   @PSGBINFO@ (PSGBORDN, "WGRP")=PS GBWGRP_U_$ $GET1^DIQ( 57.5,PSGBW GRP,.01)
  1597   "RTN","PSG BOX7",269, 0)
  1598    I 'PSGBWG RP S @PSGB INFO@(PSGB ORDN,"WGRP ")=@PSGBIN FO@(PSGBOR DN,"WARD")
  1599   "RTN","PSG BOX7",270, 0)
  1600    ;S @PSGBI NFO@(PSGBO RDN,"ATCD" )=+$$GET1^ DIQ(57.5,+ @PSGBINFO@ (PSGBORDN, "WGRP"),32 ,"I")
  1601   "RTN","PSG BOX7",271, 0)
  1602    ;
  1603   "RTN","PSG BOX7",272, 0)
  1604    ;IMO loca tions
  1605   "RTN","PSG BOX7",273, 0)
  1606    I '@PSGBI NFO@(PSGBO RDN,"WARD" ) D
  1607   "RTN","PSG BOX7",274, 0)
  1608    .S PSGBLI NC=$$GET1^ DIQ(55.06, PSGBORDN_" ,"_PSGBDFN _",",130," I")
  1609   "RTN","PSG BOX7",275, 0)
  1610    .S PSGBLG RP=$$FIND1 ^DIC(57.8, "","QX",+P SGBLINC,"A C")
  1611   "RTN","PSG BOX7",276, 0)
  1612    .S @PSGBI NFO@(PSGBO RDN,"WARD" )=0_U_$E($ $GET1^DIQ( 44,PSGBLIN C,.01),1,2 0)
  1613   "RTN","PSG BOX7",277, 0)
  1614    .I +PSGBL GRP D
  1615   "RTN","PSG BOX7",278, 0)
  1616    ..S @PSGB INFO@(PSGB ORDN,"WGRP ")=PSGBLGR P_U_$$GET1 ^DIQ(57.8, PSGBLGRP,. 01)
  1617   "RTN","PSG BOX7",279, 0)
  1618    ..S @PSGB INFO@(PSGB ORDN,"RMBD ")=0_U_$P( @PSGBINFO@ (PSGBORDN, "WGRP"),U, 2)
  1619   "RTN","PSG BOX7",280, 0)
  1620    .I 'PSGBL GRP D
  1621   "RTN","PSG BOX7",281, 0)
  1622    ..S @PSGB INFO@(PSGB ORDN,"WGRP ")=@PSGBIN FO@(PSGBOR DN,"WARD")
  1623   "RTN","PSG BOX7",282, 0)
  1624    ..S @PSGB INFO@(PSGB ORDN,"RMBD ")=@PSGBIN FO@(PSGBOR DN,"WARD")
  1625   "RTN","PSG BOX7",283, 0)
  1626    ;
  1627   "RTN","PSG BOX7",284, 0)
  1628    ;Special  instructio ns
  1629   "RTN","PSG BOX7",285, 0)
  1630    ;D GET1^D IQ(55.06,P SGBORDN_", "_PSGBDFN, "135","",$ NA(PSGBDAT D),$NA(PSG BDERR))
  1631   "RTN","PSG BOX7",286, 0)
  1632    ;S PSGBII =0
  1633   "RTN","PSG BOX7",287, 0)
  1634    ;F  S PSG BII=$O(PSG BDATD(PSGB II)) Q:PSG BII=""  D
  1635   "RTN","PSG BOX7",288, 0)
  1636    ;.S @PSGB INFO@(PSGB ORDN,"SPIN ",PSGBII)= PSGBDATD(P SGBII)
  1637   "RTN","PSG BOX7",289, 0)
  1638    ;
  1639   "RTN","PSG BOX7",290, 0)
  1640    K PSGBSIG
  1641   "RTN","PSG BOX7",291, 0)
  1642    D DRGDISP ^PSJLMUT1( PSGBDFN,PS GBORDN_"U" ,100,100,. PSGBSIG,0)
  1643   "RTN","PSG BOX7",292, 0)
  1644    S PSGBII= 1
  1645   "RTN","PSG BOX7",293, 0)
  1646    F  S PSGB II=$O(PSGB SIG(PSGBII )) Q:'PSGB II  D
  1647   "RTN","PSG BOX7",294, 0)
  1648    .S @PSGBI NFO@(PSGBO RDN,"SIG", PSGBII)=$G (PSGBSIG(P SGBII))
  1649   "RTN","PSG BOX7",295, 0)
  1650    ; 
  1651   "RTN","PSG BOX7",296, 0)
  1652    ;Activity  log to fi nd service  corrected  orders
  1653   "RTN","PSG BOX7",297, 0)
  1654    K ^TMP("P SJ",$J)
  1655   "RTN","PSG BOX7",298, 0)
  1656    Q
  1657   "RTN","PSG BOX7",299, 0)
  1658    ;
  1659   "RTN","PSG BOX7",300, 0)
  1660   RXINFODD(P SGBDDCT,PS GBDDII) ;D ispense dr ug nodes
  1661   "RTN","PSG BOX7",301, 0)
  1662    S PSGBDDC T=PSGBDDCT +1
  1663   "RTN","PSG BOX7",302, 0)
  1664    S 
  1665   @PSGBINFO@ (PSGBORDN, "DDRG",PSG BDDCT)=^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBDDI I,.
  1666   01)
  1667   "RTN","PSG BOX7",303, 0)
  1668    S 
  1669   @PSGBINFO@ (PSGBORDN, "DDUN",PSG BDDCT)=^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBDDI I,
  1670   .02)
  1671   "RTN","PSG BOX7",304, 0)
  1672    S 
  1673   @PSGBINFO@ (PSGBORDN, "DDIA",PSG BDDCT)=^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBDDI I,.
  1674   03)
  1675   "RTN","PSG BOX7",305, 0)
  1676    S 
  1677   @PSGBINFO@ (PSGBORDN, "DDPX",PSG BDDCT)=^TM P($J,"PSGB ORDN",PSGB ORDN,"DDRU G",PSGBDDI I,.
  1678   09)
  1679   "RTN","PSG BOX7",306, 0)
  1680    S 
  1681   @PSGBINFO@ (PSGBORDN, "DDMN",PSG BDDCT)=$$G ET1^DIQ(50 ,+@PSGBINF O@(PSGBORD N,"DDRG",P
  1682   SGBDDCT),2 12.2)
  1683   "RTN","PSG BOX7",307, 0)
  1684    S 
  1685   @PSGBINFO@ (PSGBORDN, "DDSH",PSG BDDCT)=$$G ET1^DIQ(50 ,+@PSGBINF O@(PSGBORD N,"DDRG",P S
  1686   GBDDCT),3)
  1687   "RTN","PSG BOX7",308, 0)
  1688    Q
  1689   "RTN","PSG BOX7",309, 0)
  1690    ;
  1691   "RTN","PSG BOX7",310, 0)
  1692   RXSKIP(PSG BINFO,PSGB URGY) ;Che ck if shou ld be incl uded. . 0= Ok 1-10=Sk ip 11-19=D elete
  1693   "RTN","PSG BOX7",311, 0)
  1694    N PSGBX,P SGBRET
  1695   "RTN","PSG BOX7",312, 0)
  1696    S PSGBRET =0
  1697   "RTN","PSG BOX7",313, 0)
  1698    I PSGBURG Y="CART" D
  1699   "RTN","PSG BOX7",314, 0)
  1700    .;I $P(@P SGBINFO@(" SCHT"),U,1 )="F" S PS GBRET=10
  1701   "RTN","PSG BOX7",315, 0)
  1702    .I @PSGBI NFO@("SCH" )["PRN" S  PSGBRET=11
  1703   "RTN","PSG BOX7",316, 0)
  1704    .I $P(@PS GBINFO@("S CHT"),U,1) ="P" S PSG BRET=11
  1705   "RTN","PSG BOX7",317, 0)
  1706    .I @PSGBI NFO@("SCH" )="OC" S P SGBRET=12
  1707   "RTN","PSG BOX7",318, 0)
  1708    .I $P(@PS GBINFO@("S CHT"),U,1) ="OC" S PS GBRET=12
  1709   "RTN","PSG BOX7",319, 0)
  1710    .I $P(@PS GBINFO@("S CHT"),U,1) ="R" S PSG BRET=13
  1711   "RTN","PSG BOX7",320, 0)
  1712    Q:+PSGBRE T PSGBRET
  1713   "RTN","PSG BOX7",321, 0)
  1714    ;
  1715   "RTN","PSG BOX7",322, 0)
  1716    S PSGBX=$ P(@PSGBINF O@("STAT") ,U,1)
  1717   "RTN","PSG BOX7",323, 0)
  1718    I PSGBURG Y="CART" D
  1719   "RTN","PSG BOX7",324, 0)
  1720    .I $S(PSG BX="A":0,P SGBX="R":0 ,PSGBX="RE ":0,1:1) S  PSGBRET=1 3
  1721   "RTN","PSG BOX7",325, 0)
  1722    Q:+PSGBRE T PSGBRET
  1723   "RTN","PSG BOX7",326, 0)
  1724    Q PSGBRET
  1725   "RTN","PSG BOX7",327, 0)
  1726    ;
  1727   "RTN","PSG BOX7",328, 0)
  1728   DTC(PSGBDT IN,PSGBFRM T) ;Date/t ime conver ter
  1729   "RTN","PSG BOX7",329, 0)
  1730    Q $TR($$F MTE^XLFDT( $E(PSGBDTI N,1,12),PS GBFRMT),"@ "," ")
  1731   "RTN","PSG BOX7",330, 0)
  1732    ;
  1733   "RTN","PSG BOX7",331, 0)
  1734   SETNODE(PS GBNDCT,PSG BBEGN,PSGB VALU,PSGBE NDN,PSGBTA BS) ;Set n ode
  1735   "RTN","PSG BOX7",332, 0)
  1736    N PSGBLIN E,PSGBSPAC
  1737   "RTN","PSG BOX7",333, 0)
  1738    S PSGBSPA C=""
  1739   "RTN","PSG BOX7",334, 0)
  1740    I +$G(PSG BTABS) D
  1741   "RTN","PSG BOX7",335, 0)
  1742    .S PSGBSP AC=$E("                 ",1,PSGB TABS*3)
  1743   "RTN","PSG BOX7",336, 0)
  1744    S PSGBLIN E=$G(PSGBB EGN)_$$ENC ODE($G(PSG BVALU))_$G (PSGBENDN)
  1745   "RTN","PSG BOX7",337, 0)
  1746    S PSGBNDC T=PSGBNDCT +1
  1747   "RTN","PSG BOX7",338, 0)
  1748    S ^TMP("P SGBOX7",$J ,"TRANS",P SGBNDCT)=P SGBSPAC_PS GBLINE
  1749   "RTN","PSG BOX7",339, 0)
  1750    Q
  1751   "RTN","PSG BOX7",340, 0)
  1752    ;
  1753   "RTN","PSG BOX7",341, 0)
  1754   ENCODE(PSG BVAL0) ;En code inval id XML cha rs
  1755   "RTN","PSG BOX7",342, 0)
  1756    N PSGBSPE C
  1757   "RTN","PSG BOX7",343, 0)
  1758    S PSGBSPE C("<")="&l t;"
  1759   "RTN","PSG BOX7",344, 0)
  1760    S PSGBSPE C(">")="&g t;"
  1761   "RTN","PSG BOX7",345, 0)
  1762    S PSGBSPE C("""")="& quot;"
  1763   "RTN","PSG BOX7",346, 0)
  1764    S PSGBSPE C("'")="&a pos;"
  1765   "RTN","PSG BOX7",347, 0)
  1766    S PSGBSPE C("&")="&a mp;"
  1767   "RTN","PSG BOX7",348, 0)
  1768    Q $$REPLA CE^XLFSTR( PSGBVAL0,. PSGBSPEC)
  1769   "RTN","PSG BOX7",349, 0)
  1770    ;
  1771   "RTN","PSG BOX7",350, 0)
  1772   ISCS(PSGBC ODE) ;Retu rn 1 if co ntrolled s ub
  1773   "RTN","PSG BOX7",351, 0)
  1774    I $S(PSGB CODE["1":1 ,PSGBCODE[ "2":1,PSGB CODE["3":1 ,PSGBCODE[ "4":1,PSGB CODE["5":1 ,1:0) Q 1
  1775   "RTN","PSG BOX7",352, 0)
  1776    Q 0
  1777   "RTN","PSG BOX7",353, 0)
  1778    ;
  1779   "RTN","PSG BOX7",354, 0)
  1780   MMERRFD(PS GBDFN,PSGB ORDN,PSGBE RR) ;Tx er ror notifi cation fir st dose
  1781   "RTN","PSG BOX7",355, 0)
  1782    N XMDUZ,X MMG,XMSUB, XMTEXT,XMY ,XMZ,PSGBP ATN,PSGBSS N,PSGBOI,V ADM,DFN
  1783   "RTN","PSG BOX7",356, 0)
  1784    S DFN=+PS GBDFN
  1785   "RTN","PSG BOX7",357, 0)
  1786    D DEM^VAD PT
  1787   "RTN","PSG BOX7",358, 0)
  1788    S PSGBPAT N=VADM(1)
  1789   "RTN","PSG BOX7",359, 0)
  1790    S PSGBSSN =$E(VADM(2 ),6,9)
  1791   "RTN","PSG BOX7",360, 0)
  1792    S PSGBOI= $$GET1^DIQ (55.06,PSG BORDN_","_ PSGBDFN_", ",108)
  1793   "RTN","PSG BOX7",361, 0)
  1794    S XMSUB=" Swiss Log  Tx Error:  "_PSGBPATN _" ("_PSGB SSN_") "_P SGBOI
  1795   "RTN","PSG BOX7",362, 0)
  1796    S XMDUZ=D UZ
  1797   "RTN","PSG BOX7",363, 0)
  1798    S XMTEXT= "PSGBMSG("
  1799   "RTN","PSG BOX7",364, 0)
  1800    S PSGBMSG (1)="This  order fail ed transmi ssion to S wiss Log I MS:"
  1801   "RTN","PSG BOX7",365, 0)
  1802    S PSGBMSG (2)=" "
  1803   "RTN","PSG BOX7",366, 0)
  1804    S PSGBMSG (3)="  Pat ient:        : "_PSGB PATN_" ("_ PSGBSSN_") "
  1805   "RTN","PSG BOX7",367, 0)
  1806    S PSGBMSG (4)="  Ord erable Ite m : "_PSGB OI
  1807   "RTN","PSG BOX7",368, 0)
  1808    S PSGBMSG (5)="  Ord er Number    : "_PSGB ORDN
  1809   "RTN","PSG BOX7",369, 0)
  1810    S PSGBMSG (6)="  Err or           : "_PSGB ERR
  1811   "RTN","PSG BOX7",370, 0)
  1812    S XMY("G. PSGBOX SWI SS LOG TX  ERROR")=""
  1813   "RTN","PSG BOX7",371, 0)
  1814    D ^XMD
  1815   "RTN","PSG BOX7",372, 0)
  1816    Q
  1817   "RTN","PSG BOX7",373, 0)
  1818    ;
  1819   "RTN","PSG BOX7",374, 0)
  1820   MMERRPL(PS GBPLGI,PSG BPLWG,PSGB ERR) ;Tx e rror notif ication pi ck list
  1821   "RTN","PSG BOX7",375, 0)
  1822    N XMDUZ,X MMG,XMSUB, XMTEXT,XMY ,XMZ,PSGBP LWN,PSGBMS G
  1823   "RTN","PSG BOX7",376, 0)
  1824    S PSGBPLW N=$$GET1^D IQ(57.5,PS GBPLWG,.01 )
  1825   "RTN","PSG BOX7",377, 0)
  1826    S XMSUB=" Swiss Log  Tx Error:  "_PSGBPLWN _" PICK LI ST #"_PSGB PLGI
  1827   "RTN","PSG BOX7",378, 0)
  1828    S XMDUZ=D UZ
  1829   "RTN","PSG BOX7",379, 0)
  1830    S XMTEXT= "PSGBMSG("
  1831   "RTN","PSG BOX7",380, 0)
  1832    S PSGBMSG (1)="This  pick list  failed tra nsmission  to Swiss L og IMS:"
  1833   "RTN","PSG BOX7",381, 0)
  1834    S PSGBMSG (2)=" "
  1835   "RTN","PSG BOX7",382, 0)
  1836    S PSGBMSG (3)="  War d       :  "_PSGBPLWN
  1837   "RTN","PSG BOX7",383, 0)
  1838    S PSGBMSG (4)="  Dat e Range :  "_$$FMTE^X LFDT($$GET 1^DIQ(53.5 ,PSGBPLGI, .03,"I")," 2")_" to 
  1839   "_$$FMTE^X LFDT($$GET 1^DIQ(53.5 ,PSGBPLGI, .04,"I")," 2")
  1840   "RTN","PSG BOX7",384, 0)
  1841    S PSGBMSG (5)="  Err or      :  "_PSGBERR
  1842   "RTN","PSG BOX7",385, 0)
  1843    S XMY("G. PSGBOX SWI SS LOG TX  ERROR")=""
  1844   "RTN","PSG BOX7",386, 0)
  1845    D ^XMD
  1846   "RTN","PSG BOX7",387, 0)
  1847    Q
  1848   "RTN","PSG BOX7",388, 0)
  1849    ;
  1850   "RTN","PSG BOX9")
  1851   0^24^B1443 3212^n/a
  1852   "RTN","PSG BOX9",1,0)
  1853   PSGBOX9 ;E PIP/WLC SW ISS LOG IN TERFACE SF TP ; 29 No v 2018  1: 07 PM
  1854   "RTN","PSG BOX9",2,0)
  1855    ;;5.0;INP ATIENT MED ICATIONS;* *332**;DEC  16, 1997; Build 8
  1856   "RTN","PSG BOX9",3,0)
  1857    ; ICR  Us age         Component
  1858   "RTN","PSG BOX9",4,0)
  1859    ; ---  -- ---         ---------
  1860   "RTN","PSG BOX9",5,0)
  1861    ; 2320  S upported   ^%ZISH
  1862   "RTN","PSG BOX9",6,0)
  1863    ;
  1864   "RTN","PSG BOX9",7,0)
  1865   SFTP(PSGBF ILE) ; Cre ate .DAT f ile to tra nsfer file (s). Retur ns 0 if su ccess.
  1866   "RTN","PSG BOX9",8,0)
  1867    N PSGBERR ,PSGBCFGN, PSGBFARR
  1868   "RTN","PSG BOX9",9,0)
  1869    S PSGBERR =0
  1870   "RTN","PSG BOX9",10,0 )
  1871    S PSGBCFG N=$$GET^XP AR("SYS"," PSG BOX SF TP CFG NAM E",1,"I")
  1872   "RTN","PSG BOX9",11,0 )
  1873    I ($T(^R1 XTFTP2)]"" ),(PSGBCFG N]"") D
  1874   "RTN","PSG BOX9",12,0 )
  1875    .S PSGBFA RR("DATA_F ILE",1)=PS GBFILE
  1876   "RTN","PSG BOX9",13,0 )
  1877    .S PSGBER R='$$FTPCF G^R1XTFTP2 (PSGBCFGN, .PSGBFARR)
  1878   "RTN","PSG BOX9",14,0 )
  1879    .I PSGBER R S PSGBER R="71;FTPC FG API cal l failed"
  1880   "RTN","PSG BOX9",15,0 )
  1881    I ($T(^R1 XTFTP2)="" )!(PSGBCFG N="") D  Q  PSGBERR
  1882   "RTN","PSG BOX9",16,0 )
  1883    .S PSGBER R=$$SFTPHC (PSGBFILE, $E($P(PSGB FILE,".",1 ),5,$L(PSG BFILE)))
  1884   "RTN","PSG BOX9",17,0 )
  1885    Q PSGBERR
  1886   "RTN","PSG BOX9",18,0 )
  1887    ;
  1888   "RTN","PSG BOX9",19,0 )
  1889   SFTPHC(PSG BFILE,PSGB SUFX) ; Cr eate .DAT  file to tr ansfer fil e(s); Hard Code versi on
  1890   "RTN","PSG BOX9",20,0 )
  1891    N PSGBEDI R,PSGBEDIL ,POP,PSGBO UTF,PSGBER R,PSGBXPV1 ,PSGBPV
  1892   "RTN","PSG BOX9",21,0 )
  1893    S PSGBERR =0
  1894   "RTN","PSG BOX9",22,0 )
  1895    S PSGBEDI R=$$PWD^%Z ISH
  1896   "RTN","PSG BOX9",23,0 )
  1897    S PSGBEDI L="/"_$TR( PSGBEDIR," []:","//")
  1898   "RTN","PSG BOX9",24,0 )
  1899    S PSGBOUT F="PSGBOX9 _"_PSGBSUF X_"FTP"
  1900   "RTN","PSG BOX9",25,0 )
  1901    D SFTPCLE A(PSGBEDIR ,PSGBOUTF)
  1902   "RTN","PSG BOX9",26,0 )
  1903    ;Create F TP data fi le
  1904   "RTN","PSG BOX9",27,0 )
  1905    D OPEN^%Z ISH("FILE1 ",PSGBEDIR ,PSGBOUTF_ ".DAT","W" )
  1906   "RTN","PSG BOX9",28,0 )
  1907    S:POP PSG BERR="90;C reate scri pt file fa iled"
  1908   "RTN","PSG BOX9",29,0 )
  1909    Q:+PSGBER R PSGBERR
  1910   "RTN","PSG BOX9",30,0 )
  1911    D USE^%ZI SUTL("FILE 1")
  1912   "RTN","PSG BOX9",31,0 )
  1913    W "lcd "_ PSGBEDIR,!
  1914   "RTN","PSG BOX9",32,0 )
  1915    W "cd inb ound",!
  1916   "RTN","PSG BOX9",33,0 )
  1917    W "put "_ PSGBFILE,!
  1918   "RTN","PSG BOX9",34,0 )
  1919    W "exit", !  ; Exit  FTP
  1920   "RTN","PSG BOX9",35,0 )
  1921    D CLOSE^% ZISH("FILE 1")
  1922   "RTN","PSG BOX9",36,0 )
  1923    ;Create C OM file
  1924   "RTN","PSG BOX9",37,0 )
  1925    D OPEN^%Z ISH("FILE2 ",PSGBEDIR ,PSGBOUTF_ ".COM","W" )
  1926   "RTN","PSG BOX9",38,0 )
  1927    D USE^%ZI SUTL("FILE 2")
  1928   "RTN","PSG BOX9",39,0 )
  1929    W "$ SET  VERIFY=(PR OCEDURE,IM AGE)",!
  1930   "RTN","PSG BOX9",40,0 )
  1931    W "$ SET  DEFAULT SF C_HFS$:[XE ROX_POSTCA RD.PCARD]" ,!
  1932   "RTN","PSG BOX9",41,0 )
  1933    W "$ sftp  -""B"" "_ PSGBEDIL_P SGBOUTF_". DAT -
  1934   oIdentityF ile=/sfc_h fs$/xerox_ postcard/p card/ssh2/ identifica tion. secV istaUser@ IP             #22",!
  1935   "RTN","PSG BOX9",42,0 )
  1936    W "$ EXIT  3",!
  1937   "RTN","PSG BOX9",43,0 )
  1938    D CLOSE^% ZISH("FILE 2")
  1939   "RTN","PSG BOX9",44,0 )
  1940    ;Execute  COM
  1941   "RTN","PSG BOX9",45,0 )
  1942    S PSGBXPV 1="S PSGBP V=$ZF(-
  1943   1,""@"_PSG BEDIR_PSGB OUTF_".COM /OUTPUT="_ PSGBEDIR_P SGBOUTF_". LOG"")"
  1944   "RTN","PSG BOX9",46,0 )
  1945    X PSGBXPV 1  ; Run t he .COM fi le to tran sfer files
  1946   "RTN","PSG BOX9",47,0 )
  1947    ;Error fl ag logic
  1948   "RTN","PSG BOX9",48,0 )
  1949    I PSGBPV= -1 S PSGBE RR="91;Cal lout faile d"  ; This  error is  generated  if failure  during xf er occurs
  1950   "RTN","PSG BOX9",49,0 )
  1951    ;Clean up
  1952   "RTN","PSG BOX9",50,0 )
  1953    D SFTPCLE A(PSGBEDIR ,PSGBOUTF)
  1954   "RTN","PSG BOX9",51,0 )
  1955    Q PSGBERR
  1956   "RTN","PSG BOX9",52,0 )
  1957    ;
  1958   "RTN","PSG BOX9",53,0 )
  1959   SFTPCLEA(P SGBEDIR,PS GBOUTF) ;C lean up fi les
  1960   "RTN","PSG BOX9",54,0 )
  1961    N PSGBFIL E,PSGBX
  1962   "RTN","PSG BOX9",55,0 )
  1963    S PSGBFIL E(PSGBOUTF _".DAT")=" "
  1964   "RTN","PSG BOX9",56,0 )
  1965    S PSGBFIL E(PSGBOUTF _".COM")=" "
  1966   "RTN","PSG BOX9",57,0 )
  1967    S PSGBFIL E(PSGBOUTF _".LOG")=" "
  1968   "RTN","PSG BOX9",58,0 )
  1969    S PSGBX=$ $DEL^%ZISH (PSGBEDIR, $NA(PSGBFI LE))
  1970   "RTN","PSG BOX9",59,0 )
  1971    Q
  1972   "RTN","PSG BOX9",60,0 )
  1973    ;
  1974   "RTN","PSG BOX9",61,0 )
  1975   TQADD(PSGB FILE) ;Add  failed jo b to task  queue
  1976   "RTN","PSG BOX9",62,0 )
  1977    N PSGBEXP Y
  1978   "RTN","PSG BOX9",63,0 )
  1979    Q:$G(PSGB FILE)=""
  1980   "RTN","PSG BOX9",64,0 )
  1981    S PSGBEXP Y=$$GET^XP AR("SYS"," PSG BOX FA IL QUE EXP IRY TIME", 1,"I")
  1982   "RTN","PSG BOX9",65,0 )
  1983    I 'PSGBEX PY D TQDEL F(PSGBFILE ) Q
  1984   "RTN","PSG BOX9",66,0 )
  1985    L +^XTMP( "PSGBOX7_Q UEUE",0):5
  1986   "RTN","PSG BOX9",67,0 )
  1987    S ^XTMP(" PSGBOX7_QU EUE",0)=$$ FMADD^XLFD T(DT,1)_U_ DT
  1988   "RTN","PSG BOX9",68,0 )
  1989    L -^XTMP( "PSGBOX7_Q UEUE",0)
  1990   "RTN","PSG BOX9",69,0 )
  1991    S ^XTMP(" PSGBOX7_QU EUE",PSGBF ILE)=U_U_$ $NOW^XLFDT
  1992   "RTN","PSG BOX9",70,0 )
  1993    Q
  1994   "RTN","PSG BOX9",71,0 )
  1995    ;
  1996   "RTN","PSG BOX9",72,0 )
  1997   TQMON ;Mon itor task  queue
  1998   "RTN","PSG BOX9",73,0 )
  1999    N PSGBII, PSGBERR,PS GBEXPY
  2000   "RTN","PSG BOX9",74,0 )
  2001    L +^XTMP( "PSGBOX7_Q UEUE","RUN NING"):20   ;Only run  one job a t a time
  2002   "RTN","PSG BOX9",75,0 )
  2003    Q:'$T
  2004   "RTN","PSG BOX9",76,0 )
  2005    S PSGBEXP Y=+$$GET^X PAR("SYS", "PSG BOX F AIL QUE EX PIRY TIME" ,1,"I")
  2006   "RTN","PSG BOX9",77,0 )
  2007    S PSGBII= 0
  2008   "RTN","PSG BOX9",78,0 )
  2009    F  S PSGB II=$O(^XTM P("PSGBOX7 _QUEUE",PS GBII)) Q:P SGBII=""   D
  2010   "RTN","PSG BOX9",79,0 )
  2011    .I $$FMDI FF^XLFDT($ $NOW^XLFDT ,$P(^XTMP( "PSGBOX7_Q UEUE",PSGB II),U,3),2 )>PSGBEXPY  D  Q
  2012   "RTN","PSG BOX9",80,0 )
  2013    ..K ^XTMP ("PSGBOX7_ QUEUE",PSG BII)
  2014   "RTN","PSG BOX9",81,0 )
  2015    ..D TQDEL F(PSGBII)
  2016   "RTN","PSG BOX9",82,0 )
  2017    .S PSGBER R=$$SFTP(P SGBII)
  2018   "RTN","PSG BOX9",83,0 )
  2019    .I 'PSGBE RR D  Q
  2020   "RTN","PSG BOX9",84,0 )
  2021    ..K ^XTMP ("PSGBOX7_ QUEUE",PSG BII)
  2022   "RTN","PSG BOX9",85,0 )
  2023    ..D TQDEL F(PSGBII)
  2024   "RTN","PSG BOX9",86,0 )
  2025    .S $P(^XT MP("PSGBOX 7_QUEUE",P SGBII),U,4 )=$$NOW^XL FDT
  2026   "RTN","PSG BOX9",87,0 )
  2027    L -^XTMP( "PSGBOX7_Q UEUE","RUN NING")
  2028   "RTN","PSG BOX9",88,0 )
  2029    Q
  2030   "RTN","PSG BOX9",89,0 )
  2031    ;
  2032   "RTN","PSG BOX9",90,0 )
  2033   TQDELF(PSG BFILE) ;De lete sftp  hfs file
  2034   "RTN","PSG BOX9",91,0 )
  2035    N PSGBSAV F,PSGBX,PS GBDELA
  2036   "RTN","PSG BOX9",92,0 )
  2037    S PSGBSAV F=$$GET^XP AR("SYS"," PSG BOX SF TP SAVE FI LE",1,"I")
  2038   "RTN","PSG BOX9",93,0 )
  2039    Q:+PSGBSA VF
  2040   "RTN","PSG BOX9",94,0 )
  2041    S PSGBDEL A(PSGBFILE )=""
  2042   "RTN","PSG BOX9",95,0 )
  2043    S PSGBX=$ $DEL^%ZISH ($$PWD^%ZI SH,$NA(PSG BDELA))
  2044   "RTN","PSG BOX9",96,0 )
  2045    Q
  2046   "RTN","PSG FILED")
  2047   0^17^B2843 8752^B2500 6038
  2048   "RTN","PSG FILED",1,0 )
  2049   PSGFILED ; BIR/CML3-V ARIOUS FIL ES' UPKEEP  ; 31 Jan  2019  4:22  PM
  2050   "RTN","PSG FILED",2,0 )
  2051    ;;5.0;INP ATIENT MED ICATIONS;* *20,50,63, 119,110,11 1,112,154, 184,181,25 7,363,332* *;16 DEC 
  2052   97;Build 8
  2053   "RTN","PSG FILED",3,0 )
  2054    ;
  2055   "RTN","PSG FILED",4,0 )
  2056    ; Referen ce to ^PS( 50.606 sup ported by  DBIA# 2174 .
  2057   "RTN","PSG FILED",5,0 )
  2058    ; Referen ce to ^PSD RUG suppor ted by DBI A# 2192.
  2059   "RTN","PSG FILED",6,0 )
  2060    ; Referen ce to ^PS( 59.7 is su pported by  DBIA# 218 1.
  2061   "RTN","PSG FILED",7,0 )
  2062    ; Referen ce to ^PS( 51 is supp orted by D BIA# 2176.
  2063   "RTN","PSG FILED",8,0 )
  2064    ; Referen ce to ^PS( 51.2 is su pported by  DBIA# 217 8.
  2065   "RTN","PSG FILED",9,0 )
  2066    ; Referen ce to ^PS( 55 is supp orted by D BIA# 2191.
  2067   "RTN","PSG FILED",10, 0)
  2068    ;
  2069   "RTN","PSG FILED",11, 0)
  2070   DONE D ENK V^PSGSETU  K D0,D1,D2 ,PSGRBS Q
  2071   "RTN","PSG FILED",12, 0)
  2072    ;
  2073   "RTN","PSG FILED",13, 0)
  2074   GED ; gene ric edit
  2075   "RTN","PSG FILED",14, 0)
  2076    S DA=+Y,D R=".01;1"  W ! D ^DIE  Q
  2077   "RTN","PSG FILED",15, 0)
  2078    ;
  2079   "RTN","PSG FILED",16, 0)
  2080   ENAT ; tea m file
  2081   "RTN","PSG FILED",17, 0)
  2082    F  S DIC= "^PS(57.7, ",DIC(0)=" QEAMIL",DL AYGO=57.7, DIC("A")=" Select WAR D: " W ! D  ^DIC K 
  2083   DIC,DLAYGO  Q:Y'>0  S  DA=+Y,DIE ="^PS(57.7 ,",DR="[PS JUMATE]" D  ^DIE
  2084   "RTN","PSG FILED",18, 0)
  2085    G DONE
  2086   "RTN","PSG FILED",19, 0)
  2087    ;
  2088   "RTN","PSG FILED",20, 0)
  2089   ENAS ; sch edules fil e - no lon ger used
  2090   "RTN","PSG FILED",21, 0)
  2091    ;
  2092   "RTN","PSG FILED",22, 0)
  2093   ENMR ; med  route fil e
  2094   "RTN","PSG FILED",23, 0)
  2095    NEW MRNO, MR K DIE,D IC,DR,Y
  2096   "RTN","PSG FILED",24, 0)
  2097    F  S DIC= "^PS(51.2, ",DIC(0)=" QEAMIL",DL AYGO=51.2  W ! D ^DIC  K DIC,DLA YGO Q:+Y'> 0  S 
  2098   MRNO=+Y,MR =$P(Y,U,2) ,DA=+Y,DIE ="^PS(51.2 ,",DR=".01 ;1;3;4" D  ^DIE D DF
  2099   "RTN","PSG FILED",25, 0)
  2100    G DONE
  2101   "RTN","PSG FILED",26, 0)
  2102    ;
  2103   "RTN","PSG FILED",27, 0)
  2104   ENWG ; war d group fi le
  2105   "RTN","PSG FILED",28, 0)
  2106    F  S DIC= "^PS(57.5, ",DIC(0)=" QEAMIL",DL AYGO=57.5  W ! D ^DIC  K DA,DIC, DR Q:+Y'>0   S 
  2107   DA=+Y,DIE= "^PS(57.5, ",DR="[PSJ U WG]" D ^ DIE
  2108   "RTN","PSG FILED",29, 0)
  2109    G DONE
  2110   "RTN","PSG FILED",30, 0)
  2111    ;
  2112   "RTN","PSG FILED",31, 0)
  2113   ENMI ; med ication in struction  file
  2114   "RTN","PSG FILED",32, 0)
  2115    F  S DIC= "^PS(51,", DIC(0)="QE AMIL",DLAY GO=51 W !  D ^DIC K D IC Q:+Y'>0   S 
  2116   DIE="^PS(5 1,",DA=+Y, DR=".01;1; 30" D ^DIE
  2117   "RTN","PSG FILED",33, 0)
  2118    G DONE
  2119   "RTN","PSG FILED",34, 0)
  2120    ;
  2121   "RTN","PSG FILED",35, 0)
  2122   ENDRG ; st andard dru g fields
  2123   "RTN","PSG FILED",36, 0)
  2124    D NOW^%DT C S PSGDT= % F  S DIC ="^PSDRUG( ",DIC(0)=" AEIMOQ",DI C("A")="Se lect DISPE NSE DRUG: 
  2125   W ! D ^DIC  K DIC Q:+ Y'>0  D DE
  2126   "RTN","PSG FILED",37, 0)
  2127    K PSIUA,P SIUDA,PSIU X G DONE
  2128   "RTN","PSG FILED",38, 0)
  2129    ;
  2130   "RTN","PSG FILED",39, 0)
  2131   DE ;
  2132   "RTN","PSG FILED",40, 0)
  2133    I $D(^PSD RUG(+Y,"I" )),^("I"), ^("I")<PSG DT W $C(7) ,$C(7),!!? 3,"*** WAR NING, THIS  DRUG IS I NACTIVE. 
  2134   ***",!
  2135   "RTN","PSG FILED",41, 0)
  2136    W ! S DIE ="^PSDRUG( ",(DA,PSIU DA)=+Y,DR= "[PSJ FILE D]"
  2137   "RTN","PSG FILED",42, 0)
  2138    S PSIUX=" U^UNIT DOS E PHARMACY ^1" D ^PSG IU,^DIE:PS IUA'["^" K  DA,DIE,DR  Q
  2139   "RTN","PSG FILED",43, 0)
  2140    ;
  2141   "RTN","PSG FILED",44, 0)
  2142   ENOSE ; or der set en ter/edit
  2143   "RTN","PSG FILED",45, 0)
  2144    K DIC F   S DLAYGO=5 3.2,DIC="^ PS(53.2,", DIC(0)="QE AML",DIC(" A")="Selec t ORDER SE T: " W ! D  ^DIC K 
  2145   DIC Q:Y'>0   S DA=+Y  S DIE="^PS (53.2,",DR ="[PSJUOSE ]" D ^DIE 
  2146   D0,D1,DA,D IE,DR,PSGN EDFD,PSGS0 XT,PSGS0Y
  2147   "RTN","PSG FILED",46, 0)
  2148    G DONE
  2149   "RTN","PSG FILED",47, 0)
  2150    ;
  2151   "RTN","PSG FILED",48, 0)
  2152   RBCHK ; us ed to vali date room- bed
  2153   "RTN","PSG FILED",49, 0)
  2154    ;No longe r used.
  2155   "RTN","PSG FILED",50, 0)
  2156    ;F Z0=0:0  S Z0=$O(^ PS(57.7,DA (2),1,Z0))  Q:'Z0  I  Z0'=DA(1), $D(^(Z0,1, "B",X)) W  !?19,X," i s already  under 
  2157   ",$S('$D(^ PS(57.7,DA (2),1,Z0,0 )):"anothe r team ("_ Z0_")!",$P (^(0),"^") ]"":$P(^(0 ),"^")_"!" ,1:"anothe
  2158   team ("_Z0 _")!") Q
  2159   "RTN","PSG FILED",51, 0)
  2160    ;I 'Z0,$D (^DIC(42,D A(2),2,+$O (^DIC(42,D A(2),2,"B" ,$P(X,"-") ,0)),1,"B" ,$P(X,"-", 2))) K Z0  Q
  2161   "RTN","PSG FILED",52, 0)
  2162    ;K X,Z0 Q
  2163   "RTN","PSG FILED",53, 0)
  2164    ;
  2165   "RTN","PSG FILED",54, 0)
  2166   RBQ ; show  room-beds  for a war d
  2167   "RTN","PSG FILED",55, 0)
  2168    ;No longe r used.
  2169   "RTN","PSG FILED",56, 0)
  2170    Q
  2171   "RTN","PSG FILED",57, 0)
  2172    ;
  2173   "RTN","PSG FILED",58, 0)
  2174   RBNP W """ ^"" TO STO P: " R Z3: DTIME W:'$ T $C(7) S: '$T Z3="^"  W $C(13), "             ",$C(13 ) Q
  2175   "RTN","PSG FILED",59, 0)
  2176    ;
  2177   "RTN","PSG FILED",60, 0)
  2178   ENPPD ; ed it pharmac y patient  data
  2179   "RTN","PSG FILED",61, 0)
  2180    ; W !!?3, "...This o ption is s till under  developme nt...",! Q
  2181   "RTN","PSG FILED",62, 0)
  2182    ;
  2183   "RTN","PSG FILED",63, 0)
  2184   ENCPDD ; e dit patien t's defaul t stop dat e (wall)
  2185   "RTN","PSG FILED",64, 0)
  2186    D ENCV^PS GSETU I $D (XQUIT) Q
  2187   "RTN","PSG FILED",65, 0)
  2188    F  D ENAO ^PSGGAO Q: PSGP'>0  D
  2189   "RTN","PSG FILED",66, 0)
  2190    .S WDN=$P ($G(^DPT(P SGP,.1))," ^") W:WDN= "" !!?2,"T he patient  is not cu rrently on  a ward."
  2191   "RTN","PSG FILED",67, 0)
  2192    .I WDN]""  S WD=$O(^ DIC(42,"B" ,WDN,0)),W D=$O(^PS(5 9.6,"B",+W D,0)) I 
  2193   $S('WD:1,1 :'$P($G(^P S(59.6,WD, 0)),"^",4) ) S X="PLE ASE NOTE:  The 'SAME  STOP DATE'  parameter  for the 
  2194   ward ("_WD N_") is no t turned o n.  Any da te entered  here will  be ignore d "
  2195   "RTN","PSG FILED",68, 0)
  2196    .I  S X=X _"until th e paramete r is turne d on for t his ward."  W $C(7),! !?2 F Y=1: 1:$L(X," " ) S X(1)=$ P(X," 
  2197   ",Y) W:$L( X(1))+$X>7 8 ! W X(1) ," "
  2198   "RTN","PSG FILED",69, 0)
  2199    .S DA=PSG P,DR="62.0 1T",DIE="^ PS(55," W  !! D ^DIE
  2200   "RTN","PSG FILED",70, 0)
  2201    K WD,WDN  G DONE
  2202   "RTN","PSG FILED",71, 0)
  2203    ;
  2204   "RTN","PSG FILED",72, 0)
  2205   ENSYS ; ed it system  file
  2206   "RTN","PSG FILED",73, 0)
  2207    ;/S DIE=" ^PS(59.7," ,DA=1,DR=" 21;26;26.3 ;26.4;26.2 ;20.412ALL OW THE CHA NGE OF ORD ER TYPES O
  2208   ORDERS FRO M OERR;32"
  2209   "RTN","PSG FILED",74, 0)
  2210    N RPDDEF
  2211   "RTN","PSG FILED",75, 0)
  2212    S RPDDEF= 0
  2213   "RTN","PSG FILED",76, 0)
  2214    D  ;For R apid picki ng list
  2215   "RTN","PSG FILED",77, 0)
  2216    .N PCKVAL
  2217   "RTN","PSG FILED",78, 0)
  2218    .D LIST^D IC(59.7,"" ,"",,,,,,, ,"PCKVAL")
  2219   "RTN","PSG FILED",79, 0)
  2220    .S RPDDEF =$$GET1^DI Q(59.7,PCK VAL("DILIS T",2,1)_", ",29.3,"E" )
  2221   "RTN","PSG FILED",80, 0)
  2222    S DIE="^P S(59.7,",D A=1,DR="21 ;26;26.3;2 6.4;26.2;2 6.5;26.6;2 6.7;26.8;3 4;27;27.1"
  2223   "RTN","PSG FILED",81, 0)
  2224    S DR="21; 26;26.3;26 .4;26.2;26 .5;26.6;26 .7;29.3//" _$S(RPDDEF ]"":RPDDEF ,1:"NO")_" ;I X'=1 S 
  2225   Y=""@1"";2 9.1;29.2;@ 1;26.8;34; 27;27.1"
  2226   "RTN","PSG FILED",82, 0)
  2227    W ! D ^DI E
  2228   "RTN","PSG FILED",83, 0)
  2229    W !!,"Edi ting KERNE L Paramete rs...",!!
  2230   "RTN","PSG FILED",84, 0)
  2231    D TEDH^XP AREDIT("PS G KERNEL P ARAMETERS" ,"B") K DI E,DA,DR W  !
  2232   "RTN","PSG FILED",85, 0)
  2233    Q
  2234   "RTN","PSG FILED",86, 0)
  2235    ;
  2236   "RTN","PSG FILED",87, 0)
  2237   ENPLSP ; e dit pick l ist site p arameters
  2238   "RTN","PSG FILED",88, 0)
  2239    ;
  2240   "RTN","PSG FILED",89, 0)
  2241   ENCS ; cha nge curren t site & p arameters
  2242   "RTN","PSG FILED",90, 0)
  2243    I $D(PSJS YSW0)#2 W  !!,"Curren t site: ", $P(PSJSYSW 0,"^")
  2244   "RTN","PSG FILED",91, 0)
  2245    S PSGCSF= 1 D ^PSGSE T,ENKV^PSG SETU W:$D( XQUIT) !!? 5,"(The In patient si te you are  currently  working 
  2246   under has  not change d.)" K PSG CSF,PSGORS ET,XQUIT Q
  2247   "RTN","PSG FILED",92, 0)
  2248    ;
  2249   "RTN","PSG FILED",93, 0)
  2250   DF ; Add/e dit Med ro ute, instr uction...  to the Dos age form f ile.
  2251   "RTN","PSG FILED",94, 0)
  2252    S DIR("A" )="Would y ou like to  update th e Dosage F orm file"
  2253   "RTN","PSG FILED",95, 0)
  2254    S DIR("?" )="If your  answer is  Yes, you  will be ab le to Add/ edit the M ed routes,  Instructi ons, Verb,  Noun 
  2255   and Prepos ition that  associate  with this  Dosage fo rm."
  2256   "RTN","PSG FILED",96, 0)
  2257    S DIR(0)= "Y",DIR("B ")="Y" D ^ DIR Q:Y'=1
  2258   "RTN","PSG FILED",97, 0)
  2259    NEW Y,DFN O K DIE,DI C,DA,DR
  2260   "RTN","PSG FILED",98, 0)
  2261    F  S DIC= "^PS(50.60 6,",DIC(0) ="QEAMI" D  ^DIC Q:+Y '>0  S DFN O=+Y D
  2262   "RTN","PSG FILED",99, 0)
  2263    . I $G(MR )]"",'$D(^ PS(50.606, DFNO,"MR", "B",MRNO))  S DIE="^P S(50.606," ,DR="1///" _MR,DA=DFN O D 
  2264   ^DIE
  2265   "RTN","PSG FILED",100 ,0)
  2266    . K DIE,D IC,DR,MR S  DIE="^PS( 50.606,",D R="1;3;4;5 ",DA=DFNO  D ^DIE
  2267   "RTN","PSG FILED",101 ,0)
  2268    ;. K DIE, DIC,DR,MR  S DIE="^PS (50.606,", DR="1;2;3; 4;5",DA=DF NO D ^DIE
  2269   "RTN","PSG FILED",102 ,0)
  2270    Q
  2271   "RTN","PSG FILED",103 ,0)
  2272   ENCD ;edit  Clinic De finitions  file
  2273   "RTN","PSG FILED",104 ,0)
  2274    N CLINICS ,CLINFLG S  CLINICS=" "
  2275   "RTN","PSG FILED",105 ,0)
  2276    F  K DIC  S DIC="^PS (53.46,",D IC(0)="AEL MQ",DIC("A ")="Select  CLINIC: " ,DLAYGO=53 .46 D ^DIC  K DIC 
  2277   Q:Y<0  D
  2278   "RTN","PSG FILED",106 ,0)
  2279    . S DIE=" ^PS(53.46, ",DA=+Y,CL INICS(DA)= "",DR="1;2 ;3;6" D ^D IE K DIE,D A,DR
  2280   "RTN","PSG FILED",107 ,0)
  2281    D IMO^PSJ IMO1(.CLIN ICS)
  2282   "RTN","PSG FILED",108 ,0)
  2283    Q
  2284   "RTN","PSG FILED",109 ,0)
  2285    ;
  2286   "RTN","PSG FILED",110 ,0)
  2287   ENCG ; war d group fi le0
  2288   "RTN","PSG FILED",111 ,0)
  2289    F  S DIC= "^PS(57.8, ",DIC(0)=" QEAMIL",DL AYGO=57.8  W ! D ^DIC  K DA,DIC, DR Q:+Y'>0   S 
  2290   DA=+Y,DIE= "^PS(57.8, ",DR=".01; 1" D ^DIE
  2291   "RTN","PSG FILED",112 ,0)
  2292    G DONE
  2293   "RTN","PSG FILED",113 ,0)
  2294    ;
  2295   "RTN","PSG IEN")
  2296   0^11^B2583 050^n/a
  2297   "RTN","PSG IEN",1,0)
  2298   PSGIEN ;BP /RCC - Pri nt Drug IE N Numbers  on Pre-Exc hange Repo rts; 02 Oc t 2018  11 :10 AM ; 2 9 Nov 
  2299   2018  1:20  PM
  2300   "RTN","PSG IEN",2,0)
  2301    ;;5.0;INP ATIENT MED ICATIONS;* *332**;16  DEC 97;Bui ld 8
  2302   "RTN","PSG IEN",3,0)
  2303    Q  ;calle d at line  tag
  2304   "RTN","PSG IEN",4,0)
  2305     ;From DD S+5^PSGPER 0 & from D DS+5^PSGPE R2
  2306   "RTN","PSG IEN",5,0)
  2307   1 S ND1=$G (^PS(55,DF N,5,ON,1,+ ND,0)),UD= $P(ND1,"^" ,2),PSGIEN =+ND1,PSGI EN=" (ien:  
  2308   "_PSGIEN_" )",ND1=$$E NDDN^PSGMI (+ND1),SND 1=$E(ND1,1 ,20)_"^"_+ ND,ND=$P(N D,"^",2)
  2309   "RTN","PSG IEN",6,0)
  2310    Q
  2311   "RTN","PSG IEN",7,0)
  2312    ;
  2313   "RTN","PSG IEN",8,0)
  2314   2 ;From DD S+5^PSGPER 0
  2315   "RTN","PSG IEN",9,0)
  2316    S 
  2317   ^TMP("PSGP ER",$J,WD, SPN,SDN,SN D1)=ND1_"^ "_UD_"^"_N D,$P(^TMP( "PSGPER",$ J,WD,SPN,S DN,SND
  2318   1),U,20)=P SGIEN
  2319   "RTN","PSG IEN",10,0)
  2320    Q
  2321   "RTN","PSG IEN",11,0)
  2322    ;
  2323   "RTN","PSG IEN",12,0)
  2324   3 ;From PR T+3^PSGPER 0 & from P RT+3^PSGPE R0
  2325   "RTN","PSG IEN",13,0)
  2326    I 1 S PDN =$P(PX,"^" ),UD=$P(PX ,"^",2),PS GIEN=$P(PX ,"^",20),P X=$P(PX,"^ ",3) W 
  2327   !?10,PDN,P SGIEN,?62, $J($S('UD: 1,$E(UD)=" .":0_UD,1: UD),5),?72 ,$J(PX,5)  Q
  2328   "RTN","PSG IEN",14,0)
  2329    Q
  2330   "RTN","PSG IEN",15,0)
  2331    ;
  2332   "RTN","PSG IEN",16,0)
  2333   4 ;From DD S+8^PSGPER 2
  2334   "RTN","PSG IEN",17,0)
  2335    S 
  2336   ^TMP("PSGP ERP",$J,WD ,SPN,SDN,S ND1)=ND1_" ^"_UD_"^"_ ND,$P(^TMP ("PSGPERP" ,$J,WD,SPN ,SDN,S
  2337   ND1),U,20) =PSGIEN
  2338   "RTN","PSG IEN",18,0)
  2339    Q
  2340   "RTN","PSG IEN",19,0)
  2341    ;
  2342   "RTN","PSG PEN")
  2343   0^3^B59188 020^B57889 018
  2344   "RTN","PSG PEN",1,0)
  2345   PSGPEN ;BI R/CML3 - F IND DEFAUL T FOR PRE- EXCHANGE N EEDS ; 02  Oct 2018   11:11 AM
  2346   "RTN","PSG PEN",2,0)
  2347    ;;5.0;INP ATIENT MED ICATIONS;* *30,37,50, 58,115,110 ,127,129,3 23,317,357 ,332**;16  DEC 97;Bui ld 8
  2348   "RTN","PSG PEN",3,0)
  2349    ;
  2350   "RTN","PSG PEN",4,0)
  2351    ; Referen ces to ^PS D(58.8 sup ported by  DBIA #2283 .
  2352   "RTN","PSG PEN",5,0)
  2353    ; Referen ces to ^PS I(58.1 sup ported by  DBIA #2284 .
  2354   "RTN","PSG PEN",6,0)
  2355    ; Referen ce to ^PS( 55 is supp orted by D BIA #2191.
  2356   "RTN","PSG PEN",7,0)
  2357    ; Referen ce to ^PSD RUG is sup ported by  DBIA #2192 .
  2358   "RTN","PSG PEN",8,0)
  2359    ; Referen ce to ^PS( 59.7 is su pported by  DBIA #218 1.
  2360   "RTN","PSG PEN",9,0)
  2361    ;
  2362   "RTN","PSG PEN",10,0)
  2363   EN(PSGPENO ) ;
  2364   "RTN","PSG PEN",11,0)
  2365    S PSGPENO =+PSGPENO
  2366   "RTN","PSG PEN",12,0)
  2367    N PSJPADE
  2368   "RTN","PSG PEN",13,0)
  2369    S PSJPADE =$$PADE($G (PSJPWD),P SGP,PSGPEN O_"U")  ;  PADE check  - PSJ*5*3 17
  2370   "RTN","PSG PEN",14,0)
  2371    N PSJSITE ,PSJPRN,PS JCLO,ND8 S  PSJCLO=0, ND8=0 S PS JSITE=0,PS JSITE=$O(^ PS(59.7,PS JSITE)) I 
  2372   $P($G(^(PS JSITE,26)) ,U,5)=1 S  PSJPRN=1
  2373   "RTN","PSG PEN",15,0)
  2374    D NOW^%DT C S PSGDT= %,DT=$$DT^ XLFDT,PSGP EN="" S 
  2375   ND=$G(^PS( 55,PSGP,5, PSGPENO,0) ),ND8=$G(^ PS(55,PSGP ,5,PSGPENO ,8))
  2376   "RTN","PSG PEN",16,0)
  2377    S:$P(ND8, "^",2) PSJ CLO=1
  2378   "RTN","PSG PEN",17,0)
  2379    S PSGPENW S=0 I PSJP WD,'PSJCLO  F Q=0:0 S  Q=$O(^PS( 55,PSGP,5, PSGPENO,1, Q)) Q:'Q   S ND=$G(^( Q,0)) 
  2380   I ND,'$P(N D,"^",3),( $D(^PSI(58 .1,"D",+ND ,PSJPWD))! $D(^PSD(58 .8,"D",+ND ,PSJPWD)))  S PSGPENW S=1 Q
  2381   "RTN","PSG PEN",18,0)
  2382    I PSGPENW S F Q=0:0  S Q=$O(^PS (55,PSGP,5 ,PSGPENO,1 ,Q)) Q:'Q   S ND=$G(^ (Q,0)) I N D,'$P(ND," ^",3) 
  2383   S:'$D(^PSI (58.1,"D", +ND,PSJPWD ))&'$D(^PS D(58.8,"D" ,+ND,PSJPW D)) PSGPEN WS=0 Q:'PS GPENWS  S 
  2384   $P(PSGPENW S,"^",2)=1
  2385   "RTN","PSG PEN",19,0)
  2386    I PSJPADE &'PSGPENWS  W !!,"The  dispense  drug",$S(P SJPADE>1:" s",1:""),"  for this  order 
  2387   ",$S(PSJPA DE>1:"are" ,1:"is a") ," PADE it em",$S(PSJ PADE>1:"s" ,1:""),"."  S PSGPEN= 0
  2388   "RTN","PSG PEN",20,0)
  2389    I PSJPADE &PSGPENWS  W !!,"The  dispense d rug",$S(PS JPADE>1:"s ",1:""),"  for this o rder 
  2390   ",$S(PSJPA DE>1:"are" ,1:"is a") ," WARD ST OCK/PADE i tem",$S(PS JPADE>1:"s ",1:""),". " S PSGPEN =0
  2391   "RTN","PSG PEN",21,0)
  2392    I PSGPENW S&'PSJPADE  W !!,"The  dispense  drug",$E(" s",$P(PSGP ENWS,"^",2 ))," for t his order 
  2393   ",$S($P(PS GPENWS,"^" ,2):"are", 1:"is a"), " WARD STO CK item",$ E("s",$P(P SGPENWS,"^ ",2)),"." 
  2394   PSGPEN=0
  2395   "RTN","PSG PEN",22,0)
  2396    I 'PSGPEN WS,PSJPWD, 'PSJPADE S  
  2397   WG=+$O(^PS (57.5,"AB" ,PSJPWD,0) ),PSGPLS=$ P($G(^PS(5 5,PSGP,5,P SGPENO,2)) ,"^",2) I  PSGPLS D
  2398   "RTN","PSG PEN",23,0)
  2399    .S PSGPLF =$O(^PS(53 .5,"AB",WG ,PSGDT))
  2400   "RTN","PSG PEN",24,0)
  2401    .N RNDT,P SJRNOS S 
  2402   RNDT=$$LAS TREN^PSJLM PRI(PSGP,$ S($G(PSJOR D)["P":PSJ ORD,1:"")) ,PSJRNOS=$ P(RNDT,"^" ,4) I 
  2403   PSJRNOS,'$ G(PSJREN)  S PSGPLS=P SJRNOS
  2404   "RTN","PSG PEN",25,0)
  2405    .I $G(PSJ REN),$G(PS JORD)["U"  S PSJRNOS= $P(^PS(55, PSGP,5,+PS JORD,2),"^ ",4) S 
  2406   PSGPLS=$S( PSJRNOS>PS GDT:PSJRNO S,1:$$DATE 2^PSJUTL2( PSGDT))
  2407   "RTN","PSG PEN",26,0)
  2408    .D:'PSGPL F GF I PSG PLF S PSGP LO=PSGPENO  D NCE,^PS GPL0 S:PSG PLC'<0 PSG PEN=PSGPLC
  2409   "RTN","PSG PEN",27,0)
  2410    I $G(PSGP RIO)="DONE " S PSGPEN =0
  2411   "RTN","PSG PEN",28,0)
  2412    ;
  2413   "RTN","PSG PEN",29,0)
  2414   UPDD ;
  2415   "RTN","PSG PEN",30,0)
  2416    N DIR,PSG PEXU S DIR (0)="NOA^0 :9999:0",D IR("A")="P re-Exchang e DOSES: " ,DIR("?")= "^D DH^PSG PEN" 
  2417   S:PSGPEN]" " DIR("B") =PSGPEN W  ! D ^DIR S :Y PSGPEXU =+Y
  2418   "RTN","PSG PEN",31,0)
  2419    ;N X S X= $$GET^XPAR ("SYS","PS G BOX FIRS T DOSE INT  ON",1,"I" ) I X D 
  2420   ORDSAVE^PS GBOX1(PSGP ,PSGPENO,Y )
  2421   "RTN","PSG PEN",32,0)
  2422    G:'Y DONE  S PSGY=+Y  W !!,"... updating d ispense dr ugs..."
  2423   "RTN","PSG PEN",33,0)
  2424    F FQ=0:0  S FQ=$O(^P S(55,PSGP, 5,PSGPENO, 1,FQ)) Q:' FQ  S ND=$ G(^(FQ,0)) ,$P(^(0)," ^",9)="" I  
  2425   ND,'$P(ND, "^",3) D D D
  2426   "RTN","PSG PEN",34,0)
  2427    N X S X=$ $GET^XPAR( "SYS","PSG  BOX FIRST  DOSE INT  ON",1,"I")  I X D 
  2428   ORDSAVE^PS GBOX1(PSGP ,PSGPENO,P SGPEXU)
  2429   "RTN","PSG PEN",35,0)
  2430    ;
  2431   "RTN","PSG PEN",36,0)
  2432   DONE ;
  2433   "RTN","PSG PEN",37,0)
  2434    I $P(PSJS YSW0,"^",2 9)="",$$DE FON^PSGPER 1 S $P(PSJ SYSW0,"^", 29)=0
  2435   "RTN","PSG PEN",38,0)
  2436    K PSGID,P SGMAR,PSGO D,PSGPLC,P SGPLF,PSGP LO,PSGPLS, PSGPLUD,WG  S:$G(PSJR EN) DUOUT= 0 Q
  2437   "RTN","PSG PEN",39,0)
  2438    ;
  2439   "RTN","PSG PEN",40,0)
  2440   NCE ;
  2441   "RTN","PSG PEN",41,0)
  2442    W !!,"The  next cart  exchange  is ",$$END TC^PSGMI(P SGPLF),! Q
  2443   "RTN","PSG PEN",42,0)
  2444    ;
  2445   "RTN","PSG PEN",43,0)
  2446   GF ;
  2447   "RTN","PSG PEN",44,0)
  2448    S QQ=0 F  Q=0:0 S Q= $O(^PS(53. 5,"AB",WG, Q)) Q:'Q   S QQ=Q
  2449   "RTN","PSG PEN",45,0)
  2450    I QQ S QQ =$O(^PS(53 .5,"AB",WG ,QQ,0)) I  QQ,$D(^PS( 53.5,QQ,0) ) S QQ=$P( ^(0),"^",4 ) I QQ>PSG DT S 
  2451   PSGPLF=QQ
  2452   "RTN","PSG PEN",46,0)
  2453    Q
  2454   "RTN","PSG PEN",47,0)
  2455    ;
  2456   "RTN","PSG PEN",48,0)
  2457   DD ;
  2458   "RTN","PSG PEN",49,0)
  2459    N DA S DR G=$S($P(ND ,"^")="":" NOT FOUND" ,'$D(^PSDR UG(+ND,0)) :"NOT FOUN
  2460   ("_$P(ND," ^")_")",$P (^(0),"^") ]"":$P(^(0 ),"^"),1:$ P(ND,"^")_ ";PSDRUG(" ),UD=$S('$ P(ND,"^",2 ):1,1:$P(N
  2461   D,"^",2))
  2462   "RTN","PSG PEN",50,0)
  2463    W !,"..." ,DRG,?45," U/D: ",UD, "..."
  2464   "RTN","PSG PEN",51,0)
  2465    S PSGDA=P SGY I 
  2466   'PSGPENWS, 'PSJCLO,ND ,PSJPWD,($ D(^PSI(58. 1,"D",+ND, PSJPWD))!$ D(^PSD(58. 8,"D",+ND, PSJPWD))) 
  2467   PSGPENWS Q :'PSGDA
  2468   "RTN","PSG PEN",52,0)
  2469    K DA,DR S  PSGDA=$S( UD#1:(PSGD A*((UD\1)+ 1)),1:PSGD A*UD)
  2470   "RTN","PSG PEN",53,0)
  2471    S DIE="^P S(55,"_PSG P_",5,"_PS GPENO_",1, ",DA(2)=PS GP,DA(1)=P SGPENO,DA= FQ,DR=".09 ////"_PSGD
  2472   D ^DIE
  2473   "RTN","PSG PEN",54,0)
  2474    S PSGPXN= $G(PSGPXN)
  2475   "RTN","PSG PEN",55,0)
  2476    D:'PSGPXN
  2477   "RTN","PSG PEN",56,0)
  2478    .D NOW^%D TC L +^PS( 53.4,0):0  S ND=$G(^P S(53.4,0))  S:ND="" N D="PRE-EXC HANGE NEED S^53.4P" F  
  2479   PSGPXN=$P( ND,"^",3)+ 1:1 I '$D( ^PS(53.4,P SGPXN)) L  +^PS(53.4, PSGPXN):0  I  S 
  2480   ^PS(53.4,0 )=$P(ND,"^ ",1,2)_"^" _PSGPXN_"^ "_($P(ND," ^",4)+1) L  -^PS(53.4 ,0) Q
  2481   "RTN","PSG PEN",57,0)
  2482    .S ^PS(53 .4,PSGPXN, 0)=DUZ_"^" _%,^PS(53. 4,"B",DUZ, PSGPXN)="" ,^PS(53.4, "AUD",DUZ, %,PSGPXN)= "" L 
  2483   -^PS(53.4, PSGPXN) Q
  2484   "RTN","PSG PEN",58,0)
  2485    I $D(^PS( 53.4,PSGPX N,1,PSGP,1 ,PSGPENO,1 ,FQ,0)) S  $P(^(0),"^ ",2)=$P(^( 0),"^",2)+ PSGDA Q
  2486   "RTN","PSG PEN",59,0)
  2487    ; naked r eference b elow refer s to line  above
  2488   "RTN","PSG PEN",60,0)
  2489    S ^(0)=FQ _"^"_PSGDA  I $D(^PS( 53.4,PSGPX N,1,PSGP,1 ,PSGPENO,1 ,0)) S 
  2490   $P(^(0),"^ ",3,4)=FQ_ "^"_($P(^( 0),"^",4)+ 1) Q
  2491   "RTN","PSG PEN",61,0)
  2492    ; naked r eference b elow refer s to line  above
  2493   "RTN","PSG PEN",62,0)
  2494    S ^(0)="^ 53.401101A ^"_FQ_"^1"  Q:$D(^PS( 53.4,PSGPX N,1,PSGP,1 ,PSGPENO,0 ))  S ^(0) =PSGPENO
  2495   "RTN","PSG PEN",63,0)
  2496    I $D(^PS( 53.4,PSGPX N,1,PSGP,1 ,0)) S $P( ^(0),"^",3 ,4)=PSGPEN O_"^"_($P( ^(0),"^",4 )+1) Q
  2497   "RTN","PSG PEN",64,0)
  2498    ; naked r eference b elow is fr om line ab ove
  2499   "RTN","PSG PEN",65,0)
  2500    S ^(0)="^ 53.4011A^" _PSGPENO_" ^1" Q:$D(^ PS(53.4,PS GPXN,1,PSG P,0))  S ^ (0)=PSGP
  2501   "RTN","PSG PEN",66,0)
  2502    I $D(^PS( 53.4,PSGPX N,1,0)) S  $P(^(0),"^ ",3,4)=PSG P_"^"_($P( ^(0),"^",4 )+1) Q
  2503   "RTN","PSG PEN",67,0)
  2504    ; naked r eference b elow is fr om line ab ove
  2505   "RTN","PSG PEN",68,0)
  2506    S ^(0)="^ 53.401PA^" _PSGP_"^1"  Q
  2507   "RTN","PSG PEN",69,0)
  2508    ;
  2509   "RTN","PSG PEN",70,0)
  2510   DH ;
  2511   "RTN","PSG PEN",71,0)
  2512    W !!?2,"E nter a num ber from 0  to 9999,  0 decimal  digits."
  2513   "RTN","PSG PEN",72,0)
  2514    W !!?2,"E nter the n umber DOSE S needed f or this or der until  the next c art exchan ge.",!,"Th is will be  the 
  2515   number of  times the  order will  be admini stered to  the patien t",!,"from  the start  of the or der until  the 
  2516   next cart  exchange."
  2517   "RTN","PSG PEN",73,0)
  2518    W !!?2,"P LEASE NOTE  that this  is DOSES,  and NOT U NITS.  The  doses ent ered will  be",!,"con verted to 
  2519   units for  each dispe nse drug o f this ord er, as eac h dispense  drug",!," may have a  different  units per  
  2520   dose." Q
  2521   "RTN","PSG PEN",74,0)
  2522    ;
  2523   "RTN","PSG PEN",75,0)
  2524   PSGPENWS ;
  2525   "RTN","PSG PEN",76,0)
  2526    W !,"This  dispense  drug is a  WARD STOCK  item."
  2527   "RTN","PSG PEN",77,0)
  2528    W !,"Woul d you like  to:",!?3, "1 - Enter  0 (no) do ses needed  for this  dispense d rug.",!?3, "2 - Enter  
  2529   ",PSGDA,"  doses need ed for thi s dispense  drug.",!? 3,"3 - Ent er another  amount as  the doses  needed fo
  2530   this dispe nse drug."
  2531   "RTN","PSG PEN",78,0)
  2532    K DIR S D IR(0)="SA^ 1:0 (no) d oses;2:"_P SGDA_" dos es;3:anoth er amount" ,DIR("A")= "Select AC TION: 
  2533   ",DIR("?") ="^D WH^PS GPEN" W !  D ^DIR I Y =1!'Y S PS GDA=0 Q
  2534   "RTN","PSG PEN",79,0)
  2535    Q:Y=2  K  DIR S DIR( 0)="NA^0:9 999:0",DIR ("A")="Pre -Exchange  DOSES for  this dispe nse drug: 
  2536   ",DIR("?") ="^D WDH^P SGPEN" W !  D ^DIR S  PSGDA=+Y Q
  2537   "RTN","PSG PEN",80,0)
  2538    ;
  2539   "RTN","PSG PEN",81,0)
  2540   WH ;
  2541   "RTN","PSG PEN",82,0)
  2542    S Q="This  dispense  drug ("_DR G_") is a  ward stock  item.  Se lect:"
  2543   "RTN","PSG PEN",83,0)
  2544    W !! F Q1 =1:1:$L(Q, " ") S Q2= $P(Q," ",Q 1) W:$X+$L (Q2)>78 !  W Q2," "
  2545   "RTN","PSG PEN",84,0)
  2546    W !?3,"1  to enter 0  (no) pre- exchange d oses for t his dispen se drug.", !?3,"2 to  enter ",PS GDA," dose s for 
  2547   this dispe nse drug." ,!?3,"3 to  enter ano ther amoun t for this  dispense  drug." Q
  2548   "RTN","PSG PEN",85,0)
  2549    ;
  2550   "RTN","PSG PEN",86,0)
  2551   WDH ;
  2552   "RTN","PSG PEN",87,0)
  2553    W !!?2,"E nter a num ber from 0  to 9999,  0 decimal  digits.  I f you ente r an '^' t o exit",!, "NO pre-ex change 
  2554   doses will  be entere d for this  dispense  drug." Q
  2555   "RTN","PSG PEN",88,0)
  2556    ;
  2557   "RTN","PSG PEN",89,0)
  2558   PADE(PSJPW D,PSGP,PSG ORD)  ; Ph armacy Aut omation Di spensing E quipment ( PADE) chec k - PSJ*5* 317
  2559   "RTN","PSG PEN",90,0)
  2560    ; INPUT:  PSJPWD = W ard locati on
  2561   "RTN","PSG PEN",91,0)
  2562    ;         PSGP   = P atient DFN
  2563   "RTN","PSG PEN",92,0)
  2564    ;         PSGORD = O rder numbe r
  2565   "RTN","PSG PEN",93,0)
  2566    ; OUTPUT:  PADE = Ca n this ord er be disp ensed via  PADE?
  2567   "RTN","PSG PEN",94,0)
  2568    ;
  2569   "RTN","PSG PEN",95,0)
  2570    N PADE,DF N,PSJDDND, PSJWDFLG
  2571   "RTN","PSG PEN",96,0)
  2572    I '$G(PSJ PWD)!'$G(P SGP)!'$G(P SGORD) Q " "
  2573   "RTN","PSG PEN",97,0)
  2574    S PADE="" ,DFN=$G(PS GP)
  2575   "RTN","PSG PEN",98,0)
  2576    ; Check D EFAULT 0 O N PADE PRE -EXCHANGE  parameter
  2577   "RTN","PSG PEN",99,0)
  2578    D GETS^DI Q(59.6,+$G (PSJSYSW), 8,"I","PSJ WDFLG")
  2579   "RTN","PSG PEN",100,0 )
  2580    I $G(PSJW DFLG("59.6 ",+$G(PSJS YSW)_",",8 ,"I")) D
  2581   "RTN","PSG PEN",101,0 )
  2582    .N PSJPDL OC,PSJORCL ,PSJCLNK
  2583   "RTN","PSG PEN",102,0 )
  2584    .; If cli nic order,  quit if c linic loca tion is no t linked t o PADE
  2585   "RTN","PSG PEN",103,0 )
  2586    .S 
  2587   PSJORCL=$S ($G(PSGORD )["P":$G(^ PS(53.1,+$ G(PSGORD), "DSS")),$G (PSGORD)[" U":$G(^PS( 55,+$G(PSG P
  2588   ),5,+$G(PS GORD),8)), $G(PSGORD) ["V":$G(^P S(55,+$G(P SGP),"IV", +$G(PSGORD ),"DSS")), 1:"")
  2589   "RTN","PSG PEN",104,0 )
  2590    .I PSJORC L,$P(PSJOR CL,"^",2)  S PSJCLNK= $$PADECL^P SJPAD50(+$ G(PSJORCL) ) Q:'PSJCL NK
  2591   "RTN","PSG PEN",105,0 )
  2592    .I '$G(PS JCLNK) Q:' $$PADEWD^P SJPAD50(PS JPWD)   ;  Quit if pa tient loca tion not l inked to P ADE
  2593   "RTN","PSG PEN",106,0 )
  2594    .S 
  2595   PSJPDLOC=$ S($G(PSGOR D)["P":+$G (^PS(53.1, +PSGORD,"D SS"))_"C", $G(PSGORD) ["U":+$G(^ PS(55,+$G( D
  2596   FN),5,+$G( PSGORD),8) )_"C",1:"" )
  2597   "RTN","PSG PEN",107,0 )
  2598    .S:'PSJPD LOC PSJPDL OC=+$G(PSJ PWD)
  2599   "RTN","PSG PEN",108,0 )
  2600    .N PADEFL AG,DDCNT S  PADEFLAG= 1
  2601   "RTN","PSG PEN",109,0 )
  2602    .I $G(PSG ORD)["U" S  Q=0 F DDC NT=0:1 S Q =$O(^PS(55 ,+$G(PSGP) ,5,+PSGORD ,1,Q)) Q:' Q!'PADEFLA G  S 
  2603   PSJDDND=$G (^(Q,0)) D
  2604   "RTN","PSG PEN",110,0 )
  2605    ..S PADEF LAG=+$$DRG QTY^PSJPAD SI(+PSJDDN D,$S(PSJPD LOC["C":"C L",1:"WD") ,+PSJPDLOC )
  2606   "RTN","PSG PEN",111,0 )
  2607    .I $G(PSG ORD)'["U"  S Q=0 F DD CNT=0:1 S  Q=$O(^PS(5 3.45,+$G(P SJSYSP),2, Q)) Q:'Q!' PADEFLAG  
  2608   PSJDDND=$G (^(Q,0)) D
  2609   "RTN","PSG PEN",112,0 )
  2610    ..S PADEF LAG=+$$DRG QTY^PSJPAD SI(+PSJDDN D,$S(PSJPD LOC["C":"C L",1:"WD") ,+PSJPDLOC )
  2611   "RTN","PSG PEN",113,0 )
  2612    .I DDCNT, PADEFLAG S  PADE=DDCN T
  2613   "RTN","PSG PEN",114,0 )
  2614    Q PADE
  2615   "RTN","PSG PER")
  2616   0^10^B2102 4384^B1833 2674
  2617   "RTN","PSG PER",1,0)
  2618   PSGPER ;BI R/CML3-PRI NTS PRE-EX CHANGE NEE DS REPORT  ; 04 Feb 2 019  11:08  AM
  2619   "RTN","PSG PER",2,0)
  2620    ;;5.0;INP ATIENT MED ICATIONS;* *95,115,12 7,133,279, 332**;16 D EC 97;Buil d 8
  2621   "RTN","PSG PER",3,0)
  2622    ;
  2623   "RTN","PSG PER",4,0)
  2624   EN ; Entry  point
  2625   "RTN","PSG PER",5,0)
  2626    S PSGPERR F=0,POP=0  N PSGPRCLD ,PSGCURCL  S PSGPRCLD ="" D DEFC L^PSGPER1( PSGPXN,.PS GPRCLD)
  2627   "RTN","PSG PER",6,0)
  2628    N PSGPRTY P,PSGPRCL
  2629   "RTN","PSG PER",7,0)
  2630    I $G(PSGP RCLD("WARD ")) S PSGP RTYP="PSGP ERP" D DEV  K PSGPRCL D("WARD")
  2631   "RTN","PSG PER",8,0)
  2632    I POP D P OP G:%=1 E N D OUT Q
  2633   "RTN","PSG PER",9,0)
  2634    I $D(PSGP RCLD)>1 S  PSGPRTYP=" PSGPERPC"  S PSGCURCL ="" F  S 
  2635   PSGCURCL=$ O(PSGPRCLD ("DEV",PSG CURCL)) Q: PSGCURCL=" "  D DEV
  2636   "RTN","PSG PER",10,0)
  2637    D OUT
  2638   "RTN","PSG PER",11,0)
  2639    Q
  2640   "RTN","PSG PER",12,0)
  2641   DEV ; Sele ct Device
  2642   "RTN","PSG PER",13,0)
  2643    S PSGION= ION
  2644   "RTN","PSG PER",14,0)
  2645    D DEV1
  2646   "RTN","PSG PER",15,0)
  2647    Q
  2648   "RTN","PSG PER",16,0)
  2649   DEV1 ; Get  default d evice, sel ect and va lidate dev ice
  2650   "RTN","PSG PER",17,0)
  2651    N PSGFG S  PSGFG=0
  2652   "RTN","PSG PER",18,0)
  2653    Q:'$$DEFO N^PSGPER1
  2654   "RTN","PSG PER",19,0)
  2655    N RPTLBL
  2656   "RTN","PSG PER",20,0)
  2657    S RPTLBL= "Pre-Excha nge Report "
  2658   "RTN","PSG PER",21,0)
  2659    W !!,$S($ $GET^XPAR( "DIV","PSG  PRE-EX RE PORT ZEBRA  LABELS"," `"_DUZ(2)) :"PRE-EXCH ANGE 
  2660   LABELS",1: "PRE-EXCHA NGE UNITS  REPORT")
  2661   "RTN","PSG PER",22,0)
  2662    I ($G(PSG CURCL)="")  S D=$S($G (PSGPXDEV) :PSGPXDEV, 1:$P(PSJSY SW0,U,29))
  2663   "RTN","PSG PER",23,0)
  2664    I $L($G(P SGCURCL))  S D=$G(PSG PRCLD("DEV ",PSGCURCL ))
  2665   "RTN","PSG PER",24,0)
  2666    S:D="" D= "HOME" S I OP=$S(D:"` "_D,1:D) K  %ZIS S %Z IS="NQ" D  ^%ZIS S D= $G(ION)
  2667   "RTN","PSG PER",25,0)
  2668    K IOP,%ZI S,IO("Q")  S %ZIS="Q" ,%ZIS("A") ="Select D EVICE for  "_$S($G(PS GPRCLD("WA RD")):"War
  2669   "_$G(^DPT( DFN,.1)),$ G(PSGCURCL )]"":"Clin ic "_PSGCU RCL,1:"")_ ": 
  2670   ",%ZIS("B" )=$S(($G(P SGCURCL)]" "):$G(PSGP RCLD("DEV" ,PSGCURCL) ),1:D)
  2671   "RTN","PSG PER",26,0)
  2672    D ^%ZIS K  %ZIS I PO P D POP G: %=1 DEV1
  2673   "RTN","PSG PER",27,0)
  2674    I D'=$G(I ON) D CURD EF
  2675   "RTN","PSG PER",28,0)
  2676    I $$GET^X PAR("DIV", "PSG PRE-E X REPORT Z EBRA LABEL S","`"_DUZ (2)) D
  2677   "RTN","PSG PER",29,0)
  2678    . K ZTSAV E S PSGTIR ="^PSGZEBL ",ZTDESC=" PRE-EXCHAN GE UNITS L ABELS"
  2679   "RTN","PSG PER",30,0)
  2680    . S ZTDTH =$H,ZTSAVE ("PSGPXN") ="",ZTSAVE ("PSGPRTYP ")=""
  2681   "RTN","PSG PER",31,0)
  2682    . S ZTSAV E("PSGCURC L")="",ZTS AVE("DFN") =""
  2683   "RTN","PSG PER",32,0)
  2684    . D ENTSK ^PSGTI G:' $D(ZTSK) D EV1 K ZTSK
  2685   "RTN","PSG PER",33,0)
  2686    E  K ZTSA VE S PSGTI R="^PSGPER 0",ZTDESC= "PRE-EXCHA NGE UNITS 
  2687   REPORT",ZT DTH=$H,ZTS AVE("PSGPX N")="",ZTS AVE("PSGPR TYP")="",Z TSAVE("PSG CURCL")="" ,ZTSAVE("
  2688   DFN")="" D  ENTSK^PSG TI G:'$D(Z TSK) DEV1  K ZTSK
  2689   "RTN","PSG PER",34,0)
  2690    D ENP^PSG PER0:'$G(P SGPXPT),EN PAT^PSGPER 0:$G(PSGPX PT),AG
  2691   "RTN","PSG PER",35,0)
  2692    I %=1 S P SGPERRF=1  G DEV1
  2693   "RTN","PSG PER",36,0)
  2694    Q
  2695   "RTN","PSG PER",37,0)
  2696    ;
  2697   "RTN","PSG PER",38,0)
  2698   OUT ; Clea n up on th e way out
  2699   "RTN","PSG PER",39,0)
  2700    D TASKPRG E^PSGPER1( PSGPXN)
  2701   "RTN","PSG PER",40,0)
  2702    K PSGPERR F,PSGPXN
  2703   "RTN","PSG PER",41,0)
  2704    Q:$G(PSJC OM)!$G(PSJ PREX)
  2705   "RTN","PSG PER",42,0)
  2706    N PSJSYSW 0,PSGVBW,P SJPWD,PSJS YSL D  Q
  2707   "RTN","PSG PER",43,0)
  2708    . D:'$G(P SGPXPT) EN IVKV^PSGSE TU
  2709   "RTN","PSG PER",44,0)
  2710    Q
  2711   "RTN","PSG PER",45,0)
  2712    ;
  2713   "RTN","PSG PER",46,0)
  2714   POP ; Abor t?
  2715   "RTN","PSG PER",47,0)
  2716    S %=2 W:' PSGPERRF ! !,"IF A DE VICE IS NO T CHOSEN,  NO REPORT  WILL BE RU N AND THE  DATA WILL  NO 
  2717   LONGER BE  RETRIEVABL E THROUGH  THIS REPOR T."
  2718   "RTN","PSG PER",48,0)
  2719    I 'PSGPER RF F  W !, "Do you wa nt another  chance to  choose a  device" S  %=1 D YN^D ICN Q:%  W  
  2720   !?3,"Enter  'YES' to  choose a d evice to p rint.  Ent er 'NO' to  quit now. "
  2721   "RTN","PSG PER",49,0)
  2722    I %'=1 S  IOP=PSGION  D ^%ZIS S  %=2
  2723   "RTN","PSG PER",50,0)
  2724    Q
  2725   "RTN","PSG PER",51,0)
  2726    ;
  2727   "RTN","PSG PER",52,0)
  2728   AG ;
  2729   "RTN","PSG PER",53,0)
  2730    F  W !!," DO YOU NEE D TO PRINT  THIS REPO RT AGAIN"  S %=2 D YN ^DICN Q:%   D AGMSG
  2731   "RTN","PSG PER",54,0)
  2732    Q
  2733   "RTN","PSG PER",55,0)
  2734    ;
  2735   "RTN","PSG PER",56,0)
  2736   AGMSG ;
  2737   "RTN","PSG PER",57,0)
  2738    I %Y'?1." ?" W $C(7) ,"  ANSWER  'YES' OR  'NO' (Entr y required )" Q
  2739   "RTN","PSG PER",58,0)
  2740    W !,"  En ter 'YES'  to print t his report  again.  E nter 'NO'  (or an '^' ) to quit" ,!,"now.   PLEASE NOT E that you  
  2741   will NOT b e able to  retrieve t his data a t a later" ,!,"date.   You shoul d print th is informa tion now."  Q
  2742   "RTN","PSG PER",59,0)
  2743   CURDEF ;
  2744   "RTN","PSG PER",60,0)
  2745    Q:$G(PSGP XDEV)=0
  2746   "RTN","PSG PER",61,0)
  2747    K DIC,DR, DA,X,Y,DIE  S DIC="^% ZIS(1,",DI C(0)="SOX" ,X=ION D ^ DIC Q:'($G (Y)>0)
  2748   "RTN","PSG PER",62,0)
  2749    N D,DN S  D=+$G(Y),D N=$P($G(Y) ,"^",2)
  2750   "RTN","PSG PER",63,0)
  2751    F  W !!," Keep ",ION ," as the  PRE-EXCHAN GE REPORT  DEVICE for  this sess ion" S %=0  D YN^DICN  S 
  2752   PSGPXDEV=$ S(%=1:D,1: 0) Q:%  D  DEFMSG
  2753   "RTN","PSG PER",64,0)
  2754    I $G(Y) S :($G(PSGCU RCL)="") $ P(PSJSYSW0 ,"^",29)=+ Y I ($G(PS GCURCL)]"" ) N CLIEN 
  2755   CLIEN=$O(^ SC("B",PSG CURCL,""))  I CLIEN S  
  2756   $P(PSJSYSW 0("CLINIC" ,CLIEN,1), "^")=D,PSG PRCLD("DEV ",PSGCURCL )=DN
  2757   "RTN","PSG PER",65,0)
  2758    K DIC,DR, DA,X,Y,DIE
  2759   "RTN","PSG PER",66,0)
  2760    Q
  2761   "RTN","PSG PER",67,0)
  2762    ;
  2763   "RTN","PSG PER",68,0)
  2764   DEFMSG ;
  2765   "RTN","PSG PER",69,0)
  2766    I %Y'?1." ?" W !,$C( 7),"     A NSWER 'YES ' OR 'NO'  (Entry req uired)" Q
  2767   "RTN","PSG PER",70,0)
  2768    W !!,"  E nter 'YES'  to make " ,ION," the  PRE-EXCHA NGE REPORT  default D EVICE"
  2769   "RTN","PSG PER",71,0)
  2770    W !,"  fo r the curr ent sessio n. PLEASE  NOTE that  this will  override t he ward"
  2771   "RTN","PSG PER",72,0)
  2772    W !,"  de fault PRE- EXCHANGE R EPORT DEVI CE for thi s session  only."
  2773   "RTN","PSG PER",73,0)
  2774    Q
  2775   "RTN","PSG PER0")
  2776   0^1^B35728 238^B34370 854
  2777   "RTN","PSG PER0",1,0)
  2778   PSGPER0 ;B IR/CML3-PR INTS PRE-E XCHANGE NE EDS REPORT  ; 26 Jul  2018  10:3 8 AM
  2779   "RTN","PSG PER0",2,0)
  2780    ;;5.0;INP ATIENT MED ICATIONS;* *58,82,95, 115,279,33 2**;16 DEC  97;Build  8
  2781   "RTN","PSG PER0",3,0)
  2782    ;
  2783   "RTN","PSG PER0",4,0)
  2784    ; Referen ce to ^PS( 55 is supp orted by D BIA 2191.
  2785   "RTN","PSG PER0",5,0)
  2786    ; Referen ce to $$GE T1^DIQ sup ported by  DBIA 2056
  2787   "RTN","PSG PER0",6,0)
  2788    ; Referen ce to PSS4 31^PSS55 s upported b y DBIA 482 6
  2789   "RTN","PSG PER0",7,0)
  2790    ;
  2791   "RTN","PSG PER0",8,0)
  2792   ENQ ;
  2793   "RTN","PSG PER0",9,0)
  2794    D ENP:'$G (PSGPXPT), ENPAT:$G(P SGPXPT)
  2795   "RTN","PSG PER0",10,0 )
  2796    D TASKPRG E^PSGPER1( PSGPXN)
  2797   "RTN","PSG PER0",11,0 )
  2798    K DA,DIK, PSGPXN
  2799   "RTN","PSG PER0",12,0 )
  2800    Q
  2801   "RTN","PSG PER0",13,0 )
  2802    ;
  2803   "RTN","PSG PER0",14,0 )
  2804   ENPAT ;
  2805   "RTN","PSG PER0",15,0 )
  2806    Q:'$G(DFN )
  2807   "RTN","PSG PER0",16,0 )
  2808    N PSGPRSU B S PSGPRS UB=$S($G(P SGPRTYP)=" PSGPERPC": "PSGPERPC" ,1:"PSGPER ")
  2809   "RTN","PSG PER0",17,0 )
  2810    K ^TMP("P SGPER",$J) ,^TMP("PSG PERPC",$J)  U IO D PA T,DONE
  2811   "RTN","PSG PER0",18,0 )
  2812    Q
  2813   "RTN","PSG PER0",19,0 )
  2814    ;
  2815   "RTN","PSG PER0",20,0 )
  2816   ENP ;
  2817   "RTN","PSG PER0",21,0 )
  2818    K ^TMP("P SGPER",$J)  U IO
  2819   "RTN","PSG PER0",22,0 )
  2820    N PSGPRSU B S PSGPRS UB=$S($G(P SGPRTYP)=" PSGPERPC": "PSGPERPC" ,1:"PSGPER ")
  2821   "RTN","PSG PER0",23,0 )
  2822    F DFN=0:0  S DFN=$O( ^PS(53.4,P SGPXN,1,DF N)) Q:'DFN   U IO D P AT,DONE
  2823   "RTN","PSG PER0",24,0 )
  2824    Q
  2825   "RTN","PSG PER0",25,0 )
  2826    ;
  2827   "RTN","PSG PER0",26,0 )
  2828   PAT ;
  2829   "RTN","PSG PER0",27,0 )
  2830    D PID^VAD PT,GWR F O N=0:0 S ON =$O(^PS(53 .4,PSGPXN, 1,DFN,1,ON )) Q:ON=""   D ONI F  DD=0:0 S 
  2831   DD=$O(^PS( 53.4,PSGPX N,1,DFN,1, ON,1,DD))  Q:'DD  I $ D(^(DD,0))  S ND=^(0)  D DDS
  2832   "RTN","PSG PER0",28,0 )
  2833    D NOW^%DT C S %=$$EN DTC^PSGMI( %),(BORD,F ,L)="",$P( L,"-
  2834   ",81)="",$ P(BORD,"#" ,25)="",T= IO'=IO(0)! ($E(IOST)' ="C"),RF=$ S(T:0,1:0)  D:'RF HEA DER S 
  2835   (DN,DDN,NP ,WD)=""
  2836   "RTN","PSG PER0",29,0 )
  2837    F  S WD=$ O(^TMP(PSG PRSUB,$J,W D)) Q:WD=" "  S PI=""  F  S F=0, PI=$O(^TMP (PSGPRSUB, $J,WD,PI))  
  2838   Q:PI=""  S  RB=^(PI)  D
  2839   "RTN","PSG PER0",30,0 )
  2840    .Q:'$$NSY NC^PSGPER2 (PSGPRSUB, WD,$G(PSGC URCL))
  2841   "RTN","PSG PER0",31,0 )
  2842    .D PPI F   S F=1,DN= $O(^TMP(PS GPRSUB,$J, WD,PI,DN))  Q:DN=""   S PX=^(DN)  D OP F  S  
  2843   DDN=$O(^TM P(PSGPRSUB ,$J,WD,PI, DN,DDN)) Q :DDN=""  S  PX=^(DDN)  D PRT
  2844   "RTN","PSG PER0",32,0 )
  2845    .I $O(^TM P(PSGPRSUB ,$J,WD,PI) )]"" S F=" " D NP
  2846   "RTN","PSG PER0",33,0 )
  2847    W:T&($Y)  @IOF,@IOF  D ^%ZISC
  2848   "RTN","PSG PER0",34,0 )
  2849    Q
  2850   "RTN","PSG PER0",35,0 )
  2851    ;
  2852   "RTN","PSG PER0",36,0 )
  2853   DONE ;
  2854   "RTN","PSG PER0",37,0 )
  2855    K 
  2856   ^TMP(PSGPR SUB,$J),BO RD,DN,DD,D O,DRG,DRGS ,F,L,MR,ND ,ND0,ND2,N D4,NP,ON,P I,PDN,PN,P X,RB,RF,
  2857   SCH,SDN,SN ,SND1,SPN, STOP,STRT, T,UD,VD,VU ,W,WD,X,XL ,Y,DDN,I2, ND1,PSG25, PSG26,PSGE B,PSGEBN,
  2858   PSGNODE,PS GOAT,PSGST AT
  2859   "RTN","PSG PER0",38,0 )
  2860    K 
  2861   DONE,FIL,N F,PDM,PDRG ,PSGACTO,P SGDA,PSGNE FDO,PSGNES DO,PSGPEN, PSGPENWS,P SGY,PSIVAC ,PSIV
  2862   CT,PSIVE,P SIVEXAM,PS IVUP,PSIVW AT,PSJH,PS JNOO,PSJNO ON
  2863   "RTN","PSG PER0",39,0 )
  2864    Q
  2865   "RTN","PSG PER0",40,0 )
  2866    ;
  2867   "RTN","PSG PER0",41,0 )
  2868   NP ;
  2869   "RTN","PSG PER0",42,0 )
  2870    I 'T K DI R S DIR(0) ="E" W ! D  ^DIR S:'Y  WD="zzz"  W:Y $C(13) ,# Q
  2871   "RTN","PSG PER0",43,0 )
  2872    ;
  2873   "RTN","PSG PER0",44,0 )
  2874   HEADER ;
  2875   "RTN","PSG PER0",45,0 )
  2876    ; PSJ*5.0 *332
  2877   "RTN","PSG PER0",46,0 )
  2878    S PSGPN=$ G(PN)_"("_ $G(SN)_")"
  2879   "RTN","PSG PER0",47,0 )
  2880    S PSGRB=$ G(RB)
  2881   "RTN","PSG PER0",48,0 )
  2882    S PSGWD=$ S(WD'="zz" :WD,1:"NOT  FOUND")
  2883   "RTN","PSG PER0",49,0 )
  2884    ;  END PS J*5.0*332  changes
  2885   "RTN","PSG PER0",50,0 )
  2886    W:$Y @IOF  W !?20,"P RE-EXCHANG E UNITS RE PORT - ",%
  2887   "RTN","PSG PER0",51,0 )
  2888    W !!,$S(( $G(PSGCURC L)]""):"Cl inic",1:"W ard"),?32, "Room-
  2889   bed",!,"Pa tient",!?5 ,"Order",? 64,"Priori ty",!?20," Dispense D rug",?64," U/D",?72," Needs",!,L
  2890   "RTN","PSG PER0",52,0 )
  2891    W:F !!,$S (WD'="zz": WD,1:"NOT  FOUND"),?3 2,RB,!,PN_ "  ("_SN_" )"
  2892   "RTN","PSG PER0",53,0 )
  2893    Q
  2894   "RTN","PSG PER0",54,0 )
  2895    ;
  2896   "RTN","PSG PER0",55,0 )
  2897   GWR ;
  2898   "RTN","PSG PER0",56,0 )
  2899    D PID^VAD PT
  2900   "RTN","PSG PER0",57,0 )
  2901    S WD=$G(^ DPT(DFN,.1 )),RB=$G(^ (.101)),PN =$P($G(^(0 )),"^") S: WD="" WD=" zz" S:RB=" " RB="NOT 
  2902   FOUND" S:P N="" PN=DF N_";DPT("
  2903   "RTN","PSG PER0",58,0 )
  2904    S SPN=$E( PN,1,20)_" ^"_DFN,^TM P(PSGPRSUB ,$J,WD,SPN )=PN_"^"_R B_"^"_VA(" BID") Q
  2905   "RTN","PSG PER0",59,0 )
  2906    ;
  2907   "RTN","PSG PER0",60,0 )
  2908   ONI ;
  2909   "RTN","PSG PER0",61,0 )
  2910    S 
  2911   ND=$G(^PS( 55,DFN,5,O N,0)),DN=$ G(^(.2)),S CH=$P($G(^ (2)),"^"), MR=$P(ND," ^",3),ND=$ $ENNPN^PSG M
  2912   I($P(ND,"^ ",2)),DO=$ P(DN,"^",2 ),DN=$P(DN ,"^") I DN ="" S DN=" zz"
  2913   "RTN","PSG PER0",62,0 )
  2914    E  S DN=$ $ENPDN^PSG MI(DN)
  2915   "RTN","PSG PER0",63,0 )
  2916    I ($$CLIN IC^PSJO1(D FN,+ON_"U" )]"") Q:(P SGPRSUB'=" PSGPERPC")   N CLINIC  S 
  2917   CLINIC=+$G (^PS(55,DF N,5,+ON,8) ) I CLINIC  S CLINIC= $P($G(^SC( +CLINIC,0) ),"^") I ( CLINIC]"")  S 
  2918   WD=CLINIC, ^TMP("PSGP ERPC",$J,W D,SPN)=PN_ "^^"_VA("B ID") D
  2919   "RTN","PSG PER0",64,0 )
  2920    .I $D(^TM P(PSGPRSUB ,$J,"zz",S PN)),($O(^ TMP(PSGPRS UB,$J,"zz" ,SPN,""))= "") K 
  2921   ^TMP(PSGPR SUB,$J,"zz ",SPN)
  2922   "RTN","PSG PER0",65,0 )
  2923    S:MR]"" M R=$$ENMRN^ PSGMI(MR) 
  2924   SDN=$E(DN, 1,20)_"^"_ ON,^TMP(PS GPRSUB,$J, WD,SPN,SDN )=DN_"^"_D O_"^"_MR_" ^"_SCH_"^" _$P(N
  2925   D,"^",2)_" ^"_$$GET1^ DIQ(55.06, ON_","_DFN _",",.24," E")  ; **  332 **
  2926   "RTN","PSG PER0",66,0 )
  2927    S ^TMP($J ,"PSGPRKIL L",PSGPXN, DFN,ON)=""
  2928   "RTN","PSG PER0",67,0 )
  2929    Q
  2930   "RTN","PSG PER0",68,0 )
  2931    ;
  2932   "RTN","PSG PER0",69,0 )
  2933   DDS ;
  2934   "RTN","PSG PER0",70,0 )
  2935    Q:'$$NSYN C^PSGPER2( PSGPRSUB,W D,$G(PSGCU RCL))
  2936   "RTN","PSG PER0",71,0 )
  2937    I ($$CLIN IC^PSJO1(D FN,+ON_"U" )]"") Q:(P SGPRSUB'=" PSGPERPC")
  2938   "RTN","PSG PER0",72,0 )
  2939    ;S 
  2940   ND1=$G(^PS (55,DFN,5, ON,1,+ND,0 )),UD=$P(N D1,"^",2), ND1=$$ENDD N^PSGMI(+N D1),SND1=$ E(ND1,1,
  2941   20)_"^"_+N D,ND=$P(ND ,"^",2)
  2942   "RTN","PSG PER0",73,0 )
  2943    D 1^PSGIE N  ; ** 33 2 **
  2944   "RTN","PSG PER0",74,0 )
  2945    I ND#1 S  ND=(ND\1)+ 1
  2946   "RTN","PSG PER0",75,0 )
  2947    ;S ^TMP(P SGPRSUB,$J ,WD,SPN,SD N,SND1)=ND 1_"^"_UD_" ^"_ND
  2948   "RTN","PSG PER0",76,0 )
  2949    D 2^PSGIE N  ; ** 33 2 **
  2950   "RTN","PSG PER0",77,0 )
  2951    Q
  2952   "RTN","PSG PER0",78,0 )
  2953    ;
  2954   "RTN","PSG PER0",79,0 )
  2955   PPI ;
  2956   "RTN","PSG PER0",80,0 )
  2957    S DFN=$P( PI,"^",2), PN=$P(RB," ^"),SN=$P( RB,"^",3), RB=$P(RB," ^",2) I 'R F,$Y+6>IOS L D NP Q:N P["^"
  2958   "RTN","PSG PER0",81,0 )
  2959    W !!,$S(W D'="zz":WD ,1:"NOT FO UND"),?32, RB,!,PN,"   ("_SN_")"  Q
  2960   "RTN","PSG PER0",82,0 )
  2961    ;
  2962   "RTN","PSG PER0",83,0 )
  2963   OP ;
  2964   "RTN","PSG PER0",84,0 )
  2965    S PDN=$P( PX,"^"),DO =$P(PX,"^" ,2),MR=$P( PX,"^",3), SCH=$P(PX, "^",4)
  2966   "RTN","PSG PER0",85,0 )
  2967    W !?5,PDN ," ",DO,"  ",MR,$S(MR ]"":" ",1: ""),SCH
  2968   "RTN","PSG PER0",86,0 )
  2969    W ?64,$P( PX,"^",6)   ; ** 332  **
  2970   "RTN","PSG PER0",87,0 )
  2971    Q
  2972   "RTN","PSG PER0",88,0 )
  2973   PRT ; find  order inf o and prin t same
  2974   "RTN","PSG PER0",89,0 )
  2975    I 'RF,$Y+ 4>IOSL D N P Q:NP="^"
  2976   "RTN","PSG PER0",90,0 )
  2977    I 1 D 3^P SGIEN Q  ;  ** 332 **
  2978   "RTN","PSG PER0",91,0 )
  2979    S 
  2980   ON=$P(DN," ^",2),ND=$ G(^PS(55,D FN,5,ON,0) ),ND2=$G(^ (2)),ND4=$ G(^(4)),Y= $P($G(^(6) ),"^"),ND0 =$G(
  2981   ^(.1)),DO= $P(ND0,"^" ,2)
  2982   "RTN","PSG PER0",92,0 )
  2983    S DRG=$$E NDDN^PSGMI ($P(ND0,"^ ")),MR=$$E NMRN^PSGMI (MR) ; 
  2984   ,DRGS=$P($ G(^(+$O(^P S(55,DFN,5 ,ON,1,0)), 0)),"^")
  2985   "RTN","PSG PER0",93,0 )
  2986    I 'RF W 
  2987   !?5,DRG,?4 7,DO,?65,$ J($S('UD:1 ,UD=.5:"1/ 2",UD=.25: "1/4",UD?1 ".".N:0_UD ,1:UD),5), ?75,$J(+PX ,5) Q
  2988   "RTN","PSG PER0",94,0 )
  2989    ;
  2990   "RTN","PSG PER0",95,0 )
  2991    S 
  2992   SCH=$P(ND2 ,"^"),STRT =$P(ND2,"^ ",2),STOP= $P(ND2,"^" ,4),VU=$P( ND4,"^",3) ,VD=$P(ND4 ,"^",4),VU =$P
  2993   ($G(^VA(20 0,+VU,0)), "^",2) S:V U="" VU=$P (ND4,"^",3 )
  2994   "RTN","PSG PER0",96,0 )
  2995    F Q="STRT ","STOP"," VD" S @Q=$ $ENDTC^PSG MI(@Q)
  2996   "RTN","PSG PER0",97,0 )
  2997    W:$Y @IOF  W !!?6,BO RD_"  PRE- EXCHANGE M ED  "_BORD ,!?6,"#",? 73,"#",!?6 ,"#  
  2998   ",PN,?50,$ S(($G(PSGC URCL)]""): "Clinic: " ,1:"Ward:  "),WD,?73, "#",!?6,"#   ("_SN_") ",?52,"RB:  
  2999   "_RB,?73," #",!?6,"#" ,?73,"#"
  3000   "RTN","PSG PER0",98,0 )
  3001    W !?6,"#   "_DRG,?46 ,"START: " _STRT,?73, "#",!?6,"#   "_$S(DRG S]"":"("_D RGS_")",1: ""),?47,"S TOP: 
  3002   "_STOP,?73 ,"#",!?6," #  GIVE: " _$S(DO]"": " "_DO,1:" ")_$S(MR]" ":" "_MR,1 :"")_$S(SC H]"":" 
  3003   "_SCH,1:"" ),?73,"#"
  3004   "RTN","PSG PER0",99,0 )
  3005    S XL=0 I  Y="" W !?6 ,"#",?73," #",!?6,"#   (NO SPECI AL INSTRUC TIONS)"
  3006   "RTN","PSG PER0",100, 0)
  3007    E  W !?6, "#",?73,"# ",!?6,"#     " S Y=$$ ENSET^PSGS ICHK(Y) F  Q=1:1:$L(Y ," ") S X= $P(Y," ",Q
  3008   S:$X+$L(X) >72 XL=XL+ 1 W:$X+$L( X)>72 ?73, "#",!?6,"#   " W X_"  "
  3009   "RTN","PSG PER0",101, 0)
  3010    W ?73,"#" ,!?6,"#",? 73,"#",!,? 6,"#",?43, "VERIFIED:  "_VD,?73, "#",!?6,"# ",?49,"BY:  
  3011   "_VU,?73," #",!?6,"#" ,?38,"SEND  TO FLOOR:  "_PX,?73, "#"
  3012   "RTN","PSG PER0",102, 0)
  3013    S XL=2-XL  I XL>0 F  Q=1:1:XL W  !?6,"#",? 73,"#"
  3014   "RTN","PSG PER0",103, 0)
  3015    W !?6,"#" ,?73,"#",! ?6,"#",?36 ,"________ _______      ________ _______  # ",!?6,"#", ?36,"FILLE
  3016   BY",?56,"C HECKED BY" ,?73,"#",! ?6,BORD_BO RD_$E(BORD ,1,20) Q
  3017   "RTN","PSG PER2")
  3018   0^2^B31133 994^B31489 798
  3019   "RTN","PSG PER2",1,0)
  3020   PSGPER2 ;B IR/CML3-PR INTS PRE-E XCHANGE NE EDS REPORT  ; 20 Sep  2018  12:4 3 PM
  3021   "RTN","PSG PER2",2,0)
  3022    ;;5.0;INP ATIENT MED ICATIONS;* *80,115,27 9,332**;16  DEC 97;Bu ild 8
  3023   "RTN","PSG PER2",3,0)
  3024    ;
  3025   "RTN","PSG PER2",4,0)
  3026    ; Referen ce to ^PS( 55 is supp orted by D BIA 2191.
  3027   "RTN","PSG PER2",5,0)
  3028    ;
  3029   "RTN","PSG PER2",6,0)
  3030   ENQ ; Task ed entry p oint
  3031   "RTN","PSG PER2",7,0)
  3032    D ENP
  3033   "RTN","PSG PER2",8,0)
  3034    D TASKPRG E^PSGPER1( PSGPXN)
  3035   "RTN","PSG PER2",9,0)
  3036    K DA,DIK, PSGPXN
  3037   "RTN","PSG PER2",10,0 )
  3038    Q
  3039   "RTN","PSG PER2",11,0 )
  3040    ;
  3041   "RTN","PSG PER2",12,0 )
  3042   ENP ;
  3043   "RTN","PSG PER2",13,0 )
  3044    N PSGPRSU B S PSGPRS UB=$S($G(P SGPRTYP)=" PSGPERPC": "PSGPERPC" ,1:"PSGPER P")
  3045   "RTN","PSG PER2",14,0 )
  3046    K ^TMP("P SGPERP",$J ),^TMP("PS GPERPC",$J ) U IO
  3047   "RTN","PSG PER2",15,0 )
  3048    F DFN=0:0  S DFN=$O( ^PS(53.4,P SGPXN,1,DF N)) Q:'DFN   D PID^VA DPT,GWR F  ON=0:0 S 
  3049   ON=$O(^PS( 53.4,PSGPX N,1,DFN,1, ON)) Q:'ON   D ONI F  DD=0:0 S 
  3050   DD=$O(^PS( 53.4,PSGPX N,1,DFN,1, ON,1,DD))  Q:'DD  I $ D(^(DD,0))  S ND=^(0)  D DDS
  3051   "RTN","PSG PER2",16,0 )
  3052    D NOW^%DT C S %=$$EN DTC^PSGMI( %),(BORD,F ,L)="",$P( L,"-
  3053   ",81)="",$ P(BORD,"#" ,25)="",T= IO'=IO(0)! ($E(IOST)' ="C"),RF=$ S(T:0,1:0)  D:'RF HEA DER S 
  3054   (DN,DDN,NP ,WD)=""
  3055   "RTN","PSG PER2",17,0 )
  3056    F  S WD=$ O(^TMP(PSG PRSUB,$J,W D)) Q:WD=" "  S PI=""  F  S F=0, PI=$O(^TMP (PSGPRSUB, $J,WD,PI))  
  3057   Q:PI=""  S  RB=$G(^(P I)) D
  3058   "RTN","PSG PER2",18,0 )
  3059    .Q:'$$NSY NC(PSGPRSU B,WD,$G(PS GCURCL))
  3060   "RTN","PSG PER2",19,0 )
  3061    .D PPI F   S F=1,DN= $O(^TMP(PS GPRSUB,$J, WD,PI,DN))  Q:DN=""   S PX=^(DN)  D OP F  S  
  3062   DDN=$O(^TM P(PSGPRSUB ,$J,WD,PI, DN,DDN)) Q :DDN=""  S  PX=^(DDN)  D PRT
  3063   "RTN","PSG PER2",20,0 )
  3064    .I $O(^TM P(PSGPRSUB ,$J,WD,PI) )]"" S F=" " D NP
  3065   "RTN","PSG PER2",21,0 )
  3066    W:T&($Y)  @IOF,@IOF  D ^%ZISC
  3067   "RTN","PSG PER2",22,0 )
  3068    ;
  3069   "RTN","PSG PER2",23,0 )
  3070   DONE ;
  3071   "RTN","PSG PER2",24,0 )
  3072    K 
  3073   ^TMP(PSGPR SUB,$J),BO RD,DN,DD,D O,DRG,DRGS ,F,L,MR,ND ,ND0,ND2,N D4,NP,ON,P I,PDN,PN,P X,RB,RF,
  3074   SCH,SDN,SN ,SND1,SPN, STOP,STRT, T,UD,VD,VU ,W,WD,X,XL ,Y,DDN,I2, ND1,PSG25, PSG26,PSGE B,PSGEBN,
  3075   PSGNODE,PS GOAT,PSGST AT
  3076   "RTN","PSG PER2",25,0 )
  3077    K 
  3078   DONE,FIL,N F,PDM,PDRG ,PSGACTO,P SGDA,PSGNE FDO,PSGNES DO,PSGPEN, PSGPENWS,P SGY,PSIVAC ,PSIV
  3079   CT,PSIVE,P SIVEXAM,PS IVUP,PSIVW AT,PSJH,PS JNOO,PSJNO ON
  3080   "RTN","PSG PER2",26,0 )
  3081    Q
  3082   "RTN","PSG PER2",27,0 )
  3083    ;
  3084   "RTN","PSG PER2",28,0 )
  3085   NP ;
  3086   "RTN","PSG PER2",29,0 )
  3087    I 'T K DI R S DIR(0) ="E" W ! D  ^DIR S:'Y  WD="zzz"  W:Y $C(13) ,# Q
  3088   "RTN","PSG PER2",30,0 )
  3089    ;
  3090   "RTN","PSG PER2",31,0 )
  3091   HEADER ;
  3092   "RTN","PSG PER2",32,0 )
  3093    W:$Y @IOF  W !?20,"P RE-EXCHANG E UNITS RE PORT - ",%
  3094   "RTN","PSG PER2",33,0 )
  3095    W !!,$S(( $G(PSGCURC L)]""):"Cl inic",1:"W ard"),?32, "Room-
  3096   bed",!,"Pa tient",!?5 ,"Order",? 64,"Priori ty",!?20," Dispense D rug",?64," U/D",?72," Needs",!,L
  3097   "RTN","PSG PER2",34,0 )
  3098    W:F !!,$S (WD'="zz": WD,1:"NOT  FOUND"),?3 2,RB,!,PN_ "  ("_SN_" )" Q
  3099   "RTN","PSG PER2",35,0 )
  3100    ;
  3101   "RTN","PSG PER2",36,0 )
  3102   GWR ;
  3103   "RTN","PSG PER2",37,0 )
  3104    D PID^VAD PT
  3105   "RTN","PSG PER2",38,0 )
  3106    S WD=$G(^ DPT(DFN,.1 )),RB=$G(^ (.101)),PN =$P($G(^(0 )),"^") S: WD="" WD=" zz" S:RB=" " RB="NOT 
  3107   FOUND" S:P N="" PN=DF N_";DPT("
  3108   "RTN","PSG PER2",39,0 )
  3109    S SPN=$E( PN,1,20)_" ^"_DFN,^TM P(PSGPRSUB ,$J,WD,SPN )=PN_"^"_R B_"^"_VA(" BID") Q
  3110   "RTN","PSG PER2",40,0 )
  3111    ;
  3112   "RTN","PSG PER2",41,0 )
  3113   ONI ;
  3114   "RTN","PSG PER2",42,0 )
  3115    S 
  3116   ND=$G(^PS( 55,DFN,5,O N,0)),DN=$ G(^(.2)),S CH=$P($G(^ (2)),"^"), MR=$P(ND," ^",3),ND=$ $ENNPN^PSG M
  3117   I($P(ND,"^ ",2)),DO=$ P(DN,"^",2 ),DN=$P(DN ,"^") I DN ="" S DN=" zz"
  3118   "RTN","PSG PER2",43,0 )
  3119    E  S DN=$ $ENPDN^PSG MI(DN)
  3120   "RTN","PSG PER2",44,0 )
  3121    I $G(^PS( 55,DFN,5,+ ON,8)) Q:( PSGPRSUB'= "PSGPERPC" )  N CLINI C S CLINIC =+^(8) I C LINIC S 
  3122   CLINIC=$P( $G(^SC(+CL INIC,0))," ^") I (CLI NIC]"") S 
  3123   WD=CLINIC, ^TMP("PSGP ERPC",$J,W D,SPN)=PN_ "^^"_VA("B ID") D
  3124   "RTN","PSG PER2",45,0 )
  3125    .I $D(^TM P(PSGPRSUB ,$J,"zz",S PN)),($O(^ TMP(PSGPRS UB,$J,"zz" ,SPN,""))= "") K 
  3126   ^TMP(PSGPR SUB,$J,"zz ",SPN)
  3127   "RTN","PSG PER2",46,0 )
  3128    S:MR]"" M R=$$ENMRN^ PSGMI(MR) 
  3129   SDN=$E(DN, 1,20)_"^"_ ON,^TMP(PS GPRSUB,$J, WD,SPN,SDN )=DN_"^"_D O_"^"_MR_" ^"_SCH_"^" _$P(N
  3130   D,"^",2)_" ^"_$$GET1^ DIQ(55.06, ON_","_DFN _",",.24)
  3131   "RTN","PSG PER2",47,0 )
  3132    S ^TMP($J ,"PSGPRKIL L",PSGPXN, DFN,ON)=""
  3133   "RTN","PSG PER2",48,0 )
  3134    Q
  3135   "RTN","PSG PER2",49,0 )
  3136    ;
  3137   "RTN","PSG PER2",50,0 )
  3138   DDS ;
  3139   "RTN","PSG PER2",51,0 )
  3140    Q:'$$NSYN C(PSGPRSUB ,WD,$G(PSG CURCL))
  3141   "RTN","PSG PER2",52,0 )
  3142    I $G(^PS( 55,DFN,5,+ ON,8)) Q:( PSGPRSUB'= "PSGPERPC" )
  3143   "RTN","PSG PER2",53,0 )
  3144    ; PSJ*5.0 *332 Begin  Mods
  3145   "RTN","PSG PER2",54,0 )
  3146    ;S 
  3147   ND1=$G(^PS (55,DFN,5, ON,1,+ND,0 )),UD=$P(N D1,"^",2), ND1=$$ENDD N^PSGMI(+N D1),SND1=$ E(ND1,1,
  3148   20)_"^"_+N D,ND=$P(ND ,"^",2)
  3149   "RTN","PSG PER2",55,0 )
  3150    D 1^PSGIE N
  3151   "RTN","PSG PER2",56,0 )
  3152    I ND#1 S  ND=(ND\1)+ 1
  3153   "RTN","PSG PER2",57,0 )
  3154    ;S ^TMP(P SGPRSUB,$J ,WD,SPN,SD N,SND1)=ND 1_"^"_UD_" ^"_ND
  3155   "RTN","PSG PER2",58,0 )
  3156    D 4^PSGIE N
  3157   "RTN","PSG PER2",59,0 )
  3158    ; PSJ*5.0 *332 End M ods
  3159   "RTN","PSG PER2",60,0 )
  3160    Q
  3161   "RTN","PSG PER2",61,0 )
  3162    ;
  3163   "RTN","PSG PER2",62,0 )
  3164   PPI ;
  3165   "RTN","PSG PER2",63,0 )
  3166    S DFN=$P( PI,"^",2), PN=$P(RB," ^"),SN=$P( RB,"^",3), RB=$P(RB," ^",2) I 'R F,$Y+6>IOS L D NP Q:N P["^"
  3167   "RTN","PSG PER2",64,0 )
  3168    W !!,$S(W D'="zz":WD ,1:"NOT FO UND"),?32, RB,!,PN,"   ("_SN_")"  Q
  3169   "RTN","PSG PER2",65,0 )
  3170    ;
  3171   "RTN","PSG PER2",66,0 )
  3172   OP ;
  3173   "RTN","PSG PER2",67,0 )
  3174    S PDN=$P( PX,"^"),DO =$P(PX,"^" ,2),MR=$P( PX,"^",3), SCH=$P(PX, "^",4)
  3175   "RTN","PSG PER2",68,0 )
  3176    W !?5,PDN ," ",DO,"  ",MR,$S(MR ]"":" ",1: ""),SCH
  3177   "RTN","PSG PER2",69,0 )
  3178    W ?64,$P( PX,"^",6)
  3179   "RTN","PSG PER2",70,0 )
  3180    Q
  3181   "RTN","PSG PER2",71,0 )
  3182   PRT ; find  order inf o and prin t same
  3183   "RTN","PSG PER2",72,0 )
  3184    I 'RF,$Y+ 4>IOSL D N P Q:NP="^"
  3185   "RTN","PSG PER2",73,0 )
  3186    ;I 1 S PD N=$P(PX,"^ "),UD=$P(P X,"^",2),P X=$P(PX,"^ ",3) W 
  3187   !?20,PDN,? 62,$J($S(' UD:1,$E(UD )=".":0_UD ,1:UD),5), ?72,$J(PX, 5) Q
  3188   "RTN","PSG PER2",74,0 )
  3189    I 1 D 3^P SGIEN  ;   ** 332 **
  3190   "RTN","PSG PER2",75,0 )
  3191    S 
  3192   ON=$P(DN," ^",2),ND=$ G(^PS(55,D FN,5,ON,0) ),ND2=$G(^ (2)),ND4=$ G(^(4)),Y= $P($G(^(6) ),"^"),ND0 =$G(
  3193   ^(.1)),DO= $P(ND0,"^" ,2)
  3194   "RTN","PSG PER2",76,0 )
  3195    S DRG=$$E NDDN^PSGMI ($P(ND0,"^ ")),MR=$$E NMRN^PSGMI (MR) ; 
  3196   ,DRGS=$P($ G(^(+$O(^P S(55,DFN,5 ,ON,1,0)), 0)),"^")
  3197   "RTN","PSG PER2",77,0 )
  3198    I 'RF W 
  3199   !?5,DRG,?4 7,DO,?65,$ J($S('UD:1 ,UD=.5:"1/ 2",UD=.25: "1/4",UD?1 ".".N:0_UD ,1:UD),5), ?75,$J(+PX ,5) Q
  3200   "RTN","PSG PER2",78,0 )
  3201    ;
  3202   "RTN","PSG PER2",79,0 )
  3203    S 
  3204   SCH=$P(ND2 ,"^"),STRT =$P(ND2,"^ ",2),STOP= $P(ND2,"^" ,4),VU=$P( ND4,"^",3) ,VD=$P(ND4 ,"^",4),VU =$P
  3205   ($G(^VA(20 0,+VU,0)), "^",2) S:V U="" VU=$P (ND4,"^",3 )
  3206   "RTN","PSG PER2",80,0 )
  3207    F Q="STRT ","STOP"," VD" S @Q=$ $ENDTC^PSG MI(@Q)
  3208   "RTN","PSG PER2",81,0 )
  3209    W:$Y @IOF  W !!?6,BO RD_"  PRE- EXCHANGE M ED  "_BORD ,!?6,"#",? 73,"#",!?6 ,"#  
  3210   ",PN,?50,$ S(($G(PSGC URCL)]""): "Clinic: " ,1:"Ward:  "),WD,?73, "#",!?6,"#   ("_SN_") ",?52,"RB:  
  3211   "_RB,?73," #",!?6,"#" ,?73,"#"
  3212   "RTN","PSG PER2",82,0 )
  3213    W !?6,"#   "_DRG,?46 ,"START: " _STRT,?73, "#",!?6,"#   "_$S(DRG S]"":"("_D RGS_")",1: ""),?47,"S TOP: 
  3214   "_STOP,?73 ,"#",!?6," #  GIVE: " _$S(DO]"": " "_DO,1:" ")_$S(MR]" ":" "_MR,1 :"")_$S(SC H]"":" 
  3215   "_SCH,1:"" ),?73,"#"
  3216   "RTN","PSG PER2",83,0 )
  3217    S XL=0 I  Y="" W !?6 ,"#",?73," #",!?6,"#   (NO SPECI AL INSTRUC TIONS)"
  3218   "RTN","PSG PER2",84,0 )
  3219    E  W !?6, "#",?73,"# ",!?6,"#     " S Y=$$ ENSET^PSGS ICHK(Y) F  Q=1:1:$L(Y ," ") S X= $P(Y," ",Q
  3220   S:$X+$L(X) >72 XL=XL+ 1 W:$X+$L( X)>72 ?73, "#",!?6,"#   " W X_"  "
  3221   "RTN","PSG PER2",85,0 )
  3222    W ?73,"#" ,!?6,"#",? 73,"#",!,? 6,"#",?43, "VERIFIED:  "_VD,?73, "#",!?6,"# ",?49,"BY:  
  3223   "_VU,?73," #",!?6,"#" ,?38,"SEND  TO FLOOR:  "_PX,?73, "#"
  3224   "RTN","PSG PER2",86,0 )
  3225    S XL=2-XL  I XL>0 F  Q=1:1:XL W  !?6,"#",? 73,"#"
  3226   "RTN","PSG PER2",87,0 )
  3227    W !?6,"#" ,?73,"#",! ?6,"#",?36 ,"________ _______      ________ _______  # ",!?6,"#", ?36,"FILLE
  3228   BY",?56,"C HECKED BY" ,?73,"#",! ?6,BORD_BO RD_$E(BORD ,1,20) Q
  3229   "RTN","PSG PER2",88,0 )
  3230    ;
  3231   "RTN","PSG PER2",89,0 )
  3232   NSYNC(PSGP RSUB,WD,PS GCURCL) ;  Don't prin t ward ord ers and cl inic order s together
  3233   "RTN","PSG PER2",90,0 )
  3234    Q:((PSGPR SUB="PSGPE RPC")&(WD' =$G(PSGCUR CL))) 0
  3235   "RTN","PSG PER2",91,0 )
  3236    Q:((PSGPR SUB'="PSGP ERPC")&($G (PSGCURCL) ]"")) 0
  3237   "RTN","PSG PER2",92,0 )
  3238    Q 1
  3239   "RTN","PSG ZEB1")
  3240   0^18^B3957 05^n/a
  3241   "RTN","PSG ZEB1",1,0)
  3242   PSGZEB1 ;; EPIP/WLC -  ZEBRA PRE -EXCHANGE  LABEL PRIN T (CONT) ;  29 Nov 20 18  1:22 P M
  3243   "RTN","PSG ZEB1",2,0)
  3244    ;;5.0;INP ATIENT MED ICATIONS;* *332**;16  DEC 1997;B uild 8
  3245   "RTN","PSG ZEB1",3,0)
  3246   SRXIEN(RXI EN) ; Stor ing Rx IEN
  3247   "RTN","PSG ZEB1",4,0)
  3248    S:'$D(PSG RXIEN) PSG RXIEN=RXIE N
  3249   "RTN","PSG ZEB1",5,0)
  3250    Q
  3251   "RTN","PSG ZEB1",6,0)
  3252    ;
  3253   "RTN","PSG ZEB1",7,0)
  3254   SHDR ; Sto ring Patie nt name (P N), SSN (S N), room a nd bed (RB ), Ward (W D)
  3255   "RTN","PSG ZEB1",8,0)
  3256    S PSGPN=$ G(PN)_" (" _$G(SN)_") "
  3257   "RTN","PSG ZEB1",9,0)
  3258    S PSGRB=$ G(RB)
  3259   "RTN","PSG ZEB1",10,0 )
  3260    S PSGWD=$ S(WD'="zz" :WD,1:"NOT  FOUND")
  3261   "RTN","PSG ZEB1",11,0 )
  3262    Q
  3263   "RTN","PSG ZEB1",12,0 )
  3264    ;
  3265   "RTN","PSG ZEB2")
  3266   0^19^B1685 13^n/a
  3267   "RTN","PSG ZEB2",1,0)
  3268   PSGZEB2 ;E PIP/WLC -  ZEBRA PRE- EXCHANGE L ABEL PRINT  (CONT); 0 2 Oct 2018   11:14 AM  ; 29 Nov  2018  
  3269   1:23 PM
  3270   "RTN","PSG ZEB2",2,0)
  3271    ;;5.0;INP ATIENT MED ICATIONS;* *332**;16- DEC-1997;B uild 8
  3272   "RTN","PSG ZEB2",3,0)
  3273    ;
  3274   "RTN","PSG ZEB2",4,0)
  3275    ; Descrip tion:  Use d only for  Zebra lab el printer
  3276   "RTN","PSG ZEB2",5,0)
  3277    ;
  3278   "RTN","PSG ZEB2",6,0)
  3279   ZEBST(X,Y, TEXT) ;
  3280   "RTN","PSG ZEB2",7,0)
  3281    W !,"^FO" _X_","_Y_" ^A0N,30,20 ^FD"_TEXT_ "^FS"
  3282   "RTN","PSG ZEB2",8,0)
  3283    Q
  3284   "RTN","PSG ZEB2",9,0)
  3285    ;
  3286   "RTN","PSG ZEB2",10,0 )
  3287   ZEBFI ; Ze bra printe r Format I nitializat ion or Sta rt of labe l
  3288   "RTN","PSG ZEB2",11,0 )
  3289    W "^XA",! ,"^LH0,0^F S",!
  3290   "RTN","PSG ZEB2",12,0 )
  3291    Q
  3292   "RTN","PSG ZEB2",13,0 )
  3293    ;
  3294   "RTN","PSG ZEB2",14,0 )
  3295   ZEBEL ; Ze bra printe r end of l abel
  3296   "RTN","PSG ZEB2",15,0 )
  3297    W !,"^XZ" ,!
  3298   "RTN","PSG ZEB2",16,0 )
  3299    Q
  3300   "RTN","PSG ZEB2",17,0 )
  3301    ;
  3302   "RTN","PSG ZEBL")
  3303   0^16^B2655 1662^n/a
  3304   "RTN","PSG ZEBL",1,0)
  3305   PSGZEBL ;E PIP/WLC -  ZEBRA PRE- EXCHANGE L ABEL PRINT  : 02 Oct  2018  11:1 5 AM ; 29  Nov 2018   1:23 
  3306   PM
  3307   "RTN","PSG ZEBL",2,0)
  3308    ;;5.0;INP ATIENT MED ICATIONS;* *332**;16- DEC-1997;B uild 8
  3309   "RTN","PSG ZEBL",3,0)
  3310    ;
  3311   "RTN","PSG ZEBL",4,0)
  3312    ;
  3313   "RTN","PSG ZEBL",5,0)
  3314    ;
  3315   "RTN","PSG ZEBL",6,0)
  3316   ENQ ;
  3317   "RTN","PSG ZEBL",7,0)
  3318    N PSGZI,P SGZIMX,PSG ZIS,PSGSHD R
  3319   "RTN","PSG ZEBL",8,0)
  3320    N IXC S I XC=1 K ^XT MP("PSGPSG 0")
  3321   "RTN","PSG ZEBL",9,0)
  3322    S PSGZI=3 20,PSGZIMX =640,PSGZI S=320,PSGS HDR=0
  3323   "RTN","PSG ZEBL",10,0 )
  3324    ;
  3325   "RTN","PSG ZEBL",11,0 )
  3326    D ENP:'$G (PSGPXPT), ENPAT:$G(P SGPXPT) S  DIK="^PS(5 3.4,",DA=P SGPXN D ^D IK
  3327   "RTN","PSG ZEBL",12,0 )
  3328    K DA,DIK, PSGPXN Q
  3329   "RTN","PSG ZEBL",13,0 )
  3330    ;
  3331   "RTN","PSG ZEBL",14,0 )
  3332   ENPAT ;
  3333   "RTN","PSG ZEBL",15,0 )
  3334    N PSGZI,P SGZIMX,PSG ZIS,PSGSHD R
  3335   "RTN","PSG ZEBL",16,0 )
  3336    N IXC S I XC=1 K ^XT MP("PSGPSG 0")
  3337   "RTN","PSG ZEBL",17,0 )
  3338    S PSGZI=3 20,PSGZIMX =640,PSGZI S=320,PSGS HDR=0
  3339   "RTN","PSG ZEBL",18,0 )
  3340    Q:'$G(DFN )
  3341   "RTN","PSG ZEBL",19,0 )
  3342    ;
  3343   "RTN","PSG ZEBL",20,0 )
  3344    K ^TMP("P SGPER",$J)  U IO D PA T,DONE
  3345   "RTN","PSG ZEBL",21,0 )
  3346    Q
  3347   "RTN","PSG ZEBL",22,0 )
  3348    ;
  3349   "RTN","PSG ZEBL",23,0 )
  3350   ENP ;
  3351   "RTN","PSG ZEBL",24,0 )
  3352    N PSGZI,P SGZIMX,PSG ZIS,PSGSHD R
  3353   "RTN","PSG ZEBL",25,0 )
  3354    N IXC S I XC=1 K ^XT MP("PSGPSG 0")
  3355   "RTN","PSG ZEBL",26,0 )
  3356    S PSGZI=3 20,PSGZIMX =640,PSGZI S=320,PSGS HDR=0
  3357   "RTN","PSG ZEBL",27,0 )
  3358    K ^TMP("P SGPER",$J)  U IO
  3359   "RTN","PSG ZEBL",28,0 )
  3360    ;
  3361   "RTN","PSG ZEBL",29,0 )
  3362    F DFN=0:0  S DFN=$O( ^PS(53.4,P SGPXN,1,DF N)) Q:'DFN   D PAT,DO NE
  3363   "RTN","PSG ZEBL",30,0 )
  3364    Q
  3365   "RTN","PSG ZEBL",31,0 )
  3366    ;
  3367   "RTN","PSG ZEBL",32,0 )
  3368   PAT ;
  3369   "RTN","PSG ZEBL",33,0 )
  3370    D PID^VAD PT,GWR F O N=0:0 S ON =$O(^PS(53 .4,PSGPXN, 1,DFN,1,ON )) Q:'ON   D ONI F DD =0:0 S 
  3371   DD=$O(^PS( 53.4,PSGPX N,1,DFN,1, ON,1,DD))  Q:'DD  I $ D(^(DD,0))  S ND=^(0)  D DDS
  3372   "RTN","PSG ZEBL",34,0 )
  3373    D NOW^%DT C
  3374   "RTN","PSG ZEBL",35,0 )
  3375    S %=$$END TC^PSGMI(% ),(BORD,F, L)="",$P(L ,"-",81)=" "
  3376   "RTN","PSG ZEBL",36,0 )
  3377    S $P(BORD ,"#",25)=" "
  3378   "RTN","PSG ZEBL",37,0 )
  3379    S T=IO'=I O(0)!($E(I OST)'="C") ,RF=$S(T:0 ,1:0) D:'R F HDR S (D N,DDN,NP,W D)=""
  3380   "RTN","PSG ZEBL",38,0 )
  3381    F  S WD=$ O(^TMP("PS GPER",$J,W D)) Q:WD=" "  S PI=""  F  S F=0, PI=$O(^TMP ("PSGPER", $J,WD,PI))  
  3382   Q:PI=""  S  RB=^(PI)  D
  3383   "RTN","PSG ZEBL",39,0 )
  3384    . D PPI F   S F=1,DN =$O(^TMP(" PSGPER",$J ,WD,PI,DN) ) Q:DN=""   S PX=^(DN ) D OP S D DN="" F  S  
  3385   DDN=$O(^TM P("PSGPER" ,$J,WD,PI, DN,DDN)) Q :DDN=""  S  PX=^(DDN)  D PRT
  3386   "RTN","PSG ZEBL",40,0 )
  3387    . D ZEBEL  I $O(^TMP ("PSGPER", $J,WD,PI)) ]"" S F=""  D NP
  3388   "RTN","PSG ZEBL",41,0 )
  3389    W:T&($Y)  @IOF,@IOF  D ^%ZISC
  3390   "RTN","PSG ZEBL",42,0 )
  3391    Q
  3392   "RTN","PSG ZEBL",43,0 )
  3393    ;
  3394   "RTN","PSG ZEBL",44,0 )
  3395   DONE ;
  3396   "RTN","PSG ZEBL",45,0 )
  3397    K 
  3398   ^TMP("PSGP ER",$J),BO RD,DN,DD,D O,DRG,DRGS ,F,L,MR,ND ,ND0,ND2,N D4,NP,ON,P I,PDN,PN,P X,RB,RF,S
  3399   CH,SDN,SN, SND1,SPN,S TOP,STRT,T ,UD,VD,VU, W,WD,X,XL, Y,DDN,I2,N D1,OSG25,P SG26,PSGEB ,PSGEBN,P
  3400   SGNODE,PSG OAT,PSGSTA T
  3401   "RTN","PSG ZEBL",46,0 )
  3402    K 
  3403   DONE,FIL,N F,PDM,PDRG ,PSGACTO,P SGDA,PSGNE FDO,PSGNES DO,PSGPEN, PSGPENWS,P SGY,PSJVAC ,PSIV
  3404   CT,PSIVE,P SIVEXAM,PS IVUP,PSIVW AT,PSJH,PS JNOO,PSJNO ON
  3405   "RTN","PSG ZEBL",47,0 )
  3406    Q
  3407   "RTN","PSG ZEBL",48,0 )
  3408    ;
  3409   "RTN","PSG ZEBL",49,0 )
  3410   NP ;
  3411   "RTN","PSG ZEBL",50,0 )
  3412    I $G(T)=" " K DIR S  DIR(0)="E"  W ! D ^DI R S:'Y WD= "zzz" W:Y  $C(13),# Q
  3413   "RTN","PSG ZEBL",51,0 )
  3414    ;
  3415   "RTN","PSG ZEBL",52,0 )
  3416   HEADER ;
  3417   "RTN","PSG ZEBL",53,0 )
  3418    W:$Y @IOF  W !?20,"P RE-EXCHANG E UNITS RE PORT - ",%
  3419   "RTN","PSG ZEBL",54,0 )
  3420    W !!,"War d",?32,"Ro om-bed",!, "Patient", !?5,"Order ",!?20,"Di spense Dru g",?64,"U/ D",?72,"Ne eds",!,L
  3421   "RTN","PSG ZEBL",55,0 )
  3422    W:F !!,$S (WD'="zz": WD,1:"NOT  FOUND"),?3 2,RB,!,PN_ "  ("_SN_" )" Q
  3423   "RTN","PSG ZEBL",56,0 )
  3424    Q
  3425   "RTN","PSG ZEBL",57,0 )
  3426    ;
  3427   "RTN","PSG ZEBL",58,0 )
  3428   HDR ;Print  header
  3429   "RTN","PSG ZEBL",59,0 )
  3430    ; Gets pa tient ward , patient  name, room  bed and s tores them  in local  variables
  3431   "RTN","PSG ZEBL",60,0 )
  3432    S PSGPN=$ G(PN),PSGS N=$G(SN),P SGRB=$G(RB )
  3433   "RTN","PSG ZEBL",61,0 )
  3434    S PSGWD=$ S(WD'="zz" :WD,1:"NOT  FOUND")
  3435   "RTN","PSG ZEBL",62,0 )
  3436    S PSGDT=%
  3437   "RTN","PSG ZEBL",63,0 )
  3438    D HDR2
  3439   "RTN","PSG ZEBL",64,0 )
  3440    Q
  3441   "RTN","PSG ZEBL",65,0 )
  3442    ;
  3443   "RTN","PSG ZEBL",66,0 )
  3444   HDR2 ;; Pr int header
  3445   "RTN","PSG ZEBL",67,0 )
  3446    D ZEBFI
  3447   "RTN","PSG ZEBL",68,0 )
  3448    D ZEBST(5 0,120,PSGW D_"-"_PSGR B)
  3449   "RTN","PSG ZEBL",69,0 )
  3450    D ZEBST(5 0,160,PSGP N_" - *"_P SGSN)
  3451   "RTN","PSG ZEBL",70,0 )
  3452    D ZEBST(5 0,240,"PRE -EXCHANGE  UNITS REPO RT  -  "_P SGDT)
  3453   "RTN","PSG ZEBL",71,0 )
  3454    Q
  3455   "RTN","PSG ZEBL",72,0 )
  3456    ;
  3457   "RTN","PSG ZEBL",73,0 )
  3458   GWR ;
  3459   "RTN","PSG ZEBL",74,0 )
  3460    S WD=$G(^ DPT(DFN,.1 )),RB=$G(^ (.101)),PN =$P($G(^(0 )),"^") S: WD="" WD=" zz" S:RB=" " RB="NOT 
  3461   FOUND" S:P N="" PN=DF N_";DPT("
  3462   "RTN","PSG ZEBL",75,0 )
  3463    S SPN=$E( PN,1,20)_" ^"_DFN,^TM P("PSGPER" ,$J,WD,SPN )=PN_"^"_R B_"^"_VA(" BID") Q
  3464   "RTN","PSG ZEBL",76,0 )
  3465    ;
  3466   "RTN","PSG ZEBL",77,0 )
  3467   ONI ;
  3468   "RTN","PSG ZEBL",78,0 )
  3469    S 
  3470   ND=$G(^PS( 55,DFN,5,O N,0)),DN=$ G(^(.2)),S CH=$P($G(^ (2)),"^"), MR=$P(ND," ^",3),ND=$ $ENNPN^PSG M
  3471   I($P(ND,"^ ",2)),DO=$ P(DN,"^",2 ),DN=$P(DN ,"^") I DN ="" S DN=" zz"
  3472   "RTN","PSG ZEBL",79,0 )
  3473    E  S DN=$ $ENPDN^PSG MI(DN)
  3474   "RTN","PSG ZEBL",80,0 )
  3475    S:MR]"" M R=$$ENMRN^ PSGMI(MR) 
  3476   SDN=$E(DN, 1,20)_"^"_ ON,^TMP("P SGPER",$J, WD,SPN,SDN )=DN_"^"_D O_"^"_MR_" ^"_SCH_"^" _$P(ND
  3477   ,"^",2) Q
  3478   "RTN","PSG ZEBL",81,0 )
  3479    ;
  3480   "RTN","PSG ZEBL",82,0 )
  3481   DDS ;
  3482   "RTN","PSG ZEBL",83,0 )
  3483    D SRXIEN^ PSGZEB1(+$ G(^PS(55,D FN,5,ON,1, +ND,0)))
  3484   "RTN","PSG ZEBL",84,0 )
  3485    S 
  3486   ND1=$G(^PS (55,DFN,5, ON,1,+ND,0 )),UD=$P(N D1,"^",2), ND1=$$ENDD N^PSGMI(+N D1),SND1=$ E(ND1,1,
  3487   20)_"^"_+N D,ND=$P(ND ,"^",2)
  3488   "RTN","PSG ZEBL",85,0 )
  3489    I ND#1 S  ND=(ND\1)+ 1
  3490   "RTN","PSG ZEBL",86,0 )
  3491    S ^TMP("P SGPER",$J, WD,SPN,SDN ,SND1)=ND1 _"^"_UD_"^ "_ND_U_PSG RXIEN
  3492   "RTN","PSG ZEBL",87,0 )
  3493    Q
  3494   "RTN","PSG ZEBL",88,0 )
  3495    ;
  3496   "RTN","PSG ZEBL",89,0 )
  3497   PPI ; gets  patient s sn and pla ce it loca l variable
  3498   "RTN","PSG ZEBL",90,0 )
  3499    S DFN=$P( PI,"^",2), PN=$P(RB," ^"),SN=$P( RB,"^",3), RB=$P(RB," ^",2) I 'R F,$Y+6>IOS L D NP Q:N P["^"
  3500   "RTN","PSG ZEBL",91,0 )
  3501    S PSGPN=$ G(PN),PSGS N=$G(SN),P SGRB=$G(RB )
  3502   "RTN","PSG ZEBL",92,0 )
  3503    S PSGWD=$ S(WD'="zz" :WD,1:"NOT  FOUND")
  3504   "RTN","PSG ZEBL",93,0 )
  3505    D ZEBST(5 0,120,PSGW D_" - "_PS GRB)
  3506   "RTN","PSG ZEBL",94,0 )
  3507    D ZEBST(5 0,160,PSGP N_" - *"_P SGSN)
  3508   "RTN","PSG ZEBL",95,0 )
  3509    D ZEBST(5 0,240,"PRE -EXCHANGE  UNITS REPO RT  -  "_P SGDT)
  3510   "RTN","PSG ZEBL",96,0 )
  3511    Q
  3512   "RTN","PSG ZEBL",97,0 )
  3513    ;
  3514   "RTN","PSG ZEBL",98,0 )
  3515   OP ;
  3516   "RTN","PSG ZEBL",99,0 )
  3517    S PX=$G(P X),PDN=$P( PX,"^"),DO =$P(PX,"^" ,2),MR=$P( PX,"^",3), SCH=$P(PX, "^",4)
  3518   "RTN","PSG ZEBL",100, 0)
  3519    S IXC=IXC +1
  3520   "RTN","PSG ZEBL",101, 0)
  3521    I (PSGSHD R>0) D ZEB EL,HDR2 S  PSGSHDR=0, PSGZI=PSGZ IS
  3522   "RTN","PSG ZEBL",102, 0)
  3523    D ZEBST(5 0,PSGZI,"" _PDN) S PS GZI=PSGZI+ 40
  3524   "RTN","PSG ZEBL",103, 0)
  3525    D ZEBST(5 0,PSGZI,"" _DO) S PSG ZI=PSGZI+4 0
  3526   "RTN","PSG ZEBL",104, 0)
  3527    D ZEBST(5 0,PSGZI,"" _SCH) S PS GZI=PSGZI+ 40
  3528   "RTN","PSG ZEBL",105, 0)
  3529    Q
  3530   "RTN","PSG ZEBL",106, 0)
  3531    ;
  3532   "RTN","PSG ZEBL",107, 0)
  3533   PRT ; find  order inf o and prin t same
  3534   "RTN","PSG ZEBL",108, 0)
  3535    I $G(RF)= "",$Y+4>IO SL D NP Q: NP="^"
  3536   "RTN","PSG ZEBL",109, 0)
  3537    D SRXIEN^ PSGZEB1($P (PX,"^",4) )
  3538   "RTN","PSG ZEBL",110, 0)
  3539    I 1 S PDN =$P(PX,"^" ),UD=$P(PX ,"^",2),PX =$P(PX,"^" ,3) D
  3540   "RTN","PSG ZEBL",111, 0)
  3541    . S PSGDO =$J($S('UD :1,$E(UD)= ".":0_UD,1 :UD),5)
  3542   "RTN","PSG ZEBL",112, 0)
  3543    . I PSGZI >PSGZIMX D  ZEBEL,HDR 2 S PSGZI= PSGZIS
  3544   "RTN","PSG ZEBL",113, 0)
  3545    . D ZEBST (50,PSGZI, PDN_" ("_P SGRXIEN_") ") S PSGZI =PSGZI+40
  3546   "RTN","PSG ZEBL",114, 0)
  3547    . I PSGZI >PSGZIMX D  ZEBEL,HDR 2 S PSGZI= PSGZIS
  3548   "RTN","PSG ZEBL",115, 0)
  3549    . D ZEBST (50,PSGZI, "U/D:"_PSG DO)
  3550   "RTN","PSG ZEBL",116, 0)
  3551    . D ZEBST (250,PSGZI ,"NEEDS:"_ $J(PX,5))
  3552   "RTN","PSG ZEBL",117, 0)
  3553    . S PSGZI =PSGZI+40, PSGSHDR=1
  3554   "RTN","PSG ZEBL",118, 0)
  3555    Q
  3556   "RTN","PSG ZEBL",119, 0)
  3557    ;
  3558   "RTN","PSG ZEBL",120, 0)
  3559   ZEBST(X,Y, TEXT) ;
  3560   "RTN","PSG ZEBL",121, 0)
  3561    D ZEBST^P SGZEB2(X,Y ,TEXT)
  3562   "RTN","PSG ZEBL",122, 0)
  3563    Q
  3564   "RTN","PSG ZEBL",123, 0)
  3565    ;
  3566   "RTN","PSG ZEBL",124, 0)
  3567   ZEBEL ;
  3568   "RTN","PSG ZEBL",125, 0)
  3569    D ZEBEL^P SGZEB2
  3570   "RTN","PSG ZEBL",126, 0)
  3571    Q
  3572   "RTN","PSG ZEBL",127, 0)
  3573    ;
  3574   "RTN","PSG ZEBL",128, 0)
  3575   ZEBFI ;
  3576   "RTN","PSG ZEBL",129, 0)
  3577    D ZEBFI^P SGZEB2
  3578   "RTN","PSG ZEBL",130, 0)
  3579    Q
  3580   "RTN","PSG ZEBL",131, 0)
  3581    ;
  3582   "RTN","PSI VHYPL")
  3583   0^13^B4897 1823^B4937 8868
  3584   "RTN","PSI VHYPL",1,0 )
  3585   PSIVHYPL ; BIR/PR-PRI NT OUT LAB ELS ; 20 S ep 2018  1 1:20 AM
  3586   "RTN","PSI VHYPL",2,0 )
  3587    ;;5.0;INP ATIENT MED ICATIONS;* *58,96,128 ,178,184,2 79,332**;1 6 DEC 97;B uild 8
  3588   "RTN","PSI VHYPL",3,0 )
  3589    ;
  3590   "RTN","PSI VHYPL",4,0 )
  3591    ; Referen ce to ^%ZI S(2 is sup ported by  DBIA 3435.
  3592   "RTN","PSI VHYPL",5,0 )
  3593    ; Referen ce to ^PS( 52.6 is su pported by  DBIA 1231 .
  3594   "RTN","PSI VHYPL",6,0 )
  3595    ; Referen ce to ^PS( 52.7 is su pported by  DBIA 2173 .
  3596   "RTN","PSI VHYPL",7,0 )
  3597    ; Referen ce to ^PS( 55 is supp orted by D BIA 2191.
  3598   "RTN","PSI VHYPL",8,0 )
  3599    ; Referen ce to ^PS( 50.4 is su pported by  DBIA 2175 .
  3600   "RTN","PSI VHYPL",9,0 )
  3601    ; Referen ce to ^PS( 51.2 is su pported by  DBIA 2178 .
  3602   "RTN","PSI VHYPL",10, 0)
  3603    ;
  3604   "RTN","PSI VHYPL",11, 0)
  3605    ;NEEDS DF N, ON AND  PSIVNOL (T otal numbe r of label s to print ) and
  3606   "RTN","PSI VHYPL",12, 0)
  3607    ;PSIVCT -  $D(PSIVCT ) NO COUNT  LABEL
  3608   "RTN","PSI VHYPL",13, 0)
  3609   SSWARD ;Ge t patient  SS# and wa rd locatio n
  3610   "RTN","PSI VHYPL",14, 0)
  3611    N X0,PSJI O,I,PSIVCL AB
  3612   "RTN","PSI VHYPL",15, 0)
  3613    S I=0 F   S I=$O(^%Z IS(2,IOST( 0),55,I))  Q:'I  S X0 =^(I,0),PS JIO($P(X0, "^"))=^(1)
  3614   "RTN","PSI VHYPL",16, 0)
  3615    S PSJIO=$ S('$D(PSJI O):0,1:1)
  3616   "RTN","PSI VHYPL",17, 0)
  3617    N PSIVCLI N,PSIVCLDT  S PSIVCLI N=+$G(^PS( 55,DFN,"IV ",+ON,"DSS ")) S:'(PS IVCLIN>0)  PSIVCLIN=" " I 
  3618   PSIVCLIN D
  3619   "RTN","PSI VHYPL",18, 0)
  3620    .S PSIVCL DT=$P(PSIV CLIN,"^",2 ) S $P(PSI VCLIN,"^", 2)=$P($G(^ SC(+PSIVCL IN,0)),"^" )
  3621   "RTN","PSI VHYPL",19, 0)
  3622    I $G(PSIV CLIN) S PS IVCLAB=$P( $G(^SC(+PS IVCLIN,0)) ,"^",2)
  3623   "RTN","PSI VHYPL",20, 0)
  3624    D ENIV^PS JAC S 
  3625   VADM(2)=$E (VADM(2),6 ,9),PSIVWD =$S(+VAIN( 4):$P(VAIN (4),U,2),$ G(PSIVCLIN )&($G(PSIV CLAB)]""): PSIV
  3626   CLAB,$G(PS IVCLIN)&($ P($G(PSIVC LIN),"^",2 )]""):$P(P SIVCLIN,"^ ",2),1:"*  OPT *")
  3627   "RTN","PSI VHYPL",21, 0)
  3628    I PSIVWD= "",$P($G(^ PS(55,DFN, "IV",+ON,0 )),"^",22)  S 
  3629   PSIVWD=$P( $G(^DIC(42 ,+$P($G(^P S(55,DFN," IV",+ON,0) ),"^",22), 0)),"^")
  3630   "RTN","PSI VHYPL",22, 0)
  3631    G:PSIVNOL <1 Q D SET P,^PSIVHYP  S 
  3632   PSIVRM=$P( PSIVSITE,U ,13),P16=$ P($G(^PS(5 5,DFN,"IV" ,+ON,9)),U ,3) S:PSIV RM<1 PSIVR M=30 I 
  3633   $D(PSIVCT) ,PSIVCT'=1  K PSIVCT
  3634   "RTN","PSI VHYPL",23, 0)
  3635    I PSJIO,$ G(PSJIO("F I"))]"" X  PSJIO("FI" )
  3636   "RTN","PSI VHYPL",24, 0)
  3637    I $P(PSIV SITE,U,7)  D
  3638   "RTN","PSI VHYPL",25, 0)
  3639    . S PSIVF LAG=1,(LIN E,PSIV1)=0 ,PSIV2=PSI VNOL,PSIVN OL=0 D RE
  3640   "RTN","PSI VHYPL",26, 0)
  3641    . S PSIVR P="",PSIVR T=""
  3642   "RTN","PSI VHYPL",27, 0)
  3643    . I $D(^P S(55,DFN," IV",+ON,.2 )) S PSIVR P=$P(^PS(5 5,DFN,"IV" ,+ON,.2),U ,3) D
  3644   "RTN","PSI VHYPL",28, 0)
  3645    .. I PSIV 1'>0!'$P(P SIVSITE,U, 3)!($P(PSI VSITE,U,3) =1&(P(4)'= "P"))!($P( PSIVSITE,U ,3)=2&("AH "'[P(4)))  Q   
  3646   ;QUIT IF " DOSE DUE A T" LINE IS  SET TO NO T PRINT
  3647   "RTN","PSI VHYPL",29, 0)
  3648    .. S PSIV RT=$P(^PS( 51.2,PSIVR P,0),U,1)
  3649   "RTN","PSI VHYPL",30, 0)
  3650    .. S X="R OUTE: "_PS IVRT D:X]" " PMR
  3651   "RTN","PSI VHYPL",31, 0)
  3652    . S X="So lution: __ __________ ___" D PRN TL S X="Ad ditive: __ __________ ___" D PRN TL
  3653   "RTN","PSI VHYPL",32, 0)
  3654    . S PSIVN OL=PSIV2
  3655   "RTN","PSI VHYPL",33, 0)
  3656    . I 'PSJI O F LINE=L INE+1:1:(P SIVSITE+$P (PSIVSITE, U,16)) W !
  3657   "RTN","PSI VHYPL",34, 0)
  3658    . I PSJIO ,$G(PSJIO( "EL"))]""  X PSJIO("E L")
  3659   "RTN","PSI VHYPL",35, 0)
  3660    I '$D(PSI VCT) D NOW ^%DTC S 
  3661   Y=%,$P(^PS (55,DFN,"I V",+ON,9), U,1,2)=Y_" ^"_PSIVNOL ,$P(^(9),U ,3)=$P(^(9 ),U,3)+PSI VNOL
  3662   "RTN","PSI VHYPL",36, 0)
  3663    K PSIVFLA G,PSIVSH
  3664   "RTN","PSI VHYPL",37, 0)
  3665   START F PS IV1=1:1:PS IVNOL D
  3666   "RTN","PSI VHYPL",38, 0)
  3667    . S LINE= 0 D RE
  3668   "RTN","PSI VHYPL",39, 0)
  3669    . Q:$D(PS IVFLAG) 
  3670   "RTN","PSI VHYPL",40, 0)
  3671    . I 'PSJI O F LINE=L INE+1:1:(P SIVSITE+$P (PSIVSITE, U,16)) W !
  3672   "RTN","PSI VHYPL",41, 0)
  3673    . I PSJIO ,$G(PSJIO( "EL"))]""  X PSJIO("E L")
  3674   "RTN","PSI VHYPL",42, 0)
  3675    I PSJIO,$ G(PSJIO("F E"))]"" X  PSJIO("FE" )
  3676   "RTN","PSI VHYPL",43, 0)
  3677    D:'$D(PSI VCT) ^PSIV STAT
  3678   "RTN","PSI VHYPL",44, 0)
  3679   Q K 
  3680   HYPL,LINE, MESS,P16,P DATE,PDOSE ,PSIV,PSIV A,PSIV1,PS IV2,PSIVCT ,PSIVDOSE, PSIVFLAG,P SIVRM,PSIV W
  3681   D,TVOL,HYP LPRT,PSIME SS Q
  3682   "RTN","PSI VHYPL",45, 0)
  3683   RE I PSIV1  S:P(15)>2 880!('P(15 )) P(15)=2 880 S P(16 )=P16+PSIV 1#(1440/P( 15)+.5\1)  S:'P(16) 
  3684   P(16)=1440 /P(15)+.5\ 1
  3685   "RTN","PSI VHYPL",46, 0)
  3686    K DO
  3687   "RTN","PSI VHYPL",47, 0)
  3688    I PSJIO,$ G(PSJIO("S L"))]"" X  PSJIO("SL" )
  3689   "RTN","PSI VHYPL",48, 0)
  3690    I PSIV1 S  PSJBCID=$ $BCMA^PSIV BCID(DFN,O N,$D(PSIVC T),$G(PSIV 1),$G(PSIV 2),$G(PSIV NOL)) D 
  3691   BARCODE
  3692   "RTN","PSI VHYPL",49, 0)
  3693    S X="["_$ P(^PS(55,D FN,"IV",+O N,0),U)_"] "_" "_VADM (2)_"  "_P SIVWD_"  
  3694   "_$E(DT,4, 5)_"/"_$E( DT,6,7)_"/ "_$E(DT,2, 3)
  3695   "RTN","PSI VHYPL",50, 0)
  3696    I ($G(PSI VCLIN)>0), $L($G(PSIV RM)),'$G(V AIN(4)) N  PSJTRNC S  PSJTRNC=$L (X)-+$G(PS IVRM) I 
  3697   PSJTRNC>0, ($L(PSIVWD )>PSJTRNC)  D
  3698   "RTN","PSI VHYPL",51, 0)
  3699    . S X="[" _$P(^PS(55 ,DFN,"IV", +ON,0),U)_ "]"_" "_VA DM(2)_"  " _$E(PSIVWD ,1,$L(PSIV WD)-PSJTRN C)_"  
  3700   "_$E(DT,4, 5)_"/"_$E( DT,6,7)_"/ "_$E(DT,2, 3)
  3701   "RTN","PSI VHYPL",52, 0)
  3702    D PRNTL
  3703   "RTN","PSI VHYPL",53, 0)
  3704    S X=VADM( 1) S:$P(PS IVSITE,U,9 ) X=X_"  " _$S(VAIN(5 )]"":VAIN( 5),1:"NF")  D PRNTL S  X=" " D P RNTL
  3705   "RTN","PSI VHYPL",54, 0)
  3706    D:$P(PSIV SITE,U,12)  TVOL
  3707   "RTN","PSI VHYPL",55, 0)
  3708    S X="",$P (X,"=",PSI VRM-1)=""  D PRNTL
  3709   "RTN","PSI VHYPL",56, 0)
  3710    I $D(PSIV FLAG) F PS IV=0:0 S P SIV=$O(^PS (55,DFN,"I V",+ON,"AD ",PSIV)) Q :'PSIV  S 
  3711   Y=^(PSIV,0 ),X=$S($D( ^PS(52.6,+ Y,0)):$P(^ (0),U),1:" *********" )_"  "_$P( Y,U,2)_" "  S:$P(Y,U, 3)]"" X=X_
  3712   ("_$P(Y,U, 3)_")" D
  3713   "RTN","PSI VHYPL",57, 0)
  3714    . D PRNTL
  3715   "RTN","PSI VHYPL",58, 0)
  3716    . D MESS
  3717   "RTN","PSI VHYPL",59, 0)
  3718    I $D(PSIV FLAG) F PS IV=0:0 S P SIV=$O(^PS (55,DFN,"I V",+ON,"SO L",PSIV))  Q:'PSIV  S  
  3719   PSIV=PSIV_ "^"_+^(PSI V,0),YY=^( 0) D
  3720   "RTN","PSI VHYPL",60, 0)
  3721    . D SOL1, PRNTL
  3722   "RTN","PSI VHYPL",61, 0)
  3723    . S X=$P( ^PS(52.7,$ P(PSIV,U,2 ),0),U,4)  I X]"" S X ="   "_X D  PRNTL
  3724   "RTN","PSI VHYPL",62, 0)
  3725    G:$D(PSIV FLAG) SOL
  3726   "RTN","PSI VHYPL",63, 0)
  3727    F PSIV=0: 0 S PSIV=$ O(^PS(55,D FN,"IV",+O N,"SOL",PS IV)) Q:'PS IV  S PSIV =PSIV_"^"_ +^(PSIV,0) ,YY=^(0) D
  3728   "RTN","PSI VHYPL",64, 0)
  3729    . D SOL1, PRNTL I PS IV1 D UP3^ PSIVBCID(D FN,PSJBLN, PSIV,YY)
  3730   "RTN","PSI VHYPL",65, 0)
  3731    . S X=$P( ^PS(52.7,$ P(PSIV,U,2 ),0),U,4)  I X]"" S X ="   "_X D  PRNTL
  3732   "RTN","PSI VHYPL",66, 0)
  3733    F I=0:0 S  I=$O(HYPL (I)) Q:'I   S PSIV=""  D
  3734   "RTN","PSI VHYPL",67, 0)
  3735    . F I=I:0  S PSIV=$O (HYPL(I,PS IV)) Q:PSI V=""  S Y= "",X=0 D
  3736   "RTN","PSI VHYPL",68, 0)
  3737    .. X "F Z Z=0:0 S Y= $O(HYPL(I, PSIV,Y)) Q :Y=""""  I  Y=""ALL"" !(Y=""***" ")!(Y[P(16 )) S 
  3738   X=X+$P(HYP L(I,PSIV,Y ),U),PSIVP =HYPL(I,PS IV,Y) D UP D"
  3739   "RTN","PSI VHYPL",69, 0)
  3740    .. I X D  HYP
  3741   "RTN","PSI VHYPL",70, 0)
  3742    K HYPAD
  3743   "RTN","PSI VHYPL",71, 0)
  3744   SOL S X="" ,$P(X,"=", PSIVRM-1)= "" D PRNTL
  3745   "RTN","PSI VHYPL",72, 0)
  3746    S X=" " D  PRNTL I 
  3747   PSIV1'>0!' $P(PSIVSIT E,U,3)!($P (PSIVSITE, U,3)=1&(P( 4)'="P"))! ($P(PSIVSI TE,U,3)=2& ("AH"'[P(4 ))) G 
  3748   MEDRT
  3749   "RTN","PSI VHYPL",73, 0)
  3750    S:'$D(PSI VDOSE) PSI VDOSE="" S  X=$P(PSIV DOSE," ",P SIV1) D:$E (X)="." CO NVER^PSIVL ABL S X="D ose 
  3751   due at: "_ $S(X="":"_ _______",1 :$E(X,4,5) _"/"_$E(X, 6,7)_"/"_$ E(X,2,3)_"  "_$E(X#1_ "000",2,5) ) D PRNTL
  3752   "RTN","PSI VHYPL",74, 0)
  3753    ;
  3754   "RTN","PSI VHYPL",75, 0)
  3755   MEDRT ;Fin d Medicati on Route    
  3756   "RTN","PSI VHYPL",76, 0)
  3757    S PSIVRP= "",PSIVRT= ""
  3758   "RTN","PSI VHYPL",77, 0)
  3759    I $D(^PS( 55,DFN,"IV ",+ON,.2))  S PSIVRP= $P(^PS(55, DFN,"IV",+ ON,.2),U,3 ) D
  3760   "RTN","PSI VHYPL",78, 0)
  3761    .S PSIVRT =$P(^PS(51 .2,PSIVRP, 0),U,1)
  3762   "RTN","PSI VHYPL",79, 0)
  3763    .S X="ROU TE: "_PSIV RT D:X]""  PMR
  3764   "RTN","PSI VHYPL",80, 0)
  3765    ;
  3766   "RTN","PSI VHYPL",81, 0)
  3767   INF S X=$P (P(8),"@")  D:X]"" PR NTL
  3768   "RTN","PSI VHYPL",82, 0)
  3769    I $D(^PS( 55,DFN,"IV ",+ON,3))  S X=$P(^(3 ),U) D:X]" " PRNTL
  3770   "RTN","PSI VHYPL",83, 0)
  3771    S X=P(9)  D:X]"" PRN TL
  3772   "RTN","PSI VHYPL",84, 0)
  3773    S X=P(11)  D:X]"" PR NTL
  3774   "RTN","PSI VHYPL",85, 0)
  3775    ;PSJ*5*18 4 - Displa y all mess ages if mo re than on e additive  has a mes sage.
  3776   "RTN","PSI VHYPL",86, 0)
  3777    I $D(MESS ) S PSIMES S="" F  S  PSIMESS=$O (MESS(PSIM ESS)) Q:PS IMESS=""   S X=PSIMES S D PRNTL
  3778   "RTN","PSI VHYPL",87, 0)
  3779    I $D(^PS( 59.5,PSIVS N,4)) S Y= ^(4) F PSI V=1:1 S X= $P(Y,U,PSI V) Q:X=""   D PRNTL
  3780   "RTN","PSI VHYPL",88, 0)
  3781    S X=PSIV1 _"["_PSIVN OL_"]" D P RNTL
  3782   "RTN","PSI VHYPL",89, 0)
  3783    Q
  3784   "RTN","PSI VHYPL",90, 0)
  3785   PRNTL N I  F LINE=LIN E+1:1 D  Q :$L(X)<1
  3786   "RTN","PSI VHYPL",91, 0)
  3787    . I LINE> PSIVSITE D
  3788   "RTN","PSI VHYPL",92, 0)
  3789    .. S LINE =1
  3790   "RTN","PSI VHYPL",93, 0)
  3791    .. I 'PSJ IO D  Q
  3792   "RTN","PSI VHYPL",94, 0)
  3793    ... F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,"^",16)   W !
  3794   "RTN","PSI VHYPL",95, 0)
  3795    .. F I="E L","SL" I  $G(PSJIO(I ))]"" X PS JIO(I)
  3796   "RTN","PSI VHYPL",96, 0)
  3797    . K ZZ
  3798   "RTN","PSI VHYPL",97, 0)
  3799    . F I="ST ","STF" I  $G(PSJIO(I ))]"" X PS JIO(I)
  3800   "RTN","PSI VHYPL",98, 0)
  3801    . W $E(X, 1,PSIVRM)
  3802   "RTN","PSI VHYPL",99, 0)
  3803    . F I="ET F","ET" I  $G(PSJIO(I ))]"" X PS JIO(I)
  3804   "RTN","PSI VHYPL",100 ,0)
  3805    . I 'PSJI O W !
  3806   "RTN","PSI VHYPL",101 ,0)
  3807    . S X=$E( X,PSIVRM+1 ,999)
  3808   "RTN","PSI VHYPL",102 ,0)
  3809    Q
  3810   "RTN","PSI VHYPL",103 ,0)
  3811   PMR ; Prin t Med Rout e on label
  3812   "RTN","PSI VHYPL",104 ,0)
  3813    ;  
  3814   "RTN","PSI VHYPL",105 ,0)
  3815    F LINE=LI NE+1:1 D   Q:$L(X)<1
  3816   "RTN","PSI VHYPL",106 ,0)
  3817    . I LINE> PSIVSITE D
  3818   "RTN","PSI VHYPL",107 ,0)
  3819    .. S LINE =1
  3820   "RTN","PSI VHYPL",108 ,0)
  3821    .. I 'PSJ IO D  Q
  3822   "RTN","PSI VHYPL",109 ,0)
  3823    ... F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,"^",16)   W !
  3824   "RTN","PSI VHYPL",110 ,0)
  3825    .. F I="E L","SL" I  $G(PSJIO(I ))]"" X PS JIO(I)
  3826   "RTN","PSI VHYPL",111 ,0)
  3827    . K ZZ
  3828   "RTN","PSI VHYPL",112 ,0)
  3829    . ;
  3830   "RTN","PSI VHYPL",113 ,0)
  3831    . F I="ST ","STF","S M","SMF" I  $G(PSJIO( I))]"" X P SJIO(I)
  3832   "RTN","PSI VHYPL",114 ,0)
  3833    . W $E(X, 1,PSIVRM)
  3834   "RTN","PSI VHYPL",115 ,0)
  3835    . F I="ET F","ET","E MF","EM" I  $G(PSJIO( I))]"" X P SJIO(I)
  3836   "RTN","PSI VHYPL",116 ,0)
  3837    . I 'PSJI O W !
  3838   "RTN","PSI VHYPL",117 ,0)
  3839    . S X=$E( X,PSIVRM+1 ,999)
  3840   "RTN","PSI VHYPL",118 ,0)
  3841    Q
  3842   "RTN","PSI VHYPL",119 ,0)
  3843   TVOL ;
  3844   "RTN","PSI VHYPL",120 ,0)
  3845    S PSIV=TV OL F X=0:0  S X=$O(^P S(55,DFN," IV",+ON,"A D",X)) Q:' X  S X=X_" ^"_^(X,0) 
  3846   S:$P(X,U,4 )[P(16)!($ P(X,U,4)=" ")!'PSIV1 
  3847   PSIV=PSIV+ $S($P(^PS( 52.6,$P(X, U,2),0),U, 10):$P(X,U ,3)/$P(^(0 ),U,10),1: 0)
  3848   "RTN","PSI VHYPL",121 ,0)
  3849    S X="Tota l Volume:  "_(PSIV+.5 \1) D PRNT L
  3850   "RTN","PSI VHYPL",122 ,0)
  3851    Q
  3852   "RTN","PSI VHYPL",123 ,0)
  3853   SOL1 S X=$ S($D(^PS(5 2.7,$P(PSI V,U,2),0)) :$P(^(0),U )_" 
  3854   "_$P(^PS(5 5,DFN,"IV" ,+ON,"SOL" ,+PSIV,0), U,2),1:"** ********")  Q
  3855   "RTN","PSI VHYPL",124 ,0)
  3856   HYP ;
  3857   "RTN","PSI VHYPL",125 ,0)
  3858    I PSIV="* " S X="***  Error in  "_$S(I=50. 4:"electro lyte",I=52 .7:"soluti on",1:"add itive") D  PRNTL Q
  3859   "RTN","PSI VHYPL",126 ,0)
  3860    S 
  3861   PSIVA=$S(I =50.4:PSIV ,I=52.7:+$ G(^PS(55,D FN,"IV",+O N,"SOL",PS IV,0)),1:+ $G(^PS(55, DFN,"IV",+ ON,"AD",
  3862   PSIV,0)))
  3863   "RTN","PSI VHYPL",127 ,0)
  3864    S X=$S($D (^PS(I,PSI VA,0)):$P( ^(0),U),1: "Undefined  
  3865   "_$S(I=50. 4:"electro lyte",I=52 .7:"soluti on",1:"add itive"))_"  
  3866   "_$S(X<1:" 0"_(X+.005 \.01/100), 1:(X+.005\ .01/100))_ " "_$P($P( HYPL(I,PSI V,$O(HYPL( I,PSIV,"") )),U)," ", 2)
  3867   "RTN","PSI VHYPL",128 ,0)
  3868    D PRNTL
  3869   "RTN","PSI VHYPL",129 ,0)
  3870    Q
  3871   "RTN","PSI VHYPL",130 ,0)
  3872   SETP S Y=^ PS(55,DFN, "IV",+ON,0 ) F X=1:1: 23 S P(X)= $P(Y,U,X)
  3873   "RTN","PSI VHYPL",131 ,0)
  3874    Q
  3875   "RTN","PSI VHYPL",132 ,0)
  3876   MESS ;PSJ* 5*184 -mak e MESS a l ocal array  so all me ssages dis play for a ll additiv es.
  3877   "RTN","PSI VHYPL",133 ,0)
  3878    I $P(^PS( 52.6,+Y,0) ,U,9)]"" S  MESS($P(^ PS(52.6,+Y ,0),U,9))= ""
  3879   "RTN","PSI VHYPL",134 ,0)
  3880    Q
  3881   "RTN","PSI VHYPL",135 ,0)
  3882   UPD N X,Y, PSIVEL,PSI VAD
  3883   "RTN","PSI VHYPL",136 ,0)
  3884    S PSIVEL= $P(PSIVP," ^",2)
  3885   "RTN","PSI VHYPL",137 ,0)
  3886    I I=50.4  F PSIVAD=0 :0 S PSIVA D=$O(HYPLR PT(PSIVEL, "AD",PSIVA D)) Q:'PSI VAD  D
  3887   "RTN","PSI VHYPL",138 ,0)
  3888    .I $D(HYP AD(+PSIVAD )) Q
  3889   "RTN","PSI VHYPL",139 ,0)
  3890    .S YY=$G( ^PS(55,DFN ,"IV",+ON, "AD",+PSIV AD,0))
  3891   "RTN","PSI VHYPL",140 ,0)
  3892    .S HYPAD( +PSIVAD)=" "
  3893   "RTN","PSI VHYPL",141 ,0)
  3894    .I +$P(YY ,U,3),(+$P (YY,U,3)'= P(16)) Q
  3895   "RTN","PSI VHYPL",142 ,0)
  3896    .D UP2^PS IVBCID(DFN ,PSJBLN,PS IV,YY)
  3897   "RTN","PSI VHYPL",143 ,0)
  3898    I I'=50.4  S YY=$G(^ PS(55,DFN, "IV",+ON," AD",+PSIV, 0)) D UP2^ PSIVBCID(D FN,PSJBLN, PSIV,YY)
  3899   "RTN","PSI VHYPL",144 ,0)
  3900    Q
  3901   "RTN","PSI VHYPL",145 ,0)
  3902   BARCODE D  PSET^%ZISP
  3903   "RTN","PSI VHYPL",146 ,0)
  3904    I 'PSJIO  D
  3905   "RTN","PSI VHYPL",147 ,0)
  3906    . I IOBAR ON]"" W @I OBARON
  3907   "RTN","PSI VHYPL",148 ,0)
  3908    . W PSJBC ID
  3909   "RTN","PSI VHYPL",149 ,0)
  3910    . I IOBAR OFF]"" W @ IOBAROFF
  3911   "RTN","PSI VHYPL",150 ,0)
  3912    . W !
  3913   "RTN","PSI VHYPL",151 ,0)
  3914    I PSJIO D
  3915   "RTN","PSI VHYPL",152 ,0)
  3916    . F I="SB ","SBF" I  $G(PSJIO(I ))]"" X PS JIO(I)
  3917   "RTN","PSI VHYPL",153 ,0)
  3918    . W PSJBC ID
  3919   "RTN","PSI VHYPL",154 ,0)
  3920    . F I="EB F","EB" I  $G(PSJIO(I ))]"" X PS JIO(I)
  3921   "RTN","PSI VHYPL",155 ,0)
  3922    Q
  3923   "RTN","PSI VHYPR")
  3924   0^12^B4637 5207^B4640 5814
  3925   "RTN","PSI VHYPR",1,0 )
  3926   PSIVHYPR ; BIR/PR-REP RINT LABEL S ; 20 Sep  2018  11: 21 AM
  3927   "RTN","PSI VHYPR",2,0 )
  3928    ;;5.0;INP ATIENT MED ICATIONS;* *58,88,96, 178,184,27 9,332**;16  DEC 97;Bu ild 8
  3929   "RTN","PSI VHYPR",3,0 )
  3930    ;
  3931   "RTN","PSI VHYPR",4,0 )
  3932    ; Referen ce to ^%ZI S(2 is sup ported by  DBIA 3435.
  3933   "RTN","PSI VHYPR",5,0 )
  3934    ; Referen ce to ^PS( 50.4 is su pported by  DBIA 2175 .
  3935   "RTN","PSI VHYPR",6,0 )
  3936    ; Referen ce to ^PS( 52.6 is su pported by  DBIA 1231 .
  3937   "RTN","PSI VHYPR",7,0 )
  3938    ; Referen ce to ^PS( 52.7 is su pported by  DBIA 2173 .
  3939   "RTN","PSI VHYPR",8,0 )
  3940    ; Referen ce to ^PS( 55 is supp orted by D BIA 2191.
  3941   "RTN","PSI VHYPR",9,0 )
  3942    ; Referen ce to ^PS( 51.2 is su pported by  DBIA 2178 .
  3943   "RTN","PSI VHYPR",10, 0)
  3944    ;
  3945   "RTN","PSI VHYPR",11, 0)
  3946    ;NEEDS DF N, ON AND  PSIVNOL (T otal numbe r of label s to print ) and
  3947   "RTN","PSI VHYPR",12, 0)
  3948    ;PSIVCT -  $D(PSIVCT ) NO COUNT  LABEL
  3949   "RTN","PSI VHYPR",13, 0)
  3950   SSWARD ;Ge t patient  SS# and wa rd locatio n
  3951   "RTN","PSI VHYPR",14, 0)
  3952    N X0,PSJI O,I,PSIVCL AB
  3953   "RTN","PSI VHYPR",15, 0)
  3954    S I=0 F   S I=$O(^%Z IS(2,IOST( 0),55,I))  Q:'I  S X0 =^(I,0),PS JIO($P(X0, "^"))=^(1)
  3955   "RTN","PSI VHYPR",16, 0)
  3956    S PSJIO=$ S('$D(PSJI O):0,1:1)
  3957   "RTN","PSI VHYPR",17, 0)
  3958    N PSIVCLI N S PSIVCL IN=+$G(^PS (55,DFN,"I V",+ON,"DS S")) I PSI VCLIN S 
  3959   $P(PSIVCLI N,"^",2)=$ P($G(^SC(+ PSIVCLIN,0 )),"^")
  3960   "RTN","PSI VHYPR",18, 0)
  3961    I $G(PSIV CLIN) S PS IVCLAB=$P( $G(^SC(+PS IVCLIN,0)) ,"^",2)
  3962   "RTN","PSI VHYPR",19, 0)
  3963    D ENIV^PS JAC S 
  3964   VADM(2)=$E (VADM(2),6 ,9),PSIVWD =$S(+VAIN( 4):$P(VAIN (4),U,2),$ G(PSIVCLIN )&($G(PSIV CLAB)]""): PSIV
  3965   CLAB,$G(PS IVCLIN)&($ P($G(PSIVC LIN),"^",2 )]""):$P(P SIVCLIN,"^ ",2),1:"*  OPT *")
  3966   "RTN","PSI VHYPR",20, 0)
  3967    I PSIVWD= "",$P($G(^ PS(55,DFN, "IV",+ON,0 )),"^",22)  S 
  3968   PSIVWD=$P( $G(^DIC(42 ,+$P($G(^P S(55,DFN," IV",+ON,0) ),"^",22), 0)),"^")
  3969   "RTN","PSI VHYPR",21, 0)
  3970    ;;NEW PSI VNOL,PSIV1  S (PSIVNO L,PSIV1)=1
  3971   "RTN","PSI VHYPR",22, 0)
  3972    NEW PSIV1  S PSIV1=1
  3973   "RTN","PSI VHYPR",23, 0)
  3974    G:PSIVNOL <1 Q D SET P,PSIVHYP  S PSIVRM=$ P(PSIVSITE ,U,13),P16 =$P($G(^PS (55,DFN,"I V",+ON,9)) ,U,3) 
  3975   S:PSIVRM<1  PSIVRM=30  I $D(PSIV CT),PSIVCT '=1 K PSIV CT
  3976   "RTN","PSI VHYPR",24, 0)
  3977    I PSJIO,$ G(PSJIO("F I"))]"" X  PSJIO("FI" )
  3978   "RTN","PSI VHYPR",25, 0)
  3979    ;PSJRPHD  is defined  in REPRT^ PSIVLBRP
  3980   "RTN","PSI VHYPR",26, 0)
  3981    I $P(PSIV SITE,U,7), '$D(PSJRPH D) D
  3982   "RTN","PSI VHYPR",27, 0)
  3983    . S PSIVF LAG=1,(LIN E,PSIV1)=0 ,PSIV2=PSI VNOL,PSIVN OL=0 D RE
  3984   "RTN","PSI VHYPR",28, 0)
  3985    . S PSIVR P="",PSIVR T=""
  3986   "RTN","PSI VHYPR",29, 0)
  3987    . I $D(^P S(55,DFN," IV",+ON,.2 )) S PSIVR P=$P(^PS(5 5,DFN,"IV" ,+ON,.2),U ,3) D
  3988   "RTN","PSI VHYPR",30, 0)
  3989    .. I PSIV 1'>0!'$P(P SIVSITE,U, 3)!($P(PSI VSITE,U,3) =1&(P(4)'= "P"))!($P( PSIVSITE,U ,3)=2&("AH "'[P(4)))  Q   
  3990   ;QUIT IF " DOSE DUE A T" IS SET  TO NOT PRI NT
  3991   "RTN","PSI VHYPR",31, 0)
  3992    .. S PSIV RT=$P(^PS( 51.2,PSIVR P,0),U,1)
  3993   "RTN","PSI VHYPR",32, 0)
  3994    .. S X="R OUTE: "_PS IVRT D:X]" " PMR
  3995   "RTN","PSI VHYPR",33, 0)
  3996    . S X="So lution: __ __________ ___" D PRN TL S X="Ad ditive: __ __________ ___" D PRN TL
  3997   "RTN","PSI VHYPR",34, 0)
  3998    . S PSIVN OL=PSIV2
  3999   "RTN","PSI VHYPR",35, 0)
  4000    . I 'PSJI O F LINE=L INE+1:1:(P SIVSITE+$P (PSIVSITE, U,16)) W !
  4001   "RTN","PSI VHYPR",36, 0)
  4002    . I PSJIO  F I="EL", "FE" I $G( PSJIO(I))] "" X PSJIO (I)
  4003   "RTN","PSI VHYPR",37, 0)
  4004    I '$D(PSI VCT) D NOW ^%DTC S 
  4005   Y=%,$P(^PS (55,DFN,"I V",+ON,9), U,1,2)=Y_" ^"_PSIVNOL ,$P(^(9),U ,3)=$P(^(9 ),U,3)+1
  4006   "RTN","PSI VHYPR",38, 0)
  4007    K PSIVFLA G,PSIVSH
  4008   "RTN","PSI VHYPR",39, 0)
  4009   START S PS IV1=1,LINE =0 D RE D
  4010   "RTN","PSI VHYPR",40, 0)
  4011    . Q:$D(PS IVFLAG) 
  4012   "RTN","PSI VHYPR",41, 0)
  4013    . I 'PSJI O F LINE=L INE+1:1:(P SIVSITE+$P (PSIVSITE, U,16)) W !
  4014   "RTN","PSI VHYPR",42, 0)
  4015    . I PSJIO ,$G(PSJIO( "EL"))]""  X PSJIO("E L")
  4016   "RTN","PSI VHYPR",43, 0)
  4017    I PSJIO,$ G(PSJIO("F E"))]"" X  PSJIO("FE" )
  4018   "RTN","PSI VHYPR",44, 0)
  4019    ;;D:'$D(P SIVCT) ^PS IVSTAT
  4020   "RTN","PSI VHYPR",45, 0)
  4021    I '$D(PSI VCT) D ^PS IVSTAT S P (16)=P(16) +PSIVNOL
  4022   "RTN","PSI VHYPR",46, 0)
  4023   Q K 
  4024   HYPL,LINE, MESS,P16,P DATE,PDOSE ,PSIV,PSIV A,PSIV1,PS IV2,PSIVCT ,PSIVDOSE, PSIVFLAG,P SIVRM,PSIV W
  4025   D,TVOL,PSI MESS Q
  4026   "RTN","PSI VHYPR",47, 0)
  4027   RE ;I PSIV 1 S:P(15)> 2880!('P(1 5)) P(15)= 2880 S P(1 6)=P16+PSI V1#(1440/P (15)+.5\1)  S:'P(16) 
  4028   P(16)=1440 /P(15)+.5\ 1
  4029   "RTN","PSI VHYPR",48, 0)
  4030    I PSJIO,$ G(PSJIO("S L"))]"" X  PSJIO("SL" )
  4031   "RTN","PSI VHYPR",49, 0)
  4032    I PSIV1 D  BARCODE
  4033   "RTN","PSI VHYPR",50, 0)
  4034    S X="["_$ P(^PS(55,D FN,"IV",+O N,0),U)_"] "_" "_VADM (2)_"  "_P SIVWD_"  
  4035   "_$E(DT,4, 5)_"/"_$E( DT,6,7)_"/ "_$E(DT,2, 3)
  4036   "RTN","PSI VHYPR",51, 0)
  4037    D
  4038   "RTN","PSI VHYPR",52, 0)
  4039    .N PSJICW ,TMPX,TMPX 1,TMPX2 S  TMPX=X,TMP X1="" I $L (TMPX)>(PS IVRM-1) F  PSJICW=1:1 :$L(TMPX,"  
  4040   ") S TMPX1 =TMPX1_$S( PSJICW=1:" ",1:" ")_$ P(TMPX," " ,PSJICW) I  $L(TMPX1) +$L($P(TMP X," 
  4041   ",PSJICW+1 ))>(PSIVRM -1) S X=TM PX1 D PRNT L S TMPX1= "",X=""
  4042   "RTN","PSI VHYPR",53, 0)
  4043    .I TMPX1] "" S X=TMP X1
  4044   "RTN","PSI VHYPR",54, 0)
  4045    .D PRNTL
  4046   "RTN","PSI VHYPR",55, 0)
  4047    S X=VADM( 1) S:$P(PS IVSITE,U,9 ) X=X_"  " _$S(VAIN(5 )]"":VAIN( 5),1:"NF")  D PRNTL S  X=" " D P RNTL
  4048   "RTN","PSI VHYPR",56, 0)
  4049    D:$P(PSIV SITE,U,12)  TVOL
  4050   "RTN","PSI VHYPR",57, 0)
  4051    S X="",$P (X,"=",PSI VRM-1)=""  D PRNTL
  4052   "RTN","PSI VHYPR",58, 0)
  4053    I $D(PSIV FLAG) F PS IV=0:0 S P SIV=$O(^PS (55,DFN,"I V",+ON,"AD ",PSIV)) Q :'PSIV  S 
  4054   Y=^(PSIV,0 ),X=$S($D( ^PS(52.6,+ Y,0)):$P(^ (0),U),1:" *********" )_" "_$P(Y ,U,2)_" "  S:$P(Y,U,3 )]"" X=X_"  
  4055   ("_$P(Y,U, 3)_")" D
  4056   "RTN","PSI VHYPR",59, 0)
  4057    . D PRNTL ,MESS
  4058   "RTN","PSI VHYPR",60, 0)
  4059    I $D(PSIV FLAG) F PS IV=0:0 S P SIV=$O(^PS (55,DFN,"I V",+ON,"SO L",PSIV))  Q:'PSIV  S  
  4060   PSIV=PSIV_ "^"_+^(PSI V,0),YY=^( 0) D
  4061   "RTN","PSI VHYPR",61, 0)
  4062    . D SOL1, PRNTL
  4063   "RTN","PSI VHYPR",62, 0)
  4064    . S X=$P( ^PS(52.7,$ P(PSIV,U,2 ),0),U,4)  I X]"" S X ="   "_X D  PRNTL
  4065   "RTN","PSI VHYPR",63, 0)
  4066    G:$D(PSIV FLAG) SOL
  4067   "RTN","PSI VHYPR",64, 0)
  4068    F PSIV=0: 0 S PSIV=$ O(^PS(55,D FN,"IVBCMA ",PSJIDNO, "SOL",PSIV )) Q:'PSIV   S 
  4069   PSIV=PSIV_ "^"_+^(PSI V,0),YY=^( 0) D
  4070   "RTN","PSI VHYPR",65, 0)
  4071    . D SOL1, PRNTL
  4072   "RTN","PSI VHYPR",66, 0)
  4073    . S X=$P( ^PS(52.7,$ P(PSIV,U,2 ),0),U,4)  I X]"" S X ="   "_X D  PRNTL
  4074   "RTN","PSI VHYPR",67, 0)
  4075    F I=0:0 S  I=$O(HYPL (I)) Q:'I   S PSIV=""  F I=I:0 S  PSIV=$O(H YPL(I,PSIV )) Q:PSIV= ""  D
  4076   "RTN","PSI VHYPR",68, 0)
  4077    . F Z=""  S Z=$O(HYP L(I,PSIV,Z )) Q:Z=""   S 
  4078   PSIVA=$S(I =50.4:PSIV ,I=52.7:+^ PS(55,DFN, "IVBCMA",P SJIDNO,"SO L",+$P(HYP L(I,PSIV,Z ),U,2),0), 1:+^PS(5
  4079   5,DFN,"IVB CMA",PSJID NO,"AD",+$ P(HYPL(I,P SIV,Z),U,2 ),0)) D HY P
  4080   "RTN","PSI VHYPR",69, 0)
  4081   SOL S X="" ,$P(X,"=", PSIVRM-1)= "" D PRNTL
  4082   "RTN","PSI VHYPR",70, 0)
  4083    S X=" " D  PRNTL I 
  4084   PSIV1'>0!' $P(PSIVSIT E,U,3)!($P (PSIVSITE, U,3)=1&(P( 4)'="P"))! ($P(PSIVSI TE,U,3)=2& ("AH"'[P(4 ))) G 
  4085   MEDRT
  4086   "RTN","PSI VHYPR",71, 0)
  4087    S:'$D(PSI VDOSE) PSI VDOSE="" S  X=$P(PSIV DOSE," ",P SIV1) D:$E (X)="." CO NVER^PSIVL ABL S X="D ose 
  4088   due at: "_ $S(X="":"_ _______",1 :$E(X,4,5) _"/"_$E(X, 6,7)_"/"_$ E(X,2,3)_"  "_$E(X#1_ "000",2,5) ) D PRNTL
  4089   "RTN","PSI VHYPR",72, 0)
  4090    ;
  4091   "RTN","PSI VHYPR",73, 0)
  4092   MEDRT ;Fin d Medicati on Route    
  4093   "RTN","PSI VHYPR",74, 0)
  4094    S PSIVRP= "",PSIVRT= ""
  4095   "RTN","PSI VHYPR",75, 0)
  4096    I $D(^PS( 55,DFN,"IV ",+ON,.2))  S PSIVRP= $P(^PS(55, DFN,"IV",+ ON,.2),U,3 ) D
  4097   "RTN","PSI VHYPR",76, 0)
  4098    .S PSIVRT =$P(^PS(51 .2,PSIVRP, 0),U,1)
  4099   "RTN","PSI VHYPR",77, 0)
  4100    .S X="ROU TE: "_PSIV RT D:X]""  PMR
  4101   "RTN","PSI VHYPR",78, 0)
  4102    ;
  4103   "RTN","PSI VHYPR",79, 0)
  4104   INF S X=$P (P(8),"@")  D:X]"" PR NTL
  4105   "RTN","PSI VHYPR",80, 0)
  4106    I $D(^PS( 55,DFN,"IV ",+ON,3))  S X=$P(^(3 ),U) D:X]" " PRNTL
  4107   "RTN","PSI VHYPR",81, 0)
  4108    S X=P(9)  D:X]"" PRN TL
  4109   "RTN","PSI VHYPR",82, 0)
  4110    S X=P(11)  D:X]"" PR NTL
  4111   "RTN","PSI VHYPR",83, 0)
  4112    ;PSJ*5*18 4 - Displa y all mess ages if mo re than on e additive  has a mes sage.
  4113   "RTN","PSI VHYPR",84, 0)
  4114    I $D(MESS ) S PSIMES S="" F  S  PSIMESS=$O (MESS(PSIM ESS)) Q:PS IMESS=""   S X=PSIMES S D PRNTL
  4115   "RTN","PSI VHYPR",85, 0)
  4116    I $D(^PS( 59.5,PSIVS N,4)) S Y= ^(4) F PSI V=1:1 S X= $P(Y,U,PSI V) Q:X=""   D PRNTL
  4117   "RTN","PSI VHYPR",86, 0)
  4118    S X=$S('+ $G(PSIV1): "0[0]",1:P SIVBAG) D  PRNTL
  4119   "RTN","PSI VHYPR",87, 0)
  4120    Q
  4121   "RTN","PSI VHYPR",88, 0)
  4122   PRNTL N I  F LINE=LIN E+1:1 D  Q :$L(X)<1
  4123   "RTN","PSI VHYPR",89, 0)
  4124    . I LINE> PSIVSITE D
  4125   "RTN","PSI VHYPR",90, 0)
  4126    .. S LINE =1
  4127   "RTN","PSI VHYPR",91, 0)
  4128    .. I 'PSJ IO D  Q
  4129   "RTN","PSI VHYPR",92, 0)
  4130    ... F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,"^",16)   W !
  4131   "RTN","PSI VHYPR",93, 0)
  4132    .. F I="E L","SL" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4133   "RTN","PSI VHYPR",94, 0)
  4134    . K ZZ
  4135   "RTN","PSI VHYPR",95, 0)
  4136    . F I="ST ","STF" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4137   "RTN","PSI VHYPR",96, 0)
  4138    . W $E(X, 1,PSIVRM)
  4139   "RTN","PSI VHYPR",97, 0)
  4140    . F I="ET F","ET" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4141   "RTN","PSI VHYPR",98, 0)
  4142    . I 'PSJI O W !
  4143   "RTN","PSI VHYPR",99, 0)
  4144    . S X=$E( X,PSIVRM+1 ,999)
  4145   "RTN","PSI VHYPR",100 ,0)
  4146    Q
  4147   "RTN","PSI VHYPR",101 ,0)
  4148   PMR ; Prin t Med Rout e on label
  4149   "RTN","PSI VHYPR",102 ,0)
  4150    F LINE=LI NE+1:1 D   Q:$L(X)<1
  4151   "RTN","PSI VHYPR",103 ,0)
  4152    . I LINE> PSIVSITE D
  4153   "RTN","PSI VHYPR",104 ,0)
  4154    .. S LINE =1
  4155   "RTN","PSI VHYPR",105 ,0)
  4156    .. I 'PSJ IO D  Q
  4157   "RTN","PSI VHYPR",106 ,0)
  4158    ... F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,"^",16)   W !
  4159   "RTN","PSI VHYPR",107 ,0)
  4160    .. F I="E L","SL" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4161   "RTN","PSI VHYPR",108 ,0)
  4162    . K ZZ
  4163   "RTN","PSI VHYPR",109 ,0)
  4164    . ;
  4165   "RTN","PSI VHYPR",110 ,0)
  4166    . F I="ST ","STF","S M","SMF" I  $G(PSJIO( I))]"" X P SJIO(I)
  4167   "RTN","PSI VHYPR",111 ,0)
  4168    . W $E(X, 1,PSIVRM)
  4169   "RTN","PSI VHYPR",112 ,0)
  4170    . F I="ET F","ET","E MF","EM" I  $G(PSJIO( I))]"" X P SJIO(I)
  4171   "RTN","PSI VHYPR",113 ,0)
  4172    . I 'PSJI O W !
  4173   "RTN","PSI VHYPR",114 ,0)
  4174    . S X=$E( X,PSIVRM+1 ,999)
  4175   "RTN","PSI VHYPR",115 ,0)
  4176    Q 
  4177   "RTN","PSI VHYPR",116 ,0)
  4178    ;
  4179   "RTN","PSI VHYPR",117 ,0)
  4180   TVOL ;
  4181   "RTN","PSI VHYPR",118 ,0)
  4182    S PSIV=TV OL F X=0:0  S X=$O(^P S(55,DFN," IVBCMA",PS JIDNO,"AD" ,X)) Q:'X   S X=X_"^" _^(X,0) 
  4183   S:$P(X,U,4 )[P(16)!($ P(X,U,4)=" ")!'PSIV1 
  4184   PSIV=PSIV+ $S($P(^PS( 52.6,$P(X, U,2),0),U, 10):$P(X,U ,3)/$P(^(0 ),U,10),1: 0)
  4185   "RTN","PSI VHYPR",119 ,0)
  4186    S X="Tota l Volume:  "_(PSIV+.5 \1) D PRNT L
  4187   "RTN","PSI VHYPR",120 ,0)
  4188    Q
  4189   "RTN","PSI VHYPR",121 ,0)
  4190   SOL1 S X=$ S($D(^PS(5 2.7,$P(PSI V,U,2),0)) :$P(^(0),U )_" 
  4191   "_$P(^PS(5 5,DFN,"IVB CMA",PSJID NO,"SOL",+ PSIV,0),U, 2),1:"**** ******") Q
  4192   "RTN","PSI VHYPR",122 ,0)
  4193   HYP ;
  4194   "RTN","PSI VHYPR",123 ,0)
  4195    I PSIV="* " S X="***  Error in  "_$S(I=50. 4:"electro lyte",I=52 .7:"soluti on",1:"add itive") D  PRNTL Q
  4196   "RTN","PSI VHYPR",124 ,0)
  4197    S X=+HYPL (I,PSIV,Z)
  4198   "RTN","PSI VHYPR",125 ,0)
  4199    S X=$S($D (^PS(I,PSI VA,0)):$P( ^(0),U),1: "Undefined  
  4200   "_$S(I=50. 4:"electro lyte",I=52 .7:"soluti on",1:"add itive"))_"  "_(X+.005 \.01/100)_
  4201   "_$P($P(HY PL(I,PSIV, Z),U)," ", 2)
  4202   "RTN","PSI VHYPR",126 ,0)
  4203    D PRNTL
  4204   "RTN","PSI VHYPR",127 ,0)
  4205    Q
  4206   "RTN","PSI VHYPR",128 ,0)
  4207   SETP S Y=^ PS(55,DFN, "IV",+ON,0 ) F X=1:1: 23 S P(X)= $P(Y,U,X)
  4208   "RTN","PSI VHYPR",129 ,0)
  4209    Q
  4210   "RTN","PSI VHYPR",130 ,0)
  4211   MESS ;PSJ* 5*184 -mak e MESS a l ocal array  so all me ssages dis play for a ll additiv es.
  4212   "RTN","PSI VHYPR",131 ,0)
  4213    I $P(^PS( 52.6,+Y,0) ,U,9)]"" S  MESS($P(^ PS(52.6,+Y ,0),U,9))= ""
  4214   "RTN","PSI VHYPR",132 ,0)
  4215    Q
  4216   "RTN","PSI VHYPR",133 ,0)
  4217   BARCODE D  PSET^%ZISP
  4218   "RTN","PSI VHYPR",134 ,0)
  4219    I 'PSJIO  D
  4220   "RTN","PSI VHYPR",135 ,0)
  4221    . I IOBAR ON]"" W @I OBARON
  4222   "RTN","PSI VHYPR",136 ,0)
  4223    . W PSJBC ID
  4224   "RTN","PSI VHYPR",137 ,0)
  4225    . I IOBAR OFF]"" W @ IOBAROFF
  4226   "RTN","PSI VHYPR",138 ,0)
  4227    . W !
  4228   "RTN","PSI VHYPR",139 ,0)
  4229    I PSJIO D
  4230   "RTN","PSI VHYPR",140 ,0)
  4231    . F I="SB ","SBF" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4232   "RTN","PSI VHYPR",141 ,0)
  4233    . W PSJBC ID
  4234   "RTN","PSI VHYPR",142 ,0)
  4235    . F I="EB F","EB" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4236   "RTN","PSI VHYPR",143 ,0)
  4237    Q
  4238   "RTN","PSI VHYPR",144 ,0)
  4239   PSIVHYP ;
  4240   "RTN","PSI VHYPR",145 ,0)
  4241    K HYPL S  TVOL=0 F Z =52.6,52.7  F DRG=0:0  S 
  4242   DRG=$O(^PS (55,DFN,"I VBCMA",PSJ IDNO,$S(Z= 52.6:"AD", 1:"SOL"),D RG)) Q:'DR G  S 
  4243   DRG=DRG_"^ "_^(DRG,0)  S $P(DRG, "^",4)="AL L" D DRG^P SIVHYP
  4244   "RTN","PSI VHYPR",146 ,0)
  4245    S TVOL=TV OL+.5\1 K  EL,DRG,NAD ,Z
  4246   "RTN","PSI VHYPR",147 ,0)
  4247    Q
  4248   "RTN","PSI VLABL")
  4249   0^14^B4482 8219^B4387 6425
  4250   "RTN","PSI VLABL",1,0 )
  4251   PSIVLABL ; BIR/PR - P RINT OUT L ABELS ; 20  Sep 2018   11:21 AM
  4252   "RTN","PSI VLABL",2,0 )
  4253    ;;5.0;INP ATIENT MED ICATIONS;* *58,82,104 ,127,178,1 84,273,279 ,331,332** ;16 DEC 97 ;Build 8
  4254   "RTN","PSI VLABL",3,0 )
  4255    ;
  4256   "RTN","PSI VLABL",4,0 )
  4257    ; Referen ce to ^%ZI S(2 is sup ported by  DBIA 3435.
  4258   "RTN","PSI VLABL",5,0 )
  4259    ; Referen ce to ^PS( 52.6 is su pported by  DBIA 1231 .
  4260   "RTN","PSI VLABL",6,0 )
  4261    ; Referen ce to ^PS( 52.7 is su pported by  DBIA 2173 .
  4262   "RTN","PSI VLABL",7,0 )
  4263    ; Referen ce to ^PS( 55 is supp orted by D BIA 2191.
  4264   "RTN","PSI VLABL",8,0 )
  4265    ; Referen ce to ^PS( 51.2 is su pported by  DBIA 2178 .
  4266   "RTN","PSI VLABL",9,0 )
  4267    ;
  4268   "RTN","PSI VLABL",10, 0)
  4269    ;Needs DF N,ON, and  PSIVNOL NO TE: If PSI VCT is def ined then  we do
  4270   "RTN","PSI VLABL",11, 0)
  4271    ;not coun t labels i n the STAT s file or  increment  cummulativ e doses or
  4272   "RTN","PSI VLABL",12, 0)
  4273    ;the last  fill fiel d.
  4274   "RTN","PSI VLABL",13, 0)
  4275    ;PSIVCT w ill be def ined if re printing s cheduled l abels, the  suspense
  4276   "RTN","PSI VLABL",14, 0)
  4277    ;list, or  if printi ng individ ual labels  and they  do not cou nt.
  4278   "RTN","PSI VLABL",15, 0)
  4279    ;
  4280   "RTN","PSI VLABL",16, 0)
  4281   DEM ;Get d emographic s and see  if label i s example  only
  4282   "RTN","PSI VLABL",17, 0)
  4283    N X0,PSJI O,I,PSIVCL IN,PSIVCLD T,PSIVCLAB ,PSIVNCNT
  4284   "RTN","PSI VLABL",18, 0)
  4285    S PSIVNCN T=0  ; ini tialize he ader label  count
  4286   "RTN","PSI VLABL",19, 0)
  4287    S I=0 F   S I=$O(^%Z IS(2,IOST( 0),55,I))  Q:'I  S X0 =$G(^(I,0) ) I X0]""  S PSJIO($P (X0,"^"))= ^(1)
  4288   "RTN","PSI VLABL",20, 0)
  4289    S PSJIO=$ S('$D(PSJI O):0,1:1)
  4290   "RTN","PSI VLABL",21, 0)
  4291    S PSIVCLI N=$G(^PS(5 5,DFN,"IV" ,+ON,"DSS" )) S:'(PSI VCLIN>0) P SIVCLIN=""  I PSIVCLI N D
  4292   "RTN","PSI VLABL",22, 0)
  4293    .S PSIVCL DT=$P(PSIV CLIN,"^",2 ) S $P(PSI VCLIN,"^", 2)=$P($G(^ SC(+PSIVCL IN,0)),"^" )
  4294   "RTN","PSI VLABL",23, 0)
  4295    I $G(PSIV CLIN) S PS IVCLAB=$P( $G(^SC(+PS IVCLIN,0)) ,"^",2)
  4296   "RTN","PSI VLABL",24, 0)
  4297    D ENIV^PS JAC,NOW^%D TC S PSIVN OW=$$ENDTC ^PSGMI(%), VADM(2)=$E (VADM(2),6 ,9)
  4298   "RTN","PSI VLABL",25, 0)
  4299    S 
  4300   PSIVWD=$S( (+VAIN(4)& '$G(PSIVCL DT)):$P(VA IN(4),U,2) ,$G(PSIVCL IN)&($G(PS IVCLAB)]"" ):PSIVCLAB ,$G(P
  4301   SIVCLIN)&( $P($G(PSIV CLIN),"^", 2)]""):$P( PSIVCLIN," ^",2),1:"*  OPT *") I  $D(PSIVEX AM) G ENX
  4302   "RTN","PSI VLABL",26, 0)
  4303    ;
  4304   "RTN","PSI VLABL",27, 0)
  4305    G:PSIVNOL <1 Q D SET P S PSIVRM =$P(PSIVSI TE,U,13),P 16=$P($G(^ PS(55,DFN, "IV",+ON,9 )),U,3) 
  4306   S:PSIVRM<1  PSIVRM=30  I $D(PSIV CT),PSIVCT '=1 K PSIV CT
  4307   "RTN","PSI VLABL",28, 0)
  4308    I PSJIO,$ G(PSJIO("F I"))]"" X  PSJIO("FI" )
  4309   "RTN","PSI VLABL",29, 0)
  4310    I $P(PSIV SITE,U,7)  N PSIVLCN, PSIVLOOP S  PSIVLCN=$ P(PSIVSITE ,U,7) F PS IVLOOP=1:1 :PSIVLCN D
  4311   "RTN","PSI VLABL",30, 0)
  4312    . S PSIVF LAG=1,(LIN E,PSIV1)=0 ,PSIV2=PSI VNOL,PSIVN OL=0 D RE
  4313   "RTN","PSI VLABL",31, 0)
  4314    . S PSIVR P="",PSIVR T=""
  4315   "RTN","PSI VLABL",32, 0)
  4316    . I $D(^P S(55,DFN," IV",+ON,.2 )) S PSIVR P=$P(^PS(5 5,DFN,"IV" ,+ON,.2),U ,3) D
  4317   "RTN","PSI VLABL",33, 0)
  4318    .. I PSIV 1'>0!'$P(P SIVSITE,U, 3)!($P(PSI VSITE,U,3) =1&(P(4)'= "P"))!($P( PSIVSITE,U ,3)=2&("AH "'[P(4)))  Q   
  4319   ;DO NOT PR INT ROUTE  IF "DOSE D UE AT" IS  SET TO NOT  PRINT.
  4320   "RTN","PSI VLABL",34, 0)
  4321    .. S PSIV RT=$P(^PS( 51.2,PSIVR P,0),U,1)
  4322   "RTN","PSI VLABL",35, 0)
  4323    .. S X="R OUTE: "_PS IVRT D:X]" " PMR
  4324   "RTN","PSI VLABL",36, 0)
  4325    . S X="So lution: __ __________ ___" D P S  X="Additi ve: ______ _________"  D P
  4326   "RTN","PSI VLABL",37, 0)
  4327    . S PSIVN OL=PSIV2
  4328   "RTN","PSI VLABL",38, 0)
  4329    . I 'PSJI O F LINE=L INE+1:1:(P SIVSITE+$P (PSIVSITE, U,16)) W !
  4330   "RTN","PSI VLABL",39, 0)
  4331    . I PSJIO ,$G(PSJIO( "EL"))]""  X PSJIO("E L")
  4332   "RTN","PSI VLABL",40, 0)
  4333    I '$D(PSI VCT) D NOW ^%DTC S 
  4334   Y=%,$P(^PS (55,DFN,"I V",+ON,9), U,1,2)=Y_" ^"_PSIVNOL ,$P(^(9),U ,3)=$P(^(9 ),U,3)+PSI VNOL
  4335   "RTN","PSI VLABL",41, 0)
  4336    K PSIVFLA G,PSIVSH G  START
  4337   "RTN","PSI VLABL",42, 0)
  4338   SETP S Y=^ PS(55,DFN, "IV",+ON,0 ) F X=1:1: 23 S P(X)= $P(Y,U,X)
  4339   "RTN","PSI VLABL",43, 0)
  4340    Q
  4341   "RTN","PSI VLABL",44, 0)
  4342   ENX ;Print  example l abel
  4343   "RTN","PSI VLABL",45, 0)
  4344    D SETP S  PSIVFLAG=1 ,PSIVRM=$P (PSIVSITE, U,13) S:PS IVRM<1 PSI VRM=30
  4345   "RTN","PSI VLABL",46, 0)
  4346   START F PS IV1=1:1:PS IVNOL D
  4347   "RTN","PSI VLABL",47, 0)
  4348    . S LINE= 0 D RE
  4349   "RTN","PSI VLABL",48, 0)
  4350    . Q:$D(PS IVFLAG)
  4351   "RTN","PSI VLABL",49, 0)
  4352    . I 'PSJI O F LINE=L INE+1:1:(P SIVSITE+$P (PSIVSITE, U,16)) W !
  4353   "RTN","PSI VLABL",50, 0)
  4354    . I PSJIO ,$G(PSJIO( "EL"))]""  X PSJIO("E L")
  4355   "RTN","PSI VLABL",51, 0)
  4356    I PSJIO,$ G(PSJIO("F E"))]"" X  PSJIO("FE" )
  4357   "RTN","PSI VLABL",52, 0)
  4358    D:'$D(PSI VCT) ^PSIV STAT
  4359   "RTN","PSI VLABL",53, 0)
  4360   Q K 
  4361   PSIV,PSIVD OSE,PSIVWD ,P16,LINE, MESS,PSIVC T,PSIV2,PS IVFLAG,PSI VRM,PSIV1, PDOSE,PDAT E,XX1,XX2, B
  4362   AG,CX,PSIM ESS Q
  4363   "RTN","PSI VLABL",54, 0)
  4364   RE ;
  4365   "RTN","PSI VLABL",55, 0)
  4366    K DO
  4367   "RTN","PSI VLABL",56, 0)
  4368    ;*273 - B ottle valu es for che mo admixtu re IVs
  4369   "RTN","PSI VLABL",57, 0)
  4370    N PSIVADT YPE I (P(4 )="A")!($P ($G(^PS(55 ,DFN,"IV", +ON,0)),U, 23)="A") S  PSIVADTYP E=1
  4371   "RTN","PSI VLABL",58, 0)
  4372    I PSIV1,$ G(PSIVADTY PE)!(P(5)= 0) S P(16) =PSIV1 I $ G(PSIVT)]" " D
  4373   "RTN","PSI VLABL",59, 0)
  4374    . S:P(15) >2880!('P( 15)) P(15) =2880 S P( 16)=P16+PS IV1#(1440/ P(15)+.5\1 ) S:'P(16)  P(16)=PSI V1
  4375   "RTN","PSI VLABL",60, 0)
  4376    I PSIV1 S  PSJBCID=$ $BCMA^PSIV BCID(DFN,O N,$D(PSIVC T),$G(PSIV 1),$G(PSIV 2),$G(PSIV NOL))
  4377   "RTN","PSI VLABL",61, 0)
  4378    ;* Only i f prt from  ward or m an list th en store B CMA ID to  set xref f or
  4379   "RTN","PSI VLABL",62, 0)
  4380    ;* reprin t later
  4381   "RTN","PSI VLABL",63, 0)
  4382    I PSIV1,$ G(PSIVWMFL ) S PSIVID ($P(PSJBCI D,"V",2))= ""
  4383   "RTN","PSI VLABL",64, 0)
  4384    I PSJIO,$ G(PSJIO("S L"))]"" X  PSJIO("SL" )
  4385   "RTN","PSI VLABL",65, 0)
  4386    I PSIV1 D  BARCODE
  4387   "RTN","PSI VLABL",66, 0)
  4388    S X="["_$ P(^PS(55,D FN,"IV",+O N,0),U)_"] "_" "_VADM (2)_"  "_P SIVWD_"  
  4389   "_$E(DT,4, 5)_"/"_$E( DT,6,7)_"/ "_$E(DT,2, 3)
  4390   "RTN","PSI VLABL",67, 0)
  4391    I ($G(PSI VCLIN)>0), $L($G(PSIV RM)),'$G(V AIN(4)) N  PSJTRNC S  PSJTRNC=$L (X)-+$G(PS IVRM) I 
  4392   PSJTRNC>0, ($L(PSIVWD )>PSJTRNC)  D
  4393   "RTN","PSI VLABL",68, 0)
  4394    . S X="[" _$P(^PS(55 ,DFN,"IV", +ON,0),U)_ "]"_" "_VA DM(2)_"  " _$E(PSIVWD ,1,$L(PSIV WD)-PSJTRN C)_"  
  4395   "_$E(DT,4, 5)_"/"_$E( DT,6,7)_"/ "_$E(DT,2, 3)
  4396   "RTN","PSI VLABL",69, 0)
  4397    D P
  4398   "RTN","PSI VLABL",70, 0)
  4399    S X=VADM( 1) S:$P(PS IVSITE,U,9 ) X=X_"  " _$S(VAIN(5 )]"":VAIN( 5),1:"NF")  D P S X="  " D P
  4400   "RTN","PSI VLABL",71, 0)
  4401    I $D(PSIV FLAG) F PS IV=0:0 S P SIV=$O(^PS (55,DFN,"I V",+ON,"AD ",PSIV)) Q :'PSIV  S 
  4402   Y=^(PSIV,0 ),X=$S($D( ^PS(52.6,+ Y,0)):$P(^ (0),"^"),1 :"******** *")_" "_$P (Y,U,2)_"  " S:$P(Y,U ,3)]"" X=X _" 
  4403   ("_$P(Y,U, 3)_")" D
  4404   "RTN","PSI VLABL",72, 0)
  4405    . D P
  4406   "RTN","PSI VLABL",73, 0)
  4407    . ;I PSIV 1 S YY=Y D  UP2^PSIVB CID(DFN,PS JBLN,PSIV, YY) S Y=YY
  4408   "RTN","PSI VLABL",74, 0)
  4409    . D MESS
  4410   "RTN","PSI VLABL",75, 0)
  4411    G:$D(PSIV FLAG) SOL
  4412   "RTN","PSI VLABL",76, 0)
  4413    ; IV BOTT LE functio nality, 3r d piece of  PS(55,DFN ,"IV",+ON, "AD",PSIV, 0) dictate s labels p er LABEL R UN 
  4414   on which t he additiv e will pri nt
  4415   "RTN","PSI VLABL",77, 0)
  4416    F PSIV=0: 0 S PSIV=$ O(^PS(55,D FN,"IV",+O N,"AD",PSI V)) Q:'PSI V  S 
  4417   Y=^(PSIV,0 ),X=$S($D( ^PS(52.6,+ Y,0)):$P(^ (0),U),1:" ********") _" "_$P(Y, U,2) I 
  4418   ","_$P(Y,U ,3)_","[(" ,"_P(16)_" ,")!('$P(Y ,U,3)) D
  4419   "RTN","PSI VLABL",78, 0)
  4420    . D P
  4421   "RTN","PSI VLABL",79, 0)
  4422    . I PSIV1  S YY=Y D  UP2^PSIVBC ID(DFN,PSJ BLN,PSIV,Y Y) S Y=YY
  4423   "RTN","PSI VLABL",80, 0)
  4424    . D MESS
  4425   "RTN","PSI VLABL",81, 0)
  4426    ;
  4427   "RTN","PSI VLABL",82, 0)
  4428   SOL F PSIV =0:0 S PSI V=$O(^PS(5 5,DFN,"IV" ,+ON,"SOL" ,PSIV)) Q: 'PSIV  S 
  4429   PSIV=PSIV_ "^"_+^(PSI V,0),YY=^( 0) D
  4430   "RTN","PSI VLABL",83, 0)
  4431    . D SOL1, P I PSIV1  D UP3^PSIV BCID(DFN,P SJBLN,PSIV ,YY)
  4432   "RTN","PSI VLABL",84, 0)
  4433    . S X=$P( ^PS(52.7,$ P(PSIV,U,2 ),0),U,4)  I X]"" S X ="   "_X D  P
  4434   "RTN","PSI VLABL",85, 0)
  4435    I P(23)'= ""!(P(4)=" S") S X="I n Syringe:  "_$E($P(^ PS(55,DFN, "IV",+ON,2 ),U,4),1,2 5) D:P(4)= "S"!(P(23) ="S") 
  4436   P S X="*CA UTION* - C HEMOTHERAP Y" D:P(23) '="" P
  4437   "RTN","PSI VLABL",86, 0)
  4438    S X=" " D  P I 
  4439   PSIV1'>0!' $P(PSIVSIT E,U,3)!($P (PSIVSITE, U,3)=1&(P( 4)'="P"))! ($P(PSIVSI TE,U,3)=2& ("AH"'[P(4 ))) G 
  4440   MEDRT
  4441   "RTN","PSI VLABL",87, 0)
  4442    S:'$D(PSI VDOSE) PSI VDOSE="" S  X=$P(PSIV DOSE," ",P SIV1) D:$E (X)="." CO NVER S X=" Dose due a t: 
  4443   "_$S(X="": "________" ,1:$E(X,4, 5)_"/"_$E( X,6,7)_"/" _$E(X,2,3) _" "_$E(X# 1_"000",2, 5)) D P
  4444   "RTN","PSI VLABL",88, 0)
  4445    ;
  4446   "RTN","PSI VLABL",89, 0)
  4447   MEDRT ;Fin d Medicati on Route    
  4448   "RTN","PSI VLABL",90, 0)
  4449    S PSIVRP= "",PSIVRT= ""
  4450   "RTN","PSI VLABL",91, 0)
  4451    I $D(^PS( 55,DFN,"IV ",+ON,.2))  S PSIVRP= $P(^PS(55, DFN,"IV",+ ON,.2),U,3 ) D
  4452   "RTN","PSI VLABL",92, 0)
  4453    .S PSIVRT =$P(^PS(51 .2,PSIVRP, 0),U,1)
  4454   "RTN","PSI VLABL",93, 0)
  4455    .S X="ROU TE: "_PSIV RT D:X]""  PMR
  4456   "RTN","PSI VLABL",94, 0)
  4457    ;
  4458   "RTN","PSI VLABL",95, 0)
  4459   INF S X=$P (P(8),"@")  D:X]"" P
  4460   "RTN","PSI VLABL",96, 0)
  4461    I $D(^PS( 55,DFN,"IV ",+ON,3))  S X=$P(^(3 ),"^") D:X ]"" P
  4462   "RTN","PSI VLABL",97, 0)
  4463    S X=P(9)  D:X]"" P
  4464   "RTN","PSI VLABL",98, 0)
  4465    S X=P(11)  D:X]"" P
  4466   "RTN","PSI VLABL",99, 0)
  4467    ;PSJ*5*18 4 - Displa y all mess ages if mo re than on e additive  has a mes sage.
  4468   "RTN","PSI VLABL",100 ,0)
  4469    I $D(MESS ) S PSIMES S="" F  S  PSIMESS=$O (MESS(PSIM ESS)) Q:PS IMESS=""   S X=PSIMES S D P
  4470   "RTN","PSI VLABL",101 ,0)
  4471    I $D(^PS( 59.5,PSIVS N,4)) S Y= ^(4) F PSI V=1:1 S X= $P(Y,U,PSI V) Q:X=""   D P
  4472   "RTN","PSI VLABL",102 ,0)
  4473    S X=PSIV1 _"["_$S(PS IV1:PSIVNO L,1:PSIV2) _"]"_"  "_ $S('PSIV1: PSIVNOW,1: "") D P
  4474   "RTN","PSI VLABL",103 ,0)
  4475    Q
  4476   "RTN","PSI VLABL",104 ,0)
  4477    ;
  4478   "RTN","PSI VLABL",105 ,0)
  4479   P F LINE=L INE+1:1 D   Q:$L(X)<1
  4480   "RTN","PSI VLABL",106 ,0)
  4481    . I LINE> PSIVSITE D
  4482   "RTN","PSI VLABL",107 ,0)
  4483    .. S LINE =1
  4484   "RTN","PSI VLABL",108 ,0)
  4485    .. I 'PSJ IO D  Q
  4486   "RTN","PSI VLABL",109 ,0)
  4487    ... F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,"^",16)   W !
  4488   "RTN","PSI VLABL",110 ,0)
  4489    .. F I="E L","SL" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4490   "RTN","PSI VLABL",111 ,0)
  4491    . K ZZ
  4492   "RTN","PSI VLABL",112 ,0)
  4493    . F I="ST ","STF" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4494   "RTN","PSI VLABL",113 ,0)
  4495    . W $E(X, 1,PSIVRM)
  4496   "RTN","PSI VLABL",114 ,0)
  4497    . F I="ET F","ET" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4498   "RTN","PSI VLABL",115 ,0)
  4499    . I 'PSJI O W !
  4500   "RTN","PSI VLABL",116 ,0)
  4501    . S X=$E( X,PSIVRM+1 ,999)
  4502   "RTN","PSI VLABL",117 ,0)
  4503    Q
  4504   "RTN","PSI VLABL",118 ,0)
  4505   PMR ; Prin t Med Rout e on label
  4506   "RTN","PSI VLABL",119 ,0)
  4507    ;  
  4508   "RTN","PSI VLABL",120 ,0)
  4509    F LINE=LI NE+1:1 D   Q:$L(X)<1
  4510   "RTN","PSI VLABL",121 ,0)
  4511    . I LINE> PSIVSITE D
  4512   "RTN","PSI VLABL",122 ,0)
  4513    .. S LINE =1
  4514   "RTN","PSI VLABL",123 ,0)
  4515    .. I 'PSJ IO D  Q
  4516   "RTN","PSI VLABL",124 ,0)
  4517    ... F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,"^",16)   W !
  4518   "RTN","PSI VLABL",125 ,0)
  4519    .. F I="E L","SL" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4520   "RTN","PSI VLABL",126 ,0)
  4521    . K ZZ
  4522   "RTN","PSI VLABL",127 ,0)
  4523    . ;
  4524   "RTN","PSI VLABL",128 ,0)
  4525    . F I="ST ","STF","S M","SMF" I  $G(PSJIO( I))]"" X P SJIO(I)
  4526   "RTN","PSI VLABL",129 ,0)
  4527    . W $E(X, 1,PSIVRM)
  4528   "RTN","PSI VLABL",130 ,0)
  4529    . F I="ET F","ET","E MF","EM" I  $G(PSJIO( I))]"" X P SJIO(I)
  4530   "RTN","PSI VLABL",131 ,0)
  4531    . I 'PSJI O W !
  4532   "RTN","PSI VLABL",132 ,0)
  4533    . S X=$E( X,PSIVRM+1 ,999)
  4534   "RTN","PSI VLABL",133 ,0)
  4535    Q
  4536   "RTN","PSI VLABL",134 ,0)
  4537    ;                
  4538   "RTN","PSI VLABL",135 ,0)
  4539   SOL1 S X=$ S($D(^PS(5 2.7,$P(PSI V,U,2),0)) :$P(^(0)," ^")_" 
  4540   "_$P(^PS(5 5,DFN,"IV" ,+ON,"SOL" ,+PSIV,0), U,2),1:"** ********")  Q
  4541   "RTN","PSI VLABL",136 ,0)
  4542   MESS ;PSJ* 5*184 -mak e MESS a l ocal array  so all me ssages dis play for a ll additiv es.
  4543   "RTN","PSI VLABL",137 ,0)
  4544    I $P(^PS( 52.6,+Y,0) ,U,9)]"" S  MESS($P(^ PS(52.6,+Y ,0),U,9))= ""
  4545   "RTN","PSI VLABL",138 ,0)
  4546    Q
  4547   "RTN","PSI VLABL",139 ,0)
  4548   CONVER ;Ex pand dose  to date.do se and set  in X
  4549   "RTN","PSI VLABL",140 ,0)
  4550    I P(15)>1 440 S X=$$ CONVER1^PS IVORE2($P( PSIVDOSE,"  "),P(15), (PSIV1-1))  Q
  4551   "RTN","PSI VLABL",141 ,0)
  4552    S PDOSE=X  S:PSIV1=2  PDATE=$E( $P(PSIVDOS E," "),1,7 )
  4553   "RTN","PSI VLABL",142 ,0)
  4554    I $P(PSIV DOSE," ",P SIV1-1)#1' <PDOSE!(P( 15)>1440)  S:$D(X1) X X1=X1 S:$D (X2) XX2=X 2 S X1=PDA TE,X2=1 
  4555   D C^%DTC S  PDATE=X,X =X_PDOSE S :$D(XX1) X 1=XX1 S:$D (XX2) X2=X X2 Q
  4556   "RTN","PSI VLABL",143 ,0)
  4557    S X=PDATE _PDOSE
  4558   "RTN","PSI VLABL",144 ,0)
  4559    Q
  4560   "RTN","PSI VLABL",145 ,0)
  4561   BARCODE D  PSET^%ZISP
  4562   "RTN","PSI VLABL",146 ,0)
  4563    I 'PSJIO  D
  4564   "RTN","PSI VLABL",147 ,0)
  4565    . I IOBAR ON]"" W @I OBARON
  4566   "RTN","PSI VLABL",148 ,0)
  4567    . W PSJBC ID
  4568   "RTN","PSI VLABL",149 ,0)
  4569    . I IOBAR OFF]"" W @ IOBAROFF
  4570   "RTN","PSI VLABL",150 ,0)
  4571    . W !
  4572   "RTN","PSI VLABL",151 ,0)
  4573    I PSJIO D
  4574   "RTN","PSI VLABL",152 ,0)
  4575    . F I="SB ","SBF" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4576   "RTN","PSI VLABL",153 ,0)
  4577    . W PSJBC ID
  4578   "RTN","PSI VLABL",154 ,0)
  4579    . F I="EB F","EB" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4580   "RTN","PSI VLABL",155 ,0)
  4581    Q
  4582   "RTN","PSI VLABR")
  4583   0^25^B4009 7446^B4012 5605
  4584   "RTN","PSI VLABR",1,0 )
  4585   PSIVLABR ; BIR/PR-REP RINT LABEL S ; 22 Jan  2019  9:2 9 AM
  4586   "RTN","PSI VLABR",2,0 )
  4587    ;;5.0;INP ATIENT MED ICATIONS;* *58,82,178 ,184,279,3 31,332**;1 6 DEC 97;B uild 8
  4588   "RTN","PSI VLABR",3,0 )
  4589    ;
  4590   "RTN","PSI VLABR",4,0 )
  4591    ; Referen ce to ^%ZI S(2 is sup ported by  DBIA 3435.
  4592   "RTN","PSI VLABR",5,0 )
  4593    ; Referen ce to ^PS( 52.6 is su pported by  DBIA 1231 .
  4594   "RTN","PSI VLABR",6,0 )
  4595    ; Referen ce to ^PS( 52.7 is su pported by  DBIA 2173 .
  4596   "RTN","PSI VLABR",7,0 )
  4597    ; Referen ce to ^PS( 55 is supp orted by D BIA 2191.
  4598   "RTN","PSI VLABR",8,0 )
  4599    ; Referen ce to ^PS( 51.2 is su pported by  DBIA 2178
  4600   "RTN","PSI VLABR",9,0 )
  4601    ;
  4602   "RTN","PSI VLABR",10, 0)
  4603    ;Needs DF N,ON, and  PSIVNOL NO TE: If PSI VCT is def ined then  we do
  4604   "RTN","PSI VLABR",11, 0)
  4605    ;not coun t labels i n the STAT s file or  increment  cummulativ e doses or
  4606   "RTN","PSI VLABR",12, 0)
  4607    ;the last  fill fiel d.
  4608   "RTN","PSI VLABR",13, 0)
  4609    ;PSIVCT w ill be def ined if re printing s cheduled l abels, the  suspense
  4610   "RTN","PSI VLABR",14, 0)
  4611    ;list, or  if printi ng individ ual labels  and they  do not cou nt.
  4612   "RTN","PSI VLABR",15, 0)
  4613    ;
  4614   "RTN","PSI VLABR",16, 0)
  4615   DEM ;Get d emographic s and see  if label i s example  only
  4616   "RTN","PSI VLABR",17, 0)
  4617    N X0,PSJI O,I,PSIVCL AB
  4618   "RTN","PSI VLABR",18, 0)
  4619    S I=0 F   S I=$O(^%Z IS(2,IOST( 0),55,I))  Q:'I  S X0 =$G(^(I,0) ) I X0]""  S PSJIO($P (X0,"^"))= ^(1)
  4620   "RTN","PSI VLABR",19, 0)
  4621    S PSJIO=$ S('$D(PSJI O):0,1:1)
  4622   "RTN","PSI VLABR",20, 0)
  4623    N PSIVCLI N,PSIVCLDT  S PSIVCLI N=$G(^PS(5 5,DFN,"IV" ,+ON,"DSS" )) S:'(PSI VCLIN>0) P SIVCLIN=""  I 
  4624   PSIVCLIN D
  4625   "RTN","PSI VLABR",21, 0)
  4626    .S PSIVCL DT=$P(PSIV CLIN,"^",2 ) S $P(PSI VCLIN,"^", 2)=$P($G(^ SC(+PSIVCL IN,0)),"^" )
  4627   "RTN","PSI VLABR",22, 0)
  4628    I $G(PSIV CLIN) S PS IVCLAB=$P( $G(^SC(+PS IVCLIN,0)) ,"^",2)
  4629   "RTN","PSI VLABR",23, 0)
  4630    D ENIV^PS JAC,NOW^%D TC S PSIVN OW=$$ENDTC ^PSGMI(%), VADM(2)=$E (VADM(2),6 ,9)
  4631   "RTN","PSI VLABR",24, 0)
  4632    S 
  4633   PSIVWD=$S( (+VAIN(4)& '$G(PSIVCL DT)):$P(VA IN(4),U,2) ,$G(PSIVCL IN)&($G(PS IVCLAB)]"" ):PSIVCLAB ,$G(P
  4634   SIVCLIN)&( $P($G(PSIV CLIN),"^", 2)]""):$P( PSIVCLIN," ^",2),1:"*  OPT *") I  $D(PSIVEX AM) G ENX
  4635   "RTN","PSI VLABR",25, 0)
  4636    ;
  4637   "RTN","PSI VLABR",26, 0)
  4638    ;;NEW PSI VNOL,PSIV1  S (PSIVNO L,PSIV1)=1
  4639   "RTN","PSI VLABR",27, 0)
  4640    NEW PSIV1  S PSIV1=1
  4641   "RTN","PSI VLABR",28, 0)
  4642    G:PSIVNOL <1 Q D SET P S PSIVRM =$P(PSIVSI TE,U,13),P 16=$P($G(^ PS(55,DFN, "IV",+ON,9 )),U,3) 
  4643   S:PSIVRM<1  PSIVRM=30  I $D(PSIV CT),PSIVCT '=1 K PSIV CT
  4644   "RTN","PSI VLABR",29, 0)
  4645    I PSJIO,$ G(PSJIO("F I"))]"" X  PSJIO("FI" )
  4646   "RTN","PSI VLABR",30, 0)
  4647    ;PSJRPHD  is defined  in REPRT^ PSIVLBRP s o header o nly print  once.
  4648   "RTN","PSI VLABR",31, 0)
  4649    I $P(PSIV SITE,U,7), '$D(PSJRPH D) D
  4650   "RTN","PSI VLABR",32, 0)
  4651    . S PSIVF LAG=1,(LIN E,PSIV1)=0 ,PSIV2=PSI VNOL,PSIVN OL=0 D RE
  4652   "RTN","PSI VLABR",33, 0)
  4653    . S PSIVR P="",PSIVR T=""
  4654   "RTN","PSI VLABR",34, 0)
  4655    . I $D(^P S(55,DFN," IV",+ON,.2 )) S PSIVR P=$P(^PS(5 5,DFN,"IV" ,+ON,.2),U ,3) D
  4656   "RTN","PSI VLABR",35, 0)
  4657    .. I PSIV 1'>0!'$P(P SIVSITE,U, 3)!($P(PSI VSITE,U,3) =1&(P(4)'= "P"))!($P( PSIVSITE,U ,3)=2&("AH "'[P(4)))  Q   
  4658   ;QUIT IF " DOSE DUE A T" IS SET  TO NOT PRI NT
  4659   "RTN","PSI VLABR",36, 0)
  4660    .. S PSIV RT=$P(^PS( 51.2,PSIVR P,0),U,1)
  4661   "RTN","PSI VLABR",37, 0)
  4662    .. S X="R OUTE: "_PS IVRT D:X]" " PMR
  4663   "RTN","PSI VLABR",38, 0)
  4664    . S X="So lution: __ __________ ___" D P S  X="Additi ve: ______ _________"  D P
  4665   "RTN","PSI VLABR",39, 0)
  4666    . S PSIVN OL=PSIV2
  4667   "RTN","PSI VLABR",40, 0)
  4668    . I 'PSJI O F LINE=L INE+1:1:(P SIVSITE+$P (PSIVSITE, U,16)) W !
  4669   "RTN","PSI VLABR",41, 0)
  4670    . I PSJIO ,$G(PSJIO( "EL"))]""  X PSJIO("E L")
  4671   "RTN","PSI VLABR",42, 0)
  4672    ;;I '$D(P SIVCT) D N OW^%DTC S 
  4673   Y=%,$P(^PS (55,DFN,"I V",+ON,9), U,1,2)=Y_" ^"_PSIVNOL ,$P(^(9),U ,3)=$P(^(9 ),U,3)+PSI VNOL
  4674   "RTN","PSI VLABR",43, 0)
  4675    I '$D(PSI VCT) D NOW ^%DTC S 
  4676   Y=%,$P(^PS (55,DFN,"I V",+ON,9), U,1,2)=Y_" ^"_PSIVNOL ,$P(^(9),U ,3)=$P(^(9 ),U,3)+1
  4677   "RTN","PSI VLABR",44, 0)
  4678    K PSIVFLA G,PSIVSH G  START
  4679   "RTN","PSI VLABR",45, 0)
  4680   SETP S Y=^ PS(55,DFN, "IV",+ON,0 ) F X=1:1: 23 S P(X)= $P(Y,U,X)
  4681   "RTN","PSI VLABR",46, 0)
  4682    Q
  4683   "RTN","PSI VLABR",47, 0)
  4684   ENX ;Print  example l abel
  4685   "RTN","PSI VLABR",48, 0)
  4686    D SETP S  PSIVFLAG=1 ,PSIVRM=$P (PSIVSITE, U,13) S:PS IVRM<1 PSI VRM=30
  4687   "RTN","PSI VLABR",49, 0)
  4688   START S PS IV1=1,LINE =0 D RE D
  4689   "RTN","PSI VLABR",50, 0)
  4690    . Q:$D(PS IVFLAG) 
  4691   "RTN","PSI VLABR",51, 0)
  4692    . I 'PSJI O F LINE=L INE+1:1:(P SIVSITE+$P (PSIVSITE, U,16)) W !
  4693   "RTN","PSI VLABR",52, 0)
  4694    . I PSJIO ,$G(PSJIO( "EL"))]""  X PSJIO("E L")
  4695   "RTN","PSI VLABR",53, 0)
  4696    I PSJIO,$ G(PSJIO("F E"))]"" X  PSJIO("FE" )
  4697   "RTN","PSI VLABR",54, 0)
  4698    D:'$D(PSI VCT) ^PSIV STAT
  4699   "RTN","PSI VLABR",55, 0)
  4700   Q K 
  4701   PSIV,PSIVD OSE,PSIVCT ,PSIVWD,P1 6,LINE,MES S,PSIV2,PS IVFLAG,PSI VRM,PSIV1, PDOSE,PDAT E,XX1,XX2, B
  4702   AG,CX,PSIM ESS Q
  4703   "RTN","PSI VLABR",56, 0)
  4704   RE ;
  4705   "RTN","PSI VLABR",57, 0)
  4706    ;NEED THE  CODE BELO W?
  4707   "RTN","PSI VLABR",58, 0)
  4708    ;;I PSIV1 ,P(4)="A"! (P(5)=0) S :P(15)>288 0!('P(15))  P(15)=288 0 S P(16)= P16+PSIV1# (1440/P(15 )+.5\1) 
  4709   S:'P(16) P (16)=PSIV1
  4710   "RTN","PSI VLABR",59, 0)
  4711    I PSJIO,$ G(PSJIO("S L"))]"" X  PSJIO("SL" )
  4712   "RTN","PSI VLABR",60, 0)
  4713    I PSIV1 D  BARCODE
  4714   "RTN","PSI VLABR",61, 0)
  4715    S X="["_$ P(^PS(55,D FN,"IV",+O N,0),U)_"] "_" "_VADM (2)_"  "_P SIVWD_"  
  4716   "_$E(DT,4, 5)_"/"_$E( DT,6,7)_"/ "_$E(DT,2, 3)
  4717   "RTN","PSI VLABR",62, 0)
  4718    I ($G(PSI VCLIN)>0), $L($G(PSIV RM)),'$G(V AIN(4)) N  PSJTRNC S  PSJTRNC=$L (X)-+$G(PS IVRM) I 
  4719   PSJTRNC>0, ($L(PSIVWD )>PSJTRNC)  D
  4720   "RTN","PSI VLABR",63, 0)
  4721    . S X="[" _$P(^PS(55 ,DFN,"IV", +ON,0),U)_ "]"_" "_VA DM(2)_"  " _$E(PSIVWD ,1,$L(PSIV WD)-PSJTRN C)_"  
  4722   "_$E(DT,4, 5)_"/"_$E( DT,6,7)_"/ "_$E(DT,2, 3)
  4723   "RTN","PSI VLABR",64, 0)
  4724    D P
  4725   "RTN","PSI VLABR",65, 0)
  4726    ;D
  4727   "RTN","PSI VLABR",66, 0)
  4728    ;.N PSJIC W,TMPX,TMP X1,TMPX2 S  TMPX=X,TM PX1="" I $ L(TMPX)>(P SIVRM-1) F  PSJICW=1: 1:$L(TMPX,
  4729   ") S TMPX1 =TMPX1_$S( PSJICW=1:" ",1:" ")_$ P(TMPX," " ,PSJICW) I  $L(TMPX1) +$L($P(TMP X," 
  4730   ",PSJICW+1 ))>(PSIVRM -1) S X=TM PX1 D P S  TMPX1="",X =""
  4731   "RTN","PSI VLABR",67, 0)
  4732    ;.I TMPX1 ]"" S X=TM PX1 D P
  4733   "RTN","PSI VLABR",68, 0)
  4734    S X=VADM( 1) S:$P(PS IVSITE,U,9 ) X=X_"  " _$S(VAIN(5 )]"":VAIN( 5),1:"NF")  D P S X="  " D P
  4735   "RTN","PSI VLABR",69, 0)
  4736    I $D(PSIV FLAG) F PS IV=0:0 S P SIV=$O(^PS (55,DFN,"I V",+ON,"AD ",PSIV)) Q :'PSIV  S 
  4737   Y=^(PSIV,0 ),X=$S($D( ^PS(52.6,+ Y,0)):$P(^ (0),"^"),1 :"******** *")_" "_$P (Y,U,2)_"  " S:$P(Y,U ,3)]"" X=X _" 
  4738   ("_$P(Y,U, 3)_")" D
  4739   "RTN","PSI VLABR",70, 0)
  4740    . D P,MES S
  4741   "RTN","PSI VLABR",71, 0)
  4742    G:$D(PSIV FLAG) SOL
  4743   "RTN","PSI VLABR",72, 0)
  4744    F PSIV=0: 0 S PSIV=$ O(^PS(55,D FN,"IVBCMA ",PSJIDNO, "AD",PSIV) ) Q:'PSIV   S 
  4745   Y=^(PSIV,0 ),X=$S($D( ^PS(52.6,+ Y,0)):$P(^ (0),U),1:" ********") _" "_$P(Y, U,2) D
  4746   "RTN","PSI VLABR",73, 0)
  4747    . D P,MES S
  4748   "RTN","PSI VLABR",74, 0)
  4749   SOL F PSIV =0:0 S PSI V=$O(^PS(5 5,DFN,"IVB CMA",PSJID NO,"SOL",P SIV)) Q:'P SIV  S 
  4750   PSIV=PSIV_ "^"_+^(PSI V,0),YY=^( 0) D
  4751   "RTN","PSI VLABR",75, 0)
  4752    . D SOL1, P
  4753   "RTN","PSI VLABR",76, 0)
  4754    . S X=$P( ^PS(52.7,$ P(PSIV,U,2 ),0),U,4)  I X]"" S X ="   "_X D  P
  4755   "RTN","PSI VLABR",77, 0)
  4756    I P(23)'= ""!(P(4)=" S") S X="I n Syringe:  "_$E($P(^ PS(55,DFN, "IV",+ON,2 ),U,4),1,2 5) D:P(4)= "S"!(P(23) ="S") 
  4757   P S X="*CA UTION* - C HEMOTHERAP Y" D:P(23) '="" P
  4758   "RTN","PSI VLABR",78, 0)
  4759    S X=" " D  P I 
  4760   PSIV1'>0!' $P(PSIVSIT E,U,3)!($P (PSIVSITE, U,3)=1&(P( 4)'="P"))! ($P(PSIVSI TE,U,3)=2& ("AH"'[P(4 ))) G 
  4761   MEDRT
  4762   "RTN","PSI VLABR",79, 0)
  4763    S:'$D(PSI VDOSE) PSI VDOSE="" S  X=$P(PSIV DOSE," ",P SIV1) D:$E (X)="." CO NVER S X=" Dose due a t: 
  4764   "_$S(X="": "________" ,1:$E(X,4, 5)_"/"_$E( X,6,7)_"/" _$E(X,2,3) _" "_$E(X# 1_"000",2, 5)) D P
  4765   "RTN","PSI VLABR",80, 0)
  4766    ;
  4767   "RTN","PSI VLABR",81, 0)
  4768   MEDRT ;Fin d Medicati on Route    
  4769   "RTN","PSI VLABR",82, 0)
  4770    S PSIVRP= "",PSIVRT= ""
  4771   "RTN","PSI VLABR",83, 0)
  4772    I $D(^PS( 55,DFN,"IV ",+ON,.2))  S PSIVRP= $P(^PS(55, DFN,"IV",+ ON,.2),U,3 ) D
  4773   "RTN","PSI VLABR",84, 0)
  4774    .S PSIVRT =$P(^PS(51 .2,PSIVRP, 0),U,1)
  4775   "RTN","PSI VLABR",85, 0)
  4776    .S X="ROU TE: "_PSIV RT D:X]""  PMR
  4777   "RTN","PSI VLABR",86, 0)
  4778    ;
  4779   "RTN","PSI VLABR",87, 0)
  4780   INF S X=$P (P(8),"@")  D:X]"" P
  4781   "RTN","PSI VLABR",88, 0)
  4782    I $D(^PS( 55,DFN,"IV ",+ON,3))  S X=$P(^(3 ),"^") D:X ]"" P
  4783   "RTN","PSI VLABR",89, 0)
  4784    S X=P(9)  D:X]"" P
  4785   "RTN","PSI VLABR",90, 0)
  4786    S X=P(11)  D:X]"" P
  4787   "RTN","PSI VLABR",91, 0)
  4788    ;PSJ*5*18 4 - Displa y all mess ages if mo re than on e additive  has a mes sage.
  4789   "RTN","PSI VLABR",92, 0)
  4790    I $D(MESS ) S PSIMES S="" F  S  PSIMESS=$O (MESS(PSIM ESS)) Q:PS IMESS=""   S X=PSIMES S D P
  4791   "RTN","PSI VLABR",93, 0)
  4792    I $D(^PS( 59.5,PSIVS N,4)) S Y= ^(4) F PSI V=1:1 S X= $P(Y,U,PSI V) Q:X=""   D P
  4793   "RTN","PSI VLABR",94, 0)
  4794    ;S X=PSIV 1_"["_$S(P SIV1:PSIVN OL,1:PSIV2 )_"]"_"  " _$S('PSIV1 :PSIVNOW,1 :"") D P
  4795   "RTN","PSI VLABR",95, 0)
  4796    S X=PSIVB AG D P
  4797   "RTN","PSI VLABR",96, 0)
  4798    Q
  4799   "RTN","PSI VLABR",97, 0)
  4800   P F LINE=L INE+1:1 D   Q:$L(X)<1
  4801   "RTN","PSI VLABR",98, 0)
  4802    . I LINE> PSIVSITE D
  4803   "RTN","PSI VLABR",99, 0)
  4804    .. S LINE =1
  4805   "RTN","PSI VLABR",100 ,0)
  4806    .. I 'PSJ IO D  Q
  4807   "RTN","PSI VLABR",101 ,0)
  4808    ... F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,"^",16)   W !
  4809   "RTN","PSI VLABR",102 ,0)
  4810    .. F I="E L","SL" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4811   "RTN","PSI VLABR",103 ,0)
  4812    . K ZZ
  4813   "RTN","PSI VLABR",104 ,0)
  4814    . F I="ST ","STF" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4815   "RTN","PSI VLABR",105 ,0)
  4816    . W $E(X, 1,PSIVRM)
  4817   "RTN","PSI VLABR",106 ,0)
  4818    . F I="ET F","ET" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4819   "RTN","PSI VLABR",107 ,0)
  4820    . I 'PSJI O W !
  4821   "RTN","PSI VLABR",108 ,0)
  4822    . S X=$E( X,PSIVRM+1 ,999)
  4823   "RTN","PSI VLABR",109 ,0)
  4824    Q
  4825   "RTN","PSI VLABR",110 ,0)
  4826   PMR ; Prin t Med Rout e on label
  4827   "RTN","PSI VLABR",111 ,0)
  4828    ;
  4829   "RTN","PSI VLABR",112 ,0)
  4830    F LINE=LI NE+1:1 D   Q:$L(X)<1
  4831   "RTN","PSI VLABR",113 ,0)
  4832    . I LINE> PSIVSITE D
  4833   "RTN","PSI VLABR",114 ,0)
  4834    .. S LINE =1
  4835   "RTN","PSI VLABR",115 ,0)
  4836    .. I 'PSJ IO D  Q
  4837   "RTN","PSI VLABR",116 ,0)
  4838    ... F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,"^",16)   W !
  4839   "RTN","PSI VLABR",117 ,0)
  4840    .. F I="E L","SL" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4841   "RTN","PSI VLABR",118 ,0)
  4842    . K ZZ
  4843   "RTN","PSI VLABR",119 ,0)
  4844    . ;
  4845   "RTN","PSI VLABR",120 ,0)
  4846    . F I="ST ","STF","S M","SMF" I  $G(PSJIO( I))]"" X P SJIO(I)
  4847   "RTN","PSI VLABR",121 ,0)
  4848    . W $E(X, 1,PSIVRM)
  4849   "RTN","PSI VLABR",122 ,0)
  4850    . F I="ET F","ET","E MF","EM" I  $G(PSJIO( I))]"" X P SJIO(I)
  4851   "RTN","PSI VLABR",123 ,0)
  4852    . I 'PSJI O W !
  4853   "RTN","PSI VLABR",124 ,0)
  4854    . S X=$E( X,PSIVRM+1 ,999)
  4855   "RTN","PSI VLABR",125 ,0)
  4856    Q
  4857   "RTN","PSI VLABR",126 ,0)
  4858   SOL1 S X=$ S($D(^PS(5 2.7,$P(PSI V,U,2),0)) :$P(^(0)," ^")_" 
  4859   "_$P(^PS(5 5,DFN,"IVB CMA",PSJID NO,"SOL",+ PSIV,0),U, 2),1:"**** ******") Q
  4860   "RTN","PSI VLABR",127 ,0)
  4861   MESS ;PSJ* 5*184 -mak e MESS a l ocal array  so all me ssages dis play for a ll additiv es.
  4862   "RTN","PSI VLABR",128 ,0)
  4863    I $P(^PS( 52.6,+Y,0) ,U,9)]"" S  MESS($P(^ PS(52.6,+Y ,0),U,9))= ""
  4864   "RTN","PSI VLABR",129 ,0)
  4865    Q
  4866   "RTN","PSI VLABR",130 ,0)
  4867   CONVER ;Ex pand dose  to date.do se and set  in X
  4868   "RTN","PSI VLABR",131 ,0)
  4869    I P(15)>1 440 S X=$$ CONVER1^PS IVORE2($P( PSIVDOSE,"  "),P(15), (PSIV1-1))  Q
  4870   "RTN","PSI VLABR",132 ,0)
  4871    S PDOSE=X  S:PSIV1=2  PDATE=$E( $P(PSIVDOS E," "),1,7 )
  4872   "RTN","PSI VLABR",133 ,0)
  4873    I $P(PSIV DOSE," ",P SIV1-1)#1' <PDOSE!(P( 15)>1440)  S:$D(X1) X X1=X1 S:$D (X2) XX2=X 2 S X1=PDA TE,X2=1 
  4874   D C^%DTC S  PDATE=X,X =X_PDOSE S :$D(XX1) X 1=XX1 S:$D (XX2) X2=X X2 Q
  4875   "RTN","PSI VLABR",134 ,0)
  4876    S X=PDATE _PDOSE
  4877   "RTN","PSI VLABR",135 ,0)
  4878    Q
  4879   "RTN","PSI VLABR",136 ,0)
  4880   BARCODE D  PSET^%ZISP
  4881   "RTN","PSI VLABR",137 ,0)
  4882    I 'PSJIO  D
  4883   "RTN","PSI VLABR",138 ,0)
  4884    . I IOBAR ON]"" W @I OBARON
  4885   "RTN","PSI VLABR",139 ,0)
  4886    . W PSJBC ID
  4887   "RTN","PSI VLABR",140 ,0)
  4888    . I IOBAR OFF]"" W @ IOBAROFF
  4889   "RTN","PSI VLABR",141 ,0)
  4890    . W !
  4891   "RTN","PSI VLABR",142 ,0)
  4892    I PSJIO D
  4893   "RTN","PSI VLABR",143 ,0)
  4894    . F I="SB ","SBF" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4895   "RTN","PSI VLABR",144 ,0)
  4896    . W PSJBC ID
  4897   "RTN","PSI VLABR",145 ,0)
  4898    . F I="EB F","EB" I  $G(PSJIO(I ))]"" X PS JIO(I)
  4899   "RTN","PSI VLABR",146 ,0)
  4900    Q
  4901   "RTN","PSI VLBL1")
  4902   0^6^B45574 055^B42809 676
  4903   "RTN","PSI VLBL1",1,0 )
  4904   PSIVLBL1 ; BIR/RGY-PR INT LABEL  FROM WARD  LIST ; 24  Oct 2017   9:08 AM
  4905   "RTN","PSI VLBL1",2,0 )
  4906    ;;5.0;INP ATIENT MED ICATIONS;* *69,58,81, 97,104,279 ,332**;16  DEC 97;Bui ld 8
  4907   "RTN","PSI VLBL1",3,0 )
  4908    ;
  4909   "RTN","PSI VLBL1",4,0 )
  4910    ; Referen ce to ^PS( 55 is supp orted by D BIA 2191.
  4911   "RTN","PSI VLBL1",5,0 )
  4912    ; Referen ce to ^%DT  is suppor ted by DBI A 10003.
  4913   "RTN","PSI VLBL1",6,0 )
  4914    ; Referen ce to ^%ZI S is suppo rted by DB IA 10086.
  4915   "RTN","PSI VLBL1",7,0 )
  4916    ; Referen ce to ^%ZT LOAD is su pported by  DBIA 1006 3.
  4917   "RTN","PSI VLBL1",8,0 )
  4918    ; Referen ce to ^DIC N is suppo rted by DB IA 10009.
  4919   "RTN","PSI VLBL1",9,0 )
  4920    ; Referen ce to ^DIR  is suppor ted by DBI A 10026.
  4921   "RTN","PSI VLBL1",10, 0)
  4922    ; Referen ce to ^VAL M1 is supp orted by D BIA 10116.
  4923   "RTN","PSI VLBL1",11, 0)
  4924    ; Referen ce to ^%ZO SF("TEST")  is suppor ted by DBI A 10096
  4925   "RTN","PSI VLBL1",12, 0)
  4926    ;
  4927   "RTN","PSI VLBL1",13, 0)
  4928   START S Y= 1 W !!,"Sc hedule lab els for DA TE: TODAY/ /" R X:DTI ME S:'$T X ="^" S:X=" " X="T" Q: X["^"  I 
  4929   X'["?" S % DT="EX" D  ^%DT
  4930   "RTN","PSI VLBL1",14, 0)
  4931    G:Y<1 STA RT
  4932   "RTN","PSI VLBL1",15, 0)
  4933    I X["?" S  HELP="LBL 1" D ^PSIV HLP S X="? " D ^%DT G  START
  4934   "RTN","PSI VLBL1",16, 0)
  4935   ASK S PSIV DT=Y\1 D ^ PSIVWL1 G  QUIT:'$D(P SIVOD)!('$ D(PSIVCD))
  4936   "RTN","PSI VLBL1",17, 0)
  4937    I PSIVPL' =ION D QUE  G QUIT
  4938   "RTN","PSI VLBL1",18, 0)
  4939   DEQ ;
  4940   "RTN","PSI VLBL1",19, 0)
  4941    L +^PS(55 ,"PSIVWL", PSIVSN):1  E  W:$Y @I OF W !!,"* *** WARNIN G --- LABE LS NOT",!, "   RUN, W ARD 
  4942   LIST IN PR OGRESS" G  QUIT
  4943   "RTN","PSI VLBL1",20, 0)
  4944    S PSIVT=" " F PSIVLB L1=0:0 S P SIVT=$O(PS IVOD(PSIVT )) Q:PSIVT =""  S WRD ="" D 
  4945   @("LBL"_$S ($D(^PS(55 ,"PSIVWLM" ,PSIVSN,PS IVT_PSIVOD (PSIVT))): "M",1:"W") )
  4946   "RTN","PSI VLBL1",21, 0)
  4947    I $G(PSJR PFLG) D
  4948   "RTN","PSI VLBL1",22, 0)
  4949    . W !!,"* ** NOTE ** *"
  4950   "RTN","PSI VLBL1",23, 0)
  4951    . W !!,"S chedule la bels had a lready pri nted for t he selecte d manufact uring time ."
  4952   "RTN","PSI VLBL1",24, 0)
  4953    . W !,"Pl ease use t he Reprint  Scheduled  Labels op tion inste ad.",!
  4954   "RTN","PSI VLBL1",25, 0)
  4955    . K PSJRP FLG
  4956   "RTN","PSI VLBL1",26, 0)
  4957   QUIT L -^P S(55,"PSIV WL",PSIVSN ) S:$D(ZTQ UEUED) ZTR EQ="@" K 
  4958   %,%DT,%T,D ,DFN,I,JJ, NOFLG,ON,P ,PSCT,PSIV ,PSIVCD,PS IVDT,PSIVD OSE,PSIVMT ,PSIVOD,PS IVNOL,PSIV T,
  4959   VAERR,WRD, X,X1,X2,Y, Z,ZTSK,OIX 1,OIX2
  4960   "RTN","PSI VLBL1",27, 0)
  4961    Q
  4962   "RTN","PSI VLBL1",28, 0)
  4963   LBLM ;
  4964   "RTN","PSI VLBL1",29, 0)
  4965    N OIX1,OI X2 I '$D(^ PS(55,"PSI VWLM",PSIV SN,PSIVT_P SIVOD(PSIV T),PSIVT))  D DESC(PS IVT) Q
  4966   "RTN","PSI VLBL1",30, 0)
  4967    S OIX1=0  F  S OIX1= $O(^PS(55, "PSIVWLM", PSIVSN,PSI VT_PSIVOD( PSIVT),PSI VT,OIX1))  Q:OIX1=""   S 
  4968   OIX2=0 F   S OIX2=$O( ^PS(55,"PS IVWLM",PSI VSN,PSIVT_ PSIVOD(PSI VT),PSIVT, OIX1,OIX2) ) Q:OIX2=" "  D 
  4969   LBLM1
  4970   "RTN","PSI VLBL1",31, 0)
  4971    K JX Q
  4972   "RTN","PSI VLBL1",32, 0)
  4973   LBLM1 ;
  4974   "RTN","PSI VLBL1",33, 0)
  4975    S NOFLG=1  N DFNX,ON X
  4976   "RTN","PSI VLBL1",34, 0)
  4977    S DFNX=0  F  S DFNX= $O(^PS(55, "PSIVWLM", PSIVSN,PSI VT_PSIVOD( PSIVT),PSI VT,OIX1,OI X2,DFNX)) 
  4978   Q:'DFNX  D
  4979   "RTN","PSI VLBL1",35, 0)
  4980    . S DFN=+ DFNX D ENI V^PSJAC S  DFN=DFNX,O NX=0 F  S 
  4981   ONX=$O(^PS (55,"PSIVW LM",PSIVSN ,PSIVT_PSI VOD(PSIVT) ,PSIVT,OIX 1,OIX2,DFN ,ONX)) Q:' ONX  D
  4982   "RTN","PSI VLBL1",36, 0)
  4983    .. S ON=+ ONX,WRD=$P (^(+ON),"^ ",2),X1=OI X1,X2=OIX2  D MEOW
  4984   "RTN","PSI VLBL1",37, 0)
  4985    ; naked r eference o n line abo ve refers  to the ^PS (55,"PSIVW LM" refere nce on the  line prec eding the 
  4986   naked refe rence
  4987   "RTN","PSI VLBL1",38, 0)
  4988    D:NOFLG D ESC(PSIVT)
  4989   "RTN","PSI VLBL1",39, 0)
  4990    Q
  4991   "RTN","PSI VLBL1",40, 0)
  4992   LBLW ; loo p through  ward lists
  4993   "RTN","PSI VLBL1",41, 0)
  4994    N DFNX,ON X,WRDX
  4995   "RTN","PSI VLBL1",42, 0)
  4996    S NOFLG=1  S WRDX=0  F  S WRDX= $O(^PS(55, "PSIVWL",P SIVSN,WRDX )) Q:WRDX= ""  D
  4997   "RTN","PSI VLBL1",43, 0)
  4998    . S WRD=W RDX S DFNX =0 F  S DF NX=$O(^PS( 55,"PSIVWL ",PSIVSN,W RD,PSIVT_P SIVOD(PSIV T),DFNX)) 
  4999   Q:'DFNX  D
  5000   "RTN","PSI VLBL1",44, 0)
  5001    .. S DFN= +DFNX D EN IV^PSJAC S  DFN=DFNX  S ONX=0 F   S 
  5002   ONX=$O(^PS (55,"PSIVW L",PSIVSN, WRD,PSIVT_ PSIVOD(PSI VT),DFN,ON X)) Q:'ONX   S ON=+ON X D MEOW
  5003   "RTN","PSI VLBL1",45, 0)
  5004    D:NOFLG D ESC(PSIVT)
  5005   "RTN","PSI VLBL1",46, 0)
  5006    Q
  5007   "RTN","PSI VLBL1",47, 0)
  5008   MEOWRPT ;R eprint fro m man/ward  list
  5009   "RTN","PSI VLBL1",48, 0)
  5010    I '$O(^PS (55,"PSIVW L",PSIVSN, WRD,PSIVT_ PSIVOD(PSI VT),DFN,+O N,0)) D ME OW Q
  5011   "RTN","PSI VLBL1",49, 0)
  5012    S PSIVWMF L=1 ;this  flag indic ate prt/re prt from w ar/man lis t
  5013   "RTN","PSI VLBL1",50, 0)
  5014    NEW PSJID ,PSIVOID,P SIVID,X,XX
  5015   "RTN","PSI VLBL1",51, 0)
  5016    F PSJID=0 :0 S PSJID =$O(^PS(55 ,"PSIVWL", PSIVSN,WRD ,PSIVT_PSI VOD(PSIVT) ,DFN,+ON,P SJID)) Q:' PSJID  
  5017   D REPRT
  5018   "RTN","PSI VLBL1",52, 0)
  5019    ;
  5020   "RTN","PSI VLBL1",53, 0)
  5021    ; Kill ol d ID and s et newly r eprinted I D.
  5022   "RTN","PSI VLBL1",54, 0)
  5023    ;
  5024   "RTN","PSI VLBL1",55, 0)
  5025    F X=0:0 S  X=$O(PSIV OID(X)) Q: 'X  D
  5026   "RTN","PSI VLBL1",56, 0)
  5027    . K ^PS(5 5,"PSIVWL" ,PSIVSN,WR D,PSIVT_PS IVOD(PSIVT ),DFN,+ON, X)
  5028   "RTN","PSI VLBL1",57, 0)
  5029    F X=0:0 S  X=$O(PSIV ID(X)) Q:' X  D
  5030   "RTN","PSI VLBL1",58, 0)
  5031    . S ^PS(5 5,"PSIVWL" ,PSIVSN,WR D,PSIVT_PS IVOD(PSIVT ),DFN,+ON, X)=""
  5032   "RTN","PSI VLBL1",59, 0)
  5033    K PSIVWMF L,PSIVOID, PSIVID
  5034   "RTN","PSI VLBL1",60, 0)
  5035    Q
  5036   "RTN","PSI VLBL1",61, 0)
  5037   REPRT ; Re print labe ls using e xisting bc ma ID
  5038   "RTN","PSI VLBL1",62, 0)
  5039    S PSIVOID (PSJID)=""
  5040   "RTN","PSI VLBL1",63, 0)
  5041    NEW PSJLB  S XX=$G(^ PS(55,DFN, "IVBCMA",P SJID,0)) Q :XX=""
  5042   "RTN","PSI VLBL1",64, 0)
  5043    F X=1:1:9  S PSJLB(X )=$P(XX,U, X)
  5044   "RTN","PSI VLBL1",65, 0)
  5045    I $S(PSJL B(4)="C":1 ,PSJLB(4)= "G":1,PSJL B(4)="I":1 ,PSJLB(7)' ="":1,PSJL B(9):1,1:0 ) Q
  5046   "RTN","PSI VLBL1",66, 0)
  5047    S PSIVCTD =0,PSIVCT= 1,PSIVNOL= 1,P(4)=$P( ^PS(55,DFN ,"IV",+ON, 0),"^",4)
  5048   "RTN","PSI VLBL1",67, 0)
  5049    D REPRT^P SIVLBRP(DF N_"V"_PSJI D)
  5050   "RTN","PSI VLBL1",68, 0)
  5051    Q
  5052   "RTN","PSI VLBL1",69, 0)
  5053   MEOW ; Pri nt labels
  5054   "RTN","PSI VLBL1",70, 0)
  5055    S 
  5056   PSIVCT=1,P SIVNOL=+^P S(55,"PSIV WL",PSIVSN ,WRD,PSIVT _PSIVOD(PS IVT),DFN,+ ON),P16=$P (^(+ON),"^ "
  5057   ,3),PSIVDO SE=$P(^(+O N),"^",2)  I '$P(^(+O N),"^",4)  S $P(^(+ON ),"^",4)=1  K PSIVCT
  5058   "RTN","PSI VLBL1",71, 0)
  5059    I PSIVNOL =0 K PSIVD OSE,PSIVCT ,PSIVWMFL, PSIVID Q
  5060   "RTN","PSI VLBL1",72, 0)
  5061    N PSJSCH, PSJST,A,PS JOK
  5062   "RTN","PSI VLBL1",73, 0)
  5063    S PSJSCH= $P(^PS(55, DFN,"IV",+ ON,0),"^", 9),PSJST=$ $ONE^PSJBC MA(DFN,ON, PSJSCH)
  5064   "RTN","PSI VLBL1",74, 0)
  5065    S PSJOK=1  I PSJST=" O" S A=0 F   S A=$O(^ PS(55,DFN, "IV",+ON," LAB",A)) Q :A=""  I $ P($G(^(A,0 )),"^",3)=
  5066   S PSJOK=0  Q
  5067   "RTN","PSI VLBL1",75, 0)
  5068    Q:'PSJOK
  5069   "RTN","PSI VLBL1",76, 0)
  5070    Q:"HOD"[$ P(^PS(55,D FN,"IV",+O N,0),"^",1 7)
  5071   "RTN","PSI VLBL1",77, 0)
  5072    I $O(^PS( 55,"PSIVWL ",PSIVSN,W RD,PSIVT_P SIVOD(PSIV T),DFN,ON, 0)) D  Q
  5073   "RTN","PSI VLBL1",78, 0)
  5074    . S NOFLG =0,PSJRPFL G=1
  5075   "RTN","PSI VLBL1",79, 0)
  5076    S PSIVWMF L=1
  5077   "RTN","PSI VLBL1",80, 0)
  5078    S IONOFF= "",P(4)=$P (^PS(55,DF N,"IV",+ON ,0),"^",4) ,ACTION=1, TRACK=2 D  ^PSIVLTR D  
  5079   ^PSIVHYPL: P(4)="H",^ PSIVLABL:" APSC"[P(4)
  5080   "RTN","PSI VLBL1",81, 0)
  5081    I $D(PSIV ID) S X=0  F  S X=$O( PSIVID(X))  Q:'X  D
  5082   "RTN","PSI VLBL1",82, 0)
  5083    . S ^PS(5 5,"PSIVWL" ,PSIVSN,WR D,PSIVT_PS IVOD(PSIVT ),DFN,ON,X )=""
  5084   "RTN","PSI VLBL1",83, 0)
  5085    S NOFLG=0
  5086   "RTN","PSI VLBL1",84, 0)
  5087    K PSIVDOS E,PSIVCT,P SIVWMFL,PS IVID Q
  5088   "RTN","PSI VLBL1",85, 0)
  5089    ;
  5090   "RTN","PSI VLBL1",86, 0)
  5091   QUE S ZTIO =PSIVPL,ZT DESC="PRIN T SCHEDULE D IV 
  5092   LABELS",ZT RTN="DEQ^P SIVLBL1",P SIVT="",ZT SAVE("PSJS YSP0")=""
  5093   "RTN","PSI VLBL1",87, 0)
  5094    F I=0:0 S  PSIVT=$O( PSIVMT(PSI VT)) Q:PSI VT=""  S 
  5095   (ZTSAVE("P SIVCD("""_ PSIVT_""") "),ZTSAVE( "PSIVMT("" "_PSIVT_"" ")"),ZTSAV E("PSIVOD( """_PSIVT_ """)"))
  5096   =""
  5097   "RTN","PSI VLBL1",88, 0)
  5098    F X="PSIV SN","PSIVS ITE","PSJS YSW0","PSJ SYSU","ION OFF" S ZTS AVE(X)=""
  5099   "RTN","PSI VLBL1",89, 0)
  5100    D ^%ZTLOA D W:$D(ZTS K) !,"Queu ed." Q
  5101   "RTN","PSI VLBL1",90, 0)
  5102    ;
  5103   "RTN","PSI VLBL1",91, 0)
  5104   ENLBLI ;Pr int indivi dual label s.
  5105   "RTN","PSI VLBL1",92, 0)
  5106    D FULL^VA LM1
  5107   "RTN","PSI VLBL1",93, 0)
  5108    S PSJORD= ON D ENNH^ PSIVORV2(O N)
  5109   "RTN","PSI VLBL1",94, 0)
  5110    I ON'["V"  W !!,$C(7 ),$C(7),"Y ou may not  print lab els for a  pending or der." W !  K DIR S DI R(0)="E" D  ^DIR 
  5111   K DIR G Q
  5112   "RTN","PSI VLBL1",95, 0)
  5113   A1 ;
  5114   "RTN","PSI VLBL1",96, 0)
  5115    I "EDP"[$ P(^PS(55,D FN,"IV",+O N,0),U,17)  W !,$C(7) ,$C(7),"WA RNING, thi s order is  not 
  5116   active.",! ,"Continue " S %=2 D  YN^DICN G: %=2!(%=-1)  Q G:%=0 A 1
  5117   "RTN","PSI VLBL1",97, 0)
  5118    D PAUSE^V ALM1
  5119   "RTN","PSI VLBL1",98, 0)
  5120    S PSIVLBT P=1,PSJMOR E=0 D EN^V ALM("PSJ L M IV LABEL S") G Q
  5121   "RTN","PSI VLBL1",99, 0)
  5122   LBLBEG R ! !,"Number  of labels  to print:  ",X:DTIME  Q:'$T!("^" [X)  S:X[" ?" HELP="N OL" D:X["? " ^PSIVHLP
  5123   G:X["?" LB LBEG K:X'= +X!(X>10)! (X<1)!(X?. E1"."1N.N)  X W:'$D(X ) $C(7),$C (7),"??" G :'$D(X) LB LBEG S 
  5124   PSIVNOL=+X ,PSIVCT=1
  5125   "RTN","PSI VLBL1",100 ,0)
  5126    ;
  5127   "RTN","PSI VLBL1",101 ,0)
  5128   USAGE ;
  5129   "RTN","PSI VLBL1",102 ,0)
  5130    W !,"Coun t as daily  usage" S  %=1 D YN^D ICN G:%=-1  Q K:%=1 P SIVCT I %= 0 S HELP=" NCILBL" D 
  5131   ^PSIVHLP1  G USAGE
  5132   "RTN","PSI VLBL1",103 ,0)
  5133    S P16=$S( '$D(PSIVCT ):$P(^PS(5 5,DFN,"IV" ,+ON,0),"^ ",16),1:0)  S:'$D(PSI VCT) $P(^( 0),"^",16) =P16+X
  5134   "RTN","PSI VLBL1",104 ,0)
  5135    S IONOFF= "",IOP=PSI VPL,%ZIS=" NQ" D ^%ZI S G:POP Q  I IO=IO(0) ,($E(IOST) ="C") W !! ! D DEQIA, Q D 
  5136   HOME^%ZIS  Q
  5137   "RTN","PSI VLBL1",105 ,0)
  5138    D HOME^%Z IS
  5139   "RTN","PSI VLBL1",106 ,0)
  5140    W ! S ZTD TH=$H,ZTIO =PSIVPL,ZT DESC="PRIN T INDIVIDU AL IV LABE LS",ZTRTN= "DEQIA^PSI VLBL1" F 
  5141   X="IONOFF" ,"P16","PS IVAC","PSI VNOL","PSI VSN","PSIV SITE","DFN ","ON","PS JSYSW0","P SJSYSU","P SJSY
  5142   SP0" S ZTS AVE(X)=""
  5143   "RTN","PSI VLBL1",107 ,0)
  5144    S:$D(PSIV CT) ZTSAVE ("PSIVCT") ="" D ^%ZT LOAD W:$D( ZTSK) !,"Q ueued."
  5145   "RTN","PSI VLBL1",108 ,0)
  5146   Q ;K 
  5147   %,IONOFF,O N,ORNS,ORP V,ORSTOP,O RSTRT,ORST S,ORVP,P,P SIVC,PSIVR EA,J,N,N2, ORIFN,P17, SCHED,PSI
  5148   VDOSE,PSIV NOL,PSIVNO W,VAERR
  5149   "RTN","PSI VLBL1",109 ,0)
  5150    K 
  5151   %,IONOFF,O RNS,ORPV,O RSTOP,ORST RT,ORSTS,O RVP,PSIVC, PSIVREA,J, N,N2,ORIFN ,P17,SCHED ,PSIVDOSE
  5152   ,PSIVNOL,P SIVNOW,VAE RR
  5153   "RTN","PSI VLBL1",110 ,0)
  5154    Q
  5155   "RTN","PSI VLBL1",111 ,0)
  5156   DEQIA ;
  5157   "RTN","PSI VLBL1",112 ,0)
  5158    K PSIVDOS E S P(4)=$ P(^PS(55,D FN,"IV",+O N,0),"^",4 )
  5159   "RTN","PSI VLBL1",113 ,0)
  5160    S ACTION= 1,TRACK=1  D ^PSIVLTR
  5161   "RTN","PSI VLBL1",114 ,0)
  5162    S X="VEFS KCIV" X ^% ZOSF("TEST ") I $TEST  D  ;check  for Scrip tPro inter face PSJ*5 .0*332
  5163   "RTN","PSI VLBL1",115 ,0)
  5164    . S (VEFS PRT,VEFSIV P)=1,ROU=" NEW^VEFSKC IV" D @ROU  K ROU
  5165   "RTN","PSI VLBL1",116 ,0)
  5166    . S (VEFS PRT,VEFSIV P)=""
  5167   "RTN","PSI VLBL1",117 ,0)
  5168    . I $G(^V EFSAL6("R" ))=Q S ^VE FSALG6(DFN ,ON,"DEQIA  PRIVLBL1" )=$H
  5169   "RTN","PSI VLBL1",118 ,0)
  5170    ;
  5171   "RTN","PSI VLBL1",119 ,0)
  5172    D ^PSIVHY PL:P(4)="H ",^PSIVLAB L:"APSC"[P (4) S:$D(Z TQUEUED) Z TREQ="@"
  5173   "RTN","PSI VLBL1",120 ,0)
  5174    Q
  5175   "RTN","PSI VLBL1",121 ,0)
  5176   DESC(X) ;E xpand the  IV type.
  5177   "RTN","PSI VLBL1",122 ,0)
  5178    NEW XX,Y, DESC,X1,X2  S Y=$$COD ES^PSIVUTL (X,55.01,. 04)
  5179   "RTN","PSI VLBL1",123 ,0)
  5180    S XX="*** NO "_Y_" D ATA***"
  5181   "RTN","PSI VLBL1",124 ,0)
  5182    NEW MARX  D TXT^PSGM UTL(XX,$P( PSIVSITE,U ,13))
  5183   "RTN","PSI VLBL1",125 ,0)
  5184    F XX=1:1: (+PSIVSITE +$P(PSIVSI TE,U,16))   W:XX>2 $G (MARX(XX-2 )) W !
  5185   "RTN","PSI VLBL1",126 ,0)
  5186    Q
  5187   "RTN","PSI VLBRP")
  5188   0^7^B19569 747^B15941 220
  5189   "RTN","PSI VLBRP",1,0 )
  5190   PSIVLBRP ; BIR/MV - R EPRINT LAB ELS FOR AN  ORDER ; 0 6 Nov 2017   8:48 AM
  5191   "RTN","PSI VLBRP",2,0 )
  5192    ;;5.0;INP ATIENT MED ICATIONS;* *58,97,250 ,332**;16  DEC 97;Bui ld 8
  5193   "RTN","PSI VLBRP",3,0 )
  5194    ;
  5195   "RTN","PSI VLBRP",4,0 )
  5196    ; Referen ce to ^PS( 55 is supp orted by D BIA 2191.
  5197   "RTN","PSI VLBRP",5,0 )
  5198    ;
  5199   "RTN","PSI VLBRP",6,0 )
  5200   EN(PSJIDLS T) ;
  5201   "RTN","PSI VLBRP",7,0 )
  5202    I '$D(PSJ IDLST) W ! ,"No label s are avai lable" D P AUSE^VALM1  Q
  5203   "RTN","PSI VLBRP",8,0 )
  5204    NEW DIR,P SIVCTD
  5205   "RTN","PSI VLBRP",9,0 )
  5206    S PSIVCT= 1
  5207   "RTN","PSI VLBRP",10, 0)
  5208    W !!,"Cou nt as dail y usage" S  %=1 D YN^ DICN Q:%=- 1  S PSIVC TD=$S(%=1: 1,1:0)
  5209   "RTN","PSI VLBRP",11, 0)
  5210    I PSIVCTD =1 K PSIVC T
  5211   "RTN","PSI VLBRP",12, 0)
  5212    S PSJY=$$ PROMPT()
  5213   "RTN","PSI VLBRP",13, 0)
  5214    Q:PSJY=""
  5215   "RTN","PSI VLBRP",14, 0)
  5216    ;*PSJ*5*2 50
  5217   "RTN","PSI VLBRP",15, 0)
  5218    N PSJSEL, PSJSEL1,PS JID,PSJSOL ,PSJSOLERR ,PSJERRLST
  5219   "RTN","PSI VLBRP",16, 0)
  5220    S PSJERRL ST=""
  5221   "RTN","PSI VLBRP",17, 0)
  5222    F PSJSEL= 1:1 S PSJS EL1=$P(PSJ Y,",",PSJS EL) Q:PSJS EL1=""  D
  5223   "RTN","PSI VLBRP",18, 0)
  5224    . S PSJID =$G(PSJIDL ST(PSJSEL1 )) Q:PSJID =""
  5225   "RTN","PSI VLBRP",19, 0)
  5226    . S PSJID NO=$P(PSJI D,"V",2)
  5227   "RTN","PSI VLBRP",20, 0)
  5228    . F PSJSO L=0:0 S PS JSOL=$O(^P S(55,DFN," IVBCMA",PS JIDNO,"SOL ",PSJSOL))  Q:'PSJSOL   D
  5229   "RTN","PSI VLBRP",21, 0)
  5230    . . I $G( ^PS(55,DFN ,"IVBCMA", PSJIDNO,"S OL",PSJSOL ,0))'=$G(^ PS(55,DFN, "IV",+ON," SOL",PSJSO L,0)) S 
  5231   PSJSOLERR= 1,PSJERRLS T=PSJERRLS T_$S(PSJER RLST="":PS JID,1:", " _PSJID)
  5232   "RTN","PSI VLBRP",22, 0)
  5233    I $G(PSJS OLERR) D F ULL^VALM1  S DIR("A", 1)="Soluti on on labe l(s) "_PSJ ERRLST_" d oes not ma tch 
  5234   current or der." S DI R("A")="En ter RETURN  to contin ue" S DIR( 0)="FO" D  ^DIR Q
  5235   "RTN","PSI VLBRP",23, 0)
  5236    ;*END PSJ *5*250
  5237   "RTN","PSI VLBRP",24, 0)
  5238    D PRT
  5239   "RTN","PSI VLBRP",25, 0)
  5240    Q
  5241   "RTN","PSI VLBRP",26, 0)
  5242   PROMPT() ;
  5243   "RTN","PSI VLBRP",27, 0)
  5244    W !
  5245   "RTN","PSI VLBRP",28, 0)
  5246    S DIR(0)= "LOA^1:"_P SJIDLST,DI R("A")="Se lect from  1 - "_PSJI DLST_" or  <RETURN> t o select b y BCMA ID:  
  5247   " D ^DIR
  5248   "RTN","PSI VLBRP",29, 0)
  5249    K DIR
  5250   "RTN","PSI VLBRP",30, 0)
  5251    S PSJY=Y
  5252   "RTN","PSI VLBRP",31, 0)
  5253    I PSJY=""  S DIR(0)= "FOA^1:50^ S X=$$UP^X LFSTR(X) K :'$D(PSJID LST(X)) X" ,DIR("A")= "Enter a B CMA ID: " 
  5254   D ^DIR S P SJY=$$UP^X LFSTR(Y)
  5255   "RTN","PSI VLBRP",32, 0)
  5256    K DIR
  5257   "RTN","PSI VLBRP",33, 0)
  5258    W !!
  5259   "RTN","PSI VLBRP",34, 0)
  5260    Q PSJY
  5261   "RTN","PSI VLBRP",35, 0)
  5262   DEQIA ;
  5263   "RTN","PSI VLBRP",36, 0)
  5264    S PSIVNOL =0
  5265   "RTN","PSI VLBRP",37, 0)
  5266    F PSJSEL= 1:1 S PSJS EL1=$P(PSJ Y,",",PSJS EL) Q:PSJS EL1=""  S  PSIVNOL=PS IVNOL+1
  5267   "RTN","PSI VLBRP",38, 0)
  5268    F PSJSEL= 1:1 S PSJS EL1=$P(PSJ Y,",",PSJS EL) Q:PSJS EL1=""  D
  5269   "RTN","PSI VLBRP",39, 0)
  5270    . S:'PSIV CTD PSIVCT =1
  5271   "RTN","PSI VLBRP",40, 0)
  5272    . S PSJID =$G(PSJIDL ST(PSJSEL1 )) Q:PSJID =""  D REP RT(PSJID)
  5273   "RTN","PSI VLBRP",41, 0)
  5274    K PSJRPHD
  5275   "RTN","PSI VLBRP",42, 0)
  5276    Q
  5277   "RTN","PSI VLBRP",43, 0)
  5278   REPRT(PSJI D) ;
  5279   "RTN","PSI VLBRP",44, 0)
  5280    S PSJNEWI D=$$BCMA^P SIVBCID(DF N,ON,$D(PS IVCT),$G(P SIV1),$G(P SIV2),$G(P SIVNOL))
  5281   "RTN","PSI VLBRP",45, 0)
  5282    I PSJNEWI D="" W !," Can't get  a new BCMA  ID.  Try  again" Q
  5283   "RTN","PSI VLBRP",46, 0)
  5284    S PSJIDNO =$P(PSJID, "V",2)
  5285   "RTN","PSI VLBRP",47, 0)
  5286    S PSIVBAG =$P($G(^PS (55,DFN,"I VBCMA",PSJ IDNO,0)),U ,8)
  5287   "RTN","PSI VLBRP",48, 0)
  5288    N DA,DR,D IE,DIC
  5289   "RTN","PSI VLBRP",49, 0)
  5290    ;S DIC(0) ="L",DA=Y, DA(1)=DFN, X=PSJNEWID ,DIC="^PS( 55,"_DA(1) _",""IVBCM A""," D FI LE^DICN
  5291   "RTN","PSI VLBRP",50, 0)
  5292    K DA,DR,D IE S DIE=" ^PS(55,"_D FN_",""IVB CMA"",",DA =$P(PSJNEW ID,"V",2), DA(1)=DFN  D NOW^%DTC
  5293   "RTN","PSI VLBRP",51, 0)
  5294    ;S DR=".0 2////"_+ON _";3////"_ PSIVCTD_"; 4////"_$E( %,1,12)_"; 6////"_PSI VBAG D ^DI E
  5295   "RTN","PSI VLBRP",52, 0)
  5296    S DR="6// //"_PSIVBA G D ^DIE
  5297   "RTN","PSI VLBRP",53, 0)
  5298    K DA,DR,D IE,DIC
  5299   "RTN","PSI VLBRP",54, 0)
  5300    S PSJNEWI D=$P(PSJNE WID,"V",2)
  5301   "RTN","PSI VLBRP",55, 0)
  5302    F PSJAD=0 :0 S PSJAD =$O(^PS(55 ,DFN,"IVBC MA",PSJIDN O,"AD",PSJ AD)) Q:'PS JAD  D
  5303   "RTN","PSI VLBRP",56, 0)
  5304    . S PSJAD X=$G(^PS(5 5,DFN,"IVB CMA",PSJID NO,"AD",PS JAD,0))
  5305   "RTN","PSI VLBRP",57, 0)
  5306    . D UP2^P SIVBCID(DF N,PSJNEWID ,PSJAD,PSJ ADX)
  5307   "RTN","PSI VLBRP",58, 0)
  5308    F PSJSOL= 0:0 S PSJS OL=$O(^PS( 55,DFN,"IV BCMA",PSJI DNO,"SOL", PSJSOL)) Q :'PSJSOL   D
  5309   "RTN","PSI VLBRP",59, 0)
  5310    . S PSJSO LX=$G(^PS( 55,DFN,"IV BCMA",PSJI DNO,"SOL", PSJSOL,0))
  5311   "RTN","PSI VLBRP",60, 0)
  5312    . D UP3^P SIVBCID(DF N,PSJNEWID ,PSJSOL,PS JSOLX)
  5313   "RTN","PSI VLBRP",61, 0)
  5314    K DA,DR,D IE,DIC
  5315   "RTN","PSI VLBRP",62, 0)
  5316    S DA=PSJI DNO,DA(1)= DFN,DIE="^ PS(55,"_DA (1)_",""IV BCMA"","
  5317   "RTN","PSI VLBRP",63, 0)
  5318    S DR="5// //RP" D ^D IE
  5319   "RTN","PSI VLBRP",64, 0)
  5320    K DA,DR,D IE,DIC
  5321   "RTN","PSI VLBRP",65, 0)
  5322    D ^PSIVHY PR:P(4)="H ",^PSIVLAB R:"APSC"[P (4) S:$D(Z TQUEUED) Z TREQ="@"
  5323   "RTN","PSI VLBRP",66, 0)
  5324    ;PSJRPHD  is defined  so ^PSIVL ABR won't  print the  header for  sub-label s.
  5325   "RTN","PSI VLBRP",67, 0)
  5326    S PSJRPHD =1
  5327   "RTN","PSI VLBRP",68, 0)
  5328    S X="VEFS KCIV" X ^% ZOSF("TEST ") I $TEST  D  ;check  for Scrip tPro inter face PSJ*5 .0*332
  5329   "RTN","PSI VLBRP",69, 0)
  5330    . S (VEFS PRT,VEFSIV P)=1 N XX  S XX="NEW^ VEFSKCIV"  D @XX
  5331   "RTN","PSI VLBRP",70, 0)
  5332    . S (VEFS PRT,VEFSIV P)=""
  5333   "RTN","PSI VLBRP",71, 0)
  5334    . I $G(^V EFSAL6("R" ))=Q S ^VE FSALG6(DFN ,ON,"DEQIA  PRIVLBL1" )=$H
  5335   "RTN","PSI VLBRP",72, 0)
  5336    ;
  5337   "RTN","PSI VLBRP",73, 0)
  5338    ;If repri nting from  war/man l ist, store  new BCMA  ID.
  5339   "RTN","PSI VLBRP",74, 0)
  5340    S:$G(PSIV WMFL) PSIV ID(PSJNEWI D)=""
  5341   "RTN","PSI VLBRP",75, 0)
  5342    Q
  5343   "RTN","PSI VLBRP",76, 0)
  5344   PRT ;
  5345   "RTN","PSI VLBRP",77, 0)
  5346    S X="VEFS KCIV" X ^% ZOSF("TEST ") I $TEST  D  ;check  for Scrip tPro inter face PSJ*5 .0*332
  5347   "RTN","PSI VLBRP",78, 0)
  5348    . S (VEFS PRT,VEFSIV P)=1 N XX  S XX="NEW^ VEFSKCIV"  D @XX
  5349   "RTN","PSI VLBRP",79, 0)
  5350    . S (VEFS PRT,VEFSIV P)=""
  5351   "RTN","PSI VLBRP",80, 0)
  5352    . I $G(^V EFSAL6("R" ))=Q S ^VE FSALG6(DFN ,ON,"DEQIA  PRIVLBL1" )=$H
  5353   "RTN","PSI VLBRP",81, 0)
  5354    ;
  5355   "RTN","PSI VLBRP",82, 0)
  5356    S IONOFF= "",IOP=PSI VPL,%ZIS=" NQ" D ^%ZI S G:POP Q  I IO=IO(0) ,($E(IOST) ="C") W !! ! D DEQIA, Q D 
  5357   HOME^%ZIS  Q
  5358   "RTN","PSI VLBRP",83, 0)
  5359    D HOME^%Z IS
  5360   "RTN","PSI VLBRP",84, 0)
  5361    W ! S ZTD TH=$H,ZTIO =PSIVPL,ZT DESC="REPR INT INDIVI DUAL IV LA BELS",ZTRT N="DEQIA^P SIVLBRP" F  
  5362   X="IONOFF" ,"P16","PS IVAC","PSI VSN","PSIV SITE","DFN ","ON","PS JSYSW0","P SJSYSU","P SJSYSP0"," PSJID
  5363   LST(","P(" ,"PSJY","P SIVCTD" S  ZTSAVE(X)= ""
  5364   "RTN","PSI VLBRP",85, 0)
  5365    S:$D(PSIV CT) ZTSAVE ("PSIVCT") ="" D ^%ZT LOAD W:$D( ZTSK) !,"Q ueued."
  5366   "RTN","PSI VLBRP",86, 0)
  5367    Q
  5368   "RTN","PSI VLBRP",87, 0)
  5369   Q ;
  5370   "RTN","PSI VLBRP",88, 0)
  5371    Q
  5372   "RTN","PSI VORLB")
  5373   0^26^B1653 1182^B1655 4015
  5374   "RTN","PSI VORLB",1,0 )
  5375   PSIVORLB ; BIR/MLM-PR INT OUT LA BELS ; 25  Jan 2019   8:40 AM
  5376   "RTN","PSI VORLB",2,0 )
  5377    ;;5.0;INP ATIENT MED ICATIONS;* *58,184,27 9,332**;16  DEC 97;Bu ild 8
  5378   "RTN","PSI VORLB",3,0 )
  5379    ;
  5380   "RTN","PSI VORLB",4,0 )
  5381    ; Referen ce to ^PS( 52.6 is su pported by  DBIA 1231 .
  5382   "RTN","PSI VORLB",5,0 )
  5383    ; Referen ce to ^PS( 52.7 is su pported by  DBIA 2173 .
  5384   "RTN","PSI VORLB",6,0 )
  5385    ;
  5386   "RTN","PSI VORLB",7,0 )
  5387   ENX ;Print  example l abel
  5388   "RTN","PSI VORLB",8,0 )
  5389    I ($G(VAI N(4))="")  D CLINIC^P SIVOREN
  5390   "RTN","PSI VORLB",9,0 )
  5391    D FULL^VA LM1
  5392   "RTN","PSI VORLB",10, 0)
  5393    S PSIVFLA G=1,PSIVRM =$P(PSIVSI TE,U,13) S :PSIVRM<1  PSIVRM=30  D:$E(P("OT "))="I" OR FLDS^PSIVE DT1 
  5394   W:$E(P("OT "))'="I" ! ,"Med Rout e: ",$P(P( "MR"),U,2) ,!
  5395   "RTN","PSI VORLB",11, 0)
  5396   START F PS IV1=1:1:PS IVNOL S LI NE=0 D RE  I '$D(PSIV FLAG) F 
  5397   LINE=LINE+ 1:1:(PSIVS ITE+$P(PSI VSITE,U,16 )) W !
  5398   "RTN","PSI VORLB",12, 0)
  5399   Q K 
  5400   PSIVDOSE,P 16,LINE,ME SS,PSIVCT, PSIV2,PSIV FLAG,PSIVR M,PSIV1,PD OSE,PDATE, XX1,XX2,BA G,CX,PSIME S
  5401   S,PSIVCLAB  Q
  5402   "RTN","PSI VORLB",13, 0)
  5403   RE ;
  5404   "RTN","PSI VORLB",14, 0)
  5405    D:'$D(VAD M(2)) DEM^ VADPT
  5406   "RTN","PSI VORLB",15, 0)
  5407    I PSIV1,P (4)="A"!(P (5)=0) S:P (15)>2880! ('P(15)) P (15)=2880  S P(16)=P1 6+PSIV1#(1 440/P(15)+ .5\1) 
  5408   S:'P(16) P (16)=1440/ P(15)+.5\1
  5409   "RTN","PSI VORLB",16, 0)
  5410    W DFN,!
  5411   "RTN","PSI VORLB",17, 0)
  5412    N PSIVCLI N,PSIVCLDT  S 
  5413   PSIVCLIN=$ S($G(P("CL IN")):P("C LIN"),($G( ON55)["V") :+$G(^PS(5 5,DFN,"IV" ,+ON55,"DS S")),($G(O N55)["P
  5414   "):+$G(^PS (53.1,+ON5 5,"DSS")), 1:"") S:'( PSIVCLIN>0 ) PSIVCLIN ="" I PSIV CLIN D
  5415   "RTN","PSI VORLB",18, 0)
  5416    .S PSIVCL DT=$P(PSIV CLIN,"^",2 ) S $P(PSI VCLIN,"^", 2)=$P($G(^ SC(+PSIVCL IN,0)),"^" )
  5417   "RTN","PSI VORLB",19, 0)
  5418    I $G(PSIV CLIN) N PS IVCLAB S P SIVCLAB=$P ($G(^SC(+P SIVCLIN,0) ),"^",2)
  5419   "RTN","PSI VORLB",20, 0)
  5420    S X=$S(P( "PON")["V" :"["_+P("P ON")_"]",1 :"")_$P($P (VADM(2),U ,2),"-",3)  D
  5421   "RTN","PSI VORLB",21, 0)
  5422    .S X=X_"   
  5423   "_$S($G(PS IVCLIN)&($ G(PSIVCLAB )]""):PSIV CLAB,$G(PS IVCLIN)&($ P(PSIVCLIN ,"^",2)'=" "):$P(PSIV CLIN,"^"
  5424   ,2),+VAIN( 4):$P(VAIN (4),U,2),1 :" *OPT*") _"  "_$E(D T,4,5)_"/" _$E(DT,6,7 )_"/"_$E(D T,2,3)
  5425   "RTN","PSI VORLB",22, 0)
  5426    D P
  5427   "RTN","PSI VORLB",23, 0)
  5428    S X=VADM( 1) S:$P(PS IVSITE,U,9 ) X=X_"  " _$S(VAIN(5 )]"":VAIN( 5),1:"NF")  D P S X="  " D P
  5429   "RTN","PSI VORLB",24, 0)
  5430    I $D(PSIV FLAG) F PS IV=0:0 S P SIV=$O(DRG ("AD",PSIV )) Q:'PSIV   S 
  5431   Y=DRG("AD" ,PSIV),X=$ S($P(Y,U,2 )]"":$P(Y, U,2),1:"** *******")_ " "_$P(Y,U ,3)_" " S: $P(Y,U,4)] "" X=X_" 
  5432   ("_$P(Y,U, 4)_")" D P ,MESS
  5433   "RTN","PSI VORLB",25, 0)
  5434    G:$D(PSIV FLAG) SOL
  5435   "RTN","PSI VORLB",26, 0)
  5436    F PSIV=0: 0 S PSIV=$ O(DRG("AD" ,PSIV)) Q: 'PSIV  S 
  5437   Y=DRG("AD" ,PSIV),X=$ S($P(Y,U,2 )]"":$P(Y, U,2),1:"** ******")_"  "_$P(Y,U, 3) I 
  5438   ","_$P(Y,U ,4)_","[(" ,"_P(16)_" ,")!('$P(Y ,U,4)) D P ,MESS
  5439   "RTN","PSI VORLB",27, 0)
  5440   SOL F PSIV =0:0 S PSI V=$O(DRG(" SOL",PSIV) ) Q:'PSIV   S Y=DRG(" SOL",PSIV)  D SOL1,P 
  5441   X=$P(^PS(5 2.7,+$P(Y, U),0),U,4)  I X]"" S  X="   "_X  D P
  5442   "RTN","PSI VORLB",28, 0)
  5443    I P(23)'= ""!(P(4)=" S") S X="I n Syringe:  "_$E(P("S YRS"),1,25 ) D:P(4)=" S"!(P(23)= "S") P S X ="*CAUTION * - 
  5444   CHEMOTHERA PY" D:P(23 )'="" P
  5445   "RTN","PSI VORLB",29, 0)
  5446    S X=" " D  P I 
  5447   PSIV1'>0!' $P(PSIVSIT E,U,3)!($P (PSIVSITE, U,3)=1&(P( 4)'="P"))! ($P(PSIVSI TE,U,3)=2& ("AH"'[P(4 ))) G INF
  5448   "RTN","PSI VORLB",30, 0)
  5449    S:'$D(PSI VDOSE) PSI VDOSE="" S  X=$P(PSIV DOSE," ",P SIV1) D:$E (X)="." CO NVER S X=" Dose due a t: 
  5450   "_$S(X="": "________" ,1:$E(X,4, 5)_"/"_$E( X,6,7)_"/" _$E(X,2,3) _" "_$E(X# 1_"000",2, 5)) D P
  5451   "RTN","PSI VORLB",31, 0)
  5452   INF S X=$P (P(8),"@")  D:X]"" P  I P("OPI") ]"" S X=$P (P("OPI"), "^") D P
  5453   "RTN","PSI VORLB",32, 0)
  5454    S X=P(9)  D:X]"" P
  5455   "RTN","PSI VORLB",33, 0)
  5456    S X=P(11)  D:X]"" P
  5457   "RTN","PSI VORLB",34, 0)
  5458    ; PSJ*5*1 84 - Displ ay all mes sages if m ore than o ne additiv e has a me ssage.
  5459   "RTN","PSI VORLB",35, 0)
  5460    I $D(MESS ) S PSIMES S="" F  S  PSIMESS=$O (MESS(PSIM ESS)) Q:PS IMESS=""   S X=PSIMES S D P
  5461   "RTN","PSI VORLB",36, 0)
  5462    I $D(^PS( 59.5,PSIVS N,4)) S Y= ^(4) F PSI V=1:1 S X= $P(Y,U,PSI V) Q:X=""   D P
  5463   "RTN","PSI VORLB",37, 0)
  5464    S X=PSIV1 _"["_PSIVN OL_"]" D P
  5465   "RTN","PSI VORLB",38, 0)
  5466    Q
  5467   "RTN","PSI VORLB",39, 0)
  5468   P F LINE=L INE+1:1 X: LINE>+PSIV SITE "S LI NE=1 F ZZ= 1:1 Q:ZZ>$ P(PSIVSITE ,""^"",16)   W !" K Z Z W 
  5469   $E(X,1,PSI VRM),! S X =$E(X,PSIV RM+1,999)  Q:$L(X)<1
  5470   "RTN","PSI VORLB",40, 0)
  5471    Q
  5472   "RTN","PSI VORLB",41, 0)
  5473   SOL1 S X=$ S($P(Y,U,2 )]"":$P(Y, U,2)_" "_$ P(Y,U,3),1 :"******** **") Q
  5474   "RTN","PSI VORLB",42, 0)
  5475   MESS ; PSJ *5*184 - m ake MESS a  local arr ay so all  messages d isplay for  all addit ives.
  5476   "RTN","PSI VORLB",43, 0)
  5477    I $P(^PS( 52.6,+$P(Y ,U),0),U,9 )]"" S MES S($P(^PS(5 2.6,+$P(Y, U),0),U,9) )=""
  5478   "RTN","PSI VORLB",44, 0)
  5479    Q
  5480   "RTN","PSI VORLB",45, 0)
  5481   CONVER ;Ex pand dose  to date.do se and set  in X
  5482   "RTN","PSI VORLB",46, 0)
  5483    I P(15)>1 440 S X=$$ CONVER1^PS IVORE2($P( PSIVDOSE,"  "),P(15), (PSIV1-1))  Q
  5484   "RTN","PSI VORLB",47, 0)
  5485    S PDOSE=X  S:PSIV1=2  PDATE=$E( $P(PSIVDOS E," "),1,7 )
  5486   "RTN","PSI VORLB",48, 0)
  5487    I $P(PSIV DOSE," ",P SIV1-1)#1' <PDOSE!(P( 15)>1440)  S:$D(X1) X X1=X1 S:$D (X2) XX2=X 2 S X1=PDA TE,X2=1 
  5488   D C^%DTC S  PDATE=X,X =X_PDOSE S :$D(XX1) X 1=XX1 S:$D (XX2) X2=X X2 Q
  5489   "RTN","PSI VORLB",49, 0)
  5490    S X=PDATE _PDOSE
  5491   "RTN","PSI VORLB",50, 0)
  5492    Q
  5493   "RTN","PSJ DIN")
  5494   0^8^B46714 111^B38154 566
  5495   "RTN","PSJ DIN",1,0)
  5496   PSJDIN ;BI R/MV - Nat ional Form ulary Indi cator Util ity ; 02 O ct 2018  1 0:45 AM
  5497   "RTN","PSJ DIN",2,0)
  5498    ;;5.0;INP ATIENT MED ICATIONS;* *50,56,76, 227,289,33 2**;16 DEC  97;Build  8
  5499   "RTN","PSJ DIN",3,0)
  5500    ;
  5501   "RTN","PSJ DIN",4,0)
  5502    ; Referen ce to ^PSS DIN is sup ported by  DBIA# 3166 .
  5503   "RTN","PSJ DIN",5,0)
  5504    ; Referen ce to ^PS( 52.6 is su pported by  DBIA# 123 1.
  5505   "RTN","PSJ DIN",6,0)
  5506    ; Referen ce to ^PS( 52.7 is su pported by  DBIA# 217 3.
  5507   "RTN","PSJ DIN",7,0)
  5508    ; Referen ce to ^PS( 50.7 is su pported by  DBIA# 218 0.
  5509   "RTN","PSJ DIN",8,0)
  5510    ; Referen ce tp ^PSD RUG is sup ported by  DBIA# 2192 .
  5511   "RTN","PSJ DIN",9,0)
  5512    ;
  5513   "RTN","PSJ DIN",10,0)
  5514   DINIV(FIL, DRGTMP)       ;
  5515   "RTN","PSJ DIN",11,0)
  5516    ;*Find th e DD & OI  IEN for th e additive  or soluti on
  5517   "RTN","PSJ DIN",12,0)
  5518    ;*FIL:     52.6 or 5 2.7
  5519   "RTN","PSJ DIN",13,0)
  5520    ;*DRGTMP:  Additive  or Solutio n's IEN
  5521   "RTN","PSJ DIN",14,0)
  5522    ;
  5523   "RTN","PSJ DIN",15,0)
  5524    NEW PSJDR G,PSJOI,PS JDD,PSJDIN ,PSJINDEX
  5525   "RTN","PSJ DIN",16,0)
  5526    S PSJDRG= $P(^PS(FIL ,+DRGTMP,0 ),U,2),PSJ OI=$P(^PS( FIL,+DRGTM P,0),U,11)
  5527   "RTN","PSJ DIN",17,0)
  5528    D DIN(PSJ OI,PSJDRG)
  5529   "RTN","PSJ DIN",18,0)
  5530    Q
  5531   "RTN","PSJ DIN",19,0)
  5532   DIN(PSJOI, PSJDRG)        ;
  5533   "RTN","PSJ DIN",20,0)
  5534    ;*This wi ll issue t he Restric tion/guide line promp t for both  OI & DD
  5535   "RTN","PSJ DIN",21,0)
  5536    ;*PSJOI:    Orderabl e Item IEN
  5537   "RTN","PSJ DIN",22,0)
  5538    ;*PSJDRG:    Dispens e drug IEN
  5539   "RTN","PSJ DIN",23,0)
  5540    ;
  5541   "RTN","PSJ DIN",24,0)
  5542    NEW PSJDI N,PSJDD,PS JINDEX,Y,X ,XIT
  5543   "RTN","PSJ DIN",25,0)
  5544    D EN^PSSD IN(PSJOI,P SJDRG)
  5545   "RTN","PSJ DIN",26,0)
  5546    Q:$O(^TMP ("PSSDIN", $J,""))=""
  5547   "RTN","PSJ DIN",27,0)
  5548    S PSJDIN= $$PROMPT^P SSDIN
  5549   "RTN","PSJ DIN",28,0)
  5550    W:"DOY"[Y  @IOF
  5551   "RTN","PSJ DIN",29,0)
  5552    I PSJDIN= "D"!(PSJDI N="Y") D   Q:XIT=U
  5553   "RTN","PSJ DIN",30,0)
  5554    . W !!,"D ispense Dr ug Text:"  W ! D TXD( "DD") W !!
  5555   "RTN","PSJ DIN",31,0)
  5556    I PSJDIN= "O"!(PSJDI N="Y") D
  5557   "RTN","PSJ DIN",32,0)
  5558    . W !!,"O rderable I tem Text:"  W ! D TXD ("OI") W ! !
  5559   "RTN","PSJ DIN",33,0)
  5560    D PAUSE^V ALM1,CLEAR ^VALM1
  5561   "RTN","PSJ DIN",34,0)
  5562    Q
  5563   "RTN","PSJ DIN",35,0)
  5564   TXD(N1) ;
  5565   "RTN","PSJ DIN",36,0)
  5566    ;N1 = "OI " or "DD"
  5567   "RTN","PSJ DIN",37,0)
  5568    ;DISPLAY  OI/DD DRUG  TEXT
  5569   "RTN","PSJ DIN",38,0)
  5570    N N2,N3,N 4,NX S XIT ="",NX="PS SDIN"  ;
  5571   "RTN","PSJ DIN",39,0)
  5572    S N2="" F   S N2=$O( ^TMP(NX,$J ,N1,N2)) Q :'N2!(XIT= U)  D
  5573   "RTN","PSJ DIN",40,0)
  5574    .S N3=""  F  S N3=$O (^TMP(NX,$ J,N1,N2,N3 )) Q:'N3!( XIT=U)  D
  5575   "RTN","PSJ DIN",41,0)
  5576    ..S N4=""  F  S N4=$ O(^TMP(NX, $J,N1,N2,N 3,N4)) Q:' N4!(XIT=U)   D
  5577   "RTN","PSJ DIN",42,0)
  5578    ...W !?5, ^TMP(NX,$J ,N1,N2,N3, N4) I $Y>1 5 W ! D HL D S XIT=X
  5579   "RTN","PSJ DIN",43,0)
  5580    Q
  5581   "RTN","PSJ DIN",44,0)
  5582   HLD ;
  5583   "RTN","PSJ DIN",45,0)
  5584    W !
  5585   "RTN","PSJ DIN",46,0)
  5586    ;K DIR S  DIR(0)="E" ,DIR("A")= "Press Ret urn to Con tinue" D ^ DIR K DIR
  5587   "RTN","PSJ DIN",47,0)
  5588    K DIR
  5589   "RTN","PSJ DIN",48,0)
  5590    S DIR(0)= "E",DIR("A ")="Press  Return to  Continue o r ""^"" to  Exit: "
  5591   "RTN","PSJ DIN",49,0)
  5592    D ^DIR K  DIR
  5593   "RTN","PSJ DIN",50,0)
  5594    W @IOF
  5595   "RTN","PSJ DIN",51,0)
  5596    Q
  5597   "RTN","PSJ DIN",52,0)
  5598   NFIV(FIL,P SJIVIEN,PS JNF)         ;
  5599   "RTN","PSJ DIN",53,0)
  5600    ;*Return  N/F and ms g display  for ad/sol .
  5601   "RTN","PSJ DIN",54,0)
  5602    ;*FIL:    "AD" or "S OL"
  5603   "RTN","PSJ DIN",55,0)
  5604    ;*PSIVIEN : Additive  or Soluti on's IEN
  5605   "RTN","PSJ DIN",56,0)
  5606    ;*PSJNF:    0 node f rom file 5 0
  5607   "RTN","PSJ DIN",57,0)
  5608    ;*PSJNF(" NF"):  Onl y exist if  it is a N on-formula ry
  5609   "RTN","PSJ DIN",58,0)
  5610    ;*PSJNF(" MSG"): Ret urn the me ssage fiel d to be di splayed /w  IV names
  5611   "RTN","PSJ DIN",59,0)
  5612    ;
  5613   "RTN","PSJ DIN",60,0)
  5614    S PSJNF=$ G(^PSDRUG( +$P($G(^PS (FIL,+PSJI VIEN,0)),U ,2),0))
  5615   "RTN","PSJ DIN",61,0)
  5616    S PSJNF(" NF")=$S($P (PSJNF,U,9 )=1:" *N/F *",1:"")
  5617   "RTN","PSJ DIN",62,0)
  5618    S PSJNF(" MSG")=$P(P SJNF,U,10)
  5619   "RTN","PSJ DIN",63,0)
  5620    Q
  5621   "RTN","PSJ DIN",64,0)
  5622   DINFLIV(DR G)   ;
  5623   "RTN","PSJ DIN",65,0)
  5624    ;*This mo dule will  find all d rug text t hat exist  for the Or derable 
  5625   "RTN","PSJ DIN",66,0)
  5626    ;*Items &  dispense  drugs asso ciated wit h the Addi tive(s) &  Solution(s )
  5627   "RTN","PSJ DIN",67,0)
  5628    ;*within  the IV ord er.  Once  a drug tex t exist, r eturn the  <DIN> 
  5629   "RTN","PSJ DIN",68,0)
  5630    ;*indicat or to be d isplayed w ithin the  order view .
  5631   "RTN","PSJ DIN",69,0)
  5632    ;
  5633   "RTN","PSJ DIN",70,0)
  5634    ;*DRG:  D rug array  from the I V order
  5635   "RTN","PSJ DIN",71,0)
  5636    NEW PSJFI L,PSJND,PS JX,PSJFL
  5637   "RTN","PSJ DIN",72,0)
  5638    F PSJFIL= "AD","SOL"  F PSJND=0 :0 S PSJND =$O(DRG(PS JFIL,PSJND )) Q:'PSJN D!$G(PSJFL )  D
  5639   "RTN","PSJ DIN",73,0)
  5640    . S PSJX= $G(^PS($S( PSJFIL="AD ":52.6,1:5 2.7),+DRG( PSJFIL,PSJ ND),0)) D 
  5641   EN^PSSDIN( $P(PSJX,U, 11),$P(PSJ X,U,2))
  5642   "RTN","PSJ DIN",74,0)
  5643    . I $O(^T MP("PSSDIN ",$J,""))] "" S PSJFL =1 Q
  5644   "RTN","PSJ DIN",75,0)
  5645    I '$G(PSJ FL),$G(PSJ ORD)["P" S  PSJFL=$$D INFLUD(+P( "PD")),PSJ FL=$S(PSJF L]"":1,1:0 )
  5646   "RTN","PSJ DIN",76,0)
  5647    K ^TMP("P SSDIN",$J)
  5648   "RTN","PSJ DIN",77,0)
  5649    Q $S($G(P SJFL):" <D IN>",1:"")
  5650   "RTN","PSJ DIN",78,0)
  5651    ;
  5652   "RTN","PSJ DIN",79,0)
  5653   DINFLUD(PS JOI,PSJDDA ) ;
  5654   "RTN","PSJ DIN",80,0)
  5655    ;*This mo dule will  find all d rug text t hat exist  for the Or derable 
  5656   "RTN","PSJ DIN",81,0)
  5657    ;*items &  dispense  drugs asso ciated wit h the unit  dose orde r.  Once
  5658   "RTN","PSJ DIN",82,0)
  5659    ;*a drug  text exist , return t he <DIN> i ndicator t o be displ ayed with
  5660   "RTN","PSJ DIN",83,0)
  5661    ;*the ord er view.
  5662   "RTN","PSJ DIN",84,0)
  5663    ;*PSJOI:   Orderable  IEN (Requ ire)
  5664   "RTN","PSJ DIN",85,0)
  5665    ;*PSJDDA:  Dispense  drug array  within th e order (O ptional)
  5666   "RTN","PSJ DIN",86,0)
  5667    ;
  5668   "RTN","PSJ DIN",87,0)
  5669    NEW PSJFL ,PSJDD
  5670   "RTN","PSJ DIN",88,0)
  5671    D EN^PSSD IN(PSJOI)  I $O(^TMP( "PSSDIN",$ J,"OI",0))  K ^TMP("P SSDIN",$J)  Q "<DIN>"
  5672   "RTN","PSJ DIN",89,0)
  5673    F PSJDD=0 :0 S PSJDD =$O(PSJDDA (PSJDD)) Q :'PSJDD  D
  5674   "RTN","PSJ DIN",90,0)
  5675    . D EN^PS SDIN(,PSJD D) I $O(^T MP("PSSDIN ",$J,"DD", 0)) S PSJF L=1 Q
  5676   "RTN","PSJ DIN",91,0)
  5677    K ^TMP("P SSDIN",$J)
  5678   "RTN","PSJ DIN",92,0)
  5679    Q $S($G(P SJFL):"<DI N>",1:"")
  5680   "RTN","PSJ DIN",93,0)
  5681    ;
  5682   "RTN","PSJ DIN",94,0)
  5683   DINHIDE(PS JDFN,PSJOR D) ;
  5684   "RTN","PSJ DIN",95,0)
  5685    ;*Display  drug text  from the  hidden act ion. 
  5686   "RTN","PSJ DIN",96,0)
  5687    ;*PSJDFN:  Patient I EN (Requir e)
  5688   "RTN","PSJ DIN",97,0)
  5689    ;*PSJORD:  Order #_" UVP" (Requ ired)
  5690   "RTN","PSJ DIN",98,0)
  5691    ;*DRG:     IV DRG ar ray (Requi red for IV  but Optio nal for UD  orders)
  5692   "RTN","PSJ DIN",99,0)
  5693    ;
  5694   "RTN","PSJ DIN",100,0 )
  5695    D:PSJORD[ "V" IV
  5696   "RTN","PSJ DIN",101,0 )
  5697    D:PSJORD[ "U" UD
  5698   "RTN","PSJ DIN",102,0 )
  5699    I PSJORD[ "P" D
  5700   "RTN","PSJ DIN",103,0 )
  5701    . D @($S( $P(^PS(53. 1,+PSJORD, 0),U,4)="U ":"UD",1:" IV"))  ;PS J*5*227 -  Unit Dose  DIN fix
  5702   "RTN","PSJ DIN",104,0 )
  5703    I PSJORD= "" D NEWUD
  5704   "RTN","PSJ DIN",105,0 )
  5705    K ^TMP("P SSDIN",$J)
  5706   "RTN","PSJ DIN",106,0 )
  5707    Q
  5708   "RTN","PSJ DIN",107,0 )
  5709   IV ;
  5710   "RTN","PSJ DIN",108,0 )
  5711    ;NEW DRG, DRGI,DRGT, ND,ON55,Y
  5712   "RTN","PSJ DIN",109,0 )
  5713    ;D:PSJORD ["P" GT531 ^PSIVORFA( DFN,PSJORD )
  5714   "RTN","PSJ DIN",110,0 )
  5715    ;I PSJORD ["V" S ON5 5=PSJORD D  GTDRG^PSI VORFB
  5716   "RTN","PSJ DIN",111,0 )
  5717    ;*Loop th ru IV DRG  array to f ind OI & D D IEN from  each AD &  SOL.
  5718   "RTN","PSJ DIN",112,0 )
  5719    ;
  5720   "RTN","PSJ DIN",113,0 )
  5721    NEW FIL,N AME,PSJDD, PSJNF,PSJO I,PSJX,Y,X ,PSJXY,STR ,UNT,STRUN
  5722   "RTN","PSJ DIN",114,0 )
  5723    D FULL^VA LM1 W @IOF
  5724   "RTN","PSJ DIN",115,0 )
  5725    W !,"Drug  restricti on/guideli ne info:"
  5726   "RTN","PSJ DIN",116,0 )
  5727    F FIL="AD ","SOL" F  PSJX=0:0 S  PSJX=$O(D RG(FIL,PSJ X)) Q:'PSJ X  D
  5728   "RTN","PSJ DIN",117,0 )
  5729    . NEW X
  5730   "RTN","PSJ DIN",118,0 )
  5731    . S PSJXY =1
  5732   "RTN","PSJ DIN",119,0 )
  5733    . SET NAM E=$P(DRG(F IL,PSJX),U ,2)
  5734   "RTN","PSJ DIN",120,0 )
  5735    . ;PSJ*5* 289 - Add  Additive S trength to  display.
  5736   "RTN","PSJ DIN",121,0 )
  5737    . S STR=$ $GET1^DIQ( 52.6,$P(DR G(FIL,PSJX ),U,1)_"," ,19)  ; Ge t STRENGTH  from IV A dditives F ile
  5738   "RTN","PSJ DIN",122,0 )
  5739    . S UNT=$ $GET1^DIQ( 52.6,$P(DR G(FIL,PSJX ),U,1)_"," ,2)   ; Ge t DRUG UNI T from IV  Additives  File
  5740   "RTN","PSJ DIN",123,0 )
  5741    . S STRUN =$G(STR)_"  "_$G(UNT)   ; Append  DRUG UNIT  to STRENG TH
  5742   "RTN","PSJ DIN",124,0 )
  5743    . I STR=" " S STRUN= "N/A"  ; P er Pharmac y User Gro up - put N /A if the  STRENGTH f ield is no t populate d.
  5744   "RTN","PSJ DIN",125,0 )
  5745    . W !!,"I V "_$S(FIL ="AD":"Add itive",1:" Solution") _": "_NAME
  5746   "RTN","PSJ DIN",126,0 )
  5747    . D NFIV( FIL,+PSJX, .PSJNF) W  $G(PSJNF(" NF"))_$S(F IL="AD":"    Additive  Strength:  "_$G(STRU N),1:""),!   
  5748   ;Put Addit ive Streng th after * N/F*.
  5749   "RTN","PSJ DIN",127,0 )
  5750    . S X=$S( FIL="AD":$ G(^PS(52.6 ,+DRG(FIL, PSJX),0)), 1:$G(^PS(5 2.7,+DRG(F IL,PSJX),0 )))
  5751   "RTN","PSJ DIN",128,0 )
  5752    . S PSJOI =$P(X,U,11 ),PSJDD=$P (X,U,2) D  EN^PSSDIN( +PSJOI,+PS JDD)
  5753   "RTN","PSJ DIN",129,0 )
  5754    . D DINOI (PSJOI,3)
  5755   "RTN","PSJ DIN",130,0 )
  5756    . D DINDD (PSJDD,3)
  5757   "RTN","PSJ DIN",131,0 )
  5758    D:'$G(PSJ XY) HLD
  5759   "RTN","PSJ DIN",132,0 )
  5760    K ^TMP("P SSDIN",$J)
  5761   "RTN","PSJ DIN",133,0 )
  5762    Q
  5763   "RTN","PSJ DIN",134,0 )
  5764   UD ;
  5765   "RTN","PSJ DIN",135,0 )
  5766    ;*Loop th ru Unit do se order f or Orderab le Item &  Dispense d rug
  5767   "RTN","PSJ DIN",136,0 )
  5768    ;
  5769   "RTN","PSJ DIN",137,0 )
  5770    NEW F,PSJ DD,PSJDDX, PSJOI,PSJX Y
  5771   "RTN","PSJ DIN",138,0 )
  5772    D FULL^VA LM1 W @IOF
  5773   "RTN","PSJ DIN",139,0 )
  5774    W !,"Drug  restricti on/guideli ne info:"
  5775   "RTN","PSJ DIN",140,0 )
  5776    S F=$S(PS JORD["U":" ^PS(55,PSJ DFN,5,+PSJ ORD,",1:"^ PS(53.1,+P SJORD,")
  5777   "RTN","PSJ DIN",141,0 )
  5778    S PSJOI=+ @(F_".2)")  D EN^PSSD IN(PSJOI), DINOI(PSJO I,3)
  5779   "RTN","PSJ DIN",142,0 )
  5780    ;*Loop th ru dispens e drug arr ay
  5781   "RTN","PSJ DIN",143,0 )
  5782    F PSJDDX= 0:0 S PSJD DX=$O(@(F_ "1,"_PSJDD X_")")) Q: 'PSJDDX  D
  5783   "RTN","PSJ DIN",144,0 )
  5784    . S PSJXY =1
  5785   "RTN","PSJ DIN",145,0 )
  5786    . S PSJDD =+@(F_"1," _PSJDDX_", 0)")
  5787   "RTN","PSJ DIN",146,0 )
  5788    . D EN^PS SDIN(PSJOI ,PSJDD)
  5789   "RTN","PSJ DIN",147,0 )
  5790    . D DINDD (PSJDD,3)
  5791   "RTN","PSJ DIN",148,0 )
  5792    D:'$G(PSJ XY) HLD
  5793   "RTN","PSJ DIN",149,0 )
  5794    K ^TMP("P SSDIN",$J)
  5795   "RTN","PSJ DIN",150,0 )
  5796    Q
  5797   "RTN","PSJ DIN",151,0 )
  5798   NEWUD ;*Ne w backdoor  order doe sn't have  an order#  yet.
  5799   "RTN","PSJ DIN",152,0 )
  5800    ;*Loop th ru Orderab le Item &  Dispense d rug
  5801   "RTN","PSJ DIN",153,0 )
  5802    ;
  5803   "RTN","PSJ DIN",154,0 )
  5804    NEW F,PSJ DD,PSJDDX, PSJOI,PSJX Y
  5805   "RTN","PSJ DIN",155,0 )
  5806    D FULL^VA LM1 W @IOF
  5807   "RTN","PSJ DIN",156,0 )
  5808    W !,"Drug  restricti on/guideli ne info:"
  5809   "RTN","PSJ DIN",157,0 )
  5810    S PSJOI=+ $G(PSGPD)  D EN^PSSDI N(PSJOI),D INOI(PSJOI ,3)
  5811   "RTN","PSJ DIN",158,0 )
  5812    ;*Loop th ru dispens e drug arr ay
  5813   "RTN","PSJ DIN",159,0 )
  5814    F PSJDDX= 0:0 S PSJD DX=$O(^PS( 53.45,PSJS YSP,2,PSJD DX)) Q:'PS JDDX  D
  5815   "RTN","PSJ DIN",160,0 )
  5816    . S PSJXY =1
  5817   "RTN","PSJ DIN",161,0 )
  5818    . S PSJDD =+$G(^PS(5 3.45,PSJSY SP,2,PSJDD X,0))
  5819   "RTN","PSJ DIN",162,0 )
  5820    . D EN^PS SDIN(PSJOI ,PSJDD)
  5821   "RTN","PSJ DIN",163,0 )
  5822    . D DINDD (PSJDD,3)
  5823   "RTN","PSJ DIN",164,0 )
  5824    D:'$G(PSJ XY) HLD
  5825   "RTN","PSJ DIN",165,0 )
  5826    K ^TMP("P SSDIN",$J)
  5827   "RTN","PSJ DIN",166,0 )
  5828    Q
  5829   "RTN","PSJ DIN",167,0 )
  5830   DINOI(PSJO I,COL)     ;
  5831   "RTN","PSJ DIN",168,0 )
  5832    ;*Display  drug text  for Order able Item
  5833   "RTN","PSJ DIN",169,0 )
  5834    ;*OI:   O rderable I tem IEN
  5835   "RTN","PSJ DIN",170,0 )
  5836    ;*COl:  C olumn to d isplay the  text in
  5837   "RTN","PSJ DIN",171,0 )
  5838    ;
  5839   "RTN","PSJ DIN",172,0 )
  5840    NEW X,XX
  5841   "RTN","PSJ DIN",173,0 )
  5842    W !!,?COL ,"Orderabl e Item: "_ $$OINAME^P SJLMUTL(PS JOI)_$$OIN F(PSJOI),!
  5843   "RTN","PSJ DIN",174,0 )
  5844    I '$O(^TM P("PSSDIN" ,$J,"OI",P SJOI,0)) W  !,?10,"No  informati on availab le",! Q
  5845   "RTN","PSJ DIN",175,0 )
  5846    D TXD("OI ") W !
  5847   "RTN","PSJ DIN",176,0 )
  5848    Q
  5849   "RTN","PSJ DIN",177,0 )
  5850   DINDD(PSJD D,COL)         ;
  5851   "RTN","PSJ DIN",178,0 )
  5852    ;*Display  drug text  for Dispe nse drug
  5853   "RTN","PSJ DIN",179,0 )
  5854    ;*PSJDD:   Dispense  drug IEN
  5855   "RTN","PSJ DIN",180,0 )
  5856    ;*COL:     Column to  display t he text in
  5857   "RTN","PSJ DIN",181,0 )
  5858    ;
  5859   "RTN","PSJ DIN",182,0 )
  5860    NEW X
  5861   "RTN","PSJ DIN",183,0 )
  5862    W !,?COL, "Dispense  drug: "_$$ DDNAME^PSJ LMUTL(+PSJ DD)_$$DDNF (PSJDD),!
  5863   "RTN","PSJ DIN",184,0 )
  5864    I '$O(^TM P("PSSDIN" ,$J,"DD",P SJDD,0)) W  !?10,"No  informatio n availabl e",! D HLD  Q
  5865   "RTN","PSJ DIN",185,0 )
  5866    D TXD("DD "),HLD W @ IOF
  5867   "RTN","PSJ DIN",186,0 )
  5868    Q
  5869   "RTN","PSJ DIN",187,0 )
  5870   OINF(PSJOI )        ;
  5871   "RTN","PSJ DIN",188,0 )
  5872    ;*Return  *N/F* if t he orderab le item is  Non-formu lary
  5873   "RTN","PSJ DIN",189,0 )
  5874    ;*Return  *PA* if or derable is  formulary , but rest ricted.
  5875   "RTN","PSJ DIN",190,0 )
  5876    N RTRN,ZC NT,ZFLG
  5877   "RTN","PSJ DIN",191,0 )
  5878    S RTRN="" ,ZFLG="N"
  5879   "RTN","PSJ DIN",192,0 )
  5880    I $$GET1^ DIQ(50.7,+ PSJOI_",", 5,"I")=1 S  RTRN=" *N /F*"
  5881   "RTN","PSJ DIN",193,0 )
  5882    I $$GET^X PAR("DIV", "PSS PRIOR  AUTH NOTA TION","`"_ DUZ(2))>0, RTRN'=" *N /F*" D
  5883   "RTN","PSJ DIN",194,0 )
  5884    . S ZCNT= 0 F  S ZCN T=$O(^PS(5 0.7,"A50", +PSJOI,ZCN T)) Q:ZCNT =""!(ZFLG= "Y")  D 
  5885   "RTN","PSJ DIN",195,0 )
  5886    . . N PSJ AR,PSJER D  GETS^DIQ( 50,+ZCNT_" ,","3;100; 102","E"," PSJAR","PS JER")
  5887   "RTN","PSJ DIN",196,0 )
  5888    . . I PSJ AR(50,+ZCN T_",",100, "E")]"" S  ZFLG="Y" Q   ; INACTI VE
  5889   "RTN","PSJ DIN",197,0 )
  5890    . . I PSJ AR(50,+ZCN T_",",3,"E ")["R" S Z FLG="Y",RT RN=" **PA* *" Q
  5891   "RTN","PSJ DIN",198,0 )
  5892    . . I PSJ AR(50,+ZCN T_",",102, "E")["REST RICTED" S  ZFLG="Y",R TRN=" **PA **" Q
  5893   "RTN","PSJ DIN",199,0 )
  5894    Q RTRN
  5895   "RTN","PSJ DIN",200,0 )
  5896    ;
  5897   "RTN","PSJ DIN",201,0 )
  5898    ;*PSJOI:  Orderable  item IEN
  5899   "RTN","PSJ DIN",202,0 )
  5900    ;
  5901   "RTN","PSJ DIN",203,0 )
  5902    ;Q $S($P( $G(^PS(50. 7,+PSJOI,0 )),U,12)=1 :" *N/F*", 1:"")
  5903   "RTN","PSJ DIN",204,0 )
  5904    ;
  5905   "RTN","PSJ DIN",205,0 )
  5906   DDNF(PSJDD )     ;
  5907   "RTN","PSJ DIN",206,0 )
  5908    ;**Return  *N/F* if  the dispen se drug is  Non-formu lary
  5909   "RTN","PSJ DIN",207,0 )
  5910    ;**Return  **PA** if  drug need s prior au thorizatio n (Restric ted)
  5911   "RTN","PSJ DIN",208,0 )
  5912    ;*PSJDD:  Dispense d rug IEN
  5913   "RTN","PSJ DIN",209,0 )
  5914    ;
  5915   "RTN","PSJ DIN",210,0 )
  5916    ;Q $S($P( $G(^PSDRUG (+PSJDD,0) ),U,9)=1:"  *N/F*",1: "")
  5917   "RTN","PSJ DIN",211,0 )
  5918    N RTRN
  5919   "RTN","PSJ DIN",212,0 )
  5920    S RTRN=""
  5921   "RTN","PSJ DIN",213,0 )
  5922    I $$GET1^ DIQ(50,+PS JDD_",",51 ,"I")=1 S  RTRN="*N/F *"
  5923   "RTN","PSJ DIN",214,0 )
  5924    I RTRN'=" *N/F*" D
  5925   "RTN","PSJ DIN",215,0 )
  5926    . I $$GET 1^DIQ(50,+ PSJDD_",", 3,"I")["R" !($$GET1^D IQ(50,+PSJ DD_",",102 ,"I"))["RE STRICTED"  S RTRN=" 
  5927   **PA**"
  5928   "RTN","PSJ DIN",216,0 )
  5929    Q RTRN
  5930   "VER")
  5931   8.0^22.2
  5932   "^DD",59.5 ,59.5,.107 ,0)
  5933   HEADER LAB EL^NJ1,0^^ 1;7^K:+X'= X!(X>9)!(X <0)!(X?.E1 "."1N.N) X
  5934   "^DD",59.5 ,59.5,.107 ,3)
  5935   Type a num ber betwee n 0 and 9,  0 decimal  digits.
  5936   "^DD",59.5 ,59.5,.107 ,20,0)
  5937   ^.3LA^1^1
  5938   "^DD",59.5 ,59.5,.107 ,20,1,0)
  5939   PSJI
  5940   "^DD",59.5 ,59.5,.107 ,21,0)
  5941   ^^3^3^3170 730^
  5942   "^DD",59.5 ,59.5,.107 ,21,1,0)
  5943   Indicates  the number  of labels  to be pro duced when  printing  pre-exchan ge 
  5944   "^DD",59.5 ,59.5,.107 ,21,2,0)
  5945   labels for  IVs.  Val id values  are 0-9, w here 0 = N o Header L abel, 1 = 
  5946   "^DD",59.5 ,59.5,.107 ,21,3,0)
  5947   label, 2 =  two (2) h eader labe ls, etc.
  5948   "^DD",59.5 ,59.5,.107 ,22)
  5949  
  5950   "^DD",59.5 ,59.5,.107 ,"DT")
  5951   3170730
  5952   "BLD",9866 ,6)
  5953   1^
  5954   $END KID P SJ*5.0*332