65. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 4/16/2019 12:20:48 PM Central Daylight 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.

65.1 Files compared

# Location File Last Modified
1 C:\AraxisMergeCompare\Pri_un\CPRS_32_P2_PCE OR_397_V10.KID Wed Mar 27 18:25:33 2019 UTC
2 C:\AraxisMergeCompare\Pri_re\CPRS v32 P2 PCE Standardization-redacted\CPRS_32_P2_PCE OR_397_V10.KID Tue Apr 16 15:58:36 2019 UTC

65.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 3 17352
Changed 2 4
Inserted 0 0
Removed 0 0

65.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

65.4 Active regular expressions

No regular expressions were active.

65.5 Comparison detail

  1   KIDS Distr ibution sa ved on Feb  05, 2019@ 06:42:21
  2   OR*3.0*397
  3   **KIDS**:O R*3.0*397^
  4  
  5   **INSTALL  NAME**
  6   OR*3.0*397
  7   "BLD",9661 ,0)
  8   OR*3.0*397 ^ORDER ENT RY/RESULTS  REPORTING ^0^3190205 ^y
  9   "BLD",9661 ,4,0)
  10   ^9.64PA^10 1.41^1
  11   "BLD",9661 ,4,101.41, 0)
  12   101.41
  13   "BLD",9661 ,4,101.41, 222)
  14   n^n^^^y^^y ^r^n
  15   "BLD",9661 ,4,101.41, 224)
  16   I $$SENDDL G^ORY397($ P(^(0),U))
  17   "BLD",9661 ,4,"B",101 .41,101.41 )
  18  
  19   "BLD",9661 ,6)
  20   2^
  21   "BLD",9661 ,6.3)
  22   17
  23   "BLD",9661 ,"ABPKG")
  24   n
  25   "BLD",9661 ,"INID")
  26   ^n
  27   "BLD",9661 ,"INIT")
  28   EN^ORY397A
  29   "BLD",9661 ,"KRN",0)
  30   ^9.67PA^77 9.2^20
  31   "BLD",9661 ,"KRN",.4, 0)
  32   .4
  33   "BLD",9661 ,"KRN",.40 1,0)
  34   .401
  35   "BLD",9661 ,"KRN",.40 2,0)
  36   .402
  37   "BLD",9661 ,"KRN",.40 3,0)
  38   .403
  39   "BLD",9661 ,"KRN",.5, 0)
  40   .5
  41   "BLD",9661 ,"KRN",.84 ,0)
  42   .84
  43   "BLD",9661 ,"KRN",3.6 ,0)
  44   3.6
  45   "BLD",9661 ,"KRN",3.8 ,0)
  46   3.8
  47   "BLD",9661 ,"KRN",9.2 ,0)
  48   9.2
  49   "BLD",9661 ,"KRN",9.8 ,0)
  50   9.8
  51   "BLD",9661 ,"KRN",9.8 ,"NM",0)
  52   ^9.68A^20^ 17
  53   "BLD",9661 ,"KRN",9.8 ,"NM",2,0)
  54   ORUPREF1^^ 0^B1301910 6
  55   "BLD",9661 ,"KRN",9.8 ,"NM",3,0)
  56   ORS100C^^0 ^B22805043
  57   "BLD",9661 ,"KRN",9.8 ,"NM",4,0)
  58   ORCMEDT4^^ 0^B1063825 62
  59   "BLD",9661 ,"KRN",9.8 ,"NM",5,0)
  60   ORCMEDT9^^ 0^B5654403 7
  61   "BLD",9661 ,"KRN",9.8 ,"NM",6,0)
  62   ORCSAVE^^0 ^B12770832 6
  63   "BLD",9661 ,"KRN",9.8 ,"NM",9,0)
  64   ORMPS1^^0^ B72421990
  65   "BLD",9661 ,"KRN",9.8 ,"NM",10,0 )
  66   ORUTL3^^0^ B3158346
  67   "BLD",9661 ,"KRN",9.8 ,"NM",11,0 )
  68   ORY397^^0^ B133927
  69   "BLD",9661 ,"KRN",9.8 ,"NM",12,0 )
  70   ORWDXM3^^0 ^B12116624 2
  71   "BLD",9661 ,"KRN",9.8 ,"NM",13,0 )
  72   ORWDXA^^0^ B119665285
  73   "BLD",9661 ,"KRN",9.8 ,"NM",14,0 )
  74   ORUTL5^^0^ B2631005
  75   "BLD",9661 ,"KRN",9.8 ,"NM",15,0 )
  76   ORWDX^^0^B 92501053
  77   "BLD",9661 ,"KRN",9.8 ,"NM",16,0 )
  78   ORCACT01^^ 0^B8992737 1
  79   "BLD",9661 ,"KRN",9.8 ,"NM",17,0 )
  80   ORWDPS32^^ 0^B7879948 9
  81   "BLD",9661 ,"KRN",9.8 ,"NM",18,0 )
  82   ORSPUTIL^^ 0^B2417275 0
  83   "BLD",9661 ,"KRN",9.8 ,"NM",19,0 )
  84   ORWDXM1^^0 ^B13048127 6
  85   "BLD",9661 ,"KRN",9.8 ,"NM",20,0 )
  86   ORWDPS3^^0 ^B22042687
  87   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORCACT01" ,16)
  88  
  89   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORCMEDT4" ,4)
  90  
  91   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORCMEDT9" ,5)
  92  
  93   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORCSAVE", 6)
  94  
  95   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORMPS1",9 )
  96  
  97   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORS100C", 3)
  98  
  99   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORSPUTIL" ,18)
  100  
  101   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORUPREF1" ,2)
  102  
  103   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORUTL3",1 0)
  104  
  105   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORUTL5",1 4)
  106  
  107   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORWDPS3", 20)
  108  
  109   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORWDPS32" ,17)
  110  
  111   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORWDX",15 )
  112  
  113   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORWDXA",1 3)
  114  
  115   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORWDXM1", 19)
  116  
  117   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORWDXM3", 12)
  118  
  119   "BLD",9661 ,"KRN",9.8 ,"NM","B", "ORY397",1 1)
  120  
  121   "BLD",9661 ,"KRN",19, 0)
  122   19
  123   "BLD",9661 ,"KRN",19, "NM",0)
  124   ^9.68A^4^4
  125   "BLD",9661 ,"KRN",19, "NM",1,0)
  126   OR PARAM C OORDINATOR  MENU^^3
  127   "BLD",9661 ,"KRN",19, "NM",2,0)
  128   OR CS ORDE R ANOMALIE S^^0
  129   "BLD",9661 ,"KRN",19, "NM",3,0)
  130   OR SUPPLY  QO CONVERS ION^^0
  131   "BLD",9661 ,"KRN",19, "NM",4,0)
  132   OR SUPPLY  UTIL MENU^ ^2
  133   "BLD",9661 ,"KRN",19, "NM","B"," OR CS ORDE R ANOMALIE S",2)
  134  
  135   "BLD",9661 ,"KRN",19, "NM","B"," OR PARAM C OORDINATOR  MENU",1)
  136  
  137   "BLD",9661 ,"KRN",19, "NM","B"," OR SUPPLY  QO CONVERS ION",3)
  138  
  139   "BLD",9661 ,"KRN",19, "NM","B"," OR SUPPLY  UTIL MENU" ,4)
  140  
  141   "BLD",9661 ,"KRN",19. 1,0)
  142   19.1
  143   "BLD",9661 ,"KRN",19. 1,"NM",0)
  144   ^9.68A^^
  145   "BLD",9661 ,"KRN",101 ,0)
  146   101
  147   "BLD",9661 ,"KRN",101 ,"NM",0)
  148   ^9.68A^1^1
  149   "BLD",9661 ,"KRN",101 ,"NM",1,0)
  150   OR COMPLET E ORDER^^0
  151   "BLD",9661 ,"KRN",101 ,"NM","B", "OR COMPLE TE ORDER", 1)
  152  
  153   "BLD",9661 ,"KRN",409 .61,0)
  154   409.61
  155   "BLD",9661 ,"KRN",771 ,0)
  156   771
  157   "BLD",9661 ,"KRN",779 .2,0)
  158   779.2
  159   "BLD",9661 ,"KRN",870 ,0)
  160   870
  161   "BLD",9661 ,"KRN",898 9.51,0)
  162   8989.51
  163   "BLD",9661 ,"KRN",898 9.52,0)
  164   8989.52
  165   "BLD",9661 ,"KRN",899 4,0)
  166   8994
  167   "BLD",9661 ,"KRN","B" ,.4,.4)
  168  
  169   "BLD",9661 ,"KRN","B" ,.401,.401 )
  170  
  171   "BLD",9661 ,"KRN","B" ,.402,.402 )
  172  
  173   "BLD",9661 ,"KRN","B" ,.403,.403 )
  174  
  175   "BLD",9661 ,"KRN","B" ,.5,.5)
  176  
  177   "BLD",9661 ,"KRN","B" ,.84,.84)
  178  
  179   "BLD",9661 ,"KRN","B" ,3.6,3.6)
  180  
  181   "BLD",9661 ,"KRN","B" ,3.8,3.8)
  182  
  183   "BLD",9661 ,"KRN","B" ,9.2,9.2)
  184  
  185   "BLD",9661 ,"KRN","B" ,9.8,9.8)
  186  
  187   "BLD",9661 ,"KRN","B" ,19,19)
  188  
  189   "BLD",9661 ,"KRN","B" ,19.1,19.1 )
  190  
  191   "BLD",9661 ,"KRN","B" ,101,101)
  192  
  193   "BLD",9661 ,"KRN","B" ,409.61,40 9.61)
  194  
  195   "BLD",9661 ,"KRN","B" ,771,771)
  196  
  197   "BLD",9661 ,"KRN","B" ,779.2,779 .2)
  198  
  199   "BLD",9661 ,"KRN","B" ,870,870)
  200  
  201   "BLD",9661 ,"KRN","B" ,8989.51,8 989.51)
  202  
  203   "BLD",9661 ,"KRN","B" ,8989.52,8 989.52)
  204  
  205   "BLD",9661 ,"KRN","B" ,8994,8994 )
  206  
  207   "BLD",9661 ,"QUES",0)
  208   ^9.62^^
  209   "BLD",9661 ,"REQB",0)
  210   ^9.611^13^ 5
  211   "BLD",9661 ,"REQB",7, 0)
  212   OR*3.0*382 ^2
  213   "BLD",9661 ,"REQB",9, 0)
  214   OR*3.0*111 ^2
  215   "BLD",9661 ,"REQB",11 ,0)
  216   OR*3.0*441 ^2
  217   "BLD",9661 ,"REQB",12 ,0)
  218   OR*3.0*490 ^2
  219   "BLD",9661 ,"REQB",13 ,0)
  220   OR*3.0*494 ^2
  221   "BLD",9661 ,"REQB","B ","OR*3.0* 111",9)
  222  
  223   "BLD",9661 ,"REQB","B ","OR*3.0* 382",7)
  224  
  225   "BLD",9661 ,"REQB","B ","OR*3.0* 441",11)
  226  
  227   "BLD",9661 ,"REQB","B ","OR*3.0* 490",12)
  228  
  229   "BLD",9661 ,"REQB","B ","OR*3.0* 494",13)
  230  
  231   "DATA",101 .41,51,0)
  232   GMRCOR CON SULT^Consu lt^^D^11^2 ^294^1^1
  233   "DATA",101 .41,51,3)
  234   D GETSERV^ ORCDGMRC
  235   "DATA",101 .41,51,3.1 )
  236   D GETSERV^ ORCDGMRC
  237   "DATA",101 .41,51,4)
  238   K ORSERV,O RPDX,GMRCN OPD,GMRCNO AT,GMRCREA F,^TMP("GM RCS",$J),^ TMP("GMRCS LIST",$J)
  239   "DATA",101 .41,51,5)
  240   ^^^Consult ^110
  241   "DATA",101 .41,51,6,0 )
  242   ^101.416
  243   "DATA",101 .41,51,10, 0)
  244   ^101.412IA ^10^10
  245   "DATA",101 .41,51,10, 1,0)
  246   1^4^^Consu lt to Serv ice/Specia lty: ^^1^^ ^^S.CSLT
  247   "DATA",101 .41,51,10, 1,1)
  248   Select the  service/s pecialty c onsultatio n you wish  to reques t for this  patient.
  249   "DATA",101 .41,51,10, 1,2)
  250   2^^^^Cons
  251   "DATA",101 .41,51,10, 1,3)
  252   I $G(ORTYP E)'="Q",'$ D(OREDIT), '$G(OREWRI TE)
  253   "DATA",101 .41,51,10, 1,4)
  254   I $$ACTIVE ^ORDD43(Y) ,$D(^TMP(" GMRCS",$J, +$P(^(0),U ,2)))
  255   "DATA",101 .41,51,10, 1,5)
  256   I $G(ORESE T)'=+Y D C KSERV^ORCD GMRC K GMR CREAF
  257   "DATA",101 .41,51,10, 1,6)
  258   D LISTSERV ^ORCDGMRC( 1)
  259   "DATA",101 .41,51,10, 1,10)
  260   N OI S OI= +$G(ORDIAL OG(PROMPT, INST)),ORS ERV=+$P($G (^ORD(101. 43,OI,0)), U,2) D:ORS ERV SERVMS G^ORCDGMRC
  261   "DATA",101 .41,51,10, 1,"W")
  262   cboService
  263   "DATA",101 .41,51,10, 2,0)
  264   2^15^^Reas on for Req uest: ^^1
  265   "DATA",101 .41,51,10, 2,1)
  266   Enter a br ief descri ption of w hy this co nsult is b eing reque sted.
  267   "DATA",101 .41,51,10, 2,3)
  268   I $G(ORTYP E)="Z"!'$G (GMRCREAF) !($G(GMRCR EAF)=1&'FI RST)
  269   "DATA",101 .41,51,10, 2,7)
  270   D REASON^O RCDGMRC
  271   "DATA",101 .41,51,10, 2,9)
  272   S:'$D(GMRC REAF) GMRC REAF=$$REA F^GMRCDRFR (+$G(ORSER V))
  273   "DATA",101 .41,51,10, 2,"W")
  274   memReason
  275   "DATA",101 .41,51,10, 3,0)
  276   3^10^^^^1
  277   "DATA",101 .41,51,10, 3,1)
  278   Enter if t he service  rendered  will be on  an inpati ent or out patient ba sis.
  279   "DATA",101 .41,51,10, 3,5)
  280   I $G(ORESE T)'="",ORE SET'=$P(Y, U) D CHANG ED^ORCDGMR C("CAT")
  281   "DATA",101 .41,51,10, 3,6)
  282   D SETLIST^ ORCD
  283   "DATA",101 .41,51,10, 3,7)
  284   S:$G(ORTYP E)'="Z" Y= $S($$INPT^ ORCD:"I",1 :"O")
  285   "DATA",101 .41,51,10, 3,9)
  286   S ORDIALOG (PROMPT,0) =$P(ORDIAL OG(PROMPT, 0),";",1,2 ) ;I or O  only
  287   "DATA",101 .41,51,10, 3,"W")
  288   refCategor y
  289   "DATA",101 .41,51,10, 4,0)
  290   4^7^^^^1^^ ^^S.GMRCT
  291   "DATA",101 .41,51,10, 4,1)
  292   Select the  urgency i ndicating  how quickl y results  from this  consult ar e needed.
  293   "DATA",101 .41,51,10, 4,2)
  294   4^^ROUTINE
  295   "DATA",101 .41,51,10, 4,7)
  296   S Y=9
  297   "DATA",101 .41,51,10, 4,9)
  298   D URGENCY^ ORCDGMRC(" C")
  299   "DATA",101 .41,51,10, 4,"W")
  300   cboUrgency
  301   "DATA",101 .41,51,10, 5,0)
  302   5^140^^^^1
  303   "DATA",101 .41,51,10, 5,1)
  304   Select the  preferred  place to  see the pa tient for  this consu lt.
  305   "DATA",101 .41,51,10, 5,2)
  306   3
  307   "DATA",101 .41,51,10, 5,6)
  308   D LIST^ORC D
  309   "DATA",101 .41,51,10, 5,7)
  310   S:$G(ORTYP E)'="Z" Y= $S($$VAL^O RCD("CATEG ORY")="I": "B",1:"C")
  311   "DATA",101 .41,51,10, 5,9)
  312   D PLACE^OR CDGMRC
  313   "DATA",101 .41,51,10, 5,"W")
  314   cboPlace
  315   "DATA",101 .41,51,10, 6,0)
  316   6^17^^Atte ntion: 
  317   "DATA",101 .41,51,10, 6,1)
  318   Enter the  service/sp ecialty us er who is  to be noti fied of th is request .
  319   "DATA",101 .41,51,10, 6,3)
  320   I '$G(GMRC NOAT)
  321   "DATA",101 .41,51,10, 6,4)
  322   N ORT S OR T=$P(^(0), U,11) I 'O RT!(ORT>DT )
  323   "DATA",101 .41,51,10, 6,"W")
  324   txtAttn
  325   "DATA",101 .41,51,10, 7,0)
  326   7^20^^Prov isional Di agnosis: ^ ^
  327   "DATA",101 .41,51,10, 7,1)
  328   Enter a pr eliminary  diagnosis  relating t o this req uest, up t o 240 char acters.
  329   "DATA",101 .41,51,10, 7,3)
  330   I '$G(GMRC NOPD)
  331   "DATA",101 .41,51,10, 7,5)
  332   D LEX^ORCD GMRC
  333   "DATA",101 .41,51,10, 7,9)
  334   D ENPDX^OR CDGMRC
  335   "DATA",101 .41,51,10, 7,"W")
  336   txtProvDia g
  337   "DATA",101 .41,51,10, 8,0)
  338   1.1^178^^C onsult Typ e: 
  339   "DATA",101 .41,51,10, 8,1)
  340   Enter the  type of co nsult you  wish to ha ve done at  this serv ice
  341   "DATA",101 .41,51,10, 8,2)
  342   1
  343   "DATA",101 .41,51,10, 8,3)
  344   I $G(ORTYP E)="Z"!$D( ORDIALOG(P ROMPT,INST )) ;popula ted by QO  only
  345   "DATA",101 .41,51,10, 9,0)
  346   7.1^173^^^ ^^^^^^20
  347   "DATA",101 .41,51,10, 9,3)
  348   I 0 ;stuff ed in via  Prov Dx
  349   "DATA",101 .41,51,10, 10,0)
  350   4.5^15820^ ^Clinicall y Indicate d Date:^^1 ^^^W
  351   "DATA",101 .41,51,10, 10,1)
  352   Enter the  clinically  indicated  date for  this consu lt to be p erformed.
  353   "DATA",101 .41,51,10, 10,3)
  354   Q:'$G(ORSE RV)  I $G( ^GMR(123.5 ,ORSERV,"I NT"))'=1
  355   "DATA",101 .41,51,10, 10,5)
  356   Q:$G(ORTYP E)'="Z"  I  $G(ORDIAL OG(PROMPT, INST))'["T " K DONE W  $C(7),!," Response m ust be rel ative date  (e.g. TOD AY, T+7D,  T+3M)"
  357   "DATA",101 .41,51,10, 10,7)
  358   Q:'$G(ORSE RV)  S:$G( ^GMR(123.5 ,ORSERV,"I NT"))'=1 Y =$$GET^XPA R("DIV^SYS ^PKG","ORC DGMRC CLIN  IND DATE  DEFAULT",1 ,"Q")
  359   "DATA",101 .41,51,10, 10,10)
  360   N X,Y,%DT  S X=$G(ORD IALOG(PROM PT,INST)), %DT="X" I  $L(X) D ^% DT S:Y>0 O RDATE=$P(Y ,".")
  361   "DATA",101 .41,51,10, 10,"W")
  362   calClinica llyIndicat ed
  363   "DATA",101 .41,51,10, 10,"W7")
  364   S Y=$$GET^ XPAR("DIV^ SYS^PKG"," ORCDGMRC C LIN IND DA TE DEFAULT ",1,"Q")
  365   "DATA",101 .41,51,99)
  366   64859,4529 6
  367   "DATA",101 .41,52,0)
  368   GMRCOR REQ UEST^Proce dure^^D^43 ^2^294^1^2
  369   "DATA",101 .41,52,4)
  370   K ORSERV,O RPDX,GMRCN OAT,GMRCNO PD,GMRCREA F,ORPROC
  371   "DATA",101 .41,52,5)
  372   ^^^Procedu re^112
  373   "DATA",101 .41,52,10, 0)
  374   ^101.412IA ^10^10
  375   "DATA",101 .41,52,10, 1,0)
  376   1^4^^Proce dure: ^^1^ ^^^S.PROC
  377   "DATA",101 .41,52,10, 1,1)
  378   Select the  procedure  you wish  to request  for this  patient.
  379   "DATA",101 .41,52,10, 1,2)
  380   1
  381   "DATA",101 .41,52,10, 1,4)
  382   I $$ACTIVE ^ORDD43(Y)
  383   "DATA",101 .41,52,10, 1,5)
  384   I $G(ORESE T)'=$P(Y,U ) D CKPROC SV^ORCDGMR C Q:'$G(DO NE)  D:$G( ORESET) CH ANGED^ORCD GMRC("OI")
  385   "DATA",101 .41,52,10, 1,6)
  386   N IDX,SCR  S IDX=$G(O RDIALOG(PR OMPT,"D")) ,SCR=$G(OR DIALOG(PRO MPT,"S"))  D XHELP^OR DD43(IDX,S CR)
  387   "DATA",101 .41,52,10, 1,10)
  388   N OI S OI= +$G(ORDIAL OG(PROMPT, INST)) I $ P($G(^ORD( 101.43,OI, 0)),"^",2) ["99PRC" S  ORPROC=$P (^ORD(101. 43,OI,0)," ^",2) D SE RVMSG^ORCD GMRC
  389   "DATA",101 .41,52,10, 2,0)
  390   2^15^^Reas on for Req uest: ^^1
  391   "DATA",101 .41,52,10, 2,1)
  392   Enter a br ief descri ption of w hy this pr ocedure is  being req uested.
  393   "DATA",101 .41,52,10, 2,3)
  394   I $G(ORTYP E)="Z"!'$G (GMRCREAF) !($G(GMRCR EAF)=1&'FI RST)
  395   "DATA",101 .41,52,10, 2,7)
  396   D REASON^O RCDGMRC
  397   "DATA",101 .41,52,10, 2,9)
  398   S:'$D(GMRC REAF)&('$G (ORPROC))  GMRCREAF=$ $REAF^GMRC DRFR($G(OR PROC))
  399   "DATA",101 .41,52,10, 3,0)
  400   3^10^^^^1
  401   "DATA",101 .41,52,10, 3,1)
  402   Enter if t he service  rendered  will be on  an inpati ent or out patient ba sis.
  403   "DATA",101 .41,52,10, 3,5)
  404   I $G(ORESE T)'="",ORE SET'=$P(Y, U) D CHANG ED^ORCDGMR C("CAT")
  405   "DATA",101 .41,52,10, 3,6)
  406   D SETLIST^ ORCD
  407   "DATA",101 .41,52,10, 3,7)
  408   S:$G(ORTYP E)'="Z" Y= $S($$INPT^ ORCD:"I",1 :"O")
  409   "DATA",101 .41,52,10, 3,9)
  410   S ORDIALOG (PROMPT,0) =$P(ORDIAL OG(PROMPT, 0),";",1,2 ) ;I or O  only
  411   "DATA",101 .41,52,10, 4,0)
  412   4^7^^^^1^^ ^^S.GMRCR
  413   "DATA",101 .41,52,10, 4,1)
  414   Select the  urgency i ndicating  how quickl y results  from this  procedure  are needed .
  415   "DATA",101 .41,52,10, 4,2)
  416   4^^ROUTINE
  417   "DATA",101 .41,52,10, 4,7)
  418   S Y=9
  419   "DATA",101 .41,52,10, 4,9)
  420   D URGENCY^ ORCDGMRC(" R")
  421   "DATA",101 .41,52,10, 5,0)
  422   5^140^^^^1
  423   "DATA",101 .41,52,10, 5,1)
  424   Select the  preferred  place to  see the pa tient for  this consu lt.
  425   "DATA",101 .41,52,10, 5,2)
  426   3
  427   "DATA",101 .41,52,10, 5,6)
  428   D LIST^ORC D
  429   "DATA",101 .41,52,10, 5,7)
  430   S:$G(ORTYP E)'="Z" Y= $S($$VAL^O RCD("CATEG ORY")="I": "B",1:"C")
  431   "DATA",101 .41,52,10, 5,9)
  432   D PLACE^OR CDGMRC
  433   "DATA",101 .41,52,10, 6,0)
  434   6^17^^Atte ntion: 
  435   "DATA",101 .41,52,10, 6,1)
  436   Enter the  service/sp ecialty us er who is  to be noti fied of th is request .
  437   "DATA",101 .41,52,10, 6,3)
  438   I '$G(GMRC NOAT)
  439   "DATA",101 .41,52,10, 6,4)
  440   N ORT S OR T=$P(^(0), U,11) I 'O RT!(ORT>DT )
  441   "DATA",101 .41,52,10, 7,0)
  442   7^20^^Prov isional Di agnosis: 
  443   "DATA",101 .41,52,10, 7,1)
  444   Enter a pr eliminary  diagnosis  relating t o this req uest, up t o 240 char acters.
  445   "DATA",101 .41,52,10, 7,3)
  446   I '$G(GMRC NOPD)
  447   "DATA",101 .41,52,10, 7,5)
  448   D LEX^ORCD GMRC
  449   "DATA",101 .41,52,10, 7,9)
  450   D ENPDX^OR CDGMRC
  451   "DATA",101 .41,52,10, 8,0)
  452   1.1^166^^^ ^1
  453   "DATA",101 .41,52,10, 8,1)
  454   Enter the  service th at will be  requested  to perfor m this pro cedure
  455   "DATA",101 .41,52,10, 8,2)
  456   2^^^^Proc
  457   "DATA",101 .41,52,10, 8,3)
  458   I $G(ORDIA LOG(PROMPT ,"LIST"))> 0
  459   "DATA",101 .41,52,10, 8,6)
  460   D LIST^ORC D
  461   "DATA",101 .41,52,10, 8,7)
  462   S:+$G(ORDI ALOG(PROMP T,"LIST")) =1 Y=+$G(O RDIALOG(PR OMPT,"LIST ",1))
  463   "DATA",101 .41,52,10, 8,9)
  464   D PROCSVC^ ORCDGMRC
  465   "DATA",101 .41,52,10, 9,0)
  466   7.1^173^^^ ^^^^^^20
  467   "DATA",101 .41,52,10, 9,3)
  468   I 0 ;stuff ed in via  Prov Dx
  469   "DATA",101 .41,52,10, 10,0)
  470   4.5^15820^ ^Clinicall y Indicate d Date:^^1 ^^^W
  471   "DATA",101 .41,52,10, 10,1)
  472   Enter the  clinically  indicated  date for  this proce dure to be  performed .
  473   "DATA",101 .41,52,10, 10,5)
  474   Q:$G(ORTYP E)'="Z"  I  $G(ORDIAL OG(PROMPT, INST))'["T " K DONE W  $C(7),!," Response m ust be rel ative date  (e.g. TOD AY, T+7D,  T+3M)"
  475   "DATA",101 .41,52,10, 10,7)
  476   S Y=$$GET^ XPAR("DIV^ SYS^PKG"," ORCDGMRC C LIN IND DA TE DEFAULT ",1,"Q")
  477   "DATA",101 .41,52,10, 10,10)
  478   N X,Y,%DT  S X=$G(ORD IALOG(PROM PT,INST)), %DT="X" I  $L(X) D ^% DT S:Y>0 O RDATE=$P(Y ,".")
  479   "DATA",101 .41,52,10, 10,"W")
  480   calClinica llyIndicat ed
  481   "DATA",101 .41,52,10, 10,"W7")
  482   S Y=$$GET^ XPAR("DIV^ SYS^PKG"," ORCDGMRC C LIN IND DA TE DEFAULT ",1,"Q")
  483   "DATA",101 .41,52,99)
  484   64859,4529 6
  485   "DATA",101 .41,15992, 0)
  486   PSJ OR CLI NIC OE^Cli nic Medica tions^^D^6 2^2^197^1^ 2
  487   "DATA",101 .41,15992, 3)
  488   D PROVIDER ^ORCDPSIV  Q:$G(ORQUI T)  D EN^O RCDPS1("I" )
  489   "DATA",101 .41,15992, 3.1)
  490   D EN1^ORCD PS1
  491   "DATA",101 .41,15992, 4)
  492   D EXIT^ORC DPS1
  493   "DATA",101 .41,15992, 5)
  494   ^^^Clinic  Medication s^1444
  495   "DATA",101 .41,15992, 7)
  496   D SC^ORCDP S3
  497   "DATA",101 .41,15992, 10,0)
  498   ^101.412IA ^24^21
  499   "DATA",101 .41,15992, 10,1,0)
  500   1^4^^Medic ation: ^^1 ^^^^S.UD R X
  501   "DATA",101 .41,15992, 10,1,1)
  502   Enter the  medication  you wish  to order f or this pa tient.
  503   "DATA",101 .41,15992, 10,1,2)
  504   1^@1350
  505   "DATA",101 .41,15992, 10,1,4)
  506   I '$G(^(.1 ))!($G(^(. 1))>$$NOW^ XLFDT)
  507   "DATA",101 .41,15992, 10,1,5)
  508   D DEA^ORCD PS1 Q:'$G( DONE)  I $ G(ORESET)' =+Y D CHAN GED^ORCDPS 1("OI")
  509   "DATA",101 .41,15992, 10,1,6)
  510   N IDX,SCR  S IDX=$G(O RDIALOG(PR OMPT,"D")) ,SCR=$G(OR DIALOG(PRO MPT,"S"))  D XHELP^OR DD43(IDX,S CR)
  511   "DATA",101 .41,15992, 10,1,9)
  512   D ENOI^ORC DPS1
  513   "DATA",101 .41,15992, 10,1,10)
  514   S OROI=+$G (ORDIALOG( PROMPT,INS T)) D ORDI TM^ORCDPS1 (OROI),NFI ^ORCDPS1(O ROI)
  515   "DATA",101 .41,15992, 10,2,0)
  516   2^136^^Dos e: ^^1^1^^ C^^^^Instr uctions: 
  517   "DATA",101 .41,15992, 10,2,1)
  518   Enter the  dosage ins tructions  for this o rder, as a n amount a nd units.
  519   "DATA",101 .41,15992, 10,2,5)
  520   D CHDOSE^O RCDPS2 Q:' $G(DONE)   D DEFCONJ^ ORCDPS1
  521   "DATA",101 .41,15992, 10,2,6)
  522   D LIST^ORC D:$G(ORDIA LOG(PROMPT ,"LIST")), F^ORCDLGH: '$G(ORDIAL OG(PROMPT, "LIST"))
  523   "DATA",101 .41,15992, 10,2,9)
  524   D DOSES^OR CDPS2 I $G (ORDIALOG( PROMPT,"LI ST")),'$O( ORDIALOG(P ROMPT,0)), '$G(ORENEW ) D LIST^O RCD
  525   "DATA",101 .41,15992, 10,2,10)
  526   D EXDOSE^O RCDPS2
  527   "DATA",101 .41,15992, 10,4,0)
  528   2.2^170^^^ ^1^^^C^^13 6
  529   "DATA",101 .41,15992, 10,4,1)
  530   Enter a st andard sch edule for  administer ing this m edication.
  531   "DATA",101 .41,15992, 10,4,5)
  532   D CKSCH^OR CDPS1
  533   "DATA",101 .41,15992, 10,4,6)
  534   N DIC,D,X  S DIC="^PS (51.1,",DI C(0)="EQS" ,D="APPSJ" ,X="??" D  MIX^PSSDI( 51.1,"PSJ" ,.DIC,D,.X )
  535   "DATA",101 .41,15992, 10,4,7)
  536   S:$L($G(^T MP("PSJSCH ",$J))) Y= ^($J)
  537   "DATA",101 .41,15992, 10,4,9)
  538   I $G(ORTYP E)'="Z" S: ORCAT="I"  REQD=$$SCH REQ^PSJORP OE(OROUTE, OROI,$G(OR DRUG))
  539   "DATA",101 .41,15992, 10,4,10)
  540   S ORSCH=$G (ORDIALOG( PROMPT,INS T))
  541   "DATA",101 .41,15992, 10,5,0)
  542   8^7^^Prior ity: ^^1^^ ^C^S.PSO
  543   "DATA",101 .41,15992, 10,5,1)
  544   Enter the  urgency of  this orde r.
  545   "DATA",101 .41,15992, 10,5,2)
  546   6^^ROUTINE  DONE
  547   "DATA",101 .41,15992, 10,5,7)
  548   S Y=+$$REC ALL^ORCD(P ROMPT) S:Y  EDITONLY= 1 S:'Y Y=9
  549   "DATA",101 .41,15992, 10,5,9)
  550   S ORDIALOG (PROMPT,"D ")=$S(ORCA T="I":"S.P SJ",1:"S.P SO")
  551   "DATA",101 .41,15992, 10,6,0)
  552   10^15^^Com ments: ^^^ ^^C
  553   "DATA",101 .41,15992, 10,6,1)
  554   Enter any  additional  instructi ons for th is order.
  555   "DATA",101 .41,15992, 10,6,2)
  556   7
  557   "DATA",101 .41,15992, 10,6,3)
  558   I '$G(PSJN OPC)!($G(O RTYPE)="Z" )
  559   "DATA",101 .41,15992, 10,7,0)
  560   1.1^384^^^ ^^^^^^4
  561   "DATA",101 .41,15992, 10,7,2)
  562   ^@1350
  563   "DATA",101 .41,15992, 10,7,3)
  564   I 0 ;stuff ed in via  Instructio ns
  565   "DATA",101 .41,15992, 10,8,0)
  566   5.5^149^^^ ^^^^C
  567   "DATA",101 .41,15992, 10,8,1)
  568   Enter the  amount (nu mber of ta blets, e.g .) to be d ispensed.
  569   "DATA",101 .41,15992, 10,8,2)
  570   8^^^Quanti ty:^^1
  571   "DATA",101 .41,15992, 10,8,3)
  572   I ORCAT="O "
  573   "DATA",101 .41,15992, 10,8,7)
  574   I $G(ORCAT )="O",$G(O RTYPE)'="Z " S Y=$$QT Y^ORCDPS1  K:Y'>0 Y
  575   "DATA",101 .41,15992, 10,8,9)
  576   I ORCAT="O " W:$L($G( ORQTY)) !, ORQTY S OR DIALOG(PRO MPT,"A")=" Quantity"_ $S($L($G(O RQTYUNT)): " ("_ORQTY UNT_"): ", 1:": ")
  577   "DATA",101 .41,15992, 10,10,0)
  578   6^150^^Ref ills: ^^1^ ^^RC
  579   "DATA",101 .41,15992, 10,10,1)
  580   Enter the  number of  refills to  allow for  this orde r.
  581   "DATA",101 .41,15992, 10,10,2)
  582   9^^^Refill s:
  583   "DATA",101 .41,15992, 10,10,3)
  584   I ORCAT="O ",$G(OREFI LLS)>0
  585   "DATA",101 .41,15992, 10,10,9)
  586   I ORCAT="O ",'$G(OREF ILLS) D MA XREFS^ORCD PS1
  587   "DATA",101 .41,15992, 10,11,0)
  588   9^151^^Is  this medic ation for  a SC condi tion? ^^^^ ^CW^^^^SC:  
  589   "DATA",101 .41,15992, 10,11,1)
  590   If this me dication i s for trea tment of a  service-c onnected c ondition,  enter YES.
  591   "DATA",101 .41,15992, 10,11,3)
  592   I ORCAT="O ",$G(ORCOP AY),$G(ORS C)
  593   "DATA",101 .41,15992, 10,11,6)
  594   N DFN S DF N=+ORVP D  DIS^DGRPDB
  595   "DATA",101 .41,15992, 10,11,7)
  596   I $G(ORTYP E)'="Z",OR CAT="O",$G (ORCOPAY), $G(ORSC) S  Y=$S($P(O RSC,U,2)>5 0:1,1:0)
  597   "DATA",101 .41,15992, 10,11,9)
  598   I ORCAT="O " S ORCOPA Y=$$ASKSC^ ORCDPS1 I  ORCOPAY,$G (ORSC),'$D (ORDIALOG( PROMPT,INS T)) N DFN  S DFN=+ORV P D:$P(ORS C,U,2)'>50  DIS^DGRPD B S:$P(ORS C,U,2)>50  $P(ORDIALO G(PROMPT,0 ),U)="YA", EDITONLY=1  ; Req'd
  599   "DATA",101 .41,15992, 10,12,0)
  600   2.3^153^^H ow long: ^ ^^^^C^^136
  601   "DATA",101 .41,15992, 10,12,1)
  602   Enter the  length of  time over  which this  dose is t o be admin istered as  '4 HOURS' , '7 DAYS' , '2 WEEKS ', or '1 M ONTH'.
  603   "DATA",101 .41,15992, 10,12,2)
  604   ^^^FOR
  605   "DATA",101 .41,15992, 10,12,3)
  606   I $$ASKDUR ^ORCDPS3
  607   "DATA",101 .41,15992, 10,12,5)
  608   D DUR^ORCD PS3
  609   "DATA",101 .41,15992, 10,12,7)
  610   Q  I $G(OR TYPE)'="Z" ,$G(ORCAT) ="I",$G(OR COMPLX),$P ($G(ORSD), U,3) S Y=+ $P(ORSD,U, 3)_" DAYS"
  611   "DATA",101 .41,15992, 10,13,0)
  612   4^6^^Start : ^^^^1^C
  613   "DATA",101 .41,15992, 10,13,1)
  614   Enter the  date this  order shou ld begin.
  615   "DATA",101 .41,15992, 10,13,3)
  616   I $G(ORCAT )="O",$G(O REVENT) ;d ischarge o rders only
  617   "DATA",101 .41,15992, 10,13,7)
  618   Q  I $G(OR TYPE)'="Z" ,ORCAT'="O " S Y=$P($ G(ORSD),U)  K:'$L(Y)  Y
  619   "DATA",101 .41,15992, 10,13,9)
  620   D START^OR CDPS3 ;I ' FIRST,$G(O RDIALOG(PR OMPT,"LIST ")),'$O(OR DIALOG(PRO MPT,0)) D  LIST^ORCD  ;editonly
  621   "DATA",101 .41,15992, 10,14,0)
  622   3^385^^Tex t: 
  623   "DATA",101 .41,15992, 10,14,2)
  624   2^^^^^1^0
  625   "DATA",101 .41,15992, 10,14,3)
  626   I 0 ;creat ed by Inst ructions,  if Outpt o rder
  627   "DATA",101 .41,15992, 10,15,0)
  628   2.5^386^^^ ^^^^*^^136
  629   "DATA",101 .41,15992, 10,15,2)
  630   ^@
  631   "DATA",101 .41,15992, 10,15,3)
  632   I 0 ;creat ed by Inst ructions
  633   "DATA",101 .41,15992, 10,15,7)
  634   S Y=$$ID^O RCDPS K:'$ L(Y) Y
  635   "DATA",101 .41,15992, 10,16,0)
  636   2.6^138^^^ ^^^^*
  637   "DATA",101 .41,15992, 10,16,3)
  638   I 0 ;creat ed by Inst ructions
  639   "DATA",101 .41,15992, 10,18,0)
  640   1.5^1350
  641   "DATA",101 .41,15992, 10,18,2)
  642   1.5
  643   "DATA",101 .41,15992, 10,18,3)
  644   I 0 ;stuff ed in via  Instructio ns
  645   "DATA",101 .41,15992, 10,19,0)
  646   2.4^388^^^ ^^^^C^^136
  647   "DATA",101 .41,15992, 10,19,.1)
  648   D INPCONJ^ ORCDPS1
  649   "DATA",101 .41,15992, 10,19,1)
  650   Enter AND  if the nex t dose is  to be admi nistered c oncurrentl y with thi s one, or  THEN if it  is to fol low after.
  651   "DATA",101 .41,15992, 10,19,3)
  652   I $G(ORCOM PLX)
  653   "DATA",101 .41,15992, 10,19,5)
  654   I $G(ORESE T)'=$P(Y,U ) D CHANGE D^ORCDPS1( "QUANTITY" )
  655   "DATA",101 .41,15992, 10,19,9)
  656   D ENCONJ^O RCDPS1
  657   "DATA",101 .41,15992, 10,19,10)
  658   I $G(ORCOM PLX),'$L($ G(ORDIALOG (PROMPT,IN ST))),FIRS T,'$G(ORJU MP) S MAX= 1 ;stop pr ompting do se multipl e
  659   "DATA",101 .41,15992, 10,20,0)
  660   3.5^1358^^ ^^^^^C
  661   "DATA",101 .41,15992, 10,20,2)
  662   3
  663   "DATA",101 .41,15992, 10,20,3)
  664   I 0 ;text  stuffed vi a Entry Ac tion
  665   "DATA",101 .41,15992, 10,20,9)
  666   D PI^ORCDP S2
  667   "DATA",101 .41,15992, 10,21,0)
  668   4.5^1359
  669   "DATA",101 .41,15992, 10,21,2)
  670   10^^^First  Dose^^1
  671   "DATA",101 .41,15992, 10,21,3)
  672   I 0 ;set v ia Entry A ction
  673   "DATA",101 .41,15992, 10,21,9)
  674   D NOW^ORCD PS3
  675   "DATA",101 .41,15992, 10,22,0)
  676   2.7^15813^ ^^^^^^*^^1 36
  677   "DATA",101 .41,15992, 10,22,2)
  678   ^@
  679   "DATA",101 .41,15992, 10,22,3)
  680   I 0 ;from  Schedule
  681   "DATA",101 .41,15992, 10,23,0)
  682   2.8^716^^^ ^^^^*^^136
  683   "DATA",101 .41,15992, 10,23,2)
  684   ^@
  685   "DATA",101 .41,15992, 10,23,3)
  686   I 0 ;from  Schedule
  687   "DATA",101 .41,15992, 10,24,0)
  688   2.1^137^^^ ^1^^^C^^13 6
  689   "DATA",101 .41,15992, 10,24,1)
  690   Enter the  route of a dministrat ion for th is drug.
  691   "DATA",101 .41,15992, 10,24,2)
  692   ^1~3
  693   "DATA",101 .41,15992, 10,24,4)
  694   I $P(^(0), U,4)
  695   "DATA",101 .41,15992, 10,24,6)
  696   D LIST^ORC D:$G(ORDIA LOG(PROMPT ,"LIST"))& (X="?"),P^ ORCDLGH:'$ G(ORDIALOG (PROMPT,"L IST"))!(X' ="?")
  697   "DATA",101 .41,15992, 10,24,7)
  698   D DEFRTE^O RCDPS1
  699   "DATA",101 .41,15992, 10,24,9)
  700   D ROUTES^O RCDPS1
  701   "DATA",101 .41,15992, 10,24,10)
  702   S OROUTE=+ $G(ORDIALO G(PROMPT,I NST))
  703   "DATA",101 .41,15992, 99)
  704   64859,4529 6
  705   "FIA",101. 41)
  706   ORDER DIAL OG
  707   "FIA",101. 41,0)
  708   ^ORD(101.4 1,
  709   "FIA",101. 41,0,0)
  710   101.41I
  711   "FIA",101. 41,0,1)
  712   n^n^f^^y^^ y^r^n
  713   "FIA",101. 41,0,10)
  714  
  715   "FIA",101. 41,0,11)
  716   I $$SENDDL G^ORY397($ P(^(0),U))
  717   "FIA",101. 41,0,"RLRO ")
  718  
  719   "FIA",101. 41,0,"VR")
  720   3.0^OR
  721   "FIA",101. 41,101.41)
  722   0
  723   "FIA",101. 41,101.411 )
  724   0
  725   "FIA",101. 41,101.412 )
  726   0
  727   "FIA",101. 41,101.412 18)
  728   0
  729   "FIA",101. 41,101.415 )
  730   0
  731   "FIA",101. 41,101.416 )
  732   0
  733   "FIA",101. 41,101.416 2)
  734   0
  735   "FRV1",101 .41,"15992 ,0",5)
  736   CLINIC MED ICATIONS
  737   "FRV1",101 .41,"15992 ,0",5,"F")
  738   ;ORD(100.9 8,
  739   "FRV1",101 .41,"15992 ,0",7)
  740   INPATIENT  MEDICATION S
  741   "FRV1",101 .41,"15992 ,0",7,"F")
  742   ;DIC(9.4,
  743   "FRV1",101 .41,"15992 ,10,1,0",2 )
  744   OR GTX ORD ERABLE ITE M
  745   "FRV1",101 .41,"15992 ,10,1,0",2 ,"F")
  746   ;ORD(101.4 1,
  747   "FRV1",101 .41,"15992 ,10,10,0", 2)
  748   OR GTX REF ILLS
  749   "FRV1",101 .41,"15992 ,10,10,0", 2,"F")
  750   ;ORD(101.4 1,
  751   "FRV1",101 .41,"15992 ,10,11,0", 2)
  752   OR GTX SER VICE CONNE CTED
  753   "FRV1",101 .41,"15992 ,10,11,0", 2,"F")
  754   ;ORD(101.4 1,
  755   "FRV1",101 .41,"15992 ,10,12,0", 2)
  756   OR GTX DUR ATION
  757   "FRV1",101 .41,"15992 ,10,12,0", 2,"F")
  758   ;ORD(101.4 1,
  759   "FRV1",101 .41,"15992 ,10,12,0", 11)
  760   OR GTX INS TRUCTIONS
  761   "FRV1",101 .41,"15992 ,10,12,0", 11,"F")
  762   ;ORD(101.4 1,
  763   "FRV1",101 .41,"15992 ,10,13,0", 2)
  764   OR GTX STA RT DATE/TI ME
  765   "FRV1",101 .41,"15992 ,10,13,0", 2,"F")
  766   ;ORD(101.4 1,
  767   "FRV1",101 .41,"15992 ,10,14,0", 2)
  768   OR GTX SIG
  769   "FRV1",101 .41,"15992 ,10,14,0", 2,"F")
  770   ;ORD(101.4 1,
  771   "FRV1",101 .41,"15992 ,10,15,0", 2)
  772   OR GTX DOS E
  773   "FRV1",101 .41,"15992 ,10,15,0", 2,"F")
  774   ;ORD(101.4 1,
  775   "FRV1",101 .41,"15992 ,10,15,0", 11)
  776   OR GTX INS TRUCTIONS
  777   "FRV1",101 .41,"15992 ,10,15,0", 11,"F")
  778   ;ORD(101.4 1,
  779   "FRV1",101 .41,"15992 ,10,16,0", 2)
  780   OR GTX DIS PENSE DRUG
  781   "FRV1",101 .41,"15992 ,10,16,0", 2,"F")
  782   ;ORD(101.4 1,
  783   "FRV1",101 .41,"15992 ,10,18,0", 2)
  784   OR GTX DRU G NAME
  785   "FRV1",101 .41,"15992 ,10,18,0", 2,"F")
  786   ;ORD(101.4 1,
  787   "FRV1",101 .41,"15992 ,10,19,0", 2)
  788   OR GTX AND /THEN
  789   "FRV1",101 .41,"15992 ,10,19,0", 2,"F")
  790   ;ORD(101.4 1,
  791   "FRV1",101 .41,"15992 ,10,19,0", 11)
  792   OR GTX INS TRUCTIONS
  793   "FRV1",101 .41,"15992 ,10,19,0", 11,"F")
  794   ;ORD(101.4 1,
  795   "FRV1",101 .41,"15992 ,10,2,0",2 )
  796   OR GTX INS TRUCTIONS
  797   "FRV1",101 .41,"15992 ,10,2,0",2 ,"F")
  798   ;ORD(101.4 1,
  799   "FRV1",101 .41,"15992 ,10,20,0", 2)
  800   OR GTX PAT IENT INSTR UCTIONS
  801   "FRV1",101 .41,"15992 ,10,20,0", 2,"F")
  802   ;ORD(101.4 1,
  803   "FRV1",101 .41,"15992 ,10,21,0", 2)
  804   OR GTX NOW
  805   "FRV1",101 .41,"15992 ,10,21,0", 2,"F")
  806   ;ORD(101.4 1,
  807   "FRV1",101 .41,"15992 ,10,22,0", 2)
  808   OR GTX ADM IN TIMES
  809   "FRV1",101 .41,"15992 ,10,22,0", 2,"F")
  810   ;ORD(101.4 1,
  811   "FRV1",101 .41,"15992 ,10,22,0", 11)
  812   OR GTX INS TRUCTIONS
  813   "FRV1",101 .41,"15992 ,10,22,0", 11,"F")
  814   ;ORD(101.4 1,
  815   "FRV1",101 .41,"15992 ,10,23,0", 2)
  816   OR GTX SCH EDULE TYPE
  817   "FRV1",101 .41,"15992 ,10,23,0", 2,"F")
  818   ;ORD(101.4 1,
  819   "FRV1",101 .41,"15992 ,10,23,0", 11)
  820   OR GTX INS TRUCTIONS
  821   "FRV1",101 .41,"15992 ,10,23,0", 11,"F")
  822   ;ORD(101.4 1,
  823   "FRV1",101 .41,"15992 ,10,24,0", 2)
  824   OR GTX ROU TE
  825   "FRV1",101 .41,"15992 ,10,24,0", 2,"F")
  826   ;ORD(101.4 1,
  827   "FRV1",101 .41,"15992 ,10,24,0", 11)
  828   OR GTX INS TRUCTIONS
  829   "FRV1",101 .41,"15992 ,10,24,0", 11,"F")
  830   ;ORD(101.4 1,
  831   "FRV1",101 .41,"15992 ,10,4,0",2 )
  832   OR GTX SCH EDULE
  833   "FRV1",101 .41,"15992 ,10,4,0",2 ,"F")
  834   ;ORD(101.4 1,
  835   "FRV1",101 .41,"15992 ,10,4,0",1 1)
  836   OR GTX INS TRUCTIONS
  837   "FRV1",101 .41,"15992 ,10,4,0",1 1,"F")
  838   ;ORD(101.4 1,
  839   "FRV1",101 .41,"15992 ,10,5,0",2 )
  840   OR GTX URG ENCY
  841   "FRV1",101 .41,"15992 ,10,5,0",2 ,"F")
  842   ;ORD(101.4 1,
  843   "FRV1",101 .41,"15992 ,10,6,0",2 )
  844   OR GTX WOR D PROCESSI NG 1
  845   "FRV1",101 .41,"15992 ,10,6,0",2 ,"F")
  846   ;ORD(101.4 1,
  847   "FRV1",101 .41,"15992 ,10,7,0",2 )
  848   OR GTX STR ENGTH
  849   "FRV1",101 .41,"15992 ,10,7,0",2 ,"F")
  850   ;ORD(101.4 1,
  851   "FRV1",101 .41,"15992 ,10,7,0",1 1)
  852   OR GTX ORD ERABLE ITE M
  853   "FRV1",101 .41,"15992 ,10,7,0",1 1,"F")
  854   ;ORD(101.4 1,
  855   "FRV1",101 .41,"15992 ,10,8,0",2 )
  856   OR GTX QUA NTITY
  857   "FRV1",101 .41,"15992 ,10,8,0",2 ,"F")
  858   ;ORD(101.4 1,
  859   "FRV1",101 .41,"51,0" ,5)
  860   CONSULTS
  861   "FRV1",101 .41,"51,0" ,5,"F")
  862   ;ORD(100.9 8,
  863   "FRV1",101 .41,"51,0" ,7)
  864   CONSULT/RE QUEST TRAC KING
  865   "FRV1",101 .41,"51,0" ,7,"F")
  866   ;DIC(9.4,
  867   "FRV1",101 .41,"51,10 ,1,0",2)
  868   OR GTX ORD ERABLE ITE M
  869   "FRV1",101 .41,"51,10 ,1,0",2,"F ")
  870   ;ORD(101.4 1,
  871   "FRV1",101 .41,"51,10 ,10,0",2)
  872   OR GTX CLI NICALLY IN DICATED DA TE
  873   "FRV1",101 .41,"51,10 ,10,0",2," F")
  874   ;ORD(101.4 1,
  875   "FRV1",101 .41,"51,10 ,2,0",2)
  876   OR GTX WOR D PROCESSI NG 1
  877   "FRV1",101 .41,"51,10 ,2,0",2,"F ")
  878   ;ORD(101.4 1,
  879   "FRV1",101 .41,"51,10 ,3,0",2)
  880   OR GTX CAT EGORY
  881   "FRV1",101 .41,"51,10 ,3,0",2,"F ")
  882   ;ORD(101.4 1,
  883   "FRV1",101 .41,"51,10 ,4,0",2)
  884   OR GTX URG ENCY
  885   "FRV1",101 .41,"51,10 ,4,0",2,"F ")
  886   ;ORD(101.4 1,
  887   "FRV1",101 .41,"51,10 ,5,0",2)
  888   OR GTX PLA CE OF CONS ULTATION
  889   "FRV1",101 .41,"51,10 ,5,0",2,"F ")
  890   ;ORD(101.4 1,
  891   "FRV1",101 .41,"51,10 ,6,0",2)
  892   OR GTX PRO VIDER
  893   "FRV1",101 .41,"51,10 ,6,0",2,"F ")
  894   ;ORD(101.4 1,
  895   "FRV1",101 .41,"51,10 ,7,0",2)
  896   OR GTX FRE E TEXT
  897   "FRV1",101 .41,"51,10 ,7,0",2,"F ")
  898   ;ORD(101.4 1,
  899   "FRV1",101 .41,"51,10 ,8,0",2)
  900   OR GTX FRE E TEXT OI
  901   "FRV1",101 .41,"51,10 ,8,0",2,"F ")
  902   ;ORD(101.4 1,
  903   "FRV1",101 .41,"51,10 ,9,0",2)
  904   OR GTX COD E
  905   "FRV1",101 .41,"51,10 ,9,0",2,"F ")
  906   ;ORD(101.4 1,
  907   "FRV1",101 .41,"51,10 ,9,0",11)
  908   OR GTX FRE E TEXT
  909   "FRV1",101 .41,"51,10 ,9,0",11," F")
  910   ;ORD(101.4 1,
  911   "FRV1",101 .41,"52,0" ,5)
  912   PROCEDURES
  913   "FRV1",101 .41,"52,0" ,5,"F")
  914   ;ORD(100.9 8,
  915   "FRV1",101 .41,"52,0" ,7)
  916   CONSULT/RE QUEST TRAC KING
  917   "FRV1",101 .41,"52,0" ,7,"F")
  918   ;DIC(9.4,
  919   "FRV1",101 .41,"52,10 ,1,0",2)
  920   OR GTX ORD ERABLE ITE M
  921   "FRV1",101 .41,"52,10 ,1,0",2,"F ")
  922   ;ORD(101.4 1,
  923   "FRV1",101 .41,"52,10 ,10,0",2)
  924   OR GTX CLI NICALLY IN DICATED DA TE
  925   "FRV1",101 .41,"52,10 ,10,0",2," F")
  926   ;ORD(101.4 1,
  927   "FRV1",101 .41,"52,10 ,2,0",2)
  928   OR GTX WOR D PROCESSI NG 1
  929   "FRV1",101 .41,"52,10 ,2,0",2,"F ")
  930   ;ORD(101.4 1,
  931   "FRV1",101 .41,"52,10 ,3,0",2)
  932   OR GTX CAT EGORY
  933   "FRV1",101 .41,"52,10 ,3,0",2,"F ")
  934   ;ORD(101.4 1,
  935   "FRV1",101 .41,"52,10 ,4,0",2)
  936   OR GTX URG ENCY
  937   "FRV1",101 .41,"52,10 ,4,0",2,"F ")
  938   ;ORD(101.4 1,
  939   "FRV1",101 .41,"52,10 ,5,0",2)
  940   OR GTX PLA CE OF CONS ULTATION
  941   "FRV1",101 .41,"52,10 ,5,0",2,"F ")
  942   ;ORD(101.4 1,
  943   "FRV1",101 .41,"52,10 ,6,0",2)
  944   OR GTX PRO VIDER
  945   "FRV1",101 .41,"52,10 ,6,0",2,"F ")
  946   ;ORD(101.4 1,
  947   "FRV1",101 .41,"52,10 ,7,0",2)
  948   OR GTX FRE E TEXT
  949   "FRV1",101 .41,"52,10 ,7,0",2,"F ")
  950   ;ORD(101.4 1,
  951   "FRV1",101 .41,"52,10 ,8,0",2)
  952   OR GTX REQ UEST SERVI CE
  953   "FRV1",101 .41,"52,10 ,8,0",2,"F ")
  954   ;ORD(101.4 1,
  955   "FRV1",101 .41,"52,10 ,9,0",2)
  956   OR GTX COD E
  957   "FRV1",101 .41,"52,10 ,9,0",2,"F ")
  958   ;ORD(101.4 1,
  959   "FRV1",101 .41,"52,10 ,9,0",11)
  960   OR GTX FRE E TEXT
  961   "FRV1",101 .41,"52,10 ,9,0",11," F")
  962   ;ORD(101.4 1,
  963   "INIT")
  964   EN^ORY397A
  965   "IX",101.4 1,101.41," B",0)
  966   101.41^B^R egular B i ndex using  full fiel d length^R ^^F^IR^I^1 01.41^^^^^ LS
  967   "IX",101.4 1,101.41," B",1)
  968   S ^ORD(101 .41,"B",$E (X,1,63),D A)=""
  969   "IX",101.4 1,101.41," B",2)
  970   K ^ORD(101 .41,"B",$E (X,1,63),D A)
  971   "IX",101.4 1,101.41," B",2.5)
  972   K ^ORD(101 .41,"B")
  973   "IX",101.4 1,101.41," B",11.1,0)
  974   ^.114IA^1^ 1
  975   "IX",101.4 1,101.41," B",11.1,1, 0)
  976   1^F^101.41 ^.01^63^1^ F
  977   "KRN",19,1 1057,-1)
  978   3^1
  979   "KRN",19,1 1057,0)
  980   OR PARAM C OORDINATOR  MENU^CPRS  Configura tion (Clin  Coord)^^M ^^^^^^^^^^
  981   "KRN",19,1 1057,1,0)
  982   ^^2^2^2971 112^^^^
  983   "KRN",19,1 1057,1,1,0 )
  984   This menu  is for edi ting CPRS  Configurat ion Parame ters.  It  should
  985   "KRN",19,1 1057,1,2,0 )
  986   be availab le to the  Clinical C oordinator  and IRM S taff.
  987   "KRN",19,1 1057,10,0)
  988   ^19.01IP^2 8^28
  989   "KRN",19,1 1057,10,28 ,0)
  990   14383^CS^6 0
  991   "KRN",19,1 1057,10,28 ,"^")
  992   OR CS ORDE R ANOMALIE S
  993   "KRN",19,1 1057,20)
  994  
  995   "KRN",19,1 1057,99)
  996   64127,5086 3
  997   "KRN",19,1 1057,99.1)
  998   65049,2160 3
  999   "KRN",19,1 1057,"U")
  1000   CPRS CONFI GURATION ( CLIN COORD
  1001   "KRN",19,1 4383,-1)
  1002   0^2
  1003   "KRN",19,1 4383,0)
  1004   OR CS ORDE R ANOMALIE S^Controll ed Substan ce Order A nomalies^^ R^^^^^^^^O RDER ENTRY /RESULTS R EPORTING
  1005   "KRN",19,1 4383,1,0)
  1006   ^^11^11^31 60518^
  1007   "KRN",19,1 4383,1,1,0 )
  1008   This repor t will fin d all orde rs for con trolled su bstances f or
  1009   "KRN",19,1 4383,1,2,0 )
  1010   Schedule 2 -5 medicat ions that  are missin g a Digita l Signatur e. All ord ers for 
  1011   "KRN",19,1 4383,1,3,0 )
  1012   these cont rolled sub stances re quire a Di gital Sign ature to c omply with  DEA
  1013   "KRN",19,1 4383,1,4,0 )
  1014   regulation s. The pur pose of th is report  is to dete rmine the  extent of  this
  1015   "KRN",19,1 4383,1,5,0 )
  1016   problem in  hopes to  determine  how these  orders are  placed in to the sys tem
  1017   "KRN",19,1 4383,1,6,0 )
  1018   without a  Digital Si gnature.  
  1019   "KRN",19,1 4383,1,7,0 )
  1020     
  1021   "KRN",19,1 4383,1,8,0 )
  1022   CPRS versi on 29 is w hen the ab ility to o rder Contr olled Subs tances wit
  1023   "KRN",19,1 4383,1,9,0 )
  1024   Digital Si gnatures b egan. This  report lo oks up the  date that  CPRS v29  was
  1025   "KRN",19,1 4383,1,10, 0)
  1026   installed  and presen ts that da te as a de fault star t date for  the repor t. Any
  1027   "KRN",19,1 4383,1,11, 0)
  1028   date range  can be en tered to d o the look up.
  1029   "KRN",19,1 4383,25)
  1030   EN^ORS100C
  1031   "KRN",19,1 4383,"U")
  1032   CONTROLLED  SUBSTANCE  ORDER ANO
  1033   "KRN",19,1 4387,-1)
  1034   2^4
  1035   "KRN",19,1 4387,0)
  1036   OR SUPPLY  UTIL MENU^ SUPPLY COV ERSION UTI LITY MENU^ ^M^1000000 0191
  1037   "KRN",19,1 4387,10,0)
  1038   ^19.01IP^3 ^3
  1039   "KRN",19,1 4387,10,3, 0)
  1040   14582^QO
  1041   "KRN",19,1 4387,10,3, "^")
  1042   OR SUPPLY  QO CONVERS ION
  1043   "KRN",19,1 4387,"U")
  1044   SUPPLY COV ERSION UTI LITY MENU
  1045   "KRN",19,1 4582,-1)
  1046   0^3
  1047   "KRN",19,1 4582,0)
  1048   OR SUPPLY  QO CONVERS ION^CONVER T SUPPLY Q UICK ORDER S^^R^^^^^^ ^^
  1049   "KRN",19,1 4582,1,0)
  1050   ^^3^3^3170 828^
  1051   "KRN",19,1 4582,1,1,0 )
  1052   Use this o ption to c onvert all  Outpatien t Medicati on quick o rders that
  1053   "KRN",19,1 4582,1,2,0 )
  1054   were built  for order able items  that are  considered  supply it ems, to us e
  1055   "KRN",19,1 4582,1,3,0 )
  1056   the PSO SU PPLY dialo g.
  1057   "KRN",19,1 4582,25)
  1058   SUPPLYQO^O RSPUTIL
  1059   "KRN",19,1 4582,"U")
  1060   CONVERT SU PPLY QUICK  ORDERS
  1061   "KRN",101, 6434,-1)
  1062   0^1
  1063   "KRN",101, 6434,0)
  1064   OR COMPLET E ORDER^Co mplete^^X^ ^^^^^^^
  1065   "KRN",101, 6434,1,0)
  1066   ^101.06^5^ 5^3180914^ ^^^
  1067   "KRN",101, 6434,1,1,0 )
  1068   The purpos e of this  protocol i s to creat e a way fo r packages  (includin
  1069   "KRN",101, 6434,1,2,0 )
  1070   COTS or Cl ass 3) to  receive no tification s when an  order is s et to a 
  1071   "KRN",101, 6434,1,3,0 )
  1072   complete s tatus in C PRS.
  1073   "KRN",101, 6434,1,4,0 )
  1074    
  1075   "KRN",101, 6434,1,5,0 )
  1076   The array  ORINFO wil l be passe d to the p rotocol. 
  1077   "KRN",101, 6434,10,0)
  1078   ^101.01PA^ 1^1
  1079   "KRN",101, 6434,99)
  1080   64905,3799 1
  1081   "MBREQ")
  1082   0
  1083   "ORD",15,1 01)
  1084   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  1085   "ORD",15,1 01,0)
  1086   PROTOCOL
  1087   "ORD",18,1 9)
  1088   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  1089   "ORD",18,1 9,0)
  1090   OPTION
  1091   "PGL",101. 41,0,5,5)
  1092   DISPLAY GR OUP^P100.9 8'^ORD(100 .98,^0;5^Q
  1093   "PGL",101. 41,0,7,7)
  1094   PACKAGE^P9 .4'^DIC(9. 4,^0;7^Q
  1095   "PGL",101. 412,0,2,2)
  1096   ITEM^P101. 41'X^ORD(1 01.41,^0;2 ^D TREE^OR DD41
  1097   "PGL",101. 412,0,11,1 )
  1098   PARENT^P10 1.41'^ORD( 101.41,^0; 11^Q
  1099   "PGL",101. 415,0,2,2)
  1100   ITEM^P101. 41'^ORD(10 1.41,^0;2^ Q
  1101   "PGL",101. 416,0,2,.0 2)
  1102   DIALOG^P10 1.41'^ORD( 101.41,^0; 2^Q
  1103   "PKG",170, -1)
  1104   1^1
  1105   "PKG",170, 0)
  1106   ORDER ENTR Y/RESULTS  REPORTING^ OR^Order E ntry/Resul ts Reporti ng
  1107   "PKG",170, 22,0)
  1108   ^9.49I^1^1
  1109   "PKG",170, 22,1,0)
  1110   3.0^297121 7^2980917^ 11712
  1111   "PKG",170, 22,1,"PAH" ,1,0)
  1112   397^319020 5^10000000 200
  1113   "QUES","XP F1",0)
  1114   Y
  1115   "QUES","XP F1","??")
  1116   ^D REP^XPD H
  1117   "QUES","XP F1","A")
  1118   Shall I wr ite over y our |FLAG|  File
  1119   "QUES","XP F1","B")
  1120   YES
  1121   "QUES","XP F1","M")
  1122   D XPF1^XPD IQ
  1123   "QUES","XP F2",0)
  1124   Y
  1125   "QUES","XP F2","??")
  1126   ^D DTA^XPD H
  1127   "QUES","XP F2","A")
  1128   Want my da ta |FLAG|  yours
  1129   "QUES","XP F2","B")
  1130   YES
  1131   "QUES","XP F2","M")
  1132   D XPF2^XPD IQ
  1133   "QUES","XP I1",0)
  1134   YO
  1135   "QUES","XP I1","??")
  1136   ^D INHIBIT ^XPDH
  1137   "QUES","XP I1","A")
  1138   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  1139   "QUES","XP I1","B")
  1140   NO
  1141   "QUES","XP I1","M")
  1142   D XPI1^XPD IQ
  1143   "QUES","XP M1",0)
  1144   PO^VA(200, :EM
  1145   "QUES","XP M1","??")
  1146   ^D MG^XPDH
  1147   "QUES","XP M1","A")
  1148   Enter the  Coordinato r for Mail  Group '|F LAG|'
  1149   "QUES","XP M1","B")
  1150  
  1151   "QUES","XP M1","M")
  1152   D XPM1^XPD IQ
  1153   "QUES","XP O1",0)
  1154   Y
  1155   "QUES","XP O1","??")
  1156   ^D MENU^XP DH
  1157   "QUES","XP O1","A")
  1158   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  1159   "QUES","XP O1","B")
  1160   NO
  1161   "QUES","XP O1","M")
  1162   D XPO1^XPD IQ
  1163   "QUES","XP Z1",0)
  1164   Y
  1165   "QUES","XP Z1","??")
  1166   ^D OPT^XPD H
  1167   "QUES","XP Z1","A")
  1168   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  1169   "QUES","XP Z1","B")
  1170   NO
  1171   "QUES","XP Z1","M")
  1172   D XPZ1^XPD IQ
  1173   "QUES","XP Z2",0)
  1174   Y
  1175   "QUES","XP Z2","??")
  1176   ^D RTN^XPD H
  1177   "QUES","XP Z2","A")
  1178   Want to MO VE routine s to other  CPUs
  1179   "QUES","XP Z2","B")
  1180   NO
  1181   "QUES","XP Z2","M")
  1182   D XPZ2^XPD IQ
  1183   "RTN")
  1184   18
  1185   "RTN","ORC ACT01")
  1186   0^16^B8992 7371
  1187   "RTN","ORC ACT01",1,0 )
  1188   ORCACT01 ; SLC/MKB-Va lidate ord er actions  cont ;Aug  24, 2018@ 08:17
  1189   "RTN","ORC ACT01",2,0 )
  1190    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**9 4,116,134, 141,163,18 7,190,213, 243,306,37 4,350,397* *;Dec 17,  1997;Build  17
  1191   "RTN","ORC ACT01",3,0 )
  1192    ;
  1193   "RTN","ORC ACT01",4,0 )
  1194    ;
  1195   "RTN","ORC ACT01",5,0 )
  1196    ;
  1197   "RTN","ORC ACT01",6,0 )
  1198   ES ; -- si gn [on cha rt]
  1199   "RTN","ORC ACT01",7,0 )
  1200    I ORDSTS= 11,VER<3,P KG'="OR" S  ERROR="Th is order c annot be r eleased an d must be  discontinu ed!" Q
  1201   "RTN","ORC ACT01",8,0 )
  1202    N X I ACT STS=11!(AC TSTS=10) D   Q:$L($G( ERROR))
  1203   "RTN","ORC ACT01",9,0 )
  1204    . I $P(OR A0,U,2)="D C",$$DONE^ ORCACT0 D  CANCEL^ORC SEND(+IFN) ,UNOTIF^OR CSIGN S OR EBUILD=1 Q
  1205   "RTN","ORC ACT01",10, 0)
  1206    . S X=$$D ISABLED^OR CACT0 I X  S ERROR=$P (X,U,2) Q
  1207   "RTN","ORC ACT01",11, 0)
  1208    I ACTION= "OC",$G(DG )="NV RX"  S:MEDPARM< 2 ERROR="Y ou are not  authorize d to relea se non-VA  med orders !" Q
  1209   "RTN","ORC ACT01",12, 0)
  1210    S X=$P(OR A0,U,4) I  X=3 S:ACTS TS'=11&(AC TSTS'=10)  ERROR="Thi s order do es not req uire a sig nature!" Q
  1211   "RTN","ORC ACT01",13, 0)
  1212    I X'=2 S  ERROR="Thi s order ha s been sig ned!" Q
  1213   "RTN","ORC ACT01",14, 0)
  1214    N ORCS D  CSVALUE^OR DEA(.ORCS, +IFN)
  1215   "RTN","ORC ACT01",15, 0)
  1216    I DG="O R X",ACTION= "RS",$G(NA TR)="I",OR CS=1 S ERR OR="Contro lled Subst ance outpa tient meds  may not b e released  without a  clinician 's signatu re!" Q
  1217   "RTN","ORC ACT01",16, 0)
  1218    I DG="O R X",ACTION' ="ES",ACTI ON'="DS",$ G(NATR)'=" I" S ERROR ="Outpatie nt meds ma y not be r eleased wi thout a cl inician's  signature! " Q
  1219   "RTN","ORC ACT01",17, 0)
  1220    I (ACTION ="ES"!(ACT ION="DS")) ,$D(^XUSEC ("ORELSE", DUZ)),$P(O R0,U,16)'< 2 S ERROR= "You are n ot privile ged to sig n this ord er!" Q
  1221   "RTN","ORC ACT01",18, 0)
  1222    ;
  1223   "RTN","ORC ACT01",19, 0)
  1224    I DG="SPL Y" D  Q:$D (ERROR)
  1225   "RTN","ORC ACT01",20, 0)
  1226    . N ORALL OWED,ORAUT HMEDS,ORHA SSUPKEY,OR X
  1227   "RTN","ORC ACT01",21, 0)
  1228    . ; User  must have  ORSUPPLY o r Auth to  Write Meds  to releas e supply i tems
  1229   "RTN","ORC ACT01",22, 0)
  1230    . S ORHAS SUPKEY=$D( ^XUSEC("OR SUPPLY",DU Z))
  1231   "RTN","ORC ACT01",23, 0)
  1232    . S ORAUT HMEDS=1
  1233   "RTN","ORC ACT01",24, 0)
  1234    . S ORX=$ G(^VA(200, DUZ,"PS"))
  1235   "RTN","ORC ACT01",25, 0)
  1236    . I '$P(O RX,U)!($P( ORX,U,4)&( DT>$P(ORX, U,4))) S O RAUTHMEDS= 0
  1237   "RTN","ORC ACT01",26, 0)
  1238    . I 'ORHA SSUPKEY,'O RAUTHMEDS  D  Q
  1239   "RTN","ORC ACT01",27, 0)
  1240    . . S ERR OR="You ar e not auth orized to  release su pply order s."
  1241   "RTN","ORC ACT01",28, 0)
  1242    . ; only  allow rele ase by pol icy, signe d on chart , or ES
  1243   "RTN","ORC ACT01",29, 0)
  1244    . ; relea se via ver bal or tel ephone is  not allowe d
  1245   "RTN","ORC ACT01",30, 0)
  1246    . S ORALL OWED=0
  1247   "RTN","ORC ACT01",31, 0)
  1248    . I ACTIO N?1(1"ES", 1"DS",1"OC ") S ORALL OWED=1
  1249   "RTN","ORC ACT01",32, 0)
  1250    . I ACTIO N="RS",$G( NATR)?1(1" I",1"W") S  ORALLOWED =1
  1251   "RTN","ORC ACT01",33, 0)
  1252    . I 'ORAL LOWED S ER ROR="Suppl ies may no t be relea sed with t his action ."
  1253   "RTN","ORC ACT01",34, 0)
  1254    ;
  1255   "RTN","ORC ACT01",35, 0)
  1256    I ACTION= "OC" S:MED PARM<2 ERR OR="You ar e not auth orized to  release me d orders!"  Q
  1257   "RTN","ORC ACT01",36, 0)
  1258    I ACTION= "RS" D  Q: $D(ERROR)   Q:$G(NATR )'="I"
  1259   "RTN","ORC ACT01",37, 0)
  1260    . Q:ACTST S=11  Q:AC TSTS=10  ; unreleased  - ok
  1261   "RTN","ORC ACT01",38, 0)
  1262    . S ERROR ="This ord er has alr eady been  released!"
  1263   "RTN","ORC ACT01",39, 0)
  1264   ES1 I PKG= "PS" D  ;a uthorized  to write m eds?
  1265   "RTN","ORC ACT01",40, 0)
  1266    . N TYPE, OI,PSOI,DE AFLG,PKI,I VERROR,ORD GNM
  1267   "RTN","ORC ACT01",41, 0)
  1268    . S X=$G( ^VA(200,DU Z,"PS"))
  1269   "RTN","ORC ACT01",42, 0)
  1270    . I DG'=" SPLY",'$P( X,U) S ERR OR="You ar e not auth orized to  sign med o rders!" Q
  1271   "RTN","ORC ACT01",43, 0)
  1272    . I DG'=" SPLY",$P(X ,U,4),$$NO W^XLFDT>$P (X,U,4) S  ERROR="You  are no lo nger autho rized to s ign med or ders!" Q
  1273   "RTN","ORC ACT01",44, 0)
  1274    . ;Q:DG=" IV RX"  Q: $P(ORA0,U, 2)="DC"  ; don't need  to ck DEA #
  1275   "RTN","ORC ACT01",45, 0)
  1276    . Q:$P(OR A0,U,2)="D C"
  1277   "RTN","ORC ACT01",46, 0)
  1278    . S ORDGN M=$$GET1^D IQ(100,+IF N_",",2)
  1279   "RTN","ORC ACT01",47, 0)
  1280    . I ORDGN M["FLUID O E" D  Q
  1281   "RTN","ORC ACT01",48, 0)
  1282    . .S FAIL =$$IVDEACH K(+IFN) I  FAIL'=0 S  ERROR=FAIL
  1283   "RTN","ORC ACT01",49, 0)
  1284    . S OI=+$ $VALUE^ORX 8(+IFN,"OR DERABLE")
  1285   "RTN","ORC ACT01",50, 0)
  1286    . S PSOI= +$P($G(^OR D(101.43,O I,0)),U,2)  Q:PSOI'>0
  1287   "RTN","ORC ACT01",51, 0)
  1288    . S TYPE= $S($P(DG,"  ")="O":"O ",1:"I"),D EAFLG=$P($ $OIDEA^PSS OPKI(PSOI, TYPE),";", 2)
  1289   "RTN","ORC ACT01",52, 0)
  1290    . S DETFL AG=$$OIDET OX^PSSOPKI (PSOI,TYPE )
  1291   "RTN","ORC ACT01",53, 0)
  1292    . S DETPR O=$$DETOX^ XUSER(+$G( DUZ))
  1293   "RTN","ORC ACT01",54, 0)
  1294    . I DETFL AG,DETPRO= "" S ERROR =3 Q
  1295   "RTN","ORC ACT01",55, 0)
  1296    . I DETFL AG,DETPRO> 0 S Y=DETP RO X ^DD(" DD") S ERR OR="5^"_Y  Q
  1297   "RTN","ORC ACT01",56, 0)
  1298    . I (DEAF LG>0!($$IS CLOZ^ORALW ORD(OI)))  D  I $G(ER ROR)]"" Q
  1299   "RTN","ORC ACT01",57, 0)
  1300    .. N RET
  1301   "RTN","ORC ACT01",58, 0)
  1302    .. I $$IS CLOZ^ORALW ORD(OI) D   Q
  1303   "RTN","ORC ACT01",59, 0)
  1304    ... S RET =$$DEA^XUS ER(,DUZ) I  RET="" S  ERROR=1
  1305   "RTN","ORC ACT01",60, 0)
  1306    .. S RET= $$SDEA^XUS ER(,DUZ,DE AFLG)
  1307   "RTN","ORC ACT01",61, 0)
  1308    .. I RET= 1 S ERROR= 1 Q
  1309   "RTN","ORC ACT01",62, 0)
  1310    .. I RET= 2 S ERROR= "2^"_$$UP^ XLFSTR(DEA FLG) Q
  1311   "RTN","ORC ACT01",63, 0)
  1312    .. I RET? 1"4".E S E RROR=RET Q
  1313   "RTN","ORC ACT01",64, 0)
  1314    .. I RET? 1N.E S ERR OR=RET
  1315   "RTN","ORC ACT01",65, 0)
  1316    . D PKISI TE^ORWOR(. PKI)
  1317   "RTN","ORC ACT01",66, 0)
  1318    . I $G(PK I),ACTION= "RS",DEAFL G=1 S ERRO R="This or der cannot  be releas ed without  a Digital  Signature " Q
  1319   "RTN","ORC ACT01",67, 0)
  1320    Q
  1321   "RTN","ORC ACT01",68, 0)
  1322    ;
  1323   "RTN","ORC ACT01",69, 0)
  1324   IVDEACHK(I FN) ; -- R eturns val ue of prom pt by ID
  1325   "RTN","ORC ACT01",70, 0)
  1326    I '$G(IFN )!('$D(^OR (100,+$G(I FN),0))) Q  ""
  1327   "RTN","ORC ACT01",71, 0)
  1328    N I,DIAL, DIALTYP,FA IL,PATCLAS S,RESULT,Y
  1329   "RTN","ORC ACT01",72, 0)
  1330    S PATCLAS S=$P(^OR(1 00,+IFN,0) ,U,12)
  1331   "RTN","ORC ACT01",73, 0)
  1332    S RESULT= 0
  1333   "RTN","ORC ACT01",74, 0)
  1334    ;if ORNP  is not set  then assu me this is  called fr om VistA n ot CPRS
  1335   "RTN","ORC ACT01",75, 0)
  1336    I $G(ORNP )="" S ORN P=DUZ
  1337   "RTN","ORC ACT01",76, 0)
  1338    S I=0,Y=" " S:'$G(IN ST) INST=1
  1339   "RTN","ORC ACT01",77, 0)
  1340    F  S I=$O (^OR(100,+ IFN,4.5,"I D","ORDERA BLE",I)) Q :I'>0!(RES ULT=1)  D
  1341   "RTN","ORC ACT01",78, 0)
  1342    .S Y=$G(^ OR(100,+IF N,4.5,I,1) ) Q:Y'>0
  1343   "RTN","ORC ACT01",79, 0)
  1344    .;S PSOI= +$P($G(^OR D(101.43,Y ,0)),U,2)  Q:PSOI'>0
  1345   "RTN","ORC ACT01",80, 0)
  1346    .I PATCLA SS="I" D   Q
  1347   "RTN","ORC ACT01",81, 0)
  1348    ..D FAILD EA^ORWDPS1 (.FAIL,Y,O RNP,"I") I  FAIL'=0 S  RESULT=FA IL
  1349   "RTN","ORC ACT01",82, 0)
  1350    .S DIAL=+ $P(^OR(100 ,+IFN,4.5, I,0),U,2)
  1351   "RTN","ORC ACT01",83, 0)
  1352    .S DIALTY P=$S($P(^O RD(101.41, DIAL,0),U) ["ADDITIVE ":"A",1:"S ")
  1353   "RTN","ORC ACT01",84, 0)
  1354    .D FDEA1^ ORWDPS1(.F AIL,Y,DIAL TYP,ORNP)
  1355   "RTN","ORC ACT01",85, 0)
  1356    .I FAIL'= 0 S RESULT =FAIL
  1357   "RTN","ORC ACT01",86, 0)
  1358    .;I $$OID EA^PSSUTLA 1(PSOI,"I" )>0 S RESU LT=1 Q
  1359   "RTN","ORC ACT01",87, 0)
  1360    Q RESULT
  1361   "RTN","ORC ACT01",88, 0)
  1362    ;
  1363   "RTN","ORC ACT01",89, 0)
  1364   XFR ; -- t ransfer to  inpt/outp t [IFN=ord er to be t ransferred ]
  1365   "RTN","ORC ACT01",90, 0)
  1366    N OI,PS I  DG="TPN"  S ERROR="T PN orders  may not be  copied!"  Q
  1367   "RTN","ORC ACT01",91, 0)
  1368    I $$INACT IVE^ORCACT 03 S ERROR ="Orders f or inactiv e orderabl es may not  be transf erred; ple ase enter  a new orde r!" Q
  1369   "RTN","ORC ACT01",92, 0)
  1370    S OI=+$O( ^OR(100,+I FN,.1,"B", 0)),ORPS=$ G(^ORD(101 .43,OI,"PS "))
  1371   "RTN","ORC ACT01",93, 0)
  1372    I DG="UD  RX",'$P(OR PS,U,2) S  ERROR="Thi s drug may  not be or dered for  an outpati ent!" Q
  1373   "RTN","ORC ACT01",94, 0)
  1374    I DG="O R X" D  Q:$L ($G(ERROR) )
  1375   "RTN","ORC ACT01",95, 0)
  1376    . I '$P(O RPS,U) S E RROR="This  drug may  not be ord ered for a n inpatien t!" Q
  1377   "RTN","ORC ACT01",96, 0)
  1378    . D:$O(^O R(100,+IFN ,4.5,"ID", "MISC",0))  DOSES^ORC ACT02(+IFN )
  1379   "RTN","ORC ACT01",97, 0)
  1380    Q
  1381   "RTN","ORC ACT01",98, 0)
  1382    ;
  1383   "RTN","ORC ACT01",99, 0)
  1384   RW ; -- re write/copy
  1385   "RTN","ORC ACT01",100 ,0)
  1386    N ORISCL  D ISCLORD^ ORUTL(.ORI SCL,+IFN)
  1387   "RTN","ORC ACT01",101 ,0)
  1388    I ORISCL  S ERROR="C annot copy  Clinic Me dication o r Clinic I nfusion or ders!"
  1389   "RTN","ORC ACT01",102 ,0)
  1390    I ACTSTS= 12 S ERROR ="Orders t hat have b een dc'd d ue to edit ing may no t be copie d!" Q
  1391   "RTN","ORC ACT01",103 ,0)
  1392    I DG="NV  RX" S ERRO R="Non-VA  Med orders  cannot be  copied!"  Q
  1393   "RTN","ORC ACT01",104 ,0)
  1394    I DG="TPN " S ERROR= "TPN order s may not  be rewritt en!" Q
  1395   "RTN","ORC ACT01",105 ,0)
  1396    I DG="UD  RX",$$NTBG ^ORCACT03( +IFN) S ER ROR="This  order has  been marke d 'Not to  be Given'  and may no t be rewri tten!" Q
  1397   "RTN","ORC ACT01",106 ,0)
  1398    I $$INACT IVE^ORCACT 03 S ERROR ="Orders f or inactiv e orderabl es may not  be copied ; please e nter a new  order!" Q
  1399   "RTN","ORC ACT01",107 ,0)
  1400    I PKG="PS ",'$$MEDOK ^ORCACT03  S ERROR="T his drug m ay not be  ordered!"  Q
  1401   "RTN","ORC ACT01",108 ,0)
  1402    I DG="O R X",$O(^OR( 100,+IFN,4 .5,"ID","M ISC",0)) D  DOSES^ORC ACT02(+IFN ) ;old for m
  1403   "RTN","ORC ACT01",109 ,0)
  1404    Q
  1405   "RTN","ORC ACT01",110 ,0)
  1406    ;
  1407   "RTN","ORC ACT01",111 ,0)
  1408   RN ; -- re new
  1409   "RTN","ORC ACT01",112 ,0)
  1410    I PKG'="P S",PKG'="O R" S ERROR ="This ord er may not  be renewe d!" Q
  1411   "RTN","ORC ACT01",113 ,0)
  1412    I (ORDSTS =11)!(ORDS TS=10) S E RROR="This  order has  not been  released t o the serv ice." Q
  1413   "RTN","ORC ACT01",114 ,0)
  1414    I ACTSTS= 12 S ERROR ="Orders t hat have b een dc'd d ue to edit ing may no t be renew ed!" Q
  1415   "RTN","ORC ACT01",115 ,0)
  1416    I $P(OR3, U,6) S ERR OR="This o rder has a lready bee n "_$S($P( $G(^OR(100 ,+$P(OR3,U ,6),3)),U, 11)=1:"cha nged!",1:" renewed!")  Q
  1417   "RTN","ORC ACT01",116 ,0)
  1418    I PKG="OR " D  Q  ;G eneric ord ers
  1419   "RTN","ORC ACT01",117 ,0)
  1420    . I $$INA CTIVE^ORCA CT03 S ERR OR="Orders  for inact ive ordera bles may n ot be rene wed!" Q
  1421   "RTN","ORC ACT01",118 ,0)
  1422    . I DG="A DT" S ERRO R="M.A.S.  orders may  not be re newed!" Q
  1423   "RTN","ORC ACT01",119 ,0)
  1424    . I "^1^2 ^6^7^"[(U_ ORDSTS_U)  Q  ;ok
  1425   "RTN","ORC ACT01",120 ,0)
  1426    . S ERROR ="This ord er may not  be renewe d!"
  1427   "RTN","ORC ACT01",121 ,0)
  1428    I (PKG="P S"),$$INAC TIVE^ORCAC T03 S ERRO R="Orders  for inacti ve orderab les may no t be renew ed!" Q
  1429   "RTN","ORC ACT01",122 ,0)
  1430    I '$$MEDO K^ORCACT03  S ERROR=" This drug  may not be  ordered!"  Q
  1431   "RTN","ORC ACT01",123 ,0)
  1432   RN1 N PSIF N S PSIFN= $G(^OR(100 ,+IFN,4))
  1433   "RTN","ORC ACT01",124 ,0)
  1434    I PSIFN<1 ,'$O(^OR(1 00,+IFN,2, 0)) S ERRO R="Missing  or invali d order nu mber!" Q
  1435   "RTN","ORC ACT01",125 ,0)
  1436    I DG="O R X"!(DG="SP LY") D  Q   ;Outpt Me ds
  1437   "RTN","ORC ACT01",126 ,0)
  1438    . N ORZ,O RD S ORZ=$ L($T(RENEW ^PSORENW), ",")
  1439   "RTN","ORC ACT01",127 ,0)
  1440    . I ORZ>1  S ORD=+$$ VALUE^ORX8 (+IFN,"DRU G"),X=$$RE NEW^PSOREN W(PSIFN,OR D)
  1441   "RTN","ORC ACT01",128 ,0)
  1442    . S:ORZ'> 1 X=$$RENE W^PSORENW( PSIFN) I X <1 S ERROR =$P(X,U,2)  Q
  1443   "RTN","ORC ACT01",129 ,0)
  1444    . S X=+$P (X,U,2) D: X RESET^OR CACT03(+IF N,X)
  1445   "RTN","ORC ACT01",130 ,0)
  1446    . I $O(^O R(100,+IFN ,4.5,"ID", "MISC",0))  D DOSES^O RCACT02(+I FN) ;old f ormat
  1447   "RTN","ORC ACT01",131 ,0)
  1448    I DG="UD  RX",$$NTBG ^ORCACT03( +IFN) S ER ROR="This  order has  been marke d 'Not to  be Given'  and may no t be renew ed!" Q
  1449   "RTN","ORC ACT01",132 ,0)
  1450    I ORDSTS= 7,'$$IV^OR CACT03,$P( OR0,U,9)<$ $FMADD^XLF DT(DT,-4)   S ERROR=" Inpatient  med orders  may not b e renewed  more than  4 days aft er expirat ion!" Q
  1451   "RTN","ORC ACT01",133 ,0)
  1452    I ORDSTS' =6,ORDSTS' =7 S ERROR ="This ord er may not  be renewe d!" Q
  1453   "RTN","ORC ACT01",134 ,0)
  1454   RN2 I $O(^ OR(100,+IF N,2,0))!$P (OR3,U,9)  D  Q:$D(ER ROR)!'PSIF N
  1455   "RTN","ORC ACT01",135 ,0)
  1456    . I $P(OR 3,U,9),$$V ALUE^ORX8( +IFN,"SCHE DULE",1,"E ")="NOW" S  ERROR="On e-time NOW  orders ma y not be r enewed!" Q
  1457   "RTN","ORC ACT01",136 ,0)
  1458    . N DAD,O RD3,I,Y S  DAD=$S($P( OR3,U,9):+ $P(OR3,U,9 ),1:+IFN), Y=0
  1459   "RTN","ORC ACT01",137 ,0)
  1460    . S ORD3= $G(^OR(100 ,DAD,3)) I  $P(ORD3,U ,6) S ERRO R="This co mplex orde r has alre ady been r enewed!" Q
  1461   "RTN","ORC ACT01",138 ,0)
  1462    . I $P(OR D3,U,3)'=6  S ERROR=" This compl ex order i s not acti ve and may  not be re newed!" Q
  1463   "RTN","ORC ACT01",139 ,0)
  1464    . I '$$AN D^ORX8(DAD ) S ERROR= "Complex o rders with  sequentia l doses ma y not be r enewed!" Q
  1465   "RTN","ORC ACT01",140 ,0)
  1466    . S I=0 F   S I=+$O( ^OR(100,DA D,2,I)) Q: I<1  D  Q: Y
  1467   "RTN","ORC ACT01",141 ,0)
  1468    .. I I=+$ O(^OR(100, DAD,2,0)), $$VALUE^OR X8(I,"SCHE DULE",1,"E ")="NOW",$ $VALUE^ORX 8(DAD,"NOW ") Q  ;ign ore NOW or ders
  1469   "RTN","ORC ACT01",142 ,0)
  1470    .. I $P($ G(^OR(100, I,3)),U,3) '=6 S Y=1, ERROR="Com plex order s with ter minated do ses may no t be renew ed!" Q
  1471   "RTN","ORC ACT01",143 ,0)
  1472    .. I PSIF N<1 S X=$$ ACTIVE^PSJ ORREN(+ORV P,$G(^OR(1 00,I,4)))  I +X'=1 S  ERROR="Thi s order ma y not be r enewed: "_ $S(+X>1:"I nactive or derable it em",1:$P(X ,U,2)) Q
  1473   "RTN","ORC ACT01",144 ,0)
  1474    ;I DG="TP N" S ERROR ="TPN orde rs may not  be renewe d!" Q
  1475   "RTN","ORC ACT01",145 ,0)
  1476    S X=$$ACT IVE^PSJORR EN(+ORVP,P SIFN) Q:+X =1  ;Ok
  1477   "RTN","ORC ACT01",146 ,0)
  1478    I +X>1,$P (X,U,2) D  RESET^ORCA CT03(+IFN, +$P(X,U,2) ) Q  ;repl ace OI
  1479   "RTN","ORC ACT01",147 ,0)
  1480    S ERROR=" This order  may not b e renewed:  "_$P(X,U, 2)
  1481   "RTN","ORC ACT01",148 ,0)
  1482    Q
  1483   "RTN","ORC ACT01",149 ,0)
  1484    ;
  1485   "RTN","ORC ACT01",150 ,0)
  1486   XX ; -- ed it/change- -
  1487   "RTN","ORC ACT01",151 ,0)
  1488    I PKG="RA ",ORDSTS'= 11,ORDSTS' =10 S ERRO R="Orders  released t o Radiolog y cannot b e changed! " Q
  1489   "RTN","ORC ACT01",152 ,0)
  1490    I PKG="LR ",ORDSTS'= 11,ORDSTS' =10 S ERRO R="Orders  released t o Lab cann ot be chan ged!" Q
  1491   "RTN","ORC ACT01",153 ,0)
  1492    I PKG="FH ",ORDSTS'= 11,ORDSTS' =10 S ERRO R="Orders  released t o Dietetic s cannot b e changed! " Q
  1493   "RTN","ORC ACT01",154 ,0)
  1494    I PKG="GM RC",ORDSTS '=11,ORDST S'=10 S ER ROR="Order s released  to Consul ts cannot  be changed !" Q
  1495   "RTN","ORC ACT01",155 ,0)
  1496    I DG="TPN " S ERROR= "TPN order s may not  be changed !" Q
  1497   "RTN","ORC ACT01",156 ,0)
  1498    I ORDSTS= 3 S ERROR= "Orders on  hold may  not be cha nged!" Q
  1499   "RTN","ORC ACT01",157 ,0)
  1500    I DG="UD  RX",$$NTBG ^ORCACT03( +IFN) S ER ROR="This  order has  been marke d 'Not to  be Given'  and may no t be chang ed!" Q
  1501   "RTN","ORC ACT01",158 ,0)
  1502    I $O(^OR( 100,+IFN,2 ,0)) S ERR OR="Comple x orders m ay not be  changed!"  Q
  1503   "RTN","ORC ACT01",159 ,0)
  1504    I $P(OR3, U,9) D  Q: $D(ERROR)
  1505   "RTN","ORC ACT01",160 ,0)
  1506    . Q:$$VAL UE^ORX8(+I FN,"SCHEDU LE",1,"E") ="NOW"  ;N OW ok
  1507   "RTN","ORC ACT01",161 ,0)
  1508    . Q:'$O(^ OR(100,+$P (OR3,U,9), 4.5,"ID"," CONJ",0))   ;no conj= 1dose/ok
  1509   "RTN","ORC ACT01",162 ,0)
  1510    . S ERROR ="Complex  orders may  not be ch anged!" Q
  1511   "RTN","ORC ACT01",163 ,0)
  1512    I $P(OR3, U,6) S ERR OR="This o rder may n ot be chan ged - a "_ $S($P($G(^ OR(100,+$P (OR3,U,6), 3)),U,11)= 1:"change" ,1:"renewa l")_" orde r already  exists!" Q
  1513   "RTN","ORC ACT01",164 ,0)
  1514    I $P(OR3, U,11)=2 D   Q:$D(ERRO R)
  1515   "RTN","ORC ACT01",165 ,0)
  1516    . I (ORDS TS=10!(ORD STS=11)),D G'="O RX"  S ERROR="U nreleased  renewals m ay not be  changed!"  Q
  1517   "RTN","ORC ACT01",166 ,0)
  1518    . I PKG=" PS",ORDSTS =5 S ERROR ="Pending  renewals m ay not be  changed!"  Q
  1519   "RTN","ORC ACT01",167 ,0)
  1520    I $$INACT IVE^ORCACT 03 S ERROR ="Orders f or inactiv e orderabl es may not  be change d; please  enter a ne w order!"  Q
  1521   "RTN","ORC ACT01",168 ,0)
  1522    I PKG="PS ",'$$MEDOK ^ORCACT03  S ERROR="T his drug m ay not be  ordered!"  Q
  1523   "RTN","ORC ACT01",169 ,0)
  1524    I DG="O R X",$O(^OR( 100,+IFN,4 .5,"ID","M ISC",0)) D  DOSES^ORC ACT02(+IFN ) ;old for m
  1525   "RTN","ORC ACT01",170 ,0)
  1526    Q
  1527   "RTN","ORC ACT01",171 ,0)
  1528    ;
  1529   "RTN","ORC MEDT4")
  1530   0^4^B10638 2562
  1531   "RTN","ORC MEDT4",1,0 )
  1532   ORCMEDT4 ; SLC/MKB-Pr ompt Edito r ;07/29/1 6  09:26
  1533   "RTN","ORC MEDT4",2,0 )
  1534    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**8 ,46,95,245 ,313,389,3 97**;Dec 1 7, 1997;Bu ild 17
  1535   "RTN","ORC MEDT4",3,0 )
  1536    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  1537   "RTN","ORC MEDT4",4,0 )
  1538   EN ; -- En ter/edit p rompts
  1539   "RTN","ORC MEDT4",5,0 )
  1540    N PRMT F   S PRMT=+$ $PROMPT Q: PRMT'>0  D   W !
  1541   "RTN","ORC MEDT4",6,0 )
  1542    . I $P($G (^ORD(101. 41,PRMT,0) ),U,7)=$O( ^DIC(9.4," C","OR",0) ) D  Q
  1543   "RTN","ORC MEDT4",7,0 )
  1544    . . N DIC ,DA S DIC= "^ORD(101. 41,",DA=PR MT D EN^DI Q
  1545   "RTN","ORC MEDT4",8,0 )
  1546    . . W !," This promp t is not e ditable!"
  1547   "RTN","ORC MEDT4",9,0 )
  1548    . D EDIT( PRMT)
  1549   "RTN","ORC MEDT4",10, 0)
  1550    Q
  1551   "RTN","ORC MEDT4",11, 0)
  1552    ;
  1553   "RTN","ORC MEDT4",12, 0)
  1554   EDIT(DA) ;  -- Edit p rompt DA
  1555   "RTN","ORC MEDT4",13, 0)
  1556    N DR,DIE, NAME,TEXT, TYPE,DOMAI N,OR0,OR1, ORP
  1557   "RTN","ORC MEDT4",14, 0)
  1558    Q:'$G(DA)   S OR0=$G (^ORD(101. 41,DA,0)), OR1=$G(^(1 )),ORP=DA
  1559   "RTN","ORC MEDT4",15, 0)
  1560    S NAME=$$ NAME(DA) Q :(NAME="@" )!(NAME="^ ")  ;delet ed or quit
  1561   "RTN","ORC MEDT4",16, 0)
  1562    S TEXT=$$ DTEXT($P(O R0,U,2)) Q :TEXT="^"
  1563   "RTN","ORC MEDT4",17, 0)
  1564    S TYPE=$$ DATATYPE($ P(OR1,U))  Q:TYPE="^"   S DOMAIN =$P(OR1,U, 2)
  1565   "RTN","ORC MEDT4",18, 0)
  1566    D @$S(TYP E="D"!(TYP E="R"):"DA TE",TYPE=" F":"TEXT", TYPE="N":" NMBR",TYPE ="P":"PTR" ,TYPE="S": "SET",1:"O THER") Q:D OMAIN="^"
  1567   "RTN","ORC MEDT4",19, 0)
  1568    S $P(^ORD (101.41,DA ,1),U,1,2) =TYPE_U_DO MAIN,DIE=" ^ORD(101.4 1,"
  1569   "RTN","ORC MEDT4",20, 0)
  1570    S DR=$S(N AME'=$P(OR 0,U):".01/ //^S X=NAM E;",1:"")_ $S(TEXT'=$ P(OR0,U,2) :"2///^S X =TEXT;",1: "")_"20"_" ;13" D ^DI E ;95
  1571   "RTN","ORC MEDT4",21, 0)
  1572    Q
  1573   "RTN","ORC MEDT4",22, 0)
  1574    ;
  1575   "RTN","ORC MEDT4",23, 0)
  1576   PROMPT() ;  -- Find p rompt in # 101.41
  1577   "RTN","ORC MEDT4",24, 0)
  1578    N X,Y,DIC ,DLAYGO
  1579   "RTN","ORC MEDT4",25, 0)
  1580    S DIC="^O RD(101.41, ",DIC(0)=" AEQLM",DLA YGO=101.41
  1581   "RTN","ORC MEDT4",26, 0)
  1582    S DIC("A" )="Select  PROMPT: ", DIC("S")=" I $P(^(0), U,4)=""P"" "
  1583   "RTN","ORC MEDT4",27, 0)
  1584    S DIC("DR ")="4////P " D ^DIC
  1585   "RTN","ORC MEDT4",28, 0)
  1586    Q Y
  1587   "RTN","ORC MEDT4",29, 0)
  1588    ;
  1589   "RTN","ORC MEDT4",30, 0)
  1590   NAME(IFN)  ; -- Edit  .01 name o f dialog I FN
  1591   "RTN","ORC MEDT4",31, 0)
  1592    N X,Y,DIR ,OLDNAME,I SPQO,NODEL ETE,DA,DIK ,TYPE
  1593   "RTN","ORC MEDT4",32, 0)
  1594    S DIR(0)= "FAO^3:63" ,DIR("A")= "NAME: "
  1595   "RTN","ORC MEDT4",33, 0)
  1596    S OLDNAME =$P($G(^OR D(101.41,I FN,0)),U), ISPQO=0,NO DELETE=1
  1597   "RTN","ORC MEDT4",34, 0)
  1598    S TYPE=$P ($G(^ORD(1 01.41,IFN, 0)),U,4)
  1599   "RTN","ORC MEDT4",35, 0)
  1600    I TYPE="Q ",$E(OLDNA ME,1,6)="O RWDQ " S I SPQO=1
  1601   "RTN","ORC MEDT4",36, 0)
  1602    I ISPQO!( TYPE="P")  S NODELETE =0 ; OK to  delete pe rsonal qui ck orders  and prompt s
  1603   "RTN","ORC MEDT4",37, 0)
  1604    S DIR("B" )=OLDNAME
  1605   "RTN","ORC MEDT4",38, 0)
  1606    S DIR("?" )="Enter a  unique na me, up to  63 charact ers in len gth."
  1607   "RTN","ORC MEDT4",39, 0)
  1608   NM I $L($P ($G(^ORD(1 01.41,IFN, 0)),U,3))> 0 W !,!,"( This "_$$G ETITM(IFN) _" has bee n disabled )"
  1609   "RTN","ORC MEDT4",40, 0)
  1610    D ^DIR S: $D(DTOUT)! (X["^") Y= "^"
  1611   "RTN","ORC MEDT4",41, 0)
  1612    I X="@" D   G NM:X=" "
  1613   "RTN","ORC MEDT4",42, 0)
  1614    . I $D(^O RD(101.41, "AD",IFN))  W $C(7),! ,"Cannot d elete - cu rrently in  use!",! S  X="" Q
  1615   "RTN","ORC MEDT4",43, 0)
  1616    . I $$INU SE^ORCMEDT 5(IFN) W $ C(7),!,"Ca nnot delet e - curren tly an Add  Orders Me nu!",! S X ="" Q
  1617   "RTN","ORC MEDT4",44, 0)
  1618    . S NODEL ETE=$$PTRC HK(IFN,"OR DLG PTRS")  I NODELET E D
  1619   "RTN","ORC MEDT4",45, 0)
  1620    . . N CON TINUE W $C (7),!,"Can not delete  - other f ile entrie s point to  this orde r dialog!" ,!
  1621   "RTN","ORC MEDT4",46, 0)
  1622    . . S CON TINUE=$$CO NT D:CONTI NUE'["^" P TRRPT("ORD LG PTRS",I FN)
  1623   "RTN","ORC MEDT4",47, 0)
  1624    . I NODEL ETE D DISA BLE(IFN) S  X="" Q
  1625   "RTN","ORC MEDT4",48, 0)
  1626    . I '$$SU RE(IFN) S  X="" Q  ;r eask
  1627   "RTN","ORC MEDT4",49, 0)
  1628    . N IDX1, IDX2 S IDX 1=0
  1629   "RTN","ORC MEDT4",50, 0)
  1630    . F  S ID X1=$O(^ORD (101.44,"C ",IFN,IDX1 )) Q:'IDX1   D
  1631   "RTN","ORC MEDT4",51, 0)
  1632    . . S IDX 2=0
  1633   "RTN","ORC MEDT4",52, 0)
  1634    . . F  S  IDX2=$O(^O RD(101.44, "C",IFN,ID X1,IDX2))  Q:'IDX2  D
  1635   "RTN","ORC MEDT4",53, 0)
  1636    . . . S D A=IDX2,DA( 1)=IDX1,DI K="^ORD(10 1.44,"_IDX 1_",10," D  ^DIK
  1637   "RTN","ORC MEDT4",54, 0)
  1638    . K DA S  DA=IFN,DIK ="^ORD(101 .41," D ^D IK W "  .. .deleted."  S (X,Y)=" @"
  1639   "RTN","ORC MEDT4",55, 0)
  1640    I ISPQO,Y '="^",X'=" @",Y'=OLDN AME D  G N M
  1641   "RTN","ORC MEDT4",56, 0)
  1642    . W $C(7) ,!,"Cannot  rename a  personal q uick order ",!
  1643   "RTN","ORC MEDT4",57, 0)
  1644    K ^TMP($J ,"ORDLG PT RS")
  1645   "RTN","ORC MEDT4",58, 0)
  1646    Q Y
  1647   "RTN","ORC MEDT4",59, 0)
  1648    ;
  1649   "RTN","ORC MEDT4",60, 0)
  1650   GETITM(DLG ) ;
  1651   "RTN","ORC MEDT4",61, 0)
  1652    N ITM
  1653   "RTN","ORC MEDT4",62, 0)
  1654    S ITM=$P( $G(^ORD(10 1.41,DLG,0 )),U,4)
  1655   "RTN","ORC MEDT4",63, 0)
  1656    I ITM="Q" ,$E($P($G( ^ORD(101.4 1,IFN,0)), U),1,6)="O RWDQ " Q " personal q uick order "
  1657   "RTN","ORC MEDT4",64, 0)
  1658    S ITM=$S( ITM="P":"p rompt",ITM ="D":"dial og",ITM="Q ":"quick o rder",ITM= "O":"order  set",ITM= "A":"actio n",ITM="M" :"menu",1: "item")
  1659   "RTN","ORC MEDT4",65, 0)
  1660    Q ITM
  1661   "RTN","ORC MEDT4",66, 0)
  1662    ;
  1663   "RTN","ORC MEDT4",67, 0)
  1664   SURE(DLG)  ; -- Are y ou sure?
  1665   "RTN","ORC MEDT4",68, 0)
  1666    N X,Y,DIR ,ITM,DA
  1667   "RTN","ORC MEDT4",69, 0)
  1668    S ITM=$$G ETITM(DLG)
  1669   "RTN","ORC MEDT4",70, 0)
  1670    S DIR(0)= "YA",DIR(" A")="Are y ou sure yo u want to  delete thi s "_ITM_"?  "
  1671   "RTN","ORC MEDT4",71, 0)
  1672    S DIR("?" )="Enter Y ES if you  want to de lete this  "_ITM_" fr om the fil e, or NO t o quit."
  1673   "RTN","ORC MEDT4",72, 0)
  1674    D ^DIR
  1675   "RTN","ORC MEDT4",73, 0)
  1676    Q +Y
  1677   "RTN","ORC MEDT4",74, 0)
  1678    ;
  1679   "RTN","ORC MEDT4",75, 0)
  1680   DISABLE(DL G) ; Disab le item -  return tru e if disab led
  1681   "RTN","ORC MEDT4",76, 0)
  1682    N DIR,X,Y ,ITM,DA,DR ,DIE,DIDEL ,DISABLED
  1683   "RTN","ORC MEDT4",77, 0)
  1684    ;W $C(7), !,!,"Delet ion not al lowed outs ide of Fil eMan."
  1685   "RTN","ORC MEDT4",78, 0)
  1686    S ITM=$$G ETITM(DLG)
  1687   "RTN","ORC MEDT4",79, 0)
  1688    S DISABLE D=$L($P($G (^ORD(101. 41,IFN,0)) ,U,3))>0
  1689   "RTN","ORC MEDT4",80, 0)
  1690    S DIR(0)= "YA"
  1691   "RTN","ORC MEDT4",81, 0)
  1692    I DISABLE D D  I 1
  1693   "RTN","ORC MEDT4",82, 0)
  1694    . S DIR(" A",1)="Thi s "_ITM_"  is already  disabled. "
  1695   "RTN","ORC MEDT4",83, 0)
  1696    . S DIR(" A")="Would  you like  to edit th e disable  message? "
  1697   "RTN","ORC MEDT4",84, 0)
  1698    . S DIR(" ?")="Enter  YES if yo u want to  edit the d isabled me ssage, or  NO to quit ."
  1699   "RTN","ORC MEDT4",85, 0)
  1700    . S DIR(" B")="NO"
  1701   "RTN","ORC MEDT4",86, 0)
  1702    E  D
  1703   "RTN","ORC MEDT4",87, 0)
  1704    . S DIR(" A")="Would  you like  to disable  this "_IT M_"? "
  1705   "RTN","ORC MEDT4",88, 0)
  1706    . S DIR(" ?")="Enter  YES if yo u want to  disable th is "_ITM_" , or NO to  quit."
  1707   "RTN","ORC MEDT4",89, 0)
  1708    . S DIR(" B")="YES"
  1709   "RTN","ORC MEDT4",90, 0)
  1710    D ^DIR
  1711   "RTN","ORC MEDT4",91, 0)
  1712    I '+Y Q
  1713   "RTN","ORC MEDT4",92, 0)
  1714    W !,"Ente r disable  message:"
  1715   "RTN","ORC MEDT4",93, 0)
  1716    S DA=DLG, DR="3",DIE ="^ORD(101 .41,"
  1717   "RTN","ORC MEDT4",94, 0)
  1718    D ^DIE
  1719   "RTN","ORC MEDT4",95, 0)
  1720    Q
  1721   "RTN","ORC MEDT4",96, 0)
  1722    ;
  1723   "RTN","ORC MEDT4",97, 0)
  1724   DTEXT(X) ;  -- Enter/ edit displ ay text of  prompt
  1725   "RTN","ORC MEDT4",98, 0)
  1726    N Y,DIR
  1727   "RTN","ORC MEDT4",99, 0)
  1728    S DIR(0)= "FA^3:63", DIR("A")=" TEXT OF PR OMPT: " S: $L($G(X))  DIR("B")=X
  1729   "RTN","ORC MEDT4",100 ,0)
  1730    S DIR("?" )="Enter t he text of  this prom pt, includ ing any pu nctuation  and spaces "
  1731   "RTN","ORC MEDT4",101 ,0)
  1732    D ^DIR S: $D(DTOUT)  Y="^"
  1733   "RTN","ORC MEDT4",102 ,0)
  1734    Q Y
  1735   "RTN","ORC MEDT4",103 ,0)
  1736    ;
  1737   "RTN","ORC MEDT4",104 ,0)
  1738   DATATYPE(X ) ; -- Ret urns desir ed datatyp e for prom pt
  1739   "RTN","ORC MEDT4",105 ,0)
  1740    N DIR,Y S  DIR("A")= "TYPE OF P ROMPT: "
  1741   "RTN","ORC MEDT4",106 ,0)
  1742    S DIR(0)= "SAM^D:dat e/time;R:r elative da te/time;F: free text; N:numeric; S:set of c odes;P:poi nter to a  file;Y:yes /no;W:word  processin g;"
  1743   "RTN","ORC MEDT4",107 ,0)
  1744    S:$L($G(X )) DIR("B" )=$P($P(DI R(0),X_":" ,2),";")
  1745   "RTN","ORC MEDT4",108 ,0)
  1746    S DIR("?" )="Select  the type o f data to  be entered  at this p rompt"
  1747   "RTN","ORC MEDT4",109 ,0)
  1748    D ^DIR S: $D(DTOUT)  Y="^"
  1749   "RTN","ORC MEDT4",110 ,0)
  1750    Q Y
  1751   "RTN","ORC MEDT4",111 ,0)
  1752    ;
  1753   "RTN","ORC MEDT4",112 ,0)
  1754   DATE ; --  date param eters
  1755   "RTN","ORC MEDT4",113 ,0)
  1756    N X,Y,DIR ,ORX,ORT,O RS,ORR
  1757   "RTN","ORC MEDT4",114 ,0)
  1758    S X=$P(DO MAIN,":",3 ),ORX=X["X ",ORT=X["T ",ORS=X["S ",ORR=X["R ",DIR(0)=" YA"
  1759   "RTN","ORC MEDT4",115 ,0)
  1760    ; Still n eed to han dle Earlie st and Lat est dates  allowed
  1761   "RTN","ORC MEDT4",116 ,0)
  1762    S DIR("A" )="CAN DAT E BE IMPRE CISE? ",DI R("B")=$S( ORX:"NO",1 :"YES")
  1763   "RTN","ORC MEDT4",117 ,0)
  1764    D ^DIR S  ORX='Y I $ D(DUOUT)!( $D(DTOUT))  S DOMAIN= "^" Q
  1765   "RTN","ORC MEDT4",118 ,0)
  1766    S DIR("A" )="CAN TIM E OF DAY B E ENTERED?  ",DIR("B" )=$S(ORT:" YES",1:"NO ")
  1767   "RTN","ORC MEDT4",119 ,0)
  1768    D ^DIR I  $D(DUOUT)! ($D(DTOUT) ) S DOMAIN ="^" Q
  1769   "RTN","ORC MEDT4",120 ,0)
  1770    S ORT=Y I  'Y S (ORS ,ORR)=0 G  DQ
  1771   "RTN","ORC MEDT4",121 ,0)
  1772    S DIR("A" )="CAN SEC ONDS BE EN TERED? ",D IR("B")=$S (ORS:"YES" ,1:"NO")
  1773   "RTN","ORC MEDT4",122 ,0)
  1774    D ^DIR S  ORS=Y I $D (DUOUT)!($ D(DTOUT))  S DOMAIN=" ^" Q
  1775   "RTN","ORC MEDT4",123 ,0)
  1776    S DIR("A" )="IS TIME  REQUIRED?  ",DIR("B" )=$S(ORR:" YES",1:"NO ")
  1777   "RTN","ORC MEDT4",124 ,0)
  1778    D ^DIR S  ORR=Y I $D (DUOUT)!($ D(DTOUT))  S DOMAIN=" ^" Q
  1779   "RTN","ORC MEDT4",125 ,0)
  1780   DQ S DOMAI N="::E"_$S (ORX:"X",1 :"")_$S(OR T:"T",1:"" )_$S(ORS:" S",1:"")_$ S(ORR:"R", 1:"")
  1781   "RTN","ORC MEDT4",126 ,0)
  1782    Q
  1783   "RTN","ORC MEDT4",127 ,0)
  1784    ;
  1785   "RTN","ORC MEDT4",128 ,0)
  1786   TEXT ; --  free text
  1787   "RTN","ORC MEDT4",129 ,0)
  1788    N X,Y,DIR
  1789   "RTN","ORC MEDT4",130 ,0)
  1790    S DIR(0)= "NAO^1:245 ",DIR("A") ="MINIMUM  LENGTH: "
  1791   "RTN","ORC MEDT4",131 ,0)
  1792    S:+DOMAIN  DIR("B")= +DOMAIN
  1793   "RTN","ORC MEDT4",132 ,0)
  1794    D ^DIR I  $D(DTOUT)! ($D(DUOUT) ) S DOMAIN ="^" Q
  1795   "RTN","ORC MEDT4",133 ,0)
  1796    S $P(DOMA IN,":")=Y, DIR("A")=" MAXIMUM LE NGTH: " K  DIR("B")
  1797   "RTN","ORC MEDT4",134 ,0)
  1798    S:$P(DOMA IN,":",2)  DIR("B")=$ P(DOMAIN," :",2)
  1799   "RTN","ORC MEDT4",135 ,0)
  1800    D ^DIR I  $D(DUOUT)! ($D(DTOUT) ) S DOMAIN ="^" Q
  1801   "RTN","ORC MEDT4",136 ,0)
  1802    S $P(DOMA IN,":",2)= Y
  1803   "RTN","ORC MEDT4",137 ,0)
  1804    ; Opt pat tern match  ??
  1805   "RTN","ORC MEDT4",138 ,0)
  1806    Q
  1807   "RTN","ORC MEDT4",139 ,0)
  1808    ;
  1809   "RTN","ORC MEDT4",140 ,0)
  1810   NMBR ; --  numeric
  1811   "RTN","ORC MEDT4",141 ,0)
  1812    N X,Y,DIR ,STR
  1813   "RTN","ORC MEDT4",142 ,0)
  1814    S DIR(0)= "NAO^::"_+ $P(DOMAIN, ":",3),DIR ("A")="INC LUSIVE LOW ER BOUND:  ",DIR("B") =+DOMAIN ; 95
  1815   "RTN","ORC MEDT4",143 ,0)
  1816    D ^DIR I  $D(DTOUT)! ($D(DUOUT) ) S DOMAIN ="^" Q
  1817   "RTN","ORC MEDT4",144 ,0)
  1818    S STR=Y,D IR(0)="NAO ^"_Y_"::"_ +$P(DOMAIN ,":",3),DI R("A")="IN CLUSIVE UP PER BOUND:  ",DIR("B" )=+$P(DOMA IN,":",2)  ;95
  1819   "RTN","ORC MEDT4",145 ,0)
  1820    D ^DIR I  $D(DTOUT)! ($D(DUOUT) ) S DOMAIN ="^" Q
  1821   "RTN","ORC MEDT4",146 ,0)
  1822    S STR=STR _":"_Y,DIR (0)="NAO", DIR("A")=" MAXIMUM NU MBER OF FR ACTIONAL D IGITS: ",D IR("B")=+$ P(DOMAIN," :",3) ;95
  1823   "RTN","ORC MEDT4",147 ,0)
  1824    D ^DIR I  $D(DUOUT)! ($D(DTOUT) ) S DOMAIN ="^" Q
  1825   "RTN","ORC MEDT4",148 ,0)
  1826    S DOMAIN= STR_":"_Y
  1827   "RTN","ORC MEDT4",149 ,0)
  1828    Q
  1829   "RTN","ORC MEDT4",150 ,0)
  1830    ;
  1831   "RTN","ORC MEDT4",151 ,0)
  1832   PTR ; -- p ointer
  1833   "RTN","ORC MEDT4",152 ,0)
  1834    I DUZ(0)= "@"!($L(DO MAIN)&'DOM AIN) D ROO T Q  ; all ow file ro ot
  1835   "RTN","ORC MEDT4",153 ,0)
  1836    N X,Y,DIR ,DIE,DR,FI LE,STR,SCR
  1837   "RTN","ORC MEDT4",154 ,0)
  1838    S DIR(0)= "PA^1:AEQM ",DIR("A") ="POINT TO  WHICH FIL E: "
  1839   "RTN","ORC MEDT4",155 ,0)
  1840    S:$L(DOMA IN) DIR("B ")=$$FILEN AME(+DOMAI N)
  1841   "RTN","ORC MEDT4",156 ,0)
  1842    D ^DIR I  $D(DUOUT)! ($D(DTOUT) ) S DOMAIN ="^" Q
  1843   "RTN","ORC MEDT4",157 ,0)
  1844    S FILE=+Y ,STR=$P(DO MAIN,":",2 ) S:'$L(ST R) STR="EQ "
  1845   "RTN","ORC MEDT4",158 ,0)
  1846    S DOMAIN= FILE_":"_S TR
  1847   "RTN","ORC MEDT4",159 ,0)
  1848    Q
  1849   "RTN","ORC MEDT4",160 ,0)
  1850    ;
  1851   "RTN","ORC MEDT4",161 ,0)
  1852   ROOT ; --  pointer vi a file roo t
  1853   "RTN","ORC MEDT4",162 ,0)
  1854    N X,Y,DIR ,STR
  1855   "RTN","ORC MEDT4",163 ,0)
  1856    S DIR(0)= "FA^1:100" ,DIR("A")= "POINT TO  WHICH FILE : "
  1857   "RTN","ORC MEDT4",164 ,0)
  1858    S DIR("?" )="Enter t he file by  name, fil e number,  or global  root (with out the le ading '^') ."
  1859   "RTN","ORC MEDT4",165 ,0)
  1860    S:$L(DOMA IN) DIR("B ")=$S(+DOM AIN:$$FILE NAME(+DOMA IN),1:$P(D OMAIN,":") )
  1861   "RTN","ORC MEDT4",166 ,0)
  1862   RT1 D ^DIR  I $D(DTOU T)!$D(DUOU T) S DOMAI N="^" Q
  1863   "RTN","ORC MEDT4",167 ,0)
  1864    I $L(DOMA IN),$L(X), X=$G(DIR(" B")) S Y=$ P(DOMAIN," :") G RTQ  ; default
  1865   "RTN","ORC MEDT4",168 ,0)
  1866    I +Y=Y S  X=$$FILENA ME(+Y) I $ L(X) W "    "_X G RTQ  ; valid f ile number
  1867   "RTN","ORC MEDT4",169 ,0)
  1868    I $L(Y),+ Y'=Y D  G: $D(Y) RTQ  ; valid ro ot or name
  1869   "RTN","ORC MEDT4",170 ,0)
  1870    . I "(,"[ $E(Y,$L(Y) ) Q:$D(@(U _Y_"0)"))   ; valid f ile root
  1871   "RTN","ORC MEDT4",171 ,0)
  1872    . S DIC=1 ,DIC(0)="E Q",X=Y D ^ DIC S:Y>0  Y=+Y K:Y'> 0 Y
  1873   "RTN","ORC MEDT4",172 ,0)
  1874    W $C(7),! ,"Invalid  file!" G R T1
  1875   "RTN","ORC MEDT4",173 ,0)
  1876   RTQ S STR= $P(DOMAIN, ":",2),DOM AIN=Y_":"_ $S($L(STR) :STR,1:"EQ ")
  1877   "RTN","ORC MEDT4",174 ,0)
  1878    Q
  1879   "RTN","ORC MEDT4",175 ,0)
  1880    ;
  1881   "RTN","ORC MEDT4",176 ,0)
  1882   SET ; -- s et of code s
  1883   "RTN","ORC MEDT4",177 ,0)
  1884    N I,ORI,O RJ,ITEM,X, Y,ORQUIT,N EWLNG S OR J=0
  1885   "RTN","ORC MEDT4",178 ,0)
  1886    F I=1:1:$ L(DOMAIN," ;") S:$P(D OMAIN,";", I)'="" ITE M(I)=$P(DO MAIN,";",I )
  1887   "RTN","ORC MEDT4",179 ,0)
  1888    S ORI=0 F   S ORI=$O (ITEM(ORI) ) Q:ORI'>0   D SETEDI T Q:$G(ORQ UIT)!(Y="" )
  1889   "RTN","ORC MEDT4",180 ,0)
  1890    I $G(ORQU IT) S DOMA IN="^" Q
  1891   "RTN","ORC MEDT4",181 ,0)
  1892    S ORI=ORJ  F  S ORI= ORI+1 D SE TEDIT Q:$G (ORQUIT)!( Y="")  ; n ew codes
  1893   "RTN","ORC MEDT4",182 ,0)
  1894    I $G(ORQU IT) S DOMA IN="^" Q
  1895   "RTN","ORC MEDT4",183 ,0)
  1896    ; now don e editing,  rebuild D OMAIN
  1897   "RTN","ORC MEDT4",184 ,0)
  1898    S I=0,DOM AIN="" F   S I=$O(ITE M(I)) Q:I' >0  S NEWL NG=$L(DOMA IN)+$L(ITE M(I))+1 S: NEWLNG'>23 5 DOMAIN=D OMAIN_ITEM (I)_";" I  NEWLNG>235  W $C(7),! ,"Domain t oo long -  unable to  store all  codes."  H  2 Q
  1899   "RTN","ORC MEDT4",185 ,0)
  1900    Q
  1901   "RTN","ORC MEDT4",186 ,0)
  1902   SETEDIT ;  -- edit ea ch item in  DOMAIN
  1903   "RTN","ORC MEDT4",187 ,0)
  1904    N DIR,TEX T,CODE S D IR(0)="FAO ^1:5",DIR( "A")="INTE RNALLY-STO RED CODE:  "
  1905   "RTN","ORC MEDT4",188 ,0)
  1906    S CODE=$P ($G(ITEM(O RI)),":"), TEXT=$P($G (ITEM(ORI) ),":",2),O RJ=ORI
  1907   "RTN","ORC MEDT4",189 ,0)
  1908    S:$L(CODE ) DIR("B") =CODE
  1909   "RTN","ORC MEDT4",190 ,0)
  1910    D ^DIR S: $D(DUOUT)! ($D(DTOUT) ) ORQUIT=1  Q:$G(ORQU IT)!(X="")
  1911   "RTN","ORC MEDT4",191 ,0)
  1912    I X="@" K  ITEM(ORI)  Q
  1913   "RTN","ORC MEDT4",192 ,0)
  1914    S CODE=X  W "  WILL  STAND FOR:  " W:$L(TE XT) TEXT_" // "
  1915   "RTN","ORC MEDT4",193 ,0)
  1916   SE1 R Y:DT IME I '$T! (Y["^") S  ORQUIT=1 Q
  1917   "RTN","ORC MEDT4",194 ,0)
  1918    S:Y="" Y= TEXT I "@" [Y W $C(7) ,!,"  Requ ired value !",!,"'"_C ODE_"' WIL L STAND FO R: " W:$L( TEXT) TEXT _"// " G S E1
  1919   "RTN","ORC MEDT4",195 ,0)
  1920    S TEXT=Y, ITEM(ORI)= CODE_":"_T EXT
  1921   "RTN","ORC MEDT4",196 ,0)
  1922    Q
  1923   "RTN","ORC MEDT4",197 ,0)
  1924    ;
  1925   "RTN","ORC MEDT4",198 ,0)
  1926   OTHER ; --  no parame ters neede d
  1927   "RTN","ORC MEDT4",199 ,0)
  1928    S DOMAIN= ""
  1929   "RTN","ORC MEDT4",200 ,0)
  1930    Q
  1931   "RTN","ORC MEDT4",201 ,0)
  1932    ;
  1933   "RTN","ORC MEDT4",202 ,0)
  1934   FILENAME(F NUM) ; --  Returns na me of file  FNUM
  1935   "RTN","ORC MEDT4",203 ,0)
  1936    N ORY,Y D :$G(FNUM)  FILE^DID(+ FNUM,,"NAM E","ORY")
  1937   "RTN","ORC MEDT4",204 ,0)
  1938    S Y=$G(OR Y("NAME"))
  1939   "RTN","ORC MEDT4",205 ,0)
  1940    Q Y
  1941   "RTN","ORC MEDT4",206 ,0)
  1942   PTRCHK(DLG ,ARRNAME)  ; --check  for pointe rs to orde r dialog
  1943   "RTN","ORC MEDT4",207 ,0)
  1944    K ^TMP($J ,ARRNAME)
  1945   "RTN","ORC MEDT4",208 ,0)
  1946    N AREPTRS ,INC S ARE PTRS=0
  1947   "RTN","ORC MEDT4",209 ,0)
  1948    I +$G(DLG ) D
  1949   "RTN","ORC MEDT4",210 ,0)
  1950    .D OR100( DLG,ARRNAM E)
  1951   "RTN","ORC MEDT4",211 ,0)
  1952    .D ORD100 98(DLG,ARR NAME)
  1953   "RTN","ORC MEDT4",212 ,0)
  1954    .D PTR801 41^ORQQPXR M(DLG_";OR D(101.41," ,ARRNAME)
  1955   "RTN","ORC MEDT4",213 ,0)
  1956    S AREPTRS =$D(^TMP($ J,ARRNAME) )
  1957   "RTN","ORC MEDT4",214 ,0)
  1958    Q +AREPTR S
  1959   "RTN","ORC MEDT4",215 ,0)
  1960   PTRRPT(ARR NAME,ORIFN ) ; --show  list of p ointers to  order dia log
  1961   "RTN","ORC MEDT4",216 ,0)
  1962    N FILENUM ,ITEMIEN,I EN,TAB,ITE M,LINCNT,C ONTINUE S  (FILENUM,I TEMIEN,IEN ,CONTINUE) ="",LINCNT =0
  1963   "RTN","ORC MEDT4",217 ,0)
  1964    F FILENUM =100.98,80 1.41,100 D
  1965   "RTN","ORC MEDT4",218 ,0)
  1966    .I $D(^TM P($J,ARRNA ME,FILENUM )) D
  1967   "RTN","ORC MEDT4",219 ,0)
  1968    ..W @IOF  S (CONTINU E,ITEMIEN) =""
  1969   "RTN","ORC MEDT4",220 ,0)
  1970    ..W !,$P( ^ORD(101.4 1,ORIFN,0) ,U)_" is p ointed to  by:"
  1971   "RTN","ORC MEDT4",221 ,0)
  1972    ..W !,"FI LE  ",?13, "IEN",?23, "NAME"
  1973   "RTN","ORC MEDT4",222 ,0)
  1974    ..W !,$$R EPEAT^XLFS TR("-",27)
  1975   "RTN","ORC MEDT4",223 ,0)
  1976    ..F  S IT EMIEN=$O(^ TMP($J,ARR NAME,FILEN UM,ITEMIEN )) Q:ITEMI EN=""!(CON TINUE["^")   D
  1977   "RTN","ORC MEDT4",224 ,0)
  1978    ...S ITEM =^TMP($J,A RRNAME,FIL ENUM,ITEMI EN)
  1979   "RTN","ORC MEDT4",225 ,0)
  1980    ...W !,$S (FILENUM=1 00:"ORDER" ,FILENUM=1 00.98:"DIS PLAY GRP", FILENUM=80 1.41:"REMI NDER DLG", 1:FILENUM) ,?13,ITEMI EN
  1981   "RTN","ORC MEDT4",226 ,0)
  1982    ...W ?23, $S(FILENUM =100:"N/A" ,1:ITEM)
  1983   "RTN","ORC MEDT4",227 ,0)
  1984    ...S LINC NT=LINCNT+ 1
  1985   "RTN","ORC MEDT4",228 ,0)
  1986    ...I LINC NT#20=0 S  CONTINUE=$ $CONT I CO NTINUE'["^ " D HDR
  1987   "RTN","ORC MEDT4",229 ,0)
  1988    ...Q:CONT INUE["^"
  1989   "RTN","ORC MEDT4",230 ,0)
  1990    ..Q:$G(CO NTINUE)="^ "  S CONTI NUE=$$CONT  Q:CONTINU E["^"
  1991   "RTN","ORC MEDT4",231 ,0)
  1992    K ^TMP($J ,ARRNAME)
  1993   "RTN","ORC MEDT4",232 ,0)
  1994    Q
  1995   "RTN","ORC MEDT4",233 ,0)
  1996    ;
  1997   "RTN","ORC MEDT4",234 ,0)
  1998   OR100(DLG, ARR) ;100
  1999   "RTN","ORC MEDT4",235 ,0)
  2000    N ORIFN,T EMP
  2001   "RTN","ORC MEDT4",236 ,0)
  2002    S TEMP=DL G_";ORD(10 1.41,",ORI FN=""
  2003   "RTN","ORC MEDT4",237 ,0)
  2004    I $D(^OR( 100,"C",TE MP)) D
  2005   "RTN","ORC MEDT4",238 ,0)
  2006    .F  S ORI FN=$O(^OR( 100,"C",TE MP,ORIFN))  Q:ORIFN=" "  D
  2007   "RTN","ORC MEDT4",239 ,0)
  2008    ..Q:$D(^O R(100,ORIF N))=0
  2009   "RTN","ORC MEDT4",240 ,0)
  2010    ..I $P(^O R(100,ORIF N,0),U,5)= TEMP D  ;i f DIALOG h as pointer  to order  dialog
  2011   "RTN","ORC MEDT4",241 ,0)
  2012    ...S ^TMP ($J,ARR,10 0,ORIFN)=$ P(^OR(100, ORIFN,0),U ,5)
  2013   "RTN","ORC MEDT4",242 ,0)
  2014    S ORIFN=" "
  2015   "RTN","ORC MEDT4",243 ,0)
  2016    I $D(^OR( 100,"D",TE MP)) D
  2017   "RTN","ORC MEDT4",244 ,0)
  2018    .F  S ORI FN=$O(^OR( 100,"D",TE MP,ORIFN))  Q:ORIFN=" "  D
  2019   "RTN","ORC MEDT4",245 ,0)
  2020    ..Q:$D(^O R(100,ORIF N))=0
  2021   "RTN","ORC MEDT4",246 ,0)
  2022    ..I $P(^O R(100,ORIF N,3),U,4)= TEMP D  ;i f ITEM ORD ERED has p ointer to  order dial og
  2023   "RTN","ORC MEDT4",247 ,0)
  2024    ...S ^TMP ($J,ARR,10 0,ORIFN)=$ P(^OR(100, ORIFN,3),U ,4)
  2025   "RTN","ORC MEDT4",248 ,0)
  2026    Q
  2027   "RTN","ORC MEDT4",249 ,0)
  2028    ;
  2029   "RTN","ORC MEDT4",250 ,0)
  2030   ORD10098(D LG,ARR) ;1 00.98
  2031   "RTN","ORC MEDT4",251 ,0)
  2032    N DISGRP, DISIEN S D ISGRP="",D ISIEN=""
  2033   "RTN","ORC MEDT4",252 ,0)
  2034    F  S DISG RP=$O(^ORD (100.98,"B ",DISGRP))  Q:DISGRP= ""  D
  2035   "RTN","ORC MEDT4",253 ,0)
  2036    .F  S DIS IEN=$O(^OR D(100.98," B",DISGRP, DISIEN)) Q :DISIEN=""   D
  2037   "RTN","ORC MEDT4",254 ,0)
  2038    ..Q:^ORD( 100.98,"B" ,DISGRP,DI SIEN)=1  ; second B x -ref entry  for SHORT  NAME, Q t o avoid du plicates i n results
  2039   "RTN","ORC MEDT4",255 ,0)
  2040    ..I $P(^O RD(100.98, DISIEN,0), U,4)=DLG D   ;if DEFA ULT DIALOG  has point er to orde r dialog
  2041   "RTN","ORC MEDT4",256 ,0)
  2042    ...S ^TMP ($J,ARR,10 0.98,DISIE N)=$P(^ORD (100.98,DI SIEN,0),U)
  2043   "RTN","ORC MEDT4",257 ,0)
  2044    Q
  2045   "RTN","ORC MEDT4",258 ,0)
  2046    ;
  2047   "RTN","ORC MEDT4",259 ,0)
  2048   HDR ;heade r
  2049   "RTN","ORC MEDT4",260 ,0)
  2050    W @IOF
  2051   "RTN","ORC MEDT4",261 ,0)
  2052    W !,"FILE   ",?13,"I EN",?23,"N AME"
  2053   "RTN","ORC MEDT4",262 ,0)
  2054    W !,$$REP EAT^XLFSTR ("-",27)
  2055   "RTN","ORC MEDT4",263 ,0)
  2056    Q
  2057   "RTN","ORC MEDT4",264 ,0)
  2058   CONT() ; - - gives us er a chanc e to read  output fro m pointer  check
  2059   "RTN","ORC MEDT4",265 ,0)
  2060    N X,Y,DIR
  2061   "RTN","ORC MEDT4",266 ,0)
  2062    S DIR(0)= "FO",DIR(" A")="Press  any key t o continue  reviewing  pointer r eport"
  2063   "RTN","ORC MEDT4",267 ,0)
  2064    S DIR("?" )="Enter a ny key to  continue;  enter ^ to  exit."
  2065   "RTN","ORC MEDT4",268 ,0)
  2066    D ^DIR
  2067   "RTN","ORC MEDT4",269 ,0)
  2068    Q X
  2069   "RTN","ORC MEDT4",270 ,0)
  2070    ;
  2071   "RTN","ORC MEDT9")
  2072   0^5^B56544 037
  2073   "RTN","ORC MEDT9",1,0 )
  2074   ORCMEDT9 ; ISP/WAT -  Move/copy  utility fo r QOs ;08/ 03/16  11: 56
  2075   "RTN","ORC MEDT9",2,0 )
  2076    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**3 89,423,397 **;Dec 17,  1997;Buil d 17
  2077   "RTN","ORC MEDT9",3,0 )
  2078   UDQO ; --  unit dose  quick orde r
  2079   "RTN","ORC MEDT9",4,0 )
  2080    N ORQDLG, ORDG,ORCMD G,ORCIDG,O RABORT,ORP MAX,ORINDE X
  2081   "RTN","ORC MEDT9",5,0 )
  2082    N ORSTART  S ORSTART =""
  2083   "RTN","ORC MEDT9",6,0 )
  2084    S ORABORT =0,ORPMAX= IOSL-5,ORI NDEX=""
  2085   "RTN","ORC MEDT9",7,0 )
  2086    S ORCMDG= $O(^ORD(10 0.98,"B"," CLINIC MED ICATIONS", ""))
  2087   "RTN","ORC MEDT9",8,0 )
  2088    S ORCIDG= $O(^ORD(10 0.98,"B"," CLINIC INF USIONS","" ))
  2089   "RTN","ORC MEDT9",9,0 )
  2090    I +$G(ORC MDG)'>0 W  !,"Abort:  Clinic Med ications d isplay gro up not fou nd!" Q
  2091   "RTN","ORC MEDT9",10, 0)
  2092    I +$G(ORC IDG)'>0 W  !,"Abort:  Clinic Inf usions dis play group  not found !" Q
  2093   "RTN","ORC MEDT9",11, 0)
  2094    D BLDUDQO
  2095   "RTN","ORC MEDT9",12, 0)
  2096    F  D  Q:O RABORT=1
  2097   "RTN","ORC MEDT9",13, 0)
  2098    . D DISP( ORPMAX,.OR INDEX)
  2099   "RTN","ORC MEDT9",14, 0)
  2100    . D CHOOS E(.ORABORT )
  2101   "RTN","ORC MEDT9",15, 0)
  2102    D CLEAN^D ILF
  2103   "RTN","ORC MEDT9",16, 0)
  2104    Q
  2105   "RTN","ORC MEDT9",17, 0)
  2106    ;
  2107   "RTN","ORC MEDT9",18, 0)
  2108   CHOOSE(ORA BORT) ;sel ect qo for  action
  2109   "RTN","ORC MEDT9",19, 0)
  2110    N ORACT
  2111   "RTN","ORC MEDT9",20, 0)
  2112    N DIR,X,Y ,DIRUT,DTO UT,DUOUT
  2113   "RTN","ORC MEDT9",21, 0)
  2114    S DIR(0)= "LO"
  2115   "RTN","ORC MEDT9",22, 0)
  2116    D ^DIR
  2117   "RTN","ORC MEDT9",23, 0)
  2118    I $D(DTOU T) S ORABO RT=1 Q
  2119   "RTN","ORC MEDT9",24, 0)
  2120    I $D(DUOU T) S ORABO RT=1 Q
  2121   "RTN","ORC MEDT9",25, 0)
  2122    Q:X=""
  2123   "RTN","ORC MEDT9",26, 0)
  2124    I X'[","& (X'["-")&( $D(^TMP("O RUDQO",$J, X))) D  Q   ;single s election c an Move OR  Copy
  2125   "RTN","ORC MEDT9",27, 0)
  2126    . S ORACT =$$ACTASK
  2127   "RTN","ORC MEDT9",28, 0)
  2128    . I ORACT ="^" S ORA BORT=1 Q
  2129   "RTN","ORC MEDT9",29, 0)
  2130    . E  D AC TION(ORACT ,X)
  2131   "RTN","ORC MEDT9",30, 0)
  2132    I X[","!( X["-") D A CTION(1,Y)  ;check fo r series o f numbers.  Move only
  2133   "RTN","ORC MEDT9",31, 0)
  2134    Q
  2135   "RTN","ORC MEDT9",32, 0)
  2136    ;
  2137   "RTN","ORC MEDT9",33, 0)
  2138   ACTION(ORG O,ORNUMBER ) ;
  2139   "RTN","ORC MEDT9",34, 0)
  2140    ;ORGO=1 M OVE, ORGO= 2 COPY
  2141   "RTN","ORC MEDT9",35, 0)
  2142    N ORTEMP, ORCOUNT
  2143   "RTN","ORC MEDT9",36, 0)
  2144    S ORINDEX =ORSTART-1  ;if user  comes to a ction, try  to return  them to l ist in the  same set  of QOS i.e . #21-40
  2145   "RTN","ORC MEDT9",37, 0)
  2146    I $G(ORGO )=2 D COPY (ORNUMBER)  Q
  2147   "RTN","ORC MEDT9",38, 0)
  2148    I '$$MOVO K() Q
  2149   "RTN","ORC MEDT9",39, 0)
  2150    W !,"Movi ng selecte d quick or der(s)..."  H 5
  2151   "RTN","ORC MEDT9",40, 0)
  2152    S:$G(ORCM DG)="" ORC MDG=$O(^OR D(100.98," B","CLINIC  MEDICATIO NS",""))
  2153   "RTN","ORC MEDT9",41, 0)
  2154    S ORCOUNT =1
  2155   "RTN","ORC MEDT9",42, 0)
  2156    F  S ORTE MP=$P(ORNU MBER,",",O RCOUNT) Q: $G(ORTEMP) =""  D
  2157   "RTN","ORC MEDT9",43, 0)
  2158    . I $D(^T MP("ORUDQO ",$J,ORTEM P)) D MOVE (ORTEMP)
  2159   "RTN","ORC MEDT9",44, 0)
  2160    . S ORCOU NT=ORCOUNT +1
  2161   "RTN","ORC MEDT9",45, 0)
  2162    W " Done! " H 2
  2163   "RTN","ORC MEDT9",46, 0)
  2164    Q
  2165   "RTN","ORC MEDT9",47, 0)
  2166    ;
  2167   "RTN","ORC MEDT9",48, 0)
  2168   DISP(ORPMA X,ORINDEX)  ; show qo  dialogs f or action  choices
  2169   "RTN","ORC MEDT9",49, 0)
  2170    N ORDLGNM ,ORIFN,ORQ ONAM,ORDIS ABL,ORDG
  2171   "RTN","ORC MEDT9",50, 0)
  2172    D HEADER
  2173   "RTN","ORC MEDT9",51, 0)
  2174    S ORIFN=" "
  2175   "RTN","ORC MEDT9",52, 0)
  2176    F  S ORIN DEX=$O(^TM P("ORUDQO" ,$J,ORINDE X)) Q:ORIN DEX=""  D   Q:$Y>ORPM AX
  2177   "RTN","ORC MEDT9",53, 0)
  2178    . I IOSL- $Y<5 D HEA DER
  2179   "RTN","ORC MEDT9",54, 0)
  2180    . S ORQON AM=$P(^TMP ("ORUDQO", $J,ORINDEX ),U,2),ORQ ONAM=$E(OR QONAM,1,45 )
  2181   "RTN","ORC MEDT9",55, 0)
  2182    . S ORDG= $P(^TMP("O RUDQO",$J, ORINDEX),U ,3)
  2183   "RTN","ORC MEDT9",56, 0)
  2184    . S ORDIS ABL=$P(^TM P("ORUDQO" ,$J,ORINDE X),U,4)
  2185   "RTN","ORC MEDT9",57, 0)
  2186    . W !,$J( ORINDEX,5) _". "_ORQO NAM,?60,OR DG,?70,ORD ISABL
  2187   "RTN","ORC MEDT9",58, 0)
  2188    S ORSTART =ORINDEX-O RPMAX
  2189   "RTN","ORC MEDT9",59, 0)
  2190    Q
  2191   "RTN","ORC MEDT9",60, 0)
  2192    ;
  2193   "RTN","ORC MEDT9",61, 0)
  2194   MOVE(ORQDL G) ;Move c hanges the  DISPLAY G ROUP to CL INIC MEDIC ATIONS or  CLINIC INF USIONS
  2195   "RTN","ORC MEDT9",62, 0)
  2196    ;ORQDLG i s the inde x from ^TM P("ORUDQO" ,$J,index) =order dia log ifn^or der NAME(. 01)^Displa yGroup^Dis abled
  2197   "RTN","ORC MEDT9",63, 0)
  2198    N ORIFN,O RCONVDG S  ORIFN=$P(^ TMP("ORUDQ O",$J,ORQD LG),U) Q:$ G(ORIFN)=" "
  2199   "RTN","ORC MEDT9",64, 0)
  2200    I $D(^ORD (101.41,OR IFN,0)) D   Q
  2201   "RTN","ORC MEDT9",65, 0)
  2202    . S ORCON VDG=$P(^TM P("ORUDQO" ,$J,ORQDLG ),U,3)
  2203   "RTN","ORC MEDT9",66, 0)
  2204    . S ORCON VDG=$S(ORC ONVDG="UDM ":ORCMDG,1 :ORCIDG)
  2205   "RTN","ORC MEDT9",67, 0)
  2206    . S $P(^O RD(101.41, ORIFN,0),U ,5)=$G(ORC ONVDG)
  2207   "RTN","ORC MEDT9",68, 0)
  2208    . I $D(^T MP("ORUDQO ",$J,ORQDL G)) K ^TMP ("ORUDQO", $J,ORQDLG)
  2209   "RTN","ORC MEDT9",69, 0)
  2210    E  D
  2211   "RTN","ORC MEDT9",70, 0)
  2212    . W $C(7) ,!,"Abort:  Order dia log not fo und - chec k file ent ry and try  again."
  2213   "RTN","ORC MEDT9",71, 0)
  2214    . W !,"Or der Dialog : "_$P(^OR D(101.41,O RIFN,0),U)
  2215   "RTN","ORC MEDT9",72, 0)
  2216    Q
  2217   "RTN","ORC MEDT9",73, 0)
  2218   COPY(ORQDL G) ;copy c reates a n ew CLINIC  MEDICATION S or CLINI C INFUSION S qo dialo g and will  ask to de lete the o riginal qo
  2219   "RTN","ORC MEDT9",74, 0)
  2220    ;ORQDLG i s the inde x from ^TM P("ORUDQO" ,$J,index) =order dia log ifn^or der NAME(. 01)^Displa yGroup^Dis abled
  2221   "RTN","ORC MEDT9",75, 0)
  2222    N ORQIFN, ORNUNAME,O RNUIFN,ORC UR0,ORESUL T,ORPOINT, OR30350,OR TMPDLG,ORD IGP
  2223   "RTN","ORC MEDT9",76, 0)
  2224    S OR30350 =$$PATCH^X PDUTL("OR* 3.0*350")  ;no delete  if 350 no t installe d
  2225   "RTN","ORC MEDT9",77, 0)
  2226    S ORQIFN= $P(^TMP("O RUDQO",$J, ORQDLG),U)  Q:+$G(ORQ IFN)'>0
  2227   "RTN","ORC MEDT9",78, 0)
  2228    S ORDIGP= $P(^TMP("O RUDQO",$J, ORQDLG),U, 3)
  2229   "RTN","ORC MEDT9",79, 0)
  2230    S ORDIGP= $S(ORDIGP= "UDM":ORCM DG,1:ORCID G)
  2231   "RTN","ORC MEDT9",80, 0)
  2232    Q:'$D(^OR D(101.41,O RQIFN,0))
  2233   "RTN","ORC MEDT9",81, 0)
  2234    S ORNUNAM E=$$GETNAM E() I $G(O RNUNAME)=" ^" S ORQDL G=ORNUNAME  Q
  2235   "RTN","ORC MEDT9",82, 0)
  2236    S ORNUIFN =$$STUB(10 1.41,ORNUN AME) I +$G (ORNUIFN)' >0 W !,"Er ror creati ng new ent ry. Please  try again  later." Q
  2237   "RTN","ORC MEDT9",83, 0)
  2238    N I,DA,DI E,DR,DIK,O RTEMP
  2239   "RTN","ORC MEDT9",84, 0)
  2240    S ORCUR0= ^ORD(101.4 1,ORQIFN,0 ) ;get 0 n ode of cur rent QO
  2241   "RTN","ORC MEDT9",85, 0)
  2242    F I=2,4,6 ,8,9 S $P( ^ORD(101.4 1,ORNUIFN, 0),U,I)=$P (ORCUR0,U, I)
  2243   "RTN","ORC MEDT9",86, 0)
  2244    S $P(^ORD (101.41,OR NUIFN,0),U ,5)=$G(ORD IGP)
  2245   "RTN","ORC MEDT9",87, 0)
  2246    S:$L($P(O RCUR0,U,2) ) ^ORD(101 .41,"C",$$ UP^XLFSTR( $P(ORCUR0, U,2)),ORNU IFN)="" ;d isp text
  2247   "RTN","ORC MEDT9",88, 0)
  2248    F I=2,3,3 .1,4,5,6,7 ,9,10 I $D (^ORD(101. 41,ORQIFN, I)) M ^ORD (101.41,OR NUIFN,I)=^ ORD(101.41 ,ORQIFN,I)
  2249   "RTN","ORC MEDT9",89, 0)
  2250    I $P(ORCU R0,U,7) S  ORTEMP=$P( ORCUR0,U,7 ),DA=ORNUI FN,DIE="^O RD(101.41, ",DR="7/// ^S X=ORTEM P;99///^S  X=$H" D ^D IE
  2251   "RTN","ORC MEDT9",90, 0)
  2252    K DA S DA (1)=ORNUIF N,DIK="^OR D(101.41," _ORNUIFN_" ,10,",DIK( 1)="2^AD"  D ENALL^DI K
  2253   "RTN","ORC MEDT9",91, 0)
  2254    W !!,"  Q uick order  copy comp lete."
  2255   "RTN","ORC MEDT9",92, 0)
  2256    I ($G(OR3 0350)=1) D   Q
  2257   "RTN","ORC MEDT9",93, 0)
  2258    . I '$$DE LOK() D  Q
  2259   "RTN","ORC MEDT9",94, 0)
  2260    . . W !," OK - If de sired, you  can manua lly delete  the QO vi a the QO e ditor."
  2261   "RTN","ORC MEDT9",95, 0)
  2262    . . S ORQ DLG="^" D  CONT("usin g the conv ersion uti lity")
  2263   "RTN","ORC MEDT9",96, 0)
  2264    . S ORPOI NT=$$PTRCH ECK(ORQIFN ) I +$G(OR POINT)>0 D   Q
  2265   "RTN","ORC MEDT9",97, 0)
  2266    . . S ORQ DLG="^" D  CONT("usin g the conv ersion uti lity")
  2267   "RTN","ORC MEDT9",98, 0)
  2268    . Q:$G(OR QDLG)="^"
  2269   "RTN","ORC MEDT9",99, 0)
  2270    . W !,"No w deleting  original  quick orde r..."
  2271   "RTN","ORC MEDT9",100 ,0)
  2272    . S ORESU LT=$$DELET E(ORQIFN)
  2273   "RTN","ORC MEDT9",101 ,0)
  2274    . I $G(OR ESULT)'="@ " W !,"Err or deletin g IEN "_OR QIFN_" fro m ORDER DI ALOG (101. 41)."
  2275   "RTN","ORC MEDT9",102 ,0)
  2276    . E  I $D (^TMP("ORU DQO",$J,OR QDLG)) K ^ TMP("ORUDQ O",$J,ORQD LG)
  2277   "RTN","ORC MEDT9",103 ,0)
  2278    Q
  2279   "RTN","ORC MEDT9",104 ,0)
  2280    ;
  2281   "RTN","ORC MEDT9",105 ,0)
  2282   BLDUDQO ;b uild list  of UDM and  IVM qos
  2283   "RTN","ORC MEDT9",106 ,0)
  2284    N ORUDMDG ,ORIVMED,O RDLGNM,ORI FN,ORINDEX ,ORDISABL, ORDG
  2285   "RTN","ORC MEDT9",107 ,0)
  2286    S ORINDEX =1,ORDLGNM =""
  2287   "RTN","ORC MEDT9",108 ,0)
  2288    S ORUDMDG =$O(^ORD(1 00.98,"B", "UNIT DOSE  MEDICATIO NS",""))
  2289   "RTN","ORC MEDT9",109 ,0)
  2290    S ORIVMED =$O(^ORD(1 00.98,"B", "IV MEDICA TIONS","") )
  2291   "RTN","ORC MEDT9",110 ,0)
  2292    Q:$G(ORUD MDG)=""!($ G(ORIVMED) ="")
  2293   "RTN","ORC MEDT9",111 ,0)
  2294    K ^TMP("O RUDQO",$J)
  2295   "RTN","ORC MEDT9",112 ,0)
  2296    F  S ORDL GNM=$O(^OR D(101.41," B",ORDLGNM ))  Q:$G(O RDLGNM)=""   D
  2297   "RTN","ORC MEDT9",113 ,0)
  2298    . S ORIFN =$O(^ORD(1 01.41,"B", ORDLGNM,"" ))
  2299   "RTN","ORC MEDT9",114 ,0)
  2300    . Q:+$G(O RIFN)'>0
  2301   "RTN","ORC MEDT9",115 ,0)
  2302    . Q:$P($G (^ORD(101. 41,ORIFN,0 )),U,5)'=O RUDMDG&($P ($G(^ORD(1 01.41,ORIF N,0)),U,5) '=ORIVMED) !($P($G(^O RD(101.41, ORIFN,0)), U,5)="")
  2303   "RTN","ORC MEDT9",116 ,0)
  2304    . Q:$P($G (^(0)),U,4 )'="Q"
  2305   "RTN","ORC MEDT9",117 ,0)
  2306    . Q:$E($P ($G(^(0)), U),1,6)="O RWDQ "
  2307   "RTN","ORC MEDT9",118 ,0)
  2308    . S ORDIS ABL=$P($G( ^(0)),U,3)
  2309   "RTN","ORC MEDT9",119 ,0)
  2310    . S ORDG= $P($G(^(0) ),U,5) S O RDG=$S(ORD G=ORUDMDG: "UDM",ORDG =ORIVMED:" IVM",1:"")
  2311   "RTN","ORC MEDT9",120 ,0)
  2312    . S ORDIS ABL=$S($L( $G(ORDISAB L))>0:"YES ",1:"")
  2313   "RTN","ORC MEDT9",121 ,0)
  2314    . S ^TMP( "ORUDQO",$ J,ORINDEX) =ORIFN_"^" _$P(^ORD(1 01.41,ORIF N,0),U)_"^ "_ORDG_"^" _ORDISABL, ORINDEX=OR INDEX+1
  2315   "RTN","ORC MEDT9",122 ,0)
  2316    Q
  2317   "RTN","ORC MEDT9",123 ,0)
  2318    ;
  2319   "RTN","ORC MEDT9",124 ,0)
  2320   GETNAME()  ;get new n ame for co pied dialo g
  2321   "RTN","ORC MEDT9",125 ,0)
  2322    N DIR,X,Y  ;prompt f or new NAM E .01
  2323   "RTN","ORC MEDT9",126 ,0)
  2324    S DIR(0)= "F^3:63^", DIR("A")=" NAME"
  2325   "RTN","ORC MEDT9",127 ,0)
  2326    S DIR("?" )="Enter a  NAME (bet ween 3 and  63 charac ters) for  the new or der dialog ."
  2327   "RTN","ORC MEDT9",128 ,0)
  2328   NM D ^DIR
  2329   "RTN","ORC MEDT9",129 ,0)
  2330    I $D(DIRU T)!($D(DUO UT)) S Y=" ^" Q Y
  2331   "RTN","ORC MEDT9",130 ,0)
  2332    I $O(^ORD (101.41,"A B",X,""))' ="" W $C(7 ),!,"Anoth er entry a lready exi sts by thi s name!",!  S X="" G  NM
  2333   "RTN","ORC MEDT9",131 ,0)
  2334    K:X[""""! ($A(X)=45)  X I $D(X)  K:$L(X)>6 3!($L(X)<3 )!'(X'?1P. E) X
  2335   "RTN","ORC MEDT9",132 ,0)
  2336    I '$D(X)  G NM
  2337   "RTN","ORC MEDT9",133 ,0)
  2338    Q Y
  2339   "RTN","ORC MEDT9",134 ,0)
  2340   PTRCHECK(O RIEN) ; ch eck for po inters if  Copy actio n
  2341   "RTN","ORC MEDT9",135 ,0)
  2342    N IHAZPTR  S IHAZPTR =0
  2343   "RTN","ORC MEDT9",136 ,0)
  2344    I $D(^ORD (101.41,"A D",ORIEN))  S IHAZPTR =1 W $C(7) ,!,"Cannot  delete or der dialog  - current ly in use! ",! Q IHAZ PTR
  2345   "RTN","ORC MEDT9",137 ,0)
  2346    S IHAZPTR =$$PTRCHK^ ORCMEDT4(O RIEN,"QO P TRS")
  2347   "RTN","ORC MEDT9",138 ,0)
  2348    I IHAZPTR  D
  2349   "RTN","ORC MEDT9",139 ,0)
  2350    . W $C(7) ,!,"Cannot  delete or der dialog  - other f ile entrie s point to  this orde r dialog!" ,!
  2351   "RTN","ORC MEDT9",140 ,0)
  2352    . D CONT( "reviewing  pointer r eport")
  2353   "RTN","ORC MEDT9",141 ,0)
  2354    . D PTRRP T^ORCMEDT4 ("QO PTRS" ,ORIEN)
  2355   "RTN","ORC MEDT9",142 ,0)
  2356    Q IHAZPTR
  2357   "RTN","ORC MEDT9",143 ,0)
  2358    ;
  2359   "RTN","ORC MEDT9",144 ,0)
  2360   ACTASK() ;  get actio n Move or  Copy
  2361   "RTN","ORC MEDT9",145 ,0)
  2362    N DIR,X,Y
  2363   "RTN","ORC MEDT9",146 ,0)
  2364    S DIR(0)= "S^1:MOVE; 2:COPY"
  2365   "RTN","ORC MEDT9",147 ,0)
  2366    S DIR("?" )="Choose  an action  for this q uick order "
  2367   "RTN","ORC MEDT9",148 ,0)
  2368    S DIR("?" ,1)="Move  converts t he selecte d QO into  a new Clin ic Medicat ion QO."
  2369   "RTN","ORC MEDT9",149 ,0)
  2370    S DIR("?" ,2)="Copy  clones the  selected  QO into a  new Clinic  Medicatio n QO."
  2371   "RTN","ORC MEDT9",150 ,0)
  2372    S DIR("?" ,3)="The o riginal QO  is then d eleted."
  2373   "RTN","ORC MEDT9",151 ,0)
  2374    D ^DIR
  2375   "RTN","ORC MEDT9",152 ,0)
  2376    S:$D(DTOU T)!($D(DUO UT)) Y="^"
  2377   "RTN","ORC MEDT9",153 ,0)
  2378    Q Y
  2379   "RTN","ORC MEDT9",154 ,0)
  2380    ;
  2381   "RTN","ORC MEDT9",155 ,0)
  2382   DELETE(IFN ) ;remove  old QO;
  2383   "RTN","ORC MEDT9",156 ,0)
  2384    N Y,DA,DI K,IDX1,IDX 2 S (IDX1, Y)=0
  2385   "RTN","ORC MEDT9",157 ,0)
  2386    F  S IDX1 =$O(^ORD(1 01.44,"C", IFN,IDX1))  Q:'IDX1   D
  2387   "RTN","ORC MEDT9",158 ,0)
  2388    . S IDX2= 0
  2389   "RTN","ORC MEDT9",159 ,0)
  2390    . F  S ID X2=$O(^ORD (101.44,"C ",IFN,IDX1 ,IDX2)) Q: 'IDX2  D
  2391   "RTN","ORC MEDT9",160 ,0)
  2392    . . S DA= IDX2,DA(1) =IDX1,DIK= "^ORD(101. 44,"_IDX1_ ",10," D ^ DIK
  2393   "RTN","ORC MEDT9",161 ,0)
  2394    K DA S DA =IFN,DIK=" ^ORD(101.4 1," D ^DIK  W "  ...d eleted." S  Y="@"
  2395   "RTN","ORC MEDT9",162 ,0)
  2396    Q Y
  2397   "RTN","ORC MEDT9",163 ,0)
  2398    ;
  2399   "RTN","ORC MEDT9",164 ,0)
  2400   STUB(ORFIL E,ORNAME)  ; create n ew entry i n file
  2401   "RTN","ORC MEDT9",165 ,0)
  2402    N FDA,MSG ,IEN
  2403   "RTN","ORC MEDT9",166 ,0)
  2404    S FDA(ORF ILE,"+1,", .01)=ORNAM E
  2405   "RTN","ORC MEDT9",167 ,0)
  2406    D UPDATE^ DIE("","FD A","IEN"," MSG")
  2407   "RTN","ORC MEDT9",168 ,0)
  2408    I $D(MSG) >0
  2409   "RTN","ORC MEDT9",169 ,0)
  2410    D CLEAN^D ILF
  2411   "RTN","ORC MEDT9",170 ,0)
  2412    Q IEN(1)
  2413   "RTN","ORC MEDT9",171 ,0)
  2414    ;
  2415   "RTN","ORC MEDT9",172 ,0)
  2416   CONT(MSG)  ; -- gives  user a ch ance to re ad output  from point er check
  2417   "RTN","ORC MEDT9",173 ,0)
  2418    N X,Y,DIR
  2419   "RTN","ORC MEDT9",174 ,0)
  2420    S DIR(0)= "FO",DIR(" A")="Press  any key t o continue  "_MSG
  2421   "RTN","ORC MEDT9",175 ,0)
  2422    S DIR("?" )="Enter a ny key to  continue;  enter ^ to  exit."
  2423   "RTN","ORC MEDT9",176 ,0)
  2424    D ^DIR
  2425   "RTN","ORC MEDT9",177 ,0)
  2426    Q
  2427   "RTN","ORC MEDT9",178 ,0)
  2428   DELOK() ;  -- Are you  ready?
  2429   "RTN","ORC MEDT9",179 ,0)
  2430    N X,Y,DIR
  2431   "RTN","ORC MEDT9",180 ,0)
  2432    S DIR(0)= "YA",DIR(" A")="Do yo u want to  delete the  original  quick orde r? ",DIR(" B")="NO"
  2433   "RTN","ORC MEDT9",181 ,0)
  2434    W ! D ^DI R
  2435   "RTN","ORC MEDT9",182 ,0)
  2436    Q +Y
  2437   "RTN","ORC MEDT9",183 ,0)
  2438   MOVOK() ;  -- Are you  ready?
  2439   "RTN","ORC MEDT9",184 ,0)
  2440    N X,Y,DIR
  2441   "RTN","ORC MEDT9",185 ,0)
  2442    S DIR(0)= "YA",DIR(" A")="Do yo u want to  MOVE the s elected qu ick order( s)? ",DIR( "B")="NO"
  2443   "RTN","ORC MEDT9",186 ,0)
  2444    W ! D ^DI R
  2445   "RTN","ORC MEDT9",187 ,0)
  2446    Q +Y
  2447   "RTN","ORC MEDT9",188 ,0)
  2448   HEADER ;he ader
  2449   "RTN","ORC MEDT9",189 ,0)
  2450    W @IOF
  2451   "RTN","ORC MEDT9",190 ,0)
  2452    W "...... .Quick Ord er",$$REPE AT^XLFSTR( ".",42),?6 0,"Type... ",?67,"Dis abled..... "
  2453   "RTN","ORC MEDT9",191 ,0)
  2454    Q
  2455   "RTN","ORC SAVE")
  2456   0^6^B12770 8326
  2457   "RTN","ORC SAVE",1,0)
  2458   ORCSAVE ;S LC/MKB/JDL -Save ;Mar  06, 2018@ 10:27
  2459   "RTN","ORC SAVE",2,0)
  2460    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**7 ,56,70,73, 92,94,116, 141,163,18 7,190,195, 243,303,29 3,280,306, 286,269,42 3,421,382, 397**;Dec  17, 1997;B uild 17
  2461   "RTN","ORC SAVE",3,0)
  2462    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  2463   "RTN","ORC SAVE",4,0)
  2464    ;
  2465   "RTN","ORC SAVE",5,0)
  2466    ; DBIA 10 103   ^XLF DT
  2467   "RTN","ORC SAVE",6,0)
  2468    ;
  2469   "RTN","ORC SAVE",7,0)
  2470   NEW(ORDIAL OG,ORDG,OR PKG,ORCAT, OREVENT,OR DUZ,ORLOG)  ; -- New  order
  2471   "RTN","ORC SAVE",8,0)
  2472    ; Returns  ORIFN = [ new] order  number, i f created/ saved
  2473   "RTN","ORC SAVE",9,0)
  2474    D EN
  2475   "RTN","ORC SAVE",10,0 )
  2476    Q
  2477   "RTN","ORC SAVE",11,0 )
  2478    ;
  2479   "RTN","ORC SAVE",12,0 )
  2480   XX ; -- sa ve new/unr eleased ed ited order  into Orde rs file
  2481   "RTN","ORC SAVE",13,0 )
  2482    ;    Requ ires: ORDI ALOG() = a rray of di alog value s
  2483   "RTN","ORC SAVE",14,0 )
  2484    ;               ORIF N      = I FN of orig inal order  that was  edited
  2485   "RTN","ORC SAVE",15,0 )
  2486    ;
  2487   "RTN","ORC SAVE",16,0 )
  2488    N OLDIFN  S ORIFN=+O RIFN,OLDIF N=0
  2489   "RTN","ORC SAVE",17,0 )
  2490    I $S($P(^ OR(100,ORI FN,3),U,3) =11:0,$P(^ (3),U,3)'= 10:1,$P(^( 8,1,0),U,4 )=2:0,1:1)  S OLDIFN= ORIFN K OR IFN ; crea te new ord er if rele ased or de layed&sign ed
  2491   "RTN","ORC SAVE",18,0 )
  2492    D EN Q:'O RIFN  S:'$ G(ORDA) OR DA=1
  2493   "RTN","ORC SAVE",19,0 )
  2494    I $G(OLDI FN) D  ;sa ve links b etween ord ers
  2495   "RTN","ORC SAVE",20,0 )
  2496    . S $P(^O R(100,ORIF N,3),U,5)= OLDIFN,$P( ^(3),U,11) =1
  2497   "RTN","ORC SAVE",21,0 )
  2498    . S $P(^O R(100,OLDI FN,3),U,6) =ORIFN S:$ D(^(5)) ^O R(100,ORIF N,5)=^OR(1 00,OLDIFN, 5)
  2499   "RTN","ORC SAVE",22,0 )
  2500    I $D(^OR( 100,+OLDIF N,0)) D
  2501   "RTN","ORC SAVE",23,0 )
  2502    . Q:'$G(O REVTDF)
  2503   "RTN","ORC SAVE",24,0 )
  2504    . N OLDEV T,OLDSTS,L STACT,PATI D,NOW,WHEN
  2505   "RTN","ORC SAVE",25,0 )
  2506    . S (OLDE VT,OLDSTS, LSTACT)=0
  2507   "RTN","ORC SAVE",26,0 )
  2508    . S NOW=$ $NOW^XLFDT
  2509   "RTN","ORC SAVE",27,0 )
  2510    . S OLDEV T=$P(^OR(1 00,+OLDIFN ,0),U,17), OLDSTS=$P( ^OR(100,+O LDIFN,3),U ,3)
  2511   "RTN","ORC SAVE",28,0 )
  2512    . ; Activ e status =  6 from #1 00.01
  2513   "RTN","ORC SAVE",29,0 )
  2514    . I (OLDE VT>0),OLDS TS=6 D
  2515   "RTN","ORC SAVE",30,0 )
  2516    . . S $P( ^OR(100,+O RIFN,0),U, 17)=OLDEVT
  2517   "RTN","ORC SAVE",31,0 )
  2518    . . S $P( ^OR(100,+O RIFN,3),U, 3)=11
  2519   "RTN","ORC SAVE",32,0 )
  2520    . . S LST ACT=$P($G( ^OR(100,+O RIFN,3)),U ,7)
  2521   "RTN","ORC SAVE",33,0 )
  2522    . . I $D( ^OR(100,+O RIFN,8,LST ACT,0)) D
  2523   "RTN","ORC SAVE",34,0 )
  2524    . . . S $ P(^OR(100, +ORIFN,8,L STACT,0),U ,15)=11
  2525   "RTN","ORC SAVE",35,0 )
  2526    . . . S P ATID=$P(^O R(100,+ORI FN,0),U,2)
  2527   "RTN","ORC SAVE",36,0 )
  2528    . . . S W HEN=$P(^OR (100,+ORIF N,8,LSTACT ,0),U)
  2529   "RTN","ORC SAVE",37,0 )
  2530    . . . S ^ OR(100,"AC ",PATID,99 99999-WHEN ,+ORIFN,LS TACT)=""
  2531   "RTN","ORC SAVE",38,0 )
  2532    Q
  2533   "RTN","ORC SAVE",39,0 )
  2534    ;
  2535   "RTN","ORC SAVE",40,0 )
  2536   RN ; -- sa ve new/unr eleased re newal orde r into Ord ers file
  2537   "RTN","ORC SAVE",41,0 )
  2538    ;    Requ ires: ORDI ALOG() = a rray of ne w dialog v alues
  2539   "RTN","ORC SAVE",42,0 )
  2540    ;               ORIF N      = I FN of orig inal order  that was  renewed
  2541   "RTN","ORC SAVE",43,0 )
  2542    ;
  2543   "RTN","ORC SAVE",44,0 )
  2544    N OLDIFN  S OLDIFN=+ ORIFN K OR IFN
  2545   "RTN","ORC SAVE",45,0 )
  2546    D EN Q:'O RIFN  S:'$ G(ORDA) OR DA=1
  2547   "RTN","ORC SAVE",46,0 )
  2548    S $P(^OR( 100,ORIFN, 3),U,5)=OL DIFN,$P(^( 3),U,11)=2
  2549   "RTN","ORC SAVE",47,0 )
  2550    S $P(^OR( 100,OLDIFN ,3),U,6)=O RIFN S:$D( ^(5)) ^OR( 100,ORIFN, 5)=^OR(100 ,OLDIFN,5)
  2551   "RTN","ORC SAVE",48,0 )
  2552    Q
  2553   "RTN","ORC SAVE",49,0 )
  2554    ;
  2555   "RTN","ORC SAVE",50,0 )
  2556   EN ; -- sa ve new/unr eleased or der in ORD IALOG() in to Orders  file
  2557   "RTN","ORC SAVE",51,0 )
  2558    ;    Requ ires: ORVP , ORNP [an d ORL, ORT S, ORAPPT  if availab le]
  2559   "RTN","ORC SAVE",52,0 )
  2560    ;    If d efined: OR CAT,ORPKG, ORDG,ORLOG ,ORDUZ,ORE VENT,ORDCN TRL,ORSRC
  2561   "RTN","ORC SAVE",53,0 )
  2562    ;     (el se use val ues from O RDIALOG an d current  state)
  2563   "RTN","ORC SAVE",54,0 )
  2564    ;
  2565   "RTN","ORC SAVE",55,0 )
  2566    N PKG,NOW ,NODE,CNT, CDL,I,X,ST S,SIGNREQD ,LOC,TRSPE C,NATR,CAT G,DG,LOG,U SR,TYPE,OR K
  2567   "RTN","ORC SAVE",56,0 )
  2568    Q:'$G(ORV P)  Q:'$G( ORDIALOG)   Q:'$D(^OR D(101.41,+ ORDIALOG,0 ))
  2569   "RTN","ORC SAVE",57,0 )
  2570    S NOW=$$N OW^XLFDT,S IGNREQD=+$ P(^ORD(101 .41,+ORDIA LOG,0),U,6 )
  2571   "RTN","ORC SAVE",58,0 )
  2572    S CATG=$S ($L($G(ORC AT)):ORCAT ,1:$S($$IN PT^ORCD:"I ",1:"O"))
  2573   "RTN","ORC SAVE",59,0 )
  2574    S PKG=$S( $G(ORPKG): ORPKG,1:$P (^ORD(101. 41,+ORDIAL OG,0),U,7) )
  2575   "RTN","ORC SAVE",60,0 )
  2576    S LOG=$S( $G(ORLOG): ORLOG,1:+$ E(NOW,1,12 )),USR=$S( $G(ORDUZ): ORDUZ,1:DU Z)
  2577   "RTN","ORC SAVE",61,0 )
  2578    I $G(ORIF N),$D(^OR( 100,ORIFN, 0)) S STS= $P(^(3),U, 3) G EN2 ;  unrel ord er
  2579   "RTN","ORC SAVE",62,0 )
  2580    S DG=$S($ G(ORDG):+O RDG,1:$P(^ ORD(101.41 ,+ORDIALOG ,0),U,5))
  2581   "RTN","ORC SAVE",63,0 )
  2582    I $G(OREV ENT),"^PSO ^RA^"'["^" _$$GET1^DI Q(9.4,+PKG _",",1)_"^ ",'$G(DGPM T) S LOC=" ",TRSPEC=" " ; p286 a dded radio logy packa ge
  2583   "RTN","ORC SAVE",64,0 )
  2584    E  S LOC= $G(ORL),TR SPEC=$G(OR TS)
  2585   "RTN","ORC SAVE",65,0 )
  2586    S TYPE=$S ("^B^C^X^P ^0^"[(U_$G (ORSRC)_U) :ORSRC,$G( ORDCNTRL)= "SN":"P",1 :0)
  2587   "RTN","ORC SAVE",66,0 )
  2588    ;S LOG=$S ($G(ORLOG) :ORLOG,1:+ $E(NOW,1,1 2)),USR=$S ($G(ORDUZ) :ORDUZ,1:D UZ) moved  up before  EN2 call
  2589   "RTN","ORC SAVE",67,0 )
  2590    S NATR=+$ O(^ORD(100 .02,"C","E ",0)) ;ass ume Elec E ntered unt il changed
  2591   "RTN","ORC SAVE",68,0 )
  2592    S STS=$S( $G(OREVENT ):10,1:11) ,ORIFN=$$N EXTIFN Q:' ORIFN
  2593   "RTN","ORC SAVE",69,0 )
  2594   EN1 S ^OR( 100,ORIFN, 0)=ORIFN_U _ORVP_U_U_ $G(ORNP)_U _+ORDIALOG _";ORD(101 .41,^"_USR _U_LOG_U_U _U_LOC_U_D G_U_CATG_U _TRSPEC_U_ PKG_U_U_SI GNREQD_U_$ G(OREVENT) _U_$G(ORAP PT)
  2595   "RTN","ORC SAVE",70,0 )
  2596    S ^OR(100 ,ORIFN,3)= LOG_"^90^" _STS_U_$S( $G(ORIT):O RIT_";ORD( 101.41,",1 :"")_U_$G( ORDIALOG(" PREV"))_"^ ^1^^^^"_TY PE
  2597   "RTN","ORC SAVE",71,0 )
  2598    S ^OR(100 ,ORIFN,8,0 )="^100.00 8DA^1^1",^ OR(100,ORI FN,8,1,0)= LOG_"^NW^" _$G(ORNP)_ U_$S(SIGNR EQD:2,1:3) _"^^^^^^^^ "_NATR_U_U SR_"^1^"_S TS,^OR(100 ,ORIFN,8," C","NW",1) =""
  2599   "RTN","ORC SAVE",72,0 )
  2600    S ^OR(100 ,"AF",LOG, ORIFN,1)=" "
  2601   "RTN","ORC SAVE",73,0 )
  2602    S ^OR(100 ,"C",+ORDI ALOG_";ORD (101.41,", ORIFN)=""   ;patch 42 3
  2603   "RTN","ORC SAVE",74,0 )
  2604    S:+$G(ORI T) ^OR(100 ,"D",+ORIT _";ORD(101 .41,",ORIF N)=""  ;pa tch 423
  2605   "RTN","ORC SAVE",75,0 )
  2606    S ^OR(100 ,"ACT",ORV P,9999999- LOG,+DG,OR IFN,1)=""
  2607   "RTN","ORC SAVE",76,0 )
  2608    ;US10045  - PB - Nov  19, 2015  modificati on to capt ure the or der create  date/time  with seco nds in HMP (800000 or ders multi ple to tra ck seconds
  2609   "RTN","ORC SAVE",77,0 )
  2610    D:$P(ORVP ,";",2)="D PT("
  2611   "RTN","ORC SAVE",78,0 )
  2612    . N RSLT, VALS
  2613   "RTN","ORC SAVE",79,0 )
  2614    . S VALS( .02)=$$NOW ^XLFDT
  2615   "RTN","ORC SAVE",80,0 )
  2616    . D ADDOR DR^HMPOR(. RSLT,.VALS ,ORIFN,+OR VP)  ;ORVP  is variab le pointer
  2617   "RTN","ORC SAVE",81,0 )
  2618    . Q:RSLT< 0  ; sub-f ile entry  not create d
  2619   "RTN","ORC SAVE",82,0 )
  2620    . D COMP^ ORMBLDOR(+ $G(ORIFN))  ;Nov 12,  2015 - PB  - trigger  unsolicite d sync act ion when o rder is sa ved
  2621   "RTN","ORC SAVE",83,0 )
  2622    ;
  2623   "RTN","ORC SAVE",84,0 )
  2624    S:STS'=10  ^OR(100," AC",ORVP,9 999999-LOG ,ORIFN,1)= ""
  2625   "RTN","ORC SAVE",85,0 )
  2626    S:SIGNREQ D ^OR(100, "AS",ORVP, 9999999-LO G,ORIFN,1) =""
  2627   "RTN","ORC SAVE",86,0 )
  2628    S:$G(OREV ENT) ^OR(1 00,"AEVNT" ,ORVP,OREV ENT,ORIFN) =""
  2629   "RTN","ORC SAVE",87,0 )
  2630    ;check if  OR GTX ST UDY REASON  is in ORD IALOG and  strip out  control ch aracters
  2631   "RTN","ORC SAVE",88,0 )
  2632    N ORRFSID
  2633   "RTN","ORC SAVE",89,0 )
  2634    S ORRFSID =$O(^ORD(1 01.41,"B", "OR GTX ST UDY REASON ",""))
  2635   "RTN","ORC SAVE",90,0 )
  2636    I ORRFSID ,$D(ORDIAL OG(ORRFSID ,1)) D
  2637   "RTN","ORC SAVE",91,0 )
  2638    .N X,I
  2639   "RTN","ORC SAVE",92,0 )
  2640    .S X=ORDI ALOG(ORRFS ID,1)
  2641   "RTN","ORC SAVE",93,0 )
  2642    .F I=1:1: 31 S X=$TR (X,$C(I))
  2643   "RTN","ORC SAVE",94,0 )
  2644    .S ORDIAL OG(ORRFSID ,1)=X
  2645   "RTN","ORC SAVE",95,0 )
  2646   EN2 S ORIF N=+ORIFN D  RESPONSE  ; save res ponses
  2647   "RTN","ORC SAVE",96,0 )
  2648    I $P(^OR( 100,ORIFN, 0),"^",5)  D  ;Copy o rders PKI  fix
  2649   "RTN","ORC SAVE",97,0 )
  2650    . N OI,OR PKIU
  2651   "RTN","ORC SAVE",98,0 )
  2652    . S OI=+$ O(^OR(100, ORIFN,4.5, "ID","ORDE RABLE",0)) ,OI=+$G(^O R(100,ORIF N,4.5,OI,1 )) Q:'OI
  2653   "RTN","ORC SAVE",99,0 )
  2654    . I PKG'= $O(^DIC(9. 4,"B","OUT PATIENT PH ARMACY",0) ) Q
  2655   "RTN","ORC SAVE",100, 0)
  2656    . S ORPKI U=0 I $D(^ ORD(100.7, "C",DUZ))  S ORPKIU=1
  2657   "RTN","ORC SAVE",101, 0)
  2658    . D PKI^O RWDPS1(.OR Y,OI,CATG, +ORVP,ORPK IU)
  2659   "RTN","ORC SAVE",102, 0)
  2660    . I $E($G (ORY))=2 S  ORDEA=ORY
  2661   "RTN","ORC SAVE",103, 0)
  2662    K ^OR(100 ,ORIFN,8,1 ,.1) D ORD TEXT^ORCSA VE1(ORIFN_ ";1") ; or der text
  2663   "RTN","ORC SAVE",104, 0)
  2664    S NODE=$G (^OR(100,O RIFN,8,1,0 )) D  S ^O R(100,ORIF N,8,1,0)=N ODE
  2665   "RTN","ORC SAVE",105, 0)
  2666    . S $P(NO DE,U,3)=$G (ORNP)
  2667   "RTN","ORC SAVE",106, 0)
  2668    . S $P(NO DE,U,13)=U SR
  2669   "RTN","ORC SAVE",107, 0)
  2670    S NODE=$G (^OR(100,O RIFN,0)) D   S ^OR(10 0,ORIFN,0) =NODE
  2671   "RTN","ORC SAVE",108, 0)
  2672    . S $P(NO DE,U,4)=$G (ORNP)
  2673   "RTN","ORC SAVE",109, 0)
  2674    . S I=$O( ^OR(100,OR IFN,4.5,"I D","LOCATI ON",0))
  2675   "RTN","ORC SAVE",110, 0)
  2676    . I I,$P( NODE,U,10)  S X=+$G(^ OR(100,ORI FN,4.5,+I, 1)) S:X $P (NODE,U,10 )=X_";SC("  ;reset Lo c if prev  value
  2677   "RTN","ORC SAVE",111, 0)
  2678    . S I=$O( ^OR(100,OR IFN,4.5,"I D","CLASS" ,0))
  2679   "RTN","ORC SAVE",112, 0)
  2680    . I I S X =$G(^OR(10 0,ORIFN,4. 5,+I,1)) S :"^I^O^"[( U_X_U) $P( NODE,U,12) =X
  2681   "RTN","ORC SAVE",113, 0)
  2682    S $P(^OR( 100,ORIFN, 3),U)=NOW
  2683   "RTN","ORC SAVE",114, 0)
  2684    D DELOCC^ OROCAPI1(O RIFN,"ACCE PTANCE_CPR S")
  2685   "RTN","ORC SAVE",115, 0)
  2686    I $G(ORCH ECK) D  ;  save order  checks
  2687   "RTN","ORC SAVE",116, 0)
  2688    . N ORCRO C
  2689   "RTN","ORC SAVE",117, 0)
  2690    . S (CNT, CDL)=0 F   S CDL=$O(O RCHECK("NE W",CDL)) Q :CDL'>0  S  I=0 D
  2691   "RTN","ORC SAVE",118, 0)
  2692    . . F  S  I=$O(ORCHE CK("NEW",C DL,I)) Q:I '>0  D
  2693   "RTN","ORC SAVE",119, 0)
  2694    . . . I $ D(ORCHECK( "NEW",CDL, I,0)) D
  2695   "RTN","ORC SAVE",120, 0)
  2696    . . . . N  J S J=0,O RCHECK("NE W",CDL,I)= ORCHECK("N EW",CDL,I, J) F  S J= $O(ORCHECK ("NEW",CDL ,I,J)) Q:' J  S ORCHE CK("NEW",C DL,I)=ORCH ECK("NEW", CDL,I)_ORC HECK("NEW" ,CDL,I,J)
  2697   "RTN","ORC SAVE",121, 0)
  2698    . . . S X =ORCHECK(" NEW",CDL,I )
  2699   "RTN","ORC SAVE",122, 0)
  2700    . . . S O RK(I,1)=+O RIFN_U_"AC CEPTANCE_C PRS"_U_DUZ _U_$$NOW^X LFDT_U_$P( X,U)_U_CDL
  2701   "RTN","ORC SAVE",123, 0)
  2702    . . . S O RK(I,2,1)= $P(X,U,3)
  2703   "RTN","ORC SAVE",124, 0)
  2704    . . . I $ E(ORK(I,2, 1),0,2)="| |" D
  2705   "RTN","ORC SAVE",125, 0)
  2706    . . . . N  ORGLOB,OR RULE,ORI,O RLINE
  2707   "RTN","ORC SAVE",126, 0)
  2708    . . . . S  ORGLOB=$P ($P(ORK(I, 2,1),"||", 2),"&"),OR RULE=$P($P (ORK(I,2,1 ),"||",2), "&",2)
  2709   "RTN","ORC SAVE",127, 0)
  2710    . . . . S  ORCROC(I) =$P($P(ORK (I,2,1),"| |",2),"&", 3)_U_$P($P (ORK(I,2,1 ),"||",2), "&",4)
  2711   "RTN","ORC SAVE",128, 0)
  2712    . . . . S  ORK(I,2,1 )=ORRULE,O RI=0,ORLIN E=2
  2713   "RTN","ORC SAVE",129, 0)
  2714    . . . . F   S ORI=$O (^TMP($J," ORK XTRA T XT",ORGLOB ,ORRULE,OR I)) Q:'ORI   S ORK(I, 2,ORLINE)= ^TMP($J,"O RK XTRA TX T",ORGLOB, ORRULE,ORI ),ORLINE=O RLINE+1
  2715   "RTN","ORC SAVE",130, 0)
  2716    . I $D(OR K) D
  2717   "RTN","ORC SAVE",131, 0)
  2718    . . N OCR ET,ORKI
  2719   "RTN","ORC SAVE",132, 0)
  2720    . . D SAV EOC^OROCAP I1(.ORK,.O CRET)
  2721   "RTN","ORC SAVE",133, 0)
  2722    . . I $D( ORCROC) D
  2723   "RTN","ORC SAVE",134, 0)
  2724    . . . N O RCROCI S O RCROCI=0 F   S ORCROC I=$O(ORCRO C(ORCROCI) ) Q:'ORCRO CI  D
  2725   "RTN","ORC SAVE",135, 0)
  2726    . . . . N  OCINST S  OCINST=$O( OCRET(ORCR OCI,"")) Q :'OCINST   D
  2727   "RTN","ORC SAVE",136, 0)
  2728    . . . . .  S ^ORD(10 0.05,OCINS T,12)=ORCR OC(ORCROCI )
  2729   "RTN","ORC SAVE",137, 0)
  2730    . . S ORK I=0 F  S O RKI=$O(ORK (ORKI)) Q: 'ORKI  D
  2731   "RTN","ORC SAVE",138, 0)
  2732    . . . N O CINST,OCTX T S OCTXT= $G(ORK(ORK I,2,1))
  2733   "RTN","ORC SAVE",139, 0)
  2734    . . . S O CINST=$O(O CRET(ORKI, 0))
  2735   "RTN","ORC SAVE",140, 0)
  2736    . . . N O RMONOI,ORM ONOQ S ORM ONOI=0,ORM ONOQ=0 F   Q:ORMONOQ= 1  S ORMON OI=$O(^TMP ($J,"ORMON OGRAPH",OR MONOI)) Q: 'ORMONOI   D
  2737   "RTN","ORC SAVE",141, 0)
  2738    . . . . I  OCTXT[$G( ^TMP($J,"O RMONOGRAPH ",ORMONOI, "OC")) D
  2739   "RTN","ORC SAVE",142, 0)
  2740    . . . . .  S ORMONOQ =1
  2741   "RTN","ORC SAVE",143, 0)
  2742    . . . . .  S ^ORD(10 0.05,OCINS T,17)=^TMP ($J,"ORMON OGRAPH",OR MONOI,"INT ")
  2743   "RTN","ORC SAVE",144, 0)
  2744    . . . . .  M ^ORD(10 0.05,OCINS T,16)=^TMP ($J,"ORMON OGRAPH",OR MONOI,"DAT A")
  2745   "RTN","ORC SAVE",145, 0)
  2746    . . . . .  S ^ORD(10 0.05,OCINS T,16,0)="^ ^"_$O(^ORD (100.05,OC INST,16,"" ),-1)_U_$O (^ORD(100. 05,OCINST, 16,""),-1) _U_+$$NOW^ XLFDT_U
  2747   "RTN","ORC SAVE",146, 0)
  2748    . . K ^TM P($J,"ORMO NOGRAPH")
  2749   "RTN","ORC SAVE",147, 0)
  2750    . . K ^TM P($J,"ORK  XTRA TXT")
  2751   "RTN","ORC SAVE",148, 0)
  2752    K ORDEA
  2753   "RTN","ORC SAVE",149, 0)
  2754   ENQ Q
  2755   "RTN","ORC SAVE",150, 0)
  2756    ;
  2757   "RTN","ORC SAVE",151, 0)
  2758   NEXTIFN()  ; -- Retur ns next av ailable OR IFN
  2759   "RTN","ORC SAVE",152, 0)
  2760    N I,HDR,L AST,TOTAL, DA
  2761   "RTN","ORC SAVE",153, 0)
  2762    L +^OR(10 0,0):$S($G (DILOCKTM) >0:DILOCKT M,1:5)
  2763   "RTN","ORC SAVE",154, 0)
  2764    I '$T Q " ^"
  2765   "RTN","ORC SAVE",155, 0)
  2766    S HDR=$G( ^OR(100,0) ),TOTAL=+$ P(HDR,U,4) ,LAST=$O(^ OR(100,"?" ),-1)
  2767   "RTN","ORC SAVE",156, 0)
  2768    S I=LAST\ 1 F I=(I+1 ):1 Q:'$D( ^OR(100,I, 0))
  2769   "RTN","ORC SAVE",157, 0)
  2770    S DA=I,^O R(100,DA,0 )=DA,$P(HD R,U,3,4)=D A_U_(TOTAL +1)
  2771   "RTN","ORC SAVE",158, 0)
  2772    S ^OR(100 ,0)=HDR L  -^OR(100,0 )
  2773   "RTN","ORC SAVE",159, 0)
  2774    Q DA
  2775   "RTN","ORC SAVE",160, 0)
  2776    ;
  2777   "RTN","ORC SAVE",161, 0)
  2778   RESPONSE ;  -- Save r esponses i n ORDIALOG () into ^O R(100,ORIF N,4.5)
  2779   "RTN","ORC SAVE",162, 0)
  2780    N PROMPT, CNT,ITM,TY PE,INST,VA LUE,I,STAR T,PAT,X
  2781   "RTN","ORC SAVE",163, 0)
  2782    S PAT=$P( ^OR(100,OR IFN,0),U,2 ),START=$P (^(0),U,8)  K ^(4.5)
  2783   "RTN","ORC SAVE",164, 0)
  2784    S (PROMPT ,CNT)=0 F   S PROMPT= $O(ORDIALO G(PROMPT))  Q:PROMPT' >0  D
  2785   "RTN","ORC SAVE",165, 0)
  2786    . S ITM=$ G(ORDIALOG (PROMPT))  Q:'ITM
  2787   "RTN","ORC SAVE",166, 0)
  2788    . S TYPE= $E($G(ORDI ALOG(PROMP T,0))) Q:' $L(TYPE)
  2789   "RTN","ORC SAVE",167, 0)
  2790    . S INST= 0 F  S INS T=$O(ORDIA LOG(PROMPT ,INST)) Q: INST'>0  D
  2791   "RTN","ORC SAVE",168, 0)
  2792    . . S VAL UE=$G(ORDI ALOG(PROMP T,INST)) Q :VALUE=""   S CNT=CNT +1
  2793   "RTN","ORC SAVE",169, 0)
  2794    . . S ^OR (100,ORIFN ,4.5,CNT,0 )=+ITM_U_P ROMPT_U_IN ST_U_$P(IT M,U,2)
  2795   "RTN","ORC SAVE",170, 0)
  2796    . . S:$L( $P(ITM,U,2 )) ^OR(100 ,ORIFN,4.5 ,"ID",$P(I TM,U,2),CN T)=""
  2797   "RTN","ORC SAVE",171, 0)
  2798    . . I VAL UE<1,TYPE= "N" S VALU E=0_+VALUE  I VALUE=" 00" S VALU E=0
  2799   "RTN","ORC SAVE",172, 0)
  2800    . . S:TYP E'="W" ^OR (100,ORIFN ,4.5,CNT,1 )=VALUE
  2801   "RTN","ORC SAVE",173, 0)
  2802    . . M:TYP E="W" ^OR( 100,ORIFN, 4.5,CNT,2) =@VALUE ;  array root
  2803   "RTN","ORC SAVE",174, 0)
  2804    S ^OR(100 ,ORIFN,4.5 ,0)="^100. 045A^"_CNT _U_CNT
  2805   "RTN","ORC SAVE",175, 0)
  2806   R1 ; [Rese t] Orderab les
  2807   "RTN","ORC SAVE",176, 0)
  2808    I $D(^OR( 100,ORIFN, .1)) S I=0  F  S I=$O (^OR(100,O RIFN,.1,I) ) Q:I'>0   S X=$G(^(I ,0)) I X,P AT,START K  ^OR(100," AOI",X,PAT ,9999999-S TART,ORIFN ) ; kill x ref
  2809   "RTN","ORC SAVE",177, 0)
  2810    K ^OR(100 ,ORIFN,.1)  I $D(^OR( 100,ORIFN, 4.5,"ID"," ORDERABLE" )) D
  2811   "RTN","ORC SAVE",178, 0)
  2812    . S (I,CN T)=0
  2813   "RTN","ORC SAVE",179, 0)
  2814    . F  S I= $O(^OR(100 ,ORIFN,4.5 ,"ID","ORD ERABLE",I) ) Q:I'>0   D
  2815   "RTN","ORC SAVE",180, 0)
  2816    . . S X=$ G(^OR(100, ORIFN,4.5, I,1)) Q:'X
  2817   "RTN","ORC SAVE",181, 0)
  2818    . . S CNT =CNT+1,^OR (100,ORIFN ,.1,CNT,0) =X,^OR(100 ,ORIFN,.1, "B",X,CNT) =""
  2819   "RTN","ORC SAVE",182, 0)
  2820    . . I PAT ,START S ^ OR(100,"AO I",X,PAT,9 999999-STA RT,ORIFN)= ""
  2821   "RTN","ORC SAVE",183, 0)
  2822    . S ^OR(1 00,ORIFN,. 1,0)="^100 .001PA^"_C NT_U_CNT
  2823   "RTN","ORC SAVE",184, 0)
  2824    Q
  2825   "RTN","ORC SAVE",185, 0)
  2826    ;
  2827   "RTN","ORC SAVE",186, 0)
  2828   RESUME(IFN ) ; -- add  Response  nodes for  RESUME tra y service
  2829   "RTN","ORC SAVE",187, 0)
  2830    ; S ^OR(1 00,+IFN,4. 5,<next>,0 )=DT_"^^^R ESUME",^(1 )=1
  2831   "RTN","ORC SAVE",188, 0)
  2832    ;
  2833   "RTN","ORC SAVE",189, 0)
  2834    N X,Y,DA, DIC,DLAYGO
  2835   "RTN","ORC SAVE",190, 0)
  2836    S DIC="^O R(100,"_+I FN_",4.5," ,DIC(0)="L X",DA(1)=+ IFN,X=DT
  2837   "RTN","ORC SAVE",191, 0)
  2838    S DIC("DR ")=".04/// RESUME",DI C("P")=$P( ^DD(100,4. 5,0),U,2), DLAYGO=100
  2839   "RTN","ORC SAVE",192, 0)
  2840    D ^DIC S: Y ^OR(100, +IFN,4.5,+ Y,1)=1
  2841   "RTN","ORC SAVE",193, 0)
  2842    Q
  2843   "RTN","ORC SAVE",194, 0)
  2844    ;
  2845   "RTN","ORC SAVE",195, 0)
  2846   PROVIDER(O RDER,PROV)  ; -- Chan ge PROVide r assigned  to ORDER
  2847   "RTN","ORC SAVE",196, 0)
  2848    Q:'$G(ORD ER)  Q:'$G (PROV)
  2849   "RTN","ORC SAVE",197, 0)
  2850    N ORACT S  ORACT=+$P (ORDER,";" ,2) S:'ORA CT ORACT=1
  2851   "RTN","ORC SAVE",198, 0)
  2852    S $P(^OR( 100,+ORDER ,8,ORACT,0 ),U,3)=PRO V
  2853   "RTN","ORC SAVE",199, 0)
  2854    S:ORACT=1  $P(^OR(10 0,+ORDER,0 ),U,4)=PRO V
  2855   "RTN","ORC SAVE",200, 0)
  2856    Q
  2857   "RTN","ORC SAVE",201, 0)
  2858    ;
  2859   "RTN","ORC SAVE",202, 0)
  2860   ACTION(COD E,DA,PROV, REASON,WHE N,WHO) ; - - save new  action
  2861   "RTN","ORC SAVE",203, 0)
  2862    N NEXT,TO TAL,HDR,LA ST,X,PAT,D GRP,SIG,NA TR,TXT S D A=+DA
  2863   "RTN","ORC SAVE",204, 0)
  2864    Q:'$D(^OR (100,DA,0) ) 0 Q:$G(C ODE)'?2U 0
  2865   "RTN","ORC SAVE",205, 0)
  2866    S:'$G(WHE N) WHEN=+$ E($$NOW^XL FDT,1,12)  S:'$G(WHO)  WHO=DUZ
  2867   "RTN","ORC SAVE",206, 0)
  2868    S NATR=+$ O(^ORD(100 .02,"C","E ",0)) ;ass ume Elec E ntered unt il changed
  2869   "RTN","ORC SAVE",207, 0)
  2870    S PAT=$P( ^OR(100,DA ,0),U,2),D GRP=$P(^(0 ),U,11),SI G=$P(^(0), U,16),X=+$ P($G(^(3)) ,U,7),HDR= $G(^(8,0))
  2871   "RTN","ORC SAVE",208, 0)
  2872    S:X'>0 X= 1 S TXT=$P ($G(^OR(10 0,DA,8,X,0 )),U,14) ; current ac tn's txt p tr
  2873   "RTN","ORC SAVE",209, 0)
  2874    S:HDR=""  HDR="^100. 008DA^^" S  TOTAL=+$P (HDR,U,4)
  2875   "RTN","ORC SAVE",210, 0)
  2876    S LAST=$O (^OR(100,D A,8,"C",CO DE,"?"),-1 ) I LAST D
  2877   "RTN","ORC SAVE",211, 0)
  2878    . S X=$G( ^OR(100,DA ,8,LAST,0) ) Q:$P(X,U ,15)'=11   Q:$P(X,U,4 )'=2
  2879   "RTN","ORC SAVE",212, 0)
  2880    . S NEXT= LAST I PAT ,$P(X,U) D   ; kill o ld xref en tries
  2881   "RTN","ORC SAVE",213, 0)
  2882    . . K:DGR P ^OR(100, "ACT",PAT, (9999999-$ P(X,U)),DG RP,DA,NEXT )
  2883   "RTN","ORC SAVE",214, 0)
  2884    . . K ^OR (100,"AC", PAT,(99999 99-$P(X,U) ),DA,NEXT) ,^OR(100," AS",PAT,(9 999999-$P( X,U)),DA,N EXT),^OR(1 00,"AF",$P (X,U),DA,N EXT)
  2885   "RTN","ORC SAVE",215, 0)
  2886    S:'$G(NEX T) NEXT=$O (^OR(100,D A,8,"?"),- 1)+1,TOTAL =TOTAL+1
  2887   "RTN","ORC SAVE",216, 0)
  2888    S ^OR(100 ,DA,8,NEXT ,0)=WHEN_U _CODE_U_$G (PROV)_U_$ S(SIG:2,1: 3)_"^^^^^^ ^^"_NATR_U _WHO_U_TXT _"^11",^OR (100,DA,8, "C",CODE,N EXT)=""
  2889   "RTN","ORC SAVE",217, 0)
  2890    S ^OR(100 ,"AF",WHEN ,DA,NEXT)= ""
  2891   "RTN","ORC SAVE",218, 0)
  2892    I PAT,DGR P S ^OR(10 0,"ACT",PA T,9999999- WHEN,DGRP, DA,NEXT)=" "
  2893   "RTN","ORC SAVE",219, 0)
  2894    I PAT S ^ OR(100,"AC ",PAT,9999 999-WHEN,D A,NEXT)=""
  2895   "RTN","ORC SAVE",220, 0)
  2896    I SIG S ^ OR(100,"AS ",PAT,9999 999-WHEN,D A,NEXT)=""
  2897   "RTN","ORC SAVE",221, 0)
  2898    S:$L($G(R EASON)) ^O R(100,DA,8 ,NEXT,1)=R EASON
  2899   "RTN","ORC SAVE",222, 0)
  2900    S $P(HDR, U,3,4)=NEX T_U_TOTAL, ^OR(100,DA ,8,0)=HDR
  2901   "RTN","ORC SAVE",223, 0)
  2902    ;
  2903   "RTN","ORC SAVE",224, 0)
  2904    D   ; DE3 504 - Jan  19, 2016 , US10045 -  PB capture  the DC of  an order  not signed  in HMP(80 0000)
  2905   "RTN","ORC SAVE",225, 0)
  2906    . N FLD,H MDFN,HMORI S,JDSNOW,R SLT,SRVRNU M,VALS,ORI FN
  2907   "RTN","ORC SAVE",226, 0)
  2908    . S ORIFN =DA,HMDFN= +$P(^OR(10 0,+ORIFN,0 ),U,2),SRV RNUM=$$SRV RNO^HMPOR( HMDFN)
  2909   "RTN","ORC SAVE",227, 0)
  2910    . Q:'SRVR NUM  ; pat ient not i n the HMP( 800000 fil e
  2911   "RTN","ORC SAVE",228, 0)
  2912    . S HMORI S=$$ORDRCH K^HMPOR(+O RIFN,HMDFN )  ; does  order exis t?  ; Jan  26, 2016 -  DE3584
  2913   "RTN","ORC SAVE",229, 0)
  2914    . S JDSNO W=$$NOW^XL FDT
  2915   "RTN","ORC SAVE",230, 0)
  2916    . ;^(#.03 )SIGNED BY ^(#.04)SIG NED DATE/T IME^(#.14) ORDER ACTI ON^(#.15)A CTION DATE /TIME
  2917   "RTN","ORC SAVE",231, 0)
  2918    . S VALS( .03)=$G(WH O),VALS(.1 4)=$G(CODE ),VALS(.15 )=JDSNOW   ; SIGNED B Y updated  to reflect  action us er
  2919   "RTN","ORC SAVE",232, 0)
  2920    . S:$G(SI G)'=2 VALS (.04)=JDSN OW  ; SIG= 2 means NO T SIGNED,  don't upda te SIGNED  DATE/TIME
  2921   "RTN","ORC SAVE",233, 0)
  2922    . D:HMORI S UPDTORDR ^HMPOR(.RS LT,.VALS,+ ORIFN,HMDF N)  ; orde r exists u pdate it
  2923   "RTN","ORC SAVE",234, 0)
  2924    . D:'HMOR IS ADDORDR ^HMPOR(.RS LT,.VALS,+ ORIFN,HMDF N)  ; crea te new ord er in HMP( 800000)
  2925   "RTN","ORC SAVE",235, 0)
  2926    . D COMP^ ORMBLDOR(+ $G(ORIFN))   ; send m essage for  completed  orders
  2927   "RTN","ORC SAVE",236, 0)
  2928    ; end DE3 504
  2929   "RTN","ORC SAVE",237, 0)
  2930    Q NEXT
  2931   "RTN","ORC SAVE",238, 0)
  2932    ;
  2933   "RTN","ORC SAVE",239, 0)
  2934   SET(DLG) ;  -- Create  new paren t for orde r set ORDI ALOG
  2935   "RTN","ORC SAVE",240, 0)
  2936    ; Returns  ORPIFN =  ifn of new  parent or der for se t
  2937   "RTN","ORC SAVE",241, 0)
  2938    ;
  2939   "RTN","ORC SAVE",242, 0)
  2940    Q:'$G(ORV P)  Q:'$G( DLG)  N OR 0,PKG,NOW, CATG,STS,O RLOC,TRSPE C,X
  2941   "RTN","ORC SAVE",243, 0)
  2942    S OR0=$G( ^ORD(101.4 1,DLG,0))  Q:OR0=""   S ORPIFN=$ $NEXTIFN Q :'ORPIFN
  2943   "RTN","ORC SAVE",244, 0)
  2944    S PKG=$O( ^DIC(9.4," C","OR",0) ),CATG=$S( $$INPT^ORC D:"I",1:"O "),STS=$S( $G(OREVENT ):10,1:11) ,NOW=$S($G (ORSLOG):O RSLOG,1:+$ E($$NOW^XL FDT,1,12))
  2945   "RTN","ORC SAVE",245, 0)
  2946    I $G(OREV ENT) S ORL OC="",TRSP EC=""
  2947   "RTN","ORC SAVE",246, 0)
  2948    S ^OR(100 ,ORPIFN,0) =ORPIFN_U_ ORVP_U_U_$ G(ORNP)_U_ DLG_";ORD( 101.41,^"_ DUZ_U_NOW_ U_U_U_ORLO C_U_U_CATG _U_TRSPEC_ U_PKG_"^^^ "_$G(OREVE NT),^(3)=N OW_"^90^"_ STS_U_$S($ G(ORIT):OR IT_"ORD(10 1.41,",1:" ")_"^^^1^^ ^^0^^"_+$P (OR0,U,6)
  2949   "RTN","ORC SAVE",247, 0)
  2950    S ^OR(100 ,ORPIFN,8, 0)="^100.0 08DA^1^1", ^(1,0)=NOW _"^NW^"_$G (ORNP)_"^^ ^^^^^^^^"_ DUZ_"^^"_S TS,^OR(100 ,ORPIFN,8, "C","NW",1 )="",^OR(1 00,"AF",NO W,ORPIFN,1 )=""
  2951   "RTN","ORC SAVE",248, 0)
  2952    S ^OR(100 ,"ACT",ORV P,9999999- NOW,ORPIFN ,1)=""
  2953   "RTN","ORC SAVE",249, 0)
  2954    S:STS=11  ^OR(100,"A C",ORVP,99 99999-NOW, ORPIFN,1)= ""
  2955   "RTN","ORC SAVE",250, 0)
  2956    ; AEVNT ? ?
  2957   "RTN","ORC SAVE",251, 0)
  2958    S ^OR(100 ,ORPIFN,1, 0)="^100.0 11^1^1",^( 1,0)=$P(OR 0,U,2) ; O rder text
  2959   "RTN","ORC SAVE",252, 0)
  2960    Q
  2961   "RTN","ORM PS1")
  2962   0^9^B72421 990
  2963   "RTN","ORM PS1",1,0)
  2964   ORMPS1 ;SL C/MKB - Pr ocess Phar macy ORM m sgs cont ; Mar 06, 20 18@10:30
  2965   "RTN","ORM PS1",2,0)
  2966    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**8 6,92,94,11 6,134,152, 158,149,19 0,195,215, 265,275,24 3,280,350, 382,397**; Dec 17, 19 97;Build 1 7
  2967   "RTN","ORM PS1",3,0)
  2968    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  2969   "RTN","ORM PS1",4,0)
  2970    ;
  2971   "RTN","ORM PS1",5,0)
  2972    ;
  2973   "RTN","ORM PS1",6,0)
  2974   UDOSE ; --  new Unit  Dose order
  2975   "RTN","ORM PS1",7,0)
  2976    N ADMIN,Q T,DRUG,INS TR,DOSE,RT E,SCH,OI,U RG,WP,DUR, STR,DRGNM, X,PSOI,PSD D,S0,ID,LD OSE,XC,NTE ,S0,RXR
  2977   "RTN","ORM PS1",8,0)
  2978    S ORDIALO G=+$O(^ORD (101.41,"A B","PSJ OR  PAT OE",0 ))
  2979   "RTN","ORM PS1",9,0)
  2980    I $G(ORAP PT)>0 S OR DG=+$O(^OR D(100.98," B","CLINIC  MEDICATIO NS",0))
  2981   "RTN","ORM PS1",10,0)
  2982    E  S ORDG =+$O(^ORD( 100.98,"B" ,"UNIT DOS E MEDICATI ONS",0))
  2983   "RTN","ORM PS1",11,0)
  2984    S ORPKG=+ $$PKG("PSJ ")
  2985   "RTN","ORM PS1",12,0)
  2986    D GETDLG1 ^ORCD(ORDI ALOG) S QT =$G(ORQT(1 ))
  2987   "RTN","ORM PS1",13,0)
  2988    S DRUG=$$ PTR("DISPE NSE DRUG") ,INSTR=$$P TR("INSTRU CTIONS")
  2989   "RTN","ORM PS1",14,0)
  2990    S DOSE=$$ PTR("DOSE" ),RTE=$$PT R("ROUTE")
  2991   "RTN","ORM PS1",15,0)
  2992    S SCH=$$P TR("SCHEDU LE"),ADMIN =$$PTR("AD MIN TIMES" )
  2993   "RTN","ORM PS1",16,0)
  2994    S OI=$$PT R("ORDERAB LE ITEM"), URG=$$PTR( "URGENCY")
  2995   "RTN","ORM PS1",17,0)
  2996    S WP=$$PT R("WORD PR OCESSING 1 "),DUR=$$P TR("DURATI ON")
  2997   "RTN","ORM PS1",18,0)
  2998    S STR=$$P TR("STRENG TH"),DRGNM =$$PTR("DR UG NAME")
  2999   "RTN","ORM PS1",19,0)
  3000   UD1 S:RXO  X=$P(RXO," |",2),ORDI ALOG(OI,1) =$$ORDITEM ^ORM(X),PS OI=$P(X,U, 4,5)
  3001   "RTN","ORM PS1",20,0)
  3002    I '$G(ORD IALOG(OI,1 )) S ORERR ="Missing  or invalid  orderable  item" Q
  3003   "RTN","ORM PS1",21,0)
  3004    S PSDD=$P ($$FIND^OR M(+RXE,3), U,4,5),ORD IALOG(DRUG ,1)=+PSDD
  3005   "RTN","ORM PS1",22,0)
  3006    S S0=$$FI ND^ORM(+RX E,26)_"&"_ $P($$FIND^ ORM(+RXE,2 7),U,5)
  3007   "RTN","ORM PS1",23,0)
  3008    S ID=$P(Q T,U),LDOSE =$P(QT,U,8 ) I 'ID,S0  D
  3009   "RTN","ORM PS1",24,0)
  3010    . N UNT,P TRN S UNT= $P(S0,"&", 2),PTRN="1 .N1"""_UNT _""""
  3011   "RTN","ORM PS1",25,0)
  3012    . I LDOSE ?@PTRN S $ P(ID,"&",1 ,2)=+LDOSE _"&"_UNT_" &&" Q  ;pr e-POE orde rs
  3013   "RTN","ORM PS1",26,0)
  3014    . S:$P(PS OI,U,2)'[S 0 ORDIALOG (STR,1)=$T R(S0,"&")
  3015   "RTN","ORM PS1",27,0)
  3016    I 'ID,'S0  S ORDIALO G(DRGNM,1) =$$UNESC^O RMPS2($P(P SDD,U,2))
  3017   "RTN","ORM PS1",28,0)
  3018    S:$L(ID)  ORDIALOG(D OSE,1)=$$U NESC^ORMPS 2($P(ID,"& ",1,4)_"&" _LDOSE_"&" _+PSDD_"&" _S0)
  3019   "RTN","ORM PS1",29,0)
  3020    I LDOSE=" " D  I LDO SE="" S OR ERR="Unabl e to deter mine instr uctions" Q
  3021   "RTN","ORM PS1",30,0)
  3022    . I $G(RX C)'>0 D  Q   ;look fo r units/do se
  3023   "RTN","ORM PS1",31,0)
  3024    .. S LDOS E=$P(ID,"& ",3),X=$P( ID,"&",4)  I 'LDOSE S  LDOSE=""  Q
  3025   "RTN","ORM PS1",32,0)
  3026    .. S:'$L( X) X=$$UNE SC^ORMPS2( $P($$FIND^ ORM(+RXE,7 ),U,5)) S: $L(X) LDOS E=LDOSE_"  "_X
  3027   "RTN","ORM PS1",33,0)
  3028    .. S ORDI ALOG(DRGNM ,1)=$$UNES C^ORMPS2($ P(PSDD,U,2 )) ;force  use of DD
  3029   "RTN","ORM PS1",34,0)
  3030    . F  D  Q :LDOSE'=""   S RXC=$O (@ORMSG@(R XC)) Q:'RX C  Q:$E(@O RMSG@(RXC) ,1,3)'="RX C"
  3031   "RTN","ORM PS1",35,0)
  3032    .. S XC=@ ORMSG@(RXC ) Q:+$P($P (XC,"|",3) ,U,4)'=+PS OI
  3033   "RTN","ORM PS1",36,0)
  3034    .. S LDOS E=$P(XC,"| ",4)_$P($P (XC,"|",5) ,U,5) ;str ength_unit s
  3035   "RTN","ORM PS1",37,0)
  3036    S ORDIALO G(INSTR,1) =$$UNESC^O RMPS2(LDOS E)
  3037   "RTN","ORM PS1",38,0)
  3038   UD2 S NTE= $$NTE^ORMP S3(21) I N TE D
  3039   "RTN","ORM PS1",39,0)
  3040    . N CNT,I  S CNT=1,^ TMP("ORWOR D",$J,WP,1 ,CNT,0)=$$ UNESC^ORMP S2($P(@ORM SG@(NTE)," |",4))
  3041   "RTN","ORM PS1",40,0)
  3042    . I $O(@O RMSG@(NTE, 0)) S I=0  F  S I=$O( @ORMSG@(NT E,I)) Q:I' >0  S CNT= CNT+1,^TMP ("ORWORD", $J,WP,1,CN T,0)=$$UNE SC^ORMPS2( @ORMSG@(NT E,I))
  3043   "RTN","ORM PS1",41,0)
  3044    . S ^TMP( "ORWORD",$ J,WP,1,0)= "^^"_CNT_U _CNT_U_DT_ U
  3045   "RTN","ORM PS1",42,0)
  3046    . S ORDIA LOG(WP,1)= "^TMP(""OR WORD"",$J, "_WP_",1)"
  3047   "RTN","ORM PS1",43,0)
  3048    S RXR=$$R XR^ORMPS I  'RXR S OR ERR="Missi ng or inva lid RXR se gment" Q
  3049   "RTN","ORM PS1",44,0)
  3050    S ORDIALO G(RTE,1)=$ P($P(RXR," |",2),U,4) ,ORDIALOG( URG,1)=ORU RG
  3051   "RTN","ORM PS1",45,0)
  3052    S X=$P(QT ,U,2)
  3053   "RTN","ORM PS1",46,0)
  3054    S ORDIALO G(SCH,1)=$ $UNESC^ORM PS2($P(X," &"))
  3055   "RTN","ORM PS1",47,0)
  3056    S:$L($P(X ,"&",2)) O RDIALOG(AD MIN,1)=$P( X,"&",2)
  3057   "RTN","ORM PS1",48,0)
  3058    S X=$P(QT ,U,3) I $L (X) D  ;se t only if  previous o rder had d uration
  3059   "RTN","ORM PS1",49,0)
  3060    . N IFN S  IFN=$S($G (ORIFN):+O RIFN,$P(ZR X,"|",2):+ $P(ZRX,"|" ,2),1:0)
  3061   "RTN","ORM PS1",50,0)
  3062    . S:$O(^O R(100,+IFN ,4.5,"ID", "DAYS",0))  ORDIALOG( DUR,1)=$$D URATION^OR MPS3(X)
  3063   "RTN","ORM PS1",51,0)
  3064    D DOSETEX T^ORCDPS2  ;reset Ins tructions  text, SIG
  3065   "RTN","ORM PS1",52,0)
  3066    D UNESCAR R^ORMPS2(" ORDIALOG")
  3067   "RTN","ORM PS1",53,0)
  3068    Q
  3069   "RTN","ORM PS1",54,0)
  3070   OUT ; -- n ew Outpt o rder
  3071   "RTN","ORM PS1",55,0)
  3072    N OI,SIG, INSTR,DOSE ,RTE,SCH,D UR,SC,STR, DRUG,PI,CO NJ,PSOI,PS DD,S0,X,I, RXR,J,NTE, ZSC,CNT,PC
  3073   "RTN","ORM PS1",56,0)
  3074    S ORDIALO G=+$O(^ORD (101.41,"A B","PSO OE RR",0))
  3075   "RTN","ORM PS1",57,0)
  3076    S ORDG=+$ O(^ORD(100 .98,"B","O UTPATIENT  MEDICATION S",0))
  3077   "RTN","ORM PS1",58,0)
  3078    S ORPKG=+ $$PKG("PSO ") D GETDL G1^ORCD(OR DIALOG)
  3079   "RTN","ORM PS1",59,0)
  3080    S OI=$$PT R("ORDERAB LE ITEM"), SIG=$$PTR( "SIG")
  3081   "RTN","ORM PS1",60,0)
  3082    S INSTR=$ $PTR("INST RUCTIONS") ,DOSE=$$PT R("DOSE")
  3083   "RTN","ORM PS1",61,0)
  3084    S SCH=$$P TR("SCHEDU LE"),DUR=$ $PTR("DURA TION")
  3085   "RTN","ORM PS1",62,0)
  3086    S RTE=$$P TR("ROUTE" ),SC=$$PTR ("SERVICE  CONNECTED" )
  3087   "RTN","ORM PS1",63,0)
  3088    S STR=$$P TR("STRENG TH"),DRUG= $$PTR("DIS PENSE DRUG ")
  3089   "RTN","ORM PS1",64,0)
  3090    S PI=$$PT R("PATIENT  INSTRUCTI ONS"),CONJ =$$PTR("AN D/THEN")
  3091   "RTN","ORM PS1",65,0)
  3092    S PC=$$PT R("WORD PR OCESSING 1 ")
  3093   "RTN","ORM PS1",66,0)
  3094    S:RXO X=$ P(RXO,"|", 2),ORDIALO G(OI,1)=$$ ORDITEM^OR M(X),PSOI= $P(X,U,4,5 )
  3095   "RTN","ORM PS1",67,0)
  3096    I '$G(ORD IALOG(OI,1 )) S ORERR ="Missing  or invalid  orderable  item" Q
  3097   "RTN","ORM PS1",68,0)
  3098    S PSDD=$P ($$FIND^OR M(+RXE,3), U,4,5),ORD IALOG(DRUG ,1)=+PSDD
  3099   "RTN","ORM PS1",69,0)
  3100    I $$ISSUP PLY^ORUTL3 (+PSDD) S  ORDG=+$O(^ ORD(100.98 ,"B","SUPP LIES/DEVIC ES",0))
  3101   "RTN","ORM PS1",70,0)
  3102    S S0=$$FI ND^ORM(+RX E,26)_"&"_ $P($$FIND^ ORM(+RXE,2 7),U,5)
  3103   "RTN","ORM PS1",71,0)
  3104    I S0,$P(P SOI,U,2)'[ S0 S ORDIA LOG(STR,1) =$TR(S0,"& ")
  3105   "RTN","ORM PS1",72,0)
  3106    I 'S0,'$G (ORQT(1))  S ORDIALOG ($$PTR("DR UG NAME"), 1)=$$UNESC ^ORMPS2($P (PSDD,U,2) )
  3107   "RTN","ORM PS1",73,0)
  3108   OUT1 S ORD IALOG($$PT R("QUANTIT Y"),1)=$$F IND^ORM(+R XE,11)
  3109   "RTN","ORM PS1",74,0)
  3110    S ORDIALO G($$PTR("R EFILLS"),1 )=$$FIND^O RM(+RXE,13 )
  3111   "RTN","ORM PS1",75,0)
  3112    S X=$$FIN D^ORM(+RXE ,23) S:$E( X)="D" X=+ $E(X,2,99)
  3113   "RTN","ORM PS1",76,0)
  3114    S:X ORDIA LOG($$PTR( "DAYS SUPP LY"),1)=X
  3115   "RTN","ORM PS1",77,0)
  3116    I ZRX S X =$P(ZRX,"| ",5) S:$L( X) ORDIALO G($$PTR("R OUTING"),1 )=X
  3117   "RTN","ORM PS1",78,0)
  3118    S:ORURG O RDIALOG($$ PTR("URGEN CY"),1)=OR URG F I=1: 1:ORQT D
  3119   "RTN","ORM PS1",79,0)
  3120    . S ORDIA LOG(INSTR, I)=$$UNESC ^ORMPS2($P (ORQT(I),U ,8)),X=$P( ORQT(I),U)
  3121   "RTN","ORM PS1",80,0)
  3122    . S:$L(X)  ORDIALOG( DOSE,I)=$$ UNESC^ORMP S2($P(X,"& ",1,4)_"&" _$P(ORQT(I ),U,8)_"&" _+PSDD_"&" _S0)
  3123   "RTN","ORM PS1",81,0)
  3124    . S X=$P( ORQT(I),U, 2) S:$L(X)  ORDIALOG( SCH,I)=$$U NESC^ORMPS 2(X)
  3125   "RTN","ORM PS1",82,0)
  3126    . S X=$P( ORQT(I),U, 3) S:$L(X)  ORDIALOG( DUR,I)=$$D URATION^OR MPS3(X)
  3127   "RTN","ORM PS1",83,0)
  3128    . S X=$P( ORQT(I),U, 9) S:$L(X)  ORDIALOG( CONJ,I)=$S (X="S":"T" ,1:X)
  3129   "RTN","ORM PS1",84,0)
  3130    S RXR=$$R XR^ORMPS I  RXR S ORD IALOG(RTE, 1)=$P($P(R XR,"|",2), U,4) D
  3131   "RTN","ORM PS1",85,0)
  3132    . S I=1,J =+RXR ;loo k for mult iple RXR's
  3133   "RTN","ORM PS1",86,0)
  3134    . F  S J= $O(@ORMSG@ (J)) Q:J'> 0  S RXR=@ ORMSG@(J)  Q:$E(RXR,1 ,3)'="RXR"   S I=I+1, ORDIALOG(R TE,I)=$P($ P(RXR,"|", 2),U,4)
  3135   "RTN","ORM PS1",87,0)
  3136   OUT2 S NTE =$$NTE^ORM PS3(6) I N TE D  ;Pro v Comm ;D: 'NTE PCOMM ^ORMPS2
  3137   "RTN","ORM PS1",88,0)
  3138    . S CNT=1 ,^TMP("ORW ORD",$J,PC ,1,CNT,0)= $$UNESC^OR MPS2($P(@O RMSG@(NTE) ,"|",4))
  3139   "RTN","ORM PS1",89,0)
  3140    . I $O(@O RMSG@(NTE, 0)) S I=0  F  S I=$O( @ORMSG@(NT E,I)) Q:I' >0  S CNT= CNT+1,^TMP ("ORWORD", $J,PC,1,CN T,0)=$$UNE SC^ORMPS2( @ORMSG@(NT E,I))
  3141   "RTN","ORM PS1",90,0)
  3142    . S ^TMP( "ORWORD",$ J,PC,1,0)= "^^"_CNT_U _CNT_U_DT_ U
  3143   "RTN","ORM PS1",91,0)
  3144    . S ORDIA LOG(PC,1)= "^TMP(""OR WORD"",$J, "_PC_",1)" ,ORDIALOG( PC,"FORMAT ")="@" ;ke ep, don't  show
  3145   "RTN","ORM PS1",92,0)
  3146    . N XCNT, XCOMM,XCOM MENT,XORCO MM,XXCNT,X ORIFN
  3147   "RTN","ORM PS1",93,0)
  3148    . S XORIF N=$G(ORIFN ) S:XORIFN ="" XORIFN =$P(RXR,"| ",2) Q:XOR IFN=""
  3149   "RTN","ORM PS1",94,0)
  3150    . S XCOMM =$O(^OR(10 0,+XORIFN, 4.5,"ID"," COMMENT",0 )) Q:XCOMM =""
  3151   "RTN","ORM PS1",95,0)
  3152    . S XCNT= 0 F  S XCN T=$O(^TMP( "ORWORD",$ J,PC,1,XCN T)) Q:XCNT =""  S XCO MMENT=^TMP ("ORWORD", $J,PC,1,XC NT,0) D
  3153   "RTN","ORM PS1",96,0)
  3154    .. S XORC OMM=$G(^OR (100,+XORI FN,4.5,XCO MM,2,XCNT, 0)),XXCNT= 0
  3155   "RTN","ORM PS1",97,0)
  3156    .. I XORC OMM="" F   S XXCNT=$O (^OR(100,+ XORIFN,4.5 ,XCOMM,2,X XCNT)) Q:X XCNT=""  S  XORCOMM=$ G(^(XXCNT, 0)) Q:XORC OMM'=""
  3157   "RTN","ORM PS1",98,0)
  3158    .. I $G(X COMMENT)=$ G(XORCOMM)  S ORDIALO G(PC,"FORM AT")="@"
  3159   "RTN","ORM PS1",99,0)
  3160    S NTE=$$N TE^ORMPS3( 7) I NTE D   ;Pat Ins tr
  3161   "RTN","ORM PS1",100,0 )
  3162    . S CNT=1 ,^TMP("ORW ORD",$J,PI ,1,CNT,0)= $$UNESC^OR MPS2($P(@O RMSG@(NTE) ,"|",4))
  3163   "RTN","ORM PS1",101,0 )
  3164    . I $O(@O RMSG@(NTE, 0)) S I=0  F  S I=$O( @ORMSG@(NT E,I)) Q:I' >0  S CNT= CNT+1,^TMP ("ORWORD", $J,PI,1,CN T,0)=$$UNE SC^ORMPS2( @ORMSG@(NT E,I))
  3165   "RTN","ORM PS1",102,0 )
  3166    . S ^TMP( "ORWORD",$ J,PI,1,0)= "^^"_CNT_U _CNT_U_DT_ U
  3167   "RTN","ORM PS1",103,0 )
  3168    . S ORDIA LOG(PI,1)= "^TMP(""OR WORD"",$J, "_PI_",1)"
  3169   "RTN","ORM PS1",104,0 )
  3170    S NTE=$$N TE^ORMPS3( 21) I NTE  D  ;Sig
  3171   "RTN","ORM PS1",105,0 )
  3172    . S CNT=1 ,^TMP("ORW ORD",$J,SI G,1,CNT,0) =$$UNESC^O RMPS2($P(@ ORMSG@(NTE ),"|",4))
  3173   "RTN","ORM PS1",106,0 )
  3174    . I $O(@O RMSG@(NTE, 0)) S I=0  F  S I=$O( @ORMSG@(NT E,I)) Q:I' >0  S CNT= CNT+1,^TMP ("ORWORD", $J,SIG,1,C NT,0)=$$UN ESC^ORMPS2 (@ORMSG@(N TE,I))
  3175   "RTN","ORM PS1",107,0 )
  3176    . S ^TMP( "ORWORD",$ J,SIG,1,0) ="^^"_CNT_ U_CNT_U_DT _U
  3177   "RTN","ORM PS1",108,0 )
  3178    . S ORDIA LOG(SIG,1) ="^TMP(""O RWORD"",$J ,"_SIG_",1 )"
  3179   "RTN","ORM PS1",109,0 )
  3180    . S ORDIA LOG(PI,"FO RMAT")="@"  ;PI alrea dy include d in Sig
  3181   "RTN","ORM PS1",110,0 )
  3182   OUT3 I '$G (ORQT(1))! ('NTE) D D OSETEXT^OR CDPS2 ;res et Instruc tions text , Sig
  3183   "RTN","ORM PS1",111,0 )
  3184    S ZSC=$$Z SC^ORMPS3, X=$P(ZSC," |",2) I X? 2.3U S ORD IALOG(SC,1 )=$S(X="SC ":1,1:0)
  3185   "RTN","ORM PS1",112,0 )
  3186    Q
  3187   "RTN","ORM PS1",113,0 )
  3188   IV ; -- ne w IV order
  3189   "RTN","ORM PS1",114,0 )
  3190    N IVTYP,I VTYPE S IV TYP=$P(ZRX ,"|",7) I  IVTYP="",$ $NUMADDS^O RMPS3'>1 G  UDOSE
  3191   "RTN","ORM PS1",115,0 )
  3192    N SOLN,VO L,ADDS,STR ,UNITS,RAT E,URG,X,X1 ,X2,X3,I,J ,TYPE,OI,W P,NTE,SCH
  3193   "RTN","ORM PS1",116,0 )
  3194    N DAYS,RO UTE,ADMIN, RXR,ADDFRE Q
  3195   "RTN","ORM PS1",117,0 )
  3196    S ORDIALO G=+$O(^ORD (101.41,"A B","PSJI O R PAT FLUI D OE",0))
  3197   "RTN","ORM PS1",118,0 )
  3198    I +$G(ORA PPT)>0 S O RDG=+$O(^O RD(100.98, "B","CLINI C INFUSION S",0))
  3199   "RTN","ORM PS1",119,0 )
  3200    E  S ORDG =+$O(^ORD( 100.98,"B" ,$S($P(ZRX ,"|",7)="T PN":"TPN", 1:"IV RX") ,0))
  3201   "RTN","ORM PS1",120,0 )
  3202    S ORPKG=+ $$PKG("PSJ ") D GETDL G1^ORCD(OR DIALOG)
  3203   "RTN","ORM PS1",121,0 )
  3204    S SOLN=$$ PTR("ORDER ABLE ITEM" ),VOL=$$PT R("VOLUME" ),SCH=$$PT R("SCHEDUL E")
  3205   "RTN","ORM PS1",122,0 )
  3206    S RATE=$$ PTR("INFUS ION RATE")  S:ORURG O RDIALOG($$ PTR("URGEN CY"),1)=OR URG
  3207   "RTN","ORM PS1",123,0 )
  3208    S WP=$$PT R("WORD PR OCESSING 1 "),ADDS=$$ PTR("ADDIT IVE")
  3209   "RTN","ORM PS1",124,0 )
  3210    S ADDFREQ =$$PTR("AD DITIVE FRE QUENCY")
  3211   "RTN","ORM PS1",125,0 )
  3212    S STR=$$P TR("STRENG TH PSIV"), UNITS=$$PT R("UNITS")
  3213   "RTN","ORM PS1",126,0 )
  3214    S DAYS=$$ PTR("DURAT ION"),IVTY PE=$$PTR(" IV TYPE"), ADMIN=$$PT R("ADMIN T IMES")
  3215   "RTN","ORM PS1",127,0 )
  3216   IV1 S NTE= $$NTE^ORMP S3(21) I N TE D
  3217   "RTN","ORM PS1",128,0 )
  3218    . N CNT,I  S CNT=1,^ TMP("ORWOR D",$J,WP,1 ,CNT,0)=$$ UNESC^ORMP S2($P(@ORM SG@(NTE)," |",4))
  3219   "RTN","ORM PS1",129,0 )
  3220    . I $O(@O RMSG@(NTE, 0)) S I=0  F  S I=$O( @ORMSG@(NT E,I)) Q:I' >0  S CNT= CNT+1,^TMP ("ORWORD", $J,WP,1,CN T,0)=$$UNE SC^ORMPS2( @ORMSG@(NT E,I))
  3221   "RTN","ORM PS1",130,0 )
  3222    . S ^TMP( "ORWORD",$ J,WP,1,0)= "^^"_CNT_U _CNT_U_DT_ U
  3223   "RTN","ORM PS1",131,0 )
  3224    . S ORDIA LOG(WP,1)= "^TMP(""OR WORD"",$J, "_WP_",1)"
  3225   "RTN","ORM PS1",132,0 )
  3226    N ORDAYS  S ORDAYS=" "
  3227   "RTN","ORM PS1",133,0 )
  3228    S:$D(RXO)  ORDAYS=$P ($P(RXO,"| ",2),"^",3 )
  3229   "RTN","ORM PS1",134,0 )
  3230    S:$L(ORDA YS) ORDAYS =$$IVLIM^O RMPS2(ORDA YS)
  3231   "RTN","ORM PS1",135,0 )
  3232    S:$L(ORDA YS) ORDIAL OG(DAYS,1) =ORDAYS
  3233   "RTN","ORM PS1",136,0 )
  3234    S ORDIALO G(IVTYPE,1 )=IVTYP
  3235   "RTN","ORM PS1",137,0 )
  3236    S X=$P($$ FIND^ORM(+ RXE,25),U, 5)
  3237   "RTN","ORM PS1",138,0 )
  3238    S ORDIALO G(RATE,1)= $$FIND^ORM (+RXE,24)_ $S($L(X):"  "_X,1:"") ,(I,J)=0
  3239   "RTN","ORM PS1",139,0 )
  3240    F  D  S R XC=$O(@ORM SG@(RXC))  Q:'RXC  Q: $E(@ORMSG@ (RXC),1,3) '="RXC"
  3241   "RTN","ORM PS1",140,0 )
  3242    . S X=@OR MSG@(RXC), TYPE=$P(X, "|",2),OI= $$ORDITEM^ ORM($P(X," |",3)) Q:' OI
  3243   "RTN","ORM PS1",141,0 )
  3244    . S X1=$P (X,"|",4), X2=$P($P(X ,"|",5),U, 5),X3=$P(X ,"|",6)
  3245   "RTN","ORM PS1",142,0 )
  3246    . I $E(TY PE)="B" S  J=J+1,ORDI ALOG(SOLN, J)=OI,ORDI ALOG(VOL,J )=X1 Q
  3247   "RTN","ORM PS1",143,0 )
  3248    . S I=I+1 ,ORDIALOG( ADDS,I)=OI ,ORDIALOG( STR,I)=X1, ORDIALOG(U NITS,I)=X2 ,ORDIALOG( ADDFREQ,I) =$$ADDFRQC V^ORMBLDP1 (X3,"I")
  3249   "RTN","ORM PS1",144,0 )
  3250   IV2 ;
  3251   "RTN","ORM PS1",145,0 )
  3252    S RXR=$$R XR^ORMPS
  3253   "RTN","ORM PS1",146,0 )
  3254    S ROUTE=$ P(RXR,"|", 2)
  3255   "RTN","ORM PS1",147,0 )
  3256    S ORDIALO G($$PTR("R OUTE"),1)= $P(ROUTE,U ,4)
  3257   "RTN","ORM PS1",148,0 )
  3258    I IVTYP=" I" S X=$P( $G(ORQT(1) ),U,2) D
  3259   "RTN","ORM PS1",149,0 )
  3260    .S:$L($P( X,"&")) OR DIALOG(SCH ,1)=$P(X," &")
  3261   "RTN","ORM PS1",150,0 )
  3262    .S:$L($P( X,"&",2))  ORDIALOG(A DMIN,1)=$P (X,"&",2)
  3263   "RTN","ORM PS1",151,0 )
  3264    D UNESCAR R^ORMPS2(" ORDIALOG")
  3265   "RTN","ORM PS1",152,0 )
  3266    Q
  3267   "RTN","ORM PS1",153,0 )
  3268   PKG(NMSP)  ; -- Retur n Package  file ptr f or NMSP
  3269   "RTN","ORM PS1",154,0 )
  3270    N I S I=0
  3271   "RTN","ORM PS1",155,0 )
  3272    F  S I=+$ O(^DIC(9.4 ,"C",NMSP, I)) Q:I<1   Q:'$O(^(I ,0))  ;no  Addl Prefs
  3273   "RTN","ORM PS1",156,0 )
  3274    Q I
  3275   "RTN","ORM PS1",157,0 )
  3276   PTR(NAME)  ; -- Retur ns ien of  prompt NAM E in Order  Dialog fi le #101.41
  3277   "RTN","ORM PS1",158,0 )
  3278    Q +$O(^OR D(101.41," AB",$E("OR  GTX "_NAM E,1,63),0) )
  3279   "RTN","ORM PS1",159,0 )
  3280   QT ; -- Un piece the  Q/T field  from RXE
  3281   "RTN","ORM PS1",160,0 )
  3282    I 'RXE S  ORQT(1)=OR QT,ORQT=1  Q  ; nothi ng to rese t
  3283   "RTN","ORM PS1",161,0 )
  3284    N X,Y,I,J ,P,SEG,DON E K ORQT
  3285   "RTN","ORM PS1",162,0 )
  3286    S SEG=$G( @ORMSG@(+R XE)),X=$P( SEG,"|",2) ,(I,J,P,DO NE)=0
  3287   "RTN","ORM PS1",163,0 )
  3288    F  D  Q:D ONE
  3289   "RTN","ORM PS1",164,0 )
  3290    . S P=P+1 ,Y=$P(X,"~ ",P) I Y=" " S DONE=1  Q
  3291   "RTN","ORM PS1",165,0 )
  3292    . I P<$L( X,"~") S I =I+1,ORQT( I)=Y Q
  3293   "RTN","ORM PS1",166,0 )
  3294    . I $L(SE G,"|")>2 S  I=I+1,ORQ T(I)=Y,DON E=1 Q
  3295   "RTN","ORM PS1",167,0 )
  3296    . S J=+$O (@ORMSG@(+ RXE,J)) I  J'>0 S I=I +1,ORQT(I) =Y,DONE=1  Q
  3297   "RTN","ORM PS1",168,0 )
  3298    . S SEG=$ G(@ORMSG@( +RXE,J)),X =$P(SEG,"| "),P=1,I=I +1,ORQT(I) =Y_$P(X,"~ ")
  3299   "RTN","ORM PS1",169,0 )
  3300    S ORQT=I  Q:'ORQT  ;  else rese t ORSTRT,  ORSTOP, OR URG
  3301   "RTN","ORM PS1",170,0 )
  3302    S ORSTRT= $P(ORQT(1) ,U,4),ORST OP=$P(ORQT (ORQT),U,5 ),ORURG=$P (ORQT(1),U ,6)
  3303   "RTN","ORM PS1",171,0 )
  3304    S:ORSTRT  ORSTRT=$$F MDATE^ORM( ORSTRT) S: ORSTOP ORS TOP=$$FMDA TE^ORM(ORS TOP) S:$L( ORURG) ORU RG=$$URGEN CY^ORM(ORU RG)
  3305   "RTN","ORM PS1",172,0 )
  3306    Q
  3307   "RTN","ORS 100C")
  3308   0^3^B22805 043
  3309   "RTN","ORS 100C",1,0)
  3310   ORS100C ;  slc/dcm -  OE/RR Cont rolled Sub stance RX  w/Missing  Digital Si g Report ; Aug 06, 20 18@06:19
  3311   "RTN","ORS 100C",2,0)
  3312    ;;3.0;ORD ER ENTRY R ESULTS REP ORTING;**3 97**;Dec 1 7, 1997;Bu ild 17
  3313   "RTN","ORS 100C",3,0)
  3314    ;CAC Repo rt showing  Orders fo r Controll ed Substan ces where  the Digita l Signatur e is missi ng since t he install ation of C PRS V29 (O R*3.0*306v 29t21)
  3315   "RTN","ORS 100C",4,0)
  3316   EN ;
  3317   "RTN","ORS 100C",5,0)
  3318    N DIR,SDA TE,SD1,SDT ,DTOUT,DUO UT,EDATE,S D2,OREDT,P OP,ZTIO,ZT RTN,ZTSAVE ,ZTSK,ZTDE SC,VA,VADM ,VAERR
  3319   "RTN","ORS 100C",6,0)
  3320    N X,X0,Y, IFN,V29DT, IDT,ORIFN, ORACT,TYPE ,PSIFN,NOD E,RXN,STAT ,PROV,ORVP ,OR0,OR3,C NT,HDR,HDR 1,PAGE,RX0 ,RX2,RX3,S TOP
  3321   "RTN","ORS 100C",7,0)
  3322    K ^TMP("P S",$J),^TM P("ORUNS", $J),^TMP(" ORSTATS",$ J)
  3323   "RTN","ORS 100C",8,0)
  3324   SDATE ;set s DIR call  to ask th e user for  a startin g date - L ook up Ins tall date  for CPRS V 29
  3325   "RTN","ORS 100C",9,0)
  3326    S IFN=0,V 29DT=""
  3327   "RTN","ORS 100C",10,0 )
  3328    F  S IFN= $O(^XPD(9. 7,"B","OR* 3.0*306",I FN)) Q:IFN =""  I $P( $G(^XPD(9. 7,IFN,1)), "^",3) S:V 29DT="" V2 9DT=$P(^(1 ),"^",3) D
  3329   "RTN","ORS 100C",11,0 )
  3330    . I $P(^X PD(9.7,IFN ,1),"^",3) <V29DT S V 29DT=$P(^( 1),"^",3)
  3331   "RTN","ORS 100C",12,0 )
  3332    W !!,"Sea rch for Co ntrolled S ubscriptio n orders w ith missin g Digital  Signatures ",!
  3333   "RTN","ORS 100C",13,0 )
  3334    W !,"CPRS  V29 (patc h OR*3.0*3 06) was in stalled on  "_$$FMTE^ XLFDT($$FM TE^XLFDT(V 29DT))
  3335   "RTN","ORS 100C",14,0 )
  3336    S DIR(0)= "DA^::ETX"
  3337   "RTN","ORS 100C",15,0 )
  3338    S DIR("A" )="Enter a  starting  date: "
  3339   "RTN","ORS 100C",16,0 )
  3340    S DIR("B" )=$P($$FMT E^XLFDT($$ FMTE^XLFDT (V29DT))," @")
  3341   "RTN","ORS 100C",17,0 )
  3342    S DIR("?" )="Enter t he date or  date/time  that you  want the s earch to s tart with.  This fiel d can be u sed to ign ore pre-CP RS v29 ord ers by ent ering the  date of yo ur CPRS v2 9 installa tion."
  3343   "RTN","ORS 100C",18,0 )
  3344    D ^DIR S: +Y>0 (SDAT E,SD1)=(99 99999-Y),S DT=$$FMTE^ XLFDT(Y) K  DIR I $D( DTOUT)!$D( DUOUT) G E XIT
  3345   "RTN","ORS 100C",19,0 )
  3346   EDATE ;set s DIR call  to ask th e user for  an ending  date (opt ional)
  3347   "RTN","ORS 100C",20,0 )
  3348    S DIR(0)= "DA^::ETX"
  3349   "RTN","ORS 100C",21,0 )
  3350    S DIR("A" )="Enter a n ending d ate: "
  3351   "RTN","ORS 100C",22,0 )
  3352    S DIR("B" )="T"
  3353   "RTN","ORS 100C",23,0 )
  3354    S DIR("?" )="Enter t he date or  date/time  that you  want the s earch to e nd with."
  3355   "RTN","ORS 100C",24,0 )
  3356    D ^DIR S  (EDATE,SD2 )=(9999999 -Y),OREDT= $$FMTE^XLF DT(Y) K DI R I $D(DTO UT)!$D(DUO UT) G EXIT
  3357   "RTN","ORS 100C",25,0 )
  3358   SWITCH ;ta kes the da te input f rom the us er and doe s a switch eroo so th ings work
  3359   "RTN","ORS 100C",26,0 )
  3360    I EDATE'> SDATE S ED ATE=SD1,SD ATE=SD2
  3361   "RTN","ORS 100C",27,0 )
  3362    ;
  3363   "RTN","ORS 100C",28,0 )
  3364   TASK ;
  3365   "RTN","ORS 100C",29,0 )
  3366    S %ZIS="Q " D ^%ZIS  I POP Q
  3367   "RTN","ORS 100C",30,0 )
  3368    I $D(IO(" Q")) D  K  IO("Q") Q
  3369   "RTN","ORS 100C",31,0 )
  3370    . S ZTIO= ION,ZTDESC ="File 100  Controlle d Substanc e with no  Digital Si g search"
  3371   "RTN","ORS 100C",32,0 )
  3372    . S ZTRTN ="LOOP^ORS 100C",ZTSA VE("SORT") ="",ZTSAVE ("TYPE")=" "
  3373   "RTN","ORS 100C",33,0 )
  3374    . S ZTSAV E("SDATE") ="",ZTSAVE ("EDATE")= "",ZTSAVE( "SINGLE")= ""
  3375   "RTN","ORS 100C",34,0 )
  3376    . S ZTSAV E("LONER*" )="",ZTSAV E("SDT")=" ",ZTSAVE(" OREDT")="" ,ZTSAVE("S UMONLY")=" "
  3377   "RTN","ORS 100C",35,0 )
  3378    . D ^%ZTL OAD I $D(Z TSK) W !,? 32,"REQUES T QUEUED"
  3379   "RTN","ORS 100C",36,0 )
  3380    U IO D LO OP^ORS100C
  3381   "RTN","ORS 100C",37,0 )
  3382    Q
  3383   "RTN","ORS 100C",38,0 )
  3384    ;
  3385   "RTN","ORS 100C",39,0 )
  3386   LOOP ;Prod uce Contro lled Subst ance, no D ig Sig Rep ort
  3387   "RTN","ORS 100C",40,0 )
  3388    N ORX,RPD T,X,IFN,V2 9DT,IDT,OR IFN,ORACT, TYPE,PSIFN ,NODE,RXN, STAT,PROV, ORVP,OR0,O R3,LOC,DIV ,SCH
  3389   "RTN","ORS 100C",41,0 )
  3390    N DFN,SSN ,PNM,RDAT, RX,DRUG,QT Y,LRDAT
  3391   "RTN","ORS 100C",42,0 )
  3392    K ^TMP("P S",$J),^TM P("ORUNS", $J),^TMP(" ORSTATS",$ J)
  3393   "RTN","ORS 100C",43,0 )
  3394    S RPDT="" "Report Da te: "",$$F MTE^XLFDT( $$NOW^XLFD T),""  Fro m: "",SDT, ""  To: "" ,OREDT",ST OP=0
  3395   "RTN","ORS 100C",44,0 )
  3396    S IDT=999 9999-EDATE
  3397   "RTN","ORS 100C",45,0 )
  3398    S (LOC,DI V)="**DELA YED ORDER/ NOT ENTERE D" ;Reset  values as  delayed or ders may n ot have th ese values  yet
  3399   "RTN","ORS 100C",46,0 )
  3400    F  S IDT= $O(^OR(100 ,"AF",IDT) ) Q:IDT=""   S ORIFN= 0 F  S ORI FN=$O(^OR( 100,"AF",I DT,ORIFN))  Q:ORIFN=" "  D
  3401   "RTN","ORS 100C",47,0 )
  3402    . S ORACT =0 F  S OR ACT=$O(^OR (100,"AF", IDT,ORIFN, ORACT)) Q: ORACT=""   D
  3403   "RTN","ORS 100C",48,0 )
  3404    .. S OR0= $G(^OR(100 ,ORIFN,0))  Q:'$L(OR0 )
  3405   "RTN","ORS 100C",49,0 )
  3406    .. I $P(O R0,U,10) S  LOC=$$LOC ^ORS100(+$ P(OR0,U,10 ))
  3407   "RTN","ORS 100C",50,0 )
  3408    .. I $P(O R0,U,10) S  DIV=$$DIV ^ORS100(+$ P(OR0,U,10 ))
  3409   "RTN","ORS 100C",51,0 )
  3410    .. S OR3= $G(^OR(100 ,ORIFN,3))  Q:'$L(OR3 )
  3411   "RTN","ORS 100C",52,0 )
  3412    .. S STAT =$P(OR3,"^ ",3),STAT= $P($G(^ORD (100.01,+S TAT,0)),"^ ",2)
  3413   "RTN","ORS 100C",53,0 )
  3414    .. S ORVP =$P(OR0,"^ ",2),TYPE= $P(OR0,"^" ,12),PSIFN =$G(^OR(10 0,ORIFN,4) ) Q:'$L(PS IFN)
  3415   "RTN","ORS 100C",54,0 )
  3416    .. S DFN= +$P(^OR(10 0,ORIFN,0) ,U,2) D DE M^VADPT S  SSN=VA("BI D"),PNM=$E (VADM(1),1 ,24)
  3417   "RTN","ORS 100C",55,0 )
  3418    .. S:TYPE ="O" PSIFN =$TR(PSIFN ,"S","P")_ $S(PSIFN?1 .N:"R",1:" ")
  3419   "RTN","ORS 100C",56,0 )
  3420    .. D OEL^ PSOORRL(+O RVP,PSIFN_ ";"_TYPE)   ;DBIA 240 0
  3421   "RTN","ORS 100C",57,0 )
  3422    .. S NODE =$G(^TMP(" PS",$J,0)) ,RX=$G(^(" RXN",0)) Q :'$L(RX)
  3423   "RTN","ORS 100C",58,0 )
  3424    .. S DRUG =$P(NODE," ^"),QTY=$P (NODE,"^", 8),RXN=$P( RX,"^"),LR DAT=$P(RX, "^",2)
  3425   "RTN","ORS 100C",59,0 )
  3426    .. S X=$G (^OR(100,O RIFN,8,ORA CT,2)),X0= $G(^(0)),R DAT=$$FMTE ^XLFDT($P( $P(X0,"^", 16),".")), PROV=$P(X0 ,"^",3),PR OV=$P($G(^ VA(200,+PR OV,0)),"^" )
  3427   "RTN","ORS 100C",60,0 )
  3428    .. I $P(X ,"^",4)>1, $P(X,"^",4 )<6,'$L($P (X,"^",3))  S SCH=$P( X,"^",4) D
  3429   "RTN","ORS 100C",61,0 )
  3430    ... S ^TM P("ORUNS", $J,IDT,ORI FN)=RXN_U_ $E(SCH,1,4 )_U_QTY_U_ PNM_U_RDAT _U_DRUG_U_ PROV_U_DIV _U_LOC_U_S TAT_U_LRDA T
  3431   "RTN","ORS 100C",62,0 )
  3432    ;
  3433   "RTN","ORS 100C",63,0 )
  3434   DISP ; Dis play resul ts
  3435   "RTN","ORS 100C",64,0 )
  3436    S HDR="!! ?8,""List  of CONTROL LED SUBSTA NCE orders  without D IGITAL SIG NATURE"""
  3437   "RTN","ORS 100C",65,0 )
  3438    S HDR1="! !,""RX #"" ,?10,""DEA "",?14,""Q TY"",?18," "PATIENT"" ,?43,""REL EASE DATE" ",?59,""OR D #"",!?2, ""DRUG"",? 43,""PROVI DER"",!?2, ""DIVISION "",?43,""L OCATION"""
  3439   "RTN","ORS 100C",66,0 )
  3440    S PAGE=0  D HDR^ORS1 00
  3441   "RTN","ORS 100C",67,0 )
  3442    I '$D(^TM P("ORUNS", $J)) W !," No orders  found" Q
  3443   "RTN","ORS 100C",68,0 )
  3444    S IDT="", CNT=0 F  S  IDT=$O(^T MP("ORUNS" ,$J,IDT))  Q:IDT=""!S TOP  D
  3445   "RTN","ORS 100C",69,0 )
  3446    . S ORIFN ="" F  S O RIFN=$O(^T MP("ORUNS" ,$J,IDT,OR IFN)) Q:OR IFN=""!STO P  S CNT=C NT+1,ORX=^ (ORIFN) D
  3447   "RTN","ORS 100C",70,0 )
  3448    .. W !,$P (ORX,U),?1 0,$P(ORX,U ,2),?14,$P (ORX,U,3), ?18,$P(ORX ,U,4),?43, $P(ORX,U,5 ),?59,ORIF N
  3449   "RTN","ORS 100C",71,0 )
  3450    .. W !?2, $P(ORX,U,6 ),?43,$P(O RX,U,7),!? 2,$P(ORX,U ,8),?43,$P (ORX,U,9), ! D:$Y>(IO SL-4) HDR^ ORS100 Q:S TOP
  3451   "RTN","ORS 100C",72,0 )
  3452    S ^TMP("O RSTATS",$J )=CNT
  3453   "RTN","ORS 100C",73,0 )
  3454    I '$D(^TM P("ORUNS", $J)) W !," No orders  found" Q
  3455   "RTN","ORS 100C",74,0 )
  3456    W !!?10," TOTAL FOUN D: "_CNT
  3457   "RTN","ORS 100C",75,0 )
  3458    D EXIT
  3459   "RTN","ORS 100C",76,0 )
  3460    Q
  3461   "RTN","ORS 100C",77,0 )
  3462   EXIT ;
  3463   "RTN","ORS 100C",78,0 )
  3464    K ^TMP("O RUNS",$J), ^TMP("ORST ATS",$J),^ TMP("PS",$ J)
  3465   "RTN","ORS 100C",79,0 )
  3466    D ^%ZISC
  3467   "RTN","ORS 100C",80,0 )
  3468    Q
  3469   "RTN","ORS PUTIL")
  3470   0^18^B2417 2750
  3471   "RTN","ORS PUTIL",1,0 )
  3472   ORSPUTIL ; SLC/JMH -  SUPPLY CON VERSION UT ILITY ;08/ 29/17  08: 48
  3473   "RTN","ORS PUTIL",2,0 )
  3474    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**4 23,397**;D ec 17, 199 7;Build 17
  3475   "RTN","ORS PUTIL",3,0 )
  3476    ;
  3477   "RTN","ORS PUTIL",4,0 )
  3478    ;
  3479   "RTN","ORS PUTIL",5,0 )
  3480    ;
  3481   "RTN","ORS PUTIL",6,0 )
  3482   SUPPLYNF ; if OI is m arked as N ON-FORMULA RY and SUP PLY then s et QO-ONLY  to yes fo r SUPPLY
  3483   "RTN","ORS PUTIL",7,0 )
  3484    W @IOF
  3485   "RTN","ORS PUTIL",8,0 )
  3486    W "This u tility wil l convert  all items  from the O RDERABLE I TEMS file  that are "
  3487   "RTN","ORS PUTIL",9,0 )
  3488    W !,"mark ed for bot h Supplies  and Non-F ormulary,  to be QO-O NLY to YES  for"
  3489   "RTN","ORS PUTIL",10, 0)
  3490    W !,"Supp lies."
  3491   "RTN","ORS PUTIL",11, 0)
  3492    I '$$SURE ("Are you  sure you w ant to con tinue?") Q
  3493   "RTN","ORS PUTIL",12, 0)
  3494    N I
  3495   "RTN","ORS PUTIL",13, 0)
  3496    S I=0 F   S I=$O(^OR D(101.43,I )) Q:'I  D
  3497   "RTN","ORS PUTIL",14, 0)
  3498    .Q:'$D(^O RD(101.43, I,"PS"))
  3499   "RTN","ORS PUTIL",15, 0)
  3500    .Q:'$P(^O RD(101.43, I,"PS"),U, 5)  ;quit  if not set  to supply
  3501   "RTN","ORS PUTIL",16, 0)
  3502    .Q:'$P(^O RD(101.43, I,"PS"),U, 6)  ;quit  if not set  to non-fo rmulary
  3503   "RTN","ORS PUTIL",17, 0)
  3504    .W !,"OI  IEN: ",I,? 20,"OI NAM E: ",$P(^O RD(101.43, I,0),U)
  3505   "RTN","ORS PUTIL",18, 0)
  3506    .D SET("S PLY",I)
  3507   "RTN","ORS PUTIL",19, 0)
  3508    Q
  3509   "RTN","ORS PUTIL",20, 0)
  3510    ;
  3511   "RTN","ORS PUTIL",21, 0)
  3512   COPYO2S ;i f OI is ma rked QO-ON LY for OUT PATIENT Me d then set  QO-ONLY t o yes for  SUPPLY
  3513   "RTN","ORS PUTIL",22, 0)
  3514    W @IOF
  3515   "RTN","ORS PUTIL",23, 0)
  3516    W "This u tility wil l convert  all items  from the O RDERABLE I TEMS file  that are "
  3517   "RTN","ORS PUTIL",24, 0)
  3518    W !,"mark ed for Sup plies and  also set a s QO-ONLY  yes for Ou tpatient M eds,"
  3519   "RTN","ORS PUTIL",25, 0)
  3520    W !,"to b e QO-ONLY  to YES for  Supplies. "
  3521   "RTN","ORS PUTIL",26, 0)
  3522    I '$$SURE ("Are you  sure you w ant to con tinue?") Q
  3523   "RTN","ORS PUTIL",27, 0)
  3524    N I
  3525   "RTN","ORS PUTIL",28, 0)
  3526    S I=0 F   S I=$O(^OR D(101.43,I )) Q:'I  D
  3527   "RTN","ORS PUTIL",29, 0)
  3528    .Q:'$D(^O RD(101.43, I,"PS"))
  3529   "RTN","ORS PUTIL",30, 0)
  3530    .Q:'$P(^O RD(101.43, I,"PS"),U, 5)  ;quit  if not set  to supply
  3531   "RTN","ORS PUTIL",31, 0)
  3532    .Q:'$$GET ("O RX",I)   ;quit if  not set t o YES for  QO-ONLY fo r outpatie nt meds
  3533   "RTN","ORS PUTIL",32, 0)
  3534    .W !,"OI  IEN: ",I,? 20,"OI NAM E: ",$P(^O RD(101.43, I,0),U)
  3535   "RTN","ORS PUTIL",33, 0)
  3536    .D SET("S PLY",I)
  3537   "RTN","ORS PUTIL",34, 0)
  3538    Q
  3539   "RTN","ORS PUTIL",35, 0)
  3540    ;
  3541   "RTN","ORS PUTIL",36, 0)
  3542   SUPPLYQO ;  Convert O utpatient  Med QO to  Supply dia log
  3543   "RTN","ORS PUTIL",37, 0)
  3544    ;
  3545   "RTN","ORS PUTIL",38, 0)
  3546    N ORCOUNT ,ORDGPSO,O RDGSUP,ORD LGOI,ORERR ,ORERRFLAG ,ORFDA,ORI EN,OROIIEN ,ORX
  3547   "RTN","ORS PUTIL",39, 0)
  3548    ;
  3549   "RTN","ORS PUTIL",40, 0)
  3550    W @IOF
  3551   "RTN","ORS PUTIL",41, 0)
  3552    W "This u tility wil l convert  all Outpat ient Medic ation quic k orders t hat were"
  3553   "RTN","ORS PUTIL",42, 0)
  3554    W !,"buil t for orde rable item s that are  considere d supply i tems, to u se the"
  3555   "RTN","ORS PUTIL",43, 0)
  3556    W !,"PSO  SUPPLY dia log."
  3557   "RTN","ORS PUTIL",44, 0)
  3558    I '$$SURE ("Are you  sure you w ant to con tinue?") Q
  3559   "RTN","ORS PUTIL",45, 0)
  3560    W !!
  3561   "RTN","ORS PUTIL",46, 0)
  3562    ;
  3563   "RTN","ORS PUTIL",47, 0)
  3564    S ORDGPSO =+$O(^ORD( 100.98,"B" ,"OUTPATIE NT MEDICAT IONS",0))
  3565   "RTN","ORS PUTIL",48, 0)
  3566    I 'ORDGPS O D ERROR( "Unable to  find the  OUTPATIENT  MEDICATIO NS display  group.")  Q
  3567   "RTN","ORS PUTIL",49, 0)
  3568    S ORDGSUP =+$O(^ORD( 100.98,"B" ,"SUPPLIES /DEVICES", 0))
  3569   "RTN","ORS PUTIL",50, 0)
  3570    I 'ORDGSU P D ERROR( "Unable to  find the  SUPPLIES/D EVICES dis play group .") Q
  3571   "RTN","ORS PUTIL",51, 0)
  3572    S ORDLGOI =+$O(^ORD( 101.41,"B" ,"OR GTX O RDERABLE I TEM",0))
  3573   "RTN","ORS PUTIL",52, 0)
  3574    I 'ORDLGO I D ERROR( "Unable to  find the  OR GTX ORD ERABLE ITE M dialog." ) Q
  3575   "RTN","ORS PUTIL",53, 0)
  3576    ;
  3577   "RTN","ORS PUTIL",54, 0)
  3578    S ORCOUNT =0
  3579   "RTN","ORS PUTIL",55, 0)
  3580    S ORIEN=0
  3581   "RTN","ORS PUTIL",56, 0)
  3582    F  S ORIE N=$O(^ORD( 101.41,ORI EN)) Q:'OR IEN  D
  3583   "RTN","ORS PUTIL",57, 0)
  3584    . ; Skip  disabled q uick order  (field #3  not blank )
  3585   "RTN","ORS PUTIL",58, 0)
  3586    . I $P(^O RD(101.41, ORIEN,0),U ,3)'="" Q
  3587   "RTN","ORS PUTIL",59, 0)
  3588    . ; Skip  non-quick  order
  3589   "RTN","ORS PUTIL",60, 0)
  3590    . I $P(^O RD(101.41, ORIEN,0),U ,4)'="Q" Q
  3591   "RTN","ORS PUTIL",61, 0)
  3592    . ; Skip  non-outpat ient medic ations
  3593   "RTN","ORS PUTIL",62, 0)
  3594    . I $P(^O RD(101.41, ORIEN,0),U ,5)'=ORDGP SO Q
  3595   "RTN","ORS PUTIL",63, 0)
  3596    . ;
  3597   "RTN","ORS PUTIL",64, 0)
  3598    . ; Deter mine if th e orderabl e item is  a supply
  3599   "RTN","ORS PUTIL",65, 0)
  3600    . S ORX=+ $O(^ORD(10 1.41,ORIEN ,6,"D",ORD LGOI,0))
  3601   "RTN","ORS PUTIL",66, 0)
  3602    . I 'ORX  Q
  3603   "RTN","ORS PUTIL",67, 0)
  3604    . S OROII EN=+$P($G( ^ORD(101.4 1,ORIEN,6, ORX,1)),U, 1)
  3605   "RTN","ORS PUTIL",68, 0)
  3606    . I 'OROI IEN Q
  3607   "RTN","ORS PUTIL",69, 0)
  3608    . I $P($P ($G(^ORD(1 01.43,OROI IEN,0)),U, 2),";",2)' ="99PSP" Q
  3609   "RTN","ORS PUTIL",70, 0)
  3610    . I $$ISO ISPLY^ORUT L3(OROIIEN ) D
  3611   "RTN","ORS PUTIL",71, 0)
  3612    . . K ORE RR,ORFDA
  3613   "RTN","ORS PUTIL",72, 0)
  3614    . . S ORF DA(101.41, ORIEN_",", 5)=ORDGSUP
  3615   "RTN","ORS PUTIL",73, 0)
  3616    . . D FIL E^DIE("K", "ORFDA","O RERR")
  3617   "RTN","ORS PUTIL",74, 0)
  3618    . . I $D( ORERR) D
  3619   "RTN","ORS PUTIL",75, 0)
  3620    . . . D E RRORFM("Un able to co nvert quic k order '" _$P($G(^OR D(101.41,O RIEN,0)),U ,1)_"' (IE N #"_ORIEN _")",.ORER R)
  3621   "RTN","ORS PUTIL",76, 0)
  3622    . . . S O RERRFLAG=1
  3623   "RTN","ORS PUTIL",77, 0)
  3624    . . E  D
  3625   "RTN","ORS PUTIL",78, 0)
  3626    . . . W ! ,"QO IEN:  ",ORIEN,?2 0,"QO NAME : ",$P($G( ^ORD(101.4 1,ORIEN,0) ),U,1)
  3627   "RTN","ORS PUTIL",79, 0)
  3628    . . . S O RCOUNT=ORC OUNT+1
  3629   "RTN","ORS PUTIL",80, 0)
  3630    ;
  3631   "RTN","ORS PUTIL",81, 0)
  3632    I $G(ORER RFLAG) D
  3633   "RTN","ORS PUTIL",82, 0)
  3634    . W !!,"T here were  some quick  orders th at could n ot be conv erted."
  3635   "RTN","ORS PUTIL",83, 0)
  3636    . W !,"Pl ease see o utput abov e for more  informati on."
  3637   "RTN","ORS PUTIL",84, 0)
  3638    . W !!,"P lease log  a CA SDM t icket for  assistance .",!
  3639   "RTN","ORS PUTIL",85, 0)
  3640    E  D
  3641   "RTN","ORS PUTIL",86, 0)
  3642    . W !!,"T he quick o rder conve rsion comp leted succ essfully."
  3643   "RTN","ORS PUTIL",87, 0)
  3644    ;
  3645   "RTN","ORS PUTIL",88, 0)
  3646    I ORCOUNT >0 D
  3647   "RTN","ORS PUTIL",89, 0)
  3648    . W !,ORC OUNT_" qui ck order"_ $S(ORCOUNT =1:" was", 1:"s were" )_" conver ted.",!!
  3649   "RTN","ORS PUTIL",90, 0)
  3650    E  D
  3651   "RTN","ORS PUTIL",91, 0)
  3652    . W !,"No  quick ord ers were c onverted"_ $S('$G(ORE RRFLAG):",  as none m et the sea rch criter ia.",1:"." ),!!
  3653   "RTN","ORS PUTIL",92, 0)
  3654    H 1
  3655   "RTN","ORS PUTIL",93, 0)
  3656    ;
  3657   "RTN","ORS PUTIL",94, 0)
  3658    Q
  3659   "RTN","ORS PUTIL",95, 0)
  3660    ;
  3661   "RTN","ORS PUTIL",96, 0)
  3662   GET(CODE,O RIEN) ;get  the curre nt status  of QO-ONLY  for a spe cific pack age type(C ODE)
  3663   "RTN","ORS PUTIL",97, 0)
  3664    N DA,ORY  S ORY=0
  3665   "RTN","ORS PUTIL",98, 0)
  3666    S DA=$O(^ ORD(101.43 ,ORIEN,9," B",CODE,"" ))
  3667   "RTN","ORS PUTIL",99, 0)
  3668    I DA D
  3669   "RTN","ORS PUTIL",100 ,0)
  3670    .I $P($G( ^ORD(101.4 3,ORIEN,9, DA,0)),U,2 ) S ORY=1
  3671   "RTN","ORS PUTIL",101 ,0)
  3672    Q ORY
  3673   "RTN","ORS PUTIL",102 ,0)
  3674    ;
  3675   "RTN","ORS PUTIL",103 ,0)
  3676   SET(CODE,O RIEN) ;set  the statu s of QO-ON LY to YES  for a spec ific packa ge type(CO DE)
  3677   "RTN","ORS PUTIL",104 ,0)
  3678    N ORDA
  3679   "RTN","ORS PUTIL",105 ,0)
  3680    S ORDA=$O (^ORD(101. 43,ORIEN,9 ,"B",CODE, ""))
  3681   "RTN","ORS PUTIL",106 ,0)
  3682    I ORDA D
  3683   "RTN","ORS PUTIL",107 ,0)
  3684    .N DA,DR, DIE
  3685   "RTN","ORS PUTIL",108 ,0)
  3686    .S DA(1)= ORIEN,DA=O RDA,DR=2_" ///YES",DI E="^ORD(10 1.43,"_DA( 1)_",9," D  ^DIE
  3687   "RTN","ORS PUTIL",109 ,0)
  3688    Q
  3689   "RTN","ORS PUTIL",110 ,0)
  3690    ;
  3691   "RTN","ORS PUTIL",111 ,0)
  3692   SURE(ORMSG ) ; -- sur e you want  to delete ?
  3693   "RTN","ORS PUTIL",112 ,0)
  3694    N X,Y,DIR
  3695   "RTN","ORS PUTIL",113 ,0)
  3696    S DIR(0)= "YA",DIR(" A")="  "_O RMSG_" "
  3697   "RTN","ORS PUTIL",114 ,0)
  3698    S DIR("B" )="NO" W $ C(7) D ^DI R
  3699   "RTN","ORS PUTIL",115 ,0)
  3700    S:$D(DTOU T) Y="^"
  3701   "RTN","ORS PUTIL",116 ,0)
  3702    Q Y
  3703   "RTN","ORS PUTIL",117 ,0)
  3704    ;
  3705   "RTN","ORS PUTIL",118 ,0)
  3706   ERROR(ORER ROR) ;
  3707   "RTN","ORS PUTIL",119 ,0)
  3708    W !!,ORER ROR
  3709   "RTN","ORS PUTIL",120 ,0)
  3710    W !,"Plea se log a C A SDM tick et for ass istance.", !
  3711   "RTN","ORS PUTIL",121 ,0)
  3712    H 2
  3713   "RTN","ORS PUTIL",122 ,0)
  3714    Q
  3715   "RTN","ORS PUTIL",123 ,0)
  3716    ;
  3717   "RTN","ORS PUTIL",124 ,0)
  3718   ERRORFM(OR TEXT,ORERR OR) ; Outp ut FileMan  Error Mes sages
  3719   "RTN","ORS PUTIL",125 ,0)
  3720    N ORX
  3721   "RTN","ORS PUTIL",126 ,0)
  3722    W !!,"ERR OR: "_ORTE XT_"."
  3723   "RTN","ORS PUTIL",127 ,0)
  3724    W !,"VA F ileMan Err or #"_$G(O RERROR("DI ERR",1))_" :"
  3725   "RTN","ORS PUTIL",128 ,0)
  3726    F ORX=1:1 :+$O(ORERR OR("DIERR" ,1,"TEXT", "A"),-1) D
  3727   "RTN","ORS PUTIL",129 ,0)
  3728    . W !,$G( ORERROR("D IERR",1,"T EXT",ORX))
  3729   "RTN","ORS PUTIL",130 ,0)
  3730    Q
  3731   "RTN","ORU PREF1")
  3732   0^2^B13019 106
  3733   "RTN","ORU PREF1",1,0 )
  3734   ORUPREF1 ;  slc/dcm -  Key alloc ation ;04/ 22/16  07: 45
  3735   "RTN","ORU PREF1",2,0 )
  3736    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**1 32,397**;D ec 17, 199 7;Build 17
  3737   "RTN","ORU PREF1",3,0 )
  3738    ;;397 - W AT Add ORS UPPLY to K EY
  3739   "RTN","ORU PREF1",4,0 )
  3740   EN ;
  3741   "RTN","ORU PREF1",5,0 )
  3742    K ORC W $ C(27),"[44 ;37m"
  3743   "RTN","ORU PREF1",6,0 )
  3744    S ORC(1)= "Black^0", ORC(2)="Re d^1",ORC(3 )="Green^2 ",ORC(4)=" Yellow^3", ORC(5)="Bl ue^4",ORC( 6)="Magent a^5",ORC(7 )="Cyan^6" ,ORC(8)="W hite^7"
  3745   "RTN","ORU PREF1",7,0 )
  3746    S ORC("B" ,"BLACK",1 )="",ORC(" B","RED",2 )="",ORC(" B","GREEN" ,3)="",ORC ("B","YELL OW",4)="", ORC("B","B LUE",5)="" ,ORC("B"," MAGENTA",6 )="",ORC(" B","CYAN", 7)="",ORC( "B","WHITE ",8)=""
  3747   "RTN","ORU PREF1",8,0 )
  3748    K ORBACK  D DISP,SEL  S ORF=$S( Y'=-1:Y,1: 37)
  3749   "RTN","ORU PREF1",9,0 )
  3750    S ORBACK= 1 D DISP,S EL S ORB=$ S(Y'=-1:Y, 1:40)
  3751   "RTN","ORU PREF1",10, 0)
  3752    W !,$C(27 ),"["_(29+ ORF)_";"_( 39+ORB)_"m "
  3753   "RTN","ORU PREF1",11, 0)
  3754   END K ORBA CK,ORF,ORB ,ORC,ORI
  3755   "RTN","ORU PREF1",12, 0)
  3756    Q
  3757   "RTN","ORU PREF1",13, 0)
  3758   DISP F ORI =1:1:8 W ! ?10,$C(27) ,"["_($S($ D(ORBACK): 40+$P(ORC( ORI),"^",2 ),1:30+$P( ORC(ORI)," ^",2))_"m" ),ORI_"  " ,$P(ORC(OR I),"^")_$E ("       " ,1,7-$L($P (ORC(ORI), "^"))) W $ C(27),"["_ ($S($D(ORB ACK):"44;3 7",1:"44;3 7")_"m")
  3759   "RTN","ORU PREF1",14, 0)
  3760    Q
  3761   "RTN","ORU PREF1",15, 0)
  3762   SEL S Y=-1  W !!,"Sel ect "_$S($ D(ORBACK): "BACKGROUN D",1:"FORE GROUND")_"  COLOR: "  R X:DTIME  Q:'$T!(X[" ^")!(X="")   D UP
  3763   "RTN","ORU PREF1",16, 0)
  3764    I X="BL"  W !,"Pleas e be more  specific"  G SEL
  3765   "RTN","ORU PREF1",17, 0)
  3766    I $D(ORC( "B",X)) S  X=$O(ORC(" B",X,0)) G  S1
  3767   "RTN","ORU PREF1",18, 0)
  3768    I $E($O(O RC("B",X)) ,1,$L(X))= X,X'="BL"  S X=$O(ORC ("B",X)),X =$O(ORC("B ",X,0)) G  S1
  3769   "RTN","ORU PREF1",19, 0)
  3770    I X'?1N!( '$D(ORC(X) )) W !,"Se lect a num ber for on e of the c hoices sho wn" G SEL
  3771   "RTN","ORU PREF1",20, 0)
  3772   S1 W "   " ,$C(27),"[ "_($S($D(O RBACK):40+ $P(ORC(X), "^",2),1:3 0+$P(ORC(X ),"^",2))_ "m"),$P(OR C(X),"^")  S Y=X
  3773   "RTN","ORU PREF1",21, 0)
  3774    W $C(27), "["_($S($D (ORBACK):" 44;37",1:" 44;37")_"m ")
  3775   "RTN","ORU PREF1",22, 0)
  3776    Q
  3777   "RTN","ORU PREF1",23, 0)
  3778   UP ;Upper  case
  3779   "RTN","ORU PREF1",24, 0)
  3780    F %=1:1:$ L(X) I $E( X,%)?1L S  X=$E(X,1,% -1)_$C($A( X,%)-32)_$ E(X,%+1,99 )
  3781   "RTN","ORU PREF1",25, 0)
  3782    Q
  3783   "RTN","ORU PREF1",26, 0)
  3784   KEY ;Edit  user secur ity keys
  3785   "RTN","ORU PREF1",27, 0)
  3786    N I
  3787   "RTN","ORU PREF1",28, 0)
  3788    S OREND=0 ,ORVER=+($ G(^DD(200, 0,"VR")))
  3789   "RTN","ORU PREF1",29, 0)
  3790    F ORKEY=" ORES","ORE LSE","OREM AS","ORSUP PLY" D K1  Q:OREND  W  ! F I=1:1 :(IOM-1) W  "="
  3791   "RTN","ORU PREF1",30, 0)
  3792    S OREND=0  K DLAYGO, DA,DR,DIE, DIC,OREND, ORK,ORKEY, ORHEAD,ORV ER
  3793   "RTN","ORU PREF1",31, 0)
  3794    Q
  3795   "RTN","ORU PREF1",32, 0)
  3796   K1 N % I ' $D(^DIC(19 .1,"B",ORK EY)) W !,O RKEY_" is  not in the  Security  Key file"  Q
  3797   "RTN","ORU PREF1",33, 0)
  3798    S ORK=$O( ^DIC(19.1, "B",ORKEY, 0)) I 'ORK !('$D(^DIC (19.1,ORK) )) W !,ORK EY_" is no t in the S ecurity Ke y file" Q
  3799   "RTN","ORU PREF1",34, 0)
  3800    W !!,"KEY : "_ORKEY, ! S I=0 F   S I=$O(^D IC(19.1,OR K,1,I)) Q: I<1  W !,^ (I,0)
  3801   "RTN","ORU PREF1",35, 0)
  3802   K2 W !!,"E dit Holder s" S %=1 D  YN^DICN S :%=-1 OREN D=1
  3803   "RTN","ORU PREF1",36, 0)
  3804    I %=0 W ! !,"Enter Y ES to edit  holders o f this key , NO to qu it." G K2
  3805   "RTN","ORU PREF1",37, 0)
  3806    Q:%'=1
  3807   "RTN","ORU PREF1",38, 0)
  3808    W ! D K7
  3809   "RTN","ORU PREF1",39, 0)
  3810    Q
  3811   "RTN","ORU PREF1",40, 0)
  3812   K7 ;edits  holders fo r Kernel V 7.0 in fil e #200
  3813   "RTN","ORU PREF1",41, 0)
  3814    N DIC,Y
  3815   "RTN","ORU PREF1",42, 0)
  3816    S DIC=200 ,DIC(0)="A EQM",DIC(" A")="Selec t HOLDER:  "
  3817   "RTN","ORU PREF1",43, 0)
  3818    F  D ^DIC  Q:Y<1  S  ORDUZ=Y,OR HAVE=$D(^X USEC(ORKEY ,+ORDUZ))  D K7SET:'O RHAVE,K7DE L:ORHAVE Q :OREND
  3819   "RTN","ORU PREF1",44, 0)
  3820    K ORDUZ,O RHAVE Q
  3821   "RTN","ORU PREF1",45, 0)
  3822   K7DEL ;del etes ORKEY  from pers on
  3823   "RTN","ORU PREF1",46, 0)
  3824    N DA,DIK
  3825   "RTN","ORU PREF1",47, 0)
  3826    W !?10,"D elete key"  S %=1 D Y N^DICN I ( %<0) S ORE ND=1 Q
  3827   "RTN","ORU PREF1",48, 0)
  3828    I %=2 W ! ?15,"Nothi ng changed !",! Q
  3829   "RTN","ORU PREF1",49, 0)
  3830    I %=0 D   G K7DEL
  3831   "RTN","ORU PREF1",50, 0)
  3832    .W !?7,"T his person  already h olds the " _ORKEY_" k ey; answer  YES"
  3833   "RTN","ORU PREF1",51, 0)
  3834    .W !?7,"t o de-alloc ate this k ey from th is user."
  3835   "RTN","ORU PREF1",52, 0)
  3836    .W !!?7," HOLDER: "_ $P(ORDUZ," ^",2)
  3837   "RTN","ORU PREF1",53, 0)
  3838    S DA=$O(^ VA(200,+OR DUZ,51,"B" ,ORK,0)),D A(1)=+ORDU Z
  3839   "RTN","ORU PREF1",54, 0)
  3840    I DA S DI K="^VA(200 ,"_DA(1)_" ,51," D ^D IK
  3841   "RTN","ORU PREF1",55, 0)
  3842    W !?15,$S (DA:"DELET ED!",1:"Er ror: ^XUSE C not cons istent wit h keys in  User file" ),!
  3843   "RTN","ORU PREF1",56, 0)
  3844    Q
  3845   "RTN","ORU PREF1",57, 0)
  3846   K7SET ;all ocates ORK EY to pers on
  3847   "RTN","ORU PREF1",58, 0)
  3848    N DIC,DA, DINUM,X
  3849   "RTN","ORU PREF1",59, 0)
  3850    I '$D(^VA (200,+ORDU Z,51,0)) S  ^VA(200,+ ORDUZ,51,0 )="^200.05 1PA^^"
  3851   "RTN","ORU PREF1",60, 0)
  3852    S DA(1)=+ ORDUZ,DIC= "^VA(200," _DA(1)_",5 1,",DIC(0) ="L",(DINU M,X)=ORK
  3853   "RTN","ORU PREF1",61, 0)
  3854    D FILE^DI CN W !?15, $S(Y>0:"Ad ded.",1:"E rror - not  added."), !
  3855   "RTN","ORU PREF1",62, 0)
  3856    Q
  3857   "RTN","ORU TL3")
  3858   0^10^B3158 346
  3859   "RTN","ORU TL3",1,0)
  3860   ORUTL3 ;SL C/JLC - OE /RR Utilit ies ;08/28 /17  14:37
  3861   "RTN","ORU TL3",2,0)
  3862    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**1 11,397**;D ec 17, 199 7;Build 17
  3863   "RTN","ORU TL3",3,0)
  3864    ;
  3865   "RTN","ORU TL3",4,0)
  3866    ;
  3867   "RTN","ORU TL3",5,0)
  3868    ;
  3869   "RTN","ORU TL3",6,0)
  3870   NATURE(ORI FN) ;find  nature of  order
  3871   "RTN","ORU TL3",7,0)
  3872    ;ORIFN is  the order ;action be ing reques ted
  3873   "RTN","ORU TL3",8,0)
  3874    ;if no ac tion is pr esent, the  API will  find the m ost recent  action th at has
  3875   "RTN","ORU TL3",9,0)
  3876    ;a nature  of order
  3877   "RTN","ORU TL3",10,0)
  3878    N OR8,ORA CT,ORNAT,O RNATURE
  3879   "RTN","ORU TL3",11,0)
  3880    S ORACT=$ P(ORIFN,"; ",2),ORIFN =$P(ORIFN, ";")
  3881   "RTN","ORU TL3",12,0)
  3882    I '$D(^OR (100,ORIFN ,0)) Q 0 ;  not a val id order
  3883   "RTN","ORU TL3",13,0)
  3884    I ORACT=" " D
  3885   "RTN","ORU TL3",14,0)
  3886    . N S1,A
  3887   "RTN","ORU TL3",15,0)
  3888    . S S1=0
  3889   "RTN","ORU TL3",16,0)
  3890    . F  S S1 =$O(^OR(10 0,ORIFN,8, S1)) Q:'S1   S A=$P($ G(^(S1,0)) ,"^",12) I  A]"" S OR ACT=S1
  3891   "RTN","ORU TL3",17,0)
  3892    I ORACT=" " Q 0 ;not  a valid o rder actio n
  3893   "RTN","ORU TL3",18,0)
  3894    I '$D(^OR (100,ORIFN ,8,ORACT))  Q 0 ;not  a valid or der action
  3895   "RTN","ORU TL3",19,0)
  3896    S OR8=$G( ^OR(100,OR IFN,8,ORAC T,0)) S OR NATURE=$P( OR8,"^",12 ),ORNAT=$$ TEXT(ORNAT URE)
  3897   "RTN","ORU TL3",20,0)
  3898    Q ORNATUR E_"^"_ORNA T
  3899   "RTN","ORU TL3",21,0)
  3900   TEXT(X) ;  -- Returns  3 ^-piece  identifie r for natu re X
  3901   "RTN","ORU TL3",22,0)
  3902    N ORN,Y S  ORN=$G(^O RD(100.02, +$G(X),0))
  3903   "RTN","ORU TL3",23,0)
  3904    S Y=$P(OR N,U,2)_U_$ P(ORN,U)_" ^99ORN"
  3905   "RTN","ORU TL3",24,0)
  3906    Q Y
  3907   "RTN","ORU TL3",25,0)
  3908   ISSUPPLY(O RDDIEN) ;I S THIS DIS PENSE DRUG  A SUPPLY  ORDER
  3909   "RTN","ORU TL3",26,0)
  3910    ;INPUT: O RDDIEN - D ISPENSE DR UG TO BE C HECKED
  3911   "RTN","ORU TL3",27,0)
  3912    D ZERO^PS S50(ORDDIE N,,,,,"ORD RUG")
  3913   "RTN","ORU TL3",28,0)
  3914    I ^TMP($J ,"ORDRUG", 0)<1 Q
  3915   "RTN","ORU TL3",29,0)
  3916    I "^XA^XX ^"[("^"_$E (^TMP($J," ORDRUG",OR DDIEN,2),1 ,2)_"^") Q  1
  3917   "RTN","ORU TL3",30,0)
  3918    I ^TMP($J ,"ORDRUG", ORDDIEN,2) ="DX900",$ G(^TMP($J, "ORDRUG",O RDDIEN,3)) ["S" Q 1
  3919   "RTN","ORU TL3",31,0)
  3920    Q 0
  3921   "RTN","ORU TL3",32,0)
  3922    ;
  3923   "RTN","ORU TL3",33,0)
  3924   ISOISPLY(O ROIIEN) ;i s this ord erable ite m a supply  order
  3925   "RTN","ORU TL3",34,0)
  3926    ; Input:  OROIIEN -  Orderable  Item IEN ( #101.43) t o be check ed
  3927   "RTN","ORU TL3",35,0)
  3928    N ORDRUG, ORLST,ORSP LY
  3929   "RTN","ORU TL3",36,0)
  3930    ;
  3931   "RTN","ORU TL3",37,0)
  3932    S ORSPLY= 1
  3933   "RTN","ORU TL3",38,0)
  3934    ;
  3935   "RTN","ORU TL3",39,0)
  3936    D OI2DD^O RKCHK5(.OR LST,OROIIE N,"O")
  3937   "RTN","ORU TL3",40,0)
  3938    I '$O(ORL ST(0)) S O RSPLY=0
  3939   "RTN","ORU TL3",41,0)
  3940    S ORDRUG= ""
  3941   "RTN","ORU TL3",42,0)
  3942    F  S ORDR UG=$O(ORLS T(ORDRUG))  Q:ORDRUG= ""!('ORSPL Y)  D
  3943   "RTN","ORU TL3",43,0)
  3944    . I '$$IS SUPPLY(+OR DRUG) S OR SPLY=0
  3945   "RTN","ORU TL3",44,0)
  3946    ;
  3947   "RTN","ORU TL3",45,0)
  3948    Q ORSPLY
  3949   "RTN","ORU TL5")
  3950   0^14^B2631 005
  3951   "RTN","ORU TL5",1,0)
  3952   ORUTL5 ; S LC/JLC - O E/RR Utili ties ;07/2 7/17  14:2 1
  3953   "RTN","ORU TL5",2,0)
  3954    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**4 61,397**;D ec 17, 199 7;Build 17
  3955   "RTN","ORU TL5",3,0)
  3956    ;
  3957   "RTN","ORU TL5",4,0)
  3958    ;
  3959   "RTN","ORU TL5",5,0)
  3960    ;
  3961   "RTN","ORU TL5",6,0)
  3962   MSG(ORREC, ORMSGT) ;
  3963   "RTN","ORU TL5",7,0)
  3964    N XMSUB,X MY,XMTEXT, XMDUZ,ORTE XT,SITE,I, A
  3965   "RTN","ORU TL5",8,0)
  3966    S ORTEXT( 1)="Attemp t to save  order with  INPATIENT  MEDICATIO NS Display  Group",SI TE=$$SITE^ VASITE()
  3967   "RTN","ORU TL5",9,0)
  3968    S ORTEXT( 2)=" "
  3969   "RTN","ORU TL5",10,0)
  3970    S A="ORMS GT("""")"  F I=3:1 S  A=$Q(@A) Q :A=""  S O RTEXT(I)=$ P(A,"(",2, 99)_" = "_ @A
  3971   "RTN","ORU TL5",11,0)
  3972    S XMDUZ=D UZ
  3973   "RTN","ORU TL5",12,0)
  3974    S XMSUB=" NEW PROBLE M ORDER SU BMITTED FR OM "_$P(SI TE,"^",2)
  3975   "RTN","ORU TL5",13,0)
  3976    S XMY("G. HPS CLIN2@ D O
M
A IN . EXT    ")="",XMY( "G.CLINICA L REMINDER S SUPPORT@ D O
M
A IN . EXT    ")=""
  3977   "RTN","ORU TL5",14,0)
  3978    S XMTEXT= "ORTEXT("
  3979   "RTN","ORU TL5",15,0)
  3980    D ^XMD
  3981   "RTN","ORU TL5",16,0)
  3982    Q
  3983   "RTN","ORU TL5",17,0)
  3984   COMPLETE(O RID) ;
  3985   "RTN","ORU TL5",18,0)
  3986    N ORDN,OR D,ORDIALOG ,ORINFO
  3987   "RTN","ORU TL5",19,0)
  3988    S ORINFO( "OR0")=$G( ^OR(100,+O RID,0)),OR INFO("OR3" )=$G(^(3)) ,ORINFO("O R4")=$G(^( 4)),ORINFO ("OR6")=$G (^(6)),ORI NFO("OR7") =$G(^(7))
  3989   "RTN","ORU TL5",20,0)
  3990    S ORDN=$P (ORINFO("O R0"),"^",5 ) Q:ORDN'[ "101.41"   S ORDN=+OR DN
  3991   "RTN","ORU TL5",21,0)
  3992    D GETDLG^ ORCD(ORDN) ,GETORDER^ ORCD(+ORID ,"ORD")
  3993   "RTN","ORU TL5",22,0)
  3994    S ORINFO( "DIALOG")= ORDN
  3995   "RTN","ORU TL5",23,0)
  3996    M ORINFO( "RESPONSES ")=ORD
  3997   "RTN","ORU TL5",24,0)
  3998    D MSG^XQO R("OR COMP LETE ORDER ",.ORINFO)
  3999   "RTN","ORU TL5",25,0)
  4000    Q
  4001   "RTN","ORW DPS3")
  4002   0^20^B2204 2687
  4003   "RTN","ORW DPS3",1,0)
  4004   ORWDPS3 ;S LC/KCM,JLI  - ORDER D IALOGS AND  MENUS ;Au g 30, 2018 @09:12
  4005   "RTN","ORW DPS3",2,0)
  4006    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**8 5,94,116,1 32,187,195 ,215,280,3 50,397**;D ec 17, 199 7;Build 17
  4007   "RTN","ORW DPS3",3,0)
  4008    ;
  4009   "RTN","ORW DPS3",4,0)
  4010    ;
  4011   "RTN","ORW DPS3",5,0)
  4012    ;
  4013   "RTN","ORW DPS3",6,0)
  4014   MEDXFER ;  -- setup O RDIALOG fo r a med th at is tran sferred (f rom SETUP^ ORWDXM4)
  4015   "RTN","ORW DPS3",7,0)
  4016    N IVDIALO G,OI K ^TM P("PS",$J)
  4017   "RTN","ORW DPS3",8,0)
  4018    S IVDIALO G=$O(^ORD( 101.41,"AB ","PSJI OR  PAT FLUID  OE",0))
  4019   "RTN","ORW DPS3",9,0)
  4020    S ORDIALO G=$O(^ORD( 101.41,"AB ","PS MEDS ",0))
  4021   "RTN","ORW DPS3",10,0 )
  4022    I +$P($G( ^OR(100,+O RIT,0)),U, 5)=IVDIALO G S ORDIAL OG=IVDIALO G
  4023   "RTN","ORW DPS3",11,0 )
  4024    S ORDG=+$ P(^ORD(101 .41,ORDIAL OG,0),U,5)
  4025   "RTN","ORW DPS3",12,0 )
  4026    D GETDLG^ ORCD(ORDIA LOG)
  4027   "RTN","ORW DPS3",13,0 )
  4028    D GETORDE R^ORCD("^O R(100,"_+O RIT_",4.5) ")
  4029   "RTN","ORW DPS3",14,0 )
  4030    ;I ORDIAL OG=IVDIALO G Q
  4031   "RTN","ORW DPS3",15,0 )
  4032    S OI=$$VA L^ORCD("ME DICATION")
  4033   "RTN","ORW DPS3",16,0 )
  4034    I ORDIALO G'=IVDIALO G,'$$MEDOK (OI,ORCAT)  D SETERR( ORIT,"This  may not b e ordered  as an "_$S (ORCAT="I" :"in",1:"o ut")_"pati ent drug." ) Q
  4035   "RTN","ORW DPS3",17,0 )
  4036    I +$G(OI) >0,$G(^ORD (101.43,OI ,.1)),(^(. 1)<$$NOW^X LFDT) D SE TERR(ORIT, "This may  no longer  be ordered .") Q
  4037   "RTN","ORW DPS3",18,0 )
  4038    I (ORDIAL OG'=IVDIAL OG),(ORCAT ="I") D OU T^ORCMED
  4039   "RTN","ORW DPS3",19,0 )
  4040    I (ORDIAL OG'=IVDIAL OG),(ORCAT ="O") D IN ^ORCMED
  4041   "RTN","ORW DPS3",20,0 )
  4042    S ORWPSWR G="" ; for ce interac tive dialo g for tran sfers
  4043   "RTN","ORW DPS3",21,0 )
  4044    Q
  4045   "RTN","ORW DPS3",22,0 )
  4046   MEDOK(OI,C AT)   ; re turn 1 if  med may be  ordered f or this pa tient cate gory
  4047   "RTN","ORW DPS3",23,0 )
  4048    N P S P=$ S(CAT="I": 1,1:2)
  4049   "RTN","ORW DPS3",24,0 )
  4050    I ORIMO S  P=1
  4051   "RTN","ORW DPS3",25,0 )
  4052    N THEGRP, INPTGRP
  4053   "RTN","ORW DPS3",26,0 )
  4054    S THEGRP= 0
  4055   "RTN","ORW DPS3",27,0 )
  4056    I $D(ORIT ),+ORIT S  THEGRP=$P( $G(^OR(100 ,+ORIT,0)) ,U,11)
  4057   "RTN","ORW DPS3",28,0 )
  4058    S INPTGRP =$O(^ORD(1 00.98,"B", "UD RX",0) )
  4059   "RTN","ORW DPS3",29,0 )
  4060    I P=2,(IN PTGRP=THEG RP),($P($G (^ORD(101. 43,+OI,"PS ")),U,1)=2 ) Q 2
  4061   "RTN","ORW DPS3",30,0 )
  4062    E  Q $P($ G(^ORD(101 .43,+OI,"P S")),U,P)
  4063   "RTN","ORW DPS3",31,0 )
  4064    ;
  4065   "RTN","ORW DPS3",32,0 )
  4066   SETERR(ID, X)       ;  sets LST  to rejecti on with er ror messag e
  4067   "RTN","ORW DPS3",33,0 )
  4068    D GETTXT^ ORWORR(.LS T,ID)
  4069   "RTN","ORW DPS3",34,0 )
  4070    S LST(0)= "8^0",LST( .5)=X,LST( .6)=""
  4071   "RTN","ORW DPS3",35,0 )
  4072    Q
  4073   "RTN","ORW DPS3",36,0 )
  4074    ;
  4075   "RTN","ORW DPS3",37,0 )
  4076   PS ; setup  environme nt for med ications
  4077   "RTN","ORW DPS3",38,0 )
  4078    D AUTHMED  Q:$G(ORQU IT)  ; che cks author ized to wr ite meds
  4079   "RTN","ORW DPS3",39,0 )
  4080    K ^TMP("P SJINS",$J) ,^TMP("PSJ MR",$J),^T MP("PSJNOU N",$J),^TM P("PSJSCH" ,$J)
  4081   "RTN","ORW DPS3",40,0 )
  4082    N PROMPT, OI
  4083   "RTN","ORW DPS3",41,0 )
  4084    S PROMPT= $O(^ORD(10 1.41,"AB", "OR GTX OR DERABLE IT EM",0))
  4085   "RTN","ORW DPS3",42,0 )
  4086    S OI=""
  4087   "RTN","ORW DPS3",43,0 )
  4088    I $D(ORDI ALOG(PROMP T,1)) S OI =ORDIALOG( PROMPT,1)  D MEDACTV  Q:$G(ORQUI T)
  4089   "RTN","ORW DPS3",44,0 )
  4090    N PSOI
  4091   "RTN","ORW DPS3",45,0 )
  4092    S PSOI=+$ P($G(^ORD( 101.43,+OI ,0)),U,2)  D START^PS SJORDF(PSO I,ORCAT)
  4093   "RTN","ORW DPS3",46,0 )
  4094    S PROMPT= $O(^ORD(10 1.41,"AB", "OR GTX SC HEDULE",0) )
  4095   "RTN","ORW DPS3",47,0 )
  4096    I $D(ORDI ALOG(PROMP T,1)) S OR SCH=ORDIAL OG(PROMPT, 1)
  4097   "RTN","ORW DPS3",48,0 )
  4098    I (ORCAT= "I"),$L($G (ORSCH)) D
  4099   "RTN","ORW DPS3",49,0 )
  4100    . S ORSD= ""
  4101   "RTN","ORW DPS3",50,0 )
  4102    . I $L($G (^DPT(+ORV P,.1))) S  ORSD=$$STA RTSTP^PSJO RPOE(+ORVP ,ORSCH,PSO I,+$G(ORWA RD),"")
  4103   "RTN","ORW DPS3",51,0 )
  4104    . I $P(OR SD,U)="NEX T" S $P(OR SD,U)="NEX TA"
  4105   "RTN","ORW DPS3",52,0 )
  4106    S PROMPT= $O(^ORD(10 1.41,"AB", "OR GTX DA YS SUPPLY" ,0))
  4107   "RTN","ORW DPS3",53,0 )
  4108    I $D(ORDI ALOG(PROMP T,1)) S OR DSUP=ORDIA LOG(PROMPT ,1)
  4109   "RTN","ORW DPS3",54,0 )
  4110    S PROMPT= $O(^ORD(10 1.41,"AB", "OR GTX DI SPENSE DRU G",0))
  4111   "RTN","ORW DPS3",55,0 )
  4112    I $D(ORDI ALOG(PROMP T,1)) S OR DRUG=ORDIA LOG(PROMPT ,1)
  4113   "RTN","ORW DPS3",56,0 )
  4114    S PROMPT= $O(^ORD(10 1.41,"AB", "OR GTX RE FILLS",0))
  4115   "RTN","ORW DPS3",57,0 )
  4116    I $D(ORDI ALOG(PROMP T,1)) S OR EFILLS=ORD IALOG(PROM PT,1)
  4117   "RTN","ORW DPS3",58,0 )
  4118    I ORCAT=" O" S ORCOP AY=$$ASKSC ^ORCDPS1
  4119   "RTN","ORW DPS3",59,0 )
  4120    I ORCAT=" I" S PROMP T=$O(^ORD( 101.41,"AB ","OR GTX  START DATE /TIME",0))  D
  4121   "RTN","ORW DPS3",60,0 )
  4122    . I $L($P ($G(ORSD), U)),'$D(OR DIALOG(PRO MPT,1)) S  ORDIALOG(P ROMPT,1)=$ P(ORSD,U)
  4123   "RTN","ORW DPS3",61,0 )
  4124    ; create  a SIG if n one exists  (i.e., wh en copying  pre-POE o rders)
  4125   "RTN","ORW DPS3",62,0 )
  4126    I '$L($G( ORDIALOG($ $PTR^ORCD( "OR GTX SI G"),1))) D
  4127   "RTN","ORW DPS3",63,0 )
  4128    . N ORDOS E,ORDRUG,O RWPSOI,PRO MPT,DRUG
  4129   "RTN","ORW DPS3",64,0 )
  4130    . S PROMP T=$$PTR^OR CD("OR GTX  INSTRUCTI ONS")
  4131   "RTN","ORW DPS3",65,0 )
  4132    . S ORDRU G=$G(ORDIA LOG($$PTR^ ORCD("OR G TX DISPENS E DRUG"),1 ))
  4133   "RTN","ORW DPS3",66,0 )
  4134    . S ORWPS OI=+$G(ORD IALOG($$PT R^ORCD("OR  GTX ORDER ABLE ITEM" ),1))
  4135   "RTN","ORW DPS3",67,0 )
  4136    . I ORWPS OI S ORWPS OI=+$P($G( ^ORD(101.4 3,+ORWPSOI ,0)),U,2)
  4137   "RTN","ORW DPS3",68,0 )
  4138    . D DOSE^ PSSORUTL(. ORDOSE,ORW PSOI,$S(OR CAT="I":"U ",1:"O"),O RVP)        ; dflt do ses
  4139   "RTN","ORW DPS3",69,0 )
  4140    . D D1^OR CDPS2  ; s et up ORDO SE & xrefs  in ORDIAL OG
  4141   "RTN","ORW DPS3",70,0 )
  4142    . S DRUG= $G(ORDOSE( "DD",+ORDR UG))
  4143   "RTN","ORW DPS3",71,0 )
  4144    . I DRUG, ORCAT="O"  D RESETID^ ORCDPS
  4145   "RTN","ORW DPS3",72,0 )
  4146    . D SIG^O RCDPS2
  4147   "RTN","ORW DPS3",73,0 )
  4148    Q
  4149   "RTN","ORW DPS3",74,0 )
  4150   AUTHMED ;  sets ORQUI T if not a uthorized  to write m eds
  4151   "RTN","ORW DPS3",75,0 )
  4152    N NOAUTH, NAME
  4153   "RTN","ORW DPS3",76,0 )
  4154    D AUTH^OR WDPS32(.NO AUTH,ORNP, $G(ORDIALO G))
  4155   "RTN","ORW DPS3",77,0 )
  4156    I +NOAUTH  D
  4157   "RTN","ORW DPS3",78,0 )
  4158    . S ORQUI T=1
  4159   "RTN","ORW DPS3",79,0 )
  4160    . S LST(0 )="8^0"
  4161   "RTN","ORW DPS3",80,0 )
  4162    . I $P(NO AUTH,U,2)' ="" S LST( .5)=$P(NOA UTH,U,2) Q
  4163   "RTN","ORW DPS3",81,0 )
  4164    . S NAME= $P($G(^VA( 200,+ORNP, 20)),U,2)
  4165   "RTN","ORW DPS3",82,0 )
  4166    . I '$L(N AME) S NAM E=$P($G(^V A(200,+ORN P,0)),U,1)
  4167   "RTN","ORW DPS3",83,0 )
  4168    . S LST(. 5)=NAME_"  is not aut horized to  write med  orders."
  4169   "RTN","ORW DPS3",84,0 )
  4170    Q
  4171   "RTN","ORW DPS3",85,0 )
  4172   MEDACTV ;  sets ORQUI T if the o rderable i tem is not  active fo r a med
  4173   "RTN","ORW DPS3",86,0 )
  4174    Q:'$G(OI)
  4175   "RTN","ORW DPS3",87,0 )
  4176    I $G(^ORD (101.43,OI ,.1)),^(.1 )'>$$NOW^X LFDT D
  4177   "RTN","ORW DPS3",88,0 )
  4178    . S ORQUI T=1
  4179   "RTN","ORW DPS3",89,0 )
  4180    . S LST(0 )="8^0"
  4181   "RTN","ORW DPS3",90,0 )
  4182    . S LST(. 5)=$P($G(^ ORD(101.43 ,OI,0)),U) _" has bee n inactiva ted and ma y not be o rdered any more."
  4183   "RTN","ORW DPS3",91,0 )
  4184    I $D(ORQU IT) Q:ORQU IT
  4185   "RTN","ORW DPS3",92,0 )
  4186    ; copied  from ORDIT M^ORCDPS1  to make su re quick o rder if fo r right di alog
  4187   "RTN","ORW DPS3",93,0 )
  4188    N ORPS,PS OI,ORIV,OR INPT
  4189   "RTN","ORW DPS3",94,0 )
  4190    S ORINPT= $$INPT^ORC D
  4191   "RTN","ORW DPS3",95,0 )
  4192    S ORPS=$G (^ORD(101. 43,+OI,"PS ")),PSOI=+ $P($G(^(0) ),U,2)
  4193   "RTN","ORW DPS3",96,0 )
  4194    S ORIV=$S ($P(ORPS,U )=2:1,1:0)
  4195   "RTN","ORW DPS3",97,0 )
  4196    I $G(ORCA T)="O",'$P (ORPS,U,2) ,'ORIMO S  LST(.5)="T his drug m ay not be  used in an  outpatien t order."
  4197   "RTN","ORW DPS3",98,0 )
  4198    I $G(ORCA T)="I" D
  4199   "RTN","ORW DPS3",99,0 )
  4200    . I $G(OR INPT),'$P( ORPS,U),'$ P(ORPS,"^" ,5),'ORIMO  S LST(.5) ="This dru g may not  be used in  an inpati ent order. "
  4201   "RTN","ORW DPS3",100, 0)
  4202    . I '$G(O RINPT),'OR IV,'ORIMO  S LST(.5)= "This drug  may not b e ordered  for an out patient."
  4203   "RTN","ORW DPS3",101, 0)
  4204    I $L($G(L ST(.5))) S  ORQUIT=1, LST(0)="8^ 0"
  4205   "RTN","ORW DPS3",102, 0)
  4206    Q
  4207   "RTN","ORW DPS32")
  4208   0^17^B7879 9489
  4209   "RTN","ORW DPS32",1,0 )
  4210   ORWDPS32 ;  SLC/KCM -  Pharmacy  Calls for  GUI Dialog  ;08/23/17   12:00
  4211   "RTN","ORW DPS32",2,0 )
  4212    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**1 0,85,94,19 0,195,237, 243,350,39 7**;Dec 17 , 1997;Bui ld 17
  4213   "RTN","ORW DPS32",3,0 )
  4214    ;Per VHA  Directive  6402, this  routine s hould not  be modifie d.
  4215   "RTN","ORW DPS32",4,0 )
  4216    ;
  4217   "RTN","ORW DPS32",5,0 )
  4218    ;
  4219   "RTN","ORW DPS32",6,0 )
  4220    ;
  4221   "RTN","ORW DPS32",7,0 )
  4222   NXT() ; --  ret next  available  index in d ata array
  4223   "RTN","ORW DPS32",8,0 )
  4224    S ILST=IL ST+1
  4225   "RTN","ORW DPS32",9,0 )
  4226    Q ILST
  4227   "RTN","ORW DPS32",10, 0)
  4228    ;
  4229   "RTN","ORW DPS32",11, 0)
  4230   DLGSLCT(LS T,PSTYPE,D FN,LOCIEN)  ; return  def lists  for dialog
  4231   "RTN","ORW DPS32",12, 0)
  4232    ; PSTYPE:  pharmacy  type (U=un it dose, F =IV fluids , O=outpt)
  4233   "RTN","ORW DPS32",13, 0)
  4234    N ILST S  ILST=0
  4235   "RTN","ORW DPS32",14, 0)
  4236    I PSTYPE= "F" D  Q                          ; IV Flui ds
  4237   "RTN","ORW DPS32",15, 0)
  4238    . S LST($ $NXT)="~Sh ortList"   D SHORT
  4239   "RTN","ORW DPS32",16, 0)
  4240    . S LST($ $NXT)="~Pr iorities"  D PRIOR
  4241   "RTN","ORW DPS32",17, 0)
  4242    . ;S LST( $$NXT)="~S chedules"   D SCHED(L OCIEN)
  4243   "RTN","ORW DPS32",18, 0)
  4244    . S LST($ $NXT)="~Ro ute" D IVR OUTE
  4245   "RTN","ORW DPS32",19, 0)
  4246    ;
  4247   "RTN","ORW DPS32",20, 0)
  4248    S LST($$N XT)="~Shor tList"  D  SHORT       ; Unit Do se & Outpt
  4249   "RTN","ORW DPS32",21, 0)
  4250    ;S LST($$ NXT)="~Sch edules"  D  SCHED(LOC IEN)
  4251   "RTN","ORW DPS32",22, 0)
  4252    S LST($$N XT)="~Prio rities" D  PRIOR
  4253   "RTN","ORW DPS32",23, 0)
  4254    I PSTYPE= "O" D                             ; Outpt
  4255   "RTN","ORW DPS32",24, 0)
  4256    . S LST($ $NXT)="~Pi ckup"   D  PICKUP
  4257   "RTN","ORW DPS32",25, 0)
  4258    . S LST($ $NXT)="~SC Status" D  SCLIST
  4259   "RTN","ORW DPS32",26, 0)
  4260    Q
  4261   "RTN","ORW DPS32",27, 0)
  4262   SHORT ; fr om DLGSLCT , get shor t list of  med quick  orders
  4263   "RTN","ORW DPS32",28, 0)
  4264    ; !!! cha nge this s o that it  uses the O RWDXQ call !!!
  4265   "RTN","ORW DPS32",29, 0)
  4266    N I,X,TMP
  4267   "RTN","ORW DPS32",30, 0)
  4268    I PSTYPE= "U" S X="U D RX"
  4269   "RTN","ORW DPS32",31, 0)
  4270    I PSTYPE= "F" S X="I V RX"
  4271   "RTN","ORW DPS32",32, 0)
  4272    I PSTYPE= "O" S X="O  RX"
  4273   "RTN","ORW DPS32",33, 0)
  4274    D GETQLST ^ORWDXQ(.T MP,X,"iQ")
  4275   "RTN","ORW DPS32",34, 0)
  4276    S I=0 F   S I=$O(TMP (I)) Q:'I   S LST($$N XT)=TMP(I)
  4277   "RTN","ORW DPS32",35, 0)
  4278    Q
  4279   "RTN","ORW DPS32",36, 0)
  4280   SCHEDA ; ( similar to  SCHED, bu t also rtn s admin ti mes)
  4281   "RTN","ORW DPS32",37, 0)
  4282    N X,IEN,S CH,TIME
  4283   "RTN","ORW DPS32",38, 0)
  4284    K ^TMP($J ,"ORWDPS32  SCHEDA")
  4285   "RTN","ORW DPS32",39, 0)
  4286    D AP^PSS5 1P1("PSJ", ,,,"ORWDPS 32 SCHEDA" )
  4287   "RTN","ORW DPS32",40, 0)
  4288    S SCH=""  F  S SCH=$ O(^TMP($J, "ORWDPS32  SCHEDA","A PPSJ",SCH) ) Q:SCH=""   D
  4289   "RTN","ORW DPS32",41, 0)
  4290    .S IEN=""  F  S IEN= $O(^TMP($J ,"ORWDPS32  SCHEDA"," APPSJ",SCH ,IEN)) Q:I EN'>0  D
  4291   "RTN","ORW DPS32",42, 0)
  4292    ..S TIME= $G(^TMP($J ,"ORWDPS32  SCHEDA",I EN,1))
  4293   "RTN","ORW DPS32",43, 0)
  4294    ..S X=$S( $L(TIME):"   ("_TIME_ ")",1:"")
  4295   "RTN","ORW DPS32",44, 0)
  4296    ..S LST($ $NXT)="i"_ IEN_U_SCH_ U_X
  4297   "RTN","ORW DPS32",45, 0)
  4298    K ^TMP($J ,"ORWDPS32  SCHEDA")
  4299   "RTN","ORW DPS32",46, 0)
  4300    Q
  4301   "RTN","ORW DPS32",47, 0)
  4302    ;
  4303   "RTN","ORW DPS32",48, 0)
  4304   IVROUTE ;
  4305   "RTN","ORW DPS32",49, 0)
  4306    N ABB,EXP ,IEN,RTE
  4307   "RTN","ORW DPS32",50, 0)
  4308    K ^TMP($J ,"ORWDPS32  IVROUTE")
  4309   "RTN","ORW DPS32",51, 0)
  4310    D ALL^PSS 51P2(,"??" ,,1,"ORWDP S32 IVROUT E")
  4311   "RTN","ORW DPS32",52, 0)
  4312    S RTE=""  F  S RTE=$ O(^TMP($J, "ORWDPS32  IVROUTE"," B",RTE)) Q :RTE=""  D
  4313   "RTN","ORW DPS32",53, 0)
  4314    .S IEN=$O (^TMP($J," ORWDPS32 I VROUTE","I V",RTE,"") ) Q:IEN'>0
  4315   "RTN","ORW DPS32",54, 0)
  4316    .S ABB=$G (^TMP($J," ORWDPS32 I VROUTE",IE N,1))
  4317   "RTN","ORW DPS32",55, 0)
  4318    .S EXP=$G (^TMP($J," ORWDPS32 I VROUTE",IE N,4))
  4319   "RTN","ORW DPS32",56, 0)
  4320    .S LST($$ NXT)="i"_I EN_U_RTE_U _ABB_U_EXP
  4321   "RTN","ORW DPS32",57, 0)
  4322    K ^TMP($J ,"ORWDPS32  IVROUTE")
  4323   "RTN","ORW DPS32",58, 0)
  4324    Q
  4325   "RTN","ORW DPS32",59, 0)
  4326    ;
  4327   "RTN","ORW DPS32",60, 0)
  4328   ALLIVRTE(L ST) ;
  4329   "RTN","ORW DPS32",61, 0)
  4330    N ABB,CNT ,EXP,IEN,R TE
  4331   "RTN","ORW DPS32",62, 0)
  4332    K ^TMP($J ,"ORWDPS32  ALLIVRTE" )
  4333   "RTN","ORW DPS32",63, 0)
  4334    S CNT=0
  4335   "RTN","ORW DPS32",64, 0)
  4336    D ALL^PSS 51P2(,"??" ,,1,"ORWDP S32 ALLIVR TE")
  4337   "RTN","ORW DPS32",65, 0)
  4338    S RTE=""  F  S RTE=$ O(^TMP($J, "ORWDPS32  ALLIVRTE", "B",RTE))  Q:RTE=""   D
  4339   "RTN","ORW DPS32",66, 0)
  4340    .S IEN=$O (^TMP($J," ORWDPS32 A LLIVRTE"," IV",RTE,"" )) Q:IEN'> 0
  4341   "RTN","ORW DPS32",67, 0)
  4342    .S ABB=$G (^TMP($J," ORWDPS32 A LLIVRTE",I EN,1))
  4343   "RTN","ORW DPS32",68, 0)
  4344    .S EXP=$G (^TMP($J," ORWDPS32 A LLIVRTE",I EN,4))
  4345   "RTN","ORW DPS32",69, 0)
  4346    .S CNT=CN T+1,LST(CN T)=IEN_U_R TE_U_ABB_U _U_U_U
  4347   "RTN","ORW DPS32",70, 0)
  4348    K ^TMP($J ,"ORWDPS32  IVROUTE")
  4349   "RTN","ORW DPS32",71, 0)
  4350    Q
  4351   "RTN","ORW DPS32",72, 0)
  4352    ;
  4353   "RTN","ORW DPS32",73, 0)
  4354   ROUTE ; fr om OISLCT^ ORWDPS32,  get list o f routes f or the dru g form
  4355   "RTN","ORW DPS32",74, 0)
  4356    ; ** NEED  BOTH ABBR EVIATION &  NAME IN L IST BOX
  4357   "RTN","ORW DPS32",75, 0)
  4358    N I,CNT,A BBR,IEN,RO UT,X
  4359   "RTN","ORW DPS32",76, 0)
  4360    S I="" F   S I=$O(^T MP("PSJMR" ,$J,I)) Q: I=""  D
  4361   "RTN","ORW DPS32",77, 0)
  4362    . S ROUT= $P(^TMP("P SJMR",$J,I ),U),ABBR= $P(^(I),U, 2),IEN=$P( ^(I),U,3)
  4363   "RTN","ORW DPS32",78, 0)
  4364    . S LST($ $NXT)="i"_ IEN_U_ROUT _U_ABBR
  4365   "RTN","ORW DPS32",79, 0)
  4366    . I I=1,I EN S LST($ $NXT)="d"_ IEN_U_ROUT  ;_U_ABBR  ; assume f irst alway s default
  4367   "RTN","ORW DPS32",80, 0)
  4368    S I="" F   S I=$O(^T MP("PSJMR" ,$J,I)) Q: I=""  D
  4369   "RTN","ORW DPS32",81, 0)
  4370    . S ROUT= $P(^TMP("P SJMR",$J,I ),U),ABBR= $P(^(I),U, 2),IEN=$P( ^(I),U,3)
  4371   "RTN","ORW DPS32",82, 0)
  4372    . I $L(AB BR),(ABBR' =ROUT) S L ST($$NXT)= "i"_IEN_U_ ABBR_" ("_ ROUT_")"_U _ABBR
  4373   "RTN","ORW DPS32",83, 0)
  4374    Q
  4375   "RTN","ORW DPS32",84, 0)
  4376    ;similar  to SCHED^O RWDPS32, a lso return s Admin Ti me for Pat ient ward  location
  4377   "RTN","ORW DPS32",85, 0)
  4378    ;AGP CPRS  27.72 THI S CODE IS  NOT NEEDED  ANYMORE
  4379   "RTN","ORW DPS32",86, 0)
  4380   SCHED(LOCI EN) ;
  4381   "RTN","ORW DPS32",87, 0)
  4382    N CNT,ORA RRAY,SCH,I EN,EXP,TIM E,TYP,X0,W IEN
  4383   "RTN","ORW DPS32",88, 0)
  4384    ;K ^TMP($ J,"ORWDPS3 2 SCHED1")
  4385   "RTN","ORW DPS32",89, 0)
  4386    S WIEN=$$ WARDIEN(+L OCIEN)
  4387   "RTN","ORW DPS32",90, 0)
  4388    D SCHED^P SS51P1(WIE N,.ORARRAY )
  4389   "RTN","ORW DPS32",91, 0)
  4390    S CNT=0 F   S CNT=$O (ORARRAY(C NT)) Q:CNT '>0  D
  4391   "RTN","ORW DPS32",92, 0)
  4392    .S LST($$ NXT)="i"_$ P(ORARRAY( CNT),U,2,5 )
  4393   "RTN","ORW DPS32",93, 0)
  4394    Q
  4395   "RTN","ORW DPS32",94, 0)
  4396    ;
  4397   "RTN","ORW DPS32",95, 0)
  4398   WARDIEN(LO CIEN) ;
  4399   "RTN","ORW DPS32",96, 0)
  4400    N RESULT
  4401   "RTN","ORW DPS32",97, 0)
  4402    S RESULT= 0
  4403   "RTN","ORW DPS32",98, 0)
  4404    I LOCIEN= 0 Q RESULT
  4405   "RTN","ORW DPS32",99, 0)
  4406    I $P($G(^ SC(LOCIEN, 42)),U)=""  Q RESULT
  4407   "RTN","ORW DPS32",100 ,0)
  4408    S RESULT= +$P($G(^SC (LOCIEN,42 )),U)
  4409   "RTN","ORW DPS32",101 ,0)
  4410    Q RESULT
  4411   "RTN","ORW DPS32",102 ,0)
  4412   PRIOR ; fr om DLGSLCT , get list  of allowe d prioriti es
  4413   "RTN","ORW DPS32",103 ,0)
  4414    N X,XREF
  4415   "RTN","ORW DPS32",104 ,0)
  4416    S XREF=$S (PSTYPE="O ":"S.PSO", 1:"S.PSJ")
  4417   "RTN","ORW DPS32",105 ,0)
  4418    S X="" F   S X=$O(^O RD(101.42, XREF,X)) Q :'$L(X)  D
  4419   "RTN","ORW DPS32",106 ,0)
  4420    . S LST($ $NXT)="i"_ $O(^ORD(10 1.42,XREF, X,0))_U_X
  4421   "RTN","ORW DPS32",107 ,0)
  4422    S LST($$N XT)="d"_$O (^ORD(101. 42,"B","RO UTINE",0)) _U_"ROUTIN E"
  4423   "RTN","ORW DPS32",108 ,0)
  4424    Q
  4425   "RTN","ORW DPS32",109 ,0)
  4426   PICKUP ; f rom DLGSLC T, get pre scription  routing
  4427   "RTN","ORW DPS32",110 ,0)
  4428    N X,EDITO NLY
  4429   "RTN","ORW DPS32",111 ,0)
  4430    F X="W^at  Window"," M^by Mail" ,"C^in Cli nic" S LST ($$NXT)="i "_X
  4431   "RTN","ORW DPS32",112 ,0)
  4432    S X=$$DEF PICK I $L( X) S LST($ $NXT)="d"_ X
  4433   "RTN","ORW DPS32",113 ,0)
  4434    Q
  4435   "RTN","ORW DPS32",114 ,0)
  4436   DEFPICK()        ; re t def rout ing
  4437   "RTN","ORW DPS32",115 ,0)
  4438    N X,DLG,P RMT
  4439   "RTN","ORW DPS32",116 ,0)
  4440    S DLG=$O( ^ORD(101.4 1,"AB","PS O OERR",0) ),X=""
  4441   "RTN","ORW DPS32",117 ,0)
  4442    S PRMT=$O (^ORD(101. 41,"AB","O R GTX ROUT ING",0))
  4443   "RTN","ORW DPS32",118 ,0)
  4444    I $D(^TMP ("ORECALL" ,$J,+DLG,+ PRMT,1)) S  X=^(1)
  4445   "RTN","ORW DPS32",119 ,0)
  4446    I X'="" S  EDITONLY= 1 Q X  ; E DITONLY us ed by def  action
  4447   "RTN","ORW DPS32",120 ,0)
  4448    ;
  4449   "RTN","ORW DPS32",121 ,0)
  4450    S X=$$GET ^XPAR("ALL ","ORWDPS  ROUTING DE FAULT",1," I")
  4451   "RTN","ORW DPS32",122 ,0)
  4452    I X="C" S  X="C^in C linic" G X PICK
  4453   "RTN","ORW DPS32",123 ,0)
  4454    I X="M" S  X="M^by M ail"   G X PICK
  4455   "RTN","ORW DPS32",124 ,0)
  4456    I X="W" S  X="W^at W indow" G X PICK
  4457   "RTN","ORW DPS32",125 ,0)
  4458    I X="N" S  X=""              G  XPICK
  4459   "RTN","ORW DPS32",126 ,0)
  4460    I X=""  S  X=$S($D(^ PSX(550,"C ")):"M^by  Mail",1:"W ^at Window ")
  4461   "RTN","ORW DPS32",127 ,0)
  4462   XPICK Q X
  4463   "RTN","ORW DPS32",128 ,0)
  4464    ;
  4465   "RTN","ORW DPS32",129 ,0)
  4466   SCLIST ; f rom DLGSLC T, get opt ions for s ervice con nected
  4467   "RTN","ORW DPS32",130 ,0)
  4468    F X="0^No ","1^Yes"  S LST($$NX T)="i"_X
  4469   "RTN","ORW DPS32",131 ,0)
  4470    Q
  4471   "RTN","ORW DPS32",132 ,0)
  4472    ;
  4473   "RTN","ORW DPS32",133 ,0)
  4474   OISLCT(LST ,OI,PSTYPE ,ORVP) ; r tn for def aults for  pharm OI
  4475   "RTN","ORW DPS32",134 ,0)
  4476    N ILST S  ILST=0
  4477   "RTN","ORW DPS32",135 ,0)
  4478    K ^TMP("P SJINS",$J) ,^TMP("PSJ MR",$J),^T MP("PSJNOU N",$J),^TM P("PSJSCH" ,$J)
  4479   "RTN","ORW DPS32",136 ,0)
  4480    S LST($$N XT)="~Disp ense" D DI SPDRG
  4481   "RTN","ORW DPS32",137 ,0)
  4482    S LST($$N XT)="~Inst ruct" D IN STRCT
  4483   "RTN","ORW DPS32",138 ,0)
  4484    S LST($$N XT)="~Rout e"    D RO UTE
  4485   "RTN","ORW DPS32",139 ,0)
  4486    S LST($$N XT)="~Mess age"  D ME SSAGE
  4487   "RTN","ORW DPS32",140 ,0)
  4488    I $L($G(^ TMP("PSJSC H",$J))) S  LST($$NXT )="~DefSch ed",LST($$ NXT)="d"_^ ($J)
  4489   "RTN","ORW DPS32",141 ,0)
  4490    K ^TMP("P SJINS",$J) ,^TMP("PSJ MR",$J),^T MP("PSJNOU N",$J),^TM P("PSJSCH" ,$J)
  4491   "RTN","ORW DPS32",142 ,0)
  4492    Q
  4493   "RTN","ORW DPS32",143 ,0)
  4494    ;
  4495   "RTN","ORW DPS32",144 ,0)
  4496   DISPDRUG(L ST,OI) ; l ist dispen se drugs f or an OI
  4497   "RTN","ORW DPS32",145 ,0)
  4498    N ILST,PS TYPE S ILS T=0,PSTYPE ="U" D DIS PDRG
  4499   "RTN","ORW DPS32",146 ,0)
  4500    Q
  4501   "RTN","ORW DPS32",147 ,0)
  4502    ;
  4503   "RTN","ORW DPS32",148 ,0)
  4504   DISPDRG ;  from OISLC T, get dis p drugs fo r this pha rm OI
  4505   "RTN","ORW DPS32",149 ,0)
  4506    N I,ORTMP ,ORX
  4507   "RTN","ORW DPS32",150 ,0)
  4508    S ORX=$T( ENDD^PSJOR UTL),ORX=$ L($P(ORX," ;"),",")
  4509   "RTN","ORW DPS32",151 ,0)
  4510    I ORX>3 D  ENDD^PSJO RUTL("^^^" _+$P($G(^O RD(101.43, OI,0)),"^" ,2),PSTYPE ,.ORTMP,+O RVP)
  4511   "RTN","ORW DPS32",152 ,0)
  4512    I ORX'>3  D ENDD^PSJ ORUTL("^^^ "_+$P($G(^ ORD(101.43 ,OI,0)),"^ ",2),PSTYP E,.ORTMP)
  4513   "RTN","ORW DPS32",153 ,0)
  4514    S I="" F   S I=$O(OR TMP(I)) Q: I=""  D
  4515   "RTN","ORW DPS32",154 ,0)
  4516    . I $P(OR TMP(I),U,4 )="1" S $P (ORTMP(I), U,4)="NF"
  4517   "RTN","ORW DPS32",155 ,0)
  4518    . S $P(OR TMP(I),U,3 )="$"_$P(O RTMP(I),U, 3)_" per " _$P(ORTMP( I),U,5)
  4519   "RTN","ORW DPS32",156 ,0)
  4520    . S LST($ $NXT)="i"_ ORTMP(I)
  4521   "RTN","ORW DPS32",157 ,0)
  4522    Q
  4523   "RTN","ORW DPS32",158 ,0)
  4524   INSTRCT ;  from OISLC T, get lis t of poten tial instr ucts (base d on drug  form)
  4525   "RTN","ORW DPS32",159 ,0)
  4526    N INOUN,N OUN,IINS,I NS,VERB,IN SREC
  4527   "RTN","ORW DPS32",160 ,0)
  4528    D START^P SSJORDF(+$ P(^ORD(101 .43,OI,0), U,2))
  4529   "RTN","ORW DPS32",161 ,0)
  4530    I PSTYPE= "U" Q  ; d on't use t he instruc tions list  for inpat ients
  4531   "RTN","ORW DPS32",162 ,0)
  4532    S IINS=0  F  S IINS= $O(^TMP("P SJINS",$J, IINS)) Q:' IINS  D
  4533   "RTN","ORW DPS32",163 ,0)
  4534    . S INSRE C=$G(^TMP( "PSJINS",$ J,IINS))
  4535   "RTN","ORW DPS32",164 ,0)
  4536    . I '$D(V ERB) S VER B=$P(INSRE C,U)
  4537   "RTN","ORW DPS32",165 ,0)
  4538    . I $L($P (INSREC,U, 2)) S LST( $$NXT)="i" _$P(INSREC ,U,2)
  4539   "RTN","ORW DPS32",166 ,0)
  4540    S LST($$N XT)="~Noun s"
  4541   "RTN","ORW DPS32",167 ,0)
  4542    S INOUN=0  F  S INOU N=$O(^TMP( "PSJNOUN", $J,INOUN))  Q:'INOUN   D
  4543   "RTN","ORW DPS32",168 ,0)
  4544    . S LST($ $NXT)="i"_ $P(^TMP("P SJNOUN",$J ,INOUN),U)
  4545   "RTN","ORW DPS32",169 ,0)
  4546    I $D(VERB ) S LST($$ NXT)="~Ver b",LST($$N XT)="d"_VE RB
  4547   "RTN","ORW DPS32",170 ,0)
  4548    ;
  4549   "RTN","ORW DPS32",171 ,0)
  4550    Q
  4551   "RTN","ORW DPS32",172 ,0)
  4552   MIXED(X)    ; Return  mixed case
  4553   "RTN","ORW DPS32",173 ,0)
  4554    Q X
  4555   "RTN","ORW DPS32",174 ,0)
  4556    ;
  4557   "RTN","ORW DPS32",175 ,0)
  4558   MESSAGE ;  message
  4559   "RTN","ORW DPS32",176 ,0)
  4560    S I=0 F   S I=$O(^OR D(101.43,O I,8,I)) Q: I'>0  S LS T($$NXT)=" t"_^(I,0)
  4561   "RTN","ORW DPS32",177 ,0)
  4562    Q
  4563   "RTN","ORW DPS32",178 ,0)
  4564   ALLROUTE(L ST) ; retu rns a list  of all av ailable me d routes
  4565   "RTN","ORW DPS32",179 ,0)
  4566    N I,X,ILS T
  4567   "RTN","ORW DPS32",180 ,0)
  4568    S ILST=0
  4569   "RTN","ORW DPS32",181 ,0)
  4570    K ^TMP($J ,"ORWDPS32  ALLROUTE" )
  4571   "RTN","ORW DPS32",182 ,0)
  4572    D ALL^PSS 51P2(,"??" ,,,"ORWDPS 32 ALLROUT E")
  4573   "RTN","ORW DPS32",183 ,0)
  4574    S I=0 F   S I=$O(^TM P($J,"ORWD PS32 ALLRO UTE",I)) Q :'I  D
  4575   "RTN","ORW DPS32",184 ,0)
  4576    . I +$P(^ TMP($J,"OR WDPS32 ALL ROUTE",I,3 ),U)>0 S L ST($$NXT)= I_U_^TMP($ J,"ORWDPS3 2 ALLROUTE ",I,.01)_U _^TMP($J," ORWDPS32 A LLROUTE",I ,1)
  4577   "RTN","ORW DPS32",185 ,0)
  4578    K ^TMP($J ,"ORWDPS32  ALLROUTE" )
  4579   "RTN","ORW DPS32",186 ,0)
  4580    Q
  4581   "RTN","ORW DPS32",187 ,0)
  4582   VALROUTE(R EC,X)         ; valid ates route  name & re turns IEN  + abbrevia tion
  4583   "RTN","ORW DPS32",188 ,0)
  4584    N ABBR,NA ME,IEN
  4585   "RTN","ORW DPS32",189 ,0)
  4586    K ^TMP($J ,"ORWDPS32  VALROUTE" )
  4587   "RTN","ORW DPS32",190 ,0)
  4588    S X=$$UPP ER(X)
  4589   "RTN","ORW DPS32",191 ,0)
  4590    D ALL^PSS 51P2(,X,,1 ,"ORWDPS32  VALROUTE" )
  4591   "RTN","ORW DPS32",192 ,0)
  4592    I $P(^TMP ($J,"ORWDP S32 VALROU TE",0),U)= -1 K ^TMP( $J,"ORWDPS 32 VALROUT E") S REC= 0 Q
  4593   "RTN","ORW DPS32",193 ,0)
  4594    S IEN=$O( ^TMP($J,"O RWDPS32 VA LROUTE","B ",X,""))
  4595   "RTN","ORW DPS32",194 ,0)
  4596    I IEN'>0  S IEN=$O(^ TMP($J,"OR WDPS32 VAL ROUTE","C" ,X,""))
  4597   "RTN","ORW DPS32",195 ,0)
  4598    I IEN'>0  S REC=0 Q
  4599   "RTN","ORW DPS32",196 ,0)
  4600    S NAME=$G (^TMP($J," ORWDPS32 V ALROUTE",I EN,.01))
  4601   "RTN","ORW DPS32",197 ,0)
  4602    S ABBR=$G (^TMP($J," ORWDPS32 V ALROUTE",I EN,1))
  4603   "RTN","ORW DPS32",198 ,0)
  4604    I '$L(ABB R) S ABBR= NAME
  4605   "RTN","ORW DPS32",199 ,0)
  4606    I ($$UPPE R(NAME)'=X ),($$UPPER (ABBR)'=X)  S REC=0 K  ^TMP($J," ORWDPS32 V ALROUTE")  Q
  4607   "RTN","ORW DPS32",200 ,0)
  4608    S REC=IEN _U_ABBR
  4609   "RTN","ORW DPS32",201 ,0)
  4610    K ^TMP($J ,"ORWDPS32  VALROUTE" )
  4611   "RTN","ORW DPS32",202 ,0)
  4612    Q
  4613   "RTN","ORW DPS32",203 ,0)
  4614   AUTH(VAL,P RV,ORDLOG)  ; For inp atient med s, check r estriction s
  4615   "RTN","ORW DPS32",204 ,0)
  4616    N NAME,AU TH,INACT,X ,ORSDLOG,O RDL,A,IFN, B
  4617   "RTN","ORW DPS32",205 ,0)
  4618    S VAL=0
  4619   "RTN","ORW DPS32",206 ,0)
  4620    S NAME=$P ($G(^VA(20 0,PRV,20)) ,U,2) S:'$ L(NAME) NA ME=$P(^(0) ,U)
  4621   "RTN","ORW DPS32",207 ,0)
  4622    S X=$G(^V A(200,PRV, "PS")),AUT H=$P(X,U), INACT=$P(X ,U,4)
  4623   "RTN","ORW DPS32",208 ,0)
  4624    S ORDLOG= $G(ORDLOG) ,ORDL=""
  4625   "RTN","ORW DPS32",209 ,0)
  4626    I ORDLOG? 1"X".E S I FN=$E(ORDL OG,2,99),A =$P($G(^OR (100,+IFN, 0)),"^",5)  D
  4627   "RTN","ORW DPS32",210 ,0)
  4628    . I $P(A, ";",2)[101 .41 S ORDL OG=+A Q
  4629   "RTN","ORW DPS32",211 ,0)
  4630    . S ORDLO G=""
  4631   "RTN","ORW DPS32",212 ,0)
  4632    I ORDLOG] "" S A=$G( ^ORD(101.4 1,ORDLOG,0 )) I $P(A, "^",4)="Q"  S B=$P(A, "^",5) I B ]"" S ORDL =$P($G(^OR D(100.98,B ,0)),"^",4 )
  4633   "RTN","ORW DPS32",213 ,0)
  4634    S ORSDLOG =$O(^ORD(1 01.41,"B", "PSO SUPPL Y",""))
  4635   "RTN","ORW DPS32",214 ,0)
  4636    I 'AUTH!( INACT&(DT> INACT)) D   Q:VAL
  4637   "RTN","ORW DPS32",215 ,0)
  4638    . I (ORDL OG=ORSDLOG !(ORDL=ORS DLOG)),$D( ^XUSEC("OR SUPPLY",DU Z)) Q
  4639   "RTN","ORW DPS32",216 ,0)
  4640    . S VAL=" 1^"_NAME_"  is not au thorized t o write me dication o rders."
  4641   "RTN","ORW DPS32",217 ,0)
  4642    I $D(^XUS EC("OREMAS ",DUZ)),'$ $GET^XPAR( "ALL","OR  OREMAS MED  ORDERS")  D  Q
  4643   "RTN","ORW DPS32",218 ,0)
  4644    . S VAL=" 1^OREMAS k ey holders  may not e nter medic ation orde rs."
  4645   "RTN","ORW DPS32",219 ,0)
  4646    Q
  4647   "RTN","ORW DPS32",220 ,0)
  4648    ;
  4649   "RTN","ORW DPS32",221 ,0)
  4650   AUTHNVA(VA L,PRV) ; F or Non-VA  meds, chec k restrict ions
  4651   "RTN","ORW DPS32",222 ,0)
  4652    N NAME,AU TH,INACT,X  S VAL=0
  4653   "RTN","ORW DPS32",223 ,0)
  4654    I $D(^XUS EC("OREMAS ",DUZ)),$$ GET^XPAR(" ALL","OR O REMAS NON- VA MED ORD ERS")=2 Q
  4655   "RTN","ORW DPS32",224 ,0)
  4656    I $D(^XUS EC("OREMAS ",DUZ)),'$ $GET^XPAR( "ALL","OR  OREMAS NON -VA MED OR DERS") D   Q
  4657   "RTN","ORW DPS32",225 ,0)
  4658    . S VAL=" 1^OREMAS k ey holders  may not e nter non-V A medicati on orders. "
  4659   "RTN","ORW DPS32",226 ,0)
  4660    S NAME=$P ($G(^VA(20 0,PRV,20)) ,U,2) S:'$ L(NAME) NA ME=$P(^(0) ,U)
  4661   "RTN","ORW DPS32",227 ,0)
  4662    S X=$G(^V A(200,PRV, "PS")),AUT H=$P(X,U), INACT=$P(X ,U,4)
  4663   "RTN","ORW DPS32",228 ,0)
  4664    I 'AUTH!( INACT&(DT> INACT)) D   Q
  4665   "RTN","ORW DPS32",229 ,0)
  4666    . S VAL=" 1^"_NAME_"  is not au thorized t o write me dication o rders."
  4667   "RTN","ORW DPS32",230 ,0)
  4668    Q
  4669   "RTN","ORW DPS32",231 ,0)
  4670    ;
  4671   "RTN","ORW DPS32",232 ,0)
  4672   UPPER(X)         ; re turn upper case
  4673   "RTN","ORW DPS32",233 ,0)
  4674    Q $TR(X," abcdefghij klmnopqrst uvwxyz","A BCDEFGHIJK LMNOPQRSTU VWXYZ")
  4675   "RTN","ORW DPS32",234 ,0)
  4676    ;
  4677   "RTN","ORW DPS32",235 ,0)
  4678   TRIM(X) ;  trim leadi ng and tra iling spac es
  4679   "RTN","ORW DPS32",236 ,0)
  4680    S X=$RE(X ) F  S:$E( X)=" " X=$ E(X,2,999)  Q:$E(X)'= " "  Q:'$L (X)  ;trai l
  4681   "RTN","ORW DPS32",237 ,0)
  4682    S X=$RE(X ) F  S:$E( X)=" " X=$ E(X,2,999)  Q:$E(X)'= " "  Q:'$L (X)  ;lead
  4683   "RTN","ORW DPS32",238 ,0)
  4684    Q X
  4685   "RTN","ORW DPS32",239 ,0)
  4686    ;
  4687   "RTN","ORW DX")
  4688   0^15^B9250 1053
  4689   "RTN","ORW DX",1,0)
  4690   ORWDX ; SL C/KCM/REV/ JLI - Orde r dialog u tilities ; Oct 03, 20 18@13:53
  4691   "RTN","ORW DX",2,0)
  4692    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**1 0,85,125,1 31,132,141 ,164,178,1 87,190,195 ,215,246,2 43,283,296 ,280,306,3 50,424,421 ,461,490,3 97**;Dec 1 7, 1997;Bu ild 17
  4693   "RTN","ORW DX",3,0)
  4694    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  4695   "RTN","ORW DX",4,0)
  4696    ;
  4697   "RTN","ORW DX",5,0)
  4698    ;Referenc e to DIC(9 .4 support ed by IA # 2058
  4699   "RTN","ORW DX",6,0)
  4700    ;Referenc e to ^SC(  supported  by ICR #10 040
  4701   "RTN","ORW DX",7,0)
  4702    ;Referenc e to ^DPT(  supported  by ICR #1 0035
  4703   "RTN","ORW DX",8,0)
  4704    ;
  4705   "RTN","ORW DX",9,0)
  4706    ;Sep 18,  2015 - PB  - modified  to trigge r an unsol icited syn c action
  4707   "RTN","ORW DX",10,0)
  4708    ;
  4709   "RTN","ORW DX",11,0)
  4710   ORDITM(Y,F ROM,DIR,XR EF,QOCALL)  ; Subset  of orderab le items
  4711   "RTN","ORW DX",12,0)
  4712    ; Y(n)=IE N^.01 Name ^.01 Name   -or-  IEN ^Synonym < .01 Name>^ .01 Name
  4713   "RTN","ORW DX",13,0)
  4714    N I,IEN,C NT,X,DTXT, CURTM,DEFR OUTE
  4715   "RTN","ORW DX",14,0)
  4716    S DEFROUT E=""
  4717   "RTN","ORW DX",15,0)
  4718    S QOCALL= +$G(QOCALL )
  4719   "RTN","ORW DX",16,0)
  4720    S I=0,CNT =44,CURTM= $$NOW^XLFD T
  4721   "RTN","ORW DX",17,0)
  4722    F  Q:I'<C NT  S FROM =$O(^ORD(1 01.43,XREF ,FROM),DIR ) Q:FROM=" "  D
  4723   "RTN","ORW DX",18,0)
  4724    . S IEN=" " F  S IEN =$O(^ORD(1 01.43,XREF ,FROM,IEN) ,DIR) Q:'I EN  D
  4725   "RTN","ORW DX",19,0)
  4726    . . S X=^ ORD(101.43 ,XREF,FROM ,IEN)
  4727   "RTN","ORW DX",20,0)
  4728    . . I +$P (X,U,3),$P (X,U,3)<CU RTM Q
  4729   "RTN","ORW DX",21,0)
  4730    . . I 'QO CALL,$P(X, U,5) Q
  4731   "RTN","ORW DX",22,0)
  4732    . . S I=I +1
  4733   "RTN","ORW DX",23,0)
  4734    . . I 'X  S Y(I)=IEN _U_$P(X,U, 2)_U_$P(X, U,2)
  4735   "RTN","ORW DX",24,0)
  4736    . . E  S  Y(I)=IEN_U _$P(X,U,2) _$C(9)_"<" _$P(X,U,4) _">"_U_$P( X,U,4)
  4737   "RTN","ORW DX",25,0)
  4738    Q
  4739   "RTN","ORW DX",26,0)
  4740   ODITMBC(Y, XREF,ODLST ) ;
  4741   "RTN","ORW DX",27,0)
  4742    N CNT,NM, XRF
  4743   "RTN","ORW DX",28,0)
  4744    S CNT=0,N M=0,XRF=XR EF
  4745   "RTN","ORW DX",29,0)
  4746    F  S CNT= $O(ODLST(C NT)) Q:'CN T  D FNDIN FO(.Y,ODLS T(CNT))
  4747   "RTN","ORW DX",30,0)
  4748    Q
  4749   "RTN","ORW DX",31,0)
  4750   FNDINFO(Y, ODIEN) ;
  4751   "RTN","ORW DX",32,0)
  4752    D FNDINFO ^ORWDX1(.Y ,.ODIEN)
  4753   "RTN","ORW DX",33,0)
  4754    Q
  4755   "RTN","ORW DX",34,0)
  4756   DLGDEF(LST ,DLG) ; Fo rmat mappi ng for a d lg
  4757   "RTN","ORW DX",35,0)
  4758    D DLGDEF^ ORWDX1(.LS T,.DLG)
  4759   "RTN","ORW DX",36,0)
  4760    Q
  4761   "RTN","ORW DX",37,0)
  4762   DLGQUIK(LS T,QO) ;(NO T USED)
  4763   "RTN","ORW DX",38,0)
  4764    D LOADRSP (.LST,QO)
  4765   "RTN","ORW DX",39,0)
  4766    Q
  4767   "RTN","ORW DX",40,0)
  4768   LOADRSP(LS T,RSPID,TR ANS)       ; Load res ponses fro m 101.41 o r 100
  4769   "RTN","ORW DX",41,0)
  4770    ; RSPID:   C123456;1 -3243 = ca ched copy,    134-323 4 = cached  quick
  4771   "RTN","ORW DX",42,0)
  4772    ;          X123456;1       = ch ange order ,  134       = quick  dialog
  4773   "RTN","ORW DX",43,0)
  4774    N I,J,DLG ,INST,ID,V AL,ILST,RO OT,ORLOC S  ROOT=""
  4775   "RTN","ORW DX",44,0)
  4776    K ^TMP($J ,"ORWDX LO ADRSP","QO  SAVE")
  4777   "RTN","ORW DX",45,0)
  4778    I +RSPID= $P(RSPID," -",1) D
  4779   "RTN","ORW DX",46,0)
  4780    .S ^TMP($ J,"ORWDX L OADRSP","Q O SAVE")=+ RSPID
  4781   "RTN","ORW DX",47,0)
  4782    I RSPID[" -" S ROOT= "^TMP(""OR WDXMQ"",$J ,"""_RSPID _""")" G X ROOT^ORWDX 2
  4783   "RTN","ORW DX",48,0)
  4784    I $E(RSPI D)="X" S R OOT="^OR(1 00,"_+$P(R SPID,"X",2 )_",4.5)"   G XROOT^O RWDX2
  4785   "RTN","ORW DX",49,0)
  4786    I +RSPID= RSPID  S R OOT="^ORD( 101.41,"_+ RSPID_",6) " G XROOT^ ORWDX2
  4787   "RTN","ORW DX",50,0)
  4788    Q:ROOT=""
  4789   "RTN","ORW DX",51,0)
  4790    G XROOT^O RWDX2
  4791   "RTN","ORW DX",52,0)
  4792   SAVE(REC,O RVP,ORNP,O RL,DLG,ORD G,ORIT,ORI FN,ORDIALO G,ORDEA,OR APPT,ORSRC ,OREVTDF)  ;
  4793   "RTN","ORW DX",53,0)
  4794    ; ORVP=DF N, ORNP=Pr ovider, OR L=Location , DLG=Orde r Dialog,
  4795   "RTN","ORW DX",54,0)
  4796    ; ORDG=Di splay Grou p, ORIT=Qu ick Order  Dialog, OR APPT=Appoi ntment
  4797   "RTN","ORW DX",55,0)
  4798    N ORDUZ,O RSTS,OREVE NT,ORCAT,O RDA,ORTS,O RNEW,ORCHE CK,ORLOG,O RLEAD,ORTR AIL,ORPKG, ORWP94,ORC ATFN,OREVT YPE,ONPASS
  4799   "RTN","ORW DX",56,0)
  4800    N MSGCAPT ,SENDMSG
  4801   "RTN","ORW DX",57,0)
  4802    ;S ORDG=$ O(^ORD(100 .98,"B","I NPATIENT M EDICATIONS ",""))
  4803   "RTN","ORW DX",58,0)
  4804    N XCNT,XC OMM,XDONE, XX  ;SBR
  4805   "RTN","ORW DX",59,0)
  4806    S (XCOMM, XCNT)=""   ;SBR
  4807   "RTN","ORW DX",60,0)
  4808    I $G(ORIF N)'="" D   ;SBR probl em only oc curs on ch ange or re new orders
  4809   "RTN","ORW DX",61,0)
  4810    . S XCNT= $O(^OR(100 ,+ORIFN,4. 5,"ID","CO MMENT",XCN T))  ;SBR
  4811   "RTN","ORW DX",62,0)
  4812    . I XCNT' ="" S XCOM M=$P($G(^O R(100,+ORI FN,4.5,XCN T,0)),"^", 2)  ;SBR
  4813   "RTN","ORW DX",63,0)
  4814    . I XCOMM '="" S XDO NE=0,XX=""  F  S XX=$ O(ORDIALOG ("WP",XCOM M,1,XX)) Q :XX=""  D   ;SBR
  4815   "RTN","ORW DX",64,0)
  4816    . . I ORD IALOG("WP" ,XCOMM,1,X X,0)'="" S  XDONE=1 Q   ;SBR
  4817   "RTN","ORW DX",65,0)
  4818    . I XCOMM '="",'$G(X DONE),$D(O RDIALOG("W P",XCOMM))  K ORDIALO G("WP",XCO MM)  ;SBR
  4819   "RTN","ORW DX",66,0)
  4820    S ORCATFN ="" I $L($ P(DLG,U,2) ) S ORCATF N=$P(DLG,U ,2),DLG=$P (DLG,U,1)
  4821   "RTN","ORW DX",67,0)
  4822    S SENDMSG =0 I $P($G (^ORD(100. 98,ORDG,0) ),U)="INPA TIENT MEDI CATIONS" D
  4823   "RTN","ORW DX",68,0)
  4824    .S MSGCAP T("PATIENT ")=ORVP,MS GCAPT("USE R")=ORNP,M SGCAPT("LO C")=+$G(OR L)
  4825   "RTN","ORW DX",69,0)
  4826    .S MSGCAP T("DIALOG" )=DLG,MSGC APT("DISPL AY GROUP") =ORDG,MSGC APT("QUICK  ORDER")=O RIT
  4827   "RTN","ORW DX",70,0)
  4828    .M MSGCAP T("ORDIALO G")=ORDIAL OG
  4829   "RTN","ORW DX",71,0)
  4830    .S ORDG=$ O(^ORD(100 .98,"B","U NIT DOSE M EDICATIONS ","")),SEN DMSG=1
  4831   "RTN","ORW DX",72,0)
  4832    ;Remove t reating fa cility if  inpatient  and IMO or der 26.42
  4833   "RTN","ORW DX",73,0)
  4834    I $G(^DPT (ORVP,.1)) '="",$P($G (^ORD(100. 98,ORDG,0) ),U)="CLIN IC MEDICAT IONS" K OR DIALOG("OR TS")
  4835   "RTN","ORW DX",74,0)
  4836    I $G(^DPT (ORVP,.1)) '="",$P($G (^ORD(100. 98,ORDG,0) ),U)="CLIN IC INFUSIO NS" K ORDI ALOG("ORTS ")
  4837   "RTN","ORW DX",75,0)
  4838    I $G(ORDI ALOG("ORTS ")) S ORTS =ORDIALOG( "ORTS") K  ORDIALOG(" ORTS")
  4839   "RTN","ORW DX",76,0)
  4840    I $G(ORDI ALOG("ORSL OG")) S OR LOG=ORDIAL OG("ORSLOG ") K ORDIA LOG("ORSLO G")
  4841   "RTN","ORW DX",77,0)
  4842    I $D(ORDI ALOG("OREV ENT")) S O REVENT=ORD IALOG("ORE VENT") K O RDIALOG("O REVENT")
  4843   "RTN","ORW DX",78,0)
  4844    ;======== ========== ========== ========== ========== =====
  4845   "RTN","ORW DX",79,0)
  4846    ; Changed  for v26.2 7 (RV)
  4847   "RTN","ORW DX",80,0)
  4848    S ORCAT=$ $INPT^ORCD ,ORCAT=$S( ORCAT=1:"I ",1:"O")
  4849   "RTN","ORW DX",81,0)
  4850    ;I $L($G( OREVENT))  D
  4851   "RTN","ORW DX",82,0)
  4852    ;. S ONPA SS=0
  4853   "RTN","ORW DX",83,0)
  4854    ;. S OREV TYPE=$$TYP E^OREVNTX( OREVENT)
  4855   "RTN","ORW DX",84,0)
  4856    ;. I OREV TYPE="T" D  ISPASS^OR EVNTX1(.ON PASS,+OREV ENT,"T")
  4857   "RTN","ORW DX",85,0)
  4858    ;. S ORCA T=$S(OREVT YPE="A":"I ",OREVTYPE ="T":"I",O NPASS=1:"O ",1:"O")
  4859   "RTN","ORW DX",86,0)
  4860    ;E  S ORC AT=$S($L($ P($G(^DPT( +ORVP,.1)) ,U)):"I",1 :"O")
  4861   "RTN","ORW DX",87,0)
  4862    ;======== ========== ========== ========== ========== =====
  4863   "RTN","ORW DX",88,0)
  4864    I DLG="PS  MEDS" S O RWP94=1 D
  4865   "RTN","ORW DX",89,0)
  4866    . I ORIT= $O(^ORD(10 1.41,"AB", "PSO SUPPL Y",0)) S D LG="PSO SU PPLY"
  4867   "RTN","ORW DX",90,0)
  4868    . I ORIT= $O(^ORD(10 1.41,"AB", "PSO OERR" ,0)) S DLG ="PSO OERR "
  4869   "RTN","ORW DX",91,0)
  4870    . I ORIT= $O(^ORD(10 1.41,"AB", "PSJ OR PA T OE",0))  S DLG="PSJ  OR PAT OE "
  4871   "RTN","ORW DX",92,0)
  4872    I DLG="PS O OERR"!(D LG="PSO SU PPLY") S O RCAT="O" I  $G(OREVEN T("EFFECTI VE")) D
  4873   "RTN","ORW DX",93,0)
  4874    . S ORDIA LOG($O(^OR D(101.41," B","OR GTX  START DAT E"_$S($G(O RWP94):"/T IME",1:"") ,0)),1)=OR EVENT("EFF ECTIVE")
  4875   "RTN","ORW DX",94,0)
  4876    I DLG="PS O OERR" D
  4877   "RTN","ORW DX",95,0)
  4878    . N DRUGP RMT,OIPRMT ,ORDRUG,OR OI
  4879   "RTN","ORW DX",96,0)
  4880    . S DRUGP RMT=+$O(^O RD(101.41, "B","OR GT X DISPENSE  DRUG",0))
  4881   "RTN","ORW DX",97,0)
  4882    . S ORDRU G=$G(ORDIA LOG(DRUGPR MT,1))
  4883   "RTN","ORW DX",98,0)
  4884    . I ORDRU G,$$ISSUPP LY^ORUTL3( ORDRUG) D
  4885   "RTN","ORW DX",99,0)
  4886    . . S ORD G=+$O(^ORD (100.98,"B ","SUPPLIE S/DEVICES" ,0))
  4887   "RTN","ORW DX",100,0)
  4888    . S OIPRM T=+$O(^ORD (101.41,"B ","OR GTX  ORDERABLE  ITEM",0))
  4889   "RTN","ORW DX",101,0)
  4890    . S OROI= $G(ORDIALO G(OIPRMT,1 ))
  4891   "RTN","ORW DX",102,0)
  4892    . I 'ORDR UG,OROI,$$ ISOISPLY^O RUTL3(OROI ) D
  4893   "RTN","ORW DX",103,0)
  4894    . . S ORD G=+$O(^ORD (100.98,"B ","SUPPLIE S/DEVICES" ,0))
  4895   "RTN","ORW DX",104,0)
  4896    I DLG="PS J OR PAT O E" S ORCAT ="I"
  4897   "RTN","ORW DX",105,0)
  4898    I DLG="PS J OR CLINI C OE" S OR CAT="I"
  4899   "RTN","ORW DX",106,0)
  4900    I DLG="CL INIC OR PA T FLUID OE " S ORCAT= "I"
  4901   "RTN","ORW DX",107,0)
  4902    S:DLG="FH W1" ORCAT= "I" S:DLG? 1"FHW "2.7 U1" MEAL"  ORCAT="O"
  4903   "RTN","ORW DX",108,0)
  4904    S ORVP=OR VP_";DPT(" ,ORL(2)=OR L_";SC(",O RL=ORL(2)
  4905   "RTN","ORW DX",109,0)
  4906    I ORDG=$O (^ORD(100. 98,"B","LA B",0)) D   ;use secti on
  4907   "RTN","ORW DX",110,0)
  4908    . N OI,SU B S OI=+$G (ORDIALOG( $$PTR^ORCD ("OR GTX O RDERABLE I TEM"),1))
  4909   "RTN","ORW DX",111,0)
  4910    . S SUB=$ P($G(^ORD( 101.43,OI, "LR")),U,6 ),ORDG=$$D GRP^ORMLR( SUB)
  4911   "RTN","ORW DX",112,0)
  4912    K:'ORDG O RDG K:'ORI T ORIT ; D grp & Quic k must be  non-zero
  4913   "RTN","ORW DX",113,0)
  4914    M ORCHECK =ORDIALOG( "ORCHECK")  K ORDIALO G("ORCHECK ")
  4915   "RTN","ORW DX",114,0)
  4916    S ORDIALO G=$O(^ORD( 101.41,"AB ",DLG,0))
  4917   "RTN","ORW DX",115,0)
  4918    I 'ORDIAL OG S ORDIA LOG=$O(^OR D(101.41," B",DLG,0))
  4919   "RTN","ORW DX",116,0)
  4920    I $D(ORDI ALOG("ORLE AD")) S OR LEAD=ORDIA LOG("ORLEA D")
  4921   "RTN","ORW DX",117,0)
  4922    I $D(ORDI ALOG("ORTR AIL")) S O RTRAIL=ORD IALOG("ORT RAIL")
  4923   "RTN","ORW DX",118,0)
  4924    D GETDLG1 ^ORCD(ORDI ALOG)
  4925   "RTN","ORW DX",119,0)
  4926    I $L(ORCA TFN) S ORC AT=ORCATFN
  4927   "RTN","ORW DX",120,0)
  4928    I $G(ORWP 94) D
  4929   "RTN","ORW DX",121,0)
  4930    . N SIGPR MT S SIGPR MT=$O(^ORD (101.41,"B ","OR GTX  SIG",0))
  4931   "RTN","ORW DX",122,0)
  4932    . N INSPR MT S INSPR MT=$O(^ORD (101.41,"B ","OR GTX  INSTRUCTIO NS",0))
  4933   "RTN","ORW DX",123,0)
  4934    . I $L($G (ORDIALOG( SIGPRMT,1) )) S ORDIA LOG(INSPRM T,"FORMAT" )="@"
  4935   "RTN","ORW DX",124,0)
  4936    . I ORCAT ="O" S ORP KG=$O(^DIC (9.4,"C"," PSO",0))
  4937   "RTN","ORW DX",125,0)
  4938    . I ORCAT ="I" S ORP KG=$O(^DIC (9.4,"C"," PSJ",0))
  4939   "RTN","ORW DX",126,0)
  4940    S ORSRC=$ G(ORSRC)
  4941   "RTN","ORW DX",127,0)
  4942    D DELPI^O RWDX1 ;del ete empty  PI
  4943   "RTN","ORW DX",128,0)
  4944    I $G(ORIF N)="" D  ;  new order
  4945   "RTN","ORW DX",129,0)
  4946    . D EN^OR CSAVE
  4947   "RTN","ORW DX",130,0)
  4948    . S REC=" " I ORIFN  D GETBYIFN ^ORWORR(.R EC,ORIFN)
  4949   "RTN","ORW DX",131,0)
  4950    . I '$D(^ TMP("ORECA LL",$J,ORD IALOG)) M  ^TMP("OREC ALL",$J,OR DIALOG)=OR DIALOG
  4951   "RTN","ORW DX",132,0)
  4952    . D COMP^ ORMBLDOR(+ $G(ORIFN))  ;Sep 28,  2015 - PB  - modified  to trigge r an unsol icited syn c action
  4953   "RTN","ORW DX",133,0)
  4954    E  D
  4955   "RTN","ORW DX",134,0)
  4956    . N OR0
  4957   "RTN","ORW DX",135,0)
  4958    . S OR0=$ G(^OR(100, +ORIFN,0)) ,ORSTS=$P( $G(^(3)),U ,3),ORDG=$ P(OR0,U,11 )
  4959   "RTN","ORW DX",136,0)
  4960    . I $L($P (OR0,U,17) ),ORSTS=10  S OREVENT =$P(OR0,U, 17),OREVEN T("TS")=$P (OR0,U,13)
  4961   "RTN","ORW DX",137,0)
  4962    . D XX^OR CSAVE ; ed it order
  4963   "RTN","ORW DX",138,0)
  4964    . D COMP^ ORMBLDOR(+ $G(ORIFN))  ;Sep 28,  2015 - PB  - modified  to trigge r an unsol icited syn c action
  4965   "RTN","ORW DX",139,0)
  4966    . S REC=" " S ORIFN= +ORIFN_";" _ORDA D GE TBYIFN^ORW ORR(.REC,O RIFN)
  4967   "RTN","ORW DX",140,0)
  4968    I SENDMSG  D
  4969   "RTN","ORW DX",141,0)
  4970    .S MSGCAP T("ORIGINA L IEN")=$G (ORIFN)
  4971   "RTN","ORW DX",142,0)
  4972    .D MSG^OR UTL5(REC,. MSGCAPT)
  4973   "RTN","ORW DX",143,0)
  4974    .;M ^XTMP ("AGP ORDE R TEST")=M SGCAPT
  4975   "RTN","ORW DX",144,0)
  4976    D:DLG="GM RCOR CONSU LT" CHKAUT O^ORCSLT
  4977   "RTN","ORW DX",145,0)
  4978    Q
  4979   "RTN","ORW DX",146,0)
  4980   SENDED(ORW LST,ORIENS ,TS,LOC) ;  Release E DOs to svc
  4981   "RTN","ORW DX",147,0)
  4982    N OK,ORVP ,ORWERR,OR SIGST,ORDA ,ORNATURE, ORIX,X,PTE VT,ORIFN,J ,EVENT,LOC K,OR3
  4983   "RTN","ORW DX",148,0)
  4984    S ORWERR= "",ORIX=0, LOC=LOC_"; SC("
  4985   "RTN","ORW DX",149,0)
  4986    F  S ORIX =$O(ORIENS (ORIX)) Q: 'ORIX  D   Q:ORWERR]" "
  4987   "RTN","ORW DX",150,0)
  4988    . S (ORIF N,ORWLST(O RIX))=ORIE NS(ORIX)
  4989   "RTN","ORW DX",151,0)
  4990    . S PTEVT =$P(^OR(10 0,+ORIFN,0 ),U,17)
  4991   "RTN","ORW DX",152,0)
  4992    . I PTEVT  D
  4993   "RTN","ORW DX",153,0)
  4994    .. I $D(E VENT(PTEVT )) S LOCK= 1 Q
  4995   "RTN","ORW DX",154,0)
  4996    .. S LOCK =$$LCKEVT^ ORX2(PTEVT ) S:LOCK E VENT(PTEVT )=""
  4997   "RTN","ORW DX",155,0)
  4998    . I 'LOCK  S ORWERR= "1^delayed  event is  locked - a nother use r is proce ssing orde rs for thi s event" S  ORWLST(OR IX)=ORWLST (ORIX)_"^E ^"_ORWERR  Q
  4999   "RTN","ORW DX",156,0)
  5000    . S ORDA= $P(ORIFN," ;",2) S:'O RDA ORDA=1
  5001   "RTN","ORW DX",157,0)
  5002    . S ORVP= $P($G(^OR( 100,+ORIFN ,0)),U,2)
  5003   "RTN","ORW DX",158,0)
  5004    . I $D(^O R(100,+ORI FN,8,ORDA, 0)) D
  5005   "RTN","ORW DX",159,0)
  5006    .. S ORSI GST=$P($G( ^(0)),U,4) ,ORNATURE= $P($G(^(0) ),U,12) ;n aked refer ences refe r to OR(10 0,+ORIFN,8 ,ORDA on l ine above
  5007   "RTN","ORW DX",160,0)
  5008    . S OK=$$ LOCK1^ORX2 (ORIFN) I  'OK S ORWE RR="1^"_$P (OK,U,2)
  5009   "RTN","ORW DX",161,0)
  5010    . I OK,$G (LOCK) D
  5011   "RTN","ORW DX",162,0)
  5012    .. S OR3= $G(^OR(100 ,+ORIFN,3) ) I $P(OR3 ,"^",3)'=1 0!($P(OR3, "^",9)]"")  D UNLK1^O RX2(ORIENS (ORIX)) Q   ;order al ready rele ased or ha s a parent
  5013   "RTN","ORW DX",163,0)
  5014    .. S:$G(L OC) $P(^OR (100,+ORIF N,0),U,10) =LOC ;set  location
  5015   "RTN","ORW DX",164,0)
  5016    .. S:$G(T S) $P(^OR( 100,+ORIFN ,0),U,13)= TS ;set sp ecialty
  5017   "RTN","ORW DX",165,0)
  5018    .. D EN2^ ORCSEND(OR IENS(ORIX) ,ORSIGST,O RNATURE,.O RWERR),UNL K1^ORX2(OR IENS(ORIX) ) ;add ,LO CK to if s tatement f or 195
  5019   "RTN","ORW DX",166,0)
  5020    . I $L(OR WERR) S OR WLST(ORIX) =ORWLST(OR IX)_"^E^"_ ORWERR Q
  5021   "RTN","ORW DX",167,0)
  5022    . E  D
  5023   "RTN","ORW DX",168,0)
  5024    .. S PTEV T=$P($G(^O R(100,+ORI ENS(ORIX), 0)),U,17)
  5025   "RTN","ORW DX",169,0)
  5026    .. D:$$TY PE^OREVNTX (PTEVT)="M " SAVE^ORM EVNT1(ORIE NS(ORIX),P TEVT,2)
  5027   "RTN","ORW DX",170,0)
  5028    . S X="RS "
  5029   "RTN","ORW DX",171,0)
  5030    . S $P(OR WLST(ORIX) ,U,2)=X
  5031   "RTN","ORW DX",172,0)
  5032    S J=0 F   S J=$O(EVE NT(J)) Q:' +J  D UNLE VT^ORX2(J)  ;195
  5033   "RTN","ORW DX",173,0)
  5034    Q
  5035   "RTN","ORW DX",174,0)
  5036   SEND(ORWLS T,DFN,ORNP ,ORL,ES,OR WREC) ; Si gn
  5037   "RTN","ORW DX",175,0)
  5038    ; DFN=Pat ient, ORNP =Provider,  ORL=Locat ion, ES=En crypted ES  code
  5039   "RTN","ORW DX",176,0)
  5040    ; ORWREC( n)=ORIFN;A ction^Sign ature Sts^ Release St s^Nature o f Order
  5041   "RTN","ORW DX",177,0)
  5042   SEND1 N OR VP,ORWI,OR WERR,ORWRE L,ORWSIG,O RWNATR,ORD ERID,ORBEF ,ORLR,ORLA B,X,I
  5043   "RTN","ORW DX",178,0)
  5044    S ORVP=DF N_";DPT(", ORL=ORL_"; SC(",ORL(2 )=ORL,ORWL ST=0
  5045   "RTN","ORW DX",179,0)
  5046    F I="LR", "VBEC" S X =+$O(^DIC( 9.4,"C",I, 0)) S:X OR LR(X)=1
  5047   "RTN","ORW DX",180,0)
  5048    S ORWI=0  F  S ORWI= $O(ORWREC( ORWI)) Q:' ORWI  D
  5049   "RTN","ORW DX",181,0)
  5050    . S X=ORW REC(ORWI), ORWERR=""
  5051   "RTN","ORW DX",182,0)
  5052    . S ORDER ID=$P(X,U) ,ORWSIG=$P (X,U,2),OR WREL=$P(X, U,3),ORWNA TR=$P(X,U, 4)
  5053   "RTN","ORW DX",183,0)
  5054    . S ORBEF =0
  5055   "RTN","ORW DX",184,0)
  5056    . I '$D(^ OR(100,+OR DERID,0))  Q
  5057   "RTN","ORW DX",185,0)
  5058    . I $D(^O R(100,+ORD ERID,8,+$P (ORDERID," ;",2),0))  S ORBEF=$P (^OR(100,+ ORDERID,8, +$P(ORDERI D,";",2),0 ),U,15)
  5059   "RTN","ORW DX",186,0)
  5060    . S:$D(^O R(100,+ORD ERID,8,+$P (ORDERID," ;",2),0))  ORWNATR=$S ($P(^OR(10 0,+ORDERID ,8,+$P(ORD ERID,";",2 ),0),"^",4 )=3:"",1:O RWNATR)
  5061   "RTN","ORW DX",187,0)
  5062    . S ORWER R=$$CHKACT ^ORWDXR(OR DERID,ORWS IG,ORWREL, ORWNATR)
  5063   "RTN","ORW DX",188,0)
  5064    . I $L(OR WERR) S OR WERR="1^"_ ORWERR
  5065   "RTN","ORW DX",189,0)
  5066    . I '$L(O RWERR) D
  5067   "RTN","ORW DX",190,0)
  5068    .. I $G(O RLR(+$P(^O R(100,+ORD ERID,0),U, 14))),'$G( ORLAB) D   ; lab batc h start
  5069   "RTN","ORW DX",191,0)
  5070    ... I $L( $T(BHS^ORM BLD)) D BH S^ORMBLD(O RVP) S ORL AB=1
  5071   "RTN","ORW DX",192,0)
  5072    .. N OK S  OK=$$LOCK 1^ORX2(ORD ERID) I 'O K S ORWERR ="1^"_$P(O K,U,2)
  5073   "RTN","ORW DX",193,0)
  5074    .. I OK D  EN^ORCSEN D(ORDERID, "",ORWSIG, ORWREL,ORW NATR,"",.O RWERR),UNL K1^ORX2(OR DERID)
  5075   "RTN","ORW DX",194,0)
  5076    . S ORWLS T(ORWI)=OR DERID,X=""
  5077   "RTN","ORW DX",195,0)
  5078    . I $L(OR WERR) S OR WLST(ORWI) =ORWLST(OR WI)_"^E^"_ ORWERR Q
  5079   "RTN","ORW DX",196,0)
  5080    . I ORWRE L,((ORBEF= 10)!(ORBEF =11)),($P( ^OR(100,+O RDERID,3), U,3)'=10)  S X="R"
  5081   "RTN","ORW DX",197,0)
  5082    . I ORWSI G'=2 S X=X _"S"
  5083   "RTN","ORW DX",198,0)
  5084    . S $P(OR WLST(ORWI) ,U,2)=X
  5085   "RTN","ORW DX",199,0)
  5086    I $G(ORLA B) D BTS^O RMBLD(ORVP )
  5087   "RTN","ORW DX",200,0)
  5088    I $D(ORWL ST)>9 D
  5089   "RTN","ORW DX",201,0)
  5090    . N I,A
  5091   "RTN","ORW DX",202,0)
  5092    . S I=0 F   S I=$O(O RWLST(I))  Q:I=""  S  A=$G(ORWLS T(I)) I A[ "Invalid P rocedure,  Inactive,  no Imaging  Type" D S M^ORWDX2(A )
  5093   "RTN","ORW DX",203,0)
  5094     Q
  5095   "RTN","ORW DX",204,0)
  5096   DLGID(VAL, ORIFN) ; r eturn dlg  IEN for or der
  5097   "RTN","ORW DX",205,0)
  5098    S VAL=$P( ^OR(100,+O RIFN,0),U, 5)
  5099   "RTN","ORW DX",206,0)
  5100    S VAL=$S( $P(VAL,";" ,2)="ORD(1 01.41,":+V AL,1:0)
  5101   "RTN","ORW DX",207,0)
  5102    Q
  5103   "RTN","ORW DX",208,0)
  5104   FORMID(VAL ,ORIFN) ;  Base dlg F ormID for  an order
  5105   "RTN","ORW DX",209,0)
  5106    N DLG
  5107   "RTN","ORW DX",210,0)
  5108    S VAL=0,D LG=$P(^OR( 100,+ORIFN ,0),U,5)
  5109   "RTN","ORW DX",211,0)
  5110    Q:$P(DLG, ";",2)'="O RD(101.41, "
  5111   "RTN","ORW DX",212,0)
  5112    D FORMID^ ORWDXM(.VA L,+DLG)
  5113   "RTN","ORW DX",213,0)
  5114    Q
  5115   "RTN","ORW DX",214,0)
  5116   AGAIN(VAL, DLG) ; ret urn true t o keep dlg  for anoth er order
  5117   "RTN","ORW DX",215,0)
  5118    S VAL=''$ P($G(^ORD( 101.41,DLG ,0)),U,9)
  5119   "RTN","ORW DX",216,0)
  5120    Q
  5121   "RTN","ORW DX",217,0)
  5122   DGRP(VAL,D LG) ; Disp lay grp po inter for  a dlg
  5123   "RTN","ORW DX",218,0)
  5124    S DLG=$S( $E(DLG)="` ":+$P(DLG, "`",2),1:$ O(^ORD(101 .41,"AB",D LG,0))) ;k cm
  5125   "RTN","ORW DX",219,0)
  5126    S VAL=$P( $G(^ORD(10 1.41,DLG,0 )),U,5)
  5127   "RTN","ORW DX",220,0)
  5128    Q
  5129   "RTN","ORW DX",221,0)
  5130   DGNM(VAL,N M) ; Displ ay grp poi nter for n ame
  5131   "RTN","ORW DX",222,0)
  5132    S VAL=$O( ^ORD(100.9 8,"B",NM,0 ))
  5133   "RTN","ORW DX",223,0)
  5134    Q
  5135   "RTN","ORW DX",224,0)
  5136   WRLST(LST, LOC) ; Lis t of dlgs  for writin g orders
  5137   "RTN","ORW DX",225,0)
  5138    G WRLST1^ ORWDX1
  5139   "RTN","ORW DX",226,0)
  5140   MSG(LST,IE N) ; Msg t ext for or derable it em
  5141   "RTN","ORW DX",227,0)
  5142    N I
  5143   "RTN","ORW DX",228,0)
  5144    S I=0 F   S I=$O(^OR D(101.43,I EN,8,I)) Q :I'>0  S L ST(I)=^(I, 0)
  5145   "RTN","ORW DX",229,0)
  5146    Q
  5147   "RTN","ORW DX",230,0)
  5148   DISMSG(VAL ,IEN) ; Di sabled mge  for order ing dlg
  5149   "RTN","ORW DX",231,0)
  5150    S VAL=$P( $G(^ORD(10 1.41,+IEN, 0)),U,3)
  5151   "RTN","ORW DX",232,0)
  5152    Q
  5153   "RTN","ORW DX",233,0)
  5154   LOCK(OK,DF N) ; Attem pt to lock  pt for or dering
  5155   "RTN","ORW DX",234,0)
  5156    S OK=$$LO CK^ORX2(DF N)
  5157   "RTN","ORW DX",235,0)
  5158    Q
  5159   "RTN","ORW DX",236,0)
  5160   UNLOCK(OK, DFN) ; Unl ock pt for  ordering
  5161   "RTN","ORW DX",237,0)
  5162    D UNLOCK^ ORX2(DFN)  S OK=1
  5163   "RTN","ORW DX",238,0)
  5164    Q
  5165   "RTN","ORW DX",239,0)
  5166   LOCKORD(OK ,ORIFN) ;  Attempt to  lock orde r
  5167   "RTN","ORW DX",240,0)
  5168    S OK=$$LO CK1^ORX2(O RIFN)
  5169   "RTN","ORW DX",241,0)
  5170    Q
  5171   "RTN","ORW DX",242,0)
  5172   UNLKORD(OK ,ORIFN) ;  Unlock ord er
  5173   "RTN","ORW DX",243,0)
  5174    D UNLK1^O RX2(ORIFN)  S OK=1
  5175   "RTN","ORW DX",244,0)
  5176    Q
  5177   "RTN","ORW DX",245,0)
  5178   UNLKOTH(OK ,ORIFN) ;  Unlock pt  not by thi s session
  5179   "RTN","ORW DX",246,0)
  5180    K ^XTMP(" ORPTLK-"_O RIFN) S OK =1
  5181   "RTN","ORW DX",247,0)
  5182    Q
  5183   "RTN","ORW DXA")
  5184   0^13^B1196 65285
  5185   "RTN","ORW DXA",1,0)
  5186   ORWDXA ; S LC/KCM/JLI  - Utilite s for Orde r Actions  ;12/21/17   07:23
  5187   "RTN","ORW DXA",2,0)
  5188    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**1 0,85,116,1 32,148,141 ,149,187,2 13,195,215 ,243,280,3 06,390,421 ,436,434,3 97**;Dec 1 7, 1997;Bu ild 17
  5189   "RTN","ORW DXA",3,0)
  5190    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  5191   "RTN","ORW DXA",4,0)
  5192    ;
  5193   "RTN","ORW DXA",5,0)
  5194    ;
  5195   "RTN","ORW DXA",6,0)
  5196   VALID(VAL, ORID,ACTIO N,ORNP,ORW NAT) ; Is  action val id for ord er?
  5197   "RTN","ORW DXA",7,0)
  5198    N DG,ORAC T,ORVP,ORV ER,ORIFN,P RTID S VAL ="",PRTID= 0
  5199   "RTN","ORW DXA",8,0)
  5200    I +ORID=0  S VAL="Th is order h as been de leted." Q
  5201   "RTN","ORW DXA",9,0)
  5202    I '$D(^OR (100,+ORID ,0)) S VAL ="This ord er has bee n deleted! " Q
  5203   "RTN","ORW DXA",10,0)
  5204    I ACTION= "XFR",'$L( $T(XFR^ORC ACT01)) S  ACTION="RW " ; for pr e-POE
  5205   "RTN","ORW DXA",11,0)
  5206    N ORNSS S  ORNSS=1
  5207   "RTN","ORW DXA",12,0)
  5208    I (ACTION ="RN") D V ALSCH^ORWN SS(.ORNSS, ORID)
  5209   "RTN","ORW DXA",13,0)
  5210    I ORNSS=0  S VAL="Th is order c ontains an  invalid a dministrat ion schedu le." Q
  5211   "RTN","ORW DXA",14,0)
  5212    I (ACTION ="RN") D I SVALIV^ORW DPS33(.VAL ,ORID,ACTI ON) I $L(V AL)>0 Q
  5213   "RTN","ORW DXA",15,0)
  5214    S ORIFN=O RID,ORVP=$ P(^OR(100, +ORID,0),U ,2)  ; ORC ACT0 expec ts
  5215   "RTN","ORW DXA",16,0)
  5216    I (ACTION ="RN") D   Q:$L(VAL)
  5217   "RTN","ORW DXA",17,0)
  5218    . N DLG S  DLG=$P(^O R(100,+ORI D,0),U,5)  Q:DLG'[";O RD(101.41, "
  5219   "RTN","ORW DXA",18,0)
  5220    . I $G(^O RD(101.41, +DLG,3))'[ "PROVIDER^ ORCDPSIV"  Q
  5221   "RTN","ORW DXA",19,0)
  5222    . D AUTH^ ORWDPS32(. VAL,ORNP,+ DLG)
  5223   "RTN","ORW DXA",20,0)
  5224    . I VAL S  VAL=$P(VA L,U,2)
  5225   "RTN","ORW DXA",21,0)
  5226    . E  S VA L=""
  5227   "RTN","ORW DXA",22,0)
  5228    S ORVER=$ S(ACTION=" CR":"R",$D (^XUSEC("O RELSE",DUZ )):"N",$D( ^XUSEC("OR EMAS",DUZ) ):"C",1:"^ ")
  5229   "RTN","ORW DXA",23,0)
  5230    I ACTION= "CR" S ACT ION="VR"
  5231   "RTN","ORW DXA",24,0)
  5232    I (ACTION ="ES")!(AC TION="OC") !(ACTION=" RS") S ORA CT=ACTION  ; why not  defined???
  5233   "RTN","ORW DXA",25,0)
  5234    I (ACTION ="VR"),'($ D(^XUSEC(" ORELSE",DU Z))!$D(^XU SEC("OREMA S",DUZ)))  D  Q
  5235   "RTN","ORW DXA",26,0)
  5236    . S VAL=" You are no t authoriz ed to veri fy these o rders."
  5237   "RTN","ORW DXA",27,0)
  5238    I $L(VAL)  Q
  5239   "RTN","ORW DXA",28,0)
  5240    N OIIEN,I SIV,IVOD
  5241   "RTN","ORW DXA",29,0)
  5242    S (ISIV,O IIEN,IVOD) =0
  5243   "RTN","ORW DXA",30,0)
  5244    I (ACTION ="RW")!(AC TION="XX") !(ACTION=" XFR") D  Q :$L(VAL)
  5245   "RTN","ORW DXA",31,0)
  5246    . S ISIV= $P(^OR(100 ,+ORID,0), U,11)
  5247   "RTN","ORW DXA",32,0)
  5248    . I ISIV, ($P(^ORD(1 00.98,ISIV ,0),U,3)=" IV RX") S  IVOD=1
  5249   "RTN","ORW DXA",33,0)
  5250    . D:'IVOD  GTORITM^O RWDXR(.OII EN,+ORID)
  5251   "RTN","ORW DXA",34,0)
  5252    . D:OIIEN  ISACTOI(. VAL,OIIEN)  I $L(VAL) >0 Q
  5253   "RTN","ORW DXA",35,0)
  5254    . N DLG,F RM,A,ORDG, I,TYPE,B
  5255   "RTN","ORW DXA",36,0)
  5256    . S A=^OR (100,+ORID ,0),DLG=$P (A,U,5),OR DG=$P(A,"^ ",11),FRM= 0
  5257   "RTN","ORW DXA",37,0)
  5258    . I $P(DL G,";",2)'= "ORD(101.4 1," S DLG= 0
  5259   "RTN","ORW DXA",38,0)
  5260    . I DLG D  FORMID^OR WDXM(.FRM, +DLG)
  5261   "RTN","ORW DXA",39,0)
  5262    . I '(DLG &FRM) D
  5263   "RTN","ORW DXA",40,0)
  5264    . . S VAL ="Copy & C hange are  not implem ented for  this order  that pred ates CPRS. "
  5265   "RTN","ORW DXA",41,0)
  5266    . I ACTIO N="XX" D   ;PATLOC is  being pas sed in and  not defin ed in this  routine
  5267   "RTN","ORW DXA",42,0)
  5268    .. F I="U NIT DOSE M EDICATIONS ","INPATIE NT MEDICAT IONS","IV  MEDICATION S" S A=$O( ^ORD(100.9 8,"B",I,"" )) I A S A (A)=""
  5269   "RTN","ORW DXA",43,0)
  5270    .. S TYPE ="" I $G(P ATLOC) S T YPE=$P(^SC (PATLOC,0) ,"^",3)
  5271   "RTN","ORW DXA",44,0)
  5272    .. I $D(A (ORDG)),TY PE="C" S B =1 D SDAUT HCL^SDAMA2 03(PATLOC, .B) I B=1  S VAL="Can not use a  Clinic Loc ation for  this chang e. Please  check your  encounter  location. "
  5273   "RTN","ORW DXA",45,0)
  5274    S DG=$P(^ OR(100,+OR ID,0),U,11 )
  5275   "RTN","ORW DXA",46,0)
  5276    I DG,($P( ^ORD(100.9 8,DG,0),U, 3)="CSDAM" ),$P($G(^O R(100,+ORI D,3)),U,3) =9 S VAL=" Partial Re turn to Cl inic Order s cannot b e disconti nued." Q
  5277   "RTN","ORW DXA",47,0)
  5278    N OREBUIL D
  5279   "RTN","ORW DXA",48,0)
  5280    ;I (ACTIO N="RW")!(A CTION="XFR ")!(ACTION ="RN") D I SVALIV^ORW DPS33(.VAL ,ORID,ACTI ON) I $L(V AL)>0 Q
  5281   "RTN","ORW DXA",49,0)
  5282    I $$VALID ^ORCACT0(O RID,ACTION ,.VAL,$G(O RWNAT)) S  VAL="" ; V AL=error
  5283   "RTN","ORW DXA",50,0)
  5284    I ACTION= "RN",$$UPC TCHK(ORID)  S VAL="Ca nnot renew  this orde r due to a n illegal  character  ""^"" in t he comment s or patie nt instruc tions."
  5285   "RTN","ORW DXA",51,0)
  5286    I ACTION= "RW",$$UPC TCHK(ORID)  S VAL="Ca nnot copy  this order  due to an  illegal c haracter " "^"" in th e comments  or patien t instruct ions."
  5287   "RTN","ORW DXA",52,0)
  5288    Q
  5289   "RTN","ORW DXA",53,0)
  5290    ;
  5291   "RTN","ORW DXA",54,0)
  5292   HOLD(REC,O RID,ORNP)  ; Place or der on hol d
  5293   "RTN","ORW DXA",55,0)
  5294    N ACTDA
  5295   "RTN","ORW DXA",56,0)
  5296    S ACTDA=$ $ACTION^OR CSAVE("HD" ,+ORID,ORN P)
  5297   "RTN","ORW DXA",57,0)
  5298    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  5299   "RTN","ORW DXA",58,0)
  5300    Q
  5301   "RTN","ORW DXA",59,0)
  5302   UNHOLD(REC ,ORID,ORNP ) ; Releas e order fr om hold
  5303   "RTN","ORW DXA",60,0)
  5304    N ACTDA
  5305   "RTN","ORW DXA",61,0)
  5306    S ACTDA=$ $ACTION^OR CSAVE("RL" ,+ORID,ORN P)
  5307   "RTN","ORW DXA",62,0)
  5308    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  5309   "RTN","ORW DXA",63,0)
  5310    Q
  5311   "RTN","ORW DXA",64,0)
  5312   DC(REC,ORI D,ORNP,ORL ,REASON,DC ORIG,ISNEW ORD) ; Dis continue/C ancel/Dele te order
  5313   "RTN","ORW DXA",65,0)
  5314    N NATURE, CREATE,PRI NT,STATUS, ACTDA,SIGS TS
  5315   "RTN","ORW DXA",66,0)
  5316    N X3,X8,C URRACT
  5317   "RTN","ORW DXA",67,0)
  5318    Q:'+ORID
  5319   "RTN","ORW DXA",68,0)
  5320    I $G(DCOR IG)="" S D CORIG=0
  5321   "RTN","ORW DXA",69,0)
  5322    S CURRACT =0
  5323   "RTN","ORW DXA",70,0)
  5324    S ORL(2)= ORL_";SC(" ,ORL=ORL(2 ),NATURE=" "
  5325   "RTN","ORW DXA",71,0)
  5326    I REASON  S NATURE=$ P(^ORD(100 .02,$P(^OR D(100.03,R EASON,0),U ,7),0),U,2 )
  5327   "RTN","ORW DXA",72,0)
  5328    S:NATURE= "" NATURE= "W"  ; S:O RNP=DUZ NA TURE="E"
  5329   "RTN","ORW DXA",73,0)
  5330    ;change t he way cre ate work t o support  forcing si gnature fo r all DC
  5331   "RTN","ORW DXA",74,0)
  5332    ;reasons
  5333   "RTN","ORW DXA",75,0)
  5334    S CREATE= 1,PRINT=$$ PRINT^ORCA CT2(NATURE )
  5335   "RTN","ORW DXA",76,0)
  5336    ;S CREATE =$$CREATE^ ORX1(NATUR E)
  5337   "RTN","ORW DXA",77,0)
  5338    S X3=$G(^ OR(100,+OR ID,3))
  5339   "RTN","ORW DXA",78,0)
  5340    S CURRACT =$P(X3,U,7 ) S:CURRAC T<1 CURRAC T=+$O(^OR( 100,+ORID, 8,"?"),-1)
  5341   "RTN","ORW DXA",79,0)
  5342    I '$D(^OR (100,+ORID ,8,+$P(ORI D,";",2),0 )) D
  5343   "RTN","ORW DXA",80,0)
  5344    . S X8=$G (^OR(100,+ ORID,8,CUR RACT,0))
  5345   "RTN","ORW DXA",81,0)
  5346    . S SIGST S=$P(X8,U, 4)
  5347   "RTN","ORW DXA",82,0)
  5348    . S $P(OR ID,";",2)= CURRACT
  5349   "RTN","ORW DXA",83,0)
  5350    E  D
  5351   "RTN","ORW DXA",84,0)
  5352    . S X8=^O R(100,+ORI D,8,+$P(OR ID,";",2), 0)
  5353   "RTN","ORW DXA",85,0)
  5354    . S SIGST S=$P(X8,U, 4)
  5355   "RTN","ORW DXA",86,0)
  5356    I '$D(SIG STS) S SIG STS=1
  5357   "RTN","ORW DXA",87,0)
  5358    S STATUS= $P($G(^OR( 100,+ORID, 8,+$P(ORID ,";",2),0) ),U,15)
  5359   "RTN","ORW DXA",88,0)
  5360    I (STATUS =10)!(STAT US=11) D   Q   ; dele te/cancel  unreleased  order
  5361   "RTN","ORW DXA",89,0)
  5362    . N RPLOR D
  5363   "RTN","ORW DXA",90,0)
  5364    . S RPLOR D=$P($G(^O R(100,+ORI D,3)),U,5)     ; repl aced order
  5365   "RTN","ORW DXA",91,0)
  5366    . D GETBY IFN^ORWORR (.REC,ORID )
  5367   "RTN","ORW DXA",92,0)
  5368    . I STATU S=10,($P(X 8,U,4)'=2)  D  ; CANC EL signed,  delayed,  unreleased
  5369   "RTN","ORW DXA",93,0)
  5370    . . ; tak en from CL RDLY^ORCAC T2
  5371   "RTN","ORW DXA",94,0)
  5372    . . I REA SON D SET^ ORCACT2(+O RID,NATURE ,REASON,,D CORIG)
  5373   "RTN","ORW DXA",95,0)
  5374    . . I 'RE ASON D SET ^ORCACT2(+ ORID,"M"," ","Delayed  Order Can celled",DC ORIG)
  5375   "RTN","ORW DXA",96,0)
  5376    . . D STA TUS^ORCSAV E2(+ORID,1 3) S $P(^O R(100,+ORI D,8,1,0),U ,15)=13
  5377   "RTN","ORW DXA",97,0)
  5378    . . ;D CO MP^ORMBLDO R(+$G(ORID )) ;  modi fied to tr igger an u nsolicited  sync acti on when a  signed ord er is disc ontinued
  5379   "RTN","ORW DXA",98,0)
  5380    . E  D                              ; CANC EL OR DELE TE unsigne d, unrelea sed
  5381   "RTN","ORW DXA",99,0)
  5382    . . I $P( X8,U,2)="D C" K ^OR(1 00,+ORID,6 )
  5383   "RTN","ORW DXA",100,0 )
  5384    . . ; del ete fwd pt r to order  about to  be deleted
  5385   "RTN","ORW DXA",101,0 )
  5386    . . I RPL ORD,$P(X8, U,2)="NW"  S $P(^OR(1 00,RPLORD, 3),U,6)=""
  5387   "RTN","ORW DXA",102,0 )
  5388    . . ; del ete ptr to  order in  Patient Ev ent file # 100.2
  5389   "RTN","ORW DXA",103,0 )
  5390    . . N EVT  S EVT=$P( $G(^OR(100 ,+ORID,0)) ,U,17) I E VT,EVT=+$O (^ORE(100. 2,"AO",+OR ID,0)) S $ P(^ORE(100 .2,EVT,0), U,4)="" K  ^ORE(100.2 ,"AO",+ORI D,EVT)
  5391   "RTN","ORW DXA",104,0 )
  5392    . . I $G( ISNEWORD)  D POST^HMP EVNT(+$P(^ OR(100,+OR ID,0),U,2) ,"order",+ ORID,"@")  D
  5393   "RTN","ORW DXA",105,0 )
  5394    . . . ; D elete the  discontinu ed order i n HMP(8000 00, if the  order is  discontinu ed before  it is sign ed it is d eleted in  OR(100,
  5395   "RTN","ORW DXA",106,0 )
  5396    . . . ; w e need to  delete in  HMP(800000  as since  the order  number can  be reused  by OR(100
  5397   "RTN","ORW DXA",107,0 )
  5398    . . . N H DFN S HDFN =+$P(^OR(1 00,+ORID,0 ),U,2) I $ D(^HMP(800 000,$$SRVR NO^HMPOR(H DFN),1,HDF N,1,+ORID, 0)) D DELO RDR^HMPOR( +HDFN,+ORI D)
  5399   "RTN","ORW DXA",108,0 )
  5400    . . I $G( ISNEWORD)  D DELETE^O RCSAVE2(OR ID)
  5401   "RTN","ORW DXA",109,0 )
  5402    . . I '$G (ISNEWORD)  D
  5403   "RTN","ORW DXA",110,0 )
  5404    . . . ; U pdate acti on date/ti me in hmp  orders sub file
  5405   "RTN","ORW DXA",111,0 )
  5406    . . . N R SLT,VALS,H DFN
  5407   "RTN","ORW DXA",112,0 )
  5408    . . . S H DFN=+$P(^O R(100,+ORI D,0),U,2)
  5409   "RTN","ORW DXA",113,0 )
  5410    . . . S V ALS(.15)=$ $NOW^XLFDT
  5411   "RTN","ORW DXA",114,0 )
  5412    . . . D U PDTORDR^HM POR(.RSLT, .VALS,+ORI D,HDFN)
  5413   "RTN","ORW DXA",115,0 )
  5414    . . . ; h andle erro rs from UP DTORDR, Ca n't just q uit here
  5415   "RTN","ORW DXA",116,0 )
  5416    . . . ; T rigger uns olicited u pdate
  5417   "RTN","ORW DXA",117,0 )
  5418    . . . D P OST^HMPEVN T(+$P(^OR( 100,+ORID, 0),U,2),"o rder",+ORI D)
  5419   "RTN","ORW DXA",118,0 )
  5420    . . . ; N ow cancel  the order
  5421   "RTN","ORW DXA",119,0 )
  5422    . . . D C ANCEL^ORCS AVE2(ORID)
  5423   "RTN","ORW DXA",120,0 )
  5424    . I RPLOR D,'(SIGSTS =1) S ORID =RPLORD  ;  for Renew s & Change s, show re placed ord er
  5425   "RTN","ORW DXA",121,0 )
  5426    . I '$D(^ OR(100,+OR ID)) D
  5427   "RTN","ORW DXA",122,0 )
  5428    . . S $P( REC(1),U)= "~0",REC(2 )="tDELETE D: "_$E(RE C(2),2,245 )
  5429   "RTN","ORW DXA",123,0 )
  5430    . E  D
  5431   "RTN","ORW DXA",124,0 )
  5432    . . K REC
  5433   "RTN","ORW DXA",125,0 )
  5434    . . D GET BYIFN^ORWO RR(.REC,+O RID_";"_$P ($G(^OR(10 0,+ORID,3) ),U,7))
  5435   "RTN","ORW DXA",126,0 )
  5436    . S $P(RE C(1),U,14) =2 ; DCTyp e = deleti on
  5437   "RTN","ORW DXA",127,0 )
  5438    S ACTDA=$ $ACTION^OR CSAVE("DC" ,+ORID,ORN P)
  5439   "RTN","ORW DXA",128,0 )
  5440    D SET^ORC ACT2(+ORID ,NATURE,RE ASON,,DCOR IG)
  5441   "RTN","ORW DXA",129,0 )
  5442    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  5443   "RTN","ORW DXA",130,0 )
  5444    S $P(REC( 1),U,14)=$ S(CREATE:1 ,1:3)  ;DC Type - 1=N ewOrder, 3 =NewStatus
  5445   "RTN","ORW DXA",131,0 )
  5446    N PKG
  5447   "RTN","ORW DXA",132,0 )
  5448    S PKG=$P( $G(^OR(100 ,+ORID,0)) ,U,14)
  5449   "RTN","ORW DXA",133,0 )
  5450    S PKG=$$N MSP^ORCD(P KG)
  5451   "RTN","ORW DXA",134,0 )
  5452    I REASON= 16&(PKG="P S") D
  5453   "RTN","ORW DXA",135,0 )
  5454    . N XMB
  5455   "RTN","ORW DXA",136,0 )
  5456    . S XMB=" OR DRUG OR DER CANCEL LED"
  5457   "RTN","ORW DXA",137,0 )
  5458    . S XMB(1 )=$P($G(RE C(2)),"tDi scontinue" ,2),XMB(4) =$P($G(^VA (200,DUZ,0 )),U)
  5459   "RTN","ORW DXA",138,0 )
  5460    . S XMB(2 )=+ORID
  5461   "RTN","ORW DXA",139,0 )
  5462    . S XMB(3 )=+$P($G(^ OR(100,+OR ID,0)),U,2 )
  5463   "RTN","ORW DXA",140,0 )
  5464    . S XMB(3 )=$P($G(^D PT(XMB(3), 0)),U)
  5465   "RTN","ORW DXA",141,0 )
  5466    . D ^XMB
  5467   "RTN","ORW DXA",142,0 )
  5468    Q
  5469   "RTN","ORW DXA",143,0 )
  5470   DCREQIEN(V AL) ; Retu rn IEN for  Req Phys  Cancelled  reason
  5471   "RTN","ORW DXA",144,0 )
  5472    S VAL=$O( ^ORD(100.0 3,"S","REQ ",0))
  5473   "RTN","ORW DXA",145,0 )
  5474    Q
  5475   "RTN","ORW DXA",146,0 )
  5476   COMPLETE(R EC,ORID,ES CODE) ; Co mplete ord er (generi c)
  5477   "RTN","ORW DXA",147,0 )
  5478    ;N X S X= +$E($$NOW^ XLFDT,1,12 )
  5479   "RTN","ORW DXA",148,0 )
  5480    ;D DATES^ ORCSAVE2(+ ORID,,X)
  5481   "RTN","ORW DXA",149,0 )
  5482    ;D STATUS ^ORCSAVE2( +ORID,2)
  5483   "RTN","ORW DXA",150,0 )
  5484    ; validat e ESCode
  5485   "RTN","ORW DXA",151,0 )
  5486    D COMP^OR CSAVE2(ORI D)
  5487   "RTN","ORW DXA",152,0 )
  5488    D COMP^OR MBLDOR(ORI D)
  5489   "RTN","ORW DXA",153,0 )
  5490    D GETBYIF N^ORWORR(. REC,ORID)
  5491   "RTN","ORW DXA",154,0 )
  5492    D COMPLET E^ORUTL5(O RID)
  5493   "RTN","ORW DXA",155,0 )
  5494    Q
  5495   "RTN","ORW DXA",156,0 )
  5496   VERIFY(REC ,ORID,ESCO DE,ORVER)  ; Verify o rder
  5497   "RTN","ORW DXA",157,0 )
  5498    ; validat e ESCode
  5499   "RTN","ORW DXA",158,0 )
  5500    S ORVER=$ G(ORVER,$S ($D(^XUSEC ("ORELSE", DUZ)):"N", $D(^XUSEC( "OREMAS",D UZ)):"C",1 :U))
  5501   "RTN","ORW DXA",159,0 )
  5502    I ORVER'= U D
  5503   "RTN","ORW DXA",160,0 )
  5504    . N ORIFN ,ORES,ORI
  5505   "RTN","ORW DXA",161,0 )
  5506    . ; VERIF Y any repl aced order s:
  5507   "RTN","ORW DXA",162,0 )
  5508    . S ORIFN =ORID,ORES (ORIFN)=""  D REPLCD^ ORCACT1
  5509   "RTN","ORW DXA",163,0 )
  5510    . S ORI=" " F  S ORI =$O(ORES(O RI)) Q:ORI =""  D EN^ ORCSEND(OR I,"VR","", ""),UNLK1^ ORX2(+ORI) :ORI'=ORID  ;ORID loc ked prior
  5511   "RTN","ORW DXA",164,0 )
  5512    D GETBYIF N^ORWORR(. REC,ORID)
  5513   "RTN","ORW DXA",165,0 )
  5514    Q
  5515   "RTN","ORW DXA",166,0 )
  5516   ALERT(DUMM Y,ORID,ORD UZ) ; aler t user (OR DUZ) when  order (ORI D) resulte d
  5517   "RTN","ORW DXA",167,0 )
  5518    ;if no us er passed,  use order ing provid er:
  5519   "RTN","ORW DXA",168,0 )
  5520    I $G(ORDU Z)<1 S ORD UZ=+$$ORDE RER^ORQOR2 (+ORID)
  5521   "RTN","ORW DXA",169,0 )
  5522    I $L($G(O RDUZ))<1 S  ORDUZ=DUZ
  5523   "RTN","ORW DXA",170,0 )
  5524    S DUMMY=1 ,$P(^OR(10 0,+ORID,3) ,U,10)=ORD UZ
  5525   "RTN","ORW DXA",171,0 )
  5526    Q
  5527   "RTN","ORW DXA",172,0 )
  5528   FLAG(REC,O RIFN,OREAS ON,ORNP) ;  Flag orde r
  5529   "RTN","ORW DXA",173,0 )
  5530    ;variable  XMZ is no t defined  by this se ction, but  passed in  (if avail able)
  5531   "RTN","ORW DXA",174,0 )
  5532    N ORB,ORV P,DA,ORPS, ORNOW
  5533   "RTN","ORW DXA",175,0 )
  5534    S ORNOW=$ $NOW^XLFDT
  5535   "RTN","ORW DXA",176,0 )
  5536    D BULLETI N
  5537   "RTN","ORW DXA",177,0 )
  5538    S DA=$P(O RIFN,";",2 ),ORVP=+$P (^OR(100,+ ORIFN,0),U ,2)
  5539   "RTN","ORW DXA",178,0 )
  5540    K ^OR(100 ,+ORIFN,8, DA,3) S ^( 3)="1^"_$G (XMZ)_U_+$ E($$NOW^XL FDT,1,12)_ U_DUZ_U_OR EASON_$S($ G(ORNP):"^ ^^^"_+ORNP ,1:"")
  5541   "RTN","ORW DXA",179,0 )
  5542    D KILL^XM ,MSG^ORCFL AG(ORIFN)
  5543   "RTN","ORW DXA",180,0 )
  5544    S $P(^OR( 100,+ORIFN ,3),U)=ORN OW ; Last  Activity
  5545   "RTN","ORW DXA",181,0 )
  5546    I +$G(ORN P)<1 S ORN P=+$P($G(^ OR(100,+OR IFN,8,DA,0 )),U,3)
  5547   "RTN","ORW DXA",182,0 )
  5548    S ORB=+OR VP_U_+ORIF N_U_ORNP_" ^1" D EN^O CXOERR(ORB ) ; notifi cation
  5549   "RTN","ORW DXA",183,0 )
  5550    D GETBYIF N^ORWORR(. REC,ORIFN)
  5551   "RTN","ORW DXA",184,0 )
  5552    D HMPFLAG (+ORIFN,OR VP,ORNOW,D UZ,"F",ORE ASON,DA)
  5553   "RTN","ORW DXA",185,0 )
  5554    ;
  5555   "RTN","ORW DXA",186,0 )
  5556    Q
  5557   "RTN","ORW DXA",187,0 )
  5558   BULLETIN ;  flagged o rder bulle tin
  5559   "RTN","ORW DXA",188,0 )
  5560    ;variable s OREASON  and ORIFN  are assume d to be de fined by t he calling  process a nd
  5561   "RTN","ORW DXA",189,0 )
  5562    ;are neit her KILLed  or NEWed  in this se ction
  5563   "RTN","ORW DXA",190,0 )
  5564    N OR0,OR3 ,ORDTXT,XM B,XMY,XMDU Z,ORENT,BU LL,ORSRV,O RUSR
  5565   "RTN","ORW DXA",191,0 )
  5566    S OR0=$G( ^OR(100,+O RIFN,0)),O R3=$G(^(3) )
  5567   "RTN","ORW DXA",192,0 )
  5568    ;CLA - 3/ 21/96:
  5569   "RTN","ORW DXA",193,0 )
  5570    S ORUSR=+ $P(OR0,U,4 )
  5571   "RTN","ORW DXA",194,0 )
  5572    S ORSRV=$ G(^VA(200, ORUSR,5))  I +ORSRV>0  S ORSRV=$ P(ORSRV,U)
  5573   "RTN","ORW DXA",195,0 )
  5574    S ORENT=" USR.`"_ORU SR_"^SRV.` "_$G(ORSRV )_"^DIV^SY S^PKG"
  5575   "RTN","ORW DXA",196,0 )
  5576    S BULL=$$ GET^XPAR(O RENT,"ORB  FLAGGED OR DERS BULLE TIN",1,"Q" )
  5577   "RTN","ORW DXA",197,0 )
  5578    Q:$G(BULL )'="Y"   ; quit if pa rm val not  'Y'es
  5579   "RTN","ORW DXA",198,0 )
  5580    ;
  5581   "RTN","ORW DXA",199,0 )
  5582    S XMB="OR  FLAGGED O RDER",XMDU Z=DUZ,XMY( +$P(OR0,U, 4))=""
  5583   "RTN","ORW DXA",200,0 )
  5584    S XMB(1)= $P(^DPT(+$ P(OR0,U,2) ,0),U),XMB (2)=$P(^(0 ),U,9),XMB (3)="" ;sb  AGE
  5585   "RTN","ORW DXA",201,0 )
  5586    S XMB(4)= $$FMTE^XLF DT($P(OR0, U,7))
  5587   "RTN","ORW DXA",202,0 )
  5588    D TEXT^OR Q12(.ORDTX T,+ORIFN,8 0)
  5589   "RTN","ORW DXA",203,0 )
  5590    S XMB(5)= $G(ORDTXT( 1)),XMB(6) =$G(ORDTXT (2)),XMB(7 )=$G(ORDTX T(3))
  5591   "RTN","ORW DXA",204,0 )
  5592    S XMB(8)= $$FMTE^XLF DT($P(OR0, U,8)),XMB( 9)=$$FMTE^ XLFDT($P(O R0,U,9)),X MB(10)=ORE ASON
  5593   "RTN","ORW DXA",205,0 )
  5594    S XMB(11) =$P($G(^OR D(100.01,+ $P(OR3,U,3 ),0)),U)
  5595   "RTN","ORW DXA",206,0 )
  5596    D EN^XMB
  5597   "RTN","ORW DXA",207,0 )
  5598    Q
  5599   "RTN","ORW DXA",208,0 )
  5600   UNFLAG(REC ,ORIFN,ORE ASON) ; Un flag order
  5601   "RTN","ORW DXA",209,0 )
  5602    N DA,ORB, ORNP,ORVP, ORPS,ORNOW
  5603   "RTN","ORW DXA",210,0 )
  5604    S ORNOW=$ $NOW^XLFDT
  5605   "RTN","ORW DXA",211,0 )
  5606    S DA=$P(O RIFN,";",2 ),ORVP=+$P (^OR(100,+ ORIFN,0),U ,2)
  5607   "RTN","ORW DXA",212,0 )
  5608    S $P(^OR( 100,+ORIFN ,8,DA,3),U )=0,$P(^(3 ),U,6,8)=+ $E($$NOW^X LFDT,1,12) _U_DUZ_U_O REASON D M SG^ORCFLAG (ORIFN)
  5609   "RTN","ORW DXA",213,0 )
  5610    S $P(^OR( 100,+ORIFN ,3),U)=ORN OW  ; Last  Activity
  5611   "RTN","ORW DXA",214,0 )
  5612    S ORNP=+$ P($G(^OR(1 00,+ORIFN, 8,DA,0)),U ,3)
  5613   "RTN","ORW DXA",215,0 )
  5614    S ORB=+OR VP_U_+ORIF N_U_ORNP_" ^0" D EN^O CXOERR(ORB ) ; notifi cation
  5615   "RTN","ORW DXA",216,0 )
  5616    D GETBYIF N^ORWORR(. REC,ORIFN)
  5617   "RTN","ORW DXA",217,0 )
  5618    D HMPFLAG (+ORIFN,OR VP,ORNOW,D UZ,"U",ORE ASON,DA)
  5619   "RTN","ORW DXA",218,0 )
  5620    Q
  5621   "RTN","ORW DXA",219,0 )
  5622   FLAGTXT(LS T,ORID) ;  flag reaso n
  5623   "RTN","ORW DXA",220,0 )
  5624    N FLAG
  5625   "RTN","ORW DXA",221,0 )
  5626    S FLAG=$G (^OR(100,+ ORID,8,$P( ORID,";",2 ),3))
  5627   "RTN","ORW DXA",222,0 )
  5628    S LST(1)= "FLAGGED:  "_$$FMTE^X LFDT($P(FL AG,U,3))_"  by "_$P($ G(^VA(200, +$P(FLAG,U ,4),0)),U)
  5629   "RTN","ORW DXA",223,0 )
  5630    S LST(2)= $P(FLAG,U, 5) ; reaso n
  5631   "RTN","ORW DXA",224,0 )
  5632    Q
  5633   "RTN","ORW DXA",225,0 )
  5634   WCGET(LST, ORID) ; wa rd comment s
  5635   "RTN","ORW DXA",226,0 )
  5636    N I,ORIFN ,ACT S ORI FN=+ORID,A CT=+$P(ORI D,";",2)
  5637   "RTN","ORW DXA",227,0 )
  5638    S I=0 F   S I=$O(^OR (100,ORIFN ,8,ACT,5,I )) Q:'I  S  LST(I)=$G (^(I,0))
  5639   "RTN","ORW DXA",228,0 )
  5640    Q
  5641   "RTN","ORW DXA",229,0 )
  5642   WCPUT(ERR, ORID,WCLST ) ; Set wa rd comment s
  5643   "RTN","ORW DXA",230,0 )
  5644    N DIERR,E RRLST,ORIF N,ACT S OR IFN=+ORID, ACT=+$P(OR ID,";",2)
  5645   "RTN","ORW DXA",231,0 )
  5646    D WP^DIE( 100.008,AC T_","_ORIF N_",",50," ","WCLST", "ERRLST")
  5647   "RTN","ORW DXA",232,0 )
  5648    S ERR=""  I $D(DIERR ) S ERR="A n error oc curred whi le saving  comments."
  5649   "RTN","ORW DXA",233,0 )
  5650    Q
  5651   "RTN","ORW DXA",234,0 )
  5652   OFCPLX(ORY ,ORID,PRTO RDER) ; is  ORID chil d of PRTOR DER
  5653   "RTN","ORW DXA",235,0 )
  5654    N NUMCHDS ,NOWID,NOW VAL,X3,ORD A,ISNOW
  5655   "RTN","ORW DXA",236,0 )
  5656    Q:'$D(^OR (100,+ORID ,0))
  5657   "RTN","ORW DXA",237,0 )
  5658    S ISNOW=0
  5659   "RTN","ORW DXA",238,0 )
  5660    D ISNOW^O RWDXR(.ISN OW,+ORID)
  5661   "RTN","ORW DXA",239,0 )
  5662    Q:ISNOW
  5663   "RTN","ORW DXA",240,0 )
  5664    N PKG
  5665   "RTN","ORW DXA",241,0 )
  5666    S PKG=$P( $G(^OR(100 ,+ORID,0)) ,U,14)
  5667   "RTN","ORW DXA",242,0 )
  5668    S PKG=$$N MSP^ORCD(P KG)
  5669   "RTN","ORW DXA",243,0 )
  5670    I PKG'="P S" Q
  5671   "RTN","ORW DXA",244,0 )
  5672    I $L($G(^ OR(100,+OR ID,3))),(' $L($P(^(3) ,U,9))) Q
  5673   "RTN","ORW DXA",245,0 )
  5674    S (NUMCHD S,NOWID,NO WVAL,X3,OR DA)=0
  5675   "RTN","ORW DXA",246,0 )
  5676    S PRTORDE R=+$P(^(3) ,U,9)
  5677   "RTN","ORW DXA",247,0 )
  5678    S X3=$G(^ OR(100,PRT ORDER,3)), ORDA=$P(X3 ,U,7)
  5679   "RTN","ORW DXA",248,0 )
  5680    S PRTORDE R=PRTORDER _";"_ORDA
  5681   "RTN","ORW DXA",249,0 )
  5682    S NUMCHDS =$P($G(^OR (100,+PRTO RDER,2,0)) ,U,4)
  5683   "RTN","ORW DXA",250,0 )
  5684    I NUMCHDS >2 S ORY=" COMPLEX-PS I"_U_PRTOR DER
  5685   "RTN","ORW DXA",251,0 )
  5686    S:$D(^OR( 100,+PRTOR DER,4.5,"I D","NOW"))  NOWID=$O( ^("NOW",0) )
  5687   "RTN","ORW DXA",252,0 )
  5688    S:NOWID N OWVAL=$G(^ OR(100,+PR TORDER,4.5 ,NOWID,1))
  5689   "RTN","ORW DXA",253,0 )
  5690    I NOWVAL= 1 Q
  5691   "RTN","ORW DXA",254,0 )
  5692    E  S ORY= "COMPLEX-P SI"_U_PRTO RDER
  5693   "RTN","ORW DXA",255,0 )
  5694    Q
  5695   "RTN","ORW DXA",256,0 )
  5696   ISACTOI(OR Y,OI) ; Is  ord item  active?
  5697   "RTN","ORW DXA",257,0 )
  5698    I $G(^ORD (101.43,+O I,.1)),^(. 1)'>$$NOW^ XLFDT D
  5699   "RTN","ORW DXA",258,0 )
  5700    . S ORY=$ P($G(^ORD( 101.43,OI, 0)),U)_" h as been in activated  and may no t be order ed anymore ."
  5701   "RTN","ORW DXA",259,0 )
  5702    Q
  5703   "RTN","ORW DXA",260,0 )
  5704   UPCTCHK(OR ID) ;
  5705   "RTN","ORW DXA",261,0 )
  5706    ;ORID=ORD ER NUMBER
  5707   "RTN","ORW DXA",262,0 )
  5708    ;RETURNS  1 IF THERE  IS AN UPC ARET IN TH E ORDER'S  COMMENTS
  5709   "RTN","ORW DXA",263,0 )
  5710    N RET,COM MID,WPCNT, PIID S RET =0
  5711   "RTN","ORW DXA",264,0 )
  5712    S COMMID= $O(^OR(100 ,+ORID,4.5 ,"ID","COM MENT",0))
  5713   "RTN","ORW DXA",265,0 )
  5714    I COMMID  S WPCNT=0  F  S WPCNT =$O(^OR(10 0,+ORID,4. 5,COMMID,2 ,WPCNT)) Q :'WPCNT!(R ET)  D
  5715   "RTN","ORW DXA",266,0 )
  5716    .I $G(^OR (100,+ORID ,4.5,COMMI D,2,WPCNT, 0))["^" S  RET=1
  5717   "RTN","ORW DXA",267,0 )
  5718    S PIID=$O (^OR(100,+ ORID,4.5," ID","PI",0 ))
  5719   "RTN","ORW DXA",268,0 )
  5720    I PIID S  WPCNT=0 F   S WPCNT=$ O(^OR(100, +ORID,4.5, PIID,2,WPC NT)) Q:'WP CNT!(RET)   D
  5721   "RTN","ORW DXA",269,0 )
  5722    .I $G(^OR (100,+ORID ,4.5,PIID, 2,WPCNT,0) )["^" S RE T=1
  5723   "RTN","ORW DXA",270,0 )
  5724    Q RET
  5725   "RTN","ORW DXA",271,0 )
  5726   HMPFLAG(OR IFN,HMDFN, WHEN,USR,F LGACTN,RSN ,ORACLVL)  ;
  5727   "RTN","ORW DXA",272,0 )
  5728    ; ORACLVL  = ^OR(100 ,ORIFN,8,l evel)
  5729   "RTN","ORW DXA",273,0 )
  5730    ;
  5731   "RTN","ORW DXA",274,0 )
  5732    N RSLT,VA L  ; resul t, FileMan  values
  5733   "RTN","ORW DXA",275,0 )
  5734    S VAL(.01 )=$G(WHEN)   ; date/t ime of act ivity
  5735   "RTN","ORW DXA",276,0 )
  5736    S VAL(.02 )=$G(FLGAC TN)  ; fla g or unfla g
  5737   "RTN","ORW DXA",277,0 )
  5738    S VAL(.03 )=$G(USR)   ; DUZ
  5739   "RTN","ORW DXA",278,0 )
  5740    S VAL(.04 )=$G(RSN)   ; flag/un flag reaso n
  5741   "RTN","ORW DXA",279,0 )
  5742    D ADDFLAG ^HMPOR(.RS LT,.VAL,+$ G(ORIFN),$ G(HMDFN),O RACLVL_";" _$G(FLGACT N))
  5743   "RTN","ORW DXA",280,0 )
  5744    Q:RSLT<0   D COMP^OR MBLDOR(+$G (ORIFN))   ;trigger u nsolicited  synch for  flag/unfl ag
  5745   "RTN","ORW DXA",281,0 )
  5746    Q
  5747   "RTN","ORW DXM1")
  5748   0^19^B1304 81276
  5749   "RTN","ORW DXM1",1,0)
  5750   ORWDXM1 ;S LC/KCM - O rder Dialo gs, Menus  ;Nov 02, 2 018@13:38
  5751   "RTN","ORW DXM1",2,0)
  5752    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**1 0,85,131,1 32,141,178 ,185,187,2 15,243,280 ,331,388,3 50,423,434 ,494,397** ;Dec 17, 1 997;Build  17
  5753   "RTN","ORW DXM1",3,0)
  5754    ;
  5755   "RTN","ORW DXM1",4,0)
  5756    ;
  5757   "RTN","ORW DXM1",5,0)
  5758   BLDQRSP(LS T,ORIT,FLD S,ISIMO,EN CLOC) ; Bu ild respon ses for an  order
  5759   "RTN","ORW DXM1",6,0)
  5760    ; LST=Qui ckLevel^Re sponseID(O RIT;$H)^Di alog^Type^ FormID^DGr p
  5761   "RTN","ORW DXM1",7,0)
  5762    ; LST(n)= verify or  reject tex t
  5763   "RTN","ORW DXM1",8,0)
  5764    ; ORIT= p tr to 101. 41 for qui ck order,  100 for co py
  5765   "RTN","ORW DXM1",9,0)
  5766    ; 1 2 3 4  5 6 7 8 1 1-20
  5767   "RTN","ORW DXM1",10,0 )
  5768    ; FLDS=DF N^LOC^ORNP ^INPT^SEX^ AGE^EVENT^ SC%^^^Key  Variables. ..
  5769   "RTN","ORW DXM1",11,0 )
  5770    ; ORIT=+O RIT: ptr t o 101.41,  $E(ORIT)=C : copy $E( ORIT)=X: c hange
  5771   "RTN","ORW DXM1",12,0 )
  5772    ; !! SHOU LD CHECK f or PRE-CPR S ORDERS ( treat as t ext?)
  5773   "RTN","ORW DXM1",13,0 )
  5774    K ^TMP($J ,"ORWDX LO ADRSP","QO  SAVE")
  5775   "RTN","ORW DXM1",14,0 )
  5776    K ^TMP("O RWDXMQ",$J )
  5777   "RTN","ORW DXM1",15,0 )
  5778    N ORWMODE  ; 0:Dlg,Q uick 1:cop y 2:change
  5779   "RTN","ORW DXM1",16,0 )
  5780    N TEMPCAT  ; pt cat  from DPT
  5781   "RTN","ORW DXM1",17,0 )
  5782    N ISXFER  ; Trnsfr o rder?
  5783   "RTN","ORW DXM1",18,0 )
  5784    N ORIMO ; If IMO(inp t med on o pt)
  5785   "RTN","ORW DXM1",19,0 )
  5786    N TEMPORI T
  5787   "RTN","ORW DXM1",20,0 )
  5788    N ADMLOC, PATLOC,ORD LOC,LEVEL, DELAY,SCHL OC,SCHTYP
  5789   "RTN","ORW DXM1",21,0 )
  5790    S PATLOC= $P(FLDS,U, 2)
  5791   "RTN","ORW DXM1",22,0 )
  5792    S ORDLOC= $S(ORIT["C ":+$P($G(^ OR(100,+$P (ORIT,"C", 2),0)),U,1 0),1:0)
  5793   "RTN","ORW DXM1",23,0 )
  5794    S ORIMO=$ G(ISIMO)
  5795   "RTN","ORW DXM1",24,0 )
  5796    S ORWMODE =0,ISXFER= ""
  5797   "RTN","ORW DXM1",25,0 )
  5798    S:$E(ORIT )="C" ORWM ODE=1 S:$E (ORIT)="T"  ORWMODE=1 ,ISXFER="; T" ;treat  xfer as co py
  5799   "RTN","ORW DXM1",26,0 )
  5800    S:$E(ORIT )="X" ORWM ODE=2
  5801   "RTN","ORW DXM1",27,0 )
  5802    S TEMPORI T=ORIT
  5803   "RTN","ORW DXM1",28,0 )
  5804    I ORWMODE  S ORIT=$E (ORIT,2,99 9)
  5805   "RTN","ORW DXM1",29,0 )
  5806    S LST(0)= ""
  5807   "RTN","ORW DXM1",30,0 )
  5808    ;disable
  5809   "RTN","ORW DXM1",31,0 )
  5810    D CHKDSBL ^ORWDXM3(. LST,ORIT,O RWMODE) Q: +LST(0)=8
  5811   "RTN","ORW DXM1",32,0 )
  5812    ;action
  5813   "RTN","ORW DXM1",33,0 )
  5814    D CHKVACT ^ORWDXM3(. LST,ORIT,O RWMODE,$P( FLDS,U,3))  Q:+LST(0) =8
  5815   "RTN","ORW DXM1",34,0 )
  5816    ;no copy
  5817   "RTN","ORW DXM1",35,0 )
  5818    I ORWMODE =1 D CHKCO PY^ORWDXM3 (.LST,ORIT ,FLDS) Q:+ LST(0)=8
  5819   "RTN","ORW DXM1",36,0 )
  5820    ;change
  5821   "RTN","ORW DXM1",37,0 )
  5822    I ORWMODE =2 D BLD4C HG^ORWDXM3 (.LST,ORIT ,FLDS) Q
  5823   "RTN","ORW DXM1",38,0 )
  5824    I 'ORWMOD E,($P(^ORD (101.41,+O RIT,0),U,4 )="D"),$P( ^ORD(101.4 1,+ORIT,0) ,"^",7)=$O (^DIC(9.4, "C","SD",0 )) S LST(0 )="0^0^"_$ $DLGINFO^O RWDXM3(ORI T,ORWMODE_ ISXFER) Q
  5825   "RTN","ORW DXM1",39,0 )
  5826    I 'ORWMOD E,($P(^ORD (101.41,+O RIT,0),U,4 )="D"),'($ O(^DIC(9.4 ,"C","OR", 0))[$P(^OR D(101.41,+ ORIT,0),U, 7)) S LST( 0)="0^0^"_ $$DLGINFO^ ORWDXM3(OR IT,ORWMODE _ISXFER) Q
  5827   "RTN","ORW DXM1",40,0 )
  5828    N ORIMTYP E,ORCOMP,O RTAS,LRFZX ,LRFSAMP,L RFSPEC,LRF DATE,LRFUR G,LRFSCH
  5829   "RTN","ORW DXM1",41,0 )
  5830    N ORTIME, ORCOLLCT,O RMAX,ORTES T,ORIMTIME ,ORSMAX,OR STMS,ORSCH
  5831   "RTN","ORW DXM1",42,0 )
  5832    N PSJNOPC ,ORMORE,OR INPT,ORXNP ,ORSCHED,O RQTY,ORNOU NS,ORXNP,O REFILLS
  5833   "RTN","ORW DXM1",43,0 )
  5834    N ORCOMPL X,ORQTY,OR COPAY,ORDR UG,ORWPSPI K,ORWPSWRG ,ORSD,ORDS UP,ORWP94
  5835   "RTN","ORW DXM1",44,0 )
  5836    N ORPARAM ,ORNPO,ORT IME,ORMEAL ,ORTRAY,OR DATE,GMRCN OPD,GMRCNO AT,GMRCREA F
  5837   "RTN","ORW DXM1",45,0 )
  5838    N ORTYPE, ORVP,ORL,O RNP,ORSEX, ORAGE,ORWA RD,OREVENT ,ORDIV,ORS C,KEYVAR
  5839   "RTN","ORW DXM1",46,0 )
  5840    N ORDG,OR DIALOG,ORC AT,FIRST,O RQUIT,X,OR TRAIL,ORLE AD,RSPREF, AUTOACK
  5841   "RTN","ORW DXM1",47,0 )
  5842    N OREVNTY P
  5843   "RTN","ORW DXM1",48,0 )
  5844    S ORWP94= $O(^ORD(10 1.41,"AB", "PS MEDS", 0))>0
  5845   "RTN","ORW DXM1",49,0 )
  5846    S ORVP=$P (FLDS,U,1) _";DPT(",O RNP=+$P(FL DS,U,3),OR SC=$P(FLDS ,U,8)
  5847   "RTN","ORW DXM1",50,0 )
  5848    S ORL=$P( FLDS,U,2)_ ";SC(",ORL (2)=ORL
  5849   "RTN","ORW DXM1",51,0 )
  5850    S ORSEX=$ P(FLDS,U,5 ),ORAGE=$P (FLDS,U,6) ,ORTYPE="Q ",FIRST=1
  5851   "RTN","ORW DXM1",52,0 )
  5852    I $P(FLDS ,U,4),$G(^ SC(+ORL,42 )) S ORWAR D=+^SC(+OR L,42)
  5853   "RTN","ORW DXM1",53,0 )
  5854    I $L($P(F LDS,U,7))  D
  5855   "RTN","ORW DXM1",54,0 )
  5856    . S OREVE NT=$P(FLDS ,U,7)
  5857   "RTN","ORW DXM1",55,0 )
  5858    . S OREVN TYP=$P(ORE VENT,";",2 )
  5859   "RTN","ORW DXM1",56,0 )
  5860    . S OREVE NT("TS")=$ P(OREVENT, ";",3)
  5861   "RTN","ORW DXM1",57,0 )
  5862    . S OREVE NT("EFFECT IVE")=$P(O REVENT,";" ,4)
  5863   "RTN","ORW DXM1",58,0 )
  5864    . S OREVE NT=+$P(ORE VENT,";",1 )
  5865   "RTN","ORW DXM1",59,0 )
  5866    I 'ORWMOD E D
  5867   "RTN","ORW DXM1",60,0 )
  5868    . D SETKE YV^ORWDXM3 ($P(FLDS,U ,11,20)) ;  from menu  path
  5869   "RTN","ORW DXM1",61,0 )
  5870    . S KEYVA R=$$KEYVAR ^ORWDXM3(O RIT) ; fro m entry ac tion
  5871   "RTN","ORW DXM1",62,0 )
  5872    . D SETKE YV^ORWDXM3 (KEYVAR)
  5873   "RTN","ORW DXM1",63,0 )
  5874    K ^TMP("O RWORD",$J)
  5875   "RTN","ORW DXM1",64,0 )
  5876    ; init re turn recor d based on  auto-acce pt
  5877   "RTN","ORW DXM1",65,0 )
  5878    I ORWMODE  S LST(0)= "2^"_ORIT  ;verify on  copy
  5879   "RTN","ORW DXM1",66,0 )
  5880    E  S LST( 0)=+$P($G( ^ORD(101.4 1,ORIT,5)) ,U,8)_U_OR IT
  5881   "RTN","ORW DXM1",67,0 )
  5882    S TEMPCAT =$S($L($P( $G(^DPT(+O RVP,.1)),U )):"I",1:" O")
  5883   "RTN","ORW DXM1",68,0 )
  5884    I TEMPCAT ="I",+$P(F LDS,U,4)=1 ,$E(TEMPOR IT)="C",$P ($G(^ORD(1 00.98,$P($ G(^OR(100, +ORIT,0)), U,11),0)), U)="OUTPAT IENT MEDIC ATIONS" S  TEMPCAT="O "
  5885   "RTN","ORW DXM1",69,0 )
  5886    I $L($G(O REVNTYP))  D
  5887   "RTN","ORW DXM1",70,0 )
  5888    . S ORCAT =$S(OREVNT YP="A":"I" ,OREVNTYP= "T":"I",OR EVNTYP="O" :TEMPCAT,O REVNTYP="M ":TEMPCAT, OREVNTYP=" C":TEMPCAT ,1:"O") I  $G(OREVENT ) D
  5889   "RTN","ORW DXM1",71,0 )
  5890    .. N X S  X=$$EVT^OR EVNTX(OREV ENT),X=$P( $G(^ORD(10 0.5,+X,0)) ,U,7)
  5891   "RTN","ORW DXM1",72,0 )
  5892    .. I OREV NTYP="T",X ,X<4 S ORC AT="O" ;To  pass=outp t
  5893   "RTN","ORW DXM1",73,0 )
  5894    .. I OREV NTYP="D",X =41 S ORCA T="I" ;Fro m ASIH=inp t
  5895   "RTN","ORW DXM1",74,0 )
  5896    E  S ORCA T=TEMPCAT
  5897   "RTN","ORW DXM1",75,0 )
  5898    D SETUP^O RWDXM4 Q:+ LST(0)=8
  5899   "RTN","ORW DXM1",76,0 )
  5900    S X="OR G TX START D ATE"_$S($G (ORWP94):" /TIME",1:" ")
  5901   "RTN","ORW DXM1",77,0 )
  5902    I ORWMODE ,(ORDG=+$O (^ORD(100. 98,"B","O  RX",0))) D   ;remove  old values
  5903   "RTN","ORW DXM1",78,0 )
  5904    . K ORDIA LOG($$PTR^ ORCD(X),1)
  5905   "RTN","ORW DXM1",79,0 )
  5906    . I ORWMO DE=2,$$DRA FT^ORWDX2( ORIT) Q  ; keep comme nts
  5907   "RTN","ORW DXM1",80,0 )
  5908    . K:ISXFE R'["T" ORD IALOG($$PT R^ORCD("OR  GTX WORD  PROCESSING  1"),1)
  5909   "RTN","ORW DXM1",81,0 )
  5910    D SETUPS^ ORWDXM4 ;m oved to sa ve space,  expects X
  5911   "RTN","ORW DXM1",82,0 )
  5912    Q:+LST(0) =8
  5913   "RTN","ORW DXM1",83,0 )
  5914    I $G(ORQU IT) S LST( 0)="0^0^"_ $$DLGINFO^ ORWDXM3(OR IT,ORWMODE _ISXFER)_" ^"_$G(KEYV AR) Q
  5915   "RTN","ORW DXM1",84,0 )
  5916    N SEQ,DA, XCODE,MUST ASK,PROMPT ,INST,KEY, IVFID,CLIV FID
  5917   "RTN","ORW DXM1",85,0 )
  5918    S IVFID=$ O(^ORD(101 .41,"B","P SJI OR PAT  FLUID OE" ,0))
  5919   "RTN","ORW DXM1",86,0 )
  5920    S CLIVFID =$O(^ORD(1 01.41,"B", "CLINIC OR  PAT FLUID  OE",0))
  5921   "RTN","ORW DXM1",87,0 )
  5922    S AUTOACK =$S($D(ORW PSWRG):0,1 :1)
  5923   "RTN","ORW DXM1",88,0 )
  5924    ; If copy ing, clear  bad dates . Later, S ETITEM wil l fill dat es with de fault valu es. ;DJE-V M *331
  5925   "RTN","ORW DXM1",89,0 )
  5926    I ORWMODE =1 D  ;
  5927   "RTN","ORW DXM1",90,0 )
  5928    . I $L($$ VAL^ORCD(" START DATE ")) D  ;
  5929   "RTN","ORW DXM1",91,0 )
  5930    . . S X=$ $VAL^ORCD( "START DAT E"),%DT="T X" D ^%DT
  5931   "RTN","ORW DXM1",92,0 )
  5932    . . I Y'< $$DT^XLFDT ,(($L($$VA L^ORCD("ST OP DATE")) =0)!('$$FT DCOMP^ORCD ("START DA TE","STOP  DATE",">") )) Q  ;qui t if valid  dates: st art not in  the past  or stop af ter start
  5933   "RTN","ORW DXM1",93,0 )
  5934    . . K ORD IALOG($$PT R("START D ATE"),1),O RDIALOG($$ PTR("START  DATE/TIME "),1) ;era se bad sta rt and sto p dates.
  5935   "RTN","ORW DXM1",94,0 )
  5936    . . K ORD IALOG($$PT R("STOP DA TE"),1),OR DIALOG($$P TR("STOP D ATE/TIME") ,1)
  5937   "RTN","ORW DXM1",95,0 )
  5938    . ; check  start and  stop date s found in  diet orde rs
  5939   "RTN","ORW DXM1",96,0 )
  5940    . I $L($$ VAL^ORCD(" EFFECTIVE  DATE/TIME" )) D  ;
  5941   "RTN","ORW DXM1",97,0 )
  5942    . . S X=$ $VAL^ORCD( "EFFECTIVE  DATE/TIME "),%DT="TX " D ^%DT
  5943   "RTN","ORW DXM1",98,0 )
  5944    . . I Y'< $$DT^XLFDT ,(($L($$VA L^ORCD("EX PIRATION D ATE/TIME") )=0)!('$$F TDCOMP^ORC D("EFFECTI VE DATE/TI ME","EXPIR ATION DATE /TIME",">" ))) Q  ;qu it if vali d dates: s tart not i n the past  or stop a fter start
  5945   "RTN","ORW DXM1",99,0 )
  5946    . . K ORD IALOG($P(O RDIALOG("B ","EFFECTI VE DATE/TI ME"),U,2), 1) ;erase  bad start  and stop d ates.
  5947   "RTN","ORW DXM1",100, 0)
  5948    . . K ORD IALOG($P(O RDIALOG("B ","EXPIRAT ION DATE/T IME"),U,2) ,1)
  5949   "RTN","ORW DXM1",101, 0)
  5950    . ; check  date desi red field  found in i maging ord ers
  5951   "RTN","ORW DXM1",102, 0)
  5952    . I $L($$ VAL^ORCD(" DATE DESIR ED")) D  ;
  5953   "RTN","ORW DXM1",103, 0)
  5954    . . S X=$ $VAL^ORCD( "DATE DESI RED"),%DT= "TX" D ^%D T
  5955   "RTN","ORW DXM1",104, 0)
  5956    . . I Y'< $$DT^XLFDT  Q  ;quit  if not a p ast date
  5957   "RTN","ORW DXM1",105, 0)
  5958    . . K ORD IALOG($P(O RDIALOG("B ","DATE DE SIRED"),U, 2),1) ;era se bad dat e
  5959   "RTN","ORW DXM1",106, 0)
  5960    . ; check  collectio n date fie ld found i n lab orde rs
  5961   "RTN","ORW DXM1",107, 0)
  5962    . I $L($$ VAL^ORCD(" COLLECTION  DATE/TIME ")) D  ;
  5963   "RTN","ORW DXM1",108, 0)
  5964    . . S X=$ $VAL^ORCD( "COLLECTIO N DATE/TIM E")
  5965   "RTN","ORW DXM1",109, 0)
  5966    . . I X=" NEXT" Q  ; No need to  check thi s.
  5967   "RTN","ORW DXM1",110, 0)
  5968    . . S %DT ="TX" D ^% DT
  5969   "RTN","ORW DXM1",111, 0)
  5970    . . I $P( Y,".",2),Y '<$E($$NOW ^XLFDT,1,1 2) Q  ;qui t if not a  past date  and time  (lab is mo re precise  than othe r dates)
  5971   "RTN","ORW DXM1",112, 0)
  5972    . . I $P( Y,".",2)=" ",Y'<$$DT^ XLFDT Q  ;
  5973   "RTN","ORW DXM1",113, 0)
  5974    . . K ORD IALOG($P(O RDIALOG("B ","COLLECT ION DATE/T IME"),U,2) ,1) ;erase  bad date
  5975   "RTN","ORW DXM1",114, 0)
  5976    . ;if cop ying a "Re turn to Cl inic" orde r, force u ser to ent er a date
  5977   "RTN","ORW DXM1",115, 0)
  5978    . I $L($$ VAL^ORCD(" RETURN TO  CLINIC DAT E")) D
  5979   "RTN","ORW DXM1",116, 0)
  5980    . . K ORD IALOG($P(O RDIALOG("B ","RETURN  TO CLINIC  DATE"),U,2 ),1)
  5981   "RTN","ORW DXM1",117, 0)
  5982    S SEQ=0 F   S SEQ=$O (^ORD(101. 41,+ORDIAL OG,10,"B", SEQ)) Q:'S EQ  D
  5983   "RTN","ORW DXM1",118, 0)
  5984    . S DA=0  F  S DA=$O (^ORD(101. 41,+ORDIAL OG,10,"B", SEQ,DA)) Q :'DA  D
  5985   "RTN","ORW DXM1",119, 0)
  5986    . . ; ski p if child  prmpt
  5987   "RTN","ORW DXM1",120, 0)
  5988    . . I $P( ^ORD(101.4 1,+ORDIALO G,10,DA,0) ,U,11) Q
  5989   "RTN","ORW DXM1",121, 0)
  5990    . . ; set  dflt for  prmpt, chk  if intera ctive
  5991   "RTN","ORW DXM1",122, 0)
  5992    . . S PRO MPT=$P(^OR D(101.41,+ ORDIALOG,1 0,DA,0),U, 2)
  5993   "RTN","ORW DXM1",123, 0)
  5994    . . D SET ITEM(DA,PR OMPT,1,.MU STASK)
  5995   "RTN","ORW DXM1",124, 0)
  5996    . . I MUS TASK S AUT OACK=0 Q
  5997   "RTN","ORW DXM1",125, 0)
  5998    . . ; ite rate throu gh child i tems if pa rent & edi t only
  5999   "RTN","ORW DXM1",126, 0)
  6000    . . Q:'$D (^ORD(101. 41,+ORDIAL OG,10,"DAD ",PROMPT))
  6001   "RTN","ORW DXM1",127, 0)
  6002    . . N CSE Q,CDA,CPRO MPT,INST,O RQUIT
  6003   "RTN","ORW DXM1",128, 0)
  6004    . . S CSE Q=0 F  S C SEQ=$O(^OR D(101.41,+ ORDIALOG,1 0,"DAD",PR OMPT,CSEQ) ) Q:'CSEQ   D  Q:$G(O RQUIT)
  6005   "RTN","ORW DXM1",129, 0)
  6006    . . . S C DA=$O(^ORD (101.41,+O RDIALOG,10 ,"DAD",PRO MPT,CSEQ,0 ))
  6007   "RTN","ORW DXM1",130, 0)
  6008    . . . S C PROMPT=$P( ^ORD(101.4 1,+ORDIALO G,10,CDA,0 ),U,2)
  6009   "RTN","ORW DXM1",131, 0)
  6010    . . . ; i f req & no  instances  then need  interacti on
  6011   "RTN","ORW DXM1",132, 0)
  6012    . . . I $ P(^ORD(101 .41,+ORDIA LOG,10,CDA ,0),U,6) D
  6013   "RTN","ORW DXM1",133, 0)
  6014    . . . . I  ORDIALOG= IVFID!(ORD IALOG=CLIV FID) Q
  6015   "RTN","ORW DXM1",134, 0)
  6016    . . . . I  '$O(ORDIA LOG(CPROMP T,0)) S AU TOACK=0
  6017   "RTN","ORW DXM1",135, 0)
  6018    . . . S I NST=0 F  S  INST=$O(O RDIALOG(CP ROMPT,INST )) Q:'INST   D
  6019   "RTN","ORW DXM1",136, 0)
  6020    . . . . N  ORASK D V BASK^ORWDX M4(INST) ;  set ORASK  for VBECS
  6021   "RTN","ORW DXM1",137, 0)
  6022    . . . . ;  set dflt  for each c hild prmpt
  6023   "RTN","ORW DXM1",138, 0)
  6024    . . . . D  SETITEM(C DA,CPROMPT ,INST,.MUS TASK)
  6025   "RTN","ORW DXM1",139, 0)
  6026    . . . . ;  if no val  & child p rmpt req'd  then need  interacti on
  6027   "RTN","ORW DXM1",140, 0)
  6028    . . . . I  MUSTASK,$ P(^ORD(101 .41,+ORDIA LOG,10,CDA ,0),U,6) S  AUTOACK=0
  6029   "RTN","ORW DXM1",141, 0)
  6030    N IVDLG,C LINFDLG,SP LYDLG
  6031   "RTN","ORW DXM1",142, 0)
  6032    S IVDLG=$ O(^ORD(101 .41,"AB"," PSJI OR PA T FLUID OE ",0))
  6033   "RTN","ORW DXM1",143, 0)
  6034    S CLINFDL G=$O(^ORD( 101.41,"AB ","CLINIC  OR PAT FLU ID OE",0))
  6035   "RTN","ORW DXM1",144, 0)
  6036    S SPLYDLG =$O(^ORD(1 01.41,"AB" ,"PSO SUPP LY",0))
  6037   "RTN","ORW DXM1",145, 0)
  6038    I $$ISMED (ORIT),(OR DIALOG'=IV DLG),(ORDI ALOG'=CLIN FDLG),(ORD IALOG'=SPL YDLG),(ORC AT="I") D
  6039   "RTN","ORW DXM1",146, 0)
  6040    . N P
  6041   "RTN","ORW DXM1",147, 0)
  6042    . F P="PA TIENT INST RUCTIONS", "DAYS SUPP LY","QUANT ITY","REFI LLS","ROUT ING","SERV ICE CONNEC TED" K ORD IALOG($$PT R(P),1)
  6043   "RTN","ORW DXM1",148, 0)
  6044    . I '$$IS QO(ORIT) K  ORDIALOG( $$PTR("STA RT DATE/TI ME"),1) ;  kill if no t a non-VA  med quick  order. p3 88
  6045   "RTN","ORW DXM1",149, 0)
  6046    S KEY=$S( ORWMODE:"C ",1:"")_OR IT_"-"_$P( $H,",",2), SEQ=0
  6047   "RTN","ORW DXM1",150, 0)
  6048    I $$ISINP MED(ORIT)  D
  6049   "RTN","ORW DXM1",151, 0)
  6050    .S LEVEL= $P(LST(0), U),DELAY=$ S($P($G(OR EVENT),";" )>0:1,1:0)
  6051   "RTN","ORW DXM1",152, 0)
  6052    .I LEVEL= 2!(ISIMO)  D ADMTIME^ ORWDXM2(OR DLOC,PATLO C,ENCLOC,D ELAY,ISIMO )
  6053   "RTN","ORW DXM1",153, 0)
  6054    I ($$ISME D(ORIT)),' ($$VALQO^O RWDXM3(ORI T)) S AUTO ACK=0
  6055   "RTN","ORW DXM1",154, 0)
  6056    I 'ORWMOD E,$P(^ORD( 101.41,+OR IT,0),U,7) =$O(^DIC(9 .4,"C","SD ",0)),'($$ SDRTCVER^O RWDXM3(.OR DIALOG)) S  AUTOACK=0
  6057   "RTN","ORW DXM1",155, 0)
  6058    S PROMPT= 0 F  S PRO MPT=$O(ORD IALOG(PROM PT)) Q:'PR OMPT  D
  6059   "RTN","ORW DXM1",156, 0)
  6060    . I '$D(^ ORD(101.41 ,ORDIALOG, 10,"D",PRO MPT)) K OR DIALOG(PRO MPT) Q
  6061   "RTN","ORW DXM1",157, 0)
  6062    . S INST= 0 F  S INS T=$O(ORDIA LOG(PROMPT ,INST)) Q: 'INST  D
  6063   "RTN","ORW DXM1",158, 0)
  6064    . . S SEQ =SEQ+1,^TM P("ORWDXMQ ",$J,KEY,S EQ,0)=U_PR OMPT_U_INS T
  6065   "RTN","ORW DXM1",159, 0)
  6066    . . ; sav e word pro c val
  6067   "RTN","ORW DXM1",160, 0)
  6068    . . I $E( ORDIALOG(P ROMPT,0))= "W",$L(ORD IALOG(PROM PT,INST))  D
  6069   "RTN","ORW DXM1",161, 0)
  6070    . . . M ^ TMP("ORWDX MQ",$J,KEY ,SEQ,2)=@O RDIALOG(PR OMPT,INST)
  6071   "RTN","ORW DXM1",162, 0)
  6072    . . ; sav e other va l types
  6073   "RTN","ORW DXM1",163, 0)
  6074    . . E  S  ^TMP("ORWD XMQ",$J,KE Y,SEQ,1)=O RDIALOG(PR OMPT,INST)
  6075   "RTN","ORW DXM1",164, 0)
  6076    I AUTOACK  D
  6077   "RTN","ORW DXM1",165, 0)
  6078    . I ORWMO DE S AUTOA CK=2
  6079   "RTN","ORW DXM1",166, 0)
  6080    . I 'ORWM ODE,($P(^O RD(101.41, ORIT,0),U, 8)!'LST(0) ) S AUTOAC K=2
  6081   "RTN","ORW DXM1",167, 0)
  6082    ;I ($$ISM ED(ORIT)), '($$VALQO^ ORWDXM3(OR IT)) S AUT OACK=0
  6083   "RTN","ORW DXM1",168, 0)
  6084    I ORIMO,O RWMODE S A UTOACK=2
  6085   "RTN","ORW DXM1",169, 0)
  6086    ; accept  Herbal/OTC /NonVA Med  quick ord ers
  6087   "RTN","ORW DXM1",170, 0)
  6088    I $L($G(^ ORD(101.41 ,+ORIT,0)) ),($P(^ORD (100.98,$P (^ORD(101. 41,+ORIT,0 ),U,5),0), U,3)="NV R X"),($P($G (^ORD(101. 41,+ORIT,5 )),U,8)) S  AUTOACK=1
  6089   "RTN","ORW DXM1",171, 0)
  6090    ;I AUTOAC K=2,$$ISME D(ORIT),(O RDIALOG=IV DLG),$$VER ORD^ORWDXM 3=0 S AUTO ACK=0
  6091   "RTN","ORW DXM1",172, 0)
  6092    I AUTOACK =2,$$ISMED (ORIT),$$V ERORD^ORWD XM3(ORIT)= 0 S AUTOAC K=0
  6093   "RTN","ORW DXM1",173, 0)
  6094    I AUTOACK =2 D VERTX T^ORWDXM2
  6095   "RTN","ORW DXM1",174, 0)
  6096    S LST(0)= AUTOACK_U_ KEY_U_$$DL GINFO^ORWD XM3(ORIT,O RWMODE_ISX FER)_"^"_$ G(KEYVAR)
  6097   "RTN","ORW DXM1",175, 0)
  6098    I $P(LST( 0),U,4)="D " S $P(LST (0),U,4)=" Q"
  6099   "RTN","ORW DXM1",176, 0)
  6100    I ORWMODE =1 S $P(LS T(0),U,4)= "C"
  6101   "RTN","ORW DXM1",177, 0)
  6102    K ^TMP("O RWORD",$J)
  6103   "RTN","ORW DXM1",178, 0)
  6104    K ^TMP("P SJINS",$J) ,^TMP("PSJ MR",$J),^T MP("PSJNOU N",$J)
  6105   "RTN","ORW DXM1",179, 0)
  6106    Q
  6107   "RTN","ORW DXM1",180, 0)
  6108   SETITEM(DA ,PROMPT,IN ST,MUSTASK ) ; set df lt val & r eturn if m ust prompt
  6109   "RTN","ORW DXM1",181, 0)
  6110    N EDITONL Y,Y,VALIV, XCODE,ORIS PROS
  6111   "RTN","ORW DXM1",182, 0)
  6112    S MUSTASK =0,EDITONL Y=0,VALIV= 0,ORISPROS =0
  6113   "RTN","ORW DXM1",183, 0)
  6114    I $D(^TMP ("ORWDHTM" ,$J,ORDIAL OG,PROMPT) ) D
  6115   "RTN","ORW DXM1",184, 0)
  6116    . I $E(OR DIALOG(PRO MPT,0))="W " D
  6117   "RTN","ORW DXM1",185, 0)
  6118    . . S ^TM P("ORWORD" ,$J,PROMPT ,INST,1,0) =^TMP("ORW DHTM",$J,O RDIALOG,PR OMPT)
  6119   "RTN","ORW DXM1",186, 0)
  6120    . . S ORD IALOG(PROM PT,INST)=" ^TMP(""ORW ORD"","_$J _","_PROMP T_","_INST _")"
  6121   "RTN","ORW DXM1",187, 0)
  6122    . E  S OR DIALOG(PRO MPT,INST)= ^TMP("ORWD HTM",$J,OR DIALOG,PRO MPT)
  6123   "RTN","ORW DXM1",188, 0)
  6124    I $D(^TMP ("ORWDHTM" ,$J,ORIT,P ROMPT)) D
  6125   "RTN","ORW DXM1",189, 0)
  6126    . S ORDIA LOG(PROMPT ,INST)=^TM P("ORWDHTM ",$J,ORIT, PROMPT)
  6127   "RTN","ORW DXM1",190, 0)
  6128    . ; NEED  TO CLEAN U P ^TMP("OR WDHTM") af ter proces s order se t!!!
  6129   "RTN","ORW DXM1",191, 0)
  6130    ;
  6131   "RTN","ORW DXM1",192, 0)
  6132    ; skip if  a value a lready exi sts for th is prompt  and not WP
  6133   "RTN","ORW DXM1",193, 0)
  6134    Q:$D(ORDI ALOG(PROMP T,INST))&( $E(ORDIALO G(PROMPT,0 ))'="W")
  6135   "RTN","ORW DXM1",194, 0)
  6136    ; execute  default a ction if n o value in  QO, check ing EDITON LY afterwa rds
  6137   "RTN","ORW DXM1",195, 0)
  6138    I '$D(ORD IALOG(PROM PT,INST))  D
  6139   "RTN","ORW DXM1",196, 0)
  6140    . ;
  6141   "RTN","ORW DXM1",197, 0)
  6142    . ;Interm ittent IV  orders do  not requir e a soluti on or an i nfusion ra te
  6143   "RTN","ORW DXM1",198, 0)
  6144    . I PROMP T=$$PTR("I NFUSION RA TE"),$$GET IVTYP^ORWD XM3="I" S  VALIV=1 Q
  6145   "RTN","ORW DXM1",199, 0)
  6146    . I PROMP T=$$PTR("O RDERABLE I TEM"),$$GE TIVTYP^ORW DXM3="I" S  VALIV=1 Q
  6147   "RTN","ORW DXM1",200, 0)
  6148    . I $E(OR DIALOG(PRO MPT,0))="W ",$D(^ORD( 101.41,+OR DIALOG,10, DA,8))>9 D
  6149   "RTN","ORW DXM1",201, 0)
  6150    . . M ^TM P("ORWORD" ,$J,PROMPT ,INST)=^OR D(101.41,+ ORDIALOG,1 0,DA,8)
  6151   "RTN","ORW DXM1",202, 0)
  6152    . . S ORD IALOG(PROM PT,INST)=" ^TMP(""ORW ORD"","_$J _","_PROMP T_","_INST _")"
  6153   "RTN","ORW DXM1",203, 0)
  6154    . E  D
  6155   "RTN","ORW DXM1",204, 0)
  6156    . . S XCO DE=$$SUBCO DE($G(^ORD (101.41,+O RDIALOG,10 ,DA,7)))
  6157   "RTN","ORW DXM1",205, 0)
  6158    . . I $L( XCODE) X X CODE S:$D( Y) ORDIALO G(PROMPT,I NST)=Y
  6159   "RTN","ORW DXM1",206, 0)
  6160    Q:VALIV=1
  6161   "RTN","ORW DXM1",207, 0)
  6162    Q:$G(EDIT ONLY)
  6163   "RTN","ORW DXM1",208, 0)
  6164    I 'ORWMOD E,$P($G(^O RD(101.41, +ORDIALOG, 10,DA,0)), U,8) Q
  6165   "RTN","ORW DXM1",209, 0)
  6166    I ORWMODE ,($P($G(^O RD(101.41, +ORDIALOG, 10,DA,0)), U,9)'["W") ,'$P($G(^O RD(101.41, +ORDIALOG, 10,DA,0)), U,6)!$D(OR DIALOG(PRO MPT,INST))  Q
  6167   "RTN","ORW DXM1",210, 0)
  6168    I 'ORWMOD E,LST(0),$ D(ORDIALOG (PROMPT,IN ST)),($E(O RDIALOG(PR OMPT,0))=" W") Q
  6169   "RTN","ORW DXM1",211, 0)
  6170    I 'ORWMOD E,LST(0),' $P($G(^ORD (101.41,+O RDIALOG,10 ,DA,0)),U, 6) Q
  6171   "RTN","ORW DXM1",212, 0)
  6172    S XCODE=$ $SUBCODE($ G(^ORD(101 .41,+ORDIA LOG,10,DA, 3)))
  6173   "RTN","ORW DXM1",213, 0)
  6174    I $L(XCOD E) X XCODE  Q:'$T
  6175   "RTN","ORW DXM1",214, 0)
  6176    I $$ISGMR C(ORIT)&(P ROMPT=$$PT R("CLINICA LLY INDICA TED DATE") ) D  W !,M USTASK,! Q   ;WAT/397  enforce C ID req'd f or GMRC au to-ack
  6177   "RTN","ORW DXM1",215, 0)
  6178    . S MUSTA SK=1
  6179   "RTN","ORW DXM1",216, 0)
  6180    . S ORISP ROS=$$ISPR OS I +$G(O RISPROS)=1  S MUSTASK =0
  6181   "RTN","ORW DXM1",217, 0)
  6182    S MUSTASK =1
  6183   "RTN","ORW DXM1",218, 0)
  6184    Q
  6185   "RTN","ORW DXM1",219, 0)
  6186   SUBCODE(X)  ; substit ute code
  6187   "RTN","ORW DXM1",220, 0)
  6188    I X["$$RE QDCOMM^ORC DLR" Q "I  $$LRRQCM^O RWDXM2"
  6189   "RTN","ORW DXM1",221, 0)
  6190    I X["$$AS KSAMP^ORCD LR" Q "I $ $LRASMP^OR WDXM2"
  6191   "RTN","ORW DXM1",222, 0)
  6192    I X["$$SC HEDULD^ORC DRA1" Q "I  $$SCHEDUL D^ORWDXM2"
  6193   "RTN","ORW DXM1",223, 0)
  6194    I X["(^PS X(550,""C" ")" Q "S Y =$E($$DEFP ICK^ORWDPS 32) K:'$L( Y) Y"
  6195   "RTN","ORW DXM1",224, 0)
  6196    I X["I $$ ASKURG^ORC DVBEC" Q " I 1"
  6197   "RTN","ORW DXM1",225, 0)
  6198    I X["K:$G (ORASK)" Q  "I $G(ORA SK)"
  6199   "RTN","ORW DXM1",226, 0)
  6200    Q X
  6201   "RTN","ORW DXM1",227, 0)
  6202   PTR(NAME)  ; -- Retur ns pointer  to OR GTX  NAME
  6203   "RTN","ORW DXM1",228, 0)
  6204    Q +$O(^OR D(101.41," AB",$E("OR  GTX "_NAM E,1,63),0) )
  6205   "RTN","ORW DXM1",229, 0)
  6206    ;
  6207   "RTN","ORW DXM1",230, 0)
  6208   ISINPMED(I FN) ;
  6209   "RTN","ORW DXM1",231, 0)
  6210    N PKG,RES ULT,Y
  6211   "RTN","ORW DXM1",232, 0)
  6212    I 'ORWMOD E S PKG=$P ($G(^ORD(1 01.41,IFN, 0)),U,7)
  6213   "RTN","ORW DXM1",233, 0)
  6214    E  S PKG= $P($G(^OR( 100,+IFN,0 )),U,14)
  6215   "RTN","ORW DXM1",234, 0)
  6216    S Y=$$GET 1^DIQ(9.4, +PKG_",",1 )
  6217   "RTN","ORW DXM1",235, 0)
  6218    S RESULT= $S($E(Y,1, 3)="PSJ":1 ,1:0)
  6219   "RTN","ORW DXM1",236, 0)
  6220    Q RESULT
  6221   "RTN","ORW DXM1",237, 0)
  6222    ;
  6223   "RTN","ORW DXM1",238, 0)
  6224   ISMED(IFN)  ; return  1 if pharm acy order  dlg used
  6225   "RTN","ORW DXM1",239, 0)
  6226    N PKG
  6227   "RTN","ORW DXM1",240, 0)
  6228    I 'ORWMOD E S PKG=$P ($G(^ORD(1 01.41,IFN, 0)),U,7)
  6229   "RTN","ORW DXM1",241, 0)
  6230    E  S PKG= $P($G(^OR( 100,+IFN,0 )),U,14)
  6231   "RTN","ORW DXM1",242, 0)
  6232    Q $$NMSP^ ORCD(PKG)= "PS"
  6233   "RTN","ORW DXM1",243, 0)
  6234   SITEVAL()  ;return 1  if site do es want th e reason f or study t o carry th rough from  past orde rs of this  ordering  session
  6235   "RTN","ORW DXM1",244, 0)
  6236    I $$GET^X PAR("ALL^S RV.`"_+^VA (200,DUZ,5 ),"OR RA R FS CARRY O N")=0 Q 0
  6237   "RTN","ORW DXM1",245, 0)
  6238    Q 1
  6239   "RTN","ORW DXM1",246, 0)
  6240   SVRPC(RET, X) ;RPC FO R SITEVAL
  6241   "RTN","ORW DXM1",247, 0)
  6242    S RET=$$S ITEVAL
  6243   "RTN","ORW DXM1",248, 0)
  6244    Q
  6245   "RTN","ORW DXM1",249, 0)
  6246   ISQO(IFN)  ;return 1  if a non-V A medicati on quick o rder type  of order d ialog. p38 8
  6247   "RTN","ORW DXM1",250, 0)
  6248    I $P($G(^ ORD(101.41 ,IFN,0)),U ,5)'=$O(^O RD(100.98, "B","NV RX ",0)) Q 0
  6249   "RTN","ORW DXM1",251, 0)
  6250    I $P($G(^ ORD(101.41 ,IFN,0)),U ,4)="Q" Q  1
  6251   "RTN","ORW DXM1",252, 0)
  6252    Q 0
  6253   "RTN","ORW DXM1",253, 0)
  6254   ISGMRC(IFN ) ; return  1 if cons ults
  6255   "RTN","ORW DXM1",254, 0)
  6256    N OR99CON ,OR99PROC  S OR99CON= $O(^ORD(10 0.98,"B"," CONSULTS", "")),OR99P ROC=$O(^OR D(100.98," B","PROCED URES",""))
  6257   "RTN","ORW DXM1",255, 0)
  6258    Q:$P(^ORD (100.98,$G (OR99CON), 0),U)'="CO NSULTS"&($ P(^ORD(100 .98,$G(OR9 9PROC),0), U)'="PROCE DURES") 0
  6259   "RTN","ORW DXM1",256, 0)
  6260    ;I $P(^OR D(101.41,I FN,0),U,5) '=OR99CON& ($P(^ORD(1 01.41,IFN, 0),U,5)'=O R99PROC) Q  0 ;not co nsults
  6261   "RTN","ORW DXM1",257, 0)
  6262    Q:$P(^ORD (101.41,IF N,0),U,5)' =OR99CON&( $P(^ORD(10 1.41,IFN,0 ),U,5)'=OR 99PROC) 0  ;not consu lts
  6263   "RTN","ORW DXM1",258, 0)
  6264    Q 1
  6265   "RTN","ORW DXM1",259, 0)
  6266   ISPROS() ; return 1 i f OI is pr osthetics  service
  6267   "RTN","ORW DXM1",260, 0)
  6268    N ORDITM, ORCONSVC,O RG
  6269   "RTN","ORW DXM1",261, 0)
  6270    Q:'$D(ORD IALOG("B", "CONSULT T O SERVICE/ SPECIALTY" )) 0
  6271   "RTN","ORW DXM1",262, 0)
  6272    S ORDITM= $P((ORDIAL OG("B","CO NSULT TO S ERVICE/SPE CIALTY")), U,2)
  6273   "RTN","ORW DXM1",263, 0)
  6274    S ORDITM= $G(ORDIALO G(ORDITM,1 )) I $G(OR DITM)="" Q  0
  6275   "RTN","ORW DXM1",264, 0)
  6276    S ORCONSV C=$P(^ORD( 101.43,ORD ITM,0),U,2 ),ORCONSVC =$P(ORCONS VC,";",1)  Q:$G(ORCON SVC)="" 0
  6277   "RTN","ORW DXM1",265, 0)
  6278    D ISPROSV C^ORQQCN2( .ORG,ORCON SVC)
  6279   "RTN","ORW DXM1",266, 0)
  6280    I +$G(ORG )>0 Q 1
  6281   "RTN","ORW DXM1",267, 0)
  6282    Q 0
  6283   "RTN","ORW DXM3")
  6284   0^12^B1211 66242
  6285   "RTN","ORW DXM3",1,0)
  6286   ORWDXM3 ;  SLC/KCM/JL I - Quick  Orders ;Oc t 03, 2018 @13:54
  6287   "RTN","ORW DXM3",2,0)
  6288    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**1 0,85,131,1 32,141,185 ,187,190,1 95,215,243 ,303,296,2 80,350,434 ,441,397** ;Dec 17, 1 997;Build  17
  6289   "RTN","ORW DXM3",3,0)
  6290    ;
  6291   "RTN","ORW DXM3",4,0)
  6292    ;
  6293   "RTN","ORW DXM3",5,0)
  6294    ;
  6295   "RTN","ORW DXM3",6,0)
  6296   VALCOUNT(N AME,ORDIAL OG) ;
  6297   "RTN","ORW DXM3",7,0)
  6298    N COUNT,I EN,NUM
  6299   "RTN","ORW DXM3",8,0)
  6300    S NUM=0,C OUNT=0
  6301   "RTN","ORW DXM3",9,0)
  6302    S IEN=$P( $G(ORDIALO G("B",NAME )),U,2) Q: IEN'>0
  6303   "RTN","ORW DXM3",10,0 )
  6304    F  S NUM= $O(ORDIALO G(IEN,NUM) ) Q:+NUM'> 0  S COUNT =COUNT+1
  6305   "RTN","ORW DXM3",11,0 )
  6306    Q COUNT
  6307   "RTN","ORW DXM3",12,0 )
  6308    ;
  6309   "RTN","ORW DXM3",13,0 )
  6310   ISMISSFL(O RDIALOG,IV TYPE) ;
  6311   "RTN","ORW DXM3",14,0 )
  6312    N ADDCNT, RESULT,SOL CNT,STRCNT
  6313   "RTN","ORW DXM3",15,0 )
  6314    S RESULT= 0
  6315   "RTN","ORW DXM3",16,0 )
  6316    S ADDCNT= $$VALCOUNT ("ADDITIVE ",.ORDIALO G)
  6317   "RTN","ORW DXM3",17,0 )
  6318    S STRCNT= $$VALCOUNT ("STRENGTH ",.ORDIALO G)
  6319   "RTN","ORW DXM3",18,0 )
  6320    S SOLCNT= $$VALCOUNT ("SOLUTION ",.ORDIALO G)
  6321   "RTN","ORW DXM3",19,0 )
  6322    I IVTYPE' ="I",ADDCN T'=STRCNT  S RESULT=1
  6323   "RTN","ORW DXM3",20,0 )
  6324    I IVTYPE= "I" D
  6325   "RTN","ORW DXM3",21,0 )
  6326    .I ADDCNT =0,SOLCNT> 0 Q
  6327   "RTN","ORW DXM3",22,0 )
  6328    .I ADDCNT =0 S RESUL T=1 Q
  6329   "RTN","ORW DXM3",23,0 )
  6330    .I ADDCNT '=STRCNT S  RESULT=1  Q
  6331   "RTN","ORW DXM3",24,0 )
  6332    Q RESULT
  6333   "RTN","ORW DXM3",25,0 )
  6334    ;
  6335   "RTN","ORW DXM3",26,0 )
  6336   IVADFCHK(O RDIALOG) ;
  6337   "RTN","ORW DXM3",27,0 )
  6338    ; This li ne tag che cks to see  if there  are the sa me number  of values
  6339   "RTN","ORW DXM3",28,0 )
  6340    ;for ADDI TIVE and A dditive Fr equency. T his also c hecks to s ee if
  6341   "RTN","ORW DXM3",29,0 )
  6342    ;the valu e assigned  to ADDFRE Q is one o f the thre e possible  values
  6343   "RTN","ORW DXM3",30,0 )
  6344    ;All Bags , 1 bag/da y, See Com ments. If  See Commen ts it also  checks
  6345   "RTN","ORW DXM3",31,0 )
  6346    ;for text  in the co mment sect ion.
  6347   "RTN","ORW DXM3",32,0 )
  6348    N ADDCNT, ADDFCNT,AD DFREQ,COMM ENT,FREQ,I NST,RESULT
  6349   "RTN","ORW DXM3",33,0 )
  6350    S ADDCNT= $$VALCOUNT ("ADDITIVE ",.ORDIALO G)
  6351   "RTN","ORW DXM3",34,0 )
  6352    S ADDFCNT =$$VALCOUN T("ADDITIV E FREQUENC Y",.ORDIAL OG)
  6353   "RTN","ORW DXM3",35,0 )
  6354    I ADDCNT' =ADDFCNT Q  0
  6355   "RTN","ORW DXM3",36,0 )
  6356    S ADDFREQ =$O(^ORD(1 01.41,"AB" ,"OR GTX A DDITIVE FR EQUENCY"," "))
  6357   "RTN","ORW DXM3",37,0 )
  6358    S COMMENT =$O(^ORD(1 01.41,"AB" ,"OR GTX W ORD PROCES SING 1","" ))
  6359   "RTN","ORW DXM3",38,0 )
  6360    I +$G(ADD FREQ)'>0 Q  0
  6361   "RTN","ORW DXM3",39,0 )
  6362    S INST=0, RESULT=1
  6363   "RTN","ORW DXM3",40,0 )
  6364    F  S INST =$O(ORDIAL OG(ADDFREQ ,INST)) Q: INST'>0!(R ESULT=0)   D
  6365   "RTN","ORW DXM3",41,0 )
  6366    .S FREQ=$ $ADDFRQCV^ ORMBLDP1($ G(ORDIALOG (ADDFREQ,I NST)),"O")
  6367   "RTN","ORW DXM3",42,0 )
  6368    .I FREQ=" A"!(FREQ=1 ) Q
  6369   "RTN","ORW DXM3",43,0 )
  6370    .I FREQ=" " S RESULT =0 Q
  6371   "RTN","ORW DXM3",44,0 )
  6372    .I FREQ=" S",'$L($G( ORDIALOG(C OMMENT,1)) ) S RESULT =0 Q
  6373   "RTN","ORW DXM3",45,0 )
  6374    Q RESULT
  6375   "RTN","ORW DXM3",46,0 )
  6376    ;
  6377   "RTN","ORW DXM3",47,0 )
  6378   KEYVAR(DLG )  ; Parse  entry act ion for ke y variable s & return  in string
  6379   "RTN","ORW DXM3",48,0 )
  6380    ; RV=Coll Tp^Samp^Sp ec^CollDt^ Urg^Sched^ NoComm^NoD iag^NoProv ^NoRsn
  6381   "RTN","ORW DXM3",49,0 )
  6382    N XCODE,R V,POS,Z
  6383   "RTN","ORW DXM3",50,0 )
  6384    S XCODE=$ G(^ORD(101 .41,DLG,3) ),RV=""
  6385   "RTN","ORW DXM3",51,0 )
  6386    I '$L(XCO DE) Q ""
  6387   "RTN","ORW DXM3",52,0 )
  6388    S POS=$F( XCODE,"LRF ZX=")    I  POS S $P( RV,U,1)=$$ VALUE(XCOD E,POS)
  6389   "RTN","ORW DXM3",53,0 )
  6390    S POS=$F( XCODE,"LRF SAMP=")  I  POS S $P( RV,U,2)=$$ VALUE(XCOD E,POS)
  6391   "RTN","ORW DXM3",54,0 )
  6392    S POS=$F( XCODE,"LRF SPEC=")  I  POS S $P( RV,U,3)=$$ VALUE(XCOD E,POS)
  6393   "RTN","ORW DXM3",55,0 )
  6394    S POS=$F( XCODE,"LRF DATE=")  I  POS S $P( RV,U,4)=$$ VALUE(XCOD E,POS)
  6395   "RTN","ORW DXM3",56,0 )
  6396    S POS=$F( XCODE,"LRF URG=")   I  POS S $P( RV,U,5)=$$ VALUE(XCOD E,POS)
  6397   "RTN","ORW DXM3",57,0 )
  6398    S POS=$F( XCODE,"LRF SCH=")   I  POS S $P( RV,U,6)=$$ VALUE(XCOD E,POS)
  6399   "RTN","ORW DXM3",58,0 )
  6400    S POS=$F( XCODE,"PSJ NOPC=")  I  POS S $P( RV,U,7)=$$ VALUE(XCOD E,POS)
  6401   "RTN","ORW DXM3",59,0 )
  6402    S POS=$F( XCODE,"GMR CNOPD=") I  POS S $P( RV,U,8)=$$ VALUE(XCOD E,POS)
  6403   "RTN","ORW DXM3",60,0 )
  6404    S POS=$F( XCODE,"GMR CNOAT=") I  POS S $P( RV,U,9)=$$ VALUE(XCOD E,POS)
  6405   "RTN","ORW DXM3",61,0 )
  6406    S POS=$F( XCODE,"GMR CREAF=") I  POS S $P( RV,U,10)=$ $VALUE(XCO DE,POS)
  6407   "RTN","ORW DXM3",62,0 )
  6408    S POS=$F( XCODE,"ORF ORGET=") I  POS D
  6409   "RTN","ORW DXM3",63,0 )
  6410    . ; need  to change  this so th at it is e xecuted in  SETKEYV s o
  6411   "RTN","ORW DXM3",64,0 )
  6412    . ; that  it is exec uted each  time menu  is revisit ed
  6413   "RTN","ORW DXM3",65,0 )
  6414    . N ORFOR GET S ORFO RGET=$$VAL UE(XCODE,P OS)
  6415   "RTN","ORW DXM3",66,0 )
  6416    . I ORFOR GET K ^TMP ("ORECALL" ,$J,+ORFOR GET)
  6417   "RTN","ORW DXM3",67,0 )
  6418    . E  K ^T MP("ORECAL L",$J)
  6419   "RTN","ORW DXM3",68,0 )
  6420    Q RV
  6421   "RTN","ORW DXM3",69,0 )
  6422   VALUE(STR, BEG) ; Ret urn value  of "var="  (copied fr om ORCONVR T)
  6423   "RTN","ORW DXM3",70,0 )
  6424    N X,Y,I S  X=$E(STR, BEG,999),Y =""
  6425   "RTN","ORW DXM3",71,0 )
  6426    S:$E(X)=" """ X=$E(X ,2,999) ;  strip lead ing "
  6427   "RTN","ORW DXM3",72,0 )
  6428    F I=1:1:$ L(X) S Z=$ E(X,I) Q:( Z=",")!(Z= " ")!(Z="" "")  S Y=Y _Z
  6429   "RTN","ORW DXM3",73,0 )
  6430    Q $TR(Y,U ,"")
  6431   "RTN","ORW DXM3",74,0 )
  6432    ;
  6433   "RTN","ORW DXM3",75,0 )
  6434   SETKEYV(X)       ; Se t the key  variables  based on c ontents of  X
  6435   "RTN","ORW DXM3",76,0 )
  6436    I $L($P(X ,U,1))  S  LRFZX=$P(X ,U,1)
  6437   "RTN","ORW DXM3",77,0 )
  6438    I $L($P(X ,U,2))  S  LRFSAMP=$P (X,U,2)
  6439   "RTN","ORW DXM3",78,0 )
  6440    I $L($P(X ,U,3))  S  LRFSPEC=$P (X,U,3)
  6441   "RTN","ORW DXM3",79,0 )
  6442    I $L($P(X ,U,4))  S  LRFDATE=$P (X,U,4)
  6443   "RTN","ORW DXM3",80,0 )
  6444    I $L($P(X ,U,5))  S  LRFURG=$P( X,U,5)
  6445   "RTN","ORW DXM3",81,0 )
  6446    I $L($P(X ,U,6))  S  LRFSCH=$P( X,U,6)
  6447   "RTN","ORW DXM3",82,0 )
  6448    I $L($P(X ,U,7))  S  PSJNOPC=$P (X,U,7)
  6449   "RTN","ORW DXM3",83,0 )
  6450    I $L($P(X ,U,8))  S  GMRCNOPD=$ P(X,U,8)
  6451   "RTN","ORW DXM3",84,0 )
  6452    I $L($P(X ,U,9))  S  GMRCNOAT=$ P(X,U,9)
  6453   "RTN","ORW DXM3",85,0 )
  6454    I $L($P(X ,U,10)) S  GMRCREAF=$ P(X,U,10)
  6455   "RTN","ORW DXM3",86,0 )
  6456    Q
  6457   "RTN","ORW DXM3",87,0 )
  6458   DLGINFO(IE N,MODE)     ; return  informatio n about a  dialog
  6459   "RTN","ORW DXM3",88,0 )
  6460    ; IEN=Dlg IEN or ORI FN, MODE=0 :Dlg,1:Cop y,2:Change
  6461   "RTN","ORW DXM3",89,0 )
  6462    ; RESULT= DlgIEN^Dlg Type^FormI D^DGrp
  6463   "RTN","ORW DXM3",90,0 )
  6464    ; If MODE ="1;T",don 't check " PS MEDS" f or transfe r order
  6465   "RTN","ORW DXM3",91,0 )
  6466    ; PSMDGP= 1: Unit/Do se  Group
  6467   "RTN","ORW DXM3",92,0 )
  6468    ; PSMDGP= 2: OutPati ent Group
  6469   "RTN","ORW DXM3",93,0 )
  6470    N X0,DLGI EN,TYP,FID ,DGRP,PSMD GP,ISXF
  6471   "RTN","ORW DXM3",94,0 )
  6472    S PSMDGP= 0,ISXF=""
  6473   "RTN","ORW DXM3",95,0 )
  6474    S ISXF=$P (MODE,";", 2)
  6475   "RTN","ORW DXM3",96,0 )
  6476    S MODE=+M ODE
  6477   "RTN","ORW DXM3",97,0 )
  6478    S DLGIEN= IEN I MODE ,(ISXF'="T ") D
  6479   "RTN","ORW DXM3",98,0 )
  6480    . S DLGIE N=+$P($G(^ OR(100,+IE N,0)),U,5)
  6481   "RTN","ORW DXM3",99,0 )
  6482    . I $P(^O RD(101.41, DLGIEN,0), U)="PS MED S" D
  6483   "RTN","ORW DXM3",100, 0)
  6484    . . N PTC AT S PTCAT =$P($G(^OR (100,+IEN, 0)),U,12)
  6485   "RTN","ORW DXM3",101, 0)
  6486    . . I PTC AT="I" S D LGIEN=$O(^ ORD(101.41 ,"B","PSJ  OR PAT OE" ,0)),PSMDG P=1
  6487   "RTN","ORW DXM3",102, 0)
  6488    . . I PTC AT="O" S D LGIEN=$O(^ ORD(101.41 ,"B","PSO  OERR",0)), PSMDGP=2
  6489   "RTN","ORW DXM3",103, 0)
  6490    I MODE,(I SXF="T") S  DLGIEN=+$ P($G(^OR(1 00,+IEN,0) ),U,5)
  6491   "RTN","ORW DXM3",104, 0)
  6492    S X0=$G(^ ORD(101.41 ,DLGIEN,0) ),TYP=$P(X 0,U,4),DGR P=$P(X0,U, 5)
  6493   "RTN","ORW DXM3",105, 0)
  6494    I MODE S  DGRP=+$P($ G(^OR(100, +IEN,0)),U ,11)
  6495   "RTN","ORW DXM3",106, 0)
  6496    ;JD NEW S TART 11/13 /02
  6497   "RTN","ORW DXM3",107, 0)
  6498    I DLGIEN= $O(^ORD(10 1.41,"B"," PSJ OR PAT  OE",0)) S  PSMDGP=1
  6499   "RTN","ORW DXM3",108, 0)
  6500    I DLGIEN= $O(^ORD(10 1.41,"B"," PSO OERR", 0)) S PSMD GP=2
  6501   "RTN","ORW DXM3",109, 0)
  6502    ;JD NEW E ND 11/13/0 2
  6503   "RTN","ORW DXM3",110, 0)
  6504    ; for cop y or chang e, if the  base dialo g has chan ged, use i t's info
  6505   "RTN","ORW DXM3",111, 0)
  6506    I MODE,$G (ORDIALOG) ,(+DLGIEN' =+ORDIALOG ),(PSMDGP= 0) D
  6507   "RTN","ORW DXM3",112, 0)
  6508    . S DLGIE N=+ORDIALO G,DGRP=$P( ^ORD(101.4 1,+ORDIALO G,0),U,5)
  6509   "RTN","ORW DXM3",113, 0)
  6510    D FORMID^ ORWDXM(.FI D,DLGIEN)
  6511   "RTN","ORW DXM3",114, 0)
  6512    Q DLGIEN_ U_TYP_U_FI D_U_DGRP
  6513   "RTN","ORW DXM3",115, 0)
  6514    ;
  6515   "RTN","ORW DXM3",116, 0)
  6516   CHKDSBL(LS T,ID,MODE)   ; return  message i f dialog d isabled
  6517   "RTN","ORW DXM3",117, 0)
  6518    ; ID=DlgI EN or ORIF N, MODE=0: Dialog,1:C opy,2:Chan ge
  6519   "RTN","ORW DXM3",118, 0)
  6520    ; LST=QL_ REJECT + d isabled me ssage or u nchanged
  6521   "RTN","ORW DXM3",119, 0)
  6522    N PKG
  6523   "RTN","ORW DXM3",120, 0)
  6524    S DLGIEN= +ID I MODE  S DLGIEN= +$P($G(^OR (100,+ID,0 )),U,5)
  6525   "RTN","ORW DXM3",121, 0)
  6526    S X0=$G(^ ORD(101.41 ,DLGIEN,0) ),X=$P(X0, U,3)
  6527   "RTN","ORW DXM3",122, 0)
  6528    I '$L(X), ($P(X0,U,4 )="Q") D   ; check de fault dial og
  6529   "RTN","ORW DXM3",123, 0)
  6530    . S DLGIE N=+$$DEFDL G^ORWDXQ($ P(X0,U,5))
  6531   "RTN","ORW DXM3",124, 0)
  6532    . S X=$P( $G(^ORD(10 1.41,DLGIE N,0)),U,3)
  6533   "RTN","ORW DXM3",125, 0)
  6534    I $L(X) D
  6535   "RTN","ORW DXM3",126, 0)
  6536    . I MODE  D GETTXT^O RWORR(.LST ,ID) S LST (.6)="",LS T(.7)="Can not "_$S(M ODE=1:"Cop y",1:"Chan ge")_" -"
  6537   "RTN","ORW DXM3",127, 0)
  6538    . S LST(0 )="8^0",LS T(.5)="Dia log Disabl ed:  "_X
  6539   "RTN","ORW DXM3",128, 0)
  6540    S PKG=$P( X0,"^",7)  I PKG]"",$ P($G(^DIC( 9.4,PKG,0) ),"^",2)=" SD",'$$PAT CH^XPDUTL( "SD*5.3*67 1") S LST( 0)="8^0",L ST(.5)="Di alog Disab led: VSE p atch SD*5. 3*671 not  installed"
  6541   "RTN","ORW DXM3",129, 0)
  6542    Q
  6543   "RTN","ORW DXM3",130, 0)
  6544   CHKVACT(LS T,ID,MODE, ORNP)  ; r eturn mess age if act ion not va lid
  6545   "RTN","ORW DXM3",131, 0)
  6546    ; ID=DlgI EN or ORIF N, MODE=0: Dialog,1:C opy,2:Chan ge
  6547   "RTN","ORW DXM3",132, 0)
  6548    ; LST=QL_ REJECT + i nvalid act ion messag e or uncha nged
  6549   "RTN","ORW DXM3",133, 0)
  6550    Q:'MODE   ; not an a ction on a n order
  6551   "RTN","ORW DXM3",134, 0)
  6552    N X,ACT S  ACT=$S(MO DE=1:"RW", MODE=2:"XX ",1:"")
  6553   "RTN","ORW DXM3",135, 0)
  6554    D VALID^O RWDXA(.X,I D,ACT,ORNP )
  6555   "RTN","ORW DXM3",136, 0)
  6556    I $L(X) D  GETTXT^OR WORR(.LST, ID) D
  6557   "RTN","ORW DXM3",137, 0)
  6558    . S LST(0 )="8^0",LS T(.5)=X,LS T(.6)="",L ST(.7)="Ca nnot "_$S( MODE=1:"Co py",1:"Cha nge")_" -"
  6559   "RTN","ORW DXM3",138, 0)
  6560    Q
  6561   "RTN","ORW DXM3",139, 0)
  6562   CHKCOPY(LS T,ID,FLDS)   ; return  message i f can't co py this or der
  6563   "RTN","ORW DXM3",140, 0)
  6564    ; ID=ORIF N;ACT FLDS =EventType  in 7th pi ece
  6565   "RTN","ORW DXM3",141, 0)
  6566    ; LST=QL_ REJECT + c annot copy  message o r unchange d
  6567   "RTN","ORW DXM3",142, 0)
  6568    I "^A^D^T ^"'[(U_$E( $P(FLDS,U, 7))_U) Q               ; not eve nt delayed
  6569   "RTN","ORW DXM3",143, 0)
  6570    N PKG S P KG=$P($G(^ OR(100,+ID ,0)),U,14)
  6571   "RTN","ORW DXM3",144, 0)
  6572    S PKG=$$N MSP^ORCD(P KG) I PKG= "OR"!(PKG= "PS") Q     ; xfer me ds, generi cs
  6573   "RTN","ORW DXM3",145, 0)
  6574    N ORWCAT  S ORWCAT=$ P($G(^OR(1 00,+ID,0)) ,U,12)
  6575   "RTN","ORW DXM3",146, 0)
  6576    I ORWCAT= "I",("^A^T ^"[(U_$E($ P(FLDS,U,7 ))_U)) Q    ; admit,  xfer inpt
  6577   "RTN","ORW DXM3",147, 0)
  6578    I ORWCAT= "O",$E($P( FLDS,U,7)) ="D" Q                 ; dischar ge outpt
  6579   "RTN","ORW DXM3",148, 0)
  6580    D GETTXT^ ORWORR(.LS T,ID)
  6581   "RTN","ORW DXM3",149, 0)
  6582    I ORWCAT= "I" S LST( .5)="inpat ient order  to outpat ient -"
  6583   "RTN","ORW DXM3",150, 0)
  6584    I ORWCAT= "O" S LST( .5)="outpa tient orde r to inpat ient -"
  6585   "RTN","ORW DXM3",151, 0)
  6586    S:$D(LST( .5)) LST(. 5)="Cannot  copy the  following  "_LST(.5)
  6587   "RTN","ORW DXM3",152, 0)
  6588    S LST(0)= "8^0",LST( .7)=""
  6589   "RTN","ORW DXM3",153, 0)
  6590    Q
  6591   "RTN","ORW DXM3",154, 0)
  6592   BLD4CHG(LS T,ID,FLDS)   ; build  responses  for an edi t
  6593   "RTN","ORW DXM3",155, 0)
  6594    ; ID=ORIF N;ACT FLDS =unused ri ght now
  6595   "RTN","ORW DXM3",156, 0)
  6596    ; LST(0)= Qlvl^RespI D(XOrderID )^DlgIEN^D lgType^For mID^DGrp
  6597   "RTN","ORW DXM3",157, 0)
  6598    N OIDX,OI ,CNT
  6599   "RTN","ORW DXM3",158, 0)
  6600    S (OI,OID X,CNT)=0
  6601   "RTN","ORW DXM3",159, 0)
  6602    S:$D(^OR( 100,+ID,4. 5,"ID","OR DERABLE"))  OIDX=$O(^ OR(100,+ID ,4.5,"ID", "ORDERABLE ",0))
  6603   "RTN","ORW DXM3",160, 0)
  6604    I $D(^OR( 100,+ID,4. 5,OIDX)) D
  6605   "RTN","ORW DXM3",161, 0)
  6606    . F  S CN T=$O(^OR(1 00,+ID,4.5 ,OIDX,CNT) ) Q:'CNT   D
  6607   "RTN","ORW DXM3",162, 0)
  6608    . . S OI= ^(CNT) D V ALDOI
  6609   "RTN","ORW DXM3",163, 0)
  6610    I +LST(0) =8 S LST(. 5)="You ca n not chan ge this or der." Q
  6611   "RTN","ORW DXM3",164, 0)
  6612    S LST(0)= "0^X"_ID_U _$$DLGINFO (+ID,2)
  6613   "RTN","ORW DXM3",165, 0)
  6614    S $P(LST( 0),U,4)="X "
  6615   "RTN","ORW DXM3",166, 0)
  6616    Q
  6617   "RTN","ORW DXM3",167, 0)
  6618   GETIVTYP()  ;
  6619   "RTN","ORW DXM3",168, 0)
  6620    N RESULT, TYPEIEN
  6621   "RTN","ORW DXM3",169, 0)
  6622    S RESULT= ""
  6623   "RTN","ORW DXM3",170, 0)
  6624    S TYPEIEN =$O(^ORD(1 01.41,"B", "OR GTX IV  TYPE","") ) I TYPEIE N'>0 Q RES ULT
  6625   "RTN","ORW DXM3",171, 0)
  6626    S RESULT= $G(ORDIALO G(TYPEIEN, 1))
  6627   "RTN","ORW DXM3",172, 0)
  6628    Q RESULT
  6629   "RTN","ORW DXM3",173, 0)
  6630    ;
  6631   "RTN","ORW DXM3",174, 0)
  6632   VALDOI ; V alidate th e Orderabl e Items
  6633   "RTN","ORW DXM3",175, 0)
  6634    N ORQUIT, ORPS
  6635   "RTN","ORW DXM3",176, 0)
  6636    I $G(^ORD (101.43,OI ,.1)),^(.1 )'>$$NOW^X LFDT D
  6637   "RTN","ORW DXM3",177, 0)
  6638    . S ORQUI T=1
  6639   "RTN","ORW DXM3",178, 0)
  6640    . S LST(0 )="8^0"
  6641   "RTN","ORW DXM3",179, 0)
  6642    I $D(ORQU IT) Q:ORQU IT
  6643   "RTN","ORW DXM3",180, 0)
  6644    S ORPS=$G (^ORD(101. 43,+OI,"PS "))
  6645   "RTN","ORW DXM3",181, 0)
  6646    I $P(ORPS ,U,1,4)="0 ^0^0^0",($ P(ORPS,U,7 )=0) S LST (0)="8^0"
  6647   "RTN","ORW DXM3",182, 0)
  6648    Q
  6649   "RTN","ORW DXM3",183, 0)
  6650   VERDUR(ORD IALOG) ;
  6651   "RTN","ORW DXM3",184, 0)
  6652    ;check fo r duration  value if  a THEN con junation i s used
  6653   "RTN","ORW DXM3",185, 0)
  6654    N CONJ,CO NVALUE,DUR ,I,SUCC
  6655   "RTN","ORW DXM3",186, 0)
  6656    S SUCC=1
  6657   "RTN","ORW DXM3",187, 0)
  6658    S CONJ=$$ PTR^ORCDPS 1("AND/THE N")
  6659   "RTN","ORW DXM3",188, 0)
  6660    S DUR=$$P TR^ORCDPS1 ("DURATION ")
  6661   "RTN","ORW DXM3",189, 0)
  6662    S I=0 F   S I=$O(ORD IALOG(CONJ ,I)) Q:I'> 0!(SUCC=0)   D
  6663   "RTN","ORW DXM3",190, 0)
  6664    . I $$UP^ XLFSTR($E( $G(ORDIALO G(CONJ,I)) ,1))="T" D
  6665   "RTN","ORW DXM3",191, 0)
  6666    . . I '$L ($G(ORDIAL OG(DUR,I)) ) S SUCC=0
  6667   "RTN","ORW DXM3",192, 0)
  6668    Q SUCC
  6669   "RTN","ORW DXM3",193, 0)
  6670    ;
  6671   "RTN","ORW DXM3",194, 0)
  6672   VERORD(OIE N) ;
  6673   "RTN","ORW DXM3",195, 0)
  6674    N IFN,INF USE,INFUID ,ODG,ODP,A SSIV,SUCC, TYPE
  6675   "RTN","ORW DXM3",196, 0)
  6676    S SUCC=0, IFN=ORDIAL OG
  6677   "RTN","ORW DXM3",197, 0)
  6678    S ODP=+$P ($G(^ORD(1 01.41,+IFN ,0)),U,7), ODG=+$P($G (^(0)),U,5 )
  6679   "RTN","ORW DXM3",198, 0)
  6680    S ODP=$$G ET1^DIQ(9. 4,+ODP_"," ,1),ODG=$P ($G(^ORD(1 00.98,ODG, 0)),U,3)
  6681   "RTN","ORW DXM3",199, 0)
  6682    I ODP'["P S" Q 1
  6683   "RTN","ORW DXM3",200, 0)
  6684    I ODP="PS H" Q 1
  6685   "RTN","ORW DXM3",201, 0)
  6686    ;check in fusion rat e for IV Q O
  6687   "RTN","ORW DXM3",202, 0)
  6688    I ODG="IV  RX"!(ODG= "TPN") D   Q SUCC
  6689   "RTN","ORW DXM3",203, 0)
  6690    .S TYPE=$ $GETIVTYP
  6691   "RTN","ORW DXM3",204, 0)
  6692    .I TYPE=" "
  6693   "RTN","ORW DXM3",205, 0)
  6694    .S PASSIV =$$IVRTECH K
  6695   "RTN","ORW DXM3",206, 0)
  6696    .I PASSIV =0
  6697   "RTN","ORW DXM3",207, 0)
  6698    .S INFUID =$O(^ORD(1 01.41,"B", "OR GTX IN FUSION RAT E",0))
  6699   "RTN","ORW DXM3",208, 0)
  6700    .S INFUSE =$G(ORDIAL OG(INFUID, 1))
  6701   "RTN","ORW DXM3",209, 0)
  6702    .S SUCC=$ $VALINF(TY PE,INFUSE)
  6703   "RTN","ORW DXM3",210, 0)
  6704    .I SUCC=0  Q
  6705   "RTN","ORW DXM3",211, 0)
  6706    .I TYPE=" C" S SUCC= $$IVADFCHK (.ORDIALOG )
  6707   "RTN","ORW DXM3",212, 0)
  6708    I (ODP="P SJ")!(ODP= "PSO"),ODG '="IV RX", ODG'="TPN"  S SUCC=$$ VERDUR(.OR DIALOG)
  6709   "RTN","ORW DXM3",213, 0)
  6710    Q SUCC
  6711   "RTN","ORW DXM3",214, 0)
  6712    ;
  6713   "RTN","ORW DXM3",215, 0)
  6714   VALINF(TYP E,INFUSE)  ;
  6715   "RTN","ORW DXM3",216, 0)
  6716    N SUCC
  6717   "RTN","ORW DXM3",217, 0)
  6718    S SUCC=0
  6719   "RTN","ORW DXM3",218, 0)
  6720    I TYPE="I " D  Q SUC C
  6721   "RTN","ORW DXM3",219, 0)
  6722    .I INFUSE ="" S SUCC =1 Q
  6723   "RTN","ORW DXM3",220, 0)
  6724    .I $TR(IN FUSE,"abcd efghijklmn opqrstuvwx yz","ABCDE FGHIJKLMNO PQRSTUVWXY Z")["INFUS E OVER" S  SUCC=1 Q
  6725   "RTN","ORW DXM3",221, 0)
  6726    .I $L(INF USE)>4 Q
  6727   "RTN","ORW DXM3",222, 0)
  6728    Q 1
  6729   "RTN","ORW DXM3",223, 0)
  6730    ;
  6731   "RTN","ORW DXM3",224, 0)
  6732   VALQO(IFN)  ;Check to  see if it 's a good  QO med
  6733   "RTN","ORW DXM3",225, 0)
  6734    ;If it's  an IV QO:  check if i nfusion ra te entered
  6735   "RTN","ORW DXM3",226, 0)
  6736    ;If it's  an UD QO:  check if d osage ente red
  6737   "RTN","ORW DXM3",227, 0)
  6738    ;regular  order trea ted as goo d QO
  6739   "RTN","ORW DXM3",228, 0)
  6740    ;
  6741   "RTN","ORW DXM3",229, 0)
  6742    I IFN[";" ,($$UPCTCH K^ORWDXA(+ IFN)) Q 0
  6743   "RTN","ORW DXM3",230, 0)
  6744    I $P($G(^ ORD(101.41 ,IFN,0)),U ,4)'="Q" Q  1
  6745   "RTN","ORW DXM3",231, 0)
  6746    N ODP,ODG ,INFUID,IN FUSE,DSAGE ID,SUCC,PA SSIV,TYPE, PRIORID,DO NEID,OK
  6747   "RTN","ORW DXM3",232, 0)
  6748    S SUCC=0
  6749   "RTN","ORW DXM3",233, 0)
  6750    S ODP=+$P ($G(^ORD(1 01.41,IFN, 0)),U,7),O DG=+$P($G( ^(0)),U,5)
  6751   "RTN","ORW DXM3",234, 0)
  6752    S ODP=$$G ET1^DIQ(9. 4,+ODP_"," ,1),ODG=$P ($G(^ORD(1 00.98,ODG, 0)),U,3)
  6753   "RTN","ORW DXM3",235, 0)
  6754    I ODP'["P S" Q 1
  6755   "RTN","ORW DXM3",236, 0)
  6756    I ODP="PS H" Q 1
  6757   "RTN","ORW DXM3",237, 0)
  6758    ;check fo r DONE urg ency/prior ity on Out patient QO
  6759   "RTN","ORW DXM3",238, 0)
  6760    I ODG="O  RX" D  Q:' OK 0
  6761   "RTN","ORW DXM3",239, 0)
  6762    . S OK=1, PRIORID=$O (^ORD(101. 41,"B","OR  GTX URGEN CY",0)) Q: 'PRIORID
  6763   "RTN","ORW DXM3",240, 0)
  6764    . S DONEI D=$O(^ORD( 101.42,"B" ,"DONE",0) ) Q:'DONEI D
  6765   "RTN","ORW DXM3",241, 0)
  6766    . I $G(OR DIALOG(PRI ORID,1))=D ONEID S OK =0
  6767   "RTN","ORW DXM3",242, 0)
  6768    ;check in fusion rat e for IV Q O
  6769   "RTN","ORW DXM3",243, 0)
  6770    I ODG="IV  RX"!(ODG= "TPN")!(OD G="CI RX")  D
  6771   "RTN","ORW DXM3",244, 0)
  6772    . S INFUI D=$O(^ORD( 101.41,"B" ,"OR GTX I NFUSION RA TE",0))
  6773   "RTN","ORW DXM3",245, 0)
  6774    . S TYPE= $$GETIVTYP
  6775   "RTN","ORW DXM3",246, 0)
  6776    . I TYPE= "" Q
  6777   "RTN","ORW DXM3",247, 0)
  6778    . I $D(OR DIALOG(INF UID,1)) D
  6779   "RTN","ORW DXM3",248, 0)
  6780    . . I TYP E="I" D  Q
  6781   "RTN","ORW DXM3",249, 0)
  6782    . . . S I NFUSE=$G(O RDIALOG(IN FUID,1))
  6783   "RTN","ORW DXM3",250, 0)
  6784    . . . I I NFUSE="" Q
  6785   "RTN","ORW DXM3",251, 0)
  6786    . . . I I NFUSE["INF USE OVER"  S SUCC=1 Q
  6787   "RTN","ORW DXM3",252, 0)
  6788    . . . I $ L(INFUSE)> 4 Q
  6789   "RTN","ORW DXM3",253, 0)
  6790    . . . I + INFUSE>0 S  INFUSE="I NFUSE OVER  "_INFUSE_ " Minutes"
  6791   "RTN","ORW DXM3",254, 0)
  6792    . . . S O RDIALOG(IN FUID,1)=IN FUSE,SUCC= 1
  6793   "RTN","ORW DXM3",255, 0)
  6794    . . S SUC C=1
  6795   "RTN","ORW DXM3",256, 0)
  6796    . ; addit ive freque ncy check/ infusion r ate checks  for conti nuous orde rs
  6797   "RTN","ORW DXM3",257, 0)
  6798    . I TYPE= "C" D  I S UCC=0 Q
  6799   "RTN","ORW DXM3",258, 0)
  6800    . . I $D( ORDIALOG(I NFUID,1))  S SUCC=1 I  SUCC=0 Q
  6801   "RTN","ORW DXM3",259, 0)
  6802    . . S SUC C=$$IVADFC HK(.ORDIAL OG)
  6803   "RTN","ORW DXM3",260, 0)
  6804    . I SUCC= 0 Q
  6805   "RTN","ORW DXM3",261, 0)
  6806    . I '$D(O RDIALOG(IN FUID,1)),T YPE="I" S  SUCC=1
  6807   "RTN","ORW DXM3",262, 0)
  6808    . S PASSI V=$$IVRTEC HK
  6809   "RTN","ORW DXM3",263, 0)
  6810    . I SUCC= 0 Q
  6811   "RTN","ORW DXM3",264, 0)
  6812    . I PASSI V=0 S SUCC =0
  6813   "RTN","ORW DXM3",265, 0)
  6814    . I SUCC= 1,$$ISMISS FL(.ORDIAL OG,TYPE)=1  S SUCC=0
  6815   "RTN","ORW DXM3",266, 0)
  6816    ;check do sage for U D QO
  6817   "RTN","ORW DXM3",267, 0)
  6818    I (ODP="P SJ")!(ODP= "PSO"),ODG '="IV RX", ODG'="TPN"  D
  6819   "RTN","ORW DXM3",268, 0)
  6820    . S DSAGE ID=$O(^ORD (101.41,"B ","OR GTX  INSTRUCTIO NS",0))
  6821   "RTN","ORW DXM3",269, 0)
  6822    . I $D(OR DIALOG(DSA GEID,1)) S  SUCC=1
  6823   "RTN","ORW DXM3",270, 0)
  6824    . I SUCC= 0 Q
  6825   "RTN","ORW DXM3",271, 0)
  6826    . ;
  6827   "RTN","ORW DXM3",272, 0)
  6828    . S SUCC= $$VERDUR(. ORDIALOG)
  6829   "RTN","ORW DXM3",273, 0)
  6830    ;
  6831   "RTN","ORW DXM3",274, 0)
  6832    I SUCC=1, $P($G(^ORD (101.41,IF N,5)),U,8)  D
  6833   "RTN","ORW DXM3",275, 0)
  6834    .N COMMID ,WPCNT
  6835   "RTN","ORW DXM3",276, 0)
  6836    .S COMMID =$O(^ORD(1 01.41,"B", "OR GTX WO RD PROCESS ING 1",0))
  6837   "RTN","ORW DXM3",277, 0)
  6838    .S COMMID =$O(^ORD(1 01.41,IFN, 6,"D",COMM ID,0))
  6839   "RTN","ORW DXM3",278, 0)
  6840    .I COMMID  S WPCNT=0  F  S WPCN T=$O(^ORD( 101.41,IFN ,6,COMMID, 2,WPCNT))  Q:'WPCNT!( 'SUCC)  D
  6841   "RTN","ORW DXM3",279, 0)
  6842    ..I ^ORD( 101.41,IFN ,6,COMMID, 2,WPCNT,0) ["^" S SUC C=0
  6843   "RTN","ORW DXM3",280, 0)
  6844    Q SUCC
  6845   "RTN","ORW DXM3",281, 0)
  6846    ;
  6847   "RTN","ORW DXM3",282, 0)
  6848   IVRTECHK()  ;
  6849   "RTN","ORW DXM3",283, 0)
  6850    N RTIEN,R TVALUE,RES ULT
  6851   "RTN","ORW DXM3",284, 0)
  6852    N CNT,NUM ,ORDERIDS, OIIEN,OTYP E,ROUTE
  6853   "RTN","ORW DXM3",285, 0)
  6854    S CNT=0,R ESULT=0
  6855   "RTN","ORW DXM3",286, 0)
  6856    S RTIEN=+ $P($G(ORDI ALOG("B"," ROUTE")),U ,2) I RTIE N'>0 Q RES ULT
  6857   "RTN","ORW DXM3",287, 0)
  6858    S RTVALUE =+$G(ORDIA LOG(RTIEN, 1)) I RTVA LUE'>0 Q R ESULT
  6859   "RTN","ORW DXM3",288, 0)
  6860    F OTYPE=" SOLUTION", "ADDITIVE"  D
  6861   "RTN","ORW DXM3",289, 0)
  6862    .S OIIEN= +$P($G(ORD IALOG("B", OTYPE)),U, 2) I OIIEN >0 D
  6863   "RTN","ORW DXM3",290, 0)
  6864    ..S NUM=0  F  S NUM= $O(ORDIALO G(OIIEN,NU M)) Q:NUM' >0  I +$G( ORDIALOG(O IIEN,NUM)) >0 D
  6865   "RTN","ORW DXM3",291, 0)
  6866    ...S CNT= CNT+1,ORDE RIDS(CNT)= ORDIALOG(O IIEN,NUM)
  6867   "RTN","ORW DXM3",292, 0)
  6868    I $D(ORDE RIDS)=0 Q
  6869   "RTN","ORW DXM3",293, 0)
  6870    S ROUTE=$ $IVQOVAL^O RWDPS33(.O RDERIDS,RT VALUE)
  6871   "RTN","ORW DXM3",294, 0)
  6872    I ROUTE=" " S ORDIAL OG(RTIEN,1 )=ROUTE
  6873   "RTN","ORW DXM3",295, 0)
  6874    I ROUTE'= "" S RESUL T=1
  6875   "RTN","ORW DXM3",296, 0)
  6876    ;K ^TMP($ J,"ORWDXM3  IVRTECHK" )
  6877   "RTN","ORW DXM3",297, 0)
  6878    ;D ALL^PS S51P2(RTVA LUE,,,,"OR WDXM3 IVRT ECHK")
  6879   "RTN","ORW DXM3",298, 0)
  6880    ;I +^TMP( $J,"ORWDXM 3 IVRTECHK ",RTVALUE, 6)'=1 S OR DIALOG(RTI EN,1)="",R ESULT=0
  6881   "RTN","ORW DXM3",299, 0)
  6882    ;K ^TMP($ J,"ORWDXM3  IVRTECHK" )
  6883   "RTN","ORW DXM3",300, 0)
  6884    Q RESULT
  6885   "RTN","ORW DXM3",301, 0)
  6886    ;
  6887   "RTN","ORW DXM3",302, 0)
  6888   ISUDQO(ORY ,DLGID) ;T rue: is un it dose qu ick order
  6889   "RTN","ORW DXM3",303, 0)
  6890    S ORY=0
  6891   "RTN","ORW DXM3",304, 0)
  6892    Q:'$D(^OR D(101.41,D LGID,0))
  6893   "RTN","ORW DXM3",305, 0)
  6894    N CLODGRP ,CLIVDGRP, UDGRP1,UDG RP2,DLGTYP ,DLGGRP
  6895   "RTN","ORW DXM3",306, 0)
  6896    S UDGRP1= $O(^ORD(10 0.98,"B"," UD RX",0))
  6897   "RTN","ORW DXM3",307, 0)
  6898    S UDGRP2= $O(^ORD(10 0.98,"B"," I RX",0))
  6899   "RTN","ORW DXM3",308, 0)
  6900    S CLODGRP =$O(^ORD(1 00.98,"B", "CLINIC ME DICATIONS" ,""))
  6901   "RTN","ORW DXM3",309, 0)
  6902    S CLIVDGR P=$O(^ORD( 100.98,"B" ,"CLINIC I NFUSIONS", ""))
  6903   "RTN","ORW DXM3",310, 0)
  6904    S DLGTYP= $P($G(^ORD (101.41,DL GID,0)),U, 4)
  6905   "RTN","ORW DXM3",311, 0)
  6906    I DLGTYP= "Q" D VERI FY^ORQOAUI C(.ORORN1, DLGID) I $ G(ORORN1)  D
  6907   "RTN","ORW DXM3",312, 0)
  6908    . S ^TMP( "OR QUICK  ORDER AUDI T",$J,"DLG ID")=DLGID  ;RTW
  6909   "RTN","ORW DXM3",313, 0)
  6910    S DLGGRP= $P($G(^ORD (101.41,DL GID,0)),U, 5)
  6911   "RTN","ORW DXM3",314, 0)
  6912    I (DLGTYP ="Q"),((DL GGRP=UDGRP 1)!(DLGGRP =UDGRP2)!( DLGGRP=CLO DGRP)!(DLG GRP=CLIVDG RP)) S ORY =1
  6913   "RTN","ORW DXM3",315, 0)
  6914    Q
  6915   "RTN","ORW DXM3",316, 0)
  6916    ;
  6917   "RTN","ORW DXM3",317, 0)
  6918   SDRTCVER(O RDIALOG) ;
  6919   "RTN","ORW DXM3",318, 0)
  6920    ;Return t o Clinic Q O verifier
  6921   "RTN","ORW DXM3",319, 0)
  6922    I +$$VAL^ ORCD("NUMB ER OF APPO INTMENTS") >1,+$$VAL^ ORCD("INTE RVAL")<1 Q  0
  6923   "RTN","ORW DXM3",320, 0)
  6924    I +$$VAL^ ORCD("NUMB ER OF APPO INTMENTS") =1,+$$VAL^ ORCD("INTE RVAL")>0 Q  0
  6925   "RTN","ORW DXM3",321, 0)
  6926    Q 1
  6927   "RTN","ORW DXM3",322, 0)
  6928    ;
  6929   "RTN","ORY 397")
  6930   0^11^B1339 27
  6931   "RTN","ORY 397",1,0)
  6932   ORY397 ;IS P/RFR - TE MP CODE FO R PATCH OR *3.0*397 ; 08/29/17   10:38
  6933   "RTN","ORY 397",2,0)
  6934    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**3 97**;Dec 1 7, 1997;Bu ild 17
  6935   "RTN","ORY 397",3,0)
  6936    Q
  6937   "RTN","ORY 397",4,0)
  6938   SENDDLG(AN AME) ; Ret urn true i f the curr ent order  dialog sho uld be sen t
  6939   "RTN","ORY 397",5,0)
  6940    I ANAME=" PSJ OR CLI NIC OE" Q  1
  6941   "RTN","ORY 397",6,0)
  6942    I ANAME=" GMRCOR CON SULT" Q 1
  6943   "RTN","ORY 397",7,0)
  6944    I ANAME=" GMRCOR REQ UEST" Q 1
  6945   "RTN","ORY 397",8,0)
  6946    Q 0
  6947   "RTN","ORY 397A")
  6948   0^^B520247 3
  6949   "RTN","ORY 397A",1,0)
  6950   ORY397A ;I SP/JLC - P OST FOR PA TCH OR*3.0 *397 ;Sep  27, 2018@1 3:23
  6951   "RTN","ORY 397A",2,0)
  6952    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**3 97**;Dec 1 7, 1997;Bu ild 17
  6953   "RTN","ORY 397A",3,0)
  6954    Q
  6955   "RTN","ORY 397A",4,0)
  6956   EN ; Task  off the re build of t he 'D' cro ss-referen ce for fil e #100
  6957   "RTN","ORY 397A",5,0)
  6958    N ZTDTH,Z TIO,ZTSK,Z TRTN,ZTDES C
  6959   "RTN","ORY 397A",6,0)
  6960    D BMES^XP DUTL("Queu eing Rebui ld of the  'D' cross- reference  for ORDERS  file (#10 0)")
  6961   "RTN","ORY 397A",7,0)
  6962    S ZTDTH=$ $FMADD^XLF DT($$NOW^X LFDT,0,0,0 ,10)
  6963   "RTN","ORY 397A",8,0)
  6964    S ZTRTN=" TASK^ORY39 7A",ZTDESC ="Rebuild  of the 'D'  xref for  file #100"
  6965   "RTN","ORY 397A",9,0)
  6966    S ZTIO=""
  6967   "RTN","ORY 397A",10,0 )
  6968    D ^%ZTLOA D
  6969   "RTN","ORY 397A",11,0 )
  6970    I +$G(ZTS K)=0 D
  6971   "RTN","ORY 397A",12,0 )
  6972    . D BMES^ XPDUTL("Un able to qu eue the fi le #100 xr ef Rebuild , file a h elp desk t icket for  assistance .")
  6973   "RTN","ORY 397A",13,0 )
  6974    E  D
  6975   "RTN","ORY 397A",14,0 )
  6976    . D BMES^ XPDUTL("DO NE - Task  #"_ZTSK)
  6977   "RTN","ORY 397A",15,0 )
  6978    Q
  6979   "RTN","ORY 397A",16,0 )
  6980   TASK ;
  6981   "RTN","ORY 397A",17,0 )
  6982    N ORIFN,I ,J,STOP,A, OR0,OR3,OR DIALOG,ORI T
  6983   "RTN","ORY 397A",18,0 )
  6984    S STOP=0
  6985   "RTN","ORY 397A",19,0 )
  6986    S ORIFN=$ G(^OR(100, "D",0)) I  ORIFN="" S  ORIFN=" "
  6987   "RTN","ORY 397A",20,0 )
  6988    F I=1:1 D   Q:'ORIFN   I STOP Q
  6989   "RTN","ORY 397A",21,0 )
  6990    . S ORIFN =$O(^OR(10 0,ORIFN),- 1) Q:'ORIF N
  6991   "RTN","ORY 397A",22,0 )
  6992    . S OR0=$ G(^OR(100, ORIFN,0))  Q:'OR0
  6993   "RTN","ORY 397A",23,0 )
  6994    . S ORDIA LOG=+$P(OR 0,"^",5),A =ORDIALOG_ ";ORD(101. 41," K ^OR (100,"D",A ,ORIFN)
  6995   "RTN","ORY 397A",24,0 )
  6996    . S OR3=$ G(^OR(100, ORIFN,3))  Q:'OR3
  6997   "RTN","ORY 397A",25,0 )
  6998    . S ORIT= $P(OR3,"^" ,4)
  6999   "RTN","ORY 397A",26,0 )
  7000    . I $G(OR IT),ORIT?. E1";ORD(10 1.41," S ^ OR(100,"D" ,ORIT,ORIF N)=""
  7001   "RTN","ORY 397A",27,0 )
  7002    . S ^OR(1 00,"D",0)= ORIFN
  7003   "RTN","ORY 397A",28,0 )
  7004    . I '(I#1 00000) D   I STOP Q
  7005   "RTN","ORY 397A",29,0 )
  7006    .. F J=1: 1:300 H 1  S STOP=$$R EQ2STOP()  I STOP Q
  7007   "RTN","ORY 397A",30,0 )
  7008    . S STOP= $$REQ2STOP () I STOP  Q
  7009   "RTN","ORY 397A",31,0 )
  7010    K ^OR(100 ,"D",0)
  7011   "RTN","ORY 397A",32,0 )
  7012    D MSG
  7013   "RTN","ORY 397A",33,0 )
  7014    Q
  7015   "RTN","ORY 397A",34,0 )
  7016   MSG ;
  7017   "RTN","ORY 397A",35,0 )
  7018    N XMSUB,X MY,XMTEXT, XMDUZ,ORTE XT,SITE,I, A
  7019   "RTN","ORY 397A",36,0 )
  7020    S ORTEXT( 1)="Rebuil d of 'D' c ross-refer ence compl eted for " _$$SITE^VA SITE()
  7021   "RTN","ORY 397A",37,0 )
  7022    S ORTEXT( 2)=" "
  7023   "RTN","ORY 397A",38,0 )
  7024    S XMDUZ=D UZ
  7025   "RTN","ORY 397A",39,0 )
  7026    S XMSUB=" Rebuild of  'D' cross -reference  completed "
  7027   "RTN","ORY 397A",40,0 )
  7028    S XMY("CR UMLEY.JAMI E@ D O
M
A IN . EXT    ")="",XMY( "THOMPSON. WILLIAM_AN THONY@ D O
M
A IN . EXT    ")=""
  7029   "RTN","ORY 397A",41,0 )
  7030    S XMTEXT= "ORTEXT("
  7031   "RTN","ORY 397A",42,0 )
  7032    D ^XMD
  7033   "RTN","ORY 397A",43,0 )
  7034    Q
  7035   "RTN","ORY 397A",44,0 )
  7036   REQ2STOP()  ;
  7037   "RTN","ORY 397A",45,0 )
  7038    ; Check f or task st op request
  7039   "RTN","ORY 397A",46,0 )
  7040    ; Returns  1 if stop  request m ade.
  7041   "RTN","ORY 397A",47,0 )
  7042    N STATUS, X
  7043   "RTN","ORY 397A",48,0 )
  7044    S STATUS= 0
  7045   "RTN","ORY 397A",49,0 )
  7046    I '$D(ZTQ UEUED) Q 0
  7047   "RTN","ORY 397A",50,0 )
  7048    S X=$$S^% ZTLOAD()
  7049   "RTN","ORY 397A",51,0 )
  7050    I X D  ;
  7051   "RTN","ORY 397A",52,0 )
  7052    . S STATU S=1
  7053   "RTN","ORY 397A",53,0 )
  7054    . S X=$$S ^%ZTLOAD(" Received s hutdown re quest")
  7055   "RTN","ORY 397A",54,0 )
  7056    ;
  7057   "RTN","ORY 397A",55,0 )
  7058    Q STATUS
  7059   "VER")
  7060   8.0^22.2
  7061   "^DD",101. 41,101.41, 0)
  7062   FIELD^NL^9 9^30
  7063   "^DD",101. 41,101.41, 0,"DDA")
  7064   N
  7065   "^DD",101. 41,101.41, 0,"DT")
  7066   3170119
  7067   "^DD",101. 41,101.41, 0,"IX","AB ",101.41,. 01)
  7068  
  7069   "^DD",101. 41,101.41, 0,"IX","AD ",101.412, 2)
  7070  
  7071   "^DD",101. 41,101.41, 0,"IX","AM ",101.41,9 9)
  7072  
  7073   "^DD",101. 41,101.41, 0,"IX","AM 2",101.41, 2)
  7074  
  7075   "^DD",101. 41,101.41, 0,"IX","AM 51",101.41 ,51)
  7076  
  7077   "^DD",101. 41,101.41, 0,"IX","AM 52",101.41 ,52)
  7078  
  7079   "^DD",101. 41,101.41, 0,"IX","AM M",101.412 ,.01)
  7080  
  7081   "^DD",101. 41,101.41, 0,"IX","AM M2",101.41 2,2)
  7082  
  7083   "^DD",101. 41,101.41, 0,"IX","AM M3",101.41 2,3)
  7084  
  7085   "^DD",101. 41,101.41, 0,"IX","AM M4",101.41 2,4)
  7086  
  7087   "^DD",101. 41,101.41, 0,"IX","AM M5",101.41 2,5)
  7088  
  7089   "^DD",101. 41,101.41, 0,"IX","AP KG",101.41 ,7)
  7090  
  7091   "^DD",101. 41,101.41, 0,"IX","C" ,101.41,2)
  7092  
  7093   "^DD",101. 41,101.41, 0,"NM","OR DER DIALOG ")
  7094  
  7095   "^DD",101. 41,101.41, 0,"PT",100 ,2)
  7096  
  7097   "^DD",101. 41,101.41, 0,"PT",100 ,7)
  7098  
  7099   "^DD",101. 41,101.41, 0,"PT",100 .045,.02)
  7100  
  7101   "^DD",101. 41,101.41, 0,"PT",100 .5,4)
  7102  
  7103   "^DD",101. 41,101.41, 0,"PT",100 .5,5)
  7104  
  7105   "^DD",101. 41,101.41, 0,"PT",100 .95,3)
  7106  
  7107   "^DD",101. 41,101.41, 0,"PT",100 .98,4)
  7108  
  7109   "^DD",101. 41,101.41, 0,"PT",101 .412,1)
  7110  
  7111   "^DD",101. 41,101.41, 0,"PT",101 .412,2)
  7112  
  7113   "^DD",101. 41,101.41, 0,"PT",101 .415,2)
  7114  
  7115   "^DD",101. 41,101.41, 0,"PT",101 .416,.02)
  7116  
  7117   "^DD",101. 41,101.41, 0,"PT",101 .441,.01)
  7118  
  7119   "^DD",101. 41,101.41, 0,"PT",801 .41,15)
  7120  
  7121   "^DD",101. 41,101.41, 0,"PT",801 .4118,.01)
  7122  
  7123   "^DD",101. 41,101.41, 0,"PT",800 001.05,.01 )
  7124  
  7125   "^DD",101. 41,101.41, 0,"VRPK")
  7126   OR
  7127   "^DD",101. 41,101.41, .01,0)
  7128   NAME^RF^^0 ;1^K:X[""" "!($A(X)=4 5) X I $D( X) K:$L(X) >63!($L(X) <3)!'(X'?1 P.E) X
  7129   "^DD",101. 41,101.41, .01,1,0)
  7130   ^.1^^-1
  7131   "^DD",101. 41,101.41, .01,1,2,0)
  7132   101.41^AB
  7133   "^DD",101. 41,101.41, .01,1,2,1)
  7134   S ^ORD(101 .41,"AB",$ E(X,1,63), DA)=""
  7135   "^DD",101. 41,101.41, .01,1,2,2)
  7136   K ^ORD(101 .41,"AB",$ E(X,1,63), DA)
  7137   "^DD",101. 41,101.41, .01,1,2,"% D",0)
  7138   ^^1^1^2971 020^
  7139   "^DD",101. 41,101.41, .01,1,2,"% D",1,0)
  7140   This is a  regular in dex on the  full 63 c haracters  of the Nam e field.
  7141   "^DD",101. 41,101.41, .01,1,2,"D T")
  7142   2971020
  7143   "^DD",101. 41,101.41, .01,3)
  7144   Answer mus t be 3-63  characters  in length .
  7145   "^DD",101. 41,101.41, .01,21,0)
  7146   ^^3^3^2971 219^
  7147   "^DD",101. 41,101.41, .01,21,1,0 )
  7148   This is th e name of  the dialog ; entries  that were  converted  from the
  7149   "^DD",101. 41,101.41, .01,21,2,0 )
  7150   Protocol f ile will r etain the  same name.   Namespac ing is not  required,
  7151   "^DD",101. 41,101.41, .01,21,3,0 )
  7152   but still  encouraged .
  7153   "^DD",101. 41,101.41, .01,"DT")
  7154   2971020
  7155   "^DD",101. 41,101.41, 2,0)
  7156   DISPLAY TE XT^FX^^0;2 ^K:$L(X)>8 0!($L(X)<3 )!($$CHKNA M^ORUTL(X) ) X
  7157   "^DD",101. 41,101.41, 2,1,0)
  7158   ^.1
  7159   "^DD",101. 41,101.41, 2,1,1,0)
  7160   101.41^C
  7161   "^DD",101. 41,101.41, 2,1,1,1)
  7162   S ^ORD(101 .41,"C",$$ UP^XLFSTR( $E(X,1,63) ),DA)=""
  7163   "^DD",101. 41,101.41, 2,1,1,2)
  7164   K ^ORD(101 .41,"C",$$ UP^XLFSTR( $E(X,1,63) ),DA)
  7165   "^DD",101. 41,101.41, 2,1,1,"DT" )
  7166   2950112
  7167   "^DD",101. 41,101.41, 2,1,2,0)
  7168   101.41^AM2 ^MUMPS
  7169   "^DD",101. 41,101.41, 2,1,2,1)
  7170   D REDOM^OR DD41
  7171   "^DD",101. 41,101.41, 2,1,2,2)
  7172   D REDOM^OR DD41
  7173   "^DD",101. 41,101.41, 2,1,2,"%D" ,0)
  7174   ^^1^1^2990 210^
  7175   "^DD",101. 41,101.41, 2,1,2,"%D" ,1,0)
  7176   Update TIM ESTAMP whe never DISP LAY TEXT i s changed.
  7177   "^DD",101. 41,101.41, 2,1,2,"DT" )
  7178   2990210
  7179   "^DD",101. 41,101.41, 2,3)
  7180   Answer mus t be 3-80  characters  and canno t contain  an up-arro w (^) or s emi-colon  (;).
  7181   "^DD",101. 41,101.41, 2,21,0)
  7182   ^.001^1^1^ 3010913^^^ ^
  7183   "^DD",101. 41,101.41, 2,21,1,0)
  7184   The text o f this dia log's name  as it app ears on a  menu or su bheader.
  7185   "^DD",101. 41,101.41, 2,"DT")
  7186   3000823
  7187   "^DD",101. 41,101.41, 3,0)
  7188   DISABLE^F^ ^0;3^K:$L( X)>40!($L( X)<1) X
  7189   "^DD",101. 41,101.41, 3,3)
  7190   Enter a me ssage here  to disabl e this dia log, 1-40  characters  in length .
  7191   "^DD",101. 41,101.41, 3,21,0)
  7192   ^^3^3^2950 112^
  7193   "^DD",101. 41,101.41, 3,21,1,0)
  7194   This field  disables  use of thi s dialog w hen it con tains text .  The tex t
  7195   "^DD",101. 41,101.41, 3,21,2,0)
  7196   should be  a short me ssage expl aining why  use of th is dialog  has been
  7197   "^DD",101. 41,101.41, 3,21,3,0)
  7198   disabled,  as it will  be displa yed if thi s dialog i s selected .
  7199   "^DD",101. 41,101.41, 3,"DT")
  7200   2950112
  7201   "^DD",101. 41,101.41, 4,0)
  7202   TYPE^RS^P: prompt;D:d ialog;Q:qu ick order; O:order se t;M:menu;A :action;^0 ;4^Q
  7203   "^DD",101. 41,101.41, 4,3)
  7204   Specify a  type for t his dialog .
  7205   "^DD",101. 41,101.41, 4,21,0)
  7206   ^^5^5^2950 716^^^^
  7207   "^DD",101. 41,101.41, 4,21,1,0)
  7208   This field  defines t he type of  order dia log to be  processed.   Control
  7209   "^DD",101. 41,101.41, 4,21,2,0)
  7210   will be pa ssed to th e OE/RR Di alog Proce ssor for d ialog item s; menu ty pes
  7211   "^DD",101. 41,101.41, 4,21,3,0)
  7212   are used f or display ing and se lecting di alog items .  Action  types will  only
  7213   "^DD",101. 41,101.41, 4,21,4,0)
  7214   execute th e entry an d exit act ions, igno ring any i tems that  may exist;  these
  7215   "^DD",101. 41,101.41, 4,21,5,0)
  7216   dialogs sh ould not c reate entr ies in the  Orders fi le.
  7217   "^DD",101. 41,101.41, 4,"DT")
  7218   2950716
  7219   "^DD",101. 41,101.41, 5,0)
  7220   DISPLAY GR OUP^P100.9 8'^ORD(100 .98,^0;5^Q
  7221   "^DD",101. 41,101.41, 5,3)
  7222   Enter the  display gr oup contai ning order able items  defined b y this dia log.
  7223   "^DD",101. 41,101.41, 5,21,0)
  7224   ^^3^3^2950 112^
  7225   "^DD",101. 41,101.41, 5,21,1,0)
  7226   This field  determine s what dis play group  this dial og has bee n defined  for.
  7227   "^DD",101. 41,101.41, 5,21,2,0)
  7228   It will de fine which  orderable  items are  selectabl e with thi s dialog,
  7229   "^DD",101. 41,101.41, 5,21,3,0)
  7230   as well as  what serv ice to sen d the orde r to when  it is comp lete.
  7231   "^DD",101. 41,101.41, 5,"DT")
  7232   2950112
  7233   "^DD",101. 41,101.41, 6,0)
  7234   SIGNATURE  REQUIRED^S ^0:NONE;1: ORELSE;2:O RES;^0;6^Q
  7235   "^DD",101. 41,101.41, 6,3)
  7236   Enter the  OR key req uired to s ign orders  created b y this dia log
  7237   "^DD",101. 41,101.41, 6,21,0)
  7238   ^^6^6^2970 318^^
  7239   "^DD",101. 41,101.41, 6,21,1,0)
  7240   This field  indicates  what sign ature will  be requir ed for ord ers create d by
  7241   "^DD",101. 41,101.41, 6,21,2,0)
  7242   this dialo g, to be c onsidered  complete a nd ready t o release  to the ser vice
  7243   "^DD",101. 41,101.41, 6,21,3,0)
  7244   for action .  If this  flag is s et to NO a nd the dia log contai ns a promp t
  7245   "^DD",101. 41,101.41, 6,21,4,0)
  7246   for item(s ) from the  Orderable  Item file , the orde r created  may still
  7247   "^DD",101. 41,101.41, 6,21,5,0)
  7248   require a  signature  if any of  the items  ordered ar e individu ally flagg ed
  7249   "^DD",101. 41,101.41, 6,21,6,0)
  7250   as requiri ng a signa ture.
  7251   "^DD",101. 41,101.41, 6,"DT")
  7252   2970318
  7253   "^DD",101. 41,101.41, 7,0)
  7254   PACKAGE^P9 .4'^DIC(9. 4,^0;7^Q
  7255   "^DD",101. 41,101.41, 7,1,0)
  7256   ^.1
  7257   "^DD",101. 41,101.41, 7,1,1,0)
  7258   101.41^APK G
  7259   "^DD",101. 41,101.41, 7,1,1,1)
  7260   S ^ORD(101 .41,"APKG" ,$E(X,1,30 ),DA)=""
  7261   "^DD",101. 41,101.41, 7,1,1,2)
  7262   K ^ORD(101 .41,"APKG" ,$E(X,1,30 ),DA)
  7263   "^DD",101. 41,101.41, 7,1,1,"DT" )
  7264   2970325
  7265   "^DD",101. 41,101.41, 7,3)
  7266   Enter the  VISTA pack age that i s to recei ve orders  created by  this dial og.
  7267   "^DD",101. 41,101.41, 7,21,0)
  7268   ^^3^3^2950 208^
  7269   "^DD",101. 41,101.41, 7,21,1,0)
  7270   This is th e VISTA pa ckage that  is intend ed to rece ive orders  created b y
  7271   "^DD",101. 41,101.41, 7,21,2,0)
  7272   this dialo g; this is  required  for creati ng the HL7  messages  to pass th e
  7273   "^DD",101. 41,101.41, 7,21,3,0)
  7274   order.
  7275   "^DD",101. 41,101.41, 7,"DT")
  7276   2970325
  7277   "^DD",101. 41,101.41, 8,0)
  7278   VERIFY ORD ER^S^1:YES ;0:NO;^0;8 ^Q
  7279   "^DD",101. 41,101.41, 8,3)
  7280   Enter YES  to have or ders creat ed by this  dialog pr esented to  the user  before sav ing, with  the opport unity to e dit.
  7281   "^DD",101. 41,101.41, 8,21,0)
  7282   ^^3^3^2950 623^
  7283   "^DD",101. 41,101.41, 8,21,1,0)
  7284   This field  is a flag , which de termines i f the orde r created  by this di alog
  7285   "^DD",101. 41,101.41, 8,21,2,0)
  7286   will be pr esented to  the user  for verifi cation bef ore saving  in the Or ders
  7287   "^DD",101. 41,101.41, 8,21,3,0)
  7288   file; for  most quick  orders, t his flag s hould be s et to 0 (n o).
  7289   "^DD",101. 41,101.41, 8,"DT")
  7290   2950623
  7291   "^DD",101. 41,101.41, 9,0)
  7292   ASK FOR AN OTHER ORDE R^S^0:NO;1 :YES;2:YES -DON'T ASK ;^0;9^Q
  7293   "^DD",101. 41,101.41, 9,3)
  7294   Enter YES  to have th e user ask ed to ente r another  order from  this dial og before  exiting.
  7295   "^DD",101. 41,101.41, 9,21,0)
  7296   ^^6^6^2970 616^^^
  7297   "^DD",101. 41,101.41, 9,21,1,0)
  7298   This field  allows th e user to  add anothe r order fr om this di alog, when  the
  7299   "^DD",101. 41,101.41, 9,21,2,0)
  7300   initial or der is acc epted and  placed; if  set to YE S, the use r will be
  7301   "^DD",101. 41,101.41, 9,21,3,0)
  7302   asked "Add  another < dialog dis play text>  order?" t o allow fo r either
  7303   "^DD",101. 41,101.41, 9,21,4,0)
  7304   exiting th e processo r or addin g an addit ional orde r of the s ame type.
  7305   "^DD",101. 41,101.41, 9,21,5,0)
  7306   This field  can also  be set to  YES-DON'T  ASK to for ce the pro cessor to
  7307   "^DD",101. 41,101.41, 9,21,6,0)
  7308   automatica lly drop i nto prompt ing for an other orde r without  asking fir st.
  7309   "^DD",101. 41,101.41, 9,"DT")
  7310   2970616
  7311   "^DD",101. 41,101.41, 10,0)
  7312   ITEMS^101. 412IA^^10; 0
  7313   "^DD",101. 41,101.41, 10,21,0)
  7314   ^^5^5^2990 211^^^^
  7315   "^DD",101. 41,101.41, 10,21,1,0)
  7316   This field  contains  the compon ents for d ialogs:
  7317   "^DD",101. 41,101.41, 10,21,2,0)
  7318        Dialo gs      ->  prompts
  7319   "^DD",101. 41,101.41, 10,21,3,0)
  7320        Quick  orders ->  prompts ( completed)
  7321   "^DD",101. 41,101.41, 10,21,4,0)
  7322        Order  sets   ->  dialogs o r quick or ders
  7323   "^DD",101. 41,101.41, 10,21,5,0)
  7324        Menus         ->  dialogs,  quick orde rs, or ord er sets
  7325   "^DD",101. 41,101.41, 11,0)
  7326   DATA TYPE^ S^D:date/t ime;R:free  text date /time;F:fr ee text;N: numeric;S: set of cod es;Y:yes/n o;P:pointe r;W:word p rocessing; ^1;1^Q
  7327   "^DD",101. 41,101.41, 11,3)
  7328   Enter the  type of da ta to be c ollected a t this pro mpt.
  7329   "^DD",101. 41,101.41, 11,21,0)
  7330   ^^2^2^2950 823^^
  7331   "^DD",101. 41,101.41, 11,21,1,0)
  7332   This is th e type of  data being  prompted  for; this  field is u sed to def ine
  7333   "^DD",101. 41,101.41, 11,21,2,0)
  7334   a call to  the reader  (^DIR) in  most case s.
  7335   "^DD",101. 41,101.41, 11,23,0)
  7336   ^^1^1^2950 823^^
  7337   "^DD",101. 41,101.41, 11,23,1,0)
  7338   Used with  Prompt-typ e only.
  7339   "^DD",101. 41,101.41, 11,"DT")
  7340   2950407
  7341   "^DD",101. 41,101.41, 12,0)
  7342   DOMAIN^F^^ 1;2^K:$L(X )>235!($L( X)<1) X
  7343   "^DD",101. 41,101.41, 12,3)
  7344   Answer mus t be 1-235  character s in lengt h.
  7345   "^DD",101. 41,101.41, 12,21,0)
  7346   ^^3^3^2990 225^^^^
  7347   "^DD",101. 41,101.41, 12,21,1,0)
  7348   This is a  parameter  that may b e used to  further sp ecify the  data type.
  7349   "^DD",101. 41,101.41, 12,21,2,0)
  7350   The string  stored he re should  be appropr iate for t he second  ^-piece of
  7351   "^DD",101. 41,101.41, 12,21,3,0)
  7352   DIR(0) whe n used wit h the data  type fiel d.
  7353   "^DD",101. 41,101.41, 12,23,0)
  7354   ^^1^1^2990 225^^^^
  7355   "^DD",101. 41,101.41, 12,23,1,0)
  7356   Used with  Prompt-typ e only.
  7357   "^DD",101. 41,101.41, 12,"DT")
  7358   2990225
  7359   "^DD",101. 41,101.41, 13,0)
  7360   ID^F^^1;3^ K:$L(X)>10 !($L(X)<2)  X
  7361   "^DD",101. 41,101.41, 13,3)
  7362   Answer mus t be 2-10  characters  in length .
  7363   "^DD",101. 41,101.41, 13,21,0)
  7364   ^.001^20^2 0^3010727^ ^
  7365   "^DD",101. 41,101.41, 13,21,1,0)
  7366   This field  may conta in a singl e word ide ntifier wh ich will b e
  7367   "^DD",101. 41,101.41, 13,21,2,0)
  7368   stored wit h the user  response  in the Ord ers file # 100, where  it
  7369   "^DD",101. 41,101.41, 13,21,3,0)
  7370   will be in dexed for  quick refe rence to c ertain val ues in the
  7371   "^DD",101. 41,101.41, 13,21,4,0)
  7372   order dial og.  The f ollowing a re some ex amples of  values
  7373   "^DD",101. 41,101.41, 13,21,5,0)
  7374   currently  in use:
  7375   "^DD",101. 41,101.41, 13,21,6,0)
  7376    
  7377   "^DD",101. 41,101.41, 13,21,7,0)
  7378      START       -> Sta rt date/ti me
  7379   "^DD",101. 41,101.41, 13,21,8,0)
  7380      STOP        -> Sto p date/tim e
  7381   "^DD",101. 41,101.41, 13,21,9,0)
  7382      SCHEDUL E   -> Adm inistratio n Schedule
  7383   "^DD",101. 41,101.41, 13,21,10,0 )
  7384      ORDERAB LE  -> Ord erable Ite m
  7385   "^DD",101. 41,101.41, 13,21,11,0 )
  7386      DRUG        -> Dis pense Drug
  7387   "^DD",101. 41,101.41, 13,21,12,0 )
  7388      CANCEL      -> Can cel Future  Orders fl ag
  7389   "^DD",101. 41,101.41, 13,21,13,0 )
  7390      COMMENT     -> Wor d processi ng comment s
  7391   "^DD",101. 41,101.41, 13,21,14,0 )
  7392    
  7393   "^DD",101. 41,101.41, 13,21,15,0 )
  7394   These valu es must be  unique am ong entrie s within a n order di alog
  7395   "^DD",101. 41,101.41, 13,21,16,0 )
  7396   but do not  need to b e unique a cross the  entire fil e.  Be sur e to
  7397   "^DD",101. 41,101.41, 13,21,17,0 )
  7398   check the  IDs assign ed to gene ric text e ntries to  make sure  that
  7399   "^DD",101. 41,101.41, 13,21,18,0 )
  7400   all IDs ar e unique.   In order  to avoid p otential p roblems it 's
  7401   "^DD",101. 41,101.41, 13,21,19,0 )
  7402   recommende d that you  use uniqu e IDs for  any local  entries th at you
  7403   "^DD",101. 41,101.41, 13,21,20,0 )
  7404   create.
  7405   "^DD",101. 41,101.41, 13,"DT")
  7406   2960215
  7407   "^DD",101. 41,101.41, 17,0)
  7408   VALIDATION ^K^^7;E1,2 45^K:$L(X) >245 X D:$ D(X) ^DIM
  7409   "^DD",101. 41,101.41, 17,3)
  7410   This is St andard MUM PS code.
  7411   "^DD",101. 41,101.41, 17,9)
  7412   @
  7413   "^DD",101. 41,101.41, 17,21,0)
  7414   ^^3^3^2960 912^
  7415   "^DD",101. 41,101.41, 17,21,1,0)
  7416   This is MU MPS code t hat will b e executed  at the ti me of rele asing an
  7417   "^DD",101. 41,101.41, 17,21,2,0)
  7418   order crea ted with t his dialog ; dialog r esponses m ay be chec ked again
  7419   "^DD",101. 41,101.41, 17,21,3,0)
  7420   here befor e releasin g the orde r to the s ervice.
  7421   "^DD",101. 41,101.41, 17,"DT")
  7422   2960912
  7423   "^DD",101. 41,101.41, 19,0)
  7424   ADDITIONAL  TEXT^K^^9 ;E1,245^K: $L(X)>245  X D:$D(X)  ^DIM
  7425   "^DD",101. 41,101.41, 19,3)
  7426   This is St andard MUM PS code.
  7427   "^DD",101. 41,101.41, 19,9)
  7428   @
  7429   "^DD",101. 41,101.41, 19,21,0)
  7430   ^^3^3^2960 405^^
  7431   "^DD",101. 41,101.41, 19,21,1,0)
  7432   This is MU MPS code t hat will b e executed  when orde r ORIFN cr eated by t his
  7433   "^DD",101. 41,101.41, 19,21,2,0)
  7434   dialog is  about to b e displaye d; any str ing that s hould be a ppended to  the
  7435   "^DD",101. 41,101.41, 19,21,3,0)
  7436   order text  should be  returned  in Y.
  7437   "^DD",101. 41,101.41, 19,"DT")
  7438   2960405
  7439   "^DD",101. 41,101.41, 20,0)
  7440   DESCRIPTIO N^101.411^ ^2;0
  7441   "^DD",101. 41,101.41, 20,21,0)
  7442   ^^1^1^2971 219^
  7443   "^DD",101. 41,101.41, 20,21,1,0)
  7444   This is a  descriptio n of the d ialog and  its uses.
  7445   "^DD",101. 41,101.41, 21,0)
  7446   RESPONSES^ 101.416^^6 ;0
  7447   "^DD",101. 41,101.41, 21,21,0)
  7448   ^^2^2^2971 219^
  7449   "^DD",101. 41,101.41, 21,21,1,0)
  7450   This multi ple contai ns any res ponses to  prompts th at have be en pre-ans wered
  7451   "^DD",101. 41,101.41, 21,21,2,0)
  7452   to create  a quick or der.
  7453   "^DD",101. 41,101.41, 30,0)
  7454   ENTRY ACTI ON^K^^3;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  7455   "^DD",101. 41,101.41, 30,3)
  7456   This is St andard MUM PS code.
  7457   "^DD",101. 41,101.41, 30,9)
  7458   @
  7459   "^DD",101. 41,101.41, 30,21,0)
  7460   ^^4^4^2950 425^
  7461   "^DD",101. 41,101.41, 30,21,1,0)
  7462   This is MU MPS code t hat will b e executed  at the to p of a dia log, prior  to
  7463   "^DD",101. 41,101.41, 30,21,2,0)
  7464   the execut ion of any  prompts;  it may per form funct ions such  as listing
  7465   "^DD",101. 41,101.41, 30,21,3,0)
  7466   the recent  Radiology  exams bef ore orderi ng a new o ne, or ale rting the
  7467   "^DD",101. 41,101.41, 30,21,4,0)
  7468   user to an  existing  diet order  before ma king a cha nge.
  7469   "^DD",101. 41,101.41, 30,"DT")
  7470   2950425
  7471   "^DD",101. 41,101.41, 31,0)
  7472   QUICK SETU P^K^^3.1;E 1,245^K:$L (X)>245 X  D:$D(X) ^D IM
  7473   "^DD",101. 41,101.41, 31,3)
  7474   This is St andard MUM PS code.
  7475   "^DD",101. 41,101.41, 31,9)
  7476   @
  7477   "^DD",101. 41,101.41, 31,21,0)
  7478   ^^3^3^2970 113^
  7479   "^DD",101. 41,101.41, 31,21,1,0)
  7480   This is MU MPS code t hat will b e executed  in the pl ace of the  Entry Act ion
  7481   "^DD",101. 41,101.41, 31,21,2,0)
  7482   when creat ing quick  orders for  this dial og; variab les may be  set here
  7483   "^DD",101. 41,101.41, 31,21,3,0)
  7484   instead to  bypass th e usual de pendence o n specific  patient v alues.
  7485   "^DD",101. 41,101.41, 31,"DT")
  7486   2970113
  7487   "^DD",101. 41,101.41, 40,0)
  7488   EXIT ACTIO N^K^^4;E1, 245^K:$L(X )>245 X D: $D(X) ^DIM
  7489   "^DD",101. 41,101.41, 40,3)
  7490   This is St andard MUM PS code.
  7491   "^DD",101. 41,101.41, 40,9)
  7492   @
  7493   "^DD",101. 41,101.41, 40,21,0)
  7494   ^^2^2^2950 622^
  7495   "^DD",101. 41,101.41, 40,21,1,0)
  7496   This is MU MPS code t hat will b e executed  upon comp letion of  processing  the
  7497   "^DD",101. 41,101.41, 40,21,2,0)
  7498   dialog; it  is curren tly used o nly with d ialog-type  entries.
  7499   "^DD",101. 41,101.41, 40,"DT")
  7500   2950622
  7501   "^DD",101. 41,101.41, 50,0)
  7502   CONTROLS^1 01.415A^^5 0;0
  7503   "^DD",101. 41,101.41, 51,0)
  7504   COLUMN WID TH^NJ3,0^^ 5;1^K:+X'= X!(X>240)! (X<20)!(X? .E1"."1N.N ) X
  7505   "^DD",101. 41,101.41, 51,1,0)
  7506   ^.1
  7507   "^DD",101. 41,101.41, 51,1,1,0)
  7508   101.41^AM5 1^MUMPS
  7509   "^DD",101. 41,101.41, 51,1,1,1)
  7510   D REDO^ORD D41
  7511   "^DD",101. 41,101.41, 51,1,1,2)
  7512   D REDO^ORD D41
  7513   "^DD",101. 41,101.41, 51,1,1,"%D ",0)
  7514   ^^1^1^2990 210^
  7515   "^DD",101. 41,101.41, 51,1,1,"%D ",1,0)
  7516   Update TIM ESTAMP whe never COLU MN WIDTH i s changed.
  7517   "^DD",101. 41,101.41, 51,1,1,"DT ")
  7518   2990210
  7519   "^DD",101. 41,101.41, 51,3)
  7520   Type a Num ber betwee n 20 and 2 40, 0 Deci mal Digits
  7521   "^DD",101. 41,101.41, 51,21,0)
  7522   ^^2^2^2950 623^
  7523   "^DD",101. 41,101.41, 51,21,1,0)
  7524   This is th e width, i n characte rs, for ea ch column  in a menu.   For exam ple,
  7525   "^DD",101. 41,101.41, 51,21,2,0)
  7526   to have 3  columns on  an 80 cha racter dev ice, enter  a width o f 26.
  7527   "^DD",101. 41,101.41, 51,"DT")
  7528   2990210
  7529   "^DD",101. 41,101.41, 52,0)
  7530   MNEMONIC W IDTH^NJ1,0 ^^5;2^K:+X '=X!(X>9)! (X<1)!(X?. E1"."1N.N)  X
  7531   "^DD",101. 41,101.41, 52,1,0)
  7532   ^.1
  7533   "^DD",101. 41,101.41, 52,1,1,0)
  7534   101.41^AM5 2^MUMPS
  7535   "^DD",101. 41,101.41, 52,1,1,1)
  7536   D REDO^ORD D41
  7537   "^DD",101. 41,101.41, 52,1,1,2)
  7538   D REDO^ORD D41
  7539   "^DD",101. 41,101.41, 52,1,1,"%D ",0)
  7540   ^^1^1^2990 210^
  7541   "^DD",101. 41,101.41, 52,1,1,"%D ",1,0)
  7542   Update TIM ESTAMP whe never MNEM ONIC WIDTH  is change d.
  7543   "^DD",101. 41,101.41, 52,1,1,"DT ")
  7544   2990210
  7545   "^DD",101. 41,101.41, 52,3)
  7546   Type a Num ber betwee n 1 and 9,  0 Decimal  Digits
  7547   "^DD",101. 41,101.41, 52,21,0)
  7548   ^^2^2^2950 623^
  7549   "^DD",101. 41,101.41, 52,21,1,0)
  7550   This field  allows th e width of  item mnem onics to b e varied;  the defaul t
  7551   "^DD",101. 41,101.41, 52,21,2,0)
  7552   value is 5 .
  7553   "^DD",101. 41,101.41, 52,"DT")
  7554   2990210
  7555   "^DD",101. 41,101.41, 53,0)
  7556   PATH SWITC H^S^1:YES; 0:NO;^5;3^ Q
  7557   "^DD",101. 41,101.41, 53,3)
  7558   Enter YES  if this me nu should  be redispl ayed when  traversing  back up t he menu tr ee.
  7559   "^DD",101. 41,101.41, 53,21,0)
  7560   ^^5^5^2950 623^
  7561   "^DD",101. 41,101.41, 53,21,1,0)
  7562   This switc h allows t he user, w hen traver sing back  UP the tre e of menus  and
  7563   "^DD",101. 41,101.41, 53,21,2,0)
  7564   items, to  select a n ew path ba ck down th e tree.  I n other wo rds, the m enu
  7565   "^DD",101. 41,101.41, 53,21,3,0)
  7566   is redispl ayed when  returning  to that me nu's level  in the tr ee and
  7567   "^DD",101. 41,101.41, 53,21,4,0)
  7568   processing  back down  the tree  is possibl e from tha t point.   If nothing  is
  7569   "^DD",101. 41,101.41, 53,21,5,0)
  7570   selected f rom the me nu, the pa th continu es back up  the tree.
  7571   "^DD",101. 41,101.41, 53,"DT")
  7572   2950623
  7573   "^DD",101. 41,101.41, 54,0)
  7574   LISTBOX TE XT^F^^5;4^ K:$L(X)>30 !($L(X)<1)  X
  7575   "^DD",101. 41,101.41, 54,3)
  7576   Answer mus t be 1-30  characters  in length .
  7577   "^DD",101. 41,101.41, 54,"DT")
  7578   2960524
  7579   "^DD",101. 41,101.41, 55,0)
  7580   WINDOW FOR M ID^NJ4,0 ^^5;5^K:+X '=X!(X>999 9)!(X<0)!( X?.E1"."1N .N) X
  7581   "^DD",101. 41,101.41, 55,3)
  7582   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  7583   "^DD",101. 41,101.41, 55,21,0)
  7584   ^.001^23^2 3^3010727^ ^
  7585   "^DD",101. 41,101.41, 55,21,1,0)
  7586   This field  tells the  GUI DELPH I code whi ch form to  use to pr ocess the
  7587   "^DD",101. 41,101.41, 55,21,2,0)
  7588   order dial og.  Each  number rep resents a  unique for m.  Follow ing are so me
  7589   "^DD",101. 41,101.41, 55,21,3,0)
  7590   of the mor e common c odes and t heir corre sponding f orm in DEL PHI.
  7591   "^DD",101. 41,101.41, 55,21,4,0)
  7592    
  7593   "^DD",101. 41,101.41, 55,21,5,0)
  7594       Form N ame     Wi ndows Form  ID
  7595   "^DD",101. 41,101.41, 55,21,6,0)
  7596       ------ ---     -- ---------- ---
  7597   "^DD",101. 41,101.41, 55,21,7,0)
  7598     OD_ACTIV ITY            100
  7599   "^DD",101. 41,101.41, 55,21,8,0)
  7600     OD_ALLER GY             105
  7601   "^DD",101. 41,101.41, 55,21,9,0)
  7602     OD_CONSU LT             110
  7603   "^DD",101. 41,101.41, 55,21,10,0 )
  7604     OD_PROCE DURE           112
  7605   "^DD",101. 41,101.41, 55,21,11,0 )
  7606     OD_DIET_ TXT            115
  7607   "^DD",101. 41,101.41, 55,21,12,0 )
  7608     OD_DIET                 117
  7609   "^DD",101. 41,101.41, 55,21,13,0 )
  7610     OD_LAB                  120
  7611   "^DD",101. 41,101.41, 55,21,14,0 )
  7612     OD_MEDIN PT             130
  7613   "^DD",101. 41,101.41, 55,21,15,0 )
  7614     OD_MEDS                 135
  7615   "^DD",101. 41,101.41, 55,21,16,0 )
  7616     OD_MEDOU TPT            140
  7617   "^DD",101. 41,101.41, 55,21,17,0 )
  7618     OD_NURSI NG             150
  7619   "^DD",101. 41,101.41, 55,21,18,0 )
  7620     OD_MISC                 151
  7621   "^DD",101. 41,101.41, 55,21,19,0 )
  7622     OD_GENER IC             152
  7623   "^DD",101. 41,101.41, 55,21,20,0 )
  7624     OD_IMAGI NG             160
  7625   "^DD",101. 41,101.41, 55,21,21,0 )
  7626     OD_VITAL S              171 
  7627   "^DD",101. 41,101.41, 55,21,22,0 )
  7628     OD_MEDIV                180
  7629   "^DD",101. 41,101.41, 55,21,23,0 )
  7630     OD_TEXTO NLY            999
  7631   "^DD",101. 41,101.41, 55,"DT")
  7632   2960804
  7633   "^DD",101. 41,101.41, 56,0)
  7634   CREATE PAR ENT ORDER^ S^1:YES;0: NO;^5;6^Q
  7635   "^DD",101. 41,101.41, 56,3)
  7636   Enter YES  if a paren t order sh ould be cr eated for  this order  set
  7637   "^DD",101. 41,101.41, 56,21,0)
  7638   ^^6^6^2970 227^
  7639   "^DD",101. 41,101.41, 56,21,1,0)
  7640   This flag  indicates  whether a  parent ord er should  be created  to group
  7641   "^DD",101. 41,101.41, 56,21,2,0)
  7642   together a ll the ord ers create d by this  order set;  this flag  is only
  7643   "^DD",101. 41,101.41, 56,21,3,0)
  7644   valid with  SET type  order dial ogs.  If t his value  is YES, a  parent
  7645   "^DD",101. 41,101.41, 56,21,4,0)
  7646   order will  be create d, and onl y the pare nt will be  presented  on the
  7647   "^DD",101. 41,101.41, 56,21,5,0)
  7648   orders lis t for disp lay and ac tion; NO w ill preven t a parent  from bein g
  7649   "^DD",101. 41,101.41, 56,21,6,0)
  7650   created an d all orde rs will be  created a nd display ed indepen dently.
  7651   "^DD",101. 41,101.41, 56,"DT")
  7652   2970227
  7653   "^DD",101. 41,101.41, 57,0)
  7654   DISPLAY SU BHEADER^S^ 1:YES;0:NO ;^5;7^Q
  7655   "^DD",101. 41,101.41, 57,3)
  7656   Enter YES  if a subhe ader shoul d be displ ayed as ea ch order i n this set  is proces sed
  7657   "^DD",101. 41,101.41, 57,21,0)
  7658   ^^3^3^2970 227^
  7659   "^DD",101. 41,101.41, 57,21,1,0)
  7660   This flag  indicates  whether a  subheader  is to be d isplayed f or each or der
  7661   "^DD",101. 41,101.41, 57,21,2,0)
  7662   in this se t as it is  processed  and place d; this fl ag is only  valid wit h
  7663   "^DD",101. 41,101.41, 57,21,3,0)
  7664   SET type o rder dialo gs.
  7665   "^DD",101. 41,101.41, 57,"DT")
  7666   2970227
  7667   "^DD",101. 41,101.41, 58,0)
  7668   AUTO-ACCEP T QUICK OR DER^S^1:YE S;^5;8^Q
  7669   "^DD",101. 41,101.41, 58,3)
  7670   Enter 'Yes ' if the o rder shoul d be place d without  displaying  the dialo g window.
  7671   "^DD",101. 41,101.41, 58,21,0)
  7672   ^^2^2^2980 902^
  7673   "^DD",101. 41,101.41, 58,21,1,0)
  7674   This can b e set to y es for a q uick order  so that i t can be p laced simp ly
  7675   "^DD",101. 41,101.41, 58,21,2,0)
  7676   by clickin g on it in  the GUI ( no orderin g dialog i s displaye d).
  7677   "^DD",101. 41,101.41, 58,"DT")
  7678   2980902
  7679   "^DD",101. 41,101.41, 99,0)
  7680   TIMESTAMP^ F^^99;1^K: $L(X)>15!( $L(X)<1) X
  7681   "^DD",101. 41,101.41, 99,1,0)
  7682   ^.1
  7683   "^DD",101. 41,101.41, 99,1,1,0)
  7684   101.41^AM^ MUMPS
  7685   "^DD",101. 41,101.41, 99,1,1,1)
  7686   D SET^ORDD 41(DA)
  7687   "^DD",101. 41,101.41, 99,1,1,2)
  7688   D KILL^ORD D41(DA)
  7689   "^DD",101. 41,101.41, 99,1,1,"%D ",0)
  7690   ^^2^2^2990 210^
  7691   "^DD",101. 41,101.41, 99,1,1,"%D ",1,0)
  7692   Recompiles  order dia log menus  in ^XUTL(" XQORM",<di alog#>_";O RD(101.41, ")
  7693   "^DD",101. 41,101.41, 99,1,1,"%D ",2,0)
  7694   whenever f ields nece ssary to d isplaying  the menu a re changed .
  7695   "^DD",101. 41,101.41, 99,1,1,"DT ")
  7696   2990210
  7697   "^DD",101. 41,101.41, 99,3)
  7698   Answer mus t be 1-15  characters  in length .
  7699   "^DD",101. 41,101.41, 99,21,0)
  7700   ^^2^2^2980 501^
  7701   "^DD",101. 41,101.41, 99,21,1,0)
  7702   For menus,  this cont ains the $ H time the  menu was  last compi led for us e
  7703   "^DD",101. 41,101.41, 99,21,2,0)
  7704   with the U nwinder ut ility (^XQ OR).
  7705   "^DD",101. 41,101.41, 99,"DT")
  7706   2990210
  7707   "^DD",101. 41,101.411 ,0)
  7708   DESCRIPTIO N SUB-FIEL D^^.01^1
  7709   "^DD",101. 41,101.411 ,0,"DT")
  7710   2950407
  7711   "^DD",101. 41,101.411 ,0,"NM","D ESCRIPTION ")
  7712  
  7713   "^DD",101. 41,101.411 ,0,"UP")
  7714   101.41
  7715   "^DD",101. 41,101.411 ,.01,0)
  7716   DESCRIPTIO N^W^^0;1^Q
  7717   "^DD",101. 41,101.411 ,.01,3)
  7718   Enter a de scription  of this di alog.
  7719   "^DD",101. 41,101.411 ,.01,21,0)
  7720   ^^1^1^2950 425^^
  7721   "^DD",101. 41,101.411 ,.01,21,1, 0)
  7722   This field  contains  a descript ion of the  content a nd use of  this dialo g.
  7723   "^DD",101. 41,101.411 ,.01,"DT")
  7724   2950407
  7725   "^DD",101. 41,101.412 ,0)
  7726   FIELD^NL^1 17^37
  7727   "^DD",101. 41,101.412 ,0,"DT")
  7728   3170119
  7729   "^DD",101. 41,101.412 ,0,"ID","W RITE")
  7730   N OR0,ORNM  S OR0=^(0 ) I $P(OR0 ,U,2) S OR NM=$P($G(^ ORD(101.41 ,+$P(OR0,U ,2),0)),U)  D:$L(ORNM ) EN^DDIOL (ORNM,,"?1 0")
  7731   "^DD",101. 41,101.412 ,0,"IX","A TXT",101.4 12,21)
  7732  
  7733   "^DD",101. 41,101.412 ,0,"IX","B ",101.412, .01)
  7734  
  7735   "^DD",101. 41,101.412 ,0,"IX","D ",101.412, 2)
  7736  
  7737   "^DD",101. 41,101.412 ,0,"IX","D AD",101.41 2,1)
  7738  
  7739   "^DD",101. 41,101.412 ,0,"IX","D AD1",101.4 12,.01)
  7740  
  7741   "^DD",101. 41,101.412 ,0,"NM","I TEMS")
  7742  
  7743   "^DD",101. 41,101.412 ,0,"UP")
  7744   101.41
  7745   "^DD",101. 41,101.412 ,.01,0)
  7746   SEQUENCE^M NJ5,1^^0;1 ^K:+X'=X!( X>999.9)!( X<.1)!(X?. E1"."2N.N)  X
  7747   "^DD",101. 41,101.412 ,.01,1,0)
  7748   ^.1
  7749   "^DD",101. 41,101.412 ,.01,1,1,0 )
  7750   101.412^B
  7751   "^DD",101. 41,101.412 ,.01,1,1,1 )
  7752   S ^ORD(101 .41,DA(1), 10,"B",$E( X,1,30),DA )=""
  7753   "^DD",101. 41,101.412 ,.01,1,1,2 )
  7754   K ^ORD(101 .41,DA(1), 10,"B",$E( X,1,30),DA )
  7755   "^DD",101. 41,101.412 ,.01,1,2,0 )
  7756   101.412^DA D1^MUMPS
  7757   "^DD",101. 41,101.412 ,.01,1,2,1 )
  7758   N ORP S OR P=$P(^ORD( 101.41,DA( 1),10,DA,0 ),U,11) S: ORP ^ORD(1 01.41,DA(1 ),10,"DAD" ,ORP,X,DA) =""
  7759   "^DD",101. 41,101.412 ,.01,1,2,2 )
  7760   N ORP S OR P=$P(^ORD( 101.41,DA( 1),10,DA,0 ),U,11) K: ORP ^ORD(1 01.41,DA(1 ),10,"DAD" ,ORP,X,DA)
  7761   "^DD",101. 41,101.412 ,.01,1,2," %D",0)
  7762   ^^1^1^2950 511^
  7763   "^DD",101. 41,101.412 ,.01,1,2," %D",1,0)
  7764   Allows ret rieval of  'child' pr ompts in s equence by  parent.
  7765   "^DD",101. 41,101.412 ,.01,1,2," DT")
  7766   2950511
  7767   "^DD",101. 41,101.412 ,.01,1,3,0 )
  7768   101.41^AMM ^MUMPS
  7769   "^DD",101. 41,101.412 ,.01,1,3,1 )
  7770   D REDOX^OR DD41
  7771   "^DD",101. 41,101.412 ,.01,1,3,2 )
  7772   D REDOX^OR DD41
  7773   "^DD",101. 41,101.412 ,.01,1,3," %D",0)
  7774   ^^1^1^2990 210^
  7775   "^DD",101. 41,101.412 ,.01,1,3," %D",1,0)
  7776   Update TIM ESTAMP whe never SEQU ENCE is ch anged.
  7777   "^DD",101. 41,101.412 ,.01,1,3," DT")
  7778   2990210
  7779   "^DD",101. 41,101.412 ,.01,3)
  7780   Type a Num ber betwee n .1 and 9 99.9, 1 De cimal Digi t
  7781   "^DD",101. 41,101.412 ,.01,21,0)
  7782   ^^2^2^2971 117^^^^
  7783   "^DD",101. 41,101.412 ,.01,21,1, 0)
  7784   This field  specifies  the order  in which  this item  will be di splayed or
  7785   "^DD",101. 41,101.412 ,.01,21,2, 0)
  7786   processed.
  7787   "^DD",101. 41,101.412 ,.01,"DT")
  7788   2990210
  7789   "^DD",101. 41,101.412 ,.1,0)
  7790   INPUT TRAN SFORM^K^^. 1;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  7791   "^DD",101. 41,101.412 ,.1,3)
  7792   This is St andard MUM PS code.
  7793   "^DD",101. 41,101.412 ,.1,9)
  7794   @
  7795   "^DD",101. 41,101.412 ,.1,21,0)
  7796   ^^2^2^2950 816^
  7797   "^DD",101. 41,101.412 ,.1,21,1,0 )
  7798   This is co de that wi ll be used  as the th ird piece  of DIR(0)  when askin g
  7799   "^DD",101. 41,101.412 ,.1,21,2,0 )
  7800   this promp t.
  7801   "^DD",101. 41,101.412 ,.1,"DT")
  7802   2950816
  7803   "^DD",101. 41,101.412 ,1,0)
  7804   PARENT^P10 1.41'^ORD( 101.41,^0; 11^Q
  7805   "^DD",101. 41,101.412 ,1,1,0)
  7806   ^.1
  7807   "^DD",101. 41,101.412 ,1,1,1,0)
  7808   101.412^DA D^MUMPS
  7809   "^DD",101. 41,101.412 ,1,1,1,1)
  7810   S ^ORD(101 .41,DA(1), 10,"DAD",X ,$P(^ORD(1 01.41,DA(1 ),10,DA,0) ,U),DA)=""
  7811   "^DD",101. 41,101.412 ,1,1,1,2)
  7812   K ^ORD(101 .41,DA(1), 10,"DAD",X ,$P(^ORD(1 01.41,DA(1 ),10,DA,0) ,U),DA)
  7813   "^DD",101. 41,101.412 ,1,1,1,"%D ",0)
  7814   ^^1^1^2950 511^^
  7815   "^DD",101. 41,101.412 ,1,1,1,"%D ",1,0)
  7816   Allows ret rieval of  'child' pr ompts in s equence by  parent.
  7817   "^DD",101. 41,101.412 ,1,1,1,"DT ")
  7818   2950511
  7819   "^DD",101. 41,101.412 ,1,3)
  7820   If this pr ompt is su bordinate  to another  in this d ialog, ent er the par ent prompt  here
  7821   "^DD",101. 41,101.412 ,1,21,0)
  7822   ^^4^4^2950 511^
  7823   "^DD",101. 41,101.412 ,1,21,1,0)
  7824   This field  controls  the behavi or of this  prompt.   If a paren t is defin ed
  7825   "^DD",101. 41,101.412 ,1,21,2,0)
  7826   here, this  prompt wi ll be aske d from wit hin the pa rent's dia log; when  it
  7827   "^DD",101. 41,101.412 ,1,21,3,0)
  7828   is invoked  independe ntly based  on its po sition seq uence numb er, the ch ild
  7829   "^DD",101. 41,101.412 ,1,21,4,0)
  7830   prompt wil l be ignor ed.
  7831   "^DD",101. 41,101.412 ,1,"DT")
  7832   2950511
  7833   "^DD",101. 41,101.412 ,2,0)
  7834   ITEM^P101. 41'X^ORD(1 01.41,^0;2 ^D TREE^OR DD41
  7835   "^DD",101. 41,101.412 ,2,1,0)
  7836   ^.1
  7837   "^DD",101. 41,101.412 ,2,1,1,0)
  7838   101.41^AD
  7839   "^DD",101. 41,101.412 ,2,1,1,1)
  7840   S ^ORD(101 .41,"AD",$ E(X,1,30), DA(1),DA)= ""
  7841   "^DD",101. 41,101.412 ,2,1,1,2)
  7842   K ^ORD(101 .41,"AD",$ E(X,1,30), DA(1),DA)
  7843   "^DD",101. 41,101.412 ,2,1,1,"DT ")
  7844   2950123
  7845   "^DD",101. 41,101.412 ,2,1,2,0)
  7846   101.412^D
  7847   "^DD",101. 41,101.412 ,2,1,2,1)
  7848   S ^ORD(101 .41,DA(1), 10,"D",$E( X,1,30),DA )=""
  7849   "^DD",101. 41,101.412 ,2,1,2,2)
  7850   K ^ORD(101 .41,DA(1), 10,"D",$E( X,1,30),DA )
  7851   "^DD",101. 41,101.412 ,2,1,2,"DT ")
  7852   2950411
  7853   "^DD",101. 41,101.412 ,2,1,3,0)
  7854   101.41^AMM 2^MUMPS
  7855   "^DD",101. 41,101.412 ,2,1,3,1)
  7856   D REDOX^OR DD41
  7857   "^DD",101. 41,101.412 ,2,1,3,2)
  7858   D REDOX^OR DD41
  7859   "^DD",101. 41,101.412 ,2,1,3,"%D ",0)
  7860   ^^1^1^2990 210^
  7861   "^DD",101. 41,101.412 ,2,1,3,"%D ",1,0)
  7862   Update TIM ESTAMP whe never ITEM  is change d.
  7863   "^DD",101. 41,101.412 ,2,1,3,"DT ")
  7864   2990210
  7865   "^DD",101. 41,101.412 ,2,3)
  7866   Enter an o rder dialo g; a dialo g that is  an ancesto r may not  also be a  sub-item.
  7867   "^DD",101. 41,101.412 ,2,21,0)
  7868   ^^3^3^2950 123^
  7869   "^DD",101. 41,101.412 ,2,21,1,0)
  7870   This field  points to  an order  dialog whi ch is subo rdinate to  this dial og.
  7871   "^DD",101. 41,101.412 ,2,21,2,0)
  7872   NOTE:  The  parent di alog menu  or one of  its ancest ors may no t be enter ed
  7873   "^DD",101. 41,101.412 ,2,21,3,0)
  7874   as an item .
  7875   "^DD",101. 41,101.412 ,2,"DT")
  7876   2990217
  7877   "^DD",101. 41,101.412 ,3,0)
  7878   MNEMONIC^F X^^0;3^K:$ L(X)>4!($L (X)<1)!(+X =X&($L(X," .")>1))!($ $CHKMNE^OR UTL(X)) X
  7879   "^DD",101. 41,101.412 ,3,1,0)
  7880   ^.1
  7881   "^DD",101. 41,101.412 ,3,1,1,0)
  7882   101.41^AMM 3^MUMPS
  7883   "^DD",101. 41,101.412 ,3,1,1,1)
  7884   D REDOX^OR DD41
  7885   "^DD",101. 41,101.412 ,3,1,1,2)
  7886   D REDOX^OR DD41
  7887   "^DD",101. 41,101.412 ,3,1,1,"%D ",0)
  7888   ^^1^1^2990 210^
  7889   "^DD",101. 41,101.412 ,3,1,1,"%D ",1,0)
  7890   Update TIM ESTAMP whe never MNEM ONIC is ch anged.
  7891   "^DD",101. 41,101.412 ,3,1,1,"DT ")
  7892   2990210
  7893   "^DD",101. 41,101.412 ,3,3)
  7894   Enter a mn emonic to  be used wh en this di alog is di splayed fo r selectio n, 1-4 cha racters in  length wi th no deci mal places  if numeri c. Standar d list man ager mnemo nics may n ot be used .
  7895   "^DD",101. 41,101.412 ,3,21,0)
  7896   ^.001^2^2^ 3010727^^^ ^
  7897   "^DD",101. 41,101.412 ,3,21,1,0)
  7898   This is a  short abbr eviation f or this it em dialog  to be used  when this
  7899   "^DD",101. 41,101.412 ,3,21,2,0)
  7900   dialog is  displayed  for select ion.
  7901   "^DD",101. 41,101.412 ,3,"DT")
  7902   3000822
  7903   "^DD",101. 41,101.412 ,4,0)
  7904   DISPLAY TE XT^FX^^0;4 ^K:$L(X)>8 0!($L(X)<1 )!($$CHKNA M^ORUTL(X) ) X
  7905   "^DD",101. 41,101.412 ,4,1,0)
  7906   ^.1
  7907   "^DD",101. 41,101.412 ,4,1,1,0)
  7908   101.41^AMM 4^MUMPS
  7909   "^DD",101. 41,101.412 ,4,1,1,1)
  7910   D REDOX^OR DD41
  7911   "^DD",101. 41,101.412 ,4,1,1,2)
  7912   D REDOX^OR DD41
  7913   "^DD",101. 41,101.412 ,4,1,1,"%D ",0)
  7914   ^^1^1^2990 210^
  7915   "^DD",101. 41,101.412 ,4,1,1,"%D ",1,0)
  7916   Update TIM ESTAMP whe never DISP LAY TEXT i s changed.
  7917   "^DD",101. 41,101.412 ,4,1,1,"DT ")
  7918   2990210
  7919   "^DD",101. 41,101.412 ,4,3)
  7920   Answer mus t be 1-80  characters  in length  and canno t contain  an up-arro w (^) or s emi-colon  (;).
  7921   "^DD",101. 41,101.412 ,4,21,0)
  7922   ^.001^2^2^ 3010419^^^ ^
  7923   "^DD",101. 41,101.412 ,4,21,1,0)
  7924   This field  allows th e text tha t normally  appears f or this it em to be
  7925   "^DD",101. 41,101.412 ,4,21,2,0)
  7926   replaced w ith altern ate text f or use in  this dialo g or menu.
  7927   "^DD",101. 41,101.412 ,4,"DT")
  7928   3000823
  7929   "^DD",101. 41,101.412 ,5,0)
  7930   DISPLAY ON LY?^S^0:NO ;1:YES;2:Y ES-HEADER; ^0;5^Q
  7931   "^DD",101. 41,101.412 ,5,1,0)
  7932   ^.1
  7933   "^DD",101. 41,101.412 ,5,1,1,0)
  7934   101.41^AMM 5^MUMPS
  7935   "^DD",101. 41,101.412 ,5,1,1,1)
  7936   D REDOX^OR DD41
  7937   "^DD",101. 41,101.412 ,5,1,1,2)
  7938   D REDOX^OR DD41
  7939   "^DD",101. 41,101.412 ,5,1,1,"%D ",0)
  7940   ^^1^1^2990 210^
  7941   "^DD",101. 41,101.412 ,5,1,1,"%D ",1,0)
  7942   Update TIM ESTAMP whe never DISP LAY ONLY?  is changed .
  7943   "^DD",101. 41,101.412 ,5,1,1,"DT ")
  7944   2990210
  7945   "^DD",101. 41,101.412 ,5,3)
  7946   Enter YES  if this it em is text  for displ ay only an d not a se lectable i tem.
  7947   "^DD",101. 41,101.412 ,5,21,0)
  7948   ^^3^3^2970 409^^^^
  7949   "^DD",101. 41,101.412 ,5,21,1,0)
  7950   This field  identifie s an item  as being f ree text f or display  purposes
  7951   "^DD",101. 41,101.412 ,5,21,2,0)
  7952   only.  The  text in t he Display  Text fiel d will be  displayed,  but it
  7953   "^DD",101. 41,101.412 ,5,21,3,0)
  7954   is not sel ectable; i f designat ed as a he ader, the  text will  be underli ned.
  7955   "^DD",101. 41,101.412 ,5,"DT")
  7956   2990210
  7957   "^DD",101. 41,101.412 ,6,0)
  7958   REQUIRED^S ^1:YES;0:N O;^0;6^Q
  7959   "^DD",101. 41,101.412 ,6,3)
  7960   Enter YES  if a respo nse to thi s prompt i s mandator y.
  7961   "^DD",101. 41,101.412 ,6,21,0)
  7962   ^^1^1^2950 407^
  7963   "^DD",101. 41,101.412 ,6,21,1,0)
  7964   This field  indicates  that the  user must  enter a re sponse to  this promp t.
  7965   "^DD",101. 41,101.412 ,6,"DT")
  7966   2950407
  7967   "^DD",101. 41,101.412 ,7,0)
  7968   MULTIPLE V ALUED^S^1: YES;0:NO;^ 0;7^Q
  7969   "^DD",101. 41,101.412 ,7,3)
  7970   Enter YES  if this pr ompt is to  be asked  multiple t imes.
  7971   "^DD",101. 41,101.412 ,7,21,0)
  7972   ^^3^3^2950 407^
  7973   "^DD",101. 41,101.412 ,7,21,1,0)
  7974   This field  determine s if this  prompt wil l be allow ed to have  multiple
  7975   "^DD",101. 41,101.412 ,7,21,2,0)
  7976   values, or  be prompt ed for onl y once; if  this prom pt is a su b-dialog,
  7977   "^DD",101. 41,101.412 ,7,21,3,0)
  7978   the entire  dialog wi ll be aske d once or  many times , as a gro up.
  7979   "^DD",101. 41,101.412 ,7,"DT")
  7980   2950407
  7981   "^DD",101. 41,101.412 ,7.1,0)
  7982   MAX NUMBER  OF MULTIP LES^NJ2,0^ ^0;12^K:+X '=X!(X>99) !(X<2)!(X? .E1"."1N.N ) X
  7983   "^DD",101. 41,101.412 ,7.1,3)
  7984   Type a Num ber betwee n 2 and 99 , 0 Decima l Digits
  7985   "^DD",101. 41,101.412 ,7.1,21,0)
  7986   ^^4^4^2950 815^
  7987   "^DD",101. 41,101.412 ,7.1,21,1, 0)
  7988   This is th e maximum  number of  values tha t may be e ntered for  this prom pt,
  7989   "^DD",101. 41,101.412 ,7.1,21,2, 0)
  7990   if it is f lagged as  being mult iple-value d.  For ex ample, a d iet order  may
  7991   "^DD",101. 41,101.412 ,7.1,21,3, 0)
  7992   have up to  5 diet mo dification s entered,  where 5 i s the maxi mum allowe d
  7993   "^DD",101. 41,101.412 ,7.1,21,4, 0)
  7994   that would  be entere d here.
  7995   "^DD",101. 41,101.412 ,7.1,"DT")
  7996   2950815
  7997   "^DD",101. 41,101.412 ,7.2,0)
  7998   TITLE^F^^0 ;13^K:$L(X )>30!($L(X )<3) X
  7999   "^DD",101. 41,101.412 ,7.2,3)
  8000   Answer mus t be 3-30  characters  in length .
  8001   "^DD",101. 41,101.412 ,7.2,21,0)
  8002   ^^8^8^2970 430^^
  8003   "^DD",101. 41,101.412 ,7.2,21,1, 0)
  8004   This is te xt that wi ll be used  in place  of the pro mpt when t he order i s
  8005   "^DD",101. 41,101.412 ,7.2,21,2, 0)
  8006   displayed  for place,  edit, or  cancel, or  at the to p of a mul tiple-valu ed
  8007   "^DD",101. 41,101.412 ,7.2,21,3, 0)
  8008   prompt.  T he Display  Text for  the prompt  will be u sed togeth er with th e
  8009   "^DD",101. 41,101.412 ,7.2,21,4, 0)
  8010   instance n umber to p rompt for  user input ; for exam ple if Tit le="Lab Te sts:"
  8011   "^DD",101. 41,101.412 ,7.2,21,5, 0)
  8012   and Displa y Text="Te st:" the u ser would  see
  8013   "^DD",101. 41,101.412 ,7.2,21,6, 0)
  8014     Lab Test s:
  8015   "^DD",101. 41,101.412 ,7.2,21,7, 0)
  8016     1. Test:
  8017   "^DD",101. 41,101.412 ,7.2,21,8, 0)
  8018     2. Test:
  8019   "^DD",101. 41,101.412 ,7.2,"DT")
  8020   2950815
  8021   "^DD",101. 41,101.412 ,7.3,0)
  8022   PROMPT^F^^ 0;14^K:$L( X)>10!($L( X)<1) X
  8023   "^DD",101. 41,101.412 ,7.3,3)
  8024   Answer mus t be 1-10  characters  in length .
  8025   "^DD",101. 41,101.412 ,7.3,21,0)
  8026   ^^3^3^2970 618^
  8027   "^DD",101. 41,101.412 ,7.3,21,1, 0)
  8028   This field  contains  text that  will be ap pended to  the beginn ing of the
  8029   "^DD",101. 41,101.412 ,7.3,21,2, 0)
  8030   display te xt when pr ompting fo r addition al values;  if this f ield is
  8031   "^DD",101. 41,101.412 ,7.3,21,3, 0)
  8032   empty, the n "Another  " will be  used.
  8033   "^DD",101. 41,101.412 ,7.3,"DT")
  8034   2970618
  8035   "^DD",101. 41,101.412 ,8,0)
  8036   ASK ON EDI T ONLY^S^1 :YES;0:NO; ^0;8^Q
  8037   "^DD",101. 41,101.412 ,8,3)
  8038   Enter YES  if this pr ompt shoul d not be a sked initi ally when  creating t his order,  only if t he user ch ooses to e dit the or der.
  8039   "^DD",101. 41,101.412 ,8,21,0)
  8040   ^^4^4^2960 112^^^
  8041   "^DD",101. 41,101.412 ,8,21,1,0)
  8042   This field  determine s the beha viour of t he dialog  driver for  this prom pt;
  8043   "^DD",101. 41,101.412 ,8,21,2,0)
  8044   if no valu e or the d efined def ault is us ually corr ect for th is prompt,
  8045   "^DD",101. 41,101.412 ,8,21,3,0)
  8046   enter YES  here to ha ve this pr ompt skipp ed on the  first pass  through t his
  8047   "^DD",101. 41,101.412 ,8,21,4,0)
  8048   dialog whe n creating  an order.
  8049   "^DD",101. 41,101.412 ,8,"DT")
  8050   2950407
  8051   "^DD",101. 41,101.412 ,9,0)
  8052   ASK ON ACT ION^F^^0;9 ^K:$L(X)>3 !($L(X)<1)  X
  8053   "^DD",101. 41,101.412 ,9,3)
  8054   Answer mus t be 1-3 c haracters  in length.
  8055   "^DD",101. 41,101.412 ,9,21,0)
  8056   ^^6^6^2970 708^^^
  8057   "^DD",101. 41,101.412 ,9,21,1,0)
  8058   This field  determine s the beha viour of t he dialog  driver for  this prom pt
  8059   "^DD",101. 41,101.412 ,9,21,2,0)
  8060   when takin g a partic ular actio n on an or der create d by this  dialog.  I f
  8061   "^DD",101. 41,101.412 ,9,21,3,0)
  8062   this strin g contains  "R", this  prompt wi ll be aske d when ren ewing an o rder;
  8063   "^DD",101. 41,101.412 ,9,21,4,0)
  8064   if this st ring conta ins "C", t his prompt  will be a sked when  changing a n
  8065   "^DD",101. 41,101.412 ,9,21,5,0)
  8066   order; if  this strin g contains  "W", this  prompt wi ll be aske d when
  8067   "^DD",101. 41,101.412 ,9,21,6,0)
  8068   rewriting  an order.
  8069   "^DD",101. 41,101.412 ,9,"DT")
  8070   2970708
  8071   "^DD",101. 41,101.412 ,10,0)
  8072   INDEX^F^^0 ;10^K:$L(X )>25!($L(X )<1) X
  8073   "^DD",101. 41,101.412 ,10,3)
  8074   Answer mus t be 1-25  characters  in length .
  8075   "^DD",101. 41,101.412 ,10,21,0)
  8076   ^^3^3^2950 713^^^
  8077   "^DD",101. 41,101.412 ,10,21,1,0 )
  8078   For pointe r-type pro mpts, this  is the in dex to use  when sear ching the  file;
  8079   "^DD",101. 41,101.412 ,10,21,2,0 )
  8080   it must be  in the fo rm of a re gular cros s-referenc e.  To sea rch on mul tiple
  8081   "^DD",101. 41,101.412 ,10,21,3,0 )
  8082   indices, e nter a str ing of ind ex names s eparated b y semi-col ons, i.e.  "B;C".
  8083   "^DD",101. 41,101.412 ,10,"DT")
  8084   2950713
  8085   "^DD",101. 41,101.412 ,11,0)
  8086   HELP MESSA GE^F^^1;1^ K:$L(X)>16 0!($L(X)<1 ) X
  8087   "^DD",101. 41,101.412 ,11,3)
  8088   Answer mus t be 1-160  character s in lengt h.
  8089   "^DD",101. 41,101.412 ,11,21,0)
  8090   ^^2^2^2970 609^^
  8091   "^DD",101. 41,101.412 ,11,21,1,0 )
  8092   This field  contains  the help m essage to  be present ed when th e user ent ers
  8093   "^DD",101. 41,101.412 ,11,21,2,0 )
  8094   a question  mark at t his prompt .
  8095   "^DD",101. 41,101.412 ,11,"DT")
  8096   2970609
  8097   "^DD",101. 41,101.412 ,12,0)
  8098   SPECIAL LO OKUP ROUTI NE^F^^1;2^ K:$L(X)>20 !($L(X)<3)  X
  8099   "^DD",101. 41,101.412 ,12,3)
  8100   Enter the  routine to  use inste ad of DIC  to do this  lookup, a s [TAG;]RO UTINE
  8101   "^DD",101. 41,101.412 ,12,21,0)
  8102   ^^3^3^2970 609^
  8103   "^DD",101. 41,101.412 ,12,21,1,0 )
  8104   This field  contains  a routine  to execute  that will  replace t he standar d
  8105   "^DD",101. 41,101.412 ,12,21,2,0 )
  8106   DIC lookup  for this  prompt; it  must be e ntered her e as LINET AG;ROUTINE
  8107   "^DD",101. 41,101.412 ,12,21,3,0 )
  8108   using a ;  instead of  ^ and whe re LINETAG  is option al.
  8109   "^DD",101. 41,101.412 ,12,"DT")
  8110   2970609
  8111   "^DD",101. 41,101.412 ,13,0)
  8112   ASK ON CON DITION^K^^ 3;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  8113   "^DD",101. 41,101.412 ,13,3)
  8114   This is MU MPS code t hat sets $ T to deter mine if th is prompt  should be  asked, or  given a de fault valu e and bypa ssed.
  8115   "^DD",101. 41,101.412 ,13,9)
  8116   @
  8117   "^DD",101. 41,101.412 ,13,21,0)
  8118   ^^5^5^2950 407^
  8119   "^DD",101. 41,101.412 ,13,21,1,0 )
  8120   This is MU MPS code t hat sets $ T to deter mine if th is prompt  should be  asked
  8121   "^DD",101. 41,101.412 ,13,21,2,0 )
  8122   or simply  given a de fault valu e and pres ented to t he user fo r acceptan ce
  8123   "^DD",101. 41,101.412 ,13,21,3,0 )
  8124   or editing .  For exa mple, the  prompt "Pr egnant: "  may have c ode here t o
  8125   "^DD",101. 41,101.412 ,13,21,4,0 )
  8126   check the  sex of the  current p atient, i. e. I ORSEX ="F" will  allow it t o be
  8127   "^DD",101. 41,101.412 ,13,21,5,0 )
  8128   asked only  for femal e patients .
  8129   "^DD",101. 41,101.412 ,13,"DT")
  8130   2950407
  8131   "^DD",101. 41,101.412 ,14,0)
  8132   SCREEN^K^^ 4;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  8133   "^DD",101. 41,101.412 ,14,3)
  8134   This is St andard MUM PS code.
  8135   "^DD",101. 41,101.412 ,14,9)
  8136   @
  8137   "^DD",101. 41,101.412 ,14,21,0)
  8138   ^^2^2^2950 407^
  8139   "^DD",101. 41,101.412 ,14,21,1,0 )
  8140   For pointe r-type pro mpts, this  field may  contain M UMPS code  that will  be
  8141   "^DD",101. 41,101.412 ,14,21,2,0 )
  8142   set into D IC("S") to  screen th e possible  choices i n the poin ted-to fil e.
  8143   "^DD",101. 41,101.412 ,14,"DT")
  8144   2950407
  8145   "^DD",101. 41,101.412 ,15,0)
  8146   POST-SELEC TION ACTIO N^K^^5;E1, 245^K:$L(X )>245 X D: $D(X) ^DIM
  8147   "^DD",101. 41,101.412 ,15,3)
  8148   This is St andard MUM PS code.
  8149   "^DD",101. 41,101.412 ,15,9)
  8150   @
  8151   "^DD",101. 41,101.412 ,15,21,0)
  8152   ^^3^3^2970 923^^^^
  8153   "^DD",101. 41,101.412 ,15,21,1,0 )
  8154   This is co de that wi ll be exec uted after  a respons e is enter ed to this
  8155   "^DD",101. 41,101.412 ,15,21,2,0 )
  8156   prompt; if  this prom pt should  be re-aske d, kill th e variable  DONE.
  8157   "^DD",101. 41,101.412 ,15,21,3,0 )
  8158   If executi on of the  ordering d ialog shou ld be stop ped, set O RQUIT=1.
  8159   "^DD",101. 41,101.412 ,15,"DT")
  8160   2970923
  8161   "^DD",101. 41,101.412 ,16,0)
  8162   XECUTABLE  HELP^K^^6; E1,245^K:$ L(X)>245 X  D:$D(X) ^ DIM
  8163   "^DD",101. 41,101.412 ,16,3)
  8164   This is St andard MUM PS code.
  8165   "^DD",101. 41,101.412 ,16,9)
  8166   @
  8167   "^DD",101. 41,101.412 ,16,21,0)
  8168   ^^2^2^2950 407^
  8169   "^DD",101. 41,101.412 ,16,21,1,0 )
  8170   This is co de that is  to be exe cuted when  the user  enters two  or more
  8171   "^DD",101. 41,101.412 ,16,21,2,0 )
  8172   question m arks at th is prompt.
  8173   "^DD",101. 41,101.412 ,16,"DT")
  8174   2950407
  8175   "^DD",101. 41,101.412 ,17,0)
  8176   DEFAULT^K^ ^7;E1,245^ K:$L(X)>24 5 X D:$D(X ) ^DIM
  8177   "^DD",101. 41,101.412 ,17,3)
  8178   This is St andard MUM PS code.
  8179   "^DD",101. 41,101.412 ,17,9)
  8180   @
  8181   "^DD",101. 41,101.412 ,17,21,0)
  8182   ^^2^2^2971 219^^^^
  8183   "^DD",101. 41,101.412 ,17,21,1,0 )
  8184   This is co de that is  to be exe cuted to d etermine t he appropr iate defau lt
  8185   "^DD",101. 41,101.412 ,17,21,2,0 )
  8186   value for  this promp t, setting  Y=interna l form of  this value .
  8187   "^DD",101. 41,101.412 ,17,"DT")
  8188   2950519
  8189   "^DD",101. 41,101.412 ,18,0)
  8190   DEFAULT WO RD-PROCESS ING TEXT^1 01.41218^^ 8;0
  8191   "^DD",101. 41,101.412 ,18,21,0)
  8192   ^^1^1^2971 219^
  8193   "^DD",101. 41,101.412 ,18,21,1,0 )
  8194   This is de fault text  to be stu ffed into  this word- processing  prompt.
  8195   "^DD",101. 41,101.412 ,19,0)
  8196   ENTRY ACTI ON^K^^9;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  8197   "^DD",101. 41,101.412 ,19,3)
  8198   This is St andard MUM PS code.
  8199   "^DD",101. 41,101.412 ,19,9)
  8200   @
  8201   "^DD",101. 41,101.412 ,19,21,0)
  8202   ^^3^3^2970 609^
  8203   "^DD",101. 41,101.412 ,19,21,1,0 )
  8204   This is co de that wi ll be exec uted at th e beginnin g of the p rocessing  of
  8205   "^DD",101. 41,101.412 ,19,21,2,0 )
  8206   this promp t, before  the Defaul t and Ask  on Conditi on fields  are execut ed;
  8207   "^DD",101. 41,101.412 ,19,21,3,0 )
  8208   any specia l setup re quired for  this fiel d should b e done her e.
  8209   "^DD",101. 41,101.412 ,19,"DT")
  8210   2970609
  8211   "^DD",101. 41,101.412 ,20,0)
  8212   EXIT ACTIO N^K^^10;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  8213   "^DD",101. 41,101.412 ,20,3)
  8214   This is St andard MUM PS code.
  8215   "^DD",101. 41,101.412 ,20,9)
  8216   @
  8217   "^DD",101. 41,101.412 ,20,21,0)
  8218   ^^3^3^2970 609^
  8219   "^DD",101. 41,101.412 ,20,21,1,0 )
  8220   This is co de that wi ll be exec uted at th e very end  of the pr ocessing o f
  8221   "^DD",101. 41,101.412 ,20,21,2,0 )
  8222   this promp t, after p rompting a nd the Val idation fi eld is exe cuted;
  8223   "^DD",101. 41,101.412 ,20,21,3,0 )
  8224   any specia l cleanup  should be  done here.
  8225   "^DD",101. 41,101.412 ,20,"DT")
  8226   2970609
  8227   "^DD",101. 41,101.412 ,21,0)
  8228   ORDER TEXT  SEQUENCE^ NJ5,2^^2;1 ^K:+X'=X!( X>99.99)!( X<1)!(X?.E 1"."3N.N)  X
  8229   "^DD",101. 41,101.412 ,21,1,0)
  8230   ^.1
  8231   "^DD",101. 41,101.412 ,21,1,1,0)
  8232   101.412^AT XT
  8233   "^DD",101. 41,101.412 ,21,1,1,1)
  8234   S ^ORD(101 .41,DA(1), 10,"ATXT", $E(X,1,30) ,DA)=""
  8235   "^DD",101. 41,101.412 ,21,1,1,2)
  8236   K ^ORD(101 .41,DA(1), 10,"ATXT", $E(X,1,30) ,DA)
  8237   "^DD",101. 41,101.412 ,21,1,1,"% D",0)
  8238   ^^1^1^2960 226^
  8239   "^DD",101. 41,101.412 ,21,1,1,"% D",1,0)
  8240   Used to bu ild order  text.
  8241   "^DD",101. 41,101.412 ,21,1,1,"D T")
  8242   2960226
  8243   "^DD",101. 41,101.412 ,21,3)
  8244   Enter the  order in w hich this  value shou ld be adde d to the o rder text,  as a numb er between  1 and 99. 99; leave  this field  blank to  prevent th is value f rom being  included
  8245   "^DD",101. 41,101.412 ,21,21,0)
  8246   ^^3^3^2970 607^^^
  8247   "^DD",101. 41,101.412 ,21,21,1,0 )
  8248   This field  indicates  the order  in which  values wil l be conca tenated
  8249   "^DD",101. 41,101.412 ,21,21,2,0 )
  8250   together t o build th e order te xt; this m ay differ  from the p rompting
  8251   "^DD",101. 41,101.412 ,21,21,3,0 )
  8252   order defi ned in the  .01 Seque nce field.
  8253   "^DD",101. 41,101.412 ,21,"DT")
  8254   2960226
  8255   "^DD",101. 41,101.412 ,22,0)
  8256   FORMAT^F^^ 2;2^K:$L(X )>10!($L(X )<1) X
  8257   "^DD",101. 41,101.412 ,22,3)
  8258   Answer mus t be 1-10  characters  in length .
  8259   "^DD",101. 41,101.412 ,22,21,0)
  8260   ^^15^15^29 71207^^^^
  8261   "^DD",101. 41,101.412 ,22,21,1,0 )
  8262   This is a  string of  characters  that will  define an y exceptio ns to how
  8263   "^DD",101. 41,101.412 ,22,21,2,0 )
  8264   the extern al form of  this valu e is gener ated.  Pos sible valu es include :
  8265   "^DD",101. 41,101.412 ,22,21,3,0 )
  8266     Pointer          ->  <field #> ~<piece in  RPC list  of field # >, default  =.01
  8267   "^DD",101. 41,101.412 ,22,21,4,0 )
  8268     Set of C odes    ->  1~<piece  in RPC lis t of code>  to use co de for nam e
  8269   "^DD",101. 41,101.412 ,22,21,5,0 )
  8270     Date/Tim e       ->  Format st ring to pa ss $$FMTE^ XLFDT (def ault = 2)
  8271   "^DD",101. 41,101.412 ,22,21,6,0 )
  8272     
  8273   "^DD",101. 41,101.412 ,22,21,7,0 )
  8274     Suppress  value  ->  @
  8275   "^DD",101. 41,101.412 ,22,21,8,0 )
  8276     Replace  value   ->  @<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  8277   "^DD",101. 41,101.412 ,22,21,9,0 )
  8278                           whose va lue, when  present, s upersedes  this value
  8279   "^DD",101. 41,101.412 ,22,21,10, 0)
  8280     Required  value  ->  *<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  8281   "^DD",101. 41,101.412 ,22,21,11, 0)
  8282                           whose va lue is req uired to b e present  to include
  8283   "^DD",101. 41,101.412 ,22,21,12, 0)
  8284                           this val ue
  8285   "^DD",101. 41,101.412 ,22,21,13, 0)
  8286     Ignore i f same  ->  =<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  8287   "^DD",101. 41,101.412 ,22,21,14, 0)
  8288                           whose va lue, if th e external  form is t he same,
  8289   "^DD",101. 41,101.412 ,22,21,15, 0)
  8290                           supersed es this va lue
  8291   "^DD",101. 41,101.412 ,22,"DT")
  8292   2960226
  8293   "^DD",101. 41,101.412 ,23,0)
  8294   OMIT TEXT^ F^^2;3^K:$ L(X)>30!($ L(X)<1) X
  8295   "^DD",101. 41,101.412 ,23,3)
  8296   Answer mus t be 1-30  characters  in length .
  8297   "^DD",101. 41,101.412 ,23,21,0)
  8298   ^^3^3^2970 829^^^^
  8299   "^DD",101. 41,101.412 ,23,21,1,0 )
  8300   This is th e external  form of a  value tha t is not t o be inclu ded when b uilding
  8301   "^DD",101. 41,101.412 ,23,21,2,0 )
  8302   the order  text.  E.g . to inclu de the urg ency in th e order te xt unless  it
  8303   "^DD",101. 41,101.412 ,23,21,3,0 )
  8304   is routine , enter "R OUTINE" he re.
  8305   "^DD",101. 41,101.412 ,23,"DT")
  8306   2970829
  8307   "^DD",101. 41,101.412 ,24,0)
  8308   LEADING TE XT^F^^2;4^ K:$L(X)>80 !($L(X)<1)  X
  8309   "^DD",101. 41,101.412 ,24,3)
  8310   Answer mus t be 1-80  characters  in length .
  8311   "^DD",101. 41,101.412 ,24,21,0)
  8312   ^^3^3^2970 724^^^^
  8313   "^DD",101. 41,101.412 ,24,21,1,0 )
  8314   This field  contains  text that  will be ap pended to  the order  text
  8315   "^DD",101. 41,101.412 ,24,21,2,0 )
  8316   immediatel y in front  of this v alue, e.g.  "Instruct ions:".  I f this tex t
  8317   "^DD",101. 41,101.412 ,24,21,3,0 )
  8318   is contain ed in a va riable, en ter @NAME  where NAME  is the va riable nam e.
  8319   "^DD",101. 41,101.412 ,24,"DT")
  8320   2970724
  8321   "^DD",101. 41,101.412 ,25,0)
  8322   TRAILING T EXT^F^^2;5 ^K:$L(X)>8 0!($L(X)<1 ) X
  8323   "^DD",101. 41,101.412 ,25,3)
  8324   Answer mus t be 1-80  characters  in length .
  8325   "^DD",101. 41,101.412 ,25,21,0)
  8326   ^^3^3^2970 724^^^^
  8327   "^DD",101. 41,101.412 ,25,21,1,0 )
  8328   This field  contains  text that  will be ap pended to  the order  text
  8329   "^DD",101. 41,101.412 ,25,21,2,0 )
  8330   immediatel y followin g this val ue, e.g. " refills".   If this t ext is
  8331   "^DD",101. 41,101.412 ,25,21,3,0 )
  8332   contained  in a varia ble, enter  @NAME whe re NAME is  the varia ble name.
  8333   "^DD",101. 41,101.412 ,25,"DT")
  8334   2970724
  8335   "^DD",101. 41,101.412 ,26,0)
  8336   START NEW  LINE^S^1:Y ES;0:NO;^2 ;6^Q
  8337   "^DD",101. 41,101.412 ,26,3)
  8338   Enter YES  if this va lue should  begin on  a new line  in the or der text.
  8339   "^DD",101. 41,101.412 ,26,21,0)
  8340   0^^2^2^297 0911^
  8341   "^DD",101. 41,101.412 ,26,21,1,0 )
  8342   This field  determine s if this  value is c oncatenate d onto the  current l ine
  8343   "^DD",101. 41,101.412 ,26,21,2,0 )
  8344   when build ing the or der text,  or if a ne w line is  started wi th this va lue.
  8345   "^DD",101. 41,101.412 ,26,"DT")
  8346   2970911
  8347   "^DD",101. 41,101.412 ,27,0)
  8348   WORD-WRAP^ S^1:DON'T  WRAP;0:WRA P;^2;7^Q
  8349   "^DD",101. 41,101.412 ,27,3)
  8350   Enter 'Don 't Wrap' t o have the  text be a dded line- by-line as  it is sto red; the d efault for matting is  'Wrap'.
  8351   "^DD",101. 41,101.412 ,27,21,0)
  8352   ^^3^3^2970 926^^^
  8353   "^DD",101. 41,101.412 ,27,21,1,0 )
  8354   This field  determine s if this  text shoul d be wrapp ed when ad ded to the
  8355   "^DD",101. 41,101.412 ,27,21,2,0 )
  8356   order text , or appen ded line b y line as  stored in  the file;  this is on ly
  8357   "^DD",101. 41,101.412 ,27,21,3,0 )
  8358   used for w ord-proces sing type  prompts.
  8359   "^DD",101. 41,101.412 ,27,"DT")
  8360   2970926
  8361   "^DD",101. 41,101.412 ,101,0)
  8362   WINDOWS CO NTROL^F^^W ;1^K:$L(X) >30!($L(X) <1) X
  8363   "^DD",101. 41,101.412 ,101,3)
  8364   Answer mus t be 1-30  characters  in length .
  8365   "^DD",101. 41,101.412 ,101,21,0)
  8366   ^^2^2^2950 715^
  8367   "^DD",101. 41,101.412 ,101,21,1, 0)
  8368   Stores the  type of W indows con trol neces sary to ge t the data  for this
  8369   "^DD",101. 41,101.412 ,101,21,2, 0)
  8370   prompt.
  8371   "^DD",101. 41,101.412 ,101,"DT")
  8372   2960517
  8373   "^DD",101. 41,101.412 ,102,0)
  8374   API NAME^F ^^W;2^K:$L (X)>30!($L (X)<1) X
  8375   "^DD",101. 41,101.412 ,102,3)
  8376   Answer mus t be 1-30  characters  in length .
  8377   "^DD",101. 41,101.412 ,102,21,0)
  8378   ^^3^3^2950 715^
  8379   "^DD",101. 41,101.412 ,102,21,1, 0)
  8380   This is th e API that  should be  called wh en the con trol is us ed.  How t he API
  8381   "^DD",101. 41,101.412 ,102,21,2, 0)
  8382   is used va rys with t he control .  Example s are: fil ling list  boxes, get ting
  8383   "^DD",101. 41,101.412 ,102,21,3, 0)
  8384   boilerplat e text, et c.
  8385   "^DD",101. 41,101.412 ,102,"DT")
  8386   2951002
  8387   "^DD",101. 41,101.412 ,103,0)
  8388   API PARAME TER #1^F^^ W;3^K:$L(X )>30!($L(X )<1) X
  8389   "^DD",101. 41,101.412 ,103,3)
  8390   Answer mus t be 1-30  characters  in length .
  8391   "^DD",101. 41,101.412 ,103,21,0)
  8392   ^^1^1^2950 715^
  8393   "^DD",101. 41,101.412 ,103,21,1, 0)
  8394   A paramete r that is  used by th e API call  may be st ored here.
  8395   "^DD",101. 41,101.412 ,103,"DT")
  8396   2950715
  8397   "^DD",101. 41,101.412 ,113,0)
  8398   WINDOWS CO NDITION^K^ ^W3;E1,245 ^K:$L(X)>2 45 X D:$D( X) ^DIM
  8399   "^DD",101. 41,101.412 ,113,3)
  8400   This is St andard MUM PS code.
  8401   "^DD",101. 41,101.412 ,113,9)
  8402   @
  8403   "^DD",101. 41,101.412 ,113,21,0)
  8404   ^^3^3^2950 715^
  8405   "^DD",101. 41,101.412 ,113,21,1, 0)
  8406   This is si lent code  that is ex ecuted whe n building  the dialo g for wind ows.
  8407   "^DD",101. 41,101.412 ,113,21,2, 0)
  8408   It identif ies which  prompts sh ould be in cluded in  the dialog .  The con dition
  8409   "^DD",101. 41,101.412 ,113,21,3, 0)
  8410   should lea ve $T fals e if the p rompt shou ld not be  asked.
  8411   "^DD",101. 41,101.412 ,113,"DT")
  8412   2950715
  8413   "^DD",101. 41,101.412 ,117,0)
  8414   WINDOWS DE FAULT^K^^W 7;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  8415   "^DD",101. 41,101.412 ,117,3)
  8416   This is St andard MUM PS code.
  8417   "^DD",101. 41,101.412 ,117,9)
  8418   @
  8419   "^DD",101. 41,101.412 ,117,21,0)
  8420   ^^2^2^2950 715^
  8421   "^DD",101. 41,101.412 ,117,21,1, 0)
  8422   This code  should sil ently set  the defaul t value of  a prompt  when it is  
  8423   "^DD",101. 41,101.412 ,117,21,2, 0)
  8424   selected.
  8425   "^DD",101. 41,101.412 ,117,"DT")
  8426   2950715
  8427   "^DD",101. 41,101.412 18,0)
  8428   DEFAULT WO RD-PROCESS ING TEXT S UB-FIELD^^ .01^1
  8429   "^DD",101. 41,101.412 18,0,"DT")
  8430   2950407
  8431   "^DD",101. 41,101.412 18,0,"NM", "DEFAULT W ORD-PROCES SING TEXT" )
  8432  
  8433   "^DD",101. 41,101.412 18,0,"UP")
  8434   101.412
  8435   "^DD",101. 41,101.412 18,.01,0)
  8436   DEFAULT WO RD-PROCESS ING TEXT^W ^^0;1^Q
  8437   "^DD",101. 41,101.412 18,.01,3)
  8438   Enter the  default re sponse for  a word-pr ocessing t ype prompt .
  8439   "^DD",101. 41,101.412 18,.01,21, 0)
  8440   ^^2^2^2950 407^
  8441   "^DD",101. 41,101.412 18,.01,21, 1,0)
  8442   This field  contains  the text t o be prese nted as th e default  for this p rompt,
  8443   "^DD",101. 41,101.412 18,.01,21, 2,0)
  8444   for word-p rocessing  type promp ts.
  8445   "^DD",101. 41,101.412 18,.01,"DT ")
  8446   2950407
  8447   "^DD",101. 41,101.415 ,0)
  8448   CONTROLS S UB-FIELD^^ 14^14
  8449   "^DD",101. 41,101.415 ,0,"DT")
  8450   2960202
  8451   "^DD",101. 41,101.415 ,0,"IX","A C",101.415 ,3)
  8452  
  8453   "^DD",101. 41,101.415 ,0,"IX","B ",101.415, .01)
  8454  
  8455   "^DD",101. 41,101.415 ,0,"NM","C ONTROLS")
  8456  
  8457   "^DD",101. 41,101.415 ,0,"UP")
  8458   101.41
  8459   "^DD",101. 41,101.415 ,.01,0)
  8460   LOGICAL NA ME^MF^^0;1 ^K:$L(X)>8 !($L(X)<1) !'(X?1.8U)  X
  8461   "^DD",101. 41,101.415 ,.01,1,0)
  8462   ^.1
  8463   "^DD",101. 41,101.415 ,.01,1,1,0 )
  8464   101.415^B
  8465   "^DD",101. 41,101.415 ,.01,1,1,1 )
  8466   S ^ORD(101 .41,DA(1), 50,"B",$E( X,1,30),DA )=""
  8467   "^DD",101. 41,101.415 ,.01,1,1,2 )
  8468   K ^ORD(101 .41,DA(1), 50,"B",$E( X,1,30),DA )
  8469   "^DD",101. 41,101.415 ,.01,3)
  8470   Answer mus t be 1-8 c haracters  in length.
  8471   "^DD",101. 41,101.415 ,.01,21,0)
  8472   ^^1^1^2960 202^
  8473   "^DD",101. 41,101.415 ,.01,21,1, 0)
  8474   This is th e name by  which cont rols can r efer to ea ch other.
  8475   "^DD",101. 41,101.415 ,.01,"DT")
  8476   2960202
  8477   "^DD",101. 41,101.415 ,2,0)
  8478   ITEM^P101. 41'^ORD(10 1.41,^0;2^ Q
  8479   "^DD",101. 41,101.415 ,2,"DT")
  8480   2960202
  8481   "^DD",101. 41,101.415 ,3,0)
  8482   CREATE SEQ UENCE^NJ2, 0^^0;3^K:+ X'=X!(X>99 )!(X<1)!(X ?.E1"."1N. N) X
  8483   "^DD",101. 41,101.415 ,3,1,0)
  8484   ^.1
  8485   "^DD",101. 41,101.415 ,3,1,1,0)
  8486   101.415^AC
  8487   "^DD",101. 41,101.415 ,3,1,1,1)
  8488   S ^ORD(101 .41,DA(1), 50,"AC",$E (X,1,30),D A)=""
  8489   "^DD",101. 41,101.415 ,3,1,1,2)
  8490   K ^ORD(101 .41,DA(1), 50,"AC",$E (X,1,30),D A)
  8491   "^DD",101. 41,101.415 ,3,1,1,"%D ",0)
  8492   ^^2^2^2960 202^
  8493   "^DD",101. 41,101.415 ,3,1,1,"%D ",1,0)
  8494   The 'AC' c ross-refer ence puts  in window  controls i n order by  creation 
  8495   "^DD",101. 41,101.415 ,3,1,1,"%D ",2,0)
  8496   sequence.
  8497   "^DD",101. 41,101.415 ,3,1,1,"DT ")
  8498   2960202
  8499   "^DD",101. 41,101.415 ,3,3)
  8500   Type a Num ber betwee n 1 and 99 , 0 Decima l Digits
  8501   "^DD",101. 41,101.415 ,3,"DT")
  8502   2960202
  8503   "^DD",101. 41,101.415 ,4,0)
  8504   CONTROL TY PE^S^0:Lab el;1:Butto n;2:Edit;3 :Memo;4:Li stBox;5:Si mpleCombo; 6:DropDown List;7:Lon gCombo;^0; 4^Q
  8505   "^DD",101. 41,101.415 ,4,"DT")
  8506   2960202
  8507   "^DD",101. 41,101.415 ,5,0)
  8508   LABEL^F^^0 ;5^K:$L(X) >30!($L(X) <1) X
  8509   "^DD",101. 41,101.415 ,5,3)
  8510   Answer mus t be 1-30  characters  in length .
  8511   "^DD",101. 41,101.415 ,5,"DT")
  8512   2960202
  8513   "^DD",101. 41,101.415 ,6,0)
  8514   BESIDE^F^^ 0;6^K:$L(X )>8!($L(X) <1) X
  8515   "^DD",101. 41,101.415 ,6,3)
  8516   Answer mus t be 1-8 c haracters  in length.
  8517   "^DD",101. 41,101.415 ,6,"DT")
  8518   2960202
  8519   "^DD",101. 41,101.415 ,7,0)
  8520   BELOW^F^^0 ;7^K:$L(X) >8!($L(X)< 1) X
  8521   "^DD",101. 41,101.415 ,7,3)
  8522   Answer mus t be 1-8 c haracters  in length.
  8523   "^DD",101. 41,101.415 ,7,"DT")
  8524   2960202
  8525   "^DD",101. 41,101.415 ,8,0)
  8526   WIDTH^NJ6, 4^^0;8^K:+ X'=X!(X>1) !(X<0)!(X? .E1"."5N.N ) X
  8527   "^DD",101. 41,101.415 ,8,3)
  8528   Type a Num ber betwee n 0 and 1,  4 Decimal  Digits
  8529   "^DD",101. 41,101.415 ,8,"DT")
  8530   2960202
  8531   "^DD",101. 41,101.415 ,9,0)
  8532   LEFT CONTR OL^F^^0;9^ K:$L(X)>8! ($L(X)<1)  X
  8533   "^DD",101. 41,101.415 ,9,3)
  8534   Answer mus t be 1-8 c haracters  in length.
  8535   "^DD",101. 41,101.415 ,9,"DT")
  8536   2960202
  8537   "^DD",101. 41,101.415 ,10,0)
  8538   RIGHT CONT ROL^F^^0;1 0^K:$L(X)> 8!($L(X)<1 ) X
  8539   "^DD",101. 41,101.415 ,10,3)
  8540   Answer mus t be 1-8 c haracters  in length.
  8541   "^DD",101. 41,101.415 ,10,"DT")
  8542   2960202
  8543   "^DD",101. 41,101.415 ,11,0)
  8544   HEIGHT^NJ2 ,0^^0;11^K :+X'=X!(X> 15)!(X<1)! (X?.E1"."1 N.N) X
  8545   "^DD",101. 41,101.415 ,11,3)
  8546   Type a Num ber betwee n 1 and 15 , 0 Decima l Digits
  8547   "^DD",101. 41,101.415 ,11,"DT")
  8548   2960202
  8549   "^DD",101. 41,101.415 ,12,0)
  8550   UPPER CONT ROL^F^^0;1 2^K:$L(X)> 8!($L(X)<1 ) X
  8551   "^DD",101. 41,101.415 ,12,3)
  8552   Answer mus t be 1-8 c haracters  in length.
  8553   "^DD",101. 41,101.415 ,12,"DT")
  8554   2960202
  8555   "^DD",101. 41,101.415 ,13,0)
  8556   LOWER CONT ROL^F^^0;1 3^K:$L(X)> 8!($L(X)<1 ) X
  8557   "^DD",101. 41,101.415 ,13,3)
  8558   Answer mus t be 1-8 c haracters  in length.
  8559   "^DD",101. 41,101.415 ,13,"DT")
  8560   2960202
  8561   "^DD",101. 41,101.415 ,14,0)
  8562   TAB SEQUEN CE^NJ2,0^^ 0;14^K:+X' =X!(X>89)! (X<0)!(X?. E1"."1N.N)  X
  8563   "^DD",101. 41,101.415 ,14,3)
  8564   Type a Num ber betwee n 0 and 89 , 0 Decima l Digits
  8565   "^DD",101. 41,101.415 ,14,"DT")
  8566   2960202
  8567   "^DD",101. 41,101.416 ,0)
  8568   RESPONSES  SUB-FIELD^ ^2^5
  8569   "^DD",101. 41,101.416 ,0,"DT")
  8570   2960717
  8571   "^DD",101. 41,101.416 ,0,"IX","D ",101.416, .02)
  8572  
  8573   "^DD",101. 41,101.416 ,0,"NM","R ESPONSES")
  8574  
  8575   "^DD",101. 41,101.416 ,0,"UP")
  8576   101.41
  8577   "^DD",101. 41,101.416 ,.01,0)
  8578   ITEM ENTRY ^MNJ7,0^^0 ;1^K:+X'=X !(X>999999 9)!(X<1)!( X?.E1"."1N .N) X
  8579   "^DD",101. 41,101.416 ,.01,1,0)
  8580   ^.1^^0
  8581   "^DD",101. 41,101.416 ,.01,3)
  8582   Type a Num ber betwee n 1 and 99 99999, 0 D ecimal Dig its
  8583   "^DD",101. 41,101.416 ,.01,21,0)
  8584   ^^2^2^2971 219^^^
  8585   "^DD",101. 41,101.416 ,.01,21,1, 0)
  8586   This is th e internal  entry num ber of the  prompt in  the Item  multiple
  8587   "^DD",101. 41,101.416 ,.01,21,2, 0)
  8588   by which t his respon se was obt ained.
  8589   "^DD",101. 41,101.416 ,.01,"DT")
  8590   2961118
  8591   "^DD",101. 41,101.416 ,.02,0)
  8592   DIALOG^P10 1.41'^ORD( 101.41,^0; 2^Q
  8593   "^DD",101. 41,101.416 ,.02,1,0)
  8594   ^.1
  8595   "^DD",101. 41,101.416 ,.02,1,1,0 )
  8596   101.416^D
  8597   "^DD",101. 41,101.416 ,.02,1,1,1 )
  8598   S ^ORD(101 .41,DA(1), 6,"D",$E(X ,1,30),DA) =""
  8599   "^DD",101. 41,101.416 ,.02,1,1,2 )
  8600   K ^ORD(101 .41,DA(1), 6,"D",$E(X ,1,30),DA)
  8601   "^DD",101. 41,101.416 ,.02,1,1," DT")
  8602   2961118
  8603   "^DD",101. 41,101.416 ,.02,3)
  8604   Select the  dialog pr ompt from  which this  response  was genera ted.
  8605   "^DD",101. 41,101.416 ,.02,21,0)
  8606   ^^2^2^2960 717^
  8607   "^DD",101. 41,101.416 ,.02,21,1, 0)
  8608   This is a  pointer to  the dialo g prompt,  which is i n the Orde r Dialog f ile
  8609   "^DD",101. 41,101.416 ,.02,21,2, 0)
  8610   as type pr ompt.
  8611   "^DD",101. 41,101.416 ,.02,"DT")
  8612   2961118
  8613   "^DD",101. 41,101.416 ,.03,0)
  8614   INSTANCE^N J7,0^^0;3^ K:+X'=X!(X >9999999)! (X<1)!(X?. E1"."1N.N)  X
  8615   "^DD",101. 41,101.416 ,.03,3)
  8616   Type a Num ber betwee n 1 and 99 99999, 0 D ecimal Dig its
  8617   "^DD",101. 41,101.416 ,.03,21,0)
  8618   ^^2^2^2960 717^
  8619   "^DD",101. 41,101.416 ,.03,21,1, 0)
  8620   In the cas e of multi ple answer s for the  same item,  this iden tifies the
  8621   "^DD",101. 41,101.416 ,.03,21,2, 0)
  8622   individual  instance.
  8623   "^DD",101. 41,101.416 ,.03,"DT")
  8624   2960717
  8625   "^DD",101. 41,101.416 ,1,0)
  8626   VALUE^FO^^ 1;1^K:$L(X )>245!($L( X)<1) X
  8627   "^DD",101. 41,101.416 ,1,2)
  8628   S Y(0)=Y S  Y=$$OUTPU T^ORCMEDT5 (Y)
  8629   "^DD",101. 41,101.416 ,1,2.1)
  8630   S Y=$$OUTP UT^ORCMEDT 5(Y)
  8631   "^DD",101. 41,101.416 ,1,3)
  8632   Answer mus t be 1-245  character s in lengt h.
  8633   "^DD",101. 41,101.416 ,1,21,0)
  8634   ^^2^2^2971 219^^
  8635   "^DD",101. 41,101.416 ,1,21,1,0)
  8636   This conta ins the ac tual respo nse, unles s the valu e is a wor d processi ng
  8637   "^DD",101. 41,101.416 ,1,21,2,0)
  8638   type.
  8639   "^DD",101. 41,101.416 ,1,"DT")
  8640   2980717
  8641   "^DD",101. 41,101.416 ,2,0)
  8642   TEXT^101.4 162^^2;0
  8643   "^DD",101. 41,101.416 ,2,21,0)
  8644   ^^1^1^2971 219^
  8645   "^DD",101. 41,101.416 ,2,21,1,0)
  8646   This conta ins the ac tual respo nse, for w ord-proces sing type  prompts.
  8647   "^DD",101. 41,101.416 ,2,"DT")
  8648   2960717
  8649   "^DD",101. 41,101.416 2,0)
  8650   TEXT SUB-F IELD^^.01^ 1
  8651   "^DD",101. 41,101.416 2,0,"DT")
  8652   2960717
  8653   "^DD",101. 41,101.416 2,0,"NM"," TEXT")
  8654  
  8655   "^DD",101. 41,101.416 2,0,"UP")
  8656   101.416
  8657   "^DD",101. 41,101.416 2,.01,0)
  8658   TEXT^WL^^0 ;1^Q
  8659   "^DD",101. 41,101.416 2,.01,21,0 )
  8660   ^^1^1^2960 717^^
  8661   "^DD",101. 41,101.416 2,.01,21,1 ,0)
  8662   This conta ins respon ses to ite ms that ar e a word p rocessing  type.
  8663   "^DD",101. 41,101.416 2,.01,"DT" )
  8664   2960717
  8665   "^DIC",101 .41,101.41 ,0)
  8666   ORDER DIAL OG^101.41
  8667   "^DIC",101 .41,101.41 ,0,"GL")
  8668   ^ORD(101.4 1,
  8669   "^DIC",101 .41,101.41 ,"%D",0)
  8670   ^^2^2^2960 819^^
  8671   "^DIC",101 .41,101.41 ,"%D",1,0)
  8672   This file  contains t he informa tion neede d to defin e how to p rompt for  each
  8673   "^DIC",101 .41,101.41 ,"%D",2,0)
  8674   order, wha t values a re accepta ble, etc.
  8675   "^DIC",101 .41,"B","O RDER DIALO G",101.41)
  8676  
  8677   **END**
  8678   **END**