13. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 10/3/2017 11:15:12 AM 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.

13.1 Files compared

# Location File Last Modified
1 ehmp.zip\ehmp\ehmp\product\production\kids HMP1_S54.KID Tue Dec 15 14:05:18 2015 UTC
2 ehmp.zip\ehmp\ehmp\product\production\kids HMP1_S54.KID Mon Oct 2 19:46:56 2017 UTC

13.2 Comparison summary

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

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

13.4 Active regular expressions

No regular expressions were active.

13.5 Comparison detail

  1   KIDS Distr ibution sa ved on Apr  08, 2014@ 17:57:36
  2   HMP 1.0 Bu ild for S5 4 (April 8 , 2014)
  3   **KIDS**:H MP 1.0^MD* 1.0*38^OR* 3.0*390^VP R*1.0*3^
  4  
  5   **INSTALL  NAME**
  6   HMP 1.0
  7   "BLD",8821 ,0)
  8   HMP 1.0^^1 ^3140408^n
  9   "BLD",8821 ,6.3)
  10   107
  11   "BLD",8821 ,10,0)
  12   ^9.63^3^3
  13   "BLD",8821 ,10,1,0)
  14   MD*1.0*38^ 1
  15   "BLD",8821 ,10,2,0)
  16   OR*3.0*390 ^1
  17   "BLD",8821 ,10,3,0)
  18   VPR*1.0*3^ 1
  19   "BLD",8821 ,10,"B","M D*1.0*38", 1)
  20  
  21   "BLD",8821 ,10,"B","O R*3.0*390" ,2)
  22  
  23   "BLD",8821 ,10,"B","V PR*1.0*3", 3)
  24  
  25   "BLD",8821 ,"KRN",0)
  26   ^9.67PA^77 9.2^20
  27   "BLD",8821 ,"KRN",.4, 0)
  28   .4
  29   "BLD",8821 ,"KRN",.40 1,0)
  30   .401
  31   "BLD",8821 ,"KRN",.40 2,0)
  32   .402
  33   "BLD",8821 ,"KRN",.40 3,0)
  34   .403
  35   "BLD",8821 ,"KRN",.5, 0)
  36   .5
  37   "BLD",8821 ,"KRN",.84 ,0)
  38   .84
  39   "BLD",8821 ,"KRN",3.6 ,0)
  40   3.6
  41   "BLD",8821 ,"KRN",3.8 ,0)
  42   3.8
  43   "BLD",8821 ,"KRN",9.2 ,0)
  44   9.2
  45   "BLD",8821 ,"KRN",9.8 ,0)
  46   9.8
  47   "BLD",8821 ,"KRN",19, 0)
  48   19
  49   "BLD",8821 ,"KRN",19. 1,0)
  50   19.1
  51   "BLD",8821 ,"KRN",101 ,0)
  52   101
  53   "BLD",8821 ,"KRN",409 .61,0)
  54   409.61
  55   "BLD",8821 ,"KRN",771 ,0)
  56   771
  57   "BLD",8821 ,"KRN",779 .2,0)
  58   779.2
  59   "BLD",8821 ,"KRN",870 ,0)
  60   870
  61   "BLD",8821 ,"KRN",898 9.51,0)
  62   8989.51
  63   "BLD",8821 ,"KRN",898 9.52,0)
  64   8989.52
  65   "BLD",8821 ,"KRN",899 4,0)
  66   8994
  67   "BLD",8821 ,"KRN","B" ,.4,.4)
  68  
  69   "BLD",8821 ,"KRN","B" ,.401,.401 )
  70  
  71   "BLD",8821 ,"KRN","B" ,.402,.402 )
  72  
  73   "BLD",8821 ,"KRN","B" ,.403,.403 )
  74  
  75   "BLD",8821 ,"KRN","B" ,.5,.5)
  76  
  77   "BLD",8821 ,"KRN","B" ,.84,.84)
  78  
  79   "BLD",8821 ,"KRN","B" ,3.6,3.6)
  80  
  81   "BLD",8821 ,"KRN","B" ,3.8,3.8)
  82  
  83   "BLD",8821 ,"KRN","B" ,9.2,9.2)
  84  
  85   "BLD",8821 ,"KRN","B" ,9.8,9.8)
  86  
  87   "BLD",8821 ,"KRN","B" ,19,19)
  88  
  89   "BLD",8821 ,"KRN","B" ,19.1,19.1 )
  90  
  91   "BLD",8821 ,"KRN","B" ,101,101)
  92  
  93   "BLD",8821 ,"KRN","B" ,409.61,40 9.61)
  94  
  95   "BLD",8821 ,"KRN","B" ,771,771)
  96  
  97   "BLD",8821 ,"KRN","B" ,779.2,779 .2)
  98  
  99   "BLD",8821 ,"KRN","B" ,870,870)
  100  
  101   "BLD",8821 ,"KRN","B" ,8989.51,8 989.51)
  102  
  103   "BLD",8821 ,"KRN","B" ,8989.52,8 989.52)
  104  
  105   "BLD",8821 ,"KRN","B" ,8994,8994 )
  106  
  107   "MBREQ")
  108   0
  109   "QUES","XP F1",0)
  110   Y
  111   "QUES","XP F1","??")
  112   ^D REP^XPD H
  113   "QUES","XP F1","A")
  114   Shall I wr ite over y our |FLAG|  File
  115   "QUES","XP F1","B")
  116   YES
  117   "QUES","XP F1","M")
  118   D XPF1^XPD IQ
  119   "QUES","XP F2",0)
  120   Y
  121   "QUES","XP F2","??")
  122   ^D DTA^XPD H
  123   "QUES","XP F2","A")
  124   Want my da ta |FLAG|  yours
  125   "QUES","XP F2","B")
  126   YES
  127   "QUES","XP F2","M")
  128   D XPF2^XPD IQ
  129   "QUES","XP I1",0)
  130   YO
  131   "QUES","XP I1","??")
  132   ^D INHIBIT ^XPDH
  133   "QUES","XP I1","A")
  134   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  135   "QUES","XP I1","B")
  136   NO
  137   "QUES","XP I1","M")
  138   D XPI1^XPD IQ
  139   "QUES","XP M1",0)
  140   PO^VA(200, :EM
  141   "QUES","XP M1","??")
  142   ^D MG^XPDH
  143   "QUES","XP M1","A")
  144   Enter the  Coordinato r for Mail  Group '|F LAG|'
  145   "QUES","XP M1","B")
  146  
  147   "QUES","XP M1","M")
  148   D XPM1^XPD IQ
  149   "QUES","XP O1",0)
  150   Y
  151   "QUES","XP O1","??")
  152   ^D MENU^XP DH
  153   "QUES","XP O1","A")
  154   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  155   "QUES","XP O1","B")
  156   NO
  157   "QUES","XP O1","M")
  158   D XPO1^XPD IQ
  159   "QUES","XP Z1",0)
  160   Y
  161   "QUES","XP Z1","??")
  162   ^D OPT^XPD H
  163   "QUES","XP Z1","A")
  164   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  165   "QUES","XP Z1","B")
  166   NO
  167   "QUES","XP Z1","M")
  168   D XPZ1^XPD IQ
  169   "QUES","XP Z2",0)
  170   Y
  171   "QUES","XP Z2","??")
  172   ^D RTN^XPD H
  173   "QUES","XP Z2","A")
  174   Want to MO VE routine s to other  CPUs
  175   "QUES","XP Z2","B")
  176   NO
  177   "QUES","XP Z2","M")
  178   D XPZ2^XPD IQ
  179   "VER")
  180   8.0^22.0
  181   **INSTALL  NAME**
  182   MD*1.0*38
  183   "BLD",8820 ,0)
  184   MD*1.0*38^ CLINICAL P ROCEDURES^ 0^3140408^ y
  185   "BLD",8820 ,1,0)
  186   ^^2^2^3131 219^
  187   "BLD",8820 ,1,1,0)
  188   This patch  creates a n event fo r broadcas ting new o r updated  data in th e
  189   "BLD",8820 ,1,2,0)
  190   Clinical O bservation s (CLiO) m odule.
  191   "BLD",8820 ,4,0)
  192   ^9.64PA^^
  193   "BLD",8820 ,6.3)
  194   97
  195   "BLD",8820 ,"INIT")
  196   EN^MDPOST3 8
  197   "BLD",8820 ,"KRN",0)
  198   ^9.67PA^77 9.2^20
  199   "BLD",8820 ,"KRN",.4, 0)
  200   .4
  201   "BLD",8820 ,"KRN",.40 1,0)
  202   .401
  203   "BLD",8820 ,"KRN",.40 2,0)
  204   .402
  205   "BLD",8820 ,"KRN",.40 3,0)
  206   .403
  207   "BLD",8820 ,"KRN",.5, 0)
  208   .5
  209   "BLD",8820 ,"KRN",.84 ,0)
  210   .84
  211   "BLD",8820 ,"KRN",3.6 ,0)
  212   3.6
  213   "BLD",8820 ,"KRN",3.8 ,0)
  214   3.8
  215   "BLD",8820 ,"KRN",9.2 ,0)
  216   9.2
  217   "BLD",8820 ,"KRN",9.8 ,0)
  218   9.8
  219   "BLD",8820 ,"KRN",9.8 ,"NM",0)
  220   ^9.68A^1^1
  221   "BLD",8820 ,"KRN",9.8 ,"NM",1,0)
  222   MDCPROTD^^ 0^B6599959
  223   "BLD",8820 ,"KRN",9.8 ,"NM","B", "MDCPROTD" ,1)
  224  
  225   "BLD",8820 ,"KRN",19, 0)
  226   19
  227   "BLD",8820 ,"KRN",19. 1,0)
  228   19.1
  229   "BLD",8820 ,"KRN",101 ,0)
  230   101
  231   "BLD",8820 ,"KRN",101 ,"NM",0)
  232   ^9.68A^1^1
  233   "BLD",8820 ,"KRN",101 ,"NM",1,0)
  234   MDC OBSERV ATION UPDA TE^^0
  235   "BLD",8820 ,"KRN",101 ,"NM","B", "MDC OBSER VATION UPD ATE",1)
  236  
  237   "BLD",8820 ,"KRN",409 .61,0)
  238   409.61
  239   "BLD",8820 ,"KRN",771 ,0)
  240   771
  241   "BLD",8820 ,"KRN",779 .2,0)
  242   779.2
  243   "BLD",8820 ,"KRN",870 ,0)
  244   870
  245   "BLD",8820 ,"KRN",898 9.51,0)
  246   8989.51
  247   "BLD",8820 ,"KRN",898 9.52,0)
  248   8989.52
  249   "BLD",8820 ,"KRN",899 4,0)
  250   8994
  251   "BLD",8820 ,"KRN","B" ,.4,.4)
  252  
  253   "BLD",8820 ,"KRN","B" ,.401,.401 )
  254  
  255   "BLD",8820 ,"KRN","B" ,.402,.402 )
  256  
  257   "BLD",8820 ,"KRN","B" ,.403,.403 )
  258  
  259   "BLD",8820 ,"KRN","B" ,.5,.5)
  260  
  261   "BLD",8820 ,"KRN","B" ,.84,.84)
  262  
  263   "BLD",8820 ,"KRN","B" ,3.6,3.6)
  264  
  265   "BLD",8820 ,"KRN","B" ,3.8,3.8)
  266  
  267   "BLD",8820 ,"KRN","B" ,9.2,9.2)
  268  
  269   "BLD",8820 ,"KRN","B" ,9.8,9.8)
  270  
  271   "BLD",8820 ,"KRN","B" ,19,19)
  272  
  273   "BLD",8820 ,"KRN","B" ,19.1,19.1 )
  274  
  275   "BLD",8820 ,"KRN","B" ,101,101)
  276  
  277   "BLD",8820 ,"KRN","B" ,409.61,40 9.61)
  278  
  279   "BLD",8820 ,"KRN","B" ,771,771)
  280  
  281   "BLD",8820 ,"KRN","B" ,779.2,779 .2)
  282  
  283   "BLD",8820 ,"KRN","B" ,870,870)
  284  
  285   "BLD",8820 ,"KRN","B" ,8989.51,8 989.51)
  286  
  287   "BLD",8820 ,"KRN","B" ,8989.52,8 989.52)
  288  
  289   "BLD",8820 ,"KRN","B" ,8994,8994 )
  290  
  291   "BLD",8820 ,"QUES",0)
  292   ^9.62^^
  293   "BLD",8820 ,"REQB",0)
  294   ^9.611^^
  295   "INIT")
  296   EN^MDPOST3 8
  297   "KRN",101, 5982,-1)
  298   0^1
  299   "KRN",101, 5982,0)
  300   MDC OBSERV ATION UPDA TE^Observa tion updat e notifica tion^^X^^^ ^^^^^CLINI CAL PROCED URES
  301   "KRN",101, 5982,1,0)
  302   ^^16^16^31 20830^
  303   "KRN",101, 5982,1,1,0 )
  304   This proto col will b e triggere d when an  observatio n in the O BS file 
  305   "KRN",101, 5982,1,2,0 )
  306   enters or  leaves VER IFIED stat us.
  307   "KRN",101, 5982,1,3,0 )
  308    
  309   "KRN",101, 5982,1,4,0 )
  310   The local  array "MDC OBS" will  be populat ed as foll ows:
  311   "KRN",101, 5982,1,5,0 )
  312    
  313   "KRN",101, 5982,1,6,0 )
  314   MDCOBS("OB S_ID","E") ="{3562723 0-5C66-49E 3-AD93-97C 269CB257D} "
  315   "KRN",101, 5982,1,7,0 )
  316   MDCOBS("OB S_ID","I") ="{3562723 0-5C66-49E 3-AD93-97C 269CB257D} "
  317   "KRN",101, 5982,1,8,0 )
  318   MDCOBS("OL D_STATUS", "E")="Veri fied"
  319   "KRN",101, 5982,1,9,0 )
  320   MDCOBS("OL D_STATUS", "I")=1
  321   "KRN",101, 5982,1,10, 0)
  322   MDCOBS("PA TIENT_ID", "E")="SIMP SON,BARTHO LOMUE"
  323   "KRN",101, 5982,1,11, 0)
  324   MDCOBS("PA TIENT_ID", "I")=2
  325   "KRN",101, 5982,1,12, 0)
  326   MDCOBS("ST ATUS","E") ="Unverifi ed"
  327   "KRN",101, 5982,1,13, 0)
  328   MDCOBS("ST ATUS","I") =0
  329   "KRN",101, 5982,1,14, 0)
  330    
  331   "KRN",101, 5982,1,15, 0)
  332   In case of  an error,  MDCOBS("E RROR") wil l be popul ated with  the error 
  333   "KRN",101, 5982,1,16, 0)
  334   number and  error tex t from Fil eMan.
  335   "KRN",101, 5982,5)
  336  
  337   "KRN",101, 5982,10,0)
  338   ^101.01PA^ 6^1
  339   "KRN",101, 5982,20)
  340   D EN^MDCPR OTD
  341   "KRN",101, 5982,99)
  342   63272,5447 5
  343   "KRN",101, 5982,775,0 )
  344   ^101.0775P A^^
  345   "MBREQ")
  346   1
  347   "ORD",15,1 01)
  348   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  349   "ORD",15,1 01,0)
  350   PROTOCOL
  351   "PKG",557, -1)
  352   1^1
  353   "PKG",557, 0)
  354   CLINICAL P ROCEDURES^ MD^Clinica l Procedur es
  355   "PKG",557, 20,0)
  356   ^9.402P^^
  357   "PKG",557, 22,0)
  358   ^9.49I^1^1
  359   "PKG",557, 22,1,0)
  360   1.0^304042 9^3050121^ 1000000002 0
  361   "PKG",557, 22,1,"PAH" ,1,0)
  362   38^3140408 ^1085
  363   "PKG",557, 22,1,"PAH" ,1,1,0)
  364   ^^2^2^3140 408
  365   "PKG",557, 22,1,"PAH" ,1,1,1,0)
  366   This patch  creates a n event fo r broadcas ting new o r updated  data in th e
  367   "PKG",557, 22,1,"PAH" ,1,1,2,0)
  368   Clinical O bservation s (CLiO) m odule.
  369   "QUES","XP F1",0)
  370   Y
  371   "QUES","XP F1","??")
  372   ^D REP^XPD H
  373   "QUES","XP F1","A")
  374   Shall I wr ite over y our |FLAG|  File
  375   "QUES","XP F1","B")
  376   YES
  377   "QUES","XP F1","M")
  378   D XPF1^XPD IQ
  379   "QUES","XP F2",0)
  380   Y
  381   "QUES","XP F2","??")
  382   ^D DTA^XPD H
  383   "QUES","XP F2","A")
  384   Want my da ta |FLAG|  yours
  385   "QUES","XP F2","B")
  386   YES
  387   "QUES","XP F2","M")
  388   D XPF2^XPD IQ
  389   "QUES","XP I1",0)
  390   YO
  391   "QUES","XP I1","??")
  392   ^D INHIBIT ^XPDH
  393   "QUES","XP I1","A")
  394   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  395   "QUES","XP I1","B")
  396   NO
  397   "QUES","XP I1","M")
  398   D XPI1^XPD IQ
  399   "QUES","XP M1",0)
  400   PO^VA(200, :EM
  401   "QUES","XP M1","??")
  402   ^D MG^XPDH
  403   "QUES","XP M1","A")
  404   Enter the  Coordinato r for Mail  Group '|F LAG|'
  405   "QUES","XP M1","B")
  406  
  407   "QUES","XP M1","M")
  408   D XPM1^XPD IQ
  409   "QUES","XP O1",0)
  410   Y
  411   "QUES","XP O1","??")
  412   ^D MENU^XP DH
  413   "QUES","XP O1","A")
  414   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  415   "QUES","XP O1","B")
  416   NO
  417   "QUES","XP O1","M")
  418   D XPO1^XPD IQ
  419   "QUES","XP Z1",0)
  420   Y
  421   "QUES","XP Z1","??")
  422   ^D OPT^XPD H
  423   "QUES","XP Z1","A")
  424   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  425   "QUES","XP Z1","B")
  426   NO
  427   "QUES","XP Z1","M")
  428   D XPZ1^XPD IQ
  429   "QUES","XP Z2",0)
  430   Y
  431   "QUES","XP Z2","??")
  432   ^D RTN^XPD H
  433   "QUES","XP Z2","A")
  434   Want to MO VE routine s to other  CPUs
  435   "QUES","XP Z2","B")
  436   NO
  437   "QUES","XP Z2","M")
  438   D XPZ2^XPD IQ
  439   "RTN")
  440   2
  441   "RTN","MDC PROTD")
  442   0^1^B65999 59
  443   "RTN","MDC PROTD",1,0 )
  444   MDCPROTD ; HINES OIFO /BLJ - Cli O backend  driver;02  Feb 2005 ;  12/12/13  8:52pm
  445   "RTN","MDC PROTD",2,0 )
  446    ;;1.0;CLI NICAL PROC EDURES;**3 8**;Apr 01 , 2004;Bui ld 97
  447   "RTN","MDC PROTD",3,0 )
  448    ;Per VHA  Directive  2004-038,  this routi ne should  not be mod ified.
  449   "RTN","MDC PROTD",4,0 )
  450    ;
  451   "RTN","MDC PROTD",5,0 )
  452    ; Externa l Referenc es -
  453   "RTN","MDC PROTD",6,0 )
  454    ;  EN^XQO R - IA # 1 0101
  455   "RTN","MDC PROTD",7,0 )
  456    ;
  457   "RTN","MDC PROTD",8,0 )
  458   EN ;
  459   "RTN","MDC PROTD",9,0 )
  460    ; First,  we'll get  the root o bservation .
  461   "RTN","MDC PROTD",10, 0)
  462    New MDCER R,IEN
  463   "RTN","MDC PROTD",11, 0)
  464    Set IEN=$ Get(DA) If  '+IEN Wri te "IEN FO R PROTOCOL  UNDEFINED !",! Quit
  465   "RTN","MDC PROTD",12, 0)
  466    Do GETS^D IQ(704.117 ,IEN_","," .01;.08;.0 9","EINR", "^TMP(""MD COBS"",$J) ","MDCERR" )
  467   "RTN","MDC PROTD",13, 0)
  468    If $Data( MDCERR) Do   Quit
  469   "RTN","MDC PROTD",14, 0)
  470    . Set MDC OBS("ERROR ")=$Get(MD CERR("DIER R",1))_U_$ Get(MDCERR ("DIERR",1 ,"TEXT",1) )
  471   "RTN","MDC PROTD",15, 0)
  472    Merge MDC OBS=^TMP(" MDCOBS",$J ,704.117,I EN_",") Ki ll ^TMP("M DCOBS",$J)
  473   "RTN","MDC PROTD",16, 0)
  474    Set MDCOB S("OLD_STA TUS","E")= $$EXTERNAL ^DILFD(704 .117,".09" ,,$Get(X1) )
  475   "RTN","MDC PROTD",17, 0)
  476    Set MDCOB S("OLD_STA TUS","I")= X1
  477   "RTN","MDC PROTD",18, 0)
  478    Set MDCOB S("DOMAIN" ,"VITALS") =0
  479   "RTN","MDC PROTD",19, 0)
  480    Set MDGUI D=$$GET1^D IQ(704.117 ,IEN_",",. 07)
  481   "RTN","MDC PROTD",20, 0)
  482    For Y=1:1  Quit:$Tex t(MAP+Y)=" "  If $Pie ce($Text(M AP+Y),";", 4)=MDGUID  Set MDCOBS ("DOMAIN", "VITALS")= 1 Quit
  483   "RTN","MDC PROTD",21, 0)
  484    Quit
  485   "RTN","MDC PROTD",22, 0)
  486    ;
  487   "RTN","MDC PROTD",23, 0)
  488   PROT ;Call  the proto col.
  489   "RTN","MDC PROTD",24, 0)
  490    Set X="MD C OBSERVAT ION UPDATE ",DIC="101 "
  491   "RTN","MDC PROTD",25, 0)
  492    Do EN^XQO R
  493   "RTN","MDC PROTD",26, 0)
  494    Quit
  495   "RTN","MDC PROTD",27, 0)
  496    ;
  497   "RTN","MDC PROTD",28, 0)
  498    ; This mu st be upda ted if Vit als EVER a dds a new  term that  we map to.  This only  says our  term it pa ired with  a vital si gn.
  499   "RTN","MDC PROTD",29, 0)
  500    ;
  501   "RTN","MDC PROTD",30, 0)
  502   MAP ; Cont ains the m appings fr om Vitals  to CliO -  vital;abbv ;vuid;term _guid
  503   "RTN","MDC PROTD",31, 0)
  504    ;;ABDOMIN AL GIRTH;{ F70E6642-2 719-22BE-B E87-DEF0A8 84F177}
  505   "RTN","MDC PROTD",32, 0)
  506    ;;AUDIOME TRY;{FFD29 134-8BB2-2 48E-0412-9 3C2C08B076 F}
  507   "RTN","MDC PROTD",33, 0)
  508    ;;BLOOD P RESSURE;{B 15F2DF6-CE 99-B847-FE 6B-3D5F174 A2BCD}
  509   "RTN","MDC PROTD",34, 0)
  510    ;;CENTRAL  VENOUS PR ESSURE;{D3 0F98A7-4C5 D-12E8-AB4 D-9C85A433 2EC3}
  511   "RTN","MDC PROTD",35, 0)
  512    ;;CIRCUMF ERENCE/GIR TH;{92A124 D4-B75F-9F D9-1A51-60 5887BCEA79 };
  513   "RTN","MDC PROTD",36, 0)
  514    ;;FETAL H EART TONES ;{A2E22A44 -E924-ADDE -2B8E-0251 666B4DE6}
  515   "RTN","MDC PROTD",37, 0)
  516    ;;FUNDAL  HEIGHT;{EE AB8762-624 F-7BA3-400 1-114FD229 BA69}
  517   "RTN","MDC PROTD",38, 0)
  518    ;;HEAD CI RCUMFERENC E;{33827E3 C-5DBB-083 C-D8BE-4DF D7D42071F}
  519   "RTN","MDC PROTD",39, 0)
  520    ;;HEARING ;{813CCC94 -3D64-5093 -BC6C-053E FD9948F9}
  521   "RTN","MDC PROTD",40, 0)
  522    ;;HEIGHT; {B440216B- 0FB3-1950- 7859-7C1BE 398FE4A}
  523   "RTN","MDC PROTD",41, 0)
  524    ;;PAIN;{4 7A83DEA-BA 95-38AD-DF 2E-1F20912 2E684}
  525   "RTN","MDC PROTD",42, 0)
  526    ;;PULSE;{ FCA63B76-E F4C-EBE5-3 3C1-F1EEBD 7A7BC4}
  527   "RTN","MDC PROTD",43, 0)
  528    ;;PULSE O XIMETRY;{5 F84DD55-3C CF-094C-25 36-B51EB7F AD999}
  529   "RTN","MDC PROTD",44, 0)
  530    ;;RESPIRA TION;{973E D2C0-0625- 7DF9-17DC- 8FFF7E376F 23}
  531   "RTN","MDC PROTD",45, 0)
  532    ;;TEMPERA TURE;{0F33 223E-DF2C- 6B8B-5201- 5E091C5F90 65}
  533   "RTN","MDC PROTD",46, 0)
  534    ;;TONOMET RY;{C06989 EF-4B0F-49 41-B1A7-FA 9D81A480FF }
  535   "RTN","MDC PROTD",47, 0)
  536    ;;VISION  CORRECTED; {ED022AC1- EBE4-E708- 684D-63D00 628A94C}
  537   "RTN","MDC PROTD",48, 0)
  538    ;;VISION  UNCORRECTE D;{BEA5E56 5-D728-F5B 3-0A3A-052 8C42A45C4}
  539   "RTN","MDC PROTD",49, 0)
  540    ;;WEIGHT; {CD2D8263- 6B71-0E1C- 0AFE-87B4B 2C12632}
  541   "RTN","MDP OST38")
  542   0^^B228306 4
  543   "RTN","MDP OST38",1,0 )
  544   MDPOST38 ; HINES OIFO /MKB - Pos t Installa tion Tasks ;02 Mar 20 08 ; 12/12 /13 8:52pm
  545   "RTN","MDP OST38",2,0 )
  546    ;;1.0;CLI NICAL PROC EDURES;**3 8**;Apr 01 , 2004;Bui ld 97
  547   "RTN","MDP OST38",3,0 )
  548    ;Per VHA  Directive  2004-038,  this routi ne should  not be mod ified.
  549   "RTN","MDP OST38",4,0 )
  550    ;
  551   "RTN","MDP OST38",5,0 )
  552    ; Externa l Referenc es -
  553   "RTN","MDP OST38",6,0 )
  554    ;  CREIXN ^DDMOD - I A # 2916
  555   "RTN","MDP OST38",7,0 )
  556    ;
  557   "RTN","MDP OST38",8,0 )
  558   EN ; -- cr eate ASTAT US index o n OBS file  #704.117
  559   "RTN","MDP OST38",9,0 )
  560    Q:$O(^DD( "IX","BB", 704.117,"A STATUS",0) )  ;exists
  561   "RTN","MDP OST38",10, 0)
  562    N VPRX,VP RY
  563   "RTN","MDP OST38",11, 0)
  564    S VPRX("F ILE")=704. 117,VPRX(" NAME")="AS TATUS"
  565   "RTN","MDP OST38",12, 0)
  566    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  567   "RTN","MDP OST38",13, 0)
  568    S VPRX("E XECUTION") ="F",VPRX( "ACTIVITY" )=""
  569   "RTN","MDP OST38",14, 0)
  570    S VPRX("S HORT DESCR ")="Used t o trigger  MD OBSERVA TION UPDAT E protocol "
  571   "RTN","MDP OST38",15, 0)
  572    S VPRX("D ESCR",1)=" This index  invokes t he MD OBSE RVATION UP DATE proto col when t he"
  573   "RTN","MDP OST38",16, 0)
  574    S VPRX("D ESCR",2)=" status of  OBS data i s changed  to or from  verified. "
  575   "RTN","MDP OST38",17, 0)
  576    S VPRX("D ESCR",3)=" No actual  cross-refe rence node s are set  or killed. "
  577   "RTN","MDP OST38",18, 0)
  578    S VPRX("S ET")="D:(( X1=""1"")! (X2=""1"") ) PROT^MDC PROTD Q"
  579   "RTN","MDP OST38",19, 0)
  580    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  581   "RTN","MDP OST38",20, 0)
  582    S VPRX("V AL",1)=.09              ;Status
  583   "RTN","MDP OST38",21, 0)
  584    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  585   "RTN","MDP OST38",22, 0)
  586    Q
  587   "VER")
  588   8.0^22.0
  589   **INSTALL  NAME**
  590   OR*3.0*390
  591   "BLD",8850 ,0)
  592   OR*3.0*390 ^ORDER ENT RY/RESULTS  REPORTING ^0^3140408 ^y
  593   "BLD",8850 ,4,0)
  594   ^9.64PA^^
  595   "BLD",8850 ,6.3)
  596   32
  597   "BLD",8850 ,"KRN",0)
  598   ^9.67PA^77 9.2^20
  599   "BLD",8850 ,"KRN",.4, 0)
  600   .4
  601   "BLD",8850 ,"KRN",.40 1,0)
  602   .401
  603   "BLD",8850 ,"KRN",.40 2,0)
  604   .402
  605   "BLD",8850 ,"KRN",.40 3,0)
  606   .403
  607   "BLD",8850 ,"KRN",.5, 0)
  608   .5
  609   "BLD",8850 ,"KRN",.84 ,0)
  610   .84
  611   "BLD",8850 ,"KRN",3.6 ,0)
  612   3.6
  613   "BLD",8850 ,"KRN",3.8 ,0)
  614   3.8
  615   "BLD",8850 ,"KRN",9.2 ,0)
  616   9.2
  617   "BLD",8850 ,"KRN",9.8 ,0)
  618   9.8
  619   "BLD",8850 ,"KRN",9.8 ,"NM",0)
  620   ^9.68A^4^4
  621   "BLD",8850 ,"KRN",9.8 ,"NM",1,0)
  622   ORCACT1^^0 ^B49643037
  623   "BLD",8850 ,"KRN",9.8 ,"NM",2,0)
  624   ORCSEND^^0 ^B65938879
  625   "BLD",8850 ,"KRN",9.8 ,"NM",3,0)
  626   ORMBLDOR^^ 0^B5650360
  627   "BLD",8850 ,"KRN",9.8 ,"NM",4,0)
  628   ORWDXA^^0^ B83177974
  629   "BLD",8850 ,"KRN",9.8 ,"NM","B", "ORCACT1", 1)
  630  
  631   "BLD",8850 ,"KRN",9.8 ,"NM","B", "ORCSEND", 2)
  632  
  633   "BLD",8850 ,"KRN",9.8 ,"NM","B", "ORMBLDOR" ,3)
  634  
  635   "BLD",8850 ,"KRN",9.8 ,"NM","B", "ORWDXA",4 )
  636  
  637   "BLD",8850 ,"KRN",19, 0)
  638   19
  639   "BLD",8850 ,"KRN",19. 1,0)
  640   19.1
  641   "BLD",8850 ,"KRN",101 ,0)
  642   101
  643   "BLD",8850 ,"KRN",101 ,"NM",0)
  644   ^9.68A^1^1
  645   "BLD",8850 ,"KRN",101 ,"NM",1,0)
  646   OR EVSEND  VPR^^0
  647   "BLD",8850 ,"KRN",101 ,"NM","B", "OR EVSEND  VPR",1)
  648  
  649   "BLD",8850 ,"KRN",409 .61,0)
  650   409.61
  651   "BLD",8850 ,"KRN",771 ,0)
  652   771
  653   "BLD",8850 ,"KRN",779 .2,0)
  654   779.2
  655   "BLD",8850 ,"KRN",870 ,0)
  656   870
  657   "BLD",8850 ,"KRN",898 9.51,0)
  658   8989.51
  659   "BLD",8850 ,"KRN",898 9.52,0)
  660   8989.52
  661   "BLD",8850 ,"KRN",899 4,0)
  662   8994
  663   "BLD",8850 ,"KRN","B" ,.4,.4)
  664  
  665   "BLD",8850 ,"KRN","B" ,.401,.401 )
  666  
  667   "BLD",8850 ,"KRN","B" ,.402,.402 )
  668  
  669   "BLD",8850 ,"KRN","B" ,.403,.403 )
  670  
  671   "BLD",8850 ,"KRN","B" ,.5,.5)
  672  
  673   "BLD",8850 ,"KRN","B" ,.84,.84)
  674  
  675   "BLD",8850 ,"KRN","B" ,3.6,3.6)
  676  
  677   "BLD",8850 ,"KRN","B" ,3.8,3.8)
  678  
  679   "BLD",8850 ,"KRN","B" ,9.2,9.2)
  680  
  681   "BLD",8850 ,"KRN","B" ,9.8,9.8)
  682  
  683   "BLD",8850 ,"KRN","B" ,19,19)
  684  
  685   "BLD",8850 ,"KRN","B" ,19.1,19.1 )
  686  
  687   "BLD",8850 ,"KRN","B" ,101,101)
  688  
  689   "BLD",8850 ,"KRN","B" ,409.61,40 9.61)
  690  
  691   "BLD",8850 ,"KRN","B" ,771,771)
  692  
  693   "BLD",8850 ,"KRN","B" ,779.2,779 .2)
  694  
  695   "BLD",8850 ,"KRN","B" ,870,870)
  696  
  697   "BLD",8850 ,"KRN","B" ,8989.51,8 989.51)
  698  
  699   "BLD",8850 ,"KRN","B" ,8989.52,8 989.52)
  700  
  701   "BLD",8850 ,"KRN","B" ,8994,8994 )
  702  
  703   "BLD",8850 ,"QUES",0)
  704   ^9.62^^
  705   "BLD",8850 ,"REQB",0)
  706   ^9.611^4^4
  707   "BLD",8850 ,"REQB",1, 0)
  708   OR*3.0*97^ 2
  709   "BLD",8850 ,"REQB",2, 0)
  710   OR*3.0*284 ^2
  711   "BLD",8850 ,"REQB",3, 0)
  712   OR*3.0*296 ^2
  713   "BLD",8850 ,"REQB",4, 0)
  714   OR*3.0*306 ^2
  715   "BLD",8850 ,"REQB","B ","OR*3.0* 284",2)
  716  
  717   "BLD",8850 ,"REQB","B ","OR*3.0* 296",3)
  718  
  719   "BLD",8850 ,"REQB","B ","OR*3.0* 306",4)
  720  
  721   "BLD",8850 ,"REQB","B ","OR*3.0* 97",1)
  722  
  723   "KRN",101, 6053,-1)
  724   0^1
  725   "KRN",101, 6053,0)
  726   OR EVSEND  VPR^OE/RR  => VPR MES SAGE EVENT ^^X^^^^^^^ ^
  727   "KRN",101, 6053,10,0)
  728   ^101.01PA^ 8^1
  729   "KRN",101, 6053,99)
  730   63272,5447 5
  731   "MBREQ")
  732   1
  733   "ORD",15,1 01)
  734   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  735   "ORD",15,1 01,0)
  736   PROTOCOL
  737   "PKG",170, -1)
  738   1^1
  739   "PKG",170, 0)
  740   ORDER ENTR Y/RESULTS  REPORTING^ OR^Order E ntry/Resul ts Reporti ng
  741   "PKG",170, 22,0)
  742   ^9.49I^1^1
  743   "PKG",170, 22,1,0)
  744   3.0^297121 7^2980917^ 11712
  745   "PKG",170, 22,1,"PAH" ,1,0)
  746   390^314040 8^1085
  747   "QUES","XP F1",0)
  748   Y
  749   "QUES","XP F1","??")
  750   ^D REP^XPD H
  751   "QUES","XP F1","A")
  752   Shall I wr ite over y our |FLAG|  File
  753   "QUES","XP F1","B")
  754   YES
  755   "QUES","XP F1","M")
  756   D XPF1^XPD IQ
  757   "QUES","XP F2",0)
  758   Y
  759   "QUES","XP F2","??")
  760   ^D DTA^XPD H
  761   "QUES","XP F2","A")
  762   Want my da ta |FLAG|  yours
  763   "QUES","XP F2","B")
  764   YES
  765   "QUES","XP F2","M")
  766   D XPF2^XPD IQ
  767   "QUES","XP I1",0)
  768   YO
  769   "QUES","XP I1","??")
  770   ^D INHIBIT ^XPDH
  771   "QUES","XP I1","A")
  772   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  773   "QUES","XP I1","B")
  774   NO
  775   "QUES","XP I1","M")
  776   D XPI1^XPD IQ
  777   "QUES","XP M1",0)
  778   PO^VA(200, :EM
  779   "QUES","XP M1","??")
  780   ^D MG^XPDH
  781   "QUES","XP M1","A")
  782   Enter the  Coordinato r for Mail  Group '|F LAG|'
  783   "QUES","XP M1","B")
  784  
  785   "QUES","XP M1","M")
  786   D XPM1^XPD IQ
  787   "QUES","XP O1",0)
  788   Y
  789   "QUES","XP O1","??")
  790   ^D MENU^XP DH
  791   "QUES","XP O1","A")
  792   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  793   "QUES","XP O1","B")
  794   NO
  795   "QUES","XP O1","M")
  796   D XPO1^XPD IQ
  797   "QUES","XP Z1",0)
  798   Y
  799   "QUES","XP Z1","??")
  800   ^D OPT^XPD H
  801   "QUES","XP Z1","A")
  802   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  803   "QUES","XP Z1","B")
  804   NO
  805   "QUES","XP Z1","M")
  806   D XPZ1^XPD IQ
  807   "QUES","XP Z2",0)
  808   Y
  809   "QUES","XP Z2","??")
  810   ^D RTN^XPD H
  811   "QUES","XP Z2","A")
  812   Want to MO VE routine s to other  CPUs
  813   "QUES","XP Z2","B")
  814   NO
  815   "QUES","XP Z2","M")
  816   D XPZ2^XPD IQ
  817   "RTN")
  818   4
  819   "RTN","ORC ACT1")
  820   0^1^B49643 037
  821   "RTN","ORC ACT1",1,0)
  822   ORCACT1 ;S LC/MKB-Act  on orders  cont ;7/2 9/97  08:2 6
  823   "RTN","ORC ACT1",2,0)
  824    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**7 ,27,56,48, 86,92,116, 149,215,28 4,390**;De c 17, 1997 ;Build 32
  825   "RTN","ORC ACT1",3,0)
  826    ;
  827   "RTN","ORC ACT1",4,0)
  828   FLAG ; --  flag order s
  829   "RTN","ORC ACT1",5,0)
  830    D EN("FL" ) Q
  831   "RTN","ORC ACT1",6,0)
  832    ;
  833   "RTN","ORC ACT1",7,0)
  834   UNFLAG ; - - unflag o rders
  835   "RTN","ORC ACT1",8,0)
  836    D EN("UF" ) Q
  837   "RTN","ORC ACT1",9,0)
  838    ;
  839   "RTN","ORC ACT1",10,0 )
  840   COMMENT ;  -- add war d comments  to orders
  841   "RTN","ORC ACT1",11,0 )
  842    D EN("CM" ) Q
  843   "RTN","ORC ACT1",12,0 )
  844    ;
  845   "RTN","ORC ACT1",13,0 )
  846   ALERT ; --  alert pro vider when  results a vailable
  847   "RTN","ORC ACT1",14,0 )
  848    D EN("AL" ) Q
  849   "RTN","ORC ACT1",15,0 )
  850    ;
  851   "RTN","ORC ACT1",16,0 )
  852   UNHOLD ; - - release  hold on or ders - no  longer in  use
  853   "RTN","ORC ACT1",17,0 )
  854    Q  ; see  UNHOLD^ORC ACT instea d
  855   "RTN","ORC ACT1",18,0 )
  856    ;
  857   "RTN","ORC ACT1",19,0 )
  858   EN(ORACT)  ; -- Actio ns that do n't create  orders
  859   "RTN","ORC ACT1",20,0 )
  860    ;    ORNM BR = #,#,. ..,# of se lected ord ers
  861   "RTN","ORC ACT1",21,0 )
  862    ;    ORAC T  = actio n to be ta ken
  863   "RTN","ORC ACT1",22,0 )
  864    ;
  865   "RTN","ORC ACT1",23,0 )
  866    ;    OREB UILD defin ed on retu rn if Orde rs tab nee ds to be r ebuilt
  867   "RTN","ORC ACT1",24,0 )
  868    ;
  869   "RTN","ORC ACT1",25,0 )
  870    N ORLK,OR I,NMBR,IDX ,ORIFN,ORD ITM,ORERR, ORQUIT
  871   "RTN","ORC ACT1",26,0 )
  872    I '$G(ORN MBR) S ORN MBR=$$ORDE RS^ORCHART ("") Q:'OR NMBR
  873   "RTN","ORC ACT1",27,0 )
  874    D FREEZE^ ORCMENU S  VALMBCK="R " K OREBUI LD
  875   "RTN","ORC ACT1",28,0 )
  876    F ORI=1:1 :$L(ORNMBR ,",") S NM BR=$P(ORNM BR,",",ORI ) D:NMBR   Q:$D(ORQUI T)
  877   "RTN","ORC ACT1",29,0 )
  878    . S IDX=$ G(^TMP("OR ",$J,ORTAB ,"IDX",NMB R)),ORIFN= $P(IDX,U)
  879   "RTN","ORC ACT1",30,0 )
  880    . Q:'ORIF N  S:'$P(O RIFN,";",2 ) ORIFN=+O RIFN_";1"
  881   "RTN","ORC ACT1",31,0 )
  882    . I '$D(^ OR(100,+OR IFN,0)) W  !,"This or der has be en deleted !" H 1 Q
  883   "RTN","ORC ACT1",32,0 )
  884    . S ORDIT M=$$ORDITE M^ORCACT(O RIFN) D SU BHDR^ORCAC T(ORDITM)
  885   "RTN","ORC ACT1",33,0 )
  886    . I '$$VA LID^ORCACT 0(ORIFN,OR ACT,.ORERR ) W !,ORER R H 1 Q
  887   "RTN","ORC ACT1",34,0 )
  888    . S ORLK= $$LOCK1^OR X2(+ORIFN)  I 'ORLK W  !,$P(ORLK ,U,2) H 1  Q
  889   "RTN","ORC ACT1",35,0 )
  890    . D @ORAC T,UNLK1^OR X2(+ORIFN)
  891   "RTN","ORC ACT1",36,0 )
  892   ENQ Q
  893   "RTN","ORC ACT1",37,0 )
  894    ;
  895   "RTN","ORC ACT1",38,0 )
  896   FL ; -- Fl ag order O RIFN
  897   "RTN","ORC ACT1",39,0 )
  898    D EN^ORCF LAG
  899   "RTN","ORC ACT1",40,0 )
  900    Q
  901   "RTN","ORC ACT1",41,0 )
  902    ;
  903   "RTN","ORC ACT1",42,0 )
  904   UF ; -- Un flag order  ORIFN
  905   "RTN","ORC ACT1",43,0 )
  906    D UN^ORCF LAG
  907   "RTN","ORC ACT1",44,0 )
  908    Q
  909   "RTN","ORC ACT1",45,0 )
  910    ;
  911   "RTN","ORC ACT1",46,0 )
  912   CM ; -- Wa rd Comment s on order  ORIFN
  913   "RTN","ORC ACT1",47,0 )
  914    N DIC,DWP K,DIWEPSE, DIWESUB,DD WRW
  915   "RTN","ORC ACT1",48,0 )
  916    S DIC="^O R(100,"_+O RIFN_",8," _+$P(ORIFN ,";",2)_", 5,",(DWPK, DIWEPSE)=1
  917   "RTN","ORC ACT1",49,0 )
  918    S DIWESUB =ORDITM,DD WRW="B" ;g o to botto m of text
  919   "RTN","ORC ACT1",50,0 )
  920    D EN^DIWE
  921   "RTN","ORC ACT1",51,0 )
  922    Q
  923   "RTN","ORC ACT1",52,0 )
  924    ;
  925   "RTN","ORC ACT1",53,0 )
  926   AL ; -- Al ert when r esults are  available  for order  ORIFN
  927   "RTN","ORC ACT1",54,0 )
  928    S $P(^OR( 100,+ORIFN ,3),U,10)= 1
  929   "RTN","ORC ACT1",55,0 )
  930    W !?10,". .. done."  H 1
  931   "RTN","ORC ACT1",56,0 )
  932    Q
  933   "RTN","ORC ACT1",57,0 )
  934    ;
  935   "RTN","ORC ACT1",58,0 )
  936   RL ; -- Re lease hold  on order  ORIFN [No  longer use d]
  937   "RTN","ORC ACT1",59,0 )
  938    D EN^ORCS END(+ORIFN ,ORACT,3,1 ,,,.ORERR)
  939   "RTN","ORC ACT1",60,0 )
  940    W !,"...  order "_$S ($G(ORERR) :"not ",1: "")_"relea sed from h old."
  941   "RTN","ORC ACT1",61,0 )
  942    W:$L($P($ G(ORERR),U ,2)) !,"   >> "_$P(OR ERR,U,2) H  1
  943   "RTN","ORC ACT1",62,0 )
  944    S OREBUIL D=1 ; prin t?
  945   "RTN","ORC ACT1",63,0 )
  946    Q
  947   "RTN","ORC ACT1",64,0 )
  948    ;
  949   "RTN","ORC ACT1",65,0 )
  950   VERIFY(ORV ER) ; -- V erify orde rs
  951   "RTN","ORC ACT1",66,0 )
  952    N ORLK,OR I,NMBR,IDX ,ORIFN,ORD ITM,ORES,O RERR,ORSIG ,OROLDSTS, ORNEW,ORWA IT
  953   "RTN","ORC ACT1",67,0 )
  954    I "^"[$G( ORVER) W $ C(7),!!,"Y ou must be  a nurse o r clerk to  verify th ese orders !" S VALMB CK="" H 2  Q
  955   "RTN","ORC ACT1",68,0 )
  956    I '$G(ORN MBR) S ORN MBR=$$ORDE RS^ORCHART ("") Q:'OR NMBR
  957   "RTN","ORC ACT1",69,0 )
  958    D FREEZE^ ORCMENU S  VALMBCK="R " K OREBUI LD
  959   "RTN","ORC ACT1",70,0 )
  960    F ORI=1:1 :$L(ORNMBR ,",") S NM BR=$P(ORNM BR,",",ORI ) D:NMBR   Q:$D(ORQUI T)
  961   "RTN","ORC ACT1",71,0 )
  962    . S IDX=$ G(^TMP("OR ",$J,ORTAB ,"IDX",NMB R)),ORIFN= $P(IDX,U)
  963   "RTN","ORC ACT1",72,0 )
  964    . Q:'ORIF N  S:'$P(O RIFN,";",2 ) ORIFN=+O RIFN_";1"  Q:$D(ORES( ORIFN))
  965   "RTN","ORC ACT1",73,0 )
  966    . I '$$VA LID^ORCACT 0(ORIFN,"V R",.ORERR)  W !!,$$OR DITEM^ORCA CT(ORIFN)_ " invalid. ",!,"  >>  "_ORERR H  1 Q
  967   "RTN","ORC ACT1",74,0 )
  968    . S ORLK= $$LOCK1^OR X2(+ORIFN)  I 'ORLK W  !!,$$ORDI TEM^ORCACT (ORIFN)_"  invalid.", !,"  >> "_ $P(ORLK,U, 2) H 1 Q
  969   "RTN","ORC ACT1",75,0 )
  970    . S ORES( ORIFN)=""  D REPLCD
  971   "RTN","ORC ACT1",76,0 )
  972   VR1 Q:'$O( ORES(0))   D COMPLX S  ORSIG=$S( $$ESIG^ORC SIGN:1,1:0 )
  973   "RTN","ORC ACT1",77,0 )
  974    I 'ORSIG  W !,"Nothi ng verifie d!" D UNLO CK H 1 Q
  975   "RTN","ORC ACT1",78,0 )
  976    W !!,"Ver ifying ord ers ..."
  977   "RTN","ORC ACT1",79,0 )
  978    S ORIFN=0  F  S ORIF N=$O(ORES( ORIFN)) Q: ORIFN'>0   D
  979   "RTN","ORC ACT1",80,0 )
  980    . S OROLD STS=+$P($G (^OR(100,+ ORIFN,3)), U,3)
  981   "RTN","ORC ACT1",81,0 )
  982    . D EN^OR CSEND(ORIF N,"VR","", "",,,.ORER R),UNLK1^O RX2(+ORIFN )
  983   "RTN","ORC ACT1",82,0 )
  984    . I $G(OR ERR) D  Q
  985   "RTN","ORC ACT1",83,0 )
  986    . . W !,$ $ORDITEM^O RCACT(ORIF N)_" not v erified."
  987   "RTN","ORC ACT1",84,0 )
  988    . . W:$L( $P($G(ORER R),U,2)) ! ,"  >> "_$ P(ORERR,U, 2) H 1
  989   "RTN","ORC ACT1",85,0 )
  990    . S ORNEW =+$P($G(^O R(100,+ORI FN,3)),U,3 ) I ORNEW' =OROLDSTS  W !,$$ORDI TEM^ORCACT (ORIFN)_"  is now "_$ $STS(ORNEW )_"." S OR WAIT=1
  991   "RTN","ORC ACT1",86,0 )
  992    S OREBUIL D=1 D:'$D( XQAID) CKA LERT I $G( ORWAIT) H  2
  993   "RTN","ORC ACT1",87,0 )
  994   VRQ Q
  995   "RTN","ORC ACT1",88,0 )
  996    ;
  997   "RTN","ORC ACT1",89,0 )
  998   STS(X) ; - - Return n ame of sta tus X
  999   "RTN","ORC ACT1",90,0 )
  1000    N Y S Y=$ P($G(^ORD( 100.01,+$G (X),0)),U)
  1001   "RTN","ORC ACT1",91,0 )
  1002    Q Y
  1003   "RTN","ORC ACT1",92,0 )
  1004    ;
  1005   "RTN","ORC ACT1",93,0 )
  1006   REPLCD ; - - Ck for u nverified  replaced o rders for  ORIFN, add  to ORES(o rder#)
  1007   "RTN","ORC ACT1",94,0 )
  1008    ;    [Exp ects ORVER ; also cal led from V ERIFY^ORWD XA,VERIFY^ ORRCOR]
  1009   "RTN","ORC ACT1",95,0 )
  1010    N OR3,ORI G,ORFLD,OR DA,ORI,ORL K
  1011   "RTN","ORC ACT1",96,0 )
  1012    S ORFLD=$ S($G(ORVER )="N":8,$G (ORVER)="R ":18,1:10) ,ORDA=+$P( ORIFN,";", 2)
  1013   "RTN","ORC ACT1",97,0 )
  1014    I ORDA>1  D  Q  ;ck  for prior  unverified  actions
  1015   "RTN","ORC ACT1",98,0 )
  1016    . ;Q:$P($ G(^OR(100, +ORIFN,8,O RDA,0)),U, 2)'="XX"
  1017   "RTN","ORC ACT1",99,0 )
  1018    . S ORI=0  F  S ORI= $O(^OR(100 ,+ORIFN,8, ORI)) Q:OR I<1  Q:ORI '<ORDA  D
  1019   "RTN","ORC ACT1",100, 0)
  1020    .. Q:$P($ G(^OR(100, +ORIFN,8,O RI,0)),U,O RFLD)  ;al ready veri fied
  1021   "RTN","ORC ACT1",101, 0)
  1022    .. S ORLK =$$LOCK1^O RX2(+ORIFN ) Q:'ORLK
  1023   "RTN","ORC ACT1",102, 0)
  1024    .. S ORES (+ORIFN_"; "_ORI)=""
  1025   "RTN","ORC ACT1",103, 0)
  1026    S OR3=$G( ^OR(100,+O RIFN,3)) Q :$P(OR3,U, 11)'=1
  1027   "RTN","ORC ACT1",104, 0)
  1028    S ORIG=+$ P(OR3,U,5)  Q:'ORIG   Q:$P($G(^O R(100,ORIG ,3)),U,3)' =12
  1029   "RTN","ORC ACT1",105, 0)
  1030    S ORDA=0  F  S ORDA= $O(^OR(100 ,ORIG,8,OR DA)) Q:ORD A'>0  I '$ P($G(^(ORD A,0)),U,OR FLD) D
  1031   "RTN","ORC ACT1",106, 0)
  1032    . S ORLK= $$LOCK1^OR X2(ORIG) Q :'ORLK
  1033   "RTN","ORC ACT1",107, 0)
  1034    . S ORES( ORIG_";"_O RDA)=""
  1035   "RTN","ORC ACT1",108, 0)
  1036    Q
  1037   "RTN","ORC ACT1",109, 0)
  1038    ;
  1039   "RTN","ORC ACT1",110, 0)
  1040   COMPLX ; - - Ck for o ther child  orders to  be verifi ed at same  time
  1041   "RTN","ORC ACT1",111, 0)
  1042    N IFN,DAD ,CHLD,ALL, P,X,I
  1043   "RTN","ORC ACT1",112, 0)
  1044    S P=$S(OR VER="N":9, ORVER="C": 11,ORVER=" R":19,1:0)  Q:P<1
  1045   "RTN","ORC ACT1",113, 0)
  1046    S IFN=0 F   S IFN=$O (ORES(IFN) ) Q:IFN<1   D
  1047   "RTN","ORC ACT1",114, 0)
  1048    . S X=+$P ($G(^OR(10 0,+IFN,0)) ,U,14) Q:$ $NMSP^ORCD (X)'["PS"
  1049   "RTN","ORC ACT1",115, 0)
  1050    . S X=$P( $G(^OR(100 ,+IFN,8,+$ P(IFN,";", 2),0)),U,2 ) Q:X'="NW "&(X'="XX" )
  1051   "RTN","ORC ACT1",116, 0)
  1052    . I $P($G (^OR(100,+ IFN,3)),U, 9) S DAD(+ $P(^(3),U, 9))=""
  1053   "RTN","ORC ACT1",117, 0)
  1054    Q:'$O(DAD (0))  S IF N=0 F  S I FN=+$O(DAD (IFN)) Q:I FN<1  D
  1055   "RTN","ORC ACT1",118, 0)
  1056    . S CHLD= 0,ALL=1
  1057   "RTN","ORC ACT1",119, 0)
  1058    . F  S CH LD=+$O(^OR (100,IFN,2 ,CHLD)) Q: CHLD<1  F  X="NW","XX " D
  1059   "RTN","ORC ACT1",120, 0)
  1060    .. S I=+$ O(^OR(100, CHLD,8,"C" ,X,0)) Q:I <1
  1061   "RTN","ORC ACT1",121, 0)
  1062    .. Q:$P($ G(^OR(100, CHLD,8,I,0 )),U,P)  Q :$D(ORES(C HLD_";"_I) )
  1063   "RTN","ORC ACT1",122, 0)
  1064    .. S ORES (CHLD_";"_ I)="",ALL= 0
  1065   "RTN","ORC ACT1",123, 0)
  1066    . Q:ALL   S X=$$ORDI TEM^ORCACT (IFN) D SU BHDR^ORCAC T(X)
  1067   "RTN","ORC ACT1",124, 0)
  1068    . W !,"Al l doses of  this comp lex order  must be ve rified tog ether;"
  1069   "RTN","ORC ACT1",125, 0)
  1070    . W !,"ad ding remai ning doses  to signat ure list.. ."
  1071   "RTN","ORC ACT1",126, 0)
  1072    Q
  1073   "RTN","ORC ACT1",127, 0)
  1074    ;
  1075   "RTN","ORC ACT1",128, 0)
  1076   CKALERT ;  -- Ck if U nverified  Orders ale rts can be  deleted
  1077   "RTN","ORC ACT1",129, 0)
  1078    N ORNOW,O RBEG,ORLIS T,ORALL,OR MEDS S ORN OW=$$NOW^X LFDT
  1079   "RTN","ORC ACT1",130, 0)
  1080    S:'$G(ORW ARD) ORBEG =$$FMADD^X LFDT(ORNOW ,"-30") I  $G(ORWARD)  D
  1081   "RTN","ORC ACT1",131, 0)
  1082    . N DFN,V AIN,VAERR  S DFN=+ORV P D INP^VA DPT
  1083   "RTN","ORC ACT1",132, 0)
  1084    . S ORBEG =$S($G(VAI N(7)):$P(V AIN(7),U), 1:$$FMADD^ XLFDT(ORNO W,-30))
  1085   "RTN","ORC ACT1",133, 0)
  1086    D EN^ORQ1 (ORVP,,9,, ORBEG,ORNO W) ;see if  any unver ified orde rs remain
  1087   "RTN","ORC ACT1",134, 0)
  1088    I $G(ORLI ST),$G(^TM P("ORR",$J ,ORLIST,"T OT")) D  ; see if any  are meds
  1089   "RTN","ORC ACT1",135, 0)
  1090    . N ORRX, ORGRP,I,IF N,DG S ORA LL=1
  1091   "RTN","ORC ACT1",136, 0)
  1092    . S ORRX= +$O(^ORD(1 00.98,"B", "RX",0)) D  GRP^ORQ1( ORRX)
  1093   "RTN","ORC ACT1",137, 0)
  1094    . S I=0 F   S I=$O(^ TMP("ORR", $J,ORLIST, I)) Q:I'>0   S IFN=+^ (I),DG=+$P ($G(^OR(10 0,IFN,0)), U,11) I $D (ORGRP(DG) ) S ORMEDS =1 Q
  1095   "RTN","ORC ACT1",138, 0)
  1096    D:'$G(ORA LL) DELALR T("UNVERIF IED ORDER" )
  1097   "RTN","ORC ACT1",139, 0)
  1098    D:'$G(ORM EDS) DELAL RT("UNVERI FIED MEDIC ATION ORDE R")
  1099   "RTN","ORC ACT1",140, 0)
  1100    Q
  1101   "RTN","ORC ACT1",141, 0)
  1102    ;
  1103   "RTN","ORC ACT1",142, 0)
  1104   DELALRT(X)  ; -- dele te alert X
  1105   "RTN","ORC ACT1",143, 0)
  1106    N ORNIFN, XQAKILL,XQ AID
  1107   "RTN","ORC ACT1",144, 0)
  1108    S ORNIFN= +$O(^ORD(1 00.9,"B",X ,0)) Q:ORN IFN'>0
  1109   "RTN","ORC ACT1",145, 0)
  1110    S XQAKILL =$$XQAKILL ^ORB3F1(OR NIFN)
  1111   "RTN","ORC ACT1",146, 0)
  1112    S XQAID=$ P($G(^ORD( 100.9,ORNI FN,0)),U,2 )_","_+ORV P_","_ORNI FN
  1113   "RTN","ORC ACT1",147, 0)
  1114    D DELETEA ^XQALERT
  1115   "RTN","ORC ACT1",148, 0)
  1116    Q
  1117   "RTN","ORC ACT1",149, 0)
  1118    ;
  1119   "RTN","ORC ACT1",150, 0)
  1120   UNLOCK ; - - Unlock o rders in O RES(ORIFN)  [from VR1 ]
  1121   "RTN","ORC ACT1",151, 0)
  1122    F  S ORIF N=$O(ORES( ORIFN)) Q: ORIFN'>0   D UNLK1^OR X2(+ORIFN)
  1123   "RTN","ORC ACT1",152, 0)
  1124    Q
  1125   "RTN","ORC ACT1",153, 0)
  1126    ;
  1127   "RTN","ORC ACT1",154, 0)
  1128   SIGNREQD(I FN) ; -- R eturns 2,  1, or 0, i f order/ac tions need  ES
  1129   "RTN","ORC ACT1",155, 0)
  1130    Q +$P($G( ^OR(100,IF N,0)),U,16 )
  1131   "RTN","ORC ACT1",156, 0)
  1132    ;
  1133   "RTN","ORC ACT1",157, 0)
  1134   SIGN ; --  Sign order s [no long er used]
  1135   "RTN","ORC ACT1",158, 0)
  1136    D EN^ORCS IGN
  1137   "RTN","ORC ACT1",159, 0)
  1138    Q
  1139   "RTN","ORC ACT1",160, 0)
  1140    ;
  1141   "RTN","ORC ACT1",161, 0)
  1142   COMPLETE ;  -- comple te orders
  1143   "RTN","ORC ACT1",162, 0)
  1144    N ORLK,OR I,NMBR,IDX ,ORIFN,ORD ITM,ORES,O RERR,ORSIG ,ORSTOP
  1145   "RTN","ORC ACT1",163, 0)
  1146    I '$G(ORN MBR) S ORN MBR=$$ORDE RS^ORCHART ("complete ") Q:'ORNM BR
  1147   "RTN","ORC ACT1",164, 0)
  1148    D FREEZE^ ORCMENU S  VALMBCK="R " K OREBUI LD
  1149   "RTN","ORC ACT1",165, 0)
  1150    F ORI=1:1 :$L(ORNMBR ) S NMBR=$ P(ORNMBR," ,",ORI) D: NMBR  Q:$D (ORQUIT)
  1151   "RTN","ORC ACT1",166, 0)
  1152    . S IDX=$ G(^TMP("OR ",$J,ORTAB ,"IDX",NMB R)),ORIFN= $P(IDX,U)
  1153   "RTN","ORC ACT1",167, 0)
  1154    . Q:'ORIF N  S:'$P(O RIFN,";",2 ) ORIFN=+O RIFN_";1"
  1155   "RTN","ORC ACT1",168, 0)
  1156    . I '$$VA LID^ORCACT 0(ORIFN,"C P",.ORERR)  W !!,$$OR DITEM^ORCA CT(ORIFN)_ " invalid. ",!,"  >>  "_ORERR H  1 Q
  1157   "RTN","ORC ACT1",169, 0)
  1158    . S ORLK= $$LOCK1^OR X2(+ORIFN)  I 'ORLK W  !!,$$ORDI TEM^ORCACT (ORIFN)_"  invalid.", !,"  >> "_ $P(ORLK,U, 2) H 1 Q
  1159   "RTN","ORC ACT1",170, 0)
  1160    . S ORES( ORIFN)=""
  1161   "RTN","ORC ACT1",171, 0)
  1162   CP1 Q:'$O( ORES(0))   S ORSIG=$S ($$ESIG^OR CSIGN:1,1: 0)
  1163   "RTN","ORC ACT1",172, 0)
  1164    I 'ORSIG  W !,"Nothi ng complet ed!" D UNL OCK H 1 Q
  1165   "RTN","ORC ACT1",173, 0)
  1166    W !!,"Com pleting or ders ..."  S ORSTOP=+ $E($$NOW^X LFDT,1,12) ,ORIFN=0
  1167   "RTN","ORC ACT1",174, 0)
  1168    F  S ORIF N=$O(ORES( ORIFN)) Q: ORIFN'>0   D
  1169   "RTN","ORC ACT1",175, 0)
  1170    . D COMP^ ORCSAVE2(O RIFN,DUZ,O RSTOP),UNL K1^ORX2(+O RIFN)
  1171   "RTN","ORC ACT1",176, 0)
  1172    . D COMP^ ORMBLDOR(O RIFN)
  1173   "RTN","ORC ACT1",177, 0)
  1174    S OREBUIL D=1
  1175   "RTN","ORC ACT1",178, 0)
  1176   CPQ Q
  1177   "RTN","ORC SEND")
  1178   0^2^B65938 879
  1179   "RTN","ORC SEND",1,0)
  1180   ORCSEND ;S LC/MKB-Rel ease order s ; 11/8/2 006
  1181   "RTN","ORC SEND",2,0)
  1182    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**4 ,27,45,79, 92,141,165 ,195,228,2 43,303,296 ,390**;Dec  17, 1997; Build 32
  1183   "RTN","ORC SEND",3,0)
  1184    ;
  1185   "RTN","ORC SEND",4,0)
  1186   EN(ORIFN,A CTION,SIGS TS,RELSTS, NATURE,REA SON,ORERR)  ; -- Rele ase [actio ns on] ord ers
  1187   "RTN","ORC SEND",5,0)
  1188    N ORDA,OR NOW,SIGNRE QD,SIGNED, SIGNER
  1189   "RTN","ORC SEND",6,0)
  1190    S SIGNREQ D=+$P($G(^ OR(100,+OR IFN,0)),U, 16),ORERR= ""
  1191   "RTN","ORC SEND",7,0)
  1192    S SIGNED= $S(SIGSTS= 2:0,1:1),S IGNER=$S(S IGSTS=1:DU Z,SIGSTS=7 :DUZ,1:"")
  1193   "RTN","ORC SEND",8,0)
  1194    S ORDA=+$ P(ORIFN,"; ",2),ORIFN =+ORIFN,OR NOW=+$E($$ NOW^XLFDT, 1,12)
  1195   "RTN","ORC SEND",9,0)
  1196    S:"ES"[$G (ACTION) A CTION=$P($ G(^OR(100, ORIFN,8,OR DA,0)),U,2 )
  1197   "RTN","ORC SEND",10,0 )
  1198    I SIGNREQ D,ORDA,"^N W^RW^XX^RN ^DC^HD^RL^ "[(U_ACTIO N_U) D  ;  sign/alert
  1199   "RTN","ORC SEND",11,0 )
  1200    . I 'SIGN ED D NOTIF ^ORCSIGN Q
  1201   "RTN","ORC SEND",12,0 )
  1202    . D:SIGST S'="" SIGN ^ORCSAVE2( ORIFN,SIGN ER,ORNOW,S IGSTS,ORDA )
  1203   "RTN","ORC SEND",13,0 )
  1204    . D:SIGST S=4 CHART^ ORCSIGN ;  not used a nymore
  1205   "RTN","ORC SEND",14,0 )
  1206    I '$L(ACT ION) S ORE RR="1^Inva lid order  action" Q
  1207   "RTN","ORC SEND",15,0 )
  1208    I $$READY (ORIFN,ORD A) D:$L($T (@ACTION))  @ACTION I  'ORERR,AC TION="NW"  D
  1209   "RTN","ORC SEND",16,0 )
  1210    . N OREVT  S OREVT=+ $P($G(^OR( 100,ORIFN, 0)),U,17)  Q:OREVT<1
  1211   "RTN","ORC SEND",17,0 )
  1212    . I '$$EV TORDER^ORE VNTX(ORIFN ) D SAVE^O RMEVNT1(OR IFN,OREVT, 2,"ES")
  1213   "RTN","ORC SEND",18,0 )
  1214    ; If orde r originat ed from th e back doo r, send Dx  and TxF b ack to anc il.
  1215   "RTN","ORC SEND",19,0 )
  1216    I SIGNED, $P($G(^OR( 100,+ORIFN ,3)),U,11) ="P" D BDO EDIT^ORWDB A7
  1217   "RTN","ORC SEND",20,0 )
  1218    Q
  1219   "RTN","ORC SEND",21,0 )
  1220    ;
  1221   "RTN","ORC SEND",22,0 )
  1222   EN1(ORDER, ORERR) ; - - Delayed  Release [f rom RELEAS E^ORMEVNT]
  1223   "RTN","ORC SEND",23,0 )
  1224    ;
  1225   "RTN","ORC SEND",24,0 )
  1226    Q:$P($G(^ OR(100,+OR DER,3)),U, 3)'=10
  1227   "RTN","ORC SEND",25,0 )
  1228    N ORPKG,O RA0,ORNOW, ORIFN,ORDA ,ORNP,ORNA TR,ORQUIT, ORDUZ,SIGS TS,RELSTS
  1229   "RTN","ORC SEND",26,0 )
  1230    S ORPKG=$ P($G(^OR(1 00,+ORDER, 0)),U,14), ORA0=$G(^( 8,1,0))
  1231   "RTN","ORC SEND",27,0 )
  1232    S ORNOW=+ $E($$NOW^X LFDT,1,12) ,ORIFN=+OR DER,ORDA=1 ,ORNP=$P(O RA0,U,3)
  1233   "RTN","ORC SEND",28,0 )
  1234    S SIGSTS= $P(ORA0,U, 4),ORNATR= $P($G(^ORD (100.02,+$ P(ORA0,U,1 2),0)),U,2 )
  1235   "RTN","ORC SEND",29,0 )
  1236    S RELSTS= $S(SIGSTS' =2:1,"^V^P ^"[(U_ORNA TR_U):1,1: 0)
  1237   "RTN","ORC SEND",30,0 )
  1238    I RELSTS  D
  1239   "RTN","ORC SEND",31,0 )
  1240    . D START DT^ORCSAVE 2(ORIFN),P KGSTUFF^OR CSEND1(ORP KG) Q:$G(O RQUIT)
  1241   "RTN","ORC SEND",32,0 )
  1242    . S ORDUZ =$S(SIGSTS =0:$P(ORA0 ,U,7),SIGS TS=1:$P(OR A0,U,5),SI GSTS=2:$P( ORA0,U,17) ,SIGSTS=3: $P(ORA0,U, 13),1:DUZ)
  1243   "RTN","ORC SEND",33,0 )
  1244    . D EDO1^ ORWPFSS1   ;PFSS Even t Delayed  Orders
  1245   "RTN","ORC SEND",34,0 )
  1246    . D RELEA SE^ORCSAVE 2(ORIFN,OR DA,ORNOW,O RDUZ),NEW^ ORMBLD(ORI FN)
  1247   "RTN","ORC SEND",35,0 )
  1248    . I "^10^ 13^"[(U_$P ($G(^OR(10 0,ORIFN,3) ),U,3)_U)  S ORERR=1  ;error
  1249   "RTN","ORC SEND",36,0 )
  1250    I 'RELSTS !$G(ORERR) ,$P($G(^OR (100,ORIFN ,3)),U,3)= 10 D STATU S^ORCSAVE2 (ORIFN,11)  S $P(^OR( 100,ORIFN, 8,1,0),U,1 5)=11
  1251   "RTN","ORC SEND",37,0 )
  1252    Q
  1253   "RTN","ORC SEND",38,0 )
  1254    ;
  1255   "RTN","ORC SEND",39,0 )
  1256   EN2(ORIFN, SIGSTS,NAT URE,ORERR)  ; -- Manu al Release  [from ORE VNT1,SENDE D^ORWDX]
  1257   "RTN","ORC SEND",40,0 )
  1258    N ORDA,OR NOW,OREVT, ORA0,ORNP, SIGNREQD,S IGNED,RELS TS
  1259   "RTN","ORC SEND",41,0 )
  1260    S ORDA=+$ P(ORIFN,"; ",2),ORIFN =+ORIFN S: ORDA<1 ORD A=1
  1261   "RTN","ORC SEND",42,0 )
  1262    S OREVT=+ $P($G(^OR( 100,ORIFN, 0)),U,17), ORA0=$G(^( 8,ORDA,0))
  1263   "RTN","ORC SEND",43,0 )
  1264    S ORNP=$P (ORA0,U,3) ,SIGNREQD= ($P(ORA0,U ,4)'=3),(S IGNED,RELS TS)=1
  1265   "RTN","ORC SEND",44,0 )
  1266    S ORNOW=+ $E($$NOW^X LFDT,1,12) ,ORERR=""
  1267   "RTN","ORC SEND",45,0 )
  1268    I $P(ORA0 ,U,4)=2 D   ;needs ES
  1269   "RTN","ORC SEND",46,0 )
  1270    . N SIGNE R S SIGNER =$S(SIGSTS =1:DUZ,1:" ")
  1271   "RTN","ORC SEND",47,0 )
  1272    . I SIGST S=2 D NOTI F^ORCSIGN  S SIGNED=0  Q  ;still  unsigned
  1273   "RTN","ORC SEND",48,0 )
  1274    . D:SIGST S'="" SIGN ^ORCSAVE2( ORIFN,SIGN ER,ORNOW,S IGSTS,ORDA )
  1275   "RTN","ORC SEND",49,0 )
  1276    D EDO2^OR WPFSS1  ;P FSS Event  Delayed Or ders
  1277   "RTN","ORC SEND",50,0 )
  1278    D NW I 'O RERR D SAV E^ORMEVNT1 (+ORIFN,OR EVT,2,"MN" )
  1279   "RTN","ORC SEND",51,0 )
  1280    Q
  1281   "RTN","ORC SEND",52,0 )
  1282    ;
  1283   "RTN","ORC SEND",53,0 )
  1284   NW ; -- Ne w order OR IFN
  1285   "RTN","ORC SEND",54,0 )
  1286   RW ; -- Re written or der ORIFN
  1287   "RTN","ORC SEND",55,0 )
  1288   XX ; -- Ch anged orde r ORIFN
  1289   "RTN","ORC SEND",56,0 )
  1290   RN ; -- Re newed orde r ORIFN
  1291   "RTN","ORC SEND",57,0 )
  1292    N ORQUIT, STS,TYPE,O R0,OR3,COD E,ORIG,ORS AVE
  1293   "RTN","ORC SEND",58,0 )
  1294    N IVDIEN, IVPKGM
  1295   "RTN","ORC SEND",59,0 )
  1296    S IVPKGM= 0
  1297   "RTN","ORC SEND",60,0 )
  1298    S IVDIEN= $O(^ORD(10 1.41,"B"," PSJI OR PA T FLUID OE ",""))
  1299   "RTN","ORC SEND",61,0 )
  1300    I SIGNREQ D,'SIGNED, 'RELSTS S  ORERR=$$NE EDSIG,OREB UILD=1 Q
  1301   "RTN","ORC SEND",62,0 )
  1302    S:'ORDA O RDA=1 S OR SAVE=ORIFN
  1303   "RTN","ORC SEND",63,0 )
  1304    S OR0=$G( ^OR(100,OR IFN,0)),OR 3=$G(^(3))  D STARTDT ^ORCSAVE2( ORIFN)
  1305   "RTN","ORC SEND",64,0 )
  1306    S TYPE=$P (OR3,U,11) ,ORIG=+$P( OR3,U,5),C ODE="NW"
  1307   "RTN","ORC SEND",65,0 )
  1308    I TYPE=1, ORIG,$D(^O R(100,ORIG ,4)) S COD E="XO",^OR (100,ORIG, 6)=$O(^ORD (100.02,"C ","C",0))_ U_DUZ_U_OR NOW
  1309   "RTN","ORC SEND",66,0 )
  1310    I $$GET1^ DIQ(9.4,+$ P(OR0,U,14 )_",",1)=" PSJ" S IVP KGM=1
  1311   "RTN","ORC SEND",67,0 )
  1312    I IVPKGM= 1,$P($P(OR 0,U,5),";" )=IVDIEN D  PSJI^ORCS END3 Q:$G( ORQUIT)
  1313   "RTN","ORC SEND",68,0 )
  1314    I IVPKGM= 0!($P($P(O R0,U,5),"; ")'=IVDIEN ) D PKGSTU FF^ORCSEND 1(+$P(OR0, U,14)) Q:$ G(ORQUIT)
  1315   "RTN","ORC SEND",69,0 )
  1316    D RELEASE ^ORCSAVE2( ORIFN,ORDA ,ORNOW,DUZ ,$G(NATURE ))
  1317   "RTN","ORC SEND",70,0 )
  1318    D NEW^ORM BLD(ORIFN, CODE) S OR IFN=ORSAVE ,STS=$P($G (^OR(100,O RIFN,3)),U ,3)
  1319   "RTN","ORC SEND",71,0 )
  1320    I (STS=1) !(STS=13)  S ORERR="1 ^"_$$WHY(O RIFN,1) D: 'SIGNED&SI GNREQD NOS IG K:ORIG  ^OR(100,OR IG,6)
  1321   "RTN","ORC SEND",72,0 )
  1322    I STS=11  S ORERR="1 ^ERROR"
  1323   "RTN","ORC SEND",73,0 )
  1324    Q
  1325   "RTN","ORC SEND",74,0 )
  1326    ;
  1327   "RTN","ORC SEND",75,0 )
  1328   DC ; -- DC  order ORI FN
  1329   "RTN","ORC SEND",76,0 )
  1330    N PKG,COD E,ORCHLD,O RCHDA,STS, ORIDA,ORSA VE,OR3,OR6 ,DCNATURE
  1331   "RTN","ORC SEND",77,0 )
  1332    I '$G(REA SON),$G(NA TURE)="D"  S REASON=+ $O(^ORD(10 0.03,"C"," ORDUP",0))
  1333   "RTN","ORC SEND",78,0 )
  1334    S:$G(REAS ON) $P(^OR (100,ORIFN ,6),U,1,5) =$S($G(NAT URE):NATUR E,$L($G(NA TURE)):$O( ^ORD(100.0 2,"C",NATU RE,0)),1:" ")_"^^^"_+ REASON_U_$ P(^ORD(100 .03,+REASO N,0),U)
  1335   "RTN","ORC SEND",79,0 )
  1336    I SIGNREQ D,'SIGNED, 'RELSTS S  ORERR=$$NE EDSIG Q
  1337   "RTN","ORC SEND",80,0 )
  1338    S $P(^OR( 100,ORIFN, 6),U,2,3)= $S($G(DGPM T):"",1:DU Z)_U_ORNOW ,ORSAVE=OR IFN S:'$G( REASON) RE ASON=$P(^( 6),U,4)
  1339   "RTN","ORC SEND",81,0 )
  1340    S STS=$P( $G(^OR(100 ,ORIFN,3)) ,U,3),PKG= $P($G(^(0) ),U,14),PK G=$$NMSP^O RCD(PKG),C ODE=$S(PKG ="LR":"CA" ,(PKG="PS" )&(STS=5): "CA",(PKG= "FH")&(STS =8):"CA",1 :"DC")
  1341   "RTN","ORC SEND",82,0 )
  1342    D:ORDA RE LEASE^ORCS AVE2(ORIFN ,ORDA,ORNO W,DUZ,$G(N ATURE))
  1343   "RTN","ORC SEND",83,0 )
  1344   DC1 I $O(^ OR(100,ORI FN,2,0)) D   G DC2 ;  DC childre n
  1345   "RTN","ORC SEND",84,0 )
  1346    . S ORCHL D=0 F  S O RCHLD=$O(^ OR(100,ORI FN,2,ORCHL D)) Q:ORCH LD'>0  I $ $VALID^ORC ACT0(ORCHL D,"DC") D   Q:$G(ORER R)
  1347   "RTN","ORC SEND",85,0 )
  1348    . . S ORC HDA=$S(ORD A:$$ACTION ^ORCSAVE(" DC",ORCHLD ,ORNP),1:0 )
  1349   "RTN","ORC SEND",86,0 )
  1350    . . D:ORC HDA SIGN^O RCSAVE2(OR CHLD,,,8,O RCHDA) ;Si g on Paren t only
  1351   "RTN","ORC SEND",87,0 )
  1352    . . D MSG ^ORMBLD((O RCHLD_";"_ ORCHDA),CO DE,$G(REAS ON))
  1353   "RTN","ORC SEND",88,0 )
  1354    . . I "^1 ^13^"'[(U_ $P(^OR(100 ,ORCHLD,3) ,U,3)_U) S  ORERR="1^ "_$$WHY(OR CHLD,ORCHD A)
  1355   "RTN","ORC SEND",89,0 )
  1356    . ;D:'$G( ORERR) STA TUS^ORCSAV E2(ORIFN,1 )
  1357   "RTN","ORC SEND",90,0 )
  1358    . S:$G(OR ERR) ^OR(1 00,ORIFN,8 ,ORDA,1)=$ P(ORERR,U, 2)
  1359   "RTN","ORC SEND",91,0 )
  1360    D MSG^ORM BLD((ORIFN _";"_ORDA) ,CODE,$G(R EASON))
  1361   "RTN","ORC SEND",92,0 )
  1362   DC2 S ORIF N=ORSAVE,O R3=$G(^OR( 100,ORIFN, 3)),STS=$P (OR3,U,3)
  1363   "RTN","ORC SEND",93,0 )
  1364    S OR6=$G( ^OR(100,OR IFN,6))
  1365   "RTN","ORC SEND",94,0 )
  1366    I STS'=1, STS'=13,ST S'=2 D  Q
  1367   "RTN","ORC SEND",95,0 )
  1368    . S ORERR ="1^"_$S(O RDA:$$WHY( ORIFN,ORDA ),1:"Unabl e to disco ntinue")
  1369   "RTN","ORC SEND",96,0 )
  1370    . I ORDA, 'SIGNED&SI GNREQD D N OSIG ; sig  no longer  reqd
  1371   "RTN","ORC SEND",97,0 )
  1372    . K ^OR(1 00,ORIFN,6 )
  1373   "RTN","ORC SEND",98,0 )
  1374    S DCNATUR E=$S(+OR6: +OR6,1:$G( NATURE))
  1375   "RTN","ORC SEND",99,0 )
  1376    S $P(^OR( 100,ORIFN, 3),U,7)=$S ('$$ACTV^O RX1($G(DCN ATURE)):0, ORDA:ORDA, 1:$P(OR3,U ,7))
  1377   "RTN","ORC SEND",100, 0)
  1378    D CANCEL( ORIFN),SET ALL^ORDD10 0(ORIFN)
  1379   "RTN","ORC SEND",101, 0)
  1380    I $P(OR3, U,11)=2 D   ; dc a re newal
  1381   "RTN","ORC SEND",102, 0)
  1382    . N ORIG, ORIG3,NATR  S ORIG=$P (OR3,U,5), ORIG3=$G(^ OR(100,ORI G,3)) Q:'O RIG
  1383   "RTN","ORC SEND",103, 0)
  1384    . ;I CODE ="CA",+$P( OR6,U,9)'> 0 S $P(^OR (100,ORIG, 3),U,6)=""  Q  ;pend  - remove f wd ptr
  1385   "RTN","ORC SEND",104, 0)
  1386    . I +$P(O R6,U,9)'>0  S $P(^OR( 100,ORIG,3 ),U,6)=""  Q  ;pend -  remove fw d ptr
  1387   "RTN","ORC SEND",105, 0)
  1388    . Q:"^1^7 ^12^13^"[( U_$P(ORIG3 ,U,3)_U)   S NATR=$O( ^ORD(100.0 2,"C","A", 0))
  1389   "RTN","ORC SEND",106, 0)
  1390    . S ^OR(1 00,ORIG,6) =NATR_U_DU Z_U_ORNOW_ "^^Renewal  cancelled "
  1391   "RTN","ORC SEND",107, 0)
  1392    . D MSG^O RMBLD(ORIG ,"DC") I " ^1^13^"'[$ P(^OR(100, ORIG,3),U, 3) K ^(6)  Q
  1393   "RTN","ORC SEND",108, 0)
  1394    . S:'$$AC TV^ORX1(NA TR) $P(^OR (100,ORIG, 3),U,7)=0
  1395   "RTN","ORC SEND",109, 0)
  1396    Q
  1397   "RTN","ORC SEND",110, 0)
  1398    ;
  1399   "RTN","ORC SEND",111, 0)
  1400   CANCEL(IFN ) ; -- Can cel any ou tstanding  actions fo r order IF
  1401   "RTN","ORC SEND",112, 0)
  1402    N I S I=0
  1403   "RTN","ORC SEND",113, 0)
  1404    F  S I=$O (^OR(100,I FN,8,I)) Q :I'>0  I $ P(^(I,0),U ,15)=11 S  $P(^(0),U, 15)=13 D:$ P(^(0),U,4 )=2 SIGN^O RCSAVE2(IF N,"","",5, I) ; cance lled, sig  not reqd n ow
  1405   "RTN","ORC SEND",114, 0)
  1406    Q
  1407   "RTN","ORC SEND",115, 0)
  1408    ;
  1409   "RTN","ORC SEND",116, 0)
  1410   HD ; -- Ho ld order O RIFN
  1411   "RTN","ORC SEND",117, 0)
  1412    N STS,ORS AVE I 'ORD A S ORERR= "1^Unable  to hold" Q
  1413   "RTN","ORC SEND",118, 0)
  1414    I SIGNREQ D,'SIGNED, 'RELSTS S  ORERR=$$NE EDSIG Q
  1415   "RTN","ORC SEND",119, 0)
  1416    D RELEASE ^ORCSAVE2( ORIFN,ORDA ,ORNOW,DUZ ,$G(NATURE ))
  1417   "RTN","ORC SEND",120, 0)
  1418    S ORSAVE= ORIFN D MS G^ORMBLD(( ORIFN_";"_ ORDA),"HD" ) S ORIFN= ORSAVE
  1419   "RTN","ORC SEND",121, 0)
  1420    S STS=$P( $G(^OR(100 ,ORIFN,3)) ,U,3) I ST S=3 S $P(^ (3),U,7)=O RDA D SET^ ORDD100(OR IFN,ORDA)
  1421   "RTN","ORC SEND",122, 0)
  1422    I STS'=3  S ORERR="1 ^"_$$WHY(O RIFN,ORDA)  D:'SIGNED &SIGNREQD  NOSIG
  1423   "RTN","ORC SEND",123, 0)
  1424    Q
  1425   "RTN","ORC SEND",124, 0)
  1426    ;
  1427   "RTN","ORC SEND",125, 0)
  1428   RL ; -- Re lease hold  on order  ORIFN
  1429   "RTN","ORC SEND",126, 0)
  1430    N STS,ORS AVE,ORHD I  'ORDA S O RERR="1^Un able to re lease hold " Q
  1431   "RTN","ORC SEND",127, 0)
  1432    I SIGNREQ D,'SIGNED, 'RELSTS S  ORERR=$$NE EDSIG Q
  1433   "RTN","ORC SEND",128, 0)
  1434    D RELEASE ^ORCSAVE2( ORIFN,ORDA ,ORNOW,DUZ ,$G(NATURE ))
  1435   "RTN","ORC SEND",129, 0)
  1436    S ORSAVE= ORIFN D MS G^ORMBLD(( ORIFN_";"_ ORDA),"RL" ) S ORIFN= ORSAVE
  1437   "RTN","ORC SEND",130, 0)
  1438    S STS=$P( $G(^OR(100 ,ORIFN,3)) ,U,3),ORHD =+$P($G(^( 3)),U,7)
  1439   "RTN","ORC SEND",131, 0)
  1440    I STS'=3  S $P(^OR(1 00,ORIFN,3 ),U,7)=ORD A,$P(^(8,O RHD,2),U,1 ,2)=ORNOW_ U_DUZ D SE T^ORDD100( ORIFN,ORDA )
  1441   "RTN","ORC SEND",132, 0)
  1442    I STS=3 S  ORERR="1^ "_$$WHY(OR IFN,ORDA)  D:'SIGNED& SIGNREQD N OSIG
  1443   "RTN","ORC SEND",133, 0)
  1444    Q
  1445   "RTN","ORC SEND",134, 0)
  1446    ;
  1447   "RTN","ORC SEND",135, 0)
  1448   FL ; -- Fl ag order O RIFN
  1449   "RTN","ORC SEND",136, 0)
  1450    Q
  1451   "RTN","ORC SEND",137, 0)
  1452    ;
  1453   "RTN","ORC SEND",138, 0)
  1454   UF ; -- Un flag order  ORIFN
  1455   "RTN","ORC SEND",139, 0)
  1456    Q
  1457   "RTN","ORC SEND",140, 0)
  1458    ;
  1459   "RTN","ORC SEND",141, 0)
  1460   CM ; -- Ad d Ward com ments to o rder ORIFN
  1461   "RTN","ORC SEND",142, 0)
  1462    Q
  1463   "RTN","ORC SEND",143, 0)
  1464    ;
  1465   "RTN","ORC SEND",144, 0)
  1466   VR ; -- Ve rify order  ORIFN
  1467   "RTN","ORC SEND",145, 0)
  1468    I 'ORDA!( SIGSTS=2)  S ORERR="1 ^Unable to  verify" Q
  1469   "RTN","ORC SEND",146, 0)
  1470    I "^N^C^R ^"'[(U_$G( ORVER)_U)  S ORERR="1 ^Unable to  verify" Q
  1471   "RTN","ORC SEND",147, 0)
  1472    D VERIFY^ ORCSAVE2(O RIFN,ORDA, ORVER,DUZ, ORNOW)
  1473   "RTN","ORC SEND",148, 0)
  1474    ; -- send  HL7 msg t o Pharmacy  if Nurse- Verified,  [Sts=pendi ng]
  1475   "RTN","ORC SEND",149, 0)
  1476    Q:ORVER'= "N"  N ORS TS,ORPKG,O RX
  1477   "RTN","ORC SEND",150, 0)
  1478    S ORX=$P( $G(^OR(100 ,ORIFN,8,O RDA,0)),U, 2) Q:ORX'= "NW"&(ORX' ="XX")
  1479   "RTN","ORC SEND",151, 0)
  1480    S ORPKG=+ $P($G(^OR( 100,ORIFN, 0)),U,14), ORSTS=$P($ G(^(3)),U, 3)
  1481   "RTN","ORC SEND",152, 0)
  1482    ;I ORSTS= 5!$L($T(ZV ^ORMPS)),$ $NMSP^ORCD (ORPKG)="P S" D VER^O RMBLDPS(OR IFN)
  1483   "RTN","ORC SEND",153, 0)
  1484    I $$NMSP^ ORCD(ORPKG )="PS" D V ER^ORMBLDP S(ORIFN) Q
  1485   "RTN","ORC SEND",154, 0)
  1486    D VER^ORM BLDOR(ORIF N)
  1487   "RTN","ORC SEND",155, 0)
  1488    Q
  1489   "RTN","ORC SEND",156, 0)
  1490    ;
  1491   "RTN","ORC SEND",157, 0)
  1492   NEEDSIG()  ; -- Msg
  1493   "RTN","ORC SEND",158, 0)
  1494    Q "1^This  order req uires a si gnature."
  1495   "RTN","ORC SEND",159, 0)
  1496    ;
  1497   "RTN","ORC SEND",160, 0)
  1498   WHY(IFN,DA ) ; -- Ret urn reason  request w as rejecte d
  1499   "RTN","ORC SEND",161, 0)
  1500    N X S X=$ G(^OR(100, IFN,8,DA,1 ))
  1501   "RTN","ORC SEND",162, 0)
  1502    S:'$L(X)  X="Unable  to "_$S(AC TION="HD": "hold",ACT ION="RL":" release ho ld",ACTION ="DC":"dis continue", ACTION="XX ":"change" ,ACTION="R N":"renew" ,1:"releas e")
  1503   "RTN","ORC SEND",163, 0)
  1504    Q X
  1505   "RTN","ORC SEND",164, 0)
  1506    ;
  1507   "RTN","ORC SEND",165, 0)
  1508   NOSIG ; --  Mark orde r as Sig n ot Req'd d ue to canc el/reject
  1509   "RTN","ORC SEND",166, 0)
  1510    D SIGN^OR CSAVE2(ORI FN,"","",5 ,ORDA) S S IGNREQD=0
  1511   "RTN","ORC SEND",167, 0)
  1512    Q
  1513   "RTN","ORC SEND",168, 0)
  1514    ;
  1515   "RTN","ORC SEND",169, 0)
  1516   READY(IFN, ACT) ; --  Ready to r elease?
  1517   "RTN","ORC SEND",170, 0)
  1518    N X,Y,OR0 ,OR3,ORA
  1519   "RTN","ORC SEND",171, 0)
  1520    I ACTION= "VR" S Y=1  G RQ ; no  action to  release
  1521   "RTN","ORC SEND",172, 0)
  1522    I 'ACT,AC TION="DC"  S Y=1 G RQ  ; cancel  a duplicat e
  1523   "RTN","ORC SEND",173, 0)
  1524    S Y=0,OR0 =$G(^OR(10 0,IFN,0)), OR3=$G(^(3 )),ORA=$G( ^(8,ACT,0) )
  1525   "RTN","ORC SEND",174, 0)
  1526    I $P(ORA, U,15)=11 S  Y=1 G RQ  ; unreleas ed
  1527   "RTN","ORC SEND",175, 0)
  1528    I $P(ORA, U,15)=10 D   G RQ ; d elayed
  1529   "RTN","ORC SEND",176, 0)
  1530    . I $G(^D PT(+ORVP,. 105)),$$GE T1^DIQ(9.4 ,+$P(OR0,U ,14)_",",1 )="PSO" S  Y=1 Q
  1531   "RTN","ORC SEND",177, 0)
  1532    . Q:'RELS TS  N ORIG  S ORIG=+$ P(OR3,U,5)
  1533   "RTN","ORC SEND",178, 0)
  1534    . I 'SIGN ED,$L($G(N ATURE)) S  $P(ORA,U,1 7)=DUZ,$P( ORA,U,12)= $S(NATURE: NATURE,1:+ $O(^ORD(10 0.02,"C",N ATURE,0))) ,^OR(100,I FN,8,ACT,0 )=ORA
  1535   "RTN","ORC SEND",179, 0)
  1536    . Q:$P(OR 3,U,11)'=1 !('ORIG)   ;dc origin al if sign ed edit
  1537   "RTN","ORC SEND",180, 0)
  1538    . D STATU S^ORCSAVE2 (ORIG,12)
  1539   "RTN","ORC SEND",181, 0)
  1540    . S ^OR(1 00,ORIG,6) =+$O(^ORD( 100.02,"C" ,"C",0))_U _DUZ_U_ORN OW
  1541   "RTN","ORC SEND",182, 0)
  1542    . S $P(^O R(100,ORIG ,3),U,7)=0 ,$P(^(8,1, 0),U,15)=1 2 D:$P($G( ^(0)),U,4) =2 SIGN^OR CSAVE2(ORI G,,,5,1)
  1543   "RTN","ORC SEND",183, 0)
  1544    I $P(OR3, U,3)=11,$P (ORA,U,2)= "NW" S Y=1  ; Action  Sts = "" ( old)
  1545   "RTN","ORC SEND",184, 0)
  1546   RQ I +$$SW STAT^IBBAP I() D:Y=1  EN^ORWPFSS 4(+IFN) ;  Associate  PFSS Accou nt Referen ce with or der, Patch  OR*3.0*22 8 IA #4663
  1547   "RTN","ORC SEND",185, 0)
  1548    Q Y
  1549   "RTN","ORM BLDOR")
  1550   0^3^B56503 60
  1551   "RTN","ORM BLDOR",1,0 )
  1552   ORMBLDOR ;  SLC/MKB -  Build out going OR m sgs ;11/17 /00  11:11
  1553   "RTN","ORM BLDOR",2,0 )
  1554    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**9 7,390**;De c 17, 1997 ;Build 32
  1555   "RTN","ORM BLDOR",3,0 )
  1556   EN ; -- Ge neric orde rs: Activi ty, Nursin g, Diagnos is, Condit ion, Vital s
  1557   "RTN","ORM BLDOR",4,0 )
  1558    N OI,STAR T,STOP,SCH ,TXT
  1559   "RTN","ORM BLDOR",5,0 )
  1560    S OI=$G(O RDIALOG($$ PTR("ORDER ABLE ITEM" ),1))
  1561   "RTN","ORM BLDOR",6,0 )
  1562    S TXT=$G( ORDIALOG($ $PTR("FREE  TEXT 1"), 1))
  1563   "RTN","ORM BLDOR",7,0 )
  1564    S START=$ P(OR0,U,8) ,STOP=$P(O R0,U,9),SC H=""
  1565   "RTN","ORM BLDOR",8,0 )
  1566    S:ORDG=$O (^ORD(100. 98,"B","V/ M",0)) SCH =$$VALUE^O RCSAVE2(IF N,"SCHEDUL E")
  1567   "RTN","ORM BLDOR",9,0 )
  1568    S $P(ORMS G(4),"|",8 )=U_SCH_"^ ^"_$$HL7DA TE(START)_ U_$$HL7DAT E(STOP) ;  QT
  1569   "RTN","ORM BLDOR",10, 0)
  1570    S ORMSG(5 )="OBR|||| "_$$USID^O RMBLD(OI)
  1571   "RTN","ORM BLDOR",11, 0)
  1572    S:$L(TXT)  ORMSG(6)= "NTE|1|L|" _TXT ; ord er text?
  1573   "RTN","ORM BLDOR",12, 0)
  1574    Q
  1575   "RTN","ORM BLDOR",13, 0)
  1576    ;
  1577   "RTN","ORM BLDOR",14, 0)
  1578   ADT ; -- M .A.S. even t requests
  1579   "RTN","ORM BLDOR",15, 0)
  1580    Q  N PROV ,PROV1,ORI FN
  1581   "RTN","ORM BLDOR",16, 0)
  1582    S PROV=+$ G(ORDIALOG ($$PTR("PR OVIDER"),1 )) I 'PROV  D EN Q
  1583   "RTN","ORM BLDOR",17, 0)
  1584    S PROV1=+ $G(ORDIALO G($$PTR("P ROVIDER 1" ),1)),PKG= "DGPM"
  1585   "RTN","ORM BLDOR",18, 0)
  1586    S $P(ORMS G(1),"|",5 )="M.A.S." ,$P(ORMSG( 1),"|",9)= "ADT"
  1587   "RTN","ORM BLDOR",19, 0)
  1588    K ORMSG(4 ) S ORMSG( 4)=ORMSG(3 ),ORMSG(3) =ORMSG(2)
  1589   "RTN","ORM BLDOR",20, 0)
  1590    S ORMSG(2 )="EVN|A08 |"_$$HL7DA TE($$NOW^X LFDT)
  1591   "RTN","ORM BLDOR",21, 0)
  1592    S $P(ORMS G(4),"|",8 )=PROV
  1593   "RTN","ORM BLDOR",22, 0)
  1594    S:PROV1 O RMSG(5)="Z DG|"_PROV1
  1595   "RTN","ORM BLDOR",23, 0)
  1596    S ORIFN=+ IFN D NW^O RMORG ; se t status,  start date
  1597   "RTN","ORM BLDOR",24, 0)
  1598    Q
  1599   "RTN","ORM BLDOR",25, 0)
  1600    ;
  1601   "RTN","ORM BLDOR",26, 0)
  1602   PTR(X) ; - - Returns  ptr value  of prompt  X in #101. 41
  1603   "RTN","ORM BLDOR",27, 0)
  1604    Q +$O(^OR D(101.41," AB",$E("OR  GTX "_X,1 ,63),0))
  1605   "RTN","ORM BLDOR",28, 0)
  1606    ;
  1607   "RTN","ORM BLDOR",29, 0)
  1608   HL7DATE(D)  ; -- FM-> HL7 format
  1609   "RTN","ORM BLDOR",30, 0)
  1610    Q $$FMTHL 7^XLFDT(D)   ;**97
  1611   "RTN","ORM BLDOR",31, 0)
  1612    ;
  1613   "RTN","ORM BLDOR",32, 0)
  1614   COMP(IFN)  ; -- send  message fo r complete d orders
  1615   "RTN","ORM BLDOR",33, 0)
  1616    N OR0,ORM SG S OR0=$ G(^OR(100, +IFN,0))
  1617   "RTN","ORM BLDOR",34, 0)
  1618    S ORMSG(1 )=$$MSH^OR MBLD("ORM" ,"OR"),ORM SG(2)=$$PI D^ORMBLD($ P(OR0,U,2) )
  1619   "RTN","ORM BLDOR",35, 0)
  1620    S ORMSG(3 )=$$PV1^OR MBLD($P(OR 0,U,2),$P( OR0,U,12), +$P(OR0,U, 10))
  1621   "RTN","ORM BLDOR",36, 0)
  1622    S ORMSG(4 )="ORC|SC| "_+IFN_"^O R|"_+IFN_" ^OR||CM||| |||"_DUZ_" ||||"_$$FM THL7^XLFDT ($$NOW^XLF DT)
  1623   "RTN","ORM BLDOR",37, 0)
  1624    D MSG^XQO R("OR EVSE ND VPR",.O RMSG)
  1625   "RTN","ORM BLDOR",38, 0)
  1626    Q
  1627   "RTN","ORM BLDOR",39, 0)
  1628    ;
  1629   "RTN","ORM BLDOR",40, 0)
  1630   VER(IFN) ;  -- Send m sg for ver ified orde rs
  1631   "RTN","ORM BLDOR",41, 0)
  1632    N OR0,ORM SG S OR0=$ G(^OR(100, +IFN,0))
  1633   "RTN","ORM BLDOR",42, 0)
  1634    S ORMSG(1 )=$$MSH^OR MBLD("ORM" ,"OR"),ORM SG(2)=$$PI D^ORMBLD($ P(OR0,U,2) )
  1635   "RTN","ORM BLDOR",43, 0)
  1636    S ORMSG(3 )=$$PV1^OR MBLD($P(OR 0,U,2),$P( OR0,U,12), +$P(OR0,U, 10))
  1637   "RTN","ORM BLDOR",44, 0)
  1638    S ORMSG(4 )="ORC|ZV| "_IFN_"^OR |"_$G(^OR( 100,+IFN,4 ))_U_$$NMS P^ORCD($P( OR0,U,14)) _"|||||||| "_DUZ_"||| |"_$$FMTHL 7^XLFDT($$ NOW^XLFDT)
  1639   "RTN","ORM BLDOR",45, 0)
  1640    D MSG^XQO R("OR EVSE ND VPR",.O RMSG)
  1641   "RTN","ORM BLDOR",46, 0)
  1642    Q
  1643   "RTN","ORW DXA")
  1644   0^4^B83177 974
  1645   "RTN","ORW DXA",1,0)
  1646   ORWDXA ; S LC/KCM/JLI  - Utilite s for Orde r Actions  ;12/14/12   13:38
  1647   "RTN","ORW DXA",2,0)
  1648    ;;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**;D ec 17, 199 7;Build 32
  1649   "RTN","ORW DXA",3,0)
  1650    ;
  1651   "RTN","ORW DXA",4,0)
  1652   VALID(VAL, ORID,ACTIO N,ORNP,ORW NAT) ; Is  action val id for ord er?
  1653   "RTN","ORW DXA",5,0)
  1654    N ORACT,O RVP,ORVER, ORIFN,PRTI D S VAL="" ,PRTID=0
  1655   "RTN","ORW DXA",6,0)
  1656    I +ORID=0  S VAL="Th is order h as been de leted." Q
  1657   "RTN","ORW DXA",7,0)
  1658    I '$D(^OR (100,+ORID ,0)) S VAL ="This ord er has bee n deleted! " Q
  1659   "RTN","ORW DXA",8,0)
  1660    I ACTION= "XFR",'$L( $T(XFR^ORC ACT01)) S  ACTION="RW " ; for pr e-POE
  1661   "RTN","ORW DXA",9,0)
  1662    N ORNSS S  ORNSS=1
  1663   "RTN","ORW DXA",10,0)
  1664    I (ACTION ="RN") D V ALSCH^ORWN SS(.ORNSS, ORID)
  1665   "RTN","ORW DXA",11,0)
  1666    I ORNSS=0  S VAL="Th is order c ontains an  invalid a dministrat ion schedu le." Q
  1667   "RTN","ORW DXA",12,0)
  1668    I (ACTION ="RN") D I SVALIV^ORW DPS33(.VAL ,ORID,ACTI ON) I $L(V AL)>0 Q
  1669   "RTN","ORW DXA",13,0)
  1670    S ORIFN=O RID,ORVP=$ P(^OR(100, +ORID,0),U ,2)  ; ORC ACT0 expec ts
  1671   "RTN","ORW DXA",14,0)
  1672    I (ACTION ="RN") D   Q:$L(VAL)
  1673   "RTN","ORW DXA",15,0)
  1674    . N DLG S  DLG=$P(^O R(100,+ORI D,0),U,5)  Q:DLG'[";O RD(101.41, "
  1675   "RTN","ORW DXA",16,0)
  1676    . I $G(^O RD(101.41, +DLG,3))'[ "PROVIDER^ ORCDPSIV"  Q
  1677   "RTN","ORW DXA",17,0)
  1678    . D AUTH^ ORWDPS32(. VAL,ORNP)
  1679   "RTN","ORW DXA",18,0)
  1680    . I VAL S  VAL=$P(VA L,U,2)
  1681   "RTN","ORW DXA",19,0)
  1682    . E  S VA L=""
  1683   "RTN","ORW DXA",20,0)
  1684    S ORVER=$ S(ACTION=" CR":"R",$D (^XUSEC("O RELSE",DUZ )):"N",$D( ^XUSEC("OR EMAS",DUZ) ):"C",1:"^ ")
  1685   "RTN","ORW DXA",21,0)
  1686    I ACTION= "CR" S ACT ION="VR"
  1687   "RTN","ORW DXA",22,0)
  1688    I (ACTION ="ES")!(AC TION="OC") !(ACTION=" RS") S ORA CT=ACTION  ; why not  defined???
  1689   "RTN","ORW DXA",23,0)
  1690    I (ACTION ="VR"),'($ D(^XUSEC(" ORELSE",DU Z))!$D(^XU SEC("OREMA S",DUZ)))  D  Q
  1691   "RTN","ORW DXA",24,0)
  1692    . S VAL=" You are no t authoriz ed to veri fy these o rders."
  1693   "RTN","ORW DXA",25,0)
  1694    I $L(VAL)  Q
  1695   "RTN","ORW DXA",26,0)
  1696    N OIIEN,I SIV,IVOD
  1697   "RTN","ORW DXA",27,0)
  1698    S (ISIV,O IIEN,IVOD) =0
  1699   "RTN","ORW DXA",28,0)
  1700    I (ACTION ="RW")!(AC TION="XX") !(ACTION=" XFR") D  Q :$L(VAL)
  1701   "RTN","ORW DXA",29,0)
  1702    . S ISIV= $P(^OR(100 ,+ORID,0), U,11)
  1703   "RTN","ORW DXA",30,0)
  1704    . I ISIV, ($P(^ORD(1 00.98,ISIV ,0),U,3)=" IV RX") S  IVOD=1
  1705   "RTN","ORW DXA",31,0)
  1706    . D:'IVOD  GTORITM^O RWDXR(.OII EN,+ORID)
  1707   "RTN","ORW DXA",32,0)
  1708    . D:OIIEN  ISACTOI(. VAL,OIIEN)  I $L(VAL) >0 Q
  1709   "RTN","ORW DXA",33,0)
  1710    . N DLG,F RM
  1711   "RTN","ORW DXA",34,0)
  1712    . S DLG=$ P(^OR(100, +ORID,0),U ,5),FRM=0
  1713   "RTN","ORW DXA",35,0)
  1714    . I $P(DL G,";",2)'= "ORD(101.4 1," S DLG= 0
  1715   "RTN","ORW DXA",36,0)
  1716    . I DLG D  FORMID^OR WDXM(.FRM, +DLG)
  1717   "RTN","ORW DXA",37,0)
  1718    . I '(DLG &FRM) D
  1719   "RTN","ORW DXA",38,0)
  1720    . . S VAL ="Copy & C hange are  not implem ented for  this order  that pred ates CPRS. "
  1721   "RTN","ORW DXA",39,0)
  1722    N OREBUIL D
  1723   "RTN","ORW DXA",40,0)
  1724    ;I (ACTIO N="RW")!(A CTION="XFR ")!(ACTION ="RN") D I SVALIV^ORW DPS33(.VAL ,ORID,ACTI ON) I $L(V AL)>0 Q
  1725   "RTN","ORW DXA",41,0)
  1726    I $$VALID ^ORCACT0(O RID,ACTION ,.VAL,$G(O RWNAT)) S  VAL="" ; V AL=error
  1727   "RTN","ORW DXA",42,0)
  1728    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."
  1729   "RTN","ORW DXA",43,0)
  1730    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."
  1731   "RTN","ORW DXA",44,0)
  1732    Q
  1733   "RTN","ORW DXA",45,0)
  1734    ;
  1735   "RTN","ORW DXA",46,0)
  1736   HOLD(REC,O RID,ORNP)  ; Place or der on hol d
  1737   "RTN","ORW DXA",47,0)
  1738    N ACTDA
  1739   "RTN","ORW DXA",48,0)
  1740    S ACTDA=$ $ACTION^OR CSAVE("HD" ,+ORID,ORN P)
  1741   "RTN","ORW DXA",49,0)
  1742    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  1743   "RTN","ORW DXA",50,0)
  1744    Q
  1745   "RTN","ORW DXA",51,0)
  1746   UNHOLD(REC ,ORID,ORNP ) ; Releas e order fr om hold
  1747   "RTN","ORW DXA",52,0)
  1748    N ACTDA
  1749   "RTN","ORW DXA",53,0)
  1750    S ACTDA=$ $ACTION^OR CSAVE("RL" ,+ORID,ORN P)
  1751   "RTN","ORW DXA",54,0)
  1752    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  1753   "RTN","ORW DXA",55,0)
  1754    Q
  1755   "RTN","ORW DXA",56,0)
  1756   DC(REC,ORI D,ORNP,ORL ,REASON,DC ORIG,ISNEW ORD) ; Dis continue/C ancel/Dele te order
  1757   "RTN","ORW DXA",57,0)
  1758    N NATURE, CREATE,PRI NT,STATUS, ACTDA,SIGS TS
  1759   "RTN","ORW DXA",58,0)
  1760    N X3,X8,C URRACT
  1761   "RTN","ORW DXA",59,0)
  1762    Q:'+ORID
  1763   "RTN","ORW DXA",60,0)
  1764    I $G(DCOR IG)="" S D CORIG=0
  1765   "RTN","ORW DXA",61,0)
  1766    S CURRACT =0
  1767   "RTN","ORW DXA",62,0)
  1768    S ORL(2)= ORL_";SC(" ,ORL=ORL(2 ),NATURE=" "
  1769   "RTN","ORW DXA",63,0)
  1770    I REASON  S NATURE=$ P(^ORD(100 .02,$P(^OR D(100.03,R EASON,0),U ,7),0),U,2 )
  1771   "RTN","ORW DXA",64,0)
  1772    S:NATURE= "" NATURE= "W"  ; S:O RNP=DUZ NA TURE="E"
  1773   "RTN","ORW DXA",65,0)
  1774    ;change t he way cre ate work t o support  forcing si gnature fo r all DC
  1775   "RTN","ORW DXA",66,0)
  1776    ;reasons
  1777   "RTN","ORW DXA",67,0)
  1778    S CREATE= 1,PRINT=$$ PRINT^ORCA CT2(NATURE )
  1779   "RTN","ORW DXA",68,0)
  1780    ;S CREATE =$$CREATE^ ORX1(NATUR E)
  1781   "RTN","ORW DXA",69,0)
  1782    S X3=$G(^ OR(100,+OR ID,3))
  1783   "RTN","ORW DXA",70,0)
  1784    S CURRACT =$P(X3,U,7 ) S:CURRAC T<1 CURRAC T=+$O(^OR( 100,+ORID, 8,"?"),-1)
  1785   "RTN","ORW DXA",71,0)
  1786    I '$D(^OR (100,+ORID ,8,+$P(ORI D,";",2),0 )) D
  1787   "RTN","ORW DXA",72,0)
  1788    . S X8=$G (^OR(100,+ ORID,8,CUR RACT,0))
  1789   "RTN","ORW DXA",73,0)
  1790    . S SIGST S=$P(X8,U, 4)
  1791   "RTN","ORW DXA",74,0)
  1792    . S $P(OR ID,";",2)= CURRACT
  1793   "RTN","ORW DXA",75,0)
  1794    E  D
  1795   "RTN","ORW DXA",76,0)
  1796    . S X8=^O R(100,+ORI D,8,+$P(OR ID,";",2), 0)
  1797   "RTN","ORW DXA",77,0)
  1798    . S SIGST S=$P(X8,U, 4)
  1799   "RTN","ORW DXA",78,0)
  1800    I '$D(SIG STS) S SIG STS=1
  1801   "RTN","ORW DXA",79,0)
  1802    S STATUS= $P($G(^OR( 100,+ORID, 8,+$P(ORID ,";",2),0) ),U,15)
  1803   "RTN","ORW DXA",80,0)
  1804    I (STATUS =10)!(STAT US=11) D   Q   ; dele te/cancel  unreleased  order
  1805   "RTN","ORW DXA",81,0)
  1806    . N RPLOR D
  1807   "RTN","ORW DXA",82,0)
  1808    . S RPLOR D=$P($G(^O R(100,+ORI D,3)),U,5)     ; repl aced order
  1809   "RTN","ORW DXA",83,0)
  1810    . D GETBY IFN^ORWORR (.REC,ORID )
  1811   "RTN","ORW DXA",84,0)
  1812    . I STATU S=10,($P(X 8,U,4)'=2)  D  ; CANC EL signed,  delayed,  unreleased
  1813   "RTN","ORW DXA",85,0)
  1814    . . ; tak en from CL RDLY^ORCAC T2
  1815   "RTN","ORW DXA",86,0)
  1816    . . I REA SON D SET^ ORCACT2(+O RID,NATURE ,REASON,,D CORIG)
  1817   "RTN","ORW DXA",87,0)
  1818    . . I 'RE ASON D SET ^ORCACT2(+ ORID,"M"," ","Delayed  Order Can celled",DC ORIG)
  1819   "RTN","ORW DXA",88,0)
  1820    . . D STA TUS^ORCSAV E2(+ORID,1 3) S $P(^O R(100,+ORI D,8,1,0),U ,15)=13
  1821   "RTN","ORW DXA",89,0)
  1822    . E  D                              ; CANC EL OR DELE TE unsigne d, unrelea sed
  1823   "RTN","ORW DXA",90,0)
  1824    . . I $P( X8,U,2)="D C" K ^OR(1 00,+ORID,6 )
  1825   "RTN","ORW DXA",91,0)
  1826    . . ; del ete fwd pt r to order  about to  be deleted
  1827   "RTN","ORW DXA",92,0)
  1828    . . I RPL ORD,$P(X8, U,2)="NW"  S $P(^OR(1 00,RPLORD, 3),U,6)=""
  1829   "RTN","ORW DXA",93,0)
  1830    . . ; del ete ptr to  order in  Patient Ev ent file # 100.2
  1831   "RTN","ORW DXA",94,0)
  1832    . . 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)
  1833   "RTN","ORW DXA",95,0)
  1834    . . I $G( ISNEWORD)  D DELETE^O RCSAVE2(OR ID)
  1835   "RTN","ORW DXA",96,0)
  1836    . . I '$G (ISNEWORD)  D CANCEL^ ORCSAVE2(O RID)
  1837   "RTN","ORW DXA",97,0)
  1838    . I RPLOR D,'(SIGSTS =1) S ORID =RPLORD  ;  for Renew s & Change s, show re placed ord er
  1839   "RTN","ORW DXA",98,0)
  1840    . I '$D(^ OR(100,+OR ID)) D
  1841   "RTN","ORW DXA",99,0)
  1842    . . S $P( REC(1),U)= "~0",REC(2 )="tDELETE D: "_$E(RE C(2),2,245 )
  1843   "RTN","ORW DXA",100,0 )
  1844    . E  D
  1845   "RTN","ORW DXA",101,0 )
  1846    . . K REC
  1847   "RTN","ORW DXA",102,0 )
  1848    . . D GET BYIFN^ORWO RR(.REC,+O RID_";"_$P ($G(^OR(10 0,+ORID,3) ),U,7))
  1849   "RTN","ORW DXA",103,0 )
  1850    . S $P(RE C(1),U,14) =2 ; DCTyp e = deleti on
  1851   "RTN","ORW DXA",104,0 )
  1852    S ACTDA=$ $ACTION^OR CSAVE("DC" ,+ORID,ORN P)
  1853   "RTN","ORW DXA",105,0 )
  1854    D SET^ORC ACT2(+ORID ,NATURE,RE ASON,,DCOR IG)
  1855   "RTN","ORW DXA",106,0 )
  1856    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  1857   "RTN","ORW DXA",107,0 )
  1858    S $P(REC( 1),U,14)=$ S(CREATE:1 ,1:3)  ;DC Type - 1=N ewOrder, 3 =NewStatus
  1859   "RTN","ORW DXA",108,0 )
  1860    N PKG
  1861   "RTN","ORW DXA",109,0 )
  1862    S PKG=$P( $G(^OR(100 ,+ORID,0)) ,U,14)
  1863   "RTN","ORW DXA",110,0 )
  1864    S PKG=$$N MSP^ORCD(P KG)
  1865   "RTN","ORW DXA",111,0 )
  1866    I REASON= 16&(PKG="P S") D
  1867   "RTN","ORW DXA",112,0 )
  1868    . N XMB
  1869   "RTN","ORW DXA",113,0 )
  1870    . S XMB=" OR DRUG OR DER CANCEL LED"
  1871   "RTN","ORW DXA",114,0 )
  1872    . S XMB(1 )=$P($G(RE C(2)),"tDi scontinue" ,2),XMB(4) =$P($G(^VA (200,DUZ,0 )),U)
  1873   "RTN","ORW DXA",115,0 )
  1874    . S XMB(2 )=+ORID
  1875   "RTN","ORW DXA",116,0 )
  1876    . S XMB(3 )=+$P($G(^ OR(100,+OR ID,0)),U,2 )
  1877   "RTN","ORW DXA",117,0 )
  1878    . S XMB(3 )=$P($G(^D PT(XMB(3), 0)),U)
  1879   "RTN","ORW DXA",118,0 )
  1880    . D ^XMB
  1881   "RTN","ORW DXA",119,0 )
  1882    Q
  1883   "RTN","ORW DXA",120,0 )
  1884   DCREQIEN(V AL) ; Retu rn IEN for  Req Phys  Cancelled  reason
  1885   "RTN","ORW DXA",121,0 )
  1886    S VAL=$O( ^ORD(100.0 3,"S","REQ ",0))
  1887   "RTN","ORW DXA",122,0 )
  1888    Q
  1889   "RTN","ORW DXA",123,0 )
  1890   COMPLETE(R EC,ORID,ES CODE) ; Co mplete ord er (generi c)
  1891   "RTN","ORW DXA",124,0 )
  1892    ;N X S X= +$E($$NOW^ XLFDT,1,12 )
  1893   "RTN","ORW DXA",125,0 )
  1894    ;D DATES^ ORCSAVE2(+ ORID,,X)
  1895   "RTN","ORW DXA",126,0 )
  1896    ;D STATUS ^ORCSAVE2( +ORID,2)
  1897   "RTN","ORW DXA",127,0 )
  1898    ; validat e ESCode
  1899   "RTN","ORW DXA",128,0 )
  1900    D COMP^OR CSAVE2(ORI D)
  1901   "RTN","ORW DXA",129,0 )
  1902    D COMP^OR MBLDOR(ORI D)
  1903   "RTN","ORW DXA",130,0 )
  1904    D GETBYIF N^ORWORR(. REC,ORID)
  1905   "RTN","ORW DXA",131,0 )
  1906    Q
  1907   "RTN","ORW DXA",132,0 )
  1908   VERIFY(REC ,ORID,ESCO DE,ORVER)  ; Verify o rder
  1909   "RTN","ORW DXA",133,0 )
  1910    ; validat e ESCode
  1911   "RTN","ORW DXA",134,0 )
  1912    S ORVER=$ G(ORVER,$S ($D(^XUSEC ("ORELSE", DUZ)):"N", $D(^XUSEC( "OREMAS",D UZ)):"C",1 :U))
  1913   "RTN","ORW DXA",135,0 )
  1914    I ORVER'= U D
  1915   "RTN","ORW DXA",136,0 )
  1916    . N ORIFN ,ORES,ORI
  1917   "RTN","ORW DXA",137,0 )
  1918    . ; VERIF Y any repl aced order s:
  1919   "RTN","ORW DXA",138,0 )
  1920    . S ORIFN =ORID,ORES (ORIFN)=""  D REPLCD^ ORCACT1
  1921   "RTN","ORW DXA",139,0 )
  1922    . 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
  1923   "RTN","ORW DXA",140,0 )
  1924    D GETBYIF N^ORWORR(. REC,ORID)
  1925   "RTN","ORW DXA",141,0 )
  1926    Q
  1927   "RTN","ORW DXA",142,0 )
  1928   ALERT(DUMM Y,ORID,ORD UZ) ; aler t user (OR DUZ) when  order (ORI D) resulte d
  1929   "RTN","ORW DXA",143,0 )
  1930    ;if no us er passed,  use order ing provid er:
  1931   "RTN","ORW DXA",144,0 )
  1932    I $G(ORDU Z)<1 S ORD UZ=+$$ORDE RER^ORQOR2 (+ORID)
  1933   "RTN","ORW DXA",145,0 )
  1934    I $L($G(O RDUZ))<1 S  ORDUZ=DUZ
  1935   "RTN","ORW DXA",146,0 )
  1936    S DUMMY=1 ,$P(^OR(10 0,+ORID,3) ,U,10)=ORD UZ
  1937   "RTN","ORW DXA",147,0 )
  1938    Q
  1939   "RTN","ORW DXA",148,0 )
  1940   FLAG(REC,O RIFN,OREAS ON,ORNP) ;  Flag orde r
  1941   "RTN","ORW DXA",149,0 )
  1942    N ORB,ORV P,DA,ORPS
  1943   "RTN","ORW DXA",150,0 )
  1944    D BULLETI N
  1945   "RTN","ORW DXA",151,0 )
  1946    S DA=$P(O RIFN,";",2 ),ORVP=+$P (^OR(100,+ ORIFN,0),U ,2)
  1947   "RTN","ORW DXA",152,0 )
  1948    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:"")
  1949   "RTN","ORW DXA",153,0 )
  1950    D KILL^XM ,MSG^ORCFL AG(ORIFN)
  1951   "RTN","ORW DXA",154,0 )
  1952    S $P(^OR( 100,+ORIFN ,3),U)=$$N OW^XLFDT ;  Last Acti vity
  1953   "RTN","ORW DXA",155,0 )
  1954    I +$G(ORN P)<1 S ORN P=+$P($G(^ OR(100,+OR IFN,8,DA,0 )),U,3)
  1955   "RTN","ORW DXA",156,0 )
  1956    S ORB=+OR VP_U_+ORIF N_U_ORNP_" ^1" D EN^O CXOERR(ORB ) ; notifi cation
  1957   "RTN","ORW DXA",157,0 )
  1958    D GETBYIF N^ORWORR(. REC,ORIFN)
  1959   "RTN","ORW DXA",158,0 )
  1960    Q
  1961   "RTN","ORW DXA",159,0 )
  1962   BULLETIN ;  flagged o rder bulle tin
  1963   "RTN","ORW DXA",160,0 )
  1964    N OR0,OR3 ,ORDTXT,XM B,XMY,XMDU Z,ORENT,BU LL,ORSRV,O RUSR
  1965   "RTN","ORW DXA",161,0 )
  1966    S OR0=$G( ^OR(100,+O RIFN,0)),O R3=$G(^(3) )
  1967   "RTN","ORW DXA",162,0 )
  1968    ;CLA - 3/ 21/96:
  1969   "RTN","ORW DXA",163,0 )
  1970    S ORUSR=+ $P(OR0,U,4 )
  1971   "RTN","ORW DXA",164,0 )
  1972    S ORSRV=$ G(^VA(200, ORUSR,5))  I +ORSRV>0  S ORSRV=$ P(ORSRV,U)
  1973   "RTN","ORW DXA",165,0 )
  1974    S ORENT=" USR.`"_ORU SR_"^SRV.` "_$G(ORSRV )_"^DIV^SY S^PKG"
  1975   "RTN","ORW DXA",166,0 )
  1976    S BULL=$$ GET^XPAR(O RENT,"ORB  FLAGGED OR DERS BULLE TIN",1,"Q" )
  1977   "RTN","ORW DXA",167,0 )
  1978    Q:$G(BULL )'="Y"   ; quit if pa rm val not  'Y'es
  1979   "RTN","ORW DXA",168,0 )
  1980    ;
  1981   "RTN","ORW DXA",169,0 )
  1982    S XMB="OR  FLAGGED O RDER",XMDU Z=DUZ,XMY( +$P(OR0,U, 4))=""
  1983   "RTN","ORW DXA",170,0 )
  1984    S XMB(1)= $P(^DPT(+$ P(OR0,U,2) ,0),U),XMB (2)=$P(^(0 ),U,9),XMB (3)="" ;sb  AGE
  1985   "RTN","ORW DXA",171,0 )
  1986    S XMB(4)= $$FMTE^XLF DT($P(OR0, U,7))
  1987   "RTN","ORW DXA",172,0 )
  1988    D TEXT^OR Q12(.ORDTX T,+ORIFN,8 0)
  1989   "RTN","ORW DXA",173,0 )
  1990    S XMB(5)= $G(ORDTXT( 1)),XMB(6) =$G(ORDTXT (2)),XMB(7 )=$G(ORDTX T(3))
  1991   "RTN","ORW DXA",174,0 )
  1992    S XMB(8)= $$FMTE^XLF DT($P(OR0, U,8)),XMB( 9)=$$FMTE^ XLFDT($P(O R0,U,9)),X MB(10)=ORE ASON
  1993   "RTN","ORW DXA",175,0 )
  1994    S XMB(11) =$P($G(^OR D(100.01,+ $P(OR3,U,3 ),0)),U)
  1995   "RTN","ORW DXA",176,0 )
  1996    D EN^XMB
  1997   "RTN","ORW DXA",177,0 )
  1998    Q
  1999   "RTN","ORW DXA",178,0 )
  2000   UNFLAG(REC ,ORIFN,ORE ASON) ; Un flag order
  2001   "RTN","ORW DXA",179,0 )
  2002    N DA,ORB, ORNP,ORVP, ORPS
  2003   "RTN","ORW DXA",180,0 )
  2004    S DA=$P(O RIFN,";",2 ),ORVP=+$P (^OR(100,+ ORIFN,0),U ,2)
  2005   "RTN","ORW DXA",181,0 )
  2006    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)
  2007   "RTN","ORW DXA",182,0 )
  2008    S $P(^OR( 100,+ORIFN ,3),U)=$$N OW^XLFDT   ; Last Act ivity
  2009   "RTN","ORW DXA",183,0 )
  2010    S ORNP=+$ P($G(^OR(1 00,+ORIFN, 8,DA,0)),U ,3)
  2011   "RTN","ORW DXA",184,0 )
  2012    S ORB=+OR VP_U_+ORIF N_U_ORNP_" ^0" D EN^O CXOERR(ORB ) ; notifi cation
  2013   "RTN","ORW DXA",185,0 )
  2014    D GETBYIF N^ORWORR(. REC,ORIFN)
  2015   "RTN","ORW DXA",186,0 )
  2016    Q
  2017   "RTN","ORW DXA",187,0 )
  2018   FLAGTXT(LS T,ORID) ;  flag reaso n
  2019   "RTN","ORW DXA",188,0 )
  2020    N FLAG
  2021   "RTN","ORW DXA",189,0 )
  2022    S FLAG=$G (^OR(100,+ ORID,8,$P( ORID,";",2 ),3))
  2023   "RTN","ORW DXA",190,0 )
  2024    S LST(1)= "FLAGGED:  "_$$FMTE^X LFDT($P(FL AG,U,3))_"  by "_$P($ G(^VA(200, +$P(FLAG,U ,4),0)),U)
  2025   "RTN","ORW DXA",191,0 )
  2026    S LST(2)= $P(FLAG,U, 5) ; reaso n
  2027   "RTN","ORW DXA",192,0 )
  2028    Q
  2029   "RTN","ORW DXA",193,0 )
  2030   WCGET(LST, ORID) ; wa rd comment s
  2031   "RTN","ORW DXA",194,0 )
  2032    N I,ORIFN ,ACT S ORI FN=+ORID,A CT=+$P(ORI D,";",2)
  2033   "RTN","ORW DXA",195,0 )
  2034    S I=0 F   S I=$O(^OR (100,ORIFN ,8,ACT,5,I )) Q:'I  S  LST(I)=$G (^(I,0))
  2035   "RTN","ORW DXA",196,0 )
  2036    Q
  2037   "RTN","ORW DXA",197,0 )
  2038   WCPUT(ERR, ORID,WCLST ) ; Set wa rd comment s
  2039   "RTN","ORW DXA",198,0 )
  2040    N DIERR,E RRLST,ORIF N,ACT S OR IFN=+ORID, ACT=+$P(OR ID,";",2)
  2041   "RTN","ORW DXA",199,0 )
  2042    D WP^DIE( 100.008,AC T_","_ORIF N_",",50," ","WCLST", "ERRLST")
  2043   "RTN","ORW DXA",200,0 )
  2044    S ERR=""  I $D(DIERR ) S ERR="A n error oc curred whi le saving  comments."
  2045   "RTN","ORW DXA",201,0 )
  2046    Q
  2047   "RTN","ORW DXA",202,0 )
  2048   OFCPLX(ORY ,ORID,PRTO RDER) ; is  ORID chil d of PRTOR DER
  2049   "RTN","ORW DXA",203,0 )
  2050    N NUMCHDS ,NOWID,NOW VAL,X3,ORD A,ISNOW
  2051   "RTN","ORW DXA",204,0 )
  2052    Q:'$D(^OR (100,+ORID ,0))
  2053   "RTN","ORW DXA",205,0 )
  2054    S ISNOW=0
  2055   "RTN","ORW DXA",206,0 )
  2056    D ISNOW^O RWDXR(.ISN OW,+ORID)
  2057   "RTN","ORW DXA",207,0 )
  2058    Q:ISNOW
  2059   "RTN","ORW DXA",208,0 )
  2060    N PKG
  2061   "RTN","ORW DXA",209,0 )
  2062    S PKG=$P( $G(^OR(100 ,+ORID,0)) ,U,14)
  2063   "RTN","ORW DXA",210,0 )
  2064    S PKG=$$N MSP^ORCD(P KG)
  2065   "RTN","ORW DXA",211,0 )
  2066    I PKG'="P S" Q
  2067   "RTN","ORW DXA",212,0 )
  2068    I $L($G(^ OR(100,+OR ID,3))),(' $L($P(^(3) ,U,9))) Q
  2069   "RTN","ORW DXA",213,0 )
  2070    S (NUMCHD S,NOWID,NO WVAL,X3,OR DA)=0
  2071   "RTN","ORW DXA",214,0 )
  2072    S PRTORDE R=+$P(^(3) ,U,9)
  2073   "RTN","ORW DXA",215,0 )
  2074    S X3=$G(^ OR(100,PRT ORDER,3)), ORDA=$P(X3 ,U,7)
  2075   "RTN","ORW DXA",216,0 )
  2076    S PRTORDE R=PRTORDER _";"_ORDA
  2077   "RTN","ORW DXA",217,0 )
  2078    S NUMCHDS =$P($G(^OR (100,+PRTO RDER,2,0)) ,U,4)
  2079   "RTN","ORW DXA",218,0 )
  2080    I NUMCHDS >2 S ORY=" COMPLEX-PS I"_U_PRTOR DER
  2081   "RTN","ORW DXA",219,0 )
  2082    S:$D(^OR( 100,+PRTOR DER,4.5,"I D","NOW"))  NOWID=$O( ^("NOW",0) )
  2083   "RTN","ORW DXA",220,0 )
  2084    S:NOWID N OWVAL=$G(^ OR(100,+PR TORDER,4.5 ,NOWID,1))
  2085   "RTN","ORW DXA",221,0 )
  2086    I NOWVAL= 1 Q
  2087   "RTN","ORW DXA",222,0 )
  2088    E  S ORY= "COMPLEX-P SI"_U_PRTO RDER
  2089   "RTN","ORW DXA",223,0 )
  2090    Q
  2091   "RTN","ORW DXA",224,0 )
  2092   ISACTOI(OR Y,OI) ; Is  ord item  active?
  2093   "RTN","ORW DXA",225,0 )
  2094    I $G(^ORD (101.43,+O I,.1)),^(. 1)'>$$NOW^ XLFDT D
  2095   "RTN","ORW DXA",226,0 )
  2096    . S ORY=$ P($G(^ORD( 101.43,OI, 0)),U)_" h as been in activated  and may no t be order ed anymore ."
  2097   "RTN","ORW DXA",227,0 )
  2098    Q
  2099   "RTN","ORW DXA",228,0 )
  2100   UPCTCHK(OR ID) ;
  2101   "RTN","ORW DXA",229,0 )
  2102    ;ORID=ORD ER NUMBER
  2103   "RTN","ORW DXA",230,0 )
  2104    ;RETURNS  1 IF THERE  IS AN UPC ARET IN TH E ORDER'S  COMMENTS
  2105   "RTN","ORW DXA",231,0 )
  2106    N RET,COM MID,WPCNT, PIID S RET =0
  2107   "RTN","ORW DXA",232,0 )
  2108    S COMMID= $O(^OR(100 ,+ORID,4.5 ,"ID","COM MENT",0))
  2109   "RTN","ORW DXA",233,0 )
  2110    I COMMID  S WPCNT=0  F  S WPCNT =$O(^OR(10 0,+ORID,4. 5,COMMID,2 ,WPCNT)) Q :'WPCNT!(R ET)  D
  2111   "RTN","ORW DXA",234,0 )
  2112    .I $G(^OR (100,+ORID ,4.5,COMMI D,2,WPCNT, 0))["^" S  RET=1
  2113   "RTN","ORW DXA",235,0 )
  2114    S PIID=$O (^OR(100,+ ORID,4.5," ID","PI",0 ))
  2115   "RTN","ORW DXA",236,0 )
  2116    I PIID S  WPCNT=0 F   S WPCNT=$ O(^OR(100, +ORID,4.5, PIID,2,WPC NT)) Q:'WP CNT!(RET)   D
  2117   "RTN","ORW DXA",237,0 )
  2118    .I $G(^OR (100,+ORID ,4.5,PIID, 2,WPCNT,0) )["^" S RE T=1
  2119   "RTN","ORW DXA",238,0 )
  2120    Q RET
  2121   "VER")
  2122   8.0^22.0
  2123   **INSTALL  NAME**
  2124   VPR*1.0*3
  2125   "BLD",8470 ,0)
  2126   VPR*1.0*3^ VIRTUAL PA TIENT RECO RD^0^31404 08^y
  2127   "BLD",8470 ,1,0)
  2128   ^9.61A^2^2 ^3130717^^ ^
  2129   "BLD",8470 ,1,1,0)
  2130   The Virtua l Patient  Record (VP R) monitor s a VistA  system for  new data
  2131   "BLD",8470 ,1,2,0)
  2132   and activi ty, and ma kes that d ata availa ble to a s ubscribing  client.
  2133   "BLD",8470 ,4,0)
  2134   ^9.64PA^10 0.98^7
  2135   "BLD",8470 ,4,100.98, 0)
  2136   100.98
  2137   "BLD",8470 ,4,100.98, 222)
  2138   n^n^f^^n^^ y^o^n
  2139   "BLD",8470 ,4,100.98, 223)
  2140  
  2141   "BLD",8470 ,4,100.98, 224)
  2142   I $P(^(0), U,3)="NTX"
  2143   "BLD",8470 ,4,101.41, 0)
  2144   101.41
  2145   "BLD",8470 ,4,101.41, 222)
  2146   n^n^f^^n^^ y^o^n
  2147   "BLD",8470 ,4,101.41, 224)
  2148   I $P(^(0), U)="OR GXM ISC TREATM ENTS"
  2149   "BLD",8470 ,4,560,0)
  2150   560
  2151   "BLD",8470 ,4,560,222 )
  2152   y^y^f^^^^n
  2153   "BLD",8470 ,4,560.1,0 )
  2154   560.1
  2155   "BLD",8470 ,4,560.1,2 22)
  2156   y^y^f^^^^n
  2157   "BLD",8470 ,4,560.11, 0)
  2158   560.11
  2159   "BLD",8470 ,4,560.11, 222)
  2160   y^y^f^^^^n
  2161   "BLD",8470 ,4,561,0)
  2162   561
  2163   "BLD",8470 ,4,561,222 )
  2164   y^y^f^^^^n
  2165   "BLD",8470 ,4,561.2,0 )
  2166   561.2
  2167   "BLD",8470 ,4,561.2,2 22)
  2168   y^y^f
  2169   "BLD",8470 ,4,"B",100 .98,100.98 )
  2170  
  2171   "BLD",8470 ,4,"B",101 .41,101.41 )
  2172  
  2173   "BLD",8470 ,4,"B",560 ,560)
  2174  
  2175   "BLD",8470 ,4,"B",560 .1,560.1)
  2176  
  2177   "BLD",8470 ,4,"B",560 .11,560.11 )
  2178  
  2179   "BLD",8470 ,4,"B",561 ,561)
  2180  
  2181   "BLD",8470 ,4,"B",561 .2,561.2)
  2182  
  2183   "BLD",8470 ,6.3)
  2184   205
  2185   "BLD",8470 ,"ABPKG")
  2186   n
  2187   "BLD",8470 ,"INI")
  2188   PRE^VPRP3I
  2189   "BLD",8470 ,"INIT")
  2190   POST^VPRP3 I
  2191   "BLD",8470 ,"KRN",0)
  2192   ^9.67PA^77 9.2^20
  2193   "BLD",8470 ,"KRN",.4, 0)
  2194   .4
  2195   "BLD",8470 ,"KRN",.40 1,0)
  2196   .401
  2197   "BLD",8470 ,"KRN",.40 2,0)
  2198   .402
  2199   "BLD",8470 ,"KRN",.40 3,0)
  2200   .403
  2201   "BLD",8470 ,"KRN",.5, 0)
  2202   .5
  2203   "BLD",8470 ,"KRN",.84 ,0)
  2204   .84
  2205   "BLD",8470 ,"KRN",3.6 ,0)
  2206   3.6
  2207   "BLD",8470 ,"KRN",3.8 ,0)
  2208   3.8
  2209   "BLD",8470 ,"KRN",9.2 ,0)
  2210   9.2
  2211   "BLD",8470 ,"KRN",9.8 ,0)
  2212   9.8
  2213   "BLD",8470 ,"KRN",9.8 ,"NM",0)
  2214   ^9.68A^98^ 71
  2215   "BLD",8470 ,"KRN",9.8 ,"NM",1,0)
  2216   VPRIDX^^0^ B14502148
  2217   "BLD",8470 ,"KRN",9.8 ,"NM",2,0)
  2218   VPREVNT^^0 ^B98045334
  2219   "BLD",8470 ,"KRN",9.8 ,"NM",3,0)
  2220   VPRPATS^^0 ^B44568818
  2221   "BLD",8470 ,"KRN",9.8 ,"NM",4,0)
  2222   VPRSR^^0^B 406288
  2223   "BLD",8470 ,"KRN",9.8 ,"NM",5,0)
  2224   VPRHTTP^^0 ^B14174140
  2225   "BLD",8470 ,"KRN",9.8 ,"NM",6,0)
  2226   VPRCORD^^0 ^B7454230
  2227   "BLD",8470 ,"KRN",9.8 ,"NM",7,0)
  2228   VPRCORD1^^ 0^B1959765 62
  2229   "BLD",8470 ,"KRN",9.8 ,"NM",8,0)
  2230   VPRCORD2^^ 0^B6771688 9
  2231   "BLD",8470 ,"KRN",9.8 ,"NM",9,0)
  2232   VPRCPAT^^0 ^B18789518
  2233   "BLD",8470 ,"KRN",9.8 ,"NM",10,0 )
  2234   VPRCPAT1^^ 0^B7071755
  2235   "BLD",8470 ,"KRN",9.8 ,"NM",11,0 )
  2236   VPRPANEL^^ 0^B9307129
  2237   "BLD",8470 ,"KRN",9.8 ,"NM",12,0 )
  2238   VPRFPTC^^0 ^B14441086
  2239   "BLD",8470 ,"KRN",9.8 ,"NM",13,0 )
  2240   VPRROS2^^0 ^B10651660 0
  2241   "BLD",8470 ,"KRN",9.8 ,"NM",14,0 )
  2242   VPRROS3^^0 ^B86684006
  2243   "BLD",8470 ,"KRN",9.8 ,"NM",15,0 )
  2244   VPRROS4^^0 ^B91302550
  2245   "BLD",8470 ,"KRN",9.8 ,"NM",16,0 )
  2246   VPRROS5^^0 ^B9679013
  2247   "BLD",8470 ,"KRN",9.8 ,"NM",18,0 )
  2248   VPRPRODC^^ 0^B2553308
  2249   "BLD",8470 ,"KRN",9.8 ,"NM",19,0 )
  2250   VPRCRPC^^0 ^B11294692
  2251   "BLD",8470 ,"KRN",9.8 ,"NM",20,0 )
  2252   VPRCRPC1^^ 0^B9103000 0
  2253   "BLD",8470 ,"KRN",9.8 ,"NM",43,0 )
  2254   VPRDX^^1^
  2255   "BLD",8470 ,"KRN",9.8 ,"NM",45,0 )
  2256   VPRCORD3^^ 0^B1513718 65
  2257   "BLD",8470 ,"KRN",9.8 ,"NM",46,0 )
  2258   VPRCORD4^^ 0^B1370186 75
  2259   "BLD",8470 ,"KRN",9.8 ,"NM",47,0 )
  2260   VPRCPRS^^0 ^B4945756
  2261   "BLD",8470 ,"KRN",9.8 ,"NM",49,0 )
  2262   VPRDJ04E^^ 0^B1017070 3
  2263   "BLD",8470 ,"KRN",9.8 ,"NM",50,0 )
  2264   VPRDJ1^^0^ B18149314
  2265   "BLD",8470 ,"KRN",9.8 ,"NM",51,0 )
  2266   VPRDJ2^^0^ B21100510
  2267   "BLD",8470 ,"KRN",9.8 ,"NM",52,0 )
  2268   VPRDJX^^0^ B36169855
  2269   "BLD",8470 ,"KRN",9.8 ,"NM",53,0 )
  2270   VPREASU^^0 ^B57462080
  2271   "BLD",8470 ,"KRN",9.8 ,"NM",54,0 )
  2272   VPREF^^0^B 153229419
  2273   "BLD",8470 ,"KRN",9.8 ,"NM",55,0 )
  2274   VPREFX^^0^ B8552882
  2275   "BLD",8470 ,"KRN",9.8 ,"NM",56,0 )
  2276   VPRENSZ^^0 ^B68594142
  2277   "BLD",8470 ,"KRN",9.8 ,"NM",57,0 )
  2278   VPRENSZ1^^ 0^B1068678 8
  2279   "BLD",8470 ,"KRN",9.8 ,"NM",58,0 )
  2280   VPRMDUTL^^ 0^B4973270 1
  2281   "BLD",8470 ,"KRN",9.8 ,"NM",59,0 )
  2282   VPRPARAM^^ 0^B1543611 3
  2283   "BLD",8470 ,"KRN",9.8 ,"NM",60,0 )
  2284   VPRPXRM^^0 ^B12244143
  2285   "BLD",8470 ,"KRN",9.8 ,"NM",61,0 )
  2286   VPRROS6^^0 ^B26492527
  2287   "BLD",8470 ,"KRN",9.8 ,"NM",62,0 )
  2288   VPRROS7^^0 ^B23838606
  2289   "BLD",8470 ,"KRN",9.8 ,"NM",63,0 )
  2290   VPRTRPC^^0 ^B3739499
  2291   "BLD",8470 ,"KRN",9.8 ,"NM",64,0 )
  2292   VPRTRPC1^^ 0^B4108189 1
  2293   "BLD",8470 ,"KRN",9.8 ,"NM",65,0 )
  2294   VPRDJ09M^^ 0^B1020485 9
  2295   "BLD",8470 ,"KRN",9.8 ,"NM",66,0 )
  2296   VPRYFRP^^0 ^B93175404
  2297   "BLD",8470 ,"KRN",9.8 ,"NM",67,0 )
  2298   VPRYPAR^^0 ^B3971880
  2299   "BLD",8470 ,"KRN",9.8 ,"NM",68,0 )
  2300   VPRDJ^^0^B 33552080
  2301   "BLD",8470 ,"KRN",9.8 ,"NM",70,0 )
  2302   VPRDJ00^^0 ^B64784793
  2303   "BLD",8470 ,"KRN",9.8 ,"NM",71,0 )
  2304   VPRDJ01^^0 ^B41209021
  2305   "BLD",8470 ,"KRN",9.8 ,"NM",72,0 )
  2306   VPRDJ02^^0 ^B63154209
  2307   "BLD",8470 ,"KRN",9.8 ,"NM",73,0 )
  2308   VPRDJ03^^0 ^B54346353
  2309   "BLD",8470 ,"KRN",9.8 ,"NM",74,0 )
  2310   VPRDJ04^^0 ^B50472734
  2311   "BLD",8470 ,"KRN",9.8 ,"NM",75,0 )
  2312   VPRDJ05^^0 ^B78637701
  2313   "BLD",8470 ,"KRN",9.8 ,"NM",77,0 )
  2314   VPRDJ06^^0 ^B58927484
  2315   "BLD",8470 ,"KRN",9.8 ,"NM",78,0 )
  2316   VPRDJ07^^0 ^B21890653
  2317   "BLD",8470 ,"KRN",9.8 ,"NM",79,0 )
  2318   VPRDJ08^^0 ^B69154613
  2319   "BLD",8470 ,"KRN",9.8 ,"NM",80,0 )
  2320   VPRDJ09^^0 ^B39174048
  2321   "BLD",8470 ,"KRN",9.8 ,"NM",81,0 )
  2322   VPRDJ04A^^ 0^B3600734 6
  2323   "BLD",8470 ,"KRN",9.8 ,"NM",82,0 )
  2324   VPRDJ08A^^ 0^B4451787 6
  2325   "BLD",8470 ,"KRN",9.8 ,"NM",83,0 )
  2326   VPRUPD^^0^ B20368971
  2327   "BLD",8470 ,"KRN",9.8 ,"NM",84,0 )
  2328   VPRELAB^^0 ^B4110490
  2329   "BLD",8470 ,"KRN",9.8 ,"NM",85,0 )
  2330   VPRDJFS^^0 ^B56866811
  2331   "BLD",8470 ,"KRN",9.8 ,"NM",86,0 )
  2332   VPRDJFSG^^ 0^B9451978 6
  2333   "BLD",8470 ,"KRN",9.8 ,"NM",87,0 )
  2334   VPRDJFSP^^ 0^B8660241 2
  2335   "BLD",8470 ,"KRN",9.8 ,"NM",88,0 )
  2336   VPRDJFST^^ 0^B3324893 8
  2337   "BLD",8470 ,"KRN",9.8 ,"NM",89,0 )
  2338   VPREFSG^^0 ^B7186739
  2339   "BLD",8470 ,"KRN",9.8 ,"NM",90,0 )
  2340   VPREFSP^^0 ^B44858817
  2341   "BLD",8470 ,"KRN",9.8 ,"NM",91,0 )
  2342   VPREFST^^0 ^B5375002
  2343   "BLD",8470 ,"KRN",9.8 ,"NM",92,0 )
  2344   VPRCAC^^0^ B93805364
  2345   "BLD",8470 ,"KRN",9.8 ,"NM",93,0 )
  2346   VPRUTILS^^ 0^B1865995 6
  2347   "BLD",8470 ,"KRN",9.8 ,"NM",94,0 )
  2348   VPRJSON^^0 ^B11235996
  2349   "BLD",8470 ,"KRN",9.8 ,"NM",95,0 )
  2350   VPRJSOND^^ 0^B6876000 5
  2351   "BLD",8470 ,"KRN",9.8 ,"NM",96,0 )
  2352   VPRJSONE^^ 0^B2251846 7
  2353   "BLD",8470 ,"KRN",9.8 ,"NM",97,0 )
  2354   VPREHL7^^0 ^B986624
  2355   "BLD",8470 ,"KRN",9.8 ,"NM",98,0 )
  2356   VPRDJFSM^^ 0^B2284368 2
  2357   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCAC",9 2)
  2358  
  2359   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD", 6)
  2360  
  2361   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD1" ,7)
  2362  
  2363   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD2" ,8)
  2364  
  2365   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD3" ,45)
  2366  
  2367   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD4" ,46)
  2368  
  2369   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCPAT", 9)
  2370  
  2371   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCPAT1" ,10)
  2372  
  2373   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCPRS", 47)
  2374  
  2375   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCRPC", 19)
  2376  
  2377   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCRPC1" ,20)
  2378  
  2379   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ",68 )
  2380  
  2381   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ00", 70)
  2382  
  2383   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ01", 71)
  2384  
  2385   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ02", 72)
  2386  
  2387   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ03", 73)
  2388  
  2389   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ04", 74)
  2390  
  2391   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ04A" ,81)
  2392  
  2393   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ04E" ,49)
  2394  
  2395   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ05", 75)
  2396  
  2397   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ06", 77)
  2398  
  2399   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ07", 78)
  2400  
  2401   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ08", 79)
  2402  
  2403   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ08A" ,82)
  2404  
  2405   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ09", 80)
  2406  
  2407   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ09M" ,65)
  2408  
  2409   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ1",5 0)
  2410  
  2411   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ2",5 1)
  2412  
  2413   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFS", 85)
  2414  
  2415   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFSG" ,86)
  2416  
  2417   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFSM" ,98)
  2418  
  2419   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFSP" ,87)
  2420  
  2421   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFST" ,88)
  2422  
  2423   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJX",5 2)
  2424  
  2425   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDX",43 )
  2426  
  2427   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREASU", 53)
  2428  
  2429   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREF",54 )
  2430  
  2431   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREFSG", 89)
  2432  
  2433   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREFSP", 90)
  2434  
  2435   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREFST", 91)
  2436  
  2437   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREFX",5 5)
  2438  
  2439   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREHL7", 97)
  2440  
  2441   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRELAB", 84)
  2442  
  2443   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRENSZ", 56)
  2444  
  2445   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRENSZ1" ,57)
  2446  
  2447   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREVNT", 2)
  2448  
  2449   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRFPTC", 12)
  2450  
  2451   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRHTTP", 5)
  2452  
  2453   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRIDX",1 )
  2454  
  2455   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRJSON", 94)
  2456  
  2457   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRJSOND" ,95)
  2458  
  2459   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRJSONE" ,96)
  2460  
  2461   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRMDUTL" ,58)
  2462  
  2463   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPANEL" ,11)
  2464  
  2465   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPARAM" ,59)
  2466  
  2467   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPATS", 3)
  2468  
  2469   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPRODC" ,18)
  2470  
  2471   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPXRM", 60)
  2472  
  2473   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS2", 13)
  2474  
  2475   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS3", 14)
  2476  
  2477   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS4", 15)
  2478  
  2479   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS5", 16)
  2480  
  2481   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS6", 61)
  2482  
  2483   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS7", 62)
  2484  
  2485   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRSR",4)
  2486  
  2487   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRTRPC", 63)
  2488  
  2489   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRTRPC1" ,64)
  2490  
  2491   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRUPD",8 3)
  2492  
  2493   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRUTILS" ,93)
  2494  
  2495   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRYFRP", 66)
  2496  
  2497   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRYPAR", 67)
  2498  
  2499   "BLD",8470 ,"KRN",19, 0)
  2500   19
  2501   "BLD",8470 ,"KRN",19, "NM",0)
  2502   ^9.68A^14^ 14
  2503   "BLD",8470 ,"KRN",19, "NM",1,0)
  2504   VPR APPOIN TMENTS^^0
  2505   "BLD",8470 ,"KRN",19, "NM",2,0)
  2506   VPR PATIEN T DATA MON ITOR^^0
  2507   "BLD",8470 ,"KRN",19, "NM",3,0)
  2508   VPR UI CON TEXT^^0
  2509   "BLD",8470 ,"KRN",19, "NM",4,0)
  2510   VPR SYNCHR ONIZATION  CONTEXT^^0
  2511   "BLD",8470 ,"KRN",19, "NM",5,0)
  2512   VPR APPLIC ATION PROX Y^^0
  2513   "BLD",8470 ,"KRN",19, "NM",6,0)
  2514   VPR XU EVE NTS^^0
  2515   "BLD",8470 ,"KRN",19, "NM",7,0)
  2516   XU USER AD D^^2
  2517   "BLD",8470 ,"KRN",19, "NM",8,0)
  2518   XU USER CH ANGE^^2
  2519   "BLD",8470 ,"KRN",19, "NM",9,0)
  2520   XU USER TE RMINATE^^2
  2521   "BLD",8470 ,"KRN",19, "NM",10,0)
  2522   VPRM ADD H MP USER^^0
  2523   "BLD",8470 ,"KRN",19, "NM",11,0)
  2524   VPRM EXTRA CT MONITOR ^^0
  2525   "BLD",8470 ,"KRN",19, "NM",12,0)
  2526   VPRM ADD H MP PATIENT ^^0
  2527   "BLD",8470 ,"KRN",19, "NM",13,0)
  2528   VPRM EMERG ENCY STOP^ ^0
  2529   "BLD",8470 ,"KRN",19, "NM",14,0)
  2530   VPRMGR^^0
  2531   "BLD",8470 ,"KRN",19, "NM","B"," VPR APPLIC ATION PROX Y",5)
  2532  
  2533   "BLD",8470 ,"KRN",19, "NM","B"," VPR APPOIN TMENTS",1)
  2534  
  2535   "BLD",8470 ,"KRN",19, "NM","B"," VPR PATIEN T DATA MON ITOR",2)
  2536  
  2537   "BLD",8470 ,"KRN",19, "NM","B"," VPR SYNCHR ONIZATION  CONTEXT",4 )
  2538  
  2539   "BLD",8470 ,"KRN",19, "NM","B"," VPR UI CON TEXT",3)
  2540  
  2541   "BLD",8470 ,"KRN",19, "NM","B"," VPR XU EVE NTS",6)
  2542  
  2543   "BLD",8470 ,"KRN",19, "NM","B"," VPRM ADD H MP PATIENT ",12)
  2544  
  2545   "BLD",8470 ,"KRN",19, "NM","B"," VPRM ADD H MP USER",1 0)
  2546  
  2547   "BLD",8470 ,"KRN",19, "NM","B"," VPRM EMERG ENCY STOP" ,13)
  2548  
  2549   "BLD",8470 ,"KRN",19, "NM","B"," VPRM EXTRA CT MONITOR ",11)
  2550  
  2551   "BLD",8470 ,"KRN",19, "NM","B"," VPRMGR",14 )
  2552  
  2553   "BLD",8470 ,"KRN",19, "NM","B"," XU USER AD D",7)
  2554  
  2555   "BLD",8470 ,"KRN",19, "NM","B"," XU USER CH ANGE",8)
  2556  
  2557   "BLD",8470 ,"KRN",19, "NM","B"," XU USER TE RMINATE",9 )
  2558  
  2559   "BLD",8470 ,"KRN",19. 1,0)
  2560   19.1
  2561   "BLD",8470 ,"KRN",19. 1,"NM",0)
  2562   ^9.68A^1^1
  2563   "BLD",8470 ,"KRN",19. 1,"NM",1,0 )
  2564   VPR EXPERI MENTAL^^0
  2565   "BLD",8470 ,"KRN",19. 1,"NM","B" ,"VPR EXPE RIMENTAL", 1)
  2566  
  2567   "BLD",8470 ,"KRN",101 ,0)
  2568   101
  2569   "BLD",8470 ,"KRN",101 ,"NM",0)
  2570   ^9.68A^36^ 31
  2571   "BLD",8470 ,"KRN",101 ,"NM",1,0)
  2572   VPR APPT E VENTS^^0
  2573   "BLD",8470 ,"KRN",101 ,"NM",2,0)
  2574   VPR DG UPD ATES^^0
  2575   "BLD",8470 ,"KRN",101 ,"NM",3,0)
  2576   VPR INPT E VENTS^^0
  2577   "BLD",8470 ,"KRN",101 ,"NM",4,0)
  2578   VPR PCE EV ENTS^^0
  2579   "BLD",8470 ,"KRN",101 ,"NM",5,0)
  2580   VPR XQOR E VENTS^^0
  2581   "BLD",8470 ,"KRN",101 ,"NM",7,0)
  2582   DG FIELD M ONITOR^^2
  2583   "BLD",8470 ,"KRN",101 ,"NM",8,0)
  2584   DGPM MOVEM ENT EVENTS ^^2
  2585   "BLD",8470 ,"KRN",101 ,"NM",9,0)
  2586   LR7O CH EV SEND OR^^2
  2587   "BLD",8470 ,"KRN",101 ,"NM",10,0 )
  2588   PS EVSEND  OR^^2
  2589   "BLD",8470 ,"KRN",101 ,"NM",11,0 )
  2590   PXK VISIT  DATA EVENT ^^2
  2591   "BLD",8470 ,"KRN",101 ,"NM",12,0 )
  2592   RA EVSEND  OR^^2
  2593   "BLD",8470 ,"KRN",101 ,"NM",13,0 )
  2594   SDAM APPOI NTMENT EVE NTS^^2
  2595   "BLD",8470 ,"KRN",101 ,"NM",14,0 )
  2596   VPR GMRA E VENTS^^0
  2597   "BLD",8470 ,"KRN",101 ,"NM",15,0 )
  2598   GMRA ENTER ED IN ERRO R^^2
  2599   "BLD",8470 ,"KRN",101 ,"NM",16,0 )
  2600   GMRA SIGN- OFF ON DAT A^^2
  2601   "BLD",8470 ,"KRN",101 ,"NM",17,0 )
  2602   GMRC EVSEN D OR^^2
  2603   "BLD",8470 ,"KRN",101 ,"NM",20,0 )
  2604   OR EVSEND  GMRC^^2
  2605   "BLD",8470 ,"KRN",101 ,"NM",23,0 )
  2606   OR EVSEND  LRCH^^2
  2607   "BLD",8470 ,"KRN",101 ,"NM",24,0 )
  2608   OR EVSEND  ORG^^2
  2609   "BLD",8470 ,"KRN",101 ,"NM",25,0 )
  2610   OR EVSEND  PS^^2
  2611   "BLD",8470 ,"KRN",101 ,"NM",26,0 )
  2612   OR EVSEND  RA^^2
  2613   "BLD",8470 ,"KRN",101 ,"NM",27,0 )
  2614   GMPL EVENT ^^2
  2615   "BLD",8470 ,"KRN",101 ,"NM",28,0 )
  2616   VPR GMPL E VENT^^0
  2617   "BLD",8470 ,"KRN",101 ,"NM",29,0 )
  2618   VPR NA EVE NTS^^0
  2619   "BLD",8470 ,"KRN",101 ,"NM",30,0 )
  2620   MDC OBSERV ATION UPDA TE^^2
  2621   "BLD",8470 ,"KRN",101 ,"NM",31,0 )
  2622   OR EVSEND  FH^^2
  2623   "BLD",8470 ,"KRN",101 ,"NM",32,0 )
  2624   VPR MDC EV ENT^^0
  2625   "BLD",8470 ,"KRN",101 ,"NM",33,0 )
  2626   FH EVSEND  OR^^2
  2627   "BLD",8470 ,"KRN",101 ,"NM",34,0 )
  2628   OR EVSEND  VPR^^2
  2629   "BLD",8470 ,"KRN",101 ,"NM",35,0 )
  2630   VPR ADT-A0 4 CLIENT^^ 0
  2631   "BLD",8470 ,"KRN",101 ,"NM",36,0 )
  2632   VAFC ADT-A 04 SERVER^ ^2
  2633   "BLD",8470 ,"KRN",101 ,"NM","B", "DG FIELD  MONITOR",7 )
  2634  
  2635   "BLD",8470 ,"KRN",101 ,"NM","B", "DGPM MOVE MENT EVENT S",8)
  2636  
  2637   "BLD",8470 ,"KRN",101 ,"NM","B", "FH EVSEND  OR",33)
  2638  
  2639   "BLD",8470 ,"KRN",101 ,"NM","B", "GMPL EVEN T",27)
  2640  
  2641   "BLD",8470 ,"KRN",101 ,"NM","B", "GMRA ENTE RED IN ERR OR",15)
  2642  
  2643   "BLD",8470 ,"KRN",101 ,"NM","B", "GMRA SIGN -OFF ON DA TA",16)
  2644  
  2645   "BLD",8470 ,"KRN",101 ,"NM","B", "GMRC EVSE ND OR",17)
  2646  
  2647   "BLD",8470 ,"KRN",101 ,"NM","B", "LR7O CH E VSEND OR", 9)
  2648  
  2649   "BLD",8470 ,"KRN",101 ,"NM","B", "MDC OBSER VATION UPD ATE",30)
  2650  
  2651   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  FH",31)
  2652  
  2653   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  GMRC",20)
  2654  
  2655   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  LRCH",23)
  2656  
  2657   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  ORG",24)
  2658  
  2659   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  PS",25)
  2660  
  2661   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  RA",26)
  2662  
  2663   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  VPR",34)
  2664  
  2665   "BLD",8470 ,"KRN",101 ,"NM","B", "PS EVSEND  OR",10)
  2666  
  2667   "BLD",8470 ,"KRN",101 ,"NM","B", "PXK VISIT  DATA EVEN T",11)
  2668  
  2669   "BLD",8470 ,"KRN",101 ,"NM","B", "RA EVSEND  OR",12)
  2670  
  2671   "BLD",8470 ,"KRN",101 ,"NM","B", "SDAM APPO INTMENT EV ENTS",13)
  2672  
  2673   "BLD",8470 ,"KRN",101 ,"NM","B", "VAFC ADT- A04 SERVER ",36)
  2674  
  2675   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR ADT-A 04 CLIENT" ,35)
  2676  
  2677   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR APPT  EVENTS",1)
  2678  
  2679   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR DG UP DATES",2)
  2680  
  2681   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR GMPL  EVENT",28)
  2682  
  2683   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR GMRA  EVENTS",14 )
  2684  
  2685   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR INPT  EVENTS",3)
  2686  
  2687   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR MDC E VENT",32)
  2688  
  2689   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR NA EV ENTS",29)
  2690  
  2691   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR PCE E VENTS",4)
  2692  
  2693   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR XQOR  EVENTS",5)
  2694  
  2695   "BLD",8470 ,"KRN",409 .61,0)
  2696   409.61
  2697   "BLD",8470 ,"KRN",771 ,0)
  2698   771
  2699   "BLD",8470 ,"KRN",771 ,"NM",0)
  2700   ^9.68A^1^1
  2701   "BLD",8470 ,"KRN",771 ,"NM",1,0)
  2702   VPR HL7^^0
  2703   "BLD",8470 ,"KRN",771 ,"NM","B", "VPR HL7", 1)
  2704  
  2705   "BLD",8470 ,"KRN",779 .2,0)
  2706   779.2
  2707   "BLD",8470 ,"KRN",870 ,0)
  2708   870
  2709   "BLD",8470 ,"KRN",898 9.51,0)
  2710   8989.51
  2711   "BLD",8470 ,"KRN",898 9.51,"NM", 0)
  2712   ^9.68A^4^4
  2713   "BLD",8470 ,"KRN",898 9.51,"NM", 1,0)
  2714   VPR LOCATI ONS^^0
  2715   "BLD",8470 ,"KRN",898 9.51,"NM", 2,0)
  2716   VPR TASK W AIT TIME^^ 0
  2717   "BLD",8470 ,"KRN",898 9.51,"NM", 3,0)
  2718   VPR PARAME TERS^^0
  2719   "BLD",8470 ,"KRN",898 9.51,"NM", 4,0)
  2720   VPR CPRS P ATH^^0
  2721   "BLD",8470 ,"KRN",898 9.51,"NM", "B","VPR C PRS PATH", 4)
  2722  
  2723   "BLD",8470 ,"KRN",898 9.51,"NM", "B","VPR L OCATIONS", 1)
  2724  
  2725   "BLD",8470 ,"KRN",898 9.51,"NM", "B","VPR P ARAMETERS" ,3)
  2726  
  2727   "BLD",8470 ,"KRN",898 9.51,"NM", "B","VPR T ASK WAIT T IME",2)
  2728  
  2729   "BLD",8470 ,"KRN",898 9.52,0)
  2730   8989.52
  2731   "BLD",8470 ,"KRN",899 4,0)
  2732   8994
  2733   "BLD",8470 ,"KRN",899 4,"NM",0)
  2734   ^9.68A^28^ 27
  2735   "BLD",8470 ,"KRN",899 4,"NM",1,0 )
  2736   VPR APPOIN TMENTS^^0
  2737   "BLD",8470 ,"KRN",899 4,"NM",2,0 )
  2738   VPR INPATI ENTS^^0
  2739   "BLD",8470 ,"KRN",899 4,"NM",3,0 )
  2740   VPR SUBSCR IBE^^0
  2741   "BLD",8470 ,"KRN",899 4,"NM",4,0 )
  2742   VPRCORD RP C^^0
  2743   "BLD",8470 ,"KRN",899 4,"NM",5,0 )
  2744   VPRCPAT RP C^^0
  2745   "BLD",8470 ,"KRN",899 4,"NM",7,0 )
  2746   VPRFPTC CH KS^^0
  2747   "BLD",8470 ,"KRN",899 4,"NM",8,0 )
  2748   VPRFPTC LO G^^0
  2749   "BLD",8470 ,"KRN",899 4,"NM",9,0 )
  2750   VPR ROSTER  PATIENTS^ ^0
  2751   "BLD",8470 ,"KRN",899 4,"NM",10, 0)
  2752   VPR ROSTER S^^0
  2753   "BLD",8470 ,"KRN",899 4,"NM",11, 0)
  2754   VPR UPDATE  ROSTER^^0
  2755   "BLD",8470 ,"KRN",899 4,"NM",12, 0)
  2756   VPR PREVIE W ROSTER^^ 0
  2757   "BLD",8470 ,"KRN",899 4,"NM",13, 0)
  2758   VPR GET SO URCE^^0
  2759   "BLD",8470 ,"KRN",899 4,"NM",14, 0)
  2760   VPR DELETE  ROSTER^^0
  2761   "BLD",8470 ,"KRN",899 4,"NM",15, 0)
  2762   VPRCRPC RP C^^0
  2763   "BLD",8470 ,"KRN",899 4,"NM",16, 0)
  2764   VPR DELETE  OBJECT^^0
  2765   "BLD",8470 ,"KRN",899 4,"NM",17, 0)
  2766   VPR GET OB JECT^^0
  2767   "BLD",8470 ,"KRN",899 4,"NM",18, 0)
  2768   VPR GET OP ERATIONAL  DATA^^0
  2769   "BLD",8470 ,"KRN",899 4,"NM",19, 0)
  2770   VPR GET RO STER LIST^ ^0
  2771   "BLD",8470 ,"KRN",899 4,"NM",20, 0)
  2772   VPR PUT OB JECT^^0
  2773   "BLD",8470 ,"KRN",899 4,"NM",21, 0)
  2774   VPR PUT PA TIENT DATA ^^0
  2775   "BLD",8470 ,"KRN",899 4,"NM",22, 0)
  2776   VPR GET RE FERENCE DA TA^^0
  2777   "BLD",8470 ,"KRN",899 4,"NM",23, 0)
  2778   VPR SUBSCR IBE ROSTER S^^0
  2779   "BLD",8470 ,"KRN",899 4,"NM",24, 0)
  2780   VPRCPRS RP C^^0
  2781   "BLD",8470 ,"KRN",899 4,"NM",25, 0)
  2782   VPRCRPC RP CCHAIN^^0
  2783   "BLD",8470 ,"KRN",899 4,"NM",26, 0)
  2784   VPR PUT DE MOGRAPHICS ^^0
  2785   "BLD",8470 ,"KRN",899 4,"NM",27, 0)
  2786   VPRDJFS AP I^^0
  2787   "BLD",8470 ,"KRN",899 4,"NM",28, 0)
  2788   VPRDJFS DE LSUB^^0
  2789   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR APPO INTMENTS", 1)
  2790  
  2791   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR DELE TE OBJECT" ,16)
  2792  
  2793   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR DELE TE ROSTER" ,14)
  2794  
  2795   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  OBJECT",17 )
  2796  
  2797   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  OPERATIONA L DATA",18 )
  2798  
  2799   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  REFERENCE  DATA",22)
  2800  
  2801   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  ROSTER LIS T",19)
  2802  
  2803   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  SOURCE",13 )
  2804  
  2805   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR INPA TIENTS",2)
  2806  
  2807   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR PREV IEW ROSTER ",12)
  2808  
  2809   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR PUT  DEMOGRAPHI CS",26)
  2810  
  2811   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR PUT  OBJECT",20 )
  2812  
  2813   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR PUT  PATIENT DA TA",21)
  2814  
  2815   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR ROST ER PATIENT S",9)
  2816  
  2817   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR ROST ERS",10)
  2818  
  2819   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR SUBS CRIBE",3)
  2820  
  2821   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR SUBS CRIBE ROST ERS",23)
  2822  
  2823   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR UPDA TE ROSTER" ,11)
  2824  
  2825   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCORD  RPC",4)
  2826  
  2827   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCPAT  RPC",5)
  2828  
  2829   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCPRS  RPC",24)
  2830  
  2831   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCRPC  RPC",15)
  2832  
  2833   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCRPC  RPCCHAIN", 25)
  2834  
  2835   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRDJFS  API",27)
  2836  
  2837   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRDJFS  DELSUB",28 )
  2838  
  2839   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRFPTC  CHKS",7)
  2840  
  2841   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRFPTC  LOG",8)
  2842  
  2843   "BLD",8470 ,"KRN","B" ,.4,.4)
  2844  
  2845   "BLD",8470 ,"KRN","B" ,.401,.401 )
  2846  
  2847   "BLD",8470 ,"KRN","B" ,.402,.402 )
  2848  
  2849   "BLD",8470 ,"KRN","B" ,.403,.403 )
  2850  
  2851   "BLD",8470 ,"KRN","B" ,.5,.5)
  2852  
  2853   "BLD",8470 ,"KRN","B" ,.84,.84)
  2854  
  2855   "BLD",8470 ,"KRN","B" ,3.6,3.6)
  2856  
  2857   "BLD",8470 ,"KRN","B" ,3.8,3.8)
  2858  
  2859   "BLD",8470 ,"KRN","B" ,9.2,9.2)
  2860  
  2861   "BLD",8470 ,"KRN","B" ,9.8,9.8)
  2862  
  2863   "BLD",8470 ,"KRN","B" ,19,19)
  2864  
  2865   "BLD",8470 ,"KRN","B" ,19.1,19.1 )
  2866  
  2867   "BLD",8470 ,"KRN","B" ,101,101)
  2868  
  2869   "BLD",8470 ,"KRN","B" ,409.61,40 9.61)
  2870  
  2871   "BLD",8470 ,"KRN","B" ,771,771)
  2872  
  2873   "BLD",8470 ,"KRN","B" ,779.2,779 .2)
  2874  
  2875   "BLD",8470 ,"KRN","B" ,870,870)
  2876  
  2877   "BLD",8470 ,"KRN","B" ,8989.51,8 989.51)
  2878  
  2879   "BLD",8470 ,"KRN","B" ,8989.52,8 989.52)
  2880  
  2881   "BLD",8470 ,"KRN","B" ,8994,8994 )
  2882  
  2883   "BLD",8470 ,"PRE")
  2884  
  2885   "BLD",8470 ,"QUES",0)
  2886   ^9.62^^
  2887   "BLD",8470 ,"REQB",0)
  2888   ^9.611^4^2
  2889   "BLD",8470 ,"REQB",3, 0)
  2890   SD*5.3*575 ^2
  2891   "BLD",8470 ,"REQB",4, 0)
  2892   VPR*1.0*2^ 2
  2893   "BLD",8470 ,"REQB","B ","SD*5.3* 575",3)
  2894  
  2895   "BLD",8470 ,"REQB","B ","VPR*1.0 *2",4)
  2896  
  2897   "DATA",100 .98,67,0)
  2898   TREATMENTS ^Treatment s^NTX
  2899   "DATA",101 .41,15917, 0)
  2900   OR GXMISC  TREATMENTS ^Nursing T reatment O rder^^D^67 ^1^170^1^
  2901   "DATA",101 .41,15917, 5)
  2902   ^^^Nursing  Treatment ^^^^
  2903   "DATA",101 .41,15917, 10,0)
  2904   ^101.412IA ^5^5
  2905   "DATA",101 .41,15917, 10,1,0)
  2906   1^4^^Treat ment: ^^1^ ^^^S.NTX
  2907   "DATA",101 .41,15917, 10,1,1)
  2908   Enter a tr eatment it em.
  2909   "DATA",101 .41,15917, 10,1,2)
  2910   1
  2911   "DATA",101 .41,15917, 10,1,4)
  2912   I $$ACTIVE ^ORDD43(Y)
  2913   "DATA",101 .41,15917, 10,1,6)
  2914   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)
  2915   "DATA",101 .41,15917, 10,1,10)
  2916   N OI S OI= +$G(ORDIAL OG(PROMPT, INST)) D:O I ORDMSG^O RCD(OI)
  2917   "DATA",101 .41,15917, 10,1,"W")
  2918   cboNursing
  2919   "DATA",101 .41,15917, 10,2,0)
  2920   2^19^^Inst ructions:  ^^^^^C
  2921   "DATA",101 .41,15917, 10,2,1)
  2922   Enter the  instructio ns for thi s order, u p to 240 c haracters  of text.
  2923   "DATA",101 .41,15917, 10,2,2)
  2924   2^^^^^1
  2925   "DATA",101 .41,15917, 10,3,0)
  2926   4^6^^^^1^^ 1^RCW
  2927   "DATA",101 .41,15917, 10,3,1)
  2928   Enter the  date/time  to begin t his order.
  2929   "DATA",101 .41,15917, 10,3,7)
  2930   S Y="NOW"
  2931   "DATA",101 .41,15917, 10,4,0)
  2932   5^24^^^^^^ ^RCW
  2933   "DATA",101 .41,15917, 10,4,1)
  2934   Enter the  date/time  to end thi s order.
  2935   "DATA",101 .41,15917, 10,4,5)
  2936   I $$FTDCOM P^ORCD("ST ART DATE/T IME","STOP  DATE/TIME ",">") K D ONE W $C(7 ),!,"Canno t end befo re start d ate/time!" ,!
  2937   "DATA",101 .41,15917, 10,5,0)
  2938   3^29^^^^^^ ^^
  2939   "DATA",101 .41,15917, 10,5,1)
  2940   ^
  2941   "DATA",101 .41,15917, 10,5,2)
  2942   3
  2943   "DATA",101 .41,15917, 99)
  2944   63272,5447 5
  2945   "FIA",100. 98)
  2946   DISPLAY GR OUP
  2947   "FIA",100. 98,0)
  2948   ^ORD(100.9 8,
  2949   "FIA",100. 98,0,0)
  2950   100.98I
  2951   "FIA",100. 98,0,1)
  2952   n^n^f^^n^^ y^o^n
  2953   "FIA",100. 98,0,10)
  2954  
  2955   "FIA",100. 98,0,11)
  2956   I $P(^(0), U,3)="NTX"
  2957   "FIA",100. 98,0,"RLRO ")
  2958  
  2959   "FIA",100. 98,0,"VR")
  2960   1.0^VPR
  2961   "FIA",100. 98,100.98)
  2962   0
  2963   "FIA",100. 98,100.981 )
  2964   0
  2965   "FIA",101. 41)
  2966   ORDER DIAL OG
  2967   "FIA",101. 41,0)
  2968   ^ORD(101.4 1,
  2969   "FIA",101. 41,0,0)
  2970   101.41I
  2971   "FIA",101. 41,0,1)
  2972   n^n^f^^n^^ y^o^n
  2973   "FIA",101. 41,0,10)
  2974  
  2975   "FIA",101. 41,0,11)
  2976   I $P(^(0), U)="OR GXM ISC TREATM ENTS"
  2977   "FIA",101. 41,0,"RLRO ")
  2978  
  2979   "FIA",101. 41,0,"VR")
  2980   1.0^VPR
  2981   "FIA",101. 41,101.41)
  2982   0
  2983   "FIA",101. 41,101.411 )
  2984   0
  2985   "FIA",101. 41,101.412 )
  2986   0
  2987   "FIA",101. 41,101.412 18)
  2988   0
  2989   "FIA",101. 41,101.415 )
  2990   0
  2991   "FIA",101. 41,101.416 )
  2992   0
  2993   "FIA",101. 41,101.416 2)
  2994   0
  2995   "FIA",560)
  2996   VPR SUBSCR IPTION
  2997   "FIA",560, 0)
  2998   ^VPR(560,
  2999   "FIA",560, 0,0)
  3000   560
  3001   "FIA",560, 0,1)
  3002   y^y^f^^^^n
  3003   "FIA",560, 0,10)
  3004  
  3005   "FIA",560, 0,11)
  3006  
  3007   "FIA",560, 0,"RLRO")
  3008  
  3009   "FIA",560, 0,"VR")
  3010   1.0^VPR
  3011   "FIA",560, 560)
  3012   0
  3013   "FIA",560, 560.01)
  3014   0
  3015   "FIA",560, 560.02)
  3016   0
  3017   "FIA",560. 1)
  3018   VPR PATIEN T OBJECT
  3019   "FIA",560. 1,0)
  3020   ^VPR(560.1 ,
  3021   "FIA",560. 1,0,0)
  3022   560.1
  3023   "FIA",560. 1,0,1)
  3024   y^y^f^^^^n
  3025   "FIA",560. 1,0,10)
  3026  
  3027   "FIA",560. 1,0,11)
  3028  
  3029   "FIA",560. 1,0,"RLRO" )
  3030  
  3031   "FIA",560. 1,0,"VR")
  3032   1.0^VPR
  3033   "FIA",560. 1,560.1)
  3034   0
  3035   "FIA",560. 1,560.101)
  3036   0
  3037   "FIA",560. 11)
  3038   VPR OBJECT
  3039   "FIA",560. 11,0)
  3040   ^VPR(560.1 1,
  3041   "FIA",560. 11,0,0)
  3042   560.11
  3043   "FIA",560. 11,0,1)
  3044   y^y^f^^^^n
  3045   "FIA",560. 11,0,10)
  3046  
  3047   "FIA",560. 11,0,11)
  3048  
  3049   "FIA",560. 11,0,"RLRO ")
  3050  
  3051   "FIA",560. 11,0,"VR")
  3052   1.0^VPR
  3053   "FIA",560. 11,560.11)
  3054   0
  3055   "FIA",560. 11,560.111 )
  3056   0
  3057   "FIA",561)
  3058   VPR PANEL
  3059   "FIA",561, 0)
  3060   ^VPRPANEL(
  3061   "FIA",561, 0,0)
  3062   561P
  3063   "FIA",561, 0,1)
  3064   y^y^f^^^^n
  3065   "FIA",561, 0,10)
  3066  
  3067   "FIA",561, 0,11)
  3068  
  3069   "FIA",561, 0,"RLRO")
  3070  
  3071   "FIA",561, 0,"VR")
  3072   1.0^VPR
  3073   "FIA",561, 561)
  3074   0
  3075   "FIA",561, 561.05)
  3076   0
  3077   "FIA",561. 2)
  3078   VPROSTER
  3079   "FIA",561. 2,0)
  3080   ^VPROSTER(
  3081   "FIA",561. 2,0,0)
  3082   561.2
  3083   "FIA",561. 2,0,1)
  3084   y^y^f
  3085   "FIA",561. 2,0,10)
  3086  
  3087   "FIA",561. 2,0,11)
  3088  
  3089   "FIA",561. 2,0,"RLRO" )
  3090  
  3091   "FIA",561. 2,0,"VR")
  3092   1.0^VPR
  3093   "FIA",561. 2,561.2)
  3094   0
  3095   "FIA",561. 2,561.21)
  3096   0
  3097   "FIA",561. 2,561.23)
  3098   0
  3099   "INI")
  3100   PRE^VPRP3I
  3101   "INIT")
  3102   POST^VPRP3 I
  3103   "IX",101.4 1,101.41," B",0)
  3104   101.41^B^R egular B i ndex using  full fiel d length^R ^^F^IR^I^1 01.41^^^^^ LS
  3105   "IX",101.4 1,101.41," B",1)
  3106   S ^ORD(101 .41,"B",$E (X,1,63),D A)=""
  3107   "IX",101.4 1,101.41," B",2)
  3108   K ^ORD(101 .41,"B",$E (X,1,63),D A)
  3109   "IX",101.4 1,101.41," B",2.5)
  3110   K ^ORD(101 .41,"B")
  3111   "IX",101.4 1,101.41," B",11.1,0)
  3112   ^.114IA^1^ 1
  3113   "IX",101.4 1,101.41," B",11.1,1, 0)
  3114   1^F^101.41 ^.01^63^1^ F
  3115   "IX",560,5 60,"ADFN", 0)
  3116   560^ADFN^P atients to  track in  the Data M onitor^MU^ ^R^IR^W^56 0.01^^^^^S
  3117   "IX",560,5 60,"ADFN", 1)
  3118   D VPRSET^V PRDJFS(.DA ,.X)
  3119   "IX",560,5 60,"ADFN", 1.4)
  3120   S X=0 I +X (1)>0 S X= 1
  3121   "IX",560,5 60,"ADFN", 2)
  3122   D VPRKILL^ VPRDJFS(.D A,.X)
  3123   "IX",560,5 60,"ADFN", 2.4)
  3124   S X=0 I X( 1)'="" S X =1
  3125   "IX",560,5 60,"ADFN", 2.5)
  3126   K ^VPR(560 ,"AITEM")
  3127   "IX",560,5 60,"ADFN", 11.1,0)
  3128   ^.114IA^2^ 2
  3129   "IX",560,5 60,"ADFN", 11.1,1,0)
  3130   1^F^560.01 ^.01^^1^F
  3131   "IX",560,5 60,"ADFN", 11.1,2,0)
  3132   2^F^560.01 ^2^^^F
  3133   "IX",560,5 60,"AITEM" ,0)
  3134   560^AITEM^ AITEM TEST ^MU^^F^IR^ I^560^^^^^ A
  3135   "IX",560,5 60,"AITEM" ,1)
  3136   D VPROSET^ VPRDJFS(DA ,X)
  3137   "IX",560,5 60,"AITEM" ,1.4)
  3138   I X(1)'=""
  3139   "IX",560,5 60,"AITEM" ,2)
  3140   D VPROKILL ^VPRDJFS(D A)
  3141   "IX",560,5 60,"AITEM" ,2.4)
  3142   I X(1)'=""
  3143   "IX",560,5 60,"AITEM" ,2.5)
  3144   K ^VPR(560 ,"AITEM")
  3145   "IX",560,5 60,"AITEM" ,11.1,0)
  3146   ^.114IA^1^ 1
  3147   "IX",560,5 60,"AITEM" ,11.1,1,0)
  3148   1^F^560^.0 3^^^F
  3149   "IX",560,5 60,"AITEM" ,11.1,1,3)
  3150  
  3151   "IX",560,5 60,"AROS", 0)
  3152   560^AROS^R osters to  track in t he Data Mo nitor^MU^^ R^IR^W^560 .02^^^^^S
  3153   "IX",560,5 60,"AROS", 1)
  3154   S:X2(2) ^V PR(560,"AR OS",X,DA(1 ))=""
  3155   "IX",560,5 60,"AROS", 2)
  3156   K:X1(2) ^V PR(560,"AR OS",X,DA(1 ))
  3157   "IX",560,5 60,"AROS", 2.5)
  3158   K ^VPR(560 ,"AROS")
  3159   "IX",560,5 60,"AROS", 11.1,0)
  3160   ^.114IA^2^ 2
  3161   "IX",560,5 60,"AROS", 11.1,1,0)
  3162   1^F^560.02 ^.01^^1^F
  3163   "IX",560,5 60,"AROS", 11.1,1,3)
  3164  
  3165   "IX",560,5 60,"AROS", 11.1,2,0)
  3166   2^F^560.02 ^2^^2^
  3167   "IX",560,5 60,"AROS", 11.1,2,3)
  3168  
  3169   "IX",560.1 ,560.1,"C" ,0)
  3170   560.1^C^In dex by pat ient, coll ection^R^^ R^IR^I^560 .1^^^^^LS
  3171   "IX",560.1 ,560.1,"C" ,1)
  3172   S ^VPR(560 .1,"C",X(1 ),X(2),DA) =""
  3173   "IX",560.1 ,560.1,"C" ,2)
  3174   K ^VPR(560 .1,"C",X(1 ),X(2),DA)
  3175   "IX",560.1 ,560.1,"C" ,2.5)
  3176   K ^VPR(560 .1,"C")
  3177   "IX",560.1 ,560.1,"C" ,11.1,0)
  3178   ^.114IA^2^ 2
  3179   "IX",560.1 ,560.1,"C" ,11.1,1,0)
  3180   1^F^560.1^ .02^^1^F
  3181   "IX",560.1 ,560.1,"C" ,11.1,1,3)
  3182  
  3183   "IX",560.1 ,560.1,"C" ,11.1,2,0)
  3184   2^F^560.1^ .03^^2^F
  3185   "IX",560.1 ,560.1,"C" ,11.1,2,3)
  3186  
  3187   "IX",561.2 ,561.21,"A C",0)
  3188   561.21^AC^ SORT BY SE QUENCE^R^^ F^IR^I^561 .21^^^^^S
  3189   "IX",561.2 ,561.21,"A C",1)
  3190   Q
  3191   "IX",561.2 ,561.21,"A C",2)
  3192   Q
  3193   "KRN",19,9 027,-1)
  3194   2^9
  3195   "KRN",19,9 027,0)
  3196   XU USER TE RMINATE^Us er termina te event^^ X^10000000 020^^^^^^^ 163^y^1^^^
  3197   "KRN",19,9 027,10,0)
  3198   ^19.01IP^8 ^8
  3199   "KRN",19,9 027,10,8,0 )
  3200   14101
  3201   "KRN",19,9 027,10,8," ^")
  3202   VPR XU EVE NTS
  3203   "KRN",19,9 027,"U")
  3204   USER TERMI NATE EVENT
  3205   "KRN",19,1 2365,-1)
  3206   2^7
  3207   "KRN",19,1 2365,0)
  3208   XU USER AD D^New User  Event^^X^ 1000000002 0^^^^^^^16 3^y^1
  3209   "KRN",19,1 2365,10,0)
  3210   ^19.01IP^2 ^2
  3211   "KRN",19,1 2365,10,2, 0)
  3212   14101
  3213   "KRN",19,1 2365,10,2, "^")
  3214   VPR XU EVE NTS
  3215   "KRN",19,1 2365,"U")
  3216   NEW USER E VENT
  3217   "KRN",19,1 2366,-1)
  3218   2^8
  3219   "KRN",19,1 2366,0)
  3220   XU USER CH ANGE^User  Change Eve nt^^X^1000 0000020^^^ ^^^^163^y^ 1
  3221   "KRN",19,1 2366,10,0)
  3222   ^19.01IP^2 ^2
  3223   "KRN",19,1 2366,10,2, 0)
  3224   14101
  3225   "KRN",19,1 2366,10,2, "^")
  3226   VPR XU EVE NTS
  3227   "KRN",19,1 2366,"U")
  3228   USER CHANG E EVENT
  3229   "KRN",19,1 3996,-1)
  3230   0^1
  3231   "KRN",19,1 3996,0)
  3232   VPR APPOIN TMENTS^Ret urn list o f tomorrow 's patient s^^A^^^^^^ ^^VIRTUAL  PATIENT RE CORD^^1
  3233   "KRN",19,1 3996,1,0)
  3234   ^^3^3^3110 406^
  3235   "KRN",19,1 3996,1,1,0 )
  3236   This optio n is inten ded to be  scheduled  to run nig htly, to n otify the
  3237   "KRN",19,1 3996,1,2,0 )
  3238   AViVA Virt ual Patien t Record ( VPR) of pa tients tha t are expe cted to be
  3239   "KRN",19,1 3996,1,3,0 )
  3240   seen tomor row.
  3241   "KRN",19,1 3996,20)
  3242   D APPT^VPR PATS
  3243   "KRN",19,1 3996,200.9 )
  3244   y
  3245   "KRN",19,1 3996,"U")
  3246   RETURN LIS T OF TOMOR ROW'S PATI
  3247   "KRN",19,1 3997,-1)
  3248   0^2
  3249   "KRN",19,1 3997,0)
  3250   VPR PATIEN T DATA MON ITOR^VPR P atient Dat a Monitor^ ^A^^^^^^^^ VIRTUAL PA TIENT RECO RD^^1
  3251   "KRN",19,1 3997,1,0)
  3252   ^^4^4^3110 406^
  3253   "KRN",19,1 3997,1,1,0 )
  3254   This optio n manages  the VPR Pa tient Data  Monitor b ackground  job.  It 
  3255   "KRN",19,1 3997,1,2,0 )
  3256   first chec ks to see  if the job  is alread y running,  and will  prompt to
  3257   "KRN",19,1 3997,1,3,0 )
  3258   start it i f not.  It  may also  stop the j ob if runn ing, but t he AViVA
  3259   "KRN",19,1 3997,1,4,0 )
  3260   client may  not displ ay up-to-d ate data u ntil it is  started u p again.
  3261   "KRN",19,1 3997,20)
  3262   D EN^VPRHT TP
  3263   "KRN",19,1 3997,"U")
  3264   VPR PATIEN T DATA MON ITOR
  3265   "KRN",19,1 3998,-1)
  3266   0^4
  3267   "KRN",19,1 3998,0)
  3268   VPR SYNCHR ONIZATION  CONTEXT^Sy nchronize  the VPR^^B ^^^^^^^^
  3269   "KRN",19,1 3998,99.1)
  3270   63012,3326 5
  3271   "KRN",19,1 3998,"RPC" ,0)
  3272   ^19.05P^20 ^20
  3273   "KRN",19,1 3998,"RPC" ,2,0)
  3274   VPR DATA V ERSION
  3275   "KRN",19,1 3998,"RPC" ,4,0)
  3276   VPR SUBSCR IBE
  3277   "KRN",19,1 3998,"RPC" ,5,0)
  3278   VPR GET PA TIENT DATA  JSON
  3279   "KRN",19,1 3998,"RPC" ,7,0)
  3280   VPR GET OB JECT
  3281   "KRN",19,1 3998,"RPC" ,8,0)
  3282   VPR GET OP ERATIONAL  DATA
  3283   "KRN",19,1 3998,"RPC" ,10,0)
  3284   VPR PUT OB JECT
  3285   "KRN",19,1 3998,"RPC" ,17,0)
  3286   VPR GET CH ECKSUM
  3287   "KRN",19,1 3998,"RPC" ,19,0)
  3288   VPRDJFS AP I
  3289   "KRN",19,1 3998,"RPC" ,20,0)
  3290   VPRDJFS DE LSUB
  3291   "KRN",19,1 3998,"U")
  3292   SYNCHRONIZ E THE VPR
  3293   "KRN",19,1 3999,-1)
  3294   0^5
  3295   "KRN",19,1 3999,0)
  3296   VPR APPLIC ATION PROX Y^VPR Appl ication Pr oxy^^B^^^^ ^^^^VIRTUA L PATIENT  RECORD
  3297   "KRN",19,1 3999,1,0)
  3298   ^19.06^1^1 ^3110602^^ ^^
  3299   "KRN",19,1 3999,1,1,0 )
  3300   This optio n allows t he VPR con nector pro xy access  to the Vis tA system.
  3301   "KRN",19,1 3999,99.1)
  3302   62971,3386 5
  3303   "KRN",19,1 3999,"RPC" ,0)
  3304   ^19.05P^4^ 4
  3305   "KRN",19,1 3999,"RPC" ,2,0)
  3306   VPR GET PA TIENT DATA
  3307   "KRN",19,1 3999,"RPC" ,3,0)
  3308   VPR DATA V ERSION
  3309   "KRN",19,1 3999,"RPC" ,4,0)
  3310   VPR SUBSCR IBE
  3311   "KRN",19,1 3999,"U")
  3312   VPR APPLIC ATION PROX Y
  3313   "KRN",19,1 4005,-1)
  3314   0^3
  3315   "KRN",19,1 4005,0)
  3316   VPR UI CON TEXT^VPR U I CONTEXT  version 0. 7-S54^^B^^ ^^^^^^VIRT UAL PATIEN T RECORD
  3317   "KRN",19,1 4005,1,0)
  3318   ^^1^1^3110 630^
  3319   "KRN",19,1 4005,1,1,0 )
  3320   This optio n allows t he VPR UI  access to  the VistA  system.
  3321   "KRN",19,1 4005,99.1)
  3322   62990,2964 7
  3323   "KRN",19,1 4005,"RPC" ,0)
  3324   ^19.05P^41 ^41
  3325   "KRN",19,1 4005,"RPC" ,1,0)
  3326   VPRCORD RP C
  3327   "KRN",19,1 4005,"RPC" ,2,0)
  3328   VPRCPAT RP C
  3329   "KRN",19,1 4005,"RPC" ,3,0)
  3330   VPRFPTC CH KS
  3331   "KRN",19,1 4005,"RPC" ,4,0)
  3332   VPRFPTC LO G
  3333   "KRN",19,1 4005,"RPC" ,5,0)
  3334   VPR APPOIN TMENTS
  3335   "KRN",19,1 4005,"RPC" ,6,0)
  3336   VPR DATA V ERSION
  3337   "KRN",19,1 4005,"RPC" ,7,0)
  3338   VPR DELETE  ROSTER
  3339   "KRN",19,1 4005,"RPC" ,8,0)
  3340   VPR GET PA TIENT DATA
  3341   "KRN",19,1 4005,"RPC" ,9,0)
  3342   VPR GET SO URCE
  3343   "KRN",19,1 4005,"RPC" ,10,0)
  3344   VPR INPATI ENTS
  3345   "KRN",19,1 4005,"RPC" ,11,0)
  3346   VPR PREVIE W ROSTER
  3347   "KRN",19,1 4005,"RPC" ,12,0)
  3348   VPR ROSTER  PATIENTS
  3349   "KRN",19,1 4005,"RPC" ,13,0)
  3350   VPR ROSTER S
  3351   "KRN",19,1 4005,"RPC" ,14,0)
  3352   VPR SUBSCR IBE
  3353   "KRN",19,1 4005,"RPC" ,15,0)
  3354   VPR UPDATE  ROSTER
  3355   "KRN",19,1 4005,"RPC" ,16,0)
  3356   VPRCRPC RP C
  3357   "KRN",19,1 4005,"RPC" ,19,0)
  3358   XHD GET PA RAMETER DE F LIST
  3359   "KRN",19,1 4005,"RPC" ,20,0)
  3360   VPR PUT PA TIENT DATA
  3361   "KRN",19,1 4005,"RPC" ,21,0)
  3362   VPR PUT OB JECT
  3363   "KRN",19,1 4005,"RPC" ,22,0)
  3364   VPR DELETE  OBJECT
  3365   "KRN",19,1 4005,"RPC" ,23,0)
  3366   VPR GET OB JECT
  3367   "KRN",19,1 4005,"RPC" ,24,0)
  3368   VPR GET RO STER LIST
  3369   "KRN",19,1 4005,"RPC" ,25,0)
  3370   VPRCPRS RP C
  3371   "KRN",19,1 4005,"RPC" ,26,0)
  3372   ORQPT WARD S
  3373   "KRN",19,1 4005,"RPC" ,27,0)
  3374   ORQPT WARD  PATIENTS
  3375   "KRN",19,1 4005,"RPC" ,28,0)
  3376   ORQPT SPEC IALTIES
  3377   "KRN",19,1 4005,"RPC" ,29,0)
  3378   ORQPT SPEC IALTY PATI ENTS
  3379   "KRN",19,1 4005,"RPC" ,30,0)
  3380   ORWU CLINL OC
  3381   "KRN",19,1 4005,"RPC" ,31,0)
  3382   ORQPT CLIN IC PATIENT S
  3383   "KRN",19,1 4005,"RPC" ,32,0)
  3384   ORWU NEWPE RS
  3385   "KRN",19,1 4005,"RPC" ,33,0)
  3386   ORQPT PROV IDER PATIE NTS
  3387   "KRN",19,1 4005,"RPC" ,34,0)
  3388   ORWRP COLU MN HEADERS
  3389   "KRN",19,1 4005,"RPC" ,35,0)
  3390   ORWLR CUMU LATIVE REP ORT
  3391   "KRN",19,1 4005,"RPC" ,36,0)
  3392   ORWLRR INT ERIM
  3393   "KRN",19,1 4005,"RPC" ,37,0)
  3394   ORWRP REPO RT TEXT
  3395   "KRN",19,1 4005,"RPC" ,38,0)
  3396   ORWRP3 EXP AND COLUMN S
  3397   "KRN",19,1 4005,"RPC" ,39,0)
  3398   VPR PUT DE MOGRAPHICS
  3399   "KRN",19,1 4005,"RPC" ,40,0)
  3400   VPRCRPC RP CCHAIN
  3401   "KRN",19,1 4005,"RPC" ,41,0)
  3402   ORQPT DEFA ULT PATIEN T LIST
  3403   "KRN",19,1 4005,"U")
  3404   VPR UI CON TEXT VERSI ON 0.7-S54
  3405   "KRN",19,1 4101,-1)
  3406   0^6
  3407   "KRN",19,1 4101,0)
  3408   VPR XU EVE NTS^New Pe rson event s for VPR^ ^A^^^^^^^^ VIRTUAL PA TIENT RECO RD^^1
  3409   "KRN",19,1 4101,1,0)
  3410   ^^1^1^3130 116^
  3411   "KRN",19,1 4101,1,1,0 )
  3412   This proto col will t rack New P erson upda tes for VP R.
  3413   "KRN",19,1 4101,20)
  3414   D XU^VPREV NT(XUIEN," ")
  3415   "KRN",19,1 4101,"U")
  3416   NEW PERSON  EVENTS FO R VPR
  3417   "KRN",19,1 4233,-1)
  3418   0^10
  3419   "KRN",19,1 4233,0)
  3420   VPRM ADD H MP USER^Ad d Health M anagement  Platform U ser^^A^^^^ ^^^^VIRTUA L PATIENT  RECORD^^1
  3421   "KRN",19,1 4233,1,0)
  3422   ^^4^4^3140 326^
  3423   "KRN",19,1 4233,1,1,0 )
  3424   This optio n allows a  user to b e given ac cess to us e the Heal th Managem ent
  3425   "KRN",19,1 4233,1,2,0 )
  3426   Platform.   The selec ted user w ill be giv en the VPR  UI CONTEX T option.
  3427   "KRN",19,1 4233,1,3,0 )
  3428   Additional ly, their  default pa tient list  my be set  up for au tomatic
  3429   "KRN",19,1 4233,1,4,0 )
  3430   synchroniz ation with  the Healt h Manageme nt Platfor m (HMP).
  3431   "KRN",19,1 4233,20)
  3432   D OPTASGN^ VPRCAC
  3433   "KRN",19,1 4233,"U")
  3434   ADD HEALTH  MANAGEMEN T PLATFORM
  3435   "KRN",19,1 4234,-1)
  3436   0^11
  3437   "KRN",19,1 4234,0)
  3438   VPRM EXTRA CT MONITOR ^Monitor H MP Server  Synchroniz ation^^A^^ ^^^^^^VIRT UAL PATIEN T RECORD^^ 1
  3439   "KRN",19,1 4234,1,0)
  3440   ^^2^2^3140 402^
  3441   "KRN",19,1 4234,1,1,0 )
  3442   This optio n allow on e to monit or the pol ls from an  HMP serve r and any 
  3443   "KRN",19,1 4234,1,2,0 )
  3444   currently  executing  VPR extrac ts.
  3445   "KRN",19,1 4234,20)
  3446   D EN^VPRDJ FSM
  3447   "KRN",19,1 4234,"U")
  3448   MONITOR HM P SERVER S YNCHRONIZA
  3449   "KRN",19,1 4235,-1)
  3450   0^13
  3451   "KRN",19,1 4235,0)
  3452   VPRM EMERG ENCY STOP^ Emergency  Stop VPR F reshness U pdates^^A^ ^^^^^^^VIR TUAL PATIE NT RECORD^ ^1
  3453   "KRN",19,1 4235,1,0)
  3454   ^^5^5^3140 403^
  3455   "KRN",19,1 4235,1,1,0 )
  3456   This optio n should b e used wit h caution.   It will  stop the f reshness 
  3457   "KRN",19,1 4235,1,2,0 )
  3458   events for  the Virtu al Patient  Record (V PR) from b eing calle d.  Once t he 
  3459   "KRN",19,1 4235,1,3,0 )
  3460   freshness  events are  stopped,  patient da ta must be  re-synchr onized wit h
  3461   "KRN",19,1 4235,1,4,0 )
  3462   the VPR to  ensure co mpleteness .  Only st op freshne ss updates  if there  is a
  3463   "KRN",19,1 4235,1,5,0 )
  3464   problem wi th system  operation.
  3465   "KRN",19,1 4235,20)
  3466   D EMERSTOP ^VPRDJFSM
  3467   "KRN",19,1 4235,"U")
  3468   EMERGENCY  STOP VPR F RESHNESS U
  3469   "KRN",19,1 4236,-1)
  3470   0^12
  3471   "KRN",19,1 4236,0)
  3472   VPRM ADD H MP PATIENT ^Manually  Add Patien t to VPR^^ A^^^^^^^^V IRTUAL PAT IENT RECOR D^^1
  3473   "KRN",19,1 4236,1,0)
  3474   ^^2^2^3140 404^
  3475   "KRN",19,1 4236,1,1,0 )
  3476   Use this p atient to  manually a dd a patie nt for syn chronizati on with th
  3477   "KRN",19,1 4236,1,2,0 )
  3478   Virtual Pa tient Reco rd (VPR).
  3479   "KRN",19,1 4236,20)
  3480   D ADDPT^VP RDJFSM
  3481   "KRN",19,1 4236,"U")
  3482   MANUALLY A DD PATIENT  TO VPR
  3483   "KRN",19,1 4237,-1)
  3484   0^14
  3485   "KRN",19,1 4237,0)
  3486   VPRMGR^HMP  Technical  Managemen t^^M^^^^^^ ^^VIRTUAL  PATIENT RE CORD
  3487   "KRN",19,1 4237,1,0)
  3488   ^^1^1^3140 404^
  3489   "KRN",19,1 4237,1,1,0 )
  3490   This menu  contains v arious opt ions to he lp with th e manageme nt of HMP.
  3491   "KRN",19,1 4237,10,0)
  3492   ^19.01IP^3 ^3
  3493   "KRN",19,1 4237,10,1, 0)
  3494   14233
  3495   "KRN",19,1 4237,10,1, "^")
  3496   VPRM ADD H MP USER
  3497   "KRN",19,1 4237,10,2, 0)
  3498   14236
  3499   "KRN",19,1 4237,10,2, "^")
  3500   VPRM ADD H MP PATIENT
  3501   "KRN",19,1 4237,10,3, 0)
  3502   14234
  3503   "KRN",19,1 4237,10,3, "^")
  3504   VPRM EXTRA CT MONITOR
  3505   "KRN",19,1 4237,99)
  3506   63281,1411
  3507   "KRN",19,1 4237,"U")
  3508   HMP TECHNI CAL MANAGE MENT
  3509   "KRN",19.1 ,646,-1)
  3510   0^1
  3511   "KRN",19.1 ,646,0)
  3512   VPR EXPERI MENTAL
  3513   "KRN",101, 1240,-1)
  3514   2^8
  3515   "KRN",101, 1240,0)
  3516   DGPM MOVEM ENT EVENTS ^MOVEMENT  EVENTS v 5 .0^^X^1085 ^^^^^^^114
  3517   "KRN",101, 1240,10,0)
  3518   ^101.01PA^ 38^38
  3519   "KRN",101, 1240,10,38 ,0)
  3520   5869^^^
  3521   "KRN",101, 1240,10,38 ,"^")
  3522   VPR INPT E VENTS
  3523   "KRN",101, 1302,-1)
  3524   2^13
  3525   "KRN",101, 1302,0)
  3526   SDAM APPOI NTMENT EVE NTS^Appoin tment Even t Driver^^ X^1085^^^^ ^^^16
  3527   "KRN",101, 1302,10,0)
  3528   ^101.01PA^ 20^20
  3529   "KRN",101, 1302,10,20 ,0)
  3530   5870^^^
  3531   "KRN",101, 1302,10,20 ,"^")
  3532   VPR APPT E VENTS
  3533   "KRN",101, 2690,-1)
  3534   2^12
  3535   "KRN",101, 2690,0)
  3536   RA EVSEND  OR^Radiolo gy event s ent to OE/ RR^^X^1085 ^^^^^^^31
  3537   "KRN",101, 2690,10,0)
  3538   ^101.01PA^ 4^4
  3539   "KRN",101, 2690,10,4, 0)
  3540   5872^^^
  3541   "KRN",101, 2690,10,4, "^")
  3542   VPR XQOR E VENTS
  3543   "KRN",101, 2700,-1)
  3544   2^11
  3545   "KRN",101, 2700,0)
  3546   PXK VISIT  DATA EVENT ^VISIT REL ATED DATA^ ^X^1085^^^ ^^^^
  3547   "KRN",101, 2700,10,0)
  3548   ^101.01PA^ 6^6
  3549   "KRN",101, 2700,10,6, 0)
  3550   5871^^^
  3551   "KRN",101, 2700,10,6, "^")
  3552   VPR PCE EV ENTS
  3553   "KRN",101, 2894,-1)
  3554   2^16
  3555   "KRN",101, 2894,0)
  3556   GMRA SIGN- OFF ON DAT A^Sign-off  on Reacti on Data^^X ^1085^^^^^ ^^247
  3557   "KRN",101, 2894,10,0)
  3558   ^101.01PA^ 2^2
  3559   "KRN",101, 2894,10,2, 0)
  3560   5873^^^
  3561   "KRN",101, 2894,10,2, "^")
  3562   VPR GMRA E VENTS
  3563   "KRN",101, 2896,-1)
  3564   2^15
  3565   "KRN",101, 2896,0)
  3566   GMRA ENTER ED IN ERRO R^Reaction  Data Ente red in Err or^^X^1085 ^^^^^^^247
  3567   "KRN",101, 2896,10,0)
  3568   ^101.01PA^ 2^2
  3569   "KRN",101, 2896,10,2, 0)
  3570   5873^^^
  3571   "KRN",101, 2896,10,2, "^")
  3572   VPR GMRA E VENTS
  3573   "KRN",101, 3336,-1)
  3574   2^9
  3575   "KRN",101, 3336,0)
  3576   LR7O CH EV SEND OR^LA B => OE/RR  ORDER MES SAGE EVENT ^^X^1085^^ ^^^^^
  3577   "KRN",101, 3336,10,0)
  3578   ^101.01PA^ 4^4
  3579   "KRN",101, 3336,10,4, 0)
  3580   5872^^^
  3581   "KRN",101, 3336,10,4, "^")
  3582   VPR XQOR E VENTS
  3583   "KRN",101, 3373,-1)
  3584   2^10
  3585   "KRN",101, 3373,0)
  3586   PS EVSEND  OR^Send Ph armacy ord ers to CPR S.^^X^1085 ^^^^^^^18
  3587   "KRN",101, 3373,10,0)
  3588   ^101.01PA^ 6^6
  3589   "KRN",101, 3373,10,6, 0)
  3590   5872^^^
  3591   "KRN",101, 3373,10,6, "^")
  3592   VPR XQOR E VENTS
  3593   "KRN",101, 3392,-1)
  3594   2^17
  3595   "KRN",101, 3392,0)
  3596   GMRC EVSEN D OR^Consu lts event  sent to OE /RR^^X^108 5^^^^^^^29 4
  3597   "KRN",101, 3392,10,0)
  3598   ^101.01PA^ 6^6
  3599   "KRN",101, 3392,10,6, 0)
  3600   5872^^^
  3601   "KRN",101, 3392,10,6, "^")
  3602   VPR XQOR E VENTS
  3603   "KRN",101, 3411,-1)
  3604   2^33
  3605   "KRN",101, 3411,0)
  3606   FH EVSEND  OR^FH -->  OR event m essages^^X ^1085^^^^^ ^^
  3607   "KRN",101, 3411,10,0)
  3608   ^101.01PA^ 4^4
  3609   "KRN",101, 3411,10,4, 0)
  3610   5872^^^
  3611   "KRN",101, 3411,10,4, "^")
  3612   VPR XQOR E VENTS
  3613   "KRN",101, 3417,-1)
  3614   2^36
  3615   "KRN",101, 3417,0)
  3616   VAFC ADT-A 04 SERVER^ This proto col fires  off of the  PIMS Regi stration o ption^^E^1 085^^^^^^^ 114
  3617   "KRN",101, 3417,775,0 )
  3618   ^101.0775P A^6^6
  3619   "KRN",101, 3417,775,6 ,0)
  3620   6054
  3621   "KRN",101, 3417,775,6 ,"^")
  3622   VPR ADT-A0 4 CLIENT
  3623   "KRN",101, 3529,-1)
  3624   2^26
  3625   "KRN",101, 3529,0)
  3626   OR EVSEND  RA^OE/RR = > RAD/NM M ESSAGE EVE NT^^X^1085 ^^^^^^^
  3627   "KRN",101, 3529,10,0)
  3628   ^101.01PA^ 4^4
  3629   "KRN",101, 3529,10,4, 0)
  3630   5874^^^
  3631   "KRN",101, 3529,10,4, "^")
  3632   VPR NA EVE NTS
  3633   "KRN",101, 3530,-1)
  3634   2^23
  3635   "KRN",101, 3530,0)
  3636   OR EVSEND  LRCH^OE/RR  => LAB ME SSAGE EVEN T^^X^1085^ ^^^^^^
  3637   "KRN",101, 3530,10,0)
  3638   ^101.01PA^ 4^4
  3639   "KRN",101, 3530,10,4, 0)
  3640   5874^^^
  3641   "KRN",101, 3530,10,4, "^")
  3642   VPR NA EVE NTS
  3643   "KRN",101, 3535,-1)
  3644   2^31
  3645   "KRN",101, 3535,0)
  3646   OR EVSEND  FH^OE/RR = > DIET MES SAGE EVENT ^^X^1085^^ ^^^^^
  3647   "KRN",101, 3535,10,0)
  3648   ^101.01PA^ 4^4
  3649   "KRN",101, 3535,10,4, 0)
  3650   5874^^^
  3651   "KRN",101, 3535,10,4, "^")
  3652   VPR NA EVE NTS
  3653   "KRN",101, 3536,-1)
  3654   2^24
  3655   "KRN",101, 3536,0)
  3656   OR EVSEND  ORG^OE/RR  => GENERIC  MESSAGE E VENT^^X^10 85^^^^^^^
  3657   "KRN",101, 3536,10,0)
  3658   ^101.01PA^ 4^4
  3659   "KRN",101, 3536,10,4, 0)
  3660   5872^^^
  3661   "KRN",101, 3536,10,4, "^")
  3662   VPR XQOR E VENTS
  3663   "KRN",101, 3537,-1)
  3664   2^25
  3665   "KRN",101, 3537,0)
  3666   OR EVSEND  PS^OE/RR = > PHARMACY  MESSAGE E VENT^^X^10 85^^^^^^^
  3667   "KRN",101, 3537,10,0)
  3668   ^101.01PA^ 4^4
  3669   "KRN",101, 3537,10,4, 0)
  3670   5874^^^
  3671   "KRN",101, 3537,10,4, "^")
  3672   VPR NA EVE NTS
  3673   "KRN",101, 3539,-1)
  3674   2^20
  3675   "KRN",101, 3539,0)
  3676   OR EVSEND  GMRC^OE/RR  => CONSUL TS MESSAGE  EVENT^^X^ 1085^^^^^^ ^
  3677   "KRN",101, 3539,10,0)
  3678   ^101.01PA^ 6^6
  3679   "KRN",101, 3539,10,6, 0)
  3680   5874^^^
  3681   "KRN",101, 3539,10,6, "^")
  3682   VPR NA EVE NTS
  3683   "KRN",101, 4717,-1)
  3684   2^7
  3685   "KRN",101, 4717,0)
  3686   DG FIELD M ONITOR^DG  Field Moni tor^^X^108 5^^^^^^^11 4
  3687   "KRN",101, 4717,10,0)
  3688   ^101.01PA^ 5^5
  3689   "KRN",101, 4717,10,5, 0)
  3690   5868^^^
  3691   "KRN",101, 4717,10,5, "^")
  3692   VPR DG UPD ATES
  3693   "KRN",101, 5868,-1)
  3694   0^2
  3695   "KRN",101, 5868,0)
  3696   VPR DG UPD ATES^DG up dates for  VPR^^A^^^^ ^^^^
  3697   "KRN",101, 5868,1,0)
  3698   ^101.06^1^ 1^3101129^ ^^^
  3699   "KRN",101, 5868,1,1,0 )
  3700   This proto col will t rack Patie nt file ch anges for  VPR.
  3701   "KRN",101, 5868,20)
  3702   D DG^VPREV NT
  3703   "KRN",101, 5868,99)
  3704   63272,5447 5
  3705   "KRN",101, 5869,-1)
  3706   0^3
  3707   "KRN",101, 5869,0)
  3708   VPR INPT E VENTS^Inpa tient Move ment event s for VPR^ ^A^^^^^^^^
  3709   "KRN",101, 5869,1,0)
  3710   ^101.06^1^ 1^3101202^ ^^^
  3711   "KRN",101, 5869,1,1,0 )
  3712   This proto col will t rack patie nt admissi ons and di scharges f or VPR.
  3713   "KRN",101, 5869,20)
  3714   D DGPM^VPR EVNT
  3715   "KRN",101, 5869,99)
  3716   63272,5447 5
  3717   "KRN",101, 5870,-1)
  3718   0^1
  3719   "KRN",101, 5870,0)
  3720   VPR APPT E VENTS^Appo intment ev ents for V PR^^A^^^^^ ^^^
  3721   "KRN",101, 5870,1,0)
  3722   ^101.06^1^ 1^3101129^ ^^^
  3723   "KRN",101, 5870,1,1,0 )
  3724   This proto col will t rack appoi ntments fo r VPR.
  3725   "KRN",101, 5870,20)
  3726   D SDAM^VPR EVNT
  3727   "KRN",101, 5870,99)
  3728   63272,5447 5
  3729   "KRN",101, 5871,-1)
  3730   0^4
  3731   "KRN",101, 5871,0)
  3732   VPR PCE EV ENTS^PCE e vents for  VPR^^A^^^^ ^^^^
  3733   "KRN",101, 5871,1,0)
  3734   ^101.06^1^ 1^3101129^ ^^
  3735   "KRN",101, 5871,1,1,0 )
  3736   This proto col will t rack PCE v isit data  for VPR.
  3737   "KRN",101, 5871,20)
  3738   D PCE^VPRE VNT
  3739   "KRN",101, 5871,99)
  3740   63272,5447 5
  3741   "KRN",101, 5872,-1)
  3742   0^5
  3743   "KRN",101, 5872,0)
  3744   VPR XQOR E VENTS^XQOR  HL7 event s for VPR^ ^A^^^^^^^^
  3745   "KRN",101, 5872,1,0)
  3746   ^101.06^3^ 3^3101129^ ^
  3747   "KRN",101, 5872,1,1,0 )
  3748   This proto col monito rs order e vents for  VPR.  It i s placed o n the 
  3749   "KRN",101, 5872,1,2,0 )
  3750   * EVSEND O R protocol s to check  for updat es being s ent from a ncillary
  3751   "KRN",101, 5872,1,3,0 )
  3752   packages t o Order En try; it mo nitors whe n orders a re complet ed.
  3753   "KRN",101, 5872,20)
  3754   D XQOR^VPR EVNT(.XQOR MSG)
  3755   "KRN",101, 5872,99)
  3756   63272,5447 5
  3757   "KRN",101, 5873,-1)
  3758   0^14
  3759   "KRN",101, 5873,0)
  3760   VPR GMRA E VENTS^Alle rgy Events  for VPR^^ A^^^^^^^^
  3761   "KRN",101, 5873,1,0)
  3762   ^101.06^1^ 1^3120822^ ^
  3763   "KRN",101, 5873,1,1,0 )
  3764   This proto col will t rack Aller gy data up dates for  VPR.
  3765   "KRN",101, 5873,20)
  3766   D GMRA^VPR EVNT("")
  3767   "KRN",101, 5873,99)
  3768   63272,5447 5
  3769   "KRN",101, 5874,-1)
  3770   0^29
  3771   "KRN",101, 5874,0)
  3772   VPR NA EVE NTS^XQOR H L7 events  for VPR^^A ^^^^^^^^
  3773   "KRN",101, 5874,1,0)
  3774   ^101.06^3^ 3^3110818^ ^^
  3775   "KRN",101, 5874,1,1,0 )
  3776   This proto col monito rs order e vents for  VPR.  It i s placed o n the 
  3777   "KRN",101, 5874,1,2,0 )
  3778   OR EVSEND  * protocol s to check  for order  numbers a ssigned to  new order s
  3779   "KRN",101, 5874,1,3,0 )
  3780   placed fro m the anci llary pack ages.
  3781   "KRN",101, 5874,20)
  3782   D NA^VPREV NT(.XQORMS G)
  3783   "KRN",101, 5874,99)
  3784   63272,5447 5
  3785   "KRN",101, 5875,-1)
  3786   2^27
  3787   "KRN",101, 5875,0)
  3788   GMPL EVENT ^Problem L ist Update  Event^^X^ 1085^^^^^^ ^402
  3789   "KRN",101, 5875,10,0)
  3790   ^101.01PA^ 1^1
  3791   "KRN",101, 5875,10,1, 0)
  3792   5876^^1^
  3793   "KRN",101, 5875,10,1, "^")
  3794   VPR GMPL E VENT
  3795   "KRN",101, 5876,-1)
  3796   0^28
  3797   "KRN",101, 5876,0)
  3798   VPR GMPL E VENT^Probl em List ev ents for V PR^^A^^^^^ ^^^
  3799   "KRN",101, 5876,1,0)
  3800   ^101.06^1^ 1^3110823^ ^^^
  3801   "KRN",101, 5876,1,1,0 )
  3802   This proto col will t rack new a nd updated  problems  for VPR.
  3803   "KRN",101, 5876,20)
  3804   D GMPL^VPR EVNT(DFN,G MPIFN)
  3805   "KRN",101, 5876,99)
  3806   63272,5447 5
  3807   "KRN",101, 5982,-1)
  3808   2^30
  3809   "KRN",101, 5982,0)
  3810   MDC OBSERV ATION UPDA TE^Observa tion updat e notifica tion^^X^10 85^^^^^^^5 57
  3811   "KRN",101, 5982,10,0)
  3812   ^101.01PA^ 6^1
  3813   "KRN",101, 5982,10,6, 0)
  3814   5983^^^
  3815   "KRN",101, 5982,10,6, "^")
  3816   VPR MDC EV ENT
  3817   "KRN",101, 5982,775,0 )
  3818   ^101.0775P A^^
  3819   "KRN",101, 5983,-1)
  3820   0^32
  3821   "KRN",101, 5983,0)
  3822   VPR MDC EV ENT^CLiO e vents for  VPR^^A^^^^ ^^^^
  3823   "KRN",101, 5983,1,0)
  3824   ^101.06^1^ 1^3120830^ ^^^
  3825   "KRN",101, 5983,1,1,0 )
  3826   This proto col will t rack new a nd updated  observati ons for VP R.
  3827   "KRN",101, 5983,20)
  3828   D MDC^VPRE VNT(.MDCOB S)
  3829   "KRN",101, 5983,99)
  3830   63272,5447 5
  3831   "KRN",101, 6053,-1)
  3832   2^34
  3833   "KRN",101, 6053,0)
  3834   OR EVSEND  VPR^OE/RR  => VPR MES SAGE EVENT ^^X^1085^^ ^^^^^
  3835   "KRN",101, 6053,10,0)
  3836   ^101.01PA^ 8^1
  3837   "KRN",101, 6053,10,8, 0)
  3838   5872^^^
  3839   "KRN",101, 6053,10,8, "^")
  3840   VPR XQOR E VENTS
  3841   "KRN",101, 6054,-1)
  3842   0^35
  3843   "KRN",101, 6054,0)
  3844   VPR ADT-A0 4 CLIENT^V PR HL7 ADT -A04 Clien t^^S^^^^^^ ^^VIRTUAL  PATIENT RE CORD
  3845   "KRN",101, 6054,1,0)
  3846   ^^10^10^31 40326^
  3847   "KRN",101, 6054,1,1,0 )
  3848   This clien t protocol  is used t o process  HL7 ADT/A0 4 messages  published  by 
  3849   "KRN",101, 6054,1,2,0 )
  3850   the VAFC A DT-A04 SER VER protoc ol.
  3851   "KRN",101, 6054,1,3,0 )
  3852    
  3853   "KRN",101, 6054,1,4,0 )
  3854   The client  causes a  VPR 'fresh ness' even t for each  new patie nt 
  3855   "KRN",101, 6054,1,5,0 )
  3856   registrati on that oc curs. This  is especi ally impor tant for n ew patient s, 
  3857   "KRN",101, 6054,1,6,0 )
  3858   as it is t he only MA S event me chanism av ailable th at can be  used to 
  3859   "KRN",101, 6054,1,7,0 )
  3860   discover n ew patient  entries.
  3861   "KRN",101, 6054,1,8,0 )
  3862    
  3863   "KRN",101, 6054,1,9,0 )
  3864   Note: The  ROUTING LO GIC does n ot send an y HL7 mess ages. As m entioned 
  3865   "KRN",101, 6054,1,10, 0)
  3866   above, It  adds a HMP  (Health M anagement  Platform)  'freshness ' event.
  3867   "KRN",101, 6054,99)
  3868   63272,7331 7
  3869   "KRN",101, 6054,770)
  3870   ^VPR HL7^^ ^^^^^^^ADT
  3871   "KRN",101, 6054,774)
  3872   DO A04^VPR EHL7
  3873   "KRN",771, 238,-1)
  3874   0^1
  3875   "KRN",771, 238,0)
  3876   VPR HL7^a^ ^^^^USA
  3877   "KRN",8989 .5,13424,0 )
  3878   571;DIC(9. 4,^VPR TAS K WAIT TIM E^1
  3879   "KRN",8989 .5,13424,1 )
  3880   99
  3881   "KRN",8989 .51,651,-1 )
  3882   0^2
  3883   "KRN",8989 .51,651,0)
  3884   VPR TASK W AIT TIME^H ang time u ntil next  cycle^^^#S ECONDS
  3885   "KRN",8989 .51,651,1)
  3886   N^1:9999^E nter the n umber of s econds to  wait befor e the VPR  Data Monit or re-queu es.
  3887   "KRN",8989 .51,651,20 ,0)
  3888   ^^2^2^3110 317^
  3889   "KRN",8989 .51,651,20 ,1,0)
  3890   This is th e number o f seconds  that the s ystem will  wait befo re re-queu ing
  3891   "KRN",8989 .51,651,20 ,2,0)
  3892   the VPR Da ta Monitor  backgroun d job.
  3893   "KRN",8989 .51,651,30 ,0)
  3894   ^8989.513I ^2^2
  3895   "KRN",8989 .51,651,30 ,1,0)
  3896   1^9.4
  3897   "KRN",8989 .51,651,30 ,2,0)
  3898   2^4.2
  3899   "KRN",8989 .51,652,-1 )
  3900   0^1
  3901   "KRN",8989 .51,652,0)
  3902   VPR LOCATI ONS^VPR Lo cations^1^ Clinic^Syn cronized
  3903   "KRN",8989 .51,652,1)
  3904   Y
  3905   "KRN",8989 .51,652,6)
  3906   P^44^Enter  clinic to  synch wit h VPR
  3907   "KRN",8989 .51,652,30 ,0)
  3908   ^8989.513I ^1^1
  3909   "KRN",8989 .51,652,30 ,1,0)
  3910   5^4
  3911   "KRN",8989 .51,656,-1 )
  3912   0^3
  3913   "KRN",8989 .51,656,0)
  3914   VPR PARAME TERS^VPR S YSTEM PARA METERS^1^S ystem Para meters^Sys tem Parame ters Name
  3915   "KRN",8989 .51,656,1)
  3916   W
  3917   "KRN",8989 .51,656,6)
  3918   F
  3919   "KRN",8989 .51,656,20 ,0)
  3920   ^8989.512^ 2^2^312012 5^^^
  3921   "KRN",8989 .51,656,20 ,1,0)
  3922   This param eter store s a list o f paramete rs used by  the VPR m iddle teir  
  3923   "KRN",8989 .51,656,20 ,2,0)
  3924   and the VP R UI.
  3925   "KRN",8989 .51,656,30 ,0)
  3926   ^8989.513I ^2^2
  3927   "KRN",8989 .51,656,30 ,1,0)
  3928   6^4.2
  3929   "KRN",8989 .51,656,30 ,2,0)
  3930   1^200
  3931   "KRN",8989 .51,740,-1 )
  3932   0^4
  3933   "KRN",8989 .51,740,0)
  3934   VPR CPRS P ATH^CPRS L ocation^0
  3935   "KRN",8989 .51,740,1)
  3936   F
  3937   "KRN",8989 .51,740,6)
  3938   F
  3939   "KRN",8989 .51,740,30 ,0)
  3940   ^8989.513I ^2^2
  3941   "KRN",8989 .51,740,30 ,1,0)
  3942   4^4.2
  3943   "KRN",8989 .51,740,30 ,2,0)
  3944   1^200
  3945   "KRN",8994 ,815,-1)
  3946   0^22
  3947   "KRN",8994 ,815,0)
  3948   VPR GET RE FERENCE DA TA^GET^VPR EF^4^S^^^0 ^1^^1
  3949   "KRN",8994 ,815,1,0)
  3950   ^^2^2^3131 105
  3951   "KRN",8994 ,815,1,1,0 )
  3952   This RPC r etrieves t he request ed data fr om VistA,  and return s it in
  3953   "KRN",8994 ,815,1,2,0 )
  3954   ^TMP("VPR" ,$J,n) as  JSON.
  3955   "KRN",8994 ,815,2,0)
  3956   ^8994.02A^ 1^1
  3957   "KRN",8994 ,815,2,1,0 )
  3958   FILTER^2^^ 0^1
  3959   "KRN",8994 ,815,2,1,1 ,0)
  3960   ^^1^1^3131 105
  3961   "KRN",8994 ,815,2,1,1 ,1,0)
  3962   List of na me-value p airs defin ing the se arch.
  3963   "KRN",8994 ,815,2,"B" ,"FILTER", 1)
  3964  
  3965   "KRN",8994 ,815,2,"PA RAMSEQ",1, 1)
  3966  
  3967   "KRN",8994 ,815,3,0)
  3968   ^^1^1^3131 105
  3969   "KRN",8994 ,815,3,1,0 )
  3970   Text array  formatted  as JSON
  3971   "KRN",8994 ,818,-1)
  3972   0^26
  3973   "KRN",8994 ,818,0)
  3974   VPR PUT DE MOGRAPHICS ^PUT^VPRUP D^4^S^^^0^ 1^^1
  3975   "KRN",8994 ,818,1,0)
  3976   ^8994.01^2 ^2^3131119 ^^
  3977   "KRN",8994 ,818,1,1,0 )
  3978   This RPC r eceives up dated phon e numbers  from the c lient and  calls
  3979   "KRN",8994 ,818,1,2,0 )
  3980   VAFCPTED t o save the m in the P atient fil e #2.
  3981   "KRN",8994 ,818,2,0)
  3982   ^8994.02A^ 3^3
  3983   "KRN",8994 ,818,2,1,0 )
  3984   OBJECT^3^^ ^3
  3985   "KRN",8994 ,818,2,1,1 ,0)
  3986   ^8994.021^ 1^1^313112 0^^^
  3987   "KRN",8994 ,818,2,1,1 ,1,0)
  3988   The data,  as a JSON  object
  3989   "KRN",8994 ,818,2,2,0 )
  3990   COMMAND^1^ ^^2
  3991   "KRN",8994 ,818,2,2,1 ,0)
  3992   ^8994.021^ 1^1^313112 0^^
  3993   "KRN",8994 ,818,2,2,1 ,1,0)
  3994   The action  to take o n the obje ct in Vist A
  3995   "KRN",8994 ,818,2,3,0 )
  3996   PATIENT^1^ ^^1
  3997   "KRN",8994 ,818,2,3,1 ,0)
  3998   ^^1^1^3131 120^
  3999   "KRN",8994 ,818,2,3,1 ,1,0)
  4000   Patient fi le #2 ien
  4001   "KRN",8994 ,818,2,"B" ,"COMMAND" ,2)
  4002  
  4003   "KRN",8994 ,818,2,"B" ,"OBJECT", 1)
  4004  
  4005   "KRN",8994 ,818,2,"B" ,"PATIENT" ,3)
  4006  
  4007   "KRN",8994 ,818,2,"PA RAMSEQ",1, 3)
  4008  
  4009   "KRN",8994 ,818,2,"PA RAMSEQ",2, 2)
  4010  
  4011   "KRN",8994 ,818,2,"PA RAMSEQ",3, 1)
  4012  
  4013   "KRN",8994 ,818,3,0)
  4014   ^8994.03^1 ^1^3131120 ^^^^
  4015   "KRN",8994 ,818,3,1,0 )
  4016   Text array  formatted  as JSON
  4017   "KRN",8994 ,821,-1)
  4018   0^25
  4019   "KRN",8994 ,821,0)
  4020   VPRCRPC RP CCHAIN^CHA INRPC^VPRC RPC^3^P^0^ ^0^1^^1
  4021   "KRN",8994 ,821,2,0)
  4022   ^8994.02A^ 1^1
  4023   "KRN",8994 ,821,2,1,0 )
  4024   PARAMS^2^3 2000^1^1
  4025   "KRN",8994 ,821,2,"B" ,"PARAMS", 1)
  4026  
  4027   "KRN",8994 ,821,2,"PA RAMSEQ",1, 1)
  4028  
  4029   "KRN",8994 ,839,-1)
  4030   0^3
  4031   "KRN",8994 ,839,0)
  4032   VPR SUBSCR IBE^SUBS^V PRPATS^4^S ^^^1^^^1
  4033   "KRN",8994 ,839,1,0)
  4034   ^8994.01^3 ^3^3130417 ^^^^
  4035   "KRN",8994 ,839,1,1,0 )
  4036   This RPC w ill mainta in a list  of patient s & events  to monito r for new  data.
  4037   "KRN",8994 ,839,1,2,0 )
  4038   The LIST o f patients  passed in to this RP C is retur ned in ^TM P($J,"VPR" ,n)
  4039   "KRN",8994 ,839,1,3,0 )
  4040   as XML, wi th a subsc ription st atus of 'o n', 'off',  or 'error '.
  4041   "KRN",8994 ,839,2,0)
  4042   ^8994.02A^ 3^3
  4043   "KRN",8994 ,839,2,1,0 )
  4044   SYS^1^^0^1
  4045   "KRN",8994 ,839,2,1,1 ,0)
  4046   ^8994.021^ 3^3^313041 7^^^^
  4047   "KRN",8994 ,839,2,1,1 ,1,0)
  4048   This is th e name of  the system  calling t he RPC; it  is used t o create
  4049   "KRN",8994 ,839,2,1,1 ,2,0)
  4050   an entry i n the VPR  SUBSCRIPTI ON file, a nd link a  system to  a list of
  4051   "KRN",8994 ,839,2,1,1 ,3,0)
  4052   patients a nd/or even ts.
  4053   "KRN",8994 ,839,2,2,0 )
  4054   LIST^2^^0^ 3
  4055   "KRN",8994 ,839,2,2,1 ,0)
  4056   ^8994.021^ 2^2^311031 0^^^
  4057   "KRN",8994 ,839,2,2,1 ,1,0)
  4058   This is th e list of  patient id entifiers,  in the fo rm 'dfn;ic n', that
  4059   "KRN",8994 ,839,2,2,1 ,2,0)
  4060   are to be  either add ed to or r emoved fro m the moni tor.
  4061   "KRN",8994 ,839,2,3,0 )
  4062   STS^1^^0^2
  4063   "KRN",8994 ,839,2,3,1 ,0)
  4064   ^^2^2^3110 310^
  4065   "KRN",8994 ,839,2,3,1 ,1,0)
  4066   This is a  boolean va lue, 1 or  0, indicat ing if the  patient s hould be
  4067   "KRN",8994 ,839,2,3,1 ,2,0)
  4068   added to o r removed  from the d ata monito r.
  4069   "KRN",8994 ,839,2,"B" ,"LIST",2)
  4070  
  4071   "KRN",8994 ,839,2,"B" ,"STS",3)
  4072  
  4073   "KRN",8994 ,839,2,"B" ,"SYS",1)
  4074  
  4075   "KRN",8994 ,839,2,"PA RAMSEQ",1, 1)
  4076  
  4077   "KRN",8994 ,839,2,"PA RAMSEQ",2, 3)
  4078  
  4079   "KRN",8994 ,839,2,"PA RAMSEQ",3, 2)
  4080  
  4081   "KRN",8994 ,839,3,0)
  4082   ^8994.03^1 ^1^3130417 ^^^^
  4083   "KRN",8994 ,839,3,1,0 )
  4084   Text array  formatted  as XML.
  4085   "KRN",8994 ,846,-1)
  4086   0^1
  4087   "KRN",8994 ,846,0)
  4088   VPR APPOIN TMENTS^OUT ^VPRPATS^4 ^S^^^1^^^1
  4089   "KRN",8994 ,846,1,0)
  4090   ^8994.01^2 ^2^3101129 ^^
  4091   "KRN",8994 ,846,1,1,0 )
  4092   This RPC f inds a lis t of patie nts that h ave schedu led appoin tments dur ing
  4093   "KRN",8994 ,846,1,2,0 )
  4094   the reques ted timefr ame, as XM L in ^TMP( $J,"VPR",n ).
  4095   "KRN",8994 ,846,2,0)
  4096   ^8994.02A^ 2^2
  4097   "KRN",8994 ,846,2,1,0 )
  4098   START^1^20 ^0^1
  4099   "KRN",8994 ,846,2,1,1 ,0)
  4100   ^8994.021^ 2^2^310112 9^^^
  4101   "KRN",8994 ,846,2,1,1 ,1,0)
  4102   The date/t ime from w hich to be gin search ing for ap pointments ; optional ,
  4103   "KRN",8994 ,846,2,1,1 ,2,0)
  4104   will defau lt to tomo rrow if no t defined.
  4105   "KRN",8994 ,846,2,2,0 )
  4106   STOP^1^20^ 0^2
  4107   "KRN",8994 ,846,2,2,1 ,0)
  4108   ^8994.021^ 2^2^310112 9^^
  4109   "KRN",8994 ,846,2,2,1 ,1,0)
  4110   The date/t ime at whi ch to end  searching  for appoin tments; op tional,
  4111   "KRN",8994 ,846,2,2,1 ,2,0)
  4112   will defau lt to tomo rrow if no t defined.
  4113   "KRN",8994 ,846,2,"B" ,"START",1 )
  4114  
  4115   "KRN",8994 ,846,2,"B" ,"STOP",2)
  4116  
  4117   "KRN",8994 ,846,2,"PA RAMSEQ",1, 1)
  4118  
  4119   "KRN",8994 ,846,2,"PA RAMSEQ",2, 2)
  4120  
  4121   "KRN",8994 ,846,3,0)
  4122   ^8994.03^1 ^1^3101129 ^^
  4123   "KRN",8994 ,846,3,1,0 )
  4124   Text array  formatted  XML
  4125   "KRN",8994 ,848,-1)
  4126   0^2
  4127   "KRN",8994 ,848,0)
  4128   VPR INPATI ENTS^IN^VP RPATS^4^S^ ^^1^^^1
  4129   "KRN",8994 ,848,1,0)
  4130   ^8994.01^2 ^2^3101129 ^^^
  4131   "KRN",8994 ,848,1,1,0 )
  4132   This RPC f inds a lis t of patie nts that a re current ly admitte d,
  4133   "KRN",8994 ,848,1,2,0 )
  4134   as XML in  ^TMP($J,"V PR",n).
  4135   "KRN",8994 ,848,2,0)
  4136   ^8994.02A^ ^0
  4137   "KRN",8994 ,848,3,0)
  4138   ^8994.03^1 ^1^3101129 ^^^
  4139   "KRN",8994 ,848,3,1,0 )
  4140   Text array  formatted  XML
  4141   "KRN",8994 ,849,-1)
  4142   0^27
  4143   "KRN",8994 ,849,0)
  4144   VPRDJFS AP I^API^VPRD JFS^4^^^^0
  4145   "KRN",8994 ,1342,-1)
  4146   0^28
  4147   "KRN",8994 ,1342,0)
  4148   VPRDJFS DE LSUB^DELSU B^VPRDJFS^ 1^P^0
  4149   "KRN",8994 ,1345,-1)
  4150   0^4
  4151   "KRN",8994 ,1345,0)
  4152   VPRCORD RP C^RPC^VPRC ORD^3^^^^0
  4153   "KRN",8994 ,1345,2,0)
  4154   ^8994.02A^ 1^1
  4155   "KRN",8994 ,1345,2,1, 0)
  4156   PARAMS^2^^ 1^1
  4157   "KRN",8994 ,1345,2,"B ","PARAMS" ,1)
  4158  
  4159   "KRN",8994 ,1345,2,"P ARAMSEQ",1 ,1)
  4160  
  4161   "KRN",8994 ,1346,-1)
  4162   0^5
  4163   "KRN",8994 ,1346,0)
  4164   VPRCPAT RP C^RPC^VPRC PAT^4
  4165   "KRN",8994 ,1346,2,0)
  4166   ^8994.02A^ 1^1
  4167   "KRN",8994 ,1346,2,1, 0)
  4168   PARAMS^2^^ 1^1
  4169   "KRN",8994 ,1346,2,"B ","PARAMS" ,1)
  4170  
  4171   "KRN",8994 ,1346,2,"P ARAMSEQ",1 ,1)
  4172  
  4173   "KRN",8994 ,1347,-1)
  4174   0^9
  4175   "KRN",8994 ,1347,0)
  4176   VPR ROSTER  PATIENTS^ COMPILE^VP RROS2^4^P^ ^^1^1^^1
  4177   "KRN",8994 ,1347,1,0)
  4178   ^8994.01^1 ^1^3120105 ^^^^
  4179   "KRN",8994 ,1347,1,1, 0)
  4180   Provides p atients as sociated w ith reques ted Roster .
  4181   "KRN",8994 ,1347,2,0)
  4182   ^8994.02A^ 2^2
  4183   "KRN",8994 ,1347,2,1, 0)
  4184   ROSTER^1^1 5^0^1
  4185   "KRN",8994 ,1347,2,1, 1,0)
  4186   ^8994.021^ 1^1^312010 5^^^^
  4187   "KRN",8994 ,1347,2,1, 1,1,0)
  4188   IEN of Ros ter you ar e requesti ng patient s for.
  4189   "KRN",8994 ,1347,2,2, 0)
  4190   OWNER^1^15 ^0^2
  4191   "KRN",8994 ,1347,2,2, 1,0)
  4192   ^^1^1^3120 105^
  4193   "KRN",8994 ,1347,2,2, 1,1,0)
  4194   Compile al l rosters  for this o wner.
  4195   "KRN",8994 ,1347,2,"B ","OWNER", 2)
  4196  
  4197   "KRN",8994 ,1347,2,"B ","ROSTER" ,1)
  4198  
  4199   "KRN",8994 ,1347,2,"P ARAMSEQ",1 ,1)
  4200  
  4201   "KRN",8994 ,1347,2,"P ARAMSEQ",2 ,2)
  4202  
  4203   "KRN",8994 ,1347,3,0)
  4204   ^8994.03^1 ^1^3120105 ^^^^
  4205   "KRN",8994 ,1347,3,1, 0)
  4206   Text array  formated  XML.
  4207   "KRN",8994 ,1350,-1)
  4208   0^10
  4209   "KRN",8994 ,1350,0)
  4210   VPR ROSTER S^GETROS^V PRROS2^4^P ^^^1^1^^1
  4211   "KRN",8994 ,1350,1,0)
  4212   ^8994.01^1 ^1^3111110 ^^^^
  4213   "KRN",8994 ,1350,1,1, 0)
  4214   Creates XM L list of  all Roster s.
  4215   "KRN",8994 ,1350,2,0)
  4216   ^8994.02A^ 1^1
  4217   "KRN",8994 ,1350,2,1, 0)
  4218   VPRFILT^1^ 30^0^1
  4219   "KRN",8994 ,1350,2,1, 1,0)
  4220   ^8994.021^ 1^1^311111 0^^
  4221   "KRN",8994 ,1350,2,1, 1,1,0)
  4222   Filter ros ters if fi lter not n ull.
  4223   "KRN",8994 ,1350,2,"B ","VPRFILT ",1)
  4224  
  4225   "KRN",8994 ,1350,2,"P ARAMSEQ",1 ,1)
  4226  
  4227   "KRN",8994 ,1350,3,0)
  4228   ^8994.03^1 ^1^3111110 ^^^^
  4229   "KRN",8994 ,1350,3,1, 0)
  4230   Text array  formatted  in XML.
  4231   "KRN",8994 ,1351,-1)
  4232   0^12
  4233   "KRN",8994 ,1351,0)
  4234   VPR PREVIE W ROSTER^P REVIEW^VPR ROS3^4^P^^ ^1^1^^1
  4235   "KRN",8994 ,1351,1,0)
  4236   ^8994.01^1 ^1^3120131 ^^^^
  4237   "KRN",8994 ,1351,1,1, 0)
  4238   Compiles R oster base d on data  passed fro m GUI Inte rface.
  4239   "KRN",8994 ,1351,2,0)
  4240   ^8994.02A^ 1^1
  4241   "KRN",8994 ,1351,2,1, 0)
  4242   VPRARRAY^2 ^32000^1^1
  4243   "KRN",8994 ,1351,2,1, 1,0)
  4244   ^8994.021^ 1^1^311102 2^^^^
  4245   "KRN",8994 ,1351,2,1, 1,1,0)
  4246   Roster dat a from GUI .
  4247   "KRN",8994 ,1351,2,"B ","VPRARRA Y",1)
  4248  
  4249   "KRN",8994 ,1351,2,"P ARAMSEQ",1 ,1)
  4250  
  4251   "KRN",8994 ,1351,3,0)
  4252   ^8994.03^1 ^1^3111022 ^^^^
  4253   "KRN",8994 ,1351,3,1, 0)
  4254   XML format ted Roster .
  4255   "KRN",8994 ,1352,-1)
  4256   0^11
  4257   "KRN",8994 ,1352,0)
  4258   VPR UPDATE  ROSTER^UP DATE^VPRRO S3^4^P^^^1 ^1^^1
  4259   "KRN",8994 ,1352,1,0)
  4260   ^8994.01^1 ^1^3111031 ^^
  4261   "KRN",8994 ,1352,1,1, 0)
  4262   Udates ros ter data e ditted by  GUI into V istA.
  4263   "KRN",8994 ,1352,2,0)
  4264   ^8994.02A^ 1^1
  4265   "KRN",8994 ,1352,2,1, 0)
  4266   VPRARRAY^2 ^32000^1^1
  4267   "KRN",8994 ,1352,2,"B ","VPRARRA Y",1)
  4268  
  4269   "KRN",8994 ,1352,2,"P ARAMSEQ",1 ,1)
  4270  
  4271   "KRN",8994 ,1360,-1)
  4272   0^13
  4273   "KRN",8994 ,1360,0)
  4274   VPR GET SO URCE^GETSR C^VPRROS4^ 4^P^^^1^1^ ^1
  4275   "KRN",8994 ,1360,1,0)
  4276   ^8994.01^2 ^2^3111101 ^^
  4277   "KRN",8994 ,1360,1,1, 0)
  4278   Get all so urce infor mation for  requested  source.   For exampl e, Request  is for Cl inics.  Tr ansmit all  active cl inics
  4279   "KRN",8994 ,1360,1,2, 0)
  4280   include na me and ien .
  4281   "KRN",8994 ,1360,2,0)
  4282   ^8994.02A^ 2^2
  4283   "KRN",8994 ,1360,2,1, 0)
  4284   VPRSRC^1^3 0^1^1
  4285   "KRN",8994 ,1360,2,1, 1,0)
  4286   ^^1^1^3111 031^
  4287   "KRN",8994 ,1360,2,1, 1,1,0)
  4288   Identifies  which sou rce inform ation to s end to the  GUI.
  4289   "KRN",8994 ,1360,2,2, 0)
  4290   VPRFILT^1^ 30^0^2
  4291   "KRN",8994 ,1360,2,2, 1,0)
  4292   ^8994.021^ 1^1^311110 3^^
  4293   "KRN",8994 ,1360,2,2, 1,1,0)
  4294   Text ident ifying wha t you are  looking fo r.  Will b e used whe n matching  for detai ls.
  4295   "KRN",8994 ,1360,2,"B ","VPRFILT ",2)
  4296  
  4297   "KRN",8994 ,1360,2,"B ","VPRSRC" ,1)
  4298  
  4299   "KRN",8994 ,1360,2,"P ARAMSEQ",1 ,1)
  4300  
  4301   "KRN",8994 ,1360,2,"P ARAMSEQ",2 ,2)
  4302  
  4303   "KRN",8994 ,1360,3,0)
  4304   ^8994.03^1 ^1^3111101 ^^
  4305   "KRN",8994 ,1360,3,1, 0)
  4306   An array c ontaining  names and  ien's of s ource data .
  4307   "KRN",8994 ,1464,-1)
  4308   0^7
  4309   "KRN",8994 ,1464,0)
  4310   VPRFPTC CH KS^CHKS^VP RFPTC^3^^^ ^0
  4311   "KRN",8994 ,1464,1,0)
  4312   ^8994.01^2 ^2^3120629 ^^^
  4313   "KRN",8994 ,1464,1,1, 0)
  4314   This RPC r eturns the  patient s election c hecks for  a sensitiv e patient,  
  4315   "KRN",8994 ,1464,1,2, 0)
  4316   deceased,  and PRF.
  4317   "KRN",8994 ,1464,2,0)
  4318   ^8994.02A^ 1^1
  4319   "KRN",8994 ,1464,2,1, 0)
  4320   ICN^1^^1^1
  4321   "KRN",8994 ,1464,2,1, 1,0)
  4322   ^8994.021^ 1^1^312062 9^^
  4323   "KRN",8994 ,1464,2,1, 1,1,0)
  4324   This is th e patient  ICN
  4325   "KRN",8994 ,1464,2,"B ","ICN",1)
  4326  
  4327   "KRN",8994 ,1464,2,"P ARAMSEQ",1 ,1)
  4328  
  4329   "KRN",8994 ,1466,-1)
  4330   0^15
  4331   "KRN",8994 ,1466,0)
  4332   VPRCRPC RP C^RPC^VPRC RPC^3^^^^0
  4333   "KRN",8994 ,1466,1,0)
  4334   ^8994.01^2 ^2^3120515 ^^
  4335   "KRN",8994 ,1466,1,1, 0)
  4336   This RPC i s used to  save and g et data to /from the  VPR PARAME TERS in th
  4337   "KRN",8994 ,1466,1,2, 0)
  4338   parameter  file.
  4339   "KRN",8994 ,1466,2,0)
  4340   ^8994.02A^ 1^1
  4341   "KRN",8994 ,1466,2,1, 0)
  4342   PARAMS^2^^ 1^1
  4343   "KRN",8994 ,1466,2,"B ","PARAMS" ,1)
  4344  
  4345   "KRN",8994 ,1466,2,"P ARAMSEQ",1 ,1)
  4346  
  4347   "KRN",8994 ,1467,-1)
  4348   0^8
  4349   "KRN",8994 ,1467,0)
  4350   VPRFPTC LO G^LOG^VPRF PTC^3^^^^0
  4351   "KRN",8994 ,1467,1,0)
  4352   ^8994.01^2 ^2^3120124 ^
  4353   "KRN",8994 ,1467,1,1, 0)
  4354   This RPC i s used to  log a pati ent when a  provider  is accessi ng a 
  4355   "KRN",8994 ,1467,1,2, 0)
  4356   sensitive  record.
  4357   "KRN",8994 ,1467,2,0)
  4358   ^8994.02A^ 1^1
  4359   "KRN",8994 ,1467,2,1, 0)
  4360   ICN^1^^1^1
  4361   "KRN",8994 ,1467,2,"B ","ICN",1)
  4362  
  4363   "KRN",8994 ,1467,2,"P ARAMSEQ",1 ,1)
  4364  
  4365   "KRN",8994 ,1468,-1)
  4366   0^14
  4367   "KRN",8994 ,1468,0)
  4368   VPR DELETE  ROSTER^DE LROS^VPRRO S3^1^^^^^1 .2
  4369   "KRN",8994 ,1468,2,0)
  4370   ^8994.02A^ 1^1
  4371   "KRN",8994 ,1468,2,1, 0)
  4372   VPRIEN^1^1 00^1^1
  4373   "KRN",8994 ,1468,2,1, 1,0)
  4374   ^8994.021^ 1^1^313121 0^^
  4375   "KRN",8994 ,1468,2,1, 1,1,0)
  4376   Roster IEN .
  4377   "KRN",8994 ,1468,2,"B ","VPRIEN" ,1)
  4378  
  4379   "KRN",8994 ,1468,2,"P ARAMSEQ",1 ,1)
  4380  
  4381   "KRN",8994 ,2949,-1)
  4382   0^21
  4383   "KRN",8994 ,2949,0)
  4384   VPR PUT PA TIENT DATA ^PUT^VPRDJ 1^1^S^^^1^ 1^^1
  4385   "KRN",8994 ,2949,1,0)
  4386   ^8994.01^2 ^2^3121129 ^^^^
  4387   "KRN",8994 ,2949,1,1, 0)
  4388   This RPC r eceives da ta from th e client a nd saves i t in the V PR Patient
  4389   "KRN",8994 ,2949,1,2, 0)
  4390   Object fil e #560.1 a s JSON.
  4391   "KRN",8994 ,2949,2,0)
  4392   ^8994.02A^ 3^3
  4393   "KRN",8994 ,2949,2,1, 0)
  4394   DFN^1^20^1 ^1
  4395   "KRN",8994 ,2949,2,1, 1,0)
  4396   ^8994.021^ 2^2^312101 0^^^
  4397   "KRN",8994 ,2949,2,1, 1,1,0)
  4398   Internal e ntry numbe r from Pat ient file  #2
  4399   "KRN",8994 ,2949,2,1, 1,2,0)
  4400   [optionall y DFN;ICN  for remote  calls]
  4401   "KRN",8994 ,2949,2,2, 0)
  4402   TYPE^1^100 ^0^2
  4403   "KRN",8994 ,2949,2,2, 1,0)
  4404   ^8994.021^ 1^1^312101 0^^^^
  4405   "KRN",8994 ,2949,2,2, 1,1,0)
  4406   The kind o f data bei ng stored.
  4407   "KRN",8994 ,2949,2,3, 0)
  4408   OBJECT^3^^ 0^3
  4409   "KRN",8994 ,2949,2,3, 1,0)
  4410   ^8994.021^ 1^1^312112 9^^^^
  4411   "KRN",8994 ,2949,2,3, 1,1,0)
  4412   The conten t of the o bject, as  JSON
  4413   "KRN",8994 ,2949,2,"B ","DFN",1)
  4414  
  4415   "KRN",8994 ,2949,2,"B ","OBJECT" ,3)
  4416  
  4417   "KRN",8994 ,2949,2,"B ","TYPE",2 )
  4418  
  4419   "KRN",8994 ,2949,2,"P ARAMSEQ",1 ,1)
  4420  
  4421   "KRN",8994 ,2949,2,"P ARAMSEQ",2 ,2)
  4422  
  4423   "KRN",8994 ,2949,2,"P ARAMSEQ",3 ,3)
  4424  
  4425   "KRN",8994 ,2949,3,0)
  4426   ^8994.03^1 ^1^3121129 ^^^^
  4427   "KRN",8994 ,2949,3,1, 0)
  4428   Text array  formatted  as JSON
  4429   "KRN",8994 ,2950,-1)
  4430   0^20
  4431   "KRN",8994 ,2950,0)
  4432   VPR PUT OB JECT^PUT^V PRDJ2^1^S^ ^^1^1^^1
  4433   "KRN",8994 ,2950,1,0)
  4434   ^8994.01^2 ^2^3131216 ^^^^
  4435   "KRN",8994 ,2950,1,1, 0)
  4436   This RPC r eceives da ta from th e client a nd saves i t in the V PR Object
  4437   "KRN",8994 ,2950,1,2, 0)
  4438   file #560. 11 as JSON .
  4439   "KRN",8994 ,2950,2,0)
  4440   ^8994.02A^ 3^2
  4441   "KRN",8994 ,2950,2,2, 0)
  4442   TYPE^1^100 ^0^1
  4443   "KRN",8994 ,2950,2,2, 1,0)
  4444   ^8994.021^ 1^1^312112 9^^^^
  4445   "KRN",8994 ,2950,2,2, 1,1,0)
  4446   The kind o f data bei ng stored.
  4447   "KRN",8994 ,2950,2,3, 0)
  4448   OBJECT^3^^ 0^2
  4449   "KRN",8994 ,2950,2,3, 1,0)
  4450   ^8994.021^ 1^1^312112 9^^^^
  4451   "KRN",8994 ,2950,2,3, 1,1,0)
  4452   The conten t of the o bject, as  JSON
  4453   "KRN",8994 ,2950,2,"B ","OBJECT" ,3)
  4454  
  4455   "KRN",8994 ,2950,2,"B ","TYPE",2 )
  4456  
  4457   "KRN",8994 ,2950,2,"P ARAMSEQ",1 ,2)
  4458  
  4459   "KRN",8994 ,2950,2,"P ARAMSEQ",2 ,3)
  4460  
  4461   "KRN",8994 ,2950,3,0)
  4462   ^8994.03^1 ^1^3121129 ^^^^
  4463   "KRN",8994 ,2950,3,1, 0)
  4464   Text array  formatted  as JSON
  4465   "KRN",8994 ,2953,-1)
  4466   0^17
  4467   "KRN",8994 ,2953,0)
  4468   VPR GET OB JECT^GET^V PRDJ2^4^S^ ^^0^1^^1
  4469   "KRN",8994 ,2953,1,0)
  4470   ^8994.01^2 ^2^3121219 ^^^^
  4471   "KRN",8994 ,2953,1,1, 0)
  4472   This RPC r etrieves t he request ed data fr om VistA,  and return s it in
  4473   "KRN",8994 ,2953,1,2, 0)
  4474   ^TMP("VPR" ,$J,n) as  JSON.
  4475   "KRN",8994 ,2953,2,0)
  4476   ^8994.02A^ 1^1
  4477   "KRN",8994 ,2953,2,1, 0)
  4478   FILTER^2^^ 0^1
  4479   "KRN",8994 ,2953,2,1, 1,0)
  4480   ^8994.021^ 1^1^312121 9^^^^
  4481   "KRN",8994 ,2953,2,1, 1,1,0)
  4482   List of na me-value p airs defin ing the se arch.
  4483   "KRN",8994 ,2953,2,"B ","FILTER" ,1)
  4484  
  4485   "KRN",8994 ,2953,2,"P ARAMSEQ",1 ,1)
  4486  
  4487   "KRN",8994 ,2953,3,0)
  4488   ^8994.03^1 ^1^3121219 ^^^^
  4489   "KRN",8994 ,2953,3,1, 0)
  4490   Text array  formatted  as JSON
  4491   "KRN",8994 ,2954,-1)
  4492   0^16
  4493   "KRN",8994 ,2954,0)
  4494   VPR DELETE  OBJECT^DE L^VPRDJ2^1 ^S^^^1^1^^ 1
  4495   "KRN",8994 ,2954,1,0)
  4496   ^8994.01^2 ^2^3130103 ^^^^
  4497   "KRN",8994 ,2954,1,1, 0)
  4498   This RPC r eceives a  Uid from t he client  and delete s the obje ct from th e
  4499   "KRN",8994 ,2954,1,2, 0)
  4500   VPR Object  file #560 .11.
  4501   "KRN",8994 ,2954,2,0)
  4502   ^8994.02A^ 2^1
  4503   "KRN",8994 ,2954,2,2, 0)
  4504   UID^1^100^ 1^1
  4505   "KRN",8994 ,2954,2,2, 1,0)
  4506   ^8994.021^ 1^1^313010 3^^^^
  4507   "KRN",8994 ,2954,2,2, 1,1,0)
  4508   The Uid of  the objec t being de leted.
  4509   "KRN",8994 ,2954,2,"B ","UID",2)
  4510  
  4511   "KRN",8994 ,2954,2,"P ARAMSEQ",1 ,2)
  4512  
  4513   "KRN",8994 ,2954,3,0)
  4514   ^8994.03^1 ^1^3130103 ^^^^
  4515   "KRN",8994 ,2954,3,1, 0)
  4516   Text array  formatted  as JSON
  4517   "KRN",8994 ,2955,-1)
  4518   0^19
  4519   "KRN",8994 ,2955,0)
  4520   VPR GET RO STER LIST^ GET^VPRROS 7^4^S^^^^1 ^^1
  4521   "KRN",8994 ,2955,1,0)
  4522   ^8994.01^2 ^2^3130221 ^^
  4523   "KRN",8994 ,2955,1,1, 0)
  4524   Patient id entificati on data pa ssed in an d roster i dentificat ion return ed.
  4525   "KRN",8994 ,2955,1,2, 0)
  4526   List will  contain al l rosters  associated  with pati ent.
  4527   "KRN",8994 ,2955,2,0)
  4528   ^8994.02A^ 2^2
  4529   "KRN",8994 ,2955,2,1, 0)
  4530   VPR^2^3200 ^1^1
  4531   "KRN",8994 ,2955,2,2, 0)
  4532   VPRARRAY^2 ^3200^1^1
  4533   "KRN",8994 ,2955,2,"B ","VPR",1)
  4534  
  4535   "KRN",8994 ,2955,2,"B ","VPRARRA Y",2)
  4536  
  4537   "KRN",8994 ,2955,2,"P ARAMSEQ",1 ,1)
  4538  
  4539   "KRN",8994 ,2955,2,"P ARAMSEQ",1 ,2)
  4540  
  4541   "KRN",8994 ,2956,-1)
  4542   0^18
  4543   "KRN",8994 ,2956,0)
  4544   VPR GET OP ERATIONAL  DATA^GET^V PREF^4^S^^ ^0^1^^1
  4545   "KRN",8994 ,2956,1,0)
  4546   ^8994.01^2 ^2^3130507 ^^^^
  4547   "KRN",8994 ,2956,1,1, 0)
  4548   This RPC r etrieves t he request ed data fr om VistA,  and return s it in
  4549   "KRN",8994 ,2956,1,2, 0)
  4550   ^TMP("VPR" ,$J,n) as  JSON.
  4551   "KRN",8994 ,2956,2,0)
  4552   ^8994.02A^ 1^1
  4553   "KRN",8994 ,2956,2,1, 0)
  4554   FILTER^2^^ 0^1
  4555   "KRN",8994 ,2956,2,1, 1,0)
  4556   ^8994.021^ 1^1^313050 7^^^^
  4557   "KRN",8994 ,2956,2,1, 1,1,0)
  4558   List of na me-value p airs defin ing the se arch.
  4559   "KRN",8994 ,2956,2,"B ","FILTER" ,1)
  4560  
  4561   "KRN",8994 ,2956,2,"P ARAMSEQ",1 ,1)
  4562  
  4563   "KRN",8994 ,2956,3,0)
  4564   ^8994.03^1 ^1^3130507 ^^^^
  4565   "KRN",8994 ,2956,3,1, 0)
  4566   Text array  formatted  as JSON
  4567   "KRN",8994 ,2965,-1)
  4568   0^23
  4569   "KRN",8994 ,2965,0)
  4570   VPR SUBSCR IBE ROSTER S^SUBS^VPR ROS7^4^S^^ ^1^^^1
  4571   "KRN",8994 ,2965,1,0)
  4572   ^8994.01^3 ^3^3130417 ^^^^
  4573   "KRN",8994 ,2965,1,1, 0)
  4574   This RPC w ill mainta in a list  of rosters  to monito r for new  patients.
  4575   "KRN",8994 ,2965,1,2, 0)
  4576   The LIST o f rosters  passed int o this RPC  is return ed in ^TMP ($J,"VPR", n)
  4577   "KRN",8994 ,2965,1,3, 0)
  4578   as XML, wi th a subsc ription st atus of 'o n', 'off',  or 'error '.
  4579   "KRN",8994 ,2965,2,0)
  4580   ^8994.02A^ 3^3
  4581   "KRN",8994 ,2965,2,1, 0)
  4582   SYS^1^^0^1
  4583   "KRN",8994 ,2965,2,1, 1,0)
  4584   ^8994.021^ 3^3^313041 7^^^^
  4585   "KRN",8994 ,2965,2,1, 1,1,0)
  4586   This is th e name of  the system  calling t he RPC; it  is used t o create
  4587   "KRN",8994 ,2965,2,1, 1,2,0)
  4588   an entry i n the VPR  SUBSCRIPTI ON file, a nd link a  system to  a list of
  4589   "KRN",8994 ,2965,2,1, 1,3,0)
  4590   rosters.
  4591   "KRN",8994 ,2965,2,2, 0)
  4592   LIST^2^^0^ 3
  4593   "KRN",8994 ,2965,2,2, 1,0)
  4594   ^8994.021^ 2^2^313041 7^^^^
  4595   "KRN",8994 ,2965,2,2, 1,1,0)
  4596   This is th e list of  roster ide ntifiers t hat are to  be either  added to  or
  4597   "KRN",8994 ,2965,2,2, 1,2,0)
  4598   removed fr om the mon itor.
  4599   "KRN",8994 ,2965,2,3, 0)
  4600   STS^1^^0^2
  4601   "KRN",8994 ,2965,2,3, 1,0)
  4602   ^8994.021^ 2^2^313041 7^^
  4603   "KRN",8994 ,2965,2,3, 1,1,0)
  4604   This is a  boolean va lue, 1 or  0, indicat ing if the  roster sh ould be
  4605   "KRN",8994 ,2965,2,3, 1,2,0)
  4606   added to o r removed  from the d ata monito r.
  4607   "KRN",8994 ,2965,2,"B ","LIST",2 )
  4608  
  4609   "KRN",8994 ,2965,2,"B ","STS",3)
  4610  
  4611   "KRN",8994 ,2965,2,"B ","SYS",1)
  4612  
  4613   "KRN",8994 ,2965,2,"P ARAMSEQ",1 ,1)
  4614  
  4615   "KRN",8994 ,2965,2,"P ARAMSEQ",2 ,3)
  4616  
  4617   "KRN",8994 ,2965,2,"P ARAMSEQ",3 ,2)
  4618  
  4619   "KRN",8994 ,2965,3,0)
  4620   ^8994.03^1 ^1^3130417 ^^^^
  4621   "KRN",8994 ,2965,3,1, 0)
  4622   Text array  formatted  as XML.
  4623   "KRN",8994 ,2973,-1)
  4624   0^24
  4625   "KRN",8994 ,2973,0)
  4626   VPRCPRS RP C^RPC^VPRC PRS^3^^^^0
  4627   "KRN",8994 ,2973,2,0)
  4628   ^8994.02A^ 1^1
  4629   "KRN",8994 ,2973,2,1, 0)
  4630   PARAMS^2^^ 1^1
  4631   "KRN",8994 ,2973,2,"B ","PARAMS" ,1)
  4632  
  4633   "KRN",8994 ,2973,2,"P ARAMSEQ",1 ,1)
  4634  
  4635   "MBREQ")
  4636   1
  4637   "ORD",0,9. 8)
  4638   9.8;;1;RTN F^XPDTA;RT NE^XPDTA
  4639   "ORD",0,9. 8,0)
  4640   ROUTINE
  4641   "ORD",3,19 .1)
  4642   19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
  4643   "ORD",3,19 .1,0)
  4644   SECURITY K EY
  4645   "ORD",14,7 71)
  4646   771;14;;;H LAP^XPDTA1 ;HLAPF1^XP DIA1;HLAPE 1^XPDIA1;H LAPF2^XPDI A1;;HLAPDE L^XPDIA1(% )
  4647   "ORD",14,7 71,0)
  4648   HL7 APPLIC ATION PARA METER
  4649   "ORD",15,1 01)
  4650   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  4651   "ORD",15,1 01,0)
  4652   PROTOCOL
  4653   "ORD",16,8 994)
  4654   8994;16;1; ;;;;;;RPCD EL^XPDIA1
  4655   "ORD",16,8 994,0)
  4656   REMOTE PRO CEDURE
  4657   "ORD",18,1 9)
  4658   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  4659   "ORD",18,1 9,0)
  4660   OPTION
  4661   "ORD",20,8 989.51)
  4662   8989.51;20 ;;;PAR1E1^ XPDTA2;PAR 1F1^XPDIA3 ;PAR1E1^XP DIA3;PAR1F 2^XPDIA3;; PAR1DEL^XP DIA3(%)
  4663   "ORD",20,8 989.51,0)
  4664   PARAMETER  DEFINITION
  4665   "PKG",571, -1)
  4666   1^1
  4667   "PKG",571, 0)
  4668   VIRTUAL PA TIENT RECO RD^VPR^Uti lities to  manage a v irtual cop y of the p atient rec ord
  4669   "PKG",571, 20,0)
  4670   ^9.402P^^
  4671   "PKG",571, 22,0)
  4672   ^9.49I^1^1
  4673   "PKG",571, 22,1,0)
  4674   1.0^311080 4^3110525^ 1085
  4675   "PKG",571, 22,1,"PAH" ,1,0)
  4676   3^3140408^ 1085
  4677   "PKG",571, 22,1,"PAH" ,1,1,0)
  4678   ^^2^2^3140 408
  4679   "PKG",571, 22,1,"PAH" ,1,1,1,0)
  4680   The Virtua l Patient  Record (VP R) monitor s a VistA  system for  new data
  4681   "PKG",571, 22,1,"PAH" ,1,1,2,0)
  4682   and activi ty, and ma kes that d ata availa ble to a s ubscribing  client.
  4683   "QUES","XP F1",0)
  4684   Y
  4685   "QUES","XP F1","??")
  4686   ^D REP^XPD H
  4687   "QUES","XP F1","A")
  4688   Shall I wr ite over y our |FLAG|  File
  4689   "QUES","XP F1","B")
  4690   YES
  4691   "QUES","XP F1","M")
  4692   D XPF1^XPD IQ
  4693   "QUES","XP F2",0)
  4694   Y
  4695   "QUES","XP F2","??")
  4696   ^D DTA^XPD H
  4697   "QUES","XP F2","A")
  4698   Want my da ta |FLAG|  yours
  4699   "QUES","XP F2","B")
  4700   YES
  4701   "QUES","XP F2","M")
  4702   D XPF2^XPD IQ
  4703   "QUES","XP I1",0)
  4704   YO
  4705   "QUES","XP I1","??")
  4706   ^D INHIBIT ^XPDH
  4707   "QUES","XP I1","A")
  4708   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  4709   "QUES","XP I1","B")
  4710   NO
  4711   "QUES","XP I1","M")
  4712   D XPI1^XPD IQ
  4713   "QUES","XP M1",0)
  4714   PO^VA(200, :EM
  4715   "QUES","XP M1","??")
  4716   ^D MG^XPDH
  4717   "QUES","XP M1","A")
  4718   Enter the  Coordinato r for Mail  Group '|F LAG|'
  4719   "QUES","XP M1","B")
  4720  
  4721   "QUES","XP M1","M")
  4722   D XPM1^XPD IQ
  4723   "QUES","XP O1",0)
  4724   Y
  4725   "QUES","XP O1","??")
  4726   ^D MENU^XP DH
  4727   "QUES","XP O1","A")
  4728   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  4729   "QUES","XP O1","B")
  4730   NO
  4731   "QUES","XP O1","M")
  4732   D XPO1^XPD IQ
  4733   "QUES","XP Z1",0)
  4734   Y
  4735   "QUES","XP Z1","??")
  4736   ^D OPT^XPD H
  4737   "QUES","XP Z1","A")
  4738   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  4739   "QUES","XP Z1","B")
  4740   NO
  4741   "QUES","XP Z1","M")
  4742   D XPZ1^XPD IQ
  4743   "QUES","XP Z2",0)
  4744   Y
  4745   "QUES","XP Z2","??")
  4746   ^D RTN^XPD H
  4747   "QUES","XP Z2","A")
  4748   Want to MO VE routine s to other  CPUs
  4749   "QUES","XP Z2","B")
  4750   NO
  4751   "QUES","XP Z2","M")
  4752   D XPZ2^XPD IQ
  4753   "RTN")
  4754   72
  4755   "RTN","VPR CAC")
  4756   0^92^B9380 5364
  4757   "RTN","VPR CAC",1,0)
  4758   VPRCAC ;SL C/AGP-- VP R CAC Tool s
  4759   "RTN","VPR CAC",2,0)
  4760    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Feb  06, 2014;B uild 205
  4761   "RTN","VPR CAC",3,0)
  4762    ;
  4763   "RTN","VPR CAC",4,0)
  4764    Q
  4765   "RTN","VPR CAC",5,0)
  4766    ;
  4767   "RTN","VPR CAC",6,0)
  4768   ASK(YESNO, PROMPT)       ;
  4769   "RTN","VPR CAC",7,0)
  4770    N X,Y,TEX T
  4771   "RTN","VPR CAC",8,0)
  4772    K DIROUT, DIRUT,DTOU T,DUOUT
  4773   "RTN","VPR CAC",9,0)
  4774    S DIR(0)= "YA0"
  4775   "RTN","VPR CAC",10,0)
  4776    S DIR("A" )=PROMPT
  4777   "RTN","VPR CAC",11,0)
  4778    S DIR("B" )="N"
  4779   "RTN","VPR CAC",12,0)
  4780    S DIR("?" )="Enter Y  or N. For  detailed  help type  ??"
  4781   "RTN","VPR CAC",13,0)
  4782    ;S DIR("? ?")=U_"D H ELP^PXRMLC R("_NUM_") "
  4783   "RTN","VPR CAC",14,0)
  4784    W !
  4785   "RTN","VPR CAC",15,0)
  4786    D ^DIR K  DIR
  4787   "RTN","VPR CAC",16,0)
  4788    I $D(DIRO UT) S DTOU T=1
  4789   "RTN","VPR CAC",17,0)
  4790    I $D(DTOU T)!($D(DUO UT)) Q
  4791   "RTN","VPR CAC",18,0)
  4792    S YESNO=$ E(Y(0))
  4793   "RTN","VPR CAC",19,0)
  4794    Q
  4795   "RTN","VPR CAC",20,0)
  4796    ;
  4797   "RTN","VPR CAC",21,0)
  4798   ADDSVR() ;
  4799   "RTN","VPR CAC",22,0)
  4800    N DIC,DLA YGO,Y
  4801   "RTN","VPR CAC",23,0)
  4802    S DIC="^V PR(560,",D IC(0)="AEM QL",DIC("A ")="Select  HMP serve r instance : ",DLAYGO =560
  4803   "RTN","VPR CAC",24,0)
  4804    D ^DIC
  4805   "RTN","VPR CAC",25,0)
  4806    Q Y
  4807   "RTN","VPR CAC",26,0)
  4808    ;
  4809   "RTN","VPR CAC",27,0)
  4810   OPTASGN()  ;
  4811   "RTN","VPR CAC",28,0)
  4812    N ARGS,DI C,DLAYGO,F DA,HASOPT, IEN,LIST,M SG,OPTNAME ,PAT,RESUL T,SVR,VPRE RR,VPROPT, Y,YESNO
  4813   "RTN","VPR CAC",29,0)
  4814    S OPTNAME ="VPR UI C ONTEXT"
  4815   "RTN","VPR CAC",30,0)
  4816    S VPROPT= $$FIND1^DI C(19,"","B ",OPTNAME, ,,"MSG") I  VPROPT'>0  W !,"Erro r: Could n ot find 'V PR UI CONT EXT' optio n." Q
  4817   "RTN","VPR CAC",31,0)
  4818    ;
  4819   "RTN","VPR CAC",32,0)
  4820    S Y=$$ADD SVR() I +Y <0 Q
  4821   "RTN","VPR CAC",33,0)
  4822    S SVR=$P( $G(^VPR(56 0,+Y,0)),U )
  4823   "RTN","VPR CAC",34,0)
  4824    ;
  4825   "RTN","VPR CAC",35,0)
  4826    K DLAYGO
  4827   "RTN","VPR CAC",36,0)
  4828    S DIC="^V A(200,",DI C(0)="AEMQ ",DIC("A") ="Select u ser to pro vide acces s to HMP:  "
  4829   "RTN","VPR CAC",37,0)
  4830    D ^DIC
  4831   "RTN","VPR CAC",38,0)
  4832    I +Y<0 Q
  4833   "RTN","VPR CAC",39,0)
  4834    S IEN=+Y
  4835   "RTN","VPR CAC",40,0)
  4836    ;
  4837   "RTN","VPR CAC",41,0)
  4838    S HASOPT= $$ACCESS^X QCHK(IEN,V PROPT)
  4839   "RTN","VPR CAC",42,0)
  4840    I +HASOPT >0 D  Q
  4841   "RTN","VPR CAC",43,0)
  4842    .W !,"Use r has 'VPR  UI CONTEX T' already  assigned. " D ASK(.Y ESNO,"Sync  user defa ult CPRS p atient lis t: ") I YE SNO'="Y" Q
  4843   "RTN","VPR CAC",44,0)
  4844    .I $G(YES NO)="Y" D  GETPATS(.R ESULT,IEN, SVR)
  4845   "RTN","VPR CAC",45,0)
  4846    ;
  4847   "RTN","VPR CAC",46,0)
  4848    K YESNO
  4849   "RTN","VPR CAC",47,0)
  4850    D ASK(.YE SNO,"Assig n 'VPR UI  CONTEXT':  ")
  4851   "RTN","VPR CAC",48,0)
  4852    I YESNO'= "Y" Q
  4853   "RTN","VPR CAC",49,0)
  4854    S FDA(200 .03,"+2,"_ IEN_",",.0 1)="VPR UI  CONTEXT"
  4855   "RTN","VPR CAC",50,0)
  4856    D UPDATE^ DIE("","FD A","","VPR ERR")
  4857   "RTN","VPR CAC",51,0)
  4858    I $D(VPRE RR) D  Q
  4859   "RTN","VPR CAC",52,0)
  4860    .D EN^DDI OL("Update  failed, U PDATE^DIE  returned t he followi ng error m essage.")
  4861   "RTN","VPR CAC",53,0)
  4862    .S IC="VP RERR"
  4863   "RTN","VPR CAC",54,0)
  4864    .F  S IC= $Q(@IC) Q: IC=""  W ! ,IC,"=",@I C
  4865   "RTN","VPR CAC",55,0)
  4866    D GETPATS (.RESULT,I EN,SVR)
  4867   "RTN","VPR CAC",56,0)
  4868    Q
  4869   "RTN","VPR CAC",57,0)
  4870    ;
  4871   "RTN","VPR CAC",58,0)
  4872   GETPATS(RE SULT,IEN,S RV) ;
  4873   "RTN","VPR CAC",59,0)
  4874    N ARGS,LI ST,PAT
  4875   "RTN","VPR CAC",60,0)
  4876    D GETDFLS T(.LIST,IE N)
  4877   "RTN","VPR CAC",61,0)
  4878    I '$D(LIS T) W !,"No  default p atient lis t found."  Q
  4879   "RTN","VPR CAC",62,0)
  4880    S ARGS("c ommand")=" putPtSubsc ription"
  4881   "RTN","VPR CAC",63,0)
  4882    S ARGS("s erver")=SR V
  4883   "RTN","VPR CAC",64,0)
  4884    S PAT=0 F   S PAT=$O (LIST(PAT) ) Q:PAT'>0   D
  4885   "RTN","VPR CAC",65,0)
  4886    .;check t o see if p atient is  already sy nc for the  server.
  4887   "RTN","VPR CAC",66,0)
  4888    .I $G(^VP R(560,"AIT EM",PAT,SR V))>0 W !, "Patient " _PAT_" alr eady synce d." Q
  4889   "RTN","VPR CAC",67,0)
  4890    .S ARGS(" localId")= PAT
  4891   "RTN","VPR CAC",68,0)
  4892    .W !,"Sta rting sync  on patien t: "_PAT
  4893   "RTN","VPR CAC",69,0)
  4894    .D API^VP RDJFS(.RES ULT,.ARGS)
  4895   "RTN","VPR CAC",70,0)
  4896    Q
  4897   "RTN","VPR CAC",71,0)
  4898    ;
  4899   "RTN","VPR CAC",72,0)
  4900    ;
  4901   "RTN","VPR CAC",73,0)
  4902   BLDLIST(LI ST,VPRY) ;
  4903   "RTN","VPR CAC",74,0)
  4904    N I,CNT,N ODE
  4905   "RTN","VPR CAC",75,0)
  4906    S I=0 F   S I=$O(VPR Y(I)) Q:I' >0  D
  4907   "RTN","VPR CAC",76,0)
  4908    .S NODE=$ G(VPRY(I))  I +NODE'> 0 Q
  4909   "RTN","VPR CAC",77,0)
  4910    .;S CNT=$ O(VPRY(I), -1)+1
  4911   "RTN","VPR CAC",78,0)
  4912    .S LIST(+ $P(NODE,U) )=""
  4913   "RTN","VPR CAC",79,0)
  4914    Q
  4915   "RTN","VPR CAC",80,0)
  4916    ;
  4917   "RTN","VPR CAC",81,0)
  4918    ;The appo intment li st date ra nge is des igned to q uery for f ull dates,  
  4919   "RTN","VPR CAC",82,0)
  4920    ;so when  the search  result ex ceeds 200  appointmen ts, 
  4921   "RTN","VPR CAC",83,0)
  4922    ;the disp lay will e nd with th e last app ointment o f the last  day befor e the maxi mum was re ached. 
  4923   "RTN","VPR CAC",84,0)
  4924   CLINPTS2(Y ,USER,CLIN ,BDATE,EDA TE) ; WRAP PER FUNCTI ON FOR USE  BY RPC CA LL ORQPT C LINIC PATI ENTS
  4925   "RTN","VPR CAC",85,0)
  4926    N MAXAPPT S,APPTBGN, APPTEND,NU MAPPTS
  4927   "RTN","VPR CAC",86,0)
  4928    S MAXAPPT S=200 I BD ATE=EDATE  S MAXAPPTS =0  ; if w e only wan t one day,  don't lim it answer.
  4929   "RTN","VPR CAC",87,0)
  4930    D CLINPTS (.Y,USER,C LIN,BDATE, EDATE,MAXA PPTS,.APPT BGN,.APPTE ND)
  4931   "RTN","VPR CAC",88,0)
  4932    S NUMAPPT S=$O(Y("") ,-1)
  4933   "RTN","VPR CAC",89,0)
  4934    I MAXAPPT S,NUMAPPTS '<MAXAPPTS  D
  4935   "RTN","VPR CAC",90,0)
  4936    . N ORI
  4937   "RTN","VPR CAC",91,0)
  4938    . S ORI=0  S APPTEND =$P(APPTEN D,".")
  4939   "RTN","VPR CAC",92,0)
  4940    . F  S OR I=$O(Y(ORI )) Q:'ORI   D  ;erase  last day' s appts si nce we ass ume it to  be partial
  4941   "RTN","VPR CAC",93,0)
  4942    .. I APPT END<$P(Y(O RI),U,4) K  Y(ORI) S  NUMAPPTS=N UMAPPTS-1  ;erase an  appointmen t
  4943   "RTN","VPR CAC",94,0)
  4944    . S Y(MAX APPTS+1)=" ^ *** UNAB LE TO SHOW  ALL APPOI NTMENTS ** *"
  4945   "RTN","VPR CAC",95,0)
  4946    . S Y(MAX APPTS+2)=" ^ Showing  the first  "_NUMAPPTS _" appoint ments from  "_$$FMTE^ XLFDT(APPT BGN,"D")_"  to "_$$FM TE^XLFDT(A PPTEND-1," D")
  4947   "RTN","VPR CAC",96,0)
  4948    . S Y(MAX APPTS+3)=" ^"_$C(160) _" Modify  the appoin tment list  date rang e to start  on "_$$FM TE^XLFDT(A PPTEND,"D" )_" to see  additiona l appointm ents." ;ad d blank li ne
  4949   "RTN","VPR CAC",97,0)
  4950    . S Y(MAX APPTS+4)=" ^"_$C(160) _$C(160) ; add blank  line
  4951   "RTN","VPR CAC",98,0)
  4952    ;
  4953   "RTN","VPR CAC",99,0)
  4954   CLINPTS(Y, USER,CLIN, BDATE,EDAT E,MAXAPPTS ,APPTBGN,A PPTEND) ;  RETURN LIS T OF PTS W /CLINIC AP PT W/IN BE GINNING AN D END DATE S
  4955   "RTN","VPR CAC",100,0 )
  4956    ; PKS-8/2 003: Modif ied for ne w scheduli ng pkg API s.
  4957   "RTN","VPR CAC",101,0 )
  4958    I +$G(CLI N)<1 S Y(1 )="^No cli nic identi fied" Q 
  4959   "RTN","VPR CAC",102,0 )
  4960    I $$ACTLO C^ORWU(CLI N)'=1 S Y( 1)="^Clini c is inact ive or Occ asion Of S ervice" Q
  4961   "RTN","VPR CAC",103,0 )
  4962    N ORSRV,O RRESULT,OR ERR,ORI,OR PT,ORPTSTA T,ORAPPT,O RCLIN,SDAR RAY,NODE
  4963   "RTN","VPR CAC",104,0 )
  4964    I $L($G(M AXAPPTS))= 0 S MAXAPP TS=200
  4965   "RTN","VPR CAC",105,0 )
  4966    S ORSRV=$ G(^VA(200, USER,5)) I  +ORSRV>0  S ORSRV=$P (ORSRV,U)
  4967   "RTN","VPR CAC",106,0 )
  4968    I BDATE=" " S BDATE= $$UP^XLFST R($$GET^XP AR("USR^SR V.`"_+$G(O RSRV)_"^DI V^SYS^PKG" ,"ORLP DEF AULT CLINI C START DA TE",1,"E") )
  4969   "RTN","VPR CAC",107,0 )
  4970    I EDATE=" " S EDATE= $$UP^XLFST R($$GET^XP AR("USR^SR V.`"_+$G(O RSRV)_"^DI V^SYS^PKG" ,"ORLP DEF AULT CLINI C STOP DAT E",1,"E"))
  4971   "RTN","VPR CAC",108,0 )
  4972    ;
  4973   "RTN","VPR CAC",109,0 )
  4974    ; Convert  BDATE, ED ATE to FM  Date/Time:
  4975   "RTN","VPR CAC",110,0 )
  4976    D DT^DILF ("T",BDATE ,.BDATE,"" ,"")
  4977   "RTN","VPR CAC",111,0 )
  4978    D DT^DILF ("T",EDATE ,.EDATE,"" ,"")
  4979   "RTN","VPR CAC",112,0 )
  4980    I (BDATE= -1)!(EDATE =-1) S Y(1 )="^Error  in date ra nge." Q 
  4981   "RTN","VPR CAC",113,0 )
  4982    S EDATE=$ P(EDATE,". ")_.5 ; Ad d 1/2 day  to end dat e.
  4983   "RTN","VPR CAC",114,0 )
  4984    ;
  4985   "RTN","VPR CAC",115,0 )
  4986    K ^TMP($J ,"SDAMA301 ") ; Clean  house bef ore starti ng.
  4987   "RTN","VPR CAC",116,0 )
  4988    S ORRESUL T=""
  4989   "RTN","VPR CAC",117,0 )
  4990    S ORCLIN= +CLIN
  4991   "RTN","VPR CAC",118,0 )
  4992    S SDARRAY (1)=BDATE_ ";"_EDATE
  4993   "RTN","VPR CAC",119,0 )
  4994    S SDARRAY (2)=+CLIN
  4995   "RTN","VPR CAC",120,0 )
  4996    S SDARRAY (3)="R;I;N T"
  4997   "RTN","VPR CAC",121,0 )
  4998    S SDARRAY ("SORT")=" P" ;no cli nic index
  4999   "RTN","VPR CAC",122,0 )
  5000    S SDARRAY ("FLDS")=" 3;4"  ;App tStatus^IE N;PtName
  5001   "RTN","VPR CAC",123,0 )
  5002    I MAXAPPT S S SDARRA Y("MAX")=M AXAPPTS
  5003   "RTN","VPR CAC",124,0 )
  5004    ;
  5005   "RTN","VPR CAC",125,0 )
  5006    S ORRESUL T=$$SDAPI^ SDAMA301(. SDARRAY) ;  DBIA 4433
  5007   "RTN","VPR CAC",126,0 )
  5008    ;
  5009   "RTN","VPR CAC",127,0 )
  5010    ; Deal wi th server  errors:
  5011   "RTN","VPR CAC",128,0 )
  5012    I ORRESUL T<0 D  S Y (1)=U_ORER R Q
  5013   "RTN","VPR CAC",129,0 )
  5014    .S ORERR= ""
  5015   "RTN","VPR CAC",130,0 )
  5016    .N IDXERR  S IDXERR= $O(^TMP($J ,"SDAMA301 ","")) Q:I DXERR'>0
  5017   "RTN","VPR CAC",131,0 )
  5018    .S ORERR= ^TMP($J,"S DAMA301",I DXERR)
  5019   "RTN","VPR CAC",132,0 )
  5020    ;
  5021   "RTN","VPR CAC",133,0 )
  5022    ; Reassig n ^TMP arr ay to loca l array:
  5023   "RTN","VPR CAC",134,0 )
  5024    S (ORPT,O RI)=0
  5025   "RTN","VPR CAC",135,0 )
  5026    I ORRESUL T'>0 S Y(1 )="^No app ointments. " Q
  5027   "RTN","VPR CAC",136,0 )
  5028    F  S ORPT =$O(^TMP($ J,"SDAMA30 1",ORPT))  Q:ORPT=""   D
  5029   "RTN","VPR CAC",137,0 )
  5030    .S ORAPPT =""
  5031   "RTN","VPR CAC",138,0 )
  5032    .F  S ORA PPT=$O(^TM P($J,"SDAM A301",ORPT ,ORAPPT))  Q:ORAPPT=" "  D
  5033   "RTN","VPR CAC",139,0 )
  5034    ..S ORI=O RI+1
  5035   "RTN","VPR CAC",140,0 )
  5036    ..S NODE= ^TMP($J,"S DAMA301",O RPT,ORAPPT )
  5037   "RTN","VPR CAC",141,0 )
  5038    ..S Y(ORI )=$TR($P(N ODE,U,4)," ;","^") ;  IEN^Name.
  5039   "RTN","VPR CAC",142,0 )
  5040    ..S Y(ORI )=Y(ORI)_U _ORCLIN ;  ^Clinic IE N.
  5041   "RTN","VPR CAC",143,0 )
  5042    ..S Y(ORI )=Y(ORI)_U _ORAPPT ;  App't.
  5043   "RTN","VPR CAC",144,0 )
  5044    ..I $L($G (APPTEND)) =0 S APPTE ND=ORAPPT, APPTBGN=OR APPT
  5045   "RTN","VPR CAC",145,0 )
  5046    ..I ORAPP T>APPTEND  S APPTEND= ORAPPT
  5047   "RTN","VPR CAC",146,0 )
  5048    ..I ORAPP T<APPTBGN  S APPTBGN= ORAPPT
  5049   "RTN","VPR CAC",147,0 )
  5050    ..S ORPTS TAT=$P($P( NODE,U,3), ";",1) ;ap pt status,  will be t ransformed  to pt sta tus.
  5051   "RTN","VPR CAC",148,0 )
  5052    ..S ORPTS TAT=$S(ORP TSTAT="I": "IPT",ORPT STAT="R":" OPT",ORPTS TAT="NT":" OPT",1:"")  ; Pt Stat us.
  5053   "RTN","VPR CAC",149,0 )
  5054    ..S Y(ORI )=Y(ORI)_U _U_U_U_U_O RPTSTAT ;  Pt I or O  status (or  "NT").
  5055   "RTN","VPR CAC",150,0 )
  5056    K ^TMP($J ,"SDAMA301 ") ; Clean  house aft er finishi ng.
  5057   "RTN","VPR CAC",151,0 )
  5058    ;
  5059   "RTN","VPR CAC",152,0 )
  5060    Q
  5061   "RTN","VPR CAC",153,0 )
  5062    ;
  5063   "RTN","VPR CAC",154,0 )
  5064   COMBPTS(LI ST,USER,PT R,BDATE,ED ATE) ;
  5065   "RTN","VPR CAC",155,0 )
  5066    N FILE,MA XAPPTS,MSG ,PTR,RTN,S RC,TXT,VPR ERR,VPRY
  5067   "RTN","VPR CAC",156,0 )
  5068    ;
  5069   "RTN","VPR CAC",157,0 )
  5070    ; Do prel iminary se ttings, cl eanup, loo k for an e xisting us er record:
  5071   "RTN","VPR CAC",158,0 )
  5072    S MSG=""                                           ;  Default.
  5073   "RTN","VPR CAC",159,0 )
  5074    S MAXAPPT S=$S(BDATE =EDATE:0,1 :200)          ; If d ate range  is only on e day then  no max, o therwise 2 00
  5075   "RTN","VPR CAC",160,0 )
  5076    S RTN=$$F IND1^DIC(1 00.24,""," QX",USER," ","","VPRE RR")
  5077   "RTN","VPR CAC",161,0 )
  5078    K VPRERR
  5079   "RTN","VPR CAC",162,0 )
  5080    D CLEAN^D ILF ; Clea n up after  DB call.
  5081   "RTN","VPR CAC",163,0 )
  5082    ;
  5083   "RTN","VPR CAC",164,0 )
  5084    ; If no c ombination  record, t hen punt:
  5085   "RTN","VPR CAC",165,0 )
  5086    I +RTN<1  D
  5087   "RTN","VPR CAC",166,0 )
  5088    .S MSG="N o combinat ion entry. "
  5089   "RTN","VPR CAC",167,0 )
  5090    .Q
  5091   "RTN","VPR CAC",168,0 )
  5092    ;
  5093   "RTN","VPR CAC",169,0 )
  5094    ; Order t hrough the  user's co mbination  source ent ries:
  5095   "RTN","VPR CAC",170,0 )
  5096    S SORT="A " ; Requir ed variabl e for PTSC OMBO^ORQPT Q5.
  5097   "RTN","VPR CAC",171,0 )
  5098    S SRC=0
  5099   "RTN","VPR CAC",172,0 )
  5100    F  S SRC= $O(^OR(100 .24,RTN,.0 1,SRC)) Q: 'SRC  D
  5101   "RTN","VPR CAC",173,0 )
  5102    .K ORY                                             ;  Clean up e ach time.
  5103   "RTN","VPR CAC",174,0 )
  5104    .S TXT=""                                       ; Ini tialize.
  5105   "RTN","VPR CAC",175,0 )
  5106    .S TXT=$G (^OR(100.2 4,RTN,.01, SRC,0))  ;  Get recor d's value.
  5107   "RTN","VPR CAC",176,0 )
  5108    .;
  5109   "RTN","VPR CAC",177,0 )
  5110    .; In cas e of error , punt:
  5111   "RTN","VPR CAC",178,0 )
  5112    .I TXT=""  S MSG="Co mbination  source ent ry error."
  5113   "RTN","VPR CAC",179,0 )
  5114    .I TXT=""  Q
  5115   "RTN","VPR CAC",180,0 )
  5116    .S PTR=$P (TXT,";")                          ; Get po inter.
  5117   "RTN","VPR CAC",181,0 )
  5118    .S FILE=" ^"_$P(TXT, ";",2)                  ; Get fi le.
  5119   "RTN","VPR CAC",182,0 )
  5120    .;
  5121   "RTN","VPR CAC",183,0 )
  5122    .; Get in fo for eac h source e ntry and b uild VPRY  array acco rdingly.
  5123   "RTN","VPR CAC",184,0 )
  5124    .I FILE=" ^DIC(42,"  D  Q                       ; War ds.
  5125   "RTN","VPR CAC",185,0 )
  5126    ..D WARDP TS^ORQPTQ2 (.VPRY,PTR )
  5127   "RTN","VPR CAC",186,0 )
  5128    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  5129   "RTN","VPR CAC",187,0 )
  5130    .I FILE=" ^VA(200,"  D  Q                       ; Pro viders.
  5131   "RTN","VPR CAC",188,0 )
  5132    ..D PROVP TS^ORQPTQ2 (.VPRY,PTR )
  5133   "RTN","VPR CAC",189,0 )
  5134    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  5135   "RTN","VPR CAC",190,0 )
  5136    .I FILE=" ^DIC(45.7, " D  Q                     ; Spe cialties.
  5137   "RTN","VPR CAC",191,0 )
  5138    ..D SPECP TS^ORQPTQ2 (.VPRY,PTR )
  5139   "RTN","VPR CAC",192,0 )
  5140    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  5141   "RTN","VPR CAC",193,0 )
  5142    .I FILE=" ^OR(100.21 ," D  Q                    ; Tea m Lists
  5143   "RTN","VPR CAC",194,0 )
  5144    ..D TEAMP TS^ORQPTQ1 (.VPRY,PTR )
  5145   "RTN","VPR CAC",195,0 )
  5146    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  5147   "RTN","VPR CAC",196,0 )
  5148    .I FILE=" ^SC(" D  Q                            ; Cli nics.
  5149   "RTN","VPR CAC",197,0 )
  5150    ..N APPTB GN,APPTEND  S (APPTBG N,APPTEND) =""
  5151   "RTN","VPR CAC",198,0 )
  5152    ..D CLINP TS^ORQPTQ2 (.VPRY,PTR ,BDATE,EDA TE,MAXAPPT S,.APPTBGN ,.APPTEND)
  5153   "RTN","VPR CAC",199,0 )
  5154    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  5155   "RTN","VPR CAC",200,0 )
  5156    Q
  5157   "RTN","VPR CAC",201,0 )
  5158    ;
  5159   "RTN","VPR CAC",202,0 )
  5160   GETDFLST(L IST,USER)  ;
  5161   "RTN","VPR CAC",203,0 )
  5162    N API,BEG ,END,IEN,S RC,SRV,VPR SRC,VPRY,X
  5163   "RTN","VPR CAC",204,0 )
  5164    S SRV=$G( ^VA(200,US ER,5)) I + SRV>0 S SR V=$P(SRV,U )
  5165   "RTN","VPR CAC",205,0 )
  5166    S SRC=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT LIST SO URCE",1,"Q ")
  5167   "RTN","VPR CAC",206,0 )
  5168    ;
  5169   "RTN","VPR CAC",207,0 )
  5170    I SRC="T"  S IEN=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT TEAM",1 ,"Q") D:+$ G(IEN)>0 T EAMPTS^ORQ PTQ1(.VPRY ,IEN)
  5171   "RTN","VPR CAC",208,0 )
  5172    I SRC="W"  S IEN=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT WARD",1 ,"Q") D:+$ G(IEN)>0 B YWARD^ORWP T(.VPRY,IE N)
  5173   "RTN","VPR CAC",209,0 )
  5174    I SRC="P"  S IEN=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT PROVIDE R",1,"Q")  D:+$G(IEN) >0 PROVPTS ^ORQPTQ2(. VPRY,IEN)
  5175   "RTN","VPR CAC",210,0 )
  5176    I SRC="S"  S IEN=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT SPECIAL TY",1,"Q")  D:+$G(IEN )>0 SPECPT S^ORQPTQ2( .VPRY,IEN)
  5177   "RTN","VPR CAC",211,0 )
  5178    I SRC'="C ",SRC'="M"  D BLDLIST (.LIST,.VP RY) Q
  5179   "RTN","VPR CAC",212,0 )
  5180    ;
  5181   "RTN","VPR CAC",213,0 )
  5182     I SRC="C " D  Q
  5183   "RTN","VPR CAC",214,0 )
  5184    .F X="Mon day","Tues day","Wedn esday","Th ursday","F riday","Sa turday","S unday" D
  5185   "RTN","VPR CAC",215,0 )
  5186    ..S API=" ORLP DEFAU LT CLINIC  "_$$UP^XLF STR($$DOW^ XLFDT(DT)) ,IEN=$$GET ^XPAR("USR .`"_USER_" ^SRV.`"_+$ G(SRV),API ,1,"Q") I  +$G(IEN)>0  D
  5187   "RTN","VPR CAC",216,0 )
  5188    ...S BEG= $$UP^XLFST R($$GET^XP AR("USR.`" _USER_"^SR V.`"_+$G(S RV)_"^DIV^ SYS^PKG"," ORLP DEFAU LT CLINIC  START DATE ",1,"E"))
  5189   "RTN","VPR CAC",217,0 )
  5190    ...I BEG= "T+0" S BE G=$$FMTE^X LFDT(DT,BE G)
  5191   "RTN","VPR CAC",218,0 )
  5192    ...S END= $$UP^XLFST R($$GET^XP AR("USR.`" _USER_"^SR V.`"_+$G(S RV)_"^DIV^ SYS^PKG"," ORLP DEFAU LT CLINIC  STOP DATE" ,1,"E"))
  5193   "RTN","VPR CAC",219,0 )
  5194    ...I END= "T+0" S EN D=$$FMTE^X LFDT(DT,EN D)
  5195   "RTN","VPR CAC",220,0 )
  5196    ...D CLIN PTS2(.VPRY ,USER,+$G( IEN),BEG,E ND)
  5197   "RTN","VPR CAC",221,0 )
  5198    ...D BLDL IST(.LIST, .VPRY)
  5199   "RTN","VPR CAC",222,0 )
  5200    I SRC="M"  D  Q
  5201   "RTN","VPR CAC",223,0 )
  5202    .S IEN=$D (^OR(100.2 4,USER,0))  I +$G(IEN )>0 S IEN= USER D
  5203   "RTN","VPR CAC",224,0 )
  5204    ..S BEG=$ $UP^XLFSTR ($$GET^XPA R("USR.`"_ USER_"^SRV .`"_+$G(SR V)_"^DIV^S YS^PKG","O RLP DEFAUL T CLINIC S TART DATE" ,1,"E"))
  5205   "RTN","VPR CAC",225,0 )
  5206    ..I BEG=" T+0" S BEG =$$FMTE^XL FDT(DT,BEG )
  5207   "RTN","VPR CAC",226,0 )
  5208    ..S END=$ $UP^XLFSTR ($$GET^XPA R("USR.`"_ USER_"^SRV .`"_+$G(SR V)_"^DIV^S YS^PKG","O RLP DEFAUL T CLINIC S TOP DATE", 1,"E"))
  5209   "RTN","VPR CAC",227,0 )
  5210    ..I END=" T+0" S END =$$FMTE^XL FDT(DT,END )
  5211   "RTN","VPR CAC",228,0 )
  5212    ..D COMBP TS(.LIST,U SER,+$G(IE N),BEG,END ) ; "0"= G UI RPC cal l.
  5213   "RTN","VPR CAC",229,0 )
  5214    Q
  5215   "RTN","VPR CAC",230,0 )
  5216    ;
  5217   "RTN","VPR CAC",231,0 )
  5218   REMOPT(IEN ,OPT) ;
  5219   "RTN","VPR CAC",232,0 )
  5220    Q
  5221   "RTN","VPR CAC",233,0 )
  5222    ;
  5223   "RTN","VPR CORD")
  5224   0^6^B74542 30
  5225   "RTN","VPR CORD",1,0)
  5226   VPRCORD ;S LC/AGP - O rdering Co ntroller f or VPR ; 9 /21/12 5:5 7pm
  5227   "RTN","VPR CORD",2,0)
  5228    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  5229   "RTN","VPR CORD",3,0)
  5230    ;
  5231   "RTN","VPR CORD",4,0)
  5232    ;
  5233   "RTN","VPR CORD",5,0)
  5234   RPC(VPROUT ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  5235   "RTN","VPR CORD",6,0)
  5236    N X,REQ,V PRCNT,VPRS ITE,VPRUSE R,VPRDBUG, VPRSTA
  5237   "RTN","VPR CORD",7,0)
  5238    S VPRCNT= 0
  5239   "RTN","VPR CORD",8,0)
  5240    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2))
  5241   "RTN","VPR CORD",9,0)
  5242    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  S R EQ(X,1)=PA RAMS(X)
  5243   "RTN","VPR CORD",10,0 )
  5244    ;
  5245   "RTN","VPR CORD",11,0 )
  5246   COMMON ; C ome here f or both CS P and RPC  Mode
  5247   "RTN","VPR CORD",12,0 )
  5248    ;
  5249   "RTN","VPR CORD",13,0 )
  5250    N CMD
  5251   "RTN","VPR CORD",14,0 )
  5252    S CMD=$G( REQ("comma nd",1))
  5253   "RTN","VPR CORD",15,0 )
  5254    ;
  5255   "RTN","VPR CORD",16,0 )
  5256    ; returns  an order  structure  for change  orders
  5257   "RTN","VPR CORD",17,0 )
  5258    ; or plac es an orde r if auto- accept QO
  5259   "RTN","VPR CORD",18,0 )
  5260    I CMD="or dering" D   G OUT
  5261   "RTN","VPR CORD",19,0 )
  5262    . D ORDER ING^VPRCOR D1(.VPROUT ,$$VAL("ui d"),$$VAL( "qoIen"),$ $VAL("pati ent"),$$VA L("locatio n"),$$VAL( "provider" ),$$VAL("o rderAction "),0,$$VAL ("snippet" ),$$VAL("n ame"))
  5263   "RTN","VPR CORD",20,0 )
  5264    ;
  5265   "RTN","VPR CORD",21,0 )
  5266    ;
  5267   "RTN","VPR CORD",22,0 )
  5268    I CMD="li stQuickOrd ers" D  G  OUT
  5269   "RTN","VPR CORD",23,0 )
  5270    . D QOL^V PRCORD1(.V PROUT,$$VA L("locatio n"),$$VAL( "provider" ),$$VAL("p anelNumber "),$$VAL(" patient"))
  5271   "RTN","VPR CORD",24,0 )
  5272    ;
  5273   "RTN","VPR CORD",25,0 )
  5274    I CMD="re newOrder"  D  G OUT
  5275   "RTN","VPR CORD",26,0 )
  5276    . D RENEW ^VPRCORD1( .VPROUT,$$ VAL("uid") ,$$VAL("pr ovider"),0 ,$$VAL("sn ippet"),$$ VAL("name" ))
  5277   "RTN","VPR CORD",27,0 )
  5278    ;
  5279   "RTN","VPR CORD",28,0 )
  5280    I CMD="dc ReasonsLis t" D  G OU T
  5281   "RTN","VPR CORD",29,0 )
  5282    . D DCLRE AS^VPRCORD 1(.VPROUT, $$VAL("uid "),$$VAL(" provider") )
  5283   "RTN","VPR CORD",30,0 )
  5284    ;
  5285   "RTN","VPR CORD",31,0 )
  5286    I CMD="di scontinue"  D  G OUT
  5287   "RTN","VPR CORD",32,0 )
  5288    . D DC^VP RCORD1(.VP ROUT,$$VAL ("uid"),$$ VAL("provi der"),$$VA L("locatio n"),$$VAL( "patient") ,$$VAL("sn ippet"),$$ VAL("name" ))
  5289   "RTN","VPR CORD",33,0 )
  5290    ;
  5291   "RTN","VPR CORD",34,0 )
  5292    I CMD="ca ncel" D  G  OUT
  5293   "RTN","VPR CORD",35,0 )
  5294    . D CANCE L^VPRCORD1 (.VPROUT,$ $VAL("uid" ))
  5295   "RTN","VPR CORD",36,0 )
  5296    ;
  5297   "RTN","VPR CORD",37,0 )
  5298    I CMD="pe rformOrder Checks" D   G OUT
  5299   "RTN","VPR CORD",38,0 )
  5300    . D ORDER ING^VPRCOR D1(.VPROUT ,$$VAL("ui d"),$$VAL( "qoIen"),$ $VAL("pati ent"),$$VA L("locatio n"),$$VAL( "provider" ),$$VAL("o rderAction "),1)
  5301   "RTN","VPR CORD",39,0 )
  5302    ;
  5303   "RTN","VPR CORD",40,0 )
  5304    I CMD="ge tSnippets"  D  G OUT
  5305   "RTN","VPR CORD",41,0 )
  5306    .D GETSNI PS^VPRCORD 1(.VPROUT, $$VAL("pat ient"),$$V AL("provid er"))
  5307   "RTN","VPR CORD",42,0 )
  5308    ;
  5309   "RTN","VPR CORD",43,0 )
  5310    I CMD="sa veOrder" D   G OUT
  5311   "RTN","VPR CORD",44,0 )
  5312    .M ^XTMP( "AGP INFO" ,"PARAMS") =PARAMS
  5313   "RTN","VPR CORD",45,0 )
  5314    .D EN^VPR CORD3(.VPR OUT,.PARAM S)
  5315   "RTN","VPR CORD",46,0 )
  5316    ;
  5317   "RTN","VPR CORD",47,0 )
  5318    I CMD="or derAction"  D  G OUT
  5319   "RTN","VPR CORD",48,0 )
  5320    .N INFO
  5321   "RTN","VPR CORD",49,0 )
  5322    .;M ^XTMP ("AGP PARA MS")=REQ
  5323   "RTN","VPR CORD",50,0 )
  5324    .D BLDINF O(.INFO)
  5325   "RTN","VPR CORD",51,0 )
  5326    .D ORDERU ID^VPRCORD 1(.VPROUT, .INFO)
  5327   "RTN","VPR CORD",52,0 )
  5328    ;
  5329   "RTN","VPR CORD",53,0 )
  5330   OUT ;
  5331   "RTN","VPR CORD",54,0 )
  5332   END ;
  5333   "RTN","VPR CORD",55,0 )
  5334    ;
  5335   "RTN","VPR CORD",56,0 )
  5336   BLDINFO(IN FO) ;
  5337   "RTN","VPR CORD",57,0 )
  5338    N X
  5339   "RTN","VPR CORD",58,0 )
  5340    S X="" F   S X=$O(RE Q(X)) Q:X= ""  D
  5341   "RTN","VPR CORD",59,0 )
  5342    .S INFO(X )=REQ(X,1)
  5343   "RTN","VPR CORD",60,0 )
  5344    Q
  5345   "RTN","VPR CORD",61,0 )
  5346    ;
  5347   "RTN","VPR CORD",62,0 )
  5348   VAL(X) ; r eturn valu e from req uest
  5349   "RTN","VPR CORD",63,0 )
  5350    Q $G(REQ( X,1))
  5351   "RTN","VPR CORD",64,0 )
  5352    ;
  5353   "RTN","VPR CORD1")
  5354   0^7^B19597 6562
  5355   "RTN","VPR CORD1",1,0 )
  5356   VPRCORD1 ;  SLC/AGP,J LC - Proce ss Order R equest fro m AVIVA Sy stem. ; 9/ 21/12 5:59 pm
  5357   "RTN","VPR CORD1",2,0 )
  5358    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  5359   "RTN","VPR CORD1",3,0 )
  5360    Q
  5361   "RTN","VPR CORD1",4,0 )
  5362    ;
  5363   "RTN","VPR CORD1",5,0 )
  5364   ADD(X,VPRV ALUE) ; Ad d a line @ NHIN@(n)=X
  5365   "RTN","VPR CORD1",6,0 )
  5366    N RESULT
  5367   "RTN","VPR CORD1",7,0 )
  5368    S RESULT( "success") ="false"
  5369   "RTN","VPR CORD1",8,0 )
  5370    S RESULT( "error")=X
  5371   "RTN","VPR CORD1",9,0 )
  5372    D ENCODE^ VPRJSON("R ESULT","VP RVALUE","V PRERR")
  5373   "RTN","VPR CORD1",10, 0)
  5374    Q
  5375   "RTN","VPR CORD1",11, 0)
  5376    ;
  5377   "RTN","VPR CORD1",12, 0)
  5378   AE(TEXT,VP RVALUE) ;
  5379   "RTN","VPR CORD1",13, 0)
  5380    ;N RESULT
  5381   "RTN","VPR CORD1",14, 0)
  5382    ;S RESULT ("success" )="false"
  5383   "RTN","VPR CORD1",15, 0)
  5384    ;S RESULT ("error")= TEXT
  5385   "RTN","VPR CORD1",16, 0)
  5386    ;D ENCODE ^VPRJSON(" RESULT","V PRVALUE"," VPRERR")
  5387   "RTN","VPR CORD1",17, 0)
  5388    N DATA,TX T
  5389   "RTN","VPR CORD1",18, 0)
  5390    S TXT(1)= TEXT
  5391   "RTN","VPR CORD1",19, 0)
  5392    D SETERRO R^VPRUTILS (.VPRVALUE ,.TXT,.TXT ,.DATA)
  5393   "RTN","VPR CORD1",20, 0)
  5394    Q
  5395   "RTN","VPR CORD1",21, 0)
  5396    ;
  5397   "RTN","VPR CORD1",22, 0)
  5398   AEM(TEXT,V PRVALUE) ;
  5399   "RTN","VPR CORD1",23, 0)
  5400    ;N NUM,RE SULT
  5401   "RTN","VPR CORD1",24, 0)
  5402    ;S RESULT ("success" )="false"
  5403   "RTN","VPR CORD1",25, 0)
  5404    ;S NUM=0  F  S NUM=$ O(TEXT(NUM )) Q:NUM'> 0  D
  5405   "RTN","VPR CORD1",26, 0)
  5406    ;.I $G(RE SULT("erro r"))="" S  RESULT("er ror")=TEXT (NUM)
  5407   "RTN","VPR CORD1",27, 0)
  5408    ;.S RESUL T("error") =RESULT("e rror")_$C( 13,10)_TEX T(NUM)
  5409   "RTN","VPR CORD1",28, 0)
  5410    ;D ENCODE ^VPRJSON(" RESULT","V PRVALUE"," VPRERR")
  5411   "RTN","VPR CORD1",29, 0)
  5412    N DATA
  5413   "RTN","VPR CORD1",30, 0)
  5414    D SETERRO R^VPRUTILS (.VPRVALUE ,.TEXT,.TE XT,.DATA)
  5415   "RTN","VPR CORD1",31, 0)
  5416    Q
  5417   "RTN","VPR CORD1",32, 0)
  5418    ;
  5419   "RTN","VPR CORD1",33, 0)
  5420   CANCEL(UID ) ;
  5421   "RTN","VPR CORD1",34, 0)
  5422    N VPRERAR R,VPRERCNT ,VPRRES,VP RISORD,VPR OIFN,VPROK ,VPRPOSS
  5423   "RTN","VPR CORD1",35, 0)
  5424    S VPRERCN T=0,VPROUT =0
  5425   "RTN","VPR CORD1",36, 0)
  5426    I UID'["o rderID" D  AE("UID do es not con tain an or der ID") G  EXIT
  5427   "RTN","VPR CORD1",37, 0)
  5428    S DFN=$P( UID,":",5) ,VPROIFN=$ P(UID,"D", 2),VPRISOR D=1
  5429   "RTN","VPR CORD1",38, 0)
  5430    G UNO
  5431   "RTN","VPR CORD1",39, 0)
  5432    Q
  5433   "RTN","VPR CORD1",40, 0)
  5434    ;
  5435   "RTN","VPR CORD1",41, 0)
  5436    ;DC(VPRVA LUE,UID,US ER,LOC,ICN ,REAS,NAME ) ;
  5437   "RTN","VPR CORD1",42, 0)
  5438   DC(VPRVALU E,DFN,ID,U SER,LOC,RE AS,NAME) ;
  5439   "RTN","VPR CORD1",43, 0)
  5440    N RESULT, VPRDIEN,VP RERCNT,VPR FILL,VPRIS ORD,VPROK, VPRRES
  5441   "RTN","VPR CORD1",44, 0)
  5442    S VPRISOR D=1
  5443   "RTN","VPR CORD1",45, 0)
  5444    ;I $$VALI DUID(UID)= 0  D AE("U ID is not  valid UID" ,.VPRVALUE ) G DCX
  5445   "RTN","VPR CORD1",46, 0)
  5446    ;S DFN=$P (UID,":",5 )
  5447   "RTN","VPR CORD1",47, 0)
  5448    S VPROIFN =ID
  5449   "RTN","VPR CORD1",48, 0)
  5450    S VPRDIEN =+$P($G(^O R(100,VPRO IFN,0)),U, 5)
  5451   "RTN","VPR CORD1",49, 0)
  5452    D FILLID^ ORWDXC(.VP RFILL,VPRD IEN)
  5453   "RTN","VPR CORD1",50, 0)
  5454    D DC^ORWD XA(.VPRRES ,VPROIFN,U SER,LOC,RE AS,0,0)
  5455   "RTN","VPR CORD1",51, 0)
  5456    ;D UNO
  5457   "RTN","VPR CORD1",52, 0)
  5458    D KILLALR T^VPRCORD2 (DFN,VPRFI LL)
  5459   "RTN","VPR CORD1",53, 0)
  5460    I $D(VPRV ALUE)>0 G  DCX
  5461   "RTN","VPR CORD1",54, 0)
  5462    S REAS="D iscontinue  "_NAME_"  "_REAS
  5463   "RTN","VPR CORD1",55, 0)
  5464    D BLDJSON ^VPRCORD2( .VPRVALUE, .RESULT,.V PRPOSS,.VP RVALUE,$G( REAS),UID)
  5465   "RTN","VPR CORD1",56, 0)
  5466   DCX ;
  5467   "RTN","VPR CORD1",57, 0)
  5468    Q
  5469   "RTN","VPR CORD1",58, 0)
  5470    ;
  5471   "RTN","VPR CORD1",59, 0)
  5472    ;D DCLREA S(.VPRVALU E,DFN,ID,O RPROV)
  5473   "RTN","VPR CORD1",60, 0)
  5474   DCLREAS(RE SULT,DFN,V PROIFN,USE R) ;
  5475   "RTN","VPR CORD1",61, 0)
  5476    N CNT,NOD E,NUM,VPRH SKEY,VPRER ARR,VPRISO RD,VPROARR Y,VPROUT,V PRRES,VPRP OSS
  5477   "RTN","VPR CORD1",62, 0)
  5478    S VPRERCN T=0,VPROUT =0,VPRISOR D=1
  5479   "RTN","VPR CORD1",63, 0)
  5480    K VPROUT  D OFCPLX^O RWDXA(.VPR OUT,VPROIF N) I $D(VP ROUT)>0 S  RESULT("co mplexOrder ")="true"
  5481   "RTN","VPR CORD1",64, 0)
  5482    K VPROUT  D DCREN^OR WDX1(.VPRO UT,VPROIFN ) I $D(VPR OUT) S RES ULT("pendi ngRenewal" )="true"
  5483   "RTN","VPR CORD1",65, 0)
  5484    K VPROUT  D DCREASON ^ORWDX2(.V PROUT) I $ D(VPROUT)  D
  5485   "RTN","VPR CORD1",66, 0)
  5486    .S CNT=1, NUM=1 F  S  CNT=$O(VP ROUT(CNT))  Q:CNT'>0   D
  5487   "RTN","VPR CORD1",67, 0)
  5488    ..S NODE= $E(VPROUT( CNT),2,$L( VPROUT(CNT )))
  5489   "RTN","VPR CORD1",68, 0)
  5490    ..S RESUL T("lists", NUM,"value ")=$P(NODE ,U,2),RESU LT("lists" ,NUM,"id") =$P(NODE,U ),NUM=NUM+ 1
  5491   "RTN","VPR CORD1",69, 0)
  5492    Q
  5493   "RTN","VPR CORD1",70, 0)
  5494    ;
  5495   "RTN","VPR CORD1",71, 0)
  5496   EN(IEN,DFN ,LOC,USER, RSPID,ORDT YPE,CHKONL Y,VARSARR, ORDIALOG,E RRARR,VPRP OSS,RESULT ,VPRVALUE)  ;
  5497   "RTN","VPR CORD1",72, 0)
  5498    N CHECKS, CNT,DEFDLF ,DLGDEF,DL GNAME,DIEN ,DRUG,EXT, FILLER,INS T,ISCLOZ,I NT,NUM
  5499   "RTN","VPR CORD1",73, 0)
  5500    N ODIEN,O RDCHKOT,OR DERCHK,SAV EARR,STR,T EMP,TEXT
  5501   "RTN","VPR CORD1",74, 0)
  5502    I ORDTYPE ="E" S DIE N=+$P($G(^ OR(100,IEN ,0)),U,5)
  5503   "RTN","VPR CORD1",75, 0)
  5504    I ORDTYPE ="Q" S DIE N=IEN
  5505   "RTN","VPR CORD1",76, 0)
  5506    S VARSARR ("DISPLAY  GROUP IEN" )=$P($G(^O RD(101.41, $$DEFDLG^O RCD(DIEN), 0)),U,5)
  5507   "RTN","VPR CORD1",77, 0)
  5508    S VARSARR ("DISPLAY  GROUP")=$P ($G(^ORD(1 01.98,VARS ARR("DISPL AY GROUP I EN"),0)),U )
  5509   "RTN","VPR CORD1",78, 0)
  5510    D FILLID^ ORWDXC(.FI LLER,DIEN)
  5511   "RTN","VPR CORD1",79, 0)
  5512    S VARSARR ("FILLER I D")=FILLER
  5513   "RTN","VPR CORD1",80, 0)
  5514    K ^TMP($J ,"ORDER CH ECKS")
  5515   "RTN","VPR CORD1",81, 0)
  5516    I $$GET^X PAR("DIV^S YS^PKG","O RK SYSTEM  ENABLE/DIS ABLE")="E"  D
  5517   "RTN","VPR CORD1",82, 0)
  5518    .D DISPLA Y^ORWDXC(. CHECKS,DUZ ,VARSARR(" FILLER ID" )) I $D(CH ECKS) D IN FO^VPRCORD 2(.CHECKS)
  5519   "RTN","VPR CORD1",83, 0)
  5520    S DLGNAME =$P($G(^OR D(101.41,D IEN,0)),U)
  5521   "RTN","VPR CORD1",84, 0)
  5522    I ORDTYPE ="Q" S DLG NAME=$P($G (^ORD(101. 41,ORDIALO G,0)),U)
  5523   "RTN","VPR CORD1",85, 0)
  5524    I DLGNAME ="" D AE(" INVALID DE FAULT DIAL OG",.VPRVA LUE) G ENX
  5525   "RTN","VPR CORD1",86, 0)
  5526    S VARSARR ("DIALOG N AME")=DLGN AME
  5527   "RTN","VPR CORD1",87, 0)
  5528    D DLGDEF^ ORWDX(.DLG DEF,DLGNAM E)
  5529   "RTN","VPR CORD1",88, 0)
  5530    ;build or der check  array,buil d dialog s tructure a nd build s ave array
  5531   "RTN","VPR CORD1",89, 0)
  5532    D BLDARRS ^VPRCORD2( .RESULT,.O RDIALOG,.V ARSARR,DFN ,LOC,.ORDE RCHK,.SAVE ARR,.VPRPO SS)
  5533   "RTN","VPR CORD1",90, 0)
  5534    D ACCEPT^ ORWDXC(.OR DCHKOT,DFN ,VARSARR(" FILLER ID" ),"",LOC,. ORDERCHK," ",0) D INF O^VPRCORD2 (.ORDCHKOT )
  5535   "RTN","VPR CORD1",91, 0)
  5536    I CHKONLY =1 Q
  5537   "RTN","VPR CORD1",92, 0)
  5538    S SAVEARR ("ORCHECK" )=0,SAVEAR R("ORTS")= 0
  5539   "RTN","VPR CORD1",93, 0)
  5540    I ORDTYPE ="Q"!(ACTI ON="C") D  SAVE(.RESU LT,DFN,USE R,LOC,VARS ARR("DIALO G NAME"),V ARSARR("DI SPLAY GROU P IEN"),DI EN,0,.SAVE ARR)
  5541   "RTN","VPR CORD1",94, 0)
  5542   ENX ;
  5543   "RTN","VPR CORD1",95, 0)
  5544    Q
  5545   "RTN","VPR CORD1",96, 0)
  5546    ;
  5547   "RTN","VPR CORD1",97, 0)
  5548   GETSNIPS(V PRVALUE,IC N,USER) ;
  5549   "RTN","VPR CORD1",98, 0)
  5550    N CNT,DFN ,RESULT
  5551   "RTN","VPR CORD1",99, 0)
  5552    I +$G(DFN )'>0 S DFN =$$GETDFN^ MPIF001(IC N)
  5553   "RTN","VPR CORD1",100 ,0)
  5554    S CNT=0 F   S CNT=$O (^XTMP("VP R SNIPPET" ,DFN,USER, DT,CNT)) Q :CNT'>0  D
  5555   "RTN","VPR CORD1",101 ,0)
  5556    .I $G(RES ULT("text" ))'="" S R ESULT=$G(R ESULT("tex t"))_$C(13 ,10)_$G(^X TMP("VPR S NIPPET",DF N,USER,DT, CNT,"text" )) Q
  5557   "RTN","VPR CORD1",102 ,0)
  5558    .S RESULT ("text")=$ G(^XTMP("V PR SNIPPET ",DFN,USER ,DT,CNT,"t ext"))
  5559   "RTN","VPR CORD1",103 ,0)
  5560    S RESULT( "success") =$S($D(RES ULT):"true ",1:"false ")
  5561   "RTN","VPR CORD1",104 ,0)
  5562    D ENCODE^ VPRJSON("R ESULT","VP RVALUE","E RROR")
  5563   "RTN","VPR CORD1",105 ,0)
  5564    Q
  5565   "RTN","VPR CORD1",106 ,0)
  5566    ;
  5567   "RTN","VPR CORD1",107 ,0)
  5568   GETEXT(NAM E,VALUE) ;
  5569   "RTN","VPR CORD1",108 ,0)
  5570    N RESULT
  5571   "RTN","VPR CORD1",109 ,0)
  5572    I NAME="O RDERABLE"  Q $P(^ORD( 101.43,VAL UE,0),U)
  5573   "RTN","VPR CORD1",110 ,0)
  5574    I NAME="U RGENCY" Q  $P(^ORD(10 1.42,VALUE ,0),U)
  5575   "RTN","VPR CORD1",111 ,0)
  5576    I NAME="R OUTE" Q $$ GET1^DIQ(5 1.2,+VALUE _",",.01)
  5577   "RTN","VPR CORD1",112 ,0)
  5578    I NAME="D RUG" Q $$G ET1^DIQ(50 ,+VALUE_", ",.01)
  5579   "RTN","VPR CORD1",113 ,0)
  5580    Q VALUE
  5581   "RTN","VPR CORD1",114 ,0)
  5582    ;
  5583   "RTN","VPR CORD1",115 ,0)
  5584    ;entry po int for RP C for QO a nd editing  an existi ng order
  5585   "RTN","VPR CORD1",116 ,0)
  5586    ;ORDERING (.OUT,"",1 5833,10103 ,240,1089, "",1,"")
  5587   "RTN","VPR CORD1",117 ,0)
  5588   ORDERING(V PRVALUE,UI D,QIEN,ICN ,LOC,USER, ACTION,CHK ONLY,REAS, NAME,VPRPO SS) ;
  5589   "RTN","VPR CORD1",118 ,0)
  5590    N DFN,FAI L,ORDTYPE, RESULT,TEM P,VPRERCNT ,VPRISORD, VPROIFN
  5591   "RTN","VPR CORD1",119 ,0)
  5592    N VARSARR ,VPRERARR, VPRRES,VPR BLT
  5593   "RTN","VPR CORD1",120 ,0)
  5594    S VPRBLT= 0
  5595   "RTN","VPR CORD1",121 ,0)
  5596    K ^TMP($J ,"ORDER CH ECKS")
  5597   "RTN","VPR CORD1",122 ,0)
  5598    S VPRERCN T=0,VPRISO RD=0
  5599   "RTN","VPR CORD1",123 ,0)
  5600    S FAIL=0
  5601   "RTN","VPR CORD1",124 ,0)
  5602    I $L($G(U ID))>0 D
  5603   "RTN","VPR CORD1",125 ,0)
  5604    . ;I UID' ["orderID"  D AE("UID  does not  contain an  order ID" ) S FAIL=1
  5605   "RTN","VPR CORD1",126 ,0)
  5606    . S VPROI FN=$P(UID, ":",6)
  5607   "RTN","VPR CORD1",127 ,0)
  5608    I ACTION= "R" D RENE W(UID,USER ,ICN,CHKON LY) Q:VPRB LT=1  G OR DERUNO
  5609   "RTN","VPR CORD1",128 ,0)
  5610    I FAIL=1  G EXIT
  5611   "RTN","VPR CORD1",129 ,0)
  5612    I +$G(DFN )'>0 S DFN =$$GETDFN^ MPIF001(IC N) I DFN'> 0 D AE("Ca nnot find  patient df n from ICN ") G EXIT
  5613   "RTN","VPR CORD1",130 ,0)
  5614    ;I QIEN>0  S VPROIFN =QIEN
  5615   "RTN","VPR CORD1",131 ,0)
  5616    I QIEN>0  D QOSET(QI EN,ACTION, DFN,CHKONL Y,.RESULT, .VPRVALUE)
  5617   "RTN","VPR CORD1",132 ,0)
  5618    I +QIEN=0  D PROCESS (VPROIFN,A CTION,CHKO NLY,.RESUL T,.VPRVALU E)
  5619   "RTN","VPR CORD1",133 ,0)
  5620    I CHKONLY =1 Q
  5621   "RTN","VPR CORD1",134 ,0)
  5622    S TEMP=RE AS
  5623   "RTN","VPR CORD1",135 ,0)
  5624    I QIEN>0  D
  5625   "RTN","VPR CORD1",136 ,0)
  5626    .S NAME=" quick orde r "_$P($G( ^ORD(101.4 1,QIEN,0)) ,U,2)
  5627   "RTN","VPR CORD1",137 ,0)
  5628    .S REAS=" Place "_"q o"_" "_TEM P
  5629   "RTN","VPR CORD1",138 ,0)
  5630    I ACTION= "C" S REAS ="Copy "_N AME_" "_TE MP
  5631   "RTN","VPR CORD1",139 ,0)
  5632   ORDERUNO ;
  5633   "RTN","VPR CORD1",140 ,0)
  5634    Q
  5635   "RTN","VPR CORD1",141 ,0)
  5636    ;
  5637   "RTN","VPR CORD1",142 ,0)
  5638   QOSET(QIEN ,ACTION,DF N,CHKONLY, RESULT,VPR VALUE) ;
  5639   "RTN","VPR CORD1",143 ,0)
  5640    N NUM,VPR OIFN
  5641   "RTN","VPR CORD1",144 ,0)
  5642    I $P($G(^ ORD(101.41 ,QIEN,0)), U,4)'="O"  S VPROIFN= QIEN D PRO CESS(VPROI FN,ACTION, CHKONLY,.R ESULT,.VPR VALUE) Q
  5643   "RTN","VPR CORD1",145 ,0)
  5644    S NUM=0 F   S NUM=$O (^ORD(101. 41,QIEN,10 ,NUM)) Q:N UM'>0  D
  5645   "RTN","VPR CORD1",146 ,0)
  5646    .S VPROIF N=$P($G(^O RD(101.41, QIEN,10,NU M,0)),U,2)  I +$G(VPR OIFN)'>0 Q
  5647   "RTN","VPR CORD1",147 ,0)
  5648    .D PROCES S(VPROIFN, ACTION,CHK ONLY,.RESU LT,.VPRVAL UE)
  5649   "RTN","VPR CORD1",148 ,0)
  5650    Q
  5651   "RTN","VPR CORD1",149 ,0)
  5652   PROCESS(VP ROIFN,ACTI ON,CHKONLY ,RESULT,VP RVALUE,VPR OK) ;
  5653   "RTN","VPR CORD1",150 ,0)
  5654    N BLDRES, ORCAT,ORDA RR,ORDIALO G,RSPID,TE MP,TEXT
  5655   "RTN","VPR CORD1",151 ,0)
  5656    S TEMP=$G (ACTION)_V PROIFN
  5657   "RTN","VPR CORD1",152 ,0)
  5658    I $$BEG^V PRCORD2(DF N,LOC,TEMP ,USER,.VAR SARR,.BLDR ES)=0 G PR OCESSX
  5659   "RTN","VPR CORD1",153 ,0)
  5660    I $P(BLDR ES(0),U,4) ="Q" D
  5661   "RTN","VPR CORD1",154 ,0)
  5662    .S ORDTYP E="Q"
  5663   "RTN","VPR CORD1",155 ,0)
  5664    .I $P(BLD RES(0),U)' =1,$P(BLDR ES(0),U)'= 2 D AE("Qu ick Order  is not set  to Auto-A ccept",.VP RVALUE) G  PROCESSX
  5665   "RTN","VPR CORD1",156 ,0)
  5666    I $G(ORDT YPE)="" S  ORDTYPE=$S (ACTION="C ":"E",ACTI ON="X":"E" ,1:"N")
  5667   "RTN","VPR CORD1",157 ,0)
  5668    S RSPID=$ P(BLDRES(0 ),U,2)
  5669   "RTN","VPR CORD1",158 ,0)
  5670    I ACTION= "X" I $$CH ANGE^VPRCO RD2(VPROIF N,DFN,LOC, USER,.ERRA RR,.VPRVAL UE)=0 G PR OCESSX
  5671   "RTN","VPR CORD1",159 ,0)
  5672    I ORDTYPE ="Q" D
  5673   "RTN","VPR CORD1",160 ,0)
  5674    .D GETQDL G^ORCD(VPR OIFN)
  5675   "RTN","VPR CORD1",161 ,0)
  5676    .S ORCAT= $S(+$G(^DP T(DFN,.1)) >0:"I",1:" O"),PROMPT =$$PTR("SI G")
  5677   "RTN","VPR CORD1",162 ,0)
  5678    .D SIG^OR CDPS2
  5679   "RTN","VPR CORD1",163 ,0)
  5680    I '$D(ORD IALOG) D
  5681   "RTN","VPR CORD1",164 ,0)
  5682    .S ORDIAL OG=+$P($G( ^OR(100,+V PROIFN,0)) ,U,5)
  5683   "RTN","VPR CORD1",165 ,0)
  5684    .D GETDLG 1^ORCD(ORD IALOG)
  5685   "RTN","VPR CORD1",166 ,0)
  5686    .D GETORD ER^ORCD(+V PROIFN)
  5687   "RTN","VPR CORD1",167 ,0)
  5688    D EN(+VPR OIFN,DFN,L OC,USER,RS PID,ORDTYP E,CHKONLY, .VARSARR,. ORDIALOG,. ERRARR,.VP RPOSS,.RES ULT,.VPRVA LUE)
  5689   "RTN","VPR CORD1",168 ,0)
  5690   PROCESSX ;
  5691   "RTN","VPR CORD1",169 ,0)
  5692    Q
  5693   "RTN","VPR CORD1",170 ,0)
  5694    ;
  5695   "RTN","VPR CORD1",171 ,0)
  5696   QOL(RESULT ,LOC,PROV, IEN) ;
  5697   "RTN","VPR CORD1",172 ,0)
  5698    N CNT,BLD RES,DIEN,N AME,NODE,N UM,TEXT,TY PE,VARSARR ,VPRERCNT, VPRERARR,V PROARRY,VP RPOSS
  5699   "RTN","VPR CORD1",173 ,0)
  5700    S VPRERCN T=0
  5701   "RTN","VPR CORD1",174 ,0)
  5702    S DIEN="" ,NUM=0,TEX T=""
  5703   "RTN","VPR CORD1",175 ,0)
  5704    F  S NUM= $O(^VPRPAN EL(IEN,"OR DER DIALOG S",NUM)) Q :NUM'>0  D
  5705   "RTN","VPR CORD1",176 ,0)
  5706    .S DIEN=$ G(^VPRPANE L(IEN,"ORD ER DIALOGS ",NUM,0))  Q:+DIEN'>0
  5707   "RTN","VPR CORD1",177 ,0)
  5708    .S NAME=$ P($G(^ORD( 101.41,+DI EN,0)),U)  I NAME=""  Q
  5709   "RTN","VPR CORD1",178 ,0)
  5710    .I $$BEG^ VPRCORD2(D FN,LOC,DIE N,PROV,.VA RSARR,.BLD RES)=0 G Q OLX
  5711   "RTN","VPR CORD1",179 ,0)
  5712    .S TYPE=$ P(BLDRES(0 ),U,4)
  5713   "RTN","VPR CORD1",180 ,0)
  5714    .S RESULT ("qo",NUM, "name")=NA ME,RESULT( "qo",NUM," id")=DIEN, RESULT("qo ",NUM,"typ e")=TYPE
  5715   "RTN","VPR CORD1",181 ,0)
  5716    I $D(VPRV ALUE)>0 G  QOLX
  5717   "RTN","VPR CORD1",182 ,0)
  5718   QOLX ;
  5719   "RTN","VPR CORD1",183 ,0)
  5720    Q
  5721   "RTN","VPR CORD1",184 ,0)
  5722    ;
  5723   "RTN","VPR CORD1",185 ,0)
  5724   RENEW(VPRV ALUE,DFN,I D,ORPROV,C HKONLY,REA S,NAME,LOC ) ;
  5725   "RTN","VPR CORD1",186 ,0)
  5726    ;RENEW(VP RVALUE,UID ,PROVP,CHK ONLY,REAS, NAME) ;
  5727   "RTN","VPR CORD1",187 ,0)
  5728    ;Input -  DFN of the  patient
  5729   "RTN","VPR CORD1",188 ,0)
  5730    ;         RX to be r enewed
  5731   "RTN","VPR CORD1",189 ,0)
  5732    ;
  5733   "RTN","VPR CORD1",190 ,0)
  5734    N X,ORY,O RPKG,ORITM ,PSOSTAT,A ,PDET,ORFL DS,DRUG,DI SPLAY,FAIL ,LIST,OCHK S,OCO,OCLI ST,ORCPLX, ORINFO,ORP VSTS
  5735   "RTN","VPR CORD1",191 ,0)
  5736    N ORL,PCP ,PCPN,RESU LT,RNWFLDS ,SPACES,Y, ORUSR,NEWI FN,PNM,RXE ,VPROIFN
  5737   "RTN","VPR CORD1",192 ,0)
  5738    N VPRERAR R,VPRERCNT ,VPRRES,VP RISORD,VPR OK
  5739   "RTN","VPR CORD1",193 ,0)
  5740    K ^TMP($J ,"ORDER CH ECKS")
  5741   "RTN","VPR CORD1",194 ,0)
  5742    S VPRERCN T=0,VPRISO RD=1
  5743   "RTN","VPR CORD1",195 ,0)
  5744    S VPROIFN =ID
  5745   "RTN","VPR CORD1",196 ,0)
  5746    D RNWFLDS ^ORWDXR(.R NWFLDS,VPR OIFN) S OR FLDS(1)=RN WFLDS(0)
  5747   "RTN","VPR CORD1",197 ,0)
  5748    D ISCPLX^ ORWDXR(.OR CPLX,VPROI FN) S ORCP LX=+$G(ORC PLX)
  5749   "RTN","VPR CORD1",198 ,0)
  5750    I CHKONLY =1 Q
  5751   "RTN","VPR CORD1",199 ,0)
  5752    D RENEW^O RWDXR(.RES ULT,VPROIF N,DFN,ORPR OV,LOC,.OR FLDS,ORCPL X,0)
  5753   "RTN","VPR CORD1",200 ,0)
  5754    S NEWIFN= $P(^OR(100 ,VPROIFN,3 ),"^",6)
  5755   "RTN","VPR CORD1",201 ,0)
  5756    S $P(^OR( 100,NEWIFN ,8,1,0),"^ ",13)=ORPR OV
  5757   "RTN","VPR CORD1",202 ,0)
  5758    I $D(VPRV ALUE)>0 G  RENEWX
  5759   "RTN","VPR CORD1",203 ,0)
  5760    S REAS="R enew "_NAM E_" "_REAS
  5761   "RTN","VPR CORD1",204 ,0)
  5762   RENEWUNO ;
  5763   "RTN","VPR CORD1",205 ,0)
  5764    ;I VPRISO RD=1 D UNL KORD^ORWDX (.VPROK,VP ROIFN) I ' VPROK D AE ("Order un lock Faile d") K VPRO K
  5765   "RTN","VPR CORD1",206 ,0)
  5766   RENEWUNL ;
  5767   "RTN","VPR CORD1",207 ,0)
  5768    ;D UNLOCK ^ORWDX(.VP ROK,DFN) I  'VPROK D  AE("Chart  unlock Fai led")
  5769   "RTN","VPR CORD1",208 ,0)
  5770   RENEWX ;
  5771   "RTN","VPR CORD1",209 ,0)
  5772    ;D ENCODE ^VPRJSON(" RESULT","V PRVALUE"," VPRERR")
  5773   "RTN","VPR CORD1",210 ,0)
  5774    Q
  5775   "RTN","VPR CORD1",211 ,0)
  5776    ;
  5777   "RTN","VPR CORD1",212 ,0)
  5778   PTR(NAME)  ; -- Retur ns ptr val ue of prom pt in Dial og file
  5779   "RTN","VPR CORD1",213 ,0)
  5780    Q +$O(^OR D(101.41," AB",$E("OR  GTX "_NAM E,1,63),0) )
  5781   "RTN","VPR CORD1",214 ,0)
  5782    ;
  5783   "RTN","VPR CORD1",215 ,0)
  5784   SAVE(VPRRE S,DFN,USER ,LOC,DLGNA ME,DGIEN,Q OIEN,ORIFN ,SAVEARR)  ;
  5785   "RTN","VPR CORD1",216 ,0)
  5786    N CNT,NUM ,VPROREST
  5787   "RTN","VPR CORD1",217 ,0)
  5788    I QOIEN>0  D SAVE^OR WDX(.VPROR EST,DFN,US ER,LOC,DLG NAME,DGIEN ,QOIEN,"", .SAVEARR," ",DT,"",0)
  5789   "RTN","VPR CORD1",218 ,0)
  5790    I ORIFN>0  D SAVE^OR WDX(.VPROR EST,DFN,US ER,LOC,DLG NAME,DGIEN ,"",ORIFN, .SAVEARR," ",DT,"C",0 )
  5791   "RTN","VPR CORD1",219 ,0)
  5792    S CNT=$O( VPRRES("") ,-1)
  5793   "RTN","VPR CORD1",220 ,0)
  5794    S NUM=0 F   S NUM=$O (VPROREST( NUM)) Q:NU M'>0  D
  5795   "RTN","VPR CORD1",221 ,0)
  5796    .S CNT=CN T+1,VPRRES ("resultTe xt")=$G(VP RRES("resu ltText"))_ $C(13,10)_ VPROREST(N UM)
  5797   "RTN","VPR CORD1",222 ,0)
  5798    Q
  5799   "RTN","VPR CORD1",223 ,0)
  5800    ;
  5801   "RTN","VPR CORD1",224 ,0)
  5802   UNO ;
  5803   "RTN","VPR CORD1",225 ,0)
  5804    ;I VPRISO RD=1 D UNL KORD^ORWDX (.VPROK,VP ROIFN) I ' VPROK D AE ("Order un lock Faile d") K VPRO K
  5805   "RTN","VPR CORD1",226 ,0)
  5806   UNLOCK ;
  5807   "RTN","VPR CORD1",227 ,0)
  5808    ;D UNLOCK ^ORWDX(.VP ROK,DFN) I  'VPROK D  AE("Chart  unlock Fai led")
  5809   "RTN","VPR CORD1",228 ,0)
  5810   EXIT ;
  5811   "RTN","VPR CORD1",229 ,0)
  5812    S VPRBLT= 1
  5813   "RTN","VPR CORD1",230 ,0)
  5814    ;D BLDXML D^VPRCORD2 (.VPRERARR ,.VPRRES,. VPRPOSS)
  5815   "RTN","VPR CORD1",231 ,0)
  5816    K ^TMP($J ,"ORDER CH ECKS")
  5817   "RTN","VPR CORD1",232 ,0)
  5818    Q
  5819   "RTN","VPR CORD1",233 ,0)
  5820    ;
  5821   "RTN","VPR CORD1",234 ,0)
  5822   VAL(REQ,X)  ; return  value from  request
  5823   "RTN","VPR CORD1",235 ,0)
  5824    Q $G(REQ( X,1))
  5825   "RTN","VPR CORD1",236 ,0)
  5826    ;
  5827   "RTN","VPR CORD1",237 ,0)
  5828   VALIDUID(U ID) ;
  5829   "RTN","VPR CORD1",238 ,0)
  5830    I UID["me d" Q 1
  5831   "RTN","VPR CORD1",239 ,0)
  5832    Q 0
  5833   "RTN","VPR CORD1",240 ,0)
  5834    ;
  5835   "RTN","VPR CORD1",241 ,0)
  5836   PRECHK(VPR OK,DFN,LOC ,VPROIFN,O RPROV,ACTI ON,PACTION ,VARSARR,S AVEARR,VPR OARRY,ERRO R) ;
  5837   "RTN","VPR CORD1",242 ,0)
  5838    N ORDERCH K,ORDTYPE, TEMP,VPRPK G
  5839   "RTN","VPR CORD1",243 ,0)
  5840    I PACTION '="N" D GE TPKG^ORWDX R(.VPRPKG, VPROIFN) I  '$D(VPRPK G) D AE("I nvalid Ord er Number" ,.ERROR) S  VPROK=2 Q
  5841   "RTN","VPR CORD1",244 ,0)
  5842    I VPRPKG[ "PS" D  I  VPROK>0 Q
  5843   "RTN","VPR CORD1",245 ,0)
  5844    .S ORDTYP E=$S(ACTIO N="R":"E", PACTION="C ":"E",PACT ION="X":"E ",PACTION= "N":"N",1: "Q")
  5845   "RTN","VPR CORD1",246 ,0)
  5846    .D ALLWOR D^ORALWORD (.VPROK,DF N,VPROIFN, ORDTYPE,OR PROV) I $G (VPROK)>0  D AEM(.VPR OK,.ERROR)  Q
  5847   "RTN","VPR CORD1",247 ,0)
  5848    .I ACTION ="DL"!(ACT ION="RENEW ") D  I VP ROK>0 Q
  5849   "RTN","VPR CORD1",248 ,0)
  5850    .. S ORTY PE=$S(ACTI ON="DL":"D C",ACTION= "RENEW":"R N",1:"") I  ORTYPE=""  Q
  5851   "RTN","VPR CORD1",249 ,0)
  5852    .. D VALI D^ORWDXA(. VPROK,VPRO IFN,ORTYPE ,ORPROV) I  $G(VPROK) '="" D AE( VPROK,.ERR OR) S VPRO K=2 Q
  5853   "RTN","VPR CORD1",250 ,0)
  5854    ..I ACTIO N="DL" Q
  5855   "RTN","VPR CORD1",251 ,0)
  5856    ..D GTORI TM^ORWDXR( .ORITM,VPR OIFN)
  5857   "RTN","VPR CORD1",252 ,0)
  5858    ..I VPRPK G="PSO" D  FAILDEA^OR WDPS1(.FAI L,ORITM,OR PROV,"O")  I FAIL D A E("Failed  DEA Check" ,.ERROR) S  VPROK=2 Q
  5859   "RTN","VPR CORD1",253 ,0)
  5860    ..D RNWFL DS^ORWDXR( .RNWFLDS,V PROIFN) S  ORFLDS(1)= RNWFLDS(0)
  5861   "RTN","VPR CORD1",254 ,0)
  5862    ..D CHKGR P^ORWDPS2( .DISPLAY,V PROIFN) ;I  DISPLAY'= 2 D AE("Pa ckage Prob lem on Ord er") G UNO
  5863   "RTN","VPR CORD1",255 ,0)
  5864    ;
  5865   "RTN","VPR CORD1",256 ,0)
  5866    I ACTION= "P" D  I V PROK>0 Q 
  5867   "RTN","VPR CORD1",257 ,0)
  5868    .D BLDPOR D(VPROIFN, DFN,LOC,PA CTION,ORPR OV,.VARSAR R,.VPROK,. VPROARRY,. ORDERCHK,. SAVEARR)
  5869   "RTN","VPR CORD1",258 ,0)
  5870    ;
  5871   "RTN","VPR CORD1",259 ,0)
  5872    W !,VPRPK G
  5873   "RTN","VPR CORD1",260 ,0)
  5874    W !,VPROI FN
  5875   "RTN","VPR CORD1",261 ,0)
  5876    D PEROC(. VPROK,DFN, VPROIFN,VP RPKG,ACTIO N,LOC,.ORD ERCHK,.VAR SARR,.ORDI ALOG,.SAVE ARR,.VPROA RRY)
  5877   "RTN","VPR CORD1",262 ,0)
  5878    Q
  5879   "RTN","VPR CORD1",263 ,0)
  5880    ;
  5881   "RTN","VPR CORD1",264 ,0)
  5882   BLDPORD(VP ROIFN,DFN, LOC,PACTIO N,ORPROV,V ARSARR,VPR OK,ORDIALO G,ORDERCHK ,SAVEARR,E RROR) ;
  5883   "RTN","VPR CORD1",265 ,0)
  5884    N BLDRES, DIEN,ORDTY PE,TEMP
  5885   "RTN","VPR CORD1",266 ,0)
  5886    S TEMP=$G (PACTION)_ VPROIFN
  5887   "RTN","VPR CORD1",267 ,0)
  5888    I $$BEG^V PRCORD2(DF N,LOC,TEMP ,ORPROV,.V ARSARR,.BL DRES)=0 S  VPROK=2 Q
  5889   "RTN","VPR CORD1",268 ,0)
  5890    I $P(BLDR ES(0),U,4) ="Q" D
  5891   "RTN","VPR CORD1",269 ,0)
  5892    .S ORDTYP E="Q"
  5893   "RTN","VPR CORD1",270 ,0)
  5894    .I $P(BLD RES(0),U)' =1,$P(BLDR ES(0),U)'= 2 D AE("Qu ick Order  is not set  to Auto-A ccept",.VP RVALUE) S  VPROK=2 Q
  5895   "RTN","VPR CORD1",271 ,0)
  5896    I $G(ORDT YPE)="" S  ORDTYPE=$S (PACTION=" C":"E",PAC TION="X":" E",1:"N")
  5897   "RTN","VPR CORD1",272 ,0)
  5898    S RSPID=$ P(BLDRES(0 ),U,2)
  5899   "RTN","VPR CORD1",273 ,0)
  5900    I PACTION ="X" I $$C HANGE^VPRC ORD2(VPROI FN,DFN,LOC ,USER,.ERR ARR,.VPRVA LUE)=0 G P ROCESSX
  5901   "RTN","VPR CORD1",274 ,0)
  5902    S VARSARR ("DISPLAY  GROUP IEN" )=$S(ORDTY PE="Q":$P( $G(^ORD(10 1.41,$$DEF DLG^ORCD(V PROIFN),0) ),U,5),1:+ $P(^OR(100 ,VPROIFN,0 ),U,11))
  5903   "RTN","VPR CORD1",275 ,0)
  5904    S VARSARR ("DISPLAY  GROUP")=$P ($G(^ORD(1 01.98,VARS ARR("DISPL AY GROUP I EN"),0)),U )
  5905   "RTN","VPR CORD1",276 ,0)
  5906    D BLDORDL G(.ORDIALO G,VPROIFN, DFN,RSPID, ORDTYPE)
  5907   "RTN","VPR CORD1",277 ,0)
  5908    S DIEN=VA RSARR("DIS PLAY GROUP  IEN")
  5909   "RTN","VPR CORD1",278 ,0)
  5910    D FILLID^ ORWDXC(.FI LLER,DIEN)
  5911   "RTN","VPR CORD1",279 ,0)
  5912    S VARSARR ("FILLER I D")=FILLER
  5913   "RTN","VPR CORD1",280 ,0)
  5914    I ORDTYPE ="E" S DIE N=+$P($G(^ OR(100,VPR OIFN,0)),U ,5)
  5915   "RTN","VPR CORD1",281 ,0)
  5916    I ORDTYPE ="Q" S DIE N=VPROIFN
  5917   "RTN","VPR CORD1",282 ,0)
  5918    S DLGNAME =$P($G(^OR D(101.41,D IEN,0)),U)
  5919   "RTN","VPR CORD1",283 ,0)
  5920    I DLGNAME ="" D AE(" INVALID DE FAULT DIAL OG",.ERROR ) S VPROK= 2 Q
  5921   "RTN","VPR CORD1",284 ,0)
  5922    S VARSARR ("DIALOG N AME")=DLGN AME
  5923   "RTN","VPR CORD1",285 ,0)
  5924    D DLGDEF^ ORWDX(.DLG DEF,DLGNAM E)
  5925   "RTN","VPR CORD1",286 ,0)
  5926    ;build or der check  array,buil d dialog s tructure a nd build s ave array
  5927   "RTN","VPR CORD1",287 ,0)
  5928    D BLDARRS ^VPRCORD2( .RESULT,.O RDIALOG,.V ARSARR,DFN ,LOC,.ORDE RCHK,.SAVE ARR,.VPRPO SS)
  5929   "RTN","VPR CORD1",288 ,0)
  5930    Q
  5931   "RTN","VPR CORD1",289 ,0)
  5932    ;
  5933   "RTN","VPR CORD1",290 ,0)
  5934   BLDORDLG(O RDIALOG,VP ROIFN,DFN, RSPID,ORDT YPE) ;
  5935   "RTN","VPR CORD1",291 ,0)
  5936    N PROMPT
  5937   "RTN","VPR CORD1",292 ,0)
  5938    I ORDTYPE ="Q" D
  5939   "RTN","VPR CORD1",293 ,0)
  5940    .D GETQDL G^ORCD(VPR OIFN)
  5941   "RTN","VPR CORD1",294 ,0)
  5942    .S ORCAT= $S(+$G(^DP T(DFN,.1)) >0:"I",1:" O"),PROMPT =$$PTR("SI G")
  5943   "RTN","VPR CORD1",295 ,0)
  5944    .D SIG^OR CDPS2
  5945   "RTN","VPR CORD1",296 ,0)
  5946    I '$D(ORD IALOG) D
  5947   "RTN","VPR CORD1",297 ,0)
  5948    .S ORDIAL OG=+$P($G( ^OR(100,+V PROIFN,0)) ,U,5)
  5949   "RTN","VPR CORD1",298 ,0)
  5950    .D GETDLG 1^ORCD(ORD IALOG)
  5951   "RTN","VPR CORD1",299 ,0)
  5952    .D GETORD ER^ORCD(+V PROIFN)
  5953   "RTN","VPR CORD1",300 ,0)
  5954    Q
  5955   "RTN","VPR CORD1",301 ,0)
  5956    ;
  5957   "RTN","VPR CORD1",302 ,0)
  5958    ;PEROC(.V PROK,DFN,V PROIFN,VPR PKG,ACTION )
  5959   "RTN","VPR CORD1",303 ,0)
  5960   PEROC(VPRO K,DFN,VPRO IFN,VPRPKG ,ACTION,LO C,ORDERCHK ,VARSARR,O RDIALOG,SA VEARR,VPRO ARRY) ;
  5961   "RTN","VPR CORD1",304 ,0)
  5962    N A,OCO,O CLIST,ORIN FO,ORL,OCH KS,PATTYPE ,VPRREN,VP RPOSS
  5963   "RTN","VPR CORD1",305 ,0)
  5964    W !,VPRPK G
  5965   "RTN","VPR CORD1",306 ,0)
  5966    W !,VPROI FN
  5967   "RTN","VPR CORD1",307 ,0)
  5968    S PATTYPE =$S(+$G(^D PT(DFN,.1) )>0:"I",1: "O")
  5969   "RTN","VPR CORD1",308 ,0)
  5970    D ON^ORWD XC(.OCO)
  5971   "RTN","VPR CORD1",309 ,0)
  5972    D DISPLAY ^ORWDXC(.O CLIST,DFN, VPRPKG) I  $D(OCLIST)  D INFO^VP RCORD2(.OC LIST)
  5973   "RTN","VPR CORD1",310 ,0)
  5974    S VPRREN= 0
  5975   "RTN","VPR CORD1",311 ,0)
  5976    I ACTION= "RENEW" D   I VPROK>0  Q
  5977   "RTN","VPR CORD1",312 ,0)
  5978    .D OXDATA ^ORWDXR01( .ORINFO,VP ROIFN)
  5979   "RTN","VPR CORD1",313 ,0)
  5980    .S A=$G(^ OR(100,VPR OIFN,0)) I  A="" D AE ("Order mi ssing from  ORDERS fi le",.VPRVA LUE) S VPR OK=2 Q
  5981   "RTN","VPR CORD1",314 ,0)
  5982    .S ORPROV =+$P(A,"^" ,4),ORL=+$ P(A,"^",10 )
  5983   "RTN","VPR CORD1",315 ,0)
  5984    .S VPRREN =1
  5985   "RTN","VPR CORD1",316 ,0)
  5986    D ACCEPT^ ORWDXC(.OC HKS,DFN,VP RPKG,PATTY PE,LOC,.OR DERCHK,VPR OIFN,VPRRE N) I $D(OC HKS) D INF O^VPRCORD2 (.OCHKS)
  5987   "RTN","VPR CORD1",317 ,0)
  5988    Q
  5989   "RTN","VPR CORD1",318 ,0)
  5990    ;
  5991   "RTN","VPR CORD1",319 ,0)
  5992   ORDERUID(V PRVALUE,IN FO) ;
  5993   "RTN","VPR CORD1",320 ,0)
  5994   ENORDER ;
  5995   "RTN","VPR CORD1",321 ,0)
  5996    N ACTION, CHKONLY,DF N,ERROR,ID ,ISQO,LOC, NAME,ORDIA LOG,ORPROV ,PACTION,P ATIENT,RES ULT,SAVEAR R,SNIPPET, TEMP,TYPE, UID,USER,V PROARRY,VP ROK,VPRPOS S
  5997   "RTN","VPR CORD1",322 ,0)
  5998    S UID=$G( INFO("uid" )),DFN=""
  5999   "RTN","VPR CORD1",323 ,0)
  6000    S ACTION= $G(INFO("a ction")),S NIPPET=$G( INFO("snip pet")),ORP ROV=$G(INF O("user")) ,PATIENT=$ G(INFO("pa tient")),N AME=$G(INF O("name"))
  6001   "RTN","VPR CORD1",324 ,0)
  6002    S LOC=$G( INFO("loca tion")),CH KONLY=$G(I NFO("order ChecksOnly ")),ISQO=$ G(INFO("is QO")),PACT ION=$G(INF O("orderAc tion")),ID =$G(INFO(" qoListId") )
  6003   "RTN","VPR CORD1",325 ,0)
  6004    S ID=$G(I NFO("qoId" ))
  6005   "RTN","VPR CORD1",326 ,0)
  6006    S TEMP=$S (PACTION=" RENEW":"Or der can be  renew to  new order. ",PACTION= "C":"Order  cannot be  renew it  can be cop y to a new  order.",1 :"")
  6007   "RTN","VPR CORD1",327 ,0)
  6008    S VPROK=0
  6009   "RTN","VPR CORD1",328 ,0)
  6010    I PACTION '="" D  I  VPROK>0 G  ORDERX
  6011   "RTN","VPR CORD1",329 ,0)
  6012    .I $$VALI DUID(UID)= 0  D AE("U ID is not  valid UID" ,.ERROR)
  6013   "RTN","VPR CORD1",330 ,0)
  6014    .S DFN=$P (UID,":",5 )
  6015   "RTN","VPR CORD1",331 ,0)
  6016    .S ID=$P( UID,":",6)
  6017   "RTN","VPR CORD1",332 ,0)
  6018    I DFN=""  S DFN=PATI ENT
  6019   "RTN","VPR CORD1",333 ,0)
  6020    ;perform  Inital Che cks
  6021   "RTN","VPR CORD1",334 ,0)
  6022    I PACTION '="" D PRE CHK(.VPROK ,LOC,DFN,I D,ORPROV,A CTION,PACT ION,.VARSA RR,.SAVEAR R,.VPROARR Y,.ERROR)
  6023   "RTN","VPR CORD1",335 ,0)
  6024    I VPROK>1 ,ACTION="R ENEW" K ^T MP($J,"ORD ER CHECKS" ) S INFO(" action")=" P",INFO("o rderAction ")="C",INF O("orderCh ecksOnly") ="true" G  ENORDER
  6025   "RTN","VPR CORD1",336 ,0)
  6026    I VPROK>1  G ORDERX
  6027   "RTN","VPR CORD1",337 ,0)
  6028    I CHKONLY ="true" S  RESULT("re sultText") =TEMP G OR DERX
  6029   "RTN","VPR CORD1",338 ,0)
  6030    ;
  6031   "RTN","VPR CORD1",339 ,0)
  6032    ;list Dis continue R eason List
  6033   "RTN","VPR CORD1",340 ,0)
  6034    I ACTION= "DL" D  G  ORDERX
  6035   "RTN","VPR CORD1",341 ,0)
  6036    .D DCLREA S(.RESULT, DFN,ID,ORP ROV)
  6037   "RTN","VPR CORD1",342 ,0)
  6038    ;Disconti nue Order
  6039   "RTN","VPR CORD1",343 ,0)
  6040    I ACTION= "D" D  G O RDERX
  6041   "RTN","VPR CORD1",344 ,0)
  6042    .S REAS=I NFO("dcRea son")
  6043   "RTN","VPR CORD1",345 ,0)
  6044    .D DC(.RE SULT,DFN,I D,ORPROV,L OC,.SNIPPE T,NAME)
  6045   "RTN","VPR CORD1",346 ,0)
  6046    ;Renew Or der
  6047   "RTN","VPR CORD1",347 ,0)
  6048    I ACTION= "RENEW" D   G ORDERX
  6049   "RTN","VPR CORD1",348 ,0)
  6050    .D RENEW( .RESULT,DF N,ID,ORPRO V,CHKONLY, .SNIPPET,N AME,LOC)
  6051   "RTN","VPR CORD1",349 ,0)
  6052    ;
  6053   "RTN","VPR CORD1",350 ,0)
  6054    I ACTION= "P" D  G O RDERX
  6055   "RTN","VPR CORD1",351 ,0)
  6056    .N ORDIAL OG
  6057   "RTN","VPR CORD1",352 ,0)
  6058    .M ORDIAL OG=VPROARR Y
  6059   "RTN","VPR CORD1",353 ,0)
  6060    .S SAVEAR R("ORCHECK ")=0,SAVEA RR("ORTS") =0
  6061   "RTN","VPR CORD1",354 ,0)
  6062    .I PACTIO N="Q" D SA VE(.RESULT ,DFN,ORPRO V,LOC,VARS ARR("DIALO G NAME"),V ARSARR("DI SPLAY GROU P IEN"),ID ,0,.SAVEAR R)
  6063   "RTN","VPR CORD1",355 ,0)
  6064    .i PACTIO N="C" D SA VE(.RESULT ,DFN,ORPRO V,LOC,VARS ARR("DIALO G NAME"),V ARSARR("DI SPLAY GROU P IEN"),0, ID,.SAVEAR R)
  6065   "RTN","VPR CORD1",356 ,0)
  6066    .I $L($G( RESULT("re sultText") ))>0 S RES ULT("resul tText")=TE MP_$C(13,1 0)_RESULT( "resultTex t")
  6067   "RTN","VPR CORD1",357 ,0)
  6068    ;
  6069   "RTN","VPR CORD1",358 ,0)
  6070    I ACTION= "QL" D  G  ORDERX
  6071   "RTN","VPR CORD1",359 ,0)
  6072    .D QOL(.R ESULT,LOC, ORPROV,ID)
  6073   "RTN","VPR CORD1",360 ,0)
  6074    ;
  6075   "RTN","VPR CORD1",361 ,0)
  6076   ORDERX ;
  6077   "RTN","VPR CORD1",362 ,0)
  6078    I '$D(ERR OR) D BLDJ SON^VPRCOR D2(.RESULT ,.VPROARRY ,.VPRPOSS, .VPRVALUE, SNIPPET,UI D)
  6079   "RTN","VPR CORD1",363 ,0)
  6080    ;I $D(ERR OR) M VPRV ALUE=ERROR
  6081   "RTN","VPR CORD1",364 ,0)
  6082    I $D(ERRO R) D ENCOD E^VPRJSON( "ERROR","V PRVALUE"," VPRERR")
  6083   "RTN","VPR CORD1",365 ,0)
  6084    M ^XTMP(" AGP INFO") =VPRVALUE
  6085   "RTN","VPR CORD1",366 ,0)
  6086    Q
  6087   "RTN","VPR CORD1",367 ,0)
  6088    ;
  6089   "RTN","VPR CORD2")
  6090   0^8^B67716 889
  6091   "RTN","VPR CORD2",1,0 )
  6092   VPRCORD2 ; ;SLC/AGP -  Process O rder Reque st from AV IVA System  ; 11/2/10  11:39am
  6093   "RTN","VPR CORD2",2,0 )
  6094    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  6095   "RTN","VPR CORD2",3,0 )
  6096    ;
  6097   "RTN","VPR CORD2",4,0 )
  6098    ;The purp ose of thi s API is t o process  a request  to renew a n
  6099   "RTN","VPR CORD2",5,0 )
  6100    ;Outpatie nt Prescri ption
  6101   "RTN","VPR CORD2",6,0 )
  6102    ;
  6103   "RTN","VPR CORD2",7,0 )
  6104    Q
  6105   "RTN","VPR CORD2",8,0 )
  6106    ;
  6107   "RTN","VPR CORD2",9,0 )
  6108    ;add poss ible value s from the  dialog to  XML List  return for  each prom pt
  6109   "RTN","VPR CORD2",10, 0)
  6110   ADDPOSS(PO SS,RESULT)  ;
  6111   "RTN","VPR CORD2",11, 0)
  6112    N CNT,ISF IRST,NUM,L AST,PROMPT ,TEMP
  6113   "RTN","VPR CORD2",12, 0)
  6114    ;S RESULT ("possible Values")=" "
  6115   "RTN","VPR CORD2",13, 0)
  6116    M RESULT= POSS
  6117   "RTN","VPR CORD2",14, 0)
  6118    S ISFIRST =1,LAST="" ,PROMPT=""
  6119   "RTN","VPR CORD2",15, 0)
  6120    ;F  S PRO MPT=$O(POS S(PROMPT))  Q:PROMPT= ""  D
  6121   "RTN","VPR CORD2",16, 0)
  6122    ;.S TEMP= PROMPT_"s" ,LAST=PROM PT
  6123   "RTN","VPR CORD2",17, 0)
  6124    ;.S RESUL T("possibl eValues",T EMP)=""
  6125   "RTN","VPR CORD2",18, 0)
  6126    ;.S CNT=" ",NUM=0 F   S CNT=$O( POSS(PROMP T,CNT)) Q: CNT=""  
  6127   "RTN","VPR CORD2",19, 0)
  6128    ;..S RESU LT("possib leValues", TEMP,NUM," value")=PO SS(PROMPT, CNT),NUM=N UM+1
  6129   "RTN","VPR CORD2",20, 0)
  6130    Q
  6131   "RTN","VPR CORD2",21, 0)
  6132    ;
  6133   "RTN","VPR CORD2",22, 0)
  6134   ARRREAS(RE AS,UID) ;
  6135   "RTN","VPR CORD2",23, 0)
  6136    I '$D(^XT MP("VPR SN IPPET",DFN ,DT)) S ^X TMP("VPR S NIPPET",0) =""
  6137   "RTN","VPR CORD2",24, 0)
  6138    N CNT S C NT=$O(^XTM P("VPR SNI PPET",DFN, DT,""),-1)
  6139   "RTN","VPR CORD2",25, 0)
  6140    S CNT=CNT +1
  6141   "RTN","VPR CORD2",26, 0)
  6142    S ^XTMP(" VPR SNIPPE T",DFN,DT, CNT)=""
  6143   "RTN","VPR CORD2",27, 0)
  6144    S ^XTMP(" VPR SNIPPE T",DFN,DT, CNT,"text" )=REAS
  6145   "RTN","VPR CORD2",28, 0)
  6146    I $G(UID) '="" S ^XT MP("VPR SN IPPET",DFN ,DT,CNT,"u id")=UID
  6147   "RTN","VPR CORD2",29, 0)
  6148    Q
  6149   "RTN","VPR CORD2",30, 0)
  6150    ;
  6151   "RTN","VPR CORD2",31, 0)
  6152    ;initial  API needed  for order  actions a nd QO
  6153   "RTN","VPR CORD2",32, 0)
  6154   BEG(DFN,LO C,IEN,USER ,VARSARR,B LDRES,VPRV ALUE) ;
  6155   "RTN","VPR CORD2",33, 0)
  6156    N CNT,FLD S,HASKEY,T EXT,VPRLST
  6157   "RTN","VPR CORD2",34, 0)
  6158    D BLDVAR( DFN,LOC,DT ,.VARSARR)  I VARSARR ("PATIENT" )="" D AE^ VPRCORD1(" Invalid Pa tient",.VP RVALUE) Q  0
  6159   "RTN","VPR CORD2",35, 0)
  6160    D NPHASKE Y^ORWU(.HA SKEY,USER, "PROVIDER" ) I HASKEY =0 D AE^VP RCORD1("DO ES NOT HOL D THE PROV IDER KEY", .VPRVALUE)  Q 0
  6161   "RTN","VPR CORD2",36, 0)
  6162    S FLDS=DF N_U_LOC_U_ USER_U_VAR SARR("ISIN P")_U_VARS ARR("SEX") _U_VARSARR ("AGE")_U_ "0;C;0;0^0 ^^^"
  6163   "RTN","VPR CORD2",37, 0)
  6164    I $P($G(^ ORD(101.41 ,IEN,0)),U ,4)="O" D   Q 1
  6165   "RTN","VPR CORD2",38, 0)
  6166    .S BLDRES (0)="^^^O"
  6167   "RTN","VPR CORD2",39, 0)
  6168    .D LOADSE T^ORWDXM(. VPRLST,IEN )
  6169   "RTN","VPR CORD2",40, 0)
  6170    .S CNT=0  F  S CNT=$ O(VPRLST(C NT)) Q:CNT '>0  D
  6171   "RTN","VPR CORD2",41, 0)
  6172    ..S BLDRE S(CNT)=VPR LST(CNT)
  6173   "RTN","VPR CORD2",42, 0)
  6174    D BLDQRSP ^ORWDXM1(. BLDRES,IEN ,FLDS,VARS ARR("ISIMO "),LOC)
  6175   "RTN","VPR CORD2",43, 0)
  6176    K ^TMP("O RWDXMQ",$J )
  6177   "RTN","VPR CORD2",44, 0)
  6178    I +BLDRES (0)=8 D AE ^VPRCORD1( BLDRES(.5) ,.VPRVALUE ) Q 0
  6179   "RTN","VPR CORD2",45, 0)
  6180    Q 1
  6181   "RTN","VPR CORD2",46, 0)
  6182    ;
  6183   "RTN","VPR CORD2",47, 0)
  6184    ;builds m ultiple ar rays from  the ORDIAL OG array.
  6185   "RTN","VPR CORD2",48, 0)
  6186    ;builds X ML return  structure  of the dia log,
  6187   "RTN","VPR CORD2",49, 0)
  6188    ;ORDERCHK  array for  order che cks when p lacing an  order
  6189   "RTN","VPR CORD2",50, 0)
  6190    ;SAVEARR  array for  saving an  order for  QO
  6191   "RTN","VPR CORD2",51, 0)
  6192   BLDARRS(RE SULT,ORDIA LOG,VARSAR R,DFN,LOC, ORDERCHK,S AVEARR,POS S) ;
  6193   "RTN","VPR CORD2",52, 0)
  6194    ;D ADD("< dialog>")
  6195   "RTN","VPR CORD2",53, 0)
  6196    N CNT,DEF ,DRUG,EXT, FILLER,INC ,IEN,INST, NODE,PROMP T,SCH,STR, TEMP,VALUE ,X,ZERO
  6197   "RTN","VPR CORD2",54, 0)
  6198    D SCHALL^ ORWDPS1(.S CH,DFN,LOC )
  6199   "RTN","VPR CORD2",55, 0)
  6200    S RESULT( "name")=VA RSARR("DIA LOG NAME") ,RESULT("d isplayGrou p")=VARSAR R("DISPLAY  GROUP")
  6201   "RTN","VPR CORD2",56, 0)
  6202    S IEN=$$P TR("ORDERA BLE ITEM")
  6203   "RTN","VPR CORD2",57, 0)
  6204    S OI=ORDI ALOG(IEN,1 ),FILLER=V ARSARR("FI LLER ID")
  6205   "RTN","VPR CORD2",58, 0)
  6206    D LOADPOS S(DFN,LOC, OI,FILLER, .VARSARR,. POSS)
  6207   "RTN","VPR CORD2",59, 0)
  6208    S CNT=0,I EN=0,INC=0  F  S IEN= $O(ORDIALO G(IEN)) Q: IEN'>0  D
  6209   "RTN","VPR CORD2",60, 0)
  6210    .S NODE=$ G(ORDIALOG (IEN)),ZER O=ORDIALOG (IEN,0)
  6211   "RTN","VPR CORD2",61, 0)
  6212    .S PROMPT =$P(NODE,U ,2),CNT=CN T+1,INC=IN C+1
  6213   "RTN","VPR CORD2",62, 0)
  6214    .S RESULT ("structur e",INC,"na me")=PROMP T,RESULT(" structure" ,INC,"id") =$P(NODE,U )
  6215   "RTN","VPR CORD2",63, 0)
  6216    .S TEMP=$ S(PROMPT=" DOSE":"ALL DOSES",PRO MPT="DRUG" :"DISPENSE ",1:PROMPT )
  6217   "RTN","VPR CORD2",64, 0)
  6218    .;I $D(PO SS(TEMP))  D ADDPOSS( TEMP,.POSS )
  6219   "RTN","VPR CORD2",65, 0)
  6220    .I $P(ZER O,U)="S" D  LOADPOSC( PROMPT,$P( ZERO,U,2), .POSS)
  6221   "RTN","VPR CORD2",66, 0)
  6222    .;D ADD(" <instances >")
  6223   "RTN","VPR CORD2",67, 0)
  6224    .S X=$O(O RDIALOG(IE N,99),-1)
  6225   "RTN","VPR CORD2",68, 0)
  6226    .;I X=0 D   Q
  6227   "RTN","VPR CORD2",69, 0)
  6228    .;.S VALU E=$O(POSS( PROMPT,"DE FAULT","") ) I VALUE= "" D  Q
  6229   "RTN","VPR CORD2",70, 0)
  6230    .;..D ADD ("</instan ces>")
  6231   "RTN","VPR CORD2",71, 0)
  6232    .;..D ADD ("</prompt >")
  6233   "RTN","VPR CORD2",72, 0)
  6234    .;.D ADD( "<default  value='"_$ $ESC^VPRD( VALUE)_"'/ >")
  6235   "RTN","VPR CORD2",73, 0)
  6236    .;.D ADD( "</instanc es>")
  6237   "RTN","VPR CORD2",74, 0)
  6238    .;.D ADD( "</prompt> ")
  6239   "RTN","VPR CORD2",75, 0)
  6240    .F INST=1 :1:X D
  6241   "RTN","VPR CORD2",76, 0)
  6242    ..S VALUE =ORDIALOG( IEN,INST)
  6243   "RTN","VPR CORD2",77, 0)
  6244    ..I VALUE ["^TMP(" D   Q
  6245   "RTN","VPR CORD2",78, 0)
  6246    ... I $G( @VALUE@(1, 0))="" Q
  6247   "RTN","VPR CORD2",79, 0)
  6248    ...S SAVE ARR(IEN,IN ST)="ORDIA LOG(""WP"" ,"_IEN_",1 )"
  6249   "RTN","VPR CORD2",80, 0)
  6250    ...S SAVE ARR("WP",I EN,INST,1, 0)=@VALUE@ (1,0)
  6251   "RTN","VPR CORD2",81, 0)
  6252    ..S SAVEA RR(IEN,INS T)=VALUE
  6253   "RTN","VPR CORD2",82, 0)
  6254    ..S EXT=$ $EXT^ORCD( IEN,INST)
  6255   "RTN","VPR CORD2",83, 0)
  6256    ..S ORDER CHK(CNT)=F ILLER_U_PR OMPT_U_VAL UE_U_EXT,C NT=CNT+1
  6257   "RTN","VPR CORD2",84, 0)
  6258    ..S RESUL T("structu re",INC,"i nstance",I NST,"numbe r")=INST
  6259   "RTN","VPR CORD2",85, 0)
  6260    ..S RESUL T("structu re",INC,"i nstance",I NST,"value ")=VALUE
  6261   "RTN","VPR CORD2",86, 0)
  6262    ..S RESUL T("structu re",INC,"i nstance",I NST,"exter nal")=EXT
  6263   "RTN","VPR CORD2",87, 0)
  6264    ..I PROMP T="ORDERAB LE" S OI=V ALUE
  6265   "RTN","VPR CORD2",88, 0)
  6266    ..W !,PRO MPT_" "_$G (VALUE)
  6267   "RTN","VPR CORD2",89, 0)
  6268    ..I PROMP T="DRUG" S  DRUG=$G(V ALUE)
  6269   "RTN","VPR CORD2",90, 0)
  6270    W !,FILLE R
  6271   "RTN","VPR CORD2",91, 0)
  6272    S ORDERCH K(1)=OI_U_ FILLER_U_$ S(FILLER[" PS":$G(DRU G),1:"")
  6273   "RTN","VPR CORD2",92, 0)
  6274    Q
  6275   "RTN","VPR CORD2",93, 0)
  6276    ;
  6277   "RTN","VPR CORD2",94, 0)
  6278    ;build pa tient demo graphic va riables
  6279   "RTN","VPR CORD2",95, 0)
  6280   BLDVAR(DFN ,LOC,DATE, OUTPUT) ;
  6281   "RTN","VPR CORD2",96, 0)
  6282    N IMO,TEM P
  6283   "RTN","VPR CORD2",97, 0)
  6284    I $L(DFN) '>0 S OUTP UT("PATIEN T")="" Q
  6285   "RTN","VPR CORD2",98, 0)
  6286    S TEMP=$G (^DPT(DFN, 0))
  6287   "RTN","VPR CORD2",99, 0)
  6288    I TEMP=""  S OUTPUT( "PATIENT") ="" Q
  6289   "RTN","VPR CORD2",100 ,0)
  6290    S OUTPUT( "PATIENT") =$P(TEMP,U ,1)
  6291   "RTN","VPR CORD2",101 ,0)
  6292    S OUTPUT( "SEX")=$P( TEMP,U,2)
  6293   "RTN","VPR CORD2",102 ,0)
  6294    S OUTPUT( "DOB")=$P( TEMP,U,3)
  6295   "RTN","VPR CORD2",103 ,0)
  6296    S OUTPUT( "SSN")=$P( TEMP,U,9)
  6297   "RTN","VPR CORD2",104 ,0)
  6298    S OUTPUT( "DOD")=$P( $G(^DPT(DF N,.35)),U, 1)
  6299   "RTN","VPR CORD2",105 ,0)
  6300    I OUTPUT( "DOD")>DAT E S OUTPUT ("DOD")=""
  6301   "RTN","VPR CORD2",106 ,0)
  6302    S OUTPUT( "DFN")=DFN
  6303   "RTN","VPR CORD2",107 ,0)
  6304    S OUTPUT( "AGE")=$$A GE^PXRMAGE (OUTPUT("D OB"),OUTPU T("DOD"),D ATE)
  6305   "RTN","VPR CORD2",108 ,0)
  6306    S OUTPUT( "ISINP")=$ S(+$G(^DPT (DFN,.1))> 0:1,1:0)
  6307   "RTN","VPR CORD2",109 ,0)
  6308    D IMOLOC^ ORIMO(.IMO ,LOC,DFN)
  6309   "RTN","VPR CORD2",110 ,0)
  6310    S OUTPUT( "ISIMO")=$ S(IMO>0:1, 1:0)
  6311   "RTN","VPR CORD2",111 ,0)
  6312    Q
  6313   "RTN","VPR CORD2",112 ,0)
  6314    ;
  6315   "RTN","VPR CORD2",113 ,0)
  6316   BLDJSON(RE SULT,ORDAR R,VPRPOSS, VPRVALUE,R EAS,UID,DA TA) ;
  6317   "RTN","VPR CORD2",114 ,0)
  6318    N CNT,ERR OR,STR,TEM P,TEXT
  6319   "RTN","VPR CORD2",115 ,0)
  6320    S RESULT( "success") ="true"
  6321   "RTN","VPR CORD2",116 ,0)
  6322    I REAS'=" ",UID'=""  D ARRREAS( REAS,UID)
  6323   "RTN","VPR CORD2",117 ,0)
  6324    I $D(VPRP OSS) D ADD POSS(.VPRP OSS)
  6325   "RTN","VPR CORD2",118 ,0)
  6326    I $D(ORDA RR) D
  6327   "RTN","VPR CORD2",119 ,0)
  6328    .S RESULT ("ordered  placed")=" true"
  6329   "RTN","VPR CORD2",120 ,0)
  6330    .S CNT=0  F  S CNT=$ O(ORDARR(C NT)) Q:CNT '>0  D
  6331   "RTN","VPR CORD2",121 ,0)
  6332    ..S TEMP= ORDARR(CNT ),STR=""
  6333   "RTN","VPR CORD2",122 ,0)
  6334    ..I $E(TE MP)="t" S  STR=$E(TEM P,2,$L(TEM P))
  6335   "RTN","VPR CORD2",123 ,0)
  6336    ..I STR'= "" S RESUL T("text")= $G(RESULT( "text"))_S TR_$C(13,1 0)
  6337   "RTN","VPR CORD2",124 ,0)
  6338    I $D(^TMP ($J,"ORDER  CHECKS"))  D
  6339   "RTN","VPR CORD2",125 ,0)
  6340    .S CNT=0  F  S CNT=$ O(^TMP($J, "ORDER CHE CKS",CNT))  Q:CNT'>0   D
  6341   "RTN","VPR CORD2",126 ,0)
  6342    ..S RESUL T("orderCh ecks")=$G( RESULT("or derChecks" ))_^TMP($J ,"ORDER CH ECKS",CNT) _$C(13,10)
  6343   "RTN","VPR CORD2",127 ,0)
  6344    I $D(DATA ) M RESULT ("data")=D ATA
  6345   "RTN","VPR CORD2",128 ,0)
  6346    D ENCODE^ VPRJSON("R ESULT","VP RVALUE","V PRERR")
  6347   "RTN","VPR CORD2",129 ,0)
  6348    I $D(VPRE RR) D
  6349   "RTN","VPR CORD2",130 ,0)
  6350    .K VPRVAL UE S TEXT( 1)="Proble m encoding  save orde r array. C heck CPRS  to see if  the order  was saved. "
  6351   "RTN","VPR CORD2",131 ,0)
  6352    .D SETERR OR^VPRUTIL S(.ERROR,. VPRERR,.TE XT,.DATA)
  6353   "RTN","VPR CORD2",132 ,0)
  6354    .D ENCODE ^VPRJSON(" ERROR","VP RVALUE","V PRERR")
  6355   "RTN","VPR CORD2",133 ,0)
  6356    Q
  6357   "RTN","VPR CORD2",134 ,0)
  6358    ;
  6359   "RTN","VPR CORD2",135 ,0)
  6360   CHANGE(ORD IEN,DFN,LO C,USER,ERR ARR) ;
  6361   "RTN","VPR CORD2",136 ,0)
  6362    N TEXT,VA LUE
  6363   "RTN","VPR CORD2",137 ,0)
  6364    D VALID^O RWDXA(.VAL UE,ORDIEN, "XX",USER)  I VALUE'= "" D AE^VP RCORD1(VAL UE,.VPRVAL UE) Q 0
  6365   "RTN","VPR CORD2",138 ,0)
  6366    D OFCPLX^ ORWDXA(.VA LUE,ORDIEN ) I VALUE' ="" D AE^V PRCORD1("C ANNOT CHAN GE A COMPL EX ORDER", .VPRVALUE)  Q 0
  6367   "RTN","VPR CORD2",139 ,0)
  6368    Q 1
  6369   "RTN","VPR CORD2",140 ,0)
  6370    ;
  6371   "RTN","VPR CORD2",141 ,0)
  6372   INFO(OCHKS ) ;
  6373   "RTN","VPR CORD2",142 ,0)
  6374    N INC,CNT ,NUM,NODE, TEMP,VPROR CK
  6375   "RTN","VPR CORD2",143 ,0)
  6376    S NUM=0,C NT=+$O(^TM P($J,"ORDE R CHECKS", ""),-1)
  6377   "RTN","VPR CORD2",144 ,0)
  6378    F  S NUM= $O(OCHKS(N UM)) Q:NUM '>0  D
  6379   "RTN","VPR CORD2",145 ,0)
  6380    .S NODE=$ P(OCHKS(NU M),U,4)
  6381   "RTN","VPR CORD2",146 ,0)
  6382    .I NODE=" " S NODE=O CHKS(NUM)
  6383   "RTN","VPR CORD2",147 ,0)
  6384    .S TEMP=" "
  6385   "RTN","VPR CORD2",148 ,0)
  6386    .I NODE[" ||",NODE[" &" D
  6387   "RTN","VPR CORD2",149 ,0)
  6388    ..S TEMP= $P(NODE,"& ")
  6389   "RTN","VPR CORD2",150 ,0)
  6390    ..S NODE= $P(NODE,"& ",2)
  6391   "RTN","VPR CORD2",151 ,0)
  6392    .S CNT=CN T+1
  6393   "RTN","VPR CORD2",152 ,0)
  6394    .S ^TMP($ J,"ORDER C HECKS",CNT )=NODE
  6395   "RTN","VPR CORD2",153 ,0)
  6396    .I TEMP'= "" D
  6397   "RTN","VPR CORD2",154 ,0)
  6398    ..D GETXT RA^ORCHECK (.VPRORCK, $P(TEMP,"| |",2),NODE )
  6399   "RTN","VPR CORD2",155 ,0)
  6400    ..S INC=0  F  S INC= $O(VPRORCK (INC)) Q:I NC'>0  D
  6401   "RTN","VPR CORD2",156 ,0)
  6402    ...S CNT= CNT+1
  6403   "RTN","VPR CORD2",157 ,0)
  6404    ...S ^TMP ($J,"ORDER  CHECKS",C NT)=VPRORC K(INC)
  6405   "RTN","VPR CORD2",158 ,0)
  6406    Q
  6407   "RTN","VPR CORD2",159 ,0)
  6408    ;
  6409   "RTN","VPR CORD2",160 ,0)
  6410   KILLALRT(D FN,TYPE) ;
  6411   "RTN","VPR CORD2",161 ,0)
  6412    N VPROUT
  6413   "RTN","VPR CORD2",162 ,0)
  6414    D KILUNSN O^ORWORB(. VPROUT,DFN ) K VPROUT
  6415   "RTN","VPR CORD2",163 ,0)
  6416    I TYPE["P S" D
  6417   "RTN","VPR CORD2",164 ,0)
  6418    . D KILEX MED^ORWORB (.VPROUT,D FN) K VPRO UT
  6419   "RTN","VPR CORD2",165 ,0)
  6420    . D KILUN VMD^ORWORB (.VPROUT,D FN) K VPRO UT
  6421   "RTN","VPR CORD2",166 ,0)
  6422    D KILUNVO R^ORWORB(. VPROUT,DFN ) K VPROUT
  6423   "RTN","VPR CORD2",167 ,0)
  6424    Q
  6425   "RTN","VPR CORD2",168 ,0)
  6426    ;build a  list of po ssible sel ection ite ms for a p rompt
  6427   "RTN","VPR CORD2",169 ,0)
  6428   LOADPOSS(D FN,LOC,OI, FILLER,VAR SARR,POSS)  ;
  6429   "RTN","VPR CORD2",170 ,0)
  6430    N CNT,DGI EN,ID,NUM, PROMPT,STR ,TYPE,VPRP OSS
  6431   "RTN","VPR CORD2",171 ,0)
  6432    S TYPE=$S (FILLER="P SO":"O",1: "I")
  6433   "RTN","VPR CORD2",172 ,0)
  6434    S NUM=0
  6435   "RTN","VPR CORD2",173 ,0)
  6436    S DGIEN=V ARSARR("DI SPLAY GROU P IEN")
  6437   "RTN","VPR CORD2",174 ,0)
  6438    I FILLER[ "PS" D OIS LCT^ORWDPS 2(.VPRPOSS ,OI,TYPE,D FN,"Y","N" )
  6439   "RTN","VPR CORD2",175 ,0)
  6440    I FILLER[ "LR" D DEF ^ORWDLR32( .VPRPOSS,L OC,"")
  6441   "RTN","VPR CORD2",176 ,0)
  6442    I FILLER[ "RA" D DEF ^ORWDRA32( .VPRPOSS,D FN,"",DGIE N)
  6443   "RTN","VPR CORD2",177 ,0)
  6444    S CNT=0
  6445   "RTN","VPR CORD2",178 ,0)
  6446    F  S CNT= $O(VPRPOSS (CNT)) Q:C NT'>0  D
  6447   "RTN","VPR CORD2",179 ,0)
  6448    .S NODE=V PRPOSS(CNT )
  6449   "RTN","VPR CORD2",180 ,0)
  6450    .S TEMP=$ E($G(NODE) ,2,$L(NODE ))
  6451   "RTN","VPR CORD2",181 ,0)
  6452    .I $E(NOD E)="~" D   Q
  6453   "RTN","VPR CORD2",182 ,0)
  6454    ..S NUM=0 ,PROMPT=$$ LOW^XLFSTR (TEMP)
  6455   "RTN","VPR CORD2",183 ,0)
  6456    ..S PROMP T=$TR(PROM PT," ","_" )
  6457   "RTN","VPR CORD2",184 ,0)
  6458    ..S POSS( PROMPT)=""
  6459   "RTN","VPR CORD2",185 ,0)
  6460    ..S NUM=0
  6461   "RTN","VPR CORD2",186 ,0)
  6462    .I PROMPT ="alldoses "!(PROMPT= "route") D   Q
  6463   "RTN","VPR CORD2",187 ,0)
  6464    ..S ID=TE MP
  6465   "RTN","VPR CORD2",188 ,0)
  6466    ..S TEMP= $S(PROMPT= "alldoses" :$P(TEMP,U ),PROMPT=" route":$P( TEMP,U,2), 1:TEMP)
  6467   "RTN","VPR CORD2",189 ,0)
  6468    ..S POSS( $$LOW^XLFS TR(PROMPT) ,NUM,"valu e")=TEMP
  6469   "RTN","VPR CORD2",190 ,0)
  6470    ..S POSS( $$LOW^XLFS TR(PROMPT) ,NUM,"id") =ID
  6471   "RTN","VPR CORD2",191 ,0)
  6472    ..S POSS( $$LOW^XLFS TR(PROMPT) ,NUM,"defa ult")=$S($ E(NODE)="d ":"true",1 :"false")
  6473   "RTN","VPR CORD2",192 ,0)
  6474    ..S NUM=N UM+1
  6475   "RTN","VPR CORD2",193 ,0)
  6476    .S POSS($ $LOW^XLFST R(PROMPT), NUM,"value ")=TEMP
  6477   "RTN","VPR CORD2",194 ,0)
  6478    .;S POSS( $$LOW^XLFS TR(PROMPT) ,NUM,"id") =ID
  6479   "RTN","VPR CORD2",195 ,0)
  6480    .S POSS($ $LOW^XLFST R(PROMPT), NUM,"defau lt")=$S($E (NODE)="d" :"true",1: "false")
  6481   "RTN","VPR CORD2",196 ,0)
  6482    .S NUM=NU M+1
  6483   "RTN","VPR CORD2",197 ,0)
  6484    ;build li st of poss ible sched ules
  6485   "RTN","VPR CORD2",198 ,0)
  6486    I FILLER[ "PS" D
  6487   "RTN","VPR CORD2",199 ,0)
  6488    .D SCHALL ^ORWDPS1(. SCH,DFN,LO C)
  6489   "RTN","VPR CORD2",200 ,0)
  6490    .S NUM=0
  6491   "RTN","VPR CORD2",201 ,0)
  6492    .S CNT=0  F  S CNT=$ O(SCH(CNT) ) Q:CNT'>0   D
  6493   "RTN","VPR CORD2",202 ,0)
  6494    ..S TEMP= SCH(CNT)
  6495   "RTN","VPR CORD2",203 ,0)
  6496    ..S POSS( "schedule" ,NUM,"valu e")=$P(TEM P,U)
  6497   "RTN","VPR CORD2",204 ,0)
  6498    ..S POSS( "schedule" ,NUM,"exte rnal")=$P( TEMP,U,2)
  6499   "RTN","VPR CORD2",205 ,0)
  6500    ..S POSS( "schedule" ,NUM,"type ")=$P(TEMP ,U,3)
  6501   "RTN","VPR CORD2",206 ,0)
  6502    ..S POSS( "schedule" ,NUM,"admi n")=$P(TEM P,U,4)
  6503   "RTN","VPR CORD2",207 ,0)
  6504    ..S NUM=N UM+1
  6505   "RTN","VPR CORD2",208 ,0)
  6506    Q
  6507   "RTN","VPR CORD2",209 ,0)
  6508    ;
  6509   "RTN","VPR CORD2",210 ,0)
  6510    ;;add pos sible code  values fr om the dia log to XML  return fo r each pro mpt
  6511   "RTN","VPR CORD2",211 ,0)
  6512   LOADPOSC(P ROMPT,CODE S,POSS) ;
  6513   "RTN","VPR CORD2",212 ,0)
  6514    N CNT,STR ,NUM,TEMP
  6515   "RTN","VPR CORD2",213 ,0)
  6516    S TEMP=$$ LOW^XLFSTR (PROMPT),P OSS(TEMP)= "",NUM=0,C NT=0
  6517   "RTN","VPR CORD2",214 ,0)
  6518    F X=1:1:$ L(CODES) I  $E(CODES, X)=";" D
  6519   "RTN","VPR CORD2",215 ,0)
  6520    .S CNT=CN T+1,STR=$P (CODES,";" ,CNT) Q:ST R=""
  6521   "RTN","VPR CORD2",216 ,0)
  6522    .S POSS(T EMP,NUM,"v alue")=$P( STR,":",2) ,POSS(TEMP ,NUM,"id") =$P(STR,": "),NUM=NUM +1
  6523   "RTN","VPR CORD2",217 ,0)
  6524    Q
  6525   "RTN","VPR CORD2",218 ,0)
  6526   PTR(NAME)  ; -- Retur ns ptr val ue of prom pt in Dial og file
  6527   "RTN","VPR CORD2",219 ,0)
  6528    Q +$O(^OR D(101.41," AB",$E("OR  GTX "_NAM E,1,63),0) )
  6529   "RTN","VPR CORD2",220 ,0)
  6530    ;
  6531   "RTN","VPR CORD2",221 ,0)
  6532   UNSIGNED(U IFN) ;queu e unsigned  order ale rt
  6533   "RTN","VPR CORD2",222 ,0)
  6534    N ORVP,OR IFN,ORNP,A
  6535   "RTN","VPR CORD2",223 ,0)
  6536    Q:$G(UIFN )=""  S A= $G(^OR(100 ,UIFN,0)), ORVP=$P(A, "^",2),ORN P=$P(A,"^" ,4),ORIFN= UIFN_";1"
  6537   "RTN","VPR CORD2",224 ,0)
  6538    D NOTIF^O RCSIGN
  6539   "RTN","VPR CORD2",225 ,0)
  6540    Q
  6541   "RTN","VPR CORD3")
  6542   0^45^B1513 71865
  6543   "RTN","VPR CORD3",1,0 )
  6544   VPRCORD3 ; ;SLC/AGP -  Process O rder Reque st from AV IVA System  ; 1/4/13
  6545   "RTN","VPR CORD3",2,0 )
  6546    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  6547   "RTN","VPR CORD3",3,0 )
  6548    ;
  6549   "RTN","VPR CORD3",4,0 )
  6550    ;
  6551   "RTN","VPR CORD3",5,0 )
  6552    Q
  6553   "RTN","VPR CORD3",6,0 )
  6554    ;
  6555   "RTN","VPR CORD3",7,0 )
  6556   BLDDIAL(OR DIALOG,DG, DIAL) ;
  6557   "RTN","VPR CORD3",8,0 )
  6558    D GETDLG^ ORCD(DIAL)
  6559   "RTN","VPR CORD3",9,0 )
  6560    Q
  6561   "RTN","VPR CORD3",10, 0)
  6562    ;
  6563   "RTN","VPR CORD3",11, 0)
  6564   BLDROUTE(V PRROUTE) ;
  6565   "RTN","VPR CORD3",12, 0)
  6566    N IEN,NOD E
  6567   "RTN","VPR CORD3",13, 0)
  6568    S IEN=0 F   S IEN=$O (^PS(51.2, IEN)) Q:IE N'>0  D
  6569   "RTN","VPR CORD3",14, 0)
  6570    .;I $L($G (^PS(51.2, IEN,1)))'= "" Q
  6571   "RTN","VPR CORD3",15, 0)
  6572    .S NODE=$ G(^PS(51.2 ,IEN,0))
  6573   "RTN","VPR CORD3",16, 0)
  6574    .S VPRROU TE($P(NODE ,U))=IEN_U _$S($P(NOD E,U)'="":$ P(NODE,U), 1:$P(NODE, U))
  6575   "RTN","VPR CORD3",17, 0)
  6576    .I $P(NOD E,U,2)'=""  S VPRROUT E($P(NODE, U,2))=IEN
  6577   "RTN","VPR CORD3",18, 0)
  6578    .I $P(NOD E,U,3)'=""  S VPRROUT E($P(NODE, U,3))=IEN
  6579   "RTN","VPR CORD3",19, 0)
  6580    Q
  6581   "RTN","VPR CORD3",20, 0)
  6582    ;
  6583   "RTN","VPR CORD3",21, 0)
  6584   BLDVALS(IN ,OUT,ERROR ) ;
  6585   "RTN","VPR CORD3",22, 0)
  6586    N NUM,LAS T,SPACES,S TR,X
  6587   "RTN","VPR CORD3",23, 0)
  6588    S LAST=""
  6589   "RTN","VPR CORD3",24, 0)
  6590    S NUM=$L( IN,";")
  6591   "RTN","VPR CORD3",25, 0)
  6592    F X=1:1:N UM D
  6593   "RTN","VPR CORD3",26, 0)
  6594    .;W !,X_"  "_$P(IN," :",X)
  6595   "RTN","VPR CORD3",27, 0)
  6596    .S STR=$P (IN,";",X)
  6597   "RTN","VPR CORD3",28, 0)
  6598    .I X=1 S  OUT(STR)=" " S LAST=S TR Q
  6599   "RTN","VPR CORD3",29, 0)
  6600    .I X=NUM  S OUT(LAST )=STR Q
  6601   "RTN","VPR CORD3",30, 0)
  6602    .S SPACES =$L(STR,"  ")
  6603   "RTN","VPR CORD3",31, 0)
  6604    .I LAST'= "" S OUT(L AST)=$P(ST R," ",1,SP ACES-1)
  6605   "RTN","VPR CORD3",32, 0)
  6606    .S LAST=$ P(STR," ", SPACES)
  6607   "RTN","VPR CORD3",33, 0)
  6608    Q
  6609   "RTN","VPR CORD3",34, 0)
  6610    ;
  6611   "RTN","VPR CORD3",35, 0)
  6612   GETOCPKG(V PRTYPE) ;
  6613   "RTN","VPR CORD3",36, 0)
  6614    N RESULT
  6615   "RTN","VPR CORD3",37, 0)
  6616    S RESULT= $S(VPRTYPE ="UD RX":" PSI",VPRTY PE="O RX": "PSO",VPRT YPE="NV RX ":"PSH",1: VPRTYPE)
  6617   "RTN","VPR CORD3",38, 0)
  6618    Q RESULT
  6619   "RTN","VPR CORD3",39, 0)
  6620    ;
  6621   "RTN","VPR CORD3",40, 0)
  6622   GETSET(TYP E) ;
  6623   "RTN","VPR CORD3",41, 0)
  6624    S RESULT= $S(TYPE="I NPATIENT M EDS":"UD R X",TYPE="O UTPATIENT  MEDS":"O R X",TYPE="M EDICATIONS ":"RX",TYP E="NON-VA  MEDS":"NV  RX",1:TYPE )
  6625   "RTN","VPR CORD3",42, 0)
  6626    Q RESULT
  6627   "RTN","VPR CORD3",43, 0)
  6628    ;
  6629   "RTN","VPR CORD3",44, 0)
  6630   EN(VPRVALU E,PARAMS)  ;
  6631   "RTN","VPR CORD3",45, 0)
  6632    N DG,DIAL ,DLGNAME,E RROR,FAIL, ISIMO,LOC, OIIEN,ORDE RSTR,ORDIA LOG,PAT,PA RDG,TEMPTY PE,VPRCHEC K,VPROREST ,VPRTEMP,V PRTYPE,TYP E,VALUES
  6633   "RTN","VPR CORD3",46, 0)
  6634    K ^TMP("V PRWORD",$J ),^TMP("VP RSIG",$J), ^TMP($J,"O RDER CHECK S")
  6635   "RTN","VPR CORD3",47, 0)
  6636    S ORDERST R=$$UP^XLF STR($G(PAR AMS("order String")))  I $G(ORDE RSTR)="" D  AE^VPRCOR D1("No ord er string  found",.ER ROR) G ENX
  6637   "RTN","VPR CORD3",48, 0)
  6638    S TYPE=$$ UP^XLFSTR( $G(PARAMS( "type")))  I TYPE=""  D AE^VPRCO RD1("No or der type f ound",.VPR VALUE) G E NX
  6639   "RTN","VPR CORD3",49, 0)
  6640    S PAT=$G( PARAMS("pa tient")),L OC=$G(PARA MS("locati on")),USER =1089
  6641   "RTN","VPR CORD3",50, 0)
  6642    ;
  6643   "RTN","VPR CORD3",51, 0)
  6644    D IMOLOC^ ORIMO(.VPR TEMP,LOC,P AT) S ISIM O=VPRTEMP
  6645   "RTN","VPR CORD3",52, 0)
  6646    ;builds o rder order  values ar ray this c ode needs  to be enha nced someh ow
  6647   "RTN","VPR CORD3",53, 0)
  6648    D BLDVALS (ORDERSTR, .VALUES,.E RROR) I $D (ERROR) G  ENX
  6649   "RTN","VPR CORD3",54, 0)
  6650    S VALUES( "LOCATION" )=LOC
  6651   "RTN","VPR CORD3",55, 0)
  6652    I $D(PARA MS("COMMEN TS")) M VA LUES("COMM ENTS")=PAR AMS("COMME NTS")
  6653   "RTN","VPR CORD3",56, 0)
  6654    I $D(VALU ES("QO"))  D QO(.ERRO R,.VALUES, LOC,PAT,IS IMO,.ORD)  G ENX
  6655   "RTN","VPR CORD3",57, 0)
  6656    S VPRTYPE =$$GETSET( TYPE) I VP RTYPE="" D  AE^VPRCOR D1("Cannot  find orde r package. ",.ERROR)  G ENX
  6657   "RTN","VPR CORD3",58, 0)
  6658    S DG=$O(^ ORD(100.98 ,"B",VPRTY PE,"")) I  DG="" D AE ^VPRCORD1( "Cannot fi nd display  group.",. ERROR) G E NX
  6659   "RTN","VPR CORD3",59, 0)
  6660    S TEMPTYP E="" I VPR TYPE=TYPE  S TEMPTYPE =$P(^ORD(1 00.98,DG,0 ),U,3)
  6661   "RTN","VPR CORD3",60, 0)
  6662    S OIIEN=+ $$VALIDOI( .VALUES,$S (TEMPTYPE' ="":TEMPTY PE,1:VPRTY PE)) I OII EN<1 D AE^ VPRCORD1(" Cannot fin d valid OI ",.ERROR)  G ENX
  6663   "RTN","VPR CORD3",61, 0)
  6664    S VALUES( "ORDERABLE  ITEM")=OI IEN_U_VALU ES("OI")
  6665   "RTN","VPR CORD3",62, 0)
  6666    ;
  6667   "RTN","VPR CORD3",63, 0)
  6668    ;get disp lay group  info and d ialog info rmation
  6669   "RTN","VPR CORD3",64, 0)
  6670    S FAIL=0, DIAL=+$P($ G(^ORD(100 .98,DG,0)) ,U,4) I DI AL<1 D  I  FAIL=1 D A E^VPRCORD1 ("Cannot f ind dialog .",.ERROR)  G ENX
  6671   "RTN","VPR CORD3",65, 0)
  6672    .S PARDG= $O(^ORD(10 0.98,"AD", DG,"")) I  PARDG'>0 S  FAIL=1 Q
  6673   "RTN","VPR CORD3",66, 0)
  6674    .S DIAL=+ $P($G(^ORD (100.98,PA RDG,0)),U, 4) I DIAL< 1 S FAIL=1
  6675   "RTN","VPR CORD3",67, 0)
  6676    S DLGNAME =$P($G(^OR D(101.41,D IAL,0)),U)
  6677   "RTN","VPR CORD3",68, 0)
  6678    ;
  6679   "RTN","VPR CORD3",69, 0)
  6680    ;get pack age inform ation
  6681   "RTN","VPR CORD3",70, 0)
  6682    S PKGID=$ P(^ORD(101 .41,DIAL,0 ),U,7) I P KGID<0 D A E^VPRCORD1 ("Cannot f ind packag e",.ERROR)  G ENX
  6683   "RTN","VPR CORD3",71, 0)
  6684    S PKGNAME =$P(^DIC(9 .4,PKGID,0 ),U,2) I P KGNAME=""  D AE^VPRCO RD1("Canno t find pac kage name" ,.ERROR) G  ENX
  6685   "RTN","VPR CORD3",72, 0)
  6686    ;
  6687   "RTN","VPR CORD3",73, 0)
  6688    ;create O RDIALOG ar ray
  6689   "RTN","VPR CORD3",74, 0)
  6690    D BLDDIAL (.ORDIALOG ,DG,DIAL)  I '$D(ORDI ALOG) D AE ^VPRCORD1( "Could not  build ORD IALOG arra y",.ERROR)  G ENX
  6691   "RTN","VPR CORD3",75, 0)
  6692    ;populate  ORDIALOG  array with  values
  6693   "RTN","VPR CORD3",76, 0)
  6694    I $$POPDI AL(.ERROR, .ORDIALOG, .VPRCHECK, .VALUES,VP RTYPE,OIIE N,PAT,LOC) <1 G ENX
  6695   "RTN","VPR CORD3",77, 0)
  6696    ;
  6697   "RTN","VPR CORD3",78, 0)
  6698    D PERCHCK S(.ERROR,. ORDIALOG,. VPRCHECK,P AT,LOC,USE R,DIAL,DLG NAME,DG,PK GID,PKGNAM E,OIIEN,"N ") I $D(ER ROR) G ENX
  6699   "RTN","VPR CORD3",79, 0)
  6700    ;
  6701   "RTN","VPR CORD3",80, 0)
  6702    D SAVE(.V PROREST,PA T,USER,LOC ,DLGNAME,D G,OIIEN,0, .ORDIALOG, .ORD)
  6703   "RTN","VPR CORD3",81, 0)
  6704    ;
  6705   "RTN","VPR CORD3",82, 0)
  6706   ENX ;
  6707   "RTN","VPR CORD3",83, 0)
  6708    I $D(ERRO R) D ENCOD E^VPRJSON( "ERROR","V PRVALUE"," VPRERR") Q
  6709   "RTN","VPR CORD3",84, 0)
  6710    ;I $D(ERR OR) M VPRV ALUE=ERROR  Q
  6711   "RTN","VPR CORD3",85, 0)
  6712    D BLDJSON ^VPRCORD2( "",.VPRORE ST,"",.VPR VALUE,""," ",.ORD)
  6713   "RTN","VPR CORD3",86, 0)
  6714    Q
  6715   "RTN","VPR CORD3",87, 0)
  6716    ;
  6717   "RTN","VPR CORD3",88, 0)
  6718   ORDRCHKS(P AT,VPROIFN ,VPRPKG,LO C,ORDIALOG ,VPRCHECK)  ;
  6719   "RTN","VPR CORD3",89, 0)
  6720    N A,OCO,O CLIST,ORIN FO,ORL,OCH KS,PATTYPE ,VPRREN,VP RPOSS
  6721   "RTN","VPR CORD3",90, 0)
  6722    S PATTYPE =$S(+$G(^D PT(PAT,.1) )>0:"I",1: "O")
  6723   "RTN","VPR CORD3",91, 0)
  6724    D ON^ORWD XC(.OCO)
  6725   "RTN","VPR CORD3",92, 0)
  6726    D DISPLAY ^ORWDXC(.O CLIST,PAT, VPRPKG) I  $D(OCLIST)  D INFO^VP RCORD2(.OC LIST)
  6727   "RTN","VPR CORD3",93, 0)
  6728    D ACCEPT^ ORWDXC(.OC HKS,PAT,VP RPKG,PATTY PE,LOC,.VP RCHECK,VPR OIFN,0) I  $D(OCHKS)  D INFO^VPR CORD2(.OCH KS)
  6729   "RTN","VPR CORD3",94, 0)
  6730    Q
  6731   "RTN","VPR CORD3",95, 0)
  6732    ;
  6733   "RTN","VPR CORD3",96, 0)
  6734   PERCHCKS(E RROR,ORDIA LOG,VPRCHE CK,PAT,LOC ,USER,DIAL ,DLGNAME,D G,PKGID,PK GNAME,OIIE N,ORTYPE)  ;
  6735   "RTN","VPR CORD3",97, 0)
  6736    D NPHASKE Y^ORWU(.HA SKEY,USER, "PROVIDER" ) I HASKEY =0 D AE^VP RCORD1("DO ES NOT HOL D THE PROV IDER KEY", .ERROR) Q
  6737   "RTN","VPR CORD3",98, 0)
  6738    D ALLWORD ^ORALWORD( .VPROK,USE R,OIIEN,OR TYPE,USER)  I $G(VPRO K)>0 D AEM ^VPRCORD1( .VPROK,.ER ROR) Q
  6739   "RTN","VPR CORD3",99, 0)
  6740    D ORDRCHK S(PAT,OIIE N,PKGNAME, LOC,.ORDIA LOG,.VPRCH ECK)
  6741   "RTN","VPR CORD3",100 ,0)
  6742    Q
  6743   "RTN","VPR CORD3",101 ,0)
  6744    ;
  6745   "RTN","VPR CORD3",102 ,0)
  6746   POPDIAL(ER ROR,ORDIAL OG,VPRCHEC K,VALUES,V PRTYPE,OII EN,PAT,LOC ) ;
  6747   "RTN","VPR CORD3",103 ,0)
  6748    N CNT,NAM E,NODE,NUM ,OCPKG,PTR ,RESULT,TE MP,WP
  6749   "RTN","VPR CORD3",104 ,0)
  6750    S RESULT= 0
  6751   "RTN","VPR CORD3",105 ,0)
  6752    I VPRTYPE ["RX" S RE SULT=$$PS( .ERROR,.OR DIALOG,.VA LUES,VPRTY PE,OIIEN,P AT,LOC) I  RESULT=0 Q  0
  6753   "RTN","VPR CORD3",106 ,0)
  6754    S RESULT= $$ORDDIAL( .ERROR,.OR DIALOG,.VA LUES,VPRTY PE,OIIEN,P AT,LOC) I  RESULT=0 Q  0
  6755   "RTN","VPR CORD3",107 ,0)
  6756    ;
  6757   "RTN","VPR CORD3",108 ,0)
  6758    S NAME=""  F  S NAME =$O(VALUES (NAME)) Q: NAME=""  D
  6759   "RTN","VPR CORD3",109 ,0)
  6760    .S PTR=+$ $PTR(NAME)  I PTR=0 Q
  6761   "RTN","VPR CORD3",110 ,0)
  6762    .I '$D(OR DIALOG(PTR )) Q
  6763   "RTN","VPR CORD3",111 ,0)
  6764    .S ORDIAL OG(PTR,1)= $P(VALUES( NAME),U)
  6765   "RTN","VPR CORD3",112 ,0)
  6766    .I NAME=" SIG"!(NAME ="WORD PRO CESSING 1" ) S ORDIAL OG(PTR,1)= VALUES(NAM E)
  6767   "RTN","VPR CORD3",113 ,0)
  6768    .S TEMP(P TR)=VALUES (NAME)
  6769   "RTN","VPR CORD3",114 ,0)
  6770    ;
  6771   "RTN","VPR CORD3",115 ,0)
  6772    D POPOC(. ERROR,.ORD IALOG,.TEM P,.VPRCHEC K,VPRTYPE, OIIEN)
  6773   "RTN","VPR CORD3",116 ,0)
  6774    Q RESULT
  6775   "RTN","VPR CORD3",117 ,0)
  6776    ;
  6777   "RTN","VPR CORD3",118 ,0)
  6778   POPOC(ERRO R,ORDIALOG ,TEMP,VPRC HECK,VPRTY PE,OIIEN)  ;
  6779   "RTN","VPR CORD3",119 ,0)
  6780    N CNT,NAM E,NODE,NUM ,OCPKG,PTR ,WP
  6781   "RTN","VPR CORD3",120 ,0)
  6782    S OCPKG=$ $GETOCPKG( $G(VPRTYPE )) I OCPKG ="" Q
  6783   "RTN","VPR CORD3",121 ,0)
  6784    S CNT=1 S  VPRCHECK( CNT)=OIIEN _U_OCPKG_U
  6785   "RTN","VPR CORD3",122 ,0)
  6786    S PTR=0 F   S PTR=$O (ORDIALOG( PTR)) Q:PT R'>0  D
  6787   "RTN","VPR CORD3",123 ,0)
  6788    .S NAME=$ P(ORDIALOG (PTR),U,2)  I NAME="C OMMENT" Q
  6789   "RTN","VPR CORD3",124 ,0)
  6790    .S CNT=CN T+1
  6791   "RTN","VPR CORD3",125 ,0)
  6792    .S NUM=0  F  S NUM=$ O(ORDIALOG (PTR,NUM))  Q:+NUM'>0   D
  6793   "RTN","VPR CORD3",126 ,0)
  6794    ..S NODE= OCPKG_U_NA ME_U_TEMP( PTR)
  6795   "RTN","VPR CORD3",127 ,0)
  6796    ..I NAME= "DRUG" S $ P(VPRCHECK (1),U,3)=T EMP(PTR)
  6797   "RTN","VPR CORD3",128 ,0)
  6798    ..I NAME= "SIG" D
  6799   "RTN","VPR CORD3",129 ,0)
  6800    ...S WP=T EMP(PTR)
  6801   "RTN","VPR CORD3",130 ,0)
  6802    ...I '$D( @WP@(1,0))  Q
  6803   "RTN","VPR CORD3",131 ,0)
  6804    ...S NODE =OCPKG_U_N AME_U_1_U_ U_"WP"_U_U _@WP@(1,0)
  6805   "RTN","VPR CORD3",132 ,0)
  6806    ..S VPRCH ECK(CNT)=N ODE
  6807   "RTN","VPR CORD3",133 ,0)
  6808    ;
  6809   "RTN","VPR CORD3",134 ,0)
  6810    Q RESULT
  6811   "RTN","VPR CORD3",135 ,0)
  6812    ;
  6813   "RTN","VPR CORD3",136 ,0)
  6814   ORDDIAL(ER ROR,ORDIAL OG,VALUES, VPRTYPE,OI IEN,PAT,LO C) ;
  6815   "RTN","VPR CORD3",137 ,0)
  6816    I $D(VALU ES("STARTD ATE")) S V ALUES("STA RT DATE/TI ME")=VALUE S("STARTDA TE") K VAL UES("START DATE")
  6817   "RTN","VPR CORD3",138 ,0)
  6818    I $D(VALU ES("PREOPD ATE")) S V ALUES("PRE -OP SCHEDU LED DATE/T IME")=VALU ES("PREOPD ATE") K VA LUES("PREO PDATE")
  6819   "RTN","VPR CORD3",139 ,0)
  6820    I $D(VALU ES("SUBMIT ")) S VALU ES("IMAGIN G LOCATION ")=VALUES( "SUBMIT")  K VALUES(" SUBMIT")
  6821   "RTN","VPR CORD3",140 ,0)
  6822    I $D(VALU ES("TRANSP ORT")) S V ALUES("MOD E OF TRANS PORT")=VAL UES("TRANS PORT") K V ALUES("TRA NSPORT")
  6823   "RTN","VPR CORD3",141 ,0)
  6824    I $D(VALU ES("ISOLAT ION")) S V ALUES("YES /NO")=VALU ES("ISOLAT ION") K VA LUES("ISOL ATION")
  6825   "RTN","VPR CORD3",142 ,0)
  6826    I $D(VALU ES("REASON STUDY")) S  VALUES("S TUDY REASO N")=VALUES ("REASONST UDY") K VA LUES("REAS ONSTUDY")
  6827   "RTN","VPR CORD3",143 ,0)
  6828    I '$D(VAL UES("URGEN CY")) S VA LUES("URGE NCY")=9
  6829   "RTN","VPR CORD3",144 ,0)
  6830    I $D(VALU ES("COMMEN TS")) D
  6831   "RTN","VPR CORD3",145 ,0)
  6832    .S ^TMP(" VPRWORD",$ J,1,0)=VAL UES("COMME NTS")
  6833   "RTN","VPR CORD3",146 ,0)
  6834    .S VALUES ("WORD PRO CESSING 1" )=$NA(^TMP ("VPRWORD" ,$J))
  6835   "RTN","VPR CORD3",147 ,0)
  6836    .K VALUES ("COMMENT" )
  6837   "RTN","VPR CORD3",148 ,0)
  6838    Q 1
  6839   "RTN","VPR CORD3",149 ,0)
  6840    ;
  6841   "RTN","VPR CORD3",150 ,0)
  6842   PS(ERROR,O RDIALOG,VA LUES,VPRTY PE,OIIEN,P AT,LOC) ;
  6843   "RTN","VPR CORD3",151 ,0)
  6844    N ARRAY,C NT,DOSE,DO SENODE,DOS ESTR,DRUG, FAIL,FOUND ,NODE,PRIO RITY,ROUTE ,ROUTEIEN, SCH,TEMP,V AL,VPRLST, VPRPRIOR,V PRROUTE,VP RSCH
  6845   "RTN","VPR CORD3",152 ,0)
  6846    S FAIL=0
  6847   "RTN","VPR CORD3",153 ,0)
  6848    I $D(VALU ES("STARTD ATE")) S V ALUES("STA RT DATE/TI ME")=VALUE S("STARTDA TE") K VAL UES("START DATE")
  6849   "RTN","VPR CORD3",154 ,0)
  6850    D SCHALL^ ORWDPS1(.V PRSCH,PAT, LOC)
  6851   "RTN","VPR CORD3",155 ,0)
  6852    D ODSLCT^ ORWDPS1(.V PRPRIOR,$E (VPRTYPE), PAT,LOC)
  6853   "RTN","VPR CORD3",156 ,0)
  6854    D OISLCT^ ORWDPS2(.V PRLST,OIIE N,$E(VPRTY PE),PAT,"Y ","N")
  6855   "RTN","VPR CORD3",157 ,0)
  6856    D BLDROUT E(.VPRROUT E)
  6857   "RTN","VPR CORD3",158 ,0)
  6858    S VALUES( "INSTRUCTI ONS")=$G(V ALUES("DOS E"))_U_$G( VALUES("DO SE")) K VA LUES("DOSE S")
  6859   "RTN","VPR CORD3",159 ,0)
  6860    ;
  6861   "RTN","VPR CORD3",160 ,0)
  6862   PSROUTE ;s et route
  6863   "RTN","VPR CORD3",161 ,0)
  6864    I '$D(VAL UES("ROUTE ")),VPRTYP E="NV RX"  G PSSCH
  6865   "RTN","VPR CORD3",162 ,0)
  6866    S TEMP=$G (VALUES("R OUTE"))
  6867   "RTN","VPR CORD3",163 ,0)
  6868    S ROUTEIE N=+$G(VPRR OUTE(TEMP) ) I ROUTEI EN<1 D AE^ VPRCORD1(" Could not  find a val id route", .ERROR) S  FAIL=1
  6869   "RTN","VPR CORD3",164 ,0)
  6870    S ROUTE=$ S(VPRTYPE' ["UD":$P(V PRROUTE(VA LUES("ROUT E")),U,2), 1:TEMP)
  6871   "RTN","VPR CORD3",165 ,0)
  6872    I ROUTE=" " S ROUTE= TEMP
  6873   "RTN","VPR CORD3",166 ,0)
  6874    S VALUES( "ROUTE")=R OUTEIEN_U_ TEMP
  6875   "RTN","VPR CORD3",167 ,0)
  6876    ;
  6877   "RTN","VPR CORD3",168 ,0)
  6878   PSURG ;bui ld urgency  value
  6879   "RTN","VPR CORD3",169 ,0)
  6880    S CNT=0,F OUND=0,PRI OR=0 F  S  CNT=$O(VPR PRIOR(CNT) ) Q:CNT'>0 !(FOUND=1)   D
  6881   "RTN","VPR CORD3",170 ,0)
  6882    .S NODE=V PRPRIOR(CN T) I NODE= "~Priority " S PRIOR= 1
  6883   "RTN","VPR CORD3",171 ,0)
  6884    .I PRIOR= 0 Q
  6885   "RTN","VPR CORD3",172 ,0)
  6886    .I $E(NOD E)="~"
  6887   "RTN","VPR CORD3",173 ,0)
  6888    .I $G(VAL UES("URGEN CY"))'=""  D  Q
  6889   "RTN","VPR CORD3",174 ,0)
  6890    ..I $P(NO DE,U,2)'=V ALUES("URG ENCY") Q
  6891   "RTN","VPR CORD3",175 ,0)
  6892    ..S TEMP= $P(NODE,U)  S VALUES( "URGENCY") =$E(TEMP,2 ,$L(TEMP))  S FOUND=1
  6893   "RTN","VPR CORD3",176 ,0)
  6894    .I $E(NOD E)="i" Q
  6895   "RTN","VPR CORD3",177 ,0)
  6896    .S TEMP=$ P(NODE,U)  S VALUES(" URGENCY")= $E(TEMP,2, $L(TEMP))  S FOUND=1
  6897   "RTN","VPR CORD3",178 ,0)
  6898    ;
  6899   "RTN","VPR CORD3",179 ,0)
  6900   PSSCH ;pop ulate addi tional sch edule fiel ds for inp atient med s
  6901   "RTN","VPR CORD3",180 ,0)
  6902    ;TODO mov e to sub-r outine to  handle Day s of Weeks  schedules
  6903   "RTN","VPR CORD3",181 ,0)
  6904    I '$D(VAL UES("SCHED ULE")),VPR TYPE="NV R X" G PSSCO M
  6905   "RTN","VPR CORD3",182 ,0)
  6906    S CNT=0,F OUND=0 F   S CNT=$O(V PRSCH(CNT) ) Q:CNT'>0 !(FOUND=1)   D
  6907   "RTN","VPR CORD3",183 ,0)
  6908    .S NODE=$ G(VPRSCH(C NT)) I $P( NODE,U)'=V ALUES("SCH EDULE") Q
  6909   "RTN","VPR CORD3",184 ,0)
  6910    .S VALUES ("SCHEDULE  TYPE")=$P (NODE,U,3) _U_$P(NODE ,U,3),VALU ES("ADMIN  TIMES")=$P (NODE,U,4) _U_$P(NODE ,U,4),VALU ES("SCHEDU LE")=VALUE S("SCHEDUL E")_U_VALU ES("SCHEDU LE")
  6911   "RTN","VPR CORD3",185 ,0)
  6912    .S SCH=$S (VPRTYPE'[ "UD":$P(NO DE,U,2),1: $P(NODE,U) )
  6913   "RTN","VPR CORD3",186 ,0)
  6914    .S FOUND= 1
  6915   "RTN","VPR CORD3",187 ,0)
  6916    ;
  6917   "RTN","VPR CORD3",188 ,0)
  6918   PSSCOM ;
  6919   "RTN","VPR CORD3",189 ,0)
  6920    I $D(VALU ES("COMMEN TS")) D
  6921   "RTN","VPR CORD3",190 ,0)
  6922    .S ^TMP(" VPRWORD",$ J,1,0)=VAL UES("COMME NTS")
  6923   "RTN","VPR CORD3",191 ,0)
  6924    .S VALUES ("WORD PRO CESSING 1" )=$NA(^TMP ("VPRWORD" ,$J))
  6925   "RTN","VPR CORD3",192 ,0)
  6926    .K VALUES ("COMMENT" )
  6927   "RTN","VPR CORD3",193 ,0)
  6928    ;
  6929   "RTN","VPR CORD3",194 ,0)
  6930   PSDRUG ;po pulate add itional fe lds based  off the do se
  6931   "RTN","VPR CORD3",195 ,0)
  6932    S CNT=0,F OUND=0,DOS ENODE=0 F   S CNT=$O( VPRLST(CNT )) Q:CNT'> 0!(FOUND=1 )  D
  6933   "RTN","VPR CORD3",196 ,0)
  6934    .S NODE=V PRLST(CNT)  I NODE="~ AllDoses"  S DOSENODE =1
  6935   "RTN","VPR CORD3",197 ,0)
  6936    .I DOSENO DE=0 Q
  6937   "RTN","VPR CORD3",198 ,0)
  6938    .I $E(NOD E)="~" Q
  6939   "RTN","VPR CORD3",199 ,0)
  6940    .S DOSE=$ P(NODE,U)  S DOSE=$E( DOSE,2,$L( DOSE))
  6941   "RTN","VPR CORD3",200 ,0)
  6942    .I $P(VAL UES("INSTR UCTIONS"), U)'=DOSE Q
  6943   "RTN","VPR CORD3",201 ,0)
  6944    .S VALUES ("DISPENSE  DRUG")=$P (NODE,U,2)
  6945   "RTN","VPR CORD3",202 ,0)
  6946    .S VALUES ("DOSE")=$ P(NODE,U,3 )
  6947   "RTN","VPR CORD3",203 ,0)
  6948   PSO ;handl e outpatie nt meds
  6949   "RTN","VPR CORD3",204 ,0)
  6950    I $D(VALU ES("SUPPLY ")) D
  6951   "RTN","VPR CORD3",205 ,0)
  6952    .N CNT,DR G,PRIOR,PT R,QUANTITY ,SUP,UPD,X
  6953   "RTN","VPR CORD3",206 ,0)
  6954    .S DRG=$G (VALUES("D ISPENSE DR UG")),SUP= VALUES("SU PPLY")
  6955   "RTN","VPR CORD3",207 ,0)
  6956    .K VALUES ("SUPPLY")
  6957   "RTN","VPR CORD3",208 ,0)
  6958    .;get qua ntity do a  check to  determine  if it is v alid range  or if one  is not de fined
  6959   "RTN","VPR CORD3",209 ,0)
  6960    .;potenti ally need  to add cod e to handl e complex  orders
  6961   "RTN","VPR CORD3",210 ,0)
  6962    .S UPD=$P (VALUES("D OSE"),"&", 3)
  6963   "RTN","VPR CORD3",211 ,0)
  6964    .D DAY2QT Y^ORWDPS2( .VAL,SUP,U PD_U,$P(VA LUES("SCHE DULE"),U)_ U,"~^",PAT ,DRG)
  6965   "RTN","VPR CORD3",212 ,0)
  6966    .S QUANTI TY=+$G(VAL UES("QUANT ITY"))
  6967   "RTN","VPR CORD3",213 ,0)
  6968    .I QUANTI TY=0 S VAL UES("QUANT ITY")=+VAL
  6969   "RTN","VPR CORD3",214 ,0)
  6970    .I QUANTI TY>0 S VAL UES("QUANT ITY")=$S(Q UANTITY<VA L:QUANTITY ,+VAL=0:QU ANTITY,1:V AL)
  6971   "RTN","VPR CORD3",215 ,0)
  6972    .S VALUES ("DAYS SUP PLY")=SUP
  6973   "RTN","VPR CORD3",216 ,0)
  6974    .I +$G(VA LUES("DAYS  SUPPLY")) =0 D AE^VP RCORD1("Da ys Supply  must be gr eater then  zero",.ER ROR) S FAI L=1
  6975   "RTN","VPR CORD3",217 ,0)
  6976    .I +$G(VA LUES("QUAN TITY"))=0  D AE^VPRCO RD1("Quant ity must b e greater  then zero" ,.ERROR) S  FAIL=1
  6977   "RTN","VPR CORD3",218 ,0)
  6978    .;
  6979   "RTN","VPR CORD3",219 ,0)
  6980    .;check r efill valu es to make  sure it i s in range
  6981   "RTN","VPR CORD3",220 ,0)
  6982    .I +$G(VA LUES("REFI LLS"))>0 D
  6983   "RTN","VPR CORD3",221 ,0)
  6984    ..K VAL
  6985   "RTN","VPR CORD3",222 ,0)
  6986    ..D MAXRE F^ORWDPS2( .VAL,PAT,D RG,SUP,OII EN,0)
  6987   "RTN","VPR CORD3",223 ,0)
  6988    ..I VALUE S("REFILLS ")>VAL S V ALUES("REF ILLS")=VAL
  6989   "RTN","VPR CORD3",224 ,0)
  6990    .I +$G(VA LUES("REFI LLS"))=0 S  VALUES("R EFILLS")=0
  6991   "RTN","VPR CORD3",225 ,0)
  6992    .I $D(VAL UES("ROUTI NE")) D
  6993   "RTN","VPR CORD3",226 ,0)
  6994    ..S PTR=$ $PTR("ROUT ING") I PT R'>0 Q
  6995   "RTN","VPR CORD3",227 ,0)
  6996    ..S NODE= $P($G(^ORD (101.41,PT R,1)),U,2)  I NODE=""  Q
  6997   "RTN","VPR CORD3",228 ,0)
  6998    ..S CNT=$ L(NODE,";" )-1
  6999   "RTN","VPR CORD3",229 ,0)
  7000    ..F X=1:1 :CNT D
  7001   "RTN","VPR CORD3",230 ,0)
  7002    ...S TEMP =$P(NODE," ;",X) I TE MP="" Q
  7003   "RTN","VPR CORD3",231 ,0)
  7004    ...S ARRA Y($P(TEMP, ":",2))=$P (TEMP,":")
  7005   "RTN","VPR CORD3",232 ,0)
  7006    ...I $D(A RRAY(VALUE S("ROUTING "))) S VAL UES("ROUTI NG")=ARRAY (VALUES("R OUTING"))
  7007   "RTN","VPR CORD3",233 ,0)
  7008    .;
  7009   "RTN","VPR CORD3",234 ,0)
  7010    .;check f or valid r outing val ue or set  a default  value
  7011   "RTN","VPR CORD3",235 ,0)
  7012    .I '$D(VA LUES("ROUT ING")) D
  7013   "RTN","VPR CORD3",236 ,0)
  7014    ..S CNT=0 ,FOUND=0,P RIOR=0 F   S CNT=$O(V PRPRIOR(CN T)) Q:CNT' >0!(FOUND= 1)  D
  7015   "RTN","VPR CORD3",237 ,0)
  7016    ...S NODE =VPRPRIOR( CNT) I NOD E="~Pickup " S PRIOR= 1
  7017   "RTN","VPR CORD3",238 ,0)
  7018    ...I PRIO R=0 Q
  7019   "RTN","VPR CORD3",239 ,0)
  7020    ...I $E(N ODE)="~" Q
  7021   "RTN","VPR CORD3",240 ,0)
  7022    ...S TEMP =$P(NODE,U ) S VALUES ("ROUTING" )=$E(TEMP, 2,$L(TEMP) ) S FOUND= 1
  7023   "RTN","VPR CORD3",241 ,0)
  7024    ;
  7025   "RTN","VPR CORD3",242 ,0)
  7026    I FAIL>0  Q 0
  7027   "RTN","VPR CORD3",243 ,0)
  7028   PSSIG ;bui ld sig val ue
  7029   "RTN","VPR CORD3",244 ,0)
  7030    N WP
  7031   "RTN","VPR CORD3",245 ,0)
  7032    S ^TMP("V PRSIG",$J, 0,0)=$P(VA LUES("INST RUCTIONS") ,U)
  7033   "RTN","VPR CORD3",246 ,0)
  7034    I $G(ROUT E)'="" S ^ TMP("VPRSI G",$J,1,0) =ROUTE
  7035   "RTN","VPR CORD3",247 ,0)
  7036    I $G(SCH)  S ^TMP("V PRSIG",$J, 1,0)=$S($G (^TMP("VPR SIG",$J,1, 0))'="":^T MP("VPRSIG ",$J,1,0)_ " "_SCH,1: SCH)
  7037   "RTN","VPR CORD3",248 ,0)
  7038    I $D(VALU ES("WORD P ROCESSING  1")) D
  7039   "RTN","VPR CORD3",249 ,0)
  7040    .S WP=VAL UES("WORD  PROCESSING  1")
  7041   "RTN","VPR CORD3",250 ,0)
  7042    .S CNT=1, NUM=1 F  S  CNT=$O(@W P@(CNT)) Q :CNT'>0  D
  7043   "RTN","VPR CORD3",251 ,0)
  7044    ..S NUM=N UM+1 S ^TM P("VPRSIG" ,$J,NUM,0) =@WP@(CNT, 0)
  7045   "RTN","VPR CORD3",252 ,0)
  7046    S VALUES( "SIG")=$NA (^TMP("VPR SIG",$J))
  7047   "RTN","VPR CORD3",253 ,0)
  7048    Q 1
  7049   "RTN","VPR CORD3",254 ,0)
  7050    ;
  7051   "RTN","VPR CORD3",255 ,0)
  7052   QO(ERROR,V ALUES,LOC, PAT,ISIMO, ORD) ;
  7053   "RTN","VPR CORD3",256 ,0)
  7054    N BLDRES, DEFIEN,DIE N,IEN,PKGI D,PKGNAME, VARSARR,VP ROREST,VPR CHECK
  7055   "RTN","VPR CORD3",257 ,0)
  7056    S IEN=+$O (^ORD(101. 41,"B",VAL UES("QO"), "")) I IEN '>0 D AE^V PRCORD1("C ould not f ind QO",.E RROR) Q
  7057   "RTN","VPR CORD3",258 ,0)
  7058    ;
  7059   "RTN","VPR CORD3",259 ,0)
  7060    D BEG^VPR CORD2(PAT, LOC,IEN,US ER,.VARSAR R,.BLDRES, .VPRVALUE)  I $D(ERRO R) Q
  7061   "RTN","VPR CORD3",260 ,0)
  7062    S PKGID=+ $P($G(^ORD (101.41,IE N,0)),U,7)  I PKGID'> 0 D AE^VPR CORD1("Cou ld not fin d package  for the QO ",.ERROR)  Q
  7063   "RTN","VPR CORD3",261 ,0)
  7064    S PKGNAME =$P(^DIC(9 .4,PKGID,0 ),U,2) I P KGNAME=""  D AE^VPRCO RD1("Canno t find pac kage name" ,.VPRVALUE ) Q
  7065   "RTN","VPR CORD3",262 ,0)
  7066    ;
  7067   "RTN","VPR CORD3",263 ,0)
  7068    I $P(BLDR ES(0),U,4) '="Q" D AE ^VPRCORD1( "Item is n ot a QO",. ERROR) Q
  7069   "RTN","VPR CORD3",264 ,0)
  7070    S ORDTYPE ="Q"
  7071   "RTN","VPR CORD3",265 ,0)
  7072    ;I $P(BLD RES(0),U)' =1,$P(BLDR ES(0),U)'= 2 D AE("Qu ick Order  is not set  to Auto-A ccept",.VP RVALUE) S  VPROK=2 Q
  7073   "RTN","VPR CORD3",266 ,0)
  7074    S RSPID=$ P(BLDRES(0 ),U,2)
  7075   "RTN","VPR CORD3",267 ,0)
  7076    S DEFIEN= $$DEFDLG^O RCD(IEN)
  7077   "RTN","VPR CORD3",268 ,0)
  7078    S VARSARR ("DISPLAY  GROUP IEN" )=$P($G(^O RD(101.41, DEFIEN,0)) ,U,5)
  7079   "RTN","VPR CORD3",269 ,0)
  7080    S VARSARR ("DISPLAY  GROUP")=$P ($G(^ORD(1 01.98,VARS ARR("DISPL AY GROUP I EN"),0)),U )
  7081   "RTN","VPR CORD3",270 ,0)
  7082    D BLDORDL G^VPRCORD1 (.ORDIALOG ,IEN,PAT,R SPID,ORDTY PE)
  7083   "RTN","VPR CORD3",271 ,0)
  7084    ;S DIEN=V ARSARR("DI SPLAY GROU P IEN")
  7085   "RTN","VPR CORD3",272 ,0)
  7086    D FILLID^ ORWDXC(.FI LLER,IEN)
  7087   "RTN","VPR CORD3",273 ,0)
  7088    S VARSARR ("FILLER I D")=FILLER
  7089   "RTN","VPR CORD3",274 ,0)
  7090    ;I ORDTYP E="E" S DI EN=+$P($G( ^OR(100,VP ROIFN,0)), U,5)
  7091   "RTN","VPR CORD3",275 ,0)
  7092    ;I ORDTYP E="Q" S DI EN=VPROIFN
  7093   "RTN","VPR CORD3",276 ,0)
  7094    S DLGNAME =$P($G(^OR D(101.41,D EFIEN,0)), U)
  7095   "RTN","VPR CORD3",277 ,0)
  7096    I DLGNAME ="" D AE^V PRCORD1("I NVALID DEF AULT DIALO G",.ERROR)  Q
  7097   "RTN","VPR CORD3",278 ,0)
  7098    S VARSARR ("DIALOG N AME")=DLGN AME
  7099   "RTN","VPR CORD3",279 ,0)
  7100    D DLGDEF^ ORWDX(.DLG DEF,DLGNAM E)
  7101   "RTN","VPR CORD3",280 ,0)
  7102    ;build or der check  array,buil d dialog s tructure a nd build s ave array
  7103   "RTN","VPR CORD3",281 ,0)
  7104    D BLDARRS ^VPRCORD2( .RESULT,.O RDIALOG,.V ARSARR,PAT ,LOC,.VPRC HECK,.SAVE ARR,.VPRPO SS)
  7105   "RTN","VPR CORD3",282 ,0)
  7106    D PERCHCK S(.ERROR,. ORDIALOG,. VPRCHECK,P AT,LOC,USE R,DEFIEN,D LGNAME,VAR SARR("DISP LAY GROUP  IEN"),PKGI D,PKGNAME, IEN,"Q") I  $D(ERROR)  Q
  7107   "RTN","VPR CORD3",283 ,0)
  7108    D SAVE(.V PROREST,PA T,USER,LOC ,DLGNAME,V ARSARR("DI SPLAY GROU P IEN"),0, IEN,.ORDIA LOG,.ORD)
  7109   "RTN","VPR CORD3",284 ,0)
  7110    Q
  7111   "RTN","VPR CORD3",285 ,0)
  7112    ;
  7113   "RTN","VPR CORD3",286 ,0)
  7114   SAVE(VPROR EST,PAT,US ER,LOC,DLG NAME,DGIEN ,ORIFN,QOI EN,SAVEARR ,ORD) ;
  7115   "RTN","VPR CORD3",287 ,0)
  7116    ;SAVE(REC ,ORVP,ORNP ,ORL,DLG,O RDG,ORIT,O RIFN,ORDIA LOG,ORDEA, ORAPPT,ORS RC,OREVTDF )
  7117   "RTN","VPR CORD3",288 ,0)
  7118    I QOIEN>0  D SAVE^OR WDX(.VPROR EST,PAT,US ER,LOC,DLG NAME,DGIEN ,QOIEN,"", .SAVEARR," ",DT,"",0)
  7119   "RTN","VPR CORD3",289 ,0)
  7120    I ORIFN>0  D SAVE^OR WDX(.VPROR EST,PAT,US ER,LOC,DLG NAME,DGIEN ,"","",.SA VEARR,"",D T,"",0)
  7121   "RTN","VPR CORD3",290 ,0)
  7122    N CNT,DFN ,IEN
  7123   "RTN","VPR CORD3",291 ,0)
  7124    S CNT=0,I EN=0 F  S  CNT=$O(VPR OREST(CNT) ) Q:CNT'>0 !(IEN>0)   D
  7125   "RTN","VPR CORD3",292 ,0)
  7126    .I $E(VPR OREST(CNT) )="~" S IE N=+$P($P(V PROREST(CN T),U),"~", 2)
  7127   "RTN","VPR CORD3",293 ,0)
  7128    I IEN>0 S  DFN=PAT D  ORX^VPRDJ 01(IEN,.OR D)
  7129   "RTN","VPR CORD3",294 ,0)
  7130    Q
  7131   "RTN","VPR CORD3",295 ,0)
  7132    ;
  7133   "RTN","VPR CORD3",296 ,0)
  7134   VALIDOI(VA LUES,TYPE)  ;
  7135   "RTN","VPR CORD3",297 ,0)
  7136    N IEN,POS SOI
  7137   "RTN","VPR CORD3",298 ,0)
  7138    S IEN=$P( VALUES("OI "),":",5)  I IEN'>0 Q  -1
  7139   "RTN","VPR CORD3",299 ,0)
  7140    ;S IEN=$P (VALUES("O I"),":",5)  I IEN'>0  Q -1
  7141   "RTN","VPR CORD3",300 ,0)
  7142    S POSSOI= $P(^ORD(10 1.43,IEN,0 ),U)
  7143   "RTN","VPR CORD3",301 ,0)
  7144    S VALUES( "OI")=POSS OI
  7145   "RTN","VPR CORD3",302 ,0)
  7146    ;S SETTYP E=$$GETSET (TYPE) I S ETTYPE=""  Q -1
  7147   "RTN","VPR CORD3",303 ,0)
  7148    S RESULT= $O(^ORD(10 1.43,"S."_ TYPE,POSSO I,""))
  7149   "RTN","VPR CORD3",304 ,0)
  7150    Q RESULT
  7151   "RTN","VPR CORD3",305 ,0)
  7152    ;
  7153   "RTN","VPR CORD3",306 ,0)
  7154   PTR(NAME)  ;
  7155   "RTN","VPR CORD3",307 ,0)
  7156    Q $O(^ORD (101.41,"B ","OR GTX  "_NAME,"") )
  7157   "RTN","VPR CORD4")
  7158   0^46^B1370 18675
  7159   "RTN","VPR CORD4",1,0 )
  7160   VPRCORD4 ; ;SLC/AGP - Retreived  Orderable  Items ; 1/ 4/13
  7161   "RTN","VPR CORD4",2,0 )
  7162    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  7163   "RTN","VPR CORD4",3,0 )
  7164    ;
  7165   "RTN","VPR CORD4",4,0 )
  7166    ;
  7167   "RTN","VPR CORD4",5,0 )
  7168    Q
  7169   "RTN","VPR CORD4",6,0 )
  7170    ;
  7171   "RTN","VPR CORD4",7,0 )
  7172   ADDODG ;
  7173   "RTN","VPR CORD4",8,0 )
  7174    N CNT,IEN ,NUM,NODE, PTR,RESULT ,TEMP
  7175   "RTN","VPR CORD4",9,0 )
  7176    N ERRMSG  S ERRMSG=" A mumps er ror occurr ed while e xtaracting  display g roups"
  7177   "RTN","VPR CORD4",10, 0)
  7178    S IEN=0 F   S IEN=$O (^ORD(100. 98,IEN)) Q :IEN'>0  D
  7179   "RTN","VPR CORD4",11, 0)
  7180    .N $ES,$E T
  7181   "RTN","VPR CORD4",12, 0)
  7182    .S $ET="D  ERRHDLR^V PRDERRH"
  7183   "RTN","VPR CORD4",13, 0)
  7184    .I '$D(^O RD(100.98, IEN,1)) D   Q
  7185   "RTN","VPR CORD4",14, 0)
  7186    ..S NODE= $G(^ORD(10 0.98,IEN,0 )) D SODGN ODE(.RESUL T,NODE)
  7187   "RTN","VPR CORD4",15, 0)
  7188    ..S RESUL T("uid")=$ $SETUID^VP RUTILS("di splayGroup ","",IEN), RESULT("in ternal")=I EN
  7189   "RTN","VPR CORD4",16, 0)
  7190    ..D ADD^V PREF("RESU LT") S VPR CNT=+$G(VP RCNT)+1,VP RLAST=IEN
  7191   "RTN","VPR CORD4",17, 0)
  7192    .D ADDODG 1(IEN,.TEM P)
  7193   "RTN","VPR CORD4",18, 0)
  7194    .M RESULT =TEMP
  7195   "RTN","VPR CORD4",19, 0)
  7196    .D ADD^VP REF("RESUL T") S VPRC NT=+$G(VPR CNT)+1,VPR LAST=IEN
  7197   "RTN","VPR CORD4",20, 0)
  7198    Q
  7199   "RTN","VPR CORD4",21, 0)
  7200    ;
  7201   "RTN","VPR CORD4",22, 0)
  7202   ADDODG1(IE N,TEMP) ;
  7203   "RTN","VPR CORD4",23, 0)
  7204    N CNT,NOD E,NUM,PTR
  7205   "RTN","VPR CORD4",24, 0)
  7206    S NODE=$G (^ORD(100. 98,IEN,0))  D SODGNOD E(.TEMP,NO DE)
  7207   "RTN","VPR CORD4",25, 0)
  7208    S TEMP("u id")=$$SET UID^VPRUTI LS("displa yGroup","" ,IEN),TEMP ("internal ")=IEN
  7209   "RTN","VPR CORD4",26, 0)
  7210    I '$D(^OR D(100.98,I EN,1)) Q
  7211   "RTN","VPR CORD4",27, 0)
  7212    S NUM=0,C NT=0 F  S  NUM=$O(^OR D(100.98,I EN,1,NUM))  Q:NUM'>0   D
  7213   "RTN","VPR CORD4",28, 0)
  7214    .N ARRAY
  7215   "RTN","VPR CORD4",29, 0)
  7216    .S PTR=$G (^ORD(100. 98,IEN,1,N UM,0)) Q:P TR'>0
  7217   "RTN","VPR CORD4",30, 0)
  7218    .D ADDODG 1(PTR,.ARR AY) I '$D( ARRAY) Q
  7219   "RTN","VPR CORD4",31, 0)
  7220    .S CNT=CN T+1 M TEMP ("children ",CNT,"ite m")=ARRAY
  7221   "RTN","VPR CORD4",32, 0)
  7222    Q
  7223   "RTN","VPR CORD4",33, 0)
  7224    ;
  7225   "RTN","VPR CORD4",34, 0)
  7226   SODGNODE(R ESULT,NODE ) ;
  7227   "RTN","VPR CORD4",35, 0)
  7228    N NAME,TE MP,X
  7229   "RTN","VPR CORD4",36, 0)
  7230    F X=1:1:4  D
  7231   "RTN","VPR CORD4",37, 0)
  7232    .S TEMP=$ P(NODE,U,X ) I X<4,$L (TEMP)>1 S  RESULT($S (X=1:"name ",X=2:"dis playName", X=3:"abbre viation")) =TEMP
  7233   "RTN","VPR CORD4",38, 0)
  7234    .I X=4,+T EMP>0 S NA ME=$P($G(^ ORD(101.41 ,TEMP,0)), U) S RESUL T("default DialogUid" )=$$SETUID ^VPRUTILS( "orderDial og","",TEM P),RESULT( "defaultDi alogName") =NAME
  7235   "RTN","VPR CORD4",39, 0)
  7236    Q
  7237   "RTN","VPR CORD4",40, 0)
  7238    ;
  7239   "RTN","VPR CORD4",41, 0)
  7240   ADDROUTE ;
  7241   "RTN","VPR CORD4",42, 0)
  7242    N CNT,IEN ,NAME,RESU LT,ROUTES, X,UID,VALU E
  7243   "RTN","VPR CORD4",43, 0)
  7244    N ERRMSG
  7245   "RTN","VPR CORD4",44, 0)
  7246    S ERRMSG= "A mumps e rror occur red while  extaractin g routes."
  7247   "RTN","VPR CORD4",45, 0)
  7248    S CNT=1,I EN=0
  7249   "RTN","VPR CORD4",46, 0)
  7250    I +$G(VPR LAST)>0 S  IEN=VPRLAS T
  7251   "RTN","VPR CORD4",47, 0)
  7252    F  S IEN= $O(^PS(51. 2,IEN)) Q: IEN'>0  D
  7253   "RTN","VPR CORD4",48, 0)
  7254    .N $ES,$E T
  7255   "RTN","VPR CORD4",49, 0)
  7256    .S $ET="D  ERRHDLR^V PRDERRH"
  7257   "RTN","VPR CORD4",50, 0)
  7258    .S NODE=$ P($G(^PS(5 1.2,IEN,0) ),U,1,6)
  7259   "RTN","VPR CORD4",51, 0)
  7260    .I $P(NOD E,U,5)>0 Q
  7261   "RTN","VPR CORD4",52, 0)
  7262    .S UID=$$ SETUID^VPR UTILS("rou te","",IEN )
  7263   "RTN","VPR CORD4",53, 0)
  7264    .S RESULT ("uid")=UI D,RESULT(" internal") =IEN
  7265   "RTN","VPR CORD4",54, 0)
  7266    .F X=1,2, 3,6 D
  7267   "RTN","VPR CORD4",55, 0)
  7268    ..S VALUE =$P(NODE,U ,X) Q:VALU E=""
  7269   "RTN","VPR CORD4",56, 0)
  7270    ..S NAME= $S(X=1:"na me",X=2:"e xternalNam e",X=3:"ab breviation ",X=6:"use InIV",1:"" )
  7271   "RTN","VPR CORD4",57, 0)
  7272    ..I NAME= "" Q
  7273   "RTN","VPR CORD4",58, 0)
  7274    ..I X=6 S  VALUE=$S( VALUE=1:"t rue",1:"fa lse")
  7275   "RTN","VPR CORD4",59, 0)
  7276    ..S RESUL T(NAME)=VA LUE
  7277   "RTN","VPR CORD4",60, 0)
  7278    .D ADD^VP REF("RESUL T") S VPRC NT=+$G(VPR CNT)+1,VPR LAST=IEN
  7279   "RTN","VPR CORD4",61, 0)
  7280    .;S CNT=C NT+1
  7281   "RTN","VPR CORD4",62, 0)
  7282    .K RESULT
  7283   "RTN","VPR CORD4",63, 0)
  7284    Q
  7285   "RTN","VPR CORD4",64, 0)
  7286    ;
  7287   "RTN","VPR CORD4",65, 0)
  7288   ADDSCH ;
  7289   "RTN","VPR CORD4",66, 0)
  7290    N CNT,IEN ,NAME,NODE ,NUM,RESUL T,UID,VPRS CH
  7291   "RTN","VPR CORD4",67, 0)
  7292    ;D SCHALL ^ORWDPS1(. VPRSCH,0,0 )
  7293   "RTN","VPR CORD4",68, 0)
  7294    D SCHED^P SS51P1(0,. VPRSCH)
  7295   "RTN","VPR CORD4",69, 0)
  7296    N ERRMSG
  7297   "RTN","VPR CORD4",70, 0)
  7298    S ERRMSG= "A mumps e rror occur red while  extaractin g schedule s."
  7299   "RTN","VPR CORD4",71, 0)
  7300    S CNT=0 F   S CNT=$O (VPRSCH(CN T)) Q:CNT' >0  D
  7301   "RTN","VPR CORD4",72, 0)
  7302    .N $ES,$E T
  7303   "RTN","VPR CORD4",73, 0)
  7304    .S $ET="D  ERRHDLR^V PRDERRH"
  7305   "RTN","VPR CORD4",74, 0)
  7306    .S NODE=$ G(VPRSCH(C NT))
  7307   "RTN","VPR CORD4",75, 0)
  7308    .S NAME=$ P(NODE,U,2 )
  7309   "RTN","VPR CORD4",76, 0)
  7310    .S IEN=$P (NODE,U)
  7311   "RTN","VPR CORD4",77, 0)
  7312    .;S IEN=$ O(^PS(51.1 ,"B",NAME, "")) I IEN '>0 Q
  7313   "RTN","VPR CORD4",78, 0)
  7314    .S UID=$$ SETUID^VPR UTILS("sch edule","", IEN)
  7315   "RTN","VPR CORD4",79, 0)
  7316    .S RESULT ("uid")=UI D,RESULT(" internal") =IEN
  7317   "RTN","VPR CORD4",80, 0)
  7318    .S RESULT ("name")=N AME
  7319   "RTN","VPR CORD4",81, 0)
  7320    .I $P(NOD E,U,3)'=""  S RESULT( "externalV alue")=$P( NODE,U,3)
  7321   "RTN","VPR CORD4",82, 0)
  7322    .I $P(NOD E,U,4)'=""  S RESULT( "scheduleT ype")=$P(N ODE,U,4)
  7323   "RTN","VPR CORD4",83, 0)
  7324    .D ADD^VP REF("RESUL T") S VPRC NT=+$G(VPR CNT)+1,VPR LAST=IEN
  7325   "RTN","VPR CORD4",84, 0)
  7326    .K RESULT
  7327   "RTN","VPR CORD4",85, 0)
  7328    Q
  7329   "RTN","VPR CORD4",86, 0)
  7330    ;
  7331   "RTN","VPR CORD4",87, 0)
  7332   LAB(RESULT ,OI) ;
  7333   "RTN","VPR CORD4",88, 0)
  7334    N CNT,I,I EN,NODE,SY N,TEMP,VPR LST
  7335   "RTN","VPR CORD4",89, 0)
  7336    S RESULT( "dialogAdd itionalInf ormation", "sendPatie ntTimes",1 ,"internal ")="LT",RE SULT("dial ogAddition alInformat ion","send PatientTim es",1,"nam e")="Today "
  7337   "RTN","VPR CORD4",90, 0)
  7338    S RESULT( "dialogAdd itionalInf ormation", "sendPatie ntTimes",2 ,"internal ")="LT+1", RESULT("di alogAdditi onalInform ation","se ndPatientT imes",2,"n ame")="Tom orrow"
  7339   "RTN","VPR CORD4",91, 0)
  7340    ;
  7341   "RTN","VPR CORD4",92, 0)
  7342    D GETLST^ XPAR(.VPRL ST,"ALL"," ORWD COMMO N LAB INPT ")  ;DBIA  2263
  7343   "RTN","VPR CORD4",93, 0)
  7344    S I=0 F   S I=$O(VPR LST(I)) Q: 'I  D
  7345   "RTN","VPR CORD4",94, 0)
  7346    . S IEN=$ P(VPRLST(I ),U,2)
  7347   "RTN","VPR CORD4",95, 0)
  7348    . S P1="d ialogAddit ionalInfor mation"
  7349   "RTN","VPR CORD4",96, 0)
  7350    . S RESUL T("dialogA dditionalI nformation ","common" ,I,"uid")= $$SETUID^V PRUTILS("o rderable", "",IEN)
  7351   "RTN","VPR CORD4",97, 0)
  7352    . S RESUL T("dialogA dditionalI nformation ","common" ,I,"intern al")=IEN
  7353   "RTN","VPR CORD4",98, 0)
  7354    . S RESUL T("dialogA dditionalI nformation ","common" ,I,"name") =$P(^ORD(1 01.43,IEN, 0),U,1)
  7355   "RTN","VPR CORD4",99, 0)
  7356    ;
  7357   "RTN","VPR CORD4",100 ,0)
  7358    S NODE=$G (^ORD(101. 43,OI,"LR" ))
  7359   "RTN","VPR CORD4",101 ,0)
  7360    S RESULT( "labDetail s","specim an")=$P(NO DE,U),RESU LT("labDet ails","lab Collect")= $S($P(NODE ,U,2)=1:"t rue",1:"fa lse"),RESU LT("labDet ails","seq uence")=$P (NODE,U,3)
  7361   "RTN","VPR CORD4",102 ,0)
  7362    S RESULT( "labDetail s","maxOrd erFrequenc y")=$P(NOD E,U,4),RES ULT("labDe tails","da ilyOrderMa x")=$P(NOD E,U,5)
  7363   "RTN","VPR CORD4",103 ,0)
  7364    ;
  7365   "RTN","VPR CORD4",104 ,0)
  7366    S TEMP=$P (NODE,U,6)
  7367   "RTN","VPR CORD4",105 ,0)
  7368    S RESULT( "types",1, "abb")=TEM P,RESULT(" types",1," uid")=$$SE TUID^VPRUT ILS("labTy pe","",TEM P),RESULT( "types",1, "internal" )=TEMP,RES ULT("types ",1,"type" )=$$LABTYP E(TEMP)
  7369   "RTN","VPR CORD4",106 ,0)
  7370    S TEMP=$P (NODE,U,7)
  7371   "RTN","VPR CORD4",107 ,0)
  7372    I TEMP'=" " S RESULT ("labDetai ls","labTy peInternal ")=TEMP,RE SULT("labD etails","l abTypeName ")=$S(TEMP ="I":"Inpu t",TEMP="O ":"Output" ,TEMP="B": "Both",TEM P="N":"Nei ther")
  7373   "RTN","VPR CORD4",108 ,0)
  7374    I '$D(^OR D(101.43,O I,2)) Q
  7375   "RTN","VPR CORD4",109 ,0)
  7376    S CNT=0
  7377   "RTN","VPR CORD4",110 ,0)
  7378    S I=0 F   S I=$O(^OR D(101.43,O I,2,I)) Q: I'>0  D
  7379   "RTN","VPR CORD4",111 ,0)
  7380    .S SYN=$G (^ORD(101. 43,OI,2,I, 0)) Q:SYN= ""
  7381   "RTN","VPR CORD4",112 ,0)
  7382    .S CNT=CN T+1,RESULT ("synonym" ,CNT,"name ")=SYN
  7383   "RTN","VPR CORD4",113 ,0)
  7384    Q
  7385   "RTN","VPR CORD4",114 ,0)
  7386    ;
  7387   "RTN","VPR CORD4",115 ,0)
  7388   LABTYPE(L)  ;
  7389   "RTN","VPR CORD4",116 ,0)
  7390    I L="CH"  Q "Chemist ry"
  7391   "RTN","VPR CORD4",117 ,0)
  7392    I L="MI"  Q "MICROBI OLOGY"
  7393   "RTN","VPR CORD4",118 ,0)
  7394    I L="BB"  Q "Blood B ank"
  7395   "RTN","VPR CORD4",119 ,0)
  7396    I L="EM"  Q "Electro n Microsco py"
  7397   "RTN","VPR CORD4",120 ,0)
  7398    I L="SP"  Q "Surgica l Patholog y"
  7399   "RTN","VPR CORD4",121 ,0)
  7400    I L="AU"  Q "Autopsy "
  7401   "RTN","VPR CORD4",122 ,0)
  7402    I L="CY"  Q "Cytolog y"
  7403   "RTN","VPR CORD4",123 ,0)
  7404    Q ""
  7405   "RTN","VPR CORD4",124 ,0)
  7406    ;
  7407   "RTN","VPR CORD4",125 ,0)
  7408   OI(OITYPE)  ;
  7409   "RTN","VPR CORD4",126 ,0)
  7410    N CNT,ERR OR,IEN,NAM E,LINK,LIN KTYPE,NODE ,RADDET,RA DTYPE,RESU LT,TCNT,TY PE,UID,VPR TEMP
  7411   "RTN","VPR CORD4",127 ,0)
  7412    N ERRMSG
  7413   "RTN","VPR CORD4",128 ,0)
  7414    S ERRMSG= "A mumps e rror occur red while  extaractin g orderabl e items."
  7415   "RTN","VPR CORD4",129 ,0)
  7416    S CNT=1,I EN=0
  7417   "RTN","VPR CORD4",130 ,0)
  7418    ;
  7419   "RTN","VPR CORD4",131 ,0)
  7420    D RADTYPE (.RADTYPE, .RADDET)
  7421   "RTN","VPR CORD4",132 ,0)
  7422    I +$G(VPR LAST)>0 S  IEN=VPRLAS T
  7423   "RTN","VPR CORD4",133 ,0)
  7424    I +$G(VPR ID)>0 S IE N=VPRID
  7425   "RTN","VPR CORD4",134 ,0)
  7426    F  S IEN= $O(^ORD(10 1.43,IEN))  Q:IEN'>0   D  I VPRM AX>0,VPRI' <VPRMAX Q
  7427   "RTN","VPR CORD4",135 ,0)
  7428    .N $ES,$E T
  7429   "RTN","VPR CORD4",136 ,0)
  7430    .S $ET="D  ERRHDLR^V PRDERRH"
  7431   "RTN","VPR CORD4",137 ,0)
  7432    .K RESULT
  7433   "RTN","VPR CORD4",138 ,0)
  7434    .S TYPE=$ $VALIDOI(O ITYPE,IEN)
  7435   "RTN","VPR CORD4",139 ,0)
  7436    .I TYPE=" " Q
  7437   "RTN","VPR CORD4",140 ,0)
  7438    .S NAME=$ P(^ORD(101 .43,IEN,0) ,U),LINK=$ P($P(^ORD( 101.43,IEN ,0),U,2)," ;99",1),LI NKTYPE=$P( $P(^ORD(10 1.43,IEN,0 ),U,2),";9 9",2)
  7439   "RTN","VPR CORD4",141 ,0)
  7440    .S UID=$$ SETUID^VPR UTILS("ord erable","" ,IEN)
  7441   "RTN","VPR CORD4",142 ,0)
  7442    .S RESULT ("uid")=UI D,RESULT(" internal") =IEN
  7443   "RTN","VPR CORD4",143 ,0)
  7444    .S RESULT ("name")=N AME
  7445   "RTN","VPR CORD4",144 ,0)
  7446    .S RESULT ("link")=L INK
  7447   "RTN","VPR CORD4",145 ,0)
  7448    .S RESULT ("linktype ")=LINKTYP E
  7449   "RTN","VPR CORD4",146 ,0)
  7450    .I TYPE[" PS" D PS(. RESULT,IEN ,CNT)
  7451   "RTN","VPR CORD4",147 ,0)
  7452    .I TYPE[" RA" D RA(. RESULT,IEN ,CNT,.RADT YPE,.RADDE T)
  7453   "RTN","VPR CORD4",148 ,0)
  7454    .I TYPE[" LR" D LAB( .RESULT,IE N)
  7455   "RTN","VPR CORD4",149 ,0)
  7456    .D ADD^VP REF("RESUL T") S VPRC NT=+$G(VPR CNT)+1,VPR LAST=IEN
  7457   "RTN","VPR CORD4",150 ,0)
  7458    .S CNT=CN T+1
  7459   "RTN","VPR CORD4",151 ,0)
  7460    Q
  7461   "RTN","VPR CORD4",152 ,0)
  7462    ;
  7463   "RTN","VPR CORD4",153 ,0)
  7464   PS(RESULT, IEN,PLACE)  ;
  7465   "RTN","VPR CORD4",154 ,0)
  7466    N CNT,COS T,DOSE,DOS ES,DRUG,ME DS,NAME,NO DE,NUM,PSO I,SIZE,TYP E,UID,VPRD OSE
  7467   "RTN","VPR CORD4",155 ,0)
  7468    S CNT=0
  7469   "RTN","VPR CORD4",156 ,0)
  7470    I $D(^ORD (101.43,IE N,9,"B","N V RX")) S  CNT=CNT+1  S RESULT(" types",CNT ,"type")=" NON-VA MED S" S MEDS( "NV RX")=" "
  7471   "RTN","VPR CORD4",157 ,0)
  7472    I $D(^ORD (101.43,IE N,9,"B","O  RX")) S C NT=CNT+1 S  RESULT("t ypes",CNT, "type")="O UTPATIENT  MEDS" S ME DS("O RX") =""
  7473   "RTN","VPR CORD4",158 ,0)
  7474    I $D(^ORD (101.43,IE N,9,"B","R X")) S CNT =CNT+1 S R ESULT("typ es",CNT,"t ype")="MED S" S MEDS( "RX")=""
  7475   "RTN","VPR CORD4",159 ,0)
  7476    I $D(^ORD (101.43,IE N,9,"B","U D RX")) S  CNT=CNT+1  S RESULT(" types",CNT ,"type")=" INPATIENT  MEDS" S ME DS("UD RX" )=""
  7477   "RTN","VPR CORD4",160 ,0)
  7478    ;
  7479   "RTN","VPR CORD4",161 ,0)
  7480    ;K DOSES
  7481   "RTN","VPR CORD4",162 ,0)
  7482    S PSOI=+$ P(^ORD(101 .43,IEN,0) ,U,2)
  7483   "RTN","VPR CORD4",163 ,0)
  7484    S TYPE=""  F  S TYPE =$O(MEDS(T YPE)) Q:TY PE=""  D
  7485   "RTN","VPR CORD4",164 ,0)
  7486    .D DOSE^P SSOPKI1(.V PRDOSE,PSO I,TYPE,0)
  7487   "RTN","VPR CORD4",165 ,0)
  7488    .S CNT=0  F  S CNT=$ O(VPRDOSE( CNT)) Q:CN T'>0  D
  7489   "RTN","VPR CORD4",166 ,0)
  7490    ..S NODE= $G(VPRDOSE (CNT)),SIZ E="",UID=0 ,DRUG="",C OST=""
  7491   "RTN","VPR CORD4",167 ,0)
  7492    ..S DOSE= $P(NODE,U, 5)
  7493   "RTN","VPR CORD4",168 ,0)
  7494    ..I $D(DO SES(DOSE))  Q
  7495   "RTN","VPR CORD4",169 ,0)
  7496    ..I $P(NO DE,U,3)'=" ",$P(NODE, U,4)'="" S  SIZE=$P(N ODE,U,3)_"  "_$P(NODE ,U,4)
  7497   "RTN","VPR CORD4",170 ,0)
  7498    ..S DRUG= $P(NODE,U, 6),COST=$P (NODE,U,7)
  7499   "RTN","VPR CORD4",171 ,0)
  7500    ..S DOSES (DOSE)=$G( SIZE)_U_DR UG_U_COST
  7501   "RTN","VPR CORD4",172 ,0)
  7502    ;
  7503   "RTN","VPR CORD4",173 ,0)
  7504    S DOSE="" ,CNT=1 F   S DOSE=$O( DOSES(DOSE )) Q:DOSE= ""  D
  7505   "RTN","VPR CORD4",174 ,0)
  7506    .S NODE=D OSES(DOSE)
  7507   "RTN","VPR CORD4",175 ,0)
  7508    .S RESULT ("possible Dosages",C NT,"dose") =DOSE
  7509   "RTN","VPR CORD4",176 ,0)
  7510    .I $P(NOD E,U)'="" S  RESULT("p ossibleDos ages",CNT, "size")=$P (NODE,U)
  7511   "RTN","VPR CORD4",177 ,0)
  7512    .I $P(NOD E,U,2)>0 D
  7513   "RTN","VPR CORD4",178 ,0)
  7514    ..S NAME= $P($G(^PSD RUG($P(NOD E,U,2),0)) ,U)
  7515   "RTN","VPR CORD4",179 ,0)
  7516    ..S RESUL T("possibl eDosages", CNT,"drugU id")=$$SET UID^VPRUTI LS("drug", "",$P(NODE ,U,2))
  7517   "RTN","VPR CORD4",180 ,0)
  7518    ..S RESUL T("possibl eDosages", CNT,"drugI nternal")= $P(NODE,U, 2)
  7519   "RTN","VPR CORD4",181 ,0)
  7520    ..S RESUL T("possibl eDosages", CNT,"drugN ame")=NAME
  7521   "RTN","VPR CORD4",182 ,0)
  7522    .;I $P(NO DE,U,3)'=" " S RESULT ("possible Dosages",C NT,"cost") =$P(NODE,U ,3) 
  7523   "RTN","VPR CORD4",183 ,0)
  7524    .S CNT=CN T+1
  7525   "RTN","VPR CORD4",184 ,0)
  7526    Q
  7527   "RTN","VPR CORD4",185 ,0)
  7528    ;
  7529   "RTN","VPR CORD4",186 ,0)
  7530   RA(RESULT, IEN,PLACE, RADTYPE,RA DDET) ;
  7531   "RTN","VPR CORD4",187 ,0)
  7532    N CNT,NOD E,TEMP
  7533   "RTN","VPR CORD4",188 ,0)
  7534    S CNT=0
  7535   "RTN","VPR CORD4",189 ,0)
  7536    S NODE=$G (^ORD(101. 43,IEN,0))
  7537   "RTN","VPR CORD4",190 ,0)
  7538    I $P(NODE ,U,3)'="", $P(NODE,U, 4)'="" S R ESULT("cod e")=$$SETU ID^VPRUTIL S($$LOW^XL FSTR($P(NO DE,U,4))," ",$P(NODE, U,3))
  7539   "RTN","VPR CORD4",191 ,0)
  7540    S NODE=$G (^ORD(101. 43,IEN,"RA "))
  7541   "RTN","VPR CORD4",192 ,0)
  7542    S RESULT( "imagingDe tails","co ntractMedi a")=$P(NOD E,U)
  7543   "RTN","VPR CORD4",193 ,0)
  7544    I $P(NODE ,U,2)'=""  S TEMP=$P( NODE,U,2), RESULT("im agingDetai ls","proce dureType") =$S(TEMP=" B":"Board" ,TEMP="D": "Detailed" ,TEMP="S": "Series",T EMP="P":"P arent")
  7545   "RTN","VPR CORD4",194 ,0)
  7546    I $D(RADT YPE($P(NOD E,U,3))) D
  7547   "RTN","VPR CORD4",195 ,0)
  7548    .S TEMP=$ G(RADTYPE( $P(NODE,U, 3))),RESUL T("types", 1,"type")= $P(TEMP,U, 2),RESULT( "types",1, "uid")=$$S ETUID^VPRU TILS("radT ype","",$P (TEMP,U)), RESULT("in ternal")=$ P(TEMP,U), RESULT("ty pes",1,"ab b")=$P(NOD E,U,3)
  7549   "RTN","VPR CORD4",196 ,0)
  7550    .S RESULT ("imagingD etails","c ommonProce dure")=$S( $P(NODE,U, 4)=1:"true ",1:"false ")
  7551   "RTN","VPR CORD4",197 ,0)
  7552    .I $D(RAD TYPE($P(NO DE,U,3)))  M RESULT(" dialogAddi tionalInfo rmation")= RADDET($P( NODE,U,3))
  7553   "RTN","VPR CORD4",198 ,0)
  7554    Q
  7555   "RTN","VPR CORD4",199 ,0)
  7556    ;
  7557   "RTN","VPR CORD4",200 ,0)
  7558   RADTYPE(RA DTYPE,RADD ET) ;
  7559   "RTN","VPR CORD4",201 ,0)
  7560    ;build ra diology ty pe array f or reused  to load im aging type s
  7561   "RTN","VPR CORD4",202 ,0)
  7562    N ABB,CNT ,IMGTYP,SU BMIT,TCNT, URG,VALUES ,VPRTEMP,V PRX
  7563   "RTN","VPR CORD4",203 ,0)
  7564    D IMTYPSE L^ORWDRA32 (.VPRTEMP, "")
  7565   "RTN","VPR CORD4",204 ,0)
  7566    D CAT(.VA LUES),TRAN S(.VALUES) ,URGENCY(. VALUES)
  7567   "RTN","VPR CORD4",205 ,0)
  7568    S TCNT=""
  7569   "RTN","VPR CORD4",206 ,0)
  7570    F  S TCNT =$O(VPRTEM P(TCNT)) Q :TCNT=""   D
  7571   "RTN","VPR CORD4",207 ,0)
  7572    .S NODE=V PRTEMP(TCN T)
  7573   "RTN","VPR CORD4",208 ,0)
  7574    .S IMGTYP =$P(NODE,U ),ABB=$P(N ODE,U,3)
  7575   "RTN","VPR CORD4",209 ,0)
  7576    .D SUBMIT (.VALUES,A BB)
  7577   "RTN","VPR CORD4",210 ,0)
  7578    .S RADTYP E(ABB)=IMG TYP_U_$P(N ODE,U,2)_U _$P(NODE,U ,4)
  7579   "RTN","VPR CORD4",211 ,0)
  7580    .I $D(VAL UES) M RAD DET(ABB)=V ALUES
  7581   "RTN","VPR CORD4",212 ,0)
  7582    .;Radiolo gy Modifie r
  7583   "RTN","VPR CORD4",213 ,0)
  7584    .S I=$O(^ RA(79.2,"C ",ABB,0))  Q:'I
  7585   "RTN","VPR CORD4",214 ,0)
  7586    .S VPRX=0 ,CNT=0 F   S VPRX=$O( ^RAMIS(71. 2,"AB",I,V PRX)) Q:'V PRX  D
  7587   "RTN","VPR CORD4",215 ,0)
  7588    ..S CNT=C NT+1
  7589   "RTN","VPR CORD4",216 ,0)
  7590    ..S RADDE T(ABB,"mod ifier",CNT ,"uid")=$$ SETUID^VPR UTILS("mod ifier","", VPRX),RADD ET(ABB,"mo difier",CN T,"interna l")=VPRX
  7591   "RTN","VPR CORD4",217 ,0)
  7592    ..S RADDE T(ABB,"mod ifier",CNT ,"name")=$ P(^RAMIS(7 1.2,VPRX,0 ),U)
  7593   "RTN","VPR CORD4",218 ,0)
  7594    Q
  7595   "RTN","VPR CORD4",219 ,0)
  7596    ;
  7597   "RTN","VPR CORD4",220 ,0)
  7598    ;Transpor t values
  7599   "RTN","VPR CORD4",221 ,0)
  7600   TRANS(RADD ET) ;
  7601   "RTN","VPR CORD4",222 ,0)
  7602    N CNT,VPR X
  7603   "RTN","VPR CORD4",223 ,0)
  7604    S CNT=0
  7605   "RTN","VPR CORD4",224 ,0)
  7606    F VPRX="A ^AMBULATOR Y","P^PORT ABLE","S^S TRETCHER", "W^WHEELCH AIR" D
  7607   "RTN","VPR CORD4",225 ,0)
  7608    .S CNT=CN T+1,RADDET ("transpor t",CNT,"ui d")=$$SETU ID^VPRUTIL S("transpo rt","",$P( VPRX,U)),R ADDET("tra nsport",CN T,"name")= $P(VPRX,U, 2),RADDET( "transport ",CNT,"int ernal")=$P (VPRX,U)
  7609   "RTN","VPR CORD4",226 ,0)
  7610    Q
  7611   "RTN","VPR CORD4",227 ,0)
  7612    ;
  7613   "RTN","VPR CORD4",228 ,0)
  7614   CAT(RADDET ) ;categor y values
  7615   "RTN","VPR CORD4",229 ,0)
  7616    N CNT,VPR X
  7617   "RTN","VPR CORD4",230 ,0)
  7618    S CNT=0
  7619   "RTN","VPR CORD4",231 ,0)
  7620    F VPRX="I ^INPATIENT ","O^OUTPA TIENT","E^ EMPLOYEE", "C^CONTRAC T","S^SHAR ING","R^RE SEARCH" D
  7621   "RTN","VPR CORD4",232 ,0)
  7622    .S CNT=CN T+1,RADDET ("category ",CNT,"uid ")=$$SETUI D^VPRUTILS ("transpor t","",$P(V PRX,U)),RA DDET("cate gory",CNT, "name")=$P (VPRX,U,2) ,RADDET("c ategory",C NT,"intern al")=$P(VP RX,U)
  7623   "RTN","VPR CORD4",233 ,0)
  7624    Q
  7625   "RTN","VPR CORD4",234 ,0)
  7626    ;
  7627   "RTN","VPR CORD4",235 ,0)
  7628   URGENCY(UR G) ; Get t he allowab le urgenci es and def ault
  7629   "RTN","VPR CORD4",236 ,0)
  7630    N CNT,I,V PRX
  7631   "RTN","VPR CORD4",237 ,0)
  7632    S VPRX="" ,I=0,CNT=0
  7633   "RTN","VPR CORD4",238 ,0)
  7634    F  S ORX= $O(^ORD(10 1.42,"S.RA ",VPRX)) Q :VPRX=""   D
  7635   "RTN","VPR CORD4",239 ,0)
  7636    . S I=$O( ^ORD(101.4 2,"S.RA",V PRX,0))
  7637   "RTN","VPR CORD4",240 ,0)
  7638    . S URG(" urgency",C NT,"uid")= $$SETUID^V PRUTILS("u rgency","" ,I),URG("u rgency",CN T,"interna l")=I
  7639   "RTN","VPR CORD4",241 ,0)
  7640    . S URG(" urgency",C NT,"name") =VPRX
  7641   "RTN","VPR CORD4",242 ,0)
  7642    . S URG(" urgency",C NT,"defaul t")="false "
  7643   "RTN","VPR CORD4",243 ,0)
  7644    . S CNT=C NT+1
  7645   "RTN","VPR CORD4",244 ,0)
  7646    S I=$O(^O RD(101.42, "B","ROUTI NE",0)) I  +I=0 Q
  7647   "RTN","VPR CORD4",245 ,0)
  7648    S CNT=CNT +1
  7649   "RTN","VPR CORD4",246 ,0)
  7650    S URG("ur gency",CNT ,"uid")=$$ SETUID^VPR UTILS("urg ency","",I ),URG("urg ency",CNT, "internal" )=I
  7651   "RTN","VPR CORD4",247 ,0)
  7652    S URG("ur gency",CNT ,"name")=" Routine"
  7653   "RTN","VPR CORD4",248 ,0)
  7654    S URG("ur gency",CNT ,"default" )="true"
  7655   "RTN","VPR CORD4",249 ,0)
  7656    Q
  7657   "RTN","VPR CORD4",250 ,0)
  7658    ;
  7659   "RTN","VPR CORD4",251 ,0)
  7660   SUBMIT(SUB MIT,IMGTYP ) ; Get th e location s to which  the reque st may be  submitted
  7661   "RTN","VPR CORD4",252 ,0)
  7662    N CNT,FIR ST,TMPLST, ASK,VPRX
  7663   "RTN","VPR CORD4",253 ,0)
  7664    S CNT=0
  7665   "RTN","VPR CORD4",254 ,0)
  7666    D EN4^RAO 7PC1(IMGTY P,"TMPLST" )
  7667   "RTN","VPR CORD4",255 ,0)
  7668    S FIRST=1
  7669   "RTN","VPR CORD4",256 ,0)
  7670    S I=0 F   S I=$O(TMP LST(I)) Q: 'I  D
  7671   "RTN","VPR CORD4",257 ,0)
  7672    . S CNT=C NT+1,VPRX= $P(TMPLST( I),U,1,2), SUBMIT("su bmit",CNT, "name")=$P (VPRX,U,2)
  7673   "RTN","VPR CORD4",258 ,0)
  7674    . S SUBMI T("submit" ,CNT,"defa ult")=$S(F IRST=1:"tr ue",1:"fal se")
  7675   "RTN","VPR CORD4",259 ,0)
  7676    . S SUBMI T("submit" ,CNT,"uid" )=$$SETUID ^VPRUTILS( "imagingLo cation","" ,$P(VPRX,U )),SUBMIT( "submit",C NT,"intern al")=$P(VP RX,U),FIRS T=0
  7677   "RTN","VPR CORD4",260 ,0)
  7678    S VPRX=$$ GET^XPAR(" ALL","RA S UBMIT PROM PT",1,"Q")
  7679   "RTN","VPR CORD4",261 ,0)
  7680    S ASK=$S( $L(VPRX):V PRX,1:1)
  7681   "RTN","VPR CORD4",262 ,0)
  7682    S SUBMIT( "askSubmit ")=$S(ASK= 1:"true",A SK=0:"fals e",1:"true ")
  7683   "RTN","VPR CORD4",263 ,0)
  7684    Q
  7685   "RTN","VPR CORD4",264 ,0)
  7686    ;
  7687   "RTN","VPR CORD4",265 ,0)
  7688   QO ;
  7689   "RTN","VPR CORD4",266 ,0)
  7690    N IEN,NAM E,NODE,RES ULT
  7691   "RTN","VPR CORD4",267 ,0)
  7692    N ERRMSG  S ERRMSG=" A mumps er ror occurr ed while e xtaracting  orderable  items."
  7693   "RTN","VPR CORD4",268 ,0)
  7694    S IEN=0 F   S IEN=$O (^ORD(101. 41,IEN)) Q :IEN'>0  D
  7695   "RTN","VPR CORD4",269 ,0)
  7696    .N $ES,$E T
  7697   "RTN","VPR CORD4",270 ,0)
  7698    .S $ET="D  ERRHDLR^V PRDERRH"
  7699   "RTN","VPR CORD4",271 ,0)
  7700    .S NODE=$ G(^ORD(101 .41,IEN,0) ) I $P(NOD E,U,4)'="Q " Q
  7701   "RTN","VPR CORD4",272 ,0)
  7702    .S NAME=$ S($P(NODE, U,2)'="":$ P(NODE,U,2 ),1:$P(NOD E,U))
  7703   "RTN","VPR CORD4",273 ,0)
  7704    .S RESULT ("name")=N AME
  7705   "RTN","VPR CORD4",274 ,0)
  7706    .S RESULT ("uid")=$$ SETUID^VPR UTILS("qo" ,"",IEN),R ESULT("int ernal")=IE N
  7707   "RTN","VPR CORD4",275 ,0)
  7708    .S VPRCNT =VPRCNT+1  D ADD^VPRE F("RESULT" )
  7709   "RTN","VPR CORD4",276 ,0)
  7710    Q
  7711   "RTN","VPR CORD4",277 ,0)
  7712    ;
  7713   "RTN","VPR CORD4",278 ,0)
  7714   VALIDOI(OI TYPE,IEN)  ;
  7715   "RTN","VPR CORD4",279 ,0)
  7716    N TEMP,TY PE
  7717   "RTN","VPR CORD4",280 ,0)
  7718    I $G(^ORD (101.43,IE N,0))'=""
  7719   "RTN","VPR CORD4",281 ,0)
  7720    S TEMP=$P (^ORD(101. 43,IEN,0), U,2)
  7721   "RTN","VPR CORD4",282 ,0)
  7722    S TYPE=$P (TEMP,";", 2)
  7723   "RTN","VPR CORD4",283 ,0)
  7724    S TYPE=$E (TYPE,3,$L (TYPE))
  7725   "RTN","VPR CORD4",284 ,0)
  7726    I OITYPE= "" Q TYPE
  7727   "RTN","VPR CORD4",285 ,0)
  7728    I TYPE["P S" Q TYPE
  7729   "RTN","VPR CORD4",286 ,0)
  7730    I OITYPE[ TYPE Q TYP E
  7731   "RTN","VPR CORD4",287 ,0)
  7732    Q ""
  7733   "RTN","VPR CORD4",288 ,0)
  7734    ;
  7735   "RTN","VPR CPAT")
  7736   0^9^B18789 518
  7737   "RTN","VPR CPAT",1,0)
  7738   VPRCPAT ;S LC/AGP - P atient Inf ormation C ontroller  for VPR ;  12/12/13 8 :52pm
  7739   "RTN","VPR CPAT",2,0)
  7740    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  7741   "RTN","VPR CPAT",3,0)
  7742    ;
  7743   "RTN","VPR CPAT",4,0)
  7744   ADD(X) ; A dd a line  @NHIN@(n)= X
  7745   "RTN","VPR CPAT",5,0)
  7746    S VPRCNT= $G(VPRCNT) +1
  7747   "RTN","VPR CPAT",6,0)
  7748    S @VPRXML @(VPRCNT)= X
  7749   "RTN","VPR CPAT",7,0)
  7750    Q
  7751   "RTN","VPR CPAT",8,0)
  7752    ;
  7753   "RTN","VPR CPAT",9,0)
  7754   RPC(VPRXML ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  7755   "RTN","VPR CPAT",10,0 )
  7756    N X,REQ,V PRCNT,VPRS ITE,VPRUSE R,VPRDBUG, VPRSTA
  7757   "RTN","VPR CPAT",11,0 )
  7758    S VPRXML= $NA(^TMP($ J,"VPR RES ULTS")) K  @VPRXML
  7759   "RTN","VPR CPAT",12,0 )
  7760    S VPRCNT= 0
  7761   "RTN","VPR CPAT",13,0 )
  7762    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2))
  7763   "RTN","VPR CPAT",14,0 )
  7764    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  S R EQ(X,1)=PA RAMS(X)
  7765   "RTN","VPR CPAT",15,0 )
  7766    ;
  7767   "RTN","VPR CPAT",16,0 )
  7768   COMMON ; C ome here f or both CS P and RPC  Mode
  7769   "RTN","VPR CPAT",17,0 )
  7770    ;
  7771   "RTN","VPR CPAT",18,0 )
  7772    N CMD
  7773   "RTN","VPR CPAT",19,0 )
  7774    S CMD=$G( REQ("comma nd",1))
  7775   "RTN","VPR CPAT",20,0 )
  7776    D ADD("<r esults>")
  7777   "RTN","VPR CPAT",21,0 )
  7778    ;
  7779   "RTN","VPR CPAT",22,0 )
  7780    I CMD="ge tPatPcmmIn fo" D  G O UT
  7781   "RTN","VPR CPAT",23,0 )
  7782    . D GETPC MM^VPRCPAT 1($$VAL("p atient"))
  7783   "RTN","VPR CPAT",24,0 )
  7784    ;
  7785   "RTN","VPR CPAT",25,0 )
  7786   OUT ; outp ut the XML
  7787   "RTN","VPR CPAT",26,0 )
  7788    D ADD("</ results>")
  7789   "RTN","VPR CPAT",27,0 )
  7790    ;I EDPDBU G D PUTXML ^EDPCDBG(E DPDBUG,.ED PXML)
  7791   "RTN","VPR CPAT",28,0 )
  7792    ;I $L($G( EDPHTTP))  D        ;  if in CSP  mode
  7793   "RTN","VPR CPAT",29,0 )
  7794    ;. U EDPH TTP
  7795   "RTN","VPR CPAT",30,0 )
  7796    ;. W "<re sults>",!
  7797   "RTN","VPR CPAT",31,0 )
  7798    ;. N I S  I=0 F  S I =$O(EDPXML (I)) Q:'I   W EDPXML( I),!
  7799   "RTN","VPR CPAT",32,0 )
  7800    ;. W "</r esults>",!
  7801   "RTN","VPR CPAT",33,0 )
  7802   END Q
  7803   "RTN","VPR CPAT",34,0 )
  7804    ;
  7805   "RTN","VPR CPAT",35,0 )
  7806   VAL(X) ; r eturn valu e from req uest
  7807   "RTN","VPR CPAT",36,0 )
  7808    Q $G(REQ( X,1))
  7809   "RTN","VPR CPAT",37,0 )
  7810    ;
  7811   "RTN","VPR CPAT",38,0 )
  7812    ;
  7813   "RTN","VPR CPAT",39,0 )
  7814    ; --- for  VPRCNTRL:  Expects V PRCMD(), D FN, UID, A RRAY
  7815   "RTN","VPR CPAT",40,0 )
  7816    ;
  7817   "RTN","VPR CPAT",41,0 )
  7818   EN ; -- Pa tient data  controlle r
  7819   "RTN","VPR CPAT",42,0 )
  7820    N CMD K V PRERR
  7821   "RTN","VPR CPAT",43,0 )
  7822    S CMD=$G( VPRCMD("co mmand"))
  7823   "RTN","VPR CPAT",44,0 )
  7824    ;
  7825   "RTN","VPR CPAT",45,0 )
  7826    I CMD="sa vePhone" D  PHONE G E NQ
  7827   "RTN","VPR CPAT",46,0 )
  7828    ; others  ??
  7829   "RTN","VPR CPAT",47,0 )
  7830    ;
  7831   "RTN","VPR CPAT",48,0 )
  7832   ENQ ; done
  7833   "RTN","VPR CPAT",49,0 )
  7834    I $D(VPRE RR) D ERRO R Q
  7835   "RTN","VPR CPAT",50,0 )
  7836    D POST^VP REVNT(DFN, "patient", DFN)
  7837   "RTN","VPR CPAT",51,0 )
  7838    D DPT1^VP RDJ00
  7839   "RTN","VPR CPAT",52,0 )
  7840    Q
  7841   "RTN","VPR CPAT",53,0 )
  7842    ;
  7843   "RTN","VPR CPAT",54,0 )
  7844   ERROR ; --  add error  info inst ead of upd ated data  object
  7845   "RTN","VPR CPAT",55,0 )
  7846    N ERROR
  7847   "RTN","VPR CPAT",56,0 )
  7848    S ERROR=" {""command "":"""_CMD _""",""suc cess"":fal se,""error "":"""_VPR ERR_"""}"
  7849   "RTN","VPR CPAT",57,0 )
  7850    S VPRI=VP RI+1 S:VPR I>1 @VPR@( VPRI,.3)=" ,"
  7851   "RTN","VPR CPAT",58,0 )
  7852    S @VPR@(V PRI,1)=ERR OR
  7853   "RTN","VPR CPAT",59,0 )
  7854    Q
  7855   "RTN","VPR CPAT",60,0 )
  7856    ;
  7857   "RTN","VPR CPAT",61,0 )
  7858   PHONE ; --  update ph one number s
  7859   "RTN","VPR CPAT",62,0 )
  7860    N VPRX,VP RDR,HOME,C ELL,NOK,EC ON,I,J,X,O K
  7861   "RTN","VPR CPAT",63,0 )
  7862    S (VPRDR, HOME,CELL, NOK,ECON)= "" D VALS( "old")
  7863   "RTN","VPR CPAT",64,0 )
  7864    S I="" F   S I=$O(AR RAY("telec oms",I)) Q :I<1  D
  7865   "RTN","VPR CPAT",65,0 )
  7866    . I $G(AR RAY("telec oms",I,"us ageCode")) ="H" D  Q
  7867   "RTN","VPR CPAT",66,0 )
  7868    .. S HOME =$G(ARRAY( "telecoms" ,I,"teleco m"))
  7869   "RTN","VPR CPAT",67,0 )
  7870    .. I HOME =HOME("old ") S HOME= "" Q            ;no c hange
  7871   "RTN","VPR CPAT",68,0 )
  7872    .. I "@"[ HOME S:$L( HOME("old" )) HOME="@ " Q  ;dele te
  7873   "RTN","VPR CPAT",69,0 )
  7874    .. S HOME =$$FORMAT( HOME),ARRA Y("telecom s",I,"tele com")=HOME
  7875   "RTN","VPR CPAT",70,0 )
  7876    . I $G(AR RAY("telec oms",I,"us ageCode")) ="MC" D  Q
  7877   "RTN","VPR CPAT",71,0 )
  7878    .. S CELL =$G(ARRAY( "telecoms" ,I,"teleco m"))
  7879   "RTN","VPR CPAT",72,0 )
  7880    .. I CELL =CELL("old ") S CELL= "" Q            ;no c hange
  7881   "RTN","VPR CPAT",73,0 )
  7882    .. I "@"[ CELL S:$L( CELL("old" )) CELL="@ " Q  ;dele te
  7883   "RTN","VPR CPAT",74,0 )
  7884    .. S CELL =$$FORMAT( CELL),ARRA Y("telecom s",I,"tele com")=CELL
  7885   "RTN","VPR CPAT",75,0 )
  7886    S I="" F   S I=$O(AR RAY("suppo rts",I)) Q :I<1  D
  7887   "RTN","VPR CPAT",76,0 )
  7888    . S X=$P( $G(ARRAY(" supports", I,"contact TypeCode") ),":",4) ; NOK or ECO N
  7889   "RTN","VPR CPAT",77,0 )
  7890    . S J=""  F  S J=$O( ARRAY("sup ports",I," telecomLis t",J)) Q:J <1  D
  7891   "RTN","VPR CPAT",78,0 )
  7892    .. Q:$G(A RRAY("supp orts",I,"t elecomList ",J,"usage Code"))'=" H"
  7893   "RTN","VPR CPAT",79,0 )
  7894    .. S @X=$ G(ARRAY("s upports",I ,"telecomL ist",J,"te lecom"))
  7895   "RTN","VPR CPAT",80,0 )
  7896    .. I @X=@ X@("old")  S @X="" Q                  ;no c hange
  7897   "RTN","VPR CPAT",81,0 )
  7898    .. I "@"[ @X S:$L(@X @("old"))  @X="@" Q        ;dele te
  7899   "RTN","VPR CPAT",82,0 )
  7900    .. S @X=$ $FORMAT(@X ),ARRAY("s upports",I ,"telecomL ist",J,"te lecom")=@X
  7901   "RTN","VPR CPAT",83,0 )
  7902    ;
  7903   "RTN","VPR CPAT",84,0 )
  7904    S:$L(HOME ) VPRX(.13 1)=HOME,VP RDR=".131"  ;@=delete
  7905   "RTN","VPR CPAT",85,0 )
  7906    S:$L(CELL ) VPRX(.13 4)=CELL,VP RDR=VPRDR_ $S($L(VPRD R):";",1:" ")_".134"
  7907   "RTN","VPR CPAT",86,0 )
  7908    S:$L(ECON ) VPRX(.33 9)=ECON,VP RDR=VPRDR_ $S($L(VPRD R):";",1:" ")_".339"
  7909   "RTN","VPR CPAT",87,0 )
  7910    S:$L(NOK)  VPRX(.219 )=NOK,VPRD R=VPRDR_$S ($L(VPRDR) :";",1:"") _".219"
  7911   "RTN","VPR CPAT",88,0 )
  7912    I '$O(VPR X(0)) S VP RERR="Data  not chang ed" Q  ;$$ ERR(5) Q
  7913   "RTN","VPR CPAT",89,0 )
  7914    D EDIT^VA FCPTED(DFN ,"VPRX",VP RDR)
  7915   "RTN","VPR CPAT",90,0 )
  7916    S X=$G(^D PT(DFN,.13 )),OK=1 D   ;check gl obal
  7917   "RTN","VPR CPAT",91,0 )
  7918    . I $L(HO ME),$S(HOM E="@":$L($ P(X,U)),1: (HOME'=$P( X,U))) S O K=0
  7919   "RTN","VPR CPAT",92,0 )
  7920    . I $L(CE LL),$S(CEL L="@":$L($ P(X,U,4)), 1:(CELL'=$ P(X,U,4)))  S OK=0
  7921   "RTN","VPR CPAT",93,0 )
  7922    . I $L(EC ON) S X=$G (^DPT(DFN, .33)) I $S (ECON="@": $L($P(X,U, 9)),1:(VPR X(.339)'=$ P(X,U,9)))  S OK=0
  7923   "RTN","VPR CPAT",94,0 )
  7924    . I $L(NO K) S X=$G( ^DPT(DFN,. 21)) I $S( NOK="@":$L ($P(X,U,9) ),1:(NOK'= $P(X,U,9)) ) S OK=0
  7925   "RTN","VPR CPAT",95,0 )
  7926    S:'OK VPR ERR="Updat e failed"  ;$$ERR(6)
  7927   "RTN","VPR CPAT",96,0 )
  7928    Q
  7929   "RTN","VPR CPAT",97,0 )
  7930    ;
  7931   "RTN","VPR CPAT",98,0 )
  7932   FORMAT(X)  ; -- enfor ce (xxx)xx x-xxxx pho ne format
  7933   "RTN","VPR CPAT",99,0 )
  7934    S X=$G(X)  I X?1"("3 N1")"3N1"- "4N.E Q X
  7935   "RTN","VPR CPAT",100, 0)
  7936    N P,N,I,Y  S P=""
  7937   "RTN","VPR CPAT",101, 0)
  7938    F I=1:1:$ L(X) S N=$ E(X,I) I N =+N S P=P_ N
  7939   "RTN","VPR CPAT",102, 0)
  7940    S:$L(P)<1 0 P=$E("00 00000000", 1,10-$L(P) )_P
  7941   "RTN","VPR CPAT",103, 0)
  7942    S Y=$S(P: "("_$E(P,1 ,3)_")"_$E (P,4,6)_"- "_$E(P,7,1 0),1:"")
  7943   "RTN","VPR CPAT",104, 0)
  7944    Q Y
  7945   "RTN","VPR CPAT",105, 0)
  7946    ;
  7947   "RTN","VPR CPAT",106, 0)
  7948   VALS(SUB)  ; -- pull  values fro m ^DPT
  7949   "RTN","VPR CPAT",107, 0)
  7950    N X S X=$ G(^DPT(DFN ,.13))
  7951   "RTN","VPR CPAT",108, 0)
  7952    S HOME(SU B)=$P(X,U) ,CELL(SUB) =$P(X,U,4)
  7953   "RTN","VPR CPAT",109, 0)
  7954    S X=$G(^D PT(DFN,.33 )),ECON(SU B)=$P(X,U, 9)
  7955   "RTN","VPR CPAT",110, 0)
  7956    S X=$G(^D PT(DFN,.21 )),NOK(SUB )=$P(X,U,9 )
  7957   "RTN","VPR CPAT",111, 0)
  7958    Q
  7959   "RTN","VPR CPAT1")
  7960   0^10^B7071 755
  7961   "RTN","VPR CPAT1",1,0 )
  7962   VPRCPAT1 ;  SLC/AGP,J LC - Proce ss Patient  Request f rom AVIVA  System. ;  05/27/2011
  7963   "RTN","VPR CPAT1",2,0 )
  7964    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  7965   "RTN","VPR CPAT1",3,0 )
  7966    Q
  7967   "RTN","VPR CPAT1",4,0 )
  7968    ;
  7969   "RTN","VPR CPAT1",5,0 )
  7970   ADD(X) ; A dd a line  @NHIN@(n)= X
  7971   "RTN","VPR CPAT1",6,0 )
  7972    S VPRCNT= $G(VPRCNT) +1
  7973   "RTN","VPR CPAT1",7,0 )
  7974    S @VPRXML @(VPRCNT)= X
  7975   "RTN","VPR CPAT1",8,0 )
  7976    Q
  7977   "RTN","VPR CPAT1",9,0 )
  7978    ;
  7979   "RTN","VPR CPAT1",10, 0)
  7980   AE(TEXT) ;
  7981   "RTN","VPR CPAT1",11, 0)
  7982    S VPRERCN T=VPRERCNT +1
  7983   "RTN","VPR CPAT1",12, 0)
  7984    S VPRERAR R(VPRERCNT )=TEXT
  7985   "RTN","VPR CPAT1",13, 0)
  7986    Q
  7987   "RTN","VPR CPAT1",14, 0)
  7988    ;
  7989   "RTN","VPR CPAT1",15, 0)
  7990   AEM(TEXT)  ;
  7991   "RTN","VPR CPAT1",16, 0)
  7992    N NUM
  7993   "RTN","VPR CPAT1",17, 0)
  7994    S NUM=0 F   S NUM=$O (TEXT(NUM) ) Q:NUM'>0   D
  7995   "RTN","VPR CPAT1",18, 0)
  7996    .S VPRERC NT=VPRERCN T+1
  7997   "RTN","VPR CPAT1",19, 0)
  7998    .S VPRERA RR(VPRERCN T)=TEXT(NU M)
  7999   "RTN","VPR CPAT1",20, 0)
  8000    Q
  8001   "RTN","VPR CPAT1",21, 0)
  8002    ;
  8003   "RTN","VPR CPAT1",22, 0)
  8004   GETPCMM(IC N) ;
  8005   "RTN","VPR CPAT1",23, 0)
  8006    N DFN,VPR DATA,VPRDC NT,VPRERAR R,VPRERCNT
  8007   "RTN","VPR CPAT1",24, 0)
  8008    S VPRERCN T=0,VPRDCN T=0
  8009   "RTN","VPR CPAT1",25, 0)
  8010    S DFN=$$G ETDFN^MPIF 001(ICN) I  DFN'>0 D  AE("Cannot  find pati ent dfn fr om ICN") G  EXIT
  8011   "RTN","VPR CPAT1",26, 0)
  8012    N PCT,PCP ,ATT,ASS
  8013   "RTN","VPR CPAT1",27, 0)
  8014    S PCT=$$O UTPTTM^SDU TL3(DFN,DT ) I $P(PCT ,U)>0 S VP RDCNT=VPRD CNT+1,VPRD ATA(VPRDCN T)="<team  id='"_$P(P CT,U)_"' v alue='"_$$ ESC^VPRD($ P(PCT,U,2) )_"'/>"
  8015   "RTN","VPR CPAT1",28, 0)
  8016    S PCP=$$O UTPTPR^SDU TL3(DFN,DT ) I $P(PCP ,U)>0 S VP RDCNT=VPRD CNT+1,VPRD ATA(VPRDCN T)="<prima ryProvider  id='"_$P( PCP,U)_"'  value='"_$ $ESC^VPRD( $P(PCP,U,2 ))_"'/>"
  8017   "RTN","VPR CPAT1",29, 0)
  8018    S ATT=$G( ^DPT(DFN,. 1041)) I A TT S VPRDC NT=VPRDCNT +1,VPRDATA (VPRDCNT)= "<attendin gProvider  id='"_ATT_ "' value=' "_$$ESC^VP RD($P($G(^ VA(200,ATT ,0)),U))_" '/>"
  8019   "RTN","VPR CPAT1",30, 0)
  8020    S ASS=$$O UTPTAP^SDU TL3(DFN,DT ) I $P(ASS ,U)>0 S VP RDCNT=VPRD CNT+1,VPRD ATA(VPRDCN T)="<assoc iateProvid er id='"_$ P(ASS,U)_" ' value='" _$$ESC^VPR D($P(ASS,U ,2))_"'/>"
  8021   "RTN","VPR CPAT1",31, 0)
  8022    G EXIT
  8023   "RTN","VPR CPAT1",32, 0)
  8024    Q
  8025   "RTN","VPR CPAT1",33, 0)
  8026    ;
  8027   "RTN","VPR CPAT1",34, 0)
  8028   EXIT ;
  8029   "RTN","VPR CPAT1",35, 0)
  8030    N CNT
  8031   "RTN","VPR CPAT1",36, 0)
  8032    I $D(VPRE RARR) D  Q
  8033   "RTN","VPR CPAT1",37, 0)
  8034    .D ADD("< success>fa lse</succe ss>")
  8035   "RTN","VPR CPAT1",38, 0)
  8036    .D ADD("< error>")
  8037   "RTN","VPR CPAT1",39, 0)
  8038    .D ADD("< message xm l:space='p reserve'/> ")
  8039   "RTN","VPR CPAT1",40, 0)
  8040    .S CNT=0  F  S CNT=$ O(VPRERARR (CNT)) Q:C NT'>0  D
  8041   "RTN","VPR CPAT1",41, 0)
  8042    ..D ADD($ $ESC^VPRD( VPRERARR(C NT)))
  8043   "RTN","VPR CPAT1",42, 0)
  8044    .D ADD("< /error>")
  8045   "RTN","VPR CPAT1",43, 0)
  8046    D ADD("<s uccess>tru e</success >")
  8047   "RTN","VPR CPAT1",44, 0)
  8048    D ADD("<d ata>")
  8049   "RTN","VPR CPAT1",45, 0)
  8050    S CNT=0 F   S CNT=$O (VPRDATA(C NT)) Q:CNT '>0  D
  8051   "RTN","VPR CPAT1",46, 0)
  8052    .D ADD(VP RDATA(CNT) )
  8053   "RTN","VPR CPAT1",47, 0)
  8054    D ADD("</ data>")
  8055   "RTN","VPR CPAT1",48, 0)
  8056    Q
  8057   "RTN","VPR CPRS")
  8058   0^47^B4945 756
  8059   "RTN","VPR CPRS",1,0)
  8060   VPRCPRS ;S LC/AGP - C PRS RPC fo r  ; 9/21/ 12 5:57pm
  8061   "RTN","VPR CPRS",2,0)
  8062    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  8063   "RTN","VPR CPRS",3,0)
  8064    ;
  8065   "RTN","VPR CPRS",4,0)
  8066    ;
  8067   "RTN","VPR CPRS",5,0)
  8068   RPC(VPROUT ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  8069   "RTN","VPR CPRS",6,0)
  8070    N X,REQ,V PRCNT,VPRS ITE,VPRUSE R,VPRDBUG, VPRSTA
  8071   "RTN","VPR CPRS",7,0)
  8072    S VPRCNT= 0
  8073   "RTN","VPR CPRS",8,0)
  8074    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2))
  8075   "RTN","VPR CPRS",9,0)
  8076    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  S R EQ(X,1)=PA RAMS(X)
  8077   "RTN","VPR CPRS",10,0 )
  8078    ;
  8079   "RTN","VPR CPRS",11,0 )
  8080   COMMON ; C ome here f or both CS P and RPC  Mode
  8081   "RTN","VPR CPRS",12,0 )
  8082    ;
  8083   "RTN","VPR CPRS",13,0 )
  8084    N CMD
  8085   "RTN","VPR CPRS",14,0 )
  8086    S CMD=$G( REQ("comma nd",1))
  8087   "RTN","VPR CPRS",15,0 )
  8088    ;
  8089   "RTN","VPR CPRS",16,0 )
  8090    ; returns  an order  structure  for change  orders
  8091   "RTN","VPR CPRS",17,0 )
  8092    ; or plac es an orde r if auto- accept QO
  8093   "RTN","VPR CPRS",18,0 )
  8094    I CMD="al erts" D  G  OUT
  8095   "RTN","VPR CPRS",19,0 )
  8096    . D ALERT S(.VPROUT)
  8097   "RTN","VPR CPRS",20,0 )
  8098    ;
  8099   "RTN","VPR CPRS",21,0 )
  8100    I CMD="re minders" D   G OUT
  8101   "RTN","VPR CPRS",22,0 )
  8102    .D EVALLI ST^VPRPXRM (.VPROUT,$ $VAL("pati entId"),$$ VAL("userI d"),$$VAL( "location" ))
  8103   "RTN","VPR CPRS",23,0 )
  8104    ;
  8105   "RTN","VPR CPRS",24,0 )
  8106   OUT ;
  8107   "RTN","VPR CPRS",25,0 )
  8108   END ;
  8109   "RTN","VPR CPRS",26,0 )
  8110    ;
  8111   "RTN","VPR CPRS",27,0 )
  8112   BLDINFO(IN FO) ;
  8113   "RTN","VPR CPRS",28,0 )
  8114    N X
  8115   "RTN","VPR CPRS",29,0 )
  8116    S X="" F   S X=$O(RE Q(X)) Q:X= ""  D
  8117   "RTN","VPR CPRS",30,0 )
  8118    .S INFO(X )=REQ(X,1)
  8119   "RTN","VPR CPRS",31,0 )
  8120    Q
  8121   "RTN","VPR CPRS",32,0 )
  8122    ;
  8123   "RTN","VPR CPRS",33,0 )
  8124   VAL(X) ; r eturn valu e from req uest
  8125   "RTN","VPR CPRS",34,0 )
  8126    Q $G(REQ( X,1))
  8127   "RTN","VPR CPRS",35,0 )
  8128    ;
  8129   "RTN","VPR CPRS",36,0 )
  8130   ALERTS(VPR OUT) ;
  8131   "RTN","VPR CPRS",37,0 )
  8132    N ALERT,C NT,ERROR,N ODE,NUM,RE SULT,VPROR Y
  8133   "RTN","VPR CPRS",38,0 )
  8134    K ^TMP("V PRALERTS", $J),^TMP(" VPROUT",$J )
  8135   "RTN","VPR CPRS",39,0 )
  8136    ;S VPROUT =$NA(^TMP( "VPROUT",$ J))
  8137   "RTN","VPR CPRS",40,0 )
  8138    D FASTUSE R^ORWORB(. VPRORY)
  8139   "RTN","VPR CPRS",41,0 )
  8140    ;ZW VPROR Y
  8141   "RTN","VPR CPRS",42,0 )
  8142    S CNT=0,N UM=1 F  S  CNT=$O(@VP RORY@(CNT) ) Q:CNT'>0   D
  8143   "RTN","VPR CPRS",43,0 )
  8144    .S NODE=$ G(@VPRORY@ (CNT))
  8145   "RTN","VPR CPRS",44,0 )
  8146    .K ALERT
  8147   "RTN","VPR CPRS",45,0 )
  8148    .I $P(NOD E,U)="I" S  ALERT("in foOnly")=" I"
  8149   "RTN","VPR CPRS",46,0 )
  8150    .S ALERT( "patient") =$P(NODE,U ,2),ALERT( "urgency") =$P(NODE,U ,4),ALERT( "dateTime" )=$P(NODE, U,5)
  8151   "RTN","VPR CPRS",47,0 )
  8152    .I $P(NOD E,U,3)'=""  S ALERT(" location") =$P(NODE,U ,3)
  8153   "RTN","VPR CPRS",48,0 )
  8154    .S ALERT( "message") =$P(NODE,U ,6)
  8155   "RTN","VPR CPRS",49,0 )
  8156    .I $P(NOD E,U,8)'=""  S ALERT(" action")=$ P(NODE,U,8 )
  8157   "RTN","VPR CPRS",50,0 )
  8158    .S ALERT( "mustBePro cess")=$S( $P(NODE,U, 9)="yes":" false",1:" true")
  8159   "RTN","VPR CPRS",51,0 )
  8160    .I $P(NOD E,U,10)'=" " S ALERT( "forwardBy ")="true"
  8161   "RTN","VPR CPRS",52,0 )
  8162    .M ^TMP(" VPRALERTS" ,$J,"data" ,"alerts", NUM,"alert ")=ALERT S  NUM=NUM+1
  8163   "RTN","VPR CPRS",53,0 )
  8164    D ENCODE^ VPRJSON($N A(^TMP("VP RALERTS",$ J)),"VPROU T","ERROR" )
  8165   "RTN","VPR CPRS",54,0 )
  8166    Q
  8167   "RTN","VPR CPRS",55,0 )
  8168    ;
  8169   "RTN","VPR CRPC")
  8170   0^19^B1129 4692
  8171   "RTN","VPR CRPC",1,0)
  8172   VPRCRPC ;S LC/AGP - G eneric RPC  controlle r for VPR  ; 11/7/12  5:42pm
  8173   "RTN","VPR CRPC",2,0)
  8174    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  8175   "RTN","VPR CRPC",3,0)
  8176    ;
  8177   "RTN","VPR CRPC",4,0)
  8178    ;
  8179   "RTN","VPR CRPC",5,0)
  8180   CHAINRPC(V PRRES,PARA MS) ; Chai n multiple  rpcs into  one call
  8181   "RTN","VPR CRPC",6,0)
  8182    N CITER,R SP,PID
  8183   "RTN","VPR CRPC",7,0)
  8184    S CITER=" " F  S CIT ER=$O(PARA MS("comman dList",CIT ER)) Q:CIT ER=""  D
  8185   "RTN","VPR CRPC",8,0)
  8186    . N SUBCM D,SUBRSP,X
  8187   "RTN","VPR CRPC",9,0)
  8188    . S X=""
  8189   "RTN","VPR CRPC",10,0 )
  8190    . F  S X= $O(PARAMS( "commandLi st",CITER, X)) Q:X=""   M SUBCMD (X)=PARAMS ("commandL ist",CITER ,X)
  8191   "RTN","VPR CRPC",11,0 )
  8192    . D CHAIN CMD(.SUBCM D,.SUBRSP)
  8193   "RTN","VPR CRPC",12,0 )
  8194    . I $D(SU BRSP) D DE CODE^VPRJS ON("SUBRSP ","RSP(SUB CMD(""comm and""))"," ^JMCERR")  I 1
  8195   "RTN","VPR CRPC",13,0 )
  8196    . I '$TES T S RSP(SU BCMD("comm and"))=""
  8197   "RTN","VPR CRPC",14,0 )
  8198    D ENCODE^ VPRJSON("R SP","VPRRE S","^JMCER R")
  8199   "RTN","VPR CRPC",15,0 )
  8200    Q
  8201   "RTN","VPR CRPC",16,0 )
  8202   RPC(VPRRES ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  8203   "RTN","VPR CRPC",17,0 )
  8204    N X,REQ,V PRVAL,VPRC NT,VPRSITE ,VPRUSER,V PRDBUG,VPR STA
  8205   "RTN","VPR CRPC",18,0 )
  8206    ;S VPRXML =$NA(^TMP( $J,"VPR RE SULTS")) K  @VPRXML
  8207   "RTN","VPR CRPC",19,0 )
  8208    S VPRCNT= 0
  8209   "RTN","VPR CRPC",20,0 )
  8210    ;S VPRUSE R=DUZ,VPRS ITE=DUZ(2) ,VPRSTA=$$ STA^XUAF4( DUZ(2))
  8211   "RTN","VPR CRPC",21,0 )
  8212    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  I X '="value"  S REQ(X,1) =PARAMS(X)
  8213   "RTN","VPR CRPC",22,0 )
  8214    I $D(PARA MS("value" )) M VPRVA L=PARAMS(" value")
  8215   "RTN","VPR CRPC",23,0 )
  8216    ;
  8217   "RTN","VPR CRPC",24,0 )
  8218   COMMON ; C ome here f or both CS P and RPC  Mode
  8219   "RTN","VPR CRPC",25,0 )
  8220    ; 
  8221   "RTN","VPR CRPC",26,0 )
  8222    N CMD
  8223   "RTN","VPR CRPC",27,0 )
  8224    S CMD=$G( REQ("comma nd",1))
  8225   "RTN","VPR CRPC",28,0 )
  8226    ;
  8227   "RTN","VPR CRPC",29,0 )
  8228    I CMD="sa veParam" D   G OUT
  8229   "RTN","VPR CRPC",30,0 )
  8230    . D PUTPA RAM^VPRPAR AM(.VPRRES ,.VPRVAL," ")
  8231   "RTN","VPR CRPC",31,0 )
  8232    ;
  8233   "RTN","VPR CRPC",32,0 )
  8234    I CMD="sa veByUid" D   G OUT
  8235   "RTN","VPR CRPC",33,0 )
  8236    . D PUTBY UID^VPRPAR AM(.VPRRES ,$$VAL("ui d"),.VPRVA L)
  8237   "RTN","VPR CRPC",34,0 )
  8238    ;
  8239   "RTN","VPR CRPC",35,0 )
  8240    I CMD="ge tParam" D   G OUT
  8241   "RTN","VPR CRPC",36,0 )
  8242    . D GETBY UID^VPRPAR AM(.VPRRES ,$$VAL("ui d"))
  8243   "RTN","VPR CRPC",37,0 )
  8244    ;
  8245   "RTN","VPR CRPC",38,0 )
  8246    I CMD="cl earParam"  D  G OUT
  8247   "RTN","VPR CRPC",39,0 )
  8248    . D DELPA RAM^VPRPAR AM(.VPRRES ,$$VAL("ui d"))
  8249   "RTN","VPR CRPC",40,0 )
  8250    ;
  8251   "RTN","VPR CRPC",41,0 )
  8252    I CMD="ge tAllParam"  D  G OUT
  8253   "RTN","VPR CRPC",42,0 )
  8254    .D GETALP AR^VPRPARA M(.VPRRES, $$VAL("ent ity"),$$VA L("entityI d"),$$VAL( "getValues "))
  8255   "RTN","VPR CRPC",43,0 )
  8256    ;
  8257   "RTN","VPR CRPC",44,0 )
  8258    I CMD="ge tUserInfo"  D  G OUT
  8259   "RTN","VPR CRPC",45,0 )
  8260    .D GETUSE RI^VPRCRPC 1(.VPRRES, $$VAL("use rId"))
  8261   "RTN","VPR CRPC",46,0 )
  8262    ;
  8263   "RTN","VPR CRPC",47,0 )
  8264    I CMD="ge tPatientIn fo" D  G O UT
  8265   "RTN","VPR CRPC",48,0 )
  8266    .D GETPAT I^VPRCRPC1 (.VPRRES,$ $VAL("pati entId"))
  8267   "RTN","VPR CRPC",49,0 )
  8268    ;
  8269   "RTN","VPR CRPC",50,0 )
  8270    I CMD="is PatientSen sitive" D   G OUT
  8271   "RTN","VPR CRPC",51,0 )
  8272    .D CHKS^V PRFPTC(.VP RRES,$$VAL ("patientI d"))
  8273   "RTN","VPR CRPC",52,0 )
  8274    ;
  8275   "RTN","VPR CRPC",53,0 )
  8276    I CMD="lo gPatientAc cess" D  G  OUT
  8277   "RTN","VPR CRPC",54,0 )
  8278    .D LOG^VP RFPTC(.VPR RES,$$VAL( "patientId "))
  8279   "RTN","VPR CRPC",55,0 )
  8280    ;
  8281   "RTN","VPR CRPC",56,0 )
  8282    I CMD="ad dTask" D   G OUT
  8283   "RTN","VPR CRPC",57,0 )
  8284    .D PUT^VP RDJ1(.VPRR ES,$$VAL(" patientId" ),$$VAL("t ype"),.VPR VAL)
  8285   "RTN","VPR CRPC",58,0 )
  8286    ;
  8287   "RTN","VPR CRPC",59,0 )
  8288    I CMD="ge tReminderL ist" D  G  OUT
  8289   "RTN","VPR CRPC",60,0 )
  8290    .D REMLIS T^VPRPXRM( .VPRRES,$$ VAL("user" ),$$VAL("l ocation"))
  8291   "RTN","VPR CRPC",61,0 )
  8292    ;
  8293   "RTN","VPR CRPC",62,0 )
  8294    I CMD="ev aluateRemi nder" D  G  OUT
  8295   "RTN","VPR CRPC",63,0 )
  8296    .D EVALRE M^VPRPXRM( .VPRRES,$$ VAL("patie ntId"),$$V AL("uid"))
  8297   "RTN","VPR CRPC",64,0 )
  8298    ;
  8299   "RTN","VPR CRPC",65,0 )
  8300    I CMD="ge tDefaultLi st" D  G O UT
  8301   "RTN","VPR CRPC",66,0 )
  8302    .D GETDLI ST^VPRROS8 (.VPRRES,$ $VAL("serv er"))
  8303   "RTN","VPR CRPC",67,0 )
  8304    ;
  8305   "RTN","VPR CRPC",68,0 )
  8306   OUT ; outp ut the XML
  8307   "RTN","VPR CRPC",69,0 )
  8308    ;S VPRRES =$G(RESULT )
  8309   "RTN","VPR CRPC",70,0 )
  8310    I '$D(VPR RES) S VPR RES="{}"
  8311   "RTN","VPR CRPC",71,0 )
  8312   END Q
  8313   "RTN","VPR CRPC",72,0 )
  8314    ;
  8315   "RTN","VPR CRPC",73,0 )
  8316   VAL(X) ; r eturn valu e from req uest
  8317   "RTN","VPR CRPC",74,0 )
  8318    Q $G(REQ( X,1))
  8319   "RTN","VPR CRPC",75,0 )
  8320    ;
  8321   "RTN","VPR CRPC",76,0 )
  8322   CHAINCMD(V PRCMD,VPRR SP) ; Do o ne command  in chain
  8323   "RTN","VPR CRPC",77,0 )
  8324    ; 
  8325   "RTN","VPR CRPC",78,0 )
  8326    N CMD
  8327   "RTN","VPR CRPC",79,0 )
  8328    S CMD=$G( VPRCMD("co mmand"))
  8329   "RTN","VPR CRPC",80,0 )
  8330    I CMD="ge tParam" D  GETBYUID^V PRPARAM(.V PRRSP,$G(V PRCMD("uid ")))
  8331   "RTN","VPR CRPC",81,0 )
  8332    I CMD="ge tPatientIn fo" D GETP ATI^VPRCRP C1(.VPRRSP ,$G(VPRCMD ("patientI d")))
  8333   "RTN","VPR CRPC",82,0 )
  8334    I CMD="is PatientSen sitive" D  CHKS^VPRFP TC(.VPRRSP ,$G(VPRCMD ("patientI d")))
  8335   "RTN","VPR CRPC",83,0 )
  8336    I CMD="sa veParam" D  PUTPARAM^ VPRPARAM(. VPRRSP,$G( VPRCMD("va lue")),"")
  8337   "RTN","VPR CRPC",84,0 )
  8338    I CMD="sa veByUid" D  PUTBYUID^ VPRPARAM(. VPRRSP,$G( VPRCMD("ui d")),$G(VP RCMD("valu e")))
  8339   "RTN","VPR CRPC",85,0 )
  8340    Q
  8341   "RTN","VPR CRPC1")
  8342   0^20^B9103 0000
  8343   "RTN","VPR CRPC1",1,0 )
  8344   VPRCRPC1 ;  SLC/AGP -  Patient a nd User ro utine. ; 1 2/13/13 7: 27pm
  8345   "RTN","VPR CRPC1",2,0 )
  8346    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  8347   "RTN","VPR CRPC1",3,0 )
  8348    Q
  8349   "RTN","VPR CRPC1",4,0 )
  8350    ;
  8351   "RTN","VPR CRPC1",5,0 )
  8352   GETADD(VAL UES,DFN) ;
  8353   "RTN","VPR CRPC1",6,0 )
  8354    D ADD^VAD PT
  8355   "RTN","VPR CRPC1",7,0 )
  8356    I VAPA(12 )=1 D  G A DDX
  8357   "RTN","VPR CRPC1",8,0 )
  8358    .I $L(VAP A(13))>0 S  VALUES("a ddress","s treet",0)= VAPA(13)
  8359   "RTN","VPR CRPC1",9,0 )
  8360    .I $L(VAP A(14))>0 S  VALUES("a ddress","s treet",1)= VAPA(14)
  8361   "RTN","VPR CRPC1",10, 0)
  8362    .I $L(VAP A(15))>0 S  VALUES("a ddress","s treet",2)= VAPA(15)
  8363   "RTN","VPR CRPC1",11, 0)
  8364    .I $L(VAP A(16))>0 S  VALUES("a ddress","c ity")=VAPA (16)
  8365   "RTN","VPR CRPC1",12, 0)
  8366    .I $L(VAP A(17))>0 S  VALUES("a ddress","s tate")=$P( VAPA(17),U ,2)
  8367   "RTN","VPR CRPC1",13, 0)
  8368    .I $L(VAP A(18))>0 S  VALUES("a ddress","z ip")=VAPA( 18)
  8369   "RTN","VPR CRPC1",14, 0)
  8370    .S VALUES ("address" ,"confiden tIal")="tr ue"
  8371   "RTN","VPR CRPC1",15, 0)
  8372    ;
  8373   "RTN","VPR CRPC1",16, 0)
  8374    I $L(VAPA (1))>0 S V ALUES("add ress","str eet",0)=VA PA(1)
  8375   "RTN","VPR CRPC1",17, 0)
  8376    I $L(VAPA (2))>0 S V ALUES("add ress","str eet",1)=VA PA(2)
  8377   "RTN","VPR CRPC1",18, 0)
  8378    I $L(VAPA (3))>0 S V ALUES("add ress","str eet",2)=VA PA(3)
  8379   "RTN","VPR CRPC1",19, 0)
  8380    I $L(VAPA (4))>0 S V ALUES("add ress","cit y")=VAPA(4 )
  8381   "RTN","VPR CRPC1",20, 0)
  8382    I $L(VAPA (5))>0 S V ALUES("add ress","sta te")=$P(VA PA(5),U,2)
  8383   "RTN","VPR CRPC1",21, 0)
  8384    I $L(VAPA (6))>0 S V ALUES("add ress","zip ")=VAPA(6)
  8385   "RTN","VPR CRPC1",22, 0)
  8386    S VALUES( "address", "confident Ial")="fal se"
  8387   "RTN","VPR CRPC1",23, 0)
  8388   ADDX ;
  8389   "RTN","VPR CRPC1",24, 0)
  8390    I $L(VAPA (8))>0 S V ALUES("add ress","pho ne")=VAPA( 8)
  8391   "RTN","VPR CRPC1",25, 0)
  8392    D KVAR^VA DPT
  8393   "RTN","VPR CRPC1",26, 0)
  8394    Q
  8395   "RTN","VPR CRPC1",27, 0)
  8396    ;
  8397   "RTN","VPR CRPC1",28, 0)
  8398   GETBSA(DFN ) ;
  8399   "RTN","VPR CRPC1",29, 0)
  8400    N DATE,DA TA,NFOUND, TEST,TEXT
  8401   "RTN","VPR CRPC1",30, 0)
  8402    S TEST=""
  8403   "RTN","VPR CRPC1",31, 0)
  8404    D BSA^PXR MBMI(DFN,1 ,0,DT,.NFO UND,.TEST, .DATE,.DAT A,.TEXT)
  8405   "RTN","VPR CRPC1",32, 0)
  8406    Q +$G(DAT A(1,"BSA") )
  8407   "RTN","VPR CRPC1",33, 0)
  8408    ;
  8409   "RTN","VPR CRPC1",34, 0)
  8410   GETBMI(DFN ) ;
  8411   "RTN","VPR CRPC1",35, 0)
  8412    ;  BMI(DF N,NGET,BDT ,EDT,NFOUN D,TEST,DAT E,DATA,TEX T) 
  8413   "RTN","VPR CRPC1",36, 0)
  8414    N DATE,DA TA,NFOUND, TEST,TEXT
  8415   "RTN","VPR CRPC1",37, 0)
  8416    D BMI^PXR MBMI(DFN,1 ,0,DT,.NFO UND,.TEST, .DATE,.DAT A,.TEXT)
  8417   "RTN","VPR CRPC1",38, 0)
  8418    Q +$G(DAT A(1,"BMI") )
  8419   "RTN","VPR CRPC1",39, 0)
  8420    ;
  8421   "RTN","VPR CRPC1",40, 0)
  8422   GETDEM(VAL UES,DFN) ;
  8423   "RTN","VPR CRPC1",41, 0)
  8424    D DEM^VAD PT
  8425   "RTN","VPR CRPC1",42, 0)
  8426    S VALUES( "name")=VA DM(1)
  8427   "RTN","VPR CRPC1",43, 0)
  8428    I VADM(2) ]"" S VALU ES("ssn")= $P(VADM(2) ,U,2)
  8429   "RTN","VPR CRPC1",44, 0)
  8430    I VADM(3) ]"" S VALU ES("dob")= $P(VADM(3) ,U,2)
  8431   "RTN","VPR CRPC1",45, 0)
  8432    I VADM(4) ]"" S VALU ES("age")= VADM(4)
  8433   "RTN","VPR CRPC1",46, 0)
  8434    I VADM(5) ]"" S VALU ES("gender ")=$P(VADM (5),U,2)
  8435   "RTN","VPR CRPC1",47, 0)
  8436    D KVAR^VA DPT
  8437   "RTN","VPR CRPC1",48, 0)
  8438    Q
  8439   "RTN","VPR CRPC1",49, 0)
  8440    ;
  8441   "RTN","VPR CRPC1",50, 0)
  8442   GETKEYS(VA LUES,USER)  ;
  8443   "RTN","VPR CRPC1",51, 0)
  8444    N NAME,VP RERR,VPRLI ST,CNT
  8445   "RTN","VPR CRPC1",52, 0)
  8446    D LIST^DI C(200.051, ","_USER_" ,",".01",, ,,,,,,"VPR LIST","VPR ERR")
  8447   "RTN","VPR CRPC1",53, 0)
  8448    S CNT=0 F   S CNT=$O (VPRLIST(" DILIST",1, CNT)) Q:CN T'>0  D
  8449   "RTN","VPR CRPC1",54, 0)
  8450    . S NAME= $G(VPRLIST ("DILIST", 1,CNT)) Q: NAME=""
  8451   "RTN","VPR CRPC1",55, 0)
  8452    . S VALUE S("vistaKe ys",NAME)= "TRUE"
  8453   "RTN","VPR CRPC1",56, 0)
  8454    Q
  8455   "RTN","VPR CRPC1",57, 0)
  8456    ;
  8457   "RTN","VPR CRPC1",58, 0)
  8458   GETNOK(VAL UES,DFN,TY PE) ;
  8459   "RTN","VPR CRPC1",59, 0)
  8460    S VAOA("A ")=TYPE
  8461   "RTN","VPR CRPC1",60, 0)
  8462    N CNT,CON TACT
  8463   "RTN","VPR CRPC1",61, 0)
  8464    S CONTACT =$S(TYPE=3 :"secondar y",1:"prim ary")
  8465   "RTN","VPR CRPC1",62, 0)
  8466    S CNT=$S( TYPE=3:2,1 :1)
  8467   "RTN","VPR CRPC1",63, 0)
  8468    D OAD^VAD PT
  8469   "RTN","VPR CRPC1",64, 0)
  8470    ;
  8471   "RTN","VPR CRPC1",65, 0)
  8472    I VAOA(9) ]"" S VALU ES("nok",C NT,"name") =VAOA(9)
  8473   "RTN","VPR CRPC1",66, 0)
  8474    I VAOA(10 )]"" S VAL UES("nok", CNT,"relat ionship")= VAOA(10)
  8475   "RTN","VPR CRPC1",67, 0)
  8476    I VAOA(1) ]"" S VALU ES("nok",C NT,"addres s","street ",1)=VAOA( 1)
  8477   "RTN","VPR CRPC1",68, 0)
  8478    I VAOA(2) ]"" S VALU ES("nok",C NT,"addres s","street ",2)=VAOA( 2)
  8479   "RTN","VPR CRPC1",69, 0)
  8480    I VAOA(3) ]"" S VALU ES("nok",C NT,"addres s","street ",3)=VAOA( 3)
  8481   "RTN","VPR CRPC1",70, 0)
  8482    I VAOA(4) ]"" S VALU ES("nok",C NT,"addres s","city") =VAOA(4)
  8483   "RTN","VPR CRPC1",71, 0)
  8484    I VAOA(5) ]"" S VALU ES("nok",C NT,"addres s","state" )=$P(VAOA( 5),U,2)
  8485   "RTN","VPR CRPC1",72, 0)
  8486    I VAOA(6) ]"" S VALU ES("nok",C NT,"addres s","zip")= VAOA(6)
  8487   "RTN","VPR CRPC1",73, 0)
  8488    I VAOA(8) ]"" S VALU ES("nok",C NT,"addres s","phone" )=VAOA(8)
  8489   "RTN","VPR CRPC1",74, 0)
  8490    D KVAR^VA DPT
  8491   "RTN","VPR CRPC1",75, 0)
  8492    Q
  8493   "RTN","VPR CRPC1",76, 0)
  8494    ;
  8495   "RTN","VPR CRPC1",77, 0)
  8496   GETPATI(RE SULT,DFN)  ;
  8497   "RTN","VPR CRPC1",78, 0)
  8498    N TYPE,VA LUES,VPRER R,Y
  8499   "RTN","VPR CRPC1",79, 0)
  8500    D BUILDUI D^VPRPARAM (.VALUES," patient",D FN)
  8501   "RTN","VPR CRPC1",80, 0)
  8502    D GETDEM( .VALUES,DF N)
  8503   "RTN","VPR CRPC1",81, 0)
  8504    D GETADD( .VALUES,DF N)
  8505   "RTN","VPR CRPC1",82, 0)
  8506    F TYPE=1, 3 D GETNOK (.VALUES,D FN,TYPE)
  8507   "RTN","VPR CRPC1",83, 0)
  8508    D GETPATT M(.VALUES, DFN)
  8509   "RTN","VPR CRPC1",84, 0)
  8510    D GETPATV I(.VALUES, DFN)
  8511   "RTN","VPR CRPC1",85, 0)
  8512    D GETPATI P(.VALUES, DFN)
  8513   "RTN","VPR CRPC1",86, 0)
  8514    D PRF^VPR FPTC(DFN,. VALUES)
  8515   "RTN","VPR CRPC1",87, 0)
  8516    S Y=$$CWA D^ORQPT2(D FN)
  8517   "RTN","VPR CRPC1",88, 0)
  8518    I Y]"" S  VALUES("cw ad")=Y
  8519   "RTN","VPR CRPC1",89, 0)
  8520    I $D(VALU ES("patien tRecordFla g")) S VAL UES("cwad" )=$G(VALUE S("cwad")) _"F"
  8521   "RTN","VPR CRPC1",90, 0)
  8522    D PTINQ^O RWPT(.DEM, DFN)
  8523   "RTN","VPR CRPC1",91, 0)
  8524    S NUM=5,S TR=""
  8525   "RTN","VPR CRPC1",92, 0)
  8526    F  S NUM= $O(@DEM@(N UM)) Q:NUM '>0  D
  8527   "RTN","VPR CRPC1",93, 0)
  8528    .S VALUES ("patDemDe tails","te xt","\",NU M)=@DEM@(N UM)_$C(13, 10)
  8529   "RTN","VPR CRPC1",94, 0)
  8530    S VALUES( "success") ="true"
  8531   "RTN","VPR CRPC1",95, 0)
  8532    D ENCODE^ VPRJSON("V ALUES","RE SULT","VPR ERR")
  8533   "RTN","VPR CRPC1",96, 0)
  8534    I $D(VPRE RR) D
  8535   "RTN","VPR CRPC1",97, 0)
  8536    .K RESULT  N TEMP,TX T
  8537   "RTN","VPR CRPC1",98, 0)
  8538    .S TXT(1) ="Problem  encoding j son output ."
  8539   "RTN","VPR CRPC1",99, 0)
  8540    .D SETERR OR^VPRUTIL S(.TEMP,.V PRERR,.TXT ,.VALUES)
  8541   "RTN","VPR CRPC1",100 ,0)
  8542    .K VPRERR  D ENCODE^ VPRJSON("T EMP","RESU LT","VPRER R")
  8543   "RTN","VPR CRPC1",101 ,0)
  8544    Q
  8545   "RTN","VPR CRPC1",102 ,0)
  8546    ;
  8547   "RTN","VPR CRPC1",103 ,0)
  8548   GETPATIP(V ALUES,DFN)  ;
  8549   "RTN","VPR CRPC1",104 ,0)
  8550    N VPRDATA
  8551   "RTN","VPR CRPC1",105 ,0)
  8552    D INPLOC^ ORWPT(.VPR DATA,DFN)
  8553   "RTN","VPR CRPC1",106 ,0)
  8554    I +VPRDAT A S VALUES ("inpatien tLocation" )=$P(VPRDA TA,U,2)
  8555   "RTN","VPR CRPC1",107 ,0)
  8556    Q
  8557   "RTN","VPR CRPC1",108 ,0)
  8558    ;
  8559   "RTN","VPR CRPC1",109 ,0)
  8560   GETPATVI(V ALUES,DFN)  ;
  8561   "RTN","VPR CRPC1",110 ,0)
  8562    N BMI,DAS ,HT,LDATE, VPRTEMP,WT
  8563   "RTN","VPR CRPC1",111 ,0)
  8564    ;get weig ht
  8565   "RTN","VPR CRPC1",112 ,0)
  8566    S LDATE=$ O(^PXRMIND X(120.5,"P I",DFN,9," "),-1)
  8567   "RTN","VPR CRPC1",113 ,0)
  8568    I LDATE>0  D
  8569   "RTN","VPR CRPC1",114 ,0)
  8570    .S DAS=$O (^PXRMINDX (120.5,"PI ",DFN,9,LD ATE,""))
  8571   "RTN","VPR CRPC1",115 ,0)
  8572    .I DAS']" " Q
  8573   "RTN","VPR CRPC1",116 ,0)
  8574    .D GETDAT A^PXRMVITL (DAS,.VPRT EMP)
  8575   "RTN","VPR CRPC1",117 ,0)
  8576    .S WT=VPR TEMP("VALU E")
  8577   "RTN","VPR CRPC1",118 ,0)
  8578    .S VALUES ("lastVita ls","weigh t","value" )=WT
  8579   "RTN","VPR CRPC1",119 ,0)
  8580    .S VALUES ("lastVita ls","weigh t","lastDo ne")=$$FMT E^XLFDT(LD ATE,"D")
  8581   "RTN","VPR CRPC1",120 ,0)
  8582    ;get heig ht
  8583   "RTN","VPR CRPC1",121 ,0)
  8584    K LDATE,D AS
  8585   "RTN","VPR CRPC1",122 ,0)
  8586    S LDATE=$ O(^PXRMIND X(120.5,"P I",DFN,8," "),-1)
  8587   "RTN","VPR CRPC1",123 ,0)
  8588    I LDATE>0  D
  8589   "RTN","VPR CRPC1",124 ,0)
  8590    .S DAS=$O (^PXRMINDX (120.5,"PI ",DFN,8,LD ATE,""))
  8591   "RTN","VPR CRPC1",125 ,0)
  8592    .I DAS']" " Q
  8593   "RTN","VPR CRPC1",126 ,0)
  8594    .D GETDAT A^PXRMVITL (DAS,.VPRT EMP)
  8595   "RTN","VPR CRPC1",127 ,0)
  8596    .S HT=VPR TEMP("VALU E")
  8597   "RTN","VPR CRPC1",128 ,0)
  8598    .S VALUES ("lastVita ls","heigh t","value" )=HT
  8599   "RTN","VPR CRPC1",129 ,0)
  8600    .S VALUES ("lastVita ls","heigh t","lastDo ne")=$$FMT E^XLFDT(LD ATE,"D")
  8601   "RTN","VPR CRPC1",130 ,0)
  8602    S BMI=$$G ETBMI(DFN)
  8603   "RTN","VPR CRPC1",131 ,0)
  8604    I BMI>0 S  VALUES("l astVitals" ,"bmi")=BM I
  8605   "RTN","VPR CRPC1",132 ,0)
  8606    S BSA=$$G ETBSA(DFN)
  8607   "RTN","VPR CRPC1",133 ,0)
  8608    I BSA>0 S  VALUES("l astVitals" ,"bsa")=BS A
  8609   "RTN","VPR CRPC1",134 ,0)
  8610    Q
  8611   "RTN","VPR CRPC1",135 ,0)
  8612   GETPATTM(V ALUES,DFN)  ;
  8613   "RTN","VPR CRPC1",136 ,0)
  8614    N CNT,PRO V,TEAM,MH, X,VPRTEAM
  8615   "RTN","VPR CRPC1",137 ,0)
  8616    S PROV=$$ OUTPTPR^SD UTL3(DFN)
  8617   "RTN","VPR CRPC1",138 ,0)
  8618    S TEAM=$$ OUTPTTM^SD UTL3(DFN)
  8619   "RTN","VPR CRPC1",139 ,0)
  8620    S MH=$$ST ART^SCMCMH TC(DFN)
  8621   "RTN","VPR CRPC1",140 ,0)
  8622    I PROV D
  8623   "RTN","VPR CRPC1",141 ,0)
  8624    .S VALUES ("teamInfo ","primary Provider", "name")=$P (PROV,U,2)
  8625   "RTN","VPR CRPC1",142 ,0)
  8626    .S VALUES ("teamInfo ","primary Provider", "analogPag er")=$P($G (^VA(200,+ PROV,.13)) ,U,7)
  8627   "RTN","VPR CRPC1",143 ,0)
  8628    .S VALUES ("teamInfo ","primary Provider", "digitalPa ger")=$P($ G(^VA(200, +PROV,.13) ),U,8)
  8629   "RTN","VPR CRPC1",144 ,0)
  8630    .S VALUES ("teamInfo ","primary Provider", "officelPa ger")=$P($ G(^VA(200, +PROV,.13) ),U,2)
  8631   "RTN","VPR CRPC1",145 ,0)
  8632    I 'PROV S  VALUES("t eamInfo"," primaryPro vider","na me")="unas signed"
  8633   "RTN","VPR CRPC1",146 ,0)
  8634    I TEAM D
  8635   "RTN","VPR CRPC1",147 ,0)
  8636    .S VALUES ("teamInfo ","team"," name")=$P( TEAM,U,2)
  8637   "RTN","VPR CRPC1",148 ,0)
  8638    .S VALUES ("teamInfo ","team"," phone")=$P ($G(^SCTM( 404.51,+TE AM,0)),U,2 )
  8639   "RTN","VPR CRPC1",149 ,0)
  8640    I 'TEAM S  VALUES("t eamInfo"," team","nam e")="unass igned"
  8641   "RTN","VPR CRPC1",150 ,0)
  8642    S X=$G(^D PT(DFN,.10 41))
  8643   "RTN","VPR CRPC1",151 ,0)
  8644    I +X D
  8645   "RTN","VPR CRPC1",152 ,0)
  8646    . S VALUE S("teamInf o","attend ingProvide r","name") =$P($G(^VA (200,+X,0) ),U)
  8647   "RTN","VPR CRPC1",153 ,0)
  8648    . S VALUE S("teamInf o","attend ingProvide r","analog Pager")=$P ($G(^VA(20 0,+X,.13)) ,U,7)
  8649   "RTN","VPR CRPC1",154 ,0)
  8650    . S VALUE S("teamInf o","attend ingProvide r","office lPager")=$ P($G(^VA(2 00,+X,.13) ),U,8)
  8651   "RTN","VPR CRPC1",155 ,0)
  8652    . S VALUE S("teamInf o","attend ingProvide r","office lPager")=$ P($G(^VA(2 00,+X,.13) ),U,2)
  8653   "RTN","VPR CRPC1",156 ,0)
  8654    I '+X S V ALUES("tea mInfo","at tendingPro vider","na me")="unas signed"
  8655   "RTN","VPR CRPC1",157 ,0)
  8656    I MH D
  8657   "RTN","VPR CRPC1",158 ,0)
  8658    .S VALUES ("teamInfo ","mhCoord inator","n ame")=$P(M H,U,2)
  8659   "RTN","VPR CRPC1",159 ,0)
  8660    .S VALUES ("teamInfo ","mhPosit ion")=$P(M H,U,3)
  8661   "RTN","VPR CRPC1",160 ,0)
  8662    .S VALUES ("teamInfo ","mhTeam" )=$P(MH,U, 5)
  8663   "RTN","VPR CRPC1",161 ,0)
  8664    .S VALUES ("teamInfo ","mhCoord inator","a nalogPager ")=$P($G(^ VA(200,+MH ,.13)),U,7 )
  8665   "RTN","VPR CRPC1",162 ,0)
  8666    .S VALUES ("teamInfo ","mhCoord inator","d igitalPage r")=$P($G( ^VA(200,+M H,.13)),U, 8)
  8667   "RTN","VPR CRPC1",163 ,0)
  8668    .S VALUES ("teamInfo ","mhCoord inator","o fficePhone ")=$P($G(^ VA(200,+MH ,.13)),U,2 )
  8669   "RTN","VPR CRPC1",164 ,0)
  8670    .I 'MH D
  8671   "RTN","VPR CRPC1",165 ,0)
  8672    ..S VALUE S("teamInf o","mhCoor dinator"," name")="un assigned"
  8673   "RTN","VPR CRPC1",166 ,0)
  8674    ..S VALUE S("teamInf o","mhPosi tion")="un assigned"
  8675   "RTN","VPR CRPC1",167 ,0)
  8676    ..S VALUE S("teamInf o","mhTeam ")="unassi gned"
  8677   "RTN","VPR CRPC1",168 ,0)
  8678    D PCDETAI L^ORWPT1(. VPRTEAM,DF N)
  8679   "RTN","VPR CRPC1",169 ,0)
  8680    S CNT=0 F   S CNT=$O (VPRTEAM(C NT)) Q:CNT '>0  D
  8681   "RTN","VPR CRPC1",170 ,0)
  8682    .S VALUES ("teamInfo ","text"," \",CNT)=VP RTEAM(CNT) _$C(13,10)
  8683   "RTN","VPR CRPC1",171 ,0)
  8684    Q
  8685   "RTN","VPR CRPC1",172 ,0)
  8686    ;
  8687   "RTN","VPR CRPC1",173 ,0)
  8688   GETPOS(VAL UES,USER)  ;
  8689   "RTN","VPR CRPC1",174 ,0)
  8690    ; this re turns the  list of po sition for  an user
  8691   "RTN","VPR CRPC1",175 ,0)
  8692    N CNT,NOD E,NUM,ROLE IEN,ROLE,T EAM,TEAMIE N,TEAMPHN, VPRLIST,VP RERR
  8693   "RTN","VPR CRPC1",176 ,0)
  8694    ;$$TPPR^S CAPMC(DUZ, SCDATES,SC PURPA,SCRO LEA,"LIST" ,VPRERR)
  8695   "RTN","VPR CRPC1",177 ,0)
  8696    S NUM=$$T PPR^SCAPMC (USER,""," ","","",.V PRERR)
  8697   "RTN","VPR CRPC1",178 ,0)
  8698    F CNT=1:1 :NUM D
  8699   "RTN","VPR CRPC1",179 ,0)
  8700    .S NODE=$ G(^TMP("SC  TMP LIST" ,$J,CNT))
  8701   "RTN","VPR CRPC1",180 ,0)
  8702    .S VALUES ("vistaPos itions",CN T,"positio n")=$P(NOD E,U,2)
  8703   "RTN","VPR CRPC1",181 ,0)
  8704    .S VALUES ("vistaPos itions",CN T,"effecti veDate")=$ P(NODE,U,5 )
  8705   "RTN","VPR CRPC1",182 ,0)
  8706    .S VALUES ("vistaPos itions",CN T,"inactiv eDate")=$P (NODE,U,6)
  8707   "RTN","VPR CRPC1",183 ,0)
  8708    .S TEAMIE N=$P(NODE, U,3)
  8709   "RTN","VPR CRPC1",184 ,0)
  8710    .S TEAM=$ $GET1^DIQ( 404.51,(+T EAMIEN_"," ),.01)
  8711   "RTN","VPR CRPC1",185 ,0)
  8712    .S TEAMPH N=$$GET1^D IQ(404.51, (+TEAMIEN_ ","),.02)
  8713   "RTN","VPR CRPC1",186 ,0)
  8714    .S VALUES ("vistaPos itions",CN T,"teamNam e")=TEAM
  8715   "RTN","VPR CRPC1",187 ,0)
  8716    .S VALUES ("vistaPos itions",CN T,"teamPho ne")=TEAMP HN
  8717   "RTN","VPR CRPC1",188 ,0)
  8718    .I $P(NOD E,U,9)>0 D
  8719   "RTN","VPR CRPC1",189 ,0)
  8720    .S VALUES ("vistaPos itions",CN T,"role")= $$GET1^DIQ (8930,($P( NODE,U,9)_ ","),.01)
  8721   "RTN","VPR CRPC1",190 ,0)
  8722    Q
  8723   "RTN","VPR CRPC1",191 ,0)
  8724    ;
  8725   "RTN","VPR CRPC1",192 ,0)
  8726   GETUSERC(V ALUES,USER ) ;
  8727   "RTN","VPR CRPC1",193 ,0)
  8728    N CNT,EFF DATE,EXPDA TE,IND,NOD E
  8729   "RTN","VPR CRPC1",194 ,0)
  8730    D WHATIS^ USRLM(USER ,"LIST",1)
  8731   "RTN","VPR CRPC1",195 ,0)
  8732    ;LIST(Upp ername_ind icator)=Us erClassIEN ^Membershi pIEN^name^ EffectDt^E xpireDt
  8733   "RTN","VPR CRPC1",196 ,0)
  8734    S IND=0,C NT=0 F  S  IND=$O(LIS T(IND)) Q: IND=""  D
  8735   "RTN","VPR CRPC1",197 ,0)
  8736    .S NODE=L IST(IND)
  8737   "RTN","VPR CRPC1",198 ,0)
  8738    .S EFFDAT E=$P(NODE, U,4),EXPDA TE=$P(NODE ,U,5)
  8739   "RTN","VPR CRPC1",199 ,0)
  8740    .I EFFDAT E>0,EFFDAT E>DT Q
  8741   "RTN","VPR CRPC1",200 ,0)
  8742    .I EXPDAT E>0,EXPDAT E<DT Q
  8743   "RTN","VPR CRPC1",201 ,0)
  8744    .S CNT=CN T+1
  8745   "RTN","VPR CRPC1",202 ,0)
  8746    .S VALUES ("vistaUse rClass",CN T,"role")= $P(NODE,U, 3)
  8747   "RTN","VPR CRPC1",203 ,0)
  8748    .S VALUES ("vistaUse rClass",CN T,"id")=$P (NODE,U)
  8749   "RTN","VPR CRPC1",204 ,0)
  8750    .S VALUES ("vistaUse rClass",CN T,"effecti veDate")=E FFDATE
  8751   "RTN","VPR CRPC1",205 ,0)
  8752    .S VALUES ("vistaUse rClass",CN T,"expirat ionDate")= EXPDATE
  8753   "RTN","VPR CRPC1",206 ,0)
  8754    .S VALUES ("vistaUse rClass",CN T,"uid")=$ $SETUID^VP RUTILS("as u-class",, $P(NODE,U) )
  8755   "RTN","VPR CRPC1",207 ,0)
  8756    .S VALUES ("vistaUse rClass",CN T,"roleUid ")=$$SETUI D^VPRUTILS ("asu-role ",,$P(NODE ,U,3))
  8757   "RTN","VPR CRPC1",208 ,0)
  8758    Q
  8759   "RTN","VPR CRPC1",209 ,0)
  8760    ;
  8761   "RTN","VPR CRPC1",210 ,0)
  8762   GETUSERI(R ESULT,USER ) ;
  8763   "RTN","VPR CRPC1",211 ,0)
  8764    N RPCOPT, VALUES,VPR ERR,VPRLIS T
  8765   "RTN","VPR CRPC1",212 ,0)
  8766    D BUILDUI D^VPRPARAM (.VALUES," user",USER )
  8767   "RTN","VPR CRPC1",213 ,0)
  8768    S VALUES( "timeout") =$$GET^XPA R("USR^SYS ","ORWOR T IMEOUT CHA RT",1,"I")
  8769   "RTN","VPR CRPC1",214 ,0)
  8770    S VALUES( "timeoutCo unter")=$$ GET^XPAR(" USR^SYS^PK G","ORWOR  TIMEOUT CO UNTDOWN",1 ,"I")
  8771   "RTN","VPR CRPC1",215 ,0)
  8772    S CPRSPAT H=$$GET^XP AR("USR^SY S","VPR CP RS PATH",1 ,"I")
  8773   "RTN","VPR CRPC1",216 ,0)
  8774    S VALUES( "cprsPath" )=$S($L($G (CPRSPATH) )>0:CPRSPA TH,1:"")
  8775   "RTN","VPR CRPC1",217 ,0)
  8776    D FIND^DI C(19,"",1, "X","VPR U I CONTEXT" ,1,,,,"VPR LIST")
  8777   "RTN","VPR CRPC1",218 ,0)
  8778    S RPCOPT= $S($D(^VPR LIST("DILI ST",0)):-1 ,1:$P(VPRL IST("DILIS T","ID",1, 1),"versio n ",2))
  8779   "RTN","VPR CRPC1",219 ,0)
  8780    ;S VALUES ("signingP riv")=$S($ D(^XUSEC(" ORES",DUZ) ):3,$D(^XU SEC("ORELS E",DUZ)):2 ,$D(^XUSEC ("OREMAS", DUZ)):1,1: 0)
  8781   "RTN","VPR CRPC1",220 ,0)
  8782    S VALUES( "orderingR ole")=$$OR DROLE(USER )
  8783   "RTN","VPR CRPC1",221 ,0)
  8784    S VALUES( "hmpVersio n")=RPCOPT
  8785   "RTN","VPR CRPC1",222 ,0)
  8786    S VALUES( "domain")= $$KSP^XUPA RAM("WHERE ")  ; doma in
  8787   "RTN","VPR CRPC1",223 ,0)
  8788    S VALUES( "service") =+$G(^VA(2 00,USER,5) )     ; se rvice/sect ion
  8789   "RTN","VPR CRPC1",224 ,0)
  8790    D GETUSER C(.VALUES, USER)
  8791   "RTN","VPR CRPC1",225 ,0)
  8792    D GETPOS( .VALUES,US ER)
  8793   "RTN","VPR CRPC1",226 ,0)
  8794    D GETKEYS (.VALUES,U SER)
  8795   "RTN","VPR CRPC1",227 ,0)
  8796    S VALUES( "productio nAccount") =$S($$PROD ^XUPROD=1: "true",1:" false")
  8797   "RTN","VPR CRPC1",228 ,0)
  8798    ;S RESULT =$$ENCODE^ VPRJSON("V ALUES","VP RERR")
  8799   "RTN","VPR CRPC1",229 ,0)
  8800    D ENCODE^ VPRJSON("V ALUES","RE SULT","VPR ERR")
  8801   "RTN","VPR CRPC1",230 ,0)
  8802    Q
  8803   "RTN","VPR CRPC1",231 ,0)
  8804    ;
  8805   "RTN","VPR CRPC1",232 ,0)
  8806   ORDROLE(US ER) ; retu rns the ro le a perso n takes in  ordering
  8807   "RTN","VPR CRPC1",233 ,0)
  8808    ; VAL: 0= nokey, 1=c lerk, 2=nu rse, 3=phy sician, 4= student, 5 =bad keys
  8809   "RTN","VPR CRPC1",234 ,0)
  8810    ;I '$G(OR WCLVER) Q  0  ; versi on of clie nt is to o ld for ord ering
  8811   "RTN","VPR CRPC1",235 ,0)
  8812    I ($D(^XU SEC("OREMA S",USER))+ $D(^XUSEC( "ORELSE",U SER))+$D(^ XUSEC("ORE S",USER))) >1 Q 5
  8813   "RTN","VPR CRPC1",236 ,0)
  8814    I $D(^XUS EC("OREMAS ",USER)) Q  1                             ;  clerk
  8815   "RTN","VPR CRPC1",237 ,0)
  8816    I $D(^XUS EC("ORELSE ",USER)) Q  2                             ;  nurse
  8817   "RTN","VPR CRPC1",238 ,0)
  8818    I $D(^XUS EC("ORES", USER)),$D( ^XUSEC("PR OVIDER",US ER)) Q 3   ; doctor
  8819   "RTN","VPR CRPC1",239 ,0)
  8820    I $D(^XUS EC("PROVID ER",USER))  Q 4                           ;  student
  8821   "RTN","VPR CRPC1",240 ,0)
  8822    Q 0
  8823   "RTN","VPR CRPC1",241 ,0)
  8824    ;
  8825   "RTN","VPR DJ")
  8826   0^68^B3355 2080
  8827   "RTN","VPR DJ",1,0)
  8828   VPRDJ ;SLC /MKB -- Se rve VistA  data as JS ON via RPC  ;10/18/12  6:26pm
  8829   "RTN","VPR DJ",2,0)
  8830    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  8831   "RTN","VPR DJ",3,0)
  8832    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  8833   "RTN","VPR DJ",4,0)
  8834    ;
  8835   "RTN","VPR DJ",5,0)
  8836    ; Externa l Referenc es           DBIA#
  8837   "RTN","VPR DJ",6,0)
  8838    ; ------- ---------- --           -----
  8839   "RTN","VPR DJ",7,0)
  8840    ; ^DPT                            10035
  8841   "RTN","VPR DJ",8,0)
  8842    ; MPIF001                          2701
  8843   "RTN","VPR DJ",9,0)
  8844    ; XLFDT                           10103
  8845   "RTN","VPR DJ",10,0)
  8846    ; XLFSTR                          10104
  8847   "RTN","VPR DJ",11,0)
  8848    ; XUPARAM                          2541
  8849   "RTN","VPR DJ",12,0)
  8850    ;
  8851   "RTN","VPR DJ",13,0)
  8852   GET(VPR,FI LTER) ; --  Return se arch resul ts as JSON  in @VPR@( n)
  8853   "RTN","VPR DJ",14,0)
  8854    ; RPC = V PR GET PAT IENT DATA  JSON
  8855   "RTN","VPR DJ",15,0)
  8856    ; where F ILTER("pat ientId") =  DFN or DF N;ICN
  8857   "RTN","VPR DJ",16,0)
  8858    ;       F ILTER("dom ain")    =  name of d esired dat a type  (s ee VPRDJ0)
  8859   "RTN","VPR DJ",17,0)
  8860    ;       F ILTER("tex t")      =  boolean,  to include  document  text [opt]
  8861   "RTN","VPR DJ",18,0)
  8862    ;       F ILTER("sta rt")     =  start dat e.time of  search          [opt]
  8863   "RTN","VPR DJ",19,0)
  8864    ;       F ILTER("sto p")      =  stop date .time of s earch           [opt]
  8865   "RTN","VPR DJ",20,0)
  8866    ;       F ILTER("max ")       =  maximum n umber of i tems to re turn [opt]
  8867   "RTN","VPR DJ",21,0)
  8868    ;       F ILTER("id" )        =  single it em id to r eturn           [opt]
  8869   "RTN","VPR DJ",22,0)
  8870    ;       F ILTER("uid ")       =  single re cord uid t o return        [opt]
  8871   "RTN","VPR DJ",23,0)
  8872    ;       F ILTER("noH ead")    =  flag, to  omit heade r and comm as   [opt]
  8873   "RTN","VPR DJ",24,0)
  8874    ;
  8875   "RTN","VPR DJ",25,0)
  8876    N ICN,DFN ,VPRI,VPRS YS,VPRTYPE ,VPRSTART, VPRSTOP,VP RMAX,VPRID ,VPRTEXT,V PRP,TYPE,V PRTN,VPRER R
  8877   "RTN","VPR DJ",26,0)
  8878    S VPR=$NA (^TMP("VPR ",$J)),VPR I=0 K @VPR
  8879   "RTN","VPR DJ",27,0)
  8880    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  8881   "RTN","VPR DJ",28,0)
  8882    S DT=$$DT ^XLFDT              ; for crossi ng midnigh t boundary
  8883   "RTN","VPR DJ",29,0)
  8884    ;
  8885   "RTN","VPR DJ",30,0)
  8886    ; parse &  validate  input para meters
  8887   "RTN","VPR DJ",31,0)
  8888    I $G(FILT ER("uid")) '="" D SEP UID(.FILTE R)
  8889   "RTN","VPR DJ",32,0)
  8890    S DFN=$G( FILTER("pa tientId"))
  8891   "RTN","VPR DJ",33,0)
  8892    S ICN=+$P ($G(DFN)," ;",2),DFN= +$G(DFN)
  8893   "RTN","VPR DJ",34,0)
  8894    I DFN<1,I CN S DFN=+ $$GETDFN^M PIF001(ICN )
  8895   "RTN","VPR DJ",35,0)
  8896    ;
  8897   "RTN","VPR DJ",36,0)
  8898    S VPRTYPE =$G(FILTER ("domain") ) S:VPRTYP E="" VPRTY PE=$$ALL
  8899   "RTN","VPR DJ",37,0)
  8900    I $D(ZTQU EUED) S VP R=$NA(^XTM P(VPRBATCH ,VPRFZTSK, VPRTYPE))  K @VPR
  8901   "RTN","VPR DJ",38,0)
  8902    I VPRTYPE '="new",DF N<1!'$D(^D PT(DFN)) S  VPRERR=$$ ERR(1,DFN)  G GTQ
  8903   "RTN","VPR DJ",39,0)
  8904    ;
  8905   "RTN","VPR DJ",40,0)
  8906    S VPRSTAR T=+$G(FILT ER("start" ),1410102)
  8907   "RTN","VPR DJ",41,0)
  8908    S VPRSTOP =+$G(FILTE R("stop"), 4141015)
  8909   "RTN","VPR DJ",42,0)
  8910    S VPRMAX= +$G(FILTER ("max"),99 9999)
  8911   "RTN","VPR DJ",43,0)
  8912    I VPRSTAR T,VPRSTOP, VPRSTOP<VP RSTART D
  8913   "RTN","VPR DJ",44,0)
  8914    . N X S X =VPRSTART, VPRSTART=V PRSTOP,VPR STOP=X
  8915   "RTN","VPR DJ",45,0)
  8916    I VPRSTOP ,$L(VPRSTO P,".")<2 S  VPRSTOP=V PRSTOP_".2 4"
  8917   "RTN","VPR DJ",46,0)
  8918    ;
  8919   "RTN","VPR DJ",47,0)
  8920    S VPRID=$ G(FILTER(" id"))
  8921   "RTN","VPR DJ",48,0)
  8922    S VPRTEXT =+$G(FILTE R("text"), 1) ;defaul t = true/t ext
  8923   "RTN","VPR DJ",49,0)
  8924    ;
  8925   "RTN","VPR DJ",50,0)
  8926    ;set erro r trap
  8927   "RTN","VPR DJ",51,0)
  8928    K ^TMP($J ,"VPR ERRO R")
  8929   "RTN","VPR DJ",52,0)
  8930    ;
  8931   "RTN","VPR DJ",53,0)
  8932    ; extract  data
  8933   "RTN","VPR DJ",54,0)
  8934    I VPRTYPE ="new",$L( $T(EN^VPRD JX)),'$G(^ XTMP("VPR- off","GET" )) D EN^VP RDJX(VPRID ,VPRMAX) Q   ;data up dates
  8935   "RTN","VPR DJ",55,0)
  8936    F VPRP=1: 1:$L(VPRTY PE,";") S  TYPE=$P(VP RTYPE,";", VPRP) I $L (TYPE) D
  8937   "RTN","VPR DJ",56,0)
  8938    . S VPRTN =$$TAG(TYP E)_"^VPRDJ 0" Q:'$L($ T(@VPRTN))   ;D ERR(2 ) Q
  8939   "RTN","VPR DJ",57,0)
  8940    . N $ES,$ ET,ERRPAT, ERRMSG
  8941   "RTN","VPR DJ",58,0)
  8942    . S $ET=" D ERRHDLR^ VPRDERRH", ERRMSG="A  problem oc curred whe n trying t o load pat ient data  from an AP I."
  8943   "RTN","VPR DJ",59,0)
  8944    . D @VPRT N
  8945   "RTN","VPR DJ",60,0)
  8946    ;
  8947   "RTN","VPR DJ",61,0)
  8948   GTQ ; add  item count  and termi nating cha racters
  8949   "RTN","VPR DJ",62,0)
  8950    N ERROR I  $D(^TMP($ J,"VPR ERR OR"))>0 D  BUILDERR(. ERROR)
  8951   "RTN","VPR DJ",63,0)
  8952    I +$G(FIL TER("noHea d"))=1 D   Q
  8953   "RTN","VPR DJ",64,0)
  8954    .S @VPR@( "total")=+ $G(VPRI)
  8955   "RTN","VPR DJ",65,0)
  8956    .I $L($G( ERROR(1))) >1 S @VPR@ ("error")= ERROR(1)
  8957   "RTN","VPR DJ",66,0)
  8958    S @VPR@(. 5)="{""api Version"": ""1.01""," "params"": {"_$$SYS_" },"
  8959   "RTN","VPR DJ",67,0)
  8960    I $D(VPRE RR) S @VPR @(1)="""er ror"":{""m essage"":" ""_VPRERR_ """}}" Q
  8961   "RTN","VPR DJ",68,0)
  8962    I '$D(@VP R)!'$G(VPR I) D  Q
  8963   "RTN","VPR DJ",69,0)
  8964    . I '$D(E RROR) S @V PR@(1)=""" data"":{"" totalItems "":0,""ite ms"":[]}}"  Q
  8965   "RTN","VPR DJ",70,0)
  8966    . S @VPR@ (1)="""dat a"":{""tot alItems"": 0,""items" ":[]},"
  8967   "RTN","VPR DJ",71,0)
  8968    . S @VPR@ (2,1)=ERRO R(1)_"}"
  8969   "RTN","VPR DJ",72,0)
  8970    ;
  8971   "RTN","VPR DJ",73,0)
  8972    S @VPR@(. 6)="""data "":{""upda ted"":"""_ $$HL7NOW_" "",""total Items"":"_ VPRI_",""i tems"":["
  8973   "RTN","VPR DJ",74,0)
  8974    S VPRI=VP RI+1,@VPR@ (VPRI)=$S( $D(ERROR): "]}",1:"]} }")
  8975   "RTN","VPR DJ",75,0)
  8976    I $D(ERRO R)>0 S VPR I=VPRI+1,@ VPR@(VPRI, .3)=",",@V PR@(VPRI,1 )=ERROR(1) _"}"
  8977   "RTN","VPR DJ",76,0)
  8978    K ^TMP($J ,"VPR ERRO R"),^TMP(" VPRTEXT",$ J)
  8979   "RTN","VPR DJ",77,0)
  8980    Q
  8981   "RTN","VPR DJ",78,0)
  8982    ;
  8983   "RTN","VPR DJ",79,0)
  8984   SEPUID(FIL TER) ; --  separate u id into FI LTER piece s
  8985   "RTN","VPR DJ",80,0)
  8986    N UID
  8987   "RTN","VPR DJ",81,0)
  8988    S UID=$G( FILTER("ui d")) K FIL TER("uid")  Q:UID=""
  8989   "RTN","VPR DJ",82,0)
  8990    I $P(UID, ":",4)'=VP RSYS Q
  8991   "RTN","VPR DJ",83,0)
  8992    S FILTER( "patientId ")=$P(UID, ":",5)
  8993   "RTN","VPR DJ",84,0)
  8994    S FILTER( "domain")= $P(UID,":" ,3)
  8995   "RTN","VPR DJ",85,0)
  8996    S FILTER( "id")=$P(U ID,":",6)
  8997   "RTN","VPR DJ",86,0)
  8998    Q
  8999   "RTN","VPR DJ",87,0)
  9000    ;
  9001   "RTN","VPR DJ",88,0)
  9002   SYS() ; --  return sy stem info  for JSON h eader
  9003   "RTN","VPR DJ",89,0)
  9004    Q """doma in"":"""_$ $KSP^XUPAR AM("WHERE" )_""",""sy stemId"":" ""_VPRSYS_ """"
  9005   "RTN","VPR DJ",90,0)
  9006    ;
  9007   "RTN","VPR DJ",91,0)
  9008   BUILDERR(R ESULT,DFN)  ; -- buil d error ar ray
  9009   "RTN","VPR DJ",92,0)
  9010    N COUNT,M ESSAGE,MSG CNT
  9011   "RTN","VPR DJ",93,0)
  9012    S COUNT=$ G(^TMP($J, "VPR ERROR ","# of Er rors"))
  9013   "RTN","VPR DJ",94,0)
  9014    S MESSAGE ="A mumps  error occu rred when  extracting  patient d ata. A tot al of "_CO UNT_" occu rred.\n\r"
  9015   "RTN","VPR DJ",95,0)
  9016    S MSGCNT= 0 F  S MSG CNT=$O(^TM P($J,"VPR  ERROR","ER ROR MESSAG E",MSGCNT) ) Q:MSGCNT '>0  D
  9017   "RTN","VPR DJ",96,0)
  9018    . S MESSA GE=MESSAGE _$G(^TMP($ J,"VPR ERR OR","ERROR  MESSAGE", MSGCNT))_" \n\r"
  9019   "RTN","VPR DJ",97,0)
  9020    S RESULT( 1)="""erro r"":{""mes sage"":""" _MESSAGE_" ""}"
  9021   "RTN","VPR DJ",98,0)
  9022    Q
  9023   "RTN","VPR DJ",99,0)
  9024    ;
  9025   "RTN","VPR DJ",100,0)
  9026   TAG(X) ; - - Return l inetag in  VPRDJ0 rou tine for c linical do main X
  9027   "RTN","VPR DJ",101,0)
  9028    N Y S X=$ G(X,"Z")
  9029   "RTN","VPR DJ",102,0)
  9030    S Y=$E($$ UP^XLFSTR( X),1,8)
  9031   "RTN","VPR DJ",103,0)
  9032    S:'$L($T( @(Y_"^VPRD J0"))) Y=" VPR"
  9033   "RTN","VPR DJ",104,0)
  9034    Q Y
  9035   "RTN","VPR DJ",105,0)
  9036    ;
  9037   "RTN","VPR DJ",106,0)
  9038   ALL() ; --  return st ring for a ll types o f data
  9039   "RTN","VPR DJ",107,0)
  9040    Q "patien t;problem; allergy;co nsult;vita l;lab;proc edure;obs; order;trea tment;med; ptf;factor ;immunizat ion;exam;c pt;educati on;pov;ski n;image;ap pointment; surgery;do cument;vis it;mh"
  9041   "RTN","VPR DJ",108,0)
  9042    ;
  9043   "RTN","VPR DJ",109,0)
  9044   ERR(X,VAL)  ; -- retu rn error m essage
  9045   "RTN","VPR DJ",110,0)
  9046    N MSG  S  MSG="Error "
  9047   "RTN","VPR DJ",111,0)
  9048    I X=1  S  MSG="Patie nt with df n '"_$G(VA L)_"' not  found"
  9049   "RTN","VPR DJ",112,0)
  9050    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  9051   "RTN","VPR DJ",113,0)
  9052    I X=3  S  MSG="UID ' "_$G(VAL)_ "' not fou nd"
  9053   "RTN","VPR DJ",114,0)
  9054    I X=4  S  MSG="Unabl e to creat e new obje ct"
  9055   "RTN","VPR DJ",115,0)
  9056    I X=99 S  MSG="Unkno wn request "
  9057   "RTN","VPR DJ",116,0)
  9058    Q MSG
  9059   "RTN","VPR DJ",117,0)
  9060    ;
  9061   "RTN","VPR DJ",118,0)
  9062   HL7NOW() ;  -- Return  current t ime in HL7  format
  9063   "RTN","VPR DJ",119,0)
  9064    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  9065   "RTN","VPR DJ",120,0)
  9066    ;
  9067   "RTN","VPR DJ",121,0)
  9068   ADD(ITEM,C OLL) ; --  add ITEM t o results
  9069   "RTN","VPR DJ",122,0)
  9070    I $D(VPRC RC),$D(COL L) D ONE^V PRDCRC(ITE M,COLL) Q   ;checksum
  9071   "RTN","VPR DJ",123,0)
  9072    ; -- add  ITEM to @V PR@(VPRI)  to return  JSON
  9073   "RTN","VPR DJ",124,0)
  9074    N VPRY,VP RERR
  9075   "RTN","VPR DJ",125,0)
  9076    D ENCODE^ VPRJSON(IT EM,"VPRY", "VPRERR")
  9077   "RTN","VPR DJ",126,0)
  9078    I $D(VPRE RR) D  ;re turn ERRor  instead o f ITEM
  9079   "RTN","VPR DJ",127,0)
  9080    . N VPRTM P,VPRTXT,V PRITM
  9081   "RTN","VPR DJ",128,0)
  9082    . M VPRIT M=@ITEM K  VPRY
  9083   "RTN","VPR DJ",129,0)
  9084    . S VPRTX T(1)="Prob lem encodi ng json ou tput."
  9085   "RTN","VPR DJ",130,0)
  9086    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.VP RITM)
  9087   "RTN","VPR DJ",131,0)
  9088    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","V PRY","VPRE RR")
  9089   "RTN","VPR DJ",132,0)
  9090    I $D(VPRY ) D
  9091   "RTN","VPR DJ",133,0)
  9092    . S VPRI= VPRI+1
  9093   "RTN","VPR DJ",134,0)
  9094    . ;I VPRI >1,'$G(FIL TER("noHea d")) S @VP R@(VPRI,.3 )=","
  9095   "RTN","VPR DJ",135,0)
  9096    . I VPRI> 1 S @VPR@( VPRI,.3)=" ,"
  9097   "RTN","VPR DJ",136,0)
  9098    . M @VPR@ (VPRI)=VPR Y
  9099   "RTN","VPR DJ",137,0)
  9100    Q
  9101   "RTN","VPR DJ",138,0)
  9102    ;
  9103   "RTN","VPR DJ",139,0)
  9104   TEST(DFN,T YPE,ID,TEX T,IN) ; --  test GET,  write res ults to sc reen
  9105   "RTN","VPR DJ",140,0)
  9106    N OUT,IDX  S U="^"
  9107   "RTN","VPR DJ",141,0)
  9108    S:'$D(IN( "systemID" )) IN("sys temID")=$$ GET^XPAR(" SYS","VPR  SYSTEM NAM E")
  9109   "RTN","VPR DJ",142,0)
  9110    S IN("pat ientId")=+ $G(DFN)
  9111   "RTN","VPR DJ",143,0)
  9112    S IN("dom ain")=$G(T YPE)
  9113   "RTN","VPR DJ",144,0)
  9114    S:$D(ID)  IN("id")=I D
  9115   "RTN","VPR DJ",145,0)
  9116    S:$D(TEXT ) IN("text ")=TEXT
  9117   "RTN","VPR DJ",146,0)
  9118    D GET(.OU T,.IN)
  9119   "RTN","VPR DJ",147,0)
  9120    ;
  9121   "RTN","VPR DJ",148,0)
  9122    S IDX=OUT
  9123   "RTN","VPR DJ",149,0)
  9124    F  S IDX= $Q(@IDX) Q :IDX'?1"^T MP(""VPR"" ,"1.N.E  Q :+$P(IDX," ,",2)'=$J   W !,@IDX
  9125   "RTN","VPR DJ",150,0)
  9126    Q
  9127   "RTN","VPR DJ00")
  9128   0^70^B6478 4793
  9129   "RTN","VPR DJ00",1,0)
  9130   VPRDJ00 ;S LC/MKB --  Patient de mographics  ;8/11/11   15:29
  9131   "RTN","VPR DJ00",2,0)
  9132    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  9133   "RTN","VPR DJ00",3,0)
  9134    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  9135   "RTN","VPR DJ00",4,0)
  9136    ;
  9137   "RTN","VPR DJ00",5,0)
  9138    ; Externa l Referenc es           DBIA#
  9139   "RTN","VPR DJ00",6,0)
  9140    ; ------- ---------- --           -----
  9141   "RTN","VPR DJ00",7,0)
  9142    ; ^AUPNVS IT                       2028
  9143   "RTN","VPR DJ00",8,0)
  9144    ; ^DPT                            10035
  9145   "RTN","VPR DJ00",9,0)
  9146    ; DGCV                             4156
  9147   "RTN","VPR DJ00",10,0 )
  9148    ; DGMSTAP I                        2716
  9149   "RTN","VPR DJ00",11,0 )
  9150    ; DGNTAPI                          3457
  9151   "RTN","VPR DJ00",12,0 )
  9152    ; DGPFAPI                          3860
  9153   "RTN","VPR DJ00",13,0 )
  9154    ; DGRPDB                           4807
  9155   "RTN","VPR DJ00",14,0 )
  9156    ; DIQ                              2056
  9157   "RTN","VPR DJ00",15,0 )
  9158    ; MPIF001                          2701
  9159   "RTN","VPR DJ00",16,0 )
  9160    ; SDUTL3                           1252
  9161   "RTN","VPR DJ00",17,0 )
  9162    ; VADPT                           10061
  9163   "RTN","VPR DJ00",18,0 )
  9164    ; VAFCTFU 1                        2990
  9165   "RTN","VPR DJ00",19,0 )
  9166    ; VASITE                          10112
  9167   "RTN","VPR DJ00",20,0 )
  9168    ; XUAF4                            2171
  9169   "RTN","VPR DJ00",21,0 )
  9170    ;
  9171   "RTN","VPR DJ00",22,0 )
  9172    ; All tag s expect D FN, VPRID,  [VPRSTART , VPRSTOP,  VPRMAX, V PRTEXT]
  9173   "RTN","VPR DJ00",23,0 )
  9174    ;
  9175   "RTN","VPR DJ00",24,0 )
  9176   DPT1 ; --  Demographi cs [VPRSTA RT,VPRSTOP ,VPRMAX,VP RID not cu rrently us ed here]
  9177   "RTN","VPR DJ00",25,0 )
  9178    N PAT,SYS  S SYS=$$S ITE^VASITE
  9179   "RTN","VPR DJ00",26,0 )
  9180    N $ES,$ET ,ERRPAT,ER RMSG
  9181   "RTN","VPR DJ00",27,0 )
  9182    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  9183   "RTN","VPR DJ00",28,0 )
  9184    S ERRMSG= "A problem  occurred  building t he patient  "_DFN_" d emographic  extract."
  9185   "RTN","VPR DJ00",29,0 )
  9186    D DEM,SVC ,PRF,ATC,S UPP,ALIAS, FAC,PC
  9187   "RTN","VPR DJ00",30,0 )
  9188    I $D(PAT) >9 D ADD^V PRDJ("PAT" )
  9189   "RTN","VPR DJ00",31,0 )
  9190    Q
  9191   "RTN","VPR DJ00",32,0 )
  9192    ;
  9193   "RTN","VPR DJ00",33,0 )
  9194   DEM ;-demo graphic da ta
  9195   "RTN","VPR DJ00",34,0 )
  9196    N VADM,VA ,VAERR,X
  9197   "RTN","VPR DJ00",35,0 )
  9198    S X=$$GET ICN^MPIF00 1(DFN) S:X >1 PAT("ic n")=X
  9199   "RTN","VPR DJ00",36,0 )
  9200    D DEM^VAD PT S X=VAD M(1),PAT(" fullName") =X
  9201   "RTN","VPR DJ00",37,0 )
  9202    S PAT("fa milyName") =$P(X,",") ,PAT("give nNames")=$ P(X,",",2, 99)
  9203   "RTN","VPR DJ00",38,0 )
  9204    S PAT("ss n")=$P(VAD M(2),U),PA T("localId ")=DFN
  9205   "RTN","VPR DJ00",39,0 )
  9206    S PAT("ui d")=$$SETU ID^VPRUTIL S("patient ",DFN,DFN)
  9207   "RTN","VPR DJ00",40,0 )
  9208    S:$D(VA(" BID")) PAT ("briefId" )=$E(X)_VA ("BID")
  9209   "RTN","VPR DJ00",41,0 )
  9210    S X=+$P($ P(VADM(3), U),"."),PA T("dateOfB irth")=$$J SONDT^VPRU TILS(X)
  9211   "RTN","VPR DJ00",42,0 )
  9212    S X=$P(VA DM(5),U),P AT("gender Code")="ur n:va:pat-g ender:"_X, PAT("gende rName")=$$ NAME(X,"ge nder")
  9213   "RTN","VPR DJ00",43,0 )
  9214    S X=+$P($ P(VADM(6), U),".") S: X PAT("die d")=$$JSON DT^VPRUTIL S(X)
  9215   "RTN","VPR DJ00",44,0 )
  9216    S X=$$GET 1^DIQ(38.1 ,DFN_",",2 ,"I") S:$L (X) PAT("s ensitive") =$$BOOL(X)
  9217   "RTN","VPR DJ00",45,0 )
  9218    S X=+VADM (9) S:X PA T("religio nCode")="u rn:va:pat- religion:" _X,PAT("re ligionName ")=$$NAME( X,"religio n")
  9219   "RTN","VPR DJ00",46,0 )
  9220    S X=$P(VA DM(10),U,2 ) I $L(X)  D  ;PAT("m aritalStat us")=$E(X)
  9221   "RTN","VPR DJ00",47,0 )
  9222    . S X=$E( X),X=$S(X= "S":"L",X= "N":"S",1: X)
  9223   "RTN","VPR DJ00",48,0 )
  9224    . S PAT(" maritalSta tuses",1," code")="ur n:va:pat-m aritalStat us:"_X
  9225   "RTN","VPR DJ00",49,0 )
  9226    . S PAT(" maritalSta tuses",1," name")=$$N AME(X,"mar italStatus ")
  9227   "RTN","VPR DJ00",50,0 )
  9228    I VADM(11 ) D
  9229   "RTN","VPR DJ00",51,0 )
  9230    . N I S I =0
  9231   "RTN","VPR DJ00",52,0 )
  9232    . F  S I= $O(VADM(11 ,I)) Q:I<1   S X=+VAD M(11,I),PA T("ethnici ties",X,"e thnicity") =$$GET1^DI Q(2.06,X_" ,"_DFN_"," ,".01:3")
  9233   "RTN","VPR DJ00",53,0 )
  9234    I VADM(12 ) D
  9235   "RTN","VPR DJ00",54,0 )
  9236    . N I S I =0
  9237   "RTN","VPR DJ00",55,0 )
  9238    . F  S I= $O(VADM(12 ,I)) Q:I<1   S X=+VAD M(12,I),PA T("races", X,"race")= $$GET1^DIQ (2.02,X_", "_DFN_",", ".01:3")
  9239   "RTN","VPR DJ00",56,0 )
  9240    Q
  9241   "RTN","VPR DJ00",57,0 )
  9242   SVC ;-serv ice data
  9243   "RTN","VPR DJ00",58,0 )
  9244    N VAEL,VA SV,VAERR,X ,Y,I,P,AO, IR,PGF,HNC ,MST,CV,VP RSC
  9245   "RTN","VPR DJ00",59,0 )
  9246    D 7^VADPT
  9247   "RTN","VPR DJ00",60,0 )
  9248    ; PAT("ve teran")=VA EL(4)
  9249   "RTN","VPR DJ00",61,0 )
  9250    S PAT("ve teran","se rviceConne cted")=$$B OOL(+VAEL( 3)) I VAEL (3) D
  9251   "RTN","VPR DJ00",62,0 )
  9252    . S PAT(" veteran"," serviceCon nectionPer cent")=+$P (VAEL(3),U ,2)
  9253   "RTN","VPR DJ00",63,0 )
  9254    . D GETS^ DIQ(2,DFN_ ",",".3731 *",,"VPRSC ")
  9255   "RTN","VPR DJ00",64,0 )
  9256    . S I=""  F  S I=$O( VPRSC(2.05 ,I)) Q:I=" "  D
  9257   "RTN","VPR DJ00",65,0 )
  9258    .. S PAT( "veteran", "scConditi ons",+I,"n ame")=VPRS C(2.05,I,. 01)
  9259   "RTN","VPR DJ00",66,0 )
  9260    .. S PAT( "veteran", "scConditi ons",+I,"s cPercent") =VPRSC(2.0 5,I,.02)
  9261   "RTN","VPR DJ00",67,0 )
  9262    S X=+$G(^ DPT(DFN,"L R")) S:X P AT("vetera n","lrdfn" )=X
  9263   "RTN","VPR DJ00",68,0 )
  9264    ;
  9265   "RTN","VPR DJ00",69,0 )
  9266    ; exposur es
  9267   "RTN","VPR DJ00",70,0 )
  9268    S AO=VASV (2),IR=VAS V(3)
  9269   "RTN","VPR DJ00",71,0 )
  9270    S PGF=VAS V(11)!VASV (12)!VASV( 13) ;OIF/O EF
  9271   "RTN","VPR DJ00",72,0 )
  9272    S X=$$GET CUR^DGNTAP I(DFN,"HNC "),X=+($G( HNC("STAT" )))
  9273   "RTN","VPR DJ00",73,0 )
  9274    S HNC=$S( X=4:1,X=5: 1,X=1:0,X= 6:0,1:"")
  9275   "RTN","VPR DJ00",74,0 )
  9276    S X=$P($$ GETSTAT^DG MSTAPI(DFN ),U,2),MST =$S(X="Y": 1,X="N":0, 1:"")
  9277   "RTN","VPR DJ00",75,0 )
  9278    S X=$$CVE DT^DGCV(DF N),CV=$S(+ X<0:"",+X= 0:0,$P(X,U ,3):1,1:0)
  9279   "RTN","VPR DJ00",76,0 )
  9280    S X=AO_U_ IR_U_PGF_U _HNC_U_MST _U_CV
  9281   "RTN","VPR DJ00",77,0 )
  9282    F P=1:1:6  S I=$P(X, U,P),$P(X, U,P)=$S(I: "Yes",I=0: "No",1:"Un known")
  9283   "RTN","VPR DJ00",78,0 )
  9284    S NM="age nt-orange^ ionizing-r adiation^s w-asia^hea d-neck-can cer^mst^co mbat-vet"
  9285   "RTN","VPR DJ00",79,0 )
  9286    F P=1:1:6  S PAT("ex posures",P ,"uid")="u rn:va:"_$P (NM,U,P)_" :"_$E($P(X ,U,P)),PAT ("exposure s",P,"name ")=$P(X,U, P)
  9287   "RTN","VPR DJ00",80,0 )
  9288    ;
  9289   "RTN","VPR DJ00",81,0 )
  9290    ; rated d isabilitie s [DGRPDB]
  9291   "RTN","VPR DJ00",82,0 )
  9292    N VPRDIS, DIS,NM,DX
  9293   "RTN","VPR DJ00",83,0 )
  9294    D RDIS^DG RPDB(DFN,. VPRDIS)
  9295   "RTN","VPR DJ00",84,0 )
  9296    S I=0 F   S I=$O(VPR DIS(I)) Q: I<1  D
  9297   "RTN","VPR DJ00",85,0 )
  9298    . S DIS=V PRDIS(I)
  9299   "RTN","VPR DJ00",86,0 )
  9300    . S NM=$$ GET1^DIQ(3 1,+DIS_"," ,.01),DX=$ $GET1^DIQ( 31,+DIS_", ",2)
  9301   "RTN","VPR DJ00",87,0 )
  9302    . S PAT(" disabiliti es",+DX,"n ame")=NM
  9303   "RTN","VPR DJ00",88,0 )
  9304    . S PAT(" disabiliti es",+DX,"d isPercent" )=$P(DIS,U ,2)
  9305   "RTN","VPR DJ00",89,0 )
  9306    . S PAT(" disabiliti es",+DX,"s erviceConn ected")=$$ BOOL($P(DI S,U,3))
  9307   "RTN","VPR DJ00",90,0 )
  9308    Q
  9309   "RTN","VPR DJ00",91,0 )
  9310   PRF ;-pati ent record  flags
  9311   "RTN","VPR DJ00",92,0 )
  9312    N VPRPF,I ,NAME,TEXT
  9313   "RTN","VPR DJ00",93,0 )
  9314    Q:'$$GETA CT^DGPFAPI (DFN,"VPRP F")
  9315   "RTN","VPR DJ00",94,0 )
  9316    S I=0 F   S I=$O(VPR PF(I)) Q:I <1  D
  9317   "RTN","VPR DJ00",95,0 )
  9318    . S NAME= $P(VPRPF(I ,"FLAG"),U ,2)
  9319   "RTN","VPR DJ00",96,0 )
  9320    . M TEXT= VPRPF(I,"N ARR")
  9321   "RTN","VPR DJ00",97,0 )
  9322    . S PAT(" flags",I," name")=NAM E
  9323   "RTN","VPR DJ00",98,0 )
  9324    . S PAT(" flags",I," text")=$$S TRING^VPRD (.TEXT)
  9325   "RTN","VPR DJ00",99,0 )
  9326    Q
  9327   "RTN","VPR DJ00",100, 0)
  9328   ATC ;-addr ess & tele com
  9329   "RTN","VPR DJ00",101, 0)
  9330    N VAPA,I, X,P,NM
  9331   "RTN","VPR DJ00",102, 0)
  9332    S VAPA("P ")="" D AD D^VADPT ;p ermanent a ddress
  9333   "RTN","VPR DJ00",103, 0)
  9334    S:$L(VAPA (1)) PAT(" addresses" ,1,"street Line1")=VA PA(1)
  9335   "RTN","VPR DJ00",104, 0)
  9336    S X=VAPA( 2) I $L(X) ,$L(VAPA(3 )) S X=X_"  "_VAPA(3)
  9337   "RTN","VPR DJ00",105, 0)
  9338    S:$L(X) P AT("addres ses",1,"st reetLine2" )=X
  9339   "RTN","VPR DJ00",106, 0)
  9340    S:$L(VAPA (4)) PAT(" addresses" ,1,"city") =VAPA(4)
  9341   "RTN","VPR DJ00",107, 0)
  9342    S X=$P(VA PA(5),U,2)  S:$L(X) P AT("addres ses",1,"st ateProvinc e")=X
  9343   "RTN","VPR DJ00",108, 0)
  9344    S X=$P(VA PA(11),U,2 ) S:$L(X)  PAT("addre sses",1,"p ostalCode" )=X
  9345   "RTN","VPR DJ00",109, 0)
  9346    ; 
  9347   "RTN","VPR DJ00",110, 0)
  9348    ; X=home^ cell^work  phones
  9349   "RTN","VPR DJ00",111, 0)
  9350    S X=$$FOR MAT(VAPA(8 ))_U_$$FOR MAT($$GET1 ^DIQ(2,DFN _",",.134) )_U_$$FORM AT($$GET1^ DIQ(2,DFN_ ",",.132))
  9351   "RTN","VPR DJ00",112, 0)
  9352    S NM="H^M C^WP" F P= 1:1:3 I $L ($P(X,U,P) ) D
  9353   "RTN","VPR DJ00",113, 0)
  9354    . S I=$P( NM,U,P),PA T("telecom s",P,"usag eCode")=I
  9355   "RTN","VPR DJ00",114, 0)
  9356    . S PAT(" telecoms", P,"usageNa me")=$S(I= "WP":"work  place",I= "MC":"mobi le contact ",1:"home  address")
  9357   "RTN","VPR DJ00",115, 0)
  9358    . S PAT(" telecoms", P,"telecom ")=$P(X,U, P)
  9359   "RTN","VPR DJ00",116, 0)
  9360    Q
  9361   "RTN","VPR DJ00",117, 0)
  9362   SUPP ;-sup port conta cts
  9363   "RTN","VPR DJ00",118, 0)
  9364    N VAOA,A, I,X,TYPE,S
  9365   "RTN","VPR DJ00",119, 0)
  9366    S S=0 F A ="",1 K VA OA D
  9367   "RTN","VPR DJ00",120, 0)
  9368    . S:A VAO A("A")=A D  OAD^VADPT  Q:'$L($G( VAOA(9)))
  9369   "RTN","VPR DJ00",121, 0)
  9370    . S S=S+1 ,TYPE=$S(A =1:"ECON^E mergency C ontact",1: "NOK^Next  of Kin")
  9371   "RTN","VPR DJ00",122, 0)
  9372    . S PAT(" supports", S,"contact TypeCode") ="urn:va:p at-contact :"_$P(TYPE ,U)
  9373   "RTN","VPR DJ00",123, 0)
  9374    . S PAT(" supports", S,"contact TypeName") =$P(TYPE,U ,2)
  9375   "RTN","VPR DJ00",124, 0)
  9376    . S:$L(VA OA(9)) PAT ("supports ",S,"name" )=VAOA(9)
  9377   "RTN","VPR DJ00",125, 0)
  9378    . S:$L(VA OA(10)) PA T("support s",S,"rela tionship") =VAOA(10)
  9379   "RTN","VPR DJ00",126, 0)
  9380    . S:$L(VA OA(1)) PAT ("supports ",S,"addre sses",1,"s treetLine1 ")=VAOA(1)
  9381   "RTN","VPR DJ00",127, 0)
  9382    . S X=VAO A(2) I $L( X),$L(VAOA (3)) S X=X _" "_VAOA( 3)
  9383   "RTN","VPR DJ00",128, 0)
  9384    . S:$L(X)  PAT("supp orts",S,"a ddresses", 1,"streetL ine2")=X
  9385   "RTN","VPR DJ00",129, 0)
  9386    . S:$L(VA OA(4)) PAT ("supports ",S,"addre sses",1,"c ity")=VAOA (4)
  9387   "RTN","VPR DJ00",130, 0)
  9388    . S X=$P( VAOA(5),U, 2) S:$L(X)  PAT("supp orts",S,"a ddresses", 1,"statePr ovince")=X
  9389   "RTN","VPR DJ00",131, 0)
  9390    . S X=$P( VAOA(11),U ,2) S:$L(X ) PAT("sup ports",S," addresses" ,1,"postal Code")=X
  9391   "RTN","VPR DJ00",132, 0)
  9392    . S I=$S( A=1:.33011 ,1:.21011) ,X=$$FORMA T(VAOA(8)) _U_U_$$FOR MAT($$GET1 ^DIQ(2,DFN _",",I))
  9393   "RTN","VPR DJ00",133, 0)
  9394    . ; X=hom e^cell^wor k phones
  9395   "RTN","VPR DJ00",134, 0)
  9396    . S NM="H ^MC^WP" F  P=1:1:3 I  $L($P(X,U, P)) D
  9397   "RTN","VPR DJ00",135, 0)
  9398    .. S I=$P (NM,U,P),P AT("suppor ts",S,"tel ecomList", P,"usageCo de")=I
  9399   "RTN","VPR DJ00",136, 0)
  9400    .. S PAT( "supports" ,S,"teleco mList",P," usageName" )=$S(I="WP ":"work pl ace",I="MC ":"mobile  contact",1 :"home add ress")
  9401   "RTN","VPR DJ00",137, 0)
  9402    .. S PAT( "supports" ,S,"teleco mList",P," telecom")= $P(X,U,P)
  9403   "RTN","VPR DJ00",138, 0)
  9404    Q
  9405   "RTN","VPR DJ00",139, 0)
  9406   ALIAS ;-ot her names  used
  9407   "RTN","VPR DJ00",140, 0)
  9408    N I,X
  9409   "RTN","VPR DJ00",141, 0)
  9410    S I=0 F   S I=$O(^DP T(DFN,.01, I)) Q:I<1   S X=$G(^( I,0)) D
  9411   "RTN","VPR DJ00",142, 0)
  9412    . S PAT(" aliases",I ,"fullName ")=$P(X,U)
  9413   "RTN","VPR DJ00",143, 0)
  9414    Q
  9415   "RTN","VPR DJ00",144, 0)
  9416   FAC ;-trea ting facil ities [see  FACLIST^O RWCIRN]
  9417   "RTN","VPR DJ00",145, 0)
  9418    N IFN S D FN=+$G(DFN ) Q:DFN<1
  9419   "RTN","VPR DJ00",146, 0)
  9420    N VPRY,HO ME,LAST,I, X,IEN,VASI TE
  9421   "RTN","VPR DJ00",147, 0)
  9422    S X=$$ALL ^VASITE ;V ASITE(stn# )=stn# for  all local
  9423   "RTN","VPR DJ00",148, 0)
  9424    I $L($T(T FL^VAFCTFU 1)) D TFL^ VAFCTFU1(. VPRY,DFN)
  9425   "RTN","VPR DJ00",149, 0)
  9426    S HOME=+$ P($G(^DPT( DFN,"MPI") ),U,3) ;ho me facilit y
  9427   "RTN","VPR DJ00",150, 0)
  9428    I $P($G(V PRY(1)),U) <0 D  ;not  setup
  9429   "RTN","VPR DJ00",151, 0)
  9430    . S X=$O( ^AUPNVSIT( "AA",DFN,0 )),LAST=$S (X:9999999 -$P(X,".") ,1:"")
  9431   "RTN","VPR DJ00",152, 0)
  9432    . S X=$$S ITE^VASITE
  9433   "RTN","VPR DJ00",153, 0)
  9434    . S VPRY( 1)=$P(X,U, 3)_U_$P(X, U,2)_U_LAS T_U_$$GET1 ^DIQ(4,+X_ ",",60)
  9435   "RTN","VPR DJ00",154, 0)
  9436    S I=0 F   S I=$O(VPR Y(I)) Q:I< 1  D
  9437   "RTN","VPR DJ00",155, 0)
  9438    . S X=VPR Y(I) Q:$P( X,U)=""  ; unknown
  9439   "RTN","VPR DJ00",156, 0)
  9440    . S IEN=+ $$IEN^XUAF 4($P(X,U))
  9441   "RTN","VPR DJ00",157, 0)
  9442    . I +X=77 6!(+X=200)  S $P(X,U, 2)="DEPT.  OF DEFENSE "
  9443   "RTN","VPR DJ00",158, 0)
  9444    . S PAT(" facilities ",I,"code" )=$P(X,U)     ;stn#
  9445   "RTN","VPR DJ00",159, 0)
  9446    . S PAT(" facilities ",I,"name" )=$P(X,U,2 )  ;name
  9447   "RTN","VPR DJ00",160, 0)
  9448    . S:IEN=H OME PAT("f acilities" ,I,"homeSi te")="true "
  9449   "RTN","VPR DJ00",161, 0)
  9450    . S:$L($P (X,U,3)) P AT("facili ties",I,"l atestDate" )=$$JSONDT ^VPRUTILS( $P($P(X,U, 3),"."))
  9451   "RTN","VPR DJ00",162, 0)
  9452    . I $D(VA SITE(+X))  D
  9453   "RTN","VPR DJ00",163, 0)
  9454    .. S PAT( "facilitie s",I,"loca lPatientId ")=DFN
  9455   "RTN","VPR DJ00",164, 0)
  9456    .. S PAT( "facilitie s",I,"syst emId")=VPR SYS
  9457   "RTN","VPR DJ00",165, 0)
  9458    Q
  9459   "RTN","VPR DJ00",166, 0)
  9460   PC ;-prima ry care as signments
  9461   "RTN","VPR DJ00",167, 0)
  9462    N X S X=$ $OUTPTPR^S DUTL3(DFN)  I X D
  9463   "RTN","VPR DJ00",168, 0)
  9464    . S PAT(" pcProvider Uid")=$$SE TUID^VPRUT ILS("user" ,,+X)
  9465   "RTN","VPR DJ00",169, 0)
  9466    . S PAT(" pcProvider Name")=$P( X,U,2)
  9467   "RTN","VPR DJ00",170, 0)
  9468    S X=$$OUT PTTM^SDUTL 3(DFN) I X  D
  9469   "RTN","VPR DJ00",171, 0)
  9470    . S PAT(" pcTeamUid" )=$$SETUID ^VPRUTILS( "team",,+X )
  9471   "RTN","VPR DJ00",172, 0)
  9472    . S PAT(" pcTeamName ")=$$GET1^ DIQ(404.51 ,+X_",",.0 1)
  9473   "RTN","VPR DJ00",173, 0)
  9474    Q
  9475   "RTN","VPR DJ00",174, 0)
  9476    ;
  9477   "RTN","VPR DJ00",175, 0)
  9478   FORMAT(X)  ; -- enfor ce (xxx)xx x-xxxx pho ne format
  9479   "RTN","VPR DJ00",176, 0)
  9480    S X=$G(X)  I X?1"("3 N1")"3N1"- "4N.E Q X
  9481   "RTN","VPR DJ00",177, 0)
  9482    N P,N,I,Y  S P=""
  9483   "RTN","VPR DJ00",178, 0)
  9484    F I=1:1:$ L(X) S N=$ E(X,I) I N =+N S P=P_ N
  9485   "RTN","VPR DJ00",179, 0)
  9486    S:$L(P)<1 0 P=$E("00 00000000", 1,10-$L(P) )_P
  9487   "RTN","VPR DJ00",180, 0)
  9488    S Y=$S(P: "("_$E(P,1 ,3)_")"_$E (P,4,6)_"- "_$E(P,7,1 0),1:"")
  9489   "RTN","VPR DJ00",181, 0)
  9490    Q Y
  9491   "RTN","VPR DJ00",182, 0)
  9492    ;
  9493   "RTN","VPR DJ00",183, 0)
  9494   NAME(CODE, SET) ; --  Return exp anded name  for code  set
  9495   "RTN","VPR DJ00",184, 0)
  9496    N Y S Y=" ",CODE=$G( CODE)
  9497   "RTN","VPR DJ00",185, 0)
  9498    I $G(SET) ="gender"  S Y=$S(COD E="F":"Fem ale",CODE= "M":"Male" ,1:"Unknow n")
  9499   "RTN","VPR DJ00",186, 0)
  9500    I $G(SET) ="maritalS tatus" S Y =$S(CODE=" D":"Divorc ed",CODE=" M":"Marrie d",CODE="W ":"Widowed ",CODE="L" :"Legally  Separated" ,CODE="S": "Never Mar ried",1:"U nknown")
  9501   "RTN","VPR DJ00",187, 0)
  9502    I $G(SET) ="religion " S Y=$$GE T1^DIQ(13, CODE_",",. 01)
  9503   "RTN","VPR DJ00",188, 0)
  9504    Q Y
  9505   "RTN","VPR DJ00",189, 0)
  9506    ;
  9507   "RTN","VPR DJ00",190, 0)
  9508   BOOL(X) ;
  9509   "RTN","VPR DJ00",191, 0)
  9510    Q $S(X>0: "true",1:" false")
  9511   "RTN","VPR DJ01")
  9512   0^71^B4120 9021
  9513   "RTN","VPR DJ01",1,0)
  9514   VPRDJ01 ;S LC/MKB --  Orders ;6/ 25/12  16: 11
  9515   "RTN","VPR DJ01",2,0)
  9516    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  9517   "RTN","VPR DJ01",3,0)
  9518    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  9519   "RTN","VPR DJ01",4,0)
  9520    ;
  9521   "RTN","VPR DJ01",5,0)
  9522    ; Externa l Referenc es           DBIA#
  9523   "RTN","VPR DJ01",6,0)
  9524    ; ------- ---------- --           -----
  9525   "RTN","VPR DJ01",7,0)
  9526    ; ^DPT                            10035
  9527   "RTN","VPR DJ01",8,0)
  9528    ; ^OR(100                          5771
  9529   "RTN","VPR DJ01",9,0)
  9530    ; ^ORA(10 2.4                      5769
  9531   "RTN","VPR DJ01",10,0 )
  9532    ; ^ORD(10 0.98                      873
  9533   "RTN","VPR DJ01",11,0 )
  9534    ; ^PXRMIN DX                       4290
  9535   "RTN","VPR DJ01",12,0 )
  9536    ; ^RADPT                           2480
  9537   "RTN","VPR DJ01",13,0 )
  9538    ; ^SC                             10040
  9539   "RTN","VPR DJ01",14,0 )
  9540    ; ^VA(200                         10060
  9541   "RTN","VPR DJ01",15,0 )
  9542    ; DIC                              2051
  9543   "RTN","VPR DJ01",16,0 )
  9544    ; DIQ                              2056
  9545   "RTN","VPR DJ01",17,0 )
  9546    ; GMRCGUI B                        2980
  9547   "RTN","VPR DJ01",18,0 )
  9548    ; LR7OU1                           2955
  9549   "RTN","VPR DJ01",19,0 )
  9550    ; ORQ1,^T MP("ORR"                 3154
  9551   "RTN","VPR DJ01",20,0 )
  9552    ; ORQ12,^ TMP("ORR"                5704
  9553   "RTN","VPR DJ01",21,0 )
  9554    ; ORX8                             2467
  9555   "RTN","VPR DJ01",22,0 )
  9556    ; PSS51P1                          4546
  9557   "RTN","VPR DJ01",23,0 )
  9558    ;
  9559   "RTN","VPR DJ01",24,0 )
  9560    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  9561   "RTN","VPR DJ01",25,0 )
  9562    ;
  9563   "RTN","VPR DJ01",26,0 )
  9564   OR1(ID) ;  -- order I D >> ^TMP( "ORR",$J,O RLIST,VPRN )
  9565   "RTN","VPR DJ01",27,0 )
  9566    N ORDER,C HILD,VPRC
  9567   "RTN","VPR DJ01",28,0 )
  9568    D ORX(ID, .ORDER)
  9569   "RTN","VPR DJ01",29,0 )
  9570    S VPRC=0  F  S VPRC= $O(^OR(100 ,ID,2,VPRC )) Q:VPRC< 1  D
  9571   "RTN","VPR DJ01",30,0 )
  9572    . K CHILD  D ORX(VPR C,.CHILD)
  9573   "RTN","VPR DJ01",31,0 )
  9574    . M ORDER ("children ",VPRC)=CH ILD
  9575   "RTN","VPR DJ01",32,0 )
  9576    D ADD^VPR DJ("ORDER" ,"order")
  9577   "RTN","VPR DJ01",33,0 )
  9578    Q
  9579   "RTN","VPR DJ01",34,0 )
  9580   ORX(IFN,OR D) ; -- ex tract orde r IFN into  ORD("attr ibute")
  9581   "RTN","VPR DJ01",35,0 )
  9582    N ORLIST, ORLST,X0,X 8,LOC,X,I, DA
  9583   "RTN","VPR DJ01",36,0 )
  9584    S ORLST=$ S(+$G(VPRN ):VPRN-1,1 :0) S:'$D( ORLIST) OR LIST=$H
  9585   "RTN","VPR DJ01",37,0 )
  9586    D GET^ORQ 12(IFN,ORL IST,1)
  9587   "RTN","VPR DJ01",38,0 )
  9588    S X0=$G(^ TMP("ORR", $J,ORLIST, ORLST))
  9589   "RTN","VPR DJ01",39,0 )
  9590    N $ES,$ET ,ERRPAT,ER RMSG
  9591   "RTN","VPR DJ01",40,0 )
  9592    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  9593   "RTN","VPR DJ01",41,0 )
  9594    S ERRMSG= "A problem  occurred  converting  record "_ IFN_" for  the orders  domain"
  9595   "RTN","VPR DJ01",42,0 )
  9596    ;
  9597   "RTN","VPR DJ01",43,0 )
  9598    S ORD("lo calId")=IF N,ORD("uid ")=$$SETUI D^VPRUTILS ("order",D FN,IFN)
  9599   "RTN","VPR DJ01",44,0 )
  9600    S X=$$OI^ ORX8(+X0)  I $L(X) D
  9601   "RTN","VPR DJ01",45,0 )
  9602    . N ARRAY ,NAME
  9603   "RTN","VPR DJ01",46,0 )
  9604    . S ARRAY ("Code")=1 _U_"oi",AR RAY("Name" )=2,ARRAY( "PackageRe f")=3
  9605   "RTN","VPR DJ01",47,0 )
  9606    . D SPLIT VAL^VPRUTI LS(X,.ARRA Y) S ORD(" name")=ARR AY("Name")
  9607   "RTN","VPR DJ01",48,0 )
  9608    . S NAME= "" F  S NA ME=$O(ARRA Y(NAME)) Q :NAME=""   S ORD("oi" _NAME)=$G( ARRAY(NAME ))
  9609   "RTN","VPR DJ01",49,0 )
  9610    S ORD("di splayGroup ")=$P(X0,U ,2)
  9611   "RTN","VPR DJ01",50,0 )
  9612    S ORD("en tered")=$$ JSONDT^VPR UTILS($P(X 0,U,3))
  9613   "RTN","VPR DJ01",51,0 )
  9614    S ORD("st art")=$$TM ($P(X0,U,4 )),ORD("st op")=$$TM( $P(X0,U,5) )
  9615   "RTN","VPR DJ01",52,0 )
  9616    S ORD("st atusCode") ="urn:va:o rder-statu s:"_$P(X0, U,7)
  9617   "RTN","VPR DJ01",53,0 )
  9618    S ORD("st atusName") =$P(X0,U,6 )
  9619   "RTN","VPR DJ01",54,0 )
  9620    S ORD("st atusVuid") ="urn:va:v uid:"_$$ST S^VPRDOR($ P(X0,U,7))
  9621   "RTN","VPR DJ01",55,0 )
  9622    D SETTEXT ^VPRUTILS( $NA(^TMP(" ORR",$J,OR LIST,ORLST ,"TX")),$N A(^TMP("VP RTEXT",$J, IFN)))
  9623   "RTN","VPR DJ01",56,0 )
  9624    M ORD("co ntent","\" )=^TMP("VP RTEXT",$J, IFN)
  9625   "RTN","VPR DJ01",57,0 )
  9626    S X=$$GET 1^DIQ(100, IFN_",",1, "I") I X D
  9627   "RTN","VPR DJ01",58,0 )
  9628    . S ORD(" providerUi d")=$$SETU ID^VPRUTIL S("user",, +X)
  9629   "RTN","VPR DJ01",59,0 )
  9630    . S ORD(" providerNa me")=$P($G (^VA(200,+ X,0)),U)
  9631   "RTN","VPR DJ01",60,0 )
  9632    S LOC=+$$ GET1^DIQ(1 00,IFN_"," ,6,"I"),FA C=$$FAC^VP RD(LOC) I  LOC D
  9633   "RTN","VPR DJ01",61,0 )
  9634    . S ORD(" locationNa me")=$P($G (^SC(LOC,0 )),U)
  9635   "RTN","VPR DJ01",62,0 )
  9636    . S ORD(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,LOC)
  9637   "RTN","VPR DJ01",63,0 )
  9638    D FACILIT Y^VPRUTILS (FAC,"ORD" )
  9639   "RTN","VPR DJ01",64,0 )
  9640    S ORD("se rvice")=$$ GET1^DIQ(1 00,IFN_"," ,"12:1")
  9641   "RTN","VPR DJ01",65,0 )
  9642    S X=$$GET 1^DIQ(100, IFN_",",9, "I") S:X O RD("predec essor")=$$ SETUID^VPR UTILS("ord er",DFN,+X )
  9643   "RTN","VPR DJ01",66,0 )
  9644    S X=$$GET 1^DIQ(100, IFN_",",9. 1,"I") S:X  ORD("succ essor")=$$ SETUID^VPR UTILS("ord er",DFN,+X )
  9645   "RTN","VPR DJ01",67,0 )
  9646    D RESULTS
  9647   "RTN","VPR DJ01",68,0 )
  9648    ; sign/ve rify
  9649   "RTN","VPR DJ01",69,0 )
  9650    S X8=$G(^ OR(100,IFN ,8,1,0)),I =0 I $P(X8 ,U,6) D        ;signe d
  9651   "RTN","VPR DJ01",70,0 )
  9652    . N PROV  S PROV=$P( X8,U,5) S: PROV<1 PRO V=$P(X8,U, 3)  ;if on  chart,
  9653   "RTN","VPR DJ01",71,0 )
  9654    . D USER( .I,"S",PRO V,$P(X8,U, 6))                       ;   us e provider
  9655   "RTN","VPR DJ01",72,0 )
  9656    I $P(X8,U ,9)  D USE R(.I,"N",$ P(X8,U,8), $P(X8,U,9) )   ;nurse
  9657   "RTN","VPR DJ01",73,0 )
  9658    I $P(X8,U ,11) D USE R(.I,"C",$ P(X8,U,10) ,$P(X8,U,1 1)) ;clerk
  9659   "RTN","VPR DJ01",74,0 )
  9660    I $P(X8,U ,19) D USE R(.I,"R",$ P(X8,U,18) ,$P(X8,U,1 9)) ;chart  review
  9661   "RTN","VPR DJ01",75,0 )
  9662    Q
  9663   "RTN","VPR DJ01",76,0 )
  9664    ; acknowl edgements
  9665   "RTN","VPR DJ01",77,0 )
  9666    S DA=0 F   S DA=$O(^ ORA(102.4, "B",+IFN,D A)) Q:DA<1   D
  9667   "RTN","VPR DJ01",78,0 )
  9668    . S X0=$G (^ORA(102. 4,DA,0)) Q :'$P(X0,U, 3)  ;stub  - not ack' d
  9669   "RTN","VPR DJ01",79,0 )
  9670    . S X=+$P (X0,U,2),X =$S(X:X_U_ $P($G(^VA( 200,X,0)), U),1:U)
  9671   "RTN","VPR DJ01",80,0 )
  9672    . S ORD(" acknowledg ement",DA) =X_U_$P(X0 ,U,3)
  9673   "RTN","VPR DJ01",81,0 )
  9674    Q
  9675   "RTN","VPR DJ01",82,0 )
  9676    ;
  9677   "RTN","VPR DJ01",83,0 )
  9678   RESULTS ;  -- add ORD ("results" ,n,"uid")  list
  9679   "RTN","VPR DJ01",84,0 )
  9680    N ORPK,OR PKG,ORDG
  9681   "RTN","VPR DJ01",85,0 )
  9682    S ORPK=$G (^OR(100,I FN,4)),ORP KG=ORD("se rvice"),OR DG=ORD("di splayGroup ")
  9683   "RTN","VPR DJ01",86,0 )
  9684    I ORPKG=" GMRC" D  Q
  9685   "RTN","VPR DJ01",87,0 )
  9686    . N VPRD, I,N,X D DO CLIST^GMRC GUIB(.VPRD ,+ORPK)
  9687   "RTN","VPR DJ01",88,0 )
  9688    . S N=1,O RD("result s",N,"uid" )=$$SETUID ^VPRUTILS( "consult", DFN,+ORPK)
  9689   "RTN","VPR DJ01",89,0 )
  9690    . S I=0 F   S I=$O(V PRD(50,I))  Q:I<1  S  X=$G(VPRD( 50,I)) D
  9691   "RTN","VPR DJ01",90,0 )
  9692    .. Q:'$D( @(U_$P(X," ;",2)_+X_" )"))  ;tex t deleted
  9693   "RTN","VPR DJ01",91,0 )
  9694    .. S N=N+ 1,ORD("res ults",N,"u id")=$$SET UID^VPRUTI LS("docume nt",DFN,+X )
  9695   "RTN","VPR DJ01",92,0 )
  9696    . Q:ORDG' ="PROC"
  9697   "RTN","VPR DJ01",93,0 )
  9698    . N VPRC  D FIND^DIC (702,,"@", "Q",+ORPK, ,"ACON",,, "VPRC") ;C P
  9699   "RTN","VPR DJ01",94,0 )
  9700    . S I=0 F   S I=$O(V PRC("DILIS T",2,I)) Q :I<1  D
  9701   "RTN","VPR DJ01",95,0 )
  9702    .. S X=+$ G(VPRC("DI LIST",2,I) )_";MDD(70 2,"
  9703   "RTN","VPR DJ01",96,0 )
  9704    .. S N=N+ 1,ORD("res ults",N,"u id")=$$SET UID^VPRUTI LS("proced ure",DFN,X )
  9705   "RTN","VPR DJ01",97,0 )
  9706    I ORPKG=" LR" D  Q
  9707   "RTN","VPR DJ01",98,0 )
  9708    . Q:$L(OR PK,";")'>3   ;no resu lts yet, o r parent o rder
  9709   "RTN","VPR DJ01",99,0 )
  9710    . N SUB,I DT,CDT,ITM ,VPRT,ID,T ,N,LRDFN,I DX
  9711   "RTN","VPR DJ01",100, 0)
  9712    . S SUB=$ P(ORPK,";" ,4),IDT=$P (ORPK,";", 5),CDT=999 9999-IDT
  9713   "RTN","VPR DJ01",101, 0)
  9714    . I SUB=" CH" D  Q
  9715   "RTN","VPR DJ01",102, 0)
  9716    .. S ITM= +$G(ORD("o iPackageRe f")) D EXP AND^LR7OU1 (ITM,.VPRT )
  9717   "RTN","VPR DJ01",103, 0)
  9718    .. S (T,N )=0 F  S T =$O(VPRT(T )) Q:T<1   S ID=$O(^P XRMINDX(63 ,"PI",DFN, T,CDT,""))  I $L(ID)  S N=N+1,OR D("results ",N,"uid") =$$SETUID^ VPRUTILS(" lab",DFN,$ P(ID,";",2 ,9))
  9719   "RTN","VPR DJ01",104, 0)
  9720    . I SUB=" MI" D  Q
  9721   "RTN","VPR DJ01",105, 0)
  9722    .. S ITM= "M;A;",N=0 ,LRDFN=$G( ^DPT(DFN," LR"))
  9723   "RTN","VPR DJ01",106, 0)
  9724    .. F  S I TM=$O(^PXR MINDX(63," PI",DFN,IT M)) Q:$E(I TM,1,4)'=" M;A;"  I $ D(^(ITM,CD T)) D
  9725   "RTN","VPR DJ01",107, 0)
  9726    ... S IDX =LRDFN_";M I;"_IDT
  9727   "RTN","VPR DJ01",108, 0)
  9728    ... F  S  IDX=$O(^PX RMINDX(63, "PI",DFN,I TM,CDT,IDX )) Q:IDX=" "  S ID=$P (IDX,";",2 ,99),N=N+1 ,ORD("resu lts",N,"ui d")=$$SETU ID^VPRUTIL S("lab",DF N,ID)
  9729   "RTN","VPR DJ01",109, 0)
  9730    .. S N=N+ 1,ORD("res ults",N,"u id")=$$SET UID^VPRUTI LS("docume nt",DFN,SU B_";"_IDT)
  9731   "RTN","VPR DJ01",110, 0)
  9732    . ; SUB:" AP" [AU,CY ,EM,SP]
  9733   "RTN","VPR DJ01",111, 0)
  9734    . S ORD(" results",1 ,"uid")=$$ SETUID^VPR UTILS("lab ",DFN,SUB_ ";"_IDT)
  9735   "RTN","VPR DJ01",112, 0)
  9736    . S ORD(" results",2 ,"uid")=$$ SETUID^VPR UTILS("doc ument",DFN ,SUB_";"_I DT)
  9737   "RTN","VPR DJ01",113, 0)
  9738    I ORPKG[" PS" D  Q
  9739   "RTN","VPR DJ01",114, 0)
  9740    . S:ORPK  ORD("resul ts",1,"uid ")=$$SETUI D^VPRUTILS ("med",DFN ,IFN)
  9741   "RTN","VPR DJ01",115, 0)
  9742    I ORPKG=" RA" D  Q
  9743   "RTN","VPR DJ01",116, 0)
  9744    . N IDT,C N S IDT=+$ O(^RADPT(" AO",+ORPK, DFN,0)) Q: 'IDT
  9745   "RTN","VPR DJ01",117, 0)
  9746    . S CN=0  F  S CN=$O (^RADPT("A O",+ORPK,D FN,IDT,CN) ) Q:CN<1   S ORD("res ults",CN," uid")=$$SE TUID^VPRUT ILS("image ",DFN,IDT_ "-"_CN)
  9747   "RTN","VPR DJ01",118, 0)
  9748    ; rest sh ould be ge neric (OR)  orders
  9749   "RTN","VPR DJ01",119, 0)
  9750    I ORDG="N TX" S ORD( "results", 1,"uid")=$ $SETUID^VP RUTILS("tr eatment",D FN,IFN) Q
  9751   "RTN","VPR DJ01",120, 0)
  9752    I ORDG="V /M" Q  ;no  link
  9753   "RTN","VPR DJ01",121, 0)
  9754    Q
  9755   "RTN","VPR DJ01",122, 0)
  9756    ;
  9757   "RTN","VPR DJ01",123, 0)
  9758   NTX1(IFN)  ; -- extra ct nursing  treatment  order IFN  into NTX( "attribute ")
  9759   "RTN","VPR DJ01",124, 0)
  9760    N NTX,X
  9761   "RTN","VPR DJ01",125, 0)
  9762    D ORX(IFN ,.NTX) ;ge t basic or der info
  9763   "RTN","VPR DJ01",126, 0)
  9764    S NTX("or derUid")=N TX("uid")
  9765   "RTN","VPR DJ01",127, 0)
  9766    S NTX("ui d")=$$SETU ID^VPRUTIL S("treatme nt",DFN,IF N)
  9767   "RTN","VPR DJ01",128, 0)
  9768    S X=$$VAL UE^ORX8(IF N,"COMMENT ") S:$L(X)  NTX("inst ructions") =X
  9769   "RTN","VPR DJ01",129, 0)
  9770    S X=$$VAL UE^ORX8(IF N,"SCHEDUL E") I X D
  9771   "RTN","VPR DJ01",130, 0)
  9772    . D ZERO^ PSS51P1(X, ,,,"VPRS")
  9773   "RTN","VPR DJ01",131, 0)
  9774    . S NTX(" scheduleNa me")=$G(^T MP($J,"VPR S",X,.01))
  9775   "RTN","VPR DJ01",132, 0)
  9776    . S NTX(" adminTimes ")=$G(^TMP ($J,"VPRS" ,X,1))
  9777   "RTN","VPR DJ01",133, 0)
  9778    . K ^TMP( $J,"VPRS")
  9779   "RTN","VPR DJ01",134, 0)
  9780    D ADD^VPR DJ("NTX"," treatment" )
  9781   "RTN","VPR DJ01",135, 0)
  9782    Q
  9783   "RTN","VPR DJ01",136, 0)
  9784    ;
  9785   "RTN","VPR DJ01",137, 0)
  9786   USER(N,ROL E,IEN,DATE ) ; -- add  signature /verificat ion data
  9787   "RTN","VPR DJ01",138, 0)
  9788    S N=+$G(N )+1
  9789   "RTN","VPR DJ01",139, 0)
  9790    S ORD("cl inicians", N,"signedD ateTime")= $$JSONDT^V PRUTILS(DA TE)
  9791   "RTN","VPR DJ01",140, 0)
  9792    S ORD("cl inicians", N,"role")= $G(ROLE)
  9793   "RTN","VPR DJ01",141, 0)
  9794    Q:+$G(IEN )<1
  9795   "RTN","VPR DJ01",142, 0)
  9796    S ORD("cl inicians", N,"uid")=$ $SETUID^VP RUTILS("us er",,IEN)
  9797   "RTN","VPR DJ01",143, 0)
  9798    S ORD("cl inicians", N,"name")= $P($G(^VA( 200,IEN,0) ),U)
  9799   "RTN","VPR DJ01",144, 0)
  9800    Q
  9801   "RTN","VPR DJ01",145, 0)
  9802    ;
  9803   "RTN","VPR DJ01",146, 0)
  9804   TM(X) ; --  strip sec onds off a  FM time
  9805   "RTN","VPR DJ01",147, 0)
  9806    N D,T,Y S  D=$P(X,". "),T=$P(X, ".",2)
  9807   "RTN","VPR DJ01",148, 0)
  9808    S Y=D_$S( T:"."_$E(T ,1,4),1:"" )
  9809   "RTN","VPR DJ01",149, 0)
  9810    S Y=$$JSO NDT^VPRUTI LS(Y)
  9811   "RTN","VPR DJ01",150, 0)
  9812    Q Y
  9813   "RTN","VPR DJ02")
  9814   0^72^B6315 4209
  9815   "RTN","VPR DJ02",1,0)
  9816   VPRDJ02 ;S LC/MKB --  Problems,A llergies,V itals ;6/2 5/12  16:1 1
  9817   "RTN","VPR DJ02",2,0)
  9818    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  9819   "RTN","VPR DJ02",3,0)
  9820    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  9821   "RTN","VPR DJ02",4,0)
  9822    ;
  9823   "RTN","VPR DJ02",5,0)
  9824    ; Externa l Referenc es           DBIA#
  9825   "RTN","VPR DJ02",6,0)
  9826    ; ------- ---------- --           -----
  9827   "RTN","VPR DJ02",7,0)
  9828    ; ^PXRMIN DX                       4290
  9829   "RTN","VPR DJ02",8,0)
  9830    ; ^SC                             10040
  9831   "RTN","VPR DJ02",9,0)
  9832    ; DIC                              2051
  9833   "RTN","VPR DJ02",10,0 )
  9834    ; DIQ                              2056
  9835   "RTN","VPR DJ02",11,0 )
  9836    ; GMPLUTL 2                        2741
  9837   "RTN","VPR DJ02",12,0 )
  9838    ; GMRADPT                         10099
  9839   "RTN","VPR DJ02",13,0 )
  9840    ; GMRAOR2                          2422
  9841   "RTN","VPR DJ02",14,0 )
  9842    ; GMRVUT0 ,^UTILITY( $J            1446
  9843   "RTN","VPR DJ02",15,0 )
  9844    ; GMVGETQ L                        5048
  9845   "RTN","VPR DJ02",16,0 )
  9846    ; GMVGETV T                        5047
  9847   "RTN","VPR DJ02",17,0 )
  9848    ; GMVUTL                           5046
  9849   "RTN","VPR DJ02",18,0 )
  9850    ; ICDCODE                          3990
  9851   "RTN","VPR DJ02",19,0 )
  9852    ; XLFSTR                          10104
  9853   "RTN","VPR DJ02",20,0 )
  9854    ; XUAF4                            2171
  9855   "RTN","VPR DJ02",21,0 )
  9856    ;
  9857   "RTN","VPR DJ02",22,0 )
  9858    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  9859   "RTN","VPR DJ02",23,0 )
  9860    ;
  9861   "RTN","VPR DJ02",24,0 )
  9862   GMPL1(ID)  ; -- probl em
  9863   "RTN","VPR DJ02",25,0 )
  9864    N VPRL,PR OB,X,I,DAT E,USER,FAC
  9865   "RTN","VPR DJ02",26,0 )
  9866    D DETAIL^ GMPLUTL2(I D,.VPRL) Q :'$D(VPRL)   ;doesn't  exist
  9867   "RTN","VPR DJ02",27,0 )
  9868    N $ES,$ET ,ERRPAT,ER RMSG
  9869   "RTN","VPR DJ02",28,0 )
  9870    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  9871   "RTN","VPR DJ02",29,0 )
  9872    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he problem  domain"
  9873   "RTN","VPR DJ02",30,0 )
  9874    ;
  9875   "RTN","VPR DJ02",31,0 )
  9876    S PROB("u id")=$$SET UID^VPRUTI LS("proble m",DFN,ID) ,PROB("loc alId")=ID
  9877   "RTN","VPR DJ02",32,0 )
  9878    S PROB("p roblemText ")=$G(VPRL ("NARRATIV E"))
  9879   "RTN","VPR DJ02",33,0 )
  9880    S DATE=$P ($G(VPRL(" ENTERED")) ,U)
  9881   "RTN","VPR DJ02",34,0 )
  9882    S:$L(DATE ) DATE=$$D ATE^VPRDGM PL(DATE),P ROB("enter ed")=$$JSO NDT^VPRUTI LS(DATE)
  9883   "RTN","VPR DJ02",35,0 )
  9884    S X=$G(VP RL("DIAGNO SIS")) I $ L(X) D
  9885   "RTN","VPR DJ02",36,0 )
  9886    . N ICD9Z N,DIAG
  9887   "RTN","VPR DJ02",37,0 )
  9888    . I DATE' >0 S DATE= DT
  9889   "RTN","VPR DJ02",38,0 )
  9890    . S ICD9Z N=$$ICDDX^ ICDCODE(X, DATE),DIAG =$S($P($G( ICD9ZN),U, 4)'="":$P( ICD9ZN,U,4 ),1:X)
  9891   "RTN","VPR DJ02",39,0 )
  9892    . S PROB( "icdCode") =$$SETNCS^ VPRUTILS(" icd",X),PR OB("icdNam e")=DIAG
  9893   "RTN","VPR DJ02",40,0 )
  9894    S X=$G(VP RL("ONSET" )) S:$L(X)  X=$$DATE^ VPRDGMPL(X ),PROB("on set")=$$JS ONDT^VPRUT ILS(X)
  9895   "RTN","VPR DJ02",41,0 )
  9896    S X=$G(VP RL("MODIFI ED")) S:$L (X) X=$$DA TE^VPRDGMP L(X),PROB( "updated") =$$JSONDT^ VPRUTILS(X )
  9897   "RTN","VPR DJ02",42,0 )
  9898    S X=$G(VP RL("STATUS ")) I $L(X ) D
  9899   "RTN","VPR DJ02",43,0 )
  9900    . S PROB( "statusNam e")=X,X=$E (X)
  9901   "RTN","VPR DJ02",44,0 )
  9902    . S X=$S( X="A":5556 1003,X="I" :73425007, 1:"")
  9903   "RTN","VPR DJ02",45,0 )
  9904    . S PROB( "statusCod e")=$$SETN CS^VPRUTIL S("sct",X)
  9905   "RTN","VPR DJ02",46,0 )
  9906    S X=$G(VP RL("PRIORI TY")) I X] "" D
  9907   "RTN","VPR DJ02",47,0 )
  9908    . S X=$$L OW^XLFSTR( X),PROB("a cuityName" )=X
  9909   "RTN","VPR DJ02",48,0 )
  9910    . S PROB( "acuityCod e")=$$SETV URN^VPRUTI LS("prob-a cuity",$E( X))
  9911   "RTN","VPR DJ02",49,0 )
  9912    S X=$$GET 1^DIQ(9000 011,ID_"," ,1.07,"I")  S:X PROB( "resolved" )=$$JSONDT ^VPRUTILS( X)
  9913   "RTN","VPR DJ02",50,0 )
  9914    S X=$$GET 1^DIQ(9000 011,ID_"," ,1.02,"I")
  9915   "RTN","VPR DJ02",51,0 )
  9916    S:X="P" P ROB("unver ified")="f alse",PROB ("removed" )="false"
  9917   "RTN","VPR DJ02",52,0 )
  9918    S:X="T" P ROB("unver ified")="t rue",PROB( "removed") ="false"
  9919   "RTN","VPR DJ02",53,0 )
  9920    S:X="H" P ROB("unver ified")="f alse",PROB ("removed" )="true"
  9921   "RTN","VPR DJ02",54,0 )
  9922    S X=$G(VP RL("SC")), X=$S(X="YE S":"",X="N O":"false" ,1:"")
  9923   "RTN","VPR DJ02",55,0 )
  9924    S:$L(X) P ROB("servi ceConnecte d")=X
  9925   "RTN","VPR DJ02",56,0 )
  9926    S X=$G(VP RL("PROVID ER")) I $L (X) D
  9927   "RTN","VPR DJ02",57,0 )
  9928    . S PROB( "providerN ame")=X,X= $$GET1^DIQ (9000011,I D_",",1.05 ,"I")
  9929   "RTN","VPR DJ02",58,0 )
  9930    . S PROB( "providerU id")=$$SET UID^VPRUTI LS("user", ,+X)
  9931   "RTN","VPR DJ02",59,0 )
  9932    S X=$$GET 1^DIQ(9000 011,ID_"," ,1.06) S:$ L(X) PROB( "service") =X
  9933   "RTN","VPR DJ02",60,0 )
  9934    S X=$G(VP RL("CLINIC ")) I $L(X ) D
  9935   "RTN","VPR DJ02",61,0 )
  9936    . S PROB( "locationN ame")=X
  9937   "RTN","VPR DJ02",62,0 )
  9938    . N LOC S  LOC=+$$FI ND1^DIC(44 ,,"QX",X)
  9939   "RTN","VPR DJ02",63,0 )
  9940    . S:LOC P ROB("locat ionUid")=$ $SETUID^VP RUTILS("lo cation",,L OC)
  9941   "RTN","VPR DJ02",64,0 )
  9942    S X=+$$GE T1^DIQ(900 0011,ID_", ",.06,"I")
  9943   "RTN","VPR DJ02",65,0 )
  9944    S:X FAC=$ $STA^XUAF4 (X)_U_$P($ $NS^XUAF4( X),U)
  9945   "RTN","VPR DJ02",66,0 )
  9946    I 'X S FA C=$$FAC^VP RD ;local  stn#^name
  9947   "RTN","VPR DJ02",67,0 )
  9948    D FACILIT Y^VPRUTILS (FAC,"PROB ")
  9949   "RTN","VPR DJ02",68,0 )
  9950    S I=0 F   S I=$O(VPR L("COMMENT ",I)) Q:I< 1  D
  9951   "RTN","VPR DJ02",69,0 )
  9952    . S X=$G( VPRL("COMM ENT",I))
  9953   "RTN","VPR DJ02",70,0 )
  9954    . S USER= $$VA200^VP RDGMPL($P( X,U,2)),DA TE=$$DATE^ VPRDGMPL($ P(X,U))
  9955   "RTN","VPR DJ02",71,0 )
  9956    . S PROB( "comments" ,I,"entere dByCode")= $$SETUID^V PRUTILS("u ser",,+USE R)
  9957   "RTN","VPR DJ02",72,0 )
  9958    . S PROB( "comments" ,I,"entere dByName")= $P(X,U,2)
  9959   "RTN","VPR DJ02",73,0 )
  9960    . S PROB( "comments" ,I,"entere d")=$$JSON DT^VPRUTIL S(DATE)
  9961   "RTN","VPR DJ02",74,0 )
  9962    . S PROB( "comments" ,I,"commen t")=$P(X,U ,3)
  9963   "RTN","VPR DJ02",75,0 )
  9964    D ADD^VPR DJ("PROB", "problem")
  9965   "RTN","VPR DJ02",76,0 )
  9966    Q
  9967   "RTN","VPR DJ02",77,0 )
  9968    ;
  9969   "RTN","VPR DJ02",78,0 )
  9970   GMRA1(ID)  ; -- aller gy/reactio n GMRAL(ID )
  9971   "RTN","VPR DJ02",79,0 )
  9972    N GMRA,VP RY,REAC,X, Y,I,USER,C MMT
  9973   "RTN","VPR DJ02",80,0 )
  9974    S GMRA=$G (GMRAL(ID) ) D EN1^GM RAOR2(ID," VPRY")
  9975   "RTN","VPR DJ02",81,0 )
  9976    N $ES,$ET ,ERRPAT,ER RMSG
  9977   "RTN","VPR DJ02",82,0 )
  9978    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  9979   "RTN","VPR DJ02",83,0 )
  9980    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he allergy  domain"
  9981   "RTN","VPR DJ02",84,0 )
  9982    ;
  9983   "RTN","VPR DJ02",85,0 )
  9984    S X=$P(VP RY,U,10) I  $L(X) S X =$$DATE^VP RDGMRA(X)  Q:X<VPRSTA RT  Q:X>VP RSTOP  S R EAC("enter ed")=$$JSO NDT^VPRUTI LS(X)
  9985   "RTN","VPR DJ02",86,0 )
  9986    S X=$$FAC ^VPRD D FA CILITY^VPR UTILS(X,"R EAC")
  9987   "RTN","VPR DJ02",87,0 )
  9988    S REAC("k ind")="All ergy / Adv erse React ion"
  9989   "RTN","VPR DJ02",88,0 )
  9990    S REAC("l ocalId")=I D,REAC("ui d")=$$SETU ID^VPRUTIL S("allergy ",DFN,ID)
  9991   "RTN","VPR DJ02",89,0 )
  9992    S (REAC(" summary"), REAC("prod ucts",1,"n ame"))=$P( VPRY,U) I  $P(GMRA,U, 9) D
  9993   "RTN","VPR DJ02",90,0 )
  9994    . S X=$P( GMRA,U,9), REAC("refe rence")=X
  9995   "RTN","VPR DJ02",91,0 )
  9996    . S Y=+$P (X,"(",2)  I 'Y,X["PS DRUG" S Y= 50
  9997   "RTN","VPR DJ02",92,0 )
  9998    . S I=$$V UID^VPRD(+ X,Y),REAC( "products" ,1,"vuid") =$$SETVURN ^VPRUTILS( "vuid",I)
  9999   "RTN","VPR DJ02",93,0 )
  10000    S X=$P(VP RY,U,2) S: $L(X) REAC ("originat orName")=X
  10001   "RTN","VPR DJ02",94,0 )
  10002    S REAC("h istorical" )=$S($E($P (VPRY,U,5) )="H":"tru e",1:"fals e")
  10003   "RTN","VPR DJ02",95,0 )
  10004    S X=$P(VP RY,U,6) S: $L(X) REAC ("mechanis m")=X
  10005   "RTN","VPR DJ02",96,0 )
  10006    S X=$P(VP RY,U,7) S: $L(X) REAC ("typeName ")=X
  10007   "RTN","VPR DJ02",97,0 )
  10008    ; REAC("a dverseEven tTypeName" )=$P(VPRY, U,7)_" "_$ P(VPRY,U,6 ) ;TYPE_ME CH
  10009   "RTN","VPR DJ02",98,0 )
  10010    I $P(VPRY ,U,4)="VER IFIED",$P( VPRY,U,9)  D
  10011   "RTN","VPR DJ02",99,0 )
  10012    . S REAC( "verified" )=$$JSONDT ^VPRUTILS( $P(VPRY,U, 9))
  10013   "RTN","VPR DJ02",100, 0)
  10014    . S REAC( "verifierN ame")=$P(V PRY,U,8)
  10015   "RTN","VPR DJ02",101, 0)
  10016    ; severit y
  10017   "RTN","VPR DJ02",102, 0)
  10018    S I=0 F   S I=$O(VPR Y("O",I))  Q:I<1  D
  10019   "RTN","VPR DJ02",103, 0)
  10020    . S X=$G( VPRY("O",I ))
  10021   "RTN","VPR DJ02",104, 0)
  10022    . S REAC( "observati ons",I,"da te")=$$JSO NDT^VPRUTI LS(+X)
  10023   "RTN","VPR DJ02",105, 0)
  10024    . S REAC( "observati ons",I,"se verity")=$ P(X,U,2)
  10025   "RTN","VPR DJ02",106, 0)
  10026    ; reactio ns
  10027   "RTN","VPR DJ02",107, 0)
  10028    S I=0 F   S I=$O(GMR AL(ID,"S", I)) Q:I<1   D
  10029   "RTN","VPR DJ02",108, 0)
  10030    . S X=$G( GMRAL(ID," S",I))
  10031   "RTN","VPR DJ02",109, 0)
  10032    . S REAC( "reactions ",I,"name" )=$P(X,";" )
  10033   "RTN","VPR DJ02",110, 0)
  10034    . S Y=$$V UID^VPRD(+ $P(X,";",2 ),120.83)
  10035   "RTN","VPR DJ02",111, 0)
  10036    . S REAC( "reactions ",I,"vuid" )=$$SETVUR N^VPRUTILS ("vuid",Y)
  10037   "RTN","VPR DJ02",112, 0)
  10038    ; drug cl asses
  10039   "RTN","VPR DJ02",113, 0)
  10040    S I=0 F   S I=$O(VPR Y("V",I))  Q:I<1  D
  10041   "RTN","VPR DJ02",114, 0)
  10042    . S X=$G( VPRY("V",I ))
  10043   "RTN","VPR DJ02",115, 0)
  10044    . S REAC( "drugClass es",I,"cod e")=$P(X,U )
  10045   "RTN","VPR DJ02",116, 0)
  10046    . S REAC( "drugClass es",I,"nam e")=$P(X,U ,2)
  10047   "RTN","VPR DJ02",117, 0)
  10048    S I=0 F   S I=$O(VPR Y("C",I))  Q:I<1  D
  10049   "RTN","VPR DJ02",118, 0)
  10050    . S X=$G( VPRY("C",I )),USER=$$ VA200^VPRD GMPL($P(X, U,3))
  10051   "RTN","VPR DJ02",119, 0)
  10052    . S REAC( "comments" ,I,"entere dByUid")=$ $SETUID^VP RUTILS("us er",,+USER )
  10053   "RTN","VPR DJ02",120, 0)
  10054    . S REAC( "comments" ,I,"entere dByName")= $P(X,U,3)
  10055   "RTN","VPR DJ02",121, 0)
  10056    . S REAC( "comments" ,I,"entere d")=$$JSON DT^VPRUTIL S(+X)
  10057   "RTN","VPR DJ02",122, 0)
  10058    . K CMMT  M CMMT=VPR Y("C",I)
  10059   "RTN","VPR DJ02",123, 0)
  10060    . S REAC( "comments" ,I,"commen t")=$$STRI NG^VPRD(.C MMT)
  10061   "RTN","VPR DJ02",124, 0)
  10062    I GMRA=""  S REAC("r emoved")=" true" ;ent ered in er ror
  10063   "RTN","VPR DJ02",125, 0)
  10064    D ADD^VPR DJ("REAC", "allergy")
  10065   "RTN","VPR DJ02",126, 0)
  10066    Q
  10067   "RTN","VPR DJ02",127, 0)
  10068    ;
  10069   "RTN","VPR DJ02",128, 0)
  10070   NKA ; -- n o assessme nt or NKA  [GMRAL=0 o r ""]
  10071   "RTN","VPR DJ02",129, 0)
  10072    N REAC,X
  10073   "RTN","VPR DJ02",130, 0)
  10074    S REAC("a ssessment" )=$S(GMRAL =0:"nka",1 :"not done ")
  10075   "RTN","VPR DJ02",131, 0)
  10076    S X=$$FAC ^VPRD D FA CILITY^VPR UTILS(X,"R EAC")
  10077   "RTN","VPR DJ02",132, 0)
  10078    D ADD^VPR DJ("REAC", "allergy")
  10079   "RTN","VPR DJ02",133, 0)
  10080    Q
  10081   "RTN","VPR DJ02",134, 0)
  10082    ;
  10083   "RTN","VPR DJ02",135, 0)
  10084   GMV1(ID) ;  -- vital/ measuremen t ^UTILITY ($J,"GMRVD ",VPRIDT,V PRTYP,ID)
  10085   "RTN","VPR DJ02",136, 0)
  10086    N VIT,VPR Y,X0,TYPE, LOC,FAC,X, Y,MRES,MUN T,HIGH,LOW ,I
  10087   "RTN","VPR DJ02",137, 0)
  10088    D GETREC^ GMVUTL(.VP RY,ID,1) S  X0=$G(VPR Y(0))
  10089   "RTN","VPR DJ02",138, 0)
  10090    ; GMRVUT0  returns C LiO data w ith a pseu do-ID >> g et real ID
  10091   "RTN","VPR DJ02",139, 0)
  10092    I X0="",$ G(VPRIDT), $D(VPRTYP)  D  ;[from  VPRDJ0]
  10093   "RTN","VPR DJ02",140, 0)
  10094    . N GMRVD  S GMRVD=$ G(^UTILITY ($J,"GMRVD ",VPRIDT,V PRTYP,ID))
  10095   "RTN","VPR DJ02",141, 0)
  10096    . S ID=$O (^PXRMINDX (120.5,"PI ",DFN,$P(G MRVD,U,3), +GMRVD,"") )
  10097   "RTN","VPR DJ02",142, 0)
  10098    . I $L(ID ) D GETREC ^GMVUTL(.V PRY,ID,1)  S X0=$G(VP RY(0))
  10099   "RTN","VPR DJ02",143, 0)
  10100    Q:X0=""
  10101   "RTN","VPR DJ02",144, 0)
  10102    ;
  10103   "RTN","VPR DJ02",145, 0)
  10104    N $ES,$ET ,ERRPAT,ER RMSG
  10105   "RTN","VPR DJ02",146, 0)
  10106    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  10107   "RTN","VPR DJ02",147, 0)
  10108    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he vitals  domain"
  10109   "RTN","VPR DJ02",148, 0)
  10110    S VIT("lo calId")=ID ,VIT("kind ")="Vital  Sign"
  10111   "RTN","VPR DJ02",149, 0)
  10112    S VIT("ui d")=$$SETU ID^VPRUTIL S("vital", DFN,ID)
  10113   "RTN","VPR DJ02",150, 0)
  10114    S VIT("ob served")=$ $JSONDT^VP RUTILS(+X0 )
  10115   "RTN","VPR DJ02",151, 0)
  10116    S VIT("re sulted")=$ $JSONDT^VP RUTILS(+$P (X0,U,4))
  10117   "RTN","VPR DJ02",152, 0)
  10118    S TYPE=$$ FIELD^GMVG ETVT(+$P(X 0,U,3),2)
  10119   "RTN","VPR DJ02",153, 0)
  10120    S VIT("di splayName" )=TYPE
  10121   "RTN","VPR DJ02",154, 0)
  10122    S VIT("ty peName")=$ $FIELD^GMV GETVT($P(X 0,U,3),1)
  10123   "RTN","VPR DJ02",155, 0)
  10124    S VIT("ty peCode")=" urn:va:vui d:"_$$FIEL D^GMVGETVT ($P(X0,U,3 ),4)
  10125   "RTN","VPR DJ02",156, 0)
  10126    S X=$P(X0 ,U,8),VIT( "result")= X
  10127   "RTN","VPR DJ02",157, 0)
  10128    S VIT("un its")=$$UN IT^VPRDGMV (TYPE),(MR ES,MUNT)=" "
  10129   "RTN","VPR DJ02",158, 0)
  10130    I TYPE="T "  S MUNT= "C",MRES=$ J(X-32*5/9 ,0,1) ;EN1 ^GMRVUTL
  10131   "RTN","VPR DJ02",159, 0)
  10132    I TYPE="H T" S MUNT= "cm",MRES= $J(2.54*X, 0,2)  ;EN2 ^GMRVUTL
  10133   "RTN","VPR DJ02",160, 0)
  10134    I TYPE="W T" S MUNT= "kg",MRES= $J(X/2.2,0 ,2)   ;EN3 ^GMRVUTL
  10135   "RTN","VPR DJ02",161, 0)
  10136    I TYPE="C G" S MUNT= "cm",MRES= $J(2.54*X, 0,2)
  10137   "RTN","VPR DJ02",162, 0)
  10138    S:MRES VI T("metricR esult")=MR ES,VIT("me tricUnits" )=MUNT
  10139   "RTN","VPR DJ02",163, 0)
  10140    S X=$$RAN GE^VPRDGMV (TYPE) I $ L(X) S VIT ("high")=$ P(X,U),VIT ("low")=$P (X,U,2)
  10141   "RTN","VPR DJ02",164, 0)
  10142    S VIT("su mmary")=VI T("typeNam e")_" "_VI T("result" )_" "_VIT( "units")
  10143   "RTN","VPR DJ02",165, 0)
  10144    F I=1:1:$ L(VPRY(5), U) S X=$P( VPRY(5),U, I) I X D
  10145   "RTN","VPR DJ02",166, 0)
  10146    . S VIT(" qualifiers ",I,"name" )=$$FIELD^ GMVGETQL(X ,1)
  10147   "RTN","VPR DJ02",167, 0)
  10148    . S VIT(" qualifiers ",I,"vuid" )=$$FIELD^ GMVGETQL(X ,3)
  10149   "RTN","VPR DJ02",168, 0)
  10150    I $G(VPRY (2)) S VIT ("removed" )="true"         ;ent ered in er ror
  10151   "RTN","VPR DJ02",169, 0)
  10152    S LOC=+$P (X0,U,5),F AC=$$FAC^V PRD(LOC)
  10153   "RTN","VPR DJ02",170, 0)
  10154    S VIT("lo cationUid" )=$$SETUID ^VPRUTILS( "location" ,,LOC)
  10155   "RTN","VPR DJ02",171, 0)
  10156    S VIT("lo cationName ")=$S(LOC: $P($G(^SC( LOC,0)),U) ,1:"unknow n")
  10157   "RTN","VPR DJ02",172, 0)
  10158    D FACILIT Y^VPRUTILS (FAC,"VIT" )
  10159   "RTN","VPR DJ02",173, 0)
  10160    D ADD^VPR DJ("VIT"," vital")
  10161   "RTN","VPR DJ02",174, 0)
  10162    Q
  10163   "RTN","VPR DJ02",175, 0)
  10164    ;
  10165   "RTN","VPR DJ02",176, 0)
  10166   VPR(COLL)  ; -- VPR P atient Obj ects
  10167   "RTN","VPR DJ02",177, 0)
  10168    N ID I $L ($G(VPRID) ) D  Q
  10169   "RTN","VPR DJ02",178, 0)
  10170    . S ID=+V PRID I 'ID  S ID=+$O( ^VPR(560.1 ,"B",VPRID ,0)) ;IEN  or UID
  10171   "RTN","VPR DJ02",179, 0)
  10172    . D:ID VP R1(560.1,I D)
  10173   "RTN","VPR DJ02",180, 0)
  10174    Q:$G(COLL )=""  ;err or
  10175   "RTN","VPR DJ02",181, 0)
  10176    S ID=0 F   S ID=$O(^ VPR(560.1, "C",DFN,CO LL,ID)) Q: ID<1  D VP R1(560.1,I D)
  10177   "RTN","VPR DJ02",182, 0)
  10178    Q
  10179   "RTN","VPR DJ02",183, 0)
  10180   VPR1(FNUM, ID) ; -- [ patient] o bject
  10181   "RTN","VPR DJ02",184, 0)
  10182    N I,X,VPR Y
  10183   "RTN","VPR DJ02",185, 0)
  10184    N $ES,$ET ,ERRPAT,ER RMSG
  10185   "RTN","VPR DJ02",186, 0)
  10186    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=$G(DF N)
  10187   "RTN","VPR DJ02",187, 0)
  10188    S ERRMSG= "A problem  occurred  retreiving  record "_ ID_" for t he VPR dom ain"
  10189   "RTN","VPR DJ02",188, 0)
  10190    S I=0 F   S I=$O(^VP R(FNUM,ID, 1,I)) Q:I< 1  S X=$G( ^(I,0)),VP RY(I)=X
  10191   "RTN","VPR DJ02",189, 0)
  10192    I $D(VPRY ) D  ;alre ady encode d JSON
  10193   "RTN","VPR DJ02",190, 0)
  10194    . S VPRI= VPRI+1 S:V PRI>1 @VPR @(VPRI,.3) =","
  10195   "RTN","VPR DJ02",191, 0)
  10196    . M @VPR@ (VPRI)=VPR Y
  10197   "RTN","VPR DJ02",192, 0)
  10198    Q
  10199   "RTN","VPR DJ03")
  10200   0^73^B5434 6353
  10201   "RTN","VPR DJ03",1,0)
  10202   VPRDJ03 ;S LC/MKB --  Consults,C linProcedu res,CLiO ; 6/25/12  1 6:11
  10203   "RTN","VPR DJ03",2,0)
  10204    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  10205   "RTN","VPR DJ03",3,0)
  10206    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  10207   "RTN","VPR DJ03",4,0)
  10208    ;
  10209   "RTN","VPR DJ03",5,0)
  10210    ; Externa l Referenc es           DBIA#
  10211   "RTN","VPR DJ03",6,0)
  10212    ; ------- ---------- --           -----
  10213   "RTN","VPR DJ03",7,0)
  10214    ; ^SC                             10040
  10215   "RTN","VPR DJ03",8,0)
  10216    ; ^TIU(89 25.1                     5677
  10217   "RTN","VPR DJ03",9,0)
  10218    ; ^VA(200                         10060
  10219   "RTN","VPR DJ03",10,0 )
  10220    ; %DT                             10003
  10221   "RTN","VPR DJ03",11,0 )
  10222    ; DILFD                            2055
  10223   "RTN","VPR DJ03",12,0 )
  10224    ; DIQ                              2056
  10225   "RTN","VPR DJ03",13,0 )
  10226    ; GMRCGUI B                        2980
  10227   "RTN","VPR DJ03",14,0 )
  10228    ; GMRCSLM 1,^TMP("GM RCR"          2740
  10229   "RTN","VPR DJ03",15,0 )
  10230    ; MCARUTL 3                        3280
  10231   "RTN","VPR DJ03",16,0 )
  10232    ; MDPS1,^ TMP("MDHSP "             4230
  10233   "RTN","VPR DJ03",17,0 )
  10234    ; ORX8                             2467
  10235   "RTN","VPR DJ03",18,0 )
  10236    ; TIULQ                            2693
  10237   "RTN","VPR DJ03",19,0 )
  10238    ; TIUSRVL O                        2834
  10239   "RTN","VPR DJ03",20,0 )
  10240    ; XLFSTR                          10104
  10241   "RTN","VPR DJ03",21,0 )
  10242    ; XUAF4                            2171
  10243   "RTN","VPR DJ03",22,0 )
  10244    ;
  10245   "RTN","VPR DJ03",23,0 )
  10246    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  10247   "RTN","VPR DJ03",24,0 )
  10248    ;
  10249   "RTN","VPR DJ03",25,0 )
  10250   GMRC1(ID)  ; -- consu lt/request  VPRX=^TMP ("GMRCR",$ J,"CS",VPR N,0)
  10251   "RTN","VPR DJ03",26,0 )
  10252    N CONS,OR DER,VPRD,X 0,X,VPRJ,V PRTIU
  10253   "RTN","VPR DJ03",27,0 )
  10254    N $ES,$ET ,ERRPAT,ER RMSG
  10255   "RTN","VPR DJ03",28,0 )
  10256    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  10257   "RTN","VPR DJ03",29,0 )
  10258    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he consult s domain"
  10259   "RTN","VPR DJ03",30,0 )
  10260    ;
  10261   "RTN","VPR DJ03",31,0 )
  10262    S CONS("l ocalId")=+ VPRX,CONS( "uid")=$$S ETUID^VPRU TILS("cons ult",DFN,+ VPRX)
  10263   "RTN","VPR DJ03",32,0 )
  10264    S CONS("d ateTime")= $$JSONDT^V PRUTILS($P (VPRX,U,2) )
  10265   "RTN","VPR DJ03",33,0 )
  10266    S CONS("s tatusName" )=$P(VPRX, U,3),CONS( "service") =$P(VPRX,U ,4)
  10267   "RTN","VPR DJ03",34,0 )
  10268    S CONS("c onsultProc edure")=$P (VPRX,U,5)
  10269   "RTN","VPR DJ03",35,0 )
  10270    I $P(VPRX ,U,6)="*"  S CONS("in terpretati on")="SIGN IFICANT FI NDINGS"
  10271   "RTN","VPR DJ03",36,0 )
  10272    S CONS("t ypeName")= $P(VPRX,U, 7),CONS("c ategory")= $P(VPRX,U, 9)
  10273   "RTN","VPR DJ03",37,0 )
  10274    S ORDER=+ $P(VPRX,U, 8),CONS("o rderName") =$P($$OI^O RX8(ORDER) ,U,2)
  10275   "RTN","VPR DJ03",38,0 )
  10276    S CONS("o rderUid")= $$SETUID^V PRUTILS("o rder",DFN, ORDER)
  10277   "RTN","VPR DJ03",39,0 )
  10278    D DOCLIST ^GMRCGUIB( .VPRD,+VPR X) S X0=$G (VPRD(0))  ;=^GMR(123 ,ID,0)
  10279   "RTN","VPR DJ03",40,0 )
  10280    S X=+$P(X 0,U,14) I  X D  ;orde ring provi der
  10281   "RTN","VPR DJ03",41,0 )
  10282    . S CONS( "providerU id")=$$SET UID^VPRUTI LS("user", ,X)
  10283   "RTN","VPR DJ03",42,0 )
  10284    . S CONS( "providerN ame")=$P($ G(^VA(200, X,0)),U)
  10285   "RTN","VPR DJ03",43,0 )
  10286    S VPRJ=0  F  S VPRJ= $O(VPRD(50 ,VPRJ)) Q: VPRJ<1  S  X=$G(VPRD( 50,VPRJ))  D
  10287   "RTN","VPR DJ03",44,0 )
  10288    . Q:'$D(@ (U_$P(X,"; ",2)_+X_") "))  ;text  deleted
  10289   "RTN","VPR DJ03",45,0 )
  10290    . S CONS( "results", VPRJ,"uid" )=$$SETUID ^VPRUTILS( "document" ,DFN,+X)
  10291   "RTN","VPR DJ03",46,0 )
  10292    . D EXTRA CT^TIULQ(+ X,"VPRTIU" ,,.01)
  10293   "RTN","VPR DJ03",47,0 )
  10294    . S CONS( "results", VPRJ,"loca lTitle")=$ G(VPRTIU(+ X,.01,"E") )
  10295   "RTN","VPR DJ03",48,0 )
  10296    S X=$P(X0 ,U,21),X=$ S(X:$$STA^ XUAF4(X)_U _$P($$NS^X UAF4(X),U) ,1:$$FAC^V PRD)
  10297   "RTN","VPR DJ03",49,0 )
  10298    D FACILIT Y^VPRUTILS (X,"CONS")
  10299   "RTN","VPR DJ03",50,0 )
  10300    D ADD^VPR DJ("CONS", "consult")
  10301   "RTN","VPR DJ03",51,0 )
  10302    Q
  10303   "RTN","VPR DJ03",52,0 )
  10304    ;
  10305   "RTN","VPR DJ03",53,0 )
  10306   MDPS1(DFN, BEG,END,MA X) ; -- pe rform CP s earch (sco pe variabl es)
  10307   "RTN","VPR DJ03",54,0 )
  10308    N MCARCOD E,MCARDT,M CARPROC,MC ESKEY,MCES SEC,MCFILE ,MDC,MDIMG ,RES
  10309   "RTN","VPR DJ03",55,0 )
  10310    S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
  10311   "RTN","VPR DJ03",56,0 )
  10312    K ^TMP("M DHSP",$J)  S RES=""
  10313   "RTN","VPR DJ03",57,0 )
  10314    D EN1^MDP S1(.RES,DF N,BEG,END, MAX,"",0)  ;RES=^TMP( "MDHSP",$J )
  10315   "RTN","VPR DJ03",58,0 )
  10316    Q
  10317   "RTN","VPR DJ03",59,0 )
  10318    ;
  10319   "RTN","VPR DJ03",60,0 )
  10320   MC1(ID) ;  -- clinica l procedur e VPRX=^TM P("MDHSP", $J,VPRN)
  10321   "RTN","VPR DJ03",61,0 )
  10322    N X,Y,%DT ,DATE,RTN, GBL,CONS,T IUN,VPRD,X 0,PROC,VPR T,LOC,FAC
  10323   "RTN","VPR DJ03",62,0 )
  10324    N $ES,$ET ,ERRPAT,ER RMSG
  10325   "RTN","VPR DJ03",63,0 )
  10326    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  10327   "RTN","VPR DJ03",64,0 )
  10328    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he clinica l procedur e domain"
  10329   "RTN","VPR DJ03",65,0 )
  10330    ;
  10331   "RTN","VPR DJ03",66,0 )
  10332    S RTN=$P( VPRX,U,3,4 ) Q:RTN="P RPRO^MDPS4 "  ;skip n on-CP item s
  10333   "RTN","VPR DJ03",67,0 )
  10334    S X=$P(VP RX,U,6),%D T="TXS" D  ^%DT Q:Y'> 0  S DATE= Y
  10335   "RTN","VPR DJ03",68,0 )
  10336    S GBL=+$P (VPRX,U,2) _";"_$S(RT N="PR702^M DPS1":"MDD (702,",1:$ $ROOT^VPRD MC(DFN,$P( VPRX,U,11) ,DATE))
  10337   "RTN","VPR DJ03",69,0 )
  10338    Q:'GBL  I  $G(ID),ID '=GBL Q                  ;unknow n, or not  requested
  10339   "RTN","VPR DJ03",70,0 )
  10340    ;
  10341   "RTN","VPR DJ03",71,0 )
  10342    S CONS=+$ P(VPRX,U,1 3) D:CONS  DOCLIST^GM RCGUIB(.VP RD,CONS) S  X0=$G(VPR D(0)) ;=^G MR(123,ID, 0)
  10343   "RTN","VPR DJ03",72,0 )
  10344    S TIUN=+$ P(VPRX,U,1 4) S:TIUN  TIUN=TIUN_ U_$$RESOLV E^TIUSRVLO (TIUN)
  10345   "RTN","VPR DJ03",73,0 )
  10346    S PROC("l ocalId")=G BL,PROC("c ategory")= "CP"
  10347   "RTN","VPR DJ03",74,0 )
  10348    S PROC("u id")=$$SET UID^VPRUTI LS("proced ure",DFN,G BL)
  10349   "RTN","VPR DJ03",75,0 )
  10350    S PROC("n ame")=$P(V PRX,U),PRO C("dateTim e")=$$JSON DT^VPRUTIL S(DATE)
  10351   "RTN","VPR DJ03",76,0 )
  10352    S X=$P(VP RX,U,7) S: $L(X) PROC ("interpre tation")=X
  10353   "RTN","VPR DJ03",77,0 )
  10354    S PROC("k ind")="Pro cedure"
  10355   "RTN","VPR DJ03",78,0 )
  10356    I CONS,X0  D
  10357   "RTN","VPR DJ03",79,0 )
  10358    . N VPRJ  S PROC("re quested")= $$JSONDT^V PRUTILS(+X 0)
  10359   "RTN","VPR DJ03",80,0 )
  10360    . S PROC( "consultUi d")=$$SETU ID^VPRUTIL S("consult ",DFN,CONS )
  10361   "RTN","VPR DJ03",81,0 )
  10362    . S PROC( "orderUid" )=$$SETUID ^VPRUTILS( "order",DF N,+$P(X0,U ,3))
  10363   "RTN","VPR DJ03",82,0 )
  10364    . S PROC( "statusNam e")=$$EXTE RNAL^DILFD (123,8,,$P (X0,U,12))
  10365   "RTN","VPR DJ03",83,0 )
  10366    . S VPRJ= 0 F  S VPR J=$O(VPRD( 50,VPRJ))  Q:VPRJ<1   S X=+$G(VP RD(50,VPRJ )) D
  10367   "RTN","VPR DJ03",84,0 )
  10368    .. D NOTE (X)
  10369   "RTN","VPR DJ03",85,0 )
  10370    .. S:'TIU N TIUN=X_U _$$RESOLVE ^TIUSRVLO( X)
  10371   "RTN","VPR DJ03",86,0 )
  10372    I TIUN D
  10373   "RTN","VPR DJ03",87,0 )
  10374    . S X=$P( TIUN,U,5)  I X D
  10375   "RTN","VPR DJ03",88,0 )
  10376    .. S PROC ("provider s",1,"prov iderUid")= $$SETUID^V PRUTILS("u ser",,+X)
  10377   "RTN","VPR DJ03",89,0 )
  10378    .. S PROC ("provider s",1,"prov iderName") =$P(X,";", 3)
  10379   "RTN","VPR DJ03",90,0 )
  10380    . S:$P(TI UN,U,11) P ROC("hasIm ages")="tr ue"
  10381   "RTN","VPR DJ03",91,0 )
  10382    . K VPRT  D EXTRACT^ TIULQ(+TIU N,"VPRT",, ".03;.05;1 211",,,"I" )
  10383   "RTN","VPR DJ03",92,0 )
  10384    . S X=+$G (VPRT(+TIU N,.03,"I") ),PROC("en counterUid ")=$$SETUI D^VPRUTILS ("visit",D FN,X)
  10385   "RTN","VPR DJ03",93,0 )
  10386    . S LOC=+ $G(VPRT(+T IUN,1211," I")) I LOC  S LOC=LOC _U_$P($G(^ SC(LOC,0)) ,U)
  10387   "RTN","VPR DJ03",94,0 )
  10388    . E  S X= $P(TIUN,U, 6) S:$L(X)  LOC=+$O(^ SC("B",X,0 ))_U_X
  10389   "RTN","VPR DJ03",95,0 )
  10390    . S:LOC P ROC("locat ionUid")=$ $SETUID^VP RUTILS("lo cation",,+ LOC),PROC( "locationN ame")=$P(L OC,U,2),FA C=$$FAC^VP RD(+LOC)
  10391   "RTN","VPR DJ03",96,0 )
  10392    . I '$D(P ROC("statu sName")) S  X=+$G(VPR T(+TIUN,.0 5,"I")),PR OC("status Name")=$S( X<6:"PARTI AL RESULTS ",1:"COMPL ETE")
  10393   "RTN","VPR DJ03",97,0 )
  10394    . I '$G(P ROC("resul ts",+TIUN) ) D NOTE(+ TIUN)
  10395   "RTN","VPR DJ03",98,0 )
  10396    ; if no c onsult or  note/visit  ...
  10397   "RTN","VPR DJ03",99,0 )
  10398    S:'$D(PRO C("statusN ame")) PRO C("statusN ame")="COM PLETE"
  10399   "RTN","VPR DJ03",100, 0)
  10400    I '$D(FAC ) S X=$P(X 0,U,21),FA C=$S(X:$$S TA^XUAF4(X )_U_$P($$N S^XUAF4(X) ,U),1:$$FA C^VPRD)
  10401   "RTN","VPR DJ03",101, 0)
  10402    D FACILIT Y^VPRUTILS (FAC,"PROC ")
  10403   "RTN","VPR DJ03",102, 0)
  10404    D ADD^VPR DJ("PROC", "procedure ")
  10405   "RTN","VPR DJ03",103, 0)
  10406    Q
  10407   "RTN","VPR DJ03",104, 0)
  10408    ;
  10409   "RTN","VPR DJ03",105, 0)
  10410   NOTE(DA) ;  -- add TI U note inf o
  10411   "RTN","VPR DJ03",106, 0)
  10412    N VPRT,TE XT
  10413   "RTN","VPR DJ03",107, 0)
  10414    D EXTRACT ^TIULQ(DA, "VPRT",,.0 1)
  10415   "RTN","VPR DJ03",108, 0)
  10416    S PROC("r esults",DA ,"uid")=$$ SETUID^VPR UTILS("doc ument",+$G (DFN),DA)
  10417   "RTN","VPR DJ03",109, 0)
  10418    S PROC("r esults",DA ,"localTit le")=$G(VP RT(DA,.01, "E"))
  10419   "RTN","VPR DJ03",110, 0)
  10420    Q
  10421   "RTN","VPR DJ03",111, 0)
  10422    ;
  10423   "RTN","VPR DJ03",112, 0)
  10424   MDC1(ID) ;  -- clinic al observa tion
  10425   "RTN","VPR DJ03",113, 0)
  10426    N GUID,CL IO,VPRC,VP RT,LOC,FAC ,I,X,Y
  10427   "RTN","VPR DJ03",114, 0)
  10428    S GUID=$G (ID) Q:GUI D=""  ;inv alid GUID
  10429   "RTN","VPR DJ03",115, 0)
  10430    D QRYOBS^ VPRDMDC("V PRC",GUID)  Q:'$D(VPR C)  ;doesn 't exist
  10431   "RTN","VPR DJ03",116, 0)
  10432    Q:$L($G(V PRC("PAREN T_ID","E") ))             ;PAREN T also in  list
  10433   "RTN","VPR DJ03",117, 0)
  10434    N $ES,$ET ,ERRPAT,ER RMSG
  10435   "RTN","VPR DJ03",118, 0)
  10436    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  10437   "RTN","VPR DJ03",119, 0)
  10438    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he clinica l observat ion domain "
  10439   "RTN","VPR DJ03",120, 0)
  10440    ;
  10441   "RTN","VPR DJ03",121, 0)
  10442    S CLIO("l ocalId")=G UID,CLIO(" uid")=$$SE TUID^VPRUT ILS("obs", DFN,GUID)
  10443   "RTN","VPR DJ03",122, 0)
  10444    S X=$G(VP RC("TERM_I D","I")) S :X CLIO("t ypeVuid")= "urn:va:vu id:"_X
  10445   "RTN","VPR DJ03",123, 0)
  10446    S CLIO("t ypeCode")= "urn:va:cl ioterminol ogy:"_$G(V PRC("TERM_ ID","GUID" ))
  10447   "RTN","VPR DJ03",124, 0)
  10448    S CLIO("t ypeName")= $G(VPRC("T ERM_ID","E "))
  10449   "RTN","VPR DJ03",125, 0)
  10450    S CLIO("r esult")=$G (VPRC("SVA LUE","E"))
  10451   "RTN","VPR DJ03",126, 0)
  10452    S X=$G(VP RC("UNIT_I D","ABBV") ) S:$L(X)  CLIO("unit s")=X
  10453   "RTN","VPR DJ03",127, 0)
  10454    S X=$G(VP RC("ENTERE D_DATE_TIM E","I")),C LIO("enter ed")=$$JSO NDT^VPRUTI LS(X)
  10455   "RTN","VPR DJ03",128, 0)
  10456    S X=$G(VP RC("OBSERV ED_DATE_TI ME","I")), CLIO("obse rved")=$$J SONDT^VPRU TILS(X)
  10457   "RTN","VPR DJ03",129, 0)
  10458    D QRYTYPE S^VPRDMDC( "VPRT")
  10459   "RTN","VPR DJ03",130, 0)
  10460    F I=3,5 S  X=$G(VPRT (I,"XML"))  I $L($G(V PRC(X,"E") )) D
  10461   "RTN","VPR DJ03",131, 0)
  10462    . S Y=VPR T(I,"NAME" ),Y=$S(Y=" LOCATION": "bodySite" ,1:$$LOW^X LFSTR(Y))
  10463   "RTN","VPR DJ03",132, 0)
  10464    . S CLIO( Y_"Code")= VPRC(X,"I" ),CLIO(Y_" Name")=VPR C(X,"E")
  10465   "RTN","VPR DJ03",133, 0)
  10466    F I=4,6,7  S X=$G(VP RT(I,"XML" )) I $L($G (VPRC(X,"E "))) D
  10467   "RTN","VPR DJ03",134, 0)
  10468    . S CLIO( "qualifier s",I,"type ")=$$LOW^X LFSTR(VPRT (I,"NAME") )
  10469   "RTN","VPR DJ03",135, 0)
  10470    . S CLIO( "qualifier s",I,"code ")=VPRC(X, "I")
  10471   "RTN","VPR DJ03",136, 0)
  10472    . S CLIO( "qualifier s",I,"name ")=VPRC(X, "E")
  10473   "RTN","VPR DJ03",137, 0)
  10474    S X=$G(VP RC("RANGE" ,"E")) I $ L(X) D
  10475   "RTN","VPR DJ03",138, 0)
  10476    . S Y=$S( X="Out of  Bounds Low ":"<",X="O ut of Boun ds High":" >",1:$E(X) )
  10477   "RTN","VPR DJ03",139, 0)
  10478    . S CLIO( "interpret ationCode" )="urn:hl7 :observati on-interpr etation:"_ Y
  10479   "RTN","VPR DJ03",140, 0)
  10480    . S CLIO( "interpret ationName" )=$S(X="<" :"Low off  scale",X=" >":"High o ff scale", 1:X)
  10481   "RTN","VPR DJ03",141, 0)
  10482    ; X=$G(VP RC("STATUS ","E")) S: $L(X) CLIO ("resultSt atus")=$S( X="unverif ied":"acti ve",1:"com plete")
  10483   "RTN","VPR DJ03",142, 0)
  10484    I $D(VPRC ("SUPP_PAG E")) D  ;a dd set inf o
  10485   "RTN","VPR DJ03",143, 0)
  10486    . S CLIO( "setID")=$ G(VPRC("SU PP_PAGE"," GUID"))
  10487   "RTN","VPR DJ03",144, 0)
  10488    . S CLIO( "setName") =$G(VPRC(" SUPP_PAGE" ,"DISPLAY_ NAME"))
  10489   "RTN","VPR DJ03",145, 0)
  10490    . S X=$G( VPRC("SUPP _PAGE","TY PE")) S:$L (X) CLIO(" setType")= X
  10491   "RTN","VPR DJ03",146, 0)
  10492    . S X=$G( VPRC("SUPP _PAGE","AC TIVATED_DA TE_TIME"))  S:X CLIO( "setStart" )=$$JSONDT ^VPRUTILS( X)
  10493   "RTN","VPR DJ03",147, 0)
  10494    . S X=$G( VPRC("SUPP _PAGE","DE ACTIVATED_ DATE_TIME" )) S:X CLI O("setStop ")=$$JSOND T^VPRUTILS (X)
  10495   "RTN","VPR DJ03",148, 0)
  10496    S CLIO("s tatusCode" )="urn:va: observatio n-status:c omplete",C LIO("statu sName")="c omplete"
  10497   "RTN","VPR DJ03",149, 0)
  10498    S LOC=$G( VPRC("HOSP ITAL_LOCAT ION_ID","I ")),FAC=$$ FAC^VPRD(L OC)
  10499   "RTN","VPR DJ03",150, 0)
  10500    S CLIO("l ocationUid ")=$$SETUI D^VPRUTILS ("location ",,LOC)
  10501   "RTN","VPR DJ03",151, 0)
  10502    S CLIO("l ocationNam e")=$G(VPR C("HOSPITA L_LOCATION _ID","E"))
  10503   "RTN","VPR DJ03",152, 0)
  10504    D FACILIT Y^VPRUTILS (FAC,"CLIO ")
  10505   "RTN","VPR DJ03",153, 0)
  10506    S X=$G(VP RC("COMMEN T","E")) S :$L(X) CLI O("comment ")=X
  10507   "RTN","VPR DJ03",154, 0)
  10508    D ADD^VPR DJ("CLIO", "obs")
  10509   "RTN","VPR DJ03",155, 0)
  10510    Q
  10511   "RTN","VPR DJ04")
  10512   0^74^B5047 2734
  10513   "RTN","VPR DJ04",1,0)
  10514   VPRDJ04 ;S LC/MKB --  Appointmen ts,Visits  ;6/25/12   16:11
  10515   "RTN","VPR DJ04",2,0)
  10516    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  10517   "RTN","VPR DJ04",3,0)
  10518    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  10519   "RTN","VPR DJ04",4,0)
  10520    ;
  10521   "RTN","VPR DJ04",5,0)
  10522    ; Externa l Referenc es           DBIA#
  10523   "RTN","VPR DJ04",6,0)
  10524    ; ------- ---------- --           -----
  10525   "RTN","VPR DJ04",7,0)
  10526    ; ^AUPNVS IT                       2028
  10527   "RTN","VPR DJ04",8,0)
  10528    ; ^DGS(41 .1                       3796
  10529   "RTN","VPR DJ04",9,0)
  10530    ; ^DIC(42                         10039
  10531   "RTN","VPR DJ04",10,0 )
  10532    ; ^SC                             10040
  10533   "RTN","VPR DJ04",11,0 )
  10534    ; ^VA(200                         10060
  10535   "RTN","VPR DJ04",12,0 )
  10536    ; DIQ                              2056
  10537   "RTN","VPR DJ04",13,0 )
  10538    ; ICPTCOD                          1995
  10539   "RTN","VPR DJ04",14,0 )
  10540    ; PXAPI,^ TMP("PXKEN C"            1894
  10541   "RTN","VPR DJ04",15,0 )
  10542    ; SDAMA30 1                        4433
  10543   "RTN","VPR DJ04",16,0 )
  10544    ; XLFDT                           10103
  10545   "RTN","VPR DJ04",17,0 )
  10546    ; XUAF4                            2171
  10547   "RTN","VPR DJ04",18,0 )
  10548    ;
  10549   "RTN","VPR DJ04",19,0 )
  10550    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  10551   "RTN","VPR DJ04",20,0 )
  10552    ;
  10553   "RTN","VPR DJ04",21,0 )
  10554   SDAM1 ; --  appointme nt ^TMP($J ,"SDAMA301 ",DFN,VPRD T)
  10555   "RTN","VPR DJ04",22,0 )
  10556    N NODE,HL OC,APPT,X, STS,CLS,FA C,SV,PRV
  10557   "RTN","VPR DJ04",23,0 )
  10558    S NODE=$G (^TMP($J," SDAMA301", DFN,VPRDT) )
  10559   "RTN","VPR DJ04",24,0 )
  10560    N $ES,$ET ,ERRPAT,ER RMSG
  10561   "RTN","VPR DJ04",25,0 )
  10562    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  10563   "RTN","VPR DJ04",26,0 )
  10564    S ERRMSG= "A problem  occurred  converting  a record  for the ap pointment  domain"
  10565   "RTN","VPR DJ04",27,0 )
  10566    ;
  10567   "RTN","VPR DJ04",28,0 )
  10568    S HLOC=$P (NODE,U,2) ,X="A;"_VP RDT_";"_+H LOC
  10569   "RTN","VPR DJ04",29,0 )
  10570    I $L($G(I D)),$P(ID, ";",1,3)'= X Q
  10571   "RTN","VPR DJ04",30,0 )
  10572    S APPT("l ocalId")=X ,APPT("uid ")=$$SETUI D^VPRUTILS ("appointm ent",DFN,X )
  10573   "RTN","VPR DJ04",31,0 )
  10574    S X=$P(NO DE,U,10),A PPT("typeC ode")=$P(X ,";"),APPT ("typeName ")=$P(X,"; ",2)
  10575   "RTN","VPR DJ04",32,0 )
  10576    S STS=$P( NODE,U,3), CLS=$S($E( STS)="I":" I",1:"O")
  10577   "RTN","VPR DJ04",33,0 )
  10578    S APPT("d ateTime")= $$JSONDT^V PRUTILS(VP RDT)
  10579   "RTN","VPR DJ04",34,0 )
  10580    S:$L($P(N ODE,U,6))  APPT("comm ent")=$P(N ODE,U,6)
  10581   "RTN","VPR DJ04",35,0 )
  10582    S:$P(NODE ,U,9) APPT ("checkIn" )=$$JSONDT ^VPRUTILS( $P(NODE,U, 9))
  10583   "RTN","VPR DJ04",36,0 )
  10584    S:$P(NODE ,U,11) APP T("checkOu t")=$$JSON DT^VPRUTIL S($P(NODE, U,11))
  10585   "RTN","VPR DJ04",37,0 )
  10586    I $L(ID," ;")>3 S AP PT("reason Name")=$P( ID,";",4), PRV=+$P(ID ,";",5) ;f rom SDAM e vent
  10587   "RTN","VPR DJ04",38,0 )
  10588    S FAC=$$F AC^VPRD(+H LOC) D FAC ILITY^VPRU TILS(FAC," APPT") I H LOC D
  10589   "RTN","VPR DJ04",39,0 )
  10590    . S APPT( "locationN ame")=$P(H LOC,";",2)
  10591   "RTN","VPR DJ04",40,0 )
  10592    . S APPT( "locationU id")=$$SET UID^VPRUTI LS("locati on",,+HLOC )
  10593   "RTN","VPR DJ04",41,0 )
  10594    . S X=$$A MIS^VPRDVS IT(+$P(NOD E,U,13))
  10595   "RTN","VPR DJ04",42,0 )
  10596    . S:$L(X)  APPT("sto pCodeUid") ="urn:va:s top-code:" _$P(X,U),A PPT("stopC odeName")= $P(X,U,2)
  10597   "RTN","VPR DJ04",43,0 )
  10598    . S SV=$$ GET1^DIQ(4 4,+HLOC_", ",9.5,"I")
  10599   "RTN","VPR DJ04",44,0 )
  10600    . I SV S  APPT("serv ice")=$$SE RV^VPRDSDA M(SV)
  10601   "RTN","VPR DJ04",45,0 )
  10602    . ;find d efault pro vider
  10603   "RTN","VPR DJ04",46,0 )
  10604    . S:'$G(P RV) PRV=+$ $GET1^DIQ( 44,+HLOC_" ,",16,"I")  I 'PRV D
  10605   "RTN","VPR DJ04",47,0 )
  10606    .. N VPRP ,I,FIRST
  10607   "RTN","VPR DJ04",48,0 )
  10608    .. D GETS ^DIQ(44,+H LOC_",","2 600*","I", "VPRP")
  10609   "RTN","VPR DJ04",49,0 )
  10610    .. S FIRS T=$O(VPRP( 44.1,"")), I=""
  10611   "RTN","VPR DJ04",50,0 )
  10612    .. F  S I =$O(VPRP(4 4.1,I)) Q: I=""  I $G (VPRP(44.1 ,I,.02,"I" )) S PRV=$ G(VPRP(44. 1,I,.01,"I ")) Q
  10613   "RTN","VPR DJ04",51,0 )
  10614    .. I 'PRV ,FIRST S P RV=$G(VPRP (44.1,FIRS T,.01,"I") )
  10615   "RTN","VPR DJ04",52,0 )
  10616    I $G(PRV)  S APPT("p roviders", 1,"provide rUid")=$$S ETUID^VPRU TILS("user ",,PRV),AP PT("provid ers",1,"pr oviderName ")=$P($G(^ VA(200,PRV ,0)),U)
  10617   "RTN","VPR DJ04",53,0 )
  10618    I $G(SV)  S APPT("su mmary")="$ {"_APPT("s ervice")_" }:"_$P(HLO C,";",2)
  10619   "RTN","VPR DJ04",54,0 )
  10620    S APPT("p atientClas sCode")="u rn:va:pati ent-class: "_$S(CLS=" I":"IMP",1 :"AMB")
  10621   "RTN","VPR DJ04",55,0 )
  10622    S APPT("p atientClas sName")=$S (CLS="I":" Inpatient" ,1:"Ambula tory")
  10623   "RTN","VPR DJ04",56,0 )
  10624    S APPT("c ategoryCod e")="urn:v a:encounte r-category :OV",APPT( "categoryN ame")="Out patient Vi sit"
  10625   "RTN","VPR DJ04",57,0 )
  10626    S APPT("a ppointment Status")=$ P(STS,";", 2)
  10627   "RTN","VPR DJ04",58,0 )
  10628    D ADD^VPR DJ("APPT", "appointme nt")
  10629   "RTN","VPR DJ04",59,0 )
  10630    Q
  10631   "RTN","VPR DJ04",60,0 )
  10632    ;
  10633   "RTN","VPR DJ04",61,0 )
  10634   DGS ; sche duled admi ssions [fr om APPOINT M^VPRDJ0]
  10635   "RTN","VPR DJ04",62,0 )
  10636    S VPRA=0  F  S VPRA= $O(^DGS(41 .1,"B",DFN ,VPRA)) Q: VPRA<1  D   Q:VPRI'<V PRMAX
  10637   "RTN","VPR DJ04",63,0 )
  10638    . S VPRX= $G(^DGS(41 .1,VPRA,0) )
  10639   "RTN","VPR DJ04",64,0 )
  10640    . I $L($G (ID)),+$P( ID,";",2)= +$P(VPRX,U ,2) D DGS1 (VPRA) Q
  10641   "RTN","VPR DJ04",65,0 )
  10642    . Q:$P(VP RX,U,13)   Q:$P(VPRX, U,17)  ;ca ncelled or  admitted
  10643   "RTN","VPR DJ04",66,0 )
  10644    . S X=$P( VPRX,U,2)  Q:X<VPRSTA RT!(X>VPRS TOP)  ;out  of date r ange
  10645   "RTN","VPR DJ04",67,0 )
  10646    . D DGS1( VPRA)
  10647   "RTN","VPR DJ04",68,0 )
  10648    Q
  10649   "RTN","VPR DJ04",69,0 )
  10650    ;
  10651   "RTN","VPR DJ04",70,0 )
  10652   DGS1(IFN)  ; -- sched uled admis sion
  10653   "RTN","VPR DJ04",71,0 )
  10654    N ADM,X0, DATE,HLOC, FAC,SV,X
  10655   "RTN","VPR DJ04",72,0 )
  10656    S X0=$G(^ DGS(41.1,+ $G(IFN),0) ) Q:X0=""   ;deleted
  10657   "RTN","VPR DJ04",73,0 )
  10658    ;
  10659   "RTN","VPR DJ04",74,0 )
  10660    S DATE=+$ P(X0,U,2), HLOC=+$G(^ DIC(42,+$P (X0,U,8),4 4))
  10661   "RTN","VPR DJ04",75,0 )
  10662    S X="H;"_ DATE,ADM(" localId")= X,ADM("uid ")=$$SETUI D^VPRUTILS ("appointm ent",DFN,X )
  10663   "RTN","VPR DJ04",76,0 )
  10664    S ADM("da teTime")=$ $JSONDT^VP RUTILS(DAT E)
  10665   "RTN","VPR DJ04",77,0 )
  10666    S FAC=$$F AC^VPRD(+H LOC) D FAC ILITY^VPRU TILS(FAC," ADM") I HL OC D
  10667   "RTN","VPR DJ04",78,0 )
  10668    . S HLOC= +HLOC_";"_ $P($G(^SC( +HLOC,0)), U)
  10669   "RTN","VPR DJ04",79,0 )
  10670    . S ADM(" uid")=ADM( "uid")_";" _+HLOC
  10671   "RTN","VPR DJ04",80,0 )
  10672    . S ADM(" locationNa me")=$P(HL OC,";",2)
  10673   "RTN","VPR DJ04",81,0 )
  10674    . S ADM(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+HLOC)
  10675   "RTN","VPR DJ04",82,0 )
  10676    . S X=$$G ET1^DIQ(44 ,+HLOC_"," ,8,"I"),X= $$AMIS^VPR DVSIT(X)
  10677   "RTN","VPR DJ04",83,0 )
  10678    . S:$L(X)  ADM("stop CodeUid")= "urn:va:st op-code:"_ $P(X,U),AD M("stopCod eName")=$P (X,U,2)
  10679   "RTN","VPR DJ04",84,0 )
  10680    . S SV=$$ GET1^DIQ(4 4,+HLOC_", ",9.5,"I")
  10681   "RTN","VPR DJ04",85,0 )
  10682    . I SV S  ADM("servi ce")=$$SER V^VPRDSDAM (SV)
  10683   "RTN","VPR DJ04",86,0 )
  10684    I $G(SV)  S ADM("sum mary")="${ "_ADM("ser vice")_"}: "_$P(HLOC, ";",2)
  10685   "RTN","VPR DJ04",87,0 )
  10686    S X=+$P(X 0,U,5) I X  D
  10687   "RTN","VPR DJ04",88,0 )
  10688    . S ADM(" providers" ,1,"provid erUid")=$$ SETUID^VPR UTILS("use r",,X)
  10689   "RTN","VPR DJ04",89,0 )
  10690    . S ADM(" providers" ,1,"provid erName")=$ P($G(^VA(2 00,X,0)),U )
  10691   "RTN","VPR DJ04",90,0 )
  10692    S ADM("pa tientClass Code")="ur n:va:patie nt-class:I MP",ADM("p atientClas sName")="I npatient"
  10693   "RTN","VPR DJ04",91,0 )
  10694    S ADM("ca tegoryCode ")="urn:va :encounter -category: AD",ADM("c ategoryNam e")="Admis sion"
  10695   "RTN","VPR DJ04",92,0 )
  10696    S ADM("ap pointmentS tatus")=$S ($P(X0,U,1 7):"ADMITT ED",$P(X0, U,13):"CAN CELLED",1: "SCHEDULED ")
  10697   "RTN","VPR DJ04",93,0 )
  10698    D ADD^VPR DJ("ADM"," appointmen t")
  10699   "RTN","VPR DJ04",94,0 )
  10700    Q
  10701   "RTN","VPR DJ04",95,0 )
  10702    ;
  10703   "RTN","VPR DJ04",96,0 )
  10704   VSIT1(ID)  ; -- visit
  10705   "RTN","VPR DJ04",97,0 )
  10706    N VST,X0, X15,X,FAC, LOC,CATG,A MIS,INPT,D A
  10707   "RTN","VPR DJ04",98,0 )
  10708    I $G(ID)? 1"H"1.N D  ADM^VPRDJ0 4A(ID) Q
  10709   "RTN","VPR DJ04",99,0 )
  10710    I $D(^EDP (230,"V",I D)),$L($T( EDP1^VPRDJ 04E)) D ED P1^VPRDJ04 E(ID) Q
  10711   "RTN","VPR DJ04",100, 0)
  10712    D ENCEVEN T^PXAPI(ID )
  10713   "RTN","VPR DJ04",101, 0)
  10714    ;
  10715   "RTN","VPR DJ04",102, 0)
  10716    S X0=$G(^ TMP("PXKEN C",$J,ID," VST",ID,0) ),X15=$G(^ (150))
  10717   "RTN","VPR DJ04",103, 0)
  10718    ;Q:$P(X15 ,U,3)'="P"   Q:$P(X0, U,7)="E"   Q:$P(X0,U, 12)  ;prim ary, not h istorical  or child
  10719   "RTN","VPR DJ04",104, 0)
  10720    I $P(X0,U ,7)="H" D  ADM^VPRDJ0 4A(ID,+X0)  Q
  10721   "RTN","VPR DJ04",105, 0)
  10722    S VST("lo calId")=ID ,VST("uid" )=$$SETUID ^VPRUTILS( "visit",DF N,ID)
  10723   "RTN","VPR DJ04",106, 0)
  10724    S VST("da teTime")=$ $JSONDT^VP RUTILS(+X0 )
  10725   "RTN","VPR DJ04",107, 0)
  10726    S:$P(X0,U ,18) VST(" checkOut") =$$JSONDT^ VPRUTILS($ P(X0,U,18) )
  10727   "RTN","VPR DJ04",108, 0)
  10728    S:$P(X0,U ,12) VST(" parentUid" )=$$SETUID ^VPRUTILS( "visit",DF N,$P(X0,U, 12))
  10729   "RTN","VPR DJ04",109, 0)
  10730    S FAC=+$P (X0,U,6),C ATG=$P(X0, U,7),LOC=+ $P(X0,U,22 )
  10731   "RTN","VPR DJ04",110, 0)
  10732    S:FAC X=$ $STA^XUAF4 (FAC)_U_$P ($$NS^XUAF 4(FAC),U)
  10733   "RTN","VPR DJ04",111, 0)
  10734    S:'FAC X= $$FAC^VPRD (LOC) D FA CILITY^VPR UTILS(X,"V ST")
  10735   "RTN","VPR DJ04",112, 0)
  10736    S X=$S(CA TG="H":"AD ",CATG="C" :"CR",CATG ="T":"TC", CATG="N":" U",CATG="R ":"NH","D^ X"[CATG:"O ",1:"OV")
  10737   "RTN","VPR DJ04",113, 0)
  10738    S VST("ca tegoryCode ")="urn:va :encounter -category: "_X
  10739   "RTN","VPR DJ04",114, 0)
  10740    S VST("ca tegoryName ")=$S(X="A D":"Admiss ion",X="CR ":"Chart R eview",X=" TC":"Phone  Contact", X="U":"Unk nown",X="N H":"Nursin g Home",X= "O":"Other ",1:"Outpa tient Visi t")
  10741   "RTN","VPR DJ04",115, 0)
  10742    S INPT=$P (X15,U,2)  S:INPT=""  INPT=$S("H ^I^R^D"[CA TG:1,1:0)
  10743   "RTN","VPR DJ04",116, 0)
  10744    S X=$P(X1 5,U,3) S:$ L(X) VST(" encounterT ype")=X
  10745   "RTN","VPR DJ04",117, 0)
  10746    S X=$$CPT ^VPRDVSIT( ID) S:X VS T("typeNam e")=$P($$C PT^ICPTCOD (X),U,3)
  10747   "RTN","VPR DJ04",118, 0)
  10748    I 'X S VS T("typeNam e")=$S('IN PT&LOC:$P( $G(^SC(LOC ,0)),U)_"  VISIT",1:$ $CATG^VPRD VSIT(CATG) )
  10749   "RTN","VPR DJ04",119, 0)
  10750    S VST("pa tientClass Code")="ur n:va:patie nt-class:" _$S(INPT:" IMP",1:"AM B")
  10751   "RTN","VPR DJ04",120, 0)
  10752    S VST("pa tientClass Name")=$S( INPT:"Inpa tient",1:" Ambulatory ")
  10753   "RTN","VPR DJ04",121, 0)
  10754    S X=$P(X0 ,U,8) S:X  AMIS=$$AMI S^VPRDVSIT (X) I LOC  D
  10755   "RTN","VPR DJ04",122, 0)
  10756    . N L0 S  L0=$G(^SC( LOC,0))
  10757   "RTN","VPR DJ04",123, 0)
  10758    . I 'X S  AMIS=$$AMI S^VPRDVSIT ($P(L0,U,7 ))
  10759   "RTN","VPR DJ04",124, 0)
  10760    . S VST(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+LOC)
  10761   "RTN","VPR DJ04",125, 0)
  10762    . S VST(" locationNa me")=$P(L0 ,U)
  10763   "RTN","VPR DJ04",126, 0)
  10764    . S X=$$S ERV^VPRDVS IT($P(L0,U ,20)) Q:X= ""
  10765   "RTN","VPR DJ04",127, 0)
  10766    . S:$L(X)  VST("serv ice")=X,VS T("summary ")="${"_VS T("service ")_"}:"_$P (L0,U)
  10767   "RTN","VPR DJ04",128, 0)
  10768    S:$D(AMIS ) VST("sto pCodeUid") ="urn:va:s top-code:" _$P(AMIS,U ),VST("sto pCodeName" )=$P(AMIS, U,2)
  10769   "RTN","VPR DJ04",129, 0)
  10770    S X=$$POV ^VPRDVSIT( ID) S:$L(X ) VST("rea sonUid")=$ $SETNCS^VP RUTILS("ic d",$P(X,U) ),VST("rea sonName")= $P(X,U,2)
  10771   "RTN","VPR DJ04",130, 0)
  10772    ; provide r(s)
  10773   "RTN","VPR DJ04",131, 0)
  10774    S DA=0 F   S DA=$O(^ TMP("PXKEN C",$J,ID," PRV",DA))  Q:DA<1  S  X0=$G(^(DA ,0)) D
  10775   "RTN","VPR DJ04",132, 0)
  10776    . I $P(X0 ,U,4)="P"  D PROV("VS T",DA,+X0, "P",1) Q   ;primary
  10777   "RTN","VPR DJ04",133, 0)
  10778    . D PROV( "VST",DA,+ X0,"S")                          ;secondary
  10779   "RTN","VPR DJ04",134, 0)
  10780    K ^TMP("P XKENC",$J, ID)
  10781   "RTN","VPR DJ04",135, 0)
  10782    D ADD^VPR DJ("VST"," visit")
  10783   "RTN","VPR DJ04",136, 0)
  10784    Q
  10785   "RTN","VPR DJ04",137, 0)
  10786    ;
  10787   "RTN","VPR DJ04",138, 0)
  10788   PROV(ARR,I ,IEN,ROLE, PRIM) ; --  add provi ders
  10789   "RTN","VPR DJ04",139, 0)
  10790    S @ARR@(" providers" ,I,"provid erUid")=$$ SETUID^VPR UTILS("use r",,+IEN)
  10791   "RTN","VPR DJ04",140, 0)
  10792    S @ARR@(" providers" ,I,"provid erName")=$ P($G(^VA(2 00,+IEN,0) ),U)
  10793   "RTN","VPR DJ04",141, 0)
  10794    S @ARR@(" providers" ,I,"role") =ROLE
  10795   "RTN","VPR DJ04",142, 0)
  10796    S:$G(PRIM ) @ARR@("p roviders", I,"primary ")="true"
  10797   "RTN","VPR DJ04",143, 0)
  10798    Q
  10799   "RTN","VPR DJ04",144, 0)
  10800    ;
  10801   "RTN","VPR DJ04",145, 0)
  10802   NAME(IEN)  ; -- Retur n a string  'name' fo r the visi t
  10803   "RTN","VPR DJ04",146, 0)
  10804    N Y,X0,LO C,DATE
  10805   "RTN","VPR DJ04",147, 0)
  10806    S X0=$G(^ AUPNVSIT(+ $G(IEN),0) ),Y=""
  10807   "RTN","VPR DJ04",148, 0)
  10808    S DATE=+X 0,LOC=+$P( X0,U,22) S :LOC LOC=$ P($G(^SC(L OC,0)),U)_ " "
  10809   "RTN","VPR DJ04",149, 0)
  10810    S Y=LOC_$ $FMTE^XLFD T(DATE,"1D ") ;Mon DD , YYYY
  10811   "RTN","VPR DJ04",150, 0)
  10812    Q Y
  10813   "RTN","VPR DJ04A")
  10814   0^81^B3600 7346
  10815   "RTN","VPR DJ04A",1,0 )
  10816   VPRDJ04A ; SLC/MKB --  Admission s,PTF ;7/2 5/13
  10817   "RTN","VPR DJ04A",2,0 )
  10818    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  10819   "RTN","VPR DJ04A",3,0 )
  10820    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  10821   "RTN","VPR DJ04A",4,0 )
  10822    ;
  10823   "RTN","VPR DJ04A",5,0 )
  10824    ; Externa l Referenc es           DBIA#
  10825   "RTN","VPR DJ04A",6,0 )
  10826    ; ------- ---------- --           -----
  10827   "RTN","VPR DJ04A",7,0 )
  10828    ; ^AUPNVS IT                       2028
  10829   "RTN","VPR DJ04A",8,0 )
  10830    ; ^DGPM                            1865
  10831   "RTN","VPR DJ04A",9,0 )
  10832    ; ^DIC(42                         10039
  10833   "RTN","VPR DJ04A",10, 0)
  10834    ; ^DPT                            10035
  10835   "RTN","VPR DJ04A",11, 0)
  10836    ; ^SC                             10040
  10837   "RTN","VPR DJ04A",12, 0)
  10838    ; ^VA(200                         10060
  10839   "RTN","VPR DJ04A",13, 0)
  10840    ; DGPTFAP I                        3157
  10841   "RTN","VPR DJ04A",14, 0)
  10842    ; DIC                              2051
  10843   "RTN","VPR DJ04A",15, 0)
  10844    ; DILFD                            2055
  10845   "RTN","VPR DJ04A",16, 0)
  10846    ; DIQ                              2056
  10847   "RTN","VPR DJ04A",17, 0)
  10848    ; ICDCODE                          3990
  10849   "RTN","VPR DJ04A",18, 0)
  10850    ; ICPTCOD                          1995
  10851   "RTN","VPR DJ04A",19, 0)
  10852    ; VADPT                           10061
  10853   "RTN","VPR DJ04A",20, 0)
  10854    ; XUAF4                            2171
  10855   "RTN","VPR DJ04A",21, 0)
  10856    ;
  10857   "RTN","VPR DJ04A",22, 0)
  10858    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  10859   "RTN","VPR DJ04A",23, 0)
  10860    ;
  10861   "RTN","VPR DJ04A",24, 0)
  10862   ADM(ID,DAT E) ; -- ad mission [f rom VSIT1]
  10863   "RTN","VPR DJ04A",25, 0)
  10864    N ADM,VAD MVT,VAIP,V AERR,MVT,S PEC,HLOC,F AC,ICD,I
  10865   "RTN","VPR DJ04A",26, 0)
  10866    S ID=$G(I D),DATE=+$ G(DATE) Q: ID=""  ;Q: DATE<1
  10867   "RTN","VPR DJ04A",27, 0)
  10868    I ID S VA IP("D")=DA TE,VST=+ID
  10869   "RTN","VPR DJ04A",28, 0)
  10870    I ID?1"H" 1.N S VAIP ("E")=+$E( ID,2,99),V ST=0
  10871   "RTN","VPR DJ04A",29, 0)
  10872    D IN5^VAD PT Q:'$G(V AIP(1))  ; deleted
  10873   "RTN","VPR DJ04A",30, 0)
  10874    S VADMVT= +$G(VAIP(1 3)),ID="H" _VADMVT
  10875   "RTN","VPR DJ04A",31, 0)
  10876    S ADM("lo calId")=ID ,ADM("uid" )=$$SETUID ^VPRUTILS( "visit",DF N,ID)
  10877   "RTN","VPR DJ04A",32, 0)
  10878    S:'DATE D ATE=+$G(VA IP(13,1))  S:'VST VST =$$VISIT(D FN,DATE)
  10879   "RTN","VPR DJ04A",33, 0)
  10880    S (ADM("d ateTime"), ADM("stay" ,"arrivalD ateTime")) =$$JSONDT^ VPRUTILS(D ATE)
  10881   "RTN","VPR DJ04A",34, 0)
  10882    S:$L($P(V AIP(6),U,2 )) ADM("ro omBed")=$P (VAIP(6),U ,2)
  10883   "RTN","VPR DJ04A",35, 0)
  10884    S MVT=13, I=0 I VADM VT=$G(^DPT (DFN,.105) ) D  ;if c urrent adm ission,
  10885   "RTN","VPR DJ04A",36, 0)
  10886    . S ADM(" current")= "true",MVT =14             ; use  last move ment info
  10887   "RTN","VPR DJ04A",37, 0)
  10888    . S X=$G( ^DPT(DFN,. 101)) S:$L (X) ADM("r oomBed")=X
  10889   "RTN","VPR DJ04A",38, 0)
  10890    . K VPRAD MIT                                   ;kill  flag from  VPRDJ0
  10891   "RTN","VPR DJ04A",39, 0)
  10892    S SPEC=$G (VAIP(MVT, 6)),ADM("s pecialty") =$P(SPEC,U ,2)
  10893   "RTN","VPR DJ04A",40, 0)
  10894    S X=$$SER V^VPRDVSIT (+SPEC),AD M("service ")=X
  10895   "RTN","VPR DJ04A",41, 0)
  10896    S HLOC=+$ G(^DIC(42, +$G(VAIP(M VT,4)),44) ),FAC=$$FA C^VPRD(+HL OC) I HLOC  D
  10897   "RTN","VPR DJ04A",42, 0)
  10898    . S ADM(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+HLOC)
  10899   "RTN","VPR DJ04A",43, 0)
  10900    . S ADM(" locationNa me")=$P($G (^SC(HLOC, 0)),U)
  10901   "RTN","VPR DJ04A",44, 0)
  10902    . S X=$$A MIS^VPRDVS IT($P($G(^ SC(HLOC,0) ),U,7))
  10903   "RTN","VPR DJ04A",45, 0)
  10904    . S:$L($G (X)) ADM(" stopCodeUi d")="urn:v a:stop-cod e:"_$P(X,U ),ADM("sto pCodeName" )=$P(X,U,2 )
  10905   "RTN","VPR DJ04A",46, 0)
  10906    . S ADM(" summary")= "${"_ADM(" service")_ "}:"_ADM(" locationNa me")
  10907   "RTN","VPR DJ04A",47, 0)
  10908    D FACILIT Y^VPRUTILS (FAC,"ADM" )
  10909   "RTN","VPR DJ04A",48, 0)
  10910    S ADM("ca tegoryCode ")="urn:va :encounter -category: AD",ADM("c ategoryNam e")="Admis sion"
  10911   "RTN","VPR DJ04A",49, 0)
  10912    S ADM("pa tientClass Code")="ur n:va:patie nt-class:I MP",ADM("p atientClas sName")="I npatient"
  10913   "RTN","VPR DJ04A",50, 0)
  10914    I $G(VAIP (17)) S AD M("stay"," dischargeD ateTime")= $$JSONDT^V PRUTILS(+$ G(VAIP(17, 1)))
  10915   "RTN","VPR DJ04A",51, 0)
  10916    I $G(VAIP (18)) S I= I+1 D PROV ("ADM",I,+ VAIP(18)," A")          ;attendi ng
  10917   "RTN","VPR DJ04A",52, 0)
  10918    I $G(VAIP (MVT,5)) S  I=I+1 D P ROV("ADM", I,+VAIP(MV T,5),"P",1 ) ;primary
  10919   "RTN","VPR DJ04A",53, 0)
  10920    S ICD=$$P OV^VPRDVSI T(VST) S:' ICD ICD=$$ PTF^VPRDVS IT(DFN,VAI P(12)) ;PT F>ICD
  10921   "RTN","VPR DJ04A",54, 0)
  10922    I $L(ICD) <2 S ADM(" reasonName ")=$G(VAIP (MVT,7))
  10923   "RTN","VPR DJ04A",55, 0)
  10924    E  S ADM( "reasonUid ")=$$SETNC S^VPRUTILS ("icd",ICD ),ADM("rea sonName")= $P(ICD,U,2 )
  10925   "RTN","VPR DJ04A",56, 0)
  10926    S X=$$CPT ^VPRDVSIT( VST),ADM(" typeName") =$S(X:$P($ $CPT^ICPTC OD(X),U,3) ,1:$$CATG^ VPRDVSIT(" H"))
  10927   "RTN","VPR DJ04A",57, 0)
  10928    D MVT(VAD MVT)   ;su b-movement s
  10929   "RTN","VPR DJ04A",58, 0)
  10930    ; TIU(VST ,.ADM) ;no tes/summar y
  10931   "RTN","VPR DJ04A",59, 0)
  10932    D ADD^VPR DJ("ADM"," visit")
  10933   "RTN","VPR DJ04A",60, 0)
  10934    Q
  10935   "RTN","VPR DJ04A",61, 0)
  10936    ;
  10937   "RTN","VPR DJ04A",62, 0)
  10938   TIU(VISIT, ARR) ; --  add notes  to ARR("do cument")
  10939   "RTN","VPR DJ04A",63, 0)
  10940    N X,Y,I,V PRX,LT,NT, DA,CNT,VPR Y
  10941   "RTN","VPR DJ04A",64, 0)
  10942    D FIND^DI C(8925,,.0 1,"QX",+$G (VISIT),," V",,,"VPRX ")
  10943   "RTN","VPR DJ04A",65, 0)
  10944    S Y="",(I ,CNT)=0
  10945   "RTN","VPR DJ04A",66, 0)
  10946    F  S I=$O (VPRX("DIL IST",1,I))  Q:I<1  D
  10947   "RTN","VPR DJ04A",67, 0)
  10948    . S LT=$G (VPRX("DIL IST","ID", I,.01)) Q: $P(LT," ") ="Addendum "
  10949   "RTN","VPR DJ04A",68, 0)
  10950    . S DA=$G (VPRX("DIL IST",2,I))
  10951   "RTN","VPR DJ04A",69, 0)
  10952    . S NT=$$ GET1^DIQ(8 925,+DA_", ",".01:150 1")
  10953   "RTN","VPR DJ04A",70, 0)
  10954    . S CNT=C NT+1,ARR(" documents" ,CNT,"uid" )=$$SETUID ^VPRUTILS( "document" ,DFN,+DA)
  10955   "RTN","VPR DJ04A",71, 0)
  10956    . S ARR(" documents" ,CNT,"loca lTitle")=L T
  10957   "RTN","VPR DJ04A",72, 0)
  10958    . S:$L(NT ) ARR("doc uments",CN T,"nationa lTitle")=N T
  10959   "RTN","VPR DJ04A",73, 0)
  10960    Q
  10961   "RTN","VPR DJ04A",74, 0)
  10962    ;
  10963   "RTN","VPR DJ04A",75, 0)
  10964   PROV(ARR,I ,IEN,ROLE, PRIM) ; --  add provi ders
  10965   "RTN","VPR DJ04A",76, 0)
  10966    S @ARR@(" providers" ,I,"provid erUid")=$$ SETUID^VPR UTILS("use r",,+IEN)
  10967   "RTN","VPR DJ04A",77, 0)
  10968    S @ARR@(" providers" ,I,"provid erName")=$ P($G(^VA(2 00,+IEN,0) ),U)
  10969   "RTN","VPR DJ04A",78, 0)
  10970    S @ARR@(" providers" ,I,"role") =ROLE
  10971   "RTN","VPR DJ04A",79, 0)
  10972    S:$G(PRIM ) @ARR@("p roviders", I,"primary ")="true"
  10973   "RTN","VPR DJ04A",80, 0)
  10974    Q
  10975   "RTN","VPR DJ04A",81, 0)
  10976    ;
  10977   "RTN","VPR DJ04A",82, 0)
  10978   MVT(CA) ;  -- add mov ements to  ADM("movem ent",i,"at tribute")
  10979   "RTN","VPR DJ04A",83, 0)
  10980    N DATE,DA ,CNT,X S ( DATE,CNT)= 0
  10981   "RTN","VPR DJ04A",84, 0)
  10982    F  S DATE =$O(^DGPM( "APCA",DFN ,CA,DATE))  Q:DATE<1   S DA=+$O( ^(DATE,0))  I DA'=CA  D
  10983   "RTN","VPR DJ04A",85, 0)
  10984    . S X0=$G (^DGPM(DA, 0)),CNT=CN T+1
  10985   "RTN","VPR DJ04A",86, 0)
  10986    . S ADM(" movements" ,CNT,"loca lId")=DA
  10987   "RTN","VPR DJ04A",87, 0)
  10988    . S ADM(" movements" ,CNT,"date Time")=$$J SONDT^VPRU TILS(DATE)
  10989   "RTN","VPR DJ04A",88, 0)
  10990    . S ADM(" movements" ,CNT,"move mentType") =$$EXTERNA L^DILFD(40 5,.02,,$P( X0,U,2))
  10991   "RTN","VPR DJ04A",89, 0)
  10992    . S X=+$P (X0,U,19)  I X D
  10993   "RTN","VPR DJ04A",90, 0)
  10994    .. S ADM( "movements ",CNT,"pro viderUid") =$$SETUID^ VPRUTILS(" user",,X)
  10995   "RTN","VPR DJ04A",91, 0)
  10996    .. S ADM( "movements ",CNT,"pro viderName" )=$P($G(^V A(200,X,0) ),U)
  10997   "RTN","VPR DJ04A",92, 0)
  10998    . S X=+$P (X0,U,9)
  10999   "RTN","VPR DJ04A",93, 0)
  11000    . S:X ADM ("movement s",CNT,"sp ecialty")= $$EXTERNAL ^DILFD(405 ,.09,,X)
  11001   "RTN","VPR DJ04A",94, 0)
  11002    . S HLOC= +$G(^DIC(4 2,+$P(X0,U ,6),44)),F AC=$$FAC^V PRD(HLOC)  I HLOC D
  11003   "RTN","VPR DJ04A",95, 0)
  11004    .. S ADM( "movements ",CNT,"loc ationUid") =$$SETUID^ VPRUTILS(" location", ,HLOC)
  11005   "RTN","VPR DJ04A",96, 0)
  11006    .. S ADM( "movements ",CNT,"loc ationName" )=$P($G(^S C(HLOC,0)) ,U)
  11007   "RTN","VPR DJ04A",97, 0)
  11008    Q
  11009   "RTN","VPR DJ04A",98, 0)
  11010    ;
  11011   "RTN","VPR DJ04A",99, 0)
  11012   PTFA(ID) ;  -- find I D in ^PXRM INDX(FNUM) , fall thr u to PX1 i f successf ul
  11013   "RTN","VPR DJ04A",100 ,0)
  11014    N ROOT,ID X,ITEM,DAT E K ^TMP(" VPRPX",$J)
  11015   "RTN","VPR DJ04A",101 ,0)
  11016    S P=$L(ID ,";"),TYPE =$P(ID,";" ,P),ID=$P( ID,";",1,P -1)
  11017   "RTN","VPR DJ04A",102 ,0)
  11018    S ROOT="^ PXRMINDX(4 5,""ICD9"" ,""PNI""," _+$G(DFN)_ ","_""""_T YPE_""""
  11019   "RTN","VPR DJ04A",103 ,0)
  11020    S IDX=ROO T_")" F  S  IDX=$Q(@I DX) Q:$P(I DX,",",1,5 )'=ROOT  D
  11021   "RTN","VPR DJ04A",104 ,0)
  11022    . I """"_ ID_""")"'= $P(IDX,"," ,8) Q
  11023   "RTN","VPR DJ04A",105 ,0)
  11024    . S DATE= +$P(IDX,", ",7),ITEM= +$P(IDX,", ",6)
  11025   "RTN","VPR DJ04A",106 ,0)
  11026    . S VPRID T=9999999- DATE,^TMP( "VPRPX",$J ,VPRIDT,ID _";"_TYPE) =ITEM_U_DA TE
  11027   "RTN","VPR DJ04A",107 ,0)
  11028    Q:'$D(^TM P("VPRPX", $J))  ;not  found
  11029   "RTN","VPR DJ04A",108 ,0)
  11030    S ID=ID_" ;"_TYPE
  11031   "RTN","VPR DJ04A",109 ,0)
  11032   PTF1 ; --  PTF where  ID=iens;TY PE
  11033   "RTN","VPR DJ04A",110 ,0)
  11034    ;   Expec ts ^TMP("V PRPX",$J,V PRIDT,ID)= ITM^[DISCH ARGE]DATE
  11035   "RTN","VPR DJ04A",111 ,0)
  11036    N TMP,PTF ,ADM,DIS,V AIN,VAINDT ,HLOC,FAC, X,Y,VISIT, X0
  11037   "RTN","VPR DJ04A",112 ,0)
  11038    ; PTF^DGP TPXRM(+ID, .VPRF)
  11039   "RTN","VPR DJ04A",113 ,0)
  11040    S TMP=$G( ^TMP("VPRP X",$J,VPRI DT,ID))
  11041   "RTN","VPR DJ04A",114 ,0)
  11042    N $ES,$ET ,ERRPAT,ER RMSG
  11043   "RTN","VPR DJ04A",115 ,0)
  11044    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11045   "RTN","VPR DJ04A",116 ,0)
  11046    S ERRMSG= "A problem  occurred  converting  a record  for the pt f domain"
  11047   "RTN","VPR DJ04A",117 ,0)
  11048    ;
  11049   "RTN","VPR DJ04A",118 ,0)
  11050    S PTF("lo calId")=ID ,PTF("uid" )=$$SETUID ^VPRUTILS( "ptf",DFN, ID)
  11051   "RTN","VPR DJ04A",119 ,0)
  11052    S P=$L(ID ,";"),TYPE =$P(ID,";" ,P) S:TYPE ="DXLS" PT F("princip alDx")="tr ue"
  11053   "RTN","VPR DJ04A",120 ,0)
  11054    S X=$$ICD DX^ICDCODE ($P(TMP,U) ,$P(TMP,U, 2)),Y=$S($ P(X,U,4)'= "":$P(X,U, 4),1:$P(X, U,2))
  11055   "RTN","VPR DJ04A",121 ,0)
  11056    S PTF("ic dCode")=$$ SETNCS^VPR UTILS("icd ",$P(X,U,2 )),PTF("ic dName")=Y
  11057   "RTN","VPR DJ04A",122 ,0)
  11058    S DIS=$P( TMP,U,2) S :DIS VAIND T=DIS-.000 1
  11059   "RTN","VPR DJ04A",123 ,0)
  11060    D INP^VAD PT Q:'$G(V AIN(1))  ; admission  not found
  11061   "RTN","VPR DJ04A",124 ,0)
  11062    S PTF("ad missionUid ")=$$SETUI D^VPRUTILS ("visit",D FN,"H"_VAI N(1))
  11063   "RTN","VPR DJ04A",125 ,0)
  11064    S ADM=+$G (VAIN(7)), HLOC=+$G(^ DIC(42,+$G (VAIN(4)), 44))
  11065   "RTN","VPR DJ04A",126 ,0)
  11066    S:ADM PTF ("arrivalD ateTime")= $$JSONDT^V PRUTILS(AD M)
  11067   "RTN","VPR DJ04A",127 ,0)
  11068    S:DIS PTF ("discharg eDateTime" )=$$JSONDT ^VPRUTILS( DIS)
  11069   "RTN","VPR DJ04A",128 ,0)
  11070    S FAC=$$F AC^VPRD(HL OC) D:FAC  FACILITY^V PRUTILS(FA C,"PTF")
  11071   "RTN","VPR DJ04A",129 ,0)
  11072    D ADD^VPR DJ("PTF"," ptf")
  11073   "RTN","VPR DJ04A",130 ,0)
  11074    Q
  11075   "RTN","VPR DJ04A",131 ,0)
  11076    ;
  11077   "RTN","VPR DJ04A",132 ,0)
  11078   VISIT(DFN, DATE) ; --  Return vi sit# for a dmission
  11079   "RTN","VPR DJ04A",133 ,0)
  11080    N X,Y
  11081   "RTN","VPR DJ04A",134 ,0)
  11082    S X=99999 99-$P(DATE ,".")_"."_ $P(DATE,". ",2)
  11083   "RTN","VPR DJ04A",135 ,0)
  11084    S Y=+$O(^ AUPNVSIT(" AAH",DFN,X ,0))
  11085   "RTN","VPR DJ04A",136 ,0)
  11086    Q Y
  11087   "RTN","VPR DJ04E")
  11088   0^49^B1017 0703
  11089   "RTN","VPR DJ04E",1,0 )
  11090   VPRDJ04E ; SLC/MKB --  EDIS ;6/2 5/12  16:1 1
  11091   "RTN","VPR DJ04E",2,0 )
  11092    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  11093   "RTN","VPR DJ04E",3,0 )
  11094    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  11095   "RTN","VPR DJ04E",4,0 )
  11096    ;
  11097   "RTN","VPR DJ04E",5,0 )
  11098    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  11099   "RTN","VPR DJ04E",6,0 )
  11100    ;
  11101   "RTN","VPR DJ04E",7,0 )
  11102    ;
  11103   "RTN","VPR DJ04E",8,0 )
  11104   EDP1(ID) ;  -- ED vis it
  11105   "RTN","VPR DJ04E",9,0 )
  11106    N DA,EDP, X0,VST,FAC ,LOC,LOC0, X,I,ICD
  11107   "RTN","VPR DJ04E",10, 0)
  11108    S DA=+$O( ^EDP(230," V",+$G(ID) ,0)) Q:DA< 1
  11109   "RTN","VPR DJ04E",11, 0)
  11110    S EDP=$G( ^EDP(230,D A,0)),X0=$ G(^AUPNVSI T(ID,0))
  11111   "RTN","VPR DJ04E",12, 0)
  11112    ;
  11113   "RTN","VPR DJ04E",13, 0)
  11114    S VST("lo calId")=ID ,VST("uid" )=$$SETUID ^VPRUTILS( "visit",DF N,ID)
  11115   "RTN","VPR DJ04E",14, 0)
  11116    S VST("da teTime")=$ $JSONDT^VP RUTILS(+X0 )
  11117   "RTN","VPR DJ04E",15, 0)
  11118    S:$P(EDP, U,8) VST(" stay","arr ivalDateTi me")=$$JSO NDT^VPRUTI LS($P(EDP, U,8))
  11119   "RTN","VPR DJ04E",16, 0)
  11120    S:$P(EDP, U,9) VST(" stay","dis chargeDate Time")=$$J SONDT^VPRU TILS($P(ED P,U,9))
  11121   "RTN","VPR DJ04E",17, 0)
  11122    S FAC=+$P (EDP,U,2), LOC=+$P(ED P,U,14),LO C0=$S(LOC: $G(^SC(LOC ,0)),1:"")
  11123   "RTN","VPR DJ04E",18, 0)
  11124    S:FAC X=$ $STA^XUAF4 (FAC)_U_$P ($$NS^XUAF 4(FAC),U)
  11125   "RTN","VPR DJ04E",19, 0)
  11126    S:'FAC X= $$FAC^VPRD (LOC) D FA CILITY^VPR UTILS(X,"V ST")
  11127   "RTN","VPR DJ04E",20, 0)
  11128    S VST("ca tegoryCode ")="urn:va :encounter -category: OV"
  11129   "RTN","VPR DJ04E",21, 0)
  11130    S VST("ca tegoryName ")="Outpat ient Visit "
  11131   "RTN","VPR DJ04E",22, 0)
  11132    S VST("pa tientClass Code")="ur n:va:patie nt-class:E MER"
  11133   "RTN","VPR DJ04E",23, 0)
  11134    S VST("pa tientClass Name")="Em ergency"
  11135   "RTN","VPR DJ04E",24, 0)
  11136    ;
  11137   "RTN","VPR DJ04E",25, 0)
  11138    S X=$$CPT ^VPRDVSIT( ID) S:X VS T("typeNam e")=$P($$C PT^ICPTCOD (X),U,3)
  11139   "RTN","VPR DJ04E",26, 0)
  11140    I 'X S VS T("typeNam e")=$S(LOC :$P(LOC0,U )_" VISIT" ,1:"EMERGE NCY")
  11141   "RTN","VPR DJ04E",27, 0)
  11142    S X=$P(X0 ,U,8) S:X  AMIS=$$AMI S^VPRDVSIT (X) I LOC  D
  11143   "RTN","VPR DJ04E",28, 0)
  11144    . I 'X S  AMIS=$$AMI S^VPRDVSIT ($P(LOC0,U ,7))
  11145   "RTN","VPR DJ04E",29, 0)
  11146    . S VST(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+LOC)
  11147   "RTN","VPR DJ04E",30, 0)
  11148    . S VST(" locationNa me")=$P(LO C0,U)
  11149   "RTN","VPR DJ04E",31, 0)
  11150    . S X=$$S ERV^VPRDVS IT($P(LOC0 ,U,20)) Q: X=""
  11151   "RTN","VPR DJ04E",32, 0)
  11152    . S:$L(X)  VST("serv ice")=X,VS T("summary ")="${"_VS T("service ")_"}:"_$P (LOC0,U)
  11153   "RTN","VPR DJ04E",33, 0)
  11154    S:$G(AMIS ) VST("sto pCodeUid") ="urn:va:s top-code:" _$P(AMIS,U ),VST("sto pCodeName" )=$P(AMIS, U,2)
  11155   "RTN","VPR DJ04E",34, 0)
  11156    ; X=$$POV ^VPRDVSIT( ID) S:$L(X ) VST("rea sonUid")=$ $SETNCS^VP RUTILS("ic d",$P(X,U) ),VST("rea sonName")= $P(X,U,2)
  11157   "RTN","VPR DJ04E",35, 0)
  11158    ;
  11159   "RTN","VPR DJ04E",36, 0)
  11160    S VST("re asonName") =$P($G(^ED P(230,+DA, 1)),U)
  11161   "RTN","VPR DJ04E",37, 0)
  11162    S I=0 F   S I=$O(^ED P(230,+DA, 4,I)) Q:I< 1  I $P($G (^(I,0)),U ,3) D  ;pr imary Dx
  11163   "RTN","VPR DJ04E",38, 0)
  11164    . S X=$G( ^EDP(230,+ DA,4,I,0)) ,VST("reas onName")=$ P(X,U) Q:' $P(X,U,2)
  11165   "RTN","VPR DJ04E",39, 0)
  11166    . S ICD=$ $ICD^VPRDV SIT($P(X,U ,2)) Q:$L( ICD)'>1
  11167   "RTN","VPR DJ04E",40, 0)
  11168    . S VST(" reasonUid" )=$$SETNCS ^VPRUTILS( "icd",$P(I CD,U)),VST ("reasonNa me")=$P(IC D,U,2)
  11169   "RTN","VPR DJ04E",41, 0)
  11170    ;
  11171   "RTN","VPR DJ04E",42, 0)
  11172    ; provide r(s)
  11173   "RTN","VPR DJ04E",43, 0)
  11174    S EDP=$G( ^EDP(230,D A,3)),I=0
  11175   "RTN","VPR DJ04E",44, 0)
  11176    I $P(EDP, U,5) S I=I +1 D PROV( "VST",I,+$ P(EDP,U,5) ,"P",1) ;p rimary/MD
  11177   "RTN","VPR DJ04E",45, 0)
  11178    I $P(EDP, U,6) S I=I +1 D PROV( "VST",I,+$ P(EDP,U,6) ,"N")   ;n urse
  11179   "RTN","VPR DJ04E",46, 0)
  11180    I $P(EDP, U,7) S I=I +1 D PROV( "VST",I,+$ P(EDP,U,7) ,"R")   ;r esident
  11181   "RTN","VPR DJ04E",47, 0)
  11182    S:$L($P(E DP,U,8)) V ST("commen t")=$P(EDP ,U,8)
  11183   "RTN","VPR DJ04E",48, 0)
  11184    S:$P(EDP, U,2) VST(" appointmen tStatus")= $$NAME(+$P (EDP,U,2))
  11185   "RTN","VPR DJ04E",49, 0)
  11186    ;
  11187   "RTN","VPR DJ04E",50, 0)
  11188    ; note(s)
  11189   "RTN","VPR DJ04E",51, 0)
  11190    ; TIU^VPR DJ04A(ID,. VST)
  11191   "RTN","VPR DJ04E",52, 0)
  11192    K ^TMP("P XKENC",$J, ID)
  11193   "RTN","VPR DJ04E",53, 0)
  11194    D ADD^VPR DJ("VST"," visit")
  11195   "RTN","VPR DJ04E",54, 0)
  11196    Q
  11197   "RTN","VPR DJ04E",55, 0)
  11198    ;
  11199   "RTN","VPR DJ04E",56, 0)
  11200   PROV(ARR,I ,IEN,ROLE, PRIM) ; --  add provi ders
  11201   "RTN","VPR DJ04E",57, 0)
  11202    S @ARR@(" providers" ,I,"provid erUid")=$$ SETUID^VPR UTILS("use r",,+IEN)
  11203   "RTN","VPR DJ04E",58, 0)
  11204    S @ARR@(" providers" ,I,"provid erName")=$ P($G(^VA(2 00,+IEN,0) ),U)
  11205   "RTN","VPR DJ04E",59, 0)
  11206    S @ARR@(" providers" ,I,"role") =ROLE
  11207   "RTN","VPR DJ04E",60, 0)
  11208    S:$G(PRIM ) @ARR@("p roviders", I,"primary ")="true"
  11209   "RTN","VPR DJ04E",61, 0)
  11210    Q
  11211   "RTN","VPR DJ04E",62, 0)
  11212    ;
  11213   "RTN","VPR DJ04E",63, 0)
  11214   NAME(X) ;  -- name of  a code in  #233.1
  11215   "RTN","VPR DJ04E",64, 0)
  11216    N Y S Y=$ P($G(^EDPB (233.1,+$G (X),0)),U, 2)
  11217   "RTN","VPR DJ04E",65, 0)
  11218    Q Y
  11219   "RTN","VPR DJ05")
  11220   0^75^B7863 7701
  11221   "RTN","VPR DJ05",1,0)
  11222   VPRDJ05 ;S LC/MKB --  Medication s by order  ;8/2/11   15:29
  11223   "RTN","VPR DJ05",2,0)
  11224    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  11225   "RTN","VPR DJ05",3,0)
  11226    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  11227   "RTN","VPR DJ05",4,0)
  11228    ;
  11229   "RTN","VPR DJ05",5,0)
  11230    ; Externa l Referenc es: see VP RDJ05V for  DBIA list
  11231   "RTN","VPR DJ05",6,0)
  11232    ;
  11233   "RTN","VPR DJ05",7,0)
  11234    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  11235   "RTN","VPR DJ05",8,0)
  11236    ;
  11237   "RTN","VPR DJ05",9,0)
  11238   PS1(ID) ;  -- med ord er
  11239   "RTN","VPR DJ05",10,0 )
  11240    N $ES,$ET ,ERRPAT,ER RMSG
  11241   "RTN","VPR DJ05",11,0 )
  11242    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11243   "RTN","VPR DJ05",12,0 )
  11244    S ERRMSG= "A problem  occurred  converting  order "_I D_" for th e medicati on domain"
  11245   "RTN","VPR DJ05",13,0 )
  11246    N ORPK,TY PE S ID=+$ G(ID)
  11247   "RTN","VPR DJ05",14,0 )
  11248    S ORPK=$$ PKGID^ORX8 (ID),TYPE= $E(ORPK,$L (ORPK)) S: TYPE=+TYPE  TYPE="R"
  11249   "RTN","VPR DJ05",15,0 )
  11250    ;
  11251   "RTN","VPR DJ05",16,0 )
  11252    N ORUPCHU K,ORVP,ORP CL,ORDUZ,O RODT,ORSTR T,ORSTOP,O RL,ORTO,OR STS,ORNP,O RPV,ORTX
  11253   "RTN","VPR DJ05",17,0 )
  11254    N MED,CLS ,OI,X,LOC, FAC,DRUG,D A,CNT,VPRE SP
  11255   "RTN","VPR DJ05",18,0 )
  11256    S X=$S(OR PK:$E(ORPK ,$L(ORPK)) ,1:"Z") S: X=+X X="R"  ;last cha r = PS fil e
  11257   "RTN","VPR DJ05",19,0 )
  11258    S CLS=$S( "RSN"[X:"O ","UV"[X:" I",1:$$GET 1^DIQ(100, ID_",",10, "I"))
  11259   "RTN","VPR DJ05",20,0 )
  11260    S MED("ui d")=$$SETU ID^VPRUTIL S("med",DF N,ID)
  11261   "RTN","VPR DJ05",21,0 )
  11262    S MED("or ders",1,"o rderUid")= $$SETUID^V PRUTILS("o rder",DFN, ID)
  11263   "RTN","VPR DJ05",22,0 )
  11264    S X=$$GET 1^DIQ(100, ID_",",9," I") S:X ME D("orders" ,1,"predec essor")=$$ SETUID^VPR UTILS("med ",DFN,+X)
  11265   "RTN","VPR DJ05",23,0 )
  11266    S X=$$GET 1^DIQ(100, ID_",",9.1 ,"I") S:X  MED("order s",1,"succ essor")=$$ SETUID^VPR UTILS("med ",DFN,+X)
  11267   "RTN","VPR DJ05",24,0 )
  11268    S:ORPK ME D("localId ")=ORPK_"; "_CLS
  11269   "RTN","VPR DJ05",25,0 )
  11270    D EN^ORX8 (ID) S X=" " F  S X=$ O(ORUPCHUK (X)) Q:X=" "  S:$D(OR UPCHUK(X)) #2 @X=ORUP CHUK(X)
  11271   "RTN","VPR DJ05",26,0 )
  11272    S:$G(OROD T) MED("or ders",1,"o rdered")=$ $JSONDT^VP RUTILS(ORO DT)
  11273   "RTN","VPR DJ05",27,0 )
  11274    S:$G(ORNP ) MED("ord ers",1,"pr oviderUid" )=$$SETUID ^VPRUTILS( "user",,+O RNP),MED(" orders",1, "providerN ame")=$P(O RNP,U,2)
  11275   "RTN","VPR DJ05",28,0 )
  11276    S LOC=+$G (ORL),FAC= $$FAC^VPRD (LOC) I LO C D
  11277   "RTN","VPR DJ05",29,0 )
  11278    . S MED(" orders",1, "locationU id")=$$SET UID^VPRUTI LS("locati on",,LOC)
  11279   "RTN","VPR DJ05",30,0 )
  11280    . S MED(" orders",1, "locationN ame")=$P(^ SC(LOC,0), U)
  11281   "RTN","VPR DJ05",31,0 )
  11282    D FACILIT Y^VPRUTILS (FAC,"MED" )
  11283   "RTN","VPR DJ05",32,0 )
  11284    S:$G(ORST RT) MED("o verallStar t")=$$JSON DT^VPRUTIL S(ORSTRT)
  11285   "RTN","VPR DJ05",33,0 )
  11286    S:$G(ORST OP) (MED(" stopped"), MED("overa llStop"))= $$JSONDT^V PRUTILS(OR STOP)
  11287   "RTN","VPR DJ05",34,0 )
  11288    S MED("va Status")=$ P($G(ORSTS ),U,2)
  11289   "RTN","VPR DJ05",35,0 )
  11290    S MED("me dStatusNam e")=$$STAT US^VPRDPSO R(+$G(ORST S))
  11291   "RTN","VPR DJ05",36,0 )
  11292    S MED("me dStatus")= $$MEDSTAT^ VPRDJ05V(M ED("medSta tusName"))
  11293   "RTN","VPR DJ05",37,0 )
  11294    I CLS="I"  D
  11295   "RTN","VPR DJ05",38,0 )
  11296    . S:$P($G (^SC(+$G(L OC),0)),U, 25) MED("I MO")="true "
  11297   "RTN","VPR DJ05",39,0 )
  11298    . S X=$P( $G(^OR(100 ,ID,3)),U, 9) S:X MED ("parent") =X
  11299   "RTN","VPR DJ05",40,0 )
  11300    I ORPK D  OEL^PSOORR L(DFN,ORPK _";"_CLS)
  11301   "RTN","VPR DJ05",41,0 )
  11302    S X=$S(OR PK["N":"N" ,1:CLS),ME D("vaType" )=X,MED("m edType")=$ $TYPE^VPRD J05V(X)
  11303   "RTN","VPR DJ05",42,0 )
  11304    I CLS="O"  S MED("ty pe")=$S(OR PK["N":"OT C",1:"Pres cription")
  11305   "RTN","VPR DJ05",43,0 )
  11306    S X=$G(VP RESP("COMM ENT",1)) S :$L(X) MED ("comment" )=X
  11307   "RTN","VPR DJ05",44,0 )
  11308    I $$ISIV^ VPRDJ05V G  IV1^VPRDJ 05V
  11309   "RTN","VPR DJ05",45,0 )
  11310    ;
  11311   "RTN","VPR DJ05",46,0 )
  11312   A ; - Get  order resp onses
  11313   "RTN","VPR DJ05",47,0 )
  11314    S OI=$$OI ^ORX8(ID)  I OI D
  11315   "RTN","VPR DJ05",48,0 )
  11316    . S X=$P( OI,U,2) S: $E(X,$L(X) )=" " X=$E (X,1,$L(X) -1)
  11317   "RTN","VPR DJ05",49,0 )
  11318    . S MED(" name")=X
  11319   "RTN","VPR DJ05",50,0 )
  11320    . D ZERO^ PSS50P7(+$ P(OI,U,3), ,,"PSOI")
  11321   "RTN","VPR DJ05",51,0 )
  11322    . S MED(" productFor mName")=$P ($G(^TMP($ J,"PSOI",+ $P(OI,U,3) ,.02)),U,2 )
  11323   "RTN","VPR DJ05",52,0 )
  11324    . S:+$G(^ TMP($J,"PS OI",+$P(OI ,U,3),.09) ) MED("sup ply")="tru e"
  11325   "RTN","VPR DJ05",53,0 )
  11326    D RESP^VP RDPSOR(ID, .VPRESP) ; order resp onses
  11327   "RTN","VPR DJ05",54,0 )
  11328    S DRUG=+$ G(^TMP("PS ",$J,"DD", 1,0)) S:'D RUG DRUG=+ $G(VPRESP( "DRUG",1))
  11329   "RTN","VPR DJ05",55,0 )
  11330    S MED("si g")=$S(CLS ="I":"Give : ",1:"")_ $G(VPRESP( "SIG",1))  ;ORTX(2)
  11331   "RTN","VPR DJ05",56,0 )
  11332    I CLS="O" ,'$L($G(VP RESP("SIG" ,1))),'$D( VPRESP("IN STR")) S M ED("sig")= $G(VPRESP( "COMMENT", 1)) ;old R x
  11333   "RTN","VPR DJ05",57,0 )
  11334    ;
  11335   "RTN","VPR DJ05",58,0 )
  11336   B ; - Get  dosages
  11337   "RTN","VPR DJ05",59,0 )
  11338    I '$O(^OR (100,ID,2, 0)) D  ;si ngle dose  or OP
  11339   "RTN","VPR DJ05",60,0 )
  11340    . N VPRY, START,STOP ,DUR,CONJ, MIN
  11341   "RTN","VPR DJ05",61,0 )
  11342    . S START =$G(ORSTRT ),STOP=$G( ORSTOP),MI N=0
  11343   "RTN","VPR DJ05",62,0 )
  11344    . S CNT=0  F  S CNT= $O(VPRESP( "INSTR",CN T)) Q:CNT< 1  D
  11345   "RTN","VPR DJ05",63,0 )
  11346    .. K VPRY  D DOSE(.V PRY,CNT) M  MED("dosa ges",CNT)= VPRY
  11347   "RTN","VPR DJ05",64,0 )
  11348    .. ;deter mine start  & stop pe r dose
  11349   "RTN","VPR DJ05",65,0 )
  11350    .. S MED( "dosages", CNT,"relat iveStart") =MIN
  11351   "RTN","VPR DJ05",66,0 )
  11352    .. S DUR= $G(VPRY("c omplexDura tion")),CO NJ=$G(VPRY ("complexC onjunction "))
  11353   "RTN","VPR DJ05",67,0 )
  11354    .. S STOP =$S(DUR:$$ STOP(START ,DUR),1:ST OP)
  11355   "RTN","VPR DJ05",68,0 )
  11356    .. S:STAR T MED("dos ages",CNT, "start")=$ $JSONDT^VP RUTILS(STA RT)
  11357   "RTN","VPR DJ05",69,0 )
  11358    .. S:STOP  MED("dosa ges",CNT," stop")=$$J SONDT^VPRU TILS(STOP)
  11359   "RTN","VPR DJ05",70,0 )
  11360    .. S X=$$ RELTIME(ST ART,STOP,D UR,MIN),ME D("dosages ",CNT,"rel ativeStop" )=$S($E(X) =".":0_X,1 :X)
  11361   "RTN","VPR DJ05",71,0 )
  11362    .. I $E(C ONJ)="T",D UR S START =STOP,MIN= X
  11363   "RTN","VPR DJ05",72,0 )
  11364    I $O(^OR( 100,ID,2,0 )) D
  11365   "RTN","VPR DJ05",73,0 )
  11366    . N DD,CO NJ,VPRY,MI N
  11367   "RTN","VPR DJ05",74,0 )
  11368    . M CONJ= VPRESP("CO NJ"),DUR=V PRESP("DAY S") S MIN= 0
  11369   "RTN","VPR DJ05",75,0 )
  11370    . S (DA,C NT)=0 F  S  DA=$O(^OR (100,ID,2, DA)) Q:DA< 1  D  ;chi ld orders
  11371   "RTN","VPR DJ05",76,0 )
  11372    .. K VPRE SP,VPRY D  RESP^VPRDP SOR(DA,.VP RESP),DOSE (.VPRY,1)
  11373   "RTN","VPR DJ05",77,0 )
  11374    .. S CNT= CNT+1 M ME D("dosages ",CNT)=VPR Y
  11375   "RTN","VPR DJ05",78,0 )
  11376    .. S MED( "dosages", CNT,"relat iveStart") =MIN
  11377   "RTN","VPR DJ05",79,0 )
  11378    .. S MED( "dosages", CNT,"compl exConjunct ion")=$G(C ONJ(CNT))
  11379   "RTN","VPR DJ05",80,0 )
  11380    .. S MED( "dosages", CNT,"compl exDuration ")=$G(DUR( CNT))
  11381   "RTN","VPR DJ05",81,0 )
  11382    .. S MED( "dosages", CNT,"relat edOrder")= DA
  11383   "RTN","VPR DJ05",82,0 )
  11384    .. S X=$P ($G(^OR(10 0,DA,0)),U ,8,9)
  11385   "RTN","VPR DJ05",83,0 )
  11386    .. S:$P(X ,U) MED("d osages",CN T,"start") =$$JSONDT^ VPRUTILS($ P(X,U))
  11387   "RTN","VPR DJ05",84,0 )
  11388    .. S:$P(X ,U,2) MED( "dosages", CNT,"stop" )=$$JSONDT ^VPRUTILS( $P(X,U,2))
  11389   "RTN","VPR DJ05",85,0 )
  11390    .. I $P(X ,U,2)>$G(O RSTOP) S O RSTOP=$P(X ,U,2) ;get  last stop  time
  11391   "RTN","VPR DJ05",86,0 )
  11392    .. S X=$$ RELTIME($P (X,U),$P(X ,U,2),$G(D UR(CNT)),M IN)
  11393   "RTN","VPR DJ05",87,0 )
  11394    .. S MED( "dosages", CNT,"relat iveStop")= $S($E(X)=" .":0_X,1:X ) S:$G(CON J(CNT))="T " MIN=X
  11395   "RTN","VPR DJ05",88,0 )
  11396    .. S:'DRU G DD=+$G(V PRESP("DRU G",1)),DD( DD,DA)=""  ;dispense  drug(s)
  11397   "RTN","VPR DJ05",89,0 )
  11398    .. ; get  ^TMP("PS", $J) from 1 st child,  if Inpt pa rent:
  11399   "RTN","VPR DJ05",90,0 )
  11400    .. I '$D( ^TMP("PS", $J)) S ORP K=$$PKGID^ ORX8(DA) D  OEL^PSOOR RL(DFN,ORP K_";"_CLS)
  11401   "RTN","VPR DJ05",91,0 )
  11402    . S MED(" stopped")= $$JSONDT^V PRUTILS($G (ORSTOP))  ;reset fro m last chi ld order
  11403   "RTN","VPR DJ05",92,0 )
  11404    . S DD=$O (DD(0)) I  DD,'$O(DD( DD)) S DRU G=DD Q     ;1 drug fo r order
  11405   "RTN","VPR DJ05",93,0 )
  11406    . S (DD,C NT)=0 F  S  DD=$O(DD( DD)) Q:DD< 1  S DA=0  F  S DA=$O (DD(DD,DA) ) Q:DA<1   S CNT=CNT+ 1 D NDF(DD ,CNT,DA)
  11407   "RTN","VPR DJ05",94,0 )
  11408    ;
  11409   "RTN","VPR DJ05",95,0 )
  11410   C ; - Get  OP data
  11411   "RTN","VPR DJ05",96,0 )
  11412    I CLS="O" ,ORPK'["N"  D
  11413   "RTN","VPR DJ05",97,0 )
  11414    . S MED(" orders",1, "quantityO rdered")=$ G(VPRESP(" QTY",1))
  11415   "RTN","VPR DJ05",98,0 )
  11416    . S MED(" orders",1, "daysSuppl y")=$G(VPR ESP("SUPPL Y",1))
  11417   "RTN","VPR DJ05",99,0 )
  11418    . S MED(" orders",1, "vaRouting ")=$G(VPRE SP("PICKUP ",1))
  11419   "RTN","VPR DJ05",100, 0)
  11420    . S MED(" orders",1, "fillsAllo wed")=$G(V PRESP("REF ILLS",1))
  11421   "RTN","VPR DJ05",101, 0)
  11422    . S MED(" patientIns truction") =$G(VPRESP ("PI",1))
  11423   "RTN","VPR DJ05",102, 0)
  11424    . Q:ORPK[ "P"!(ORPK[ "S")  ;pen ding
  11425   "RTN","VPR DJ05",103, 0)
  11426    . N VPR,R X0,RX1,FIL L,RFD,MW,R EL
  11427   "RTN","VPR DJ05",104, 0)
  11428    . K ^TMP( "PSOR",$J)  D EN^PSOO RDER(DFN,+ ORPK)
  11429   "RTN","VPR DJ05",105, 0)
  11430    . S RX0=$ G(^TMP("PS OR",$J,+OR PK,0)),RX1 =$G(^(1)), MED("order s",1,"pres criptionId ")=$P(RX0, U,5)
  11431   "RTN","VPR DJ05",106, 0)
  11432    . I '$G(V PRESP("QTY ",1)) S ME D("orders" ,1,"quanti tyOrdered" )=$P(RX0,U ,6)
  11433   "RTN","VPR DJ05",107, 0)
  11434    . I '$G(V PRESP("SUP PLY",1)) S  MED("orde rs",1,"day sSupply")= $P(RX0,U,7 )
  11435   "RTN","VPR DJ05",108, 0)
  11436    . S MED(" orders",1, "fillsRema ining")=$P (RX0,U,9), MED("lastF illed")=$$ JSONDT^VPR UTILS($P(R X0,U,3))
  11437   "RTN","VPR DJ05",109, 0)
  11438    . S I=$P( RX0,U,2) I  I S FILL( I)=I_"^^^" _$P(RX0,U, 6,7)_"^^^" _$P(RX0,U, 13)_"^^"_$ P(RX1,U,6)  ;original  fill
  11439   "RTN","VPR DJ05",110, 0)
  11440    . S I=0 F   S I=$O(^ TMP("PSOR" ,$J,+ORPK, "REF",I))  Q:I<1  S X =$G(^(I,0) ),FILL(+X) =X
  11441   "RTN","VPR DJ05",111, 0)
  11442    . S I=0 F   S I=$O(^ TMP("PSOR" ,$J,+ORPK, "RPAR",I))  Q:I<1  S  X=$G(^(I,0 )),$P(X,U, 14)=1,FILL (+X)=X
  11443   "RTN","VPR DJ05",112, 0)
  11444    . S (I,RF D)=0 F  S  RFD=$O(FIL L(RFD)) Q: RFD<1  S X =$G(FILL(R FD)) D  ;s ort 1st
  11445   "RTN","VPR DJ05",113, 0)
  11446    .. S I=I+ 1,MW=$P($P (X,U,10)," ;"),REL=$P ($P(X,U,8) ,".")
  11447   "RTN","VPR DJ05",114, 0)
  11448    .. S MED( "fills",I, "dispenseD ate")=$$JS ONDT^VPRUT ILS($P(RFD ,"."))
  11449   "RTN","VPR DJ05",115, 0)
  11450    .. S MED( "fills",I, "releaseDa te")=$$JSO NDT^VPRUTI LS(REL)
  11451   "RTN","VPR DJ05",116, 0)
  11452    .. S MED( "fills",I, "routing") =MW
  11453   "RTN","VPR DJ05",117, 0)
  11454    .. S MED( "fills",I, "quantityD ispensed") =$P(X,U,4)
  11455   "RTN","VPR DJ05",118, 0)
  11456    .. S MED( "fills",I, "daysSuppl yDispensed ")=$P(X,U, 5)
  11457   "RTN","VPR DJ05",119, 0)
  11458    .. S:$P(X ,U,14) MED ("fills",I ,"partial" )=1 ;"true "
  11459   "RTN","VPR DJ05",120, 0)
  11460    . S X=$S( $P(RX0,U,1 1):$P(RX0, U,11),$P(R X0,U,10):$ P(RX0,U,10 ),1:0)
  11461   "RTN","VPR DJ05",121, 0)
  11462    . S:X MED ("orders", 1,"fillCos t")=X
  11463   "RTN","VPR DJ05",122, 0)
  11464    . S X=$$G ET1^PSODI( 52,+ORPK_" ,",26,"I")  S:X MED(" overallSto p")=$$JSON DT^VPRUTIL S($P(X,U,2 )) ;1^expi rationDate
  11465   "RTN","VPR DJ05",123, 0)
  11466    I CLS="I"  D
  11467   "RTN","VPR DJ05",124, 0)
  11468    . S X=$$G ET1^DIQ(55 .06,+ORPK_ ","_DFN_", ",25,"I")
  11469   "RTN","VPR DJ05",125, 0)
  11470    . S:X MED ("overallS top")=$$JS ONDT^VPRUT ILS(X)
  11471   "RTN","VPR DJ05",126, 0)
  11472    . D BCMA^ VPRDJ05V(. MED,DFN,OR PK)
  11473   "RTN","VPR DJ05",127, 0)
  11474    ;
  11475   "RTN","VPR DJ05",128, 0)
  11476   PSQ ; fini sh
  11477   "RTN","VPR DJ05",129, 0)
  11478    D:DRUG ND F(+DRUG)
  11479   "RTN","VPR DJ05",130, 0)
  11480    S MED("qu alifiedNam e")=$G(MED ("name"))
  11481   "RTN","VPR DJ05",131, 0)
  11482    S X=+$P($ G(^TMP("PS ",$J,"RXN" ,0)),U,5)
  11483   "RTN","VPR DJ05",132, 0)
  11484    S:X MED(" orders",1, "pharmacis tUid")=$$S ETUID^VPRU TILS("user ",,X),MED( "orders",1 ,"pharmaci stName")=$ P($G(^VA(2 00,X,0)),U )
  11485   "RTN","VPR DJ05",133, 0)
  11486    K ^TMP("P S",$J),^TM P($J,"PSOI "),^TMP("P SOR",$J)
  11487   "RTN","VPR DJ05",134, 0)
  11488    D ADD^VPR DJ("MED"," med")
  11489   "RTN","VPR DJ05",135, 0)
  11490    Q
  11491   "RTN","VPR DJ05",136, 0)
  11492    ;
  11493   "RTN","VPR DJ05",137, 0)
  11494   DOSE(Y,N)  ; -- retur n dosage d ata from V PRESP(ID,N ) to Y("na me")
  11495   "RTN","VPR DJ05",138, 0)
  11496    N X,DUR,C ONJ S N=+$ G(N,1) K Y
  11497   "RTN","VPR DJ05",139, 0)
  11498    S X=$P($G (VPRESP("D OSE",N))," &",1,2) ;  units per  dose + nou n
  11499   "RTN","VPR DJ05",140, 0)
  11500    S Y("dose ")=$S($L(X )>2:$TR(X, "&"," "),1 :$P(X,"&") )
  11501   "RTN","VPR DJ05",141, 0)
  11502    S Y("unit s")=$P(X," &",2)
  11503   "RTN","VPR DJ05",142, 0)
  11504    S X=+$G(V PRESP("ROU TE",N)) D  ALL^PSS51P 2(X,,,,"VP RTE")
  11505   "RTN","VPR DJ05",143, 0)
  11506    S Y("rout eName")=$G (^TMP($J," VPRTE",X,1 ))
  11507   "RTN","VPR DJ05",144, 0)
  11508    S X=$G(VP RESP("SCHE DULE",N))  I $L(X) S  Y("schedul eName")=X  D SCH^VPRD J05V(X)
  11509   "RTN","VPR DJ05",145, 0)
  11510    S X=$G(VP RESP("ADMI N",N)) S:$ L(X) Y("ad minTimes") =X
  11511   "RTN","VPR DJ05",146, 0)
  11512    S X=$G(VP RESP("DAYS ",N)) S:$L (X) Y("com plexDurati on")=X,DUR =X
  11513   "RTN","VPR DJ05",147, 0)
  11514    S X=$G(VP RESP("CONJ ",N)) S:$L (X) Y("com plexConjun ction")=X, CONJ=X
  11515   "RTN","VPR DJ05",148, 0)
  11516    I $L($G(C ONJ)),'$L( $G(DUR)) D   ;look ah ead to fin d duration
  11517   "RTN","VPR DJ05",149, 0)
  11518    . N I,D S  I=$O(VPRE SP("DAYS", N)),D=$S(I :$G(VPRESP ("DAYS",I) ),1:"")
  11519   "RTN","VPR DJ05",150, 0)
  11520    . S:$L(D)  Y("comple xDuration" )=D
  11521   "RTN","VPR DJ05",151, 0)
  11522    K ^TMP($J ,"VPRTE")
  11523   "RTN","VPR DJ05",152, 0)
  11524    Q
  11525   "RTN","VPR DJ05",153, 0)
  11526    ;
  11527   "RTN","VPR DJ05",154, 0)
  11528   STOP(BEG,X ) ; -- Ret urn date a fter addin g X to BEG
  11529   "RTN","VPR DJ05",155, 0)
  11530    N D,H,M,U NT,Y
  11531   "RTN","VPR DJ05",156, 0)
  11532    S Y=BEG,( D,H,M)=0,U NT=$P(X,+X ,2),X=+X
  11533   "RTN","VPR DJ05",157, 0)
  11534    S UNT=$S( $E(UNT)="  ":$E(UNT,2 ),1:$E(UNT )) I UNT=" " S UNT="D "
  11535   "RTN","VPR DJ05",158, 0)
  11536    S:UNT="L"  D=30*X
  11537   "RTN","VPR DJ05",159, 0)
  11538    S:UNT="W"  D=7*X
  11539   "RTN","VPR DJ05",160, 0)
  11540    S:UNT="D"  D=X
  11541   "RTN","VPR DJ05",161, 0)
  11542    S:UNT="H"  H=X
  11543   "RTN","VPR DJ05",162, 0)
  11544    S:UNT="M"  M=X
  11545   "RTN","VPR DJ05",163, 0)
  11546    S Y=$$FMA DD^XLFDT(B EG,D,H,M)
  11547   "RTN","VPR DJ05",164, 0)
  11548    Q Y
  11549   "RTN","VPR DJ05",165, 0)
  11550    ;
  11551   "RTN","VPR DJ05",166, 0)
  11552   NDF(DRUG,V PI,ORD) ;  -- Set NDF  data for  dispense D RUG ien
  11553   "RTN","VPR DJ05",167, 0)
  11554    ; code ^  name ^ vui d [^ role  ^ concentr ation ^ or der]
  11555   "RTN","VPR DJ05",168, 0)
  11556    N LEN,VPR X,STR,VUID ,X,I
  11557   "RTN","VPR DJ05",169, 0)
  11558    S DRUG=+$ G(DRUG) Q: 'DRUG
  11559   "RTN","VPR DJ05",170, 0)
  11560    D EN^PSSD I(50,,50," 901;902",D RUG,"VPRX" )
  11561   "RTN","VPR DJ05",171, 0)
  11562    S STR=$S( $G(VPRX(50 ,DRUG,901) ):$G(VPRX( 50,DRUG,90 1))_" "_$G (VPRX(50,D RUG,902)), 1:"")
  11563   "RTN","VPR DJ05",172, 0)
  11564    D NDF^PSS 50(DRUG,,, ,,"NDF") S  VPI=+$G(V PI,1)
  11565   "RTN","VPR DJ05",173, 0)
  11566    ;
  11567   "RTN","VPR DJ05",174, 0)
  11568    S MED("pr oducts",VP I,"ingredi entRole")= "urn:sct:4 10942007"  ;Drug
  11569   "RTN","VPR DJ05",175, 0)
  11570    S:$G(ORD)  MED("prod ucts",VPI, "relatedOr der")=ORD
  11571   "RTN","VPR DJ05",176, 0)
  11572    S:$G(STR)  MED("prod ucts",VPI, "strength" )=STR
  11573   "RTN","VPR DJ05",177, 0)
  11574    S X=$G(ME D("name"))  S:$L(X) M ED("produc ts",VPI,"i ngredientN ame")=X
  11575   "RTN","VPR DJ05",178, 0)
  11576    ;
  11577   "RTN","VPR DJ05",179, 0)
  11578    S X=$G(^T MP($J,"NDF ",DRUG,20) ) ;VA Gene ric
  11579   "RTN","VPR DJ05",180, 0)
  11580    S MED("pr oducts",VP I,"ingredi entCode")= "urn:va:vu id:"_$$VUI D^VPRD(+X, 50.6)
  11581   "RTN","VPR DJ05",181, 0)
  11582    S MED("pr oducts",VP I,"ingredi entCodeNam e")=$P(X,U ,2)
  11583   "RTN","VPR DJ05",182, 0)
  11584    ;
  11585   "RTN","VPR DJ05",183, 0)
  11586    S X=$G(^T MP($J,"NDF ",DRUG,22) ) ;VA Prod uct
  11587   "RTN","VPR DJ05",184, 0)
  11588    S MED("pr oducts",VP I,"supplie dCode")="u rn:va:vuid :"_$$VUID^ VPRD(+X,50 .68)
  11589   "RTN","VPR DJ05",185, 0)
  11590    S MED("pr oducts",VP I,"supplie dName")=$P (X,U,2)
  11591   "RTN","VPR DJ05",186, 0)
  11592    ;
  11593   "RTN","VPR DJ05",187, 0)
  11594    S X=$G(^T MP($J,"NDF ",DRUG,25) ) ;VA Drug  Class
  11595   "RTN","VPR DJ05",188, 0)
  11596    S MED("pr oducts",VP I,"drugCla ssCode")=" urn:vadc:" _$P(X,U,2)
  11597   "RTN","VPR DJ05",189, 0)
  11598    S MED("pr oducts",VP I,"drugCla ssName")=$ P(X,U,3)
  11599   "RTN","VPR DJ05",190, 0)
  11600    ;
  11601   "RTN","VPR DJ05",191, 0)
  11602    K ^TMP($J ,"NDF")
  11603   "RTN","VPR DJ05",192, 0)
  11604    Q
  11605   "RTN","VPR DJ05",193, 0)
  11606    ;
  11607   "RTN","VPR DJ05",194, 0)
  11608   RELTIME(ST ART,STOP,D UR,MIN) ;  -- Return  #min for d ose
  11609   "RTN","VPR DJ05",195, 0)
  11610    N Y S Y=0
  11611   "RTN","VPR DJ05",196, 0)
  11612    I START>0 ,STOP>0 S  Y=$$FMDIFF ^XLFDT(STO P,START,2) \60 I 1
  11613   "RTN","VPR DJ05",197, 0)
  11614    E  I DUR  S Y=$$TOMI N(DUR) I 1
  11615   "RTN","VPR DJ05",198, 0)
  11616    E  S Y=$G (VPRESP("S UPPLY",1)) *1440
  11617   "RTN","VPR DJ05",199, 0)
  11618    S Y=$S(Y: Y+MIN,1:MI N)
  11619   "RTN","VPR DJ05",200, 0)
  11620    Q Y
  11621   "RTN","VPR DJ05",201, 0)
  11622    ;
  11623   "RTN","VPR DJ05",202, 0)
  11624   TOMIN(DUR)  ;
  11625   "RTN","VPR DJ05",203, 0)
  11626    N RESULT, TIME,UNIT
  11627   "RTN","VPR DJ05",204, 0)
  11628    S UNIT=$$ UP^XLFSTR( $E($P(DUR, " ",2)))
  11629   "RTN","VPR DJ05",205, 0)
  11630    I UNIT=""  Q 0
  11631   "RTN","VPR DJ05",206, 0)
  11632    S TIME=$P (DUR," ")
  11633   "RTN","VPR DJ05",207, 0)
  11634    S RESULT= $S(UNIT="M ":TIME,UNI T="H":TIME *60,UNIT=" D":TIME*14 40,UNIT="W ":TIME*100 80,UNIT="L ":TIME*432 00,1:0)
  11635   "RTN","VPR DJ05",208, 0)
  11636    Q RESULT
  11637   "RTN","VPR DJ06")
  11638   0^77^B5892 7484
  11639   "RTN","VPR DJ06",1,0)
  11640   VPRDJ06 ;S LC/MKB --  Laboratory  ;6/25/12   16:11
  11641   "RTN","VPR DJ06",2,0)
  11642    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  11643   "RTN","VPR DJ06",3,0)
  11644    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  11645   "RTN","VPR DJ06",4,0)
  11646    ;
  11647   "RTN","VPR DJ06",5,0)
  11648    ; Externa l Referenc es           DBIA#
  11649   "RTN","VPR DJ06",6,0)
  11650    ; ------- ---------- --           -----
  11651   "RTN","VPR DJ06",7,0)
  11652    ; ^LAB(60                         10054
  11653   "RTN","VPR DJ06",8,0)
  11654    ; ^LR                               525
  11655   "RTN","VPR DJ06",9,0)
  11656    ; ^PXRMIN DX                       4290
  11657   "RTN","VPR DJ06",10,0 )
  11658    ; ^TMP("L RRR" [LR7O R1]           2503
  11659   "RTN","VPR DJ06",11,0 )
  11660    ; DIQ                              2056
  11661   "RTN","VPR DJ06",12,0 )
  11662    ; LR7OR1, ^TMP("LRRR "             2503
  11663   "RTN","VPR DJ06",13,0 )
  11664    ; LRPXAPI                          4245
  11665   "RTN","VPR DJ06",14,0 )
  11666    ; LRPXAPI U                        4246
  11667   "RTN","VPR DJ06",15,0 )
  11668    ; XLFSTR                          10104
  11669   "RTN","VPR DJ06",16,0 )
  11670    ; XUAF4                            2171
  11671   "RTN","VPR DJ06",17,0 )
  11672    ;
  11673   "RTN","VPR DJ06",18,0 )
  11674    ; All tag s expect D FN, ID, LR DFN, [VPRS TART, VPRS TOP, VPRMA X, VPRTEXT ]
  11675   "RTN","VPR DJ06",19,0 )
  11676    ;                & ^ TMP("LRRR" ,$J,DFN,VP RSUB,VPRID T,VPRP),VP RN
  11677   "RTN","VPR DJ06",20,0 )
  11678    ;
  11679   "RTN","VPR DJ06",21,0 )
  11680   CH1 ; -- l ab ID = CH ;VPRIDT;VP RN
  11681   "RTN","VPR DJ06",22,0 )
  11682    N LAB,LRI ,X,X0,SPC, LOINC,ORD, CMMT
  11683   "RTN","VPR DJ06",23,0 )
  11684    N $ES,$ET ,ERRPAT,ER RMSG
  11685   "RTN","VPR DJ06",24,0 )
  11686    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11687   "RTN","VPR DJ06",25,0 )
  11688    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he chemist ry domain"
  11689   "RTN","VPR DJ06",26,0 )
  11690    ;
  11691   "RTN","VPR DJ06",27,0 )
  11692    M LAB=VPR ACC ;get a ccession i nfo
  11693   "RTN","VPR DJ06",28,0 )
  11694    S LAB("lo calId")=ID ,LAB("uid" )=$$SETUID ^VPRUTILS( "lab",DFN, ID)
  11695   "RTN","VPR DJ06",29,0 )
  11696    S LAB("ca tegoryCode ")="urn:va :lab-categ ory:CH"
  11697   "RTN","VPR DJ06",30,0 )
  11698    S LAB("ca tegoryName ")="Labora tory"
  11699   "RTN","VPR DJ06",31,0 )
  11700    S LAB("di splayOrder ")=VPRP
  11701   "RTN","VPR DJ06",32,0 )
  11702    S LRI=$G( ^LR(LRDFN, "CH",VPRID T,VPRN))
  11703   "RTN","VPR DJ06",33,0 )
  11704    S X0=$G(^ TMP("LRRR" ,$J,DFN,"C H",VPRIDT, VPRP)),SPC =+$P(X0,U, 19)
  11705   "RTN","VPR DJ06",34,0 )
  11706    S LAB("ty peId")=+X0 ,LAB("type Name")=$P( $G(^LAB(60 ,+X0,0)),U )
  11707   "RTN","VPR DJ06",35,0 )
  11708    S:$L($P(X 0,U,2)) LA B("result" )=$P(X0,U, 2)
  11709   "RTN","VPR DJ06",36,0 )
  11710    S:$L($P(X 0,U,4)) LA B("units") =$P(X0,U,4 )
  11711   "RTN","VPR DJ06",37,0 )
  11712    S X=$P(X0 ,U,5) I $L (X),X["-"  S LAB("low ")=$$TRIM^ XLFSTR($P( X,"-")),LA B("high")= $$TRIM^XLF STR($P(X," -",2))
  11713   "RTN","VPR DJ06",38,0 )
  11714    S X=$P(X0 ,U,3) I $L (X) D
  11715   "RTN","VPR DJ06",39,0 )
  11716    . S:X["*"  X=$S(X["L ":"LL",1:" HH")
  11717   "RTN","VPR DJ06",40,0 )
  11718    . S LAB(" interpreta tionCode") ="urn:hl7: observatio n-interpre tation:"_X
  11719   "RTN","VPR DJ06",41,0 )
  11720    . S LAB(" interpreta tionName") =$S(X["L": "Low",1:"H igh")_$S($ L(X)>1:" a lert",1:"" )
  11721   "RTN","VPR DJ06",42,0 )
  11722    S LAB("di splayName" )=$S($L($P (X0,U,15)) :$P(X0,U,1 5),1:LAB(" test"))
  11723   "RTN","VPR DJ06",43,0 )
  11724    S ORD=+$P (X0,U,17)  S:ORD LAB( "labOrderI d")=ORD
  11725   "RTN","VPR DJ06",44,0 )
  11726    S X=$$ORD ER^VPRDLR( ORD,+X0) S :X LAB("or derUid")=$ $SETUID^VP RUTILS("or der",DFN,X )
  11727   "RTN","VPR DJ06",45,0 )
  11728    S LOINC=$ P($P(LRI,U ,3),"!",3)  S:'LOINC  LOINC=$$LO INC(+X0,SP C)
  11729   "RTN","VPR DJ06",46,0 )
  11730    I LOINC S  LAB("type Code")="ur n:lnc:"_$$ GET1^DIQ(9 5.3,+LOINC _",",.01), LAB("vuid" )="urn:va: vuid:"_$$V UID^VPRD(+ LOINC,95.3 )
  11731   "RTN","VPR DJ06",47,0 )
  11732    I 'LOINC  S LAB("typ eCode")="u rn:va:ien: 60:"_+X0_" :"_SPC
  11733   "RTN","VPR DJ06",48,0 )
  11734    I $D(^TMP ("LRRR",$J ,DFN,"CH", VPRIDT,"N" )) M CMMT= ^("N") S L AB("commen t")=$$STRI NG^VPRD(.C MMT)
  11735   "RTN","VPR DJ06",49,0 )
  11736    S LAB("st atusCode") ="urn:va:l ab-status: completed" ,LAB("stat usName")=" completed"
  11737   "RTN","VPR DJ06",50,0 )
  11738    D ADD^VPR DJ("LAB"," lab")
  11739   "RTN","VPR DJ06",51,0 )
  11740    Q
  11741   "RTN","VPR DJ06",52,0 )
  11742    ;
  11743   "RTN","VPR DJ06",53,0 )
  11744   LOINC(TEST ,SPEC) ; - - find LOI NC ien, if  not saved  with resu lt [for DE V only]
  11745   "RTN","VPR DJ06",54,0 )
  11746    N Y,X,LAM ,I S Y=""
  11747   "RTN","VPR DJ06",55,0 )
  11748    I '$G(TES T)!'$G(SPE C) Q ""
  11749   "RTN","VPR DJ06",56,0 )
  11750    S Y=+$G(^ LAB(60,TES T,1,SPEC,9 5.3)) I 'Y  D
  11751   "RTN","VPR DJ06",57,0 )
  11752    . S LAM=$ G(^LAB(60, TEST,64)), X=$S($P(LA M,U,2):$P( LAM,U,2),L AM:+LAM,1: "") Q:'X
  11753   "RTN","VPR DJ06",58,0 )
  11754    . S I=+$O (^LAM(X,5, SPEC,1,0)) ,Y=+$P($G( ^(I,1)),U)  Q:Y  ;fir st, node 1
  11755   "RTN","VPR DJ06",59,0 )
  11756    . S Y=$P( $G(^LAM(X, 9)),U) ;de fault LOIN C
  11757   "RTN","VPR DJ06",60,0 )
  11758    Q Y
  11759   "RTN","VPR DJ06",61,0 )
  11760    ;
  11761   "RTN","VPR DJ06",62,0 )
  11762   ACC ; -- p ut accessi on-level d ata in VPR ACC("attri bute")
  11763   "RTN","VPR DJ06",63,0 )
  11764    N LR0,CDT ,SPC,X K V PRACC
  11765   "RTN","VPR DJ06",64,0 )
  11766    S LR0=$G( ^LR(LRDFN, VPRSUB,VPR IDT,0))
  11767   "RTN","VPR DJ06",65,0 )
  11768    S CDT=999 9999-VPRID T,VPRACC(" observed") =$$DATE(CD T)
  11769   "RTN","VPR DJ06",66,0 )
  11770    S VPRACC( "resulted" )=$$DATE($ P(LR0,U,3) ),SPC=+$P( LR0,U,5) I  SPC D
  11771   "RTN","VPR DJ06",67,0 )
  11772    . N IENS, VPRY S IEN S=SPC_","
  11773   "RTN","VPR DJ06",68,0 )
  11774    . D GETS^ DIQ(61,IEN S,".01;4.1 ",,"VPRY")
  11775   "RTN","VPR DJ06",69,0 )
  11776    . S VPRAC C("specime n")=$G(VPR Y(61,IENS, .01))
  11777   "RTN","VPR DJ06",70,0 )
  11778    . S VPRAC C("sample" )=$G(VPRY( 61,IENS,4. 1))
  11779   "RTN","VPR DJ06",71,0 )
  11780    S VPRACC( "groupUid" )=$$SETUID ^VPRUTILS( "accession ",DFN,VPRS UB_";"_VPR IDT)
  11781   "RTN","VPR DJ06",72,0 )
  11782    S VPRACC( "groupName ")=$P(LR0, U,6)
  11783   "RTN","VPR DJ06",73,0 )
  11784    S X=+$P(L R0,U,14) D   D FACILI TY^VPRUTIL S(X,"VPRAC C")
  11785   "RTN","VPR DJ06",74,0 )
  11786    . S:X X=$ $STA^XUAF4 (X)_U_$P($ $NS^XUAF4( X),U)
  11787   "RTN","VPR DJ06",75,0 )
  11788    . I 'X S  X=$$FAC^VP RD ;local  stn#^name
  11789   "RTN","VPR DJ06",76,0 )
  11790    Q
  11791   "RTN","VPR DJ06",77,0 )
  11792    ;
  11793   "RTN","VPR DJ06",78,0 )
  11794   MI ; -- mi crobiology  accession  ID = MI;V PRIDT
  11795   "RTN","VPR DJ06",79,0 )
  11796    N LAB,CDT ,LR0,X,ACC ,FAC,X0,X1 ,X2,IDX,VP RM,VPRPX,V PRITM,DA,F LD
  11797   "RTN","VPR DJ06",80,0 )
  11798    N $ES,$ET ,ERRPAT,ER RMSG
  11799   "RTN","VPR DJ06",81,0 )
  11800    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11801   "RTN","VPR DJ06",82,0 )
  11802    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he microbi ology doma in"
  11803   "RTN","VPR DJ06",83,0 )
  11804    ;
  11805   "RTN","VPR DJ06",84,0 )
  11806    S LAB("lo calId")=ID ,LAB("uid" )=$$SETUID ^VPRUTILS( "lab",DFN, ID)
  11807   "RTN","VPR DJ06",85,0 )
  11808    S LAB("ca tegoryCode ")="urn:va :lab-categ ory:MI"
  11809   "RTN","VPR DJ06",86,0 )
  11810    S LAB("ca tegoryName ")="Microb iology"
  11811   "RTN","VPR DJ06",87,0 )
  11812    S LAB("st atusCode") ="urn:va:l ab-status: completed" ,LAB("stat usName")=" completed"
  11813   "RTN","VPR DJ06",88,0 )
  11814    S CDT=999 9999-VPRID T,LAB("obs erved")=$$ DATE(CDT)
  11815   "RTN","VPR DJ06",89,0 )
  11816    S LR0=$G( ^LR(LRDFN, "MI",VPRID T,0))
  11817   "RTN","VPR DJ06",90,0 )
  11818    S:$P(LR0, U,3) LAB(" resulted") =$$DATE($P (LR0,U,3))
  11819   "RTN","VPR DJ06",91,0 )
  11820    S X=+$P(L R0,U,5) I  X D  ;spec imen
  11821   "RTN","VPR DJ06",92,0 )
  11822    . N IENS, VPRY S IEN S=X_","
  11823   "RTN","VPR DJ06",93,0 )
  11824    . D GETS^ DIQ(61,IEN S,".01;2", ,"VPRY")
  11825   "RTN","VPR DJ06",94,0 )
  11826    . S LAB(" specimen") =$G(VPRY(6 1,IENS,.01 ))
  11827   "RTN","VPR DJ06",95,0 )
  11828    . S LAB(" sample")=$ $GET1^DIQ( 61,X_",",4 .1)
  11829   "RTN","VPR DJ06",96,0 )
  11830    S LAB("gr oupName")= $P(LR0,U,6 ),ACC=$P(I D,";",1,2)  ;accessio n#
  11831   "RTN","VPR DJ06",97,0 )
  11832    S LAB("gr oupUid")=$ $SETUID^VP RUTILS("ac cession",D FN,ACC)
  11833   "RTN","VPR DJ06",98,0 )
  11834    S X=$P(LR 0,U,14),FA C=$S(X:$$S TA^XUAF4(X )_U_$P($$N S^XUAF4(X) ,U),1:$$FA C^VPRD)
  11835   "RTN","VPR DJ06",99,0 )
  11836    D FACILIT Y^VPRUTILS (FAC,"LAB" )
  11837   "RTN","VPR DJ06",100, 0)
  11838    ; get res ults from  ^TMP
  11839   "RTN","VPR DJ06",101, 0)
  11840    S VPRN=0  F  S VPRN= $O(^TMP("L RRR",$J,DF N,VPRSUB,V PRIDT,VPRN )) Q:VPRN< 1  D
  11841   "RTN","VPR DJ06",102, 0)
  11842    . S X0=$G (^TMP("LRR R",$J,DFN, "MI",VPRID T,VPRN)),X 1=$P(X0,U) ,X2=$P(X0, U,2)
  11843   "RTN","VPR DJ06",103, 0)
  11844    . I X1="U RINE SCREE N" S LAB(" urineScree n")=X2 Q
  11845   "RTN","VPR DJ06",104, 0)
  11846    . ; X1="O RGANISM" S  LAB("orga nism")=$P( X2,";"),LA B("organis mQty")=$P( X2,";",2)
  11847   "RTN","VPR DJ06",105, 0)
  11848    . I X1="G RAM STAIN"  S LAB("gr amStain",V PRN,"resul t")=X2 Q
  11849   "RTN","VPR DJ06",106, 0)
  11850    . I X1="B acteriolog y Remark(s )" S LAB(" bactRemark s")=X2 Q
  11851   "RTN","VPR DJ06",107, 0)
  11852    ; get oth er results  from ^PXR MINDX
  11853   "RTN","VPR DJ06",108, 0)
  11854    S X=$O(^P XRMINDX(63 ,"PDI",DFN ,CDT,"M;T; 0")) I X?1 "M;T;"1.N  D
  11855   "RTN","VPR DJ06",109, 0)
  11856    . S IDX=$ O(^PXRMIND X(63,"PDI" ,DFN,CDT,X ,"")) K VP RM
  11857   "RTN","VPR DJ06",110, 0)
  11858    . D LRPXR M^LRPXAPI( .VPRM,IDX, X) Q:VPRM< 1
  11859   "RTN","VPR DJ06",111, 0)
  11860    . S LAB(" typeName") =$P(VPRM,U ,2)
  11861   "RTN","VPR DJ06",112, 0)
  11862    . S LAB(" typeCode") ="urn:va:i en:60:"_+V PRM_":"_+$ P(VPRM,U,7 )
  11863   "RTN","VPR DJ06",113, 0)
  11864    F VPRPX=" M;O;","M;A ;" D
  11865   "RTN","VPR DJ06",114, 0)
  11866    . S VPRIT M=VPRPX F   S VPRITM= $O(^PXRMIN DX(63,"PDI ",DFN,CDT, VPRITM)) Q :$E(VPRITM ,1,4)'=VPR PX  D
  11867   "RTN","VPR DJ06",115, 0)
  11868    .. S IDX= $O(^PXRMIN DX(63,"PDI ",DFN,CDT, VPRITM,"") ) K VPRM
  11869   "RTN","VPR DJ06",116, 0)
  11870    .. S DA=$ P(IDX,";", 5),FLD=$P( IDX,";",6)
  11871   "RTN","VPR DJ06",117, 0)
  11872    .. D LRPX RM^LRPXAPI (.VPRM,IDX ,VPRITM) Q :'$L($G(VP RM))
  11873   "RTN","VPR DJ06",118, 0)
  11874    .. I VPRP X["O" S LA B("organis ms",DA,"na me")=$P(VP RM,U,2),LA B("organis ms",DA,"qt y")=$P(VPR M,U,4) Q
  11875   "RTN","VPR DJ06",119, 0)
  11876    .. I VPRP X["A" D  Q
  11877   "RTN","VPR DJ06",120, 0)
  11878    ... S LAB ("organism s",DA,"dru gs",FLD,"n ame")=$P(V PRM,U,2)
  11879   "RTN","VPR DJ06",121, 0)
  11880    ... S LAB ("organism s",DA,"dru gs",FLD,"r esult")=$P (VPRM,U,3)
  11881   "RTN","VPR DJ06",122, 0)
  11882    ... S LAB ("organism s",DA,"dru gs",FLD,"i nterp")=$P (VPRM,U,4)
  11883   "RTN","VPR DJ06",123, 0)
  11884    ... S:$L( $P(VPRM,U, 5)) LAB("o rganisms", DA,"drugs" ,FLD,"rest rict")=$P( VPRM,U,5)
  11885   "RTN","VPR DJ06",124, 0)
  11886    ;
  11887   "RTN","VPR DJ06",125, 0)
  11888    S LAB("re sults",1," uid")=ACC
  11889   "RTN","VPR DJ06",126, 0)
  11890    S LAB("re sults",1," resultUid" )=$$SETUID ^VPRUTILS( "document" ,DFN,ACC)
  11891   "RTN","VPR DJ06",127, 0)
  11892    S LAB("re sults",1," localTitle ")="LR MIC ROBIOLOGY  REPORT"
  11893   "RTN","VPR DJ06",128, 0)
  11894    I $L($G(^ LR(LRDFN," MI",VPRIDT ,99))) S L AB("commen t")=^(99)
  11895   "RTN","VPR DJ06",129, 0)
  11896    D ADD^VPR DJ("LAB"," lab")
  11897   "RTN","VPR DJ06",130, 0)
  11898    Q
  11899   "RTN","VPR DJ06",131, 0)
  11900    ;
  11901   "RTN","VPR DJ06",132, 0)
  11902   ITEM() ; - - find ITE M string f rom ^PXRMI NDX [uses  LRDFN,ID,D FN,CDT]
  11903   "RTN","VPR DJ06",133, 0)
  11904    N ITM,IDX ,Y S Y=""
  11905   "RTN","VPR DJ06",134, 0)
  11906    S IDX=LRD FN_";"_ID, ITM="M"
  11907   "RTN","VPR DJ06",135, 0)
  11908    F  S ITM= $O(^PXRMIN DX(63,"PI" ,DFN,ITM))  Q:$E(ITM) '="M"  I $ D(^PXRMIND X(63,"PI", DFN,ITM,CD T,IDX)) S  Y=ITM Q
  11909   "RTN","VPR DJ06",136, 0)
  11910    Q Y
  11911   "RTN","VPR DJ06",137, 0)
  11912    ;
  11913   "RTN","VPR DJ06",138, 0)
  11914   AP ; -- pa thology ID  = VPRSUB; VPRIDT
  11915   "RTN","VPR DJ06",139, 0)
  11916    N LAB,LR0 ,X,I,NODE
  11917   "RTN","VPR DJ06",140, 0)
  11918    N $ES,$ET ,ERRPAT,ER RMSG
  11919   "RTN","VPR DJ06",141, 0)
  11920    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11921   "RTN","VPR DJ06",142, 0)
  11922    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he patholo gy domain"
  11923   "RTN","VPR DJ06",143, 0)
  11924    ;
  11925   "RTN","VPR DJ06",144, 0)
  11926    S LAB("lo calId")=ID ,LAB("orga nizerType" )="accessi on"
  11927   "RTN","VPR DJ06",145, 0)
  11928    S LAB("ui d")=$$SETU ID^VPRUTIL S("lab",DF N,ID)
  11929   "RTN","VPR DJ06",146, 0)
  11930    S LAB("ca tegoryCode ")="urn:va :lab-categ ory:"_VPRS UB
  11931   "RTN","VPR DJ06",147, 0)
  11932    S LAB("ca tegoryName ")=$S(VPRS UB="BB":"B lood Bank" ,VPRSUB="S P":"Surgic al Patholo gy",1:"Pat hology")
  11933   "RTN","VPR DJ06",148, 0)
  11934    S LAB("st atusCode") ="urn:va:l ab-status: completed" ,LAB("stat usName")=" completed"
  11935   "RTN","VPR DJ06",149, 0)
  11936    S CDT=999 9999-VPRID T,LAB("obs erved")=$$ DATE(CDT)
  11937   "RTN","VPR DJ06",150, 0)
  11938    S LR0=$G( ^LR(LRDFN, VPRSUB,VPR IDT,0))
  11939   "RTN","VPR DJ06",151, 0)
  11940    S LAB("re sulted")=$ $DATE($P(L R0,U,11)), LAB("group Name")=$P( LR0,U,6)
  11941   "RTN","VPR DJ06",152, 0)
  11942    S X="",I= 0 F  S I=$ O(^LR(LRDF N,VPRSUB,V PRIDT,.1,I )) Q:I<1   S X=X_$S($ L(X):", ", 1:"")_$P($ G(^(I,0)), U)
  11943   "RTN","VPR DJ06",153, 0)
  11944    S:$L(X) L AB("specim en")=X
  11945   "RTN","VPR DJ06",154, 0)
  11946    D FACILIT Y^VPRUTILS ($$FAC^VPR D,"LAB")
  11947   "RTN","VPR DJ06",155, 0)
  11948    S NODE=$S (VPRSUB="A U":$NA(^LR (LRDFN,101 )),1:$NA(^ LR(LRDFN,V PRSUB,VPRI DT,.05)))
  11949   "RTN","VPR DJ06",156, 0)
  11950    S I=0 F   S I=$O(@NO DE@(I)) Q: I<1  S X=+ $P($G(@NOD E@(I,0)),U ,2) I X D
  11951   "RTN","VPR DJ06",157, 0)
  11952    . N LT S  LT=$$GET1^ DIQ(8925,+ X_",",.01)  Q:$P(LT,"  ")="Adden dum"
  11953   "RTN","VPR DJ06",158, 0)
  11954    . S LAB(" results",I ,"uid")=LA B("uid")
  11955   "RTN","VPR DJ06",159, 0)
  11956    . S LAB(" results",I ,"resultUi d")=$$SETU ID^VPRUTIL S("documen t",DFN,X)
  11957   "RTN","VPR DJ06",160, 0)
  11958    . S LAB(" results",I ,"localTit le")=LT
  11959   "RTN","VPR DJ06",161, 0)
  11960    I '$O(LAB ("results" ,0)) D  ;n on-TIU rep orts
  11961   "RTN","VPR DJ06",162, 0)
  11962    . S LAB(" results",1 ,"uid")=LA B("uid")
  11963   "RTN","VPR DJ06",163, 0)
  11964    . S LAB(" results",1 ,"resultUi d")=$$SETU ID^VPRUTIL S("documen t",DFN,ID)
  11965   "RTN","VPR DJ06",164, 0)
  11966    . S LAB(" results",1 ,"localTit le")="LR " _$$NAME^VP RDLRA(VPRS UB)_" REPO RT"
  11967   "RTN","VPR DJ06",165, 0)
  11968    D ADD^VPR DJ("LAB"," lab")
  11969   "RTN","VPR DJ06",166, 0)
  11970    ;
  11971   "RTN","VPR DJ06",167, 0)
  11972   DATE(X) ;  -- strip o ff seconds , return J SON format
  11973   "RTN","VPR DJ06",168, 0)
  11974    N Y S Y=$ G(X)
  11975   "RTN","VPR DJ06",169, 0)
  11976    I $L($P(Y ,".",2))>4  S Y=$P(Y, ".")_"."_$ E($P(Y,"." ,2),1,4) ; strip seco nds
  11977   "RTN","VPR DJ06",170, 0)
  11978    S:Y Y=$$J SONDT^VPRU TILS(Y)
  11979   "RTN","VPR DJ06",171, 0)
  11980    Q Y
  11981   "RTN","VPR DJ07")
  11982   0^78^B2189 0653
  11983   "RTN","VPR DJ07",1,0)
  11984   VPRDJ07 ;S LC/MKB --  Radiology, Surgery ;6 /25/12  16 :11
  11985   "RTN","VPR DJ07",2,0)
  11986    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  11987   "RTN","VPR DJ07",3,0)
  11988    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  11989   "RTN","VPR DJ07",4,0)
  11990    ;
  11991   "RTN","VPR DJ07",5,0)
  11992    ; Externa l Referenc es           DBIA#
  11993   "RTN","VPR DJ07",6,0)
  11994    ; ------- ---------- --           -----
  11995   "RTN","VPR DJ07",7,0)
  11996    ; ^SC                             10040
  11997   "RTN","VPR DJ07",8,0)
  11998    ; ^VA(200                         10060
  11999   "RTN","VPR DJ07",9,0)
  12000    ; DIC                              2051
  12001   "RTN","VPR DJ07",10,0 )
  12002    ; DIQ                              2056
  12003   "RTN","VPR DJ07",11,0 )
  12004    ; RAO7PC1                    20 43,2265
  12005   "RTN","VPR DJ07",12,0 )
  12006    ; SROESTV                          3533
  12007   "RTN","VPR DJ07",13,0 )
  12008    ;
  12009   "RTN","VPR DJ07",14,0 )
  12010    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  12011   "RTN","VPR DJ07",15,0 )
  12012    ;
  12013   "RTN","VPR DJ07",16,0 )
  12014   RA1(ID) ;  -- radiolo gy exam ^T MP($J,"RAE 1",DFN,ID)
  12015   "RTN","VPR DJ07",17,0 )
  12016    N EXAM,X0 ,SET,PROC, DATE,LOC,X ,Y,IENS,ID 3,N
  12017   "RTN","VPR DJ07",18,0 )
  12018    N $ES,$ET ,ERRPAT,ER RMSG
  12019   "RTN","VPR DJ07",19,0 )
  12020    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12021   "RTN","VPR DJ07",20,0 )
  12022    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he radiolo gy domain"
  12023   "RTN","VPR DJ07",21,0 )
  12024    ;
  12025   "RTN","VPR DJ07",22,0 )
  12026    S X0=$G(^ TMP($J,"RA E1",DFN,ID )),SET=$G( ^(ID,"CPRS ")),PROC=$ P(X0,U) Q: X0=""
  12027   "RTN","VPR DJ07",23,0 )
  12028    S EXAM("l ocalId")=I D,EXAM("ui d")=$$SETU ID^VPRUTIL S("image", DFN,ID)
  12029   "RTN","VPR DJ07",24,0 )
  12030    S EXAM("n ame")=PROC ,EXAM("cas e")=$P(X0, U,2),EXAM( "category" )="RA"
  12031   "RTN","VPR DJ07",25,0 )
  12032    S DATE=99 99999.9999 -+ID,EXAM( "dateTime" )=$$JSONDT ^VPRUTILS( DATE)
  12033   "RTN","VPR DJ07",26,0 )
  12034    I $P(X0,U ,5) D  ;re port exist s
  12035   "RTN","VPR DJ07",27,0 )
  12036    . N NM S  NM=$S(+SET =2:$P(SET, U,2),1:PRO C) ;2 = sh ared repor t
  12037   "RTN","VPR DJ07",28,0 )
  12038    . S EXAM( "results", 1,"uid")=$ $SETUID^VP RUTILS("do cument",DF N,ID)
  12039   "RTN","VPR DJ07",29,0 )
  12040    . S EXAM( "results", 1,"localTi tle")=NM
  12041   "RTN","VPR DJ07",30,0 )
  12042    . S EXAM( "verified" )=$S($E($P (X0,U,3))= "V":"true" ,1:"false" )
  12043   "RTN","VPR DJ07",31,0 )
  12044    S:$L($P(X 0,U,6)) EX AM("status Name")=$P( $P(X0,U,6) ,"~",2)
  12045   "RTN","VPR DJ07",32,0 )
  12046    S X=$P(X0 ,U,7),LOC= "" I $L(X)  D
  12047   "RTN","VPR DJ07",33,0 )
  12048    . S EXAM( "imageLoca tion")=X,E XAM("locat ionName")= X
  12049   "RTN","VPR DJ07",34,0 )
  12050    . S LOC=+ $O(^SC("B" ,X,0))
  12051   "RTN","VPR DJ07",35,0 )
  12052    . S EXAM( "locationU id")=$$SET UID^VPRUTI LS("locati on",,LOC)
  12053   "RTN","VPR DJ07",36,0 )
  12054    S X=$$FAC ^VPRD(LOC)  D FACILIT Y^VPRUTILS (X,"EXAM")
  12055   "RTN","VPR DJ07",37,0 )
  12056    I $L($P(X 0,U,8)) S  X=$P($P(X0 ,U,8),"~", 2),EXAM("i magingType Uid")=$$SE TVURN^VPRU TILS("imag ing-Type", X)
  12057   "RTN","VPR DJ07",38,0 )
  12058    S X=$P(X0 ,U,10) I X  D
  12059   "RTN","VPR DJ07",39,0 )
  12060    . N CPT S  CPT=$$CPT ^VPRDRA(X)
  12061   "RTN","VPR DJ07",40,0 )
  12062    . S (EXAM ("typeName "),EXAM("s ummary"))= $P(CPT,U,2 )
  12063   "RTN","VPR DJ07",41,0 )
  12064    . ;I $D(^ TMP($J,"RA E1",DFN,ID ,"CMOD"))  M EXAM("mo difier")=^ ("CMOD")
  12065   "RTN","VPR DJ07",42,0 )
  12066    I $P(X0,U ,11) D
  12067   "RTN","VPR DJ07",43,0 )
  12068    . S EXAM( "orderUid" )=$$SETUID ^VPRUTILS( "order",DF N,+$P(X0,U ,11))
  12069   "RTN","VPR DJ07",44,0 )
  12070    . S EXAM( "orderName ")=$S($L(S ET):$P(SET ,U,2),1:PR OC)
  12071   "RTN","VPR DJ07",45,0 )
  12072    S EXAM("h asImages") =$S($P(X0, U,12)="Y": "true",1:" false")
  12073   "RTN","VPR DJ07",46,0 )
  12074    I $P(X0,U ,4)="Y"!($ P(X0,U,9)= "Y") S EXA M("interpr etation")= "ABNORMAL"
  12075   "RTN","VPR DJ07",47,0 )
  12076    S IENS=$P (ID,"-",2) _","_+ID_" ,"_DFN_","
  12077   "RTN","VPR DJ07",48,0 )
  12078    S X=$$GET 1^DIQ(70.0 3,IENS,27, "I") I X D
  12079   "RTN","VPR DJ07",49,0 )
  12080    . S EXAM( "encounter Uid")=$$SE TUID^VPRUT ILS("visit ",DFN,+X)
  12081   "RTN","VPR DJ07",50,0 )
  12082    . S EXAM( "encounter Name")=$$N AME^VPRDJ0 4(+X)
  12083   "RTN","VPR DJ07",51,0 )
  12084    S ID3=DFN _U_$TR(ID, "-","^") D  EN3^RAO7P C1(ID3) D   ;get addi tional val ues
  12085   "RTN","VPR DJ07",52,0 )
  12086    . S X=+$G (^TMP($J," RAE2",DFN, +$P(ID3,U, 3),PROC,"P ")) Q:'X
  12087   "RTN","VPR DJ07",53,0 )
  12088    . S EXAM( "providers ",1,"provi derUid")=$ $SETUID^VP RUTILS("us er",,X)
  12089   "RTN","VPR DJ07",54,0 )
  12090    . S EXAM( "providers ",1,"provi derName")= $P($G(^VA( 200,X,0)), U),N=0
  12091   "RTN","VPR DJ07",55,0 )
  12092    . F  S N= $O(^TMP($J ,"RAE2",DF N,+$P(ID3, U,3),PROC, "D",N)) Q: N<1  S X=$ G(^(N)) D
  12093   "RTN","VPR DJ07",56,0 )
  12094    .. S EXAM ("diagnosi s",N,"code ")=X
  12095   "RTN","VPR DJ07",57,0 )
  12096    .. S:N=1  EXAM("diag nosis",N," primary")= "true"
  12097   "RTN","VPR DJ07",58,0 )
  12098    .. N EXP  S EXP=$$LE X(X) S:EXP  EXAM("dia gnosis",N, "lexicon") =X
  12099   "RTN","VPR DJ07",59,0 )
  12100    . K ^TMP( $J,"RAE2", DFN)
  12101   "RTN","VPR DJ07",60,0 )
  12102    S EXAM("k ind")="Ima ging"
  12103   "RTN","VPR DJ07",61,0 )
  12104    D ADD^VPR DJ("EXAM", "image")
  12105   "RTN","VPR DJ07",62,0 )
  12106    Q
  12107   "RTN","VPR DJ07",63,0 )
  12108    ;
  12109   "RTN","VPR DJ07",64,0 )
  12110   LEX(X) ; - - Return L exicon ptr  for a Dx  Code
  12111   "RTN","VPR DJ07",65,0 )
  12112    N X,Y,DIC ,LEX
  12113   "RTN","VPR DJ07",66,0 )
  12114    S DIC=78. 3,DIC(0)=" BFOXZ" D ^ DIC
  12115   "RTN","VPR DJ07",67,0 )
  12116    S LEX=$P( $G(Y(0)),U ,6)
  12117   "RTN","VPR DJ07",68,0 )
  12118    Q LEX
  12119   "RTN","VPR DJ07",69,0 )
  12120    ;
  12121   "RTN","VPR DJ07",70,0 )
  12122   SR1(ID) ;  -- surgery
  12123   "RTN","VPR DJ07",71,0 )
  12124    N SURG,VP RX,VPRY,X, Y,I
  12125   "RTN","VPR DJ07",72,0 )
  12126    D ONE^SRO ESTV("VPRY ",ID) S VP RX=$G(VPRY (ID)) Q:VP RX=""
  12127   "RTN","VPR DJ07",73,0 )
  12128    N $ES,$ET ,ERRPAT,ER RMSG
  12129   "RTN","VPR DJ07",74,0 )
  12130    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12131   "RTN","VPR DJ07",75,0 )
  12132    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he surgery  domain"
  12133   "RTN","VPR DJ07",76,0 )
  12134    ;
  12135   "RTN","VPR DJ07",77,0 )
  12136    S SURG("l ocalId")=I D,SURG("ui d")=$$SETU ID^VPRUTIL S("surgery ",DFN,ID)
  12137   "RTN","VPR DJ07",78,0 )
  12138    S X=$P(VP RX,U,2),SU RG("status Name")="CO MPLETED"
  12139   "RTN","VPR DJ07",79,0 )
  12140    I X?1"* A borted * " .E S X=$E( X,13,999), SURG("stat usName")=" ABORTED"
  12141   "RTN","VPR DJ07",80,0 )
  12142    S (SURG(" typeName") ,SURG("sum mary"))=X
  12143   "RTN","VPR DJ07",81,0 )
  12144    S SURG("d ateTime")= $$JSONDT^V PRUTILS($P (VPRX,U,3) )
  12145   "RTN","VPR DJ07",82,0 )
  12146    S X=$P(VP RX,U,4) I  X D
  12147   "RTN","VPR DJ07",83,0 )
  12148    . S SURG( "providers ",1,"provi derUid")=$ $SETUID^VP RUTILS("us er",,+X)
  12149   "RTN","VPR DJ07",84,0 )
  12150    . S SURG( "providers ",1,"provi derName")= $P(X,";",2 )
  12151   "RTN","VPR DJ07",85,0 )
  12152    S X=$$GET 1^DIQ(130, ID_",",50, "I"),X=$$F AC^VPRD(X)
  12153   "RTN","VPR DJ07",86,0 )
  12154    D FACILIT Y^VPRUTILS (X,"SURG")
  12155   "RTN","VPR DJ07",87,0 )
  12156    S X=$$GET 1^DIQ(130, ID_",",.01 5,"I") I X  D
  12157   "RTN","VPR DJ07",88,0 )
  12158    . S SURG( "encounter Uid")=$$SE TUID^VPRUT ILS("visit ",DFN,+X)
  12159   "RTN","VPR DJ07",89,0 )
  12160    . S SURG( "encounter Name")=$$N AME^VPRDJ0 4(+X)
  12161   "RTN","VPR DJ07",90,0 )
  12162    S X=$$GET 1^DIQ(136, ID_",",.02 ,"I") I X  D
  12163   "RTN","VPR DJ07",91,0 )
  12164    . S X=$$C PT^VPRDSR( X)
  12165   "RTN","VPR DJ07",92,0 )
  12166    . S (SURG ("typeName "),SURG("s ummary"))= $P(X,U,2)
  12167   "RTN","VPR DJ07",93,0 )
  12168    . S SURG( "typeCode" )=$$SETNCS ^VPRUTILS( "cpt",+X)
  12169   "RTN","VPR DJ07",94,0 )
  12170    S I=0 F   S I=$O(VPR Y(ID,I)) Q :I<1  S X= $G(VPRY(ID ,I)) I X D
  12171   "RTN","VPR DJ07",95,0 )
  12172    . N LT S  LT=$P(X,U, 2) Q:$P(LT ," ")="Add endum"
  12173   "RTN","VPR DJ07",96,0 )
  12174    . S SURG( "results", I,"uid")=$ $SETUID^VP RUTILS("do cument",DF N,+X)
  12175   "RTN","VPR DJ07",97,0 )
  12176    . S SURG( "results", I,"localTi tle")=LT
  12177   "RTN","VPR DJ07",98,0 )
  12178    S SURG("k ind")="Sur gery",SURG ("category ")="SR"
  12179   "RTN","VPR DJ07",99,0 )
  12180    K ^TMP("T IULIST",$J )
  12181   "RTN","VPR DJ07",100, 0)
  12182    D ADD^VPR DJ("SURG", "surgery")
  12183   "RTN","VPR DJ07",101, 0)
  12184    Q
  12185   "RTN","VPR DJ08")
  12186   0^79^B6915 4613
  12187   "RTN","VPR DJ08",1,0)
  12188   VPRDJ08 ;S LC/MKB --  Documents  ;6/25/12   16:11
  12189   "RTN","VPR DJ08",2,0)
  12190    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  12191   "RTN","VPR DJ08",3,0)
  12192    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  12193   "RTN","VPR DJ08",4,0)
  12194    ;
  12195   "RTN","VPR DJ08",5,0)
  12196    ; Externa l Referenc es           DBIA#
  12197   "RTN","VPR DJ08",6,0)
  12198    ; ------- ---------- --           -----
  12199   "RTN","VPR DJ08",7,0)
  12200    ; ^SC                             10040
  12201   "RTN","VPR DJ08",8,0)
  12202    ; ^TIU(89 25.1               23 21,5677
  12203   "RTN","VPR DJ08",9,0)
  12204    ; ^TIU(89 26.1                     5678
  12205   "RTN","VPR DJ08",10,0 )
  12206    ; ^VA(200                         10060
  12207   "RTN","VPR DJ08",11,0 )
  12208    ; DIQ                              2056
  12209   "RTN","VPR DJ08",12,0 )
  12210    ; RAO7PC1                          2043
  12211   "RTN","VPR DJ08",13,0 )
  12212    ; TIUCNSL T                        5546
  12213   "RTN","VPR DJ08",14,0 )
  12214    ; TIUCP                            3568
  12215   "RTN","VPR DJ08",15,0 )
  12216    ; TIULQ                            2693
  12217   "RTN","VPR DJ08",16,0 )
  12218    ; TIULX                            3058
  12219   "RTN","VPR DJ08",17,0 )
  12220    ; TIUSROI                          5676
  12221   "RTN","VPR DJ08",18,0 )
  12222    ; TIUSRVL O                  28 34,2865
  12223   "RTN","VPR DJ08",19,0 )
  12224    ; XLFSTR                          10104
  12225   "RTN","VPR DJ08",20,0 )
  12226    ;
  12227   "RTN","VPR DJ08",21,0 )
  12228    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  12229   "RTN","VPR DJ08",22,0 )
  12230    ;
  12231   "RTN","VPR DJ08",23,0 )
  12232   TIU1(ID) ;  -- docume nt
  12233   "RTN","VPR DJ08",24,0 )
  12234    I ID[";"  D   Q
  12235   "RTN","VPR DJ08",25,0 )
  12236    . I ID D  EN1($$CP1^ VPRDJ08A(D FN,ID),"CP ") Q  ;CP
  12237   "RTN","VPR DJ08",26,0 )
  12238    . D EN1($ $LR1^VPRDJ 08A(DFN,ID ),"LR") Q        ;Lab
  12239   "RTN","VPR DJ08",27,0 )
  12240    I ID["-"  D  Q                                   ;Rad iology
  12241   "RTN","VPR DJ08",28,0 )
  12242    . S (BEG, END)=99999 99.9999-+I D D EN1^RA O7PC1(DFN, BEG,END,"9 9P")
  12243   "RTN","VPR DJ08",29,0 )
  12244    . Q:'$D(^ TMP($J,"RA E1",DFN,ID ))               ;del eted
  12245   "RTN","VPR DJ08",30,0 )
  12246    . D EN1($ $RA1^VPRDJ 08A(DFN,ID ),"RA") K  ^TMP($J,"R AE1")
  12247   "RTN","VPR DJ08",31,0 )
  12248    D EN1(ID, 38)
  12249   "RTN","VPR DJ08",32,0 )
  12250    Q
  12251   "RTN","VPR DJ08",33,0 )
  12252    ;
  12253   "RTN","VPR DJ08",34,0 )
  12254   EN1(VPRX,T IU) ; -- d ocument
  12255   "RTN","VPR DJ08",35,0 )
  12256    ;  Expect s DFN, VPR X=IEN^$$RE SOLVE^TIUS RVLO(IEN)  or equival ent
  12257   "RTN","VPR DJ08",36,0 )
  12258    ;           TIU = do cument cla ss#, or co de (CP, RA , LR) if n on-TIU
  12259   "RTN","VPR DJ08",37,0 )
  12260    N DOC,IEN ,X,VPRTIU, ES,I,TEXT, SUB,VPRY,E RR
  12261   "RTN","VPR DJ08",38,0 )
  12262    S IEN=$P( $G(VPRX),U ),TIU=$G(T IU) Q:IEN= ""  ;inval id ien
  12263   "RTN","VPR DJ08",39,0 )
  12264    ;
  12265   "RTN","VPR DJ08",40,0 )
  12266    I +VPRX=V PRX,TIU D   ;get TIU  data strin g, if need ed
  12267   "RTN","VPR DJ08",41,0 )
  12268    . N SHOWA DD,DA S SH OWADD=1,DA =+VPRX
  12269   "RTN","VPR DJ08",42,0 )
  12270    . S VPRX= DA_U_$$RES OLVE^TIUSR VLO(DA)
  12271   "RTN","VPR DJ08",43,0 )
  12272    Q:"UNKNOW N"[$P($G(V PRX),U,2)   ;null or  invalid
  12273   "RTN","VPR DJ08",44,0 )
  12274    N $ES,$ET ,ERRPAT,ER RMSG
  12275   "RTN","VPR DJ08",45,0 )
  12276    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12277   "RTN","VPR DJ08",46,0 )
  12278    S ERRMSG= "A problem  occurred  converting  record "_ IEN_" for  the docume nt domain"
  12279   "RTN","VPR DJ08",47,0 )
  12280    S DOC("lo calId")=IE N,DOC("uid ")=$$SETUI D^VPRUTILS ("document ",DFN,IEN)
  12281   "RTN","VPR DJ08",48,0 )
  12282    S DOC("lo calTitle") =$P(VPRX,U ,2)
  12283   "RTN","VPR DJ08",49,0 )
  12284    S DOC("re ferenceDat eTime")=$$ JSONDT^VPR UTILS($P(V PRX,U,3))
  12285   "RTN","VPR DJ08",50,0 )
  12286    S X=$P(VP RX,U,6) D   ;S:$L(X)  DOC("locat ion")=X
  12287   "RTN","VPR DJ08",51,0 )
  12288    . N LOC,F AC S LOC=$ S($L(X):+$ O(^SC("B", X,0)),1:0)
  12289   "RTN","VPR DJ08",52,0 )
  12290    . S X=$$F AC^VPRD(LO C)
  12291   "RTN","VPR DJ08",53,0 )
  12292    . S DOC(" facilityCo de")=$P(X, U),DOC("fa cilityName ")=$P(X,U, 2)
  12293   "RTN","VPR DJ08",54,0 )
  12294    S X=$P(VP RX,U,7) I  $L(X) D
  12295   "RTN","VPR DJ08",55,0 )
  12296    . N SUB S  DOC("stat usName")=X ,SUB=$$FIN D1^DIC(893 0.6,,"QX", X)
  12297   "RTN","VPR DJ08",56,0 )
  12298    . S:SUB>0  DOC("stat usUid")=$$ SETUID^VPR UTILS("doc -status",, SUB)
  12299   "RTN","VPR DJ08",57,0 )
  12300    S:$P(VPRX ,U,11) DOC ("images") =+$P(VPRX, U,11)
  12301   "RTN","VPR DJ08",58,0 )
  12302    S:$L($P(V PRX,U,12))  DOC("subj ect")=$P(V PRX,U,12)
  12303   "RTN","VPR DJ08",59,0 )
  12304    I $P(VPRX ,U,14)>5 S  DOC("pare ntUid")=$$ SETUID^VPR UTILS("doc ument",DFN ,$P(VPRX,U ,14)) ;ID  notes
  12305   "RTN","VPR DJ08",60,0 )
  12306   A ; nation al title
  12307   "RTN","VPR DJ08",61,0 )
  12308    S X=$S(TI U:$$GET1^D IQ(8925,IE N_",",".01 :1501","I" ),1:$P(VPR X,U,10))
  12309   "RTN","VPR DJ08",62,0 )
  12310    I X D  ;N ational Ti tle + attr ibutes
  12311   "RTN","VPR DJ08",63,0 )
  12312    . N IENS, TIU,Y,FNUM ,NAME
  12313   "RTN","VPR DJ08",64,0 )
  12314    . S IENS= X_"," D GE TS^DIQ(892 6.1,IENS," *","IE","T IU")
  12315   "RTN","VPR DJ08",65,0 )
  12316    . S DOC(" nationalTi tle","vuid ")="urn:va :vuid:"_$G (TIU(8926. 1,IENS,99. 99,"E"))
  12317   "RTN","VPR DJ08",66,0 )
  12318    . S DOC(" nationalTi tle","titl e")=$G(TIU (8926.1,IE NS,.01,"E" ))
  12319   "RTN","VPR DJ08",67,0 )
  12320    . F I=".0 4^Subject^ 2",".05^Ro le^3",".06 ^Setting^4 ",".07^Ser vice^5",". 08^Type^6"  D
  12321   "RTN","VPR DJ08",68,0 )
  12322    .. S Y=+$ G(TIU(8926 .1,IENS,+I ,"I")) Q:Y '>0
  12323   "RTN","VPR DJ08",69,0 )
  12324    .. S FNUM ="8926."_+ $P(I,U,3), NAME=$$LOW ^XLFSTR($P (I,U,2))
  12325   "RTN","VPR DJ08",70,0 )
  12326    .. S DOC( "nationalT itle"_$P(I ,U,2),"vui d")="urn:v a:vuid:"_$ $VUID^VPRD (Y,FNUM)
  12327   "RTN","VPR DJ08",71,0 )
  12328    .. S DOC( "nationalT itle"_$P(I ,U,2),NAME )=$G(TIU(8 926.1,IENS ,+I,"E"))
  12329   "RTN","VPR DJ08",72,0 )
  12330   B ; other  TIU data
  12331   "RTN","VPR DJ08",73,0 )
  12332    D:TIU EXT RACT^TIULQ (IEN,"VPRT IU",,".01: .05;.09;12 01;1202;12 04;1208;12 09;1301;13 02;1501:15 08",,1,,1)  ;".01:.04 ;1501:1508 ")
  12333   "RTN","VPR DJ08",74,0 )
  12334    S X=$G(VP RTIU(IEN,. 01,"I")) S :X DOC("do cDefUid")= $$SETUID^V PRUTILS("d oc-def",,X )
  12335   "RTN","VPR DJ08",75,0 )
  12336    S X=$G(VP RTIU(IEN,1 201,"I"))  S:X DOC("e ntered")=$ $JSONDT^VP RUTILS(X)
  12337   "RTN","VPR DJ08",76,0 )
  12338    S X=$G(VP RTIU(IEN,. 09,"E")) S :$L(X) DOC ("urgency" )=X
  12339   "RTN","VPR DJ08",77,0 )
  12340    S X=TIU I  TIU S X=+ $G(VPRTIU( IEN,.01,"I ")),X=$$CA TG^VPRDTIU (X) ;2U ty pe code
  12341   "RTN","VPR DJ08",78,0 )
  12342    S DOC("do cumentType Code")=X,D OC("docume ntTypeName ")=$$TYPE( X)
  12343   "RTN","VPR DJ08",79,0 )
  12344    S DOC("do cumentClas s")=$S(X=" LR":"LR LA BORATORY R EPORTS",X= "SR":"SURG ICAL REPOR TS",X="CP" :"CLINICAL  PROCEDURE S",X="RA": "RADIOLOGY  REPORTS", X="DS":"DI SCHARGE SU MMARY",1:" PROGRESS N OTES")
  12345   "RTN","VPR DJ08",80,0 )
  12346    S X=$S(TI U:$G(VPRTI U(IEN,.03, "I")),1:$P (VPRX,U,8) )
  12347   "RTN","VPR DJ08",81,0 )
  12348    S:X DOC(" encounterU id")=$$SET UID^VPRUTI LS("visit" ,DFN,X),DO C("encount erName")=$ $NAME^VPRD J04(X)
  12349   "RTN","VPR DJ08",82,0 )
  12350   C ; text b locks, sig natures
  12351   "RTN","VPR DJ08",83,0 )
  12352    N VPRT,VP RA,VPRADD
  12353   "RTN","VPR DJ08",84,0 )
  12354    S DOC("te xt",1,"dat eTime")=DO C("referen ceDateTime ")
  12355   "RTN","VPR DJ08",85,0 )
  12356    S DOC("te xt",1,"sta tus")=$G(D OC("status Name"))
  12357   "RTN","VPR DJ08",86,0 )
  12358    S DOC("te xt",1,"uid ")=DOC("ui d")
  12359   "RTN","VPR DJ08",87,0 )
  12360    S VPRT=1, X=$P(VPRX, U,5),I=0
  12361   "RTN","VPR DJ08",88,0 )
  12362    I X D USE R(.I,+X,$P (X,";",3), "AU")    ; author
  12363   "RTN","VPR DJ08",89,0 )
  12364    M ES=VPRT IU(IEN) S  X=$P(VPRX, "//",2) ;n on-TIU, pu t into ES  for use:
  12365   "RTN","VPR DJ08",90,0 )
  12366    I $L(X) S  ES(1502," I")=+X,ES( 1502,"E")= $P(X,";",2 ),ES(1501, "I")=$P(X, ";",3)
  12367   "RTN","VPR DJ08",91,0 )
  12368    I $G(ES(1 501,"I"))  D USER(.I, ES(1502,"I "),ES(1502 ,"E"),"S", ES(1501,"I ")) ;signe r
  12369   "RTN","VPR DJ08",92,0 )
  12370    I $G(ES(1 507,"I"))  D USER(.I, ES(1508,"I "),ES(1508 ,"E"),"C", ES(1507,"I ")) ;cosig ner
  12371   "RTN","VPR DJ08",93,0 )
  12372    I $G(ES(1 204,"I"))  D USER(.I, ES(1204,"I "),ES(1204 ,"E"),"ES" )   ;expec ted signer
  12373   "RTN","VPR DJ08",94,0 )
  12374    I $G(ES(1 208,"I"))  D USER(.I, ES(1208,"I "),ES(1208 ,"E"),"EC" )   ;expec ted cosign er
  12375   "RTN","VPR DJ08",95,0 )
  12376    I $G(ES(1 302,"I"))  D USER(.I, ES(1302,"I "),ES(1302 ,"E"),"E")     ;enter ed
  12377   "RTN","VPR DJ08",96,0 )
  12378    I $G(ES(1 209,"I"))  D USER(.I, ES(1209,"I "),ES(1209 ,"E"),"ATT ")  ;atten ding
  12379   "RTN","VPR DJ08",97,0 )
  12380    I $G(VPRT EXT) D
  12381   "RTN","VPR DJ08",98,0 )
  12382    . S X=$S( TIU:$NA(VP RTIU(IEN," TEXT")),1: $NA(^TMP(" VPRTEXT",$ J,IEN)))
  12383   "RTN","VPR DJ08",99,0 )
  12384    . K ^TMP( $J,"VPR TI U TEXT")
  12385   "RTN","VPR DJ08",100, 0)
  12386    . D SETTE XT^VPRUTIL S(X,$NA(^T MP($J,"VPR  TIU TEXT" )))
  12387   "RTN","VPR DJ08",101, 0)
  12388    . M DOC(" text",1,"c ontent","\ ")=^TMP($J ,"VPR TIU  TEXT")
  12389   "RTN","VPR DJ08",102, 0)
  12390   D ; addend a
  12391   "RTN","VPR DJ08",103, 0)
  12392    S VPRA=0  F  S VPRA= $O(VPRTIU( IEN,"ZADD" ,VPRA)) Q: VPRA<1  D
  12393   "RTN","VPR DJ08",104, 0)
  12394    . S VPRT= VPRT+1,I=0  K VPRADD  M VPRADD=V PRTIU(IEN, "ZADD",VPR A)
  12395   "RTN","VPR DJ08",105, 0)
  12396    . S DOC(" text",VPRT ,"status") =$G(VPRADD (.05,"E"))
  12397   "RTN","VPR DJ08",106, 0)
  12398    . S DOC(" text",VPRT ,"uid")=$$ SETUID^VPR UTILS("doc ument",DFN ,VPRA)
  12399   "RTN","VPR DJ08",107, 0)
  12400    . S DOC(" text",VPRT ,"dateTime ")=$$JSOND T^VPRUTILS ($G(VPRADD (1301,"I") ))
  12401   "RTN","VPR DJ08",108, 0)
  12402    . I $G(VP RADD(1302, "I")) D US ER(.I,VPRA DD(1302,"I "),VPRADD( 1302,"E"), "E")
  12403   "RTN","VPR DJ08",109, 0)
  12404    . I $G(VP RADD(1202, "I")) D US ER(.I,VPRA DD(1202,"I "),VPRADD( 1202,"E"), "AU")
  12405   "RTN","VPR DJ08",110, 0)
  12406    . I $G(VP RADD(1501, "I")) D US ER(.I,VPRA DD(1502,"I "),VPRADD( 1502,"E"), "S",VPRADD (1501,"I") )
  12407   "RTN","VPR DJ08",111, 0)
  12408    . I $G(VP RADD(1507, "I")) D US ER(.I,VPRA DD(1508,"I "),VPRADD( 1508,"E"), "C",VPRADD (1507,"I") )
  12409   "RTN","VPR DJ08",112, 0)
  12410    . I $G(VP RADD(1204, "I")) D US ER(.I,VPRA DD(1204,"I "),VPRADD( 1204,"E"), "ES")
  12411   "RTN","VPR DJ08",113, 0)
  12412    . I $G(VP RADD(1208, "I")) D US ER(.I,VPRA DD(1208,"I "),VPRADD( 1208,"E"), "EC")
  12413   "RTN","VPR DJ08",114, 0)
  12414    . I $G(VP RADD(1209, "I")) D US ER(.I,VPRA DD(1209,"I "),VPRADD( 1209,"E"), "ATT")
  12415   "RTN","VPR DJ08",115, 0)
  12416    . Q:'$G(V PRTEXT)  K  ^TMP($J," VPR TIU TE XT")
  12417   "RTN","VPR DJ08",116, 0)
  12418    . S X=$NA (VPRTIU(IE N,"ZADD",V PRA,"TEXT" ))
  12419   "RTN","VPR DJ08",117, 0)
  12420    . D SETTE XT^VPRUTIL S(X,$NA(^T MP($J,"VPR  TIU TEXT" )))
  12421   "RTN","VPR DJ08",118, 0)
  12422    . M DOC(" text",VPRT ,"content" ,"\")=^TMP ($J,"VPR T IU TEXT")
  12423   "RTN","VPR DJ08",119, 0)
  12424   ENQ ; end
  12425   "RTN","VPR DJ08",120, 0)
  12426    K ^TMP($J ,"VPR TIU  TEXT")
  12427   "RTN","VPR DJ08",121, 0)
  12428    D ADD^VPR DJ("DOC"," document")
  12429   "RTN","VPR DJ08",122, 0)
  12430    Q
  12431   "RTN","VPR DJ08",123, 0)
  12432    ;
  12433   "RTN","VPR DJ08",124, 0)
  12434   USER(N,IEN ,NAME,ROLE ,DATE) ; - - set auth or, signer (s)
  12435   "RTN","VPR DJ08",125, 0)
  12436    Q:'$G(IEN )  S N=+$G (N)+1
  12437   "RTN","VPR DJ08",126, 0)
  12438    S DOC("te xt",VPRT," clinicians ",N,"uid") =$$SETUID^ VPRUTILS(" user",,IEN )
  12439   "RTN","VPR DJ08",127, 0)
  12440    S DOC("te xt",VPRT," clinicians ",N,"name" )=$S($L($G (NAME)):NA ME,1:$P($G (^VA(200,I EN,0)),U))
  12441   "RTN","VPR DJ08",128, 0)
  12442    S DOC("te xt",VPRT," clinicians ",N,"role" )=$G(ROLE)
  12443   "RTN","VPR DJ08",129, 0)
  12444    Q:'$G(DAT E)  ;not c o/signed
  12445   "RTN","VPR DJ08",130, 0)
  12446    S DOC("te xt",VPRT," clinicians ",N,"signe dDateTime" )=$$JSONDT ^VPRUTILS( DATE)
  12447   "RTN","VPR DJ08",131, 0)
  12448    S DOC("te xt",VPRT," clinicians ",N,"signa ture")=$$S IG^VPRDTIU (IEN)
  12449   "RTN","VPR DJ08",132, 0)
  12450    Q
  12451   "RTN","VPR DJ08",133, 0)
  12452    ;
  12453   "RTN","VPR DJ08",134, 0)
  12454    ; ------- ----- Get/ apply sear ch criteri a -------- ----
  12455   "RTN","VPR DJ08",135, 0)
  12456    ;                [fr om DOCUMEN T^VPRDJ0]
  12457   "RTN","VPR DJ08",136, 0)
  12458    ;
  12459   "RTN","VPR DJ08",137, 0)
  12460   SETUP ; --  convert F ILTER("att ribute") =  value to  TIU criter ia
  12461   "RTN","VPR DJ08",138, 0)
  12462    ; Expects : FILTER(" category")  = code (s ee $$CATG)
  12463   "RTN","VPR DJ08",139, 0)
  12464    ;           FILTER(" status")    = 'signed ','unsigne d','all'
  12465   "RTN","VPR DJ08",140, 0)
  12466    ; Returns : CLASS,[S UBCLASS,ST ATUS]
  12467   "RTN","VPR DJ08",141, 0)
  12468    ;
  12469   "RTN","VPR DJ08",142, 0)
  12470    N TYPE,ST S,CP
  12471   "RTN","VPR DJ08",143, 0)
  12472    S TYPE=$$ UP^XLFSTR( $G(FILTER( "category" )))
  12473   "RTN","VPR DJ08",144, 0)
  12474    S CLASS=0 ,(SUBCLASS ,STATUS)=" "
  12475   "RTN","VPR DJ08",145, 0)
  12476    ;
  12477   "RTN","VPR DJ08",146, 0)
  12478    ; status  [default=' signed']
  12479   "RTN","VPR DJ08",147, 0)
  12480    S STS=$$L OW^XLFSTR( $G(FILTER( "status")) )
  12481   "RTN","VPR DJ08",148, 0)
  12482    S STATUS= $S(STS?1"u nsig".E:2, STS="all": "5^2",1:5)      ;TIUS RVLO statu ses
  12483   "RTN","VPR DJ08",149, 0)
  12484    ;
  12485   "RTN","VPR DJ08",150, 0)
  12486    ; all doc uments
  12487   "RTN","VPR DJ08",151, 0)
  12488    S:TYPE=""  TYPE="ALL "
  12489   "RTN","VPR DJ08",152, 0)
  12490    I TYPE="A LL" S CLAS S="3^244^" _+$$CLASS^ TIUSROI("S URGICAL RE PORTS")_"^ CP^LR^RA"  Q
  12491   "RTN","VPR DJ08",153, 0)
  12492    ;
  12493   "RTN","VPR DJ08",154, 0)
  12494    I TYPE="P N"   S CLA SS=3 Q                               ;Progr ess Notes
  12495   "RTN","VPR DJ08",155, 0)
  12496    I TYPE="C R"   S CLA SS=3,SUBCL ASS=$$CLAS S^TIUCNSLT  Q  ;Consu lts
  12497   "RTN","VPR DJ08",156, 0)
  12498    I TYPE="C WAD" S CLA SS=3,SUBCL ASS="25^27 ^30^31" Q      ;CWAD
  12499   "RTN","VPR DJ08",157, 0)
  12500    I TYPE="C "    S CLA SS=3,SUBCL ASS=30 Q                  ;Crisi s Note
  12501   "RTN","VPR DJ08",158, 0)
  12502    I TYPE="W "    S CLA SS=3,SUBCL ASS=31 Q                  ;Clini cal Warnin g
  12503   "RTN","VPR DJ08",159, 0)
  12504    I TYPE="A "    S CLA SS=3,SUBCL ASS=25 Q                  ;Aller gy Note
  12505   "RTN","VPR DJ08",160, 0)
  12506    I TYPE="D "    S CLA SS=3,SUBCL ASS=27 Q                  ;Advan ce Directi ve
  12507   "RTN","VPR DJ08",161, 0)
  12508    ;
  12509   "RTN","VPR DJ08",162, 0)
  12510    I TYPE="D S"   S CLA SS=244 Q                             ;Disch arge Summa ry
  12511   "RTN","VPR DJ08",163, 0)
  12512    ;
  12513   "RTN","VPR DJ08",164, 0)
  12514    I TYPE="S R"   S CLA SS=$$CLASS ^TIUSROI(" SURGICAL R EPORTS") Q
  12515   "RTN","VPR DJ08",165, 0)
  12516    I TYPE="C P" D  Q                                         ;Clin  Procedures
  12517   "RTN","VPR DJ08",166, 0)
  12518    . I STATU S'=2 S CLA SS="CP"                              ; if u nsigned,
  12519   "RTN","VPR DJ08",167, 0)
  12520    . E  D CP CLASS^TIUC P(.CP) S C LASS=CP                   ; use  TIU class#
  12521   "RTN","VPR DJ08",168, 0)
  12522    ;
  12523   "RTN","VPR DJ08",169, 0)
  12524    I TYPE="L R"   S CLA SS=$S(STAT US=2:$$LR, 1:"LR") Q      ;Lab/P athology
  12525   "RTN","VPR DJ08",170, 0)
  12526    ;
  12527   "RTN","VPR DJ08",171, 0)
  12528    I TYPE="R A"   S CLA SS="RA" Q                            ;Radio logy
  12529   "RTN","VPR DJ08",172, 0)
  12530    ;
  12531   "RTN","VPR DJ08",173, 0)
  12532    Q
  12533   "RTN","VPR DJ08",174, 0)
  12534    ;
  12535   "RTN","VPR DJ08",175, 0)
  12536   LR() ; --  Return ien  of Lab cl ass
  12537   "RTN","VPR DJ08",176, 0)
  12538    N Y S Y=+ $O(^TIU(89 25.1,"B"," LR LABORAT ORY REPORT S",0))
  12539   "RTN","VPR DJ08",177, 0)
  12540    I Y>0,$S( $P($G(^TIU (8925.1,Y, 0)),U,4)=" CL":0,$P($ G(^(0)),U, 4)="DC":0, 1:1) S Y=0
  12541   "RTN","VPR DJ08",178, 0)
  12542    Q Y
  12543   "RTN","VPR DJ08",179, 0)
  12544    ;
  12545   "RTN","VPR DJ08",180, 0)
  12546   MATCH(DOC, STS) ; --  Return 1 o r 0, if do cument DA  matches se arch crite ria
  12547   "RTN","VPR DJ08",181, 0)
  12548    N Y,DA,LO CAL,NATL,X 0,OK S Y=0
  12549   "RTN","VPR DJ08",182, 0)
  12550    S DA=+$G( DOC) G:DA< 1 MQ
  12551   "RTN","VPR DJ08",183, 0)
  12552    ; include  addenda i f pulling  only unsig ned items
  12553   "RTN","VPR DJ08",184, 0)
  12554    I $P(DOC, U,2)?1"Add endum ".E, STATUS'=2  G MQ
  12555   "RTN","VPR DJ08",185, 0)
  12556    ; TIU uns igned list  can inclu de complet ed parent  notes
  12557   "RTN","VPR DJ08",186, 0)
  12558    I $G(STS) =2,$P(DOC, U,7)'="uns igned" G M Q
  12559   "RTN","VPR DJ08",187, 0)
  12560    S LOCAL=$ $GET1^DIQ( 8925,DA_", ",.01,"I")  ;local Ti tle 8925.1  ien
  12561   "RTN","VPR DJ08",188, 0)
  12562    I $L(SUBC LASS) D  G :'OK MQ
  12563   "RTN","VPR DJ08",189, 0)
  12564    . N I,X S  OK=0
  12565   "RTN","VPR DJ08",190, 0)
  12566    . F I=1:1 :$L(SUBCLA SS,"^") S  X=$P(SUBCL ASS,U,I) I  $$ISA^TIU LX(LOCAL,X ) S OK=1 Q
  12567   "RTN","VPR DJ08",191, 0)
  12568    S Y=1
  12569   "RTN","VPR DJ08",192, 0)
  12570   MQ Q Y
  12571   "RTN","VPR DJ08",193, 0)
  12572    ;
  12573   "RTN","VPR DJ08",194, 0)
  12574   TYPE(X) ;  -- Return  name of ca tegory typ e X
  12575   "RTN","VPR DJ08",195, 0)
  12576    S X=$G(X)
  12577   "RTN","VPR DJ08",196, 0)
  12578    I X="PN"  Q "Progres s Note"
  12579   "RTN","VPR DJ08",197, 0)
  12580    I X="DS"  Q "Dischar ge Summary "
  12581   "RTN","VPR DJ08",198, 0)
  12582    I X="CP"  Q "Clinica l Procedur e"
  12583   "RTN","VPR DJ08",199, 0)
  12584    I X="SR"  Q "Surgery  Report"
  12585   "RTN","VPR DJ08",200, 0)
  12586    I X="LR"  Q "Laborat ory Report "
  12587   "RTN","VPR DJ08",201, 0)
  12588    I X="RA"  Q "Radiolo gy Report"
  12589   "RTN","VPR DJ08",202, 0)
  12590    I X="CR"  Q "Consult  Report"
  12591   "RTN","VPR DJ08",203, 0)
  12592    I X="C"   Q "Crisis  Note"
  12593   "RTN","VPR DJ08",204, 0)
  12594    I X="W"   Q "Clinica l Warning"
  12595   "RTN","VPR DJ08",205, 0)
  12596    I X="A"   Q "Allergy /Adverse R eaction"
  12597   "RTN","VPR DJ08",206, 0)
  12598    I X="D"   Q "Advance  Directive "
  12599   "RTN","VPR DJ08",207, 0)
  12600    Q ""
  12601   "RTN","VPR DJ08A")
  12602   0^82^B4451 7876
  12603   "RTN","VPR DJ08A",1,0 )
  12604   VPRDJ08A ; SLC/MKB --  Documents  cont ;6/2 5/12  16:1 1
  12605   "RTN","VPR DJ08A",2,0 )
  12606    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  12607   "RTN","VPR DJ08A",3,0 )
  12608    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  12609   "RTN","VPR DJ08A",4,0 )
  12610    ;
  12611   "RTN","VPR DJ08A",5,0 )
  12612    ; Externa l Referenc es           DBIA#
  12613   "RTN","VPR DJ08A",6,0 )
  12614    ; ------- ---------- --           -----
  12615   "RTN","VPR DJ08A",7,0 )
  12616    ; ^DPT                            10035
  12617   "RTN","VPR DJ08A",8,0 )
  12618    ; ^LR                               525
  12619   "RTN","VPR DJ08A",9,0 )
  12620    ; ^RADPT                           2480
  12621   "RTN","VPR DJ08A",10, 0)
  12622    ; ^RARPT                           5605
  12623   "RTN","VPR DJ08A",11, 0)
  12624    ; ^SC                             10040
  12625   "RTN","VPR DJ08A",12, 0)
  12626    ; ^TMP("M DHSP" [MDP S1]           4230
  12627   "RTN","VPR DJ08A",13, 0)
  12628    ; ^VA(200                         10060
  12629   "RTN","VPR DJ08A",14, 0)
  12630    ; %DT                             10003
  12631   "RTN","VPR DJ08A",15, 0)
  12632    ; DIQ                              2056
  12633   "RTN","VPR DJ08A",16, 0)
  12634    ; GMRCGUI B                        2980
  12635   "RTN","VPR DJ08A",17, 0)
  12636    ; LR7OR1, ^TMP("LRRR "             2503
  12637   "RTN","VPR DJ08A",18, 0)
  12638    ; MCARUTL 3                        3280
  12639   "RTN","VPR DJ08A",19, 0)
  12640    ; PXAPI                            1894
  12641   "RTN","VPR DJ08A",20, 0)
  12642    ; RAO7PC1                    20 43,2265
  12643   "RTN","VPR DJ08A",21, 0)
  12644    ; RAO7PC3                          2877
  12645   "RTN","VPR DJ08A",22, 0)
  12646    ;
  12647   "RTN","VPR DJ08A",23, 0)
  12648    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  12649   "RTN","VPR DJ08A",24, 0)
  12650    ;
  12651   "RTN","VPR DJ08A",25, 0)
  12652    ; ------- ---------- ---------- ---------- ---------- ---------- ---------
  12653   "RTN","VPR DJ08A",26, 0)
  12654    ; documen tClass = C LINICAL PR OCEDURES
  12655   "RTN","VPR DJ08A",27, 0)
  12656    ; nationa lTitle = 4 696566^PRO CEDURE REP ORT
  12657   "RTN","VPR DJ08A",28, 0)
  12658    ;       S ervice = 4 696471^PRO CEDURE
  12659   "RTN","VPR DJ08A",29, 0)
  12660    ;           Type = 4 696123^REP ORT
  12661   "RTN","VPR DJ08A",30, 0)
  12662    ;
  12663   "RTN","VPR DJ08A",31, 0)
  12664   CP(DFN,BEG ,END,MAX)  ; -- Medic ine report s
  12665   "RTN","VPR DJ08A",32, 0)
  12666    N VPRN,VP RX,RTN,TIU N,CONS,VPR D,I,DA,X,Y ,%DT,DATE, GBL
  12667   "RTN","VPR DJ08A",33, 0)
  12668    S DFN=+$G (DFN) Q:$G (DFN)<1
  12669   "RTN","VPR DJ08A",34, 0)
  12670    D MDPS1^V PRDJ03(DFN ,BEG,END,M AX)              ;get s ^TMP("MD HSP",$J)
  12671   "RTN","VPR DJ08A",35, 0)
  12672    S VPRN=0  F  S VPRN= $O(^TMP("M DHSP",$J,V PRN)) Q:VP RN<1  S VP RX=$G(^(VP RN)) D
  12673   "RTN","VPR DJ08A",36, 0)
  12674    . N $ES,$ ET,ERRPAT, ERRMSG
  12675   "RTN","VPR DJ08A",37, 0)
  12676    . S $ET=" D ERRHDLR^ VPRDERRH", ERRPAT=DFN
  12677   "RTN","VPR DJ08A",38, 0)
  12678    . S ERRMS G="A probl em occurre d converti ng a medic ine report ."
  12679   "RTN","VPR DJ08A",39, 0)
  12680    . S RTN=$ P(VPRX,U,3 ,4)  Q:RTN ="PRPRO^MD PS4"  ;ski p non-CP i tems
  12681   "RTN","VPR DJ08A",40, 0)
  12682    . S TIUN= +$P(VPRX,U ,14)
  12683   "RTN","VPR DJ08A",41, 0)
  12684    . I TIUN  D EN1^VPRD J08(TIUN,3 8)               ;38= TIU Clinic al Documen t
  12685   "RTN","VPR DJ08A",42, 0)
  12686    . S CONS= +$P(VPRX,U ,13) D:CON S DOCLIST^ GMRCGUIB(. VPRD,CONS)
  12687   "RTN","VPR DJ08A",43, 0)
  12688    . K DA S  I=0 F  S I =$O(VPRD(5 0,I)) Q:I< 1  D
  12689   "RTN","VPR DJ08A",44, 0)
  12690    .. S DA=+ VPRD(50,I)  Q:DA=TIUN
  12691   "RTN","VPR DJ08A",45, 0)
  12692    .. D EN1^ VPRDJ08(DA ,38)
  12693   "RTN","VPR DJ08A",46, 0)
  12694    . Q:TIUN! $G(DA)                                 ;don e [got TIU  note(s)]
  12695   "RTN","VPR DJ08A",47, 0)
  12696    . Q:RTN=" PR702^MDPS 1"                          ;CP,  but no TI U note yet
  12697   "RTN","VPR DJ08A",48, 0)
  12698    . Q:RTN=" PRPRO^MDPS 4"                          ;non -CP proced ure
  12699   "RTN","VPR DJ08A",49, 0)
  12700    . ; find  ID for pre -TIU repor t
  12701   "RTN","VPR DJ08A",50, 0)
  12702    . S X=$P( VPRX,U,6), %DT="TXS"  D ^%DT Q:Y '>0  S DAT E=Y
  12703   "RTN","VPR DJ08A",51, 0)
  12704    . S GBL=+ $P(VPRX,U, 2)_";"_$$R OOT^VPRDMC (DFN,$P(VP RX,U,11),D ATE)
  12705   "RTN","VPR DJ08A",52, 0)
  12706    . I GBL S  X=$$CP1(D FN,GBL) D  EN1^VPRDJ0 8(X,"CP")
  12707   "RTN","VPR DJ08A",53, 0)
  12708    K ^TMP("M DHSP",$J), ^TMP("VPRT EXT",$J)
  12709   "RTN","VPR DJ08A",54, 0)
  12710    Q
  12711   "RTN","VPR DJ08A",55, 0)
  12712    ;
  12713   "RTN","VPR DJ08A",56, 0)
  12714   CP1(DFN,ID ) ; -- ret urn report  data as T IU string  [$$RESOLVE ]
  12715   "RTN","VPR DJ08A",57, 0)
  12716    S DFN=+$G (DFN),ID=$ G(ID) I DF N<1!'$L(ID ) Q ""
  12717   "RTN","VPR DJ08A",58, 0)
  12718    N Y,VPRY, VPRFN,X,NA ME,DATE,ST S,USER,SIG N,TEXT
  12719   "RTN","VPR DJ08A",59, 0)
  12720    S VPRFN=+ $P(ID,"(", 2)
  12721   "RTN","VPR DJ08A",60, 0)
  12722    D MEDLKUP ^MCARUTL3( .VPRY,VPRF N,+ID)
  12723   "RTN","VPR DJ08A",61, 0)
  12724    I VPRY<1  Q ""  ;err or in CP
  12725   "RTN","VPR DJ08A",62, 0)
  12726    S NAME=$P (VPRY,U,9) ,DATE=$P(V PRY,U,6)
  12727   "RTN","VPR DJ08A",63, 0)
  12728    S X=$$GET 1^DIQ(VPRF N,+ID_",", 1506)
  12729   "RTN","VPR DJ08A",64, 0)
  12730    S STS=$S( $L(X):X,1: "COMPLETED ")
  12731   "RTN","VPR DJ08A",65, 0)
  12732    S X=+$$GE T1^DIQ(VPR FN,+ID_"," ,701,"I"), (USER,SIGN )=""
  12733   "RTN","VPR DJ08A",66, 0)
  12734    S:X USER= X_";;"_$P( $G(^VA(200 ,X,0)),U)
  12735   "RTN","VPR DJ08A",67, 0)
  12736    S X=+$$GE T1^DIQ(VPR FN,+ID_"," ,1503,"I")
  12737   "RTN","VPR DJ08A",68, 0)
  12738    S:X SIGN= "//"_X_";" _$P($G(^VA (200,X,0)) ,U)_";"_$$ GET1^DIQ(V PRFN,+ID_" ,",1505,"I ")
  12739   "RTN","VPR DJ08A",69, 0)
  12740    ; VST=$$G ET1^DIQ(VP RFN,+ID_", ",900,"I")
  12741   "RTN","VPR DJ08A",70, 0)
  12742    S Y=ID_U_ NAME_U_DAT E_U_U_USER _U_U_STS_" ^^^2461^"_ SIGN
  12743   "RTN","VPR DJ08A",71, 0)
  12744    S:$G(VPRT EXT) TEXT= $$TEXT^VPR DMC(DFN,ID ,NAME) ;^T MP("VPRTEX T",$J,ID)
  12745   "RTN","VPR DJ08A",72, 0)
  12746    Q Y
  12747   "RTN","VPR DJ08A",73, 0)
  12748    ;
  12749   "RTN","VPR DJ08A",74, 0)
  12750    ; ------- ---------- ---------- ---------- ---------- ---------- ---------
  12751   "RTN","VPR DJ08A",75, 0)
  12752    ; documen tClass = L R LABORATO RY REPORTS
  12753   "RTN","VPR DJ08A",76, 0)
  12754    ; nationa lTitle = 4 697105^LAB ORATORY NO TE
  12755   "RTN","VPR DJ08A",77, 0)
  12756    ;       S ubject = 4 697104^LAB ORATORY
  12757   "RTN","VPR DJ08A",78, 0)
  12758    ;           Type = 4 696120^NOT E
  12759   "RTN","VPR DJ08A",79, 0)
  12760    ;
  12761   "RTN","VPR DJ08A",80, 0)
  12762   LR(DFN,BEG ,END,MAX)  ; -- Lab r eports
  12763   "RTN","VPR DJ08A",81, 0)
  12764    N VPRSUB, VPRIDT,VPR ITM,VPRTIU ,VPRXID,LR DFN,IVDT,V PRN,DA
  12765   "RTN","VPR DJ08A",82, 0)
  12766    S DFN=+$G (DFN) Q:$G (DFN)<1
  12767   "RTN","VPR DJ08A",83, 0)
  12768    S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
  12769   "RTN","VPR DJ08A",84, 0)
  12770    S LRDFN=+ $G(^DPT(DF N,"LR")),I VDT=999999 9-+$G(^LR( LRDFN,"AU" )) ;LR7OB6 3D error
  12771   "RTN","VPR DJ08A",85, 0)
  12772    K ^TMP("L RRR",$J,DF N) D RR^LR 7OR1(DFN,, BEG,END,"M IAP",,,MAX )
  12773   "RTN","VPR DJ08A",86, 0)
  12774    S VPRSUB= "" F  S VP RSUB=$O(^T MP("LRRR", $J,DFN,VPR SUB)) Q:VP RSUB=""  D
  12775   "RTN","VPR DJ08A",87, 0)
  12776    . S VPRID T=0 F  S V PRIDT=$O(^ TMP("LRRR" ,$J,DFN,VP RSUB,VPRID T)) Q:VPRI DT<1  I $O (^(VPRIDT, 0)) D
  12777   "RTN","VPR DJ08A",88, 0)
  12778    .. S VPRT IU=$S(VPRS UB="AU":$N A(^LR(LRDF N,101)),1: $NA(^LR(LR DFN,VPRSUB ,VPRIDT,.0 5)))
  12779   "RTN","VPR DJ08A",89, 0)
  12780    .. K VPRI TM S VPRXI D=VPRSUB_" ;"_VPRIDT
  12781   "RTN","VPR DJ08A",90, 0)
  12782    .. I '$O( @VPRTIU@(0 )) S VPRX= $$LR1(DFN, VPRXID) D  EN1^VPRDJ0 8(VPRX,"LR ") Q
  12783   "RTN","VPR DJ08A",91, 0)
  12784    .. S VPRN =0 F  S VP RN=$O(@VPR TIU@(VPRN) ) Q:VPRN<1   D  ;38=T IU Clin Do c
  12785   "RTN","VPR DJ08A",92, 0)
  12786    ... S DA= +$P($G(@VP RTIU@(VPRN ,0)),U,2)
  12787   "RTN","VPR DJ08A",93, 0)
  12788    ... D:DA  EN1^VPRDJ0 8(DA,38)
  12789   "RTN","VPR DJ08A",94, 0)
  12790    K ^TMP("L RRR",$J,DF N),^TMP("V PRTEXT",$J )
  12791   "RTN","VPR DJ08A",95, 0)
  12792    Q
  12793   "RTN","VPR DJ08A",96, 0)
  12794    ;
  12795   "RTN","VPR DJ08A",97, 0)
  12796   LR1(DFN,ID ) ; -- ret urn report  data as T IU string  [$$RESOLVE ]
  12797   "RTN","VPR DJ08A",98, 0)
  12798    N $ES,$ET ,ERRPAT,ER RMSG
  12799   "RTN","VPR DJ08A",99, 0)
  12800    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12801   "RTN","VPR DJ08A",100 ,0)
  12802    S ERRMSG= "A problem  occurred  converting  lab repor t "_ID
  12803   "RTN","VPR DJ08A",101 ,0)
  12804    S DFN=+$G (DFN),ID=$ G(ID) I DF N<1!'$L(ID ) Q ""
  12805   "RTN","VPR DJ08A",102 ,0)
  12806    N Y,SUB,I DT,LRDFN,L R,NAME,LOC ,USER,VST, SIGN,TEXT
  12807   "RTN","VPR DJ08A",103 ,0)
  12808    K ^TMP("V PRTEXT",$J ,ID)
  12809   "RTN","VPR DJ08A",104 ,0)
  12810    S SUB=$P( ID,";"),ID T=+$P(ID," ;",2),LRDF N=$G(^DPT( DFN,"LR"))
  12811   "RTN","VPR DJ08A",105 ,0)
  12812    S LR=$S(S UB="AU":$G (^LR(LRDFN ,"AU")),1: $G(^LR(LRD FN,SUB,IDT ,0)))
  12813   "RTN","VPR DJ08A",106 ,0)
  12814    S NAME="L R "_$$NAME ^VPRDLRA(S UB)_" REPO RT"
  12815   "RTN","VPR DJ08A",107 ,0)
  12816    S LOC=$P( LR,U,$S(SU B="AU":5,1 :8)) D  ;l ook-up vis it
  12817   "RTN","VPR DJ08A",108 ,0)
  12818    . N CDT,S C S CDT=99 99999-IDT, SC="",X=0
  12819   "RTN","VPR DJ08A",109 ,0)
  12820    . S:$L(LO C) SC=+$O( ^SC("B",LO C,0))
  12821   "RTN","VPR DJ08A",110 ,0)
  12822    . I CDT,L OC S X=$$G ETENC^PXAP I(DFN,CDT, SC)
  12823   "RTN","VPR DJ08A",111 ,0)
  12824    . S:X VST =+X
  12825   "RTN","VPR DJ08A",112 ,0)
  12826    S X=+$P(L R,U,$S(SUB ="AU":10,S UB="MI":4, 1:2)) ;pat hologist[a uthor]
  12827   "RTN","VPR DJ08A",113 ,0)
  12828    S USER=$S (X:X_";;"_ $P($G(^VA( 200,X,0)), U),1:""),S IGN=""
  12829   "RTN","VPR DJ08A",114 ,0)
  12830    S X=$S(SU B="AU":$P( LR,U,15,16 ),SUB="MI" :$P(LR,U,3 ,4),1:$P(L R,U,11)_U_ $P(LR,U,13 )) ;releas ed
  12831   "RTN","VPR DJ08A",115 ,0)
  12832    S:X SIGN= "//"_+$P(X ,U,2)_";"_ $P($G(^VA( 200,+$P(X, U,2),0)),U )_";"_+X
  12833   "RTN","VPR DJ08A",116 ,0)
  12834    S Y=ID_U_ NAME_U_(99 99999-IDT) _U_U_USER_ U_LOC_"^CO MPLETED^"_ $G(VST)_"^ ^2753^"_SI GN
  12835   "RTN","VPR DJ08A",117 ,0)
  12836    S:$G(VPRT EXT) TEXT= $$TEXT^VPR DLRA(DFN,S UB,IDT) ;^ TMP("VPRTE XT",$J,ID)
  12837   "RTN","VPR DJ08A",118 ,0)
  12838    Q Y
  12839   "RTN","VPR DJ08A",119 ,0)
  12840    ;
  12841   "RTN","VPR DJ08A",120 ,0)
  12842    ; ------- ---------- ---------- ---------- ---------- ---------- ---------
  12843   "RTN","VPR DJ08A",121 ,0)
  12844    ; nationa lTitle = 4 695068^RAD IOLOGY REP ORT
  12845   "RTN","VPR DJ08A",122 ,0)
  12846    ;       S ubject = 4 693357^RAD IOLOGY
  12847   "RTN","VPR DJ08A",123 ,0)
  12848    ;           Type = 4 696123^REP ORT
  12849   "RTN","VPR DJ08A",124 ,0)
  12850    ;
  12851   "RTN","VPR DJ08A",125 ,0)
  12852   RA(DFN,BEG ,END,MAX)  ; -- Radio logy repor ts
  12853   "RTN","VPR DJ08A",126 ,0)
  12854    N VPRXID, STS,PSET
  12855   "RTN","VPR DJ08A",127 ,0)
  12856    S DFN=+$G (DFN) Q:DF N<1
  12857   "RTN","VPR DJ08A",128 ,0)
  12858    S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)_ "P"
  12859   "RTN","VPR DJ08A",129 ,0)
  12860    K ^TMP($J ,"RAE1") D  EN1^RAO7P C1(DFN,BEG ,END,MAX)
  12861   "RTN","VPR DJ08A",130 ,0)
  12862    S VPRXID= "" F  S VP RXID=$O(^T MP($J,"RAE 1",DFN,VPR XID)) Q:VP RXID=""  D
  12863   "RTN","VPR DJ08A",131 ,0)
  12864    . S STS=$ P($G(^TMP( $J,"RAE1", DFN,VPRXID )),U,3),PS ET=$G(^(VP RXID,"CPRS "))
  12865   "RTN","VPR DJ08A",132 ,0)
  12866    . Q:STS=" No Report" !(STS="Del eted")  ;! (STS["Draf t")
  12867   "RTN","VPR DJ08A",133 ,0)
  12868    . I +PSET =2,$G(PSET (+VPRXID,$ P(PSET,U,2 ))) Q  ;al ready have  report
  12869   "RTN","VPR DJ08A",134 ,0)
  12870    . S VPRX= $$RA1(DFN, VPRXID) D  EN1^VPRDJ0 8(VPRX,"RA ")
  12871   "RTN","VPR DJ08A",135 ,0)
  12872    . I +PSET =2 S PSET( +VPRXID,$P (PSET,U,2) )=$P(VPRXI D,"-",2) ; parent
  12873   "RTN","VPR DJ08A",136 ,0)
  12874    K ^TMP($J ,"RAE1"),^ TMP("VPRTE XT",$J)
  12875   "RTN","VPR DJ08A",137 ,0)
  12876    Q
  12877   "RTN","VPR DJ08A",138 ,0)
  12878    ;
  12879   "RTN","VPR DJ08A",139 ,0)
  12880   RA1(DFN,ID ) ; -- ret urn report  data as T IU string  [$$RESOLVE ]
  12881   "RTN","VPR DJ08A",140 ,0)
  12882    N $ES,$ET ,ERRPAT,ER RMSG
  12883   "RTN","VPR DJ08A",141 ,0)
  12884    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12885   "RTN","VPR DJ08A",142 ,0)
  12886    S ERRMSG= "A problem  occurred  converting  radiology  report "_ ID
  12887   "RTN","VPR DJ08A",143 ,0)
  12888    S DFN=+$G (DFN),ID=$ G(ID) I DF N<1!'$L(ID ) Q ""
  12889   "RTN","VPR DJ08A",144 ,0)
  12890    N EXAM,CA SE,PROC,RA E3,RAE1,TE XT,I,X,Y,D ATE,LOC,ST S,IENS,VST ,USER,SIGN
  12891   "RTN","VPR DJ08A",145 ,0)
  12892    K RPT,^TM P("VPRTEXT ",$J,ID)
  12893   "RTN","VPR DJ08A",146 ,0)
  12894    S EXAM=DF N_U_$TR(ID ,"-","^")  D
  12895   "RTN","VPR DJ08A",147 ,0)
  12896    . N DFN D  EN3^RAO7P C3(EXAM) ; report
  12897   "RTN","VPR DJ08A",148 ,0)
  12898    . D EN3^R AO7PC1(EXA M)       ; add'l valu es
  12899   "RTN","VPR DJ08A",149 ,0)
  12900    S CASE=$O (^TMP($J," RAE3",DFN, 0)),PROC=$ O(^(CASE," ")),RAE3=$ G(^(PROC))
  12901   "RTN","VPR DJ08A",150 ,0)
  12902    S RAE1=$G (^TMP($J," RAE1",DFN, ID))
  12903   "RTN","VPR DJ08A",151 ,0)
  12904    I $G(VPRT EXT) D
  12905   "RTN","VPR DJ08A",152 ,0)
  12906    . S TEXT= $NA(^TMP(" VPRTEXT",$ J,ID))
  12907   "RTN","VPR DJ08A",153 ,0)
  12908    . S I=0 F   S I=$O(^ TMP($J,"RA E3",DFN,CA SE,PROC,I) ) Q:I<1  S  X=^(I),@T EXT@(I)=X
  12909   "RTN","VPR DJ08A",154 ,0)
  12910    S DATE=99 99999.9999 -(+ID),LOC =$P(RAE1,U ,7),STS=$P (RAE3,U)
  12911   "RTN","VPR DJ08A",155 ,0)
  12912    S IENS=$P (ID,"-",2) _","_+ID_" ,"_DFN_","
  12913   "RTN","VPR DJ08A",156 ,0)
  12914    S VST=$$G ET1^DIQ(70 .03,IENS,2 7,"I")
  12915   "RTN","VPR DJ08A",157 ,0)
  12916    S X=+$G(^ TMP($J,"RA E2",DFN,CA SE,PROC,"P ")),(USER, SIGN)=""
  12917   "RTN","VPR DJ08A",158 ,0)
  12918    S:X USER= X_";;"_$P( $G(^VA(200 ,X,0)),U)
  12919   "RTN","VPR DJ08A",159 ,0)
  12920    S X=$G(^T MP($J,"RAE 2",DFN,CAS E,PROC,"V" ))
  12921   "RTN","VPR DJ08A",160 ,0)
  12922    S:X SIGN= "//"_+X_"; "_$P($G(^V A(200,+X,0 )),U)_";"_ $$GET1^DIQ (74,+$P(RA E1,U,5)_", ",7,"I")
  12923   "RTN","VPR DJ08A",161 ,0)
  12924    I $D(^TMP ($J,"RAE3" ,DFN,"PRIN T_SET")) S  PROC=$G(^ ("ORD")) ; use parent , if print set
  12925   "RTN","VPR DJ08A",162 ,0)
  12926    S Y=ID_U_ PROC_U_DAT E_U_U_USER _U_LOC_U_S TS_U_VST_" ^^1901^"_S IGN
  12927   "RTN","VPR DJ08A",163 ,0)
  12928    K ^TMP($J ,"RAE3",DF N),^TMP($J ,"RAE2",DF N)
  12929   "RTN","VPR DJ08A",164 ,0)
  12930    Q Y
  12931   "RTN","VPR DJ09")
  12932   0^80^B3917 4048
  12933   "RTN","VPR DJ09",1,0)
  12934   VPRDJ09 ;S LC/MKB --  PCE ;8/2/1 1  15:29
  12935   "RTN","VPR DJ09",2,0)
  12936    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  12937   "RTN","VPR DJ09",3,0)
  12938    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  12939   "RTN","VPR DJ09",4,0)
  12940    ;
  12941   "RTN","VPR DJ09",5,0)
  12942    ; Externa l Referenc es           DBIA#
  12943   "RTN","VPR DJ09",6,0)
  12944    ; ------- ---------- --           -----
  12945   "RTN","VPR DJ09",7,0)
  12946    ; ^AUPNVS IT                       2028
  12947   "RTN","VPR DJ09",8,0)
  12948    ; ^PXRMIN DX                       4290
  12949   "RTN","VPR DJ09",9,0)
  12950    ; ^SC                             10040
  12951   "RTN","VPR DJ09",10,0 )
  12952    ; ^VA(200                         10060
  12953   "RTN","VPR DJ09",11,0 )
  12954    ; DIC                              2051
  12955   "RTN","VPR DJ09",12,0 )
  12956    ; DILFD                            2055
  12957   "RTN","VPR DJ09",13,0 )
  12958    ; DIQ                              2056
  12959   "RTN","VPR DJ09",14,0 )
  12960    ; PXAPI,^ TMP("PXKEN C"            1894
  12961   "RTN","VPR DJ09",15,0 )
  12962    ; VALM1                           10116
  12963   "RTN","VPR DJ09",16,0 )
  12964    ; XUAF4                            2171
  12965   "RTN","VPR DJ09",17,0 )
  12966    ;
  12967   "RTN","VPR DJ09",18,0 )
  12968    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  12969   "RTN","VPR DJ09",19,0 )
  12970    ;
  12971   "RTN","VPR DJ09",20,0 )
  12972   PX(FNUM) ;  -- PCE it em(s)
  12973   "RTN","VPR DJ09",21,0 )
  12974    I $G(VPRI D) D PXA(V PRID) Q
  12975   "RTN","VPR DJ09",22,0 )
  12976    N VPRIDT, ID D SORT  ;sort ^PXR MINDX into  ^TMP("VPR PX",$J,IDT )
  12977   "RTN","VPR DJ09",23,0 )
  12978    S VPRIDT= 0 F  S VPR IDT=$O(^TM P("VPRPX", $J,VPRIDT) ) Q:VPRIDT <1  D  Q:V PRI'<VPRMA X
  12979   "RTN","VPR DJ09",24,0 )
  12980    . S ID=0  F  S ID=$O (^TMP("VPR PX",$J,VPR IDT,ID)) Q :ID<1  D P X1 Q:VPRI' <VPRMAX
  12981   "RTN","VPR DJ09",25,0 )
  12982    K ^TMP("V PRPX",$J)
  12983   "RTN","VPR DJ09",26,0 )
  12984    Q
  12985   "RTN","VPR DJ09",27,0 )
  12986    ;
  12987   "RTN","VPR DJ09",28,0 )
  12988   PXA(ID) ;  -- find ID  in ^PXRMI NDX(FNUM),  fall thru  to PX1 if  successfu l
  12989   "RTN","VPR DJ09",29,0 )
  12990    N N,ROOT, IDX,P,ITEM ,DATE,VPRI DT
  12991   "RTN","VPR DJ09",30,0 )
  12992    S N=+$P(F NUM,".",2)  K ^TMP("V PRPX",$J)
  12993   "RTN","VPR DJ09",31,0 )
  12994    I N=7!(N= 18) S ROOT ="^PXRMIND X("_FNUM_" ,""PPI""," _+$G(DFN)
  12995   "RTN","VPR DJ09",32,0 )
  12996    E  S ROOT ="^PXRMIND X("_FNUM_" ,""PI"","_ +$G(DFN)
  12997   "RTN","VPR DJ09",33,0 )
  12998    S IDX=ROO T_")" F  S  IDX=$Q(@I DX) Q:$P(I DX,",",1,3 )'=ROOT  D
  12999   "RTN","VPR DJ09",34,0 )
  13000    . S P=$L( IDX,",") Q :ID'=+$P(I DX,",",P)   ;last sub script
  13001   "RTN","VPR DJ09",35,0 )
  13002    . S DATE= +$P(IDX,", ",P-1),ITE M=+$P(IDX, ",",P-2)
  13003   "RTN","VPR DJ09",36,0 )
  13004    . S VPRID T=9999999- DATE,^TMP( "VPRPX",$J ,VPRIDT,ID )=ITEM_U_D ATE
  13005   "RTN","VPR DJ09",37,0 )
  13006    Q:'$D(^TM P("VPRPX", $J))  ;not  found
  13007   "RTN","VPR DJ09",38,0 )
  13008   PX1 ; -- P CE ^TMP("V PRPX",$J,V PRIDT,ID)= ITM^DATE f or FNUM
  13009   "RTN","VPR DJ09",39,0 )
  13010    N N,COLL, TAG,VPRF,F LD,TMP,VIS IT,X0,X12, FAC,LOC,X, Y,PCE
  13011   "RTN","VPR DJ09",40,0 )
  13012    N $ES,$ET ,ERRPAT,ER RMSG
  13013   "RTN","VPR DJ09",41,0 )
  13014    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  13015   "RTN","VPR DJ09",42,0 )
  13016    S N=+$P(F NUM,".",2) ,TAG=$S(N= 7:"VPOV",N =11:"VIMM" ,N=12:"VSK IN",N=13:" VXAM",N=16 :"VPEDU",N =18:"VCPT" ,1:"VHF")
  13017   "RTN","VPR DJ09",43,0 )
  13018    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for " _TAG
  13019   "RTN","VPR DJ09",44,0 )
  13020    D @(TAG_" ^PXPXRM(ID ,.VPRF)")
  13021   "RTN","VPR DJ09",45,0 )
  13022    ;
  13023   "RTN","VPR DJ09",46,0 )
  13024    S PCE("lo calId")=ID ,TMP=$G(^T MP("VPRPX" ,$J,VPRIDT ,ID))
  13025   "RTN","VPR DJ09",47,0 )
  13026    S COLL=$S (N=7:"pov" ,N=11:"imm unization" ,N=12:"ski n",N=13:"e xam",N=16: "education ",N=18:"cp t",1:"fact or")
  13027   "RTN","VPR DJ09",48,0 )
  13028    S PCE("ui d")=$$SETU ID^VPRUTIL S(COLL,DFN ,ID)
  13029   "RTN","VPR DJ09",49,0 )
  13030    ; TAG=$S( N=23:"reco rded",N=11 :"administ eredDateTi me",1:"dat eTimeEnter ed")
  13031   "RTN","VPR DJ09",50,0 )
  13032    S TAG=$S( N=11:"admi nisteredDa teTime",1: "entered")
  13033   "RTN","VPR DJ09",51,0 )
  13034    S PCE(TAG )=$$JSONDT ^VPRUTILS( $P(TMP,U,2 ))
  13035   "RTN","VPR DJ09",52,0 )
  13036    S PCE("na me")=$$EXT ERNAL^DILF D(FNUM,.01 ,,+TMP)
  13037   "RTN","VPR DJ09",53,0 )
  13038    S VISIT=+ $G(VPRF("V ISIT")),PC E("encount erUid")=$$ SETUID^VPR UTILS("vis it",DFN,VI SIT)
  13039   "RTN","VPR DJ09",54,0 )
  13040    S PCE("en counterNam e")=$$NAME ^VPRDJ04(V ISIT)
  13041   "RTN","VPR DJ09",55,0 )
  13042    S X0=$G(^ AUPNVSIT(+ VISIT,0)), FAC=+$P(X0 ,U,6),LOC= +$P(X0,U,2 2)
  13043   "RTN","VPR DJ09",56,0 )
  13044    S:FAC X=$ $STA^XUAF4 (FAC)_U_$P ($$NS^XUAF 4(FAC),U)
  13045   "RTN","VPR DJ09",57,0 )
  13046    S:'FAC X= $$FAC^VPRD (LOC)
  13047   "RTN","VPR DJ09",58,0 )
  13048    D FACILIT Y^VPRUTILS (X,"PCE")
  13049   "RTN","VPR DJ09",59,0 )
  13050    S:LOC PCE ("location Uid")=$$SE TUID^VPRUT ILS("locat ion",,LOC) ,PCE("loca tionName") =$P($G(^SC (LOC,0)),U )
  13051   "RTN","VPR DJ09",60,0 )
  13052    S X=$G(VP RF("COMMEN TS")) S:$L (X) PCE("c omment")=X
  13053   "RTN","VPR DJ09",61,0 )
  13054   POV I FNUM =9000010.0 7 D  G PXQ
  13055   "RTN","VPR DJ09",62,0 )
  13056    . S X=$G( VPRF("PRIM ARY/SECOND ARY")),PCE ("type")=$ S($L(X):X, 1:"U")
  13057   "RTN","VPR DJ09",63,0 )
  13058    . S X=PCE ("name"),P CE("icdCod e")=$$SETN CS^VPRUTIL S("icd",X)
  13059   "RTN","VPR DJ09",64,0 )
  13060    . S X=$G( VPRF("PROV IDER NARRA TIVE")),PC E("name")= $$EXTERNAL ^DILFD(900 0010.07,.0 4,,X)
  13061   "RTN","VPR DJ09",65,0 )
  13062   CPT I FNUM =9000010.1 8 D  G PXQ
  13063   "RTN","VPR DJ09",66,0 )
  13064    . S X=$G( VPRF("PRIN CIPAL PROC EDURE")),P CE("type") =$S($L(X): X,1:"U")
  13065   "RTN","VPR DJ09",67,0 )
  13066    . S X=PCE ("name"),P CE("cptCod e")=$$SETN CS^VPRUTIL S("cpt",X)
  13067   "RTN","VPR DJ09",68,0 )
  13068    . S X=$G( VPRF("PROV IDER NARRA TIVE")),PC E("name")= $$EXTERNAL ^DILFD(900 0010.18,.0 4,,X)
  13069   "RTN","VPR DJ09",69,0 )
  13070    . S PCE(" quantity") =VPRF("QUA NTITY")
  13071   "RTN","VPR DJ09",70,0 )
  13072    S X=$G(VP RF("VALUE" )),FLD=$S( FNUM=90000 10.16:.06, 1:.04)
  13073   "RTN","VPR DJ09",71,0 )
  13074    S Y=$$EXT ERNAL^DILF D(FNUM,FLD ,,X)
  13075   "RTN","VPR DJ09",72,0 )
  13076   IM I FNUM= 9000010.11  D  G PXQ  ;immunizat ion
  13077   "RTN","VPR DJ09",73,0 )
  13078    . S:$L(Y)  PCE("seri esName")=Y ,PCE("seri esCode")=$ $SETUID^VP RUTILS("se ries",DFN, Y)
  13079   "RTN","VPR DJ09",74,0 )
  13080    . S X=$G( VPRF("REAC TION")) I  $L(X) D
  13081   "RTN","VPR DJ09",75,0 )
  13082    .. S PCE( "reactionN ame")=$$EX TERNAL^DIL FD(9000010 .11,.06,,X )
  13083   "RTN","VPR DJ09",76,0 )
  13084    .. S PCE( "reactionC ode")=$$SE TUID^VPRUT ILS("react ion",DFN,X )
  13085   "RTN","VPR DJ09",77,0 )
  13086    . S PCE(" contraindi cated")=$S (+$G(VPRF( "CONTRAIND ICATED")): "true",1:" false")
  13087   "RTN","VPR DJ09",78,0 )
  13088    . I '$D(^ TMP("PXKEN C",$J,VISI T)) D ENCE VENT^PXAPI (VISIT,1)
  13089   "RTN","VPR DJ09",79,0 )
  13090    . S X12=$ G(^TMP("PX KENC",$J,V ISIT,"IMM" ,ID,12))
  13091   "RTN","VPR DJ09",80,0 )
  13092    . S X=$P( X12,U,4) S :'X X=$P(X 12,U,2)
  13093   "RTN","VPR DJ09",81,0 )
  13094    . I 'X S  I=0 F  S I =$O(^TMP(" PXKENC",$J ,VISIT,"PR V",I)) Q:I <1  I $P($ G(^(I,0)), U,4)="P" S  X=+^(0) Q
  13095   "RTN","VPR DJ09",82,0 )
  13096    . S:X PCE ("performe rUid")=$$S ETUID^VPRU TILS("user ",,+X),PCE ("performe rName")=$P ($G(^VA(20 0,X,0)),U)
  13097   "RTN","VPR DJ09",83,0 )
  13098    . ; CPT m apping
  13099   "RTN","VPR DJ09",84,0 )
  13100    . S X=+$$ FIND1^DIC( 811.1,,"QX ",+TMP_";A UTTIMM("," B") I X>0  D
  13101   "RTN","VPR DJ09",85,0 )
  13102    .. S Y=$$ GET1^DIQ(8 11.1,X_"," ,.02,"I")  Q:Y<1
  13103   "RTN","VPR DJ09",86,0 )
  13104    .. N CPT  S CPT=$G(@ (U_$P(Y,"; ",2)_+Y_", 0)"))
  13105   "RTN","VPR DJ09",87,0 )
  13106    .. S PCE( "cptCode") =$$SETNCS^ VPRUTILS(" cpt",+CPT)
  13107   "RTN","VPR DJ09",88,0 )
  13108    .. S (PCE ("summary" ),PCE("cpt Name"))=$P (CPT,U,2)
  13109   "RTN","VPR DJ09",89,0 )
  13110   HF I FNUM= 9000010.23  D  G PXQ  ;health fa ctor
  13111   "RTN","VPR DJ09",90,0 )
  13112    . S:$L(X)  PCE("seve rityUid")= $$SETVURN^ VPRUTILS(" factor-sev erity",X), PCE("sever ityName")= $$LOWER^VA LM1(Y)
  13113   "RTN","VPR DJ09",91,0 )
  13114    . S X=$$G ET1^DIQ(99 99999.64,+ TMP_",",.0 3,"I") I X  D
  13115   "RTN","VPR DJ09",92,0 )
  13116    .. S PCE( "categoryU id")=$$SET VURN^VPRUT ILS("facto r-category ",X)
  13117   "RTN","VPR DJ09",93,0 )
  13118    .. S PCE( "categoryN ame")=$$EX TERNAL^DIL FD(9999999 .64,.03,"" ,X)
  13119   "RTN","VPR DJ09",94,0 )
  13120    . S X=$$G ET1^DIQ(99 99999.64,+ TMP_",",.0 8)
  13121   "RTN","VPR DJ09",95,0 )
  13122    . I $E(X) ="Y" S PCE ("display" )="true"
  13123   "RTN","VPR DJ09",96,0 )
  13124    . S PCE(" kind")="He alth Facto r",PCE("su mmary")=PC E("name")
  13125   "RTN","VPR DJ09",97,0 )
  13126   SK I FNUM= 9000010.12  D  ;skin  test [fall  thru to s et result]
  13127   "RTN","VPR DJ09",98,0 )
  13128    . S X=$G( VPRF("READ ING")) S:$ L(X) PCE(" reading")= X
  13129   "RTN","VPR DJ09",99,0 )
  13130    . S X=$G( VPRF("DATE  READ")) S :X PCE("da teRead")=$ $JSONDT^VP RUTILS(X)
  13131   "RTN","VPR DJ09",100, 0)
  13132    S:$L(Y) P CE("result ")=Y
  13133   "RTN","VPR DJ09",101, 0)
  13134   PXQ ;finis h
  13135   "RTN","VPR DJ09",102, 0)
  13136    D ADD^VPR DJ("PCE",C OLL)
  13137   "RTN","VPR DJ09",103, 0)
  13138    Q
  13139   "RTN","VPR DJ09",104, 0)
  13140    ;
  13141   "RTN","VPR DJ09",105, 0)
  13142   SORT ; --  build ^TMP ("VPRPX",$ J,9999999- DATE,DA)=I TEM^DATE i n range
  13143   "RTN","VPR DJ09",106, 0)
  13144    N TYPE,IT EM,DATE,DA ,IDT K ^TM P("VPRPX", $J)
  13145   "RTN","VPR DJ09",107, 0)
  13146    I FNUM=90 00010.07!( FNUM=90000 10.18) G P PI
  13147   "RTN","VPR DJ09",108, 0)
  13148   PI ; from  ^PXRMINDX( FNUM,"PI", DFN,ITEM,D ATE,DA)
  13149   "RTN","VPR DJ09",109, 0)
  13150    S ITEM=0  F  S ITEM= $O(^PXRMIN DX(FNUM,"P I",+$G(DFN ),ITEM)) Q :ITEM<1  D
  13151   "RTN","VPR DJ09",110, 0)
  13152    . S DATE= 0 F  S DAT E=$O(^PXRM INDX(FNUM, "PI",+$G(D FN),ITEM,D ATE)) Q:DA TE<1  D
  13153   "RTN","VPR DJ09",111, 0)
  13154    .. Q:DATE <VPRSTART   Q:DATE>VP RSTOP  S I DT=9999999 -DATE
  13155   "RTN","VPR DJ09",112, 0)
  13156    .. S DA=0  F  S DA=$ O(^PXRMIND X(FNUM,"PI ",+$G(DFN) ,ITEM,DATE ,DA)) Q:DA <1  S ^TMP ("VPRPX",$ J,IDT,DA)= ITEM_U_DAT E
  13157   "RTN","VPR DJ09",113, 0)
  13158    Q
  13159   "RTN","VPR DJ09",114, 0)
  13160   PPI ; from  ^PXRMINDX (FNUM,"PPI ",DFN,TYPE ,ITEM,DATE ,DA)
  13161   "RTN","VPR DJ09",115, 0)
  13162    S TYPE=""  F  S TYPE =$O(^PXRMI NDX(FNUM," PPI",+$G(D FN),TYPE))  Q:TYPE=""   D
  13163   "RTN","VPR DJ09",116, 0)
  13164    . S ITEM= 0 F  S ITE M=$O(^PXRM INDX(FNUM, "PPI",+$G( DFN),TYPE, ITEM)) Q:I TEM<1  D
  13165   "RTN","VPR DJ09",117, 0)
  13166    .. S DATE =0 F  S DA TE=$O(^PXR MINDX(FNUM ,"PPI",+$G (DFN),TYPE ,ITEM,DATE )) Q:DATE< 1  D
  13167   "RTN","VPR DJ09",118, 0)
  13168    ... Q:DAT E<VPRSTART   Q:DATE>V PRSTOP  S  IDT=999999 9-DATE
  13169   "RTN","VPR DJ09",119, 0)
  13170    ... S DA= 0 F  S DA= $O(^PXRMIN DX(FNUM,"P PI",+$G(DF N),TYPE,IT EM,DATE,DA )) Q:DA<1   S ^TMP("V PRPX",$J,I DT,DA)=ITE M_U_DATE
  13171   "RTN","VPR DJ09",120, 0)
  13172    Q
  13173   "RTN","VPR DJ09",121, 0)
  13174   PTF ; from  ^PXRMINDX (45,"ICD9" ,"PNI",DFN ,TYPE,ITEM ,DATE,DA)
  13175   "RTN","VPR DJ09",122, 0)
  13176    S TYPE=""  F  S TYPE =$O(^PXRMI NDX(45,"IC D9","PNI", +$G(DFN),T YPE)) Q:TY PE=""  D
  13177   "RTN","VPR DJ09",123, 0)
  13178    . S ITEM= 0 F  S ITE M=$O(^PXRM INDX(45,"I CD9","PNI" ,+$G(DFN), TYPE,ITEM) ) Q:ITEM<1   D
  13179   "RTN","VPR DJ09",124, 0)
  13180    .. S DATE =0 F  S DA TE=$O(^PXR MINDX(45," ICD9","PNI ",+$G(DFN) ,TYPE,ITEM ,DATE)) Q: DATE<1  D
  13181   "RTN","VPR DJ09",125, 0)
  13182    ... Q:DAT E<VPRSTART   Q:DATE>V PRSTOP  S  IDT=999999 9-DATE
  13183   "RTN","VPR DJ09",126, 0)
  13184    ... S DA= "" F  S DA =$O(^PXRMI NDX(45,"IC D9","PNI", +$G(DFN),T YPE,ITEM,D ATE,DA)) Q :DA=""  S  ^TMP("VPRP X",$J,IDT, DA_";"_TYP E)=ITEM_U_ DATE
  13185   "RTN","VPR DJ09",127, 0)
  13186    Q
  13187   "RTN","VPR DJ09M")
  13188   0^65^B1020 4859
  13189   "RTN","VPR DJ09M",1,0 )
  13190   VPRDJ09M ; SLC/MKB --  Mental He alth ;9/9/ 13 4:51pm
  13191   "RTN","VPR DJ09M",2,0 )
  13192    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  13193   "RTN","VPR DJ09M",3,0 )
  13194    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  13195   "RTN","VPR DJ09M",4,0 )
  13196    ;
  13197   "RTN","VPR DJ09M",5,0 )
  13198    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  13199   "RTN","VPR DJ09M",6,0 )
  13200    ;
  13201   "RTN","VPR DJ09M",7,0 )
  13202    ;
  13203   "RTN","VPR DJ09M",8,0 )
  13204   MH ; -- Me ntal Healt h Administ rations [f rom ^VPRDJ 0]
  13205   "RTN","VPR DJ09M",9,0 )
  13206    I $G(VPRI D) D MH1(V PRID) Q
  13207   "RTN","VPR DJ09M",10, 0)
  13208    N CNT,VPR IDT,ID,FNU M,TOTAL,VP ROUT,VPRYS ,IEN
  13209   "RTN","VPR DJ09M",11, 0)
  13210    ;
  13211   "RTN","VPR DJ09M",12, 0)
  13212    S IEN=0 F   S IEN=$O (^YTT(601. 71,IEN)) Q :IEN'>0  D
  13213   "RTN","VPR DJ09M",13, 0)
  13214    .S VPRYS( "CODE")=IE N,VPRYS("D FN")=+$G(D FN),VPRYS( "LIMIT")=9 99
  13215   "RTN","VPR DJ09M",14, 0)
  13216    .K VPROUT
  13217   "RTN","VPR DJ09M",15, 0)
  13218    .D PTTEST ^YTQPXRM2( .VPROUT,.V PRYS)
  13219   "RTN","VPR DJ09M",16, 0)
  13220    .I VPROUT (1)["[ERRO R]" Q
  13221   "RTN","VPR DJ09M",17, 0)
  13222    .S TOTAL= $P(VPROUT( 1),U,2)+1
  13223   "RTN","VPR DJ09M",18, 0)
  13224    .I $P(VPR OUT(1),U,2 )<1 Q
  13225   "RTN","VPR DJ09M",19, 0)
  13226    .;S CNT=1  F  S CNT= $O(VPROUT( CNT)) Q:CN T'>0  D
  13227   "RTN","VPR DJ09M",20, 0)
  13228    .F CNT=2: 1:TOTAL D
  13229   "RTN","VPR DJ09M",21, 0)
  13230    ..I $G(VP ROUT(CNT)) ="" Q
  13231   "RTN","VPR DJ09M",22, 0)
  13232    ..S ID=$P (VPROUT(CN T),U)
  13233   "RTN","VPR DJ09M",23, 0)
  13234    ..D MH1(I D,IEN)
  13235   "RTN","VPR DJ09M",24, 0)
  13236    ;handle o ld MH test  before th e lastest  revision t o their pa ckage
  13237   "RTN","VPR DJ09M",25, 0)
  13238    ;S FNUM=6 01.2 D SOR T^VPRDJ09  ;sort ^PXR MINDX into  ^TMP("VPR PX",$J,IDT )
  13239   "RTN","VPR DJ09M",26, 0)
  13240    ;S VPRIDT =0 F  S VP RIDT=$O(^T MP("VPRPX" ,$J,VPRIDT )) Q:VPRID T<1  D  Q: VPRI'<VPRM AX
  13241   "RTN","VPR DJ09M",27, 0)
  13242    ;. S ID=0  F  S ID=$ O(^TMP("VP RPX",$J,VP RIDT,ID))  Q:ID<1  D  YT1^VPRDJ0 9(ID) Q:VP RI'<VPRMAX
  13243   "RTN","VPR DJ09M",28, 0)
  13244    ;I VPRI'< VPRMAX Q
  13245   "RTN","VPR DJ09M",29, 0)
  13246    ;handle n ew MH test   after re vision to  their pack age
  13247   "RTN","VPR DJ09M",30, 0)
  13248    ;S FNUM=6 01.84 D SO RT^VPRDJ09  ;sort ^PX RMINDX int o ^TMP("VP RPX",$J,ID T)
  13249   "RTN","VPR DJ09M",31, 0)
  13250    ;S VPRIDT =0 F  S VP RIDT=$O(^T MP("VPRPX" ,$J,VPRIDT )) Q:VPRID T<1  D  Q: VPRI'<VPRM AX
  13251   "RTN","VPR DJ09M",32, 0)
  13252    ;. S ID=0  F  S ID=$ O(^TMP("VP RPX",$J,VP RIDT,ID))  Q:ID<1  D  YT1^VPRDJ0 9(ID) Q:VP RI'<VPRMAX
  13253   "RTN","VPR DJ09M",33, 0)
  13254    K ^TMP("V PRPX",$J)
  13255   "RTN","VPR DJ09M",34, 0)
  13256    Q
  13257   "RTN","VPR DJ09M",35, 0)
  13258    ;
  13259   "RTN","VPR DJ09M",36, 0)
  13260   MH1(ID,IEN ) ; -- MH  Administra tion
  13261   "RTN","VPR DJ09M",37, 0)
  13262    N VPRY,CO PY,GBL,ISC OPY,MH,NAM E,NODE,CNT ,I,X2,X,Y, TEMP,TEXT
  13263   "RTN","VPR DJ09M",38, 0)
  13264    D ENDAS71 ^YTQPXRM6( .VPRY,ID)
  13265   "RTN","VPR DJ09M",39, 0)
  13266    ;
  13267   "RTN","VPR DJ09M",40, 0)
  13268    S NAME=$P ($G(^YTT(6 01.71,IEN, 0)),U)
  13269   "RTN","VPR DJ09M",41, 0)
  13270    S COPY=$G (^YTT(601. 71,IEN,7))
  13271   "RTN","VPR DJ09M",42, 0)
  13272    S ISCOPY= +$P($G(^YT T(601.71,I EN,8)),U,5 )
  13273   "RTN","VPR DJ09M",43, 0)
  13274    S MH("loc alId")=ID, X2=$G(VPRY (2))
  13275   "RTN","VPR DJ09M",44, 0)
  13276    S MH("uid ")=$$SETUI D^VPRUTILS ("mh",DFN, ID)
  13277   "RTN","VPR DJ09M",45, 0)
  13278    S MH("dis playName") =$P(X2,U,2 ),MH("name ")=$S(NAME '="":NAME, 1:$P(X2,U, 3))
  13279   "RTN","VPR DJ09M",46, 0)
  13280    S MH("adm inisteredD ateTime")= $$JSONDT^V PRUTILS($P (X2,U,4))
  13281   "RTN","VPR DJ09M",47, 0)
  13282    S X=$P(X2 ,U,6) I $L (X) D  ;or dered by
  13283   "RTN","VPR DJ09M",48, 0)
  13284    . S Y=+$O (^VA(200," B",X,0)),M H("provide rName")=X
  13285   "RTN","VPR DJ09M",49, 0)
  13286    . S:Y MH( "providerU id")=$$SET UID^VPRUTI LS("user", ,Y)
  13287   "RTN","VPR DJ09M",50, 0)
  13288    ;get ques tions/answ ers for te st
  13289   "RTN","VPR DJ09M",51, 0)
  13290    S I=0,CNT =0 F  S I= $O(VPRY("R ",I)) Q:I' >0  D
  13291   "RTN","VPR DJ09M",52, 0)
  13292    .S NODE=$ G(VPRY("R" ,I))
  13293   "RTN","VPR DJ09M",53, 0)
  13294    .S CNT=CN T+1
  13295   "RTN","VPR DJ09M",54, 0)
  13296    .K TEMP,^ TMP($J,"VP R MH TEXT" )
  13297   "RTN","VPR DJ09M",55, 0)
  13298    .;answers
  13299   "RTN","VPR DJ09M",56, 0)
  13300    .S TEMP=$ P(NODE,U,2 ) I TEMP>0  D
  13301   "RTN","VPR DJ09M",57, 0)
  13302    ..S MH("r esponses", CNT,"answe r","uid")= $$SETVURN^ VPRUTILS(" mha-answer ",TEMP)
  13303   "RTN","VPR DJ09M",58, 0)
  13304    ..S MH("r esponses", CNT,"answe r","text") =$P(NODE,U ,6)
  13305   "RTN","VPR DJ09M",59, 0)
  13306    .;questio ns
  13307   "RTN","VPR DJ09M",60, 0)
  13308    .S TEMP=$ P(NODE,U,3 ) I TEMP>0  D
  13309   "RTN","VPR DJ09M",61, 0)
  13310    ..S MH("r esponses", CNT,"quest ion","uid" )=$$SETVUR N^VPRUTILS ("mha-ques tion",TEMP )
  13311   "RTN","VPR DJ09M",62, 0)
  13312    ..S GBL=$ NA(^YTT(60 1.72,TEMP, 1))
  13313   "RTN","VPR DJ09M",63, 0)
  13314    ..D SETTE XT^VPRUTIL S(GBL,$NA( ^TMP($J,"V PR MH TEXT ")))
  13315   "RTN","VPR DJ09M",64, 0)
  13316    ..M MH("r esponses", CNT,"quest ion","text ","\")=^TM P($J,"VPR  MH TEXT")
  13317   "RTN","VPR DJ09M",65, 0)
  13318    ; get sca le(s) for  test
  13319   "RTN","VPR DJ09M",66, 0)
  13320    S I=0,CNT =0 F  S I= $O(VPRY("S I",I)) Q:I '>0  D
  13321   "RTN","VPR DJ09M",67, 0)
  13322    .S NODE=$ G(VPRY("SI ",I))
  13323   "RTN","VPR DJ09M",68, 0)
  13324    .S CNT=CN T+1
  13325   "RTN","VPR DJ09M",69, 0)
  13326    .S MH("sc ales",CNT, "scale","u id")=$$SET VURN^VPRUT ILS("mha-s cale",I)
  13327   "RTN","VPR DJ09M",70, 0)
  13328    .S MH("sc ales",CNT, "scale","n ame")=$P(N ODE,U,2)
  13329   "RTN","VPR DJ09M",71, 0)
  13330    .S MH("sc ales",CNT, "scale","r awScore")= $P(NODE,U, 3)
  13331   "RTN","VPR DJ09M",72, 0)
  13332    .I $P(NOD E,U,4)'=""  S MH("sca les",CNT," scale","tr ansformSco re")=$P(NO DE,U,4)
  13333   "RTN","VPR DJ09M",73, 0)
  13334    S MH("isC opyright") =$S(ISCOPY =1:"true", 1:"false")
  13335   "RTN","VPR DJ09M",74, 0)
  13336    I ISCOPY= 1 S MH("co pyrightTex t")=COPY
  13337   "RTN","VPR DJ09M",75, 0)
  13338    D ADD^VPR DJ("MH","m h")
  13339   "RTN","VPR DJ09M",76, 0)
  13340    Q
  13341   "RTN","VPR DJ1")
  13342   0^50^B1814 9314
  13343   "RTN","VPR DJ1",1,0)
  13344   VPRDJ1 ;SL C/MKB -- V PR Patient  Object RP Cs ; 11/2/ 12 5:45pm
  13345   "RTN","VPR DJ1",2,0)
  13346    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  13347   "RTN","VPR DJ1",3,0)
  13348    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  13349   "RTN","VPR DJ1",4,0)
  13350    ;
  13351   "RTN","VPR DJ1",5,0)
  13352    ;
  13353   "RTN","VPR DJ1",6,0)
  13354   PUT(VPR,PA T,TYPE,JSO N) ; -- Sa ve/update  JSON OBJEC T in ^VPR( 560.1), re turn UID i f successf ul
  13355   "RTN","VPR DJ1",7,0)
  13356    ; RPC = V PR PUT PAT IENT DATA
  13357   "RTN","VPR DJ1",8,0)
  13358    ;
  13359   "RTN","VPR DJ1",9,0)
  13360    N ARRAY,C NT,ERR,VPR ERR,UID,DA ,X,I,DFN,V PRSYS
  13361   "RTN","VPR DJ1",10,0)
  13362    ;M JSON=I NPUT(0)
  13363   "RTN","VPR DJ1",11,0)
  13364    D DECODE^ VPRJSON("J SON","ARRA Y","VPRERR ")
  13365   "RTN","VPR DJ1",12,0)
  13366    ;N XCNT S  XCNT=$O(^ XTMP("AGPA RRAY",""), -1),XCNT=X CNT+1
  13367   "RTN","VPR DJ1",13,0)
  13368    ;M ^XTMP( "AGPARRAY" ,XCNT,"DAT A")=ARRAY
  13369   "RTN","VPR DJ1",14,0)
  13370    ;S ^XTMP( "AGPARRAY" ,XCNT,"TYP E")=TYPE
  13371   "RTN","VPR DJ1",15,0)
  13372    ;M ^XTMP( "AGPARRAY" )=ARRAY
  13373   "RTN","VPR DJ1",16,0)
  13374    I $D(VPRE RR) D  Q   ;S X=$G(ER R(1)) K ER R S ERR=X  G PTQ
  13375   "RTN","VPR DJ1",17,0)
  13376    . K ARRAY  N VPRTMP, VPRTXT
  13377   "RTN","VPR DJ1",18,0)
  13378    . S VPRTX T(1)="Prob lem decodi ng json in put."
  13379   "RTN","VPR DJ1",19,0)
  13380    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.JS ON)
  13381   "RTN","VPR DJ1",20,0)
  13382    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","A RRAY","VPR ERR")
  13383   "RTN","VPR DJ1",21,0)
  13384    . S VPR(. 5)="{""api Version"": ""1.01""," "error"":{ "
  13385   "RTN","VPR DJ1",22,0)
  13386    . M VPR(1 )=ARRAY
  13387   "RTN","VPR DJ1",23,0)
  13388    . S VPR(2 )="}}"
  13389   "RTN","VPR DJ1",24,0)
  13390    ;
  13391   "RTN","VPR DJ1",25,0)
  13392    S UID=$G( ARRAY("uid ")),VPRSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  13393   "RTN","VPR DJ1",26,0)
  13394    I $L(UID)  S DA=+$O( ^VPR(560.1 ,"B",UID,0 )) I DA<1  S ERR=$$ER R(3,UID) G  PTQ
  13395   "RTN","VPR DJ1",27,0)
  13396    I '$L(UID ) D  G:$D( ERR) PTQ Q :$D(VPRERR )
  13397   "RTN","VPR DJ1",28,0)
  13398    . D NEW Q :$D(ERR)
  13399   "RTN","VPR DJ1",29,0)
  13400    . S ARRAY ("uid")=UI D K JSON
  13401   "RTN","VPR DJ1",30,0)
  13402    . D ENCOD E^VPRJSON( "ARRAY","J SON","VPRE RR")
  13403   "RTN","VPR DJ1",31,0)
  13404    . I $D(VP RERR) D  Q   ;S X=$G( ERR(1)) K  ERR S ERR= X Q
  13405   "RTN","VPR DJ1",32,0)
  13406    .. K JSON  N VPRTMP, VPRTXT
  13407   "RTN","VPR DJ1",33,0)
  13408    .. S VPRT XT(1)="Pro blem encod ing json o utput."
  13409   "RTN","VPR DJ1",34,0)
  13410    .. D SETE RROR^VPRUT ILS(.VPRTM P,.VPRERR, .VPRTXT,.A RRAY)
  13411   "RTN","VPR DJ1",35,0)
  13412    .. K VPRE RR D ENCOD E^VPRJSON( "VPRTMP"," JSON","VPR ERR")
  13413   "RTN","VPR DJ1",36,0)
  13414    .. S VPR( .5)="{""ap iVersion"" :""1.01"", ""error"": {"
  13415   "RTN","VPR DJ1",37,0)
  13416    .. M VPR( 1)=JSON
  13417   "RTN","VPR DJ1",38,0)
  13418    .. S VPR( 2)="}}"
  13419   "RTN","VPR DJ1",39,0)
  13420    ;
  13421   "RTN","VPR DJ1",40,0)
  13422    K ^VPR(56 0.1,DA,1)  S ^(1,0)=" ^560.101^^ ",CNT=0
  13423   "RTN","VPR DJ1",41,0)
  13424    S I="" F   S I=$O(JS ON(I)) Q:I =""  S CNT =CNT+1,^VP R(560.1,DA ,1,CNT,0)= JSON(I)
  13425   "RTN","VPR DJ1",42,0)
  13426    S:$G(CNT)  ^VPR(560. 1,DA,1,0)= "^560.101^ "_CNT_U_CN T
  13427   "RTN","VPR DJ1",43,0)
  13428    ;
  13429   "RTN","VPR DJ1",44,0)
  13430   PTQ ; add  item count  and termi nating cha racters
  13431   "RTN","VPR DJ1",45,0)
  13432    I $D(ERR)  S VPR="{" "apiVersio n"":""1.01 "",""error "":{""mess age"":"""_ ERR_"""}," "success"" :false}" Q
  13433   "RTN","VPR DJ1",46,0)
  13434    S VPR="{" "apiVersio n"":""1.01 "",""data" ":{""updat ed"":"_""" "_$$HL7NOW _""""_","" uid"":"""_ UID_"""}," "success"" :true}"
  13435   "RTN","VPR DJ1",47,0)
  13436    S DFN=+$P (UID,":",5 )
  13437   "RTN","VPR DJ1",48,0)
  13438    D POST^VP REVNT(DFN, TYPE,DA) ; UID)
  13439   "RTN","VPR DJ1",49,0)
  13440    Q
  13441   "RTN","VPR DJ1",50,0)
  13442    ;
  13443   "RTN","VPR DJ1",51,0)
  13444   NEW ; -- c reate new  entry in ^ VPR(560.1)  from PAT, TYPE,VPRSY S
  13445   "RTN","VPR DJ1",52,0)
  13446    ;  Return  UID & DA,  or ERR
  13447   "RTN","VPR DJ1",53,0)
  13448    N DFN,ICN
  13449   "RTN","VPR DJ1",54,0)
  13450    S DFN=+$G (PAT),ICN= "",TYPE=$G (TYPE)
  13451   "RTN","VPR DJ1",55,0)
  13452    I DFN<1,D FN[";" S I CN=+$P($G( DFN),";",2 ),DFN=+$G( DFN)
  13453   "RTN","VPR DJ1",56,0)
  13454    I DFN<1,I CN S DFN=+ $$GETDFN^M PIF001(ICN )
  13455   "RTN","VPR DJ1",57,0)
  13456    I DFN<1!' $D(^DPT(DF N)) S ERR= $$ERR(1,DF N) Q
  13457   "RTN","VPR DJ1",58,0)
  13458    I TYPE=""  S ERR=$$E RR(2,"null ") Q
  13459   "RTN","VPR DJ1",59,0)
  13460    ;
  13461   "RTN","VPR DJ1",60,0)
  13462    S DA=$$NE XTIFN I DA <1 S ERR=$ $ERR(4) Q
  13463   "RTN","VPR DJ1",61,0)
  13464    S UID="ur n:va:"_TYP E_":"_VPRS YS_":"_DFN _":"_DA
  13465   "RTN","VPR DJ1",62,0)
  13466    S ^VPR(56 0.1,DA,0)= UID_U_DFN_ U_TYPE
  13467   "RTN","VPR DJ1",63,0)
  13468    S ^VPR(56 0.1,"B",UI D,DA)=""
  13469   "RTN","VPR DJ1",64,0)
  13470    S ^VPR(56 0.1,"C",DF N,TYPE,DA) =""
  13471   "RTN","VPR DJ1",65,0)
  13472    Q
  13473   "RTN","VPR DJ1",66,0)
  13474    ;
  13475   "RTN","VPR DJ1",67,0)
  13476   NEXTIFN()  ; -- Retur ns next av ailable IF N
  13477   "RTN","VPR DJ1",68,0)
  13478    N I,HDR,T OTAL,DA
  13479   "RTN","VPR DJ1",69,0)
  13480    L +^VPR(5 60.1,0):$S ($G(DILOCK TM)>0:DILO CKTM,1:5)
  13481   "RTN","VPR DJ1",70,0)
  13482    I '$T Q " ^"
  13483   "RTN","VPR DJ1",71,0)
  13484    S HDR=$G( ^VPR(560.1 ,0)),TOTAL =+$P(HDR,U ,4),I=$O(^ VPR(560.1, "?"),-1)
  13485   "RTN","VPR DJ1",72,0)
  13486    F I=(I+1) :1 Q:'$D(^ VPR(560.1, I,0))
  13487   "RTN","VPR DJ1",73,0)
  13488    S DA=I,$P (HDR,U,3,4 )=DA_U_(TO TAL+1) S ^ VPR(560.1, 0)=HDR
  13489   "RTN","VPR DJ1",74,0)
  13490    L -^VPR(5 60.1,0)
  13491   "RTN","VPR DJ1",75,0)
  13492    Q DA
  13493   "RTN","VPR DJ1",76,0)
  13494    ;
  13495   "RTN","VPR DJ1",77,0)
  13496   ERR(X,VAL)  ; -- retu rn error m essage
  13497   "RTN","VPR DJ1",78,0)
  13498    N MSG  S  MSG="Error "
  13499   "RTN","VPR DJ1",79,0)
  13500    I X=1  S  MSG="Patie nt with df n '"_$G(VA L)_"' not  found"
  13501   "RTN","VPR DJ1",80,0)
  13502    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  13503   "RTN","VPR DJ1",81,0)
  13504    I X=3  S  MSG="UID ' "_$G(VAL)_ "' not fou nd"
  13505   "RTN","VPR DJ1",82,0)
  13506    I X=4  S  MSG="Unabl e to creat e new obje ct"
  13507   "RTN","VPR DJ1",83,0)
  13508    I X=99 S  MSG="Unkno wn request "
  13509   "RTN","VPR DJ1",84,0)
  13510    Q MSG
  13511   "RTN","VPR DJ1",85,0)
  13512    ;
  13513   "RTN","VPR DJ1",86,0)
  13514   HL7NOW() ;  -- Return  current t ime in HL7  format
  13515   "RTN","VPR DJ1",87,0)
  13516    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  13517   "RTN","VPR DJ1",88,0)
  13518    ;
  13519   "RTN","VPR DJ1",89,0)
  13520   CONV ; --  convert ui d format
  13521   "RTN","VPR DJ1",90,0)
  13522    N DA,X0,U ID,VPRSYS, DFN,COLL,N EW,I,JSON, VPRY,ERR,C NT
  13523   "RTN","VPR DJ1",91,0)
  13524    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  13525   "RTN","VPR DJ1",92,0)
  13526    S DA=0 F   S DA=$O(^ VPR(560.1, DA)) Q:DA< 1  D
  13527   "RTN","VPR DJ1",93,0)
  13528    . S X0=$G (^VPR(560. 1,DA,0)),U ID=$P(X0,U )
  13529   "RTN","VPR DJ1",94,0)
  13530    . K ^VPR( 560.1,"B", UID,DA),JS ON
  13531   "RTN","VPR DJ1",95,0)
  13532    . S DFN=$ P(X0,"^",2 ),COLL=$P( X0,"^",3)
  13533   "RTN","VPR DJ1",96,0)
  13534    . S NEW=" urn:va:"_C OLL_":"_VP RSYS_":"_D FN_":"_DA
  13535   "RTN","VPR DJ1",97,0)
  13536    . S $P(^V PR(560.1,D A,0),U)=NE W,^VPR(560 .1,"B",NEW ,DA)=""
  13537   "RTN","VPR DJ1",98,0)
  13538    . ;decode  JSON obje ct, reset  uid
  13539   "RTN","VPR DJ1",99,0)
  13540    . S I=0 F   S I=$O(^ VPR(560.1, DA,1,I)) Q :I<1  S JS ON(I)=$G(^ (I,0))
  13541   "RTN","VPR DJ1",100,0 )
  13542    . Q:'$D(J SON)  K VP RY,ERR
  13543   "RTN","VPR DJ1",101,0 )
  13544    . D DECOD E^VPRJSON( "JSON","VP RY","ERR")  I $D(ERR)  W !,DA Q
  13545   "RTN","VPR DJ1",102,0 )
  13546    . S VPRY( "uid")=NEW  K JSON
  13547   "RTN","VPR DJ1",103,0 )
  13548    . D ENCOD E^VPRJSON( "VPRY","JS ON","ERR")  I $D(ERR)  W !,DA Q
  13549   "RTN","VPR DJ1",104,0 )
  13550    . K ^VPR( 560.1,DA,1 ) S ^(1,0) ="^560.101 ^^",CNT=0
  13551   "RTN","VPR DJ1",105,0 )
  13552    . S I=""  F  S I=$O( JSON(I)) Q :I=""  S C NT=CNT+1,^ VPR(560.1, DA,1,CNT,0 )=JSON(I)
  13553   "RTN","VPR DJ1",106,0 )
  13554    . S:$G(CN T) ^VPR(56 0.1,DA,1,0 )="^560.10 1^"_CNT_U_ CNT
  13555   "RTN","VPR DJ1",107,0 )
  13556    Q
  13557   "RTN","VPR DJ2")
  13558   0^51^B2110 0510
  13559   "RTN","VPR DJ2",1,0)
  13560   VPRDJ2 ;SL C/MKB -- V PR Object  RPCs ; 1/1 8/13 3:54p m
  13561   "RTN","VPR DJ2",2,0)
  13562    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  13563   "RTN","VPR DJ2",3,0)
  13564    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  13565   "RTN","VPR DJ2",4,0)
  13566    ;
  13567   "RTN","VPR DJ2",5,0)
  13568    ;
  13569   "RTN","VPR DJ2",6,0)
  13570   GET(VPR,FI LTER) ; --  Return se arch resul ts as JSON  in @VPR@( n)
  13571   "RTN","VPR DJ2",7,0)
  13572    ; RPC = V PR GET OBJ ECT
  13573   "RTN","VPR DJ2",8,0)
  13574    N TYPE,VP RMAX,VPRI, VPRID,VPRE RR,IEN
  13575   "RTN","VPR DJ2",9,0)
  13576    S VPR=$NA (^TMP("VPR ",$J)),VPR I=0 K @VPR
  13577   "RTN","VPR DJ2",10,0)
  13578    ;
  13579   "RTN","VPR DJ2",11,0)
  13580    ; parse &  validate  input para meters
  13581   "RTN","VPR DJ2",12,0)
  13582    S TYPE=$G (FILTER("c ollection" )),TYPE=$$ LOW^XLFSTR (TYPE)
  13583   "RTN","VPR DJ2",13,0)
  13584    S VPRMAX= +$G(FILTER ("max"),99 99) ;??
  13585   "RTN","VPR DJ2",14,0)
  13586    S VPRID=$ G(FILTER(" id"))
  13587   "RTN","VPR DJ2",15,0)
  13588    ;
  13589   "RTN","VPR DJ2",16,0)
  13590    ;set erro r trap
  13591   "RTN","VPR DJ2",17,0)
  13592    N $ES,$ET ,ERRARRY,E RRDOM,ERRP AT,ERRMSG
  13593   "RTN","VPR DJ2",18,0)
  13594    ;S $ET="D  ERRHDLR^V PRDERRH G  ERRQ^VPRDJ 0"
  13595   "RTN","VPR DJ2",19,0)
  13596    S ERRDOM= "vpr",ERRM SG=$G(TYPE )
  13597   "RTN","VPR DJ2",20,0)
  13598    K ^TMP($J ,"VPR ERRO R")
  13599   "RTN","VPR DJ2",21,0)
  13600    ;
  13601   "RTN","VPR DJ2",22,0)
  13602    ; extract  data
  13603   "RTN","VPR DJ2",23,0)
  13604    I $L(VPRI D) D  G GQ
  13605   "RTN","VPR DJ2",24,0)
  13606    . S IEN=+ VPRID I 'I EN S IEN=+ $O(^VPR(56 0.11,"B",V PRID,0)) ; IEN or UID
  13607   "RTN","VPR DJ2",25,0)
  13608    . D:IEN V PR1^VPRDJ0 2(560.11,I EN)
  13609   "RTN","VPR DJ2",26,0)
  13610    I TYPE=""  S VPRERR= "Missing o r invalid  collection  type" G G Q
  13611   "RTN","VPR DJ2",27,0)
  13612    S IEN=0 F   S IEN=$O (^VPR(560. 11,"C",TYP E,IEN)) Q: IEN<1  D V PR1^VPRDJ0 2(560.11,I EN)
  13613   "RTN","VPR DJ2",28,0)
  13614    ;
  13615   "RTN","VPR DJ2",29,0)
  13616   GQ ;build  return JSO N
  13617   "RTN","VPR DJ2",30,0)
  13618    D GTQ^VPR DJ
  13619   "RTN","VPR DJ2",31,0)
  13620    Q
  13621   "RTN","VPR DJ2",32,0)
  13622    ;
  13623   "RTN","VPR DJ2",33,0)
  13624   DEL(VPR,VP RID) ; --  Delete obj ect VPRID  from ^VPR( 560.11)
  13625   "RTN","VPR DJ2",34,0)
  13626    ; RPC = V PR DELETE  OBJECT
  13627   "RTN","VPR DJ2",35,0)
  13628    ;
  13629   "RTN","VPR DJ2",36,0)
  13630    N ACTION, ERR,UID,DA ,DIK,TYPE
  13631   "RTN","VPR DJ2",37,0)
  13632    S UID=$G( VPRID) I ' $L(UID) S  ERR=$$ERR( 3,"null")  G PTQ
  13633   "RTN","VPR DJ2",38,0)
  13634    S DA=+$O( ^VPR(560.1 1,"B",UID, 0)) I DA<1  S ERR=$$E RR(3,UID)  G PTQ
  13635   "RTN","VPR DJ2",39,0)
  13636    S DIK="^V PR(560.11, " D ^DIK
  13637   "RTN","VPR DJ2",40,0)
  13638    S ACTION= "@",TYPE=$ P(UID,":", 3)
  13639   "RTN","VPR DJ2",41,0)
  13640    G PTQ
  13641   "RTN","VPR DJ2",42,0)
  13642    Q
  13643   "RTN","VPR DJ2",43,0)
  13644    ;
  13645   "RTN","VPR DJ2",44,0)
  13646   PUT(VPR,TY PE,JSON) ;  -- Save/u pdate JSON  OBJECT in  ^VPR(560. 11), retur n UID if s uccessful
  13647   "RTN","VPR DJ2",45,0)
  13648    ; RPC = V PR PUT OBJ ECT
  13649   "RTN","VPR DJ2",46,0)
  13650    ;
  13651   "RTN","VPR DJ2",47,0)
  13652    N ACTION, ARRAY,CNT, ERR,VPRERR ,UID,DA,X, I,VPRSYS
  13653   "RTN","VPR DJ2",48,0)
  13654    D DECODE^ VPRJSON("J SON","ARRA Y","VPRERR ")
  13655   "RTN","VPR DJ2",49,0)
  13656    ;N XCNT S  XCNT=$O(^ XTMP("AGPA RRAY",""), -1),XCNT=X CNT+1
  13657   "RTN","VPR DJ2",50,0)
  13658    ;M ^XTMP( "AGPARRAY" ,XCNT,"DAT A")=ARRAY
  13659   "RTN","VPR DJ2",51,0)
  13660    ;S ^XTMP( "AGPARRAY" ,XCNT,"TYP E")=TYPE
  13661   "RTN","VPR DJ2",52,0)
  13662    I $D(VPRE RR) D  Q   ;S X=$G(ER R(1)) K ER R S ERR=X  G PTQ
  13663   "RTN","VPR DJ2",53,0)
  13664    . K ARRAY  N VPRTMP, VPRTXT
  13665   "RTN","VPR DJ2",54,0)
  13666    . S VPRTX T(1)="Prob lem decodi ng json in put."
  13667   "RTN","VPR DJ2",55,0)
  13668    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.JS ON)
  13669   "RTN","VPR DJ2",56,0)
  13670    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","A RRAY","VPR ERR")
  13671   "RTN","VPR DJ2",57,0)
  13672    . S VPR(. 5)="{""api Version"": ""1.01""," "error"":{ "
  13673   "RTN","VPR DJ2",58,0)
  13674    . M VPR(1 )=ARRAY
  13675   "RTN","VPR DJ2",59,0)
  13676    . S VPR(2 )="}}"
  13677   "RTN","VPR DJ2",60,0)
  13678    ;
  13679   "RTN","VPR DJ2",61,0)
  13680    S UID=$G( ARRAY("uid ")),VPRSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  13681   "RTN","VPR DJ2",62,0)
  13682    I $L(UID)  S DA=+$O( ^VPR(560.1 1,"B",UID, 0)) I DA<1  S ERR=$$E RR(3,UID)  G PTQ
  13683   "RTN","VPR DJ2",63,0)
  13684    ;I $L(UID ) S DA=+$O (^VPR(560. 11,"B",UID ,0)) I DA< 1 D NEW1(U ID)
  13685   "RTN","VPR DJ2",64,0)
  13686    I '$L(UID ) D  G:$D( ERR) PTQ Q :$D(VPRERR )
  13687   "RTN","VPR DJ2",65,0)
  13688    . D NEW Q :$D(ERR)
  13689   "RTN","VPR DJ2",66,0)
  13690    . S ARRAY ("uid")=UI D K JSON
  13691   "RTN","VPR DJ2",67,0)
  13692    . D ENCOD E^VPRJSON( "ARRAY","J SON","VPRE RR")
  13693   "RTN","VPR DJ2",68,0)
  13694    . I $D(VP RERR) D  Q   ;S X=$G( ERR(1)) K  ERR S ERR= X Q
  13695   "RTN","VPR DJ2",69,0)
  13696    .. K JSON  N VPRTMP, VPRTXT
  13697   "RTN","VPR DJ2",70,0)
  13698    .. S VPRT XT(1)="Pro blem encod ing json o utput."
  13699   "RTN","VPR DJ2",71,0)
  13700    .. D SETE RROR^VPRUT ILS(.VPRTM P,.VPRERR, .VPRTXT,.A RRAY)
  13701   "RTN","VPR DJ2",72,0)
  13702    .. K VPRE RR D ENCOD E^VPRJSON( "VPRTMP"," JSON","VPR ERR")
  13703   "RTN","VPR DJ2",73,0)
  13704    .. S VPR( .5)="{""ap iVersion"" :""1.01"", ""error"": {"
  13705   "RTN","VPR DJ2",74,0)
  13706    .. M VPR( 1)=JSON
  13707   "RTN","VPR DJ2",75,0)
  13708    .. S VPR( 2)="}}"
  13709   "RTN","VPR DJ2",76,0)
  13710    ;
  13711   "RTN","VPR DJ2",77,0)
  13712    K ^VPR(56 0.11,DA,1)  S ^(1,0)= "^560.111^ ^",CNT=0
  13713   "RTN","VPR DJ2",78,0)
  13714    S I="" F   S I=$O(JS ON(I)) Q:I =""  S CNT =CNT+1,^VP R(560.11,D A,1,CNT,0) =JSON(I)
  13715   "RTN","VPR DJ2",79,0)
  13716    S:$G(CNT)  ^VPR(560. 11,DA,1,0) ="^560.111 ^"_CNT_U_C NT
  13717   "RTN","VPR DJ2",80,0)
  13718    ;
  13719   "RTN","VPR DJ2",81,0)
  13720   PTQ ; add  item count  and termi nating cha racters
  13721   "RTN","VPR DJ2",82,0)
  13722    I $D(ERR)  S VPR="{" "apiVersio n"":""1.01 "",""error "":{""mess age"":"""_ ERR_"""}," "success"" :false}" Q
  13723   "RTN","VPR DJ2",83,0)
  13724    S VPR="{" "apiVersio n"":""1.01 "",""data" ":{""updat ed"":"_""" "_$$HL7NOW _""""_","" uid"":"""_ UID_"""}," "success"" :true}"
  13725   "RTN","VPR DJ2",84,0)
  13726    D POSTX^V PREVNT(TYP E,DA,$G(AC TION)) ;UI D)
  13727   "RTN","VPR DJ2",85,0)
  13728    Q
  13729   "RTN","VPR DJ2",86,0)
  13730    ;
  13731   "RTN","VPR DJ2",87,0)
  13732   NEW1(UID)  ; -- creat e new entr y in ^VPR( 560.11) fr om PAT,TYP E,VPRSYS
  13733   "RTN","VPR DJ2",88,0)
  13734    ;  Return  UID & DA,  or ERR
  13735   "RTN","VPR DJ2",89,0)
  13736    S TYPE=$G (TYPE)
  13737   "RTN","VPR DJ2",90,0)
  13738    I TYPE=""  S ERR=$$E RR(2,"null ") Q
  13739   "RTN","VPR DJ2",91,0)
  13740    ;
  13741   "RTN","VPR DJ2",92,0)
  13742    S DA=$$NE XTIFN I DA <1 S ERR=$ $ERR(4) Q
  13743   "RTN","VPR DJ2",93,0)
  13744    S UID="ur n:va:"_TYP E_":"_VPRS YS_":"_DA
  13745   "RTN","VPR DJ2",94,0)
  13746    S ^VPR(56 0.11,DA,0) =UID_U_U_T YPE
  13747   "RTN","VPR DJ2",95,0)
  13748    S ^VPR(56 0.11,"B",U ID,DA)=""
  13749   "RTN","VPR DJ2",96,0)
  13750    S ^VPR(56 0.11,"C",T YPE,DA)=""
  13751   "RTN","VPR DJ2",97,0)
  13752    Q
  13753   "RTN","VPR DJ2",98,0)
  13754    ;
  13755   "RTN","VPR DJ2",99,0)
  13756   NEW ; -- c reate new  entry in ^ VPR(560.11 ) from PAT ,TYPE,VPRS YS
  13757   "RTN","VPR DJ2",100,0 )
  13758    ;  Return  UID & DA,  or ERR
  13759   "RTN","VPR DJ2",101,0 )
  13760    S TYPE=$G (TYPE)
  13761   "RTN","VPR DJ2",102,0 )
  13762    I TYPE=""  S ERR=$$E RR(2,"null ") Q
  13763   "RTN","VPR DJ2",103,0 )
  13764    ;
  13765   "RTN","VPR DJ2",104,0 )
  13766    S DA=$$NE XTIFN I DA <1 S ERR=$ $ERR(4) Q
  13767   "RTN","VPR DJ2",105,0 )
  13768    S UID="ur n:va:"_TYP E_":"_VPRS YS_":"_DA
  13769   "RTN","VPR DJ2",106,0 )
  13770    S ^VPR(56 0.11,DA,0) =UID_U_U_T YPE
  13771   "RTN","VPR DJ2",107,0 )
  13772    S ^VPR(56 0.11,"B",U ID,DA)=""
  13773   "RTN","VPR DJ2",108,0 )
  13774    S ^VPR(56 0.11,"C",T YPE,DA)=""
  13775   "RTN","VPR DJ2",109,0 )
  13776    Q
  13777   "RTN","VPR DJ2",110,0 )
  13778    ;
  13779   "RTN","VPR DJ2",111,0 )
  13780   NEXTIFN()  ; -- Retur ns next av ailable IF N
  13781   "RTN","VPR DJ2",112,0 )
  13782    N I,HDR,T OTAL,DA
  13783   "RTN","VPR DJ2",113,0 )
  13784    L +^VPR(5 60.11,0):$ S($G(DILOC KTM)>0:DIL OCKTM,1:5)
  13785   "RTN","VPR DJ2",114,0 )
  13786    I '$T Q " ^"
  13787   "RTN","VPR DJ2",115,0 )
  13788    S HDR=$G( ^VPR(560.1 1,0)),TOTA L=+$P(HDR, U,4),I=$O( ^VPR(560.1 1,"?"),-1)
  13789   "RTN","VPR DJ2",116,0 )
  13790    F I=(I+1) :1 Q:'$D(^ VPR(560.11 ,I,0))
  13791   "RTN","VPR DJ2",117,0 )
  13792    S DA=I,$P (HDR,U,3,4 )=DA_U_(TO TAL+1) S ^ VPR(560.11 ,0)=HDR
  13793   "RTN","VPR DJ2",118,0 )
  13794    L -^VPR(5 60.11,0)
  13795   "RTN","VPR DJ2",119,0 )
  13796    Q DA
  13797   "RTN","VPR DJ2",120,0 )
  13798    ;
  13799   "RTN","VPR DJ2",121,0 )
  13800   ERR(X,VAL)  ; -- retu rn error m essage
  13801   "RTN","VPR DJ2",122,0 )
  13802    N MSG  S  MSG="Error "
  13803   "RTN","VPR DJ2",123,0 )
  13804    I X=1  S  MSG="Patie nt with df n '"_$G(VA L)_"' not  found"
  13805   "RTN","VPR DJ2",124,0 )
  13806    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  13807   "RTN","VPR DJ2",125,0 )
  13808    I X=3  S  MSG="UID ' "_$G(VAL)_ "' not fou nd"
  13809   "RTN","VPR DJ2",126,0 )
  13810    I X=4  S  MSG="Unabl e to creat e new obje ct"
  13811   "RTN","VPR DJ2",127,0 )
  13812    I X=99 S  MSG="Unkno wn request "
  13813   "RTN","VPR DJ2",128,0 )
  13814    Q MSG
  13815   "RTN","VPR DJ2",129,0 )
  13816    ;
  13817   "RTN","VPR DJ2",130,0 )
  13818   HL7NOW() ;  -- Return  current t ime in HL7  format
  13819   "RTN","VPR DJ2",131,0 )
  13820    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  13821   "RTN","VPR DJFS")
  13822   0^85^B5686 6811
  13823   "RTN","VPR DJFS",1,0)
  13824   VPRDJFS ;S LC/KCM --  Asynchrono us Extract s and Fres hness via  stream
  13825   "RTN","VPR DJFS",2,0)
  13826    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  13827   "RTN","VPR DJFS",3,0)
  13828    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  13829   "RTN","VPR DJFS",4,0)
  13830    ;
  13831   "RTN","VPR DJFS",5,0)
  13832    ;
  13833   "RTN","VPR DJFS",6,0)
  13834    ; PUT/POS T   call $ $TAG^ROUTI NE(.args,. body)
  13835   "RTN","VPR DJFS",7,0)
  13836    ; GET/DEL ETE call    TAG^ROUTI NE(.respon se,.args)
  13837   "RTN","VPR DJFS",8,0)
  13838    ;
  13839   "RTN","VPR DJFS",9,0)
  13840    ; TODO: c hange this  to use ^V PR(560) in stead of ^ XTMP("VPRF P")
  13841   "RTN","VPR DJFS",10,0 )
  13842    ; TODO: c reate func tion to bu ild ARGS f rom PATH
  13843   "RTN","VPR DJFS",11,0 )
  13844    ; TODO: c reate func tion to re turn TAG^R OUTINE fro m MTHD,PAT H
  13845   "RTN","VPR DJFS",12,0 )
  13846    ;
  13847   "RTN","VPR DJFS",13,0 )
  13848    ; todo: g et the big  sync work ing
  13849   "RTN","VPR DJFS",14,0 )
  13850    ; todo: c hange to u se RPC cal ls
  13851   "RTN","VPR DJFS",15,0 )
  13852    ; todo: a dd in fres hness 
  13853   "RTN","VPR DJFS",16,0 )
  13854    ;
  13855   "RTN","VPR DJFS",17,0 )
  13856   REST(VPRFR SP,MTHD,PA TH,BODY) ;  call here  for RESTf ul style
  13857   "RTN","VPR DJFS",18,0 )
  13858    ; results  end up in  ^TMP("VPR F",$J)
  13859   "RTN","VPR DJFS",19,0 )
  13860    K ^TMP("V PRF",$J),^ TMP("VPRFE RR",$J)
  13861   "RTN","VPR DJFS",20,0 )
  13862    ; parse a nd branch  to appropr iate routi ne
  13863   "RTN","VPR DJFS",21,0 )
  13864    N VPRFOK  S VPRFOK=0
  13865   "RTN","VPR DJFS",22,0 )
  13866    S MTHD=$$ UP^XLFSTR( MTHD)
  13867   "RTN","VPR DJFS",23,0 )
  13868    I MTHD="P UT"!(MTHD= "POST"),($ $LOW^XLFST R(PATH)="v pr/subscri ption") D
  13869   "RTN","VPR DJFS",24,0 )
  13870    . N LOC
  13871   "RTN","VPR DJFS",25,0 )
  13872    . S LOC=$ $PUTSUB^VP RDJFSP("", .BODY),VPR FOK=1
  13873   "RTN","VPR DJFS",26,0 )
  13874    . I $L(LO C) S ^TMP( "VPRF",$J, 1)="{""api Version"": ""1.0"","" location"" :"""_LOC_" ""}"
  13875   "RTN","VPR DJFS",27,0 )
  13876    I MTHD="D ELETE" ;
  13877   "RTN","VPR DJFS",28,0 )
  13878    I MTHD="G ET",$P($$L OW^XLFSTR( PATH),"/", 1,3)="/vpr /subscript ion" D
  13879   "RTN","VPR DJFS",29,0 )
  13880    . N ARGS  ;/vpr/subs cription/{ hmpSrvId}/ {last}?lim it={limit}
  13881   "RTN","VPR DJFS",30,0 )
  13882    . S ARGS( "hmpSrvId" )=$P(PATH, "/",4) Q:' $L(ARGS("h mpSrvId"))
  13883   "RTN","VPR DJFS",31,0 )
  13884    . S ARGS( "last")=$P (PATH,"/", 5) Q:'$L(A RGS("last" ))
  13885   "RTN","VPR DJFS",32,0 )
  13886    . S PATH= $$LOW^XLFS TR(PATH),V PRFOK=1
  13887   "RTN","VPR DJFS",33,0 )
  13888    . I PATH[ "?limit="  S ARGS("li mit")=+$P( PATH,"?lim it=",2)
  13889   "RTN","VPR DJFS",34,0 )
  13890    . D GETSU B^VPRDJFSG (.VPRFRSP, .ARGS)
  13891   "RTN","VPR DJFS",35,0 )
  13892    I 'VPRFOK  ; set met hod/path n ot found e rror
  13893   "RTN","VPR DJFS",36,0 )
  13894    ;
  13895   "RTN","VPR DJFS",37,0 )
  13896    I $D(^TMP ("VPRFERR" ,$J)) S VP RFRSP=$NA( ^TMP("VPRF ERR",$J))  Q  ; error  
  13897   "RTN","VPR DJFS",38,0 )
  13898    S VPRFRSP =$NA(^TMP( "VPRF",$J) )                                   ; norma l
  13899   "RTN","VPR DJFS",39,0 )
  13900    Q
  13901   "RTN","VPR DJFS",40,0 )
  13902    ;
  13903   "RTN","VPR DJFS",41,0 )
  13904   API(VPRFRS P,ARGS) ;
  13905   "RTN","VPR DJFS",42,0 )
  13906    N VPRFERR ,CNT,ACNT
  13907   "RTN","VPR DJFS",43,0 )
  13908    K ^TMP("V PRF",$J)
  13909   "RTN","VPR DJFS",44,0 )
  13910    S VPRFRSP =$NA(^TMP( "VPRF",$J) )
  13911   "RTN","VPR DJFS",45,0 )
  13912    I ARGS("c ommand")=" putPtSubsc ription" D   Q
  13913   "RTN","VPR DJFS",46,0 )
  13914    . N BODY, ERROR,LOC
  13915   "RTN","VPR DJFS",47,0 )
  13916    . D ENCOD E^VPRJSON( "ARGS","BO DY","ERROR ")
  13917   "RTN","VPR DJFS",48,0 )
  13918    . I $D(ER ROR) D SET ERR("Error  encoding  JSON") Q
  13919   "RTN","VPR DJFS",49,0 )
  13920    . S LOC=$ $PUTSUB^VP RDJFSP("", .BODY)
  13921   "RTN","VPR DJFS",50,0 )
  13922    . I $L(LO C) S ^TMP( "VPRF",$J, 1)="{""api Version"": ""1.0"","" location"" :"""_LOC_" ""}"
  13923   "RTN","VPR DJFS",51,0 )
  13924    I ARGS("c ommand")=" startOpera tionalData Extract" D   Q
  13925   "RTN","VPR DJFS",52,0 )
  13926    . N BODY, ERROR,LOC
  13927   "RTN","VPR DJFS",53,0 )
  13928    . S ARGS( "isOperati onal")="tr ue"
  13929   "RTN","VPR DJFS",54,0 )
  13930    . D ENCOD E^VPRJSON( "ARGS","BO DY","ERROR ")
  13931   "RTN","VPR DJFS",55,0 )
  13932    . I $D(ER ROR) D SET ERR("Error  encoding  JSON") Q
  13933   "RTN","VPR DJFS",56,0 )
  13934    . S LOC=$ $PUTSUB^VP RDJFSP("", .BODY)
  13935   "RTN","VPR DJFS",57,0 )
  13936    . ;S LOC= $$PUTSUB^V PREFSP("", .BODY)
  13937   "RTN","VPR DJFS",58,0 )
  13938    . I $L(LO C) S ^TMP( "VPRF",$J, 1)="{""api Version"": ""1.0"","" location"" :"""_LOC_" ""}"
  13939   "RTN","VPR DJFS",59,0 )
  13940    I ARGS("c ommand")=" getPtUpdat es" D  Q
  13941   "RTN","VPR DJFS",60,0 )
  13942    . D GETSU B^VPRDJFSG (VPRFRSP,. ARGS)
  13943   "RTN","VPR DJFS",61,0 )
  13944    I ARGS("c ommand")=" resetAllSu bscription s" D  Q
  13945   "RTN","VPR DJFS",62,0 )
  13946    . D RESET SVR(.ARGS)
  13947   "RTN","VPR DJFS",63,0 )
  13948    . ;I $G(A RGS("serve r"))="" Q
  13949   "RTN","VPR DJFS",64,0 )
  13950    . ;I $G(A RGS("patie ntId"))>0  D CLEARPAT (ARGS("ser ver"),ARGS ("patientI d")) Q
  13951   "RTN","VPR DJFS",65,0 )
  13952    . ;I $G(A RGS("domai n"))'="" D  CLEARDOM( ARGS("serv er"),ARGS( "domain"))  Q
  13953   "RTN","VPR DJFS",66,0 )
  13954    . ;D KILL SVR(ARGS(" server"))
  13955   "RTN","VPR DJFS",67,0 )
  13956    . S ^TMP( "VPRF",$J, 1)="{""api Version"": ""1.0"","" removed"": ""true""}"
  13957   "RTN","VPR DJFS",68,0 )
  13958    ;
  13959   "RTN","VPR DJFS",69,0 )
  13960    D SETERR( "command n ot recogni zed")  ; s hould not  get this f ar
  13961   "RTN","VPR DJFS",70,0 )
  13962    Q
  13963   "RTN","VPR DJFS",71,0 )
  13964    ;
  13965   "RTN","VPR DJFS",72,0 )
  13966    ; --- del ete a pati ent subscr iption
  13967   "RTN","VPR DJFS",73,0 )
  13968    ;
  13969   "RTN","VPR DJFS",74,0 )
  13970   DELSUB(RSP ,ARGS) ; c ancel a su bscription
  13971   "RTN","VPR DJFS",75,0 )
  13972    ; DELETE  with: /vpr /subscript ion/{hmpSr vId}/patie nt/{pid}
  13973   "RTN","VPR DJFS",76,0 )
  13974    ; remove  patient fr om VPR SUB SCRIPTION  file
  13975   "RTN","VPR DJFS",77,0 )
  13976    ; remove  ^XTMP(VPRX  and ^XTMP (VPRH node s
  13977   "RTN","VPR DJFS",78,0 )
  13978    ; look ah ead (from  lastId) an d remove a ny nodes f or the pat ient
  13979   "RTN","VPR DJFS",79,0 )
  13980    N DFN,HMP SRV,BATCH, HMPSRVID
  13981   "RTN","VPR DJFS",80,0 )
  13982    S DFN=$$D FN(ARGS("p id")) Q:$D (VPRFERR)
  13983   "RTN","VPR DJFS",81,0 )
  13984    S HMPSRV= ARGS("hmpS rvId")
  13985   "RTN","VPR DJFS",82,0 )
  13986    S BATCH=" VPRFX~"_HM PSRV_"~"_D FN
  13987   "RTN","VPR DJFS",83,0 )
  13988    L +^XTMP( "VPRFP",DF N,HMPSRV): 20 E  D SE TERR("unab le to get  lock") Q
  13989   "RTN","VPR DJFS",84,0 )
  13990    ; if extr act still  running, i t should r emove itse lf when it  finishes
  13991   "RTN","VPR DJFS",85,0 )
  13992    K ^XTMP(" VPRFX~"_HM PSRV_"~"_D FN) ; kill  extract n odes
  13993   "RTN","VPR DJFS",86,0 )
  13994    K ^XTMP(" VPRFH~"_HM PSRV_"~"_D FN) ; kill  held fres hness upda tes
  13995   "RTN","VPR DJFS",87,0 )
  13996    ; remove  all nodes  for this p atient bet ween "last " and "nex t"
  13997   "RTN","VPR DJFS",88,0 )
  13998    ; loop fo rward from  "last" in  ^XTMP("VP RFP",0,hmp Srv) and r emove node s for this  DFN
  13999   "RTN","VPR DJFS",89,0 )
  14000    K ^XTMP(" VPRFP",DFN ,HMPSRV)       ; kill  subscript ion
  14001   "RTN","VPR DJFS",90,0 )
  14002    D DELPT(D FN,HMPSRV)
  14003   "RTN","VPR DJFS",91,0 )
  14004    ;K ^VPR(5 60,$O(^VPR (560,"B",H MPSRV,"")) ,1,DFN),^V PR(560,"AI TEM",DFN,H MPSRV)
  14005   "RTN","VPR DJFS",92,0 )
  14006    L -^XTMP( "VPRFP",DF N,HMPSRV)
  14007   "RTN","VPR DJFS",93,0 )
  14008    S RSP="{" "apiVersio n"":""1.0" ",""succes s"":""true ""}" ; if  successful
  14009   "RTN","VPR DJFS",94,0 )
  14010    Q
  14011   "RTN","VPR DJFS",95,0 )
  14012   DELPT(DFN, SRV) ; del ete patien t DFN for  server SRV
  14013   "RTN","VPR DJFS",96,0 )
  14014    N DIK,DA
  14015   "RTN","VPR DJFS",97,0 )
  14016    S DA(1)=$ O(^VPR(560 ,"B",SRV," ")) Q:'DA( 1)
  14017   "RTN","VPR DJFS",98,0 )
  14018    S DA=DFN  Q:'DA
  14019   "RTN","VPR DJFS",99,0 )
  14020    S DIK="^V PR(560,"_D A(1)_",1,"
  14021   "RTN","VPR DJFS",100, 0)
  14022    D ^DIK
  14023   "RTN","VPR DJFS",101, 0)
  14024    Q
  14025   "RTN","VPR DJFS",102, 0)
  14026    ;
  14027   "RTN","VPR DJFS",103, 0)
  14028    ; --- pos t freshnes s updates  (internal  to VistA)
  14029   "RTN","VPR DJFS",104, 0)
  14030    ;
  14031   "RTN","VPR DJFS",105, 0)
  14032   POST(DFN,T YPE,ID,ACT ,SERVER,NO DES) ; add s new fres hness item , return D T-seq
  14033   "RTN","VPR DJFS",106, 0)
  14034    ; if init ializing u se: ^XTMP( "VPRFH-hmp serverid-d fn",seq#)     -hold
  14035   "RTN","VPR DJFS",107, 0)
  14036    ;       o therwise u se: ^XTMP( "VPRFS-hmp serverid-d ate",seq#)    -stream
  14037   "RTN","VPR DJFS",108, 0)
  14038    ;
  14039   "RTN","VPR DJFS",109, 0)
  14040    ; loop th rough subs cribing st reams for  this patie nt
  14041   "RTN","VPR DJFS",110, 0)
  14042    ; if pati ent is ini tialized f or an hmp  server sen d events d irectly to  stream
  14043   "RTN","VPR DJFS",111, 0)
  14044    ; otherwi se, events  go to tem porary hol ding area
  14045   "RTN","VPR DJFS",112, 0)
  14046    ; initial  extracts  always to  directly t o stream
  14047   "RTN","VPR DJFS",113, 0)
  14048    N HMPSRV, INIT,STREA M,DATE,SEQ ,CNT
  14049   "RTN","VPR DJFS",114, 0)
  14050    S DATE=$$ DT^XLFDT
  14051   "RTN","VPR DJFS",115, 0)
  14052    S HMPSRV= "" F  S HM PSRV=$O(^V PR(560,"AI TEM",DFN,H MPSRV)) Q: '$L(HMPSRV )  D
  14053   "RTN","VPR DJFS",116, 0)
  14054    .I SERVER '="",HMPSR V'=SERVER  Q
  14055   "RTN","VPR DJFS",117, 0)
  14056    . I '$D(^ VPR(560,"A ITEM",DFN, HMPSRV)) Q            ; patient  not subscr ibed
  14057   "RTN","VPR DJFS",118, 0)
  14058    . S INIT= (^VPR(560, "AITEM",DF N,HMPSRV)= 2),CNT=1   ; 2 means  patient in itialized
  14059   "RTN","VPR DJFS",119, 0)
  14060    . I $E(TY PE,1,4)="s ync" S INI T=1               ; s ync* goes  to main st ream
  14061   "RTN","VPR DJFS",120, 0)
  14062    . I TYPE= "syncDomai n" S CNT=+ $P(ID,":", 3) S:CNT<1  CNT=1 ; C NT must be  >0
  14063   "RTN","VPR DJFS",121, 0)
  14064    . S STREA M=$S(INIT: "VPRFS~",1 :"VPRFH~") _HMPSRV_"~ "_$S(INIT: DATE,1:DFN )
  14065   "RTN","VPR DJFS",122, 0)
  14066    . I '$D(^ XTMP(STREA M)) D NEWX TMP(STREAM ,2,"VPR Fr eshness St ream")
  14067   "RTN","VPR DJFS",123, 0)
  14068    . L +^XTM P(STREAM): 5 E  S $EC =",Uno loc k obtained ," Q  ; th row error
  14069   "RTN","VPR DJFS",124, 0)
  14070    . S SEQ=$ G(^XTMP(ST REAM,"last "),0)+CNT
  14071   "RTN","VPR DJFS",125, 0)
  14072    . S ^XTMP (STREAM,SE Q)=DFN_U_T YPE_U_ID_U _$G(ACT)
  14073   "RTN","VPR DJFS",126, 0)
  14074    . S ^XTMP (STREAM,"l ast")=SEQ
  14075   "RTN","VPR DJFS",127, 0)
  14076    . L -^XTM P(STREAM)
  14077   "RTN","VPR DJFS",128, 0)
  14078    . ; NODES (hmpserver id)=stream Date^seque nce option ally retur ned
  14079   "RTN","VPR DJFS",129, 0)
  14080    . S NODES ($P(STREAM ,"~",2))=$ S(INIT:DAT E,1:0)_U_S EQ
  14081   "RTN","VPR DJFS",130, 0)
  14082    Q
  14083   "RTN","VPR DJFS",131, 0)
  14084    ;
  14085   "RTN","VPR DJFS",132, 0)
  14086   NEWXTMP(NO DE,DAYS,DE SC) ; Set  a new node  in ^XTMP
  14087   "RTN","VPR DJFS",133, 0)
  14088    K ^XTMP(N ODE)
  14089   "RTN","VPR DJFS",134, 0)
  14090    S ^XTMP(N ODE,0)=$$H TFM^XLFDT( +$H+DAYS)_ U_$$HTFM^X LFDT(+$H)_ U_DESC
  14091   "RTN","VPR DJFS",135, 0)
  14092    Q
  14093   "RTN","VPR DJFS",136, 0)
  14094   PIDS(DFN)  ; return s tring cont aining pat ient id's  ready for  JSON
  14095   "RTN","VPR DJFS",137, 0)
  14096    ; expects  VPRFSYS
  14097   "RTN","VPR DJFS",138, 0)
  14098    Q:'DFN ""
  14099   "RTN","VPR DJFS",139, 0)
  14100    N PID,X
  14101   "RTN","VPR DJFS",140, 0)
  14102    S PID=$$P ID(DFN)
  14103   "RTN","VPR DJFS",141, 0)
  14104    S X=",""p id"":"""_P ID_""""
  14105   "RTN","VPR DJFS",142, 0)
  14106    S X=X_"," "systemId" ":"""_VPRF SYS_""""
  14107   "RTN","VPR DJFS",143, 0)
  14108    S X=X_"," "localId"" :"""_DFN_" """
  14109   "RTN","VPR DJFS",144, 0)
  14110    S X=X_"," "icn"":""" _$S(PID["; ":"",1:PID )_""""
  14111   "RTN","VPR DJFS",145, 0)
  14112    Q X
  14113   "RTN","VPR DJFS",146, 0)
  14114    ;
  14115   "RTN","VPR DJFS",147, 0)
  14116   PID(DFN) ;  return mo st likely  PID (ICN o r SYS;DFN)
  14117   "RTN","VPR DJFS",148, 0)
  14118    ; expects  VPRFSYS
  14119   "RTN","VPR DJFS",149, 0)
  14120    N PID S P ID=""
  14121   "RTN","VPR DJFS",150, 0)
  14122    I +DFN>0  D
  14123   "RTN","VPR DJFS",151, 0)
  14124    . S PID=+ $$GETICN^M PIF001(DFN ) I PID'>0  D
  14125   "RTN","VPR DJFS",152, 0)
  14126    . . I '$L ($G(VPRFSY S)) S VPRF SYS=$$GET^ XPAR("SYS" ,"VPR SYST EM NAME")
  14127   "RTN","VPR DJFS",153, 0)
  14128    . . S PID =VPRFSYS_" ;"_DFN
  14129   "RTN","VPR DJFS",154, 0)
  14130    Q PID
  14131   "RTN","VPR DJFS",155, 0)
  14132    ;
  14133   "RTN","VPR DJFS",156, 0)
  14134   DFN(PID) ;  return th e DFN give n the PID  (ICN or SY S;DFN)
  14135   "RTN","VPR DJFS",157, 0)
  14136    N DFN
  14137   "RTN","VPR DJFS",158, 0)
  14138    S PID=$TR (PID,":"," ;")
  14139   "RTN","VPR DJFS",159, 0)
  14140    I PID'["; " D  Q DFN   ; treat  as ICN
  14141   "RTN","VPR DJFS",160, 0)
  14142    . S DFN=$ $GETDFN^MP IF001(PID)
  14143   "RTN","VPR DJFS",161, 0)
  14144    . I DFN<0  D SETERR( $P(DFN,"^" ,2))
  14145   "RTN","VPR DJFS",162, 0)
  14146    ; otherwi se
  14147   "RTN","VPR DJFS",163, 0)
  14148    I $P(PID, ";")'=$$GE T^XPAR("SY S","VPR SY STEM NAME" ) D SETERR ("DFN unkn own to thi s system")  Q 0
  14149   "RTN","VPR DJFS",164, 0)
  14150    Q $P(PID, ";",2)
  14151   "RTN","VPR DJFS",165, 0)
  14152    ;
  14153   "RTN","VPR DJFS",166, 0)
  14154    ; --- han dle errors
  14155   "RTN","VPR DJFS",167, 0)
  14156    ;
  14157   "RTN","VPR DJFS",168, 0)
  14158   SETERR(MSG ) ; create  error obj ect in ^TM P("VPRFERR ",$J) and  set VPRFER R
  14159   "RTN","VPR DJFS",169, 0)
  14160    ; TODO: e scape MSG  for JSON
  14161   "RTN","VPR DJFS",170, 0)
  14162    S @VPRFRS P@(1)="{"" apiVersion "":""1.0"" ,""error"" :{""messag e"":"""_MS G_"""}}"
  14163   "RTN","VPR DJFS",171, 0)
  14164    S ^TMP("V PRFERR",$J ,$H)=MSG
  14165   "RTN","VPR DJFS",172, 0)
  14166    S VPRFERR =1
  14167   "RTN","VPR DJFS",173, 0)
  14168    Q
  14169   "RTN","VPR DJFS",174, 0)
  14170    ;
  14171   "RTN","VPR DJFS",175, 0)
  14172   DEBUG(MSG)  ;
  14173   "RTN","VPR DJFS",176, 0)
  14174    S ^TMP("V PRDEBUG",$ J,0)=$G(^T MP("VPRDEB UG",$J,0), 0)+1
  14175   "RTN","VPR DJFS",177, 0)
  14176    I $D(MSG) '=1 M ^TMP ("VPRDEBUG ",$J,^TMP( "VPRDEBUG" ,$J,0))=MS G
  14177   "RTN","VPR DJFS",178, 0)
  14178    E  S ^TMP ("VPRDEBUG ",$J,^TMP( "VPRDEBUG" ,$J,0))=MS G
  14179   "RTN","VPR DJFS",179, 0)
  14180    Q
  14181   "RTN","VPR DJFS",180, 0)
  14182   RESETSVR(A RGS) ;
  14183   "RTN","VPR DJFS",181, 0)
  14184    N DA,DIE, DIK,DR,IEN ,SRV,SRVIE N,X
  14185   "RTN","VPR DJFS",182, 0)
  14186    S SRV=$G( ARGS("serv er")) I SR V="" Q
  14187   "RTN","VPR DJFS",183, 0)
  14188    S DA=$O(^ VPR(560,"B ",SRV,""))  I DA'>0 Q
  14189   "RTN","VPR DJFS",184, 0)
  14190    S SRVIEN= DA
  14191   "RTN","VPR DJFS",185, 0)
  14192    L +^VPR(5 60,SRVIEN) :5 E  S $E C=",Uno lo ck obtaine d," Q
  14193   "RTN","VPR DJFS",186, 0)
  14194    ;delete o perational  data fiel d
  14195   "RTN","VPR DJFS",187, 0)
  14196    S DIE="^V PR(560,",D R=".03///@ " D ^DIE
  14197   "RTN","VPR DJFS",188, 0)
  14198    S DA(1)=D A,DA=0
  14199   "RTN","VPR DJFS",189, 0)
  14200    ;delate p atient mul tiple valu es
  14201   "RTN","VPR DJFS",190, 0)
  14202    S DIK="^V PR(560,"_D A(1)_",1,"
  14203   "RTN","VPR DJFS",191, 0)
  14204    F  S DA=$ O(^VPR(560 ,DA(1),1,D A)) Q:DA'> 0  D ^DIK
  14205   "RTN","VPR DJFS",192, 0)
  14206    ;kill ser ver ^XTMP
  14207   "RTN","VPR DJFS",193, 0)
  14208    S X="VPRF " F  S X=$ O(^XTMP(X) ) Q:$E(X,1 ,4)'="VPRF "  D
  14209   "RTN","VPR DJFS",194, 0)
  14210    . I X[SRV  K ^XTMP(X ) I 1
  14211   "RTN","VPR DJFS",195, 0)
  14212    ;kill tid y node
  14213   "RTN","VPR DJFS",196, 0)
  14214    K ^XTMP(" VPRFP","ti dy",SRV)
  14215   "RTN","VPR DJFS",197, 0)
  14216    L -^VPR(5 60,SRVIEN)
  14217   "RTN","VPR DJFS",198, 0)
  14218    Q
  14219   "RTN","VPR DJFS",199, 0)
  14220    ;
  14221   "RTN","VPR DJFS",200, 0)
  14222   CLEARDOM(S VR,PAT) ;
  14223   "RTN","VPR DJFS",201, 0)
  14224    Q
  14225   "RTN","VPR DJFS",202, 0)
  14226    ;
  14227   "RTN","VPR DJFS",203, 0)
  14228   CLEARPAT(S VR,PAT) ;
  14229   "RTN","VPR DJFS",204, 0)
  14230    I '$D(^XT MP("VPRFP" ,PAT,SVR))  Q
  14231   "RTN","VPR DJFS",205, 0)
  14232    ;do we ne ed a check  for patie nt initial ized?
  14233   "RTN","VPR DJFS",206, 0)
  14234    K ^XTMP(" VPRFP",PAT ,SVR)
  14235   "RTN","VPR DJFS",207, 0)
  14236    Q
  14237   "RTN","VPR DJFS",208, 0)
  14238    ;
  14239   "RTN","VPR DJFS",209, 0)
  14240   VPRSET(DA, NEW) ;
  14241   "RTN","VPR DJFS",210, 0)
  14242    N IEN,NAM E
  14243   "RTN","VPR DJFS",211, 0)
  14244    S IEN=0 F   S IEN=$O (^VPR(560, IEN)) Q:IE N'>0  D
  14245   "RTN","VPR DJFS",212, 0)
  14246    .S NAME=$ P(^VPR(560 ,IEN,0),U)
  14247   "RTN","VPR DJFS",213, 0)
  14248    .I $D(^VP R(560,IEN, 1,NEW(1))) >0 S ^VPR( 560,"AITEM ",NEW(1),N AME)=NEW(2 )
  14249   "RTN","VPR DJFS",214, 0)
  14250    Q
  14251   "RTN","VPR DJFS",215, 0)
  14252    ;
  14253   "RTN","VPR DJFS",216, 0)
  14254   VPRKILL(DA ,OLD) ;
  14255   "RTN","VPR DJFS",217, 0)
  14256    N NAME
  14257   "RTN","VPR DJFS",218, 0)
  14258    S NAME=$P ($G(^VPR(5 60,DA(1),0 )),U) I NA ME="" Q
  14259   "RTN","VPR DJFS",219, 0)
  14260    K ^VPR(56 0,"AITEM", OLD(1),NAM E)
  14261   "RTN","VPR DJFS",220, 0)
  14262    Q
  14263   "RTN","VPR DJFS",221, 0)
  14264    ;
  14265   "RTN","VPR DJFS",222, 0)
  14266   VPROSET(DA ,NEW) ;
  14267   "RTN","VPR DJFS",223, 0)
  14268    N IEN,NAM E
  14269   "RTN","VPR DJFS",224, 0)
  14270    S IEN=0 F   S IEN=$O (^VPR(560, IEN)) Q:IE N'>0  D
  14271   "RTN","VPR DJFS",225, 0)
  14272    .S NAME=$ P(^VPR(560 ,IEN,0),U)
  14273   "RTN","VPR DJFS",226, 0)
  14274    .S ^VPR(5 60,"AITEM" ,"OPD",NAM E)=NEW
  14275   "RTN","VPR DJFS",227, 0)
  14276    Q
  14277   "RTN","VPR DJFS",228, 0)
  14278    ;
  14279   "RTN","VPR DJFS",229, 0)
  14280   VPROKILL(D A) ;
  14281   "RTN","VPR DJFS",230, 0)
  14282    N NAME
  14283   "RTN","VPR DJFS",231, 0)
  14284    S NAME=$P ($G(^VPR(5 60,DA,0)), U) I NAME= "" Q
  14285   "RTN","VPR DJFS",232, 0)
  14286    K ^VPR(56 0,"AITEM", "OPD",NAME )
  14287   "RTN","VPR DJFS",233, 0)
  14288    Q
  14289   "RTN","VPR DJFS",234, 0)
  14290   KILL ; cle ar out all  ^XTMP nod es
  14291   "RTN","VPR DJFS",235, 0)
  14292    N X
  14293   "RTN","VPR DJFS",236, 0)
  14294    S X="VPRF " F  S X=$ O(^XTMP(X) ) Q:$E(X,1 ,4)'="VPRF "  W !,X   K ^XTMP(X)
  14295   "RTN","VPR DJFS",237, 0)
  14296    Q
  14297   "RTN","VPR DJFS",238, 0)
  14298   KILLSVR(SV R) ; clear  out for s pecific ma shine
  14299   "RTN","VPR DJFS",239, 0)
  14300    N X
  14301   "RTN","VPR DJFS",240, 0)
  14302    S X="VPRF " F  S X=$ O(^XTMP(X) ) Q:$E(X,1 ,4)'="VPRF "  D
  14303   "RTN","VPR DJFS",241, 0)
  14304    . I X[SVR  W !,X  K  ^XTMP(X) I  1
  14305   "RTN","VPR DJFS",242, 0)
  14306    S X="" F   S X=$O(^X TMP("VPRFP ",X)) Q:X= ""  D
  14307   "RTN","VPR DJFS",243, 0)
  14308    . I $D(^X TMP("VPRFP ",X,SVR))  K ^XTMP("V PRFP",X,SV R)
  14309   "RTN","VPR DJFS",244, 0)
  14310    Q
  14311   "RTN","VPR DJFSG")
  14312   0^86^B9451 9786
  14313   "RTN","VPR DJFSG",1,0 )
  14314   VPRDJFSG ; SLC/KCM --  GET for E xtract and  Freshness  Stream
  14315   "RTN","VPR DJFSG",2,0 )
  14316    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  14317   "RTN","VPR DJFSG",3,0 )
  14318    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  14319   "RTN","VPR DJFSG",4,0 )
  14320    ;
  14321   "RTN","VPR DJFSG",5,0 )
  14322    ;
  14323   "RTN","VPR DJFSG",6,0 )
  14324    ; --- ret rieve upda tes for an  HMP serve r's subscr iptions
  14325   "RTN","VPR DJFSG",7,0 )
  14326    ;
  14327   "RTN","VPR DJFSG",8,0 )
  14328   GETSUB(VPR FRSP,ARGS)  ; retriev e items fr om stream
  14329   "RTN","VPR DJFSG",9,0 )
  14330    ;      GE T from: /v pr/subscri ption/{hmp SrvId}/{la st}?limit= {limit}
  14331   "RTN","VPR DJFSG",10, 0)
  14332    ; ARGS("l ast") : da te-seq of  last item  retrieved  (ex. 31312 06-27)
  14333   "RTN","VPR DJFSG",11, 0)
  14334    ; ARGS("l imit"): ma ximum numb er of item s to retur n (default  99999)
  14335   "RTN","VPR DJFSG",12, 0)
  14336    ;
  14337   "RTN","VPR DJFSG",13, 0)
  14338    ; VPRFSYS  : the id  (hash) of  the VistA  system
  14339   "RTN","VPR DJFSG",14, 0)
  14340    ; VPRFHMP  : the nam e of the H MP server 
  14341   "RTN","VPR DJFSG",15, 0)
  14342    ; VPRFSEQ  : final s equence (b ecomes nex t LASTSEQ)
  14343   "RTN","VPR DJFSG",16, 0)
  14344    ; VPRFIDX  : index t o iterate  from LASTS EQ to fina l sequence
  14345   "RTN","VPR DJFSG",17, 0)
  14346    ; VPRFLAS T: used to  clean up  extracts p rior to th is
  14347   "RTN","VPR DJFSG",18, 0)
  14348    ; VPRFSTR M: the ext ract/fresh ness strea m (VPRFS-h mpSrvId-fm Date) 
  14349   "RTN","VPR DJFSG",19, 0)
  14350    ; (most v ariables n amespaced  since call ing variet y of extra cts)
  14351   "RTN","VPR DJFSG",20, 0)
  14352    ;
  14353   "RTN","VPR DJFSG",21, 0)
  14354    K ^TMP("V PRF",$J)
  14355   "RTN","VPR DJFSG",22, 0)
  14356    N VPRFSYS ,VPRFHMP,V PRFSTRM,VP RFLAST,VPR FDT,VPRFLI M,VPRFSEQ, VPRFIDX,VP RFCNT,SNOD E,STYPE,VP RFERR,VPRD EL,VPRERR, VPRSTGET
  14357   "RTN","VPR DJFSG",23, 0)
  14358    S VPRFRSP =$NA(^TMP( "VPRF",$J) )
  14359   "RTN","VPR DJFSG",24, 0)
  14360    S VPRFSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  14361   "RTN","VPR DJFSG",25, 0)
  14362    S VPRFHMP =$TR($G(AR GS("server ")),"~","= ")
  14363   "RTN","VPR DJFSG",26, 0)
  14364    I '$L(VPR FHMP) D SE TERR^VPRDJ FS("Missin g HMP Serv er ID") Q
  14365   "RTN","VPR DJFSG",27, 0)
  14366    S VPRFDT= $P($G(ARGS ("lastUpda te")),"-")
  14367   "RTN","VPR DJFSG",28, 0)
  14368    S VPRFSEQ =+$P($G(AR GS("lastUp date")),"- ",2)
  14369   "RTN","VPR DJFSG",29, 0)
  14370    S VPRSTGE T=$G(ARGS( "getStatus "))
  14371   "RTN","VPR DJFSG",30, 0)
  14372    ; stream  goes back  a maximum  of 2 days
  14373   "RTN","VPR DJFSG",31, 0)
  14374    I VPRFDT< $$FMADD^XL FDT($$DT^X LFDT,-2) S  VPRFDT=$$ HTFM^XLFDT (+$H-2),VP RFSEQ=0
  14375   "RTN","VPR DJFSG",32, 0)
  14376    S VPRFLAS T=VPRFDT_" -"_VPRFSEQ
  14377   "RTN","VPR DJFSG",33, 0)
  14378    D LASTUPD (VPRFHMP,V PRFLAST)
  14379   "RTN","VPR DJFSG",34, 0)
  14380    S VPRFLIM =$G(ARGS(" max"),9999 9)
  14381   "RTN","VPR DJFSG",35, 0)
  14382    S VPRFSTR M="VPRFS~" _VPRFHMP_" ~"_VPRFDT  ; stream i dentifier
  14383   "RTN","VPR DJFSG",36, 0)
  14384    S VPRFCNT =0,VPRFIDX =VPRFSEQ
  14385   "RTN","VPR DJFSG",37, 0)
  14386    F  D  Q:V PRFCNT'<VP RFLIM  D N XTSTRM Q:V PRFSTRM=""
  14387   "RTN","VPR DJFSG",38, 0)
  14388    . F  S VP RFIDX=$O(^ XTMP(VPRFS TRM,VPRFID X)) Q:'VPR FIDX  D  Q :VPRFCNT'< VPRFLIM
  14389   "RTN","VPR DJFSG",39, 0)
  14390    . . S SNO DE=^XTMP(V PRFSTRM,VP RFIDX),STY PE=$P(SNOD E,U,2)
  14391   "RTN","VPR DJFSG",40, 0)
  14392    . . I STY PE="syncNo op" Q                       ; sk ip, patien t was unsu bscribed
  14393   "RTN","VPR DJFSG",41, 0)
  14394    . . I STY PE="syncDo main" D DO MITMS Q          ; ad d multiple  extract i tems
  14395   "RTN","VPR DJFSG",42, 0)
  14396    . . S VPR FSEQ=VPRFI DX
  14397   "RTN","VPR DJFSG",43, 0)
  14398    . . I STY PE="syncEr ror" D SYN CERR(SNODE ,.VPRERR)  Q
  14399   "RTN","VPR DJFSG",44, 0)
  14400    . . I STY PE="syncSt art" D SYN CSTRT(SNOD E) Q  ; be gin initia l extracti on
  14401   "RTN","VPR DJFSG",45, 0)
  14402    . . I STY PE="syncDo ne" D SYNC DONE(SNODE ) Q   ; en d of initi al extract ion
  14403   "RTN","VPR DJFSG",46, 0)
  14404    . . D FRE SHITM(SNOD E,.VPRDEL, .VPRERR)                           ; freshn ess item
  14405   "RTN","VPR DJFSG",47, 0)
  14406    Q:$G(VPRF ERR)
  14407   "RTN","VPR DJFSG",48, 0)
  14408    D FINISH( .VPRDEL,.V PRERR)
  14409   "RTN","VPR DJFSG",49, 0)
  14410    Q
  14411   "RTN","VPR DJFSG",50, 0)
  14412   DOMITMS ;  loop thru  extract it ems, OFFSE T is last  sent
  14413   "RTN","VPR DJFSG",51, 0)
  14414    ; expects  VPRFSTRM, VPRFIDX,VP RFHMP
  14415   "RTN","VPR DJFSG",52, 0)
  14416    ; changes  VPRFSEQ,V PRFCNT as  each item  added
  14417   "RTN","VPR DJFSG",53, 0)
  14418    N X,OFFSE T,DFN,PIDS ,DOMAIN,TA SK,BATCH,T OTAL
  14419   "RTN","VPR DJFSG",54, 0)
  14420    S X=^XTMP (VPRFSTRM, VPRFIDX),D FN=$P(X,U)
  14421   "RTN","VPR DJFSG",55, 0)
  14422    I DFN="OP D" D DOMIT MS^VPREFSG  Q
  14423   "RTN","VPR DJFSG",56, 0)
  14424    S PIDS=$$ PIDS^VPRDJ FS(DFN)
  14425   "RTN","VPR DJFSG",57, 0)
  14426    S X=$P(X, U,3),DOMAI N=$P(X,":" ),TASK=$P( X,":",2),T OTAL=$P(X, ":",4)
  14427   "RTN","VPR DJFSG",58, 0)
  14428    S BATCH=" VPRFX~"_VP RFHMP_"~"_ DFN        ; extract  node in ^X TMP
  14429   "RTN","VPR DJFSG",59, 0)
  14430    S OFFSET= TOTAL-(VPR FIDX-VPRFS EQ)
  14431   "RTN","VPR DJFSG",60, 0)
  14432    ;S OFFSET =.9                               ; skip no des < 1
  14433   "RTN","VPR DJFSG",61, 0)
  14434    ;I 'VPRFC NT S OFFSE T=VPRFIDX- VPRFSEQ+.9  ; in case  starting  mid-extrac t
  14435   "RTN","VPR DJFSG",62, 0)
  14436    F  S OFFS ET=$O(^XTM P(BATCH,TA SK,DOMAIN, OFFSET)) Q :'OFFSET   D  Q:VPRFC NT'<VPRFLI M
  14437   "RTN","VPR DJFSG",63, 0)
  14438    . S VPRFC NT=VPRFCNT +1 ; incre ment the c ount of re turned ite ms
  14439   "RTN","VPR DJFSG",64, 0)
  14440    . S VPRFS EQ=VPRFSEQ +1 ; incre ment the s equence nu mber in th e stream
  14441   "RTN","VPR DJFSG",65, 0)
  14442    . M ^TMP( "VPRF",$J, VPRFCNT)=^ XTMP(BATCH ,TASK,DOMA IN,OFFSET)
  14443   "RTN","VPR DJFSG",66, 0)
  14444    . S ^TMP( "VPRF",$J, VPRFCNT,.3 )=$$WRAPPE R(DOMAIN,P IDS,$S('TO TAL:0,1:OF FSET),+TOT AL)
  14445   "RTN","VPR DJFSG",67, 0)
  14446    Q
  14447   "RTN","VPR DJFSG",68, 0)
  14448   MIDXTRCT()  ; Return  true if mi d-extract
  14449   "RTN","VPR DJFSG",69, 0)
  14450    ; from GE TSUB expec ts VPRFSTR M,VPRFSEQ
  14451   "RTN","VPR DJFSG",70, 0)
  14452    I 'VPRFSE Q Q 0
  14453   "RTN","VPR DJFSG",71, 0)
  14454    I '$D(^XT MP(VPRFSTR M,VPRFSEQ) ) Q 1                    ; middl e of extra ct
  14455   "RTN","VPR DJFSG",72, 0)
  14456    I $P(^XTM P(VPRFSTRM ,VPRFSEQ), U,2)="sync Domain" Q  1  ; just  starting e xtract
  14457   "RTN","VPR DJFSG",73, 0)
  14458    Q 0
  14459   "RTN","VPR DJFSG",74, 0)
  14460    ;
  14461   "RTN","VPR DJFSG",75, 0)
  14462   NXTSTRM ;  Reset vari ables for  next date  in this HM P stream
  14463   "RTN","VPR DJFSG",76, 0)
  14464    ; from GE TSUB expec ts VPRFSTR M,VPRFDT,V PRFIDX
  14465   "RTN","VPR DJFSG",77, 0)
  14466    ; VPRFSTR M set to " " if no ne xt stream
  14467   "RTN","VPR DJFSG",78, 0)
  14468    ; VPRFIDX   set to 0  if next s tream, or  left as is
  14469   "RTN","VPR DJFSG",79, 0)
  14470    ; VPRFDT    set to l ast date a ctually us ed
  14471   "RTN","VPR DJFSG",80, 0)
  14472    N NEXTDT, DONE
  14473   "RTN","VPR DJFSG",81, 0)
  14474    S NEXTDT= VPRFDT,DON E=0
  14475   "RTN","VPR DJFSG",82, 0)
  14476    F  D  Q:D ONE
  14477   "RTN","VPR DJFSG",83, 0)
  14478    . S NEXTD T=$$FMADD^ XLFDT(NEXT DT,1)
  14479   "RTN","VPR DJFSG",84, 0)
  14480    . I NEXTD T>$$DT^XLF DT S VPRFS TRM="" S D ONE=1 Q
  14481   "RTN","VPR DJFSG",85, 0)
  14482    . S $P(VP RFSTRM,"~" ,3)=NEXTDT
  14483   "RTN","VPR DJFSG",86, 0)
  14484    . I '+$O( ^XTMP(VPRF STRM,0)) Q   ; nothin g here, tr y next dat e
  14485   "RTN","VPR DJFSG",87, 0)
  14486    . S VPRFD T=NEXTDT,V PRFIDX=0,V PRFSEQ=0,D ONE=1
  14487   "RTN","VPR DJFSG",88, 0)
  14488    Q
  14489   "RTN","VPR DJFSG",89, 0)
  14490   FINISH(VPR DEL,VPRERR ) ;reset t he FIRST o bject deli miter, add  header an d tail
  14491   "RTN","VPR DJFSG",90, 0)
  14492    ; expects  VPRFCNT,V PRFDT,VPRF SEQ,VPRFHM P,VPRFLAST
  14493   "RTN","VPR DJFSG",91, 0)
  14494    N CLOSE,I ,START,TEX T,UID,X,II
  14495   "RTN","VPR DJFSG",92, 0)
  14496    S X=$G(^T MP("VPRF", $J,1,.3))
  14497   "RTN","VPR DJFSG",93, 0)
  14498    I $E(X,1, 2)="}," S  X=$E(X,3,$ L(X)),^TMP ("VPRF",$J ,1,.3)=X
  14499   "RTN","VPR DJFSG",94, 0)
  14500    S ^TMP("V PRF",$J,.5 )=$$APIHDR (VPRFCNT,V PRFDT_"-"_ VPRFSEQ)
  14501   "RTN","VPR DJFSG",95, 0)
  14502    ;delete n ode
  14503   "RTN","VPR DJFSG",96, 0)
  14504    I $D(VPRD EL) D
  14505   "RTN","VPR DJFSG",97, 0)
  14506    .S CLOSE= $S(VPRFCNT :"},",1:"" ),START=1
  14507   "RTN","VPR DJFSG",98, 0)
  14508    .;S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)=CLO SE_"]}"
  14509   "RTN","VPR DJFSG",99, 0)
  14510    .S VPRFCN T=VPRFCNT+ 1,^TMP("VP RF",$J,VPR FCNT)=CLOS E_"{""dele tes"":["
  14511   "RTN","VPR DJFSG",100 ,0)
  14512    .S UID=""  F  S UID= $O(VPRDEL( UID)) Q:UI D=""  D
  14513   "RTN","VPR DJFSG",101 ,0)
  14514    ..S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)=$S( START:"",1 :",")_"{"" uid"":"""_ UID_"""}"  S START=0
  14515   "RTN","VPR DJFSG",102 ,0)
  14516    .S VPRFCN T=VPRFCNT+ 1,^TMP("VP RF",$J,VPR FCNT)="]"
  14517   "RTN","VPR DJFSG",103 ,0)
  14518    ;error no de
  14519   "RTN","VPR DJFSG",104 ,0)
  14520    I $D(VPRE RR) D
  14521   "RTN","VPR DJFSG",105 ,0)
  14522    .S CLOSE= $S(VPRFCNT :"},",1:"" ),START=1
  14523   "RTN","VPR DJFSG",106 ,0)
  14524    .;S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)=CLO SE_"]}"
  14525   "RTN","VPR DJFSG",107 ,0)
  14526    .S VPRFCN T=VPRFCNT+ 1,^TMP("VP RF",$J,VPR FCNT)=CLOS E_"{""erro r"":["
  14527   "RTN","VPR DJFSG",108 ,0)
  14528    .S I=0 F   S I=$O(VP RERR(I)) Q :I'>0  D
  14529   "RTN","VPR DJFSG",109 ,0)
  14530    ..S TEXT= VPRERR(I)
  14531   "RTN","VPR DJFSG",110 ,0)
  14532    ..S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)=$S( START:"",1 :",")_TEXT  S START=0
  14533   "RTN","VPR DJFSG",111 ,0)
  14534    .S VPRFCN T=VPRFCNT+ 1,^TMP("VP RF",$J,VPR FCNT)="]"
  14535   "RTN","VPR DJFSG",112 ,0)
  14536    S ^TMP("V PRF",$J,VP RFCNT+1)=$ S(VPRFCNT: "}",1:"")_ "]",VPRFCN T=VPRFCNT+ 1
  14537   "RTN","VPR DJFSG",113 ,0)
  14538    I $G(VPRS TGET)="tru e" D
  14539   "RTN","VPR DJFSG",114 ,0)
  14540    . S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)="," "syncStati i"":[",STA RT=1
  14541   "RTN","VPR DJFSG",115 ,0)
  14542    . S I=0 F   S I=$O(^ VPR(560,I) ) Q:+I=0   D
  14543   "RTN","VPR DJFSG",116 ,0)
  14544    . . I $P( $G(^VPR(56 0,I,0)),"^ ",1)=VPRFH MP D
  14545   "RTN","VPR DJFSG",117 ,0)
  14546    . . . S I I=0 F  S I I=$O(^VPR( 560,I,1,II )) Q:+II=0   D
  14547   "RTN","VPR DJFSG",118 ,0)
  14548    . . . . S  TEXT="{"" pid"":"_II _",""statu s"":"_$P(^ VPR(560,I, 1,II,0),"^ ",2)_"}"
  14549   "RTN","VPR DJFSG",119 ,0)
  14550    . . . . S  VPRFCNT=V PRFCNT+1,^ TMP("VPRF" ,$J,VPRFCN T)=$S(STAR T:"",1:"," )_TEXT S S TART=0
  14551   "RTN","VPR DJFSG",120 ,0)
  14552    . S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)="]"
  14553   "RTN","VPR DJFSG",121 ,0)
  14554    S ^TMP("V PRF",$J,VP RFCNT+1)=" }}"
  14555   "RTN","VPR DJFSG",122 ,0)
  14556    ;I '$D(VP RDEL),'$D( VPRERR) S  ^TMP("VPRF ",$J,VPRFC NT+1)=$S(V PRFCNT:"}" ,1:"")_"]} }"
  14557   "RTN","VPR DJFSG",123 ,0)
  14558    ;I $D(VPR DEL)!($D(V PRERR)) S  ^TMP("VPRF ",$J,VPRFC NT+1)="}"
  14559   "RTN","VPR DJFSG",124 ,0)
  14560    ;
  14561   "RTN","VPR DJFSG",125 ,0)
  14562    ; remove  any ^XTMP  nodes that  have been  successfu lly sent b ased on LA ST
  14563   "RTN","VPR DJFSG",126 ,0)
  14564    N DATE,SE Q,LASTDT,L ASTSEQ
  14565   "RTN","VPR DJFSG",127 ,0)
  14566    S LASTDT= +$P(VPRFLA ST,"-"),LA STSEQ=+$P( VPRFLAST," -",2)
  14567   "RTN","VPR DJFSG",128 ,0)
  14568    S DATE=0  F  S DATE= $O(^XTMP(" VPRFP","ti dy",VPRFHM P,DATE)) Q :'DATE  Q: DATE>LASTD T  D
  14569   "RTN","VPR DJFSG",129 ,0)
  14570    . I DATE< LASTDT D
  14571   "RTN","VPR DJFSG",130 ,0)
  14572    . . S SEQ =0 F  S SE Q=$O(^XTMP ("VPRFP"," tidy",VPRF HMP,DATE,S EQ)) Q:'SE Q  D TIDYX (DATE,SEQ)
  14573   "RTN","VPR DJFSG",131 ,0)
  14574    . I DATE= LASTDT D
  14575   "RTN","VPR DJFSG",132 ,0)
  14576    . . S SEQ =0 F  S SE Q=$O(^XTMP ("VPRFP"," tidy",VPRF HMP,DATE,S EQ)) Q:'SE Q  Q:SEQ>L ASTSEQ  D  TIDYX(DATE ,SEQ)
  14577   "RTN","VPR DJFSG",133 ,0)
  14578    Q
  14579   "RTN","VPR DJFSG",134 ,0)
  14580   TIDYX(DATE ,SEQ) ; cl ean up ext racts afte r they hav e been ret rieved
  14581   "RTN","VPR DJFSG",135 ,0)
  14582    ; from FI NISH expec ts VPRFHMP
  14583   "RTN","VPR DJFSG",136 ,0)
  14584    N BATCH
  14585   "RTN","VPR DJFSG",137 ,0)
  14586    S BATCH=^ XTMP("VPRF P","tidy", VPRFHMP,DA TE,SEQ)
  14587   "RTN","VPR DJFSG",138 ,0)
  14588    K ^XTMP(B ATCH)
  14589   "RTN","VPR DJFSG",139 ,0)
  14590    K ^XTMP(" VPRFP","ti dy",VPRFHM P,DATE,SEQ )
  14591   "RTN","VPR DJFSG",140 ,0)
  14592    Q
  14593   "RTN","VPR DJFSG",141 ,0)
  14594   SYNCSTRT(S EQNODE) ;  Build sync Start obje ct with de mograhics
  14595   "RTN","VPR DJFSG",142 ,0)
  14596    N DFN,FIL TER,DFN
  14597   "RTN","VPR DJFSG",143 ,0)
  14598    S DFN=$P( $P(SEQNODE ,U,3),"~", 3) ; VPRFX ~hmpSrvId~ dfn
  14599   "RTN","VPR DJFSG",144 ,0)
  14600    I DFN="OP D" D SYNCS TRT^VPREFS G Q
  14601   "RTN","VPR DJFSG",145 ,0)
  14602    S FILTER( "patientId ")=DFN,FIL TER("domai n")="patie nt"
  14603   "RTN","VPR DJFSG",146 ,0)
  14604    D GET^VPR DJ(.RSLT,. FILTER)
  14605   "RTN","VPR DJFSG",147 ,0)
  14606    S VPRFCNT =VPRFCNT+1
  14607   "RTN","VPR DJFSG",148 ,0)
  14608    M ^TMP("V PRF",$J,VP RFCNT)=^TM P("VPR",$J ,1)
  14609   "RTN","VPR DJFSG",149 ,0)
  14610    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER( "syncStart ",$$PIDS^V PRDJFS(DFN ),1,1)
  14611   "RTN","VPR DJFSG",150 ,0)
  14612    Q
  14613   "RTN","VPR DJFSG",151 ,0)
  14614   SYNCDONE(S EQNODE) ;  Build sync Status obj ect and st ick in ^TM P
  14615   "RTN","VPR DJFSG",152 ,0)
  14616    ;  expect s: VPRFSYS ,VPRFCNT
  14617   "RTN","VPR DJFSG",153 ,0)
  14618    N VPRBATC H,DFN,VPRB ATCH,STS,S TSJSON,X,E RR
  14619   "RTN","VPR DJFSG",154 ,0)
  14620    S VPRBATC H=$P(SEQNO DE,U,3) ;  VPRFX~hmpS rvId~dfn
  14621   "RTN","VPR DJFSG",155 ,0)
  14622    S DFN=$P( VPRBATCH," ~",3)
  14623   "RTN","VPR DJFSG",156 ,0)
  14624    I DFN="OP D" D SYNCD ONE^VPREFS G(SEQNODE)  Q
  14625   "RTN","VPR DJFSG",157 ,0)
  14626    S STS("ui d")="urn:v a:syncStat us:"_VPRFS YS_":"_DFN
  14627   "RTN","VPR DJFSG",158 ,0)
  14628    S STS("in itialized" )="true"
  14629   "RTN","VPR DJFSG",159 ,0)
  14630    S STS("lo calId")=DF N
  14631   "RTN","VPR DJFSG",160 ,0)
  14632    S X="" F   S X=$O(^X TMP(VPRBAT CH,0,"coun t",X)) Q:' $L(X)  D
  14633   "RTN","VPR DJFSG",161 ,0)
  14634    . S STS(" domainTota ls",X)=^XT MP(VPRBATC H,0,"count ",X)
  14635   "RTN","VPR DJFSG",162 ,0)
  14636    D ENCODE^ VPRJSON("S TS","STSJS ON","ERR")
  14637   "RTN","VPR DJFSG",163 ,0)
  14638    I $D(ERR)  S $EC=",U JSON encod e error,"  Q
  14639   "RTN","VPR DJFSG",164 ,0)
  14640    S VPRFCNT =VPRFCNT+1
  14641   "RTN","VPR DJFSG",165 ,0)
  14642    M ^TMP("V PRF",$J,VP RFCNT)=STS JSON
  14643   "RTN","VPR DJFSG",166 ,0)
  14644    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER( "syncStatu s",$$PIDS^ VPRDJFS(DF N),"",-1)
  14645   "RTN","VPR DJFSG",167 ,0)
  14646    Q
  14647   "RTN","VPR DJFSG",168 ,0)
  14648    ;
  14649   "RTN","VPR DJFSG",169 ,0)
  14650   SYNCERR(SN ODE,VPRERR ) ;
  14651   "RTN","VPR DJFSG",170 ,0)
  14652    ;M ^AGP(" snode")=SN ODE
  14653   "RTN","VPR DJFSG",171 ,0)
  14654    N BATCH,C NT,DFN,NUM ,OFFSET,PI D,TASK,TOT AL,X
  14655   "RTN","VPR DJFSG",172 ,0)
  14656    S DFN=$P( SNODE,U),X =$P(SNODE, U,3)
  14657   "RTN","VPR DJFSG",173 ,0)
  14658    ;I DFN="O PD" D DOMI TMS^VPREFS G Q
  14659   "RTN","VPR DJFSG",174 ,0)
  14660    S PIDS=$$ PIDS^VPRDJ FS(DFN)
  14661   "RTN","VPR DJFSG",175 ,0)
  14662    S TASK=$P (X,":",2), TOTAL=$P(X ,":",4)
  14663   "RTN","VPR DJFSG",176 ,0)
  14664    S BATCH=" VPRFX~"_VP RFHMP_"~"_ DFN        ; extract  node in ^X TMP
  14665   "RTN","VPR DJFSG",177 ,0)
  14666    ;S OFFSET =TOTAL-(VP RFIDX-VPRF SEQ)
  14667   "RTN","VPR DJFSG",178 ,0)
  14668    ;S OFFSET =.9                               ; skip no des < 1
  14669   "RTN","VPR DJFSG",179 ,0)
  14670    ;I 'VPRFC NT S OFFSE T=VPRFIDX- VPRFSEQ+.9  ; in case  starting  mid-extrac t
  14671   "RTN","VPR DJFSG",180 ,0)
  14672    S CNT=$O( VPRERR("") ,-1)
  14673   "RTN","VPR DJFSG",181 ,0)
  14674    S NUM=0 F   S NUM=$O (^XTMP(BAT CH,TASK,"e rror",NUM) ) Q:NUM'>0   D
  14675   "RTN","VPR DJFSG",182 ,0)
  14676    .S CNT=CN T+1 S VPRE RR(CNT)=$G (^XTMP(BAT CH,TASK,"e rror",NUM, 1))
  14677   "RTN","VPR DJFSG",183 ,0)
  14678    . ;M ^TMP ("VPRF",$J ,VPRFCNT)= ^XTMP(BATC H,TASK,DOM AIN,OFFSET )
  14679   "RTN","VPR DJFSG",184 ,0)
  14680    . ;S ^TMP ("VPRF",$J ,VPRFCNT,. 3)=$$WRAPP ER(DOMAIN, PIDS,$S('T OTAL:0,1:O FFSET),+TO TAL)
  14681   "RTN","VPR DJFSG",185 ,0)
  14682    ;I $G(ERR VAL)="" Q
  14683   "RTN","VPR DJFSG",186 ,0)
  14684    ;S ERRVAL ="{"_ERRVA L_"}"
  14685   "RTN","VPR DJFSG",187 ,0)
  14686    ;D DECODE ^VPRJSON(" ERRVAL","E RROBJ","ER R")
  14687   "RTN","VPR DJFSG",188 ,0)
  14688    ;I $D(ERR ) M ^AGP(" ERR")=ERR
  14689   "RTN","VPR DJFSG",189 ,0)
  14690    ;I $D(ERR ) S $EC=", UJSON deco de error,"
  14691   "RTN","VPR DJFSG",190 ,0)
  14692    ;K ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,"erro r")
  14693   "RTN","VPR DJFSG",191 ,0)
  14694    ;S ERRMSG =ERROBJ("e rror","mes sage")
  14695   "RTN","VPR DJFSG",192 ,0)
  14696    ;Q:'$L(ER RMSG)
  14697   "RTN","VPR DJFSG",193 ,0)
  14698    ;S SYNCER R("uid")=" urn:va:syn cError:"_V PRFSYS_":" _DFN_":"_D OMAIN
  14699   "RTN","VPR DJFSG",194 ,0)
  14700    ;S SYNCER R("collect ion")=DOMA IN
  14701   "RTN","VPR DJFSG",195 ,0)
  14702    ;S SYNCER R("error") =ERRMSG
  14703   "RTN","VPR DJFSG",196 ,0)
  14704    ;D ENCODE ^VPRJSON(" SYNCERR"," ERRJSON"," ERR") I $D (ERR) S $E C=",UJSON  encode err or,"
  14705   "RTN","VPR DJFSG",197 ,0)
  14706    ;D POST^V PRDJFS(DFN ,"syncErro r","error: "_VPRFZTSK _":1:1","" ,HMPSRV)
  14707   "RTN","VPR DJFSG",198 ,0)
  14708    Q
  14709   "RTN","VPR DJFSG",199 ,0)
  14710   FRESHITM(S EQNODE,DEL ETE,ERROR)  ; Get fre shness ite m and stic k in ^TMP
  14711   "RTN","VPR DJFSG",200 ,0)
  14712    ; TODO: i mplement t his -- add  freshness  object to  ^TMP("VPR F",$J)
  14713   "RTN","VPR DJFSG",201 ,0)
  14714    N ACT,DFN ,DOMAIN,EC NT,FILTER, ID,RSLT,UI D,VPRI,WRA P
  14715   "RTN","VPR DJFSG",202 ,0)
  14716    S FILTER( "noHead")= 1
  14717   "RTN","VPR DJFSG",203 ,0)
  14718    S DFN=$P( SEQNODE,U) ,DOMAIN=$P (SEQNODE,U ,2),ID=$P( SEQNODE,U, 3),ACT=$P( SEQNODE,U, 4)
  14719   "RTN","VPR DJFSG",204 ,0)
  14720    I ACT="@"  D  Q
  14721   "RTN","VPR DJFSG",205 ,0)
  14722    . S UID=$ $SETUID^VP RUTILS(DOM AIN,$S(+DF N>0:DFN,1: ""),ID)
  14723   "RTN","VPR DJFSG",206 ,0)
  14724    . S DELET E(UID)=""
  14725   "RTN","VPR DJFSG",207 ,0)
  14726    S FILTER( "id")=ID
  14727   "RTN","VPR DJFSG",208 ,0)
  14728    S FILTER( "domain")= DOMAIN
  14729   "RTN","VPR DJFSG",209 ,0)
  14730    I DFN="OP D" D GET^V PREF(.RSLT ,.FILTER)
  14731   "RTN","VPR DJFSG",210 ,0)
  14732    I +DFN>0  D
  14733   "RTN","VPR DJFSG",211 ,0)
  14734    . S FILTE R("patient Id")=DFN
  14735   "RTN","VPR DJFSG",212 ,0)
  14736    . D GET^V PRDJ(.RSLT ,.FILTER)
  14737   "RTN","VPR DJFSG",213 ,0)
  14738    I $L($G(^ TMP("VPR", $J,"error" )))>0 D BL DSERR(DFN, .ERROR)  Q
  14739   "RTN","VPR DJFSG",214 ,0)
  14740    ;
  14741   "RTN","VPR DJFSG",215 ,0)
  14742    I '$D(^TM P("VPR",$J ,1)) D  Q
  14743   "RTN","VPR DJFSG",216 ,0)
  14744    . S UID=$ $SETUID^VP RUTILS(DOM AIN,$S(+DF N>0:DFN,1: ""),ID)
  14745   "RTN","VPR DJFSG",217 ,0)
  14746    . S DELET E(UID)=""
  14747   "RTN","VPR DJFSG",218 ,0)
  14748    ;
  14749   "RTN","VPR DJFSG",219 ,0)
  14750    I DFN="OP D",DOMAIN= "patient"  S DFN=ID
  14751   "RTN","VPR DJFSG",220 ,0)
  14752    S WRAP=$S (DFN>0:$$W RAPPER(DOM AIN,$$PIDS ^VPRDJFS(D FN),1,1),1 :$$WRAPPER ^VPREFSG(D OMAIN,1,1) )
  14753   "RTN","VPR DJFSG",221 ,0)
  14754    F VPRI=1: 1 Q:'$D(^T MP("VPR",$ J,VPRI))   D
  14755   "RTN","VPR DJFSG",222 ,0)
  14756    . S VPRFC NT=VPRFCNT +1
  14757   "RTN","VPR DJFSG",223 ,0)
  14758    . M ^TMP( "VPRF",$J, VPRFCNT)=^ TMP("VPR", $J,VPRI)
  14759   "RTN","VPR DJFSG",224 ,0)
  14760    . S ^TMP( "VPRF",$J, VPRFCNT,.3 )=WRAP
  14761   "RTN","VPR DJFSG",225 ,0)
  14762    Q
  14763   "RTN","VPR DJFSG",226 ,0)
  14764    ;
  14765   "RTN","VPR DJFSG",227 ,0)
  14766   BLDSERR(DF N,ERROR) ;  Create sy ncError ob ject in ER RJSON
  14767   "RTN","VPR DJFSG",228 ,0)
  14768    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  14769   "RTN","VPR DJFSG",229 ,0)
  14770    N COUNT,E RRVAL,ERRO BJ,ERR,ERR MSG,SYNCER R
  14771   "RTN","VPR DJFSG",230 ,0)
  14772    ;S ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,NODE, .3)="{"  ;  replace ,  with { fo r decoding  JSON
  14773   "RTN","VPR DJFSG",231 ,0)
  14774    M ERRVAL= ^TMP("VPR" ,$J,"error ")
  14775   "RTN","VPR DJFSG",232 ,0)
  14776    I $G(ERRV AL)="" Q
  14777   "RTN","VPR DJFSG",233 ,0)
  14778    S ERRVAL= "{"_ERRVAL _"}"
  14779   "RTN","VPR DJFSG",234 ,0)
  14780    D DECODE^ VPRJSON("E RRVAL","ER ROBJ","ERR ")
  14781   "RTN","VPR DJFSG",235 ,0)
  14782    I $D(ERR)  S $EC=",U JSON decod e error,"
  14783   "RTN","VPR DJFSG",236 ,0)
  14784    S ERRMSG= ERROBJ("er ror","mess age")
  14785   "RTN","VPR DJFSG",237 ,0)
  14786    Q:'$L(ERR MSG)
  14787   "RTN","VPR DJFSG",238 ,0)
  14788    S SYNCERR ("uid")="u rn:va:sync Error:"_VP RFSYS_":"_ DFN_":FRES HNESS"
  14789   "RTN","VPR DJFSG",239 ,0)
  14790    S SYNCERR ("collecti on")=DOMAI N
  14791   "RTN","VPR DJFSG",240 ,0)
  14792    S SYNCERR ("error")= ERRMSG
  14793   "RTN","VPR DJFSG",241 ,0)
  14794    D ENCODE^ VPRJSON("S YNCERR","E RRJSON","E RR") I $D( ERR) S $EC =",UJSON e ncode erro r," Q
  14795   "RTN","VPR DJFSG",242 ,0)
  14796    S COUNT=$ O(ERROR("" ),-1)+1
  14797   "RTN","VPR DJFSG",243 ,0)
  14798    M ERROR(C OUNT)=ERRJ SON
  14799   "RTN","VPR DJFSG",244 ,0)
  14800    Q
  14801   "RTN","VPR DJFSG",245 ,0)
  14802   WRAPPER(DO MAIN,PIDS, OFFSET,TOT AL) ; retu rn JSON wr apper for  each item
  14803   "RTN","VPR DJFSG",246 ,0)
  14804    ; add obj ect tag if  extract t otal not z ero or if  total pass ed as -1
  14805   "RTN","VPR DJFSG",247 ,0)
  14806    ; seq and  total tag s only add ed if non- zero
  14807   "RTN","VPR DJFSG",248 ,0)
  14808    N X
  14809   "RTN","VPR DJFSG",249 ,0)
  14810    S X="},{" "collectio n"":"""_DO MAIN_""""_ PIDS
  14811   "RTN","VPR DJFSG",250 ,0)
  14812    I $G(OFFS ET)>0 S X= X_",""seq" ":"_OFFSET
  14813   "RTN","VPR DJFSG",251 ,0)
  14814    I $G(TOTA L)>0 S X=X _",""total "":"_TOTAL
  14815   "RTN","VPR DJFSG",252 ,0)
  14816    I $G(TOTA L) S X=X_" ,""object" ":"
  14817   "RTN","VPR DJFSG",253 ,0)
  14818    Q X
  14819   "RTN","VPR DJFSG",254 ,0)
  14820    ;
  14821   "RTN","VPR DJFSG",255 ,0)
  14822   APIHDR(COU NT,LASTITM ) ; return  JSON
  14823   "RTN","VPR DJFSG",256 ,0)
  14824    ; expects  VPRFSYS
  14825   "RTN","VPR DJFSG",257 ,0)
  14826    N X
  14827   "RTN","VPR DJFSG",258 ,0)
  14828    S X="{""a piVersion" ":1.02,""p arams"":{" "domain"": """_$$KSP^ XUPARAM("W HERE")_""" "
  14829   "RTN","VPR DJFSG",259 ,0)
  14830    S X=X_"," "systemId" ":"""_VPRF SYS_"""}," "data"":{" "updated"" :"""_$$HL7 NOW^VPRDJ_ """"
  14831   "RTN","VPR DJFSG",260 ,0)
  14832    S X=X_"," "totalItem s"":"_COUN T_",""last Update"":" ""_LASTITM _""",""ite ms"":["
  14833   "RTN","VPR DJFSG",261 ,0)
  14834    Q X
  14835   "RTN","VPR DJFSG",262 ,0)
  14836    ;
  14837   "RTN","VPR DJFSG",263 ,0)
  14838   LASTUPD(HM PSRV,LASTU PD) ; save  the last  update
  14839   "RTN","VPR DJFSG",264 ,0)
  14840    ; TODO: c hange this  to use Fi leman call
  14841   "RTN","VPR DJFSG",265 ,0)
  14842    N IEN,CUR RUPD,REPEA T
  14843   "RTN","VPR DJFSG",266 ,0)
  14844    S IEN=$O( ^VPR(560," B",HMPSRV, 0)) Q:'IEN
  14845   "RTN","VPR DJFSG",267 ,0)
  14846    Q:LASTUPD ["^"
  14847   "RTN","VPR DJFSG",268 ,0)
  14848    S CURRUPD =$P(^VPR(5 60,IEN,0), "^",2),REP EAT=$P(^VP R(560,IEN, 0),"^",4)
  14849   "RTN","VPR DJFSG",269 ,0)
  14850    I LASTUPD =CURRUPD S  $P(^VPR(5 60,IEN,0), "^",4)=REP EAT+1 QUIT
  14851   "RTN","VPR DJFSG",270 ,0)
  14852    S $P(^VPR (560,IEN,0 ),"^",2)=L ASTUPD,$P( ^VPR(560,I EN,0),"^", 4)=0
  14853   "RTN","VPR DJFSG",271 ,0)
  14854    Q
  14855   "RTN","VPR DJFSG",272 ,0)
  14856   TEST ;
  14857   "RTN","VPR DJFSG",273 ,0)
  14858    N ARGS,KC M
  14859   "RTN","VPR DJFSG",274 ,0)
  14860    K ^TMP("V PRF",$J)
  14861   "RTN","VPR DJFSG",275 ,0)
  14862    S ARGS("s erver")="h mp-kcm"
  14863   "RTN","VPR DJFSG",276 ,0)
  14864    S ARGS("l astUpdate" )="3140113 -47" ;"0"  ;"3031206- 300" ;"313 1205-304"  ;"3131205- 240"
  14865   "RTN","VPR DJFSG",277 ,0)
  14866    S ARGS("m ax")=100
  14867   "RTN","VPR DJFSG",278 ,0)
  14868    D GETSUB( .KCM,.ARGS )
  14869   "RTN","VPR DJFSG",279 ,0)
  14870    Q
  14871   "RTN","VPR DJFSG",280 ,0)
  14872   JSONOUT ;  Write out  JSON in ^T MP
  14873   "RTN","VPR DJFSG",281 ,0)
  14874    N X
  14875   "RTN","VPR DJFSG",282 ,0)
  14876    S X=$NA(^ TMP("VPRF" ,$J))
  14877   "RTN","VPR DJFSG",283 ,0)
  14878    F  S X=$Q (@X) Q:($Q S(X,1)'="V PRF")!($QS (X,2)'=$J)   W !,@X
  14879   "RTN","VPR DJFSG",284 ,0)
  14880    Q
  14881   "RTN","VPR DJFSM")
  14882   0^98^B2284 3682
  14883   "RTN","VPR DJFSM",1,0 )
  14884   VPRDJFSM ; SLC/KCM --  Monitorin g Tools fo r Extracts
  14885   "RTN","VPR DJFSM",2,0 )
  14886    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  14887   "RTN","VPR DJFSM",3,0 )
  14888    ;
  14889   "RTN","VPR DJFSM",4,0 )
  14890   EN ; Show  informatio n for one  server
  14891   "RTN","VPR DJFSM",5,0 )
  14892    N IEN
  14893   "RTN","VPR DJFSM",6,0 )
  14894    S IEN=$$G ETSRV() Q: IEN'>0
  14895   "RTN","VPR DJFSM",7,0 )
  14896    D LOOP(IE N)
  14897   "RTN","VPR DJFSM",8,0 )
  14898    Q
  14899   "RTN","VPR DJFSM",9,0 )
  14900   ALL ; Show  informati on for all  servers
  14901   "RTN","VPR DJFSM",10, 0)
  14902    D LOOP("A LL")
  14903   "RTN","VPR DJFSM",11, 0)
  14904    Q
  14905   "RTN","VPR DJFSM",12, 0)
  14906   ADDPT(PAT)  ; Add pat ient to se rver
  14907   "RTN","VPR DJFSM",13, 0)
  14908    N SRV,ARG S,RESULT
  14909   "RTN","VPR DJFSM",14, 0)
  14910    I '$G(PAT ) S PAT=$$ GETPAT() Q :'PAT
  14911   "RTN","VPR DJFSM",15, 0)
  14912    S SRV=$$G ETSRV() Q: SRV'>0
  14913   "RTN","VPR DJFSM",16, 0)
  14914    I $G(^VPR (560,"AITE M",PAT,SRV ))>0 W !," Patient "_ PAT_" alre ady synced ."
  14915   "RTN","VPR DJFSM",17, 0)
  14916    ;
  14917   "RTN","VPR DJFSM",18, 0)
  14918    S ARGS("c ommand")=" putPtSubsc ription"
  14919   "RTN","VPR DJFSM",19, 0)
  14920    S ARGS("s erver")=$P (^VPR(560, SRV,0),"^" )
  14921   "RTN","VPR DJFSM",20, 0)
  14922    S ARGS("l ocalId")=P AT
  14923   "RTN","VPR DJFSM",21, 0)
  14924    D API^VPR DJFS(.RESU LT,.ARGS)
  14925   "RTN","VPR DJFSM",22, 0)
  14926    I ^TMP("V PRF",$J,1) ["location " W !,$P($ G(^DPT(PAT ,0)),"^"), " is being  synced."
  14927   "RTN","VPR DJFSM",23, 0)
  14928    E  W !,"S ubscriptio n failed."
  14929   "RTN","VPR DJFSM",24, 0)
  14930    Q
  14931   "RTN","VPR DJFSM",25, 0)
  14932    ;
  14933   "RTN","VPR DJFSM",26, 0)
  14934   LOOP(SRV)  ; Monitor  refresh lo op
  14935   "RTN","VPR DJFSM",27, 0)
  14936    N ACT,IEN
  14937   "RTN","VPR DJFSM",28, 0)
  14938    S ACT=""  F  D  Q:AC T["^"  Q:A CT="Q"  Q: ACT="q"
  14939   "RTN","VPR DJFSM",29, 0)
  14940    . W #
  14941   "RTN","VPR DJFSM",30, 0)
  14942    . W !,$$H TE^XLFDT($ H),?64,"Sl ots Open:  ",$$SLOTS
  14943   "RTN","VPR DJFSM",31, 0)
  14944    . I +SRV  W ! D SHOW SRV(SRV) I  1
  14945   "RTN","VPR DJFSM",32, 0)
  14946    . E  S IE N=0 F  S I EN=$O(^VPR (560,IEN))  Q:'IEN  W  ! D SHOWS RV(IEN)
  14947   "RTN","VPR DJFSM",33, 0)
  14948    . W !!,"E nter Monit or Action:  REFRESH//  "
  14949   "RTN","VPR DJFSM",34, 0)
  14950    . R ACT:3 00 I '$T S  ACT="^"
  14951   "RTN","VPR DJFSM",35, 0)
  14952    Q
  14953   "RTN","VPR DJFSM",36, 0)
  14954   GETSRV() ;  Return th e IEN for  the server  to monito r
  14955   "RTN","VPR DJFSM",37, 0)
  14956    N DIC,Y
  14957   "RTN","VPR DJFSM",38, 0)
  14958    S DIC="^V PR(560,",D IC(0)="AEM Q",DIC("A" )="Select  HMP server  instance:  "
  14959   "RTN","VPR DJFSM",39, 0)
  14960    D ^DIC
  14961   "RTN","VPR DJFSM",40, 0)
  14962    Q +Y
  14963   "RTN","VPR DJFSM",41, 0)
  14964    ;
  14965   "RTN","VPR DJFSM",42, 0)
  14966   GETPAT() ;  Return DF N for a pa tient
  14967   "RTN","VPR DJFSM",43, 0)
  14968    N DIC,Y
  14969   "RTN","VPR DJFSM",44, 0)
  14970    S DIC="^D PT(",DIC(0 )="AEMQ"
  14971   "RTN","VPR DJFSM",45, 0)
  14972    D ^DIC
  14973   "RTN","VPR DJFSM",46, 0)
  14974    Q +Y
  14975   "RTN","VPR DJFSM",47, 0)
  14976    ; 
  14977   "RTN","VPR DJFSM",48, 0)
  14978   SHOWSRV(IE N) ; Show  informatio n for a se rver
  14979   "RTN","VPR DJFSM",49, 0)
  14980    N X0,ROOT ,BATCH,STR EAM,SRVNM, LASTUP,REP EAT,TASK
  14981   "RTN","VPR DJFSM",50, 0)
  14982    S X0=^VPR (560,IEN,0 )
  14983   "RTN","VPR DJFSM",51, 0)
  14984    S SRVNM=$ P(X0,"^"), LASTUP=$P( X0,"^",2), REPEAT=$P( X0,"^",4)
  14985   "RTN","VPR DJFSM",52, 0)
  14986    S STREAM= $O(^XTMP(" VPRFS~"_SR VNM_"~9999 999"),-1)  ; not alwa ys "today"
  14987   "RTN","VPR DJFSM",53, 0)
  14988    W !,SRVNM ,?30,"Last  Update: " ,LASTUP W: REPEAT "   x",REPEAT
  14989   "RTN","VPR DJFSM",54, 0)
  14990    I $D(^XTM P(STREAM))  D
  14991   "RTN","VPR DJFSM",55, 0)
  14992    . W !,?29 ,"End of Q ueue: ",$P (STREAM,"~ ",3),"-",$ G(^XTMP(ST REAM,"last "))
  14993   "RTN","VPR DJFSM",56, 0)
  14994    ; loop th ru extract s for this  server
  14995   "RTN","VPR DJFSM",57, 0)
  14996    S ROOT="V PRFX~"_SRV NM_"~",BAT CH=ROOT
  14997   "RTN","VPR DJFSM",58, 0)
  14998    S BATCH=R OOT F  S B ATCH=$O(^X TMP(BATCH) ) Q:$E(BAT CH,1,$L(RO OT))'=ROOT   D
  14999   "RTN","VPR DJFSM",59, 0)
  15000    . W !,$J( $P(BATCH," ~",3),12)
  15001   "RTN","VPR DJFSM",60, 0)
  15002    . S TASK= $O(^XTMP(B ATCH,0,"ta sk",0))
  15003   "RTN","VPR DJFSM",61, 0)
  15004    . W ?14," Task#"_TAS K
  15005   "RTN","VPR DJFSM",62, 0)
  15006    . I '$D(^ XTMP(BATCH ,0,"wait") ) W ?34,"w aiting: ", $$WAIT(BAT CH)," seco nds" Q
  15007   "RTN","VPR DJFSM",63, 0)
  15008    . W ?31," extracting : ",$$LOBJ (BATCH,TAS K)
  15009   "RTN","VPR DJFSM",64, 0)
  15010    Q
  15011   "RTN","VPR DJFSM",65, 0)
  15012   WAIT(BATCH ) ; Return  the numbe r of secon ds the bat ch has bee n waiting
  15013   "RTN","VPR DJFSM",66, 0)
  15014    N START
  15015   "RTN","VPR DJFSM",67, 0)
  15016    S START=$ G(^XTMP(BA TCH,0,"tim e")) Q:'ST ART 0
  15017   "RTN","VPR DJFSM",68, 0)
  15018    Q $$HDIFF ^XLFDT($H, START,2)
  15019   "RTN","VPR DJFSM",69, 0)
  15020    ;
  15021   "RTN","VPR DJFSM",70, 0)
  15022   LOBJ(BATCH ,TASK) ; R eturn the  last domai n>count re trieved fo r this bat ch
  15023   "RTN","VPR DJFSM",71, 0)
  15024    Q:'TASK " no task"
  15025   "RTN","VPR DJFSM",72, 0)
  15026    N LASTITM ,DOMAIN,NU M
  15027   "RTN","VPR DJFSM",73, 0)
  15028    S LASTITM =""
  15029   "RTN","VPR DJFSM",74, 0)
  15030    S DOMAIN= "",LASTITM =""
  15031   "RTN","VPR DJFSM",75, 0)
  15032    F  S DOMA IN=$O(^XTM P(BATCH,0, "status",D OMAIN)) Q: '$L(DOMAIN )  D  Q:$L (LASTITM)
  15033   "RTN","VPR DJFSM",76, 0)
  15034    . I $G(^X TMP(BATCH, 0,"status" ,DOMAIN))  Q  ; domai n complete
  15035   "RTN","VPR DJFSM",77, 0)
  15036    . S NUM=$ O(^XTMP(BA TCH,TASK,D OMAIN,""), -1)
  15037   "RTN","VPR DJFSM",78, 0)
  15038    . S LASTI TM=DOMAIN_ $S(NUM:" # "_NUM,1:"" )
  15039   "RTN","VPR DJFSM",79, 0)
  15040    Q $S('$L( LASTITM):" <finished> ",1:LASTIT M)
  15041   "RTN","VPR DJFSM",80, 0)
  15042    ;
  15043   "RTN","VPR DJFSM",81, 0)
  15044   SLOTS() ;  Return the  number of  slots ava ilable
  15045   "RTN","VPR DJFSM",82, 0)
  15046    N OUT
  15047   "RTN","VPR DJFSM",83, 0)
  15048    D FIND^DI C(3.54,"", "1","BX"," VPR EXTRAC T RESOURCE ","","","" ,"","OUT")
  15049   "RTN","VPR DJFSM",84, 0)
  15050    Q $G(OUT( "DILIST"," ID",1,1))
  15051   "RTN","VPR DJFSM",85, 0)
  15052    ;
  15053   "RTN","VPR DJFSM",86, 0)
  15054   EMERSTOP ;  Emergency  Stop for  Freshness
  15055   "RTN","VPR DJFSM",87, 0)
  15056    W !,"WARN ING!  This  will stop  freshness  updates f or the VPR ."
  15057   "RTN","VPR DJFSM",88, 0)
  15058    W !,"           It w ill be nec essary to  re-synch p atient dat a.",!
  15059   "RTN","VPR DJFSM",89, 0)
  15060    N TYPLST, ALPHA,I,TY PE
  15061   "RTN","VPR DJFSM",90, 0)
  15062    D EVNTYPS (.TYPLST)
  15063   "RTN","VPR DJFSM",91, 0)
  15064    S I=0 F   S I=$O(TYP LST(I)) Q: 'I  S ALPH A(TYPLST(I ))=""
  15065   "RTN","VPR DJFSM",92, 0)
  15066    S TYPE=$$ GETFTYP(.A LPHA)
  15067   "RTN","VPR DJFSM",93, 0)
  15068    Q:TYPE=""
  15069   "RTN","VPR DJFSM",94, 0)
  15070    I TYPE="* " D  Q
  15071   "RTN","VPR DJFSM",95, 0)
  15072    . S TYPE= "" F  S TY PE=$O(ALPH A(TYPE)) Q :TYPE=""   D STOPFTYP (TYPE)
  15073   "RTN","VPR DJFSM",96, 0)
  15074    D STOPFTY P(TYPE)
  15075   "RTN","VPR DJFSM",97, 0)
  15076    Q
  15077   "RTN","VPR DJFSM",98, 0)
  15078   STOPFTYP(T YPE) ; Sto p freshnes s updates  for type
  15079   "RTN","VPR DJFSM",99, 0)
  15080    I '$D(^XT MP("VPR-of f",0)) D N EWXTMP^VPR DJFS("VPR- off",999," Switch off  VPR fresh ness updat es")
  15081   "RTN","VPR DJFSM",100 ,0)
  15082    W !,"Stop ping fresh ess update s for: ",T YPE
  15083   "RTN","VPR DJFSM",101 ,0)
  15084    S ^XTMP(" VPR-off",T YPE)=1
  15085   "RTN","VPR DJFSM",102 ,0)
  15086    Q
  15087   "RTN","VPR DJFSM",103 ,0)
  15088   GETFTYP(AL PHA) ; Ret urn item f rom the li st
  15089   "RTN","VPR DJFSM",104 ,0)
  15090    N X,T
  15091   "RTN","VPR DJFSM",105 ,0)
  15092    F  D  Q:X '["?"
  15093   "RTN","VPR DJFSM",106 ,0)
  15094    . D SHOWF TYP(.ALPHA )
  15095   "RTN","VPR DJFSM",107 ,0)
  15096    . W !!,"C hoose doma in to stop  (* stops  all): "
  15097   "RTN","VPR DJFSM",108 ,0)
  15098    . R X:300  S:$E(X)=" ^" X="" Q: X=""  Q:X= "*"
  15099   "RTN","VPR DJFSM",109 ,0)
  15100    . S X=$$L OW^XLFSTR( X)
  15101   "RTN","VPR DJFSM",110 ,0)
  15102    . Q:$D(AL PHA(X))
  15103   "RTN","VPR DJFSM",111 ,0)
  15104    . S T=$O( ALPHA(X))
  15105   "RTN","VPR DJFSM",112 ,0)
  15106    . I X=$E( T,1,$L(X))  W "  ",T  S X=T Q
  15107   "RTN","VPR DJFSM",113 ,0)
  15108    . W "  ?? ",! S X="? "
  15109   "RTN","VPR DJFSM",114 ,0)
  15110    Q X
  15111   "RTN","VPR DJFSM",115 ,0)
  15112    ;
  15113   "RTN","VPR DJFSM",116 ,0)
  15114   SHOWFTYP(A LPHA) ; Sh ow freshne ss types
  15115   "RTN","VPR DJFSM",117 ,0)
  15116    N I,X,P
  15117   "RTN","VPR DJFSM",118 ,0)
  15118    S I=0,X=" " F  S X=$ O(ALPHA(X) ) Q:'$L(X)   D
  15119   "RTN","VPR DJFSM",119 ,0)
  15120    . S I=I+1 ,P=I#3
  15121   "RTN","VPR DJFSM",120 ,0)
  15122    . W:P=1 ! ,X
  15123   "RTN","VPR DJFSM",121 ,0)
  15124    . W:P=2 ? 26,X
  15125   "RTN","VPR DJFSM",122 ,0)
  15126    . W:P=0 ? 52,X
  15127   "RTN","VPR DJFSM",123 ,0)
  15128    Q
  15129   "RTN","VPR DJFSM",124 ,0)
  15130   EVNTYPS(LI ST) ; load  event typ es
  15131   "RTN","VPR DJFSM",125 ,0)
  15132    ;;allergy
  15133   "RTN","VPR DJFSM",126 ,0)
  15134    ;;med
  15135   "RTN","VPR DJFSM",127 ,0)
  15136    ;;auxilia ry
  15137   "RTN","VPR DJFSM",128 ,0)
  15138    ;;appoint ment
  15139   "RTN","VPR DJFSM",129 ,0)
  15140    ;;diagnos is
  15141   "RTN","VPR DJFSM",130 ,0)
  15142    ;;documen t
  15143   "RTN","VPR DJFSM",131 ,0)
  15144    ;;factor
  15145   "RTN","VPR DJFSM",132 ,0)
  15146    ;;immuniz ation
  15147   "RTN","VPR DJFSM",133 ,0)
  15148    ;;lab
  15149   "RTN","VPR DJFSM",134 ,0)
  15150    ;;obs
  15151   "RTN","VPR DJFSM",135 ,0)
  15152    ;;order
  15153   "RTN","VPR DJFSM",136 ,0)
  15154    ;;problem
  15155   "RTN","VPR DJFSM",137 ,0)
  15156    ;;procedu re
  15157   "RTN","VPR DJFSM",138 ,0)
  15158    ;;consult
  15159   "RTN","VPR DJFSM",139 ,0)
  15160    ;;image
  15161   "RTN","VPR DJFSM",140 ,0)
  15162    ;;surgery
  15163   "RTN","VPR DJFSM",141 ,0)
  15164    ;;task
  15165   "RTN","VPR DJFSM",142 ,0)
  15166    ;;visit
  15167   "RTN","VPR DJFSM",143 ,0)
  15168    ;;vital
  15169   "RTN","VPR DJFSM",144 ,0)
  15170    ;;mh
  15171   "RTN","VPR DJFSM",145 ,0)
  15172    ;;ptf
  15173   "RTN","VPR DJFSM",146 ,0)
  15174    ;;exam
  15175   "RTN","VPR DJFSM",147 ,0)
  15176    ;;cpt
  15177   "RTN","VPR DJFSM",148 ,0)
  15178    ;;educati on
  15179   "RTN","VPR DJFSM",149 ,0)
  15180    ;;pov
  15181   "RTN","VPR DJFSM",150 ,0)
  15182    ;;skin
  15183   "RTN","VPR DJFSM",151 ,0)
  15184    ;;treatme nt
  15185   "RTN","VPR DJFSM",152 ,0)
  15186    ;;roadtri p
  15187   "RTN","VPR DJFSM",153 ,0)
  15188    ;;diet
  15189   "RTN","VPR DJFSM",154 ,0)
  15190    ;;patient
  15191   "RTN","VPR DJFSM",155 ,0)
  15192    ;;roster
  15193   "RTN","VPR DJFSM",156 ,0)
  15194    ;;user
  15195   "RTN","VPR DJFSM",157 ,0)
  15196    ;;zzzzz
  15197   "RTN","VPR DJFSM",158 ,0)
  15198    N I,X
  15199   "RTN","VPR DJFSM",159 ,0)
  15200    F I=1:1 S  X=$P($T(E VNTYPS+I), ";;",2,99)  Q:X="zzzz z"  S LIST (I)=X
  15201   "RTN","VPR DJFSM",160 ,0)
  15202    Q
  15203   "RTN","VPR DJFSM",161 ,0)
  15204    ;
  15205   "RTN","VPR DJFSP")
  15206   0^87^B8660 2412
  15207   "RTN","VPR DJFSP",1,0 )
  15208   VPRDJFSP ; SLC/KCM --  PUT/POST  for Extrac t and Fres hness Stre am
  15209   "RTN","VPR DJFSP",2,0 )
  15210    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  15211   "RTN","VPR DJFSP",3,0 )
  15212    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  15213   "RTN","VPR DJFSP",4,0 )
  15214    ;
  15215   "RTN","VPR DJFSP",5,0 )
  15216    ;
  15217   "RTN","VPR DJFSP",6,0 )
  15218    ; --- cre ate a new  patient su bscription
  15219   "RTN","VPR DJFSP",7,0 )
  15220    ;
  15221   "RTN","VPR DJFSP",8,0 )
  15222   PUTSUB(ARG S,BODY) ;  return loc ation afte r creating  a new sub scription
  15223   "RTN","VPR DJFSP",9,0 )
  15224    ; PUT to:  /vpr/subs cription
  15225   "RTN","VPR DJFSP",10, 0)
  15226    ;   JSON:  {server:h mpXYZ,loca lId:229,ic n:10232432 4,domains: [lab,med,. ..]}
  15227   "RTN","VPR DJFSP",11, 0)
  15228    ;VPRFRSP:  location: /vpr/subsc ription/{h mpSrvId}/p atient/{df n}
  15229   "RTN","VPR DJFSP",12, 0)
  15230    ;
  15231   "RTN","VPR DJFSP",13, 0)
  15232    N ICN,OBJ ,ERR,HMPSR V,VPRFDFN, VPRFDOM,VP RBATCH,VPR FERR,VPROP D,NEWSUB
  15233   "RTN","VPR DJFSP",14, 0)
  15234    D DECODE^ VPRJSON("B ODY","OBJ" ,"ERR")
  15235   "RTN","VPR DJFSP",15, 0)
  15236    I $D(ERR)  D SETERR^ VPRDJFS("U nable to d ecode JSON ") Q ""
  15237   "RTN","VPR DJFSP",16, 0)
  15238    S VPROPD= $S($G(OBJ( "isOperati onal"))="t rue":1,1:0 )
  15239   "RTN","VPR DJFSP",17, 0)
  15240    I VPROPD= 0 D  I '$L (VPRFDFN)  D SETERR^V PRDJFS("No  patient s pecified")  Q ""
  15241   "RTN","VPR DJFSP",18, 0)
  15242    .S VPRFDF N=$G(OBJ(" localId")) ,ICN=$G(OB J("icn"))
  15243   "RTN","VPR DJFSP",19, 0)
  15244    .I '$L(VP RFDFN),$L( ICN) S VPR FDFN=+$$GE TDFN^MPIF0 01(ICN)
  15245   "RTN","VPR DJFSP",20, 0)
  15246    .;I '$L(V PRFDFN) D  SETERR^VPR DJFS("No p atient spe cified") Q  ""
  15247   "RTN","VPR DJFSP",21, 0)
  15248    I VPROPD= 1 S VPRFDF N="OPD"
  15249   "RTN","VPR DJFSP",22, 0)
  15250    S HMPSRV= $TR($G(OBJ ("server") ),"~","=")
  15251   "RTN","VPR DJFSP",23, 0)
  15252    I '$L(HMP SRV) D SET ERR^VPRDJF S("Missing  HMP Serve r ID") Q " "
  15253   "RTN","VPR DJFSP",24, 0)
  15254    M VPRFDOM =OBJ("doma ins") I $D (VPRFDOM)< 10 D
  15255   "RTN","VPR DJFSP",25, 0)
  15256    .I VPROPD =1 D DOMAI NS^VPREFSP (.VPRFDOM)  Q
  15257   "RTN","VPR DJFSP",26, 0)
  15258    .D DOMAIN S(.VPRFDOM )
  15259   "RTN","VPR DJFSP",27, 0)
  15260    S VPRBATC H="VPRFX~" _HMPSRV_"~ "_VPRFDFN
  15261   "RTN","VPR DJFSP",28, 0)
  15262    ;
  15263   "RTN","VPR DJFSP",29, 0)
  15264    I '$$TM^% ZTLOAD D S ETERR^VPRD JFS("Taskm an not run ning") Q " "
  15265   "RTN","VPR DJFSP",30, 0)
  15266    ;
  15267   "RTN","VPR DJFSP",31, 0)
  15268    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=0 -- un subscribed
  15269   "RTN","VPR DJFSP",32, 0)
  15270    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=1 -- su bscribed
  15271   "RTN","VPR DJFSP",33, 0)
  15272    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=2 -- in itialized  (extracts  complete)
  15273   "RTN","VPR DJFSP",34, 0)
  15274    ; locks e nsure only  one proce ss queues  the extrac ts
  15275   "RTN","VPR DJFSP",35, 0)
  15276    S NEWSUB= $$SETPAT(V PRFDFN,VPR OPD,HMPSRV )
  15277   "RTN","VPR DJFSP",36, 0)
  15278    I NEWSUB  D QUINIT(V PRBATCH,VP RFDFN,.VPR FDOM) Q:$G (VPRFERR)  ""
  15279   "RTN","VPR DJFSP",37, 0)
  15280    Q "/vpr/s ubscriptio n/"_HMPSRV _"/patient /"_$$PID^V PRDJFS(VPR FDFN)
  15281   "RTN","VPR DJFSP",38, 0)
  15282    ;
  15283   "RTN","VPR DJFSP",39, 0)
  15284   QUINIT(VPR BATCH,VPRF DFN,VPRFDO M) ; Queue  the initi al extract s for a pa tient
  15285   "RTN","VPR DJFSP",40, 0)
  15286    ; VPRBATC H="VPRFX~h mpsrvid~df n"  exampl e: VPRFX~h mpXYZ~229
  15287   "RTN","VPR DJFSP",41, 0)
  15288    ; VPRFDOM (n)="domai nName"
  15289   "RTN","VPR DJFSP",42, 0)
  15290    ; 
  15291   "RTN","VPR DJFSP",43, 0)
  15292    ; ^XTMP(" VPRFX~hmps rvid~dfn", 0)=expires ^created^V PR Patient  Extract
  15293   "RTN","VPR DJFSP",44, 0)
  15294    ;                             , 0,"status" ,domain)=e xtract sta tus
  15295   "RTN","VPR DJFSP",45, 0)
  15296    ;                             , 0,"task",t askIen)=""
  15297   "RTN","VPR DJFSP",46, 0)
  15298    ;                             , taskIen,do main,... ( extract da ta)
  15299   "RTN","VPR DJFSP",47, 0)
  15300    ;
  15301   "RTN","VPR DJFSP",48, 0)
  15302    D NEWXTMP ^VPRDJFS(V PRBATCH,1, "VPR Patie nt Extract ")
  15303   "RTN","VPR DJFSP",49, 0)
  15304    S ^XTMP(V PRBATCH,0, "time")=$H
  15305   "RTN","VPR DJFSP",50, 0)
  15306    N I S I=0  F  S I=$O (VPRFDOM(I )) Q:'I  D  SETDOM("s tatus",VPR FDOM(I),0)
  15307   "RTN","VPR DJFSP",51, 0)
  15308    D SETMARK ("Start",V PRFDFN,VPR BATCH) ; s ends full  demographi cs
  15309   "RTN","VPR DJFSP",52, 0)
  15310    ;
  15311   "RTN","VPR DJFSP",53, 0)
  15312    N ZTRTN,Z TDESC,ZTDT H,ZTIO,ZTU CI,ZTCPU,Z TPRI,ZTSAV E,ZTKIL,ZT SYNC,ZTSK
  15313   "RTN","VPR DJFSP",54, 0)
  15314    S ZTRTN=" DQINIT^VPR DJFSP",ZTI O="VPR EXT RACT RESOU RCE",ZTDTH =$H
  15315   "RTN","VPR DJFSP",55, 0)
  15316    S ZTSAVE( "VPRBATCH" )="",ZTSAV E("VPRFDFN ")="",ZTSA VE("VPRFDO M(")=""
  15317   "RTN","VPR DJFSP",56, 0)
  15318    S ZTDESC= "Build VPR  domains f or a patie nt"
  15319   "RTN","VPR DJFSP",57, 0)
  15320    D ^%ZTLOA D
  15321   "RTN","VPR DJFSP",58, 0)
  15322    ;
  15323   "RTN","VPR DJFSP",59, 0)
  15324    I $G(ZTSK ) S ^XTMP( VPRBATCH,0 ,"task",ZT SK)="" I 1
  15325   "RTN","VPR DJFSP",60, 0)
  15326    E  D SETE RR^VPRDJFS ("Task not  created")
  15327   "RTN","VPR DJFSP",61, 0)
  15328    Q
  15329   "RTN","VPR DJFSP",62, 0)
  15330   SETDOM(ATT RIB,DOMAIN ,VALUE) ;  Set value  for a doma in
  15331   "RTN","VPR DJFSP",63, 0)
  15332    ; expects : VPRBATCH
  15333   "RTN","VPR DJFSP",64, 0)
  15334    ; ATTRIB:  "status"  or "count"  attribute
  15335   "RTN","VPR DJFSP",65, 0)
  15336    ; DOMAIN:  name of d omain
  15337   "RTN","VPR DJFSP",66, 0)
  15338    ; if stat us, VALUE:  0=waiting , 1=ready
  15339   "RTN","VPR DJFSP",67, 0)
  15340    ; if coun t,  VALUE:  count of  items
  15341   "RTN","VPR DJFSP",68, 0)
  15342    S ^XTMP(V PRBATCH,0, ATTRIB,DOM AIN)=VALUE
  15343   "RTN","VPR DJFSP",69, 0)
  15344    Q
  15345   "RTN","VPR DJFSP",70, 0)
  15346   DQINIT ; D equeue ini tial extra cts
  15347   "RTN","VPR DJFSP",71, 0)
  15348    ; expects :  VPRBATC H, VPRFDFN , VPRFDOM,  ZTSK
  15349   "RTN","VPR DJFSP",72, 0)
  15350    I '$D(^XT MP(VPRBATC H,0,"task" ,ZTSK)) Q   ; extract  was super ceded
  15351   "RTN","VPR DJFSP",73, 0)
  15352    N COUNT,V PRFDOMI,VP RFSYS,VPRF ZTSK
  15353   "RTN","VPR DJFSP",74, 0)
  15354    K ^TMP("V PRERR",$J)
  15355   "RTN","VPR DJFSP",75, 0)
  15356    S VPRFSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  15357   "RTN","VPR DJFSP",76, 0)
  15358    S VPRFZTS K=ZTSK ; j ust in cas e the unex pected hap pens to ZT SK
  15359   "RTN","VPR DJFSP",77, 0)
  15360    S ^XTMP(V PRBATCH,0, "wait")=$$ HDIFF^XLFD T($H,$G(^X TMP(VPRBAT CH,0,"time ")),2)
  15361   "RTN","VPR DJFSP",78, 0)
  15362    D UPDPAT( VPRFDFN,$P (VPRBATCH, "~",2),1)
  15363   "RTN","VPR DJFSP",79, 0)
  15364    S VPRFDOM I="" F  S  VPRFDOMI=$ O(VPRFDOM( VPRFDOMI))  Q:'VPRFDO MI  D
  15365   "RTN","VPR DJFSP",80, 0)
  15366    . N FILTE R,RSLT
  15367   "RTN","VPR DJFSP",81, 0)
  15368    . S FILTE R("noHead" )=1
  15369   "RTN","VPR DJFSP",82, 0)
  15370    . S FILTE R("domain" )=VPRFDOM( VPRFDOMI)
  15371   "RTN","VPR DJFSP",83, 0)
  15372    . I VPRFD FN="OPD" D  GET^VPREF (.RSLT,.FI LTER)
  15373   "RTN","VPR DJFSP",84, 0)
  15374    . I +VPRF DFN>0 D
  15375   "RTN","VPR DJFSP",85, 0)
  15376    . . S FIL TER("patie ntId")=VPR FDFN
  15377   "RTN","VPR DJFSP",86, 0)
  15378    . . D GET ^VPRDJ(.RS LT,.FILTER )
  15379   "RTN","VPR DJFSP",87, 0)
  15380    . D MOD4S TRM(VPRFDO M(VPRFDOMI ))
  15381   "RTN","VPR DJFSP",88, 0)
  15382    . ; if su perceded,  stop proce ssing doma ins
  15383   "RTN","VPR DJFSP",89, 0)
  15384    . I '$D(^ XTMP(VPRBA TCH,0,"tas k",VPRFZTS K)) S VPRF DOMI=999 Q
  15385   "RTN","VPR DJFSP",90, 0)
  15386    . D SETDO M("status" ,VPRFDOM(V PRFDOMI),1 ) ; ready
  15387   "RTN","VPR DJFSP",91, 0)
  15388    ; if supe rceded, re move extra cts produc ed by this  task
  15389   "RTN","VPR DJFSP",92, 0)
  15390    I '$D(^XT MP(VPRBATC H,0,"task" ,VPRFZTSK) ) K ^XTMP( VPRBATCH,V PRFZTSK) Q
  15391   "RTN","VPR DJFSP",93, 0)
  15392    ; don't a ssume init ialized, s ince we ma y split do mains to o ther tasks
  15393   "RTN","VPR DJFSP",94, 0)
  15394    I $$INITD ONE(VPRBAT CH) D              ;  if all dom ains extra cted
  15395   "RTN","VPR DJFSP",95, 0)
  15396    . S COUNT =$O(^TMP(" VPRERR",$J ,"")) I CO UNT>0 D PO STERR(COUN T,VPRFDFN)
  15397   "RTN","VPR DJFSP",96, 0)
  15398    . D SETMA RK("Done", VPRFDFN,VP RBATCH) ;  - add upda ted syncSt atus
  15399   "RTN","VPR DJFSP",97, 0)
  15400    . D MVFRU PD(VPRBATC H,VPRFDFN)         ;  - move fre shness upd ates over
  15401   "RTN","VPR DJFSP",98, 0)
  15402    Q
  15403   "RTN","VPR DJFSP",99, 0)
  15404   SETMARK(TY PE,VPRFDFN ,VPRBATCH)  ; Post ma rkers for  begin and  end of ini tial synch
  15405   "RTN","VPR DJFSP",100 ,0)
  15406    N HPMSRV, NODES,X
  15407   "RTN","VPR DJFSP",101 ,0)
  15408    S HMPSRV= $P(VPRBATC H,"~",2)
  15409   "RTN","VPR DJFSP",102 ,0)
  15410    D POST^VP RDJFS(VPRF DFN,"sync" _TYPE,VPRB ATCH,"",HM PSRV,.NODE S)
  15411   "RTN","VPR DJFSP",103 ,0)
  15412    Q:TYPE="S tart"
  15413   "RTN","VPR DJFSP",104 ,0)
  15414    S X="" F   S X=$O(NO DES(X)) Q: X=""  D  ;  iterate h mp servers
  15415   "RTN","VPR DJFSP",105 ,0)
  15416    . S ^XTMP ("VPRFP"," tidy",X,$P (NODES(X), U),$P(NODE S(X),U,2)) =VPRBATCH
  15417   "RTN","VPR DJFSP",106 ,0)
  15418    Q
  15419   "RTN","VPR DJFSP",107 ,0)
  15420   MVFRUPD(VP RBATCH,VPR FDFN) ; Mo ve freshne ss updates  over acti ve stream
  15421   "RTN","VPR DJFSP",108 ,0)
  15422    N I,X,FRO M,HMPSRV,D FN,TYPE,ID ,ACT
  15423   "RTN","VPR DJFSP",109 ,0)
  15424    S HMPSRV= $P(VPRBATC H,"~",2)
  15425   "RTN","VPR DJFSP",110 ,0)
  15426    D UPDPAT( VPRFDFN,HM PSRV,2)
  15427   "RTN","VPR DJFSP",111 ,0)
  15428    ;S ^XTMP( "VPRFP",VP RFDFN,HMPS RV)=2        ; now in itialized
  15429   "RTN","VPR DJFSP",112 ,0)
  15430    S FROM="V PRFH~"_HMP SRV_"~"_VP RFDFN
  15431   "RTN","VPR DJFSP",113 ,0)
  15432    S I=0 F   S I=$O(^XT MP(FROM,I) ) Q:'I  D   ; move ov er held up dates
  15433   "RTN","VPR DJFSP",114 ,0)
  15434    . S X=^XT MP(FROM,I)
  15435   "RTN","VPR DJFSP",115 ,0)
  15436    . S DFN=$ P(X,U),TYP E=$P(X,U,2 ),ID=$P(X, U,3),ACT=$ P(X,U,4)
  15437   "RTN","VPR DJFSP",116 ,0)
  15438    . D POST^ VPRDJFS(DF N,TYPE,ID, ACT,HMPSRV )
  15439   "RTN","VPR DJFSP",117 ,0)
  15440    K ^XTMP(F ROM)
  15441   "RTN","VPR DJFSP",118 ,0)
  15442    Q
  15443   "RTN","VPR DJFSP",119 ,0)
  15444   MOD4STRM(D OMAIN) ; m odify extr act to be  ready for  stream
  15445   "RTN","VPR DJFSP",120 ,0)
  15446    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  15447   "RTN","VPR DJFSP",121 ,0)
  15448    ; results  are in ^X TMP("VPRFX ~hmpsrv~df n",DFN,DOM AIN,...)
  15449   "RTN","VPR DJFSP",122 ,0)
  15450    ; syncErr or: {uid,c ollection, error}  ui d=urn:va:s yncError:s ysId:dfn:e xtract
  15451   "RTN","VPR DJFSP",123 ,0)
  15452    N DFN,HMP SRV,COUNT
  15453   "RTN","VPR DJFSP",124 ,0)
  15454    S DFN=$P( VPRBATCH," ~",3),HMPS RV=$P(VPRB ATCH,"~",2 )
  15455   "RTN","VPR DJFSP",125 ,0)
  15456    ; no item s -- COUNT  is in 1 n ode, other wise COUNT  is in the  .6 node
  15457   "RTN","VPR DJFSP",126 ,0)
  15458    S COUNT=0
  15459   "RTN","VPR DJFSP",127 ,0)
  15460    I $D(^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,"to tal")) S C OUNT=+$G(^ ("total"))
  15461   "RTN","VPR DJFSP",128 ,0)
  15462    ; remove  headers (. 5,.6) and  closing br aces (at C OUNT+1)
  15463   "RTN","VPR DJFSP",129 ,0)
  15464    ;K ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,.5)
  15465   "RTN","VPR DJFSP",130 ,0)
  15466    ;K ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,.6)
  15467   "RTN","VPR DJFSP",131 ,0)
  15468    ;K ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,COUNT +1)
  15469   "RTN","VPR DJFSP",132 ,0)
  15470    ; if no i tems -- re turn empty  object to  be wrappe d
  15471   "RTN","VPR DJFSP",133 ,0)
  15472    I COUNT=0  S ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,1,1)=" "
  15473   "RTN","VPR DJFSP",134 ,0)
  15474    ; if erro r, add syn cError obj ect (from  COUNT+2)
  15475   "RTN","VPR DJFSP",135 ,0)
  15476    I $D(^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,"er ror")) D
  15477   "RTN","VPR DJFSP",136 ,0)
  15478    . N JSON
  15479   "RTN","VPR DJFSP",137 ,0)
  15480    . ;D BLDS ERR(DFN,DO MAIN,.JSON ) Q:'$D(JS ON)
  15481   "RTN","VPR DJFSP",138 ,0)
  15482    . ;S COUN T=COUNT+1
  15483   "RTN","VPR DJFSP",139 ,0)
  15484    . ;S ^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,COU NT,1)=","
  15485   "RTN","VPR DJFSP",140 ,0)
  15486    . ;M ^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,COU NT,1)=JSON
  15487   "RTN","VPR DJFSP",141 ,0)
  15488    ; set .7  node to to tal count  (including  error)
  15489   "RTN","VPR DJFSP",142 ,0)
  15490    ;S ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,.7)=C OUNT
  15491   "RTN","VPR DJFSP",143 ,0)
  15492    S ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,"total ")=COUNT
  15493   "RTN","VPR DJFSP",144 ,0)
  15494    D SETDOM( "count",DO MAIN,COUNT )
  15495   "RTN","VPR DJFSP",145 ,0)
  15496    ; if coun t 0 -- sti ll return  wrapper ob ject so we  know the  domain had  nothing
  15497   "RTN","VPR DJFSP",146 ,0)
  15498    D POST^VP RDJFS(DFN, "syncDomai n",DOMAIN_ ":"_VPRFZT SK_":"_($S (COUNT=0:1 ,1:COUNT)) _":"_COUNT ,"",HMPSRV )
  15499   "RTN","VPR DJFSP",147 ,0)
  15500    Q
  15501   "RTN","VPR DJFSP",148 ,0)
  15502   BLDSERR(DF N,DOMAIN,E RRJSON) ;  Create syn cError obj ect in ERR JSON
  15503   "RTN","VPR DJFSP",149 ,0)
  15504    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  15505   "RTN","VPR DJFSP",150 ,0)
  15506    N COUNT,E RRVAL,ERRO BJ,ERR,ERR MSG,SYNCER R
  15507   "RTN","VPR DJFSP",151 ,0)
  15508    ;S ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,NODE, .3)="{"  ;  replace ,  with { fo r decoding  JSON
  15509   "RTN","VPR DJFSP",152 ,0)
  15510    M ERRVAL= ^XTMP(VPRB ATCH,VPRFZ TSK,DOMAIN ,"error")
  15511   "RTN","VPR DJFSP",153 ,0)
  15512    I $G(ERRV AL)="" Q
  15513   "RTN","VPR DJFSP",154 ,0)
  15514    S ERRVAL= "{"_ERRVAL _"}"
  15515   "RTN","VPR DJFSP",155 ,0)
  15516    D DECODE^ VPRJSON("E RRVAL","ER ROBJ","ERR ")
  15517   "RTN","VPR DJFSP",156 ,0)
  15518    I $D(ERR)  S $EC=",U JSON decod e error,"
  15519   "RTN","VPR DJFSP",157 ,0)
  15520    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,"error ")
  15521   "RTN","VPR DJFSP",158 ,0)
  15522    S ERRMSG= ERROBJ("er ror","mess age")
  15523   "RTN","VPR DJFSP",159 ,0)
  15524    Q:'$L(ERR MSG)
  15525   "RTN","VPR DJFSP",160 ,0)
  15526    S SYNCERR ("uid")="u rn:va:sync Error:"_VP RFSYS_":"_ DFN_":"_DO MAIN
  15527   "RTN","VPR DJFSP",161 ,0)
  15528    S SYNCERR ("collecti on")=DOMAI N
  15529   "RTN","VPR DJFSP",162 ,0)
  15530    S SYNCERR ("error")= ERRMSG
  15531   "RTN","VPR DJFSP",163 ,0)
  15532    D ENCODE^ VPRJSON("S YNCERR","E RRJSON","E RR") I $D( ERR) S $EC =",UJSON e ncode erro r," Q
  15533   "RTN","VPR DJFSP",164 ,0)
  15534    S COUNT=$ O(^TMP("VP RERR",$J," "),-1)+1
  15535   "RTN","VPR DJFSP",165 ,0)
  15536    ;D POST^V PRDJFS(DFN ,"syncErro r","error: "_VPRFZTSK _":1:1","" ,HMPSRV)
  15537   "RTN","VPR DJFSP",166 ,0)
  15538    M ^TMP("V PRERR",$J, COUNT)=ERR JSON
  15539   "RTN","VPR DJFSP",167 ,0)
  15540    Q
  15541   "RTN","VPR DJFSP",168 ,0)
  15542    ;
  15543   "RTN","VPR DJFSP",169 ,0)
  15544   POSTERR(CO UNT,DFN) ;
  15545   "RTN","VPR DJFSP",170 ,0)
  15546    N CNT,NOD E,HMPSRV
  15547   "RTN","VPR DJFSP",171 ,0)
  15548    S HMPSRV= $P(VPRBATC H,"~",2)
  15549   "RTN","VPR DJFSP",172 ,0)
  15550    S CNT=0 F   S CNT=$O (^TMP("VPR ERR",$J,CN T)) Q:CNT' >0  D
  15551   "RTN","VPR DJFSP",173 ,0)
  15552    .S NODE=$ G(^TMP("VP RERR",$J,C NT,1))
  15553   "RTN","VPR DJFSP",174 ,0)
  15554    .S ^XTMP( VPRBATCH,V PRFZTSK,"e rror",CNT, 1)=NODE
  15555   "RTN","VPR DJFSP",175 ,0)
  15556    .I CNT>1  S ^XTMP(VP RBATCH,VPR FZTSK,"err or",CNT,.3 )=","
  15557   "RTN","VPR DJFSP",176 ,0)
  15558    D POST^VP RDJFS(DFN, "syncError ","error:" _VPRFZTSK_ ":"_COUNT_ ":"_COUNT, "",HMPSRV)
  15559   "RTN","VPR DJFSP",177 ,0)
  15560    Q
  15561   "RTN","VPR DJFSP",178 ,0)
  15562    ;
  15563   "RTN","VPR DJFSP",179 ,0)
  15564   INITDONE(V PRBATCH) ;  Return 1  if all dom ains are d one
  15565   "RTN","VPR DJFSP",180 ,0)
  15566    N X,DONE
  15567   "RTN","VPR DJFSP",181 ,0)
  15568    S X="",DO NE=1
  15569   "RTN","VPR DJFSP",182 ,0)
  15570    F  S X=$O (^XTMP(VPR BATCH,0,"s tatus",X))  Q:'$L(X)   I '^(X) S  DONE=0
  15571   "RTN","VPR DJFSP",183 ,0)
  15572    Q DONE
  15573   "RTN","VPR DJFSP",184 ,0)
  15574    ;
  15575   "RTN","VPR DJFSP",185 ,0)
  15576   SETPAT(DFN ,OPD,SRV)  ;
  15577   "RTN","VPR DJFSP",186 ,0)
  15578    N ERR,FDA ,IEN,IENRO OT,RESULT
  15579   "RTN","VPR DJFSP",187 ,0)
  15580    S RESULT= 0
  15581   "RTN","VPR DJFSP",188 ,0)
  15582    S IEN=$O( ^VPR(560," B",SRV,"") ) I +IEN'> 0 D SETERR ^VPRDJFS(" Unable to  find serve r: "_SRV)  Q RESULT
  15583   "RTN","VPR DJFSP",189 ,0)
  15584    I OPD=1 D   Q RESULT
  15585   "RTN","VPR DJFSP",190 ,0)
  15586    . I $P($G (^VPR(560, IEN,0)),U, 3)=1 Q
  15587   "RTN","VPR DJFSP",191 ,0)
  15588    . L +^VPR (560,IEN): 5 E  D SET ERR^VPRDJF S("Unable  to lock se rver: "_SV R) Q
  15589   "RTN","VPR DJFSP",192 ,0)
  15590    . S FDA(5 60,"?"_IEN _",",.01)= SRV
  15591   "RTN","VPR DJFSP",193 ,0)
  15592    . S FDA(5 60,"?"_IEN _",",.03)= 0
  15593   "RTN","VPR DJFSP",194 ,0)
  15594    . D UPDAT E^DIE(""," FDA","","E RR")
  15595   "RTN","VPR DJFSP",195 ,0)
  15596    . I $D(ER R) D SETER R^VPRDJFS( "Error upd ating VPR  Subscripti on File")  D DEBUG^VP RDJFS(.ERR )
  15597   "RTN","VPR DJFSP",196 ,0)
  15598    . I '$D(E RR) S RESU LT=1
  15599   "RTN","VPR DJFSP",197 ,0)
  15600    . L -^VPR (560,IEN)
  15601   "RTN","VPR DJFSP",198 ,0)
  15602    I OPD=0 D
  15603   "RTN","VPR DJFSP",199 ,0)
  15604    . L +^VPR (560,IEN,1 ,DFN):5 E   D SETERR^ VPRDJFS("U nable to l ock patien t: "_DFN)  Q
  15605   "RTN","VPR DJFSP",200 ,0)
  15606    . I '$D(^ VPR(560,IE N,1,DFN))  D
  15607   "RTN","VPR DJFSP",201 ,0)
  15608    ..S IENRO OT(DFN)=DF N
  15609   "RTN","VPR DJFSP",202 ,0)
  15610    ..S FDA(5 60.01,"?+" _DFN_","_I EN_",",.01 )=DFN
  15611   "RTN","VPR DJFSP",203 ,0)
  15612    ..S FDA(5 60.01,"?+" _DFN_","_I EN_",",2)= 0
  15613   "RTN","VPR DJFSP",204 ,0)
  15614    ..D UPDAT E^DIE(""," FDA","IENR OOT","ERR" )
  15615   "RTN","VPR DJFSP",205 ,0)
  15616    ..I $D(ER R) D SETER R^VPRDJFS( "Error upd ating VPR  Subscripti on File")  D DEBUG^VP RDJFS(.ERR )
  15617   "RTN","VPR DJFSP",206 ,0)
  15618    ..I '$D(E RR) S RESU LT=1
  15619   "RTN","VPR DJFSP",207 ,0)
  15620    . L -^VPR (560,IEN,1 ,DFN)
  15621   "RTN","VPR DJFSP",208 ,0)
  15622    ;
  15623   "RTN","VPR DJFSP",209 ,0)
  15624    Q RESULT
  15625   "RTN","VPR DJFSP",210 ,0)
  15626    ;
  15627   "RTN","VPR DJFSP",211 ,0)
  15628   UPDPAT(DFN ,SRV,STS)  ;
  15629   "RTN","VPR DJFSP",212 ,0)
  15630    N ERR,FDA ,IEN
  15631   "RTN","VPR DJFSP",213 ,0)
  15632    S IEN=$O( ^VPR(560," B",SRV,"") ) I +IEN'> 0 Q
  15633   "RTN","VPR DJFSP",214 ,0)
  15634    I DFN="OP D" D
  15635   "RTN","VPR DJFSP",215 ,0)
  15636    . S FDA(5 60,"?"_IEN _",",.01)= SRV
  15637   "RTN","VPR DJFSP",216 ,0)
  15638    . S FDA(5 60,"?"_IEN _",",.03)= STS
  15639   "RTN","VPR DJFSP",217 ,0)
  15640    I +DFN>0  D
  15641   "RTN","VPR DJFSP",218 ,0)
  15642    .S FDA(56 0.01,"?"_D FN_","_IEN _",",.01)= DFN
  15643   "RTN","VPR DJFSP",219 ,0)
  15644    .S FDA(56 0.01,"?"_D FN_","_IEN _",",2)=ST S
  15645   "RTN","VPR DJFSP",220 ,0)
  15646    D UPDATE^ DIE("","FD A","","ERR ")
  15647   "RTN","VPR DJFSP",221 ,0)
  15648    ;I $D(ERR ) M ^AGP(" error")=ER R
  15649   "RTN","VPR DJFSP",222 ,0)
  15650    Q
  15651   "RTN","VPR DJFSP",223 ,0)
  15652    ;
  15653   "RTN","VPR DJFSP",224 ,0)
  15654   DOMAINS(LI ST) ; load  default d omains (pu t in param eter?)
  15655   "RTN","VPR DJFSP",225 ,0)
  15656    ;;allergy
  15657   "RTN","VPR DJFSP",226 ,0)
  15658    ;;auxilia ry
  15659   "RTN","VPR DJFSP",227 ,0)
  15660    ;;appoint ment
  15661   "RTN","VPR DJFSP",228 ,0)
  15662    ;;diagnos is
  15663   "RTN","VPR DJFSP",229 ,0)
  15664    ;;documen t
  15665   "RTN","VPR DJFSP",230 ,0)
  15666    ;;factor
  15667   "RTN","VPR DJFSP",231 ,0)
  15668    ;;immuniz ation
  15669   "RTN","VPR DJFSP",232 ,0)
  15670    ;;lab
  15671   "RTN","VPR DJFSP",233 ,0)
  15672    ;;med
  15673   "RTN","VPR DJFSP",234 ,0)
  15674    ;;obs
  15675   "RTN","VPR DJFSP",235 ,0)
  15676    ;;order
  15677   "RTN","VPR DJFSP",236 ,0)
  15678    ;;problem
  15679   "RTN","VPR DJFSP",237 ,0)
  15680    ;;procedu re
  15681   "RTN","VPR DJFSP",238 ,0)
  15682    ;;consult
  15683   "RTN","VPR DJFSP",239 ,0)
  15684    ;;image
  15685   "RTN","VPR DJFSP",240 ,0)
  15686    ;;surgery
  15687   "RTN","VPR DJFSP",241 ,0)
  15688    ;;task
  15689   "RTN","VPR DJFSP",242 ,0)
  15690    ;;visit
  15691   "RTN","VPR DJFSP",243 ,0)
  15692    ;;vital
  15693   "RTN","VPR DJFSP",244 ,0)
  15694    ;;mh
  15695   "RTN","VPR DJFSP",245 ,0)
  15696    ;;ptf
  15697   "RTN","VPR DJFSP",246 ,0)
  15698    ;;exam
  15699   "RTN","VPR DJFSP",247 ,0)
  15700    ;;cpt
  15701   "RTN","VPR DJFSP",248 ,0)
  15702    ;;educati on
  15703   "RTN","VPR DJFSP",249 ,0)
  15704    ;;pov
  15705   "RTN","VPR DJFSP",250 ,0)
  15706    ;;skin
  15707   "RTN","VPR DJFSP",251 ,0)
  15708    ;;treatme nt
  15709   "RTN","VPR DJFSP",252 ,0)
  15710    ;;roadtri p
  15711   "RTN","VPR DJFSP",253 ,0)
  15712    ;;zzzzz
  15713   "RTN","VPR DJFSP",254 ,0)
  15714    N I,X
  15715   "RTN","VPR DJFSP",255 ,0)
  15716    F I=1:1 S  X=$P($T(D OMAINS+I), ";;",2,99)  Q:X="zzzz z"  S LIST (I)=X
  15717   "RTN","VPR DJFSP",256 ,0)
  15718    Q
  15719   "RTN","VPR DJFSP",257 ,0)
  15720    ;
  15721   "RTN","VPR DJFSP",258 ,0)
  15722   TESTPUT ;
  15723   "RTN","VPR DJFSP",259 ,0)
  15724    ;;{"serve r":"hmpTes t","localI d":"229"}
  15725   "RTN","VPR DJFSP",260 ,0)
  15726    ;;{"serve r":"hmpTes t","localI d":"229"," domains":[ "allergy", "lab","med "]}
  15727   "RTN","VPR DJFSP",261 ,0)
  15728    S U="^"
  15729   "RTN","VPR DJFSP",262 ,0)
  15730    D KILL^VP RDJFS
  15731   "RTN","VPR DJFSP",263 ,0)
  15732    N JSON S  JSON=$P($T (TESTPUT+1 ),";;",2,9 9)
  15733   "RTN","VPR DJFSP",264 ,0)
  15734    W !,$$PUT SUB("",.JS ON)
  15735   "RTN","VPR DJFSP",265 ,0)
  15736    Q
  15737   "RTN","VPR DJFSP",266 ,0)
  15738   TESTDQ ;
  15739   "RTN","VPR DJFSP",267 ,0)
  15740    D KILL^VP RDJFS
  15741   "RTN","VPR DJFSP",268 ,0)
  15742    N VPRBATC H,VPRFDFN, VPRFDOM,ZT SK
  15743   "RTN","VPR DJFSP",269 ,0)
  15744    S VPRBATC H="VPRFX~h mpTest~229 "
  15745   "RTN","VPR DJFSP",270 ,0)
  15746    S VPRFDFN =229
  15747   "RTN","VPR DJFSP",271 ,0)
  15748    S VPRFDOM (1)="aller gy",VPRFDO M(2)="lab" ,VPRFDOM(3 )="med"
  15749   "RTN","VPR DJFSP",272 ,0)
  15750    D NEWXTMP ^VPRDJFS(V PRBATCH,1, "VPR Test  Patient Ex tract")
  15751   "RTN","VPR DJFSP",273 ,0)
  15752    N I S I=0  F  S I=$O (VPRFDOM(I )) Q:'I  D  SETDOM("s tatus",VPR FDOM(I),0)
  15753   "RTN","VPR DJFSP",274 ,0)
  15754    S ZTSK=99 999,ZTQUEU ED=1
  15755   "RTN","VPR DJFSP",275 ,0)
  15756    K ^XTMP(V PRBATCH)
  15757   "RTN","VPR DJFSP",276 ,0)
  15758    S ^XTMP(V PRBATCH,0, "task",ZTS K)=""
  15759   "RTN","VPR DJFSP",277 ,0)
  15760    D DQINIT
  15761   "RTN","VPR DJFSP",278 ,0)
  15762    Q
  15763   "RTN","VPR DJFSP",279 ,0)
  15764    ;
  15765   "RTN","VPR DJFSP",280 ,0)
  15766   TESTFRSH(S ERVER,LAST UPD) ;
  15767   "RTN","VPR DJFSP",281 ,0)
  15768    N I,C,LI, FILTER,RES ULT
  15769   "RTN","VPR DJFSP",282 ,0)
  15770    S FILTER( "command") ="getPtUpd ates"
  15771   "RTN","VPR DJFSP",283 ,0)
  15772    S FILTER( "lastUpdat e")=LASTUP D
  15773   "RTN","VPR DJFSP",284 ,0)
  15774    S FILTER( "server")= SERVER
  15775   "RTN","VPR DJFSP",285 ,0)
  15776    D API^VPR DJFS(.RESU LT,.FILTER )
  15777   "RTN","VPR DJFSP",286 ,0)
  15778    S I=""
  15779   "RTN","VPR DJFSP",287 ,0)
  15780    F  S I=$O (^TMP("VPR F",$J,I))  Q:I=""  D
  15781   "RTN","VPR DJFSP",288 ,0)
  15782    .W $G(^TM P("VPRF",$ J,I))
  15783   "RTN","VPR DJFSP",289 ,0)
  15784    .S LI=I
  15785   "RTN","VPR DJFSP",290 ,0)
  15786    .S C="" F   S C=$O(^ TMP("VPRF" ,$J,I,C))  Q:C=""  W  ^TMP("VPRF ",$J,I,C)
  15787   "RTN","VPR DJFSP",291 ,0)
  15788    Q
  15789   "RTN","VPR DJFSP",292 ,0)
  15790    ;
  15791   "RTN","VPR DJFST")
  15792   0^88^B3324 8938
  15793   "RTN","VPR DJFST",1,0 )
  15794   VPRDJFST ; SLC/KCM --  Tests for  extract a nd freshne ss stream
  15795   "RTN","VPR DJFST",2,0 )
  15796    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  15797   "RTN","VPR DJFST",3,0 )
  15798    ;
  15799   "RTN","VPR DJFST",4,0 )
  15800    ; Test Op erational  Synchroniz ation
  15801   "RTN","VPR DJFST",5,0 )
  15802    ;
  15803   "RTN","VPR DJFST",6,0 )
  15804   TESTOPD(NU M) ; Test  operationa l data for  server NU M
  15805   "RTN","VPR DJFST",7,0 )
  15806    Q:'NUM
  15807   "RTN","VPR DJFST",8,0 )
  15808    N SERVER
  15809   "RTN","VPR DJFST",9,0 )
  15810    S SERVER= "Test-Serv er-"_NUM
  15811   "RTN","VPR DJFST",10, 0)
  15812    D RUNOPD( SERVER)
  15813   "RTN","VPR DJFST",11, 0)
  15814    Q
  15815   "RTN","VPR DJFST",12, 0)
  15816   RUNOPD(SER VER) ; Tes t operatio nal data
  15817   "RTN","VPR DJFST",13, 0)
  15818    K ^TMP("V PRF",$J)
  15819   "RTN","VPR DJFST",14, 0)
  15820    N LASTUP, COLLECT,DO MTOT,TOTAL ,DONE
  15821   "RTN","VPR DJFST",15, 0)
  15822    S LASTUP= 0,TOTAL=0, DONE=0
  15823   "RTN","VPR DJFST",16, 0)
  15824    D ADDSRVR (SERVER)
  15825   "RTN","VPR DJFST",17, 0)
  15826    D SRVRSET (SERVER)
  15827   "RTN","VPR DJFST",18, 0)
  15828    D OPDSTRT (SERVER)
  15829   "RTN","VPR DJFST",19, 0)
  15830    F  H 2 D  GETUPDS(SE RVER,.LAST UP) Q:DONE
  15831   "RTN","VPR DJFST",20, 0)
  15832    ; Write o ut the col lection co unts and d omain tota ls.
  15833   "RTN","VPR DJFST",21, 0)
  15834    ; They sh ould be th e same unl ess 1 item , which ma y be just  the wrappe r.
  15835   "RTN","VPR DJFST",22, 0)
  15836    N NM
  15837   "RTN","VPR DJFST",23, 0)
  15838    W !!!,"Co llection", ?20,"Objec ts",?30,"D omain Tota ls",!
  15839   "RTN","VPR DJFST",24, 0)
  15840    S NM="" F   S NM=$O( COLLECT(NM )) Q:NM=""   D
  15841   "RTN","VPR DJFST",25, 0)
  15842    . W !,NM, ?20,$J($G( COLLECT(NM )),7),?30, $J($G(COLL ECT(NM,"to tal")),13)
  15843   "RTN","VPR DJFST",26, 0)
  15844    W !!,"Tot al Objects : ",TOTAL
  15845   "RTN","VPR DJFST",27, 0)
  15846    K ^TMP("V PRF",$J)
  15847   "RTN","VPR DJFST",28, 0)
  15848    Q
  15849   "RTN","VPR DJFST",29, 0)
  15850   ADDSRVR(SE RVER) ; ad d a SERVER  if not th ere
  15851   "RTN","VPR DJFST",30, 0)
  15852    Q:$D(^VPR (560,"B",S ERVER))
  15853   "RTN","VPR DJFST",31, 0)
  15854    N FDA,FDA IEN,DIERR, ERR
  15855   "RTN","VPR DJFST",32, 0)
  15856    S FDA(560 ,"+1,",.01 )=SERVER
  15857   "RTN","VPR DJFST",33, 0)
  15858    D UPDATE^ DIE("","FD A","FDAIEN ","ERR")
  15859   "RTN","VPR DJFST",34, 0)
  15860    I $D(DIER R) W !,"Er ror saving  server"
  15861   "RTN","VPR DJFST",35, 0)
  15862    D CLEAN^D ILF
  15863   "RTN","VPR DJFST",36, 0)
  15864    Q
  15865   "RTN","VPR DJFST",37, 0)
  15866   SRVRSET(SE RVER) ; Re set subscr iptions fo r named SE RVER
  15867   "RTN","VPR DJFST",38, 0)
  15868    N ARGS,RS P
  15869   "RTN","VPR DJFST",39, 0)
  15870    S ARGS("c ommand")=" resetAllSu bscription s"
  15871   "RTN","VPR DJFST",40, 0)
  15872    S ARGS("s erver")=SE RVER
  15873   "RTN","VPR DJFST",41, 0)
  15874    D API^VPR DJFS(.RSP, .ARGS)
  15875   "RTN","VPR DJFST",42, 0)
  15876    W !,"Rese t",?10,@RS P@(1) ;{"a piVersion" :"1.0","re moved":"tr ue"}
  15877   "RTN","VPR DJFST",43, 0)
  15878    Q
  15879   "RTN","VPR DJFST",44, 0)
  15880   OPDSTRT(SE RVER) ; St art operat ional data  extracts  for SERVER
  15881   "RTN","VPR DJFST",45, 0)
  15882    N ARGS,RS P
  15883   "RTN","VPR DJFST",46, 0)
  15884    S ARGS("c ommand")=" startOpera tionalData Extract"
  15885   "RTN","VPR DJFST",47, 0)
  15886    S ARGS("s erver")=SE RVER
  15887   "RTN","VPR DJFST",48, 0)
  15888    D API^VPR DJFS(.RSP, .ARGS) ;SH OULD THIS  RETURN TAS K #?
  15889   "RTN","VPR DJFST",49, 0)
  15890    W !,"Star t",?10,@RS P@(1) ;{"a piVersion" :"1.0","lo cation":"/ vpr/subscr iption/Tes t-Server-1 /patient/" }
  15891   "RTN","VPR DJFST",50, 0)
  15892    Q
  15893   "RTN","VPR DJFST",51, 0)
  15894   GETUPDS(SE RVER,LASTU P) ; Get u pdates for  the named  SERVER
  15895   "RTN","VPR DJFST",52, 0)
  15896    ; expects  COLLECT,D OMTOT,TOTA L,DONE
  15897   "RTN","VPR DJFST",53, 0)
  15898    N ARGS,RS P,CNT
  15899   "RTN","VPR DJFST",54, 0)
  15900    S ARGS("c ommand")=" getPtUpdat es"
  15901   "RTN","VPR DJFST",55, 0)
  15902    S ARGS("s erver")=SE RVER
  15903   "RTN","VPR DJFST",56, 0)
  15904    S ARGS("l astUpdate" )=LASTUP
  15905   "RTN","VPR DJFST",57, 0)
  15906    S ARGS("m ax")=1000
  15907   "RTN","VPR DJFST",58, 0)
  15908    D API^VPR DJFS(.RSP, .ARGS)
  15909   "RTN","VPR DJFST",59, 0)
  15910    ;D SHOWHD RS
  15911   "RTN","VPR DJFST",60, 0)
  15912    S LASTUP= $$GETLUPD( ),CNT=$$CN TOBJS(),TO TAL=TOTAL+ CNT
  15913   "RTN","VPR DJFST",61, 0)
  15914    W !,"Fetc h",?10,"Ob ject Count : ",$J(CNT ,7),"   La st Update:  ",LASTUP
  15915   "RTN","VPR DJFST",62, 0)
  15916    D CNTCOLL (.COLLECT, .DONE) ; c ount colle ctions
  15917   "RTN","VPR DJFST",63, 0)
  15918    Q
  15919   "RTN","VPR DJFST",64, 0)
  15920   CNTCOLL(CO LL,DONE) ;  add colle ction coun ts
  15921   "RTN","VPR DJFST",65, 0)
  15922    N I,NM
  15923   "RTN","VPR DJFST",66, 0)
  15924    S I=.9 F   S I=$O(^T MP("VPRF", $J,I)) Q:' I  D
  15925   "RTN","VPR DJFST",67, 0)
  15926    . S NM=$P ($P($G(^TM P("VPRF",$ J,I,.3))," ""collecti on"":""",2 ),"""")
  15927   "RTN","VPR DJFST",68, 0)
  15928    . Q:'$L(N M)
  15929   "RTN","VPR DJFST",69, 0)
  15930    . I NM="s yncStatus"  D DOMTOT( .COLL,I) S  DONE=1 Q
  15931   "RTN","VPR DJFST",70, 0)
  15932    . S COLL( NM)=$G(COL L(NM))+1
  15933   "RTN","VPR DJFST",71, 0)
  15934    Q
  15935   "RTN","VPR DJFST",72, 0)
  15936   DOMTOT(COL L,I) ; add  domain to tals to co llection a rray
  15937   "RTN","VPR DJFST",73, 0)
  15938    N JSON,OB J,ERR
  15939   "RTN","VPR DJFST",74, 0)
  15940    M JSON=^T MP("VPRF", $J,I)
  15941   "RTN","VPR DJFST",75, 0)
  15942    K JSON(.3 )
  15943   "RTN","VPR DJFST",76, 0)
  15944    D DECODE^ VPRJSON("J SON","OBJ" ,"ERR")
  15945   "RTN","VPR DJFST",77, 0)
  15946    I $D(ERR)  W !,"ERRO R:  decodi ng syncSta tus object "
  15947   "RTN","VPR DJFST",78, 0)
  15948    S NM="" F   S NM=$O( OBJ("domai nTotals",N M)) Q:NM=" "  S COLL( NM,"total" )=OBJ("dom ainTotals" ,NM)
  15949   "RTN","VPR DJFST",79, 0)
  15950    Q
  15951   "RTN","VPR DJFST",80, 0)
  15952    ;
  15953   "RTN","VPR DJFST",81, 0)
  15954    ; Test Pa tient Sync ronization
  15955   "RTN","VPR DJFST",82, 0)
  15956    ;
  15957   "RTN","VPR DJFST",83, 0)
  15958   TEST ; Tes t synchron ization pr ocess
  15959   "RTN","VPR DJFST",84, 0)
  15960    N LASTUPD ,TOTPTS,DO NEPTS,STAR T,GTOTAL
  15961   "RTN","VPR DJFST",85, 0)
  15962    S LASTUPD ="3140204- 35839",TOT PTS=0,DONE PTS=0,GTOT AL=0
  15963   "RTN","VPR DJFST",86, 0)
  15964    S START=$ P($H,",",2 )
  15965   "RTN","VPR DJFST",87, 0)
  15966    ;D KILL^V PRDJFS
  15967   "RTN","VPR DJFST",88, 0)
  15968    D ADDPTS
  15969   "RTN","VPR DJFST",89, 0)
  15970    F  H 1 D  LOADUPD Q: DONEPTS'<T OTPTS
  15971   "RTN","VPR DJFST",90, 0)
  15972    D LOADUPD  ; one las t time to  clear the  last patie nt
  15973   "RTN","VPR DJFST",91, 0)
  15974    W !,"Elap sed Second s: ",$P($H ,",",2)-ST ART
  15975   "RTN","VPR DJFST",92, 0)
  15976    Q
  15977   "RTN","VPR DJFST",93, 0)
  15978   ADDPTS ; A dd patient s for sync hronizatio n
  15979   "RTN","VPR DJFST",94, 0)
  15980    ; expects  TOTPTS
  15981   "RTN","VPR DJFST",95, 0)
  15982    F I=1:1 S  X=$P($T(P ATIENTS+I) ,";;",2,99 9) Q:X="zz zzz"  D
  15983   "RTN","VPR DJFST",96, 0)
  15984    . N ARGS, RSP
  15985   "RTN","VPR DJFST",97, 0)
  15986    . S ARGS( "command") ="putPtSub scription"
  15987   "RTN","VPR DJFST",98, 0)
  15988    . S ARGS( "server")= "hmpTest"
  15989   "RTN","VPR DJFST",99, 0)
  15990    . S ARGS( "localId") =+X
  15991   "RTN","VPR DJFST",100 ,0)
  15992    . D API^V PRDJFS(.RS P,.ARGS)
  15993   "RTN","VPR DJFST",101 ,0)
  15994    . S TOTPT S=TOTPTS+1
  15995   "RTN","VPR DJFST",102 ,0)
  15996    Q
  15997   "RTN","VPR DJFST",103 ,0)
  15998   TSTSUB ; T est subscr ibing a pa tient
  15999   "RTN","VPR DJFST",104 ,0)
  16000    N RSP,ARG S
  16001   "RTN","VPR DJFST",105 ,0)
  16002    S ARGS("c ommand")=" putPtSubsc ription"
  16003   "RTN","VPR DJFST",106 ,0)
  16004    S ARGS("s erver")="K CM"
  16005   "RTN","VPR DJFST",107 ,0)
  16006    S ARGS("l ocalId")=1 00647
  16007   "RTN","VPR DJFST",108 ,0)
  16008    D API^VPR DJFS(.RSP, .ARGS)
  16009   "RTN","VPR DJFST",109 ,0)
  16010    Q
  16011   "RTN","VPR DJFST",110 ,0)
  16012   LOADUPD ;  Load updat es
  16013   "RTN","VPR DJFST",111 ,0)
  16014    ; expects  LASTUPD
  16015   "RTN","VPR DJFST",112 ,0)
  16016    N RSP,ARG S,ERR,CNT, LNODE
  16017   "RTN","VPR DJFST",113 ,0)
  16018    S ARGS("c ommand")=" getPtUpdat es"
  16019   "RTN","VPR DJFST",114 ,0)
  16020    S ARGS("s erver")="h mpTest"
  16021   "RTN","VPR DJFST",115 ,0)
  16022    S ARGS("l astUpdate" )=LASTUPD
  16023   "RTN","VPR DJFST",116 ,0)
  16024    S ARGS("m ax")=1000
  16025   "RTN","VPR DJFST",117 ,0)
  16026    D API^VPR DJFS(.RSP, .ARGS)
  16027   "RTN","VPR DJFST",118 ,0)
  16028    D SCANHDR S
  16029   "RTN","VPR DJFST",119 ,0)
  16030    S LASTUPD =$$GETLUPD
  16031   "RTN","VPR DJFST",120 ,0)
  16032    S CNT=$$C NTOBJS,GTO TAL=GTOTAL +CNT
  16033   "RTN","VPR DJFST",121 ,0)
  16034    W !,"last Update: ", LASTUPD,"   items: ", CNT_"/"_GT OTAL,?50," loaded: ", DONEPTS_"/ "_TOTPTS
  16035   "RTN","VPR DJFST",122 ,0)
  16036    Q
  16037   "RTN","VPR DJFST",123 ,0)
  16038    ;
  16039   "RTN","VPR DJFST",124 ,0)
  16040    ; Common  functions
  16041   "RTN","VPR DJFST",125 ,0)
  16042    ;
  16043   "RTN","VPR DJFST",126 ,0)
  16044   SCANHDRS ;  Scan head ers for sy ncDone obj ects
  16045   "RTN","VPR DJFST",127 ,0)
  16046    ; expects  DONEPTS
  16047   "RTN","VPR DJFST",128 ,0)
  16048    N I
  16049   "RTN","VPR DJFST",129 ,0)
  16050    S I=0 F   S I=$O(^TM P("VPRF",$ J,I)) Q:'I   D
  16051   "RTN","VPR DJFST",130 ,0)
  16052    . I $G(^T MP("VPRF", $J,I,.3))[ "syncStatu s" S DONEP TS=DONEPTS +1
  16053   "RTN","VPR DJFST",131 ,0)
  16054    Q
  16055   "RTN","VPR DJFST",132 ,0)
  16056   SHOWHDRS ;  Show obje ct header  info
  16057   "RTN","VPR DJFST",133 ,0)
  16058    N I
  16059   "RTN","VPR DJFST",134 ,0)
  16060    S I=0 F   S I=$O(^TM P("VPRF",$ J,I)) Q:'I   D
  16061   "RTN","VPR DJFST",135 ,0)
  16062    . W !,"Hd r: ",$G(^T MP("VPRF", $J,I,.3))
  16063   "RTN","VPR DJFST",136 ,0)
  16064    Q
  16065   "RTN","VPR DJFST",137 ,0)
  16066   CNTOBJS()  ; Return c ount of ob jects retu rned
  16067   "RTN","VPR DJFST",138 ,0)
  16068    N I,C
  16069   "RTN","VPR DJFST",139 ,0)
  16070    S C=0
  16071   "RTN","VPR DJFST",140 ,0)
  16072    S I=.9 ;  skip .5 he ader node
  16073   "RTN","VPR DJFST",141 ,0)
  16074    F  S I=$O (^TMP("VPR F",$J,I))  Q:'I  I $L ($G(^TMP(" VPRF",$J,I ,1))) S C= C+1
  16075   "RTN","VPR DJFST",142 ,0)
  16076    Q C
  16077   "RTN","VPR DJFST",143 ,0)
  16078    ;
  16079   "RTN","VPR DJFST",144 ,0)
  16080   GETLUPD()  ; Return l ast update  value
  16081   "RTN","VPR DJFST",145 ,0)
  16082    N X
  16083   "RTN","VPR DJFST",146 ,0)
  16084    S X=^TMP( "VPRF",$J, .5),X=$P(X ,"""lastUp date"":""" ,2),X=$P(X ,""",")
  16085   "RTN","VPR DJFST",147 ,0)
  16086    Q X
  16087   "RTN","VPR DJFST",148 ,0)
  16088    ;
  16089   "RTN","VPR DJFST",149 ,0)
  16090   TOTALS ;
  16091   "RTN","VPR DJFST",150 ,0)
  16092    N P,T
  16093   "RTN","VPR DJFST",151 ,0)
  16094    S T=0
  16095   "RTN","VPR DJFST",152 ,0)
  16096    S P=0 F   S P=$O(^XT MP("VPRFP" ,P)) Q:'P   S T=T+^XT MP("VPRFP" ,P,"hmpTes t","total" )
  16097   "RTN","VPR DJFST",153 ,0)
  16098    W !,"TOTA L: ",T
  16099   "RTN","VPR DJFST",154 ,0)
  16100    Q
  16101   "RTN","VPR DJFST",155 ,0)
  16102   GETFEW ;
  16103   "RTN","VPR DJFST",156 ,0)
  16104    S ARGS("c ommand")=" getPtUpdat es"
  16105   "RTN","VPR DJFST",157 ,0)
  16106    S ARGS("s erver")="h mpTest"
  16107   "RTN","VPR DJFST",158 ,0)
  16108    S ARGS("l astUpdate" )="3140115 -251"
  16109   "RTN","VPR DJFST",159 ,0)
  16110    S ARGS("m ax")=10
  16111   "RTN","VPR DJFST",160 ,0)
  16112    D API^VPR DJFS(.RSP, .ARGS)
  16113   "RTN","VPR DJFST",161 ,0)
  16114    Q
  16115   "RTN","VPR DJFST",162 ,0)
  16116   PATIENTS ;  list of p atients
  16117   "RTN","VPR DJFST",163 ,0)
  16118    ;;25      AVIVAPATIE NT,TWENTYT HREE
  16119   "RTN","VPR DJFST",164 ,0)
  16120    ;;100848  AVIVAPATIE NT,EIGHT
  16121   "RTN","VPR DJFST",165 ,0)
  16122    ;;100851  AVIVAPATIE NT,ELEVEN
  16123   "RTN","VPR DJFST",166 ,0)
  16124    ;;100846  AVIVAPATIE NT,FIVE
  16125   "RTN","VPR DJFST",167 ,0)
  16126    ;;100845  AVIVAPATIE NT,FOUR
  16127   "RTN","VPR DJFST",168 ,0)
  16128    ;;100849  AVIVAPATIE NT,NINE
  16129   "RTN","VPR DJFST",169 ,0)
  16130    ;;100842  AVIVAPATIE NT,ONE
  16131   "RTN","VPR DJFST",170 ,0)
  16132    ;;100841  AVIVAPATIE NT,SEVEN
  16133   "RTN","VPR DJFST",171 ,0)
  16134    ;;100847  AVIVAPATIE NT,SIX
  16135   "RTN","VPR DJFST",172 ,0)
  16136    ;;100850  AVIVAPATIE NT,TEN
  16137   "RTN","VPR DJFST",173 ,0)
  16138    ;;8       AVIVAPATIE NT,THIRTY
  16139   "RTN","VPR DJFST",174 ,0)
  16140    ;;100844  AVIVAPATIE NT,THREE
  16141   "RTN","VPR DJFST",175 ,0)
  16142    ;;100852  AVIVAPATIE NT,TWELVE
  16143   "RTN","VPR DJFST",176 ,0)
  16144    ;;3       AVIVAPATIE NT,TWENTYE IGHT
  16145   "RTN","VPR DJFST",177 ,0)
  16146    ;;231     AVIVAPATIE NT,TWENTYF IVE
  16147   "RTN","VPR DJFST",178 ,0)
  16148    ;;229     AVIVAPATIE NT,TWENTYF OUR
  16149   "RTN","VPR DJFST",179 ,0)
  16150    ;;217     AVIVAPATIE NT,TWENTYN INE
  16151   "RTN","VPR DJFST",180 ,0)
  16152    ;;237     AVIVAPATIE NT,TWENTYO NE
  16153   "RTN","VPR DJFST",181 ,0)
  16154    ;;253     AVIVAPATIE NT,TWENTYS EVEN
  16155   "RTN","VPR DJFST",182 ,0)
  16156    ;;418     AVIVAPATIE NT,TWENTYS IX
  16157   "RTN","VPR DJFST",183 ,0)
  16158    ;;205     AVIVAPATIE NT,TWENTYT WO
  16159   "RTN","VPR DJFST",184 ,0)
  16160    ;;100843  AVIVAPATIE NT,TWO
  16161   "RTN","VPR DJFST",185 ,0)
  16162    ;;zzzzz
  16163   "RTN","VPR DJX")
  16164   0^52^B3616 9855
  16165   "RTN","VPR DJX",1,0)
  16166   VPRDJX ;SL C/MKB -- N ew data up date ; 11/ 5/13 7:02p m
  16167   "RTN","VPR DJX",2,0)
  16168    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  16169   "RTN","VPR DJX",3,0)
  16170    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  16171   "RTN","VPR DJX",4,0)
  16172    ;
  16173   "RTN","VPR DJX",5,0)
  16174    ; Externa l Referenc es           DBIA#
  16175   "RTN","VPR DJX",6,0)
  16176    ; ------- ---------- --           -----
  16177   "RTN","VPR DJX",7,0)
  16178    ; ^DPT                            10035
  16179   "RTN","VPR DJX",8,0)
  16180    ; MPIF001                          2701
  16181   "RTN","VPR DJX",9,0)
  16182    ; XLFSTR                          10104
  16183   "RTN","VPR DJX",10,0)
  16184    ;
  16185   "RTN","VPR DJX",11,0)
  16186   EN(LAST,MA X) ; -- ge t data fro m ^XTMP("V PR-<date>" ,n)
  16187   "RTN","VPR DJX",12,0)
  16188    ; Expects  VPR=$NA(^ TMP("VPR", $J))
  16189   "RTN","VPR DJX",13,0)
  16190    ;
  16191   "RTN","VPR DJX",14,0)
  16192    N SYS,X,Y ,VPRTOTL,D FN,PATCNT, ICN,DOMCNT ,TYPE,RTN, VPRLASTI,V PRID,DATA, DELETE,UID ,CNT,TSTAR T,TSTOP
  16193   "RTN","VPR DJX",15,0)
  16194    S TSTART= $$NOW^XLFD T()
  16195   "RTN","VPR DJX",16,0)
  16196    S LAST=$G (LAST),SYS =$G(FILTER ("systemID ")) Q:SYS= ""
  16197   "RTN","VPR DJX",17,0)
  16198    S MAX=$G( MAX,999)
  16199   "RTN","VPR DJX",18,0)
  16200    D GETLIST (LAST,SYS, MAX)
  16201   "RTN","VPR DJX",19,0)
  16202    ;
  16203   "RTN","VPR DJX",20,0)
  16204    S (DFN,PA TCNT,VPRTO TL)=0 F  S  DFN=$O(^T MP("VPRX", $J,DFN)) Q :DFN<1  D
  16205   "RTN","VPR DJX",21,0)
  16206    . K ^TMP( $J,"VPR ER ROR")
  16207   "RTN","VPR DJX",22,0)
  16208    . S PATCN T=PATCNT+1 ,ICN=+$$GE TICN^MPIF0 01(DFN),ER RPAT=DFN
  16209   "RTN","VPR DJX",23,0)
  16210    . S DOMCN T=0 K DATA ,DELETE
  16211   "RTN","VPR DJX",24,0)
  16212    . S TYPE= "" F  S TY PE=$O(^TMP ("VPRX",$J ,DFN,TYPE) ) Q:TYPE=" "  D
  16213   "RTN","VPR DJX",25,0)
  16214    .. S RTN= $$TAG^VPRD J(TYPE)_"^ VPRDJ0" Q: '$L($T(@RT N))
  16215   "RTN","VPR DJX",26,0)
  16216    .. S DOMC NT=DOMCNT+ 1
  16217   "RTN","VPR DJX",27,0)
  16218    .. ;
  16219   "RTN","VPR DJX",28,0)
  16220    .. N VPR  S VPR=$NA( ^TMP("VPR" ,$J,PATCNT ,DOMCNT)), VPRI=0,VPR ID=""
  16221   "RTN","VPR DJX",29,0)
  16222    .. F  S V PRID=$O(^T MP("VPRX", $J,DFN,TYP E,VPRID))  Q:VPRID=""   S X=$G(^ (VPRID)) D
  16223   "RTN","VPR DJX",30,0)
  16224    ... N $ES ,$ET,ERRPA T,ERRMSG
  16225   "RTN","VPR DJX",31,0)
  16226    ... S $ET ="D ERRHDL R^VPRDERRH ",ERRPAT=D FN
  16227   "RTN","VPR DJX",32,0)
  16228    ... S ERR MSG="A pro blem occur red when t rying to r efresh pat ient data  from an AP I."
  16229   "RTN","VPR DJX",33,0)
  16230    ... ;
  16231   "RTN","VPR DJX",34,0)
  16232    ... I X=" @" D DELET E(TYPE,DFN ,VPRID) Q
  16233   "RTN","VPR DJX",35,0)
  16234    ... S VPR LASTI=VPRI  D @RTN    ;creates @ VPR@(VPRI+ 1)
  16235   "RTN","VPR DJX",36,0)
  16236    ... ;
  16237   "RTN","VPR DJX",37,0)
  16238    ... ; if  no new ite m, assume  the record  has been  deleted
  16239   "RTN","VPR DJX",38,0)
  16240    ... I VPR I'>VPRLAST I D DELETE (TYPE,DFN, VPRID) Q
  16241   "RTN","VPR DJX",39,0)
  16242    ... S VPR TOTL=VPRTO TL+1,DATA= 1
  16243   "RTN","VPR DJX",40,0)
  16244    .. I 'VPR I S DOMCNT =DOMCNT-1  Q   ;no da ta, or err or
  16245   "RTN","VPR DJX",41,0)
  16246    .. ;
  16247   "RTN","VPR DJX",42,0)
  16248    .. S:DOMC NT>1 @VPR@ (.3)=","
  16249   "RTN","VPR DJX",43,0)
  16250    .. S @VPR @(.5)="{"" domainName "":"""_TYP E_""",""to tal"":"_VP RI_",""ite ms"":["
  16251   "RTN","VPR DJX",44,0)
  16252    .. S VPRI =VPRI+1,@V PR@(VPRI)= "]}"
  16253   "RTN","VPR DJX",45,0)
  16254    . ;
  16255   "RTN","VPR DJX",46,0)
  16256   A . ; VPR= $NA(^TMP(" VPR",$J))  again
  16257   "RTN","VPR DJX",47,0)
  16258    . S:PATCN T>1 @VPR@( PATCNT,.3) =","
  16259   "RTN","VPR DJX",48,0)
  16260    . S @VPR@ (PATCNT,.5 )="{""pati entDfn"":" _DFN_",""p atientIcn" ":"""_ICN_ """"
  16261   "RTN","VPR DJX",49,0)
  16262    . I DOMCN T D
  16263   "RTN","VPR DJX",50,0)
  16264    .. S @VPR @(PATCNT,. 6)=",""dom ains"":["
  16265   "RTN","VPR DJX",51,0)
  16266    .. S DOMC NT=DOMCNT+ 1,@VPR@(PA TCNT,DOMCN T)="]"
  16267   "RTN","VPR DJX",52,0)
  16268    . ;
  16269   "RTN","VPR DJX",53,0)
  16270    . I $D(DE LETE) D
  16271   "RTN","VPR DJX",54,0)
  16272    .. S DOMC NT=DOMCNT+ 1,@VPR@(PA TCNT,DOMCN T,.5)=","" deletes"": ["
  16273   "RTN","VPR DJX",55,0)
  16274    .. S VPRI =0,UID=""  F  S UID=$ O(DELETE(U ID)) Q:UID =""  D
  16275   "RTN","VPR DJX",56,0)
  16276    ... S TYP E=DELETE(U ID),VPRI=V PRI+1
  16277   "RTN","VPR DJX",57,0)
  16278    ... S:VPR I>1 @VPR@( PATCNT,DOM CNT,VPRI,. 3)=","
  16279   "RTN","VPR DJX",58,0)
  16280    ... S @VP R@(PATCNT, DOMCNT,VPR I,1)="{""u id"":"""_U ID_""",""d omainName" ":"""_TYPE _"""}"
  16281   "RTN","VPR DJX",59,0)
  16282    .. S VPRI =VPRI+1,@V PR@(PATCNT ,DOMCNT,VP RI)="]"
  16283   "RTN","VPR DJX",60,0)
  16284    . ;
  16285   "RTN","VPR DJX",61,0)
  16286    . I $D(^T MP($J,"VPR  ERROR"))  D
  16287   "RTN","VPR DJX",62,0)
  16288    .. N ERRO R D BUILDE RR^VPRDJ(. ERROR)
  16289   "RTN","VPR DJX",63,0)
  16290    .. S DOMC NT=DOMCNT+ 1,@VPR@(PA TCNT,DOMCN T,.3)=","
  16291   "RTN","VPR DJX",64,0)
  16292    .. M @VPR @(PATCNT,D OMCNT)=ERR OR
  16293   "RTN","VPR DJX",65,0)
  16294    .. K ^TMP ($J,"VPR E RROR")
  16295   "RTN","VPR DJX",66,0)
  16296    . ;
  16297   "RTN","VPR DJX",67,0)
  16298    . S DOMCN T=DOMCNT+1 ,@VPR@(PAT CNT,DOMCNT )="}"
  16299   "RTN","VPR DJX",68,0)
  16300    ;
  16301   "RTN","VPR DJX",69,0)
  16302    S Y=$G(^T MP("VPRX", $J,0)) S:Y ="" Y=LAST
  16303   "RTN","VPR DJX",70,0)
  16304    S T=$$NOW ^XLFDT()
  16305   "RTN","VPR DJX",71,0)
  16306    S @VPR@(. 5)="{""api Version"": ""1.01""," "data"":{" "lastUpdat e"":"""_Y_ """,""star tDateTime" ":"""_TSTA RT_""",""t otalPatien ts"":"_PAT CNT
  16307   "RTN","VPR DJX",72,0)
  16308    S:PATCNT  @VPR@(.6)= ",""patien ts"":[",PA TCNT=PATCN T+1,@VPR@( PATCNT)="] "
  16309   "RTN","VPR DJX",73,0)
  16310    ;
  16311   "RTN","VPR DJX",74,0)
  16312   B ;
  16313   "RTN","VPR DJX",75,0)
  16314    I $D(^TMP ("VPRX",$J ,"OP")) D          ;o perational  data
  16315   "RTN","VPR DJX",76,0)
  16316    . S (VPRT OTL,DOMCNT )=0,PATCNT =PATCNT+1  K DATA,DEL ETE
  16317   "RTN","VPR DJX",77,0)
  16318    . S TYPE= "" F  S TY PE=$O(^TMP ("VPRX",$J ,"OP",TYPE )) Q:TYPE= ""  D
  16319   "RTN","VPR DJX",78,0)
  16320    .. S RTN= $$TAG^VPRE F(TYPE)_"^ VPREF" Q:' $L($T(@RTN ))
  16321   "RTN","VPR DJX",79,0)
  16322    .. S DOMC NT=DOMCNT+ 1,DFN=""
  16323   "RTN","VPR DJX",80,0)
  16324    .. ;
  16325   "RTN","VPR DJX",81,0)
  16326    .. N VPR  S VPR=$NA( ^TMP("VPR" ,$J,PATCNT ,DOMCNT)), VPRI=0,VPR ID=""
  16327   "RTN","VPR DJX",82,0)
  16328    .. F  S V PRID=$O(^T MP("VPRX", $J,"OP",TY PE,VPRID))  Q:VPRID=" "  S X=$G( ^(VPRID))  D
  16329   "RTN","VPR DJX",83,0)
  16330    ... I X=" @" D DELET E(TYPE,DFN ,VPRID) Q
  16331   "RTN","VPR DJX",84,0)
  16332    ... S VPR LASTI=VPRI  D @RTN            ;c reates @VP R@(VPRI+1)
  16333   "RTN","VPR DJX",85,0)
  16334    ... ; if  no new ite m, assume  the record  has been  deleted
  16335   "RTN","VPR DJX",86,0)
  16336    ... I VPR I'>VPRLAST I D DELETE (TYPE,DFN, VPRID) Q
  16337   "RTN","VPR DJX",87,0)
  16338    ... S VPR TOTL=VPRTO TL+1,DATA= 1
  16339   "RTN","VPR DJX",88,0)
  16340    .. I 'VPR I S DOMCNT =DOMCNT-1  Q       ;n o data, or  error
  16341   "RTN","VPR DJX",89,0)
  16342    .. ;
  16343   "RTN","VPR DJX",90,0)
  16344    .. S:DOMC NT>1 @VPR@ (.3)=","
  16345   "RTN","VPR DJX",91,0)
  16346    .. S @VPR @(.5)="{"" domainName "":"""_TYP E_""",""to tal"":"_VP RI_",""ite ms"":["
  16347   "RTN","VPR DJX",92,0)
  16348    .. S VPRI =VPRI+1,@V PR@(VPRI)= "]}"
  16349   "RTN","VPR DJX",93,0)
  16350    . ;
  16351   "RTN","VPR DJX",94,0)
  16352   C . ; VPR= $NA(^TMP(" VPR",$J))  again
  16353   "RTN","VPR DJX",95,0)
  16354    . I 'DOMC NT,'$D(DEL ETE) Q  ;n o data, or  error
  16355   "RTN","VPR DJX",96,0)
  16356    . S @VPR@ (PATCNT,.5 )=",""oper ational"": {"
  16357   "RTN","VPR DJX",97,0)
  16358    . I DOMCN T D
  16359   "RTN","VPR DJX",98,0)
  16360    .. S @VPR @(PATCNT,. 6)="""doma ins"":["
  16361   "RTN","VPR DJX",99,0)
  16362    .. S DOMC NT=DOMCNT+ 1 S @VPR@( PATCNT,DOM CNT)="]"
  16363   "RTN","VPR DJX",100,0 )
  16364    . ;
  16365   "RTN","VPR DJX",101,0 )
  16366    . I $D(DE LETE) D
  16367   "RTN","VPR DJX",102,0 )
  16368    .. S DOMC NT=DOMCNT+ 1 S:DOMCNT >1 @VPR@(P ATCNT,DOMC NT,.3)=","
  16369   "RTN","VPR DJX",103,0 )
  16370    .. S @VPR @(PATCNT,D OMCNT,.5)= """deletes "":["
  16371   "RTN","VPR DJX",104,0 )
  16372    .. S VPRI =0,UID=""  F  S UID=$ O(DELETE(U ID)) Q:UID =""  D
  16373   "RTN","VPR DJX",105,0 )
  16374    ... S TYP E=DELETE(U ID),VPRI=V PRI+1
  16375   "RTN","VPR DJX",106,0 )
  16376    ... S:VPR I>1 @VPR@( PATCNT,DOM CNT,VPRI,. 3)=","
  16377   "RTN","VPR DJX",107,0 )
  16378    ... S @VP R@(PATCNT, DOMCNT,VPR I,1)="{""u id"":"""_U ID_""",""d omainName" ":"""_TYPE _"""}"
  16379   "RTN","VPR DJX",108,0 )
  16380    .. S VPRI =VPRI+1,@V PR@(PATCNT ,DOMCNT,VP RI)="]"
  16381   "RTN","VPR DJX",109,0 )
  16382    . ;
  16383   "RTN","VPR DJX",110,0 )
  16384    . S DOMCN T=DOMCNT+1 ,@VPR@(PAT CNT,DOMCNT )="}"
  16385   "RTN","VPR DJX",111,0 )
  16386    ; 
  16387   "RTN","VPR DJX",112,0 )
  16388    S TSTOP=$ $NOW^XLFDT ()
  16389   "RTN","VPR DJX",113,0 )
  16390    S PATCNT= PATCNT+1,@ VPR@(PATCN T)=",""end DateTime"" :"""_TSTOP _"""}}" ;c lose JSON
  16391   "RTN","VPR DJX",114,0 )
  16392    K ^TMP("V PRX",$J),^ TMP("VPRTE XT",$J)
  16393   "RTN","VPR DJX",115,0 )
  16394    Q
  16395   "RTN","VPR DJX",116,0 )
  16396    ;
  16397   "RTN","VPR DJX",117,0 )
  16398   DELETE(NAM E,DFN,ID)  ; -- set D ELETE node s
  16399   "RTN","VPR DJX",118,0 )
  16400    N UID
  16401   "RTN","VPR DJX",119,0 )
  16402    S UID=$$S ETUID^VPRU TILS(NAME, DFN,ID)
  16403   "RTN","VPR DJX",120,0 )
  16404    S DELETE( UID)=NAME
  16405   "RTN","VPR DJX",121,0 )
  16406    Q
  16407   "RTN","VPR DJX",122,0 )
  16408    ;
  16409   "RTN","VPR DJX",123,0 )
  16410   GETLIST(LA ST,SYS,MAX ) ; -- bui ld list of  updates f or client
  16411   "RTN","VPR DJX",124,0 )
  16412    ; Returns  ^TMP("VPR X",$J,0) =  last DATE :SEQ inclu ded
  16413   "RTN","VPR DJX",125,0 )
  16414    ;          ^TMP("VPR X",$J,DFN, TYPE,ID)=A CT
  16415   "RTN","VPR DJX",126,0 )
  16416    N DATE,SE Q,DA,END,I DX,X0,DFN, TYPE,ID,AC T,D,N,CNT
  16417   "RTN","VPR DJX",127,0 )
  16418    K ^TMP("V PRX",$J)
  16419   "RTN","VPR DJX",128,0 )
  16420    S DATE=+L AST,SEQ=+$ P(LAST,":" ,2),CNT=0
  16421   "RTN","VPR DJX",129,0 )
  16422    S DA=$$FI ND^VPRPATS (SYS) Q:'D A
  16423   "RTN","VPR DJX",130,0 )
  16424    ;
  16425   "RTN","VPR DJX",131,0 )
  16426    ; generat e list ID,  and end p oint
  16427   "RTN","VPR DJX",132,0 )
  16428    S D=DT,N= +$O(^XTMP( "VPR-"_DT, "A"),-1)        ;last  entry, as  of now
  16429   "RTN","VPR DJX",133,0 )
  16430    I DATE=DT ,SEQ=N S ^ TMP("VPRX" ,$J,0)=LAS T Q  ;no n ew items
  16431   "RTN","VPR DJX",134,0 )
  16432    ;
  16433   "RTN","VPR DJX",135,0 )
  16434    S IDX=$NA (^XTMP("VP R-"_DATE,S EQ)),END=N      ;init  loop wher e left off
  16435   "RTN","VPR DJX",136,0 )
  16436    F  S IDX= $Q(@IDX) Q :$$DONE  D   Q:CNT'<M AX
  16437   "RTN","VPR DJX",137,0 )
  16438    . S D=+$P (IDX,"-",2 ),N=+$P(ID X,",",2)
  16439   "RTN","VPR DJX",138,0 )
  16440    . S X0=@I DX,DFN=$P( X0,U) S:DF N="" DFN=" OP"
  16441   "RTN","VPR DJX",139,0 )
  16442    . I DFN,' $D(^VPR(56 0,"ADFN",D FN,DA)) Q
  16443   "RTN","VPR DJX",140,0 )
  16444    . S TYPE= $P(X0,U,2) ,ID=$P(X0, U,3),ACT=$ P(X0,U,4)
  16445   "RTN","VPR DJX",141,0 )
  16446    . I TYPE= ""!(ID="")  Q  ;error
  16447   "RTN","VPR DJX",142,0 )
  16448    . I TYPE= "ROSTER",' $D(^VPR(56 0,"AROS",I D,DA)) Q
  16449   "RTN","VPR DJX",143,0 )
  16450    . S:'$D(^ TMP("VPRX" ,$J,DFN,TY PE,ID)) CN T=CNT+1
  16451   "RTN","VPR DJX",144,0 )
  16452    . S ^TMP( "VPRX",$J, DFN,TYPE,I D)=ACT
  16453   "RTN","VPR DJX",145,0 )
  16454    S ^TMP("V PRX",$J,0) =D_":"_N                   ;fina l date:seq
  16455   "RTN","VPR DJX",146,0 )
  16456    Q
  16457   "RTN","VPR DJX",147,0 )
  16458    ;
  16459   "RTN","VPR DJX",148,0 )
  16460   DONE() ; - - Return 1  or 0, if  loop has f inished
  16461   "RTN","VPR DJX",149,0 )
  16462    I IDX'?1" ^XTMP(""VP R-"7N.E  Q  1       ; end of ^XT MP("VPR")
  16463   "RTN","VPR DJX",150,0 )
  16464    N D,N S D =+$P(IDX," -",2),N=+$ P(IDX,",", 2)
  16465   "RTN","VPR DJX",151,0 )
  16466    ; check V PR-DATE su bscript
  16467   "RTN","VPR DJX",152,0 )
  16468    I D<DT Q  0                              ; prior day:  keep goin g
  16469   "RTN","VPR DJX",153,0 )
  16470    I D>DT Q  1                              ; next day:   stop loop
  16471   "RTN","VPR DJX",154,0 )
  16472    ; D=DT: c heck seque nce# subsc ript
  16473   "RTN","VPR DJX",155,0 )
  16474    I N>END Q  1
  16475   "RTN","VPR DJX",156,0 )
  16476    Q 0
  16477   "RTN","VPR DX")
  16478   1^43
  16479   "RTN","VPR EASU")
  16480   0^53^B5746 2080
  16481   "RTN","VPR EASU",1,0)
  16482   VPREASU ;S LC/GRR --  Serve Vist A referenc e data as  JSON via R PC ; 10/18 /12 6:26pm
  16483   "RTN","VPR EASU",2,0)
  16484    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  16485   "RTN","VPR EASU",3,0)
  16486    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  16487   "RTN","VPR EASU",4,0)
  16488    ;
  16489   "RTN","VPR EASU",5,0)
  16490   CLASS ; --  USR Class  file #893 0
  16491   "RTN","VPR EASU",6,0)
  16492    N PRV S P RV=+$G(VPR LAST)
  16493   "RTN","VPR EASU",7,0)
  16494    S VPRCNT= $$TOTAL^VP REF("^USR( 8930)")
  16495   "RTN","VPR EASU",8,0)
  16496    I PRV=0 S  PRV=.9
  16497   "RTN","VPR EASU",9,0)
  16498    I $L(VPRI D) D CLS1( VPRID) Q
  16499   "RTN","VPR EASU",10,0 )
  16500    F  S PRV= $O(^USR(89 30,PRV)) Q :PRV'>0  D  CLS1(PRV)  I VPRMAX, VPRI'<VPRM AX Q
  16501   "RTN","VPR EASU",11,0 )
  16502    Q
  16503   "RTN","VPR EASU",12,0 )
  16504    ;
  16505   "RTN","VPR EASU",13,0 )
  16506   CLS1(IEN)  ;
  16507   "RTN","VPR EASU",14,0 )
  16508    N $ES,$ET ,ERRMSG
  16509   "RTN","VPR EASU",15,0 )
  16510    S ERRMSG= $$ERRMSG^V PREF("User  Class",IE N)
  16511   "RTN","VPR EASU",16,0 )
  16512    S $ET="D  ERRHDLR^VP RDERRH"
  16513   "RTN","VPR EASU",17,0 )
  16514    N VPRV,FL DS,X,Y,INR EC
  16515   "RTN","VPR EASU",18,0 )
  16516    K VPRV S  FLDS=".01: .05;1*"
  16517   "RTN","VPR EASU",19,0 )
  16518    D GETS^DI Q(8930,IEN _",",FLDS, "IEN","VPR V")
  16519   "RTN","VPR EASU",20,0 )
  16520    S Y=$NA(V PRV(8930,I EN_","))
  16521   "RTN","VPR EASU",21,0 )
  16522    S INREC(" name")=$G( @Y@(.01,"E "))
  16523   "RTN","VPR EASU",22,0 )
  16524    S INREC(" localId")= IEN,INREC( "uid")=$$S ETUID^VPRU TILS("asu- class",,IE N)
  16525   "RTN","VPR EASU",23,0 )
  16526    S INREC(" abbreviati on")=$G(@Y @(.02,"E") ),INREC("a ctive")=$S ($G(@Y@(.0 3,"I"))=1: "true",1:" false")
  16527   "RTN","VPR EASU",24,0 )
  16528    S INREC(" displayNam e")=$G(@Y@ (.04,"E"))
  16529   "RTN","VPR EASU",25,0 )
  16530    I $D(VPRV ("8930.01" )) D
  16531   "RTN","VPR EASU",26,0 )
  16532    . N IEN2, ID,CNT
  16533   "RTN","VPR EASU",27,0 )
  16534    . S IEN2= "",CNT=0
  16535   "RTN","VPR EASU",28,0 )
  16536    . F  S IE N2=$O(VPRV (8930.01,I EN2)) Q:IE N2=""  D
  16537   "RTN","VPR EASU",29,0 )
  16538    . . S CNT =CNT+1,INR EC("subCla ss",CNT,"n ame")=VPRV ("8930.01" ,IEN2,".01 ","E")
  16539   "RTN","VPR EASU",30,0 )
  16540    . . S ID= VPRV(8930. 01,IEN2,.0 1,"I"),INR EC("subCla ss",CNT,"u id")=$$SET UID^VPRUTI LS("asu-cl ass",,ID)
  16541   "RTN","VPR EASU",31,0 )
  16542    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  16543   "RTN","VPR EASU",32,0 )
  16544    Q
  16545   "RTN","VPR EASU",33,0 )
  16546    ;
  16547   "RTN","VPR EASU",34,0 )
  16548   RULE ; --  USR Author ization/Su bscription  file #893 0.1
  16549   "RTN","VPR EASU",35,0 )
  16550    N PRV S P RV=+$G(VPR LAST)
  16551   "RTN","VPR EASU",36,0 )
  16552    S VPRCNT= $$TOTAL^VP REF("^USR( 8930.1)")
  16553   "RTN","VPR EASU",37,0 )
  16554    I PRV=0 S  PRV=.9
  16555   "RTN","VPR EASU",38,0 )
  16556    I $L(VPRI D) D RULE1 (VPRID) Q
  16557   "RTN","VPR EASU",39,0 )
  16558    F  S PRV= $O(^USR(89 30.1,PRV))  Q:PRV'>0   D RULE1(P RV) I VPRM AX,VPRI'<V PRMAX Q
  16559   "RTN","VPR EASU",40,0 )
  16560    Q
  16561   "RTN","VPR EASU",41,0 )
  16562    ;
  16563   "RTN","VPR EASU",42,0 )
  16564   RULE1(IEN)  ;
  16565   "RTN","VPR EASU",43,0 )
  16566    N $ES,$ET ,ERRMSG
  16567   "RTN","VPR EASU",44,0 )
  16568    S ERRMSG= $$ERRMSG^V PREF("ASU  Rule",IEN)
  16569   "RTN","VPR EASU",45,0 )
  16570    S $ET="D  ERRHDLR^VP RDERRH"
  16571   "RTN","VPR EASU",46,0 )
  16572    N VPRV,FL DS,X,Y,INR EC,DESC
  16573   "RTN","VPR EASU",47,0 )
  16574    K VPRV S  FLDS=".01: 1"
  16575   "RTN","VPR EASU",48,0 )
  16576    D GETS^DI Q(8930.1,I EN_",",FLD S,"IEN","V PRV")
  16577   "RTN","VPR EASU",49,0 )
  16578    S Y=$NA(V PRV(8930.1 ,IEN_","))
  16579   "RTN","VPR EASU",50,0 )
  16580    S INREC(" localId")= IEN,INREC( "uid")=$$S ETUID^VPRU TILS("asu- rule",,IEN )
  16581   "RTN","VPR EASU",51,0 )
  16582    S X=$G(@Y @(.01,"I") ) S:X INRE C("docDefU id")=$$SET UID^VPRUTI LS("doc-de f",,X),INR EC("docDef Name")=$G( @Y@(.01,"E "))
  16583   "RTN","VPR EASU",52,0 )
  16584    S X=$G(@Y @(.02,"I") ) S:X INRE C("statusU id")=$$SET UID^VPRUTI LS("doc-st atus",,X), INREC("sta tusName")= $G(@Y@(.02 ,"E"))
  16585   "RTN","VPR EASU",53,0 )
  16586    S X=$G(@Y @(.03,"I") ) S:X INRE C("actionU id")=$$SET UID^VPRUTI LS("doc-ac tion",,X), INREC("act ionName")= $G(@Y@(.03 ,"E"))
  16587   "RTN","VPR EASU",54,0 )
  16588    S X=$G(@Y @(.04,"I") ) S:X INRE C("userCla ssUid")=$$ SETUID^VPR UTILS("asu -class",,X ),INREC("u serClassNa me")=$G(@Y @(.04,"E") )
  16589   "RTN","VPR EASU",55,0 )
  16590    S X=$G(@Y @(.05,"I") ),INREC("i sAnd")=$S( X="&":"tru e",1:"fals e") ;,INRE C("isOr")= $S(X="!":" true",1:"f alse")
  16591   "RTN","VPR EASU",56,0 )
  16592    S X=$G(@Y @(.06,"I") ) S:X INRE C("userRol eUid")=$$S ETUID^VPRU TILS("asu- role",,X), INREC("use rRoleName" )=$G(@Y@(. 06,"E"))
  16593   "RTN","VPR EASU",57,0 )
  16594    I $D(@Y@( 1)) D
  16595   "RTN","VPR EASU",58,0 )
  16596    . N I S I =0 F  S I= $O(@Y@(1,I )) Q:I<1   S DESC(I)= @Y@(1,I)
  16597   "RTN","VPR EASU",59,0 )
  16598    . S INREC ("descript ion")=$$ST RING^VPRD( .DESC)
  16599   "RTN","VPR EASU",60,0 )
  16600    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  16601   "RTN","VPR EASU",61,0 )
  16602    Q
  16603   "RTN","VPR EASU",62,0 )
  16604    ;
  16605   "RTN","VPR EASU",63,0 )
  16606   ROLE ; --  USR Role f ile #8930. 2
  16607   "RTN","VPR EASU",64,0 )
  16608    N PRV S P RV=+$G(VPR LAST)
  16609   "RTN","VPR EASU",65,0 )
  16610    S VPRCNT= $$TOTAL^VP REF("^USR( 8930.2)")
  16611   "RTN","VPR EASU",66,0 )
  16612    I PRV=0 S  PRV=.9
  16613   "RTN","VPR EASU",67,0 )
  16614    I $L(VPRI D) D ROLE1 (VPRID) Q
  16615   "RTN","VPR EASU",68,0 )
  16616    F  S PRV= $O(^USR(89 30.2,PRV))  Q:PRV'>0   D ROLE1(P RV) I VPRM AX,VPRI'<V PRMAX Q
  16617   "RTN","VPR EASU",69,0 )
  16618    Q
  16619   "RTN","VPR EASU",70,0 )
  16620    ;
  16621   "RTN","VPR EASU",71,0 )
  16622   ROLE1(IEN)  ;
  16623   "RTN","VPR EASU",72,0 )
  16624    N $ES,$ET ,ERRMSG
  16625   "RTN","VPR EASU",73,0 )
  16626    S ERRMSG= $$ERRMSG^V PREF("User  Rule",IEN )
  16627   "RTN","VPR EASU",74,0 )
  16628    S $ET="D  ERRHDLR^VP RDERRH"
  16629   "RTN","VPR EASU",75,0 )
  16630    N VPRV,FL DS,X,Y,INR EC
  16631   "RTN","VPR EASU",76,0 )
  16632    K VPRV S  FLDS=".01: .03"
  16633   "RTN","VPR EASU",77,0 )
  16634    D GETS^DI Q(8930.2,I EN_",",FLD S,"IEN","V PRV")
  16635   "RTN","VPR EASU",78,0 )
  16636    S Y=$NA(V PRV(8930.2 ,IEN_","))
  16637   "RTN","VPR EASU",79,0 )
  16638    S INREC(" name")=$G( @Y@(.01,"E "))
  16639   "RTN","VPR EASU",80,0 )
  16640    S INREC(" uid")=$$SE TUID^VPRUT ILS("asu-r ole",,IEN)
  16641   "RTN","VPR EASU",81,0 )
  16642    S INREC(" displayNam e")=$G(@Y@ (.02,"E"))
  16643   "RTN","VPR EASU",82,0 )
  16644    S INREC(" abbreviati on")=$G(@Y @(.03,"E") )
  16645   "RTN","VPR EASU",83,0 )
  16646    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  16647   "RTN","VPR EASU",84,0 )
  16648    Q
  16649   "RTN","VPR EASU",85,0 )
  16650    ;
  16651   "RTN","VPR EASU",86,0 )
  16652   ACTION ; - - USR Acti on file #8 930.8
  16653   "RTN","VPR EASU",87,0 )
  16654    N PRV S P RV=+$G(VPR LAST)
  16655   "RTN","VPR EASU",88,0 )
  16656    S VPRCNT= $$TOTAL^VP REF("^USR( 8930.8)")
  16657   "RTN","VPR EASU",89,0 )
  16658    I PRV=0 S  PRV=.9
  16659   "RTN","VPR EASU",90,0 )
  16660    I $L(VPRI D) D ACT1( VPRID) Q
  16661   "RTN","VPR EASU",91,0 )
  16662    F  S PRV= $O(^USR(89 30.8,PRV))  Q:PRV'>0   D ACT1(PR V) I VPRMA X,VPRI'<VP RMAX Q
  16663   "RTN","VPR EASU",92,0 )
  16664    Q
  16665   "RTN","VPR EASU",93,0 )
  16666    ;
  16667   "RTN","VPR EASU",94,0 )
  16668   ACT1(IEN)  ;
  16669   "RTN","VPR EASU",95,0 )
  16670    N $ES,$ET ,ERRMSG
  16671   "RTN","VPR EASU",96,0 )
  16672    S ERRMSG= $$ERRMSG^V PREF("ASU  Action",IE N)
  16673   "RTN","VPR EASU",97,0 )
  16674    S $ET="D  ERRHDLR^VP RDERRH"
  16675   "RTN","VPR EASU",98,0 )
  16676    N VPRV,FL DS,X,Y,INR EC
  16677   "RTN","VPR EASU",99,0 )
  16678    K VPRV S  FLDS=".01: .08;1*"
  16679   "RTN","VPR EASU",100, 0)
  16680    D GETS^DI Q(8930.8,I EN_",",FLD S,"IEN","V PRV")
  16681   "RTN","VPR EASU",101, 0)
  16682    S Y=$NA(V PRV(8930.8 ,IEN_","))
  16683   "RTN","VPR EASU",102, 0)
  16684    S INREC(" name")=$G( @Y@(.01,"E ")),INREC( "actionUid ")=$$SETUI D^VPRUTILS ("doc-acti on",,IEN)
  16685   "RTN","VPR EASU",103, 0)
  16686    ; INREC(" isAuthoriz ation")=$S (@Y@(.02," E")="A":"t rue",1:"fa lse")
  16687   "RTN","VPR EASU",104, 0)
  16688    ; INREC(" isSubscrip tion")=$S( @Y@(.02,"E ")="S":"tr ue",1:"fal se")
  16689   "RTN","VPR EASU",105, 0)
  16690    S INREC(" eventType" )=$G(@Y@(. 02,"E"))
  16691   "RTN","VPR EASU",106, 0)
  16692    S INREC(" appliesTo" )=$G(@Y@(. 03,"E"))
  16693   "RTN","VPR EASU",107, 0)
  16694    S INREC(" userVerb") =$G(@Y@(.0 5,"E"))
  16695   "RTN","VPR EASU",108, 0)
  16696    S INREC(" documentVe rb")=$G(@Y @(.06,"E") )
  16697   "RTN","VPR EASU",109, 0)
  16698    S INREC(" userVerbMo difier")=$ G(@Y@(.07, "E"))
  16699   "RTN","VPR EASU",110, 0)
  16700    S INREC(" identifyin gPhrase")= $G(@Y@(.08 ,"E"))
  16701   "RTN","VPR EASU",111, 0)
  16702    I $D(VPRV (8930.81))  D
  16703   "RTN","VPR EASU",112, 0)
  16704    . N CNT,S NODE S CNT =0,SNODE=" "
  16705   "RTN","VPR EASU",113, 0)
  16706    . F  S SN ODE=$O(VPR V(8930.81, SNODE)) Q: SNODE=""   D
  16707   "RTN","VPR EASU",114, 0)
  16708    . . S CNT =CNT+1,INR EC("implie dAction",C NT,"name") =VPRV(8930 .81,SNODE, .01,"E")
  16709   "RTN","VPR EASU",115, 0)
  16710    . . S X=V PRV(8930.8 1,SNODE,.0 1,"I"),INR EC("implie dAction",C NT,"uid")= $$SETUID^V PRUTILS("d oc-action" ,,X)
  16711   "RTN","VPR EASU",116, 0)
  16712    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  16713   "RTN","VPR EASU",117, 0)
  16714    Q
  16715   "RTN","VPR EASU",118, 0)
  16716    ;
  16717   "RTN","VPR EASU",119, 0)
  16718   STATUS ; - - USR Reco rd Status  file #8930 .6
  16719   "RTN","VPR EASU",120, 0)
  16720    N PRV S P RV=+$G(VPR LAST)
  16721   "RTN","VPR EASU",121, 0)
  16722    S VPRCNT= $$TOTAL^VP REF("^USR( 8930.6)")
  16723   "RTN","VPR EASU",122, 0)
  16724    I PRV=0 S  PRV=.9
  16725   "RTN","VPR EASU",123, 0)
  16726    I $L(VPRI D) D STS1( VPRID) Q
  16727   "RTN","VPR EASU",124, 0)
  16728    F  S PRV= $O(^USR(89 30.6,PRV))  Q:PRV'>0   D STS1(PR V) I VPRMA X,VPRI'<VP RMAX Q
  16729   "RTN","VPR EASU",125, 0)
  16730    Q
  16731   "RTN","VPR EASU",126, 0)
  16732    ;
  16733   "RTN","VPR EASU",127, 0)
  16734   STS1(IEN)  ;
  16735   "RTN","VPR EASU",128, 0)
  16736    N $ES,$ET ,ERRMSG
  16737   "RTN","VPR EASU",129, 0)
  16738    S ERRMSG= $$ERRMSG^V PREF("ASU  Status",IE N)
  16739   "RTN","VPR EASU",130, 0)
  16740    S $ET="D  ERRHDLR^VP RDERRH"
  16741   "RTN","VPR EASU",131, 0)
  16742    N VPRV,FL DS,Y,INREC
  16743   "RTN","VPR EASU",132, 0)
  16744    K VPRV S  FLDS=".01: .04"
  16745   "RTN","VPR EASU",133, 0)
  16746    D GETS^DI Q(8930.6,I EN_",",FLD S,"IEN","V PRV")
  16747   "RTN","VPR EASU",134, 0)
  16748    S Y=$NA(V PRV(8930.6 ,IEN_","))
  16749   "RTN","VPR EASU",135, 0)
  16750    S INREC(" name")=$G( @Y@(.01,"E "))
  16751   "RTN","VPR EASU",136, 0)
  16752    S INREC(" uid")=$$SE TUID^VPRUT ILS("doc-s tatus",,IE N)
  16753   "RTN","VPR EASU",137, 0)
  16754    S INREC(" abbreviati on")=$G(@Y @(.02,"E") )
  16755   "RTN","VPR EASU",138, 0)
  16756    S INREC(" sequence") =$G(@Y@(.0 3,"E"))
  16757   "RTN","VPR EASU",139, 0)
  16758    S INREC(" appliesTo" )=$G(@Y@(. 04,"E"))
  16759   "RTN","VPR EASU",140, 0)
  16760    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  16761   "RTN","VPR EASU",141, 0)
  16762    Q
  16763   "RTN","VPR EASU",142, 0)
  16764    ;
  16765   "RTN","VPR EASU",143, 0)
  16766   DEF ; -- T IU Documen t Definiti on file #8 925.1
  16767   "RTN","VPR EASU",144, 0)
  16768    N PRV S P RV=+$G(VPR LAST)
  16769   "RTN","VPR EASU",145, 0)
  16770    S VPRCNT= $$TOTAL^VP REF("^TIU( 8925.1)")
  16771   "RTN","VPR EASU",146, 0)
  16772    I PRV=0 S  PRV=.9
  16773   "RTN","VPR EASU",147, 0)
  16774    I $L(VPRI D) D DEF1( VPRID) Q
  16775   "RTN","VPR EASU",148, 0)
  16776    F  S PRV= $O(^TIU(89 25.1,PRV))  Q:PRV'>0   D DEF1(PR V) I VPRMA X,VPRI'<VP RMAX Q
  16777   "RTN","VPR EASU",149, 0)
  16778    Q
  16779   "RTN","VPR EASU",150, 0)
  16780    ;
  16781   "RTN","VPR EASU",151, 0)
  16782   DEF1(IEN)  ;
  16783   "RTN","VPR EASU",152, 0)
  16784    N $ES,$ET ,ERRMSG
  16785   "RTN","VPR EASU",153, 0)
  16786    S ERRMSG= $$ERRMSG^V PREF("TIU  Doc Def",I EN)
  16787   "RTN","VPR EASU",154, 0)
  16788    S $ET="D  ERRHDLR^VP RDERRH"
  16789   "RTN","VPR EASU",155, 0)
  16790    N VPRV,FL DS,X,Y,I,I NREC
  16791   "RTN","VPR EASU",156, 0)
  16792    K VPRV S  FLDS=".01: .14;1501"
  16793   "RTN","VPR EASU",157, 0)
  16794    D GETS^DI Q(8925.1,I EN_",",FLD S,"IEN","V PRV")
  16795   "RTN","VPR EASU",158, 0)
  16796    S Y=$NA(V PRV(8925.1 ,IEN_","))
  16797   "RTN","VPR EASU",159, 0)
  16798    S INREC(" name")=$G( @Y@(.01,"E "))
  16799   "RTN","VPR EASU",160, 0)
  16800    S INREC(" uid")=$$SE TUID^VPRUT ILS("doc-d ef",,IEN)
  16801   "RTN","VPR EASU",161, 0)
  16802    S INREC(" abbreviati on")=$G(@Y @(.02,"E") )
  16803   "RTN","VPR EASU",162, 0)
  16804    S INREC(" displayNam e")=$G(@Y@ (.03,"E"))
  16805   "RTN","VPR EASU",163, 0)
  16806    S INREC(" typeName") =$G(@Y@(.0 4,"E"))
  16807   "RTN","VPR EASU",164, 0)
  16808    S INREC(" typeUid")= $$SETUID^V PRUTILS("d oc-type",, $G(@Y@(.04 ,"I")))
  16809   "RTN","VPR EASU",165, 0)
  16810    S X=$G(@Y @(.05,"I") ) I X D
  16811   "RTN","VPR EASU",166, 0)
  16812    . S INREC ("ownerUid ")=$$SETUI D^VPRUTILS ("user",,X )
  16813   "RTN","VPR EASU",167, 0)
  16814    . S INREC ("ownerNam e")=$G(@Y@ (.05,"E"))
  16815   "RTN","VPR EASU",168, 0)
  16816    S X=$G(@Y @(.06,"I") ) S:X INRE C("classOw ner")=$$SE TUID^VPRUT ILS("asu-c lass",,X)
  16817   "RTN","VPR EASU",169, 0)
  16818    S X=$G(@Y @(.07,"I") ) I X D
  16819   "RTN","VPR EASU",170, 0)
  16820    . S INREC ("statusUi d")=$$SETU ID^VPRUTIL S("doc-sta tus",,X)
  16821   "RTN","VPR EASU",171, 0)
  16822    . S INREC ("statusNa me")=$G(@Y @(.07,"E") )
  16823   "RTN","VPR EASU",172, 0)
  16824    S X=$G(@Y @(.1,"I"))  S:X INREC ("shared") ="true"
  16825   "RTN","VPR EASU",173, 0)
  16826    S X=$G(@Y @(.13,"I") ) S:X INRE C("nationa lStandard" )="true"
  16827   "RTN","VPR EASU",174, 0)
  16828    S X=$G(@Y @(.14,"I") ) S:X INRE C("posting Code")=$$S ETUID^VPRU TILS("doc- posting",, X)
  16829   "RTN","VPR EASU",175, 0)
  16830    S I=0 F   S I=$O(^TI U(8925.1,I EN,10,I))  Q:I<1  S X =+$G(^(I,0 )) D
  16831   "RTN","VPR EASU",176, 0)
  16832    . S INREC ("item",I, "uid")=$$S ETUID^VPRU TILS("doc- def",,X)
  16833   "RTN","VPR EASU",177, 0)
  16834    . S INREC ("item",I, "name")=$$ GET1^DIQ(8 925.1,X_", ",.01)
  16835   "RTN","VPR EASU",178, 0)
  16836    ; nationa l title in fo
  16837   "RTN","VPR EASU",179, 0)
  16838    S X=$G(@Y @(1501,"I" )) I X D   ;National  Title + at tributes
  16839   "RTN","VPR EASU",180, 0)
  16840    . N IENS, TIU,DA,FNU M,NAME
  16841   "RTN","VPR EASU",181, 0)
  16842    . S IENS= X_"," D GE TS^DIQ(892 6.1,IENS," *","IE","T IU")
  16843   "RTN","VPR EASU",182, 0)
  16844    . S INREC ("national Title","vu id")="urn: va:vuid:"_ $G(TIU(892 6.1,IENS,9 9.99,"E"))
  16845   "RTN","VPR EASU",183, 0)
  16846    . S INREC ("national Title","na me")=$G(TI U(8926.1,I ENS,.01,"E "))
  16847   "RTN","VPR EASU",184, 0)
  16848    . F I=".0 4^Subject^ 2",".05^Ro le^3",".06 ^Setting^4 ",".07^Ser vice^5",". 08^Type^6"  D
  16849   "RTN","VPR EASU",185, 0)
  16850    .. S DA=+ $G(TIU(892 6.1,IENS,+ I,"I")) Q: DA'>0
  16851   "RTN","VPR EASU",186, 0)
  16852    .. S FNUM ="8926."_+ $P(I,U,3), NAME=$$LOW ^XLFSTR($P (I,U,2))
  16853   "RTN","VPR EASU",187, 0)
  16854    .. S INRE C("nationa lTitle"_$P (I,U,2),"v uid")="urn :va:vuid:" _$$VUID^VP RD(DA,FNUM )
  16855   "RTN","VPR EASU",188, 0)
  16856    .. S INRE C("nationa lTitle"_$P (I,U,2),"n ame")=$G(T IU(8926.1, IENS,+I,"E "))
  16857   "RTN","VPR EASU",189, 0)
  16858    ;
  16859   "RTN","VPR EASU",190, 0)
  16860    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  16861   "RTN","VPR EASU",191, 0)
  16862    Q
  16863   "RTN","VPR EF")
  16864   0^54^B1532 29419
  16865   "RTN","VPR EF",1,0)
  16866   VPREF ;SLC /MKB -- Se rve VistA  operationa l data as  JSON via R PC ; 10/18 /12 6:26pm
  16867   "RTN","VPR EF",2,0)
  16868    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  16869   "RTN","VPR EF",3,0)
  16870    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  16871   "RTN","VPR EF",4,0)
  16872    ;
  16873   "RTN","VPR EF",5,0)
  16874   GET(VPR,FI LTER) ; --  Return se arch resul ts as JSON  in @VPR@( n)
  16875   "RTN","VPR EF",6,0)
  16876    ; RPC = V PR GET OPE RATIONAL D ATA
  16877   "RTN","VPR EF",7,0)
  16878    ; where F ILTER("dom ain")  = n ame of des ired data  type (see  $$TAG)
  16879   "RTN","VPR EF",8,0)
  16880    ;       F ILTER("lim it")   = m aximum num ber of ite ms to retu rn [opt]
  16881   "RTN","VPR EF",9,0)
  16882    ;       F ILTER("sta rt")   = i en to star t search f rom           [opt]
  16883   "RTN","VPR EF",10,0)
  16884    ;       F ILTER("id" )      = s ingle item  id to ret urn           [opt]
  16885   "RTN","VPR EF",11,0)
  16886    ;
  16887   "RTN","VPR EF",12,0)
  16888    N VPRSYS, TYPE,VPRMA X,VPRI,VPR ID,VPRERR, VPRTN,VPRL AST,VPRCNT
  16889   "RTN","VPR EF",13,0)
  16890    S VPR=$NA (^TMP("VPR ",$J)),VPR I=0 K @VPR
  16891   "RTN","VPR EF",14,0)
  16892    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  16893   "RTN","VPR EF",15,0)
  16894    ;
  16895   "RTN","VPR EF",16,0)
  16896    ; parse &  validate  input para meters
  16897   "RTN","VPR EF",17,0)
  16898    S TYPE=$G (FILTER("d omain")) ; ,TYPE=$$LO W^XLFSTR(T YPE)
  16899   "RTN","VPR EF",18,0)
  16900    S VPRMAX= +$G(FILTER ("limit")) ,VPRCNT=0
  16901   "RTN","VPR EF",19,0)
  16902    S VPRLAST =+$G(FILTE R("start") )
  16903   "RTN","VPR EF",20,0)
  16904    S VPRID=$ G(FILTER(" id"))
  16905   "RTN","VPR EF",21,0)
  16906    ;
  16907   "RTN","VPR EF",22,0)
  16908    ;set erro r trap
  16909   "RTN","VPR EF",23,0)
  16910    K ^TMP($J ,"VPR ERRO R")
  16911   "RTN","VPR EF",24,0)
  16912    ;
  16913   "RTN","VPR EF",25,0)
  16914    ; extract  data
  16915   "RTN","VPR EF",26,0)
  16916    I TYPE=""  S VPRERR= "Missing o r invalid  reference  type" G GT Q
  16917   "RTN","VPR EF",27,0)
  16918    I $D(ZTQU EUED) S VP R=$NA(^XTM P(VPRBATCH ,VPRFZTSK, TYPE)) K @ VPR
  16919   "RTN","VPR EF",28,0)
  16920    I TYPE="n ew",$L($T( EN^VPREFX) ) D EN^VPR EFX(VPRID, VPRMAX) Q
  16921   "RTN","VPR EF",29,0)
  16922    S VPRTN=$ $TAG(TYPE)  Q:'$L(VPR TN)  ;D ER R(2) Q
  16923   "RTN","VPR EF",30,0)
  16924    ;N $ES,$E T,ERRMSG
  16925   "RTN","VPR EF",31,0)
  16926    ;S $ET="D  ERRHDLR^V PRDERRH",E RRMSG="A M UMPS error  occurred  while extr acting "_T YPE_" data "
  16927   "RTN","VPR EF",32,0)
  16928    D @VPRTN
  16929   "RTN","VPR EF",33,0)
  16930    ;
  16931   "RTN","VPR EF",34,0)
  16932   GTQ ; add  item count  and termi nating cha racters
  16933   "RTN","VPR EF",35,0)
  16934    N ERROR I  $D(^TMP($ J,"VPR ERR OR"))>0 D  BUILDERR(. ERROR) S E RROR(1)=ER ROR(1)_"}"
  16935   "RTN","VPR EF",36,0)
  16936    I +$G(FIL TER("noHea d"))=1 D   Q
  16937   "RTN","VPR EF",37,0)
  16938    .S @VPR@( "total")=+ $G(VPRI)
  16939   "RTN","VPR EF",38,0)
  16940    .I $L($G( ERROR(1))) >1 S @VPR@ ("error")= ERROR(1)
  16941   "RTN","VPR EF",39,0)
  16942    I '$D(@VP R)!'$G(VPR I) D  Q
  16943   "RTN","VPR EF",40,0)
  16944    .I '$D(^T MP($J,"VPR  ERROR"))  S @VPR@(1) ="""data"" :{""totalI tems"":0," "items"":[ ]}}" Q
  16945   "RTN","VPR EF",41,0)
  16946    .S @VPR@( 1)="""data "":{""tota lItems"":0 ,""items"" :[]},"
  16947   "RTN","VPR EF",42,0)
  16948    .M @VPR@( 2)=ERROR
  16949   "RTN","VPR EF",43,0)
  16950    ;
  16951   "RTN","VPR EF",44,0)
  16952    I $D(@VPR ),$G(VPRI)  D
  16953   "RTN","VPR EF",45,0)
  16954    . S @VPR@ (.5)="{""a piVersion" ":""1.01"" ,""data"": {""updated "":"""_$$H L7NOW_""", ""currentI temCount"" :"_VPRI
  16955   "RTN","VPR EF",46,0)
  16956    . S:$G(VP RCNT) @VPR @(.5)=@VPR @(.5)_","" totalItems "":"_VPRCN T
  16957   "RTN","VPR EF",47,0)
  16958    . S:$G(VP RLAST) @VP R@(.5)=@VP R@(.5)_"," "last"":"_ VPRLAST
  16959   "RTN","VPR EF",48,0)
  16960    . S @VPR@ (.5)=@VPR@ (.5)_",""i tems"":["
  16961   "RTN","VPR EF",49,0)
  16962    . S VPRI= VPRI+1,@VP R@(VPRI)=$ S($D(^TMP( $J,"VPR ER ROR"))>0:" ]}",1:"]}} ")
  16963   "RTN","VPR EF",50,0)
  16964    I $D(^TMP ($J,"VPR E RROR"))>0  S VPRI=VPR I+1,@VPR@( VPRI,.3)=" ," M @VPR@ (VPRI)=ERR OR ;S VPRI =VPRI+1,@V PR@(VPRI)= "}"
  16965   "RTN","VPR EF",51,0)
  16966    K ^TMP($J ,"VPR ERRO R")
  16967   "RTN","VPR EF",52,0)
  16968    Q
  16969   "RTN","VPR EF",53,0)
  16970    ;
  16971   "RTN","VPR EF",54,0)
  16972   BUILDERR(R ESULT) ; - - build er ror array
  16973   "RTN","VPR EF",55,0)
  16974    N CNT,COU NT,DOM,DOM CNT,ERRMSG ,ERROR,FIE LD,MESSAGE ,MSG,MSGCN T,T,TEMP
  16975   "RTN","VPR EF",56,0)
  16976    S COUNT=$ G(^TMP($J, "VPR ERROR ","# of Er rors"))
  16977   "RTN","VPR EF",57,0)
  16978    S MESSAGE ="A mumps  error occu rred when  extracting  data. A t otal of "_ COUNT_" oc curred.\n\ r"
  16979   "RTN","VPR EF",58,0)
  16980    S CNT=1,E RROR("erro r","messag e","\",CNT )="A mumps  error occ urred when  extractin g patient  data. A to tal of "_C OUNT_" occ urred.\n\r "
  16981   "RTN","VPR EF",59,0)
  16982    S MSGCNT= 0 F  S MSG CNT=$O(^TM P($J,"VPR  ERROR","ER ROR MESSAG E",MSGCNT) ) Q:MSGCNT '>0  D
  16983   "RTN","VPR EF",60,0)
  16984    . S CNT=C NT+1,MESSA GE=MESSAGE _$G(^TMP($ J,"VPR ERR OR","ERROR  MESSAGE", MSGCNT))_" \n\r"
  16985   "RTN","VPR EF",61,0)
  16986    S RESULT( 1)="""erro r"":{""mes sage"":"_" """_MESSAG E_""""_"}"
  16987   "RTN","VPR EF",62,0)
  16988    Q
  16989   "RTN","VPR EF",63,0)
  16990    ;
  16991   "RTN","VPR EF",64,0)
  16992   TAG(X) ; - - Return l inetag for  reference  domain X
  16993   "RTN","VPR EF",65,0)
  16994    N Y S Y=" VPR",X=$G( X)
  16995   "RTN","VPR EF",66,0)
  16996    ; default  = VPR Obj ect (vario us types)
  16997   "RTN","VPR EF",67,0)
  16998    I X="loca tion"       S Y="LOC"
  16999   "RTN","VPR EF",68,0)
  17000    I X="pati ent"        S Y="PAT"
  17001   "RTN","VPR EF",69,0)
  17002    I X="pers on"         S Y="NP"
  17003   "RTN","VPR EF",70,0)
  17004    I X="user "           S Y="NP"
  17005   "RTN","VPR EF",71,0)
  17006    I X="rost er"         S Y="ROS"
  17007   "RTN","VPR EF",72,0)
  17008    I X="labg roup"       S Y="LABG RP"
  17009   "RTN","VPR EF",73,0)
  17010    I X="labp anel"       S Y="LABP NL"
  17011   "RTN","VPR EF",74,0)
  17012    I X["orde rable"      S Y="OI"
  17013   "RTN","VPR EF",75,0)
  17014    I X["sche dule"       S Y="SCHE DULE"
  17015   "RTN","VPR EF",76,0)
  17016    I X["rout e"          S Y="ROUT E"
  17017   "RTN","VPR EF",77,0)
  17018    I X["quic k"          S Y="QO"
  17019   "RTN","VPR EF",78,0)
  17020    I X="disp layGroup"   S Y="ODG"
  17021   "RTN","VPR EF",79,0)
  17022    I X["asu- "           S Y="ASU"
  17023   "RTN","VPR EF",80,0)
  17024    I X["doc- "           S Y="ASU"
  17025   "RTN","VPR EF",81,0)
  17026    I X["clio term"       S Y="MDTE RMS" ;blj
  17027   "RTN","VPR EF",82,0)
  17028    Q Y
  17029   "RTN","VPR EF",83,0)
  17030    ;
  17031   "RTN","VPR EF",84,0)
  17032   ERR(X,VAL)  ; -- retu rn error m essage
  17033   "RTN","VPR EF",85,0)
  17034    N MSG  S  MSG="Error "
  17035   "RTN","VPR EF",86,0)
  17036    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  17037   "RTN","VPR EF",87,0)
  17038    I X=3  S  MSG="UID ' "_$G(VAL)_ "' not fou nd"
  17039   "RTN","VPR EF",88,0)
  17040    I X=99 S  MSG="Unkno wn request "
  17041   "RTN","VPR EF",89,0)
  17042    Q MSG
  17043   "RTN","VPR EF",90,0)
  17044    ;
  17045   "RTN","VPR EF",91,0)
  17046   ERRMSG(X,V AL) ; -- r eturn erro r message,  if needed
  17047   "RTN","VPR EF",92,0)
  17048    N Y S Y=" A MUMPS er ror occurr ed while e xtracting  "_X_" data "
  17049   "RTN","VPR EF",93,0)
  17050    S:$G(VAL)  Y=Y_", ie n "_VAL
  17051   "RTN","VPR EF",94,0)
  17052    Q Y
  17053   "RTN","VPR EF",95,0)
  17054    ;
  17055   "RTN","VPR EF",96,0)
  17056   ERRQ ; --  Quit for e rror handl ing
  17057   "RTN","VPR EF",97,0)
  17058    Q
  17059   "RTN","VPR EF",98,0)
  17060    ;
  17061   "RTN","VPR EF",99,0)
  17062   HL7NOW() ;  -- Return  current t ime in HL7  format
  17063   "RTN","VPR EF",100,0)
  17064    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  17065   "RTN","VPR EF",101,0)
  17066    ;
  17067   "RTN","VPR EF",102,0)
  17068   ALL() ;
  17069   "RTN","VPR EF",103,0)
  17070    Q "locati on;patient ;person;or derable;sc hedule;rou te;quick;d isplayGrou p;asu-clas s;asu-rule ;asu-role; doc-action ;doc-statu s;clioterm "
  17071   "RTN","VPR EF",104,0)
  17072    ;
  17073   "RTN","VPR EF",105,0)
  17074   ADD(ITEM)  ; -- add I TEM to @VP R@(VPRI)
  17075   "RTN","VPR EF",106,0)
  17076    N VPRY,VP RERR
  17077   "RTN","VPR EF",107,0)
  17078    D ENCODE^ VPRJSON(IT EM,"VPRY", "VPRERR")
  17079   "RTN","VPR EF",108,0)
  17080    I $D(VPRE RR) D  ;re turn ERRor  instead o f ITEM
  17081   "RTN","VPR EF",109,0)
  17082    . N VPRTM P,VPRTXT,V PRITM
  17083   "RTN","VPR EF",110,0)
  17084    . M VPRIT M=@ITEM K  VPRY
  17085   "RTN","VPR EF",111,0)
  17086    . S VPRTX T(1)="Prob lem encodi ng json ou tput."
  17087   "RTN","VPR EF",112,0)
  17088    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.VP RITM)
  17089   "RTN","VPR EF",113,0)
  17090    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","V PRY","VPRE RR")
  17091   "RTN","VPR EF",114,0)
  17092    I $D(VPRY ) D
  17093   "RTN","VPR EF",115,0)
  17094    . I VPRI  D COMMA(VP RI)
  17095   "RTN","VPR EF",116,0)
  17096    . ;I VPRI ,'$G(FILTE R("noHead" )) D COMMA (VPRI)
  17097   "RTN","VPR EF",117,0)
  17098    . S VPRI= VPRI+1 M @ VPR@(VPRI) =VPRY
  17099   "RTN","VPR EF",118,0)
  17100    Q
  17101   "RTN","VPR EF",119,0)
  17102    ;
  17103   "RTN","VPR EF",120,0)
  17104   COMMA(I) ;  -- add co mma betwee n items
  17105   "RTN","VPR EF",121,0)
  17106    I $D(ZTQU EUED) Q
  17107   "RTN","VPR EF",122,0)
  17108    N J S J=+ $O(@VPR@(I ,"A"),-1)  ;last sub- node for i tem I
  17109   "RTN","VPR EF",123,0)
  17110    S J=J+1,@ VPR@(I,J)= ","
  17111   "RTN","VPR EF",124,0)
  17112    Q
  17113   "RTN","VPR EF",125,0)
  17114    ;
  17115   "RTN","VPR EF",126,0)
  17116   TOTAL(ROOT ) ; -- Ret urn total  #items in  @ROOT@(n)
  17117   "RTN","VPR EF",127,0)
  17118    Q $P($G(@ ROOT@(0)), U,4)
  17119   "RTN","VPR EF",128,0)
  17120    ;
  17121   "RTN","VPR EF",129,0)
  17122    N I,Y S ( I,Y)=0
  17123   "RTN","VPR EF",130,0)
  17124    F  S I=$O (@ROOT@(I) ) Q:I<1  S  Y=Y+1
  17125   "RTN","VPR EF",131,0)
  17126    Q Y
  17127   "RTN","VPR EF",132,0)
  17128    ;
  17129   "RTN","VPR EF",133,0)
  17130   TEST(TYPE, ID,IN) ; - - test GET , write re sults to s creen
  17131   "RTN","VPR EF",134,0)
  17132    N OUT,IDX
  17133   "RTN","VPR EF",135,0)
  17134    S U="^"
  17135   "RTN","VPR EF",136,0)
  17136    S IN("dom ain")=$G(T YPE)
  17137   "RTN","VPR EF",137,0)
  17138    S:$D(ID)  IN("id")=I D
  17139   "RTN","VPR EF",138,0)
  17140    D GET(.OU T,.IN)
  17141   "RTN","VPR EF",139,0)
  17142    ;
  17143   "RTN","VPR EF",140,0)
  17144    S IDX=OUT
  17145   "RTN","VPR EF",141,0)
  17146    F  S IDX= $Q(@IDX) Q :IDX'?1"^T MP(""VPR"" ,"1.N.E  Q :+$P(IDX," ,",2)'=$J   W !,@IDX
  17147   "RTN","VPR EF",142,0)
  17148    Q
  17149   "RTN","VPR EF",143,0)
  17150    ;
  17151   "RTN","VPR EF",144,0)
  17152    ; ** Refe rence file  searches,  using FIL TER("param eter")
  17153   "RTN","VPR EF",145,0)
  17154    ;
  17155   "RTN","VPR EF",146,0)
  17156   PAT ; -- R eturn Pati ents [use  shorter DE M^VPRDJ00? ]
  17157   "RTN","VPR EF",147,0)
  17158    N DFN,PAT ,VPRPOPD
  17159   "RTN","VPR EF",148,0)
  17160    S VPRPOPD =1
  17161   "RTN","VPR EF",149,0)
  17162    S VPRCNT= $$TOTAL("^ DPT")
  17163   "RTN","VPR EF",150,0)
  17164    ;I $G(VPR ID) S DFN= VPRID D DP T1^VPRDJ00 ,ADD("PAT" ) Q
  17165   "RTN","VPR EF",151,0)
  17166    I $G(VPRI D) S DFN=V PRID D DPT 1^VPRDJ00  Q
  17167   "RTN","VPR EF",152,0)
  17168    N ERRMSG  S ERRMSG=" A mumps er ror occurr ed while e xtracting  patients."
  17169   "RTN","VPR EF",153,0)
  17170    ;Q:VPRI'< VPRMAX
  17171   "RTN","VPR EF",154,0)
  17172    S DFN=+$G (VPRLAST)  F  S DFN=$ O(^DPT(DFN )) Q:DFN<1   D  I VPR MAX>0,VPRI '<VPRMAX Q
  17173   "RTN","VPR EF",155,0)
  17174    . N $ES,$ ET
  17175   "RTN","VPR EF",156,0)
  17176    . S $ET=" D ERRHDLR^ VPRDERRH"
  17177   "RTN","VPR EF",157,0)
  17178    . I $P($G (^DPT(DFN, 0)),U)=""  Q
  17179   "RTN","VPR EF",158,0)
  17180    . S ERRMS G=$$ERRMSG ("Patient" ,DFN)
  17181   "RTN","VPR EF",159,0)
  17182    . K PAT D  DPT1^VPRD J00
  17183   "RTN","VPR EF",160,0)
  17184    . ;D ADD( "PAT") S V PRLAST=DFN
  17185   "RTN","VPR EF",161,0)
  17186    . S VPRLA ST=DFN
  17187   "RTN","VPR EF",162,0)
  17188    Q
  17189   "RTN","VPR EF",163,0)
  17190   LOC ; -- R eturn Hosp ital Locat ions
  17191   "RTN","VPR EF",164,0)
  17192    S VPRCNT= $$TOTAL("^ SC")
  17193   "RTN","VPR EF",165,0)
  17194    I $G(VPRI D) D LOC1( VPRID) Q
  17195   "RTN","VPR EF",166,0)
  17196    N HL S HL =+$G(VPRLA ST)
  17197   "RTN","VPR EF",167,0)
  17198    F  S HL=$ O(^SC(HL))  Q:HL<1  D  LOC1(HL)  I VPRMAX>0 ,VPRI'<VPR MAX Q
  17199   "RTN","VPR EF",168,0)
  17200    Q
  17201   "RTN","VPR EF",169,0)
  17202    ;
  17203   "RTN","VPR EF",170,0)
  17204   LOC1(IEN)  ; -- get o ne locatio n
  17205   "RTN","VPR EF",171,0)
  17206    N $ES,$ET ,ERRMSG
  17207   "RTN","VPR EF",172,0)
  17208    S ERRMSG= $$ERRMSG(" Location", IEN)
  17209   "RTN","VPR EF",173,0)
  17210    S $ET="D  ERRHDLR^VP RDERRH"
  17211   "RTN","VPR EF",174,0)
  17212    N LOC,X0, X,Y
  17213   "RTN","VPR EF",175,0)
  17214    S X0=$G(^ SC(IEN,0)) ,LOC("name ")=$P(X0,U )
  17215   "RTN","VPR EF",176,0)
  17216    S LOC("lo calId")=IE N,LOC("uid ")=$$SETUI D^VPRUTILS ("location ",,IEN)
  17217   "RTN","VPR EF",177,0)
  17218    S LOC("sh ortName")= $P(X0,U,2) ,LOC("type ")=$P(X0,U ,3)
  17219   "RTN","VPR EF",178,0)
  17220    S LOC("re fId")=IEN
  17221   "RTN","VPR EF",179,0)
  17222    I $G(^SC( IEN,42))'= "" D
  17223   "RTN","VPR EF",180,0)
  17224    .I $D(^DI C(42,+^SC( IEN,42)))  S LOC("ref Id")=+^SC( IEN,42)
  17225   "RTN","VPR EF",181,0)
  17226    S X=+$P(X 0,U,4) I X  D
  17227   "RTN","VPR EF",182,0)
  17228    . S Y=$$N S^XUAF4(X) ,X=$P(Y,U, 2)_U_$P(Y, U)
  17229   "RTN","VPR EF",183,0)
  17230    . D FACIL ITY^VPRUTI LS(X,"LOC" )
  17231   "RTN","VPR EF",184,0)
  17232    I '$$ACTL OC(IEN) S  LOC("inact ive")="tru e"
  17233   "RTN","VPR EF",185,0)
  17234    D ADD("LO C") S VPRL AST=IEN
  17235   "RTN","VPR EF",186,0)
  17236    Q
  17237   "RTN","VPR EF",187,0)
  17238    ;
  17239   "RTN","VPR EF",188,0)
  17240   ACTLOC(LOC ) ; Functi on: return s TRUE if  active hos pital loca tion
  17241   "RTN","VPR EF",189,0)
  17242    ; IA# 100 40.
  17243   "RTN","VPR EF",190,0)
  17244    N D0,X I  +$G(^SC(LO C,"OOS"))  Q 0                 ;  screen ou t OOS entr y
  17245   "RTN","VPR EF",191,0)
  17246    S D0=+$G( ^SC(LOC,42 )) I D0 D  WIN^DGPMDD CF Q 'X  ;  chk out o f svc ward s
  17247   "RTN","VPR EF",192,0)
  17248    S X=$G(^S C(LOC,"I") ) I +X=0 Q  1                  ;  no inacti vate date
  17249   "RTN","VPR EF",193,0)
  17250    I DT>$P(X ,U)&($P(X, U,2)=""!(D T<$P(X,U,2 ))) Q 0  ;  chk react ivate date
  17251   "RTN","VPR EF",194,0)
  17252    Q 1                                                 ;  must stil l be activ e
  17253   "RTN","VPR EF",195,0)
  17254    ;
  17255   "RTN","VPR EF",196,0)
  17256   NP ; -- Re turn New P ersons
  17257   "RTN","VPR EF",197,0)
  17258    N PRV
  17259   "RTN","VPR EF",198,0)
  17260    S VPRCNT= $$TOTAL("^ VA(200)")
  17261   "RTN","VPR EF",199,0)
  17262    I $G(VPRI D) D NP1(V PRID) Q
  17263   "RTN","VPR EF",200,0)
  17264    S PRV=+$G (VPRLAST)  ;$S(VPRLAS T:VPRLAST, 1:.9)
  17265   "RTN","VPR EF",201,0)
  17266    I PRV=0 S  PRV=.9
  17267   "RTN","VPR EF",202,0)
  17268    F  S PRV= $O(^VA(200 ,PRV)) Q:P RV<1  D NP 1(PRV) I V PRMAX>0,VP RI'<VPRMAX  Q
  17269   "RTN","VPR EF",203,0)
  17270    Q
  17271   "RTN","VPR EF",204,0)
  17272    ;
  17273   "RTN","VPR EF",205,0)
  17274   NP1(IEN) ;  -- get on e person
  17275   "RTN","VPR EF",206,0)
  17276    N $ES,$ET ,ERRMSG
  17277   "RTN","VPR EF",207,0)
  17278    S ERRMSG= $$ERRMSG(" person",IE N)
  17279   "RTN","VPR EF",208,0)
  17280    S $ET="D  ERRHDLR^VP RDERRH"
  17281   "RTN","VPR EF",209,0)
  17282    N VPRV,FL DS,USER,X, Y
  17283   "RTN","VPR EF",210,0)
  17284    I $$ISPRO XY(IEN)=1  Q
  17285   "RTN","VPR EF",211,0)
  17286    K VPRV S  FLDS=".01; 4:9.2;9.5* ;19:53.8;6 54.3;.132: .138"
  17287   "RTN","VPR EF",212,0)
  17288    D GETS^DI Q(200,IEN_ ",",FLDS," IEN","VPRV ")
  17289   "RTN","VPR EF",213,0)
  17290    S Y=$NA(V PRV(200,IE N_","))
  17291   "RTN","VPR EF",214,0)
  17292    S USER("n ame")=$G(@ Y@(.01,"E" ))
  17293   "RTN","VPR EF",215,0)
  17294    S USER("l ocalId")=I EN,USER("u id")=$$SET UID^VPRUTI LS("user", ,IEN)
  17295   "RTN","VPR EF",216,0)
  17296    S:$D(@Y@( 4)) USER(" genderCode ")="urn:va :gender:"_ @Y@(4,"I") ,USER("gen derName")= @Y@(4,"E")
  17297   "RTN","VPR EF",217,0)
  17298    S X=+$P($ G(@Y@(5,"I ")),".") S :X USER("d ateOfBirth ")=$$JSOND T^VPRUTILS (X)
  17299   "RTN","VPR EF",218,0)
  17300    S X=$G(@Y @(7,"I"))  S:$L(X) US ER("disuse r")=$S(X:" true",1:"f alse")
  17301   "RTN","VPR EF",219,0)
  17302    S X=$G(@Y @(8,"E"))  S:$L(X) US ER("title" )=X
  17303   "RTN","VPR EF",220,0)
  17304    S X=$G(@Y @(9,"E"))  S:$L(X) US ER("ssn")= X
  17305   "RTN","VPR EF",221,0)
  17306    S X=$G(@Y @(9.2,"I") ) S:$L(X)  USER("term inated")=$ $JSONDT^VP RUTILS(X)
  17307   "RTN","VPR EF",222,0)
  17308    S X=+$G(@ Y@(19,"I") ) S:X USER ("delegate Code")=$$S ETUID^VPRU TILS("user ",,X),USER ("delegate Name")=$G( @Y@(19,"E" ))
  17309   "RTN","VPR EF",223,0)
  17310    S X=$G(@Y @(29,"E"))  S:$L(X) U SER("servi ce")=X
  17311   "RTN","VPR EF",224,0)
  17312    S X=$G(@Y @(53.5,"E" )) S:$L(X)  USER("pro viderClass ")=X
  17313   "RTN","VPR EF",225,0)
  17314    S X=$G(@Y @(53.6,"E" )) S:$L(X)  USER("pro viderType" )=X
  17315   "RTN","VPR EF",226,0)
  17316    S X=+$G(@ Y@(654.3," I")) S:X U SER("surro gateCode") =$$SETUID^ VPRUTILS(" user",,X), USER("surr ogateName" )=$G(@Y@(6 54.3,"E"))
  17317   "RTN","VPR EF",227,0)
  17318    S X=$G(@Y @(.132,"E" )) S:$L(X)  USER("off icePhone") =X
  17319   "RTN","VPR EF",228,0)
  17320    S X=$G(@Y @(.133,"E" )) S:$L(X)  USER("pho ne3")=X
  17321   "RTN","VPR EF",229,0)
  17322    S X=$G(@Y @(.134,"E" )) S:$L(X)  USER("pho ne4")=X
  17323   "RTN","VPR EF",230,0)
  17324    S X=$G(@Y @(.135,"E" )) S:$L(X)  USER("com mercialPho ne")=X
  17325   "RTN","VPR EF",231,0)
  17326    S X=$G(@Y @(.136,"E" )) S:$L(X)  USER("fax ")=X
  17327   "RTN","VPR EF",232,0)
  17328    S X=$G(@Y @(.137,"E" )) S:$L(X)  USER("voi cePager")= X
  17329   "RTN","VPR EF",233,0)
  17330    S X=$G(@Y @(.138,"E" )) S:$L(X)  USER("dig italPager" )=X
  17331   "RTN","VPR EF",234,0)
  17332    D KEYS(IE N)
  17333   "RTN","VPR EF",235,0)
  17334    D ADD("US ER") S VPR LAST=IEN
  17335   "RTN","VPR EF",236,0)
  17336    Q
  17337   "RTN","VPR EF",237,0)
  17338    ;
  17339   "RTN","VPR EF",238,0)
  17340   KEYS(IEN)  ; -- get u ser's keys
  17341   "RTN","VPR EF",239,0)
  17342    N VPRKEY, IENS,X,CNT
  17343   "RTN","VPR EF",240,0)
  17344    D GETS^DI Q(200,IEN_ ",","51*", "IE","VPRK EY") S CNT =0
  17345   "RTN","VPR EF",241,0)
  17346    S IENS=""  F  S IENS =$O(VPRKEY (200.051,I ENS)) Q:IE NS=""  D
  17347   "RTN","VPR EF",242,0)
  17348    . S X=$G( VPRKEY(200 .051,IENS, .01,"E")), CNT=CNT+1
  17349   "RTN","VPR EF",243,0)
  17350    . S USER( "vistaKeys ",CNT,"nam e")=X
  17351   "RTN","VPR EF",244,0)
  17352    . S X=$G( VPRKEY(200 .051,IENS, 3,"I"))
  17353   "RTN","VPR EF",245,0)
  17354    . S:X USE R("vistaKe ys",CNT,"r eviewDate" )=$$JSONDT ^VPRUTILS( X)
  17355   "RTN","VPR EF",246,0)
  17356    Q
  17357   "RTN","VPR EF",247,0)
  17358    ;
  17359   "RTN","VPR EF",248,0)
  17360   ODG ;
  17361   "RTN","VPR EF",249,0)
  17362    D ADDODG^ VPRCORD4
  17363   "RTN","VPR EF",250,0)
  17364    Q
  17365   "RTN","VPR EF",251,0)
  17366    ;
  17367   "RTN","VPR EF",252,0)
  17368   OI ;
  17369   "RTN","VPR EF",253,0)
  17370    ;I 1/0
  17371   "RTN","VPR EF",254,0)
  17372    D OI^VPRC ORD4("PS^R AP^LRT")
  17373   "RTN","VPR EF",255,0)
  17374    Q
  17375   "RTN","VPR EF",256,0)
  17376    ;
  17377   "RTN","VPR EF",257,0)
  17378   QO ;
  17379   "RTN","VPR EF",258,0)
  17380    D QO^VPRC ORD4
  17381   "RTN","VPR EF",259,0)
  17382    Q
  17383   "RTN","VPR EF",260,0)
  17384    ;
  17385   "RTN","VPR EF",261,0)
  17386   SCHEDULE ;
  17387   "RTN","VPR EF",262,0)
  17388    N RESULT
  17389   "RTN","VPR EF",263,0)
  17390    D ADDSCH^ VPRCORD4
  17391   "RTN","VPR EF",264,0)
  17392    ;D ADD("R ESULT")
  17393   "RTN","VPR EF",265,0)
  17394    Q
  17395   "RTN","VPR EF",266,0)
  17396    ;
  17397   "RTN","VPR EF",267,0)
  17398   ROUTE ;
  17399   "RTN","VPR EF",268,0)
  17400    N RESULT
  17401   "RTN","VPR EF",269,0)
  17402    D ADDROUT E^VPRCORD4
  17403   "RTN","VPR EF",270,0)
  17404    ;D ADD("R ESULT")
  17405   "RTN","VPR EF",271,0)
  17406    Q
  17407   "RTN","VPR EF",272,0)
  17408    ;
  17409   "RTN","VPR EF",273,0)
  17410   VPR ; -- R eturn VPR  Objects
  17411   "RTN","VPR EF",274,0)
  17412    N IEN
  17413   "RTN","VPR EF",275,0)
  17414    S VPRCNT= $$TOTAL("^ VPR(560.11 )")
  17415   "RTN","VPR EF",276,0)
  17416    I $L(VPRI D) D  Q
  17417   "RTN","VPR EF",277,0)
  17418    . I VPRID =+VPRID S  IEN=VPRID
  17419   "RTN","VPR EF",278,0)
  17420    . E  S IE N=+$O(^VPR (560.11,"B ",VPRID,0) )
  17421   "RTN","VPR EF",279,0)
  17422    . S ERRMS G=$$ERRMSG ("VPR Obje ct",IEN)
  17423   "RTN","VPR EF",280,0)
  17424    . D:IEN V PR1^VPRDJ0 2(560.11,I EN)
  17425   "RTN","VPR EF",281,0)
  17426    S IEN=+$G (VPRLAST)  F  S IEN=$ O(^VPR(560 .11,"C",TY PE,IEN)) Q :IEN<1  D   I VPRMAX> 0,VPRI'<VP RMAX Q
  17427   "RTN","VPR EF",282,0)
  17428    . S ERRMS G=$$ERRMSG ("VPR Obje ct",IEN)
  17429   "RTN","VPR EF",283,0)
  17430    . D VPR1^ VPRDJ02(56 0.11,IEN)  S VPRLAST= IEN
  17431   "RTN","VPR EF",284,0)
  17432    Q
  17433   "RTN","VPR EF",285,0)
  17434    ;
  17435   "RTN","VPR EF",286,0)
  17436   ROS ; -- R eturn rost ers
  17437   "RTN","VPR EF",287,0)
  17438    N PRV
  17439   "RTN","VPR EF",288,0)
  17440    S VPRCNT= $$TOTAL("^ VPROSTER")
  17441   "RTN","VPR EF",289,0)
  17442    I $L(VPRI D) D:$D(^V PROSTER(VP RID,0)) RO S1(VPRID)  Q
  17443   "RTN","VPR EF",290,0)
  17444    S PRV=+$G (VPRLAST)
  17445   "RTN","VPR EF",291,0)
  17446    I PRV=0 S  PRV=.9
  17447   "RTN","VPR EF",292,0)
  17448    F  S PRV= $O(^VPROST ER(PRV)) Q :PRV'>0  D  ROS1(PRV)  I VPRMAX, VPRI'<VPRM AX Q
  17449   "RTN","VPR EF",293,0)
  17450    Q
  17451   "RTN","VPR EF",294,0)
  17452    ;
  17453   "RTN","VPR EF",295,0)
  17454   ROS1(IEN)  ; -- get o ne roster
  17455   "RTN","VPR EF",296,0)
  17456    N ERRMSG
  17457   "RTN","VPR EF",297,0)
  17458    S ERRMSG= "A mumps e rror occur red while  extaractin g roster."
  17459   "RTN","VPR EF",298,0)
  17460    ;S ERRMSG =$$ERRMSG( "roster",I EN)
  17461   "RTN","VPR EF",299,0)
  17462    ;S $ET="D  ERRHDLR^V PRDERRH"
  17463   "RTN","VPR EF",300,0)
  17464    D GET^VPR ROS6(IEN)
  17465   "RTN","VPR EF",301,0)
  17466    N ROSTER, GBL,FLDS,R ESULT,VPRZ ,X,Y,VPRSE Q,VPRACT,V PRSOURCE,V PRV,NODE,V PRPAT,ID
  17467   "RTN","VPR EF",302,0)
  17468    K VPRV S  FLDS=".01: .06;1*;2;3 *;99",ID=I EN
  17469   "RTN","VPR EF",303,0)
  17470    D GETS^DI Q(561.2,IE N_",",FLDS ,"IEN","VP RV")
  17471   "RTN","VPR EF",304,0)
  17472    S Y=$NA(V PRV(561.2, IEN_","))
  17473   "RTN","VPR EF",305,0)
  17474    S ROSTER( "name")=$G (@Y@(.01," E"))
  17475   "RTN","VPR EF",306,0)
  17476    S ROSTER( "localId") =ID,ROSTER ("uid")=$$ SETUID^VPR UTILS("ros ter",,ID)
  17477   "RTN","VPR EF",307,0)
  17478    S X=$G(@Y @(99,"I"))  S:X ROSTE R("dateUpd ated")=$$J SONDT^VPRU TILS(X)
  17479   "RTN","VPR EF",308,0)
  17480    S X=$G(@Y @(.04,"I") ) S:X ROST ER("ownerL ocalId")=X ,ROSTER("o wnerUid")= $$SETUID^V PRUTILS("u ser",,X)
  17481   "RTN","VPR EF",309,0)
  17482    S X=$G(@Y @(.06,"E") ) S:X ROST ER("patien tListName" )=X
  17483   "RTN","VPR EF",310,0)
  17484    S X=$G(@Y @(.03,"I") ) S ROSTER ("disabled ")=$S(X=1: "true",1:" false")
  17485   "RTN","VPR EF",311,0)
  17486    S X=$G(@Y @(.05,"I") ) S ROSTER ("private" )=$S(X="PR ":"true",1 :"false")
  17487   "RTN","VPR EF",312,0)
  17488    S X=$G(@Y @(2,"E"))  S:X ROSTER ("specialH andling")= X
  17489   "RTN","VPR EF",313,0)
  17490    I $D(VPRV (561.21))  S NODE="", VPRZ=0 D
  17491   "RTN","VPR EF",314,0)
  17492    . F  S NO DE=$O(VPRV (561.21,NO DE)) Q:NOD E=""  D 
  17493   "RTN","VPR EF",315,0)
  17494    . . S VPR SEQ=VPRV(5 61.21,NODE ,.01,"I")  S ROSTER(" sources",V PRSEQ,"seq uence")=VP RSEQ
  17495   "RTN","VPR EF",316,0)
  17496    . . S VPR ACT=VPRV(5 61.21,NODE ,.03,"E")  S ROSTER(" sources",V PRSEQ,"act ion")=VPRA CT
  17497   "RTN","VPR EF",317,0)
  17498    . . S VPR SOURCE=VPR V(561.21,N ODE,.02,"I "),ROSTER( "sources", VPRSEQ,"so urce")=$$S OURCE(VPRS OURCE)
  17499   "RTN","VPR EF",318,0)
  17500    . . S ROS TER("sourc es",VPRSEQ ,"localId" )=+VPRSOUR CE
  17501   "RTN","VPR EF",319,0)
  17502    . . S GBL =U_$$CREF^ DILF($P(VP RSOURCE,"; ",2)) S RO STER("sour ces",VPRSE Q,"name")= $P($G(@GBL @(+VPRSOUR CE,0)),U)
  17503   "RTN","VPR EF",320,0)
  17504    I $D(VPRV (561.23))  S NODE="", VPRZ=0 D
  17505   "RTN","VPR EF",321,0)
  17506    . F  S NO DE=$O(VPRV (561.23,NO DE)) Q:NOD E=""  D
  17507   "RTN","VPR EF",322,0)
  17508    . . S VPR Z=VPRZ+1,V PRPAT=VPRV (561.23,NO DE,.01,"E" ),DFN=VPRV (561.23,NO DE,.01,"I" ),ICN=+$$G ETICN^MPIF 001(DFN)
  17509   "RTN","VPR EF",323,0)
  17510    . . S ROS TER("patie nts",VPRZ, "name")=VP RPAT,ROSTE R("patient s",VPRZ,"l ocalId")=D FN
  17511   "RTN","VPR EF",324,0)
  17512    . . S ROS TER("patie nts",VPRZ, "uid")=$$S ETUID^VPRU TILS("pati ent",DFN,D FN)
  17513   "RTN","VPR EF",325,0)
  17514    . . I $D( VPRV(561.2 3,NODE,.02 )) S ROSTE R("patient s",VPRZ,"s ourceSeque nce")=VPRV (561.23,NO DE,.02,"I" )
  17515   "RTN","VPR EF",326,0)
  17516    . . I ICN >0 S ROSTE R("patient s",VPRZ,"i cn")=ICN
  17517   "RTN","VPR EF",327,0)
  17518    D ADD("RO STER") S V PRLAST=ID
  17519   "RTN","VPR EF",328,0)
  17520    Q
  17521   "RTN","VPR EF",329,0)
  17522    ;
  17523   "RTN","VPR EF",330,0)
  17524   SOURCE(SRC ) ;
  17525   "RTN","VPR EF",331,0)
  17526    N X S X=" "
  17527   "RTN","VPR EF",332,0)
  17528    I SRC["SC ("         S X="clini c"
  17529   "RTN","VPR EF",333,0)
  17530    I SRC["DP T("        S X="patie nt"
  17531   "RTN","VPR EF",334,0)
  17532    I SRC["DI C(42"      S X="ward"
  17533   "RTN","VPR EF",335,0)
  17534    I SRC["SC TM"        S X="pcmm"
  17535   "RTN","VPR EF",336,0)
  17536    I SRC["OR (100.21"   S X="cprs"
  17537   "RTN","VPR EF",337,0)
  17538    I SRC["VP ROSTER"    S X="roste r"
  17539   "RTN","VPR EF",338,0)
  17540    I SRC["DI C(45.7"    S X="speci alty"
  17541   "RTN","VPR EF",339,0)
  17542    I SRC["VA (200"      S X="provi der"
  17543   "RTN","VPR EF",340,0)
  17544    I SRC["PX RM(810.4"  S X="pxrm"
  17545   "RTN","VPR EF",341,0)
  17546    Q X
  17547   "RTN","VPR EF",342,0)
  17548    ;
  17549   "RTN","VPR EF",343,0)
  17550   TESTROS ;  TEMPORARY  FOR TESTIN G
  17551   "RTN","VPR EF",344,0)
  17552    S FILT("d omain")="r oster"
  17553   "RTN","VPR EF",345,0)
  17554    S FILT("i d")=277
  17555   "RTN","VPR EF",346,0)
  17556    D GET^VPR EF(.ZZ,.FI LT)
  17557   "RTN","VPR EF",347,0)
  17558    Q
  17559   "RTN","VPR EF",348,0)
  17560    ;
  17561   "RTN","VPR EF",349,0)
  17562   ASU ; -- A SU files
  17563   "RTN","VPR EF",350,0)
  17564    N X,RTN S  X=$P($G(T YPE),"-",2 )
  17565   "RTN","VPR EF",351,0)
  17566    S RTN=$$U P^XLFSTR(X )_"^VPREAS U"
  17567   "RTN","VPR EF",352,0)
  17568    I X'="",$ L($T(@RTN) ) D @RTN
  17569   "RTN","VPR EF",353,0)
  17570    Q
  17571   "RTN","VPR EF",354,0)
  17572    ;
  17573   "RTN","VPR EF",355,0)
  17574   MDTERMS ;  -- CP Term inology
  17575   "RTN","VPR EF",356,0)
  17576    D:$L($T(T ERM^VPRMDU TL)) TERM^ VPRMDUTL
  17577   "RTN","VPR EF",357,0)
  17578    Q
  17579   "RTN","VPR EF",358,0)
  17580   LABGRP ;
  17581   "RTN","VPR EF",359,0)
  17582    D SHWCUMR 2^VPRELAB
  17583   "RTN","VPR EF",360,0)
  17584    Q
  17585   "RTN","VPR EF",361,0)
  17586   LABPNL ;
  17587   "RTN","VPR EF",362,0)
  17588    D SHWORPN L^VPRELAB
  17589   "RTN","VPR EF",363,0)
  17590    Q
  17591   "RTN","VPR EF",364,0)
  17592    ;
  17593   "RTN","VPR EF",365,0)
  17594   ISPROXY(IE N) ;
  17595   "RTN","VPR EF",366,0)
  17596    N APP
  17597   "RTN","VPR EF",367,0)
  17598    S APP=$O( ^VA(201,"B ","APPLICA TION PROXY ","")) I A PP'>0 Q 0
  17599   "RTN","VPR EF",368,0)
  17600    I $D(^VA( 200,IEN,"U SC3","B",A PP)) Q 1
  17601   "RTN","VPR EF",369,0)
  17602    Q 0
  17603   "RTN","VPR EFSG")
  17604   0^89^B7186 739
  17605   "RTN","VPR EFSG",1,0)
  17606   VPREFSG ;S LC/KCM --  GET for Ex tract and  Freshness  Stream
  17607   "RTN","VPR EFSG",2,0)
  17608    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  17609   "RTN","VPR EFSG",3,0)
  17610    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  17611   "RTN","VPR EFSG",4,0)
  17612    ;
  17613   "RTN","VPR EFSG",5,0)
  17614    ;
  17615   "RTN","VPR EFSG",6,0)
  17616   DOMITMS ;  loop thru  extract it ems, OFFSE T is last  sent
  17617   "RTN","VPR EFSG",7,0)
  17618    ; expects  VPRFSTRM, VPRFIDX,VP RFHMP
  17619   "RTN","VPR EFSG",8,0)
  17620    ; changes  VPRFSEQ,V PRFCNT as  each item  added
  17621   "RTN","VPR EFSG",9,0)
  17622    N X,OFFSE T,DOMAIN,T ASK,BATCH, TOTAL
  17623   "RTN","VPR EFSG",10,0 )
  17624    S X=^XTMP (VPRFSTRM, VPRFIDX)
  17625   "RTN","VPR EFSG",11,0 )
  17626    S X=$P(X, U,3),DOMAI N=$P(X,":" ),TASK=$P( X,":",2),T OTAL=$P(X, ":",4)
  17627   "RTN","VPR EFSG",12,0 )
  17628    S BATCH=" VPRFX~"_VP RFHMP_"~OP D"       ;  extract n ode in ^XT MP
  17629   "RTN","VPR EFSG",13,0 )
  17630    S OFFSET= TOTAL-(VPR FIDX-VPRFS EQ)
  17631   "RTN","VPR EFSG",14,0 )
  17632    F  S OFFS ET=$O(^XTM P(BATCH,TA SK,DOMAIN, OFFSET)) Q :'OFFSET   D  Q:VPRFC NT'<VPRFLI M
  17633   "RTN","VPR EFSG",15,0 )
  17634    . S VPRFC NT=VPRFCNT +1 ; incre ment the c ount of re turned ite ms
  17635   "RTN","VPR EFSG",16,0 )
  17636    . S VPRFS EQ=VPRFSEQ +1 ; incre ment the s equence nu mber in th e stream
  17637   "RTN","VPR EFSG",17,0 )
  17638    . M ^TMP( "VPRF",$J, VPRFCNT)=^ XTMP(BATCH ,TASK,DOMA IN,OFFSET)
  17639   "RTN","VPR EFSG",18,0 )
  17640    . I DOMAI N="patient " I $$PATI ENT(VPRFCN T,DOMAIN,$ G(TOTAL),O FFSET)=1 Q
  17641   "RTN","VPR EFSG",19,0 )
  17642    . S ^TMP( "VPRF",$J, VPRFCNT,.3 )=$$WRAPPE R(DOMAIN,$ S('TOTAL:0 ,1:OFFSET) ,+TOTAL)
  17643   "RTN","VPR EFSG",20,0 )
  17644    Q
  17645   "RTN","VPR EFSG",21,0 )
  17646    ;
  17647   "RTN","VPR EFSG",22,0 )
  17648   SYNCSTRT(S EQNODE) ;  Build sync Start obje ct with de mograhics
  17649   "RTN","VPR EFSG",23,0 )
  17650    S VPRFCNT =VPRFCNT+1
  17651   "RTN","VPR EFSG",24,0 )
  17652    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER( "syncStart ",1,0)
  17653   "RTN","VPR EFSG",25,0 )
  17654    Q
  17655   "RTN","VPR EFSG",26,0 )
  17656   SYNCDONE(S EQNODE) ;  Build sync Status obj ect and st ick in ^TM P
  17657   "RTN","VPR EFSG",27,0 )
  17658    ;  expect s: VPRFSYS ,VPRFCNT
  17659   "RTN","VPR EFSG",28,0 )
  17660    N VPRBATC H,DFN,VPRB ATCH,STS,S TSJSON,X,E RR
  17661   "RTN","VPR EFSG",29,0 )
  17662    S VPRBATC H=$P(SEQNO DE,U,3) ;  VPRFX~hmpS rvId~dfn
  17663   "RTN","VPR EFSG",30,0 )
  17664    S STS("ui d")="urn:v a:syncStat us:"_VPRFS YS_":OPD"
  17665   "RTN","VPR EFSG",31,0 )
  17666    S STS("in itialized" )="true"
  17667   "RTN","VPR EFSG",32,0 )
  17668    S X="" F   S X=$O(^X TMP(VPRBAT CH,0,"coun t",X)) Q:' $L(X)  D
  17669   "RTN","VPR EFSG",33,0 )
  17670    . S STS(" domainTota ls",X)=^XT MP(VPRBATC H,0,"count ",X)
  17671   "RTN","VPR EFSG",34,0 )
  17672    D ENCODE^ VPRJSON("S TS","STSJS ON","ERR")
  17673   "RTN","VPR EFSG",35,0 )
  17674    I $D(ERR)  S $EC=",U JSON encod e error,"  Q
  17675   "RTN","VPR EFSG",36,0 )
  17676    S VPRFCNT =VPRFCNT+1
  17677   "RTN","VPR EFSG",37,0 )
  17678    M ^TMP("V PRF",$J,VP RFCNT)=STS JSON
  17679   "RTN","VPR EFSG",38,0 )
  17680    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER( "syncStatu s","",-1)
  17681   "RTN","VPR EFSG",39,0 )
  17682    Q
  17683   "RTN","VPR EFSG",40,0 )
  17684    ;
  17685   "RTN","VPR EFSG",41,0 )
  17686   WRAPPER(DO MAIN,OFFSE T,TOTAL) ;  return JS ON wrapper  for each  item
  17687   "RTN","VPR EFSG",42,0 )
  17688    ; add obj ect tag if  extract t otal not z ero or if  total pass ed as -1
  17689   "RTN","VPR EFSG",43,0 )
  17690    ; seq and  total tag s only add ed if non- zero
  17691   "RTN","VPR EFSG",44,0 )
  17692    N X
  17693   "RTN","VPR EFSG",45,0 )
  17694    S X="},{" "collectio n"":"""_DO MAIN_""""
  17695   "RTN","VPR EFSG",46,0 )
  17696    I $G(OFFS ET)>0 S X= X_",""seq" ":"_OFFSET
  17697   "RTN","VPR EFSG",47,0 )
  17698    I $G(TOTA L)>0 S X=X _",""total "":"_TOTAL
  17699   "RTN","VPR EFSG",48,0 )
  17700    I $G(TOTA L) S X=X_" ,""object" ":"
  17701   "RTN","VPR EFSG",49,0 )
  17702    Q X
  17703   "RTN","VPR EFSG",50,0 )
  17704    ;
  17705   "RTN","VPR EFSG",51,0 )
  17706   PATIENT(VP RFCNT,DOMA IN,TOTAL,O FFSET) ;
  17707   "RTN","VPR EFSG",52,0 )
  17708    N DFN,PID S,TEMP,ERR OR,PTJSON
  17709   "RTN","VPR EFSG",53,0 )
  17710    M PTJSON= ^TMP("VPRF ",$J,VPRFC NT)
  17711   "RTN","VPR EFSG",54,0 )
  17712    K PTJSON( .3)
  17713   "RTN","VPR EFSG",55,0 )
  17714    D DECODE^ VPRJSON("P TJSON","TE MP","ERROR ")
  17715   "RTN","VPR EFSG",56,0 )
  17716    ;D DECODE ^VPRJSON($ NA(^TMP("V PRF",$J,VP RFCNT,1)), "TEMP","ER ROR")
  17717   "RTN","VPR EFSG",57,0 )
  17718    I '$D(TEM P) Q 0
  17719   "RTN","VPR EFSG",58,0 )
  17720    S DFN=TEM P("localId ") I DFN'> 0 Q 0
  17721   "RTN","VPR EFSG",59,0 )
  17722    S PIDS=$$ PIDS^VPRDJ FS(DFN)
  17723   "RTN","VPR EFSG",60,0 )
  17724    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER^ VPRDJFSG(D OMAIN,PIDS ,$S('TOTAL :0,1:OFFSE T),+TOTAL)
  17725   "RTN","VPR EFSG",61,0 )
  17726    Q 1
  17727   "RTN","VPR EFSG",62,0 )
  17728    ;
  17729   "RTN","VPR EFSP")
  17730   0^90^B4485 8817
  17731   "RTN","VPR EFSP",1,0)
  17732   VPREFSP ;S LC/KCM --  PUT/POST f or Extract  and Fresh ness Strea m
  17733   "RTN","VPR EFSP",2,0)
  17734    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  17735   "RTN","VPR EFSP",3,0)
  17736    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  17737   "RTN","VPR EFSP",4,0)
  17738    ;
  17739   "RTN","VPR EFSP",5,0)
  17740    ;
  17741   "RTN","VPR EFSP",6,0)
  17742    ; --- cre ate a new  patient su bscription
  17743   "RTN","VPR EFSP",7,0)
  17744    ;
  17745   "RTN","VPR EFSP",8,0)
  17746   PUTSUB(ARG S,BODY) ;  return loc ation afte r creating  a new sub scription
  17747   "RTN","VPR EFSP",9,0)
  17748    ; PUT to:  /vpr/subs cription
  17749   "RTN","VPR EFSP",10,0 )
  17750    ;   JSON:  {server:h mpXYZ,loca lId:229,ic n:10232432 4,domains: [lab,med,. ..]}
  17751   "RTN","VPR EFSP",11,0 )
  17752    ;VPRFRSP:  location: /vpr/subsc ription/{h mpSrvId}/p atient/{df n}
  17753   "RTN","VPR EFSP",12,0 )
  17754    ;
  17755   "RTN","VPR EFSP",13,0 )
  17756    N CNT,DOM AIN,ICN,OB J,ERR,HMPS RV,VPRFDFN ,VPRFDOM,V PRBATCH,VP RFERR,NEWS UB
  17757   "RTN","VPR EFSP",14,0 )
  17758    D DECODE^ VPRJSON("B ODY","OBJ" ,"ERR")
  17759   "RTN","VPR EFSP",15,0 )
  17760    I $D(ERR)  D SETERR^ VPRDJFS("U nable to d ecode JSON ") Q ""
  17761   "RTN","VPR EFSP",16,0 )
  17762    S HMPSRV= $TR($G(OBJ ("server") ),"~","=")
  17763   "RTN","VPR EFSP",17,0 )
  17764    I '$L(HMP SRV) D SET ERR^VPRDJF S("Missing  HMP Serve r ID") Q " "
  17765   "RTN","VPR EFSP",18,0 )
  17766    M VPRFDOM =OBJ("doma ins") I $D (VPRFDOM)< 10 D DOMAI NS(.VPRFDO M)
  17767   "RTN","VPR EFSP",19,0 )
  17768    S VPRBATC H="VPRFX~" _HMPSRV_"~ OPD"
  17769   "RTN","VPR EFSP",20,0 )
  17770    ;;AGP che ck for dom ains alrea dy in proc ess, remov e domains  that alrea dy in proc ess.
  17771   "RTN","VPR EFSP",21,0 )
  17772    I $D(^XTM P(VPRBATCH ,0,"status ")) D
  17773   "RTN","VPR EFSP",22,0 )
  17774    .S CNT=0  F  S CNT=$ O(VPRFDOM( CNT)) Q:CN T'>0  D
  17775   "RTN","VPR EFSP",23,0 )
  17776    ..S DOMAI N=$G(VPRFD OM(CNT)) I  DOMAIN=""  Q
  17777   "RTN","VPR EFSP",24,0 )
  17778    ..I $G(^X TMP(VPRBAT CH,0,"stat us",DOMAIN ))=0 K VPR FDOM(CNT)
  17779   "RTN","VPR EFSP",25,0 )
  17780    ;
  17781   "RTN","VPR EFSP",26,0 )
  17782    I '$$TM^% ZTLOAD D S ETERR^VPRD JFS("Taskm an not run ning") Q " "
  17783   "RTN","VPR EFSP",27,0 )
  17784    I '$D(^XT MP("VPRFP" ,0)) D NEW XTMP^VPRDJ FS("VPRFP" ,9999,"VPR  Subscript ions")
  17785   "RTN","VPR EFSP",28,0 )
  17786    ;
  17787   "RTN","VPR EFSP",29,0 )
  17788    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=0 -- un subscribed
  17789   "RTN","VPR EFSP",30,0 )
  17790    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=1 -- su bscribed
  17791   "RTN","VPR EFSP",31,0 )
  17792    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=2 -- in itialized  (extracts  complete)
  17793   "RTN","VPR EFSP",32,0 )
  17794    ; locks e nsure only  one proce ss queues  the extrac ts
  17795   "RTN","VPR EFSP",33,0 )
  17796    S NEWSUB= 0
  17797   "RTN","VPR EFSP",34,0 )
  17798    ;
  17799   "RTN","VPR EFSP",35,0 )
  17800    L +^XTMP( "VPRFP","O PD",HMPSRV ):5 E  D S ETERR^VPRD JFS("Unabl e to lock  operationa l data for  "_DOMAIN)  Q
  17801   "RTN","VPR EFSP",36,0 )
  17802    ;I $G(^XT MP("VPRFP" ,DOMAIN,HM PSRV))'=1  S ^XTMP("V PRFP","OPD ",HMPSRV)= 1,NEWSUB=1
  17803   "RTN","VPR EFSP",37,0 )
  17804    S ^XTMP(" VPRFP","OP D",HMPSRV) =1,NEWSUB= 1
  17805   "RTN","VPR EFSP",38,0 )
  17806    L -^XTMP( "VPRFP","O PD",HMPSRV )
  17807   "RTN","VPR EFSP",39,0 )
  17808    I NEWSUB  D QUINIT(V PRBATCH,.V PRFDOM) Q: $G(VPRFERR ) ""
  17809   "RTN","VPR EFSP",40,0 )
  17810    Q "/vpr/s ubscriptio n/"_HMPSRV _"/operati onalData"
  17811   "RTN","VPR EFSP",41,0 )
  17812    ;
  17813   "RTN","VPR EFSP",42,0 )
  17814   QUINIT(VPR BATCH,VPRF DOM) ; Que ue the ini tial extra cts for a  patient
  17815   "RTN","VPR EFSP",43,0 )
  17816    ; VPRBATC H="VPRFP~h mpsrvid~OP D"  exampl e: VPRFX~h mpXYZ~229
  17817   "RTN","VPR EFSP",44,0 )
  17818    ; VPRFDOM (n)="domai nName"
  17819   "RTN","VPR EFSP",45,0 )
  17820    ; 
  17821   "RTN","VPR EFSP",46,0 )
  17822    ; ^XTMP(" VPRFX~hmps rvid~OPD", 0)=expires ^created^V PR Operati onal Data  Extract
  17823   "RTN","VPR EFSP",47,0 )
  17824    ;                             , 0,"status" ,domain)=e xtract sta tus
  17825   "RTN","VPR EFSP",48,0 )
  17826    ;                             , 0,"task",t askIen)=""
  17827   "RTN","VPR EFSP",49,0 )
  17828    ;                             , taskIen,do main,... ( extract da ta)
  17829   "RTN","VPR EFSP",50,0 )
  17830    ;
  17831   "RTN","VPR EFSP",51,0 )
  17832    D NEWXTMP ^VPRDJFS(V PRBATCH,1, "VPR Opera tional Dat a Extract" )
  17833   "RTN","VPR EFSP",52,0 )
  17834    S ^XTMP(V PRBATCH,0, "time")=$H
  17835   "RTN","VPR EFSP",53,0 )
  17836    N I S I=0  F  S I=$O (VPRFDOM(I )) Q:'I  D  SETDOM("s tatus",VPR FDOM(I),0)
  17837   "RTN","VPR EFSP",54,0 )
  17838    D SETMARK ("Start",V PRBATCH) ;  sends ful l demograp hics
  17839   "RTN","VPR EFSP",55,0 )
  17840    ;
  17841   "RTN","VPR EFSP",56,0 )
  17842    N ZTRTN,Z TDESC,ZTDT H,ZTIO,ZTU CI,ZTCPU,Z TPRI,ZTSAV E,ZTKIL,ZT SYNC,ZTSK
  17843   "RTN","VPR EFSP",57,0 )
  17844    S ZTRTN=" DQINIT^VPR EFSP",ZTIO ="",ZTDTH= $H
  17845   "RTN","VPR EFSP",58,0 )
  17846    S ZTSAVE( "VPRBATCH" )="",ZTSAV E("VPRFDOM (")=""
  17847   "RTN","VPR EFSP",59,0 )
  17848    S ZTDESC= "Build VPR  operation al data do mains"
  17849   "RTN","VPR EFSP",60,0 )
  17850    D ^%ZTLOA D
  17851   "RTN","VPR EFSP",61,0 )
  17852    ;D DQINIT
  17853   "RTN","VPR EFSP",62,0 )
  17854    ;
  17855   "RTN","VPR EFSP",63,0 )
  17856    I $G(ZTSK ) D
  17857   "RTN","VPR EFSP",64,0 )
  17858    .W !,"tas k: "_ZTSK
  17859   "RTN","VPR EFSP",65,0 )
  17860    .S ^XTMP( VPRBATCH,0 ,"task",ZT SK)="" I 1
  17861   "RTN","VPR EFSP",66,0 )
  17862    E  D SETE RR^VPRDJFS ("Task not  created")
  17863   "RTN","VPR EFSP",67,0 )
  17864    Q
  17865   "RTN","VPR EFSP",68,0 )
  17866   SETDOM(ATT RIB,DOMAIN ,VALUE) ;  Set value  for a doma in
  17867   "RTN","VPR EFSP",69,0 )
  17868    ; expects : VPRBATCH
  17869   "RTN","VPR EFSP",70,0 )
  17870    ; ATTRIB:  "status"  or "count"  attribute
  17871   "RTN","VPR EFSP",71,0 )
  17872    ; DOMAIN:  name of d omain
  17873   "RTN","VPR EFSP",72,0 )
  17874    ; if stat us, VALUE:  0=waiting , 1=ready
  17875   "RTN","VPR EFSP",73,0 )
  17876    ; if coun t,  VALUE:  count of  items
  17877   "RTN","VPR EFSP",74,0 )
  17878    S ^XTMP(V PRBATCH,0, ATTRIB,DOM AIN)=VALUE
  17879   "RTN","VPR EFSP",75,0 )
  17880    Q
  17881   "RTN","VPR EFSP",76,0 )
  17882   DQINIT ; D equeue ini tial extra cts
  17883   "RTN","VPR EFSP",77,0 )
  17884    ; expects :  VPRBATC H, VPRFDFN , VPRFDOM,  ZTSK
  17885   "RTN","VPR EFSP",78,0 )
  17886    I '$D(^XT MP(VPRBATC H,0,"task" ,ZTSK)) Q   ; extract  was super ceded
  17887   "RTN","VPR EFSP",79,0 )
  17888    N VPRFDOM I,VPRFSYS, VPRFZTSK
  17889   "RTN","VPR EFSP",80,0 )
  17890    S VPRFSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  17891   "RTN","VPR EFSP",81,0 )
  17892    S VPRFZTS K=ZTSK ; j ust in cas e the unex pected hap pens to ZT SK
  17893   "RTN","VPR EFSP",82,0 )
  17894    S VPRFDOM I="" F  S  VPRFDOMI=$ O(VPRFDOM( VPRFDOMI))  Q:'VPRFDO MI  D
  17895   "RTN","VPR EFSP",83,0 )
  17896    . N FILTE R,RSLT
  17897   "RTN","VPR EFSP",84,0 )
  17898    . S FILTE R("domain" )=VPRFDOM( VPRFDOMI)
  17899   "RTN","VPR EFSP",85,0 )
  17900    . D GET^V PREF(.RSLT ,.FILTER)
  17901   "RTN","VPR EFSP",86,0 )
  17902    . D MOD4S TRM(VPRFDO M(VPRFDOMI ))
  17903   "RTN","VPR EFSP",87,0 )
  17904    . ; if su perceded,  stop proce ssing doma ins
  17905   "RTN","VPR EFSP",88,0 )
  17906    . I '$D(^ XTMP(VPRBA TCH,0,"tas k",VPRFZTS K)) S VPRF DOMI=999 Q
  17907   "RTN","VPR EFSP",89,0 )
  17908    . D SETDO M("status" ,VPRFDOM(V PRFDOMI),1 ) ; ready
  17909   "RTN","VPR EFSP",90,0 )
  17910    ; if supe rceded, re move extra cts produc ed by this  task
  17911   "RTN","VPR EFSP",91,0 )
  17912    I '$D(^XT MP(VPRBATC H,0,"task" ,VPRFZTSK) ) K ^XTMP( VPRBATCH,V PRFZTSK) Q
  17913   "RTN","VPR EFSP",92,0 )
  17914    ; don't a ssume init ialized, s ince we ma y split do mains to o ther tasks
  17915   "RTN","VPR EFSP",93,0 )
  17916    I $$INITD ONE(VPRBAT CH) D              ;  if all dom ains extra cted
  17917   "RTN","VPR EFSP",94,0 )
  17918    . D SETMA RK("Done", VPRBATCH)  ; - add up dated sync Status
  17919   "RTN","VPR EFSP",95,0 )
  17920    . D MVFRU PD(VPRBATC H)         ; - move f reshness u pdates ove r
  17921   "RTN","VPR EFSP",96,0 )
  17922    Q
  17923   "RTN","VPR EFSP",97,0 )
  17924   SETMARK(TY PE,VPRBATC H) ; Post  markers fo r begin an d end of i nitial syn ch
  17925   "RTN","VPR EFSP",98,0 )
  17926    N HPMSRV, NODES,X
  17927   "RTN","VPR EFSP",99,0 )
  17928    S HMPSRV= $P(VPRBATC H,"~",2)
  17929   "RTN","VPR EFSP",100, 0)
  17930    D POST^VP RDJFS("OPD ","sync"_T YPE,VPRBAT CH,"",HMPS RV,.NODES)
  17931   "RTN","VPR EFSP",101, 0)
  17932    Q:TYPE="S tart"
  17933   "RTN","VPR EFSP",102, 0)
  17934    S X="" F   S X=$O(NO DES(X)) Q: X=""  D  ;  iterate h mp servers
  17935   "RTN","VPR EFSP",103, 0)
  17936    . S ^XTMP ("VPRFP"," tidy",X,$P (NODES(X), U),$P(NODE S(X),U,2)) =VPRBATCH
  17937   "RTN","VPR EFSP",104, 0)
  17938    Q
  17939   "RTN","VPR EFSP",105, 0)
  17940   MVFRUPD(VP RBATCH) ;  Move fresh ness updat es over ac tive strea m
  17941   "RTN","VPR EFSP",106, 0)
  17942    N I,X,FRO M,HMPSRV,T YPE,ID,ACT
  17943   "RTN","VPR EFSP",107, 0)
  17944    S HMPSRV= $P(VPRBATC H,"~",2)
  17945   "RTN","VPR EFSP",108, 0)
  17946    S ^XTMP(" VPRFP","OP D",HMPSRV) =2       ;  now initi alized
  17947   "RTN","VPR EFSP",109, 0)
  17948    S FROM="V PRFH~"_HMP SRV_"~OPD"
  17949   "RTN","VPR EFSP",110, 0)
  17950    S I=0 F   S I=$O(^XT MP(FROM,I) ) Q:'I  D   ; move ov er held up dates
  17951   "RTN","VPR EFSP",111, 0)
  17952    . S X=^XT MP(FROM,I)
  17953   "RTN","VPR EFSP",112, 0)
  17954    . S TYPE= $P(X,U,2), ID=$P(X,U, 3),ACT=$P( X,U,4)
  17955   "RTN","VPR EFSP",113, 0)
  17956    . D POST^ VPRDJFS("O PD",TYPE,I D,ACT,HMPS RV)
  17957   "RTN","VPR EFSP",114, 0)
  17958    K ^XTMP(F ROM)
  17959   "RTN","VPR EFSP",115, 0)
  17960    Q
  17961   "RTN","VPR EFSP",116, 0)
  17962   MOD4STRM(D OMAIN) ; m odify extr act to be  ready for  stream
  17963   "RTN","VPR EFSP",117, 0)
  17964    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  17965   "RTN","VPR EFSP",118, 0)
  17966    ; results  are in ^X TMP("VPRFX ~hmpsrv~df n",DFN,DOM AIN,...)
  17967   "RTN","VPR EFSP",119, 0)
  17968    ; syncErr or: {uid,c ollection, error}  ui d=urn:va:s yncError:s ysId:dfn:e xtract
  17969   "RTN","VPR EFSP",120, 0)
  17970    N DFN,HMP SRV,COUNT, LNODE
  17971   "RTN","VPR EFSP",121, 0)
  17972    S HMPSRV= $P(VPRBATC H,"~",2)
  17973   "RTN","VPR EFSP",122, 0)
  17974    ; no item s -- COUNT  is in 1 n ode, other wise COUNT  is in the  .5 node
  17975   "RTN","VPR EFSP",123, 0)
  17976    S COUNT=0
  17977   "RTN","VPR EFSP",124, 0)
  17978    I $D(^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,.5) ) S COUNT= +$P(^(.5), """totalIt ems"":",2)
  17979   "RTN","VPR EFSP",125, 0)
  17980    ; remove  headers (. 5,.6) and  closing br aces (at C OUNT+1)
  17981   "RTN","VPR EFSP",126, 0)
  17982    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,.5)
  17983   "RTN","VPR EFSP",127, 0)
  17984    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,.6)
  17985   "RTN","VPR EFSP",128, 0)
  17986    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,COUNT+ 1)
  17987   "RTN","VPR EFSP",129, 0)
  17988    S LNODE=$ O(^XTMP(VP RBATCH,VPR FZTSK,DOMA IN,""),-1)
  17989   "RTN","VPR EFSP",130, 0)
  17990    I LNODE>0 ,$G(^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,LNODE ))="]}}" K  ^XTMP(VPR BATCH,VPRF ZTSK,DOMAI N,LNODE)
  17991   "RTN","VPR EFSP",131, 0)
  17992    ; if no i tems -- re turn empty  object to  be wrappe d
  17993   "RTN","VPR EFSP",132, 0)
  17994    I COUNT=0  S ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,1,1)=" "
  17995   "RTN","VPR EFSP",133, 0)
  17996    ; if erro r, add syn cError obj ect (from  COUNT+2)
  17997   "RTN","VPR EFSP",134, 0)
  17998    I $D(^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,COU NT+2)) D
  17999   "RTN","VPR EFSP",135, 0)
  18000    . N JSON
  18001   "RTN","VPR EFSP",136, 0)
  18002    . D BLDSE RR(COUNT+2 ,DOMAIN,.J SON) Q:'$D (JSON)
  18003   "RTN","VPR EFSP",137, 0)
  18004    . S COUNT =COUNT+1
  18005   "RTN","VPR EFSP",138, 0)
  18006    . M ^XTMP (VPRBATCH, VPRFZTSK,D OMAIN,COUN T)=JSON
  18007   "RTN","VPR EFSP",139, 0)
  18008    ; set .7  node to to tal count  (including  error)
  18009   "RTN","VPR EFSP",140, 0)
  18010    ;S ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,.7)=C OUNT
  18011   "RTN","VPR EFSP",141, 0)
  18012    D SETDOM( "count",DO MAIN,COUNT )
  18013   "RTN","VPR EFSP",142, 0)
  18014    ; if coun t 0 -- sti ll return  wrapper ob ject so we  know the  domain had  nothing
  18015   "RTN","VPR EFSP",143, 0)
  18016    D POST^VP RDJFS("OPD ","syncDom ain",DOMAI N_":"_VPRF ZTSK_":"_( $S(COUNT=0 :1,1:COUNT ))_":"_COU NT,"",HMPS RV)
  18017   "RTN","VPR EFSP",144, 0)
  18018    Q
  18019   "RTN","VPR EFSP",145, 0)
  18020   BLDSERR(NO DE,DOMAIN, ERRJSON) ;  Create sy ncError ob ject in ER RJSON
  18021   "RTN","VPR EFSP",146, 0)
  18022    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  18023   "RTN","VPR EFSP",147, 0)
  18024    N ERRJSON ,ERROBJ,ER R,ERRMSG,S YNCERR
  18025   "RTN","VPR EFSP",148, 0)
  18026    S ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,NODE,. 3)="{"  ;  replace ,  with { for  decoding  JSON
  18027   "RTN","VPR EFSP",149, 0)
  18028    M ERRJSON =^XTMP(VPR BATCH,VPRF ZTSK,DOMAI N,NODE)
  18029   "RTN","VPR EFSP",150, 0)
  18030    D DECODE^ VPRJSON("E RRJSON","E RROBJ","ER R") I $D(E RR) S $EC= ",UJSON de code error ,"
  18031   "RTN","VPR EFSP",151, 0)
  18032    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,NODE)
  18033   "RTN","VPR EFSP",152, 0)
  18034    S ERRMSG= ERROBJ("er ror","mess age")
  18035   "RTN","VPR EFSP",153, 0)
  18036    Q:'$L(ERR MSG)
  18037   "RTN","VPR EFSP",154, 0)
  18038    S SYNCERR ("uid")="u rn:va:sync Error:"_VP RFSYS_":"_ DOMAIN
  18039   "RTN","VPR EFSP",155, 0)
  18040    S SYNCERR ("collecti on")=DOMAI N
  18041   "RTN","VPR EFSP",156, 0)
  18042    S SYNCERR ("error")= ERRMSG
  18043   "RTN","VPR EFSP",157, 0)
  18044    D ENCODE^ VPRJSON("S YNCERR","E RRJSON","E RR") I $D( ERR) S $EC =",UJSON e ncode erro r,"
  18045   "RTN","VPR EFSP",158, 0)
  18046    Q
  18047   "RTN","VPR EFSP",159, 0)
  18048   INITDONE(V PRBATCH) ;  Return 1  if all dom ains are d one
  18049   "RTN","VPR EFSP",160, 0)
  18050    N X,DONE
  18051   "RTN","VPR EFSP",161, 0)
  18052    S X="",DO NE=1
  18053   "RTN","VPR EFSP",162, 0)
  18054    F  S X=$O (^XTMP(VPR BATCH,0,"s tatus",X))  Q:'$L(X)   I '^(X) S  DONE=0
  18055   "RTN","VPR EFSP",163, 0)
  18056    Q DONE
  18057   "RTN","VPR EFSP",164, 0)
  18058    ;
  18059   "RTN","VPR EFSP",165, 0)
  18060   DOMAINS(LI ST) ; load  default d omains (pu t in param eter?)
  18061   "RTN","VPR EFSP",166, 0)
  18062    ;;asu-cla ss
  18063   "RTN","VPR EFSP",167, 0)
  18064    ;;asu-rul e
  18065   "RTN","VPR EFSP",168, 0)
  18066    ;;categor y
  18067   "RTN","VPR EFSP",169, 0)
  18068    ;;chartta b
  18069   "RTN","VPR EFSP",170, 0)
  18070    ;;display group
  18071   "RTN","VPR EFSP",171, 0)
  18072    ;;doc-def
  18073   "RTN","VPR EFSP",172, 0)
  18074    ;;labgrou p
  18075   "RTN","VPR EFSP",173, 0)
  18076    ;;labpane l
  18077   "RTN","VPR EFSP",174, 0)
  18078    ;;locatio n
  18079   "RTN","VPR EFSP",175, 0)
  18080    ;;orderab le
  18081   "RTN","VPR EFSP",176, 0)
  18082    ;;page
  18083   "RTN","VPR EFSP",177, 0)
  18084    ;;patient
  18085   "RTN","VPR EFSP",178, 0)
  18086    ;;personp hoto
  18087   "RTN","VPR EFSP",179, 0)
  18088    ;;pointof care
  18089   "RTN","VPR EFSP",180, 0)
  18090    ;;quick
  18091   "RTN","VPR EFSP",181, 0)
  18092    ;;roster
  18093   "RTN","VPR EFSP",182, 0)
  18094    ;;route
  18095   "RTN","VPR EFSP",183, 0)
  18096    ;;schedul e
  18097   "RTN","VPR EFSP",184, 0)
  18098    ;;team
  18099   "RTN","VPR EFSP",185, 0)
  18100    ;;teampos ition
  18101   "RTN","VPR EFSP",186, 0)
  18102    ;;user
  18103   "RTN","VPR EFSP",187, 0)
  18104    ;;usertab prefs
  18105   "RTN","VPR EFSP",188, 0)
  18106    ;;viewdef def
  18107   "RTN","VPR EFSP",189, 0)
  18108    ;;viewdef defcoldefc onfigtempl ate
  18109   "RTN","VPR EFSP",190, 0)
  18110    ;;zzzzz
  18111   "RTN","VPR EFSP",191, 0)
  18112    ;;clioter minology
  18113   "RTN","VPR EFSP",192, 0)
  18114    ;;doc-act ion
  18115   "RTN","VPR EFSP",193, 0)
  18116    ;;doc-sta tus
  18117   "RTN","VPR EFSP",194, 0)
  18118    N I,X
  18119   "RTN","VPR EFSP",195, 0)
  18120    F I=1:1 S  X=$P($T(D OMAINS+I), ";;",2,99)  Q:X="zzzz z"  S LIST (I)=X
  18121   "RTN","VPR EFSP",196, 0)
  18122    Q
  18123   "RTN","VPR EFSP",197, 0)
  18124    ;
  18125   "RTN","VPR EFST")
  18126   0^91^B5375 002
  18127   "RTN","VPR EFST",1,0)
  18128   VPREFST ;S LC/KCM --  Tests for  extract an d freshnes s stream
  18129   "RTN","VPR EFST",2,0)
  18130    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  18131   "RTN","VPR EFST",3,0)
  18132    ;
  18133   "RTN","VPR EFST",4,0)
  18134   TEST ; Tes t synchron ization pr ocess
  18135   "RTN","VPR EFST",5,0)
  18136    N LASTUPD ,TOTPTS,DO NE,START,G TOTAL
  18137   "RTN","VPR EFST",6,0)
  18138    S LASTUPD =0,TOTPTS= 0,DONE=0,G TOTAL=0
  18139   "RTN","VPR EFST",7,0)
  18140    S START=$ P($H,",",2 )
  18141   "RTN","VPR EFST",8,0)
  18142    ;D KILL^V PRDJFS
  18143   "RTN","VPR EFST",9,0)
  18144    D STRTSYN C
  18145   "RTN","VPR EFST",10,0 )
  18146    F  H 2 D  LOADUPD Q: DONE=1
  18147   "RTN","VPR EFST",11,0 )
  18148    ;D LOADUP D ; one la st time to  clear the  last pati ent
  18149   "RTN","VPR EFST",12,0 )
  18150    W !,"Elap sed Second s: ",$P($H ,",",2)-ST ART
  18151   "RTN","VPR EFST",13,0 )
  18152    Q
  18153   "RTN","VPR EFST",14,0 )
  18154   STRTSYNC ;  Add patie nts for sy nchronizat ion
  18155   "RTN","VPR EFST",15,0 )
  18156    ; expects  TOTPTS
  18157   "RTN","VPR EFST",16,0 )
  18158    N ARGS,RS P
  18159   "RTN","VPR EFST",17,0 )
  18160    S ARGS("c ommand")=" startOpera tionalData Extract"
  18161   "RTN","VPR EFST",18,0 )
  18162    S ARGS("s erver")="h mpTest"
  18163   "RTN","VPR EFST",19,0 )
  18164    D API^VPR DJFS(.RSP, .ARGS)
  18165   "RTN","VPR EFST",20,0 )
  18166    ;ZW ^TMP( "VPRF",$J)
  18167   "RTN","VPR EFST",21,0 )
  18168    Q
  18169   "RTN","VPR EFST",22,0 )
  18170   LOADUPD ;  Load updat es
  18171   "RTN","VPR EFST",23,0 )
  18172    ; expects  LASTUPD
  18173   "RTN","VPR EFST",24,0 )
  18174    N RSP,ARG S,ERR,CNT, LNODE
  18175   "RTN","VPR EFST",25,0 )
  18176    ;S ARGS(" command")= "getOperat ionalDataU pdates"
  18177   "RTN","VPR EFST",26,0 )
  18178    S ARGS("c ommand")=" getPtUpdat es"
  18179   "RTN","VPR EFST",27,0 )
  18180    S ARGS("s erver")="h mpTest"
  18181   "RTN","VPR EFST",28,0 )
  18182    S ARGS("l astUpdate" )=LASTUPD
  18183   "RTN","VPR EFST",29,0 )
  18184    S ARGS("m ax")=1000
  18185   "RTN","VPR EFST",30,0 )
  18186    D API^VPR DJFS(.RSP, .ARGS)
  18187   "RTN","VPR EFST",31,0 )
  18188    D SCANHDR S
  18189   "RTN","VPR EFST",32,0 )
  18190    S LASTUPD =$$GETLUPD
  18191   "RTN","VPR EFST",33,0 )
  18192    S CNT=$$C NTOBJS,GTO TAL=GTOTAL +CNT
  18193   "RTN","VPR EFST",34,0 )
  18194    W !,"last Update: ", LASTUPD,"   items: ", CNT_"/"_GT OTAL,?50
  18195   "RTN","VPR EFST",35,0 )
  18196    Q
  18197   "RTN","VPR EFST",36,0 )
  18198   SCANHDRS ;  Scan head ers for sy ncDone obj ects
  18199   "RTN","VPR EFST",37,0 )
  18200    ; expects  DONEPTS
  18201   "RTN","VPR EFST",38,0 )
  18202    N I
  18203   "RTN","VPR EFST",39,0 )
  18204    W !
  18205   "RTN","VPR EFST",40,0 )
  18206    ;ZW ^TMP( "VPRF",$J)
  18207   "RTN","VPR EFST",41,0 )
  18208    S I=0 F   S I=$O(^TM P("VPRF",$ J,I)) Q:'I   D
  18209   "RTN","VPR EFST",42,0 )
  18210    . I $G(^T MP("VPRF", $J,I,.3))[ "syncStatu s" S DONE= 1
  18211   "RTN","VPR EFST",43,0 )
  18212    Q
  18213   "RTN","VPR EFST",44,0 )
  18214   SHOWHDRS ;  Show obje ct header  info
  18215   "RTN","VPR EFST",45,0 )
  18216    N I
  18217   "RTN","VPR EFST",46,0 )
  18218    S I=0 F   S I=$O(^TM P("VPRF",$ J,I)) Q:'I   D
  18219   "RTN","VPR EFST",47,0 )
  18220    . W !,"Hd r: ",$G(^T MP("VPRF", $J,I,.3))
  18221   "RTN","VPR EFST",48,0 )
  18222    Q
  18223   "RTN","VPR EFST",49,0 )
  18224   CNTOBJS()  ; Return c ount of ob jects retu rned
  18225   "RTN","VPR EFST",50,0 )
  18226    N I,C
  18227   "RTN","VPR EFST",51,0 )
  18228    S C=0
  18229   "RTN","VPR EFST",52,0 )
  18230    S I=.9 ;  skip .5 he ader node
  18231   "RTN","VPR EFST",53,0 )
  18232    W !
  18233   "RTN","VPR EFST",54,0 )
  18234    ;ZW ^TMP( "VPRF",$J)
  18235   "RTN","VPR EFST",55,0 )
  18236    F  S I=$O (^TMP("VPR F",$J,I))  Q:'I  I $L ($G(^TMP(" VPRF",$J,I ,1))) S C= C+1 W !,^T MP("VPRF", $J,I,1)
  18237   "RTN","VPR EFST",56,0 )
  18238    Q C
  18239   "RTN","VPR EFST",57,0 )
  18240    ;
  18241   "RTN","VPR EFST",58,0 )
  18242   GETLUPD()  ; Return l ast update  value
  18243   "RTN","VPR EFST",59,0 )
  18244    N X
  18245   "RTN","VPR EFST",60,0 )
  18246    W !
  18247   "RTN","VPR EFST",61,0 )
  18248    ;ZW ^TMP( "VPRF",$J)
  18249   "RTN","VPR EFST",62,0 )
  18250    S X=^TMP( "VPRF",$J, .5),X=$P(X ,"""lastUp date"":""" ,2),X=$P(X ,""",")
  18251   "RTN","VPR EFST",63,0 )
  18252    Q X
  18253   "RTN","VPR EFST",64,0 )
  18254    ;
  18255   "RTN","VPR EFST",65,0 )
  18256   TOTALS ;
  18257   "RTN","VPR EFST",66,0 )
  18258    N P,T
  18259   "RTN","VPR EFST",67,0 )
  18260    S T=0
  18261   "RTN","VPR EFST",68,0 )
  18262    S P=0 F   S P=$O(^XT MP("VPRFP" ,P)) Q:'P   S T=T+^XT MP("VPRFP" ,P,"hmpTes t","total" )
  18263   "RTN","VPR EFST",69,0 )
  18264    W !,"TOTA L: ",T
  18265   "RTN","VPR EFST",70,0 )
  18266    Q
  18267   "RTN","VPR EFST",71,0 )
  18268   GETFEW ;
  18269   "RTN","VPR EFST",72,0 )
  18270    S ARGS("c ommand")=" getPtUpdat es"
  18271   "RTN","VPR EFST",73,0 )
  18272    S ARGS("s erver")="h mpTest"
  18273   "RTN","VPR EFST",74,0 )
  18274    S ARGS("l astUpdate" )="3140115 -251"
  18275   "RTN","VPR EFST",75,0 )
  18276    S ARGS("m ax")=10
  18277   "RTN","VPR EFST",76,0 )
  18278    D API^VPR DJFS(.RSP, .ARGS)
  18279   "RTN","VPR EFST",77,0 )
  18280    Q
  18281   "RTN","VPR EFX")
  18282   0^55^B8552 882
  18283   "RTN","VPR EFX",1,0)
  18284   VPREFX ;SL C/MKB -- R eference d ata update  ; 7/19/12  2:26pm
  18285   "RTN","VPR EFX",2,0)
  18286    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  18287   "RTN","VPR EFX",3,0)
  18288    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  18289   "RTN","VPR EFX",4,0)
  18290    ;
  18291   "RTN","VPR EFX",5,0)
  18292    ; Externa l Referenc es           DBIA#
  18293   "RTN","VPR EFX",6,0)
  18294    ; ------- ---------- --           -----
  18295   "RTN","VPR EFX",7,0)
  18296    ; ^DPT                            10035
  18297   "RTN","VPR EFX",8,0)
  18298    ; MPIF001                          2701
  18299   "RTN","VPR EFX",9,0)
  18300    ; XLFSTR                          10104
  18301   "RTN","VPR EFX",10,0)
  18302    ;
  18303   "RTN","VPR EFX",11,0)
  18304   EN(LAST,MA X) ; -- ge t data fro m ^XTMP("V PREF-<date >",n)
  18305   "RTN","VPR EFX",12,0)
  18306    ;[MAX not  used yet]
  18307   "RTN","VPR EFX",13,0)
  18308    N X,Y,VPR TOTL,DOMCN T,TYPE,NAM E,RTN,VPRI D
  18309   "RTN","VPR EFX",14,0)
  18310    S LAST=$G (LAST) D G ETLIST(LAS T)
  18311   "RTN","VPR EFX",15,0)
  18312    G ENQ:$G( ^TMP("VPRX ",$J,0))<1  ;no data
  18313   "RTN","VPR EFX",16,0)
  18314    ;
  18315   "RTN","VPR EFX",17,0)
  18316    S (VPRTOT L,DOMCNT)= 0
  18317   "RTN","VPR EFX",18,0)
  18318    S TYPE=""  F  S TYPE =$O(^TMP(" VPRX",$J,T YPE)) Q:TY PE=""  D
  18319   "RTN","VPR EFX",19,0)
  18320    . S NAME= $$LOW^XLFS TR(TYPE)
  18321   "RTN","VPR EFX",20,0)
  18322    . S RTN=$ $TAG^VPREF (NAME)_"^V PREF" Q:'$ L($T(@RTN) )
  18323   "RTN","VPR EFX",21,0)
  18324    . S DOMCN T=DOMCNT+1
  18325   "RTN","VPR EFX",22,0)
  18326    . ;
  18327   "RTN","VPR EFX",23,0)
  18328    . N VPR,V PRI
  18329   "RTN","VPR EFX",24,0)
  18330    . S VPR=$ NA(^TMP("V PR",$J,DOM CNT)),VPRI =0,VPRID=" "
  18331   "RTN","VPR EFX",25,0)
  18332    . F  S VP RID=$O(^TM P("VPRX",$ J,TYPE,VPR ID)) Q:VPR ID=""  D
  18333   "RTN","VPR EFX",26,0)
  18334    .. D @RTN  S VPRTOTL =VPRTOTL+1
  18335   "RTN","VPR EFX",27,0)
  18336    . ;
  18337   "RTN","VPR EFX",28,0)
  18338    . I 'VPRI  S DOMCNT= DOMCNT-1 Q    ;no dat a, or erro r
  18339   "RTN","VPR EFX",29,0)
  18340    . S:DOMCN T>1 @VPR@( .3)=","
  18341   "RTN","VPR EFX",30,0)
  18342    . S @VPR@ (.5)="{""d omainName" ":"""_NAME _""",""tot al"":"_VPR I_",""item s"":["
  18343   "RTN","VPR EFX",31,0)
  18344    . S VPRI= VPRI+1,@VP R@(VPRI)=" ]}"
  18345   "RTN","VPR EFX",32,0)
  18346    ;
  18347   "RTN","VPR EFX",33,0)
  18348   ENQ ;
  18349   "RTN","VPR EFX",34,0)
  18350    S Y=$G(^T MP("VPRX", $J,0)) K ^ TMP("VPRX" ,$J)
  18351   "RTN","VPR EFX",35,0)
  18352    I '$G(DOM CNT) S @VP R@(.5)="{" "apiVersio n"":""1.01 "",""data" ":{""lastU pdate"":"" "_LAST_""" ,""totalIt ems"":0,"" items"":[] }}" Q
  18353   "RTN","VPR EFX",36,0)
  18354    ;
  18355   "RTN","VPR EFX",37,0)
  18356    S @VPR@(. 5)="{""api Version"": ""1.01""," "data"":{" "lastUpdat e"":"""_Y_ """,""tota lItems"":" _DOMCNT_", ""items"": ["
  18357   "RTN","VPR EFX",38,0)
  18358    S VPRI=DO MCNT I $D( ^TMP($J,"V PR ERROR") ) D
  18359   "RTN","VPR EFX",39,0)
  18360    . N ERROR ,CNT
  18361   "RTN","VPR EFX",40,0)
  18362    . D BUILD ERR^VPREF( .ERROR)
  18363   "RTN","VPR EFX",41,0)
  18364    . S VPRI= VPRI+1,@VP R@(VPRI)=" ,",CNT=0
  18365   "RTN","VPR EFX",42,0)
  18366    . F  S CN T=$O(ERROR (CNT)) Q:C NT'>0  S V PRI=VPRI+1 ,@VPR@(VPR I)=ERROR(C NT)
  18367   "RTN","VPR EFX",43,0)
  18368    . K ^TMP( $J,"VPR ER ROR")
  18369   "RTN","VPR EFX",44,0)
  18370    S VPRI=VP RI+1,@VPR@ (VPRI)="]} }"
  18371   "RTN","VPR EFX",45,0)
  18372    Q
  18373   "RTN","VPR EFX",46,0)
  18374    ;
  18375   "RTN","VPR EFX",47,0)
  18376   GETLIST(LA ST) ; -- b uild list  of updates  for clien t
  18377   "RTN","VPR EFX",48,0)
  18378    ; Returns  ^TMP("VPR X",$J,0) =  last DATE :SEQ inclu ded
  18379   "RTN","VPR EFX",49,0)
  18380    ;          ^TMP("VPR X",$J,TYPE ,ID)=ACT
  18381   "RTN","VPR EFX",50,0)
  18382    N DATE,SE Q,BEG,END, IDX,X0,DFN ,TYPE,ID,A CT
  18383   "RTN","VPR EFX",51,0)
  18384    K ^TMP("V PRX",$J)
  18385   "RTN","VPR EFX",52,0)
  18386    S DATE=+L AST,SEQ=+$ P(LAST,":" ,2)
  18387   "RTN","VPR EFX",53,0)
  18388    ; generat e list ID,  and end p oint
  18389   "RTN","VPR EFX",54,0)
  18390    S BEG=$NA (^XTMP("VP REF-"_DATE ,SEQ))          ;init  loop wher e left off
  18391   "RTN","VPR EFX",55,0)
  18392    ; END=$Q( ^XTMP("VPR EF-"_(DT+1 ),9999999) ,-1) ;last  node
  18393   "RTN","VPR EFX",56,0)
  18394    S END=+$O (^XTMP("VP REF-"_DT," A"),-1)         ;last  node
  18395   "RTN","VPR EFX",57,0)
  18396    S ^TMP("V PRX",$J,0) =DT_":"_EN D               ;date :seq
  18397   "RTN","VPR EFX",58,0)
  18398    ;
  18399   "RTN","VPR EFX",59,0)
  18400    S IDX=BEG  F  S IDX= $Q(@IDX) Q :$$DONE  D
  18401   "RTN","VPR EFX",60,0)
  18402    . S X0=@I DX,TYPE=$P (X0,U),ID= $P(X0,U,2) ,ACT=$P(X0 ,U,3)
  18403   "RTN","VPR EFX",61,0)
  18404    . I TYPE= ""!(ID="")  Q  ;error
  18405   "RTN","VPR EFX",62,0)
  18406    . S ^TMP( "VPRX",$J, TYPE,ID)=A CT
  18407   "RTN","VPR EFX",63,0)
  18408    Q
  18409   "RTN","VPR EFX",64,0)
  18410    ;
  18411   "RTN","VPR EFX",65,0)
  18412   DONE() ; - - Return 1  or 0, if  loop has f inished
  18413   "RTN","VPR EFX",66,0)
  18414    I IDX'?1" ^XTMP(""VP REF-"7N.E   Q 1  ;end  of ^XTMP
  18415   "RTN","VPR EFX",67,0)
  18416    N D,N S D =+$P(IDX," -",2),N=+$ P(IDX,",", 2)
  18417   "RTN","VPR EFX",68,0)
  18418    ; check V PR-DATE su bscript
  18419   "RTN","VPR EFX",69,0)
  18420    I D<DT Q  0                           ;pri or day: ke ep going
  18421   "RTN","VPR EFX",70,0)
  18422    I D>DT Q  1                           ;nex t day:  st op loop
  18423   "RTN","VPR EFX",71,0)
  18424    ; D=DT: c heck seque nce# subsc ript
  18425   "RTN","VPR EFX",72,0)
  18426    I N>END Q  1
  18427   "RTN","VPR EFX",73,0)
  18428    Q 0
  18429   "RTN","VPR EHL7")
  18430   0^97^B9866 24
  18431   "RTN","VPR EHL7",1,0)
  18432   VPREHL7 ;A LB/MJK - V PR HL7 ADT  Message P rocessor ; 03/25/2014  16:50:09
  18433   "RTN","VPR EHL7",2,0)
  18434    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  18435   "RTN","VPR EHL7",3,0)
  18436    ;;
  18437   "RTN","VPR EHL7",4,0)
  18438    ;
  18439   "RTN","VPR EHL7",5,0)
  18440   A04 ; -- m ain entry  point for  VPR ADT-A0 4 CLIENT p rotocol
  18441   "RTN","VPR EHL7",6,0)
  18442    ;       T his router  protocol  subscribes  to the VA FC ADT-A04  SERVER 
  18443   "RTN","VPR EHL7",7,0)
  18444    ;       p rotocol.
  18445   "RTN","VPR EHL7",8,0)
  18446    ;
  18447   "RTN","VPR EHL7",9,0)
  18448    ; Note: T hese varia bles are p rovided bu t the Vist A HL7 syst em when a
  18449   "RTN","VPR EHL7",10,0 )
  18450    ;       s ubscriber  protocol's  ROUTING L OGIC is ca lled:
  18451   "RTN","VPR EHL7",11,0 )
  18452    ;             - HLNE XT
  18453   "RTN","VPR EHL7",12,0 )
  18454    ;             - HLQU IT
  18455   "RTN","VPR EHL7",13,0 )
  18456    ;             - HLNO DE
  18457   "RTN","VPR EHL7",14,0 )
  18458    ;             - HL(" FS")
  18459   "RTN","VPR EHL7",15,0 )
  18460    ;             - HL(" ECH")
  18461   "RTN","VPR EHL7",16,0 )
  18462    ;
  18463   "RTN","VPR EHL7",17,0 )
  18464    ; -- scan  ADT/A04 m essage for  PID segme nt and DFN ; set ^XTM P("VPRF*~. ..
  18465   "RTN","VPR EHL7",18,0 )
  18466    SET DONE= 0
  18467   "RTN","VPR EHL7",19,0 )
  18468    FOR  XECU TE HLNEXT  QUIT:HLQUI T'>0  DO   QUIT:DONE
  18469   "RTN","VPR EHL7",20,0 )
  18470    . IF $EXT RACT(HLNOD E,1,3)'="P ID" QUIT
  18471   "RTN","VPR EHL7",21,0 )
  18472    . SET DON E=1
  18473   "RTN","VPR EHL7",22,0 )
  18474    . NEW DFN
  18475   "RTN","VPR EHL7",23,0 )
  18476    . SET DFN =+$PIECE($ PIECE(HLNO DE,HL("FS" ),4),$EXTR ACT(HL("EC H")))
  18477   "RTN","VPR EHL7",24,0 )
  18478    . IF 'DFN  QUIT
  18479   "RTN","VPR EHL7",25,0 )
  18480    . IF '$DA TA(^VPR(56 0,"AITEM", DFN)) DO P OSTX^VPREV NT("patien t",DFN) QU IT
  18481   "RTN","VPR EHL7",26,0 )
  18482    . DO POST ^VPREVNT(D FN,"patien t",DFN)
  18483   "RTN","VPR EHL7",27,0 )
  18484    QUIT
  18485   "RTN","VPR EHL7",28,0 )
  18486    ;
  18487   "RTN","VPR ELAB")
  18488   0^84^B4110 490
  18489   "RTN","VPR ELAB",1,0)
  18490   VPRELAB ;  SLC/JMC -  Lab extrac t utilitie s ; 2/20/1 4 4:23pm
  18491   "RTN","VPR ELAB",2,0)
  18492    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 1913;B uild 205
  18493   "RTN","VPR ELAB",3,0)
  18494   SHWORPNL ;  Ordering  panels (en ds in "pan el")
  18495   "RTN","VPR ELAB",4,0)
  18496    N X,COUNT ,LABDAT
  18497   "RTN","VPR ELAB",5,0)
  18498    S X=$NA(^ LAB(60))
  18499   "RTN","VPR ELAB",6,0)
  18500    F  S X=$Q (@X) Q:($Q S(X,1)'=60 )!($QS(X,2 )'=+$QS(X, 2))  D
  18501   "RTN","VPR ELAB",7,0)
  18502    . I $QS(X ,3)=0  D
  18503   "RTN","VPR ELAB",8,0)
  18504    . . I $D( LABDAT),CO UNT>0 S VP RCNT=VPRCN T+1 D ADD^ VPREF("LAB DAT") K LA BDAT
  18505   "RTN","VPR ELAB",9,0)
  18506    . . S COU NT=0,LABDA T("name")= $P(@X,"^", 1),LABDAT( "uid")=$$S ETUID^VPRU TILS("labp anel","",$ QS(X,2))
  18507   "RTN","VPR ELAB",10,0 )
  18508    . I $QS(X ,3)=2,$QS( X,4)>0  D
  18509   "RTN","VPR ELAB",11,0 )
  18510    . . S LAB DAT("labs" ,$QS(X,4), "id")=@X,L ABDAT("lab s",$QS(X,4 ),"name")= $P(^LAB(60 ,+@X,0),"^ ",1),COUNT =COUNT+1
  18511   "RTN","VPR ELAB",12,0 )
  18512    I $D(LABD AT),COUNT> 0 S VPRCNT =VPRCNT+1  D ADD^VPRE F("LABDAT" ) K LABDAT
  18513   "RTN","VPR ELAB",13,0 )
  18514    Q
  18515   "RTN","VPR ELAB",14,0 )
  18516   SHWCUMR2 ;  All Cumul ative Repo rts and th e labs the y point to  (for UI p ick on lab s view)
  18517   "RTN","VPR ELAB",15,0 )
  18518    N X,LASTS UB,LASTLAB ,LABDAT
  18519   "RTN","VPR ELAB",16,0 )
  18520    S LASTSUB =0,LASTLAB =0,X=$NA(^ LAB(64.5,1 ,1))
  18521   "RTN","VPR ELAB",17,0 )
  18522    F  S X=$Q (@X) Q:($Q S(X,4)="B" )!($QS(X,3 )'=1)!($QS (X,2)'=1)! ($QS(X,1)' =64.5)  D
  18523   "RTN","VPR ELAB",18,0 )
  18524    . I $QS(X ,5)=0  D
  18525   "RTN","VPR ELAB",19,0 )
  18526    . . I $D( LABDAT) S  VPRCNT=VPR CNT+1 D AD D^VPREF("L ABDAT") K  LABDAT
  18527   "RTN","VPR ELAB",20,0 )
  18528    . . S LAS TSUB=0,LAS TLAB=0,LAB DAT("name" )=$P(@X,"^ ",1)
  18529   "RTN","VPR ELAB",21,0 )
  18530    . I $QS(X ,7)=0 S LA STSUB=LAST SUB+1,LAST LAB=0,LABD AT("uid")= $$SETUID^V PRUTILS("l abgroup",, $QS(X,4)), LABDAT("gr oups",LAST SUB,"name" )=$P(@X,"^ ",1)
  18531   "RTN","VPR ELAB",22,0 )
  18532    . I $QS(X ,9)=0  D
  18533   "RTN","VPR ELAB",23,0 )
  18534    . . S LAS TLAB=LASTL AB+1
  18535   "RTN","VPR ELAB",24,0 )
  18536    . . S LAB DAT("group s",LASTSUB ,"labs",LA STLAB,"nam e")=$P(^LA B(60,$P(@X ,"^",1),0) ,"^",1)
  18537   "RTN","VPR ELAB",25,0 )
  18538    . . S LAB DAT("group s",LASTSUB ,"labs",LA STLAB,"id" )=$P(@X,"^ ",1)
  18539   "RTN","VPR ELAB",26,0 )
  18540    I $D(LABD AT) S VPRC NT=VPRCNT+ 1 D ADD^VP REF("LABDA T") K LABD AT
  18541   "RTN","VPR ELAB",27,0 )
  18542    Q
  18543   "RTN","VPR ENSZ")
  18544   0^56^B6859 4142
  18545   "RTN","VPR ENSZ",1,0)
  18546   VPRENSZ ;S LC/KCM - M easure dat a sizes
  18547   "RTN","VPR ENSZ",2,0)
  18548    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  18549   "RTN","VPR ENSZ",3,0)
  18550    ;
  18551   "RTN","VPR ENSZ",4,0)
  18552   EN ; Find  Max, Mean,  Median fo r each TAG
  18553   "RTN","VPR ENSZ",5,0)
  18554    K ^XTMP(" VPRENSZ-DO MAINS")
  18555   "RTN","VPR ENSZ",6,0)
  18556    D ALG,PRB ,DOC,ENC,A CC,LAB,MIC ,RAD,VIT,R XI,RXO,NVA ,ORD,OBS
  18557   "RTN","VPR ENSZ",7,0)
  18558    Q
  18559   "RTN","VPR ENSZ",8,0)
  18560   ALG ;@type  ALLERGY @ name Aller gies
  18561   "RTN","VPR ENSZ",9,0)
  18562    D REPORT( 120.8,"ALG ")
  18563   "RTN","VPR ENSZ",10,0 )
  18564    Q
  18565   "RTN","VPR ENSZ",11,0 )
  18566   PRB ;@type  PROBLEM @ name Probl ems
  18567   "RTN","VPR ENSZ",12,0 )
  18568    D REPORT( 9000011,"P RB")
  18569   "RTN","VPR ENSZ",13,0 )
  18570    Q
  18571   "RTN","VPR ENSZ",14,0 )
  18572   DOC ;@type  DOCUMENT  @name Docu ments
  18573   "RTN","VPR ENSZ",15,0 )
  18574    D REPORT( 8925,"DOC" )
  18575   "RTN","VPR ENSZ",16,0 )
  18576    Q
  18577   "RTN","VPR ENSZ",17,0 )
  18578   ENC ;@type  VISIT @na me Encount ers
  18579   "RTN","VPR ENSZ",18,0 )
  18580    D REPORT( 9000010,"E NC")
  18581   "RTN","VPR ENSZ",19,0 )
  18582    Q
  18583   "RTN","VPR ENSZ",20,0 )
  18584   ACC ;@type  ACCESSION  @name Acc essions
  18585   "RTN","VPR ENSZ",21,0 )
  18586    D REPORT( "63ACC","A CC")
  18587   "RTN","VPR ENSZ",22,0 )
  18588    Q
  18589   "RTN","VPR ENSZ",23,0 )
  18590   LAB ;@type  LAB @name  Lab Resul ts
  18591   "RTN","VPR ENSZ",24,0 )
  18592    D REPORT( 63,"LAB")
  18593   "RTN","VPR ENSZ",25,0 )
  18594    Q
  18595   "RTN","VPR ENSZ",26,0 )
  18596   MIC ;@name  Micro/AP  Collection s
  18597   "RTN","VPR ENSZ",27,0 )
  18598    D REPORT( "63MI","MI C")
  18599   "RTN","VPR ENSZ",28,0 )
  18600    Q
  18601   "RTN","VPR ENSZ",29,0 )
  18602   RAD ;@type  RADIOLOGY  @name Rad iology Pro cedures
  18603   "RTN","VPR ENSZ",30,0 )
  18604    D REPORT( 70,"RAD")
  18605   "RTN","VPR ENSZ",31,0 )
  18606    Q
  18607   "RTN","VPR ENSZ",32,0 )
  18608   VIT ;@type  VITAL @na me Vital M easurement s
  18609   "RTN","VPR ENSZ",33,0 )
  18610    D REPORT( 120.5,"VIT ")
  18611   "RTN","VPR ENSZ",34,0 )
  18612    Q
  18613   "RTN","VPR ENSZ",35,0 )
  18614   RXI ;@type  MED @name  Inpatient  Medicatio ns
  18615   "RTN","VPR ENSZ",36,0 )
  18616    D REPORT( 55,"RXI")
  18617   "RTN","VPR ENSZ",37,0 )
  18618    Q
  18619   "RTN","VPR ENSZ",38,0 )
  18620   RXO ;@type  RX @name  Outpatient  Medicatio ns
  18621   "RTN","VPR ENSZ",39,0 )
  18622    D REPORT( 52,"RXO")
  18623   "RTN","VPR ENSZ",40,0 )
  18624    Q
  18625   "RTN","VPR ENSZ",41,0 )
  18626   NVA ;@type  MED @name  Non-VA Me dications
  18627   "RTN","VPR ENSZ",42,0 )
  18628    D REPORT( "55NVA","N VA")
  18629   "RTN","VPR ENSZ",43,0 )
  18630    Q
  18631   "RTN","VPR ENSZ",44,0 )
  18632   ORD ;@name  Orders
  18633   "RTN","VPR ENSZ",45,0 )
  18634    D REPORT( 100,"ORD")
  18635   "RTN","VPR ENSZ",46,0 )
  18636    Q
  18637   "RTN","VPR ENSZ",47,0 )
  18638   OBS ;@name  Observati ons
  18639   "RTN","VPR ENSZ",48,0 )
  18640    D REPORT( 704.117,"O BS")
  18641   "RTN","VPR ENSZ",49,0 )
  18642    Q
  18643   "RTN","VPR ENSZ",50,0 )
  18644   REPORT(FIL E,TAG) ; l oop thru r eminder in dex, calul ate stats  & show rep ort
  18645   "RTN","VPR ENSZ",51,0 )
  18646    D ILOOP(F ILE,TAG),C ALC(TAG),S AVE(TAG),S HOW(TAG)
  18647   "RTN","VPR ENSZ",52,0 )
  18648    K ^TMP($J )
  18649   "RTN","VPR ENSZ",53,0 )
  18650    Q
  18651   "RTN","VPR ENSZ",54,0 )
  18652   ILOOP(FN,T AG) ;
  18653   "RTN","VPR ENSZ",55,0 )
  18654    K ^TMP($J )
  18655   "RTN","VPR ENSZ",56,0 )
  18656    N PT,PTDF N,CNT,TOTP T,HIGHCNT, TOTREC
  18657   "RTN","VPR ENSZ",57,0 )
  18658    S TOTPT=0 ,TOTREC=0, HIGHCNT=0
  18659   "RTN","VPR ENSZ",58,0 )
  18660    S PT=0 F   S PT=$$NE XTPT(FN,PT ) Q:'PT  D
  18661   "RTN","VPR ENSZ",59,0 )
  18662    . S TOTPT =TOTPT+1 W :TOTPT#100 =0 "."
  18663   "RTN","VPR ENSZ",60,0 )
  18664    . I "^55^ 55NVA^52^1 00^"[("^"_ FN_"^") S  CNT=$$LP1( PT,FN)
  18665   "RTN","VPR ENSZ",61,0 )
  18666    . I "^63^ 70^120.5^" [("^"_FN_" ^") S CNT= $$LP2(PT,F N)
  18667   "RTN","VPR ENSZ",62,0 )
  18668    . I "63MI "=FN S CNT =$$LPMI(PT )
  18669   "RTN","VPR ENSZ",63,0 )
  18670    . I "63AC C"=FN S CN T=$$LPACC( PT)
  18671   "RTN","VPR ENSZ",64,0 )
  18672    . I 8925= FN S CNT=$ $LPDOC(PT)
  18673   "RTN","VPR ENSZ",65,0 )
  18674    . I 120.8 =FN S CNT= $$LPALG(PT )
  18675   "RTN","VPR ENSZ",66,0 )
  18676    . I 90000 11=FN S CN T=$$LPROB( PT)
  18677   "RTN","VPR ENSZ",67,0 )
  18678    . I 90000 10=FN S CN T=$$LPVST( PT)
  18679   "RTN","VPR ENSZ",68,0 )
  18680    . I FN=70 4.117 S CN T=$$MDC^VP RENSZ(PT)
  18681   "RTN","VPR ENSZ",69,0 )
  18682    . Q:'CNT
  18683   "RTN","VPR ENSZ",70,0 )
  18684    . I (FN=" 63ACC"),($ P(^LR(PT,0 ),"^",2)'= 2) Q  ;non -patient c ollection
  18685   "RTN","VPR ENSZ",71,0 )
  18686    . S PTDFN =$S(FN="63 ACC":$P(^L R(PT,0),"^ ",3),1:PT)
  18687   "RTN","VPR ENSZ",72,0 )
  18688    . I CNT>H IGHCNT S H IGHCNT=CNT
  18689   "RTN","VPR ENSZ",73,0 )
  18690    . S ^TMP( $J,TAG,"FR EQ",CNT)=+ $G(^TMP($J ,TAG,"FREQ ",CNT))+1
  18691   "RTN","VPR ENSZ",74,0 )
  18692    . S ^TMP( $J,TAG,"CO UNT",CNT,P TDFN)="",T OTREC=TOTR EC+CNT
  18693   "RTN","VPR ENSZ",75,0 )
  18694    S ^TMP($J ,TAG,"STAT S","Highes tCount")=H IGHCNT
  18695   "RTN","VPR ENSZ",76,0 )
  18696    S ^TMP($J ,TAG,"STAT S","TotalR ecords")=T OTREC
  18697   "RTN","VPR ENSZ",77,0 )
  18698    S ^TMP($J ,TAG,"STAT S","TotalP atients")= TOTPT
  18699   "RTN","VPR ENSZ",78,0 )
  18700    Q
  18701   "RTN","VPR ENSZ",79,0 )
  18702   NEXTPT(FN, PT) ; Retu rns the ne xt patient  based on  PT passed  in
  18703   "RTN","VPR ENSZ",80,0 )
  18704    I FN="63M I" Q $O(^P XRMINDX(63 ,"PDI",PT) )
  18705   "RTN","VPR ENSZ",81,0 )
  18706    I FN="63A CC" Q $O(^ LR(PT))
  18707   "RTN","VPR ENSZ",82,0 )
  18708    I FN=8925  Q $O(^TIU (8925,"C", PT))
  18709   "RTN","VPR ENSZ",83,0 )
  18710    I FN=120. 8 Q $O(^GM R(120.8,"B ",PT))
  18711   "RTN","VPR ENSZ",84,0 )
  18712    I FN=9000 011 Q $O(^ AUPNPROB(" AC",PT))
  18713   "RTN","VPR ENSZ",85,0 )
  18714    I FN=9000 010 Q $O(^ AUPNVSIT(" C",PT))
  18715   "RTN","VPR ENSZ",86,0 )
  18716    I FN=704. 117 Q $O(^ MDC(704.11 7,"PT",PT) )
  18717   "RTN","VPR ENSZ",87,0 )
  18718    Q $O(^PXR MINDX(FN," PI",PT))
  18719   "RTN","VPR ENSZ",88,0 )
  18720    ;
  18721   "RTN","VPR ENSZ",89,0 )
  18722   LP1(PT,FN)  ; return  count for  indexes wi th start/s top dates
  18723   "RTN","VPR ENSZ",90,0 )
  18724    N CNT S C NT=0
  18725   "RTN","VPR ENSZ",91,0 )
  18726    N ITM,STR T,STOP,DAS
  18727   "RTN","VPR ENSZ",92,0 )
  18728    S ITM=""  F  S ITM=$ O(^PXRMIND X(FN,"PI", PT,ITM)) Q :ITM=""  D
  18729   "RTN","VPR ENSZ",93,0 )
  18730    . S STRT= "" F  S ST RT=$O(^PXR MINDX(FN," PI",PT,ITM ,STRT)) Q: STRT=""  D
  18731   "RTN","VPR ENSZ",94,0 )
  18732    . . S STO P="" F  S  STOP=$O(^P XRMINDX(FN ,"PI",PT,I TM,STRT,ST OP)) Q:STO P=""  D
  18733   "RTN","VPR ENSZ",95,0 )
  18734    . . . S D AS="" F  S  DAS=$O(^P XRMINDX(FN ,"PI",PT,I TM,STRT,ST OP,DAS)) Q :DAS=""  S  CNT=CNT+1
  18735   "RTN","VPR ENSZ",96,0 )
  18736    Q CNT
  18737   "RTN","VPR ENSZ",97,0 )
  18738    ;
  18739   "RTN","VPR ENSZ",98,0 )
  18740   LP2(PT,FN)  ; return  count for  indexes wi th date on ly
  18741   "RTN","VPR ENSZ",99,0 )
  18742    N CNT S C NT=0
  18743   "RTN","VPR ENSZ",100, 0)
  18744    N ITM,DAT E,DAS
  18745   "RTN","VPR ENSZ",101, 0)
  18746    S ITM=""  F  S ITM=$ O(^PXRMIND X(FN,"PI", PT,ITM)) Q :ITM=""  D
  18747   "RTN","VPR ENSZ",102, 0)
  18748    . S DATE= "" F  S DA TE=$O(^PXR MINDX(FN," PI",PT,ITM ,DATE)) Q: DATE=""  D
  18749   "RTN","VPR ENSZ",103, 0)
  18750    . . S DAS ="" F  S D AS=$O(^PXR MINDX(FN," PI",PT,ITM ,DATE,DAS) ) Q:DAS=""   S CNT=CN T+1
  18751   "RTN","VPR ENSZ",104, 0)
  18752    Q CNT
  18753   "RTN","VPR ENSZ",105, 0)
  18754    ;
  18755   "RTN","VPR ENSZ",106, 0)
  18756   LPMI(PT) ;  return co unt for mi cro/anatom ic path co llections
  18757   "RTN","VPR ENSZ",107, 0)
  18758    N CNT S C NT=0
  18759   "RTN","VPR ENSZ",108, 0)
  18760    N DATE
  18761   "RTN","VPR ENSZ",109, 0)
  18762    S DATE=""  F  S DATE =$O(^PXRMI NDX(63,"PD I",PT,DATE )) Q:DATE= ""  S CNT= CNT+1
  18763   "RTN","VPR ENSZ",110, 0)
  18764    Q CNT
  18765   "RTN","VPR ENSZ",111, 0)
  18766    ;
  18767   "RTN","VPR ENSZ",112, 0)
  18768   LPDOC(PT)  ; return c ount for T IU documen ts
  18769   "RTN","VPR ENSZ",113, 0)
  18770    N CNT S C NT=0
  18771   "RTN","VPR ENSZ",114, 0)
  18772    N DA
  18773   "RTN","VPR ENSZ",115, 0)
  18774    S DA=0 F   S DA=$O(^ TIU(8925," C",PT,DA))  Q:'DA  S  CNT=CNT+1
  18775   "RTN","VPR ENSZ",116, 0)
  18776    Q CNT
  18777   "RTN","VPR ENSZ",117, 0)
  18778    ;
  18779   "RTN","VPR ENSZ",118, 0)
  18780    ;N CNT S  CNT=0
  18781   "RTN","VPR ENSZ",119, 0)
  18782    ;N CLS,TM ,DA
  18783   "RTN","VPR ENSZ",120, 0)
  18784    ;S CLS=0  F  S CLS=$ O(^TIU(892 5,"ACLPT", CLS)) Q:'C LS  D
  18785   "RTN","VPR ENSZ",121, 0)
  18786    ;. S TM=0  F  S TM=$ O(^TIU(892 5,"ACLPT", CLS,PT,TM) ) Q:'TM  D
  18787   "RTN","VPR ENSZ",122, 0)
  18788    ;. . S DA =0 F  S DA =$O(^TIU(8 925,"ACLPT ",CLS,PT,T M,DA)) Q:' DA  S CNT= CNT+1
  18789   "RTN","VPR ENSZ",123, 0)
  18790    ;Q CNT
  18791   "RTN","VPR ENSZ",124, 0)
  18792    ;
  18793   "RTN","VPR ENSZ",125, 0)
  18794    ;N CNT S  CNT=0
  18795   "RTN","VPR ENSZ",126, 0)
  18796    ;N DOC,TM
  18797   "RTN","VPR ENSZ",127, 0)
  18798    ;S DOC=0  F  S DOC=$ O(^TIU(892 5,"AA",PT, DOC)) Q:'D OC  D
  18799   "RTN","VPR ENSZ",128, 0)
  18800    ;. S TM=0  F  S TM=$ O(^TIU(892 5,"AA",PT, DOC,TM)) Q :'TM  D
  18801   "RTN","VPR ENSZ",129, 0)
  18802    ;. . S DA =0 F  S DA =$O(^TIU(8 925,"AA",P T,DOC,TM,D A)) Q:'DA   S CNT=CNT +1
  18803   "RTN","VPR ENSZ",130, 0)
  18804    ;Q CNT
  18805   "RTN","VPR ENSZ",131, 0)
  18806    ;
  18807   "RTN","VPR ENSZ",132, 0)
  18808   LPALG(PT)  ; return c ount for a llergies
  18809   "RTN","VPR ENSZ",133, 0)
  18810    N CNT S C NT=0
  18811   "RTN","VPR ENSZ",134, 0)
  18812    N DA S DA =0
  18813   "RTN","VPR ENSZ",135, 0)
  18814    F  S DA=$ O(^GMR(120 .8,"B",PT, DA)) Q:'DA   S CNT=CN T+1
  18815   "RTN","VPR ENSZ",136, 0)
  18816    Q CNT
  18817   "RTN","VPR ENSZ",137, 0)
  18818    ;
  18819   "RTN","VPR ENSZ",138, 0)
  18820   LPROB(PT)  ; return c ount for p roblems
  18821   "RTN","VPR ENSZ",139, 0)
  18822    N CNT S C NT=0
  18823   "RTN","VPR ENSZ",140, 0)
  18824    N DA S DA =0
  18825   "RTN","VPR ENSZ",141, 0)
  18826    F  S DA=$ O(^AUPNPRO B("AC",PT, DA)) Q:'DA   S CNT=CN T+1
  18827   "RTN","VPR ENSZ",142, 0)
  18828    Q CNT
  18829   "RTN","VPR ENSZ",143, 0)
  18830    ;
  18831   "RTN","VPR ENSZ",144, 0)
  18832   LPVST(PT)  ; return c ount for v isits
  18833   "RTN","VPR ENSZ",145, 0)
  18834    N CNT S C NT=0
  18835   "RTN","VPR ENSZ",146, 0)
  18836    N DA S DA =0
  18837   "RTN","VPR ENSZ",147, 0)
  18838    F  S DA=$ O(^AUPNVSI T("C",PT,D A)) Q:'DA   D
  18839   "RTN","VPR ENSZ",148, 0)
  18840    . I "AHSR "[$P(^AUPN VSIT(DA,0) ,"^",7) S  CNT=CNT+1
  18841   "RTN","VPR ENSZ",149, 0)
  18842    . ; (only  include a mbulatory,  hospitali zation, su rgery, and  nursing h ome)
  18843   "RTN","VPR ENSZ",150, 0)
  18844    Q CNT
  18845   "RTN","VPR ENSZ",151, 0)
  18846    ;
  18847   "RTN","VPR ENSZ",152, 0)
  18848   LPACC(PT)  ; return c ount of ac cessions
  18849   "RTN","VPR ENSZ",153, 0)
  18850    N CNT S C NT=0
  18851   "RTN","VPR ENSZ",154, 0)
  18852    N ACC S A CC=0
  18853   "RTN","VPR ENSZ",155, 0)
  18854    F  S ACC= $O(^LR(PT, "CH",ACC))  Q:'ACC  S  CNT=CNT+1
  18855   "RTN","VPR ENSZ",156, 0)
  18856    Q CNT
  18857   "RTN","VPR ENSZ",157, 0)
  18858    ; 
  18859   "RTN","VPR ENSZ",158, 0)
  18860   CALC(TAG)  ; calculat e statisti cs for a T AG
  18861   "RTN","VPR ENSZ",159, 0)
  18862    ; find th e highest  item coun
  18863   "RTN","VPR ENSZ",160, 0)
  18864    N MAX S M AX=^TMP($J ,TAG,"STAT S","Highes tCount")
  18865   "RTN","VPR ENSZ",161, 0)
  18866    D MAXPTS( TAG,MAX)
  18867   "RTN","VPR ENSZ",162, 0)
  18868    ;
  18869   "RTN","VPR ENSZ",163, 0)
  18870    ; find th e average  item count
  18871   "RTN","VPR ENSZ",164, 0)
  18872    N PTS,MEA N
  18873   "RTN","VPR ENSZ",165, 0)
  18874    S PTS=^TM P($J,TAG," STATS","To talPatient s"),MEAN=0
  18875   "RTN","VPR ENSZ",166, 0)
  18876    I PTS S M EAN=^TMP($ J,TAG,"STA TS","Total Records")\ PTS
  18877   "RTN","VPR ENSZ",167, 0)
  18878    D ADDPTS( TAG,"MEAN" ,MEAN)
  18879   "RTN","VPR ENSZ",168, 0)
  18880    ;
  18881   "RTN","VPR ENSZ",169, 0)
  18882    ; find th e median i tem count
  18883   "RTN","VPR ENSZ",170, 0)
  18884    N POS,CNT ,PT,I
  18885   "RTN","VPR ENSZ",171, 0)
  18886    S:PTS#2 P TS=PTS+1 S  POS=PTS\2
  18887   "RTN","VPR ENSZ",172, 0)
  18888    S I=0
  18889   "RTN","VPR ENSZ",173, 0)
  18890    S CNT=0 F   S CNT=$O (^TMP($J,T AG,"COUNT" ,CNT)) Q:' CNT  D  Q: I'<POS
  18891   "RTN","VPR ENSZ",174, 0)
  18892    . S PT=0  F  S PT=$O (^TMP($J,T AG,"COUNT" ,CNT,PT))  Q:'PT  S I =I+1 Q:I'< POS
  18893   "RTN","VPR ENSZ",175, 0)
  18894    D ADDPTS( TAG,"MEDIA N",CNT)
  18895   "RTN","VPR ENSZ",176, 0)
  18896    ;
  18897   "RTN","VPR ENSZ",177, 0)
  18898    N HIGH,MO DE S HIGH= 0,MODE=0,C NT=0
  18899   "RTN","VPR ENSZ",178, 0)
  18900    F  S CNT= +$O(^TMP($ J,TAG,"COU NT",CNT))  Q:'CNT  D
  18901   "RTN","VPR ENSZ",179, 0)
  18902    . I ^TMP( $J,TAG,"FR EQ",CNT)>H IGH S HIGH =^(CNT),MO DE=CNT
  18903   "RTN","VPR ENSZ",180, 0)
  18904    D ADDPTS( TAG,"MODE" ,MODE)
  18905   "RTN","VPR ENSZ",181, 0)
  18906    ;
  18907   "RTN","VPR ENSZ",182, 0)
  18908    D MINPTS( TAG)
  18909   "RTN","VPR ENSZ",183, 0)
  18910    ;
  18911   "RTN","VPR ENSZ",184, 0)
  18912    K ^TMP($J ,TAG,"COUN T") ; rele ase space
  18913   "RTN","VPR ENSZ",185, 0)
  18914    ;S CNT=0  F  S CNT=$ O(^TMP($J, TAG,"FREQ" ,CNT)) Q:' CNT  W !,C NT_"="_^(C NT)
  18915   "RTN","VPR ENSZ",186, 0)
  18916    ;
  18917   "RTN","VPR ENSZ",187, 0)
  18918    Q
  18919   "RTN","VPR ENSZ",188, 0)
  18920   ADDPTS(TAG ,STAT,CNT)  ; add pat ients that  represent  this meas urement
  18921   "RTN","VPR ENSZ",189, 0)
  18922    S ^TMP($J ,TAG,"STAT S",STAT)=C NT
  18923   "RTN","VPR ENSZ",190, 0)
  18924    Q:CNT=""
  18925   "RTN","VPR ENSZ",191, 0)
  18926    N PT,TOTP T,MAXPT
  18927   "RTN","VPR ENSZ",192, 0)
  18928    S TOTPT=0 ,MAXPT=5
  18929   "RTN","VPR ENSZ",193, 0)
  18930    S PT="" ;  since we  are revers e ordering ...
  18931   "RTN","VPR ENSZ",194, 0)
  18932    F  S PT=$ O(^TMP($J, TAG,"COUNT ",CNT,PT), -1) Q:'PT   D  Q:TOTP T'<MAXPT
  18933   "RTN","VPR ENSZ",195, 0)
  18934    . S TOTPT =TOTPT+1
  18935   "RTN","VPR ENSZ",196, 0)
  18936    . S ^TMP( $J,TAG,"ST ATS",STAT, TOTPT)=$P( ^DPT(PT,0) ,"^")_"^"_ PT
  18937   "RTN","VPR ENSZ",197, 0)
  18938    Q
  18939   "RTN","VPR ENSZ",198, 0)
  18940   MINPTS(TAG ) ; store  the top 10  patients  with the h ighest cou nts
  18941   "RTN","VPR ENSZ",199, 0)
  18942    N PT,TOTP T,MAXPT
  18943   "RTN","VPR ENSZ",200, 0)
  18944    S CNT=0,T OTPT=0,MAX PT=10
  18945   "RTN","VPR ENSZ",201, 0)
  18946    F  S CNT= $O(^TMP($J ,TAG,"COUN T",CNT)) Q :'CNT  D   Q:TOTPT'<M AXPT
  18947   "RTN","VPR ENSZ",202, 0)
  18948    .I $G(^TM P($J,TAG," STATS","MI N"))="" S  ^TMP($J,TA G,"STATS", "MIN")=CNT
  18949   "RTN","VPR ENSZ",203, 0)
  18950    . S PT=0  F  S PT=$O (^TMP($J,T AG,"COUNT" ,CNT,PT))  Q:'PT  D   Q:TOTPT'<M AXPT
  18951   "RTN","VPR ENSZ",204, 0)
  18952    . . S TOT PT=TOTPT+1
  18953   "RTN","VPR ENSZ",205, 0)
  18954    . . S ^TM P($J,TAG," STATS","MI N",TOTPT)= $P(^DPT(PT ,0),"^")_" ^"_PT_"^"_ CNT
  18955   "RTN","VPR ENSZ",206, 0)
  18956    I $G(^TMP ($J,TAG,"S TATS","MIN "))="" S ^ TMP($J,TAG ,"STATS"," MIN")=0
  18957   "RTN","VPR ENSZ",207, 0)
  18958    Q
  18959   "RTN","VPR ENSZ",208, 0)
  18960   MAXPTS(TAG ,CNT) ; st ore the to p 10 patie nts with t he highest  counts
  18961   "RTN","VPR ENSZ",209, 0)
  18962    S ^TMP($J ,TAG,"STAT S","MAX")= CNT
  18963   "RTN","VPR ENSZ",210, 0)
  18964    N PT,TOTP T,MAXPT
  18965   "RTN","VPR ENSZ",211, 0)
  18966    S CNT=CNT +1,TOTPT=0 ,MAXPT=10
  18967   "RTN","VPR ENSZ",212, 0)
  18968    F  S CNT= $O(^TMP($J ,TAG,"COUN T",CNT),-1 ) Q:'CNT   D  Q:TOTPT '<MAXPT
  18969   "RTN","VPR ENSZ",213, 0)
  18970    . S PT=0  F  S PT=$O (^TMP($J,T AG,"COUNT" ,CNT,PT))  Q:'PT  D   Q:TOTPT'<M AXPT
  18971   "RTN","VPR ENSZ",214, 0)
  18972    . . S TOT PT=TOTPT+1
  18973   "RTN","VPR ENSZ",215, 0)
  18974    . . S ^TM P($J,TAG," STATS","MA X",TOTPT)= $P(^DPT(PT ,0),"^")_" ^"_PT_"^"_ CNT
  18975   "RTN","VPR ENSZ",216, 0)
  18976    Q
  18977   "RTN","VPR ENSZ",217, 0)
  18978   SAVE(TAG)  ; save the  TAG measu rements in  ^XTMP
  18979   "RTN","VPR ENSZ",218, 0)
  18980    S ^XTMP(" VPRENSZ-DO MAINS",0)= $$FMADD^XL FDT(DT,30) _U_DT
  18981   "RTN","VPR ENSZ",219, 0)
  18982    K ^XTMP(" VPRENSZ-DO MAINS",TAG )
  18983   "RTN","VPR ENSZ",220, 0)
  18984    M ^XTMP(" VPRENSZ-DO MAINS",TAG ,"FREQ")=^ TMP($J,TAG ,"FREQ")
  18985   "RTN","VPR ENSZ",221, 0)
  18986    M ^XTMP(" VPRENSZ-DO MAINS",TAG ,"STATS")= ^TMP($J,TA G,"STATS")
  18987   "RTN","VPR ENSZ",222, 0)
  18988    Q
  18989   "RTN","VPR ENSZ",223, 0)
  18990   SHOW(TAG)  ; show inf ormation a bout sizes
  18991   "RTN","VPR ENSZ",224, 0)
  18992    N STATS M  STATS=^TM P($J,TAG," STATS")
  18993   "RTN","VPR ENSZ",225, 0)
  18994    N DOMAIN  S DOMAIN=$ $DOMNAME(T AG)
  18995   "RTN","VPR ENSZ",226, 0)
  18996    W !!,DOMA IN,", Pati ents Searc hed: ",STA TS("TotalP atients")
  18997   "RTN","VPR ENSZ",227, 0)
  18998    W "    To tal Record s: ",STATS ("TotalRec ords"),"   "
  18999   "RTN","VPR ENSZ",228, 0)
  19000    N I F I=$ X:1:76 W " -"
  19001   "RTN","VPR ENSZ",229, 0)
  19002    W !!,DOMA IN," Maxim um (top te n):  ",STA TS("MAX")  D LSTPT(TA G,"MAX")
  19003   "RTN","VPR ENSZ",230, 0)
  19004    W !!,DOMA IN," Mean  (average):   ",STATS( "MEAN") D  LSTPT(TAG, "MEAN")
  19005   "RTN","VPR ENSZ",231, 0)
  19006    W !!,DOMA IN," Media n (middle) :  ",STATS ("MEDIAN")  D LSTPT(T AG,"MEDIAN ")
  19007   "RTN","VPR ENSZ",232, 0)
  19008    W !!,DOMA IN," Mode  (most comm on):  ",ST ATS("MODE" ) D LSTPT( TAG,"MODE" )
  19009   "RTN","VPR ENSZ",233, 0)
  19010    W !!,DOMA IN," Small est (top t en):  ",ST ATS("MIN")  D LSTPT(T AG,"MIN")
  19011   "RTN","VPR ENSZ",234, 0)
  19012    Q
  19013   "RTN","VPR ENSZ",235, 0)
  19014   LSTPT(TAG, STAT) ; li st sample  patients m atching cr iteria
  19015   "RTN","VPR ENSZ",236, 0)
  19016    N I,X,CNT  S CNT=0
  19017   "RTN","VPR ENSZ",237, 0)
  19018    S I=0 F   S I=$O(^TM P($J,TAG," STATS",STA T,I)) Q:'I   D
  19019   "RTN","VPR ENSZ",238, 0)
  19020    . S X=^TM P($J,TAG," STATS",STA T,I),CNT=C NT+1
  19021   "RTN","VPR ENSZ",239, 0)
  19022    . W !,?2, $P(X,"^"), ?44,$P(X," ^",2)
  19023   "RTN","VPR ENSZ",240, 0)
  19024    . I $P(X, "^",3) W ? 62,$P(X,"^ ",3)," rec ords"
  19025   "RTN","VPR ENSZ",241, 0)
  19026    Q
  19027   "RTN","VPR ENSZ",242, 0)
  19028   DOMNAME(TA G) ; retur n full TAG  name give n tag
  19029   "RTN","VPR ENSZ",243, 0)
  19030    N X,NAME
  19031   "RTN","VPR ENSZ",244, 0)
  19032    S X=$T(@( TAG_"^VPRE NSZ")),NAM E=$E(X,$F( X,"@name " ),$L(X))
  19033   "RTN","VPR ENSZ",245, 0)
  19034    Q NAME
  19035   "RTN","VPR ENSZ",246, 0)
  19036    ;
  19037   "RTN","VPR ENSZ",247, 0)
  19038   VTYPES ; d ump visit  types
  19039   "RTN","VPR ENSZ",248, 0)
  19040    S DFN=0 F   S DFN=$O (^AUPNVSIT ("C",DFN))  Q:'DFN  D
  19041   "RTN","VPR ENSZ",249, 0)
  19042    . S DA=0  F  S DA=$O (^AUPNVSIT ("C",DFN,D A)) Q:'DA   D
  19043   "RTN","VPR ENSZ",250, 0)
  19044    .. W !,DF N,?10,$P(^ AUPNVSIT(D A,0),"^",7 )
  19045   "RTN","VPR ENSZ",251, 0)
  19046    Q
  19047   "RTN","VPR ENSZ",252, 0)
  19048   TCOMP ; te st compila tion
  19049   "RTN","VPR ENSZ",253, 0)
  19050    W !,"This  compiles  on VDEV"
  19051   "RTN","VPR ENSZ",254, 0)
  19052    Q
  19053   "RTN","VPR ENSZ",255, 0)
  19054   MDC(PT) ;  Observatio ns in clio  for a pt.
  19055   "RTN","VPR ENSZ",256, 0)
  19056    ; Run the  PT XREF o n the OBS  file (704. 117)
  19057   "RTN","VPR ENSZ",257, 0)
  19058    N CNT,OBS DT,OBSIFN  S OBSDT="" ,OBSIFN="" ,CNT=0
  19059   "RTN","VPR ENSZ",258, 0)
  19060    F  S OBSD T=$O(^MDC( 704.117,"P T",PT,OBSD T)) Q:OBSD T=""  D
  19061   "RTN","VPR ENSZ",259, 0)
  19062    .F  S OBS IFN=$O(^MD C(704.117, "PT",PT,OB SDT,OBSIFN )) Q:OBSIF N=""  D
  19063   "RTN","VPR ENSZ",260, 0)
  19064    ..S CNT=C NT+1
  19065   "RTN","VPR ENSZ",261, 0)
  19066    Q CNT
  19067   "RTN","VPR ENSZ1")
  19068   0^57^B1068 6788
  19069   "RTN","VPR ENSZ1",1,0 )
  19070   VPRENSZ1 ; SLC/KCM -  Measure da ta sizes
  19071   "RTN","VPR ENSZ1",2,0 )
  19072    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  19073   "RTN","VPR ENSZ1",3,0 )
  19074    ;
  19075   "RTN","VPR ENSZ1",4,0 )
  19076   DOMAINS(LS T) ; RPC -  list of d omains for  which siz ing inform ation is a vailable
  19077   "RTN","VPR ENSZ1",5,0 )
  19078    N I,X,TAG ,NAME
  19079   "RTN","VPR ENSZ1",6,0 )
  19080    S LST=1,L ST(LST)="< domains>"
  19081   "RTN","VPR ENSZ1",7,0 )
  19082    F I=2:1 S  X=$T(@("+ "_I_"^VPRE NSZ")) Q:' $L(X)  I ( X?1.7U1" ; ".E),(X["@ name ") D
  19083   "RTN","VPR ENSZ1",8,0 )
  19084    . S TAG=$ P(X," ") S  NAME=$E(X ,$F(X,"@na me "),$L(X ))
  19085   "RTN","VPR ENSZ1",9,0 )
  19086    . S LST=L ST+1,LST(L ST)="<doma in tag='"_ TAG_"'>"_N AME_"</dom ain>"
  19087   "RTN","VPR ENSZ1",10, 0)
  19088    S LST=LST +1,LST(LST )="</domai ns>"
  19089   "RTN","VPR ENSZ1",11, 0)
  19090    Q
  19091   "RTN","VPR ENSZ1",12, 0)
  19092   STATS(LST, TAG) ; RPC  - list st ats, patie nts, & raw  data for  a domain
  19093   "RTN","VPR ENSZ1",13, 0)
  19094    N X,STATS ,FREQ,DOMA IN
  19095   "RTN","VPR ENSZ1",14, 0)
  19096    S X=$T(@( TAG_"^VPRE NSZ"))
  19097   "RTN","VPR ENSZ1",15, 0)
  19098    S DOMAIN= $E(X,$F(X, "@name "), $L(X))
  19099   "RTN","VPR ENSZ1",16, 0)
  19100    S TYPE=$P (X,"@type  ",2),TYPE= $P(TYPE,"  ")
  19101   "RTN","VPR ENSZ1",17, 0)
  19102    S LST=0
  19103   "RTN","VPR ENSZ1",18, 0)
  19104    I '$D(^XT MP("VPRENS Z-DOMAINS" ,TAG)) D E RRMSG(DOMA IN_"("_TAG _") size m easurement s unavaila ble.") Q
  19105   "RTN","VPR ENSZ1",19, 0)
  19106    ;
  19107   "RTN","VPR ENSZ1",20, 0)
  19108    M STATS=^ XTMP("VPRE NSZ-DOMAIN S",TAG,"ST ATS")
  19109   "RTN","VPR ENSZ1",21, 0)
  19110    ; M FREQ= ^XTMP("VPR ENSZ-DOMAI NS",TAG,"F REQ") - DO N'T NEED T HIS... 
  19111   "RTN","VPR ENSZ1",22, 0)
  19112    ;
  19113   "RTN","VPR ENSZ1",23, 0)
  19114    S X="<sta ts domain= '"_DOMAIN_ "' tag='"_ TAG_"' typ e='"_TYPE_ "' "
  19115   "RTN","VPR ENSZ1",24, 0)
  19116    S X=X_"pa tients='"_ STATS("Tot alPatients ")_"' "
  19117   "RTN","VPR ENSZ1",25, 0)
  19118    S X=X_"re cords='"_S TATS("Tota lRecords") _"' >"
  19119   "RTN","VPR ENSZ1",26, 0)
  19120    S LST=LST +1,LST(LST )=X
  19121   "RTN","VPR ENSZ1",27, 0)
  19122    ;
  19123   "RTN","VPR ENSZ1",28, 0)
  19124    S LST=LST +1,LST(LST )="<mean v alue='"_ST ATS("MEAN" )_"' >"
  19125   "RTN","VPR ENSZ1",29, 0)
  19126    D PTS2XML ("MEAN")
  19127   "RTN","VPR ENSZ1",30, 0)
  19128    S LST=LST +1,LST(LST )="</mean> "
  19129   "RTN","VPR ENSZ1",31, 0)
  19130    ;
  19131   "RTN","VPR ENSZ1",32, 0)
  19132    S LST=LST +1,LST(LST )="<median  value='"_ STATS("MED IAN")_"' > "
  19133   "RTN","VPR ENSZ1",33, 0)
  19134    D PTS2XML ("MEDIAN")
  19135   "RTN","VPR ENSZ1",34, 0)
  19136    S LST=LST +1,LST(LST )="</media n>"
  19137   "RTN","VPR ENSZ1",35, 0)
  19138    ;
  19139   "RTN","VPR ENSZ1",36, 0)
  19140    S LST=LST +1,LST(LST )="<mode v alue='"_ST ATS("MODE" )_"' >"
  19141   "RTN","VPR ENSZ1",37, 0)
  19142    D PTS2XML ("MODE")
  19143   "RTN","VPR ENSZ1",38, 0)
  19144    S LST=LST +1,LST(LST )="</mode> "
  19145   "RTN","VPR ENSZ1",39, 0)
  19146    ;
  19147   "RTN","VPR ENSZ1",40, 0)
  19148    S LST=LST +1,LST(LST )="<max va lue='"_STA TS("MAX")_ "' >"
  19149   "RTN","VPR ENSZ1",41, 0)
  19150    D PTS2XML ("MAX")
  19151   "RTN","VPR ENSZ1",42, 0)
  19152    S LST=LST +1,LST(LST )="</max>"
  19153   "RTN","VPR ENSZ1",43, 0)
  19154    ;
  19155   "RTN","VPR ENSZ1",44, 0)
  19156    D FREQ
  19157   "RTN","VPR ENSZ1",45, 0)
  19158    S LST=LST +1,LST(LST )="</stats >"
  19159   "RTN","VPR ENSZ1",46, 0)
  19160    Q
  19161   "RTN","VPR ENSZ1",47, 0)
  19162   PTS2XML(ST AT) ; add  patients t o the retu rn XML
  19163   "RTN","VPR ENSZ1",48, 0)
  19164    ; expects : LST, STA TS
  19165   "RTN","VPR ENSZ1",49, 0)
  19166    ; <patien t dfn=4323 423 count= 342234 icn =342432424 3>doe,john </patient>
  19167   "RTN","VPR ENSZ1",50, 0)
  19168    N I,X,NM, DFN,CNT,IC N
  19169   "RTN","VPR ENSZ1",51, 0)
  19170    S I=0 F   S I=$O(STA TS(STAT,I) ) Q:'I  D
  19171   "RTN","VPR ENSZ1",52, 0)
  19172    . S X=STA TS(STAT,I)
  19173   "RTN","VPR ENSZ1",53, 0)
  19174    . S NM=$P (X,U),DFN= $P(X,U,2), CNT=$P(X,U ,3)
  19175   "RTN","VPR ENSZ1",54, 0)
  19176    . S ICN=$ $GETICN^MP IF001(DFN)  S:+ICN<0  ICN=""
  19177   "RTN","VPR ENSZ1",55, 0)
  19178    . S LST=L ST+1
  19179   "RTN","VPR ENSZ1",56, 0)
  19180    . S LST(L ST)="<pati ent dfn='" _DFN_"' co unt='"_CNT _"' icn='" _ICN_"' >" _NM_"</pat ient>"
  19181   "RTN","VPR ENSZ1",57, 0)
  19182    Q
  19183   "RTN","VPR ENSZ1",58, 0)
  19184   FREQ ; add  RecordCou nt=Patient Count stri ngs
  19185   "RTN","VPR ENSZ1",59, 0)
  19186    N X,I
  19187   "RTN","VPR ENSZ1",60, 0)
  19188    S LST=LST +1,LST(LST )="<record Count>"
  19189   "RTN","VPR ENSZ1",61, 0)
  19190    S X="",I= 0 F  S I=$ O(^XTMP("V PRENSZ-DOM AINS",TAG, "FREQ",I))  Q:'I  D
  19191   "RTN","VPR ENSZ1",62, 0)
  19192    . S X=X_I _"," I $L( X)>72 S LS T=LST+1,LS T(LST)=X,X =""
  19193   "RTN","VPR ENSZ1",63, 0)
  19194    I $L(X) S  LST=LST+1 ,LST(LST)= X
  19195   "RTN","VPR ENSZ1",64, 0)
  19196    D NOCOMMA
  19197   "RTN","VPR ENSZ1",65, 0)
  19198    S LST=LST +1,LST(LST )="</recor dCount>"
  19199   "RTN","VPR ENSZ1",66, 0)
  19200    ; 
  19201   "RTN","VPR ENSZ1",67, 0)
  19202    S LST=LST +1,LST(LST )="<patien tCount>"
  19203   "RTN","VPR ENSZ1",68, 0)
  19204    S X="",I= 0 F  S I=$ O(^XTMP("V PRENSZ-DOM AINS",TAG, "FREQ",I))  Q:'I  D
  19205   "RTN","VPR ENSZ1",69, 0)
  19206    . S X=X_^ XTMP("VPRE NSZ-DOMAIN S",TAG,"FR EQ",I)_","
  19207   "RTN","VPR ENSZ1",70, 0)
  19208    . I $L(X) >72 S LST= LST+1,LST( LST)=X,X=" "
  19209   "RTN","VPR ENSZ1",71, 0)
  19210    I $L(X) S  LST=LST+1 ,LST(LST)= X
  19211   "RTN","VPR ENSZ1",72, 0)
  19212    D NOCOMMA
  19213   "RTN","VPR ENSZ1",73, 0)
  19214    S LST=LST +1,LST(LST )="</patie ntCount>"
  19215   "RTN","VPR ENSZ1",74, 0)
  19216    Q
  19217   "RTN","VPR ENSZ1",75, 0)
  19218   NOCOMMA ;
  19219   "RTN","VPR ENSZ1",76, 0)
  19220    I $E(LST( LST),$L(LS T(LST)))=" ," S LST(L ST)=$E(LST (LST),1,$L (LST(LST)) -1)
  19221   "RTN","VPR ENSZ1",77, 0)
  19222    Q
  19223   "RTN","VPR ENSZ1",78, 0)
  19224   ERRMSG(X)  ; build er ror messag e
  19225   "RTN","VPR ENSZ1",79, 0)
  19226    S LST=LST +1,LST(LST )="<error  msg='"_X_" ' />"
  19227   "RTN","VPR ENSZ1",80, 0)
  19228    Q
  19229   "RTN","VPR ENSZ1",81, 0)
  19230   CF ; Count  frequenci es
  19231   "RTN","VPR ENSZ1",82, 0)
  19232    S DOM=""  F  S DOM=$ O(^XTMP("V PRENSZ-DOM AINS",DOM) ) Q:DOM=""   D
  19233   "RTN","VPR ENSZ1",83, 0)
  19234    . S (I,T) =0 F  S I= $O(^XTMP(" VPRENSZ-DO MAINS",DOM ,"FREQ",I) ) Q:'I  S  T=T+1
  19235   "RTN","VPR ENSZ1",84, 0)
  19236    . W !,DOM ,"=",T
  19237   "RTN","VPR ENSZ1",85, 0)
  19238    Q
  19239   "RTN","VPR EVNT")
  19240   0^2^B98045 334
  19241   "RTN","VPR EVNT",1,0)
  19242   VPREVNT ;S LC/MKB --  VistA even t listener s
  19243   "RTN","VPR EVNT",2,0)
  19244    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  19245   "RTN","VPR EVNT",3,0)
  19246    ;
  19247   "RTN","VPR EVNT",4,0)
  19248    ; Externa l Referenc es           DBIA#
  19249   "RTN","VPR EVNT",5,0)
  19250    ; ------- ---------- --           -----
  19251   "RTN","VPR EVNT",6,0)
  19252    ; DG FIEL D MONITOR               +3344
  19253   "RTN","VPR EVNT",7,0)
  19254    ; DGPM MO VEMENT EVE NTS          +1181
  19255   "RTN","VPR EVNT",8,0)
  19256    ; FH EVSE ND OR                   +
  19257   "RTN","VPR EVNT",9,0)
  19258    ; GMRA EN TERED IN E RROR         +1467
  19259   "RTN","VPR EVNT",10,0 )
  19260    ; GMRA SI GN-OFF ON  DATA         +1469
  19261   "RTN","VPR EVNT",11,0 )
  19262    ; GMRC EV SEND OR                 +3140
  19263   "RTN","VPR EVNT",12,0 )
  19264    ; LR70 CH  EVSEND OR              +3565 *
  19265   "RTN","VPR EVNT",13,0 )
  19266    ; MDC OBS ERVATION U PDATE        +
  19267   "RTN","VPR EVNT",14,0 )
  19268    ; OR EVSE ND *                    +3135
  19269   "RTN","VPR EVNT",15,0 )
  19270    ; PS EVSE ND OR                   +2415
  19271   "RTN","VPR EVNT",16,0 )
  19272    ; PXK VIS IT DATA EV ENT          +1298
  19273   "RTN","VPR EVNT",17,0 )
  19274    ; RA EVSE ND OR                   +
  19275   "RTN","VPR EVNT",18,0 )
  19276    ; SDAM AP POINTMENT  EVENTS       +1320
  19277   "RTN","VPR EVNT",19,0 )
  19278    ; ^AUPNVS IT                       2028
  19279   "RTN","VPR EVNT",20,0 )
  19280    ; ^DPT                            10035
  19281   "RTN","VPR EVNT",21,0 )
  19282    ; ^OR(100                          5771
  19283   "RTN","VPR EVNT",22,0 )
  19284    ; DIQ                              2056
  19285   "RTN","VPR EVNT",23,0 )
  19286    ; GMVUTL                           5046
  19287   "RTN","VPR EVNT",24,0 )
  19288    ; TIUSRVL O                        2834
  19289   "RTN","VPR EVNT",25,0 )
  19290    ; VADPT                           10061
  19291   "RTN","VPR EVNT",26,0 )
  19292    ; VASITE                          10112
  19293   "RTN","VPR EVNT",27,0 )
  19294    ; XLFDT                           10103
  19295   "RTN","VPR EVNT",28,0 )
  19296    ; XTHC10                           5515
  19297   "RTN","VPR EVNT",29,0 )
  19298    ;
  19299   "RTN","VPR EVNT",30,0 )
  19300   DG ; -- DG  FIELD MON ITOR proto col listen er
  19301   "RTN","VPR EVNT",31,0 )
  19302    Q:$G(DGFI LE)'=2          ;Pati ent file o nly
  19303   "RTN","VPR EVNT",32,0 )
  19304    Q:'$$FLD( +$G(DGFIEL D))  ;not  a used fie ld
  19305   "RTN","VPR EVNT",33,0 )
  19306    N DFN S D FN=+$G(DGD A)   ;if n ot subscri bed, use R ef File ev ent
  19307   "RTN","VPR EVNT",34,0 )
  19308    I '$D(^VP R(560,"AIT EM",DFN))  D POSTX("p atient",DF N) Q
  19309   "RTN","VPR EVNT",35,0 )
  19310    ;D POSTX( "patient", DFN)
  19311   "RTN","VPR EVNT",36,0 )
  19312    D POST(DF N,"patient ",DFN)
  19313   "RTN","VPR EVNT",37,0 )
  19314    Q
  19315   "RTN","VPR EVNT",38,0 )
  19316    ;
  19317   "RTN","VPR EVNT",39,0 )
  19318   FLD(X) ; - -Return 1  or 0, if X  is a fiel d tracked  by VPR
  19319   "RTN","VPR EVNT",40,0 )
  19320    S X=U_+$G (X)_U
  19321   "RTN","VPR EVNT",41,0 )
  19322    I "^.01^. 02^.03^.05 ^.08^.09^. 351^.364^" [X Q 1                ;demograph ic
  19323   "RTN","VPR EVNT",42,0 )
  19324    I "^.111^ .1112^.112 ^.113^.114 ^.115^.131 ^.132^.134 ^"[X Q 1   ;addr/phon e
  19325   "RTN","VPR EVNT",43,0 )
  19326    I "^.211^ .212^.213^ .214^.216^ .217^.218^ .219^"[X Q  1         ;NOK
  19327   "RTN","VPR EVNT",44,0 )
  19328    I "^.301^ .302^1901^ .32102^.32 103^.32201 ^.5295^"[X  Q 1       ;serv conn
  19329   "RTN","VPR EVNT",45,0 )
  19330    Q 0
  19331   "RTN","VPR EVNT",46,0 )
  19332    ;
  19333   "RTN","VPR EVNT",47,0 )
  19334   DGPM ; --  DGPM MOVEM ENT EVENTS  protocol  listener
  19335   "RTN","VPR EVNT",48,0 )
  19336    ;    [exp ects DFN,D GPM* varia bles]
  19337   "RTN","VPR EVNT",49,0 )
  19338    N ADM,ACT  S ADM=DGP MDA
  19339   "RTN","VPR EVNT",50,0 )
  19340    I DGPMT'= 1 S ADM=$S (DGPMA:$P( DGPMA,U,14 ),1:$P(DGP MP,U,14))  Q:ADM<1
  19341   "RTN","VPR EVNT",51,0 )
  19342    S ACT=$S( DGPMA:"",1 :"@")
  19343   "RTN","VPR EVNT",52,0 )
  19344    I $D(^VPR (560,"AITE M",DFN)) D  POST(DFN, "visit","H "_ADM,ACT)
  19345   "RTN","VPR EVNT",53,0 )
  19346    ; update  roster(s)  if current  movement
  19347   "RTN","VPR EVNT",54,0 )
  19348    N ADMX,MV TX,PREV,NE W,OLD,WARD
  19349   "RTN","VPR EVNT",55,0 )
  19350    S ADMX=$Q (^DGPM("AT ID1",DFN))  Q:$QS(ADM X,4)'=ADM
  19351   "RTN","VPR EVNT",56,0 )
  19352    S MVTX=$Q (^DGPM("AP MV",DFN,AD M)) Q:$QS( MVTX,5)'=D GPMDA
  19353   "RTN","VPR EVNT",57,0 )
  19354    S PREV=$G (DGPMP) I  'PREV,DGPM T'=1 D  ;p revious or  edited mv t
  19355   "RTN","VPR EVNT",58,0 )
  19356    . S MVTX= $Q(@MVTX)  Q:DFN'=$QS (MVTX,2)   Q:ADM'=$QS (MVTX,3)
  19357   "RTN","VPR EVNT",59,0 )
  19358    . S PREV= $G(^DGPM(+ $QS(MVTX,5 ),0))
  19359   "RTN","VPR EVNT",60,0 )
  19360    S NEW=$P( DGPMA,U,6) ,OLD=$P(PR EV,U,6)
  19361   "RTN","VPR EVNT",61,0 )
  19362    I NEW'=OL D F WARD=N EW,OLD I W ARD D
  19363   "RTN","VPR EVNT",62,0 )
  19364    . S I=0 F   S I=$O(^ VPROSTER(" AD",WARD_" ;DIC(42,", I)) Q:I<1   D POSTX(" roster",I)
  19365   "RTN","VPR EVNT",63,0 )
  19366    Q
  19367   "RTN","VPR EVNT",64,0 )
  19368    ;-find vi sit# for c orrespondi ng admissi on [not us ed]
  19369   "RTN","VPR EVNT",65,0 )
  19370    N ADM,PTF ,IDT,ID,AC T
  19371   "RTN","VPR EVNT",66,0 )
  19372    I DGPMA S  ADM=+DGPM A,PTF=+$P( DGPMA,U,16 )
  19373   "RTN","VPR EVNT",67,0 )
  19374    E  S ADM= +DGPMP,PTF =+$P(DGPMP ,U,16)
  19375   "RTN","VPR EVNT",68,0 )
  19376    I DGPMT'= 1 D  Q:ADM <1
  19377   "RTN","VPR EVNT",69,0 )
  19378    . N VAIP  S VAIP("E" )=DGPMDA
  19379   "RTN","VPR EVNT",70,0 )
  19380    . D IN5^V ADPT S ADM =+VAIP(13, 1),PTF=+VA IP(12)
  19381   "RTN","VPR EVNT",71,0 )
  19382    S IDT=999 9999-$P(AD M,".") S:A DM["." IDT =IDT_"."_$ P(ADM,".", 2)
  19383   "RTN","VPR EVNT",72,0 )
  19384    S ID=+$O( ^AUPNVSIT( "AAH",DFN, IDT,0)) Q: 'ID
  19385   "RTN","VPR EVNT",73,0 )
  19386    S ACT=$S( DGPMA:"",1 :"@")
  19387   "RTN","VPR EVNT",74,0 )
  19388    D POST(DF N,"visit", ID,ACT)
  19389   "RTN","VPR EVNT",75,0 )
  19390    ; POST(DF N,"ptf",PT F,ACT):DGP MT=3
  19391   "RTN","VPR EVNT",76,0 )
  19392    Q
  19393   "RTN","VPR EVNT",77,0 )
  19394    ;
  19395   "RTN","VPR EVNT",78,0 )
  19396   NEWINPT()  ; -- is DF N newly ad mitted?
  19397   "RTN","VPR EVNT",79,0 )
  19398    N Y S Y=0
  19399   "RTN","VPR EVNT",80,0 )
  19400    I DGPMT=1 ,DGPMA,'DG PMP,+$G(^D PT(DFN,.10 5))=DGPMDA  S Y=1 ;ne w admissio n
  19401   "RTN","VPR EVNT",81,0 )
  19402    Q Y
  19403   "RTN","VPR EVNT",82,0 )
  19404    ;
  19405   "RTN","VPR EVNT",83,0 )
  19406   SDAM ; --  SDAM APPOI NTMENT EVE NTS protoc ol listene r
  19407   "RTN","VPR EVNT",84,0 )
  19408    I $G(SDAT A) D  Q  ; appointmen ts
  19409   "RTN","VPR EVNT",85,0 )
  19410    . N DFN,D ATE,HLOC,S TS,REASON, PROV
  19411   "RTN","VPR EVNT",86,0 )
  19412    . S DFN=+ $P(SDATA,U ,2) Q:DFN< 1
  19413   "RTN","VPR EVNT",87,0 )
  19414    . Q:'$D(^ VPR(560,"A ITEM",DFN) )
  19415   "RTN","VPR EVNT",88,0 )
  19416    . S DATE= +$P(SDATA, U,3),HLOC= +$P(SDATA, U,4),(PROV ,REASON)=" "
  19417   "RTN","VPR EVNT",89,0 )
  19418    . ;I SDAM EVT=1 K DI R S DIR(0) ="F^3:20", DIR("A")=" Enter Reas on for App ointment:  ",DIR("?") ="Answer m ust be 2-2 0 characte rs" D ^DIR  S REASON= Y
  19419   "RTN","VPR EVNT",90,0 )
  19420    . ;I SDAM EVT=1 K DI C S DIC="^ VA(200,",D IC("A")="S elect Pati ent's Prov ider: ",DI C(0)="AEQ" ,D="AK.PRO VIDER" D I X^DIC S PR OV=$P(Y,"^ ",1,2)
  19421   "RTN","VPR EVNT",91,0 )
  19422    . D POST( DFN,"appoi ntment","A ;"_DATE_"; "_HLOC_";" _REASON_"; "_$TR($P(P ROV,U,1,2) ,"^",";"))
  19423   "RTN","VPR EVNT",92,0 )
  19424    Q
  19425   "RTN","VPR EVNT",93,0 )
  19426    ;
  19427   "RTN","VPR EVNT",94,0 )
  19428   PCE ; -- P XK VISIT D ATA EVENT  protocol l istener
  19429   "RTN","VPR EVNT",95,0 )
  19430    N IEN,PX0 A,PX0B,DFN ,DA,ACT
  19431   "RTN","VPR EVNT",96,0 )
  19432    S IEN=+$O (^TMP("PXK CO",$J,0))  Q:IEN<1
  19433   "RTN","VPR EVNT",97,0 )
  19434    S PX0A=$G (^TMP("PXK CO",$J,IEN ,"VST",IEN ,0,"AFTER" )),PX0B=$G (^("BEFORE "))
  19435   "RTN","VPR EVNT",98,0 )
  19436    S DFN=$S( $L(PX0A):+ $P(PX0A,U, 5),1:+$P(P X0B,U,5))
  19437   "RTN","VPR EVNT",99,0 )
  19438    Q:DFN<1   Q:'$D(^VPR (560,"AITE M",DFN))
  19439   "RTN","VPR EVNT",100, 0)
  19440    ; Visit f ile
  19441   "RTN","VPR EVNT",101, 0)
  19442    S ACT=$S( PX0A="":"@ ",1:"")
  19443   "RTN","VPR EVNT",102, 0)
  19444    D POST(DF N,"visit", IEN,ACT)
  19445   "RTN","VPR EVNT",103, 0)
  19446    ; check V -files
  19447   "RTN","VPR EVNT",104, 0)
  19448    F SUB="HF ","IMM","X AM","CPT", "PED","POV ","SK" D
  19449   "RTN","VPR EVNT",105, 0)
  19450    . S DA=0  F  S DA=$O (^TMP("PXK CO",$J,IEN ,SUB,DA))  Q:DA<1  D
  19451   "RTN","VPR EVNT",106, 0)
  19452    .. S ACT= $S($G(^TMP ("PXKCO",$ J,IEN,SUB, DA,0,"AFTE R"))="":"@ ",1:"")
  19453   "RTN","VPR EVNT",107, 0)
  19454    .. D POST (DFN,$$NAM E(SUB),DA, ACT)
  19455   "RTN","VPR EVNT",108, 0)
  19456    Q
  19457   "RTN","VPR EVNT",109, 0)
  19458    ;
  19459   "RTN","VPR EVNT",110, 0)
  19460   NAME(X) ;  -- return  object nam e for V-fi les
  19461   "RTN","VPR EVNT",111, 0)
  19462    N Y S Y=" "
  19463   "RTN","VPR EVNT",112, 0)
  19464    I X="HF"   S Y="fact or"
  19465   "RTN","VPR EVNT",113, 0)
  19466    I X="IMM"  S Y="immu nization"
  19467   "RTN","VPR EVNT",114, 0)
  19468    I X="XAM"  S Y="exam "
  19469   "RTN","VPR EVNT",115, 0)
  19470    I X="CPT"  S Y="cpt"
  19471   "RTN","VPR EVNT",116, 0)
  19472    I X="PED"  S Y="educ ation"
  19473   "RTN","VPR EVNT",117, 0)
  19474    I X="POV"  S Y="pov"
  19475   "RTN","VPR EVNT",118, 0)
  19476    I X="SK"   S Y="skin "
  19477   "RTN","VPR EVNT",119, 0)
  19478    Q Y
  19479   "RTN","VPR EVNT",120, 0)
  19480    ;
  19481   "RTN","VPR EVNT",121, 0)
  19482   ZPCE ; --  old PXK VI SIT DATA E VENT proto col listen er [not in  use]
  19483   "RTN","VPR EVNT",122, 0)
  19484    N IEN,PX0 ,PX150,DFN ,DA
  19485   "RTN","VPR EVNT",123, 0)
  19486    S IEN=+$O (^TMP("PXK CO",$J,0))  Q:IEN<1
  19487   "RTN","VPR EVNT",124, 0)
  19488    S PX0=$G( ^TMP("PXKC O",$J,IEN, "VST",IEN, 0,"AFTER") ) Q:$P(PX0 ,U,7)="E"
  19489   "RTN","VPR EVNT",125, 0)
  19490    I PX0=""  D POST(DFN ,"visit",I EN,"@") Q   ;deleted
  19491   "RTN","VPR EVNT",126, 0)
  19492    S PX150=$ G(^TMP("PX KCO",$J,IE N,"VST",IE N,150,"AFT ER")) Q:$P (PX150,U,3 )'="P"
  19493   "RTN","VPR EVNT",127, 0)
  19494    S DFN=+$P (PX0,U,5)  Q:DFN<1  Q :'$D(^VPR( 560,"AITEM ",DFN))
  19495   "RTN","VPR EVNT",128, 0)
  19496    D POST(DF N,"visit", IEN)
  19497   "RTN","VPR EVNT",129, 0)
  19498    S DA=0 F   S DA=$O(^ TMP("PXKCO ",$J,IEN," IMM",DA))  Q:DA<1  D  POST(DFN," immunizati on",DA)
  19499   "RTN","VPR EVNT",130, 0)
  19500    S DA=0 F   S DA=$O(^ TMP("PXKCO ",$J,IEN," HF",DA)) Q :DA<1  D P OST(DFN,"f actor",DA)
  19501   "RTN","VPR EVNT",131, 0)
  19502    Q
  19503   "RTN","VPR EVNT",132, 0)
  19504    ;
  19505   "RTN","VPR EVNT",133, 0)
  19506   XQOR(MSG)  ; -- messa ging liste ner (updat e meds, la bs, xrays,  consults)
  19507   "RTN","VPR EVNT",134, 0)
  19508    N VPRMSG, VPRPKG,MSH ,ORC,DFN
  19509   "RTN","VPR EVNT",135, 0)
  19510    S VPRMSG= $S($L($G(M SG)):MSG,1 :"MSG") Q: '$O(@VPRMS G@(0))
  19511   "RTN","VPR EVNT",136, 0)
  19512    S MSH=0 F   S MSH=$O (@VPRMSG@( MSH)) Q:MS H'>0  Q:$E (@VPRMSG@( MSH),1,3)= "MSH"
  19513   "RTN","VPR EVNT",137, 0)
  19514    Q:'MSH  Q :'$L($G(@V PRMSG@(MSH )))
  19515   "RTN","VPR EVNT",138, 0)
  19516    S VPRPKG= $$TYPE($P( @VPRMSG@(M SH),"|",3) )  Q:'$L(V PRPKG)
  19517   "RTN","VPR EVNT",139, 0)
  19518    S DFN=$$P ID Q:DFN<1   Q:'$D(^V PR(560,"AI TEM",DFN))
  19519   "RTN","VPR EVNT",140, 0)
  19520    S ORC=MSH  F  S ORC= $O(@VPRMSG @(+ORC)) Q :ORC'>0  I  $E(@VPRMS G@(ORC),1, 3)="ORC" D
  19521   "RTN","VPR EVNT",141, 0)
  19522    . N ORDCN TRL,PKGIFN ,ORIFN
  19523   "RTN","VPR EVNT",142, 0)
  19524    . S ORC=O RC_U_@VPRM SG@(ORC),O RDCNTRL=$T R($P(ORC," |",2),"@", "P")
  19525   "RTN","VPR EVNT",143, 0)
  19526    . ; QUIT  if action  failed, co nversion,  purge, or  backdoor v erify/new
  19527   "RTN","VPR EVNT",144, 0)
  19528    . I ORDCN TRL["U"!(" DE^ZC^ZP^Z R^ZV^SN"[O RDCNTRL) Q
  19529   "RTN","VPR EVNT",145, 0)
  19530    . S ORIFN =+$P($P(OR C,"|",3),U ),PKGIFN=$ P($P(ORC," |",4),U)
  19531   "RTN","VPR EVNT",146, 0)
  19532    . ; if or der has a  parent, us e parent#  and update  entire or der
  19533   "RTN","VPR EVNT",147, 0)
  19534    . S ORIFN =$S($P($G( ^OR(100,OR IFN,3)),U, 9):$P(^(3) ,U,9),1:OR IFN)
  19535   "RTN","VPR EVNT",148, 0)
  19536    . I $$RES ULT D  ;up date ancil lary domai ns
  19537   "RTN","VPR EVNT",149, 0)
  19538    .. D POST (DFN,VPRPK G,PKGIFN)
  19539   "RTN","VPR EVNT",150, 0)
  19540    .. D:VPRP KG="image"  POST(DFN, "document" ,PKGIFN)
  19541   "RTN","VPR EVNT",151, 0)
  19542    .. I VPRP KG="lab",P KGIFN'["CH ",'$$LRTIU (DFN,PKGIF N) D POST( DFN,"docum ent",$P(PK GIFN,";",4 ,5))
  19543   "RTN","VPR EVNT",152, 0)
  19544    . I ORIFN ,ORDCNTRL' ="ZD" D  ; update ord er(s)
  19545   "RTN","VPR EVNT",153, 0)
  19546    .. D POST (DFN,"orde r",ORIFN)
  19547   "RTN","VPR EVNT",154, 0)
  19548    .. N ORIG  S ORIG=+$ P($G(^OR(1 00,ORIFN,3 )),U,5)
  19549   "RTN","VPR EVNT",155, 0)
  19550    .. I ORIG  D POST(DF N,"order", ORIG) ;nee d fwd ptrs , sig flds
  19551   "RTN","VPR EVNT",156, 0)
  19552    Q
  19553   "RTN","VPR EVNT",157, 0)
  19554    ;
  19555   "RTN","VPR EVNT",158, 0)
  19556   RESULT() ;  -- Return  1 or 0, i f message  broadcasts  a result
  19557   "RTN","VPR EVNT",159, 0)
  19558    ;            [may mo dify PKGIF N for use  in POST]
  19559   "RTN","VPR EVNT",160, 0)
  19560    N Y S Y=0
  19561   "RTN","VPR EVNT",161, 0)
  19562    I VPRPKG= "consult"  S Y=1,PKGI FN=+PKGIFN  G RQ
  19563   "RTN","VPR EVNT",162, 0)
  19564    I VPRPKG= "med"      S Y=1,PKGI FN=ORIFN G  RQ
  19565   "RTN","VPR EVNT",163, 0)
  19566    I VPRPKG= "lab"      S:ORDCNTRL ="RE"&($L( PKGIFN,";" )>3) Y=1 G  RQ
  19567   "RTN","VPR EVNT",164, 0)
  19568    I VPRPKG= "image"    S:PKGIFN[" ~" Y=1,PKG IFN=$TR($P (PKGIFN,"~ ",2,3),"~" ,"-") G RQ
  19569   "RTN","VPR EVNT",165, 0)
  19570   RQ Q Y
  19571   "RTN","VPR EVNT",166, 0)
  19572    ;
  19573   "RTN","VPR EVNT",167, 0)
  19574   LRTIU(DFN, ORPK) ; --  Return 1  or 0, if L R report i s in TIU
  19575   "RTN","VPR EVNT",168, 0)
  19576    I $G(DFN) <1!'$L($G( ORPK)) Q 0
  19577   "RTN","VPR EVNT",169, 0)
  19578    I ORPK["C H"!(ORPK[" MI") Q 0
  19579   "RTN","VPR EVNT",170, 0)
  19580    N SUB,IDT ,LRDFN
  19581   "RTN","VPR EVNT",171, 0)
  19582    S SUB=$P( ORPK,";",4 ),IDT=+$P( ORPK,";",5 ),LRDFN=+$ G(^DPT(+DF N,"LR"))
  19583   "RTN","VPR EVNT",172, 0)
  19584    I $O(^LR( LRDFN,SUB, IDT,.05,0) ) Q 1
  19585   "RTN","VPR EVNT",173, 0)
  19586    Q 0
  19587   "RTN","VPR EVNT",174, 0)
  19588    ;
  19589   "RTN","VPR EVNT",175, 0)
  19590   NA(MSG) ;  -- messagi ng listene r (new bac kdoor orde rs)
  19591   "RTN","VPR EVNT",176, 0)
  19592    N VPRMSG, VPRPKG,MSH ,ORC,DFN
  19593   "RTN","VPR EVNT",177, 0)
  19594    S VPRMSG= $S($L($G(M SG)):MSG,1 :"MSG") Q: '$O(@VPRMS G@(0))
  19595   "RTN","VPR EVNT",178, 0)
  19596    S MSH=0 F   S MSH=$O (@VPRMSG@( MSH)) Q:MS H'>0  Q:$E (@VPRMSG@( MSH),1,3)= "MSH"
  19597   "RTN","VPR EVNT",179, 0)
  19598    Q:'MSH  Q :'$L($G(@V PRMSG@(MSH )))
  19599   "RTN","VPR EVNT",180, 0)
  19600    S VPRPKG= $$TYPE($P( @VPRMSG@(M SH),"|",3) )  Q:'$L(V PRPKG)
  19601   "RTN","VPR EVNT",181, 0)
  19602    S DFN=$$P ID Q:DFN<1   Q:'$D(^V PR(560,"AI TEM",DFN))
  19603   "RTN","VPR EVNT",182, 0)
  19604    S ORC=MSH  F  S ORC= $O(@VPRMSG @(+ORC)) Q :ORC'>0  I  $E(@VPRMS G@(ORC),1, 3)="ORC" D
  19605   "RTN","VPR EVNT",183, 0)
  19606    . N ORDCN TRL,ORIFN
  19607   "RTN","VPR EVNT",184, 0)
  19608    . S ORC=O RC_U_@VPRM SG@(ORC),O RDCNTRL=$T R($P(ORC," |",2),"@", "P")
  19609   "RTN","VPR EVNT",185, 0)
  19610    . Q:ORDCN TRL'="NA"
  19611   "RTN","VPR EVNT",186, 0)
  19612    . S ORIFN =+$P($P(OR C,"|",3),U ) D POST(D FN,"order" ,ORIFN)
  19613   "RTN","VPR EVNT",187, 0)
  19614    . I VPRPK G="med" D  POST(DFN,V PRPKG,ORIF N)
  19615   "RTN","VPR EVNT",188, 0)
  19616    Q
  19617   "RTN","VPR EVNT",189, 0)
  19618    ;
  19619   "RTN","VPR EVNT",190, 0)
  19620   TYPE(NAME)  ; -- Retu rns type n ame for XM L
  19621   "RTN","VPR EVNT",191, 0)
  19622    I NAME="L ABORATORY"   Q "lab"
  19623   "RTN","VPR EVNT",192, 0)
  19624    I NAME="P HARMACY"     Q "med"
  19625   "RTN","VPR EVNT",193, 0)
  19626    I NAME="C ONSULTS"     Q "consu lt"
  19627   "RTN","VPR EVNT",194, 0)
  19628    I NAME="P ROCEDURES"   Q "consu lt"
  19629   "RTN","VPR EVNT",195, 0)
  19630    I NAME="R ADIOLOGY"    Q "image "
  19631   "RTN","VPR EVNT",196, 0)
  19632    I NAME="I MAGING"      Q "image "
  19633   "RTN","VPR EVNT",197, 0)
  19634    I NAME="O RDER ENTRY " Q "order "
  19635   "RTN","VPR EVNT",198, 0)
  19636    I NAME="D IETETICS"    Q "diet"
  19637   "RTN","VPR EVNT",199, 0)
  19638    Q ""
  19639   "RTN","VPR EVNT",200, 0)
  19640    ;
  19641   "RTN","VPR EVNT",201, 0)
  19642   PID() ; --  Returns p atient fro m PID segm ent in cur rent msg
  19643   "RTN","VPR EVNT",202, 0)
  19644    N I,SEG,Y  S I=MSH
  19645   "RTN","VPR EVNT",203, 0)
  19646    F  S I=$O (@VPRMSG@( I)) Q:I'>0   S SEG=$E (@VPRMSG@( I),1,3) Q: SEG="ORC"   I SEG="PI D" D  Q
  19647   "RTN","VPR EVNT",204, 0)
  19648    . S Y=+$P (@VPRMSG@( I),"|",4)
  19649   "RTN","VPR EVNT",205, 0)
  19650    .;I '$D(^ DPT(Y,0))  S:$L($P(@V PRMSG@(I), "|",5)) Y= +$P(@VPRMS G@(I),"|", 5) ;alt ID  for Lab
  19651   "RTN","VPR EVNT",206, 0)
  19652    Q Y
  19653   "RTN","VPR EVNT",207, 0)
  19654    ;
  19655   "RTN","VPR EVNT",208, 0)
  19656   PV1() ; --  Returns p atient cla ss from PV 1 segment  in current  msg
  19657   "RTN","VPR EVNT",209, 0)
  19658    N I,SEG,Y  S I=MSH,Y =""
  19659   "RTN","VPR EVNT",210, 0)
  19660    F  S I=$O (@VPRMSG@( I)) Q:I'>0   S SEG=$E (@VPRMSG@( I),1,3) Q: SEG="ORC"   I SEG="PV 1" D  Q
  19661   "RTN","VPR EVNT",211, 0)
  19662    . S Y=$P( @VPRMSG@(I ),"|",3)
  19663   "RTN","VPR EVNT",212, 0)
  19664    I Y="",$G (ORIFN) S  Y=$$GET1^D IQ(100,+OR IFN_",",10 ,"I")
  19665   "RTN","VPR EVNT",213, 0)
  19666    Q Y
  19667   "RTN","VPR EVNT",214, 0)
  19668    ;
  19669   "RTN","VPR EVNT",215, 0)
  19670   GMRA(ACT)  ; -- GMRA  SIGN-OFF O N DATA pro tocol list ener
  19671   "RTN","VPR EVNT",216, 0)
  19672    ;   also  GMRA ENTER ED IN ERRO R [ACT=@]
  19673   "RTN","VPR EVNT",217, 0)
  19674    N DFN,IEN
  19675   "RTN","VPR EVNT",218, 0)
  19676    S DFN=+$G (GMRAPA(0) ),IEN=+$G( GMRAPA)
  19677   "RTN","VPR EVNT",219, 0)
  19678    D POST(DF N,"allergy ",IEN,$G(A CT))
  19679   "RTN","VPR EVNT",220, 0)
  19680    Q
  19681   "RTN","VPR EVNT",221, 0)
  19682    ;
  19683   "RTN","VPR EVNT",222, 0)
  19684   GMPL(DFN,I EN) ; -- G MPL EVENT  protocol l istener
  19685   "RTN","VPR EVNT",223, 0)
  19686    S DFN=+$G (DFN),IEN= +$G(IEN)
  19687   "RTN","VPR EVNT",224, 0)
  19688    ;N ACT S  ACT=$S($P( $G(^AUPNPR OB(IEN,1)) ,U,2)="H": "@",1:"")
  19689   "RTN","VPR EVNT",225, 0)
  19690    D POST(DF N,"problem ",IEN) ;,A CT)
  19691   "RTN","VPR EVNT",226, 0)
  19692    Q
  19693   "RTN","VPR EVNT",227, 0)
  19694    ;
  19695   "RTN","VPR EVNT",228, 0)
  19696   GMRV(DFN,I EN,ERR) ;  -- Vital M easurement  file #120 .5 AVPR in dex
  19697   "RTN","VPR EVNT",229, 0)
  19698    S DFN=+$G (DFN),IEN= +$G(IEN)
  19699   "RTN","VPR EVNT",230, 0)
  19700    ;. N VPRY
  19701   "RTN","VPR EVNT",231, 0)
  19702    ;. D GETR EC^GMVUTL( .VPRY,IEN, 1) ;use Da te Taken i nstead,
  19703   "RTN","VPR EVNT",232, 0)
  19704    ;. I $G(V PRY(0)) S  IEN=+VPRY( 0) ; to ge t all rela ted result s
  19705   "RTN","VPR EVNT",233, 0)
  19706    N ACT S A CT=$S($G(E RR):"@",1: "")
  19707   "RTN","VPR EVNT",234, 0)
  19708    D POST(DF N,"vital", IEN,ACT)
  19709   "RTN","VPR EVNT",235, 0)
  19710    Q
  19711   "RTN","VPR EVNT",236, 0)
  19712    ;
  19713   "RTN","VPR EVNT",237, 0)
  19714   MDC(OBS) ;  -- CLiO O BS file #7 04.117
  19715   "RTN","VPR EVNT",238, 0)
  19716    N DFN,ID, ACT
  19717   "RTN","VPR EVNT",239, 0)
  19718    S DFN=+$G (OBS("PATI ENT_ID","I ")) Q:DFN< 1
  19719   "RTN","VPR EVNT",240, 0)
  19720    S ID=$G(O BS("OBS_ID ","I")) Q: '$L(ID)
  19721   "RTN","VPR EVNT",241, 0)
  19722    S ACT=$S( '$G(OBS("S TATUS","I" )):"@",1:" ")
  19723   "RTN","VPR EVNT",242, 0)
  19724    D POST(DF N,"obs",ID ,ACT)
  19725   "RTN","VPR EVNT",243, 0)
  19726    I $G(OBS( "DOMAIN"," VITALS"))  D POST(DFN ,"vital",I D,ACT)
  19727   "RTN","VPR EVNT",244, 0)
  19728    Q
  19729   "RTN","VPR EVNT",245, 0)
  19730    ;
  19731   "RTN","VPR EVNT",246, 0)
  19732   CP(DFN,ID, ACT) ; --  CP Transac tion file  #702 AVPR  index
  19733   "RTN","VPR EVNT",247, 0)
  19734    S DFN=+$G (DFN),ID=$ G(ID)
  19735   "RTN","VPR EVNT",248, 0)
  19736    D POST(DF N,"procedu re",ID,$G( ACT))
  19737   "RTN","VPR EVNT",249, 0)
  19738    Q
  19739   "RTN","VPR EVNT",250, 0)
  19740    ;
  19741   "RTN","VPR EVNT",251, 0)
  19742   SR(DFN,IEN ,ACT) ; --  Surgery [ SROERR] up date
  19743   "RTN","VPR EVNT",252, 0)
  19744    S DFN=+$G (DFN),IEN= +$G(IEN)
  19745   "RTN","VPR EVNT",253, 0)
  19746    D POST(DF N,"surgery ",IEN,$G(A CT))
  19747   "RTN","VPR EVNT",254, 0)
  19748    Q
  19749   "RTN","VPR EVNT",255, 0)
  19750    ;
  19751   "RTN","VPR EVNT",256, 0)
  19752   TIU(DFN,IE N) ; -- TI U Document  file #892 5 AVPR ind ex
  19753   "RTN","VPR EVNT",257, 0)
  19754    N ACT
  19755   "RTN","VPR EVNT",258, 0)
  19756    S DFN=+$G (DFN),IEN= +$G(IEN),A CT=""
  19757   "RTN","VPR EVNT",259, 0)
  19758    ; $$ISADD NDM^TIULC1 (IEN) S IE N=+$$GET1^ DIQ(8925,I EN_",",.06 ,"I")
  19759   "RTN","VPR EVNT",260, 0)
  19760    N VPRX S  VPRX=$$RES OLVE^TIUSR VLO(IEN)
  19761   "RTN","VPR EVNT",261, 0)
  19762    I $P(VPRX ,U,13),$P( $P(VPRX,U) ," ")="Add endum" S I EN=$P(VPRX ,U,13)
  19763   "RTN","VPR EVNT",262, 0)
  19764    I $P(VPRX ,U,6)="ret racted" S  ACT="@"
  19765   "RTN","VPR EVNT",263, 0)
  19766    D POST(DF N,"documen t",IEN,ACT )
  19767   "RTN","VPR EVNT",264, 0)
  19768    Q
  19769   "RTN","VPR EVNT",265, 0)
  19770    ;
  19771   "RTN","VPR EVNT",266, 0)
  19772   XU(IEN,ACT ) ; -- XU  USER ADD/C HANGE/TERM INATE opti on listene r
  19773   "RTN","VPR EVNT",267, 0)
  19774    S IEN=+$G (IEN) Q:IE N<1
  19775   "RTN","VPR EVNT",268, 0)
  19776    D POSTX(" user",IEN, $G(ACT))
  19777   "RTN","VPR EVNT",269, 0)
  19778    Q
  19779   "RTN","VPR EVNT",270, 0)
  19780    ;
  19781   "RTN","VPR EVNT",271, 0)
  19782   POST(DFN,T YPE,ID,ACT ) ; -- tra ck updated  patient d ata
  19783   "RTN","VPR EVNT",272, 0)
  19784    S DFN=+$G (DFN),TYPE =$G(TYPE), ID=$G(ID)
  19785   "RTN","VPR EVNT",273, 0)
  19786    Q:DFN<1   Q:TYPE=""   Q:ID=""   ;incomplet e request
  19787   "RTN","VPR EVNT",274, 0)
  19788    Q:$G(^XTM P("VPR-off ",TYPE))   ;domain tu rned 'off'
  19789   "RTN","VPR EVNT",275, 0)
  19790    Q:'$D(^VP R(560,"AIT EM",DFN))   ;patient  not subscr ibed to
  19791   "RTN","VPR EVNT",276, 0)
  19792    N VPRDT S  VPRDT="VP R-"_DT
  19793   "RTN","VPR EVNT",277, 0)
  19794    ;S ^XTMP( VPRDT,$$NE XT)=DFN_U_ TYPE_U_ID_ U_$G(ACT)
  19795   "RTN","VPR EVNT",278, 0)
  19796    N NODES
  19797   "RTN","VPR EVNT",279, 0)
  19798    D POST^VP RDJFS(DFN, TYPE,ID,$G (ACT),"",. NODES)
  19799   "RTN","VPR EVNT",280, 0)
  19800    Q
  19801   "RTN","VPR EVNT",281, 0)
  19802    ;
  19803   "RTN","VPR EVNT",282, 0)
  19804   POSTX(TYPE ,ID,ACT) ;  -- track  updated re ference it ems
  19805   "RTN","VPR EVNT",283, 0)
  19806    S TYPE=$G (TYPE),ID= $G(ID)
  19807   "RTN","VPR EVNT",284, 0)
  19808    Q:TYPE=""   Q:ID=""
  19809   "RTN","VPR EVNT",285, 0)
  19810    Q:$G(^XTM P("VPR-off ",TYPE))   ;domain tu rned 'off'
  19811   "RTN","VPR EVNT",286, 0)
  19812    N VPRDT S  VPRDT="VP R-"_DT ;"V PREF-"_DT
  19813   "RTN","VPR EVNT",287, 0)
  19814    ;S ^XTMP( VPRDT,$$NE XT)=U_TYPE _U_ID_U_$G (ACT)
  19815   "RTN","VPR EVNT",288, 0)
  19816    N NODES
  19817   "RTN","VPR EVNT",289, 0)
  19818    D POST^VP RDJFS("OPD ",TYPE,ID, $G(ACT),"" ,.NODES)
  19819   "RTN","VPR EVNT",290, 0)
  19820    Q
  19821   "RTN","VPR EVNT",291, 0)
  19822    ;
  19823   "RTN","VPR EVNT",292, 0)
  19824   NEXT() ; - - Return n ext sequen tial numbe r in ^XTMP (VPRDT,n)
  19825   "RTN","VPR EVNT",293, 0)
  19826    L +^XTMP( VPRDT):5 ; I'$T ??
  19827   "RTN","VPR EVNT",294, 0)
  19828    N Y S Y=+ $O(^XTMP(V PRDT,"A"), -1)+1
  19829   "RTN","VPR EVNT",295, 0)
  19830    I '$D(^XT MP(VPRDT,0 )) S ^(0)= $$FMADD^XL FDT(DT,3)_ U_DT_"^VPR  Updates"
  19831   "RTN","VPR EVNT",296, 0)
  19832    L -^XTMP( VPRDT)
  19833   "RTN","VPR EVNT",297, 0)
  19834    Q Y
  19835   "RTN","VPR EVNT",298, 0)
  19836    ;
  19837   "RTN","VPR EVNT",299, 0)
  19838   HTTP(DFN,T YPE,ID) ;  -- send me ssage that  TYPE/ID h as been up dated [not  in use]
  19839   "RTN","VPR EVNT",300, 0)
  19840    N DIV,URL ,X,VPRX
  19841   "RTN","VPR EVNT",301, 0)
  19842    S DFN=+$G (DFN) Q:DF N<1  ;pati ent req'd
  19843   "RTN","VPR EVNT",302, 0)
  19844    S DIV=$P( $$SITE^VAS ITE,U,3) ; station nu mber
  19845   "RTN","VPR EVNT",303, 0)
  19846    S URL="ht tp:// V s ID        2. DNS             :8080/vpr/ echo?divis ion="_DIV_ "&dfn="_+$ G(DFN)
  19847   "RTN","VPR EVNT",304, 0)
  19848    I $L($G(T YPE)) S UR L=URL_"&ty pe="_TYPE
  19849   "RTN","VPR EVNT",305, 0)
  19850    I $L($G(I D))   S UR L=URL_"&id ="_ID
  19851   "RTN","VPR EVNT",306, 0)
  19852    S ^XTMP(" VPR",DFN," HTTP")=$H
  19853   "RTN","VPR EVNT",307, 0)
  19854    S X=$$GET URL^XTHC10 (URL,,"VPR X")
  19855   "RTN","VPR EVNT",308, 0)
  19856    ; I X>200  = ERROR
  19857   "RTN","VPR EVNT",309, 0)
  19858    Q
  19859   "RTN","VPR FPTC")
  19860   0^12^B1444 1086
  19861   "RTN","VPR FPTC",1,0)
  19862   VPRFPTC ;S LC/MKB,AGP  - Patient  look-up U tilities a t Facility  ; 6/06/12
  19863   "RTN","VPR FPTC",2,0)
  19864    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  19865   "RTN","VPR FPTC",3,0)
  19866    ;
  19867   "RTN","VPR FPTC",4,0)
  19868   CHKS(VPRZ, DFN) ; per form patie nt select  checks
  19869   "RTN","VPR FPTC",5,0)
  19870    ;
  19871   "RTN","VPR FPTC",6,0)
  19872    N ACCESS, CHKS,CNT,E RR,I,IEN,S TR,X,VPRY
  19873   "RTN","VPR FPTC",7,0)
  19874    ; check f or sensiti ve record
  19875   "RTN","VPR FPTC",8,0)
  19876    S STR="pa tientCheck s"
  19877   "RTN","VPR FPTC",9,0)
  19878    S ACCESS= 0
  19879   "RTN","VPR FPTC",10,0 )
  19880    D PTSEC^D GSEC4(.VPR Y,DFN)  ;I A #3027
  19881   "RTN","VPR FPTC",11,0 )
  19882    S ACCESS= 1
  19883   "RTN","VPR FPTC",12,0 )
  19884    I VPRY(1) >0 D
  19885   "RTN","VPR FPTC",13,0 )
  19886    .S CHKS(" sensitive" ,"dfn")=DF N
  19887   "RTN","VPR FPTC",14,0 )
  19888    .S ACCESS =(VPRY(1)< 3)
  19889   "RTN","VPR FPTC",15,0 )
  19890    .S CHKS(" sensitive" ,"mayAcces s")=$S(ACC ESS=1:"tru e",1:"fals e")
  19891   "RTN","VPR FPTC",16,0 )
  19892    .S CHKS(" sensitive" ,"logAcces s")=$S(VPR Y(1)>1:"tr ue",1:"fal se")
  19893   "RTN","VPR FPTC",17,0 )
  19894    .S CNT=2, X=""
  19895   "RTN","VPR FPTC",18,0 )
  19896    .F  S CNT =$O(VPRY(C NT)) Q:CNT '>0  S X=X _$C(13)_$C (10)_$G(VP RY(CNT))
  19897   "RTN","VPR FPTC",19,0 )
  19898    .S CHKS(" sensitive" ,"text")=X
  19899   "RTN","VPR FPTC",20,0 )
  19900    ;
  19901   "RTN","VPR FPTC",21,0 )
  19902    ; check f or decease d patient
  19903   "RTN","VPR FPTC",22,0 )
  19904    I +$G(^DP T(DFN,.35) ) D
  19905   "RTN","VPR FPTC",23,0 )
  19906    . S CHKS( "deceased" ,"text")=" This patie nt died on  "_$$FMTE^ XLFDT(^DPT (DFN,.35), "D")_"."_$ C(13)_$C(1 0)_" Do yo u wish to  continue?"
  19907   "RTN","VPR FPTC",24,0 )
  19908    ;
  19909   "RTN","VPR FPTC",25,0 )
  19910    ; check f or similar  patients
  19911   "RTN","VPR FPTC",26,0 )
  19912    K VPRY
  19913   "RTN","VPR FPTC",27,0 )
  19914    N MSG,SIM ,SIMPAT,TE XT S MSG=0 ,SIM=0
  19915   "RTN","VPR FPTC",28,0 )
  19916    D GUIBS5A ^DPTLK6(.V PRY,DFN)   ;IA #3593
  19917   "RTN","VPR FPTC",29,0 )
  19918    I VPRY(1) >0 D
  19919   "RTN","VPR FPTC",30,0 )
  19920    .S TEXT=" "
  19921   "RTN","VPR FPTC",31,0 )
  19922    .S I=1 F   S I=$O(VP RY(I)) Q:' I  S X=VPR Y(I) D
  19923   "RTN","VPR FPTC",32,0 )
  19924    .. S SIM= SIM+1
  19925   "RTN","VPR FPTC",33,0 )
  19926    .. I $E(X )=0 S TEXT =$S($L(TEX T):TEXT_$C (13)_$C(10 )_$P(X,U,2 ),1:$P(X,U ,2))
  19927   "RTN","VPR FPTC",34,0 )
  19928    .. I $E(X )=1 D
  19929   "RTN","VPR FPTC",35,0 )
  19930    ... ;S CH KS("simila r",SIM,"df n")=$P(X,U ,2)
  19931   "RTN","VPR FPTC",36,0 )
  19932    ... ;S CH KS("simila r",SIM,"na me")=$P(X, U,3)
  19933   "RTN","VPR FPTC",37,0 )
  19934    ... ;S CH KS("simila r",SIM,"do b")=$$FMTE ^XLFDT($P( X,U,4),"D" )
  19935   "RTN","VPR FPTC",38,0 )
  19936    ... ;S CH KS("simila r",SIM,"ss n")=$P(X,U ,5)
  19937   "RTN","VPR FPTC",39,0 )
  19938    ... S SIM PAT="Patie nt Name: " _$P(X,U,3) _" Date of  Birth: "_ $$FMTE^XLF DT($P(X,U, 4),"D")_"  SSN: "_$P( X,U,5)
  19939   "RTN","VPR FPTC",40,0 )
  19940    ... S TEX T=TEXT_$C( 13)_$C(10) _SIMPAT
  19941   "RTN","VPR FPTC",41,0 )
  19942    .S CHKS(" similar"," text")=TEX T
  19943   "RTN","VPR FPTC",42,0 )
  19944    ;
  19945   "RTN","VPR FPTC",43,0 )
  19946    ; possibl y check me ans test:  GUIMTD^DPT LK6
  19947   "RTN","VPR FPTC",44,0 )
  19948    ; possibl y check le gacy data:  I $L($T(H XDATA^A7RD PAGU)...
  19949   "RTN","VPR FPTC",45,0 )
  19950    ;
  19951   "RTN","VPR FPTC",46,0 )
  19952    I ACCESS  D PRF(DFN, .CHKS)
  19953   "RTN","VPR FPTC",47,0 )
  19954    S ERR(0)= ""
  19955   "RTN","VPR FPTC",48,0 )
  19956    ;S VPR=$$ ENCODE^VPR JSON("CHKS ","ERR")
  19957   "RTN","VPR FPTC",49,0 )
  19958    D ENCODE^ VPRJSON("C HKS","VPRZ ","ERR")
  19959   "RTN","VPR FPTC",50,0 )
  19960    Q
  19961   "RTN","VPR FPTC",51,0 )
  19962    ;
  19963   "RTN","VPR FPTC",52,0 )
  19964   PRF(DFN,CH KS) ; get  Patient Re cord Flags
  19965   "RTN","VPR FPTC",53,0 )
  19966    N VPRY,ED I,PRF,N,X
  19967   "RTN","VPR FPTC",54,0 )
  19968    Q:$$GETAC T^DGPFAPI( DFN,"VPRY" )'>0
  19969   "RTN","VPR FPTC",55,0 )
  19970    S EDI=0 F   S EDI=$O (VPRY(EDI) ) Q:EDI<1   K PRF D
  19971   "RTN","VPR FPTC",56,0 )
  19972    . S CHKS( "patientRe cordFlag", EDI,"assig nmentStatu s")="Activ e"
  19973   "RTN","VPR FPTC",57,0 )
  19974    . S CHKS( "patientRe cordFlag", EDI,"assig nTS")=$$JS ONDT^VPRUT ILS($P($G( VPRY(EDI," ASSIGNDT") ),U))
  19975   "RTN","VPR FPTC",58,0 )
  19976    . S CHKS( "patientRe cordFlag", EDI,"appro ved")=$P($ G(VPRY(EDI ,"APPRVBY" )),U,2)
  19977   "RTN","VPR FPTC",59,0 )
  19978    . S CHKS( "patientRe cordFlag", EDI,"nextR eviewDT")= $$JSONDT^V PRUTILS($P ($G(VPRY(E DI,"REVIEW DT")),U))
  19979   "RTN","VPR FPTC",60,0 )
  19980    . S CHKS( "patientRe cordFlag", EDI,"name" )=$P($G(VP RY(EDI,"FL AG")),U,2)
  19981   "RTN","VPR FPTC",61,0 )
  19982    . S CHKS( "patientRe cordFlag", EDI,"type" )=$P($G(VP RY(EDI,"FL AGTYPE")), U,2)
  19983   "RTN","VPR FPTC",62,0 )
  19984    . S CHKS( "patientRe cordFlag", EDI,"categ ory")=$P($ G(VPRY(EDI ,"CATEGORY ")),U,2)
  19985   "RTN","VPR FPTC",63,0 )
  19986    . S CHKS( "patientRe cordFlag", EDI,"owner Site")=$P( $G(VPRY(ED I,"OWNER") ),U,2)
  19987   "RTN","VPR FPTC",64,0 )
  19988    . S CHKS( "patientRe cordFlag", EDI,"origi natingSite ")=$P($G(V PRY(EDI,"O RIGSITE")) ,U,2)
  19989   "RTN","VPR FPTC",65,0 )
  19990    . S N=1,X =$G(VPRY(E DI,"NARR", 1,0))
  19991   "RTN","VPR FPTC",66,0 )
  19992    . F  S N= $O(VPRY(ED I,"NARR",N )) Q:N<1   S X=X_$C(1 3)_$C(10)_ $G(VPRY(ED I,"NARR",N ,0))
  19993   "RTN","VPR FPTC",67,0 )
  19994    . S CHKS( "patientRe cordFlag", EDI,"text" )=X
  19995   "RTN","VPR FPTC",68,0 )
  19996    Q
  19997   "RTN","VPR FPTC",69,0 )
  19998    ;
  19999   "RTN","VPR FPTC",70,0 )
  20000   LOG(VPRZ,D FN) ; Make  entry in  security l og for sen sitive pat ient acces s
  20001   "RTN","VPR FPTC",71,0 )
  20002    N ERR,RES ULTS,VPRY, X
  20003   "RTN","VPR FPTC",72,0 )
  20004    D NOTICE^ DGSEC4(.VP RY,DFN) ;I A #3027
  20005   "RTN","VPR FPTC",73,0 )
  20006    S X=$S(VP RY:"ok",1: "fail")
  20007   "RTN","VPR FPTC",74,0 )
  20008    S RESULTS ("result") =X
  20009   "RTN","VPR FPTC",75,0 )
  20010    ;S VPR=$$ ENCODE^VPR JSON("RESU LTS","ERR" )
  20011   "RTN","VPR FPTC",76,0 )
  20012    D ENCODE^ VPRJSON("R ESULTS","V PRZ","ERR" )
  20013   "RTN","VPR FPTC",77,0 )
  20014    Q
  20015   "RTN","VPR FPTC",78,0 )
  20016    ;
  20017   "RTN","VPR FPTC",79,0 )
  20018   ENROS(VPRZ ,DFNARRAY)  ;PROCESS  PATIENTS F ROM A ROST ER
  20019   "RTN","VPR FPTC",80,0 )
  20020    N DFN S D FN=0
  20021   "RTN","VPR FPTC",81,0 )
  20022    F  S DFN= $O(DFNARRA Y(DFN)) Q: DFN'>0  D  CHKS(.VPRZ ,DFN)
  20023   "RTN","VPR FPTC",82,0 )
  20024    Q
  20025   "RTN","VPR FPTC",83,0 )
  20026    ;
  20027   "RTN","VPR FPTC",84,0 )
  20028   TEST ; 
  20029   "RTN","VPR FPTC",85,0 )
  20030    S EDPSITE =$$IEN^XUA F4(442),NA ME="doe,jo hn"
  20031   "RTN","VPR FPTC",86,0 )
  20032    D CHKS(1, "",NAME)
  20033   "RTN","VPR FPTC",87,0 )
  20034    ;N PID S  EDPSITE=$$ IEN^XUAF4( 442)
  20035   "RTN","VPR FPTC",88,0 )
  20036    ;R "DFN:" ,PID Q:PID =""  W !
  20037   "RTN","VPR FPTC",89,0 )
  20038    ;D CHK(1, PID,$P(^DP T(PID,0),U ))
  20039   "RTN","VPR FPTC",90,0 )
  20040    N I S I=0  F  S I=$O (EDPXML(I) ) Q:'I  W  !,EDPXML(I )
  20041   "RTN","VPR FPTC",91,0 )
  20042    K EDPXML
  20043   "RTN","VPR FPTC",92,0 )
  20044    Q
  20045   "RTN","VPR FPTC",93,0 )
  20046   TEST1 ;
  20047   "RTN","VPR FPTC",94,0 )
  20048    S EDPSITE =$$IEN^XUA F4(442),NA ME="doe,jo hn"
  20049   "RTN","VPR FPTC",95,0 )
  20050    D CHKS(1, "",NAME)
  20051   "RTN","VPR FPTC",96,0 )
  20052    ;
  20053   "RTN","VPR FPTC",97,0 )
  20054    ;DO LATER ?  -- link ed progres s notes
  20055   "RTN","VPR FPTC",98,0 )
  20056    ;D GETTIT LE^TIUPRF2 (.EDPT,DFN ,EDI),GETN OTES^TIUPR F2(.EDPN,D FN,EDPT,1)
  20057   "RTN","VPR FPTC",99,0 )
  20058    ;I $O(EDP N(0)) D
  20059   "RTN","VPR FPTC",100, 0)
  20060    ;. D XML^ EDPX("<not es>")
  20061   "RTN","VPR FPTC",101, 0)
  20062    ;. S N=0  F  S N=$O( EDPN(N)) Q :N<1  K PN  S X=EDPN( N) D
  20063   "RTN","VPR FPTC",102, 0)
  20064    ;.. S PN( "id")=+X,P N("action" )=$P(X,U,2 ),PN("auth or")=$P(X, U,4)
  20065   "RTN","VPR FPTC",103, 0)
  20066    ;.. S PN( "noteTS")= 9999999-N
  20067   "RTN","VPR FPTC",104, 0)
  20068    ;.. D TGE T^TIUSRVR1 (.EDPX,+X)
  20069   "RTN","VPR FPTC",105, 0)
  20070    ;.. S X=$ $XMLA^EDPX ("note",.P N),X=$TR(X ,"/") D XM L^EDPX(X)
  20071   "RTN","VPR FPTC",106, 0)
  20072    ;.. S I=1 ,X=$G(@EDP X@(1))
  20073   "RTN","VPR FPTC",107, 0)
  20074    ;.. F  S  I=$O(@EDPX @(I)) Q:I< 1  S X=X_$ C(13,10)_$ G(@EDPX@(I ))
  20075   "RTN","VPR FPTC",108, 0)
  20076    ;.. S X=" <text>"_$$ ESC^EDPX(X )_"</text> " D XML^ED PX(X)
  20077   "RTN","VPR FPTC",109, 0)
  20078    ;.. D XML ^EDPX("</n ote>")
  20079   "RTN","VPR FPTC",110, 0)
  20080    ;. D XML^ EDPX("</no tes>")
  20081   "RTN","VPR HTTP")
  20082   0^5^B14174 140
  20083   "RTN","VPR HTTP",1,0)
  20084   VPRHTTP ;S LC/MKB --  HTTP inter face
  20085   "RTN","VPR HTTP",2,0)
  20086    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  20087   "RTN","VPR HTTP",3,0)
  20088    ;
  20089   "RTN","VPR HTTP",4,0)
  20090    ; Externa l Referenc es           DBIA#
  20091   "RTN","VPR HTTP",5,0)
  20092    ; ------- ---------- --           -----
  20093   "RTN","VPR HTTP",6,0)
  20094    ; %ZTLOAD                         10063
  20095   "RTN","VPR HTTP",7,0)
  20096    ; DIR                             10026
  20097   "RTN","VPR HTTP",8,0)
  20098    ; VASITE                          10112
  20099   "RTN","VPR HTTP",9,0)
  20100    ; XLFCRC                           3156
  20101   "RTN","VPR HTTP",10,0 )
  20102    ; XLFUTL                           2622
  20103   "RTN","VPR HTTP",11,0 )
  20104    ; XPAR                             2263
  20105   "RTN","VPR HTTP",12,0 )
  20106    ; XTHC10                           5515
  20107   "RTN","VPR HTTP",13,0 )
  20108    ; XUPARAM                          2541
  20109   "RTN","VPR HTTP",14,0 )
  20110    ;
  20111   "RTN","VPR HTTP",15,0 )
  20112   EN ; -- ma nage the b ackground  job
  20113   "RTN","VPR HTTP",16,0 )
  20114    N ZTSK,ST S
  20115   "RTN","VPR HTTP",17,0 )
  20116    S ZTSK=+$ G(^XTMP("V PR","ZTSK" )),STS=$$S TS
  20117   "RTN","VPR HTTP",18,0 )
  20118    W !,?24," --- VPR Pa tient Data  Monitor - --"
  20119   "RTN","VPR HTTP",19,0 )
  20120    W !!,"Tas k"_$S(ZTSK :" #"_ZTSK ,1:"")_" i s "_$P(STS ,U,2)_".", !
  20121   "RTN","VPR HTTP",20,0 )
  20122    ;
  20123   "RTN","VPR HTTP",21,0 )
  20124    I ZTSK,+S TS=1!(+STS =2) D:$$ST OP  Q
  20125   "RTN","VPR HTTP",22,0 )
  20126    . N X S X =$$ASKSTOP ^%ZTLOAD(Z TSK)
  20127   "RTN","VPR HTTP",23,0 )
  20128    . W !,$P( X,U,2),!
  20129   "RTN","VPR HTTP",24,0 )
  20130    ;
  20131   "RTN","VPR HTTP",25,0 )
  20132    I $$START  D
  20133   "RTN","VPR HTTP",26,0 )
  20134    . W !!,"S tarting VP R Patient  Data Monit or ... " D  QUE
  20135   "RTN","VPR HTTP",27,0 )
  20136    . I $G(ZT SK) W "tas k #"_ZTSK_ " started. ",!
  20137   "RTN","VPR HTTP",28,0 )
  20138    . E  W !, "ERROR: ta sk NOT cre ated.  Try  again lat er.",!
  20139   "RTN","VPR HTTP",29,0 )
  20140    . S ^XTMP ("VPR","ZT SK")=$G(ZT SK)
  20141   "RTN","VPR HTTP",30,0 )
  20142    Q
  20143   "RTN","VPR HTTP",31,0 )
  20144    ;
  20145   "RTN","VPR HTTP",32,0 )
  20146   STS() ; --  get the s tatus of Z TSK
  20147   "RTN","VPR HTTP",33,0 )
  20148    D STAT^%Z TLOAD
  20149   "RTN","VPR HTTP",34,0 )
  20150    N Y S Y=+ $G(ZTSK(1) )_U_$G(ZTS K(2))
  20151   "RTN","VPR HTTP",35,0 )
  20152    Q Y
  20153   "RTN","VPR HTTP",36,0 )
  20154    ;
  20155   "RTN","VPR HTTP",37,0 )
  20156   STOP() ; - - stop the  task?
  20157   "RTN","VPR HTTP",38,0 )
  20158    N X,Y,DIR
  20159   "RTN","VPR HTTP",39,0 )
  20160    S DIR("A" )="Do you  want to st op the dat a monitor?  ",DIR(0)= "YA",DIR(" B")="NO"
  20161   "RTN","VPR HTTP",40,0 )
  20162    S DIR("?" ,1)="Enter  YES to st op or canc el the dat a monitor;  please re start ASAP !"
  20163   "RTN","VPR HTTP",41,0 )
  20164    S DIR("?" ,3)="This  job must b e running  in the bac kground fo r AViVA to  be notifi ed"
  20165   "RTN","VPR HTTP",42,0 )
  20166    S DIR("?" )="when ne w patient  data is av ailable.", DIR("?",2) ="  "
  20167   "RTN","VPR HTTP",43,0 )
  20168    D ^DIR S: Y<1 Y=0
  20169   "RTN","VPR HTTP",44,0 )
  20170    Q Y
  20171   "RTN","VPR HTTP",45,0 )
  20172    ;
  20173   "RTN","VPR HTTP",46,0 )
  20174   START() ;  -- [re]sta rt the tas k?
  20175   "RTN","VPR HTTP",47,0 )
  20176    N X,Y,DIR
  20177   "RTN","VPR HTTP",48,0 )
  20178    S DIR(0)= "YA",DIR(" B")="YES"
  20179   "RTN","VPR HTTP",49,0 )
  20180    S DIR("A" )="Do you  want to "_ $S(STS:"re ",1:"")_"s tart the d ata monito r? "
  20181   "RTN","VPR HTTP",50,0 )
  20182    S DIR("?" ,1)="Enter  YES to "_ $S(STS:"re ",1:"")_"s tart the V PR Patient  Data Moni tor."
  20183   "RTN","VPR HTTP",51,0 )
  20184    S DIR("?" ,3)="This  job must b e running  in the bac kground fo r AViVA to  be notifi ed"
  20185   "RTN","VPR HTTP",52,0 )
  20186    S DIR("?" )="when ne w patient  data is av ailable.", DIR("?",2) ="  "
  20187   "RTN","VPR HTTP",53,0 )
  20188    D ^DIR S: Y<1 Y=0
  20189   "RTN","VPR HTTP",54,0 )
  20190    Q Y
  20191   "RTN","VPR HTTP",55,0 )
  20192    ;
  20193   "RTN","VPR HTTP",56,0 )
  20194   QUE ; -- c reate the  background  task: ret urns ZTSK
  20195   "RTN","VPR HTTP",57,0 )
  20196    N IO,IOP, ZTRTN,ZTDE SC,ZTDTH,Z TIO,ZTUCI, ZTCPU,ZTPR I,ZTKIL,ZT SYNC,ZTSAV E,%ZIS
  20197   "RTN","VPR HTTP",58,0 )
  20198    S %ZIS="0 H",IOP="NU LL" D ^%ZI S I POP W  !,"Null De vice Not F ound" Q
  20199   "RTN","VPR HTTP",59,0 )
  20200    S ZTDESC= "VPR new d ata monito r for AViV A",ZTDTH=$ H,ZTIO=""
  20201   "RTN","VPR HTTP",60,0 )
  20202    S ZTRTN=" POKE^VPRHT TP" K ZTSK
  20203   "RTN","VPR HTTP",61,0 )
  20204    D ^%ZTLOA D
  20205   "RTN","VPR HTTP",62,0 )
  20206    Q
  20207   "RTN","VPR HTTP",63,0 )
  20208    ;
  20209   "RTN","VPR HTTP",64,0 )
  20210   POKE ; --  background  job to po ke the cli ent when n ew data is  available
  20211   "RTN","VPR HTTP",65,0 )
  20212    ; ^XTMP(" VPR",DFN,T YPE,ID) =  new data s ince last  update
  20213   "RTN","VPR HTTP",66,0 )
  20214    N DIV,ID, DFN,DATA,I OP,X,DA,TO KEN,NEW K  ZTSTOP
  20215   "RTN","VPR HTTP",67,0 )
  20216    S IOP="NU LL" D ^%ZI S
  20217   "RTN","VPR HTTP",68,0 )
  20218    S ID=(+$H )+$P($H,", ",2)
  20219   "RTN","VPR HTTP",69,0 )
  20220    S DFN=0 F   S DFN=$O (^XTMP("VP R",DFN)) Q :DFN<1  I  $D(^(DFN)) >9 D
  20221   "RTN","VPR HTTP",70,0 )
  20222    . L +^XTM P("VPR",DF N):5 Q:'$T   ;try aga in next cy cle
  20223   "RTN","VPR HTTP",71,0 )
  20224    . K DATA  M DATA=^XT MP("VPR",D FN)
  20225   "RTN","VPR HTTP",72,0 )
  20226    . S X=$G( ^XTMP("VPR ",DFN)) K  ^(DFN) S ^ (DFN)=X ;c lear list,  keep subs cription
  20227   "RTN","VPR HTTP",73,0 )
  20228    . L -^XTM P("VPR",DF N)
  20229   "RTN","VPR HTTP",74,0 )
  20230    . ; add t o list for  URL
  20231   "RTN","VPR HTTP",75,0 )
  20232    . S DA=0  F  S DA=$O (^VPR(560, "ADFN",DFN ,DA)) Q:DA <1  D
  20233   "RTN","VPR HTTP",76,0 )
  20234    .. S TOKE N=DA_"~"_I D,NEW(TOKE N)=""
  20235   "RTN","VPR HTTP",77,0 )
  20236    .. M ^XTM P("VPRX",T OKEN,DFN)= DATA
  20237   "RTN","VPR HTTP",78,0 )
  20238    D SEND(.N EW)
  20239   "RTN","VPR HTTP",79,0 )
  20240    I $$S^%ZT LOAD S ZTS TOP=1,ZTRE Q="@" Q
  20241   "RTN","VPR HTTP",80,0 )
  20242    D HANG S  ZTREQ="" ; re-queue
  20243   "RTN","VPR HTTP",81,0 )
  20244    Q
  20245   "RTN","VPR HTTP",82,0 )
  20246    ;
  20247   "RTN","VPR HTTP",83,0 )
  20248   SEND(LIST)  ; send ea ch list ID  to its UR L
  20249   "RTN","VPR HTTP",84,0 )
  20250    N SYS,ID, DA,URL,X
  20251   "RTN","VPR HTTP",85,0 )
  20252    S SYS=$$S YS
  20253   "RTN","VPR HTTP",86,0 )
  20254    ; DIV=$P( $$SITE^VAS ITE,U,3) ; station#
  20255   "RTN","VPR HTTP",87,0 )
  20256    S ID="" F   S ID=$O( LIST(ID))  Q:ID=""  D
  20257   "RTN","VPR HTTP",88,0 )
  20258    . S DA=+I D,URL=$G(^ VPR(560,DA ,.1)) Q:UR L=""
  20259   "RTN","VPR HTTP",89,0 )
  20260    . S URL=U RL_"?vista Id="_SYS_" &id="_ID
  20261   "RTN","VPR HTTP",90,0 )
  20262    . S X=$$G ETURL^XTHC 10(URL,,"V PRX") ;I X >200 = ERR OR
  20263   "RTN","VPR HTTP",91,0 )
  20264    Q
  20265   "RTN","VPR HTTP",92,0 )
  20266    ;
  20267   "RTN","VPR HTTP",93,0 )
  20268   SYS() ; --  return ha shed syste m name
  20269   "RTN","VPR HTTP",94,0 )
  20270    Q $$BASE^ XLFUTL($$C RC16^XLFCR C($$KSP^XU PARAM("WHE RE")),10,1 6)
  20271   "RTN","VPR HTTP",95,0 )
  20272    ;
  20273   "RTN","VPR HTTP",96,0 )
  20274   HANG ; --  wait #seco nds
  20275   "RTN","VPR HTTP",97,0 )
  20276    N X S X=$ $GET^XPAR( "ALL","VPR  TASK WAIT  TIME") S: 'X X=99
  20277   "RTN","VPR HTTP",98,0 )
  20278    H X
  20279   "RTN","VPR HTTP",99,0 )
  20280    Q
  20281   "RTN","VPR HTTP",100, 0)
  20282    ;
  20283   "RTN","VPR HTTP",101, 0)
  20284   KILL ; --  kill/reset  ^VPR(560)  for testi ng
  20285   "RTN","VPR HTTP",102, 0)
  20286    K ^VPR(56 0)
  20287   "RTN","VPR HTTP",103, 0)
  20288    S ^VPR(56 0,0)="VPR  SUBSCRIPTI ON^560^^"
  20289   "RTN","VPR HTTP",104, 0)
  20290    Q
  20291   "RTN","VPR IDX")
  20292   0^1^B14502 148
  20293   "RTN","VPR IDX",1,0)
  20294   VPRIDX ;SL C/MKB -- C reate VPR  triggers
  20295   "RTN","VPR IDX",2,0)
  20296    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  20297   "RTN","VPR IDX",3,0)
  20298    Q
  20299   "RTN","VPR IDX",4,0)
  20300    ;
  20301   "RTN","VPR IDX",5,0)
  20302   EN ; -- cr eate index  triggers
  20303   "RTN","VPR IDX",6,0)
  20304    ; GMPL                ;Problems  -- GMPL*2 *36 provid es protoco l event
  20305   "RTN","VPR IDX",7,0)
  20306    D GMRV                ;Vitals
  20307   "RTN","VPR IDX",8,0)
  20308    ; MDC                 ;CLiO      -- MD*1*3 8 provides  protocol  event
  20309   "RTN","VPR IDX",9,0)
  20310    D TIU                 ;TIU
  20311   "RTN","VPR IDX",10,0)
  20312    ;
  20313   "RTN","VPR IDX",11,0)
  20314    D EN^XPAR ("PKG.VIRT UAL PATIEN T RECORD", "VPR TASK  WAIT TIME" ,1,99)
  20315   "RTN","VPR IDX",12,0)
  20316    S ^XTMP(" VPR",0)="3 991231^311 0101^VPR P atient Dat a Monitor"
  20317   "RTN","VPR IDX",13,0)
  20318    Q
  20319   "RTN","VPR IDX",14,0)
  20320    ;
  20321   "RTN","VPR IDX",15,0)
  20322   GMPL ; --  create AVP R index on  Problem f ile #90000 11
  20323   "RTN","VPR IDX",16,0)
  20324    Q:$O(^DD( "IX","BB", 9000011,"A VPR",0))   ;exists
  20325   "RTN","VPR IDX",17,0)
  20326    N VPRX,VP RY
  20327   "RTN","VPR IDX",18,0)
  20328    S VPRX("F ILE")=9000 011,VPRX(" NAME")="AV PR"
  20329   "RTN","VPR IDX",19,0)
  20330    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  20331   "RTN","VPR IDX",20,0)
  20332    S VPRX("E XECUTION") ="R",VPRX( "ACTIVITY" )=""
  20333   "RTN","VPR IDX",21,0)
  20334    S VPRX("S HORT DESCR ")="Event  for VPR"
  20335   "RTN","VPR IDX",22,0)
  20336    S VPRX("D ESCR",1)=" This index  invokes a  VPR event  point whe n problems  are modif ied."
  20337   "RTN","VPR IDX",23,0)
  20338    S VPRX("D ESCR",2)=" No actual  cross-refe rence node s are set  or killed. "
  20339   "RTN","VPR IDX",24,0)
  20340    S VPRX("S ET")="Q:$D (DIU(0))!( $G(XDRDVAL F)=1)  D G MPL^VPREVN T(X,DA)"
  20341   "RTN","VPR IDX",25,0)
  20342    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  20343   "RTN","VPR IDX",26,0)
  20344    S VPRX("V AL",1)=.02              ;Patient
  20345   "RTN","VPR IDX",27,0)
  20346    S VPRX("V AL",2)=.03              ;Date La st Modifie d
  20347   "RTN","VPR IDX",28,0)
  20348    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  20349   "RTN","VPR IDX",29,0)
  20350    Q
  20351   "RTN","VPR IDX",30,0)
  20352    ;
  20353   "RTN","VPR IDX",31,0)
  20354   GMRV ; --  create AVP R index on  GMRV Meas urement fi le #120.5
  20355   "RTN","VPR IDX",32,0)
  20356    Q:$O(^DD( "IX","BB", 120.5,"AVP R",0))  ;u pdate
  20357   "RTN","VPR IDX",33,0)
  20358    N VPRX,VP RY
  20359   "RTN","VPR IDX",34,0)
  20360    S VPRX("F ILE")=120. 5,VPRX("NA ME")="AVPR "
  20361   "RTN","VPR IDX",35,0)
  20362    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  20363   "RTN","VPR IDX",36,0)
  20364    S VPRX("E XECUTION") ="R",VPRX( "ACTIVITY" )=""
  20365   "RTN","VPR IDX",37,0)
  20366    S VPRX("S HORT DESCR ")="Event  for VPR"
  20367   "RTN","VPR IDX",38,0)
  20368    S VPRX("D ESCR",1)=" This index  invokes a  VPR event  point whe n vitals a re modifie d."
  20369   "RTN","VPR IDX",39,0)
  20370    S VPRX("D ESCR",2)=" No actual  cross-refe rence node s are set  or killed. "
  20371   "RTN","VPR IDX",40,0)
  20372    S VPRX("S ET")="Q:$D (DIU(0))!( $G(XDRDVAL F)=1)  D G MRV^VPREVN T(X,DA,$G( X(3)))"
  20373   "RTN","VPR IDX",41,0)
  20374    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  20375   "RTN","VPR IDX",42,0)
  20376    S VPRX("V AL",1)=.02              ;Patient
  20377   "RTN","VPR IDX",43,0)
  20378    S VPRX("V AL",2)=1.2              ;Rate
  20379   "RTN","VPR IDX",44,0)
  20380    S VPRX("V AL",3)=2                ;Entered  in Error
  20381   "RTN","VPR IDX",45,0)
  20382    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  20383   "RTN","VPR IDX",46,0)
  20384    Q
  20385   "RTN","VPR IDX",47,0)
  20386    ;
  20387   "RTN","VPR IDX",48,0)
  20388   MDC ; -- c reate ASTA TUS index  on OBS fil e #704.117
  20389   "RTN","VPR IDX",49,0)
  20390    Q:$O(^DD( "IX","BB", 704.117,"A STATUS",0) )  ;exists
  20391   "RTN","VPR IDX",50,0)
  20392    N VPRX,VP RY
  20393   "RTN","VPR IDX",51,0)
  20394    S VPRX("F ILE")=704. 117,VPRX(" NAME")="AS TATUS"
  20395   "RTN","VPR IDX",52,0)
  20396    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  20397   "RTN","VPR IDX",53,0)
  20398    S VPRX("E XECUTION") ="F",VPRX( "ACTIVITY" )=""
  20399   "RTN","VPR IDX",54,0)
  20400    S VPRX("S HORT DESCR ")="Used t o trigger  MD OBSERVA TION UPDAT E protocol "
  20401   "RTN","VPR IDX",55,0)
  20402    S VPRX("D ESCR",1)=" This index  invokes t he MD OBSE RVATION UP DATE proto col when t he"
  20403   "RTN","VPR IDX",56,0)
  20404    S VPRX("D ESCR",2)=" status of  OBS data i s changed  to or from  verified. "
  20405   "RTN","VPR IDX",57,0)
  20406    S VPRX("D ESCR",3)=" No actual  cross-refe rence node s are set  or killed. "
  20407   "RTN","VPR IDX",58,0)
  20408    S VPRX("S ET")="D:(( X1=""1"")! (X2=""1"") ) PROT^MDC PROTD Q"
  20409   "RTN","VPR IDX",59,0)
  20410    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  20411   "RTN","VPR IDX",60,0)
  20412    S VPRX("V AL",1)=.09              ;Status
  20413   "RTN","VPR IDX",61,0)
  20414    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  20415   "RTN","VPR IDX",62,0)
  20416    Q
  20417   "RTN","VPR IDX",63,0)
  20418    ;
  20419   "RTN","VPR IDX",64,0)
  20420   TIU ; -- c reate AVPR  index on  TIU Docume nt file #8 925
  20421   "RTN","VPR IDX",65,0)
  20422    Q:$O(^DD( "IX","BB", 8925,"AVPR ",0))  ;ex ists
  20423   "RTN","VPR IDX",66,0)
  20424    N VPRX,VP RY
  20425   "RTN","VPR IDX",67,0)
  20426    S VPRX("F ILE")=8925 ,VPRX("NAM E")="AVPR"
  20427   "RTN","VPR IDX",68,0)
  20428    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  20429   "RTN","VPR IDX",69,0)
  20430    S VPRX("E XECUTION") ="R",VPRX( "ACTIVITY" )=""
  20431   "RTN","VPR IDX",70,0)
  20432    S VPRX("S HORT DESCR ")="Event  for VPR"
  20433   "RTN","VPR IDX",71,0)
  20434    S VPRX("D ESCR",1)=" This index  invokes a  VPR event  point whe n document s are modi fied."
  20435   "RTN","VPR IDX",72,0)
  20436    S VPRX("D ESCR",2)=" No actual  cross-refe rence node s are set  or killed. "
  20437   "RTN","VPR IDX",73,0)
  20438    S VPRX("S ET")="Q:$D (DIU(0))!( $G(XDRDVAL F)=1)  D:X (2)>5 TIU^ VPREVNT(X, DA)"
  20439   "RTN","VPR IDX",74,0)
  20440    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  20441   "RTN","VPR IDX",75,0)
  20442    S VPRX("V AL",1)=.02              ;Patient
  20443   "RTN","VPR IDX",76,0)
  20444    S VPRX("V AL",2)=.05              ;Status
  20445   "RTN","VPR IDX",77,0)
  20446    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  20447   "RTN","VPR IDX",78,0)
  20448    Q
  20449   "RTN","VPR JSON")
  20450   0^94^B1123 5996
  20451   "RTN","VPR JSON",1,0)
  20452   VPRJSON ;S LC/KCM --  Decode/Enc ode JSON ; 8/14/13  1 1:22
  20453   "RTN","VPR JSON",2,0)
  20454    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  20455   "RTN","VPR JSON",3,0)
  20456    ;
  20457   "RTN","VPR JSON",4,0)
  20458    ; Note:   Since the  routines u se closed  array refe rences, VV ROOT and V VERR
  20459   "RTN","VPR JSON",5,0)
  20460    ;         are used t o reduce r isk of nam ing confli cts on the  closed ar ray.
  20461   "RTN","VPR JSON",6,0)
  20462    ;
  20463   "RTN","VPR JSON",7,0)
  20464   DECODE(VVJ SON,VVROOT ,VVERR)  ;  Set JSON  object int o closed a rray ref V VROOT
  20465   "RTN","VPR JSON",8,0)
  20466    ; Example s: D DECOD E^VPRJSON( "MYJSON"," LOCALVAR", "LOCALERR" )
  20467   "RTN","VPR JSON",9,0)
  20468    ;            D DECOD E^VPRJSON( "^MYJSON(1 )","^GLO(9 9)","^TMP( $J)")
  20469   "RTN","VPR JSON",10,0 )
  20470    ;
  20471   "RTN","VPR JSON",11,0 )
  20472    ; VVJSON:  string/ar ray contai ning seria lized JSON  object
  20473   "RTN","VPR JSON",12,0 )
  20474    ; VVROOT:  closed ar ray refere nce for M  representa tion of ob ject
  20475   "RTN","VPR JSON",13,0 )
  20476    ;  VVERR:  contains  error mess ages, defa ults to ^T MP("VPRJER R",$J)
  20477   "RTN","VPR JSON",14,0 )
  20478    ;
  20479   "RTN","VPR JSON",15,0 )
  20480    ;   VVIDX : points t o next cha racter in  JSON strin g to proce ss
  20481   "RTN","VPR JSON",16,0 )
  20482    ; VVSTACK : manages  stack of s ubscripts
  20483   "RTN","VPR JSON",17,0 )
  20484    ;  VVPROP : true if  next strin g is prope rty name,  otherwise  treat as v alue
  20485   "RTN","VPR JSON",18,0 )
  20486    ;
  20487   "RTN","VPR JSON",19,0 )
  20488    G DIRECT^ VPRJSOND
  20489   "RTN","VPR JSON",20,0 )
  20490    ;
  20491   "RTN","VPR JSON",21,0 )
  20492   ENCODE(VVR OOT,VVJSON ,VVERR) ;  VVROOT (M  structure)  --> VVJSO N (array o f strings)
  20493   "RTN","VPR JSON",22,0 )
  20494    ; Example s:  D ENCO DE^VPRJSON ("^GLO(99, 2)","^TMP( $J)")
  20495   "RTN","VPR JSON",23,0 )
  20496    ;             D ENCO DE^VPRJSON ("LOCALVAR ","MYJSON" ,"LOCALERR ")
  20497   "RTN","VPR JSON",24,0 )
  20498    ;
  20499   "RTN","VPR JSON",25,0 )
  20500    ; VVROOT:  closed ar ray refere nce for M  representa tion of ob ject
  20501   "RTN","VPR JSON",26,0 )
  20502    ; VVJSON:  destinati on variabl e for the  string arr ay formatt ed as JSON
  20503   "RTN","VPR JSON",27,0 )
  20504    ;  VVERR:  contains  error mess ages, defa ults to ^T MP("VPRJER R",$J)
  20505   "RTN","VPR JSON",28,0 )
  20506    ;
  20507   "RTN","VPR JSON",29,0 )
  20508    G DIRECT^ VPRJSONE
  20509   "RTN","VPR JSON",30,0 )
  20510    ;
  20511   "RTN","VPR JSON",31,0 )
  20512    ;
  20513   "RTN","VPR JSON",32,0 )
  20514   ESC(X) ; E scape stri ng for JSO N
  20515   "RTN","VPR JSON",33,0 )
  20516    Q $$ESC^V PRJSONE(X)
  20517   "RTN","VPR JSON",34,0 )
  20518    ;
  20519   "RTN","VPR JSON",35,0 )
  20520   UES(X) ; U nescape JS ON string
  20521   "RTN","VPR JSON",36,0 )
  20522    Q $$UES^V PRJSOND(X)
  20523   "RTN","VPR JSON",37,0 )
  20524    ;
  20525   "RTN","VPR JSON",38,0 )
  20526   ERRX(ID,VA L) ; Set t he appropr iate error  message
  20527   "RTN","VPR JSON",39,0 )
  20528    ; switch  (ID) -- XE RRX ends s tatement
  20529   "RTN","VPR JSON",40,0 )
  20530    N ERRMSG
  20531   "RTN","VPR JSON",41,0 )
  20532    ;
  20533   "RTN","VPR JSON",42,0 )
  20534    ; Decode  Error Mess ages
  20535   "RTN","VPR JSON",43,0 )
  20536    ;
  20537   "RTN","VPR JSON",44,0 )
  20538    I ID="STL {" S ERRMS G="Stack t oo large f or new obj ect." G XE RRX
  20539   "RTN","VPR JSON",45,0 )
  20540    I ID="SUF }" S ERRMS G="Stack U nderflow -  extra } f ound" G XE RRX
  20541   "RTN","VPR JSON",46,0 )
  20542    I ID="STL [" S ERRMS G="Stack t oo large f or new arr ay." G XER RX
  20543   "RTN","VPR JSON",47,0 )
  20544    I ID="SUF ]" S ERRMS G="Stack U nderflow -  extra ] f ound." G X ERRX
  20545   "RTN","VPR JSON",48,0 )
  20546    I ID="OBM " S ERRMSG ="Array mi smatch - e xpected ]  got }." G  XERRX
  20547   "RTN","VPR JSON",49,0 )
  20548    I ID="ARM " S ERRMSG ="Object m ismatch -  expected }  got ]." G  XERRX
  20549   "RTN","VPR JSON",50,0 )
  20550    I ID="MPN " S ERRMSG ="Missing  property n ame." G XE RRX
  20551   "RTN","VPR JSON",51,0 )
  20552    I ID="EXT " S ERRMSG ="Expected  true, got  "_VAL G X ERRX
  20553   "RTN","VPR JSON",52,0 )
  20554    I ID="EXF " S ERRMSG ="Expected  false, go t "_VAL G  XERRX
  20555   "RTN","VPR JSON",53,0 )
  20556    I ID="EXN " S ERRMSG ="Expected  null, got  "_VAL G X ERRX
  20557   "RTN","VPR JSON",54,0 )
  20558    I ID="TKN " S ERRMSG ="Unable t o identify  type of t oken, valu e was "_VA L G XERRX
  20559   "RTN","VPR JSON",55,0 )
  20560    I ID="SCT " S ERRMSG ="Stack mi smatch - e xit stack  level was   "_VAL G X ERRX
  20561   "RTN","VPR JSON",56,0 )
  20562    I ID="EIQ " S ERRMSG ="Close qu ote not fo und before  end of in put." G XE RRX
  20563   "RTN","VPR JSON",57,0 )
  20564    I ID="EIU " S ERRMSG ="Unexpect ed end of  input whil e unescapi ng." G XER RX
  20565   "RTN","VPR JSON",58,0 )
  20566    I ID="RSB " S ERRMSG ="Reverse  search for  \ past be ginning of  input." G  XERRX
  20567   "RTN","VPR JSON",59,0 )
  20568    I ID="ORN " S ERRMSG ="Overrun  while scan ning name. " G XERRX
  20569   "RTN","VPR JSON",60,0 )
  20570    I ID="OR# " S ERRMSG ="Overrun  while scan ning numbe r." G XERR X
  20571   "RTN","VPR JSON",61,0 )
  20572    I ID="ORB " S ERRMSG ="Overrun  while scan ning boole an." G XER RX
  20573   "RTN","VPR JSON",62,0 )
  20574    I ID="ESC " S ERRMSG ="Escaped  character  not recogn ized"_VAL  G XERRX
  20575   "RTN","VPR JSON",63,0 )
  20576    ;
  20577   "RTN","VPR JSON",64,0 )
  20578    ; Encode  Error Mess ages
  20579   "RTN","VPR JSON",65,0 )
  20580    ;
  20581   "RTN","VPR JSON",66,0 )
  20582    I ID="SOB " S ERRMSG ="Unable t o serializ e node as  object, va lue was "_ VAL G XERR X
  20583   "RTN","VPR JSON",67,0 )
  20584    I ID="SAR " S ERRMSG ="Unable t o serializ e node as  array, val ue was "_V AL G XERRX
  20585   "RTN","VPR JSON",68,0 )
  20586    S ERRMSG= "Unspecifi ed error " _ID_" "_$G (VAL)
  20587   "RTN","VPR JSON",69,0 )
  20588   XERRX ; en d switch
  20589   "RTN","VPR JSON",70,0 )
  20590    S @VVERR@ (0)=$G(@VV ERR@(0))+1
  20591   "RTN","VPR JSON",71,0 )
  20592    S @VVERR@ (@VVERR@(0 ))=ERRMSG
  20593   "RTN","VPR JSON",72,0 )
  20594    S VVERROR S=VVERRORS +1
  20595   "RTN","VPR JSON",73,0 )
  20596    Q
  20597   "RTN","VPR JSOND")
  20598   0^95^B6876 0005
  20599   "RTN","VPR JSOND",1,0 )
  20600   VPRJSOND ; SLC/KCM --  Decode JS ON
  20601   "RTN","VPR JSOND",2,0 )
  20602    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  20603   "RTN","VPR JSOND",3,0 )
  20604    ;
  20605   "RTN","VPR JSOND",4,0 )
  20606   DECODE(VVJ SON,VVROOT ,VVERR) ;  Set JSON o bject into  closed ar ray ref VV ROOT
  20607   "RTN","VPR JSOND",5,0 )
  20608    ;
  20609   "RTN","VPR JSOND",6,0 )
  20610   DIRECT ; T AG for use  by DECODE ^VPRJSON
  20611   "RTN","VPR JSOND",7,0 )
  20612    ;
  20613   "RTN","VPR JSOND",8,0 )
  20614    ; Example s: D DECOD E^VPRJSON( "MYJSON"," LOCALVAR", "LOCALERR" )
  20615   "RTN","VPR JSOND",9,0 )
  20616    ;            D DECOD E^VPRJSON( "^MYJSON(1 )","^GLO(9 9)","^TMP( $J)")
  20617   "RTN","VPR JSOND",10, 0)
  20618    ;
  20619   "RTN","VPR JSOND",11, 0)
  20620    ; VVJSON:  string/ar ray contai ning seria lized JSON  object
  20621   "RTN","VPR JSOND",12, 0)
  20622    ; VVROOT:  closed ar ray refere nce for M  representa tion of ob ject
  20623   "RTN","VPR JSOND",13, 0)
  20624    ;  VVERR:  contains  error mess ages, defa ults to ^T MP("VPRJER R",$J)
  20625   "RTN","VPR JSOND",14, 0)
  20626    ;
  20627   "RTN","VPR JSOND",15, 0)
  20628    ;   VVIDX : points t o next cha racter in  JSON strin g to proce ss
  20629   "RTN","VPR JSOND",16, 0)
  20630    ; VVSTACK : manages  stack of s ubscripts
  20631   "RTN","VPR JSOND",17, 0)
  20632    ;  VVPROP : true if  next strin g is prope rty name,  otherwise  treat as v alue
  20633   "RTN","VPR JSOND",18, 0)
  20634    ;
  20635   "RTN","VPR JSOND",19, 0)
  20636    N VVMAX S  VVMAX=400 0 ; limit  document l ines to 40 00 charact ers
  20637   "RTN","VPR JSOND",20, 0)
  20638    S VVERR=$ G(VVERR,"^ TMP(""VPRJ ERR"",$J)" )
  20639   "RTN","VPR JSOND",21, 0)
  20640    ; If a si mple strin g is passe d in, move  it to an  temp array  (VVINPUT)
  20641   "RTN","VPR JSOND",22, 0)
  20642    ; so that  the proce ssing is c onsistentl y on an ar ray.
  20643   "RTN","VPR JSOND",23, 0)
  20644    I $D(@VVJ SON)=1 N V VINPUT S V VINPUT(1)= @VVJSON,VV JSON="VVIN PUT"
  20645   "RTN","VPR JSOND",24, 0)
  20646    S VVROOT= $NA(@VVROO T@("Z")),V VROOT=$E(V VROOT,1,$L (VVROOT)-4 ) ; make o pen array  ref
  20647   "RTN","VPR JSOND",25, 0)
  20648    N VVLINE, VVIDX,VVST ACK,VVPROP ,VVTYPE,VV ERRORS
  20649   "RTN","VPR JSOND",26, 0)
  20650    S VVLINE= $O(@VVJSON @("")),VVI DX=1,VVSTA CK=0,VVPRO P=0,VVERRO RS=0
  20651   "RTN","VPR JSOND",27, 0)
  20652    F  S VVTY PE=$$NXTKN () Q:VVTYP E=""  D  I  VVERRORS  Q
  20653   "RTN","VPR JSOND",28, 0)
  20654    . I VVTYP E="{" S VV STACK=VVST ACK+1,VVST ACK(VVSTAC K)="",VVPR OP=1 D:VVS TACK>64 ER RX("STL{")  Q
  20655   "RTN","VPR JSOND",29, 0)
  20656    . I VVTYP E="}" D  Q UIT
  20657   "RTN","VPR JSOND",30, 0)
  20658    . . I +VV STACK(VVST ACK)=VVSTA CK(VVSTACK ),VVSTACK( VVSTACK) D  ERRX("OBM ") ; Numer ic and tru e only
  20659   "RTN","VPR JSOND",31, 0)
  20660    . . S VVS TACK=VVSTA CK-1 D:VVS TACK<0 ERR X("SUF}")
  20661   "RTN","VPR JSOND",32, 0)
  20662    . I VVTYP E="[" S VV STACK=VVST ACK+1,VVST ACK(VVSTAC K)=1 D:VVS TACK>64 ER RX("STL[")  Q
  20663   "RTN","VPR JSOND",33, 0)
  20664    . I VVTYP E="]" D:'V VSTACK(VVS TACK) ERRX ("ARM") S  VVSTACK=VV STACK-1 D: VVSTACK<0  ERRX("SUF] ") Q
  20665   "RTN","VPR JSOND",34, 0)
  20666    . I VVTYP E="," D  Q
  20667   "RTN","VPR JSOND",35, 0)
  20668    . . I +VV STACK(VVST ACK)=VVSTA CK(VVSTACK ),VVSTACK( VVSTACK) S  VVSTACK(V VSTACK)=VV STACK(VVST ACK)+1  ;  VEN/SMH -  next in ar ray 
  20669   "RTN","VPR JSOND",36, 0)
  20670    . . E  S  VVPROP=1                                       ; or ne xt propert y name
  20671   "RTN","VPR JSOND",37, 0)
  20672    . I VVTYP E=":" S VV PROP=0 D:' $L($G(VVST ACK(VVSTAC K))) ERRX( "MPN") Q
  20673   "RTN","VPR JSOND",38, 0)
  20674    . I VVTYP E="""" D   Q
  20675   "RTN","VPR JSOND",39, 0)
  20676    . . I VVP ROP S VVST ACK(VVSTAC K)=$$NAMPA RS() I 1
  20677   "RTN","VPR JSOND",40, 0)
  20678    . . E  D  ADDSTR
  20679   "RTN","VPR JSOND",41, 0)
  20680    . S VVTYP E=$TR(VVTY PE,"TFN"," tfn")
  20681   "RTN","VPR JSOND",42, 0)
  20682    . I VVTYP E="t" D SE TBOOL("t")  Q
  20683   "RTN","VPR JSOND",43, 0)
  20684    . I VVTYP E="f" D SE TBOOL("f")  Q
  20685   "RTN","VPR JSOND",44, 0)
  20686    . I VVTYP E="n" D SE TBOOL("n")  Q
  20687   "RTN","VPR JSOND",45, 0)
  20688    . I "0123 456789+-.e E"[VVTYPE  D SETNUM(V VTYPE) Q   ;S @$$CURN ODE()=$$NU MPARS(VVTY PE) Q
  20689   "RTN","VPR JSOND",46, 0)
  20690    . D ERRX( "TKN",VVTY PE)
  20691   "RTN","VPR JSOND",47, 0)
  20692    I VVSTACK '=0 D ERRX ("SCT",VVS TACK)
  20693   "RTN","VPR JSOND",48, 0)
  20694    Q
  20695   "RTN","VPR JSOND",49, 0)
  20696   NXTKN() ;  Move the p ointers to  the begin ning of th e next tok en
  20697   "RTN","VPR JSOND",50, 0)
  20698    N VVDONE, VVEOF,VVTO KEN
  20699   "RTN","VPR JSOND",51, 0)
  20700    S VVDONE= 0,VVEOF=0  F  D  Q:VV DONE!VVEOF   ; eat sp aces & new  lines unt il next vi sible char
  20701   "RTN","VPR JSOND",52, 0)
  20702    . I VVIDX >$L(@VVJSO N@(VVLINE) ) S VVLINE =$O(@VVJSO N@(VVLINE) ),VVIDX=1  I 'VVLINE  S VVEOF=1  Q
  20703   "RTN","VPR JSOND",53, 0)
  20704    . I $A(@V VJSON@(VVL INE),VVIDX )>32 S VVD ONE=1 Q
  20705   "RTN","VPR JSOND",54, 0)
  20706    . S VVIDX =VVIDX+1
  20707   "RTN","VPR JSOND",55, 0)
  20708    Q:VVEOF " "  ; we're  at the en d of input
  20709   "RTN","VPR JSOND",56, 0)
  20710    S VVTOKEN =$E(@VVJSO N@(VVLINE) ,VVIDX),VV IDX=VVIDX+ 1
  20711   "RTN","VPR JSOND",57, 0)
  20712    Q VVTOKEN
  20713   "RTN","VPR JSOND",58, 0)
  20714    ;
  20715   "RTN","VPR JSOND",59, 0)
  20716   ADDSTR ; A dd string  value to c urrent nod e, escapin g text alo ng the way
  20717   "RTN","VPR JSOND",60, 0)
  20718    ; Expects  VVLINE,VV IDX to ref erence tha t starting  point of  the index
  20719   "RTN","VPR JSOND",61, 0)
  20720    ; TODO: a dd a mecha nism to sp ecify name s that sho uld not be  escaped
  20721   "RTN","VPR JSOND",62, 0)
  20722    ;       j ust store  as ":")= a nd ":",n)=
  20723   "RTN","VPR JSOND",63, 0)
  20724    ;
  20725   "RTN","VPR JSOND",64, 0)
  20726    ; Happy p ath -- we  find the e nd quote i n the same  line
  20727   "RTN","VPR JSOND",65, 0)
  20728    N VVEND,V VX
  20729   "RTN","VPR JSOND",66, 0)
  20730    S VVEND=$ F(@VVJSON@ (VVLINE)," """,VVIDX)
  20731   "RTN","VPR JSOND",67, 0)
  20732    I VVEND,( $E(@VVJSON @(VVLINE), VVEND-2)'= "\") D SET STR  QUIT   ;normal
  20733   "RTN","VPR JSOND",68, 0)
  20734    I VVEND,$ $ISCLOSEQ( VVLINE) D  SETSTR QUI T  ;close  quote prec eded by es caped \
  20735   "RTN","VPR JSOND",69, 0)
  20736    ;
  20737   "RTN","VPR JSOND",70, 0)
  20738    ; Less ha ppy path - - first qu ote wasn't  close quo te
  20739   "RTN","VPR JSOND",71, 0)
  20740    N VVDONE, VVTLINE
  20741   "RTN","VPR JSOND",72, 0)
  20742    S VVDONE= 0,VVTLINE= VVLINE ; V VTLINE for  temporary  increment  of VVLINE
  20743   "RTN","VPR JSOND",73, 0)
  20744    F  D  Q:V VDONE  Q:V VERRORS
  20745   "RTN","VPR JSOND",74, 0)
  20746    . ;if no  quote on c urrent lin e advance  line, scan  again
  20747   "RTN","VPR JSOND",75, 0)
  20748    . I 'VVEN D S VVTLIN E=VVTLINE+ 1,VVEND=1  I '$D(@VVJ SON@(VVTLI NE)) D ERR X("EIQ") Q
  20749   "RTN","VPR JSOND",76, 0)
  20750    . S VVEND =$F(@VVJSO N@(VVTLINE ),"""",VVE ND)
  20751   "RTN","VPR JSOND",77, 0)
  20752    . Q:'VVEN D  ; conti nue on to  next line  if no quot e found on  this one
  20753   "RTN","VPR JSOND",78, 0)
  20754    . I (VVEN D>2),($E(@ VVJSON@(VV TLINE),VVE ND-2)'="\" ) S VVDONE =1 Q  ; fo und quote  position
  20755   "RTN","VPR JSOND",79, 0)
  20756    . S VVDON E=$$ISCLOS EQ(VVTLINE ) ; see if  this is a n escaped  quote or c losing quo te
  20757   "RTN","VPR JSOND",80, 0)
  20758    Q:VVERROR S
  20759   "RTN","VPR JSOND",81, 0)
  20760    ; unescap e from VVI DX to VVEN D, using \ -extension  nodes as  necessary
  20761   "RTN","VPR JSOND",82, 0)
  20762    D UESEXT
  20763   "RTN","VPR JSOND",83, 0)
  20764    ; now we  need to mo ve VVLINE  and VVIDX  to next pa rsing poin t
  20765   "RTN","VPR JSOND",84, 0)
  20766    S VVLINE= VVTLINE,VV IDX=VVEND
  20767   "RTN","VPR JSOND",85, 0)
  20768    Q
  20769   "RTN","VPR JSOND",86, 0)
  20770   SETSTR ; S et simple  string val ue from wi thin same  line
  20771   "RTN","VPR JSOND",87, 0)
  20772    ; expects  VVJSON, V VLINE, VVI NX, VVEND
  20773   "RTN","VPR JSOND",88, 0)
  20774    N VVX
  20775   "RTN","VPR JSOND",89, 0)
  20776    S VVX=$E( @VVJSON@(V VLINE),VVI DX,VVEND-2 ),VVIDX=VV END
  20777   "RTN","VPR JSOND",90, 0)
  20778    S @$$CURN ODE()=$$UE S(VVX)
  20779   "RTN","VPR JSOND",91, 0)
  20780    I VVX']]$ C(1) S @$$ CURNODE()@ ("\s")=""  ; indicate  string si nce collat es as nume ric
  20781   "RTN","VPR JSOND",92, 0)
  20782    I VVIDX>$ L(@VVJSON@ (VVLINE))  S VVLINE=V VLINE+1,VV IDX=1
  20783   "RTN","VPR JSOND",93, 0)
  20784    Q
  20785   "RTN","VPR JSOND",94, 0)
  20786   UESEXT ; u nescape fr om VVLINE, VVIDX to V VTLINE,VVE ND & exten d (\) if n ecessary
  20787   "RTN","VPR JSOND",95, 0)
  20788    ; expects  VVLINE,VV IDX,VVTLIN E,VVEND
  20789   "RTN","VPR JSOND",96, 0)
  20790    N VVI,VVY ,VVSTART,V VSTOP,VVDO NE,VVBUF,V VNODE,VVMO RE,VVTO
  20791   "RTN","VPR JSOND",97, 0)
  20792    S VVNODE= $$CURNODE( ),VVBUF="" ,VVMORE=0, VVSTOP=VVE ND-2
  20793   "RTN","VPR JSOND",98, 0)
  20794    S VVI=VVI DX,VVY=VVL INE,VVDONE =0
  20795   "RTN","VPR JSOND",99, 0)
  20796    F  D  Q:V VDONE  Q:V VERRORS
  20797   "RTN","VPR JSOND",100 ,0)
  20798    . S VVSTA RT=VVI,VVI =$F(@VVJSO N@(VVY),"\ ",VVI)
  20799   "RTN","VPR JSOND",101 ,0)
  20800    . ; if we  are on th e last lin e, don't e xtract pas t VVSTOP
  20801   "RTN","VPR JSOND",102 ,0)
  20802    . I (VVY= VVTLINE) S  VVTO=$S(' VVI:VVSTOP ,VVI>VVSTO P:VVSTOP,1 :VVI-2) I  1
  20803   "RTN","VPR JSOND",103 ,0)
  20804    . E  S VV TO=$S('VVI :99999,1:V VI-2)
  20805   "RTN","VPR JSOND",104 ,0)
  20806    . D ADDBU F($E(@VVJS ON@(VVY),V VSTART,VVT O))
  20807   "RTN","VPR JSOND",105 ,0)
  20808    . I (VVY' <VVTLINE), (('VVI)!(V VI>VVSTOP) ) S VVDONE =1 QUIT  ;  now past  close quot e
  20809   "RTN","VPR JSOND",106 ,0)
  20810    . I 'VVI  S VVY=VVY+ 1,VVI=1 QU IT  ; noth ing escape d, go to n ext line
  20811   "RTN","VPR JSOND",107 ,0)
  20812    . I VVI>$ L(@VVJSON@ (VVY)) S V VY=VVY+1,V VI=1 I '$D (@VVJSON@( VVY)) D ER RX("EIU")
  20813   "RTN","VPR JSOND",108 ,0)
  20814    . N VVTGT  S VVTGT=$ E(@VVJSON@ (VVY),VVI)
  20815   "RTN","VPR JSOND",109 ,0)
  20816    . I VVTGT ="u" D  I  1
  20817   "RTN","VPR JSOND",110 ,0)
  20818    . . N VVT GTC S VVTG TC=$E(@VVJ SON@(VVY), VVI+1,VVI+ 4),VVI=VVI +4
  20819   "RTN","VPR JSOND",111 ,0)
  20820    . . I $L( VVTGTC)<4  S VVY=VVY+ 1,VVI=4-$L (VVTGTC),V VTGTC=VVTG TC_$E(@VVJ SON@(VVY), 1,VVI)
  20821   "RTN","VPR JSOND",112 ,0)
  20822    . . D ADD BUF($C($$D EC^XLFUTL( VVTGTC,16) ))
  20823   "RTN","VPR JSOND",113 ,0)
  20824    . E  D AD DBUF($$REA LCHAR(VVTG T))
  20825   "RTN","VPR JSOND",114 ,0)
  20826    . S VVI=V VI+1
  20827   "RTN","VPR JSOND",115 ,0)
  20828    . I (VVY' <VVTLINE), (VVI>VVSTO P) S VVDON E=1 ; VVI  incremente d past sto p
  20829   "RTN","VPR JSOND",116 ,0)
  20830    Q:VVERROR S
  20831   "RTN","VPR JSOND",117 ,0)
  20832    D SAVEBUF
  20833   "RTN","VPR JSOND",118 ,0)
  20834    Q
  20835   "RTN","VPR JSOND",119 ,0)
  20836   ADDBUF(VVX ) ; add bu ffer of ch aracters t o destinat ion
  20837   "RTN","VPR JSOND",120 ,0)
  20838    ; expects  VVBUF,VVM AX,VVNODE, VVMORE to  be defined
  20839   "RTN","VPR JSOND",121 ,0)
  20840    ; used di rectly by  ADDSTR
  20841   "RTN","VPR JSOND",122 ,0)
  20842    I $L(VVX) +$L(VVBUF) >VVMAX D S AVEBUF
  20843   "RTN","VPR JSOND",123 ,0)
  20844    S VVBUF=V VBUF_VVX
  20845   "RTN","VPR JSOND",124 ,0)
  20846    Q
  20847   "RTN","VPR JSOND",125 ,0)
  20848   SAVEBUF ;  write out  buffer to  destinatio n
  20849   "RTN","VPR JSOND",126 ,0)
  20850    ; expects  VVBUF,VVM AX,VVNODE, VVMORE to  be defined
  20851   "RTN","VPR JSOND",127 ,0)
  20852    ; used di rectly by  ADDSTR,ADD BUF
  20853   "RTN","VPR JSOND",128 ,0)
  20854    I VVMORE  S @VVNODE@ ("\",VVMOR E)=VVBUF
  20855   "RTN","VPR JSOND",129 ,0)
  20856    I 'VVMORE  S @VVNODE =VVBUF I $ L(VVBUF)<1 9,+$E(VVBU F,1,18) S  @VVNODE@(" \s")=""
  20857   "RTN","VPR JSOND",130 ,0)
  20858    S VVMORE= VVMORE+1,V VBUF=""
  20859   "RTN","VPR JSOND",131 ,0)
  20860    Q
  20861   "RTN","VPR JSOND",132 ,0)
  20862   ISCLOSEQ(V VBLINE) ;  return tru e if this  is a closi ng, rather  than esca ped, quote
  20863   "RTN","VPR JSOND",133 ,0)
  20864    ; expects
  20865   "RTN","VPR JSOND",134 ,0)
  20866    ;   VVJSO N: lines o f the JSON  encoded s tring
  20867   "RTN","VPR JSOND",135 ,0)
  20868    ;    VVID X: points  to 1st cha racter of  the segmen t
  20869   "RTN","VPR JSOND",136 ,0)
  20870    ;   VVLIN E: points  to the lin e in which  the segme nt starts
  20871   "RTN","VPR JSOND",137 ,0)
  20872    ;    VVEN D: points  to 1st cha racter aft er the " ( may be pas t the end  of the lin e)
  20873   "RTN","VPR JSOND",138 ,0)
  20874    ; used di rectly by  ADDSTR
  20875   "RTN","VPR JSOND",139 ,0)
  20876    N VVBS,VV BIDX,VVBDO NE
  20877   "RTN","VPR JSOND",140 ,0)
  20878    S VVBS=0, VVBIDX=VVE ND-2,VVBDO NE=0 ; VVB IDX starts  at 1st ch aracter be fore quote
  20879   "RTN","VPR JSOND",141 ,0)
  20880    ; count t he backsla shes prece ding the q uote (odd  number mea ns the quo te was esc aped)
  20881   "RTN","VPR JSOND",142 ,0)
  20882    F  D  Q:V VBDONE!VVE RRORS
  20883   "RTN","VPR JSOND",143 ,0)
  20884    . I VVBID X<1 D  Q   ; when VVB IDX<1 go b ack a line
  20885   "RTN","VPR JSOND",144 ,0)
  20886    . . S VVB LINE=VVBLI NE-1 I VVB LINE<VVLIN E D ERRX(" RSB") Q
  20887   "RTN","VPR JSOND",145 ,0)
  20888    . . S VVB IDX=$L(@VV JSON@(VVBL INE))
  20889   "RTN","VPR JSOND",146 ,0)
  20890    . I $E(@V VJSON@(VVB LINE),VVBI DX)'="\" S  VVBDONE=1  Q
  20891   "RTN","VPR JSOND",147 ,0)
  20892    . S VVBS= VVBS+1,VVB IDX=VVBIDX -1
  20893   "RTN","VPR JSOND",148 ,0)
  20894    Q VVBS#2= 0  ; VVBS  is even if  this is a  close quo te
  20895   "RTN","VPR JSOND",149 ,0)
  20896    ;
  20897   "RTN","VPR JSOND",150 ,0)
  20898   NAMPARS()  ; Return p arsed name , advancin g index pa st the clo se quote
  20899   "RTN","VPR JSOND",151 ,0)
  20900    ; -- This  assumes n o embedded  quotes ar e in the n ame itself  --
  20901   "RTN","VPR JSOND",152 ,0)
  20902    N VVEND,V VDONE,VVNA ME
  20903   "RTN","VPR JSOND",153 ,0)
  20904    S VVDONE= 0,VVNAME=" "
  20905   "RTN","VPR JSOND",154 ,0)
  20906    F  D  Q:V VDONE  Q:V VERRORS
  20907   "RTN","VPR JSOND",155 ,0)
  20908    . S VVEND =$F(@VVJSO N@(VVLINE) ,"""",VVID X)
  20909   "RTN","VPR JSOND",156 ,0)
  20910    . I VVEND  S VVNAME= VVNAME_$E( @VVJSON@(V VLINE),VVI DX,VVEND-2 ),VVIDX=VV END,VVDONE =1
  20911   "RTN","VPR JSOND",157 ,0)
  20912    . I 'VVEN D S VVNAME =VVNAME_$E (@VVJSON@( VVLINE),VV IDX,$L(@VV JSON@(VVLI NE)))
  20913   "RTN","VPR JSOND",158 ,0)
  20914    . I 'VVEN D!(VVEND>$ L(@VVJSON@ (VVLINE)))  S VVLINE= VVLINE+1,V VIDX=1 I ' $D(@VVJSON @(VVLINE))  D ERRX("O RN")
  20915   "RTN","VPR JSOND",159 ,0)
  20916    Q VVNAME
  20917   "RTN","VPR JSOND",160 ,0)
  20918    ;
  20919   "RTN","VPR JSOND",161 ,0)
  20920   SETNUM(VVD IGIT) ; Se t numeric  along with  any neces sary modif ier
  20921   "RTN","VPR JSOND",162 ,0)
  20922    N VVX
  20923   "RTN","VPR JSOND",163 ,0)
  20924    S VVX=$$N UMPARS(VVD IGIT)
  20925   "RTN","VPR JSOND",164 ,0)
  20926    S @$$CURN ODE()=+VVX
  20927   "RTN","VPR JSOND",165 ,0)
  20928    ; if nume ric is exp onent, "0. nnn" or "- 0.nnn" sto re origina l string
  20929   "RTN","VPR JSOND",166 ,0)
  20930    I +VVX'=V VX S @$$CU RNODE()@(" \n")=VVX
  20931   "RTN","VPR JSOND",167 ,0)
  20932    Q
  20933   "RTN","VPR JSOND",168 ,0)
  20934   NUMPARS(VV DIGIT) ; R eturn pars ed number,  advancing  index pas t end of n umber
  20935   "RTN","VPR JSOND",169 ,0)
  20936    ; VVIDX i ntially re ferences t he second  digit
  20937   "RTN","VPR JSOND",170 ,0)
  20938    N VVDONE, VVNUM
  20939   "RTN","VPR JSOND",171 ,0)
  20940    S VVDONE= 0,VVNUM=VV DIGIT
  20941   "RTN","VPR JSOND",172 ,0)
  20942    F  D  Q:V VDONE  Q:V VERRORS
  20943   "RTN","VPR JSOND",173 ,0)
  20944    . I '("01 23456789+- .eE"[$E(@V VJSON@(VVL INE),VVIDX )) S VVDON E=1 Q
  20945   "RTN","VPR JSOND",174 ,0)
  20946    . S VVNUM =VVNUM_$E( @VVJSON@(V VLINE),VVI DX)
  20947   "RTN","VPR JSOND",175 ,0)
  20948    . S VVIDX =VVIDX+1 I  VVIDX>$L( @VVJSON@(V VLINE)) S  VVLINE=VVL INE+1,VVID X=1 I '$D( @VVJSON@(V VLINE)) D  ERRX("OR#" )
  20949   "RTN","VPR JSOND",176 ,0)
  20950    Q VVNUM
  20951   "RTN","VPR JSOND",177 ,0)
  20952    ;
  20953   "RTN","VPR JSOND",178 ,0)
  20954   SETBOOL(VV LTR) ; Par se and set  boolean v alue, adva ncing inde x past end  of value
  20955   "RTN","VPR JSOND",179 ,0)
  20956    N VVDONE, VVBOOL,VVX
  20957   "RTN","VPR JSOND",180 ,0)
  20958    S VVDONE= 0,VVBOOL=V VLTR
  20959   "RTN","VPR JSOND",181 ,0)
  20960    F  D  Q:V VDONE  Q:V VERRORS
  20961   "RTN","VPR JSOND",182 ,0)
  20962    . S VVX=$ TR($E(@VVJ SON@(VVLIN E),VVIDX), "TRUEFALSN ","truefal sn")
  20963   "RTN","VPR JSOND",183 ,0)
  20964    . I '("tr uefalsn"[V VX) S VVDO NE=1 Q
  20965   "RTN","VPR JSOND",184 ,0)
  20966    . S VVBOO L=VVBOOL_V VX
  20967   "RTN","VPR JSOND",185 ,0)
  20968    . S VVIDX =VVIDX+1 I  VVIDX>$L( @VVJSON@(V VLINE)) S  VVLINE=VVL INE+1,VVID X=1 I '$D( @VVJSON@(V VLINE)) D  ERRX("ORB" )
  20969   "RTN","VPR JSOND",186 ,0)
  20970    I VVLTR=" t",(VVBOOL '="true")  D ERRX("EX T",VVTYPE)
  20971   "RTN","VPR JSOND",187 ,0)
  20972    I VVLTR=" f",(VVBOOL '="false")  D ERRX("E XF",VVTYPE )
  20973   "RTN","VPR JSOND",188 ,0)
  20974    I VVLTR=" n",(VVBOOL '="null")  D ERRX("EX N",VVTYPE)
  20975   "RTN","VPR JSOND",189 ,0)
  20976    S @$$CURN ODE()=VVBO OL
  20977   "RTN","VPR JSOND",190 ,0)
  20978    Q
  20979   "RTN","VPR JSOND",191 ,0)
  20980    ;
  20981   "RTN","VPR JSOND",192 ,0)
  20982   OSETBOOL(V VX) ; set  a value an d incremen t VVIDX
  20983   "RTN","VPR JSOND",193 ,0)
  20984    S @$$CURN ODE()=VVX
  20985   "RTN","VPR JSOND",194 ,0)
  20986    S VVIDX=V VIDX+$L(VV X)-1
  20987   "RTN","VPR JSOND",195 ,0)
  20988    N VVDIFF  S VVDIFF=V VIDX-$L(@V VJSON@(VVL INE))  ; i n case VVI DX moves t o next lin e
  20989   "RTN","VPR JSOND",196 ,0)
  20990    I VVDIFF> 0 S VVLINE =VVLINE+1, VVIDX=VVDI FF I '$D(@ VVJSON@(VV LINE)) D E RRX("ORB")
  20991   "RTN","VPR JSOND",197 ,0)
  20992    Q
  20993   "RTN","VPR JSOND",198 ,0)
  20994   CURNODE()  ; Return a  global/lo cal variab le name ba sed on VVS TACK
  20995   "RTN","VPR JSOND",199 ,0)
  20996    ; Expects  VVSTACK t o be defin ed already
  20997   "RTN","VPR JSOND",200 ,0)
  20998    N VVI,VVS UBS
  20999   "RTN","VPR JSOND",201 ,0)
  21000    S VVSUBS= ""
  21001   "RTN","VPR JSOND",202 ,0)
  21002    F VVI=1:1 :VVSTACK S :VVI>1 VVS UBS=VVSUBS _"," D
  21003   "RTN","VPR JSOND",203 ,0)
  21004    . I VVSTA CK(VVI)=+V VSTACK(VVI ) S VVSUBS =VVSUBS_VV STACK(VVI)  ; VEN/SMH  Fix psudo  array bug .
  21005   "RTN","VPR JSOND",204 ,0)
  21006    . E  S VV SUBS=VVSUB S_""""_VVS TACK(VVI)_ """"
  21007   "RTN","VPR JSOND",205 ,0)
  21008    Q VVROOT_ VVSUBS_")"
  21009   "RTN","VPR JSOND",206 ,0)
  21010    ;
  21011   "RTN","VPR JSOND",207 ,0)
  21012   UES(X) ; U nescape JS ON string
  21013   "RTN","VPR JSOND",208 ,0)
  21014    ; copy se gments fro m START to  POS-2 (ri ght before  \)
  21015   "RTN","VPR JSOND",209 ,0)
  21016    ; transla te target  character  (which is  at $F posi tion)
  21017   "RTN","VPR JSOND",210 ,0)
  21018    N POS,Y,S TART
  21019   "RTN","VPR JSOND",211 ,0)
  21020    S POS=0,Y =""
  21021   "RTN","VPR JSOND",212 ,0)
  21022    F  S STAR T=POS+1 D   Q:START>$ L(X)
  21023   "RTN","VPR JSOND",213 ,0)
  21024    . S POS=$ F(X,"\",ST ART) ; fin d next pos ition
  21025   "RTN","VPR JSOND",214 ,0)
  21026    . I 'POS  S Y=Y_$E(X ,START,$L( X)),POS=$L (X) Q
  21027   "RTN","VPR JSOND",215 ,0)
  21028    . ; other wise handl e escaped  char
  21029   "RTN","VPR JSOND",216 ,0)
  21030    . N TGT
  21031   "RTN","VPR JSOND",217 ,0)
  21032    . S TGT=$ E(X,POS),Y =Y_$E(X,ST ART,POS-2)
  21033   "RTN","VPR JSOND",218 ,0)
  21034    . I TGT=" u" S Y=Y_$ C($$DEC^XL FUTL($E(X, POS+1,POS+ 4),16)),PO S=POS+4 Q
  21035   "RTN","VPR JSOND",219 ,0)
  21036    . S Y=Y_$ $REALCHAR( TGT)
  21037   "RTN","VPR JSOND",220 ,0)
  21038    Q Y
  21039   "RTN","VPR JSOND",221 ,0)
  21040    ;
  21041   "RTN","VPR JSOND",222 ,0)
  21042   REALCHAR(C ) ; Return  actual ch aracter fr om escaped
  21043   "RTN","VPR JSOND",223 ,0)
  21044    I C=""""  Q """"
  21045   "RTN","VPR JSOND",224 ,0)
  21046    I C="/" Q  "/"
  21047   "RTN","VPR JSOND",225 ,0)
  21048    I C="\" Q  "\"
  21049   "RTN","VPR JSOND",226 ,0)
  21050    I C="b" Q  $C(8)
  21051   "RTN","VPR JSOND",227 ,0)
  21052    I C="f" Q  $C(12)
  21053   "RTN","VPR JSOND",228 ,0)
  21054    I C="n" Q  $C(10)
  21055   "RTN","VPR JSOND",229 ,0)
  21056    I C="r" Q  $C(13)
  21057   "RTN","VPR JSOND",230 ,0)
  21058    I C="t" Q  $C(9)
  21059   "RTN","VPR JSOND",231 ,0)
  21060    I C="u" ; case cover ed above i n $$DEC^XL FUTL calls
  21061   "RTN","VPR JSOND",232 ,0)
  21062    ;otherwis e
  21063   "RTN","VPR JSOND",233 ,0)
  21064    I $L($G(V VERR)) D E RRX("ESC", C)
  21065   "RTN","VPR JSOND",234 ,0)
  21066    Q C
  21067   "RTN","VPR JSOND",235 ,0)
  21068    ;
  21069   "RTN","VPR JSOND",236 ,0)
  21070   ERRX(ID,VA L) ; Set t he appropr iate error  message
  21071   "RTN","VPR JSOND",237 ,0)
  21072    D ERRX^VP RJSON(ID,$ G(VAL))
  21073   "RTN","VPR JSOND",238 ,0)
  21074    Q
  21075   "RTN","VPR JSONE")
  21076   0^96^B2251 8467
  21077   "RTN","VPR JSONE",1,0 )
  21078   VPRJSONE ; SLC/KCM --  Encode JS ON
  21079   "RTN","VPR JSONE",2,0 )
  21080    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  21081   "RTN","VPR JSONE",3,0 )
  21082    ;
  21083   "RTN","VPR JSONE",4,0 )
  21084   ENCODE(VVR OOT,VVJSON ,VVERR) ;  VVROOT (M  structure)  --> VVJSO N (array o f strings)
  21085   "RTN","VPR JSONE",5,0 )
  21086    ;
  21087   "RTN","VPR JSONE",6,0 )
  21088   DIRECT ; T AG for use  by ENCODE ^VPRJSON
  21089   "RTN","VPR JSONE",7,0 )
  21090    ;
  21091   "RTN","VPR JSONE",8,0 )
  21092    ; Example s:  D ENCO DE^VPRJSON ("^GLO(99, 2)","^TMP( $J)")
  21093   "RTN","VPR JSONE",9,0 )
  21094    ;             D ENCO DE^VPRJSON ("LOCALVAR ","MYJSON" ,"LOCALERR ")
  21095   "RTN","VPR JSONE",10, 0)
  21096    ;
  21097   "RTN","VPR JSONE",11, 0)
  21098    ; VVROOT:  closed ar ray refere nce for M  representa tion of ob ject
  21099   "RTN","VPR JSONE",12, 0)
  21100    ; VVJSON:  destinati on variabl e for the  string arr ay formatt ed as JSON
  21101   "RTN","VPR JSONE",13, 0)
  21102    ;  VVERR:  contains  error mess ages, defa ults to ^T MP("VPRJER R",$J)
  21103   "RTN","VPR JSONE",14, 0)
  21104    ;
  21105   "RTN","VPR JSONE",15, 0)
  21106    S VVERR=$ G(VVERR,"^ TMP(""VPRJ ERR"",$J)" )
  21107   "RTN","VPR JSONE",16, 0)
  21108    I '$L($G( VVROOT)) ;  set error  info
  21109   "RTN","VPR JSONE",17, 0)
  21110    I '$L($G( VVJSON)) ;  set error  info
  21111   "RTN","VPR JSONE",18, 0)
  21112    N VVLINE, VVMAX,VVER RORS
  21113   "RTN","VPR JSONE",19, 0)
  21114    S VVLINE= 1,VVMAX=40 00,VVERROR S=0  ; 96  more bytes  of wiggle  room
  21115   "RTN","VPR JSONE",20, 0)
  21116    S @VVJSON @(VVLINE)= ""
  21117   "RTN","VPR JSONE",21, 0)
  21118    D SEROBJ( VVROOT)
  21119   "RTN","VPR JSONE",22, 0)
  21120    Q
  21121   "RTN","VPR JSONE",23, 0)
  21122    ;
  21123   "RTN","VPR JSONE",24, 0)
  21124   SEROBJ(VVR OOT) ; Ser ialize int o a JSON o bject
  21125   "RTN","VPR JSONE",25, 0)
  21126    N VVFIRST ,VVSUB,VVN XT
  21127   "RTN","VPR JSONE",26, 0)
  21128    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_"{"
  21129   "RTN","VPR JSONE",27, 0)
  21130    S VVFIRST =1
  21131   "RTN","VPR JSONE",28, 0)
  21132    S VVSUB=" " F  S VVS UB=$O(@VVR OOT@(VVSUB )) Q:VVSUB =""  D
  21133   "RTN","VPR JSONE",29, 0)
  21134    . S:'VVFI RST @VVJSO N@(VVLINE) =@VVJSON@( VVLINE)_", " S VVFIRS T=0
  21135   "RTN","VPR JSONE",30, 0)
  21136    . ; get t he name pa rt
  21137   "RTN","VPR JSONE",31, 0)
  21138    . D SERNA ME(VVSUB)
  21139   "RTN","VPR JSONE",32, 0)
  21140    . ; if th is is a va lue, seria lize it
  21141   "RTN","VPR JSONE",33, 0)
  21142    . I $$ISV ALUE(VVROO T,VVSUB) D  SERVAL(VV ROOT,VVSUB ) Q
  21143   "RTN","VPR JSONE",34, 0)
  21144    . ; other wise navig ate to the  next chil d object o r array
  21145   "RTN","VPR JSONE",35, 0)
  21146    . I $D(@V VROOT@(VVS UB))=10 S  VVNXT=$O(@ VVROOT@(VV SUB,"")) D   Q
  21147   "RTN","VPR JSONE",36, 0)
  21148    . . I +VV NXT D SERA RY($NA(@VV ROOT@(VVSU B))) I 1
  21149   "RTN","VPR JSONE",37, 0)
  21150    . . E  D  SEROBJ($NA (@VVROOT@( VVSUB)))
  21151   "RTN","VPR JSONE",38, 0)
  21152    . D ERRX( "SOB",VVSU B)  ; shou ld quit lo op before  here
  21153   "RTN","VPR JSONE",39, 0)
  21154    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_"}"
  21155   "RTN","VPR JSONE",40, 0)
  21156    Q
  21157   "RTN","VPR JSONE",41, 0)
  21158   SERARY(VVR OOT) ; Ser ialize int o a JSON a rray
  21159   "RTN","VPR JSONE",42, 0)
  21160    N VVFIRST ,VVI,VVNXT
  21161   "RTN","VPR JSONE",43, 0)
  21162    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_"["
  21163   "RTN","VPR JSONE",44, 0)
  21164    S VVFIRST =1
  21165   "RTN","VPR JSONE",45, 0)
  21166    S VVI=0 F   S VVI=$O (@VVROOT@( VVI)) Q:'V VI  D
  21167   "RTN","VPR JSONE",46, 0)
  21168    . S:'VVFI RST @VVJSO N@(VVLINE) =@VVJSON@( VVLINE)_", " S VVFIRS T=0
  21169   "RTN","VPR JSONE",47, 0)
  21170    . I $$ISV ALUE(VVROO T,VVI) D S ERVAL(VVRO OT,VVI) Q   ; write v alue
  21171   "RTN","VPR JSONE",48, 0)
  21172    . I $D(@V VROOT@(VVI ))=10 S VV NXT=$O(@VV ROOT@(VVI, "")) D  Q
  21173   "RTN","VPR JSONE",49, 0)
  21174    . . I +VV NXT D SERA RY($NA(@VV ROOT@(VVI) )) I 1
  21175   "RTN","VPR JSONE",50, 0)
  21176    . . E  D  SEROBJ($NA (@VVROOT@( VVI)))
  21177   "RTN","VPR JSONE",51, 0)
  21178    . D ERRX( "SAR",VVI)   ; should  quit loop  before he re
  21179   "RTN","VPR JSONE",52, 0)
  21180    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_"]"
  21181   "RTN","VPR JSONE",53, 0)
  21182    Q
  21183   "RTN","VPR JSONE",54, 0)
  21184   SERNAME(VV SUB) ; Ser ialize the  object na me into JS ON string
  21185   "RTN","VPR JSONE",55, 0)
  21186    I ($L(VVS UB)+$L(@VV JSON@(VVLI NE)))>VVMA X S VVLINE =VVLINE+1, @VVJSON@(V VLINE)=""
  21187   "RTN","VPR JSONE",56, 0)
  21188    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_""" "_VVSUB_"" ""_":"
  21189   "RTN","VPR JSONE",57, 0)
  21190    Q
  21191   "RTN","VPR JSONE",58, 0)
  21192   SERVAL(VVR OOT,VVSUB)  ; Seriali ze X into  appropriat e JSON rep resentatio n
  21193   "RTN","VPR JSONE",59, 0)
  21194    N VVX,VVI
  21195   "RTN","VPR JSONE",60, 0)
  21196    ; if the  node is al ready in J SON format , just add  it
  21197   "RTN","VPR JSONE",61, 0)
  21198    I $D(@VVR OOT@(VVSUB ,":")) D   QUIT  ; <- - jump out  here if p reformatte d
  21199   "RTN","VPR JSONE",62, 0)
  21200    . S VVX=$ G(@VVROOT@ (VVSUB,":" )) D:$L(VV X) CONCAT
  21201   "RTN","VPR JSONE",63, 0)
  21202    . S VVI=0  F  S VVI= $O(@VVROOT @(VVSUB,": ",VVI)) Q: 'VVI  S VV X=@VVROOT@ (VVSUB,":" ,VVI) D CO NCAT
  21203   "RTN","VPR JSONE",64, 0)
  21204    ;
  21205   "RTN","VPR JSONE",65, 0)
  21206    S VVX=$G( @VVROOT@(V VSUB))
  21207   "RTN","VPR JSONE",66, 0)
  21208    ; handle  the numeri c, boolean , and null  types
  21209   "RTN","VPR JSONE",67, 0)
  21210    I $D(@VVR OOT@(VVSUB ,"\n")) S: $L(@VVROOT @(VVSUB,"\ n")) VVX=@ VVROOT@(VV SUB,"\n")  D CONCAT Q UIT  ; whe n +X'=X
  21211   "RTN","VPR JSONE",68, 0)
  21212    I '$D(@VV ROOT@(VVSU B,"\s")),$ L(VVX),(VV X']]$C(1))  S VVX=$$J NUM(VVX) D  CONCAT QU IT
  21213   "RTN","VPR JSONE",69, 0)
  21214    I (VVX="t rue")!(VVX ="false")! (VVX="null ") D CONCA T QUIT
  21215   "RTN","VPR JSONE",70, 0)
  21216    ; otherwi se treat i t as a str ing type
  21217   "RTN","VPR JSONE",71, 0)
  21218    S VVX=""" "_$$ESC(VV X) ; open  quote
  21219   "RTN","VPR JSONE",72, 0)
  21220    D CONCAT
  21221   "RTN","VPR JSONE",73, 0)
  21222    I $D(@VVR OOT@(VVSUB ,"\")) D   ; handle c ontinuatio n nodes
  21223   "RTN","VPR JSONE",74, 0)
  21224    . S VVI=0  F  S VVI= $O(@VVROOT @(VVSUB,"\ ",VVI)) Q: 'VVI   D
  21225   "RTN","VPR JSONE",75, 0)
  21226    . . S VVX =$$ESC(@VV ROOT@(VVSU B,"\",VVI) )
  21227   "RTN","VPR JSONE",76, 0)
  21228    . . D CON CAT
  21229   "RTN","VPR JSONE",77, 0)
  21230    S VVX=""" " D CONCAT     ; clos e quote
  21231   "RTN","VPR JSONE",78, 0)
  21232    Q
  21233   "RTN","VPR JSONE",79, 0)
  21234   CONCAT ; c ome here t o concaten ate to JSO N string
  21235   "RTN","VPR JSONE",80, 0)
  21236    I ($L(VVX )+$L(@VVJS ON@(VVLINE )))>VVMAX  S VVLINE=V VLINE+1,@V VJSON@(VVL INE)=""
  21237   "RTN","VPR JSONE",81, 0)
  21238    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_VVX
  21239   "RTN","VPR JSONE",82, 0)
  21240    Q
  21241   "RTN","VPR JSONE",83, 0)
  21242   ISVALUE(VV ROOT,VVSUB ) ; Return  true if t his is a v alue node
  21243   "RTN","VPR JSONE",84, 0)
  21244    I $D(@VVR OOT@(VVSUB ))#2 Q 1
  21245   "RTN","VPR JSONE",85, 0)
  21246    N VVX S V VX=$O(@VVR OOT@(VVSUB ,""))
  21247   "RTN","VPR JSONE",86, 0)
  21248    Q:VVX="\"  1
  21249   "RTN","VPR JSONE",87, 0)
  21250    Q:VVX=":"  1
  21251   "RTN","VPR JSONE",88, 0)
  21252    Q 0
  21253   "RTN","VPR JSONE",89, 0)
  21254    ;
  21255   "RTN","VPR JSONE",90, 0)
  21256   NUMERIC(X)  ; Return  true if th e numeric
  21257   "RTN","VPR JSONE",91, 0)
  21258    I $L(X)>1 8 Q 0         ; strin g (too lon g for nume ric)
  21259   "RTN","VPR JSONE",92, 0)
  21260    I X=0 Q 1               ; numer ic (value  is zero)
  21261   "RTN","VPR JSONE",93, 0)
  21262    I +X=0 Q  0             ; strin g
  21263   "RTN","VPR JSONE",94, 0)
  21264    I $E(X,1) ="." Q 0      ; not a  JSON numb er (althou gh numeric  in M)
  21265   "RTN","VPR JSONE",95, 0)
  21266    I $E(X,1, 2)="-." Q  0  ; not a  JSON numb er
  21267   "RTN","VPR JSONE",96, 0)
  21268    I +X=X Q  1             ; numer ic
  21269   "RTN","VPR JSONE",97, 0)
  21270    I X?1"0." 1.n Q 1       ; posit ive fracti on
  21271   "RTN","VPR JSONE",98, 0)
  21272    I X?1"-0. "1.N Q 1      ; negat ive fracti on
  21273   "RTN","VPR JSONE",99, 0)
  21274    S X=$TR(X ,"e","E")
  21275   "RTN","VPR JSONE",100 ,0)
  21276    I X?.1"-" 1.N.1".".N 1"E".1"+"1 .N Q 1  ;  {-}99{.99} E{+}99
  21277   "RTN","VPR JSONE",101 ,0)
  21278    I X?.1"-" 1.N.1".".N 1"E-"1.N Q  1      ;  {-}99{.99} E-99
  21279   "RTN","VPR JSONE",102 ,0)
  21280    Q 0
  21281   "RTN","VPR JSONE",103 ,0)
  21282    ;
  21283   "RTN","VPR JSONE",104 ,0)
  21284   ESC(X) ; E scape stri ng for JSO N
  21285   "RTN","VPR JSONE",105 ,0)
  21286    N Y,I,PAI R,FROM,TO
  21287   "RTN","VPR JSONE",106 ,0)
  21288    S Y=X
  21289   "RTN","VPR JSONE",107 ,0)
  21290    F PAIR="\ \","""""", "//",$C(8, 98),$C(12, 102),$C(10 ,110),$C(1 3,114),$C( 9,116) D
  21291   "RTN","VPR JSONE",108 ,0)
  21292    . S FROM= $E(PAIR),T O=$E(PAIR, 2)
  21293   "RTN","VPR JSONE",109 ,0)
  21294    . S X=Y,Y =$P(X,FROM ) F I=2:1: $L(X,FROM)  S Y=Y_"\" _TO_$P(X,F ROM,I)
  21295   "RTN","VPR JSONE",110 ,0)
  21296    I Y?.E1.C .E S X=Y,Y ="" F I=1: 1:$L(X) S  FROM=$A(X, I) D
  21297   "RTN","VPR JSONE",111 ,0)
  21298    . ; skip  NUL charac ter, other wise encod e ctrl-cha r
  21299   "RTN","VPR JSONE",112 ,0)
  21300    . I FROM< 32 Q:FROM= 0  S Y=Y_$ $UCODE(FRO M) Q
  21301   "RTN","VPR JSONE",113 ,0)
  21302    . I FROM> 126,(FROM< 160) S Y=Y _$$UCODE(F ROM) Q
  21303   "RTN","VPR JSONE",114 ,0)
  21304    . S Y=Y_$ E(X,I)
  21305   "RTN","VPR JSONE",115 ,0)
  21306    Q Y
  21307   "RTN","VPR JSONE",116 ,0)
  21308    ;
  21309   "RTN","VPR JSONE",117 ,0)
  21310   JNUM(N) ;  Return JSO N represen tation of  a number
  21311   "RTN","VPR JSONE",118 ,0)
  21312    I N'<1 Q  N
  21313   "RTN","VPR JSONE",119 ,0)
  21314    I N'>-1 Q  N
  21315   "RTN","VPR JSONE",120 ,0)
  21316    I N>0 Q " 0"_N
  21317   "RTN","VPR JSONE",121 ,0)
  21318    I N<0 Q " -0"_$P(N," -",2,9)
  21319   "RTN","VPR JSONE",122 ,0)
  21320    Q N
  21321   "RTN","VPR JSONE",123 ,0)
  21322    ;
  21323   "RTN","VPR JSONE",124 ,0)
  21324   UCODE(C) ;  Return \u 00nn repre sentation  of decimal  character  value
  21325   "RTN","VPR JSONE",125 ,0)
  21326    N H S H=" 0000"_$$CN V^XLFUTL(C ,16)
  21327   "RTN","VPR JSONE",126 ,0)
  21328    Q "\u"_$E (H,$L(H)-3 ,$L(H))
  21329   "RTN","VPR JSONE",127 ,0)
  21330    ;
  21331   "RTN","VPR JSONE",128 ,0)
  21332   ERRX(ID,VA L) ; Set t he appropr iate error  message
  21333   "RTN","VPR JSONE",129 ,0)
  21334    D ERRX^VP RJSON(ID,$ G(VAL))
  21335   "RTN","VPR JSONE",130 ,0)
  21336    Q
  21337   "RTN","VPR MDUTL")
  21338   0^58^B4973 2701
  21339   "RTN","VPR MDUTL",1,0 )
  21340   VPRMDUTL ; HINES OIFO /BLJ - Fil eMan JSON  utilities  for HMP;02  April 201 3
  21341   "RTN","VPR MDUTL",2,0 )
  21342    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  21343   "RTN","VPR MDUTL",3,0 )
  21344    ; Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  21345   "RTN","VPR MDUTL",4,0 )
  21346    ;
  21347   "RTN","VPR MDUTL",5,0 )
  21348   EN Q  ; On ly call vi a linetag.
  21349   "RTN","VPR MDUTL",6,0 )
  21350   TERM ; Ret rieves lis t of terms
  21351   "RTN","VPR MDUTL",7,0 )
  21352     ; NOTE:  we're not  gonna supp ort paged  retrieves  with this  unless we  have to.   Do not cou nt on
  21353   "RTN","VPR MDUTL",8,0 )
  21354     ; them b eing there .
  21355   "RTN","VPR MDUTL",9,0 )
  21356     ;
  21357   "RTN","VPR MDUTL",10, 0)
  21358     ; Gets t erminology .
  21359   "RTN","VPR MDUTL",11, 0)
  21360     N TERMIE NS,TERMCNT ,X
  21361   "RTN","VPR MDUTL",12, 0)
  21362     D LIST^D IC("704.10 1",,,,,,,, "I $P(^(0) ,U,5)=1")
  21363   "RTN","VPR MDUTL",13, 0)
  21364     M TERMIE NS=^TMP("D ILIST",$J, 2)
  21365   "RTN","VPR MDUTL",14, 0)
  21366     S TERMCN T=$P($G(^T MP("DILIST ",$J,0)),U ,1)
  21367   "RTN","VPR MDUTL",15, 0)
  21368     K ^TMP(" DILIST",$J )
  21369   "RTN","VPR MDUTL",16, 0)
  21370     ;
  21371   "RTN","VPR MDUTL",17, 0)
  21372     F X=0:0  S X=$O(TER MIENS(X))  Q:'X  D
  21373   "RTN","VPR MDUTL",18, 0)
  21374     . N RESU LT
  21375   "RTN","VPR MDUTL",19, 0)
  21376     . ; term
  21377   "RTN","VPR MDUTL",20, 0)
  21378     . D ONET ERM($G(TER MIENS(X)), "RESULT")
  21379   "RTN","VPR MDUTL",21, 0)
  21380     . ;
  21381   "RTN","VPR MDUTL",22, 0)
  21382     . D ADD^ VPREF("RES ULT")
  21383   "RTN","VPR MDUTL",23, 0)
  21384     . S VPRC NT=X,VPRLA ST=X
  21385   "RTN","VPR MDUTL",24, 0)
  21386     Q
  21387   "RTN","VPR MDUTL",25, 0)
  21388   ONETERM(ID ,TARGET) ;  loads one  term
  21389   "RTN","VPR MDUTL",26, 0)
  21390     Q:+ID<1   ; Gotta b e a valid  integer/id
  21391   "RTN","VPR MDUTL",27, 0)
  21392     N $ES,$E T,ERRMSG
  21393   "RTN","VPR MDUTL",28, 0)
  21394     S ERRMSG =$$ERRMSG^ VPREF("CLi O Term",ID )
  21395   "RTN","VPR MDUTL",29, 0)
  21396     S $ET="D  ERRHDLR^V PRDERRH"
  21397   "RTN","VPR MDUTL",30, 0)
  21398     N TERM,T RM,TERMTYP E
  21399   "RTN","VPR MDUTL",31, 0)
  21400     ;
  21401   "RTN","VPR MDUTL",32, 0)
  21402     D GETS^D IQ("704.10 1",ID_",", "*","IE"," TERM")
  21403   "RTN","VPR MDUTL",33, 0)
  21404     N TRM S  TRM=$NA(TE RM(704.101 ,""_ID_"," ))
  21405   "RTN","VPR MDUTL",34, 0)
  21406     S @TARGE T@("id")=$ G(@TRM@(.0 1,"E"))
  21407   "RTN","VPR MDUTL",35, 0)
  21408     S @TARGE T@("uid")= "urn:va:cl ioterminol ogy:"_$G(@ TARGET@("i d"))
  21409   "RTN","VPR MDUTL",36, 0)
  21410     S @TARGE T@("term") =$$SANITIZ E($G(@TRM@ (.02,"E")) )
  21411   "RTN","VPR MDUTL",37, 0)
  21412     S @TARGE T@("abbrev iation")=$ $SANITIZE( $G(@TRM@(. 03,"E")))
  21413   "RTN","VPR MDUTL",38, 0)
  21414     S @TARGE T@("displa yName")=$$ SANITIZE($ G(@TRM@(.0 4,"E")))
  21415   "RTN","VPR MDUTL",39, 0)
  21416     ; Get Te rm Type
  21417   "RTN","VPR MDUTL",40, 0)
  21418     S TERMTY PE=$$SANIT IZE($G(@TR M@(.05,"I" )))
  21419   "RTN","VPR MDUTL",41, 0)
  21420     D TERMTY PE(TERMTYP E,.TARGET)
  21421   "RTN","VPR MDUTL",42, 0)
  21422     ;
  21423   "RTN","VPR MDUTL",43, 0)
  21424     S @TARGE T@("dataTy pe")=$$SAN ITIZE($G(@ TRM@(.06," I")))
  21425   "RTN","VPR MDUTL",44, 0)
  21426     S @TARGE T@("valueT ype")=$$SA NITIZE($G( @TRM@(.07, "I")))
  21427   "RTN","VPR MDUTL",45, 0)
  21428     S @TARGE T@("active ")=$$SANIT IZE($G(@TR M@(.09,"E" )))
  21429   "RTN","VPR MDUTL",46, 0)
  21430     S @TARGE T@("descri ption")=$$ SANITIZE($ G(@TRM@(.1 ,"E")))
  21431   "RTN","VPR MDUTL",47, 0)
  21432     S @TARGE T@("helpTe xt")=$$SAN ITIZE($G(@ TRM@(.2,"E ")))
  21433   "RTN","VPR MDUTL",48, 0)
  21434     S @TARGE T@("boolea nValueTrue ")=$$SANIT IZE($G(@TR M@(.31,"E" )))
  21435   "RTN","VPR MDUTL",49, 0)
  21436     S @TARGE T@("boolea nValueFals e")=$$SANI TIZE($G(@T RM@(.32,"E ")))
  21437   "RTN","VPR MDUTL",50, 0)
  21438     S @TARGE T@("multiS electPickl ist")=$$SA NITIZE($G( @TRM@(.33, "E")))
  21439   "RTN","VPR MDUTL",51, 0)
  21440     S @TARGE T@("VUID") ="urn:va:v uid:"_$$SA NITIZE($G( @TRM@(99.9 9,"E")))
  21441   "RTN","VPR MDUTL",52, 0)
  21442     ; term - > child te rms
  21443   "RTN","VPR MDUTL",53, 0)
  21444     ;
  21445   "RTN","VPR MDUTL",54, 0)
  21446     ; Note,  for right  now this i s a little  odd: the  initial lo ad is done  off of DF N.  This l oad
  21447   "RTN","VPR MDUTL",55, 0)
  21448     ; is don e off of U ID.  We'll  probably  change tha t to UID o r IFN for  both at so me point.
  21449   "RTN","VPR MDUTL",56, 0)
  21450     ;
  21451   "RTN","VPR MDUTL",57, 0)
  21452     D TERMCH LD($G(@TRM @(.01,"E") ),.TARGET)
  21453   "RTN","VPR MDUTL",58, 0)
  21454     ;
  21455   "RTN","VPR MDUTL",59, 0)
  21456     ; term - > unit pai r
  21457   "RTN","VPR MDUTL",60, 0)
  21458     D TERMUN IT($G(@TRM @(.01,"E") ),.TARGET)
  21459   "RTN","VPR MDUTL",61, 0)
  21460     ;
  21461   "RTN","VPR MDUTL",62, 0)
  21462     ; term - > qualifie r pair
  21463   "RTN","VPR MDUTL",63, 0)
  21464     ;
  21465   "RTN","VPR MDUTL",64, 0)
  21466     D TERMQU AL($G(@TRM @(.01,"E") ),.TARGET, ID)
  21467   "RTN","VPR MDUTL",65, 0)
  21468     ;
  21469   "RTN","VPR MDUTL",66, 0)
  21470     ; term - > unit con version -  for right  now, we're  not going  to pull t erm -> uni t conversi ons.  We w ill need t o do so at  some poin t
  21471   "RTN","VPR MDUTL",67, 0)
  21472     ; though .
  21473   "RTN","VPR MDUTL",68, 0)
  21474     K TERMTY PE,TRM
  21475   "RTN","VPR MDUTL",69, 0)
  21476     Q
  21477   "RTN","VPR MDUTL",70, 0)
  21478     ;
  21479   "RTN","VPR MDUTL",71, 0)
  21480   TERMTYPE(I D,TARGET)  ;Loads ter m types.
  21481   "RTN","VPR MDUTL",72, 0)
  21482     ;
  21483   "RTN","VPR MDUTL",73, 0)
  21484     ; TARGET  passed by  reference .  
  21485   "RTN","VPR MDUTL",74, 0)
  21486     ;
  21487   "RTN","VPR MDUTL",75, 0)
  21488     ; Sanity  checks fi rst
  21489   "RTN","VPR MDUTL",76, 0)
  21490     ; 
  21491   "RTN","VPR MDUTL",77, 0)
  21492     Q:+ID<1   ; Gotta b e a number , we're do ing a dire ct IFN loo kup.
  21493   "RTN","VPR MDUTL",78, 0)
  21494     N TERMTY PE
  21495   "RTN","VPR MDUTL",79, 0)
  21496     D GETS^D IQ("704.10 2",ID_",", "*","E","T ERMTYPE")
  21497   "RTN","VPR MDUTL",80, 0)
  21498     N VPRNAM E S VPRNAM E=$T(TTFLD S+1)
  21499   "RTN","VPR MDUTL",81, 0)
  21500     ;
  21501   "RTN","VPR MDUTL",82, 0)
  21502     N VPREPL AC S VPREP LAC("""")= "\"""
  21503   "RTN","VPR MDUTL",83, 0)
  21504     S @TARGE T@("termTy pe",$P(VPR NAME,";",3 ))=ID
  21505   "RTN","VPR MDUTL",84, 0)
  21506     S @TARGE T@("termTy pe",$P(VPR NAME,";",4 ))=$$SANIT IZE($$REPL ACE^XLFSTR (TERMTYPE( "704.102", ID_",",.01 ,"E"),.VPR EPLAC))
  21507   "RTN","VPR MDUTL",85, 0)
  21508     S @TARGE T@("termTy pe",$P(VPR NAME,";",5 ))=$$SANIT IZE($$REPL ACE^XLFSTR (TERMTYPE( "704.102", ID_",",.02 ,"E"),.VPR EPLAC))
  21509   "RTN","VPR MDUTL",86, 0)
  21510     S @TARGE T@("termTy pe",$P(VPR NAME,";",6 ))=$$SANIT IZE($$REPL ACE^XLFSTR (TERMTYPE( "704.102", ID_",",.03 ,"E"),.VPR EPLAC))
  21511   "RTN","VPR MDUTL",87, 0)
  21512     K TERMTY PE
  21513   "RTN","VPR MDUTL",88, 0)
  21514     Q
  21515   "RTN","VPR MDUTL",89, 0)
  21516   TERMCHLD(I D,TARGET)  ;Loads chi ld terms f or a term
  21517   "RTN","VPR MDUTL",90, 0)
  21518     ;
  21519   "RTN","VPR MDUTL",91, 0)
  21520     ;
  21521   "RTN","VPR MDUTL",92, 0)
  21522     N MSGROO T S MSGROO T="TERMCHL D("""_ID_" "")"
  21523   "RTN","VPR MDUTL",93, 0)
  21524     D FIND^D IC("704.10 6",,".02E; .03I;.04I; .05E;.06E; .07E;.08E; .09E","M", ID,,,,,MSG ROOT)
  21525   "RTN","VPR MDUTL",94, 0)
  21526     ; Check  to see if  we actuall y have any  children.
  21527   "RTN","VPR MDUTL",95, 0)
  21528     I +$P(TE RMCHLD(ID, "DILIST",0 ),U,1)<1 K  @MSGROOT  Q
  21529   "RTN","VPR MDUTL",96, 0)
  21530     N X F X= 0:0 S X=($ O(TERMCHLD (ID,"DILIS T","ID",X) )) Q:'X  D
  21531   "RTN","VPR MDUTL",97, 0)
  21532     . ; .01  is the Ter m ID
  21533   "RTN","VPR MDUTL",98, 0)
  21534     . S @TAR GET@("term Child",X," childOrder ")=$$SANIT IZE($G(TER MCHLD(ID," DILIST","I D",X,.02)) )
  21535   "RTN","VPR MDUTL",99, 0)
  21536     . ; .03  is the Chi ld ID
  21537   "RTN","VPR MDUTL",100 ,0)
  21538     . N CHIL D S CHILD= $NA(@TARGE T@("termCh ild",X,"ch ildTerm"))
  21539   "RTN","VPR MDUTL",101 ,0)
  21540     . D ONET ERM($G(TER MCHLD(ID," DILIST","I D",X,.03)) ,.CHILD)
  21541   "RTN","VPR MDUTL",102 ,0)
  21542     . S @TAR GET@("term Child",X," valueType" )=$$SANITI ZE($G(TERM CHLD(ID,"D ILIST","ID ",X,.05)))
  21543   "RTN","VPR MDUTL",103 ,0)
  21544     . S @TAR GET@("term Child",X," valueDelim iter")=$$S ANITIZE($G (TERMCHLD( ID,"DILIST ","ID",X,. 06)))
  21545   "RTN","VPR MDUTL",104 ,0)
  21546     . S @TAR GET@("term Child",X," valueStart ")=$$SANIT IZE($G(TER MCHLD(ID," DILIST","I D",X,.07)) )
  21547   "RTN","VPR MDUTL",105 ,0)
  21548     . S @TAR GET@("term Child",X," valueStop" )=$$SANITI ZE($G(TERM CHLD(ID,"D ILIST","ID ",X,.08)))
  21549   "RTN","VPR MDUTL",106 ,0)
  21550     . S @TAR GET@("term Child",X," descriptio n")=$$SANI TIZE($G(TE RMCHLD(ID, "DILIST"," ID",X,.09) ))
  21551   "RTN","VPR MDUTL",107 ,0)
  21552     K @MSGRO OT
  21553   "RTN","VPR MDUTL",108 ,0)
  21554     Q
  21555   "RTN","VPR MDUTL",109 ,0)
  21556   TERMUNIT(I D,TARGET)  ;Loads Uni ts for a t erm.
  21557   "RTN","VPR MDUTL",110 ,0)
  21558     ;
  21559   "RTN","VPR MDUTL",111 ,0)
  21560     N MSGROO T S MSGROO T="TERMUNI T("""_ID_" "")"
  21561   "RTN","VPR MDUTL",112 ,0)
  21562     D FIND^D IC("704.10 5",,".02I; .03E;.04E; .05E;.06E; .07E","M", ID,,,,,MSG ROOT)
  21563   "RTN","VPR MDUTL",113 ,0)
  21564     ; Check  to see if  we actuall y have any  children.
  21565   "RTN","VPR MDUTL",114 ,0)
  21566     I +$P(TE RMUNIT(ID, "DILIST",0 ),U,1)<1 K  @MSGROOT  Q
  21567   "RTN","VPR MDUTL",115 ,0)
  21568     N X F X= 0:0 S X=($ O(TERMUNIT (ID,"DILIS T","ID",X) )) Q:'X  D
  21569   "RTN","VPR MDUTL",116 ,0)
  21570     . ; .01  is the Ter m ID
  21571   "RTN","VPR MDUTL",117 ,0)
  21572     . ; .02  is the Uni t ID
  21573   "RTN","VPR MDUTL",118 ,0)
  21574     . N UNIT  S UNIT=$N A(@TARGET@ ("units",X ,"unitTerm "))
  21575   "RTN","VPR MDUTL",119 ,0)
  21576     . D ONET ERM($G(TER MUNIT(ID," DILIST","I D",X,.02)) ,.UNIT)
  21577   "RTN","VPR MDUTL",120 ,0)
  21578     . S @TAR GET@("unit s",X,"minV alue")=$$S ANITIZE($G (TERMUNIT( ID,"DILIST ","ID",X,. 03)))
  21579   "RTN","VPR MDUTL",121 ,0)
  21580     . S @TAR GET@("unit s",X,"maxV alue")=$$S ANITIZE($G (TERMUNIT( ID,"DILIST ","ID",X,. 04)))
  21581   "RTN","VPR MDUTL",122 ,0)
  21582     . S @TAR GET@("unit s",X,"decP recision") =$$SANITIZ E($G(TERMU NIT(ID,"DI LIST","ID" ,X,.05)))
  21583   "RTN","VPR MDUTL",123 ,0)
  21584     . S @TAR GET@("unit s",X,"refL ow")=$$SAN ITIZE($G(T ERMUNIT(ID ,"DILIST", "ID",X,.06 )))
  21585   "RTN","VPR MDUTL",124 ,0)
  21586     . S @TAR GET@("unit s",X,"refH igh")=$$SA NITIZE($G( TERMUNIT(I D,"DILIST" ,"ID",X,.0 7)))
  21587   "RTN","VPR MDUTL",125 ,0)
  21588     K @MSGRO OT
  21589   "RTN","VPR MDUTL",126 ,0)
  21590     Q
  21591   "RTN","VPR MDUTL",127 ,0)
  21592   TERMQUAL(I D,TARGET,I FN) ;Loads  Qualifier s for a te rm
  21593   "RTN","VPR MDUTL",128 ,0)
  21594     ;
  21595   "RTN","VPR MDUTL",129 ,0)
  21596     N MSGROO T S MSGROO T="TERMQUA L("""_ID_" "")"
  21597   "RTN","VPR MDUTL",130 ,0)
  21598     D FIND^D IC("704.10 3",,".02E; .03I;.04E" ,"M",ID,,, ,,MSGROOT)
  21599   "RTN","VPR MDUTL",131 ,0)
  21600     ; Check  to see if  we actuall y have any  qualifier s.
  21601   "RTN","VPR MDUTL",132 ,0)
  21602     I +$P(TE RMQUAL(ID, "DILIST",0 ),U,1)<1 K  @MSGROOT  Q
  21603   "RTN","VPR MDUTL",133 ,0)
  21604     N X F X= 0:0 S X=($ O(TERMQUAL (ID,"DILIS T","ID",X) )) Q:'X  D
  21605   "RTN","VPR MDUTL",134 ,0)
  21606     . ; .01  is the Ter m ID
  21607   "RTN","VPR MDUTL",135 ,0)
  21608     . ; .03  is the Qua lifier ID
  21609   "RTN","VPR MDUTL",136 ,0)
  21610     . N QUAL  S QUAL=$N A(@TARGET@ ("qualifie rs",X,"qua lTerm"))
  21611   "RTN","VPR MDUTL",137 ,0)
  21612     . ; blj  28 Feb 201 4: bandaid  to preven t recursiv e calls if  someone h as messed  up the str ucture of  the TERM_Q UALIFIER f ile.
  21613   "RTN","VPR MDUTL",138 ,0)
  21614     . I IFN' =$G(TERMQU AL(ID,"DIL IST","ID", X,.03)) D  ONETERM($G (TERMQUAL( ID,"DILIST ","ID",X,. 03)),.QUAL )
  21615   "RTN","VPR MDUTL",139 ,0)
  21616     . S @TAR GET@("qual ifiers",X, "qualOrder ")=$$SANIT IZE($G(TER MQUAL(ID," DILIST","I D",X,.02)) )
  21617   "RTN","VPR MDUTL",140 ,0)
  21618     . S @TAR GET@("qual ifiers",X, "ranking") =$$SANITIZ E($G(TERMQ UAL(ID,"DI LIST","ID" ,X,.04)))
  21619   "RTN","VPR MDUTL",141 ,0)
  21620     K @MSGRO OT
  21621   "RTN","VPR MDUTL",142 ,0)
  21622     Q
  21623   "RTN","VPR MDUTL",143 ,0)
  21624   SANITIZE(V ALUE) ; Ma kds sure v alues are  formatted  correctly.
  21625   "RTN","VPR MDUTL",144 ,0)
  21626     I +VALUE '=VALUE Q  VALUE
  21627   "RTN","VPR MDUTL",145 ,0)
  21628     I VALUE? 1".".N S V ALUE="0"_V ALUE
  21629   "RTN","VPR MDUTL",146 ,0)
  21630     I VALUE? 1"-.".N S  VALUE="-0" _$E(VALUE, 2,$LENGTH( VALUE))
  21631   "RTN","VPR MDUTL",147 ,0)
  21632     Q VALUE
  21633   "RTN","VPR MDUTL",148 ,0)
  21634   TRMFLDS ;F ields for  terminolog y
  21635   "RTN","VPR MDUTL",149 ,0)
  21636     ;;.01;id
  21637   "RTN","VPR MDUTL",150 ,0)
  21638     ;;.02;te rm
  21639   "RTN","VPR MDUTL",151 ,0)
  21640     ;;.03;ab breviation
  21641   "RTN","VPR MDUTL",152 ,0)
  21642     ;;.04;di splayName
  21643   "RTN","VPR MDUTL",153 ,0)
  21644     ;;.05;te rmType
  21645   "RTN","VPR MDUTL",154 ,0)
  21646     ;;.06;da taType
  21647   "RTN","VPR MDUTL",155 ,0)
  21648     ;;.07;va lueType
  21649   "RTN","VPR MDUTL",156 ,0)
  21650     ;;.09;ac tive
  21651   "RTN","VPR MDUTL",157 ,0)
  21652     ;;.1;des cription
  21653   "RTN","VPR MDUTL",158 ,0)
  21654     ;;.2;hel pText;
  21655   "RTN","VPR MDUTL",159 ,0)
  21656     ;;.31;bo oleanValue True
  21657   "RTN","VPR MDUTL",160 ,0)
  21658     ;;.32;bo oleanValue False;
  21659   "RTN","VPR MDUTL",161 ,0)
  21660     ;;.33;mu ltiSelectP icklist
  21661   "RTN","VPR MDUTL",162 ,0)
  21662     ;;99.99; VUID
  21663   "RTN","VPR MDUTL",163 ,0)
  21664     ;;***
  21665   "RTN","VPR MDUTL",164 ,0)
  21666   TTFLDS ;Fi elds for T erm Typea
  21667   "RTN","VPR MDUTL",165 ,0)
  21668     ;;id;typ e;xmlTag;V UID
  21669   "RTN","VPR P3I")
  21670   0^^B419405 06
  21671   "RTN","VPR P3I",1,0)
  21672   VPRP3I ;SL C/AGP -- V PR patch 3  post inst all
  21673   "RTN","VPR P3I",2,0)
  21674    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  21675   "RTN","VPR P3I",3,0)
  21676    ;
  21677   "RTN","VPR P3I",4,0)
  21678   ENV ; -- e nvironment  check to  prevent pr oduction i nstallatio n
  21679   "RTN","VPR P3I",5,0)
  21680    I $$PROD^ XUPROD D
  21681   "RTN","VPR P3I",6,0)
  21682    .W !,"You  are attem pting to i nstall thi s software  into your  productio n account. ",!,"At th is time, t his softwa re is not  ready for  a producti on install ."
  21683   "RTN","VPR P3I",7,0)
  21684    .W !!,"Pl ease verif y the acco unt you're  attemptin g to insta ll into an d",!,"if y ou believe  you're co rrect, con tact Ron M assey or T ana Defa." ,!!,"INSTA LLATION AB ORTED!"
  21685   "RTN","VPR P3I",8,0)
  21686    .S XPDABO RT=1
  21687   "RTN","VPR P3I",9,0)
  21688    Q
  21689   "RTN","VPR P3I",10,0)
  21690    ;
  21691   "RTN","VPR P3I",11,0)
  21692   PRE ; -- c lean out V PR SUBSCRI PTION and  ^XTMP("VPR ") entries  for testi ng
  21693   "RTN","VPR P3I",12,0)
  21694    N VPRDT S  VPRDT="VP R-1111111"
  21695   "RTN","VPR P3I",13,0)
  21696    F  S VPRD T=$O(^XTMP (VPRDT)) Q :VPRDT'?1" VPR-"7N  K  ^XTMP(VPR DT)
  21697   "RTN","VPR P3I",14,0)
  21698    S VPRDT=" VPREF-1111 111"
  21699   "RTN","VPR P3I",15,0)
  21700    F  S VPRD T=$O(^XTMP (VPRDT)) Q :VPRDT'?1" VPREF-"7N   K ^XTMP(V PRDT)
  21701   "RTN","VPR P3I",16,0)
  21702    K ^XTMP(" VPR"),^TMP ("VPRX")
  21703   "RTN","VPR P3I",17,0)
  21704    I $$VERCM P($$VERSRV (),"0.7-S5 4")>0 D  ;  if curren t < S54
  21705   "RTN","VPR P3I",18,0)
  21706    . K ^VPR( 560)
  21707   "RTN","VPR P3I",19,0)
  21708    . S ^VPR( 560,0)="VP R SUBSCRIP TION^560^^ "
  21709   "RTN","VPR P3I",20,0)
  21710    ;D CLEARP AR
  21711   "RTN","VPR P3I",21,0)
  21712    I $D(^DD( 560.04)) D   ;remove  old Subscr iption sub -files
  21713   "RTN","VPR P3I",22,0)
  21714    . N DIU S  DIU(0)="S "
  21715   "RTN","VPR P3I",23,0)
  21716    . S DIU=5 60.04 D EN ^DIU2
  21717   "RTN","VPR P3I",24,0)
  21718    . S DIU=5 60.03 D EN ^DIU2
  21719   "RTN","VPR P3I",25,0)
  21720    ;D TASKCO NV
  21721   "RTN","VPR P3I",26,0)
  21722    D ADDRSRC  ; add res ource for  throttling  extract t asks
  21723   "RTN","VPR P3I",27,0)
  21724    Q
  21725   "RTN","VPR P3I",28,0)
  21726    ;
  21727   "RTN","VPR P3I",29,0)
  21728   CLEARPAR ;
  21729   "RTN","VPR P3I",30,0)
  21730    N ENT,ERR OR,INST,LI ST,PAR,TYP E,X,UID
  21731   "RTN","VPR P3I",31,0)
  21732    ;S PAR=""  F  S PAR= $O(^XTV(89 89.51,"B", "VPR PARAM ETERS","") ) I PAR>0  Q
  21733   "RTN","VPR P3I",32,0)
  21734    S PAR=$O( ^XTV(8989. 51,"B","VP R PARAMETE RS","")) Q :PAR'>0
  21735   "RTN","VPR P3I",33,0)
  21736    S X="" F   S X=$O(^X TV(8989.5, "AC",PAR,X )) Q:X=""   D
  21737   "RTN","VPR P3I",34,0)
  21738    .S TYPE=$ S(X["VA":" USR",X["DI C":"SYS",1 :"") I TYP E="" Q
  21739   "RTN","VPR P3I",35,0)
  21740    .S ENT=TY PE_".`"_+X
  21741   "RTN","VPR P3I",36,0)
  21742    .S UID=""  F  S UID= $O(^XTV(89 89.5,"AC", PAR,X,UID) ) Q:UID=""   D
  21743   "RTN","VPR P3I",37,0)
  21744    ..D DEL^X PAR(ENT,"V PR PARAMET ERS",UID,. ERROR)
  21745   "RTN","VPR P3I",38,0)
  21746    Q
  21747   "RTN","VPR P3I",39,0)
  21748    ;
  21749   "RTN","VPR P3I",40,0)
  21750    ; VERSRV  and VERCMP  are also  in VPRUTIL S, but not  until aft er the ins tall
  21751   "RTN","VPR P3I",41,0)
  21752    ; of this  patch (VP R*1*3), so  they are  reproduced  here.
  21753   "RTN","VPR P3I",42,0)
  21754    ;
  21755   "RTN","VPR P3I",43,0)
  21756   VERSRV()    ; Return  server ver sion of op tion name
  21757   "RTN","VPR P3I",44,0)
  21758    N VPRLST, VAL
  21759   "RTN","VPR P3I",45,0)
  21760    D FIND^DI C(19,"",1, "X","VPR U I CONTEXT" ,1,,,,"VPR LST")
  21761   "RTN","VPR P3I",46,0)
  21762    S VAL=$G( VPRLST("DI LIST","ID" ,1,1))
  21763   "RTN","VPR P3I",47,0)
  21764    Q $$UP^XL FSTR($P(VA L,"version  ",2))
  21765   "RTN","VPR P3I",48,0)
  21766    ;
  21767   "RTN","VPR P3I",49,0)
  21768   VERCMP(CUR ,VAL) ; Re turns 1 if  CUR<VAL,  -1 if CUR> VAL, 0 if  equal
  21769   "RTN","VPR P3I",50,0)
  21770    N CURMAJO R,CURMINOR ,CURSNAP,V ALMAJOR,VA LMINOR,VAL SNAP
  21771   "RTN","VPR P3I",51,0)
  21772    S CURMAJO R=$P(CUR," -"),CURMIN OR=$P(CUR, "-",2),CUR SNAP=$E($P (CUR,"-",3 ),1,4)="SN AP"
  21773   "RTN","VPR P3I",52,0)
  21774    S VALMAJO R=$P(VAL," -"),VALMIN OR=$P(VAL, "-",2),VAL SNAP=$E($P (VAL,"-",3 ),1,4)="SN AP"
  21775   "RTN","VPR P3I",53,0)
  21776    I $E(VALM INOR)="P"  S VALMINOR =$E(VALMIN OR,2,99)      ; "P"il ot version s (old)
  21777   "RTN","VPR P3I",54,0)
  21778    I $E(CURM INOR)="P"  S CURMINOR =$E(VALMIN OR,2,99)
  21779   "RTN","VPR P3I",55,0)
  21780    I $E(VALM INOR)="S"  S VALMINOR =$E(VALMIN OR,2,99)*1 0  ; "S"pr int versio ns
  21781   "RTN","VPR P3I",56,0)
  21782    I $E(CURM INOR)="S"  S CURMINOR =$E(CURMIN OR,2,99)*1 0
  21783   "RTN","VPR P3I",57,0)
  21784    Q:VALMAJO R>CURMAJOR  1   Q:VAL MAJOR<CURM AJOR -1  ;  compare m ajor versi ons
  21785   "RTN","VPR P3I",58,0)
  21786    Q:VALMINO R>CURMINOR  1   Q:VAL MINOR<CURM INOR -1  ;  compare m inor versi ons
  21787   "RTN","VPR P3I",59,0)
  21788    Q:(CURSNA P&'VALSNAP ) 1  Q:(VA LSNAP&'CUR SNAP) -1 ;  "SNAPSHOT " < releas ed
  21789   "RTN","VPR P3I",60,0)
  21790    Q 0
  21791   "RTN","VPR P3I",61,0)
  21792    ;
  21793   "RTN","VPR P3I",62,0)
  21794    ;
  21795   "RTN","VPR P3I",63,0)
  21796   POST ; --  set up new  Tx data
  21797   "RTN","VPR P3I",64,0)
  21798    ;D CREATE US
  21799   "RTN","VPR P3I",65,0)
  21800    D EN^VPRI DX
  21801   "RTN","VPR P3I",66,0)
  21802    D DG
  21803   "RTN","VPR P3I",67,0)
  21804    D OI
  21805   "RTN","VPR P3I",68,0)
  21806    D VERSION
  21807   "RTN","VPR P3I",69,0)
  21808    Q
  21809   "RTN","VPR P3I",70,0)
  21810    ;
  21811   "RTN","VPR P3I",71,0)
  21812   VERSION ;  -- update  V# paramet er
  21813   "RTN","VPR P3I",72,0)
  21814    D PUT^XPA R("PKG","V PR VERSION ",1,"1.03" )
  21815   "RTN","VPR P3I",73,0)
  21816    Q
  21817   "RTN","VPR P3I",74,0)
  21818    ;
  21819   "RTN","VPR P3I",75,0)
  21820   DG ; -- ad d Treatmen ts display  group to  Nursing pa rent
  21821   "RTN","VPR P3I",76,0)
  21822    Q:'$O(^OR D(100.98," B","NTX",0 ))
  21823   "RTN","VPR P3I",77,0)
  21824    N DA,DIC, DLAYGO,Y
  21825   "RTN","VPR P3I",78,0)
  21826    S DA(1)=$ O(^ORD(100 .98,"B","N URS",0)) I  'DA(1) K  DA Q
  21827   "RTN","VPR P3I",79,0)
  21828    S:'$D(^OR D(100.98,D A(1),1,0))  ^(0)="^10 0.981P^^"
  21829   "RTN","VPR P3I",80,0)
  21830    S DIC="^O RD(100.98, "_DA(1)_", 1,",DIC(0) ="NLX",DLA YGO=100.98
  21831   "RTN","VPR P3I",81,0)
  21832    S X="NTX"  D ^DIC
  21833   "RTN","VPR P3I",82,0)
  21834    Q
  21835   "RTN","VPR P3I",83,0)
  21836    ;
  21837   "RTN","VPR P3I",84,0)
  21838   OI ; -- as sign Nursi ng orderab le items t o Treatmen ts
  21839   "RTN","VPR P3I",85,0)
  21840    N ORDG,OR X,ORI
  21841   "RTN","VPR P3I",86,0)
  21842    F ORDG="A CT","NURS"  D
  21843   "RTN","VPR P3I",87,0)
  21844    . S ORX=" " F  S ORX =$O(^ORD(1 01.43,"S." _ORDG,ORX) ) Q:ORX=""   D  ;OI n ame
  21845   "RTN","VPR P3I",88,0)
  21846    .. S ORI= 0 F  S ORI =$O(^ORD(1 01.43,"S." _ORDG,ORX, ORI)) Q:OR I<1  D SET ^ORDD43("N TX",ORI)
  21847   "RTN","VPR P3I",89,0)
  21848    Q
  21849   "RTN","VPR P3I",90,0)
  21850    ;
  21851   "RTN","VPR P3I",91,0)
  21852   CREATEUS ;
  21853   "RTN","VPR P3I",92,0)
  21854    N DIV,FDA ,IC,IEN,IE NS,NAME,SE R,VPRERR
  21855   "RTN","VPR P3I",93,0)
  21856    ;do not c reate the  user if th e patch is  already i nstalled o r if the u ser is alr eady creat ed
  21857   "RTN","VPR P3I",94,0)
  21858    I $$PATCH ^XPDUTL("V PR*1.0*3")  Q
  21859   "RTN","VPR P3I",95,0)
  21860    D EN^DDIO L("Creatin g VPR Sync  User")
  21861   "RTN","VPR P3I",96,0)
  21862    ;
  21863   "RTN","VPR P3I",97,0)
  21864    S NAME="V PR,USER SY NC"
  21865   "RTN","VPR P3I",98,0)
  21866    S IEN=$$C REATE^XUSA P(NAME,"", "VPR SYNCH RONIZATION  CONTEXT")
  21867   "RTN","VPR P3I",99,0)
  21868    I IEN=0 D  EN^DDIOL( "User alre ady exists ") Q
  21869   "RTN","VPR P3I",100,0 )
  21870    I IEN<0 D  EN^DDIOL( "Cannot cr eate user" ) Q
  21871   "RTN","VPR P3I",101,0 )
  21872    S IENS="? "_IEN_","
  21873   "RTN","VPR P3I",102,0 )
  21874    S DIV=$$A SK(4) I DI V'>0 D EN^ DDIOL("A d ivision ne eds to be  selected." ) Q
  21875   "RTN","VPR P3I",103,0 )
  21876    S SER=$$A SK(49) I S ER'>0 D EN ^DDIOL("A  service ne eds to be  selected." ) Q
  21877   "RTN","VPR P3I",104,0 )
  21878    S FDA(200 ,IENS,.01) =NAME
  21879   "RTN","VPR P3I",105,0 )
  21880    S FDA(200 ,IENS,7.2) =1
  21881   "RTN","VPR P3I",106,0 )
  21882    S FDA(200 ,IENS,29)= $P(SER,U)
  21883   "RTN","VPR P3I",107,0 )
  21884    S FDA(200 ,IENS,200. 04)=1
  21885   "RTN","VPR P3I",108,0 )
  21886    S FDA(200 ,IENS,200. 1)=99999
  21887   "RTN","VPR P3I",109,0 )
  21888    ;S FDA(20 0.03,"?+2, "_IENS,.01 )="VPR SYN CHRONIZATI ON CONTEXT "
  21889   "RTN","VPR P3I",110,0 )
  21890    ;S FDA(20 0.03,"?+3, "_IENS,.01 )="VPR UI  CONTEXT"
  21891   "RTN","VPR P3I",111,0 )
  21892    S FDA(200 .02,"?+4," _IENS,.01) =$P(DIV,U)
  21893   "RTN","VPR P3I",112,0 )
  21894    S FDA(200 .02,"?+4," _IENS,1)=1
  21895   "RTN","VPR P3I",113,0 )
  21896    D UPDATE^ DIE("","FD A","","VPR ERR")
  21897   "RTN","VPR P3I",114,0 )
  21898    I $D(VPRE RR) D  Q
  21899   "RTN","VPR P3I",115,0 )
  21900    .D EN^DDI OL("Update  failed, U PDATE^DIE  returned t he followi ng error m essage.")
  21901   "RTN","VPR P3I",116,0 )
  21902    .S IC="VP RERR"
  21903   "RTN","VPR P3I",117,0 )
  21904    .F  S IC= $Q(@IC) Q: IC=""  W ! ,IC,"=",@I C
  21905   "RTN","VPR P3I",118,0 )
  21906    .D EN^DDI OL("Examin e the abov e error me ssage for  the reason .")
  21907   "RTN","VPR P3I",119,0 )
  21908    .H 2
  21909   "RTN","VPR P3I",120,0 )
  21910    D EN^DDIO L("Add ACC ESS/VERIFY  codes to  the "_NAME )
  21911   "RTN","VPR P3I",121,0 )
  21912    Q
  21913   "RTN","VPR P3I",122,0 )
  21914    ;
  21915   "RTN","VPR P3I",123,0 )
  21916   ASK(FILENU M) ;
  21917   "RTN","VPR P3I",124,0 )
  21918    N DIC,Y
  21919   "RTN","VPR P3I",125,0 )
  21920    S DIC=FIL ENUM,DIC(0 )="AEQMZ", DIC("A")=" Select "_$ S(FILENUM= 4:"divisio n: ",1:"se rvice/sect ion: ")
  21921   "RTN","VPR P3I",126,0 )
  21922    I FILENUM =4 S DIC(" S")="S DIN UM=X K:$S( $D(^XUSEC( ""XUMGR"", DUZ)):0,'$ $TF^XUAF4( X):1,1:0)  X,DINUM"
  21923   "RTN","VPR P3I",127,0 )
  21924    D ^DIC
  21925   "RTN","VPR P3I",128,0 )
  21926    Q Y
  21927   "RTN","VPR P3I",129,0 )
  21928    ;
  21929   "RTN","VPR P3I",130,0 )
  21930   TASKCONV ;
  21931   "RTN","VPR P3I",131,0 )
  21932    N COLL,I, IEN,NODE,P AT,TEMP,UI D,UPDATE,V PRY
  21933   "RTN","VPR P3I",132,0 )
  21934    K ^TMP($J ,"VPRY"),^ TMP($J,"VP RTEMP")
  21935   "RTN","VPR P3I",133,0 )
  21936    S VPRY=$N A(^TMP($J, "VPRY")),T EMP=$NA(^T MP($J,"VPR TEMP"))
  21937   "RTN","VPR P3I",134,0 )
  21938    S PAT=0 F   S PAT=$O (^VPR(560. 1,"C",PAT) ) Q:PAT'>0   D
  21939   "RTN","VPR P3I",135,0 )
  21940    .S IEN=0  F  S IEN=$ O(^VPR(560 .1,"C",PAT ,"task",IE N)) Q:IEN' >0  D
  21941   "RTN","VPR P3I",136,0 )
  21942    ..S NODE= $G(^VPR(56 0.1,IEN,0) )
  21943   "RTN","VPR P3I",137,0 )
  21944    ..S UID=$ P(NODE,U)  I UID="" Q
  21945   "RTN","VPR P3I",138,0 )
  21946    ..S UPDAT E=0
  21947   "RTN","VPR P3I",139,0 )
  21948    ..S I=0 F   S I=$O(^ VPR(560.1, IEN,1,I))  Q:I<1  S X =$G(^(I,0) ),VPRY(I)= X
  21949   "RTN","VPR P3I",140,0 )
  21950    ..D DECOD E^VPRJSON( "VPRY","TE MP","ERROR ")
  21951   "RTN","VPR P3I",141,0 )
  21952    ..I $D(ER ROR) D EN^ DDIOL("Err or in deco ding JSON  Object") Q
  21953   "RTN","VPR P3I",142,0 )
  21954    ..K VPRY, ^TMP($J,"V PRY")
  21955   "RTN","VPR P3I",143,0 )
  21956    ..I $G(@T EMP@("assi gnToCode") )'="" S @T EMP@("crea tedByCode" )=@TEMP@(" assignToCo de"),UPDAT E=1 K @TEM P@("assign ToCode")
  21957   "RTN","VPR P3I",144,0 )
  21958    ..I $G(@T EMP@("assi gnToName") )'="" S @T EMP@("crea tedByName" )=@TEMP@(" assignToNa me"),UPDAT E=1 K @TEM P@("assign ToName")
  21959   "RTN","VPR P3I",145,0 )
  21960    ..I $G(@T EMP@("owne rName"))'= "" S UPDAT E=1 K @TEM P@("ownerN ame")
  21961   "RTN","VPR P3I",146,0 )
  21962    ..I $G(@T EMP@("owne rCode"))'= "" S UPDAT E=1 K @TEM P@("ownerC ode")
  21963   "RTN","VPR P3I",147,0 )
  21964    ..I UPDAT E=0 Q
  21965   "RTN","VPR P3I",148,0 )
  21966    ..;
  21967   "RTN","VPR P3I",149,0 )
  21968    ..S VPRY= $NA(^TMP($ J,"VPRY"))
  21969   "RTN","VPR P3I",150,0 )
  21970    ..D ENCOD E^VPRJSON( "TEMP","VP RY","ERROR ")
  21971   "RTN","VPR P3I",151,0 )
  21972    ..I $D(ER ROR) D EN^ DDIOL("Err or in enco ding JSON  Object") Q
  21973   "RTN","VPR P3I",152,0 )
  21974    ..D EN^DD IOL("Updat ing task u id: "_UID)
  21975   "RTN","VPR P3I",153,0 )
  21976    ..D PUT^V PRDJ1(.VPR ,PAT,"task ",.VPRY)
  21977   "RTN","VPR P3I",154,0 )
  21978    K ^TMP($J ,"VPRY"),^ TMP($J,"VP RTEMP")
  21979   "RTN","VPR P3I",155,0 )
  21980    Q
  21981   "RTN","VPR P3I",156,0 )
  21982   ADDRSRC ;  Add resour ce device
  21983   "RTN","VPR P3I",157,0 )
  21984    N RNAME,R DESC,RSLOT ,RTYPE,RIE N
  21985   "RTN","VPR P3I",158,0 )
  21986    S RNAME=" VPR EXTRAC T RESOURCE "
  21987   "RTN","VPR P3I",159,0 )
  21988    S RDESC=" Controls t he number  of VPR ext ract jobs  that run s imultaneou sly."
  21989   "RTN","VPR P3I",160,0 )
  21990    S RSLOT=1 0
  21991   "RTN","VPR P3I",161,0 )
  21992    S RTYPE=" P-OTHER"
  21993   "RTN","VPR P3I",162,0 )
  21994    S RIEN=$$ RES^XUDHSE T(RNAME,RN AME,RSLOT, RDESC,RTYP E)
  21995   "RTN","VPR P3I",163,0 )
  21996    Q
  21997   "RTN","VPR PANEL")
  21998   0^11^B9307 129
  21999   "RTN","VPR PANEL",1,0 )
  22000   VPRPANEL ; SLC/GRR --  Reminder  List proce ssing
  22001   "RTN","VPR PANEL",2,0 )
  22002    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  22003   "RTN","VPR PANEL",3,0 )
  22004    ;
  22005   "RTN","VPR PANEL",4,0 )
  22006    ; Externa l Referenc es           DBIA#
  22007   "RTN","VPR PANEL",5,0 )
  22008    ; ------- ---------- --           -----
  22009   "RTN","VPR PANEL",6,0 )
  22010    ;
  22011   "RTN","VPR PANEL",7,0 )
  22012    ; ------- ----- Get  Panel(s) f rom VistA  ---------- --
  22013   "RTN","VPR PANEL",8,0 )
  22014    ;
  22015   "RTN","VPR PANEL",9,0 )
  22016   EN(VPR) ;  -- find Pa nels to up date
  22017   "RTN","VPR PANEL",10, 0)
  22018    K ^TMP($J ,"VPRPANEL ")
  22019   "RTN","VPR PANEL",11, 0)
  22020    N VPRPAN, VPRPAT,VPR I
  22021   "RTN","VPR PANEL",12, 0)
  22022    S VPR=$NA (^TMP($J," VPR")),VPR C=0,VPRT=0
  22023   "RTN","VPR PANEL",13, 0)
  22024    F  S VPRC =$O(^VPROS TER(VPRC))  Q:VPRC'>0   D
  22025   "RTN","VPR PANEL",14, 0)
  22026    . S VPRT= VPRT+1
  22027   "RTN","VPR PANEL",15, 0)
  22028    . S VPRPA N(VPRC)=^V PROSTER(VP RC,0) D
  22029   "RTN","VPR PANEL",16, 0)
  22030    . N LIEN, PLNAME S L IEN=+$P(VP RPAN(VPRC) ,"^",2),PL NAME=$P(VP RPAN(VPRC) ,U,1)
  22031   "RTN","VPR PANEL",17, 0)
  22032    . ;agp ne ed to dete rmine what  secure an d over sho uld be set  to
  22033   "RTN","VPR PANEL",18, 0)
  22034    . S SECUR E=0,OVER=1
  22035   "RTN","VPR PANEL",19, 0)
  22036    . D RUNLI ST(.VPRPAN ,LIEN,PLNA ME,SECURE, OVER)
  22037   "RTN","VPR PANEL",20, 0)
  22038   CREATE ; - - create p anel(s) in  XML
  22039   "RTN","VPR PANEL",21, 0)
  22040    N VPRVER  S VPRVER=" <results v ersion='"_ $P($T(VPRP ANEL+1),"; ",3)_"'>"
  22041   "RTN","VPR PANEL",22, 0)
  22042    N VPRTTXT  S VPRTTXT ="<panels  total='"_V PRT_"'>"
  22043   "RTN","VPR PANEL",23, 0)
  22044    D ADD(VPR VER),ADD(V PRTTXT)
  22045   "RTN","VPR PANEL",24, 0)
  22046    D PANEL
  22047   "RTN","VPR PANEL",25, 0)
  22048    S TEXT="< /results>"  D ADD(TEX T)
  22049   "RTN","VPR PANEL",26, 0)
  22050    Q
  22051   "RTN","VPR PANEL",27, 0)
  22052    ;
  22053   "RTN","VPR PANEL",28, 0)
  22054   PANEL ;--  create pan el XML
  22055   "RTN","VPR PANEL",29, 0)
  22056    S VPRC=0  F  S VPRC= $O(VPRPAN( VPRC)) Q:V PRC'>0  D
  22057   "RTN","VPR PANEL",30, 0)
  22058    .D ADD("< panel>")
  22059   "RTN","VPR PANEL",31, 0)
  22060    .N TEXT S  TEXT="<pa nel name=' "_$P(VPRPA N(VPRC),"^ ",2)_"' /> " D ADD(TE XT)
  22061   "RTN","VPR PANEL",32, 0)
  22062    .S TEXT=" <panelStri ng code='" _$P(VPRPAN (VPRC),"^" )_"' />" D  ADD(TEXT)
  22063   "RTN","VPR PANEL",33, 0)
  22064    .D PATS
  22065   "RTN","VPR PANEL",34, 0)
  22066    .S TEXT=" </panel>"  D ADD(TEXT )
  22067   "RTN","VPR PANEL",35, 0)
  22068    S TEXT="< /panels>"  D ADD(TEXT )
  22069   "RTN","VPR PANEL",36, 0)
  22070    Q
  22071   "RTN","VPR PANEL",37, 0)
  22072    ;
  22073   "RTN","VPR PANEL",38, 0)
  22074   CREATEPL(P LNAME,SECU RE,OVER) ;
  22075   "RTN","VPR PANEL",39, 0)
  22076    N FDA,IEN S,NAME,NUM ,RESULT,UN IQUE
  22077   "RTN","VPR PANEL",40, 0)
  22078    S (NUM,RE SULT,UNIQU E)=0
  22079   "RTN","VPR PANEL",41, 0)
  22080    ;if overw rite check  to see if  the list  exist
  22081   "RTN","VPR PANEL",42, 0)
  22082    I OVER=1  S RESULT=$ O(^PXRMXP( 810.5,"B", PLNAME,"") )
  22083   "RTN","VPR PANEL",43, 0)
  22084    I RESULT> 0 Q RESULT
  22085   "RTN","VPR PANEL",44, 0)
  22086    S NAME=PL NAME
  22087   "RTN","VPR PANEL",45, 0)
  22088    ;if not o verwrite f ind unique  name
  22089   "RTN","VPR PANEL",46, 0)
  22090    I OVER=0  D
  22091   "RTN","VPR PANEL",47, 0)
  22092    .I $D(^PX RMXP(810.5 ,"B",NAME) )=0 Q
  22093   "RTN","VPR PANEL",48, 0)
  22094    .F  Q:UNI QUE=1  D
  22095   "RTN","VPR PANEL",49, 0)
  22096    ..S NUM=N UM+1
  22097   "RTN","VPR PANEL",50, 0)
  22098    ..S NAME= PLNAME_" ( "_NUM_")"
  22099   "RTN","VPR PANEL",51, 0)
  22100    ..I $D(^P XRMXP(810. 5,"B",NAME ))=0 S UNI QUE=1
  22101   "RTN","VPR PANEL",52, 0)
  22102    ;create s tub in 810 .5
  22103   "RTN","VPR PANEL",53, 0)
  22104    S IENS="+ 1,"
  22105   "RTN","VPR PANEL",54, 0)
  22106    S FDA(810 .5,IENS,.0 1)=NAME
  22107   "RTN","VPR PANEL",55, 0)
  22108    S FDA(810 .5,IENS,10 0)="L"
  22109   "RTN","VPR PANEL",56, 0)
  22110    S FDA(810 .5,IENS,.0 7)=DUZ
  22111   "RTN","VPR PANEL",57, 0)
  22112    S FDA(810 .5,IENS,.0 8)=$S(SECU RE=0:"PUB" ,1:"PVT")
  22113   "RTN","VPR PANEL",58, 0)
  22114    D UPDATE^ DIE("","FD A","","MSG ")
  22115   "RTN","VPR PANEL",59, 0)
  22116    ;if error  display m essage and  quit
  22117   "RTN","VPR PANEL",60, 0)
  22118    I $D(MSG)  D AWRITE^ PXRMUTIL(" MSG") Q 0
  22119   "RTN","VPR PANEL",61, 0)
  22120    S RESULT= $O(^PXRMXP (810.5,"B" ,NAME,""))
  22121   "RTN","VPR PANEL",62, 0)
  22122    Q RESULT
  22123   "RTN","VPR PANEL",63, 0)
  22124    ;
  22125   "RTN","VPR PANEL",64, 0)
  22126   RUNLIST(VP RPAN,LIEN, PLNAME,SEC URE,OVER)  ;
  22127   "RTN","VPR PANEL",65, 0)
  22128    N PLIEN
  22129   "RTN","VPR PANEL",66, 0)
  22130    S PLIEN=$ $CREATEPL( PLNAME,SEC URE,OVER)
  22131   "RTN","VPR PANEL",67, 0)
  22132    S PATCREA T=$S(SECUR E=1:"Y",1: 0),PLISTPU G=1
  22133   "RTN","VPR PANEL",68, 0)
  22134    I PLIEN=0  Q
  22135   "RTN","VPR PANEL",69, 0)
  22136    D RUN^PXR MLCR(LIEN, PLIEN,"PXR MRULE",DT, DT,0,0)
  22137   "RTN","VPR PANEL",70, 0)
  22138    N VPRPAT  S VPRPAT=0
  22139   "RTN","VPR PANEL",71, 0)
  22140    F  S VPRP AT=$O(^PXR MXP(810.5, PLIEN,30,V PRPAT)) Q: VPRPAT'>0   S VPRPAN( VPRC,VPRPA T)=$P($G(^ PXRMXP(810 .5,PLIEN,3 0,VPRPAT,0 )),"^",1)
  22141   "RTN","VPR PANEL",72, 0)
  22142    Q
  22143   "RTN","VPR PANEL",73, 0)
  22144    ;
  22145   "RTN","VPR PANEL",74, 0)
  22146   PATS ; --  create pat ient XML
  22147   "RTN","VPR PANEL",75, 0)
  22148    S TEXT="< patients>"  D ADD(TEX T)
  22149   "RTN","VPR PANEL",76, 0)
  22150    S VPRPAT= 0 F  S VPR PAT=$O(VPR PAN(VPRC,V PRPAT)) D   Q:VPRPAT' >0
  22151   "RTN","VPR PANEL",77, 0)
  22152    .I VPRPAT '>0 S TEXT ="</patien ts>" D ADD (TEXT) Q
  22153   "RTN","VPR PANEL",78, 0)
  22154    .S TEXT=" <patient c ode='"_VPR PAN(VPRC,V PRPAT)_"'  />" D ADD( TEXT)
  22155   "RTN","VPR PANEL",79, 0)
  22156    ;
  22157   "RTN","VPR PANEL",80, 0)
  22158    ;
  22159   "RTN","VPR PANEL",81, 0)
  22160   ADD(X) ; - - Add a li ne @VPR@(n )=X
  22161   "RTN","VPR PANEL",82, 0)
  22162    S VPRI=$G (VPRI)+1
  22163   "RTN","VPR PANEL",83, 0)
  22164    S @VPR@(V PRI)=X
  22165   "RTN","VPR PANEL",84, 0)
  22166    Q
  22167   "RTN","VPR PANEL",85, 0)
  22168    ;
  22169   "RTN","VPR PANEL",86, 0)
  22170   NITELY ; - - Nightly  run to upd ate all Pa nels
  22171   "RTN","VPR PANEL",87, 0)
  22172    ; 
  22173   "RTN","VPR PARAM")
  22174   0^59^B1543 6113
  22175   "RTN","VPR PARAM",1,0 )
  22176   VPRPARAM ;  SLC/AGP -  Parameter  routine.  ; 8/16/12  7:09pm
  22177   "RTN","VPR PARAM",2,0 )
  22178    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  22179   "RTN","VPR PARAM",3,0 )
  22180    Q
  22181   "RTN","VPR PARAM",4,0 )
  22182    ;
  22183   "RTN","VPR PARAM",5,0 )
  22184    ;
  22185   "RTN","VPR PARAM",6,0 )
  22186   BLDENT(UID ,ENTITY) ;
  22187   "RTN","VPR PARAM",7,0 )
  22188    ;urn:va:p aram:F484: 1120:VPR U SER PREF
  22189   "RTN","VPR PARAM",8,0 )
  22190    ;urn:va:p aram:F484: 1120:VPR R OSTER PREF :13
  22191   "RTN","VPR PARAM",9,0 )
  22192    ;urn:va:p aram:F484: SYS:VPR US ER PREF
  22193   "RTN","VPR PARAM",10, 0)
  22194    S ENTITY( "uid")=UID
  22195   "RTN","VPR PARAM",11, 0)
  22196    I +$P(UID ,":",5)>0  D  Q
  22197   "RTN","VPR PARAM",12, 0)
  22198    .S ENTITY ("entity") ="USR"
  22199   "RTN","VPR PARAM",13, 0)
  22200    .S ENTITY ("entityId ")=$P(UID, ":",5)
  22201   "RTN","VPR PARAM",14, 0)
  22202    S ENTITY( "entity")= "SYS"
  22203   "RTN","VPR PARAM",15, 0)
  22204    Q
  22205   "RTN","VPR PARAM",16, 0)
  22206    ;
  22207   "RTN","VPR PARAM",17, 0)
  22208   BUILDUID(V ALUES,TYPE ,ID) ;
  22209   "RTN","VPR PARAM",18, 0)
  22210    N DOMAIN
  22211   "RTN","VPR PARAM",19, 0)
  22212    S DOMAIN= $$BASE^XLF UTL($$CRC1 6^XLFCRC($ $KSP^XUPAR AM("WHERE" )),10,16)
  22213   "RTN","VPR PARAM",20, 0)
  22214    S VALUES( "uid")="ur n:va:"_TYP E_":"_DOMA IN_":"_ID
  22215   "RTN","VPR PARAM",21, 0)
  22216    Q
  22217   "RTN","VPR PARAM",22, 0)
  22218    ;
  22219   "RTN","VPR PARAM",23, 0)
  22220   DELPARAM(R ESULT,UID)  ;
  22221   "RTN","VPR PARAM",24, 0)
  22222    N ARRAY,E NT,ENTITY, ENTVALUE,E RR,STR,VPR ERR
  22223   "RTN","VPR PARAM",25, 0)
  22224    D BLDENT( UID,.ARRAY )
  22225   "RTN","VPR PARAM",26, 0)
  22226    ;delete o ld paramet er
  22227   "RTN","VPR PARAM",27, 0)
  22228    S ENTITY= ARRAY("ent ity")
  22229   "RTN","VPR PARAM",28, 0)
  22230    S ENTVALU E=ARRAY("e ntityId")
  22231   "RTN","VPR PARAM",29, 0)
  22232    S ENT=$S( $G(ENTVALU E)>0:ENTIT Y_".`"_ENT VALUE,1:EN TITY)
  22233   "RTN","VPR PARAM",30, 0)
  22234    I $G(ARRA Y("uid"))= "" Q
  22235   "RTN","VPR PARAM",31, 0)
  22236    I $G(ENT) ="" Q
  22237   "RTN","VPR PARAM",32, 0)
  22238    D DEL^XPA R(ENT,"VPR  PARAMETER S",ARRAY(" uid"),.VPR ERR)
  22239   "RTN","VPR PARAM",33, 0)
  22240    Q
  22241   "RTN","VPR PARAM",34, 0)
  22242    ;
  22243   "RTN","VPR PARAM",35, 0)
  22244   GETALPAR(J SONRES,ENT ITY,ENTVAL UE,RETVALU E) ;
  22245   "RTN","VPR PARAM",36, 0)
  22246    N CNT,DEC ODE,ENT,GE TVAL,INST, PARAM,RESU LT,VPRERR, VPRLIST
  22247   "RTN","VPR PARAM",37, 0)
  22248    S ENT=$S( $G(ENTVALU E)'="":ENT ITY_".`"_E NTVALUE,1: ENTITY)
  22249   "RTN","VPR PARAM",38, 0)
  22250    D GETLST^ XPAR(.VPRL IST,ENT,"V PR PARAMET ERS","I")
  22251   "RTN","VPR PARAM",39, 0)
  22252    I VPRLIST =0 Q
  22253   "RTN","VPR PARAM",40, 0)
  22254    S GETVAL= $S(RETVALU E="true":1 ,1:0)
  22255   "RTN","VPR PARAM",41, 0)
  22256    I GETVAL= 0 D   Q
  22257   "RTN","VPR PARAM",42, 0)
  22258    .S CNT=0, INST="" F   S INST=$O (VPRLIST(I NST)) Q:IN ST=""  S J SONRES(CNT )=INST,CNT =CNT+1
  22259   "RTN","VPR PARAM",43, 0)
  22260    S CNT=0,I NST="" F   S INST=$O( VPRLIST(IN ST)) Q:INS T=""  D
  22261   "RTN","VPR PARAM",44, 0)
  22262    .S CNT=CN T+1
  22263   "RTN","VPR PARAM",45, 0)
  22264    .S RESULT ("params", CNT,"uid") =INST
  22265   "RTN","VPR PARAM",46, 0)
  22266    .D GETPAR AM(.PARAM, "VPR PARAM ETERS",ENT ITY,ENTVAL UE,INST)
  22267   "RTN","VPR PARAM",47, 0)
  22268    .I '$D(PA RAM) Q
  22269   "RTN","VPR PARAM",48, 0)
  22270    .M RESULT ("params", CNT,"value ",":")=PAR AM
  22271   "RTN","VPR PARAM",49, 0)
  22272    .K PARAM
  22273   "RTN","VPR PARAM",50, 0)
  22274    I '$D(RES ULT) Q ""
  22275   "RTN","VPR PARAM",51, 0)
  22276    S RESULT( "success") ="true"
  22277   "RTN","VPR PARAM",52, 0)
  22278    D ENCODE^ VPRJSON("R ESULT","JS ONRES","VP RERR")
  22279   "RTN","VPR PARAM",53, 0)
  22280    I $D(VPRE RR) K JSON RES S TXT( 1)="Proble m encoding  results t o json for mat." D SE TERROR(.RE SULT,.VPRE RR,.TXT,.J SONRES) Q
  22281   "RTN","VPR PARAM",54, 0)
  22282    Q
  22283   "RTN","VPR PARAM",55, 0)
  22284    ;
  22285   "RTN","VPR PARAM",56, 0)
  22286   GETPARAM(R ESULT,NAME ,ENTITY,EN TVALUE,INS T) ; Get v alue for a  param
  22287   "RTN","VPR PARAM",57, 0)
  22288    N CNT,ENT ,FORMAT,IE N,VPRPAR,V PRERR
  22289   "RTN","VPR PARAM",58, 0)
  22290    ;S IEN=$O (^XTV(8989 .51,"B",NA ME,"")) Q: IEN'>0
  22291   "RTN","VPR PARAM",59, 0)
  22292    S FORMAT= "I"
  22293   "RTN","VPR PARAM",60, 0)
  22294    ;D BLDLST ^XPAREDIT( .VPRPAR,IE N
  22295   "RTN","VPR PARAM",61, 0)
  22296    S ENT=$S( $G(ENTVALU E)'="":ENT ITY_".`"_E NTVALUE,1: ENTITY)
  22297   "RTN","VPR PARAM",62, 0)
  22298    D GETWP^X PAR(.VPRAR ,ENT,NAME, INST,.VPRE RR)
  22299   "RTN","VPR PARAM",63, 0)
  22300    S CNT=0 F   S CNT=$O (VPRAR(CNT )) Q:CNT'> 0  D
  22301   "RTN","VPR PARAM",64, 0)
  22302    .S RESULT (CNT)=VPRA R(CNT,0)
  22303   "RTN","VPR PARAM",65, 0)
  22304    Q
  22305   "RTN","VPR PARAM",66, 0)
  22306    ;
  22307   "RTN","VPR PARAM",67, 0)
  22308   GETBYUID(R ESULT,UID)  ;
  22309   "RTN","VPR PARAM",68, 0)
  22310    N ENTITY
  22311   "RTN","VPR PARAM",69, 0)
  22312    D BLDENT( UID,.ENTIT Y)
  22313   "RTN","VPR PARAM",70, 0)
  22314    D GETPARA M(.RESULT, "VPR PARAM ETERS",$G( ENTITY("en tity")),$G (ENTITY("e ntityId")) ,$G(ENTITY ("uid")))
  22315   "RTN","VPR PARAM",71, 0)
  22316    ;I $D(RES ULT)<10 S  RESULT(0)= "{}"
  22317   "RTN","VPR PARAM",72, 0)
  22318    Q
  22319   "RTN","VPR PARAM",73, 0)
  22320    ;
  22321   "RTN","VPR PARAM",74, 0)
  22322   PARSEJSN(V ALUE,ARRAY ,ERR) ;
  22323   "RTN","VPR PARAM",75, 0)
  22324    N ERROR,J SON,TXT
  22325   "RTN","VPR PARAM",76, 0)
  22326    D DECODE^ VPRJSON("V ALUE","ARR AY","ERROR ")
  22327   "RTN","VPR PARAM",77, 0)
  22328    I $D(ERR)  K ARRAY S  TXT(1)="P roblem dec oding json  value." D  SETERROR( .VALUE,.ER ROR,.TXT,. ERR) Q 0
  22329   "RTN","VPR PARAM",78, 0)
  22330    Q 1
  22331   "RTN","VPR PARAM",79, 0)
  22332    ;
  22333   "RTN","VPR PARAM",80, 0)
  22334   PUTPARAM(R ESULT,VALU E,ENTARR)  ;
  22335   "RTN","VPR PARAM",81, 0)
  22336    N CNT,ENT ,ENTITY,EN TVALUE,ERR ,STR,VPRER R,X
  22337   "RTN","VPR PARAM",82, 0)
  22338    I $D(ENTA RR)<10 I $ $PARSEJSN( .VALUE,.EN TARR,.ERR) =0 M RESUL T=ERR Q
  22339   "RTN","VPR PARAM",83, 0)
  22340    ;delete o ld paramet er
  22341   "RTN","VPR PARAM",84, 0)
  22342    S ENTITY= ENTARR("en tity")
  22343   "RTN","VPR PARAM",85, 0)
  22344    S ENTVALU E=ENTARR(" entityId")
  22345   "RTN","VPR PARAM",86, 0)
  22346    S ENT=$S( $G(ENTVALU E)>0:ENTIT Y_".`"_ENT VALUE,1:EN TITY)
  22347   "RTN","VPR PARAM",87, 0)
  22348    D DEL^XPA R(ENT,"VPR  PARAMETER S",ENTARR( "uid"),.VP RERR)
  22349   "RTN","VPR PARAM",88, 0)
  22350    S CNT=$O( VALUE(""), -1) I CNT= "" S STR(1 ,0)=VALUE
  22351   "RTN","VPR PARAM",89, 0)
  22352    I CNT>0 F  X=0:1:CNT  S STR(X+1 ,0)=VALUE( X)
  22353   "RTN","VPR PARAM",90, 0)
  22354    D PUT^XPA R(ENT,"VPR  PARAMETER S",ENTARR( "uid"),.ST R,.VPRERR)
  22355   "RTN","VPR PARAM",91, 0)
  22356    S RESULT( 0)="{""suc cess"":""t rue""}"
  22357   "RTN","VPR PARAM",92, 0)
  22358    Q
  22359   "RTN","VPR PARAM",93, 0)
  22360    ;
  22361   "RTN","VPR PARAM",94, 0)
  22362   PUTBYUID(R ESULT,UID, VALUE) ;
  22363   "RTN","VPR PARAM",95, 0)
  22364    N ENTITY
  22365   "RTN","VPR PARAM",96, 0)
  22366    D BLDENT( UID,.ENTIT Y)
  22367   "RTN","VPR PARAM",97, 0)
  22368    D PUTPARA M(.RESULT, .VALUE,.EN TITY)
  22369   "RTN","VPR PARAM",98, 0)
  22370    Q
  22371   "RTN","VPR PARAM",99, 0)
  22372    ;
  22373   "RTN","VPR PARAM",100 ,0)
  22374   SETERROR(I NPDATA,ERR ORMSG,TXT, OUTPUT) ;
  22375   "RTN","VPR PARAM",101 ,0)
  22376    N ERRARR
  22377   "RTN","VPR PARAM",102 ,0)
  22378    D SETERRO R^VPRUTILS (.ERRARR,. ERRORMSG,. TXT,.INPDA TA)
  22379   "RTN","VPR PARAM",103 ,0)
  22380    D ENCODE^ VPRJSON("E RRARR","OU TPUT","ERR OR")
  22381   "RTN","VPR PARAM",104 ,0)
  22382    Q
  22383   "RTN","VPR PATS")
  22384   0^3^B44568 818
  22385   "RTN","VPR PATS",1,0)
  22386   VPRPATS ;S LC/MKB --  Patient Ma nagement U tilities
  22387   "RTN","VPR PATS",2,0)
  22388    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  22389   "RTN","VPR PATS",3,0)
  22390    ;
  22391   "RTN","VPR PATS",4,0)
  22392    ; Externa l Referenc es           DBIA#
  22393   "RTN","VPR PATS",5,0)
  22394    ; ------- ---------- --           -----
  22395   "RTN","VPR PATS",6,0)
  22396    ; ^DGS(41 .1                       3796
  22397   "RTN","VPR PATS",7,0)
  22398    ; ^DPT                            10035
  22399   "RTN","VPR PATS",8,0)
  22400    ; ^OR(100 .21
  22401   "RTN","VPR PATS",9,0)
  22402    ; ^PXRMXP (810.5
  22403   "RTN","VPR PATS",10,0 )
  22404    ; ^SC                             10040
  22405   "RTN","VPR PATS",11,0 )
  22406    ; ^SCTM(4 04.51                   +2936? > >or use FI ND^DIC?
  22407   "RTN","VPR PATS",12,0 )
  22408    ; DICN                            10009
  22409   "RTN","VPR PATS",13,0 )
  22410    ; MPIF001                          2701
  22411   "RTN","VPR PATS",14,0 )
  22412    ; SCAPMC                           1916
  22413   "RTN","VPR PATS",15,0 )
  22414    ; SDAMA30 1                        4433
  22415   "RTN","VPR PATS",16,0 )
  22416    ; XLFDT                           10103
  22417   "RTN","VPR PATS",17,0 )
  22418    ; XPAR                             2263
  22419   "RTN","VPR PATS",18,0 )
  22420    ; XUAF4                            2171
  22421   "RTN","VPR PATS",19,0 )
  22422    ;
  22423   "RTN","VPR PATS",20,0 )
  22424   APPT ; --  Return pat ients w/ap pointments  tomorrow
  22425   "RTN","VPR PATS",21,0 )
  22426    ; OPT = V PR APPOINT MENTS
  22427   "RTN","VPR PATS",22,0 )
  22428    N NOW,NOW 1,VPRX,VPR L,VPRN,DFN ,DA,TOKEN, NEW,X
  22429   "RTN","VPR PATS",23,0 )
  22430    S NOW=$$N OW^XLFDT,N OW1=$$FMAD D^XLFDT(NO W,1)
  22431   "RTN","VPR PATS",24,0 )
  22432    S VPRX(1) =NOW_";"_N OW1 ;next  24hours
  22433   "RTN","VPR PATS",25,0 )
  22434    S VPRX("F LDS")=1,VP RX("SORT") ="P",VPRX( 3)="R;I;NT "
  22435   "RTN","VPR PATS",26,0 )
  22436    ; ck para meter for  desired lo cation(s):  VPRX(2)=" loc1;loc2; ...;loc#"
  22437   "RTN","VPR PATS",27,0 )
  22438    D GETLST^ XPAR(.VPRL ,"ALL","VP R LOCATION S") I +$G( VPRL) D
  22439   "RTN","VPR PATS",28,0 )
  22440    . S X=+$G (VPRL(1)), VPRX(2)=$S ($D(^SC(X, 0)):X,1:"" )
  22441   "RTN","VPR PATS",29,0 )
  22442    . F I=2:1 :+VPRL S X =+$G(VPRL( I)) S:$D(^ SC(X,0)) V PRX(2)=VPR X(2)_";"_X
  22443   "RTN","VPR PATS",30,0 )
  22444    S VPRN=$$ SDAPI^SDAM A301(.VPRX ) Q:VPRN<1
  22445   "RTN","VPR PATS",31,0 )
  22446    S DFN=0 F   S DFN=$O (^TMP($J," SDAMA301", DFN)) Q:DF N<1  D
  22447   "RTN","VPR PATS",32,0 )
  22448    . S DA=0  F  S DA=$O (^VPR(560, DA)) Q:DA< 1  I $P($G (^(DA,0)), U,2) D
  22449   "RTN","VPR PATS",33,0 )
  22450    .. Q:$D(^ VPR(560,"A DFN",DFN,D A))  ;alre ady subscr ibed
  22451   "RTN","VPR PATS",34,0 )
  22452    .. S TOKE N=DA_"~"_N OW,NEW(TOK EN)=""
  22453   "RTN","VPR PATS",35,0 )
  22454    .. S ^XTM P("VPRX",T OKEN,DFN)= ""
  22455   "RTN","VPR PATS",36,0 )
  22456    I $D(NEW)  D SEND^VP RHTTP(.NEW ) ;send po ke to each  URL with  list TOKEN
  22457   "RTN","VPR PATS",37,0 )
  22458    Q
  22459   "RTN","VPR PATS",38,0 )
  22460    ;
  22461   "RTN","VPR PATS",39,0 )
  22462   ADM(DFN) ;  -- Return  new inpat ient [from  DGPM^VPRE VNT]
  22463   "RTN","VPR PATS",40,0 )
  22464    N NOW,DA, TOKEN,NEW
  22465   "RTN","VPR PATS",41,0 )
  22466    S NOW=$$N OW^XLFDT,D FN=+$G(DFN )
  22467   "RTN","VPR PATS",42,0 )
  22468    S DA=0 F   S DA=$O(^ VPR(560,DA )) Q:DA<1   I $P($G(^ (DA,0)),U, 3) D
  22469   "RTN","VPR PATS",43,0 )
  22470    . Q:$D(^V PR(560,"AD FN",DFN,DA ))  ;alrea dy subscri bed
  22471   "RTN","VPR PATS",44,0 )
  22472    . S TOKEN =DA_"~"_NO W,NEW(TOKE N)=""
  22473   "RTN","VPR PATS",45,0 )
  22474    . S ^XTMP ("VPRX",TO KEN,DFN)=" "
  22475   "RTN","VPR PATS",46,0 )
  22476    I $D(NEW)  D SEND^VP RHTTP(.NEW ) ;send po ke to each  URL with  list TOKEN
  22477   "RTN","VPR PATS",47,0 )
  22478    Q
  22479   "RTN","VPR PATS",48,0 )
  22480    ;
  22481   "RTN","VPR PATS",49,0 )
  22482   GTALLLST(V PR,VPRTYPE ) ;
  22483   "RTN","VPR PATS",50,0 )
  22484    S VPR=$NA (^TMP($J," VPR")) K @ VPR
  22485   "RTN","VPR PATS",51,0 )
  22486    N VPRI,VP RSITE,VPRU SER,VPRSTA
  22487   "RTN","VPR PATS",52,0 )
  22488    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2)),VPR I=0
  22489   "RTN","VPR PATS",53,0 )
  22490    D ADD("<r esults>")
  22491   "RTN","VPR PATS",54,0 )
  22492    I $D(VPRT YPE("ALL") )>0 S (VPR TYPE("OR") ,VPRTYPE(" PXRM"),VPR TYPE("PCMM "))=""
  22493   "RTN","VPR PATS",55,0 )
  22494    D ADD("<l ists>")
  22495   "RTN","VPR PATS",56,0 )
  22496    I $D(VPRT YPE("OR")) >0 D GETOE RRL
  22497   "RTN","VPR PATS",57,0 )
  22498    I $D(VPRT YPE("PXRM" ))>0 D GET PXRML
  22499   "RTN","VPR PATS",58,0 )
  22500    I $D(VPRT YPE("PCMM" ))>0 D GET PCMML
  22501   "RTN","VPR PATS",59,0 )
  22502    D ADD("</ lists>")
  22503   "RTN","VPR PATS",60,0 )
  22504    D ADD("</ results>")
  22505   "RTN","VPR PATS",61,0 )
  22506    Q
  22507   "RTN","VPR PATS",62,0 )
  22508    ;
  22509   "RTN","VPR PATS",63,0 )
  22510   GETLSTPT(V PR,VPRLIST ) ;
  22511   "RTN","VPR PATS",64,0 )
  22512    S VPR=$NA (^TMP($J," VPR")) K @ VPR
  22513   "RTN","VPR PATS",65,0 )
  22514    N GBL,IEN ,TAG,VPRI, VPRSITE,VP RUSER,VPRS TA
  22515   "RTN","VPR PATS",66,0 )
  22516    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2)),VPR I=0
  22517   "RTN","VPR PATS",67,0 )
  22518    D ADD("<r esults>")
  22519   "RTN","VPR PATS",68,0 )
  22520    S GBL=VPR LIST("glob al"),IEN=V PRLIST("ie n")
  22521   "RTN","VPR PATS",69,0 )
  22522    S TAG=$S( GBL="OR":" GETOERRP", GBL="PXRMX P":"GETPXR MP",GBL="P CMM":"GETP CMMP",1:"" )
  22523   "RTN","VPR PATS",70,0 )
  22524    I TAG'="" ,IEN'="" D  @(TAG_"(I EN)")
  22525   "RTN","VPR PATS",71,0 )
  22526    D ADD("</ results>")
  22527   "RTN","VPR PATS",72,0 )
  22528    Q
  22529   "RTN","VPR PATS",73,0 )
  22530    Q
  22531   "RTN","VPR PATS",74,0 )
  22532    ;
  22533   "RTN","VPR PATS",75,0 )
  22534   GETPCMML ;
  22535   "RTN","VPR PATS",76,0 )
  22536    N NAME,IE N
  22537   "RTN","VPR PATS",77,0 )
  22538    S NAME=""  F  S NAME =$O(^SCTM( 404.51,"B" ,NAME)) Q: NAME=""  D
  22539   "RTN","VPR PATS",78,0 )
  22540    .S IEN=$O (^SCTM(404 .51,"B",NA ME,"")) Q: IEN'>0
  22541   "RTN","VPR PATS",79,0 )
  22542    .D ADD("< list value ='"_NAME_" ' id='"_IE N_"' globa l='PCMM'/> ")
  22543   "RTN","VPR PATS",80,0 )
  22544    Q
  22545   "RTN","VPR PATS",81,0 )
  22546    ;
  22547   "RTN","VPR PATS",82,0 )
  22548   GETPCMMP(I EN) ;
  22549   "RTN","VPR PATS",83,0 )
  22550    N DFN,OK, VPRERR,VPR X
  22551   "RTN","VPR PATS",84,0 )
  22552    K ^TMP($J ,"PCM")
  22553   "RTN","VPR PATS",85,0 )
  22554    S OK=$$PT TM^SCAPMC( IEN,"SCDT" ,"^TMP($J, ""PCM"")", .VPRERR)
  22555   "RTN","VPR PATS",86,0 )
  22556    I OK'>0 Q
  22557   "RTN","VPR PATS",87,0 )
  22558    S DFN=0 F   S DFN=$O (^TMP($J," PCM","SCPT A",DFN)) Q :DFN'>0  D
  22559   "RTN","VPR PATS",88,0 )
  22560    .S VPRX(D FN)=""
  22561   "RTN","VPR PATS",89,0 )
  22562    D XML(.VP RX)
  22563   "RTN","VPR PATS",90,0 )
  22564    Q
  22565   "RTN","VPR PATS",91,0 )
  22566    ;
  22567   "RTN","VPR PATS",92,0 )
  22568   GETPXRML ;
  22569   "RTN","VPR PATS",93,0 )
  22570    N NAME,IE N
  22571   "RTN","VPR PATS",94,0 )
  22572    S NAME=""  F  S NAME =$O(^PXRMX P(810.5,"B ",NAME)) Q :NAME=""   D
  22573   "RTN","VPR PATS",95,0 )
  22574    .S IEN=$O (^PXRMXP(8 10.5,"B",N AME,"")) Q :IEN'>0
  22575   "RTN","VPR PATS",96,0 )
  22576    .D ADD("< list value ='"_NAME_" ' id='"_IE N_"' globa l='PXRMXP' />")
  22577   "RTN","VPR PATS",97,0 )
  22578    Q
  22579   "RTN","VPR PATS",98,0 )
  22580    ;
  22581   "RTN","VPR PATS",99,0 )
  22582   GETPXRMP(I EN) ;
  22583   "RTN","VPR PATS",100, 0)
  22584    N CNT,VPR X
  22585   "RTN","VPR PATS",101, 0)
  22586    S CNT=0 F   S CNT=$O (^PXRMXP(8 10.5,IEN,3 0,CNT)) Q: CNT'>0  D
  22587   "RTN","VPR PATS",102, 0)
  22588    .S VPRX(+ $G(^PXRMXP (810.5,IEN ,30,CNT,0) ))=""
  22589   "RTN","VPR PATS",103, 0)
  22590    D XML(.VP RX)
  22591   "RTN","VPR PATS",104, 0)
  22592    Q
  22593   "RTN","VPR PATS",105, 0)
  22594    ;
  22595   "RTN","VPR PATS",106, 0)
  22596   GETOERRL ;
  22597   "RTN","VPR PATS",107, 0)
  22598    N NAME,IE N
  22599   "RTN","VPR PATS",108, 0)
  22600    S NAME=""  F  S NAME =$O(^OR(10 0.21,"B",N AME)) Q:NA ME=""  D
  22601   "RTN","VPR PATS",109, 0)
  22602    .S IEN=$O (^OR(100.2 1,"B",NAME ,"")) Q:IE N'>0
  22603   "RTN","VPR PATS",110, 0)
  22604    .D ADD("< list value ='"_NAME_" ' id='"_IE N_"' globa l='OR'/>")
  22605   "RTN","VPR PATS",111, 0)
  22606    Q
  22607   "RTN","VPR PATS",112, 0)
  22608    ;
  22609   "RTN","VPR PATS",113, 0)
  22610   GETOERRP(I EN) ;
  22611   "RTN","VPR PATS",114, 0)
  22612    N CNT,VPR X
  22613   "RTN","VPR PATS",115, 0)
  22614    S CNT=0 F   S CNT=$O (^OR(100.2 1,IEN,10,C NT)) Q:CNT '>0  D
  22615   "RTN","VPR PATS",116, 0)
  22616    .S VPRX(+ $G(^OR(100 .21,IEN,10 ,CNT,0)))= ""
  22617   "RTN","VPR PATS",117, 0)
  22618    D XML(.VP RX)
  22619   "RTN","VPR PATS",118, 0)
  22620    Q
  22621   "RTN","VPR PATS",119, 0)
  22622    ;
  22623   "RTN","VPR PATS",120, 0)
  22624   IN(VPR) ;  -- Return  current in patients
  22625   "RTN","VPR PATS",121, 0)
  22626    ; RPC = V PR INPATIE NTS
  22627   "RTN","VPR PATS",122, 0)
  22628    N WARD,DF N,VPRX,VPR I
  22629   "RTN","VPR PATS",123, 0)
  22630    S WARD=""  F  S WARD =$O(^DPT(" CN",WARD))  Q:WARD=""   D
  22631   "RTN","VPR PATS",124, 0)
  22632    . S DFN=0  F  S DFN= $O(^DPT("C N",WARD,DF N)) Q:DFN< 1  S VPRX( DFN)=""
  22633   "RTN","VPR PATS",125, 0)
  22634    S VPR=$NA (^TMP($J," VPR")) K @ VPR
  22635   "RTN","VPR PATS",126, 0)
  22636    D XML(.VP RX)
  22637   "RTN","VPR PATS",127, 0)
  22638    Q
  22639   "RTN","VPR PATS",128, 0)
  22640    ;
  22641   "RTN","VPR PATS",129, 0)
  22642   OUT(VPR,BE G,END) ; - - Return p atients w/ appointmen ts [tomorr ow]
  22643   "RTN","VPR PATS",130, 0)
  22644    ; RPC = V PR APPOINT MENTS
  22645   "RTN","VPR PATS",131, 0)
  22646    N VPRX,VP RN,DFN,VPR DT,VPRI,VP RA
  22647   "RTN","VPR PATS",132, 0)
  22648    I '$G(BEG ) D   ;def ault = tom orrow, if  not passed  in
  22649   "RTN","VPR PATS",133, 0)
  22650    . S BEG=$ $FMADD^XLF DT(DT,1),E ND=BEG
  22651   "RTN","VPR PATS",134, 0)
  22652    ; find pa tients wit h appointm ents
  22653   "RTN","VPR PATS",135, 0)
  22654    S END=$G( END,BEG),V PRX(1)=BEG _";"_END
  22655   "RTN","VPR PATS",136, 0)
  22656    S VPRX("S ORT")="P", VPRX("FLDS ")=1,VPRX( 3)="R;I;NT "
  22657   "RTN","VPR PATS",137, 0)
  22658    S VPRN=$$ SDAPI^SDAM A301(.VPRX ) Q:VPRN<1   K VPRX
  22659   "RTN","VPR PATS",138, 0)
  22660    S DFN=0 F   S DFN=$O (^TMP($J," SDAMA301", DFN)) Q:DF N<1  S VPR X(DFN)=""
  22661   "RTN","VPR PATS",139, 0)
  22662    ; find pa tients sch eduled for  admission
  22663   "RTN","VPR PATS",140, 0)
  22664    S VPRDT=0  F  S VPRD T=$O(^DGS( 41.1,"C",V PRDT)) Q:V PRDT<1!(VP RDT>END)   D
  22665   "RTN","VPR PATS",141, 0)
  22666    . S VPRI= 0 F  S VPR I=$O(^DGS( 41.1,"C",V PRDT,VPRI) ) Q:VPRI<1   D
  22667   "RTN","VPR PATS",142, 0)
  22668    .. S VPRA =$G(^DGS(4 1.1,VPRI))
  22669   "RTN","VPR PATS",143, 0)
  22670    .. Q:$P(V PRA,U,13)   Q:$P(VPRA ,U,17)  ;c ancelled o r admitted
  22671   "RTN","VPR PATS",144, 0)
  22672    .. S DFN= +VPRA S:DF N VPRX(DFN )=""
  22673   "RTN","VPR PATS",145, 0)
  22674    ; return  list
  22675   "RTN","VPR PATS",146, 0)
  22676    S VPR=$NA (^TMP($J," VPR")) K @ VPR
  22677   "RTN","VPR PATS",147, 0)
  22678    D XML(.VP RX)
  22679   "RTN","VPR PATS",148, 0)
  22680    Q
  22681   "RTN","VPR PATS",149, 0)
  22682    ;
  22683   "RTN","VPR PATS",150, 0)
  22684   XML(PATIEN T) ; -- Re turn patie nt list as  XML
  22685   "RTN","VPR PATS",151, 0)
  22686    N DFN,ICN ,Y
  22687   "RTN","VPR PATS",152, 0)
  22688    D ADD("<p atients>")
  22689   "RTN","VPR PATS",153, 0)
  22690    S DFN=0 F   S DFN=$O (PATIENT(D FN)) Q:DFN <1  D
  22691   "RTN","VPR PATS",154, 0)
  22692    . S ICN=$ $GETICN^MP IF001(DFN)
  22693   "RTN","VPR PATS",155, 0)
  22694    . S Y="<p atient id= '"_DFN_$S( ICN:"' icn ='"_ICN,1: "")_"' />"  D ADD(Y)
  22695   "RTN","VPR PATS",156, 0)
  22696    D ADD("</ patients>" )
  22697   "RTN","VPR PATS",157, 0)
  22698    Q
  22699   "RTN","VPR PATS",158, 0)
  22700    ;
  22701   "RTN","VPR PATS",159, 0)
  22702   SUBS(VPR,S YS,ON,LIST ) ; -- Un/ Subscribe  to Patient  Data Moni tor
  22703   "RTN","VPR PATS",160, 0)
  22704    ; RPC = V PR SUBSCRI BE
  22705   "RTN","VPR PATS",161, 0)
  22706    N DA,I,IC N,DFN,HDR, VPRI
  22707   "RTN","VPR PATS",162, 0)
  22708    S SYS=$G( SYS),ON=+$ G(ON) Q:'$ L(SYS)
  22709   "RTN","VPR PATS",163, 0)
  22710    S DA=$$FI ND(SYS) Q: DA<1
  22711   "RTN","VPR PATS",164, 0)
  22712    S VPR=$NA (^TMP("VPR ",$J)) K @ VPR
  22713   "RTN","VPR PATS",165, 0)
  22714    S:'$D(^XT MP("VPR"))  ^XTMP("VP R",0)="399 1231^"_DT_ "^VPR Pati ent Data M onitor"
  22715   "RTN","VPR PATS",166, 0)
  22716    ;
  22717   "RTN","VPR PATS",167, 0)
  22718    ; loop th rough LIST (n) = 'dfn ;icn'
  22719   "RTN","VPR PATS",168, 0)
  22720    D ADD("<p atients>")
  22721   "RTN","VPR PATS",169, 0)
  22722    S I="" F   S I=$O(LI ST(I)) Q:I =""  S DFN =LIST(I) D
  22723   "RTN","VPR PATS",170, 0)
  22724    . S ICN=+ $P(DFN,";" ,2),DFN=+$ G(DFN)
  22725   "RTN","VPR PATS",171, 0)
  22726    . I 'DFN  S DFN=+$$G ETDFN^MPIF 001(ICN)
  22727   "RTN","VPR PATS",172, 0)
  22728    . I DFN<1 !'$D(^DPT( DFN)) D RE T(DFN,"err or") Q
  22729   "RTN","VPR PATS",173, 0)
  22730    . I ON D   Q
  22731   "RTN","VPR PATS",174, 0)
  22732    .. S:'$D( ^VPR(560,D A,1,DFN,0) ) HDR=$G(^ VPR(560,DA ,1,0)),^(0 )="^560.01 P^"_DFN_U_ ($P(HDR,U, 4)+1)
  22733   "RTN","VPR PATS",175, 0)
  22734    .. S ^VPR (560,DA,1, DFN,0)=DFN _U_ON,^VPR (560,"ADFN ",DFN,DA)= ""
  22735   "RTN","VPR PATS",176, 0)
  22736    .. D RET( DFN,"on")
  22737   "RTN","VPR PATS",177, 0)
  22738    . ; else,  remove pa tient trac king info  from ^XTMP
  22739   "RTN","VPR PATS",178, 0)
  22740    . S:$D(^V PR(560,DA, 1,DFN,0))  $P(^(0),U, 2)=0
  22741   "RTN","VPR PATS",179, 0)
  22742    . K ^VPR( 560,"ADFN" ,DFN,DA)
  22743   "RTN","VPR PATS",180, 0)
  22744    . D RET(D FN,"off")
  22745   "RTN","VPR PATS",181, 0)
  22746    D ADD("</ patients>" )
  22747   "RTN","VPR PATS",182, 0)
  22748    Q
  22749   "RTN","VPR PATS",183, 0)
  22750    ;
  22751   "RTN","VPR PATS",184, 0)
  22752   FIND(ID) ;  -- Return  ien of sy stem ID in  ^VPR
  22753   "RTN","VPR PATS",185, 0)
  22754    N DA,DO,D IC,X,Y
  22755   "RTN","VPR PATS",186, 0)
  22756    I $G(ID)= "" Q 0                           ;error
  22757   "RTN","VPR PATS",187, 0)
  22758    S DA=+$O( ^VPR(560," B",ID,0))  I DA<1 D   ;add
  22759   "RTN","VPR PATS",188, 0)
  22760    . S DIC=" ^VPR(560," ,DIC(0)="F ",X=ID
  22761   "RTN","VPR PATS",189, 0)
  22762    . D FILE^ DICN S DA= +Y
  22763   "RTN","VPR PATS",190, 0)
  22764    Q DA
  22765   "RTN","VPR PATS",191, 0)
  22766    ;
  22767   "RTN","VPR PATS",192, 0)
  22768   ZFIND(URL)  ; -- Retu rn ien of  URL in ^VP R
  22769   "RTN","VPR PATS",193, 0)
  22770    N NAME,DA  S NAME=$G (URL)
  22771   "RTN","VPR PATS",194, 0)
  22772    S:NAME?1" http".E NA ME=$P(NAME ,"/",3) S: NAME[":" N AME=$P(NAM E,":")
  22773   "RTN","VPR PATS",195, 0)
  22774    S DA=0 F   S DA=$O(^ VPR(560,"B ",NAME,DA) ) Q:DA<1   I $G(^VPR( 560,DA,.1) )=URL Q
  22775   "RTN","VPR PATS",196, 0)
  22776    I DA<1 D   ;add
  22777   "RTN","VPR PATS",197, 0)
  22778    . N DO,DI C,X,Y
  22779   "RTN","VPR PATS",198, 0)
  22780    . S DIC=" ^VPR(560," ,DIC(0)="F ",X=NAME
  22781   "RTN","VPR PATS",199, 0)
  22782    . D FILE^ DICN S DA= +Y
  22783   "RTN","VPR PATS",200, 0)
  22784    . S:DA>0  ^VPR(560,D A,.1)=URL
  22785   "RTN","VPR PATS",201, 0)
  22786    Q DA
  22787   "RTN","VPR PATS",202, 0)
  22788    ;
  22789   "RTN","VPR PATS",203, 0)
  22790   RET(DFN,ST S) ; -- ad d XML node  for patie nt DFN upd ate subscr iption
  22791   "RTN","VPR PATS",204, 0)
  22792    N Y S Y=" <patient d fn='"_$G(D FN)
  22793   "RTN","VPR PATS",205, 0)
  22794    S Y=Y_"'  subscribe= '"_$G(STS) _"' />"
  22795   "RTN","VPR PATS",206, 0)
  22796    D ADD(Y)
  22797   "RTN","VPR PATS",207, 0)
  22798    Q
  22799   "RTN","VPR PATS",208, 0)
  22800    ;
  22801   "RTN","VPR PATS",209, 0)
  22802   ADD(X) ; A dd a line  @VPR@(n)=X
  22803   "RTN","VPR PATS",210, 0)
  22804    S VPRI=$G (VPRI)+1
  22805   "RTN","VPR PATS",211, 0)
  22806    S @VPR@(V PRI)=X
  22807   "RTN","VPR PATS",212, 0)
  22808    Q
  22809   "RTN","VPR PRODC")
  22810   0^18^B2553 308
  22811   "RTN","VPR PRODC",1,0 )
  22812   VPRPRODC ; SLC/AGP -  Environmen tal check  for instal lations ;0 2/02/12
  22813   "RTN","VPR PRODC",2,0 )
  22814    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  22815   "RTN","VPR PRODC",3,0 )
  22816    ;
  22817   "RTN","VPR PRODC",4,0 )
  22818    ;This rou tine will  check to s ee if the  user is in  a product ion accoun t
  22819   "RTN","VPR PRODC",5,0 )
  22820    ;if they  are then t he user wi ll not be  allowed to  install t his
  22821   "RTN","VPR PRODC",6,0 )
  22822    ;patch/bu ild/bundle
  22823   "RTN","VPR PRODC",7,0 )
  22824    ;
  22825   "RTN","VPR PRODC",8,0 )
  22826   ENV ;
  22827   "RTN","VPR PRODC",9,0 )
  22828    I $$PROD^ XUPROD D
  22829   "RTN","VPR PRODC",10, 0)
  22830    .W !,"You  are attem pting to i nstall thi s software  into your  productio n account. ",!,"At th is time, t his softwa re is not  ready for  a producti on install ."
  22831   "RTN","VPR PRODC",11, 0)
  22832    .W !!,"Pl ease verif y the acco unt you're  attemptin g to insta ll into an d",!,"if y ou believe  you're co rrect, con tact Ron M assey or T ana Defa." ,!!,"INSTA LLATION AB ORTED!"
  22833   "RTN","VPR PRODC",12, 0)
  22834    .S XPDABO RT=1
  22835   "RTN","VPR PRODC",13, 0)
  22836    Q
  22837   "RTN","VPR PXRM")
  22838   0^60^B1224 4143
  22839   "RTN","VPR PXRM",1,0)
  22840   VPRPXRM ;  SLC/AGP -  Clinical R emidners r outine. ;  8/16/12 7: 09pm
  22841   "RTN","VPR PXRM",2,0)
  22842    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  22843   "RTN","VPR PXRM",3,0)
  22844    Q
  22845   "RTN","VPR PXRM",4,0)
  22846    ;
  22847   "RTN","VPR PXRM",5,0)
  22848   EVALLIST(R ESULT,PT,U SER,LOC) ;
  22849   "RTN","VPR PXRM",6,0)
  22850    N CNT,NUM ,RIEN,TMP, UID,VPRTMP ,VPRSYS
  22851   "RTN","VPR PXRM",7,0)
  22852    N DUEDATE ,I,J,LASTD ONE,NAME,N ODE,STATUS ,TXT
  22853   "RTN","VPR PXRM",8,0)
  22854    ;S USER=$ P(USERUID, ":",5)
  22855   "RTN","VPR PXRM",9,0)
  22856    D GETLIST ^ORQQPX(.V PRTMP,LOC)
  22857   "RTN","VPR PXRM",10,0 )
  22858    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  22859   "RTN","VPR PXRM",11,0 )
  22860    S CNT=0,N UM=0 F  S  CNT=$O(VPR TMP(CNT))  Q:CNT'>0   D
  22861   "RTN","VPR PXRM",12,0 )
  22862    .S RIEN=$ G(VPRTMP(C NT)) I RIE N'>0 Q
  22863   "RTN","VPR PXRM",13,0 )
  22864    .S NAME=" " S NAME=$ P($G(^PXD( 811.9,RIEN ,0)),U,3)
  22865   "RTN","VPR PXRM",14,0 )
  22866    .I NAME=" " S NAME=$ P($G(^PXD( 811.9,RIEN ,0)),U)
  22867   "RTN","VPR PXRM",15,0 )
  22868    .S UID="u rn:va:pxrm :"_VPRSYS_ ":"_RIEN
  22869   "RTN","VPR PXRM",16,0 )
  22870    .S NUM=NU M+1,TMP("r eminders", NUM,"uid") =UID,TMP(" reminders" ,NUM,"name ")=NAME
  22871   "RTN","VPR PXRM",17,0 )
  22872    .K ^TMP(" PXRHM",$J)
  22873   "RTN","VPR PXRM",18,0 )
  22874    .D MAIN^P XRM(PT,RIE N,5)     ;  5 returns  all remin der info
  22875   "RTN","VPR PXRM",19,0 )
  22876    .S I=1,TX T=""
  22877   "RTN","VPR PXRM",20,0 )
  22878    .S NAME=" ",NAME=$O( ^TMP("PXRH M",$J,RIEN ,NAME)) Q: NAME=""  D
  22879   "RTN","VPR PXRM",21,0 )
  22880    ..S NODE= $G(^TMP("P XRHM",$J,R IEN,NAME))
  22881   "RTN","VPR PXRM",22,0 )
  22882    ..S STATU S=$P(NODE, U),DUEDATE =$$JSONDT^ VPRUTILS($ P(NODE,U,2 )),LASTDON E=$$JSONDT ^VPRUTILS( $P(NODE,U, 3))
  22883   "RTN","VPR PXRM",23,0 )
  22884    ..S J=0 F   S J=$O(^ TMP("PXRHM ",$J,RIEN, NAME,"TXT" ,J)) Q:J=" "  D
  22885   "RTN","VPR PXRM",24,0 )
  22886    ...S TXT= $G(TXT)_^T MP("PXRHM" ,$J,RIEN,N AME,"TXT", J)_$C(13)_ $C(10),I=I +1
  22887   "RTN","VPR PXRM",25,0 )
  22888    .K ^TMP(" PXRHM",$J)
  22889   "RTN","VPR PXRM",26,0 )
  22890    .S TMP("r eminders", NUM,"statu s")=STATUS
  22891   "RTN","VPR PXRM",27,0 )
  22892    .S TMP("r eminders", NUM,"dueDa te")=DUEDA TE
  22893   "RTN","VPR PXRM",28,0 )
  22894    .S TMP("r eminders", NUM,"lastD one")=LAST DONE
  22895   "RTN","VPR PXRM",29,0 )
  22896    .S TMP("r eminders", NUM,"clini calMainten ance")=TXT
  22897   "RTN","VPR PXRM",30,0 )
  22898    S TMP("su ccess")="t rue"
  22899   "RTN","VPR PXRM",31,0 )
  22900    D ENCODE^ VPRJSON("T MP","RESUL T","ERROR" )
  22901   "RTN","VPR PXRM",32,0 )
  22902    I $D(ERRO R) D SETER ROR(.TMP,. ERROR,.RES ULT)
  22903   "RTN","VPR PXRM",33,0 )
  22904    Q
  22905   "RTN","VPR PXRM",34,0 )
  22906    ;
  22907   "RTN","VPR PXRM",35,0 )
  22908   EVALREM(RE SULT,PT,UI D) ;return  detail fo r a pt's c linical re minder
  22909   "RTN","VPR PXRM",36,0 )
  22910    K ^TMP("P XRHM",$J)
  22911   "RTN","VPR PXRM",37,0 )
  22912    N DUEDATE ,I,J,LASTD ONE,NAME,N ODE,RIEN,S TATUS,TMP, TXT
  22913   "RTN","VPR PXRM",38,0 )
  22914    S RIEN=$P (UID,":",5 )
  22915   "RTN","VPR PXRM",39,0 )
  22916    D MAIN^PX RM(PT,RIEN ,5)     ;  5 returns  all remind er info
  22917   "RTN","VPR PXRM",40,0 )
  22918    S I=1,TXT =""
  22919   "RTN","VPR PXRM",41,0 )
  22920    S NAME="" ,NAME=$O(^ TMP("PXRHM ",$J,RIEN, NAME)) Q:N AME=""  D
  22921   "RTN","VPR PXRM",42,0 )
  22922    .S NODE=$ G(^TMP("PX RHM",$J,RI EN,NAME))
  22923   "RTN","VPR PXRM",43,0 )
  22924    .S STATUS =$P(NODE,U ),DUEDATE= $$JSONDT^V PRUTILS($P (NODE,U,2) ),LASTDONE =$$JSONDT^ VPRUTILS($ P(NODE,U,3 ))
  22925   "RTN","VPR PXRM",44,0 )
  22926    .S J=0 F   S J=$O(^T MP("PXRHM" ,$J,RIEN,N AME,"TXT", J)) Q:J=""   D
  22927   "RTN","VPR PXRM",45,0 )
  22928    ..S TXT=$ G(TXT)_^TM P("PXRHM", $J,RIEN,NA ME,"TXT",J )_$C(13)_$ C(10),I=I+ 1
  22929   "RTN","VPR PXRM",46,0 )
  22930    K ^TMP("P XRHM",$J)
  22931   "RTN","VPR PXRM",47,0 )
  22932    S TMP("ui d")=UID
  22933   "RTN","VPR PXRM",48,0 )
  22934    S TMP("st atus")=STA TUS
  22935   "RTN","VPR PXRM",49,0 )
  22936    S TMP("du eDate")=DU EDATE
  22937   "RTN","VPR PXRM",50,0 )
  22938    S TMP("la stDone")=L ASTDONE
  22939   "RTN","VPR PXRM",51,0 )
  22940    S TMP("cl inicalMain tenance")= TXT
  22941   "RTN","VPR PXRM",52,0 )
  22942    S TMP("su ccess")="t rue"
  22943   "RTN","VPR PXRM",53,0 )
  22944    D ENCODE^ VPRJSON("T MP","RESUL T","ERROR" )
  22945   "RTN","VPR PXRM",54,0 )
  22946    I $D(ERRO R) D SETER ROR(.TMP,. ERROR,.RES ULT)
  22947   "RTN","VPR PXRM",55,0 )
  22948    Q
  22949   "RTN","VPR PXRM",56,0 )
  22950    ;
  22951   "RTN","VPR PXRM",57,0 )
  22952   REMLIST(RE SULT,USERU ID,LOC) ;
  22953   "RTN","VPR PXRM",58,0 )
  22954    N CNT,NUM ,RIEN,TMP, UID,USER,V PRTMP,VPRS YS
  22955   "RTN","VPR PXRM",59,0 )
  22956    S USER=$P (USERUID," :",5)
  22957   "RTN","VPR PXRM",60,0 )
  22958    D GETLIST ^ORQQPX(.V PRTMP,LOC)
  22959   "RTN","VPR PXRM",61,0 )
  22960    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  22961   "RTN","VPR PXRM",62,0 )
  22962    S CNT=0,N UM=0 F  S  CNT=$O(VPR TMP(CNT))  Q:CNT'>0   D
  22963   "RTN","VPR PXRM",63,0 )
  22964    .S RIEN=$ G(VPRTMP(C NT)) I RIE N'>0 Q
  22965   "RTN","VPR PXRM",64,0 )
  22966    .S NAME=" " S NAME=$ P($G(^PXD( 811.9,RIEN ,0)),U,3)
  22967   "RTN","VPR PXRM",65,0 )
  22968    .I NAME=" " S NAME=$ P($G(^PXD( 811.9,RIEN ,0)),U)
  22969   "RTN","VPR PXRM",66,0 )
  22970    .S UID="u rn:va:pxrm :"_VPRSYS_ ":"_RIEN
  22971   "RTN","VPR PXRM",67,0 )
  22972    .S NUM=NU M+1,TMP("r eminders", NUM,"uid") =UID,TMP(" reminders" ,NUM,"name ")=NAME
  22973   "RTN","VPR PXRM",68,0 )
  22974    S TMP("su ccess")="t rue"
  22975   "RTN","VPR PXRM",69,0 )
  22976    D ENCODE^ VPRJSON("T MP","RESUL T","ERROR" )
  22977   "RTN","VPR PXRM",70,0 )
  22978    I $D(ERRO R) D SETER ROR(.TMP,. ERROR,.RES ULT)
  22979   "RTN","VPR PXRM",71,0 )
  22980    Q
  22981   "RTN","VPR PXRM",72,0 )
  22982    ;
  22983   "RTN","VPR PXRM",73,0 )
  22984   SETERROR(I NPDATA,ERR ORMSG,OUTP UT) ;
  22985   "RTN","VPR PXRM",74,0 )
  22986    N ERRARR, TXT
  22987   "RTN","VPR PXRM",75,0 )
  22988    S TXT(1)= "Problem e ncoding js on output"
  22989   "RTN","VPR PXRM",76,0 )
  22990    D SETERRO R^VPRUTILS (.ERRARR,. ERRORMSG,. TXT,.INPDA TA)
  22991   "RTN","VPR PXRM",77,0 )
  22992    D ENCODE^ VPRJSON("E RRARR","OU TPUT","ERR OR")
  22993   "RTN","VPR PXRM",78,0 )
  22994    Q
  22995   "RTN","VPR PXRM",79,0 )
  22996    ;
  22997   "RTN","VPR ROS2")
  22998   0^13^B1065 16600
  22999   "RTN","VPR ROS2",1,0)
  23000   VPRROS2 ;S LC/GRR --  Roster Man agement
  23001   "RTN","VPR ROS2",2,0)
  23002    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  23003   "RTN","VPR ROS2",3,0)
  23004    ;; Compil e Roster
  23005   "RTN","VPR ROS2",4,0)
  23006   COMPILE(VP R,VPRIEN,V PROWNER) ;
  23007   "RTN","VPR ROS2",5,0)
  23008    ;; Input  - VPRIEN i s internal  entry num ber of ros ter
  23009   "RTN","VPR ROS2",6,0)
  23010    ;;          VPROWNER  - If this  parameter  exists, o nly roster s for this  owner wil l be compi led and pa ssed
  23011   "RTN","VPR ROS2",7,0)
  23012    ;; Output  - AFTER a rray conta ins curren t patients
  23013   "RTN","VPR ROS2",8,0)
  23014    ;
  23015   "RTN","VPR ROS2",9,0)
  23016    K VPRLIST ,VPRLIST2
  23017   "RTN","VPR ROS2",10,0 )
  23018    N VPRLIST ,VPRFILT,V PRTYPE,VPE RR,VPRI,VP RRNAME,VPR Y,VPROP,VP RTAG,VPRLA B,VPRNLIST ,BEG,DOB,E ND,GENDER, ICN,NAME,V PRACT,VPRC
  23019   "RTN","VPR ROS2",11,0 )
  23020    N VPRCIEN ,VPRDNAME, VPRDOB,VPR III,VPRINM ,VPRLIEN,V PRNAME,VPR OIEN,VPRON AME,VPROWN ID,VPROWNN M,VPRPAT,V PRPIEN,VPR NME,VPRCNT
  23021   "RTN","VPR ROS2",12,0 )
  23022    N VPRSRCD N,VPRCID,V PRTEXT,VPR TIEN,VPRTL ST,VPRVER, VPRWIEN,VP RWNAME,VPR PNME,VPRRC NT,VPRSRCI D,X,Y
  23023   "RTN","VPR ROS2",13,0 )
  23024    K ^TMP($J ,"VPROSTER ")
  23025   "RTN","VPR ROS2",14,0 )
  23026    S VPR=$NA (^TMP($J," VPROSTER") ),VPRNLIST =""
  23027   "RTN","VPR ROS2",15,0 )
  23028    I $G(VPRI EN)="" S V PRIEN=0
  23029   "RTN","VPR ROS2",16,0 )
  23030    S (VPRLIS T,VPRFILT, VPRTYPE,VP ROP,VPRLIS T2,VPERR)= "",VPRI=0
  23031   "RTN","VPR ROS2",17,0 )
  23032    I $G(VPRO WNER)'=""  D MULTI Q  VPR
  23033   "RTN","VPR ROS2",18,0 )
  23034    I +$G(VPR IEN)'>0 S  VPERR="0^I nvalid Ros ter IEN" Q
  23035   "RTN","VPR ROS2",19,0 )
  23036    S VPRRNAM E=$P(^VPRO STER(VPRIE N,0),"^",1 )
  23037   "RTN","VPR ROS2",20,0 )
  23038    F  S VPRI =$O(^VPROS TER(VPRIEN ,1,VPRI))  Q:VPRI'>0   D
  23039   "RTN","VPR ROS2",21,0 )
  23040    . S VPRY= $G(^VPROST ER(VPRIEN, 1,VPRI,0))
  23041   "RTN","VPR ROS2",22,0 )
  23042    . S VPROP =$P(VPRY," ^",3)
  23043   "RTN","VPR ROS2",23,0 )
  23044    . S VPRFI LT=$P(VPRY ,"^",4)
  23045   "RTN","VPR ROS2",24,0 )
  23046    . S VPRTA G=$P($P(VP RY,"^",2), ";",2)
  23047   "RTN","VPR ROS2",25,0 )
  23048    . S VPRLA B=""
  23049   "RTN","VPR ROS2",26,0 )
  23050    . I VPRTA G["SC(" S  VPRLAB="CL IN"
  23051   "RTN","VPR ROS2",27,0 )
  23052    . I VPRTA G["DIC(42"  S VPRLAB= "WARD"
  23053   "RTN","VPR ROS2",28,0 )
  23054    . I VPRTA G["DPT" S  VPRLAB="PA T"
  23055   "RTN","VPR ROS2",29,0 )
  23056    . I VPRTA G["SCTM" S  VPRLAB="P CMM"
  23057   "RTN","VPR ROS2",30,0 )
  23058    . I VPRTA G["OR(100. 21" S VPRL AB="CPRS"
  23059   "RTN","VPR ROS2",31,0 )
  23060    . I VPRTA G["VPROSTE R" S VPRLA B="ROST"
  23061   "RTN","VPR ROS2",32,0 )
  23062    . I VPRTA G["DIC(45. 7" S VPRLA B="SPEC"
  23063   "RTN","VPR ROS2",33,0 )
  23064    . I VPRTA G["VA(200"  S VPRLAB= "PROV"
  23065   "RTN","VPR ROS2",34,0 )
  23066    . I VPRTA G["PXRM(81 0.4" S VPR LAB="PXRM"
  23067   "RTN","VPR ROS2",35,0 )
  23068    . I VPRLA B="" S VPE RR="1^INVA LID FILE T YPE" Q
  23069   "RTN","VPR ROS2",36,0 )
  23070    . D @VPRL AB
  23071   "RTN","VPR ROS2",37,0 )
  23072    . S VPRLA B=$S(VPROP =0:"UNION" ,VPROP=1:" INTER",1:" DIFF")
  23073   "RTN","VPR ROS2",38,0 )
  23074    . S VPRNL IST=""
  23075   "RTN","VPR ROS2",39,0 )
  23076    . D @VPRL AB
  23077   "RTN","VPR ROS2",40,0 )
  23078    I $D(VPRO UT) K VPRO UT M VPRLI ST2=VPRLIS T Q
  23079   "RTN","VPR ROS2",41,0 )
  23080    I $O(VPRL IST(0))'>0  S VPERR=" 1^EMPTY RO STER",@VPR @(1)=VPERR  Q
  23081   "RTN","VPR ROS2",42,0 )
  23082    M AFTER=V PRLIST
  23083   "RTN","VPR ROS2",43,0 )
  23084    D SEND
  23085   "RTN","VPR ROS2",44,0 )
  23086    D ENROS^V PRFPTC(.ZZ ,.VPRLIST)  ;added 5/ 17/12 grr  to check p atient sen sitivity
  23087   "RTN","VPR ROS2",45,0 )
  23088    Q
  23089   "RTN","VPR ROS2",46,0 )
  23090    ;
  23091   "RTN","VPR ROS2",47,0 )
  23092   CLIN ;Proc ess patien ts for thi s clinic.   Select al l if filte r is null
  23093   "RTN","VPR ROS2",48,0 )
  23094    K VPRLIST 2 S VPRLIS T2=""
  23095   "RTN","VPR ROS2",49,0 )
  23096    I '$D(DT)  S DT=$$DT ^XLFDT()
  23097   "RTN","VPR ROS2",50,0 )
  23098    S BEG=DT, END=$S(VPR FILT="T":D T+.24,1:99 99999+.24) ,VPRIII=BE G
  23099   "RTN","VPR ROS2",51,0 )
  23100    S VPRCIEN =+$P(VPRY, "^",2) F   S VPRIII=$ O(^SC(VPRC IEN,"S",VP RIII)) Q:V PRIII'>0!( VPRIII>END )  D
  23101   "RTN","VPR ROS2",52,0 )
  23102    . S VPRII =0 F  S VP RII=$O(^SC (VPRCIEN," S",VPRIII, 1,VPRII))  Q:VPRII'>0   S DFN=$P ($G(^SC(VP RCIEN,"S", VPRIII,1,V PRII,0))," ^",1) I DF N>0 D
  23103   "RTN","VPR ROS2",53,0 )
  23104    . .S VPRL IST2(DFN)= ""
  23105   "RTN","VPR ROS2",54,0 )
  23106    Q
  23107   "RTN","VPR ROS2",55,0 )
  23108    ;
  23109   "RTN","VPR ROS2",56,0 )
  23110   WARD ;Proc ess patien ts for thi s ward
  23111   "RTN","VPR ROS2",57,0 )
  23112    K VPRLIST 2 S VPRLIS T2=""
  23113   "RTN","VPR ROS2",58,0 )
  23114    S VPRWIEN =+$P(VPRY, "^",2),VPR WNAME=$P($ G(^DIC(42, VPRWIEN,0) ),"^",1)
  23115   "RTN","VPR ROS2",59,0 )
  23116    S VPRIII= 0 F  S VPR III=$O(^DG PM("CN",VP RWNAME,VPR III)) Q:VP RIII'>0  D
  23117   "RTN","VPR ROS2",60,0 )
  23118    . S DFN=$ P($G(^DGPM (VPRIII,0) ),"^",3),V PRLIST2(DF N)=""
  23119   "RTN","VPR ROS2",61,0 )
  23120    Q
  23121   "RTN","VPR ROS2",62,0 )
  23122    ;
  23123   "RTN","VPR ROS2",63,0 )
  23124   PAT ;Proce ss patient  from Pati ent file S ource
  23125   "RTN","VPR ROS2",64,0 )
  23126    K VPRLIST 2 S VPRLIS T2=""
  23127   "RTN","VPR ROS2",65,0 )
  23128    S DFN=+$P (VPRY,"^", 2),VPRLIST 2(DFN)=""
  23129   "RTN","VPR ROS2",66,0 )
  23130    Q
  23131   "RTN","VPR ROS2",67,0 )
  23132    ;
  23133   "RTN","VPR ROS2",68,0 )
  23134   PCMM ;Proc ess patien ts from a  PCMM team
  23135   "RTN","VPR ROS2",69,0 )
  23136    K VPRLIST 2 S VPRLIS T2=""
  23137   "RTN","VPR ROS2",70,0 )
  23138    S VPRTIEN =+$P(VPRY, "^",2),VPE RR="",VPRT LST=""
  23139   "RTN","VPR ROS2",71,0 )
  23140    D PTTM^SC APMC(VPRTI EN,,"VPRTL ST",VPERR)
  23141   "RTN","VPR ROS2",72,0 )
  23142    S VPRIII= "" F  S VP RIII=$O(VP RTLST(VPRI II)) Q:VPR III'>0  S  DFN=$P(VPR TLST(VPRII I),"^",1)  S VPRLIST2 (DFN)=""
  23143   "RTN","VPR ROS2",73,0 )
  23144    Q
  23145   "RTN","VPR ROS2",74,0 )
  23146    ;
  23147   "RTN","VPR ROS2",75,0 )
  23148   CPRS ;Proc ess patien ts from CP RS Lists
  23149   "RTN","VPR ROS2",76,0 )
  23150    K VPRLIST 2 S VPRLIS T2=""
  23151   "RTN","VPR ROS2",77,0 )
  23152    S VPROIEN =+$P(VPRY, "^",2),VPE RR=""
  23153   "RTN","VPR ROS2",78,0 )
  23154    S VPRIII= 0 F  S VPR III=$O(^OR (100.21,VP ROIEN,10,V PRIII)) Q: VPRIII'>0   S DFN=$P( ^OR(100.21 ,VPROIEN,1 0,VPRIII,0 ),";",1) S  VPRLIST2( DFN)=""
  23155   "RTN","VPR ROS2",79,0 )
  23156    Q
  23157   "RTN","VPR ROS2",80,0 )
  23158    ;
  23159   "RTN","VPR ROS2",81,0 )
  23160   ROST ;Proc ess patien ts from se lected ros ter
  23161   "RTN","VPR ROS2",82,0 )
  23162    K VPRLIST 2,VPRBLIST  S (VPRLIS T2,VPRBLIS T)="" ; --  kcm added  comma
  23163   "RTN","VPR ROS2",83,0 )
  23164    N VPR,VPR IEN,VPERR
  23165   "RTN","VPR ROS2",84,0 )
  23166    S VPRIEN= +$P(VPRY," ^",2),VPER R="",VPROU T=1,VPR="V PRBLIST"
  23167   "RTN","VPR ROS2",85,0 )
  23168    D COMPILE ^VPRROS2(. VPR,VPRIEN ,"")
  23169   "RTN","VPR ROS2",86,0 )
  23170    M VPRBLIS T=VPRLIST2
  23171   "RTN","VPR ROS2",87,0 )
  23172    K VPROUT
  23173   "RTN","VPR ROS2",88,0 )
  23174    Q
  23175   "RTN","VPR ROS2",89,0 )
  23176    ;
  23177   "RTN","VPR ROS2",90,0 )
  23178   SPEC ;Proc ess patien ts with se lected Tre ating Spec ialty
  23179   "RTN","VPR ROS2",91,0 )
  23180    K VPRLIST 2 S VPRLIS T2=""
  23181   "RTN","VPR ROS2",92,0 )
  23182    S VPROIEN =+$P(VPRY, "^",2),VPE RR=""
  23183   "RTN","VPR ROS2",93,0 )
  23184    N DFN S D FN=0 F  S  DFN=$O(^DP T("ATR",VP ROIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  23185   "RTN","VPR ROS2",94,0 )
  23186    Q
  23187   "RTN","VPR ROS2",95,0 )
  23188    ;
  23189   "RTN","VPR ROS2",96,0 )
  23190   PROV ;Proc ess patien ts for sel ected prov ider
  23191   "RTN","VPR ROS2",97,0 )
  23192    K VPRLIST 2 S VPRLIS T2=""
  23193   "RTN","VPR ROS2",98,0 )
  23194    S VPRPIEN =+$P(VPRY, "^",2),VPE RR=""
  23195   "RTN","VPR ROS2",99,0 )
  23196    N DFN S D FN=0 F  S  DFN=$O(^DP T("APR",VP RPIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  23197   "RTN","VPR ROS2",100, 0)
  23198    Q
  23199   "RTN","VPR ROS2",101, 0)
  23200    ;
  23201   "RTN","VPR ROS2",102, 0)
  23202   PXRM ;Proc ess patien ts for sel ected pane l
  23203   "RTN","VPR ROS2",103, 0)
  23204    K VPRLIST 2 S VPRLIS T2=""
  23205   "RTN","VPR ROS2",104, 0)
  23206    S VPRPIEN =+$P(VPRY, "^",2),VPE RR=""
  23207   "RTN","VPR ROS2",105, 0)
  23208    S VPRC=VP RPIEN,VPRL IEN=$P(^VP ROSTER(VPR IEN,0),"^" ,1),VPRPNM E=$P(^VPRO STER(VPRIE N,0),"^",6 ) I VPRPNM E="" S VPR PNME=VPRRN AME,$P(^VP ROSTER(VPR IEN,0),U,6 )=VPRRNAME
  23209   "RTN","VPR ROS2",106, 0)
  23210    S VPRPAT= "" D RUNLI ST^VPRROS5 (.VPRPAT,V PRLIEN,VPR PNME,0,1)
  23211   "RTN","VPR ROS2",107, 0)
  23212    S VPRII=0  F  S VPRI I=$O(VPRPA T(VPRC,VPR II)) Q:VPR II'>0  S D FN=VPRPAT( VPRC,VPRII ),VPRLIST2 (DFN)=""
  23213   "RTN","VPR ROS2",108, 0)
  23214    Q
  23215   "RTN","VPR ROS2",109, 0)
  23216    ;
  23217   "RTN","VPR ROS2",110, 0)
  23218   UNION ;Add  to existi ng list
  23219   "RTN","VPR ROS2",111, 0)
  23220    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  S VPRL IST(VPRII) =""
  23221   "RTN","VPR ROS2",112, 0)
  23222    Q
  23223   "RTN","VPR ROS2",113, 0)
  23224    ;
  23225   "RTN","VPR ROS2",114, 0)
  23226   INTER ;Int ersect wit h existing  list
  23227   "RTN","VPR ROS2",115, 0)
  23228    S VPRII=0  F  S VPRI I=$O(VPRLI ST(VPRII))  Q:VPRII'> 0  D
  23229   "RTN","VPR ROS2",116, 0)
  23230    . I '$D(V PRLIST2(VP RII)) K VP RLIST(VPRI I)
  23231   "RTN","VPR ROS2",117, 0)
  23232    Q
  23233   "RTN","VPR ROS2",118, 0)
  23234    ;
  23235   "RTN","VPR ROS2",119, 0)
  23236   DIFF ;Remo ve patient s from thi s source t hat we hav e so far
  23237   "RTN","VPR ROS2",120, 0)
  23238    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  D
  23239   "RTN","VPR ROS2",121, 0)
  23240    . K VPRLI ST(VPRII)
  23241   "RTN","VPR ROS2",122, 0)
  23242    Q
  23243   "RTN","VPR ROS2",123, 0)
  23244    ;
  23245   "RTN","VPR ROS2",124, 0)
  23246   SEND ;send  pending r osters.  C alled thro ugh RPC
  23247   "RTN","VPR ROS2",125, 0)
  23248    S VPRRCNT =0,VPRI=0, VPRII=0
  23249   "RTN","VPR ROS2",126, 0)
  23250    S VPRVER= "<results  version='" _$P($T(VPR ROS2+1),"; ",3)_"'>"
  23251   "RTN","VPR ROS2",127, 0)
  23252    D ADD(VPR VER)
  23253   "RTN","VPR ROS2",128, 0)
  23254    S VPRRNAM E=$P(^VPRO STER(VPRIE N,0),"^",1 ),VPRDNAME =$P(^VPROS TER(VPRIEN ,0),"^",2) ,VPRRNAME= $$ESC^VPRD (VPRRNAME) ,VPRDNAME= $$ESC^VPRD (VPRDNAME)
  23255   "RTN","VPR ROS2",129, 0)
  23256    S VPRTEXT ="<roster  ien='"_VPR IEN_"'>" D  ADD(VPRTE XT)
  23257   "RTN","VPR ROS2",130, 0)
  23258    S VPRTEXT ="<rosterN ame>"_VPRR NAME_"</ro sterName>"  D ADD(VPR TEXT)
  23259   "RTN","VPR ROS2",131, 0)
  23260    S VPRTEXT ="<display Name>"_VPR DNAME_"</d isplayName >" D ADD(V PRTEXT)
  23261   "RTN","VPR ROS2",132, 0)
  23262    D ADD("<p atients>")
  23263   "RTN","VPR ROS2",133, 0)
  23264    K VPRII S  VPRII=0 F   S VPRII= $O(VPRLIST (VPRII)) Q :VPRII'>0   D
  23265   "RTN","VPR ROS2",134, 0)
  23266    . N VPRY
  23267   "RTN","VPR ROS2",135, 0)
  23268    . S DFN=V PRII,VPRY= $G(^DPT(DF N,0))
  23269   "RTN","VPR ROS2",136, 0)
  23270    . S ICN=$ $GETICN^MP IF001(DFN)
  23271   "RTN","VPR ROS2",137, 0)
  23272    . S NAME= $P(VPRY,"^ ",1),GENDE R=$P(VPRY, "^",2),DOB =$P(VPRY," ^",3),SSN= $P(VPRY,"^ ",9),VPRDO B=$$FMTHL7 ^XLFDT(DOB )
  23273   "RTN","VPR ROS2",138, 0)
  23274    . S Y="<p atient nam e='"_NAME_ "' gender= '"_GENDER_ "' dob='"_ VPRDOB_"'  ssn='"_SSN _"' id='"_ DFN_$S(ICN :"' icn='" _ICN,1:"") _"' />" D  ADD(Y)
  23275   "RTN","VPR ROS2",139, 0)
  23276    D ADD("</ patients>" )
  23277   "RTN","VPR ROS2",140, 0)
  23278    D ADD("</ roster>")
  23279   "RTN","VPR ROS2",141, 0)
  23280    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  23281   "RTN","VPR ROS2",142, 0)
  23282    Q
  23283   "RTN","VPR ROS2",143, 0)
  23284    ;
  23285   "RTN","VPR ROS2",144, 0)
  23286   ADD(X) ; - - Add a li ne @VPR@(n )=X
  23287   "RTN","VPR ROS2",145, 0)
  23288    S VPRI=$G (VPRI)+1
  23289   "RTN","VPR ROS2",146, 0)
  23290    S @VPR@(V PRI)=X
  23291   "RTN","VPR ROS2",147, 0)
  23292    Q
  23293   "RTN","VPR ROS2",148, 0)
  23294    ;
  23295   "RTN","VPR ROS2",149, 0)
  23296   GETROS(VPR ,VPRFILT)  ;; Get all  Rosters
  23297   "RTN","VPR ROS2",150, 0)
  23298    ;; Input  - None
  23299   "RTN","VPR ROS2",151, 0)
  23300    N VPRLIST ,VPRTYPE,V PERR,VPRI, VPRRNAME,V PRY,VPROP, VPRTAG,VPR LAB,VPRNLI ST,BEG,DOB ,END,GENDE R,ICN,NAME ,VPRACT,VP RC
  23301   "RTN","VPR ROS2",152, 0)
  23302    N VPRCIEN ,VPRDNAME, VPRDOB,VPR III,VPRINM ,VPRLIEN,V PRNAME,VPR OIEN,VPRON AME,VPROWN ID,VPROWNN M,VPRPAT,V PRPIEN,VPR NME,VPRCNT
  23303   "RTN","VPR ROS2",153, 0)
  23304    N VPRSRCD N,VPRCID,V PRTEXT,VPR TIEN,VPRTL ST,VPRVER, VPRWIEN,VP RWNAME,VPR PNME,VPRRC NT,VPRSRCI D,X,Y
  23305   "RTN","VPR ROS2",154, 0)
  23306    K VPRLIST
  23307   "RTN","VPR ROS2",155, 0)
  23308    S (VPRLIS T,VPRNAME, VPRTYPE,VP ROP,VPRLIS T2)="",VPR I=0,VPRIEN =0
  23309   "RTN","VPR ROS2",156, 0)
  23310    S VPRACT= "I 1"
  23311   "RTN","VPR ROS2",157, 0)
  23312    K ^TMP($J ,"VPROSTER ")
  23313   "RTN","VPR ROS2",158, 0)
  23314    S VPR=$NA (^TMP($J," VPROSTER") )
  23315   "RTN","VPR ROS2",159, 0)
  23316    S VPRVER= "<results  version='" _$P($T(VPR ROS2+1),"; ",3)_"'>"
  23317   "RTN","VPR ROS2",160, 0)
  23318    D ADD(VPR VER)
  23319   "RTN","VPR ROS2",161, 0)
  23320    S VPRNAME ="",VPRFIL T=$G(VPRFI LT)
  23321   "RTN","VPR ROS2",162, 0)
  23322    I VPRFILT '="" S X=V PRFILT X ^ %ZOSF("UPP ERCASE") S  VPRFILT=X ,VPRNAME=" ",VPRACT=" I VPRNAME[ VPRFILT"
  23323   "RTN","VPR ROS2",163, 0)
  23324    F  S VPRN AME=$O(^VP ROSTER("B" ,VPRNAME))  Q:VPRNAME =""  S X=V PRNAME X ^ %ZOSF("UPP ERCASE") X  VPRACT D
  23325   "RTN","VPR ROS2",164, 0)
  23326    . S VPRIE N=0 F  S V PRIEN=$O(^ VPROSTER(" B",VPRNAME ,VPRIEN))  Q:VPRIEN'> 0  I '$P(^ VPROSTER(V PRIEN,0)," ^",3)!($P( $G(^VPROST ER(VPRIEN, 3)),"^",1) ']"") X VP RACT I  D 
  23327   "RTN","VPR ROS2",165, 0)
  23328    . . S VPR ONAME=$$ES C^VPRD(VPR NAME),VPRD NAME=$P(^V PROSTER(VP RIEN,0),"^ ",2),VPRDN AME=$$ESC^ VPRD(VPRDN AME)
  23329   "RTN","VPR ROS2",166, 0)
  23330    . . S VPR OWNID=$P(^ VPROSTER(V PRIEN,0)," ^",4),VPRO WNNM=$P($G (^VA(200,V PROWNID,0) ),"^",1),V PROWNNM=$$ ESC^VPRD(V PROWNNM)
  23331   "RTN","VPR ROS2",167, 0)
  23332    . . S VPR TEXT="<ros ter ien='" _VPRIEN_"'   ownernam e='"_VPROW NNM_"'  ow nerid='"_V PROWNID_"' >" D ADD(V PRTEXT)
  23333   "RTN","VPR ROS2",168, 0)
  23334    . . S VPR TEXT="<ros terName>"_ VPRONAME_" </rosterNa me>" D ADD (VPRTEXT)
  23335   "RTN","VPR ROS2",169, 0)
  23336    . . S VPR TEXT="<dis playName>" _VPRDNAME_ "</display Name>" D A DD(VPRTEXT )
  23337   "RTN","VPR ROS2",170, 0)
  23338    . . S VPR TEXT="<sou rces>" D A DD(VPRTEXT )
  23339   "RTN","VPR ROS2",171, 0)
  23340    . . N VPR II,VPRAS S  VPRII=0 F   S VPRII= $O(^VPROST ER(VPRIEN, 1,"AS",VPR II)) Q:VPR II'>0  S V PRAS=$O(^V PROSTER(VP RIEN,1,"AS ",VPRII,0) ) D
  23341   "RTN","VPR ROS2",172, 0)
  23342    . . . N V PRSEQ,VPRS RC,VPRTYP, VPROP,VPRY ,VPRSRCNM
  23343   "RTN","VPR ROS2",173, 0)
  23344    . . . S V PRY=$G(^VP ROSTER(VPR IEN,1,VPRA S,0))
  23345   "RTN","VPR ROS2",174, 0)
  23346    . . . S V PRSRC=$P($ P(VPRY,"^" ,2),";",2)
  23347   "RTN","VPR ROS2",175, 0)
  23348    . . . S V PRSEQ=VPRI I
  23349   "RTN","VPR ROS2",176, 0)
  23350    . . . I V PRSRC["SC( " S VPRSRC NM="Clinic "
  23351   "RTN","VPR ROS2",177, 0)
  23352    . . . I V PRSRC["DIC (42," S VP RSRCNM="Wa rd"
  23353   "RTN","VPR ROS2",178, 0)
  23354    . . . I V PRSRC["DPT (" S VPRSR CNM="Patie nt"
  23355   "RTN","VPR ROS2",179, 0)
  23356    . . . I V PRSRC["SCT M" S VPRSR CNM="PCMM  Team"
  23357   "RTN","VPR ROS2",180, 0)
  23358    . . . I V PRSRC["OR( 100.21" S  VPRSRCNM=" OE/RR"
  23359   "RTN","VPR ROS2",181, 0)
  23360    . . . I V PRSRC["VPR OSTER" S V PRSRCNM="V PR Roster"
  23361   "RTN","VPR ROS2",182, 0)
  23362    . . . I V PRSRC["DIC (45.7" S V PRSRCNM="S pecialty"
  23363   "RTN","VPR ROS2",183, 0)
  23364    . . . I V PRSRC["VA( 200," S VP RSRCNM="Pr ovider"
  23365   "RTN","VPR ROS2",184, 0)
  23366    . . . I V PRSRC["PXR M(810.4,"  S VPRSRCNM ="PXRM"
  23367   "RTN","VPR ROS2",185, 0)
  23368    . . . S V PRSRCID=+$ P(VPRY,"^" ,2),VPRSRC DN="^"_VPR SRC_VPRSRC ID_",0)",V PRINM=$P(@ VPRSRCDN," ^",1),VPRI NM=$$ESC^V PRD(VPRINM )
  23369   "RTN","VPR ROS2",186, 0)
  23370    . . . S V PROP=$S($P (VPRY,"^", 3)=0:"Unio n",$P(VPRY ,"^",3)=1: "Intersect ion",$P(VP RY,"^",3)= 2:"Differe nce",1:"In valid")
  23371   "RTN","VPR ROS2",187, 0)
  23372    . . . S V PRTEXT="<s ource sequ ence='"_VP RSEQ_"'  t ype='"_VPR SRCNM_"'   name='"_VP RINM_"'  i d='"_VPRSR CID_"'  op eration='" _VPROP_"'  />" D ADD( VPRTEXT)
  23373   "RTN","VPR ROS2",188, 0)
  23374    . . S VPR TEXT="</so urces>" D  ADD(VPRTEX T)
  23375   "RTN","VPR ROS2",189, 0)
  23376    . . S VPR TEXT="</ro ster>" D A DD(VPRTEXT )
  23377   "RTN","VPR ROS2",190, 0)
  23378    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  23379   "RTN","VPR ROS2",191, 0)
  23380    Q
  23381   "RTN","VPR ROS2",192, 0)
  23382    ;
  23383   "RTN","VPR ROS2",193, 0)
  23384   MULTI ;;Pr ocess mult iple roste rs
  23385   "RTN","VPR ROS2",194, 0)
  23386    I $O(^VPR OSTER("AC" ,VPROWNER, 0))'>0 S V PERR="1^EM PTY ROSTER ",@VPR@(1) =VPERR Q
  23387   "RTN","VPR ROS2",195, 0)
  23388    S VPRRCNT =0,VPRI=0, VPRII=0,VP RIII=0
  23389   "RTN","VPR ROS2",196, 0)
  23390    S VPRVER= "<results  version='" _$P($T(VPR ROS2+1),"; ",3)_"'>"
  23391   "RTN","VPR ROS2",197, 0)
  23392    D ADD(VPR VER)
  23393   "RTN","VPR ROS2",198, 0)
  23394    F  S VPRI EN=$O(^VPR OSTER("AC" ,VPROWNER, VPRIEN)) Q :VPRIEN'>0   D
  23395   "RTN","VPR ROS2",199, 0)
  23396    .S VPRRNA ME=$P(^VPR OSTER(VPRI EN,0),"^", 1),VPRDNAM E=$P(^VPRO STER(VPRIE N,0),"^",2 )
  23397   "RTN","VPR ROS2",200, 0)
  23398    .S VPRTEX T="<roster  ien='"_VP RIEN_"'>"  D ADD(VPRT EXT)
  23399   "RTN","VPR ROS2",201, 0)
  23400    .S VPRTEX T="<roster Name>"_VPR RNAME_"</r osterName> " D ADD(VP RTEXT)
  23401   "RTN","VPR ROS2",202, 0)
  23402    .S VPRTEX T="<displa yName>"_VP RDNAME_"</ displayNam e>" D ADD( VPRTEXT)
  23403   "RTN","VPR ROS2",203, 0)
  23404    . S VPRII I=0 F  S V PRIII=$O(^ VPROSTER(V PRIEN,1,VP RIII)) Q:V PRIII'>0   D
  23405   "RTN","VPR ROS2",204, 0)
  23406    .. S VPRY =$G(^VPROS TER(VPRIEN ,1,VPRIII, 0))
  23407   "RTN","VPR ROS2",205, 0)
  23408    .. S VPRO P=$P(VPRY, "^",3)
  23409   "RTN","VPR ROS2",206, 0)
  23410    .. S VPRF ILT=$P(VPR Y,"^",4)
  23411   "RTN","VPR ROS2",207, 0)
  23412    .. S VPRT AG=$P($P(V PRY,"^",2) ,";",2)
  23413   "RTN","VPR ROS2",208, 0)
  23414    .. S VPRL AB=""
  23415   "RTN","VPR ROS2",209, 0)
  23416    .. I VPRT AG["SC(" S  VPRLAB="C LIN"
  23417   "RTN","VPR ROS2",210, 0)
  23418    .. I VPRT AG["DIC(42 " S VPRLAB ="WARD"
  23419   "RTN","VPR ROS2",211, 0)
  23420    .. I VPRT AG["DPT" S  VPRLAB="P AT"
  23421   "RTN","VPR ROS2",212, 0)
  23422    .. I VPRT AG["SCTM"  S VPRLAB=" PCMM"
  23423   "RTN","VPR ROS2",213, 0)
  23424    .. I VPRT AG["OR(100 .21" S VPR LAB="CPRS"
  23425   "RTN","VPR ROS2",214, 0)
  23426    .. I VPRT AG["VPROST ER" S VPRL AB="ROST"
  23427   "RTN","VPR ROS2",215, 0)
  23428    .. I VPRT AG["DIC(45 .7" S VPRL AB="SPEC"
  23429   "RTN","VPR ROS2",216, 0)
  23430    .. I VPRT AG["VA(200 " S VPRLAB ="PROV"
  23431   "RTN","VPR ROS2",217, 0)
  23432    .. I VPRT AG["PXRM(8 10.4," S V PRLAB="PXR M"
  23433   "RTN","VPR ROS2",218, 0)
  23434    .. I VPRL AB="" S VP ERR="1^INV ALID FILE  TYPE" Q
  23435   "RTN","VPR ROS2",219, 0)
  23436    .. D @VPR LAB
  23437   "RTN","VPR ROS2",220, 0)
  23438    .. S VPRL AB=$S(VPRO P=0:"UNION ",VPROP=1: "INTER",1: "DIFF")
  23439   "RTN","VPR ROS2",221, 0)
  23440    .. D @VPR LAB
  23441   "RTN","VPR ROS2",222, 0)
  23442    . D FORMA T
  23443   "RTN","VPR ROS2",223, 0)
  23444    . I $O(VP RLIST(0))' >0 S VPERR ="1^EMPTY  ROSTER",@V PR@(1)=VPE RR Q
  23445   "RTN","VPR ROS2",224, 0)
  23446    . D ENROS ^VPRFPTC(. ZZ,VPRLIST ) ;added 5 /17/12 grr  to check  patient se nsitivity
  23447   "RTN","VPR ROS2",225, 0)
  23448    . I $D(VP ROUT) K VP ROUT M @VP R=VPRLIST  Q
  23449   "RTN","VPR ROS2",226, 0)
  23450    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  23451   "RTN","VPR ROS2",227, 0)
  23452    Q
  23453   "RTN","VPR ROS2",228, 0)
  23454    ;;
  23455   "RTN","VPR ROS2",229, 0)
  23456   FORMAT ;;
  23457   "RTN","VPR ROS2",230, 0)
  23458    D ADD("<p atients>")
  23459   "RTN","VPR ROS2",231, 0)
  23460    K VPRII S  VPRII=0 F   S VPRII= $O(VPRLIST (VPRII)) Q :VPRII'>0   D
  23461   "RTN","VPR ROS2",232, 0)
  23462    . N VPRY
  23463   "RTN","VPR ROS2",233, 0)
  23464    . S DFN=V PRII,VPRY= ^DPT(DFN,0 )
  23465   "RTN","VPR ROS2",234, 0)
  23466    . S ICN=$ $GETICN^MP IF001(DFN)
  23467   "RTN","VPR ROS2",235, 0)
  23468    . S NAME= $P(VPRY,"^ ",1),GENDE R=$P(VPRY, "^",2),DOB =$P(VPRY," ^",3),VPRD OB=$$FMTHL 7^XLFDT(DO B),SSN=$P( VPRY,"^",9 )
  23469   "RTN","VPR ROS2",236, 0)
  23470    . S Y="<p atient nam e='"_NAME_ "' gender= '"_GENDER_ "' dob='"_ VPRDOB_"'  ssn='"_SSN _"' id='"_ DFN_$S(ICN :"' icn='" _ICN,1:"") _"' />" D  ADD(Y)
  23471   "RTN","VPR ROS2",237, 0)
  23472    D ADD("</ patients>" )
  23473   "RTN","VPR ROS2",238, 0)
  23474    D ADD("</ roster>")
  23475   "RTN","VPR ROS2",239, 0)
  23476    K Y
  23477   "RTN","VPR ROS2",240, 0)
  23478    Q
  23479   "RTN","VPR ROS2",241, 0)
  23480    ;;
  23481   "RTN","VPR ROS3")
  23482   0^14^B8668 4006
  23483   "RTN","VPR ROS3",1,0)
  23484   VPRROS3 ;S LC/GRR --  Roster Man agement ;4 /24/2012
  23485   "RTN","VPR ROS3",2,0)
  23486    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;AUG  17, 2011;B uild 205
  23487   "RTN","VPR ROS3",3,0)
  23488   PREVIEW(VP R,VPRARRAY ) ;; Previ ews what a  roster wo uld look l ike as def ined
  23489   "RTN","VPR ROS3",4,0)
  23490    ;;  Calle d by the G UI Roster  Builder
  23491   "RTN","VPR ROS3",5,0)
  23492    ;; Input  - VPRARRAY  - contain s roster d ata entere d thru GUI
  23493   "RTN","VPR ROS3",6,0)
  23494    K VPRLIST ,VPRLIST2
  23495   "RTN","VPR ROS3",7,0)
  23496    N %,BEG,D A,DIDEL,DI E,DOB,SSN, DR,END,GEN DER,ICN,NA ME,VPRC,VP RCIEN,VPRD IS,VPRDNAM E,VPRDOB,V PRDT,VPRII I,VPRLIEN, VPROIEN,VP ROWNID
  23497   "RTN","VPR ROS3",8,0)
  23498    N VPROWNN M,VPRPAT,V PRPIEN,VPR PNME,VPRRC NT,VPRRID, VPRTEXT,VP RTIEN,VPRL ST,VPRVAR, VPRVER,VPR WIEN,VPRWN AME,VPRZ,X ,Y
  23499   "RTN","VPR ROS3",9,0)
  23500    N VPRFILT ,VPRI,VPRN LIST,VPRSR CID,VPRTAG ,VPRTLST,V PRY,VPRTYP E,ZZ
  23501   "RTN","VPR ROS3",10,0 )
  23502    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  23503   "RTN","VPR ROS3",11,0 )
  23504    S (VPRLIS T,VPRFILT, VPRTYPE,VP ROP,VPRLIS T2,VPERR)= "",VPRI=0
  23505   "RTN","VPR ROS3",12,0 )
  23506    S VPR=$NA (^TMP($J," VPROSTER") ) ; kcm --  moved thi s here so  VPR gets d efined
  23507   "RTN","VPR ROS3",13,0 )
  23508    K ^TMP($J ,"VPROSTER ")
  23509   "RTN","VPR ROS3",14,0 )
  23510    I $O(VPRA RRAY(""))= "" S @VPR@ (1)="0^No  roster dat a passed"  Q
  23511   "RTN","VPR ROS3",15,0 )
  23512    Q:'$$VALI DATE
  23513   "RTN","VPR ROS3",16,0 )
  23514    D NOW^%DT C S VPRDT= %
  23515   "RTN","VPR ROS3",17,0 )
  23516    S VPRZ=""  S VPRZ=$O (VPRARRAY( VPRZ)) I V PRZ="" Q
  23517   "RTN","VPR ROS3",18,0 )
  23518    S VPRNLIS T=""
  23519   "RTN","VPR ROS3",19,0 )
  23520    S VPRRNAM E=$P(VPRAR RAY(VPRZ), "^",1),VPR RNAME=$$ES C^VPRD(VPR RNAME)
  23521   "RTN","VPR ROS3",20,0 )
  23522    S VPRDNAM E=$P(VPRAR RAY(VPRZ), "^",3),VPR DNAME=$$ES C^VPRD(VPR DNAME)
  23523   "RTN","VPR ROS3",21,0 )
  23524    S VPRDIS= $P(VPRARRA Y(VPRZ),"^ ",4)
  23525   "RTN","VPR ROS3",22,0 )
  23526    S VPROWNI D=$P(VPRAR RAY(VPRZ), "^",5)
  23527   "RTN","VPR ROS3",23,0 )
  23528    S VPROWNN M=$P($G(^V A(200,VPRO WNID,0))," ^",1),VPRO WNNM=$$ESC ^VPRD(VPRO WNNM)
  23529   "RTN","VPR ROS3",24,0 )
  23530    F  S VPRZ =$O(VPRARR AY(VPRZ))  Q:VPRZ=""   D
  23531   "RTN","VPR ROS3",25,0 )
  23532    . S VPRY= VPRARRAY(V PRZ)
  23533   "RTN","VPR ROS3",26,0 )
  23534    . S VPROP =$P(VPRY," ^",2)
  23535   "RTN","VPR ROS3",27,0 )
  23536    . S VPRTA G=$P(VPRY, "^",1)
  23537   "RTN","VPR ROS3",28,0 )
  23538    . S VPRLA B=""
  23539   "RTN","VPR ROS3",29,0 )
  23540    . I VPRTA G["Clinic"  S VPRLAB= "CLIN"
  23541   "RTN","VPR ROS3",30,0 )
  23542    . I VPRTA G["Ward" S  VPRLAB="W ARD"
  23543   "RTN","VPR ROS3",31,0 )
  23544    . I VPRTA G["Patient " S VPRLAB ="PAT"
  23545   "RTN","VPR ROS3",32,0 )
  23546    . I VPRTA G["PCMM Te am" S VPRL AB="PCMM"
  23547   "RTN","VPR ROS3",33,0 )
  23548    . I VPRTA G["OE/RR"  S VPRLAB=" CPRS"
  23549   "RTN","VPR ROS3",34,0 )
  23550    . I VPRTA G["VPR Ros ter" S VPR LAB="ROST"
  23551   "RTN","VPR ROS3",35,0 )
  23552    . I VPRTA G["Special ty" S VPRL AB="SPEC"
  23553   "RTN","VPR ROS3",36,0 )
  23554    . I VPRTA G["Provide r" S VPRLA B="PROV"
  23555   "RTN","VPR ROS3",37,0 )
  23556    . I VPRTA G["PXRM" S  VPRLAB="P XRM"
  23557   "RTN","VPR ROS3",38,0 )
  23558    . I VPRLA B="" S @VP R@(1)="1^I NVALID FIL E TYPE" Q
  23559   "RTN","VPR ROS3",39,0 )
  23560    . D @VPRL AB
  23561   "RTN","VPR ROS3",40,0 )
  23562    . S VPRLA B=$S(VPROP ="UNION":" UNION",VPR OP="Inters ection":"I NTER",1:"D IFF")
  23563   "RTN","VPR ROS3",41,0 )
  23564    . S VPRNL IST=""
  23565   "RTN","VPR ROS3",42,0 )
  23566    . D @VPRL AB
  23567   "RTN","VPR ROS3",43,0 )
  23568    I $D(VPRO UT) K VPRO UT M VPRLI ST2=VPRLIS T Q
  23569   "RTN","VPR ROS3",44,0 )
  23570    I $O(VPRL IST(0))'>0  S @VPR@(1 )="1^EMPTY  ROSTER" Q
  23571   "RTN","VPR ROS3",45,0 )
  23572    D SEND
  23573   "RTN","VPR ROS3",46,0 )
  23574    D ENROS^V PRFPTC(.ZZ ,VPRLIST)  ;added 5/1 7/12 grr t o check pa tient sens itivity
  23575   "RTN","VPR ROS3",47,0 )
  23576    Q
  23577   "RTN","VPR ROS3",48,0 )
  23578    ;
  23579   "RTN","VPR ROS3",49,0 )
  23580   CLIN ;Proc ess patien ts for thi s clinic.   Select al l if filte r is null
  23581   "RTN","VPR ROS3",50,0 )
  23582    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  23583   "RTN","VPR ROS3",51,0 )
  23584    I '$D(DT)  S DT=$$DT ^XLFDT()
  23585   "RTN","VPR ROS3",52,0 )
  23586    S BEG=DT, END=$S(VPR FILT="T":D T+.24,1:99 99999+.24) ,VPRIII=BE G
  23587   "RTN","VPR ROS3",53,0 )
  23588    S VPRCIEN =+$P(VPRY, "^",3) F   S VPRIII=$ O(^SC(VPRC IEN,"S",VP RIII)) Q:V PRIII'>0!( VPRIII>END )  D
  23589   "RTN","VPR ROS3",54,0 )
  23590    . S VPRII =0 F  S VP RII=$O(^SC (VPRCIEN," S",VPRIII, 1,VPRII))  Q:VPRII'>0   S DFN=$P ($G(^SC(VP RCIEN,"S", VPRIII,1,V PRII,0))," ^",1) I DF N>0 D
  23591   "RTN","VPR ROS3",55,0 )
  23592    . .S VPRL IST2(DFN)= ""
  23593   "RTN","VPR ROS3",56,0 )
  23594    Q
  23595   "RTN","VPR ROS3",57,0 )
  23596    ;
  23597   "RTN","VPR ROS3",58,0 )
  23598   WARD ;Proc ess patien ts for thi s ward
  23599   "RTN","VPR ROS3",59,0 )
  23600    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  23601   "RTN","VPR ROS3",60,0 )
  23602    S VPRWIEN =+$P(VPRY, "^",3),VPR WNAME=$P($ G(^DIC(42, VPRWIEN,0) ),"^",1)
  23603   "RTN","VPR ROS3",61,0 )
  23604    S VPRIII= 0 F  S VPR III=$O(^DG PM("CN",VP RWNAME,VPR III)) Q:VP RIII'>0  D
  23605   "RTN","VPR ROS3",62,0 )
  23606    . S DFN=$ P($G(^DGPM (VPRIII,0) ),"^",3),V PRLIST2(DF N)=""
  23607   "RTN","VPR ROS3",63,0 )
  23608    Q
  23609   "RTN","VPR ROS3",64,0 )
  23610    ;
  23611   "RTN","VPR ROS3",65,0 )
  23612   PAT ;Proce ss patient  from Pati ent file S ource
  23613   "RTN","VPR ROS3",66,0 )
  23614    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  23615   "RTN","VPR ROS3",67,0 )
  23616    S DFN=+$P (VPRY,"^", 3),VPRLIST 2(DFN)=""
  23617   "RTN","VPR ROS3",68,0 )
  23618    Q
  23619   "RTN","VPR ROS3",69,0 )
  23620    ;
  23621   "RTN","VPR ROS3",70,0 )
  23622   PCMM ;Proc ess patien ts from a  PCMM team
  23623   "RTN","VPR ROS3",71,0 )
  23624    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  23625   "RTN","VPR ROS3",72,0 )
  23626    S VPRTIEN =+$P(VPRY, "^",3),VPE RR="",VPRT LST=""
  23627   "RTN","VPR ROS3",73,0 )
  23628    D PTTM^SC APMC(VPRTI EN,,"VPRTL ST",VPERR)
  23629   "RTN","VPR ROS3",74,0 )
  23630    S VPRIII= "" F  S VP RIII=$O(VP RTLST(VPRI II)) Q:VPR III'>0  S  DFN=$P(VPR TLST(VPRII I),"^",1)  S VPRLIST2 (DFN)=""
  23631   "RTN","VPR ROS3",75,0 )
  23632    Q
  23633   "RTN","VPR ROS3",76,0 )
  23634    ;
  23635   "RTN","VPR ROS3",77,0 )
  23636   CPRS ;Proc ess patien ts from CP RS Lists
  23637   "RTN","VPR ROS3",78,0 )
  23638    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  23639   "RTN","VPR ROS3",79,0 )
  23640    S VPROIEN =+$P(VPRY, "^",3),VPE RR=""
  23641   "RTN","VPR ROS3",80,0 )
  23642    S VPRIII= 0 F  S VPR III=$O(^OR (100.21,VP ROIEN,10,V PRIII)) Q: VPRIII'>0   S DFN=$P( ^OR(100.21 ,VPROIEN,1 0,VPRIII,0 ),";",1) S  VPRLIST2( DFN)=""
  23643   "RTN","VPR ROS3",81,0 )
  23644    Q
  23645   "RTN","VPR ROS3",82,0 )
  23646    ;
  23647   "RTN","VPR ROS3",83,0 )
  23648   ROST ;Proc ess patien ts from se lected ros ter
  23649   "RTN","VPR ROS3",84,0 )
  23650    N VPR,VPR IEN,VPERR
  23651   "RTN","VPR ROS3",85,0 )
  23652    S VPRIEN= +$P(VPRY," ^",3),VPER R="",VPROU T=1
  23653   "RTN","VPR ROS3",86,0 )
  23654    D COMPILE ^VPRROS2(. VPR,VPRIEN ,"")
  23655   "RTN","VPR ROS3",87,0 )
  23656    M VPRLIST =VPRLIST2
  23657   "RTN","VPR ROS3",88,0 )
  23658    K VPROUT
  23659   "RTN","VPR ROS3",89,0 )
  23660    Q
  23661   "RTN","VPR ROS3",90,0 )
  23662    ;
  23663   "RTN","VPR ROS3",91,0 )
  23664   SPEC ;Proc ess patien ts with se lected Tre ating Spec ialty
  23665   "RTN","VPR ROS3",92,0 )
  23666    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  23667   "RTN","VPR ROS3",93,0 )
  23668    S VPROIEN =+$P(VPRY, "^",3),VPE RR=""
  23669   "RTN","VPR ROS3",94,0 )
  23670    N DFN S D FN=0 F  S  DFN=$O(^DP T("ATR",VP ROIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  23671   "RTN","VPR ROS3",95,0 )
  23672    Q
  23673   "RTN","VPR ROS3",96,0 )
  23674    ;
  23675   "RTN","VPR ROS3",97,0 )
  23676   PROV ;Proc ess patien ts for sel ected prov ider
  23677   "RTN","VPR ROS3",98,0 )
  23678    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  23679   "RTN","VPR ROS3",99,0 )
  23680    S VPRPIEN =+$P(VPRY, "^",3),VPE RR=""
  23681   "RTN","VPR ROS3",100, 0)
  23682    N DFN S D FN=0 F  S  DFN=$O(^DP T("APR",VP RPIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  23683   "RTN","VPR ROS3",101, 0)
  23684    Q
  23685   "RTN","VPR ROS3",102, 0)
  23686    ;
  23687   "RTN","VPR ROS3",103, 0)
  23688   PXRM ;Proc ess patien ts for sel ected pane l
  23689   "RTN","VPR ROS3",104, 0)
  23690    K VPRLIST 2,VPROUT,V PRPAT,VPRR IEN S VPRL IST2=""
  23691   "RTN","VPR ROS3",105, 0)
  23692    S VPRPIEN =+$P(VPRY, "^",3),VPE RR="",VPRL IEN=$P($G( ^PXRM(810. 4,VPRPIEN, 0)),"^",1)  I VPRLIEN ="" S @VPR @(1)="Inva lid PXRM"  Q
  23693   "RTN","VPR ROS3",106, 0)
  23694    ;S VPRRIE N=$O(^VPRO STER("B",V PRRNAME,"" )) I VPRRI EN'>0 S @V PR@(1)="In valid PXRM " Q
  23695   "RTN","VPR ROS3",107, 0)
  23696    ;S VPRPNM E=$P(^VPRO STER(VPRRI EN,0),"^", 6)
  23697   "RTN","VPR ROS3",108, 0)
  23698    S VPRC=VP RPIEN
  23699   "RTN","VPR ROS3",109, 0)
  23700    S VPRPAT= "" D RUNLI ST^VPRROS5 (.VPRPAT,V PRPIEN,VPR RNAME,0,1)
  23701   "RTN","VPR ROS3",110, 0)
  23702    S VPRII=0  F  S VPRI I=$O(VPRPA T(VPRC,VPR II)) Q:VPR II'>0  S D FN=VPRPAT( VPRC,VPRII ),VPRLIST2 (DFN)=""
  23703   "RTN","VPR ROS3",111, 0)
  23704    Q
  23705   "RTN","VPR ROS3",112, 0)
  23706    ;
  23707   "RTN","VPR ROS3",113, 0)
  23708   UNION ;Add  to existi ng list
  23709   "RTN","VPR ROS3",114, 0)
  23710    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  S VPRL IST(VPRII) =""
  23711   "RTN","VPR ROS3",115, 0)
  23712    Q
  23713   "RTN","VPR ROS3",116, 0)
  23714    ;
  23715   "RTN","VPR ROS3",117, 0)
  23716   INTER ;Int ersect wit h existing  list
  23717   "RTN","VPR ROS3",118, 0)
  23718    S VPRII=0  F  S VPRI I=$O(VPRLI ST(VPRII))  Q:VPRII'> 0  D
  23719   "RTN","VPR ROS3",119, 0)
  23720    . I '$D(V PRLIST2(VP RII)) K VP RLIST(VPRI I)
  23721   "RTN","VPR ROS3",120, 0)
  23722    Q
  23723   "RTN","VPR ROS3",121, 0)
  23724    ;
  23725   "RTN","VPR ROS3",122, 0)
  23726   DIFF ;Remo ve patient s from thi s source t hat we hav e so far o r add new  one
  23727   "RTN","VPR ROS3",123, 0)
  23728    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  D
  23729   "RTN","VPR ROS3",124, 0)
  23730    . I '$D(V PRLIST(VPR II)) S VPR LIST(VPRII )=""
  23731   "RTN","VPR ROS3",125, 0)
  23732    . E  K VP RLIST(VPRI I)
  23733   "RTN","VPR ROS3",126, 0)
  23734    Q
  23735   "RTN","VPR ROS3",127, 0)
  23736    ;
  23737   "RTN","VPR ROS3",128, 0)
  23738   SEND ;send  pending r osters.  C alled thro ugh RPC
  23739   "RTN","VPR ROS3",129, 0)
  23740    S VPRRCNT =0,VPRI=0, VPRII=0
  23741   "RTN","VPR ROS3",130, 0)
  23742    S VPRVER= "<results  version='" _$P($T(VPR ROS3+1),"; ",3)_"'>"
  23743   "RTN","VPR ROS3",131, 0)
  23744    D ADD(VPR VER)
  23745   "RTN","VPR ROS3",132, 0)
  23746    ;S VPRRNA ME=$P(^VPR OSTER(VPRI EN,0),"^", 1),VPRDNAM E=$P(^VPRO STER(VPRIE N,0),"^",2 )
  23747   "RTN","VPR ROS3",133, 0)
  23748    S VPRTEXT ="<roster  ien='' own ername='"_ VPROWNNM_" '  ownerid ='"_VPROWN ID_"'>" D  ADD(VPRTEX T)
  23749   "RTN","VPR ROS3",134, 0)
  23750    S VPRTEXT ="<rosterN ame>"_VPRR NAME_"</ro sterName>"  D ADD(VPR TEXT)
  23751   "RTN","VPR ROS3",135, 0)
  23752    S VPRTEXT ="<display Name>"_VPR DNAME_"</d isplayName >" D ADD(V PRTEXT)
  23753   "RTN","VPR ROS3",136, 0)
  23754    D ADD("<p atients>")
  23755   "RTN","VPR ROS3",137, 0)
  23756    K VPRII S  VPRII=0 F   S VPRII= $O(VPRLIST (VPRII)) Q :VPRII'>0   D 
  23757   "RTN","VPR ROS3",138, 0)
  23758    . S DFN=V PRII
  23759   "RTN","VPR ROS3",139, 0)
  23760    . S ICN=$ $GETICN^MP IF001(DFN)
  23761   "RTN","VPR ROS3",140, 0)
  23762    . S NAME= $P(^DPT(DF N,0),"^",1 ),GENDER=$ P(^DPT(DFN ,0),"^",2) ,SSN=$P(^D PT(DFN,0), "^",9),DOB =$P(^DPT(D FN,0),"^", 3),VPRDOB= $$FMTHL7^X LFDT(DOB)
  23763   "RTN","VPR ROS3",141, 0)
  23764    . S Y="<p atient nam e='"_NAME_ "' gender= '"_GENDER_ "' dob='"_ VPRDOB_"'  ssn='"_SSN _"' id='"_ DFN_$S(ICN :"' icn='" _ICN,1:"") _"' />" D  ADD(Y)
  23765   "RTN","VPR ROS3",142, 0)
  23766    D ADD("</ patients>" )
  23767   "RTN","VPR ROS3",143, 0)
  23768    D ADD("</ roster>")
  23769   "RTN","VPR ROS3",144, 0)
  23770    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  23771   "RTN","VPR ROS3",145, 0)
  23772    Q
  23773   "RTN","VPR ROS3",146, 0)
  23774    ;
  23775   "RTN","VPR ROS3",147, 0)
  23776    ;
  23777   "RTN","VPR ROS3",148, 0)
  23778   ADD(X) ; - - Add a li ne @VPR@(n )=X
  23779   "RTN","VPR ROS3",149, 0)
  23780    S VPRI=$G (VPRI)+1
  23781   "RTN","VPR ROS3",150, 0)
  23782    S @VPR@(V PRI)=X
  23783   "RTN","VPR ROS3",151, 0)
  23784    Q
  23785   "RTN","VPR ROS3",152, 0)
  23786    ;
  23787   "RTN","VPR ROS3",153, 0)
  23788   UPDATE(VPR ,VPRARRAY)  ;;Update  Roster dat a with dat a from GUI
  23789   "RTN","VPR ROS3",154, 0)
  23790    N VPRZ,VP RRNAME,VPR ID,VPRDNAM E,VPRDIS,V PRRID,FDA, VPROWNID,V PRSRCID,VP ROP,VPRSRC NM,VPRLAB, VPRVAR,BEF ORE,AFTER
  23791   "RTN","VPR ROS3",155, 0)
  23792    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  23793   "RTN","VPR ROS3",156, 0)
  23794    S VPR=$NA (^TMP($J," VPROSTER") )
  23795   "RTN","VPR ROS3",157, 0)
  23796    Q:'$$VALI DATE
  23797   "RTN","VPR ROS3",158, 0)
  23798    D NOW^%DT C S VPRDT= % ;added 5 /11/12 grr  for traci ng
  23799   "RTN","VPR ROS3",159, 0)
  23800    S VPRZ=""  S VPRZ=$O (VPRARRAY( VPRZ)) Q:V PRZ=""
  23801   "RTN","VPR ROS3",160, 0)
  23802    S VPRRNAM E=$P(VPRAR RAY(VPRZ), "^",1),VPR RID=$P(VPR ARRAY(VPRZ ),"^",2),V PRDNAME=$P (VPRARRAY( VPRZ),"^", 3),VPRDIS= $P(VPRARRA Y(VPRZ),"^ ",4),VPROW NID=$P(VPR ARRAY(VPRZ ),"^",5)
  23803   "RTN","VPR ROS3",161, 0)
  23804    D:VPRRID> 0 BEFORE
  23805   "RTN","VPR ROS3",162, 0)
  23806    I VPRRID= "" D ADDRO S
  23807   "RTN","VPR ROS3",163, 0)
  23808    I '$D(^VP ROSTER(VPR RID,0)) S  @VPR@(1)=" RosterID p assed was  invalid" Q
  23809   "RTN","VPR ROS3",164, 0)
  23810    S FDA(1,5 61.2,""_VP RRID_","_" ",.01)=VPR RNAME
  23811   "RTN","VPR ROS3",165, 0)
  23812    S FDA(1,5 61.2,""_VP RRID_","_" ",.02)=VPR DNAME
  23813   "RTN","VPR ROS3",166, 0)
  23814    S FDA(1,5 61.2,""_VP RRID_","_" ",.03)=VPR DIS
  23815   "RTN","VPR ROS3",167, 0)
  23816    S FDA(1,5 61.2,""_VP RRID_","_" ",.04)=VPR OWNID
  23817   "RTN","VPR ROS3",168, 0)
  23818    S FDA(1,5 61.2,""_VP RRID_","_" ",99)=VPRD T
  23819   "RTN","VPR ROS3",169, 0)
  23820    D UPDATE^ DIE("","FD A(1)")
  23821   "RTN","VPR ROS3",170, 0)
  23822    K ^VPROST ER(VPRRID, 1),FDA
  23823   "RTN","VPR ROS3",171, 0)
  23824    F  S VPRZ =$O(VPRARR AY(VPRZ))  Q:VPRZ=""   D
  23825   "RTN","VPR ROS3",172, 0)
  23826    . S VPRY= VPRARRAY(V PRZ)
  23827   "RTN","VPR ROS3",173, 0)
  23828    . S VPRSR CID=$P(VPR Y,"^",3)
  23829   "RTN","VPR ROS3",174, 0)
  23830    . S VPROP =$P(VPRY," ^",2)
  23831   "RTN","VPR ROS3",175, 0)
  23832    . S VPRSR CNM=$$UP^X LFSTR($P(V PRY,"^",1) )
  23833   "RTN","VPR ROS3",176, 0)
  23834    . S VPRLA B=""
  23835   "RTN","VPR ROS3",177, 0)
  23836    . I VPRSR CNM["CLINI C" S VPRVA R="SC("
  23837   "RTN","VPR ROS3",178, 0)
  23838    . I VPRSR CNM["WARD"  S VPRVAR= "DIC(42,"
  23839   "RTN","VPR ROS3",179, 0)
  23840    . I VPRSR CNM["PATIE NT" S VPRV AR="DPT("
  23841   "RTN","VPR ROS3",180, 0)
  23842    . I VPRSR CNM["PCMM  TEAM" S VP RVAR="SCTM (404.51,"
  23843   "RTN","VPR ROS3",181, 0)
  23844    . I VPRSR CNM["OE/RR " S VPRVAR ="OR(100.2 1,"
  23845   "RTN","VPR ROS3",182, 0)
  23846    . I VPRSR CNM["VPR R OSTER" S V PRVAR="VPR OSTER("
  23847   "RTN","VPR ROS3",183, 0)
  23848    . I VPRSR CNM["SPECI ALTY" S VP RVAR="DIC( 45.7,"
  23849   "RTN","VPR ROS3",184, 0)
  23850    . I VPRSR CNM["PROVI DER" S VPR VAR="VA(20 0,"
  23851   "RTN","VPR ROS3",185, 0)
  23852    . I VPRSR CNM["PXRM"  S VPRVAR= "PXRM(810. 4,"
  23853   "RTN","VPR ROS3",186, 0)
  23854    . S FDA(1 ,561.21,"+ 1,"_VPRRID _",",.01)= VPRZ
  23855   "RTN","VPR ROS3",187, 0)
  23856    . S FDA(1 ,561.21,"+ 1,"_VPRRID _",",.02)= VPRSRCID_" ;"_VPRVAR
  23857   "RTN","VPR ROS3",188, 0)
  23858    . S FDA(1 ,561.21,"+ 1,"_VPRRID _",",.03)= $S(VPROP=" UNION":0,V PROP="INTE RSECTION": 1,1:2)
  23859   "RTN","VPR ROS3",189, 0)
  23860    . I VPRSR CNM="PXRM"  S FDA(1,5 61.21,"+1, "_VPRRID_" ,",.06)="U PDATE TEST  HMP ROSTE R"
  23861   "RTN","VPR ROS3",190, 0)
  23862    . D UPDAT E^DIE(""," FDA(1)")
  23863   "RTN","VPR ROS3",191, 0)
  23864    ;D GET^VP RROS6(VPRR ID)
  23865   "RTN","VPR ROS3",192, 0)
  23866    S FILTER( "domain")= "roster",F ILTER("id" )=VPRRID
  23867   "RTN","VPR ROS3",193, 0)
  23868    D GET^VPR EF(.VPR,.F ILTER)
  23869   "RTN","VPR ROS3",194, 0)
  23870    S RESULT= $$COMPARE( .BEFORE,.A FTER)
  23871   "RTN","VPR ROS3",195, 0)
  23872    I RESULT= 1 D POSTX^ VPREVNT("r oster",VPR RID) ;if R ESULT is 1  means ros ter has ch anged
  23873   "RTN","VPR ROS3",196, 0)
  23874    Q
  23875   "RTN","VPR ROS3",197, 0)
  23876    ;
  23877   "RTN","VPR ROS3",198, 0)
  23878   ADDROS ;
  23879   "RTN","VPR ROS3",199, 0)
  23880    N DIC,DLA YGO,X,Y
  23881   "RTN","VPR ROS3",200, 0)
  23882    S DIC="^V PROSTER(", DIC(0)="LQ ",DLAYGO=5 61.2,X=VPR RNAME D ^D IC S VPRRI D=+Y
  23883   "RTN","VPR ROS3",201, 0)
  23884    Q
  23885   "RTN","VPR ROS3",202, 0)
  23886    ;
  23887   "RTN","VPR ROS3",203, 0)
  23888   DELROS(VPR ,VPRIEN) ;
  23889   "RTN","VPR ROS3",204, 0)
  23890    S HDUZ(0) =DUZ(0),DU Z(0)="@",D IK="^VPROS TER(",DA=V PRIEN,DIDE L=1 D ^DIK  S DUZ(0)= HDUZ(0),VP R="Roster  Deleted!"
  23891   "RTN","VPR ROS3",205, 0)
  23892    K HDUZ,DI K,DIDEL
  23893   "RTN","VPR ROS3",206, 0)
  23894    Q
  23895   "RTN","VPR ROS3",207, 0)
  23896    ;
  23897   "RTN","VPR ROS3",208, 0)
  23898   COMPARE(OL D,NEW) ;
  23899   "RTN","VPR ROS3",209, 0)
  23900    N VPRII,D IFF
  23901   "RTN","VPR ROS3",210, 0)
  23902    S VPRII=0  F  S VPRI I=$O(OLD(V PRII)) Q:V PRII'>0  D
  23903   "RTN","VPR ROS3",211, 0)
  23904    . I '$D(N EW(VPRII))  S NEW(VPR II)=""
  23905   "RTN","VPR ROS3",212, 0)
  23906    . E  K NE W(VPRII)
  23907   "RTN","VPR ROS3",213, 0)
  23908    S DIFF=$S ($O(NEW(0) )'>0:0,1:1 )
  23909   "RTN","VPR ROS3",214, 0)
  23910    Q DIFF
  23911   "RTN","VPR ROS3",215, 0)
  23912    ;
  23913   "RTN","VPR ROS3",216, 0)
  23914   VALIDATE()  ;Will ver ify VPRARR AY entries  are all v alid
  23915   "RTN","VPR ROS3",217, 0)
  23916    N I,OUT,O K
  23917   "RTN","VPR ROS3",218, 0)
  23918    S I="",OK =0,OUT=0
  23919   "RTN","VPR ROS3",219, 0)
  23920    F  S I=$O (VPRARRAY( I)) Q:I=""   D  Q:OUT
  23921   "RTN","VPR ROS3",220, 0)
  23922    . I $L(VP RARRAY(I), "^")'=5&($ L(VPRARRAY (I),"^")'= 3) S @VPR@ (1)="Param eter forma t invalid:  "_VPRARRA Y(I) S OK= 0,OUT=1 Q
  23923   "RTN","VPR ROS3",221, 0)
  23924    . I $L(VP RARRAY(I), "^")=3 D   Q:OUT
  23925   "RTN","VPR ROS3",222, 0)
  23926    . . I $P( VPRARRAY(I ),"^",2)=" UNION"!($P (VPRARRAY( I),"^",2)= "INTERSECT ION")!($P( VPRARRAY(I ),"^",2)=" DIFFERENCE ") S OK=1, OUT=0
  23927   "RTN","VPR ROS3",223, 0)
  23928    . . E  S  OK=0,OUT=1 ,@VPR@(1)= "Parameter  format in valid: "_V PRARRAY(I)  Q
  23929   "RTN","VPR ROS3",224, 0)
  23930    . . I $P( VPRARRAY(I ),"^",3)>0  S OK=1,OU T=0
  23931   "RTN","VPR ROS3",225, 0)
  23932    . . E  S  OK=0,OUT=1 ,@VPR@(1)= "Parameter  format in valid: "_V PRARRAY(I)  Q
  23933   "RTN","VPR ROS3",226, 0)
  23934    Q OK
  23935   "RTN","VPR ROS3",227, 0)
  23936    ;
  23937   "RTN","VPR ROS3",228, 0)
  23938   BEFORE ;SA VE EXISTIN G ROSTER P ATIENTS
  23939   "RTN","VPR ROS3",229, 0)
  23940    Q:$O(^VPR OSTER(VPRR ID,4,0))'> 0
  23941   "RTN","VPR ROS3",230, 0)
  23942    S I=0 F   S I=$O(^VP ROSTER(VPR RID,4,I))  Q:I'>0  S  DFN=$P(^VP ROSTER(VPR RID,4,I,0) ,"^"),BEFO RE(DFN)=""
  23943   "RTN","VPR ROS3",231, 0)
  23944    Q
  23945   "RTN","VPR ROS3",232, 0)
  23946    ;
  23947   "RTN","VPR ROS3",233, 0)
  23948   TEST ;TEMP ORARY
  23949   "RTN","VPR ROS3",234, 0)
  23950    S VPRARRA Y(0)="AAA  TEST^^aaaa  test^^108 8"
  23951   "RTN","VPR ROS3",235, 0)
  23952    S VPRARRA Y(1)="Pati ent^UNION^ 100846"
  23953   "RTN","VPR ROS3",236, 0)
  23954    S VPRARRA Y(2)="Pati ent^UNION^ 100847"
  23955   "RTN","VPR ROS3",237, 0)
  23956    D UPDATE( .VPR,.VPRA RRAY)
  23957   "RTN","VPR ROS3",238, 0)
  23958    Q
  23959   "RTN","VPR ROS3",239, 0)
  23960   TEST0 ;
  23961   "RTN","VPR ROS3",240, 0)
  23962    S BEFORE( 1)="",BEFO RE(5)="",B EFORE(8)=" ",AFTER(1) ="",AFTER( 5)="",AFTE R(8)=""
  23963   "RTN","VPR ROS3",241, 0)
  23964    S RESULT= $$COMPARE( .BEFORE,.A FTER)
  23965   "RTN","VPR ROS3",242, 0)
  23966    W "RESULT  IS: ",RES ULT
  23967   "RTN","VPR ROS3",243, 0)
  23968    Q
  23969   "RTN","VPR ROS3",244, 0)
  23970    ;
  23971   "RTN","VPR ROS3",245, 0)
  23972   TEST1 ;
  23973   "RTN","VPR ROS3",246, 0)
  23974    S BEFORE( 1)="",BEFO RE(5)="",B EFORE(8)=" ",AFTER(5) ="",AFTER( 8)=""
  23975   "RTN","VPR ROS3",247, 0)
  23976    S RESULT= $$COMPARE( .BEFORE,.A FTER)
  23977   "RTN","VPR ROS3",248, 0)
  23978    W "RESULT  IS: ",RES ULT
  23979   "RTN","VPR ROS3",249, 0)
  23980    Q
  23981   "RTN","VPR ROS3",250, 0)
  23982    ;
  23983   "RTN","VPR ROS4")
  23984   0^15^B9130 2550
  23985   "RTN","VPR ROS4",1,0)
  23986   VPRROS4 ;S LC/GRR --  Roster Man agement
  23987   "RTN","VPR ROS4",2,0)
  23988    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;AUG  17, 2011;B uild 205
  23989   "RTN","VPR ROS4",3,0)
  23990   GETSRC(VPR ,VPRSRC,VP RFILT) ;;  Get Source  data from  requested  source ty pe
  23991   "RTN","VPR ROS4",4,0)
  23992    ;;  For e xample, If  source ty pe is "Cli nic", pass  all clini c names an d id's to  calling GU I
  23993   "RTN","VPR ROS4",5,0)
  23994    ;; Input  - VPRARRAY  - contain s roster d ata entere d thru GUI
  23995   "RTN","VPR ROS4",6,0)
  23996    ;K VPRLIS T,VPRLIST2
  23997   "RTN","VPR ROS4",7,0)
  23998    I '$D(VPR FILT) S VP RFILT=""
  23999   "RTN","VPR ROS4",8,0)
  24000    N VPRLIST ,VPRLIST2, VPRTYPE,VP ERR,VPRI,V PRRNAME,VP RY,VPROP,V PRTAG,VPRL AB,VPRNLIS T,VPRSTN,V PRTEXT,VPR VER,Y,ACT, CHK,CSNM
  24001   "RTN","VPR ROS4",9,0)
  24002    N CSNUM,C SP,IDNAME, IDVALUE,TY PENM,UPNAM E,VDATE,VP RACT,VPRDA TA,VPRDIVP ,VPRNAME,V PRCNT,VPRR CNT,ACTIVE
  24003   "RTN","VPR ROS4",10,0 )
  24004    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  24005   "RTN","VPR ROS4",11,0 )
  24006    S (VPRLIS T,VPRTYPE, VPROP,VPRL IST2,VPERR )="",VPRI= 0
  24007   "RTN","VPR ROS4",12,0 )
  24008    K ^TMP($J ,"VPROSTER ")
  24009   "RTN","VPR ROS4",13,0 )
  24010    S VPR=$NA (^TMP($J," VPROSTER") )
  24011   "RTN","VPR ROS4",14,0 )
  24012    S VPRACT= "I 1"
  24013   "RTN","VPR ROS4",15,0 )
  24014    I VPRFILT '="" S X=V PRFILT X ^ %ZOSF("UPP ERCASE") S  VPRFILT=Y  S VPRACT= "I UPNAME[ VPRFILT"
  24015   "RTN","VPR ROS4",16,0 )
  24016    I VPRSRC[ "Clinic" S  VPRLAB="C LIN"
  24017   "RTN","VPR ROS4",17,0 )
  24018    I VPRSRC[ "Ward" S V PRLAB="WAR D"
  24019   "RTN","VPR ROS4",18,0 )
  24020    I VPRSRC[ "Patient"  S VPRLAB=" PAT"
  24021   "RTN","VPR ROS4",19,0 )
  24022    I VPRSRC[ "PCMM Team " S VPRLAB ="PCMM"
  24023   "RTN","VPR ROS4",20,0 )
  24024    I VPRSRC[ "OE/RR" S  VPRLAB="CP RS"
  24025   "RTN","VPR ROS4",21,0 )
  24026    I VPRSRC[ "VPR Roste r" S VPRLA B="ROST"
  24027   "RTN","VPR ROS4",22,0 )
  24028    I VPRSRC[ "Specialty " S VPRLAB ="SPEC"
  24029   "RTN","VPR ROS4",23,0 )
  24030    I VPRSRC[ "Provider"  S VPRLAB= "PROV"
  24031   "RTN","VPR ROS4",24,0 )
  24032    I VPRSRC[ "PXRM" S V PRLAB="PXR M"
  24033   "RTN","VPR ROS4",25,0 )
  24034    I VPRLAB= "" S VPERR ="1^INVALI D SOURCE T YPE" Q
  24035   "RTN","VPR ROS4",26,0 )
  24036    D @VPRLAB
  24037   "RTN","VPR ROS4",27,0 )
  24038    D SEND
  24039   "RTN","VPR ROS4",28,0 )
  24040    Q VPR
  24041   "RTN","VPR ROS4",29,0 )
  24042    ;
  24043   "RTN","VPR ROS4",30,0 )
  24044   CLIN ;Proc ess patien ts for thi s clinic.   Select al l if filte r is null
  24045   "RTN","VPR ROS4",31,0 )
  24046    K VPRARRA Y S VPRARR AY=""
  24047   "RTN","VPR ROS4",32,0 )
  24048    S VPRNAME ="" F  S V PRNAME=$O( ^SC("B",VP RNAME)) Q: VPRNAME=""   S X=VPRN AME X ^%ZO SF("UPPERC ASE") S UP NAME=Y X V PRACT I  D
  24049   "RTN","VPR ROS4",33,0 )
  24050    . S VPRI= $O(^SC("B" ,VPRNAME,0 )) I ($P(^ SC(VPRI,0) ,"^",3)="C ")&($$ACTL OC^ORWU(VP RI)) D
  24051   "RTN","VPR ROS4",34,0 )
  24052    . . I $D( ^SC(VPRI," I")) Q:$P( ^("I"),"^" ,2)=""  ;a dded 4/24/ 2013
  24053   "RTN","VPR ROS4",35,0 )
  24054    . . S (CS P,CSNM,CSN UM,SVC,SER VICE,VPRDI V,VPRDIVP) ="" ;added  4/24/2013
  24055   "RTN","VPR ROS4",36,0 )
  24056    . . S CSP =$P(^SC(VP RI,0),"^", 7) I CSP]" " S CSNM=$ P(^DIC(40. 7,CSP,0)," ^",1),CSNU M=$P(^DIC( 40.7,CSP,0 ),"^",2) ; modified 4 /24/2013
  24057   "RTN","VPR ROS4",37,0 )
  24058    . . S VPR DIVP=$P(^S C(VPRI,0), "^",15) I  VPRDIVP]""  S VPRDIV= $P($G(^DG( 40.8,VPRDI VP,0)),"^" ,1) ;modif ied 4/24/2 013
  24059   "RTN","VPR ROS4",38,0 )
  24060    . . S SVC =$P(^SC(VP RI,0),"^", 8),SERVICE =$S(SVC="M ":"MEDICIN E",SVC="S" :"SURGERY" ,SVC="P":" PSYCHIATRY ",SVC="R": "REHAB MED ICINE",SVC ="N":"NEUR OLOGY",1:" NONE")
  24061   "RTN","VPR ROS4",39,0 )
  24062    . . S VPR ARRAY(VPRN AME)=VPRI
  24063   "RTN","VPR ROS4",40,0 )
  24064    . . S VPR ARRAY(VPRN AME,1)="DI VISION"_"^ "_VPRDIV
  24065   "RTN","VPR ROS4",41,0 )
  24066    . . S VPR ARRAY(VPRN AME,2)="CL INIC STOP  NAME"_"^"_ CSNM
  24067   "RTN","VPR ROS4",42,0 )
  24068    . . S VPR ARRAY(VPRN AME,3)="CL INIC STOP  NUMBER"_"^ "_CSNUM
  24069   "RTN","VPR ROS4",43,0 )
  24070    . . S VPR ARRAY(VPRN AME,4)="SE RVICE"_"^" _SERVICE
  24071   "RTN","VPR ROS4",44,0 )
  24072    Q
  24073   "RTN","VPR ROS4",45,0 )
  24074    ;
  24075   "RTN","VPR ROS4",46,0 )
  24076   WARD ;Proc ess patien ts for thi s ward
  24077   "RTN","VPR ROS4",47,0 )
  24078    K VPRARRA Y S VPRARR AY=""
  24079   "RTN","VPR ROS4",48,0 )
  24080    S VPRNAME ="" F  S V PRNAME=$O( ^DIC(42,"B ",VPRNAME) ) Q:VPRNAM E=""  S X= VPRNAME X  ^%ZOSF("UP PERCASE")  S UPNAME=Y  X VPRACT  I  D 
  24081   "RTN","VPR ROS4",49,0 )
  24082    . S VPRI= $O(^DIC(42 ,"B",VPRNA ME,0))
  24083   "RTN","VPR ROS4",50,0 )
  24084    . S VPRAR RAY(VPRNAM E)=VPRI
  24085   "RTN","VPR ROS4",51,0 )
  24086    . N DIVP, VPRDIV,SPE CP,SPEC,SV C,SERVICE
  24087   "RTN","VPR ROS4",52,0 )
  24088    . S (DIVP ,VPRDIV,SP ECP,SPEC,S VC,SERVICE )=""
  24089   "RTN","VPR ROS4",53,0 )
  24090    . S DIVP= $P(^DIC(42 ,VPRI,0)," ^",11) I D IVP]"" S V PRDIV=$P($ G(^DG(40.8 ,DIVP,0)), "^",1)
  24091   "RTN","VPR ROS4",54,0 )
  24092    . S SPECP =$P(^DIC(4 2,VPRI,0), "^",12) I  SPECP]"" S  SPEC=$P($ G(^DIC(42. 4,SPECP,0) ),"^",1)
  24093   "RTN","VPR ROS4",55,0 )
  24094    . S SVC=$ P(^DIC(42, VPRI,0),"^ ",3)
  24095   "RTN","VPR ROS4",56,0 )
  24096    . S SERVI CE=$S(SVC= "M":"MEDIC INE",SVC=" S":"SURGER Y",SVC="P" :"PSYCHIAT RY",SVC="N H":"NHCU", SVC="NE":" NEUROLOGY" ,SVC="I":" INTERMEDIA TE MEDICIN E",1:"")
  24097   "RTN","VPR ROS4",57,0 )
  24098    . S:'$L(S ERVICE) SE RVICE=$S(S VC="R":"RE HAB MEDICI NE",SVC="S CI":"SPINA L CORD INJ URY",SVC=" D":"DOMICI LLIARY",SV C="B":"BLI ND REHAB", 1:"NONE")
  24099   "RTN","VPR ROS4",58,0 )
  24100    . S VPRAR RAY(VPRNAM E,1)="DIVI SION"_"^"_ VPRDIV
  24101   "RTN","VPR ROS4",59,0 )
  24102    . S VPRAR RAY(VPRNAM E,2)="SPEC IALTY"_"^" _SPEC
  24103   "RTN","VPR ROS4",60,0 )
  24104    . S VPRAR RAY(VPRNAM E,3)="SERV ICE"_"^"_S ERVICE
  24105   "RTN","VPR ROS4",61,0 )
  24106    Q
  24107   "RTN","VPR ROS4",62,0 )
  24108    ;
  24109   "RTN","VPR ROS4",63,0 )
  24110   PAT ;Proce ss patient  from Pati ent file S ource
  24111   "RTN","VPR ROS4",64,0 )
  24112    K VPRARRA Y S VPRARR AY=""
  24113   "RTN","VPR ROS4",65,0 )
  24114    N DFN,SEX ,DOB,SSN,I CN,DOBOUT
  24115   "RTN","VPR ROS4",66,0 )
  24116    I VPRFILT ?1U4N D  Q
  24117   "RTN","VPR ROS4",67,0 )
  24118    . I $D(^D PT("BS5",V PRFILT)) D
  24119   "RTN","VPR ROS4",68,0 )
  24120    . . S VPR I=0 F  S V PRI=$O(^DP T("BS5",VP RFILT,VPRI )) Q:VPRI' >0  D
  24121   "RTN","VPR ROS4",69,0 )
  24122    . . . S D FN=VPRI,IC N=$$GETICN ^MPIF001(D FN)
  24123   "RTN","VPR ROS4",70,0 )
  24124    . . . K W ARN S WARN ="" D SECC HK ;ZW WAR N
  24125   "RTN","VPR ROS4",71,0 )
  24126    . . . S V PRNAME=$P( ^DPT(VPRI, 0),"^",1), VPRARRAY(V PRNAME)=VP RI
  24127   "RTN","VPR ROS4",72,0 )
  24128    . . . S S EX=$P(^DPT (VPRI,0)," ^",2),DOB= $P(^DPT(VP RI,0),"^", 3),SSN=$P( ^DPT(VPRI, 0),"^",9)
  24129   "RTN","VPR ROS4",73,0 )
  24130    . . . S D OBOUT=$$FM THL7^XLFDT (DOB)
  24131   "RTN","VPR ROS4",74,0 )
  24132    . . . S V PRARRAY(VP RNAME,1)=" ICN"_"^"_I CN
  24133   "RTN","VPR ROS4",75,0 )
  24134    . . . S V PRARRAY(VP RNAME,2)=" GENDER"_"^ "_$S(SEX=" M":"MALE", SEX="F":"F EMALE",1:" NONE")
  24135   "RTN","VPR ROS4",76,0 )
  24136    . . . S V PRARRAY(VP RNAME,3)=" DOB"_"^"_D OBOUT
  24137   "RTN","VPR ROS4",77,0 )
  24138    . . . S V PRARRAY(VP RNAME,4)=" SSN"_"^"_S SN
  24139   "RTN","VPR ROS4",78,0 )
  24140    S VPRNAME =VPRFILT
  24141   "RTN","VPR ROS4",79,0 )
  24142    I $D(^DPT ("B",VPRNA ME)) D  Q
  24143   "RTN","VPR ROS4",80,0 )
  24144    . S VPRI= 0 F  S VPR I=$O(^DPT( "B",VPRNAM E,VPRI)) Q :VPRI'>0   S VPRARRAY (VPRNAME)= VPRI D
  24145   "RTN","VPR ROS4",81,0 )
  24146    . . S DFN =VPRI,ICN= $$GETICN^M PIF001(DFN )
  24147   "RTN","VPR ROS4",82,0 )
  24148    . . K WAR N S WARN=" " D SECCHK  ;ZW WARN
  24149   "RTN","VPR ROS4",83,0 )
  24150    . . S SEX =$P(^DPT(V PRI,0),"^" ,2),DOB=$P (^DPT(VPRI ,0),"^",3) ,SSN=$P(^D PT(VPRI,0) ,"^",9)
  24151   "RTN","VPR ROS4",84,0 )
  24152    . . S DOB OUT=$$FMTH L7^XLFDT(D OB)
  24153   "RTN","VPR ROS4",85,0 )
  24154    . . S VPR ARRAY(VPRN AME,1)="IC N"_"^"_ICN
  24155   "RTN","VPR ROS4",86,0 )
  24156    . . S VPR ARRAY(VPRN AME,2)="GE NDER"_"^"_ $S(SEX="M" :"MALE",SE X="F":"FEM ALE",1:"NO NE")
  24157   "RTN","VPR ROS4",87,0 )
  24158    . . S VPR ARRAY(VPRN AME,3)="DO B"_"^"_DOB OUT
  24159   "RTN","VPR ROS4",88,0 )
  24160    . . S VPR ARRAY(VPRN AME,4)="SS N"_"^"_SSN
  24161   "RTN","VPR ROS4",89,0 )
  24162    E  F  S V PRNAME=$O( ^DPT("B",V PRNAME)) Q :VPRNAME=" "!(VPRNAME '[VPRFILT)   D
  24163   "RTN","VPR ROS4",90,0 )
  24164    . S VPRI= 0 F  S VPR I=$O(^DPT( "B",VPRNAM E,VPRI)) Q :VPRI'>0   S VPRARRAY (VPRNAME)= VPRI D
  24165   "RTN","VPR ROS4",91,0 )
  24166    . . S DFN =VPRI,ICN= $$GETICN^M PIF001(DFN )
  24167   "RTN","VPR ROS4",92,0 )
  24168    . . K WAR N S WARN=" " D SECCHK  ;ZW WARN
  24169   "RTN","VPR ROS4",93,0 )
  24170    . . S SEX =$P(^DPT(V PRI,0),"^" ,2),DOB=$P (^DPT(VPRI ,0),"^",3) ,SSN=$P(^D PT(VPRI,0) ,"^",9)
  24171   "RTN","VPR ROS4",94,0 )
  24172    . . S DOB OUT=$$FMTH L7^XLFDT(D OB)
  24173   "RTN","VPR ROS4",95,0 )
  24174    . . S VPR ARRAY(VPRN AME,1)="IC N"_"^"_ICN
  24175   "RTN","VPR ROS4",96,0 )
  24176    . . S VPR ARRAY(VPRN AME,2)="GE NDER"_"^"_ $S(SEX="M" :"MALE",SE X="F":"FEM ALE",1:"NO NE")
  24177   "RTN","VPR ROS4",97,0 )
  24178    . . S VPR ARRAY(VPRN AME,3)="DO B"_"^"_DOB OUT
  24179   "RTN","VPR ROS4",98,0 )
  24180    . . S VPR ARRAY(VPRN AME,4)="SS N"_"^"_SSN
  24181   "RTN","VPR ROS4",99,0 )
  24182    Q
  24183   "RTN","VPR ROS4",100, 0)
  24184    ;
  24185   "RTN","VPR ROS4",101, 0)
  24186   PCMM ;Proc ess patien ts from a  PCMM team
  24187   "RTN","VPR ROS4",102, 0)
  24188    K VPRARRA Y S VPRARR AY=""
  24189   "RTN","VPR ROS4",103, 0)
  24190    S VPRSTN= $P($G(^XMB (1,1,"XUS" )),"^",17)
  24191   "RTN","VPR ROS4",104, 0)
  24192    S VPRI=0  F  S VPRI= $O(^SCTM(4 04.51,"AIN ST",VPRSTN ,VPRI)) Q: VPRI'>0  S  VPRNAME=$ P($G(^SCTM (404.51,VP RI,0)),"^" ,1) S X=VP RNAME X ^% ZOSF("UPPE RCASE") S  UPNAME=Y X  VPRACT I   D
  24193   "RTN","VPR ROS4",105, 0)
  24194    . S VPRAR RAY(VPRNAM E)=VPRI
  24195   "RTN","VPR ROS4",106, 0)
  24196    . N TEAMP ,TEAMPP,SV CP,SERVICE  S (TEAMP, TEAMPP,SVC P,SERVICE) =""
  24197   "RTN","VPR ROS4",107, 0)
  24198    . S TEAMP P=$P(^SCTM (404.51,VP RI,0),"^", 3) I TEAMP P]"" S TEA MP=$P(^SD( 403.47,TEA MPP,0),"^" ,1)
  24199   "RTN","VPR ROS4",108, 0)
  24200    . S SVCP= $P(^SCTM(4 04.51,VPRI ,0),"^",6)  I SVCP]""  S SERVICE =$P(^DIC(4 9,SVCP,0), "^",1)
  24201   "RTN","VPR ROS4",109, 0)
  24202    . S VPRAR RAY(VPRNAM E,1)="TEAM  PURPOSE"_ "^"_TEAMP
  24203   "RTN","VPR ROS4",110, 0)
  24204    . S VPRAR RAY(VPRNAM E,2)="SERV ICE"_"^"_S ERVICE
  24205   "RTN","VPR ROS4",111, 0)
  24206    Q
  24207   "RTN","VPR ROS4",112, 0)
  24208    ;
  24209   "RTN","VPR ROS4",113, 0)
  24210   CPRS ;Proc ess patien ts from CP RS Lists
  24211   "RTN","VPR ROS4",114, 0)
  24212    K VPRARRA Y S VPRARR AY=""
  24213   "RTN","VPR ROS4",115, 0)
  24214    S VPRNAME ="" F  S V PRNAME=$O( ^OR(100.21 ,"B",VPRNA ME)) Q:VPR NAME=""  S  X=VPRNAME  X ^%ZOSF( "UPPERCASE ") S UPNAM E=Y X VPRA CT I  D
  24215   "RTN","VPR ROS4",116, 0)
  24216    . S VPRI= 0 F  S VPR I=$O(^OR(1 00.21,"B", VPRNAME,VP RI)) Q:VPR I'>0  D
  24217   "RTN","VPR ROS4",117, 0)
  24218    . . S VPR ARRAY(VPRN AME)=VPRI
  24219   "RTN","VPR ROS4",118, 0)
  24220    . . N TYP E,CREATP,C REATOR
  24221   "RTN","VPR ROS4",119, 0)
  24222    . . S TYP E=$P(^OR(1 00.21,VPRI ,0),"^",2)
  24223   "RTN","VPR ROS4",120, 0)
  24224    . . S TYP ENM=$S(TYP E="P":"PER SONAL PATI ENT",TYPE= "TA":"TEAM  PATIENT A UTOLINKED" ,TYPE="TM" :"TEAM PAT IENT MANUA L",TYPE="M RAL":"MANU AL REMOVAL  AUTOLINK  ADDITION", 1:"NONE")
  24225   "RTN","VPR ROS4",121, 0)
  24226    . . S CRE ATP=$P(^OR (100.21,VP RI,0),"^", 5),CREATOR =""
  24227   "RTN","VPR ROS4",122, 0)
  24228    . . I CRE ATP]"" S C REATOR=$P( $G(^VA(200 ,CREATP,0) ),"^",1)
  24229   "RTN","VPR ROS4",123, 0)
  24230    . . S VPR ARRAY(VPRN AME,1)="TY PE"_"^"_TY PENM
  24231   "RTN","VPR ROS4",124, 0)
  24232    . . S VPR ARRAY(VPRN AME,2)="CR EATOR"_"^" _CREATOR
  24233   "RTN","VPR ROS4",125, 0)
  24234    Q
  24235   "RTN","VPR ROS4",126, 0)
  24236    ;
  24237   "RTN","VPR ROS4",127, 0)
  24238   ROST ;Proc ess patien ts from se lected ros ter
  24239   "RTN","VPR ROS4",128, 0)
  24240    K VPRARRA Y S VPRARR AY=""
  24241   "RTN","VPR ROS4",129, 0)
  24242    S VPRNAME ="" F  S V PRNAME=$O( ^VPROSTER( "B",VPRNAM E)) Q:VPRN AME=""  S  X=VPRNAME  X ^%ZOSF(" UPPERCASE" ) S UPNAME =Y X VPRAC T I  D
  24243   "RTN","VPR ROS4",130, 0)
  24244    . S VPRI= $O(^VPROST ER("B",VPR NAME,0)) S  VPRARRAY( VPRNAME)=V PRI
  24245   "RTN","VPR ROS4",131, 0)
  24246    . N DISP, OWNERP,OWN ER
  24247   "RTN","VPR ROS4",132, 0)
  24248    . S DISP= $P(^VPROST ER(VPRI,0) ,"^",2)
  24249   "RTN","VPR ROS4",133, 0)
  24250    . S OWNER P=$P(^VPRO STER(VPRI, 0),"^",4), OWNER=""
  24251   "RTN","VPR ROS4",134, 0)
  24252    . I OWNER P]"" S OWN ER=$P($G(^ VA(200,OWN ERP,0)),"^ ",1)
  24253   "RTN","VPR ROS4",135, 0)
  24254    . S VPRAR RAY(VPRNAM E,1)="DISP LAY NAME"_ "^"_DISP
  24255   "RTN","VPR ROS4",136, 0)
  24256    . S VPRAR RAY(VPRNAM E,2)="OWNE R"_"^"_OWN ER
  24257   "RTN","VPR ROS4",137, 0)
  24258    Q
  24259   "RTN","VPR ROS4",138, 0)
  24260    ;
  24261   "RTN","VPR ROS4",139, 0)
  24262   SPEC ;Proc ess patien ts with se lected Tre ating Spec ialty
  24263   "RTN","VPR ROS4",140, 0)
  24264    K VPRARRA Y S VPRARR AY=""
  24265   "RTN","VPR ROS4",141, 0)
  24266    S VPRNAME ="" F  S V PRNAME=$O( ^DIC(45.7, "B",VPRNAM E)) Q:VPRN AME=""  S  X=VPRNAME  X ^%ZOSF(" UPPERCASE" ) S UPNAME =Y X VPRAC T I  D
  24267   "RTN","VPR ROS4",142, 0)
  24268    . S VPRI= $O(^DIC(45 .7,"B",VPR NAME,0)),V DATE=$O(^D IC(45.7,VP RI,"E","AD ATE","")), ACT=$O(^DI C(45.7,VPR I,"E","ADA TE",VDATE, 0)),ACTIVE =$P(^DIC(4 5.7,VPRI," E",ACT,0), "^",2)
  24269   "RTN","VPR ROS4",143, 0)
  24270    . I ACTIV E D
  24271   "RTN","VPR ROS4",144, 0)
  24272    . . S VPR ARRAY(VPRN AME)=VPRI
  24273   "RTN","VPR ROS4",145, 0)
  24274    . . N SVC ,SERVICE
  24275   "RTN","VPR ROS4",146, 0)
  24276    . . S SVC =$P(^DIC(4 5.7,VPRI,0 ),"^",3)
  24277   "RTN","VPR ROS4",147, 0)
  24278    . . S SER VICE=$S(SV C="M":"MED ICINE",SVC ="S":"SURG ERY",SVC=" P":"PSYCHI ATRY",SVC= "NH":"NHCU ",SVC="NE" :"NEUROLOG Y",SVC="I" :"INTERMED IATE MEDIC INE",1:"")
  24279   "RTN","VPR ROS4",148, 0)
  24280    . . S:'$L (SERVICE)  SERVICE=$S (SVC="R":" REHAB MEDI CINE",SVC= "SCI":"SPI NAL CORD I NJURY",SVC ="D":"DOMI CILLIARY", SVC="B":"B LIND REHAB ",SVC="RE" :"RESPITE  CARE",1:"N ONE")
  24281   "RTN","VPR ROS4",149, 0)
  24282    . . S VPR ARRAY(VPRN AME,1)="SE RVICE"_"^" _SERVICE
  24283   "RTN","VPR ROS4",150, 0)
  24284    Q
  24285   "RTN","VPR ROS4",151, 0)
  24286    ;
  24287   "RTN","VPR ROS4",152, 0)
  24288   PROV ;Proc ess patien ts for sel ected prov ider
  24289   "RTN","VPR ROS4",153, 0)
  24290    K VPRARRA Y S VPRARR AY=""
  24291   "RTN","VPR ROS4",154, 0)
  24292    N TITLEP, VTITLE,SEX
  24293   "RTN","VPR ROS4",155, 0)
  24294    S VTITLE= ""
  24295   "RTN","VPR ROS4",156, 0)
  24296    I VPRFILT '="" D
  24297   "RTN","VPR ROS4",157, 0)
  24298    . S VPRNA ME=VPRFILT
  24299   "RTN","VPR ROS4",158, 0)
  24300    . F  S VP RNAME=$O(^ VA(200,"B" ,VPRNAME))  Q:VPRNAME =""!(VPRNA ME'[VPRFIL T)  D
  24301   "RTN","VPR ROS4",159, 0)
  24302    . . S VPR I=0 F  S V PRI=$O(^VA (200,"B",V PRNAME,VPR I)) Q:VPRI '>0  D
  24303   "RTN","VPR ROS4",160, 0)
  24304    . . . S T ITLEP=$P(^ VA(200,VPR I,0),"^",9 ) I TITLEP ]"" S VTIT LE=$P($G(^ DIC(3.1,TI TLEP,0))," ^",1)
  24305   "RTN","VPR ROS4",161, 0)
  24306    . . . S S EX=$P(^VA( 200,VPRI,1 ),"^",2)
  24307   "RTN","VPR ROS4",162, 0)
  24308    . . . S V PRARRAY(VP RNAME)=VPR I
  24309   "RTN","VPR ROS4",163, 0)
  24310    . . . S V PRARRAY(VP RNAME,1)=" SEX"_"^"_S EX
  24311   "RTN","VPR ROS4",164, 0)
  24312    . . . S V PRARRAY(VP RNAME,2)=" TITLE"_"^" _VTITLE
  24313   "RTN","VPR ROS4",165, 0)
  24314    I VPRFILT ="" D
  24315   "RTN","VPR ROS4",166, 0)
  24316    . S VPRNA ME="" F  S  VPRNAME=$ O(^VA(200, "B",VPRNAM E)) Q:VPRN AME=""  D
  24317   "RTN","VPR ROS4",167, 0)
  24318    . . S VPR I=0 F  S V PRI=$O(^VA (200,"B",V PRNAME,VPR I)) Q:VPRI '>0  D
  24319   "RTN","VPR ROS4",168, 0)
  24320    . . . S T ITLEP=$P(^ VA(200,VPR I,0),"^",9 ) I TITLEP ]"" S VTIT LE=$P($G(^ DIC(3.1,TI TLEP,0))," ^",1)
  24321   "RTN","VPR ROS4",169, 0)
  24322    . . . S S EX=$P(^VA( 200,VPRI,1 ),"^",2)
  24323   "RTN","VPR ROS4",170, 0)
  24324    . . . S V PRARRAY(VP RNAME)=VPR I
  24325   "RTN","VPR ROS4",171, 0)
  24326    . . . S V PRARRAY(VP RNAME,1)=" SEX"_"^"_S EX
  24327   "RTN","VPR ROS4",172, 0)
  24328    . . . S V PRARRAY(VP RNAME,2)=" TITLE"_"^" _VTITLE
  24329   "RTN","VPR ROS4",173, 0)
  24330    Q
  24331   "RTN","VPR ROS4",174, 0)
  24332    ;
  24333   "RTN","VPR ROS4",175, 0)
  24334   PXRM ;Proc ess patien ts for sel ected pane l
  24335   "RTN","VPR ROS4",176, 0)
  24336    K VPRARRA Y S VPRARR AY=""
  24337   "RTN","VPR ROS4",177, 0)
  24338    S VPRNAME ="" F  S V PRNAME=$O( ^PXRM(810. 4,"B",VPRN AME)) Q:VP RNAME=""   S X=VPRNAM E X ^%ZOSF ("UPPERCAS E") S UPNA ME=Y X VPR ACT I  D
  24339   "RTN","VPR ROS4",178, 0)
  24340    . S VPRI= 0 F  S VPR I=$O(^PXRM (810.4,"B" ,VPRNAME,V PRI)) Q:VP RI'>0  I $ P($G(^PXRM (810.4,VPR I,0)),"^", 3)=3 D
  24341   "RTN","VPR ROS4",179, 0)
  24342    . . S VPR ARRAY(VPRN AME)=VPRI
  24343   "RTN","VPR ROS4",180, 0)
  24344    . . N LIS TP,LISTN,C LASS,CLASS NM
  24345   "RTN","VPR ROS4",181, 0)
  24346    . . S (LI STP,LISTN, CLASS,CLAS SNM)="" ;a dded 3/15/ 11 grr
  24347   "RTN","VPR ROS4",182, 0)
  24348    . . S LIS TP=$P(^PXR M(810.4,VP RI,0),"^", 7) I LISTP ]"" S LIST N=$P(^PXRM D(811.5,LI STP,0),"^" ,1)
  24349   "RTN","VPR ROS4",183, 0)
  24350    . . S CLA SS=$P(^PXR M(810.4,VP RI,100),"^ ",1),CLASS NM=$S(CLAS S="N":"Nat ional",CLA SS="V":"VI SN",CLASS= "L":"Local ",1:"NONE" )
  24351   "RTN","VPR ROS4",184, 0)
  24352    . . S VPR ARRAY(VPRN AME,1)="TE RM"_"^"_LI STN
  24353   "RTN","VPR ROS4",185, 0)
  24354    . . S VPR ARRAY(VPRN AME,2)="CL ASS"_"^"_C LASSNM
  24355   "RTN","VPR ROS4",186, 0)
  24356    Q
  24357   "RTN","VPR ROS4",187, 0)
  24358    ;
  24359   "RTN","VPR ROS4",188, 0)
  24360   SEND ;send  pending r osters.  C alled thro ugh RPC
  24361   "RTN","VPR ROS4",189, 0)
  24362    S VPRRCNT =0,VPRI=0
  24363   "RTN","VPR ROS4",190, 0)
  24364    S VPRVER= "<results  version='" _$P($T(VPR ROS4+1),"; ",3)_"'>"
  24365   "RTN","VPR ROS4",191, 0)
  24366    D ADD(VPR VER)
  24367   "RTN","VPR ROS4",192, 0)
  24368    S VPRTEXT ="<source  name='"_VP RSRC_"' >"  D ADD(VPR TEXT)
  24369   "RTN","VPR ROS4",193, 0)
  24370    D ADD("<e ntries>")
  24371   "RTN","VPR ROS4",194, 0)
  24372    K VPRII S  VPRII=""  F  S VPRII =$O(VPRARR AY(VPRII))  Q:VPRII=" "  D
  24373   "RTN","VPR ROS4",195, 0)
  24374    . S VPRDA TA=$$ESC^V PRD(VPRII)
  24375   "RTN","VPR ROS4",196, 0)
  24376    . S VPRTE XT="<entry  NAME='"_V PRDATA_"'  id='"_VPRA RRAY(VPRII )_"' />" D  ADD(VPRTE XT)
  24377   "RTN","VPR ROS4",197, 0)
  24378    . D ADD(" <identifie rs>")
  24379   "RTN","VPR ROS4",198, 0)
  24380    . N I S I =0 F  S I= $O(VPRARRA Y(VPRII,I) ) Q:I'>0   D
  24381   "RTN","VPR ROS4",199, 0)
  24382    . . S IDN AME=$P(VPR ARRAY(VPRI I,I),"^",1 ),IDVALUE= $P(VPRARRA Y(VPRII,I) ,"^",2),ID VALUE=$$ES C^VPRD(IDV ALUE)
  24383   "RTN","VPR ROS4",200, 0)
  24384    . . S VPR TEXT="<ide nt name='" _IDNAME_"'  value='"_ IDVALUE_"'  />" D ADD (VPRTEXT)
  24385   "RTN","VPR ROS4",201, 0)
  24386    . D ADD(" </identifi ers>")
  24387   "RTN","VPR ROS4",202, 0)
  24388    D ADD("</ entries>")
  24389   "RTN","VPR ROS4",203, 0)
  24390    D ADD("</ source>")
  24391   "RTN","VPR ROS4",204, 0)
  24392    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  24393   "RTN","VPR ROS4",205, 0)
  24394    Q
  24395   "RTN","VPR ROS4",206, 0)
  24396    ;
  24397   "RTN","VPR ROS4",207, 0)
  24398   ADD(X) ; - - Add a li ne @VPR@(n )=X
  24399   "RTN","VPR ROS4",208, 0)
  24400    I X'["<"  S X=$$ESC^ VPRD(X)
  24401   "RTN","VPR ROS4",209, 0)
  24402    S VPRI=$G (VPRI)+1
  24403   "RTN","VPR ROS4",210, 0)
  24404    S @VPR@(V PRI)=X
  24405   "RTN","VPR ROS4",211, 0)
  24406    Q
  24407   "RTN","VPR ROS4",212, 0)
  24408    ;
  24409   "RTN","VPR ROS4",213, 0)
  24410   SECCHK ; c heck for s ensitive r ecord
  24411   "RTN","VPR ROS4",214, 0)
  24412    N VPRY,I, X
  24413   "RTN","VPR ROS4",215, 0)
  24414    K WARN
  24415   "RTN","VPR ROS4",216, 0)
  24416    D PTSEC^D GSEC4(.VPR Y,DFN,1)   ;IA #3027
  24417   "RTN","VPR ROS4",217, 0)
  24418    S CHK("df n")=DFN
  24419   "RTN","VPR ROS4",218, 0)
  24420    S CHK("se nsitive")= (VPRY(1)>0 )
  24421   "RTN","VPR ROS4",219, 0)
  24422    S CHK("ma yAccess")= (VPRY(1)<3 )
  24423   "RTN","VPR ROS4",220, 0)
  24424    S CHK("lo gAccess")= (VPRY(1)>1 )
  24425   "RTN","VPR ROS4",221, 0)
  24426    M WARN=VP RY K WARN( 1)
  24427   "RTN","VPR ROS4",222, 0)
  24428    ;
  24429   "RTN","VPR ROS5")
  24430   0^16^B9679 013
  24431   "RTN","VPR ROS5",1,0)
  24432   VPRROS5 ;S LC/GRR --  Clinical R eminders L ist Proces sing
  24433   "RTN","VPR ROS5",2,0)
  24434    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  24435   "RTN","VPR ROS5",3,0)
  24436    ;
  24437   "RTN","VPR ROS5",4,0)
  24438    ; Externa l Referenc es           DBIA#
  24439   "RTN","VPR ROS5",5,0)
  24440    ; ------- ---------- --           -----
  24441   "RTN","VPR ROS5",6,0)
  24442    ;
  24443   "RTN","VPR ROS5",7,0)
  24444    ; ------- ----- Get  Panel(s) f rom VistA  ---------- --
  24445   "RTN","VPR ROS5",8,0)
  24446    ;
  24447   "RTN","VPR ROS5",9,0)
  24448   EN(VPR) ;  -- find Pa nels to up date
  24449   "RTN","VPR ROS5",10,0 )
  24450    K ^TMP($J ,"VPRPANEL ")
  24451   "RTN","VPR ROS5",11,0 )
  24452    N VPRPAN, VPRPAT,VPR I,MSG,PATC REAT,PLIST PUG,VPRC,V PRT
  24453   "RTN","VPR ROS5",12,0 )
  24454    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  24455   "RTN","VPR ROS5",13,0 )
  24456    S VPR=$NA (^TMP($J," VPR")),VPR C=0,VPRT=0
  24457   "RTN","VPR ROS5",14,0 )
  24458    F  S VPRC =$O(^VPRPA NEL(VPRC))  Q:VPRC'>0   D
  24459   "RTN","VPR ROS5",15,0 )
  24460    . S VPRT= VPRT+1
  24461   "RTN","VPR ROS5",16,0 )
  24462    . S VPRPA N(VPRC)=^V PRPANEL(VP RC,0) D
  24463   "RTN","VPR ROS5",17,0 )
  24464    . N LIEN, PLNAME S L IEN=$P(VPR PAN(VPRC), "^"),PLNAM E=$P(VPRPA N(VPRC),U, 3)
  24465   "RTN","VPR ROS5",18,0 )
  24466    . ;agp ne ed to dete rmine what  secure an d over sho uld be set  to
  24467   "RTN","VPR ROS5",19,0 )
  24468    . S SECUR E=0,OVER=1
  24469   "RTN","VPR ROS5",20,0 )
  24470    . D RUNLI ST(.VPRPAN ,LIEN,PLNA ME,SECURE, OVER)
  24471   "RTN","VPR ROS5",21,0 )
  24472   CREATE ; - - create p anel(s) in  XML
  24473   "RTN","VPR ROS5",22,0 )
  24474    N VPRVER  S VPRVER=" <results v ersion='"_ $P($T(VPRP ANEL+1),"; ",3)_"'>"
  24475   "RTN","VPR ROS5",23,0 )
  24476    N VPRTTXT  S VPRTTXT ="<panels  total='"_V PRT_"'>"
  24477   "RTN","VPR ROS5",24,0 )
  24478    D ADD(VPR VER),ADD(V PRTTXT)
  24479   "RTN","VPR ROS5",25,0 )
  24480    D PANEL
  24481   "RTN","VPR ROS5",26,0 )
  24482    S TEXT="< /results>"  D ADD(TEX T)
  24483   "RTN","VPR ROS5",27,0 )
  24484    Q
  24485   "RTN","VPR ROS5",28,0 )
  24486    ;
  24487   "RTN","VPR ROS5",29,0 )
  24488   PANEL ;--  create pan el XML
  24489   "RTN","VPR ROS5",30,0 )
  24490    S VPRC=0  F  S VPRC= $O(VPRPAN( VPRC)) Q:V PRC'>0  D
  24491   "RTN","VPR ROS5",31,0 )
  24492    .D ADD("< panel>")
  24493   "RTN","VPR ROS5",32,0 )
  24494    .N TEXT S  TEXT="<pa nel name=' "_$P(VPRPA N(VPRC),"^ ",2)_"' /> " D ADD(TE XT)
  24495   "RTN","VPR ROS5",33,0 )
  24496    .S TEXT=" <panelStri ng code='" _$P(VPRPAN (VPRC),"^" )_"' />" D  ADD(TEXT)
  24497   "RTN","VPR ROS5",34,0 )
  24498    .D PATS
  24499   "RTN","VPR ROS5",35,0 )
  24500    .S TEXT=" </panel>"  D ADD(TEXT )
  24501   "RTN","VPR ROS5",36,0 )
  24502    S TEXT="< /panels>"  D ADD(TEXT )
  24503   "RTN","VPR ROS5",37,0 )
  24504    Q
  24505   "RTN","VPR ROS5",38,0 )
  24506    ;
  24507   "RTN","VPR ROS5",39,0 )
  24508   CREATEPL(P LNAME,SECU RE,OVER) ;
  24509   "RTN","VPR ROS5",40,0 )
  24510    N FDA,IEN S,NAME,NUM ,RESULT,UN IQUE
  24511   "RTN","VPR ROS5",41,0 )
  24512    S (NUM,RE SULT,UNIQU E)=0
  24513   "RTN","VPR ROS5",42,0 )
  24514    ;if overw rite check  to see if  the list  exist
  24515   "RTN","VPR ROS5",43,0 )
  24516    I OVER=1  S RESULT=$ O(^PXRMXP( 810.5,"B", PLNAME,"") )
  24517   "RTN","VPR ROS5",44,0 )
  24518    I RESULT> 0 Q RESULT
  24519   "RTN","VPR ROS5",45,0 )
  24520    S NAME=PL NAME
  24521   "RTN","VPR ROS5",46,0 )
  24522    ;if not o verwrite f ind unique  name
  24523   "RTN","VPR ROS5",47,0 )
  24524    I OVER=0  D
  24525   "RTN","VPR ROS5",48,0 )
  24526    .I $D(^PX RMXP(810.5 ,"B",NAME) )=0 Q
  24527   "RTN","VPR ROS5",49,0 )
  24528    .F  Q:UNI QUE=1  D
  24529   "RTN","VPR ROS5",50,0 )
  24530    ..S NUM=N UM+1
  24531   "RTN","VPR ROS5",51,0 )
  24532    ..S NAME= PLNAME_" ( "_NUM_")"
  24533   "RTN","VPR ROS5",52,0 )
  24534    ..I $D(^P XRMXP(810. 5,"B",NAME ))=0 S UNI QUE=1
  24535   "RTN","VPR ROS5",53,0 )
  24536    ;create s tub in 810 .5
  24537   "RTN","VPR ROS5",54,0 )
  24538    S IENS="+ 1,"
  24539   "RTN","VPR ROS5",55,0 )
  24540    S FDA(810 .5,IENS,.0 1)=NAME
  24541   "RTN","VPR ROS5",56,0 )
  24542    S FDA(810 .5,IENS,10 0)="L"
  24543   "RTN","VPR ROS5",57,0 )
  24544    S FDA(810 .5,IENS,.0 7)=DUZ
  24545   "RTN","VPR ROS5",58,0 )
  24546    S FDA(810 .5,IENS,.0 8)=$S(SECU RE=0:"PUB" ,1:"PVT")
  24547   "RTN","VPR ROS5",59,0 )
  24548    D UPDATE^ DIE("","FD A","","MSG ")
  24549   "RTN","VPR ROS5",60,0 )
  24550    ;if error  display m essage and  quit
  24551   "RTN","VPR ROS5",61,0 )
  24552    I $D(MSG)  D AWRITE^ PXRMUTIL(" MSG") Q 0
  24553   "RTN","VPR ROS5",62,0 )
  24554    S RESULT= $O(^PXRMXP (810.5,"B" ,NAME,""))
  24555   "RTN","VPR ROS5",63,0 )
  24556    Q RESULT
  24557   "RTN","VPR ROS5",64,0 )
  24558    ;
  24559   "RTN","VPR ROS5",65,0 )
  24560   RUNLIST(VP RPAN,LIEN, PLNAME,SEC URE,OVER)  ;
  24561   "RTN","VPR ROS5",66,0 )
  24562    N PLIEN
  24563   "RTN","VPR ROS5",67,0 )
  24564    S PLIEN=$ $CREATEPL( PLNAME,SEC URE,OVER)
  24565   "RTN","VPR ROS5",68,0 )
  24566    S PATCREA T=$S(SECUR E=1:"Y",1: 0),PLISTPU G=1
  24567   "RTN","VPR ROS5",69,0 )
  24568    I PLIEN=0  Q
  24569   "RTN","VPR ROS5",70,0 )
  24570    D RUN^PXR MLCR(LIEN, PLIEN,"PXR MRULE",DT, DT,0,0)
  24571   "RTN","VPR ROS5",71,0 )
  24572    N VPRPAT  S VPRPAT=0
  24573   "RTN","VPR ROS5",72,0 )
  24574    F  S VPRP AT=$O(^PXR MXP(810.5, PLIEN,30,V PRPAT)) Q: VPRPAT'>0   S VPRPAN( VPRC,VPRPA T)=$P($G(^ PXRMXP(810 .5,PLIEN,3 0,VPRPAT,0 )),"^",1)
  24575   "RTN","VPR ROS5",73,0 )
  24576    Q
  24577   "RTN","VPR ROS5",74,0 )
  24578    ;
  24579   "RTN","VPR ROS5",75,0 )
  24580   PATS ; --  create pat ient XML
  24581   "RTN","VPR ROS5",76,0 )
  24582    S TEXT="< patients>"  D ADD(TEX T)
  24583   "RTN","VPR ROS5",77,0 )
  24584    S VPRPAT= 0 F  S VPR PAT=$O(VPR PAN(VPRC,V PRPAT)) D   Q:VPRPAT' >0
  24585   "RTN","VPR ROS5",78,0 )
  24586    .I VPRPAT '>0 S TEXT ="</patien ts>" D ADD (TEXT) Q
  24587   "RTN","VPR ROS5",79,0 )
  24588    .S TEXT=" <patient c ode='"_VPR PAN(VPRC,V PRPAT)_"'  />" D ADD( TEXT)
  24589   "RTN","VPR ROS5",80,0 )
  24590    ;
  24591   "RTN","VPR ROS5",81,0 )
  24592    ;
  24593   "RTN","VPR ROS5",82,0 )
  24594   ADD(X) ; - - Add a li ne @VPR@(n )=X
  24595   "RTN","VPR ROS5",83,0 )
  24596    S VPRI=$G (VPRI)+1
  24597   "RTN","VPR ROS5",84,0 )
  24598    S @VPR@(V PRI)=X
  24599   "RTN","VPR ROS5",85,0 )
  24600    Q
  24601   "RTN","VPR ROS5",86,0 )
  24602    ;
  24603   "RTN","VPR ROS5",87,0 )
  24604   NITELY ; - - Nightly  run to upd ate all Pa nels
  24605   "RTN","VPR ROS5",88,0 )
  24606    ;
  24607   "RTN","VPR ROS6")
  24608   0^61^B2649 2527
  24609   "RTN","VPR ROS6",1,0)
  24610   VPRROS6 ;S LC/GRR --  Generate R oster Pati ents
  24611   "RTN","VPR ROS6",2,0)
  24612    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  24613   "RTN","VPR ROS6",3,0)
  24614    ;; Compil e Roster
  24615   "RTN","VPR ROS6",4,0)
  24616   GET(VPRIEN ) ;
  24617   "RTN","VPR ROS6",5,0)
  24618    ;; Input  - VPRIEN i s internal  entry num ber of ros ter
  24619   "RTN","VPR ROS6",6,0)
  24620    ;;          VPROWNER  - If this  parameter  exists, o nly roster s for this  owner wil l be compi led and pa ssed
  24621   "RTN","VPR ROS6",7,0)
  24622    ;; Output  - AFTER a rray conta ins curren t patients
  24623   "RTN","VPR ROS6",8,0)
  24624    ;
  24625   "RTN","VPR ROS6",9,0)
  24626    K VPRLIST ,VPRLIST2
  24627   "RTN","VPR ROS6",10,0 )
  24628    N VPRI,VP RFILT,VPRT YPE,VPERR, VPRRNAME,V PRNY,VPROP ,VPRTAG,VP RLAB,VPRNL IST,BEG,DO B,END,GEND ER,ICN,NAM E,VPRACT,V PRC
  24629   "RTN","VPR ROS6",11,0 )
  24630    N VPRCIEN ,VPRDNAME, VPRDOB,VPR III,VPRINM ,VPRLIEN,V PRNAME,VPR OIEN,VPRON AME,VPROWN ID,VPROWNN M,VPRPAT,V PRPIEN,VPR NME,VPRCNT
  24631   "RTN","VPR ROS6",12,0 )
  24632    N VPRSRCD N,VPRCID,V PRTEXT,VPR TIEN,VPRTL ST,VPRVER, VPRWIEN,VP RWNAME,VPR PNME,VPRRC NT,VPRSRCI D,X,Y,SSN, VPRZ,VPRIZ ,VPRX
  24633   "RTN","VPR ROS6",13,0 )
  24634    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  24635   "RTN","VPR ROS6",14,0 )
  24636    S VPRIZ=0
  24637   "RTN","VPR ROS6",15,0 )
  24638    I $G(VPRI EN)="" S V PRIEN=0
  24639   "RTN","VPR ROS6",16,0 )
  24640    S (VPRLIS T,VPRFILT, VPRTYPE,VP ROP,VPRLIS T2,VPERR)= ""
  24641   "RTN","VPR ROS6",17,0 )
  24642    I +$G(VPR IEN)'>0 S  VPERR="0^I nvalid Ros ter IEN" Q
  24643   "RTN","VPR ROS6",18,0 )
  24644    S VPRRNAM E=$P($G(^V PROSTER(VP RIEN,0))," ^",1) I VP RRNAME=""  S VPERR="0 ^Deleted R oster IEN"  Q
  24645   "RTN","VPR ROS6",19,0 )
  24646    F  S VPRI Z=$O(^VPRO STER(VPRIE N,1,VPRIZ) ) Q:VPRIZ' >0  D
  24647   "RTN","VPR ROS6",20,0 )
  24648    . S VPRX= $G(^VPROST ER(VPRIEN, 1,VPRIZ,0) )
  24649   "RTN","VPR ROS6",21,0 )
  24650    . S VPROP =$P(VPRX," ^",3)
  24651   "RTN","VPR ROS6",22,0 )
  24652    . S VPRFI LT=$P(VPRX ,"^",4)
  24653   "RTN","VPR ROS6",23,0 )
  24654    . S VPRTA G=$P($P(VP RX,"^",2), ";",2)
  24655   "RTN","VPR ROS6",24,0 )
  24656    . S VPRLA B=""
  24657   "RTN","VPR ROS6",25,0 )
  24658    . I VPRTA G["SC(" S  VPRLAB="CL IN"
  24659   "RTN","VPR ROS6",26,0 )
  24660    . I VPRTA G["DIC(42"  S VPRLAB= "WARD"
  24661   "RTN","VPR ROS6",27,0 )
  24662    . I VPRTA G["DPT" S  VPRLAB="PA T"
  24663   "RTN","VPR ROS6",28,0 )
  24664    . I VPRTA G["SCTM" S  VPRLAB="P CMM"
  24665   "RTN","VPR ROS6",29,0 )
  24666    . I VPRTA G["OR(100. 21" S VPRL AB="CPRS"
  24667   "RTN","VPR ROS6",30,0 )
  24668    . I VPRTA G["VPROSTE R" S VPRLA B="ROST"
  24669   "RTN","VPR ROS6",31,0 )
  24670    . I VPRTA G["DIC(45. 7" S VPRLA B="SPEC"
  24671   "RTN","VPR ROS6",32,0 )
  24672    . I VPRTA G["VA(200"  S VPRLAB= "PROV"
  24673   "RTN","VPR ROS6",33,0 )
  24674    . I VPRTA G["PXRM(81 0.4" S VPR LAB="PXRM"
  24675   "RTN","VPR ROS6",34,0 )
  24676    . I VPRLA B="" S VPE RR="1^INVA LID FILE T YPE" Q
  24677   "RTN","VPR ROS6",35,0 )
  24678    . D @VPRL AB
  24679   "RTN","VPR ROS6",36,0 )
  24680    . S VPRLA B=$S(VPROP =0:"UNION" ,VPROP=1:" INTER",1:" DIFF")
  24681   "RTN","VPR ROS6",37,0 )
  24682    . S VPRNL IST=""
  24683   "RTN","VPR ROS6",38,0 )
  24684    . D @VPRL AB
  24685   "RTN","VPR ROS6",39,0 )
  24686    M VPRLIST 2=VPRLIST
  24687   "RTN","VPR ROS6",40,0 )
  24688    D GENPAT( VPRIEN)
  24689   "RTN","VPR ROS6",41,0 )
  24690    Q
  24691   "RTN","VPR ROS6",42,0 )
  24692    ;
  24693   "RTN","VPR ROS6",43,0 )
  24694   CLIN ;Proc ess patien ts for thi s clinic.   Select al l if filte r is null
  24695   "RTN","VPR ROS6",44,0 )
  24696    K VPRLIST 2 S VPRLIS T2=""
  24697   "RTN","VPR ROS6",45,0 )
  24698    I '$D(DT)  S DT=$$DT ^XLFDT()
  24699   "RTN","VPR ROS6",46,0 )
  24700    S BEG=DT, END=$S(VPR FILT="T":D T+.24,1:99 99999+.24) ,VPRIII=BE G
  24701   "RTN","VPR ROS6",47,0 )
  24702    S VPRCIEN =+$P(VPRX, "^",2) F   S VPRIII=$ O(^SC(VPRC IEN,"S",VP RIII)) Q:V PRIII'>0!( VPRIII>END )  D
  24703   "RTN","VPR ROS6",48,0 )
  24704    . S VPRII =0 F  S VP RII=$O(^SC (VPRCIEN," S",VPRIII, 1,VPRII))  Q:VPRII'>0   S DFN=$P ($G(^SC(VP RCIEN,"S", VPRIII,1,V PRII,0))," ^",1) I DF N>0 D
  24705   "RTN","VPR ROS6",49,0 )
  24706    . .S VPRL IST2(DFN)= VPRIZ
  24707   "RTN","VPR ROS6",50,0 )
  24708    Q
  24709   "RTN","VPR ROS6",51,0 )
  24710    ;
  24711   "RTN","VPR ROS6",52,0 )
  24712   WARD ;Proc ess patien ts for thi s ward
  24713   "RTN","VPR ROS6",53,0 )
  24714    K VPRLIST 2 S VPRLIS T2=""
  24715   "RTN","VPR ROS6",54,0 )
  24716    S VPRWIEN =+$P(VPRX, "^",2),VPR WNAME=$P($ G(^DIC(42, VPRWIEN,0) ),"^",1)
  24717   "RTN","VPR ROS6",55,0 )
  24718    S VPRIII= 0 F  S VPR III=$O(^DG PM("CN",VP RWNAME,VPR III)) Q:VP RIII'>0  D
  24719   "RTN","VPR ROS6",56,0 )
  24720    . S DFN=$ P($G(^DGPM (VPRIII,0) ),"^",3),V PRLIST2(DF N)=VPRIZ
  24721   "RTN","VPR ROS6",57,0 )
  24722    Q
  24723   "RTN","VPR ROS6",58,0 )
  24724    ;
  24725   "RTN","VPR ROS6",59,0 )
  24726   PAT ;Proce ss patient  from Pati ent file S ource
  24727   "RTN","VPR ROS6",60,0 )
  24728    K VPRLIST 2 S VPRLIS T2=""
  24729   "RTN","VPR ROS6",61,0 )
  24730    S DFN=+$P (VPRX,"^", 2),VPRLIST 2(DFN)=VPR IZ
  24731   "RTN","VPR ROS6",62,0 )
  24732    Q
  24733   "RTN","VPR ROS6",63,0 )
  24734    ;
  24735   "RTN","VPR ROS6",64,0 )
  24736   PCMM ;Proc ess patien ts from a  PCMM team
  24737   "RTN","VPR ROS6",65,0 )
  24738    K VPRLIST 2 S VPRLIS T2=""
  24739   "RTN","VPR ROS6",66,0 )
  24740    S VPRTIEN =+$P(VPRX, "^",2),VPE RR="",VPRT LST=""
  24741   "RTN","VPR ROS6",67,0 )
  24742    D PTTM^SC APMC(VPRTI EN,,"VPRTL ST",VPERR)
  24743   "RTN","VPR ROS6",68,0 )
  24744    S VPRIII= "" F  S VP RIII=$O(VP RTLST(VPRI II)) Q:VPR III'>0  S  DFN=$P(VPR TLST(VPRII I),"^",1)  S VPRTST2( DFN)=VPRIZ
  24745   "RTN","VPR ROS6",69,0 )
  24746    Q
  24747   "RTN","VPR ROS6",70,0 )
  24748    ;
  24749   "RTN","VPR ROS6",71,0 )
  24750   CPRS ;Proc ess patien ts from CP RS Lists
  24751   "RTN","VPR ROS6",72,0 )
  24752    K VPRLIST 2 S VPRLIS T2=""
  24753   "RTN","VPR ROS6",73,0 )
  24754    S VPROIEN =+$P(VPRX, "^",2),VPE RR=""
  24755   "RTN","VPR ROS6",74,0 )
  24756    S VPRIII= 0 F  S VPR III=$O(^OR (100.21,VP ROIEN,10,V PRIII)) Q: VPRIII'>0   S DFN=$P( ^OR(100.21 ,VPROIEN,1 0,VPRIII,0 ),";",1) S  VPRLIST2( DFN)=VPRIZ
  24757   "RTN","VPR ROS6",75,0 )
  24758    Q
  24759   "RTN","VPR ROS6",76,0 )
  24760    ;
  24761   "RTN","VPR ROS6",77,0 )
  24762   ROST ;Proc ess patien ts from se lected ros ter
  24763   "RTN","VPR ROS6",78,0 )
  24764    K VPRLIST 2,VPRBLIST  S (VPRLIS T2,VPRBLIS T)="" ; --  kcm added  comma
  24765   "RTN","VPR ROS6",79,0 )
  24766    N VPR,VPR IEN,VPERR
  24767   "RTN","VPR ROS6",80,0 )
  24768    S VPRIEN= +$P(VPRX," ^",2),VPER R="",VPROU T=1,VPR="V PRBLIST"
  24769   "RTN","VPR ROS6",81,0 )
  24770    D COMPILE ^VPRROS2(. VPRZ,VPRIE N,"")
  24771   "RTN","VPR ROS6",82,0 )
  24772    M VPRBLIS T=VPRLIST2
  24773   "RTN","VPR ROS6",83,0 )
  24774    K VPROUT
  24775   "RTN","VPR ROS6",84,0 )
  24776    Q
  24777   "RTN","VPR ROS6",85,0 )
  24778    ;
  24779   "RTN","VPR ROS6",86,0 )
  24780   SPEC ;Proc ess patien ts with se lected Tre ating Spec ialty
  24781   "RTN","VPR ROS6",87,0 )
  24782    K VPRLIST 2 S VPRLIS T2=""
  24783   "RTN","VPR ROS6",88,0 )
  24784    S VPROIEN =+$P(VPRX, "^",2),VPE RR=""
  24785   "RTN","VPR ROS6",89,0 )
  24786    N DFN S D FN=0 F  S  DFN=$O(^DP T("ATR",VP ROIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=VP RIZ
  24787   "RTN","VPR ROS6",90,0 )
  24788    Q
  24789   "RTN","VPR ROS6",91,0 )
  24790    ;
  24791   "RTN","VPR ROS6",92,0 )
  24792   PROV ;Proc ess patien ts for sel ected prov ider
  24793   "RTN","VPR ROS6",93,0 )
  24794    K VPRLIST 2 S VPRLIS T2=""
  24795   "RTN","VPR ROS6",94,0 )
  24796    S VPRPIEN =+$P(VPRX, "^",2),VPE RR=""
  24797   "RTN","VPR ROS6",95,0 )
  24798    N DFN S D FN=0 F  S  DFN=$O(^DP T("APR",VP RPIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  24799   "RTN","VPR ROS6",96,0 )
  24800    Q
  24801   "RTN","VPR ROS6",97,0 )
  24802    ;
  24803   "RTN","VPR ROS6",98,0 )
  24804   PXRM ;Proc ess patien ts for sel ected pane l
  24805   "RTN","VPR ROS6",99,0 )
  24806    K VPRLIST 2 S VPRLIS T2=""
  24807   "RTN","VPR ROS6",100, 0)
  24808    S VPRPIEN =+$P(VPRX, "^",2),VPE RR=""
  24809   "RTN","VPR ROS6",101, 0)
  24810    S VPRC=VP RPIEN,VPRL IEN=$P(^VP ROSTER(VPR IEN,0),"^" ,1),VPRPNM E=$P(^VPRO STER(VPRIE N,0),"^",6 ) I VPRPNM E="" S VPR PNME=VPRRN AME,$P(^VP ROSTER(VPR IEN,0),U,6 )=VPRRNAME
  24811   "RTN","VPR ROS6",102, 0)
  24812    S VPRPAT= "" D RUNLI ST^VPRROS5 (.VPRPAT,V PRLIEN,VPR PNME,0,1)
  24813   "RTN","VPR ROS6",103, 0)
  24814    S VPRII=0  F  S VPRI I=$O(VPRPA T(VPRC,VPR II)) Q:VPR II'>0  S D FN=VPRPAT( VPRC,VPRII ),VPRLIST2 (DFN)=VPRI Z
  24815   "RTN","VPR ROS6",104, 0)
  24816    Q
  24817   "RTN","VPR ROS6",105, 0)
  24818    ;
  24819   "RTN","VPR ROS6",106, 0)
  24820   UNION ;Add  to existi ng list
  24821   "RTN","VPR ROS6",107, 0)
  24822    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  S VPRL IST(VPRII) =VPRLIST2( VPRII)
  24823   "RTN","VPR ROS6",108, 0)
  24824    Q
  24825   "RTN","VPR ROS6",109, 0)
  24826    ;
  24827   "RTN","VPR ROS6",110, 0)
  24828   INTER ;Int ersect wit h existing  list
  24829   "RTN","VPR ROS6",111, 0)
  24830    S VPRII=0  F  S VPRI I=$O(VPRLI ST(VPRII))  Q:VPRII'> 0  D
  24831   "RTN","VPR ROS6",112, 0)
  24832    . I '$D(V PRLIST2(VP RII)) K VP RLIST(VPRI I)
  24833   "RTN","VPR ROS6",113, 0)
  24834    Q
  24835   "RTN","VPR ROS6",114, 0)
  24836    ;
  24837   "RTN","VPR ROS6",115, 0)
  24838   DIFF ;Remo ve patient s from thi s source t hat we hav e so far
  24839   "RTN","VPR ROS6",116, 0)
  24840    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  D
  24841   "RTN","VPR ROS6",117, 0)
  24842    . K VPRLI ST(VPRII)
  24843   "RTN","VPR ROS6",118, 0)
  24844    Q
  24845   "RTN","VPR ROS6",119, 0)
  24846    ;
  24847   "RTN","VPR ROS6",120, 0)
  24848   GENPAT(VPR ID) ;
  24849   "RTN","VPR ROS6",121, 0)
  24850    N DFN,DIC ,DR,DIE,DA ,NODE,VPRN UM
  24851   "RTN","VPR ROS6",122, 0)
  24852    S DFN=0
  24853   "RTN","VPR ROS6",123, 0)
  24854    S VPRNUM= 0
  24855   "RTN","VPR ROS6",124, 0)
  24856    K ^VPROST ER(VPRID,4 ) S ^VPROS TER(VPRID, 4,0)="^561 .23P^^"
  24857   "RTN","VPR ROS6",125, 0)
  24858    F  S DFN= $O(VPRLIST (DFN)) Q:D FN'>0  D
  24859   "RTN","VPR ROS6",126, 0)
  24860    . S VPRNU M=VPRNUM+1  S ^VPROST ER(VPRID,4 ,VPRNUM,0) =DFN_"^"_V PRLIST(DFN ),^VPROSTE R(VPRID,4, "B",DFN,VP RNUM)="",^ VPROSTER(" AB",DFN,VP RID,VPRNUM )=""
  24861   "RTN","VPR ROS6",127, 0)
  24862    Q
  24863   "RTN","VPR ROS7")
  24864   0^62^B2383 8606
  24865   "RTN","VPR ROS7",1,0)
  24866   VPRROS7 ;S LC/GRR --  Get Roster  identific ation for  patient(s)  ;4/24/201 2
  24867   "RTN","VPR ROS7",2,0)
  24868    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;AUG  17, 2011;B uild 205
  24869   "RTN","VPR ROS7",3,0)
  24870   GET(VPR,VP RARRAY) ;;  Previews  what a ros ter would  look like  as defined
  24871   "RTN","VPR ROS7",4,0)
  24872    ;;  Calle d by the G UI Roster  Builder
  24873   "RTN","VPR ROS7",5,0)
  24874    ;; Input  - VPRARRAY  - contain s roster d ata entere d thru GUI
  24875   "RTN","VPR ROS7",6,0)
  24876    K VPRLIST ,VPRLIST2
  24877   "RTN","VPR ROS7",7,0)
  24878    N %,BEG,D A,DIDEL,DI E,DOB,SSN, DR,END,GEN DER,ICN,NA ME,VPRC,VP RCIEN,VPRD IS,VPRDNAM E,VPRDOB,V PRDT,VPRII I,VPRLIEN, VPROIEN,VP ROWNID
  24879   "RTN","VPR ROS7",8,0)
  24880    N VPROWNN M,VPRPAT,V PRPIEN,VPR PNME,VPRRC NT,VPRRID, VPRTEXT,VP RTIEN,VPRL ST,VPRVAR, VPRVER,VPR WIEN,VPRWN AME,VPRZ,X ,Y
  24881   "RTN","VPR ROS7",9,0)
  24882    N VPRFILT ,VPRI,VPRN LIST,VPRSR CID,VPRTAG ,VPRTLST,V PRY,VPRTYP E,ZZ,DFN,I EN,VPERR,V PRICN,VPRO P,VPRPNAME ,VPRRNAME
  24883   "RTN","VPR ROS7",10,0 )
  24884    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  24885   "RTN","VPR ROS7",11,0 )
  24886    S (VPRLIS T,VPRFILT, VPRTYPE,VP ROP,VPRLIS T2,VPERR)= "",VPRI=0
  24887   "RTN","VPR ROS7",12,0 )
  24888    S VPR=$NA (^TMP($J," VPROSTER") ) ; kcm --  moved thi s here so  VPR gets d efined
  24889   "RTN","VPR ROS7",13,0 )
  24890    K ^TMP($J ,"VPROSTER ")
  24891   "RTN","VPR ROS7",14,0 )
  24892    I $O(VPRA RRAY(""))= "" S @VPR@ (1)="0^No  patient da ta passed"  Q
  24893   "RTN","VPR ROS7",15,0 )
  24894    D NOW^%DT C S VPRDT= %
  24895   "RTN","VPR ROS7",16,0 )
  24896    S VPRVER= "<results  version='" _$P($T(VPR ROS7+1),"; ",3)_"'>"
  24897   "RTN","VPR ROS7",17,0 )
  24898    D ADD(VPR VER)
  24899   "RTN","VPR ROS7",18,0 )
  24900    S VPRZ=""  F  S VPRZ =$O(VPRARR AY(VPRZ))  Q:VPRZ=""   D
  24901   "RTN","VPR ROS7",19,0 )
  24902    . S DFN=$ P(VPRARRAY (VPRZ),"^" ,1),VPRPNA ME=$P(VPRA RRAY(VPRZ) ,"^",2),VP RPNAME=$$E SC^VPRD(VP RPNAME),VP RICN=$P(VP RARRAY(VPR Z),"^",3)
  24903   "RTN","VPR ROS7",20,0 )
  24904    . S ICN=$ $GETICN^MP IF001(DFN)
  24905   "RTN","VPR ROS7",21,0 )
  24906    . S NAME= $P(^DPT(DF N,0),"^",1 ),GENDER=$ P(^DPT(DFN ,0),"^",2) ,SSN=$P(^D PT(DFN,0), "^",9),DOB =$P(^DPT(D FN,0),"^", 3),VPRDOB= $$FMTHL7^X LFDT(DOB)
  24907   "RTN","VPR ROS7",22,0 )
  24908    . S Y="<p atient nam e='"_NAME_ "' gender= '"_GENDER_ "' dob='"_ VPRDOB_"'  ssn='"_SSN _"' id='"_ DFN_$S(ICN :"' icn='" _ICN,1:"") _"' />" D  ADD(Y)
  24909   "RTN","VPR ROS7",23,0 )
  24910    . S IEN=" " F  S IEN =$O(^VPROS TER("AB",D FN,IEN)) Q :IEN=""  D
  24911   "RTN","VPR ROS7",24,0 )
  24912    . . S VPR RID=IEN,VP RRNAME=$P( $G(^VPROST ER(VPRRID, 0)),"^",1) ,VPRRNAME= $$ESC^VPRD (VPRRNAME)
  24913   "RTN","VPR ROS7",25,0 )
  24914    . . S VPR TEXT="<ros ter ien='" _VPRRID_"'  rosterNam e='"_VPRRN AME_"'/>"  D ADD(VPRT EXT)
  24915   "RTN","VPR ROS7",26,0 )
  24916    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  24917   "RTN","VPR ROS7",27,0 )
  24918    Q
  24919   "RTN","VPR ROS7",28,0 )
  24920    ;
  24921   "RTN","VPR ROS7",29,0 )
  24922   ADD(X) ; - - Add a li ne @VPR@(n )=X
  24923   "RTN","VPR ROS7",30,0 )
  24924    S VPRI=$G (VPRI)+1
  24925   "RTN","VPR ROS7",31,0 )
  24926    S @VPR@(V PRI)=X
  24927   "RTN","VPR ROS7",32,0 )
  24928    Q
  24929   "RTN","VPR ROS7",33,0 )
  24930    ;
  24931   "RTN","VPR ROS7",34,0 )
  24932   TEST ;TEMP ORARY
  24933   "RTN","VPR ROS7",35,0 )
  24934    S VPRARRA Y(0)="1008 45^AVIVAPA TIENT,FOUR ^"
  24935   "RTN","VPR ROS7",36,0 )
  24936    S VPRARRA Y(1)="1008 50^AVIVAPA TIENT,TEN^ "
  24937   "RTN","VPR ROS7",37,0 )
  24938    D GET(.VP R,.VPRARRA Y)
  24939   "RTN","VPR ROS7",38,0 )
  24940    Q
  24941   "RTN","VPR ROS7",39,0 )
  24942    ;
  24943   "RTN","VPR ROS7",40,0 )
  24944   TESTJ ;TEM PORARY
  24945   "RTN","VPR ROS7",41,0 )
  24946    S VPRARRA Y(0)="1008 45^AVIVAPA TIENT,FOUR ^"
  24947   "RTN","VPR ROS7",42,0 )
  24948    S VPRARRA Y(1)="1008 50^AVIVAPA TIENT,TEN^ "
  24949   "RTN","VPR ROS7",43,0 )
  24950    D GETJ(.V PR,.VPRARR AY)
  24951   "RTN","VPR ROS7",44,0 )
  24952    Q
  24953   "RTN","VPR ROS7",45,0 )
  24954    ;
  24955   "RTN","VPR ROS7",46,0 )
  24956   GETJ(VPR,V PRARRAY) ; Get Roster s which ar e in selec ted patien t(s)
  24957   "RTN","VPR ROS7",47,0 )
  24958    ;output i n JSON obj ect contai ns patient  informati on and all  rosters p atient is  currently  in
  24959   "RTN","VPR ROS7",48,0 )
  24960    S VPR=$NA (^TMP($J," VPROSTER") ) ; kcm --  moved thi s here so  VPR gets d efined
  24961   "RTN","VPR ROS7",49,0 )
  24962    N VPRI,VP RDT,VPRZ,D FN,VPRRNAM E,VPRICN,N AME,SSN,DO B,VPRDOB,P AT,VPRRID, X,Y
  24963   "RTN","VPR ROS7",50,0 )
  24964    K ^TMP($J ,"VPROSTER ")
  24965   "RTN","VPR ROS7",51,0 )
  24966    I $O(VPRA RRAY(""))= "" S @VPR@ (1)="0^No  patient da ta passed"  Q
  24967   "RTN","VPR ROS7",52,0 )
  24968    D NOW^%DT C S VPRDT= %
  24969   "RTN","VPR ROS7",53,0 )
  24970    S VPRI=0
  24971   "RTN","VPR ROS7",54,0 )
  24972    S VPRZ=""  F  S VPRZ =$O(VPRARR AY(VPRZ))  Q:VPRZ=""   D
  24973   "RTN","VPR ROS7",55,0 )
  24974    . S DFN=$ P(VPRARRAY (VPRZ),"^" ,1),VPRPNA ME=$P(VPRA RRAY(VPRZ) ,"^",2),VP RPNAME=$$E SC^VPRD(VP RPNAME),VP RICN=$P(VP RARRAY(VPR Z),"^",3)
  24975   "RTN","VPR ROS7",56,0 )
  24976    . S ICN=$ $GETICN^MP IF001(DFN)
  24977   "RTN","VPR ROS7",57,0 )
  24978    . S NAME= $P(^DPT(DF N,0),"^",1 ),GENDER=$ P(^DPT(DFN ,0),"^",2) ,SSN=$P(^D PT(DFN,0), "^",9),DOB =$P(^DPT(D FN,0),"^", 3),VPRDOB= $$JSONDT^V PRUTILS(DO B)
  24979   "RTN","VPR ROS7",58,0 )
  24980    . S PAT(" familyName ")=$P(NAME ,",",1),PA T("givenNa mes")=$P(N AME,",",2, 99),PAT("s sn")=SSN,P AT("localI d")=DFN
  24981   "RTN","VPR ROS7",59,0 )
  24982    . S X=GEN DER S PAT( "genderCod e")="urn:v a:pat-gend er:"_X,PAT ("genderNa me")=$$NAM E^VPRDJ00( X,"gender" )
  24983   "RTN","VPR ROS7",60,0 )
  24984    . S PAT(" dateOfBirt h")=VPRDOB ,PAT("uid" )=$$SETUID ^VPRUTILS( "pat",DFN, DFN,"")
  24985   "RTN","VPR ROS7",61,0 )
  24986    . S IEN=" " F  S IEN =$O(^VPROS TER("AB",D FN,IEN)) Q :IEN=""  D
  24987   "RTN","VPR ROS7",62,0 )
  24988    . . S VPR RID=IEN,VP RRNAME=$P( $G(^VPROST ER(VPRRID, 0)),"^",1) ,VPRRNAME= $$ESC^VPRD (VPRRNAME)
  24989   "RTN","VPR ROS7",63,0 )
  24990    . . S PAT ("roster", IEN,"local Id")=IEN,P AT("roster ",IEN,"uid ")=$$SETUI D^VPRUTILS ("roster", "",IEN,"")
  24991   "RTN","VPR ROS7",64,0 )
  24992    . . S PAT ("roster", IEN,"roste rName")=VP RRNAME
  24993   "RTN","VPR ROS7",65,0 )
  24994    I $D(PAT) >9 D ADDJ
  24995   "RTN","VPR ROS7",66,0 )
  24996    Q
  24997   "RTN","VPR ROS7",67,0 )
  24998    ;
  24999   "RTN","VPR ROS7",68,0 )
  25000   ADDJ ;
  25001   "RTN","VPR ROS7",69,0 )
  25002    N VPRY,ER R
  25003   "RTN","VPR ROS7",70,0 )
  25004    D ENCODE^ VPRJSON("P AT","VPRY" ,"ERR")
  25005   "RTN","VPR ROS7",71,0 )
  25006    I $D(VPRY ) D
  25007   "RTN","VPR ROS7",72,0 )
  25008    . D:VPRI  COMMA(VPRI )
  25009   "RTN","VPR ROS7",73,0 )
  25010    . S VPRI= VPRI+1 M @ VPR@(VPRI) =VPRY
  25011   "RTN","VPR ROS7",74,0 )
  25012    Q
  25013   "RTN","VPR ROS7",75,0 )
  25014    ;
  25015   "RTN","VPR ROS7",76,0 )
  25016   COMMA(I) ; ; -- add c omma betwe en items
  25017   "RTN","VPR ROS7",77,0 )
  25018    N J S J=+ $O(@VPR@(I ,"A"),-1)  ;last sub- node for i tem I
  25019   "RTN","VPR ROS7",78,0 )
  25020    S J=J+1,@ VPR@(I,J)= ","
  25021   "RTN","VPR ROS7",79,0 )
  25022    Q
  25023   "RTN","VPR ROS7",80,0 )
  25024    ;
  25025   "RTN","VPR ROS7",81,0 )
  25026   SUBS(VPR,S YS,ON,LIST ) ; -- Un/ Subscribe  to Patient  Data Moni tor
  25027   "RTN","VPR ROS7",82,0 )
  25028    ; RPC = V PR SUBSCRI BE ROSTERS
  25029   "RTN","VPR ROS7",83,0 )
  25030    N DA,I,ID ,HDR,VPRI
  25031   "RTN","VPR ROS7",84,0 )
  25032    S SYS=$G( SYS),ON=+$ G(ON) Q:'$ L(SYS)
  25033   "RTN","VPR ROS7",85,0 )
  25034    S DA=$$FI ND^VPRPATS (SYS) Q:DA <1
  25035   "RTN","VPR ROS7",86,0 )
  25036    S VPR=$NA (^TMP("VPR ",$J)) K @ VPR
  25037   "RTN","VPR ROS7",87,0 )
  25038    ;S:'$D(^X TMP("VPROS ")) ^XTMP( "VPROS",0) ="3991231^ "_DT_"^VPR  Patient D ata Monito r"
  25039   "RTN","VPR ROS7",88,0 )
  25040    ;
  25041   "RTN","VPR ROS7",89,0 )
  25042    ; loop th rough LIST (n) = 'id'
  25043   "RTN","VPR ROS7",90,0 )
  25044    D ADD("<r osters>")
  25045   "RTN","VPR ROS7",91,0 )
  25046    S I="" F   S I=$O(LI ST(I)) Q:I =""  S ID= LIST(I) D
  25047   "RTN","VPR ROS7",92,0 )
  25048    . I ID<1! '$D(^VPROS TER(ID)) D  RET(ID,"e rror") Q
  25049   "RTN","VPR ROS7",93,0 )
  25050    . I ON D   Q
  25051   "RTN","VPR ROS7",94,0 )
  25052    .. S:'$D( ^VPR(560,D A,2,ID,0))  HDR=$G(^V PR(560,DA, 2,0)),^(0) ="^560.02P ^"_ID_U_($ P(HDR,U,4) +1)
  25053   "RTN","VPR ROS7",95,0 )
  25054    .. S ^VPR (560,DA,2, ID,0)=ID_U _ON,^VPR(5 60,"AROS", ID,DA)=""
  25055   "RTN","VPR ROS7",96,0 )
  25056    .. D RET( ID,"on") ; S ^XTMP("V PROS",ID)= ON
  25057   "RTN","VPR ROS7",97,0 )
  25058    . ; else,  remove pa tient trac king info  from ^XTMP
  25059   "RTN","VPR ROS7",98,0 )
  25060    . S:$D(^V PR(560,DA, 2,ID,0)) $ P(^(0),U,2 )=0
  25061   "RTN","VPR ROS7",99,0 )
  25062    . K ^VPR( 560,"AROS" ,ID,DA) ;I  '$D(^VPR( 560,"AROS" ,ID)) K ^X TMP("VPROS ",ID)
  25063   "RTN","VPR ROS7",100, 0)
  25064    . D RET(I D,"off")
  25065   "RTN","VPR ROS7",101, 0)
  25066    D ADD("</ rosters>")
  25067   "RTN","VPR ROS7",102, 0)
  25068    Q
  25069   "RTN","VPR ROS7",103, 0)
  25070    ;
  25071   "RTN","VPR ROS7",104, 0)
  25072   RET(ID,STS ) ; -- add  XML node  for roster  ID update  subscript ion
  25073   "RTN","VPR ROS7",105, 0)
  25074    N Y S Y=" <roster id ='"_$G(ID)
  25075   "RTN","VPR ROS7",106, 0)
  25076    S Y=Y_"'  subscribe= '"_$G(STS) _"' />"
  25077   "RTN","VPR ROS7",107, 0)
  25078    D ADD(Y)
  25079   "RTN","VPR ROS7",108, 0)
  25080    Q
  25081   "RTN","VPR SR")
  25082   0^4^B40628 8
  25083   "RTN","VPR SR",1,0)
  25084   VPRSR ;SLC /MKB -- Su rgery inte rface
  25085   "RTN","VPR SR",2,0)
  25086    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  25087   "RTN","VPR SR",3,0)
  25088    ;
  25089   "RTN","VPR SR",4,0)
  25090    ; Support ed by DBIA  #4750
  25091   "RTN","VPR SR",5,0)
  25092    ;
  25093   "RTN","VPR SR",6,0)
  25094    ; ------- ---------  Update Tri ggers ---- ---------- --
  25095   "RTN","VPR SR",7,0)
  25096    ;
  25097   "RTN","VPR SR",8,0)
  25098   NEW(IEN,DF N,STS) ; - - new surg ery reques t [from SR OERR]
  25099   "RTN","VPR SR",9,0)
  25100    S IEN=+$G (IEN),DFN= +$G(DFN) Q :DFN<1
  25101   "RTN","VPR SR",10,0)
  25102    D SR^VPRE VNT(DFN,IE N)
  25103   "RTN","VPR SR",11,0)
  25104    Q
  25105   "RTN","VPR SR",12,0)
  25106    ;
  25107   "RTN","VPR SR",13,0)
  25108   UPD(IEN,DF N,STS) ; - - updated  surgery re quest [fro m SROERR0]
  25109   "RTN","VPR SR",14,0)
  25110    S IEN=+$G (IEN),DFN= +$G(DFN) Q :DFN<1
  25111   "RTN","VPR SR",15,0)
  25112    D SR^VPRE VNT(DFN,IE N)
  25113   "RTN","VPR SR",16,0)
  25114    Q
  25115   "RTN","VPR SR",17,0)
  25116    ;
  25117   "RTN","VPR SR",18,0)
  25118   DEL(IEN,DF N) ; -- de lete surge ry request  [from SRO ERR]
  25119   "RTN","VPR SR",19,0)
  25120    S IEN=+$G (IEN),DFN= +$G(DFN) Q :DFN<1
  25121   "RTN","VPR SR",20,0)
  25122    D SR^VPRE VNT(DFN,IE N,"@")
  25123   "RTN","VPR SR",21,0)
  25124    Q
  25125   "RTN","VPR TRPC")
  25126   0^63^B3739 499
  25127   "RTN","VPR TRPC",1,0)
  25128   VPRTRPC ;S LC/AGP - G eneric RPC  controlle r for VPR  ; 7/30/13  3:29pm
  25129   "RTN","VPR TRPC",2,0)
  25130    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  25131   "RTN","VPR TRPC",3,0)
  25132    ;
  25133   "RTN","VPR TRPC",4,0)
  25134    ;
  25135   "RTN","VPR TRPC",5,0)
  25136   RPC(VPRRES ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  25137   "RTN","VPR TRPC",6,0)
  25138    N X,REQ,V PRCNT,VPRS ITE,VPRUSE R,VPRDBUG, VPRSTA
  25139   "RTN","VPR TRPC",7,0)
  25140    ;S VPRXML =$NA(^TMP( $J,"VPR RE SULTS")) K  @VPRXML
  25141   "RTN","VPR TRPC",8,0)
  25142    S VPRCNT= 0
  25143   "RTN","VPR TRPC",9,0)
  25144    ;S VPRUSE R=DUZ,VPRS ITE=DUZ(2) ,VPRSTA=$$ STA^XUAF4( DUZ(2))
  25145   "RTN","VPR TRPC",10,0 )
  25146    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  S R EQ(X,1)=PA RAMS(X)
  25147   "RTN","VPR TRPC",11,0 )
  25148    ;
  25149   "RTN","VPR TRPC",12,0 )
  25150   COMMON ; C ome here f or both CS P and RPC  Mode
  25151   "RTN","VPR TRPC",13,0 )
  25152    ; 
  25153   "RTN","VPR TRPC",14,0 )
  25154    N CMD
  25155   "RTN","VPR TRPC",15,0 )
  25156    S CMD=$G( REQ("comma nd",1))
  25157   "RTN","VPR TRPC",16,0 )
  25158    ;
  25159   "RTN","VPR TRPC",17,0 )
  25160    I CMD="te stRPC" D   G OUT
  25161   "RTN","VPR TRPC",18,0 )
  25162    . D TESTR PC(.VPRRES ,$$VAL("va lue"))
  25163   "RTN","VPR TRPC",19,0 )
  25164    ;
  25165   "RTN","VPR TRPC",20,0 )
  25166    I CMD="im portJson"  D IMPJSON^ VPRTRPC1(. VPRRES,.PA RAMS)
  25167   "RTN","VPR TRPC",21,0 )
  25168    ;
  25169   "RTN","VPR TRPC",22,0 )
  25170    I CMD="te stDelay" D  DELAY^VPR TRPC1(.VPR RES,.PARAM S)
  25171   "RTN","VPR TRPC",23,0 )
  25172    ;
  25173   "RTN","VPR TRPC",24,0 )
  25174    I CMD="sa veData" D  SAVE^VPRTR PC1(.VPRRE S,$$VAL("p atient"),$ $VAL("user "),$$VAL(" domain"),$ $VAL("num" ),$$VAL("s ystem"),$$ VAL("json" ))
  25175   "RTN","VPR TRPC",25,0 )
  25176    ;
  25177   "RTN","VPR TRPC",26,0 )
  25178    I CMD="de leteData"  D DELETE^V PRTRPC1(.V PRRES,$$VA L("patient "),$$VAL(" system"),$ $VAL("json "))
  25179   "RTN","VPR TRPC",27,0 )
  25180    ;
  25181   "RTN","VPR TRPC",28,0 )
  25182    ;M ^XTMP( "AGP TEST" ,"PARAMS") =PARAMS
  25183   "RTN","VPR TRPC",29,0 )
  25184    I CMD="cl earData" D  CLEARVAL^ VPRTRPC1(. VPRRES,$$V AL("system "),$$VAL(" patient"), $$VAL("beg "),$$VAL(" end"),$$VA L("json"))
  25185   "RTN","VPR TRPC",30,0 )
  25186    ;
  25187   "RTN","VPR TRPC",31,0 )
  25188    I CMD="ge tFields" D  GETFLDS^V PRTRPC1(.V PRRES)
  25189   "RTN","VPR TRPC",32,0 )
  25190    ;
  25191   "RTN","VPR TRPC",33,0 )
  25192   OUT ;
  25193   "RTN","VPR TRPC",34,0 )
  25194    I '$D(VPR RES) S VPR RES=""
  25195   "RTN","VPR TRPC",35,0 )
  25196   END Q
  25197   "RTN","VPR TRPC",36,0 )
  25198    ;
  25199   "RTN","VPR TRPC",37,0 )
  25200   VAL(X) ; r eturn valu e from req uest
  25201   "RTN","VPR TRPC",38,0 )
  25202    Q $G(REQ( X,1))
  25203   "RTN","VPR TRPC",39,0 )
  25204    ;
  25205   "RTN","VPR TRPC",40,0 )
  25206   TESTRPC(RE SULT,VALUE ) ;
  25207   "RTN","VPR TRPC",41,0 )
  25208    S RESULT= "result"
  25209   "RTN","VPR TRPC",42,0 )
  25210    I VALUE=" error" D A PPERROR^%Z TER("test  RPC Error" ) Q
  25211   "RTN","VPR TRPC",43,0 )
  25212    I VALUE=" wait" H 60
  25213   "RTN","VPR TRPC",44,0 )
  25214    Q
  25215   "RTN","VPR TRPC",45,0 )
  25216    ;
  25217   "RTN","VPR TRPC1")
  25218   0^64^B4108 1891
  25219   "RTN","VPR TRPC1",1,0 )
  25220   VPRTRPC1 ;  SLC/AGP -  Process O rder Reque st from AV IVA System . ; 7/30/1 3 3:29pm
  25221   "RTN","VPR TRPC1",2,0 )
  25222    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  25223   "RTN","VPR TRPC1",3,0 )
  25224    Q
  25225   "RTN","VPR TRPC1",4,0 )
  25226    ;
  25227   "RTN","VPR TRPC1",5,0 )
  25228   GETFLDS(RE SULT) ;
  25229   "RTN","VPR TRPC1",6,0 )
  25230    N ARRAY,C NT,FCNT,FI ELDS,NUM,T YPE,VPRP,V PRTYPE,X
  25231   "RTN","VPR TRPC1",7,0 )
  25232    S CNT=0
  25233   "RTN","VPR TRPC1",8,0 )
  25234    ;F TYPE=" vs","prob" ,"art","or der","med" ,"cons","p roc","obs" ,"lab","ra d","surger y","tiu"," mha","imm" ,"pov","sk in","exam" ,"cpt","ed ","factor" ,"appt","v isit","ptf " D
  25235   "RTN","VPR TRPC1",9,0 )
  25236    S VPRTYPE =$$ALL^VPR DJ
  25237   "RTN","VPR TRPC1",10, 0)
  25238    F VPRP=1: 1:$L(VPRTY PE,";") S  TYPE=$P(VP RTYPE,";", VPRP) I $L (TYPE) D
  25239   "RTN","VPR TRPC1",11, 0)
  25240    .S CNT=CN T+1
  25241   "RTN","VPR TRPC1",12, 0)
  25242    .S ARRAY( "data",CNT ,"type","n ame")=TYPE
  25243   "RTN","VPR TRPC1",13, 0)
  25244    .S FIELDS =$$ATTR^VP RDCRC(TYPE )
  25245   "RTN","VPR TRPC1",14, 0)
  25246    .S NUM=$L (FIELDS,U)
  25247   "RTN","VPR TRPC1",15, 0)
  25248    .S FCNT=0
  25249   "RTN","VPR TRPC1",16, 0)
  25250    .F X=1:1: NUM D
  25251   "RTN","VPR TRPC1",17, 0)
  25252    ..I $P(FI ELDS,U,X)= "" Q
  25253   "RTN","VPR TRPC1",18, 0)
  25254    ..S FCNT= FCNT+1
  25255   "RTN","VPR TRPC1",19, 0)
  25256    ..S ARRAY ("data",CN T,"type"," fields",FC NT,"field" )=$P(FIELD S,U,X)
  25257   "RTN","VPR TRPC1",20, 0)
  25258    D ENCODE^ VPRJSON("A RRAY","RES ULT","ERRO R")
  25259   "RTN","VPR TRPC1",21, 0)
  25260    ;I $D(ERR OR) ZW ERR OR
  25261   "RTN","VPR TRPC1",22, 0)
  25262    Q
  25263   "RTN","VPR TRPC1",23, 0)
  25264    ;
  25265   "RTN","VPR TRPC1",24, 0)
  25266   TESTRPC(OU T,PARAMS)  ;
  25267   "RTN","VPR TRPC1",25, 0)
  25268    K ^XTMP(" ZZVPR PARA MS"),^XTMP ("ZZVPR JS ON")
  25269   "RTN","VPR TRPC1",26, 0)
  25270    ;M ^XTMP( "ZZVPR JSO N")=JSON
  25271   "RTN","VPR TRPC1",27, 0)
  25272    M ^XTMP(" ZZVPR PARA MS")=PARAM S
  25273   "RTN","VPR TRPC1",28, 0)
  25274    Q
  25275   "RTN","VPR TRPC1",29, 0)
  25276    ;
  25277   "RTN","VPR TRPC1",30, 0)
  25278   CLEARVAL(R ESULT,SYS, PAT,BEG,EN D,JSON) ;
  25279   "RTN","VPR TRPC1",31, 0)
  25280    N BDATE,B NUM,DATE,E DATE,ENUM, LAST,NODE, SUB,X,LAST
  25281   "RTN","VPR TRPC1",32, 0)
  25282    D DELSYS( SYS)
  25283   "RTN","VPR TRPC1",33, 0)
  25284    S BDATE=$ P(BEG,":") ,BNUM=$P(B EG,":",2)
  25285   "RTN","VPR TRPC1",34, 0)
  25286    S EDATE=$ P(END,":") ,ENUM=$P(E ND,":",2)
  25287   "RTN","VPR TRPC1",35, 0)
  25288    S SUB="VP R-"_BDATE
  25289   "RTN","VPR TRPC1",36, 0)
  25290    ;handle c leaning ou t the ^xtm p for the  same date  range
  25291   "RTN","VPR TRPC1",37, 0)
  25292    I BDATE=E DATE D  Q
  25293   "RTN","VPR TRPC1",38, 0)
  25294    .F X=BNUM :1:ENUM I  $P(^XTMP(" VPR-"_BDAT E,X),U)=PA T K ^XTMP( "VPR-"_BDA TE,X)
  25295   "RTN","VPR TRPC1",39, 0)
  25296    ;
  25297   "RTN","VPR TRPC1",40, 0)
  25298    F  S SUB= $O(^XTMP(S UB)) D  Q: SUB=""!($$ END(SUB,ED ATE)=1)
  25299   "RTN","VPR TRPC1",41, 0)
  25300    .;handle  date less  then end d ate but da te equal s tart date
  25301   "RTN","VPR TRPC1",42, 0)
  25302    .S DATE=$ P(SUB,"-", 2) I DATE< EDATE,DATE =BDATE D   Q
  25303   "RTN","VPR TRPC1",43, 0)
  25304    ..S LAST= $O(^XTMP(S UB,""),-1)
  25305   "RTN","VPR TRPC1",44, 0)
  25306    ..F X=BNU M:1:LAST I  $P(^XTMP( SUB,X),U)= PAT K ^XTM P(SUB,X)
  25307   "RTN","VPR TRPC1",45, 0)
  25308    .;
  25309   "RTN","VPR TRPC1",46, 0)
  25310    .;handle  date great er then st art date a nd less th en end dat e
  25311   "RTN","VPR TRPC1",47, 0)
  25312    .I DATE<E DATE,DATE> BDATE D  Q
  25313   "RTN","VPR TRPC1",48, 0)
  25314    ..S LAST= $O(^XTMP(S UB,""),-1)
  25315   "RTN","VPR TRPC1",49, 0)
  25316    ..F X=1:1 :LAST I $P (^XTMP(SUB ,X),U)=PAT  K ^XTMP(S UB,X)
  25317   "RTN","VPR TRPC1",50, 0)
  25318    .;
  25319   "RTN","VPR TRPC1",51, 0)
  25320    .;S LAST= $O(^XTMP(S UB,""),-1)
  25321   "RTN","VPR TRPC1",52, 0)
  25322    .;assume  date equal  stop date  and great er then st art date
  25323   "RTN","VPR TRPC1",53, 0)
  25324    .F X=1:1: ENUM I $P( ^XTMP(SUB, X),U)=PAT  K ^XTMP(SU B,X)
  25325   "RTN","VPR TRPC1",54, 0)
  25326    ;S LAST=$ O(^XTMP("V PR-"_DATE, ""),-1)
  25327   "RTN","VPR TRPC1",55, 0)
  25328    ;F X=NUM: 1:LAST K ^ XTMP("VPR- "_DATE,X)
  25329   "RTN","VPR TRPC1",56, 0)
  25330    ;Need to  iterate js on node an d delete e ntries tha t were mar ked as ent ered in er ror (for e xample  Vi tals)
  25331   "RTN","VPR TRPC1",57, 0)
  25332    ;This res et the fre shness XTM P. Should  this be in  it own RP C call?
  25333   "RTN","VPR TRPC1",58, 0)
  25334    ;K ^XTMP( "VPR-"_DT)  M ^XTMP(" VPR-"_DT)= ^XTMP("VPR  BACKUP")  K ^XTMP("V PR BACKUP" )
  25335   "RTN","VPR TRPC1",59, 0)
  25336    Q
  25337   "RTN","VPR TRPC1",60, 0)
  25338   END(NODE,E DATE) ;
  25339   "RTN","VPR TRPC1",61, 0)
  25340    N DATE
  25341   "RTN","VPR TRPC1",62, 0)
  25342    S DATE=$P (NODE,"-", 2)
  25343   "RTN","VPR TRPC1",63, 0)
  25344    I DATE'>E DATE Q 0
  25345   "RTN","VPR TRPC1",64, 0)
  25346    Q 1
  25347   "RTN","VPR TRPC1",65, 0)
  25348    ;
  25349   "RTN","VPR TRPC1",66, 0)
  25350   DELETE(RES ULT,PAT,SY S,JSON) ;
  25351   "RTN","VPR TRPC1",67, 0)
  25352    N CNT,DA, DIK,ERROR, FILENUM,GL OBAL
  25353   "RTN","VPR TRPC1",68, 0)
  25354    D DECODE^ VPRJSON("J SON","IN", "ERROR")
  25355   "RTN","VPR TRPC1",69, 0)
  25356    S FILENUM =IN("FILEN UM")
  25357   "RTN","VPR TRPC1",70, 0)
  25358    ;Handle f iles that  are not de leted need  to check  with Mel/J erry about  the actio n
  25359   "RTN","VPR TRPC1",71, 0)
  25360    ;I FILENU M="NOT DEL ETE NODES"  D NODELET E D POST^V PREVNT(PAT ,DOMAIN,DA ,"") Q
  25361   "RTN","VPR TRPC1",72, 0)
  25362    S GLOBAL= $$GET1^DID (FILENUM," ","","GLOB AL NAME")
  25363   "RTN","VPR TRPC1",73, 0)
  25364    S DIK=GLO BAL
  25365   "RTN","VPR TRPC1",74, 0)
  25366    S CNT=0 F   S CNT=$O (IN("ITEMS ",CNT)) Q: CNT'>0  D
  25367   "RTN","VPR TRPC1",75, 0)
  25368    .S DA=$G( IN("ITEMS" ,CNT,"IEN" ))
  25369   "RTN","VPR TRPC1",76, 0)
  25370    .D ^DIK
  25371   "RTN","VPR TRPC1",77, 0)
  25372    .D POST^V PREVNT(PAT ,"factor", DA,"@")
  25373   "RTN","VPR TRPC1",78, 0)
  25374    ;This res et the fre shness XTM P. Should  this be in  it own RP C call?
  25375   "RTN","VPR TRPC1",79, 0)
  25376    ;K ^XTMP( "VPR-"_DT)  M ^XTMP(" VPR-"_DT)= ^XTMP("VPR  BACKUP")  K ^XTMP("V PR BACKUP" )
  25377   "RTN","VPR TRPC1",80, 0)
  25378    Q
  25379   "RTN","VPR TRPC1",81, 0)
  25380    ;
  25381   "RTN","VPR TRPC1",82, 0)
  25382   DELAY(OUT, PARAMS) ;
  25383   "RTN","VPR TRPC1",83, 0)
  25384    N ARRAY,D ELAY
  25385   "RTN","VPR TRPC1",84, 0)
  25386    S DELAY=$ G(PARAMS(" delay"))
  25387   "RTN","VPR TRPC1",85, 0)
  25388    H DELAY
  25389   "RTN","VPR TRPC1",86, 0)
  25390    S ARRAY(" success")= "true"
  25391   "RTN","VPR TRPC1",87, 0)
  25392    D ENCODE^ VPRJSON("A RRAY","OUT ","ERROR")
  25393   "RTN","VPR TRPC1",88, 0)
  25394    I $D(ERRO R) D
  25395   "RTN","VPR TRPC1",89, 0)
  25396    .N RESULT ,TXT K OUT
  25397   "RTN","VPR TRPC1",90, 0)
  25398    .S TXT(1) ="Problem  encoding j son output "
  25399   "RTN","VPR TRPC1",91, 0)
  25400    .D SETERR OR^VPRUTIL S(.RESULT, .ERROR,.TX T,.ARRAY)
  25401   "RTN","VPR TRPC1",92, 0)
  25402    .D ENCODE ^VPRJSON(" RESULT","O UT","ERROR ")
  25403   "RTN","VPR TRPC1",93, 0)
  25404    Q
  25405   "RTN","VPR TRPC1",94, 0)
  25406    ;
  25407   "RTN","VPR TRPC1",95, 0)
  25408   DELSYS(SYS ) ;
  25409   "RTN","VPR TRPC1",96, 0)
  25410    N DA,DIK
  25411   "RTN","VPR TRPC1",97, 0)
  25412    S DA=$O(^ VPR(560,"B ",SYS,""))  I +DA'>0  Q
  25413   "RTN","VPR TRPC1",98, 0)
  25414    S DIK="^V PR(560," D  ^DIK
  25415   "RTN","VPR TRPC1",99, 0)
  25416    Q
  25417   "RTN","VPR TRPC1",100 ,0)
  25418    ;
  25419   "RTN","VPR TRPC1",101 ,0)
  25420   IMPJSON(OU T,PARAMS)  ;
  25421   "RTN","VPR TRPC1",102 ,0)
  25422    N GBL,JSO NI,DOMAIN, PATIENT,ER ROR
  25423   "RTN","VPR TRPC1",103 ,0)
  25424    S JSONI=P ARAMS("val ue"),DOMAI N=PARAMS(" domain"),P ATIENT=PAR AMS("patie ntId")
  25425   "RTN","VPR TRPC1",104 ,0)
  25426    S GBL=$NA (^XTMP("JS ON",DOMAIN ,PATIENT))
  25427   "RTN","VPR TRPC1",105 ,0)
  25428    D DECODE^ VPRJSON("J SONI",GBL, "ERROR")
  25429   "RTN","VPR TRPC1",106 ,0)
  25430    I $D(ERRO R) D  Q
  25431   "RTN","VPR TRPC1",107 ,0)
  25432    .N RESULT ,TXT K OUT
  25433   "RTN","VPR TRPC1",108 ,0)
  25434    .S TXT(1) ="Problem  decoding j son input"
  25435   "RTN","VPR TRPC1",109 ,0)
  25436    .D SETERR OR^VPRUTIL S(.RESULT, .ERROR,.TX T,.JSONI)
  25437   "RTN","VPR TRPC1",110 ,0)
  25438    .D ENCODE ^VPRJSON(" RESULT","O UT","ERROR ")
  25439   "RTN","VPR TRPC1",111 ,0)
  25440    D ENCODE^ VPRJSON("A RRAY","OUT ","ERROR")
  25441   "RTN","VPR TRPC1",112 ,0)
  25442    Q
  25443   "RTN","VPR TRPC1",113 ,0)
  25444    ;
  25445   "RTN","VPR TRPC1",114 ,0)
  25446   GETTEAMS(O UT) ;
  25447   "RTN","VPR TRPC1",115 ,0)
  25448    N ACTPRIM ,ARRAY,CNT ,ERROR,NOD E,NUM,NAME ,PATS,SER
  25449   "RTN","VPR TRPC1",116 ,0)
  25450    S NUM=0,C NT=0 F  S  NUM=$O(^SC TM(404.51, NUM)) Q:NU M'>0  D
  25451   "RTN","VPR TRPC1",117 ,0)
  25452    .S NODE=$ G(^SCTM(40 4.51,NUM,0 )),CNT=CNT +1
  25453   "RTN","VPR TRPC1",118 ,0)
  25454    .S NAME=$ P(NODE,U), ACTPRIM=$S ($P(NODE,U ,5)=1:"tru e",1:"fals e")
  25455   "RTN","VPR TRPC1",119 ,0)
  25456    .S SER=""
  25457   "RTN","VPR TRPC1",120 ,0)
  25458    .I $P(NOD E,U,6)>6 S  SER=$P($G (^DIC(49,$ P(NODE,U,6 ),0)),U)
  25459   "RTN","VPR TRPC1",121 ,0)
  25460    .S PATS=$ $TEAMCNT^S CAPMCU1(NU M,DT)
  25461   "RTN","VPR TRPC1",122 ,0)
  25462    .S ARRAY( "data",CNT ,"name")=N AME
  25463   "RTN","VPR TRPC1",123 ,0)
  25464    .I SER'=" " S ARRAY( "data",CNT ,"service" )=SER
  25465   "RTN","VPR TRPC1",124 ,0)
  25466    .S ARRAY( "data",CNT ,"patients ")=PATS
  25467   "RTN","VPR TRPC1",125 ,0)
  25468    D ENCODE^ VPRJSON("A RRAY","OUT ","ERROR")
  25469   "RTN","VPR TRPC1",126 ,0)
  25470    I $D(ERRO R) D
  25471   "RTN","VPR TRPC1",127 ,0)
  25472    .N RESULT ,TXT K OUT
  25473   "RTN","VPR TRPC1",128 ,0)
  25474    .S TXT(1) ="Problem  encoding j son output "
  25475   "RTN","VPR TRPC1",129 ,0)
  25476    .D SETERR OR^VPRUTIL S(.RESULT, .ERROR,.TX T,.ARRAY)
  25477   "RTN","VPR TRPC1",130 ,0)
  25478    .D ENCODE ^VPRJSON(" RESULT","O UT","ERROR ")
  25479   "RTN","VPR TRPC1",131 ,0)
  25480    Q
  25481   "RTN","VPR TRPC1",132 ,0)
  25482    ;
  25483   "RTN","VPR TRPC1",133 ,0)
  25484   SAVE(RESUL T,PAT,USER ,DOMAIN,NU M,SYS,JSON ) ;
  25485   "RTN","VPR TRPC1",134 ,0)
  25486    N ERROR,I ENARRAY,LD ATE,LNUM,V ALUE
  25487   "RTN","VPR TRPC1",135 ,0)
  25488    D SETSYS( SYS,PAT)
  25489   "RTN","VPR TRPC1",136 ,0)
  25490    D DECODE^ VPRJSON("J SON","VALU E","ERROR" )
  25491   "RTN","VPR TRPC1",137 ,0)
  25492    K ^XTMP(" VPR BACKUP ")
  25493   "RTN","VPR TRPC1",138 ,0)
  25494    S LDATE=" VPR-"_DT,L NUM=0
  25495   "RTN","VPR TRPC1",139 ,0)
  25496    I '$D(^XT MP("VPR-"_ DT)) S LDA TE=$O(^XTM P("VPR-A") ,-1)
  25497   "RTN","VPR TRPC1",140 ,0)
  25498    S LNUM=$O (^XTMP(LDA TE,""),-1)
  25499   "RTN","VPR TRPC1",141 ,0)
  25500    S IENARRA Y("lastUpd ate")=$P(L DATE,"-",2 )_":"_LNUM
  25501   "RTN","VPR TRPC1",142 ,0)
  25502    M ^XTMP(" VPR BACKUP ")=^XTMP(" VPR-"_DT)
  25503   "RTN","VPR TRPC1",143 ,0)
  25504    I DOMAIN= "factor" D  HF(PAT,US ER,NUM,.VA LUE,.IENAR RAY)
  25505   "RTN","VPR TRPC1",144 ,0)
  25506    ;M RESULT =IENARRAY
  25507   "RTN","VPR TRPC1",145 ,0)
  25508    D ENCODE^ VPRJSON("I ENARRAY"," RESULT","E RROR")
  25509   "RTN","VPR TRPC1",146 ,0)
  25510    Q
  25511   "RTN","VPR TRPC1",147 ,0)
  25512    ;
  25513   "RTN","VPR TRPC1",148 ,0)
  25514   SETSYS(SYS ,PAT) ;
  25515   "RTN","VPR TRPC1",149 ,0)
  25516    N FDA,MSG ,NAME
  25517   "RTN","VPR TRPC1",150 ,0)
  25518    S NAME=$P ($G(^DPT(P AT,0)),U)  I NAME=""  Q
  25519   "RTN","VPR TRPC1",151 ,0)
  25520    S FDA(560 ,"?+1,",.0 1)=SYS
  25521   "RTN","VPR TRPC1",152 ,0)
  25522    S FDA(560 .01,"?+2,? +1,",.01)= PAT
  25523   "RTN","VPR TRPC1",153 ,0)
  25524    S FDA(560 .01,"?+2,? +1,",2)=1
  25525   "RTN","VPR TRPC1",154 ,0)
  25526    D UPDATE^ DIE("","FD A","","MSG ")
  25527   "RTN","VPR TRPC1",155 ,0)
  25528    I $D(MSG)  D  Q
  25529   "RTN","VPR TRPC1",156 ,0)
  25530    .D EN^DDI OL("Update  failed, U PDATE^DIE  returned t he followi ng error m essage.")
  25531   "RTN","VPR TRPC1",157 ,0)
  25532    .S IC="MS G"
  25533   "RTN","VPR TRPC1",158 ,0)
  25534    .F  S IC= $Q(@IC) Q: IC=""  W ! ,IC,"=",@I C
  25535   "RTN","VPR TRPC1",159 ,0)
  25536    .D EN^DDI OL("Examin e the abov e error me ssage for  the reason .")
  25537   "RTN","VPR TRPC1",160 ,0)
  25538    .H 2
  25539   "RTN","VPR TRPC1",161 ,0)
  25540    Q
  25541   "RTN","VPR TRPC1",162 ,0)
  25542    ;
  25543   "RTN","VPR TRPC1",163 ,0)
  25544   HF(PAT,USE R,NUM,VALU E,IENARRAY ) ;
  25545   "RTN","VPR TRPC1",164 ,0)
  25546    N CNT,ENC IEN,FDA,FM ,FSEC,IEN, LNUM,MSG,N AME,UID,X
  25547   "RTN","VPR TRPC1",165 ,0)
  25548    S FSEC=$P (VALUE("ui d"),":",1, 5)
  25549   "RTN","VPR TRPC1",166 ,0)
  25550    S FM=$$HL 7TFM^XLFDT (VALUE("en tered"))
  25551   "RTN","VPR TRPC1",167 ,0)
  25552    S LNUM=$O (^AUPNVHF( "A"),-1)
  25553   "RTN","VPR TRPC1",168 ,0)
  25554    S NAME=$G (VALUE("na me"))
  25555   "RTN","VPR TRPC1",169 ,0)
  25556    S IEN=$O( ^AUTTHF("B ",NAME,"") )
  25557   "RTN","VPR TRPC1",170 ,0)
  25558    S ENCIEN= $P($G(VALU E("encount erUid"))," :",6)
  25559   "RTN","VPR TRPC1",171 ,0)
  25560    S CNT=0
  25561   "RTN","VPR TRPC1",172 ,0)
  25562    F X=1:1:N UM D
  25563   "RTN","VPR TRPC1",173 ,0)
  25564    .S IENS=L NUM+X
  25565   "RTN","VPR TRPC1",174 ,0)
  25566    .S CNT=CN T+1
  25567   "RTN","VPR TRPC1",175 ,0)
  25568    .S FDA(90 00010.23," +"_IENS_", ",.01)=IEN
  25569   "RTN","VPR TRPC1",176 ,0)
  25570    .S FDA(90 00010.23," +"_IENS_", ",.03)=ENC IEN
  25571   "RTN","VPR TRPC1",177 ,0)
  25572    .S FDA(90 00010.23," +"_IENS_", ",1201)=FM
  25573   "RTN","VPR TRPC1",178 ,0)
  25574    .S FDA(90 00010.23," +"_IENS_", ",.02)=PAT
  25575   "RTN","VPR TRPC1",179 ,0)
  25576    .D UPDATE ^DIE("","F DA","","MS G")
  25577   "RTN","VPR TRPC1",180 ,0)
  25578    .I $D(MSG ) D  Q
  25579   "RTN","VPR TRPC1",181 ,0)
  25580    ..D EN^DD IOL("Updat e failed,  UPDATE^DIE  returned  the follow ing error  message.")
  25581   "RTN","VPR TRPC1",182 ,0)
  25582    ..S IC="M SG"
  25583   "RTN","VPR TRPC1",183 ,0)
  25584    ..F  S IC =$Q(@IC) Q :IC=""  W  !,IC,"=",@ IC
  25585   "RTN","VPR TRPC1",184 ,0)
  25586    ..D EN^DD IOL("Exami ne the abo ve error m essage for  the reaso n.")
  25587   "RTN","VPR TRPC1",185 ,0)
  25588    ..H 2
  25589   "RTN","VPR TRPC1",186 ,0)
  25590    .D POST^V PREVNT(PAT ,"factor", IENS)
  25591   "RTN","VPR TRPC1",187 ,0)
  25592    .S IENARR AY("FILENU M")="90000 10.23"
  25593   "RTN","VPR TRPC1",188 ,0)
  25594    .S IENARR AY("ITEMS" ,X,"IEN")= IENS
  25595   "RTN","VPR TRPC1",189 ,0)
  25596    Q
  25597   "RTN","VPR TRPC1",190 ,0)
  25598    ;
  25599   "RTN","VPR UPD")
  25600   0^83^B2036 8971
  25601   "RTN","VPR UPD",1,0)
  25602   VPRUPD ;SL C/MKB - Up date local  data ;11/ 13/13 2:11 pm
  25603   "RTN","VPR UPD",2,0)
  25604    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  25605   "RTN","VPR UPD",3,0)
  25606    ;
  25607   "RTN","VPR UPD",4,0)
  25608   PHONE(VPR, JSON) ; RP C = VPR PU T PHONE
  25609   "RTN","VPR UPD",5,0)
  25610    Q
  25611   "RTN","VPR UPD",6,0)
  25612   PUT(VPR,DF N,CMD,JSON ) ; -- upd ate phone  numbers
  25613   "RTN","VPR UPD",7,0)
  25614    ; RPC = V PR PUT DEM OGRAPHICS
  25615   "RTN","VPR UPD",8,0)
  25616    ;
  25617   "RTN","VPR UPD",9,0)
  25618    N ARRAY,V PRERR,ERR, HOME,CELL, NOK,ECON,X ,OK,VPRSYS
  25619   "RTN","VPR UPD",10,0)
  25620    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  25621   "RTN","VPR UPD",11,0)
  25622    D DECODE^ VPRJSON("J SON","ARRA Y","VPRERR ")
  25623   "RTN","VPR UPD",12,0)
  25624    I $D(VPRE RR) D  G P Q
  25625   "RTN","VPR UPD",13,0)
  25626    . K ARRAY  N VPRTMP, VPRTXT
  25627   "RTN","VPR UPD",14,0)
  25628    . S VPRTX T(1)="Prob lem decodi ng json in put."
  25629   "RTN","VPR UPD",15,0)
  25630    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.JS ON)
  25631   "RTN","VPR UPD",16,0)
  25632    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","A RRAY","VPR ERR")
  25633   "RTN","VPR UPD",17,0)
  25634    . S VPR(. 5)="{""api Version"": ""1.01""," "error"":{ "
  25635   "RTN","VPR UPD",18,0)
  25636    . M VPR(1 )=ARRAY
  25637   "RTN","VPR UPD",19,0)
  25638    . S VPR(2 )="}}"
  25639   "RTN","VPR UPD",20,0)
  25640    ;
  25641   "RTN","VPR UPD",21,0)
  25642    S DFN=+$G (DFN) I DF N<1 S ERR= $$ERR(1,DF N) G PHQ
  25643   "RTN","VPR UPD",22,0)
  25644    S CMD=$G( CMD) ;can  only updat e phone#
  25645   "RTN","VPR UPD",23,0)
  25646    N VPRX,VP RDR,I,J S  (VPRDR,HOM E,CELL,NOK ,ECON)=""
  25647   "RTN","VPR UPD",24,0)
  25648    D VAL("ol d")
  25649   "RTN","VPR UPD",25,0)
  25650    S I="" F   S I=$O(AR RAY("telec oms",I)) Q :I<1  D
  25651   "RTN","VPR UPD",26,0)
  25652    . I $G(AR RAY("telec oms",I,"us ageCode")) ="H" D  Q
  25653   "RTN","VPR UPD",27,0)
  25654    .. S HOME =$G(ARRAY( "telecoms" ,I,"teleco m"))
  25655   "RTN","VPR UPD",28,0)
  25656    .. I HOME =HOME("old ") S HOME= "" Q            ;no c hange
  25657   "RTN","VPR UPD",29,0)
  25658    .. I "@"[ HOME S:$L( HOME("old" )) HOME="@ " Q  ;dele te
  25659   "RTN","VPR UPD",30,0)
  25660    .. S HOME =$$FORMAT( HOME),ARRA Y("telecom s",I,"tele com")=HOME
  25661   "RTN","VPR UPD",31,0)
  25662    . I $G(AR RAY("telec oms",I,"us ageCode")) ="MC" D  Q
  25663   "RTN","VPR UPD",32,0)
  25664    .. S CELL =$G(ARRAY( "telecoms" ,I,"teleco m"))
  25665   "RTN","VPR UPD",33,0)
  25666    .. I CELL =CELL("old ") S CELL= "" Q            ;no c hange
  25667   "RTN","VPR UPD",34,0)
  25668    .. I "@"[ CELL S:$L( CELL("old" )) CELL="@ " Q  ;dele te
  25669   "RTN","VPR UPD",35,0)
  25670    .. S CELL =$$FORMAT( CELL),ARRA Y("telecom s",I,"tele com")=CELL
  25671   "RTN","VPR UPD",36,0)
  25672    S I="" F   S I=$O(AR RAY("suppo rts",I)) Q :I<1  D
  25673   "RTN","VPR UPD",37,0)
  25674    . S X=$P( $G(ARRAY(" supports", I,"contact TypeCode") ),":",4) Q :X=""  ;NO K or ECON
  25675   "RTN","VPR UPD",38,0)
  25676    . S J=""  F  S J=$O( ARRAY("sup ports",I," telecomLis t",J)) Q:J <1  D
  25677   "RTN","VPR UPD",39,0)
  25678    .. Q:$G(A RRAY("supp orts",I,"t elecomList ",J,"usage Code"))'=" H"
  25679   "RTN","VPR UPD",40,0)
  25680    .. S @X=$ G(ARRAY("s upports",I ,"telecomL ist",J,"te lecom"))
  25681   "RTN","VPR UPD",41,0)
  25682    .. I @X=@ X@("old")  S @X="" Q                  ;no c hange
  25683   "RTN","VPR UPD",42,0)
  25684    .. I "@"[ @X S:$L(@X @("old"))  @X="@" Q        ;dele te
  25685   "RTN","VPR UPD",43,0)
  25686    .. S @X=$ $FORMAT(@X ),ARRAY("s upports",I ,"telecomL ist",J,"te lecom")=@X
  25687   "RTN","VPR UPD",44,0)
  25688    .. ; X="N OK" S NOK= $$FORMAT(N OK),ARRAY( "supports" ,I,"teleco mList",J," telecom")= NOK
  25689   "RTN","VPR UPD",45,0)
  25690    ;
  25691   "RTN","VPR UPD",46,0)
  25692    S:$L(HOME ) VPRX(.13 1)=HOME,VP RDR=".131"
  25693   "RTN","VPR UPD",47,0)
  25694    S:$L(CELL ) VPRX(.13 4)=CELL,VP RDR=VPRDR_ $S($L(VPRD R):";",1:" ")_".134"
  25695   "RTN","VPR UPD",48,0)
  25696    S:$L(ECON ) VPRX(.33 9)=ECON,VP RDR=VPRDR_ $S($L(VPRD R):";",1:" ")_".339"
  25697   "RTN","VPR UPD",49,0)
  25698    S:$L(NOK)  VPRX(.219 )=NOK,VPRD R=VPRDR_$S ($L(VPRDR) :";",1:"") _".219"
  25699   "RTN","VPR UPD",50,0)
  25700    I '$O(VPR X(0)) S ER R=$$ERR(3)  G PHQ
  25701   "RTN","VPR UPD",51,0)
  25702    D EDIT^VA FCPTED(DFN ,"VPRX",VP RDR)
  25703   "RTN","VPR UPD",52,0)
  25704    S X=$G(^D PT(DFN,.13 )),OK=1 D   ;check gl obal
  25705   "RTN","VPR UPD",53,0)
  25706    . I $L(HO ME),$S(HOM E="@":$L($ P(X,U)),1: (VPRX(.131 )'=$P(X,U) )) S OK=0
  25707   "RTN","VPR UPD",54,0)
  25708    . I $L(CE LL),$S(CEL L="@":$L($ P(X,U,4)), 1:(VPRX(.1 34)'=$P(X, U,4))) S O K=0
  25709   "RTN","VPR UPD",55,0)
  25710    . I $L(EC ON) S X=$G (^DPT(DFN, .33)) I $S (ECON="@": $L($P(X,U, 9)),1:(VPR X(.339)'=$ P(X,U,9)))  S OK=0
  25711   "RTN","VPR UPD",56,0)
  25712    . I $L(NO K) S X=$G( ^DPT(DFN,. 21)) I $S( NOK="@":$L ($P(X,U,9) ),1:(VPRX( .219)'=$P( X,U,9))) S  OK=0
  25713   "RTN","VPR UPD",57,0)
  25714    S:'OK ERR =$$ERR(5)
  25715   "RTN","VPR UPD",58,0)
  25716    ;
  25717   "RTN","VPR UPD",59,0)
  25718   PHQ ; add  item count  and termi nating cha racters
  25719   "RTN","VPR UPD",60,0)
  25720    I $D(ERR)  S VPR(1)= "{""apiVer sion"":""1 .01"",""er ror"":{""m essage"":" ""_ERR_""" },""succes s"":false} " G PQ
  25721   "RTN","VPR UPD",61,0)
  25722    ; VPR="{" "apiVersio n"":""1.01 "",""data" ":{""updat ed"":"_""" "_$$HL7NOW _""""_","" localId"": """_DFN_"" "},""succe ss"":true} "
  25723   "RTN","VPR UPD",62,0)
  25724    D POSTX^V PREVNT("pa tient",DFN )
  25725   "RTN","VPR UPD",63,0)
  25726    D ENCODE^ VPRJSON("A RRAY","VPR ","VPRERR" )
  25727   "RTN","VPR UPD",64,0)
  25728    I $D(VPRE RR) D  G P Q
  25729   "RTN","VPR UPD",65,0)
  25730    . K VPR N  VPRTMP,VP RTXT
  25731   "RTN","VPR UPD",66,0)
  25732    . S VPRTX T(1)="Prob lem encodi ng json ou tput."
  25733   "RTN","VPR UPD",67,0)
  25734    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.AR RAY)
  25735   "RTN","VPR UPD",68,0)
  25736    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","V PR","VPRER R")
  25737   "RTN","VPR UPD",69,0)
  25738    . S VPR(. 5)="{""api Version"": ""1.01""," "error"":{ ",VPR(99)= "}}"
  25739   "RTN","VPR UPD",70,0)
  25740    S VPR(.5) ="{""apiVe rsion"":"" 1.01"",""p arams"":{" _$$SYS^VPR DJ_"},""su ccess"":tr ue,"
  25741   "RTN","VPR UPD",71,0)
  25742    S VPR(.6) ="""data"" :{""update d"":"""_$$ HL7NOW^VPR DJ_""",""t otalItems" ":1,""item s"":["
  25743   "RTN","VPR UPD",72,0)
  25744    S VPR(99) ="]}}"
  25745   "RTN","VPR UPD",73,0)
  25746   PQ ; exit
  25747   "RTN","VPR UPD",74,0)
  25748    K ^TMP($J ,"VPR")
  25749   "RTN","VPR UPD",75,0)
  25750    M ^TMP($J ,"VPR")=VP R
  25751   "RTN","VPR UPD",76,0)
  25752    K VPR S V PR=$NA(^TM P($J,"VPR" ))
  25753   "RTN","VPR UPD",77,0)
  25754    Q
  25755   "RTN","VPR UPD",78,0)
  25756    ;
  25757   "RTN","VPR UPD",79,0)
  25758   FORMAT(X)  ; -- enfor ce (xxx)xx x-xxxx pho ne format
  25759   "RTN","VPR UPD",80,0)
  25760    S X=$G(X)  I X?1"("3 N1")"3N1"- "4N.E Q X
  25761   "RTN","VPR UPD",81,0)
  25762    N P,N,I,Y  S P=""
  25763   "RTN","VPR UPD",82,0)
  25764    F I=1:1:$ L(X) S N=$ E(X,I) I N =+N S P=P_ N
  25765   "RTN","VPR UPD",83,0)
  25766    S:$L(P)<1 0 P=$E("00 00000000", 1,10-$L(P) )_P
  25767   "RTN","VPR UPD",84,0)
  25768    S Y=$S(P: "("_$E(P,1 ,3)_")"_$E (P,4,6)_"- "_$E(P,7,1 0),1:"")
  25769   "RTN","VPR UPD",85,0)
  25770    Q Y
  25771   "RTN","VPR UPD",86,0)
  25772    ;
  25773   "RTN","VPR UPD",87,0)
  25774   HL7NOW() ;  -- Return  current t ime in HL7  format
  25775   "RTN","VPR UPD",88,0)
  25776    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  25777   "RTN","VPR UPD",89,0)
  25778    ;
  25779   "RTN","VPR UPD",90,0)
  25780   ERR(X,VAL)  ; -- retu rn error m essage
  25781   "RTN","VPR UPD",91,0)
  25782    N MSG  S  MSG="Error "
  25783   "RTN","VPR UPD",92,0)
  25784    I X=1  S  MSG="Patie nt with df n '"_$G(VA L)_"' not  found"
  25785   "RTN","VPR UPD",93,0)
  25786    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  25787   "RTN","VPR UPD",94,0)
  25788    I X=3  S  MSG="Data  not change d"
  25789   "RTN","VPR UPD",95,0)
  25790    I X=4  S  MSG="Unabl e to creat e new obje ct"
  25791   "RTN","VPR UPD",96,0)
  25792    I X=5  S  MSG="Updat e failed"
  25793   "RTN","VPR UPD",97,0)
  25794    I X=99 S  MSG="Unkno wn request "
  25795   "RTN","VPR UPD",98,0)
  25796    Q MSG
  25797   "RTN","VPR UPD",99,0)
  25798    ;
  25799   "RTN","VPR UPD",100,0 )
  25800   VAL(SUB) ;  -- pull v alues from  ^DPT
  25801   "RTN","VPR UPD",101,0 )
  25802    N X S X=$ G(^DPT(DFN ,.13))
  25803   "RTN","VPR UPD",102,0 )
  25804    S HOME(SU B)=$P(X,U) ,CELL(SUB) =$P(X,U,4)
  25805   "RTN","VPR UPD",103,0 )
  25806    S X=$G(^D PT(DFN,.33 )),ECON(SU B)=$P(X,U, 9)
  25807   "RTN","VPR UPD",104,0 )
  25808    S X=$G(^D PT(DFN,.21 )),NOK(SUB )=$P(X,U,9 )
  25809   "RTN","VPR UPD",105,0 )
  25810    Q
  25811   "RTN","VPR UTILS")
  25812   0^93^B1865 9956
  25813   "RTN","VPR UTILS",1,0 )
  25814   VPRUTILS ; SLC/AGP --  VPR utili ties routi ne ;8/14/1 3  11:22
  25815   "RTN","VPR UTILS",2,0 )
  25816    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 205
  25817   "RTN","VPR UTILS",3,0 )
  25818    ;
  25819   "RTN","VPR UTILS",4,0 )
  25820    ; Externa l Referenc es           DBIA#
  25821   "RTN","VPR UTILS",5,0 )
  25822    ; ------- ---------- --           -----
  25823   "RTN","VPR UTILS",6,0 )
  25824    ; XLFCRC                           3156
  25825   "RTN","VPR UTILS",7,0 )
  25826    ; XLFDT                           10103
  25827   "RTN","VPR UTILS",8,0 )
  25828    ; XLFUTL                           2622
  25829   "RTN","VPR UTILS",9,0 )
  25830    ; XUPARAM                          2541
  25831   "RTN","VPR UTILS",10, 0)
  25832    ;
  25833   "RTN","VPR UTILS",11, 0)
  25834    Q
  25835   "RTN","VPR UTILS",12, 0)
  25836    ;
  25837   "RTN","VPR UTILS",13, 0)
  25838   SETERROR(R ESULT,ERRO R,EXTERROR ,DATA) ; - - error te xt for JSO N
  25839   "RTN","VPR UTILS",14, 0)
  25840    N CNT,TEM P,VPRTEMP, XCNT
  25841   "RTN","VPR UTILS",15, 0)
  25842    S VPRTEMP ="VPRXTEMP  ERRORS"
  25843   "RTN","VPR UTILS",16, 0)
  25844    I '$D(^XT MP(VPRTEMP ,0)) S ^XT MP(VPRTEMP ,0)=$$FMAD D^XLFDT(DT ,7)_U_DT_U _"VPR ERRO R GLOBAL"
  25845   "RTN","VPR UTILS",17, 0)
  25846    S RESULT( "success") ="false"
  25847   "RTN","VPR UTILS",18, 0)
  25848    I $D(DATA ) S XCNT=$ O(^XTMP(VP RTEMP,""), -1)+1 M ^X TMP(VPRTEM P,XCNT,"ER ROR")=DATA
  25849   "RTN","VPR UTILS",19, 0)
  25850    I $D(ERRO R) D SETER RTX(.TEMP, .ERROR) S  RESULT("er ror","code ")=TEMP
  25851   "RTN","VPR UTILS",20, 0)
  25852    I +$G(XCN T)>0 S RES ULT("error ","code")= $G(RESULT( "error","c ode"))_" S ee ^XTMP(" _VPRTEMP_" ,"_XCNT_", DATA) for  data"
  25853   "RTN","VPR UTILS",21, 0)
  25854    I $D(EXTE RROR) D SE TERRTX(.TE MP,.EXTERR OR) I TEMP '="" S RES ULT("error ","message ")=TEMP
  25855   "RTN","VPR UTILS",22, 0)
  25856    ;
  25857   "RTN","VPR UTILS",23, 0)
  25858    Q
  25859   "RTN","VPR UTILS",24, 0)
  25860    ;
  25861   "RTN","VPR UTILS",25, 0)
  25862   SETERRTX(T EMP,ERROR)  ;
  25863   "RTN","VPR UTILS",26, 0)
  25864    S TEMP=""
  25865   "RTN","VPR UTILS",27, 0)
  25866    S CNT=0 F   S CNT=$O (ERROR(CNT )) Q:CNT'> 0  D
  25867   "RTN","VPR UTILS",28, 0)
  25868    .S TEMP=$ S(TEMP'="" :TEMP=TEMP _$C(13,10) _ERROR(CNT ),1:ERROR( CNT))
  25869   "RTN","VPR UTILS",29, 0)
  25870    Q
  25871   "RTN","VPR UTILS",30, 0)
  25872    ;
  25873   "RTN","VPR UTILS",31, 0)
  25874   SETTEXT(X, VALUE) ; - - format w ord proces sing
  25875   "RTN","VPR UTILS",32, 0)
  25876    N FIRST,I ,LINE
  25877   "RTN","VPR UTILS",33, 0)
  25878    S FIRST=1
  25879   "RTN","VPR UTILS",34, 0)
  25880    S I=0 F   S I=$O(@X@ (I)) Q:I<1   D
  25881   "RTN","VPR UTILS",35, 0)
  25882    .S LINE=$ S($D(@X@(I ,0)):@X@(I ,0),1:@X@( I))
  25883   "RTN","VPR UTILS",36, 0)
  25884    .; FIRST= 1 S @VALUE @(I)=LINE, FIRST=0 Q
  25885   "RTN","VPR UTILS",37, 0)
  25886    .S @VALUE @(I)=LINE_ $C(13)_$C( 10)
  25887   "RTN","VPR UTILS",38, 0)
  25888    Q
  25889   "RTN","VPR UTILS",39, 0)
  25890    ;
  25891   "RTN","VPR UTILS",40, 0)
  25892   SPLITVAL(N ODE,ARRAY)  ; -- spli t a value  into a lis t
  25893   "RTN","VPR UTILS",41, 0)
  25894    N CNT,NAM E,VALUE,FI ELD
  25895   "RTN","VPR UTILS",42, 0)
  25896    S NAME=""  F  S NAME =$O(ARRAY( NAME)) Q:N AME=""  D
  25897   "RTN","VPR UTILS",43, 0)
  25898    .S CNT=+A RRAY(NAME)
  25899   "RTN","VPR UTILS",44, 0)
  25900    .S VALUE= $P($G(NODE ),U,CNT)
  25901   "RTN","VPR UTILS",45, 0)
  25902    .I NAME=" Code" S FI ELD=$P(ARR AY(NAME),U ,2) S VALU E=$$SETVUR N(FIELD,VA LUE)
  25903   "RTN","VPR UTILS",46, 0)
  25904    .S ARRAY( NAME)=VALU E
  25905   "RTN","VPR UTILS",47, 0)
  25906    Q
  25907   "RTN","VPR UTILS",48, 0)
  25908    ;
  25909   "RTN","VPR UTILS",49, 0)
  25910   SETPROV(NO DE,PROV) ;  -- provid ers
  25911   "RTN","VPR UTILS",50, 0)
  25912    S PROV("p roviderUid ")=$$SETUI D("user",, +NODE)
  25913   "RTN","VPR UTILS",51, 0)
  25914    S PROV("p roviderNam e")=$P(NOD E,U,2)
  25915   "RTN","VPR UTILS",52, 0)
  25916    Q
  25917   "RTN","VPR UTILS",53, 0)
  25918    ;
  25919   "RTN","VPR UTILS",54, 0)
  25920   SETUID(DOM AIN,PAT,ID ,ADDDATA)  ; -- creat e uid stri ng
  25921   "RTN","VPR UTILS",55, 0)
  25922    N RESULT, SYS
  25923   "RTN","VPR UTILS",56, 0)
  25924    S SYS=$S( $D(VPRSYS) :VPRSYS,1: $$GET^XPAR ("SYS","VP R SYSTEM N AME"))
  25925   "RTN","VPR UTILS",57, 0)
  25926    S RESULT= "urn:va:"_ DOMAIN_":" _SYS_":"_$ S($G(PAT): PAT_":",1: "")_ID
  25927   "RTN","VPR UTILS",58, 0)
  25928    I $L($G(A DDDATA)) S  RESULT=RE SULT_":"_A DDDATA
  25929   "RTN","VPR UTILS",59, 0)
  25930    Q RESULT
  25931   "RTN","VPR UTILS",60, 0)
  25932    ;
  25933   "RTN","VPR UTILS",61, 0)
  25934   SETFCURN(D OMAIN,FACI LITY,VALUE ) ; -- cre ate facili ty urn
  25935   "RTN","VPR UTILS",62, 0)
  25936    Q "urn:va :"_DOMAIN_ ":"_FACILI TY_":"_VAL UE
  25937   "RTN","VPR UTILS",63, 0)
  25938    ;
  25939   "RTN","VPR UTILS",64, 0)
  25940   SETVURN(DO MAIN,VALUE ) ; -- cre ate VA urn
  25941   "RTN","VPR UTILS",65, 0)
  25942    N RESULT  S RESULT=" "
  25943   "RTN","VPR UTILS",66, 0)
  25944    S RESULT= "urn:va:"_ DOMAIN_":" _VALUE
  25945   "RTN","VPR UTILS",67, 0)
  25946    Q RESULT
  25947   "RTN","VPR UTILS",68, 0)
  25948    ;
  25949   "RTN","VPR UTILS",69, 0)
  25950   SYS() ; --  return ha shed syste m name
  25951   "RTN","VPR UTILS",70, 0)
  25952    Q $$BASE^ XLFUTL($$C RC16^XLFCR C($$KSP^XU PARAM("WHE RE")),10,1 6)
  25953   "RTN","VPR UTILS",71, 0)
  25954    ;
  25955   "RTN","VPR UTILS",72, 0)
  25956   SETNCS(COD ESET,VALUE ) ; -- cre ate nation al codeset  urn
  25957   "RTN","VPR UTILS",73, 0)
  25958    Q "urn:"_ CODESET_": "_VALUE
  25959   "RTN","VPR UTILS",74, 0)
  25960    ;
  25961   "RTN","VPR UTILS",75, 0)
  25962   JSONDT(X)  ; -- conve rt FileMan  DT to HL7  DT for JS ON
  25963   "RTN","VPR UTILS",76, 0)
  25964    N D,DATE, M,TIME,Y
  25965   "RTN","VPR UTILS",77, 0)
  25966    S DATE=$P ($$FMTHL7^ XLFDT(X)," -")
  25967   "RTN","VPR UTILS",78, 0)
  25968    I $L(DATE )>8 S TIME =$E(DATE,9 ,$L(DATE))
  25969   "RTN","VPR UTILS",79, 0)
  25970    S Y=$E(DA TE,1,4),M= $E(DATE,5, 6),D=$E(DA TE,7,8)
  25971   "RTN","VPR UTILS",80, 0)
  25972    K DATE
  25973   "RTN","VPR UTILS",81, 0)
  25974    S DATE=Y  I M>0 S DA TE=DATE_M  S:D>0 DATE =DATE_D
  25975   "RTN","VPR UTILS",82, 0)
  25976    I $G(TIME )'="" D  S  DATE=DATE _TIME
  25977   "RTN","VPR UTILS",83, 0)
  25978    . N S S S =$E(TIME_" 000000",5, 6)
  25979   "RTN","VPR UTILS",84, 0)
  25980    . I S,S>5 9 S TIME=$ E(TIME,1,4 ) ;strip b ad seconds
  25981   "RTN","VPR UTILS",85, 0)
  25982    Q DATE
  25983   "RTN","VPR UTILS",86, 0)
  25984    ;
  25985   "RTN","VPR UTILS",87, 0)
  25986   FACILITY(X ,Y) ; -- a dd facilit y info to  array for  JSON
  25987   "RTN","VPR UTILS",88, 0)
  25988    ;  X=STAT ION NUMBER ^STATION N AME
  25989   "RTN","VPR UTILS",89, 0)
  25990    ;  Y=Vari able array  name
  25991   "RTN","VPR UTILS",90, 0)
  25992    ; >D FACI LITY^VPRUT ILS("500^C AMP MASTER ","LAB")
  25993   "RTN","VPR UTILS",91, 0)
  25994    ;
  25995   "RTN","VPR UTILS",92, 0)
  25996    S @Y@("fa cilityCode ")=$P(X,"^ ")
  25997   "RTN","VPR UTILS",93, 0)
  25998    S @Y@("fa cilityName ")=$P(X,"^ ",2)
  25999   "RTN","VPR UTILS",94, 0)
  26000    Q
  26001   "RTN","VPR UTILS",95, 0)
  26002   VERSRV()    ; Return  server ver sion of op tion name
  26003   "RTN","VPR UTILS",96, 0)
  26004    N VPRLST, VAL
  26005   "RTN","VPR UTILS",97, 0)
  26006    D FIND^DI C(19,"",1, "X","VPR U I CONTEXT" ,1,,,,"VPR LST")
  26007   "RTN","VPR UTILS",98, 0)
  26008    S VAL=$G( VPRLST("DI LIST","ID" ,1,1))
  26009   "RTN","VPR UTILS",99, 0)
  26010    Q $$UP^XL FSTR($P(VA L,"version  ",2))
  26011   "RTN","VPR UTILS",100 ,0)
  26012    ;
  26013   "RTN","VPR UTILS",101 ,0)
  26014   VERCMP(CUR ,VAL) ; Re turns 1 if  CUR<VAL,  -1 if CUR> VAL, 0 if  equal
  26015   "RTN","VPR UTILS",102 ,0)
  26016    N CURMAJO R,CURMINOR ,CURSNAP,V ALMAJOR,VA LMINOR,VAL SNAP
  26017   "RTN","VPR UTILS",103 ,0)
  26018    S CURMAJO R=$P(CUR," -"),CURMIN OR=$P(CUR, "-",2),CUR SNAP=$E($P (CUR,"-",3 ),1,4)="SN AP"
  26019   "RTN","VPR UTILS",104 ,0)
  26020    S VALMAJO R=$P(VAL," -"),VALMIN OR=$P(VAL, "-",2),VAL SNAP=$E($P (VAL,"-",3 ),1,4)="SN AP"
  26021   "RTN","VPR UTILS",105 ,0)
  26022    I $E(VALM INOR)="P"  S VALMINOR =$E(VALMIN OR,2,99)      ; "P"il ot version s (old)
  26023   "RTN","VPR UTILS",106 ,0)
  26024    I $E(CURM INOR)="P"  S CURMINOR =$E(VALMIN OR,2,99)
  26025   "RTN","VPR UTILS",107 ,0)
  26026    I $E(VALM INOR)="S"  S VALMINOR =$E(VALMIN OR,2,99)*1 0  ; "S"pr int versio ns
  26027   "RTN","VPR UTILS",108 ,0)
  26028    I $E(CURM INOR)="S"  S CURMINOR =$E(CURMIN OR,2,99)*1 0
  26029   "RTN","VPR UTILS",109 ,0)
  26030    Q:VALMAJO R>CURMAJOR  1   Q:VAL MAJOR<CURM AJOR -1  ;  compare m ajor versi ons
  26031   "RTN","VPR UTILS",110 ,0)
  26032    Q:VALMINO R>CURMINOR  1   Q:VAL MINOR<CURM INOR -1  ;  compare m inor versi ons
  26033   "RTN","VPR UTILS",111 ,0)
  26034    Q:(CURSNA P&'VALSNAP ) 1  Q:(VA LSNAP&'CUR SNAP) -1 ;  "SNAPSHOT " < releas ed
  26035   "RTN","VPR UTILS",112 ,0)
  26036    Q 0
  26037   "RTN","VPR UTILS",113 ,0)
  26038    ;
  26039   "RTN","VPR YFRP")
  26040   0^66^B9317 5404
  26041   "RTN","VPR YFRP",1,0)
  26042   VPRYFRP ;S LC/KCM --  Find recen t patients  and put o n roster
  26043   "RTN","VPR YFRP",2,0)
  26044    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  26045   "RTN","VPR YFRP",3,0)
  26046    ;
  26047   "RTN","VPR YFRP",4,0)
  26048   EN ; Utili ties for b uilding ro ster lists
  26049   "RTN","VPR YFRP",5,0)
  26050    W !,"D BL DMTHS to c reate list s"
  26051   "RTN","VPR YFRP",6,0)
  26052    W !,"D SH OWCNT to s ee how man y patients  in each m onth"
  26053   "RTN","VPR YFRP",7,0)
  26054    W !,"D XT RLST to ge t a single  month"
  26055   "RTN","VPR YFRP",8,0)
  26056    W !,"D GE T4ALL to d o extracts  for all t he patient s"
  26057   "RTN","VPR YFRP",9,0)
  26058    W !,"D SH OWSIZE to  show sizes  for each  month"
  26059   "RTN","VPR YFRP",10,0 )
  26060    W !,"D SH OWSTS to s how task s tatus and  any errors  in extrac ts"
  26061   "RTN","VPR YFRP",11,0 )
  26062    W !,"D SH OWTOP to s how the hi ghest time s and size s"
  26063   "RTN","VPR YFRP",12,0 )
  26064    W !,"D ST OP to stop  processin g of extra cts"
  26065   "RTN","VPR YFRP",13,0 )
  26066    W !!,"Dat a stored i n ^XTMP("" VPRYFRP"") ",!
  26067   "RTN","VPR YFRP",14,0 )
  26068    Q
  26069   "RTN","VPR YFRP",15,0 )
  26070    ;
  26071   "RTN","VPR YFRP",16,0 )
  26072   BLDMTHS ;  Build pati ent lists  for a rang e of month
  26073   "RTN","VPR YFRP",17,0 )
  26074    ; ^XTMP(" VPRYFRP"," FOUND",DFN )=""          ; patie nts alread y found
  26075   "RTN","VPR YFRP",18,0 )
  26076    ; ^XTMP(" VPRYFRP"," MONTH",YYY YMM,DFN)=" "  ; patie nts by mon th of last  visit
  26077   "RTN","VPR YFRP",19,0 )
  26078    ; MONTHS( inverseMon th)=YYYMM^ MmmYYYY       ; month s to measu re
  26079   "RTN","VPR YFRP",20,0 )
  26080    ;
  26081   "RTN","VPR YFRP",21,0 )
  26082    K ^XTMP(" VPRYFRP")
  26083   "RTN","VPR YFRP",22,0 )
  26084    S ^XTMP(" VPRYFRP",0 )=$$HTFM^X LFDT(+$H+4 )_"^"_$$HT FM^XLFDT(+ $H)_"^VPR  Build Rost ers by Mon th"
  26085   "RTN","VPR YFRP",23,0 )
  26086    ;
  26087   "RTN","VPR YFRP",24,0 )
  26088    N MTHBEG, MTHEND,MON TH,MONTHS
  26089   "RTN","VPR YFRP",25,0 )
  26090    D PRMTMTH S(.MTHBEG, .MTHEND) Q :'MTHBEG
  26091   "RTN","VPR YFRP",26,0 )
  26092    I MTHBEG> MTHEND N X  S X=MTHEN D,MTHEND=M THBEG,MTHB EG=X
  26093   "RTN","VPR YFRP",27,0 )
  26094    S MONTH=M THBEG F  D   Q:MONTH> MTHEND
  26095   "RTN","VPR YFRP",28,0 )
  26096    . S MONTH S(MONTH)=M ONTH_"^"_$ $EXTMTH(MO NTH)
  26097   "RTN","VPR YFRP",29,0 )
  26098    . S MONTH =$$INCMTH( MONTH)
  26099   "RTN","VPR YFRP",30,0 )
  26100    S MONTH=0  F  S MONT H=$O(MONTH S(MONTH))  Q:'MONTH   D BLDMTH(M ONTHS(MONT H)) W "."
  26101   "RTN","VPR YFRP",31,0 )
  26102    W ! D SHO WCNT
  26103   "RTN","VPR YFRP",32,0 )
  26104    Q
  26105   "RTN","VPR YFRP",33,0 )
  26106   BLDMTH(MON TH) ; Buil d list of  patients f or a month
  26107   "RTN","VPR YFRP",34,0 )
  26108    N NAME,ST ART,STOP,V DATE,VISIT ,X0,DFN,CA T
  26109   "RTN","VPR YFRP",35,0 )
  26110    S START=$ P(MONTH,"^ "),NAME=$P (MONTH,"^" ,2)
  26111   "RTN","VPR YFRP",36,0 )
  26112    S ^XTMP(" VPRYFRP"," SEQUENCE", START)=NAM E
  26113   "RTN","VPR YFRP",37,0 )
  26114    S VDATE=+ (START_"00 "),STOP=+( START_"99" )
  26115   "RTN","VPR YFRP",38,0 )
  26116    F  S VDAT E=$O(^AUPN VSIT("B",V DATE))  Q: 'VDATE  Q: VDATE>STOP   D
  26117   "RTN","VPR YFRP",39,0 )
  26118    . S VISIT =0 F  S VI SIT=$O(^AU PNVSIT("B" ,VDATE,VIS IT)) Q:'VI SIT  D
  26119   "RTN","VPR YFRP",40,0 )
  26120    . . S X0= ^AUPNVSIT( VISIT,0),D FN=$P(X0," ^",5),CAT= $P(X0,"^", 7)
  26121   "RTN","VPR YFRP",41,0 )
  26122    . . Q:$D( ^XTMP("VPR YFRP","FOU ND",DFN))
  26123   "RTN","VPR YFRP",42,0 )
  26124    . . Q:CAT ="E"  ; ev ent (histo rical)
  26125   "RTN","VPR YFRP",43,0 )
  26126    . . Q:CAT ="N"  ; no t found
  26127   "RTN","VPR YFRP",44,0 )
  26128    . . S ^XT MP("VPRYFR P","MONTH" ,NAME,DFN) =""
  26129   "RTN","VPR YFRP",45,0 )
  26130    . . S ^XT MP("VPRYFR P","FOUND" ,DFN)=""
  26131   "RTN","VPR YFRP",46,0 )
  26132    Q
  26133   "RTN","VPR YFRP",47,0 )
  26134   XTRLST ; P rompt for  a list nam e and extr act it int eractively
  26135   "RTN","VPR YFRP",48,0 )
  26136    N DIR,DTO UT,DUOUT,D IRUT,DIROU T,X,Y,DA,F ROMSYS,TOS YS
  26137   "RTN","VPR YFRP",49,0 )
  26138    S DIR(0)= "D^::EMP", DIR("A")=" Extract Mo nth",DIR(" ?")="Enter  the month  to run an  extract."
  26139   "RTN","VPR YFRP",50,0 )
  26140    D ^DIR I  $D(DIRUT)  Q
  26141   "RTN","VPR YFRP",51,0 )
  26142    N VPRYNAM E S VPRYNA ME=$$EXTMT H(Y)
  26143   "RTN","VPR YFRP",52,0 )
  26144    W !,"Runn ing Extrac ts for "_V PRYNAME_".   Continue ? NO// " R  X:300
  26145   "RTN","VPR YFRP",53,0 )
  26146    I $E($$UP ^XLFSTR(X) )'="Y" Q
  26147   "RTN","VPR YFRP",54,0 )
  26148    W !
  26149   "RTN","VPR YFRP",55,0 )
  26150    D GET4LST
  26151   "RTN","VPR YFRP",56,0 )
  26152    Q
  26153   "RTN","VPR YFRP",57,0 )
  26154   GET4ALL ;  Extract da ta for all  lists
  26155   "RTN","VPR YFRP",58,0 )
  26156    ; VARIABL ES THAT CO NTROL EXTR ACT PROCES S
  26157   "RTN","VPR YFRP",59,0 )
  26158    ; VPRYNAM E: name of  month for  which pat ients are  being extr acted
  26159   "RTN","VPR YFRP",60,0 )
  26160    ; VPRYDFN  : current  DFN in th e month
  26161   "RTN","VPR YFRP",61,0 )
  26162    ; VPRYDOM S: domains  for which  extracts  will be do ne
  26163   "RTN","VPR YFRP",62,0 )
  26164    ; VPRYDOM  : current  DOMAIN fo r extract
  26165   "RTN","VPR YFRP",63,0 )
  26166    ; these v ariables g et saved b efore each  extract s o KILL^XUS CLEAN may  be called
  26167   "RTN","VPR YFRP",64,0 )
  26168    N VPRYNAM E,X
  26169   "RTN","VPR YFRP",65,0 )
  26170    W !,"Queu e each lis t?  NO// "  R X:300
  26171   "RTN","VPR YFRP",66,0 )
  26172    I $E($$UP ^XLFSTR(X) )="Y" N VP RYQ,LASTPT ,VPRDTH S  VPRYQ=1,LA STPT=0
  26173   "RTN","VPR YFRP",67,0 )
  26174    S VPRYNAM E=""
  26175   "RTN","VPR YFRP",68,0 )
  26176    F  S VPRY NAME=$O(^X TMP("VPRYF RP","MONTH ",VPRYNAME )) Q:VPRYN AME=""  D
  26177   "RTN","VPR YFRP",69,0 )
  26178    . I $G(VP RYQ) D  Q
  26179   "RTN","VPR YFRP",70,0 )
  26180    . . S VPR DTH=$$HADD ^XLFDT($H, ,LASTPT\10 00)
  26181   "RTN","VPR YFRP",71,0 )
  26182    . . D QU4 LST
  26183   "RTN","VPR YFRP",72,0 )
  26184    . . S LAS TPT=LASTPT +^XTMP("VP RYFRP","co unt",VPRYN AME)
  26185   "RTN","VPR YFRP",73,0 )
  26186    . E  D
  26187   "RTN","VPR YFRP",74,0 )
  26188    . . W !," Running ex tracts for  "_VPRYNAM E
  26189   "RTN","VPR YFRP",75,0 )
  26190    . . D GET 4LST
  26191   "RTN","VPR YFRP",76,0 )
  26192    Q
  26193   "RTN","VPR YFRP",77,0 )
  26194   STOP ; Sto p queued j obs
  26195   "RTN","VPR YFRP",78,0 )
  26196    S ^XTMP(" VPRYFRP"," STOP")=1
  26197   "RTN","VPR YFRP",79,0 )
  26198    Q
  26199   "RTN","VPR YFRP",80,0 )
  26200    ;
  26201   "RTN","VPR YFRP",81,0 )
  26202   QU4LST ; Q ueue extra ct of a mo nth
  26203   "RTN","VPR YFRP",82,0 )
  26204    ; expects  VPRYNAME  from GET4A LL
  26205   "RTN","VPR YFRP",83,0 )
  26206    N ZTRTN,Z TDESC,ZTDT H,ZTIO,ZTU CI,ZTCPU,Z TPRI,ZTSAV E,ZTKIL,ZT SYNC,ZTSK
  26207   "RTN","VPR YFRP",84,0 )
  26208    S ZTRTN=" GET4LST^VP RYFRP",ZTI O="",ZTSAV E("VPRYNAM E")="",ZTD TH=VPRDTH
  26209   "RTN","VPR YFRP",85,0 )
  26210    S ZTDESC= "Measure e xtract siz es for pat ients with  visits in  a month"
  26211   "RTN","VPR YFRP",86,0 )
  26212    D ^%ZTLOA D I '$G(ZT SK) W !,"E rror queui ng "_VPRYN AME
  26213   "RTN","VPR YFRP",87,0 )
  26214    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME)="Ta sk #"_ZTSK
  26215   "RTN","VPR YFRP",88,0 )
  26216    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"sta tus")="Que ued"
  26217   "RTN","VPR YFRP",89,0 )
  26218    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"cou nt")=0
  26219   "RTN","VPR YFRP",90,0 )
  26220    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"res ult")=""
  26221   "RTN","VPR YFRP",91,0 )
  26222    W !,VPRYN AME,", tas k #"_ZTSK_ " queued f or "_$$HTE ^XLFDT(VPR DTH)
  26223   "RTN","VPR YFRP",92,0 )
  26224    Q
  26225   "RTN","VPR YFRP",93,0 )
  26226   GET4LST ;  Extract da ta for a l ist & meas ure size
  26227   "RTN","VPR YFRP",94,0 )
  26228    ; expects  VPRYNAME  from GET4A LL or XTRL ST or Queu ed Job
  26229   "RTN","VPR YFRP",95,0 )
  26230    N VPRYDFN ,VPRYH,VPR YDOMS,PTSI ZE,VPRFZTS K
  26231   "RTN","VPR YFRP",96,0 )
  26232    D BLDDOMS (.VPRYDOMS )
  26233   "RTN","VPR YFRP",97,0 )
  26234    S VPRYH=$ H
  26235   "RTN","VPR YFRP",98,0 )
  26236    S VPRFZTS K=$G(ZTSK)  ; if task ed, VPRDJ  expects VP RFZTSK to  be task
  26237   "RTN","VPR YFRP",99,0 )
  26238    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"sta tus")="Sta rted"
  26239   "RTN","VPR YFRP",100, 0)
  26240    S VPRYDFN =0 F  S VP RYDFN=$O(^ XTMP("VPRY FRP","MONT H",VPRYNAM E,VPRYDFN) ) Q:'VPRYD FN  D
  26241   "RTN","VPR YFRP",101, 0)
  26242    . S PTSIZ E=$$SIZEPT (VPRYDFN)
  26243   "RTN","VPR YFRP",102, 0)
  26244    . S ^XTMP ("VPRYFRP" ,"MONTH",V PRYNAME,VP RYDFN)=PTS IZE
  26245   "RTN","VPR YFRP",103, 0)
  26246    . D TOPSI ZE(VPRYDFN ,"",PTSIZE ,"PatientS ize")
  26247   "RTN","VPR YFRP",104, 0)
  26248    S ^XTMP(" VPRYFRP"," MONTH",VPR YNAME)=$$H DIFF^XLFDT ($H,VPRYH, 2)
  26249   "RTN","VPR YFRP",105, 0)
  26250    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"sta tus")="Fin ished"
  26251   "RTN","VPR YFRP",106, 0)
  26252    Q
  26253   "RTN","VPR YFRP",107, 0)
  26254   SIZEPT(VPR YDFN) ; Ex tract data  for a pat ient and r eturn size
  26255   "RTN","VPR YFRP",108, 0)
  26256    I '$D(ZTQ UEUED) W " ."
  26257   "RTN","VPR YFRP",109, 0)
  26258    N VPRYSIZ E,VPRYDOM, VPRBATCH,V PRYET,DOMS IZE
  26259   "RTN","VPR YFRP",110, 0)
  26260    S VPRYSIZ E=0,VPRBAT CH="VPRYFR P"
  26261   "RTN","VPR YFRP",111, 0)
  26262    S VPRYDOM ="" F  S V PRYDOM=$O( VPRYDOMS(V PRYDOM)) Q :VPRYDOM=" "  D
  26263   "RTN","VPR YFRP",112, 0)
  26264    . D CLEAN DOM
  26265   "RTN","VPR YFRP",113, 0)
  26266    . S VPRYE T=$H
  26267   "RTN","VPR YFRP",114, 0)
  26268    . S DOMSI ZE=$$SIZED OM(VPRYDFN ,VPRYDOM)
  26269   "RTN","VPR YFRP",115, 0)
  26270    . S VPRYE T=$$HDIFF^ XLFDT($H,V PRYET,2)
  26271   "RTN","VPR YFRP",116, 0)
  26272    . S VPRYS IZE=VPRYSI ZE+DOMSIZE
  26273   "RTN","VPR YFRP",117, 0)
  26274    . D TOPSI ZE(VPRYDFN ,VPRYDOM,V PRYET,"Ext ractTime")
  26275   "RTN","VPR YFRP",118, 0)
  26276    . D TOPSI ZE(VPRYDFN ,VPRYDOM,D OMSIZE,"Ex tractSize" )
  26277   "RTN","VPR YFRP",119, 0)
  26278    Q VPRYSIZ E
  26279   "RTN","VPR YFRP",120, 0)
  26280    ;
  26281   "RTN","VPR YFRP",121, 0)
  26282   SIZEDOM(DF N,DOMAIN)  ; Extract  1 domain a nd return  size
  26283   "RTN","VPR YFRP",122, 0)
  26284    N $ESTACK ,$ETRAP S  $ETRAP="D  EXTERR^VPR YFRP"
  26285   "RTN","VPR YFRP",123, 0)
  26286    Q:$G(^XTM P("VPRYFRP ","STOP")) =1 0
  26287   "RTN","VPR YFRP",124, 0)
  26288    N FILTER, RSLT,SIZE
  26289   "RTN","VPR YFRP",125, 0)
  26290    S FILTER( "patientId ")=DFN
  26291   "RTN","VPR YFRP",126, 0)
  26292    S FILTER( "domain")= DOMAIN
  26293   "RTN","VPR YFRP",127, 0)
  26294    D GET^VPR DJ(.RSLT,. FILTER)
  26295   "RTN","VPR YFRP",128, 0)
  26296    S SIZE=$$ SIZEREF(RS LT)
  26297   "RTN","VPR YFRP",129, 0)
  26298    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"cou nt")=$G(^X TMP("VPRYF RP","TASKS ",VPRYNAME ,"count")) +1
  26299   "RTN","VPR YFRP",130, 0)
  26300    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"res ult")=RSLT
  26301   "RTN","VPR YFRP",131, 0)
  26302    K @RSLT ; ^XTMP("VPR YFRP",VPRY DFN,VPRYDO M)
  26303   "RTN","VPR YFRP",132, 0)
  26304    Q SIZE
  26305   "RTN","VPR YFRP",133, 0)
  26306    ;
  26307   "RTN","VPR YFRP",134, 0)
  26308   CLEANDOM ;  Clean up  partition  for domain  extract
  26309   "RTN","VPR YFRP",135, 0)
  26310    N X
  26311   "RTN","VPR YFRP",136, 0)
  26312    K ^TMP("V PRY",$J)
  26313   "RTN","VPR YFRP",137, 0)
  26314    F X="VPRY NAME","VPR YDOMS","VP RYDFN","VP RYDOM","VP RYSIZE","V PRYH","VPR BATCH","VP RFZTSK" M  ^TMP("VPRY ",$J,X)=@X
  26315   "RTN","VPR YFRP",138, 0)
  26316    D KILL^XU SCLEAN
  26317   "RTN","VPR YFRP",139, 0)
  26318    F X="VPRY NAME","VPR YDOMS","VP RYDFN","VP RYDOM","VP RYSIZE","V PRYH","VPR BATCH","VP RFZTSK" M  @X=^TMP("V PRY",$J,X)
  26319   "RTN","VPR YFRP",140, 0)
  26320    K ^TMP("V PRY",$J)
  26321   "RTN","VPR YFRP",141, 0)
  26322    Q
  26323   "RTN","VPR YFRP",142, 0)
  26324   TOPSIZE(DF N,DOMAIN,S IZE,MEASUR E) ; Recor d the high est measur es (time,  size)
  26325   "RTN","VPR YFRP",143, 0)
  26326    Q:SIZE<1
  26327   "RTN","VPR YFRP",144, 0)
  26328    N LOW,NUM ,MAX,DFNS, DOMS
  26329   "RTN","VPR YFRP",145, 0)
  26330    S MAX=30
  26331   "RTN","VPR YFRP",146, 0)
  26332    S LOW=+$O (^XTMP("VP RYFRP","ME ASURE",MEA SURE,"")), NUM=$G(^XT MP("VPRYFR P","MEASUR E",MEASURE ),0)
  26333   "RTN","VPR YFRP",147, 0)
  26334    I SIZE>LO W S ^XTMP( "VPRYFRP", "MEASURE", MEASURE,SI ZE,DFN,$S( $L(DOMAIN) :DOMAIN,1: 0))="",NUM =NUM+1
  26335   "RTN","VPR YFRP",148, 0)
  26336    I NUM>MAX  D
  26337   "RTN","VPR YFRP",149, 0)
  26338    . S LOW=" " F  S LOW =$O(^XTMP( "VPRYFRP", "MEASURE", MEASURE,LO W)) Q:'LOW   D  Q:NUM '>MAX
  26339   "RTN","VPR YFRP",150, 0)
  26340    . . S DFN S="" F  S  DFNS=$O(^X TMP("VPRYF RP","MEASU RE",MEASUR E,LOW,DFNS )) Q:'DFNS   D  Q:NUM '>MAX
  26341   "RTN","VPR YFRP",151, 0)
  26342    . . . S D OMS="" F   S DOMS=$O( ^XTMP("VPR YFRP","MEA SURE",MEAS URE,LOW,DF NS,DOMS))  Q:DOMS=""   D  Q:NUM' >MAX
  26343   "RTN","VPR YFRP",152, 0)
  26344    . . . . S  NUM=NUM-1  K ^XTMP(" VPRYFRP"," MEASURE",M EASURE,LOW ,DFNS,DOMS )
  26345   "RTN","VPR YFRP",153, 0)
  26346    S ^XTMP(" VPRYFRP"," MEASURE",M EASURE)=NU M
  26347   "RTN","VPR YFRP",154, 0)
  26348    Q
  26349   "RTN","VPR YFRP",155, 0)
  26350   EXTERR ; C ome here i n case of  error duri ng extract
  26351   "RTN","VPR YFRP",156, 0)
  26352    S ^XTMP(" VPRYFRP"," ERRORS",$G (VPRYDFN,0 ),$G(VPRYD OM,0))=$H
  26353   "RTN","VPR YFRP",157, 0)
  26354    I $D(ZTQU EUED),$L($ G(VPRYDFN) ),$L($G(VP RYDOM)) K  ^XTMP("VPR YFRP",VPRY DFN,VPRYDO M)
  26355   "RTN","VPR YFRP",158, 0)
  26356    D ^%ZTER
  26357   "RTN","VPR YFRP",159, 0)
  26358    G UNWIND^ %ZTER
  26359   "RTN","VPR YFRP",160, 0)
  26360    ;
  26361   "RTN","VPR YFRP",161, 0)
  26362   SIZEREF(RE F) ; Retur n size of  date in re f
  26363   "RTN","VPR YFRP",162, 0)
  26364    N X,SIZE, ROOT,LROOT
  26365   "RTN","VPR YFRP",163, 0)
  26366    S SIZE=0
  26367   "RTN","VPR YFRP",164, 0)
  26368    S ROOT=$R E($P($RE(R EF),")",2, 99)),LROOT =$L(ROOT)
  26369   "RTN","VPR YFRP",165, 0)
  26370    S X=REF F   S X=$Q(@ X) Q:$E(X, 1,LROOT)'= ROOT  S SI ZE=SIZE+$L (@X)
  26371   "RTN","VPR YFRP",166, 0)
  26372    Q SIZE
  26373   "RTN","VPR YFRP",167, 0)
  26374    ;
  26375   "RTN","VPR YFRP",168, 0)
  26376   SHOWCNT ;  Show count s of uniqu e patients  by month
  26377   "RTN","VPR YFRP",169, 0)
  26378    N NAME,IM ONTH,CNT,D FN,TOTAL
  26379   "RTN","VPR YFRP",170, 0)
  26380    S TOTAL=0
  26381   "RTN","VPR YFRP",171, 0)
  26382    S IMONTH= 0 F  S IMO NTH=$O(^XT MP("VPRYFR P","SEQUEN CE",IMONTH )) Q:'IMON TH  D
  26383   "RTN","VPR YFRP",172, 0)
  26384    . S NAME= ^XTMP("VPR YFRP","SEQ UENCE",IMO NTH)
  26385   "RTN","VPR YFRP",173, 0)
  26386    . S CNT=0
  26387   "RTN","VPR YFRP",174, 0)
  26388    . S DFN=0  F  S DFN= $O(^XTMP(" VPRYFRP"," MONTH",NAM E,DFN)) Q: 'DFN  S CN T=CNT+1
  26389   "RTN","VPR YFRP",175, 0)
  26390    . W !,NAM E,?12,CNT, " patients "
  26391   "RTN","VPR YFRP",176, 0)
  26392    . S ^XTMP ("VPRYFRP" ,"count",N AME)=CNT
  26393   "RTN","VPR YFRP",177, 0)
  26394    . S TOTAL =TOTAL+CNT
  26395   "RTN","VPR YFRP",178, 0)
  26396    W !!,"Tot al",?11,TO TAL," pati ents"
  26397   "RTN","VPR YFRP",179, 0)
  26398    Q
  26399   "RTN","VPR YFRP",180, 0)
  26400   SHOWSIZE ;  Show extr act sizes  by month
  26401   "RTN","VPR YFRP",181, 0)
  26402    N NAME,IM ONTH,SIZE, DFN,SECS
  26403   "RTN","VPR YFRP",182, 0)
  26404    S IMONTH= 0 F  S IMO NTH=$O(^XT MP("VPRYFR P","SEQUEN CE",IMONTH )) Q:'IMON TH  D
  26405   "RTN","VPR YFRP",183, 0)
  26406    . S NAME= ^XTMP("VPR YFRP","SEQ UENCE",IMO NTH)
  26407   "RTN","VPR YFRP",184, 0)
  26408    . S SIZE= 0
  26409   "RTN","VPR YFRP",185, 0)
  26410    . S DFN=0  F  S DFN= $O(^XTMP(" VPRYFRP"," MONTH",NAM E,DFN)) Q: 'DFN  S SI ZE=SIZE+^X TMP("VPRYF RP","MONTH ",NAME,DFN )
  26411   "RTN","VPR YFRP",186, 0)
  26412    . S SECS= $G(^XTMP(" VPRYFRP"," MONTH",NAM E),0)
  26413   "RTN","VPR YFRP",187, 0)
  26414    . W !,NAM E,?12,SIZE ," bytes", ?30,SECS\6 0," minute s ",SECS#6 0," second s"
  26415   "RTN","VPR YFRP",188, 0)
  26416    Q
  26417   "RTN","VPR YFRP",189, 0)
  26418   SHOWSTS ;  Show task  status and  errors
  26419   "RTN","VPR YFRP",190, 0)
  26420    N DFN,DOM AIN,X
  26421   "RTN","VPR YFRP",191, 0)
  26422    S X="" F   S X=$O(^X TMP("VPRYF RP","TASKS ",X)) Q:X= ""  D
  26423   "RTN","VPR YFRP",192, 0)
  26424    . W !,X
  26425   "RTN","VPR YFRP",193, 0)
  26426    . W ?9,$G (^XTMP("VP RYFRP","TA SKS",X))
  26427   "RTN","VPR YFRP",194, 0)
  26428    . W ?25,$ G(^XTMP("V PRYFRP","T ASKS",X,"s tatus"))
  26429   "RTN","VPR YFRP",195, 0)
  26430    . W ?35,$ G(^XTMP("V PRYFRP","T ASKS",X,"c ount"))
  26431   "RTN","VPR YFRP",196, 0)
  26432    . ; W ?40 ,$G(^XTMP( "VPRYFRP", "TASKS",X, "result"))
  26433   "RTN","VPR YFRP",197, 0)
  26434    ;
  26435   "RTN","VPR YFRP",198, 0)
  26436    W !,"Erro rs (if any ) --"
  26437   "RTN","VPR YFRP",199, 0)
  26438    S DFN=""  F  S DFN=$ O(^XTMP("V PRYFRP","E RRORS",DFN )) Q:'DFN   D
  26439   "RTN","VPR YFRP",200, 0)
  26440    . S DOMAI N="" F  S  DOMAIN=$O( ^XTMP("VPR YFRP","ERR ORS",DFN,D OMAIN)) Q: DOMAIN=""   D
  26441   "RTN","VPR YFRP",201, 0)
  26442    . . W !,D FN,?20,DOM AIN,?45,$$ HTE^XLFDT( ^XTMP("VPR YFRP","ERR ORS",DFN,D OMAIN))
  26443   "RTN","VPR YFRP",202, 0)
  26444    Q
  26445   "RTN","VPR YFRP",203, 0)
  26446   SHOWTOP ;  Show large st sizes a nd times
  26447   "RTN","VPR YFRP",204, 0)
  26448    N MEASURE ,SIZE,DFN, DOMAIN,I
  26449   "RTN","VPR YFRP",205, 0)
  26450    F MEASURE ="PatientS ize","Extr actSize"," ExtractTim e" D
  26451   "RTN","VPR YFRP",206, 0)
  26452    . W !,MEA SURE," " F  I=1:1:24  W "-"
  26453   "RTN","VPR YFRP",207, 0)
  26454    . W !,"DF N",?15,$S( MEASURE["T ime":"Seco nds",1:"By tes")
  26455   "RTN","VPR YFRP",208, 0)
  26456    . I MEASU RE'="Patie ntSize" W  ?30,"Domai n"
  26457   "RTN","VPR YFRP",209, 0)
  26458    . S SIZE= 0 F  S SIZ E=$O(^XTMP ("VPRYFRP" ,"MEASURE" ,MEASURE,S IZE)) Q:'S IZE  D
  26459   "RTN","VPR YFRP",210, 0)
  26460    . . S DFN =0 F  S DF N=$O(^XTMP ("VPRYFRP" ,"MEASURE" ,MEASURE,S IZE,DFN))  Q:'DFN  D
  26461   "RTN","VPR YFRP",211, 0)
  26462    . . . S D OMAIN="" F   S DOMAIN =$O(^XTMP( "VPRYFRP", "MEASURE", MEASURE,SI ZE,DFN,DOM AIN)) Q:DO MAIN=""  D
  26463   "RTN","VPR YFRP",212, 0)
  26464    . . . . W  !,DFN,?15 ,SIZE
  26465   "RTN","VPR YFRP",213, 0)
  26466    . . . . I  DOMAIN'=0  W ?30,DOM AIN
  26467   "RTN","VPR YFRP",214, 0)
  26468    . W !
  26469   "RTN","VPR YFRP",215, 0)
  26470    Q
  26471   "RTN","VPR YFRP",216, 0)
  26472   EXTMTH(DT)  ; Return  external M mmYYYY for mat
  26473   "RTN","VPR YFRP",217, 0)
  26474    N M,Y
  26475   "RTN","VPR YFRP",218, 0)
  26476    S M=$E(DT ,4,5),Y=$E (DT,1,3)
  26477   "RTN","VPR YFRP",219, 0)
  26478    S Y=Y+170 0
  26479   "RTN","VPR YFRP",220, 0)
  26480    S M=$P($P ($T(MNAMES ),";;",2,9 9),";",M)
  26481   "RTN","VPR YFRP",221, 0)
  26482    Q M_Y
  26483   "RTN","VPR YFRP",222, 0)
  26484    ;
  26485   "RTN","VPR YFRP",223, 0)
  26486   INCMTH(DT)  ; Return  incremente d month
  26487   "RTN","VPR YFRP",224, 0)
  26488    N M,Y
  26489   "RTN","VPR YFRP",225, 0)
  26490    S M=$E(DT ,4,5),Y=$E (DT,1,3)
  26491   "RTN","VPR YFRP",226, 0)
  26492    S M=M+1
  26493   "RTN","VPR YFRP",227, 0)
  26494    I M>12 S  M=1,Y=Y+1
  26495   "RTN","VPR YFRP",228, 0)
  26496    I $L(Y)'= 3 W !,"err or in year " Q 99999
  26497   "RTN","VPR YFRP",229, 0)
  26498    S M="00"_ M,M=$E(M,$ L(M)-1,$L( M))
  26499   "RTN","VPR YFRP",230, 0)
  26500    Q Y_M
  26501   "RTN","VPR YFRP",231, 0)
  26502    ;
  26503   "RTN","VPR YFRP",232, 0)
  26504   PRMTMTHS(B EG,END) ;  prompt for  the month  range
  26505   "RTN","VPR YFRP",233, 0)
  26506    N DIR,DTO UT,DUOUT,D IRUT,DIROU T,X,Y,DA,F ROMSYS,TOS YS
  26507   "RTN","VPR YFRP",234, 0)
  26508    S DIR(0)= "D^::EMP", DIR("A")=" Beginning  Month",DIR ("?")="Ent er the ear liest mont h of visit s to evalu ate."
  26509   "RTN","VPR YFRP",235, 0)
  26510    D ^DIR I  $D(DIRUT)  S BEG="",E ND="" Q
  26511   "RTN","VPR YFRP",236, 0)
  26512    S BEG=Y
  26513   "RTN","VPR YFRP",237, 0)
  26514    S DIR(0)= "D^::EMP", DIR("A")=" Ending Mon th",DIR("? ")="Enter  the latest  month of  visits to  evaluate."
  26515   "RTN","VPR YFRP",238, 0)
  26516    D ^DIR I  $D(DIRUT)  S BEG="",E ND="" Q
  26517   "RTN","VPR YFRP",239, 0)
  26518    S END=Y
  26519   "RTN","VPR YFRP",240, 0)
  26520    W !,"Sear ching visi ts from ", $$FMTE^XLF DT(BEG),"  through ", $$FMTE^XLF DT(END),".   Continue ? NO// " R  X:300
  26521   "RTN","VPR YFRP",241, 0)
  26522    I $E($$UP ^XLFSTR(X) )'="Y" S B EG="",END= "" Q
  26523   "RTN","VPR YFRP",242, 0)
  26524    S BEG=$E( BEG,1,5),E ND=$E(END, 1,5)
  26525   "RTN","VPR YFRP",243, 0)
  26526    Q
  26527   "RTN","VPR YFRP",244, 0)
  26528   BLDDOMS(DO MAINS) ; B uild a lis t of domai ns
  26529   "RTN","VPR YFRP",245, 0)
  26530    N X
  26531   "RTN","VPR YFRP",246, 0)
  26532    F I=1:1 S  X=$P($T(D OMAINS+I), ";;",2) Q: X="zzzzz"   S DOMAINS (X)=""
  26533   "RTN","VPR YFRP",247, 0)
  26534    Q
  26535   "RTN","VPR YFRP",248, 0)
  26536   MNAMES ;;J an;Feb;Mar ;Apr;May;J un;Jul;Aug ;Sep;Oct;N ov;Dec
  26537   "RTN","VPR YFRP",249, 0)
  26538    ;
  26539   "RTN","VPR YFRP",250, 0)
  26540   DOMAINS ;
  26541   "RTN","VPR YFRP",251, 0)
  26542    ;;allergy
  26543   "RTN","VPR YFRP",252, 0)
  26544    ;;auxilia ry
  26545   "RTN","VPR YFRP",253, 0)
  26546    ;;appoint ment
  26547   "RTN","VPR YFRP",254, 0)
  26548    ;;diagnos is
  26549   "RTN","VPR YFRP",255, 0)
  26550    ;;documen t
  26551   "RTN","VPR YFRP",256, 0)
  26552    ;;factor
  26553   "RTN","VPR YFRP",257, 0)
  26554    ;;immuniz ation
  26555   "RTN","VPR YFRP",258, 0)
  26556    ;;lab
  26557   "RTN","VPR YFRP",259, 0)
  26558    ;;med
  26559   "RTN","VPR YFRP",260, 0)
  26560    ;;obs
  26561   "RTN","VPR YFRP",261, 0)
  26562    ;;order
  26563   "RTN","VPR YFRP",262, 0)
  26564    ;;problem
  26565   "RTN","VPR YFRP",263, 0)
  26566    ;;procedu re
  26567   "RTN","VPR YFRP",264, 0)
  26568    ;;consult
  26569   "RTN","VPR YFRP",265, 0)
  26570    ;;image
  26571   "RTN","VPR YFRP",266, 0)
  26572    ;;surgery
  26573   "RTN","VPR YFRP",267, 0)
  26574    ;;task
  26575   "RTN","VPR YFRP",268, 0)
  26576    ;;visit
  26577   "RTN","VPR YFRP",269, 0)
  26578    ;;vital
  26579   "RTN","VPR YFRP",270, 0)
  26580    ;;mh
  26581   "RTN","VPR YFRP",271, 0)
  26582    ;;ptf
  26583   "RTN","VPR YFRP",272, 0)
  26584    ;;exam
  26585   "RTN","VPR YFRP",273, 0)
  26586    ;;cpt
  26587   "RTN","VPR YFRP",274, 0)
  26588    ;;educati on
  26589   "RTN","VPR YFRP",275, 0)
  26590    ;;pov
  26591   "RTN","VPR YFRP",276, 0)
  26592    ;;skin
  26593   "RTN","VPR YFRP",277, 0)
  26594    ;;treatme nt
  26595   "RTN","VPR YFRP",278, 0)
  26596    ;;roadtri p
  26597   "RTN","VPR YFRP",279, 0)
  26598    ;;zzzzz
  26599   "RTN","VPR YPAR")
  26600   0^67^B3971 880
  26601   "RTN","VPR YPAR",1,0)
  26602   VPRYPAR ;S LC/KCM --  Modify Par ameters
  26603   "RTN","VPR YPAR",2,0)
  26604    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 205
  26605   "RTN","VPR YPAR",3,0)
  26606    ;
  26607   "RTN","VPR YPAR",4,0)
  26608   PARLOOP ;  Loop thru  parameter
  26609   "RTN","VPR YPAR",5,0)
  26610    N PAR,ENT ,INST,IEN
  26611   "RTN","VPR YPAR",6,0)
  26612    S PAR=$O( ^XTV(8989. 51,"B","VP R PARAMETE RS",0))
  26613   "RTN","VPR YPAR",7,0)
  26614    S ENT=""  F  S ENT=$ O(^XTV(898 9.5,"AC",P AR,ENT)) Q :ENT=""  D
  26615   "RTN","VPR YPAR",8,0)
  26616    . S INST= "" F  S IN ST=$O(^XTV (8989.5,"A C",PAR,ENT ,INST)) Q: INST=""  D
  26617   "RTN","VPR YPAR",9,0)
  26618    . . S IEN =0 F  S IE N=$O(^XTV( 8989.5,"AC ",PAR,ENT, INST,IEN))  Q:IEN=""   D
  26619   "RTN","VPR YPAR",10,0 )
  26620    . . . I $ P(^XTV(898 9.5,IEN,0) ,":",6)'=" VPR USER P REF" Q
  26621   "RTN","VPR YPAR",11,0 )
  26622    . . . D P ULLPID(IEN )
  26623   "RTN","VPR YPAR",12,0 )
  26624    Q
  26625   "RTN","VPR YPAR",13,0 )
  26626   PULLPID(IE N) ; Remov e PID entr ies
  26627   "RTN","VPR YPAR",14,0 )
  26628    N JSON,WP ,OBJ,ERR,I
  26629   "RTN","VPR YPAR",15,0 )
  26630    S I=0 F   S I=$O(^XT V(8989.5,I EN,2,I)) Q :'I  S JSO N(I)=^XTV( 8989.5,IEN ,2,I,0)
  26631   "RTN","VPR YPAR",16,0 )
  26632    D DECODE^ VPRJSON("J SON","OBJ" ,"ERR")
  26633   "RTN","VPR YPAR",17,0 )
  26634    I $D(ERR)  W !,"Erro r decoding  ",IEN Q
  26635   "RTN","VPR YPAR",18,0 )
  26636    I '$D(OBJ ("cpe.cont ext.patien t")) Q
  26637   "RTN","VPR YPAR",19,0 )
  26638    ;
  26639   "RTN","VPR YPAR",20,0 )
  26640    K OBJ("cp e.context. patient"), JSON
  26641   "RTN","VPR YPAR",21,0 )
  26642    D ENCODE^ VPRJSON("O BJ","JSON" ,"ERR")
  26643   "RTN","VPR YPAR",22,0 )
  26644    I $D(ERR)  W !,"Erro r encoding  ",IEN
  26645   "RTN","VPR YPAR",23,0 )
  26646    ;
  26647   "RTN","VPR YPAR",24,0 )
  26648    W !,"Upda ting ",^XT V(8989.5,I EN,0)
  26649   "RTN","VPR YPAR",25,0 )
  26650    S I=0 F   S I=$O(JSO N(I)) Q:'I   S WP(I,0 )=JSON(I)
  26651   "RTN","VPR YPAR",26,0 )
  26652    I $D(WP)  D WP^DIE(8 989.5,IEN_ ",",2,""," WP","ERR")
  26653   "RTN","VPR YPAR",27,0 )
  26654    I $D(DIER R) W !,"Sa ve failed  for WP: ", IEN,!
  26655   "RTN","VPR YPAR",28,0 )
  26656    D CLEAN^D ILF
  26657   "RTN","VPR YPAR",29,0 )
  26658    Q
  26659   "RTN","VPR YPAR",30,0 )
  26660   SHOWPAR ;  Show value s for para meters
  26661   "RTN","VPR YPAR",31,0 )
  26662    N PARAM,I EN
  26663   "RTN","VPR YPAR",32,0 )
  26664    S PARAM=$ O(^XTV(898 9.51,"B"," VPR PARAME TERS",0))
  26665   "RTN","VPR YPAR",33,0 )
  26666    W !,"Para m:",PARAM
  26667   "RTN","VPR YPAR",34,0 )
  26668    S IEN=0 F   S IEN=$O (^XTV(8989 .5,IEN)) Q :'IEN  D
  26669   "RTN","VPR YPAR",35,0 )
  26670    . I $P(^X TV(8989.5, IEN,0),"^" ,2)'=PARAM  Q
  26671   "RTN","VPR YPAR",36,0 )
  26672    . S INST= $P(^XTV(89 89.5,IEN,0 ),"^",3)
  26673   "RTN","VPR YPAR",37,0 )
  26674    . I $P(IN ST,":",6)' ="VPR USER  PREF" Q
  26675   "RTN","VPR YPAR",38,0 )
  26676    . N JSON, OBJ,ERR,X
  26677   "RTN","VPR YPAR",39,0 )
  26678    . S I=0 F   S I=$O(^ XTV(8989.5 ,IEN,2,I))  Q:'I  S J SON(I)=^XT V(8989.5,I EN,2,I,0)
  26679   "RTN","VPR YPAR",40,0 )
  26680    . D DECOD E^VPRJSON( "JSON","OB J","ERR")
  26681   "RTN","VPR YPAR",41,0 )
  26682    . W !!,IN ST,"  ("_I EN_") ---- ---------- ------"
  26683   "RTN","VPR YPAR",42,0 )
  26684    . S X=""  F  S X=$O( OBJ(X)) Q: X=""  W !, X," = ",OB J(X)
  26685   "RTN","VPR YPAR",43,0 )
  26686    Q
  26687   "SEC","^DI C",560,560 ,0,"AUDIT" )
  26688   @
  26689   "SEC","^DI C",560,560 ,0,"DD")
  26690   @
  26691   "SEC","^DI C",560,560 ,0,"DEL")
  26692   @
  26693   "SEC","^DI C",560,560 ,0,"LAYGO" )
  26694   @
  26695   "SEC","^DI C",560,560 ,0,"RD")
  26696   @
  26697   "SEC","^DI C",560,560 ,0,"WR")
  26698   @
  26699   "SEC","^DI C",560.1,5 60.1,0,"AU DIT")
  26700   @
  26701   "SEC","^DI C",560.1,5 60.1,0,"DD ")
  26702   @
  26703   "SEC","^DI C",560.1,5 60.1,0,"DE L")
  26704   @
  26705   "SEC","^DI C",560.1,5 60.1,0,"LA YGO")
  26706   @
  26707   "SEC","^DI C",560.1,5 60.1,0,"RD ")
  26708   @
  26709   "SEC","^DI C",560.1,5 60.1,0,"WR ")
  26710   @
  26711   "SEC","^DI C",560.11, 560.11,0," AUDIT")
  26712   @
  26713   "SEC","^DI C",560.11, 560.11,0," DD")
  26714   @
  26715   "SEC","^DI C",560.11, 560.11,0," DEL")
  26716   @
  26717   "SEC","^DI C",560.11, 560.11,0," LAYGO")
  26718   @
  26719   "SEC","^DI C",560.11, 560.11,0," RD")
  26720   @
  26721   "SEC","^DI C",560.11, 560.11,0," WR")
  26722   @
  26723   "SEC","^DI C",561,561 ,0,"AUDIT" )
  26724   @
  26725   "SEC","^DI C",561,561 ,0,"DD")
  26726   @
  26727   "SEC","^DI C",561,561 ,0,"DEL")
  26728   @
  26729   "SEC","^DI C",561,561 ,0,"LAYGO" )
  26730   #
  26731   "SEC","^DI C",561,561 ,0,"RD")
  26732   #
  26733   "SEC","^DI C",561,561 ,0,"WR")
  26734   #
  26735   "SEC","^DI C",561.2,5 61.2,0,"AU DIT")
  26736   @
  26737   "SEC","^DI C",561.2,5 61.2,0,"DD ")
  26738   @
  26739   "SEC","^DI C",561.2,5 61.2,0,"DE L")
  26740   @
  26741   "SEC","^DI C",561.2,5 61.2,0,"LA YGO")
  26742   @
  26743   "SEC","^DI C",561.2,5 61.2,0,"RD ")
  26744   @
  26745   "SEC","^DI C",561.2,5 61.2,0,"WR ")
  26746   @
  26747   "VER")
  26748   8.0^22.0
  26749   "^DD",100. 98,100.98, 0)
  26750   FIELD^^4^5
  26751   "^DD",100. 98,100.98, 0,"DDA")
  26752   N
  26753   "^DD",100. 98,100.98, 0,"DT")
  26754   2960814
  26755   "^DD",100. 98,100.98, 0,"IX","AD ",100.981, .01)
  26756  
  26757   "^DD",100. 98,100.98, 0,"IX","B" ,100.98,.0 1)
  26758  
  26759   "^DD",100. 98,100.98, 0,"IX","B" ,100.98,3)
  26760  
  26761   "^DD",100. 98,100.98, 0,"NM","DI SPLAY GROU P")
  26762  
  26763   "^DD",100. 98,100.98, 0,"PT",100 ,23)
  26764  
  26765   "^DD",100. 98,100.98, 0,"PT",100 .65,.01)
  26766  
  26767   "^DD",100. 98,100.98, 0,"PT",100 .981,.01)
  26768  
  26769   "^DD",100. 98,100.98, 0,"PT",100 .995,1.1)
  26770  
  26771   "^DD",100. 98,100.98, 0,"PT",101 .41,5)
  26772  
  26773   "^DD",100. 98,100.98, 0,"PT",101 .43,5)
  26774  
  26775   "^DD",100. 98,100.98, 0,"PT",123 .5,123.01)
  26776  
  26777   "^DD",100. 98,100.98, 0,"VRPK")
  26778   ORDER ENTR Y/RESULTS  REPORTING
  26779   "^DD",100. 98,100.98, .01,0)
  26780   NAME^RF^^0 ;1^K:X[""" "!($A(X)=4 5) X I $D( X) K:$L(X) >30!($L(X) <3)!'(X'?1 P.E) X
  26781   "^DD",100. 98,100.98, .01,1,0)
  26782   ^.1^^-1
  26783   "^DD",100. 98,100.98, .01,1,1,0)
  26784   100.98^B
  26785   "^DD",100. 98,100.98, .01,1,1,1)
  26786   S ^ORD(100 .98,"B",$E (X,1,30),D A)=""
  26787   "^DD",100. 98,100.98, .01,1,1,2)
  26788   K ^ORD(100 .98,"B",$E (X,1,30),D A)
  26789   "^DD",100. 98,100.98, .01,3)
  26790   ANSWER MUS T BE 3-30  CHARACTERS  IN LENGTH
  26791   "^DD",100. 98,100.98, .01,4)
  26792  
  26793   "^DD",100. 98,100.98, .01,21,0)
  26794   ^^3^3^2920 224^^^^
  26795   "^DD",100. 98,100.98, .01,21,1,0 )
  26796   This is th e name of  the displa y group fo r a partic ular kind  of order.
  26797   "^DD",100. 98,100.98, .01,21,2,0 )
  26798   The displa y group ge nerally co rresponds  to a hospi tal servic e or part
  26799   "^DD",100. 98,100.98, .01,21,3,0 )
  26800   of a servi ce.
  26801   "^DD",100. 98,100.98, .01,"DT")
  26802   2890131
  26803   "^DD",100. 98,100.98, 1,0)
  26804   MEMBER^100 .981P^^1;0
  26805   "^DD",100. 98,100.98, 1,3)
  26806   Enter a di splay grou p as a mem ber.
  26807   "^DD",100. 98,100.98, 1,21,0)
  26808   ^^3^3^2920 224^^^^
  26809   "^DD",100. 98,100.98, 1,21,1,0)
  26810   This is a  list of sp ecific dis play group s that `be long' to t he display
  26811   "^DD",100. 98,100.98, 1,21,2,0)
  26812   group list ed in the  NAME field .  (This i s similar  to menu it ems in the
  26813   "^DD",100. 98,100.98, 1,21,3,0)
  26814   OPTION Fil e.)
  26815   "^DD",100. 98,100.98, 2,0)
  26816   MIXED NAME ^F^^0;2^K: $L(X)>30!( $L(X)<1) X
  26817   "^DD",100. 98,100.98, 2,3)
  26818   Answer mus t be 1-30  characters  in length .
  26819   "^DD",100. 98,100.98, 2,21,0)
  26820   ^^3^3^2960 617^
  26821   "^DD",100. 98,100.98, 2,21,1,0)
  26822   This field  contains  a mixed ca se name fo r the disp lay group.   The name  
  26823   "^DD",100. 98,100.98, 2,21,2,0)
  26824   should be  as short a s possible  without b eing obscu re.  This  name is 
  26825   "^DD",100. 98,100.98, 2,21,3,0)
  26826   primarily  intended f or use in  the window s display  of orders.
  26827   "^DD",100. 98,100.98, 2,"DT")
  26828   2960617
  26829   "^DD",100. 98,100.98, 3,0)
  26830   SHORT NAME ^F^^0;3^K: X[""""!($A (X)=45) X  I $D(X) K: $L(X)>5!($ L(X)<1) X
  26831   "^DD",100. 98,100.98, 3,1,0)
  26832   ^.1
  26833   "^DD",100. 98,100.98, 3,1,1,0)
  26834   100.98^B^M NEMONIC
  26835   "^DD",100. 98,100.98, 3,1,1,1)
  26836   S:'$D(^ORD (100.98,"B ",$E(X,1,3 0),DA)) ^( DA)=1
  26837   "^DD",100. 98,100.98, 3,1,1,2)
  26838   I $D(^ORD( 100.98,"B" ,$E(X,1,30 ),DA)),^(D A) K ^(DA)
  26839   "^DD",100. 98,100.98, 3,3)
  26840   ANSWER MUS T BE 1-5 C HARACTERS  IN LENGTH
  26841   "^DD",100. 98,100.98, 3,21,0)
  26842   ^^2^2^2920 224^^^
  26843   "^DD",100. 98,100.98, 3,21,1,0)
  26844   This is an  abbreviat ion for th e display  group to b e used in  displays a nd
  26845   "^DD",100. 98,100.98, 3,21,2,0)
  26846   reports.
  26847   "^DD",100. 98,100.98, 3,"DT")
  26848   2880308
  26849   "^DD",100. 98,100.98, 4,0)
  26850   DEFAULT DI ALOG^P101. 41'^ORD(10 1.41,^0;4^ Q
  26851   "^DD",100. 98,100.98, 4,3)
  26852   Enter the  default or dering dia log for th is display  group.
  26853   "^DD",100. 98,100.98, 4,21,0)
  26854   ^^2^2^2960 815^^
  26855   "^DD",100. 98,100.98, 4,21,1,0)
  26856   This is th e dialog t hat will b e used as  the defaul t definiti on when
  26857   "^DD",100. 98,100.98, 4,21,2,0)
  26858   placing qu ick orders  associate d with thi s display  group.
  26859   "^DD",100. 98,100.98, 4,"DT")
  26860   2960814
  26861   "^DD",100. 98,100.981 ,0)
  26862   MEMBER SUB -FIELD^^.0 1^2
  26863   "^DD",100. 98,100.981 ,0,"DT")
  26864   2920601
  26865   "^DD",100. 98,100.981 ,0,"IX","B ",100.981, .01)
  26866  
  26867   "^DD",100. 98,100.981 ,0,"NM","M EMBER")
  26868  
  26869   "^DD",100. 98,100.981 ,0,"UP")
  26870   100.98
  26871   "^DD",100. 98,100.981 ,.001,0)
  26872   SEQUENCE^N J5,1^^ ^K: +X'=X!(X>9 00)!(X<0)! (X?.E1"."2 N.N) X
  26873   "^DD",100. 98,100.981 ,.001,3)
  26874   Type a Num ber betwee n 0 and 90 0, 1 Decim al Digit
  26875   "^DD",100. 98,100.981 ,.001,21,0 )
  26876   ^^2^2^2920 601^
  26877   "^DD",100. 98,100.981 ,.001,21,1 ,0)
  26878   This is th e sequence  of the me mber in th e display  group for  reporting
  26879   "^DD",100. 98,100.981 ,.001,21,2 ,0)
  26880   purposes.
  26881   "^DD",100. 98,100.981 ,.001,"DT" )
  26882   2920601
  26883   "^DD",100. 98,100.981 ,.01,0)
  26884   MEMBER^MP1 00.98X^ORD (100.98,^0 ;1^S ORDDF =100.98 D  TREE^ORDD1 01
  26885   "^DD",100. 98,100.981 ,.01,1,0)
  26886   ^.1
  26887   "^DD",100. 98,100.981 ,.01,1,1,0 )
  26888   100.981^B
  26889   "^DD",100. 98,100.981 ,.01,1,1,1 )
  26890   S ^ORD(100 .98,DA(1), 1,"B",$E(X ,1,30),DA) =""
  26891   "^DD",100. 98,100.981 ,.01,1,1,2 )
  26892   K ^ORD(100 .98,DA(1), 1,"B",$E(X ,1,30),DA)
  26893   "^DD",100. 98,100.981 ,.01,1,2,0 )
  26894   100.98^AD^ MUMPS
  26895   "^DD",100. 98,100.981 ,.01,1,2,1 )
  26896   S ^ORD(100 .98,"AD",$ E(X,1,30), DA(1),DA)= ""
  26897   "^DD",100. 98,100.981 ,.01,1,2,2 )
  26898   K ^ORD(100 .98,"AD",$ E(X,1,30), DA(1),DA)
  26899   "^DD",100. 98,100.981 ,.01,1,2," %D",0)
  26900   ^^2^2^2971 217^^
  26901   "^DD",100. 98,100.981 ,.01,1,2," %D",1,0)
  26902   ^ORD(100.9 8,"AD",ORM EM,ORGRP,D A)
  26903   "^DD",100. 98,100.981 ,.01,1,2," %D",2,0)
  26904   Provides b ackwards p ointer fro m member t o parent g roup.
  26905   "^DD",100. 98,100.981 ,.01,3)
  26906   Enter a di splay grou p.  A disp lay group  that is an  ancestor  may not al so be a me mber.
  26907   "^DD",100. 98,100.981 ,.01,4)
  26908  
  26909   "^DD",100. 98,100.981 ,.01,21,0)
  26910   ^^2^2^2920 224^^^
  26911   "^DD",100. 98,100.981 ,.01,21,1, 0)
  26912   This is a  display gr oup listed  in the NA ME field.  (This is s imilar to  a
  26913   "^DD",100. 98,100.981 ,.01,21,2, 0)
  26914   menu item  in the OPT ION File.)
  26915   "^DD",100. 98,100.981 ,.01,"DT")
  26916   2890207
  26917   "^DD",101. 41,101.41, 0)
  26918   FIELD^^99^ 30
  26919   "^DD",101. 41,101.41, 0,"DDA")
  26920   N
  26921   "^DD",101. 41,101.41, 0,"DT")
  26922   2980501
  26923   "^DD",101. 41,101.41, 0,"IX","AB ",101.41,. 01)
  26924  
  26925   "^DD",101. 41,101.41, 0,"IX","AD ",101.412, 2)
  26926  
  26927   "^DD",101. 41,101.41, 0,"IX","AM ",101.41,9 9)
  26928  
  26929   "^DD",101. 41,101.41, 0,"IX","AM 2",101.41, 2)
  26930  
  26931   "^DD",101. 41,101.41, 0,"IX","AM 51",101.41 ,51)
  26932  
  26933   "^DD",101. 41,101.41, 0,"IX","AM 52",101.41 ,52)
  26934  
  26935   "^DD",101. 41,101.41, 0,"IX","AM M",101.412 ,.01)
  26936  
  26937   "^DD",101. 41,101.41, 0,"IX","AM M2",101.41 2,2)
  26938  
  26939   "^DD",101. 41,101.41, 0,"IX","AM M3",101.41 2,3)
  26940  
  26941   "^DD",101. 41,101.41, 0,"IX","AM M4",101.41 2,4)
  26942  
  26943   "^DD",101. 41,101.41, 0,"IX","AM M5",101.41 2,5)
  26944  
  26945   "^DD",101. 41,101.41, 0,"IX","AP KG",101.41 ,7)
  26946  
  26947   "^DD",101. 41,101.41, 0,"IX","C" ,101.41,2)
  26948  
  26949   "^DD",101. 41,101.41, 0,"NM","OR DER DIALOG ")
  26950  
  26951   "^DD",101. 41,101.41, 0,"PT",100 ,2)
  26952  
  26953   "^DD",101. 41,101.41, 0,"PT",100 ,7)
  26954  
  26955   "^DD",101. 41,101.41, 0,"PT",100 .045,.02)
  26956  
  26957   "^DD",101. 41,101.41, 0,"PT",100 .5,4)
  26958  
  26959   "^DD",101. 41,101.41, 0,"PT",100 .5,5)
  26960  
  26961   "^DD",101. 41,101.41, 0,"PT",100 .98,4)
  26962  
  26963   "^DD",101. 41,101.41, 0,"PT",101 .412,1)
  26964  
  26965   "^DD",101. 41,101.41, 0,"PT",101 .412,2)
  26966  
  26967   "^DD",101. 41,101.41, 0,"PT",101 .415,2)
  26968  
  26969   "^DD",101. 41,101.41, 0,"PT",101 .416,.02)
  26970  
  26971   "^DD",101. 41,101.41, 0,"PT",101 .441,.01)
  26972  
  26973   "^DD",101. 41,101.41, 0,"PT",561 .05,.01)
  26974  
  26975   "^DD",101. 41,101.41, 0,"PT",801 .41,15)
  26976  
  26977   "^DD",101. 41,101.41, 0,"PT",801 .4118,.01)
  26978  
  26979   "^DD",101. 41,101.41, 0,"VRPK")
  26980   OR
  26981   "^DD",101. 41,101.41, .01,0)
  26982   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
  26983   "^DD",101. 41,101.41, .01,1,0)
  26984   ^.1^^-1
  26985   "^DD",101. 41,101.41, .01,1,2,0)
  26986   101.41^AB
  26987   "^DD",101. 41,101.41, .01,1,2,1)
  26988   S ^ORD(101 .41,"AB",$ E(X,1,63), DA)=""
  26989   "^DD",101. 41,101.41, .01,1,2,2)
  26990   K ^ORD(101 .41,"AB",$ E(X,1,63), DA)
  26991   "^DD",101. 41,101.41, .01,1,2,"% D",0)
  26992   ^^1^1^2971 020^
  26993   "^DD",101. 41,101.41, .01,1,2,"% D",1,0)
  26994   This is a  regular in dex on the  full 63 c haracters  of the Nam e field.
  26995   "^DD",101. 41,101.41, .01,1,2,"D T")
  26996   2971020
  26997   "^DD",101. 41,101.41, .01,3)
  26998   Answer mus t be 3-63  characters  in length .
  26999   "^DD",101. 41,101.41, .01,21,0)
  27000   ^^3^3^2971 219^
  27001   "^DD",101. 41,101.41, .01,21,1,0 )
  27002   This is th e name of  the dialog ; entries  that were  converted  from the
  27003   "^DD",101. 41,101.41, .01,21,2,0 )
  27004   Protocol f ile will r etain the  same name.   Namespac ing is not  required,
  27005   "^DD",101. 41,101.41, .01,21,3,0 )
  27006   but still  encouraged .
  27007   "^DD",101. 41,101.41, .01,"DT")
  27008   2971020
  27009   "^DD",101. 41,101.41, 2,0)
  27010   DISPLAY TE XT^FX^^0;2 ^K:$L(X)>8 0!($L(X)<3 )!($$CHKNA M^ORUTL(X) ) X
  27011   "^DD",101. 41,101.41, 2,1,0)
  27012   ^.1
  27013   "^DD",101. 41,101.41, 2,1,1,0)
  27014   101.41^C
  27015   "^DD",101. 41,101.41, 2,1,1,1)
  27016   S ^ORD(101 .41,"C",$$ UP^XLFSTR( $E(X,1,63) ),DA)=""
  27017   "^DD",101. 41,101.41, 2,1,1,2)
  27018   K ^ORD(101 .41,"C",$$ UP^XLFSTR( $E(X,1,63) ),DA)
  27019   "^DD",101. 41,101.41, 2,1,1,"DT" )
  27020   2950112
  27021   "^DD",101. 41,101.41, 2,1,2,0)
  27022   101.41^AM2 ^MUMPS
  27023   "^DD",101. 41,101.41, 2,1,2,1)
  27024   D REDOM^OR DD41
  27025   "^DD",101. 41,101.41, 2,1,2,2)
  27026   D REDOM^OR DD41
  27027   "^DD",101. 41,101.41, 2,1,2,"%D" ,0)
  27028   ^^1^1^2990 210^
  27029   "^DD",101. 41,101.41, 2,1,2,"%D" ,1,0)
  27030   Update TIM ESTAMP whe never DISP LAY TEXT i s changed.
  27031   "^DD",101. 41,101.41, 2,1,2,"DT" )
  27032   2990210
  27033   "^DD",101. 41,101.41, 2,3)
  27034   Answer mus t be 3-80  characters  in length  and canno t contain  a semicolo n (;), a c omma (,),  an up-arro w (^), a d ash (-), o r an equal  sign (=).  
  27035   "^DD",101. 41,101.41, 2,21,0)
  27036   ^.001^1^1^ 3010913^^^ ^
  27037   "^DD",101. 41,101.41, 2,21,1,0)
  27038   The text o f this dia log's name  as it app ears on a  menu or su bheader.
  27039   "^DD",101. 41,101.41, 2,"DT")
  27040   3000823
  27041   "^DD",101. 41,101.41, 3,0)
  27042   DISABLE^F^ ^0;3^K:$L( X)>40!($L( X)<1) X
  27043   "^DD",101. 41,101.41, 3,3)
  27044   Enter a me ssage here  to disabl e this dia log, 1-40  characters  in length .
  27045   "^DD",101. 41,101.41, 3,21,0)
  27046   ^^3^3^2950 112^
  27047   "^DD",101. 41,101.41, 3,21,1,0)
  27048   This field  disables  use of thi s dialog w hen it con tains text .  The tex t
  27049   "^DD",101. 41,101.41, 3,21,2,0)
  27050   should be  a short me ssage expl aining why  use of th is dialog  has been
  27051   "^DD",101. 41,101.41, 3,21,3,0)
  27052   disabled,  as it will  be displa yed if thi s dialog i s selected .
  27053   "^DD",101. 41,101.41, 3,"DT")
  27054   2950112
  27055   "^DD",101. 41,101.41, 4,0)
  27056   TYPE^RS^P: prompt;D:d ialog;Q:qu ick order; O:order se t;M:menu;A :action;^0 ;4^Q
  27057   "^DD",101. 41,101.41, 4,3)
  27058   Specify a  type for t his dialog .
  27059   "^DD",101. 41,101.41, 4,21,0)
  27060   ^^5^5^2950 716^^^^
  27061   "^DD",101. 41,101.41, 4,21,1,0)
  27062   This field  defines t he type of  order dia log to be  processed.   Control
  27063   "^DD",101. 41,101.41, 4,21,2,0)
  27064   will be pa ssed to th e OE/RR Di alog Proce ssor for d ialog item s; menu ty pes
  27065   "^DD",101. 41,101.41, 4,21,3,0)
  27066   are used f or display ing and se lecting di alog items .  Action  types will  only
  27067   "^DD",101. 41,101.41, 4,21,4,0)
  27068   execute th e entry an d exit act ions, igno ring any i tems that  may exist;  these
  27069   "^DD",101. 41,101.41, 4,21,5,0)
  27070   dialogs sh ould not c reate entr ies in the  Orders fi le.
  27071   "^DD",101. 41,101.41, 4,"DT")
  27072   2950716
  27073   "^DD",101. 41,101.41, 5,0)
  27074   DISPLAY GR OUP^P100.9 8'^ORD(100 .98,^0;5^Q
  27075   "^DD",101. 41,101.41, 5,3)
  27076   Enter the  display gr oup contai ning order able items  defined b y this dia log.
  27077   "^DD",101. 41,101.41, 5,21,0)
  27078   ^^3^3^2950 112^
  27079   "^DD",101. 41,101.41, 5,21,1,0)
  27080   This field  determine s what dis play group  this dial og has bee n defined  for.
  27081   "^DD",101. 41,101.41, 5,21,2,0)
  27082   It will de fine which  orderable  items are  selectabl e with thi s dialog,
  27083   "^DD",101. 41,101.41, 5,21,3,0)
  27084   as well as  what serv ice to sen d the orde r to when  it is comp lete.
  27085   "^DD",101. 41,101.41, 5,"DT")
  27086   2950112
  27087   "^DD",101. 41,101.41, 6,0)
  27088   SIGNATURE  REQUIRED^S ^0:NONE;1: ORELSE;2:O RES;^0;6^Q
  27089   "^DD",101. 41,101.41, 6,3)
  27090   Enter the  OR key req uired to s ign orders  created b y this dia log
  27091   "^DD",101. 41,101.41, 6,21,0)
  27092   ^^6^6^2970 318^^
  27093   "^DD",101. 41,101.41, 6,21,1,0)
  27094   This field  indicates  what sign ature will  be requir ed for ord ers create d by
  27095   "^DD",101. 41,101.41, 6,21,2,0)
  27096   this dialo g, to be c onsidered  complete a nd ready t o release  to the ser vice
  27097   "^DD",101. 41,101.41, 6,21,3,0)
  27098   for action .  If this  flag is s et to NO a nd the dia log contai ns a promp t
  27099   "^DD",101. 41,101.41, 6,21,4,0)
  27100   for item(s ) from the  Orderable  Item file , the orde r created  may still
  27101   "^DD",101. 41,101.41, 6,21,5,0)
  27102   require a  signature  if any of  the items  ordered ar e individu ally flagg ed
  27103   "^DD",101. 41,101.41, 6,21,6,0)
  27104   as requiri ng a signa ture.
  27105   "^DD",101. 41,101.41, 6,"DT")
  27106   2970318
  27107   "^DD",101. 41,101.41, 7,0)
  27108   PACKAGE^P9 .4'^DIC(9. 4,^0;7^Q
  27109   "^DD",101. 41,101.41, 7,1,0)
  27110   ^.1
  27111   "^DD",101. 41,101.41, 7,1,1,0)
  27112   101.41^APK G
  27113   "^DD",101. 41,101.41, 7,1,1,1)
  27114   S ^ORD(101 .41,"APKG" ,$E(X,1,30 ),DA)=""
  27115   "^DD",101. 41,101.41, 7,1,1,2)
  27116   K ^ORD(101 .41,"APKG" ,$E(X,1,30 ),DA)
  27117   "^DD",101. 41,101.41, 7,1,1,"DT" )
  27118   2970325
  27119   "^DD",101. 41,101.41, 7,3)
  27120   Enter the  VISTA pack age that i s to recei ve orders  created by  this dial og.
  27121   "^DD",101. 41,101.41, 7,21,0)
  27122   ^^3^3^2950 208^
  27123   "^DD",101. 41,101.41, 7,21,1,0)
  27124   This is th e VISTA pa ckage that  is intend ed to rece ive orders  created b y
  27125   "^DD",101. 41,101.41, 7,21,2,0)
  27126   this dialo g; this is  required  for creati ng the HL7  messages  to pass th e
  27127   "^DD",101. 41,101.41, 7,21,3,0)
  27128   order.
  27129   "^DD",101. 41,101.41, 7,"DT")
  27130   2970325
  27131   "^DD",101. 41,101.41, 8,0)
  27132   VERIFY ORD ER^S^1:YES ;0:NO;^0;8 ^Q
  27133   "^DD",101. 41,101.41, 8,3)
  27134   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.
  27135   "^DD",101. 41,101.41, 8,21,0)
  27136   ^^3^3^2950 623^
  27137   "^DD",101. 41,101.41, 8,21,1,0)
  27138   This field  is a flag , which de termines i f the orde r created  by this di alog
  27139   "^DD",101. 41,101.41, 8,21,2,0)
  27140   will be pr esented to  the user  for verifi cation bef ore saving  in the Or ders
  27141   "^DD",101. 41,101.41, 8,21,3,0)
  27142   file; for  most quick  orders, t his flag s hould be s et to 0 (n o).
  27143   "^DD",101. 41,101.41, 8,"DT")
  27144   2950623
  27145   "^DD",101. 41,101.41, 9,0)
  27146   ASK FOR AN OTHER ORDE R^S^0:NO;1 :YES;2:YES -DON'T ASK ;^0;9^Q
  27147   "^DD",101. 41,101.41, 9,3)
  27148   Enter YES  to have th e user ask ed to ente r another  order from  this dial og before  exiting.
  27149   "^DD",101. 41,101.41, 9,21,0)
  27150   ^^6^6^2970 616^^^
  27151   "^DD",101. 41,101.41, 9,21,1,0)
  27152   This field  allows th e user to  add anothe r order fr om this di alog, when  the
  27153   "^DD",101. 41,101.41, 9,21,2,0)
  27154   initial or der is acc epted and  placed; if  set to YE S, the use r will be
  27155   "^DD",101. 41,101.41, 9,21,3,0)
  27156   asked "Add  another < dialog dis play text>  order?" t o allow fo r either
  27157   "^DD",101. 41,101.41, 9,21,4,0)
  27158   exiting th e processo r or addin g an addit ional orde r of the s ame type.
  27159   "^DD",101. 41,101.41, 9,21,5,0)
  27160   This field  can also  be set to  YES-DON'T  ASK to for ce the pro cessor to
  27161   "^DD",101. 41,101.41, 9,21,6,0)
  27162   automatica lly drop i nto prompt ing for an other orde r without  asking fir st.
  27163   "^DD",101. 41,101.41, 9,"DT")
  27164   2970616
  27165   "^DD",101. 41,101.41, 10,0)
  27166   ITEMS^101. 412IA^^10; 0
  27167   "^DD",101. 41,101.41, 10,21,0)
  27168   ^^5^5^2990 211^^^^
  27169   "^DD",101. 41,101.41, 10,21,1,0)
  27170   This field  contains  the compon ents for d ialogs:
  27171   "^DD",101. 41,101.41, 10,21,2,0)
  27172        Dialo gs      ->  prompts
  27173   "^DD",101. 41,101.41, 10,21,3,0)
  27174        Quick  orders ->  prompts ( completed)
  27175   "^DD",101. 41,101.41, 10,21,4,0)
  27176        Order  sets   ->  dialogs o r quick or ders
  27177   "^DD",101. 41,101.41, 10,21,5,0)
  27178        Menus         ->  dialogs,  quick orde rs, or ord er sets
  27179   "^DD",101. 41,101.41, 11,0)
  27180   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
  27181   "^DD",101. 41,101.41, 11,3)
  27182   Enter the  type of da ta to be c ollected a t this pro mpt.
  27183   "^DD",101. 41,101.41, 11,21,0)
  27184   ^^2^2^2950 823^^
  27185   "^DD",101. 41,101.41, 11,21,1,0)
  27186   This is th e type of  data being  prompted  for; this  field is u sed to def ine
  27187   "^DD",101. 41,101.41, 11,21,2,0)
  27188   a call to  the reader  (^DIR) in  most case s.
  27189   "^DD",101. 41,101.41, 11,23,0)
  27190   ^^1^1^2950 823^^
  27191   "^DD",101. 41,101.41, 11,23,1,0)
  27192   Used with  Prompt-typ e only.
  27193   "^DD",101. 41,101.41, 11,"DT")
  27194   2950407
  27195   "^DD",101. 41,101.41, 12,0)
  27196   DOMAIN^F^^ 1;2^K:$L(X )>235!($L( X)<1) X
  27197   "^DD",101. 41,101.41, 12,3)
  27198   Answer mus t be 1-235  character s in lengt h.
  27199   "^DD",101. 41,101.41, 12,21,0)
  27200   ^^3^3^2990 225^^^^
  27201   "^DD",101. 41,101.41, 12,21,1,0)
  27202   This is a  parameter  that may b e used to  further sp ecify the  data type.
  27203   "^DD",101. 41,101.41, 12,21,2,0)
  27204   The string  stored he re should  be appropr iate for t he second  ^-piece of
  27205   "^DD",101. 41,101.41, 12,21,3,0)
  27206   DIR(0) whe n used wit h the data  type fiel d.
  27207   "^DD",101. 41,101.41, 12,23,0)
  27208   ^^1^1^2990 225^^^^
  27209   "^DD",101. 41,101.41, 12,23,1,0)
  27210   Used with  Prompt-typ e only.
  27211   "^DD",101. 41,101.41, 12,"DT")
  27212   2990225
  27213   "^DD",101. 41,101.41, 13,0)
  27214   ID^F^^1;3^ K:$L(X)>10 !($L(X)<2)  X
  27215   "^DD",101. 41,101.41, 13,3)
  27216   Answer mus t be 2-10  characters  in length .
  27217   "^DD",101. 41,101.41, 13,21,0)
  27218   ^.001^20^2 0^3010727^ ^
  27219   "^DD",101. 41,101.41, 13,21,1,0)
  27220   This field  may conta in a singl e word ide ntifier wh ich will b e
  27221   "^DD",101. 41,101.41, 13,21,2,0)
  27222   stored wit h the user  response  in the Ord ers file # 100, where  it
  27223   "^DD",101. 41,101.41, 13,21,3,0)
  27224   will be in dexed for  quick refe rence to c ertain val ues in the
  27225   "^DD",101. 41,101.41, 13,21,4,0)
  27226   order dial og.  The f ollowing a re some ex amples of  values
  27227   "^DD",101. 41,101.41, 13,21,5,0)
  27228   currently  in use:
  27229   "^DD",101. 41,101.41, 13,21,6,0)
  27230    
  27231   "^DD",101. 41,101.41, 13,21,7,0)
  27232      START       -> Sta rt date/ti me
  27233   "^DD",101. 41,101.41, 13,21,8,0)
  27234      STOP        -> Sto p date/tim e
  27235   "^DD",101. 41,101.41, 13,21,9,0)
  27236      SCHEDUL E   -> Adm inistratio n Schedule
  27237   "^DD",101. 41,101.41, 13,21,10,0 )
  27238      ORDERAB LE  -> Ord erable Ite m
  27239   "^DD",101. 41,101.41, 13,21,11,0 )
  27240      DRUG        -> Dis pense Drug
  27241   "^DD",101. 41,101.41, 13,21,12,0 )
  27242      CANCEL      -> Can cel Future  Orders fl ag
  27243   "^DD",101. 41,101.41, 13,21,13,0 )
  27244      COMMENT     -> Wor d processi ng comment s
  27245   "^DD",101. 41,101.41, 13,21,14,0 )
  27246    
  27247   "^DD",101. 41,101.41, 13,21,15,0 )
  27248   These valu es must be  unique am ong entrie s within a n order di alog
  27249   "^DD",101. 41,101.41, 13,21,16,0 )
  27250   but do not  need to b e unique a cross the  entire fil e.  Be sur e to
  27251   "^DD",101. 41,101.41, 13,21,17,0 )
  27252   check the  IDs assign ed to gene ric text e ntries to  make sure  that
  27253   "^DD",101. 41,101.41, 13,21,18,0 )
  27254   all IDs ar e unique.   In order  to avoid p otential p roblems it 's
  27255   "^DD",101. 41,101.41, 13,21,19,0 )
  27256   recommende d that you  use uniqu e IDs for  any local  entries th at you
  27257   "^DD",101. 41,101.41, 13,21,20,0 )
  27258   create.
  27259   "^DD",101. 41,101.41, 13,"DT")
  27260   2960215
  27261   "^DD",101. 41,101.41, 17,0)
  27262   VALIDATION ^K^^7;E1,2 45^K:$L(X) >245 X D:$ D(X) ^DIM
  27263   "^DD",101. 41,101.41, 17,3)
  27264   This is St andard MUM PS code.
  27265   "^DD",101. 41,101.41, 17,9)
  27266   @
  27267   "^DD",101. 41,101.41, 17,21,0)
  27268   ^^3^3^2960 912^
  27269   "^DD",101. 41,101.41, 17,21,1,0)
  27270   This is MU MPS code t hat will b e executed  at the ti me of rele asing an
  27271   "^DD",101. 41,101.41, 17,21,2,0)
  27272   order crea ted with t his dialog ; dialog r esponses m ay be chec ked again
  27273   "^DD",101. 41,101.41, 17,21,3,0)
  27274   here befor e releasin g the orde r to the s ervice.
  27275   "^DD",101. 41,101.41, 17,"DT")
  27276   2960912
  27277   "^DD",101. 41,101.41, 19,0)
  27278   ADDITIONAL  TEXT^K^^9 ;E1,245^K: $L(X)>245  X D:$D(X)  ^DIM
  27279   "^DD",101. 41,101.41, 19,3)
  27280   This is St andard MUM PS code.
  27281   "^DD",101. 41,101.41, 19,9)
  27282   @
  27283   "^DD",101. 41,101.41, 19,21,0)
  27284   ^^3^3^2960 405^^
  27285   "^DD",101. 41,101.41, 19,21,1,0)
  27286   This is MU MPS code t hat will b e executed  when orde r ORIFN cr eated by t his
  27287   "^DD",101. 41,101.41, 19,21,2,0)
  27288   dialog is  about to b e displaye d; any str ing that s hould be a ppended to  the
  27289   "^DD",101. 41,101.41, 19,21,3,0)
  27290   order text  should be  returned  in Y.
  27291   "^DD",101. 41,101.41, 19,"DT")
  27292   2960405
  27293   "^DD",101. 41,101.41, 20,0)
  27294   DESCRIPTIO N^101.411^ ^2;0
  27295   "^DD",101. 41,101.41, 20,21,0)
  27296   ^^1^1^2971 219^
  27297   "^DD",101. 41,101.41, 20,21,1,0)
  27298   This is a  descriptio n of the d ialog and  its uses.
  27299   "^DD",101. 41,101.41, 21,0)
  27300   RESPONSES^ 101.416^^6 ;0
  27301   "^DD",101. 41,101.41, 21,21,0)
  27302   ^^2^2^2971 219^
  27303   "^DD",101. 41,101.41, 21,21,1,0)
  27304   This multi ple contai ns any res ponses to  prompts th at have be en pre-ans wered
  27305   "^DD",101. 41,101.41, 21,21,2,0)
  27306   to create  a quick or der.
  27307   "^DD",101. 41,101.41, 30,0)
  27308   ENTRY ACTI ON^K^^3;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  27309   "^DD",101. 41,101.41, 30,3)
  27310   This is St andard MUM PS code.
  27311   "^DD",101. 41,101.41, 30,9)
  27312   @
  27313   "^DD",101. 41,101.41, 30,21,0)
  27314   ^^4^4^2950 425^
  27315   "^DD",101. 41,101.41, 30,21,1,0)
  27316   This is MU MPS code t hat will b e executed  at the to p of a dia log, prior  to
  27317   "^DD",101. 41,101.41, 30,21,2,0)
  27318   the execut ion of any  prompts;  it may per form funct ions such  as listing
  27319   "^DD",101. 41,101.41, 30,21,3,0)
  27320   the recent  Radiology  exams bef ore orderi ng a new o ne, or ale rting the
  27321   "^DD",101. 41,101.41, 30,21,4,0)
  27322   user to an  existing  diet order  before ma king a cha nge.
  27323   "^DD",101. 41,101.41, 30,"DT")
  27324   2950425
  27325   "^DD",101. 41,101.41, 31,0)
  27326   QUICK SETU P^K^^3.1;E 1,245^K:$L (X)>245 X  D:$D(X) ^D IM
  27327   "^DD",101. 41,101.41, 31,3)
  27328   This is St andard MUM PS code.
  27329   "^DD",101. 41,101.41, 31,9)
  27330   @
  27331   "^DD",101. 41,101.41, 31,21,0)
  27332   ^^3^3^2970 113^
  27333   "^DD",101. 41,101.41, 31,21,1,0)
  27334   This is MU MPS code t hat will b e executed  in the pl ace of the  Entry Act ion
  27335   "^DD",101. 41,101.41, 31,21,2,0)
  27336   when creat ing quick  orders for  this dial og; variab les may be  set here
  27337   "^DD",101. 41,101.41, 31,21,3,0)
  27338   instead to  bypass th e usual de pendence o n specific  patient v alues.
  27339   "^DD",101. 41,101.41, 31,"DT")
  27340   2970113
  27341   "^DD",101. 41,101.41, 40,0)
  27342   EXIT ACTIO N^K^^4;E1, 245^K:$L(X )>245 X D: $D(X) ^DIM
  27343   "^DD",101. 41,101.41, 40,3)
  27344   This is St andard MUM PS code.
  27345   "^DD",101. 41,101.41, 40,9)
  27346   @
  27347   "^DD",101. 41,101.41, 40,21,0)
  27348   ^^2^2^2950 622^
  27349   "^DD",101. 41,101.41, 40,21,1,0)
  27350   This is MU MPS code t hat will b e executed  upon comp letion of  processing  the
  27351   "^DD",101. 41,101.41, 40,21,2,0)
  27352   dialog; it  is curren tly used o nly with d ialog-type  entries.
  27353   "^DD",101. 41,101.41, 40,"DT")
  27354   2950622
  27355   "^DD",101. 41,101.41, 50,0)
  27356   CONTROLS^1 01.415A^^5 0;0
  27357   "^DD",101. 41,101.41, 51,0)
  27358   COLUMN WID TH^NJ3,0^^ 5;1^K:+X'= X!(X>240)! (X<20)!(X? .E1"."1N.N ) X
  27359   "^DD",101. 41,101.41, 51,1,0)
  27360   ^.1
  27361   "^DD",101. 41,101.41, 51,1,1,0)
  27362   101.41^AM5 1^MUMPS
  27363   "^DD",101. 41,101.41, 51,1,1,1)
  27364   D REDO^ORD D41
  27365   "^DD",101. 41,101.41, 51,1,1,2)
  27366   D REDO^ORD D41
  27367   "^DD",101. 41,101.41, 51,1,1,"%D ",0)
  27368   ^^1^1^2990 210^
  27369   "^DD",101. 41,101.41, 51,1,1,"%D ",1,0)
  27370   Update TIM ESTAMP whe never COLU MN WIDTH i s changed.
  27371   "^DD",101. 41,101.41, 51,1,1,"DT ")
  27372   2990210
  27373   "^DD",101. 41,101.41, 51,3)
  27374   Type a Num ber betwee n 20 and 2 40, 0 Deci mal Digits
  27375   "^DD",101. 41,101.41, 51,21,0)
  27376   ^^2^2^2950 623^
  27377   "^DD",101. 41,101.41, 51,21,1,0)
  27378   This is th e width, i n characte rs, for ea ch column  in a menu.   For exam ple,
  27379   "^DD",101. 41,101.41, 51,21,2,0)
  27380   to have 3  columns on  an 80 cha racter dev ice, enter  a width o f 26.
  27381   "^DD",101. 41,101.41, 51,"DT")
  27382   2990210
  27383   "^DD",101. 41,101.41, 52,0)
  27384   MNEMONIC W IDTH^NJ1,0 ^^5;2^K:+X '=X!(X>9)! (X<1)!(X?. E1"."1N.N)  X
  27385   "^DD",101. 41,101.41, 52,1,0)
  27386   ^.1
  27387   "^DD",101. 41,101.41, 52,1,1,0)
  27388   101.41^AM5 2^MUMPS
  27389   "^DD",101. 41,101.41, 52,1,1,1)
  27390   D REDO^ORD D41
  27391   "^DD",101. 41,101.41, 52,1,1,2)
  27392   D REDO^ORD D41
  27393   "^DD",101. 41,101.41, 52,1,1,"%D ",0)
  27394   ^^1^1^2990 210^
  27395   "^DD",101. 41,101.41, 52,1,1,"%D ",1,0)
  27396   Update TIM ESTAMP whe never MNEM ONIC WIDTH  is change d.
  27397   "^DD",101. 41,101.41, 52,1,1,"DT ")
  27398   2990210
  27399   "^DD",101. 41,101.41, 52,3)
  27400   Type a Num ber betwee n 1 and 9,  0 Decimal  Digits
  27401   "^DD",101. 41,101.41, 52,21,0)
  27402   ^^2^2^2950 623^
  27403   "^DD",101. 41,101.41, 52,21,1,0)
  27404   This field  allows th e width of  item mnem onics to b e varied;  the defaul t
  27405   "^DD",101. 41,101.41, 52,21,2,0)
  27406   value is 5 .
  27407   "^DD",101. 41,101.41, 52,"DT")
  27408   2990210
  27409   "^DD",101. 41,101.41, 53,0)
  27410   PATH SWITC H^S^1:YES; 0:NO;^5;3^ Q
  27411   "^DD",101. 41,101.41, 53,3)
  27412   Enter YES  if this me nu should  be redispl ayed when  traversing  back up t he menu tr ee.
  27413   "^DD",101. 41,101.41, 53,21,0)
  27414   ^^5^5^2950 623^
  27415   "^DD",101. 41,101.41, 53,21,1,0)
  27416   This switc h allows t he user, w hen traver sing back  UP the tre e of menus  and
  27417   "^DD",101. 41,101.41, 53,21,2,0)
  27418   items, to  select a n ew path ba ck down th e tree.  I n other wo rds, the m enu
  27419   "^DD",101. 41,101.41, 53,21,3,0)
  27420   is redispl ayed when  returning  to that me nu's level  in the tr ee and
  27421   "^DD",101. 41,101.41, 53,21,4,0)
  27422   processing  back down  the tree  is possibl e from tha t point.   If nothing  is
  27423   "^DD",101. 41,101.41, 53,21,5,0)
  27424   selected f rom the me nu, the pa th continu es back up  the tree.
  27425   "^DD",101. 41,101.41, 53,"DT")
  27426   2950623
  27427   "^DD",101. 41,101.41, 54,0)
  27428   LISTBOX TE XT^F^^5;4^ K:$L(X)>30 !($L(X)<1)  X
  27429   "^DD",101. 41,101.41, 54,3)
  27430   Answer mus t be 1-30  characters  in length .
  27431   "^DD",101. 41,101.41, 54,"DT")
  27432   2960524
  27433   "^DD",101. 41,101.41, 55,0)
  27434   WINDOW FOR M ID^NJ4,0 ^^5;5^K:+X '=X!(X>999 9)!(X<0)!( X?.E1"."1N .N) X
  27435   "^DD",101. 41,101.41, 55,3)
  27436   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  27437   "^DD",101. 41,101.41, 55,21,0)
  27438   ^.001^23^2 3^3010727^ ^
  27439   "^DD",101. 41,101.41, 55,21,1,0)
  27440   This field  tells the  GUI DELPH I code whi ch form to  use to pr ocess the
  27441   "^DD",101. 41,101.41, 55,21,2,0)
  27442   order dial og.  Each  number rep resents a  unique for m.  Follow ing are so me
  27443   "^DD",101. 41,101.41, 55,21,3,0)
  27444   of the mor e common c odes and t heir corre sponding f orm in DEL PHI.
  27445   "^DD",101. 41,101.41, 55,21,4,0)
  27446    
  27447   "^DD",101. 41,101.41, 55,21,5,0)
  27448       Form N ame     Wi ndows Form  ID
  27449   "^DD",101. 41,101.41, 55,21,6,0)
  27450       ------ ---     -- ---------- ---
  27451   "^DD",101. 41,101.41, 55,21,7,0)
  27452     OD_ACTIV ITY            100
  27453   "^DD",101. 41,101.41, 55,21,8,0)
  27454     OD_ALLER GY             105
  27455   "^DD",101. 41,101.41, 55,21,9,0)
  27456     OD_CONSU LT             110
  27457   "^DD",101. 41,101.41, 55,21,10,0 )
  27458     OD_PROCE DURE           112
  27459   "^DD",101. 41,101.41, 55,21,11,0 )
  27460     OD_DIET_ TXT            115
  27461   "^DD",101. 41,101.41, 55,21,12,0 )
  27462     OD_DIET                 117
  27463   "^DD",101. 41,101.41, 55,21,13,0 )
  27464     OD_LAB                  120
  27465   "^DD",101. 41,101.41, 55,21,14,0 )
  27466     OD_MEDIN PT             130
  27467   "^DD",101. 41,101.41, 55,21,15,0 )
  27468     OD_MEDS                 135
  27469   "^DD",101. 41,101.41, 55,21,16,0 )
  27470     OD_MEDOU TPT            140
  27471   "^DD",101. 41,101.41, 55,21,17,0 )
  27472     OD_NURSI NG             150
  27473   "^DD",101. 41,101.41, 55,21,18,0 )
  27474     OD_MISC                 151
  27475   "^DD",101. 41,101.41, 55,21,19,0 )
  27476     OD_GENER IC             152
  27477   "^DD",101. 41,101.41, 55,21,20,0 )
  27478     OD_IMAGI NG             160
  27479   "^DD",101. 41,101.41, 55,21,21,0 )
  27480     OD_VITAL S              171 
  27481   "^DD",101. 41,101.41, 55,21,22,0 )
  27482     OD_MEDIV                180
  27483   "^DD",101. 41,101.41, 55,21,23,0 )
  27484     OD_TEXTO NLY            999
  27485   "^DD",101. 41,101.41, 55,"DT")
  27486   2960804
  27487   "^DD",101. 41,101.41, 56,0)
  27488   CREATE PAR ENT ORDER^ S^1:YES;0: NO;^5;6^Q
  27489   "^DD",101. 41,101.41, 56,3)
  27490   Enter YES  if a paren t order sh ould be cr eated for  this order  set
  27491   "^DD",101. 41,101.41, 56,21,0)
  27492   ^^6^6^2970 227^
  27493   "^DD",101. 41,101.41, 56,21,1,0)
  27494   This flag  indicates  whether a  parent ord er should  be created  to group
  27495   "^DD",101. 41,101.41, 56,21,2,0)
  27496   together a ll the ord ers create d by this  order set;  this flag  is only
  27497   "^DD",101. 41,101.41, 56,21,3,0)
  27498   valid with  SET type  order dial ogs.  If t his value  is YES, a  parent
  27499   "^DD",101. 41,101.41, 56,21,4,0)
  27500   order will  be create d, and onl y the pare nt will be  presented  on the
  27501   "^DD",101. 41,101.41, 56,21,5,0)
  27502   orders lis t for disp lay and ac tion; NO w ill preven t a parent  from bein g
  27503   "^DD",101. 41,101.41, 56,21,6,0)
  27504   created an d all orde rs will be  created a nd display ed indepen dently.
  27505   "^DD",101. 41,101.41, 56,"DT")
  27506   2970227
  27507   "^DD",101. 41,101.41, 57,0)
  27508   DISPLAY SU BHEADER^S^ 1:YES;0:NO ;^5;7^Q
  27509   "^DD",101. 41,101.41, 57,3)
  27510   Enter YES  if a subhe ader shoul d be displ ayed as ea ch order i n this set  is proces sed
  27511   "^DD",101. 41,101.41, 57,21,0)
  27512   ^^3^3^2970 227^
  27513   "^DD",101. 41,101.41, 57,21,1,0)
  27514   This flag  indicates  whether a  subheader  is to be d isplayed f or each or der
  27515   "^DD",101. 41,101.41, 57,21,2,0)
  27516   in this se t as it is  processed  and place d; this fl ag is only  valid wit h
  27517   "^DD",101. 41,101.41, 57,21,3,0)
  27518   SET type o rder dialo gs.
  27519   "^DD",101. 41,101.41, 57,"DT")
  27520   2970227
  27521   "^DD",101. 41,101.41, 58,0)
  27522   AUTO-ACCEP T QUICK OR DER^S^1:YE S;^5;8^Q
  27523   "^DD",101. 41,101.41, 58,3)
  27524   Enter 'Yes ' if the o rder shoul d be place d without  displaying  the dialo g window.
  27525   "^DD",101. 41,101.41, 58,21,0)
  27526   ^^2^2^2980 902^
  27527   "^DD",101. 41,101.41, 58,21,1,0)
  27528   This can b e set to y es for a q uick order  so that i t can be p laced simp ly
  27529   "^DD",101. 41,101.41, 58,21,2,0)
  27530   by clickin g on it in  the GUI ( no orderin g dialog i s displaye d).
  27531   "^DD",101. 41,101.41, 58,"DT")
  27532   2980902
  27533   "^DD",101. 41,101.41, 99,0)
  27534   TIMESTAMP^ F^^99;1^K: $L(X)>15!( $L(X)<1) X
  27535   "^DD",101. 41,101.41, 99,1,0)
  27536   ^.1
  27537   "^DD",101. 41,101.41, 99,1,1,0)
  27538   101.41^AM^ MUMPS
  27539   "^DD",101. 41,101.41, 99,1,1,1)
  27540   D SET^ORDD 41(DA)
  27541   "^DD",101. 41,101.41, 99,1,1,2)
  27542   D KILL^ORD D41(DA)
  27543   "^DD",101. 41,101.41, 99,1,1,"%D ",0)
  27544   ^^2^2^2990 210^
  27545   "^DD",101. 41,101.41, 99,1,1,"%D ",1,0)
  27546   Recompiles  order dia log menus  in ^XUTL(" XQORM",<di alog#>_";O RD(101.41, ")
  27547   "^DD",101. 41,101.41, 99,1,1,"%D ",2,0)
  27548   whenever f ields nece ssary to d isplaying  the menu a re changed .
  27549   "^DD",101. 41,101.41, 99,1,1,"DT ")
  27550   2990210
  27551   "^DD",101. 41,101.41, 99,3)
  27552   Answer mus t be 1-15  characters  in length .
  27553   "^DD",101. 41,101.41, 99,21,0)
  27554   ^^2^2^2980 501^
  27555   "^DD",101. 41,101.41, 99,21,1,0)
  27556   For menus,  this cont ains the $ H time the  menu was  last compi led for us e
  27557   "^DD",101. 41,101.41, 99,21,2,0)
  27558   with the U nwinder ut ility (^XQ OR).
  27559   "^DD",101. 41,101.41, 99,"DT")
  27560   2990210
  27561   "^DD",101. 41,101.411 ,0)
  27562   DESCRIPTIO N SUB-FIEL D^^.01^1
  27563   "^DD",101. 41,101.411 ,0,"DT")
  27564   2950407
  27565   "^DD",101. 41,101.411 ,0,"NM","D ESCRIPTION ")
  27566  
  27567   "^DD",101. 41,101.411 ,0,"UP")
  27568   101.41
  27569   "^DD",101. 41,101.411 ,.01,0)
  27570   DESCRIPTIO N^W^^0;1^Q
  27571   "^DD",101. 41,101.411 ,.01,3)
  27572   Enter a de scription  of this di alog.
  27573   "^DD",101. 41,101.411 ,.01,21,0)
  27574   ^^1^1^2950 425^^
  27575   "^DD",101. 41,101.411 ,.01,21,1, 0)
  27576   This field  contains  a descript ion of the  content a nd use of  this dialo g.
  27577   "^DD",101. 41,101.411 ,.01,"DT")
  27578   2950407
  27579   "^DD",101. 41,101.412 ,0)
  27580   ITEMS SUB- FIELD^^117 ^37
  27581   "^DD",101. 41,101.412 ,0,"DT")
  27582   2971117
  27583   "^DD",101. 41,101.412 ,0,"ID","W RITE")
  27584   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")
  27585   "^DD",101. 41,101.412 ,0,"IX","A TXT",101.4 12,21)
  27586  
  27587   "^DD",101. 41,101.412 ,0,"IX","B ",101.412, .01)
  27588  
  27589   "^DD",101. 41,101.412 ,0,"IX","D ",101.412, 2)
  27590  
  27591   "^DD",101. 41,101.412 ,0,"IX","D AD",101.41 2,1)
  27592  
  27593   "^DD",101. 41,101.412 ,0,"IX","D AD1",101.4 12,.01)
  27594  
  27595   "^DD",101. 41,101.412 ,0,"NM","I TEMS")
  27596  
  27597   "^DD",101. 41,101.412 ,0,"UP")
  27598   101.41
  27599   "^DD",101. 41,101.412 ,.01,0)
  27600   SEQUENCE^M NJ5,1^^0;1 ^K:+X'=X!( X>999.9)!( X<.1)!(X?. E1"."2N.N)  X
  27601   "^DD",101. 41,101.412 ,.01,1,0)
  27602   ^.1
  27603   "^DD",101. 41,101.412 ,.01,1,1,0 )
  27604   101.412^B
  27605   "^DD",101. 41,101.412 ,.01,1,1,1 )
  27606   S ^ORD(101 .41,DA(1), 10,"B",$E( X,1,30),DA )=""
  27607   "^DD",101. 41,101.412 ,.01,1,1,2 )
  27608   K ^ORD(101 .41,DA(1), 10,"B",$E( X,1,30),DA )
  27609   "^DD",101. 41,101.412 ,.01,1,2,0 )
  27610   101.412^DA D1^MUMPS
  27611   "^DD",101. 41,101.412 ,.01,1,2,1 )
  27612   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) =""
  27613   "^DD",101. 41,101.412 ,.01,1,2,2 )
  27614   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)
  27615   "^DD",101. 41,101.412 ,.01,1,2," %D",0)
  27616   ^^1^1^2950 511^
  27617   "^DD",101. 41,101.412 ,.01,1,2," %D",1,0)
  27618   Allows ret rieval of  'child' pr ompts in s equence by  parent.
  27619   "^DD",101. 41,101.412 ,.01,1,2," DT")
  27620   2950511
  27621   "^DD",101. 41,101.412 ,.01,1,3,0 )
  27622   101.41^AMM ^MUMPS
  27623   "^DD",101. 41,101.412 ,.01,1,3,1 )
  27624   D REDOX^OR DD41
  27625   "^DD",101. 41,101.412 ,.01,1,3,2 )
  27626   D REDOX^OR DD41
  27627   "^DD",101. 41,101.412 ,.01,1,3," %D",0)
  27628   ^^1^1^2990 210^
  27629   "^DD",101. 41,101.412 ,.01,1,3," %D",1,0)
  27630   Update TIM ESTAMP whe never SEQU ENCE is ch anged.
  27631   "^DD",101. 41,101.412 ,.01,1,3," DT")
  27632   2990210
  27633   "^DD",101. 41,101.412 ,.01,3)
  27634   Type a Num ber betwee n .1 and 9 99.9, 1 De cimal Digi t
  27635   "^DD",101. 41,101.412 ,.01,21,0)
  27636   ^^2^2^2971 117^^^^
  27637   "^DD",101. 41,101.412 ,.01,21,1, 0)
  27638   This field  specifies  the order  in which  this item  will be di splayed or
  27639   "^DD",101. 41,101.412 ,.01,21,2, 0)
  27640   processed.
  27641   "^DD",101. 41,101.412 ,.01,"DT")
  27642   2990210
  27643   "^DD",101. 41,101.412 ,.1,0)
  27644   INPUT TRAN SFORM^K^^. 1;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  27645   "^DD",101. 41,101.412 ,.1,3)
  27646   This is St andard MUM PS code.
  27647   "^DD",101. 41,101.412 ,.1,9)
  27648   @
  27649   "^DD",101. 41,101.412 ,.1,21,0)
  27650   ^^2^2^2950 816^
  27651   "^DD",101. 41,101.412 ,.1,21,1,0 )
  27652   This is co de that wi ll be used  as the th ird piece  of DIR(0)  when askin g
  27653   "^DD",101. 41,101.412 ,.1,21,2,0 )
  27654   this promp t.
  27655   "^DD",101. 41,101.412 ,.1,"DT")
  27656   2950816
  27657   "^DD",101. 41,101.412 ,1,0)
  27658   PARENT^P10 1.41'^ORD( 101.41,^0; 11^Q
  27659   "^DD",101. 41,101.412 ,1,1,0)
  27660   ^.1
  27661   "^DD",101. 41,101.412 ,1,1,1,0)
  27662   101.412^DA D^MUMPS
  27663   "^DD",101. 41,101.412 ,1,1,1,1)
  27664   S ^ORD(101 .41,DA(1), 10,"DAD",X ,$P(^ORD(1 01.41,DA(1 ),10,DA,0) ,U),DA)=""
  27665   "^DD",101. 41,101.412 ,1,1,1,2)
  27666   K ^ORD(101 .41,DA(1), 10,"DAD",X ,$P(^ORD(1 01.41,DA(1 ),10,DA,0) ,U),DA)
  27667   "^DD",101. 41,101.412 ,1,1,1,"%D ",0)
  27668   ^^1^1^2950 511^^
  27669   "^DD",101. 41,101.412 ,1,1,1,"%D ",1,0)
  27670   Allows ret rieval of  'child' pr ompts in s equence by  parent.
  27671   "^DD",101. 41,101.412 ,1,1,1,"DT ")
  27672   2950511
  27673   "^DD",101. 41,101.412 ,1,3)
  27674   If this pr ompt is su bordinate  to another  in this d ialog, ent er the par ent prompt  here
  27675   "^DD",101. 41,101.412 ,1,21,0)
  27676   ^^4^4^2950 511^
  27677   "^DD",101. 41,101.412 ,1,21,1,0)
  27678   This field  controls  the behavi or of this  prompt.   If a paren t is defin ed
  27679   "^DD",101. 41,101.412 ,1,21,2,0)
  27680   here, this  prompt wi ll be aske d from wit hin the pa rent's dia log; when  it
  27681   "^DD",101. 41,101.412 ,1,21,3,0)
  27682   is invoked  independe ntly based  on its po sition seq uence numb er, the ch ild
  27683   "^DD",101. 41,101.412 ,1,21,4,0)
  27684   prompt wil l be ignor ed.
  27685   "^DD",101. 41,101.412 ,1,"DT")
  27686   2950511
  27687   "^DD",101. 41,101.412 ,2,0)
  27688   ITEM^P101. 41'X^ORD(1 01.41,^0;2 ^D TREE^OR DD41
  27689   "^DD",101. 41,101.412 ,2,1,0)
  27690   ^.1
  27691   "^DD",101. 41,101.412 ,2,1,1,0)
  27692   101.41^AD
  27693   "^DD",101. 41,101.412 ,2,1,1,1)
  27694   S ^ORD(101 .41,"AD",$ E(X,1,30), DA(1),DA)= ""
  27695   "^DD",101. 41,101.412 ,2,1,1,2)
  27696   K ^ORD(101 .41,"AD",$ E(X,1,30), DA(1),DA)
  27697   "^DD",101. 41,101.412 ,2,1,1,"DT ")
  27698   2950123
  27699   "^DD",101. 41,101.412 ,2,1,2,0)
  27700   101.412^D
  27701   "^DD",101. 41,101.412 ,2,1,2,1)
  27702   S ^ORD(101 .41,DA(1), 10,"D",$E( X,1,30),DA )=""
  27703   "^DD",101. 41,101.412 ,2,1,2,2)
  27704   K ^ORD(101 .41,DA(1), 10,"D",$E( X,1,30),DA )
  27705   "^DD",101. 41,101.412 ,2,1,2,"DT ")
  27706   2950411
  27707   "^DD",101. 41,101.412 ,2,1,3,0)
  27708   101.41^AMM 2^MUMPS
  27709   "^DD",101. 41,101.412 ,2,1,3,1)
  27710   D REDOX^OR DD41
  27711   "^DD",101. 41,101.412 ,2,1,3,2)
  27712   D REDOX^OR DD41
  27713   "^DD",101. 41,101.412 ,2,1,3,"%D ",0)
  27714   ^^1^1^2990 210^
  27715   "^DD",101. 41,101.412 ,2,1,3,"%D ",1,0)
  27716   Update TIM ESTAMP whe never ITEM  is change d.
  27717   "^DD",101. 41,101.412 ,2,1,3,"DT ")
  27718   2990210
  27719   "^DD",101. 41,101.412 ,2,3)
  27720   Enter an o rder dialo g; a dialo g that is  an ancesto r may not  also be a  sub-item.
  27721   "^DD",101. 41,101.412 ,2,21,0)
  27722   ^^3^3^2950 123^
  27723   "^DD",101. 41,101.412 ,2,21,1,0)
  27724   This field  points to  an order  dialog whi ch is subo rdinate to  this dial og.
  27725   "^DD",101. 41,101.412 ,2,21,2,0)
  27726   NOTE:  The  parent di alog menu  or one of  its ancest ors may no t be enter ed
  27727   "^DD",101. 41,101.412 ,2,21,3,0)
  27728   as an item .
  27729   "^DD",101. 41,101.412 ,2,"DT")
  27730   2990217
  27731   "^DD",101. 41,101.412 ,3,0)
  27732   MNEMONIC^F X^^0;3^K:$ L(X)>4!($L (X)<1)!(+X =X&($L(X," .")>1))!($ $CHKMNE^OR UTL(X)) X
  27733   "^DD",101. 41,101.412 ,3,1,0)
  27734   ^.1
  27735   "^DD",101. 41,101.412 ,3,1,1,0)
  27736   101.41^AMM 3^MUMPS
  27737   "^DD",101. 41,101.412 ,3,1,1,1)
  27738   D REDOX^OR DD41
  27739   "^DD",101. 41,101.412 ,3,1,1,2)
  27740   D REDOX^OR DD41
  27741   "^DD",101. 41,101.412 ,3,1,1,"%D ",0)
  27742   ^^1^1^2990 210^
  27743   "^DD",101. 41,101.412 ,3,1,1,"%D ",1,0)
  27744   Update TIM ESTAMP whe never MNEM ONIC is ch anged.
  27745   "^DD",101. 41,101.412 ,3,1,1,"DT ")
  27746   2990210
  27747   "^DD",101. 41,101.412 ,3,3)
  27748   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 .
  27749   "^DD",101. 41,101.412 ,3,21,0)
  27750   ^.001^2^2^ 3010727^^^ ^
  27751   "^DD",101. 41,101.412 ,3,21,1,0)
  27752   This is a  short abbr eviation f or this it em dialog  to be used  when this
  27753   "^DD",101. 41,101.412 ,3,21,2,0)
  27754   dialog is  displayed  for select ion.
  27755   "^DD",101. 41,101.412 ,3,"DT")
  27756   3000822
  27757   "^DD",101. 41,101.412 ,4,0)
  27758   DISPLAY TE XT^FX^^0;4 ^K:$L(X)>8 0!($L(X)<1 )!($$CHKNA M^ORUTL(X) ) X
  27759   "^DD",101. 41,101.412 ,4,1,0)
  27760   ^.1
  27761   "^DD",101. 41,101.412 ,4,1,1,0)
  27762   101.41^AMM 4^MUMPS
  27763   "^DD",101. 41,101.412 ,4,1,1,1)
  27764   D REDOX^OR DD41
  27765   "^DD",101. 41,101.412 ,4,1,1,2)
  27766   D REDOX^OR DD41
  27767   "^DD",101. 41,101.412 ,4,1,1,"%D ",0)
  27768   ^^1^1^2990 210^
  27769   "^DD",101. 41,101.412 ,4,1,1,"%D ",1,0)
  27770   Update TIM ESTAMP whe never DISP LAY TEXT i s changed.
  27771   "^DD",101. 41,101.412 ,4,1,1,"DT ")
  27772   2990210
  27773   "^DD",101. 41,101.412 ,4,3)
  27774   Answer mus t be 1-80  characters  in length  and canno t contain  a semicolo n (;), a c omma (,),  an up-arro w (^), a d ash (-), o r an equal  sign (=).
  27775   "^DD",101. 41,101.412 ,4,21,0)
  27776   ^.001^2^2^ 3010419^^^ ^
  27777   "^DD",101. 41,101.412 ,4,21,1,0)
  27778   This field  allows th e text tha t normally  appears f or this it em to be
  27779   "^DD",101. 41,101.412 ,4,21,2,0)
  27780   replaced w ith altern ate text f or use in  this dialo g or menu.
  27781   "^DD",101. 41,101.412 ,4,"DT")
  27782   3000823
  27783   "^DD",101. 41,101.412 ,5,0)
  27784   DISPLAY ON LY?^S^0:NO ;1:YES;2:Y ES-HEADER; ^0;5^Q
  27785   "^DD",101. 41,101.412 ,5,1,0)
  27786   ^.1
  27787   "^DD",101. 41,101.412 ,5,1,1,0)
  27788   101.41^AMM 5^MUMPS
  27789   "^DD",101. 41,101.412 ,5,1,1,1)
  27790   D REDOX^OR DD41
  27791   "^DD",101. 41,101.412 ,5,1,1,2)
  27792   D REDOX^OR DD41
  27793   "^DD",101. 41,101.412 ,5,1,1,"%D ",0)
  27794   ^^1^1^2990 210^
  27795   "^DD",101. 41,101.412 ,5,1,1,"%D ",1,0)
  27796   Update TIM ESTAMP whe never DISP LAY ONLY?  is changed .
  27797   "^DD",101. 41,101.412 ,5,1,1,"DT ")
  27798   2990210
  27799   "^DD",101. 41,101.412 ,5,3)
  27800   Enter YES  if this it em is text  for displ ay only an d not a se lectable i tem.
  27801   "^DD",101. 41,101.412 ,5,21,0)
  27802   ^^3^3^2970 409^^^^
  27803   "^DD",101. 41,101.412 ,5,21,1,0)
  27804   This field  identifie s an item  as being f ree text f or display  purposes
  27805   "^DD",101. 41,101.412 ,5,21,2,0)
  27806   only.  The  text in t he Display  Text fiel d will be  displayed,  but it
  27807   "^DD",101. 41,101.412 ,5,21,3,0)
  27808   is not sel ectable; i f designat ed as a he ader, the  text will  be underli ned.
  27809   "^DD",101. 41,101.412 ,5,"DT")
  27810   2990210
  27811   "^DD",101. 41,101.412 ,6,0)
  27812   REQUIRED^S ^1:YES;0:N O;^0;6^Q
  27813   "^DD",101. 41,101.412 ,6,3)
  27814   Enter YES  if a respo nse to thi s prompt i s mandator y.
  27815   "^DD",101. 41,101.412 ,6,21,0)
  27816   ^^1^1^2950 407^
  27817   "^DD",101. 41,101.412 ,6,21,1,0)
  27818   This field  indicates  that the  user must  enter a re sponse to  this promp t.
  27819   "^DD",101. 41,101.412 ,6,"DT")
  27820   2950407
  27821   "^DD",101. 41,101.412 ,7,0)
  27822   MULTIPLE V ALUED^S^1: YES;0:NO;^ 0;7^Q
  27823   "^DD",101. 41,101.412 ,7,3)
  27824   Enter YES  if this pr ompt is to  be asked  multiple t imes.
  27825   "^DD",101. 41,101.412 ,7,21,0)
  27826   ^^3^3^2950 407^
  27827   "^DD",101. 41,101.412 ,7,21,1,0)
  27828   This field  determine s if this  prompt wil l be allow ed to have  multiple
  27829   "^DD",101. 41,101.412 ,7,21,2,0)
  27830   values, or  be prompt ed for onl y once; if  this prom pt is a su b-dialog,
  27831   "^DD",101. 41,101.412 ,7,21,3,0)
  27832   the entire  dialog wi ll be aske d once or  many times , as a gro up.
  27833   "^DD",101. 41,101.412 ,7,"DT")
  27834   2950407
  27835   "^DD",101. 41,101.412 ,7.1,0)
  27836   MAX NUMBER  OF MULTIP LES^NJ2,0^ ^0;12^K:+X '=X!(X>99) !(X<2)!(X? .E1"."1N.N ) X
  27837   "^DD",101. 41,101.412 ,7.1,3)
  27838   Type a Num ber betwee n 2 and 99 , 0 Decima l Digits
  27839   "^DD",101. 41,101.412 ,7.1,21,0)
  27840   ^^4^4^2950 815^
  27841   "^DD",101. 41,101.412 ,7.1,21,1, 0)
  27842   This is th e maximum  number of  values tha t may be e ntered for  this prom pt,
  27843   "^DD",101. 41,101.412 ,7.1,21,2, 0)
  27844   if it is f lagged as  being mult iple-value d.  For ex ample, a d iet order  may
  27845   "^DD",101. 41,101.412 ,7.1,21,3, 0)
  27846   have up to  5 diet mo dification s entered,  where 5 i s the maxi mum allowe d
  27847   "^DD",101. 41,101.412 ,7.1,21,4, 0)
  27848   that would  be entere d here.
  27849   "^DD",101. 41,101.412 ,7.1,"DT")
  27850   2950815
  27851   "^DD",101. 41,101.412 ,7.2,0)
  27852   TITLE^F^^0 ;13^K:$L(X )>30!($L(X )<3) X
  27853   "^DD",101. 41,101.412 ,7.2,3)
  27854   Answer mus t be 3-30  characters  in length .
  27855   "^DD",101. 41,101.412 ,7.2,21,0)
  27856   ^^8^8^2970 430^^
  27857   "^DD",101. 41,101.412 ,7.2,21,1, 0)
  27858   This is te xt that wi ll be used  in place  of the pro mpt when t he order i s
  27859   "^DD",101. 41,101.412 ,7.2,21,2, 0)
  27860   displayed  for place,  edit, or  cancel, or  at the to p of a mul tiple-valu ed
  27861   "^DD",101. 41,101.412 ,7.2,21,3, 0)
  27862   prompt.  T he Display  Text for  the prompt  will be u sed togeth er with th e
  27863   "^DD",101. 41,101.412 ,7.2,21,4, 0)
  27864   instance n umber to p rompt for  user input ; for exam ple if Tit le="Lab Te sts:"
  27865   "^DD",101. 41,101.412 ,7.2,21,5, 0)
  27866   and Displa y Text="Te st:" the u ser would  see
  27867   "^DD",101. 41,101.412 ,7.2,21,6, 0)
  27868     Lab Test s:
  27869   "^DD",101. 41,101.412 ,7.2,21,7, 0)
  27870     1. Test:
  27871   "^DD",101. 41,101.412 ,7.2,21,8, 0)
  27872     2. Test:
  27873   "^DD",101. 41,101.412 ,7.2,"DT")
  27874   2950815
  27875   "^DD",101. 41,101.412 ,7.3,0)
  27876   PROMPT^F^^ 0;14^K:$L( X)>10!($L( X)<1) X
  27877   "^DD",101. 41,101.412 ,7.3,3)
  27878   Answer mus t be 1-10  characters  in length .
  27879   "^DD",101. 41,101.412 ,7.3,21,0)
  27880   ^^3^3^2970 618^
  27881   "^DD",101. 41,101.412 ,7.3,21,1, 0)
  27882   This field  contains  text that  will be ap pended to  the beginn ing of the
  27883   "^DD",101. 41,101.412 ,7.3,21,2, 0)
  27884   display te xt when pr ompting fo r addition al values;  if this f ield is
  27885   "^DD",101. 41,101.412 ,7.3,21,3, 0)
  27886   empty, the n "Another  " will be  used.
  27887   "^DD",101. 41,101.412 ,7.3,"DT")
  27888   2970618
  27889   "^DD",101. 41,101.412 ,8,0)
  27890   ASK ON EDI T ONLY^S^1 :YES;0:NO; ^0;8^Q
  27891   "^DD",101. 41,101.412 ,8,3)
  27892   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.
  27893   "^DD",101. 41,101.412 ,8,21,0)
  27894   ^^4^4^2960 112^^^
  27895   "^DD",101. 41,101.412 ,8,21,1,0)
  27896   This field  determine s the beha viour of t he dialog  driver for  this prom pt;
  27897   "^DD",101. 41,101.412 ,8,21,2,0)
  27898   if no valu e or the d efined def ault is us ually corr ect for th is prompt,
  27899   "^DD",101. 41,101.412 ,8,21,3,0)
  27900   enter YES  here to ha ve this pr ompt skipp ed on the  first pass  through t his
  27901   "^DD",101. 41,101.412 ,8,21,4,0)
  27902   dialog whe n creating  an order.
  27903   "^DD",101. 41,101.412 ,8,"DT")
  27904   2950407
  27905   "^DD",101. 41,101.412 ,9,0)
  27906   ASK ON ACT ION^F^^0;9 ^K:$L(X)>3 !($L(X)<1)  X
  27907   "^DD",101. 41,101.412 ,9,3)
  27908   Answer mus t be 1-3 c haracters  in length.
  27909   "^DD",101. 41,101.412 ,9,21,0)
  27910   ^^6^6^2970 708^^^
  27911   "^DD",101. 41,101.412 ,9,21,1,0)
  27912   This field  determine s the beha viour of t he dialog  driver for  this prom pt
  27913   "^DD",101. 41,101.412 ,9,21,2,0)
  27914   when takin g a partic ular actio n on an or der create d by this  dialog.  I f
  27915   "^DD",101. 41,101.412 ,9,21,3,0)
  27916   this strin g contains  "R", this  prompt wi ll be aske d when ren ewing an o rder;
  27917   "^DD",101. 41,101.412 ,9,21,4,0)
  27918   if this st ring conta ins "C", t his prompt  will be a sked when  changing a n
  27919   "^DD",101. 41,101.412 ,9,21,5,0)
  27920   order; if  this strin g contains  "W", this  prompt wi ll be aske d when
  27921   "^DD",101. 41,101.412 ,9,21,6,0)
  27922   rewriting  an order.
  27923   "^DD",101. 41,101.412 ,9,"DT")
  27924   2970708
  27925   "^DD",101. 41,101.412 ,10,0)
  27926   INDEX^F^^0 ;10^K:$L(X )>25!($L(X )<1) X
  27927   "^DD",101. 41,101.412 ,10,3)
  27928   Answer mus t be 1-25  characters  in length .
  27929   "^DD",101. 41,101.412 ,10,21,0)
  27930   ^^3^3^2950 713^^^
  27931   "^DD",101. 41,101.412 ,10,21,1,0 )
  27932   For pointe r-type pro mpts, this  is the in dex to use  when sear ching the  file;
  27933   "^DD",101. 41,101.412 ,10,21,2,0 )
  27934   it must be  in the fo rm of a re gular cros s-referenc e.  To sea rch on mul tiple
  27935   "^DD",101. 41,101.412 ,10,21,3,0 )
  27936   indices, e nter a str ing of ind ex names s eparated b y semi-col ons, i.e.  "B;C".
  27937   "^DD",101. 41,101.412 ,10,"DT")
  27938   2950713
  27939   "^DD",101. 41,101.412 ,11,0)
  27940   HELP MESSA GE^F^^1;1^ K:$L(X)>16 0!($L(X)<1 ) X
  27941   "^DD",101. 41,101.412 ,11,3)
  27942   Answer mus t be 1-160  character s in lengt h.
  27943   "^DD",101. 41,101.412 ,11,21,0)
  27944   ^^2^2^2970 609^^
  27945   "^DD",101. 41,101.412 ,11,21,1,0 )
  27946   This field  contains  the help m essage to  be present ed when th e user ent ers
  27947   "^DD",101. 41,101.412 ,11,21,2,0 )
  27948   a question  mark at t his prompt .
  27949   "^DD",101. 41,101.412 ,11,"DT")
  27950   2970609
  27951   "^DD",101. 41,101.412 ,12,0)
  27952   SPECIAL LO OKUP ROUTI NE^F^^1;2^ K:$L(X)>20 !($L(X)<3)  X
  27953   "^DD",101. 41,101.412 ,12,3)
  27954   Enter the  routine to  use inste ad of DIC  to do this  lookup, a s [TAG;]RO UTINE
  27955   "^DD",101. 41,101.412 ,12,21,0)
  27956   ^^3^3^2970 609^
  27957   "^DD",101. 41,101.412 ,12,21,1,0 )
  27958   This field  contains  a routine  to execute  that will  replace t he standar d
  27959   "^DD",101. 41,101.412 ,12,21,2,0 )
  27960   DIC lookup  for this  prompt; it  must be e ntered her e as LINET AG;ROUTINE
  27961   "^DD",101. 41,101.412 ,12,21,3,0 )
  27962   using a ;  instead of  ^ and whe re LINETAG  is option al.
  27963   "^DD",101. 41,101.412 ,12,"DT")
  27964   2970609
  27965   "^DD",101. 41,101.412 ,13,0)
  27966   ASK ON CON DITION^K^^ 3;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  27967   "^DD",101. 41,101.412 ,13,3)
  27968   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.
  27969   "^DD",101. 41,101.412 ,13,9)
  27970   @
  27971   "^DD",101. 41,101.412 ,13,21,0)
  27972   ^^5^5^2950 407^
  27973   "^DD",101. 41,101.412 ,13,21,1,0 )
  27974   This is MU MPS code t hat sets $ T to deter mine if th is prompt  should be  asked
  27975   "^DD",101. 41,101.412 ,13,21,2,0 )
  27976   or simply  given a de fault valu e and pres ented to t he user fo r acceptan ce
  27977   "^DD",101. 41,101.412 ,13,21,3,0 )
  27978   or editing .  For exa mple, the  prompt "Pr egnant: "  may have c ode here t o
  27979   "^DD",101. 41,101.412 ,13,21,4,0 )
  27980   check the  sex of the  current p atient, i. e. I ORSEX ="F" will  allow it t o be
  27981   "^DD",101. 41,101.412 ,13,21,5,0 )
  27982   asked only  for femal e patients .
  27983   "^DD",101. 41,101.412 ,13,"DT")
  27984   2950407
  27985   "^DD",101. 41,101.412 ,14,0)
  27986   SCREEN^K^^ 4;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  27987   "^DD",101. 41,101.412 ,14,3)
  27988   This is St andard MUM PS code.
  27989   "^DD",101. 41,101.412 ,14,9)
  27990   @
  27991   "^DD",101. 41,101.412 ,14,21,0)
  27992   ^^2^2^2950 407^
  27993   "^DD",101. 41,101.412 ,14,21,1,0 )
  27994   For pointe r-type pro mpts, this  field may  contain M UMPS code  that will  be
  27995   "^DD",101. 41,101.412 ,14,21,2,0 )
  27996   set into D IC("S") to  screen th e possible  choices i n the poin ted-to fil e.
  27997   "^DD",101. 41,101.412 ,14,"DT")
  27998   2950407
  27999   "^DD",101. 41,101.412 ,15,0)
  28000   POST-SELEC TION ACTIO N^K^^5;E1, 245^K:$L(X )>245 X D: $D(X) ^DIM
  28001   "^DD",101. 41,101.412 ,15,3)
  28002   This is St andard MUM PS code.
  28003   "^DD",101. 41,101.412 ,15,9)
  28004   @
  28005   "^DD",101. 41,101.412 ,15,21,0)
  28006   ^^3^3^2970 923^^^^
  28007   "^DD",101. 41,101.412 ,15,21,1,0 )
  28008   This is co de that wi ll be exec uted after  a respons e is enter ed to this
  28009   "^DD",101. 41,101.412 ,15,21,2,0 )
  28010   prompt; if  this prom pt should  be re-aske d, kill th e variable  DONE.
  28011   "^DD",101. 41,101.412 ,15,21,3,0 )
  28012   If executi on of the  ordering d ialog shou ld be stop ped, set O RQUIT=1.
  28013   "^DD",101. 41,101.412 ,15,"DT")
  28014   2970923
  28015   "^DD",101. 41,101.412 ,16,0)
  28016   XECUTABLE  HELP^K^^6; E1,245^K:$ L(X)>245 X  D:$D(X) ^ DIM
  28017   "^DD",101. 41,101.412 ,16,3)
  28018   This is St andard MUM PS code.
  28019   "^DD",101. 41,101.412 ,16,9)
  28020   @
  28021   "^DD",101. 41,101.412 ,16,21,0)
  28022   ^^2^2^2950 407^
  28023   "^DD",101. 41,101.412 ,16,21,1,0 )
  28024   This is co de that is  to be exe cuted when  the user  enters two  or more
  28025   "^DD",101. 41,101.412 ,16,21,2,0 )
  28026   question m arks at th is prompt.
  28027   "^DD",101. 41,101.412 ,16,"DT")
  28028   2950407
  28029   "^DD",101. 41,101.412 ,17,0)
  28030   DEFAULT^K^ ^7;E1,245^ K:$L(X)>24 5 X D:$D(X ) ^DIM
  28031   "^DD",101. 41,101.412 ,17,3)
  28032   This is St andard MUM PS code.
  28033   "^DD",101. 41,101.412 ,17,9)
  28034   @
  28035   "^DD",101. 41,101.412 ,17,21,0)
  28036   ^^2^2^2971 219^^^^
  28037   "^DD",101. 41,101.412 ,17,21,1,0 )
  28038   This is co de that is  to be exe cuted to d etermine t he appropr iate defau lt
  28039   "^DD",101. 41,101.412 ,17,21,2,0 )
  28040   value for  this promp t, setting  Y=interna l form of  this value .
  28041   "^DD",101. 41,101.412 ,17,"DT")
  28042   2950519
  28043   "^DD",101. 41,101.412 ,18,0)
  28044   DEFAULT WO RD-PROCESS ING TEXT^1 01.41218^^ 8;0
  28045   "^DD",101. 41,101.412 ,18,21,0)
  28046   ^^1^1^2971 219^
  28047   "^DD",101. 41,101.412 ,18,21,1,0 )
  28048   This is de fault text  to be stu ffed into  this word- processing  prompt.
  28049   "^DD",101. 41,101.412 ,19,0)
  28050   ENTRY ACTI ON^K^^9;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  28051   "^DD",101. 41,101.412 ,19,3)
  28052   This is St andard MUM PS code.
  28053   "^DD",101. 41,101.412 ,19,9)
  28054   @
  28055   "^DD",101. 41,101.412 ,19,21,0)
  28056   ^^3^3^2970 609^
  28057   "^DD",101. 41,101.412 ,19,21,1,0 )
  28058   This is co de that wi ll be exec uted at th e beginnin g of the p rocessing  of
  28059   "^DD",101. 41,101.412 ,19,21,2,0 )
  28060   this promp t, before  the Defaul t and Ask  on Conditi on fields  are execut ed;
  28061   "^DD",101. 41,101.412 ,19,21,3,0 )
  28062   any specia l setup re quired for  this fiel d should b e done her e.
  28063   "^DD",101. 41,101.412 ,19,"DT")
  28064   2970609
  28065   "^DD",101. 41,101.412 ,20,0)
  28066   EXIT ACTIO N^K^^10;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  28067   "^DD",101. 41,101.412 ,20,3)
  28068   This is St andard MUM PS code.
  28069   "^DD",101. 41,101.412 ,20,9)
  28070   @
  28071   "^DD",101. 41,101.412 ,20,21,0)
  28072   ^^3^3^2970 609^
  28073   "^DD",101. 41,101.412 ,20,21,1,0 )
  28074   This is co de that wi ll be exec uted at th e very end  of the pr ocessing o f
  28075   "^DD",101. 41,101.412 ,20,21,2,0 )
  28076   this promp t, after p rompting a nd the Val idation fi eld is exe cuted;
  28077   "^DD",101. 41,101.412 ,20,21,3,0 )
  28078   any specia l cleanup  should be  done here.
  28079   "^DD",101. 41,101.412 ,20,"DT")
  28080   2970609
  28081   "^DD",101. 41,101.412 ,21,0)
  28082   ORDER TEXT  SEQUENCE^ NJ5,2^^2;1 ^K:+X'=X!( X>99.99)!( X<1)!(X?.E 1"."3N.N)  X
  28083   "^DD",101. 41,101.412 ,21,1,0)
  28084   ^.1
  28085   "^DD",101. 41,101.412 ,21,1,1,0)
  28086   101.412^AT XT
  28087   "^DD",101. 41,101.412 ,21,1,1,1)
  28088   S ^ORD(101 .41,DA(1), 10,"ATXT", $E(X,1,30) ,DA)=""
  28089   "^DD",101. 41,101.412 ,21,1,1,2)
  28090   K ^ORD(101 .41,DA(1), 10,"ATXT", $E(X,1,30) ,DA)
  28091   "^DD",101. 41,101.412 ,21,1,1,"% D",0)
  28092   ^^1^1^2960 226^
  28093   "^DD",101. 41,101.412 ,21,1,1,"% D",1,0)
  28094   Used to bu ild order  text.
  28095   "^DD",101. 41,101.412 ,21,1,1,"D T")
  28096   2960226
  28097   "^DD",101. 41,101.412 ,21,3)
  28098   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
  28099   "^DD",101. 41,101.412 ,21,21,0)
  28100   ^^3^3^2970 607^^^
  28101   "^DD",101. 41,101.412 ,21,21,1,0 )
  28102   This field  indicates  the order  in which  values wil l be conca tenated
  28103   "^DD",101. 41,101.412 ,21,21,2,0 )
  28104   together t o build th e order te xt; this m ay differ  from the p rompting
  28105   "^DD",101. 41,101.412 ,21,21,3,0 )
  28106   order defi ned in the  .01 Seque nce field.
  28107   "^DD",101. 41,101.412 ,21,"DT")
  28108   2960226
  28109   "^DD",101. 41,101.412 ,22,0)
  28110   FORMAT^F^^ 2;2^K:$L(X )>10!($L(X )<1) X
  28111   "^DD",101. 41,101.412 ,22,3)
  28112   Answer mus t be 1-10  characters  in length .
  28113   "^DD",101. 41,101.412 ,22,21,0)
  28114   ^^15^15^29 71207^^^^
  28115   "^DD",101. 41,101.412 ,22,21,1,0 )
  28116   This is a  string of  characters  that will  define an y exceptio ns to how
  28117   "^DD",101. 41,101.412 ,22,21,2,0 )
  28118   the extern al form of  this valu e is gener ated.  Pos sible valu es include :
  28119   "^DD",101. 41,101.412 ,22,21,3,0 )
  28120     Pointer          ->  <field #> ~<piece in  RPC list  of field # >, default  =.01
  28121   "^DD",101. 41,101.412 ,22,21,4,0 )
  28122     Set of C odes    ->  1~<piece  in RPC lis t of code>  to use co de for nam e
  28123   "^DD",101. 41,101.412 ,22,21,5,0 )
  28124     Date/Tim e       ->  Format st ring to pa ss $$FMTE^ XLFDT (def ault = 2)
  28125   "^DD",101. 41,101.412 ,22,21,6,0 )
  28126     
  28127   "^DD",101. 41,101.412 ,22,21,7,0 )
  28128     Suppress  value  ->  @
  28129   "^DD",101. 41,101.412 ,22,21,8,0 )
  28130     Replace  value   ->  @<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  28131   "^DD",101. 41,101.412 ,22,21,9,0 )
  28132                           whose va lue, when  present, s upersedes  this value
  28133   "^DD",101. 41,101.412 ,22,21,10, 0)
  28134     Required  value  ->  *<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  28135   "^DD",101. 41,101.412 ,22,21,11, 0)
  28136                           whose va lue is req uired to b e present  to include
  28137   "^DD",101. 41,101.412 ,22,21,12, 0)
  28138                           this val ue
  28139   "^DD",101. 41,101.412 ,22,21,13, 0)
  28140     Ignore i f same  ->  =<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  28141   "^DD",101. 41,101.412 ,22,21,14, 0)
  28142                           whose va lue, if th e external  form is t he same,
  28143   "^DD",101. 41,101.412 ,22,21,15, 0)
  28144                           supersed es this va lue
  28145   "^DD",101. 41,101.412 ,22,"DT")
  28146   2960226
  28147   "^DD",101. 41,101.412 ,23,0)
  28148   OMIT TEXT^ F^^2;3^K:$ L(X)>30!($ L(X)<1) X
  28149   "^DD",101. 41,101.412 ,23,3)
  28150   Answer mus t be 1-30  characters  in length .
  28151   "^DD",101. 41,101.412 ,23,21,0)
  28152   ^^3^3^2970 829^^^^
  28153   "^DD",101. 41,101.412 ,23,21,1,0 )
  28154   This is th e external  form of a  value tha t is not t o be inclu ded when b uilding
  28155   "^DD",101. 41,101.412 ,23,21,2,0 )
  28156   the order  text.  E.g . to inclu de the urg ency in th e order te xt unless  it
  28157   "^DD",101. 41,101.412 ,23,21,3,0 )
  28158   is routine , enter "R OUTINE" he re.
  28159   "^DD",101. 41,101.412 ,23,"DT")
  28160   2970829
  28161   "^DD",101. 41,101.412 ,24,0)
  28162   LEADING TE XT^F^^2;4^ K:$L(X)>80 !($L(X)<1)  X
  28163   "^DD",101. 41,101.412 ,24,3)
  28164   Answer mus t be 1-80  characters  in length .
  28165   "^DD",101. 41,101.412 ,24,21,0)
  28166   ^^3^3^2970 724^^^^
  28167   "^DD",101. 41,101.412 ,24,21,1,0 )
  28168   This field  contains  text that  will be ap pended to  the order  text
  28169   "^DD",101. 41,101.412 ,24,21,2,0 )
  28170   immediatel y in front  of this v alue, e.g.  "Instruct ions:".  I f this tex t
  28171   "^DD",101. 41,101.412 ,24,21,3,0 )
  28172   is contain ed in a va riable, en ter @NAME  where NAME  is the va riable nam e.
  28173   "^DD",101. 41,101.412 ,24,"DT")
  28174   2970724
  28175   "^DD",101. 41,101.412 ,25,0)
  28176   TRAILING T EXT^F^^2;5 ^K:$L(X)>8 0!($L(X)<1 ) X
  28177   "^DD",101. 41,101.412 ,25,3)
  28178   Answer mus t be 1-80  characters  in length .
  28179   "^DD",101. 41,101.412 ,25,21,0)
  28180   ^^3^3^2970 724^^^^
  28181   "^DD",101. 41,101.412 ,25,21,1,0 )
  28182   This field  contains  text that  will be ap pended to  the order  text
  28183   "^DD",101. 41,101.412 ,25,21,2,0 )
  28184   immediatel y followin g this val ue, e.g. " refills".   If this t ext is
  28185   "^DD",101. 41,101.412 ,25,21,3,0 )
  28186   contained  in a varia ble, enter  @NAME whe re NAME is  the varia ble name.
  28187   "^DD",101. 41,101.412 ,25,"DT")
  28188   2970724
  28189   "^DD",101. 41,101.412 ,26,0)
  28190   START NEW  LINE^S^1:Y ES;0:NO;^2 ;6^Q
  28191   "^DD",101. 41,101.412 ,26,3)
  28192   Enter YES  if this va lue should  begin on  a new line  in the or der text.
  28193   "^DD",101. 41,101.412 ,26,21,0)
  28194   0^^2^2^297 0911^
  28195   "^DD",101. 41,101.412 ,26,21,1,0 )
  28196   This field  determine s if this  value is c oncatenate d onto the  current l ine
  28197   "^DD",101. 41,101.412 ,26,21,2,0 )
  28198   when build ing the or der text,  or if a ne w line is  started wi th this va lue.
  28199   "^DD",101. 41,101.412 ,26,"DT")
  28200   2970911
  28201   "^DD",101. 41,101.412 ,27,0)
  28202   WORD-WRAP^ S^1:DON'T  WRAP;0:WRA P;^2;7^Q
  28203   "^DD",101. 41,101.412 ,27,3)
  28204   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'.
  28205   "^DD",101. 41,101.412 ,27,21,0)
  28206   ^^3^3^2970 926^^^
  28207   "^DD",101. 41,101.412 ,27,21,1,0 )
  28208   This field  determine s if this  text shoul d be wrapp ed when ad ded to the
  28209   "^DD",101. 41,101.412 ,27,21,2,0 )
  28210   order text , or appen ded line b y line as  stored in  the file;  this is on ly
  28211   "^DD",101. 41,101.412 ,27,21,3,0 )
  28212   used for w ord-proces sing type  prompts.
  28213   "^DD",101. 41,101.412 ,27,"DT")
  28214   2970926
  28215   "^DD",101. 41,101.412 ,101,0)
  28216   WINDOWS CO NTROL^F^^W ;1^K:$L(X) >30!($L(X) <1) X
  28217   "^DD",101. 41,101.412 ,101,3)
  28218   Answer mus t be 1-30  characters  in length .
  28219   "^DD",101. 41,101.412 ,101,21,0)
  28220   ^^2^2^2950 715^
  28221   "^DD",101. 41,101.412 ,101,21,1, 0)
  28222   Stores the  type of W indows con trol neces sary to ge t the data  for this
  28223   "^DD",101. 41,101.412 ,101,21,2, 0)
  28224   prompt.
  28225   "^DD",101. 41,101.412 ,101,"DT")
  28226   2960517
  28227   "^DD",101. 41,101.412 ,102,0)
  28228   API NAME^F ^^W;2^K:$L (X)>30!($L (X)<1) X
  28229   "^DD",101. 41,101.412 ,102,3)
  28230   Answer mus t be 1-30  characters  in length .
  28231   "^DD",101. 41,101.412 ,102,21,0)
  28232   ^^3^3^2950 715^
  28233   "^DD",101. 41,101.412 ,102,21,1, 0)
  28234   This is th e API that  should be  called wh en the con trol is us ed.  How t he API
  28235   "^DD",101. 41,101.412 ,102,21,2, 0)
  28236   is used va rys with t he control .  Example s are: fil ling list  boxes, get ting
  28237   "^DD",101. 41,101.412 ,102,21,3, 0)
  28238   boilerplat e text, et c.
  28239   "^DD",101. 41,101.412 ,102,"DT")
  28240   2951002
  28241   "^DD",101. 41,101.412 ,103,0)
  28242   API PARAME TER #1^F^^ W;3^K:$L(X )>30!($L(X )<1) X
  28243   "^DD",101. 41,101.412 ,103,3)
  28244   Answer mus t be 1-30  characters  in length .
  28245   "^DD",101. 41,101.412 ,103,21,0)
  28246   ^^1^1^2950 715^
  28247   "^DD",101. 41,101.412 ,103,21,1, 0)
  28248   A paramete r that is  used by th e API call  may be st ored here.
  28249   "^DD",101. 41,101.412 ,103,"DT")
  28250   2950715
  28251   "^DD",101. 41,101.412 ,113,0)
  28252   WINDOWS CO NDITION^K^ ^W3;E1,245 ^K:$L(X)>2 45 X D:$D( X) ^DIM
  28253   "^DD",101. 41,101.412 ,113,3)
  28254   This is St andard MUM PS code.
  28255   "^DD",101. 41,101.412 ,113,9)
  28256   @
  28257   "^DD",101. 41,101.412 ,113,21,0)
  28258   ^^3^3^2950 715^
  28259   "^DD",101. 41,101.412 ,113,21,1, 0)
  28260   This is si lent code  that is ex ecuted whe n building  the dialo g for wind ows.
  28261   "^DD",101. 41,101.412 ,113,21,2, 0)
  28262   It identif ies which  prompts sh ould be in cluded in  the dialog .  The con dition
  28263   "^DD",101. 41,101.412 ,113,21,3, 0)
  28264   should lea ve $T fals e if the p rompt shou ld not be  asked.
  28265   "^DD",101. 41,101.412 ,113,"DT")
  28266   2950715
  28267   "^DD",101. 41,101.412 ,117,0)
  28268   WINDOWS DE FAULT^K^^W 7;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  28269   "^DD",101. 41,101.412 ,117,3)
  28270   This is St andard MUM PS code.
  28271   "^DD",101. 41,101.412 ,117,9)
  28272   @
  28273   "^DD",101. 41,101.412 ,117,21,0)
  28274   ^^2^2^2950 715^
  28275   "^DD",101. 41,101.412 ,117,21,1, 0)
  28276   This code  should sil ently set  the defaul t value of  a prompt  when it is  
  28277   "^DD",101. 41,101.412 ,117,21,2, 0)
  28278   selected.
  28279   "^DD",101. 41,101.412 ,117,"DT")
  28280   2950715
  28281   "^DD",101. 41,101.412 18,0)
  28282   DEFAULT WO RD-PROCESS ING TEXT S UB-FIELD^^ .01^1
  28283   "^DD",101. 41,101.412 18,0,"DT")
  28284   2950407
  28285   "^DD",101. 41,101.412 18,0,"NM", "DEFAULT W ORD-PROCES SING TEXT" )
  28286  
  28287   "^DD",101. 41,101.412 18,0,"UP")
  28288   101.412
  28289   "^DD",101. 41,101.412 18,.01,0)
  28290   DEFAULT WO RD-PROCESS ING TEXT^W ^^0;1^Q
  28291   "^DD",101. 41,101.412 18,.01,3)
  28292   Enter the  default re sponse for  a word-pr ocessing t ype prompt .
  28293   "^DD",101. 41,101.412 18,.01,21, 0)
  28294   ^^2^2^2950 407^
  28295   "^DD",101. 41,101.412 18,.01,21, 1,0)
  28296   This field  contains  the text t o be prese nted as th e default  for this p rompt,
  28297   "^DD",101. 41,101.412 18,.01,21, 2,0)
  28298   for word-p rocessing  type promp ts.
  28299   "^DD",101. 41,101.412 18,.01,"DT ")
  28300   2950407
  28301   "^DD",101. 41,101.415 ,0)
  28302   CONTROLS S UB-FIELD^^ 14^14
  28303   "^DD",101. 41,101.415 ,0,"DT")
  28304   2960202
  28305   "^DD",101. 41,101.415 ,0,"IX","A C",101.415 ,3)
  28306  
  28307   "^DD",101. 41,101.415 ,0,"IX","B ",101.415, .01)
  28308  
  28309   "^DD",101. 41,101.415 ,0,"NM","C ONTROLS")
  28310  
  28311   "^DD",101. 41,101.415 ,0,"UP")
  28312   101.41
  28313   "^DD",101. 41,101.415 ,.01,0)
  28314   LOGICAL NA ME^MF^^0;1 ^K:$L(X)>8 !($L(X)<1) !'(X?1.8U)  X
  28315   "^DD",101. 41,101.415 ,.01,1,0)
  28316   ^.1
  28317   "^DD",101. 41,101.415 ,.01,1,1,0 )
  28318   101.415^B
  28319   "^DD",101. 41,101.415 ,.01,1,1,1 )
  28320   S ^ORD(101 .41,DA(1), 50,"B",$E( X,1,30),DA )=""
  28321   "^DD",101. 41,101.415 ,.01,1,1,2 )
  28322   K ^ORD(101 .41,DA(1), 50,"B",$E( X,1,30),DA )
  28323   "^DD",101. 41,101.415 ,.01,3)
  28324   Answer mus t be 1-8 c haracters  in length.
  28325   "^DD",101. 41,101.415 ,.01,21,0)
  28326   ^^1^1^2960 202^
  28327   "^DD",101. 41,101.415 ,.01,21,1, 0)
  28328   This is th e name by  which cont rols can r efer to ea ch other.
  28329   "^DD",101. 41,101.415 ,.01,"DT")
  28330   2960202
  28331   "^DD",101. 41,101.415 ,2,0)
  28332   ITEM^P101. 41'^ORD(10 1.41,^0;2^ Q
  28333   "^DD",101. 41,101.415 ,2,"DT")
  28334   2960202
  28335   "^DD",101. 41,101.415 ,3,0)
  28336   CREATE SEQ UENCE^NJ2, 0^^0;3^K:+ X'=X!(X>99 )!(X<1)!(X ?.E1"."1N. N) X
  28337   "^DD",101. 41,101.415 ,3,1,0)
  28338   ^.1
  28339   "^DD",101. 41,101.415 ,3,1,1,0)
  28340   101.415^AC
  28341   "^DD",101. 41,101.415 ,3,1,1,1)
  28342   S ^ORD(101 .41,DA(1), 50,"AC",$E (X,1,30),D A)=""
  28343   "^DD",101. 41,101.415 ,3,1,1,2)
  28344   K ^ORD(101 .41,DA(1), 50,"AC",$E (X,1,30),D A)
  28345   "^DD",101. 41,101.415 ,3,1,1,"%D ",0)
  28346   ^^2^2^2960 202^
  28347   "^DD",101. 41,101.415 ,3,1,1,"%D ",1,0)
  28348   The 'AC' c ross-refer ence puts  in window  controls i n order by  creation 
  28349   "^DD",101. 41,101.415 ,3,1,1,"%D ",2,0)
  28350   sequence.
  28351   "^DD",101. 41,101.415 ,3,1,1,"DT ")
  28352   2960202
  28353   "^DD",101. 41,101.415 ,3,3)
  28354   Type a Num ber betwee n 1 and 99 , 0 Decima l Digits
  28355   "^DD",101. 41,101.415 ,3,"DT")
  28356   2960202
  28357   "^DD",101. 41,101.415 ,4,0)
  28358   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
  28359   "^DD",101. 41,101.415 ,4,"DT")
  28360   2960202
  28361   "^DD",101. 41,101.415 ,5,0)
  28362   LABEL^F^^0 ;5^K:$L(X) >30!($L(X) <1) X
  28363   "^DD",101. 41,101.415 ,5,3)
  28364   Answer mus t be 1-30  characters  in length .
  28365   "^DD",101. 41,101.415 ,5,"DT")
  28366   2960202
  28367   "^DD",101. 41,101.415 ,6,0)
  28368   BESIDE^F^^ 0;6^K:$L(X )>8!($L(X) <1) X
  28369   "^DD",101. 41,101.415 ,6,3)
  28370   Answer mus t be 1-8 c haracters  in length.
  28371   "^DD",101. 41,101.415 ,6,"DT")
  28372   2960202
  28373   "^DD",101. 41,101.415 ,7,0)
  28374   BELOW^F^^0 ;7^K:$L(X) >8!($L(X)< 1) X
  28375   "^DD",101. 41,101.415 ,7,3)
  28376   Answer mus t be 1-8 c haracters  in length.
  28377   "^DD",101. 41,101.415 ,7,"DT")
  28378   2960202
  28379   "^DD",101. 41,101.415 ,8,0)
  28380   WIDTH^NJ6, 4^^0;8^K:+ X'=X!(X>1) !(X<0)!(X? .E1"."5N.N ) X
  28381   "^DD",101. 41,101.415 ,8,3)
  28382   Type a Num ber betwee n 0 and 1,  4 Decimal  Digits
  28383   "^DD",101. 41,101.415 ,8,"DT")
  28384   2960202
  28385   "^DD",101. 41,101.415 ,9,0)
  28386   LEFT CONTR OL^F^^0;9^ K:$L(X)>8! ($L(X)<1)  X
  28387   "^DD",101. 41,101.415 ,9,3)
  28388   Answer mus t be 1-8 c haracters  in length.
  28389   "^DD",101. 41,101.415 ,9,"DT")
  28390   2960202
  28391   "^DD",101. 41,101.415 ,10,0)
  28392   RIGHT CONT ROL^F^^0;1 0^K:$L(X)> 8!($L(X)<1 ) X
  28393   "^DD",101. 41,101.415 ,10,3)
  28394   Answer mus t be 1-8 c haracters  in length.
  28395   "^DD",101. 41,101.415 ,10,"DT")
  28396   2960202
  28397   "^DD",101. 41,101.415 ,11,0)
  28398   HEIGHT^NJ2 ,0^^0;11^K :+X'=X!(X> 15)!(X<1)! (X?.E1"."1 N.N) X
  28399   "^DD",101. 41,101.415 ,11,3)
  28400   Type a Num ber betwee n 1 and 15 , 0 Decima l Digits
  28401   "^DD",101. 41,101.415 ,11,"DT")
  28402   2960202
  28403   "^DD",101. 41,101.415 ,12,0)
  28404   UPPER CONT ROL^F^^0;1 2^K:$L(X)> 8!($L(X)<1 ) X
  28405   "^DD",101. 41,101.415 ,12,3)
  28406   Answer mus t be 1-8 c haracters  in length.
  28407   "^DD",101. 41,101.415 ,12,"DT")
  28408   2960202
  28409   "^DD",101. 41,101.415 ,13,0)
  28410   LOWER CONT ROL^F^^0;1 3^K:$L(X)> 8!($L(X)<1 ) X
  28411   "^DD",101. 41,101.415 ,13,3)
  28412   Answer mus t be 1-8 c haracters  in length.
  28413   "^DD",101. 41,101.415 ,13,"DT")
  28414   2960202
  28415   "^DD",101. 41,101.415 ,14,0)
  28416   TAB SEQUEN CE^NJ2,0^^ 0;14^K:+X' =X!(X>89)! (X<0)!(X?. E1"."1N.N)  X
  28417   "^DD",101. 41,101.415 ,14,3)
  28418   Type a Num ber betwee n 0 and 89 , 0 Decima l Digits
  28419   "^DD",101. 41,101.415 ,14,"DT")
  28420   2960202
  28421   "^DD",101. 41,101.416 ,0)
  28422   RESPONSES  SUB-FIELD^ ^2^5
  28423   "^DD",101. 41,101.416 ,0,"DT")
  28424   2960717
  28425   "^DD",101. 41,101.416 ,0,"IX","D ",101.416, .02)
  28426  
  28427   "^DD",101. 41,101.416 ,0,"NM","R ESPONSES")
  28428  
  28429   "^DD",101. 41,101.416 ,0,"UP")
  28430   101.41
  28431   "^DD",101. 41,101.416 ,.01,0)
  28432   ITEM ENTRY ^MNJ7,0^^0 ;1^K:+X'=X !(X>999999 9)!(X<1)!( X?.E1"."1N .N) X
  28433   "^DD",101. 41,101.416 ,.01,1,0)
  28434   ^.1^^0
  28435   "^DD",101. 41,101.416 ,.01,3)
  28436   Type a Num ber betwee n 1 and 99 99999, 0 D ecimal Dig its
  28437   "^DD",101. 41,101.416 ,.01,21,0)
  28438   ^^2^2^2971 219^^^
  28439   "^DD",101. 41,101.416 ,.01,21,1, 0)
  28440   This is th e internal  entry num ber of the  prompt in  the Item  multiple
  28441   "^DD",101. 41,101.416 ,.01,21,2, 0)
  28442   by which t his respon se was obt ained.
  28443   "^DD",101. 41,101.416 ,.01,"DT")
  28444   2961118
  28445   "^DD",101. 41,101.416 ,.02,0)
  28446   DIALOG^P10 1.41'^ORD( 101.41,^0; 2^Q
  28447   "^DD",101. 41,101.416 ,.02,1,0)
  28448   ^.1
  28449   "^DD",101. 41,101.416 ,.02,1,1,0 )
  28450   101.416^D
  28451   "^DD",101. 41,101.416 ,.02,1,1,1 )
  28452   S ^ORD(101 .41,DA(1), 6,"D",$E(X ,1,30),DA) =""
  28453   "^DD",101. 41,101.416 ,.02,1,1,2 )
  28454   K ^ORD(101 .41,DA(1), 6,"D",$E(X ,1,30),DA)
  28455   "^DD",101. 41,101.416 ,.02,1,1," DT")
  28456   2961118
  28457   "^DD",101. 41,101.416 ,.02,3)
  28458   Select the  dialog pr ompt from  which this  response  was genera ted.
  28459   "^DD",101. 41,101.416 ,.02,21,0)
  28460   ^^2^2^2960 717^
  28461   "^DD",101. 41,101.416 ,.02,21,1, 0)
  28462   This is a  pointer to  the dialo g prompt,  which is i n the Orde r Dialog f ile
  28463   "^DD",101. 41,101.416 ,.02,21,2, 0)
  28464   as type pr ompt.
  28465   "^DD",101. 41,101.416 ,.02,"DT")
  28466   2961118
  28467   "^DD",101. 41,101.416 ,.03,0)
  28468   INSTANCE^N J7,0^^0;3^ K:+X'=X!(X >9999999)! (X<1)!(X?. E1"."1N.N)  X
  28469   "^DD",101. 41,101.416 ,.03,3)
  28470   Type a Num ber betwee n 1 and 99 99999, 0 D ecimal Dig its
  28471   "^DD",101. 41,101.416 ,.03,21,0)
  28472   ^^2^2^2960 717^
  28473   "^DD",101. 41,101.416 ,.03,21,1, 0)
  28474   In the cas e of multi ple answer s for the  same item,  this iden tifies the
  28475   "^DD",101. 41,101.416 ,.03,21,2, 0)
  28476   individual  instance.
  28477   "^DD",101. 41,101.416 ,.03,"DT")
  28478   2960717
  28479   "^DD",101. 41,101.416 ,1,0)
  28480   VALUE^FO^^ 1;1^K:$L(X )>245!($L( X)<1) X
  28481   "^DD",101. 41,101.416 ,1,2)
  28482   S Y(0)=Y S  Y=$$OUTPU T^ORCMEDT5 (Y)
  28483   "^DD",101. 41,101.416 ,1,2.1)
  28484   S Y=$$OUTP UT^ORCMEDT 5(Y)
  28485   "^DD",101. 41,101.416 ,1,3)
  28486   Answer mus t be 1-245  character s in lengt h.
  28487   "^DD",101. 41,101.416 ,1,21,0)
  28488   ^^2^2^2971 219^^
  28489   "^DD",101. 41,101.416 ,1,21,1,0)
  28490   This conta ins the ac tual respo nse, unles s the valu e is a wor d processi ng
  28491   "^DD",101. 41,101.416 ,1,21,2,0)
  28492   type.
  28493   "^DD",101. 41,101.416 ,1,"DT")
  28494   2980717
  28495   "^DD",101. 41,101.416 ,2,0)
  28496   TEXT^101.4 162^^2;0
  28497   "^DD",101. 41,101.416 ,2,21,0)
  28498   ^^1^1^2971 219^
  28499   "^DD",101. 41,101.416 ,2,21,1,0)
  28500   This conta ins the ac tual respo nse, for w ord-proces sing type  prompts.
  28501   "^DD",101. 41,101.416 ,2,"DT")
  28502   2960717
  28503   "^DD",101. 41,101.416 2,0)
  28504   TEXT SUB-F IELD^^.01^ 1
  28505   "^DD",101. 41,101.416 2,0,"DT")
  28506   2960717
  28507   "^DD",101. 41,101.416 2,0,"NM"," TEXT")
  28508  
  28509   "^DD",101. 41,101.416 2,0,"UP")
  28510   101.416
  28511   "^DD",101. 41,101.416 2,.01,0)
  28512   TEXT^WL^^0 ;1^Q
  28513   "^DD",101. 41,101.416 2,.01,21,0 )
  28514   ^^1^1^2960 717^^
  28515   "^DD",101. 41,101.416 2,.01,21,1 ,0)
  28516   This conta ins respon ses to ite ms that ar e a word p rocessing  type.
  28517   "^DD",101. 41,101.416 2,.01,"DT" )
  28518   2960717
  28519   "^DD",560, 560,0)
  28520   FIELD^^.04 ^7
  28521   "^DD",560, 560,0,"DT" )
  28522   3140407
  28523   "^DD",560, 560,0,"IX" ,"B",560,. 01)
  28524  
  28525   "^DD",560, 560,0,"NM" ,"VPR SUBS CRIPTION")
  28526  
  28527   "^DD",560, 560,0,"VRP K")
  28528   VPR
  28529   "^DD",560, 560,.01,0)
  28530   SERVER^RF^ ^0;1^K:$L( X)>64!($L( X)<1)!'(X' ?1P.E) X
  28531   "^DD",560, 560,.01,1, 0)
  28532   ^.1^^-1
  28533   "^DD",560, 560,.01,1, 1,0)
  28534   560^B
  28535   "^DD",560, 560,.01,1, 1,1)
  28536   S ^VPR(560 ,"B",$E(X, 1,64),DA)= ""
  28537   "^DD",560, 560,.01,1, 1,2)
  28538   K ^VPR(560 ,"B",$E(X, 1,64),DA)
  28539   "^DD",560, 560,.01,3)
  28540   Answer mus t be 1-64  characters  in length .
  28541   "^DD",560, 560,.01,21 ,0)
  28542   ^.001^1^1^ 3140212^^^ ^
  28543   "^DD",560, 560,.01,21 ,1,0)
  28544   This is th e name of  the client  system th at is subs cribing to  data upda tes.
  28545   "^DD",560, 560,.01,"D T")
  28546   3120522
  28547   "^DD",560, 560,.02,0)
  28548   LASTUPDATE ^F^^0;2^K: $L(X)>100! ($L(X)<3)  X
  28549   "^DD",560, 560,.02,3)
  28550   Answer mus t be 3-100  character s in lengt h. (Do not  modified)
  28551   "^DD",560, 560,.02,21 ,0)
  28552   ^^3^3^3110 908^
  28553   "^DD",560, 560,.02,21 ,1,0)
  28554   This field  holds a f lag, indic ating if t his URL sh ould be no tified via  the
  28555   "^DD",560, 560,.02,21 ,2,0)
  28556   nightly sc heduled op tion VPR A PPOINTMENT S of the l ist of pat ients expe cted
  28557   "^DD",560, 560,.02,21 ,3,0)
  28558   to be seen  tomorrow.
  28559   "^DD",560, 560,.02,"D T")
  28560   3140225
  28561   "^DD",560, 560,.03,0)
  28562   OPERATION  DATA^S^0:U NSUBCRIBED ;1:SUBSCRI BED;2:INIT IALIZED;^0 ;3^Q
  28563   "^DD",560, 560,.03,3)
  28564   Enter YES  if the hmp  server ha s received  a sync of  operation al data (D o Not Modi fied)
  28565   "^DD",560, 560,.03,21 ,0)
  28566   ^^2^2^3110 908^
  28567   "^DD",560, 560,.03,21 ,1,0)
  28568   This field  holds a f lag, indic ating if t his URL sh ould be no tified via  http
  28569   "^DD",560, 560,.03,21 ,2,0)
  28570   when a pat ient is ad mitted.
  28571   "^DD",560, 560,.03,"D T")
  28572   3140226
  28573   "^DD",560, 560,.04,0)
  28574   REPEAT POL LS^NJ8,0^^ 0;4^K:+X'= X!(X>99999 999)!(X<0) !(X?.E1"." 1N.N) X
  28575   "^DD",560, 560,.04,3)
  28576   Type a num ber betwee n 0 and 99 999999, 0  decimal di gits.
  28577   "^DD",560, 560,.04,21 ,0)
  28578   ^^2^2^3140 407^
  28579   "^DD",560, 560,.04,21 ,1,0)
  28580   This track s the numb er of time s the same  "last upd ate" value  has been 
  28581   "^DD",560, 560,.04,21 ,2,0)
  28582   repeated.   A high re peat may b e normal i f data are  not chang ing.
  28583   "^DD",560, 560,.04,"D T")
  28584   3140407
  28585   "^DD",560, 560,.1,0)
  28586   URL^F^^.1; 1^K:$L(X)> 250!($L(X) <1) X
  28587   "^DD",560, 560,.1,3)
  28588   Answer mus t be 1-250  character s in lengt h.
  28589   "^DD",560, 560,.1,21, 0)
  28590   ^^1^1^3110 706^
  28591   "^DD",560, 560,.1,21, 1,0)
  28592   This is th e fully sp ecified UR L to call  when updat es are ava ilable.
  28593   "^DD",560, 560,.1,"DT ")
  28594   3110706
  28595   "^DD",560, 560,1,0)
  28596   PATIENT^56 0.01P^^1;0
  28597   "^DD",560, 560,1,21,0 )
  28598   ^.001^1^1^ 3140212^^^ ^
  28599   "^DD",560, 560,1,21,1 ,0)
  28600   This is a  patient th at will be  monitored  for new d ata and up dates.
  28601   "^DD",560, 560,2,0)
  28602   ROSTER^560 .02P^^2;0
  28603   "^DD",560, 560,2,21,0 )
  28604   ^.001^1^1^ 3130417^^^ ^
  28605   "^DD",560, 560,2,21,1 ,0)
  28606   This is a  roster tha t will be  monitored  for new pa tients and  updates.
  28607   "^DD",560, 560,2,"DT" )
  28608   3130417
  28609   "^DD",560, 560.01,0)
  28610   PATIENT SU B-FIELD^^2 ^2
  28611   "^DD",560, 560.01,0," DT")
  28612   3140225
  28613   "^DD",560, 560.01,0," NM","PATIE NT")
  28614  
  28615   "^DD",560, 560.01,0," UP")
  28616   560
  28617   "^DD",560, 560.01,.01 ,0)
  28618   PATIENT NA ME^MP2'X^D PT(^0;1^S  DINUM=X
  28619   "^DD",560, 560.01,.01 ,1,0)
  28620   ^.1^^0
  28621   "^DD",560, 560.01,.01 ,3)
  28622   Enter the  name of a  patient to  be tracke d.
  28623   "^DD",560, 560.01,.01 ,21,0)
  28624   ^.001^1^1^ 3140212^^
  28625   "^DD",560, 560.01,.01 ,21,1,0)
  28626   This is th e name of  the patien t being mo nitored fo r new data .
  28627   "^DD",560, 560.01,.01 ,"DT")
  28628   3140226
  28629   "^DD",560, 560.01,2,0 )
  28630   STATUS^S^0 :UNSUBSCRI BED;1:SUBS CRIBED;2:I NITIALIZED ;^0;2^Q
  28631   "^DD",560, 560.01,2,3 )
  28632   Tracks the  status of  a patient  sync. (Do  Not Modif ied)
  28633   "^DD",560, 560.01,2,2 1,0)
  28634   ^.001^3^3^ 3130417^^^
  28635   "^DD",560, 560.01,2,2 1,1,0)
  28636   This field  turns on  the Data M onitor for  this pati ent and cl ient syste m.
  28637   "^DD",560, 560.01,2,2 1,2,0)
  28638   If ON=true , new data  for this  patient wi ll be sent  to the cl ient when
  28639   "^DD",560, 560.01,2,2 1,3,0)
  28640   updates ar e requeste d.
  28641   "^DD",560, 560.01,2," DT")
  28642   3140226
  28643   "^DD",560, 560.02,0)
  28644   ROSTER SUB -FIELD^^2^ 2
  28645   "^DD",560, 560.02,0," DT")
  28646   3130417
  28647   "^DD",560, 560.02,0," NM","ROSTE R")
  28648  
  28649   "^DD",560, 560.02,0," UP")
  28650   560
  28651   "^DD",560, 560.02,.01 ,0)
  28652   NAME^MP561 .2'X^VPROS TER(^0;1^S  DINUM=X
  28653   "^DD",560, 560.02,.01 ,1,0)
  28654   ^.1^^0
  28655   "^DD",560, 560.02,.01 ,3)
  28656   Enter the  name of a  roster to  be tracked .
  28657   "^DD",560, 560.02,.01 ,21,0)
  28658   ^.001^1^1^ 3130417^^
  28659   "^DD",560, 560.02,.01 ,21,1,0)
  28660   This is th e name of  the roster  being mon itored for  new patie nts.
  28661   "^DD",560, 560.02,.01 ,"DT")
  28662   3130417
  28663   "^DD",560, 560.02,2,0 )
  28664   ON^S^1:YES ;0:NO;^0;2 ^Q
  28665   "^DD",560, 560.02,2,3 )
  28666   Enter YES  to turn on  data trac king for t his roster .
  28667   "^DD",560, 560.02,2,2 1,0)
  28668   ^.001^3^3^ 3130417^^
  28669   "^DD",560, 560.02,2,2 1,1,0)
  28670   This field  turns on  the Data M onitor for  this rost er and cli ent system .
  28671   "^DD",560, 560.02,2,2 1,2,0)
  28672   If ON=true , a new sn apshot of  this roste r will be  sent to th e client
  28673   "^DD",560, 560.02,2,2 1,3,0)
  28674   when new d ata update s are requ ested.
  28675   "^DD",560, 560.02,2," DT")
  28676   3130417
  28677   "^DD",560. 1,560.1,0)
  28678   FIELD^^1^4
  28679   "^DD",560. 1,560.1,0, "DT")
  28680   3121129
  28681   "^DD",560. 1,560.1,0, "IX","B",5 60.1,.01)
  28682  
  28683   "^DD",560. 1,560.1,0, "NM","VPR  PATIENT OB JECT")
  28684  
  28685   "^DD",560. 1,560.1,0, "VRPK")
  28686   VPR
  28687   "^DD",560. 1,560.1,.0 1,0)
  28688   UID^RF^^0; 1^K:$L(X)> 63!($L(X)< 3)!'(X'?1P .E) X
  28689   "^DD",560. 1,560.1,.0 1,1,0)
  28690   ^.1
  28691   "^DD",560. 1,560.1,.0 1,1,1,0)
  28692   560.1^B
  28693   "^DD",560. 1,560.1,.0 1,1,1,1)
  28694   S ^VPR(560 .1,"B",$E( X,1,63),DA )=""
  28695   "^DD",560. 1,560.1,.0 1,1,1,2)
  28696   K ^VPR(560 .1,"B",$E( X,1,63),DA )
  28697   "^DD",560. 1,560.1,.0 1,3)
  28698   Answer mus t be 3-63  characters  in length .
  28699   "^DD",560. 1,560.1,.0 1,21,0)
  28700   ^^1^1^3121 129^
  28701   "^DD",560. 1,560.1,.0 1,21,1,0)
  28702   The fully  specified  Universal  ID string  for this o bject.
  28703   "^DD",560. 1,560.1,.0 1,23,0)
  28704   ^^1^1^3121 129^
  28705   "^DD",560. 1,560.1,.0 1,23,1,0)
  28706   urn:va:{sy stemId}:{D FN}:{colle ction}:{ie n}
  28707   "^DD",560. 1,560.1,.0 1,"DT")
  28708   3121129
  28709   "^DD",560. 1,560.1,.0 2,0)
  28710   PATIENT^RP 2'^DPT(^0; 2^Q
  28711   "^DD",560. 1,560.1,.0 2,3)
  28712   Enter the  patient th at owns th is object.
  28713   "^DD",560. 1,560.1,.0 2,21,0)
  28714   ^^1^1^3121 129^
  28715   "^DD",560. 1,560.1,.0 2,21,1,0)
  28716   Patient fi le #2 ien
  28717   "^DD",560. 1,560.1,.0 2,"DT")
  28718   3121129
  28719   "^DD",560. 1,560.1,.0 3,0)
  28720   COLLECTION ^F^^0;3^K: $L(X)>30!( $L(X)<3) X
  28721   "^DD",560. 1,560.1,.0 3,3)
  28722   Answer mus t be 3-30  characters  in length .
  28723   "^DD",560. 1,560.1,.0 3,21,0)
  28724   ^^1^1^3121 129^
  28725   "^DD",560. 1,560.1,.0 3,21,1,0)
  28726   The name o f the type  or kind o f data thi s object b elongs to.
  28727   "^DD",560. 1,560.1,.0 3,"DT")
  28728   3121129
  28729   "^DD",560. 1,560.1,1, 0)
  28730   DATA^560.1 01^^1;0
  28731   "^DD",560. 1,560.101, 0)
  28732   DATA SUB-F IELD^^.01^ 1
  28733   "^DD",560. 1,560.101, 0,"DT")
  28734   3121129
  28735   "^DD",560. 1,560.101, 0,"NM","DA TA")
  28736  
  28737   "^DD",560. 1,560.101, 0,"UP")
  28738   560.1
  28739   "^DD",560. 1,560.101, .01,0)
  28740   DATA^Wx^^0 ;1^Q
  28741   "^DD",560. 1,560.101, .01,21,0)
  28742   ^^1^1^3121 129^
  28743   "^DD",560. 1,560.101, .01,21,1,0 )
  28744   JSON data  object
  28745   "^DD",560. 1,560.101, .01,"DT")
  28746   3121129
  28747   "^DD",560. 11,560.11, 0)
  28748   FIELD^^1^3
  28749   "^DD",560. 11,560.11, 0,"DT")
  28750   3121129
  28751   "^DD",560. 11,560.11, 0,"IX","B" ,560.11,.0 1)
  28752  
  28753   "^DD",560. 11,560.11, 0,"IX","C" ,560.11,.0 3)
  28754  
  28755   "^DD",560. 11,560.11, 0,"NM","VP R OBJECT")
  28756  
  28757   "^DD",560. 11,560.11, 0,"VRPK")
  28758   VPR
  28759   "^DD",560. 11,560.11, .01,0)
  28760   UID^RF^^0; 1^K:$L(X)> 63!($L(X)< 3)!'(X'?1P .E) X
  28761   "^DD",560. 11,560.11, .01,1,0)
  28762   ^.1
  28763   "^DD",560. 11,560.11, .01,1,1,0)
  28764   560.11^B
  28765   "^DD",560. 11,560.11, .01,1,1,1)
  28766   S ^VPR(560 .11,"B",$E (X,1,63),D A)=""
  28767   "^DD",560. 11,560.11, .01,1,1,2)
  28768   K ^VPR(560 .11,"B",$E (X,1,63),D A)
  28769   "^DD",560. 11,560.11, .01,3)
  28770   Answer mus t be 3-63  characters  in length .
  28771   "^DD",560. 11,560.11, .01,21,0)
  28772   ^^1^1^3121 129^
  28773   "^DD",560. 11,560.11, .01,21,1,0 )
  28774   The fully  specified  Universal  ID string  for this o bject.
  28775   "^DD",560. 11,560.11, .01,23,0)
  28776   ^^1^1^3121 129^
  28777   "^DD",560. 11,560.11, .01,23,1,0 )
  28778   urn:va:{co llection}: {systemId} :{ien}
  28779   "^DD",560. 11,560.11, .01,"DT")
  28780   3121129
  28781   "^DD",560. 11,560.11, .03,0)
  28782   COLLECTION ^F^^0;3^K: $L(X)>30!( $L(X)<3) X
  28783   "^DD",560. 11,560.11, .03,1,0)
  28784   ^.1
  28785   "^DD",560. 11,560.11, .03,1,1,0)
  28786   560.11^C
  28787   "^DD",560. 11,560.11, .03,1,1,1)
  28788   S ^VPR(560 .11,"C",$E (X,1,30),D A)=""
  28789   "^DD",560. 11,560.11, .03,1,1,2)
  28790   K ^VPR(560 .11,"C",$E (X,1,30),D A)
  28791   "^DD",560. 11,560.11, .03,1,1,"D T")
  28792   3121129
  28793   "^DD",560. 11,560.11, .03,3)
  28794   Answer mus t be 3-30  characters  in length .
  28795   "^DD",560. 11,560.11, .03,21,0)
  28796   ^^1^1^3121 129^
  28797   "^DD",560. 11,560.11, .03,21,1,0 )
  28798   The name o f the type  or kind o f data thi s object b elongs to.
  28799   "^DD",560. 11,560.11, .03,"DT")
  28800   3121129
  28801   "^DD",560. 11,560.11, 1,0)
  28802   DATA^560.1 11^^1;0
  28803   "^DD",560. 11,560.111 ,0)
  28804   DATA SUB-F IELD^^.01^ 1
  28805   "^DD",560. 11,560.111 ,0,"DT")
  28806   3121129
  28807   "^DD",560. 11,560.111 ,0,"NM","D ATA")
  28808  
  28809   "^DD",560. 11,560.111 ,0,"UP")
  28810   560.11
  28811   "^DD",560. 11,560.111 ,.01,0)
  28812   DATA^Wx^^0 ;1^Q
  28813   "^DD",560. 11,560.111 ,.01,21,0)
  28814   ^^1^1^3121 129^
  28815   "^DD",560. 11,560.111 ,.01,21,1, 0)
  28816   JSON data  object
  28817   "^DD",560. 11,560.111 ,.01,"DT")
  28818   3121129
  28819   "^DD",561, 561,0)
  28820   FIELD^^.03 ^4
  28821   "^DD",561, 561,0,"DDA ")
  28822   N
  28823   "^DD",561, 561,0,"DT" )
  28824   3110729
  28825   "^DD",561, 561,0,"IX" ,"B",561,. 01)
  28826  
  28827   "^DD",561, 561,0,"IX" ,"C",561,. 03)
  28828  
  28829   "^DD",561, 561,0,"NM" ,"VPR PANE L")
  28830  
  28831   "^DD",561, 561,0,"PT" ,561.21,.0 2)
  28832  
  28833   "^DD",561, 561,0,"VRP K")
  28834   VPR
  28835   "^DD",561, 561,.01,0)
  28836   NAME^R*P81 0.4'^PXRM( 810.4,^0;1 ^S DIC("S" )="I $P(^( 0),U,3)=3"  D ^DIC K  DIC S DIC= DIE,X=+Y K :Y<0 X
  28837   "^DD",561, 561,.01,1, 0)
  28838   ^.1
  28839   "^DD",561, 561,.01,1, 1,0)
  28840   561^B
  28841   "^DD",561, 561,.01,1, 1,1)
  28842   S ^VPRPANE L("B",$E(X ,1,30),DA) =""
  28843   "^DD",561, 561,.01,1, 1,2)
  28844   K ^VPRPANE L("B",$E(X ,1,30),DA)
  28845   "^DD",561, 561,.01,3)
  28846  
  28847   "^DD",561, 561,.01,12 )
  28848   Only selec t RULE SET  types
  28849   "^DD",561, 561,.01,12 .1)
  28850   S DIC("S") ="I $P(^(0 ),U,3)=3"
  28851   "^DD",561, 561,.01,"D T")
  28852   3110629
  28853   "^DD",561, 561,.02,0)
  28854   DISPLAY NA ME^RF^^0;2 ^K:$L(X)>5 0!($L(X)<3 ) X
  28855   "^DD",561, 561,.02,3)
  28856   Answer mus t be 3-50  characters  in length .
  28857   "^DD",561, 561,.02,"D T")
  28858   3110630
  28859   "^DD",561, 561,.03,0)
  28860   PATIENT LI ST NAME^F^ ^0;3^K:$L( X)>40!($L( X)<3) X
  28861   "^DD",561, 561,.03,1, 0)
  28862   ^.1
  28863   "^DD",561, 561,.03,1, 1,0)
  28864   561^C
  28865   "^DD",561, 561,.03,1, 1,1)
  28866   S ^VPRPANE L("C",$E(X ,1,30),DA) =""
  28867   "^DD",561, 561,.03,1, 1,2)
  28868   K ^VPRPANE L("C",$E(X ,1,30),DA)
  28869   "^DD",561, 561,.03,1, 1,"DT")
  28870   3111006
  28871   "^DD",561, 561,.03,3)
  28872   Answer mus t be 3-40  characters  in length .
  28873   "^DD",561, 561,.03,"D T")
  28874   3111006
  28875   "^DD",561, 561,5,0)
  28876   ORDER DIAL OGS^561.05 P^^ORDER D IALOGS;0
  28877   "^DD",561, 561.05,0)
  28878   ORDER DIAL OGS SUB-FI ELD^^.01^1
  28879   "^DD",561, 561.05,0," DT")
  28880   3110629
  28881   "^DD",561, 561.05,0," IX","B",56 1.05,.01)
  28882  
  28883   "^DD",561, 561.05,0," NM","ORDER  DIALOGS")
  28884  
  28885   "^DD",561, 561.05,0," UP")
  28886   561
  28887   "^DD",561, 561.05,.01 ,0)
  28888   ORDER DIAL OGS^MP101. 41'^ORD(10 1.41,^0;1^ Q
  28889   "^DD",561, 561.05,.01 ,1,0)
  28890   ^.1
  28891   "^DD",561, 561.05,.01 ,1,1,0)
  28892   561.05^B
  28893   "^DD",561, 561.05,.01 ,1,1,1)
  28894   S ^VPRPANE L(DA(1),"O RDER DIALO GS","B",$E (X,1,30),D A)=""
  28895   "^DD",561, 561.05,.01 ,1,1,2)
  28896   K ^VPRPANE L(DA(1),"O RDER DIALO GS","B",$E (X,1,30),D A)
  28897   "^DD",561, 561.05,.01 ,"DT")
  28898   3110629
  28899   "^DD",561. 2,561.2,0)
  28900   FIELD^^3^1 0
  28901   "^DD",561. 2,561.2,0, "DT")
  28902   3130717
  28903   "^DD",561. 2,561.2,0, "IX","AB", 561.23,.01 )
  28904  
  28905   "^DD",561. 2,561.2,0, "IX","AC", 561.2,.04)
  28906  
  28907   "^DD",561. 2,561.2,0, "IX","AD", 561.21,.02 )
  28908  
  28909   "^DD",561. 2,561.2,0, "IX","ATS" ,561.2,99)
  28910  
  28911   "^DD",561. 2,561.2,0, "IX","B",5 61.2,.01)
  28912  
  28913   "^DD",561. 2,561.2,0, "NM","VPRO STER")
  28914  
  28915   "^DD",561. 2,561.2,0, "PT",560.0 2,.01)
  28916  
  28917   "^DD",561. 2,561.2,0, "PT",561.2 1,.02)
  28918  
  28919   "^DD",561. 2,561.2,0, "VRPK")
  28920   VPR
  28921   "^DD",561. 2,561.2,.0 1,0)
  28922   NAME^RF^^0 ;1^K:$L(X) >104!($L(X )<3)!'(X'? 1P.E) X
  28923   "^DD",561. 2,561.2,.0 1,1,0)
  28924   ^.1
  28925   "^DD",561. 2,561.2,.0 1,1,1,0)
  28926   561.2^B
  28927   "^DD",561. 2,561.2,.0 1,1,1,1)
  28928   S ^VPROSTE R("B",$E(X ,1,30),DA) =""
  28929   "^DD",561. 2,561.2,.0 1,1,1,2)
  28930   K ^VPROSTE R("B",$E(X ,1,30),DA)
  28931   "^DD",561. 2,561.2,.0 1,3)
  28932   Answer mus t be 3-104  character s in lengt h.
  28933   "^DD",561. 2,561.2,.0 1,"DT")
  28934   3130220
  28935   "^DD",561. 2,561.2,.0 2,0)
  28936   DISPLAY NA ME^F^^0;2^ K:$L(X)>45 !($L(X)<3)  X
  28937   "^DD",561. 2,561.2,.0 2,3)
  28938   Answer mus t be 3-45  characters  in length .
  28939   "^DD",561. 2,561.2,.0 2,"DT")
  28940   3110830
  28941   "^DD",561. 2,561.2,.0 3,0)
  28942   DISABLE^S^ 1:YES;^0;3 ^Q
  28943   "^DD",561. 2,561.2,.0 3,3)
  28944   ENTER A 1  OR YES TO  DISABLE TH IS ROSTER.
  28945   "^DD",561. 2,561.2,.0 3,"DT")
  28946   3110830
  28947   "^DD",561. 2,561.2,.0 4,0)
  28948   OWNER^P200 '^VA(200,^ 0;4^Q
  28949   "^DD",561. 2,561.2,.0 4,1,0)
  28950   ^.1
  28951   "^DD",561. 2,561.2,.0 4,1,1,0)
  28952   561.2^AC
  28953   "^DD",561. 2,561.2,.0 4,1,1,1)
  28954   S ^VPROSTE R("AC",$E( X,1,30),DA )=""
  28955   "^DD",561. 2,561.2,.0 4,1,1,2)
  28956   K ^VPROSTE R("AC",$E( X,1,30),DA )
  28957   "^DD",561. 2,561.2,.0 4,1,1,"%D" ,0)
  28958   ^^1^1^3120 105^
  28959   "^DD",561. 2,561.2,.0 4,1,1,"%D" ,1,0)
  28960   Index all  rosters by  owner.
  28961   "^DD",561. 2,561.2,.0 4,1,1,"DT" )
  28962   3120105
  28963   "^DD",561. 2,561.2,.0 4,3)
  28964   ENTER THE  OWNER OF T HIS ROSTER
  28965   "^DD",561. 2,561.2,.0 4,"DT")
  28966   3120105
  28967   "^DD",561. 2,561.2,.0 5,0)
  28968   TYPE^RS^PU :PUBLIC;PR :PRIVATE;^ 0;5^Q
  28969   "^DD",561. 2,561.2,.0 5,"DT")
  28970   3111115
  28971   "^DD",561. 2,561.2,.0 6,0)
  28972   PATIENT LI ST NAME^F^ ^0;6^K:$L( X)>40!($L( X)<3) X
  28973   "^DD",561. 2,561.2,.0 6,3)
  28974   Answer mus t be 3-40  characters  in length .
  28975   "^DD",561. 2,561.2,.0 6,"DT")
  28976   3120120
  28977   "^DD",561. 2,561.2,1, 0)
  28978   SOURCES^56 1.21^^1;0
  28979   "^DD",561. 2,561.2,2, 0)
  28980   SPECIAL HA NDLING^K^^ 3;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  28981   "^DD",561. 2,561.2,2, 3)
  28982   This is St andard MUM PS code.
  28983   "^DD",561. 2,561.2,2, 9)
  28984   @
  28985   "^DD",561. 2,561.2,2, "DT")
  28986   3120103
  28987   "^DD",561. 2,561.2,3, 0)
  28988   PATIENT^56 1.23P^^4;0
  28989   "^DD",561. 2,561.2,99 ,0)
  28990   TIMESTAMP^ D^^2;1^S % DT="ESTXR"  D ^%DT S  X=Y K:3110 830.0839>X  X
  28991   "^DD",561. 2,561.2,99 ,1,0)
  28992   ^.1
  28993   "^DD",561. 2,561.2,99 ,1,1,0)
  28994   561.2^ATS
  28995   "^DD",561. 2,561.2,99 ,1,1,1)
  28996   S ^VPROSTE R("ATS",$E (X,1,30),D A)=""
  28997   "^DD",561. 2,561.2,99 ,1,1,2)
  28998   K ^VPROSTE R("ATS",$E (X,1,30),D A)
  28999   "^DD",561. 2,561.2,99 ,1,1,"DT")
  29000   3110831
  29001   "^DD",561. 2,561.2,99 ,3)
  29002   Type a dat e not earl ier than A UG 30, 201 1@08:39.
  29003   "^DD",561. 2,561.2,99 ,"DT")
  29004   3110831
  29005   "^DD",561. 2,561.21,0 )
  29006   SOURCES SU B-FIELD^^. 05^5
  29007   "^DD",561. 2,561.21,0 ,"DT")
  29008   3120119
  29009   "^DD",561. 2,561.21,0 ,"IX","AS" ,561.21,.0 1)
  29010  
  29011   "^DD",561. 2,561.21,0 ,"IX","B", 561.21,.01 )
  29012  
  29013   "^DD",561. 2,561.21,0 ,"NM","SOU RCES")
  29014  
  29015   "^DD",561. 2,561.21,0 ,"UP")
  29016   561.2
  29017   "^DD",561. 2,561.21,. 01,0)
  29018   SEQUENCE^M NJ8,0^^0;1 ^K:+X'=X!( X>99999999 )!(X<1)!(X ?.E1"."1.N ) X
  29019   "^DD",561. 2,561.21,. 01,1,0)
  29020   ^.1
  29021   "^DD",561. 2,561.21,. 01,1,1,0)
  29022   561.21^B
  29023   "^DD",561. 2,561.21,. 01,1,1,1)
  29024   S ^VPROSTE R(DA(1),1, "B",$E(X,1 ,30),DA)=" "
  29025   "^DD",561. 2,561.21,. 01,1,1,2)
  29026   K ^VPROSTE R(DA(1),1, "B",$E(X,1 ,30),DA)
  29027   "^DD",561. 2,561.21,. 01,1,2,0)
  29028   561.21^AS
  29029   "^DD",561. 2,561.21,. 01,1,2,1)
  29030   S ^VPROSTE R(DA(1),1, "AS",$E(X, 1,30),DA)= ""
  29031   "^DD",561. 2,561.21,. 01,1,2,2)
  29032   K ^VPROSTE R(DA(1),1, "AS",$E(X, 1,30),DA)
  29033   "^DD",561. 2,561.21,. 01,1,2,"DT ")
  29034   3110901
  29035   "^DD",561. 2,561.21,. 01,3)
  29036   Type a num ber betwee n 1 and 99 999999, 0  decimal di gits.
  29037   "^DD",561. 2,561.21,. 01,"DT")
  29038   3110901
  29039   "^DD",561. 2,561.21,. 02,0)
  29040   SOURCE^RV^ ^0;2^Q
  29041   "^DD",561. 2,561.21,. 02,1,0)
  29042   ^.1
  29043   "^DD",561. 2,561.21,. 02,1,1,0)
  29044   561.2^AD
  29045   "^DD",561. 2,561.21,. 02,1,1,1)
  29046   S ^VPROSTE R("AD",$E( X,1,30),DA (1),DA)=""
  29047   "^DD",561. 2,561.21,. 02,1,1,2)
  29048   K ^VPROSTE R("AD",$E( X,1,30),DA (1),DA)
  29049   "^DD",561. 2,561.21,. 02,1,1,"DT ")
  29050   3131126
  29051   "^DD",561. 2,561.21,. 02,3)
  29052   ENTER FILE  WHICH WIL L BE THE S OURCE FOR  THIS ROSTE R
  29053   "^DD",561. 2,561.21,. 02,"DT")
  29054   3131126
  29055   "^DD",561. 2,561.21,. 02,"V",0)
  29056   ^.12P^12^1 0
  29057   "^DD",561. 2,561.21,. 02,"V",1,0 )
  29058   2^PATIENT^ 1^PAT^n^n
  29059   "^DD",561. 2,561.21,. 02,"V",1,1 )
  29060  
  29061   "^DD",561. 2,561.21,. 02,"V",1,2 )
  29062  
  29063   "^DD",561. 2,561.21,. 02,"V",2,0 )
  29064   42^WARD LO CATION^2^W ARD^n^n
  29065   "^DD",561. 2,561.21,. 02,"V",2,1 )
  29066  
  29067   "^DD",561. 2,561.21,. 02,"V",2,2 )
  29068  
  29069   "^DD",561. 2,561.21,. 02,"V",3,0 )
  29070   44^CLINIC^ 3^CL^n^n
  29071   "^DD",561. 2,561.21,. 02,"V",3,1 )
  29072  
  29073   "^DD",561. 2,561.21,. 02,"V",3,2 )
  29074  
  29075   "^DD",561. 2,561.21,. 02,"V",5,0 )
  29076   200^PROVID ER^5^PROV^ n^n
  29077   "^DD",561. 2,561.21,. 02,"V",5,1 )
  29078  
  29079   "^DD",561. 2,561.21,. 02,"V",5,2 )
  29080  
  29081   "^DD",561. 2,561.21,. 02,"V",6,0 )
  29082   100.21^CPR S^6^CPRS^n ^n
  29083   "^DD",561. 2,561.21,. 02,"V",6,1 )
  29084  
  29085   "^DD",561. 2,561.21,. 02,"V",6,2 )
  29086  
  29087   "^DD",561. 2,561.21,. 02,"V",7,0 )
  29088   404.51^PCM M TEAM^7^P CMM^n^n
  29089   "^DD",561. 2,561.21,. 02,"V",7,1 )
  29090  
  29091   "^DD",561. 2,561.21,. 02,"V",7,2 )
  29092  
  29093   "^DD",561. 2,561.21,. 02,"V",8,0 )
  29094   810.4^REMI NDER'S LIS T RULE FIL E^22^PXRM^ y^n
  29095   "^DD",561. 2,561.21,. 02,"V",8,1 )
  29096   S DIC("S") ="I $P(^(0 ),U,3)=3"
  29097   "^DD",561. 2,561.21,. 02,"V",8,2 )
  29098   Only selec t Rule Set  types
  29099   "^DD",561. 2,561.21,. 02,"V",9,0 )
  29100   561.2^VPR  ROSTER FIL E^9^ROST^^ n
  29101   "^DD",561. 2,561.21,. 02,"V",11, 0)
  29102   45.7^SPECI ALTY^70^SP EC^n^n
  29103   "^DD",561. 2,561.21,. 02,"V",12, 0)
  29104   561^Select  VPR Panel  List Rule ^80^VPRPAN ^n^n
  29105   "^DD",561. 2,561.21,. 03,0)
  29106   OPERATION^ S^0:UNION; 1:INTERSEC TION;2:DIF FERENCE;^0 ;3^Q
  29107   "^DD",561. 2,561.21,. 03,"DT")
  29108   3110830
  29109   "^DD",561. 2,561.21,. 04,0)
  29110   FILTER^S^T :TODAY;^0; 4^Q
  29111   "^DD",561. 2,561.21,. 04,3)
  29112  
  29113   "^DD",561. 2,561.21,. 04,"DT")
  29114   3110901
  29115   "^DD",561. 2,561.21,. 05,0)
  29116   REFRESH FR EQUENCY^S^ D:DAILY;H: HOURLY;^0; 5^Q
  29117   "^DD",561. 2,561.21,. 05,3)
  29118  
  29119   "^DD",561. 2,561.21,. 05,"DT")
  29120   3120119
  29121   "^DD",561. 2,561.23,0 )
  29122   PATIENT SU B-FIELD^^. 02^2
  29123   "^DD",561. 2,561.23,0 ,"DT")
  29124   3130717
  29125   "^DD",561. 2,561.23,0 ,"IX","B", 561.23,.01 )
  29126  
  29127   "^DD",561. 2,561.23,0 ,"NM","PAT IENT")
  29128  
  29129   "^DD",561. 2,561.23,0 ,"UP")
  29130   561.2
  29131   "^DD",561. 2,561.23,. 01,0)
  29132   PATIENT^MP 2'^DPT(^0; 1^Q
  29133   "^DD",561. 2,561.23,. 01,1,0)
  29134   ^.1
  29135   "^DD",561. 2,561.23,. 01,1,1,0)
  29136   561.23^B
  29137   "^DD",561. 2,561.23,. 01,1,1,1)
  29138   S ^VPROSTE R(DA(1),4, "B",$E(X,1 ,30),DA)=" "
  29139   "^DD",561. 2,561.23,. 01,1,1,2)
  29140   K ^VPROSTE R(DA(1),4, "B",$E(X,1 ,30),DA)
  29141   "^DD",561. 2,561.23,. 01,1,2,0)
  29142   561.2^AB
  29143   "^DD",561. 2,561.23,. 01,1,2,1)
  29144   S ^VPROSTE R("AB",$E( X,1,30),DA (1),DA)=""
  29145   "^DD",561. 2,561.23,. 01,1,2,2)
  29146   K ^VPROSTE R("AB",$E( X,1,30),DA (1),DA)
  29147   "^DD",561. 2,561.23,. 01,1,2,"%D ",0)
  29148   ^^1^1^3121 220^
  29149   "^DD",561. 2,561.23,. 01,1,2,"%D ",1,0)
  29150   Index of a ll rosters  patient i s in.
  29151   "^DD",561. 2,561.23,. 01,1,2,"DT ")
  29152   3121220
  29153   "^DD",561. 2,561.23,. 01,"DT")
  29154   3121220
  29155   "^DD",561. 2,561.23,. 02,0)
  29156   SRCSEQ^NJ6 ,0^^0;2^K: +X'=X!(X>9 99999)!(X< 1)!(X?.E1" ."1N.N) X
  29157   "^DD",561. 2,561.23,. 02,3)
  29158   Type a num ber betwee n 1 and 99 9999, 0 de cimal digi ts.
  29159   "^DD",561. 2,561.23,. 02,"DT")
  29160   3130717
  29161   "^DIC",100 .98,100.98 ,0)
  29162   DISPLAY GR OUP^100.98 I
  29163   "^DIC",100 .98,100.98 ,0,"GL")
  29164   ^ORD(100.9 8,
  29165   "^DIC",100 .98,100.98 ,"%D",0)
  29166   ^^5^5^2971 218^^^^
  29167   "^DIC",100 .98,100.98 ,"%D",1,0)
  29168   This file  allows ord ers to be  clustered  in groups  other than  by packag e.
  29169   "^DIC",100 .98,100.98 ,"%D",2,0)
  29170   It is simi lar in str ucture to  the OPTION  File (19) .  This al lows displ ay
  29171   "^DIC",100 .98,100.98 ,"%D",3,0)
  29172   groups to  be arrange d in a hie rarchy.  T he main en try in thi s file
  29173   "^DIC",100 .98,100.98 ,"%D",4,0)
  29174   should be  'ALL SERVI CES'.  Oth er entries  should be  logically  subordina te
  29175   "^DIC",100 .98,100.98 ,"%D",5,0)
  29176   to the 'AL L SERVICES ' entry.
  29177   "^DIC",100 .98,"B","D ISPLAY GRO UP",100.98 )
  29178  
  29179   "^DIC",101 .41,101.41 ,0)
  29180   ORDER DIAL OG^101.41
  29181   "^DIC",101 .41,101.41 ,0,"GL")
  29182   ^ORD(101.4 1,
  29183   "^DIC",101 .41,101.41 ,"%D",0)
  29184   ^^2^2^2960 819^^
  29185   "^DIC",101 .41,101.41 ,"%D",1,0)
  29186   This file  contains t he informa tion neede d to defin e how to p rompt for  each
  29187   "^DIC",101 .41,101.41 ,"%D",2,0)
  29188   order, wha t values a re accepta ble, etc.
  29189   "^DIC",101 .41,"B","O RDER DIALO G",101.41)
  29190  
  29191   "^DIC",560 ,560,0)
  29192   VPR SUBSCR IPTION^560
  29193   "^DIC",560 ,560,0,"GL ")
  29194   ^VPR(560,
  29195   "^DIC",560 ,"B","VPR  SUBSCRIPTI ON",560)
  29196  
  29197   "^DIC",560 .1,560.1,0 )
  29198   VPR PATIEN T OBJECT^5 60.1
  29199   "^DIC",560 .1,560.1,0 ,"GL")
  29200   ^VPR(560.1 ,
  29201   "^DIC",560 .1,560.1," %",0)
  29202   ^1.005^^0
  29203   "^DIC",560 .1,"B","VP R PATIENT  OBJECT",56 0.1)
  29204  
  29205   "^DIC",560 .11,560.11 ,0)
  29206   VPR OBJECT ^560.11
  29207   "^DIC",560 .11,560.11 ,0,"GL")
  29208   ^VPR(560.1 1,
  29209   "^DIC",560 .11,"B","V PR OBJECT" ,560.11)
  29210  
  29211   "^DIC",561 ,561,0)
  29212   VPR PANEL^ 561
  29213   "^DIC",561 ,561,0,"GL ")
  29214   ^VPRPANEL(
  29215   "^DIC",561 ,561,"%",0 )
  29216   ^1.005^1^1
  29217   "^DIC",561 ,561,"%",1 ,0)
  29218   VPR
  29219   "^DIC",561 ,561,"%"," B","VPR",1 )
  29220  
  29221   "^DIC",561 ,561,"%D", 0)
  29222   ^1.001^4^4 ^3110701^^ ^
  29223   "^DIC",561 ,561,"%D", 1,0)
  29224   Contains t he Rule Se ts that co ntain the  cohorts fo r creating  patient p anels.
  29225   "^DIC",561 ,561,"%D", 2,0)
  29226   For exampl e, panel w hich inclu des Diabet ic patient s will be  created
  29227   "^DIC",561 ,561,"%D", 3,0)
  29228   nightly to  update th e list of  patients.   All panel s in this  file will  be
  29229   "^DIC",561 ,561,"%D", 4,0)
  29230   updated ni ghtly.
  29231   "^DIC",561 ,"B","VPR  PANEL",561 )
  29232  
  29233   "^DIC",561 .2,561.2,0 )
  29234   VPROSTER^5 61.2
  29235   "^DIC",561 .2,561.2,0 ,"GL")
  29236   ^VPROSTER(
  29237   "^DIC",561 .2,"B","VP ROSTER",56 1.2)
  29238  
  29239   **END**
  29240   **END**