6. EPMO Open Source Coordination Office Redaction File Detail Report

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

6.1 Files compared

# Location File Last Modified
1 ehmp.zip\ehmp\ehmp\product\production\hmp\src\kids PX_1-0_215V3.KID Tue Jan 10 16:20:50 2017 UTC
2 ehmp.zip\ehmp\ehmp\product\production\hmp\src\kids PX_1-0_215V3.KID Mon Oct 2 20:26:23 2017 UTC

6.2 Comparison summary

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

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

6.4 Active regular expressions

No regular expressions were active.

6.5 Comparison detail

  1   KIDS Distr ibution sa ved on Sep  24, 2014@ 15:12:13
  2   VAFCT OPTI ON FIX
  3   **KIDS**:P X*1.0*215^
  4  
  5   **INSTALL  NAME**
  6   PX*1.0*215
  7   "BLD",9218 ,0)
  8   PX*1.0*215 ^PCE PATIE NT CARE EN COUNTER^0^ 3160428^y
  9   "BLD",9218 ,1,0)
  10   ^^5^5^3160 302^
  11   "BLD",9218 ,1,1,0)
  12   The Vetera ns Health  Informatio n Systems  and Techno logy Archi tecture
  13   "BLD",9218 ,1,2,0)
  14   (VistA) Im munization s Enhancem ents (VIMM ) 2.0 proj ect, Incre ment 3, bu ilds
  15   "BLD",9218 ,1,3,0)
  16   upon the f ile struct ures and s tandardize d data int roduced in  Increment s 1
  17   "BLD",9218 ,1,4,0)
  18   and 2 by a dding func tional enh ancements  to the exi sting Vist A Patient  Care
  19   "BLD",9218 ,1,5,0)
  20   Encounter  (PCE) pack age.
  21   "BLD",9218 ,4,0)
  22   ^9.64PA^90 00010.12^8
  23   "BLD",9218 ,4,811.1,0 )
  24   811.1
  25   "BLD",9218 ,4,811.1,2 ,0)
  26   ^9.641^811 .1^1
  27   "BLD",9218 ,4,811.1,2 ,811.1,0)
  28   PCE CODE M APPING  (F ile-top le vel)
  29   "BLD",9218 ,4,811.1,2 ,811.1,1,0 )
  30   ^9.6411^^
  31   "BLD",9218 ,4,811.1,2 22)
  32   y^n^p^^^^n ^^n
  33   "BLD",9218 ,4,811.1,2 24)
  34  
  35   "BLD",9218 ,4,920.05, 0)
  36   920.05
  37   "BLD",9218 ,4,920.05, 222)
  38   y^y^f^^^^n
  39   "BLD",9218 ,4,920.4,0 )
  40   920.4
  41   "BLD",9218 ,4,920.4,2 ,0)
  42   ^9.641^920 .4^1
  43   "BLD",9218 ,4,920.4,2 ,920.4,0)
  44   IMM CONTRA INDICATION  REASONS   (File-top  level)
  45   "BLD",9218 ,4,920.4,2 ,920.4,1,0 )
  46   ^9.6411^.0 5^1
  47   "BLD",9218 ,4,920.4,2 ,920.4,1,. 05,0)
  48   CONCEPT CO DING SYSTE M
  49   "BLD",9218 ,4,920.4,2 22)
  50   y^y^p^^^^n ^^n
  51   "BLD",9218 ,4,920.4,2 24)
  52  
  53   "BLD",9218 ,4,920.6,0 )
  54   920.6
  55   "BLD",9218 ,4,920.6,2 22)
  56   y^y^f^^^^n
  57   "BLD",9218 ,4,9000010 .11,0)
  58   9000010.11
  59   "BLD",9218 ,4,9000010 .11,222)
  60   y^y^f^^^^n ^^n
  61   "BLD",9218 ,4,9000010 .11,224)
  62  
  63   "BLD",9218 ,4,9000010 .12,0)
  64   9000010.12
  65   "BLD",9218 ,4,9000010 .12,2,0)
  66   ^9.641^900 0010.12^1
  67   "BLD",9218 ,4,9000010 .12,2,9000 010.12,0)
  68   V SKIN TES T  (File-t op level)
  69   "BLD",9218 ,4,9000010 .12,2,9000 010.12,1,0 )
  70   ^9.6411^^
  71   "BLD",9218 ,4,9000010 .12,222)
  72   y^n^p^^^^n ^^n
  73   "BLD",9218 ,4,9000010 .12,224)
  74  
  75   "BLD",9218 ,4,9000010 .707,0)
  76   9000010.70 7
  77   "BLD",9218 ,4,9000010 .707,222)
  78   y^y^f^^^^n
  79   "BLD",9218 ,4,9999999 .41,0)
  80   9999999.41
  81   "BLD",9218 ,4,9999999 .41,2,0)
  82   ^9.641^999 9999.41^1
  83   "BLD",9218 ,4,9999999 .41,2,9999 999.41,0)
  84   IMMUNIZATI ON LOT  (F ile-top le vel)
  85   "BLD",9218 ,4,9999999 .41,2,9999 999.41,1,0 )
  86   ^9.6411^.1 8^1
  87   "BLD",9218 ,4,9999999 .41,2,9999 999.41,1,. 18,0)
  88   NDC CODE ( VA)
  89   "BLD",9218 ,4,9999999 .41,222)
  90   y^y^p^^^^n ^^n
  91   "BLD",9218 ,4,9999999 .41,224)
  92  
  93   "BLD",9218 ,4,"APDD", 811.1,811. 1)
  94  
  95   "BLD",9218 ,4,"APDD", 920.4,920. 4)
  96  
  97   "BLD",9218 ,4,"APDD", 920.4,920. 4,.05)
  98  
  99   "BLD",9218 ,4,"APDD", 9000010.12 ,9000010.1 2)
  100  
  101   "BLD",9218 ,4,"APDD", 9999999.41 ,9999999.4 1)
  102  
  103   "BLD",9218 ,4,"APDD", 9999999.41 ,9999999.4 1,.18)
  104  
  105   "BLD",9218 ,4,"B",811 .1,811.1)
  106  
  107   "BLD",9218 ,4,"B",920 .05,920.05 )
  108  
  109   "BLD",9218 ,4,"B",920 .4,920.4)
  110  
  111   "BLD",9218 ,4,"B",920 .6,920.6)
  112  
  113   "BLD",9218 ,4,"B",900 0010.11,90 00010.11)
  114  
  115   "BLD",9218 ,4,"B",900 0010.12,90 00010.12)
  116  
  117   "BLD",9218 ,4,"B",900 0010.707,9 000010.707 )
  118  
  119   "BLD",9218 ,4,"B",999 9999.41,99 99999.41)
  120  
  121   "BLD",9218 ,6.3)
  122   10
  123   "BLD",9218 ,"ABPKG")
  124   n
  125   "BLD",9218 ,"INI")
  126  
  127   "BLD",9218 ,"INID")
  128   ^n^
  129   "BLD",9218 ,"INIT")
  130   POST^PXVP2 15
  131   "BLD",9218 ,"KRN",0)
  132   ^9.67PA^77 9.2^20
  133   "BLD",9218 ,"KRN",.4, 0)
  134   .4
  135   "BLD",9218 ,"KRN",.40 1,0)
  136   .401
  137   "BLD",9218 ,"KRN",.40 2,0)
  138   .402
  139   "BLD",9218 ,"KRN",.40 3,0)
  140   .403
  141   "BLD",9218 ,"KRN",.5, 0)
  142   .5
  143   "BLD",9218 ,"KRN",.84 ,0)
  144   .84
  145   "BLD",9218 ,"KRN",3.6 ,0)
  146   3.6
  147   "BLD",9218 ,"KRN",3.8 ,0)
  148   3.8
  149   "BLD",9218 ,"KRN",9.2 ,0)
  150   9.2
  151   "BLD",9218 ,"KRN",9.8 ,0)
  152   9.8
  153   "BLD",9218 ,"KRN",9.8 ,"NM",0)
  154   ^9.68A^35^ 32
  155   "BLD",9218 ,"KRN",9.8 ,"NM",1,0)
  156   PXAI^^0^B4 2819168
  157   "BLD",9218 ,"KRN",9.8 ,"NM",3,0)
  158   PXAPIIM^^0 ^B80558091
  159   "BLD",9218 ,"KRN",9.8 ,"NM",4,0)
  160   PXKENC^^0^ B29334197
  161   "BLD",9218 ,"KRN",9.8 ,"NM",5,0)
  162   PXPXRM^^0^ B125590932
  163   "BLD",9218 ,"KRN",9.8 ,"NM",6,0)
  164   PXPXRMI1^^ 0^B1042256 70
  165   "BLD",9218 ,"KRN",9.8 ,"NM",7,0)
  166   PXRPC^^0^B 156917264
  167   "BLD",9218 ,"KRN",9.8 ,"NM",8,0)
  168   PXAIICR^^0 ^B5253575
  169   "BLD",9218 ,"KRN",9.8 ,"NM",9,0)
  170   PXAIICRV^^ 0^B1277586 5
  171   "BLD",9218 ,"KRN",9.8 ,"NM",10,0 )
  172   PXKFICR^^0 ^B1725753
  173   "BLD",9218 ,"KRN",9.8 ,"NM",11,0 )
  174   PXCEAE^^0^ B33109650
  175   "BLD",9218 ,"KRN",9.8 ,"NM",12,0 )
  176   PXCEAE1^^0 ^B29262597
  177   "BLD",9218 ,"KRN",9.8 ,"NM",13,0 )
  178   PXCEICR^^0 ^B18593217
  179   "BLD",9218 ,"KRN",9.8 ,"NM",14,0 )
  180   PXCEVFI1^^ 0^B3319888 8
  181   "BLD",9218 ,"KRN",9.8 ,"NM",15,0 )
  182   PXCEVFI2^^ 0^B3781829 4
  183   "BLD",9218 ,"KRN",9.8 ,"NM",16,0 )
  184   PXCEVFIL^^ 0^B4418551 9
  185   "BLD",9218 ,"KRN",9.8 ,"NM",17,0 )
  186   PXCEVIMM^^ 0^B8610167 7
  187   "BLD",9218 ,"KRN",9.8 ,"NM",18,0 )
  188   PXKFIMM^^0 ^B5142444
  189   "BLD",9218 ,"KRN",9.8 ,"NM",19,0 )
  190   PXVUTIL^^0 ^B13284181
  191   "BLD",9218 ,"KRN",9.8 ,"NM",20,0 )
  192   PXKMAIN^^0 ^B55424847
  193   "BLD",9218 ,"KRN",9.8 ,"NM",21,0 )
  194   PXKMAIN2^^ 0^B2582981 8
  195   "BLD",9218 ,"KRN",9.8 ,"NM",22,0 )
  196   PXKFPOV1^^ 0^B9458058
  197   "BLD",9218 ,"KRN",9.8 ,"NM",24,0 )
  198   PXVRPC1^^0 ^B70359613
  199   "BLD",9218 ,"KRN",9.8 ,"NM",25,0 )
  200   PXVRPC2^^0 ^B29476719
  201   "BLD",9218 ,"KRN",9.8 ,"NM",26,0 )
  202   PXVRPC3^^0 ^B28618741
  203   "BLD",9218 ,"KRN",9.8 ,"NM",27,0 )
  204   PXVRPC4^^0 ^B13132181 9
  205   "BLD",9218 ,"KRN",9.8 ,"NM",28,0 )
  206   PXVZRT^^0^ B82546869
  207   "BLD",9218 ,"KRN",9.8 ,"NM",29,0 )
  208   PXVRPC5^^0 ^B35105697
  209   "BLD",9218 ,"KRN",9.8 ,"NM",30,0 )
  210   PXKFCPT1^^ 0^B2465669 7
  211   "BLD",9218 ,"KRN",9.8 ,"NM",31,0 )
  212   PXAIIMM^^0 ^B16045767
  213   "BLD",9218 ,"KRN",9.8 ,"NM",32,0 )
  214   PXVNDC^^0^ B1736379
  215   "BLD",9218 ,"KRN",9.8 ,"NM",34,0 )
  216   PXVRESP^^0 ^B3810590
  217   "BLD",9218 ,"KRN",9.8 ,"NM",35,0 )
  218   PXVRPC6^^0 ^B16158307
  219   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXAI",1)
  220  
  221   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXAIICR", 8)
  222  
  223   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXAIICRV" ,9)
  224  
  225   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXAIIMM", 31)
  226  
  227   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXAPIIM", 3)
  228  
  229   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXCEAE",1 1)
  230  
  231   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXCEAE1", 12)
  232  
  233   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXCEICR", 13)
  234  
  235   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXCEVFI1" ,14)
  236  
  237   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXCEVFI2" ,15)
  238  
  239   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXCEVFIL" ,16)
  240  
  241   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXCEVIMM" ,17)
  242  
  243   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXKENC",4 )
  244  
  245   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXKFCPT1" ,30)
  246  
  247   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXKFICR", 10)
  248  
  249   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXKFIMM", 18)
  250  
  251   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXKFPOV1" ,22)
  252  
  253   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXKMAIN", 20)
  254  
  255   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXKMAIN2" ,21)
  256  
  257   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXPXRM",5 )
  258  
  259   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXPXRMI1" ,6)
  260  
  261   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXRPC",7)
  262  
  263   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVNDC",3 2)
  264  
  265   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVRESP", 34)
  266  
  267   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVRPC1", 24)
  268  
  269   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVRPC2", 25)
  270  
  271   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVRPC3", 26)
  272  
  273   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVRPC4", 27)
  274  
  275   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVRPC5", 29)
  276  
  277   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVRPC6", 35)
  278  
  279   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVUTIL", 19)
  280  
  281   "BLD",9218 ,"KRN",9.8 ,"NM","B", "PXVZRT",2 8)
  282  
  283   "BLD",9218 ,"KRN",19, 0)
  284   19
  285   "BLD",9218 ,"KRN",19, "NM",0)
  286   ^9.68A^3^3
  287   "BLD",9218 ,"KRN",19, "NM",1,0)
  288   PXV EDIT D EFAULT RES PONSES^^0
  289   "BLD",9218 ,"KRN",19, "NM",2,0)
  290   PXTT TABLE  MAINTENAN CE^^2
  291   "BLD",9218 ,"KRN",19, "NM",3,0)
  292   PX PCE COD E MAPPING  LIST^^0
  293   "BLD",9218 ,"KRN",19, "NM","B"," PX PCE COD E MAPPING  LIST",3)
  294  
  295   "BLD",9218 ,"KRN",19, "NM","B"," PXTT TABLE  MAINTENAN CE",2)
  296  
  297   "BLD",9218 ,"KRN",19, "NM","B"," PXV EDIT D EFAULT RES PONSES",1)
  298  
  299   "BLD",9218 ,"KRN",19. 1,0)
  300   19.1
  301   "BLD",9218 ,"KRN",19. 1,"NM",0)
  302   ^9.68A^^
  303   "BLD",9218 ,"KRN",101 ,0)
  304   101
  305   "BLD",9218 ,"KRN",101 ,"NM",0)
  306   ^9.68A^2^2
  307   "BLD",9218 ,"KRN",101 ,"NM",1,0)
  308   PXCE ADD/E DIT MENU^^ 2
  309   "BLD",9218 ,"KRN",101 ,"NM",2,0)
  310   PXCE ICR A DD^^0
  311   "BLD",9218 ,"KRN",101 ,"NM","B", "PXCE ADD/ EDIT MENU" ,1)
  312  
  313   "BLD",9218 ,"KRN",101 ,"NM","B", "PXCE ICR  ADD",2)
  314  
  315   "BLD",9218 ,"KRN",409 .61,0)
  316   409.61
  317   "BLD",9218 ,"KRN",771 ,0)
  318   771
  319   "BLD",9218 ,"KRN",779 .2,0)
  320   779.2
  321   "BLD",9218 ,"KRN",870 ,0)
  322   870
  323   "BLD",9218 ,"KRN",898 9.51,0)
  324   8989.51
  325   "BLD",9218 ,"KRN",898 9.52,0)
  326   8989.52
  327   "BLD",9218 ,"KRN",899 4,0)
  328   8994
  329   "BLD",9218 ,"KRN",899 4,"NM",0)
  330   ^9.68A^14^ 14
  331   "BLD",9218 ,"KRN",899 4,"NM",1,0 )
  332   PX SAVE DA TA^^0
  333   "BLD",9218 ,"KRN",899 4,"NM",2,0 )
  334   PXVIMM ADM IN ROUTE^^ 0
  335   "BLD",9218 ,"KRN",899 4,"NM",3,0 )
  336   PXVIMM ADM IN SITE^^0
  337   "BLD",9218 ,"KRN",899 4,"NM",4,0 )
  338   PXVIMM IMM  DETAILED^ ^0
  339   "BLD",9218 ,"KRN",899 4,"NM",5,0 )
  340   PXVIMM IMM  LOT^^0
  341   "BLD",9218 ,"KRN",899 4,"NM",6,0 )
  342   PXVIMM IMM  MAN^^0
  343   "BLD",9218 ,"KRN",899 4,"NM",7,0 )
  344   PXVIMM IMM  SHORT LIS T^^0
  345   "BLD",9218 ,"KRN",899 4,"NM",8,0 )
  346   PXVIMM IMM DATA^^0
  347   "BLD",9218 ,"KRN",899 4,"NM",9,0 )
  348   PXVIMM INF O SOURCE^^ 0
  349   "BLD",9218 ,"KRN",899 4,"NM",10, 0)
  350   PXVIMM VIS ^^0
  351   "BLD",9218 ,"KRN",899 4,"NM",11, 0)
  352   PXVIMM ICR  LIST^^0
  353   "BLD",9218 ,"KRN",899 4,"NM",12, 0)
  354   PXVIMM VIC R EVENTS^^ 0
  355   "BLD",9218 ,"KRN",899 4,"NM",13, 0)
  356   PXVIMM ADM IN CODES^^ 0
  357   "BLD",9218 ,"KRN",899 4,"NM",14, 0)
  358   PXVIMM IMM  FORMAT^^0
  359   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PX SAVE  DATA",1)
  360  
  361   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM A DMIN CODES ",13)
  362  
  363   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM A DMIN ROUTE ",2)
  364  
  365   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM A DMIN SITE" ,3)
  366  
  367   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM I CR LIST",1 1)
  368  
  369   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM I MM DETAILE D",4)
  370  
  371   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM I MM FORMAT" ,14)
  372  
  373   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM I MM LOT",5)
  374  
  375   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM I MM MAN",6)
  376  
  377   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM I MM SHORT L IST",7)
  378  
  379   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM I MMDATA",8)
  380  
  381   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM I NFO SOURCE ",9)
  382  
  383   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM V ICR EVENTS ",12)
  384  
  385   "BLD",9218 ,"KRN",899 4,"NM","B" ,"PXVIMM V IS",10)
  386  
  387   "BLD",9218 ,"KRN","B" ,.4,.4)
  388  
  389   "BLD",9218 ,"KRN","B" ,.401,.401 )
  390  
  391   "BLD",9218 ,"KRN","B" ,.402,.402 )
  392  
  393   "BLD",9218 ,"KRN","B" ,.403,.403 )
  394  
  395   "BLD",9218 ,"KRN","B" ,.5,.5)
  396  
  397   "BLD",9218 ,"KRN","B" ,.84,.84)
  398  
  399   "BLD",9218 ,"KRN","B" ,3.6,3.6)
  400  
  401   "BLD",9218 ,"KRN","B" ,3.8,3.8)
  402  
  403   "BLD",9218 ,"KRN","B" ,9.2,9.2)
  404  
  405   "BLD",9218 ,"KRN","B" ,9.8,9.8)
  406  
  407   "BLD",9218 ,"KRN","B" ,19,19)
  408  
  409   "BLD",9218 ,"KRN","B" ,19.1,19.1 )
  410  
  411   "BLD",9218 ,"KRN","B" ,101,101)
  412  
  413   "BLD",9218 ,"KRN","B" ,409.61,40 9.61)
  414  
  415   "BLD",9218 ,"KRN","B" ,771,771)
  416  
  417   "BLD",9218 ,"KRN","B" ,779.2,779 .2)
  418  
  419   "BLD",9218 ,"KRN","B" ,870,870)
  420  
  421   "BLD",9218 ,"KRN","B" ,8989.51,8 989.51)
  422  
  423   "BLD",9218 ,"KRN","B" ,8989.52,8 989.52)
  424  
  425   "BLD",9218 ,"KRN","B" ,8994,8994 )
  426  
  427   "BLD",9218 ,"QDEF")
  428   ^^^^NO^^^^ YES^^NO
  429   "BLD",9218 ,"QUES",0)
  430   ^9.62^^
  431   "BLD",9218 ,"REQB",0)
  432   ^9.611^5^4
  433   "BLD",9218 ,"REQB",1, 0)
  434   PX*1.0*210 ^2
  435   "BLD",9218 ,"REQB",2, 0)
  436   PX*1.0*195 ^2
  437   "BLD",9218 ,"REQB",3, 0)
  438   PX*1.0*186 ^2
  439   "BLD",9218 ,"REQB",5, 0)
  440   PSN*4.0*44 8^2
  441   "BLD",9218 ,"REQB","B ","PSN*4.0 *448",5)
  442  
  443   "BLD",9218 ,"REQB","B ","PX*1.0* 186",3)
  444  
  445   "BLD",9218 ,"REQB","B ","PX*1.0* 195",2)
  446  
  447   "BLD",9218 ,"REQB","B ","PX*1.0* 210",1)
  448  
  449   "FIA",811. 1)
  450   PCE CODE M APPING
  451   "FIA",811. 1,0)
  452   ^PXD(811.1 ,
  453   "FIA",811. 1,0,0)
  454   811.1IV
  455   "FIA",811. 1,0,1)
  456   y^n^f^^^^n ^^n
  457   "FIA",811. 1,0,10)
  458  
  459   "FIA",811. 1,0,11)
  460  
  461   "FIA",811. 1,0,"RLRO" )
  462  
  463   "FIA",811. 1,0,"VR")
  464   1.0^PX
  465   "FIA",811. 1,811.1)
  466   0
  467   "FIA",920. 05)
  468   IMM DEFAUL T RESPONSE S
  469   "FIA",920. 05,0)
  470   ^PXV(920.0 5,
  471   "FIA",920. 05,0,0)
  472   920.05P
  473   "FIA",920. 05,0,1)
  474   y^y^f^^^^n
  475   "FIA",920. 05,0,10)
  476  
  477   "FIA",920. 05,0,11)
  478  
  479   "FIA",920. 05,0,"RLRO ")
  480  
  481   "FIA",920. 05,0,"VR")
  482   1.0^PX
  483   "FIA",920. 05,920.05)
  484   0
  485   "FIA",920. 05,920.051 )
  486   0
  487   "FIA",920. 4)
  488   IMM CONTRA INDICATION  REASONS
  489   "FIA",920. 4,0)
  490   ^PXV(920.4 ,
  491   "FIA",920. 4,0,0)
  492   920.4I
  493   "FIA",920. 4,0,1)
  494   y^y^p^^^^n ^^n
  495   "FIA",920. 4,0,10)
  496  
  497   "FIA",920. 4,0,11)
  498  
  499   "FIA",920. 4,0,"RLRO" )
  500  
  501   "FIA",920. 4,0,"VR")
  502   1.0^PX
  503   "FIA",920. 4,920.4)
  504   1
  505   "FIA",920. 4,920.4,.0 5)
  506  
  507   "FIA",920. 6)
  508   IMM ROUTES  TO SITES
  509   "FIA",920. 6,0)
  510   ^PXV(920.6 ,
  511   "FIA",920. 6,0,0)
  512   920.6P
  513   "FIA",920. 6,0,1)
  514   y^y^f^^^^n
  515   "FIA",920. 6,0,10)
  516  
  517   "FIA",920. 6,0,11)
  518  
  519   "FIA",920. 6,0,"RLRO" )
  520  
  521   "FIA",920. 6,0,"VR")
  522   1.0^PX
  523   "FIA",920. 6,920.6)
  524   0
  525   "FIA",920. 6,920.61)
  526   0
  527   "FIA",9000 010.11)
  528   V IMMUNIZA TION
  529   "FIA",9000 010.11,0)
  530   ^AUPNVIMM(
  531   "FIA",9000 010.11,0,0 )
  532   9000010.11 IP
  533   "FIA",9000 010.11,0,1 )
  534   y^y^f^^^^n ^^n
  535   "FIA",9000 010.11,0,1 0)
  536  
  537   "FIA",9000 010.11,0,1 1)
  538  
  539   "FIA",9000 010.11,0," RLRO")
  540  
  541   "FIA",9000 010.11,0," VR")
  542   1.0^PX
  543   "FIA",9000 010.11,900 0010.11)
  544   0
  545   "FIA",9000 010.11,900 0010.1111)
  546   0
  547   "FIA",9000 010.11,900 0010.112)
  548   0
  549   "FIA",9000 010.11,900 0010.1126)
  550   0
  551   "FIA",9000 010.11,900 0010.1127)
  552   0
  553   "FIA",9000 010.11,900 0010.113)
  554   0
  555   "FIA",9000 010.12)
  556   V SKIN TES T
  557   "FIA",9000 010.12,0)
  558   ^AUPNVSK(
  559   "FIA",9000 010.12,0,0 )
  560   9000010.12 IP
  561   "FIA",9000 010.12,0,1 )
  562   y^n^f^^^^n ^^n
  563   "FIA",9000 010.12,0,1 0)
  564  
  565   "FIA",9000 010.12,0,1 1)
  566  
  567   "FIA",9000 010.12,0," RLRO")
  568  
  569   "FIA",9000 010.12,0," VR")
  570   1.0^PX
  571   "FIA",9000 010.12,900 0010.12)
  572   0
  573   "FIA",9000 010.707)
  574   V IMM CONT RA/REFUSAL  EVENTS
  575   "FIA",9000 010.707,0)
  576   ^AUPNVICR(
  577   "FIA",9000 010.707,0, 0)
  578   9000010.70 7IV
  579   "FIA",9000 010.707,0, 1)
  580   y^y^f^^^^n
  581   "FIA",9000 010.707,0, 10)
  582  
  583   "FIA",9000 010.707,0, 11)
  584  
  585   "FIA",9000 010.707,0, "RLRO")
  586  
  587   "FIA",9000 010.707,0, "VR")
  588   1.0^PX
  589   "FIA",9000 010.707,90 00010.707)
  590   0
  591   "FIA",9999 999.41)
  592   IMMUNIZATI ON LOT
  593   "FIA",9999 999.41,0)
  594   ^AUTTIML(
  595   "FIA",9999 999.41,0,0 )
  596   9999999.41 I
  597   "FIA",9999 999.41,0,1 )
  598   y^y^p^^^^n ^^n
  599   "FIA",9999 999.41,0,1 0)
  600  
  601   "FIA",9999 999.41,0,1 1)
  602  
  603   "FIA",9999 999.41,0," RLRO")
  604  
  605   "FIA",9999 999.41,0," VR")
  606   1.0^PX
  607   "FIA",9999 999.41,999 9999.41)
  608   1
  609   "FIA",9999 999.41,999 9999.41,.1 8)
  610  
  611   "INIT")
  612   POST^PXVP2 15
  613   "IX",920.0 5,920.05," AC",0)
  614   920.05^AC^ Index that  sorts on  Institutio n and Immu nization.^ R^^R^IR^W^ 920.051^^^ ^^S
  615   "IX",920.0 5,920.05," AC",.1,0)
  616   ^^2^2^3160 309^
  617   "IX",920.0 5,920.05," AC",.1,1,0 )
  618   This cross  reference  is used f or sorting  immunizat ion type b y institut ion
  619   "IX",920.0 5,920.05," AC",.1,2,0 )
  620   (facility) .
  621   "IX",920.0 5,920.05," AC",1)
  622   S ^PXV(920 .05,"AC",X (1),X(2),D A(1),DA)=" "
  623   "IX",920.0 5,920.05," AC",2)
  624   K ^PXV(920 .05,"AC",X (1),X(2),D A(1),DA)
  625   "IX",920.0 5,920.05," AC",2.5)
  626   K ^PXV(920 .05,"AC")
  627   "IX",920.0 5,920.05," AC",11.1,0 )
  628   ^.114IA^2^ 2
  629   "IX",920.0 5,920.05," AC",11.1,1 ,0)
  630   1^C^^^^1
  631   "IX",920.0 5,920.05," AC",11.1,1 ,1.5)
  632   S X=$P($G( ^PXV(920.0 5,+$G(DA(1 )),0)),"^" )
  633   "IX",920.0 5,920.05," AC",11.1,2 ,0)
  634   2^F^920.05 1^.01^^2^F
  635   "IX",90000 10.11,9000 010.11,"AC R",0)
  636   9000010.11 ^ACR^Clini cal Remind ers index. ^MU^^R^IR^ I^9000010. 11^^^^^A
  637   "IX",90000 10.11,9000 010.11,"AC R",.1,0)
  638   ^^12^12^31 51109
  639   "IX",90000 10.11,9000 010.11,"AC R",.1,1,0)
  640   This cross -reference  builds fo ur indexes , two for  finding al l patients
  641   "IX",90000 10.11,9000 010.11,"AC R",.1,2,0)
  642   with a par ticular im munization  and two f or finding  all the i mmunizatio ns a
  643   "IX",90000 10.11,9000 010.11,"AC R",.1,3,0)
  644   patient ha s.
  645   "IX",90000 10.11,9000 010.11,"AC R",.1,4,0)
  646   The indexe s are stor ed in the  Clinical R eminders i ndex globa l as:
  647   "IX",90000 10.11,9000 010.11,"AC R",.1,5,0)
  648   ^PXRMINDX( 9000010.11 ,"IP",IMMU NIZATION,D FN,DATE,DA S)
  649   "IX",90000 10.11,9000 010.11,"AC R",.1,6,0)
  650   ^PXRMINDX( 9000010.11 ,"CVX","IP ",CVX CODE ,DFN,DATE, DAS)
  651   "IX",90000 10.11,9000 010.11,"AC R",.1,7,0)
  652   and
  653   "IX",90000 10.11,9000 010.11,"AC R",.1,8,0)
  654   ^PXRMINDX( 9000010.11 ,"PI",DFN, IMMUNIZATI ON,DATE,DA S)
  655   "IX",90000 10.11,9000 010.11,"AC R",.1,9,0)
  656   ^PXRMINDX( 9000010.11 ,"CVX","PI ",DFN,CVX  CODE,DATE, DAS)
  657   "IX",90000 10.11,9000 010.11,"AC R",.1,10,0 )
  658   respective ly.
  659   "IX",90000 10.11,9000 010.11,"AC R",.1,11,0 )
  660   For all th e details,  see the C linical Re minders In dex Techni cal
  661   "IX",90000 10.11,9000 010.11,"AC R",.1,12,0 )
  662   Guide/Prog rammer's M anual.
  663   "IX",90000 10.11,9000 010.11,"AC R",1)
  664   D SVFILE^P XPXRM(9000 010.11,.X, .DA)
  665   "IX",90000 10.11,9000 010.11,"AC R",2)
  666   D KVFILE^P XPXRM(9000 010.11,.X, .DA)
  667   "IX",90000 10.11,9000 010.11,"AC R",2.5)
  668   K ^PXRMIND X(9000010. 11)
  669   "IX",90000 10.11,9000 010.11,"AC R",11.1,0)
  670   ^.114IA^4^ 4
  671   "IX",90000 10.11,9000 010.11,"AC R",11.1,1, 0)
  672   1^F^900001 0.11^.01^^ 1^F
  673   "IX",90000 10.11,9000 010.11,"AC R",11.1,2, 0)
  674   2^F^900001 0.11^.02^^ 2^F
  675   "IX",90000 10.11,9000 010.11,"AC R",11.1,3, 0)
  676   3^F^900001 0.11^.03^^ 3^F
  677   "IX",90000 10.11,9000 010.11,"AC R",11.1,4, 0)
  678   4^F^900001 0.11^1201^ ^^F
  679   "IX",90000 10.11,9000 010.11,"AH ",0)
  680   9000010.11 ^AH^Hours  between ad ministrati on and rea ding^MU^^R ^IR^I^9000 010.11^^^^ ^A
  681   "IX",90000 10.11,9000 010.11,"AH ",.1,0)
  682   ^^3^3^3150 818^
  683   "IX",90000 10.11,9000 010.11,"AH ",.1,1,0)
  684   This cross  reference  calculate s the numb er of hour s between  the EVENT
  685   "IX",90000 10.11,9000 010.11,"AH ",.1,2,0)
  686   DATE AND T IME field  (#1201) an d the DATE /TIME READ  field (#1 403) and
  687   "IX",90000 10.11,9000 010.11,"AH ",.1,3,0)
  688   stores tha t value in  the HOURS  READ POST -INOCULATI ON field ( #1406).
  689   "IX",90000 10.11,9000 010.11,"AH ",1)
  690   D HRS^PXVU TIL Q
  691   "IX",90000 10.11,9000 010.11,"AH ",1.4)
  692   S X=(X(1)' ="")
  693   "IX",90000 10.11,9000 010.11,"AH ",2)
  694   D HRS^PXVU TIL Q
  695   "IX",90000 10.11,9000 010.11,"AH ",2.4)
  696   S X=(X(1)' ="")
  697   "IX",90000 10.11,9000 010.11,"AH ",2.5)
  698   Q
  699   "IX",90000 10.11,9000 010.11,"AH ",11.1,0)
  700   ^.114IA^3^ 3
  701   "IX",90000 10.11,9000 010.11,"AH ",11.1,1,0 )
  702   1^F^900001 0.11^1403^ ^^F
  703   "IX",90000 10.11,9000 010.11,"AH ",11.1,2,0 )
  704   2^F^900001 0.11^1201^ ^^F
  705   "IX",90000 10.11,9000 010.11,"AH ",11.1,3,0 )
  706   3^F^900001 0.11^1406^ ^^F
  707   "IX",90000 10.12,9000 010.12,"AC R",0)
  708   9000010.12 ^ACR^Clini cal Remind ers index. ^MU^^R^IR^ I^9000010. 12^^^^^A
  709   "IX",90000 10.12,9000 010.12,"AC R",.1,0)
  710   ^^8^8^3081 110
  711   "IX",90000 10.12,9000 010.12,"AC R",.1,1,0)
  712   This cross -reference  builds tw o indexes,  one for f inding
  713   "IX",90000 10.12,9000 010.12,"AC R",.1,2,0)
  714   all patien ts with a  particular  skin test  and one f or finding  all
  715   "IX",90000 10.12,9000 010.12,"AC R",.1,3,0)
  716   the skin t ests a pat ient has.
  717   "IX",90000 10.12,9000 010.12,"AC R",.1,4,0)
  718   The indexe s are stor ed in the  Clinical R eminders i ndex globa l as:
  719   "IX",90000 10.12,9000 010.12,"AC R",.1,5,0)
  720    ^PXRMINDX (9000010.1 2,"IP",SKI N TEST,DFN ,VISIT DAT E,DAS) and
  721   "IX",90000 10.12,9000 010.12,"AC R",.1,6,0)
  722    ^PXRMINDX (9000010.1 2,"PI",DFN ,SKIN TEST ,VISIT DAT E,DAS)
  723   "IX",90000 10.12,9000 010.12,"AC R",.1,7,0)
  724   respective ly.
  725   "IX",90000 10.12,9000 010.12,"AC R",.1,8,0)
  726   For all th e details,  see the C linical Re minders In dex Techni cal Guide/ Programmer 's Manual.
  727   "IX",90000 10.12,9000 010.12,"AC R",1)
  728   D SVFILE^P XPXRM(9000 010.12,.X, .DA)
  729   "IX",90000 10.12,9000 010.12,"AC R",2)
  730   D KVFILE^P XPXRM(9000 010.12,.X, .DA)
  731   "IX",90000 10.12,9000 010.12,"AC R",2.5)
  732   K ^PXRMIND X(9000010. 12)
  733   "IX",90000 10.12,9000 010.12,"AC R",11.1,0)
  734   ^.114IA^3^ 3
  735   "IX",90000 10.12,9000 010.12,"AC R",11.1,1, 0)
  736   1^F^900001 0.12^.01^^ 1^F
  737   "IX",90000 10.12,9000 010.12,"AC R",11.1,2, 0)
  738   2^F^900001 0.12^.02^^ 2^F
  739   "IX",90000 10.12,9000 010.12,"AC R",11.1,3, 0)
  740   3^F^900001 0.12^.03^^ 3^F
  741   "IX",90000 10.12,9000 010.12,"AH ",0)
  742   9000010.12 ^AH^Hours  between pl acement an d reading^ MU^^R^IR^I ^9000010.1 2^^^^^A
  743   "IX",90000 10.12,9000 010.12,"AH ",.1,0)
  744   ^^3^3^3150 818^
  745   "IX",90000 10.12,9000 010.12,"AH ",.1,1,0)
  746   This cross  reference  calculate s the numb er of hour s between  the EVENT
  747   "IX",90000 10.12,9000 010.12,"AH ",.1,2,0)
  748   DATE AND T IME field  (#1201) an d the DATE  READ fiel d (#.06) a nd stores
  749   "IX",90000 10.12,9000 010.12,"AH ",.1,3,0)
  750   that value  in the HO URS READ P OST-PLACEM ENT field  (#1214).
  751   "IX",90000 10.12,9000 010.12,"AH ",1)
  752   D HR^PXVUT L Q
  753   "IX",90000 10.12,9000 010.12,"AH ",1.4)
  754   S X=(X(1)' ="")
  755   "IX",90000 10.12,9000 010.12,"AH ",2)
  756   D HR^PXVUT L Q
  757   "IX",90000 10.12,9000 010.12,"AH ",2.4)
  758   S X=(X(1)' ="")
  759   "IX",90000 10.12,9000 010.12,"AH ",2.5)
  760   Q
  761   "IX",90000 10.12,9000 010.12,"AH ",11.1,0)
  762   ^.114IA^3^ 3
  763   "IX",90000 10.12,9000 010.12,"AH ",11.1,1,0 )
  764   1^F^900001 0.12^.06^^ ^F
  765   "IX",90000 10.12,9000 010.12,"AH ",11.1,2,0 )
  766   2^F^900001 0.12^1201^ ^^F
  767   "IX",90000 10.12,9000 010.12,"AH ",11.1,3,0 )
  768   3^F^900001 0.12^1214^ ^^F
  769   "IX",90000 10.707,900 0010.707," AA",0)
  770   9000010.70 7^AA^Index  the patie nt, contra indication /refusal,  inverted v isit date. ^MU^^R^IR^ I^9000010. 707^^^^^A
  771   "IX",90000 10.707,900 0010.707," AA",.1,0)
  772   ^^3^3^3160 405^
  773   "IX",90000 10.707,900 0010.707," AA",.1,1,0 )
  774   This cross  reference  is used f or sorting  contraind ication/re fusal
  775   "IX",90000 10.707,900 0010.707," AA",.1,2,0 )
  776   events in  sequence b y patient,  contraind ication/re fusal, inv erted visi t
  777   "IX",90000 10.707,900 0010.707," AA",.1,3,0 )
  778   date, and  internal e ntry numbe r.
  779   "IX",90000 10.707,900 0010.707," AA",1)
  780   S ^AUPNVIC R("AA",X(1 ),X(2),(99 99999-$P(^ AUPNVSIT(X (3),0),"." )),DA)=""
  781   "IX",90000 10.707,900 0010.707," AA",1.4)
  782   S X=((X(1) '="")&(X(2 )'="")&(X( 3)'=""))
  783   "IX",90000 10.707,900 0010.707," AA",2)
  784   K ^AUPNVIC R("AA",X(1 ),X(2),(99 99999-$P(^ AUPNVSIT(X (3),0),"." )),DA)
  785   "IX",90000 10.707,900 0010.707," AA",2.4)
  786   S X=((X(1) '="")&(X(2 )'="")&(X( 3)'=""))
  787   "IX",90000 10.707,900 0010.707," AA",2.5)
  788   K ^AUPNVIC R("AA")
  789   "IX",90000 10.707,900 0010.707," AA",11.1,0 )
  790   ^.114IA^3^ 3
  791   "IX",90000 10.707,900 0010.707," AA",11.1,1 ,0)
  792   1^F^900001 0.707^.02^ ^1^F
  793   "IX",90000 10.707,900 0010.707," AA",11.1,2 ,0)
  794   2^F^900001 0.707^.01^ ^2^F
  795   "IX",90000 10.707,900 0010.707," AA",11.1,3 ,0)
  796   3^F^900001 0.707^.03^ ^3^F
  797   "IX",90000 10.707,900 0010.707," AC",0)
  798   9000010.70 7^AC^Index  the Visit , Immuniza tion, and  Contraindi cation/Ref usal field s.^R^^R^IR ^I^9000010 .707^^^^^S
  799   "IX",90000 10.707,900 0010.707," AC",.1,0)
  800   ^^2^2^3160 309^^
  801   "IX",90000 10.707,900 0010.707," AC",.1,1,0 )
  802   This cross  reference  is used f or sorting  contraind ications a nd refusal s
  803   "IX",90000 10.707,900 0010.707," AC",.1,2,0 )
  804   by immuniz ation type  within vi sits.
  805   "IX",90000 10.707,900 0010.707," AC",1)
  806   S ^AUPNVIC R("AC",X(1 ),X(2),X(3 ),DA)=""
  807   "IX",90000 10.707,900 0010.707," AC",2)
  808   K ^AUPNVIC R("AC",X(1 ),X(2),X(3 ),DA)
  809   "IX",90000 10.707,900 0010.707," AC",2.5)
  810   K ^AUPNVIC R("AC")
  811   "IX",90000 10.707,900 0010.707," AC",11.1,0 )
  812   ^.114IA^3^ 3
  813   "IX",90000 10.707,900 0010.707," AC",11.1,1 ,0)
  814   1^F^900001 0.707^.03^ ^1^F
  815   "IX",90000 10.707,900 0010.707," AC",11.1,2 ,0)
  816   2^F^900001 0.707^.04^ ^2^F
  817   "IX",90000 10.707,900 0010.707," AC",11.1,3 ,0)
  818   3^F^900001 0.707^.01^ ^3^F
  819   "IX",90000 10.707,900 0010.707," ACR",0)
  820   9000010.70 7^ACR^Clin ical Remin ders index .^MU^^R^IR ^I^9000010 .707^^^^^A
  821   "IX",90000 10.707,900 0010.707," ACR",.1,0)
  822   ^^12^12^31 51203^
  823   "IX",90000 10.707,900 0010.707," ACR",.1,1, 0)
  824   This cross -reference  builds fo ur indexes , two for  finding al l patients
  825   "IX",90000 10.707,900 0010.707," ACR",.1,2, 0)
  826   with a par ticular im munization  contraind ication/re fusal and  two for
  827   "IX",90000 10.707,900 0010.707," ACR",.1,3, 0)
  828   finding al l the immu nization c ontraindic ation/refu sals a pat ient has.  The
  829   "IX",90000 10.707,900 0010.707," ACR",.1,4, 0)
  830   indexes ar e stored i n the Clin ical Remin ders index  global as :
  831   "IX",90000 10.707,900 0010.707," ACR",.1,5, 0)
  832   ^PXRMINDX( 9000010.70 7,"PIC",DF N,IMM,CONT RA/REFUSAL ,START,STO P,DAS)
  833   "IX",90000 10.707,900 0010.707," ACR",.1,6, 0)
  834   ^PXRMINDX( 9000010.70 7,"PCI",DF N,CONTRA/R EFUSAL,IMM ,START,STO P,DAS)
  835   "IX",90000 10.707,900 0010.707," ACR",.1,7, 0)
  836   and
  837   "IX",90000 10.707,900 0010.707," ACR",.1,8, 0)
  838   ^PXRMINDX( 9000010.70 7,"ICP",IM M,CONTRA/R EFUSAL,DFN ,START,STO P,DAS)
  839   "IX",90000 10.707,900 0010.707," ACR",.1,9, 0)
  840   ^PXRMINDX( 9000010.70 7,"CIP",CO NTRA/REFUS AL,IMM,DFN ,START,STO P,DAS)
  841   "IX",90000 10.707,900 0010.707," ACR",.1,10 ,0)
  842   respective ly.
  843   "IX",90000 10.707,900 0010.707," ACR",.1,11 ,0)
  844   For all th e details,  see the C linical Re minders In dex Techni cal
  845   "IX",90000 10.707,900 0010.707," ACR",.1,12 ,0)
  846   Guide/Prog rammer's M anual.
  847   "IX",90000 10.707,900 0010.707," ACR",1)
  848   D VICRFILE ^PXPXRM(.X ,.DA,"S")
  849   "IX",90000 10.707,900 0010.707," ACR",2)
  850   D VICRFILE ^PXPXRM(.X ,.DA,"K")
  851   "IX",90000 10.707,900 0010.707," ACR",2.5)
  852   K ^PXRMIND X(9000010. 707)
  853   "IX",90000 10.707,900 0010.707," ACR",11.1, 0)
  854   ^.114IA^6^ 6
  855   "IX",90000 10.707,900 0010.707," ACR",11.1, 1,0)
  856   1^F^900001 0.707^.01^ ^1^F
  857   "IX",90000 10.707,900 0010.707," ACR",11.1, 1,3)
  858  
  859   "IX",90000 10.707,900 0010.707," ACR",11.1, 2,0)
  860   2^F^900001 0.707^.02^ ^2^F
  861   "IX",90000 10.707,900 0010.707," ACR",11.1, 2,3)
  862  
  863   "IX",90000 10.707,900 0010.707," ACR",11.1, 3,0)
  864   3^F^900001 0.707^.03^ ^3^F
  865   "IX",90000 10.707,900 0010.707," ACR",11.1, 3,3)
  866  
  867   "IX",90000 10.707,900 0010.707," ACR",11.1, 4,0)
  868   4^F^900001 0.707^.04^ ^4^F
  869   "IX",90000 10.707,900 0010.707," ACR",11.1, 4,3)
  870  
  871   "IX",90000 10.707,900 0010.707," ACR",11.1, 5,0)
  872   5^F^900001 0.707^1201 ^^^F
  873   "IX",90000 10.707,900 0010.707," ACR",11.1, 5,3)
  874  
  875   "IX",90000 10.707,900 0010.707," ACR",11.1, 6,0)
  876   6^F^900001 0.707^.05^ ^^F
  877   "IX",90000 10.707,900 0010.707," ACR",11.1, 6,3)
  878  
  879   "IX",90000 10.707,900 0010.707," AE",0)
  880   9000010.70 7^AE^Index  the Patie nt, Immuni zation, an d Contrain dication/R efusal fie lds.^R^^R^ IR^I^90000 10.707^^^^ ^S
  881   "IX",90000 10.707,900 0010.707," AE",.1,0)
  882   ^^2^2^3160 309^
  883   "IX",90000 10.707,900 0010.707," AE",.1,1,0 )
  884   This cross  reference  is used f or sorting  contraind ications a nd refusal s
  885   "IX",90000 10.707,900 0010.707," AE",.1,2,0 )
  886   by immuniz ation type  for a pat ient.
  887   "IX",90000 10.707,900 0010.707," AE",1)
  888   S ^AUPNVIC R("AE",X(1 ),X(2),X(3 ),DA)=""
  889   "IX",90000 10.707,900 0010.707," AE",2)
  890   K ^AUPNVIC R("AE",X(1 ),X(2),X(3 ),DA)
  891   "IX",90000 10.707,900 0010.707," AE",2.5)
  892   K ^AUPNVIC R("AE")
  893   "IX",90000 10.707,900 0010.707," AE",11.1,0 )
  894   ^.114IA^3^ 3
  895   "IX",90000 10.707,900 0010.707," AE",11.1,1 ,0)
  896   1^F^900001 0.707^.02^ ^1^F
  897   "IX",90000 10.707,900 0010.707," AE",11.1,1 ,3)
  898  
  899   "IX",90000 10.707,900 0010.707," AE",11.1,2 ,0)
  900   2^F^900001 0.707^.04^ ^2^F
  901   "IX",90000 10.707,900 0010.707," AE",11.1,2 ,3)
  902  
  903   "IX",90000 10.707,900 0010.707," AE",11.1,3 ,0)
  904   3^F^900001 0.707^.01^ ^3^F
  905   "IX",90000 10.707,900 0010.707," AE",11.1,3 ,3)
  906  
  907   "KRN",19,9 862,-1)
  908   2^2
  909   "KRN",19,9 862,0)
  910   PXTT TABLE  MAINTENAN CE^PCE Tab le Mainten ance^^M^10 000000009^ ^^^^^^
  911   "KRN",19,9 862,10,0)
  912   ^19.01IP^1 7^17
  913   "KRN",19,9 862,10,17, 0)
  914   14304^DEF
  915   "KRN",19,9 862,10,17, "^")
  916   PXV EDIT D EFAULT RES PONSES
  917   "KRN",19,9 862,"U")
  918   PCE TABLE  MAINTENANC E
  919   "KRN",19,9 881,-1)
  920   0^3
  921   "KRN",19,9 881,0)
  922   PX PCE COD E MAPPING  LIST^PCE C ode Mappin g List^^P^ ^^^^^^y^PC E PATIENT  CARE ENCOU NTER
  923   "KRN",19,9 881,1,0)
  924   ^^13^13^31 60314^
  925   "KRN",19,9 881,1,1,0)
  926   This optio n allows t he user to  see the m apping bet ween CPT c odes
  927   "KRN",19,9 881,1,2,0)
  928   and a rela ted entry  in a PCE s upporting  file.  For  example,  the
  929   "KRN",19,9 881,1,3,0)
  930   CPT code 9 0732 is re lated to t he Immuniz ation file  entry PNE UMOCCOCAL.
  931   "KRN",19,9 881,1,4,0)
  932  
  933   "KRN",19,9 881,1,5,0)
  934   PCE uses t he code ma pping rela tionships  to populat e multiple  files fro m
  935   "KRN",19,9 881,1,6,0)
  936   one data e ntry step.   For exam ple, an en try of PNE UMOCCOCAL  in the V
  937   "KRN",19,9 881,1,7,0)
  938   Immunizati on file wi ll also cr eate a CPT  entry, 90 732 in the  V CPT fil e
  939   "KRN",19,9 881,1,8,0)
  940   which will  then be p assed to P IMS for us e by IB, W orkload, a nd DSS.
  941   "KRN",19,9 881,1,9,0)
  942  
  943   "KRN",19,9 881,1,10,0 )
  944   NOTE: As o f patch PX *1.0*215,  the PCE CO DE MAPPING  file (#81 1.1) has b een
  945   "KRN",19,9 881,1,11,0 )
  946   superseded . The mapp ings of im munization s and skin  tests to  CPT codes  are
  947   "KRN",19,9 881,1,12,0 )
  948   now contai ned in the  CODING SY STEM multi ple of the  IMMUNIZAT ION
  949   "KRN",19,9 881,1,13,0 )
  950   (#9999999. 14) and SK IN TEST (# 9999999.28 ) files th emselves.
  951   "KRN",19,9 881,60)
  952   PXD(811.1,
  953   "KRN",19,9 881,62)
  954   0
  955   "KRN",19,9 881,63)
  956   [PX CODE M APPING PRI NT]
  957   "KRN",19,9 881,64)
  958   [PX CODE M APPING]
  959   "KRN",19,9 881,"U")
  960   PCE CODE M APPING LIS T
  961   "KRN",19,1 4304,-1)
  962   0^1
  963   "KRN",19,1 4304,0)
  964   PXV EDIT D EFAULT RES PONSES^Imm unization  Default Re sponses En ter/Edit^^ R^^^^^^^^
  965   "KRN",19,1 4304,1,0)
  966   ^^2^2^3160 307^
  967   "KRN",19,1 4304,1,1,0 )
  968   This optio n allows t he user to  enter or  update inf ormation i n the IMM
  969   "KRN",19,1 4304,1,2,0 )
  970   DEFAULT RE SPONSES fi le (#920.0 5).
  971   "KRN",19,1 4304,25)
  972   DEF^PXVRES P
  973   "KRN",19,1 4304,"U")
  974   IMMUNIZATI ON DEFAULT  RESPONSES
  975   "KRN",101, 2918,-1)
  976   2^1
  977   "KRN",101, 2918,0)
  978   PXCE ADD/E DIT MENU^A dd/Edit Me nu^^M^1095 8^^^^^^^50 7
  979   "KRN",101, 2918,10,0)
  980   ^101.01PA^ 18^18
  981   "KRN",101, 2918,10,18 ,0)
  982   6150^CR^97 ^
  983   "KRN",101, 2918,10,18 ,"^")
  984   PXCE ICR A DD
  985   "KRN",101, 6150,-1)
  986   0^2
  987   "KRN",101, 6150,0)
  988   PXCE ICR A DD^Contra/ Refusal Ev ent^^A^^^^ ^^^^PCE PA TIENT CARE  ENCOUNTER
  989   "KRN",101, 6150,1,0)
  990   ^^2^2^3151 112^
  991   "KRN",101, 6150,1,1,0 )
  992   This actio n allows y ou to ente r an immun ization co ntraindica tion or
  993   "KRN",101, 6150,1,2,0 )
  994   refusal ev ent.
  995   "KRN",101, 6150,4)
  996   ^^^CR
  997   "KRN",101, 6150,15)
  998   D INIT^PXC EAE
  999   "KRN",101, 6150,20)
  1000   S PXCEFIEN ="" D EN^P XCEVFIL("I CR")
  1001   "KRN",101, 6150,99)
  1002   63874,4702 2
  1003   "KRN",8994 ,3286,-1)
  1004   0^1
  1005   "KRN",8994 ,3286,0)
  1006   PX SAVE DA TA^SAVE^PX RPC^1^P^^^ ^^^1
  1007   "KRN",8994 ,3286,1,0)
  1008   ^8994.01^3 ^3^3160328 ^^^^
  1009   "KRN",8994 ,3286,1,1, 0)
  1010   The purpos e of this  RPC is to  allow the  calling ap plication  to save da ta
  1011   "KRN",8994 ,3286,1,2, 0)
  1012   to PCE, su ch as Immu nization d ata. See t he Integra tion Contr ol
  1013   "KRN",8994 ,3286,1,3, 0)
  1014   Registrati on documen t for the  full descr iption of  the data n eeded.
  1015   "KRN",8994 ,3286,2,0)
  1016   ^8994.02A^ 4^4
  1017   "KRN",8994 ,3286,2,1, 0)
  1018   PCELIST^2^ 10000^1^1
  1019   "KRN",8994 ,3286,2,1, 1,0)
  1020   ^^56^56^31 60328^
  1021   "KRN",8994 ,3286,2,1, 1,1,0)
  1022   PCELIST (n )= HDR ^ E ncounter I npatient?  ^ Note has  CPT codes ? ^ Visit
  1023   "KRN",8994 ,3286,2,1, 1,2,0)
  1024                 string  [Encounter  location;  Encounter  date/time ; Encounte r
  1025   "KRN",8994 ,3286,2,1, 1,3,0)
  1026                 Service  category]   (REQUIRE D)
  1027   "KRN",8994 ,3286,2,1, 1,4,0)
  1028           (n )=VST^DT^E ncounter d ate/time
  1029   "KRN",8994 ,3286,2,1, 1,5,0)
  1030           (n )=VST^PT^E ncounter p atient (DF N) (n)=VST ^HL^Encoun ter locati on
  1031   "KRN",8994 ,3286,2,1, 1,6,0)
  1032           (n )=VST^VC^  Encounter  Service Ca tegory
  1033   "KRN",8994 ,3286,2,1, 1,7,0)
  1034  
  1035   "KRN",8994 ,3286,2,1, 1,8,0)
  1036           If   applicab le:
  1037   "KRN",8994 ,3286,2,1, 1,9,0)
  1038  
  1039   "KRN",8994 ,3286,2,1, 1,10,0)
  1040           (n )=VST^PR^  Parent for  secondary  visit
  1041   "KRN",8994 ,3286,2,1, 1,11,0)
  1042           (n )=VST^OL^  Outside Lo cation for  Historica l visits
  1043   "KRN",8994 ,3286,2,1, 1,12,0)
  1044           (n )=VST^SC^  Service Co nnected re lated?
  1045   "KRN",8994 ,3286,2,1, 1,13,0)
  1046           (n )=VST^AO^  Agent Oran ge related ?
  1047   "KRN",8994 ,3286,2,1, 1,14,0)
  1048           (n )=VST^IR^  Ionizing R adiation r elated?
  1049   "KRN",8994 ,3286,2,1, 1,15,0)
  1050           (n )=VST^EC^  Environmen tal Contam inates rel ated?
  1051   "KRN",8994 ,3286,2,1, 1,16,0)
  1052           (n )=VST^MST^  Military  Sexual Tra uma relate d?
  1053   "KRN",8994 ,3286,2,1, 1,17,0)
  1054           (n )=VST^HNC^  Head and/ or Neck Ca ncer relat ed?
  1055   "KRN",8994 ,3286,2,1, 1,18,0)
  1056           (n )=VST^CV^  Combat Vet  related?
  1057   "KRN",8994 ,3286,2,1, 1,19,0)
  1058           (n )=VST^SHD^  Shipboard  Hazard an d Defense  related?
  1059   "KRN",8994 ,3286,2,1, 1,20,0)
  1060           (n )=PRV(+:   add, -: de lete) ^ Pr ovider IEN  ^^^ Provi der Name ^
  1061   "KRN",8994 ,3286,2,1, 1,21,0)
  1062                Primary  Provider?
  1063   "KRN",8994 ,3286,2,1, 1,22,0)
  1064           (n )=POV(+:   add, -: de lete) ^ IC D diagnosi s code ^ C ategory  ^
  1065   "KRN",8994 ,3286,2,1, 1,23,0)
  1066                Narrativ e (Diagnos is descrip tion) ^ Pr imary Diag nosis? ^
  1067   "KRN",8994 ,3286,2,1, 1,24,0)
  1068                Provider  String ^  Add to Pro blem List?  ^^^ Next  comment
  1069   "KRN",8994 ,3286,2,1, 1,25,0)
  1070                sequence  # if savi ng comment s
  1071   "KRN",8994 ,3286,2,1, 1,26,0)
  1072           (n )=COM^COM  (Comments)  ^ Next co mment sequ ence # ^ @  = no
  1073   "KRN",8994 ,3286,2,1, 1,27,0)
  1074                comments  added
  1075   "KRN",8994 ,3286,2,1, 1,28,0)
  1076           (n )=CPT (+:   add, -: d elete) ^ P rocedural   CPT code  ^ Category  ^
  1077   "KRN",8994 ,3286,2,1, 1,29,0)
  1078                Narrativ e (Procedu re descrip tion) ^ Qu antity ^ P rovider IE N
  1079   "KRN",8994 ,3286,2,1, 1,30,0)
  1080                ^^^ [# o f modifier s;  Modifi er code/Mo difier IEN  ^ Next
  1081   "KRN",8994 ,3286,2,1, 1,31,0)
  1082                comment  sequence #  ^
  1083   "KRN",8994 ,3286,2,1, 1,32,0)
  1084           (n )=IMM (+:   add, -: d elete) ^ I mmunizatio n IEN ^ Ca tegory ^
  1085   "KRN",8994 ,3286,2,1, 1,33,0)
  1086                Narrativ e (Immuniz ation desc ription/na me) ^ Seri es ^
  1087   "KRN",8994 ,3286,2,1, 1,34,0)
  1088                Encounte r Provider  ^ Reactio n ^ Contra indicated?  ^ ^
  1089   "KRN",8994 ,3286,2,1, 1,35,0)
  1090                Next com ment seque nce # ^ CV X Code ^ E vent Info  Source HL7
  1091   "KRN",8994 ,3286,2,1, 1,36,0)
  1092                Code;IEN  ^ Dose;Un its;Units  IEN ^ Rout e Name;HL7  Code;IEN  ^
  1093   "KRN",8994 ,3286,2,1, 1,37,0)
  1094                Admin Si te Name;HL 7 Code;IEN  ^ Lot#;IE N ^ Manufa cturer ^
  1095   "KRN",8994 ,3286,2,1, 1,38,0)
  1096                Expirati on Date ^  Event Date  and Time  ^ Ordering  Provider  ^
  1097   "KRN",8994 ,3286,2,1, 1,39,0)
  1098                VIS IEN/ VIS Date;  VIS IEN n/ VIS Date n  ^ Remarks  Start Seq
  1099   "KRN",8994 ,3286,2,1, 1,40,0)
  1100                #;Remark s End Seq  # ^ Warnin g Ack ^ Ov erride Rea son (Seq # )
  1101   "KRN",8994 ,3286,2,1, 1,41,0)
  1102           (n )=SK (+:   add, -: de lete) ^ Sk in Test IE N ^ Catego ry ^
  1103   "KRN",8994 ,3286,2,1, 1,42,0)
  1104                Narrativ e (Skin Te st descrip tion/name)  ^ Results  ^^ Readin g
  1105   "KRN",8994 ,3286,2,1, 1,43,0)
  1106                ^^^ Next  comment s equence #
  1107   "KRN",8994 ,3286,2,1, 1,44,0)
  1108           (n )=PED (+:   add, -: d elete) ^ P atient Edu cation IEN  ^ Categor y ^
  1109   "KRN",8994 ,3286,2,1, 1,45,0)
  1110                Narrativ e (Patient  Education  descripti on/name) ^  Level of
  1111   "KRN",8994 ,3286,2,1, 1,46,0)
  1112                understa nding ^^^^ ^ ^^ Next  comment se quence #
  1113   "KRN",8994 ,3286,2,1, 1,47,0)
  1114           (n )=HF (+:   add, -: de lete) ^ He alth Facto r IEN ^ Ca tegory ^
  1115   "KRN",8994 ,3286,2,1, 1,48,0)
  1116                Narrativ e (Health  Factor des cription/n ame) ^ Lev el ^^^^^ N ext
  1117   "KRN",8994 ,3286,2,1, 1,49,0)
  1118                comment  sequence #  ^ Get Rem inder
  1119   "KRN",8994 ,3286,2,1, 1,50,0)
  1120           (n )=XAM(+:   add, -: de lete) ^ Ex am IEN ^ C ategory ^  Narrative
  1121   "KRN",8994 ,3286,2,1, 1,51,0)
  1122                (Exam de scription/ name) ^ Re sults ^^^^ ^ Next com ment seque nce
  1123   "KRN",8994 ,3286,2,1, 1,52,0)
  1124                #
  1125   "KRN",8994 ,3286,2,1, 1,53,0)
  1126           (n )=ICR (+:   add, -: d elete) ^ V ariable Po inter IMM
  1127   "KRN",8994 ,3286,2,1, 1,54,0)
  1128                Contrain dication R easons/IMM  Refusal R easons ^ C ategory ^
  1129   "KRN",8994 ,3286,2,1, 1,55,0)
  1130                Narrativ e ^ Immuni zation IEN  ^ Warn Un til Date ^  Event
  1131   "KRN",8994 ,3286,2,1, 1,56,0)
  1132                Date/Tim e ^ Enc Pr ovider IEN  ^ ^ Next  comment se quence #
  1133   "KRN",8994 ,3286,2,2, 0)
  1134   LOC^1^40^0 ^2
  1135   "KRN",8994 ,3286,2,2, 1,0)
  1136   ^^2^2^3140 225^
  1137   "KRN",8994 ,3286,2,2, 1,1,0)
  1138   This is th e hospital  location.  This is n ot used wh en the inf ormation i s
  1139   "KRN",8994 ,3286,2,2, 1,2,0)
  1140   from an ou tside sour ce.
  1141   "KRN",8994 ,3286,2,3, 0)
  1142   PKGNAME^1^ 60^1^3
  1143   "KRN",8994 ,3286,2,3, 1,0)
  1144   ^^2^2^3140 225^
  1145   "KRN",8994 ,3286,2,3, 1,1,0)
  1146   The packag e name tha t is sendi ng the dat a to PCE.  This shoul d be the
  1147   "KRN",8994 ,3286,2,3, 1,2,0)
  1148   full packa ge name, s uch as PAT IENT CARE  ENCOUNTERS .
  1149   "KRN",8994 ,3286,2,4, 0)
  1150   SRC^1^60^1 ^4
  1151   "KRN",8994 ,3286,2,4, 1,0)
  1152   ^8994.021^ 1^1^316032 8^^^^
  1153   "KRN",8994 ,3286,2,4, 1,1,0)
  1154   The source  of the da ta - such  as VLER E- HEALTH EXC HANGE.
  1155   "KRN",8994 ,3286,2,"B ","LOC",2)
  1156  
  1157   "KRN",8994 ,3286,2,"B ","PCELIST ",1)
  1158  
  1159   "KRN",8994 ,3286,2,"B ","PKGNAME ",3)
  1160  
  1161   "KRN",8994 ,3286,2,"B ","SRC",4)
  1162  
  1163   "KRN",8994 ,3286,2,"P ARAMSEQ",1 ,1)
  1164  
  1165   "KRN",8994 ,3286,2,"P ARAMSEQ",2 ,2)
  1166  
  1167   "KRN",8994 ,3286,2,"P ARAMSEQ",3 ,3)
  1168  
  1169   "KRN",8994 ,3286,2,"P ARAMSEQ",4 ,4)
  1170  
  1171   "KRN",8994 ,3286,3,0)
  1172   ^8994.03^8 ^8^3160328 ^^^^
  1173   "KRN",8994 ,3286,3,1, 0)
  1174   The only r eturn will  be the on e passed b ack to the  calling a pplication .
  1175   "KRN",8994 ,3286,3,2, 0)
  1176  
  1177   "KRN",8994 ,3286,3,3, 0)
  1178   A -2 indic ates that  the routin e PXAI fou nd an issu e even tho ugh the
  1179   "KRN",8994 ,3286,3,4, 0)
  1180   original i nput value s appeared  to be cor rect.
  1181   "KRN",8994 ,3286,3,5, 0)
  1182  
  1183   "KRN",8994 ,3286,3,6, 0)
  1184   A -3 indic ates that  the input  parameters  were not  properly d efined.
  1185   "KRN",8994 ,3286,3,7, 0)
  1186  
  1187   "KRN",8994 ,3286,3,8, 0)
  1188   A 1 indica te success .
  1189   "KRN",8994 ,3292,-1)
  1190   0^9
  1191   "KRN",8994 ,3292,0)
  1192   PXVIMM INF O SOURCE^I MMSRC^PXVR PC2^2
  1193   "KRN",8994 ,3292,1,0)
  1194   ^8994.01^1 ^1^3160216 ^^^^
  1195   "KRN",8994 ,3292,1,1, 0)
  1196   Returns en tries from  the IMMUN IZATION IN FO SOURCE  file (920. 1).
  1197   "KRN",8994 ,3292,2,0)
  1198   ^8994.02A^ 1^1
  1199   "KRN",8994 ,3292,2,1, 0)
  1200   FILTER^1^^ 0^1
  1201   "KRN",8994 ,3292,2,1, 1,0)
  1202   ^8994.021^ 11^11^3160 216^^
  1203   "KRN",8994 ,3292,2,1, 1,1,0)
  1204   Filter. Po ssible val ues are:
  1205   "KRN",8994 ,3292,2,1, 1,2,0)
  1206      R:XXX -  Return en try with I EN XXX.
  1207   "KRN",8994 ,3292,2,1, 1,3,0)
  1208      H:XXX -  Return en try with H L7 Code XX X.
  1209   "KRN",8994 ,3292,2,1, 1,4,0)
  1210      N:XXX -  Return en try with # .01 field  equal to X XX
  1211   "KRN",8994 ,3292,2,1, 1,5,0)
  1212      S:X   -  Return al l entries  with a sta tus of X.
  1213   "KRN",8994 ,3292,2,1, 1,6,0)
  1214               Possible  values of  X:
  1215   "KRN",8994 ,3292,2,1, 1,7,0)
  1216                  A - Ac tive Entri es
  1217   "KRN",8994 ,3292,2,1, 1,8,0)
  1218                  I - In active Ent ries
  1219   "KRN",8994 ,3292,2,1, 1,9,0)
  1220                  B - Bo th active  and inacti ve entries
  1221   "KRN",8994 ,3292,2,1, 1,10,0)
  1222  
  1223   "KRN",8994 ,3292,2,1, 1,11,0)
  1224   Defaults t o "S:B".
  1225   "KRN",8994 ,3292,2,"B ","FILTER" ,1)
  1226  
  1227   "KRN",8994 ,3292,2,"P ARAMSEQ",1 ,1)
  1228  
  1229   "KRN",8994 ,3292,3,0)
  1230   ^8994.03^1 4^14^31510 05^^
  1231   "KRN",8994 ,3292,3,1, 0)
  1232   Returns:
  1233   "KRN",8994 ,3292,3,2, 0)
  1234      PXVRSLT (0)=Count  of element s returned  (0 if not hing found )
  1235   "KRN",8994 ,3292,3,3, 0)
  1236      PXVRSLT (n)=IEN^Na me^HL7 Cod e^Status ( 1:Active,  0:Inactive )
  1237   "KRN",8994 ,3292,3,4, 0)
  1238  
  1239   "KRN",8994 ,3292,3,5, 0)
  1240   When filte ring based  off IEN,  HL7 Code,  or #.01 fi eld, only  one entry  will
  1241   "KRN",8994 ,3292,3,6, 0)
  1242   be returne d in PXVRS LT(1).
  1243   "KRN",8994 ,3292,3,7, 0)
  1244  
  1245   "KRN",8994 ,3292,3,8, 0)
  1246   When filte ring based  off statu s, multipl e entries  can be ret urned. The
  1247   "KRN",8994 ,3292,3,9, 0)
  1248   first entr y will be  returned i n subscrip t 1, and s ubscripts  will be
  1249   "KRN",8994 ,3292,3,10 ,0)
  1250   incremente d by 1 for  further e ntries. En tries will  be sorted
  1251   "KRN",8994 ,3292,3,11 ,0)
  1252   alphabetic ally.
  1253   "KRN",8994 ,3292,3,12 ,0)
  1254  
  1255   "KRN",8994 ,3292,3,13 ,0)
  1256   If no entr ies are fo und based  off the fi ltering cr iteria, PX VRSLT(0) w ill
  1257   "KRN",8994 ,3292,3,14 ,0)
  1258   equal 0, a nd there w ill be no  data retur ned in the  subsequen t subscrip ts.
  1259   "KRN",8994 ,3293,-1)
  1260   0^2
  1261   "KRN",8994 ,3293,0)
  1262   PXVIMM ADM IN ROUTE^I MMROUTE^PX VRPC2^2
  1263   "KRN",8994 ,3293,1,0)
  1264   ^8994.01^1 ^1^3160328 ^^^^
  1265   "KRN",8994 ,3293,1,1, 0)
  1266   Returns en tries from  the IMM A DMINISTRAT ION ROUTE  file (920. 2).
  1267   "KRN",8994 ,3293,2,0)
  1268   ^8994.02A^ 3^2
  1269   "KRN",8994 ,3293,2,1, 0)
  1270   FILTER^1^^ 0^1
  1271   "KRN",8994 ,3293,2,1, 1,0)
  1272   ^8994.021^ 11^11^3160 328^^
  1273   "KRN",8994 ,3293,2,1, 1,1,0)
  1274   Filter. Po ssible val ues are:
  1275   "KRN",8994 ,3293,2,1, 1,2,0)
  1276      R:XXX -  Return en try with I EN XXX.
  1277   "KRN",8994 ,3293,2,1, 1,3,0)
  1278      H:XXX -  Return en try with H L7 Code XX X.
  1279   "KRN",8994 ,3293,2,1, 1,4,0)
  1280      N:XXX -  Return en try with # .01 field  equal to X XX
  1281   "KRN",8994 ,3293,2,1, 1,5,0)
  1282      S:X   -  Return al l entries  with a sta tus of X.
  1283   "KRN",8994 ,3293,2,1, 1,6,0)
  1284               Possible  values of  X:
  1285   "KRN",8994 ,3293,2,1, 1,7,0)
  1286                  A - Ac tive Entri es
  1287   "KRN",8994 ,3293,2,1, 1,8,0)
  1288                  I - In active Ent ries
  1289   "KRN",8994 ,3293,2,1, 1,9,0)
  1290                  B - Bo th active  and inacti ve entries
  1291   "KRN",8994 ,3293,2,1, 1,10,0)
  1292  
  1293   "KRN",8994 ,3293,2,1, 1,11,0)
  1294   Defaults t o "S:B".
  1295   "KRN",8994 ,3293,2,3, 0)
  1296   PXVSITES^1 ^^0^2
  1297   "KRN",8994 ,3293,2,3, 1,0)
  1298   ^8994.021^ 1^1^316021 6^^^
  1299   "KRN",8994 ,3293,2,3, 1,1,0)
  1300   Controls i f the avai lable site s for a gi ve route a re returne d.
  1301   "KRN",8994 ,3293,2,"B ","FILTER" ,1)
  1302  
  1303   "KRN",8994 ,3293,2,"B ","PXVSITE S",3)
  1304  
  1305   "KRN",8994 ,3293,2,"P ARAMSEQ",1 ,1)
  1306  
  1307   "KRN",8994 ,3293,2,"P ARAMSEQ",2 ,3)
  1308  
  1309   "KRN",8994 ,3293,3,0)
  1310   ^8994.03^1 3^13^31603 28^^^
  1311   "KRN",8994 ,3293,3,1, 0)
  1312   PXVRSLT(0) =Count of  elements r eturned (0  if nothin g found)
  1313   "KRN",8994 ,3293,3,2, 0)
  1314   PXVRSLT(n) =IEN^Name^ HL7 Code^S tatus (1:A ctive, 0:I nactive)
  1315   "KRN",8994 ,3293,3,3, 0)
  1316  
  1317   "KRN",8994 ,3293,3,4, 0)
  1318   If PXVSITE S=1, the s ites for a  given rou te will al so be retu rned.
  1319   "KRN",8994 ,3293,3,5, 0)
  1320      o If on ly a subse t of sites  are selec table for  a route, t hat list w ill
  1321   "KRN",8994 ,3293,3,6, 0)
  1322        be re turned in:
  1323   "KRN",8994 ,3293,3,7, 0)
  1324          PXV RSLT(n+1)= SITE^Site  IEN 1
  1325   "KRN",8994 ,3293,3,8, 0)
  1326          PXV RSLT(n+2)= SITE^Site  IEN 2
  1327   "KRN",8994 ,3293,3,9, 0)
  1328          PXV RSLT(n+x)= SITE^Site  IEN x
  1329   "KRN",8994 ,3293,3,10 ,0)
  1330      o If al l sites ar e selectab le for a r oute, the  RPC will r eturn:
  1331   "KRN",8994 ,3293,3,11 ,0)
  1332          PXV RSLT(n+1)= SITE^ALL
  1333   "KRN",8994 ,3293,3,12 ,0)
  1334      o If no  sites are  selectabl e for a ro ute, the R PC will re turn:
  1335   "KRN",8994 ,3293,3,13 ,0)
  1336          PXV RSLT(n+1)= SITE^NONE
  1337   "KRN",8994 ,3293,3,14 ,0)
  1338   equal 0, a nd there w ill be no  data retur ned in the  subsequen t subscrip ts.
  1339   "KRN",8994 ,3294,-1)
  1340   0^3
  1341   "KRN",8994 ,3294,0)
  1342   PXVIMM ADM IN SITE^IM MSITE^PXVR PC2^2
  1343   "KRN",8994 ,3294,1,0)
  1344   ^8994.01^1 ^1^3160216 ^^
  1345   "KRN",8994 ,3294,1,1, 0)
  1346   Returns en tries from  the IMM A DMINISTRAT ION SITE ( BODY) file  (920.3).
  1347   "KRN",8994 ,3294,2,0)
  1348   ^8994.02A^ 1^1
  1349   "KRN",8994 ,3294,2,1, 0)
  1350   FILTER^1^^ 0^1
  1351   "KRN",8994 ,3294,2,1, 1,0)
  1352   ^^11^11^31 51001^
  1353   "KRN",8994 ,3294,2,1, 1,1,0)
  1354   Filter. Po ssible val ues are:
  1355   "KRN",8994 ,3294,2,1, 1,2,0)
  1356      R:XXX -  Return en try with I EN XXX.
  1357   "KRN",8994 ,3294,2,1, 1,3,0)
  1358      H:XXX -  Return en try with H L7 Code XX X.
  1359   "KRN",8994 ,3294,2,1, 1,4,0)
  1360      N:XXX -  Return en try with # .01 field  equal to X XX
  1361   "KRN",8994 ,3294,2,1, 1,5,0)
  1362      S:X   -  Return al l entries  with a sta tus of X.
  1363   "KRN",8994 ,3294,2,1, 1,6,0)
  1364               Possible  values of  X:
  1365   "KRN",8994 ,3294,2,1, 1,7,0)
  1366                  A - Ac tive Entri es
  1367   "KRN",8994 ,3294,2,1, 1,8,0)
  1368                  I - In active Ent ries
  1369   "KRN",8994 ,3294,2,1, 1,9,0)
  1370                  B - Bo th active  and inacti ve entries
  1371   "KRN",8994 ,3294,2,1, 1,10,0)
  1372  
  1373   "KRN",8994 ,3294,2,1, 1,11,0)
  1374   Defaults t o "S:B".
  1375   "KRN",8994 ,3294,2,"B ","FILTER" ,1)
  1376  
  1377   "KRN",8994 ,3294,2,"P ARAMSEQ",1 ,1)
  1378  
  1379   "KRN",8994 ,3294,3,0)
  1380   ^8994.03^1 4^14^31510 01^^
  1381   "KRN",8994 ,3294,3,1, 0)
  1382   Returns:
  1383   "KRN",8994 ,3294,3,2, 0)
  1384      PXVRSLT (0)=Count  of element s returned  (0 if not hing found )
  1385   "KRN",8994 ,3294,3,3, 0)
  1386      PXVRSLT (n)=IEN^Na me^HL7 Cod e^Status ( 1:Active,  0:Inactive )
  1387   "KRN",8994 ,3294,3,4, 0)
  1388  
  1389   "KRN",8994 ,3294,3,5, 0)
  1390   When filte ring based  off IEN,  HL7 Code,  or #.01 fi eld, only  one entry  will
  1391   "KRN",8994 ,3294,3,6, 0)
  1392   be returne d in PXVRS LT(1).
  1393   "KRN",8994 ,3294,3,7, 0)
  1394  
  1395   "KRN",8994 ,3294,3,8, 0)
  1396   When filte ring based  off statu s, multipl e entries  can be ret urned. The
  1397   "KRN",8994 ,3294,3,9, 0)
  1398   first entr y will be  returned i n subscrip t 1, and s ubscripts  will be
  1399   "KRN",8994 ,3294,3,10 ,0)
  1400   incremente d by 1 for  further e ntries. En tries will  be sorted
  1401   "KRN",8994 ,3294,3,11 ,0)
  1402   alphabetic ally.
  1403   "KRN",8994 ,3294,3,12 ,0)
  1404  
  1405   "KRN",8994 ,3294,3,13 ,0)
  1406   If no entr ies are fo und based  off the fi ltering cr iteria, PX VRSLT(0) w ill
  1407   "KRN",8994 ,3294,3,14 ,0)
  1408   equal 0, a nd there w ill be no  data retur ned in the  subsequen t subscrip ts.
  1409   "KRN",8994 ,3295,-1)
  1410   0^5
  1411   "KRN",8994 ,3295,0)
  1412   PXVIMM IMM  LOT^ILOT^ PXVRPC1^4^ ^^^1
  1413   "KRN",8994 ,3295,1,0)
  1414   ^8994.01^2 ^2^3160201 ^^^^
  1415   "KRN",8994 ,3295,1,1, 0)
  1416   This RPC r eturns inf ormation f rom the IM MUNIZATION  LOT file
  1417   "KRN",8994 ,3295,1,2, 0)
  1418   (#9999999. 41).
  1419   "KRN",8994 ,3295,2,0)
  1420   ^8994.02A^ 2^2
  1421   "KRN",8994 ,3295,2,1, 0)
  1422   FILTER^1^3 0^0^1
  1423   "KRN",8994 ,3295,2,1, 1,0)
  1424   ^8994.021^ 9^9^315112 0^^^^
  1425   "KRN",8994 ,3295,2,1, 1,1,0)
  1426   This input  parameter  is used t o specify  the IMMUNI ZATION LOT  file
  1427   "KRN",8994 ,3295,2,1, 1,2,0)
  1428   records to  be return ed. Possib le values:
  1429   "KRN",8994 ,3295,2,1, 1,3,0)
  1430      R:XXX -  return en try with i en XXX
  1431   "KRN",8994 ,3295,2,1, 1,4,0)
  1432      N:XXX -  return en try with l ot number  XXX
  1433   "KRN",8994 ,3295,2,1, 1,5,0)
  1434      S:A   -  return li st of all  active lot  numbers
  1435   "KRN",8994 ,3295,2,1, 1,6,0)
  1436      S:I   -  return li st of all  inactive l ot num
  1437   "KRN",8994 ,3295,2,1, 1,7,0)
  1438      S:B   -  return li st of all  lot number s, active  and inacti ve
  1439   "KRN",8994 ,3295,2,1, 1,8,0)
  1440  
  1441   "KRN",8994 ,3295,2,1, 1,9,0)
  1442   If this pa rameter is  null, it  defaults t o "S:B".
  1443   "KRN",8994 ,3295,2,2, 0)
  1444   PXVI^1^1^0 ^2
  1445   "KRN",8994 ,3295,2,2, 1,0)
  1446   ^8994.021^ 4^4^316020 1^^^
  1447   "KRN",8994 ,3295,2,2, 1,1,0)
  1448   This optio nal input  parameter  is used to  return an  alternate  array wit h
  1449   "KRN",8994 ,3295,2,2, 1,2,0)
  1450   record dat a in a car et delimit ed string.  If this p arameter i s null or  0,
  1451   "KRN",8994 ,3295,2,2, 1,3,0)
  1452   the return  defaults  to the oth er array.
  1453   "KRN",8994 ,3295,2,2, 1,4,0)
  1454      1 - ret urn altern ate array  with inter nal values  in delimi ted string
  1455   "KRN",8994 ,3295,2,"B ","FILTER" ,1)
  1456  
  1457   "KRN",8994 ,3295,2,"B ","PXVI",2 )
  1458  
  1459   "KRN",8994 ,3295,2,"P ARAMSEQ",1 ,1)
  1460  
  1461   "KRN",8994 ,3295,2,"P ARAMSEQ",2 ,2)
  1462  
  1463   "KRN",8994 ,3295,3,0)
  1464   ^8994.03^6 4^64^31602 01^^^
  1465   "KRN",8994 ,3295,3,1, 0)
  1466   Returns wi th PXVI no t equal to  1:
  1467   "KRN",8994 ,3295,3,2, 0)
  1468      PXVRETR N  - retur ned inform ation is s tored in ^ TMP("PXVLS T",$J))
  1469   "KRN",8994 ,3295,3,3, 0)
  1470                 - retur n info for mat: Data  Element Na me^Data El ement Valu e
  1471   "KRN",8994 ,3295,3,4, 0)
  1472                 -        error for mat: -1^er ror messag e
  1473   "KRN",8994 ,3295,3,5, 0)
  1474  
  1475   "KRN",8994 ,3295,3,6, 0)
  1476   For each r ecord retu rned in th e global a rray, the  top value  returned w ill
  1477   "KRN",8994 ,3295,3,7, 0)
  1478   indicate t he record  number in  the array  and the to tal number  of record s
  1479   "KRN",8994 ,3295,3,8, 0)
  1480   returned,  e.g., "REC ORD^1 OF 3 ".
  1481   "KRN",8994 ,3295,3,9, 0)
  1482  
  1483   "KRN",8994 ,3295,3,10 ,0)
  1484   This RPC r eturns the  internal  entry numb er (IEN) o f the reco rd and dat a in
  1485   "KRN",8994 ,3295,3,11 ,0)
  1486   external f ormat from  the follo wing data  fields in  the IMMUNI ZATION LOT
  1487   "KRN",8994 ,3295,3,12 ,0)
  1488   file:
  1489   "KRN",8994 ,3295,3,13 ,0)
  1490      - LOT N UMBER (#.0 1)
  1491   "KRN",8994 ,3295,3,14 ,0)
  1492      - MANUF ACTURER (# .02)
  1493   "KRN",8994 ,3295,3,15 ,0)
  1494      - STATU S (#.03)
  1495   "KRN",8994 ,3295,3,16 ,0)
  1496      - VACCI NE (#.04)
  1497   "KRN",8994 ,3295,3,17 ,0)
  1498      - EXPIR ATION DATE  (#.09)
  1499   "KRN",8994 ,3295,3,18 ,0)
  1500      - DOSES  UNUSED (# .12)
  1501   "KRN",8994 ,3295,3,19 ,0)
  1502      - LOW S UPPLY ALER T (#.15)
  1503   "KRN",8994 ,3295,3,20 ,0)
  1504      - NDC C ODE (VA) ( #.18)
  1505   "KRN",8994 ,3295,3,21 ,0)
  1506  
  1507   "KRN",8994 ,3295,3,22 ,0)
  1508     Example  Global Arr ay Returne d:
  1509   "KRN",8994 ,3295,3,23 ,0)
  1510      ^TMP("P XVLST",$J, "P92A8769L N 1",0)="R ECORD^1 OF  1"
  1511   "KRN",8994 ,3295,3,24 ,0)
  1512                                      .001)="I EN^6"
  1513   "KRN",8994 ,3295,3,25 ,0)
  1514                                       .01)="L OT NUMBER^ P92A8769LN "
  1515   "KRN",8994 ,3295,3,26 ,0)
  1516                                       .02)="M ANUFACTURE R^SCLAVO,  INC."
  1517   "KRN",8994 ,3295,3,27 ,0)
  1518                                       .03)="S TATUS^ACTI VE"
  1519   "KRN",8994 ,3295,3,28 ,0)
  1520                                       .04)="V ACCINE^ANT HRAX"
  1521   "KRN",8994 ,3295,3,29 ,0)
  1522                                       .09)="E XPIRATION  DATE^DEC 3 1, 2016"
  1523   "KRN",8994 ,3295,3,30 ,0)
  1524                                       .12)="D OSES UNUSE D^94"
  1525   "KRN",8994 ,3295,3,31 ,0)
  1526                                       .15)="L OW SUPPLY  ALERT^10"
  1527   "KRN",8994 ,3295,3,32 ,0)
  1528                                       .18)="N DC CODE (V A)^"
  1529   "KRN",8994 ,3295,3,33 ,0)
  1530  
  1531   "KRN",8994 ,3295,3,34 ,0)
  1532     Example  Global Arr ay Returne d if No Re cords Foun d:
  1533   "KRN",8994 ,3295,3,35 ,0)
  1534      ^TMP("P XVLST",$J, 0)="0 RECO RDS"
  1535   "KRN",8994 ,3295,3,36 ,0)
  1536  
  1537   "KRN",8994 ,3295,3,37 ,0)
  1538     Example  error mess ages:
  1539   "KRN",8994 ,3295,3,38 ,0)
  1540      ^TMP("P XVLST",$J, 0)="-1^Inv alid input  value"
  1541   "KRN",8994 ,3295,3,39 ,0)
  1542      ^TMP("P XVLST",$J, 0)="-1^Inv alid input  for immun ization lo t IEN"
  1543   "KRN",8994 ,3295,3,40 ,0)
  1544      ^TMP("P XVLST",$J, 0)="-1^Inv alid input  for lot n umber"
  1545   "KRN",8994 ,3295,3,41 ,0)
  1546  
  1547   "KRN",8994 ,3295,3,42 ,0)
  1548   Returns wi th PXVI eq ual to 1:
  1549   "KRN",8994 ,3295,3,43 ,0)
  1550      PXVRETR N  - retur ned inform ation is s tored in ^ TMP("PXVLS T",$J))
  1551   "KRN",8994 ,3295,3,44 ,0)
  1552  
  1553   "KRN",8994 ,3295,3,45 ,0)
  1554      Each re cord is a  caret-deli mited list  of values . Within t he
  1555   "KRN",8994 ,3295,3,46 ,0)
  1556      caret-d elimited l ist, for f ields with  different  internal  and extern al
  1557   "KRN",8994 ,3295,3,47 ,0)
  1558      values,  both the  internal a nd externa l values a re include d, delimit ed
  1559   "KRN",8994 ,3295,3,48 ,0)
  1560      by a ti lde (~) as  indicated  below:
  1561   "KRN",8994 ,3295,3,49 ,0)
  1562       Piece#  Field# Fi eld Name
  1563   "KRN",8994 ,3295,3,50 ,0)
  1564       ------  ------ -- --------
  1565   "KRN",8994 ,3295,3,51 ,0)
  1566       1              IE N
  1567   "KRN",8994 ,3295,3,52 ,0)
  1568       2       .01    LO T NUMBER
  1569   "KRN",8994 ,3295,3,53 ,0)
  1570       3       .02    MA NUFACTURER   (Interna l~External )
  1571   "KRN",8994 ,3295,3,54 ,0)
  1572       4       .03    ST ATUS (Inte rnal~Exter nal)
  1573   "KRN",8994 ,3295,3,55 ,0)
  1574       5       .04    VA CCINE (Int ernal~Exte rnal)
  1575   "KRN",8994 ,3295,3,56 ,0)
  1576       6       .09    EX PIRATION D ATE (Inter nal~Extern al)
  1577   "KRN",8994 ,3295,3,57 ,0)
  1578       7       .12    DO SES UNUSED
  1579   "KRN",8994 ,3295,3,58 ,0)
  1580       8       .15    LO W SUPPLY A LERT
  1581   "KRN",8994 ,3295,3,59 ,0)
  1582       9       .18    ND C CODE (VA ) (Interna l~External )
  1583   "KRN",8994 ,3295,3,60 ,0)
  1584  
  1585   "KRN",8994 ,3295,3,61 ,0)
  1586     Example  Alternate  Global Arr ay:
  1587   "KRN",8994 ,3295,3,62 ,0)
  1588      ^TMP("P XVLST",$J, 0)=1 RECOR D
  1589   "KRN",8994 ,3295,3,63 ,0)
  1590                          6)="6^P92 A8769LN^49 ~SCLAVO, I NC.^0~ACTI VE^41~ANTH RAX^
  1591   "KRN",8994 ,3295,3,64 ,0)
  1592                               3161 231~DEC 31 , 2016^93^ 10^~"
  1593   "KRN",8994 ,3296,-1)
  1594   0^6
  1595   "KRN",8994 ,3296,0)
  1596   PXVIMM IMM  MAN^IMAN^ PXVRPC1^4^ ^^^1
  1597   "KRN",8994 ,3296,1,0)
  1598   ^8994.01^2 ^2^3160201 ^^^^
  1599   "KRN",8994 ,3296,1,1, 0)
  1600   This RPC r eturns inf ormation f rom the IM M MANUFACT URER file
  1601   "KRN",8994 ,3296,1,2, 0)
  1602   (#9999999. 04).
  1603   "KRN",8994 ,3296,2,0)
  1604   ^8994.02A^ 3^3
  1605   "KRN",8994 ,3296,2,1, 0)
  1606   FILTER^1^8 0^0^1
  1607   "KRN",8994 ,3296,2,1, 1,0)
  1608   ^8994.021^ 10^10^3151 006^^
  1609   "KRN",8994 ,3296,2,1, 1,1,0)
  1610   This input  parameter  is used t o specify  the IMMUNI ZATION LOT  file
  1611   "KRN",8994 ,3296,2,1, 1,2,0)
  1612   records to  be return ed. Possib le values:
  1613   "KRN",8994 ,3296,2,1, 1,3,0)
  1614      R:XXX -  return en try with i en XXX
  1615   "KRN",8994 ,3296,2,1, 1,4,0)
  1616      M:XXX -  return en try with M VX code XX X
  1617   "KRN",8994 ,3296,2,1, 1,5,0)
  1618      N:XXX -  return en try with i mm manufac turer name  XXX
  1619   "KRN",8994 ,3296,2,1, 1,6,0)
  1620      S:A   -  return li st of all  active man ufacturers
  1621   "KRN",8994 ,3296,2,1, 1,7,0)
  1622      S:I   -  return li st of all  inactive m anufacture rs
  1623   "KRN",8994 ,3296,2,1, 1,8,0)
  1624      S:B   -  return li st of all  manufactur ers, activ e and inac tive
  1625   "KRN",8994 ,3296,2,1, 1,9,0)
  1626  
  1627   "KRN",8994 ,3296,2,1, 1,10,0)
  1628   If this pa rameter is  null, it  defaults t o "S:B".
  1629   "KRN",8994 ,3296,2,2, 0)
  1630   PXVDATE^1^ 7^0^2
  1631   "KRN",8994 ,3296,2,2, 1,0)
  1632   ^8994.021^ 3^3^316020 1^^^
  1633   "KRN",8994 ,3296,2,2, 1,1,0)
  1634   This optio nal input  parameter  is used in  determini ng status.  Input
  1635   "KRN",8994 ,3296,2,2, 1,2,0)
  1636   should be  in VA File Man date f ormat. The  default v alue is th e current
  1637   "KRN",8994 ,3296,2,2, 1,3,0)
  1638   date.
  1639   "KRN",8994 ,3296,2,3, 0)
  1640   PXVI^1^1^0 ^3
  1641   "KRN",8994 ,3296,2,3, 1,0)
  1642   ^^4^4^3160 201^
  1643   "KRN",8994 ,3296,2,3, 1,1,0)
  1644   This optio nal input  parameter  is used to  return an  alternate  array wit h
  1645   "KRN",8994 ,3296,2,3, 1,2,0)
  1646   record dat a in a car et delimit ed string.  If this p arameter i s null or  0,
  1647   "KRN",8994 ,3296,2,3, 1,3,0)
  1648   the return  defaults  to the oth er array.
  1649   "KRN",8994 ,3296,2,3, 1,4,0)
  1650      1 - ret urn altern ate array  with inter nal values  in delimi ted string
  1651   "KRN",8994 ,3296,2,"B ","FILTER" ,1)
  1652  
  1653   "KRN",8994 ,3296,2,"B ","PXVDATE ",2)
  1654  
  1655   "KRN",8994 ,3296,2,"B ","PXVI",3 )
  1656  
  1657   "KRN",8994 ,3296,2,"P ARAMSEQ",1 ,1)
  1658  
  1659   "KRN",8994 ,3296,2,"P ARAMSEQ",2 ,2)
  1660  
  1661   "KRN",8994 ,3296,2,"P ARAMSEQ",3 ,3)
  1662  
  1663   "KRN",8994 ,3296,3,0)
  1664   ^^52^52^31 60201^
  1665   "KRN",8994 ,3296,3,1, 0)
  1666   Returns wi th PXVI no t equal to  1:
  1667   "KRN",8994 ,3296,3,2, 0)
  1668      PXVRETR N  - retur ned inform ation is s tored in ^ TMP("PXVLS T",$J))
  1669   "KRN",8994 ,3296,3,3, 0)
  1670                 - retur n info for mat: Data  Element Na me^Data El ement Valu e
  1671   "KRN",8994 ,3296,3,4, 0)
  1672                 -        error for mat: -1^er ror messag e
  1673   "KRN",8994 ,3296,3,5, 0)
  1674  
  1675   "KRN",8994 ,3296,3,6, 0)
  1676   For each r ecord retu rned in th e global a rray, the  top value  returned w ill
  1677   "KRN",8994 ,3296,3,7, 0)
  1678   indicate t he record  number in  the array  and the to tal number  of record s
  1679   "KRN",8994 ,3296,3,8, 0)
  1680   returned,  e.g., "REC ORD^1 OF 3 ".
  1681   "KRN",8994 ,3296,3,9, 0)
  1682  
  1683   "KRN",8994 ,3296,3,10 ,0)
  1684   This RPC r eturns the  internal  entry numb er (IEN) o f the reco rd and dat a
  1685   "KRN",8994 ,3296,3,11 ,0)
  1686   in externa l format f rom the fo llowing da ta fields  in the IMM
  1687   "KRN",8994 ,3296,3,12 ,0)
  1688   MANUFACTUR ER file:
  1689   "KRN",8994 ,3296,3,13 ,0)
  1690     - NAME ( #.01)
  1691   "KRN",8994 ,3296,3,14 ,0)
  1692     - MVX (# .02)
  1693   "KRN",8994 ,3296,3,15 ,0)
  1694     - INACTI VE FLAG (# .03)
  1695   "KRN",8994 ,3296,3,16 ,0)
  1696     - CDC NO TES (#201)
  1697   "KRN",8994 ,3296,3,17 ,0)
  1698     - STATUS  (computed  by Data S tandardiza tion utili ty)
  1699   "KRN",8994 ,3296,3,18 ,0)
  1700  
  1701   "KRN",8994 ,3296,3,19 ,0)
  1702     Example  Global Arr ay Returne d:
  1703   "KRN",8994 ,3296,3,20 ,0)
  1704     ^TMP("PX VLST",$J," WYETH-AYER ST 1",0)=" RECORD^1 O F 1"
  1705   "KRN",8994 ,3296,3,21 ,0)
  1706                                       .001)=" IEN^55"
  1707   "KRN",8994 ,3296,3,22 ,0)
  1708                                        .01)=" NAME^WYETH -AYERST"
  1709   "KRN",8994 ,3296,3,23 ,0)
  1710                                        .02)=" MVX CODE^W A"
  1711   "KRN",8994 ,3296,3,24 ,0)
  1712                                        .03)=" INACTIVE F LAG^INACTI VE"
  1713   "KRN",8994 ,3296,3,25 ,0)
  1714                                        201)=" CDC NOTES^ became WAL , now owne d by
  1715   "KRN",8994 ,3296,3,26 ,0)
  1716                                               Pfizer"
  1717   "KRN",8994 ,3296,3,27 ,0)
  1718                                  " STATUS")=" STATUS^INA CTIVE"
  1719   "KRN",8994 ,3296,3,28 ,0)
  1720  
  1721   "KRN",8994 ,3296,3,29 ,0)
  1722     Example  Global Arr ay Returne d if No Re cords Foun d:
  1723   "KRN",8994 ,3296,3,30 ,0)
  1724     ^TMP("PX VLST",$J,0 )="0 RECOR DS"
  1725   "KRN",8994 ,3296,3,31 ,0)
  1726  
  1727   "KRN",8994 ,3296,3,32 ,0)
  1728     Example  error mess ages:
  1729   "KRN",8994 ,3296,3,33 ,0)
  1730     ^TMP("PX VLST",$J,0 )="-1^Inva lid input  value"
  1731   "KRN",8994 ,3296,3,34 ,0)
  1732     ^TMP("PX VLST",$J,0 )="-1^Inva lid input  for manufa cturer IEN "
  1733   "KRN",8994 ,3296,3,35 ,0)
  1734     ^TMP("PX VLST",$J,0 )="-1^Inva lid input  for MVX co de"
  1735   "KRN",8994 ,3296,3,36 ,0)
  1736     ^TMP("PX VLST",$J,0 )="-1^Inva lid input  for manufa cturer nam e"
  1737   "KRN",8994 ,3296,3,37 ,0)
  1738  
  1739   "KRN",8994 ,3296,3,38 ,0)
  1740   Returns wi th PXVI eq ual to 1:
  1741   "KRN",8994 ,3296,3,39 ,0)
  1742      PXVRETR N  - retur ned inform ation is s tored in ^ TMP("PXVLS T",$J))
  1743   "KRN",8994 ,3296,3,40 ,0)
  1744  
  1745   "KRN",8994 ,3296,3,41 ,0)
  1746      Each re cord is a  caret-deli mited list  of values . Within t he
  1747   "KRN",8994 ,3296,3,42 ,0)
  1748      caret-d elimited l ist, for f ields with  different  internal  and extern al
  1749   "KRN",8994 ,3296,3,43 ,0)
  1750      values,  both the  internal a nd externa l values a re include d, delimit ed
  1751   "KRN",8994 ,3296,3,44 ,0)
  1752      by a ti lde (~) as  indicated  below:
  1753   "KRN",8994 ,3296,3,45 ,0)
  1754       Piece#  Field# Fi eld Name
  1755   "KRN",8994 ,3296,3,46 ,0)
  1756       ------  ------ -- --------
  1757   "KRN",8994 ,3296,3,47 ,0)
  1758       1              IE N
  1759   "KRN",8994 ,3296,3,48 ,0)
  1760       2       .01    NA ME
  1761   "KRN",8994 ,3296,3,49 ,0)
  1762       3       .02    MV X CODE
  1763   "KRN",8994 ,3296,3,50 ,0)
  1764       4       .03    IN ACTIVE FLA G (Interna l~External )
  1765   "KRN",8994 ,3296,3,51 ,0)
  1766       5       201    CD C NOTES
  1767   "KRN",8994 ,3296,3,52 ,0)
  1768       6              ST ATUS (comp uted by Da ta Standar dization u tility)
  1769   "KRN",8994 ,3297,-1)
  1770   0^10
  1771   "KRN",8994 ,3297,0)
  1772   PXVIMM VIS ^IVIS^PXVR PC1^4^^^^1
  1773   "KRN",8994 ,3297,1,0)
  1774   ^8994.01^2 ^2^3151102 ^^^^
  1775   "KRN",8994 ,3297,1,1, 0)
  1776   This RPC r eturns inf ormation f rom the VA CCINE INFO RMATION ST ATEMENT fi le
  1777   "KRN",8994 ,3297,1,2, 0)
  1778   (#920).
  1779   "KRN",8994 ,3297,2,0)
  1780   ^8994.02A^ 2^2
  1781   "KRN",8994 ,3297,2,1, 0)
  1782   FILTER^1^5 5^0^1
  1783   "KRN",8994 ,3297,2,1, 1,0)
  1784   ^^9^9^3151 006^
  1785   "KRN",8994 ,3297,2,1, 1,1,0)
  1786   This input  parameter  is used t o specify  the VACCIN E INFORMAT ION
  1787   "KRN",8994 ,3297,2,1, 1,2,0)
  1788   STATEMENT  file recor ds to be r eturned.
  1789   "KRN",8994 ,3297,2,1, 1,3,0)
  1790      R:XXX -  return en try with i en XXX
  1791   "KRN",8994 ,3297,2,1, 1,4,0)
  1792      N:XXX -  return en try with V IS name XX X
  1793   "KRN",8994 ,3297,2,1, 1,5,0)
  1794      S:A   -  return li st of all  active VIS s
  1795   "KRN",8994 ,3297,2,1, 1,6,0)
  1796      S:I   -  return li st of all  inactive V ISs
  1797   "KRN",8994 ,3297,2,1, 1,7,0)
  1798      S:B   -  return li st of all  VISs, acti ve and ina ctive
  1799   "KRN",8994 ,3297,2,1, 1,8,0)
  1800  
  1801   "KRN",8994 ,3297,2,1, 1,9,0)
  1802   If this pa rameter is  null, it  defaults t o "S:B".
  1803   "KRN",8994 ,3297,2,2, 0)
  1804   PXVDATE^1^ 7^0^2
  1805   "KRN",8994 ,3297,2,2, 1,0)
  1806   ^8994.021^ 3^3^315100 8^^
  1807   "KRN",8994 ,3297,2,2, 1,1,0)
  1808   This optio nal input  parameter  is used in  determini ng status.  Input
  1809   "KRN",8994 ,3297,2,2, 1,2,0)
  1810   should be  in VA File Man date f ormat. The  default v alue is th e current
  1811   "KRN",8994 ,3297,2,2, 1,3,0)
  1812   date.
  1813   "KRN",8994 ,3297,2,"B ","FILTER" ,1)
  1814  
  1815   "KRN",8994 ,3297,2,"B ","PXVDATE ",2)
  1816  
  1817   "KRN",8994 ,3297,2,"P ARAMSEQ",1 ,1)
  1818  
  1819   "KRN",8994 ,3297,2,"P ARAMSEQ",2 ,2)
  1820  
  1821   "KRN",8994 ,3297,3,0)
  1822   ^^52^52^31 51102^
  1823   "KRN",8994 ,3297,3,1, 0)
  1824   Returns:
  1825   "KRN",8994 ,3297,3,2, 0)
  1826     PXVRETRN   - return ed informa tion is st ored in ^T MP("PXVLST ",$J))
  1827   "KRN",8994 ,3297,3,3, 0)
  1828                - return  info form at: Data E lement Nam e^Data Ele ment Value
  1829   "KRN",8994 ,3297,3,4, 0)
  1830                -        error form at: -1^err or message
  1831   "KRN",8994 ,3297,3,5, 0)
  1832  
  1833   "KRN",8994 ,3297,3,6, 0)
  1834   For each r ecord retu rned in th e global a rray, the  top value  returned w ill
  1835   "KRN",8994 ,3297,3,7, 0)
  1836   indicate t he record  number in  the array  and the to tal number  of record s
  1837   "KRN",8994 ,3297,3,8, 0)
  1838   returned,  e.g., "REC ORD^1 OF 3 ".
  1839   "KRN",8994 ,3297,3,9, 0)
  1840  
  1841   "KRN",8994 ,3297,3,10 ,0)
  1842   This RPC r eturns the  internal  entry numb er (IEN) o f the reco rd and dat a
  1843   "KRN",8994 ,3297,3,11 ,0)
  1844   in externa l format f rom the fo llowing da ta fields  in the VAC CINE
  1845   "KRN",8994 ,3297,3,12 ,0)
  1846   INFORMATIO N STATEMEN T file:
  1847   "KRN",8994 ,3297,3,13 ,0)
  1848     - NAME ( #.01)
  1849   "KRN",8994 ,3297,3,14 ,0)
  1850     - EDITIO N DATE (#. 02)
  1851   "KRN",8994 ,3297,3,15 ,0)
  1852     - EDITIO N STATUS ( #.03)
  1853   "KRN",8994 ,3297,3,16 ,0)
  1854     - LANGUA GE (#.04)
  1855   "KRN",8994 ,3297,3,17 ,0)
  1856     - VIS TE XT (#2) (w ord-proces sing)
  1857   "KRN",8994 ,3297,3,18 ,0)
  1858     - 2D BAR  CODE (#10 0)
  1859   "KRN",8994 ,3297,3,19 ,0)
  1860     - VIS UR L (#101)
  1861   "KRN",8994 ,3297,3,20 ,0)
  1862     - STATUS  (computed  by Data S tandardiza tion utili ty)
  1863   "KRN",8994 ,3297,3,21 ,0)
  1864  
  1865   "KRN",8994 ,3297,3,22 ,0)
  1866   Example Gl obal Array  Returned:
  1867   "KRN",8994 ,3297,3,23 ,0)
  1868   (Stored in  ^TMP("PXV LST",$J,"S HINGLES VI S 1",)
  1869   "KRN",8994 ,3297,3,24 ,0)
  1870      0)="REC ORD^1 OF 1 "
  1871   "KRN",8994 ,3297,3,25 ,0)
  1872    .001)="IE N^27"
  1873   "KRN",8994 ,3297,3,26 ,0)
  1874    .01)="NAM E^SHINGLES  VIS"
  1875   "KRN",8994 ,3297,3,27 ,0)
  1876    .02)="EDI TION DATE^ OCT 06, 20 09"
  1877   "KRN",8994 ,3297,3,28 ,0)
  1878    .03)="EDI TION STATU S^CURRENT"
  1879   "KRN",8994 ,3297,3,29 ,0)
  1880    .04)="LAN GUAGE^ENGL ISH"
  1881   "KRN",8994 ,3297,3,30 ,0)
  1882    2,1)="VIS  TEXT 1^Sh ingles  Va ccine: Wha t you need  to know "
  1883   "KRN",8994 ,3297,3,31 ,0)
  1884      2)="VIS  TEXT 2^ "
  1885   "KRN",8994 ,3297,3,32 ,0)
  1886      3)="VIS  TEXT 3^1.  What is s hingles?"
  1887   "KRN",8994 ,3297,3,33 ,0)
  1888      4)="VIS  TEXT 4^ "
  1889   "KRN",8994 ,3297,3,34 ,0)
  1890      5)="VIS  TEXT 5^Sh ingles is  a painful  skin rash,  often wit h blisters . It
  1891   "KRN",8994 ,3297,3,35 ,0)
  1892          is  also calle d "
  1893   "KRN",8994 ,3297,3,36 ,0)
  1894      .
  1895   "KRN",8994 ,3297,3,37 ,0)
  1896      .
  1897   "KRN",8994 ,3297,3,38 ,0)
  1898      .
  1899   "KRN",8994 ,3297,3,39 ,0)
  1900      117)="V IS TEXT 11 7^ "
  1901   "KRN",8994 ,3297,3,40 ,0)
  1902      118)="V IS TEXT 11 8^Departme nt of Heal th and Hum an Service s"
  1903   "KRN",8994 ,3297,3,41 ,0)
  1904      119)="V IS TEXT 11 9^Centers  for Diseas e Control  and Preven tion"
  1905   "KRN",8994 ,3297,3,42 ,0)
  1906    100)="2D  BAR CODE^2 5308869830 0020211091 006"
  1907   "KRN",8994 ,3297,3,43 ,0)
  1908    101)="VIS  URL^http: //www.immu nize.org/v is/shingle s.pdf"
  1909   "KRN",8994 ,3297,3,44 ,0)
  1910    "STATUS") ="STATUS^A CTIVE"
  1911   "KRN",8994 ,3297,3,45 ,0)
  1912  
  1913   "KRN",8994 ,3297,3,46 ,0)
  1914   Example Gl obal Array  Returned  if No Reco rds Found:
  1915   "KRN",8994 ,3297,3,47 ,0)
  1916    ^TMP("PXV LST",$J,0) ="0 RECORD S"
  1917   "KRN",8994 ,3297,3,48 ,0)
  1918  
  1919   "KRN",8994 ,3297,3,49 ,0)
  1920   Example er ror messag es:
  1921   "KRN",8994 ,3297,3,50 ,0)
  1922    ^TMP("PXV LST",$J,0) ="-1^Inval id input v alue"
  1923   "KRN",8994 ,3297,3,51 ,0)
  1924    ^TMP("PXV LST",$J,0) ="-1^Inval id input f or VIS IEN "
  1925   "KRN",8994 ,3297,3,52 ,0)
  1926    ^TMP("PXV LST",$J,0) ="-1^Inval id input f or VIS nam e"
  1927   "KRN",8994 ,3298,-1)
  1928   0^8
  1929   "KRN",8994 ,3298,0)
  1930   PXVIMM IMM DATA^IMMDA TA^PXVRPC3 ^4^^^^1
  1931   "KRN",8994 ,3298,1,0)
  1932   ^8994.01^1 ^1^3151120 ^^^
  1933   "KRN",8994 ,3298,1,1, 0)
  1934   Returns en tries from  the IMMUN IZATION fi le (999999 9.14).
  1935   "KRN",8994 ,3298,2,0)
  1936   ^8994.02A^ 2^2
  1937   "KRN",8994 ,3298,2,1, 0)
  1938   FILTER^1^^ 0^1
  1939   "KRN",8994 ,3298,2,1, 1,0)
  1940   ^^8^8^3151 021^
  1941   "KRN",8994 ,3298,2,1, 1,1,0)
  1942   This param eter is us ed to spec ify the IM MUNIZATION  file reco rds to be
  1943   "KRN",8994 ,3298,2,1, 1,2,0)
  1944   returned.  Possible v alues:
  1945   "KRN",8994 ,3298,2,1, 1,3,0)
  1946      R:XXX -  return en try with i en XXX
  1947   "KRN",8994 ,3298,2,1, 1,4,0)
  1948      S:A   -  return li st of acti ve immuniz ations
  1949   "KRN",8994 ,3298,2,1, 1,5,0)
  1950      S:H   -  return li st of [sel ectable fo r] histori c immuniza tions
  1951   "KRN",8994 ,3298,2,1, 1,6,0)
  1952      S:*   -  return al l records  regardless  of their  status
  1953   "KRN",8994 ,3298,2,1, 1,7,0)
  1954  
  1955   "KRN",8994 ,3298,2,1, 1,8,0)
  1956   If this pa rameter is  null, it  defaults t o "S:A".
  1957   "KRN",8994 ,3298,2,2, 0)
  1958   SUBFILES^1 ^1^0^2
  1959   "KRN",8994 ,3298,2,2, 1,0)
  1960   ^8994.021^ 1^1^315112 0^^
  1961   "KRN",8994 ,3298,2,2, 1,1,0)
  1962   A value of  1 or Y in dicates th at all sub file multi ples shoul d be inclu ded.
  1963   "KRN",8994 ,3298,2,"B ","FILTER" ,1)
  1964  
  1965   "KRN",8994 ,3298,2,"B ","SUBFILE S",2)
  1966  
  1967   "KRN",8994 ,3298,2,"P ARAMSEQ",1 ,1)
  1968  
  1969   "KRN",8994 ,3298,2,"P ARAMSEQ",2 ,2)
  1970  
  1971   "KRN",8994 ,3298,3,0)
  1972   ^8994.03^2 8^28^31511 20^^
  1973   "KRN",8994 ,3298,3,1, 0)
  1974   The first  record of  the return ed array c ontains th e count of  records
  1975   "KRN",8994 ,3298,3,2, 0)
  1976   being retu rned.
  1977   "KRN",8994 ,3298,3,3, 0)
  1978   Each recor d is a car et-delimit ed list of  values.
  1979   "KRN",8994 ,3298,3,4, 0)
  1980   Piece# Fie ld# Field  Name
  1981   "KRN",8994 ,3298,3,5, 0)
  1982   ------ --- --- ------ ----
  1983   "KRN",8994 ,3298,3,6, 0)
  1984   1              IEN
  1985   "KRN",8994 ,3298,3,7, 0)
  1986   2      .01     NAME
  1987   "KRN",8994 ,3298,3,8, 0)
  1988   3      .02     SHORT  NAME
  1989   "KRN",8994 ,3298,3,9, 0)
  1990   4      .03     CVX CO DE
  1991   "KRN",8994 ,3298,3,10 ,0)
  1992   5      .05     MAX #  IN SERIES
  1993   "KRN",8994 ,3298,3,11 ,0)
  1994   6      .07     INACTI VE FLAG
  1995   "KRN",8994 ,3298,3,12 ,0)
  1996   7      880 1   MNEMON IC
  1997   "KRN",8994 ,3298,3,13 ,0)
  1998   8      880 2   ACRONY M
  1999   "KRN",8994 ,3298,3,14 ,0)
  2000   9      880 3   SELECT ABLE FOR H ISTORIC
  2001   "KRN",8994 ,3298,3,15 ,0)
  2002   (These sub files are  included w hen the SU BFILES par ameter is  set to 1)
  2003   "KRN",8994 ,3298,3,16 ,0)
  2004   (Each mult iple is se parated by  the pipe  (|) charac ter)
  2005   "KRN",8994 ,3298,3,17 ,0)
  2006   10     2       CDC FU LL VACCINE  NAME
  2007   "KRN",8994 ,3298,3,18 ,0)
  2008   11     3       CODING  SYSTEM
  2009   "KRN",8994 ,3298,3,19 ,0)
  2010                  (For e ach CODING  SYSTEM, t here are m ultiple CO DE values. )
  2011   "KRN",8994 ,3298,3,20 ,0)
  2012                  (CODIN G SYSTEM1~ CODE1;;COD E2|CODING  SYSTEM2~CO DE3;;CODE4 )
  2013   "KRN",8994 ,3298,3,21 ,0)
  2014   12     4       VACCIN E INFORMAT ION STATEM ENT
  2015   "KRN",8994 ,3298,3,22 ,0)
  2016                  (VIS1- IEN~VIS1-N AME|VIS2-I EN~VIS2-NA ME)
  2017   "KRN",8994 ,3298,3,23 ,0)
  2018   13     5       CDC PR ODUCT NAME
  2019   "KRN",8994 ,3298,3,24 ,0)
  2020   14     7       VACCIN E GROUP NA ME
  2021   "KRN",8994 ,3298,3,25 ,0)
  2022   15     10      SYNONY M
  2023   "KRN",8994 ,3298,3,26 ,0)
  2024   16     99. 991 EFFECT IVE DATE/T IME
  2025   "KRN",8994 ,3298,3,27 ,0)
  2026                  (There  are date/ time and s tatus fiel ds in each  multiple. )
  2027   "KRN",8994 ,3298,3,28 ,0)
  2028                  (EFFEC TIVE DATE/ TIME1~STAT US1|EFFECT IVE DATE/T IME2~STATU S2)
  2029   "KRN",8994 ,3312,-1)
  2030   0^11
  2031   "KRN",8994 ,3312,0)
  2032   PXVIMM ICR  LIST^GETI CR^PXVRPC5 ^2
  2033   "KRN",8994 ,3312,1,0)
  2034   ^8994.01^2 ^2^3160216 ^^
  2035   "KRN",8994 ,3312,1,1, 0)
  2036   Returns en tries from  the IMM C ONTRAINDIC ATION REAS ONS (#920. 4) and IMM
  2037   "KRN",8994 ,3312,1,2, 0)
  2038   REFUSAL RE ASONS (#92 0.5) files .
  2039   "KRN",8994 ,3312,2,0)
  2040   ^8994.02A^ 2^2
  2041   "KRN",8994 ,3312,2,1, 0)
  2042   PXFILE^1^^ 0^1
  2043   "KRN",8994 ,3312,2,1, 1,0)
  2044   ^^6^6^3160 129^
  2045   "KRN",8994 ,3312,2,1, 1,1,0)
  2046   Which file  to pull f rom.
  2047   "KRN",8994 ,3312,2,1, 1,2,0)
  2048   (Optional;  Leave thi s null to  pull entri es from bo th files)
  2049   "KRN",8994 ,3312,2,1, 1,3,0)
  2050   Possible v alues are:
  2051   "KRN",8994 ,3312,2,1, 1,4,0)
  2052      "920.4"  - Only re turn entri es from IM M CONTRAIN DICATION R EASONS
  2053   "KRN",8994 ,3312,2,1, 1,5,0)
  2054                 (#920.4 )
  2055   "KRN",8994 ,3312,2,1, 1,6,0)
  2056      "920.5"  - Only re turn entri es from IM M REFUSAL  REASONS (# 920.5)
  2057   "KRN",8994 ,3312,2,2, 0)
  2058   FILTER^1^^ 0^2
  2059   "KRN",8994 ,3312,2,2, 1,0)
  2060   ^^13^13^31 60129^
  2061   "KRN",8994 ,3312,2,2, 1,1,0)
  2062   Filter (Op tional; De faults to  "S:A")
  2063   "KRN",8994 ,3312,2,2, 1,2,0)
  2064   Possible v alues are:
  2065   "KRN",8994 ,3312,2,2, 1,3,0)
  2066      R:X   -  Return en try with I EN X (PXFI LE must be  passed in  with this
  2067   "KRN",8994 ,3312,2,2, 1,4,0)
  2068               option).
  2069   "KRN",8994 ,3312,2,2, 1,5,0)
  2070      C:X^Y -  Return en try with C oncept Cod e^Coding S ystem X^Y  (used only  for
  2071   "KRN",8994 ,3312,2,2, 1,6,0)
  2072               #920.4).
  2073   "KRN",8994 ,3312,2,2, 1,7,0)
  2074      H:X   -  Return en try with H L7 Code X  (used only  for #920. 5).
  2075   "KRN",8994 ,3312,2,2, 1,8,0)
  2076      N:X   -  Return en try with # .01 field  equal to X
  2077   "KRN",8994 ,3312,2,2, 1,9,0)
  2078      I:X   -  Return al l active e ntries tha t are sele ctable for  Immunizat ion
  2079   "KRN",8994 ,3312,2,2, 1,10,0)
  2080               IEN X.
  2081   "KRN",8994 ,3312,2,2, 1,11,0)
  2082      S:A   -  Return al l active e ntries.
  2083   "KRN",8994 ,3312,2,2, 1,12,0)
  2084      S:I   -  Return al l inactive  entries.
  2085   "KRN",8994 ,3312,2,2, 1,13,0)
  2086      S:B   -  Return al l entries  (both acti ve and ina ctive).
  2087   "KRN",8994 ,3312,2,"B ","FILTER" ,2)
  2088  
  2089   "KRN",8994 ,3312,2,"B ","PXFILE" ,1)
  2090  
  2091   "KRN",8994 ,3312,2,"P ARAMSEQ",1 ,1)
  2092  
  2093   "KRN",8994 ,3312,2,"P ARAMSEQ",2 ,2)
  2094  
  2095   "KRN",8994 ,3312,3,0)
  2096   ^^6^6^3160 129^
  2097   "KRN",8994 ,3312,3,1, 0)
  2098   PXRSLT(0)= Count of e lements re turned (0  if nothing  found)
  2099   "KRN",8994 ,3312,3,2, 0)
  2100   For 920.4  Entry:
  2101   "KRN",8994 ,3312,3,3, 0)
  2102      PXRSLT( n)=IEN;PXV (920.4,^Na me^Status  (1:Active,  0:Inactiv e)^Code|Co ding
  2103   "KRN",8994 ,3312,3,4, 0)
  2104                 System^ NIP004^Con traindicat ion/Precau tion
  2105   "KRN",8994 ,3312,3,5, 0)
  2106   For 920.5  Entry:
  2107   "KRN",8994 ,3312,3,6, 0)
  2108      PXRSLT( n)=IEN;PXV (920.5,^Na me^Status  (1:Active,  0:Inactiv e)^HL7 Cod e
  2109   "KRN",8994 ,3313,-1)
  2110   0^12
  2111   "KRN",8994 ,3313,0)
  2112   PXVIMM VIC R EVENTS^G ETVICR^PXV RPC5^2
  2113   "KRN",8994 ,3313,1,0)
  2114   ^8994.01^4 ^4^3160405 ^^^^
  2115   "KRN",8994 ,3313,1,1, 0)
  2116   Returns "a ctive" ent ries from  the V IMM  CONTRA/REF USAL EVENT S file
  2117   "KRN",8994 ,3313,1,2, 0)
  2118   (#9000010. 707) that  are relate d to the g iven patie nt and imm unization.
  2119   "KRN",8994 ,3313,1,3, 0)
  2120   "Active" i s defined  as entries  where the  Event Dat e and Time  is >= PXD ATE
  2121   "KRN",8994 ,3313,1,4, 0)
  2122   and the Wa rn Until D ate is nul l or great er than PX DATE.
  2123   "KRN",8994 ,3313,2,0)
  2124   ^8994.02A^ 4^4
  2125   "KRN",8994 ,3313,2,1, 0)
  2126   DFN^1^^1^1
  2127   "KRN",8994 ,3313,2,1, 1,0)
  2128   ^^1^1^3160 129^
  2129   "KRN",8994 ,3313,2,1, 1,1,0)
  2130   Pointer to  file #2.
  2131   "KRN",8994 ,3313,2,2, 0)
  2132   PXVIMM^1^^ 1^2
  2133   "KRN",8994 ,3313,2,2, 1,0)
  2134   ^^1^1^3160 129^
  2135   "KRN",8994 ,3313,2,2, 1,1,0)
  2136   Pointer to  #9999999. 14.
  2137   "KRN",8994 ,3313,2,3, 0)
  2138   PXDATE^1^^ 0^3
  2139   "KRN",8994 ,3313,2,3, 1,0)
  2140   ^^1^1^3160 308^
  2141   "KRN",8994 ,3313,2,3, 1,1,0)
  2142   Used to de termine if  entry is  "active" ( Optional;  Defaults t o TODAY)
  2143   "KRN",8994 ,3313,2,4, 0)
  2144   PXFORMAT^1 ^^0^4
  2145   "KRN",8994 ,3313,2,4, 1,0)
  2146   ^8994.021^ 4^4^316040 5^^
  2147   "KRN",8994 ,3313,2,4, 1,1,0)
  2148   Format tha t return a rray shoul d be retur ned (Optio nal; Defau lts to "L" )
  2149   "KRN",8994 ,3313,2,4, 1,2,0)
  2150   Possible v alues are:
  2151   "KRN",8994 ,3313,2,4, 1,3,0)
  2152      "L": Re turn a car et-delimit ed list of  entries.
  2153   "KRN",8994 ,3313,2,4, 1,4,0)
  2154      "W": Re turns a wa rning mess age.
  2155   "KRN",8994 ,3313,2,"B ","DFN",1)
  2156  
  2157   "KRN",8994 ,3313,2,"B ","PXDATE" ,3)
  2158  
  2159   "KRN",8994 ,3313,2,"B ","PXFORMA T",4)
  2160  
  2161   "KRN",8994 ,3313,2,"B ","PXVIMM" ,2)
  2162  
  2163   "KRN",8994 ,3313,2,"P ARAMSEQ",1 ,1)
  2164  
  2165   "KRN",8994 ,3313,2,"P ARAMSEQ",2 ,2)
  2166  
  2167   "KRN",8994 ,3313,2,"P ARAMSEQ",3 ,3)
  2168  
  2169   "KRN",8994 ,3313,2,"P ARAMSEQ",4 ,4)
  2170  
  2171   "KRN",8994 ,3313,3,0)
  2172   ^^9^9^3160 405^
  2173   "KRN",8994 ,3313,3,1, 0)
  2174   PXRSLT(0)= Count of e lements re turned (0  if nothing  found)
  2175   "KRN",8994 ,3313,3,2, 0)
  2176   If PXFORMA T="L":
  2177   "KRN",8994 ,3313,3,3, 0)
  2178      PXRSLT( n)="VICR"  ^ V IMM Co ntra/Refus al Events  IEN ^ Visi t IEN ^
  2179   "KRN",8994 ,3313,3,4, 0)
  2180                 Contra/ Refusal va riable poi nter | Con tra/Refusa l Name ^
  2181   "KRN",8994 ,3313,3,5, 0)
  2182                 Immuniz ation IEN  | Name ^ W arn Until  Date ^ D/T  Recorded  ^
  2183   "KRN",8994 ,3313,3,6, 0)
  2184                 Event D /T ^ Encou nter Provi der IEN |  Name
  2185   "KRN",8994 ,3313,3,7, 0)
  2186      PXRSLT( n)="COM" ^  Comments
  2187   "KRN",8994 ,3313,3,8, 0)
  2188   If PXFORMA T["W":
  2189   "KRN",8994 ,3313,3,9, 0)
  2190      PXRSLT( n)=Warning  text
  2191   "KRN",8994 ,3314,-1)
  2192   0^7
  2193   "KRN",8994 ,3314,0)
  2194   PXVIMM IMM  SHORT LIS T^IMMSHORT ^PXVRPC4^2
  2195   "KRN",8994 ,3314,1,0)
  2196   ^^1^1^3160 129^
  2197   "KRN",8994 ,3314,1,1, 0)
  2198   Returns a  short list  of immuni zations.
  2199   "KRN",8994 ,3314,2,0)
  2200   ^8994.02A^ 2^2
  2201   "KRN",8994 ,3314,2,1, 0)
  2202   FILTER^1^^ 0^1
  2203   "KRN",8994 ,3314,2,1, 1,0)
  2204   ^8994.021^ 6^6^316012 9^^
  2205   "KRN",8994 ,3314,2,1, 1,1,0)
  2206   Filter (Op tional; De faults to  "B")
  2207   "KRN",8994 ,3314,2,1, 1,2,0)
  2208   Possible v alues are:  ;
  2209   "KRN",8994 ,3314,2,1, 1,3,0)
  2210      "A": On ly return  active ent ries
  2211   "KRN",8994 ,3314,2,1, 1,4,0)
  2212      "H": On ly return  entries ma rked as Se lectable f or Histori c
  2213   "KRN",8994 ,3314,2,1, 1,5,0)
  2214      "B": Re turn both  active ent ries and t hose marke d as Selec table for
  2215   "KRN",8994 ,3314,2,1, 1,6,0)
  2216           Hi storic
  2217   "KRN",8994 ,3314,2,2, 0)
  2218   PXDATE^1^^ 0^2
  2219   "KRN",8994 ,3314,2,2, 1,0)
  2220   ^^3^3^3160 129^
  2221   "KRN",8994 ,3314,2,2, 1,1,0)
  2222   Date (opti onal; defa ults to TO DAY)
  2223   "KRN",8994 ,3314,2,2, 1,2,0)
  2224   Used for d etermining  immunizat ion status  (both for  filtering  and for
  2225   "KRN",8994 ,3314,2,2, 1,3,0)
  2226   return val ue)
  2227   "KRN",8994 ,3314,2,"B ","FILTER" ,1)
  2228  
  2229   "KRN",8994 ,3314,2,"B ","PXDATE" ,2)
  2230  
  2231   "KRN",8994 ,3314,2,"P ARAMSEQ",1 ,1)
  2232  
  2233   "KRN",8994 ,3314,2,"P ARAMSEQ",2 ,2)
  2234  
  2235   "KRN",8994 ,3314,3,0)
  2236   ^^20^20^31 60129^
  2237   "KRN",8994 ,3314,3,1, 0)
  2238   PXRTRN(x)
  2239   "KRN",8994 ,3314,3,2, 0)
  2240      Note: S tatus (in  the 5th pi ece) is de termined a s follows:
  2241   "KRN",8994 ,3314,3,3, 0)
  2242        - If  PXDATE is  today, the  status is  based off  the Inact ive Flag
  2243   "KRN",8994 ,3314,3,4, 0)
  2244          (#. 07)
  2245   "KRN",8994 ,3314,3,5, 0)
  2246        - If  PXDATE is  different  than today , we will  look when  an update  was
  2247   "KRN",8994 ,3314,3,6, 0)
  2248          las t made to  the Immuni zation fil e (based o ff the Aud its). If t here
  2249   "KRN",8994 ,3314,3,7, 0)
  2250          hav e not been  any chang es since P XDATE, we  will get t he status
  2251   "KRN",8994 ,3314,3,8, 0)
  2252          bas ed off the  Inactive  Flag, othe rwise, we  will get t he status  for
  2253   "KRN",8994 ,3314,3,9, 0)
  2254          tha t date by  calling GE TSTAT^XTID .
  2255   "KRN",8994 ,3314,3,10 ,0)
  2256      1: "IMM "
  2257   "KRN",8994 ,3314,3,11 ,0)
  2258      2: #999 9999.14 IE N
  2259   "KRN",8994 ,3314,3,12 ,0)
  2260      3: Name  (#.01)
  2261   "KRN",8994 ,3314,3,13 ,0)
  2262      4: CVX  Code (#.03 )
  2263   "KRN",8994 ,3314,3,14 ,0)
  2264      5: Stat us (1: Act ive; 0: In active)
  2265   "KRN",8994 ,3314,3,15 ,0)
  2266      6: Sele ctable for  Historic  (#8803)
  2267   "KRN",8994 ,3314,3,16 ,0)
  2268      7: Mnem onic (#880 1)
  2269   "KRN",8994 ,3314,3,17 ,0)
  2270      8: Acro nym (#8802 )
  2271   "KRN",8994 ,3314,3,18 ,0)
  2272   PXRTRN(x)
  2273   "KRN",8994 ,3314,3,19 ,0)
  2274      1: "CDC "
  2275   "KRN",8994 ,3314,3,20 ,0)
  2276      2: CDC  Product Na me (#99999 99.145, #. 01)
  2277   "KRN",8994 ,3315,-1)
  2278   0^4
  2279   "KRN",8994 ,3315,0)
  2280   PXVIMM IMM  DETAILED^ IMMRPC^PXV RPC4^4^^^^ 1
  2281   "KRN",8994 ,3315,1,0)
  2282   ^8994.01^1 ^1^3160310 ^^^^
  2283   "KRN",8994 ,3315,1,1, 0)
  2284   Returns a  detailed I mmunizatio n record
  2285   "KRN",8994 ,3315,2,0)
  2286   ^8994.02A^ 2^2
  2287   "KRN",8994 ,3315,2,1, 0)
  2288   PXIMM^1^^1 ^1
  2289   "KRN",8994 ,3315,2,1, 1,0)
  2290   ^^1^1^3160 129^
  2291   "KRN",8994 ,3315,2,1, 1,1,0)
  2292   Pointer to  #9999999. 14 (Requir ed)
  2293   "KRN",8994 ,3315,2,2, 0)
  2294   PXDATE^1^^ 0^2
  2295   "KRN",8994 ,3315,2,2, 1,0)
  2296   ^8994.021^ 2^2^316031 0^^^^
  2297   "KRN",8994 ,3315,2,2, 1,1,0)
  2298   Immunizati on status  and Codes  will be ba sed off th is date
  2299   "KRN",8994 ,3315,2,2, 1,2,0)
  2300   (Optional;  Defaults  to NOW)
  2301   "KRN",8994 ,3315,2,"B ","PXDATE" ,2)
  2302  
  2303   "KRN",8994 ,3315,2,"B ","PXIMM", 1)
  2304  
  2305   "KRN",8994 ,3315,2,"P ARAMSEQ",1 ,1)
  2306  
  2307   "KRN",8994 ,3315,2,"P ARAMSEQ",2 ,2)
  2308  
  2309   "KRN",8994 ,3315,3,0)
  2310   ^^78^78^31 60310^
  2311   "KRN",8994 ,3315,3,1, 0)
  2312   ^TMP("PXVI MMRPC",$J, 0)
  2313   "KRN",8994 ,3315,3,2, 0)
  2314      1:  1 -  Immunizat ion was fo und. The " 1" node wi ll be retu rned, but  the
  2315   "KRN",8994 ,3315,3,3, 0)
  2316               other nod es are opt ional.
  2317   "KRN",8994 ,3315,3,4, 0)
  2318         -1 -  Immunizat ion was no t found; n o other no des will b e returned
  2319   "KRN",8994 ,3315,3,5, 0)
  2320   ^TMP("PXVI MMRPC",$J, 1)
  2321   "KRN",8994 ,3315,3,6, 0)
  2322      Note: S tatus (in  the 5th pi ece) is de termined a s follows:
  2323   "KRN",8994 ,3315,3,7, 0)
  2324        - If  PXDATE is  today, the  status is  based off  the Inact ive Flag
  2325   "KRN",8994 ,3315,3,8, 0)
  2326          (#. 07)
  2327   "KRN",8994 ,3315,3,9, 0)
  2328        - If  PXDATE is  different  than today , we will  look when  an update  was
  2329   "KRN",8994 ,3315,3,10 ,0)
  2330          las t made to  the Immuni zation fil e (based o ff the Aud its). If t here
  2331   "KRN",8994 ,3315,3,11 ,0)
  2332          hav e not been  any chang es since P XDATE, we  will get t he status
  2333   "KRN",8994 ,3315,3,12 ,0)
  2334          bas ed off the  Inactive  Flag, othe rwise, we  will get t he status  for
  2335   "KRN",8994 ,3315,3,13 ,0)
  2336          tha t date by  calling GE TSTAT^XTID .
  2337   "KRN",8994 ,3315,3,14 ,0)
  2338      1: "IMM "
  2339   "KRN",8994 ,3315,3,15 ,0)
  2340      2: #999 9999.14 IE N
  2341   "KRN",8994 ,3315,3,16 ,0)
  2342      3: Name  (#.01)
  2343   "KRN",8994 ,3315,3,17 ,0)
  2344      4: CVX  Code (#.03 )
  2345   "KRN",8994 ,3315,3,18 ,0)
  2346      5: Stat us (1: Act ive; 0: In active)
  2347   "KRN",8994 ,3315,3,19 ,0)
  2348      6: Sele ctable for  Historic  (#8803)
  2349   "KRN",8994 ,3315,3,20 ,0)
  2350      7: Mnem onic (#880 1)
  2351   "KRN",8994 ,3315,3,21 ,0)
  2352      8: Acro nym (#8802 )
  2353   "KRN",8994 ,3315,3,22 ,0)
  2354      9: Max  # In Serie s (#.05)
  2355   "KRN",8994 ,3315,3,23 ,0)
  2356     10: Comb ination Im munization  (Y/N) (#. 2)
  2357   "KRN",8994 ,3315,3,24 ,0)
  2358     11: Read ing Requir ed (#.51)
  2359   "KRN",8994 ,3315,3,25 ,0)
  2360   ^TMP("PXVI MMRPC",$J, x)
  2361   "KRN",8994 ,3315,3,26 ,0)
  2362      1: "VIS "
  2363   "KRN",8994 ,3315,3,27 ,0)
  2364      2: #920  IEN
  2365   "KRN",8994 ,3315,3,28 ,0)
  2366      3: Name  (#920,#.0 1)
  2367   "KRN",8994 ,3315,3,29 ,0)
  2368      4: Edit ion Date ( #920,#.02)
  2369   "KRN",8994 ,3315,3,30 ,0)
  2370      5: Edit ion Status  (#920,#.0 3)
  2371   "KRN",8994 ,3315,3,31 ,0)
  2372      6: Lang uage (#920 , #.04)
  2373   "KRN",8994 ,3315,3,32 ,0)
  2374      7: 2D B ar Code (# 100)
  2375   "KRN",8994 ,3315,3,33 ,0)
  2376   ^TMP("PXVI MMRPC",$J, x)
  2377   "KRN",8994 ,3315,3,34 ,0)
  2378      1: "CDC "
  2379   "KRN",8994 ,3315,3,35 ,0)
  2380      2: CDC  Product Na me (#99999 99.145, #. 01)
  2381   "KRN",8994 ,3315,3,36 ,0)
  2382   ^TMP("PXVI MMRPC",$J, x)
  2383   "KRN",8994 ,3315,3,37 ,0)
  2384      1: "GRO UP"
  2385   "KRN",8994 ,3315,3,38 ,0)
  2386      2: Vacc ine Group  Name (#999 9999.147,  #.01)
  2387   "KRN",8994 ,3315,3,39 ,0)
  2388   ^TMP("PXVI MMRPC",$J, x)
  2389   "KRN",8994 ,3315,3,40 ,0)
  2390      1: "SYN ONYM"
  2391   "KRN",8994 ,3315,3,41 ,0)
  2392      2: Syno nym (#9999 999.141, # .01)
  2393   "KRN",8994 ,3315,3,42 ,0)
  2394   ^TMP("PXVI MMRPC",$J, x)
  2395   "KRN",8994 ,3315,3,43 ,0)
  2396      Note: O nly active  codes (ba sed off PX DATE) are  returned.
  2397   "KRN",8994 ,3315,3,44 ,0)
  2398      1: "CS"
  2399   "KRN",8994 ,3315,3,45 ,0)
  2400      2: Codi ng System  (#9999999. 143, #.01)
  2401   "KRN",8994 ,3315,3,46 ,0)
  2402      3: Code  (#9999999 .1431,#.01 )
  2403   "KRN",8994 ,3315,3,47 ,0)
  2404      4: Vari able point er. e.g.,  IEN;ICPT(
  2405   "KRN",8994 ,3315,3,48 ,0)
  2406      5: Shor t Descript ion
  2407   "KRN",8994 ,3315,3,49 ,0)
  2408   ^TMP("PXVI MMRPC",$J, x)
  2409   "KRN",8994 ,3315,3,50 ,0)
  2410      Note: O nly active  lots are  returned.
  2411   "KRN",8994 ,3315,3,51 ,0)
  2412            A lso, the E xpiration  date must  be >= PXDA TE
  2413   "KRN",8994 ,3315,3,52 ,0)
  2414      1: "LOT "
  2415   "KRN",8994 ,3315,3,53 ,0)
  2416      2: #999 9999.41 IE N
  2417   "KRN",8994 ,3315,3,54 ,0)
  2418      3: Lot  Number (#9 999999.41,  #.01)
  2419   "KRN",8994 ,3315,3,55 ,0)
  2420      4: Manu facturer ( #9999999.0 4, #.01)
  2421   "KRN",8994 ,3315,3,56 ,0)
  2422      5: Expi ration Dat e (#999999 9.41, #.09 )
  2423   "KRN",8994 ,3315,3,57 ,0)
  2424      6: Dose s Unused ( #9999999.4 1, #.12)
  2425   "KRN",8994 ,3315,3,58 ,0)
  2426      7: Low  Supply Ale rt (#99999 99.41, #.1 5)
  2427   "KRN",8994 ,3315,3,59 ,0)
  2428      8: NDC  Code (#999 9999.41, # .18)
  2429   "KRN",8994 ,3315,3,60 ,0)
  2430   ^TMP("PXVI MMRPC",$J, x)
  2431   "KRN",8994 ,3315,3,61 ,0)
  2432      Note: O nly active  contraind ications a re returne d
  2433   "KRN",8994 ,3315,3,62 ,0)
  2434      1: "CON TRA"
  2435   "KRN",8994 ,3315,3,63 ,0)
  2436      2: #920 .4 variabl e pointer:  IEN;PXV(9 20.4,
  2437   "KRN",8994 ,3315,3,64 ,0)
  2438      3: Name  (#920.4,  #.01)
  2439   "KRN",8994 ,3315,3,65 ,0)
  2440      4: Stat us (1:Acti ve, 0:Inac tive)
  2441   "KRN",8994 ,3315,3,66 ,0)
  2442      5: Code |Coding Sy stem (#920 .4, #.02 a nd .05)
  2443   "KRN",8994 ,3315,3,67 ,0)
  2444      6: NIP0 04 (#920.4 , #.04)
  2445   "KRN",8994 ,3315,3,68 ,0)
  2446      7: Cont raindicati on/Precaut ion (#920. 4, #.06)
  2447   "KRN",8994 ,3315,3,69 ,0)
  2448   ^TMP("PXVI MMRPC",$J, x)
  2449   "KRN",8994 ,3315,3,70 ,0)
  2450      1: "DEF "
  2451   "KRN",8994 ,3315,3,71 ,0)
  2452      2: Defa ult Route  (#920.051,  #1302)
  2453   "KRN",8994 ,3315,3,72 ,0)
  2454      3: Defa ult Site ( #920.051,  #1303)
  2455   "KRN",8994 ,3315,3,73 ,0)
  2456      4: Defa ult Dose ( #920.051,  #1312)
  2457   "KRN",8994 ,3315,3,74 ,0)
  2458      5: Defa ult Dose U nits (#920 .051, #131 3)
  2459   "KRN",8994 ,3315,3,75 ,0)
  2460      6: Defa ult Dose U nits (exte rnal forma t) (#920.0 51, #1313)
  2461   "KRN",8994 ,3315,3,76 ,0)
  2462   ^TMP("PXVI MMRPC",$J, x)
  2463   "KRN",8994 ,3315,3,77 ,0)
  2464      1: "DEF C"
  2465   "KRN",8994 ,3315,3,78 ,0)
  2466      2: Defa ult Commen ts (#920.0 51, #81101 )
  2467   "KRN",8994 ,3316,-1)
  2468   0^13
  2469   "KRN",8994 ,3316,0)
  2470   PXVIMM ADM IN CODES^I MMADMCD^PX VRPC4^2
  2471   "KRN",8994 ,3316,1,0)
  2472   ^^1^1^3160 217^
  2473   "KRN",8994 ,3316,1,1, 0)
  2474   Returns im munization  administr ation CPT  codes.
  2475   "KRN",8994 ,3316,2,0)
  2476   ^8994.02A^ 1^1
  2477   "KRN",8994 ,3316,2,1, 0)
  2478   PXDATE^1^^ 0^1
  2479   "KRN",8994 ,3316,2,1, 1,0)
  2480   ^^1^1^3160 217^
  2481   "KRN",8994 ,3316,2,1, 1,1,0)
  2482   Code statu s will be  based off  this date.  (Optional ; Defaults  to TODAY) .
  2483   "KRN",8994 ,3316,2,"B ","PXDATE" ,1)
  2484  
  2485   "KRN",8994 ,3316,2,"P ARAMSEQ",1 ,1)
  2486  
  2487   "KRN",8994 ,3316,3,0)
  2488   ^^7^7^3160 217^
  2489   "KRN",8994 ,3316,3,1, 0)
  2490   PXRSLT(0)  = Count of  elements  returned ( 0 if nothi ng found)
  2491   "KRN",8994 ,3316,3,2, 0)
  2492   PXRSLT(n)  =
  2493   "KRN",8994 ,3316,3,3, 0)
  2494      Note: O nly active  codes (ba sed off PX DATE) are  returned.
  2495   "KRN",8994 ,3316,3,4, 0)
  2496      1: "CPT -ADM" or " CPT-ADD"
  2497   "KRN",8994 ,3316,3,5, 0)
  2498      2: Code
  2499   "KRN",8994 ,3316,3,6, 0)
  2500      3: Vari able point er. e.g.,  IEN;ICPT(
  2501   "KRN",8994 ,3316,3,7, 0)
  2502      4: Shor t Descript ion
  2503   "KRN",8994 ,3317,-1)
  2504   0^14
  2505   "KRN",8994 ,3317,0)
  2506   PXVIMM IMM  FORMAT^GE TTEXT^PXVR PC6^2
  2507   "KRN",8994 ,3317,1,0)
  2508   ^8994.01^2 ^2^3160408 ^^^
  2509   "KRN",8994 ,3317,1,1, 0)
  2510   This RPC t akes an in put array  of immuniz ation prop erties set  from the  GUI.
  2511   "KRN",8994 ,3317,1,2, 0)
  2512   It returns  a formatt ed text of  an immuni zation for  use in do cumentatio n.
  2513   "KRN",8994 ,3317,2,0)
  2514   ^8994.02A^ 1^1
  2515   "KRN",8994 ,3317,2,1, 0)
  2516   INPUT^2^^1 ^1
  2517   "KRN",8994 ,3317,2,1, 1,0)
  2518   ^8994.021^ 12^12^3160 408^^
  2519   "KRN",8994 ,3317,2,1, 1,1,0)
  2520   INPUT(n)=I MM ^ Imm I EN ^  ^ Da te Adminis tered (for  immunizat ions) / Da te
  2521   "KRN",8994 ,3317,2,1, 1,2,0)
  2522            C ontra-Refu sal Event  Documented  (for cont ra/refusal s) ^ Warn
  2523   "KRN",8994 ,3317,2,1, 1,3,0)
  2524            U ntil Date  (for contr a/refusals ) ^ Series  ^ Refusal  reason ^
  2525   "KRN",8994 ,3317,2,1, 1,4,0)
  2526            C ontraindic ation Reas on ^ Order ed By ^ Ad ministered  By (for V A
  2527   "KRN",8994 ,3317,2,1, 1,5,0)
  2528            a dministere d) / Docum ented By ( for histor ical) ^ Do cument Typ e
  2529   "KRN",8994 ,3317,2,1, 1,6,0)
  2530            ( "Historica l"/"Admini stered") ^  Informati on Source
  2531   "KRN",8994 ,3317,2,1, 1,7,0)
  2532        (n)=L OC ^ File  #44 IEN ^   ^  ^ Outs ide Locati on (for hi storicals)
  2533   "KRN",8994 ,3317,2,1, 1,8,0)
  2534        (n)=R OUTE ^ Rou te ^ Site  ^ Dosage
  2535   "KRN",8994 ,3317,2,1, 1,9,0)
  2536        (n)=V IS ^ VIS N ame ^ Edit ion Date ^  Language
  2537   "KRN",8994 ,3317,2,1, 1,10,0)
  2538        (n)=L OT ^ Lot #  ^ Manufac turer ^ Ex p Date
  2539   "KRN",8994 ,3317,2,1, 1,11,0)
  2540        (n)=C OM ^ Comme nt
  2541   "KRN",8994 ,3317,2,1, 1,12,0)
  2542        (n)=O VER ^ Over ride Reaso n
  2543   "KRN",8994 ,3317,2,"B ","INPUT", 1)
  2544  
  2545   "KRN",8994 ,3317,2,"P ARAMSEQ",1 ,1)
  2546  
  2547   "KRN",8994 ,3317,3,0)
  2548   ^8994.03^1 ^1^3160408 ^^^
  2549   "KRN",8994 ,3317,3,1, 0)
  2550   Formatted  text of an  immunizat ion for us e in docum entation.
  2551   "MBREQ")
  2552   0
  2553   "ORD",15,1 01)
  2554   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  2555   "ORD",15,1 01,0)
  2556   PROTOCOL
  2557   "ORD",16,8 994)
  2558   8994;16;1; ;;;;;;RPCD EL^XPDIA1
  2559   "ORD",16,8 994,0)
  2560   REMOTE PRO CEDURE
  2561   "ORD",18,1 9)
  2562   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  2563   "ORD",18,1 9,0)
  2564   OPTION
  2565   "PKG",507, -1)
  2566   1^1
  2567   "PKG",507, 0)
  2568   PCE PATIEN T CARE ENC OUNTER^PX^ Patient Ca re Encount er
  2569   "PKG",507, 20,0)
  2570   ^9.402P^^
  2571   "PKG",507, 22,0)
  2572   ^9.49I^1^1
  2573   "PKG",507, 22,1,0)
  2574   1.0^296081 2^2960912^ 10958
  2575   "PKG",507, 22,1,"PAH" ,1,0)
  2576   215^316042 8
  2577   "PKG",507, 22,1,"PAH" ,1,1,0)
  2578   ^^5^5^3160 428
  2579   "PKG",507, 22,1,"PAH" ,1,1,1,0)
  2580   The Vetera ns Health  Informatio n Systems  and Techno logy Archi tecture
  2581   "PKG",507, 22,1,"PAH" ,1,1,2,0)
  2582   (VistA) Im munization s Enhancem ents (VIMM ) 2.0 proj ect, Incre ment 3, bu ilds
  2583   "PKG",507, 22,1,"PAH" ,1,1,3,0)
  2584   upon the f ile struct ures and s tandardize d data int roduced in  Increment s 1
  2585   "PKG",507, 22,1,"PAH" ,1,1,4,0)
  2586   and 2 by a dding func tional enh ancements  to the exi sting Vist A Patient  Care
  2587   "PKG",507, 22,1,"PAH" ,1,1,5,0)
  2588   Encounter  (PCE) pack age.
  2589   "QUES","XP F1",0)
  2590   Y
  2591   "QUES","XP F1","??")
  2592   ^D REP^XPD H
  2593   "QUES","XP F1","A")
  2594   Shall I wr ite over y our |FLAG|  File
  2595   "QUES","XP F1","B")
  2596   YES
  2597   "QUES","XP F1","M")
  2598   D XPF1^XPD IQ
  2599   "QUES","XP F2",0)
  2600   Y
  2601   "QUES","XP F2","??")
  2602   ^D DTA^XPD H
  2603   "QUES","XP F2","A")
  2604   Want my da ta |FLAG|  yours
  2605   "QUES","XP F2","B")
  2606   YES
  2607   "QUES","XP F2","M")
  2608   D XPF2^XPD IQ
  2609   "QUES","XP I1",0)
  2610   YO
  2611   "QUES","XP I1","??")
  2612   ^D INHIBIT ^XPDH
  2613   "QUES","XP I1","A")
  2614   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  2615   "QUES","XP I1","B")
  2616   NO
  2617   "QUES","XP I1","M")
  2618   D XPI1^XPD IQ
  2619   "QUES","XP M1",0)
  2620   PO^VA(200, :EM
  2621   "QUES","XP M1","??")
  2622   ^D MG^XPDH
  2623   "QUES","XP M1","A")
  2624   Enter the  Coordinato r for Mail  Group '|F LAG|'
  2625   "QUES","XP M1","B")
  2626  
  2627   "QUES","XP M1","M")
  2628   D XPM1^XPD IQ
  2629   "QUES","XP O1",0)
  2630   Y
  2631   "QUES","XP O1","??")
  2632   ^D MENU^XP DH
  2633   "QUES","XP O1","A")
  2634   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  2635   "QUES","XP O1","B")
  2636   YES
  2637   "QUES","XP O1","M")
  2638   D XPO1^XPD IQ
  2639   "QUES","XP Z1",0)
  2640   Y
  2641   "QUES","XP Z1","??")
  2642   ^D OPT^XPD H
  2643   "QUES","XP Z1","A")
  2644   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  2645   "QUES","XP Z1","B")
  2646   NO
  2647   "QUES","XP Z1","M")
  2648   D XPZ1^XPD IQ
  2649   "QUES","XP Z2",0)
  2650   Y
  2651   "QUES","XP Z2","??")
  2652   ^D RTN^XPD H
  2653   "QUES","XP Z2","A")
  2654   Want to MO VE routine s to other  CPUs
  2655   "QUES","XP Z2","B")
  2656   NO
  2657   "QUES","XP Z2","M")
  2658   D XPZ2^XPD IQ
  2659   "RTN")
  2660   33
  2661   "RTN","PXA I")
  2662   0^1^B42819 168^B40979 532
  2663   "RTN","PXA I",1,0)
  2664   PXAI ;ISL/ JVS,ISA/KW P,ESW - PC E DRIVING  RTN FOR 'D ATA2PCE' A PI ;11/12/ 15  09:21
  2665   "RTN","PXA I",2,0)
  2666    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**15,7 4,69,102,1 11,112,130 ,164,168,2 15**;Aug 1 2, 1996;Bu ild 10
  2667   "RTN","PXA I",3,0)
  2668    Q
  2669   "RTN","PXA I",4,0)
  2670    ;
  2671   "RTN","PXA I",5,0)
  2672    ;+  1        2        3         4        5        6       7       8       9
  2673   "RTN","PXA I",6,0)
  2674   DATA2PCE(P XADATA,PXA PKG,PXASOU RC,PXAVISI T,PXAUSER, PXANOT,ERR RET,PXAPRE DT,PXAPROB ,PXACCNT)  ;+API to p ass data f or add/edi t/delete t o PCE.
  2675   "RTN","PXA I",7,0)
  2676    ;+  PXADA TA  (requi red)
  2677   "RTN","PXA I",8,0)
  2678    ;+  PXAPK G   (requi red)
  2679   "RTN","PXA I",9,0)
  2680    ;+  PXASO URC (requi red)
  2681   "RTN","PXA I",10,0)
  2682    ;+  PXAVI SIT (optio nal) is po inter to a  visit for  which the  data is t o
  2683   "RTN","PXA I",11,0)
  2684    ;+         be relate d.  If the  visit is  not known  then there  must be
  2685   "RTN","PXA I",12,0)
  2686    ;+         the ENCOU NTER nodes  needed to  lookup/cr eate the v isit.
  2687   "RTN","PXA I",13,0)
  2688    ;+  PXAUS ER  (optio nal) this  is a point er to the  user addin g the data .
  2689   "RTN","PXA I",14,0)
  2690    ;+  PXANO T   (optio nal) set t o 1 if err ors are to  be displa yed to the  screen sh ould only  be set whi le writing  and debug ging the i nitial cod e.
  2691   "RTN","PXA I",15,0)
  2692    ;+  ERRRE T   (optio nal) passe d by refer ence.  If  present wi ll return  PXKERROR
  2693   "RTN","PXA I",16,0)
  2694    ;+                        array  elements  to the cal ler.
  2695   "RTN","PXA I",17,0)
  2696    ;+  PXAPR EDT  (opti onal) Set  to 1 if yo u want to  edit the P rimary Pro vider
  2697   "RTN","PXA I",18,0)
  2698    ;+             only  use if for  the momen t that edi ting is be ing done.  (dangerous )
  2699   "RTN","PXA I",19,0)
  2700    ;+  PXAPR OB   (opti onal) A do tted varia ble name.  When error s and
  2701   "RTN","PXA I",20,0)
  2702    ;+              warn ings occur , They wil l be passe d back in  the form
  2703   "RTN","PXA I",21,0)
  2704    ;+             of an  array wit h the gene ral descri ption of t he problem .
  2705   "RTN","PXA I",22,0)
  2706    ;+ IF ERR OR1 - (GEN ERAL ERROR S)
  2707   "RTN","PXA I",23,0)
  2708    ;+      P XAPROB($J, SUBSCRIPT, "ERROR1",P ASSED IN ' FILE',PASS ED IN FIEL D,
  2709   "RTN","PXA I",24,0)
  2710    ;+               SUB SCRIPT FRO M PXADATA)
  2711   "RTN","PXA I",25,0)
  2712    ;+      P XAPROB(234 32234,2,"E RROR1","PR OVIDER","N AME",7)="B ECAUSE..."
  2713   "RTN","PXA I",26,0)
  2714    ;+ IF WAR NING2 - (G ENERAL WAR NINGS)
  2715   "RTN","PXA I",27,0)
  2716    ;+      P XAPROB($J, SUBSCRIPT, "WARNING2" ,PASSED IN  'FILE',PA SSED IN FI ELD,
  2717   "RTN","PXA I",28,0)
  2718    ;+               SUB SCRIPT FRO M PXADATA)
  2719   "RTN","PXA I",29,0)
  2720    ;+      P XAPROB(234 32234,3,"W ARNING2"," PROCEDURE" ,"QTY",3)= "BECAUSE.. ."
  2721   "RTN","PXA I",30,0)
  2722    ;+ IF WAR NING3 - (W ARNINGS FO R SERVICE  CONNECTION )
  2723   "RTN","PXA I",31,0)
  2724    ;+      P XAPROB($J, 1,"WARNING 3","ENCOUN TER",1,"AO ")=REASON
  2725   "RTN","PXA I",32,0)
  2726    ;+      P XAPROB($J, 1,"WARNING 3","ENCOUN TER",1,"EC ")=REASON
  2727   "RTN","PXA I",33,0)
  2728    ;+      P XAPROB($J, 1,"WARNING 3","ENCOUN TER",1,"IR ")=REASON
  2729   "RTN","PXA I",34,0)
  2730    ;+      P XAPROB($J, 1,"WARNING 3","ENCOUN TER",1,"SC ")=REASON
  2731   "RTN","PXA I",35,0)
  2732    ;+      P XAPROB($J, 1,"WARNING 3","ENCOUN TER",1,"MS T")=REASON
  2733   "RTN","PXA I",36,0)
  2734    ;+      P XAPROB($J, 1,"WARNING 3","ENCOUN TER",1,"HN C")=REASON
  2735   "RTN","PXA I",37,0)
  2736    ;+      P XAPROB($J, 1,"WARNING 3","ENCOUN TER",1,"CV ")=REASON
  2737   "RTN","PXA I",38,0)
  2738    ;+      P XAPROB($J, 1,"WARNING 3","ENCOUN TER",1,"SH AD")=REASO N
  2739   "RTN","PXA I",39,0)
  2740    ;+ IF ERR OR4 - (PRO BLEM LIST  ERRORS)
  2741   "RTN","PXA I",40,0)
  2742    ;+      P XAPROB($J, 6,"ERROR4" ,"PX/DL",( SUBSCRIPT  FROM PXADA TA))=REASO N
  2743   "RTN","PXA I",41,0)
  2744    ;+ PXACCN T    (opti onal)  pas sed by ref erence.  R eturns the  PFSS Acco unt Refere nce if kno wn.
  2745   "RTN","PXA I",42,0)
  2746    ;               Retu rned as nu ll if the  PFSS Accou nt Referen ce is loca ted in the  Order fil e(#100)
  2747   "RTN","PXA I",43,0)
  2748    ;+
  2749   "RTN","PXA I",44,0)
  2750    ;+
  2751   "RTN","PXA I",45,0)
  2752    ;+ Return s:
  2753   "RTN","PXA I",46,0)
  2754    ;+   1  i f no error s and proc ess comple tely
  2755   "RTN","PXA I",47,0)
  2756    ;+  -1  i f errors o ccurred bu t processe d complete ly as poss ible
  2757   "RTN","PXA I",48,0)
  2758    ;+  -2  i f could no t get a vi sit
  2759   "RTN","PXA I",49,0)
  2760    ;+  -3  i f called i ncorrectly
  2761   "RTN","PXA I",50,0)
  2762    ;
  2763   "RTN","PXA I",51,0)
  2764   NEW ;--NEW  VARIABLES
  2765   "RTN","PXA I",52,0)
  2766    N NOVSIT, PXAK,DFN,P XAERRF,PXA DEC,PXELAP ,PXASUB
  2767   "RTN","PXA I",53,0)
  2768    N PATIENT ,VALQUIET, PRIMFND
  2769   "RTN","PXA I",54,0)
  2770    K PXAERRO R,PXKERROR ,PXAERR,PR VDR
  2771   "RTN","PXA I",55,0)
  2772    S PXASUB= 0,VALQUIET =1
  2773   "RTN","PXA I",56,0)
  2774    ; needs t o look up  if not pas sed.
  2775   "RTN","PXA I",57,0)
  2776    I '$G(PXA VISIT),'$D (@PXADATA@ ("ENCOUNTE R")) Q -3
  2777   "RTN","PXA I",58,0)
  2778    I $G(PXAU SER)<1 S P XAUSER=DUZ
  2779   "RTN","PXA I",59,0)
  2780    ;
  2781   "RTN","PXA I",60,0)
  2782    K ^TMP("P XK",$J),^T MP("DIERR" ,$J),^TMP( "PXAIADDPR V",$J)
  2783   "RTN","PXA I",61,0)
  2784   SOR ;--SOU RCE
  2785   "RTN","PXA I",62,0)
  2786    I PXAPKG= +PXAPKG S  PXAPKG=PXA PKG
  2787   "RTN","PXA I",63,0)
  2788    E  S PXAP KG=$$PKG2I EN^VSIT(PX APKG)
  2789   "RTN","PXA I",64,0)
  2790    I PXASOUR C=+PXASOUR C S PXASOU RC=PXASOUR C
  2791   "RTN","PXA I",65,0)
  2792    E  S PXAS OURC=$$SOU RCE^PXAPIU TL(PXASOUR C)
  2793   "RTN","PXA I",66,0)
  2794    ;
  2795   "RTN","PXA I",67,0)
  2796    D TMPSOUR C^PXAPIUTL (PXASOURC)  ;-SAVES &  CREATES ^ TMP("PXK", $J,"SOR")
  2797   "RTN","PXA I",68,0)
  2798   VST ;--VIS IT
  2799   "RTN","PXA I",69,0)
  2800    ;--KILL V ISIT
  2801   "RTN","PXA I",70,0)
  2802    I $G(PXAV ISIT) D VP TR^PXAIVST V I $G(PXA ERRF) D ER R Q -2
  2803   "RTN","PXA I",71,0)
  2804    D VST^PXA IVST
  2805   "RTN","PXA I",72,0)
  2806    I $G(PXAV ISIT)<0 Q  -2
  2807   "RTN","PXA I",73,0)
  2808    I $G(PXAE RRF) D ERR  K PXAERR  Q -2
  2809   "RTN","PXA I",74,0)
  2810   PRV ;--PRO VIDER
  2811   "RTN","PXA I",75,0)
  2812    S PATIENT =$P($G(^AU PNVSIT(PXA VISIT,0)), "^",5)
  2813   "RTN","PXA I",76,0)
  2814    S (PXAK,P RIMFND)=0
  2815   "RTN","PXA I",77,0)
  2816    F  S PXAK =$O(@PXADA TA@("PROVI DER",PXAK) ) Q:(PRIMF ND)!(PXAK= "")  D
  2817   "RTN","PXA I",78,0)
  2818    .I $D(@PX ADATA@("PR OVIDER",PX AK,"PRIMAR Y")) D
  2819   "RTN","PXA I",79,0)
  2820    ..S PRIMF ND=$G(@PXA DATA@("PRO VIDER",PXA K,"PRIMARY "))
  2821   "RTN","PXA I",80,0)
  2822    I 'PRIMFN D D  ;Chec k for each  provider' s status a s Primary  or Seconda ry
  2823   "RTN","PXA I",81,0)
  2824    .S PXAK=0  F  S PXAK =$O(@PXADA TA@("PROVI DER",PXAK) ) Q:PXAK=" "  D
  2825   "RTN","PXA I",82,0)
  2826    ..I '$D(@ PXADATA@(" PROVIDER", PXAK,"PRIM ARY")) D P ROVDRST
  2827   "RTN","PXA I",83,0)
  2828    S PXAK=0  F  S PXAK= $O(@PXADAT A@("PROVID ER",PXAK))  Q:PXAK=""   D
  2829   "RTN","PXA I",84,0)
  2830    . D PRV^P XAIPRV I $ G(PXAERRF)  D ERR
  2831   "RTN","PXA I",85,0)
  2832    K PRI ;-- FLAG FOR P RIMARY PRO VIDER
  2833   "RTN","PXA I",86,0)
  2834    K PXAERR
  2835   "RTN","PXA I",87,0)
  2836   POV ;--DIA GNOSIS
  2837   "RTN","PXA I",88,0)
  2838    S (PXAK,P RIMFND)=0
  2839   "RTN","PXA I",89,0)
  2840    F  S PXAK =$O(@PXADA TA@("DX/PL ",PXAK)) Q :(PXAK="")   D  Q:PRI MFND
  2841   "RTN","PXA I",90,0)
  2842    .I +$G(@P XADATA@("D X/PL",PXAK ,"PRIMARY" ))=1 D
  2843   "RTN","PXA I",91,0)
  2844    ..S PRIMF ND=$G(@PXA DATA@("DX/ PL",PXAK," DIAGNOSIS" ))
  2845   "RTN","PXA I",92,0)
  2846    I $D(@PXA DATA@("DX/ PL")) D PO VPRM(PXAVI SIT,PRIMFN D,.PXADATA ) D
  2847   "RTN","PXA I",93,0)
  2848    .S PXAK=0  F  S PXAK =$O(@PXADA TA@("DX/PL ",PXAK))   Q:PXAK=""   D
  2849   "RTN","PXA I",94,0)
  2850    ..D POV^P XAIPOV I $ G(PXAERRF)  D ERR
  2851   "RTN","PXA I",95,0)
  2852    K PXAERR
  2853   "RTN","PXA I",96,0)
  2854    ;
  2855   "RTN","PXA I",97,0)
  2856   CPT ;--PRO CEDURE
  2857   "RTN","PXA I",98,0)
  2858    S PXAK=0  F  S PXAK= $O(@PXADAT A@("PROCED URE",PXAK) )  Q:PXAK= ""  D
  2859   "RTN","PXA I",99,0)
  2860    . D CPT^P XAICPT I $ G(PXAERRF)  D ERR
  2861   "RTN","PXA I",100,0)
  2862    K PXAERR
  2863   "RTN","PXA I",101,0)
  2864    ;
  2865   "RTN","PXA I",102,0)
  2866   EDU ;--PAT IENT EDUCA TION
  2867   "RTN","PXA I",103,0)
  2868    S PXAK=0  F  S PXAK= $O(@PXADAT A@("PATIEN T ED",PXAK ))  Q:PXAK =""  D
  2869   "RTN","PXA I",104,0)
  2870    . D EDU^P XAIPED I $ G(PXAERRF)  D ERR
  2871   "RTN","PXA I",105,0)
  2872    K PXAERR
  2873   "RTN","PXA I",106,0)
  2874    ;
  2875   "RTN","PXA I",107,0)
  2876   EXAM ;--EX AMINATION
  2877   "RTN","PXA I",108,0)
  2878    S PXAK=0  F  S PXAK= $O(@PXADAT A@("EXAM", PXAK))  Q: PXAK=""  D
  2879   "RTN","PXA I",109,0)
  2880    . D EXAM^ PXAIXAM I  $G(PXAERRF ) D ERR
  2881   "RTN","PXA I",110,0)
  2882    K PXAERR
  2883   "RTN","PXA I",111,0)
  2884    ;
  2885   "RTN","PXA I",112,0)
  2886   HF ;--HEAL TH FACTOR
  2887   "RTN","PXA I",113,0)
  2888    S PXAK=0  F  S PXAK= $O(@PXADAT A@("HEALTH  FACTOR",P XAK))  Q:P XAK=""  D
  2889   "RTN","PXA I",114,0)
  2890    . D HF^PX AIHF I $G( PXAERRF) D  ERR
  2891   "RTN","PXA I",115,0)
  2892    K PXAERR
  2893   "RTN","PXA I",116,0)
  2894    ;
  2895   "RTN","PXA I",117,0)
  2896   IMM ;--IMM UNIZATION
  2897   "RTN","PXA I",118,0)
  2898    S PXAK=0  F  S PXAK= $O(@PXADAT A@("IMMUNI ZATION",PX AK))  Q:PX AK=""  D
  2899   "RTN","PXA I",119,0)
  2900    . D IMM^P XAIIMM I $ G(PXAERRF)  D ERR
  2901   "RTN","PXA I",120,0)
  2902    K PXAERR
  2903   "RTN","PXA I",121,0)
  2904    ;
  2905   "RTN","PXA I",122,0)
  2906   SKIN ;--SK IN TEST
  2907   "RTN","PXA I",123,0)
  2908    S PXAK=0  F  S PXAK= $O(@PXADAT A@("SKIN T EST",PXAK) )  Q:PXAK= ""  D
  2909   "RTN","PXA I",124,0)
  2910    . D SKIN^ PXAISK I $ G(PXAERRF)  D ERR
  2911   "RTN","PXA I",125,0)
  2912    K PXAERR
  2913   "RTN","PXA I",126,0)
  2914    ;
  2915   "RTN","PXA I",127,0)
  2916   ICR ;--IMM  CONTRAIND ICATION/RE FUSAL
  2917   "RTN","PXA I",128,0)
  2918    S PXAK=0  F  S PXAK= $O(@PXADAT A@("IMM CO NTRA/REFUS AL",PXAK))   Q:PXAK=" "  D
  2919   "RTN","PXA I",129,0)
  2920    . D ICR^P XAIICR I $ G(PXAERRF)  D ERR
  2921   "RTN","PXA I",130,0)
  2922    K PXAERR
  2923   "RTN","PXA I",131,0)
  2924    ;
  2925   "RTN","PXA I",132,0)
  2926    ;
  2927   "RTN","PXA I",133,0)
  2928    D OTHER^P XAIPRV
  2929   "RTN","PXA I",134,0)
  2930    ;
  2931   "RTN","PXA I",135,0)
  2932    ;
  2933   "RTN","PXA I",136,0)
  2934    I $D(^TMP ("PXK",$J) ) D
  2935   "RTN","PXA I",137,0)
  2936    . D EN1^P XKMAIN
  2937   "RTN","PXA I",138,0)
  2938    . M ERRRE T=PXKERROR
  2939   "RTN","PXA I",139,0)
  2940    . D PRIM^ PXAIPRV K  PRVDR
  2941   "RTN","PXA I",140,0)
  2942    . D EVENT ^PXKMAIN
  2943   "RTN","PXA I",141,0)
  2944    S PXACCNT =$P($G(^AU PNVSIT(PXA VISIT,0)), "^",26) ;P X*1.0*164  ;Sets the  PFSS Accou nt Referen ce, if any
  2945   "RTN","PXA I",142,0)
  2946    K ^TMP("P XK",$J),PX AERR,PXKER ROR
  2947   "RTN","PXA I",143,0)
  2948    Q $S($G(P XAERRF):-1 ,1:1)
  2949   "RTN","PXA I",144,0)
  2950    ;
  2951   "RTN","PXA I",145,0)
  2952    ;
  2953   "RTN","PXA I",146,0)
  2954   EXIT ;--EX IT AND CLE AN UP
  2955   "RTN","PXA I",147,0)
  2956    D EVENT^P XKMAIN
  2957   "RTN","PXA I",148,0)
  2958    K ^TMP("P XK",$J),PR VDR
  2959   "RTN","PXA I",149,0)
  2960    K PXAERR
  2961   "RTN","PXA I",150,0)
  2962    Q
  2963   "RTN","PXA I",151,0)
  2964    ;-------- ---------S UBROUTINES ---------- ---------- ---
  2965   "RTN","PXA I",152,0)
  2966   ERR ;
  2967   "RTN","PXA I",153,0)
  2968    ;
  2969   "RTN","PXA I",154,0)
  2970    ;
  2971   "RTN","PXA I",155,0)
  2972    I '$D(PXA DI("DIALOG ")) Q
  2973   "RTN","PXA I",156,0)
  2974    N NODE,SC REEN
  2975   "RTN","PXA I",157,0)
  2976    S PXAERR( 1)=$G(PXAD ATA),PXAER R(2)=$G(PX APKG),PXAE RR(3)=$G(P XASOURC)
  2977   "RTN","PXA I",158,0)
  2978    S PXAERR( 4)=$G(PXAV ISIT),PXAE RR(5)=$G(P XAUSER)_"   "_$P($G(^ VA(200,PXA USER,0))," ^",1)
  2979   "RTN","PXA I",159,0)
  2980    I $G(PXAN OT)=1 D EX TERNAL
  2981   "RTN","PXA I",160,0)
  2982    E  D INTE RNAL
  2983   "RTN","PXA I",161,0)
  2984    D ARRAY^P XAICPTV
  2985   "RTN","PXA I",162,0)
  2986    K PXADI(" DIALOG")
  2987   "RTN","PXA I",163,0)
  2988    Q
  2989   "RTN","PXA I",164,0)
  2990    ;
  2991   "RTN","PXA I",165,0)
  2992   EXTERNAL ; ---SEND ER RORS TO SC REEN
  2993   "RTN","PXA I",166,0)
  2994    W !,"---- ---------- ---------- ---------- ---------- ---------- ---------- -"
  2995   "RTN","PXA I",167,0)
  2996    D BLD^DIA LOG($G(PXA DI("DIALOG ")),.PXAER R,"","SCRE EN","F")
  2997   "RTN","PXA I",168,0)
  2998    D MSG^DIA LOG("ESW", "",50,10," SCREEN")
  2999   "RTN","PXA I",169,0)
  3000    ;
  3001   "RTN","PXA I",170,0)
  3002    Q
  3003   "RTN","PXA I",171,0)
  3004   INTERNAL ; ---SET ERR ORS TO GLO BAL ARRAY
  3005   "RTN","PXA I",172,0)
  3006    S NODE=PX ADATA
  3007   "RTN","PXA I",173,0)
  3008    D BLD^DIA LOG($G(PXA DI("DIALOG ")),.PXAER R,.PXAERR, NODE,"F")
  3009   "RTN","PXA I",174,0)
  3010    S NODE=$N A(@PXADATA @("DIERR", $J)) D MSG ^DIALOG("E SW","",50, 10,NODE)
  3011   "RTN","PXA I",175,0)
  3012    Q
  3013   "RTN","PXA I",176,0)
  3014    ;
  3015   "RTN","PXA I",177,0)
  3016   PROVDRST ;  Check pro vider stat us (Primar y or Secon dary)
  3017   "RTN","PXA I",178,0)
  3018    N PRVIEN, DETS,DIC,D R,DA,DIQ,P RI,PRVPRIM
  3019   "RTN","PXA I",179,0)
  3020    I $G(PXAK )="" QUIT
  3021   "RTN","PXA I",180,0)
  3022    S PRVIEN= 0
  3023   "RTN","PXA I",181,0)
  3024    F  S PRVI EN=$O(^AUP NVPRV("AD" ,PXAVISIT, PRVIEN)) Q :PRVIEN=""   D
  3025   "RTN","PXA I",182,0)
  3026    .S DETS=$ G(^AUPNVPR V(PRVIEN,0 ))
  3027   "RTN","PXA I",183,0)
  3028    .I $P(DET S,U)=$G(@P XADATA@("P ROVIDER",P XAK,"NAME" )) D
  3029   "RTN","PXA I",184,0)
  3030    ..S DIC=9 000010.06, DR=.04,DA= PRVIEN
  3031   "RTN","PXA I",185,0)
  3032    ..S DIQ=" PRVPRIM(", DIQ(0)="EI " D EN^DIQ 1
  3033   "RTN","PXA I",186,0)
  3034    ..S PRI=$ E($G(PRVPR IM(9000010 .06,DA,DR, "E")),1,1)
  3035   "RTN","PXA I",187,0)
  3036    ..S @PXAD ATA@("PROV IDER",PXAK ,"PRIMARY" )=$S(PRI=" P":1,1:0)
  3037   "RTN","PXA I",188,0)
  3038    Q
  3039   "RTN","PXA I",189,0)
  3040   POVPRM(VIS IT,PRIMFND ,POVARR) ;
  3041   "RTN","PXA I",190,0)
  3042    N PRVIEN, DETS,STOP, LPXAK,ORDX ,NDX,ORDXP
  3043   "RTN","PXA I",191,0)
  3044    S PRVIEN= 0
  3045   "RTN","PXA I",192,0)
  3046    ;create a rray of ex isting DX;  ORDX - po inter to ^ ICD9(
  3047   "RTN","PXA I",193,0)
  3048    F  S PRVI EN=$O(^AUP NVPOV("AD" ,PXAVISIT, PRVIEN)) Q :PRVIEN=""   D
  3049   "RTN","PXA I",194,0)
  3050    .S DETS=$ G(^AUPNVPO V(PRVIEN,0 )),ORDX=$P (DETS,U)
  3051   "RTN","PXA I",195,0)
  3052    .S ORDX(O RDX)=PRVIE N I $P(DET S,U,12)="P " S ORDXP( ORDX)=""
  3053   "RTN","PXA I",196,0)
  3054    ; create  array of p assed DX;  NDX - poin ter to ^IC D9(
  3055   "RTN","PXA I",197,0)
  3056    S PXAK=0  F  S PXAK= $O(@POVARR @("DX/PL", PXAK)) Q:P XAK=""  D
  3057   "RTN","PXA I",198,0)
  3058    .S NDX=$G (@POVARR@( "DX/PL",PX AK,"DIAGNO SIS")) S N DX(NDX)=PX AK
  3059   "RTN","PXA I",199,0)
  3060    ; force e ntry of or iginally p rimary dia gnosis wit h "S" flag
  3061   "RTN","PXA I",200,0)
  3062    I PRIMFND  S ORDX=""  D
  3063   "RTN","PXA I",201,0)
  3064    .F  S ORD X=$O(ORDXP (ORDX)) Q: ORDX=""  I  PRIMFND'= ORDX D
  3065   "RTN","PXA I",202,0)
  3066    ..I $D(ND X(ORDX)) S  @POVARR@( "DX/PL",ND X(ORDX),"P RIMARY")=0
  3067   "RTN","PXA I",203,0)
  3068    ..E  D
  3069   "RTN","PXA I",204,0)
  3070    ...S LPXA K=$O(@POVA RR@("DX/PL ",""),-1)
  3071   "RTN","PXA I",205,0)
  3072    ...S @POV ARR@("DX/P L",LPXAK+1 ,"DIAGNOSI S")=ORDX
  3073   "RTN","PXA I",206,0)
  3074    ...S @POV ARR@("DX/P L",LPXAK+1 ,"PRIMARY" )=0
  3075   "RTN","PXA I",207,0)
  3076    Q
  3077   "RTN","PXA I",208,0)
  3078    ;
  3079   "RTN","PXA IICR")
  3080   0^8^B52535 75^n/a
  3081   "RTN","PXA IICR",1,0)
  3082   PXAIICR ;B PFO/LMT -  Set the IM M CONTRA/R EFUSAL nod es ;11/18/ 15  11:34
  3083   "RTN","PXA IICR",2,0)
  3084    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  3085   "RTN","PXA IICR",3,0)
  3086    ;
  3087   "RTN","PXA IICR",4,0)
  3088   ICR ;Main  entry poin t.
  3089   "RTN","PXA IICR",5,0)
  3090    ;
  3091   "RTN","PXA IICR",6,0)
  3092    K PXAERR
  3093   "RTN","PXA IICR",7,0)
  3094    S PXAERR( 8)=PXAK
  3095   "RTN","PXA IICR",8,0)
  3096    S PXAERR( 7)="IMM CO NTRA/REFUS AL"
  3097   "RTN","PXA IICR",9,0)
  3098    ;
  3099   "RTN","PXA IICR",10,0 )
  3100    N IND,PXA A
  3101   "RTN","PXA IICR",11,0 )
  3102    S IND=""
  3103   "RTN","PXA IICR",12,0 )
  3104    F  S IND= $O(@PXADAT A@("IMM CO NTRA/REFUS AL",PXAK,I ND)) Q:IND =""  D
  3105   "RTN","PXA IICR",13,0 )
  3106    . S PXAA( IND)=@PXAD ATA@("IMM  CONTRA/REF USAL",PXAK ,IND)
  3107   "RTN","PXA IICR",14,0 )
  3108    ;
  3109   "RTN","PXA IICR",15,0 )
  3110    ;Validate  the data.
  3111   "RTN","PXA IICR",16,0 )
  3112    N STOP
  3113   "RTN","PXA IICR",17,0 )
  3114    D VAL^PXA IICRV
  3115   "RTN","PXA IICR",18,0 )
  3116    I $G(STOP ) Q
  3117   "RTN","PXA IICR",19,0 )
  3118    ;
  3119   "RTN","PXA IICR",20,0 )
  3120   SETVARA ;S et the aft er visit v ariables.
  3121   "RTN","PXA IICR",21,0 )
  3122    N AFTER0, AFTER12,AF TER811,AFT ER812
  3123   "RTN","PXA IICR",22,0 )
  3124    ;
  3125   "RTN","PXA IICR",23,0 )
  3126    S $P(AFTE R0,U,1)=$G (PXAA("CON TRA/REFUSA L"))
  3127   "RTN","PXA IICR",24,0 )
  3128    I $G(PXAA ("DELETE") ) S $P(AFT ER0,U,1)=" @"
  3129   "RTN","PXA IICR",25,0 )
  3130    S $P(AFTE R0,U,2)=$G (PATIENT)
  3131   "RTN","PXA IICR",26,0 )
  3132    S $P(AFTE R0,U,3)=$G (PXAVISIT)
  3133   "RTN","PXA IICR",27,0 )
  3134    S $P(AFTE R0,U,4)=$G (PXAA("IMM UN"))
  3135   "RTN","PXA IICR",28,0 )
  3136    S $P(AFTE R0,U,5)=$G (PXAA("WAR N UNTIL DA TE"))
  3137   "RTN","PXA IICR",29,0 )
  3138    S $P(AFTE R12,U,1)=$ G(PXAA("EV ENT D/T"))
  3139   "RTN","PXA IICR",30,0 )
  3140    S $P(AFTE R12,U,4)=$ G(PXAA("EN C PROVIDER "))
  3141   "RTN","PXA IICR",31,0 )
  3142    S $P(AFTE R811,U,1)= $G(PXAA("C OMMENT"))
  3143   "RTN","PXA IICR",32,0 )
  3144    ;
  3145   "RTN","PXA IICR",33,0 )
  3146    ;--PACKAG E AND SOUR CE
  3147   "RTN","PXA IICR",34,0 )
  3148    S $P(AFTE R812,"^",2 )=$G(PXAPK G)
  3149   "RTN","PXA IICR",35,0 )
  3150    S $P(AFTE R812,"^",3 )=$G(PXASO URC)
  3151   "RTN","PXA IICR",36,0 )
  3152    ;
  3153   "RTN","PXA IICR",37,0 )
  3154    S ^TMP("P XK",$J,"IC R",PXAK,0, "AFTER")=A FTER0
  3155   "RTN","PXA IICR",38,0 )
  3156    S ^TMP("P XK",$J,"IC R",PXAK,12 ,"AFTER")= AFTER12
  3157   "RTN","PXA IICR",39,0 )
  3158    S ^TMP("P XK",$J,"IC R",PXAK,81 1,"AFTER") =AFTER811
  3159   "RTN","PXA IICR",40,0 )
  3160    S ^TMP("P XK",$J,"IC R",PXAK,81 2,"AFTER") =AFTER812
  3161   "RTN","PXA IICR",41,0 )
  3162    ;
  3163   "RTN","PXA IICR",42,0 )
  3164   SETVARB ;S et the bef ore variab les.
  3165   "RTN","PXA IICR",43,0 )
  3166    N BEFOR0, BEFOR12,BE FOR811,BEF OR812,IENB
  3167   "RTN","PXA IICR",44,0 )
  3168    ;
  3169   "RTN","PXA IICR",45,0 )
  3170    S IENB=""
  3171   "RTN","PXA IICR",46,0 )
  3172    S IENB=$O (^AUPNVICR ("AC",+$G( PXAVISIT), +$G(PXAA(" IMMUN")),$ G(PXAA("CO NTRA/REFUS AL")),IENB ))
  3173   "RTN","PXA IICR",47,0 )
  3174    ;
  3175   "RTN","PXA IICR",48,0 )
  3176    I $G(IENB ) D
  3177   "RTN","PXA IICR",49,0 )
  3178    . S BEFOR 0=$G(^AUPN VICR(IENB, 0))
  3179   "RTN","PXA IICR",50,0 )
  3180    . S BEFOR 12=$G(^AUP NVICR(IENB ,12))
  3181   "RTN","PXA IICR",51,0 )
  3182    . S BEFOR 811=$G(^AU PNVICR(IEN B,811))
  3183   "RTN","PXA IICR",52,0 )
  3184    . S BEFOR 812=$G(^AU PNVICR(IEN B,812))
  3185   "RTN","PXA IICR",53,0 )
  3186    E  S (BEF OR0,BEFOR1 2,BEFOR811 ,BEFOR812) =""
  3187   "RTN","PXA IICR",54,0 )
  3188    ;
  3189   "RTN","PXA IICR",55,0 )
  3190    S ^TMP("P XK",$J,"IC R",PXAK,0, "BEFORE")= BEFOR0
  3191   "RTN","PXA IICR",56,0 )
  3192    S ^TMP("P XK",$J,"IC R",PXAK,12 ,"BEFORE") =BEFOR12
  3193   "RTN","PXA IICR",57,0 )
  3194    S ^TMP("P XK",$J,"IC R",PXAK,81 1,"BEFORE" )=BEFOR811
  3195   "RTN","PXA IICR",58,0 )
  3196    S ^TMP("P XK",$J,"IC R",PXAK,81 2,"BEFORE" )=BEFOR812
  3197   "RTN","PXA IICR",59,0 )
  3198    S ^TMP("P XK",$J,"IC R",PXAK,"I EN")=IENB
  3199   "RTN","PXA IICR",60,0 )
  3200    ;
  3201   "RTN","PXA IICR",61,0 )
  3202    Q
  3203   "RTN","PXA IICRV")
  3204   0^9^B12775 865^n/a
  3205   "RTN","PXA IICRV",1,0 )
  3206   PXAIICRV ; BPFO/LMT -  VALIDATE  IMM CONTRA /REFUSAL D ATA ;12/31 /15  14:57
  3207   "RTN","PXA IICRV",2,0 )
  3208    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  3209   "RTN","PXA IICRV",3,0 )
  3210    ;
  3211   "RTN","PXA IICRV",4,0 )
  3212   VAL ;Make  sure the r equired fi elds are p resent.
  3213   "RTN","PXA IICRV",5,0 )
  3214    ;
  3215   "RTN","PXA IICRV",6,0 )
  3216    N PXFLD,P XFLDNAME,P XFLDNUM,PX FILE,PXOK, PXVAL,PXFL GERR
  3217   "RTN","PXA IICRV",7,0 )
  3218    ;
  3219   "RTN","PXA IICRV",8,0 )
  3220    S PXFILE= 9000010.70 7
  3221   "RTN","PXA IICRV",9,0 )
  3222    ;
  3223   "RTN","PXA IICRV",10, 0)
  3224    ; Validat e Required  fields
  3225   "RTN","PXA IICRV",11, 0)
  3226    F PXFLD=" CONTRA/REF USAL^.01", "IMMUN^.04 " D  Q:$G( STOP)=1
  3227   "RTN","PXA IICRV",12, 0)
  3228    . S PXFLD NAME=$P(PX FLD,"^",1)
  3229   "RTN","PXA IICRV",13, 0)
  3230    . S PXFLD NUM=$P(PXF LD,"^",2)
  3231   "RTN","PXA IICRV",14, 0)
  3232    . S PXVAL =$G(PXAA(P XFLDNAME))
  3233   "RTN","PXA IICRV",15, 0)
  3234    . I PXVAL ="" D  Q:$ G(STOP)=1
  3235   "RTN","PXA IICRV",16, 0)
  3236    . . S STO P=1
  3237   "RTN","PXA IICRV",17, 0)
  3238    . . S PXA ERRF=1
  3239   "RTN","PXA IICRV",18, 0)
  3240    . . S PXA DI("DIALOG ")=8390001 .001
  3241   "RTN","PXA IICRV",19, 0)
  3242    . . S PXA ERR(9)=PXF LDNAME
  3243   "RTN","PXA IICRV",20, 0)
  3244    . . S PXA ERR(10)="A FTER"
  3245   "RTN","PXA IICRV",21, 0)
  3246    . . S PXA ERR(11)=$G (PXAA(PXFL DNAME))
  3247   "RTN","PXA IICRV",22, 0)
  3248    . . S PXA ERR(12)="Y ou are mis sing the r equired fi eld: "_PXF LDNAME
  3249   "RTN","PXA IICRV",23, 0)
  3250    . ;
  3251   "RTN","PXA IICRV",24, 0)
  3252    . I $G(ST OP)=1 Q
  3253   "RTN","PXA IICRV",25, 0)
  3254    . ;
  3255   "RTN","PXA IICRV",26, 0)
  3256    . S PXOK= $$VALFLD(P XFILE,PXFL DNUM,PXVAL )
  3257   "RTN","PXA IICRV",27, 0)
  3258    . I 'PXOK  D ERRMSG( 8390001.00 1,1,PXVAL, PXFLDNAME)
  3259   "RTN","PXA IICRV",28, 0)
  3260    . ;
  3261   "RTN","PXA IICRV",29, 0)
  3262    . I ($G(S TOP)=1)!(P XFLDNUM'=. 04) Q
  3263   "RTN","PXA IICRV",30, 0)
  3264    . ;
  3265   "RTN","PXA IICRV",31, 0)
  3266    . I '$$IM MCRSEL^PXV UTIL(PXAA( "CONTRA/RE FUSAL"),PX AA("IMMUN" )) D
  3267   "RTN","PXA IICRV",32, 0)
  3268    . . S STO P=1
  3269   "RTN","PXA IICRV",33, 0)
  3270    . . S PXA ERRF=1
  3271   "RTN","PXA IICRV",34, 0)
  3272    . . S PXA DI("DIALOG ")=8390001 .001
  3273   "RTN","PXA IICRV",35, 0)
  3274    . . S PXA ERR(9)=PXF LDNAME
  3275   "RTN","PXA IICRV",36, 0)
  3276    . . S PXA ERR(10)="A FTER"
  3277   "RTN","PXA IICRV",37, 0)
  3278    . . S PXA ERR(11)=PX AA("IMMUN" )
  3279   "RTN","PXA IICRV",38, 0)
  3280    . . S PXA ERR(12)="I MMUNIZATIO N #"_PXAA( "IMMUN")_"  is NOT se lectable f or this "_ $S(PXAA("C ONTRA/REFU SAL")[920. 4:"Contrai ndication" ,1:"Refusa l")_" Reas on"
  3281   "RTN","PXA IICRV",39, 0)
  3282    ;
  3283   "RTN","PXA IICRV",40, 0)
  3284    I $G(STOP )=1 Q
  3285   "RTN","PXA IICRV",41, 0)
  3286    I $G(PXAA ("DELETE") )=1 Q  ; d on't bothe r checking  optional  fields if  this is a  deletion
  3287   "RTN","PXA IICRV",42, 0)
  3288    ;
  3289   "RTN","PXA IICRV",43, 0)
  3290    ; Validat e optional  fields
  3291   "RTN","PXA IICRV",44, 0)
  3292    F PXFLD=" WARN UNTIL  DATE^.05^ 1","EVENT  D/T^1201^0 ","ENC PRO VIDER^1204 ^0" D  Q:$ G(STOP)=1
  3293   "RTN","PXA IICRV",45, 0)
  3294    . ;
  3295   "RTN","PXA IICRV",46, 0)
  3296    . S PXFLD NAME=$P(PX FLD,"^",1)
  3297   "RTN","PXA IICRV",47, 0)
  3298    . S PXFLD NUM=$P(PXF LD,"^",2)
  3299   "RTN","PXA IICRV",48, 0)
  3300    . S PXFLG ERR=$P(PXF LD,"^",3)  ; if valid ation fail s, flag th is is as e rror (1) o r warning  (0)
  3301   "RTN","PXA IICRV",49, 0)
  3302    . ;
  3303   "RTN","PXA IICRV",50, 0)
  3304    . S PXVAL =$G(PXAA(P XFLDNAME))
  3305   "RTN","PXA IICRV",51, 0)
  3306    . I PXVAL ="" Q
  3307   "RTN","PXA IICRV",52, 0)
  3308    . ;
  3309   "RTN","PXA IICRV",53, 0)
  3310    . S PXOK= $$VALFLD(P XFILE,PXFL DNUM,PXVAL )
  3311   "RTN","PXA IICRV",54, 0)
  3312    . I 'PXOK  D
  3313   "RTN","PXA IICRV",55, 0)
  3314    . . I PXF LGERR D ER RMSG(83900 01.001,1,P XVAL,PXFLD NAME)
  3315   "RTN","PXA IICRV",56, 0)
  3316    . . I 'PX FLGERR D E RRMSG(8390 001.002,0, PXVAL,PXFL DNAME)
  3317   "RTN","PXA IICRV",57, 0)
  3318    . . I $G( STOP)=1 Q
  3319   "RTN","PXA IICRV",58, 0)
  3320    . . K PXA A(PXFLDNAM E) ; Don't  file this  field, as  it's inva lid
  3321   "RTN","PXA IICRV",59, 0)
  3322    ;
  3323   "RTN","PXA IICRV",60, 0)
  3324    Q
  3325   "RTN","PXA IICRV",61, 0)
  3326    ;
  3327   "RTN","PXA IICRV",62, 0)
  3328   VALFLD(PXF ILE,PXFLDN UM,PXVAL)  ;
  3329   "RTN","PXA IICRV",63, 0)
  3330    ;
  3331   "RTN","PXA IICRV",64, 0)
  3332    ; Validat e field an d return:
  3333   "RTN","PXA IICRV",65, 0)
  3334    ;
  3335   "RTN","PXA IICRV",66, 0)
  3336    ;    1    - Field is  valid
  3337   "RTN","PXA IICRV",67, 0)
  3338    ;    0    - Field is  invalid
  3339   "RTN","PXA IICRV",68, 0)
  3340    ;
  3341   "RTN","PXA IICRV",69, 0)
  3342    N PXOK,PX EXT,PXFLDT YP,PXRSLT, PXERR
  3343   "RTN","PXA IICRV",70, 0)
  3344    ;
  3345   "RTN","PXA IICRV",71, 0)
  3346    S PXOK=1
  3347   "RTN","PXA IICRV",72, 0)
  3348    ;
  3349   "RTN","PXA IICRV",73, 0)
  3350    I PXVAL=" @" Q PXOK
  3351   "RTN","PXA IICRV",74, 0)
  3352    ;
  3353   "RTN","PXA IICRV",75, 0)
  3354    S PXFLDTY P=$$GET1^D ID(PXFILE, PXFLDNUM,, "TYPE",,"P XERR")
  3355   "RTN","PXA IICRV",76, 0)
  3356    I PXFLDNU M=.01,PXFL DTYP="VARI ABLE-POINT ER" D
  3357   "RTN","PXA IICRV",77, 0)
  3358    . I PXVAL [920.4 S P XVAL="C.`" _(+PXVAL)
  3359   "RTN","PXA IICRV",78, 0)
  3360    . I PXVAL [920.5 S P XVAL="R.`" _(+PXVAL)
  3361   "RTN","PXA IICRV",79, 0)
  3362    I PXFLDTY P="POINTER " D
  3363   "RTN","PXA IICRV",80, 0)
  3364    . S PXVAL ="`"_PXVAL
  3365   "RTN","PXA IICRV",81, 0)
  3366    ;
  3367   "RTN","PXA IICRV",82, 0)
  3368    S PXEXT=" "
  3369   "RTN","PXA IICRV",83, 0)
  3370    D CHK^DIE (PXFILE,PX FLDNUM,"", PXVAL,.PXR SLT,"PXERR ")
  3371   "RTN","PXA IICRV",84, 0)
  3372    I $G(PXRS LT)="^" S  PXOK=0
  3373   "RTN","PXA IICRV",85, 0)
  3374    ;
  3375   "RTN","PXA IICRV",86, 0)
  3376    Q PXOK
  3377   "RTN","PXA IICRV",87, 0)
  3378    ;
  3379   "RTN","PXA IICRV",88, 0)
  3380   ERRMSG(PXD LG,PXSTOP, PXVAL,PXFL DNAME) ;
  3381   "RTN","PXA IICRV",89, 0)
  3382    ;
  3383   "RTN","PXA IICRV",90, 0)
  3384    S STOP=$G (PXSTOP,0)
  3385   "RTN","PXA IICRV",91, 0)
  3386    S PXAERRF =1
  3387   "RTN","PXA IICRV",92, 0)
  3388    S PXADI(" DIALOG")=$ G(PXDLG,"8 390001.002 ")
  3389   "RTN","PXA IICRV",93, 0)
  3390    I $G(PXAE RR(9))'=""  D
  3391   "RTN","PXA IICRV",94, 0)
  3392    . S PXAER R(9)=PXAER R(9)_", "
  3393   "RTN","PXA IICRV",95, 0)
  3394    . S PXAER R(11)=PXAE RR(11)_",  "
  3395   "RTN","PXA IICRV",96, 0)
  3396    . S PXAER R(12)=PXAE RR(12)_" "
  3397   "RTN","PXA IICRV",97, 0)
  3398    S PXAERR( 9)=$G(PXAE RR(9))_PXF LDNAME
  3399   "RTN","PXA IICRV",98, 0)
  3400    S PXAERR( 11)=$G(PXA ERR(11))_P XVAL
  3401   "RTN","PXA IICRV",99, 0)
  3402    S PXAERR( 12)=$G(PXA ERR(12))_" '"_PXVAL_" ' is not a  valid val ue for fie ld "_PXFLD NAME_"."
  3403   "RTN","PXA IICRV",100 ,0)
  3404    ;
  3405   "RTN","PXA IICRV",101 ,0)
  3406    Q
  3407   "RTN","PXA IIMM")
  3408   0^31^B1604 5767^B1425 5138
  3409   "RTN","PXA IIMM",1,0)
  3410   PXAIIMM ;I SL/PKR - S et the IMM UNIZATION  nodes. ;02 /04/16  09 :21
  3411   "RTN","PXA IIMM",2,0)
  3412    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**45,1 24,209,210 ,215**;Aug  12, 1996; Build 10
  3413   "RTN","PXA IIMM",3,0)
  3414    ;
  3415   "RTN","PXA IIMM",4,0)
  3416   IMM ;Main  entry poin t.
  3417   "RTN","PXA IIMM",5,0)
  3418    ;
  3419   "RTN","PXA IIMM",6,0)
  3420    K PXAERR
  3421   "RTN","PXA IIMM",7,0)
  3422    S PXAERR( 8)=PXAK
  3423   "RTN","PXA IIMM",8,0)
  3424    S PXAERR( 7)="IMMUNI ZATION"
  3425   "RTN","PXA IIMM",9,0)
  3426    ;
  3427   "RTN","PXA IIMM",10,0 )
  3428    N IND,PXA A
  3429   "RTN","PXA IIMM",11,0 )
  3430    S IND=""
  3431   "RTN","PXA IIMM",12,0 )
  3432    F  S IND= $O(@PXADAT A@("IMMUNI ZATION",PX AK,IND)) Q :IND=""  D
  3433   "RTN","PXA IIMM",13,0 )
  3434    . I IND?1 (1"VIS",1" REMARKS")  D  Q
  3435   "RTN","PXA IIMM",14,0 )
  3436    . . M PXA A(IND)=@PX ADATA@("IM MUNIZATION ",PXAK,IND )
  3437   "RTN","PXA IIMM",15,0 )
  3438    . S PXAA( IND)=@PXAD ATA@("IMMU NIZATION", PXAK,IND)
  3439   "RTN","PXA IIMM",16,0 )
  3440    ;
  3441   "RTN","PXA IIMM",17,0 )
  3442    ;Validate  the data.
  3443   "RTN","PXA IIMM",18,0 )
  3444    N STOP
  3445   "RTN","PXA IIMM",19,0 )
  3446    D VAL^PXA IIMMV
  3447   "RTN","PXA IIMM",20,0 )
  3448    I $G(STOP ) Q
  3449   "RTN","PXA IIMM",21,0 )
  3450    ;
  3451   "RTN","PXA IIMM",22,0 )
  3452   SETVARA ;S et the aft er visit v ariables.
  3453   "RTN","PXA IIMM",23,0 )
  3454    N AFTER0, AFTER12,AF TER13,AFTE R16,AFTER8 11,AFTER81 2
  3455   "RTN","PXA IIMM",24,0 )
  3456    S $P(AFTE R0,U,1)=$G (PXAA("IMM UN"))
  3457   "RTN","PXA IIMM",25,0 )
  3458    I $G(PXAA ("DELETE") ) S $P(AFT ER0,U,1)=" @"
  3459   "RTN","PXA IIMM",26,0 )
  3460    S $P(AFTE R0,U,2)=$G (PATIENT)
  3461   "RTN","PXA IIMM",27,0 )
  3462    S $P(AFTE R0,U,3)=$G (PXAVISIT)
  3463   "RTN","PXA IIMM",28,0 )
  3464    S $P(AFTE R0,U,4)=$G (PXAA("SER IES"))
  3465   "RTN","PXA IIMM",29,0 )
  3466    S $P(AFTE R0,U,6)=$G (PXAA("REA CTION"))
  3467   "RTN","PXA IIMM",30,0 )
  3468    S $P(AFTE R0,U,7)=$G (PXAA("CON TRAINDICAT ED"))
  3469   "RTN","PXA IIMM",31,0 )
  3470    S $P(AFTE R12,U,1)=$ G(PXAA("EV ENT D/T"))
  3471   "RTN","PXA IIMM",32,0 )
  3472    S $P(AFTE R12,U,4)=$ G(PXAA("EN C PROVIDER "))
  3473   "RTN","PXA IIMM",33,0 )
  3474    S $P(AFTE R811,U,1)= $G(PXAA("C OMMENT"))
  3475   "RTN","PXA IIMM",34,0 )
  3476    ;
  3477   "RTN","PXA IIMM",35,0 )
  3478    ;--PACKAG E AND SOUR CE
  3479   "RTN","PXA IIMM",36,0 )
  3480    S $P(AFTE R812,"^",2 )=$G(PXAPK G)
  3481   "RTN","PXA IIMM",37,0 )
  3482    S $P(AFTE R812,"^",3 )=$G(PXASO URC)
  3483   "RTN","PXA IIMM",38,0 )
  3484    ;
  3485   "RTN","PXA IIMM",39,0 )
  3486    ;--Add ne w fields f or VIMM 2. 0 - PX*1*2 09/210/215
  3487   "RTN","PXA IIMM",40,0 )
  3488    S $P(AFTE R12,U,2)=$ G(PXAA("OR D PROVIDER "))
  3489   "RTN","PXA IIMM",41,0 )
  3490    S $P(AFTE R12,U,7)=$ G(PXAA("LO T NUM"))
  3491   "RTN","PXA IIMM",42,0 )
  3492    S $P(AFTE R12,U,20)= $G(PXAA("W ARNING ACK "))
  3493   "RTN","PXA IIMM",43,0 )
  3494    S $P(AFTE R13,U)=$G( PXAA("INFO  SOURCE"))
  3495   "RTN","PXA IIMM",44,0 )
  3496    S $P(AFTE R13,U,2)=$ G(PXAA("AD MIN ROUTE" ))
  3497   "RTN","PXA IIMM",45,0 )
  3498    S $P(AFTE R13,U,3)=$ G(PXAA("AN ATOMIC LOC "))
  3499   "RTN","PXA IIMM",46,0 )
  3500    S $P(AFTE R13,U,4)=$ G(PXAA("DI AGNOSIS"))
  3501   "RTN","PXA IIMM",47,0 )
  3502    S $P(AFTE R13,U,12)= $G(PXAA("D OSE"))
  3503   "RTN","PXA IIMM",48,0 )
  3504    S $P(AFTE R13,U,13)= $G(PXAA("D OSE UNITS" ))
  3505   "RTN","PXA IIMM",49,0 )
  3506    S $P(AFTE R16,U,1)=$ G(PXAA("OV ERRIDE REA SON"))
  3507   "RTN","PXA IIMM",50,0 )
  3508    ;
  3509   "RTN","PXA IIMM",51,0 )
  3510    S ^TMP("P XK",$J,"IM M",PXAK,0, "AFTER")=A FTER0
  3511   "RTN","PXA IIMM",52,0 )
  3512    S ^TMP("P XK",$J,"IM M",PXAK,12 ,"AFTER")= AFTER12
  3513   "RTN","PXA IIMM",53,0 )
  3514    S ^TMP("P XK",$J,"IM M",PXAK,13 ,"AFTER")= AFTER13
  3515   "RTN","PXA IIMM",54,0 )
  3516    S ^TMP("P XK",$J,"IM M",PXAK,16 ,"AFTER")= AFTER16
  3517   "RTN","PXA IIMM",55,0 )
  3518    S ^TMP("P XK",$J,"IM M",PXAK,81 1,"AFTER") =AFTER811
  3519   "RTN","PXA IIMM",56,0 )
  3520    S ^TMP("P XK",$J,"IM M",PXAK,81 2,"AFTER") =AFTER812
  3521   "RTN","PXA IIMM",57,0 )
  3522    ;
  3523   "RTN","PXA IIMM",58,0 )
  3524    ; Add mul tiple data  to PXK AF TER - PX*1 *210
  3525   "RTN","PXA IIMM",59,0 )
  3526    N FLD,SEQ ,SUB
  3527   "RTN","PXA IIMM",60,0 )
  3528    ;
  3529   "RTN","PXA IIMM",61,0 )
  3530    F FLD="VI S","REMARK S" D
  3531   "RTN","PXA IIMM",62,0 )
  3532    . ;
  3533   "RTN","PXA IIMM",63,0 )
  3534    . S SUB=$ S(FLD="VIS ":2,1:11)
  3535   "RTN","PXA IIMM",64,0 )
  3536    . ;
  3537   "RTN","PXA IIMM",65,0 )
  3538    . ; Delet e multiple
  3539   "RTN","PXA IIMM",66,0 )
  3540    . I $G(PX AA(FLD))=" @" D  Q
  3541   "RTN","PXA IIMM",67,0 )
  3542    . . S ^TM P("PXK",$J ,"IMM",PXA K,SUB,0,"A FTER")="@"
  3543   "RTN","PXA IIMM",68,0 )
  3544    . ;
  3545   "RTN","PXA IIMM",69,0 )
  3546    . S SEQ=0
  3547   "RTN","PXA IIMM",70,0 )
  3548    . F  S SE Q=$O(PXAA( FLD,SEQ))  Q:'SEQ  D
  3549   "RTN","PXA IIMM",71,0 )
  3550    . . S ^TM P("PXK",$J ,"IMM",PXA K,SUB,SEQ, "AFTER")=$ G(PXAA(FLD ,SEQ,0))
  3551   "RTN","PXA IIMM",72,0 )
  3552    ;
  3553   "RTN","PXA IIMM",73,0 )
  3554    ; Add DIA GNOSIS 2 t hru 8 to O THER DIAGN OSIS multi ple
  3555   "RTN","PXA IIMM",74,0 )
  3556    N DIAGNUM ,DIAGSTR
  3557   "RTN","PXA IIMM",75,0 )
  3558    ;
  3559   "RTN","PXA IIMM",76,0 )
  3560    S SEQ=0
  3561   "RTN","PXA IIMM",77,0 )
  3562    ;
  3563   "RTN","PXA IIMM",78,0 )
  3564    F DIAGNUM =2:1:8 D
  3565   "RTN","PXA IIMM",79,0 )
  3566    . S DIAGS TR="DIAGNO SIS "_DIAG NUM
  3567   "RTN","PXA IIMM",80,0 )
  3568    . I $G(PX AA(DIAGSTR ))'="" D
  3569   "RTN","PXA IIMM",81,0 )
  3570    . . S SEQ =SEQ+1
  3571   "RTN","PXA IIMM",82,0 )
  3572    . . S ^TM P("PXK",$J ,"IMM",PXA K,3,SEQ,"A FTER")=PXA A(DIAGSTR)
  3573   "RTN","PXA IIMM",83,0 )
  3574    ;
  3575   "RTN","PXA IIMM",84,0 )
  3576   SETVARB ;S et the bef ore variab les.
  3577   "RTN","PXA IIMM",85,0 )
  3578    N BEFOR0, BEFOR12,BE FOR13,BEFO R16,BEFOR8 11,BEFOR81 2
  3579   "RTN","PXA IIMM",86,0 )
  3580    N IENB,PX AAX,PXBCNT ,PXBKY,PXB SKY,PXBSAM
  3581   "RTN","PXA IIMM",87,0 )
  3582    D IMM^PXB GIMM(PXAVI SIT)
  3583   "RTN","PXA IIMM",88,0 )
  3584    ;
  3585   "RTN","PXA IIMM",89,0 )
  3586    S IENB=""
  3587   "RTN","PXA IIMM",90,0 )
  3588    I PXBCNT> 0 D
  3589   "RTN","PXA IIMM",91,0 )
  3590    . S PXAAX ("IMMUN")= $P($G(^AUT TIMM(PXAA( "IMMUN"),0 )),U,1)
  3591   "RTN","PXA IIMM",92,0 )
  3592    . S IENB= $O(PXBKY(P XAAX("IMMU N"),IENB))
  3593   "RTN","PXA IIMM",93,0 )
  3594    I $G(IENB ) D
  3595   "RTN","PXA IIMM",94,0 )
  3596    . S BEFOR 0=$G(^AUPN VIMM(IENB, 0))
  3597   "RTN","PXA IIMM",95,0 )
  3598    . S BEFOR 12=$G(^AUP NVIMM(IENB ,12))
  3599   "RTN","PXA IIMM",96,0 )
  3600    . S BEFOR 13=$G(^AUP NVIMM(IENB ,13))
  3601   "RTN","PXA IIMM",97,0 )
  3602    . S BEFOR 16=$G(^AUP NVIMM(IENB ,16))
  3603   "RTN","PXA IIMM",98,0 )
  3604    . S BEFOR 811=$G(^AU PNVIMM(IEN B,811))
  3605   "RTN","PXA IIMM",99,0 )
  3606    . S BEFOR 812=$G(^AU PNVIMM(IEN B,812))
  3607   "RTN","PXA IIMM",100, 0)
  3608    E  S (BEF OR0,BEFOR1 1,BEFOR12, BEFOR13,BE FOR16,BEFO R811,BEFOR 812)=""
  3609   "RTN","PXA IIMM",101, 0)
  3610    ;
  3611   "RTN","PXA IIMM",102, 0)
  3612    S ^TMP("P XK",$J,"IM M",PXAK,0, "BEFORE")= BEFOR0
  3613   "RTN","PXA IIMM",103, 0)
  3614    S ^TMP("P XK",$J,"IM M",PXAK,12 ,"BEFORE") =BEFOR12
  3615   "RTN","PXA IIMM",104, 0)
  3616    S ^TMP("P XK",$J,"IM M",PXAK,13 ,"BEFORE") =BEFOR13
  3617   "RTN","PXA IIMM",105, 0)
  3618    S ^TMP("P XK",$J,"IM M",PXAK,16 ,"BEFORE") =BEFOR16
  3619   "RTN","PXA IIMM",106, 0)
  3620    S ^TMP("P XK",$J,"IM M",PXAK,81 1,"BEFORE" )=BEFOR811
  3621   "RTN","PXA IIMM",107, 0)
  3622    S ^TMP("P XK",$J,"IM M",PXAK,81 2,"BEFORE" )=BEFOR812
  3623   "RTN","PXA IIMM",108, 0)
  3624    S ^TMP("P XK",$J,"IM M",PXAK,"I EN")=IENB
  3625   "RTN","PXA IIMM",109, 0)
  3626    ;
  3627   "RTN","PXA IIMM",110, 0)
  3628    ; Add mul tiple data  to PXK BE FORE
  3629   "RTN","PXA IIMM",111, 0)
  3630    I $G(IENB ) D
  3631   "RTN","PXA IIMM",112, 0)
  3632    . N IENSU B,SUB
  3633   "RTN","PXA IIMM",113, 0)
  3634    . F SUB=2 ,3,11 D
  3635   "RTN","PXA IIMM",114, 0)
  3636    . . S IEN SUB=0
  3637   "RTN","PXA IIMM",115, 0)
  3638    . . F  S  IENSUB=$O( ^AUPNVIMM( IENB,SUB,I ENSUB)) Q: 'IENSUB  D
  3639   "RTN","PXA IIMM",116, 0)
  3640    . . . S ^ TMP("PXK", $J,"IMM",P XAK,SUB,IE NSUB,"BEFO RE")=$G(^A UPNVIMM(IE NB,SUB,IEN SUB,0))
  3641   "RTN","PXA IIMM",117, 0)
  3642    ;
  3643   "RTN","PXA IIMM",118, 0)
  3644    Q
  3645   "RTN","PXA PIIM")
  3646   0^3^B80558 091^B27410 56
  3647   "RTN","PXA PIIM",1,0)
  3648   PXAPIIM ;B P/LMT - PC E Immuniza tion APIs  ;04/20/16   10:00
  3649   "RTN","PXA PIIM",2,0)
  3650    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**210, 215**;Aug  12, 1996;B uild 10
  3651   "RTN","PXA PIIM",3,0)
  3652    ;
  3653   "RTN","PXA PIIM",4,0)
  3654    ; Referen ce to NAME  in file . 85 is supp orted by I CR #6062
  3655   "RTN","PXA PIIM",5,0)
  3656    ;
  3657   "RTN","PXA PIIM",6,0)
  3658    Q
  3659   "RTN","PXA PIIM",7,0)
  3660    ;
  3661   "RTN","PXA PIIM",8,0)
  3662   VIS(PXRESU LT,PXVIS,P XDATE) ;Ca lled from  VIS^PXAPI
  3663   "RTN","PXA PIIM",9,0)
  3664    ;
  3665   "RTN","PXA PIIM",10,0 )
  3666    ;Input:
  3667   "RTN","PXA PIIM",11,0 )
  3668    ;  PXRESU LT  (requi red) Retur n value (p assed by r eference)
  3669   "RTN","PXA PIIM",12,0 )
  3670    ;     PXV IS  (requi red) Point er to #920
  3671   "RTN","PXA PIIM",13,0 )
  3672    ;    PXDA TE  (optio nal; defau lts to NOW ) The date  in FileMa n format.
  3673   "RTN","PXA PIIM",14,0 )
  3674    ;                         Used  to check t he status  of the VIS  on that d ate.
  3675   "RTN","PXA PIIM",15,0 )
  3676    ;Returns:
  3677   "RTN","PXA PIIM",16,0 )
  3678    ;  PXRESU LT("NAME")  = VIS Nam e
  3679   "RTN","PXA PIIM",17,0 )
  3680    ;  PXRESU LT("EDITIO N DATE") =  FileManag er Interna l Format f or date/ti me
  3681   "RTN","PXA PIIM",18,0 )
  3682    ;  PXRESU LT("EDITIO N STATUS")  = code^va lue (C^CUR RENT or H^ HISTORIC)
  3683   "RTN","PXA PIIM",19,0 )
  3684    ;  PXRESU LT("LANGUA GE") = IEN  ^ Languag e (e.g., 1 ^ENGLISH)
  3685   "RTN","PXA PIIM",20,0 )
  3686    ;  PXRESU LT("2D BAR  CODE") =  Barcode fr om the CDC  VIS barco de lookup  table
  3687   "RTN","PXA PIIM",21,0 )
  3688    ;  PXRESU LT("VIS UR L") = Inte rnet URL f or this VI S
  3689   "RTN","PXA PIIM",22,0 )
  3690    ;  PXRESU LT("STATUS ") = Statu s based on  PXDATE (1 ^ACTIVE or  0^INACTIV E)
  3691   "RTN","PXA PIIM",23,0 )
  3692    ;
  3693   "RTN","PXA PIIM",24,0 )
  3694    N PXDATA, PXFILE,PXI ENS,PXLANG ,PXSTATUS
  3695   "RTN","PXA PIIM",25,0 )
  3696    ;
  3697   "RTN","PXA PIIM",26,0 )
  3698    S PXFILE= 920
  3699   "RTN","PXA PIIM",27,0 )
  3700    S PXIENS= PXVIS_","
  3701   "RTN","PXA PIIM",28,0 )
  3702    D GETS^DI Q(PXFILE,P XIENS,"*", "EI","PXDA TA")
  3703   "RTN","PXA PIIM",29,0 )
  3704    ;
  3705   "RTN","PXA PIIM",30,0 )
  3706    S PXRESUL T("NAME")= $G(PXDATA( PXFILE,PXI ENS,.01,"E "))
  3707   "RTN","PXA PIIM",31,0 )
  3708    S PXRESUL T("EDITION  DATE")=$G (PXDATA(PX FILE,PXIEN S,.02,"I") )
  3709   "RTN","PXA PIIM",32,0 )
  3710    S PXRESUL T("EDITION  STATUS")= $G(PXDATA( PXFILE,PXI ENS,.03,"I "))_U_$G(P XDATA(PXFI LE,PXIENS, .03,"E"))
  3711   "RTN","PXA PIIM",33,0 )
  3712    S PXRESUL T("2D BAR  CODE")=$G( PXDATA(PXF ILE,PXIENS ,100,"E"))
  3713   "RTN","PXA PIIM",34,0 )
  3714    S PXRESUL T("VIS URL ")=$G(PXDA TA(PXFILE, PXIENS,101 ,"E"))
  3715   "RTN","PXA PIIM",35,0 )
  3716    ;
  3717   "RTN","PXA PIIM",36,0 )
  3718    S PXLANG= $G(PXDATA( PXFILE,PXI ENS,.04,"I "))
  3719   "RTN","PXA PIIM",37,0 )
  3720    I PXLANG  D
  3721   "RTN","PXA PIIM",38,0 )
  3722    . S PXLAN G=PXLANG_U _$$GET1^DI Q(.85,PXLA NG_",","NA ME")  ;ICR  6062
  3723   "RTN","PXA PIIM",39,0 )
  3724    S PXRESUL T("LANGUAG E")=PXLANG
  3725   "RTN","PXA PIIM",40,0 )
  3726    ;
  3727   "RTN","PXA PIIM",41,0 )
  3728    S PXSTATU S=$$GETSTA T^XTID(PXF ILE,.01,PX IENS,$G(PX DATE))
  3729   "RTN","PXA PIIM",42,0 )
  3730    S PXRESUL T("STATUS" )=$P(PXSTA TUS,U,1)_U _$P(PXSTAT US,U,3)
  3731   "RTN","PXA PIIM",43,0 )
  3732    ;
  3733   "RTN","PXA PIIM",44,0 )
  3734    Q
  3735   "RTN","PXA PIIM",45,0 )
  3736    ;
  3737   "RTN","PXA PIIM",46,0 )
  3738   IMMGRP(PXR ESULT,PXIM M) ;
  3739   "RTN","PXA PIIM",47,0 )
  3740    ;
  3741   "RTN","PXA PIIM",48,0 )
  3742    ; Returns  a list of  immunizat ions that  share the  same CVX c ode and Va ccine Grou p
  3743   "RTN","PXA PIIM",49,0 )
  3744    ; Name(s)  as PXIMM,  as well a s Contrain dications  that are l imited to  PXIMM.
  3745   "RTN","PXA PIIM",50,0 )
  3746    ;
  3747   "RTN","PXA PIIM",51,0 )
  3748    ;Input:
  3749   "RTN","PXA PIIM",52,0 )
  3750    ;  PXRESU LT  (requi red) Retur n value (p assed by r eference)
  3751   "RTN","PXA PIIM",53,0 )
  3752    ;     PXI MM  (requi red) Point er to #999 9999.14
  3753   "RTN","PXA PIIM",54,0 )
  3754    ;
  3755   "RTN","PXA PIIM",55,0 )
  3756    ;Returns:
  3757   "RTN","PXA PIIM",56,0 )
  3758    ;  PXRESU LT("CVX",C VX_CODE,IM M_IEN) = I mmunizatio n Name
  3759   "RTN","PXA PIIM",57,0 )
  3760    ;  PXRESU LT("VG",GR OUP_NAME,I MM_IEN) =  Immunizati on Name
  3761   "RTN","PXA PIIM",58,0 )
  3762    ;  PXRESU LT("ICR",C ONTRA_VIEN ) = Contra indication  Name
  3763   "RTN","PXA PIIM",59,0 )
  3764    ;
  3765   "RTN","PXA PIIM",60,0 )
  3766    N PXCODE, PXCVX,PXIC RIEN,PXICR NAME,PXIMM B,PXNAME,P XVGIEN,PXV GNAME
  3767   "RTN","PXA PIIM",61,0 )
  3768    ;
  3769   "RTN","PXA PIIM",62,0 )
  3770    I '$G(PXI MM) Q
  3771   "RTN","PXA PIIM",63,0 )
  3772    ;
  3773   "RTN","PXA PIIM",64,0 )
  3774    S PXNAME= $P($G(^AUT TIMM(PXIMM ,0)),U,1)
  3775   "RTN","PXA PIIM",65,0 )
  3776    ;
  3777   "RTN","PXA PIIM",66,0 )
  3778    S PXCVX=$ P($G(^AUTT IMM(PXIMM, 0)),U,3)
  3779   "RTN","PXA PIIM",67,0 )
  3780    I PXCVX'= "" D
  3781   "RTN","PXA PIIM",68,0 )
  3782    . S PXIMM B=0
  3783   "RTN","PXA PIIM",69,0 )
  3784    . F  S PX IMMB=$O(^A UTTIMM("C" ,PXCVX,PXI MMB)) Q:'P XIMMB  D
  3785   "RTN","PXA PIIM",70,0 )
  3786    . . S PXN AME=$P($G( ^AUTTIMM(P XIMMB,0)), U,1)
  3787   "RTN","PXA PIIM",71,0 )
  3788    . . S PXR ESULT("CVX ",PXCVX,PX IMMB)=PXNA ME
  3789   "RTN","PXA PIIM",72,0 )
  3790    ;
  3791   "RTN","PXA PIIM",73,0 )
  3792    S PXVGIEN =0
  3793   "RTN","PXA PIIM",74,0 )
  3794    F  S PXVG IEN=$O(^AU TTIMM(PXIM M,7,PXVGIE N)) Q:'PXV GIEN  D
  3795   "RTN","PXA PIIM",75,0 )
  3796    . S PXVGN AME=$P($G( ^AUTTIMM(P XIMM,7,PXV GIEN,0)),U ,1)
  3797   "RTN","PXA PIIM",76,0 )
  3798    . I PXVGN AME="" Q
  3799   "RTN","PXA PIIM",77,0 )
  3800    . S PXIMM B=0
  3801   "RTN","PXA PIIM",78,0 )
  3802    . F  S PX IMMB=$O(^A UTTIMM("I" ,PXVGNAME, PXIMMB)) Q :'PXIMMB   D
  3803   "RTN","PXA PIIM",79,0 )
  3804    . . S PXN AME=$P($G( ^AUTTIMM(P XIMMB,0)), U,1)
  3805   "RTN","PXA PIIM",80,0 )
  3806    . . S PXR ESULT("VG" ,PXVGNAME, PXIMMB)=PX NAME
  3807   "RTN","PXA PIIM",81,0 )
  3808    ;
  3809   "RTN","PXA PIIM",82,0 )
  3810    S PXICRIE N=0
  3811   "RTN","PXA PIIM",83,0 )
  3812    F  S PXIC RIEN=$O(^P XV(920.4,P XICRIEN))  Q:'PXICRIE N  D
  3813   "RTN","PXA PIIM",84,0 )
  3814    . S PXICR NAME=$P($G (^PXV(920. 4,PXICRIEN ,0)),U,1)
  3815   "RTN","PXA PIIM",85,0 )
  3816    . ;
  3817   "RTN","PXA PIIM",86,0 )
  3818    . ; If th is imm is  listed in  the Immuni zations Li mited To
  3819   "RTN","PXA PIIM",87,0 )
  3820    . ; multi ple, inclu de it
  3821   "RTN","PXA PIIM",88,0 )
  3822    . I $O(^P XV(920.4,P XICRIEN,3, "B",PXIMM, 0)) D  Q
  3823   "RTN","PXA PIIM",89,0 )
  3824    . . S PXR ESULT("ICR ",PXICRIEN _";PXV(920 .4,")=PXIC RNAME
  3825   "RTN","PXA PIIM",90,0 )
  3826    . ;
  3827   "RTN","PXA PIIM",91,0 )
  3828    . ; Inclu de all con tras that  don't have  the Immun izations
  3829   "RTN","PXA PIIM",92,0 )
  3830    . ; Limit ed To mult iple popul ated, exce pt Severe  Reaction
  3831   "RTN","PXA PIIM",93,0 )
  3832    . ; Previ ous Dose
  3833   "RTN","PXA PIIM",94,0 )
  3834    . I '$O(^ PXV(920.4, PXICRIEN,3 ,0)) D  Q
  3835   "RTN","PXA PIIM",95,0 )
  3836    . . S PXC ODE=$P($G( ^PXV(920.4 ,PXICRIEN, 0)),U,2)
  3837   "RTN","PXA PIIM",96,0 )
  3838    . . I (PX ICRNAME="S EVERE REAC TION PREVI OUS DOSE") !(PXCODE=" VXC20") Q
  3839   "RTN","PXA PIIM",97,0 )
  3840    . . S PXR ESULT("ICR ",PXICRIEN _";PXV(920 .4,")=PXIC RNAME
  3841   "RTN","PXA PIIM",98,0 )
  3842    ;
  3843   "RTN","PXA PIIM",99,0 )
  3844    Q
  3845   "RTN","PXA PIIM",100, 0)
  3846    ;
  3847   "RTN","PXA PIIM",101, 0)
  3848   IMMSTAT(PX IMM) ;
  3849   "RTN","PXA PIIM",102, 0)
  3850    ;
  3851   "RTN","PXA PIIM",103, 0)
  3852    ;Returns  Immunizati on status
  3853   "RTN","PXA PIIM",104, 0)
  3854    ;
  3855   "RTN","PXA PIIM",105, 0)
  3856    ;Input:
  3857   "RTN","PXA PIIM",106, 0)
  3858    ;  PXIMM  - (require d) Pointer  to #99999 99.14
  3859   "RTN","PXA PIIM",107, 0)
  3860    ;
  3861   "RTN","PXA PIIM",108, 0)
  3862    ;Returns:
  3863   "RTN","PXA PIIM",109, 0)
  3864    ;  A: Act ive
  3865   "RTN","PXA PIIM",110, 0)
  3866    ;  H: Ina ctive, but  Selectabl e for Hist oric
  3867   "RTN","PXA PIIM",111, 0)
  3868    ;  I: Ina ctive
  3869   "RTN","PXA PIIM",112, 0)
  3870    ;
  3871   "RTN","PXA PIIM",113, 0)
  3872    I '$G(PXI MM) Q ""
  3873   "RTN","PXA PIIM",114, 0)
  3874    I '$D(^AU TTIMM(PXIM M)) Q ""
  3875   "RTN","PXA PIIM",115, 0)
  3876    I $P($G(^ AUTTIMM(PX IMM,0)),U, 7)="" Q "A "
  3877   "RTN","PXA PIIM",116, 0)
  3878    I $P($G(^ AUTTIMM(PX IMM,6)),U, 1)="Y" Q " H"
  3879   "RTN","PXA PIIM",117, 0)
  3880    Q "I"
  3881   "RTN","PXA PIIM",118, 0)
  3882    ;
  3883   "RTN","PXA PIIM",119, 0)
  3884   IMMNODEF()  ; Returns  "IMMUNIZA TION, NO D EFAULT SEL ECTED" ent ry
  3885   "RTN","PXA PIIM",120, 0)
  3886    N PXIMM
  3887   "RTN","PXA PIIM",121, 0)
  3888    S PXIMM=$ O(^AUTTIMM ("AVUID",5 237389,0))
  3889   "RTN","PXA PIIM",122, 0)
  3890    I 'PXIMM  S PXIMM=$O (^AUTTIMM( "B","IMMUN IZATION, N O DEFAULT  SELECTED", 0))
  3891   "RTN","PXA PIIM",123, 0)
  3892    Q PXIMM
  3893   "RTN","PXA PIIM",124, 0)
  3894    ;
  3895   "RTN","PXA PIIM",125, 0)
  3896   IMMBYNM(PX NAME) ; Fi nds Immuni zation tha t matches  on PXNAME  and return s IEN
  3897   "RTN","PXA PIIM",126, 0)
  3898    N PXIMM
  3899   "RTN","PXA PIIM",127, 0)
  3900    I $G(PXNA ME)="" Q 0
  3901   "RTN","PXA PIIM",128, 0)
  3902    S PXIMM=$ O(^AUTTIMM ("B",PXNAM E,0))
  3903   "RTN","PXA PIIM",129, 0)
  3904    I PXIMM Q  PXIMM
  3905   "RTN","PXA PIIM",130, 0)
  3906    S PXIMM=$ O(^AUTTIMM ("G",PXNAM E,0))
  3907   "RTN","PXA PIIM",131, 0)
  3908    I PXIMM Q  PXIMM
  3909   "RTN","PXA PIIM",132, 0)
  3910    S PXIMM=$ O(^AUTTIMM ("H",PXNAM E,0))
  3911   "RTN","PXA PIIM",133, 0)
  3912    I PXIMM Q  PXIMM
  3913   "RTN","PXA PIIM",134, 0)
  3914    Q 0
  3915   "RTN","PXA PIIM",135, 0)
  3916    ;
  3917   "RTN","PXA PIIM",136, 0)
  3918   PATICR(PXR ESULT,DFN, PXIMM,PXBD T,PXEDT) ;
  3919   "RTN","PXA PIIM",137, 0)
  3920    ;
  3921   "RTN","PXA PIIM",138, 0)
  3922    ; Finds a ll of a pa tient's co ntraindica tions/refu sals using  the follo wing crite ria:
  3923   "RTN","PXA PIIM",139, 0)
  3924    ;   1. An y current- dated cont raindicati on/refusal  for PXIMM  AND any i mmunizatio n
  3925   "RTN","PXA PIIM",140, 0)
  3926    ;      th at shares  the same C VX code.
  3927   "RTN","PXA PIIM",141, 0)
  3928    ;   2. An y current- dated refu sals for a n immuniza tion that  shares the  same vacc ine
  3929   "RTN","PXA PIIM",142, 0)
  3930    ;      gr oup as PXI MM.
  3931   "RTN","PXA PIIM",143, 0)
  3932    ;   3. An y current- dated cont raindicati ons where  the contra indication  has PXIMM
  3933   "RTN","PXA PIIM",144, 0)
  3934    ;      li sted in th e "Immuniz ation Limi ted To" mu ltiple.
  3935   "RTN","PXA PIIM",145, 0)
  3936    ;   4. An y current- dated cont raindicati ons where  the contra indication  does not  have
  3937   "RTN","PXA PIIM",146, 0)
  3938    ;      an ything lis ted in the  "Immuniza tion Limit ed To" mul tiple, exc luding Sev ere
  3939   "RTN","PXA PIIM",147, 0)
  3940    ;      Re action Pre vious Dose .
  3941   "RTN","PXA PIIM",148, 0)
  3942    ;
  3943   "RTN","PXA PIIM",149, 0)
  3944    ;   * If  PXBDT and  PXEDT are  null, then  "current- dated" mea ns where S TOP >= TOD AY.
  3945   "RTN","PXA PIIM",150, 0)
  3946    ;   * If  PXBDT and  PXEDT are  defined, t hen "curre nt-dated"  means wher e START
  3947   "RTN","PXA PIIM",151, 0)
  3948    ;     <=  PXEDT, and  STOP is > = PXBDT.
  3949   "RTN","PXA PIIM",152, 0)
  3950    ;
  3951   "RTN","PXA PIIM",153, 0)
  3952    ;Input:
  3953   "RTN","PXA PIIM",154, 0)
  3954    ;  PXRESU LT - (requ ired) Retu rn value ( passed by  reference)
  3955   "RTN","PXA PIIM",155, 0)
  3956    ;       D FN - (requ ired) Poin ter to #2
  3957   "RTN","PXA PIIM",156, 0)
  3958    ;     PXI MM - (requ ired) Poin ter to #99 99999.14
  3959   "RTN","PXA PIIM",157, 0)
  3960    ;     PXB DT - (opti onal; defa ults to TO DAY) Begin  Search Da te
  3961   "RTN","PXA PIIM",158, 0)
  3962    ;     PXE DT - (opti onal; defa ults to 99 99999) End  Search Da te
  3963   "RTN","PXA PIIM",159, 0)
  3964    ;
  3965   "RTN","PXA PIIM",160, 0)
  3966    ;Returns:
  3967   "RTN","PXA PIIM",161, 0)
  3968    ;  PXRESU LT(DAS) =  Visit IEN  ^ Contra/R efusal var iable poin ter | Cont ra/Refusal  Name
  3969   "RTN","PXA PIIM",162, 0)
  3970    ;                    ^ Immuniza tion IEN |  Name ^ Wa rn Until D ate ^ D/T  Recorded ^  Event D/T
  3971   "RTN","PXA PIIM",163, 0)
  3972    ;                    ^ Encounte r Provider  IEN | Nam e
  3973   "RTN","PXA PIIM",164, 0)
  3974    ;  PXRESU LT(DAS,"CO MMENTS") =  Comments
  3975   "RTN","PXA PIIM",165, 0)
  3976    ;
  3977   "RTN","PXA PIIM",166, 0)
  3978    ;  * DAS  = Pointer  to #900001 0.707
  3979   "RTN","PXA PIIM",167, 0)
  3980    ;
  3981   "RTN","PXA PIIM",168, 0)
  3982    N PXCVX,P XDAS,PXDAT A,PXFILE,P XICR,PXIMM B,PXIMMGRP ,PXSEARCH, PXSEARCHBY ,PXSUB,PXV GN,PXX
  3983   "RTN","PXA PIIM",169, 0)
  3984    ;
  3985   "RTN","PXA PIIM",170, 0)
  3986    I '$G(DFN )!('$G(PXI MM)) Q
  3987   "RTN","PXA PIIM",171, 0)
  3988    ;
  3989   "RTN","PXA PIIM",172, 0)
  3990    S PXFILE= 9000010.70 7
  3991   "RTN","PXA PIIM",173, 0)
  3992    ;
  3993   "RTN","PXA PIIM",174, 0)
  3994    I $G(PXED T)="" S PX EDT=999999 9
  3995   "RTN","PXA PIIM",175, 0)
  3996    I $G(PXBD T)="" S PX BDT=DT
  3997   "RTN","PXA PIIM",176, 0)
  3998    I PXBDT S  PXBDT=PXB DT-.000000 1
  3999   "RTN","PXA PIIM",177, 0)
  4000    ;
  4001   "RTN","PXA PIIM",178, 0)
  4002    D IMMGRP( .PXIMMGRP, PXIMM)
  4003   "RTN","PXA PIIM",179, 0)
  4004    ;
  4005   "RTN","PXA PIIM",180, 0)
  4006    ; >> Sear ch based o ff criteri a #1 & #2:
  4007   "RTN","PXA PIIM",181, 0)
  4008    ;
  4009   "RTN","PXA PIIM",182, 0)
  4010    ; PXSEARC H("ALL") -  assists i n searchin g based of f criteria  #1
  4011   "RTN","PXA PIIM",183, 0)
  4012    S PXSEARC H("ALL",PX IMM)=""
  4013   "RTN","PXA PIIM",184, 0)
  4014    S PXCVX=$ O(PXIMMGRP ("CVX","") )
  4015   "RTN","PXA PIIM",185, 0)
  4016    I PXCVX'= "" D
  4017   "RTN","PXA PIIM",186, 0)
  4018    . S PXIMM B=0
  4019   "RTN","PXA PIIM",187, 0)
  4020    . F  S PX IMMB=$O(PX IMMGRP("CV X",PXCVX,P XIMMB)) Q: 'PXIMMB  D
  4021   "RTN","PXA PIIM",188, 0)
  4022    . . S PXS EARCH("ALL ",PXIMMB)= ""
  4023   "RTN","PXA PIIM",189, 0)
  4024    ;
  4025   "RTN","PXA PIIM",190, 0)
  4026    ; PXSEARC H("REFUSAL S") - assi sts in sea rching bas ed off cri teria #2
  4027   "RTN","PXA PIIM",191, 0)
  4028    S PXVGN=" "
  4029   "RTN","PXA PIIM",192, 0)
  4030    F  S PXVG N=$O(PXIMM GRP("VG",P XVGN)) Q:P XVGN=""  D
  4031   "RTN","PXA PIIM",193, 0)
  4032    . S PXIMM B=0
  4033   "RTN","PXA PIIM",194, 0)
  4034    . F  S PX IMMB=$O(PX IMMGRP("VG ",PXVGN,PX IMMB)) Q:' PXIMMB  D
  4035   "RTN","PXA PIIM",195, 0)
  4036    . . I '$D (PXSEARCH( "ALL",PXIM MB)) S PXS EARCH("REF USALS",PXI MMB)=""
  4037   "RTN","PXA PIIM",196, 0)
  4038    ;
  4039   "RTN","PXA PIIM",197, 0)
  4040    F PXSEARC HBY="ALL", "REFUSALS"  D
  4041   "RTN","PXA PIIM",198, 0)
  4042    . S PXIMM B=0
  4043   "RTN","PXA PIIM",199, 0)
  4044    . F  S PX IMMB=$O(PX SEARCH(PXS EARCHBY,PX IMMB)) Q:' PXIMMB  D
  4045   "RTN","PXA PIIM",200, 0)
  4046    . . S PXI CR=""
  4047   "RTN","PXA PIIM",201, 0)
  4048    . . F  S  PXICR=$O(^ PXRMINDX(P XFILE,"PIC ",DFN,PXIM MB,PXICR))  Q:'PXICR   D
  4049   "RTN","PXA PIIM",202, 0)
  4050    . . . I P XSEARCHBY= "REFUSALS" ,PXICR'[92 0.5 Q
  4051   "RTN","PXA PIIM",203, 0)
  4052    . . . S P XSUB(1)=PX FILE,PXSUB (2)="PIC", PXSUB(3)=D FN,PXSUB(4 )=PXIMMB,P XSUB(5)=PX ICR
  4053   "RTN","PXA PIIM",204, 0)
  4054    . . . D S EARCH(.PXR ESULT,.PXS UB,.PXBDT, .PXEDT)
  4055   "RTN","PXA PIIM",205, 0)
  4056    ;
  4057   "RTN","PXA PIIM",206, 0)
  4058    ; >> Sear ch based o ff criteri a #3 & #4:
  4059   "RTN","PXA PIIM",207, 0)
  4060    ;
  4061   "RTN","PXA PIIM",208, 0)
  4062    S PXICR=" "
  4063   "RTN","PXA PIIM",209, 0)
  4064    F  S PXIC R=$O(PXIMM GRP("ICR", PXICR)) Q: 'PXICR  D
  4065   "RTN","PXA PIIM",210, 0)
  4066    . S PXIMM B=0
  4067   "RTN","PXA PIIM",211, 0)
  4068    . F  S PX IMMB=$O(^P XRMINDX(PX FILE,"PCI" ,DFN,PXICR ,PXIMMB))  Q:'PXIMMB   D
  4069   "RTN","PXA PIIM",212, 0)
  4070    . . S PXS UB(1)=PXFI LE,PXSUB(2 )="PCI",PX SUB(3)=DFN ,PXSUB(4)= PXICR,PXSU B(5)=PXIMM B
  4071   "RTN","PXA PIIM",213, 0)
  4072    . . D SEA RCH(.PXRES ULT,.PXSUB ,.PXBDT,.P XEDT)
  4073   "RTN","PXA PIIM",214, 0)
  4074    ;
  4075   "RTN","PXA PIIM",215, 0)
  4076    ; >> Setu p return a rray field s:
  4077   "RTN","PXA PIIM",216, 0)
  4078    S PXDAS=0
  4079   "RTN","PXA PIIM",217, 0)
  4080    F  S PXDA S=$O(PXRES ULT(PXDAS) ) Q:'PXDAS   D
  4081   "RTN","PXA PIIM",218, 0)
  4082    . D VICR^ PXPXRM(PXD AS,.PXDATA )
  4083   "RTN","PXA PIIM",219, 0)
  4084    . S PXX=$ G(PXDATA(" VISIT"))
  4085   "RTN","PXA PIIM",220, 0)
  4086    . S PXX=P XX_U_$P($G (PXDATA("C ONTRA/REFU SAL")),U,1 )_"|"_$P($ G(PXDATA(" CONTRA/REF USAL")),U, 2)
  4087   "RTN","PXA PIIM",221, 0)
  4088    . S PXX=P XX_U_$P($G (PXDATA("I MMUN")),U, 1)_"|"_$P( $G(PXDATA( "IMMUN")), U,2)
  4089   "RTN","PXA PIIM",222, 0)
  4090    . S PXX=P XX_U_$G(PX DATA("WARN  UNTIL DAT E"))
  4091   "RTN","PXA PIIM",223, 0)
  4092    . S PXX=P XX_U_$G(PX DATA("D/T  RECORDED") )
  4093   "RTN","PXA PIIM",224, 0)
  4094    . S PXX=P XX_U_$G(PX DATA("EVEN T D/T"))
  4095   "RTN","PXA PIIM",225, 0)
  4096    . S PXX=P XX_U_$P($G (PXDATA("E NC PROVIDE R")),U,1)_ "|"_$P($G( PXDATA("EN C PROVIDER ")),U,2)
  4097   "RTN","PXA PIIM",226, 0)
  4098    . S PXRES ULT(PXDAS) =PXX
  4099   "RTN","PXA PIIM",227, 0)
  4100    . S PXRES ULT(PXDAS, "COMMENTS" )=$G(PXDAT A("COMMENT S"))
  4101   "RTN","PXA PIIM",228, 0)
  4102    ;
  4103   "RTN","PXA PIIM",229, 0)
  4104    Q
  4105   "RTN","PXA PIIM",230, 0)
  4106    ;
  4107   "RTN","PXA PIIM",231, 0)
  4108   SEARCH(PXR ESULT,PXSU B,PXBDT,PX EDT) ; Hel per functi on for PAT ICR
  4109   "RTN","PXA PIIM",232, 0)
  4110    ;
  4111   "RTN","PXA PIIM",233, 0)
  4112    N PXDAS,P XSTART,PXS TOP
  4113   "RTN","PXA PIIM",234, 0)
  4114    ;
  4115   "RTN","PXA PIIM",235, 0)
  4116    S PXSTART =0
  4117   "RTN","PXA PIIM",236, 0)
  4118    F  S PXST ART=$O(^PX RMINDX(PXS UB(1),PXSU B(2),PXSUB (3),PXSUB( 4),PXSUB(5 ),PXSTART) ) Q:'PXSTA RT!(PXEDT< PXSTART)   D
  4119   "RTN","PXA PIIM",237, 0)
  4120    . S PXSTO P=PXBDT
  4121   "RTN","PXA PIIM",238, 0)
  4122    . F  S PX STOP=$O(^P XRMINDX(PX SUB(1),PXS UB(2),PXSU B(3),PXSUB (4),PXSUB( 5),PXSTART ,PXSTOP))  Q:'PXSTOP   D
  4123   "RTN","PXA PIIM",239, 0)
  4124    . . S PXD AS=0
  4125   "RTN","PXA PIIM",240, 0)
  4126    . . F  S  PXDAS=$O(^ PXRMINDX(P XSUB(1),PX SUB(2),PXS UB(3),PXSU B(4),PXSUB (5),PXSTAR T,PXSTOP,P XDAS)) Q:' PXDAS  D
  4127   "RTN","PXA PIIM",241, 0)
  4128    . . . S P XRESULT(PX DAS)=""
  4129   "RTN","PXA PIIM",242, 0)
  4130    ;
  4131   "RTN","PXA PIIM",243, 0)
  4132    Q
  4133   "RTN","PXA PIIM",244, 0)
  4134    ;
  4135   "RTN","PXA PIIM",245, 0)
  4136   SITES(PXRS LT,PXROUTE ,PXSORTBY)  ;
  4137   "RTN","PXA PIIM",246, 0)
  4138    ;
  4139   "RTN","PXA PIIM",247, 0)
  4140    ;Returns  list of se lectable S ites for a  given Rou te
  4141   "RTN","PXA PIIM",248, 0)
  4142    ;
  4143   "RTN","PXA PIIM",249, 0)
  4144    ;Input:
  4145   "RTN","PXA PIIM",250, 0)
  4146    ;   PXROU TE - (requ ired) Poin ter to #92 0.2
  4147   "RTN","PXA PIIM",251, 0)
  4148    ;  PXSORT BY - (opti onal; defa ults to "N ")
  4149   "RTN","PXA PIIM",252, 0)
  4150    ;                  " N" - Sort  by Name
  4151   "RTN","PXA PIIM",253, 0)
  4152    ;                  " R" - Sort  by IEN
  4153   "RTN","PXA PIIM",254, 0)
  4154    ;
  4155   "RTN","PXA PIIM",255, 0)
  4156    ;Returns:
  4157   "RTN","PXA PIIM",256, 0)
  4158    ; - If on ly a subse t of sites  are selec table for  this route ,
  4159   "RTN","PXA PIIM",257, 0)
  4160    ;   that  list will  be returne d in PXRSL T.
  4161   "RTN","PXA PIIM",258, 0)
  4162    ;    o If  PXSORTBY= "N" - PXRS LT(Site_Na me)=920_3_ IEN ^ HL7  Code
  4163   "RTN","PXA PIIM",259, 0)
  4164    ;    o If  PXSORTBY= "R" - PXRS LT(920_3_I EN)=Site_N ame ^ HL7  Code
  4165   "RTN","PXA PIIM",260, 0)
  4166    ; - If al l sites ar e selectab le for thi s route, t he API wil l return:
  4167   "RTN","PXA PIIM",261, 0)
  4168    ;   PXRSL T("ALL")=" "
  4169   "RTN","PXA PIIM",262, 0)
  4170    ; - If no  sites are  selectabl e for this  route, th e API will  return:
  4171   "RTN","PXA PIIM",263, 0)
  4172    ;   PXRSL T("NONE")= ""
  4173   "RTN","PXA PIIM",264, 0)
  4174    ;
  4175   "RTN","PXA PIIM",265, 0)
  4176    N PXI,PXS ITE,PXSITE HL,PXSITEN M
  4177   "RTN","PXA PIIM",266, 0)
  4178    ;
  4179   "RTN","PXA PIIM",267, 0)
  4180    I '$G(PXR OUTE) Q
  4181   "RTN","PXA PIIM",268, 0)
  4182    I '$D(^PX V(920.2,PX ROUTE,0))  Q
  4183   "RTN","PXA PIIM",269, 0)
  4184    I $G(PXSO RTBY)'?1(1 "N",1"R")  S PXSORTBY ="N"
  4185   "RTN","PXA PIIM",270, 0)
  4186    ;
  4187   "RTN","PXA PIIM",271, 0)
  4188    I $D(^PXV (920.6,PXR OUTE)) D
  4189   "RTN","PXA PIIM",272, 0)
  4190    . S PXI=0
  4191   "RTN","PXA PIIM",273, 0)
  4192    . F  S PX I=$O(^PXV( 920.6,PXRO UTE,1,PXI) ) Q:'PXI   D
  4193   "RTN","PXA PIIM",274, 0)
  4194    . . S PXS ITE=$P($G( ^PXV(920.6 ,PXROUTE,1 ,PXI,0)),U ,1)
  4195   "RTN","PXA PIIM",275, 0)
  4196    . . S PXS ITENM=$P($ G(^PXV(920 .3,+PXSITE ,0)),U,1)
  4197   "RTN","PXA PIIM",276, 0)
  4198    . . S PXS ITEHL=$P($ G(^PXV(920 .3,PXSITE, 0)),U,2)
  4199   "RTN","PXA PIIM",277, 0)
  4200    . . I PXS ITENM="" Q
  4201   "RTN","PXA PIIM",278, 0)
  4202    . . I PXS ORTBY="N"  S PXRSLT(P XSITENM)=P XSITE_U_PX SITEHL
  4203   "RTN","PXA PIIM",279, 0)
  4204    . . I PXS ORTBY="R"  S PXRSLT(P XSITE)=PXS ITENM_U_PX SITEHL
  4205   "RTN","PXA PIIM",280, 0)
  4206    . ;
  4207   "RTN","PXA PIIM",281, 0)
  4208    . ; if th is route e xists in 9 20.6, but  is not map ped to any  sites
  4209   "RTN","PXA PIIM",282, 0)
  4210    . ; then  no sites s hould be s electable  for this r oute (e.g. , Oral)
  4211   "RTN","PXA PIIM",283, 0)
  4212    . I '$D(P XRSLT) S P XRSLT("NON E")=""
  4213   "RTN","PXA PIIM",284, 0)
  4214    ;
  4215   "RTN","PXA PIIM",285, 0)
  4216    ; If no m apping exi sts, all e ntries are  selectabl e
  4217   "RTN","PXA PIIM",286, 0)
  4218    I '$D(^PX V(920.6,PX ROUTE)) D
  4219   "RTN","PXA PIIM",287, 0)
  4220    . S PXRSL T("ALL")=" "
  4221   "RTN","PXA PIIM",288, 0)
  4222    ;
  4223   "RTN","PXA PIIM",289, 0)
  4224    Q
  4225   "RTN","PXA PIIM",290, 0)
  4226    ;
  4227   "RTN","PXA PIIM",291, 0)
  4228   IMMDEF(PXR SLT,PXIMM, PXINST) ;
  4229   "RTN","PXA PIIM",292, 0)
  4230    ;
  4231   "RTN","PXA PIIM",293, 0)
  4232    N PXIEN,P XPRNT,PXST A
  4233   "RTN","PXA PIIM",294, 0)
  4234    ;
  4235   "RTN","PXA PIIM",295, 0)
  4236    I '$G(PXI MM)!('$G(P XINST)) Q
  4237   "RTN","PXA PIIM",296, 0)
  4238    I $D(PXIN ST(PXINST) ) Q  ; Use d to preve nt infinit e recursio n
  4239   "RTN","PXA PIIM",297, 0)
  4240    ;
  4241   "RTN","PXA PIIM",298, 0)
  4242    S PXIEN=$ O(^PXV(920 .05,"AC",P XINST,PXIM M,0))
  4243   "RTN","PXA PIIM",299, 0)
  4244    ;
  4245   "RTN","PXA PIIM",300, 0)
  4246    I PXIEN D   Q
  4247   "RTN","PXA PIIM",301, 0)
  4248    . M PXRSL T=^PXV(920 .05,PXIEN, 1,PXIMM)
  4249   "RTN","PXA PIIM",302, 0)
  4250    ;
  4251   "RTN","PXA PIIM",303, 0)
  4252    ; If site  did not c reate defa ults, make  recursive
  4253   "RTN","PXA PIIM",304, 0)
  4254    ; call fo r parent I nstitution ; if paren t has defa ults,
  4255   "RTN","PXA PIIM",305, 0)
  4256    ; inherit  from pare nt.
  4257   "RTN","PXA PIIM",306, 0)
  4258    I 'PXIEN  D  Q
  4259   "RTN","PXA PIIM",307, 0)
  4260    . S PXSTA =$$STA^XUA F4(PXINST)
  4261   "RTN","PXA PIIM",308, 0)
  4262    . I PXSTA ="" Q
  4263   "RTN","PXA PIIM",309, 0)
  4264    . S PXPRN T=$$PRNT^X UAF4(PXSTA )
  4265   "RTN","PXA PIIM",310, 0)
  4266    . ;
  4267   "RTN","PXA PIIM",311, 0)
  4268    . ; If pa rent = sel f, we reac hed the to p of the c hain
  4269   "RTN","PXA PIIM",312, 0)
  4270    . I $P(PX PRNT,U,2)= PXSTA Q
  4271   "RTN","PXA PIIM",313, 0)
  4272    . I (+PXP RNT)=PXINS T Q
  4273   "RTN","PXA PIIM",314, 0)
  4274    . I 'PXPR NT Q
  4275   "RTN","PXA PIIM",315, 0)
  4276    . ;
  4277   "RTN","PXA PIIM",316, 0)
  4278    . ; Used  to prevent  infinite  recursion
  4279   "RTN","PXA PIIM",317, 0)
  4280    . S PXINS T(PXINST)= ""
  4281   "RTN","PXA PIIM",318, 0)
  4282    . ;
  4283   "RTN","PXA PIIM",319, 0)
  4284    . S PXINS T=+PXPRNT
  4285   "RTN","PXA PIIM",320, 0)
  4286    . D IMMDE F(.PXRSLT, PXIMM,.PXI NST)
  4287   "RTN","PXA PIIM",321, 0)
  4288    ;
  4289   "RTN","PXA PIIM",322, 0)
  4290    Q
  4291   "RTN","PXC EAE")
  4292   0^11^B3310 9650^B3286 7509
  4293   "RTN","PXC EAE",1,0)
  4294   PXCEAE ;IS L/dee,ISA/ KWP - Main  routine f or the Lis t Manager  display of  a visit a nd related  v-files ; 11/17/2015
  4295   "RTN","PXC EAE",2,0)
  4296    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**37,6 7,99,147,1 56,172,195 ,215**;Aug  12, 1996; Build 10
  4297   "RTN","PXC EAE",3,0)
  4298    ;; ;
  4299   "RTN","PXC EAE",4,0)
  4300    Q
  4301   "RTN","PXC EAE",5,0)
  4302   EN ;+ -- m ain entry  point for  PXCE DISPL AY VISIT
  4303   "RTN","PXC EAE",6,0)
  4304    Q:$G(PXCE VIEN)'>0
  4305   "RTN","PXC EAE",7,0)
  4306    ;The sele ction list  for the A ICS' packa ge interfa ce used in  help mess ages
  4307   "RTN","PXC EAE",8,0)
  4308    N PXCEHLS T
  4309   "RTN","PXC EAE",9,0)
  4310    ;
  4311   "RTN","PXC EAE",10,0)
  4312    N PXCEAEV W S PXCEAE VW="B"
  4313   "RTN","PXC EAE",11,0)
  4314    N PXCEVDE L S PXCEVD EL=0
  4315   "RTN","PXC EAE",12,0)
  4316    ;
  4317   "RTN","PXC EAE",13,0)
  4318    I '$D(PXC EPAT) N PX CEPAT D
  4319   "RTN","PXC EAE",14,0)
  4320    . S PXCEP AT=$P($G(^ AUPNVSIT(P XCEVIEN,0) ),"^",5)
  4321   "RTN","PXC EAE",15,0)
  4322    ; next 3  lines PX*1 .0*172
  4323   "RTN","PXC EAE",16,0)
  4324    N PXREC,P XPTSSN,PXD UZ S PXDUZ =DUZ,PXPTS SN=$P($G(^ DPT(PXCEPA T,0)),U,9)
  4325   "RTN","PXC EAE",17,0)
  4326    D SEC^PXC EEXP(.PXRE C,PXDUZ,PX PTSSN)
  4327   "RTN","PXC EAE",18,0)
  4328    I PXREC W  !!,"Secur ity regula tions proh ibit compu ter access  to your o wn medical  record."  H 3 Q
  4329   "RTN","PXC EAE",19,0)
  4330    S PXCECAT ="AEP" D P ATINFO^PXC EPAT(.PXCE PAT) K PXC ECAT
  4331   "RTN","PXC EAE",20,0)
  4332    ;
  4333   "RTN","PXC EAE",21,0)
  4334    I '$D(PXC EHLOC) N P XCEHLOC S  PXCEHLOC=$ P($G(^AUPN VSIT(PXCEV IEN,0)),"^ ",22)
  4335   "RTN","PXC EAE",22,0)
  4336    ;Get Visi t date/tim e if exist s - PX*195
  4337   "RTN","PXC EAE",23,0)
  4338    I '$D(PXC EAPDT) N P XCEAPDT S  PXCEAPDT=$ P($G(^AUPN VSIT(PXCEV IEN,0)),"^ ")
  4339   "RTN","PXC EAE",24,0)
  4340    ;+If not  called fro m encounte r viewer l ock ^PXLCK USR
  4341   "RTN","PXC EAE",25,0)
  4342    ;+and cre ate ^XTMP( "PXLCKUSR" ,VISIEN)=D UZ
  4343   "RTN","PXC EAE",26,0)
  4344    I PXCEKEY S'["V" D
  4345   "RTN","PXC EAE",27,0)
  4346    .N PXRESV AL,PXVISIE N,PXMSG,PX USR
  4347   "RTN","PXC EAE",28,0)
  4348    .S PXMSG= "",PXVISIE N=PXCEVIEN
  4349   "RTN","PXC EAE",29,0)
  4350    .I $D(^XT MP("PXLCKU SR",PXVISI EN)) S PXU SR=$G(^VA( 200,^XTMP( "PXLCKUSR" ,PXVISIEN) ,0)),PXUSR =$S(PXUSR= "":"Unknow n",1:$P(PX USR,"^")), PXMSG="Enc ounter Loc ked by "_P XUSR
  4351   "RTN","PXC EAE",30,0)
  4352    .S PXRESV AL=$$LOCK^ PXUALOCK(" ^PXLCKUSR( "_PXVISIEN _")",5,0,P XMSG,0)
  4353   "RTN","PXC EAE",31,0)
  4354    .I 'PXRES VAL Q
  4355   "RTN","PXC EAE",32,0)
  4356    .S PXRESV AL=$$CREAT E^PXUAXTMP ("PXLCKUSR ",PXVISIEN ,365,"PCE  Encounter  Lock",DUZ)
  4357   "RTN","PXC EAE",33,0)
  4358    .I 'PXRES VAL D UNLO CK^PXUALOC K("^PXLCKU SR("_PXVIS IEN_")") Q
  4359   "RTN","PXC EAE",34,0)
  4360    .D EN^VAL M("PXCE AD D/EDIT MEN U")
  4361   "RTN","PXC EAE",35,0)
  4362    .D UNLOCK ^PXUALOCK( "^PXLCKUSR ("_PXVISIE N_")"),DEL ETE^PXUAXT MP("PXLCKU SR",PXVISI EN)
  4363   "RTN","PXC EAE",36,0)
  4364    I PXCEKEY S["V",$D(^ TMP("VALM  DATA",$J,V ALMEVL,"EX P")),^("EX P")]"" X ^ ("EXP")
  4365   "RTN","PXC EAE",37,0)
  4366    Q
  4367   "RTN","PXC EAE",38,0)
  4368    ;
  4369   "RTN","PXC EAE",39,0)
  4370   GETVIEN ;A sk the use r which vi sit.
  4371   "RTN","PXC EAE",40,0)
  4372    N PXCEVID X
  4373   "RTN","PXC EAE",41,0)
  4374    S PXCEVID X=+$P(XQOR NOD(0),"^" ,3)
  4375   "RTN","PXC EAE",42,0)
  4376    S:PXCEVID X'>0 PXCEV IDX=$$SEL1 ^PXCE("")
  4377   "RTN","PXC EAE",43,0)
  4378    Q:PXCEVID X'>0
  4379   "RTN","PXC EAE",44,0)
  4380    S PXCEVIE N=$G(^TMP( "PXCEIDX", $J,PXCEVID X))
  4381   "RTN","PXC EAE",45,0)
  4382    ;Check th at it is n ot related  to a no s how or can celed appp ointment
  4383   "RTN","PXC EAE",46,0)
  4384    D APPCHEC K^PXCESDAM (.PXCEVIEN )
  4385   "RTN","PXC EAE",47,0)
  4386    Q:'$D(PXC EVIEN)
  4387   "RTN","PXC EAE",48,0)
  4388    ;Cannot e dit future  visits
  4389   "RTN","PXC EAE",49,0)
  4390    I $P(+^AU PNVSIT(PXC EVIEN,0)," .")>DT D   Q
  4391   "RTN","PXC EAE",50,0)
  4392    . W !!,$C (7),"Can n ot update  future enc ounters."
  4393   "RTN","PXC EAE",51,0)
  4394    . D WAIT^ PXCEHELP
  4395   "RTN","PXC EAE",52,0)
  4396    . K PXCEV IEN
  4397   "RTN","PXC EAE",53,0)
  4398    ;Check if  the visit  can be as sociated w ith an app ointment.
  4399   "RTN","PXC EAE",54,0)
  4400    S PXCEAPP M=$G(^DPT( $P(^AUPNVS IT(PXCEVIE N,0),"^",5 ),"S",+^AU PNVSIT(PXC EVIEN,0),0 ))
  4401   "RTN","PXC EAE",55,0)
  4402    I $P(PXCE VIEN,"^",7 )="E" D  I  'Y K PXCE VIEN Q
  4403   "RTN","PXC EAE",56,0)
  4404    . W !!,"T his is a h istorical  encounter  for docume nting a cl inical enc ounter onl y"
  4405   "RTN","PXC EAE",57,0)
  4406    . W !,"an d will not  be used b y Scheduli ng, Billin g or Workl oad credit ."
  4407   "RTN","PXC EAE",58,0)
  4408    . D PAUSE ^PXCEHELP
  4409   "RTN","PXC EAE",59,0)
  4410    Q
  4411   "RTN","PXC EAE",60,0)
  4412    ;
  4413   "RTN","PXC EAE",61,0)
  4414   HDR ; -- h eader code
  4415   "RTN","PXC EAE",62,0)
  4416    I '$D(^AU PNVSIT(PXC EVIEN,0))  S VALMQUIT =1 Q
  4417   "RTN","PXC EAE",63,0)
  4418    K VALMHDR
  4419   "RTN","PXC EAE",64,0)
  4420    N VISIT0
  4421   "RTN","PXC EAE",65,0)
  4422    ;
  4423   "RTN","PXC EAE",66,0)
  4424    ;PATIENT
  4425   "RTN","PXC EAE",67,0)
  4426    S VISIT0= ^AUPNVSIT( PXCEVIEN,0 )
  4427   "RTN","PXC EAE",68,0)
  4428    S VALMHDR (1)=$E(PXC EPAT("NAME "),1,26)
  4429   "RTN","PXC EAE",69,0)
  4430    S VALMHDR (1)=$E(VAL MHDR(1)_$E ("    ",1, (27-$L(VAL MHDR(1)))) _PXCEPAT(" SSN")_"                                                ",1,40)
  4431   "RTN","PXC EAE",70,0)
  4432    S VALMHDR (1)=VALMHD R(1)_"Clin ic:  "_$S( $P(VISIT0, "^",22)>0: $P(^SC($P( VISIT0,"^" ,22),0),"^ "),1:"")
  4433   "RTN","PXC EAE",71,0)
  4434    ;
  4435   "RTN","PXC EAE",72,0)
  4436    ;DATE
  4437   "RTN","PXC EAE",73,0)
  4438    S VALMHDR (2)=$E("En counter Da te  "_$S($ P(VISIT0," ^",1)>0:$$ DATE^PXCED ATE($P(VIS IT0,"^",1) ),1:"")_"                                                ",1,40)
  4439   "RTN","PXC EAE",74,0)
  4440    S VALMHDR (2)=VALMHD R(2)_"Clin ic Stop:   "_$S($P(VI SIT0,"^",8 )>0:$$DISP LY08^PXCEC STP($P(VIS IT0,"^",8) ),1:"")
  4441   "RTN","PXC EAE",75,0)
  4442    ;
  4443   "RTN","PXC EAE",76,0)
  4444    S VALMSG= "+ Next Sc reen   - P rev Screen    ?? More  Actions"
  4445   "RTN","PXC EAE",77,0)
  4446    ;
  4447   "RTN","PXC EAE",78,0)
  4448    Q
  4449   "RTN","PXC EAE",79,0)
  4450    ;
  4451   "RTN","PXC EAE",80,0)
  4452   KEYS(PXCEP ROT,PXCEEN D) ;Set up  ^XQORM("K EY") array  so that c an edit an  item by h aving its
  4453   "RTN","PXC EAE",81,0)
  4454    ;  number  be and ac tion to ed it it.
  4455   "RTN","PXC EAE",82,0)
  4456    N PXCEPIE N,PXCEINDX
  4457   "RTN","PXC EAE",83,0)
  4458    S PXCEPIE N=$O(^ORD( 101,"B",PX CEPROT,0)) _"^1"
  4459   "RTN","PXC EAE",84,0)
  4460    F PXCEIND X=1:1:PXCE END S XQOR M("KEY",PX CEINDX)=PX CEPIEN
  4461   "RTN","PXC EAE",85,0)
  4462    ;
  4463   "RTN","PXC EAE",86,0)
  4464    Q
  4465   "RTN","PXC EAE",87,0)
  4466    ;
  4467   "RTN","PXC EAE",88,0)
  4468   INIT ; --  init varia bles and l ist array
  4469   "RTN","PXC EAE",89,0)
  4470    D BUILD^P XCEAE1(PXC EVIEN,PXCE AEVW,"^TMP (""PXCEAE" ",$J)","^T MP(""PXCEA EIX"",$J)" )
  4471   "RTN","PXC EAE",90,0)
  4472    I '$D(VAL MBCK) K VA LMHDR S VA LMBCK="R"
  4473   "RTN","PXC EAE",91,0)
  4474    Q
  4475   "RTN","PXC EAE",92,0)
  4476    ;
  4477   "RTN","PXC EAE",93,0)
  4478   HELP ; --  help code
  4479   "RTN","PXC EAE",94,0)
  4480    S X="?" D  DISP^XQOR M1 W !!
  4481   "RTN","PXC EAE",95,0)
  4482    Q
  4483   "RTN","PXC EAE",96,0)
  4484    ;
  4485   "RTN","PXC EAE",97,0)
  4486   EXIT ; --  exit code
  4487   "RTN","PXC EAE",98,0)
  4488    ;
  4489   "RTN","PXC EAE",99,0)
  4490    ;Check fo r incomple te ENCOUNT ER if not  already re moved.
  4491   "RTN","PXC EAE",100,0 )
  4492    N PXQUIT
  4493   "RTN","PXC EAE",101,0 )
  4494    S PXQUIT= 1
  4495   "RTN","PXC EAE",102,0 )
  4496    D:'$G(PXC EEXIT) CHE CK^PXCEVFI 5
  4497   "RTN","PXC EAE",103,0 )
  4498    ;
  4499   "RTN","PXC EAE",104,0 )
  4500    D CLEAN^V ALM10
  4501   "RTN","PXC EAE",105,0 )
  4502    K ^TMP("P XCEAE",$J) ,^TMP("PXC EAEIX",$J)
  4503   "RTN","PXC EAE",106,0 )
  4504    D EVENT^P XKMAIN
  4505   "RTN","PXC EAE",107,0 )
  4506    K PXCEVIE N,PXCEAPPM
  4507   "RTN","PXC EAE",108,0 )
  4508    Q
  4509   "RTN","PXC EAE",109,0 )
  4510    ;
  4511   "RTN","PXC EAE",110,0 )
  4512   EXPND ; --  expand co de
  4513   "RTN","PXC EAE",111,0 )
  4514    S PXCEAEV W=$S(PXCEA EVW="B":"D ",1:"B")
  4515   "RTN","PXC EAE",112,0 )
  4516    D BUILD^P XCEAE1(PXC EVIEN,PXCE AEVW,"^TMP (""PXCEAE" ",$J)","^T MP(""PXCEA EIX"",$J)" )
  4517   "RTN","PXC EAE",113,0 )
  4518    D DONE^PX CE
  4519   "RTN","PXC EAE",114,0 )
  4520    Q
  4521   "RTN","PXC EAE",115,0 )
  4522    ;
  4523   "RTN","PXC EAE",116,0 )
  4524   EDIT ; --  edit a V-F ile entry
  4525   "RTN","PXC EAE",117,0 )
  4526    N PXCEFID X
  4527   "RTN","PXC EAE",118,0 )
  4528    S PXCEFID X=+$P(XQOR NOD(0),"^" ,3)
  4529   "RTN","PXC EAE",119,0 )
  4530    D DOMANY( PXCEFIDX," E","EN^PXC EVFIL(PXCE CAT)")
  4531   "RTN","PXC EAE",120,0 )
  4532    Q
  4533   "RTN","PXC EAE",121,0 )
  4534    ;
  4535   "RTN","PXC EAE",122,0 )
  4536   DEL ; -- d elete a V- File entri es
  4537   "RTN","PXC EAE",123,0 )
  4538    I PXCEKEY S'["D",PXC EKEYS'["d"  W !!!,$C( 7),"Error:  You do no t have del ete access ." D WAIT^ PXCEHELP Q
  4539   "RTN","PXC EAE",124,0 )
  4540    D DOMANY( 0,"D","DEL ^PXCEVFI2( PXCECAT)")
  4541   "RTN","PXC EAE",125,0 )
  4542    Q
  4543   "RTN","PXC EAE",126,0 )
  4544    ;
  4545   "RTN","PXC EAE",127,0 )
  4546   DOMANY(PXC EFIDX,WHAT DO,WHATTOD O) ;Proces s one or m ore V-File  entries
  4547   "RTN","PXC EAE",128,0 )
  4548    ;WHATDO i s E for ed it and D f or delete
  4549   "RTN","PXC EAE",129,0 )
  4550    ;WHATTODO  is the ro utine to c all
  4551   "RTN","PXC EAE",130,0 )
  4552    ;
  4553   "RTN","PXC EAE",131,0 )
  4554    I WHATDO= "D" N PXCE DELV S PXC EDELV=0
  4555   "RTN","PXC EAE",132,0 )
  4556    D FULL^VA LM1
  4557   "RTN","PXC EAE",133,0 )
  4558    I WHATDO= "E" D
  4559   "RTN","PXC EAE",134,0 )
  4560    . S:PXCEF IDX'>0 PXC EFIDX=$$SE L^PXCEAE2( "Edit",1)
  4561   "RTN","PXC EAE",135,0 )
  4562    E  I WHAT DO="D" D
  4563   "RTN","PXC EAE",136,0 )
  4564    . S:PXCEF IDX'>0 PXC EFIDX=$$SE L^PXCEAE2( "Delete",2 )
  4565   "RTN","PXC EAE",137,0 )
  4566    E  W "??" ,$C(7) Q
  4567   "RTN","PXC EAE",138,0 )
  4568    Q:+PXCEFI DX'>0
  4569   "RTN","PXC EAE",139,0 )
  4570    N PXCEIND X,PXCEFIX1 ,PXCEFIX2
  4571   "RTN","PXC EAE",140,0 )
  4572    F PXCEIND X=1:1 S PX CEFIX1=$P( PXCEFIDX," ,",PXCEIND X) Q:PXCEF IX1']""  D
  4573   "RTN","PXC EAE",141,0 )
  4574    . I $L(PX CEFIX1,"-" )=1 D
  4575   "RTN","PXC EAE",142,0 )
  4576    .. I WHAT DO="D",PXC EFIX1=1 S  PXCEDELV=1
  4577   "RTN","PXC EAE",143,0 )
  4578    .. E  D D O1(PXCEFIX 1,WHATDO,W HATTODO)
  4579   "RTN","PXC EAE",144,0 )
  4580    . E  F PX CEFIX2=$P( PXCEFIX1," -",1):1:$P (PXCEFIX1, "-",2) D
  4581   "RTN","PXC EAE",145,0 )
  4582    .. I WHAT DO="D",PXC EFIX2=1 S  PXCEDELV=1
  4583   "RTN","PXC EAE",146,0 )
  4584    .. E  D D O1(PXCEFIX 2,WHATDO,W HATTODO)
  4585   "RTN","PXC EAE",147,0 )
  4586    I WHATDO= "D",PXCEDE LV D DO1(1 ,WHATDO,WH ATTODO)
  4587   "RTN","PXC EAE",148,0 )
  4588    D INIT
  4589   "RTN","PXC EAE",149,0 )
  4590    Q
  4591   "RTN","PXC EAE",150,0 )
  4592    ;
  4593   "RTN","PXC EAE",151,0 )
  4594   DO1(PXCEFI DX,WHATDO, WHATTODO)  ;Process o ne V-File  entry
  4595   "RTN","PXC EAE",152,0 )
  4596    ;PXCEFIDX  is and in dex into ^ TMP("PXCEA EIX",$J, w hich tells  the V-Fil e
  4597   "RTN","PXC EAE",153,0 )
  4598    ;  and th e IEN to p rocess
  4599   "RTN","PXC EAE",154,0 )
  4600    ;WHATDO i s E for ed it and D f or delete
  4601   "RTN","PXC EAE",155,0 )
  4602    ;WHATTODO  is the ro utine to c all
  4603   "RTN","PXC EAE",156,0 )
  4604    ;
  4605   "RTN","PXC EAE",157,0 )
  4606    N PXCEONE ,PXCECAT,P XCEFIEN
  4607   "RTN","PXC EAE",158,0 )
  4608    S PXCEONE =$G(^TMP(" PXCEAEIX", $J,PXCEFID X))
  4609   "RTN","PXC EAE",159,0 )
  4610    S PXCEFIE N=+PXCEONE
  4611   "RTN","PXC EAE",160,0 )
  4612    S PXCECAT =$P(PXCEON E,"^",2)
  4613   "RTN","PXC EAE",161,0 )
  4614    I PXCECAT ="CSTP",WH ATDO="E" W  !!!,$C(7) ,"You cann ot edit st op codes."  S PXCENOE R=1 D WAIT ^PXCEHELP  Q
  4615   "RTN","PXC EAE",162,0 )
  4616    I PXCECAT ="VST",$P( ^AUPNVSIT( PXCEFIEN,0 ),"^",7)=" E" S PXCEC AT="HIST"
  4617   "RTN","PXC EAE",163,0 )
  4618    D @$S("~V ST~HIST~CS TP~CPT~IMM ~PED~POV~P RV~SK~TRT~ HF~XAM~ICR ~"[("~"_PX CECAT_"~") :WHATTODO, 1:"QUIT")  ; PX*1*215
  4619   "RTN","PXC EAE",164,0 )
  4620    Q
  4621   "RTN","PXC EAE",165,0 )
  4622    ;
  4623   "RTN","PXC EAE",166,0 )
  4624   QUIT Q
  4625   "RTN","PXC EAE",167,0 )
  4626    ;
  4627   "RTN","PXC EAE1")
  4628   0^12^B2926 2597^B2916 8014
  4629   "RTN","PXC EAE1",1,0)
  4630   PXCEAE1 ;I SL/dee,ISA /KWP,SLC/a jb - Build s the List  Manager d isplay of  a visit an d related  v-files ;1 1/16/2015
  4631   "RTN","PXC EAE1",2,0)
  4632    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**22,7 3,199,201, 210,215**; Aug 12, 19 96;Build 1 0
  4633   "RTN","PXC EAE1",3,0)
  4634    ;; ;
  4635   "RTN","PXC EAE1",4,0)
  4636    Q
  4637   "RTN","PXC EAE1",5,0)
  4638    ;
  4639   "RTN","PXC EAE1",6,0)
  4640   BUILD(VISI TIEN,AEVIE W,ARRAY,AR RAYIX) ;
  4641   "RTN","PXC EAE1",7,0)
  4642    ;AEVIEW i s "B" for  brief disp lay and "D " for expa nded displ ay.
  4643   "RTN","PXC EAE1",8,0)
  4644    I '$D(^AU PNVSIT(VIS ITIEN)) S  VALMBCK="Q " Q
  4645   "RTN","PXC EAE1",9,0)
  4646    N PXCECNT
  4647   "RTN","PXC EAE1",10,0 )
  4648    D FULL^VA LM1
  4649   "RTN","PXC EAE1",11,0 )
  4650    D CLEAN^V ALM10
  4651   "RTN","PXC EAE1",12,0 )
  4652    K @ARRAYI X
  4653   "RTN","PXC EAE1",13,0 )
  4654    S (VALMCN T,PXCECNT) =0
  4655   "RTN","PXC EAE1",14,0 )
  4656    ;
  4657   "RTN","PXC EAE1",15,0 )
  4658    ;
  4659   "RTN","PXC EAE1",16,0 )
  4660    N IEN,FIL E,VFILE,VR OUTINE
  4661   "RTN","PXC EAE1",17,0 )
  4662    F FILE="S IT","CSTP" ,"PRV","PO V","CPT"," TRT","IMM" ,"PED","SK ","HF","XA M","ICR" D   ; PX*1*2 15
  4663   "RTN","PXC EAE1",18,0 )
  4664    . S VROUT INE="PXCE" _$S(FILE=" IMM":"VIMM ",1:FILE)
  4665   "RTN","PXC EAE1",19,0 )
  4666    . S VFILE =$P($T(FOR MAT^@VROUT INE),"~",5 )
  4667   "RTN","PXC EAE1",20,0 )
  4668    . I FILE= "SIT" D
  4669   "RTN","PXC EAE1",21,0 )
  4670    .. S IEN= VISITIEN
  4671   "RTN","PXC EAE1",22,0 )
  4672    .. D AFIL E(IEN,FILE ,VFILE,VRO UTINE,ARRA Y,ARRAYIX, .VALMCNT,. PXCECNT,AE VIEW)
  4673   "RTN","PXC EAE1",23,0 )
  4674    .. S VALM CNT=VALMCN T+1
  4675   "RTN","PXC EAE1",24,0 )
  4676    .. S @ARR AY@(VALMCN T,0)=""
  4677   "RTN","PXC EAE1",25,0 )
  4678    . E  D
  4679   "RTN","PXC EAE1",26,0 )
  4680    .. S IEN= ""
  4681   "RTN","PXC EAE1",27,0 )
  4682    .. F  S I EN=$O(@VFI LE@("AD",V ISITIEN,IE N)) Q:'IEN   D AFILE( IEN,FILE,V FILE,VROUT INE,ARRAY, ARRAYIX,.V ALMCNT,.PX CECNT,AEVI EW)
  4683   "RTN","PXC EAE1",28,0 )
  4684    S @ARRAYI X@(0)=PXCE CNT
  4685   "RTN","PXC EAE1",29,0 )
  4686    I VALMCNT =0 S VALMB CK="Q"
  4687   "RTN","PXC EAE1",30,0 )
  4688    Q
  4689   "RTN","PXC EAE1",31,0 )
  4690    ;
  4691   "RTN","PXC EAE1",32,0 )
  4692   AFILE(IEN, FILE,VFILE ,VROUTINE, ARRAY,ARRA YIX,VALMCN T,PXCECNT, AEVIEW) ;
  4693   "RTN","PXC EAE1",33,0 )
  4694    N ENTRY,N ODE,NODES, NODECNT
  4695   "RTN","PXC EAE1",34,0 )
  4696    S PXCECNT =PXCECNT+1
  4697   "RTN","PXC EAE1",35,0 )
  4698    S NODES=$ P($T(FORMA T^@VROUTIN E),"~",3)
  4699   "RTN","PXC EAE1",36,0 )
  4700    F NODECNT =1:1 S NOD E=$P(NODES ,",",NODEC NT) Q:NODE ']""  S EN TRY(NODE)= $G(@VFILE@ (IEN,NODE) )
  4701   "RTN","PXC EAE1",37,0 )
  4702    D DISPLAY (.ENTRY,VR OUTINE,ARR AY,ARRAYIX ,.VALMCNT, PXCECNT,AE VIEW)
  4703   "RTN","PXC EAE1",38,0 )
  4704    I FILE="S IT" S @ARR AYIX@(PXCE CNT)=VISIT IEN_"^VST"
  4705   "RTN","PXC EAE1",39,0 )
  4706    E  S @ARR AYIX@(PXCE CNT)=IEN_" ^"_FILE
  4707   "RTN","PXC EAE1",40,0 )
  4708    Q
  4709   "RTN","PXC EAE1",41,0 )
  4710    ;
  4711   "RTN","PXC EAE1",42,0 )
  4712   DISPLAY(EN TRY,PXCECO DE,ARRAY,A RRAYIX,LIN E,COUNT,VI EW) ; -- d isplay the  data
  4713   "RTN","PXC EAE1",43,0 )
  4714    N PXCEFIL E,PXCELINE ,PXCETEXT, PXCEINT,PX CEEXT
  4715   "RTN","PXC EAE1",44,0 )
  4716    S PXCEFIL E=$P($T(FO RMAT^@PXCE CODE),"~", 2)
  4717   "RTN","PXC EAE1",45,0 )
  4718    F PXCELIN E=1:1 S PX CETEXT=$P( $T(FORMAT+ PXCELINE^@ PXCECODE), ";;",2) Q: PXCETEXT'] ""  D
  4719   "RTN","PXC EAE1",46,0 )
  4720    . ; save  original P XCETEXT fo r multiple  diagnosis  ouput ; a jb
  4721   "RTN","PXC EAE1",47,0 )
  4722    . I VFILE ="^AUPNVIM M",+PXCETE XT=3 N TMP TXT S TMPT XT=PXCETEX T ; ajb
  4723   "RTN","PXC EAE1",48,0 )
  4724    . I VFILE ="^AUPNVIM M",+PXCETE XT=2 N TMP TXT S TMPT XT=PXCETEX T ; PX*1*2 10
  4725   "RTN","PXC EAE1",49,0 )
  4726    . S (PXCE EXT,PXCEIN T)=$P(ENTR Y($P(PXCET EXT,"~",1) ),"^",$P(P XCETEXT,"~ ",2))
  4727   "RTN","PXC EAE1",50,0 )
  4728    . ; get e ntries fro m diagnosi s multiple  ; ajb
  4729   "RTN","PXC EAE1",51,0 )
  4730    . I VFILE ="^AUPNVIM M",+PXCETE XT=3 D  S: PXCEINT=""  PXCEINT=" ^" S PXCEE XT=PXCEINT  ; ajb
  4731   "RTN","PXC EAE1",52,0 )
  4732    . . N CNT ,NIEN S (C NT,NIEN)=0  F  S NIEN =$O(^AUPNV IMM(IEN,3, NIEN)) Q:' +NIEN  D   ; ajb
  4733   "RTN","PXC EAE1",53,0 )
  4734    . . . S C NT=CNT+1,$ P(PXCEINT, U,CNT)=$G( ^AUPNVIMM( IEN,3,NIEN ,0)) ; ajb
  4735   "RTN","PXC EAE1",54,0 )
  4736    . ; ajb -  above / P X*1*210 -  below
  4737   "RTN","PXC EAE1",55,0 )
  4738    . ; get e ntries fro m vis offe red/given  to patient  multiple  ; PX*1*210
  4739   "RTN","PXC EAE1",56,0 )
  4740    . I VFILE ="^AUPNVIM M",+PXCETE XT=2 D  S: PXCEINT=""  PXCEINT=" ^" S PXCEE XT=PXCEINT
  4741   "RTN","PXC EAE1",57,0 )
  4742    . . N CNT ,NIEN S (C NT,NIEN)=0  F  S NIEN =$O(^AUPNV IMM(IEN,2, NIEN)) Q:' +NIEN  D
  4743   "RTN","PXC EAE1",58,0 )
  4744    . . . S C NT=CNT+1,$ P(PXCEINT, U,CNT)=$P( $G(^AUPNVI MM(IEN,2,N IEN,0)),"^ ")
  4745   "RTN","PXC EAE1",59,0 )
  4746    . ; PX*1* 210
  4747   "RTN","PXC EAE1",60,0 )
  4748    . I PXCET EXT'["CPT  Modifier", PXCEINT=""  Q  ;Q:PXC EINT=""
  4749   "RTN","PXC EAE1",61,0 )
  4750    . Q:$P(PX CETEXT,"~" ,10)="N"
  4751   "RTN","PXC EAE1",62,0 )
  4752    . I VIEW' ="D",$P(PX CETEXT,"~" ,10)="D" Q
  4753   "RTN","PXC EAE1",63,0 )
  4754    . I PXCEC ODE="PXCEC STP",$P(PX CETEXT,"~" ,3)=.01 Q
  4755   "RTN","PXC EAE1",64,0 )
  4756    . I VFILE ="^AUPNVIM M",+PXCETE XT=2,+PXCE INT D VIS  Q
  4757   "RTN","PXC EAE1",65,0 )
  4758    . I $P(PX CETEXT,"~" ,6)]"" D   Q:PXCEEXT= ""
  4759   "RTN","PXC EAE1",66,0 )
  4760    .. ;I PXC ECODE["CPT ",$P(PXCET EXT,"~",6) ["DNAR" B
  4761   "RTN","PXC EAE1",67,0 )
  4762    .. S @("P XCEEXT="_$ P(PXCETEXT ,"~",6)_"( """_$S($P( PXCETEXT," ~",3)=.01: ENTRY($P(P XCETEXT,"~ ",1)),1:PX CEINT)_""" )")
  4763   "RTN","PXC EAE1",68,0 )
  4764    . E  D
  4765   "RTN","PXC EAE1",69,0 )
  4766    .. N PXCE DILF,DIERR ,PXCEI
  4767   "RTN","PXC EAE1",70,0 )
  4768    .. S PXCE EXT=$$EXTE RNAL^DILFD (PXCEFILE, $P(PXCETEX T,"~",3)," ",PXCEINT, "PXCEDILF" )
  4769   "RTN","PXC EAE1",71,0 )
  4770    .. S PXCE EXT=$S('$D (DIERR):PX CEEXT,1:PX CEINT)
  4771   "RTN","PXC EAE1",72,0 )
  4772    . ; get I CD info fo r multiple  diagnosis  ; ajb
  4773   "RTN","PXC EAE1",73,0 )
  4774    . I VFILE ="^AUPNVIM M",+PXCETE XT=3,+PXCE INT D  ; a jb
  4775   "RTN","PXC EAE1",74,0 )
  4776    . . S PXC EEXT="" ;  ajb
  4777   "RTN","PXC EAE1",75,0 )
  4778    . . N CNT  F CNT=1:1 :$L(PXCEIN T,U) S $P( PXCEEXT,U, CNT)=$$DIS PLY01^PXCE POV($P(PXC EINT,U,CNT )) ; ajb
  4779   "RTN","PXC EAE1",76,0 )
  4780    . N TEMP  S TEMP=PXC EEXT
  4781   "RTN","PXC EAE1",77,0 )
  4782    . N PXI F  PXI=1:1 Q :$P(TEMP," ^",PXI)=""   S PXCEEX T=$P(TEMP, "^",PXI) D  ADDLINE S :+$D(TMPTX T) PXCETEX T=TMPTXT ;  replace m odified wi th origina l for mult iple diagn osis ; ajb
  4783   "RTN","PXC EAE1",78,0 )
  4784    Q
  4785   "RTN","PXC EAE1",79,0 )
  4786   ADDLINE ;
  4787   "RTN","PXC EAE1",80,0 )
  4788    S LINE=LI NE+1
  4789   "RTN","PXC EAE1",81,0 )
  4790    I PXCELIN E=1!(PXCEC ODE="PXCEC STP") S @A RRAY@(LINE ,0)=$J(COU NT,3)_" "
  4791   "RTN","PXC EAE1",82,0 )
  4792    E  S @ARR AY@(LINE,0 )="    "
  4793   "RTN","PXC EAE1",83,0 )
  4794    I $P(PXCE TEXT,"~",5 )["Diagnos is" D
  4795   "RTN","PXC EAE1",84,0 )
  4796    . N PXDAT E,PXACSREC ,PXACS
  4797   "RTN","PXC EAE1",85,0 )
  4798    . S PXDAT E=$S($D(PX CEVIEN)=1: $$CSDATE^P XDXUTL(PXC EVIEN),$D( PXCEAPDT)= 1:PXCEAPDT ,1:DT)
  4799   "RTN","PXC EAE1",86,0 )
  4800    . S PXACS REC=$$ACTD T^PXDXUTL( PXDATE),PX ACS=$P(PXA CSREC,"^", 3)
  4801   "RTN","PXC EAE1",87,0 )
  4802    . I PXACS ["-" S PXA CS=$P(PXAC S,"-",1,2)
  4803   "RTN","PXC EAE1",88,0 )
  4804    . I $P(PX CETEXT,"~" ,5)'["ICD  Code or Di agnosis" D
  4805   "RTN","PXC EAE1",89,0 )
  4806    .. S $P(P XCETEXT,"~ ",5)=$P($P (PXCETEXT, "~",5),"Di agnosis",1 )_PXACS_"  Diagnosis" _$P($P(PXC ETEXT,"~", 5),"Diagno sis",2)
  4807   "RTN","PXC EAE1",90,0 )
  4808    . I $P(PX CETEXT,"~" ,5)["ICD C ode or Dia gnosis" D
  4809   "RTN","PXC EAE1",91,0 )
  4810    .. S $P(P XCETEXT,"~ ",5)=PXACS _$P($P(PXC ETEXT,"~", 5),"ICD",2 )
  4811   "RTN","PXC EAE1",92,0 )
  4812    S @ARRAY@ (LINE,0)=@ ARRAY@(LIN E,0)_$P(PX CETEXT,"~" ,5)
  4813   "RTN","PXC EAE1",93,0 )
  4814    I ($L(@AR RAY@(LINE, 0))+$L(PXC EEXT))'>80  D
  4815   "RTN","PXC EAE1",94,0 )
  4816    . S @ARRA Y@(LINE,0) =@ARRAY@(L INE,0)_PXC EEXT
  4817   "RTN","PXC EAE1",95,0 )
  4818    E  D
  4819   "RTN","PXC EAE1",96,0 )
  4820    . N PXCEW RAP,PXCECO UN,PXCEHEA D
  4821   "RTN","PXC EAE1",97,0 )
  4822    . S PXCEH EAD=$L(@AR RAY@(LINE, 0))
  4823   "RTN","PXC EAE1",98,0 )
  4824    . D WRAP^ PXCEVFI4(P XCEEXT,80- PXCEHEAD,. PXCEWRAP)
  4825   "RTN","PXC EAE1",99,0 )
  4826    . S @ARRA Y@(LINE,0) =@ARRAY@(L INE,0)_$G( PXCEWRAP(1 ))
  4827   "RTN","PXC EAE1",100, 0)
  4828    . S PXCEC OUN=1
  4829   "RTN","PXC EAE1",101, 0)
  4830    . F  S PX CECOUN=$O( PXCEWRAP(P XCECOUN))  Q:PXCECOUN ']""  D
  4831   "RTN","PXC EAE1",102, 0)
  4832    .. S LINE =LINE+1
  4833   "RTN","PXC EAE1",103, 0)
  4834    .. S @ARR AY@(LINE,0 )=$J("",PX CEHEAD)_PX CEWRAP(PXC ECOUN)
  4835   "RTN","PXC EAE1",104, 0)
  4836    Q
  4837   "RTN","PXC EAE1",105, 0)
  4838   VIS ; get  vaccine in formation  statement  info ; adm
  4839   "RTN","PXC EAE1",106, 0)
  4840    S PXCEEXT =""
  4841   "RTN","PXC EAE1",107, 0)
  4842    N CNT F C NT=1:1:$L( PXCEINT,U)  S $P(PXCE EXT,U,CNT) =$$DISPVIS ^PXCEVIS($ P(PXCEINT, U,CNT))
  4843   "RTN","PXC EAE1",108, 0)
  4844    N TEMP S  TEMP=PXCEE XT
  4845   "RTN","PXC EAE1",109, 0)
  4846    N PXI F P XI=1:1 Q:$ P(TEMP,"^" ,PXI)=""   S PXCEEXT= $P(TEMP,"^ ",PXI) D A DDLINE S:+ $D(TMPTXT)  PXCETEXT= TMPTXT
  4847   "RTN","PXC EAE1",110, 0)
  4848    Q
  4849   "RTN","PXC EAE1",111, 0)
  4850    ;
  4851   "RTN","PXC EICR")
  4852   0^13^B1859 3217^n/a
  4853   "RTN","PXC EICR",1,0)
  4854   PXCEICR ;B HM/ADM - E DIT/DISPLA Y CONTRAIN DICATION/R EFUSAL ;02 /01/2016
  4855   "RTN","PXC EICR",2,0)
  4856    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  4857   "RTN","PXC EICR",3,0)
  4858    ;
  4859   "RTN","PXC EICR",4,0)
  4860    Q
  4861   "RTN","PXC EICR",5,0)
  4862    ;
  4863   "RTN","PXC EICR",6,0)
  4864    ;Line wit h the line  label "FO RMAT"
  4865   "RTN","PXC EICR",7,0)
  4866    ;;Long na me~File Nu mber~Node  Subscripts ~Allow Dup licate ent ries (1=ye s, 0=no)~F ile global  name
  4867   "RTN","PXC EICR",8,0)
  4868    ;     1          2               3                     4                                      5
  4869   "RTN","PXC EICR",9,0)
  4870    ;
  4871   "RTN","PXC EICR",10,0 )
  4872    ;Followin g lines:
  4873   "RTN","PXC EICR",11,0 )
  4874    ;;Node~Pi ece~,Field  Number~Ed it Label~D isplay Lab el~Display  Routine~E dit Routin e~Help Tex t for DIR( "?")~Set o f PXCEKEYS  that can  Edit~D if  Detail Dis play Only~
  4875   "RTN","PXC EICR",12,0 )
  4876    ;  1  ~   2  ~       3      ~      4    ~         5     ~         6      ~      7       ~       8                ~           9                    ~        10
  4877   "RTN","PXC EICR",13,0 )
  4878    ;The Disp lay & Edit  routines  are for sp ecial case s.
  4879   "RTN","PXC EICR",14,0 )
  4880    ;  (The . 01 field c annot have  a special  edit.)
  4881   "RTN","PXC EICR",15,0 )
  4882    ;
  4883   "RTN","PXC EICR",16,0 )
  4884   FORMAT ;;I mm Contrai ndication/ Refusal Ev ent~900001 0.707~0,12 ,801,811,8 12~1~^AUPN VICR
  4885   "RTN","PXC EICR",17,0 )
  4886    ;;0~1~.01 ~Contraind ication/Re fusal:  ~C ontra/Refu sal Event:   ~~~~~B
  4887   "RTN","PXC EICR",18,0 )
  4888    ;;0~4~.04 ~Immunizat ion:  ~Imm unization:   ~~EIMM^P XCEICR~~~D
  4889   "RTN","PXC EICR",19,0 )
  4890    ;;12~1~12 01~Event D ate and Ti me: ~Event  Date and  Time: ~~~~ ~D
  4891   "RTN","PXC EICR",20,0 )
  4892    ;;12~4~12 04~Encount er Provide r:  ~Encou nter Provi der:  ~~EP ROV12^PXCE PRV~~~D
  4893   "RTN","PXC EICR",21,0 )
  4894    ;;0~5~.05 ~Warning U ntil Date:   ~Warning  Until Dat e:  ~~~~~D
  4895   "RTN","PXC EICR",22,0 )
  4896    ;;0~6~.06 ~Date/Time  Recorded:  ~Date/Tim e Recorded :  ~~~~~D
  4897   "RTN","PXC EICR",23,0 )
  4898    ;;811~1~8 1101~Comme nts:  ~Com ments:  ~~ ~~~D
  4899   "RTN","PXC EICR",24,0 )
  4900    ;;
  4901   "RTN","PXC EICR",25,0 )
  4902    ;
  4903   "RTN","PXC EICR",26,0 )
  4904    ;******** ********** ********** ****
  4905   "RTN","PXC EICR",27,0 )
  4906    ;Display  text for t he .01 fie ld
  4907   "RTN","PXC EICR",28,0 )
  4908    ;(Must ha ve is call ed by ASK^ PXCEVFI2 a nd DEL^PXC EVFI2.)
  4909   "RTN","PXC EICR",29,0 )
  4910   DISPLY01(P XCEICR) ;
  4911   "RTN","PXC EICR",30,0 )
  4912    N DIERR,P XCEDILF,PX CEINT,PXCE EXT
  4913   "RTN","PXC EICR",31,0 )
  4914    S PXCEINT =$P(PXCEIC R,"^",1)
  4915   "RTN","PXC EICR",32,0 )
  4916    S PXCEEXT =$$EXTERNA L^DILFD(90 00010.707, .01,"",PXC EINT,"PXCE DILF")
  4917   "RTN","PXC EICR",33,0 )
  4918    Q $S('$D( DIERR):PXC EEXT,1:PXC EINT)
  4919   "RTN","PXC EICR",34,0 )
  4920    ;
  4921   "RTN","PXC EICR",35,0 )
  4922   EIMM ; Edi t Immuniza tion
  4923   "RTN","PXC EICR",36,0 )
  4924    N DA,DIR, DTOUT,DUOU T,X,Y
  4925   "RTN","PXC EICR",37,0 )
  4926    I $P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))'= "" D
  4927   "RTN","PXC EICR",38,0 )
  4928    . N DIERR ,PXCEDILF, PXCEINT,PX CEEXT
  4929   "RTN","PXC EICR",39,0 )
  4930    . S PXCEI NT=$P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))
  4931   "RTN","PXC EICR",40,0 )
  4932    . S PXCEE XT=$$EXTER NAL^DILFD( PXCEFILE,$ P(PXCETEXT ,"~",3),"" ,PXCEINT," PXCEDILF")
  4933   "RTN","PXC EICR",41,0 )
  4934    . S DIR(" B")=$S('$D (DIERR):PX CEEXT,1:PX CEINT)
  4935   "RTN","PXC EICR",42,0 )
  4936    S DIR(0)= "PA^999999 9.14:QEM"
  4937   "RTN","PXC EICR",43,0 )
  4938    S DIR("S" )="I $$IMM CRSEL^PXVU TIL($P($G( PXCEAFTR(0 )),U,1),Y) "
  4939   "RTN","PXC EICR",44,0 )
  4940    S DIR("A" )=$P(PXCET EXT,"~",4)
  4941   "RTN","PXC EICR",45,0 )
  4942    S:$P(PXCE TEXT,"~",8 )]"" DIR(" ?")=$P(PXC ETEXT,"~", 8)
  4943   "RTN","PXC EICR",46,0 )
  4944    D ^DIR
  4945   "RTN","PXC EICR",47,0 )
  4946    I X="@" S  Y="@"
  4947   "RTN","PXC EICR",48,0 )
  4948    E  I $D(D TOUT)!$D(D UOUT) S PX CEEND=1
  4949   "RTN","PXC EICR",49,0 )
  4950    S $P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))=$ P(Y,"^")
  4951   "RTN","PXC EICR",50,0 )
  4952    Q
  4953   "RTN","PXC EICR",51,0 )
  4954    ;
  4955   "RTN","PXC EICR",52,0 )
  4956   CONTRA ;
  4957   "RTN","PXC EICR",53,0 )
  4958    Q:'$G(PXC EPAT)!'+$G (PXD)
  4959   "RTN","PXC EICR",54,0 )
  4960    N PXCNT,P XD1,PXEXT, PXIEN,PXRE SULT,PXVJF LG,PXWUD
  4961   "RTN","PXC EICR",55,0 )
  4962    S (PXVACK ,PXCNT)=0, PXD1=+PXD, PXJUST=""
  4963   "RTN","PXC EICR",56,0 )
  4964    D PATICR^ PXAPIIM(.P XRESULT,PX CEPAT,PXD1 )
  4965   "RTN","PXC EICR",57,0 )
  4966    I '$O(PXR ESULT(0))  Q
  4967   "RTN","PXC EICR",58,0 )
  4968    S PXIEN=0  F  S PXIE N=$O(PXRES ULT(PXIEN) ) Q:'PXIEN   D CHK
  4969   "RTN","PXC EICR",59,0 )
  4970    I PXCNT S  PXCONTRA= 1 D
  4971   "RTN","PXC EICR",60,0 )
  4972    . I $P($G (PXCEAFTR( "12")),"^" ,20) D JUS T I PXVJFL G S PXVACK =1 Q
  4973   "RTN","PXC EICR",61,0 )
  4974    . K DIR S  DIR("A",1 )=""
  4975   "RTN","PXC EICR",62,0 )
  4976    . S DIR(" A")="Ackno wledge war ning and p roceed wit h administ ration",DI R(0)="Y",D IR("B")="N O"
  4977   "RTN","PXC EICR",63,0 )
  4978    . S DIR(" ?",1)="Ent er YES to  acknowledg e a warnin g of contr aindicatio n/refusal  events"
  4979   "RTN","PXC EICR",64,0 )
  4980    . S DIR(" ?")="assoc iated with  this immu nization a nd to proc eed with a dministrat ion." D ^D IR K DIR
  4981   "RTN","PXC EICR",65,0 )
  4982    . I $D(DT OUT)!$D(DU OUT)!'Y Q
  4983   "RTN","PXC EICR",66,0 )
  4984    . I Y D J UST I PXVJ FLG S PXVA CK=1 Q
  4985   "RTN","PXC EICR",67,0 )
  4986    Q
  4987   "RTN","PXC EICR",68,0 )
  4988   CHK ;
  4989   "RTN","PXC EICR",69,0 )
  4990    S PXWUD=$ P(PXRESULT (PXIEN),"^ ",4) I $G( PXWUD),$G( PXWUD)<DT  Q
  4991   "RTN","PXC EICR",70,0 )
  4992    S PXCNT=P XCNT+1 I P XCNT=1 D W ARN
  4993   "RTN","PXC EICR",71,0 )
  4994    S PXEXT=$ P($P(PXRES ULT(PXIEN) ,"^",2),"| ",2)
  4995   "RTN","PXC EICR",72,0 )
  4996    I $G(PXWU D) S Y=PXW UD D DD^%D T S PXEXT= PXEXT_"  ( Until "_Y_ ")"
  4997   "RTN","PXC EICR",73,0 )
  4998    D EN^DDIO L(PXEXT,," !,?4")
  4999   "RTN","PXC EICR",74,0 )
  5000    N PXC S P XC=$G(PXRE SULT(PXIEN ,"COMMENTS ")) I $L(P XC) S PXC= "COMMENT:  "_PXC D EN ^DDIOL(PXC ,,"!,?6")
  5001   "RTN","PXC EICR",75,0 )
  5002    Q
  5003   "RTN","PXC EICR",76,0 )
  5004   WARN ;
  5005   "RTN","PXC EICR",77,0 )
  5006    N PXX S P XX=$C(7)_" WARNING!"  D EN^DDIOL (PXX,,"!!" )
  5007   "RTN","PXC EICR",78,0 )
  5008    D EN^DDIO L("Contrai ndication/ refusal ev ent(s) ass ociated wi th this im munization :",,"!,?2" )
  5009   "RTN","PXC EICR",79,0 )
  5010    Q
  5011   "RTN","PXC EICR",80,0 )
  5012   JUST ; ent er comment  concernin g override  of warnin g
  5013   "RTN","PXC EICR",81,0 )
  5014    S PXVJFLG =0
  5015   "RTN","PXC EICR",82,0 )
  5016    K DIR I $ D(PXCEAFTR ("16")) S  DIR("B")=$ P(PXCEAFTR ("16"),"^" )
  5017   "RTN","PXC EICR",83,0 )
  5018    S DIR("A" )="Warning  Override  Justificat ion",DIR(0 )="9000010 .11,1601"  D ^DIR K D IR
  5019   "RTN","PXC EICR",84,0 )
  5020    I $D(DTOU T)!$D(DUOU T) S:Y="^"  PXJUST="@ " Q
  5021   "RTN","PXC EICR",85,0 )
  5022    I Y="" D  EN^DDIOL(" Override j ustificati on entry i s required  to procee d with adm inistratio n.",,"!,?2 ") G JUST
  5023   "RTN","PXC EICR",86,0 )
  5024    S PXJUST= Y,PXVJFLG= 1
  5025   "RTN","PXC EICR",87,0 )
  5026    Q
  5027   "RTN","PXC EVFI1")
  5028   0^14^B3319 8888^B2392 4796
  5029   "RTN","PXC EVFI1",1,0 )
  5030   PXCEVFI1 ; ISL/dee,es w - Routin e to edit  a visit or  v-file en try ;04/11 /2016
  5031   "RTN","PXC EVFI1",2,0 )
  5032    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**23,7 3,112,136, 143,124,18 4,185,210, 215**;Aug  12, 1996;B uild 10
  5033   "RTN","PXC EVFI1",3,0 )
  5034    Q
  5035   "RTN","PXC EVFI1",4,0 )
  5036    ;
  5037   "RTN","PXC EVFI1",5,0 )
  5038   EDIT ; --  edit the V -File stor ed in "AFT ER"
  5039   "RTN","PXC EVFI1",6,0 )
  5040    N DIR,DA, X,Y,C,PXCE INP,PXCEIN 01,PXCEEND ,PXD,PXCON TRA,PXJUST ,PXVACK
  5041   "RTN","PXC EVFI1",7,0 )
  5042    N PXCELIN E,PXCETEXT ,PXCEDIRB, PXCEMOD
  5043   "RTN","PXC EVFI1",8,0 )
  5044    N PXCEKEY ,PXCEIKEY, PXCENKEY,P XMDCNT
  5045   "RTN","PXC EVFI1",9,0 )
  5046    W !
  5047   "RTN","PXC EVFI1",10, 0)
  5048    G:PXCECAT ="VST"!(PX CECAT="APP M")!(PXCEC AT="CSTP")  REST
  5049   "RTN","PXC EVFI1",11, 0)
  5050    ;
  5051   "RTN","PXC EVFI1",12, 0)
  5052   EDIT01 ;
  5053   "RTN","PXC EVFI1",13, 0)
  5054    I PXCECAT ="CPT"!(PX CECAT="POV ")!(PXCECA T="SK")!(P XCECAT="IM M") D SC^P XCEVFI2($P (^AUPNVSIT (PXCEVIEN, 0),U,5))
  5055   "RTN","PXC EVFI1",14, 0)
  5056    S PXCETEX T=$P($T(FO RMAT+1^@PX CECODE),"; ;",2)
  5057   "RTN","PXC EVFI1",15, 0)
  5058    K DIR,DA, X,Y,C,PXCE DIRB
  5059   "RTN","PXC EVFI1",16, 0)
  5060    I $P(PXCE AFTR(0),"^ ",1) D
  5061   "RTN","PXC EVFI1",17, 0)
  5062    . N DIEER ,PXCEDILF, PXCEEXT
  5063   "RTN","PXC EVFI1",18, 0)
  5064    . S PXCEE XT=$$EXTER NAL^DILFD( PXCEFILE,. 01,"",$P(P XCEAFTR(0) ,"^",1),"P XCEDILF")
  5065   "RTN","PXC EVFI1",19, 0)
  5066    . S PXCED IRB=$S('$D (DIERR):PX CEEXT,1:$P (PXCEAFTR( 0),"^",1))
  5067   "RTN","PXC EVFI1",20, 0)
  5068    E  S PXCE DIRB=""
  5069   "RTN","PXC EVFI1",21, 0)
  5070    I $P(PXCE TEXT,"~",7 )]"" D
  5071   "RTN","PXC EVFI1",22, 0)
  5072    . D @$P(P XCETEXT,"~ ",7)
  5073   "RTN","PXC EVFI1",23, 0)
  5074    E  D
  5075   "RTN","PXC EVFI1",24, 0)
  5076    . I PXCED IRB'="" S  DIR("B")=P XCEDIRB
  5077   "RTN","PXC EVFI1",25, 0)
  5078    . S DIR(0 )=PXCEFILE _",.01OA"
  5079   "RTN","PXC EVFI1",26, 0)
  5080    . S DIR(" A")=$P(PXC ETEXT,"~", 4)
  5081   "RTN","PXC EVFI1",27, 0)
  5082    . S:$P(PX CETEXT,"~" ,8)]"" DIR ("?")=$P(P XCETEXT,"~ ",8)
  5083   "RTN","PXC EVFI1",28, 0)
  5084    . I PXCEC AT="IMM" D
  5085   "RTN","PXC EVFI1",29, 0)
  5086    . . S DIR (0)="PAO^9 999999.14: QEM"
  5087   "RTN","PXC EVFI1",30, 0)
  5088    . . S DIR ("S")="I $ $IMMSEL^PX VUTIL(Y,$G (PXCEVIEN) )"
  5089   "RTN","PXC EVFI1",31, 0)
  5090    . D ^DIR
  5091   "RTN","PXC EVFI1",32, 0)
  5092    I X="@" D   G ENDEDI T
  5093   "RTN","PXC EVFI1",33, 0)
  5094    . N DIRUT
  5095   "RTN","PXC EVFI1",34, 0)
  5096    . I $P(PX CEAFTR(0), "^",1)=""  D
  5097   "RTN","PXC EVFI1",35, 0)
  5098    .. W !,"T here is no  entry to  delete."
  5099   "RTN","PXC EVFI1",36, 0)
  5100    .. D WAIT ^PXCEHELP
  5101   "RTN","PXC EVFI1",37, 0)
  5102    . E  D DE L^PXCEVFI2 (PXCECAT)
  5103   "RTN","PXC EVFI1",38, 0)
  5104    I $D(DIRU T),$P(PXCE AFTR(0),"^ ",1)="" S  PXCELOOP=1
  5105   "RTN","PXC EVFI1",39, 0)
  5106    I $D(DIRU T) S PXCEQ UIT=1 Q
  5107   "RTN","PXC EVFI1",40, 0)
  5108    S (PXCEIN P,PXD)=Y
  5109   "RTN","PXC EVFI1",41, 0)
  5110    S PXCEIN0 1=X
  5111   "RTN","PXC EVFI1",42, 0)
  5112    I $P(Y,"^ ",2)'=PXCE DIRB,$$DUP (PXCEINP)  G EDIT01
  5113   "RTN","PXC EVFI1",43, 0)
  5114    I PXCECAT ="IMM" D   Q:PXCEQUIT   ; PX*1*2 15
  5115   "RTN","PXC EVFI1",44, 0)
  5116    . S (PXCO NTRA,PXVAC K)=0,PXJUS T="" D CON TRA^PXCEIC R
  5117   "RTN","PXC EVFI1",45, 0)
  5118    . I 'PXCO NTRA S $P( PXCEAFTR(1 2),"^",20) ="@",$P(PX CEAFTR(16) ,"^",1)="@ " Q
  5119   "RTN","PXC EVFI1",46, 0)
  5120    . I PXCON TRA,'PXVAC K S PXCEQU IT=1 Q
  5121   "RTN","PXC EVFI1",47, 0)
  5122    . I PXCON TRA,PXVACK  D
  5123   "RTN","PXC EVFI1",48, 0)
  5124    ..S $P(PX CEAFTR(12) ,"^",20)=1
  5125   "RTN","PXC EVFI1",49, 0)
  5126    ..S $P(PX CEAFTR(16) ,"^",1)=PX JUST
  5127   "RTN","PXC EVFI1",50, 0)
  5128    ;--File n ew CPT cod e and retr ieve IEN
  5129   "RTN","PXC EVFI1",51, 0)
  5130    I PXCECAT ="CPT" D
  5131   "RTN","PXC EVFI1",52, 0)
  5132    . S PXMDC NT=$$CODM^ ICPTCOD(+Y ,"^TMP(""P XMODARR"", $J",PXCESO R,+^TMP("P XK",$J,"VS T",1,0,"AF TER"))
  5133   "RTN","PXC EVFI1",53, 0)
  5134    . K ^TMP( "PXMODARR" ,$J)
  5135   "RTN","PXC EVFI1",54, 0)
  5136    . I $P(PX CEAFTR(0), "^",1)'="" !(PXMDCNT' >0) Q
  5137   "RTN","PXC EVFI1",55, 0)
  5138    . N PXCEF IEN
  5139   "RTN","PXC EVFI1",56, 0)
  5140    . D NEWCO DE^PXCECPT
  5141   "RTN","PXC EVFI1",57, 0)
  5142    . S ^TMP( "PXK",$J,P XCECATS,1, "IEN")=PXC EFIEN
  5143   "RTN","PXC EVFI1",58, 0)
  5144    I PXCECAT ="PRV",$P( PXCEAFTR(0 ),"^",1)>0 ,PXCEDIRB] "" S $P(PX CEAFTR(0), "^",6)=""
  5145   "RTN","PXC EVFI1",59, 0)
  5146    S $P(PXCE AFTR(0),"^ ",1)=$P(PX CEINP,"^")
  5147   "RTN","PXC EVFI1",60, 0)
  5148    K DIR,DA
  5149   "RTN","PXC EVFI1",61, 0)
  5150    ;followin g code add ed per PX* 185
  5151   "RTN","PXC EVFI1",62, 0)
  5152    I $D(XQOR NOD(0)) I  $P(XQORNOD (0),U,4)=" HF" D
  5153   "RTN","PXC EVFI1",63, 0)
  5154    .N HFIEN, NODE
  5155   "RTN","PXC EVFI1",64, 0)
  5156    .S HFIEN= $P(PXCEINP ,U),NODE=$ G(^AUTTHF( HFIEN,0))
  5157   "RTN","PXC EVFI1",65, 0)
  5158    .Q:'$D(NO DE)
  5159   "RTN","PXC EVFI1",66, 0)
  5160    .I $P(NOD E,U,8)'="Y " W !!,"WA RNING:  Th is Health  Factor is  currently  not set to ",!?10,"di splay on a  Health Su mmary repo rt.",!!
  5161   "RTN","PXC EVFI1",67, 0)
  5162    .K HFIEN, NODE
  5163   "RTN","PXC EVFI1",68, 0)
  5164    .Q
  5165   "RTN","PXC EVFI1",69, 0)
  5166    ;
  5167   "RTN","PXC EVFI1",70, 0)
  5168   REST S PXC EEND=0
  5169   "RTN","PXC EVFI1",71, 0)
  5170    F PXCELIN E=2:1 S PX CETEXT=$P( $T(FORMAT+ PXCELINE^@ PXCECODE), ";;",2) Q: PXCETEXT'] ""  D  Q:P XCEEND
  5171   "RTN","PXC EVFI1",72, 0)
  5172    . I $P(PX CETEXT,"~" ,3)=.06,PX CECAT="ICR " Q  ; PX* 1*215
  5173   "RTN","PXC EVFI1",73, 0)
  5174    . I $P(PX CETEXT,"~" ,3)=1301,P XCECAT="IM M",'$$HIST  Q  ; PX*1 *215
  5175   "RTN","PXC EVFI1",74, 0)
  5176    . I $P(PX CETEXT,"~" ,3)=1220,P XCECAT="IM M" Q  ; PX *1*215
  5177   "RTN","PXC EVFI1",75, 0)
  5178    . I $P(PX CETEXT,"~" ,3)=1601,P XCECAT="IM M" Q  ; PX *1*215
  5179   "RTN","PXC EVFI1",76, 0)
  5180    . I $P(PX CETEXT,"~" ,3)=1214,P XCECAT="SK " Q  ; PX* 1*210
  5181   "RTN","PXC EVFI1",77, 0)
  5182    . I $P(PX CETEXT,"~" ,3)=1406,P XCECAT="IM M" Q  ; PX *1*210
  5183   "RTN","PXC EVFI1",78, 0)
  5184    . I $P(PX CETEXT,"~" ,3)=1403 D   Q:PXCEEN D  ; PX*1* 210
  5185   "RTN","PXC EVFI1",79, 0)
  5186    .. I PXCE CAT'="IMM"  S PXCEEND =1 Q  ; PX *1*210
  5187   "RTN","PXC EVFI1",80, 0)
  5188    .. I +$G( PXD),'$P($ G(^AUTTIMM (+PXD,.5)) ,"^") S PX CEEND=1 Q   ; PX*1*21 0
  5189   "RTN","PXC EVFI1",81, 0)
  5190    . I $P(PX CETEXT,"~" ,9)]"",$P( PXCETEXT," ~",3)'=802 01 S PXCEK EY="" D  Q :PXCEKEY'= 1
  5191   "RTN","PXC EVFI1",82, 0)
  5192    .. S PXCE NKEY=$L($P (PXCETEXT, "~",9))
  5193   "RTN","PXC EVFI1",83, 0)
  5194    .. F PXCE IKEY=1:1:P XCENKEY I  PXCEKEYS[$ E($P(PXCET EXT,"~",9) ,PXCEIKEY)  S PXCEKEY =1 Q
  5195   "RTN","PXC EVFI1",84, 0)
  5196    . K DIR,D A,X,Y,C
  5197   "RTN","PXC EVFI1",85, 0)
  5198    . I $P(PX CETEXT,"~" ,7)]"" D
  5199   "RTN","PXC EVFI1",86, 0)
  5200    .. D @$P( PXCETEXT," ~",7)
  5201   "RTN","PXC EVFI1",87, 0)
  5202    . E  D
  5203   "RTN","PXC EVFI1",88, 0)
  5204    .. I $P(P XCEAFTR($P (PXCETEXT, "~",1)),"^ ",$P(PXCET EXT,"~",2) )'="" D
  5205   "RTN","PXC EVFI1",89, 0)
  5206    ... N DIE RR,PXCEDIL F,PXCEINT, PXCEEXT
  5207   "RTN","PXC EVFI1",90, 0)
  5208    ... S PXC EINT=$P(PX CEAFTR($P( PXCETEXT," ~",1)),"^" ,$P(PXCETE XT,"~",2))
  5209   "RTN","PXC EVFI1",91, 0)
  5210    ... S PXC EEXT=$$EXT ERNAL^DILF D(PXCEFILE ,$P(PXCETE XT,"~",3), "",PXCEINT ,"PXCEDILF ")
  5211   "RTN","PXC EVFI1",92, 0)
  5212    ... S DIR ("B")=$S(' $D(DIERR): PXCEEXT,1: PXCEINT)
  5213   "RTN","PXC EVFI1",93, 0)
  5214    .. S DIR( 0)=PXCEFIL E_","_$P(P XCETEXT,"~ ",3)_"A"
  5215   "RTN","PXC EVFI1",94, 0)
  5216    .. S DIR( "A")=$P(PX CETEXT,"~" ,4)
  5217   "RTN","PXC EVFI1",95, 0)
  5218    .. I PXCE CAT="IMM", $G(DIR("B" ))="" D DE F ; PX*1*2 15
  5219   "RTN","PXC EVFI1",96, 0)
  5220    .. S:$P(P XCETEXT,"~ ",8)]"" DI R("?")=$P( PXCETEXT," ~",8)
  5221   "RTN","PXC EVFI1",97, 0)
  5222    .. D ^DIR
  5223   "RTN","PXC EVFI1",98, 0)
  5224    .. K DIR, DA
  5225   "RTN","PXC EVFI1",99, 0)
  5226    .. I X="@ " S Y="@"
  5227   "RTN","PXC EVFI1",100 ,0)
  5228    .. E  I $ D(DTOUT)!$ D(DUOUT) S  PXCEEND=1  S:PXCECAT ="SIT"!(PX CECAT="APP M")!(PXCEC AT="HIST") !(PXCECAT= "CPT") PXC EQUIT=1 Q
  5229   "RTN","PXC EVFI1",101 ,0)
  5230    .. S $P(P XCEAFTR($P (PXCETEXT, "~",1)),"^ ",$P(PXCET EXT,"~",2) )=$P(Y,"^" )
  5231   "RTN","PXC EVFI1",102 ,0)
  5232    . I ($P(P XCETEXT,"~ ",3)=1202! ($P(PXCETE XT,"~",3)= 1204)) D:+ Y>0 PROVID ER^PXCEVFI 4(+Y)
  5233   "RTN","PXC EVFI1",103 ,0)
  5234    ;
  5235   "RTN","PXC EVFI1",104 ,0)
  5236   ENDEDIT ;
  5237   "RTN","PXC EVFI1",105 ,0)
  5238    Q
  5239   "RTN","PXC EVFI1",106 ,0)
  5240    ;
  5241   "RTN","PXC EVFI1",107 ,0)
  5242   DUP(PXCEIN P) ; -- Ch eck for du p entries.
  5243   "RTN","PXC EVFI1",108 ,0)
  5244    Q:PXCECAT ="SIT"!(PX CECAT="APP M")!(PXCEC AT="HIST")  0
  5245   "RTN","PXC EVFI1",109 ,0)
  5246    ;
  5247   "RTN","PXC EVFI1",110 ,0)
  5248    N PXCEDUP ,PXCEINDX, X,Y
  5249   "RTN","PXC EVFI1",111 ,0)
  5250    S PXCEDUP =0
  5251   "RTN","PXC EVFI1",112 ,0)
  5252    S PXCEIND X=""
  5253   "RTN","PXC EVFI1",113 ,0)
  5254    F  S PXCE INDX=$O(@( PXCEAUPN_" (""AD"",PX CEVIEN,PXC EINDX)"))  Q:'PXCEIND X!PXCEDUP   S:+@(PXCE AUPN_"(PXC EINDX,0)") =+PXCEINP& (PXCEINDX' =PXCEFIEN)  PXCEDUP=1
  5255   "RTN","PXC EVFI1",114 ,0)
  5256    I PXCEDUP  D
  5257   "RTN","PXC EVFI1",115 ,0)
  5258    . I PXCED UP
  5259   "RTN","PXC EVFI1",116 ,0)
  5260    . W !,$P( PXCEINP,"^ ",2)," is  already a  "_PXCECATT _" for thi s Encounte r."
  5261   "RTN","PXC EVFI1",117 ,0)
  5262    . I PXCEC AT="POV" W  !!,"Dupli cate Diagn osis Not A llowed." Q   ;PX/112
  5263   "RTN","PXC EVFI1",118 ,0)
  5264    . I PXCEC AT="CPT",$ $GET1^DIQ( 357.69,$P( PXCEINP,"^ ",2),.01)> 0 D  Q
  5265   "RTN","PXC EVFI1",119 ,0)
  5266    . . W !," No duplica te E&M cod es allowed ."   ;PX/1 36
  5267   "RTN","PXC EVFI1",120 ,0)
  5268    . I $P($T (FORMAT^@P XCECODE)," ~",4) D
  5269   "RTN","PXC EVFI1",121 ,0)
  5270    .. N DIR, DA
  5271   "RTN","PXC EVFI1",122 ,0)
  5272    .. S DIR( 0)="Y"
  5273   "RTN","PXC EVFI1",123 ,0)
  5274    .. S DIR( "A")="Do y ou want to  add anoth er "_$P(PX CEINP,"^", 2)_""
  5275   "RTN","PXC EVFI1",124 ,0)
  5276    .. S DIR( "B")="NO"
  5277   "RTN","PXC EVFI1",125 ,0)
  5278    .. D ^DIR
  5279   "RTN","PXC EVFI1",126 ,0)
  5280    .. S PXCE DUP='+Y
  5281   "RTN","PXC EVFI1",127 ,0)
  5282    Q PXCEDUP
  5283   "RTN","PXC EVFI1",128 ,0)
  5284    ;
  5285   "RTN","PXC EVFI1",129 ,0)
  5286   DEF ; get  default re sponse fro m file #92 0.05; PX*1 *215
  5287   "RTN","PXC EVFI1",130 ,0)
  5288    N PXVDEF, PXVFAC,PXV IMM,PXCEEX T
  5289   "RTN","PXC EVFI1",131 ,0)
  5290    Q:'$D(PXC EVIEN)
  5291   "RTN","PXC EVFI1",132 ,0)
  5292    S PXVFAC= $$INST^PXV RESP(PXCEV IEN) Q:'PX VFAC
  5293   "RTN","PXC EVFI1",133 ,0)
  5294    S PXVIMM= +$G(PXD) Q :'PXVIMM
  5295   "RTN","PXC EVFI1",134 ,0)
  5296    S PXVDEF= $P($G(^PXV (920.05,PX VFAC,1,PXV IMM,$P(PXC ETEXT,"~", 1))),"^",$ P(PXCETEXT ,"~",2))
  5297   "RTN","PXC EVFI1",135 ,0)
  5298    S PXCEEXT =$$EXTERNA L^DILFD(PX CEFILE,$P( PXCETEXT," ~",3),"",P XVDEF,"PXC EDILF")
  5299   "RTN","PXC EVFI1",136 ,0)
  5300    I PXCEEXT '="" S DIR ("B")=PXCE EXT
  5301   "RTN","PXC EVFI1",137 ,0)
  5302    Q
  5303   "RTN","PXC EVFI1",138 ,0)
  5304   HIST() ; c heck if hi storical e ncounter;  PX*1*215
  5305   "RTN","PXC EVFI1",139 ,0)
  5306    N PXVHIST  S PXVHIST =0
  5307   "RTN","PXC EVFI1",140 ,0)
  5308    I $G(PXCE VIEN),$P(^ AUPNVSIT(P XCEVIEN,0) ,"^",7)="E " S PXVHIS T=1
  5309   "RTN","PXC EVFI1",141 ,0)
  5310    Q PXVHIST
  5311   "RTN","PXC EVFI2")
  5312   0^15^B3781 8294^B3434 4095
  5313   "RTN","PXC EVFI2",1,0 )
  5314   PXCEVFI2 ; ISL/dee,ES W - Suppor ting routi nes for ed iting a vi sit or v-f ile entry  ;12/03/201 5
  5315   "RTN","PXC EVFI2",2,0 )
  5316    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**22,7 3,95,96,12 4,158,184, 215**;Aug  12, 1996;B uild 10
  5317   "RTN","PXC EVFI2",3,0 )
  5318    ;
  5319   "RTN","PXC EVFI2",4,0 )
  5320    Q
  5321   "RTN","PXC EVFI2",5,0 )
  5322   ASK(PXCVIE N,PXCFIEN, PXCEAUPN,P XCCATT,PXC CODE) ; --  Display a  selection  list from  one V-Fil e for this  visit
  5323   "RTN","PXC EVFI2",6,0 )
  5324    N PXCEIND X,PXCECNT, PXCEASK,PX CEREF
  5325   "RTN","PXC EVFI2",7,0 )
  5326    N DIR,DA, X,Y
  5327   "RTN","PXC EVFI2",8,0 )
  5328    S PXCEIND X=""
  5329   "RTN","PXC EVFI2",9,0 )
  5330    F PXCECNT =0:1 S PXC EINDX=$O(@ (PXCEAUPN_ "(""AD"",P XCVIEN,PXC EINDX)"))  Q:'PXCEIND X  D
  5331   "RTN","PXC EVFI2",10, 0)
  5332    . I PXCEC NT=0&(PXCC ATT="Diagn osis") D S C($P(^AUPN VSIT(PXCEV IEN,0),U,5 ))
  5333   "RTN","PXC EVFI2",11, 0)
  5334    . I PXCEC NT=0&(PXCC ATT="CPT")  D SC($P(^ AUPNVSIT(P XCEVIEN,0) ,U,5))
  5335   "RTN","PXC EVFI2",12, 0)
  5336    . W:PXCEC NT=0 !!,"- -- "_PXCCA TT_" ---", !
  5337   "RTN","PXC EVFI2",13, 0)
  5338    . S PXCEA SK(PXCECNT +1)=PXCEIN DX
  5339   "RTN","PXC EVFI2",14, 0)
  5340    . W !,$J( PXCECNT+1, 3),?6,@("$ $DISPLY01^ "_PXCCODE_ "("_PXCEAU PN_"(PXCEI NDX,0))")
  5341   "RTN","PXC EVFI2",15, 0)
  5342    Q:PXCECNT '>0
  5343   "RTN","PXC EVFI2",16, 0)
  5344   ASKLOOP S  DIR(0)="FA O^1:"_$L(P XCECNT)
  5345   "RTN","PXC EVFI2",17, 0)
  5346    I PXCECAT ="IMM" D
  5347   "RTN","PXC EVFI2",18, 0)
  5348    . S DIR(" A",1)="Ent er 1-"_PXC ECNT_" to  Edit, 'A'  to Add, or "
  5349   "RTN","PXC EVFI2",19, 0)
  5350    . S DIR(" A")=" 'C'  to documen t a Contra indication /Refusal:  "
  5351   "RTN","PXC EVFI2",20, 0)
  5352    . S DIR(" ?",1)="Ent er the num ber of the  "_PXCCATT _" you wis h to edit,  A to add  a"
  5353   "RTN","PXC EVFI2",21, 0)
  5354    . S DIR(" ?")="new " _PXCCATT_" , or 'C' t o document  a Contrai ndication/ Refusal."
  5355   "RTN","PXC EVFI2",22, 0)
  5356    E  D
  5357   "RTN","PXC EVFI2",23, 0)
  5358    . S DIR(" A")="Enter  1-"_PXCEC NT_" to Ed it, or 'A'  to Add: "
  5359   "RTN","PXC EVFI2",24, 0)
  5360    . S DIR(" ?")="Enter  the numbe r of the " _PXCCATT_"  you wish  to edit or  A to add  a new "_PX CCATT_"."
  5361   "RTN","PXC EVFI2",25, 0)
  5362    D ^DIR
  5363   "RTN","PXC EVFI2",26, 0)
  5364    K DIR,DA
  5365   "RTN","PXC EVFI2",27, 0)
  5366    I $D(DIRU T) S PXCEQ UIT=1 Q
  5367   "RTN","PXC EVFI2",28, 0)
  5368    Q:"Aa"[Y
  5369   "RTN","PXC EVFI2",29, 0)
  5370    I "Cc"[Y  S PXVICR=1  Q
  5371   "RTN","PXC EVFI2",30, 0)
  5372    G:Y<1!(Y> PXCECNT) A SKLOOP
  5373   "RTN","PXC EVFI2",31, 0)
  5374    G:$G(PXCE ASK(Y))'>0  ASKLOOP
  5375   "RTN","PXC EVFI2",32, 0)
  5376    S PXCFIEN =$G(PXCEAS K(Y))
  5377   "RTN","PXC EVFI2",33, 0)
  5378    Q
  5379   "RTN","PXC EVFI2",34, 0)
  5380    ;
  5381   "RTN","PXC EVFI2",35, 0)
  5382   SAVE ; --  Save this  edited and  quit edit ing.
  5383   "RTN","PXC EVFI2",36, 0)
  5384    I PXCECAT ="CSTP" S  PXCEFIEN=$ $STOPCODE^ PXUTLSTP(P XCESOR,$P( PXCEAFTR(0 ),"^",8),P XCEVIEN)
  5385   "RTN","PXC EVFI2",37, 0)
  5386    E  D
  5387   "RTN","PXC EVFI2",38, 0)
  5388    . N PXCEN ODS,PXCEFO R,PXCENODE ,PXCESEQ
  5389   "RTN","PXC EVFI2",39, 0)
  5390    . S PXCEN ODS=$P($T( FORMAT^@PX CECODE),"~ ",3)
  5391   "RTN","PXC EVFI2",40, 0)
  5392    . F PXCEF OR=1:1 S P XCENODE=$P (PXCENODS, ",",PXCEFO R) Q:PXCEN ODE']""  D
  5393   "RTN","PXC EVFI2",41, 0)
  5394    .. I PXCE NODE=1,PXC ECATS="CPT " D  Q
  5395   "RTN","PXC EVFI2",42, 0)
  5396    ... S PXC ESEQ=""
  5397   "RTN","PXC EVFI2",43, 0)
  5398    ... F  S  PXCESEQ=$O (PXCEAFTR( PXCENODE,P XCESEQ)) Q :PXCESEQ=" "  D
  5399   "RTN","PXC EVFI2",44, 0)
  5400    .... S ^T MP("PXK",$ J,PXCECATS ,1,PXCENOD E,PXCESEQ, "AFTER")=P XCEAFTR(PX CENODE,PXC ESEQ)
  5401   "RTN","PXC EVFI2",45, 0)
  5402    .. S ^TMP ("PXK",$J, PXCECATS,1 ,PXCENODE, "AFTER")=P XCEAFTR(PX CENODE)
  5403   "RTN","PXC EVFI2",46, 0)
  5404    . I PXCEC AT="SK",$G (^TMP("PXK ",$J,PXCEC ATS,1,"IEN "))]"" D S AVE^PXCESK
  5405   "RTN","PXC EVFI2",47, 0)
  5406    . D EN1^P XKMAIN
  5407   "RTN","PXC EVFI2",48, 0)
  5408    . I PXCEC AT="SIT"!( PXCECAT="A PPM")!(PXC ECAT="HIST ") S PXCEV IEN=^TMP(" PXK",$J,"V ST",1,"IEN ")
  5409   "RTN","PXC EVFI2",49, 0)
  5410    Q
  5411   "RTN","PXC EVFI2",50, 0)
  5412    ;
  5413   "RTN","PXC EVFI2",51, 0)
  5414   DEL(PXCECA T) ; -- De lete this  V-File ent ry from th e List if  all the vi sit inform ation.
  5415   "RTN","PXC EVFI2",52, 0)
  5416    I PXCEFIE N'>0!(PXCE VIEN'>0) W  !!,$C(7), "Error: Ca nnot delet e this an  unknown V- File entry ." D PAUSE ^PXCEHELP  Q
  5417   "RTN","PXC EVFI2",53, 0)
  5418    I PXCEKEY S'["D",PXC EKEYS'["d"  W !!,$C(7 ),"Error:  You do not  have dele te access. " D PAUSE^ PXCEHELP Q
  5419   "RTN","PXC EVFI2",54, 0)
  5420    ;
  5421   "RTN","PXC EVFI2",55, 0)
  5422    N PXCENOD S,PXCEFOR, PXCENODE,P XCECATS,PX CECATT,PXC ECODE,PXCE AUPN,PXCEQ UIT
  5423   "RTN","PXC EVFI2",56, 0)
  5424    S PXCECOD E="PXCE"_$ S(PXCECAT= "IMM":"VIM M",1:PXCEC AT)
  5425   "RTN","PXC EVFI2",57, 0)
  5426    S PXCECAT S=$S(PXCEC AT="CSTP": "VST",PXCE CAT="HIST" :"VST",1:P XCECAT)
  5427   "RTN","PXC EVFI2",58, 0)
  5428    S PXCEAUP N=$P($T(FO RMAT^@PXCE CODE),"~", 5)
  5429   "RTN","PXC EVFI2",59, 0)
  5430    S PXCECAT T=$P($P($T (FORMAT^@P XCECODE)," ;;",2),"~" ,1)
  5431   "RTN","PXC EVFI2",60, 0)
  5432    ;
  5433   "RTN","PXC EVFI2",61, 0)
  5434    I '$D(@(P XCEAUPN_"( PXCEFIEN)" )) Q
  5435   "RTN","PXC EVFI2",62, 0)
  5436    I $P($G(@ (PXCEAUPN_ "(PXCEFIEN ,812)"))," ^",1) D  Q
  5437   "RTN","PXC EVFI2",63, 0)
  5438    . W !!,"E rror on de leting "_P XCECATT_"  ",@("$$DIS PLY01^"_PX CECODE_"(@ (PXCEAUPN_ ""(PXCEFIE N,0)""))")
  5439   "RTN","PXC EVFI2",64, 0)
  5440    . W !,"Er ror: You c annot dele te this en try it has  been ""Ve rified""."  D WAIT^PX CEHELP
  5441   "RTN","PXC EVFI2",65, 0)
  5442    I PXCEKEY S'["D" D   Q:PXCEQUIT
  5443   "RTN","PXC EVFI2",66, 0)
  5444    . N PXCEC HK
  5445   "RTN","PXC EVFI2",67, 0)
  5446    . S PXCEQ UIT=0
  5447   "RTN","PXC EVFI2",68, 0)
  5448    . I PXCEC ATS="VST"  S PXCECHK= $P($G(@(PX CEAUPN_"(P XCEFIEN,0) ")),"^",23 )
  5449   "RTN","PXC EVFI2",69, 0)
  5450    . E  S PX CECHK=$P($ P($P($G(@( PXCEAUPN_" (PXCEFIEN, 801)")),"^ ",2),";",1 )," ",2)
  5451   "RTN","PXC EVFI2",70, 0)
  5452    . I DUZ'= PXCECHK D
  5453   "RTN","PXC EVFI2",71, 0)
  5454    .. S PXCE QUIT=1
  5455   "RTN","PXC EVFI2",72, 0)
  5456    .. N NODE 0
  5457   "RTN","PXC EVFI2",73, 0)
  5458    .. S NODE 0=@(PXCEAU PN_"(PXCEF IEN,0)")
  5459   "RTN","PXC EVFI2",74, 0)
  5460    .. W !!," Error on d eleting "_ PXCECATT_"  ",@("$$DI SPLY01^"_P XCECODE_"( NODE0)")
  5461   "RTN","PXC EVFI2",75, 0)
  5462    .. W !,"E rror: You  cannot del ete an ent ry you did  not creat e." D WAIT ^PXCEHELP
  5463   "RTN","PXC EVFI2",76, 0)
  5464    ;
  5465   "RTN","PXC EVFI2",77, 0)
  5466    I PXCECAT ="CSTP" D
  5467   "RTN","PXC EVFI2",78, 0)
  5468    . W !!,"D eleting "_ PXCECATT_"  "
  5469   "RTN","PXC EVFI2",79, 0)
  5470    . W @("$$ DISPLY01^" _PXCECODE_ "($G(@(PXC EAUPN_""(P XCEFIEN,0) "")))")
  5471   "RTN","PXC EVFI2",80, 0)
  5472    . Q:'$$SU RE^PXCEAE2
  5473   "RTN","PXC EVFI2",81, 0)
  5474    . N PXCER ESU
  5475   "RTN","PXC EVFI2",82, 0)
  5476    . S PXCER ESU=$$STOP CODE^PXUTL STP(PXCESO R,"@",PXCE VIEN,PXCEF IEN)
  5477   "RTN","PXC EVFI2",83, 0)
  5478    . S:$D(PX CELOOP) PX CELOOP=1
  5479   "RTN","PXC EVFI2",84, 0)
  5480    E  I PXCE CATS="VST"  D
  5481   "RTN","PXC EVFI2",85, 0)
  5482    . W !!,"D eleting "_ PXCECATT_"  "
  5483   "RTN","PXC EVFI2",86, 0)
  5484    . W @("$$ DISPLY01^" _PXCECODE_ "($G(@(PXC EAUPN_""(P XCEFIEN,0) "")))")
  5485   "RTN","PXC EVFI2",87, 0)
  5486    . Q:'$$SU RE^PXCEAE2
  5487   "RTN","PXC EVFI2",88, 0)
  5488    . N PXCER ESU
  5489   "RTN","PXC EVFI2",89, 0)
  5490    . S PXCER ESU=$$KILL ^VSITKIL(P XCEVIEN)
  5491   "RTN","PXC EVFI2",90, 0)
  5492    . I PXCER ESU D
  5493   "RTN","PXC EVFI2",91, 0)
  5494    .. I PXCE RESU=1,$O( ^SCE("AVSI T",PXCEVIE N,"")) Q
  5495   "RTN","PXC EVFI2",92, 0)
  5496    .. W !,$C (7),"Could  not delet e the enco unter.  Th ere are st ill users  of it." D  WAIT^PXCEH ELP
  5497   "RTN","PXC EVFI2",93, 0)
  5498    . I 'PXCE RESU S PXC EVDEL=1 S: $D(PXCELOO P) (PXCELO OP,PXCEQUI T,PXCENOER )=1
  5499   "RTN","PXC EVFI2",94, 0)
  5500    . D EVENT ^PXKMAIN
  5501   "RTN","PXC EVFI2",95, 0)
  5502    ;
  5503   "RTN","PXC EVFI2",96, 0)
  5504    E  D
  5505   "RTN","PXC EVFI2",97, 0)
  5506    . K ^TMP( "PXK",$J)
  5507   "RTN","PXC EVFI2",98, 0)
  5508    . S ^TMP( "PXK",$J," VST",1,"IE N")=PXCEVI EN
  5509   "RTN","PXC EVFI2",99, 0)
  5510    . F PXCEN ODE=0,21,1 50,800,811 ,812 D
  5511   "RTN","PXC EVFI2",100 ,0)
  5512    .. S (^TM P("PXK",$J ,"VST",1,P XCENODE,"A FTER"),^TM P("PXK",$J ,"VST",1,P XCENODE,"B EFORE"))=$ G(^AUPNVSI T(PXCEVIEN ,PXCENODE) )
  5513   "RTN","PXC EVFI2",101 ,0)
  5514    . ;
  5515   "RTN","PXC EVFI2",102 ,0)
  5516    . S ^TMP( "PXK",$J," SOR")=PXCE SOR
  5517   "RTN","PXC EVFI2",103 ,0)
  5518    . S ^TMP( "PXK",$J,P XCECATS,1, "IEN")=PXC EFIEN
  5519   "RTN","PXC EVFI2",104 ,0)
  5520    . ;
  5521   "RTN","PXC EVFI2",105 ,0)
  5522    . S PXCEN ODS=$P($T( FORMAT^@PX CECODE),"~ ",3)
  5523   "RTN","PXC EVFI2",106 ,0)
  5524    . F PXCEF OR=1:1 S P XCENODE=$P (PXCENODS, ",",PXCEFO R) Q:PXCEN ODE']""  D
  5525   "RTN","PXC EVFI2",107 ,0)
  5526    .. S ^TMP ("PXK",$J, PXCECATS,1 ,PXCENODE, "BEFORE")= $G(@(PXCEA UPN_"(PXCE FIEN,PXCEN ODE)"))
  5527   "RTN","PXC EVFI2",108 ,0)
  5528    . ;
  5529   "RTN","PXC EVFI2",109 ,0)
  5530    . N DIK,D A
  5531   "RTN","PXC EVFI2",110 ,0)
  5532    . W !!,"D eleting "_ PXCECATT_"  "
  5533   "RTN","PXC EVFI2",111 ,0)
  5534    . W @("$$ DISPLY01^" _PXCECODE_ "(^TMP(""P XK"",$J,PX CECATS,1,0 ,""BEFORE" "))")
  5535   "RTN","PXC EVFI2",112 ,0)
  5536    . Q:'$$SU RE^PXCEAE2   ;DELQUIT
  5537   "RTN","PXC EVFI2",113 ,0)
  5538    . S PXCEN ODS=$P($T( FORMAT^@PX CECODE),"~ ",3)
  5539   "RTN","PXC EVFI2",114 ,0)
  5540    . F PXCEF OR=1:1 S P XCENODE=$P (PXCENODS, ",",PXCEFO R) Q:PXCEN ODE']""  S  ^TMP("PXK ",$J,PXCEC ATS,1,PXCE NODE,"AFTE R")=$S(PXC ENODE=0:"@ ",1:"")
  5541   "RTN","PXC EVFI2",115 ,0)
  5542    . D EN1^P XKMAIN
  5543   "RTN","PXC EVFI2",116 ,0)
  5544    . S:$D(PX CELOOP) PX CELOOP=1
  5545   "RTN","PXC EVFI2",117 ,0)
  5546    . I $D(PX CENOER)#2  S PXCENOER =1
  5547   "RTN","PXC EVFI2",118 ,0)
  5548    ;
  5549   "RTN","PXC EVFI2",119 ,0)
  5550   DELQUIT ;
  5551   "RTN","PXC EVFI2",120 ,0)
  5552    K ^TMP("P XK",$J)
  5553   "RTN","PXC EVFI2",121 ,0)
  5554    Q
  5555   "RTN","PXC EVFI2",122 ,0)
  5556    ;
  5557   "RTN","PXC EVFI2",123 ,0)
  5558   SC(PXDFN)  ;Service C onnected H elp
  5559   "RTN","PXC EVFI2",124 ,0)
  5560    ; Input   -- DFN       Patient  file IEN
  5561   "RTN","PXC EVFI2",125 ,0)
  5562    ; Output  -- Help
  5563   "RTN","PXC EVFI2",126 ,0)
  5564    N I,SDCNT ,SDDC,SDRD 0
  5565   "RTN","PXC EVFI2",127 ,0)
  5566    W !!,"Pat ient's Ser vice Conne ction and  Rated Disa bilities:"
  5567   "RTN","PXC EVFI2",128 ,0)
  5568    W !!,$S($ P($G(^DPT( PXDFN,.3)) ,"^")="Y": "        S C Percent:  "_$P(^(.3 ),"^",2)_" %",1:" Ser vice Conne cted: No")
  5569   "RTN","PXC EVFI2",129 ,0)
  5570    W !,"Rate d Disabili ties: "
  5571   "RTN","PXC EVFI2",130 ,0)
  5572    I $P($G(^ DPT(PXDFN, "VET")),"^ ")'="Y",$S ('$D(^DIC( 391,+$G(^D PT(PXDFN," TYPE")),0) ):1,$P(^(0 ),"^",2):0 ,1:1) W "N ot a Veter an" Q
  5573   "RTN","PXC EVFI2",131 ,0)
  5574    S (SDCNT, I)=0
  5575   "RTN","PXC EVFI2",132 ,0)
  5576    F  S I=$O (^DPT(PXDF N,.372,I))  Q:'I  I $ P($G(^(I,0 )),"^",3)  S SDRD0=^( 0) D
  5577   "RTN","PXC EVFI2",133 ,0)
  5578    .S SDCNT= SDCNT+1
  5579   "RTN","PXC EVFI2",134 ,0)
  5580    .S SDDC=$ S('$D(^DIC (31,+SDRD0 ,0)):"",$P (^(0),"^", 4)]"":$P(^ (0),"^",4) ,1:$P(^(0) ,"^"))
  5581   "RTN","PXC EVFI2",135 ,0)
  5582    .W:SDCNT> 1 !
  5583   "RTN","PXC EVFI2",136 ,0)
  5584    .W ?20,$P ($G(^DIC(3 1,+SDRD0,0 )),"^",3), ?25,SDDC,"   (",$P(SD RD0,"^",2) ,"%-",$S($ P(SDRD0,"^ ",3):"SC", 1:""),")"
  5585   "RTN","PXC EVFI2",137 ,0)
  5586    I 'SDCNT  W $S('$O(^ DPT(PXDFN, .372,0)):" None State d",1:"No S ervice Con nected Dis abilities  Listed")
  5587   "RTN","PXC EVFI2",138 ,0)
  5588    ;
  5589   "RTN","PXC EVFIL")
  5590   0^16^B4418 5519^B4361 5497
  5591   "RTN","PXC EVFIL",1,0 )
  5592   PXCEVFIL ; ISL/dee -  Main routi ne to edit  a visit o r v-file e ntry ;11/1 8/2015
  5593   "RTN","PXC EVFIL",2,0 )
  5594    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**9,30 ,22,73,88, 89,104,147 ,124,169,2 10,215**;A ug 12, 199 6;Build 10
  5595   "RTN","PXC EVFIL",3,0 )
  5596    ;
  5597   "RTN","PXC EVFIL",4,0 )
  5598    Q
  5599   "RTN","PXC EVFIL",5,0 )
  5600   EN(PXCECAT ) ; -- mai n entry po int for PX CE pxcecat  EDIT
  5601   "RTN","PXC EVFIL",6,0 )
  5602    I PXCECAT ="SIT"!(PX CECAT="HIS T") D PATI NFO^PXCEPA T(.PXCEPAT ) Q:$D(DIR UT)
  5603   "RTN","PXC EVFIL",7,0 )
  5604    I PXCECAT '="SIT",PX CECAT'="AP PM",PXCECA T'="HIST"  Q:'$D(PXCE FIEN)!'$D( PXCEVIEN)! '$D(PXCEPA T)
  5605   "RTN","PXC EVFIL",8,0 )
  5606    E  Q:(PXC EVIEW["P"& '$D(PXCEPA T))!(PXCEV IEW["H"&'$ D(PXCEHLOC ))!("~H~P~ "'[("~"_$P (PXCEVIEW, "^")_"~"))
  5607   "RTN","PXC EVFIL",9,0 )
  5608    I PXCECAT ="CSTP",$L ($T(DATE^S CDXUTL)),$ $DATE^SCDX UTL(+$G(^A UPNVSIT(PX CEVIEN,0)) ) W !!,$C( 7),"Stop C odes can n ot be adde d to encou nters afte r "_$$FMDA TE^SCDXUTL  Q
  5609   "RTN","PXC EVFIL",10, 0)
  5610    N PXCEQUI T
  5611   "RTN","PXC EVFIL",11, 0)
  5612    I "~CPT~C STP~"[PXCE CAT D  Q:P XCEQUIT
  5613   "RTN","PXC EVFIL",12, 0)
  5614    . S PXCEQ UIT=0
  5615   "RTN","PXC EVFIL",13, 0)
  5616    . I $P($G (^AUPNVSIT (PXCEVIEN, 0)),"^",7) ="E" D  Q: $G(PXCEQUI T)
  5617   "RTN","PXC EVFIL",14, 0)
  5618    .. I PXCE CAT="CSTP"  W !!,$C(7 ),"Histori cal Encoun ters canno t have Sto p Codes."  D WAIT^PXC EHELP S PX CEQUIT=1 Q
  5619   "RTN","PXC EVFIL",15, 0)
  5620    K PXCEQUI T
  5621   "RTN","PXC EVFIL",16, 0)
  5622    D FULL^VA LM1
  5623   "RTN","PXC EVFIL",17, 0)
  5624    ;
  5625   "RTN","PXC EVFIL",18, 0)
  5626    N PXCEVFI L,PXCELOOP ,PXCENOER
  5627   "RTN","PXC EVFIL",19, 0)
  5628    N PXCECOD E,PXCEAUPN ,PXCECATS, PXCECATT,P XCEFILE,PX VICR ; PX* 1*215
  5629   "RTN","PXC EVFIL",20, 0)
  5630    N PXCEPSC C
  5631   "RTN","PXC EVFIL",21, 0)
  5632    S PXCECAT S=$S(PXCEC AT="SIT":" VST",PXCEC AT="APPM": "VST",PXCE CAT="HIST" :"VST",PXC ECAT="CSTP ":"VST",1: PXCECAT)
  5633   "RTN","PXC EVFIL",22, 0)
  5634    S PXCECOD E="PXCE"_$ S(PXCECAT= "IMM":"VIM M",1:PXCEC AT)
  5635   "RTN","PXC EVFIL",23, 0)
  5636    S PXCEAUP N=$P($T(FO RMAT^@PXCE CODE),"~", 5)
  5637   "RTN","PXC EVFIL",24, 0)
  5638    S PXCECAT T=$P($P($T (FORMAT^@P XCECODE)," ;;",2),"~" ,1)
  5639   "RTN","PXC EVFIL",25, 0)
  5640    S PXCEFIL E=$P($T(FO RMAT^@PXCE CODE),"~", 2)
  5641   "RTN","PXC EVFIL",26, 0)
  5642    S (PXCEQU IT,PXVICR) =0
  5643   "RTN","PXC EVFIL",27, 0)
  5644    I '$D(PXC AAFTR),PXC ECAT'="SIT ",PXCECAT' ="APPM",PX CECAT'="HI ST",PXCEFI EN'>0 D AS K^PXCEVFI2 (PXCEVIEN, .PXCEFIEN, PXCEAUPN,P XCECATT,PX CECODE)
  5645   "RTN","PXC EVFIL",28, 0)
  5646    Q:PXCEQUI T
  5647   "RTN","PXC EVFIL",29, 0)
  5648    I PXVICR  S PXCEFIEN ="" D EN(" ICR") Q  ;  PX*1*215
  5649   "RTN","PXC EVFIL",30, 0)
  5650    I PXCECAT '="SIT",PX CECAT'="AP PM",PXCECA T'="HIST"  S PXCELOOP =+PXCEFIEN
  5651   "RTN","PXC EVFIL",31, 0)
  5652    E  S PXCE LOOP=1,PXC EFIEN=PXCE VIEN
  5653   "RTN","PXC EVFIL",32, 0)
  5654    I PXCECAT ="CSTP" D
  5655   "RTN","PXC EVFIL",33, 0)
  5656    . I $$VST APPT^PXUTL 1(PXCEPAT, +^AUPNVSIT (PXCEVIEN, 0),PXCEHLO C,PXCEVIEN ) S PXCELO OP=0
  5657   "RTN","PXC EVFIL",34, 0)
  5658    . E  S PX CELOOP=1
  5659   "RTN","PXC EVFIL",35, 0)
  5660    I $D(PXCA AFTR) S PX CELOOP=1
  5661   "RTN","PXC EVFIL",36, 0)
  5662    F  D DOON E Q:PXCELO OP
  5663   "RTN","PXC EVFIL",37, 0)
  5664    K PXCEFIE N
  5665   "RTN","PXC EVFIL",38, 0)
  5666    Q
  5667   "RTN","PXC EVFIL",39, 0)
  5668    ;
  5669   "RTN","PXC EVFIL",40, 0)
  5670   DOONE ;
  5671   "RTN","PXC EVFIL",41, 0)
  5672    N PXCEUP, PXELAP
  5673   "RTN","PXC EVFIL",42, 0)
  5674    N PXCEAFT R
  5675   "RTN","PXC EVFIL",43, 0)
  5676    D INIT
  5677   "RTN","PXC EVFIL",44, 0)
  5678    Q:PXCEQUI T
  5679   "RTN","PXC EVFIL",45, 0)
  5680   DOONE2 ;
  5681   "RTN","PXC EVFIL",46, 0)
  5682    K PXKERRO R
  5683   "RTN","PXC EVFIL",47, 0)
  5684    S PXCENOE R=0
  5685   "RTN","PXC EVFIL",48, 0)
  5686    I PXCECAT ="IMM" S P XVNEWDA=""  ; PX*1*21 0
  5687   "RTN","PXC EVFIL",49, 0)
  5688    D EDIT^PX CEVFI1
  5689   "RTN","PXC EVFIL",50, 0)
  5690    I 'PXCEQU IT,PXCECAT ="SIT",$P( $G(PXCEAFT R(0)),"^") ]"",$P($G( PXCEAFTR(0 )),"^",22) ]"" D
  5691   "RTN","PXC EVFIL",51, 0)
  5692    . I $D(^D PT(DFN,"S" ,$P(PXCEAF TR(0),"^") ,0)),$P($G (^DPT(DFN, "S",$P(PXC EAFTR(0)," ^"),0)),"^ ")=$P(PXCE AFTR(0),"^ ",22),$P(^ DPT(DFN,"S ",$P(PXCEA FTR(0),"^" ),0),"^",2 )["C" D
  5693   "RTN","PXC EVFIL",52, 0)
  5694    .. S PXCE QUIT=1,$P( PXCEAFTR(0 ),"^")=""
  5695   "RTN","PXC EVFIL",53, 0)
  5696    .. W !,$C (7),"Canno t create e ncounter f or appoint ment date/ time and c linic that  was previ ously canc elled, NOT HING was S TORED"
  5697   "RTN","PXC EVFIL",54, 0)
  5698    .. D WAIT ^PXCEHELP
  5699   "RTN","PXC EVFIL",55, 0)
  5700    I ($P(PXC EAFTR(0)," ^")]"") D
  5701   "RTN","PXC EVFIL",56, 0)
  5702    . I PXCEQ UIT D
  5703   "RTN","PXC EVFIL",57, 0)
  5704    .. I 'PXC EFIEN,PXCE CAT="CPT"  D
  5705   "RTN","PXC EVFIL",58, 0)
  5706    ... D REM OVE(^TMP(" PXK",$J,PX CECAT,1,"I EN"))
  5707   "RTN","PXC EVFIL",59, 0)
  5708    .. I 'PXC ENOER D
  5709   "RTN","PXC EVFIL",60, 0)
  5710    ... I PXC EFIEN>0 D
  5711   "RTN","PXC EVFIL",61, 0)
  5712    .... D:PX CECAT="CPT " MODUPD
  5713   "RTN","PXC EVFIL",62, 0)
  5714    .... W !, $C(7),"The  last entr y did not  have all o f the requ ired data  and NOTHIN G was CHAN GED."
  5715   "RTN","PXC EVFIL",63, 0)
  5716    ... E  W  !,$C(7),"T he last en try did no t have all  of the re quired dat a and NOTH ING was ST ORED."
  5717   "RTN","PXC EVFIL",64, 0)
  5718    ... D WAI T^PXCEHELP
  5719   "RTN","PXC EVFIL",65, 0)
  5720    . E  D SA VE^PXCEVFI 2
  5721   "RTN","PXC EVFIL",66, 0)
  5722    I PXCECAT ="IMM",$G( PXVNEWDA)  D EVIS^PXC EVIS K PXV NEWDA ; PX *1*210
  5723   "RTN","PXC EVFIL",67, 0)
  5724    D EXIT
  5725   "RTN","PXC EVFIL",68, 0)
  5726    Q
  5727   "RTN","PXC EVFIL",69, 0)
  5728    ;
  5729   "RTN","PXC EVFIL",70, 0)
  5730   INIT ; --  init varia bles and l ist array
  5731   "RTN","PXC EVFIL",71, 0)
  5732    N PXCENOD S,PXCEFOR, PXCENODE
  5733   "RTN","PXC EVFIL",72, 0)
  5734    K ^TMP("P XK",$J),PX CEAFTR
  5735   "RTN","PXC EVFIL",73, 0)
  5736    S ^TMP("P XK",$J,"SO R")=PXCESO R
  5737   "RTN","PXC EVFIL",74, 0)
  5738    S ^TMP("P XK",$J,"VS T",1,"IEN" )=PXCEVIEN
  5739   "RTN","PXC EVFIL",75, 0)
  5740    I PXCECAT ="SIT"!(PX CECAT="APP M")!(PXCEC AT="HIST")  D
  5741   "RTN","PXC EVFIL",76, 0)
  5742    . I PXCEV IEN>0 L +@ (PXCEAUPN_ "(PXCEVIEN )"):5 E  W  !!,$C(7), "Cannot ed it at this  time, try  again lat er." D PAU SE^PXCEHEL P S PXCEQU IT=1 Q
  5743   "RTN","PXC EVFIL",77, 0)
  5744    . F PXCEN ODE=0,21,1 50,800,811 ,812 D
  5745   "RTN","PXC EVFIL",78, 0)
  5746    .. S PXCE AFTR(PXCEN ODE)=$S(PX CEVIEN>0:$ G(^AUPNVSI T(PXCEVIEN ,PXCENODE) ),1:"")
  5747   "RTN","PXC EVFIL",79, 0)
  5748    .. S ^TMP ("PXK",$J, "VST",1,PX CENODE,"BE FORE")=PXC EAFTR(PXCE NODE)
  5749   "RTN","PXC EVFIL",80, 0)
  5750    E  D
  5751   "RTN","PXC EVFIL",81, 0)
  5752    . I PXCEF IEN>0 L +@ (PXCEAUPN_ "(PXCEFIEN )"):5 E  W  !!,$C(7), "Cannot ed it at this  time, try  again lat er." D PAU SE^PXCEHEL P S PXCEQU IT=1 Q
  5753   "RTN","PXC EVFIL",82, 0)
  5754    . F PXCEN ODE=0,21,1 50,800,811 ,812 D
  5755   "RTN","PXC EVFIL",83, 0)
  5756    .. S ^TMP ("PXK",$J, "VST",1,PX CENODE,"BE FORE")=$G( ^AUPNVSIT( +PXCEVIEN, PXCENODE))
  5757   "RTN","PXC EVFIL",84, 0)
  5758    .. S ^TMP ("PXK",$J, "VST",1,PX CENODE,"AF TER")=^TMP ("PXK",$J, "VST",1,PX CENODE,"BE FORE")
  5759   "RTN","PXC EVFIL",85, 0)
  5760    . ;
  5761   "RTN","PXC EVFIL",86, 0)
  5762    . S ^TMP( "PXK",$J,P XCECATS,1, "IEN")=PXC EFIEN
  5763   "RTN","PXC EVFIL",87, 0)
  5764    . S PXCEN ODS=$P($T( FORMAT^@PX CECODE),"~ ",3)
  5765   "RTN","PXC EVFIL",88, 0)
  5766    . F PXCEF OR=1:1 S P XCENODE=$P (PXCENODS, ",",PXCEFO R) Q:PXCEN ODE']""  D
  5767   "RTN","PXC EVFIL",89, 0)
  5768    .. I PXCE FIEN>0 D
  5769   "RTN","PXC EVFIL",90, 0)
  5770    ... I PXC ECAT="CPT" ,PXCENODE= 1 D
  5771   "RTN","PXC EVFIL",91, 0)
  5772    .... ;Ret rieve CPT  Modifiers  from multi ple field
  5773   "RTN","PXC EVFIL",92, 0)
  5774    .... S PX CESEQ=0
  5775   "RTN","PXC EVFIL",93, 0)
  5776    .... F  S  PXCESEQ=$ O(@(PXCEAU PN_"(PXCEF IEN,PXCENO DE,PXCESEQ )")) Q:'PX CESEQ  D
  5777   "RTN","PXC EVFIL",94, 0)
  5778    ..... S ^ TMP("PXK", $J,PXCECAT S,1,PXCENO DE,PXCESEQ ,"BEFORE") =$G(@(PXCE AUPN_"(PXC EFIEN,PXCE NODE,PXCES EQ,0)"))
  5779   "RTN","PXC EVFIL",95, 0)
  5780    ..... S P XCEAFTR(PX CENODE,PXC ESEQ)=^TMP ("PXK",$J, PXCECATS,1 ,PXCENODE, PXCESEQ,"B EFORE")
  5781   "RTN","PXC EVFIL",96, 0)
  5782    ... E  D
  5783   "RTN","PXC EVFIL",97, 0)
  5784    .... S ^T MP("PXK",$ J,PXCECATS ,1,PXCENOD E,"BEFORE" )=$G(@(PXC EAUPN_"(PX CEFIEN,PXC ENODE)"))
  5785   "RTN","PXC EVFIL",98, 0)
  5786    .... S PX CEAFTR(PXC ENODE)=^TM P("PXK",$J ,PXCECATS, 1,PXCENODE ,"BEFORE")
  5787   "RTN","PXC EVFIL",99, 0)
  5788    .. E  D
  5789   "RTN","PXC EVFIL",100 ,0)
  5790    ... I PXC ECAT="CPT" ,PXCENODE= 1 D  Q
  5791   "RTN","PXC EVFIL",101 ,0)
  5792    .... S ^T MP("PXK",$ J,PXCECATS ,1,PXCENOD E,1,"BEFOR E")=""
  5793   "RTN","PXC EVFIL",102 ,0)
  5794    ... S ^TM P("PXK",$J ,PXCECATS, 1,PXCENODE ,"BEFORE") =""
  5795   "RTN","PXC EVFIL",103 ,0)
  5796    ... S PXC EAFTR(PXCE NODE)=^TMP ("PXK",$J, PXCECATS,1 ,PXCENODE, "BEFORE")
  5797   "RTN","PXC EVFIL",104 ,0)
  5798    Q:PXCEQUI T
  5799   "RTN","PXC EVFIL",105 ,0)
  5800    ;
  5801   "RTN","PXC EVFIL",106 ,0)
  5802    I PXCEAUP N'="^AUPNV SIT" D
  5803   "RTN","PXC EVFIL",107 ,0)
  5804    . ;Set th e Patient  and Visit  pointers i n the V-Fi le.
  5805   "RTN","PXC EVFIL",108 ,0)
  5806    . S:'$P(P XCEAFTR(0) ,"^",2) $P (PXCEAFTR( 0),"^",2)= PXCEPAT
  5807   "RTN","PXC EVFIL",109 ,0)
  5808    . S:'$P(P XCEAFTR(0) ,"^",3) $P (PXCEAFTR( 0),"^",3)= PXCEVIEN
  5809   "RTN","PXC EVFIL",110 ,0)
  5810    . I $P(PX CEAFTR(0), "^",1)=""  D
  5811   "RTN","PXC EVFIL",111 ,0)
  5812    .. S:'$P( PXCEAFTR(8 12),"^",2)  $P(PXCEAF TR(812),"^ ",2)=PXCEP KG
  5813   "RTN","PXC EVFIL",112 ,0)
  5814    .. S:'$P( PXCEAFTR(8 12),"^",3)  $P(PXCEAF TR(812),"^ ",3)=PXCES OR
  5815   "RTN","PXC EVFIL",113 ,0)
  5816    E  D
  5817   "RTN","PXC EVFIL",114 ,0)
  5818    . ;If new  visit set  package a nd source.
  5819   "RTN","PXC EVFIL",115 ,0)
  5820    . I $P(PX CEAFTR(0), "^",1)=""  D
  5821   "RTN","PXC EVFIL",116 ,0)
  5822    .. S:'$P( PXCEAFTR(8 12),"^",2)  $P(PXCEAF TR(812),"^ ",2)=PXCEP KG
  5823   "RTN","PXC EVFIL",117 ,0)
  5824    .. S:'$P( PXCEAFTR(8 12),"^",3)  $P(PXCEAF TR(812),"^ ",3)=PXCES OR
  5825   "RTN","PXC EVFIL",118 ,0)
  5826    . ;Set th e Patient  in the Vis it for new  visit.
  5827   "RTN","PXC EVFIL",119 ,0)
  5828    . I $G(PX CEAPDT)>0  D
  5829   "RTN","PXC EVFIL",120 ,0)
  5830    .. S:'$P( PXCEAFTR(0 ),"^",1) $ P(PXCEAFTR (0),"^",1) =PXCEAPDT
  5831   "RTN","PXC EVFIL",121 ,0)
  5832    .. I '$P( PXCEAFTR(0 ),"^",21)  D
  5833   "RTN","PXC EVFIL",122 ,0)
  5834    ... ;Get  the ELIGIB ILITY for  the appoin tment
  5835   "RTN","PXC EVFIL",123 ,0)
  5836    ... N PXC EELIG
  5837   "RTN","PXC EVFIL",124 ,0)
  5838    ... S PXC EELIG=$$EL IGIBIL^PXC EVSIT(PXCE PAT,PXCEHL OC,PXCEAPD T)
  5839   "RTN","PXC EVFIL",125 ,0)
  5840    ... S:PXC EELIG>0 $P (PXCEAFTR( 0),"^",21) =PXCEELIG
  5841   "RTN","PXC EVFIL",126 ,0)
  5842    . S:'$P(P XCEAFTR(0) ,"^",5)&($ G(PXCEPAT) >0) $P(PXC EAFTR(0)," ^",5)=PXCE PAT
  5843   "RTN","PXC EVFIL",127 ,0)
  5844    . S:'$P(P XCEAFTR(0) ,"^",22)&( $G(PXCEHLO C)>0) $P(P XCEAFTR(0) ,"^",22)=P XCEHLOC
  5845   "RTN","PXC EVFIL",128 ,0)
  5846    Q
  5847   "RTN","PXC EVFIL",129 ,0)
  5848    ;
  5849   "RTN","PXC EVFIL",130 ,0)
  5850   EXIT ; --  exit code
  5851   "RTN","PXC EVFIL",131 ,0)
  5852    I PXCECAT ="SIT"!(PX CECAT="APP M")!(PXCEC AT="HIST")  L:PXCEVIE N>0 -@(PXC EAUPN_"(PX CEVIEN)"): 30
  5853   "RTN","PXC EVFIL",132 ,0)
  5854    E  L:PXCE FIEN>0 -@( PXCEAUPN_" (PXCEFIEN) "):30
  5855   "RTN","PXC EVFIL",133 ,0)
  5856    S PXCEFIE N=""
  5857   "RTN","PXC EVFIL",134 ,0)
  5858    K ^TMP("P XK",$J)
  5859   "RTN","PXC EVFIL",135 ,0)
  5860    K PXCEAFT R
  5861   "RTN","PXC EVFIL",136 ,0)
  5862    S PXCEQUI T=0
  5863   "RTN","PXC EVFIL",137 ,0)
  5864    Q
  5865   "RTN","PXC EVFIL",138 ,0)
  5866    ;
  5867   "RTN","PXC EVFIL",139 ,0)
  5868   MODUPD ;Up date the M ODIFIER li st for the  currently  edited CP T code whe n all
  5869   "RTN","PXC EVFIL",140 ,0)
  5870    ;the reqi red data i s not ente red.
  5871   "RTN","PXC EVFIL",141 ,0)
  5872    ;
  5873   "RTN","PXC EVFIL",142 ,0)
  5874    N SQ,DA,D IC,DIK,X
  5875   "RTN","PXC EVFIL",143 ,0)
  5876    S SQ=""
  5877   "RTN","PXC EVFIL",144 ,0)
  5878    F  S SQ=$ O(PXCEAFTR (1,SQ)) Q: 'SQ  D
  5879   "RTN","PXC EVFIL",145 ,0)
  5880    .S DA(1)= PXCEFIEN,D A=SQ
  5881   "RTN","PXC EVFIL",146 ,0)
  5882    .S DIK="^ AUPNVCPT(" _DA(1)_"," _1_","
  5883   "RTN","PXC EVFIL",147 ,0)
  5884    .D ^DIK
  5885   "RTN","PXC EVFIL",148 ,0)
  5886    F  S SQ=$ O(^TMP("PX K",$J,"CPT ",1,1,SQ))  Q:'SQ  D
  5887   "RTN","PXC EVFIL",149 ,0)
  5888    .S X=^TMP ("PXK",$J, "CPT",1,1, SQ,"BEFORE ")
  5889   "RTN","PXC EVFIL",150 ,0)
  5890    .Q:X']""
  5891   "RTN","PXC EVFIL",151 ,0)
  5892    .K DD,DO
  5893   "RTN","PXC EVFIL",152 ,0)
  5894    .S DA(1)= PXCEFIEN
  5895   "RTN","PXC EVFIL",153 ,0)
  5896    .S DIC="^ AUPNVCPT(" _DA(1)_"," _1_","
  5897   "RTN","PXC EVFIL",154 ,0)
  5898    .S DIC(0) ="L",DIC(" P")=$P(^DD (9000010.1 8,1,0),"^" ,2)
  5899   "RTN","PXC EVFIL",155 ,0)
  5900    .D FILE^D ICN
  5901   "RTN","PXC EVFIL",156 ,0)
  5902    Q
  5903   "RTN","PXC EVFIL",157 ,0)
  5904    ;
  5905   "RTN","PXC EVFIL",158 ,0)
  5906   REMOVE(DA)  ;REMOVE I NCOMPLETE  CPT ENTRY
  5907   "RTN","PXC EVFIL",159 ,0)
  5908    N DIK
  5909   "RTN","PXC EVFIL",160 ,0)
  5910    S DIK="^A UPNVCPT("
  5911   "RTN","PXC EVFIL",161 ,0)
  5912    I $G(DA)  D ^DIK ;PX *1*124
  5913   "RTN","PXC EVFIL",162 ,0)
  5914    Q
  5915   "RTN","PXC EVIMM")
  5916   0^17^B8610 1677^B8342 3957
  5917   "RTN","PXC EVIMM",1,0 )
  5918   PXCEVIMM ; ISL/dee,SL C/ajb - Us ed to edit  and displ ay V IMMUN IZATION ;0 4/11/2016
  5919   "RTN","PXC EVIMM",2,0 )
  5920    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**27,1 24,199,201 ,210,215** ;Aug 12, 1 996;Build  10
  5921   "RTN","PXC EVIMM",3,0 )
  5922    ;;
  5923   "RTN","PXC EVIMM",4,0 )
  5924    Q
  5925   "RTN","PXC EVIMM",5,0 )
  5926    ;
  5927   "RTN","PXC EVIMM",6,0 )
  5928    ;Line wit h the line  label "FO RMAT"
  5929   "RTN","PXC EVIMM",7,0 )
  5930    ;;Long na me~File Nu mber~Node  Subscripts ~Allow Dup licate ent ries (1=ye s, 0=no)~F ile global  name
  5931   "RTN","PXC EVIMM",8,0 )
  5932    ;     1          2               3                     4                                      5
  5933   "RTN","PXC EVIMM",9,0 )
  5934    ;
  5935   "RTN","PXC EVIMM",10, 0)
  5936    ;Followin g lines:
  5937   "RTN","PXC EVIMM",11, 0)
  5938    ;;Node~Pi ece~,Field  Number~Ed it Label~D isplay Lab el~Display  Routine~E dit Routin e~Help Tex t for DIR( "?")~Set o f PXCEKEYS  that can  Edit~D if  Detail Dis play Only~
  5939   "RTN","PXC EVIMM",12, 0)
  5940    ;  1  ~   2  ~       3      ~      4    ~         5     ~         6      ~      7       ~       8                ~           9                    ~        10
  5941   "RTN","PXC EVIMM",13, 0)
  5942    ;The Disp lay & Edit  routines  are for sp ecial case s.
  5943   "RTN","PXC EVIMM",14, 0)
  5944    ;  (The . 01 field c annot have  a special  edit.)
  5945   "RTN","PXC EVIMM",15, 0)
  5946    ;
  5947   "RTN","PXC EVIMM",16, 0)
  5948   FORMAT ;;I mmunizatio n~9000010. 11~0,2,3,1 1,12,13,14 ,15,16,811 ,812~0~^AU PNVIMM
  5949   "RTN","PXC EVIMM",17, 0)
  5950    ;;0~1~.01 ~Immunizat ion:  ~Imm unization:   ~~~~~B
  5951   "RTN","PXC EVIMM",18, 0)
  5952    ;;13~1~13 01~Informa tion Sourc e:  ~Infor mation Sou rce:  ~~~~ ~D
  5953   "RTN","PXC EVIMM",19, 0)
  5954    ;;12~7~12 07~Lot Num ber:  ~Lot  Number:   ~$$DISPLN^ PXCEVIMM~~ ~~D
  5955   "RTN","PXC EVIMM",20, 0)
  5956    ;;12~2~12 02~Orderin g Provider :  ~Orderi ng Provide r:  ~~EPRO V12^PXCEPR V~~~D
  5957   "RTN","PXC EVIMM",21, 0)
  5958    ;;12~4~12 04~Encount er Provide r:  ~Encou nter Provi der:  ~~EP ROV12^PXCE PRV~~~D
  5959   "RTN","PXC EVIMM",22, 0)
  5960    ;;0~4~.04 ~Series:   ~Series:   ~~~~~D
  5961   "RTN","PXC EVIMM",23, 0)
  5962    ;;0~6~.06 ~Reaction:   ~Reactio n:  ~~~~~D
  5963   "RTN","PXC EVIMM",24, 0)
  5964    ;;0~7~.07 ~Repeat Co ntraindica ted:  ~Rep eat Contra indicated:   ~~ECONTR AI^PXCEVIM M~~~D
  5965   "RTN","PXC EVIMM",25, 0)
  5966    ;;12~1~12 01~Adminis tered Date  and Time:   ~Adminis tered Date  and Time:   ~~~~~D
  5967   "RTN","PXC EVIMM",26, 0)
  5968    ;;12~20~1 220~Warnin g Acknowle dged:  ~Wa rning Ackn owledged:   ~~~~~D
  5969   "RTN","PXC EVIMM",27, 0)
  5970    ;;16~1~16 01~Warning  Override  Reason:  ~ Warning Ov erride Rea son:  ~~~~ ~D
  5971   "RTN","PXC EVIMM",28, 0)
  5972    ;;13~12~1 312~Dose:   ~Dose:  ~ ~~~~D
  5973   "RTN","PXC EVIMM",29, 0)
  5974    ;;13~13~1 313~Dose U nits:  ~Do se Units:   ~~~~~D
  5975   "RTN","PXC EVIMM",30, 0)
  5976    ;;13~2~13 02~Route o f Administ ration:  ~ Route of A dministrat ion:  ~~~~ ~D
  5977   "RTN","PXC EVIMM",31, 0)
  5978    ;;13~3~13 03~Site of  Administr ation (Bod y):  ~Site  of Admini stration ( Body):  ~~ ~~~D
  5979   "RTN","PXC EVIMM",32, 0)
  5980    ;;2~0~2~V IS Offered /Given:  ~ VIS:  ~$$D ISPVIS^PXC EVIS~EVIS^ PXCEVIS~~~ D
  5981   "RTN","PXC EVIMM",33, 0)
  5982    ;;811~1~8 1101~Comme nts:  ~Com ments:  ~~ ~~~D
  5983   "RTN","PXC EVIMM",34, 0)
  5984    ;;13~4~13 04~Primary  Diagnosis :  ~Primar y Diagnosi s:  ~$$DIS PLY01^PXCE POV~EPOV^P XCEVIMM~~S ~
  5985   "RTN","PXC EVIMM",35, 0)
  5986    ;;3~2~.01 ~Other Dia gnosis:  ~ Other Diag nosis:  ~$ $DISPLY01^ PXCEPOV~EP OV2^PXCEVI MM~~S~
  5987   "RTN","PXC EVIMM",36, 0)
  5988    ;;14~3~14 03~Date an d Time Rea d:  ~Date/ Time Read:   ~~EREADD T^PXCEVIMM ~~~D
  5989   "RTN","PXC EVIMM",37, 0)
  5990    ;;14~2~14 02~Reading  in Millim eters (mm) :  ~Readin g in Milli meters (mm ):  ~~~~~D
  5991   "RTN","PXC EVIMM",38, 0)
  5992    ;;14~1~14 01~Results :  ~Result s:  ~~~~~D
  5993   "RTN","PXC EVIMM",39, 0)
  5994    ;;14~4~14 04~Reader:   ~Reader:   ~~EPROV1 2^PXCEPRV~ ~~D
  5995   "RTN","PXC EVIMM",40, 0)
  5996    ;;14~5~14 05~Date an d Time Rea ding Recor ded:  ~Rea ding Recor ded:  ~~~~ ~D
  5997   "RTN","PXC EVIMM",41, 0)
  5998    ;;14~6~14 06~Hours R ead Post-I noculation :  ~Hours  Read Post- Inoculatio n:  ~~~~~D
  5999   "RTN","PXC EVIMM",42, 0)
  6000    ;;15~1~15 01~Reading  Comments:   ~Reading  Comments:   ~~~~~D
  6001   "RTN","PXC EVIMM",43, 0)
  6002    ;;
  6003   "RTN","PXC EVIMM",44, 0)
  6004    ;
  6005   "RTN","PXC EVIMM",45, 0)
  6006    ;Cannot a sk work pr ocessing
  6007   "RTN","PXC EVIMM",46, 0)
  6008    ;;12~2~12 02~Orderin g Provider :  ~Orderi ng Provide r:  ~~EPRO V12^PXCEPR V~~~D
  6009   "RTN","PXC EVIMM",47, 0)
  6010    ;
  6011   "RTN","PXC EVIMM",48, 0)
  6012    ;The inte rface for  AICS to ge t list on  form for h elp.
  6013   "RTN","PXC EVIMM",49, 0)
  6014   INTRFACE ; ;PX SELECT  IMMUNIZAT IONS
  6015   "RTN","PXC EVIMM",50, 0)
  6016    ;
  6017   "RTN","PXC EVIMM",51, 0)
  6018    ;******** ********** ********** ****
  6019   "RTN","PXC EVIMM",52, 0)
  6020    ;Special  cases for  display.
  6021   "RTN","PXC EVIMM",53, 0)
  6022    ;
  6023   "RTN","PXC EVIMM",54, 0)
  6024    ;******** ********** ********** ****
  6025   "RTN","PXC EVIMM",55, 0)
  6026    ;Special  cases for  edit.
  6027   "RTN","PXC EVIMM",56, 0)
  6028    ;
  6029   "RTN","PXC EVIMM",57, 0)
  6030   ECONTRAI ;
  6031   "RTN","PXC EVIMM",58, 0)
  6032    I $P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))'= "" D
  6033   "RTN","PXC EVIMM",59, 0)
  6034    . N DIERR ,PXCEDILF, PXCEINT,PX CEEXT
  6035   "RTN","PXC EVIMM",60, 0)
  6036    . S PXCEI NT=$P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))
  6037   "RTN","PXC EVIMM",61, 0)
  6038    . S PXCEE XT=$$EXTER NAL^DILFD( PXCEFILE,$ P(PXCETEXT ,"~",3),"" ,PXCEINT," PXCEDILF")
  6039   "RTN","PXC EVIMM",62, 0)
  6040    . S DIR(" B")=$S('$D (DIERR):PX CEEXT,1:PX CEINT)
  6041   "RTN","PXC EVIMM",63, 0)
  6042    E  S DIR( "B")="NO"
  6043   "RTN","PXC EVIMM",64, 0)
  6044    S DIR(0)= PXCEFILE_" ,"_$P(PXCE TEXT,"~",3 )_"A"
  6045   "RTN","PXC EVIMM",65, 0)
  6046    S DIR("A" )=$P(PXCET EXT,"~",4)
  6047   "RTN","PXC EVIMM",66, 0)
  6048    S:$P(PXCE TEXT,"~",8 )]"" DIR(" ?")=$P(PXC ETEXT,"~", 8)
  6049   "RTN","PXC EVIMM",67, 0)
  6050    D ^DIR
  6051   "RTN","PXC EVIMM",68, 0)
  6052    K DIR,DA
  6053   "RTN","PXC EVIMM",69, 0)
  6054    I X="@" S  Y="@"
  6055   "RTN","PXC EVIMM",70, 0)
  6056    E  I $D(D TOUT)!$D(D UOUT) S PX CEEND=1 Q
  6057   "RTN","PXC EVIMM",71, 0)
  6058    S $P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))=$ P(Y,"^")
  6059   "RTN","PXC EVIMM",72, 0)
  6060    Q
  6061   "RTN","PXC EVIMM",73, 0)
  6062    ;
  6063   "RTN","PXC EVIMM",74, 0)
  6064   EREADDT ;
  6065   "RTN","PXC EVIMM",75, 0)
  6066    I $P(PXCE AFTR(14)," ^",3)'=""  D
  6067   "RTN","PXC EVIMM",76, 0)
  6068    . N DIERR ,PXCEDILF, PXCEINT,PX CEEXT
  6069   "RTN","PXC EVIMM",77, 0)
  6070    . S PXCEI NT=$P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))
  6071   "RTN","PXC EVIMM",78, 0)
  6072    . S PXCEE XT=$$EXTER NAL^DILFD( PXCEFILE,$ P(PXCETEXT ,"~",3),"" ,PXCEINT," PXCEDILF")
  6073   "RTN","PXC EVIMM",79, 0)
  6074    . S DIR(" B")=$S('$D (DIERR):PX CEEXT,1:PX CEINT)
  6075   "RTN","PXC EVIMM",80, 0)
  6076    S DIR(0)= "9000010.1 1,1403AO"
  6077   "RTN","PXC EVIMM",81, 0)
  6078    S DIR("A" )=$P(PXCET EXT,"~",4)
  6079   "RTN","PXC EVIMM",82, 0)
  6080    S:$P(PXCE TEXT,"~",8 )]"" DIR(" ?")=$P(PXC ETEXT,"~", 8)
  6081   "RTN","PXC EVIMM",83, 0)
  6082    D ^DIR
  6083   "RTN","PXC EVIMM",84, 0)
  6084    K DIR,DA
  6085   "RTN","PXC EVIMM",85, 0)
  6086    I X="@" S  Y="@"
  6087   "RTN","PXC EVIMM",86, 0)
  6088    E  I $D(D TOUT)!$D(D UOUT) S PX CEEND=1 Q
  6089   "RTN","PXC EVIMM",87, 0)
  6090    S $P(PXCE AFTR(14)," ^",3)=$P(Y ,"^")
  6091   "RTN","PXC EVIMM",88, 0)
  6092    N PXVX,X1 ,X2,X3
  6093   "RTN","PXC EVIMM",89, 0)
  6094    S X1=$P(P XCEAFTR(14 ),"^",3) ;  DATE/TIME  READ
  6095   "RTN","PXC EVIMM",90, 0)
  6096    S X2=$P(P XCEAFTR(12 ),"^") ; E VENT DATE  AND TIME
  6097   "RTN","PXC EVIMM",91, 0)
  6098    S X3=2 ;  return dif ference in  seconds
  6099   "RTN","PXC EVIMM",92, 0)
  6100    S PXVX=""
  6101   "RTN","PXC EVIMM",93, 0)
  6102    I $G(X1), $L(X1)>7,$ G(X2),$L(X 2)>7,$G(X2 )'>$G(X1)  S PXVX=$$F MDIFF^XLFD T(X1,X2,X3 )\3600
  6103   "RTN","PXC EVIMM",94, 0)
  6104    I PXVX D  EN^DDIOL(" Hours Read  Post-Inoc ulation:   "_PXVX,"", "!")
  6105   "RTN","PXC EVIMM",95, 0)
  6106    Q
  6107   "RTN","PXC EVIMM",96, 0)
  6108    ;
  6109   "RTN","PXC EVIMM",97, 0)
  6110   ELOT ;
  6111   "RTN","PXC EVIMM",98, 0)
  6112    I $P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))'= "" D
  6113   "RTN","PXC EVIMM",99, 0)
  6114    . N DIERR ,PXCEDILF, PXCEINT,PX CEEXT
  6115   "RTN","PXC EVIMM",100 ,0)
  6116    . S PXCEI NT=$P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))
  6117   "RTN","PXC EVIMM",101 ,0)
  6118    . S PXCEE XT=$$EXTER NAL^DILFD( PXCEFILE,$ P(PXCETEXT ,"~",3),"" ,PXCEINT," PXCEDILF")
  6119   "RTN","PXC EVIMM",102 ,0)
  6120    . S DIR(" B")=$S('$D (DIERR):PX CEEXT,1:PX CEINT)
  6121   "RTN","PXC EVIMM",103 ,0)
  6122    S DIR(0)= "PAO^99999 99.41:EM^K :$P(^(0),U ,3)'=0!($P (^(0),U,4) '=$P(PXCEA FTR(0),U,1 )) X"
  6123   "RTN","PXC EVIMM",104 ,0)
  6124    S DIR("A" )=$P(PXCET EXT,"~",4)
  6125   "RTN","PXC EVIMM",105 ,0)
  6126    S:$P(PXCE TEXT,"~",8 )]"" DIR(" ?")=$P(PXC ETEXT,"~", 8)
  6127   "RTN","PXC EVIMM",106 ,0)
  6128    D ^DIR
  6129   "RTN","PXC EVIMM",107 ,0)
  6130    K DIR,DA
  6131   "RTN","PXC EVIMM",108 ,0)
  6132    I X="@" S  Y="@"
  6133   "RTN","PXC EVIMM",109 ,0)
  6134    E  I $D(D TOUT)!$D(D UOUT) S PX CEEND=1 Q
  6135   "RTN","PXC EVIMM",110 ,0)
  6136    S:Y'<0 $P (PXCEAFTR( $P(PXCETEX T,"~",1)), "^",$P(PXC ETEXT,"~", 2))=$P(Y," ^")
  6137   "RTN","PXC EVIMM",111 ,0)
  6138    Q
  6139   "RTN","PXC EVIMM",112 ,0)
  6140    ;
  6141   "RTN","PXC EVIMM",113 ,0)
  6142   EPOV ;Edit  the Assoc iated DX
  6143   "RTN","PXC EVIMM",114 ,0)
  6144    N PXACS,P XACSREC,PX DATE,PXDEF ,PXDXASK,P XXX
  6145   "RTN","PXC EVIMM",115 ,0)
  6146    S PXDATE= $S($D(PXCE VIEN)=1:$$ CSDATE^PXD XUTL(PXCEV IEN),$D(PX CEAPDT)=1: PXCEAPDT,1 :DT)
  6147   "RTN","PXC EVIMM",116 ,0)
  6148    S PXACSRE C=$$ACTDT^ PXDXUTL(PX DATE),PXAC S=$P(PXACS REC,"^",3)
  6149   "RTN","PXC EVIMM",117 ,0)
  6150    I PXACS[" -" S PXACS =$P(PXACS, "-",1,2)
  6151   "RTN","PXC EVIMM",118 ,0)
  6152    I $P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))'= "" D
  6153   "RTN","PXC EVIMM",119 ,0)
  6154    .N DIERR, PXCEDILF,P XCEINT,PXC EEXT
  6155   "RTN","PXC EVIMM",120 ,0)
  6156    .S PXCEIN T=$P(PXCEA FTR($P(PXC ETEXT,"~", 1)),"^",$P (PXCETEXT, "~",2))
  6157   "RTN","PXC EVIMM",121 ,0)
  6158    .S PXCEEX T=$$EXTERN AL^DILFD(P XCEFILE,$P (PXCETEXT, "~",3),"", PXCEINT,"P XCEDILF")
  6159   "RTN","PXC EVIMM",122 ,0)
  6160    .S DIR("B ")=$S('$D( DIERR):PXC EEXT,1:PXC EINT)
  6161   "RTN","PXC EVIMM",123 ,0)
  6162    I $P(PXAC SREC,U,1)' ="ICD" D
  6163   "RTN","PXC EVIMM",124 ,0)
  6164    . S PXDXA SK=PXACS_"  "_$P(PXCE TEXT,"~",4 )
  6165   "RTN","PXC EVIMM",125 ,0)
  6166    . S PXDEF =$G(DIR("B ")),PXAGAI N=0 D ^PXD SLK I PXXX =-1 S Y=-1  Q
  6167   "RTN","PXC EVIMM",126 ,0)
  6168    . I PXXX= "@" S Y="@ " Q
  6169   "RTN","PXC EVIMM",127 ,0)
  6170    . S Y=$P( $$ICDDATA^ ICDXCODE(" DIAG",$P($ P(PXXX,U,1 ),";",2),P XDATE,"E") ,U,1)
  6171   "RTN","PXC EVIMM",128 ,0)
  6172    I $P(PXAC SREC,U,1)= "ICD" D
  6173   "RTN","PXC EVIMM",129 ,0)
  6174    . S DIR(0 )=PXCEFILE _","_$P(PX CETEXT,"~" ,3)_"A"
  6175   "RTN","PXC EVIMM",130 ,0)
  6176    . S DIR(" A")=PXACS_ " "_$P(PXC ETEXT,"~", 4)
  6177   "RTN","PXC EVIMM",131 ,0)
  6178    . S:$P(PX CETEXT,"~" ,8)]"" DIR ("?")=$P(P XCETEXT,"~ ",8)
  6179   "RTN","PXC EVIMM",132 ,0)
  6180    . D ^DIR
  6181   "RTN","PXC EVIMM",133 ,0)
  6182    K DIR,DA
  6183   "RTN","PXC EVIMM",134 ,0)
  6184    I X="@" S  Y="@" S $ P(PXCEAFTR ($P(PXCETE XT,"~",1)) ,"^",$P(PX CETEXT,"~" ,2))=$P(Y, "^") Q
  6185   "RTN","PXC EVIMM",135 ,0)
  6186    I $D(DTOU T)!$D(DUOU T) S PXCEE ND=1,PXCEQ UIT=1 Q
  6187   "RTN","PXC EVIMM",136 ,0)
  6188    I +Y'>0 S  PXCEEND=1  Q  ;S:$P( PXCETEXT," ~",3)=".08 " PXCEQUIT =1 Q
  6189   "RTN","PXC EVIMM",137 ,0)
  6190    ;See if t his diagno sis is in  the PXCEAF TR(0)
  6191   "RTN","PXC EVIMM",138 ,0)
  6192    I $P(PXCE TEXT,"~",2 )'=1,(+Y=$ P($G(PXCEA FTR(80))," ^",1)) S P XCEEND=1
  6193   "RTN","PXC EVIMM",139 ,0)
  6194    I $P(PXCE TEXT,"~",2 )'=2,(+Y=$ P($G(PXCEA FTR(80))," ^",2)) S P XCEEND=1
  6195   "RTN","PXC EVIMM",140 ,0)
  6196    I $P(PXCE TEXT,"~",2 )'=3,(+Y=$ P($G(PXCEA FTR(80))," ^",3)) S P XCEEND=1
  6197   "RTN","PXC EVIMM",141 ,0)
  6198    I $P(PXCE TEXT,"~",2 )'=4,(+Y=$ P($G(PXCEA FTR(80))," ^",4)) S P XCEEND=1
  6199   "RTN","PXC EVIMM",142 ,0)
  6200    I $P(PXCE TEXT,"~",2 )'=5,(+Y=$ P($G(PXCEA FTR(80))," ^",5)) S P XCEEND=1
  6201   "RTN","PXC EVIMM",143 ,0)
  6202    I $P(PXCE TEXT,"~",2 )'=6,(+Y=$ P($G(PXCEA FTR(80))," ^",6)) S P XCEEND=1
  6203   "RTN","PXC EVIMM",144 ,0)
  6204    I $P(PXCE TEXT,"~",2 )'=7,(+Y=$ P($G(PXCEA FTR(80))," ^",7)) S P XCEEND=1
  6205   "RTN","PXC EVIMM",145 ,0)
  6206    I $P(PXCE TEXT,"~",2 )'=8,(+Y=$ P($G(PXCEA FTR8(80)), "^",8)) S  PXCEEND=1
  6207   "RTN","PXC EVIMM",146 ,0)
  6208    ;
  6209   "RTN","PXC EVIMM",147 ,0)
  6210    ; check f or duplica te diagnos is in OTHE R DIAGNOSI S
  6211   "RTN","PXC EVIMM",148 ,0)
  6212    N DX D:+$ G(PXCEFIEN )
  6213   "RTN","PXC EVIMM",149 ,0)
  6214    . N CNT S  CNT=0 F   S CNT=$O(^ AUPNVIMM(P XCEFIEN,3, CNT)) Q:'+ CNT  D
  6215   "RTN","PXC EVIMM",150 ,0)
  6216    . . S DX( ^AUPNVIMM( PXCEFIEN,3 ,CNT,0))=" "
  6217   "RTN","PXC EVIMM",151 ,0)
  6218    I +$D(DX( +Y)) S PXC EEND=1
  6219   "RTN","PXC EVIMM",152 ,0)
  6220    ;
  6221   "RTN","PXC EVIMM",153 ,0)
  6222    I $G(PXCE END)=1 W ! ,$C(7),"Du plicate Di agnosis is  not allow ed." D WAI T^PXCEHELP  Q
  6223   "RTN","PXC EVIMM",154 ,0)
  6224    S $P(PXCE AFTR($P(PX CETEXT,"~" ,1)),"^",$ P(PXCETEXT ,"~",2))=$ P(Y,"^")
  6225   "RTN","PXC EVIMM",155 ,0)
  6226    D:+Y>0 DI AGNOS^PXCE VFI4(+Y)
  6227   "RTN","PXC EVIMM",156 ,0)
  6228    Q
  6229   "RTN","PXC EVIMM",157 ,0)
  6230   EPOV2 ; ed it OTHER D IAGNOSIS
  6231   "RTN","PXC EVIMM",158 ,0)
  6232    Q:'+$G(PX CEFIEN)
  6233   "RTN","PXC EVIMM",159 ,0)
  6234    N PXACS,P XACSREC,PX DATE,PXDEF ,PXDXASK,P XXX
  6235   "RTN","PXC EVIMM",160 ,0)
  6236    S PXDATE= $S($D(PXCE VIEN)=1:$$ CSDATE^PXD XUTL(PXCEV IEN),$D(PX CEAPDT)=1: PXCEAPDT,1 :DT)
  6237   "RTN","PXC EVIMM",161 ,0)
  6238    S PXACSRE C=$$ACTDT^ PXDXUTL(PX DATE),PXAC S=$P(PXACS REC,"^",3)
  6239   "RTN","PXC EVIMM",162 ,0)
  6240    I PXACS[" -" S PXACS =$P(PXACS, "-",1,2)
  6241   "RTN","PXC EVIMM",163 ,0)
  6242    ; get mul tiple diag nosis
  6243   "RTN","PXC EVIMM",164 ,0)
  6244    N CNT,DX, DXS S CNT= 0 F  S CNT =$O(^AUPNV IMM(PXCEFI EN,3,CNT))  Q:'+CNT   D
  6245   "RTN","PXC EVIMM",165 ,0)
  6246    . S DX(CN T)=^AUPNVI MM(PXCEFIE N,3,CNT,0)
  6247   "RTN","PXC EVIMM",166 ,0)
  6248    . S DXS(D X(CNT))=""
  6249   "RTN","PXC EVIMM",167 ,0)
  6250    I '$D(DX)  S DX(1)=" " ; if no  entries, s how empty  entry to a llow addin g
  6251   "RTN","PXC EVIMM",168 ,0)
  6252    I $P(PXAC SREC,U,1)= "ICD" D
  6253   "RTN","PXC EVIMM",169 ,0)
  6254    . N DIR S  DIR(0)=PX CEFILE_"3, "_$P(PXCET EXT,"~",3) _"A"
  6255   "RTN","PXC EVIMM",170 ,0)
  6256    . S DIR(" A")=PXACS_ " "_$P(PXC ETEXT,"~", 4)
  6257   "RTN","PXC EVIMM",171 ,0)
  6258    . S CNT=0  F  S CNT= $O(DX(CNT) ) Q:'+CNT! ($D(DTOUT) !($D(DUOUT )))  D
  6259   "RTN","PXC EVIMM",172 ,0)
  6260    . . N DA, X,Y
  6261   "RTN","PXC EVIMM",173 ,0)
  6262    . . S DIR ("B")=$$EX TERNAL^DIL FD(PXCEFIL E_3,".01", "",DX(CNT) ,"PXCEDILF ")
  6263   "RTN","PXC EVIMM",174 ,0)
  6264    . . D ^DI R Q:$D(DTO UT)!$D(DUO UT)  Q:X=" "
  6265   "RTN","PXC EVIMM",175 ,0)
  6266    . . I X=" @" W ! I + $$READ("YE ","Are you  sure you  want to re move this  entry","NO ") D DELDX (CNT) Q
  6267   "RTN","PXC EVIMM",176 ,0)
  6268    . . I +$D (DXS(+Y))  W:Y(0)'=DI R("B") !!, $C(7),"Ent ry matches  Other Dia gnosis.  D uplicate D iagnosis i s not allo wed." D:Y( 0)'=DIR("B ") WAIT^PX CEHELP Q   ; quit if  entry alre ady exists
  6269   "RTN","PXC EVIMM",177 ,0)
  6270    . . I +Y= $P($G(^AUP NVIMM(PXCE FIEN,13)), U,4) D  Q   ; quit if  entry mat ches prima ry diagnos is
  6271   "RTN","PXC EVIMM",178 ,0)
  6272    . . . W ! !,$C(7),"E ntry match es Primary  Diagnosis .  Duplica te Diagnos is is not  allowed."  D WAIT^PXC EHELP
  6273   "RTN","PXC EVIMM",179 ,0)
  6274    . . I Y(0 )'=DIR("B" ) D  ; ask  to overwr ite or add  new entry
  6275   "RTN","PXC EVIMM",180 ,0)
  6276    . . . I D IR("B")'=" " N ANS W  ! S ANS=$$ READ("SA^A :ADD;R:REP LACE","Do  you want t o ADD a ne w entry or  REPLACE t he current  entry? ", "ADD") W !
  6277   "RTN","PXC EVIMM",181 ,0)
  6278    . . . I D IR("B")=""  S ANS="A"  ; if no c urrent ent ry, always  add
  6279   "RTN","PXC EVIMM",182 ,0)
  6280    . . . I $ P(ANS,U)=" A"!($P(ANS ,U)="R") D   Q
  6281   "RTN","PXC EVIMM",183 ,0)
  6282    . . . . N  FDA,FDAIE N,ERRMSG,I EN
  6283   "RTN","PXC EVIMM",184 ,0)
  6284    . . . . S  IEN=$S($P (ANS,U)="A ":"+1,"_PX CEFIEN_"," ,1:CNT_"," _PXCEFIEN_ ",")
  6285   "RTN","PXC EVIMM",185 ,0)
  6286    . . . . S  FDA(PXCEF ILE_3,IEN, .01)=+Y
  6287   "RTN","PXC EVIMM",186 ,0)
  6288    . . . . D  DIAGNOS^P XCEVFI4(+Y ,1)
  6289   "RTN","PXC EVIMM",187 ,0)
  6290    . . . . I  '+$G(PXCE QUIT) D UP DATE^DIE(" ","FDA","F DAIEN","ER RMSG")
  6291   "RTN","PXC EVIMM",188 ,0)
  6292    Q
  6293   "RTN","PXC EVIMM",189 ,0)
  6294   DELDX(DA)  ; delete O THER DIAGN OSIS
  6295   "RTN","PXC EVIMM",190 ,0)
  6296    K DXS(DX( DA)),DX(DA )
  6297   "RTN","PXC EVIMM",191 ,0)
  6298    S DA(1)=P XCEFIEN,DI K="^AUPNVI MM("_DA(1) _",3," D ^ DIK W !!," Entry succ essfully r emoved." D  WAIT^PXCE HELP
  6299   "RTN","PXC EVIMM",192 ,0)
  6300    Q
  6301   "RTN","PXC EVIMM",193 ,0)
  6302    ;
  6303   "RTN","PXC EVIMM",194 ,0)
  6304   READ(TYPE, PROMPT,DEF AULT,HELP, SCREEN) ;
  6305   "RTN","PXC EVIMM",195 ,0)
  6306    N DIR,X,Y ,DUOUT,DTO UT,DIRUT S  DIR(0)=TY PE
  6307   "RTN","PXC EVIMM",196 ,0)
  6308    I $D(SCRE EN) S DIR( "S")=SCREE N
  6309   "RTN","PXC EVIMM",197 ,0)
  6310    I $G(PROM PT)]"" S D IR("A")=PR OMPT
  6311   "RTN","PXC EVIMM",198 ,0)
  6312    I $G(DEFA ULT)]"" S  DIR("B")=D EFAULT
  6313   "RTN","PXC EVIMM",199 ,0)
  6314    I $D(HELP ) S DIR("? ")=HELP
  6315   "RTN","PXC EVIMM",200 ,0)
  6316    D ^DIR
  6317   "RTN","PXC EVIMM",201 ,0)
  6318    I $G(X)=" @" S Y="@"  G READX
  6319   "RTN","PXC EVIMM",202 ,0)
  6320    I Y]"",($ L($G(Y),U) '=2) S Y=Y _U_$G(Y(0) ,Y)
  6321   "RTN","PXC EVIMM",203 ,0)
  6322   READX Q Y
  6323   "RTN","PXC EVIMM",204 ,0)
  6324    ;
  6325   "RTN","PXC EVIMM",205 ,0)
  6326    ;******** ********** ********** ****
  6327   "RTN","PXC EVIMM",206 ,0)
  6328    ;Display  text for t he .01 fie ld which i s a pointe r to Immun ization.
  6329   "RTN","PXC EVIMM",207 ,0)
  6330    ;(Must ha ve is call ed by ASK^ PXCEVFI2 a nd DEL^PXC EVFI2.)
  6331   "RTN","PXC EVIMM",208 ,0)
  6332   DISPLY01(P XCEIMM) ;
  6333   "RTN","PXC EVIMM",209 ,0)
  6334    N DIERR,P XCEDILF,PX CEINT,PXCE EXT
  6335   "RTN","PXC EVIMM",210 ,0)
  6336    S PXCEINT =$P(PXCEIM M,"^",1)
  6337   "RTN","PXC EVIMM",211 ,0)
  6338    S PXCEEXT =$$EXTERNA L^DILFD(90 00010.11,. 01,"",PXCE INT,"PXCED ILF")
  6339   "RTN","PXC EVIMM",212 ,0)
  6340    Q $S('$D( DIERR):PXC EEXT,1:PXC EINT)
  6341   "RTN","PXC EVIMM",213 ,0)
  6342    ;
  6343   "RTN","PXC EVIMM",214 ,0)
  6344   DISPLN(PXC EINT) ; di splay lot  number wit h manufact urer
  6345   "RTN","PXC EVIMM",215 ,0)
  6346    N PXCEDIL F,PXCEEXT, PXV2,PXVMA N
  6347   "RTN","PXC EVIMM",216 ,0)
  6348    S PXCEEXT =$$EXTERNA L^DILFD(90 00010.11,1 207,"",PXC EINT,"PXCE DILF")
  6349   "RTN","PXC EVIMM",217 ,0)
  6350    S PXV2=$P (^AUTTIML( PXCEINT,0) ,"^",2),PX VMAN=$$EXT ERNAL^DILF D(9999999. 41,.02,"", PXV2,"PXCE DILF")
  6351   "RTN","PXC EVIMM",218 ,0)
  6352    Q $S('$D( DIERR):PXC EEXT_"      "_PXVMAN, 1:PXCEINT)
  6353   "RTN","PXC EVIMM",219 ,0)
  6354    ;
  6355   "RTN","PXK ENC")
  6356   0^4^B29334 197^B29230 371
  6357   "RTN","PXK ENC",1,0)
  6358   PXKENC ;IS L/dee,ESW  - Builds t he array o f all enco unter data  for the e vent point  ;11/09/15   11:17
  6359   "RTN","PXK ENC",2,0)
  6360    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**15,2 2,73,108,1 43,183,210 ,215**;Aug  12, 1996; Build 10
  6361   "RTN","PXK ENC",3,0)
  6362    Q
  6363   "RTN","PXK ENC",4,0)
  6364    ;
  6365   "RTN","PXK ENC",5,0)
  6366   GETENC(DFN ,ENCDT,HLO C) ;Get al l of the e ncounter d ata
  6367   "RTN","PXK ENC",6,0)
  6368    ;Paramete rs:
  6369   "RTN","PXK ENC",7,0)
  6370    ;  DFN     Pointer t o the pati ent (#9000 001)
  6371   "RTN","PXK ENC",8,0)
  6372    ;  ENCDT   Date/Time  of the en counter in  Fileman f ormat
  6373   "RTN","PXK ENC",9,0)
  6374    ;  HLOC    Pointer t o Hospital  Location  (#44)
  6375   "RTN","PXK ENC",10,0)
  6376    ;
  6377   "RTN","PXK ENC",11,0)
  6378    ;Returns:
  6379   "RTN","PXK ENC",12,0)
  6380    ;  -2  if  called in correctly
  6381   "RTN","PXK ENC",13,0)
  6382    ;  -1  if  could not  find enco unter
  6383   "RTN","PXK ENC",14,0)
  6384    ;  >0  Vi sit ien(s)  separated  by ^
  6385   "RTN","PXK ENC",15,0)
  6386    ;
  6387   "RTN","PXK ENC",16,0)
  6388    ;  The en counter is  returned  in the arr ay
  6389   "RTN","PXK ENC",17,0)
  6390    ;    ^TMP ("PXKENC", $J,pointer  to visit)
  6391   "RTN","PXK ENC",18,0)
  6392    ;  may co ntain more  than one  visit
  6393   "RTN","PXK ENC",19,0)
  6394    ;
  6395   "RTN","PXK ENC",20,0)
  6396    N VISITIE N,REVDT,RE TURN
  6397   "RTN","PXK ENC",21,0)
  6398    K ^TMP("P XKENC",$J)
  6399   "RTN","PXK ENC",22,0)
  6400    S RETURN= -1
  6401   "RTN","PXK ENC",23,0)
  6402    Q:DFN'>0! (ENCDT<180 0000)!(HLO C'>0) -2
  6403   "RTN","PXK ENC",24,0)
  6404    S REVDT=( 9999999-$P (+ENCDT,". ",1))_$S($ P(+ENCDT," .",2)'="": "."_$P(+EN CDT,".",2) ,1:"")
  6405   "RTN","PXK ENC",25,0)
  6406    S VISITIE N=0
  6407   "RTN","PXK ENC",26,0)
  6408    F  S VISI TIEN=$O(^A UPNVSIT("A A",+DFN,RE VDT,VISITI EN)) Q:'VI SITIEN  D
  6409   "RTN","PXK ENC",27,0)
  6410    . I $P($G (^AUPNVSIT (VISITIEN, 0)),"^",22 )=HLOC,"C~ S"'[$P($G( ^AUPNVSIT( VISITIEN,1 50)),"^",3 ) D
  6411   "RTN","PXK ENC",28,0)
  6412    .. D ENCE VENT(VISIT IEN,1)
  6413   "RTN","PXK ENC",29,0)
  6414    .. I RETU RN<1 S RET URN=VISITI EN
  6415   "RTN","PXK ENC",30,0)
  6416    .. E  S R ETURN=RETU RN_"^"_VIS ITIEN
  6417   "RTN","PXK ENC",31,0)
  6418    Q RETURN
  6419   "RTN","PXK ENC",32,0)
  6420    ;
  6421   "RTN","PXK ENC",33,0)
  6422   ENCEVENT(V ISITIEN,DO NTKILL) ;C reate the  ^TMP("PXKE NC",$J, ar ray of all  the
  6423   "RTN","PXK ENC",34,0)
  6424    ;  inform ation abou t one enco unter.
  6425   "RTN","PXK ENC",35,0)
  6426    ;Paramete rs:
  6427   "RTN","PXK ENC",36,0)
  6428    ;  VISITI EN  Pointe r to the V isit (#900 0010)
  6429   "RTN","PXK ENC",37,0)
  6430    ;  DONOTK ILL is 1 i f the outp ut array i s not to b e killed b efore used
  6431   "RTN","PXK ENC",38,0)
  6432    ;             and 0  or null if  the array  is to be  killed (cl eaned out)
  6433   "RTN","PXK ENC",39,0)
  6434    ;
  6435   "RTN","PXK ENC",40,0)
  6436    ;  The en counter is  returned  in the arr ay
  6437   "RTN","PXK ENC",41,0)
  6438    ;    ^TMP ("PXKENC", $J,pointer  to visit)
  6439   "RTN","PXK ENC",42,0)
  6440    ;
  6441   "RTN","PXK ENC",43,0)
  6442    I $G(VISI TIEN)'>0 Q   ;PX/183
  6443   "RTN","PXK ENC",44,0)
  6444    I '$D(^AU PNVSIT(VIS ITIEN)) Q
  6445   "RTN","PXK ENC",45,0)
  6446    K:'$G(DON TKILL) ^TM P("PXKENC" ,$J)
  6447   "RTN","PXK ENC",46,0)
  6448    N PXKCNT, PXKROOT
  6449   "RTN","PXK ENC",47,0)
  6450    S PXKROOT =$NA(@("^T MP(""PXKEN C"",$J,"_V ISITIEN_") "))
  6451   "RTN","PXK ENC",48,0)
  6452    ;
  6453   "RTN","PXK ENC",49,0)
  6454    N IEN,FIL E,VFILE,FI LESTR,PXKN ODE
  6455   "RTN","PXK ENC",50,0)
  6456    F FILE="S IT","CSTP" ,"PRV","PO V","CPT"," TRT","IMM" ,"PED","SK ","HF","XA M","ICR" D
  6457   "RTN","PXK ENC",51,0)
  6458    . S FILES TR=$S(FILE ="SIT":"VS T",1:FILE)
  6459   "RTN","PXK ENC",52,0)
  6460    . S VFILE =$P($T(GLO BAL^@("PXK F"_$S(FILE ="SIT":"VS T",FILE="C STP":"VST" ,1:FILE))) ,";;",2)
  6461   "RTN","PXK ENC",53,0)
  6462    . I FILE= "SIT" D
  6463   "RTN","PXK ENC",54,0)
  6464    .. S IEN= VISITIEN
  6465   "RTN","PXK ENC",55,0)
  6466    .. S PXKN ODE=""
  6467   "RTN","PXK ENC",56,0)
  6468    .. F  S P XKNODE=$O( @VFILE@(IE N,PXKNODE) ) Q:PXKNOD E=""  D
  6469   "RTN","PXK ENC",57,0)
  6470    ... S @PX KROOT@(FIL ESTR,IEN,P XKNODE)=@V FILE@(IEN, PXKNODE)
  6471   "RTN","PXK ENC",58,0)
  6472    . E  D
  6473   "RTN","PXK ENC",59,0)
  6474    .. I FILE ="PRV" D E VALD(VISIT IEN,PXKROO T,VFILE,FI LESTR)
  6475   "RTN","PXK ENC",60,0)
  6476    .. I FILE '="PRV" S  IEN="" F   S IEN=$O(@ VFILE@("AD ",VISITIEN ,IEN)) Q:' IEN  D
  6477   "RTN","PXK ENC",61,0)
  6478    ... I FIL E="CSTP"," SC"'[$P($G (@VFILE@(I EN,150))," ^",3) Q
  6479   "RTN","PXK ENC",62,0)
  6480    ... S PXK NODE=""
  6481   "RTN","PXK ENC",63,0)
  6482    ... F  S  PXKNODE=$O (@VFILE@(I EN,PXKNODE )) Q:PXKNO DE=""  D:P XKNODE'=80 1
  6483   "RTN","PXK ENC",64,0)
  6484    .... ;for  cpt modif iers
  6485   "RTN","PXK ENC",65,0)
  6486    .... I FI LE="CPT",P XKNODE=1 D   Q
  6487   "RTN","PXK ENC",66,0)
  6488    ..... S @ PXKROOT@(F ILESTR,IEN ,PXKNODE,0 )=$G(@VFIL E@(IEN,PXK NODE,0))
  6489   "RTN","PXK ENC",67,0)
  6490    ..... N S UBIEN
  6491   "RTN","PXK ENC",68,0)
  6492    ..... S S UBIEN=0
  6493   "RTN","PXK ENC",69,0)
  6494    ..... F   S SUBIEN=$ O(@VFILE@( IEN,PXKNOD E,SUBIEN))  Q:SUBIEN= ""  D
  6495   "RTN","PXK ENC",70,0)
  6496    ...... S  @PXKROOT@( FILESTR,IE N,PXKNODE, SUBIEN,0)= $G(@VFILE@ (IEN,PXKNO DE,SUBIEN, 0))
  6497   "RTN","PXK ENC",71,0)
  6498    .... ;for  immunizat in multipl es
  6499   "RTN","PXK ENC",72,0)
  6500    .... I FI LE="IMM",P XKNODE?1(1 "2",1"3",1 "11") D  Q
  6501   "RTN","PXK ENC",73,0)
  6502    ..... N S UBIEN
  6503   "RTN","PXK ENC",74,0)
  6504    ..... S S UBIEN=0
  6505   "RTN","PXK ENC",75,0)
  6506    ..... F   S SUBIEN=$ O(@VFILE@( IEN,PXKNOD E,SUBIEN))  Q:'SUBIEN   D
  6507   "RTN","PXK ENC",76,0)
  6508    ...... S  @PXKROOT@( FILESTR,IE N,PXKNODE, SUBIEN,0)= $G(@VFILE@ (IEN,PXKNO DE,SUBIEN, 0))
  6509   "RTN","PXK ENC",77,0)
  6510    .... ;
  6511   "RTN","PXK ENC",78,0)
  6512    .... S @P XKROOT@(FI LESTR,IEN, PXKNODE)=$ G(@VFILE@( IEN,PXKNOD E))
  6513   "RTN","PXK ENC",79,0)
  6514    Q
  6515   "RTN","PXK ENC",80,0)
  6516   EVALD(VISI TIEN,PXKRO OT,VFILE,F ILESTR) ;e valuation  for duplic ate provid ers
  6517   "RTN","PXK ENC",81,0)
  6518    N CNT,PR, PRS,PS,PP, PRV,STR
  6519   "RTN","PXK ENC",82,0)
  6520    S IEN="", CNT=0
  6521   "RTN","PXK ENC",83,0)
  6522    F  S IEN= $O(@VFILE@ ("AD",VISI TIEN,IEN))  Q:'IEN  D
  6523   "RTN","PXK ENC",84,0)
  6524    .S STR=@V FILE@(IEN, 0),PR=+STR ,PS=$P(STR ,U,4)
  6525   "RTN","PXK ENC",85,0)
  6526    .I PS="P" ,'CNT S PR V=PR,CNT=1  D PXKNODE (VFILE,FIL ESTR,IEN,P XKROOT)
  6527   "RTN","PXK ENC",86,0)
  6528    .I PS="S"  S PRS(PR, IEN)="" D  PXKNODE(VF ILE,FILEST R,IEN,PXKR OOT)
  6529   "RTN","PXK ENC",87,0)
  6530    .Q
  6531   "RTN","PXK ENC",88,0)
  6532    S PR="" F   S PR=$O( PRS(PR)) Q :PR=""  S  IEN="" D
  6533   "RTN","PXK ENC",89,0)
  6534    .F PP=1:1  S IEN=$O( PRS(PR,IEN )) Q:IEN=" "  D
  6535   "RTN","PXK ENC",90,0)
  6536    ..I PR=$G (PRV) K @P XKROOT@(FI LESTR,IEN)  Q
  6537   "RTN","PXK ENC",91,0)
  6538    ..I PP>1  K @PXKROOT @(FILESTR, IEN)
  6539   "RTN","PXK ENC",92,0)
  6540    Q
  6541   "RTN","PXK ENC",93,0)
  6542   PXKNODE(VF ILE,FILEST R,IEN,PXKR OOT) ;
  6543   "RTN","PXK ENC",94,0)
  6544    N STRR S  PXKNODE=""
  6545   "RTN","PXK ENC",95,0)
  6546    F  S PXKN ODE=$O(@VF ILE@(IEN,P XKNODE)) Q :PXKNODE=" "  D:PXKNO DE'=801
  6547   "RTN","PXK ENC",96,0)
  6548    . I $E($P ($P(PXKROO T,","),"(" ,2),2,7)=" PXKENC" D
  6549   "RTN","PXK ENC",97,0)
  6550    ..; ENCEV ENT called
  6551   "RTN","PXK ENC",98,0)
  6552    .. S @PXK ROOT@(FILE STR,IEN,PX KNODE)=$G( @VFILE@(IE N,PXKNODE) )
  6553   "RTN","PXK ENC",99,0)
  6554    . I $P(PX KROOT,"""" ,2)="PXKCO ",'$D(@PXK ROOT@(FILE STR,IEN))  D
  6555   "RTN","PXK ENC",100,0 )
  6556    ..; COEVE NT called
  6557   "RTN","PXK ENC",101,0 )
  6558    .. F STRR ="BEFORE", "AFTER" D
  6559   "RTN","PXK ENC",102,0 )
  6560    ... S @PX KROOT@(FIL ESTR,IEN,P XKNODE,STR R)=$G(@VFI LE@(IEN,PX KNODE))
  6561   "RTN","PXK ENC",103,0 )
  6562    Q
  6563   "RTN","PXK ENC",104,0 )
  6564    ;
  6565   "RTN","PXK ENC",105,0 )
  6566   COEVENT(VI SITIEN) ;A dd to the  ^TMP("PXKC O",$J, arr ay all of  the
  6567   "RTN","PXK ENC",106,0 )
  6568    ;   infor mation tha t is not a lready the re.
  6569   "RTN","PXK ENC",107,0 )
  6570    I '$D(^AU PNVSIT(VIS ITIEN)) Q
  6571   "RTN","PXK ENC",108,0 )
  6572    N PXKCNT, PXKROOT
  6573   "RTN","PXK ENC",109,0 )
  6574    S PXKROOT =$NA(@("^T MP(""PXKCO "",$J,"_VI SITIEN_")" ))
  6575   "RTN","PXK ENC",110,0 )
  6576    ;
  6577   "RTN","PXK ENC",111,0 )
  6578    N IEN,FIL E,VFILE,PX KNODE
  6579   "RTN","PXK ENC",112,0 )
  6580    F FILE="C STP","PRV" ,"POV","CP T","TRT"," IMM","PED" ,"SK","HF" ,"XAM","IC R" D
  6581   "RTN","PXK ENC",113,0 )
  6582    . S VFILE =$P($T(GLO BAL^@("PXK F"_$S(FILE ="CSTP":"V ST",1:FILE ))),";;",2 )
  6583   "RTN","PXK ENC",114,0 )
  6584    . I FILE= "PRV" D EV ALD(VISITI EN,PXKROOT ,VFILE,FIL E)
  6585   "RTN","PXK ENC",115,0 )
  6586    . I FILE' ="PRV" S I EN="" F  S  IEN=$O(@V FILE@("AD" ,VISITIEN, IEN)) Q:'I EN  D
  6587   "RTN","PXK ENC",116,0 )
  6588    .. I FILE ="CSTP","S C"'[$P($G( @VFILE@(IE N,150)),"^ ",3) Q
  6589   "RTN","PXK ENC",117,0 )
  6590    .. S PXKN ODE=""
  6591   "RTN","PXK ENC",118,0 )
  6592    .. I '$D( @PXKROOT@( FILE,IEN))  D
  6593   "RTN","PXK ENC",119,0 )
  6594    ... F  S  PXKNODE=$O (@VFILE@(I EN,PXKNODE )) Q:PXKNO DE=""  D:P XKNODE'=80 1
  6595   "RTN","PXK ENC",120,0 )
  6596    .... ;
  6597   "RTN","PXK ENC",121,0 )
  6598    .... I FI LE="IMM",P XKNODE?1(1 "2",1"3",1 "11") D  Q
  6599   "RTN","PXK ENC",122,0 )
  6600    ..... N S UBIEN,VAL
  6601   "RTN","PXK ENC",123,0 )
  6602    ..... S S UBIEN=0
  6603   "RTN","PXK ENC",124,0 )
  6604    ..... F   S SUBIEN=$ O(@VFILE@( IEN,PXKNOD E,SUBIEN))  Q:'SUBIEN   D
  6605   "RTN","PXK ENC",125,0 )
  6606    ...... S  VAL=$G(@VF ILE@(IEN,P XKNODE,SUB IEN,0))
  6607   "RTN","PXK ENC",126,0 )
  6608    ...... S  @PXKROOT@( FILE,IEN,P XKNODE,"BE FORE",SUBI EN)=VAL
  6609   "RTN","PXK ENC",127,0 )
  6610    ...... S  @PXKROOT@( FILE,IEN,P XKNODE,"AF TER",SUBIE N)=VAL
  6611   "RTN","PXK ENC",128,0 )
  6612    .... ;
  6613   "RTN","PXK ENC",129,0 )
  6614    .... I FI LE="CPT",P XKNODE=1 D   Q
  6615   "RTN","PXK ENC",130,0 )
  6616    ..... N S UBIEN,MOD
  6617   "RTN","PXK ENC",131,0 )
  6618    ..... S S UBIEN=0
  6619   "RTN","PXK ENC",132,0 )
  6620    ..... F   S SUBIEN=$ O(@VFILE@( IEN,PXKNOD E,SUBIEN))  Q:'SUBIEN   D
  6621   "RTN","PXK ENC",133,0 )
  6622    ...... S  MOD=@VFILE @(IEN,PXKN ODE,SUBIEN ,0)
  6623   "RTN","PXK ENC",134,0 )
  6624    ...... S  @PXKROOT@( FILE,IEN,P XKNODE,"BE FORE",MOD) =""
  6625   "RTN","PXK ENC",135,0 )
  6626    ...... S  @PXKROOT@( FILE,IEN,P XKNODE,"AF TER",MOD)= ""
  6627   "RTN","PXK ENC",136,0 )
  6628    .... ;
  6629   "RTN","PXK ENC",137,0 )
  6630    .... S @P XKROOT@(FI LE,IEN,PXK NODE,"BEFO RE")=$G(@V FILE@(IEN, PXKNODE))
  6631   "RTN","PXK ENC",138,0 )
  6632    .... S @P XKROOT@(FI LE,IEN,PXK NODE,"AFTE R")=$G(@VF ILE@(IEN,P XKNODE))
  6633   "RTN","PXK ENC",139,0 )
  6634    Q
  6635   "RTN","PXK ENC",140,0 )
  6636    ;
  6637   "RTN","PXK FCPT1")
  6638   0^30^B2465 6697^B2383 8795
  6639   "RTN","PXK FCPT1",1,0 )
  6640   PXKFCPT1 ; ISL/JVS,SC K - PROCED URES Routi ne #2 ;02/ 03/16  11: 57
  6641   "RTN","PXK FCPT1",2,0 )
  6642    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**11,7 3,124,194, 209,215**; Aug 12, 19 96;Build 1 0
  6643   "RTN","PXK FCPT1",3,0 )
  6644    ;
  6645   "RTN","PXK FCPT1",4,0 )
  6646    ;
  6647   "RTN","PXK FCPT1",5,0 )
  6648   IMM ;
  6649   "RTN","PXK FCPT1",6,0 )
  6650    N PXKSEQ1
  6651   "RTN","PXK FCPT1",7,0 )
  6652    I PXKFGAD =1 D IMMAD D
  6653   "RTN","PXK FCPT1",8,0 )
  6654    I PXKFGDE =1 D IMMDE L
  6655   "RTN","PXK FCPT1",9,0 )
  6656    Q
  6657   "RTN","PXK FCPT1",10, 0)
  6658   IMMADD ;
  6659   "RTN","PXK FCPT1",11, 0)
  6660    S PXKKK=" "
  6661   "RTN","PXK FCPT1",12, 0)
  6662    S PXKSEQ1 =PXKSEQ+PX KXX
  6663   "RTN","PXK FCPT1",13, 0)
  6664    S PXKCPT= $P($P(PXKP XD(PXKX)," ^",2),";")
  6665   "RTN","PXK FCPT1",14, 0)
  6666   POVNAR ;
  6667   "RTN","PXK FCPT1",15, 0)
  6668    N PXK1
  6669   "RTN","PXK FCPT1",16, 0)
  6670    ;K ^UTILI TY("DIQ1", $J)
  6671   "RTN","PXK FCPT1",17, 0)
  6672    ;S DIC=81 ,DA=PXKCPT ,DR=2 D EN ^DIQ1
  6673   "RTN","PXK FCPT1",18, 0)
  6674    ;S PXKCPT N=$G(^UTIL ITY("DIQ1" ,$J,81,DA, 2))
  6675   "RTN","PXK FCPT1",19, 0)
  6676    ;K ^UTILI TY("DIQ1", $J),DIC,DA ,DR D
  6677   "RTN","PXK FCPT1",20, 0)
  6678    S PXK1=$$ CPT^ICPTCO D(PXKCPT)
  6679   "RTN","PXK FCPT1",21, 0)
  6680    S PXKCPTN =$P(PXK1,U ,3) D
  6681   "RTN","PXK FCPT1",22, 0)
  6682    .Q:PXKCPT N=""  I $D (^AUTNPOV( "B",PXKCPT N)) S PXKC PTN=$O(^AU TNPOV("B", PXKCPTN,0) )
  6683   "RTN","PXK FCPT1",23, 0)
  6684    ;
  6685   "RTN","PXK FCPT1",24, 0)
  6686   QUANTIT S  PXKQUN=1,P XSTOP=0
  6687   "RTN","PXK FCPT1",25, 0)
  6688    S PXXX=0
  6689   "RTN","PXK FCPT1",26, 0)
  6690    F  S PXXX =$O(^AUPNV CPT("AD",P XKAV(0,3), PXXX)) Q:P XXX=""  D   Q:$G(PXST OP)
  6691   "RTN","PXK FCPT1",27, 0)
  6692    .I +$P(^A UPNVCPT(PX XX,0),"^") =PXKCPT D
  6693   "RTN","PXK FCPT1",28, 0)
  6694    ..; PX*1* 215 - If c ode alread y exists,  quit; don' t incremen t qty
  6695   "RTN","PXK FCPT1",29, 0)
  6696    ..;S PXKQ UN=($P(^AU PNVCPT(PXX X,0),"^",1 6)+1)
  6697   "RTN","PXK FCPT1",30, 0)
  6698    ..S PXSTO P=1
  6699   "RTN","PXK FCPT1",31, 0)
  6700    ..;S PXKK K=PXXX
  6701   "RTN","PXK FCPT1",32, 0)
  6702    ..;S ^TMP ("PXKSAVE" ,$J,"CPT", PXKSEQ1,0, "BEFORE")= $G(^AUPNVC PT(PXXX,0) )
  6703   "RTN","PXK FCPT1",33, 0)
  6704    I $G(PXST OP) Q
  6705   "RTN","PXK FCPT1",34, 0)
  6706    K PXSTOP
  6707   "RTN","PXK FCPT1",35, 0)
  6708   CATEGOR ;
  6709   "RTN","PXK FCPT1",36, 0)
  6710    N PXKSEQ2 ,PXK1,PXK2
  6711   "RTN","PXK FCPT1",37, 0)
  6712    S PXKCPTT (1)=$P(PXK CPT,"^",1)
  6713   "RTN","PXK FCPT1",38, 0)
  6714    ;K ^UTILI TY("DIQ1", $J)
  6715   "RTN","PXK FCPT1",39, 0)
  6716    ;S DIC=81 ,DA=PXKCPT T(1),DR=3  D EN^DIQ1
  6717   "RTN","PXK FCPT1",40, 0)
  6718    S PXK1=$P ($$CPT^ICP TCOD(PXKCP TT(1)),U,4 )
  6719   "RTN","PXK FCPT1",41, 0)
  6720    S PXK2=$$ GET1^DIQ(8 1.1,PXK1,. 01)
  6721   "RTN","PXK FCPT1",42, 0)
  6722    Q:PXK2=""
  6723   "RTN","PXK FCPT1",43, 0)
  6724    ;Q:$G(^UT ILITY("DIQ 1",$J,81,D A,3))=""
  6725   "RTN","PXK FCPT1",44, 0)
  6726    ;S PXKCPT T(4.1)=$G( ^UTILITY(" DIQ1",$J,8 1,DA,3))
  6727   "RTN","PXK FCPT1",45, 0)
  6728    S PXKCPTT (4.1)=PXK2
  6729   "RTN","PXK FCPT1",46, 0)
  6730    S PXKCPTT (5)=$E(PXK CPTT(4.1), 1,30)
  6731   "RTN","PXK FCPT1",47, 0)
  6732    S PXKCPTT (6)=$O(^AU TNPOV("B", PXKCPTT(5) ,0))
  6733   "RTN","PXK FCPT1",48, 0)
  6734    S PXKPCA= $S(PXKCPTT (6)="":PXK CPTT(5),PX KCPTT(6)'= "":PXKCPTT (6),1:"")
  6735   "RTN","PXK FCPT1",49, 0)
  6736    K PXKCPTT  ;,^UTILIT Y("DIQ1",$ J),DIC,DR, DA
  6737   "RTN","PXK FCPT1",50, 0)
  6738    ;PX*1*124
  6739   "RTN","PXK FCPT1",51, 0)
  6740    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,0,"AF TER")=$G(P XKCPT)_"^" _$G(PXKAV( 0,2))_"^"_ $G(PXKAV(0 ,3))_"^"_$ G(PXKCPTN) _"^"_$G(PX KAV(0,8))_ "^^^^"
  6741   "RTN","PXK FCPT1",52, 0)
  6742    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,0,"AF TER")=^TMP ("PXKSAVE" ,$J,"CPT", PXKSEQ1,0, "AFTER")_$ G(PXKAV(0, 9))_"^"_$G (PXKAV(0,1 0))_"^"_$G (PXKAV(0,1 1))_"^"_$G (PXKAV(0,1 2))_"^"_$G (PXKAV(0,1 3))_"^"_$G (PXKAV(0,1 4))_"^"_$G (PXKAV(0,1 5))_"^"_$G (PXKQUN)
  6743   "RTN","PXK FCPT1",53, 0)
  6744    S PXKSEQ2 =0
  6745   "RTN","PXK FCPT1",54, 0)
  6746    F  S PXKS EQ2=$O(PXK AFT(1,PXKS EQ2)) Q:'P XKSEQ2  D
  6747   "RTN","PXK FCPT1",55, 0)
  6748    .S ^TMP(" PXKSAVE",$ J,"CPT",PX KSEQ1,1,PX KSEQ2,"AFT ER")=PXKAF T(1,PXKSEQ 2)
  6749   "RTN","PXK FCPT1",56, 0)
  6750    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,12,"A FTER")=$G( PXKAV(12,1 ))_"^"_$G( PXKAV(12,2 ))_"^^"_$G (PXKAV(12, 4))
  6751   "RTN","PXK FCPT1",57, 0)
  6752    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,802," AFTER")=$G (PXKCA)
  6753   "RTN","PXK FCPT1",58, 0)
  6754    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,812," AFTER")=$G (PXKAFT(81 2))
  6755   "RTN","PXK FCPT1",59, 0)
  6756    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,"IEN" )=PXKKK
  6757   "RTN","PXK FCPT1",60, 0)
  6758    K PXKQUN, PXKCPTN,PX KCA,PXXX,P XKKK
  6759   "RTN","PXK FCPT1",61, 0)
  6760    Q
  6761   "RTN","PXK FCPT1",62, 0)
  6762   IMMDEL ;Re trieve all  CPT infor mation for  VISIT fro m V CPT fi le
  6763   "RTN","PXK FCPT1",63, 0)
  6764    S PXKSEQ1 =PXKSEQ+PX KXX
  6765   "RTN","PXK FCPT1",64, 0)
  6766    S (XPFG,X P)=0 F  Q: XPFG  S XP =$O(^AUPNV CPT("AD",P XKVST,XP))  Q:XP=""   D
  6767   "RTN","PXK FCPT1",65, 0)
  6768    .I $P(^AU PNVCPT(XP, 0),"^",1)= $P($P(PXKP XD(PXKX)," ^",2),";")  D  S XPFG =1
  6769   "RTN","PXK FCPT1",66, 0)
  6770    ..I $P($G (^AUPNVCPT (XP,0)),"^ ",16)=1 D  IMMDEL1
  6771   "RTN","PXK FCPT1",67, 0)
  6772    ..I $D(XP ),$P($G(^A UPNVCPT(XP ,0)),"^",1 6)>1 D IMM DEL2
  6773   "RTN","PXK FCPT1",68, 0)
  6774    Q
  6775   "RTN","PXK FCPT1",69, 0)
  6776   IMMDEL1 ;
  6777   "RTN","PXK FCPT1",70, 0)
  6778    N PXKSEQ2 ,PXKMOD
  6779   "RTN","PXK FCPT1",71, 0)
  6780    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,0,"BE FORE")=$G( ^AUPNVCPT( XP,0))
  6781   "RTN","PXK FCPT1",72, 0)
  6782    S PXKSEQ2 =0
  6783   "RTN","PXK FCPT1",73, 0)
  6784    F  S PXKS EQ2=$O(^AU PNVCPT(XP, 1,PXKSEQ2) ) Q:'PXKSE Q2  D
  6785   "RTN","PXK FCPT1",74, 0)
  6786    .S PXKMOD =^AUPNVCPT (XP,1,PXKS EQ2,0)
  6787   "RTN","PXK FCPT1",75, 0)
  6788    .S ^TMP(" PXKSAVE",$ J,"CPT",PX KSEQ1,1,PX KSEQ2,"BEF ORE")=PXKM OD
  6789   "RTN","PXK FCPT1",76, 0)
  6790    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,12,"B EFORE")=$G (^AUPNVCPT (XP,12))
  6791   "RTN","PXK FCPT1",77, 0)
  6792    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,802," BEFORE")=$ G(^AUPNVCP T(XP,802))
  6793   "RTN","PXK FCPT1",78, 0)
  6794    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,812," BEFORE")=$ G(^AUPNVCP T(XP,812))
  6795   "RTN","PXK FCPT1",79, 0)
  6796    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,"IEN" )=XP
  6797   "RTN","PXK FCPT1",80, 0)
  6798    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,0,"AF TER")="@"
  6799   "RTN","PXK FCPT1",81, 0)
  6800    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,12,"A FTER")=""
  6801   "RTN","PXK FCPT1",82, 0)
  6802    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,802," AFTER")=""
  6803   "RTN","PXK FCPT1",83, 0)
  6804    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,812," AFTER")=""
  6805   "RTN","PXK FCPT1",84, 0)
  6806    K XPFG,XP
  6807   "RTN","PXK FCPT1",85, 0)
  6808    Q
  6809   "RTN","PXK FCPT1",86, 0)
  6810   IMMDEL2 ;
  6811   "RTN","PXK FCPT1",87, 0)
  6812    N PXKSEQ2 ,PXKMOD
  6813   "RTN","PXK FCPT1",88, 0)
  6814    S PXTEMP= $P($G(^AUP NVCPT(XP,0 )),"^",16)
  6815   "RTN","PXK FCPT1",89, 0)
  6816    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,0,"BE FORE")=$G( ^AUPNVCPT( XP,0))
  6817   "RTN","PXK FCPT1",90, 0)
  6818    S PXKSEQ2 =0
  6819   "RTN","PXK FCPT1",91, 0)
  6820    F  S PXKS EQ2=$O(^AU PNVCPT(XP, 1,PXKSEQ2) ) Q:'PXKSE Q2  D
  6821   "RTN","PXK FCPT1",92, 0)
  6822    .S PXKMOD =^AUPNVCPT (XP,1,PXKS EQ2,0)
  6823   "RTN","PXK FCPT1",93, 0)
  6824    .S ^TMP(" PXKSAVE",$ J,"CPT",PX KSEQ1,1,PX KSEQ2,"BEF ORE")=PXKM OD
  6825   "RTN","PXK FCPT1",94, 0)
  6826    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,12,"B EFORE")=$G (^AUPNVCPT (XP,12))
  6827   "RTN","PXK FCPT1",95, 0)
  6828    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,802," BEFORE")=$ G(^AUPNVCP T(XP,802))
  6829   "RTN","PXK FCPT1",96, 0)
  6830    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,812," BEFORE")=$ G(^AUPNVCP T(XP,812))
  6831   "RTN","PXK FCPT1",97, 0)
  6832    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,"IEN" )=XP
  6833   "RTN","PXK FCPT1",98, 0)
  6834    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,0,"AF TER")=$G(^ AUPNVCPT(X P,0))
  6835   "RTN","PXK FCPT1",99, 0)
  6836    S PXKSEQ2 =0
  6837   "RTN","PXK FCPT1",100 ,0)
  6838    F  S PXKS EQ2=$O(^AU PNVCPT(XP, 1,PXKSEQ2) ) Q:'PXKSE Q2  D
  6839   "RTN","PXK FCPT1",101 ,0)
  6840    .S PXKMOD =^AUPNVCPT (XP,1,PXKS EQ2,0)
  6841   "RTN","PXK FCPT1",102 ,0)
  6842    .S ^TMP(" PXKSAVE",$ J,"CPT",PX KSEQ1,1,PX KSEQ2,"BEF ORE")=PXKM OD
  6843   "RTN","PXK FCPT1",103 ,0)
  6844    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,12,"A FTER")=$G( ^AUPNVCPT( XP,12))
  6845   "RTN","PXK FCPT1",104 ,0)
  6846    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,802," AFTER")=$G (^AUPNVCPT (XP,802))
  6847   "RTN","PXK FCPT1",105 ,0)
  6848    S ^TMP("P XKSAVE",$J ,"CPT",PXK SEQ1,812," AFTER")=$G (^AUPNVCPT (XP,812))
  6849   "RTN","PXK FCPT1",106 ,0)
  6850    S $P(^TMP ("PXKSAVE" ,$J,"CPT", PXKSEQ1,0, "AFTER")," ^",16)=((P XTEMP)-(1) )
  6851   "RTN","PXK FCPT1",107 ,0)
  6852    K XPFG,XP ,PXTEMP
  6853   "RTN","PXK FCPT1",108 ,0)
  6854    Q
  6855   "RTN","PXK FCPT1",109 ,0)
  6856   SK ;--STAR T OF SKIN  TEST
  6857   "RTN","PXK FCPT1",110 ,0)
  6858    D IMM
  6859   "RTN","PXK FCPT1",111 ,0)
  6860    Q
  6861   "RTN","PXK FICR")
  6862   0^10^B1725 753^n/a
  6863   "RTN","PXK FICR",1,0)
  6864   PXKFICR ;B PFO/LMT -  Fields for  V IMM CON TRA/REFUSA L EVENTS f ile ;11/17 /15  14:46
  6865   "RTN","PXK FICR",2,0)
  6866    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  6867   "RTN","PXK FICR",3,0)
  6868    ;
  6869   "RTN","PXK FICR",4,0)
  6870    ;  Adding  or Editin g of data  in a parti cular fiel d can be c ontrolled
  6871   "RTN","PXK FICR",5,0)
  6872    ;by addin g a ~ as a  delimiter  and the l etters A a nd/or E to  the
  6873   "RTN","PXK FICR",6,0)
  6874    ;end of t he line of  text whic h represen ts what co uld be add ed
  6875   "RTN","PXK FICR",7,0)
  6876    ;to the D R string i n a DIE ca ll.
  6877   "RTN","PXK FICR",8,0)
  6878    ; 1. If n one or all  three(~AE ) of these  character s are adde d then
  6879   "RTN","PXK FICR",9,0)
  6880    ;    the  data in th is field c an be eith er added o r edited.
  6881   "RTN","PXK FICR",10,0 )
  6882    ; 2. If o nly the ~  is added t hen the da ta in this  field can  be
  6883   "RTN","PXK FICR",11,0 )
  6884    ;    neit her added  or edited.
  6885   "RTN","PXK FICR",12,0 )
  6886    ; 3. IF o nly the ~A  is added  then the d ata can on ly be adde d to
  6887   "RTN","PXK FICR",13,0 )
  6888    ;    the  file for t his field  but not ed ited.
  6889   "RTN","PXK FICR",14,0 )
  6890    ; 4. If o nly the ~E  is added  the the da ta can onl y be edite d in
  6891   "RTN","PXK FICR",15,0 )
  6892    ;    this  file for  this field . (not a l ikely poss ibility)
  6893   "RTN","PXK FICR",16,0 )
  6894    ;
  6895   "RTN","PXK FICR",17,0 )
  6896    ; The wor d "OPTION"  in front  of the lin e of text  below tell s the
  6897   "RTN","PXK FICR",18,0 )
  6898    ;software  to determ ine,based  on the dat a, the app ropriatene ss
  6899   "RTN","PXK FICR",19,0 )
  6900    ;of using  either a  "///" or " ////" stuf f in a DIE  call.
  6901   "RTN","PXK FICR",20,0 )
  6902    ;
  6903   "RTN","PXK FICR",21,0 )
  6904    ; The inf ormation o n line tag  0 $P(,,"  * ",1) are  the piece  numbers
  6905   "RTN","PXK FICR",22,0 )
  6906    ;of the f ields on t he zero no de that ar e required  by the da ta
  6907   "RTN","PXK FICR",23,0 )
  6908    ;dictiona ry and are  checked f or to dete rmine if e nough data  is presen t
  6909   "RTN","PXK FICR",24,0 )
  6910    ;to proce ed without  any error s. $P(,,"  * ",2) are  the nodes  and
  6911   "RTN","PXK FICR",25,0 )
  6912    ;piece nu mbers of t he fields  used to de termine du plicates i n the
  6913   "RTN","PXK FICR",26,0 )
  6914    ;file (no de+piece ( eg. 12+4)) . $P(,," *  ",3) is a  flag use  to
  6915   "RTN","PXK FICR",27,0 )
  6916    ;determin e if dupli cates are  allowed in  this visi t file.
  6917   "RTN","PXK FICR",28,0 )
  6918    ;If it is  set to 0  then no du plicate ch ecks will  occur. If  it is
  6919   "RTN","PXK FICR",29,0 )
  6920    ;set to 1  then the  file will  be checked  for dupli cates base d on
  6921   "RTN","PXK FICR",30,0 )
  6922    ;the info rmation in  $P 2.
  6923   "RTN","PXK FICR",31,0 )
  6924    ;
  6925   "RTN","PXK FICR",32,0 )
  6926    ; The fol lowing is  the file's  global na me.  Each  global mus t have a
  6927   "RTN","PXK FICR",33,0 )
  6928    ;unique n ame and ca n not have  any subsc ripts as p art of the  global ro ot.
  6929   "RTN","PXK FICR",34,0 )
  6930   GLOBAL ;;^ AUPNVICR
  6931   "RTN","PXK FICR",35,0 )
  6932    ;
  6933   "RTN","PXK FICR",36,0 )
  6934   EN1 ;
  6935   "RTN","PXK FICR",37,0 )
  6936    S PXKER=" "
  6937   "RTN","PXK FICR",38,0 )
  6938    S PXKER=$ P($T(@PXKN OD+PXKPCE) ,";;",2)
  6939   "RTN","PXK FICR",39,0 )
  6940    Q
  6941   "RTN","PXK FICR",40,0 )
  6942   EN2 ;
  6943   "RTN","PXK FICR",41,0 )
  6944    S PXKFD=" "
  6945   "RTN","PXK FICR",42,0 )
  6946    S PXKFD=$ P($T(@PXKN OD+PXKPCE) ,";;",2) D
  6947   "RTN","PXK FICR",43,0 )
  6948    .I PXKFD= "" S PXKPC E=PXKPCE+1  D EN2
  6949   "RTN","PXK FICR",44,0 )
  6950    Q
  6951   "RTN","PXK FICR",45,0 )
  6952   ADD ;Add a n entry to  the file
  6953   "RTN","PXK FICR",46,0 )
  6954    ;Q
  6955   "RTN","PXK FICR",47,0 )
  6956   0 ;;1,2,3, 4 * 0+1,0+ 3,0+4 * 1
  6957   "RTN","PXK FICR",48,0 )
  6958    ;;.01//// ^S X=$G(
  6959   "RTN","PXK FICR",49,0 )
  6960    ;;.02//// ^S X=$G(
  6961   "RTN","PXK FICR",50,0 )
  6962    ;;.03//// ^S X=$G(
  6963   "RTN","PXK FICR",51,0 )
  6964    ;;.04//// ^S X=$G(
  6965   "RTN","PXK FICR",52,0 )
  6966    ;;.05///^ S X=$G(
  6967   "RTN","PXK FICR",53,0 )
  6968   12 ;;
  6969   "RTN","PXK FICR",54,0 )
  6970    ;;1201/// ^S X=$G(
  6971   "RTN","PXK FICR",55,0 )
  6972    ;;
  6973   "RTN","PXK FICR",56,0 )
  6974    ;;
  6975   "RTN","PXK FICR",57,0 )
  6976    ;;1204/// /^S X=$G(
  6977   "RTN","PXK FICR",58,0 )
  6978   801 ;;
  6979   "RTN","PXK FICR",59,0 )
  6980    ;;80101// /^S X=1;
  6981   "RTN","PXK FICR",60,0 )
  6982    ;;80102// /^S X=$G(P XKAUDIT);
  6983   "RTN","PXK FICR",61,0 )
  6984   811 ;;
  6985   "RTN","PXK FICR",62,0 )
  6986    ;;81101// /^S X=$G(
  6987   "RTN","PXK FICR",63,0 )
  6988   812 ;;
  6989   "RTN","PXK FICR",64,0 )
  6990    ;;81201// /^S X=$G(
  6991   "RTN","PXK FICR",65,0 )
  6992    ;;81202// //^S X=$G(
  6993   "RTN","PXK FICR",66,0 )
  6994    ;;81203// //^S X=$G(
  6995   "RTN","PXK FICR",67,0 )
  6996   SPEC ;
  6997   "RTN","PXK FICR",68,0 )
  6998    Q
  6999   "RTN","PXK FIMM")
  7000   0^18^B5142 444^B44279 68
  7001   "RTN","PXK FIMM",1,0)
  7002   PXKFIMM ;I SL/JVS,SLC /ajb - Fie lds for V  IMMUNIZATI ONS file ; 01/11/16
  7003   "RTN","PXK FIMM",2,0)
  7004    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**22,1 24,201,209 ,210,215** ;Aug 12, 1 996;Build  10
  7005   "RTN","PXK FIMM",3,0)
  7006    ;
  7007   "RTN","PXK FIMM",4,0)
  7008    ;  Adding  or Editin g of data  in a parti cular fiel d can be c ontrolled
  7009   "RTN","PXK FIMM",5,0)
  7010    ;by addin g a ~ as a  delimiter  and the l etters A a nd/or E to  the
  7011   "RTN","PXK FIMM",6,0)
  7012    ;end of t he line of  text whic h represen ts what co uld be add ed
  7013   "RTN","PXK FIMM",7,0)
  7014    ;to the D R string i n a DIE ca ll.
  7015   "RTN","PXK FIMM",8,0)
  7016    ; 1. If n one or all  three(~AE ) of these  character s are adde d then
  7017   "RTN","PXK FIMM",9,0)
  7018    ;    the  data in th is field c an be eith er added o r edited.
  7019   "RTN","PXK FIMM",10,0 )
  7020    ; 2. If o nly the ~  is added t hen the da ta in this  field can  be
  7021   "RTN","PXK FIMM",11,0 )
  7022    ;    neit her added  or edited.
  7023   "RTN","PXK FIMM",12,0 )
  7024    ; 3. IF o nly the ~A  is added  then the d ata can on ly be adde d to
  7025   "RTN","PXK FIMM",13,0 )
  7026    ;    the  file for t his field  but not ed ited.
  7027   "RTN","PXK FIMM",14,0 )
  7028    ; 4. If o nly the ~E  is added  the the da ta can onl y be edite d in
  7029   "RTN","PXK FIMM",15,0 )
  7030    ;    this  file for  this field . (not a l ikely poss ibility)
  7031   "RTN","PXK FIMM",16,0 )
  7032    ;
  7033   "RTN","PXK FIMM",17,0 )
  7034    ; The wor d "OPTION"  in front  of the lin e of text  below tell s the
  7035   "RTN","PXK FIMM",18,0 )
  7036    ;software  to determ ine,based  on the dat a, the app ropriatene ss
  7037   "RTN","PXK FIMM",19,0 )
  7038    ;of using  either a  "///" or " ////" stuf f in a DIE  call.
  7039   "RTN","PXK FIMM",20,0 )
  7040    ;
  7041   "RTN","PXK FIMM",21,0 )
  7042    ; The inf ormation o n line tag  0 $P(,,"  * ",1) are  the piece  numbers
  7043   "RTN","PXK FIMM",22,0 )
  7044    ;of the f ields on t he zero no de that ar e required  by the da ta
  7045   "RTN","PXK FIMM",23,0 )
  7046    ;dictiona ry and are  checked f or to dete rmine if e nough data  is presen t
  7047   "RTN","PXK FIMM",24,0 )
  7048    ;to proce ed without  any error s. $P(,,"  * ",2) are  the nodes  and
  7049   "RTN","PXK FIMM",25,0 )
  7050    ;piece nu mbers of t he fields  used to de termine du plicates i n the
  7051   "RTN","PXK FIMM",26,0 )
  7052    ;file (no de+piece ( eg. 12+4)) . $P(,," *  ",3) is a  flag use  to
  7053   "RTN","PXK FIMM",27,0 )
  7054    ;determin e if dupli cates are  allowed in  this visi t file.
  7055   "RTN","PXK FIMM",28,0 )
  7056    ;If it is  set to 0  then no du plicate ch ecks will  occur. If  it is
  7057   "RTN","PXK FIMM",29,0 )
  7058    ;set to 1  then the  file will  be checked  for dupli cates base d on
  7059   "RTN","PXK FIMM",30,0 )
  7060    ;the info rmation in  $P 2.
  7061   "RTN","PXK FIMM",31,0 )
  7062    ;
  7063   "RTN","PXK FIMM",32,0 )
  7064    ; The fol lowing is  the file's  global na me.  Each  global mus t have a
  7065   "RTN","PXK FIMM",33,0 )
  7066    ;unique n ame and ca n not have  any subsc ripts as p art of the  global ro ot.
  7067   "RTN","PXK FIMM",34,0 )
  7068   GLOBAL ;;^ AUPNVIMM
  7069   "RTN","PXK FIMM",35,0 )
  7070    ;
  7071   "RTN","PXK FIMM",36,0 )
  7072   EN1 ;
  7073   "RTN","PXK FIMM",37,0 )
  7074    S PXKER=" "
  7075   "RTN","PXK FIMM",38,0 )
  7076    S PXKER=$ P($T(@PXKN OD+PXKPCE) ,";;",2)
  7077   "RTN","PXK FIMM",39,0 )
  7078    Q
  7079   "RTN","PXK FIMM",40,0 )
  7080   EN2 ;
  7081   "RTN","PXK FIMM",41,0 )
  7082    S PXKFD=" "
  7083   "RTN","PXK FIMM",42,0 )
  7084    S PXKFD=$ P($T(@PXKN OD+PXKPCE) ,";;",2) D
  7085   "RTN","PXK FIMM",43,0 )
  7086    .I PXKFD= "" S PXKPC E=PXKPCE+1  D EN2
  7087   "RTN","PXK FIMM",44,0 )
  7088    Q
  7089   "RTN","PXK FIMM",45,0 )
  7090   ADD ;Add a n entry to  the file
  7091   "RTN","PXK FIMM",46,0 )
  7092    ;Q
  7093   "RTN","PXK FIMM",47,0 )
  7094   0 ;;1,2,3  * 0+1,0+3  * 1
  7095   "RTN","PXK FIMM",48,0 )
  7096    ;;.01//// ^S X=$G(
  7097   "RTN","PXK FIMM",49,0 )
  7098    ;;.02//// ^S X=$G(
  7099   "RTN","PXK FIMM",50,0 )
  7100    ;;.03//// ^S X=$G(
  7101   "RTN","PXK FIMM",51,0 )
  7102    ;;.04//// ^S X=$G(
  7103   "RTN","PXK FIMM",52,0 )
  7104    ;;
  7105   "RTN","PXK FIMM",53,0 )
  7106    ;;.06///^ S X=$G(
  7107   "RTN","PXK FIMM",54,0 )
  7108    ;;.07///^ S X=$G(
  7109   "RTN","PXK FIMM",55,0 )
  7110    ;;.08//// ^S X=$G(
  7111   "RTN","PXK FIMM",56,0 )
  7112    ;;.09//// ^S X=$G(
  7113   "RTN","PXK FIMM",57,0 )
  7114    ;;.1////^ S X=$G(
  7115   "RTN","PXK FIMM",58,0 )
  7116    ;;.11//// ^S X=$G(
  7117   "RTN","PXK FIMM",59,0 )
  7118    ;;.12//// ^S X=$G(
  7119   "RTN","PXK FIMM",60,0 )
  7120    ;;.13//// ^S X=$G(
  7121   "RTN","PXK FIMM",61,0 )
  7122    ;;.14//// ^S X=$G(
  7123   "RTN","PXK FIMM",62,0 )
  7124    ;;.15//// ^S X=$G(
  7125   "RTN","PXK FIMM",63,0 )
  7126   11 ;;
  7127   "RTN","PXK FIMM",64,0 )
  7128    ;;1101/// ^S X=$G(
  7129   "RTN","PXK FIMM",65,0 )
  7130   12 ;;
  7131   "RTN","PXK FIMM",66,0 )
  7132    ;;1201/// ^S X=$G(
  7133   "RTN","PXK FIMM",67,0 )
  7134    ;;1202/// /^S X=$G(
  7135   "RTN","PXK FIMM",68,0 )
  7136    ;;
  7137   "RTN","PXK FIMM",69,0 )
  7138    ;;1204/// /^S X=$G(
  7139   "RTN","PXK FIMM",70,0 )
  7140    ;;1205/// /^S X=$G(
  7141   "RTN","PXK FIMM",71,0 )
  7142    ;;
  7143   "RTN","PXK FIMM",72,0 )
  7144    ;;1207/// /^S X=$G(
  7145   "RTN","PXK FIMM",73,0 )
  7146    ;;
  7147   "RTN","PXK FIMM",74,0 )
  7148    ;;
  7149   "RTN","PXK FIMM",75,0 )
  7150    ;;
  7151   "RTN","PXK FIMM",76,0 )
  7152    ;;
  7153   "RTN","PXK FIMM",77,0 )
  7154    ;;
  7155   "RTN","PXK FIMM",78,0 )
  7156    ;;
  7157   "RTN","PXK FIMM",79,0 )
  7158    ;;
  7159   "RTN","PXK FIMM",80,0 )
  7160    ;;
  7161   "RTN","PXK FIMM",81,0 )
  7162    ;;
  7163   "RTN","PXK FIMM",82,0 )
  7164    ;;
  7165   "RTN","PXK FIMM",83,0 )
  7166    ;;
  7167   "RTN","PXK FIMM",84,0 )
  7168    ;;
  7169   "RTN","PXK FIMM",85,0 )
  7170    ;;1220/// /^S X=$G(
  7171   "RTN","PXK FIMM",86,0 )
  7172   13 ;;
  7173   "RTN","PXK FIMM",87,0 )
  7174    ;;1301/// /^S X=$G(
  7175   "RTN","PXK FIMM",88,0 )
  7176    ;;1302/// /^S X=$G(
  7177   "RTN","PXK FIMM",89,0 )
  7178    ;;1303/// /^S X=$G(
  7179   "RTN","PXK FIMM",90,0 )
  7180    ;;1304/// /^S X=$G(
  7181   "RTN","PXK FIMM",91,0 )
  7182    ;;
  7183   "RTN","PXK FIMM",92,0 )
  7184    ;;
  7185   "RTN","PXK FIMM",93,0 )
  7186    ;;
  7187   "RTN","PXK FIMM",94,0 )
  7188    ;;
  7189   "RTN","PXK FIMM",95,0 )
  7190    ;;
  7191   "RTN","PXK FIMM",96,0 )
  7192    ;;
  7193   "RTN","PXK FIMM",97,0 )
  7194    ;;
  7195   "RTN","PXK FIMM",98,0 )
  7196    ;;1312/// /^S X=$G(
  7197   "RTN","PXK FIMM",99,0 )
  7198    ;;1313/// /^S X=$G(
  7199   "RTN","PXK FIMM",100, 0)
  7200   14 ;;
  7201   "RTN","PXK FIMM",101, 0)
  7202    ;;1401/// /^S X=$G(
  7203   "RTN","PXK FIMM",102, 0)
  7204    ;;1402/// ^S X=$G(
  7205   "RTN","PXK FIMM",103, 0)
  7206    ;;1403/// ^S X=$G(
  7207   "RTN","PXK FIMM",104, 0)
  7208    ;;1404/// /^S X=$G(
  7209   "RTN","PXK FIMM",105, 0)
  7210    ;;1405/// ^S X=$G(
  7211   "RTN","PXK FIMM",106, 0)
  7212    ;;1406/// ^S X=$G(
  7213   "RTN","PXK FIMM",107, 0)
  7214   15 ;;
  7215   "RTN","PXK FIMM",108, 0)
  7216    ;;1501/// ^S X=$G(
  7217   "RTN","PXK FIMM",109, 0)
  7218   16 ;;
  7219   "RTN","PXK FIMM",110, 0)
  7220    ;;1601/// ^S X=$G(
  7221   "RTN","PXK FIMM",111, 0)
  7222   801 ;;
  7223   "RTN","PXK FIMM",112, 0)
  7224    ;;80101// /^S X=1;
  7225   "RTN","PXK FIMM",113, 0)
  7226    ;;80102// /^S X=$G(P XKAUDIT);
  7227   "RTN","PXK FIMM",114, 0)
  7228   811 ;;
  7229   "RTN","PXK FIMM",115, 0)
  7230    ;;81101// /^S X=$G(
  7231   "RTN","PXK FIMM",116, 0)
  7232   812 ;;
  7233   "RTN","PXK FIMM",117, 0)
  7234    ;;81201// /^S X=$G(
  7235   "RTN","PXK FIMM",118, 0)
  7236    ;;81202// //^S X=$G(
  7237   "RTN","PXK FIMM",119, 0)
  7238    ;;81203// //^S X=$G(
  7239   "RTN","PXK FIMM",120, 0)
  7240   SPEC ;
  7241   "RTN","PXK FIMM",121, 0)
  7242    Q
  7243   "RTN","PXK FPOV1")
  7244   0^22^B9458 058^n/a
  7245   "RTN","PXK FPOV1",1,0 )
  7246   PXKFPOV1 ; BPFO/LMT -  PROMBLEM  OF VISIT R outine #2  ;01/12/16   14:36
  7247   "RTN","PXK FPOV1",2,0 )
  7248    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  7249   "RTN","PXK FPOV1",3,0 )
  7250    ;
  7251   "RTN","PXK FPOV1",4,0 )
  7252    ;
  7253   "RTN","PXK FPOV1",5,0 )
  7254   IMM ;
  7255   "RTN","PXK FPOV1",6,0 )
  7256    D MAIN
  7257   "RTN","PXK FPOV1",7,0 )
  7258    Q
  7259   "RTN","PXK FPOV1",8,0 )
  7260   SK ;
  7261   "RTN","PXK FPOV1",9,0 )
  7262    D MAIN
  7263   "RTN","PXK FPOV1",10, 0)
  7264    Q
  7265   "RTN","PXK FPOV1",11, 0)
  7266    ;
  7267   "RTN","PXK FPOV1",12, 0)
  7268   MAIN ;
  7269   "RTN","PXK FPOV1",13, 0)
  7270    I PXKFGAD =1 D ADD
  7271   "RTN","PXK FPOV1",14, 0)
  7272    I PXKFGDE =1 D DEL
  7273   "RTN","PXK FPOV1",15, 0)
  7274    Q
  7275   "RTN","PXK FPOV1",16, 0)
  7276    ;
  7277   "RTN","PXK FPOV1",17, 0)
  7278   ADD ;
  7279   "RTN","PXK FPOV1",18, 0)
  7280    N PXKSEQ1 ,PXNARR,PX VISIT,PXVI SITDT
  7281   "RTN","PXK FPOV1",19, 0)
  7282    ;
  7283   "RTN","PXK FPOV1",20, 0)
  7284    S PXVISIT =$G(^TMP(" PXK",$J,"V ST",1,"IEN "))
  7285   "RTN","PXK FPOV1",21, 0)
  7286    ;
  7287   "RTN","PXK FPOV1",22, 0)
  7288    ; Entry a lready exi sts with t his Code -  don't add  duplicate
  7289   "RTN","PXK FPOV1",23, 0)
  7290    I $$FNDVP OV(PXVISIT ,PXCODE) Q
  7291   "RTN","PXK FPOV1",24, 0)
  7292    ;
  7293   "RTN","PXK FPOV1",25, 0)
  7294    ; use dia gnosis des cription a s narrativ e
  7295   "RTN","PXK FPOV1",26, 0)
  7296    S PXVISIT DT=$$CSDAT E^PXDXUTL( PXVISIT)
  7297   "RTN","PXK FPOV1",27, 0)
  7298    S PXNARR= $$DXNARR^P XUTL1(PXCO DE,PXVISIT DT)
  7299   "RTN","PXK FPOV1",28, 0)
  7300    S PXNARR= +$$PROVNAR R^PXAPI(PX NARR,90000 10.07)
  7301   "RTN","PXK FPOV1",29, 0)
  7302    ;
  7303   "RTN","PXK FPOV1",30, 0)
  7304    S PXKSEQ1 =PXKSEQ+PX KXX
  7305   "RTN","PXK FPOV1",31, 0)
  7306    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,0,"AF TER")=PXCO DE_"^"_$G( PXKAV(0,2) )_"^"_$G(P XKAV(0,3)) _"^"_PXNAR R_"^^^^^^^ ^S"
  7307   "RTN","PXK FPOV1",32, 0)
  7308    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,12,"A FTER")=$G( PXKAV(12,1 ))_"^"_$G( PXKAV(12,2 ))_"^^"_$G (PXKAV(12, 4))
  7309   "RTN","PXK FPOV1",33, 0)
  7310    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,812," AFTER")=$G (PXKAFT(81 2))
  7311   "RTN","PXK FPOV1",34, 0)
  7312    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,"IEN" )=""
  7313   "RTN","PXK FPOV1",35, 0)
  7314    ;
  7315   "RTN","PXK FPOV1",36, 0)
  7316    Q
  7317   "RTN","PXK FPOV1",37, 0)
  7318    ;
  7319   "RTN","PXK FPOV1",38, 0)
  7320   DEL ;
  7321   "RTN","PXK FPOV1",39, 0)
  7322    N PXKSEQ1 ,PXVISIT,P XVPOV
  7323   "RTN","PXK FPOV1",40, 0)
  7324    ;
  7325   "RTN","PXK FPOV1",41, 0)
  7326    S PXVISIT =$G(^TMP(" PXK",$J,"V ST",1,"IEN "))
  7327   "RTN","PXK FPOV1",42, 0)
  7328    ;
  7329   "RTN","PXK FPOV1",43, 0)
  7330    S PXVPOV= $$FNDVPOV( PXVISIT,PX CODE)
  7331   "RTN","PXK FPOV1",44, 0)
  7332    I 'PXVPOV  Q
  7333   "RTN","PXK FPOV1",45, 0)
  7334    ;
  7335   "RTN","PXK FPOV1",46, 0)
  7336    S PXKSEQ1 =PXKSEQ+PX KXX
  7337   "RTN","PXK FPOV1",47, 0)
  7338    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,0,"BE FORE")=$G( ^AUPNVPOV( PXVPOV,0))
  7339   "RTN","PXK FPOV1",48, 0)
  7340    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,12,"B EFORE")=$G (^AUPNVPOV (PXVPOV,12 ))
  7341   "RTN","PXK FPOV1",49, 0)
  7342    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,800," BEFORE")=$ G(^AUPNVPO V(PXVPOV,8 00))
  7343   "RTN","PXK FPOV1",50, 0)
  7344    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,802," BEFORE")=$ G(^AUPNVPO V(PXVPOV,8 02))
  7345   "RTN","PXK FPOV1",51, 0)
  7346    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,811," BEFORE")=$ G(^AUPNVPO V(PXVPOV,8 11))
  7347   "RTN","PXK FPOV1",52, 0)
  7348    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,812," BEFORE")=$ G(^AUPNVPO V(PXVPOV,8 12))
  7349   "RTN","PXK FPOV1",53, 0)
  7350    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,"IEN" )=PXVPOV
  7351   "RTN","PXK FPOV1",54, 0)
  7352    ;
  7353   "RTN","PXK FPOV1",55, 0)
  7354    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,0,"AF TER")="@"
  7355   "RTN","PXK FPOV1",56, 0)
  7356    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,12,"A FTER")=""
  7357   "RTN","PXK FPOV1",57, 0)
  7358    S ^TMP("P XKSAVE",$J ,"POV",PXK SEQ1,812," AFTER")=""
  7359   "RTN","PXK FPOV1",58, 0)
  7360    ;
  7361   "RTN","PXK FPOV1",59, 0)
  7362    Q
  7363   "RTN","PXK FPOV1",60, 0)
  7364    ;
  7365   "RTN","PXK FPOV1",61, 0)
  7366   DUP(PXVISI T,PXCODE)  ;
  7367   "RTN","PXK FPOV1",62, 0)
  7368    N PXFOUND ,PXSEQ
  7369   "RTN","PXK FPOV1",63, 0)
  7370    ;
  7371   "RTN","PXK FPOV1",64, 0)
  7372    I $$FNDVP OV(PXVISIT ,PXCODE) Q  1
  7373   "RTN","PXK FPOV1",65, 0)
  7374    ;
  7375   "RTN","PXK FPOV1",66, 0)
  7376    S PXFOUND =0
  7377   "RTN","PXK FPOV1",67, 0)
  7378    S PXSEQ=0
  7379   "RTN","PXK FPOV1",68, 0)
  7380    F  Q:PXFO UND  S PXS EQ=$O(^TMP ("PXK",$J, "POV",PXSE Q)) Q:'PXS EQ  D
  7381   "RTN","PXK FPOV1",69, 0)
  7382    . I $P($G (^TMP("PXK ",$J,"POV" ,PXSEQ,0," AFTER")),U ,1)=PXCODE  D
  7383   "RTN","PXK FPOV1",70, 0)
  7384    . . S PXF OUND=1
  7385   "RTN","PXK FPOV1",71, 0)
  7386    ;
  7387   "RTN","PXK FPOV1",72, 0)
  7388    Q PXFOUND
  7389   "RTN","PXK FPOV1",73, 0)
  7390    ;
  7391   "RTN","PXK FPOV1",74, 0)
  7392   FNDVPOV(PX VISIT,PXCO DE) ;
  7393   "RTN","PXK FPOV1",75, 0)
  7394    N PXFOUND ,PXRSLT,PX VPOV
  7395   "RTN","PXK FPOV1",76, 0)
  7396    ;
  7397   "RTN","PXK FPOV1",77, 0)
  7398    S PXRSLT= 0
  7399   "RTN","PXK FPOV1",78, 0)
  7400    S PXFOUND =0
  7401   "RTN","PXK FPOV1",79, 0)
  7402    ;
  7403   "RTN","PXK FPOV1",80, 0)
  7404    S PXVPOV= 0
  7405   "RTN","PXK FPOV1",81, 0)
  7406    F  Q:PXFO UND  S PXV POV=$O(^AU PNVPOV("AD ",PXVISIT, PXVPOV)) Q :'PXVPOV   D
  7407   "RTN","PXK FPOV1",82, 0)
  7408    . I $P($G (^AUPNVPOV (PXVPOV,0) ),U,1)=PXC ODE D
  7409   "RTN","PXK FPOV1",83, 0)
  7410    . . S PXF OUND=1
  7411   "RTN","PXK FPOV1",84, 0)
  7412    . . S PXR SLT=PXVPOV
  7413   "RTN","PXK FPOV1",85, 0)
  7414    ;
  7415   "RTN","PXK FPOV1",86, 0)
  7416    Q PXRSLT
  7417   "RTN","PXK MAIN")
  7418   0^20^B5542 4847^B5541 7967
  7419   "RTN","PXK MAIN",1,0)
  7420   PXKMAIN ;I SL/JVS,ISA /Zoltan -  Main Routi ne for Dat a Capture  ;01/05/16   17:09
  7421   "RTN","PXK MAIN",2,0)
  7422    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**22,5 9,73,88,69 ,117,130,1 24,174,164 ,210,215** ;Aug 12, 1 996;Build  10
  7423   "RTN","PXK MAIN",3,0)
  7424    ;+This ro utine is r esponsible  for:
  7425   "RTN","PXK MAIN",4,0)
  7426    ;+
  7427   "RTN","PXK MAIN",5,0)
  7428    ;+LOCAL V ARIABLE LI ST:
  7429   "RTN","PXK MAIN",6,0)
  7430    ;+ PXP59L OC = LOCK  name (intr oduced in  patch PX*1 .0*59).
  7431   "RTN","PXK MAIN",7,0)
  7432    ;+ PXFG      = Stop  flag with  duplicate  of delete
  7433   "RTN","PXK MAIN",8,0)
  7434    ;+ PXKAFT    = After  node
  7435   "RTN","PXK MAIN",9,0)
  7436    ;+ PXKBEF    = Befor e node
  7437   "RTN","PXK MAIN",10,0 )
  7438    ;+ PXKAV     = Piece s from the  after nod e
  7439   "RTN","PXK MAIN",11,0 )
  7440    ;+ PXKBV     = Piece s from the  before no de
  7441   "RTN","PXK MAIN",12,0 )
  7442    ;+ PXKERR OR = Set w hen there  is an erro r
  7443   "RTN","PXK MAIN",13,0 )
  7444    ;+ PXKFGA D  = ADD f lag
  7445   "RTN","PXK MAIN",14,0 )
  7446    ;+ PXKFGE D  = EDIT  flag
  7447   "RTN","PXK MAIN",15,0 )
  7448    ;+ PXKFGD E  = DELET E flag
  7449   "RTN","PXK MAIN",16,0 )
  7450    ;+ PXKSEQ    = Seque nce number  in PXK tm p global
  7451   "RTN","PXK MAIN",17,0 )
  7452    ;+ PXKCAT    = Categ ory of ent ry (CPT,MS R,VST...)
  7453   "RTN","PXK MAIN",18,0 )
  7454    ;+ PXKREF    = Root  of temp gl obal
  7455   "RTN","PXK MAIN",19,0 )
  7456    ;+ PXKPIE N  = IEN o f v file o r the visi t file
  7457   "RTN","PXK MAIN",20,0 )
  7458    ;+ PXKREF    = The o riginal re ference we  are order ing off of
  7459   "RTN","PXK MAIN",21,0 )
  7460    ;+ PXKRT     = name  of the nod e in the v  file
  7461   "RTN","PXK MAIN",22,0 )
  7462    ;+ PXKRTN    = routi ne name fo r the file  routine
  7463   "RTN","PXK MAIN",23,0 )
  7464    ;+ PXKSOR    = the d ata source  for this  entry
  7465   "RTN","PXK MAIN",24,0 )
  7466    ;+ PXKSUB    = the s ubscript t he data is  located o n the v fi le
  7467   "RTN","PXK MAIN",25,0 )
  7468    ;+ PXKVST    = the v isit IEN
  7469   "RTN","PXK MAIN",26,0 )
  7470    ;+ PXKDUZ    = the D UZ of the  user
  7471   "RTN","PXK MAIN",27,0 )
  7472    ;+ *PXKHL R* = A var iable set  by calling  routine s o that dup licate
  7473   "RTN","PXK MAIN",28,0 )
  7474    ;+             PXKER ROR messag es aren't  produced.
  7475   "RTN","PXK MAIN",29,0 )
  7476    ;
  7477   "RTN","PXK MAIN",30,0 )
  7478    W !,"This  is not an  entry poi nt" Q
  7479   "RTN","PXK MAIN",31,0 )
  7480   EN1 ;+Main  entry poi nt to read  ^TMP("PXK ", Global
  7481   "RTN","PXK MAIN",32,0 )
  7482    ;+ Partia l ^TMP Glo bal Struct ure when c alled:
  7483   "RTN","PXK MAIN",33,0 )
  7484    ;+ ^TMP(" PXK",$J,"S OR") = Sou rce ien
  7485   "RTN","PXK MAIN",34,0 )
  7486    ;+
  7487   "RTN","PXK MAIN",35,0 )
  7488    ;+ ^TMP(" PXK",$J,"V ST",1,0,"B EFORE") =  the 0-node  of the vi sit file
  7489   "RTN","PXK MAIN",36,0 )
  7490    ;+ ^TMP(" PXK",$J,"V ST",1,0,"A FTER") = 0 -node afte r changes.
  7491   "RTN","PXK MAIN",37,0 )
  7492    ;+ ^TMP(" PXK",$J,"V ST",provid er counter ,"IEN") =  ""
  7493   "RTN","PXK MAIN",38,0 )
  7494    ;+
  7495   "RTN","PXK MAIN",39,0 )
  7496    ;+ ^TMP(" PXK",$J,"P RV",provid er counter ,0,"BEFORE ") = ""
  7497   "RTN","PXK MAIN",40,0 )
  7498    ;+ ^TMP(" PXK",$J,"P RV",provid er counter ,0,"AFTER" ) = Provid er id^DFN^ Visitien^' P' or 'S'  for primar y/secondar y
  7499   "RTN","PXK MAIN",41,0 )
  7500    ;+ ^TMP(" PXK",$J,"P RV",provid er counter ,"IEN") =  ""
  7501   "RTN","PXK MAIN",42,0 )
  7502    ;+ ^TMP(" PXK",$J,"P RV",provid er counter ,"BEFORE")  = ""
  7503   "RTN","PXK MAIN",43,0 )
  7504    ;+ ^TMP(" PXK",$J,"P RV",provid er counter ,"AFTER")  = ^Package  ien^Sourc e ien
  7505   "RTN","PXK MAIN",44,0 )
  7506    ;+
  7507   "RTN","PXK MAIN",45,0 )
  7508    N PXP59LO C
  7509   "RTN","PXK MAIN",46,0 )
  7510    D LOCK
  7511   "RTN","PXK MAIN",47,0 )
  7512    K PXKERRO R
  7513   "RTN","PXK MAIN",48,0 )
  7514    I '$G(PXK DUZ) D
  7515   "RTN","PXK MAIN",49,0 )
  7516    . I $G(DU Z) S PXKDU Z=DUZ
  7517   "RTN","PXK MAIN",50,0 )
  7518    . E  S PX KDUZ=.5
  7519   "RTN","PXK MAIN",51,0 )
  7520    D VST
  7521   "RTN","PXK MAIN",52,0 )
  7522    I $D(PXP5 9LOC) D UN LOCK
  7523   "RTN","PXK MAIN",53,0 )
  7524    Q
  7525   "RTN","PXK MAIN",54,0 )
  7526   VST ;--Che ck for vis it node an d get one  created or  quit.
  7527   "RTN","PXK MAIN",55,0 )
  7528    I '$G(^TM P("PXK",$J ,"VST",1," IEN")) D
  7529   "RTN","PXK MAIN",56,0 )
  7530    .D VSIT^P XKVST
  7531   "RTN","PXK MAIN",57,0 )
  7532    I +$G(^TM P("PXK",$J ,"VST",1," IEN"))=-1  S PXKERROR ("VISIT")= "Visit Tra cking coul d not get  a visit."  Q
  7533   "RTN","PXK MAIN",58,0 )
  7534    I +$G(^TM P("PXK",$J ,"VST",1," IEN"))=-2  S PXKERROR ("VISIT")= "PCE is no t activate d in Visit  Tracking  Parameters  and thus  cannot cre ate visits ." Q
  7535   "RTN","PXK MAIN",59,0 )
  7536    I +$G(^TM P("PXK",$J ,"VST",1," IEN"))<1 S  PXKERROR( "VISIT")=" Did not ge t a visit^ "_$G(^TMP( "PXK",$J," VST",1,"IE N")) Q
  7537   "RTN","PXK MAIN",60,0 )
  7538    ;
  7539   "RTN","PXK MAIN",61,0 )
  7540   NEW ;--New  variables  and set m ain variab les
  7541   "RTN","PXK MAIN",62,0 )
  7542    N PXKDFN, PXKSOR,PXK VST,PXKSEQ ,PXFG,PXKA FT,PXKBEF, PXKAUDIT
  7543   "RTN","PXK MAIN",63,0 )
  7544    N PXKCAT, PXKER,PXKF GAD,PXKFGE D,PXKFGDE, PXKNOD,PXK PCE
  7545   "RTN","PXK MAIN",64,0 )
  7546    N PXKPIEN ,PXKREF,PX KRTN,PXKSO RR,PXKSUB, PXKVCAT
  7547   "RTN","PXK MAIN",65,0 )
  7548    N PXKPTR, PXDFG,PX,P XJJJ,PXKAF T8,PXKAFTR ,PXKGN,PXK N,PXKP
  7549   "RTN","PXK MAIN",66,0 )
  7550    N PXKRRT, PXKVRTN,PX KRT,PXKFVD LM,TMPPX
  7551   "RTN","PXK MAIN",67,0 )
  7552   PRVTYPE ;- --DO PROVI DER TYPE-- PXKMAIN2
  7553   "RTN","PXK MAIN",68,0 )
  7554    D PRVTYPE ^PXKMAIN2
  7555   "RTN","PXK MAIN",69,0 )
  7556    ;
  7557   "RTN","PXK MAIN",70,0 )
  7558   SET ;--SET  VARIABLES  NECESSARY
  7559   "RTN","PXK MAIN",71,0 )
  7560    ;'DA' sho uld not be  defined a t this poi nt
  7561   "RTN","PXK MAIN",72,0 )
  7562    N DA ;PX* 1.0*117
  7563   "RTN","PXK MAIN",73,0 )
  7564    ;
  7565   "RTN","PXK MAIN",74,0 )
  7566    S PXFG=0, TMPPX="^", PXKLAYGO=" ",PXDFG=0
  7567   "RTN","PXK MAIN",75,0 )
  7568   SOURCE S P XKSOR=$G(^ TMP("PXK", $J,"SOR"))  D  Q:$D(P XKERROR("S OURCE"))
  7569   "RTN","PXK MAIN",76,0 )
  7570    .S PXKCO( "SOR")=PXK SOR
  7571   "RTN","PXK MAIN",77,0 )
  7572    .I $D(PXK SOR)']"" S  PXKERROR( "SOURCE")= "" Q
  7573   "RTN","PXK MAIN",78,0 )
  7574   VISIT S (P XKVST,VSIT ("IEN"))=$ G(^TMP("PX K",$J,"VST ",1,"IEN") )
  7575   "RTN","PXK MAIN",79,0 )
  7576   ORDER ;--$ ORDER Thro ugh the ^T MP("PXK",  global set ting varia bles
  7577   "RTN","PXK MAIN",80,0 )
  7578    S PXKREF= "^TMP(""PX K"",$J)"
  7579   "RTN","PXK MAIN",81,0 )
  7580   CATEG S PX KCAT="" F   S (PXKCAT ,PXKVCAT)= $O(@PXKREF @(PXKCAT))  Q:PXKCAT= ""  D
  7581   "RTN","PXK MAIN",82,0 )
  7582    .I PXKCAT ="VST" S P XKVCAT="SI T"
  7583   "RTN","PXK MAIN",83,0 )
  7584    .S PXKRTN ="PXKF"_PX KCAT
  7585   "RTN","PXK MAIN",84,0 )
  7586    .S X=PXKR TN X ^%ZOS F("TEST")  Q:'$T
  7587   "RTN","PXK MAIN",85,0 )
  7588   SEQUE .S P XKSEQ=0 F   S PXKSEQ= $O(@PXKREF @(PXKCAT,P XKSEQ)) K  PXKAV,PXKB V S PXFG=0  Q:'PXKSEQ   D
  7589   "RTN","PXK MAIN",86,0 )
  7590    ..S PXKPI EN=$G(@PXK REF@(PXKCA T,PXKSEQ," IEN")),(PX KFGAD,PXKF GDE,PXKFGE D,PXDFG)=0
  7591   "RTN","PXK MAIN",87,0 )
  7592   SUBSCR ..S  PXKSUB=""  F  S PXKS UB=$O(@PXK REF@(PXKCA T,PXKSEQ,P XKSUB)) Q: PXKSUB["IE N"  Q:PXFG =1  Q:PXDF G=1  D
  7593   "RTN","PXK MAIN",88,0 )
  7594   AFTER ...S  PXKAFT(PX KSUB)=$G(@ PXKREF@(PX KCAT,PXKSE Q,PXKSUB," AFTER"))
  7595   "RTN","PXK MAIN",89,0 )
  7596   BEFORE ... S PXKBEF(P XKSUB)=$G( @PXKREF@(P XKCAT,PXKS EQ,PXKSUB, "BEFORE"))
  7597   "RTN","PXK MAIN",90,0 )
  7598    ...I PXKC AT="CPT",P XKSUB=1 D  SUBSCR^PXK MOD
  7599   "RTN","PXK MAIN",91,0 )
  7600    ...I PXKC AT="IMM",P XKSUB?1(1" 2",1"3",1" 11") D MUL T
  7601   "RTN","PXK MAIN",92,0 )
  7602    ...D LOOP ^PXKMAIN1  D ERROR^PX KMAIN1 S P XDFG=0 I $ G(PXKAV(0, 1))["@"!(' $D(PXKAV(0 ,1))) S PX KAFT(PXKSU B)="" K PX KAV(0) S P XDFG=1
  7603   "RTN","PXK MAIN",93,0 )
  7604    ..Q:PXFG= 1
  7605   "RTN","PXK MAIN",94,0 )
  7606    ..I $D(PX KAV),'$D(P XKBV) S PX KSORR=PXKS OR_"-A "_P XKDUZ,PXKF GAD=1 I PX KCAT["VST"  S PXKFGAD =0
  7607   "RTN","PXK MAIN",95,0 )
  7608    ..I '$D(P XKAV),$D(P XKBV) S PX KFGDE=1,PX KFVDLM=""  D
  7609   "RTN","PXK MAIN",96,0 )
  7610    ...S PXKR T=$P($T(GL OBAL^@PXKR TN),";;",2 )_"("_PXKP IEN_")" I  $D(@PXKRT)  D DELETE^ PXKMAIN1,E N1^PXKMASC  S PXFG=1  K PXKRT Q
  7611   "RTN","PXK MAIN",97,0 )
  7612    ..I 'PXKF GAD,'PXKFG DE D
  7613   "RTN","PXK MAIN",98,0 )
  7614    ...I PXKC AT="VST" D  CQDEL
  7615   "RTN","PXK MAIN",99,0 )
  7616    ...D CLEA N^PXKMAIN1
  7617   "RTN","PXK MAIN",100, 0)
  7618    ...I $D(P XKAV) S PX KSORR=PXKS OR_"-E "_P XKDUZ,PXKF GED=1 I PX KCAT="VST" ,'$D(PXKBV ),$D(PXKVS T) S PXKFG ED=0
  7619   "RTN","PXK MAIN",101, 0)
  7620    ..I 'PXKF GAD,'PXKFG DE,'PXKFGE D,PXKCAT[" VST" D EN1 ^PXKMASC
  7621   "RTN","PXK MAIN",102, 0)
  7622    ..I PXKFG AD=1 D  Q: PXFG
  7623   "RTN","PXK MAIN",103, 0)
  7624    ...D ERRO R^PXKMAIN1
  7625   "RTN","PXK MAIN",104, 0)
  7626    ...I $D(P XKERROR(PX KCAT,PXKSE Q)) S PXFG =1
  7627   "RTN","PXK MAIN",105, 0)
  7628    ...D:'PXF G DUP^PXKM AIN1
  7629   "RTN","PXK MAIN",106, 0)
  7630    ...I PXFG =1 D  Q
  7631   "RTN","PXK MAIN",107, 0)
  7632    ....Q:PXK CAT'="CPT"
  7633   "RTN","PXK MAIN",108, 0)
  7634    ....I $G( @PXKREF@(P XKCAT,PXKS EQ,"IEN")) ]"" D REMO VE^PXCEVFI L(@PXKREF@ (PXKCAT,PX KSEQ,"IEN" ))
  7635   "RTN","PXK MAIN",109, 0)
  7636    ...D:'PXK PIEN FILE^ PXKMAIN1
  7637   "RTN","PXK MAIN",110, 0)
  7638    ...S:'$G( DA) DA=PXK PIEN
  7639   "RTN","PXK MAIN",111, 0)
  7640    ...D AUD2 ^PXKMAIN1, DRDIE^PXKM AIN1,EN1^P XKMASC
  7641   "RTN","PXK MAIN",112, 0)
  7642    ..I PXKFG ED=1,PXKCA T'="VST" S  PXKRT=$P( $T(GLOBAL^ @PXKRTN)," ;;",2)_"(" _PXKPIEN_" )" Q:'$D(@ PXKRT)  S  DA=PXKPIEN  D DUP^PXK MAIN1 Q:PX FG=1  D AU D12^PXKMAI N1,DRDIE^P XKMAIN1,EN 1^PXKMASC
  7643   "RTN","PXK MAIN",113, 0)
  7644    ..I PXKFG ED=1,PXKCA T="VST" S  PXKRT=$P($ T(GLOBAL^@ PXKRTN),"; ;",2)_"("_ PXKPIEN_") " Q:'$D(@P XKRT)  S D A=PXKPIEN  D DUP^PXKM AIN1 Q:PXF G=1  D DRD IE^PXKMAIN 1,EN1^PXKM ASC
  7645   "RTN","PXK MAIN",114, 0)
  7646    ..D SPEC2 ^PXKMAIN2
  7647   "RTN","PXK MAIN",115, 0)
  7648    ..K PXKAF T,PXKBEF
  7649   "RTN","PXK MAIN",116, 0)
  7650    I $D(^TMP ("PXKSAVE" ,$J)) D RE CALL^PXKMA IN2
  7651   "RTN","PXK MAIN",117, 0)
  7652    D EXIT
  7653   "RTN","PXK MAIN",118, 0)
  7654    Q
  7655   "RTN","PXK MAIN",119, 0)
  7656    ;
  7657   "RTN","PXK MAIN",120, 0)
  7658   MULT ; Add  multiples  to PXKAFT , PXKBEF,  PXKAV, PXK BV arrays
  7659   "RTN","PXK MAIN",121, 0)
  7660    ;
  7661   "RTN","PXK MAIN",122, 0)
  7662    N PXKSUBI EN,PXKI
  7663   "RTN","PXK MAIN",123, 0)
  7664    ;
  7665   "RTN","PXK MAIN",124, 0)
  7666    S PXKSUBI EN=0
  7667   "RTN","PXK MAIN",125, 0)
  7668    F  S PXKS UBIEN=$O(@ PXKREF@(PX KCAT,PXKSE Q,PXKSUB,P XKSUBIEN))  Q:'PXKSUB IEN  D
  7669   "RTN","PXK MAIN",126, 0)
  7670    . ;
  7671   "RTN","PXK MAIN",127, 0)
  7672    . I $D(@P XKREF@(PXK CAT,PXKSEQ ,PXKSUB,PX KSUBIEN,"A FTER")) D
  7673   "RTN","PXK MAIN",128, 0)
  7674    . . S PXK AFT(PXKSUB ,PXKSUBIEN )=$G(@PXKR EF@(PXKCAT ,PXKSEQ,PX KSUB,PXKSU BIEN,"AFTE R"))
  7675   "RTN","PXK MAIN",129, 0)
  7676    . . F PXK I=1:1:$L(P XKAFT(PXKS UB,PXKSUBI EN),"^") D
  7677   "RTN","PXK MAIN",130, 0)
  7678    . . . I $ P(PXKAFT(P XKSUB,PXKS UBIEN),"^" ,PXKI)'=""  S PXKAV(P XKSUB,PXKS UBIEN,PXKI )=$P(PXKAF T(PXKSUB,P XKSUBIEN), "^",PXKI)
  7679   "RTN","PXK MAIN",131, 0)
  7680    . ;
  7681   "RTN","PXK MAIN",132, 0)
  7682    . I $D(@P XKREF@(PXK CAT,PXKSEQ ,PXKSUB,PX KSUBIEN,"B EFORE")) D
  7683   "RTN","PXK MAIN",133, 0)
  7684    . . S PXK BEF(PXKSUB ,PXKSUBIEN )=$G(@PXKR EF@(PXKCAT ,PXKSEQ,PX KSUB,PXKSU BIEN,"BEFO RE"))
  7685   "RTN","PXK MAIN",134, 0)
  7686    . . F PXK I=1:1:$L(P XKBEF(PXKS UB,PXKSUBI EN),"^") D
  7687   "RTN","PXK MAIN",135, 0)
  7688    . . . I $ P(PXKBEF(P XKSUB,PXKS UBIEN),"^" ,PXKI)'=""  S PXKBV(P XKSUB,PXKS UBIEN,PXKI )=$P(PXKBE F(PXKSUB,P XKSUBIEN), "^",PXKI)
  7689   "RTN","PXK MAIN",136, 0)
  7690    ;
  7691   "RTN","PXK MAIN",137, 0)
  7692    I $G(@PXK REF@(PXKCA T,PXKSEQ,P XKSUB,0,"A FTER"))="@ " D
  7693   "RTN","PXK MAIN",138, 0)
  7694    . S PXKAF T(PXKSUB,0 )="@"
  7695   "RTN","PXK MAIN",139, 0)
  7696    . S PXKAV (PXKSUB,0) ="@"
  7697   "RTN","PXK MAIN",140, 0)
  7698    ;
  7699   "RTN","PXK MAIN",141, 0)
  7700    Q
  7701   "RTN","PXK MAIN",142, 0)
  7702    ;
  7703   "RTN","PXK MAIN",143, 0)
  7704   EXIT ;--EX IT
  7705   "RTN","PXK MAIN",144, 0)
  7706    I $D(PXKF VDLM) D MO DIFIED^VSI T(PXKVST)
  7707   "RTN","PXK MAIN",145, 0)
  7708    K PXKPXD, TMPPX
  7709   "RTN","PXK MAIN",146, 0)
  7710    K DA,DR,P XKI,PXKJ,P XKLAYGO,PX KDUZ,PXKAF T8,PXKAFTR ,VSIT("IEN ") Q
  7711   "RTN","PXK MAIN",147, 0)
  7712   EVENT ;--E NTRY POINT  TO POST E XECUTE PCE 'S EVENT
  7713   "RTN","PXK MAIN",148, 0)
  7714    ;Setting  the variab le PXKNOEV T=1 will s top the ev ent from b eing
  7715   "RTN","PXK MAIN",149, 0)
  7716    ;fired of f whenever  any data  is sent in to PCE
  7717   "RTN","PXK MAIN",150, 0)
  7718    ;
  7719   "RTN","PXK MAIN",151, 0)
  7720    ;PX*1*124   AUTO-POP ULATE THE  ENCOUNTER  SC/EI BASE D ON THE E NCOUNTER D X'S
  7721   "RTN","PXK MAIN",152, 0)
  7722    ;PX*1.0*1 64 Relocat e the PXCE CCLS call
  7723   "RTN","PXK MAIN",153, 0)
  7724    I $D(^TMP ("PXKCO",$ J)) D
  7725   "RTN","PXK MAIN",154, 0)
  7726    . S PXKVV ST=+$O(^TM P("PXKCO", $J,0))
  7727   "RTN","PXK MAIN",155, 0)
  7728    . I $G(PX KVVST) D V ST^PXCECCL S(PXKVVST)  ;PX*1.0*1 74
  7729   "RTN","PXK MAIN",156, 0)
  7730    ;
  7731   "RTN","PXK MAIN",157, 0)
  7732    I $G(PXKN OEVT) K ^T MP("PXKCO" ,$J) Q
  7733   "RTN","PXK MAIN",158, 0)
  7734    N PXP59LO C
  7735   "RTN","PXK MAIN",159, 0)
  7736    D LOCK
  7737   "RTN","PXK MAIN",160, 0)
  7738    D EVENT^P XKMASC
  7739   "RTN","PXK MAIN",161, 0)
  7740    I $D(PXP5 9LOC) D UN LOCK
  7741   "RTN","PXK MAIN",162, 0)
  7742    Q
  7743   "RTN","PXK MAIN",163, 0)
  7744   LOCK ; Loc k (results  in PXP59L OC)--Patch  PX*1.0*59 .
  7745   "RTN","PXK MAIN",164, 0)
  7746    N PX0,PXW HO,PXWHERE ,PXWHEN,PX EXIT,PXVIS IT
  7747   "RTN","PXK MAIN",165, 0)
  7748    S PXEXIT= 1,(PXWHO,P XWHERE,PXW HEN)=""
  7749   "RTN","PXK MAIN",166, 0)
  7750    ;First ca se: new vi sit data b eing saved .
  7751   "RTN","PXK MAIN",167, 0)
  7752    I 11[$D(^ TMP("PXK", $J,"VST",1 ,0,"AFTER" )) D
  7753   "RTN","PXK MAIN",168, 0)
  7754    . S PX0=^ TMP("PXK", $J,"VST",1 ,0,"AFTER" )
  7755   "RTN","PXK MAIN",169, 0)
  7756    . D L2
  7757   "RTN","PXK MAIN",170, 0)
  7758    ;Second c ase: use e xisting vi sit data.
  7759   "RTN","PXK MAIN",171, 0)
  7760    I 11[$D(^ TMP("PXK", $J,"VST",1 ,"IEN")) D
  7761   "RTN","PXK MAIN",172, 0)
  7762    . S PXVIS IT=+^TMP(" PXK",$J,"V ST",1,"IEN ")
  7763   "RTN","PXK MAIN",173, 0)
  7764    . Q:'PXVI SIT
  7765   "RTN","PXK MAIN",174, 0)
  7766    . Q:$D(^A UPNVSIT(PX VISIT,0))[ 0
  7767   "RTN","PXK MAIN",175, 0)
  7768    . S PX0=^ AUPNVSIT(P XVISIT,0)
  7769   "RTN","PXK MAIN",176, 0)
  7770    . D L2
  7771   "RTN","PXK MAIN",177, 0)
  7772    ;Third ca se: Uses " PXKCO" ins tead of "P XK".
  7773   "RTN","PXK MAIN",178, 0)
  7774    I PXEXIT, $D(^TMP("P XKCO",$J))  D
  7775   "RTN","PXK MAIN",179, 0)
  7776    . S PXVIS IT=$O(^TMP ("PXKCO",$ J,0))
  7777   "RTN","PXK MAIN",180, 0)
  7778    . Q:'PXVI SIT
  7779   "RTN","PXK MAIN",181, 0)
  7780    . S PX0=$ G(^TMP("PX KCO",$J,PX VISIT,"VST ",PXVISIT, 0,"AFTER") )
  7781   "RTN","PXK MAIN",182, 0)
  7782    . Q:PX0=" "
  7783   "RTN","PXK MAIN",183, 0)
  7784    . D L2
  7785   "RTN","PXK MAIN",184, 0)
  7786    ;Fourth c ase: Uses  "PXKENC" i nstead of  "PXK".
  7787   "RTN","PXK MAIN",185, 0)
  7788    I PXEXIT, $D(^TMP("P XKENC",$J) ) D
  7789   "RTN","PXK MAIN",186, 0)
  7790    . S PXVIS IT=$O(^TMP ("PXKENC", $J,0))
  7791   "RTN","PXK MAIN",187, 0)
  7792    . Q:'PXVI SIT
  7793   "RTN","PXK MAIN",188, 0)
  7794    . S PX0=$ G(^TMP("PX KENC",$J,P XVISIT,"VS T",PXVISIT ,0)) ; Loo k at ^TMP( "PXKENC",$ J
  7795   "RTN","PXK MAIN",189, 0)
  7796    . Q:PX0=" "
  7797   "RTN","PXK MAIN",190, 0)
  7798    . D L2
  7799   "RTN","PXK MAIN",191, 0)
  7800    I PXEXIT  Q  ; Unabl e to obtai n non-null  subscript s.
  7801   "RTN","PXK MAIN",192, 0)
  7802    S PXP59LO C=$NA(^PXL OCK(PXWHO, PXWHERE,PX WHEN))
  7803   "RTN","PXK MAIN",193, 0)
  7804    L +@PXP59 LOC:300
  7805   "RTN","PXK MAIN",194, 0)
  7806    E  K PXP5 9LOC ; Loc k was unsu ccessful.
  7807   "RTN","PXK MAIN",195, 0)
  7808    Q
  7809   "RTN","PXK MAIN",196, 0)
  7810   L2 ; Get v alues from  visit 0 n ode (PX0).
  7811   "RTN","PXK MAIN",197, 0)
  7812    I 'PXWHO  S PXWHO=$P (PX0,U,5)
  7813   "RTN","PXK MAIN",198, 0)
  7814    I 'PXWHEN  S PXWHEN= $P(PX0,U,1 )
  7815   "RTN","PXK MAIN",199, 0)
  7816    I 'PXWHER E S PXWHER E=+$P(PX0, U,22)
  7817   "RTN","PXK MAIN",200, 0)
  7818    I PXWHO,P XWHEN S PX EXIT=0
  7819   "RTN","PXK MAIN",201, 0)
  7820    Q
  7821   "RTN","PXK MAIN",202, 0)
  7822   UNLOCK ; U nlock (use  info in P XP59LOC)-- Patch PX*1 .0*59.
  7823   "RTN","PXK MAIN",203, 0)
  7824    L -@PXP59 LOC
  7825   "RTN","PXK MAIN",204, 0)
  7826    Q
  7827   "RTN","PXK MAIN",205, 0)
  7828    ;
  7829   "RTN","PXK MAIN",206, 0)
  7830   CQDEL ;Cla ssificatio n question  deletion  check
  7831   "RTN","PXK MAIN",207, 0)
  7832    I PXKCAT' ="VST" Q
  7833   "RTN","PXK MAIN",208, 0)
  7834    S PXJ=""  F  S PXJ=$ O(PXKBV(80 0,PXJ)) Q: 'PXJ  I PX KBV(800,PX J)'="" I ' $D(PXKAV(8 00,PXJ)) S  PXKAV(800 ,PXJ)="@"
  7835   "RTN","PXK MAIN",209, 0)
  7836    K PXJ Q
  7837   "RTN","PXK MAIN2")
  7838   0^21^B2582 9818^B1093 8982
  7839   "RTN","PXK MAIN2",1,0 )
  7840   PXKMAIN2 ; ISL/JVS -  Special Ro utine ;04/ 06/16  08: 10
  7841   "RTN","PXK MAIN2",2,0 )
  7842    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**69,1 86,215**;A ug 12, 199 6;Build 10
  7843   "RTN","PXK MAIN2",3,0 )
  7844    ;  VARIAB LES
  7845   "RTN","PXK MAIN2",4,0 )
  7846    ; See var iables lis ts under e ach line t ag
  7847   "RTN","PXK MAIN2",5,0 )
  7848    ;
  7849   "RTN","PXK MAIN2",6,0 )
  7850    ;
  7851   "RTN","PXK MAIN2",7,0 )
  7852   SPEC ;Popu late other  v files
  7853   "RTN","PXK MAIN2",8,0 )
  7854    ;
  7855   "RTN","PXK MAIN2",9,0 )
  7856    ; As of P X*1*215, t his entry  point (and  related P OP tag) ha s been dep recated an d
  7857   "RTN","PXK MAIN2",10, 0)
  7858    ; replace d with SPE C2. This i s part of  deprecatin g the PCE  CODE MAPPI NG file,
  7859   "RTN","PXK MAIN2",11, 0)
  7860    ; and ins tead using  the CODIN G SYSTEM m ultiple fr om the Imm unization  and
  7861   "RTN","PXK MAIN2",12, 0)
  7862    ; Skin Te st files.
  7863   "RTN","PXK MAIN2",13, 0)
  7864    ;
  7865   "RTN","PXK MAIN2",14, 0)
  7866    ;  VARIAB LES
  7867   "RTN","PXK MAIN2",15, 0)
  7868    ; PXKAV(0 )  = The A FTER varia bles creat ed in PXKM AIN
  7869   "RTN","PXK MAIN2",16, 0)
  7870    ; PXKBV(0 )  = The B EFORE vari ables crea ted in PXK MAIN
  7871   "RTN","PXK MAIN2",17, 0)
  7872    ; PXKFG(E D,DE,AD) = The EDIT,D ELETE,ADD  flags
  7873   "RTN","PXK MAIN2",18, 0)
  7874    ; PXKCAT     = The c ategory be ing $o thr ough (CPT, IMM etc... )
  7875   "RTN","PXK MAIN2",19, 0)
  7876    ; PXKIN      = The p ointer val ue of firs t piece in  the mappi ng file
  7877   "RTN","PXK MAIN2",20, 0)
  7878    ; PXKPXD     = An ar ray with a ll the ent ries to be  mapped th is go arou nd
  7879   "RTN","PXK MAIN2",21, 0)
  7880    ; PXKDIEN    = IEN o f the codi ng file
  7881   "RTN","PXK MAIN2",22, 0)
  7882    ;
  7883   "RTN","PXK MAIN2",23, 0)
  7884    S PXKDONE =0
  7885   "RTN","PXK MAIN2",24, 0)
  7886    Q:PXKFGED =1
  7887   "RTN","PXK MAIN2",25, 0)
  7888    I (PXKFGA D=1) D
  7889   "RTN","PXK MAIN2",26, 0)
  7890    .I $D(^PX D(811.1,"A A",PXKAV(0 ,1),""_PXK CAT_"",1))  D
  7891   "RTN","PXK MAIN2",27, 0)
  7892    ..S PXKDO NE=$O(^PXD (811.1,"AA ",PXKAV(0, 1),""_PXKC AT_"",1,PX KDONE))
  7893   "RTN","PXK MAIN2",28, 0)
  7894    ..S PXJ(1 )=$G(^PXD( 811.1,PXKD ONE,0)) ;8 TH IEN
  7895   "RTN","PXK MAIN2",29, 0)
  7896    ..S PXJ(2 )=$P(PXJ(1 ),"^",2) ; SECOND PIE CE OF 8TH  IEN
  7897   "RTN","PXK MAIN2",30, 0)
  7898    ..S PXJ(3 )=$P(PXJ(2 ),";",1) ; FIRST PIEC E OF ABOVE
  7899   "RTN","PXK MAIN2",31, 0)
  7900    ..S PXJ(4 )=$P(PXJ(1 ),"^",4) ; TO
  7901   "RTN","PXK MAIN2",32, 0)
  7902    ..S PXKDO NE=$O(^PXD (811.1,"AA ",PXJ(3)," "_PXJ(4)_" ",1,0))
  7903   "RTN","PXK MAIN2",33, 0)
  7904    ..S:PXKDO NE="" PXKD ONE=0  I ' $D(PXKPXD( $G(PXKDONE ))) D POP
  7905   "RTN","PXK MAIN2",34, 0)
  7906    I (PXKFGD E=1) D
  7907   "RTN","PXK MAIN2",35, 0)
  7908    .I $D(^PX D(811.1,"A A",PXKBV(0 ,1),""_PXK CAT_"",1))  D
  7909   "RTN","PXK MAIN2",36, 0)
  7910    ..S PXKDO NE=$O(^PXD (811.1,"AA ",PXKBV(0, 1),""_PXKC AT_"",1,PX KDONE))
  7911   "RTN","PXK MAIN2",37, 0)
  7912    ..S PXJ(1 )=$G(^PXD( 811.1,PXKD ONE,0)) ;8 TH IEN
  7913   "RTN","PXK MAIN2",38, 0)
  7914    ..S PXJ(2 )=$P(PXJ(1 ),"^",2) ; SECOND PIE CE OF 8TH  IEN
  7915   "RTN","PXK MAIN2",39, 0)
  7916    ..S PXJ(3 )=$P(PXJ(2 ),";",1) ; FIRST PIEC E OF ABOVE
  7917   "RTN","PXK MAIN2",40, 0)
  7918    ..S PXJ(4 )=$P(PXJ(1 ),"^",4) ; TO
  7919   "RTN","PXK MAIN2",41, 0)
  7920    ..S PXKDO NE=$O(^PXD (811.1,"AA ",PXJ(3)," "_PXJ(4)_" ",1,0))
  7921   "RTN","PXK MAIN2",42, 0)
  7922    ..S:PXKDO NE="" PXKD ONE=0  I ' $D(PXKPXD( $G(PXKDONE ))) D POP
  7923   "RTN","PXK MAIN2",43, 0)
  7924    K PXKDONE
  7925   "RTN","PXK MAIN2",44, 0)
  7926    Q
  7927   "RTN","PXK MAIN2",45, 0)
  7928    ;
  7929   "RTN","PXK MAIN2",46, 0)
  7930   POP ;Popul ation of m ore than o ne v file  using PCE  CODE MAPPI NG file 81 1.1
  7931   "RTN","PXK MAIN2",47, 0)
  7932    ;
  7933   "RTN","PXK MAIN2",48, 0)
  7934    ;N PXKPXD
  7935   "RTN","PXK MAIN2",49, 0)
  7936    N PXKROU, PXKIN,PXKX ,PXKXX,PXK DIEN,PXKTO
  7937   "RTN","PXK MAIN2",50, 0)
  7938    S PXKIN=$ S(PXKFGAD= 1:PXKAV(0, 1),PXKFGDE =1:PXKBV(0 ,1),1:"")
  7939   "RTN","PXK MAIN2",51, 0)
  7940    S PXKDIEN =0 F  S PX KDIEN=$O(^ PXD(811.1, "AA",PXKIN ,PXKCAT,1, PXKDIEN))  Q:PXKDIEN= ""  D
  7941   "RTN","PXK MAIN2",52, 0)
  7942    .S PXKPXD (PXKDIEN)= $G(^PXD(81 1.1,PXKDIE N,0))
  7943   "RTN","PXK MAIN2",53, 0)
  7944    S (PXKX,P XKXX)=0 F   S PXKX=$O (PXKPXD(PX KX)) Q:PXK X=""  S PX KXX=PXKXX+ .01 D
  7945   "RTN","PXK MAIN2",54, 0)
  7946    .I TMPPX[ ("^"_PXKX_ "^") Q
  7947   "RTN","PXK MAIN2",55, 0)
  7948    .S PXKTO= $P(PXKPXD( PXKX),"^", 4)
  7949   "RTN","PXK MAIN2",56, 0)
  7950    .S PXKROU =$P(PXKPXD (PXKX),"^" ,3)_"^PXKF "_PXKTO_"1 " D @PXKRO U
  7951   "RTN","PXK MAIN2",57, 0)
  7952    .S TMPPX= TMPPX_PXKX _"^"
  7953   "RTN","PXK MAIN2",58, 0)
  7954    S PXKNORG ("SOR")=$G (^TMP("PXK ",$J,"SOR" ))
  7955   "RTN","PXK MAIN2",59, 0)
  7956    S PXKNORG ("VSTIEN") =$G(^TMP(" PXK",$J,"V ST",1,"IEN "))
  7957   "RTN","PXK MAIN2",60, 0)
  7958    Q
  7959   "RTN","PXK MAIN2",61, 0)
  7960    ;
  7961   "RTN","PXK MAIN2",62, 0)
  7962    ;
  7963   "RTN","PXK MAIN2",63, 0)
  7964   SPEC2 ;
  7965   "RTN","PXK MAIN2",64, 0)
  7966    ; Populat es V CPT a nd V POV f iles based  off Immun ization an d
  7967   "RTN","PXK MAIN2",65, 0)
  7968    ; Skin Te st Coding  System map pings.
  7969   "RTN","PXK MAIN2",66, 0)
  7970    ;
  7971   "RTN","PXK MAIN2",67, 0)
  7972    ; As of P X*1*215, t his entry  point repl aces SPEC.
  7973   "RTN","PXK MAIN2",68, 0)
  7974    ; We now  use the Co ding Syste m multiple  instead o f the PCE  Code Mappi ng file.
  7975   "RTN","PXK MAIN2",69, 0)
  7976    ;
  7977   "RTN","PXK MAIN2",70, 0)
  7978    N PXCIEN, PXCODE,PXC ODESYS,PXC OUNT,PXCSI EN,PXFROME NTRY,PXGLB L,PXKROU,P XKX,PXKXX, PXVISIT,PX VSC
  7979   "RTN","PXK MAIN2",71, 0)
  7980    ;
  7981   "RTN","PXK MAIN2",72, 0)
  7982    I PXKFGED =1 Q
  7983   "RTN","PXK MAIN2",73, 0)
  7984    ;
  7985   "RTN","PXK MAIN2",74, 0)
  7986    S PXFROME NTRY=$S(PX KFGAD=1:PX KAV(0,1),P XKFGDE=1:P XKBV(0,1), 1:"0")
  7987   "RTN","PXK MAIN2",75, 0)
  7988    I 'PXFROM ENTRY Q
  7989   "RTN","PXK MAIN2",76, 0)
  7990    ;
  7991   "RTN","PXK MAIN2",77, 0)
  7992    I PXKCAT= "IMM" S PX GLBL="^AUT TIMM("_PXF ROMENTRY_" )"
  7993   "RTN","PXK MAIN2",78, 0)
  7994    I PXKCAT= "SK" S PXG LBL="^AUTT SK("_PXFRO MENTRY_")"
  7995   "RTN","PXK MAIN2",79, 0)
  7996    ; Only fi le codes f rom IMM/SK  -> V CPT  and V POV
  7997   "RTN","PXK MAIN2",80, 0)
  7998    I $G(PXGL BL)="" Q
  7999   "RTN","PXK MAIN2",81, 0)
  8000    ;
  8001   "RTN","PXK MAIN2",82, 0)
  8002    ; Only fi le for VA- Administer ed (non-hi storical)  entries
  8003   "RTN","PXK MAIN2",83, 0)
  8004    S PXVISIT =$G(^TMP(" PXK",$J,"V ST",1,"IEN "))
  8005   "RTN","PXK MAIN2",84, 0)
  8006    S PXVSC=$ P($G(^AUPN VSIT(+PXVI SIT,0)),U, 7)
  8007   "RTN","PXK MAIN2",85, 0)
  8008    I "AHISOR D"'[PXVSC  Q
  8009   "RTN","PXK MAIN2",86, 0)
  8010    ;
  8011   "RTN","PXK MAIN2",87, 0)
  8012    F PXCODES YS="CPT"," 10D" D
  8013   "RTN","PXK MAIN2",88, 0)
  8014    . S PXCSI EN=$O(@PXG LBL@(3,"B" ,PXCODESYS ,0))
  8015   "RTN","PXK MAIN2",89, 0)
  8016    . I 'PXCS IEN Q
  8017   "RTN","PXK MAIN2",90, 0)
  8018    . ;
  8019   "RTN","PXK MAIN2",91, 0)
  8020    . S PXCOD E=""
  8021   "RTN","PXK MAIN2",92, 0)
  8022    . S PXCOU NT=0
  8023   "RTN","PXK MAIN2",93, 0)
  8024    . S PXCIE N=0
  8025   "RTN","PXK MAIN2",94, 0)
  8026    . F  S PX CIEN=$O(@P XGLBL@(3,P XCSIEN,1,P XCIEN)) Q: 'PXCIEN  D
  8027   "RTN","PXK MAIN2",95, 0)
  8028    . . S PXC ODE=$P($G( @PXGLBL@(3 ,PXCSIEN,1 ,PXCIEN,0) ),U,1)
  8029   "RTN","PXK MAIN2",96, 0)
  8030    . . S PXC OUNT=PXCOU NT+1
  8031   "RTN","PXK MAIN2",97, 0)
  8032    . ;
  8033   "RTN","PXK MAIN2",98, 0)
  8034    . ; Only  file, when  there is  one code m apped to t he IMM/SK  entry
  8035   "RTN","PXK MAIN2",99, 0)
  8036    . I PXCOU NT'=1 Q
  8037   "RTN","PXK MAIN2",100 ,0)
  8038    . ;
  8039   "RTN","PXK MAIN2",101 ,0)
  8040    . I PXCOD ESYS="CPT"  S PXCODE= $$CODEN^IC PTCOD(PXCO DE)
  8041   "RTN","PXK MAIN2",102 ,0)
  8042    . I PXCOD ESYS="10D"  S PXCODE= +$$CODEN^I CDEX(PXCOD E,80) ;IA  5747
  8043   "RTN","PXK MAIN2",103 ,0)
  8044    . I PXCOD E'>0 Q
  8045   "RTN","PXK MAIN2",104 ,0)
  8046    . ;
  8047   "RTN","PXK MAIN2",105 ,0)
  8048    . S PXKX= ($O(PXKPXD (""),-1))+ 1
  8049   "RTN","PXK MAIN2",106 ,0)
  8050    . S PXKPX D(PXKX)=PX FROMENTRY_ ";"_$S(PXK CAT="IMM": "AUTTIMM(" ,1:"AUTTSK (")
  8051   "RTN","PXK MAIN2",107 ,0)
  8052    . S PXKPX D(PXKX)=PX KPXD(PXKX) _U_PXCODE_ ";"_$S(PXC ODESYS="CP T":"ICPT(" ,1:"ICD9(" )
  8053   "RTN","PXK MAIN2",108 ,0)
  8054    . S PXKPX D(PXKX)=PX KPXD(PXKX) _U_PXKCAT_ U_PXCODESY S_U_"1"
  8055   "RTN","PXK MAIN2",109 ,0)
  8056    . S PXKXX =PXKX*.01
  8057   "RTN","PXK MAIN2",110 ,0)
  8058    . ;
  8059   "RTN","PXK MAIN2",111 ,0)
  8060    . S PXKRO U=PXKCAT_" ^PXKF"_$S( PXCODESYS= "CPT":"CPT ",1:"POV") _"1"
  8061   "RTN","PXK MAIN2",112 ,0)
  8062    . D @PXKR OU
  8063   "RTN","PXK MAIN2",113 ,0)
  8064    . ;
  8065   "RTN","PXK MAIN2",114 ,0)
  8066    . S PXKNO RG("SOR")= $G(^TMP("P XK",$J,"SO R"))
  8067   "RTN","PXK MAIN2",115 ,0)
  8068    . S PXKNO RG("VSTIEN ")=$G(^TMP ("PXK",$J, "VST",1,"I EN"))
  8069   "RTN","PXK MAIN2",116 ,0)
  8070    ;
  8071   "RTN","PXK MAIN2",117 ,0)
  8072    Q
  8073   "RTN","PXK MAIN2",118 ,0)
  8074    ;
  8075   "RTN","PXK MAIN2",119 ,0)
  8076    ;
  8077   "RTN","PXK MAIN2",120 ,0)
  8078   RECALL ; R ecall PXKM AIN to pop ulate spec ial circum stances
  8079   "RTN","PXK MAIN2",121 ,0)
  8080    D EVENT^P XKMAIN K ^ TMP("PXK", $J)
  8081   "RTN","PXK MAIN2",122 ,0)
  8082    S PXKREF= "^TMP(""PX KSAVE"",$J )"
  8083   "RTN","PXK MAIN2",123 ,0)
  8084    F  S PXKR EF=$Q(@PXK REF) Q:$P( PXKREF,"," ,1)'["PXKS AVE"  Q:$P (PXKREF,", ",2)'[$J   Q:PXKREF=" "  S PXKSA VE=PXKREF  D
  8085   "RTN","PXK MAIN2",124 ,0)
  8086    .S $P(PXK SAVE,"""", 2)="PXK" S  @PXKSAVE= $G(@PXKREF )
  8087   "RTN","PXK MAIN2",125 ,0)
  8088    S ^TMP("P XK",$J,"SO R")=$G(PXK NORG("SOR" ))
  8089   "RTN","PXK MAIN2",126 ,0)
  8090    S ^TMP("P XK",$J,"VS T",1,"IEN" )=$G(PXKNO RG("VSTIEN "))
  8091   "RTN","PXK MAIN2",127 ,0)
  8092    K ^TMP("P XKSAVE",$J ),PXKNORG
  8093   "RTN","PXK MAIN2",128 ,0)
  8094    D EN1^PXK MAIN,EVENT ^PXKMAIN
  8095   "RTN","PXK MAIN2",129 ,0)
  8096    Q
  8097   "RTN","PXK MAIN2",130 ,0)
  8098    ;
  8099   "RTN","PXK MAIN2",131 ,0)
  8100    ;
  8101   "RTN","PXK MAIN2",132 ,0)
  8102   PRVTYPE ;- --POPULATE  PROVIDER  TYPE
  8103   "RTN","PXK MAIN2",133 ,0)
  8104    ;
  8105   "RTN","PXK MAIN2",134 ,0)
  8106    ;--**
  8107   "RTN","PXK MAIN2",135 ,0)
  8108    I '$D(^TM P("PXK",$J ,"PRV")) Q
  8109   "RTN","PXK MAIN2",136 ,0)
  8110    I '$L($T( GET^XUA4A7 2)) Q
  8111   "RTN","PXK MAIN2",137 ,0)
  8112    N PXKPSUB ,PXKPRV,PX KDT,NOD0,T YPE
  8113   "RTN","PXK MAIN2",138 ,0)
  8114    S PXKPSUB =0 F  S PX KPSUB=$O(^ TMP("PXK", $J,"PRV",P XKPSUB)) Q :PXKPSUB=" "  D
  8115   "RTN","PXK MAIN2",139 ,0)
  8116    .S NOD0=$ G(^TMP("PX K",$J,"PRV ",PXKPSUB, 0,"AFTER") )
  8117   "RTN","PXK MAIN2",140 ,0)
  8118    .S PXKPRV =$P(NOD0," ^",1)
  8119   "RTN","PXK MAIN2",141 ,0)
  8120    .I '$G(PX KPRV) Q
  8121   "RTN","PXK MAIN2",142 ,0)
  8122    .S PXKDT= +$P($G(^AU PNVSIT($G( ^TMP("PXK" ,$J,"VST", 1,"IEN")), 0)),"^",1)
  8123   "RTN","PXK MAIN2",143 ,0)
  8124    .;--** AD D FUNCTION
  8125   "RTN","PXK MAIN2",144 ,0)
  8126    .S TYPE=+ $$GET^XUA4 A72($G(PXK PRV),+$P($ G(PXKDT)," .")) Q:TYP E<1
  8127   "RTN","PXK MAIN2",145 ,0)
  8128    .I $P(NOD 0,"^",6)'] "" S $P(NO D0,"^",6)= TYPE
  8129   "RTN","PXK MAIN2",146 ,0)
  8130    .S ^TMP(" PXK",$J,"P RV",PXKPSU B,0,"AFTER ")=NOD0
  8131   "RTN","PXK MAIN2",147 ,0)
  8132    Q
  8133   "RTN","PXP XRM")
  8134   0^5^B12559 0932^B8890 4295
  8135   "RTN","PXP XRM",1,0)
  8136   PXPXRM ;SL C/PKR - AP Is for Cli nical Remi nder index es. ;03/31 /16  15:08
  8137   "RTN","PXP XRM",2,0)
  8138    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**119, 199,210,21 5**;Aug 12 , 1996;Bui ld 10
  8139   "RTN","PXP XRM",3,0)
  8140    ;
  8141   "RTN","PXP XRM",4,0)
  8142    ; Referen ce to CODE C^ICDEX su pported by  ICR #5747
  8143   "RTN","PXP XRM",5,0)
  8144    ; Referen ce to CSI^ ICDEX supp orted by I CR #5747
  8145   "RTN","PXP XRM",6,0)
  8146    ; Referen ce to SINF O^ICDEX su pported by  ICR #5747
  8147   "RTN","PXP XRM",7,0)
  8148    ; Referen ce to NAME  in file . 85 is supp orted by I CR #6062
  8149   "RTN","PXP XRM",8,0)
  8150    ;
  8151   "RTN","PXP XRM",9,0)
  8152    Q
  8153   "RTN","PXP XRM",10,0)
  8154    ;======== ========== ========== ========== ========== ========== =====
  8155   "RTN","PXP XRM",11,0)
  8156   KVFILE(FIL ENUM,X,DA)  ;Delete i ndexes for  a regular  V File.
  8157   "RTN","PXP XRM",12,0)
  8158    N CVX,VDA TE,VISIT
  8159   "RTN","PXP XRM",13,0)
  8160    S VISIT=$ G(^AUPNVSI T(X(3),0))
  8161   "RTN","PXP XRM",14,0)
  8162    I VISIT=" " Q
  8163   "RTN","PXP XRM",15,0)
  8164    S VDATE=$ P(VISIT,U, 1)
  8165   "RTN","PXP XRM",16,0)
  8166    ;
  8167   "RTN","PXP XRM",17,0)
  8168    I FILENUM =9000010.1 1 D  ; if  V IMMUNIZA TION: kill  CVX index ; and use  Event DT,  if availab le
  8169   "RTN","PXP XRM",18,0)
  8170    . I $G(X( 4)) S VDAT E=X(4)
  8171   "RTN","PXP XRM",19,0)
  8172    . S CVX=$ P($G(^AUTT IMM(X(1),0 )),U,3)
  8173   "RTN","PXP XRM",20,0)
  8174    . I CVX'= "" D
  8175   "RTN","PXP XRM",21,0)
  8176    . . K ^PX RMINDX(FIL ENUM,"CVX" ,"IP",CVX, X(2),VDATE ,DA)
  8177   "RTN","PXP XRM",22,0)
  8178    . . K ^PX RMINDX(FIL ENUM,"CVX" ,"PI",X(2) ,CVX,VDATE ,DA)
  8179   "RTN","PXP XRM",23,0)
  8180    ;
  8181   "RTN","PXP XRM",24,0)
  8182    K ^PXRMIN DX(FILENUM ,"IP",X(1) ,X(2),VDAT E,DA)
  8183   "RTN","PXP XRM",25,0)
  8184    K ^PXRMIN DX(FILENUM ,"PI",X(2) ,X(1),VDAT E,DA)
  8185   "RTN","PXP XRM",26,0)
  8186    Q
  8187   "RTN","PXP XRM",27,0)
  8188    ;
  8189   "RTN","PXP XRM",28,0)
  8190    ;======== ========== ========== ========== ========== ========== =====
  8191   "RTN","PXP XRM",29,0)
  8192   KVFILEC(FI LENUM,X,DA ) ;Delete  indexes fo r V Files  with coded  entries.
  8193   "RTN","PXP XRM",30,0)
  8194    ; FILENUM  = file nu mber, e.g.  9000010.0 7
  8195   "RTN","PXP XRM",31,0)
  8196    ;       X  = Array o f fields
  8197   "RTN","PXP XRM",32,0)
  8198    ;            X(1) =  Item point er:  Dx fo r V POV, C PT for V C PT
  8199   "RTN","PXP XRM",33,0)
  8200    ;            X(2) =  PATIENT NA ME (DFN)
  8201   "RTN","PXP XRM",34,0)
  8202    ;            X(3) =  VISIT (ptr  to 900001 0)
  8203   "RTN","PXP XRM",35,0)
  8204    ;            X(4) =  PRIMARY/SE CONDARY fo r V POV
  8205   "RTN","PXP XRM",36,0)
  8206    ;                or  PRINCIPAL  PROCEDURE  FOR V CPT
  8207   "RTN","PXP XRM",37,0)
  8208    ;      DA  = IEN int o FILENUM  file
  8209   "RTN","PXP XRM",38,0)
  8210    N CODE,CT YPE,PXCSYS ,VDATE,VIS IT
  8211   "RTN","PXP XRM",39,0)
  8212    S VISIT=$ G(^AUPNVSI T(X(3),0))  ; get Vis it zero no de
  8213   "RTN","PXP XRM",40,0)
  8214    I VISIT=" " Q  ; if  Visit not  found, bai l out
  8215   "RTN","PXP XRM",41,0)
  8216    S CTYPE=$ S(X(4)="": "U",1:X(4) ) ; U if b lank other wise use v alue passe d in
  8217   "RTN","PXP XRM",42,0)
  8218    S VDATE=$ P(VISIT,U, 1) ; get V isit Date/ Time from  1st piece  of zero no de
  8219   "RTN","PXP XRM",43,0)
  8220    S PXCSYS= "ICD"
  8221   "RTN","PXP XRM",44,0)
  8222    I FILENUM =9000010.0 7 D  ; if  V POV get  Coding Sys tem type
  8223   "RTN","PXP XRM",45,0)
  8224    . S PXCSY S=$P($$SIN FO^ICDEX($ $CSI^ICDEX (80,X(1))) ,U,3) ; co ding syste m abbrevia tion
  8225   "RTN","PXP XRM",46,0)
  8226    I PXCSYS' ="ICD" D K VFILEV Q   ; if not I CD-9, use  alternate  format and  Quit
  8227   "RTN","PXP XRM",47,0)
  8228    ; the fol lowing is  the origin al format  used for V  CPT and I CD-9 diagn oses
  8229   "RTN","PXP XRM",48,0)
  8230    K ^PXRMIN DX(FILENUM ,"IPP",X(1 ),CTYPE,X( 2),VDATE,D A) ; Kill  the "IPP"  node
  8231   "RTN","PXP XRM",49,0)
  8232    K ^PXRMIN DX(FILENUM ,"PPI",X(2 ),CTYPE,X( 1),VDATE,D A) ; Kill  the "PPI"  node
  8233   "RTN","PXP XRM",50,0)
  8234    Q
  8235   "RTN","PXP XRM",51,0)
  8236    ;
  8237   "RTN","PXP XRM",52,0)
  8238    ;======== ========== ========== ========== ========== ========== =====
  8239   "RTN","PXP XRM",53,0)
  8240   KVFILEV ;  alternate  index form at for ICD -10 and hi gher, adde d with PX* 1.0*199
  8241   "RTN","PXP XRM",54,0)
  8242    S CODE=$$ CODEC^ICDE X(80,X(1))  ; convert  IEN to Dx  code
  8243   "RTN","PXP XRM",55,0)
  8244    K ^PXRMIN DX(FILENUM ,PXCSYS,"I PP",CODE,C TYPE,X(2), VDATE,DA)
  8245   "RTN","PXP XRM",56,0)
  8246    K ^PXRMIN DX(FILENUM ,PXCSYS,"P PI",X(2),C TYPE,CODE, VDATE,DA)
  8247   "RTN","PXP XRM",57,0)
  8248    Q
  8249   "RTN","PXP XRM",58,0)
  8250    ;
  8251   "RTN","PXP XRM",59,0)
  8252    ;======== ========== ========== ========== ========== ========== =====
  8253   "RTN","PXP XRM",60,0)
  8254   SVFILE(FIL ENUM,X,DA)  ;Set inde xes for a  regular V  File.
  8255   "RTN","PXP XRM",61,0)
  8256    ;X(1)=ITE M, X(2)=DF N, X(3)=VI SIT.
  8257   "RTN","PXP XRM",62,0)
  8258    ; for V I MMUNIZATIO N X(4)=EVE NT DATE AN D TIME
  8259   "RTN","PXP XRM",63,0)
  8260    N CVX,VDA TE,VISIT
  8261   "RTN","PXP XRM",64,0)
  8262    S VISIT=$ G(^AUPNVSI T(X(3),0))
  8263   "RTN","PXP XRM",65,0)
  8264    I VISIT=" " Q
  8265   "RTN","PXP XRM",66,0)
  8266    S VDATE=$ P(VISIT,U, 1)
  8267   "RTN","PXP XRM",67,0)
  8268    ;
  8269   "RTN","PXP XRM",68,0)
  8270    I FILENUM =9000010.1 1 D  ; if  V IMMUNIZA TION: set  CVX index;  and use E vent DT, i f availabl e
  8271   "RTN","PXP XRM",69,0)
  8272    . I $G(X( 4)) S VDAT E=X(4)
  8273   "RTN","PXP XRM",70,0)
  8274    . S CVX=$ P($G(^AUTT IMM(X(1),0 )),U,3)
  8275   "RTN","PXP XRM",71,0)
  8276    . I CVX'= "" D
  8277   "RTN","PXP XRM",72,0)
  8278    . . S ^PX RMINDX(FIL ENUM,"CVX" ,"IP",CVX, X(2),VDATE ,DA)=""
  8279   "RTN","PXP XRM",73,0)
  8280    . . S ^PX RMINDX(FIL ENUM,"CVX" ,"PI",X(2) ,CVX,VDATE ,DA)=""
  8281   "RTN","PXP XRM",74,0)
  8282    ;
  8283   "RTN","PXP XRM",75,0)
  8284    S ^PXRMIN DX(FILENUM ,"IP",X(1) ,X(2),VDAT E,DA)=""
  8285   "RTN","PXP XRM",76,0)
  8286    S ^PXRMIN DX(FILENUM ,"PI",X(2) ,X(1),VDAT E,DA)=""
  8287   "RTN","PXP XRM",77,0)
  8288    Q
  8289   "RTN","PXP XRM",78,0)
  8290    ;
  8291   "RTN","PXP XRM",79,0)
  8292    ;======== ========== ========== ========== ========== ========== =====
  8293   "RTN","PXP XRM",80,0)
  8294   SVFILEC(FI LENUM,X,DA ) ;Set ind exes for V  Files wit h coded en tries. The se
  8295   "RTN","PXP XRM",81,0)
  8296    ;are V CP T and VPOV
  8297   "RTN","PXP XRM",82,0)
  8298    ;X(1)=ITE M, X(2)=DF N, X(3)=VI SIT,
  8299   "RTN","PXP XRM",83,0)
  8300    ; for V C PT X(4)=PR INCIPAL PR OCEDURE
  8301   "RTN","PXP XRM",84,0)
  8302    ; for V P OV X(4)=PR IMARY/SECO NDARY
  8303   "RTN","PXP XRM",85,0)
  8304    N CODE,CT YPE,PXCSYS ,VDATE,VIS IT
  8305   "RTN","PXP XRM",86,0)
  8306    S VISIT=$ G(^AUPNVSI T(X(3),0))
  8307   "RTN","PXP XRM",87,0)
  8308    I VISIT=" " Q
  8309   "RTN","PXP XRM",88,0)
  8310    S CTYPE=$ S(X(4)="": "U",1:X(4) )
  8311   "RTN","PXP XRM",89,0)
  8312    S VDATE=$ P(VISIT,U, 1)
  8313   "RTN","PXP XRM",90,0)
  8314    S PXCSYS= "ICD"
  8315   "RTN","PXP XRM",91,0)
  8316    I FILENUM =9000010.0 7 D  ; if  V POV get  Coding Sys tem type
  8317   "RTN","PXP XRM",92,0)
  8318    . S PXCSY S=$P($$SIN FO^ICDEX($ $CSI^ICDEX (80,X(1))) ,U,3) ; co ding syste m abbrevia tion
  8319   "RTN","PXP XRM",93,0)
  8320    I PXCSYS' ="ICD" D S VFILEV Q   ; if not I CD-9 use a lternate f ormat and  Quit
  8321   "RTN","PXP XRM",94,0)
  8322    ; the fol lowing is  the origin al format  used for V  CPT and I CD-9 diagn oses
  8323   "RTN","PXP XRM",95,0)
  8324    S ^PXRMIN DX(FILENUM ,"IPP",X(1 ),CTYPE,X( 2),VDATE,D A)=""
  8325   "RTN","PXP XRM",96,0)
  8326    S ^PXRMIN DX(FILENUM ,"PPI",X(2 ),CTYPE,X( 1),VDATE,D A)=""
  8327   "RTN","PXP XRM",97,0)
  8328    Q
  8329   "RTN","PXP XRM",98,0)
  8330    ;
  8331   "RTN","PXP XRM",99,0)
  8332    ;======== ========== ========== ========== ========== ========== =====
  8333   "RTN","PXP XRM",100,0 )
  8334   SVFILEV ;  alternate  index form at for ICD -10 and hi gher, adde d with PX* 1.0*199
  8335   "RTN","PXP XRM",101,0 )
  8336    S CODE=$$ CODEC^ICDE X(80,X(1))  ; convert  IEN to Dx  code
  8337   "RTN","PXP XRM",102,0 )
  8338    S ^PXRMIN DX(FILENUM ,PXCSYS,"I PP",CODE,C TYPE,X(2), VDATE,DA)= ""
  8339   "RTN","PXP XRM",103,0 )
  8340    S ^PXRMIN DX(FILENUM ,PXCSYS,"P PI",X(2),C TYPE,CODE, VDATE,DA)= ""
  8341   "RTN","PXP XRM",104,0 )
  8342    Q
  8343   "RTN","PXP XRM",105,0 )
  8344    ;
  8345   "RTN","PXP XRM",106,0 )
  8346    ;======== ========== ========== ========== ========== ========== =====
  8347   "RTN","PXP XRM",107,0 )
  8348   VICRFILE(X ,DA,PXACTI ON) ;Set/K ill indexe s for V Im m Contra/R efusal Eve nts.
  8349   "RTN","PXP XRM",108,0 )
  8350    ;
  8351   "RTN","PXP XRM",109,0 )
  8352    ; Inputs:
  8353   "RTN","PXP XRM",110,0 )
  8354    ;         X - X(1)=C ontra/Refu sal, X(2)= DFN, X(3)= Visit
  8355   "RTN","PXP XRM",111,0 )
  8356    ;             X(4)=I mmunizatio n, X(5)=Ev ent Date a nd Time
  8357   "RTN","PXP XRM",112,0 )
  8358    ;             X(6)=W arn Until  Date
  8359   "RTN","PXP XRM",113,0 )
  8360    ;       D A - V Imm  Contra/Ref usal Event s IEN
  8361   "RTN","PXP XRM",114,0 )
  8362    ; PXACTIO N - "S": S et index
  8363   "RTN","PXP XRM",115,0 )
  8364    ;             "K": K ill index
  8365   "RTN","PXP XRM",116,0 )
  8366    ;
  8367   "RTN","PXP XRM",117,0 )
  8368    N FILENUM ,VISIT,VDA TE,START,S TOP
  8369   "RTN","PXP XRM",118,0 )
  8370    ;
  8371   "RTN","PXP XRM",119,0 )
  8372    S FILENUM =9000010.7 07
  8373   "RTN","PXP XRM",120,0 )
  8374    S VISIT=$ G(^AUPNVSI T(X(3),0))
  8375   "RTN","PXP XRM",121,0 )
  8376    I VISIT=" " Q
  8377   "RTN","PXP XRM",122,0 )
  8378    S VDATE=$ P(VISIT,U, 1)
  8379   "RTN","PXP XRM",123,0 )
  8380    ;
  8381   "RTN","PXP XRM",124,0 )
  8382    S START=V DATE
  8383   "RTN","PXP XRM",125,0 )
  8384    I $G(X(5) ) S START= X(5)
  8385   "RTN","PXP XRM",126,0 )
  8386    ;
  8387   "RTN","PXP XRM",127,0 )
  8388    S STOP=99 99999
  8389   "RTN","PXP XRM",128,0 )
  8390    I $G(X(6) ) S STOP=X (6)
  8391   "RTN","PXP XRM",129,0 )
  8392    ;
  8393   "RTN","PXP XRM",130,0 )
  8394    I PXACTIO N="S" D
  8395   "RTN","PXP XRM",131,0 )
  8396    . S ^PXRM INDX(FILEN UM,"ICP",X (4),X(1),X (2),START, STOP,DA)=" "
  8397   "RTN","PXP XRM",132,0 )
  8398    . S ^PXRM INDX(FILEN UM,"PIC",X (2),X(4),X (1),START, STOP,DA)=" "
  8399   "RTN","PXP XRM",133,0 )
  8400    . S ^PXRM INDX(FILEN UM,"CIP",X (1),X(4),X (2),START, STOP,DA)=" "
  8401   "RTN","PXP XRM",134,0 )
  8402    . S ^PXRM INDX(FILEN UM,"PCI",X (2),X(1),X (4),START, STOP,DA)=" "
  8403   "RTN","PXP XRM",135,0 )
  8404    I PXACTIO N="K" D
  8405   "RTN","PXP XRM",136,0 )
  8406    . K ^PXRM INDX(FILEN UM,"ICP",X (4),X(1),X (2),START, STOP,DA)
  8407   "RTN","PXP XRM",137,0 )
  8408    . K ^PXRM INDX(FILEN UM,"PIC",X (2),X(4),X (1),START, STOP,DA)
  8409   "RTN","PXP XRM",138,0 )
  8410    . K ^PXRM INDX(FILEN UM,"CIP",X (1),X(4),X (2),START, STOP,DA)
  8411   "RTN","PXP XRM",139,0 )
  8412    . K ^PXRM INDX(FILEN UM,"PCI",X (2),X(1),X (4),START, STOP,DA)
  8413   "RTN","PXP XRM",140,0 )
  8414    Q
  8415   "RTN","PXP XRM",141,0 )
  8416    ;
  8417   "RTN","PXP XRM",142,0 )
  8418    ;======== ========== ========== ========== ========== ========== =====
  8419   "RTN","PXP XRM",143,0 )
  8420   UPDCVX(IMM ,CVXOLD,CV XNEW) ;
  8421   "RTN","PXP XRM",144,0 )
  8422    ; Update  CVX Index  on V Immun ization fi le
  8423   "RTN","PXP XRM",145,0 )
  8424    ; Called  from ACR c ross-refer ence on Im munization  file
  8425   "RTN","PXP XRM",146,0 )
  8426    N DA,PXDE SC,PXRTN,P XTASK,PXVA R,PXVOTH,X ,X1,X2
  8427   "RTN","PXP XRM",147,0 )
  8428    I CVXOLD= CVXNEW Q
  8429   "RTN","PXP XRM",148,0 )
  8430    S PXRTN=" UPDCVXT^PX PXRM"
  8431   "RTN","PXP XRM",149,0 )
  8432    S PXDESC= "Clinical  Reminders  CVX index  update for  V IMMUNIZ ATION"
  8433   "RTN","PXP XRM",150,0 )
  8434    S PXVAR=" IMM;CVXOLD ;CVXNEW"
  8435   "RTN","PXP XRM",151,0 )
  8436    S PXVOTH( "ZTDTH")=$ $NOW^XLFDT
  8437   "RTN","PXP XRM",152,0 )
  8438    S PXTASK= $$NODEV^XU TMDEVQ(PXR TN,PXDESC, PXVAR,.PXV OTH)
  8439   "RTN","PXP XRM",153,0 )
  8440    I PXTASK= -1 D UPDCV XT^PXPXRM
  8441   "RTN","PXP XRM",154,0 )
  8442    Q
  8443   "RTN","PXP XRM",155,0 )
  8444    ;
  8445   "RTN","PXP XRM",156,0 )
  8446    ;======== ========== ========== ========== ========== ========== =====
  8447   "RTN","PXP XRM",157,0 )
  8448   UPDCVXT ;T asked from  UPDCVX.
  8449   "RTN","PXP XRM",158,0 )
  8450    ;Variable s IMM, CVX OLD, and C VXNEW pass ed in via  task
  8451   "RTN","PXP XRM",159,0 )
  8452    S ZTREQ=" @"
  8453   "RTN","PXP XRM",160,0 )
  8454    N DATE,DF N,EDATE,VI MM,VISIT
  8455   "RTN","PXP XRM",161,0 )
  8456    S VIMM=0
  8457   "RTN","PXP XRM",162,0 )
  8458    F  S VIMM =$O(^AUPNV IMM("B",IM M,VIMM)) Q :'VIMM  D
  8459   "RTN","PXP XRM",163,0 )
  8460    . S DFN=$ P($G(^AUPN VIMM(VIMM, 0)),U,2)
  8461   "RTN","PXP XRM",164,0 )
  8462    . I 'DFN  Q
  8463   "RTN","PXP XRM",165,0 )
  8464    . S VISIT =$P($G(^AU PNVIMM(VIM M,0)),U,3)
  8465   "RTN","PXP XRM",166,0 )
  8466    . S VISIT =$G(^AUPNV SIT(+VISIT ,0))
  8467   "RTN","PXP XRM",167,0 )
  8468    . I VISIT ="" Q
  8469   "RTN","PXP XRM",168,0 )
  8470    . S DATE= $P(VISIT,U ,1)
  8471   "RTN","PXP XRM",169,0 )
  8472    . S EDATE =$P($G(^AU PNVIMM(VIM M,12)),U,1 )
  8473   "RTN","PXP XRM",170,0 )
  8474    . I EDATE  S DATE=ED ATE
  8475   "RTN","PXP XRM",171,0 )
  8476    . I 'DATE  Q
  8477   "RTN","PXP XRM",172,0 )
  8478    . I CVXOL D'="" D
  8479   "RTN","PXP XRM",173,0 )
  8480    . . K ^PX RMINDX(900 0010.11,"C VX","IP",C VXOLD,DFN, DATE,VIMM)
  8481   "RTN","PXP XRM",174,0 )
  8482    . . K ^PX RMINDX(900 0010.11,"C VX","PI",D FN,CVXOLD, DATE,VIMM)
  8483   "RTN","PXP XRM",175,0 )
  8484    . I CVXNE W'="" D
  8485   "RTN","PXP XRM",176,0 )
  8486    . . S ^PX RMINDX(900 0010.11,"C VX","IP",C VXNEW,DFN, DATE,VIMM) =""
  8487   "RTN","PXP XRM",177,0 )
  8488    . . S ^PX RMINDX(900 0010.11,"C VX","PI",D FN,CVXNEW, DATE,VIMM) =""
  8489   "RTN","PXP XRM",178,0 )
  8490    Q
  8491   "RTN","PXP XRM",179,0 )
  8492    ;
  8493   "RTN","PXP XRM",180,0 )
  8494    ;======== ========== ========== ========== ========== ========== =====
  8495   "RTN","PXP XRM",181,0 )
  8496   VCPT(DA,DA TA) ;Retur n data for  a specifi ed V CPT e ntry.
  8497   "RTN","PXP XRM",182,0 )
  8498    N TEMP
  8499   "RTN","PXP XRM",183,0 )
  8500    S TEMP=^A UPNVCPT(DA ,0)
  8501   "RTN","PXP XRM",184,0 )
  8502    S DATA("V ISIT")=$P( TEMP,U,3)
  8503   "RTN","PXP XRM",185,0 )
  8504    S DATA("P ROVIDER NA RRATIVE")= $P(TEMP,U, 4)
  8505   "RTN","PXP XRM",186,0 )
  8506    S DATA("D IAGNOSIS") =$P(TEMP,U ,5)
  8507   "RTN","PXP XRM",187,0 )
  8508    S DATA("P RINCIPAL P ROCEDURE") =$P(TEMP,U ,7)
  8509   "RTN","PXP XRM",188,0 )
  8510    S DATA("Q UANTITY")= $P(TEMP,U, 16)
  8511   "RTN","PXP XRM",189,0 )
  8512    S DATA("C OMMENTS")= $G(^AUPNVC PT(DA,811) )
  8513   "RTN","PXP XRM",190,0 )
  8514    Q
  8515   "RTN","PXP XRM",191,0 )
  8516    ;
  8517   "RTN","PXP XRM",192,0 )
  8518    ;======== ========== ========== ========== ========== ========== =====
  8519   "RTN","PXP XRM",193,0 )
  8520   VHF(DA,DAT A) ;Return  data for  a specifie d V Health  Factor en try.
  8521   "RTN","PXP XRM",194,0 )
  8522    N TEMP
  8523   "RTN","PXP XRM",195,0 )
  8524    S TEMP=^A UPNVHF(DA, 0)
  8525   "RTN","PXP XRM",196,0 )
  8526    S DATA("V ISIT")=$P( TEMP,U,3)
  8527   "RTN","PXP XRM",197,0 )
  8528    S (DATA(" LEVEL/SEVE RITY"),DAT A("VALUE") )=$P(TEMP, U,4)
  8529   "RTN","PXP XRM",198,0 )
  8530    S DATA("C OMMENTS")= $G(^AUPNVH F(DA,811))
  8531   "RTN","PXP XRM",199,0 )
  8532    Q
  8533   "RTN","PXP XRM",200,0 )
  8534    ;
  8535   "RTN","PXP XRM",201,0 )
  8536    ;======== ========== ========== ========== ========== ========== =====
  8537   "RTN","PXP XRM",202,0 )
  8538   VIMM(DA,DA TA) ;Retur n data, fo r a specif ied V Immu nization e ntry.
  8539   "RTN","PXP XRM",203,0 )
  8540    N PXCS,PX CSIEN,PXCD IEN,PXCODE ,PXFILE,PX IEN,PXTEMP ,PXVIMM,PX VISIT,PXX
  8541   "RTN","PXP XRM",204,0 )
  8542    ;
  8543   "RTN","PXP XRM",205,0 )
  8544    S PXFILE= 9000010.11
  8545   "RTN","PXP XRM",206,0 )
  8546    ;
  8547   "RTN","PXP XRM",207,0 )
  8548    S PXTEMP= ^AUPNVIMM( DA,0)
  8549   "RTN","PXP XRM",208,0 )
  8550    S PXVIMM= $P(PXTEMP, U)
  8551   "RTN","PXP XRM",209,0 )
  8552    S PXVISIT =$P(PXTEMP ,U,3)
  8553   "RTN","PXP XRM",210,0 )
  8554    S DATA("V ISIT")=PXV ISIT
  8555   "RTN","PXP XRM",211,0 )
  8556    S (DATA(" SERIES"),D ATA("VALUE "))=$P(PXT EMP,U,4)
  8557   "RTN","PXP XRM",212,0 )
  8558    S DATA("R EACTION")= $P(PXTEMP, U,6)
  8559   "RTN","PXP XRM",213,0 )
  8560    S DATA("C ONTRAINDIC ATED")=$P( PXTEMP,U,7 )
  8561   "RTN","PXP XRM",214,0 )
  8562    S DATA("C OMMENTS")= $G(^AUPNVI MM(DA,811) )
  8563   "RTN","PXP XRM",215,0 )
  8564    ;
  8565   "RTN","PXP XRM",216,0 )
  8566    S PXTEMP= $G(^AUPNVS IT(+PXVISI T,0))
  8567   "RTN","PXP XRM",217,0 )
  8568    S DATA("V ISIT DATE  TIME")=$P( PXTEMP,U)
  8569   "RTN","PXP XRM",218,0 )
  8570    S PXX=$P( PXTEMP,U,2 2)
  8571   "RTN","PXP XRM",219,0 )
  8572    S DATA("L OCATION")= PXX_$S(PXX :(U_$P($G( ^SC(+PXX,0 )),U)),1:" ")
  8573   "RTN","PXP XRM",220,0 )
  8574    S PXX=$P( PXTEMP,U,6 )
  8575   "RTN","PXP XRM",221,0 )
  8576    S DATA("F ACILITY")= PXX_$S(PXX :(U_$$NS^X UAF4(PXX)) ,1:"")
  8577   "RTN","PXP XRM",222,0 )
  8578    ;
  8579   "RTN","PXP XRM",223,0 )
  8580    S PXTEMP= $G(^AUPNVI MM(DA,12))
  8581   "RTN","PXP XRM",224,0 )
  8582    S DATA("E VENT DATE  TIME")=$P( PXTEMP,U)
  8583   "RTN","PXP XRM",225,0 )
  8584    S PXX=$P( PXTEMP,U,2 )
  8585   "RTN","PXP XRM",226,0 )
  8586    S DATA("O RDERING PR OVIDER")=P XX_$S(PXX: (U_$P($G(^ VA(200,+PX X,0)),U)), 1:"")
  8587   "RTN","PXP XRM",227,0 )
  8588    S PXX=$P( PXTEMP,U,4 )
  8589   "RTN","PXP XRM",228,0 )
  8590    S DATA("E NCOUNTER P ROVIDER")= PXX_$S(PXX :(U_$P($G( ^VA(200,+P XX,0)),U)) ,1:"")
  8591   "RTN","PXP XRM",229,0 )
  8592    S DATA("D ATE RECORD ED")=$P(PX TEMP,U,5)
  8593   "RTN","PXP XRM",230,0 )
  8594    S PXX=$P( PXTEMP,U,6 )
  8595   "RTN","PXP XRM",231,0 )
  8596    S DATA("D OCUMENTER" )=PXX_$S(P XX:(U_$P($ G(^VA(200, +PXX,0)),U )),1:"")
  8597   "RTN","PXP XRM",232,0 )
  8598    S PXX=$P( PXTEMP,U,7 )
  8599   "RTN","PXP XRM",233,0 )
  8600    S DATA("L OT NUMBER" )=PXX_$S(P XX:(U_$P($ G(^AUTTIML (+PXX,0)), U)),1:"")
  8601   "RTN","PXP XRM",234,0 )
  8602    S DATA("W ARNING ACK ")=$P(PXTE MP,U,20)
  8603   "RTN","PXP XRM",235,0 )
  8604    ;
  8605   "RTN","PXP XRM",236,0 )
  8606    S PXTEMP= $G(^AUTTIM L(+$P(PXTE MP,U,7),0) )
  8607   "RTN","PXP XRM",237,0 )
  8608    S PXX=$P( PXTEMP,U,2 )
  8609   "RTN","PXP XRM",238,0 )
  8610    S DATA("M ANUFACTURE R")=PXX_$S (PXX:(U_$P ($G(^AUTTI MAN(+PXX,0 )),U)),1:" ")
  8611   "RTN","PXP XRM",239,0 )
  8612    S DATA("E XPIRATION  DATE")=$P( PXTEMP,U,9 )
  8613   "RTN","PXP XRM",240,0 )
  8614    ;
  8615   "RTN","PXP XRM",241,0 )
  8616    S PXTEMP= $G(^AUPNVI MM(DA,13))
  8617   "RTN","PXP XRM",242,0 )
  8618    S PXX=$P( PXTEMP,U)
  8619   "RTN","PXP XRM",243,0 )
  8620    S DATA("I NFO SOURCE ")=PXX_$S( PXX:(U_$P( $G(^PXV(92 0.1,+PXX,0 )),U,2)_U_ $P($G(^PXV (920.1,+PX X,0)),U)), 1:"")
  8621   "RTN","PXP XRM",244,0 )
  8622    S PXX=$P( PXTEMP,U,2 )
  8623   "RTN","PXP XRM",245,0 )
  8624    S DATA("A DMIN ROUTE ")=PXX_$S( PXX:(U_$P( $G(^PXV(92 0.2,+PXX,0 )),U,2)_U_ $P($G(^PXV (920.2,+PX X,0)),U)), 1:"")
  8625   "RTN","PXP XRM",246,0 )
  8626    S PXX=$P( PXTEMP,U,3 )
  8627   "RTN","PXP XRM",247,0 )
  8628    S DATA("A DMIN SITE" )=PXX_$S(P XX:(U_$P($ G(^PXV(920 .3,+PXX,0) ),U,2)_U_$ P($G(^PXV( 920.3,+PXX ,0)),U)),1 :"")
  8629   "RTN","PXP XRM",248,0 )
  8630    S DATA("D OSE")=$$EX TERNAL^DIL FD(9000010 .11,1312," ",$P(PXTEM P,U,12))
  8631   "RTN","PXP XRM",249,0 )
  8632    S DATA("D OSE UNITS" )=$$EXTERN AL^DILFD(9 000010.11, 1313,"",$P (PXTEMP,U, 13))
  8633   "RTN","PXP XRM",250,0 )
  8634    ;
  8635   "RTN","PXP XRM",251,0 )
  8636    S DATA("O VERRIDE RE ASON")=$G( ^AUPNVIMM( DA,16))
  8637   "RTN","PXP XRM",252,0 )
  8638    ;
  8639   "RTN","PXP XRM",253,0 )
  8640    S PXTEMP= $G(^AUTTIM M(+PXVIMM, 0))
  8641   "RTN","PXP XRM",254,0 )
  8642    S DATA("I MMUNIZATIO N")=PXVIMM _$S(PXVIMM :(U_$P(PXT EMP,U)),1: "")
  8643   "RTN","PXP XRM",255,0 )
  8644    S DATA("C VX")=$P(PX TEMP,U,3)
  8645   "RTN","PXP XRM",256,0 )
  8646    ;
  8647   "RTN","PXP XRM",257,0 )
  8648    S PXX=$P( $G(^AUPNVI MM(DA,812) ),U,3)
  8649   "RTN","PXP XRM",258,0 )
  8650    S DATA("D ATA SOURCE ")=PXX_$S( PXX:(U_$P( $G(^PX(839 .7,PXX,0)) ,U,1)),1:" ")
  8651   "RTN","PXP XRM",259,0 )
  8652    ;
  8653   "RTN","PXP XRM",260,0 )
  8654    S PXIEN=0
  8655   "RTN","PXP XRM",261,0 )
  8656    F  S PXIE N=$O(^AUTT IMM(PXVIMM ,7,PXIEN))  Q:'PXIEN   D
  8657   "RTN","PXP XRM",262,0 )
  8658    . S PXTEM P=$P($G(^A UTTIMM(PXV IMM,7,PXIE N,0)),U,1)
  8659   "RTN","PXP XRM",263,0 )
  8660    . I PXTEM P="" Q
  8661   "RTN","PXP XRM",264,0 )
  8662    . S DATA( "VACCINE G ROUP",PXIE N,0)=PXTEM P
  8663   "RTN","PXP XRM",265,0 )
  8664    ;
  8665   "RTN","PXP XRM",266,0 )
  8666    ;S DATA(" CODES",Cod ing System  Name)=Cod e 1 ^ Code  2 ^ ... C ode x
  8667   "RTN","PXP XRM",267,0 )
  8668    S PXCSIEN =0
  8669   "RTN","PXP XRM",268,0 )
  8670    F  S PXCS IEN=$O(^AU TTIMM(PXVI MM,3,PXCSI EN)) Q:'PX CSIEN  D
  8671   "RTN","PXP XRM",269,0 )
  8672    . S PXCS= $P($G(^AUT TIMM(PXVIM M,3,PXCSIE N,0)),U,1)
  8673   "RTN","PXP XRM",270,0 )
  8674    . I PXCS= "" Q
  8675   "RTN","PXP XRM",271,0 )
  8676    . S PXCDI EN=0
  8677   "RTN","PXP XRM",272,0 )
  8678    . F  S PX CDIEN=$O(^ AUTTIMM(PX VIMM,3,PXC SIEN,1,PXC DIEN)) Q:' PXCDIEN  D
  8679   "RTN","PXP XRM",273,0 )
  8680    . . S PXC ODE=$P($G( ^AUTTIMM(P XVIMM,3,PX CSIEN,1,PX CDIEN,0)), U,1)
  8681   "RTN","PXP XRM",274,0 )
  8682    . . I PXC ODE="" Q
  8683   "RTN","PXP XRM",275,0 )
  8684    . . I '$D (DATA("COD ES",PXCS))  S DATA("C ODES",PXCS )=PXCODE Q
  8685   "RTN","PXP XRM",276,0 )
  8686    . . S DAT A("CODES", PXCS)=DATA ("CODES",P XCS)_U_PXC ODE
  8687   "RTN","PXP XRM",277,0 )
  8688    ;
  8689   "RTN","PXP XRM",278,0 )
  8690    ;DATA("VI S OFFERED" ,n,0)=IEN  ^ Date Off ered ^ Nam e ^ Editio n Date ^ L anguage
  8691   "RTN","PXP XRM",279,0 )
  8692    S PXIEN=0
  8693   "RTN","PXP XRM",280,0 )
  8694    F  S PXIE N=$O(^AUPN VIMM(DA,2, PXIEN)) Q: 'PXIEN  D
  8695   "RTN","PXP XRM",281,0 )
  8696    . S PXTEM P=$G(^AUPN VIMM(DA,2, PXIEN,0))
  8697   "RTN","PXP XRM",282,0 )
  8698    . I 'PXTE MP Q
  8699   "RTN","PXP XRM",283,0 )
  8700    . S DATA( "VIS OFFER ED",PXIEN, 0)=$P(PXTE MP,U,1,2)
  8701   "RTN","PXP XRM",284,0 )
  8702    . S PXTEM P=$G(^AUTT IVIS(+PXTE MP,0))
  8703   "RTN","PXP XRM",285,0 )
  8704    . S DATA( "VIS OFFER ED",PXIEN, 0)=DATA("V IS OFFERED ",PXIEN,0) _U_$P(PXTE MP,U)_U_$P (PXTEMP,U, 2)
  8705   "RTN","PXP XRM",286,0 )
  8706    . S PXX=$ P(PXTEMP,U ,4)
  8707   "RTN","PXP XRM",287,0 )
  8708    . I PXX S  DATA("VIS  OFFERED", PXIEN,0)=D ATA("VIS O FFERED",PX IEN,0)_U_$ $GET1^DIQ( .85,PXX_", ","NAME")   ;ICR 6062
  8709   "RTN","PXP XRM",288,0 )
  8710    ;
  8711   "RTN","PXP XRM",289,0 )
  8712    ;DATA("RE MARKS",n,0 )=Free tex t
  8713   "RTN","PXP XRM",290,0 )
  8714    M DATA("R EMARKS")=^ AUPNVIMM(D A,11)
  8715   "RTN","PXP XRM",291,0 )
  8716    K DATA("R EMARKS",0)
  8717   "RTN","PXP XRM",292,0 )
  8718    ;
  8719   "RTN","PXP XRM",293,0 )
  8720    Q
  8721   "RTN","PXP XRM",294,0 )
  8722    ;
  8723   "RTN","PXP XRM",295,0 )
  8724    ;======== ========== ========== ========== ========== ========== =====
  8725   "RTN","PXP XRM",296,0 )
  8726   VPEDU(DA,D ATA) ;Retu rn data, f or a speci fied V Pat ient ED en try.
  8727   "RTN","PXP XRM",297,0 )
  8728    N TEMP
  8729   "RTN","PXP XRM",298,0 )
  8730    S TEMP=^A UPNVPED(DA ,0)
  8731   "RTN","PXP XRM",299,0 )
  8732    S DATA("V ISIT")=$P( TEMP,U,3)
  8733   "RTN","PXP XRM",300,0 )
  8734    S (DATA(" LEVEL OF U NDERSTANDI NG"),DATA( "VALUE"))= $P(TEMP,U, 6)
  8735   "RTN","PXP XRM",301,0 )
  8736    S DATA("C OMMENTS")= $G(^AUPNVP ED(DA,811) )
  8737   "RTN","PXP XRM",302,0 )
  8738    Q
  8739   "RTN","PXP XRM",303,0 )
  8740    ;
  8741   "RTN","PXP XRM",304,0 )
  8742    ;======== ========== ========== ========== ========== ========== =====
  8743   "RTN","PXP XRM",305,0 )
  8744   VPOV(DA,DA TA) ;Retur n data for  a specifi ed V POV e ntry.
  8745   "RTN","PXP XRM",306,0 )
  8746    N TEMP
  8747   "RTN","PXP XRM",307,0 )
  8748    S TEMP=^A UPNVPOV(DA ,0)
  8749   "RTN","PXP XRM",308,0 )
  8750    S DATA("V ISIT")=$P( TEMP,U,3)
  8751   "RTN","PXP XRM",309,0 )
  8752    S DATA("P ROVIDER NA RRATIVE")= $P(TEMP,U, 4)
  8753   "RTN","PXP XRM",310,0 )
  8754    S DATA("M ODIFIER")= $P(TEMP,U, 6)
  8755   "RTN","PXP XRM",311,0 )
  8756    S DATA("P RIMARY/SEC ONDARY")=$ P(TEMP,U,1 2)
  8757   "RTN","PXP XRM",312,0 )
  8758    S DATA("D ATE OF INJ URY")=$P(T EMP,U,13)
  8759   "RTN","PXP XRM",313,0 )
  8760    S DATA("C LINICAL TE RM")=$P(TE MP,U,15)
  8761   "RTN","PXP XRM",314,0 )
  8762    S DATA("P ROBLEM LIS T ENTRY")= $P(TEMP,U, 16)
  8763   "RTN","PXP XRM",315,0 )
  8764    S DATA("C OMMENTS")= $G(^AUPNVP OV(DA,811) )
  8765   "RTN","PXP XRM",316,0 )
  8766    Q
  8767   "RTN","PXP XRM",317,0 )
  8768    ;
  8769   "RTN","PXP XRM",318,0 )
  8770    ;======== ========== ========== ========== ========== ========== =====
  8771   "RTN","PXP XRM",319,0 )
  8772   VSKIN(DA,D ATA) ;Retu rn data fo r a specif ied V Skin  Test entr y.
  8773   "RTN","PXP XRM",320,0 )
  8774    N TEMP
  8775   "RTN","PXP XRM",321,0 )
  8776    S TEMP=^A UPNVSK(DA, 0)
  8777   "RTN","PXP XRM",322,0 )
  8778    S DATA("V ISIT")=$P( TEMP,U,3)
  8779   "RTN","PXP XRM",323,0 )
  8780    S (DATA(" RESULTS"), DATA("VALU E"))=$P(TE MP,U,4)
  8781   "RTN","PXP XRM",324,0 )
  8782    S DATA("R EADING")=$ P(TEMP,U,5 )
  8783   "RTN","PXP XRM",325,0 )
  8784    S DATA("D ATE READ") =$P(TEMP,U ,6)
  8785   "RTN","PXP XRM",326,0 )
  8786    S DATA("C OMMENTS")= $G(^AUPNVS K(DA,811))
  8787   "RTN","PXP XRM",327,0 )
  8788    Q
  8789   "RTN","PXP XRM",328,0 )
  8790    ;
  8791   "RTN","PXP XRM",329,0 )
  8792    ;======== ========== ========== ========== ========== ========== =====
  8793   "RTN","PXP XRM",330,0 )
  8794   VXAM(DA,DA TA) ;Retur n data, fo r a specif ied V Exam  entry.
  8795   "RTN","PXP XRM",331,0 )
  8796    N TEMP
  8797   "RTN","PXP XRM",332,0 )
  8798    S TEMP=^A UPNVXAM(DA ,0)
  8799   "RTN","PXP XRM",333,0 )
  8800    S DATA("V ISIT")=$P( TEMP,U,3)
  8801   "RTN","PXP XRM",334,0 )
  8802    S (DATA(" RESULT"),D ATA("VALUE "))=$P(TEM P,U,4)
  8803   "RTN","PXP XRM",335,0 )
  8804    S DATA("C OMMENTS")= $G(^AUPNVX AM(DA,811) )
  8805   "RTN","PXP XRM",336,0 )
  8806    Q
  8807   "RTN","PXP XRM",337,0 )
  8808    ;
  8809   "RTN","PXP XRM",338,0 )
  8810    ;======== ========== ========== ========== ========== ========== =====
  8811   "RTN","PXP XRM",339,0 )
  8812   VICR(DA,DA TA) ;Retur n data, fo r a specif ied V Imm  Contra/Ref usal Event s entry.
  8813   "RTN","PXP XRM",340,0 )
  8814    N PXFILE, PXX,TEMP
  8815   "RTN","PXP XRM",341,0 )
  8816    S TEMP=^A UPNVICR(DA ,0)
  8817   "RTN","PXP XRM",342,0 )
  8818    S DATA("V ISIT")=$P( TEMP,U,3)
  8819   "RTN","PXP XRM",343,0 )
  8820    S PXX=$P( TEMP,U,1), PXFILE=+$P (PXX,"(",2 )
  8821   "RTN","PXP XRM",344,0 )
  8822    S DATA("C ONTRA/REFU SAL")=PXX_ U_$P($G(^P XV(PXFILE, +PXX,0)),U ,1)
  8823   "RTN","PXP XRM",345,0 )
  8824    S PXX=$P( TEMP,U,4)
  8825   "RTN","PXP XRM",346,0 )
  8826    S DATA("I MMUN")=PXX _U_$P($G(^ AUTTIMM(+P XX,0)),U,1 )
  8827   "RTN","PXP XRM",347,0 )
  8828    S DATA("W ARN UNTIL  DATE")=$P( TEMP,U,5)
  8829   "RTN","PXP XRM",348,0 )
  8830    S DATA("D /T RECORDE D")=$P(TEM P,U,6)
  8831   "RTN","PXP XRM",349,0 )
  8832    ;
  8833   "RTN","PXP XRM",350,0 )
  8834    S TEMP=$G (^AUPNVICR (DA,12))
  8835   "RTN","PXP XRM",351,0 )
  8836    S DATA("E VENT D/T") =$P(TEMP,U ,1)
  8837   "RTN","PXP XRM",352,0 )
  8838    S PXX=$P( TEMP,U,4)
  8839   "RTN","PXP XRM",353,0 )
  8840    S DATA("E NC PROVIDE R")=PXX_U_ $P($G(^VA( 200,+PXX,0 )),U,1)
  8841   "RTN","PXP XRM",354,0 )
  8842    S DATA("C OMMENTS")= $G(^AUPNVI CR(DA,811) )
  8843   "RTN","PXP XRM",355,0 )
  8844    Q
  8845   "RTN","PXP XRM",356,0 )
  8846    ;
  8847   "RTN","PXP XRMI1")
  8848   0^6^B10422 5670^B5515 9505
  8849   "RTN","PXP XRMI1",1,0 )
  8850   PXPXRMI1 ;  SLC/PKR,S CK - Build  indexes f or the V f iles. ;03/ 14/16  09: 49
  8851   "RTN","PXP XRMI1",2,0 )
  8852    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**119, 194,210,21 5**;Aug 12 , 1996;Bui ld 10
  8853   "RTN","PXP XRMI1",3,0 )
  8854    ;DBIA 411 3 supports  PXRMSXRM  entry poin ts.
  8855   "RTN","PXP XRMI1",4,0 )
  8856    ;DBIA 411 4 supports  setting a nd killing  ^PXRMINDX
  8857   "RTN","PXP XRMI1",5,0 )
  8858    ;======== ========== ========== ========== ========== ========== =====
  8859   "RTN","PXP XRMI1",6,0 )
  8860   VCPT ;Buil d the inde xes for V  CPT.
  8861   "RTN","PXP XRMI1",7,0 )
  8862    N CPT,DAS ,DATE,DFN, DIFF,DONE, END,ENTRIE S,ETEXT,GL OBAL,IND,N E,NERROR,P P
  8863   "RTN","PXP XRMI1",8,0 )
  8864    N START,T EMP,TENP,T EXT,VISIT
  8865   "RTN","PXP XRMI1",9,0 )
  8866    ;Don't le ave any ol d stuff ar ound.
  8867   "RTN","PXP XRMI1",10, 0)
  8868    K ^PXRMIN DX(9000010 .18)
  8869   "RTN","PXP XRMI1",11, 0)
  8870    S GLOBAL= $$GET1^DID (9000010.1 8,"","","G LOBAL NAME ")
  8871   "RTN","PXP XRMI1",12, 0)
  8872    S ENTRIES =$P(^AUPNV CPT(0),U,4 )
  8873   "RTN","PXP XRMI1",13, 0)
  8874    S TENP=EN TRIES/10
  8875   "RTN","PXP XRMI1",14, 0)
  8876    S TENP=+$ P(TENP,"." ,1)
  8877   "RTN","PXP XRMI1",15, 0)
  8878    I TENP<1  S TENP=1
  8879   "RTN","PXP XRMI1",16, 0)
  8880    D BMES^XP DUTL("Buil ding index es for V C PT")
  8881   "RTN","PXP XRMI1",17, 0)
  8882    S TEXT="T here are " _ENTRIES_"  entries t o process. "
  8883   "RTN","PXP XRMI1",18, 0)
  8884    D MES^XPD UTL(TEXT)
  8885   "RTN","PXP XRMI1",19, 0)
  8886    S START=$ H
  8887   "RTN","PXP XRMI1",20, 0)
  8888    S (DAS,DO NE,IND,NE, NERROR)=0
  8889   "RTN","PXP XRMI1",21, 0)
  8890    F  S DAS= $O(^AUPNVC PT(DAS)) Q :DONE  D
  8891   "RTN","PXP XRMI1",22, 0)
  8892    . I +DAS= 0 S DONE=1  Q
  8893   "RTN","PXP XRMI1",23, 0)
  8894    . I +DAS' =DAS D  Q
  8895   "RTN","PXP XRMI1",24, 0)
  8896    .. S DONE =1
  8897   "RTN","PXP XRMI1",25, 0)
  8898    .. S ETEX T="Bad ien : "_DAS_",  cannot co ntinue."
  8899   "RTN","PXP XRMI1",26, 0)
  8900    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  8901   "RTN","PXP XRMI1",27, 0)
  8902    . S IND=I ND+1
  8903   "RTN","PXP XRMI1",28, 0)
  8904    . I IND#T ENP=0 D
  8905   "RTN","PXP XRMI1",29, 0)
  8906    .. S TEXT ="Processi ng entry " _IND
  8907   "RTN","PXP XRMI1",30, 0)
  8908    .. D MES^ XPDUTL(TEX T)
  8909   "RTN","PXP XRMI1",31, 0)
  8910    . I IND#1 0000=0 W " ."
  8911   "RTN","PXP XRMI1",32, 0)
  8912    . S TEMP= ^AUPNVCPT( DAS,0)
  8913   "RTN","PXP XRMI1",33, 0)
  8914    . S CPT=$ P(TEMP,U,1 )
  8915   "RTN","PXP XRMI1",34, 0)
  8916    . I CPT=" " D  Q
  8917   "RTN","PXP XRMI1",35, 0)
  8918    .. S ETEX T=DAS_" mi ssing CPT"
  8919   "RTN","PXP XRMI1",36, 0)
  8920    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  8921   "RTN","PXP XRMI1",37, 0)
  8922    . ;I '$D( ^ICPT(CPT) ) D  Q
  8923   "RTN","PXP XRMI1",38, 0)
  8924    . I $$CPT ^ICPTCOD(C PT)<0 D  Q
  8925   "RTN","PXP XRMI1",39, 0)
  8926    .. S ETEX T=DAS_" in valid CPT"
  8927   "RTN","PXP XRMI1",40, 0)
  8928    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  8929   "RTN","PXP XRMI1",41, 0)
  8930    . S DFN=$ P(TEMP,U,2 )
  8931   "RTN","PXP XRMI1",42, 0)
  8932    . I DFN=" " D  Q
  8933   "RTN","PXP XRMI1",43, 0)
  8934    .. S ETEX T=DAS_" mi ssing DFN"
  8935   "RTN","PXP XRMI1",44, 0)
  8936    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  8937   "RTN","PXP XRMI1",45, 0)
  8938    . S VISIT =$P(TEMP,U ,3)
  8939   "RTN","PXP XRMI1",46, 0)
  8940    . I VISIT ="" D  Q
  8941   "RTN","PXP XRMI1",47, 0)
  8942    .. S ETEX T=DAS_" mi ssing visi t"
  8943   "RTN","PXP XRMI1",48, 0)
  8944    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  8945   "RTN","PXP XRMI1",49, 0)
  8946    . I '$D(^ AUPNVSIT(V ISIT)) D   Q
  8947   "RTN","PXP XRMI1",50, 0)
  8948    .. S ETEX T=DAS_" in valid visi t"
  8949   "RTN","PXP XRMI1",51, 0)
  8950    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  8951   "RTN","PXP XRMI1",52, 0)
  8952    . S DATE= $P(^AUPNVS IT(VISIT,0 ),U,1)
  8953   "RTN","PXP XRMI1",53, 0)
  8954    . I DATE= "" D  Q
  8955   "RTN","PXP XRMI1",54, 0)
  8956    .. S ETEX T=DAS_" mi ssing visi t date"
  8957   "RTN","PXP XRMI1",55, 0)
  8958    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  8959   "RTN","PXP XRMI1",56, 0)
  8960    . S PP=$P (TEMP,U,7)
  8961   "RTN","PXP XRMI1",57, 0)
  8962    . I PP=""  S PP="U"
  8963   "RTN","PXP XRMI1",58, 0)
  8964    . S NE=NE +1
  8965   "RTN","PXP XRMI1",59, 0)
  8966    . S ^PXRM INDX(90000 10.18,"IPP ",CPT,PP,D FN,DATE,DA S)=""
  8967   "RTN","PXP XRMI1",60, 0)
  8968    . S ^PXRM INDX(90000 10.18,"PPI ",DFN,PP,C PT,DATE,DA S)=""
  8969   "RTN","PXP XRMI1",61, 0)
  8970    S END=$H
  8971   "RTN","PXP XRMI1",62, 0)
  8972    S TEXT=NE _" V CPT r esults ind exed."
  8973   "RTN","PXP XRMI1",63, 0)
  8974    D MES^XPD UTL(TEXT)
  8975   "RTN","PXP XRMI1",64, 0)
  8976    D DETIME^ PXRMSXRM(S TART,END)
  8977   "RTN","PXP XRMI1",65, 0)
  8978    ;If there  were erro rs send a  message.
  8979   "RTN","PXP XRMI1",66, 0)
  8980    I NERROR> 0 D ERRMSG ^PXRMSXRM( NERROR,GLO BAL)
  8981   "RTN","PXP XRMI1",67, 0)
  8982    ;Send a M ailMan mes sage with  the result s.
  8983   "RTN","PXP XRMI1",68, 0)
  8984    D COMMSG^ PXRMSXRM(G LOBAL,STAR T,END,NE,N ERROR)
  8985   "RTN","PXP XRMI1",69, 0)
  8986    S ^PXRMIN DX(9000010 .18,"GLOBA L NAME")=G LOBAL
  8987   "RTN","PXP XRMI1",70, 0)
  8988    S ^PXRMIN DX(9000010 .18,"BUILT  BY")=DUZ
  8989   "RTN","PXP XRMI1",71, 0)
  8990    S ^PXRMIN DX(9000010 .18,"DATE  BUILT")=$$ NOW^XLFDT
  8991   "RTN","PXP XRMI1",72, 0)
  8992    Q
  8993   "RTN","PXP XRMI1",73, 0)
  8994    ;
  8995   "RTN","PXP XRMI1",74, 0)
  8996    ;======== ========== ========== ========== ========== ========== =====
  8997   "RTN","PXP XRMI1",75, 0)
  8998   VHF ;Build  the index es for V H EALTH FACT ORS.
  8999   "RTN","PXP XRMI1",76, 0)
  9000    N CAT,DAS ,DATE,DFN, DIFF,DONE, END,ENTRIE S,ETEXT,GL OBAL,HF,IN D,NE,NERRO R
  9001   "RTN","PXP XRMI1",77, 0)
  9002    N START,T EMP,TENP,T EXT,VISIT
  9003   "RTN","PXP XRMI1",78, 0)
  9004    ;Don't le ave any ol d stuff ar ound.
  9005   "RTN","PXP XRMI1",79, 0)
  9006    K ^PXRMIN DX(9000010 .23)
  9007   "RTN","PXP XRMI1",80, 0)
  9008    S GLOBAL= $$GET1^DID (9000010.2 3,"","","G LOBAL NAME ")
  9009   "RTN","PXP XRMI1",81, 0)
  9010    S ENTRIES =$P(^AUPNV HF(0),U,4)
  9011   "RTN","PXP XRMI1",82, 0)
  9012    S TENP=EN TRIES/10
  9013   "RTN","PXP XRMI1",83, 0)
  9014    S TENP=+$ P(TENP,"." ,1)
  9015   "RTN","PXP XRMI1",84, 0)
  9016    I TENP<1  S TENP=1
  9017   "RTN","PXP XRMI1",85, 0)
  9018    D BMES^XP DUTL("Buil ding index es for V H EALTH FACT ORS")
  9019   "RTN","PXP XRMI1",86, 0)
  9020    S TEXT="T here are " _ENTRIES_"  entries t o process. "
  9021   "RTN","PXP XRMI1",87, 0)
  9022    D MES^XPD UTL(TEXT)
  9023   "RTN","PXP XRMI1",88, 0)
  9024    S START=$ H
  9025   "RTN","PXP XRMI1",89, 0)
  9026    S (DAS,DO NE,IND,NE, NERROR)=0
  9027   "RTN","PXP XRMI1",90, 0)
  9028    F  S DAS= $O(^AUPNVH F(DAS)) Q: DONE  D
  9029   "RTN","PXP XRMI1",91, 0)
  9030    . I +DAS= 0 S DONE=1  Q
  9031   "RTN","PXP XRMI1",92, 0)
  9032    . I +DAS' =DAS D  Q
  9033   "RTN","PXP XRMI1",93, 0)
  9034    .. S DONE =1
  9035   "RTN","PXP XRMI1",94, 0)
  9036    .. S ETEX T="Bad ien : "_DAS_",  cannot co ntinue."
  9037   "RTN","PXP XRMI1",95, 0)
  9038    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9039   "RTN","PXP XRMI1",96, 0)
  9040    . S IND=I ND+1
  9041   "RTN","PXP XRMI1",97, 0)
  9042    . I IND#T ENP=0 D
  9043   "RTN","PXP XRMI1",98, 0)
  9044    .. S TEXT ="Processi ng entry " _IND
  9045   "RTN","PXP XRMI1",99, 0)
  9046    .. D MES^ XPDUTL(TEX T)
  9047   "RTN","PXP XRMI1",100 ,0)
  9048    . I IND#1 0000=0 W " ."
  9049   "RTN","PXP XRMI1",101 ,0)
  9050    . S TEMP= ^AUPNVHF(D AS,0)
  9051   "RTN","PXP XRMI1",102 ,0)
  9052    . S HF=$P (TEMP,U,1)
  9053   "RTN","PXP XRMI1",103 ,0)
  9054    . I HF=""  D  Q
  9055   "RTN","PXP XRMI1",104 ,0)
  9056    .. S ETEX T=DAS_" mi ssing HF"
  9057   "RTN","PXP XRMI1",105 ,0)
  9058    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9059   "RTN","PXP XRMI1",106 ,0)
  9060    . I '$D(^ AUTTHF(HF) ) D  Q
  9061   "RTN","PXP XRMI1",107 ,0)
  9062    .. S ETEX T=DAS_" in valid HF"
  9063   "RTN","PXP XRMI1",108 ,0)
  9064    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9065   "RTN","PXP XRMI1",109 ,0)
  9066    . S DFN=$ P(TEMP,U,2 )
  9067   "RTN","PXP XRMI1",110 ,0)
  9068    . I DFN=" " D  Q
  9069   "RTN","PXP XRMI1",111 ,0)
  9070    .. S ETEX T=DAS_" mi ssing DFN"
  9071   "RTN","PXP XRMI1",112 ,0)
  9072    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9073   "RTN","PXP XRMI1",113 ,0)
  9074    . S CAT=$ P(^AUTTHF( HF,0),U,3)
  9075   "RTN","PXP XRMI1",114 ,0)
  9076    . I CAT=" " D  Q
  9077   "RTN","PXP XRMI1",115 ,0)
  9078    .. S ETEX T=DAS_" HF  "_HF_" mi ssing cate gory"
  9079   "RTN","PXP XRMI1",116 ,0)
  9080    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9081   "RTN","PXP XRMI1",117 ,0)
  9082    . I HF=CA T D  Q
  9083   "RTN","PXP XRMI1",118 ,0)
  9084    .. S ETEX T=DAS_" HF  "_HF_" is  a categor y"
  9085   "RTN","PXP XRMI1",119 ,0)
  9086    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9087   "RTN","PXP XRMI1",120 ,0)
  9088    . S VISIT =$P(TEMP,U ,3)
  9089   "RTN","PXP XRMI1",121 ,0)
  9090    . I VISIT ="" D  Q
  9091   "RTN","PXP XRMI1",122 ,0)
  9092    .. S ETEX T=DAS_" mi ssing visi t"
  9093   "RTN","PXP XRMI1",123 ,0)
  9094    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9095   "RTN","PXP XRMI1",124 ,0)
  9096    . I '$D(^ AUPNVSIT(V ISIT)) D   Q
  9097   "RTN","PXP XRMI1",125 ,0)
  9098    .. S ETEX T=DAS_" in valid visi t"
  9099   "RTN","PXP XRMI1",126 ,0)
  9100    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9101   "RTN","PXP XRMI1",127 ,0)
  9102    . S DATE= $P(^AUPNVS IT(VISIT,0 ),U,1)
  9103   "RTN","PXP XRMI1",128 ,0)
  9104    . I DATE= "" D  Q
  9105   "RTN","PXP XRMI1",129 ,0)
  9106    .. S ETEX T=DAS_" mi ssing visi t date"
  9107   "RTN","PXP XRMI1",130 ,0)
  9108    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9109   "RTN","PXP XRMI1",131 ,0)
  9110    . S NE=NE +1
  9111   "RTN","PXP XRMI1",132 ,0)
  9112    . S ^PXRM INDX(90000 10.23,"IP" ,HF,DFN,DA TE,DAS)=""
  9113   "RTN","PXP XRMI1",133 ,0)
  9114    . S ^PXRM INDX(90000 10.23,"PI" ,DFN,HF,DA TE,DAS)=""
  9115   "RTN","PXP XRMI1",134 ,0)
  9116    S END=$H
  9117   "RTN","PXP XRMI1",135 ,0)
  9118    S TEXT=NE _" V HEALT H FACTOR r esults ind exed."
  9119   "RTN","PXP XRMI1",136 ,0)
  9120    D MES^XPD UTL(TEXT)
  9121   "RTN","PXP XRMI1",137 ,0)
  9122    D DETIME^ PXRMSXRM(S TART,END)
  9123   "RTN","PXP XRMI1",138 ,0)
  9124    ;If there  were erro rs send a  message.
  9125   "RTN","PXP XRMI1",139 ,0)
  9126    I NERROR> 0 D ERRMSG ^PXRMSXRM( NERROR,GLO BAL)
  9127   "RTN","PXP XRMI1",140 ,0)
  9128    ;Send a M ailMan mes sage with  the result s.
  9129   "RTN","PXP XRMI1",141 ,0)
  9130    D COMMSG^ PXRMSXRM(G LOBAL,STAR T,END,NE,N ERROR)
  9131   "RTN","PXP XRMI1",142 ,0)
  9132    S ^PXRMIN DX(9000010 .23,"GLOBA L NAME")=G LOBAL
  9133   "RTN","PXP XRMI1",143 ,0)
  9134    S ^PXRMIN DX(9000010 .23,"BUILT  BY")=DUZ
  9135   "RTN","PXP XRMI1",144 ,0)
  9136    S ^PXRMIN DX(9000010 .23,"DATE  BUILT")=$$ NOW^XLFDT
  9137   "RTN","PXP XRMI1",145 ,0)
  9138    Q
  9139   "RTN","PXP XRMI1",146 ,0)
  9140    ;
  9141   "RTN","PXP XRMI1",147 ,0)
  9142    ;======== ========== ========== ========== ========== ========== =====
  9143   "RTN","PXP XRMI1",148 ,0)
  9144   VIMM ;Buil d the inde xes for V  IMMUNIZATI ON.
  9145   "RTN","PXP XRMI1",149 ,0)
  9146    N CVX,DAS ,DATE,DFN, DIFF,DONE, END,ENTRIE S,ETEXT,EV ENTDT,GLOB AL,IMM
  9147   "RTN","PXP XRMI1",150 ,0)
  9148    N IND,NE, NERROR,STA RT,TEMP,TE NP,TEXT,VI SIT
  9149   "RTN","PXP XRMI1",151 ,0)
  9150    ;Don't le ave any ol d stuff ar ound.
  9151   "RTN","PXP XRMI1",152 ,0)
  9152    K ^PXRMIN DX(9000010 .11)
  9153   "RTN","PXP XRMI1",153 ,0)
  9154    S GLOBAL= $$GET1^DID (9000010.1 1,"","","G LOBAL NAME ")
  9155   "RTN","PXP XRMI1",154 ,0)
  9156    S ENTRIES =$P(^AUPNV IMM(0),U,4 )
  9157   "RTN","PXP XRMI1",155 ,0)
  9158    S TENP=EN TRIES/10
  9159   "RTN","PXP XRMI1",156 ,0)
  9160    S TENP=+$ P(TENP,"." ,1)
  9161   "RTN","PXP XRMI1",157 ,0)
  9162    I TENP<1  S TENP=1
  9163   "RTN","PXP XRMI1",158 ,0)
  9164    D BMES^XP DUTL("Buil ding index es for V I MMUNIZATIO N")
  9165   "RTN","PXP XRMI1",159 ,0)
  9166    S TEXT="T here are " _ENTRIES_"  entries t o process. "
  9167   "RTN","PXP XRMI1",160 ,0)
  9168    D MES^XPD UTL(TEXT)
  9169   "RTN","PXP XRMI1",161 ,0)
  9170    S START=$ H
  9171   "RTN","PXP XRMI1",162 ,0)
  9172    S (DAS,DO NE,IND,NE, NERROR)=0
  9173   "RTN","PXP XRMI1",163 ,0)
  9174    F  S DAS= $O(^AUPNVI MM(DAS)) Q :DONE  D
  9175   "RTN","PXP XRMI1",164 ,0)
  9176    . I +DAS= 0 S DONE=1  Q
  9177   "RTN","PXP XRMI1",165 ,0)
  9178    . I +DAS' =DAS D  Q
  9179   "RTN","PXP XRMI1",166 ,0)
  9180    .. S DONE =1
  9181   "RTN","PXP XRMI1",167 ,0)
  9182    .. S ETEX T="Bad ien : "_DAS_",  cannot co ntinue."
  9183   "RTN","PXP XRMI1",168 ,0)
  9184    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9185   "RTN","PXP XRMI1",169 ,0)
  9186    . S IND=I ND+1
  9187   "RTN","PXP XRMI1",170 ,0)
  9188    . I IND#T ENP=0 D
  9189   "RTN","PXP XRMI1",171 ,0)
  9190    .. S TEXT ="Processi ng entry " _IND
  9191   "RTN","PXP XRMI1",172 ,0)
  9192    .. D MES^ XPDUTL(TEX T)
  9193   "RTN","PXP XRMI1",173 ,0)
  9194    . I IND#1 0000=0 W " ."
  9195   "RTN","PXP XRMI1",174 ,0)
  9196    . S TEMP= ^AUPNVIMM( DAS,0)
  9197   "RTN","PXP XRMI1",175 ,0)
  9198    . S IMM=$ P(TEMP,U,1 )
  9199   "RTN","PXP XRMI1",176 ,0)
  9200    . I IMM=" " D  Q
  9201   "RTN","PXP XRMI1",177 ,0)
  9202    .. S ETEX T=DAS_" mi ssing immu nization"
  9203   "RTN","PXP XRMI1",178 ,0)
  9204    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9205   "RTN","PXP XRMI1",179 ,0)
  9206    . I '$D(^ AUTTIMM(IM M)) D  Q
  9207   "RTN","PXP XRMI1",180 ,0)
  9208    .. S ETEX T=DAS_" in valid immu nization"
  9209   "RTN","PXP XRMI1",181 ,0)
  9210    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9211   "RTN","PXP XRMI1",182 ,0)
  9212    . S DFN=$ P(TEMP,U,2 )
  9213   "RTN","PXP XRMI1",183 ,0)
  9214    . I DFN=" " D  Q
  9215   "RTN","PXP XRMI1",184 ,0)
  9216    .. S ETEX T=DAS_" mi ssing DFN"
  9217   "RTN","PXP XRMI1",185 ,0)
  9218    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9219   "RTN","PXP XRMI1",186 ,0)
  9220    . S VISIT =$P(TEMP,U ,3)
  9221   "RTN","PXP XRMI1",187 ,0)
  9222    . I VISIT ="" D  Q
  9223   "RTN","PXP XRMI1",188 ,0)
  9224    .. S ETEX T=DAS_" mi ssing visi t"
  9225   "RTN","PXP XRMI1",189 ,0)
  9226    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9227   "RTN","PXP XRMI1",190 ,0)
  9228    . I '$D(^ AUPNVSIT(V ISIT)) D   Q
  9229   "RTN","PXP XRMI1",191 ,0)
  9230    .. S ETEX T=DAS_" in valid visi t"
  9231   "RTN","PXP XRMI1",192 ,0)
  9232    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9233   "RTN","PXP XRMI1",193 ,0)
  9234    . S DATE= $P(^AUPNVS IT(VISIT,0 ),U,1)
  9235   "RTN","PXP XRMI1",194 ,0)
  9236    . I DATE= "" D  Q
  9237   "RTN","PXP XRMI1",195 ,0)
  9238    .. S ETEX T=DAS_" mi ssing visi t date"
  9239   "RTN","PXP XRMI1",196 ,0)
  9240    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9241   "RTN","PXP XRMI1",197 ,0)
  9242    . S EVENT DT=$P($G(^ AUPNVIMM(D AS,12)),U, 1)
  9243   "RTN","PXP XRMI1",198 ,0)
  9244    . I EVENT DT S DATE= EVENTDT
  9245   "RTN","PXP XRMI1",199 ,0)
  9246    . S NE=NE +1
  9247   "RTN","PXP XRMI1",200 ,0)
  9248    . S ^PXRM INDX(90000 10.11,"IP" ,IMM,DFN,D ATE,DAS)=" "
  9249   "RTN","PXP XRMI1",201 ,0)
  9250    . S ^PXRM INDX(90000 10.11,"PI" ,DFN,IMM,D ATE,DAS)=" "
  9251   "RTN","PXP XRMI1",202 ,0)
  9252    . S CVX=$ P($G(^AUTT IMM(IMM,0) ),U,3)
  9253   "RTN","PXP XRMI1",203 ,0)
  9254    . I CVX'= "" D
  9255   "RTN","PXP XRMI1",204 ,0)
  9256    .. S ^PXR MINDX(9000 010.11,"CV X","IP",CV X,DFN,DATE ,DAS)=""
  9257   "RTN","PXP XRMI1",205 ,0)
  9258    .. S ^PXR MINDX(9000 010.11,"CV X","PI",DF N,CVX,DATE ,DAS)=""
  9259   "RTN","PXP XRMI1",206 ,0)
  9260    S END=$H
  9261   "RTN","PXP XRMI1",207 ,0)
  9262    S TEXT=NE _" V IMMUN IZATION re sults inde xed."
  9263   "RTN","PXP XRMI1",208 ,0)
  9264    D MES^XPD UTL(TEXT)
  9265   "RTN","PXP XRMI1",209 ,0)
  9266    D DETIME^ PXRMSXRM(S TART,END)
  9267   "RTN","PXP XRMI1",210 ,0)
  9268    ;If there  were erro rs send a  message.
  9269   "RTN","PXP XRMI1",211 ,0)
  9270    I NERROR> 0 D ERRMSG ^PXRMSXRM( NERROR,GLO BAL)
  9271   "RTN","PXP XRMI1",212 ,0)
  9272    ;Send a M ailMan mes sage with  the result s.
  9273   "RTN","PXP XRMI1",213 ,0)
  9274    D COMMSG^ PXRMSXRM(G LOBAL,STAR T,END,NE,N ERROR)
  9275   "RTN","PXP XRMI1",214 ,0)
  9276    S ^PXRMIN DX(9000010 .11,"GLOBA L NAME")=G LOBAL
  9277   "RTN","PXP XRMI1",215 ,0)
  9278    S ^PXRMIN DX(9000010 .11,"BUILT  BY")=DUZ
  9279   "RTN","PXP XRMI1",216 ,0)
  9280    S ^PXRMIN DX(9000010 .11,"DATE  BUILT")=$$ NOW^XLFDT
  9281   "RTN","PXP XRMI1",217 ,0)
  9282    Q
  9283   "RTN","PXP XRMI1",218 ,0)
  9284    ;
  9285   "RTN","PXP XRMI1",219 ,0)
  9286    ;======== ========== ========== ========== ========== ========== =====
  9287   "RTN","PXP XRMI1",220 ,0)
  9288   VICR ;Buil d the inde xes for V  IMM CONTRA /REFUSAL E VENTS.
  9289   "RTN","PXP XRMI1",221 ,0)
  9290    N DAS,DFN ,DONE,END, ENTRIES,ET EXT,EVENTD T,GLOBAL,I CR,IMM,IND ,NE
  9291   "RTN","PXP XRMI1",222 ,0)
  9292    N NERROR, PXFILE,PXS TART,PXSTO P,START,TE MP,TENP,TE XT,VDATE,V ISIT,WARND T
  9293   "RTN","PXP XRMI1",223 ,0)
  9294    S PXFILE= 9000010.70 7
  9295   "RTN","PXP XRMI1",224 ,0)
  9296    ;Don't le ave any ol d stuff ar ound.
  9297   "RTN","PXP XRMI1",225 ,0)
  9298    K ^PXRMIN DX(PXFILE)
  9299   "RTN","PXP XRMI1",226 ,0)
  9300    S GLOBAL= $$GET1^DID (PXFILE,"" ,"","GLOBA L NAME")
  9301   "RTN","PXP XRMI1",227 ,0)
  9302    S ENTRIES =$P(^AUPNV ICR(0),U,4 )
  9303   "RTN","PXP XRMI1",228 ,0)
  9304    S TENP=EN TRIES/10
  9305   "RTN","PXP XRMI1",229 ,0)
  9306    S TENP=+$ P(TENP,"." ,1)
  9307   "RTN","PXP XRMI1",230 ,0)
  9308    I TENP<1  S TENP=1
  9309   "RTN","PXP XRMI1",231 ,0)
  9310    D BMES^XP DUTL("Buil ding index es for V I MM CONTRA/ REFUSAL EV ENTS")
  9311   "RTN","PXP XRMI1",232 ,0)
  9312    S TEXT="T here are " _ENTRIES_"  entries t o process. "
  9313   "RTN","PXP XRMI1",233 ,0)
  9314    D MES^XPD UTL(TEXT)
  9315   "RTN","PXP XRMI1",234 ,0)
  9316    S START=$ H
  9317   "RTN","PXP XRMI1",235 ,0)
  9318    S (DAS,DO NE,IND,NE, NERROR)=0
  9319   "RTN","PXP XRMI1",236 ,0)
  9320    F  S DAS= $O(^AUPNVI CR(DAS)) Q :DONE  D
  9321   "RTN","PXP XRMI1",237 ,0)
  9322    . I +DAS= 0 S DONE=1  Q
  9323   "RTN","PXP XRMI1",238 ,0)
  9324    . I +DAS' =DAS D  Q
  9325   "RTN","PXP XRMI1",239 ,0)
  9326    .. S DONE =1
  9327   "RTN","PXP XRMI1",240 ,0)
  9328    .. S ETEX T="Bad ien : "_DAS_",  cannot co ntinue."
  9329   "RTN","PXP XRMI1",241 ,0)
  9330    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9331   "RTN","PXP XRMI1",242 ,0)
  9332    . S IND=I ND+1
  9333   "RTN","PXP XRMI1",243 ,0)
  9334    . I IND#T ENP=0 D
  9335   "RTN","PXP XRMI1",244 ,0)
  9336    .. S TEXT ="Processi ng entry " _IND
  9337   "RTN","PXP XRMI1",245 ,0)
  9338    .. D MES^ XPDUTL(TEX T)
  9339   "RTN","PXP XRMI1",246 ,0)
  9340    . I IND#1 0000=0 W " ."
  9341   "RTN","PXP XRMI1",247 ,0)
  9342    . S TEMP= $G(^AUPNVI CR(DAS,0))
  9343   "RTN","PXP XRMI1",248 ,0)
  9344    . S ICR=$ P(TEMP,U,1 )
  9345   "RTN","PXP XRMI1",249 ,0)
  9346    . I ICR=" " D  Q
  9347   "RTN","PXP XRMI1",250 ,0)
  9348    .. S ETEX T=DAS_" mi ssing cont raindicati on/refusal "
  9349   "RTN","PXP XRMI1",251 ,0)
  9350    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9351   "RTN","PXP XRMI1",252 ,0)
  9352    . I '$D(^ PXV(+$P(IC R,"(",2),+ ICR)) D  Q
  9353   "RTN","PXP XRMI1",253 ,0)
  9354    .. S ETEX T=DAS_" in valid cont raindicati on/refusal "
  9355   "RTN","PXP XRMI1",254 ,0)
  9356    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9357   "RTN","PXP XRMI1",255 ,0)
  9358    . S IMM=$ P(TEMP,U,4 )
  9359   "RTN","PXP XRMI1",256 ,0)
  9360    . I IMM=" " D  Q
  9361   "RTN","PXP XRMI1",257 ,0)
  9362    .. S ETEX T=DAS_" mi ssing immu nization"
  9363   "RTN","PXP XRMI1",258 ,0)
  9364    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9365   "RTN","PXP XRMI1",259 ,0)
  9366    . I '$D(^ AUTTIMM(IM M)) D  Q
  9367   "RTN","PXP XRMI1",260 ,0)
  9368    .. S ETEX T=DAS_" in valid immu nization"
  9369   "RTN","PXP XRMI1",261 ,0)
  9370    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9371   "RTN","PXP XRMI1",262 ,0)
  9372    . S DFN=$ P(TEMP,U,2 )
  9373   "RTN","PXP XRMI1",263 ,0)
  9374    . I DFN=" " D  Q
  9375   "RTN","PXP XRMI1",264 ,0)
  9376    .. S ETEX T=DAS_" mi ssing DFN"
  9377   "RTN","PXP XRMI1",265 ,0)
  9378    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9379   "RTN","PXP XRMI1",266 ,0)
  9380    . S VISIT =$P(TEMP,U ,3)
  9381   "RTN","PXP XRMI1",267 ,0)
  9382    . I VISIT ="" D  Q
  9383   "RTN","PXP XRMI1",268 ,0)
  9384    .. S ETEX T=DAS_" mi ssing visi t"
  9385   "RTN","PXP XRMI1",269 ,0)
  9386    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9387   "RTN","PXP XRMI1",270 ,0)
  9388    . I '$D(^ AUPNVSIT(V ISIT)) D   Q
  9389   "RTN","PXP XRMI1",271 ,0)
  9390    .. S ETEX T=DAS_" in valid visi t"
  9391   "RTN","PXP XRMI1",272 ,0)
  9392    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9393   "RTN","PXP XRMI1",273 ,0)
  9394    . S VDATE =$P($G(^AU PNVSIT(VIS IT,0)),U,1 )
  9395   "RTN","PXP XRMI1",274 ,0)
  9396    . I VDATE ="" D  Q
  9397   "RTN","PXP XRMI1",275 ,0)
  9398    .. S ETEX T=DAS_" mi ssing visi t date"
  9399   "RTN","PXP XRMI1",276 ,0)
  9400    .. D ADDE RROR^PXRMS XRM(GLOBAL ,ETEXT,.NE RROR)
  9401   "RTN","PXP XRMI1",277 ,0)
  9402    . S WARND T=$P(TEMP, U,5)
  9403   "RTN","PXP XRMI1",278 ,0)
  9404    . S EVENT DT=$P($G(^ AUPNVICR(D AS,12)),U, 1)
  9405   "RTN","PXP XRMI1",279 ,0)
  9406    . S PXSTA RT=VDATE
  9407   "RTN","PXP XRMI1",280 ,0)
  9408    . I EVENT DT S PXSTA RT=EVENTDT
  9409   "RTN","PXP XRMI1",281 ,0)
  9410    . S PXSTO P=9999999
  9411   "RTN","PXP XRMI1",282 ,0)
  9412    . I WARND T S PXSTOP =WARNDT
  9413   "RTN","PXP XRMI1",283 ,0)
  9414    . S NE=NE +1
  9415   "RTN","PXP XRMI1",284 ,0)
  9416    . S ^PXRM INDX(PXFIL E,"ICP",IM M,ICR,DFN, PXSTART,PX STOP,DAS)= ""
  9417   "RTN","PXP XRMI1",285 ,0)
  9418    . S ^PXRM INDX(PXFIL E,"PIC",DF N,IMM,ICR, PXSTART,PX STOP,DAS)= ""
  9419   "RTN","PXP XRMI1",286 ,0)
  9420    . S ^PXRM INDX(PXFIL E,"CIP",IC R,IMM,DFN, PXSTART,PX STOP,DAS)= ""
  9421   "RTN","PXP XRMI1",287 ,0)
  9422    . S ^PXRM INDX(PXFIL E,"PCI",DF N,ICR,IMM, PXSTART,PX STOP,DAS)= ""
  9423   "RTN","PXP XRMI1",288 ,0)
  9424    S END=$H
  9425   "RTN","PXP XRMI1",289 ,0)
  9426    S TEXT=NE _" V IMM C ONTRA/REFU SAL EVENTS  results i ndexed."
  9427   "RTN","PXP XRMI1",290 ,0)
  9428    D MES^XPD UTL(TEXT)
  9429   "RTN","PXP XRMI1",291 ,0)
  9430    D DETIME^ PXRMSXRM(S TART,END)
  9431   "RTN","PXP XRMI1",292 ,0)
  9432    ;If there  were erro rs send a  message.
  9433   "RTN","PXP XRMI1",293 ,0)
  9434    I NERROR> 0 D ERRMSG ^PXRMSXRM( NERROR,GLO BAL)
  9435   "RTN","PXP XRMI1",294 ,0)
  9436    ;Send a M ailMan mes sage with  the result s.
  9437   "RTN","PXP XRMI1",295 ,0)
  9438    D COMMSG^ PXRMSXRM(G LOBAL,STAR T,END,NE,N ERROR)
  9439   "RTN","PXP XRMI1",296 ,0)
  9440    S ^PXRMIN DX(PXFILE, "GLOBAL NA ME")=GLOBA L
  9441   "RTN","PXP XRMI1",297 ,0)
  9442    S ^PXRMIN DX(PXFILE, "BUILT BY" )=DUZ
  9443   "RTN","PXP XRMI1",298 ,0)
  9444    S ^PXRMIN DX(PXFILE, "DATE BUIL T")=$$NOW^ XLFDT
  9445   "RTN","PXP XRMI1",299 ,0)
  9446    Q
  9447   "RTN","PXP XRMI1",300 ,0)
  9448    ;
  9449   "RTN","PXR PC")
  9450   0^7^B15691 7264^B1096 84381
  9451   "RTN","PXR PC",1,0)
  9452   PXRPC ;ISL /JLC - PCE  DATA2PCE  RPC ;04/06 /16  14:13
  9453   "RTN","PXR PC",2,0)
  9454    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**200, 209,210,21 5**;Aug 12 , 1996;Bui ld 10
  9455   "RTN","PXR PC",3,0)
  9456    ;
  9457   "RTN","PXR PC",4,0)
  9458    ; Referen ce to UCUM DATA^LEXMU CUM suppor ted by ICR  #6225
  9459   "RTN","PXR PC",5,0)
  9460    ; Referen ce to ICDD X^ICDEX su pported by  ICR #5747
  9461   "RTN","PXR PC",6,0)
  9462    ;
  9463   "RTN","PXR PC",7,0)
  9464    ;
  9465   "RTN","PXR PC",8,0)
  9466   SAVE(OK,PC ELIST,LOC, PKGNAME,SR C) ; save  PCE inform ation
  9467   "RTN","PXR PC",9,0)
  9468    N VSTR
  9469   "RTN","PXR PC",10,0)
  9470    N PXAPI,P XDEL,PKG,P ROBLEMS,PX AVST,PXERR OR,PXAPRED T
  9471   "RTN","PXR PC",11,0)
  9472    I '$D(PCE LIST(1)) S  OK=-3 Q
  9473   "RTN","PXR PC",12,0)
  9474    S VSTR=$P (PCELIST(1 ),U,4) K ^ TMP("PXRPC ",$J,VSTR)
  9475   "RTN","PXR PC",13,0)
  9476    I $G(PKGN AME)="" S  OK=-3 Q
  9477   "RTN","PXR PC",14,0)
  9478    I $G(SRC) ="" S OK=- 3 Q
  9479   "RTN","PXR PC",15,0)
  9480    S PKG=$$P KG2IEN^VSI T(PKGNAME)  I PKG=-1  S OK=-3 Q
  9481   "RTN","PXR PC",16,0)
  9482    M ^TMP("P XRPC",$J,V STR)=PCELI ST
  9483   "RTN","PXR PC",17,0)
  9484    D DQSAVE( .PCELIST," PXAPI","PX DEL",.PROB LEMS,.SRC)
  9485   "RTN","PXR PC",18,0)
  9486    I '$D(PXA PI)#10 S O K=-3 Q
  9487   "RTN","PXR PC",19,0)
  9488    I $D(PXAP I("PROVIDE R")) S PXA PREDT=1 ;A llow edit  of primary  flag
  9489   "RTN","PXR PC",20,0)
  9490    D DATA2PC E(.OK,"PXA PI",PKG,SR C,.PXAVST, .PXERROR)
  9491   "RTN","PXR PC",21,0)
  9492    Q
  9493   "RTN","PXR PC",22,0)
  9494    ;
  9495   "RTN","PXR PC",23,0)
  9496   DQSAVE(PCE LIST,PXPCE ARR,PXPCED ARR,PROBLE MS,SRC) ;
  9497   "RTN","PXR PC",24,0)
  9498    ;
  9499   "RTN","PXR PC",25,0)
  9500    ; Process es PCELIST  input arr ay and cre ates a new  array in  a format
  9501   "RTN","PXR PC",26,0)
  9502    ; that ca n be passe d into DAT A2PCE^PXAP I.
  9503   "RTN","PXR PC",27,0)
  9504    ;
  9505   "RTN","PXR PC",28,0)
  9506    ;Input:
  9507   "RTN","PXR PC",29,0)
  9508    ;   .PCEL IST - (Req uired) Arr ay passed  by referen ce.
  9509   "RTN","PXR PC",30,0)
  9510    ;               This  should be  in the sa me format  as the PX  SAVE DATA
  9511   "RTN","PXR PC",31,0)
  9512    ;               and  ORWPCE SAV E RPCs' PC ELIST inpu t paramete r.
  9513   "RTN","PXR PC",32,0)
  9514    ;   PXPCE ARR - (Req uired) The  root of a n array pa ssed as a  String val ue
  9515   "RTN","PXR PC",33,0)
  9516    ;               (e.g ., "ORPXAP I") that t his API wi ll populat e based of f
  9517   "RTN","PXR PC",34,0)
  9518    ;               the  PCELIST ar gument. Th is array w ill be in  a format
  9519   "RTN","PXR PC",35,0)
  9520    ;               that  can be pa ssed into  DATA2PCE^P XAPI.
  9521   "RTN","PXR PC",36,0)
  9522    ;  PXPCED ARR - (Req uired) The  root of a n array pa ssed as a  String val ue
  9523   "RTN","PXR PC",37,0)
  9524    ;               (e.g ., "ORPXDE L") that t his API wi ll populat e based of f
  9525   "RTN","PXR PC",38,0)
  9526    ;               the  PCELIST ar gument. Th is array w ill be pop ulated wit h
  9527   "RTN","PXR PC",39,0)
  9528    ;               some  deletions  that need  to be fil ed to DATA 2PCE befor e
  9529   "RTN","PXR PC",40,0)
  9530    ;               fili ng PXPCEAR R. This ar ray will b e in a for mat
  9531   "RTN","PXR PC",41,0)
  9532    ;               that  can be pa ssed into  DATA2PCE^P XAPI.
  9533   "RTN","PXR PC",42,0)
  9534    ;  .PROBL EMS - (Req uired) Thi s API will  populate  this array  with POV
  9535   "RTN","PXR PC",43,0)
  9536    ;               entr ies that a re marked  to be adde d to the P roblem Lis t.
  9537   "RTN","PXR PC",44,0)
  9538    ;       . SRC - (Req uired) The  source of  the data  - such as  'TEXT
  9539   "RTN","PXR PC",45,0)
  9540    ;               INTE GRATION UT ILITIES'.  This API c an possibl y change t he
  9541   "RTN","PXR PC",46,0)
  9542    ;               valu e of SRC,  depending  on the Hea lth Factor  (HF) valu es
  9543   "RTN","PXR PC",47,0)
  9544    ;               cont ained in P CELIST.
  9545   "RTN","PXR PC",48,0)
  9546    ;
  9547   "RTN","PXR PC",49,0)
  9548    N TYP,COD E,IEN,I,X
  9549   "RTN","PXR PC",50,0)
  9550    N CAT,NAR R,ROOT,ROO T2,PXENCDT ,IMPLDT
  9551   "RTN","PXR PC",51,0)
  9552    N PRV,CPT ,ICD,IMM,S K,PED,HF,X AM,TRT,ICR ,MOD,MODCN T,MODIDX,M ODS
  9553   "RTN","PXR PC",52,0)
  9554    N COM,COM MENT,COMME NTS,SVCAT
  9555   "RTN","PXR PC",53,0)
  9556    N DFN,PXA PREDT,PXCP TDEL
  9557   "RTN","PXR PC",54,0)
  9558    ; Vars fo r Info Sou rce (IMMIS ) Imm. Adm in Route ( IMMRT), Bo dy Site (I MMAL), Lot , Manufact urer, Exp.  Date & Co mments
  9559   "RTN","PXR PC",55,0)
  9560    N IMMISNM ,IMMISIEN, IMMRTNM,IM MRTIEN,IMM RTERR,IMMA LNAME,IMMA LIEN,IMMAL ERR,IMMLOT ,IMMMANUF, IMMEXPDT,I MMCOMM,IMM COMMS,IMML OTIEN
  9561   "RTN","PXR PC",56,0)
  9562    N NUM,REM ARK,SEQ,IM MDSG,IMMCV X,IMMCVXER ,IMMOVERRI DE
  9563   "RTN","PXR PC",57,0)
  9564    S IMPLDT= $$IMPDATE^ LEXU("10D" )
  9565   "RTN","PXR PC",58,0)
  9566    S (PRV,CP T,ICD,IMM, SK,PED,HF, XAM,TRT,IC R)=0
  9567   "RTN","PXR PC",59,0)
  9568    S I="" F   S I=$O(PC ELIST(I))  Q:'I  S X= PCELIST(I)  D
  9569   "RTN","PXR PC",60,0)
  9570    . S X=PCE LIST(I),TY P=$P(X,U), CODE=$P(X, U,2),CAT=$ P(X,U,3),N ARR=$P(X,U ,4)
  9571   "RTN","PXR PC",61,0)
  9572    . I $E(TY P,1,3)="PR V" D  Q
  9573   "RTN","PXR PC",62,0)
  9574    . . Q:'$L (CODE)
  9575   "RTN","PXR PC",63,0)
  9576    . . S PRV =PRV+1
  9577   "RTN","PXR PC",64,0)
  9578    . . S ROO T=PXPCEARR _"(""PROVI DER"","_PR V_")"
  9579   "RTN","PXR PC",65,0)
  9580    . . S ROO T2=PXPCEDA RR_"(""PRO VIDER"","_ PRV_")"
  9581   "RTN","PXR PC",66,0)
  9582    . . I $E( TYP,4)'="- " D
  9583   "RTN","PXR PC",67,0)
  9584    . . . S @ ROOT@("NAM E")=CODE
  9585   "RTN","PXR PC",68,0)
  9586    . . . S @ ROOT@("PRI MARY")=$P( X,U,6)
  9587   "RTN","PXR PC",69,0)
  9588    . . S @RO OT2@("NAME ")=CODE
  9589   "RTN","PXR PC",70,0)
  9590    . . S @RO OT2@("DELE TE")=1
  9591   "RTN","PXR PC",71,0)
  9592    . . S PXA PREDT=1 ;A llow edit  of primary  flag
  9593   "RTN","PXR PC",72,0)
  9594    . I TYP=" VST" D  Q
  9595   "RTN","PXR PC",73,0)
  9596    . . S ROO T=PXPCEARR _"(""ENCOU NTER"",1)"
  9597   "RTN","PXR PC",74,0)
  9598    . . I COD E="DT" S ( PXENCDT,@R OOT@("ENC  D/T"))=$P( X,U,3) Q
  9599   "RTN","PXR PC",75,0)
  9600    . . I COD E="PT" S @ ROOT@("PAT IENT")=$P( X,U,3),DFN =$P(X,U,3)  Q
  9601   "RTN","PXR PC",76,0)
  9602    . . I COD E="HL" S @ ROOT@("HOS  LOC")=$P( X,U,3) Q
  9603   "RTN","PXR PC",77,0)
  9604    . . I COD E="PR" S @ ROOT@("PAR ENT")=$P(X ,U,3) Q
  9605   "RTN","PXR PC",78,0)
  9606    . . ;prev ents check out!
  9607   "RTN","PXR PC",79,0)
  9608    . . I COD E="VC" S ( SVCAT,@ROO T@("SERVIC E CATEGORY "))=$P(X,U ,3) Q
  9609   "RTN","PXR PC",80,0)
  9610    . . I COD E="SC" S @ ROOT@("SC" )=$P(X,U,3 ) Q
  9611   "RTN","PXR PC",81,0)
  9612    . . I COD E="AO" S @ ROOT@("AO" )=$P(X,U,3 ) Q
  9613   "RTN","PXR PC",82,0)
  9614    . . I COD E="IR" S @ ROOT@("IR" )=$P(X,U,3 ) Q
  9615   "RTN","PXR PC",83,0)
  9616    . . I COD E="EC" S @ ROOT@("EC" )=$P(X,U,3 ) Q
  9617   "RTN","PXR PC",84,0)
  9618    . . I COD E="MST" S  @ROOT@("MS T")=$P(X,U ,3) Q
  9619   "RTN","PXR PC",85,0)
  9620    . . I COD E="HNC" S  @ROOT@("HN C")=$P(X,U ,3) Q
  9621   "RTN","PXR PC",86,0)
  9622    . . I COD E="CV" S @ ROOT@("CV" )=$P(X,U,3 ) Q
  9623   "RTN","PXR PC",87,0)
  9624    . . I COD E="SHD" S  @ROOT@("SH AD")=$P(X, U,3) Q
  9625   "RTN","PXR PC",88,0)
  9626    . . I COD E="OL" D   Q
  9627   "RTN","PXR PC",89,0)
  9628    . . . I + $P(X,U,3)  S @ROOT@(" INSTITUTIO N")=$P(X,U ,3)
  9629   "RTN","PXR PC",90,0)
  9630    . . . E   I $P(X,U,4 )'="",$P(X ,U,4)'="0"  D
  9631   "RTN","PXR PC",91,0)
  9632    . . . . I  $$PATCH^X PDUTL("PX* 1.0*96") S  @ROOT@("O UTSIDE LOC ATION")=$P (X,U,4)
  9633   "RTN","PXR PC",92,0)
  9634    . . . . E   S @ROOT@ ("COMMENT" )="OUTSIDE  LOCATION:   "_$P(X,U ,4)
  9635   "RTN","PXR PC",93,0)
  9636    . I $E(TY P,1,3)="CP T" D  Q
  9637   "RTN","PXR PC",94,0)
  9638    . . Q:'$L (CODE)
  9639   "RTN","PXR PC",95,0)
  9640    . . S CPT =CPT+1,ROO T=PXPCEARR _"(""PROCE DURE"","_C PT_")"
  9641   "RTN","PXR PC",96,0)
  9642    . . S IEN =$$CODEN^I CPTCOD(COD E) ;ICR #1 995
  9643   "RTN","PXR PC",97,0)
  9644    . . S @RO OT@("PROCE DURE")=IEN
  9645   "RTN","PXR PC",98,0)
  9646    . . I +$P (X,U,9) D
  9647   "RTN","PXR PC",99,0)
  9648    . . . S M ODS=$P(X,U ,9),MODCNT =+MODS
  9649   "RTN","PXR PC",100,0)
  9650    . . . F M ODIDX=1:1: MODCNT D
  9651   "RTN","PXR PC",101,0)
  9652    . . . . S  MOD=$P($P (MODS,";", MODIDX+1), "/")
  9653   "RTN","PXR PC",102,0)
  9654    . . . . S  @ROOT@("M ODIFIERS", MOD)=""
  9655   "RTN","PXR PC",103,0)
  9656    . . S:$L( CAT) @ROOT @("CATEGOR Y")=CAT
  9657   "RTN","PXR PC",104,0)
  9658    . . S:$L( NARR) @ROO T@("NARRAT IVE")=NARR
  9659   "RTN","PXR PC",105,0)
  9660    . . S:$L( $P(X,U,5))  @ROOT@("Q TY")=$P(X, U,5)
  9661   "RTN","PXR PC",106,0)
  9662    . . S:$P( X,U,6)>0 @ ROOT@("ENC  PROVIDER" )=$P(X,U,6 )
  9663   "RTN","PXR PC",107,0)
  9664    . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="PROCE DURE^"_CPT
  9665   "RTN","PXR PC",108,0)
  9666    . . I $E( TYP,4)="-"  S @ROOT@( "DELETE")= 1,@ROOT@(" QTY")=0,PX CPTDEL=CPT
  9667   "RTN","PXR PC",109,0)
  9668    . I $E(TY P,1,3)="PO V" D  Q
  9669   "RTN","PXR PC",110,0)
  9670    . . N PXD XI,PXDX
  9671   "RTN","PXR PC",111,0)
  9672    . . Q:'$L (CODE)
  9673   "RTN","PXR PC",112,0)
  9674    . . F PXD XI=1:1:$L( CODE,"/")  D
  9675   "RTN","PXR PC",113,0)
  9676    . . . N C SYS,CDT,IE N,LEXIEN
  9677   "RTN","PXR PC",114,0)
  9678    . . . S P XDX=$P(COD E,"/",PXDX I)
  9679   "RTN","PXR PC",115,0)
  9680    . . . S I CD=ICD+1,R OOT=PXPCEA RR_"(""DX/ PL"","_ICD _")"
  9681   "RTN","PXR PC",116,0)
  9682    . . . S C DT=$S($G(S VCAT)="E": DT,1:$G(PX ENCDT))
  9683   "RTN","PXR PC",117,0)
  9684    . . . S C SYS=$S(CDT '<IMPLDT:" 10D",1:"IC D")
  9685   "RTN","PXR PC",118,0)
  9686    . . . I ( PXDX]""),( PXDX'[".")  S PXDX=PX DX_"."
  9687   "RTN","PXR PC",119,0)
  9688    . . . S I EN=+$$ICDD X^ICDEX(PX DX,CDT,$S( CSYS="10D" :30,1:1)," E") ; ICR  #5747
  9689   "RTN","PXR PC",120,0)
  9690    . . . I I EN'>0 Q
  9691   "RTN","PXR PC",121,0)
  9692    . . . S @ ROOT@("DIA GNOSIS")=I EN
  9693   "RTN","PXR PC",122,0)
  9694    . . . S @ ROOT@("PRI MARY")=$S( PXDXI=1:$P (X,U,5),1: 0)
  9695   "RTN","PXR PC",123,0)
  9696    . . . S L EXIEN=$P($ $EXP^LEXCO DE(PXDX,CS YS,CDT),U) ,@ROOT@("L EXICON TER M")=$S(LEX IEN>0:LEXI EN,1:"")
  9697   "RTN","PXR PC",124,0)
  9698    . . . S:$ L(CAT) @RO OT@("CATEG ORY")=CAT
  9699   "RTN","PXR PC",125,0)
  9700    . . . S:$ L(NARR) @R OOT@("NARR ATIVE")=NA RR
  9701   "RTN","PXR PC",126,0)
  9702    . . . S:$ P(X,U,6)>0  @ROOT@("E NC PROVIDE R")=$P(X,U ,6)
  9703   "RTN","PXR PC",127,0)
  9704    . . . I $ L($P(X,U,7 )),($P(X,U ,7)=1),(PX DXI=1) S @ ROOT@("PL  ADD")=$P(X ,U,7),PROB LEMS(ICD)= NARR_U_COD E
  9705   "RTN","PXR PC",128,0)
  9706    . . . S:$ L($P(X,U,1 0))>0&(PXD XI=1) COMM ENT($P(X,U ,10))="DX/ PL^"_ICD
  9707   "RTN","PXR PC",129,0)
  9708    . . . I $ E(TYP,4)=" -" S @ROOT @("DELETE" )=1
  9709   "RTN","PXR PC",130,0)
  9710    . I $E(TY P,1,3)="IM M" D  Q
  9711   "RTN","PXR PC",131,0)
  9712    . . ; If  the CVX Co de is pres ent, then  use it to  find the c orrespondi ng Immuniz ation,
  9713   "RTN","PXR PC",132,0)
  9714    . . ; but  only if t he Immuniz ation IEN  is not spe cified
  9715   "RTN","PXR PC",133,0)
  9716    . . S IMM CVX=$P(X,U ,11)
  9717   "RTN","PXR PC",134,0)
  9718    . . I COD E="",IMMCV X'="" S CO DE=$$FIND1 ^DIC(99999 99.14,,,IM MCVX,"C",, "IMMCVXER" )
  9719   "RTN","PXR PC",135,0)
  9720    . . Q:'$L (CODE)
  9721   "RTN","PXR PC",136,0)
  9722    . . S IMM =IMM+1,ROO T=PXPCEARR _"(""IMMUN IZATION"", "_IMM_")"
  9723   "RTN","PXR PC",137,0)
  9724    . . S @RO OT@("IMMUN ")=CODE
  9725   "RTN","PXR PC",138,0)
  9726    . . I IMM CVX'="" S  @ROOT@("CV X")=IMMCVX
  9727   "RTN","PXR PC",139,0)
  9728    . . S:$L( $P(X,U,5))  @ROOT@("S ERIES")=$P (X,U,5)
  9729   "RTN","PXR PC",140,0)
  9730    . . S:$L( $P(X,U,7))  @ROOT@("R EACTION")= $P(X,U,7)
  9731   "RTN","PXR PC",141,0)
  9732    . . S:$L( $P(X,U,8))  @ROOT@("C ONTRAINDIC ATED")=$P( X,U,8)
  9733   "RTN","PXR PC",142,0)
  9734    . . S:$L( $P(X,U,9))  @ROOT@("R EFUSED")=$ P(X,U,9)
  9735   "RTN","PXR PC",143,0)
  9736    . . S:$P( X,U,6)>0 @ ROOT@("ENC  PROVIDER" )=$P(X,U,6 )
  9737   "RTN","PXR PC",144,0)
  9738    . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="IMMUN IZATION^"_ IMM
  9739   "RTN","PXR PC",145,0)
  9740    . . ; The se are the  additiona l fields b eing added  by PX*1.0 *209
  9741   "RTN","PXR PC",146,0)
  9742    . . S IMM ISIEN=$$IM MSRC($P(X, U,12))
  9743   "RTN","PXR PC",147,0)
  9744    . . S:IMM ISIEN @ROO T@("INFO S OURCE")=IM MISIEN
  9745   "RTN","PXR PC",148,0)
  9746    . . S IMM RTIEN=$$IM MROUTE($P( X,U,14))
  9747   "RTN","PXR PC",149,0)
  9748    . . S:IMM RTIEN @ROO T@("ADMIN  ROUTE")=IM MRTIEN
  9749   "RTN","PXR PC",150,0)
  9750    . . S IMM ALIEN=$$IM MLOC($P(X, U,15))
  9751   "RTN","PXR PC",151,0)
  9752    . . S:IMM ALIEN @ROO T@("ANATOM IC LOC")=I MMALIEN
  9753   "RTN","PXR PC",152,0)
  9754    . . S IMM LOT=$$IMML OT($P(X,U, 16),$P(X,U ,17),$P(X, U,18))
  9755   "RTN","PXR PC",153,0)
  9756    . . S IMM LOTIEN=$P( IMMLOT,"^" ,1)
  9757   "RTN","PXR PC",154,0)
  9758    . . S IMM COMM=$P(IM MLOT,"^",2 )
  9759   "RTN","PXR PC",155,0)
  9760    . . S:IMM LOTIEN @RO OT@("LOT N UM")=IMMLO TIEN
  9761   "RTN","PXR PC",156,0)
  9762    . . S IMM DSG=$$IMMD SG($P(X,U, 13))
  9763   "RTN","PXR PC",157,0)
  9764    . . I $P( IMMDSG,U,1 )'="" D
  9765   "RTN","PXR PC",158,0)
  9766    . . . S @ ROOT@("DOS E")=$P(IMM DSG,U,1)
  9767   "RTN","PXR PC",159,0)
  9768    . . . I $ P(IMMDSG,U ,2) S @ROO T@("DOSE U NITS")=$P( IMMDSG,U,2 )
  9769   "RTN","PXR PC",160,0)
  9770    . . I $P( IMMDSG,U,3 )'="" D  ;  add Dosag e to comme nts
  9771   "RTN","PXR PC",161,0)
  9772    . . . S I MMCOMM=$S( $G(IMMCOMM )'="":IMMC OMM_"; ",1 :"")_$P(IM MDSG,U,3)
  9773   "RTN","PXR PC",162,0)
  9774    . . I IMM COMM'="" D
  9775   "RTN","PXR PC",163,0)
  9776    . . . ; I f we have  something  to add to  the Imm co mment, eit her add it  to the ex isting com ment
  9777   "RTN","PXR PC",164,0)
  9778    . . . ; ( if one exi sts) or ju st set it  in the COM MENT field .
  9779   "RTN","PXR PC",165,0)
  9780    . . . I $ L($P(X,U,1 0)) S IMMC OMMS($P(X, U,10))=IMM COMM ; Thi s will get  added lat er to the  existing c omment
  9781   "RTN","PXR PC",166,0)
  9782    . . . E   S @ROOT@(" COMMENT")= IMMCOMM
  9783   "RTN","PXR PC",167,0)
  9784    . . S:$P( X,U,19)>0  @ROOT@("EV ENT D/T")= $P(X,U,19)
  9785   "RTN","PXR PC",168,0)
  9786    . . S:$P( X,U,20)>0  @ROOT@("OR D PROVIDER ")=$P(X,U, 20)
  9787   "RTN","PXR PC",169,0)
  9788    . . I $P( X,U,21)'=" " D IMMVIS ($P(X,U,21 ),ROOT)
  9789   "RTN","PXR PC",170,0)
  9790    . . I $P( X,U,22)'=" " D IMMRMR KS($P(X,U, 22),IMM,.R EMARK)
  9791   "RTN","PXR PC",171,0)
  9792    . . I $P( X,U,23)'=" " S @ROOT@ ("WARNING  ACK")=$P(X ,U,23)
  9793   "RTN","PXR PC",172,0)
  9794    . . I $P( X,U,24)>0  S IMMOVERR IDE($P(X,U ,24))="IMM UNIZATION^ "_IMM
  9795   "RTN","PXR PC",173,0)
  9796    . . I $E( TYP,4)="-"  S @ROOT@( "DELETE")= 1
  9797   "RTN","PXR PC",174,0)
  9798    . I $E(TY P,1,2)="SK " D  Q
  9799   "RTN","PXR PC",175,0)
  9800    . . Q:'$L (CODE)
  9801   "RTN","PXR PC",176,0)
  9802    . . S SK= SK+1,ROOT= PXPCEARR_" (""SKIN TE ST"","_SK_ ")"
  9803   "RTN","PXR PC",177,0)
  9804    . . S @RO OT@("TEST" )=CODE
  9805   "RTN","PXR PC",178,0)
  9806    . . S:$L( $P(X,U,5))  @ROOT@("R ESULT")=$P (X,U,5)
  9807   "RTN","PXR PC",179,0)
  9808    . . S:$L( $P(X,U,7))  @ROOT@("R EADING")=$ P(X,U,7)
  9809   "RTN","PXR PC",180,0)
  9810    . . S:$L( $P(X,U,8))  @ROOT@("D /T READ")= $P(X,U,8)
  9811   "RTN","PXR PC",181,0)
  9812    . . S:$L( $P(X,U,9))  @ROOT@("E VENT D/T") =$P(X,U,9)
  9813   "RTN","PXR PC",182,0)
  9814    . . S:$P( X,U,6)>0 @ ROOT@("ENC  PROVIDER" )=$P(X,U,6 )
  9815   "RTN","PXR PC",183,0)
  9816    . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="SKIN  TEST^"_SK
  9817   "RTN","PXR PC",184,0)
  9818    . . I $E( TYP,3)="-"  S @ROOT@( "DELETE")= 1
  9819   "RTN","PXR PC",185,0)
  9820    . I $E(TY P,1,3)="PE D" D  Q
  9821   "RTN","PXR PC",186,0)
  9822    . . Q:'$L (CODE)
  9823   "RTN","PXR PC",187,0)
  9824    . . S PED =PED+1,ROO T=PXPCEARR _"(""PATIE NT ED"","_ PED_")"
  9825   "RTN","PXR PC",188,0)
  9826    . . S @RO OT@("TOPIC ")=CODE
  9827   "RTN","PXR PC",189,0)
  9828    . . S:$L( $P(X,U,5))  @ROOT@("U NDERSTANDI NG")=$P(X, U,5)
  9829   "RTN","PXR PC",190,0)
  9830    . . S:$P( X,U,6)>0 @ ROOT@("ENC  PROVIDER" )=$P(X,U,6 )
  9831   "RTN","PXR PC",191,0)
  9832    . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="PATIE NT ED^"_PE D
  9833   "RTN","PXR PC",192,0)
  9834    . . I $E( TYP,4)="-"  S @ROOT@( "DELETE")= 1
  9835   "RTN","PXR PC",193,0)
  9836    . I $E(TY P,1,2)="HF " D  Q
  9837   "RTN","PXR PC",194,0)
  9838    . . Q:'$L (CODE)
  9839   "RTN","PXR PC",195,0)
  9840    . . S HF= HF+1,ROOT= PXPCEARR_" (""HEALTH  FACTOR""," _HF_")"
  9841   "RTN","PXR PC",196,0)
  9842    . . S @RO OT@("HEALT H FACTOR") =CODE
  9843   "RTN","PXR PC",197,0)
  9844    . . S:$L( $P(X,U,5))  @ROOT@("L EVEL/SEVER ITY")=$P(X ,U,5)
  9845   "RTN","PXR PC",198,0)
  9846    . . S:$P( X,U,6)'>0  $P(X,U,6)= $G(@PXPCEA RR@("PROVI DER",1,"NA ME"))
  9847   "RTN","PXR PC",199,0)
  9848    . . S:$P( X,U,6)>0 @ ROOT@("ENC  PROVIDER" )=$P(X,U,6 )
  9849   "RTN","PXR PC",200,0)
  9850    . . S:$L( $P(X,U,11) ) @ROOT@(" EVENT D/T" )=$P($P(X, U,11),";", 1)
  9851   "RTN","PXR PC",201,0)
  9852    . . S:$L( $P(X,U,11) ) SRC=$P($ P(X,U,11), ";",2)
  9853   "RTN","PXR PC",202,0)
  9854    . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="HEALT H FACTOR^" _HF
  9855   "RTN","PXR PC",203,0)
  9856    . . I $E( TYP,3)="-"  S @ROOT@( "DELETE")= 1
  9857   "RTN","PXR PC",204,0)
  9858    . I $E(TY P,1,3)="XA M" D  Q
  9859   "RTN","PXR PC",205,0)
  9860    . . Q:'$L (CODE)
  9861   "RTN","PXR PC",206,0)
  9862    . . S XAM =XAM+1,ROO T=PXPCEARR _"(""EXAM" ","_XAM_") "
  9863   "RTN","PXR PC",207,0)
  9864    . . S @RO OT@("EXAM" )=CODE
  9865   "RTN","PXR PC",208,0)
  9866    . . S:$L( $P(X,U,5))  @ROOT@("R ESULT")=$P (X,U,5)
  9867   "RTN","PXR PC",209,0)
  9868    . . S:$P( X,U,6)>0 @ ROOT@("ENC  PROVIDER" )=$P(X,U,6 )
  9869   "RTN","PXR PC",210,0)
  9870    . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="EXAM^ "_XAM
  9871   "RTN","PXR PC",211,0)
  9872    . . I $E( TYP,4)="-"  S @ROOT@( "DELETE")= 1
  9873   "RTN","PXR PC",212,0)
  9874    . I $E(TY P,1,3)="TR T" D  Q
  9875   "RTN","PXR PC",213,0)
  9876    . . Q:'$L (CODE)
  9877   "RTN","PXR PC",214,0)
  9878    . . S TRT =TRT+1,ROO T=PXPCEARR _"(""TREAT MENT"","_T RT_")"
  9879   "RTN","PXR PC",215,0)
  9880    . . S @RO OT@("IMMUN ")=CODE
  9881   "RTN","PXR PC",216,0)
  9882    . . S:$L( CAT) @ROOT @("CATEGOR Y")=CAT
  9883   "RTN","PXR PC",217,0)
  9884    . . S:$L( NARR) @ROO T@("NARRAT IVE")=NARR
  9885   "RTN","PXR PC",218,0)
  9886    . . S:$L( $P(X,U,5))  @ROOT@("Q TY")=$P(X, U,5)
  9887   "RTN","PXR PC",219,0)
  9888    . . S:$P( X,U,6)>0 @ ROOT@("ENC  PROVIDER" )=$P(X,U,6 )
  9889   "RTN","PXR PC",220,0)
  9890    . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="TREAT MENT^"_TRT
  9891   "RTN","PXR PC",221,0)
  9892    . . I $E( TYP,4)="-"  S @ROOT@( "DELETE")= 1,@ROOT@(" QTY")=0
  9893   "RTN","PXR PC",222,0)
  9894    . I $E(TY P,1,3)="IC R" D  Q
  9895   "RTN","PXR PC",223,0)
  9896    . . Q:'$L (CODE)
  9897   "RTN","PXR PC",224,0)
  9898    . . S ICR =ICR+1,ROO T=PXPCEARR _"(""IMM C ONTRA/REFU SAL"","_IC R_")"
  9899   "RTN","PXR PC",225,0)
  9900    . . S @RO OT@("CONTR A/REFUSAL" )=CODE
  9901   "RTN","PXR PC",226,0)
  9902    . . I $P( X,U,5)'=""  S @ROOT@( "IMMUN")=$ $TRIM^XLFS TR($P(X,U, 5))
  9903   "RTN","PXR PC",227,0)
  9904    . . I $P( X,U,6)'=""  S @ROOT@( "WARN UNTI L DATE")=$ $TRIM^XLFS TR($P(X,U, 6))
  9905   "RTN","PXR PC",228,0)
  9906    . . I $P( X,U,7)'=""  S @ROOT@( "EVENT D/T ")=$$TRIM^ XLFSTR($P( X,U,7))
  9907   "RTN","PXR PC",229,0)
  9908    . . I $P( X,U,8)'=""  S @ROOT@( "ENC PROVI DER")=$$TR IM^XLFSTR( $P(X,U,8))
  9909   "RTN","PXR PC",230,0)
  9910    . . S:$L( $P(X,U,10) )>0 COMMEN T($P(X,U,1 0))="IMM C ONTRA/REFU SAL^"_ICR
  9911   "RTN","PXR PC",231,0)
  9912    . . I $E( TYP,4)="-"  S @ROOT@( "DELETE")= 1
  9913   "RTN","PXR PC",232,0)
  9914    . I $E(TY P,1,3)="CO M" D  Q
  9915   "RTN","PXR PC",233,0)
  9916    . . Q:'$L (CODE)
  9917   "RTN","PXR PC",234,0)
  9918    . . Q:'$L (CAT)
  9919   "RTN","PXR PC",235,0)
  9920    . . S COM MENTS(CODE )=$P(X,U,3 ,999)
  9921   "RTN","PXR PC",236,0)
  9922    ;Store th e comments
  9923   "RTN","PXR PC",237,0)
  9924    S COM=""
  9925   "RTN","PXR PC",238,0)
  9926    ;F  S COM =$O(COMMEN T(COM)) Q: COM=""  S: $D(COMMENT S(COM)) PX API($P(COM MENT(COM), "^",1),$P( COMMENT(CO M),"^",2), "COMMENT") =COMMENTS( COM)
  9927   "RTN","PXR PC",239,0)
  9928    F  S COM= $O(COMMENT (COM)) Q:C OM=""  D:$ D(COMMENTS (COM))
  9929   "RTN","PXR PC",240,0)
  9930    . I $G(IM MCOMMS(COM ))'="" D
  9931   "RTN","PXR PC",241,0)
  9932    . . I COM MENTS(COM) ="@" S COM MENTS(COM) =""
  9933   "RTN","PXR PC",242,0)
  9934    . . S COM MENTS(COM) =COMMENTS( COM)_$S(CO MMENTS(COM )="":"",1: " ")_IMMCO MMS(COM)
  9935   "RTN","PXR PC",243,0)
  9936    . S @PXPC EARR@($P(C OMMENT(COM ),"^",1),$ P(COMMENT( COM),"^",2 ),"COMMENT ")=COMMENT S(COM)
  9937   "RTN","PXR PC",244,0)
  9938    ;
  9939   "RTN","PXR PC",245,0)
  9940    ;Store th e Remarks  (currently  used by i mmunizatio ns) - PX,2 10
  9941   "RTN","PXR PC",246,0)
  9942    S COM=""
  9943   "RTN","PXR PC",247,0)
  9944    F  S COM= $O(REMARK( COM)) Q:CO M=""  I $D (COMMENTS( COM)) D
  9945   "RTN","PXR PC",248,0)
  9946    . S TYP=$ P(REMARK(C OM),"^",1)
  9947   "RTN","PXR PC",249,0)
  9948    . S NUM=$ P(REMARK(C OM),"^",2)
  9949   "RTN","PXR PC",250,0)
  9950    . S SEQ=$ O(@PXPCEAR R@(TYP,NUM ,"REMARKS" ,""),-1)+1
  9951   "RTN","PXR PC",251,0)
  9952    . S @PXPC EARR@(TYP, NUM,"REMAR KS",SEQ,0) =COMMENTS( COM)
  9953   "RTN","PXR PC",252,0)
  9954    ;
  9955   "RTN","PXR PC",253,0)
  9956    ;Store th e Immuniza tion Overr ide Reason  - PX,215
  9957   "RTN","PXR PC",254,0)
  9958    S COM=""
  9959   "RTN","PXR PC",255,0)
  9960    F  S COM= $O(IMMOVER RIDE(COM))  Q:COM=""   I $G(COMM ENTS(COM)) '="" D
  9961   "RTN","PXR PC",256,0)
  9962    . S TYP=$ P(IMMOVERR IDE(COM)," ^",1)
  9963   "RTN","PXR PC",257,0)
  9964    . S NUM=$ P(IMMOVERR IDE(COM)," ^",2)
  9965   "RTN","PXR PC",258,0)
  9966    . S @PXPC EARR@(TYP, NUM,"OVERR IDE REASON ")=COMMENT S(COM)
  9967   "RTN","PXR PC",259,0)
  9968    ;
  9969   "RTN","PXR PC",260,0)
  9970    S @PXPCEA RR@("ENCOU NTER",1,"E NCOUNTER T YPE")="P"
  9971   "RTN","PXR PC",261,0)
  9972    ;
  9973   "RTN","PXR PC",262,0)
  9974    Q
  9975   "RTN","PXR PC",263,0)
  9976    ;
  9977   "RTN","PXR PC",264,0)
  9978   DATA2PCE(O K,PXPCEARR ,PKG,SRC,P XAVST,PXER ROR) ;
  9979   "RTN","PXR PC",265,0)
  9980    I '($D(PX AVST)#2) S  PXAVST=""
  9981   "RTN","PXR PC",266,0)
  9982    S OK=$$DA TA2PCE^PXA I(PXPCEARR ,PKG,SRC,. PXAVST,"", "",.PXERRO R,"","","" )
  9983   "RTN","PXR PC",267,0)
  9984    Q
  9985   "RTN","PXR PC",268,0)
  9986    ;
  9987   "RTN","PXR PC",269,0)
  9988   IMMSRC(IMM IS) ; Retu rns Event  Info Sourc e IEN
  9989   "RTN","PXR PC",270,0)
  9990    N IMMISHL ,IMMISIEN, X
  9991   "RTN","PXR PC",271,0)
  9992    S IMMISHL =$P(IMMIS, ";",1)
  9993   "RTN","PXR PC",272,0)
  9994    S IMMISIE N=$P(IMMIS ,";",2)
  9995   "RTN","PXR PC",273,0)
  9996    ; Look up  the value  in the "H " Cross-re ference
  9997   "RTN","PXR PC",274,0)
  9998    I 'IMMISI EN D
  9999   "RTN","PXR PC",275,0)
  10000    . S IMMIS IEN=$$FIND 1^DIC(920. 1,,,IMMISH L,"H",,"IM MISERR")
  10001   "RTN","PXR PC",276,0)
  10002    Q IMMISIE N
  10003   "RTN","PXR PC",277,0)
  10004    ;
  10005   "RTN","PXR PC",278,0)
  10006   IMMROUTE(I MMRT) ; Re turns Rout e IEN
  10007   "RTN","PXR PC",279,0)
  10008    N IMMRTHL ,IMMRTIEN, IMMRTNM,X
  10009   "RTN","PXR PC",280,0)
  10010    S IMMRTNM =$P(IMMRT, ";",1)
  10011   "RTN","PXR PC",281,0)
  10012    S IMMRTHL =$P(IMMRT, ";",2)
  10013   "RTN","PXR PC",282,0)
  10014    S IMMRTIE N=$P(IMMRT ,";",3)
  10015   "RTN","PXR PC",283,0)
  10016    I 'IMMRTI EN,IMMRTHL '="" D
  10017   "RTN","PXR PC",284,0)
  10018    . S IMMRT IEN=$$FIND 1^DIC(920. 2,,,IMMRTH L,"H",,"IM MRTERR")
  10019   "RTN","PXR PC",285,0)
  10020    I 'IMMRTI EN,IMMRTNM '="" D
  10021   "RTN","PXR PC",286,0)
  10022    . S IMMRT IEN=$$FIND 1^DIC(920. 2,,,IMMRTN M,"B",,"IM MRTERR")
  10023   "RTN","PXR PC",287,0)
  10024    Q IMMRTIE N
  10025   "RTN","PXR PC",288,0)
  10026    ;
  10027   "RTN","PXR PC",289,0)
  10028   IMMLOC(IMM AL) ; Retu rns Anatom ic Locatio n IEN
  10029   "RTN","PXR PC",290,0)
  10030    N IMMALHL ,IMMALIEN, IMMALNM,X
  10031   "RTN","PXR PC",291,0)
  10032    S IMMALNM =$P(IMMAL, ";",1)
  10033   "RTN","PXR PC",292,0)
  10034    S IMMALHL =$P(IMMAL, ";",2)
  10035   "RTN","PXR PC",293,0)
  10036    S IMMALIE N=$P(IMMAL ,";",3)
  10037   "RTN","PXR PC",294,0)
  10038    I 'IMMALI EN,IMMALHL '="" D
  10039   "RTN","PXR PC",295,0)
  10040    . S IMMAL IEN=$$FIND 1^DIC(920. 3,,,IMMALH L,"B",,"IM MALERR")
  10041   "RTN","PXR PC",296,0)
  10042    I 'IMMALI EN,IMMALNM '="" D
  10043   "RTN","PXR PC",297,0)
  10044    . S IMMAL IEN=$$FIND 1^DIC(920. 3,,,IMMALN M,"B",,"IM MALERR")
  10045   "RTN","PXR PC",298,0)
  10046    Q IMMALIE N
  10047   "RTN","PXR PC",299,0)
  10048    ;
  10049   "RTN","PXR PC",300,0)
  10050   IMMLOT(IMM LOT,IMMMAN UF,IMMEXPD T) ; Retur ns Lot_IEN ^Comment
  10051   "RTN","PXR PC",301,0)
  10052    N IMMCOMM ,IMMLOTIEN ,IMMLOTNM, X
  10053   "RTN","PXR PC",302,0)
  10054    S IMMLOTN M=$P(IMMLO T,";",1)
  10055   "RTN","PXR PC",303,0)
  10056    S IMMLOTI EN=$P(IMML OT,";",2)
  10057   "RTN","PXR PC",304,0)
  10058    ;
  10059   "RTN","PXR PC",305,0)
  10060    I IMMLOTI EN Q IMMLO TIEN
  10061   "RTN","PXR PC",306,0)
  10062    ;
  10063   "RTN","PXR PC",307,0)
  10064    ; If the  Lot Number , Manufact urer and E xpiration  Date are a ll specifi ed,
  10065   "RTN","PXR PC",308,0)
  10066    ; then fi nd an entr y matching  all three  values in  File 9999 999.41 (IM MUNIZATION  LOT)
  10067   "RTN","PXR PC",309,0)
  10068    ; If we d on't find  a match, t hen add th e fields t o the Comm ent.
  10069   "RTN","PXR PC",310,0)
  10070    ; For now , we will  not receiv e the Expi ration Dat e from Wal greens, so  we always  update th e Comment.
  10071   "RTN","PXR PC",311,0)
  10072    S IMMCOMM =""
  10073   "RTN","PXR PC",312,0)
  10074    S:IMMLOTN M'="" IMMC OMM=IMMCOM M_$S(IMMCO MM="":"",1 :" ")_"Lot #: "_IMMLO TNM
  10075   "RTN","PXR PC",313,0)
  10076    S:IMMMANU F'="" IMMC OMM=IMMCOM M_$S(IMMCO MM="":"",1 :" ")_"Mfr : "_IMMMAN UF
  10077   "RTN","PXR PC",314,0)
  10078    S:IMMEXPD T'="" IMMC OMM=IMMCOM M_$S(IMMCO MM="":"",1 :" ")_"Exp iration Da te: "_IMME XPDT
  10079   "RTN","PXR PC",315,0)
  10080    Q "^"_IMM COMM
  10081   "RTN","PXR PC",316,0)
  10082    ;
  10083   "RTN","PXR PC",317,0)
  10084   IMMVIS(IMM VISMULT,RO OT) ; Sets  ROOT's VI S multiple
  10085   "RTN","PXR PC",318,0)
  10086    N IMMVIS, IMMVISDT,I MMVISENTRY ,PXSEQ,PXX ,X
  10087   "RTN","PXR PC",319,0)
  10088    S PXSEQ=0
  10089   "RTN","PXR PC",320,0)
  10090    F PXX=1:1 :$L(IMMVIS MULT,";")  D
  10091   "RTN","PXR PC",321,0)
  10092    . S IMMVI SENTRY=$$T RIM^XLFSTR ($P(IMMVIS MULT,";",P XX))
  10093   "RTN","PXR PC",322,0)
  10094    . S IMMVI S=$P(IMMVI SENTRY,"/" ,1)
  10095   "RTN","PXR PC",323,0)
  10096    . I 'IMMV IS Q
  10097   "RTN","PXR PC",324,0)
  10098    . S IMMVI SDT=$P(IMM VISENTRY," /",2)
  10099   "RTN","PXR PC",325,0)
  10100    . I IMMVI SDT S IMMV IS=IMMVIS_ U_IMMVISDT
  10101   "RTN","PXR PC",326,0)
  10102    . S PXSEQ =PXSEQ+1
  10103   "RTN","PXR PC",327,0)
  10104    . S @ROOT @("VIS",PX SEQ,0)=IMM VIS
  10105   "RTN","PXR PC",328,0)
  10106    Q
  10107   "RTN","PXR PC",329,0)
  10108    ;
  10109   "RTN","PXR PC",330,0)
  10110   IMMRMRKS(I MMREMARKS, IMMNUM,REM ARK) ; Set s REMARK a rray
  10111   "RTN","PXR PC",331,0)
  10112    N PXEND,P XSTART,PXX ,X
  10113   "RTN","PXR PC",332,0)
  10114    S PXSTART =$P(IMMREM ARKS,";",1 )
  10115   "RTN","PXR PC",333,0)
  10116    S PXEND=$ P(IMMREMAR KS,";",2)
  10117   "RTN","PXR PC",334,0)
  10118    I ('PXSTA RT)!('PXEN D)!(PXEND< PXSTART) Q
  10119   "RTN","PXR PC",335,0)
  10120    F PXX=PXS TART:1:PXE ND D
  10121   "RTN","PXR PC",336,0)
  10122    . S REMAR K(PXX)="IM MUNIZATION ^"_IMMNUM
  10123   "RTN","PXR PC",337,0)
  10124    Q
  10125   "RTN","PXR PC",338,0)
  10126    ;
  10127   "RTN","PXR PC",339,0)
  10128   IMMDSG(IMM DSG) ;
  10129   "RTN","PXR PC",340,0)
  10130    N IMMDOSE ,IMMUNIT,I MMUNITIEN, IMMDOSEV,I MMUNERR,X
  10131   "RTN","PXR PC",341,0)
  10132    S IMMDSG= $$TRIM^XLF STR(IMMDSG )
  10133   "RTN","PXR PC",342,0)
  10134    I IMMDSG= "" Q ""
  10135   "RTN","PXR PC",343,0)
  10136    S IMMDOSE =$P(IMMDSG ,";",1)
  10137   "RTN","PXR PC",344,0)
  10138    S IMMUNIT =$P(IMMDSG ,";",2)
  10139   "RTN","PXR PC",345,0)
  10140    S IMMUNIT IEN=$P(IMM DSG,";",3)
  10141   "RTN","PXR PC",346,0)
  10142    I IMMDSG[ " ",IMMDSG '[";" D  ; Remove thi s DO block  when VLER  DAS start s using "; " between  dose and u nits
  10143   "RTN","PXR PC",347,0)
  10144    . S IMMDO SE=$P(IMMD SG," ",1)
  10145   "RTN","PXR PC",348,0)
  10146    . S IMMUN IT=$P(IMMD SG," ",2)
  10147   "RTN","PXR PC",349,0)
  10148    ;
  10149   "RTN","PXR PC",350,0)
  10150    I IMMDOSE ="" Q ""
  10151   "RTN","PXR PC",351,0)
  10152    ;
  10153   "RTN","PXR PC",352,0)
  10154    I IMMUNIT '="",'IMMU NITIEN D
  10155   "RTN","PXR PC",353,0)
  10156    . N UCUMD ATA
  10157   "RTN","PXR PC",354,0)
  10158    . D UCUMD ATA^LEXMUC UM(IMMUNIT ,.UCUMDATA )  ; ICR 6 225
  10159   "RTN","PXR PC",355,0)
  10160    . S IMMUN ITIEN=$O(U CUMDATA(0) )
  10161   "RTN","PXR PC",356,0)
  10162    D CHK^DIE (9000010.1 1,1312,,IM MDOSE,.IMM DOSEV,"IMM UNERR")
  10163   "RTN","PXR PC",357,0)
  10164    I IMMUNIT IEN,IMMDOS EV'="^" Q  IMMDOSEV_U _IMMUNITIE N
  10165   "RTN","PXR PC",358,0)
  10166    ;
  10167   "RTN","PXR PC",359,0)
  10168    Q U_U_"Do sage: "_IM MDOSE_" "_ IMMUNIT
  10169   "RTN","PXV NDC")
  10170   0^32^B1736 379^n/a
  10171   "RTN","PXV NDC",1,0)
  10172   PXVNDC ;BI R/ADM - UT ILITIES RE LATED TO N DC ;03/17/ 2016
  10173   "RTN","PXV NDC",2,0)
  10174    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  10175   "RTN","PXV NDC",3,0)
  10176    ;
  10177   "RTN","PXV NDC",4,0)
  10178    Q
  10179   "RTN","PXV NDC",5,0)
  10180   NDC(PXVZ)  ; called f rom input  transform  and execut able help  on field # .18 in fil e #9999999 .41
  10181   "RTN","PXV NDC",6,0)
  10182    N PXNDC,P XVIN,PXVDC ,PXVX,PXVL ST,PXVOUT
  10183   "RTN","PXV NDC",7,0)
  10184    S (PXNDC, PXVOUT)=0, PXVIN="",P XVLST="PXV LST"
  10185   "RTN","PXV NDC",8,0)
  10186    S PXVX=$S ($G(DIY):D IY,1:PXVZ)
  10187   "RTN","PXV NDC",9,0)
  10188    S:$E(PXVZ )="`" PXVX =$E(PXVZ,2 ,99)
  10189   "RTN","PXV NDC",10,0)
  10190    I +$G(PXV X) D  K:$D (PXVLST) ^ TMP($J,PXV LST) I PXV OUT Q PXND C
  10191   "RTN","PXV NDC",11,0)
  10192    .D ALL^PS N5067(PXVX ,,DT,PXVLS T) I $P($G (^TMP($J,P XVLST,0)), "^")=-1 S  PXVOUT=1 Q
  10193   "RTN","PXV NDC",12,0)
  10194    .S PXVIN= $P($G(^TMP ($J,PXVLST ,PXVX,7)), "^")
  10195   "RTN","PXV NDC",13,0)
  10196    I PXVIN=" "!(PXVIN>D T)&($P($$D RGCLS^PSNA PIS(PXVX), "^",2)="IM 000") S PX NDC=1
  10197   "RTN","PXV NDC",14,0)
  10198    Q PXNDC
  10199   "RTN","PXV NDC",15,0)
  10200    ;
  10201   "RTN","PXV NDC",16,0)
  10202   NDCOUT(PXV N) ; outpu t transfor m on NDC C ODE (VA) f ield (#.18 ) in file  #9999999.4 1
  10203   "RTN","PXV NDC",17,0)
  10204    N PXVARAY ,PXVOUT,PX V7
  10205   "RTN","PXV NDC",18,0)
  10206    I PXVN=""  S PXVOUT= "" Q PXVOU T
  10207   "RTN","PXV NDC",19,0)
  10208    D CIRN^PS NAPIS(PXVN ,.PXVARAY)
  10209   "RTN","PXV NDC",20,0)
  10210    S PXV7=$G (PXVARAY(7 ))
  10211   "RTN","PXV NDC",21,0)
  10212    S PXVOUT= $P(PXV7,"^ ")_"   "_$ P(PXV7,"^" ,3)
  10213   "RTN","PXV NDC",22,0)
  10214    Q PXVOUT
  10215   "RTN","PXV NDC",23,0)
  10216    ;
  10217   "RTN","PXV NDC",24,0)
  10218   P01 ; inpu t transfor m logic fo r field #. 18 in file  9999999.4 1
  10219   "RTN","PXV NDC",25,0)
  10220    N SCR
  10221   "RTN","PXV NDC",26,0)
  10222    S SCR="I  $$NDC^PXVN DC(X)"
  10223   "RTN","PXV NDC",27,0)
  10224    D INTRAN^ PSNAPIS(SC R)
  10225   "RTN","PXV NDC",28,0)
  10226    Q
  10227   "RTN","PXV NDC",29,0)
  10228   QUEST ; "? " or "??"  help for f ield #.18  in file 99 99999.41
  10229   "RTN","PXV NDC",30,0)
  10230    N SCR
  10231   "RTN","PXV NDC",31,0)
  10232    S SCR="I  $$NDC^PXVN DC(X)"
  10233   "RTN","PXV NDC",32,0)
  10234    D QLIST^P SNAPIS(SCR )
  10235   "RTN","PXV NDC",33,0)
  10236    Q
  10237   "RTN","PXV P215")
  10238   0^^B340392 79^n/a
  10239   "RTN","PXV P215",1,0)
  10240   PXVP215 ;B PFO/LMT -  PX*1*215 K IDS Routin e ;04/05/2 016
  10241   "RTN","PXV P215",2,0)
  10242    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  10243   "RTN","PXV P215",3,0)
  10244    ;
  10245   "RTN","PXV P215",4,0)
  10246   POST ; KID S Post ins tall for P X*1*215
  10247   "RTN","PXV P215",5,0)
  10248    D BMES("* ** Post in stall star ted ***")
  10249   "RTN","PXV P215",6,0)
  10250    ;
  10251   "RTN","PXV P215",7,0)
  10252    S DIU=900 0010.123,D IU(0)="S"  D EN^DIU2  K DIU ; De lete Codin g System m ultiple fr om file #9 000010.12
  10253   "RTN","PXV P215",8,0)
  10254    D CODEMAP  ; Generat e PCE Code  Mapping R eport
  10255   "RTN","PXV P215",9,0)
  10256    D LOAD920 6 ; Popula te data fo r #920.6
  10257   "RTN","PXV P215",10,0 )
  10258    ;
  10259   "RTN","PXV P215",11,0 )
  10260    D BMES("* ** Post in stall comp leted ***" )
  10261   "RTN","PXV P215",12,0 )
  10262    Q
  10263   "RTN","PXV P215",13,0 )
  10264    ;
  10265   "RTN","PXV P215",14,0 )
  10266    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- -
  10267   "RTN","PXV P215",15,0 )
  10268   CODEMAP ;  Generate P CE Code Ma pping Repo rt
  10269   "RTN","PXV P215",16,0 )
  10270    ;
  10271   "RTN","PXV P215",17,0 )
  10272    N PXERRLN ,PXERRNUM, PXERRTXT,P XFROM,PXFR OMEN,PXIEN ,PXIMM,PXI NCLUDE,PXI NST,PXINST NAME,PXINS TNUM
  10273   "RTN","PXV P215",18,0 )
  10274    N PXINSTR ,PXLINE,PX MGROUP,PXM SGSUB,PXMS GTO,PXNODE ,PXREMMGIE N,PXTO,PXT OEN,XMERR
  10275   "RTN","PXV P215",19,0 )
  10276    ;
  10277   "RTN","PXV P215",20,0 )
  10278    D BMES("* ** Generat ing PCE CO DE MAPPING  Report ** *")
  10279   "RTN","PXV P215",21,0 )
  10280    ;
  10281   "RTN","PXV P215",22,0 )
  10282    K ^TMP("P X215PCM",$ J)
  10283   "RTN","PXV P215",23,0 )
  10284    ;
  10285   "RTN","PXV P215",24,0 )
  10286    S PXINST= $$KSP^XUPA RAM("INST" )
  10287   "RTN","PXV P215",25,0 )
  10288    S PXINSTN AME=$$NAME ^XUAF4(PXI NST)
  10289   "RTN","PXV P215",26,0 )
  10290    S PXINSTN UM=$$STA^X UAF4(PXINS T)
  10291   "RTN","PXV P215",27,0 )
  10292    ;
  10293   "RTN","PXV P215",28,0 )
  10294    S PXLINE= 10 ; Start  at #10, a s the prea mble part  of the mes sage will  be in line s 1-10
  10295   "RTN","PXV P215",29,0 )
  10296    ;
  10297   "RTN","PXV P215",30,0 )
  10298    S PXIEN=0
  10299   "RTN","PXV P215",31,0 )
  10300    F  S PXIE N=$O(^PXD( 811.1,PXIE N)) Q:'PXI EN  D
  10301   "RTN","PXV P215",32,0 )
  10302    . S PXNOD E=$G(^PXD( 811.1,PXIE N,0))
  10303   "RTN","PXV P215",33,0 )
  10304    . ;
  10305   "RTN","PXV P215",34,0 )
  10306    . I '$P(P XNODE,U,5)  Q
  10307   "RTN","PXV P215",35,0 )
  10308    . ;
  10309   "RTN","PXV P215",36,0 )
  10310    . S PXFRO M=$P(PXNOD E,U,3)
  10311   "RTN","PXV P215",37,0 )
  10312    . S PXINC LUDE=0
  10313   "RTN","PXV P215",38,0 )
  10314    . I PXFRO M="CPT" S  PXINCLUDE= 1
  10315   "RTN","PXV P215",39,0 )
  10316    . I PXFRO M="IMM" D
  10317   "RTN","PXV P215",40,0 )
  10318    . . S PXI MM=+$P(PXN ODE,U,1)
  10319   "RTN","PXV P215",41,0 )
  10320    . . I $$I MMSTAT^PXA PIIM(PXIMM )'="A" S P XINCLUDE=1
  10321   "RTN","PXV P215",42,0 )
  10322    . ;
  10323   "RTN","PXV P215",43,0 )
  10324    . I 'PXIN CLUDE Q
  10325   "RTN","PXV P215",44,0 )
  10326    . ;
  10327   "RTN","PXV P215",45,0 )
  10328    . S PXFRO MEN=+$P(PX NODE,U,1)
  10329   "RTN","PXV P215",46,0 )
  10330    . S PXTOE N=+$P(PXNO DE,U,2)
  10331   "RTN","PXV P215",47,0 )
  10332    . S PXTO= $P(PXNODE, U,4)
  10333   "RTN","PXV P215",48,0 )
  10334    . I PXFRO M="IMM" S  PXFROMEN=$ P($G(^AUTT IMM(PXFROM EN,0)),U,1 )
  10335   "RTN","PXV P215",49,0 )
  10336    . I PXFRO M="CPT" S  PXFROMEN=$ $CODEC^ICP TCOD(PXFRO MEN)
  10337   "RTN","PXV P215",50,0 )
  10338    . I (PXFR OMEN="")!( PXFROMEN=- 1) Q
  10339   "RTN","PXV P215",51,0 )
  10340    . I PXTO= "IMM" S PX TOEN=$P($G (^AUTTIMM( PXTOEN,0)) ,U,1)
  10341   "RTN","PXV P215",52,0 )
  10342    . I PXTO= "CPT" S PX TOEN=$$COD EC^ICPTCOD (PXTOEN)
  10343   "RTN","PXV P215",53,0 )
  10344    . S ^TMP( "PX215PCM" ,$J,$$LINE ())=PXINST NUM_U_PXIN STNAME_U_P XFROM_U_PX FROMEN_U_P XTO_U_PXTO EN
  10345   "RTN","PXV P215",54,0 )
  10346    ;
  10347   "RTN","PXV P215",55,0 )
  10348    I '$D(^TM P("PX215PC M",$J)) D   Q
  10349   "RTN","PXV P215",56,0 )
  10350    . D MES(" No entries  to report .")
  10351   "RTN","PXV P215",57,0 )
  10352    ;
  10353   "RTN","PXV P215",58,0 )
  10354    S ^TMP("P X215PCM",$ J,1)="This  report wa s generate d by the P X*1*215 Po st-Install . It conta ins a list  of"
  10355   "RTN","PXV P215",59,0 )
  10356    S ^TMP("P X215PCM",$ J,3)="entr ies from t he PCE COD E MAPPING  file (#811 .1) for yo ur review. "
  10357   "RTN","PXV P215",60,0 )
  10358    S ^TMP("P X215PCM",$ J,4)=" "
  10359   "RTN","PXV P215",61,0 )
  10360    S ^TMP("P X215PCM",$ J,5)="This  report li sts entrie s where bo th: "
  10361   "RTN","PXV P215",62,0 )
  10362    S ^TMP("P X215PCM",$ J,6)="   1 . The FROM  field (#. 03) equals  ""CPT"" O R the immu nization i n the File  Entry"
  10363   "RTN","PXV P215",63,0 )
  10364    S ^TMP("P X215PCM",$ J,7)="       field (# .01) is in active."
  10365   "RTN","PXV P215",64,0 )
  10366    S ^TMP("P X215PCM",$ J,8)="   2 . And the  ON/OFF FLA G field (# .05) equal s ""ON""."
  10367   "RTN","PXV P215",65,0 )
  10368    S ^TMP("P X215PCM",$ J,9)=" "
  10369   "RTN","PXV P215",66,0 )
  10370    S ^TMP("P X215PCM",$ J,10)="Sta tion #^Sta tion Name^ From^From  Code^To^To  Code"
  10371   "RTN","PXV P215",67,0 )
  10372    ;
  10373   "RTN","PXV P215",68,0 )
  10374    S PXMSGSU B=PXINSTNU M_" PCE CO DE MAPPING  DATA FOR  REVIEW"
  10375   "RTN","PXV P215",69,0 )
  10376    S PXMSGTO (DUZ)=""
  10377   "RTN","PXV P215",70,0 )
  10378    S PXREMMG IEN=$$GET1 ^DIQ(800,1 _",",3)
  10379   "RTN","PXV P215",71,0 )
  10380    I PXREMMG IEN'="" D
  10381   "RTN","PXV P215",72,0 )
  10382    . S PXMGR OUP="G."_$ $GET1^DIQ( 3.8,PXREMM GIEN_",",. 01)
  10383   "RTN","PXV P215",73,0 )
  10384    . S PXMSG TO(PXMGROU P)=""
  10385   "RTN","PXV P215",74,0 )
  10386    I $$PROD^ XUPROD(),$ G(DUZ("AG" ))="V" D
  10387   "RTN","PXV P215",75,0 )
  10388    . S PXMSG TO("TEITEL BAUM.LEVI@ FORUM.VA.G OV")=""
  10389   "RTN","PXV P215",76,0 )
  10390    . S PXMSG TO("SILVER MAN.ROBERT @FORUM.VA. GOV")=""
  10391   "RTN","PXV P215",77,0 )
  10392    . S PXMSG TO("
P II                  ")=""
  10393   "RTN","PXV P215",78,0 )
  10394    S PXINSTR ("FROM")=" PX*1*215 P OST-INSTAL L"
  10395   "RTN","PXV P215",79,0 )
  10396    S PXINSTR ("ADDR FLA GS")="R"
  10397   "RTN","PXV P215",80,0 )
  10398    D SENDMSG ^XMXAPI(DU Z,PXMSGSUB ,"^TMP(""P X215PCM"", $J)",.PXMS GTO,.PXINS TR,.PXMSGN UM)
  10399   "RTN","PXV P215",81,0 )
  10400    D MES("Em ailed repo rt message  (#"_$G(PX MSGNUM)_") ")
  10401   "RTN","PXV P215",82,0 )
  10402    I $G(XMER R),$D(^TMP ("XMERR",$ J)) D
  10403   "RTN","PXV P215",83,0 )
  10404    . D MES(" The follow ing errors  occurred  while send ing the em ail:")
  10405   "RTN","PXV P215",84,0 )
  10406    . S PXERR NUM=0
  10407   "RTN","PXV P215",85,0 )
  10408    . F  S PX ERRNUM=$O( ^TMP("XMER R",$J,PXER RNUM)) Q:' PXERRNUM   D
  10409   "RTN","PXV P215",86,0 )
  10410    . . S PXE RRTXT="  " _PXERRNUM_ ". "
  10411   "RTN","PXV P215",87,0 )
  10412    . . S PXE RRLN=0
  10413   "RTN","PXV P215",88,0 )
  10414    . . F  S  PXERRLN=$O (^TMP("XME RR",$J,PXE RRNUM,"TEX T",PXERRLN )) Q:'PXER RLN  D
  10415   "RTN","PXV P215",89,0 )
  10416    . . . S P XERRTXT=PX ERRTXT_$G( ^TMP("XMER R",$J,PXER RNUM,"TEXT ",PXERRLN) )
  10417   "RTN","PXV P215",90,0 )
  10418    . . . D M ES(PXERRTX T)
  10419   "RTN","PXV P215",91,0 )
  10420    . . . S P XERRTXT="      "
  10421   "RTN","PXV P215",92,0 )
  10422    ;
  10423   "RTN","PXV P215",93,0 )
  10424    K ^TMP("P X215PCM",$ J)
  10425   "RTN","PXV P215",94,0 )
  10426    ;
  10427   "RTN","PXV P215",95,0 )
  10428    Q
  10429   "RTN","PXV P215",96,0 )
  10430    ;
  10431   "RTN","PXV P215",97,0 )
  10432   LINE() ;
  10433   "RTN","PXV P215",98,0 )
  10434    S PXLINE= PXLINE+1
  10435   "RTN","PXV P215",99,0 )
  10436    Q PXLINE
  10437   "RTN","PXV P215",100, 0)
  10438    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- -----
  10439   "RTN","PXV P215",101, 0)
  10440    ;
  10441   "RTN","PXV P215",102, 0)
  10442   LOAD9206 ;  Populate  data for # 920.6
  10443   "RTN","PXV P215",103, 0)
  10444    ;
  10445   "RTN","PXV P215",104, 0)
  10446    N PXERRMS G,PXFDA,PX I,PXIENS,P XROUTE,PXR OUTENM,PXR OUTES,PXSI TE,PXSITEH L,PXSITES
  10447   "RTN","PXV P215",105, 0)
  10448    ;
  10449   "RTN","PXV P215",106, 0)
  10450    D BMES("* ** Populat ing data f or #920.6  ***")
  10451   "RTN","PXV P215",107, 0)
  10452    ;
  10453   "RTN","PXV P215",108, 0)
  10454    I $O(^PXV (920.6,0))  D  Q
  10455   "RTN","PXV P215",109, 0)
  10456    . D MES(" Data alrea dy populat ed... no n eed to pop ulate agai n.")
  10457   "RTN","PXV P215",110, 0)
  10458    ;
  10459   "RTN","PXV P215",111, 0)
  10460    S PXROUTE S("INTRADE RMAL")="LA ^LLFA^LT^R A^RLFA^RT"
  10461   "RTN","PXV P215",112, 0)
  10462    S PXROUTE S("PERCUTA NEOUS")="L A^LLFA^LT^ RA^RLFA^RT "
  10463   "RTN","PXV P215",113, 0)
  10464    S PXROUTE S("SUBCUTA NEOUS")="L A^LLFA^LT^ RA^RLFA^RT "
  10465   "RTN","PXV P215",114, 0)
  10466    S PXROUTE S("INTRAMU SCULAR")=" LD^LG^LVL^ RD^RG^RVL^ RVG^LVG"
  10467   "RTN","PXV P215",115, 0)
  10468    S PXROUTE S("NASAL") ="BN^LN^RN "
  10469   "RTN","PXV P215",116, 0)
  10470    S PXROUTE S("ORAL")= ""
  10471   "RTN","PXV P215",117, 0)
  10472    ;
  10473   "RTN","PXV P215",118, 0)
  10474    S PXROUTE NM=""
  10475   "RTN","PXV P215",119, 0)
  10476    F  S PXRO UTENM=$O(P XROUTES(PX ROUTENM))  Q:PXROUTEN M=""  D
  10477   "RTN","PXV P215",120, 0)
  10478    . K PXFDA ,PXERRMSG, PXIENS
  10479   "RTN","PXV P215",121, 0)
  10480    . D CLEAN ^DILF
  10481   "RTN","PXV P215",122, 0)
  10482    . ;
  10483   "RTN","PXV P215",123, 0)
  10484    . S PXROU TE=$O(^PXV (920.2,"B" ,PXROUTENM ,0))
  10485   "RTN","PXV P215",124, 0)
  10486    . I 'PXRO UTE D  Q
  10487   "RTN","PXV P215",125, 0)
  10488    . . D MES ("Can't ad d mappings  for route  '"_PXROUT ENM_"', as  no #920.2  entry was  found for  it.")
  10489   "RTN","PXV P215",126, 0)
  10490    . ;
  10491   "RTN","PXV P215",127, 0)
  10492    . S PXFDA (1,920.6," ?+1,",.01) =PXROUTE
  10493   "RTN","PXV P215",128, 0)
  10494    . S PXIEN S(1)=PXROU TE
  10495   "RTN","PXV P215",129, 0)
  10496    . ;
  10497   "RTN","PXV P215",130, 0)
  10498    . S PXSIT ES=$G(PXRO UTES(PXROU TENM))
  10499   "RTN","PXV P215",131, 0)
  10500    . F PXI=1 :1 S PXSIT EHL=$P(PXS ITES,U,PXI ) Q:PXSITE HL=""  D
  10501   "RTN","PXV P215",132, 0)
  10502    . . S PXS ITE=$O(^PX V(920.3,"B ",PXSITEHL ,0))
  10503   "RTN","PXV P215",133, 0)
  10504    . . I 'PX SITE D  Q
  10505   "RTN","PXV P215",134, 0)
  10506    . . . D M ES("Can't  add site ' "_PXSITEHL _"', as no  #920.3 en try was fo und for it .")
  10507   "RTN","PXV P215",135, 0)
  10508    . . ;
  10509   "RTN","PXV P215",136, 0)
  10510    . . S PXF DA(1,920.6 1,"?+"_(PX I+1)_",?+1 ,",.01)=PX SITE
  10511   "RTN","PXV P215",137, 0)
  10512    . ;
  10513   "RTN","PXV P215",138, 0)
  10514    . D UPDAT E^DIE(""," PXFDA(1)", "PXIENS")
  10515   "RTN","PXV P215",139, 0)
  10516    . I $D(^T MP("DIERR" ,$J)) D
  10517   "RTN","PXV P215",140, 0)
  10518    . . D MES ("The foll owing erro rs occurre d:")
  10519   "RTN","PXV P215",141, 0)
  10520    . . D MSG ^DIALOG("A E",.PXERRM SG)
  10521   "RTN","PXV P215",142, 0)
  10522    . . D MES ^XPDUTL(.P XERRMSG)
  10523   "RTN","PXV P215",143, 0)
  10524    . ;
  10525   "RTN","PXV P215",144, 0)
  10526    . K PXFDA ,PXERRMSG, PXIENS
  10527   "RTN","PXV P215",145, 0)
  10528    . D CLEAN ^DILF
  10529   "RTN","PXV P215",146, 0)
  10530    ;
  10531   "RTN","PXV P215",147, 0)
  10532    Q
  10533   "RTN","PXV P215",148, 0)
  10534    ;
  10535   "RTN","PXV P215",149, 0)
  10536    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- -----
  10537   "RTN","PXV P215",150, 0)
  10538    ;
  10539   "RTN","PXV P215",151, 0)
  10540   BMES(STR)  ;
  10541   "RTN","PXV P215",152, 0)
  10542    ; Write s tring
  10543   "RTN","PXV P215",153, 0)
  10544    D BMES^XP DUTL($$TRI M^XLFSTR($ $CJ^XLFSTR (STR,$G(IO M,80)),"R" ," "))
  10545   "RTN","PXV P215",154, 0)
  10546    Q
  10547   "RTN","PXV P215",155, 0)
  10548   MES(STR) ;
  10549   "RTN","PXV P215",156, 0)
  10550    ; Write s tring
  10551   "RTN","PXV P215",157, 0)
  10552    D MES^XPD UTL($$TRIM ^XLFSTR($$ CJ^XLFSTR( STR,$G(IOM ,80)),"R", " "))
  10553   "RTN","PXV P215",158, 0)
  10554    Q
  10555   "RTN","PXV RESP")
  10556   0^34^B3810 590^n/a
  10557   "RTN","PXV RESP",1,0)
  10558   PXVRESP ;B IR/ADM - V IMM DEFAUL T RESPONSE  FILE UTIL ITIES ;04/ 11/2016
  10559   "RTN","PXV RESP",2,0)
  10560    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  10561   "RTN","PXV RESP",3,0)
  10562    ;
  10563   "RTN","PXV RESP",4,0)
  10564    Q
  10565   "RTN","PXV RESP",5,0)
  10566   DEF ; edit  immunizat ion defaul t response s file
  10567   "RTN","PXV RESP",6,0)
  10568    N PXVDIV, PXVHD1,PXV HDR,PXVN,P XVNAME,PXV NUM,PXVOUT
  10569   "RTN","PXV RESP",7,0)
  10570    S PXVOUT= 0,(DIDEL,D LAYGO)=920 .05
  10571   "RTN","PXV RESP",8,0)
  10572    S PXVHD1= "Enter/Edi t Immuniza tion Defau lt Respons es"
  10573   "RTN","PXV RESP",9,0)
  10574    W @IOF,!, ?10,PXVHD1 ,!
  10575   "RTN","PXV RESP",10,0 )
  10576    K DIC S D IC="^PXV(9 20.05,",DI C(0)="AEML Z",DIC("A" )="Select  Facility:  " D ^DIC
  10577   "RTN","PXV RESP",11,0 )
  10578    K DIC I $ D(DTOUT)!$ D(DUOUT)!( X="") S PX VOUT=1 D E ND Q
  10579   "RTN","PXV RESP",12,0 )
  10580    S PXVDIV= +Y,PXVN=+Y (0),PXVNAM E=Y(0,0),P XVNUM=$$GE T1^DIQ(4,P XVN,99),PX VHDR="Faci lity: "_PX VNAME_"  ( "_PXVNUM_" )"
  10581   "RTN","PXV RESP",13,0 )
  10582    W @IOF,!, ?10,PXVHD1 ,!!,PXVHDR ,!
  10583   "RTN","PXV RESP",14,0 )
  10584    S DA=PXVD IV,DIE=920 .05,DR="1" ,DR(2,920. 051)=".01; 1302;1303; 1312;1313; 81101;" D  ^DIE I $D( Y) D END Q
  10585   "RTN","PXV RESP",15,0 )
  10586   END K DA,D IE,DIC,DID EL,DLAYGO, DR,DTOUT,D UOUT,X,Y
  10587   "RTN","PXV RESP",16,0 )
  10588    Q
  10589   "RTN","PXV RESP",17,0 )
  10590    ;
  10591   "RTN","PXV RESP",18,0 )
  10592   INST(PXVIS ) ; return s facility  ien in fi le #920.05  related t o this imm unization
  10593   "RTN","PXV RESP",19,0 )
  10594    ; PXVIS -  ien of vi sit in fil e #9000010
  10595   "RTN","PXV RESP",20,0 )
  10596    N PXVINST ,PXVFAC,PX VHL,PXVN,P XVPRNT,PXV STN
  10597   "RTN","PXV RESP",21,0 )
  10598    S PXVFAC= "",PXVN=$O (^PXV(920. 05,0)) I ' PXVN Q PXV FAC
  10599   "RTN","PXV RESP",22,0 )
  10600    I $G(PXVI S) D
  10601   "RTN","PXV RESP",23,0 )
  10602    .S PXVHL= $P($G(^AUP NVSIT(PXVI S,0)),"^", 22) I 'PXV HL Q
  10603   "RTN","PXV RESP",24,0 )
  10604    .S PXVINS T=$P(^SC(P XVHL,0),"^ ",4) I 'PX VINST Q
  10605   "RTN","PXV RESP",25,0 )
  10606    .S PXVFAC =$O(^PXV(9 20.05,"B", PXVINST,0) )
  10607   "RTN","PXV RESP",26,0 )
  10608    .I 'PXVFA C D
  10609   "RTN","PXV RESP",27,0 )
  10610    ..S PXVST N=$$STA^XU AF4(PXVINS T) Q:PXVST N=""
  10611   "RTN","PXV RESP",28,0 )
  10612    ..S PXVPR NT=$P($$PR NT^XUAF4(P XVSTN),"^" )
  10613   "RTN","PXV RESP",29,0 )
  10614    ..S PXVFA C=$O(^PXV( 920.05,"B" ,PXVPRNT,0 ))
  10615   "RTN","PXV RESP",30,0 )
  10616    I 'PXVFAC ,+$G(DUZ(2 )) D
  10617   "RTN","PXV RESP",31,0 )
  10618    .S PXVINS T=$G(DUZ(2 ))
  10619   "RTN","PXV RESP",32,0 )
  10620    .S PXVFAC =$O(^PXV(9 20.05,"B", PXVINST,0) )
  10621   "RTN","PXV RESP",33,0 )
  10622    .I 'PXVFA C D
  10623   "RTN","PXV RESP",34,0 )
  10624    ..S PXVST N=$$STA^XU AF4(PXVINS T) Q:PXVST N=""
  10625   "RTN","PXV RESP",35,0 )
  10626    ..S PXVPR NT=$P($$PR NT^XUAF4(P XVSTN),"^" )
  10627   "RTN","PXV RESP",36,0 )
  10628    ..S PXVFA C=$O(^PXV( 920.05,"B" ,PXVPRNT,0 ))
  10629   "RTN","PXV RESP",37,0 )
  10630    Q PXVFAC
  10631   "RTN","PXV RPC1")
  10632   0^24^B7035 9613^n/a
  10633   "RTN","PXV RPC1",1,0)
  10634   PXVRPC1 ;B IR/ADM - I MM MANUFAC TURER API  ;02/02/201 5
  10635   "RTN","PXV RPC1",2,0)
  10636    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  10637   "RTN","PXV RPC1",3,0)
  10638    ;
  10639   "RTN","PXV RPC1",4,0)
  10640    Q
  10641   "RTN","PXV RPC1",5,0)
  10642   ILOT(PXVRE TRN,PXVLK, PXVI) ; re turn list  of immuniz ation lot  informatio n
  10643   "RTN","PXV RPC1",6,0)
  10644    ;Input:
  10645   "RTN","PXV RPC1",7,0)
  10646    ;  PXVRET RN - (requ ired) retu rn array o f external  field val ues
  10647   "RTN","PXV RPC1",8,0)
  10648    ;  PXVLK     - (opti onal) info rmation to  be return ed - defau lts to lis t all entr ies (S:B)
  10649   "RTN","PXV RPC1",9,0)
  10650    ;                R:X XX - retur n entry wi th ien XXX
  10651   "RTN","PXV RPC1",10,0 )
  10652    ;                N:X XX - retur n entry wi th lot num ber XXX
  10653   "RTN","PXV RPC1",11,0 )
  10654    ;                S:A    - retur n list of  all active  lot numbe rs
  10655   "RTN","PXV RPC1",12,0 )
  10656    ;                S:I    - retur n list of  all inacti ve lot num bers
  10657   "RTN","PXV RPC1",13,0 )
  10658    ;                S:B    - retur n list of  all lot nu mbers, act ive and in active
  10659   "RTN","PXV RPC1",14,0 )
  10660    ;  PXVI      - (opti onal)
  10661   "RTN","PXV RPC1",15,0 )
  10662    ;                1      - retur n alternat e array wi th interna l values i n delimite d string
  10663   "RTN","PXV RPC1",16,0 )
  10664    ;
  10665   "RTN","PXV RPC1",17,0 )
  10666    ;Output:
  10667   "RTN","PXV RPC1",18,0 )
  10668    ;  PXVRET RN  - retu rned infor mation is  stored in  ^TMP("PXVL ST",$J))
  10669   "RTN","PXV RPC1",19,0 )
  10670    ;             - retu rn info fo rmat: Fiel d Name^Fie ld Value
  10671   "RTN","PXV RPC1",20,0 )
  10672    ;             -        error fo rmat: -1^e rror messa ge
  10673   "RTN","PXV RPC1",21,0 )
  10674    ;             -    a lternate a rray: care t delimite d string w ith differ ing intern al and
  10675   "RTN","PXV RPC1",22,0 )
  10676    ;                                     exte rnal value s separate d by a til de
  10677   "RTN","PXV RPC1",23,0 )
  10678    ;
  10679   "RTN","PXV RPC1",24,0 )
  10680    N PXVARAY ,PXVFLG,PX VNAME,PXVV AL,PXVCT,P XVIEN,PXVS UM
  10681   "RTN","PXV RPC1",25,0 )
  10682    S PXVARAY ="^TMP(""P XVLST"",$J )" K @PXVA RAY
  10683   "RTN","PXV RPC1",26,0 )
  10684    S PXVLK=$ S('$L($G(P XVLK)):"S: B",1:PXVLK )
  10685   "RTN","PXV RPC1",27,0 )
  10686    I $G(PXVI )'=1 S PXV I=0
  10687   "RTN","PXV RPC1",28,0 )
  10688    S PXVFLG= $P(PXVLK," :"),PXVVAL =$P(PXVLK, ":",2)
  10689   "RTN","PXV RPC1",29,0 )
  10690    I $L(PXVF LG)>1!("RN S"'[PXVFLG ) D IIV Q
  10691   "RTN","PXV RPC1",30,0 )
  10692    I PXVFLG= "R",'$G(PX VVAL) S @P XVARAY@(0) ="-1^Inval id input f or immuniz ation lot  IEN" D TMP RET Q
  10693   "RTN","PXV RPC1",31,0 )
  10694    I PXVFLG= "R",'$D(^A UTTIML(PXV VAL)) S @P XVARAY@(0) ="-1^Inval id input f or immuniz ation lot  IEN" D TMP RET Q
  10695   "RTN","PXV RPC1",32,0 )
  10696    I PXVFLG= "N",'$L(PX VVAL) S @P XVARAY@(0) ="-1^Inval id input f or lot num ber" D TMP RET Q
  10697   "RTN","PXV RPC1",33,0 )
  10698    I PXVFLG= "N",'$D(^A UTTIML("B" ,PXVVAL))  S @PXVARAY @(0)="-1^I nvalid inp ut for lot  number" D  TMPRET Q
  10699   "RTN","PXV RPC1",34,0 )
  10700    I PXVFLG= "S",(PXVVA L'="A"&(PX VVAL'="B") &(PXVVAL'= "I")) D II V Q
  10701   "RTN","PXV RPC1",35,0 )
  10702    S (PXVCT, PXVSUM)=0
  10703   "RTN","PXV RPC1",36,0 )
  10704    I PXVFLG= "R" S PXVI EN=PXVVAL  D ONEL
  10705   "RTN","PXV RPC1",37,0 )
  10706    I PXVFLG= "N" S PXVI EN=0 F  S  PXVIEN=$O( ^AUTTIML(" B",PXVVAL, PXVIEN)) Q :'PXVIEN   D ONEL
  10707   "RTN","PXV RPC1",38,0 )
  10708    I PXVFLG= "S" S PXVI EN=0 F  S  PXVIEN=$O( ^AUTTIML(P XVIEN)) Q: 'PXVIEN  D  ONEL
  10709   "RTN","PXV RPC1",39,0 )
  10710    I 'PXVI S  PXVNAME=" " F  S PXV NAME=$O(@P XVARAY@(PX VNAME)) Q: PXVNAME=""   S PXVCT= PXVCT+1,@P XVARAY@(PX VNAME,0)=" RECORD^"_P XVCT_" OF  "_PXVSUM
  10711   "RTN","PXV RPC1",40,0 )
  10712    I PXVI S  @PXVARAY@( 0)=PXVSUM_ " RECORD"_ $S(PXVSUM' >1:"",1:"S ")
  10713   "RTN","PXV RPC1",41,0 )
  10714    I PXVSUM= 0 S @PXVAR AY@(0)="0  RECORDS"
  10715   "RTN","PXV RPC1",42,0 )
  10716    D TMPRET
  10717   "RTN","PXV RPC1",43,0 )
  10718    Q
  10719   "RTN","PXV RPC1",44,0 )
  10720    ;
  10721   "RTN","PXV RPC1",45,0 )
  10722   ONEL ; ret urn array  containing  info for  selected i mmunizatio n lot
  10723   "RTN","PXV RPC1",46,0 )
  10724    N PXV0,PX VFLD,PXVIE NC,PXVY,PX VZ
  10725   "RTN","PXV RPC1",47,0 )
  10726    S PXVIENC =PXVIEN_", ",PXV0=^AU TTIML(PXVI EN,0)
  10727   "RTN","PXV RPC1",48,0 )
  10728    I PXVFLG= "S",PXVVAL ="A",$P(PX V0,"^",3)  Q
  10729   "RTN","PXV RPC1",49,0 )
  10730    I PXVFLG= "S",PXVVAL ="I",'$P(P XV0,"^",3)  Q
  10731   "RTN","PXV RPC1",50,0 )
  10732    S PXVSUM= PXVSUM+1
  10733   "RTN","PXV RPC1",51,0 )
  10734    I 'PXVI D
  10735   "RTN","PXV RPC1",52,0 )
  10736    .D GETS^D IQ(9999999 .41,PXVIEN C,".01;.02 ;.03;.04;. 09;.12;.15 ;.18",""," PXVY")
  10737   "RTN","PXV RPC1",53,0 )
  10738    .S PXVZ=0  F  S PXVZ =$O(PXVY(9 999999.41, PXVIENC,PX VZ)) Q:'PX VZ  D
  10739   "RTN","PXV RPC1",54,0 )
  10740    ..D FIELD ^DID(99999 99.41,PXVZ ,"","LABEL ","PXVFLD" )
  10741   "RTN","PXV RPC1",55,0 )
  10742    ..I PXVZ= .01 S PXVN AME=PXVY(9 999999.41, PXVIENC,PX VZ),PXVNAM E=PXVNAME_ " "_PXVSUM
  10743   "RTN","PXV RPC1",56,0 )
  10744    ..S @PXVA RAY@(PXVNA ME,PXVZ)=P XVFLD("LAB EL")_"^"_P XVY(999999 9.41,PXVIE NC,PXVZ)
  10745   "RTN","PXV RPC1",57,0 )
  10746    .S @PXVAR AY@(PXVNAM E,.001)="I EN^"_PXVIE N
  10747   "RTN","PXV RPC1",58,0 )
  10748    I PXVI D
  10749   "RTN","PXV RPC1",59,0 )
  10750    .D GETS^D IQ(9999999 .41,PXVIEN C,".02;.03 ;.04;.09;. 18","E","P XVY")
  10751   "RTN","PXV RPC1",60,0 )
  10752    .S PXVZ=P XVIEN_"^"_ $P(PXV0,"^ ")_"^"_$P( PXV0,"^",2 )_"~"_PXVY (9999999.4 1,PXVIENC, .02,"E")_" ^"_$P(PXV0 ,"^",3)_"~ "_PXVY(999 9999.41,PX VIENC,.03, "E")
  10753   "RTN","PXV RPC1",61,0 )
  10754    .S PXVZ=P XVZ_"^"_$P (PXV0,"^", 4)_"~"_PXV Y(9999999. 41,PXVIENC ,.04,"E")_ "^"_$P(PXV 0,"^",9)_" ~"_PXVY(99 99999.41,P XVIENC,.09 ,"E")
  10755   "RTN","PXV RPC1",62,0 )
  10756    .S PXVZ=P XVZ_"^"_$P (PXV0,"^", 12)_"^"_$P (PXV0,"^", 15)_"^"_$P (PXV0,"^", 18)_"~"_PX VY(9999999 .41,PXVIEN C,.18,"E")
  10757   "RTN","PXV RPC1",63,0 )
  10758    .S @PXVAR AY@(PXVIEN )=PXVZ
  10759   "RTN","PXV RPC1",64,0 )
  10760    Q
  10761   "RTN","PXV RPC1",65,0 )
  10762    ;
  10763   "RTN","PXV RPC1",66,0 )
  10764   IMAN(PXVRE TRN,PXVLK, PXVDATE,PX VI) ; rpc  to return  immunizati on manufac turer info rmation
  10765   "RTN","PXV RPC1",67,0 )
  10766    ;Input:
  10767   "RTN","PXV RPC1",68,0 )
  10768    ;  PXVRET RN - (requ ired) retu rn array
  10769   "RTN","PXV RPC1",69,0 )
  10770    ;  PXVLK     - (opti onal) info rmation to  be return ed - defau lts to lis t all entr ies (S:B)
  10771   "RTN","PXV RPC1",70,0 )
  10772    ;                R:X XX - retur n entry wi th ien XXX
  10773   "RTN","PXV RPC1",71,0 )
  10774    ;                M:X XX - retur n entry wi th MVX cod e XXX
  10775   "RTN","PXV RPC1",72,0 )
  10776    ;                N:X XX - retur n entry wi th imm man ufacturer  name XXX
  10777   "RTN","PXV RPC1",73,0 )
  10778    ;                S:A    - retur n list of  all active  manufactu rers
  10779   "RTN","PXV RPC1",74,0 )
  10780    ;                S:I    - retur n list of  all inacti ve manufac turers
  10781   "RTN","PXV RPC1",75,0 )
  10782    ;                S:B    - retur n list of  all manufa cturers, a ctive and  inactive
  10783   "RTN","PXV RPC1",76,0 )
  10784    ;  PXVDAT E  - (opti onal) date  for use i n determin ing status  - default s to TODAY
  10785   "RTN","PXV RPC1",77,0 )
  10786    ;  PXVI      - (opti onal)
  10787   "RTN","PXV RPC1",78,0 )
  10788    ;                1      - retur n alternat e array wi th interna l values i n delimite d string
  10789   "RTN","PXV RPC1",79,0 )
  10790    ;
  10791   "RTN","PXV RPC1",80,0 )
  10792    ;Output:
  10793   "RTN","PXV RPC1",81,0 )
  10794    ;  PXVRET RN  - retu rned infor mation is  stored in  ^TMP("PXVL ST",$J))
  10795   "RTN","PXV RPC1",82,0 )
  10796    ;             - retu rn info fo rmat: Fiel d Name^Fie ld Value
  10797   "RTN","PXV RPC1",83,0 )
  10798    ;             -        error fo rmat: -1^e rror messa ge
  10799   "RTN","PXV RPC1",84,0 )
  10800    ;             -    a lternate a rray: care t delimite d string w ith differ ing intern al and
  10801   "RTN","PXV RPC1",85,0 )
  10802    ;                                     exte rnal value s separate d by a til de
  10803   "RTN","PXV RPC1",86,0 )
  10804    ;
  10805   "RTN","PXV RPC1",87,0 )
  10806    N PXVARAY ,PXVFLG,PX VNAME,PXVV AL,PXVCT,P XVIEN,PXVS UM
  10807   "RTN","PXV RPC1",88,0 )
  10808    S PXVARAY ="^TMP(""P XVLST"",$J )" K @PXVA RAY
  10809   "RTN","PXV RPC1",89,0 )
  10810    S PXVLK=$ S('$L($G(P XVLK)):"S: B",1:PXVLK )
  10811   "RTN","PXV RPC1",90,0 )
  10812    I $G(PXVI )'=1 S PXV I=0
  10813   "RTN","PXV RPC1",91,0 )
  10814    S PXVFLG= $P(PXVLK," :"),PXVVAL =$P(PXVLK, ":",2)
  10815   "RTN","PXV RPC1",92,0 )
  10816    I $L(PXVF LG)>1!("RM NS"'[PXVFL G) D IIV Q
  10817   "RTN","PXV RPC1",93,0 )
  10818    I PXVFLG= "R",'$G(PX VVAL) S @P XVARAY@(0) ="-1^Inval id input f or manufac turer IEN"  D TMPRET  Q
  10819   "RTN","PXV RPC1",94,0 )
  10820    I PXVFLG= "R",'$D(^A UTTIMAN(PX VVAL)) S @ PXVARAY@(0 )="-1^Inva lid input  for manufa cturer IEN " D TMPRET  Q
  10821   "RTN","PXV RPC1",95,0 )
  10822    I PXVFLG= "M",'$L(PX VVAL) S @P XVARAY@(0) ="-1^Inval id input f or MVX cod e" D TMPRE T Q
  10823   "RTN","PXV RPC1",96,0 )
  10824    I PXVFLG= "M",'$D(^A UTTIMAN("M ",PXVVAL))  S @PXVARA Y@(0)="-1^ Invalid in put for MV X code" D  TMPRET Q
  10825   "RTN","PXV RPC1",97,0 )
  10826    I PXVFLG= "N",'$L(PX VVAL) S @P XVARAY@(0) ="-1^Inval id input f or manufac turer name " D TMPRET  Q
  10827   "RTN","PXV RPC1",98,0 )
  10828    I PXVFLG= "N",'$D(^A UTTIMAN("B ",$G(PXVVA L))) S @PX VARAY@(0)= "-1^Invali d input fo r manufact urer name"  D TMPRET  Q
  10829   "RTN","PXV RPC1",99,0 )
  10830    I PXVFLG= "S",(PXVVA L'="A"&(PX VVAL'="B") &(PXVVAL'= "I")) D II V Q
  10831   "RTN","PXV RPC1",100, 0)
  10832    S PXVDATE =$S('$L($G (PXVDATE)) :DT,1:PXVD ATE)
  10833   "RTN","PXV RPC1",101, 0)
  10834    S (PXVCT, PXVSUM)=0
  10835   "RTN","PXV RPC1",102, 0)
  10836    I PXVFLG= "R" S PXVI EN=PXVVAL  D ONEM
  10837   "RTN","PXV RPC1",103, 0)
  10838    I PXVFLG= "M" S PXVI EN=0 F  S  PXVIEN=$O( ^AUTTIMAN( "M",PXVVAL ,PXVIEN))  Q:'PXVIEN   D ONEM
  10839   "RTN","PXV RPC1",104, 0)
  10840    I PXVFLG= "N" S PXVI EN=0 F  S  PXVIEN=$O( ^AUTTIMAN( "B",PXVVAL ,PXVIEN))  Q:'PXVIEN   D ONEM
  10841   "RTN","PXV RPC1",105, 0)
  10842    I PXVFLG= "S" S PXVI EN=0 F  S  PXVIEN=$O( ^AUTTIMAN( PXVIEN)) Q :'PXVIEN   D ONEM
  10843   "RTN","PXV RPC1",106, 0)
  10844    I 'PXVI S  PXVNAME=" " F  S PXV NAME=$O(@P XVARAY@(PX VNAME)) Q: PXVNAME=""   S PXVCT= PXVCT+1,@P XVARAY@(PX VNAME,0)=" RECORD^"_P XVCT_" OF  "_PXVSUM
  10845   "RTN","PXV RPC1",107, 0)
  10846    I PXVI S  @PXVARAY@( 0)=PXVSUM_ " RECORD"_ $S(PXVSUM' >1:"",1:"S ")
  10847   "RTN","PXV RPC1",108, 0)
  10848    I PXVSUM= 0 S @PXVAR AY@(0)="0  RECORDS"
  10849   "RTN","PXV RPC1",109, 0)
  10850    D TMPRET
  10851   "RTN","PXV RPC1",110, 0)
  10852    Q
  10853   "RTN","PXV RPC1",111, 0)
  10854    ;
  10855   "RTN","PXV RPC1",112, 0)
  10856   ONEM ; ret urn array  containing  info for  selected m anufacture r
  10857   "RTN","PXV RPC1",113, 0)
  10858    N PXVACT, PXVFILE,PX VFLD,PXVIE NC,PXVP,PX VSTAT,PXV0 ,PXV2,PXVY ,PXVZ,X
  10859   "RTN","PXV RPC1",114, 0)
  10860    S PXVIENC =PXVIEN_", ",PXV0=^AU TTIMAN(PXV IEN,0),PXV FILE=99999 99.04 D ST AT
  10861   "RTN","PXV RPC1",115, 0)
  10862    I PXVFLG= "S",PXVVAL ="A",$P(PX V0,"^",3)  Q
  10863   "RTN","PXV RPC1",116, 0)
  10864    I PXVFLG= "S",PXVVAL ="I",'$P(P XV0,"^",3)  Q
  10865   "RTN","PXV RPC1",117, 0)
  10866    S PXVSUM= PXVSUM+1
  10867   "RTN","PXV RPC1",118, 0)
  10868    I 'PXVI D
  10869   "RTN","PXV RPC1",119, 0)
  10870    .D GETS^D IQ(9999999 .04,PXVIEN C,".01;.02 ;.03;201", "","PXVY")
  10871   "RTN","PXV RPC1",120, 0)
  10872    .S PXVZ=0  F  S PXVZ =$O(PXVY(9 999999.04, PXVIENC,PX VZ)) Q:'PX VZ  D
  10873   "RTN","PXV RPC1",121, 0)
  10874    ..D FIELD ^DID(99999 99.04,PXVZ ,"","LABEL ","PXVFLD" )
  10875   "RTN","PXV RPC1",122, 0)
  10876    ..I PXVZ= .01 S PXVN AME=PXVY(9 999999.04, PXVIENC,PX VZ),PXVNAM E=PXVNAME_ " "_PXVSUM
  10877   "RTN","PXV RPC1",123, 0)
  10878    ..S @PXVA RAY@(PXVNA ME,PXVZ)=P XVFLD("LAB EL")_"^"_P XVY(999999 9.04,PXVIE NC,PXVZ)
  10879   "RTN","PXV RPC1",124, 0)
  10880    .S @PXVAR AY@(PXVNAM E,"STATUS" )="STATUS^ "_PXVSTAT
  10881   "RTN","PXV RPC1",125, 0)
  10882    .S @PXVAR AY@(PXVNAM E,.001)="I EN^"_PXVIE N
  10883   "RTN","PXV RPC1",126, 0)
  10884    I PXVI D
  10885   "RTN","PXV RPC1",127, 0)
  10886    .S PXVZ=P XVIEN_"^"_ $P(PXV0,"^ ")_"^"_$P( PXV0,"^",2 )_"^"_$P(P XV0,"^",3) _"~"_$S($P (PXV0,"^", 3)=0:"ACTI VE",1:"INA CTIVE")
  10887   "RTN","PXV RPC1",128, 0)
  10888    .S PXVZ=P XVZ_"^"_$P ($G(^AUTTI MAN(PXVIEN ,2)),"^")_ "^"_PXVSTA T
  10889   "RTN","PXV RPC1",129, 0)
  10890    .S @PXVAR AY@(PXVIEN )=PXVZ
  10891   "RTN","PXV RPC1",130, 0)
  10892    Q
  10893   "RTN","PXV RPC1",131, 0)
  10894    ;
  10895   "RTN","PXV RPC1",132, 0)
  10896   IVIS(PXVRE TRN,PXVLK, PXVDATE) ;  rpc to re turn vacci ne informa tion state ment infor mation
  10897   "RTN","PXV RPC1",133, 0)
  10898    ;Input:
  10899   "RTN","PXV RPC1",134, 0)
  10900    ;  PXVRET RN - (requ ired) retu rn array
  10901   "RTN","PXV RPC1",135, 0)
  10902    ;  PXVLK     - (opti onal) info rmation to  be return ed - defau lts to lis t all entr ies (S:B)
  10903   "RTN","PXV RPC1",136, 0)
  10904    ;                R:X XX - retur n entry wi th ien XXX
  10905   "RTN","PXV RPC1",137, 0)
  10906    ;                N:X XX - retur n entry wi th VIS nam e XXX
  10907   "RTN","PXV RPC1",138, 0)
  10908    ;                S:A    - retur n list of  all active  VISs
  10909   "RTN","PXV RPC1",139, 0)
  10910    ;                S:I    - retur n list of  all inacti ve VISs
  10911   "RTN","PXV RPC1",140, 0)
  10912    ;                S:B    - retur n list of  all VISs,  active and  inactive
  10913   "RTN","PXV RPC1",141, 0)
  10914    ;  PXVDAT E  - (opti onal) date  for use i n determin ing status  - default s to TODAY
  10915   "RTN","PXV RPC1",142, 0)
  10916    ;
  10917   "RTN","PXV RPC1",143, 0)
  10918    ;Output:
  10919   "RTN","PXV RPC1",144, 0)
  10920    ;  PXVRET RN  - retu rned infor mation is  stored in  ^TMP("PXVL ST",$J))
  10921   "RTN","PXV RPC1",145, 0)
  10922    ;             - retu rn info fo rmat: Fiel d Name^Fie ld Value
  10923   "RTN","PXV RPC1",146, 0)
  10924    ;             -        error fo rmat: -1^e rror messa ge
  10925   "RTN","PXV RPC1",147, 0)
  10926    ;
  10927   "RTN","PXV RPC1",148, 0)
  10928    N PXVARAY ,PXVFLG,PX VNAME,PXVV AL,PXVCT,P XVIEN,PXVS UM
  10929   "RTN","PXV RPC1",149, 0)
  10930    S PXVARAY ="^TMP(""P XVLST"",$J )" K @PXVA RAY
  10931   "RTN","PXV RPC1",150, 0)
  10932    S PXVLK=$ S('$L($G(P XVLK)):"S: B",1:PXVLK )
  10933   "RTN","PXV RPC1",151, 0)
  10934    S PXVFLG= $P(PXVLK," :"),PXVVAL =$P(PXVLK, ":",2)
  10935   "RTN","PXV RPC1",152, 0)
  10936    I $L(PXVF LG)>1!("RN S"'[PXVFLG ) D IIV Q
  10937   "RTN","PXV RPC1",153, 0)
  10938    I PXVFLG= "R",'$G(PX VVAL) S @P XVARAY@(0) ="-1^Inval id input f or VIS IEN " D TMPRET  Q
  10939   "RTN","PXV RPC1",154, 0)
  10940    I PXVFLG= "R",'$D(^A UTTIVIS(PX VVAL)) S @ PXVARAY@(0 )="-1^Inva lid input  for VIS IE N" D TMPRE T Q
  10941   "RTN","PXV RPC1",155, 0)
  10942    I PXVFLG= "N",'$L(PX VVAL) S @P XVARAY@(0) ="-1^Inval id input f or VIS nam e" D TMPRE T Q
  10943   "RTN","PXV RPC1",156, 0)
  10944    I PXVFLG= "N",'$D(^A UTTIVIS("B ",PXVVAL))  S @PXVARA Y@(0)="-1^ Invalid in put for VI S name" D  TMPRET Q
  10945   "RTN","PXV RPC1",157, 0)
  10946    I PXVFLG= "S",(PXVVA L'="A"&(PX VVAL'="B") &(PXVVAL'= "I")) D II V Q
  10947   "RTN","PXV RPC1",158, 0)
  10948    S PXVDATE =$S('$L($G (PXVDATE)) :DT,1:PXVD ATE)
  10949   "RTN","PXV RPC1",159, 0)
  10950    S (PXVCT, PXVSUM)=0
  10951   "RTN","PXV RPC1",160, 0)
  10952    I PXVFLG= "R" S PXVI EN=PXVVAL  D ONEV
  10953   "RTN","PXV RPC1",161, 0)
  10954    I PXVFLG= "N" S PXVI EN=0 F  S  PXVIEN=$O( ^AUTTIVIS( "B",PXVVAL ,PXVIEN))  Q:'PXVIEN   D ONEV
  10955   "RTN","PXV RPC1",162, 0)
  10956    I PXVFLG= "S" S PXVI EN=0 F  S  PXVIEN=$O( ^AUTTIVIS( PXVIEN)) Q :'PXVIEN   D ONEV
  10957   "RTN","PXV RPC1",163, 0)
  10958    S PXVNAME ="" F  S P XVNAME=$O( @PXVARAY@( PXVNAME))  Q:PXVNAME= ""  S PXVC T=PXVCT+1, @PXVARAY@( PXVNAME,0) ="RECORD^" _PXVCT_" O F "_PXVSUM
  10959   "RTN","PXV RPC1",164, 0)
  10960    I PXVSUM= 0 S @PXVAR AY@(0)="0  RECORDS"
  10961   "RTN","PXV RPC1",165, 0)
  10962    D TMPRET
  10963   "RTN","PXV RPC1",166, 0)
  10964    Q
  10965   "RTN","PXV RPC1",167, 0)
  10966    ;
  10967   "RTN","PXV RPC1",168, 0)
  10968   ONEV ; ret urn array  containing  info for  VIS
  10969   "RTN","PXV RPC1",169, 0)
  10970    N PXV,PXV ACT,PXVFIL E,PXVFLD,P XVIENC,PXV L,PXVP,PXV STAT,PXVY, PXVZ
  10971   "RTN","PXV RPC1",170, 0)
  10972    S PXVIENC =PXVIEN_", ",PXVFILE= 920 D STAT
  10973   "RTN","PXV RPC1",171, 0)
  10974    I PXVFLG= "S",PXVVAL ="A",'PXVA CT Q
  10975   "RTN","PXV RPC1",172, 0)
  10976    I PXVFLG= "S",PXVVAL ="I",PXVAC T Q
  10977   "RTN","PXV RPC1",173, 0)
  10978    S PXVSUM= PXVSUM+1
  10979   "RTN","PXV RPC1",174, 0)
  10980    D GETS^DI Q(920,PXVI ENC,".01;. 02;.03;.04 ;2;100;101 ","","PXVP ")
  10981   "RTN","PXV RPC1",175, 0)
  10982    S PXVZ=0  F  S PXVZ= $O(PXVP(92 0,PXVIENC, PXVZ)) Q:' PXVZ  D
  10983   "RTN","PXV RPC1",176, 0)
  10984    .D FIELD^ DID(920,PX VZ,"","LAB EL","PXVFL D")
  10985   "RTN","PXV RPC1",177, 0)
  10986    .I PXVZ=. 01 S PXVNA ME=PXVP(92 0,PXVIENC, PXVZ),PXVN AME=PXVNAM E_" "_PXVS UM
  10987   "RTN","PXV RPC1",178, 0)
  10988    .I PXVZ=. 04,PXVP(92 0,PXVIENC, PXVZ) N X  S X=PXVP(9 20,PXVIENC ,PXVZ) D   Q
  10989   "RTN","PXV RPC1",179, 0)
  10990    ..S PXV=$ S(X=1:"ENG LISH",X=2: "GERMAN",X =3:"SPANIS H",X=4:"FR ENCH",X=5: "FINNISH", X=6:"ITALI AN",X=7:"P ORTUGUESE" ,X=8:"ARAB IC",X=11:" RUSSIAN",X =12:"GREEK ",X=18:"HE BREW",1:X)
  10991   "RTN","PXV RPC1",180, 0)
  10992    ..S @PXVA RAY@(PXVNA ME,PXVZ)=P XVFLD("LAB EL")_"^"_P XV
  10993   "RTN","PXV RPC1",181, 0)
  10994    .I PXVZ=2  D  Q
  10995   "RTN","PXV RPC1",182, 0)
  10996    ..I PXVP( 920,PXVIEN C,PXVZ)=""  S @PXVARA Y@(PXVNAME ,PXVZ)=PXV FLD("LABEL ")_"^"_PXV P(920,PXVI ENC,PXVZ)  Q
  10997   "RTN","PXV RPC1",183, 0)
  10998    ..S PXVL= 0 F  S PXV L=$O(PXVP( 920,PXVIEN C,PXVZ,PXV L)) Q:'PXV L  D
  10999   "RTN","PXV RPC1",184, 0)
  11000    ...S @PXV ARAY@(PXVN AME,PXVZ,P XVL)=PXVFL D("LABEL") _" "_PXVL_ "^"_PXVP(9 20,PXVIENC ,PXVZ,PXVL )
  11001   "RTN","PXV RPC1",185, 0)
  11002    .S @PXVAR AY@(PXVNAM E,PXVZ)=PX VFLD("LABE L")_"^"_PX VP(920,PXV IENC,PXVZ)
  11003   "RTN","PXV RPC1",186, 0)
  11004    S @PXVARA Y@(PXVNAME ,"STATUS") ="STATUS^" _PXVSTAT
  11005   "RTN","PXV RPC1",187, 0)
  11006    S @PXVARA Y@(PXVNAME ,.001)="IE N^"_PXVIEN
  11007   "RTN","PXV RPC1",188, 0)
  11008    Q
  11009   "RTN","PXV RPC1",189, 0)
  11010    ;
  11011   "RTN","PXV RPC1",190, 0)
  11012   STAT ;
  11013   "RTN","PXV RPC1",191, 0)
  11014    S PXVACT= $P($$GETST AT^XTID(PX VFILE,,PXV IENC,$G(PX VDATE)),"^ ")
  11015   "RTN","PXV RPC1",192, 0)
  11016    I PXVACT= "" S PXVAC T=1
  11017   "RTN","PXV RPC1",193, 0)
  11018    S PXVSTAT =$S(PXVACT =0:"INACTI VE",1:"ACT IVE")
  11019   "RTN","PXV RPC1",194, 0)
  11020    Q
  11021   "RTN","PXV RPC1",195, 0)
  11022    ;
  11023   "RTN","PXV RPC1",196, 0)
  11024   IIV ; retu rn invalid  input mes sage
  11025   "RTN","PXV RPC1",197, 0)
  11026    S @PXVARA Y@(0)="-1^ Invalid in put value"
  11027   "RTN","PXV RPC1",198, 0)
  11028   TMPRET ;
  11029   "RTN","PXV RPC1",199, 0)
  11030    S PXVRETR N=$NA(@PXV ARAY)
  11031   "RTN","PXV RPC1",200, 0)
  11032    Q
  11033   "RTN","PXV RPC1",201, 0)
  11034    ;
  11035   "RTN","PXV RPC2")
  11036   0^25^B2947 6719^n/a
  11037   "RTN","PXV RPC2",1,0)
  11038   PXVRPC2 ;B PFO/LMT -  PCE RPCs f or IMM Sou rce, Route , Site ;02 /16/16  13 :00
  11039   "RTN","PXV RPC2",2,0)
  11040    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  11041   "RTN","PXV RPC2",3,0)
  11042    ;
  11043   "RTN","PXV RPC2",4,0)
  11044    ; Referen ce to ^DIA (920.X,"C" ) supporte d by ICR # 2602
  11045   "RTN","PXV RPC2",5,0)
  11046    ;
  11047   "RTN","PXV RPC2",6,0)
  11048    ;******** ********** ********** ********** ********** ********** ********** ****
  11049   "RTN","PXV RPC2",7,0)
  11050    ;
  11051   "RTN","PXV RPC2",8,0)
  11052    ;Input:
  11053   "RTN","PXV RPC2",9,0)
  11054    ;  PXVRSL T - (Requi red) Retur n value
  11055   "RTN","PXV RPC2",10,0 )
  11056    ;  PXVFLT R - (Optio nal; Defau lts to "S: B") Filter . Possible  values ar e:
  11057   "RTN","PXV RPC2",11,0 )
  11058    ;                R:X XX - Retur n entry wi th IEN XXX .
  11059   "RTN","PXV RPC2",12,0 )
  11060    ;                H:X XX - Retur n entry wi th HL7 Cod e XXX.
  11061   "RTN","PXV RPC2",13,0 )
  11062    ;                N:X XX - Retur n entry wi th #.01 fi eld equal  to XXX
  11063   "RTN","PXV RPC2",14,0 )
  11064    ;                S:X    - Retur n all entr ies with a  status of  X.
  11065   "RTN","PXV RPC2",15,0 )
  11066    ;                         Possi ble values  of X:
  11067   "RTN","PXV RPC2",16,0 )
  11068    ;                           A -  Active En tries
  11069   "RTN","PXV RPC2",17,0 )
  11070    ;                           I -  Inactive  Entries
  11071   "RTN","PXV RPC2",18,0 )
  11072    ;                           B -  Both acti ve and ina ctive entr ies
  11073   "RTN","PXV RPC2",19,0 )
  11074    ;
  11075   "RTN","PXV RPC2",20,0 )
  11076    ;Returns:
  11077   "RTN","PXV RPC2",21,0 )
  11078    ; PXVRSLT (0)=Count  of element s returned  (0 if not hing found )
  11079   "RTN","PXV RPC2",22,0 )
  11080    ; PXVRSLT (n)=IEN^Na me^HL7 Cod e^Status ( 1:Active,  0:Inactive )
  11081   "RTN","PXV RPC2",23,0 )
  11082    ;
  11083   "RTN","PXV RPC2",24,0 )
  11084    ; For the  IMMROUTE  tag, see a dditional  input and  return val ues docume nted below .
  11085   "RTN","PXV RPC2",25,0 )
  11086    ;
  11087   "RTN","PXV RPC2",26,0 )
  11088    ; When fi ltering ba sed off IE N, HL7 Cod e, or #.01  field, on ly one ent ry will be  returned
  11089   "RTN","PXV RPC2",27,0 )
  11090    ; in PXVR SLT(1).
  11091   "RTN","PXV RPC2",28,0 )
  11092    ;
  11093   "RTN","PXV RPC2",29,0 )
  11094    ; When fi ltering ba sed off st atus, mult iple entri es can be  returned.  The first  entry will  be
  11095   "RTN","PXV RPC2",30,0 )
  11096    ; returne d in subsc ript 1, an d subscrip ts will be  increment ed by 1 fo r further  entries.
  11097   "RTN","PXV RPC2",31,0 )
  11098    ; Entries  will be s orted alph abetically .
  11099   "RTN","PXV RPC2",32,0 )
  11100    ;
  11101   "RTN","PXV RPC2",33,0 )
  11102    ; If no e ntries are  found bas ed off the  filtering  criteria,  PXVRSLT(0 ) will equ al 0,
  11103   "RTN","PXV RPC2",34,0 )
  11104    ; and the re will be  no data r eturned in  the subse quent subs cripts.
  11105   "RTN","PXV RPC2",35,0 )
  11106    ;
  11107   "RTN","PXV RPC2",36,0 )
  11108    ;******** ********** ********** ********** ********** ********** ********** **********
  11109   "RTN","PXV RPC2",37,0 )
  11110    ;
  11111   "RTN","PXV RPC2",38,0 )
  11112   IMMSRC(PXV RSLT,PXVFL TR) ;
  11113   "RTN","PXV RPC2",39,0 )
  11114    D GETDATA (.PXVRSLT, 920.1,$G(P XVFLTR),"" )
  11115   "RTN","PXV RPC2",40,0 )
  11116    Q
  11117   "RTN","PXV RPC2",41,0 )
  11118    ;
  11119   "RTN","PXV RPC2",42,0 )
  11120   IMMROUTE(P XVRSLT,PXV FLTR,PXVSI TES) ;
  11121   "RTN","PXV RPC2",43,0 )
  11122    ; The fol lowing add itional In put and Re turn value s are avai lable for  IMMROUTE:
  11123   "RTN","PXV RPC2",44,0 )
  11124    ;   Input :
  11125   "RTN","PXV RPC2",45,0 )
  11126    ;      PX VSITES - ( Optional)  Controls i f the avai lable site s for a gi ve route a re returne d
  11127   "RTN","PXV RPC2",46,0 )
  11128    ;   Retur ns:
  11129   "RTN","PXV RPC2",47,0 )
  11130    ;      If  PXVSITES= 1, the sit es for a g iven route  will be r eturned.
  11131   "RTN","PXV RPC2",48,0 )
  11132    ;       o  if If onl y a subset  of sites  are select able for a  route,
  11133   "RTN","PXV RPC2",49,0 )
  11134    ;          that list  will be r eturned in
  11135   "RTN","PXV RPC2",50,0 )
  11136    ;            PXVRSLT (n+1)=SITE ^Site IEN  1
  11137   "RTN","PXV RPC2",51,0 )
  11138    ;            PXVRSLT (n+2)=SITE ^Site IEN  2
  11139   "RTN","PXV RPC2",52,0 )
  11140    ;            PXVRSLT (n+x)=SITE ^Site IEN  x
  11141   "RTN","PXV RPC2",53,0 )
  11142    ;       o  if all si tes are se lectable f or a route , the RPC  will retur n:
  11143   "RTN","PXV RPC2",54,0 )
  11144    ;            PXVRSLT (n+1)=SITE ^ALL
  11145   "RTN","PXV RPC2",55,0 )
  11146    ;       o  If no sit es are sel ectable fo r a route,  the RPC w ill return :
  11147   "RTN","PXV RPC2",56,0 )
  11148    ;            PXVRSLT (n+1)=SITE ^NONE
  11149   "RTN","PXV RPC2",57,0 )
  11150    ;
  11151   "RTN","PXV RPC2",58,0 )
  11152    D GETDATA (.PXVRSLT, 920.2,$G(P XVFLTR),$G (PXVSITES) )
  11153   "RTN","PXV RPC2",59,0 )
  11154    Q
  11155   "RTN","PXV RPC2",60,0 )
  11156    ;
  11157   "RTN","PXV RPC2",61,0 )
  11158   IMMSITE(PX VRSLT,PXVF LTR,PXVDAT E) ;
  11159   "RTN","PXV RPC2",62,0 )
  11160    D GETDATA (.PXVRSLT, 920.3,$G(P XVFLTR),"" )
  11161   "RTN","PXV RPC2",63,0 )
  11162    Q
  11163   "RTN","PXV RPC2",64,0 )
  11164    ;
  11165   "RTN","PXV RPC2",65,0 )
  11166    ;******** ********** ********** ********** ********** ********** ********** ****
  11167   "RTN","PXV RPC2",66,0 )
  11168    ;
  11169   "RTN","PXV RPC2",67,0 )
  11170   GETDATA(PX VRSLT,PXFI LE,PXVFLTR ,PXVSITES)  ;
  11171   "RTN","PXV RPC2",68,0 )
  11172    ;
  11173   "RTN","PXV RPC2",69,0 )
  11174    N PXCNT,P XIEN,PXHL7 ,PXFKTRSTA T,PXFLTRTY P,PXFLTRVA L,PXFLTRST AT,PXNAME, PXFLDS,PXS TAT
  11175   "RTN","PXV RPC2",70,0 )
  11176    S PXCNT=0
  11177   "RTN","PXV RPC2",71,0 )
  11178    S PXIEN=" "
  11179   "RTN","PXV RPC2",72,0 )
  11180    S PXHL7=" "
  11181   "RTN","PXV RPC2",73,0 )
  11182    S PXFLTRT YP="S"
  11183   "RTN","PXV RPC2",74,0 )
  11184    S PXFLTRS TAT="B"
  11185   "RTN","PXV RPC2",75,0 )
  11186    D CHKCACH E(PXFILE)
  11187   "RTN","PXV RPC2",76,0 )
  11188    ;
  11189   "RTN","PXV RPC2",77,0 )
  11190    I $G(PXVF LTR)'="" D
  11191   "RTN","PXV RPC2",78,0 )
  11192    . S PXFLT RTYP=$P(PX VFLTR,":", 1)
  11193   "RTN","PXV RPC2",79,0 )
  11194    . S PXFLT RVAL=$P(PX VFLTR,":", 2)
  11195   "RTN","PXV RPC2",80,0 )
  11196    ;
  11197   "RTN","PXV RPC2",81,0 )
  11198    I PXFLTRT YP="R" D   S PXVRSLT( 0)=PXCNT Q
  11199   "RTN","PXV RPC2",82,0 )
  11200    . S PXIEN =PXFLTRVAL
  11201   "RTN","PXV RPC2",83,0 )
  11202    . I 'PXIE N Q
  11203   "RTN","PXV RPC2",84,0 )
  11204    . I '$D(^ PXV(PXFILE ,PXIEN)) Q
  11205   "RTN","PXV RPC2",85,0 )
  11206    . D ADDEN TRY(.PXVRS LT,.PXFILE ,.PXIEN,$G (PXVSITES) ,"",.PXCNT )
  11207   "RTN","PXV RPC2",86,0 )
  11208    ;
  11209   "RTN","PXV RPC2",87,0 )
  11210    I PXFLTRT YP="H" D   S PXVRSLT( 0)=PXCNT Q
  11211   "RTN","PXV RPC2",88,0 )
  11212    . N PXIND EX
  11213   "RTN","PXV RPC2",89,0 )
  11214    . S PXHL7 =PXFLTRVAL
  11215   "RTN","PXV RPC2",90,0 )
  11216    . I PXHL7 ="" Q
  11217   "RTN","PXV RPC2",91,0 )
  11218    . S PXIND EX="H"
  11219   "RTN","PXV RPC2",92,0 )
  11220    . I PXFIL E=920.3 S  PXINDEX="B "
  11221   "RTN","PXV RPC2",93,0 )
  11222    . S PXIEN =$O(^PXV(P XFILE,PXIN DEX,PXHL7, 0))
  11223   "RTN","PXV RPC2",94,0 )
  11224    . D ADDEN TRY(.PXVRS LT,.PXFILE ,.PXIEN,$G (PXVSITES) ,"",.PXCNT )
  11225   "RTN","PXV RPC2",95,0 )
  11226    ;
  11227   "RTN","PXV RPC2",96,0 )
  11228    I PXFLTRT YP="N" D   S PXVRSLT( 0)=PXCNT Q
  11229   "RTN","PXV RPC2",97,0 )
  11230    . S PXNAM E=PXFLTRVA L
  11231   "RTN","PXV RPC2",98,0 )
  11232    . I PXNAM E="" Q
  11233   "RTN","PXV RPC2",99,0 )
  11234    . S PXIEN =$O(^PXV(P XFILE,"B", PXNAME,0))
  11235   "RTN","PXV RPC2",100, 0)
  11236    . D ADDEN TRY(.PXVRS LT,.PXFILE ,.PXIEN,$G (PXVSITES) ,"",.PXCNT )
  11237   "RTN","PXV RPC2",101, 0)
  11238    ;
  11239   "RTN","PXV RPC2",102, 0)
  11240    ; I PXFLT RTYP="S" D
  11241   "RTN","PXV RPC2",103, 0)
  11242    I $G(PXFL TRVAL)?1(1 "A",1"I",1 "B") S PXF LTRSTAT=PX FLTRVAL
  11243   "RTN","PXV RPC2",104, 0)
  11244    S PXNAME= ""
  11245   "RTN","PXV RPC2",105, 0)
  11246    F  S PXNA ME=$O(^PXV (PXFILE,"B ",PXNAME))  Q:PXNAME= ""  D
  11247   "RTN","PXV RPC2",106, 0)
  11248    . S PXIEN =0
  11249   "RTN","PXV RPC2",107, 0)
  11250    . F  S PX IEN=$O(^PX V(PXFILE," B",PXNAME, PXIEN)) Q: 'PXIEN  D
  11251   "RTN","PXV RPC2",108, 0)
  11252    . . I PXF ILE=920.3, $G(^PXV(PX FILE,"B",P XNAME,PXIE N))=1 Q  ;  cross-ref  is on HL7  code - no t .01
  11253   "RTN","PXV RPC2",109, 0)
  11254    . . D ADD ENTRY(.PXV RSLT,.PXFI LE,.PXIEN, $G(PXVSITE S),PXFLTRS TAT,.PXCNT )
  11255   "RTN","PXV RPC2",110, 0)
  11256    ;
  11257   "RTN","PXV RPC2",111, 0)
  11258    S PXVRSLT (0)=PXCNT
  11259   "RTN","PXV RPC2",112, 0)
  11260    ;
  11261   "RTN","PXV RPC2",113, 0)
  11262    Q
  11263   "RTN","PXV RPC2",114, 0)
  11264    ;
  11265   "RTN","PXV RPC2",115, 0)
  11266   ADDENTRY(P XVRSLT,PXF ILE,PXIEN, PXVSITES,P XFLTRSTAT, PXCNT) ; A dds entry  to PXVRSLT
  11267   "RTN","PXV RPC2",116, 0)
  11268    ;
  11269   "RTN","PXV RPC2",117, 0)
  11270    N PXFLDS, PXSTAT
  11271   "RTN","PXV RPC2",118, 0)
  11272    ;
  11273   "RTN","PXV RPC2",119, 0)
  11274    I 'PXIEN  Q
  11275   "RTN","PXV RPC2",120, 0)
  11276    ;
  11277   "RTN","PXV RPC2",121, 0)
  11278    S PXFLDS= $$GETFLDS( PXFILE,PXI EN)
  11279   "RTN","PXV RPC2",122, 0)
  11280    S PXSTAT= $P(PXFLDS, U,4)
  11281   "RTN","PXV RPC2",123, 0)
  11282    ;
  11283   "RTN","PXV RPC2",124, 0)
  11284    I $G(PXFL TRSTAT)="A ",'PXSTAT  Q
  11285   "RTN","PXV RPC2",125, 0)
  11286    I $G(PXFL TRSTAT)="I ",PXSTAT Q
  11287   "RTN","PXV RPC2",126, 0)
  11288    ;
  11289   "RTN","PXV RPC2",127, 0)
  11290    S PXCNT=P XCNT+1
  11291   "RTN","PXV RPC2",128, 0)
  11292    S PXVRSLT (PXCNT)=PX FLDS
  11293   "RTN","PXV RPC2",129, 0)
  11294    I PXFILE= 920.2,$G(P XVSITES) D  ADDSITES( .PXVRSLT,. PXCNT,.PXI EN)
  11295   "RTN","PXV RPC2",130, 0)
  11296    ;
  11297   "RTN","PXV RPC2",131, 0)
  11298    Q
  11299   "RTN","PXV RPC2",132, 0)
  11300    ;
  11301   "RTN","PXV RPC2",133, 0)
  11302   GETFLDS(PX FILE,PXIEN ) ; Return s field va lues
  11303   "RTN","PXV RPC2",134, 0)
  11304    ;
  11305   "RTN","PXV RPC2",135, 0)
  11306    N PXNAME, PXHL7,PXVR SLT,PXSTAT
  11307   "RTN","PXV RPC2",136, 0)
  11308    ;
  11309   "RTN","PXV RPC2",137, 0)
  11310    S PXNAME= $P($G(^PXV (PXFILE,PX IEN,0)),U, 1)
  11311   "RTN","PXV RPC2",138, 0)
  11312    S PXHL7=$ P($G(^PXV( PXFILE,PXI EN,0)),U,2 )
  11313   "RTN","PXV RPC2",139, 0)
  11314    S PXSTAT= $$GETSTAT( PXFILE,PXI EN)
  11315   "RTN","PXV RPC2",140, 0)
  11316    ;
  11317   "RTN","PXV RPC2",141, 0)
  11318    S PXVRSLT =PXIEN_U_P XNAME_U_PX HL7_U_PXST AT
  11319   "RTN","PXV RPC2",142, 0)
  11320    ;
  11321   "RTN","PXV RPC2",143, 0)
  11322    Q PXVRSLT
  11323   "RTN","PXV RPC2",144, 0)
  11324    ;
  11325   "RTN","PXV RPC2",145, 0)
  11326   ADDSITES(P XVRSLT,PXC NT,PXROUTE ) ; Add Si tes to PXV RSLT
  11327   "RTN","PXV RPC2",146, 0)
  11328    ;
  11329   "RTN","PXV RPC2",147, 0)
  11330    N PXSITE, PXSITES
  11331   "RTN","PXV RPC2",148, 0)
  11332    ;
  11333   "RTN","PXV RPC2",149, 0)
  11334    D SITES^P XAPIIM(.PX SITES,PXRO UTE,"R")
  11335   "RTN","PXV RPC2",150, 0)
  11336    ;
  11337   "RTN","PXV RPC2",151, 0)
  11338    S PXSITE= ""
  11339   "RTN","PXV RPC2",152, 0)
  11340    F  S PXSI TE=$O(PXSI TES(PXSITE )) Q:PXSIT E=""  D
  11341   "RTN","PXV RPC2",153, 0)
  11342    . S PXCNT =PXCNT+1
  11343   "RTN","PXV RPC2",154, 0)
  11344    . S PXVRS LT(PXCNT)= "SITE^"_PX SITE
  11345   "RTN","PXV RPC2",155, 0)
  11346    ;
  11347   "RTN","PXV RPC2",156, 0)
  11348    Q
  11349   "RTN","PXV RPC2",157, 0)
  11350    ;
  11351   "RTN","PXV RPC2",158, 0)
  11352   GETSTAT(PX FILE,PXIEN ) ;
  11353   "RTN","PXV RPC2",159, 0)
  11354    ;
  11355   "RTN","PXV RPC2",160, 0)
  11356    N PXSTAT
  11357   "RTN","PXV RPC2",161, 0)
  11358    ;
  11359   "RTN","PXV RPC2",162, 0)
  11360    I PXFILE? 1(1"920.1" ,1"920.4")  D  Q PXST AT
  11361   "RTN","PXV RPC2",163, 0)
  11362    . S PXSTA T='$P($G(^ PXV(PXFILE ,PXIEN,0)) ,U,3)
  11363   "RTN","PXV RPC2",164, 0)
  11364    ;
  11365   "RTN","PXV RPC2",165, 0)
  11366    S PXSTAT= $G(^XTMP(" PXVCACHE-" _PXFILE,PX IEN))
  11367   "RTN","PXV RPC2",166, 0)
  11368    I PXSTAT= "" S PXSTA T=$P($$GET STAT^XTID( PXFILE,"", PXIEN_",") ,U,1)
  11369   "RTN","PXV RPC2",167, 0)
  11370    I PXSTAT= "" S PXSTA T=1
  11371   "RTN","PXV RPC2",168, 0)
  11372    Q PXSTAT
  11373   "RTN","PXV RPC2",169, 0)
  11374    ;
  11375   "RTN","PXV RPC2",170, 0)
  11376   CHKCACHE(P XFILE) ; C heck Cache  - see if  we need to  update
  11377   "RTN","PXV RPC2",171, 0)
  11378    ;
  11379   "RTN","PXV RPC2",172, 0)
  11380    N PXCACHE DT,PXLASTE DITDT
  11381   "RTN","PXV RPC2",173, 0)
  11382    ;
  11383   "RTN","PXV RPC2",174, 0)
  11384    I PXFILE? 1(1"920.1" ,1"920.4")  Q
  11385   "RTN","PXV RPC2",175, 0)
  11386    ;
  11387   "RTN","PXV RPC2",176, 0)
  11388    S PXLASTE DITDT=$O(^ DIA(PXFILE ,"C",""),- 1)   ;ICR  #2602
  11389   "RTN","PXV RPC2",177, 0)
  11390    S PXCACHE DT=$P($G(^ XTMP("PXVC ACHE-"_PXF ILE,0)),U, 2)
  11391   "RTN","PXV RPC2",178, 0)
  11392    I PXCACHE DT,PXCACHE DT>PXLASTE DITDT Q
  11393   "RTN","PXV RPC2",179, 0)
  11394    D UPDCACH E(PXFILE)
  11395   "RTN","PXV RPC2",180, 0)
  11396    ;
  11397   "RTN","PXV RPC2",181, 0)
  11398    Q
  11399   "RTN","PXV RPC2",182, 0)
  11400    ;
  11401   "RTN","PXV RPC2",183, 0)
  11402   UPDCACHE(P XFILE) ;
  11403   "RTN","PXV RPC2",184, 0)
  11404    ;
  11405   "RTN","PXV RPC2",185, 0)
  11406    N PXIEN,P XSTAT
  11407   "RTN","PXV RPC2",186, 0)
  11408    ;
  11409   "RTN","PXV RPC2",187, 0)
  11410    K ^XTMP(" PXVCACHE-" _PXFILE)
  11411   "RTN","PXV RPC2",188, 0)
  11412    S ^XTMP(" PXVCACHE-" _PXFILE,0) =$$FMADD^X LFDT(DT,73 0)_U_$$NOW ^XLFDT()_U _"Cache st atus for f ile #"_PXF ILE
  11413   "RTN","PXV RPC2",189, 0)
  11414    S PXIEN=0
  11415   "RTN","PXV RPC2",190, 0)
  11416    F  S PXIE N=$O(^PXV( PXFILE,PXI EN)) Q:'PX IEN  D
  11417   "RTN","PXV RPC2",191, 0)
  11418    . S PXSTA T=$P($$GET STAT^XTID( PXFILE,"", PXIEN_",") ,U,1)
  11419   "RTN","PXV RPC2",192, 0)
  11420    . I PXSTA T="" S PXS TAT=1
  11421   "RTN","PXV RPC2",193, 0)
  11422    . S ^XTMP ("PXVCACHE -"_PXFILE, PXIEN)=PXS TAT
  11423   "RTN","PXV RPC2",194, 0)
  11424    ;
  11425   "RTN","PXV RPC2",195, 0)
  11426    Q
  11427   "RTN","PXV RPC3")
  11428   0^26^B2861 8741^n/a
  11429   "RTN","PXV RPC3",1,0)
  11430   PXVRPC3 ;M SC/DKA - V IMM 2.0 RP C code to  return lis t of Immun izations ; 10/27/2015  13:36
  11431   "RTN","PXV RPC3",2,0)
  11432    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  11433   "RTN","PXV RPC3",3,0)
  11434    ;
  11435   "RTN","PXV RPC3",4,0)
  11436    Q
  11437   "RTN","PXV RPC3",5,0)
  11438   IMMDATA(PX VRET,PXVFL TR,SUBFILE S) ; Retur n array of  entries f rom IMMUNI ZATION, Fi le #999999 9.14
  11439   "RTN","PXV RPC3",6,0)
  11440    ; PXVFLTR  can have  one of the se values:
  11441   "RTN","PXV RPC3",7,0)
  11442    ;   R:XXX  - Return  entry with  IEN XXX.
  11443   "RTN","PXV RPC3",8,0)
  11444    ;   S:A    - List of  Active Im munization s (default )
  11445   "RTN","PXV RPC3",9,0)
  11446    ;   S:H    - List of  [Selectab le for] Hi storic Imm unizations
  11447   "RTN","PXV RPC3",10,0 )
  11448    ;   S:*    - All rec ords (Incl uding Inac tive Immun izations)
  11449   "RTN","PXV RPC3",11,0 )
  11450    ; SUBFILE S is 1 or  Y to inclu de the sub files when  returning  the data
  11451   "RTN","PXV RPC3",12,0 )
  11452    ; If SUBF ILES is 0  or N (or n ot specifi ed) then r eturn just  this subs et of fiel ds:
  11453   "RTN","PXV RPC3",13,0 )
  11454    ; IEN, NA ME, SHORT  NAME, CVX  CODE, MAX  # IN SERIE S, INACTIV E FLAG,
  11455   "RTN","PXV RPC3",14,0 )
  11456    ; MNEMONI C, ACRONYM , SELECTAB LE FOR HIS TORIC)
  11457   "RTN","PXV RPC3",15,0 )
  11458    N PXVFILE ,PXVIEN,PX VIENS,PXVC NT,PXVGBL, PXVDATA,PX VSTR,PXVRE F,PXVERR,P XVSUB,PXVS UBC,PXVDEL IM,PXVSBSC R
  11459   "RTN","PXV RPC3",16,0 )
  11460    N PXVBRIE F,PXVACTIV ,PXVHISTR, PXVINCLU,P XVTEMP,PXV DLM1,PXVDL M2,PXVDLM3 ,PXVVALID, PXVERMSG,P XVTYPE
  11461   "RTN","PXV RPC3",17,0 )
  11462    N PXVSDAT A,PXVSERR, PXVFMT,PXV SUB2,PXVSU B2C,PXVSVS C2
  11463   "RTN","PXV RPC3",18,0 )
  11464    S SUBFILE S=+$TR($E( $G(SUBFILE S,0)),"YyN n","1100")
  11465   "RTN","PXV RPC3",19,0 )
  11466    S PXVFLTR =$G(PXVFLT R,"S:A") S :PXVFLTR=" " PXVFLTR= "S:A"
  11467   "RTN","PXV RPC3",20,0 )
  11468    S PXVGBL= $NA(^AUTTI MM)
  11469   "RTN","PXV RPC3",21,0 )
  11470    K PXVRET  S PXVRET=$ NA(^TMP("P XVRPC3",$J )) K @PXVR ET
  11471   "RTN","PXV RPC3",22,0 )
  11472    S PXVVALI D=1 ; Assu me the par ameters ar e valid un til proven  otherwise
  11473   "RTN","PXV RPC3",23,0 )
  11474    I $E(PXVF LTR,1,2)=" R:" D
  11475   "RTN","PXV RPC3",24,0 )
  11476    . S PXVFM T="R",PXVI EN=$E(PXVF LTR,3,$L(P XVFLTR)),P XVTYPE="*"
  11477   "RTN","PXV RPC3",25,0 )
  11478    . S:PXVIE N'=+PXVIEN !(PXVIEN<1 ) PXVVALID =0,PXVERMS G="Invalid  IEN speci fied for R : format i n PXVFLTR  parameter"
  11479   "RTN","PXV RPC3",26,0 )
  11480    . Q:PXVIE N=""
  11481   "RTN","PXV RPC3",27,0 )
  11482    . S:'$D(@ PXVGBL@(PX VIEN)) PXV VALID=0,PX VERMSG="En try not fo und for th e specifie d IEN"
  11483   "RTN","PXV RPC3",28,0 )
  11484    E  I $E(P XVFLTR,1,2 )="S:" D
  11485   "RTN","PXV RPC3",29,0 )
  11486    . S PXVFM T="S",PXVT YPE=$E(PXV FLTR,3)
  11487   "RTN","PXV RPC3",30,0 )
  11488    . S:PXVTY PE'="A"&(P XVTYPE'="H ")&(PXVTYP E'="*") PX VVALID=0,P XVERMSG="I nvalid typ e specifie d for S: f ormat in P XVFLTR par ameter"
  11489   "RTN","PXV RPC3",31,0 )
  11490    . S ACTON LY=PXVTYPE '="H" ; Ac tiveOnly i s any type  (A or *)  except H
  11491   "RTN","PXV RPC3",32,0 )
  11492    . S SELHI ST=PXVTYPE '="A" ; Se lectable f or Histori c is any t ype (H or  *) except  A
  11493   "RTN","PXV RPC3",33,0 )
  11494    E  S PXVV ALID=0,PXV ERMSG="Inv alid Param eter(s)"
  11495   "RTN","PXV RPC3",34,0 )
  11496    I 'PXVVAL ID S @PXVR ET@(0)=-1_ U_PXVERMSG  Q
  11497   "RTN","PXV RPC3",35,0 )
  11498    S PXVBRIE F=".01;.02 ;.03;.05;. 07;8801;88 02;8803"
  11499   "RTN","PXV RPC3",36,0 )
  11500    S PXVCNT= 0
  11501   "RTN","PXV RPC3",37,0 )
  11502    S PXVFILE =9999999.1 4
  11503   "RTN","PXV RPC3",38,0 )
  11504    I PXVFMT= "R" D
  11505   "RTN","PXV RPC3",39,0 )
  11506    . D GETFL DS
  11507   "RTN","PXV RPC3",40,0 )
  11508    E  I PXVF MT="S" D
  11509   "RTN","PXV RPC3",41,0 )
  11510    . S PXVIE N=0
  11511   "RTN","PXV RPC3",42,0 )
  11512    . F  S PX VIEN=$O(@P XVGBL@(PXV IEN)) Q:'P XVIEN  D G ETFLDS
  11513   "RTN","PXV RPC3",43,0 )
  11514    S @PXVRET @(0)=PXVCN T ; Put th e number o f returned  records i n the firs t node of  the array
  11515   "RTN","PXV RPC3",44,0 )
  11516    Q
  11517   "RTN","PXV RPC3",45,0 )
  11518   GETFLDS ;  Get fields  for one I EN
  11519   "RTN","PXV RPC3",46,0 )
  11520    S PXVIENS =PXVIEN_", "
  11521   "RTN","PXV RPC3",47,0 )
  11522    K PXVDATA ,PXVERR
  11523   "RTN","PXV RPC3",48,0 )
  11524    I 'SUBFIL ES D GETS^ DIQ(PXVFIL E,PXVIENS, PXVBRIEF," I","PXVDAT A","PXVERR ")
  11525   "RTN","PXV RPC3",49,0 )
  11526    I SUBFILE S D GETS^D IQ(PXVFILE ,PXVIENS," **","IE"," PXVDATA"," PXVERR")
  11527   "RTN","PXV RPC3",50,0 )
  11528    S PXVREF= $NA(PXVDAT A(PXVFILE, PXVIENS))
  11529   "RTN","PXV RPC3",51,0 )
  11530    S PXVSTR= ""
  11531   "RTN","PXV RPC3",52,0 )
  11532    S $P(PXVS TR,U,1)=PX VIEN
  11533   "RTN","PXV RPC3",53,0 )
  11534    ; NAME
  11535   "RTN","PXV RPC3",54,0 )
  11536    S $P(PXVS TR,U,2)=@P XVREF@(.01 ,"I")
  11537   "RTN","PXV RPC3",55,0 )
  11538    S $P(PXVS TR,U,3)=@P XVREF@(.02 ,"I")
  11539   "RTN","PXV RPC3",56,0 )
  11540    S $P(PXVS TR,U,4)=@P XVREF@(.03 ,"I")
  11541   "RTN","PXV RPC3",57,0 )
  11542    S $P(PXVS TR,U,5)=@P XVREF@(.05 ,"I")
  11543   "RTN","PXV RPC3",58,0 )
  11544    ; INACTIV E FLAG - R eturn 0 or  1 instead  of "" or  1
  11545   "RTN","PXV RPC3",59,0 )
  11546    S (PXVTEM P,$P(PXVST R,U,6))=+@ PXVREF@(.0 7,"I")
  11547   "RTN","PXV RPC3",60,0 )
  11548    S PXVACTI V='PXVTEMP
  11549   "RTN","PXV RPC3",61,0 )
  11550    S $P(PXVS TR,U,7)=@P XVREF@(880 1,"I")
  11551   "RTN","PXV RPC3",62,0 )
  11552    S $P(PXVS TR,U,8)=@P XVREF@(880 2,"I")
  11553   "RTN","PXV RPC3",63,0 )
  11554    S (PXVTEM P,$P(PXVST R,U,9))=@P XVREF@(880 3,"I")
  11555   "RTN","PXV RPC3",64,0 )
  11556    S PXVHIST R=PXVTEMP= "Y"
  11557   "RTN","PXV RPC3",65,0 )
  11558    S PXVINCL U=1 ; Assu me the rec ord is to  be include d until pr oven other wise
  11559   "RTN","PXV RPC3",66,0 )
  11560    I PXVFMT' ="R",PXVTY PE'="*" D
  11561   "RTN","PXV RPC3",67,0 )
  11562    . I ACTON LY,'PXVACT IV S PXVIN CLU=0
  11563   "RTN","PXV RPC3",68,0 )
  11564    . E  I SE LHIST,'PXV HISTR S PX VINCLU=0
  11565   "RTN","PXV RPC3",69,0 )
  11566    Q:'PXVINC LU
  11567   "RTN","PXV RPC3",70,0 )
  11568    D:SUBFILE S SUBFILES
  11569   "RTN","PXV RPC3",71,0 )
  11570    S PXVCNT= PXVCNT+1
  11571   "RTN","PXV RPC3",72,0 )
  11572    S @PXVRET @(PXVCNT)= PXVSTR
  11573   "RTN","PXV RPC3",73,0 )
  11574    Q
  11575   "RTN","PXV RPC3",74,0 )
  11576   SUBFILES ;  Add the s ubfile mul tiples to  the array
  11577   "RTN","PXV RPC3",75,0 )
  11578    ; Subfile s:
  11579   "RTN","PXV RPC3",76,0 )
  11580    S PXVDLM1 ="|",PXVDL M2="~",PXV DLM3=";;"
  11581   "RTN","PXV RPC3",77,0 )
  11582    ; Field 2  - CDC FUL L VACCINE  NAME
  11583   "RTN","PXV RPC3",78,0 )
  11584    ; There's  only one  entry in F ield 2 for  each Immu nization,  but that m ay change
  11585   "RTN","PXV RPC3",79,0 )
  11586    S PXVSUB= "",PXVSUBC =0
  11587   "RTN","PXV RPC3",80,0 )
  11588    F  S PXVS UBC=PXVSUB C+1 Q:'$D( @PXVREF@(2 ,PXVSUBC))   D
  11589   "RTN","PXV RPC3",81,0 )
  11590    . S $P(PX VSUB,PXVDL M1,PXVSUBC )=@PXVREF@ (2,PXVSUBC )
  11591   "RTN","PXV RPC3",82,0 )
  11592    S $P(PXVS TR,U,10)=P XVSUB
  11593   "RTN","PXV RPC3",83,0 )
  11594    ; Field 3  - CODING  SYSTEM
  11595   "RTN","PXV RPC3",84,0 )
  11596    S PXVREF= $NA(PXVDAT A(PXVFILE_ "3"))
  11597   "RTN","PXV RPC3",85,0 )
  11598    S PXVSBSC R="",PXVSU B="",PXVSU BC=0
  11599   "RTN","PXV RPC3",86,0 )
  11600    F  S PXVS BSCR=$O(@P XVREF@(PXV SBSCR)) Q: PXVSBSCR=" "  D
  11601   "RTN","PXV RPC3",87,0 )
  11602    . S PXVSU BC=PXVSUBC +1
  11603   "RTN","PXV RPC3",88,0 )
  11604    . K PXVSD ATA,PXVSER R
  11605   "RTN","PXV RPC3",89,0 )
  11606    . D GETS^ DIQ(PXVFIL E_"3",PXVS BSCR,"**", "","PXVSDA TA","PXVSE RR")
  11607   "RTN","PXV RPC3",90,0 )
  11608    . S PXVSV SC2="",PXV SUB2C=0,PX VSUB2=""
  11609   "RTN","PXV RPC3",91,0 )
  11610    . F  S PX VSVSC2=$O( PXVSDATA(P XVFILE_"31 ",PXVSVSC2 )) Q:PXVSV SC2=""  D
  11611   "RTN","PXV RPC3",92,0 )
  11612    . . S PXV SUB2C=PXVS UB2C+1
  11613   "RTN","PXV RPC3",93,0 )
  11614    . . S $P( PXVSUB2,PX VDLM3,PXVS UB2C)=PXVS DATA(PXVFI LE_"31",PX VSVSC2,.01 )
  11615   "RTN","PXV RPC3",94,0 )
  11616    . S $P(PX VSUB,PXVDL M1,PXVSUBC )=@PXVREF@ (PXVSBSCR, .01,"I")_P XVDLM2_PXV SUB2
  11617   "RTN","PXV RPC3",95,0 )
  11618    S $P(PXVS TR,U,11)=P XVSUB
  11619   "RTN","PXV RPC3",96,0 )
  11620    ; Field 4  - VACCINE  INFORMATI ON STATEME NT
  11621   "RTN","PXV RPC3",97,0 )
  11622    S PXVREF= $NA(PXVDAT A(PXVFILE_ "4"))
  11623   "RTN","PXV RPC3",98,0 )
  11624    S PXVSBSC R="",PXVSU B="",PXVSU BC=0
  11625   "RTN","PXV RPC3",99,0 )
  11626    F  S PXVS BSCR=$O(@P XVREF@(PXV SBSCR)) Q: PXVSBSCR=" "  D
  11627   "RTN","PXV RPC3",100, 0)
  11628    . S PXVSU BC=PXVSUBC +1
  11629   "RTN","PXV RPC3",101, 0)
  11630    . S $P(PX VSUB,PXVDL M1,PXVSUBC )=@PXVREF@ (PXVSBSCR, .01,"I")_P XVDLM2_@PX VREF@(PXVS BSCR,.01," E")
  11631   "RTN","PXV RPC3",102, 0)
  11632    S $P(PXVS TR,U,12)=P XVSUB
  11633   "RTN","PXV RPC3",103, 0)
  11634    ; Field 5  - CDC PRO DUCT NAME
  11635   "RTN","PXV RPC3",104, 0)
  11636    S PXVREF= $NA(PXVDAT A(PXVFILE_ "5"))
  11637   "RTN","PXV RPC3",105, 0)
  11638    S PXVSBSC R="",PXVSU B="",PXVSU BC=0
  11639   "RTN","PXV RPC3",106, 0)
  11640    F  S PXVS BSCR=$O(@P XVREF@(PXV SBSCR)) Q: PXVSBSCR=" "  D
  11641   "RTN","PXV RPC3",107, 0)
  11642    . S PXVSU BC=PXVSUBC +1
  11643   "RTN","PXV RPC3",108, 0)
  11644    . S $P(PX VSUB,PXVDL M1,PXVSUBC )=@PXVREF@ (PXVSBSCR, .01,"I")
  11645   "RTN","PXV RPC3",109, 0)
  11646    S $P(PXVS TR,U,13)=P XVSUB
  11647   "RTN","PXV RPC3",110, 0)
  11648    ; Field 7  - VACCINE  GROUP NAM E
  11649   "RTN","PXV RPC3",111, 0)
  11650    S PXVREF= $NA(PXVDAT A(PXVFILE_ "7"))
  11651   "RTN","PXV RPC3",112, 0)
  11652    S PXVSBSC R="",PXVSU B="",PXVSU BC=0
  11653   "RTN","PXV RPC3",113, 0)
  11654    F  S PXVS BSCR=$O(@P XVREF@(PXV SBSCR)) Q: PXVSBSCR=" "  D
  11655   "RTN","PXV RPC3",114, 0)
  11656    . S PXVSU BC=PXVSUBC +1
  11657   "RTN","PXV RPC3",115, 0)
  11658    . S $P(PX VSUB,PXVDL M1,PXVSUBC )=@PXVREF@ (PXVSBSCR, .01,"I")
  11659   "RTN","PXV RPC3",116, 0)
  11660    S $P(PXVS TR,U,14)=P XVSUB
  11661   "RTN","PXV RPC3",117, 0)
  11662    ; Field 1 0 - SYNONY M
  11663   "RTN","PXV RPC3",118, 0)
  11664    S PXVREF= $NA(PXVDAT A(PXVFILE_ "1"))
  11665   "RTN","PXV RPC3",119, 0)
  11666    S PXVSBSC R="",PXVSU B="",PXVSU BC=0
  11667   "RTN","PXV RPC3",120, 0)
  11668    F  S PXVS BSCR=$O(@P XVREF@(PXV SBSCR)) Q: PXVSBSCR=" "  D
  11669   "RTN","PXV RPC3",121, 0)
  11670    . S PXVSU BC=PXVSUBC +1
  11671   "RTN","PXV RPC3",122, 0)
  11672    . S $P(PX VSUB,PXVDL M1,PXVSUBC )=@PXVREF@ (PXVSBSCR, .01,"I")
  11673   "RTN","PXV RPC3",123, 0)
  11674    S $P(PXVS TR,U,15)=P XVSUB
  11675   "RTN","PXV RPC3",124, 0)
  11676    ; Field 9 9.991 - EF FECTIVE DA TE/TIME
  11677   "RTN","PXV RPC3",125, 0)
  11678    S PXVREF= $NA(PXVDAT A(PXVFILE_ "99"))
  11679   "RTN","PXV RPC3",126, 0)
  11680    S PXVSBSC R="",PXVSU B="",PXVSU BC=0
  11681   "RTN","PXV RPC3",127, 0)
  11682    F  S PXVS BSCR=$O(@P XVREF@(PXV SBSCR)) Q: PXVSBSCR=" "  D
  11683   "RTN","PXV RPC3",128, 0)
  11684    . S PXVSU BC=PXVSUBC +1
  11685   "RTN","PXV RPC3",129, 0)
  11686    . S $P(PX VSUB,PXVDL M1,PXVSUBC )=@PXVREF@ (PXVSBSCR, .01,"I")_P XVDLM2_@PX VREF@(PXVS BSCR,.02," I")
  11687   "RTN","PXV RPC3",130, 0)
  11688    S $P(PXVS TR,U,16)=P XVSUB
  11689   "RTN","PXV RPC3",131, 0)
  11690    Q
  11691   "RTN","PXV RPC4")
  11692   0^27^B1313 21819^n/a
  11693   "RTN","PXV RPC4",1,0)
  11694   PXVRPC4 ;B PFO/LMT -  PCE RPCs f or Immuniz ation(s) ; 03/10/16   21:16
  11695   "RTN","PXV RPC4",2,0)
  11696    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  11697   "RTN","PXV RPC4",3,0)
  11698    ;
  11699   "RTN","PXV RPC4",4,0)
  11700    ; Referen ce to ^DIA (9999999.1 4,"C") sup ported by  ICR #2602
  11701   "RTN","PXV RPC4",5,0)
  11702    ; Referen ce to NAME  in file . 85 is supp orted by I CR #6062
  11703   "RTN","PXV RPC4",6,0)
  11704    ;
  11705   "RTN","PXV RPC4",7,0)
  11706   IMMRPC(PXR TRN,PXIMM, PXDATE) ;  Entry poin t for RPC
  11707   "RTN","PXV RPC4",8,0)
  11708    ;
  11709   "RTN","PXV RPC4",9,0)
  11710    ; Returns  an Immuni zation obj ect
  11711   "RTN","PXV RPC4",10,0 )
  11712    ;
  11713   "RTN","PXV RPC4",11,0 )
  11714    ;Input:
  11715   "RTN","PXV RPC4",12,0 )
  11716    ;  PXRTRN  - Return  value pass ed by refe rence (Req uired)
  11717   "RTN","PXV RPC4",13,0 )
  11718    ;   PXIMM  - Pointer  to #99999 99.14 (Req uired)
  11719   "RTN","PXV RPC4",14,0 )
  11720    ;  PXDATE  - Immuniz ation stat us and Cod es will be  based off  this date
  11721   "RTN","PXV RPC4",15,0 )
  11722    ;            (Option al; Defaul ts to NOW)
  11723   "RTN","PXV RPC4",16,0 )
  11724    ;
  11725   "RTN","PXV RPC4",17,0 )
  11726    ;Returns:
  11727   "RTN","PXV RPC4",18,0 )
  11728    ;   ^TMP( "PXVIMMRPC ",$J,0)
  11729   "RTN","PXV RPC4",19,0 )
  11730    ;      1:   1 - Immu nization w as found.  The "1" no de will be  returned,  but
  11731   "RTN","PXV RPC4",20,0 )
  11732    ;               the  other node s are opti onal.
  11733   "RTN","PXV RPC4",21,0 )
  11734    ;          -1 - Immu nization w as not fou nd; no oth er nodes w ill be ret urned
  11735   "RTN","PXV RPC4",22,0 )
  11736    ;   ^TMP( "PXVIMMRPC ",$J,1)
  11737   "RTN","PXV RPC4",23,0 )
  11738    ;      No te: Status  (in the 5 th piece)  is determi ned as fol lows:
  11739   "RTN","PXV RPC4",24,0 )
  11740    ;         - If PXDAT E is today , the stat us is base d off the  Inactive F lag (#.07)
  11741   "RTN","PXV RPC4",25,0 )
  11742    ;         - If PXDAT E is diffe rent than  today, we  will look  when an up date was
  11743   "RTN","PXV RPC4",26,0 )
  11744    ;           last mad e to the I mmunizatio n file (ba sed off th e Audits).
  11745   "RTN","PXV RPC4",27,0 )
  11746    ;           If there  have not  been any c hanges sin ce PXDATE,  we will g et the
  11747   "RTN","PXV RPC4",28,0 )
  11748    ;           status b ased off t he Inactiv e Flag, ot herwise, w e will get  the
  11749   "RTN","PXV RPC4",29,0 )
  11750    ;           status f or that da te by call ing GETSTA T^XTID.
  11751   "RTN","PXV RPC4",30,0 )
  11752    ;      1:  "IMM"
  11753   "RTN","PXV RPC4",31,0 )
  11754    ;      2:  #9999999. 14 IEN
  11755   "RTN","PXV RPC4",32,0 )
  11756    ;      3:  Name (#.0 1)
  11757   "RTN","PXV RPC4",33,0 )
  11758    ;      4:  CVX Code  (#.03)
  11759   "RTN","PXV RPC4",34,0 )
  11760    ;      5:  Status (1 : Active;  0: Inactiv e)
  11761   "RTN","PXV RPC4",35,0 )
  11762    ;      6:  Selectabl e for Hist oric (#880 3)
  11763   "RTN","PXV RPC4",36,0 )
  11764    ;      7:  Mnemonic  (#8801)
  11765   "RTN","PXV RPC4",37,0 )
  11766    ;      8:  Acronym ( #8802)
  11767   "RTN","PXV RPC4",38,0 )
  11768    ;      9:  Max # In  Series (#. 05)
  11769   "RTN","PXV RPC4",39,0 )
  11770    ;      10 : Combinat ion Immuni zation (Y/ N) (#.2)
  11771   "RTN","PXV RPC4",40,0 )
  11772    ;      11 : Reading  Required ( #.51)
  11773   "RTN","PXV RPC4",41,0 )
  11774    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11775   "RTN","PXV RPC4",42,0 )
  11776    ;      1:  "VIS"
  11777   "RTN","PXV RPC4",43,0 )
  11778    ;      2:  #920 IEN
  11779   "RTN","PXV RPC4",44,0 )
  11780    ;      3:  Name (#92 0,#.01)
  11781   "RTN","PXV RPC4",45,0 )
  11782    ;      4:  Edition D ate (#920, #.02)
  11783   "RTN","PXV RPC4",46,0 )
  11784    ;      5:  Edition S tatus (#92 0,#.03)
  11785   "RTN","PXV RPC4",47,0 )
  11786    ;      6:  Language  (#920, #.0 4)
  11787   "RTN","PXV RPC4",48,0 )
  11788    ;      7:  2D Bar Co de (#100)
  11789   "RTN","PXV RPC4",49,0 )
  11790    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11791   "RTN","PXV RPC4",50,0 )
  11792    ;      1:  "CDC"
  11793   "RTN","PXV RPC4",51,0 )
  11794    ;      2:  CDC Produ ct Name (# 9999999.14 5, #.01)
  11795   "RTN","PXV RPC4",52,0 )
  11796    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11797   "RTN","PXV RPC4",53,0 )
  11798    ;      1:  "GROUP"
  11799   "RTN","PXV RPC4",54,0 )
  11800    ;      2:  Vaccine G roup Name  (#9999999. 147, #.01)
  11801   "RTN","PXV RPC4",55,0 )
  11802    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11803   "RTN","PXV RPC4",56,0 )
  11804    ;      1:  "SYNONYM"
  11805   "RTN","PXV RPC4",57,0 )
  11806    ;      2:  Synonym ( #9999999.1 41, #.01)
  11807   "RTN","PXV RPC4",58,0 )
  11808    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11809   "RTN","PXV RPC4",59,0 )
  11810    ;      No te: Only a ctive code s (based o ff PXDATE)  are retur ned.
  11811   "RTN","PXV RPC4",60,0 )
  11812    ;      1:  "CS"
  11813   "RTN","PXV RPC4",61,0 )
  11814    ;      2:  Coding Sy stem (#999 9999.143,  #.01)
  11815   "RTN","PXV RPC4",62,0 )
  11816    ;      3:  Code (#99 99999.1431 ,#.01)
  11817   "RTN","PXV RPC4",63,0 )
  11818    ;      4:  Variable  pointer. e .g., IEN;I CPT(
  11819   "RTN","PXV RPC4",64,0 )
  11820    ;      5:  Short Des cription
  11821   "RTN","PXV RPC4",65,0 )
  11822    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11823   "RTN","PXV RPC4",66,0 )
  11824    ;      No te: Only a ctive lots  are retur ned.
  11825   "RTN","PXV RPC4",67,0 )
  11826    ;             Also,  the Expira tion date  must be >=  PXDATE
  11827   "RTN","PXV RPC4",68,0 )
  11828    ;      1:  "LOT"
  11829   "RTN","PXV RPC4",69,0 )
  11830    ;      2:  #9999999. 41 IEN
  11831   "RTN","PXV RPC4",70,0 )
  11832    ;      3:  Lot Numbe r (#999999 9.41, #.01 )
  11833   "RTN","PXV RPC4",71,0 )
  11834    ;      4:  Manufactu rer (#9999 999.04, #. 01)
  11835   "RTN","PXV RPC4",72,0 )
  11836    ;      5:  Expiratio n Date (#9 999999.41,  #.09)
  11837   "RTN","PXV RPC4",73,0 )
  11838    ;      6:  Doses Unu sed (#9999 999.41, #. 12)
  11839   "RTN","PXV RPC4",74,0 )
  11840    ;      7:  Low Suppl y Alert (# 9999999.41 , #.15)
  11841   "RTN","PXV RPC4",75,0 )
  11842    ;      8:  NDC Code  (#9999999. 41, #.18)
  11843   "RTN","PXV RPC4",76,0 )
  11844    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11845   "RTN","PXV RPC4",77,0 )
  11846    ;      No te: Only a ctive cont raindicati ons are re turned
  11847   "RTN","PXV RPC4",78,0 )
  11848    ;      1:  "CONTRA"
  11849   "RTN","PXV RPC4",79,0 )
  11850    ;      2:  #920.4 va riable poi nter: IEN; PXV(920.4,
  11851   "RTN","PXV RPC4",80,0 )
  11852    ;      3:  Name (#92 0.4, #.01)
  11853   "RTN","PXV RPC4",81,0 )
  11854    ;      4:  Status (1 :Active, 0 :Inactive)
  11855   "RTN","PXV RPC4",82,0 )
  11856    ;      5:  Code|Codi ng System  (#920.4, # .02 and .0 5)
  11857   "RTN","PXV RPC4",83,0 )
  11858    ;      6:  NIP004 (# 920.4, #.0 4)
  11859   "RTN","PXV RPC4",84,0 )
  11860    ;      7:  Contraind ication/Pr ecaution ( #920.4, #. 06)
  11861   "RTN","PXV RPC4",85,0 )
  11862    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11863   "RTN","PXV RPC4",86,0 )
  11864    ;      1:  "DEF"
  11865   "RTN","PXV RPC4",87,0 )
  11866    ;      2:  Default R oute (#920 .051, #130 2)
  11867   "RTN","PXV RPC4",88,0 )
  11868    ;      3:  Default S ite (#920. 051, #1303 )
  11869   "RTN","PXV RPC4",89,0 )
  11870    ;      4:  Default D ose (#920. 051, #1312 )
  11871   "RTN","PXV RPC4",90,0 )
  11872    ;      5:  Default D ose Units  (#920.051,  #1313)
  11873   "RTN","PXV RPC4",91,0 )
  11874    ;      6:  Default D ose Units  (external  format) (# 920.051, # 1313)
  11875   "RTN","PXV RPC4",92,0 )
  11876    ;   ^TMP( "PXVIMMRPC ",$J,x)
  11877   "RTN","PXV RPC4",93,0 )
  11878    ;      1:  "DEFC"
  11879   "RTN","PXV RPC4",94,0 )
  11880    ;      2:  Default C omments (# 920.051, # 81101)
  11881   "RTN","PXV RPC4",95,0 )
  11882    ;
  11883   "RTN","PXV RPC4",96,0 )
  11884    N PXCNT,P XCODESYS,P XFLD,PXI,P XIMMARR,PX IMMSUB,PXN ODE,PXSUB
  11885   "RTN","PXV RPC4",97,0 )
  11886    ;
  11887   "RTN","PXV RPC4",98,0 )
  11888    S PXSUB=" PXVIMMRPC"
  11889   "RTN","PXV RPC4",99,0 )
  11890    S PXRTRN= $NA(^TMP(P XSUB,$J))
  11891   "RTN","PXV RPC4",100, 0)
  11892    K ^TMP(PX SUB,$J)
  11893   "RTN","PXV RPC4",101, 0)
  11894    ;
  11895   "RTN","PXV RPC4",102, 0)
  11896    D GETIMM( .PXIMMARR, $G(PXIMM), $G(PXDATE) )
  11897   "RTN","PXV RPC4",103, 0)
  11898    S PXIMMSU B="PXVIMM"
  11899   "RTN","PXV RPC4",104, 0)
  11900    ;
  11901   "RTN","PXV RPC4",105, 0)
  11902    S PXCNT=0
  11903   "RTN","PXV RPC4",106, 0)
  11904    ;
  11905   "RTN","PXV RPC4",107, 0)
  11906    I '$D(^TM P(PXIMMSUB ,$J)) D  Q
  11907   "RTN","PXV RPC4",108, 0)
  11908    . S ^TMP( PXSUB,$J,P XCNT)="-1"
  11909   "RTN","PXV RPC4",109, 0)
  11910    ;
  11911   "RTN","PXV RPC4",110, 0)
  11912    S ^TMP(PX SUB,$J,PXC NT)=1
  11913   "RTN","PXV RPC4",111, 0)
  11914    S PXCNT=P XCNT+1
  11915   "RTN","PXV RPC4",112, 0)
  11916    S ^TMP(PX SUB,$J,PXC NT)="IMM"_ U_$G(^TMP( PXIMMSUB,$ J,0))
  11917   "RTN","PXV RPC4",113, 0)
  11918    ;
  11919   "RTN","PXV RPC4",114, 0)
  11920    F PXFLD=" VIS","LOT" ,"CDC","GR OUP","SYNO NYM","CONT RA","DEF", "DEFC" D
  11921   "RTN","PXV RPC4",115, 0)
  11922    . I '$D(^ TMP(PXIMMS UB,$J,PXFL D)) Q
  11923   "RTN","PXV RPC4",116, 0)
  11924    . S PXI=0  F  S PXI= $O(^TMP(PX IMMSUB,$J, PXFLD,PXI) ) Q:'PXI   D
  11925   "RTN","PXV RPC4",117, 0)
  11926    . . S PXN ODE=$G(^TM P(PXIMMSUB ,$J,PXFLD, PXI,0))
  11927   "RTN","PXV RPC4",118, 0)
  11928    . . I PXN ODE="" Q
  11929   "RTN","PXV RPC4",119, 0)
  11930    . . S PXC NT=PXCNT+1
  11931   "RTN","PXV RPC4",120, 0)
  11932    . . S ^TM P(PXSUB,$J ,PXCNT)=PX FLD_U_PXNO DE
  11933   "RTN","PXV RPC4",121, 0)
  11934    ;
  11935   "RTN","PXV RPC4",122, 0)
  11936    S PXFLD=" CS"
  11937   "RTN","PXV RPC4",123, 0)
  11938    I $D(^TMP (PXIMMSUB, $J,PXFLD))  D
  11939   "RTN","PXV RPC4",124, 0)
  11940    . S PXCOD ESYS=""
  11941   "RTN","PXV RPC4",125, 0)
  11942    . F  S PX CODESYS=$O (^TMP(PXIM MSUB,$J,PX FLD,PXCODE SYS)) Q:PX CODESYS=""   D
  11943   "RTN","PXV RPC4",126, 0)
  11944    . . S PXI =0
  11945   "RTN","PXV RPC4",127, 0)
  11946    . . F  S  PXI=$O(^TM P(PXIMMSUB ,$J,PXFLD, PXCODESYS, PXI)) Q:'P XI  D
  11947   "RTN","PXV RPC4",128, 0)
  11948    . . . S P XNODE=$G(^ TMP(PXIMMS UB,$J,PXFL D,PXCODESY S,PXI,0))
  11949   "RTN","PXV RPC4",129, 0)
  11950    . . . I P XNODE="" Q
  11951   "RTN","PXV RPC4",130, 0)
  11952    . . . S P XCNT=PXCNT +1
  11953   "RTN","PXV RPC4",131, 0)
  11954    . . . S ^ TMP(PXSUB, $J,PXCNT)= PXFLD_U_PX CODESYS_U_ PXNODE
  11955   "RTN","PXV RPC4",132, 0)
  11956    ;
  11957   "RTN","PXV RPC4",133, 0)
  11958    K ^TMP(PX IMMSUB,$J)
  11959   "RTN","PXV RPC4",134, 0)
  11960    ;
  11961   "RTN","PXV RPC4",135, 0)
  11962    Q
  11963   "RTN","PXV RPC4",136, 0)
  11964    ;
  11965   "RTN","PXV RPC4",137, 0)
  11966   GETIMM(PXR TRN,PXIMM, PXDATE) ;  Entry poin t for API
  11967   "RTN","PXV RPC4",138, 0)
  11968    ;
  11969   "RTN","PXV RPC4",139, 0)
  11970    N PXAUDIT ,PXI,PXNOD E,PXNODE0, PXNODETMP, PXSUB
  11971   "RTN","PXV RPC4",140, 0)
  11972    ;
  11973   "RTN","PXV RPC4",141, 0)
  11974    S PXSUB=" PXVIMM"
  11975   "RTN","PXV RPC4",142, 0)
  11976    K ^TMP(PX SUB,$J)
  11977   "RTN","PXV RPC4",143, 0)
  11978    S PXRTRN= $NA(^TMP(P XSUB,$J))
  11979   "RTN","PXV RPC4",144, 0)
  11980    ;
  11981   "RTN","PXV RPC4",145, 0)
  11982    I '$G(PXI MM) Q
  11983   "RTN","PXV RPC4",146, 0)
  11984    I '$D(^AU TTIMM(PXIM M,0)) Q
  11985   "RTN","PXV RPC4",147, 0)
  11986    I '$G(PXD ATE) S PXD ATE=$$NOW^ XLFDT()
  11987   "RTN","PXV RPC4",148, 0)
  11988    S PXAUDIT =0
  11989   "RTN","PXV RPC4",149, 0)
  11990    I $$GET1^ DID(999999 9.14,.07," ","AUDIT") ="YES, ALW AYS" S PXA UDIT=1
  11991   "RTN","PXV RPC4",150, 0)
  11992    ;
  11993   "RTN","PXV RPC4",151, 0)
  11994    S PXNODE0 =^AUTTIMM( PXIMM,0)
  11995   "RTN","PXV RPC4",152, 0)
  11996    S PXNODET MP=PXIMM_U _$P(PXNODE 0,U,1)_U_$ P(PXNODE0, U,3)
  11997   "RTN","PXV RPC4",153, 0)
  11998    S PXNODET MP=PXNODET MP_U_$$GET STAT(PXIMM ,PXDATE,$$ GETCSTAT(P XDATE,PXAU DIT),PXAUD IT)
  11999   "RTN","PXV RPC4",154, 0)
  12000    S PXNODE= $P($G(^AUT TIMM(PXIMM ,6)),U,1)
  12001   "RTN","PXV RPC4",155, 0)
  12002    S PXNODET MP=PXNODET MP_U_PXNOD E
  12003   "RTN","PXV RPC4",156, 0)
  12004    S PXNODE= $G(^AUTTIM M(PXIMM,88 ))
  12005   "RTN","PXV RPC4",157, 0)
  12006    S PXNODET MP=PXNODET MP_U_$P(PX NODE,U,1)
  12007   "RTN","PXV RPC4",158, 0)
  12008    S PXNODET MP=PXNODET MP_U_$P(PX NODE,U,2)
  12009   "RTN","PXV RPC4",159, 0)
  12010    S PXNODET MP=PXNODET MP_U_$P(PX NODE0,U,5) _U_$P(PXNO DE0,U,20)
  12011   "RTN","PXV RPC4",160, 0)
  12012    S PXNODE= $P($G(^AUT TIMM(PXIMM ,.5)),U,1)
  12013   "RTN","PXV RPC4",161, 0)
  12014    S PXNODET MP=PXNODET MP_U_PXNOD E
  12015   "RTN","PXV RPC4",162, 0)
  12016    S ^TMP(PX SUB,$J,0)= PXNODETMP
  12017   "RTN","PXV RPC4",163, 0)
  12018    ;
  12019   "RTN","PXV RPC4",164, 0)
  12020    I $D(^AUT TIMM(PXIMM ,3)) D GET CS(PXSUB,P XIMM,PXDAT E)
  12021   "RTN","PXV RPC4",165, 0)
  12022    I $D(^AUT TIMM(PXIMM ,4)) D GET VIS(PXSUB, PXIMM)
  12023   "RTN","PXV RPC4",166, 0)
  12024    F PXI=5,7 ,10 I $D(^ AUTTIMM(PX IMM,PXI))  D GETSUBS( PXSUB,PXIM M,PXI)
  12025   "RTN","PXV RPC4",167, 0)
  12026    D GETLOT( PXSUB,PXIM M,PXDATE)
  12027   "RTN","PXV RPC4",168, 0)
  12028    D GETCONT (PXSUB,PXI MM) ; Get  Contraindi cations
  12029   "RTN","PXV RPC4",169, 0)
  12030    D GETDEF( PXSUB,PXIM M) ; Get D efaults
  12031   "RTN","PXV RPC4",170, 0)
  12032    ;
  12033   "RTN","PXV RPC4",171, 0)
  12034    Q
  12035   "RTN","PXV RPC4",172, 0)
  12036    ;
  12037   "RTN","PXV RPC4",173, 0)
  12038   GETCS(PXSU B,PXIMM,PX DATE) ;
  12039   "RTN","PXV RPC4",174, 0)
  12040    ;
  12041   "RTN","PXV RPC4",175, 0)
  12042    N PXCNT,P XCODE,PXCO DESYS,PXCO DESYSLEX,P XLEX,PXLEX ADATE,PXLE XARY,PXLEX IDATE,PXLE XNODE,PXLE XSUB,PXX,P XY
  12043   "RTN","PXV RPC4",176, 0)
  12044    ;
  12045   "RTN","PXV RPC4",177, 0)
  12046    S PXDATE= $P(PXDATE, ".",1)
  12047   "RTN","PXV RPC4",178, 0)
  12048    S PXCNT=0
  12049   "RTN","PXV RPC4",179, 0)
  12050    ;
  12051   "RTN","PXV RPC4",180, 0)
  12052    S PXX=0
  12053   "RTN","PXV RPC4",181, 0)
  12054    F  S PXX= $O(^AUTTIM M(PXIMM,3, PXX)) Q:'P XX  D
  12055   "RTN","PXV RPC4",182, 0)
  12056    . S PXCOD ESYS=$G(^A UTTIMM(PXI MM,3,PXX,0 ))
  12057   "RTN","PXV RPC4",183, 0)
  12058    . I PXCOD ESYS="" Q
  12059   "RTN","PXV RPC4",184, 0)
  12060    . S PXCOD ESYSLEX=PX CODESYS
  12061   "RTN","PXV RPC4",185, 0)
  12062    . I PXCOD ESYSLEX?1( 1"CPT-ADD" ,1"CPT-ADM ") S PXCOD ESYSLEX=$P (PXCODESYS LEX,"-",1)
  12063   "RTN","PXV RPC4",186, 0)
  12064    . S PXY=0  F  S PXY= $O(^AUTTIM M(PXIMM,3, PXX,1,PXY) ) Q:'PXY   D
  12065   "RTN","PXV RPC4",187, 0)
  12066    . . S PXC ODE=$G(^AU TTIMM(PXIM M,3,PXX,1, PXY,0))
  12067   "RTN","PXV RPC4",188, 0)
  12068    . . I PXC ODE="" Q
  12069   "RTN","PXV RPC4",189, 0)
  12070    . . ;
  12071   "RTN","PXV RPC4",190, 0)
  12072    . . K PXL EXARY
  12073   "RTN","PXV RPC4",191, 0)
  12074    . . S PXL EX=$$PERIO D^LEXU(PXC ODE,PXCODE SYSLEX,.PX LEXARY)
  12075   "RTN","PXV RPC4",192, 0)
  12076    . . ;
  12077   "RTN","PXV RPC4",193, 0)
  12078    . . I $P( PXLEX,U,1) =-1 D  Q
  12079   "RTN","PXV RPC4",194, 0)
  12080    . . . I P XCODESYSLE X?1(1"CPT" ,1"10D") Q
  12081   "RTN","PXV RPC4",195, 0)
  12082    . . . S P XCNT=PXCNT +1
  12083   "RTN","PXV RPC4",196, 0)
  12084    . . . S ^ TMP(PXSUB, $J,"CS",PX CODESYS,PX CNT,0)=PXC ODE
  12085   "RTN","PXV RPC4",197, 0)
  12086    . . ;
  12087   "RTN","PXV RPC4",198, 0)
  12088    . . S PXL EXADATE=$O (PXLEXARY( (PXDATE+.0 0001)),-1)
  12089   "RTN","PXV RPC4",199, 0)
  12090    . . I PXL EXADATE=""  Q
  12091   "RTN","PXV RPC4",200, 0)
  12092    . . S PXL EXNODE=$G( PXLEXARY(P XLEXADATE) )
  12093   "RTN","PXV RPC4",201, 0)
  12094    . . S PXL EXIDATE=$P (PXLEXNODE ,U,1)
  12095   "RTN","PXV RPC4",202, 0)
  12096    . . I PXL EXIDATE,PX DATE>PXLEX IDATE Q
  12097   "RTN","PXV RPC4",203, 0)
  12098    . . S PXC NT=PXCNT+1
  12099   "RTN","PXV RPC4",204, 0)
  12100    . . S ^TM P(PXSUB,$J ,"CS",PXCO DESYS,PXCN T,0)=PXCOD E_U_$P(PXL EXNODE,U,3 )_U_$P(PXL EXNODE,U,4 )
  12101   "RTN","PXV RPC4",205, 0)
  12102    ;
  12103   "RTN","PXV RPC4",206, 0)
  12104    Q
  12105   "RTN","PXV RPC4",207, 0)
  12106    ;
  12107   "RTN","PXV RPC4",208, 0)
  12108   GETVIS(PXS UB,PXIMM)  ;
  12109   "RTN","PXV RPC4",209, 0)
  12110    ;
  12111   "RTN","PXV RPC4",210, 0)
  12112    N PXCNT,P XLANG,PXNO DE,PXVIS,P XX
  12113   "RTN","PXV RPC4",211, 0)
  12114    ;
  12115   "RTN","PXV RPC4",212, 0)
  12116    S PXCNT=0
  12117   "RTN","PXV RPC4",213, 0)
  12118    S PXX=0
  12119   "RTN","PXV RPC4",214, 0)
  12120    F  S PXX= $O(^AUTTIM M(PXIMM,4, PXX)) Q:'P XX  D
  12121   "RTN","PXV RPC4",215, 0)
  12122    . S PXVIS =+$G(^AUTT IMM(PXIMM, 4,PXX,0))
  12123   "RTN","PXV RPC4",216, 0)
  12124    . I PXVIS '>0 Q
  12125   "RTN","PXV RPC4",217, 0)
  12126    . I '$D(^ AUTTIVIS(P XVIS,0)) Q
  12127   "RTN","PXV RPC4",218, 0)
  12128    . S PXNOD E=$G(^AUTT IVIS(PXVIS ,0))
  12129   "RTN","PXV RPC4",219, 0)
  12130    . I PXNOD E="" Q
  12131   "RTN","PXV RPC4",220, 0)
  12132    . S PXLAN G=$P(PXNOD E,U,4)
  12133   "RTN","PXV RPC4",221, 0)
  12134    . I PXLAN G'="" S PX LANG=$$GET 1^DIQ(.85, PXLANG_"," ,"NAME")   ;ICR 6062
  12135   "RTN","PXV RPC4",222, 0)
  12136    . S PXCNT =PXCNT+1
  12137   "RTN","PXV RPC4",223, 0)
  12138    . S ^TMP( PXSUB,$J," VIS",PXCNT ,0)=PXVIS_ U_$P(PXNOD E,U,1,3)_U _PXLANG
  12139   "RTN","PXV RPC4",224, 0)
  12140    . S PXNOD E=$P($G(^A UTTIVIS(PX VIS,100)), U,1)
  12141   "RTN","PXV RPC4",225, 0)
  12142    . S ^TMP( PXSUB,$J," VIS",PXCNT ,0)=^TMP(P XSUB,$J,"V IS",PXCNT, 0)_U_PXNOD E
  12143   "RTN","PXV RPC4",226, 0)
  12144    Q
  12145   "RTN","PXV RPC4",227, 0)
  12146    ;
  12147   "RTN","PXV RPC4",228, 0)
  12148   GETSUBS(PX SUB,PXIMM, PXMULT) ;
  12149   "RTN","PXV RPC4",229, 0)
  12150    ;
  12151   "RTN","PXV RPC4",230, 0)
  12152    N PXCNT,P XFLD,PXNOD E,PXX
  12153   "RTN","PXV RPC4",231, 0)
  12154    ;
  12155   "RTN","PXV RPC4",232, 0)
  12156    S PXFLD=$ S(PXMULT=5 :"CDC",PXM ULT=7:"GRO UP",PXMULT =10:"SYNON YM",1:"")
  12157   "RTN","PXV RPC4",233, 0)
  12158    I PXFLD=" " Q
  12159   "RTN","PXV RPC4",234, 0)
  12160    S PXCNT=0
  12161   "RTN","PXV RPC4",235, 0)
  12162    S PXX=0 F   S PXX=$O (^AUTTIMM( PXIMM,PXMU LT,PXX)) Q :'PXX  D
  12163   "RTN","PXV RPC4",236, 0)
  12164    . S PXNOD E=$G(^AUTT IMM(PXIMM, PXMULT,PXX ,0)) Q:PXN ODE=""
  12165   "RTN","PXV RPC4",237, 0)
  12166    . S PXCNT =PXCNT+1
  12167   "RTN","PXV RPC4",238, 0)
  12168    . S ^TMP( PXSUB,$J,P XFLD,PXCNT ,0)=PXNODE
  12169   "RTN","PXV RPC4",239, 0)
  12170    Q
  12171   "RTN","PXV RPC4",240, 0)
  12172    ;
  12173   "RTN","PXV RPC4",241, 0)
  12174   GETLOT(PXS UB,PXIMM,P XDATE) ;
  12175   "RTN","PXV RPC4",242, 0)
  12176    ;
  12177   "RTN","PXV RPC4",243, 0)
  12178    N PXCNT,P XEXPDATE,P XLOT,PXMAN ,PXNDC,PXN ODE,PXSTAT ,PXTEMP
  12179   "RTN","PXV RPC4",244, 0)
  12180    ;
  12181   "RTN","PXV RPC4",245, 0)
  12182    S PXCNT=0
  12183   "RTN","PXV RPC4",246, 0)
  12184    S PXLOT=0
  12185   "RTN","PXV RPC4",247, 0)
  12186    F  S PXLO T=$O(^AUTT IML("C",PX IMM,PXLOT) ) Q:'PXLOT   D
  12187   "RTN","PXV RPC4",248, 0)
  12188    . S PXNOD E=$G(^AUTT IML(PXLOT, 0))
  12189   "RTN","PXV RPC4",249, 0)
  12190    . I PXNOD E="" Q
  12191   "RTN","PXV RPC4",250, 0)
  12192    . S PXEXP DATE=$P(PX NODE,U,9)
  12193   "RTN","PXV RPC4",251, 0)
  12194    . I $P(PX DATE,".",1 )>$P(PXEXP DATE,".",1 ) Q
  12195   "RTN","PXV RPC4",252, 0)
  12196    . S PXSTA T=$P(PXNOD E,U,3)
  12197   "RTN","PXV RPC4",253, 0)
  12198    . I PXSTA T>0 Q
  12199   "RTN","PXV RPC4",254, 0)
  12200    . S PXMAN =$P(PXNODE ,U,2)
  12201   "RTN","PXV RPC4",255, 0)
  12202    . I PXMAN  S PXMAN=$ P($G(^AUTT IMAN(PXMAN ,0)),U,1)
  12203   "RTN","PXV RPC4",256, 0)
  12204    . S PXNDC =$P(PXNODE ,U,18)
  12205   "RTN","PXV RPC4",257, 0)
  12206    . S PXCNT =PXCNT+1
  12207   "RTN","PXV RPC4",258, 0)
  12208    . S PXTEM P=PXLOT_U_ $P(PXNODE, U,1)_U_PXM AN_U_PXEXP DATE_U_$P( PXNODE,U,1 2)_U_$P(PX NODE,U,15) _U_PXNDC
  12209   "RTN","PXV RPC4",259, 0)
  12210    . S ^TMP( PXSUB,$J," LOT",PXCNT ,0)=PXTEMP
  12211   "RTN","PXV RPC4",260, 0)
  12212    Q
  12213   "RTN","PXV RPC4",261, 0)
  12214    ;
  12215   "RTN","PXV RPC4",262, 0)
  12216   GETCONT(PX SUB,PXIMM)  ; Get Con traindicat ions
  12217   "RTN","PXV RPC4",263, 0)
  12218    ;
  12219   "RTN","PXV RPC4",264, 0)
  12220    N PXCNT,P XFLDS,PXIE N,PXSKIP,P XSTAT
  12221   "RTN","PXV RPC4",265, 0)
  12222    ;
  12223   "RTN","PXV RPC4",266, 0)
  12224    S PXCNT=0
  12225   "RTN","PXV RPC4",267, 0)
  12226    S PXIEN=0
  12227   "RTN","PXV RPC4",268, 0)
  12228    F  S PXIE N=$O(^PXV( 920.4,PXIE N)) Q:'PXI EN  D
  12229   "RTN","PXV RPC4",269, 0)
  12230    . ;
  12231   "RTN","PXV RPC4",270, 0)
  12232    . S PXSKI P=0
  12233   "RTN","PXV RPC4",271, 0)
  12234    . I $O(^P XV(920.4,P XIEN,3,0))  D
  12235   "RTN","PXV RPC4",272, 0)
  12236    . . I '$O (^PXV(920. 4,PXIEN,3, "B",PXIMM, 0)) S PXSK IP=1
  12237   "RTN","PXV RPC4",273, 0)
  12238    . I PXSKI P Q
  12239   "RTN","PXV RPC4",274, 0)
  12240    . ;
  12241   "RTN","PXV RPC4",275, 0)
  12242    . S PXFLD S=$$GETFLD S^PXVRPC5( 920.4,PXIE N)
  12243   "RTN","PXV RPC4",276, 0)
  12244    . S PXSTA T=$P(PXFLD S,U,3)
  12245   "RTN","PXV RPC4",277, 0)
  12246    . I 'PXST AT Q
  12247   "RTN","PXV RPC4",278, 0)
  12248    . S PXCNT =PXCNT+1
  12249   "RTN","PXV RPC4",279, 0)
  12250    . S ^TMP( PXSUB,$J," CONTRA",PX CNT,0)=PXF LDS
  12251   "RTN","PXV RPC4",280, 0)
  12252    Q
  12253   "RTN","PXV RPC4",281, 0)
  12254    ;
  12255   "RTN","PXV RPC4",282, 0)
  12256   GETDEF(PXS UB,PXIMM)  ; Get defa ults
  12257   "RTN","PXV RPC4",283, 0)
  12258    ;
  12259   "RTN","PXV RPC4",284, 0)
  12260    N PXDFLTS ,PXINST,PX NODE,PXTMP
  12261   "RTN","PXV RPC4",285, 0)
  12262    ;
  12263   "RTN","PXV RPC4",286, 0)
  12264    S PXINST= $G(DUZ(2))
  12265   "RTN","PXV RPC4",287, 0)
  12266    I 'PXINST  S PXINST= $$KSP^XUPA RAM("INST" )
  12267   "RTN","PXV RPC4",288, 0)
  12268    I 'PXINST  Q
  12269   "RTN","PXV RPC4",289, 0)
  12270    ;
  12271   "RTN","PXV RPC4",290, 0)
  12272    D IMMDEF^ PXAPIIM(.P XDFLTS,PXI MM,PXINST)
  12273   "RTN","PXV RPC4",291, 0)
  12274    I '$D(PXD FLTS) Q
  12275   "RTN","PXV RPC4",292, 0)
  12276    ;
  12277   "RTN","PXV RPC4",293, 0)
  12278    S PXNODE= $G(PXDFLTS (13))
  12279   "RTN","PXV RPC4",294, 0)
  12280    S PXTMP=$ P(PXNODE,U ,2,3)_U_$P (PXNODE,U, 12,13)
  12281   "RTN","PXV RPC4",295, 0)
  12282    I $P(PXTM P,U,4) D
  12283   "RTN","PXV RPC4",296, 0)
  12284    . S $P(PX TMP,U,5)=$ $EXTERNAL^ DILFD(9000 010.11,131 3,"",$P(PX TMP,U,4))
  12285   "RTN","PXV RPC4",297, 0)
  12286    I PXTMP'= "^^^" S ^T MP(PXSUB,$ J,"DEF",1, 0)=PXTMP
  12287   "RTN","PXV RPC4",298, 0)
  12288    ;
  12289   "RTN","PXV RPC4",299, 0)
  12290    S PXNODE= $G(PXDFLTS (811))
  12291   "RTN","PXV RPC4",300, 0)
  12292    I PXNODE' ="" S ^TMP (PXSUB,$J, "DEFC",1,0 )=PXNODE
  12293   "RTN","PXV RPC4",301, 0)
  12294    ;
  12295   "RTN","PXV RPC4",302, 0)
  12296    Q
  12297   "RTN","PXV RPC4",303, 0)
  12298    ;
  12299   "RTN","PXV RPC4",304, 0)
  12300   IMMSHORT(P XRSLT,PXFI LTER,PXDAT E) ;
  12301   "RTN","PXV RPC4",305, 0)
  12302    ;
  12303   "RTN","PXV RPC4",306, 0)
  12304    ; Return  short list  of immuni zations
  12305   "RTN","PXV RPC4",307, 0)
  12306    ;
  12307   "RTN","PXV RPC4",308, 0)
  12308    ;Input:
  12309   "RTN","PXV RPC4",309, 0)
  12310    ;    PXRS LT - Retur n value pa ssed by re ference (R equired)
  12311   "RTN","PXV RPC4",310, 0)
  12312    ;  PXFILT ER - Filte r (Optiona l; Default s to "B")
  12313   "RTN","PXV RPC4",311, 0)
  12314    ;              Possi ble values  are:
  12315   "RTN","PXV RPC4",312, 0)
  12316    ;                "A" : Only ret urn active  entries
  12317   "RTN","PXV RPC4",313, 0)
  12318    ;                "H" : Only ret urn entrie s marked a s Selectab le for His toric
  12319   "RTN","PXV RPC4",314, 0)
  12320    ;                "B" : Return b oth active  entries a nd those m arked as S electable  for Histor ic
  12321   "RTN","PXV RPC4",315, 0)
  12322    ;    PXDA TE - Date  (optional;  defaults  to TODAY)
  12323   "RTN","PXV RPC4",316, 0)
  12324    ;              Used  for determ ining immu nization s tatus (bot h for filt ering and  for return  value)
  12325   "RTN","PXV RPC4",317, 0)
  12326    ;
  12327   "RTN","PXV RPC4",318, 0)
  12328    ;Returns:
  12329   "RTN","PXV RPC4",319, 0)
  12330    ;   PXRTR N(x)
  12331   "RTN","PXV RPC4",320, 0)
  12332    ;      No te: Status  (in the 5 th piece)  is determi ned as fol lows:
  12333   "RTN","PXV RPC4",321, 0)
  12334    ;         - If PXDAT E is today , the stat us is base d off the  Inactive F lag (#.07)
  12335   "RTN","PXV RPC4",322, 0)
  12336    ;         - If PXDAT E is diffe rent than  today, we  will look  when an up date was
  12337   "RTN","PXV RPC4",323, 0)
  12338    ;           last mad e to the I mmunizatio n file (ba sed off th e Audits).
  12339   "RTN","PXV RPC4",324, 0)
  12340    ;           If there  have not  been any c hanges sin ce PXDATE,  we will g et the
  12341   "RTN","PXV RPC4",325, 0)
  12342    ;           status b ased off t he Inactiv e Flag, ot herwise, w e will get  the
  12343   "RTN","PXV RPC4",326, 0)
  12344    ;           status f or that da te by call ing GETSTA T^XTID.
  12345   "RTN","PXV RPC4",327, 0)
  12346    ;      1:  "IMM"
  12347   "RTN","PXV RPC4",328, 0)
  12348    ;      2:  #9999999. 14 IEN
  12349   "RTN","PXV RPC4",329, 0)
  12350    ;      3:  Name (#.0 1)
  12351   "RTN","PXV RPC4",330, 0)
  12352    ;      4:  CVX Code  (#.03)
  12353   "RTN","PXV RPC4",331, 0)
  12354    ;      5:  Status (1 : Active;  0: Inactiv e)
  12355   "RTN","PXV RPC4",332, 0)
  12356    ;      6:  Selectabl e for Hist oric (#880 3)
  12357   "RTN","PXV RPC4",333, 0)
  12358    ;      7:  Mnemonic  (#8801)
  12359   "RTN","PXV RPC4",334, 0)
  12360    ;      8:  Acronym ( #8802)
  12361   "RTN","PXV RPC4",335, 0)
  12362    ;   PXRTR N(x)
  12363   "RTN","PXV RPC4",336, 0)
  12364    ;      1:  "CDC"
  12365   "RTN","PXV RPC4",337, 0)
  12366    ;      2:  CDC Produ ct Name (# 9999999.14 5, #.01)
  12367   "RTN","PXV RPC4",338, 0)
  12368    ;
  12369   "RTN","PXV RPC4",339, 0)
  12370    N PXAUDIT ,PXCNT,PXG ETCSTAT,PX IEN,PXNODE ,PXSELHIST ,PXSTAT,PX X
  12371   "RTN","PXV RPC4",340, 0)
  12372    ;
  12373   "RTN","PXV RPC4",341, 0)
  12374    I $G(PXFI LTER)'?1(1 "A",1"H",1 "B") S PXF ILTER="B"
  12375   "RTN","PXV RPC4",342, 0)
  12376    I '$G(PXD ATE) S PXD ATE=DT
  12377   "RTN","PXV RPC4",343, 0)
  12378    S PXAUDIT =0
  12379   "RTN","PXV RPC4",344, 0)
  12380    I $$GET1^ DID(999999 9.14,.07," ","AUDIT") ="YES, ALW AYS" S PXA UDIT=1
  12381   "RTN","PXV RPC4",345, 0)
  12382    S PXGETCS TAT=$$GETC STAT(PXDAT E,PXAUDIT)
  12383   "RTN","PXV RPC4",346, 0)
  12384    ;
  12385   "RTN","PXV RPC4",347, 0)
  12386    S PXCNT=0
  12387   "RTN","PXV RPC4",348, 0)
  12388    S PXIEN=0
  12389   "RTN","PXV RPC4",349, 0)
  12390    F  S PXIE N=$O(^AUTT IMM(PXIEN) ) Q:PXIEN' >0  D
  12391   "RTN","PXV RPC4",350, 0)
  12392    . S PXSEL HIST=$P($G (^AUTTIMM( PXIEN,6)), U)
  12393   "RTN","PXV RPC4",351, 0)
  12394    . S PXSTA T=$$GETSTA T(PXIEN,PX DATE,PXGET CSTAT,PXAU DIT)
  12395   "RTN","PXV RPC4",352, 0)
  12396    . I PXFIL TER="A",'P XSTAT Q
  12397   "RTN","PXV RPC4",353, 0)
  12398    . I PXFIL TER="H",PX SELHIST'=" Y" Q
  12399   "RTN","PXV RPC4",354, 0)
  12400    . I PXFIL TER="B",'P XSTAT,PXSE LHIST'="Y"  Q
  12401   "RTN","PXV RPC4",355, 0)
  12402    . ;
  12403   "RTN","PXV RPC4",356, 0)
  12404    . S PXCNT =PXCNT+1
  12405   "RTN","PXV RPC4",357, 0)
  12406    . S PXNOD E=$G(^AUTT IMM(PXIEN, 0))
  12407   "RTN","PXV RPC4",358, 0)
  12408    . S PXRSL T(PXCNT)=" IMM"_U_PXI EN_U_$P(PX NODE,U,1)_ U_$P(PXNOD E,U,3)_U_P XSTAT_U_PX SELHIST
  12409   "RTN","PXV RPC4",359, 0)
  12410    . S PXNOD E=$G(^AUTT IMM(PXIEN, 88))
  12411   "RTN","PXV RPC4",360, 0)
  12412    . I PXNOD E'="",PXNO DE'=U S PX RSLT(PXCNT )=PXRSLT(P XCNT)_U_PX NODE
  12413   "RTN","PXV RPC4",361, 0)
  12414    . S PXX=0
  12415   "RTN","PXV RPC4",362, 0)
  12416    . F  S PX X=$O(^AUTT IMM(PXIEN, 5,PXX)) Q: PXX'>0  D
  12417   "RTN","PXV RPC4",363, 0)
  12418    . . S PXN ODE=$G(^AU TTIMM(PXIE N,5,PXX,0) )
  12419   "RTN","PXV RPC4",364, 0)
  12420    . . I PXN ODE="" Q
  12421   "RTN","PXV RPC4",365, 0)
  12422    . . S PXC NT=PXCNT+1
  12423   "RTN","PXV RPC4",366, 0)
  12424    . . S PXR SLT(PXCNT) ="CDC"_U_P XNODE
  12425   "RTN","PXV RPC4",367, 0)
  12426    Q
  12427   "RTN","PXV RPC4",368, 0)
  12428    ;
  12429   "RTN","PXV RPC4",369, 0)
  12430   GETSTAT(PX IMM,PXDATE ,PXCURR,PX AUDIT) ;
  12431   "RTN","PXV RPC4",370, 0)
  12432    ;
  12433   "RTN","PXV RPC4",371, 0)
  12434    N PXLASTE DIT
  12435   "RTN","PXV RPC4",372, 0)
  12436    ;
  12437   "RTN","PXV RPC4",373, 0)
  12438    I PXCURR  Q '$P($G(^ AUTTIMM(PX IMM,0)),U, 7)
  12439   "RTN","PXV RPC4",374, 0)
  12440    ;
  12441   "RTN","PXV RPC4",375, 0)
  12442    I PXAUDIT  D
  12443   "RTN","PXV RPC4",376, 0)
  12444    . S PXLAS TEDIT=$P($ $LAST^DIAU TL(9999999 .14,PXIMM, ".07"),U,1 )
  12445   "RTN","PXV RPC4",377, 0)
  12446    . I PXDAT E>PXLASTED IT S PXCUR R=1
  12447   "RTN","PXV RPC4",378, 0)
  12448    I PXCURR  Q '$P($G(^ AUTTIMM(PX IMM,0)),U, 7)
  12449   "RTN","PXV RPC4",379, 0)
  12450    ;
  12451   "RTN","PXV RPC4",380, 0)
  12452    Q $P($$GE TSTAT^XTID (9999999.1 4,"",PXIMM _",",$G(PX DATE)),U,1 )
  12453   "RTN","PXV RPC4",381, 0)
  12454    ;
  12455   "RTN","PXV RPC4",382, 0)
  12456   GETCSTAT(P XDATE,PXAU DIT) ;
  12457   "RTN","PXV RPC4",383, 0)
  12458    ;
  12459   "RTN","PXV RPC4",384, 0)
  12460    ; Should  we get cur rent statu s of IMM e ntries or  should we  call GETST AT^XTID
  12461   "RTN","PXV RPC4",385, 0)
  12462    ; to get  status as  of a speci fic date?
  12463   "RTN","PXV RPC4",386, 0)
  12464    ; Since G ETSTAT^XTI D is slow,  we try to  avoid it  when possi ble.
  12465   "RTN","PXV RPC4",387, 0)
  12466    ;
  12467   "RTN","PXV RPC4",388, 0)
  12468    ; Returns : 0 - Call  GETSTAT^X TID
  12469   "RTN","PXV RPC4",389, 0)
  12470    ;           1 - Get  current st atus
  12471   "RTN","PXV RPC4",390, 0)
  12472    ;
  12473   "RTN","PXV RPC4",391, 0)
  12474    N PXLASTE DITDT,PXRS LT
  12475   "RTN","PXV RPC4",392, 0)
  12476    ;
  12477   "RTN","PXV RPC4",393, 0)
  12478    S PXRSLT= 0
  12479   "RTN","PXV RPC4",394, 0)
  12480    ;
  12481   "RTN","PXV RPC4",395, 0)
  12482    I '$G(PXD ATE) D  Q  PXRSLT
  12483   "RTN","PXV RPC4",396, 0)
  12484    . S PXRSL T=1
  12485   "RTN","PXV RPC4",397, 0)
  12486    ;
  12487   "RTN","PXV RPC4",398, 0)
  12488    I $P(PXDA TE,".",1)= DT D  Q PX RSLT
  12489   "RTN","PXV RPC4",399, 0)
  12490    . S PXRSL T=1
  12491   "RTN","PXV RPC4",400, 0)
  12492    ;
  12493   "RTN","PXV RPC4",401, 0)
  12494    ; If Inac tive Flag  is being a udited (wh ich should  be the ca se)
  12495   "RTN","PXV RPC4",402, 0)
  12496    ; then ge t current  status, if  file has  not been u pdated sin ce PXDATE
  12497   "RTN","PXV RPC4",403, 0)
  12498    I PXAUDIT  D
  12499   "RTN","PXV RPC4",404, 0)
  12500    . S PXLAS TEDITDT=$O (^DIA(9999 999.14,"C" ,""),-1)    ;ICR #260 2
  12501   "RTN","PXV RPC4",405, 0)
  12502    . I PXDAT E>PXLASTED ITDT S PXR SLT=1
  12503   "RTN","PXV RPC4",406, 0)
  12504    ;
  12505   "RTN","PXV RPC4",407, 0)
  12506    Q PXRSLT
  12507   "RTN","PXV RPC4",408, 0)
  12508    ;
  12509   "RTN","PXV RPC4",409, 0)
  12510   IMMADMCD(P XRSLT,PXDA TE) ;
  12511   "RTN","PXV RPC4",410, 0)
  12512    ;
  12513   "RTN","PXV RPC4",411, 0)
  12514    ; Returns  Immunizat ion Admin  CPT codes
  12515   "RTN","PXV RPC4",412, 0)
  12516    ;
  12517   "RTN","PXV RPC4",413, 0)
  12518    ;Input:
  12519   "RTN","PXV RPC4",414, 0)
  12520    ;  PXRTRN  - Return  value pass ed by refe rence (Req uired)
  12521   "RTN","PXV RPC4",415, 0)
  12522    ;  PXDATE  - Code st atus will  be based o ff this da te
  12523   "RTN","PXV RPC4",416, 0)
  12524    ;            (Option al; Defaul ts to TODA Y)
  12525   "RTN","PXV RPC4",417, 0)
  12526    ;
  12527   "RTN","PXV RPC4",418, 0)
  12528    ;Returns:
  12529   "RTN","PXV RPC4",419, 0)
  12530    ;   PXRSL T(0) = Cou nt of elem ents retur ned (0 if  nothing fo und)
  12531   "RTN","PXV RPC4",420, 0)
  12532    ;   PXRSL T(n) =
  12533   "RTN","PXV RPC4",421, 0)
  12534    ;      No te: Only a ctive code s (based o ff PXDATE)  are retur ned.
  12535   "RTN","PXV RPC4",422, 0)
  12536    ;      1:  "CPT-ADM"  or "CPT-A DD"
  12537   "RTN","PXV RPC4",423, 0)
  12538    ;      2:  Code
  12539   "RTN","PXV RPC4",424, 0)
  12540    ;      3:  Variable  pointer. e .g., IEN;I CPT(
  12541   "RTN","PXV RPC4",425, 0)
  12542    ;      4:  Short Des cription
  12543   "RTN","PXV RPC4",426, 0)
  12544    ;
  12545   "RTN","PXV RPC4",427, 0)
  12546    N PXCNT,P XFLD,PXI,P XIMM,PXNOD E,PXSUB
  12547   "RTN","PXV RPC4",428, 0)
  12548    ;
  12549   "RTN","PXV RPC4",429, 0)
  12550    S PXSUB=" PXVIMMCODE "
  12551   "RTN","PXV RPC4",430, 0)
  12552    K ^TMP(PX SUB,$J)
  12553   "RTN","PXV RPC4",431, 0)
  12554    ;
  12555   "RTN","PXV RPC4",432, 0)
  12556    S PXCNT=0
  12557   "RTN","PXV RPC4",433, 0)
  12558    I '$G(PXD ATE) S PXD ATE=DT
  12559   "RTN","PXV RPC4",434, 0)
  12560    S PXIMM=$ $IMMNODEF^ PXAPIIM()
  12561   "RTN","PXV RPC4",435, 0)
  12562    I 'PXIMM  S PXRSLT(P XCNT)=0 Q
  12563   "RTN","PXV RPC4",436, 0)
  12564    ;
  12565   "RTN","PXV RPC4",437, 0)
  12566    D GETCS(P XSUB,PXIMM ,PXDATE)
  12567   "RTN","PXV RPC4",438, 0)
  12568    F PXFLD=" CPT-ADM"," CPT-ADD" D
  12569   "RTN","PXV RPC4",439, 0)
  12570    . I '$D(^ TMP(PXSUB, $J,"CS",PX FLD)) Q
  12571   "RTN","PXV RPC4",440, 0)
  12572    . S PXI=0  F  S PXI= $O(^TMP(PX SUB,$J,"CS ",PXFLD,PX I)) Q:'PXI   D
  12573   "RTN","PXV RPC4",441, 0)
  12574    . . S PXN ODE=$G(^TM P(PXSUB,$J ,"CS",PXFL D,PXI,0))
  12575   "RTN","PXV RPC4",442, 0)
  12576    . . I PXN ODE="" Q
  12577   "RTN","PXV RPC4",443, 0)
  12578    . . S PXC NT=PXCNT+1
  12579   "RTN","PXV RPC4",444, 0)
  12580    . . S PXR SLT(PXCNT) =PXFLD_U_P XNODE
  12581   "RTN","PXV RPC4",445, 0)
  12582    ;
  12583   "RTN","PXV RPC4",446, 0)
  12584    K ^TMP(PX SUB,$J)
  12585   "RTN","PXV RPC4",447, 0)
  12586    S PXRSLT( 0)=PXCNT
  12587   "RTN","PXV RPC4",448, 0)
  12588    ;
  12589   "RTN","PXV RPC4",449, 0)
  12590    Q
  12591   "RTN","PXV RPC5")
  12592   0^29^B3510 5697^n/a
  12593   "RTN","PXV RPC5",1,0)
  12594   PXVRPC5 ;B PFO/LMT -  PCE RPCs f or Imm Con traindicat ions/refus als ;03/11 /16  09:10
  12595   "RTN","PXV RPC5",2,0)
  12596    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  12597   "RTN","PXV RPC5",3,0)
  12598    ;
  12599   "RTN","PXV RPC5",4,0)
  12600    ;
  12601   "RTN","PXV RPC5",5,0)
  12602   GETICR(PXR SLT,PXFILE ,PXFLTR) ;
  12603   "RTN","PXV RPC5",6,0)
  12604    ;
  12605   "RTN","PXV RPC5",7,0)
  12606    ; Returns  entries f rom the IM M CONTRAIN DICATION R EASONS (#9 20.4) and
  12607   "RTN","PXV RPC5",8,0)
  12608    ; IMM REF USAL REASO NS (#920.5 ) files.
  12609   "RTN","PXV RPC5",9,0)
  12610    ;
  12611   "RTN","PXV RPC5",10,0 )
  12612    ;Input:
  12613   "RTN","PXV RPC5",11,0 )
  12614    ;  PXRSLT  - Return  value pass ed by refe rence (Req uired)
  12615   "RTN","PXV RPC5",12,0 )
  12616    ;  PXFILE  - Which f ile to pul l from (Op tional; Le ave this n ull to pul l entries  from both  files)
  12617   "RTN","PXV RPC5",13,0 )
  12618    ;            Possibl e values a re:
  12619   "RTN","PXV RPC5",14,0 )
  12620    ;                "92 0.4" - Onl y return e ntries fro m IMM CONT RAINDICATI ON REASONS  (#920.4)
  12621   "RTN","PXV RPC5",15,0 )
  12622    ;                "92 0.5" - Onl y return e ntries fro m IMM REFU SAL REASON S (#920.5)
  12623   "RTN","PXV RPC5",16,0 )
  12624    ;  PXFLTR  - Filter  (Optional;  Defaults  to "S:A")
  12625   "RTN","PXV RPC5",17,0 )
  12626    ;            Possibl e values a re:
  12627   "RTN","PXV RPC5",18,0 )
  12628    ;                R:X    - Retur n entry wi th IEN X ( PXFILE mus t be passe d in with  this optio n).
  12629   "RTN","PXV RPC5",19,0 )
  12630    ;                C:X ^Y - Retur n entry wi th Concept  Code^Codi ng System  X^Y (used  only for # 920.4).
  12631   "RTN","PXV RPC5",20,0 )
  12632    ;                H:X    - Retur n entry wi th HL7 Cod e X (used  only for # 920.5).
  12633   "RTN","PXV RPC5",21,0 )
  12634    ;                N:X    - Retur n entry wi th #.01 fi eld equal  to X
  12635   "RTN","PXV RPC5",22,0 )
  12636    ;                I:X    - Retur n all acti ve entries  that are  selectable  for Immun ization IE N X.
  12637   "RTN","PXV RPC5",23,0 )
  12638    ;                S:A    - Retur n all acti ve entries .
  12639   "RTN","PXV RPC5",24,0 )
  12640    ;                S:I    - Retur n all inac tive entri es.
  12641   "RTN","PXV RPC5",25,0 )
  12642    ;                S:B    - Retur n all entr ies (both  active and  inactive) .
  12643   "RTN","PXV RPC5",26,0 )
  12644    ;
  12645   "RTN","PXV RPC5",27,0 )
  12646    ;Returns:
  12647   "RTN","PXV RPC5",28,0 )
  12648    ;  PXRSLT (0)=Count  of element s returned  (0 if not hing found )
  12649   "RTN","PXV RPC5",29,0 )
  12650    ;  For 92 0.4 Entry:
  12651   "RTN","PXV RPC5",30,0 )
  12652    ;    PXRS LT(n)=IEN; PXV(920.4, ^Name^Stat us (1:Acti ve, 0:Inac tive)^Code |Coding Sy stem^NIP00 4^Contrain dication/P recaution
  12653   "RTN","PXV RPC5",31,0 )
  12654    ;  For 92 0.5 Entry:
  12655   "RTN","PXV RPC5",32,0 )
  12656    ;    PXRS LT(n)=IEN; PXV(920.5, ^Name^Stat us (1:Acti ve, 0:Inac tive)^HL7  Code
  12657   "RTN","PXV RPC5",33,0 )
  12658    ;
  12659   "RTN","PXV RPC5",34,0 )
  12660    N PXCNT,P XCODE,PXFI LES,PXFLTR STAT,PXFLT RTYP,PXFLT RVAL,PXIEN ,PXSKIP,PX SYS,PXX
  12661   "RTN","PXV RPC5",35,0 )
  12662    ;
  12663   "RTN","PXV RPC5",36,0 )
  12664    I $G(PXFI LE)'?1(1"9 20.4",1"92 0.5") S PX FILE=""
  12665   "RTN","PXV RPC5",37,0 )
  12666    I $P($G(P XFLTR),":" ,1)'?1(1"R ",1"C",1"H ",1"N",1"I ",1"S") S  PXFLTR="S: A"
  12667   "RTN","PXV RPC5",38,0 )
  12668    S PXCNT=0
  12669   "RTN","PXV RPC5",39,0 )
  12670    S PXFLTRT YP=$P(PXFL TR,":",1)
  12671   "RTN","PXV RPC5",40,0 )
  12672    S PXFLTRV AL=$P(PXFL TR,":",2)
  12673   "RTN","PXV RPC5",41,0 )
  12674    D CHKCACH E^PXVRPC2( 920.5)
  12675   "RTN","PXV RPC5",42,0 )
  12676    ;
  12677   "RTN","PXV RPC5",43,0 )
  12678    I PXFLTRT YP="R" D
  12679   "RTN","PXV RPC5",44,0 )
  12680    . I 'PXFI LE Q
  12681   "RTN","PXV RPC5",45,0 )
  12682    . S PXIEN =PXFLTRVAL
  12683   "RTN","PXV RPC5",46,0 )
  12684    . I 'PXIE N Q
  12685   "RTN","PXV RPC5",47,0 )
  12686    . I '$D(^ PXV(PXFILE ,PXIEN)) Q
  12687   "RTN","PXV RPC5",48,0 )
  12688    . D ADDEN TRY(.PXRSL T,.PXFILE, .PXIEN,"", .PXCNT)
  12689   "RTN","PXV RPC5",49,0 )
  12690    ;
  12691   "RTN","PXV RPC5",50,0 )
  12692    I PXFLTRT YP="C" D
  12693   "RTN","PXV RPC5",51,0 )
  12694    . S PXFIL E=920.4
  12695   "RTN","PXV RPC5",52,0 )
  12696    . S PXCOD E=$P(PXFLT RVAL,U,1)
  12697   "RTN","PXV RPC5",53,0 )
  12698    . S PXSYS =$P(PXFLTR VAL,U,2)
  12699   "RTN","PXV RPC5",54,0 )
  12700    . I (PXCO DE="")!(PX SYS="") Q
  12701   "RTN","PXV RPC5",55,0 )
  12702    . S PXIEN =0
  12703   "RTN","PXV RPC5",56,0 )
  12704    . S PXX=0
  12705   "RTN","PXV RPC5",57,0 )
  12706    . F  S PX X=$O(^PXV( PXFILE,"C" ,PXCODE,PX X)) Q:'PXX   D  Q:PXI EN
  12707   "RTN","PXV RPC5",58,0 )
  12708    . . I $P( $G(^PXV(PX FILE,PXX," VUID")),U, 4)=PXSYS S  PXIEN=PXX
  12709   "RTN","PXV RPC5",59,0 )
  12710    . I 'PXIE N Q
  12711   "RTN","PXV RPC5",60,0 )
  12712    . D ADDEN TRY(.PXRSL T,.PXFILE, .PXIEN,"", .PXCNT)
  12713   "RTN","PXV RPC5",61,0 )
  12714    ;
  12715   "RTN","PXV RPC5",62,0 )
  12716    I PXFLTRT YP="H" D
  12717   "RTN","PXV RPC5",63,0 )
  12718    . S PXFIL E=920.5
  12719   "RTN","PXV RPC5",64,0 )
  12720    . I PXFLT RVAL="" Q
  12721   "RTN","PXV RPC5",65,0 )
  12722    . S PXIEN =0
  12723   "RTN","PXV RPC5",66,0 )
  12724    . S PXX=0
  12725   "RTN","PXV RPC5",67,0 )
  12726    . F  S PX X=$O(^PXV( PXFILE,PXX )) Q:'PXX   D  Q:PXIE N
  12727   "RTN","PXV RPC5",68,0 )
  12728    . . I $P( $G(^PXV(PX FILE,PXX,0 )),U,2)=PX FLTRVAL S  PXIEN=PXX
  12729   "RTN","PXV RPC5",69,0 )
  12730    . I 'PXIE N Q
  12731   "RTN","PXV RPC5",70,0 )
  12732    . D ADDEN TRY(.PXRSL T,.PXFILE, .PXIEN,"", .PXCNT)
  12733   "RTN","PXV RPC5",71,0 )
  12734    ;
  12735   "RTN","PXV RPC5",72,0 )
  12736    I PXFILE= "" D
  12737   "RTN","PXV RPC5",73,0 )
  12738    . S PXFIL ES(920.4)= ""
  12739   "RTN","PXV RPC5",74,0 )
  12740    . S PXFIL ES(920.5)= ""
  12741   "RTN","PXV RPC5",75,0 )
  12742    I PXFILE' ="" S PXFI LES(PXFILE )=""
  12743   "RTN","PXV RPC5",76,0 )
  12744    ;
  12745   "RTN","PXV RPC5",77,0 )
  12746    I PXFLTRT YP="N" D
  12747   "RTN","PXV RPC5",78,0 )
  12748    . I PXFLT RVAL="" Q
  12749   "RTN","PXV RPC5",79,0 )
  12750    . S PXIEN =0
  12751   "RTN","PXV RPC5",80,0 )
  12752    . S PXFIL E=0
  12753   "RTN","PXV RPC5",81,0 )
  12754    . F  S PX FILE=$O(PX FILES(PXFI LE)) Q:'PX FILE  D  Q :PXIEN
  12755   "RTN","PXV RPC5",82,0 )
  12756    . . S PXI EN=$O(^PXV (PXFILE,"B ",PXFLTRVA L,0))
  12757   "RTN","PXV RPC5",83,0 )
  12758    . I 'PXIE N Q
  12759   "RTN","PXV RPC5",84,0 )
  12760    . D ADDEN TRY(.PXRSL T,.PXFILE, .PXIEN,"", .PXCNT)
  12761   "RTN","PXV RPC5",85,0 )
  12762    ;
  12763   "RTN","PXV RPC5",86,0 )
  12764    I PXFLTRT YP?1(1"S", 1"I") D
  12765   "RTN","PXV RPC5",87,0 )
  12766    . S PXFLT RSTAT="A"
  12767   "RTN","PXV RPC5",88,0 )
  12768    . I PXFLT RTYP="S",$ G(PXFLTRVA L)?1(1"A", 1"I",1"B")  S PXFLTRS TAT=PXFLTR VAL
  12769   "RTN","PXV RPC5",89,0 )
  12770    . S PXFIL E=0
  12771   "RTN","PXV RPC5",90,0 )
  12772    . F  S PX FILE=$O(PX FILES(PXFI LE)) Q:'PX FILE  D
  12773   "RTN","PXV RPC5",91,0 )
  12774    . . S PXI EN=0
  12775   "RTN","PXV RPC5",92,0 )
  12776    . . F  S  PXIEN=$O(^ PXV(PXFILE ,PXIEN)) Q :'PXIEN  D
  12777   "RTN","PXV RPC5",93,0 )
  12778    . . . ;
  12779   "RTN","PXV RPC5",94,0 )
  12780    . . . S P XSKIP=0
  12781   "RTN","PXV RPC5",95,0 )
  12782    . . . I P XFILE=920. 4,PXFLTRTY P="I",PXFL TRVAL,$O(^ PXV(PXFILE ,PXIEN,3,0 )) D
  12783   "RTN","PXV RPC5",96,0 )
  12784    . . . . I  '$O(^PXV( PXFILE,PXI EN,3,"B",P XFLTRVAL,0 )) S PXSKI P=1
  12785   "RTN","PXV RPC5",97,0 )
  12786    . . . I P XSKIP Q
  12787   "RTN","PXV RPC5",98,0 )
  12788    . . . ;
  12789   "RTN","PXV RPC5",99,0 )
  12790    . . . D A DDENTRY(.P XRSLT,.PXF ILE,.PXIEN ,PXFLTRSTA T,.PXCNT)
  12791   "RTN","PXV RPC5",100, 0)
  12792    ;
  12793   "RTN","PXV RPC5",101, 0)
  12794    S PXRSLT( 0)=PXCNT
  12795   "RTN","PXV RPC5",102, 0)
  12796    ;
  12797   "RTN","PXV RPC5",103, 0)
  12798    Q
  12799   "RTN","PXV RPC5",104, 0)
  12800    ;
  12801   "RTN","PXV RPC5",105, 0)
  12802   ADDENTRY(P XRSLT,PXFI LE,PXIEN,P XFLTRSTAT, PXCNT) ; A dds entry  to PXVRSLT
  12803   "RTN","PXV RPC5",106, 0)
  12804    ;
  12805   "RTN","PXV RPC5",107, 0)
  12806    N PXFLDS, PXSTAT
  12807   "RTN","PXV RPC5",108, 0)
  12808    ;
  12809   "RTN","PXV RPC5",109, 0)
  12810    I 'PXIEN  Q
  12811   "RTN","PXV RPC5",110, 0)
  12812    ;
  12813   "RTN","PXV RPC5",111, 0)
  12814    S PXFLDS= $$GETFLDS( PXFILE,PXI EN)
  12815   "RTN","PXV RPC5",112, 0)
  12816    S PXSTAT= $P(PXFLDS, U,3)
  12817   "RTN","PXV RPC5",113, 0)
  12818    ;
  12819   "RTN","PXV RPC5",114, 0)
  12820    I $G(PXFL TRSTAT)="A ",'PXSTAT  Q
  12821   "RTN","PXV RPC5",115, 0)
  12822    I $G(PXFL TRSTAT)="I ",PXSTAT Q
  12823   "RTN","PXV RPC5",116, 0)
  12824    ;
  12825   "RTN","PXV RPC5",117, 0)
  12826    S PXCNT=P XCNT+1
  12827   "RTN","PXV RPC5",118, 0)
  12828    S PXRSLT( PXCNT)=PXF LDS
  12829   "RTN","PXV RPC5",119, 0)
  12830    ;
  12831   "RTN","PXV RPC5",120, 0)
  12832    Q
  12833   "RTN","PXV RPC5",121, 0)
  12834    ;
  12835   "RTN","PXV RPC5",122, 0)
  12836   GETFLDS(PX FILE,PXIEN ) ; Return s field va lues
  12837   "RTN","PXV RPC5",123, 0)
  12838    ;
  12839   "RTN","PXV RPC5",124, 0)
  12840    N PXCODE, PXNAME,PXN ODE,PXRSLT ,PXSTAT
  12841   "RTN","PXV RPC5",125, 0)
  12842    ;
  12843   "RTN","PXV RPC5",126, 0)
  12844    S PXNODE= $G(^PXV(PX FILE,PXIEN ,0))
  12845   "RTN","PXV RPC5",127, 0)
  12846    S PXNAME= $P(PXNODE, U,1)
  12847   "RTN","PXV RPC5",128, 0)
  12848    S PXCODE= $P(PXNODE, U,2)
  12849   "RTN","PXV RPC5",129, 0)
  12850    S PXSTAT= $$GETSTAT^ PXVRPC2(PX FILE,PXIEN )
  12851   "RTN","PXV RPC5",130, 0)
  12852    ;
  12853   "RTN","PXV RPC5",131, 0)
  12854    S PXRSLT= PXIEN_";PX V("_PXFILE _","_U_PXN AME_U_PXST AT_U_PXCOD E
  12855   "RTN","PXV RPC5",132, 0)
  12856    ;
  12857   "RTN","PXV RPC5",133, 0)
  12858    I PXFILE= 920.4 D
  12859   "RTN","PXV RPC5",134, 0)
  12860    . S PXRSL T=PXRSLT_" |"_$P($G(^ PXV(PXFILE ,PXIEN,"VU ID")),U,4)
  12861   "RTN","PXV RPC5",135, 0)
  12862    . S PXRSL T=PXRSLT_U _$P(PXNODE ,U,4)_U_$P (PXNODE,U, 5)
  12863   "RTN","PXV RPC5",136, 0)
  12864    ;
  12865   "RTN","PXV RPC5",137, 0)
  12866    Q PXRSLT
  12867   "RTN","PXV RPC5",138, 0)
  12868    ;
  12869   "RTN","PXV RPC5",139, 0)
  12870   GETVICR(PX RSLT,DFN,P XVIMM,PXDA TE,PXFORMA T) ;
  12871   "RTN","PXV RPC5",140, 0)
  12872    ;
  12873   "RTN","PXV RPC5",141, 0)
  12874    ; Returns  "active"  entries fr om the V I MM CONTRA/ REFUSAL EV ENTS file  (#9000010. 707)
  12875   "RTN","PXV RPC5",142, 0)
  12876    ; that ar e related  to the giv en patient  and immun ization.
  12877   "RTN","PXV RPC5",143, 0)
  12878    ; "Active " is defin ed as entr ies where  the Event  Date and T ime is <=  PXDATE@24
  12879   "RTN","PXV RPC5",144, 0)
  12880    ; and the  Warn Unti l Date is  null or >=  PXDATE.
  12881   "RTN","PXV RPC5",145, 0)
  12882    ;
  12883   "RTN","PXV RPC5",146, 0)
  12884    ;Input:
  12885   "RTN","PXV RPC5",147, 0)
  12886    ;    PXRS LT - Retur n value pa ssed by re ference (R equired)
  12887   "RTN","PXV RPC5",148, 0)
  12888    ;       D FN - Point er to file  #2 (Requi red)
  12889   "RTN","PXV RPC5",149, 0)
  12890    ;    PXVI MM - Point er to #999 9999.14 (R equired)
  12891   "RTN","PXV RPC5",150, 0)
  12892    ;    PXDA TE - Date  (without t ime) Used  to determi ne if entr y is "acti ve"
  12893   "RTN","PXV RPC5",151, 0)
  12894    ;              (Opti onal; Defa ults to TO DAY)
  12895   "RTN","PXV RPC5",152, 0)
  12896    ;  PXFORM AT - Forma t that ret urn array  should be  returned ( Optional;  Defaults t o "L")
  12897   "RTN","PXV RPC5",153, 0)
  12898    ;              Possi ble values  are:
  12899   "RTN","PXV RPC5",154, 0)
  12900    ;                 "L ": Return  a caret-de limited li st of entr ies
  12901   "RTN","PXV RPC5",155, 0)
  12902    ;                 "W ": Returns  a warning  message.
  12903   "RTN","PXV RPC5",156, 0)
  12904    ;
  12905   "RTN","PXV RPC5",157, 0)
  12906    ;Returns:
  12907   "RTN","PXV RPC5",158, 0)
  12908    ;  PXRSLT (0)=Count  of element s returned  (0 if not hing found )
  12909   "RTN","PXV RPC5",159, 0)
  12910    ;  If PXF ORMAT="L":
  12911   "RTN","PXV RPC5",160, 0)
  12912    ;    PXRS LT(n)="VIC R" ^ V IMM  Contra/Re fusal Even ts IEN ^ V isit IEN ^  Contra/Re fusal
  12913   "RTN","PXV RPC5",161, 0)
  12914    ;                var iable poin ter | Cont ra/Refusal  Name ^ Im munization  IEN | Nam e
  12915   "RTN","PXV RPC5",162, 0)
  12916    ;                ^ W arn Until  Date ^ D/T  Recorded  ^ Event D/ T ^ Encoun ter Provid er
  12917   "RTN","PXV RPC5",163, 0)
  12918    ;                IEN  | Name
  12919   "RTN","PXV RPC5",164, 0)
  12920    ;    PXRS LT(n)="COM " ^ Commen ts
  12921   "RTN","PXV RPC5",165, 0)
  12922    ;  If PXF ORMAT["W":
  12923   "RTN","PXV RPC5",166, 0)
  12924    ;    PXRS LT(n)=Warn ing text
  12925   "RTN","PXV RPC5",167, 0)
  12926    ;
  12927   "RTN","PXV RPC5",168, 0)
  12928    N PXCNT,P XEDATE,PXI CRARR,PXIE N,PXSDATE
  12929   "RTN","PXV RPC5",169, 0)
  12930    ;
  12931   "RTN","PXV RPC5",170, 0)
  12932    I (('$G(D FN))!('$G( PXVIMM)))  S PXRSLT(0 )=0 Q
  12933   "RTN","PXV RPC5",171, 0)
  12934    ;
  12935   "RTN","PXV RPC5",172, 0)
  12936    I '$G(PXD ATE) S PXD ATE=DT
  12937   "RTN","PXV RPC5",173, 0)
  12938    S PXSDATE =$P(PXDATE ,".",1)
  12939   "RTN","PXV RPC5",174, 0)
  12940    S PXEDATE =9999999
  12941   "RTN","PXV RPC5",175, 0)
  12942    I PXSDATE '=DT S PXE DATE=PXSDA TE_".24"
  12943   "RTN","PXV RPC5",176, 0)
  12944    I $G(PXFO RMAT)'?1(1 "W",1"L")  S PXFORMAT ="L"
  12945   "RTN","PXV RPC5",177, 0)
  12946    ;
  12947   "RTN","PXV RPC5",178, 0)
  12948    D PATICR^ PXAPIIM(.P XICRARR,$G (DFN),$G(P XVIMM),PXS DATE,PXEDA TE)
  12949   "RTN","PXV RPC5",179, 0)
  12950    S PXCNT=0
  12951   "RTN","PXV RPC5",180, 0)
  12952    ;
  12953   "RTN","PXV RPC5",181, 0)
  12954    I PXFORMA T="W",$O(P XICRARR(0) ) D
  12955   "RTN","PXV RPC5",182, 0)
  12956    . S PXCNT =PXCNT+1
  12957   "RTN","PXV RPC5",183, 0)
  12958    . S PXRSL T(PXCNT)=" Warning: C ontraindic ation/refu sal event( s) associa ted with t his immuni zation:"
  12959   "RTN","PXV RPC5",184, 0)
  12960    ;
  12961   "RTN","PXV RPC5",185, 0)
  12962    S PXIEN=0
  12963   "RTN","PXV RPC5",186, 0)
  12964    F  S PXIE N=$O(PXICR ARR(PXIEN) ) Q:'PXIEN   D
  12965   "RTN","PXV RPC5",187, 0)
  12966    . D ADDVI CR(.PXRSLT ,.PXICRARR ,.PXIEN,.P XCNT,.PXFO RMAT)
  12967   "RTN","PXV RPC5",188, 0)
  12968    ;
  12969   "RTN","PXV RPC5",189, 0)
  12970    S PXRSLT( 0)=PXCNT
  12971   "RTN","PXV RPC5",190, 0)
  12972    ;
  12973   "RTN","PXV RPC5",191, 0)
  12974    Q
  12975   "RTN","PXV RPC5",192, 0)
  12976    ;
  12977   "RTN","PXV RPC5",193, 0)
  12978   ADDVICR(PX RSLT,PXICR ARR,PXIEN, PXCNT,PXFO RMAT) ; Ad d one entr y to PXRSL T
  12979   "RTN","PXV RPC5",194, 0)
  12980    ;
  12981   "RTN","PXV RPC5",195, 0)
  12982    N PXNODE, PXWARNDT,P XX
  12983   "RTN","PXV RPC5",196, 0)
  12984    ;
  12985   "RTN","PXV RPC5",197, 0)
  12986    I PXFORMA T="L" D
  12987   "RTN","PXV RPC5",198, 0)
  12988    . S PXCNT =PXCNT+1
  12989   "RTN","PXV RPC5",199, 0)
  12990    . S PXRSL T(PXCNT)=" VICR"_U_PX IEN_U_$G(P XICRARR(PX IEN))
  12991   "RTN","PXV RPC5",200, 0)
  12992    . I $G(PX ICRARR(PXI EN,"COMMEN TS"))'=""  D
  12993   "RTN","PXV RPC5",201, 0)
  12994    . . S PXC NT=PXCNT+1
  12995   "RTN","PXV RPC5",202, 0)
  12996    . . S PXR SLT(PXCNT) ="COM"_U_$ G(PXICRARR (PXIEN,"CO MMENTS"))
  12997   "RTN","PXV RPC5",203, 0)
  12998    ;
  12999   "RTN","PXV RPC5",204, 0)
  13000    I PXFORMA T="W" D
  13001   "RTN","PXV RPC5",205, 0)
  13002    . S PXNOD E=$G(PXICR ARR(PXIEN) )
  13003   "RTN","PXV RPC5",206, 0)
  13004    . S PXX=$ P($P(PXNOD E,U,2),"|" ,2)
  13005   "RTN","PXV RPC5",207, 0)
  13006    . S PXWAR NDT=$P(PXN ODE,U,4)
  13007   "RTN","PXV RPC5",208, 0)
  13008    . I PXWAR NDT S PXX= PXX_"  (Un til "_$$FM TE^XLFDT(P XWARNDT,1) _")"
  13009   "RTN","PXV RPC5",209, 0)
  13010    . S PXCNT =PXCNT+1
  13011   "RTN","PXV RPC5",210, 0)
  13012    . S PXRSL T(PXCNT)="  "
  13013   "RTN","PXV RPC5",211, 0)
  13014    . S PXCNT =PXCNT+1
  13015   "RTN","PXV RPC5",212, 0)
  13016    . S PXRSL T(PXCNT)=P XX
  13017   "RTN","PXV RPC5",213, 0)
  13018    . I $G(PX ICRARR(PXI EN,"COMMEN TS"))'=""  D
  13019   "RTN","PXV RPC5",214, 0)
  13020    . . S PXX ="Comment:  "_PXICRAR R(PXIEN,"C OMMENTS")
  13021   "RTN","PXV RPC5",215, 0)
  13022    . . S PXC NT=PXCNT+1
  13023   "RTN","PXV RPC5",216, 0)
  13024    . . S PXR SLT(PXCNT) =PXX
  13025   "RTN","PXV RPC5",217, 0)
  13026    ;
  13027   "RTN","PXV RPC5",218, 0)
  13028    Q
  13029   "RTN","PXV RPC6")
  13030   0^35^B1615 8307^n/a
  13031   "RTN","PXV RPC6",1,0)
  13032   PXVRPC6 ;S LC/AGP - P CE RPCs fo r generati ng IMM Not e Text ;04 /06/16  15 :10
  13033   "RTN","PXV RPC6",2,0)
  13034    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**215* *;Aug 12,  1996;Build  10
  13035   "RTN","PXV RPC6",3,0)
  13036    ;
  13037   "RTN","PXV RPC6",4,0)
  13038    ;
  13039   "RTN","PXV RPC6",5,0)
  13040   GETTEXT(OU TPUT,INPUT ) ;
  13041   "RTN","PXV RPC6",6,0)
  13042    ;
  13043   "RTN","PXV RPC6",7,0)
  13044    ; This RP C takes an  input arr ay of immu nization p roperties  set from t he GUI.
  13045   "RTN","PXV RPC6",8,0)
  13046    ; It retu rns a form atted text  of an imm unization  for use in  documenta tion.
  13047   "RTN","PXV RPC6",9,0)
  13048    ;
  13049   "RTN","PXV RPC6",10,0 )
  13050    ;Input:
  13051   "RTN","PXV RPC6",11,0 )
  13052    ;   INPUT (x)=IMM ^  Imm IEN ^   ^ Date Ad ministered  (for immu nizations)  / Date Co ntra-Refus al Event D ocumented
  13053   "RTN","PXV RPC6",12,0 )
  13054    ;             (for c ontra/refu sals) ^ Wa rn Until D ate (for c ontra/refu sals) ^ Se ries ^ Ref usal reaso n ^
  13055   "RTN","PXV RPC6",13,0 )
  13056    ;             Contra indication  Reason ^  Ordered By  ^ Adminis tered By ( for VA adm inistered)  / Documen ted By
  13057   "RTN","PXV RPC6",14,0 )
  13058    ;             (for h istorical)  ^ Documen t Type ("H istorical" /"Administ ered") ^ I nformation  Source
  13059   "RTN","PXV RPC6",15,0 )
  13060    ;   INPUT (x)=LOC ^  File #44 I EN ^  ^  ^  Outside L ocation (f or histori cals)
  13061   "RTN","PXV RPC6",16,0 )
  13062    ;   INPUT (x)=ROUTE  ^ Route ^  Site ^ Dos age
  13063   "RTN","PXV RPC6",17,0 )
  13064    ;   INPUT (x)=VIS ^  VIS Name ^  Edition D ate ^ Lang uage
  13065   "RTN","PXV RPC6",18,0 )
  13066    ;   INPUT (x)=LOT ^  Lot # ^ Ma nufacturer  ^ Exp Dat e
  13067   "RTN","PXV RPC6",19,0 )
  13068    ;   INPUT (x)=COM ^  Comment
  13069   "RTN","PXV RPC6",20,0 )
  13070    ;   INPUT (x)=OVER ^  Override  Reason
  13071   "RTN","PXV RPC6",21,0 )
  13072    ;
  13073   "RTN","PXV RPC6",22,0 )
  13074    ;Returns:
  13075   "RTN","PXV RPC6",23,0 )
  13076    ;   Forma tted text  of an immu nization f or use in  documentat ion.
  13077   "RTN","PXV RPC6",24,0 )
  13078    ;
  13079   "RTN","PXV RPC6",25,0 )
  13080    N ARRAY,C OMMENT,DOC TYPE,I,IMM ,J,NODE,OV ERRIDE,TEM P,VISCNT,X 0,XLOC,XLO T,XROUTE
  13081   "RTN","PXV RPC6",26,0 )
  13082    S (X0,XRO UTE,XLOC,X LOT,COMMEN T,OVERRIDE )=""
  13083   "RTN","PXV RPC6",27,0 )
  13084    S VISCNT= 0
  13085   "RTN","PXV RPC6",28,0 )
  13086    S I=0
  13087   "RTN","PXV RPC6",29,0 )
  13088    F  S I=$O (INPUT(I))  Q:I'>0  D
  13089   "RTN","PXV RPC6",30,0 )
  13090    . S NODE= $G(INPUT(I ))
  13091   "RTN","PXV RPC6",31,0 )
  13092    . I $P(NO DE,U)="IMM " S X0=$P( NODE,U,2,9 9) Q
  13093   "RTN","PXV RPC6",32,0 )
  13094    . I $P(NO DE,U)="LOC " S XLOC=$ P(NODE,U,2 ,99) Q
  13095   "RTN","PXV RPC6",33,0 )
  13096    . I $P(NO DE,U)="ROU TE" S XROU TE=$P(NODE ,U,2,4) Q
  13097   "RTN","PXV RPC6",34,0 )
  13098    . I $P(NO DE,U)="VIS " S VISCNT =VISCNT+1, ARRAY("VIS ",VISCNT)= $P(NODE,U, 2,99) Q
  13099   "RTN","PXV RPC6",35,0 )
  13100    . I $P(NO DE,U)="LOT " S XLOT=$ P(NODE,U,2 ,99) Q
  13101   "RTN","PXV RPC6",36,0 )
  13102    . I $P(NO DE,U)="COM " S COMMEN T=$P(NODE, U,2) Q
  13103   "RTN","PXV RPC6",37,0 )
  13104    . I $P(NO DE,U)="OVE R" S OVERR IDE=$P(NOD E,U,2) Q
  13105   "RTN","PXV RPC6",38,0 )
  13106    ;
  13107   "RTN","PXV RPC6",39,0 )
  13108    S I=0
  13109   "RTN","PXV RPC6",40,0 )
  13110    ;
  13111   "RTN","PXV RPC6",41,0 )
  13112    S IMM=$P( X0,U,1)
  13113   "RTN","PXV RPC6",42,0 )
  13114    I 'IMM S  OUTPUT(I)= "" Q
  13115   "RTN","PXV RPC6",43,0 )
  13116    S I=I+1
  13117   "RTN","PXV RPC6",44,0 )
  13118    S OUTPUT( I)="IMMUNI ZATION: "_ $P($G(^AUT TIMM(IMM,0 )),U,1)
  13119   "RTN","PXV RPC6",45,0 )
  13120    S J=0 F   S J=$O(^AU TTIMM(IMM, 2,J)) Q:'J   D
  13121   "RTN","PXV RPC6",46,0 )
  13122    . S I=I+1
  13123   "RTN","PXV RPC6",47,0 )
  13124    . S OUTPU T(I)=$S(I= 2:"FULL NA ME: ",1:"" )_$G(^AUTT IMM(IMM,2, J,0))
  13125   "RTN","PXV RPC6",48,0 )
  13126    ;
  13127   "RTN","PXV RPC6",49,0 )
  13128    S DOCTYPE =$P(X0,U,1 0)
  13129   "RTN","PXV RPC6",50,0 )
  13130    ;
  13131   "RTN","PXV RPC6",51,0 )
  13132    ;contrain dacted or  refused
  13133   "RTN","PXV RPC6",52,0 )
  13134    I $P(X0,U ,6)'=""!($ P(X0,U,7)' ="") D  Q
  13135   "RTN","PXV RPC6",53,0 )
  13136    . I $P(X0 ,U,6)'=""  S I=I+1,OU TPUT(I)="R EFUSAL REA SON: "_$P( X0,U,6)
  13137   "RTN","PXV RPC6",54,0 )
  13138    . I $P(X0 ,U,7)'=""  S I=I+1,OU TPUT(I)="C ONTRAINDIC ATION REAS ON: "_$P(X 0,U,7)
  13139   "RTN","PXV RPC6",55,0 )
  13140    . I +$P(X 0,U,4)>0 S  I=I+1,OUT PUT(I)="WA RN UNTIL:  "_$TR($$FM TE^XLFDT($ P(X0,U,4), "2ZM"),"@" ," ")
  13141   "RTN","PXV RPC6",56,0 )
  13142    . I COMME NT'="" S I =I+1,OUTPU T(I)="COMM ENT: "_COM MENT
  13143   "RTN","PXV RPC6",57,0 )
  13144    . S I=I+1 ,OUTPUT(I) ="Date Doc umented: " _$TR($$FMT E^XLFDT($P (X0,U,3)," 2ZM"),"@", " ")
  13145   "RTN","PXV RPC6",58,0 )
  13146    ;
  13147   "RTN","PXV RPC6",59,0 )
  13148    ;determin e label de pending on  admin vs  historical
  13149   "RTN","PXV RPC6",60,0 )
  13150    S TEMP=$S (DOCTYPE=" Historical ":"HISTORI CAL DATE A DMINISTERE D",1:"DATE  ADMINISTE RED")_": " _$TR($$FMT E^XLFDT($P (X0,U,3)," 2ZM"),"@", " ")
  13151   "RTN","PXV RPC6",61,0 )
  13152    S I=I+1,O UTPUT(I)=$ $LJ^XLFSTR (TEMP,60)
  13153   "RTN","PXV RPC6",62,0 )
  13154    I $P(X0,U ,5)'="" S  OUTPUT(I)= OUTPUT(I)_ "SERIES: " _$P(X0,U,5 )
  13155   "RTN","PXV RPC6",63,0 )
  13156    I $P(XLOT ,U,2)'=""  S I=I+1,OU TPUT(I)="M ANUFACTURE R: "_$P(XL OT,U,2)
  13157   "RTN","PXV RPC6",64,0 )
  13158    I $P(XLOT ,U)'="" S  I=I+1,OUTP UT(I)=$$LJ ^XLFSTR("L OT: "_$P(X LOT,U),60) _"EXP DATE : "_$S($P( XLOT,U,3)' ="":$P(XLO T,U,3),1:" Unknown")
  13159   "RTN","PXV RPC6",65,0 )
  13160    ;determin e label de pending on  admin vs  historical
  13161   "RTN","PXV RPC6",66,0 )
  13162    S TEMP=$S ($P(XLOC,U )>0:"LOCAT ION: "_$P( $G(^SC($P( XLOC,U),0) ),U),$P(XL OC,U,4)'=" ":"OUTSIDE  LOCATION:  "_$P(XLOC ,U,4),1:"" )
  13163   "RTN","PXV RPC6",67,0 )
  13164    I TEMP'=" "!($P(XROU TE,U,3)'=" ") D
  13165   "RTN","PXV RPC6",68,0 )
  13166    . S I=I+1 ,OUTPUT(I) =$$LJ^XLFS TR(TEMP,60 )
  13167   "RTN","PXV RPC6",69,0 )
  13168    . I $P(XR OUTE,U,3)' ="" S OUTP UT(I)=OUTP UT(I)_"DOS AGE: "_$P( XROUTE,U,3 )
  13169   "RTN","PXV RPC6",70,0 )
  13170    I $P(XROU TE,U)'=""  S I=I+1,OU TPUT(I)="A DMIN ROUTE /SITE: "_$ P(XROUTE,U )_"/"_$P(X ROUTE,U,2)
  13171   "RTN","PXV RPC6",71,0 )
  13172    I $P(X0,U ,11)'="" S  I=I+1,OUT PUT(I)="IN FORMATION  SOURCE: "_ $P(X0,U,11 )
  13173   "RTN","PXV RPC6",72,0 )
  13174    I $D(ARRA Y("VIS"))  D
  13175   "RTN","PXV RPC6",73,0 )
  13176    . S I=I+1
  13177   "RTN","PXV RPC6",74,0 )
  13178    . S OUTPU T(I)="Vacc ine Inform ation Stat ement(s):"
  13179   "RTN","PXV RPC6",75,0 )
  13180    . S VISCN T=0 F  S V ISCNT=$O(A RRAY("VIS" ,VISCNT))  Q:VISCNT'> 0  D
  13181   "RTN","PXV RPC6",76,0 )
  13182    . . S NOD E=$G(ARRAY ("VIS",VIS CNT))
  13183   "RTN","PXV RPC6",77,0 )
  13184    . . S I=I +1
  13185   "RTN","PXV RPC6",78,0 )
  13186    . . S OUT PUT(I)="VI S Name: "_ $P(NODE,U) _", Editio n Date: "_ $TR($$FMTE ^XLFDT($P( NODE,U,2), "2ZM"),"@" ," ")_", L anguage: " _$P(NODE,U ,3)
  13187   "RTN","PXV RPC6",79,0 )
  13188    I $P(X0,U ,8)'="" S  I=I+1,OUTP UT(I)="ORD ERED BY: " _$P(X0,U,8 )
  13189   "RTN","PXV RPC6",80,0 )
  13190    I $P(X0,U ,9)'="" D
  13191   "RTN","PXV RPC6",81,0 )
  13192    . I DOCTY PE="Admini stered" S  I=I+1,OUTP UT(I)="ADM INISTERED  BY: "_$P(X 0,U,9) Q
  13193   "RTN","PXV RPC6",82,0 )
  13194    . S I=I+1 ,OUTPUT(I) ="DOCUMENT ED BY: "_$ P(X0,U,9)
  13195   "RTN","PXV RPC6",83,0 )
  13196    I COMMENT '="" S I=I +1,OUTPUT( I)="COMMEN T: "_COMME NT
  13197   "RTN","PXV RPC6",84,0 )
  13198    I OVERRID E'="" S I= I+1,OUTPUT (I)="OVERR IDE REASON : "_OVERRI DE
  13199   "RTN","PXV RPC6",85,0 )
  13200    Q
  13201   "RTN","PXV UTIL")
  13202   0^19^B1328 4181^B1000 6565
  13203   "RTN","PXV UTIL",1,0)
  13204   PXVUTIL ;B IR/ADM - V IMM UTILIT Y ROUTINE  ;12/31/15   13:03
  13205   "RTN","PXV UTIL",2,0)
  13206    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**201, 210,215**; Aug 12, 19 96;Build 1 0
  13207   "RTN","PXV UTIL",3,0)
  13208    ;
  13209   "RTN","PXV UTIL",4,0)
  13210    ; Referen ce to UCUM CODE^LEXMU CUM suppor ted by ICR  #6225
  13211   "RTN","PXV UTIL",5,0)
  13212    ;
  13213   "RTN","PXV UTIL",6,0)
  13214   VIS ; disp lay VIS na me with id entifiers
  13215   "RTN","PXV UTIL",7,0)
  13216    N C,PXVNA ME,PXVDATE ,PXVSTAT,P XVLANG,X
  13217   "RTN","PXV UTIL",8,0)
  13218    S X=$G(^A UTTIVIS(Y, 0))
  13219   "RTN","PXV UTIL",9,0)
  13220    S PXVNAME =$P(X,"^") ,PXVDATE=$ P(X,"^",2) ,PXVSTAT=$ P(X,"^",3) ,PXVLANG=$ P(X,"^",4)
  13221   "RTN","PXV UTIL",10,0 )
  13222    S X=PXVDA TE,PXVDATE =$E(X,4,5) _"-"_$E(X, 6,7)_"-"_$ E(X,2,3)
  13223   "RTN","PXV UTIL",11,0 )
  13224    S Y=PXVST AT,C=$P(^D D(920,.03, 0),"^",2)  D:Y'="" Y^ DIQ S PXVS TAT=Y
  13225   "RTN","PXV UTIL",12,0 )
  13226    S Y=PXVLA NG,C=$P(^D D(920,.04, 0),"^",2)  D:Y'="" Y^ DIQ S PXVL ANG=Y
  13227   "RTN","PXV UTIL",13,0 )
  13228    S Y=PXVNA ME_"   "_P XVDATE_"    "_PXVSTAT _"   "_PXV LANG
  13229   "RTN","PXV UTIL",14,0 )
  13230    Q
  13231   "RTN","PXV UTIL",15,0 )
  13232    ;;
  13233   "RTN","PXV UTIL",16,0 )
  13234   DUPDX(PXVI EN,PXVDX)  ; extrinsi c function  to check  for duplic ate diagno ses
  13235   "RTN","PXV UTIL",17,0 )
  13236    ; PXVIEN  - Internal  Entry Num ber of the  event, po inting to  the
  13237   "RTN","PXV UTIL",18,0 )
  13238    ;         V IMMUNIZA TION file  (9000010.1 1)
  13239   "RTN","PXV UTIL",19,0 )
  13240    ; PXVDX i s the diag nosis ente red and us ed to chec k for dupl icates
  13241   "RTN","PXV UTIL",20,0 )
  13242    ;
  13243   "RTN","PXV UTIL",21,0 )
  13244    ; this co de is call ed by the  input tran sforms of:
  13245   "RTN","PXV UTIL",22,0 )
  13246    ;         ^DD(900001 0.11,1304, 0) & ^DD(9 000010.113 ,.01,0)
  13247   "RTN","PXV UTIL",23,0 )
  13248    ;
  13249   "RTN","PXV UTIL",24,0 )
  13250    ; RETURNS  a 1 if th e diagnosi s already  exists for  this
  13251   "RTN","PXV UTIL",25,0 )
  13252    ;          entry, 0  if not
  13253   "RTN","PXV UTIL",26,0 )
  13254    ;
  13255   "RTN","PXV UTIL",27,0 )
  13256    N TXT K T XT S TXT(2 )=" ",TXT( 1,"F")="?5 "
  13257   "RTN","PXV UTIL",28,0 )
  13258    I PXVDX=$ P($G(^AUPN VIMM(PXVIE N,13)),"^" ,4) S TXT( 1)="Select ed diagnos is exists  as the Pri mary Diagn osis for t his event. " D EN^DDI OL(.TXT,"" ,"") Q 1
  13259   "RTN","PXV UTIL",29,0 )
  13260    I $D(^AUP NVIMM(PXVI EN,3,"B",P XVDX)) S T XT(1)="Sel ected diag nosis exis ts for thi s event."  D EN^DDIOL (.TXT,""," ") Q 1
  13261   "RTN","PXV UTIL",30,0 )
  13262    Q 0
  13263   "RTN","PXV UTIL",31,0 )
  13264    ;;
  13265   "RTN","PXV UTIL",32,0 )
  13266   RSETDA ; c ode needed  for the r outine AUP NSICD to h ave the co rrect valu e in
  13267   "RTN","PXV UTIL",33,0 )
  13268    ;   DA, a s AUPNSICD  is not de signed to  be called  from a mul tiple.
  13269   "RTN","PXV UTIL",34,0 )
  13270    N DA S DA =D0
  13271   "RTN","PXV UTIL",35,0 )
  13272    D ^AUPNSI CD
  13273   "RTN","PXV UTIL",36,0 )
  13274    Q
  13275   "RTN","PXV UTIL",37,0 )
  13276   HRS ; call ed by AH n ew style x -ref in V  IMMUNIZATI ON file
  13277   "RTN","PXV UTIL",38,0 )
  13278    ; set num ber of hou rs between  administr ation and  reading of  results
  13279   "RTN","PXV UTIL",39,0 )
  13280    N PXVX,X1 ,X2,X3
  13281   "RTN","PXV UTIL",40,0 )
  13282    S X1=$P($ G(^AUPNVIM M(DA,14)), "^",3) ; D ATE/TIME R EAD
  13283   "RTN","PXV UTIL",41,0 )
  13284    S X2=$P($ G(^AUPNVIM M(DA,12)), "^") ; EVE NT DATE AN D TIME
  13285   "RTN","PXV UTIL",42,0 )
  13286    S X3=2 ;  return dif ference in  seconds
  13287   "RTN","PXV UTIL",43,0 )
  13288    S PXVX=""
  13289   "RTN","PXV UTIL",44,0 )
  13290    I $G(X1), $L(X1)>7,$ G(X2),$L(X 2)>7,$G(X2 )'>$G(X1)  S PXVX=$$F MDIFF^XLFD T(X1,X2,X3 )\3600
  13291   "RTN","PXV UTIL",45,0 )
  13292    S $P(^AUP NVIMM(DA,1 4),"^",6)= PXVX
  13293   "RTN","PXV UTIL",46,0 )
  13294    Q
  13295   "RTN","PXV UTIL",47,0 )
  13296    ;
  13297   "RTN","PXV UTIL",48,0 )
  13298   DOSAGE(PXI EN) ; Used  to comput e Dosage ( 9000010.11 ,1312.5)
  13299   "RTN","PXV UTIL",49,0 )
  13300    ;Input:
  13301   "RTN","PXV UTIL",50,0 )
  13302    ;   PXIEN  = (Requir ed) Pointe r to #9000 010.11
  13303   "RTN","PXV UTIL",51,0 )
  13304    ;Returns:
  13305   "RTN","PXV UTIL",52,0 )
  13306    ;   Conca tenation o f DOSE_" " _DOSE UNIT S (e.g., " .5 mL")
  13307   "RTN","PXV UTIL",53,0 )
  13308    N PXDOSE, PXUNITS
  13309   "RTN","PXV UTIL",54,0 )
  13310    I $G(PXIE N)="" Q ""
  13311   "RTN","PXV UTIL",55,0 )
  13312    S PXDOSE= $P($G(^AUP NVIMM(PXIE N,13)),U,1 2)
  13313   "RTN","PXV UTIL",56,0 )
  13314    I PXDOSE= "" Q ""
  13315   "RTN","PXV UTIL",57,0 )
  13316    S PXDOSE= $FN(PXDOSE ,",")
  13317   "RTN","PXV UTIL",58,0 )
  13318    S PXUNITS =$P($G(^AU PNVIMM(PXI EN,13)),U, 13)
  13319   "RTN","PXV UTIL",59,0 )
  13320    I PXUNITS  S PXUNITS =$P($$UCUM CODE^LEXMU CUM(PXUNIT S),U)  ; I CR 6225
  13321   "RTN","PXV UTIL",60,0 )
  13322    Q PXDOSE_ $S(PXUNITS '="":" "_P XUNITS,1:" ")
  13323   "RTN","PXV UTIL",61,0 )
  13324    ;
  13325   "RTN","PXV UTIL",62,0 )
  13326   OFFER() ;  called fro m screen o n VIS OFFE RED/GIVEN  TO PATIENT  field (#. 01) in
  13327   "RTN","PXV UTIL",63,0 )
  13328    ; VIS OFF ERED/GIVEN  TO PATIEN T multiple  field (#2 ) in file  #9000010.1 1
  13329   "RTN","PXV UTIL",64,0 )
  13330    ;
  13331   "RTN","PXV UTIL",65,0 )
  13332    ; PXD is  defined by  immunizat ion edit p rocess in  PCE and is  the value  of
  13333   "RTN","PXV UTIL",66,0 )
  13334    ; Y from  the DIR ca ll to sele ct an immu nization.
  13335   "RTN","PXV UTIL",67,0 )
  13336    ;
  13337   "RTN","PXV UTIL",68,0 )
  13338    N PXVIS,P XDA
  13339   "RTN","PXV UTIL",69,0 )
  13340    S PXVIS=0
  13341   "RTN","PXV UTIL",70,0 )
  13342    I $G(DA), $D(^AUTTIM M($P(^AUPN VIMM(DA,0) ,"^"),4,"B ",Y)),'$D( ^AUPNVIMM( DA,2,"B",Y )) S PXVIS =1
  13343   "RTN","PXV UTIL",71,0 )
  13344    I '$G(DA) ,$G(PXD) S  PXDA=+PXD  I PXDA,$D (^AUTTIMM( PXDA,4,"B" ,Y)),'$D(^ AUPNVIMM(P XDA,2,"B", Y)) S PXVI S=1
  13345   "RTN","PXV UTIL",72,0 )
  13346    Q PXVIS
  13347   "RTN","PXV UTIL",73,0 )
  13348    ;
  13349   "RTN","PXV UTIL",74,0 )
  13350   IMMSEL(PXV IMM,PXVISI T) ; Immun ization sc reen for V  Immunizat ion file
  13351   "RTN","PXV UTIL",75,0 )
  13352    ;
  13353   "RTN","PXV UTIL",76,0 )
  13354    ; Input:
  13355   "RTN","PXV UTIL",77,0 )
  13356    ;       P XVIMM: Imm unization  IEN (#9999 999.14)
  13357   "RTN","PXV UTIL",78,0 )
  13358    ;      PX VISIT: Vis it IEN (#9 000010)
  13359   "RTN","PXV UTIL",79,0 )
  13360    ;
  13361   "RTN","PXV UTIL",80,0 )
  13362    ; Return:
  13363   "RTN","PXV UTIL",81,0 )
  13364    ;    0: E ntry is no t selectab le
  13365   "RTN","PXV UTIL",82,0 )
  13366    ;    1: E ntry is se lectable
  13367   "RTN","PXV UTIL",83,0 )
  13368    ;
  13369   "RTN","PXV UTIL",84,0 )
  13370    N PXVHIST ,PXVSC,PXV ISITDT
  13371   "RTN","PXV UTIL",85,0 )
  13372    ;
  13373   "RTN","PXV UTIL",86,0 )
  13374    I '$G(PXV IMM) Q 0
  13375   "RTN","PXV UTIL",87,0 )
  13376    ;
  13377   "RTN","PXV UTIL",88,0 )
  13378    S PXVISIT DT=""
  13379   "RTN","PXV UTIL",89,0 )
  13380    I $G(PXVI SIT) S PXV ISITDT=$P( $G(^AUPNVS IT(PXVISIT ,0)),U,1)
  13381   "RTN","PXV UTIL",90,0 )
  13382    ;
  13383   "RTN","PXV UTIL",91,0 )
  13384    S PXVHIST =0
  13385   "RTN","PXV UTIL",92,0 )
  13386    S PXVSC=$ P($G(^AUPN VSIT(+$G(P XVISIT),0) ),U,7)
  13387   "RTN","PXV UTIL",93,0 )
  13388    I $G(PXVS C)="E" S P XVHIST=1
  13389   "RTN","PXV UTIL",94,0 )
  13390    ;
  13391   "RTN","PXV UTIL",95,0 )
  13392    ; For non -historica l, only al low active  entries
  13393   "RTN","PXV UTIL",96,0 )
  13394    I 'PXVHIS T,'$$SCREE N^XTID(999 9999.14,,P XVIMM_",", PXVISITDT)  Q 1
  13395   "RTN","PXV UTIL",97,0 )
  13396    ;
  13397   "RTN","PXV UTIL",98,0 )
  13398    ; For his torical, o nly allow  SELECTABLE  FOR HISTO RIC entrie s
  13399   "RTN","PXV UTIL",99,0 )
  13400    I PXVHIST ,$P($G(^AU TTIMM(PXVI MM,6)),U,1 )="Y" Q 1
  13401   "RTN","PXV UTIL",100, 0)
  13402    ;
  13403   "RTN","PXV UTIL",101, 0)
  13404    Q 0
  13405   "RTN","PXV UTIL",102, 0)
  13406    ;
  13407   "RTN","PXV UTIL",103, 0)
  13408   IMMCRSEL(P XVICR,PXVI MM) ; Immu nization s creen for  V Imm Cont ra/Refusal  Events fi le
  13409   "RTN","PXV UTIL",104, 0)
  13410    ;
  13411   "RTN","PXV UTIL",105, 0)
  13412    ; Input:
  13413   "RTN","PXV UTIL",106, 0)
  13414    ;    PXVI CR: Contra indication /Refusal V ariable Po inter (#90 00010.707,  #.01)
  13415   "RTN","PXV UTIL",107, 0)
  13416    ;    PXVI MM: Immuni zation IEN  (#9999999 .14)
  13417   "RTN","PXV UTIL",108, 0)
  13418    ;
  13419   "RTN","PXV UTIL",109, 0)
  13420    ; Return:
  13421   "RTN","PXV UTIL",110, 0)
  13422    ;    0: E ntry is no t selectab le
  13423   "RTN","PXV UTIL",111, 0)
  13424    ;    1: E ntry is se lectable
  13425   "RTN","PXV UTIL",112, 0)
  13426    ;
  13427   "RTN","PXV UTIL",113, 0)
  13428    N PXCONTR A,PXRSLT
  13429   "RTN","PXV UTIL",114, 0)
  13430    ;
  13431   "RTN","PXV UTIL",115, 0)
  13432    S PXRSLT= 0
  13433   "RTN","PXV UTIL",116, 0)
  13434    ;
  13435   "RTN","PXV UTIL",117, 0)
  13436    I '$G(PXV ICR) Q PXR SLT
  13437   "RTN","PXV UTIL",118, 0)
  13438    I '$G(PXV IMM) Q PXR SLT
  13439   "RTN","PXV UTIL",119, 0)
  13440    ;
  13441   "RTN","PXV UTIL",120, 0)
  13442    I PXVICR[ 920.5 D  Q  PXRSLT
  13443   "RTN","PXV UTIL",121, 0)
  13444    . I $$IMM STAT^PXAPI IM(PXVIMM) ?1(1"A",1" H") S PXRS LT=1
  13445   "RTN","PXV UTIL",122, 0)
  13446    ;
  13447   "RTN","PXV UTIL",123, 0)
  13448    S PXCONTR A=+PXVICR
  13449   "RTN","PXV UTIL",124, 0)
  13450    ;
  13451   "RTN","PXV UTIL",125, 0)
  13452    ; Immuniz ations Lim ited To mu ltiple is  null
  13453   "RTN","PXV UTIL",126, 0)
  13454    I '$O(^PX V(920.4,PX CONTRA,3,0 )) D  Q PX RSLT
  13455   "RTN","PXV UTIL",127, 0)
  13456    . I $$IMM STAT^PXAPI IM(PXVIMM) ?1(1"A",1" H") S PXRS LT=1
  13457   "RTN","PXV UTIL",128, 0)
  13458    ;
  13459   "RTN","PXV UTIL",129, 0)
  13460    ; PXVIMM  is an entr y in the I mmunizatio ns Limited  To multip le
  13461   "RTN","PXV UTIL",130, 0)
  13462    I $O(^PXV (920.4,PXC ONTRA,3,"B ",PXVIMM,0 )) S PXRSL T=1
  13463   "RTN","PXV UTIL",131, 0)
  13464    ;
  13465   "RTN","PXV UTIL",132, 0)
  13466    Q PXRSLT
  13467   "RTN","PXV ZRT")
  13468   0^28^B8254 6869^B7115 9926
  13469   "RTN","PXV ZRT",1,0)
  13470   PXVZRT ;SL C/PBB - VI MM UTILITY  ROUTINE ; 01/15/2015   4:44 PM
  13471   "RTN","PXV ZRT",2,0)
  13472    ;;1.0;PCE  PATIENT C ARE ENCOUN TER;**206, 215**;Aug  12, 1996;B uild 10
  13473   "RTN","PXV ZRT",3,0)
  13474    ;
  13475   "RTN","PXV ZRT",4,0)
  13476    Q
  13477   "RTN","PXV ZRT",5,0)
  13478   ZRT ;Manip ulate upda te of MFN  ZRT segmen t for Immu nization f iles
  13479   "RTN","PXV ZRT",6,0)
  13480    I IEN,((N AME="Term" )!(NAME="S tatus")) K  XXIEN ;Th is is the  indication  that it's  first upd ate for an y subfile
  13481   "RTN","PXV ZRT",7,0)
  13482    S:$D(HLNO DE(1)) HLN ODE=HLNODE _HLNODE(1)
  13483   "RTN","PXV ZRT",8,0)
  13484    G 920:IFN =920,99999 914:IFN=99 99999.14,9 9999928:IF N=9999999. 28,9204:IF N=920.4,99 999904:IFN =9999999.0 4,9201:IFN =920.1
  13485   "RTN","PXV ZRT",9,0)
  13486    Q
  13487   "RTN","PXV ZRT",10,0)
  13488   920 ; Mani pulate upd ate of MFN  ZRT segme nt for 920  File
  13489   "RTN","PXV ZRT",11,0)
  13490    I IEN,NAM E="Term" D   Q
  13491   "RTN","PXV ZRT",12,0)
  13492    .N Y,X1
  13493   "RTN","PXV ZRT",13,0)
  13494    .S X1=$$U NESC^XUMF0 ($P(HLNODE ,HLFS,3),. HL)
  13495   "RTN","PXV ZRT",14,0)
  13496    .;Get Nam e, Date an d Language  from Term
  13497   "RTN","PXV ZRT",15,0)
  13498    .F I=1:1  S Y=$P(X1, " ",I) Q:Y ?1N.N1"/"1 N.N1"/"1N. N  I '$L(Y ),'$L($P(X 1," ",I+1, 99)) Q
  13499   "RTN","PXV ZRT",16,0)
  13500    .I Y="" S  ERROR="1^ Error - .0 1 is inval id"_" File  #: "_IFN_ " HLNODE=" _HLNODE Q
  13501   "RTN","PXV ZRT",17,0)
  13502    .S X1=$P( X1,Y)
  13503   "RTN","PXV ZRT",18,0)
  13504    .S Y=$L(X 1) F I=Y:- 1 Q:$E(X1, I)'=" "  S  X1=$E(X1, 1,Y-1) ;Ge t rid of s paces on e nd of .01
  13505   "RTN","PXV ZRT",19,0)
  13506    .S $P(HLN ODE,HLFS,3 )=X1
  13507   "RTN","PXV ZRT",20,0)
  13508    I IEN,NAM E="VistA_V IS_Languag e" D  Q
  13509   "RTN","PXV ZRT",21,0)
  13510    .N DIC,X, IENS
  13511   "RTN","PXV ZRT",22,0)
  13512    .S NAME=$ $UNESC^XUM F0($P(HLNO DE,HLFS,3) ,.HL)
  13513   "RTN","PXV ZRT",23,0)
  13514    .S DIC=.8 5,DIC(0)=" M",X=NAME  D ^DIC I Y <0 S ERROR ="1^Error  - .04 LANG UAGE is in valid"_" F ile #: "_I FN_" HLNOD E="_HLNODE  Q
  13515   "RTN","PXV ZRT",24,0)
  13516    .S IENS=I EN_","
  13517   "RTN","PXV ZRT",25,0)
  13518    .S FDA(IF N,IENS,.04 )=+Y
  13519   "RTN","PXV ZRT",26,0)
  13520    .S OUT=1
  13521   "RTN","PXV ZRT",27,0)
  13522    .Q
  13523   "RTN","PXV ZRT",28,0)
  13524    I 'IEN,NA ME="Term"  D  Q
  13525   "RTN","PXV ZRT",29,0)
  13526    .;Assumin g that the  " " delim iter is us ed in Term
  13527   "RTN","PXV ZRT",30,0)
  13528    .;Assumin g MFS Upda te will be  in the fo rm:
  13529   "RTN","PXV ZRT",31,0)
  13530    .; ZRT^Te rm^ANTHRAX  VIS 3/10/ 2010 ENGLI SH
  13531   "RTN","PXV ZRT",32,0)
  13532    .; ZRT^Vi stA_VIS_Ed ition_Date ^3/10/2010      in fo rm:mm/dd/y y
  13533   "RTN","PXV ZRT",33,0)
  13534    .; ZRT^Vi stA_VIS_La nguage^ENG LISH
  13535   "RTN","PXV ZRT",34,0)
  13536    .N DIC,X, X1,X2,X3,Y ,XREF,ROOT ,FDA,ERR,I ENS,IIEN,% DT,I
  13537   "RTN","PXV ZRT",35,0)
  13538    .S NAME=$ $UNESC^XUM F0($P(HLNO DE,HLFS,3) ,.HL)
  13539   "RTN","PXV ZRT",36,0)
  13540    .S ROOT=$ $ROOT^DILF D(IFN,,1)
  13541   "RTN","PXV ZRT",37,0)
  13542    .;Get Nam e, Date an d Language  from Term
  13543   "RTN","PXV ZRT",38,0)
  13544    .F I=1:1  S Y=$P(NAM E," ",I) Q :Y?1N.N1"/ "1N.N1"/"1 N.N  I '$L (Y),'$L($P (NAME," ", I+1,99)) Q
  13545   "RTN","PXV ZRT",39,0)
  13546    .I Y="" S  ERROR="1^ Error - .0 1 is inval id"_" File  #: "_IFN_ " HLNODE=" _HLNODE Q
  13547   "RTN","PXV ZRT",40,0)
  13548    .S X1=$P( NAME,Y),X2 =Y,X3=$P(N AME,Y,2)
  13549   "RTN","PXV ZRT",41,0)
  13550    .F I=1:1  Q:$E(X3,I) '=" "  S X 3=$E(X3,I+ 1,$L(X3))  ;Get rid o f leading  spaces fro m Language .
  13551   "RTN","PXV ZRT",42,0)
  13552    .S Y=$L(X 1) F I=Y:- 1 Q:$E(X1, I)'=" "  S  X1=$E(X1, 1,Y-1) ;Ge t rid of s paces on e nd of .01
  13553   "RTN","PXV ZRT",43,0)
  13554    .;Get Dat e from Ter m
  13555   "RTN","PXV ZRT",44,0)
  13556    .;put it  into form:  3140819
  13557   "RTN","PXV ZRT",45,0)
  13558    .S X=X2 D  ^%DT
  13559   "RTN","PXV ZRT",46,0)
  13560    .I Y=-1 S  ERROR="1^ Error - .0 2 in Term  is invalid "_" File # : "_IFN_"  HLNODE="_H LNODE Q
  13561   "RTN","PXV ZRT",47,0)
  13562    .S X2=Y
  13563   "RTN","PXV ZRT",48,0)
  13564    .;
  13565   "RTN","PXV ZRT",49,0)
  13566    .S DIC=.8 5,DIC(0)=" M",X=X3 D  ^DIC I Y<0  S ERROR=" 1^Error -  .04 LANGUA GE is inva lid"_" Fil e #: "_IFN _" HLNODE= "_HLNODE Q
  13567   "RTN","PXV ZRT",50,0)
  13568    .S X3=+Y
  13569   "RTN","PXV ZRT",51,0)
  13570    .;Lookup  B x-ref an d see if m atch of da te and Lan guage.
  13571   "RTN","PXV ZRT",52,0)
  13572    .S IIEN=0
  13573   "RTN","PXV ZRT",53,0)
  13574    .F  Q:ERR OR  S IIEN =$O(@ROOT@ ("B",X1,II EN)) Q:'II EN  S IENS =IIEN_","  I $$GET1^D IQ(920,IEN S,.02,"I") =X2,$$GET1 ^DIQ(920,I ENS,.04,"I ")=X3 D:IE N  S IEN=I IEN
  13575   "RTN","PXV ZRT",54,0)
  13576    ..;Here t he error g enerated i f more as  one entry  match ,01   and .02 a nd .04
  13577   "RTN","PXV ZRT",55,0)
  13578    ..S ERROR ="1^Error  - File IEN s duplicat e: "_IEN_"  and "_IIE N_" File # : "_IFN_"  HLNODE="_H LNODE Q
  13579   "RTN","PXV ZRT",56,0)
  13580    .Q:ERROR
  13581   "RTN","PXV ZRT",57,0)
  13582    .;
  13583   "RTN","PXV ZRT",58,0)
  13584    .I IEN D
  13585   "RTN","PXV ZRT",59,0)
  13586    ..M RECOR D("BEFORE" )=@ROOT@(I EN)
  13587   "RTN","PXV ZRT",60,0)
  13588    ..S RECOR D("STATUS" )=$$GETSTA T^XTID(IFN ,,IEN_",")
  13589   "RTN","PXV ZRT",61,0)
  13590    .I 'IEN D   Q:ERROR
  13591   "RTN","PXV ZRT",62,0)
  13592    ..D CHK^D IE(IFN,.01 ,,X1,.X)
  13593   "RTN","PXV ZRT",63,0)
  13594    ..I X="^"  S ERROR=" 1^Error -  .01 is inv alid"_" Fi le #: "_IF N_" HLNODE ="_HLNODE  Q
  13595   "RTN","PXV ZRT",64,0)
  13596    ..K DIC S  DIC=IFN,D IC(0)="F"  D FILE^DIC N K DIC
  13597   "RTN","PXV ZRT",65,0)
  13598    ..I Y="-1 " S ERROR= "1^Error -  stub entr y IFN: "_I FN_" faile d HLNODE:  "_HLNODE Q
  13599   "RTN","PXV ZRT",66,0)
  13600    ..S IEN=+ Y,RECORD(" NEW")=1
  13601   "RTN","PXV ZRT",67,0)
  13602    .;
  13603   "RTN","PXV ZRT",68,0)
  13604    .S:'$G(RE CORD("NEW" )) ^TMP("X UMF EVENT" ,$J,IFN,"B EFORE",IEN ,"REPLACED  BY")=""
  13605   "RTN","PXV ZRT",69,0)
  13606    .S:'$G(RE CORD("NEW" )) ^TMP("X UMF EVENT" ,$J,IFN,"B EFORE",IEN ,"INHERITS  FROM")=""
  13607   "RTN","PXV ZRT",70,0)
  13608    .;
  13609   "RTN","PXV ZRT",71,0)
  13610    .S IENS=I EN_","
  13611   "RTN","PXV ZRT",72,0)
  13612    .;
  13613   "RTN","PXV ZRT",73,0)
  13614    .S FDA(IF N,IENS,99. 99)=VUID
  13615   "RTN","PXV ZRT",74,0)
  13616    .S FDA(IF N,IENS,99. 98)=1
  13617   "RTN","PXV ZRT",75,0)
  13618    .;
  13619   "RTN","PXV ZRT",76,0)
  13620    .K ERR
  13621   "RTN","PXV ZRT",77,0)
  13622    .;
  13623   "RTN","PXV ZRT",78,0)
  13624    .D FILE^D IE("E","FD A","ERR")
  13625   "RTN","PXV ZRT",79,0)
  13626    .I $D(ERR ) D
  13627   "RTN","PXV ZRT",80,0)
  13628    ..S ERROR ="1^VUID u pdate erro r IFN: "_I FN_" IEN:  "_IEN_" VU ID: "_VUID _" HLNODE:  "_HLNODE
  13629   "RTN","PXV ZRT",81,0)
  13630    ..D EM^XU MF1H(ERROR ,.ERR) K E RR
  13631   "RTN","PXV ZRT",82,0)
  13632    .;
  13633   "RTN","PXV ZRT",83,0)
  13634    .;Execute  Additiona l coding f or  4.001, 3  ADD-PRO CESSING LO GIC
  13635   "RTN","PXV ZRT",84,0)
  13636    .D ADD^XU MF1H
  13637   "RTN","PXV ZRT",85,0)
  13638    .;
  13639   "RTN","PXV ZRT",86,0)
  13640    .; clean  multiple f lag
  13641   "RTN","PXV ZRT",87,0)
  13642    .K:'$D(XI EN(IEN)) X IEN
  13643   "RTN","PXV ZRT",88,0)
  13644    .S XIEN(I EN)=$G(XIE N(IEN))+1
  13645   "RTN","PXV ZRT",89,0)
  13646    .S OUT=1
  13647   "RTN","PXV ZRT",90,0)
  13648    Q
  13649   "RTN","PXV ZRT",91,0)
  13650   99999914 ;  Manipulat e update o f MFN ZRT  segment fo r 9999999. 14 File
  13651   "RTN","PXV ZRT",92,0)
  13652    N X,XX,ER R,IENS,IEN 1,IENX,X1, X2,X3,X4,X 5,X6,DA,DI K,I,FDAA,I I,TMP
  13653   "RTN","PXV ZRT",93,0)
  13654    I IEN,NAM E="VistA_C VX_Mapping " D  Q  ;Z RT^VistA_C VX_Mapping ^CPT:90701 ,90743
  13655   "RTN","PXV ZRT",94,0)
  13656    .S X=$P(H LNODE,HLFS ,3) ;X=CPT :90701,907 43
  13657   "RTN","PXV ZRT",95,0)
  13658    .I '$L(X) !(X="""""" ) D DS(999 9999.143,I EN) S OUT= 1 Q  ;Q:$G (OUT)  ;If  there is  nothing co ming from  Push, wipe  anything  was there  before
  13659   "RTN","PXV ZRT",96,0)
  13660    .I '$G(XX IEN(999999 9.143)) D  DS(9999999 .143,IEN)   S XXIEN(9 999999.143 )=1 ;CLEAN  SUBFILE E NTRY
  13661   "RTN","PXV ZRT",97,0)
  13662    .S X1=$P( X,":"),X2= $P(X,":",2 )
  13663   "RTN","PXV ZRT",98,0)
  13664    .D DUP(99 99999.143, X1,X2) ; C hecup for  duplicate  coding sys tem (ICD,  10D, CPT.. .) and cod es
  13665   "RTN","PXV ZRT",99,0)
  13666    .Q:$G(ERR OR)
  13667   "RTN","PXV ZRT",100,0 )
  13668    .S IENS=I EN_","
  13669   "RTN","PXV ZRT",101,0 )
  13670    .S IEN1=" +1,",FDAA( 9999999.14 3,"+1,"_IE NS,.01)=X1
  13671   "RTN","PXV ZRT",102,0 )
  13672    .F I=2:1  S X4=$P(X2 ,",",I-1)  Q:'$L(X4)   S IENX="+ "_I_","_IE N1_IENS,FD AA(9999999 .1431,IENX ,.01)=X4
  13673   "RTN","PXV ZRT",103,0 )
  13674    .D:$D(FDA A) UPDATE^ DIE("","FD AA",,"ERR" )
  13675   "RTN","PXV ZRT",104,0 )
  13676    .I $D(ERR ) D  Q
  13677   "RTN","PXV ZRT",105,0 )
  13678    ..S ERROR ="1^subfil e update e rror SUBFI LE#: 99999 99.1431 HL NODE:"_HLN ODE
  13679   "RTN","PXV ZRT",106,0 )
  13680    ..D EM^XU MF1H(ERROR ,.ERR)
  13681   "RTN","PXV ZRT",107,0 )
  13682    .Q:$G(ERR OR)
  13683   "RTN","PXV ZRT",108,0 )
  13684    .S OUT=1
  13685   "RTN","PXV ZRT",109,0 )
  13686    I IEN,NAM E="VistA_C DC_Product _Name" D   Q
  13687   "RTN","PXV ZRT",110,0 )
  13688    .I $P(HLN ODE,HLFS,3 )="""""" D  DS(999999 9.145,IEN)  S OUT=1 Q
  13689   "RTN","PXV ZRT",111,0 )
  13690    .I '$G(XX IEN(999999 9.145)) D  DS(9999999 .145,IEN)   S XXIEN(9 999999.145 )=1 ;CLEAN  SUBFILE E NTRY
  13691   "RTN","PXV ZRT",112,0 )
  13692    I IEN,NAM E="VistA_S ynonym" D   Q
  13693   "RTN","PXV ZRT",113,0 )
  13694    .I $P(HLN ODE,HLFS,3 )="""""" D  DS(999999 9.141,IEN)  S OUT=1 Q
  13695   "RTN","PXV ZRT",114,0 )
  13696    .I '$G(XX IEN(999999 9.141)) D  DS(9999999 .141,IEN)   S XXIEN(9 999999.141 )=1 ;CLEAN  SUBFILE E NTRY
  13697   "RTN","PXV ZRT",115,0 )
  13698    I IEN,NAM E="VistA_I nactive_Fl ag" D  Q
  13699   "RTN","PXV ZRT",116,0 )
  13700    .S:$P(HLN ODE,HLFS,3 )'=1 $P(HL NODE,HLFS, 3)=""""""
  13701   "RTN","PXV ZRT",117,0 )
  13702    I IEN,NAM E="vista_h as_vis" D   Q
  13703   "RTN","PXV ZRT",118,0 )
  13704    .I $P(HLN ODE,HLFS,3 )="""""" D  DS(999999 9.144,IEN)  S OUT=1 Q
  13705   "RTN","PXV ZRT",119,0 )
  13706    .I '$G(XX IEN(999999 9.144)) D  DS(9999999 .144,IEN)   S XXIEN(9 999999.144 )=1 ;CLEAN  SUBFILE E NTRY
  13707   "RTN","PXV ZRT",120,0 )
  13708    I IEN,NAM E="VistA_I mmunizatio n_Group" D   Q
  13709   "RTN","PXV ZRT",121,0 )
  13710    .I $P(HLN ODE,HLFS,3 )="""""" D  DS(999999 9.147,IEN)  S OUT=1 Q
  13711   "RTN","PXV ZRT",122,0 )
  13712    .I '$G(XX IEN(999999 9.147)) D  DS(9999999 .147,IEN)   S XXIEN(9 999999.147 )=1 ;CLEAN  SUBFILE E NTRY
  13713   "RTN","PXV ZRT",123,0 )
  13714    I IEN,NAM E="Status"  D IFST(.0 7,"",1) Q
  13715   "RTN","PXV ZRT",124,0 )
  13716    Q
  13717   "RTN","PXV ZRT",125,0 )
  13718   99999928   ; Manipula te update  of MFN ZRT  segment f or 9999999 .28 File
  13719   "RTN","PXV ZRT",126,0 )
  13720    N X,ERR,I ENS,IEN1,I ENX,X1,X2, X4,DA,DIK, I,FDAA
  13721   "RTN","PXV ZRT",127,0 )
  13722    I IEN,NAM E="VistA_S kin_Test_M apping" D   Q
  13723   "RTN","PXV ZRT",128,0 )
  13724    .;ZRT^Vis tA_Skin_Te st_Mapping ^CPT:90701 ,90743
  13725   "RTN","PXV ZRT",129,0 )
  13726    .S X=$P(H LNODE,HLFS ,3) ;X=CPT :90701,907 43
  13727   "RTN","PXV ZRT",130,0 )
  13728    .I '$L(X) !(X="""""" ) D DS(999 9999.283,I EN) S OUT= 1 Q  ;Q:$G (OUT)  ;If  there is  nothing co ming from  Push, wipe  anything  was there  before
  13729   "RTN","PXV ZRT",131,0 )
  13730    .I '$G(XX IEN(999999 9.283)) D  DS(9999999 .283,IEN)   S XXIEN(9 999999.283 )=1 ;CLEAN  SUBFILE E NTRY
  13731   "RTN","PXV ZRT",132,0 )
  13732    .S X1=$P( X,":"),X2= $P(X,":",2 ) ;$$FIND1 ^DIC(FILE, IENS,FLAGS ,[.]VALUE, [.]INDEXES ,[.]SCREEN ,MSG_ROOT)
  13733   "RTN","PXV ZRT",133,0 )
  13734    .D DUP(99 99999.283, X1,X2) ; C heckup for  duplicate  coding sy stem (ICD,  10D, CPT. ..) and co des
  13735   "RTN","PXV ZRT",134,0 )
  13736    .Q:$G(ERR OR)
  13737   "RTN","PXV ZRT",135,0 )
  13738    .S IENS=I EN_","
  13739   "RTN","PXV ZRT",136,0 )
  13740    .S IEN1=" +1,",FDAA( 9999999.28 3,"+1,"_IE NS,.01)=X1
  13741   "RTN","PXV ZRT",137,0 )
  13742    .F I=2:1  S X4=$P(X2 ,",",I-1)  Q:'$L(X4)   S IENX="+ "_I_","_IE N1_IENS,FD AA(9999999 .2831,IENX ,.01)=X4
  13743   "RTN","PXV ZRT",138,0 )
  13744    .D:$D(FDA A) UPDATE^ DIE("","FD AA",,"ERR" )
  13745   "RTN","PXV ZRT",139,0 )
  13746    .I $D(ERR ) D  Q
  13747   "RTN","PXV ZRT",140,0 )
  13748    ..S ERROR ="1^subfil e update e rror SUBFI LE#: 99999 99.2831 HL NODE:"_HLN ODE
  13749   "RTN","PXV ZRT",141,0 )
  13750    ..D EM^XU MF1H(ERROR ,.ERR)
  13751   "RTN","PXV ZRT",142,0 )
  13752    .Q:$G(ERR OR)
  13753   "RTN","PXV ZRT",143,0 )
  13754    .S OUT=1
  13755   "RTN","PXV ZRT",144,0 )
  13756    I IEN,NAM E="VistA_I nactive_Fl ag" D  Q
  13757   "RTN","PXV ZRT",145,0 )
  13758    .S:$P(HLN ODE,HLFS,3 )'=1 $P(HL NODE,HLFS, 3)=""""""
  13759   "RTN","PXV ZRT",146,0 )
  13760    I IEN,NAM E="VistA_C PT_Code" D   Q
  13761   "RTN","PXV ZRT",147,0 )
  13762    .S OUT=1
  13763   "RTN","PXV ZRT",148,0 )
  13764    I IEN,NAM E="Status"  D IFST(.0 3,"",1) Q
  13765   "RTN","PXV ZRT",149,0 )
  13766    Q
  13767   "RTN","PXV ZRT",150,0 )
  13768   9204 ; Man ipulate up date of MF N ZRT segm ent for 92 0.4 File
  13769   "RTN","PXV ZRT",151,0 )
  13770    I IEN,NAM E="vista_a pplies_to"  D  Q
  13771   "RTN","PXV ZRT",152,0 )
  13772    .I $P(HLN ODE,HLFS,3 )="""""" D  DS(920.43 ,IEN) S OU T=1 Q
  13773   "RTN","PXV ZRT",153,0 )
  13774    .I '$G(XX IEN(920.43 )) D DS(92 0.43,IEN)   S XXIEN(9 20.43)=1 ; CLEAN SUBF ILE ENTRY
  13775   "RTN","PXV ZRT",154,0 )
  13776    I IEN,NAM E="Status"  D IFST(.0 3,0,1) Q
  13777   "RTN","PXV ZRT",155,0 )
  13778    Q
  13779   "RTN","PXV ZRT",156,0 )
  13780   9201 ; Man ipulate up date of MF N ZRT Segm ent for 92 0.01 File
  13781   "RTN","PXV ZRT",157,0 )
  13782    I IEN,NAM E="Status"  D IFST(.0 3,0,1) Q
  13783   "RTN","PXV ZRT",158,0 )
  13784    Q
  13785   "RTN","PXV ZRT",159,0 )
  13786   99999904 ;  Manipulat e update o f MFN ZRT  Segment fo r 9999999. 04 File
  13787   "RTN","PXV ZRT",160,0 )
  13788    I IEN,NAM E="Status"  D IFST(.0 3,0,1) Q
  13789   "RTN","PXV ZRT",161,0 )
  13790    Q
  13791   "RTN","PXV ZRT",162,0 )
  13792   M92002 ;Co nversion o f File:920  field .02   EDITION  DATE to VE TS form  0 2/31/2014
  13793   "RTN","PXV ZRT",163,0 )
  13794    N Y,X ;Da te in inte rnal form:   3140231
  13795   "RTN","PXV ZRT",164,0 )
  13796    ;set Y to  HL7 Form:   20140231  and subse quently to : >> 2/31/ 2014 <<
  13797   "RTN","PXV ZRT",165,0 )
  13798    S Y=$$FMT HL7^XLFDT( TMP1(LEV,X 2,IENS,I)) ,TMP1(LEV, X2,IENS,I) =" "_+$E(Y ,5,6)_"/"_ +$E(Y,7,8) _"/"_$E(Y, 1,4)_" "
  13799   "RTN","PXV ZRT",166,0 )
  13800    ;Note tha t space pu t at begin ing and en d to get f orm: >>ADE NOVIRUS VI S 6/11/201 4 ENGLISH< <
  13801   "RTN","PXV ZRT",167,0 )
  13802    Q
  13803   "RTN","PXV ZRT",168,0 )
  13804   M92004 ;Co nversion o f File:920  field .04   POINTER  TO LANGUAG E FILE (#. 85)
  13805   "RTN","PXV ZRT",169,0 )
  13806    S TMP1(LE V,X2,IENS, I)=$$GET1^ DIQ(.85,TM P1(LEV,X2, IENS,I)_", ",1)
  13807   "RTN","PXV ZRT",170,0 )
  13808    Q
  13809   "RTN","PXV ZRT",171,0 )
  13810   M92003 ;Co nversion o f File:920  field .03  EDITION S TATUS
  13811   "RTN","PXV ZRT",172,0 )
  13812    ;Get:   7 /26/2013HI STORICENGL ISH
  13813   "RTN","PXV ZRT",173,0 )
  13814    ;Get .02  _ .03 _ .0 4   get ri d of space  on start  and end.
  13815   "RTN","PXV ZRT",174,0 )
  13816    N X,Y,XX, DIC
  13817   "RTN","PXV ZRT",175,0 )
  13818    S XX=$$GE T1^DIQ(.85 ,TMP1(LEV, X2,IENS,.0 4)_",",1)
  13819   "RTN","PXV ZRT",176,0 )
  13820    S TMP1(LE V,X2,IENS, I)=$E(TMP1 (LEV,X2,IE NS,.02),2, $L(TMP1(LE V,X2,IENS, .02))-1)_T MP1(LEV,X2 ,IENS,I)_X X
  13821   "RTN","PXV ZRT",177,0 )
  13822    Q
  13823   "RTN","PXV ZRT",178,0 )
  13824   M999142 ;C onversion  of File:99 99999.14 F IELD:.2  C OMBINATION  IMMUNIZAT ION COMVER T FROM 1 t o Y  and f rom 0 to N
  13825   "RTN","PXV ZRT",179,0 )
  13826    N X
  13827   "RTN","PXV ZRT",180,0 )
  13828    S X=TMP1( LEV,X2,IEN S,I),TMP1( LEV,X2,IEN S,I)=$S(X: "Y",1:"N")
  13829   "RTN","PXV ZRT",181,0 )
  13830    Q
  13831   "RTN","PXV ZRT",182,0 )
  13832   M9992803 ; Conversion  of File:9 999999.28  FIELD:.03   INACTIVE  FLAG
  13833   "RTN","PXV ZRT",183,0 )
  13834    S:TMP1(LE V,X2,IENS, I)'=1 TMP1 (LEV,X2,IE NS,I)=0
  13835   "RTN","PXV ZRT",184,0 )
  13836    Q
  13837   "RTN","PXV ZRT",185,0 )
  13838   M999283 ;C onversion  of File:99 99999.28 F IELD: 3  C ODING SYST EM  From:  CPT to CPT :00001,000 02
  13839   "RTN","PXV ZRT",186,0 )
  13840    ;TMP1(2," 9999999.28 3","1,7,", ".01")="CP T"    D GE TS^DIQ(X2, IENS,"*"," ","TMP1(LE V)")
  13841   "RTN","PXV ZRT",187,0 )
  13842    N TMP,X4, X3,II
  13843   "RTN","PXV ZRT",188,0 )
  13844    S X4=TMP1 (LEV,X2,IE NS,I)_":"  ;X4=CPT:
  13845   "RTN","PXV ZRT",189,0 )
  13846    D GETS^DI Q(9999999. 283,IENS," **","","TM P") ;TMP(9 999999.283 1,"1,1,7," ,.01)=8648 5
  13847   "RTN","PXV ZRT",190,0 )
  13848    S II="" F   S II=$O( TMP(999999 9.2831,II) ) Q:'II  S  X3=$G(TMP (9999999.2 831,II,.01 )) S:$L(X3 ) X4=X4_X3 _","
  13849   "RTN","PXV ZRT",191,0 )
  13850    S:$L(X3)  X4=$E(X4,1 ,$L(X4)-1)  S TMP1(LE V,X2,IENS, I)=X4
  13851   "RTN","PXV ZRT",192,0 )
  13852    Q
  13853   "RTN","PXV ZRT",193,0 )
  13854   M999143 ;C onversion  of File:99 99999.14 F IELD: 3  C ODING SYST EM  From:  CPT to CPT :00001,000 02
  13855   "RTN","PXV ZRT",194,0 )
  13856    ;TMP1(2," 9999999.14 3","1,7,", ".01")="CP T"    D GE TS^DIQ(X2, IENS,"*"," ","TMP1(LE V)")
  13857   "RTN","PXV ZRT",195,0 )
  13858    N TMP,X4, X3,II
  13859   "RTN","PXV ZRT",196,0 )
  13860    S X4=TMP1 (LEV,X2,IE NS,I)_":"  ;X4=CPT:
  13861   "RTN","PXV ZRT",197,0 )
  13862    D GETS^DI Q(9999999. 143,IENS," **","","TM P") ;TMP(9 999999.143 1,"1,1,7," ,.01)=8648 5
  13863   "RTN","PXV ZRT",198,0 )
  13864    S II="" F   S II=$O( TMP(999999 9.1431,II) ) Q:'II  S  X3=$G(TMP (9999999.1 431,II,.01 )) S:$L(X3 ) X4=X4_X3 _","
  13865   "RTN","PXV ZRT",199,0 )
  13866    ;S X4=$S( $L(X3):$E( X4,1,$L(X4 )-1),1:"")  S TMP1(LE V,X2,IENS, I)=X4
  13867   "RTN","PXV ZRT",200,0 )
  13868    S:$L(X3)  X4=$E(X4,1 ,$L(X4)-1)  S TMP1(LE V,X2,IENS, I)=X4
  13869   "RTN","PXV ZRT",201,0 )
  13870    Q
  13871   "RTN","PXV ZRT",202,0 )
  13872   DS(SUBFILE ,IENS) ;De lete subfi le
  13873   "RTN","PXV ZRT",203,0 )
  13874    N ROOT,ID X,X
  13875   "RTN","PXV ZRT",204,0 )
  13876    S ROOT=$$ ROOT^DILFD (SUBFILE," ,"_IENS,1)
  13877   "RTN","PXV ZRT",205,0 )
  13878    S IDX=0 F   S IDX=$O (@ROOT@(ID X)) Q:'IDX   D
  13879   "RTN","PXV ZRT",206,0 )
  13880    .N DA,DIK ,DIC S DA( 1)=+IENS,D A=IDX,DIK= $P(ROOT,") ")_"," D ^ DIK
  13881   "RTN","PXV ZRT",207,0 )
  13882    Q
  13883   "RTN","PXV ZRT",208,0 )
  13884   IFST(FIELD ,YES,NO) ; Send AE if  Inactive  flag doesn 't match V UID Status .
  13885   "RTN","PXV ZRT",209,0 )
  13886    Q:'$D(FDA (IFN,IEN_" ,",FIELD))
  13887   "RTN","PXV ZRT",210,0 )
  13888    N X1 S X1 =$P(HLNODE ,HLFS,3)
  13889   "RTN","PXV ZRT",211,0 )
  13890    Q:X1=1&(F DA(IFN,IEN _",",FIELD )=YES)  ;M atch, both  active
  13891   "RTN","PXV ZRT",212,0 )
  13892    Q:X1=0&(F DA(IFN,IEN _",",FIELD )=NO)  ;Ma tch, both  inactive
  13893   "RTN","PXV ZRT",213,0 )
  13894    S ERROR=" 1^"_IFN_"9 9,.02 STAT US HLNODE: "_HLNODE_"  Doesn't m atch "_FIE LD_" Inact ive Flag " _FDA(IFN,I EN_",",FIE LD)
  13895   "RTN","PXV ZRT",214,0 )
  13896    D EM^XUMF 1H(ERROR,. ERR)
  13897   "RTN","PXV ZRT",215,0 )
  13898    Q
  13899   "RTN","PXV ZRT",216,0 )
  13900   DUP(SUB,X1 ,X2) ;
  13901   "RTN","PXV ZRT",217,0 )
  13902    ;Checkup  for duplic ate coding  system (I CD, 10D, C PT...)
  13903   "RTN","PXV ZRT",218,0 )
  13904    D GETS^DI Q(IFN,IEN_ ",","**"," ","TMP") ; TMP(999999 9.143 - .1 28,"1,7,", .01)=86485    X1=CPT    X2=1234, 4567,7890
  13905   "RTN","PXV ZRT",219,0 )
  13906    S II="" F   S II=$O( TMP(SUB,II )) Q:'II   S X3=$G(TM P(SUB,II,. 01)) I $L( X3),X3=X1  D  Q
  13907   "RTN","PXV ZRT",220,0 )
  13908    .S ERROR= "1^Error -  "_II_" Du plicate Co ding Syste m"_" File  #: "_IFN_"  HLNODE="_ HLNODE
  13909   "RTN","PXV ZRT",221,0 )
  13910    Q:$G(ERRO R)
  13911   "RTN","PXV ZRT",222,0 )
  13912    ;Checkup  for duplic ate codes.  (CPT:9070 1,90743,90 701)
  13913   "RTN","PXV ZRT",223,0 )
  13914    F I=1:1 S  X5=$P(X2, ",",I) Q:' $L(X5)  S  X6(X5)=$G( X6(X5))+1  I X6(X5)>1  D  Q
  13915   "RTN","PXV ZRT",224,0 )
  13916    .S ERROR= "1^Error -  Duplicate  Codes in  Coding Sys tem"_" Fil e #: "_IFN _" HLNODE= "_HLNODE
  13917   "RTN","PXV ZRT",225,0 )
  13918    Q
  13919   "SEC","^DI C",920.05, 920.05,0," AUDIT")
  13920   @
  13921   "SEC","^DI C",920.05, 920.05,0," DD")
  13922   @
  13923   "SEC","^DI C",920.05, 920.05,0," DEL")
  13924   @
  13925   "SEC","^DI C",920.05, 920.05,0," LAYGO")
  13926   @
  13927   "SEC","^DI C",920.05, 920.05,0," RD")
  13928   @
  13929   "SEC","^DI C",920.05, 920.05,0," WR")
  13930   @
  13931   "SEC","^DI C",920.6,9 20.6,0,"AU DIT")
  13932   @
  13933   "SEC","^DI C",920.6,9 20.6,0,"DD ")
  13934   @
  13935   "SEC","^DI C",920.6,9 20.6,0,"DE L")
  13936   @
  13937   "SEC","^DI C",920.6,9 20.6,0,"LA YGO")
  13938   @
  13939   "SEC","^DI C",920.6,9 20.6,0,"RD ")
  13940   @
  13941   "SEC","^DI C",920.6,9 20.6,0,"WR ")
  13942   @
  13943   "SEC","^DI C",9000010 .11,900001 0.11,0,"DD ")
  13944   @
  13945   "SEC","^DI C",9000010 .707,90000 10.707,0," AUDIT")
  13946   @
  13947   "SEC","^DI C",9000010 .707,90000 10.707,0," DD")
  13948   @
  13949   "SEC","^DI C",9000010 .707,90000 10.707,0," DEL")
  13950   @
  13951   "SEC","^DI C",9000010 .707,90000 10.707,0," LAYGO")
  13952   @
  13953   "SEC","^DI C",9000010 .707,90000 10.707,0," RD")
  13954   @
  13955   "SEC","^DI C",9000010 .707,90000 10.707,0," WR")
  13956   @
  13957   "VER")
  13958   8.0^22.0
  13959   "^DD",811. 1,811.1,0)
  13960   FIELD^^.05 ^5
  13961   "^DD",811. 1,811.1,0, "DDA")
  13962   N
  13963   "^DD",811. 1,811.1,0, "DT")
  13964   2950323
  13965   "^DD",811. 1,811.1,0, "ID",.03)
  13966   W "   ",$P (^(0),U,3)
  13967   "^DD",811. 1,811.1,0, "IX","AA", 811.1,.01)
  13968  
  13969   "^DD",811. 1,811.1,0, "IX","AA1" ,811.1,.03 )
  13970  
  13971   "^DD",811. 1,811.1,0, "IX","AA2" ,811.1,.05 )
  13972  
  13973   "^DD",811. 1,811.1,0, "IX","B",8 11.1,.01)
  13974  
  13975   "^DD",811. 1,811.1,0, "NM","PCE  CODE MAPPI NG")
  13976  
  13977   "^DD",811. 1,811.1,.0 1,0)
  13978   FILE ENTRY ^RV^^0;1^Q
  13979   "^DD",811. 1,811.1,.0 1,1,0)
  13980   ^.1
  13981   "^DD",811. 1,811.1,.0 1,1,1,0)
  13982   811.1^B
  13983   "^DD",811. 1,811.1,.0 1,1,1,1)
  13984   S ^PXD(811 .1,"B",$E( X,1,30),DA )=""
  13985   "^DD",811. 1,811.1,.0 1,1,1,2)
  13986   K ^PXD(811 .1,"B",$E( X,1,30),DA )
  13987   "^DD",811. 1,811.1,.0 1,1,2,0)
  13988   811.1^AA^M UMPS
  13989   "^DD",811. 1,811.1,.0 1,1,2,1)
  13990   I $P(^PXD( 811.1,DA,0 ),"^",5)'= "" S ^PXD( 811.1,"AA" ,$P(X,";") ,$P(^PXD(8 11.1,DA,0) ,"^",3),$P (^PXD(811. 1,DA,0),"^ ",5),DA)=" "
  13991   "^DD",811. 1,811.1,.0 1,1,2,2)
  13992   K ^PXD(811 .1,"AA",$P (X,";"),$P (^PXD(811. 1,DA,0),"^ ",3),$P(^P XD(811.1,D A,0),"^",5 ))
  13993   "^DD",811. 1,811.1,.0 1,1,2,"%D" ,0)
  13994   ^^1^1^2950 816^
  13995   "^DD",811. 1,811.1,.0 1,1,2,"%D" ,1,0)
  13996   PXD("AA",F IRST ; PIE CE OF FILE  ENTRY FIE LD,FROM,ON /OFF FLAG, DA)
  13997   "^DD",811. 1,811.1,.0 1,1,2,"DT" )
  13998   2950221
  13999   "^DD",811. 1,811.1,.0 1,3)
  14000   Enter the  coding sys tem and en try here ( e.g. C.907 32)
  14001   "^DD",811. 1,811.1,.0 1,21,0)
  14002   ^^6^6^2951 121^^^^
  14003   "^DD",811. 1,811.1,.0 1,21,1,0)
  14004   This field  is a vari able point er which a llows code d system e ntries to  be
  14005   "^DD",811. 1,811.1,.0 1,21,2,0)
  14006   mapped to  an entry i n PCE's su pporting f iles.  For  example,  a CPT code
  14007   "^DD",811. 1,811.1,.0 1,21,3,0)
  14008   for Pneumo vax, 90732  would be  the value  entered he re, and th e Related
  14009   "^DD",811. 1,811.1,.0 1,21,4,0)
  14010   Supporting  entry fie ld would b e PNEUMO-V AC in the  Immunizati on file.
  14011   "^DD",811. 1,811.1,.0 1,21,5,0)
  14012   DO NOT use  any gener al code su ch as 'OTH ER SKIN TE STS' or 'O THER
  14013   "^DD",811. 1,811.1,.0 1,21,6,0)
  14014   PROCEDURE' .
  14015   "^DD",811. 1,811.1,.0 1,"DT")
  14016   2950221
  14017   "^DD",811. 1,811.1,.0 1,"V",0)
  14018   ^.12P^4^3
  14019   "^DD",811. 1,811.1,.0 1,"V",1,0)
  14020   81^CPT ent ry^1^C^n^n
  14021   "^DD",811. 1,811.1,.0 1,"V",3,0)
  14022   9999999.14 ^IMMUNIZAT IONS^3^I^^ n
  14023   "^DD",811. 1,811.1,.0 1,"V",4,0)
  14024   9999999.28 ^SKIN TEST ^4^S^n^n
  14025   "^DD",811. 1,811.1,.0 2,0)
  14026   RELATED SU PPORTING F ILE ENTRY^ V^^0;2^Q
  14027   "^DD",811. 1,811.1,.0 2,21,0)
  14028   ^^3^3^2951 121^^^^
  14029   "^DD",811. 1,811.1,.0 2,21,1,0)
  14030   A pointer  to the sec ond file e ncolved in  this mapp ing.
  14031   "^DD",811. 1,811.1,.0 2,21,2,0)
  14032   DO NOT poi nt this fi eld to any thing that  is genera l in natur e such
  14033   "^DD",811. 1,811.1,.0 2,21,3,0)
  14034   as 'OTHER  SKIN TESTS ' or 'OTHE R IMMUNIZA TION'.
  14035   "^DD",811. 1,811.1,.0 2,"DT")
  14036   2950111
  14037   "^DD",811. 1,811.1,.0 2,"V",0)
  14038   ^.12P^5^3
  14039   "^DD",811. 1,811.1,.0 2,"V",3,0)
  14040   9999999.14 ^IMMUNIZAT ION^1^I^n^ n
  14041   "^DD",811. 1,811.1,.0 2,"V",4,0)
  14042   9999999.28 ^SKIN TEST ^2^S^n^n
  14043   "^DD",811. 1,811.1,.0 2,"V",5,0)
  14044   81^CPT^6^C ^^n
  14045   "^DD",811. 1,811.1,.0 3,0)
  14046   FROM^RF^^0 ;3^K:X[""" "!($A(X)=4 5) X I $D( X) K:$L(X) >4!($L(X)< 2) X
  14047   "^DD",811. 1,811.1,.0 3,1,0)
  14048   ^.1^^-1
  14049   "^DD",811. 1,811.1,.0 3,1,1,0)
  14050   811.1^AA1^ MUMPS
  14051   "^DD",811. 1,811.1,.0 3,1,1,1)
  14052   I $P(^PXD( 811.1,DA,0 ),"^",5)'= "" S ^PXD( 811.1,"AA" ,$P($P(^PX D(811.1,DA ,0),"^")," ;"),X,$P(^ PXD(811.1, DA,0),"^", 5),DA)=""
  14053   "^DD",811. 1,811.1,.0 3,1,1,2)
  14054   K ^PXD(811 .1,"AA",$P ($P(^PXD(8 11.1,DA,0) ,"^"),";") ,X,$P(^PXD (811.1,DA, 0),"^",5), DA)
  14055   "^DD",811. 1,811.1,.0 3,1,1,"DT" )
  14056   2950221
  14057   "^DD",811. 1,811.1,.0 3,3)
  14058   Answer mus t be 2-4 c haracters  in length.
  14059   "^DD",811. 1,811.1,.0 3,21,0)
  14060   ^^3^3^2951 121^^^^
  14061   "^DD",811. 1,811.1,.0 3,21,1,0)
  14062   The 2 or 3  letter mn emonic tha t stands f or the fil e that the  data came
  14063   "^DD",811. 1,811.1,.0 3,21,2,0)
  14064   from or th at is also  being pop ulated at  this time.
  14065   "^DD",811. 1,811.1,.0 3,21,3,0)
  14066   IMM = V IM MUNIZATION S, CPT=V C PT ,and SK =V SKIN TE STS
  14067   "^DD",811. 1,811.1,.0 3,"DT")
  14068   2950323
  14069   "^DD",811. 1,811.1,.0 4,0)
  14070   TO^RF^^0;4 ^K:X[""""! ($A(X)=45)  X I $D(X)  K:$L(X)>4 !($L(X)<2)  X
  14071   "^DD",811. 1,811.1,.0 4,1,0)
  14072   ^.1^^0
  14073   "^DD",811. 1,811.1,.0 4,3)
  14074   Answer mus t be 2-4 c haracters  in length.
  14075   "^DD",811. 1,811.1,.0 4,21,0)
  14076   ^^2^2^2951 121^^^^
  14077   "^DD",811. 1,811.1,.0 4,21,1,0)
  14078   The 2 or 3  letter mn emonic tha t stands o f the file  that the  data is go ing
  14079   "^DD",811. 1,811.1,.0 4,21,2,0)
  14080   also be pu t into. IM M=VIMMUNIZ ATIONS, CP T=V CPT, a nd SK=VSKI N TESTS
  14081   "^DD",811. 1,811.1,.0 4,"DT")
  14082   2950405
  14083   "^DD",811. 1,811.1,.0 5,0)
  14084   ON/OFF FLA G^RS^1:ON; 0:OFF;^0;5 ^Q
  14085   "^DD",811. 1,811.1,.0 5,1,0)
  14086   ^.1^^-1
  14087   "^DD",811. 1,811.1,.0 5,1,1,0)
  14088   811.1^AA2^ MUMPS
  14089   "^DD",811. 1,811.1,.0 5,1,1,1)
  14090   S ^PXD(811 .1,"AA",$P ($P(^PXD(8 11.1,DA,0) ,"^"),";") ,$P(^PXD(8 11.1,DA,0) ,"^",3),X, DA)=""
  14091   "^DD",811. 1,811.1,.0 5,1,1,2)
  14092   K ^PXD(811 .1,"AA",$P ($P(^PXD(8 11.1,DA,0) ,"^"),";") ,$P(^PXD(8 11.1,DA,0) ,"^",3),X, DA)
  14093   "^DD",811. 1,811.1,.0 5,1,1,"%D" ,0)
  14094   ^^1^1^2950 816^^^
  14095   "^DD",811. 1,811.1,.0 5,1,1,"%D" ,1,0)
  14096   X REF  ,PO INTER NUMB ER,FROM MN EMONIC,ON/ OFF FLAG,D A
  14097   "^DD",811. 1,811.1,.0 5,1,1,"DT" )
  14098   2950210
  14099   "^DD",811. 1,811.1,.0 5,21,0)
  14100   ^^2^2^2950 816^
  14101   "^DD",811. 1,811.1,.0 5,21,1,0)
  14102   A switch t hat tells  us that th is mapping  is valid,  and the m apping
  14103   "^DD",811. 1,811.1,.0 5,21,2,0)
  14104   and storin g of the d ata is all owed to oc cur.
  14105   "^DD",811. 1,811.1,.0 5,"DT")
  14106   2950424
  14107   "^DD",920. 05,920.05, 0)
  14108   FIELD^^1^2
  14109   "^DD",920. 05,920.05, 0,"DDA")
  14110   N
  14111   "^DD",920. 05,920.05, 0,"DT")
  14112   3160212
  14113   "^DD",920. 05,920.05, 0,"IX","B" ,920.05,.0 1)
  14114  
  14115   "^DD",920. 05,920.05, 0,"NM","IM M DEFAULT  RESPONSES" )
  14116  
  14117   "^DD",920. 05,920.05, .01,0)
  14118   FACILITY^R P4a^DIC(4, ^0;1^Q
  14119   "^DD",920. 05,920.05, .01,.1)
  14120   Facility
  14121   "^DD",920. 05,920.05, .01,1,0)
  14122   ^.1
  14123   "^DD",920. 05,920.05, .01,1,1,0)
  14124   920.05^B
  14125   "^DD",920. 05,920.05, .01,1,1,1)
  14126   S ^PXV(920 .05,"B",$E (X,1,30),D A)=""
  14127   "^DD",920. 05,920.05, .01,1,1,2)
  14128   K ^PXV(920 .05,"B",$E (X,1,30),D A)
  14129   "^DD",920. 05,920.05, .01,3)
  14130   Enter the  facility a ssociated  with these  immunizat ion defaul t response s.
  14131   "^DD",920. 05,920.05, .01,21,0)
  14132   ^.001^3^3^ 3160204^^^
  14133   "^DD",920. 05,920.05, .01,21,1,0 )
  14134   This is th e facility  associate d with thi s set of d efault imm unization
  14135   "^DD",920. 05,920.05, .01,21,2,0 )
  14136   responses.  At multi- division i nstitution s this fac ility is a  division
  14137   "^DD",920. 05,920.05, .01,21,3,0 )
  14138   of that mu lti-divisi on institu tion.
  14139   "^DD",920. 05,920.05, .01,"AUDIT ")
  14140   y
  14141   "^DD",920. 05,920.05, .01,"DT")
  14142   3160204
  14143   "^DD",920. 05,920.05, 1,0)
  14144   IMMUNIZATI ON^920.051 P^^1;0
  14145   "^DD",920. 05,920.05, 1,21,0)
  14146   ^.001^2^2^ 3160212^^
  14147   "^DD",920. 05,920.05, 1,21,1,0)
  14148   This multi ple field  contains t he default  responses  for docum enting thi s
  14149   "^DD",920. 05,920.05, 1,21,2,0)
  14150   immunizati on at each  facility.
  14151   "^DD",920. 05,920.05, 1,"DT")
  14152   3160210
  14153   "^DD",920. 05,920.051 ,0)
  14154   IMMUNIZATI ON SUB-FIE LD^^.01^6
  14155   "^DD",920. 05,920.051 ,0,"DT")
  14156   3160212
  14157   "^DD",920. 05,920.051 ,0,"IX","B ",920.051, .01)
  14158  
  14159   "^DD",920. 05,920.051 ,0,"NM","I MMUNIZATIO N")
  14160  
  14161   "^DD",920. 05,920.051 ,0,"UP")
  14162   920.05
  14163   "^DD",920. 05,920.051 ,.01,0)
  14164   IMMUNIZATI ON^MP99999 99.14'Xa^A UTTIMM(^0; 1^S DINUM= X
  14165   "^DD",920. 05,920.051 ,.01,.1)
  14166   Immunizati on
  14167   "^DD",920. 05,920.051 ,.01,1,0)
  14168   ^.1
  14169   "^DD",920. 05,920.051 ,.01,1,1,0 )
  14170   920.051^B
  14171   "^DD",920. 05,920.051 ,.01,1,1,1 )
  14172   S ^PXV(920 .05,DA(1), 1,"B",$E(X ,1,30),DA) =""
  14173   "^DD",920. 05,920.051 ,.01,1,1,2 )
  14174   K ^PXV(920 .05,DA(1), 1,"B",$E(X ,1,30),DA)
  14175   "^DD",920. 05,920.051 ,.01,3)
  14176   Enter the  immunizati on associa ted with t his set of  default r esponses.
  14177   "^DD",920. 05,920.051 ,.01,21,0)
  14178   ^^2^2^3160 210^
  14179   "^DD",920. 05,920.051 ,.01,21,1, 0)
  14180   This is th e immuniza tion type  associated  with this  set of de fault
  14181   "^DD",920. 05,920.051 ,.01,21,2, 0)
  14182   responses.
  14183   "^DD",920. 05,920.051 ,.01,"AUDI T")
  14184   y
  14185   "^DD",920. 05,920.051 ,.01,"DT")
  14186   3160307
  14187   "^DD",920. 05,920.051 ,1302,0)
  14188   ROUTE OF A DMINISTRAT ION^P920.2 'a^PXV(920 .2,^13;2^Q
  14189   "^DD",920. 05,920.051 ,1302,.1)
  14190   Route of A dministrat ion
  14191   "^DD",920. 05,920.051 ,1302,3)
  14192   Enter the  default RO UTE OF ADM INISTRATIO N response  for this  immunizati on.
  14193   "^DD",920. 05,920.051 ,1302,21,0 )
  14194   ^^2^2^3160 209^
  14195   "^DD",920. 05,920.051 ,1302,21,1 ,0)
  14196   This field  holds the  default v alue for t he ROUTE O F ADMINIST RATION
  14197   "^DD",920. 05,920.051 ,1302,21,2 ,0)
  14198   field for  the immuni zation typ e given.
  14199   "^DD",920. 05,920.051 ,1302,"AUD IT")
  14200   y
  14201   "^DD",920. 05,920.051 ,1302,"DT" )
  14202   3160212
  14203   "^DD",920. 05,920.051 ,1303,0)
  14204   SITE OF AD MINISTRATI ON^P920.3' a^PXV(920. 3,^13;3^Q
  14205   "^DD",920. 05,920.051 ,1303,.1)
  14206   Site of Ad ministrati on
  14207   "^DD",920. 05,920.051 ,1303,3)
  14208   Enter the  default SI TE OF ADMI NISTRATION  response  for this i mmunizatio n.
  14209   "^DD",920. 05,920.051 ,1303,21,0 )
  14210   ^^2^2^3160 209^
  14211   "^DD",920. 05,920.051 ,1303,21,1 ,0)
  14212   This field  holds the  default v alue for t he SITE OF  ADMINISTR ATION
  14213   "^DD",920. 05,920.051 ,1303,21,2 ,0)
  14214   field for  the immuni zation typ e given.
  14215   "^DD",920. 05,920.051 ,1303,"AUD IT")
  14216   y
  14217   "^DD",920. 05,920.051 ,1303,"DT" )
  14218   3160212
  14219   "^DD",920. 05,920.051 ,1312,0)
  14220   DOSE^NJ6,2 a^^13;12^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 3.N) X
  14221   "^DD",920. 05,920.051 ,1312,.1)
  14222   Dose
  14223   "^DD",920. 05,920.051 ,1312,3)
  14224   Type a num ber betwee n 0 and 99 9, 2 decim al digits.
  14225   "^DD",920. 05,920.051 ,1312,21,0 )
  14226   ^^2^2^3160 209^
  14227   "^DD",920. 05,920.051 ,1312,21,1 ,0)
  14228   This field  holds the  default v alue for t he DOSE fi eld for th e
  14229   "^DD",920. 05,920.051 ,1312,21,2 ,0)
  14230   immunizati on type gi ven.
  14231   "^DD",920. 05,920.051 ,1312,"AUD IT")
  14232   y
  14233   "^DD",920. 05,920.051 ,1312,"DT" )
  14234   3160212
  14235   "^DD",920. 05,920.051 ,1313,0)
  14236   DOSE UNITS ^P757.5'a^ LEX(757.5, ^13;13^Q
  14237   "^DD",920. 05,920.051 ,1313,.1)
  14238   Dose Units
  14239   "^DD",920. 05,920.051 ,1313,3)
  14240   Enter the  default DO SE UNITS r esponse fo r this imm unization.
  14241   "^DD",920. 05,920.051 ,1313,21,0 )
  14242   ^^2^2^3160 310^
  14243   "^DD",920. 05,920.051 ,1313,21,1 ,0)
  14244   This field  holds the  default v alue for t he DOSE UN ITS field  for the
  14245   "^DD",920. 05,920.051 ,1313,21,2 ,0)
  14246   immunizati on type gi ven.
  14247   "^DD",920. 05,920.051 ,1313,"AUD IT")
  14248   y
  14249   "^DD",920. 05,920.051 ,1313,"DT" )
  14250   3160209
  14251   "^DD",920. 05,920.051 ,81101,0)
  14252   COMMENTS^F a^^811;1^K :$L(X)>245 !($L(X)<1)  X
  14253   "^DD",920. 05,920.051 ,81101,.1)
  14254   Comments
  14255   "^DD",920. 05,920.051 ,81101,3)
  14256   Answer mus t be 1-245  character s in lengt h.
  14257   "^DD",920. 05,920.051 ,81101,21, 0)
  14258   ^^2^2^3160 212^
  14259   "^DD",920. 05,920.051 ,81101,21, 1,0)
  14260   This field  holds the  default v alue for t he COMMENT  field for  the
  14261   "^DD",920. 05,920.051 ,81101,21, 2,0)
  14262   immunizati on type gi ven.
  14263   "^DD",920. 05,920.051 ,81101,"AU DIT")
  14264   y
  14265   "^DD",920. 05,920.051 ,81101,"DT ")
  14266   3160212
  14267   "^DD",920. 4,920.4,.0 5,0)
  14268   CONCEPT CO DING SYSTE M^Fa^^VUID ;4^K:$L(X) >10!($L(X) <3) X
  14269   "^DD",920. 4,920.4,.0 5,.1)
  14270   CDC HL7 TA BLE 0396 C ODE
  14271   "^DD",920. 4,920.4,.0 5,3)
  14272   Answer mus t be 3-10  characters  in length .
  14273   "^DD",920. 4,920.4,.0 5,9)
  14274   ^
  14275   "^DD",920. 4,920.4,.0 5,21,0)
  14276   ^^2^2^3151 208^
  14277   "^DD",920. 4,920.4,.0 5,21,1,0)
  14278   This is th e  HL7 Tab le 0396 co de to desc ribe the c oding syst em used to
  14279   "^DD",920. 4,920.4,.0 5,21,2,0)
  14280   represent  this conce pt code.
  14281   "^DD",920. 4,920.4,.0 5,"AUDIT")
  14282   y
  14283   "^DD",920. 4,920.4,.0 5,"DT")
  14284   3151208
  14285   "^DD",920. 6,920.6,0)
  14286   FIELD^^1^2
  14287   "^DD",920. 6,920.6,0, "DDA")
  14288   N
  14289   "^DD",920. 6,920.6,0, "DT")
  14290   3160114
  14291   "^DD",920. 6,920.6,0, "IX","B",9 20.6,.01)
  14292  
  14293   "^DD",920. 6,920.6,0, "NM","IMM  ROUTES TO  SITES")
  14294  
  14295   "^DD",920. 6,920.6,.0 1,0)
  14296   ROUTE^RP92 0.2'X^PXV( 920.2,^0;1 ^S DINUM=X
  14297   "^DD",920. 6,920.6,.0 1,1,0)
  14298   ^.1
  14299   "^DD",920. 6,920.6,.0 1,1,1,0)
  14300   920.6^B
  14301   "^DD",920. 6,920.6,.0 1,1,1,1)
  14302   S ^PXV(920 .6,"B",$E( X,1,30),DA )=""
  14303   "^DD",920. 6,920.6,.0 1,1,1,2)
  14304   K ^PXV(920 .6,"B",$E( X,1,30),DA )
  14305   "^DD",920. 6,920.6,.0 1,3)
  14306   Enter the  route to b e mapped.
  14307   "^DD",920. 6,920.6,.0 1,21,0)
  14308   ^^1^1^3160 114^
  14309   "^DD",920. 6,920.6,.0 1,21,1,0)
  14310   This is th e route to  be mapped .
  14311   "^DD",920. 6,920.6,.0 1,"DT")
  14312   3160114
  14313   "^DD",920. 6,920.6,1, 0)
  14314   SITES^920. 61P^^1;0
  14315   "^DD",920. 6,920.6,1, 21,0)
  14316   ^^1^1^3160 114^
  14317   "^DD",920. 6,920.6,1, 21,1,0)
  14318   These are  the sites  that are m apped to t his route.
  14319   "^DD",920. 6,920.61,0 )
  14320   SITES SUB- FIELD^^.01 ^1
  14321   "^DD",920. 6,920.61,0 ,"DT")
  14322   3160114
  14323   "^DD",920. 6,920.61,0 ,"IX","B", 920.61,.01 )
  14324  
  14325   "^DD",920. 6,920.61,0 ,"NM","SIT ES")
  14326  
  14327   "^DD",920. 6,920.61,0 ,"UP")
  14328   920.6
  14329   "^DD",920. 6,920.61,. 01,0)
  14330   SITE^MP920 .3'^PXV(92 0.3,^0;1^Q
  14331   "^DD",920. 6,920.61,. 01,1,0)
  14332   ^.1
  14333   "^DD",920. 6,920.61,. 01,1,1,0)
  14334   920.61^B
  14335   "^DD",920. 6,920.61,. 01,1,1,1)
  14336   S ^PXV(920 .6,DA(1),1 ,"B",$E(X, 1,30),DA)= ""
  14337   "^DD",920. 6,920.61,. 01,1,1,2)
  14338   K ^PXV(920 .6,DA(1),1 ,"B",$E(X, 1,30),DA)
  14339   "^DD",920. 6,920.61,. 01,3)
  14340   Enter the  site that  should be  mapped to  this route .
  14341   "^DD",920. 6,920.61,. 01,21,0)
  14342   ^^1^1^3160 114^
  14343   "^DD",920. 6,920.61,. 01,21,1,0)
  14344   This is th e site tha t will be  mapped to  this route .
  14345   "^DD",920. 6,920.61,. 01,"DT")
  14346   3160114
  14347   "^DD",9000 010.11,900 0010.11,0)
  14348   FIELD^^160 1^60
  14349   "^DD",9000 010.11,900 0010.11,0, "DDA")
  14350   N
  14351   "^DD",9000 010.11,900 0010.11,0, "DT")
  14352   3160201
  14353   "^DD",9000 010.11,900 0010.11,0, "ID",.02)
  14354   W "   ",$S ($D(^DPT(+ $P(^(0),U, 2),0))#2:$ P(^(0),U,1 ),1:""),@( "$E("_DIC_ "Y,0),0)")
  14355   "^DD",9000 010.11,900 0010.11,0, "ID",.03)
  14356   W "   " S  AIHSY=Y,Y= $S($D(^AUP NVSIT(+$P( ^(0),U,3), 0))#2:$P(^ (0),U,1),1 :"") X:Y ^ DD("DD") W  Y S Y=AIH SY K AIHSY  W @("$E(" _DIC_"Y,0) ,0)")
  14357   "^DD",9000 010.11,900 0010.11,0, "IX","AA", 9000010.11 ,.03)
  14358  
  14359   "^DD",9000 010.11,900 0010.11,0, "IX","AATO O",9000010 .11,.01)
  14360  
  14361   "^DD",9000 010.11,900 0010.11,0, "IX","AATO O2",900001 0.11,.02)
  14362  
  14363   "^DD",9000 010.11,900 0010.11,0, "IX","AD", 9000010.11 ,.03)
  14364  
  14365   "^DD",9000 010.11,900 0010.11,0, "IX","AE", 9000010.11 ,1402)
  14366  
  14367   "^DD",9000 010.11,900 0010.11,0, "IX","AF", 9000010.11 ,1207)
  14368  
  14369   "^DD",9000 010.11,900 0010.11,0, "IX","AV10 ",9000010. 11,.03)
  14370  
  14371   "^DD",9000 010.11,900 0010.11,0, "IX","B",9 000010.11, .01)
  14372  
  14373   "^DD",9000 010.11,900 0010.11,0, "IX","C",9 000010.11, .02)
  14374  
  14375   "^DD",9000 010.11,900 0010.11,0, "IX","LN", 9000010.11 ,1207)
  14376  
  14377   "^DD",9000 010.11,900 0010.11,0, "NM","V IM MUNIZATION ")
  14378  
  14379   "^DD",9000 010.11,900 0010.11,0, "PT",90000 10.11,1208 )
  14380  
  14381   "^DD",9000 010.11,900 0010.11,0, "VRPK")
  14382   PX
  14383   "^DD",9000 010.11,900 0010.11,.0 1,0)
  14384   IMMUNIZATI ON^RP99999 99.14'a^AU TTIMM(^0;1 ^Q
  14385   "^DD",9000 010.11,900 0010.11,.0 1,1,0)
  14386   ^.1^^-1
  14387   "^DD",9000 010.11,900 0010.11,.0 1,1,1,0)
  14388   9000010.11 ^B
  14389   "^DD",9000 010.11,900 0010.11,.0 1,1,1,1)
  14390   S ^AUPNVIM M("B",$E(X ,1,30),DA) =""
  14391   "^DD",9000 010.11,900 0010.11,.0 1,1,1,2)
  14392   K ^AUPNVIM M("B",$E(X ,1,30),DA)
  14393   "^DD",9000 010.11,900 0010.11,.0 1,1,2,0)
  14394   ^^TRIGGER^ 9000010.11 ^1206
  14395   "^DD",9000 010.11,900 0010.11,.0 1,1,2,1)
  14396   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVI MM(D0,12)) :^(12),1:" ") S X=$P( Y(1),U,6), X=X S DIU= X K Y S X= DIV S X=$G (DUZ) S DI H=$G(^AUPN VIMM(DIV(0 ),12)),DIV =X S $P(^( 12),U,6)=D IV,DIH=900 0010.11,DI G=1206 D ^ DICR
  14397   "^DD",9000 010.11,900 0010.11,.0 1,1,2,2)
  14398   Q
  14399   "^DD",9000 010.11,900 0010.11,.0 1,1,2,"%D" ,0)
  14400   ^^3^3^3140 422^
  14401   "^DD",9000 010.11,900 0010.11,.0 1,1,2,"%D" ,1,0)
  14402   The IMMUNI ZATION DOC UMENTER fi eld (#1206 ) will be  triggered  whenever t he
  14403   "^DD",9000 010.11,900 0010.11,.0 1,1,2,"%D" ,2,0)
  14404   IMMUNIZATI ON field ( #.01) is e ntered or  updated.   The trigge red value
  14405   "^DD",9000 010.11,900 0010.11,.0 1,1,2,"%D" ,3,0)
  14406   will be th e DUZ of t he user.
  14407   "^DD",9000 010.11,900 0010.11,.0 1,1,2,"CRE ATE VALUE" )
  14408   S X=$G(DUZ )
  14409   "^DD",9000 010.11,900 0010.11,.0 1,1,2,"DEL ETE VALUE" )
  14410   NO EFFECT
  14411   "^DD",9000 010.11,900 0010.11,.0 1,1,2,"DT" )
  14412   3140422
  14413   "^DD",9000 010.11,900 0010.11,.0 1,1,2,"FIE LD")
  14414   IMMUNIZATI ON DOCUMEN TER
  14415   "^DD",9000 010.11,900 0010.11,.0 1,1,3,0)
  14416   9000010.11 ^AATOO^MUM PS
  14417   "^DD",9000 010.11,900 0010.11,.0 1,1,3,1)
  14418   I $P(^AUPN VIMM(DA,0) ,U,2)]"",$ P(^(0),U,3 )]"" S ^AU PNVIMM("AA ",$P(^AUPN VIMM(DA,0) ,U,2),X,(9 999999-$P( +^AUPNVSIT ($P(^AUPNV IMM(DA,0), U,3),0),". ",1)),DA)= ""
  14419   "^DD",9000 010.11,900 0010.11,.0 1,1,3,2)
  14420   I $P(^AUPN VIMM(DA,0) ,U,2)]"",$ P(^(0),U,3 )]"" K ^AU PNVIMM("AA ",$P(^AUPN VIMM(DA,0) ,U,2),X,(9 999999-$P( +^AUPNVSIT ($P(^AUPNV IMM(DA,0), U,3),0),". ",1)),DA)
  14421   "^DD",9000 010.11,900 0010.11,.0 1,1,3,"%D" ,0)
  14422   ^^5^5^2950 901^^
  14423   "^DD",9000 010.11,900 0010.11,.0 1,1,3,"%D" ,1,0)
  14424   This cross  reference  is used f or searche s in seque nce by pat ient,
  14425   "^DD",9000 010.11,900 0010.11,.0 1,1,3,"%D" ,2,0)
  14426   immunizati on interna l entry, i nverted vi sit date,  and intern al
  14427   "^DD",9000 010.11,900 0010.11,.0 1,1,3,"%D" ,3,0)
  14428   entry numb er.
  14429   "^DD",9000 010.11,900 0010.11,.0 1,1,3,"%D" ,4,0)
  14430  
  14431   "^DD",9000 010.11,900 0010.11,.0 1,1,3,"%D" ,5,0)
  14432      "AA",PA TIENT,IMMU NIZATION,V ISIT,DA
  14433   "^DD",9000 010.11,900 0010.11,.0 1,3)
  14434   Enter the  name of th e immuniza tion given  to the pa tient.
  14435   "^DD",9000 010.11,900 0010.11,.0 1,21,0)
  14436   ^.001^2^2^ 3150421^^^
  14437   "^DD",9000 010.11,900 0010.11,.0 1,21,1,0)
  14438   This is th e type of  immunizati on that wa s given to  the patie nt at the
  14439   "^DD",9000 010.11,900 0010.11,.0 1,21,2,0)
  14440   encounter.
  14441   "^DD",9000 010.11,900 0010.11,.0 1,"AUDIT")
  14442   y
  14443   "^DD",9000 010.11,900 0010.11,.0 1,"DT")
  14444   3150921
  14445   "^DD",9000 010.11,900 0010.11,.0 2,0)
  14446   PATIENT NA ME^RP90000 01'Ia^AUPN PAT(^0;2^Q
  14447   "^DD",9000 010.11,900 0010.11,.0 2,1,0)
  14448   ^.1
  14449   "^DD",9000 010.11,900 0010.11,.0 2,1,2,0)
  14450   9000010.11 ^AATOO2^MU MPS
  14451   "^DD",9000 010.11,900 0010.11,.0 2,1,2,1)
  14452   I $P(^AUPN VIMM(DA,0) ,U,3)]"" S  ^AUPNVIMM ("AA",X,+^ AUPNVIMM(D A,0),(9999 999-$P(+^A UPNVSIT($P (^AUPNVIMM (DA,0),U,3 ),0),".",1 )),DA)=""
  14453   "^DD",9000 010.11,900 0010.11,.0 2,1,2,2)
  14454   I $P(^AUPN VIMM(DA,0) ,U,3)]"" K  ^AUPNVIMM ("AA",X,+^ AUPNVIMM(D A,0),(9999 999-$P(+^A UPNVSIT($P (^AUPNVIMM (DA,0),U,3 ),0),".",1 )),DA)
  14455   "^DD",9000 010.11,900 0010.11,.0 2,1,2,"%D" ,0)
  14456   ^^2^2^2940 127^
  14457   "^DD",9000 010.11,900 0010.11,.0 2,1,2,"%D" ,1,0)
  14458   This is a  Health Sum mary cross -reference .
  14459   "^DD",9000 010.11,900 0010.11,.0 2,1,2,"%D" ,2,0)
  14460   "AA",PATIE NT,IMMUNIZ ATION,VISI T,DA
  14461   "^DD",9000 010.11,900 0010.11,.0 2,1,3,0)
  14462   9000010.11 ^C
  14463   "^DD",9000 010.11,900 0010.11,.0 2,1,3,1)
  14464   S ^AUPNVIM M("C",$E(X ,1,30),DA) =""
  14465   "^DD",9000 010.11,900 0010.11,.0 2,1,3,2)
  14466   K ^AUPNVIM M("C",$E(X ,1,30),DA)
  14467   "^DD",9000 010.11,900 0010.11,.0 2,1,3,"%D" ,0)
  14468   ^^1^1^2950 901^
  14469   "^DD",9000 010.11,900 0010.11,.0 2,1,3,"%D" ,1,0)
  14470   This cross  reference  provides  a look-up  of immuniz ations by  patient na me.
  14471   "^DD",9000 010.11,900 0010.11,.0 2,1,3,"DT" )
  14472   2950901
  14473   "^DD",9000 010.11,900 0010.11,.0 2,3)
  14474   Enter the  patient wh o was give n the immu nization.
  14475   "^DD",9000 010.11,900 0010.11,.0 2,21,0)
  14476   ^.001^1^1^ 3140701^^^
  14477   "^DD",9000 010.11,900 0010.11,.0 2,21,1,0)
  14478   This is th e patient  who was gi ven the im munization .
  14479   "^DD",9000 010.11,900 0010.11,.0 2,23,0)
  14480   ^^3^3^3140 701^
  14481   "^DD",9000 010.11,900 0010.11,.0 2,23,1,0)
  14482   This is a  pointer th e Patient/ IHS file ( #9000001),  which is  dinumed to
  14483   "^DD",9000 010.11,900 0010.11,.0 2,23,2,0)
  14484   the PATIEN T file (#2 ).  This f ield is al ways stuff ed by the  applicatio n.
  14485   "^DD",9000 010.11,900 0010.11,.0 2,23,3,0)
  14486   No editing  is allowe d.
  14487   "^DD",9000 010.11,900 0010.11,.0 2,"AUDIT")
  14488   y
  14489   "^DD",9000 010.11,900 0010.11,.0 2,"DT")
  14490   3150213
  14491   "^DD",9000 010.11,900 0010.11,.0 3,0)
  14492   VISIT^R*P9 000010'Ia^ AUPNVSIT(^ 0;3^S DIC( "S")="I $P (^(0),U,5) =$P(^AUPNV IMM(DA,0), U,2)" D ^D IC K DIC S  DIC=DIE,X =+Y K:Y<0  X
  14493   "^DD",9000 010.11,900 0010.11,.0 3,1,0)
  14494   ^.1
  14495   "^DD",9000 010.11,900 0010.11,.0 3,1,1,0)
  14496   9000010.11 ^AD
  14497   "^DD",9000 010.11,900 0010.11,.0 3,1,1,1)
  14498   S ^AUPNVIM M("AD",$E( X,1,30),DA )=""
  14499   "^DD",9000 010.11,900 0010.11,.0 3,1,1,2)
  14500   K ^AUPNVIM M("AD",$E( X,1,30),DA )
  14501   "^DD",9000 010.11,900 0010.11,.0 3,1,1,"%D" ,0)
  14502   ^^4^4^2950 901^
  14503   "^DD",9000 010.11,900 0010.11,.0 3,1,1,"%D" ,1,0)
  14504   This cross  reference  is used f or searche s by the v isit point er and
  14505   "^DD",9000 010.11,900 0010.11,.0 3,1,1,"%D" ,2,0)
  14506   internal e ntry numbe r.
  14507   "^DD",9000 010.11,900 0010.11,.0 3,1,1,"%D" ,3,0)
  14508  
  14509   "^DD",9000 010.11,900 0010.11,.0 3,1,1,"%D" ,4,0)
  14510     "AD",VIS IT pointer , DA
  14511   "^DD",9000 010.11,900 0010.11,.0 3,1,2,0)
  14512   9000010.11 ^AA^MUMPS
  14513   "^DD",9000 010.11,900 0010.11,.0 3,1,2,1)
  14514   Q:$P(^AUPN VIMM(DA,0) ,U,2)=""   S ^AUPNVIM M("AA",$P( ^AUPNVIMM( DA,0),U,2) ,+^AUPNVIM M(DA,0),(9 999999-$P( +^AUPNVSIT (X,0),".", 1)),DA)=""
  14515   "^DD",9000 010.11,900 0010.11,.0 3,1,2,2)
  14516   Q:$P(^AUPN VIMM(DA,0) ,U,2)=""   K ^AUPNVIM M("AA",$P( ^AUPNVIMM( DA,0),U,2) ,+^AUPNVIM M(DA,0),(9 999999-$P( +^AUPNVSIT (X,0),".", 1)),DA)
  14517   "^DD",9000 010.11,900 0010.11,.0 3,1,2,"%D" ,0)
  14518   ^.101^4^4^ 3140626^^
  14519   "^DD",9000 010.11,900 0010.11,.0 3,1,2,"%D" ,1,0)
  14520   This cross -reference  is used f or searche s in seque nce by pat ient,
  14521   "^DD",9000 010.11,900 0010.11,.0 3,1,2,"%D" ,2,0)
  14522   Immunizati on pointer , inverted  visit dat e, and int ernal entr y number.
  14523   "^DD",9000 010.11,900 0010.11,.0 3,1,2,"%D" ,3,0)
  14524  
  14525   "^DD",9000 010.11,900 0010.11,.0 3,1,2,"%D" ,4,0)
  14526       "AA",P ATIENT,IMM UNIZATION, VISIT,DA
  14527   "^DD",9000 010.11,900 0010.11,.0 3,1,3,0)
  14528   9000010.11 ^AV10^MUMP S
  14529   "^DD",9000 010.11,900 0010.11,.0 3,1,3,1)
  14530   D ADD^AUPN VSIT
  14531   "^DD",9000 010.11,900 0010.11,.0 3,1,3,2)
  14532   D SUB^AUPN VSIT
  14533   "^DD",9000 010.11,900 0010.11,.0 3,1,3,"%D" ,0)
  14534   ^^2^2^2940 127^^
  14535   "^DD",9000 010.11,900 0010.11,.0 3,1,3,"%D" ,1,0)
  14536   This cross -reference  adds and  subtracts  from the d ependent e ntry count  in
  14537   "^DD",9000 010.11,900 0010.11,.0 3,1,3,"%D" ,2,0)
  14538   the VISIT  file.
  14539   "^DD",9000 010.11,900 0010.11,.0 3,3)
  14540   Enter the  visit date /time for  the encoun ter where  the immuni zation was  given.
  14541   "^DD",9000 010.11,900 0010.11,.0 3,12)
  14542   VISIT MUST  BE FOR CU RRENT PATI ENT
  14543   "^DD",9000 010.11,900 0010.11,.0 3,12.1)
  14544   S DIC("S") ="I $P(^(0 ),U,5)=$P( ^AUPNVIMM( DA,0),U,2) "
  14545   "^DD",9000 010.11,900 0010.11,.0 3,21,0)
  14546   ^.001^2^2^ 3140422^^
  14547   "^DD",9000 010.11,900 0010.11,.0 3,21,1,0)
  14548   This is th e encounte r defined  in the Vis it file th at represe nts when a nd
  14549   "^DD",9000 010.11,900 0010.11,.0 3,21,2,0)
  14550   where the  immunizati on was giv en.
  14551   "^DD",9000 010.11,900 0010.11,.0 3,23,0)
  14552   ^.001^2^2^ 3140422^^
  14553   "^DD",9000 010.11,900 0010.11,.0 3,23,1,0)
  14554   This is a  pointer to  the Visit  File (#90 00010).  T his field  is stuffed  by
  14555   "^DD",9000 010.11,900 0010.11,.0 3,23,2,0)
  14556   the applic ations. No  editing i s allowed.
  14557   "^DD",9000 010.11,900 0010.11,.0 3,"AUDIT")
  14558   y
  14559   "^DD",9000 010.11,900 0010.11,.0 3,"DT")
  14560   3150213
  14561   "^DD",9000 010.11,900 0010.11,.0 4,0)
  14562   SERIES^*Sa ^P:PARTIAL LY COMPLET E;C:COMPLE TE;B:BOOST ER;1:SERIE S 1;2:SERI ES 2;3:SER IES 3;4:SE RIES 4;5:S ERIES 5;6: SERIES 6;7 :SERIES 7; 8:SERIES 8 ;^0;4^Q
  14563   "^DD",9000 010.11,900 0010.11,.0 4,.1)
  14564   Series
  14565   "^DD",9000 010.11,900 0010.11,.0 4,1,0)
  14566   ^.1^^0
  14567   "^DD",9000 010.11,900 0010.11,.0 4,3)
  14568   Enter the  series num ber, boost er, partia l or compl ete.
  14569   "^DD",9000 010.11,900 0010.11,.0 4,12)
  14570   Screen pre vents sele ction of i nappropria te series  of immuniz ation type .
  14571   "^DD",9000 010.11,900 0010.11,.0 4,12.1)
  14572   S DIC("S") ="I Y'>$$S ERIES^PXVU TL0"
  14573   "^DD",9000 010.11,900 0010.11,.0 4,21,0)
  14574   ^.001^2^2^ 3150211^^^ ^
  14575   "^DD",9000 010.11,900 0010.11,.0 4,21,1,0)
  14576   This field  allows th e provider  to specif y which se ries of im munization
  14577   "^DD",9000 010.11,900 0010.11,.0 4,21,2,0)
  14578   type was g iven to th e patient.
  14579   "^DD",9000 010.11,900 0010.11,.0 4,"AUDIT")
  14580   y
  14581   "^DD",9000 010.11,900 0010.11,.0 4,"DT")
  14582   3150211
  14583   "^DD",9000 010.11,900 0010.11,.0 5,0)
  14584   LOT^*P9999 999.41'a^A UTTIML(^0; 5^S DIC("S ")="I $P(^ (0),U,3)=0 ,$D(^AUTTI ML(""C"",$ P(^AUPNVIM M(DA,0),U, 1),Y))" D  ^DIC K DIC  S DIC=DIE ,X=+Y K:Y< 0 X
  14585   "^DD",9000 010.11,900 0010.11,.0 5,3)
  14586   Select the  lot of th e immuniza tion being  administe red.
  14587   "^DD",9000 010.11,900 0010.11,.0 5,12)
  14588   LOT MUST B E AVAILABL E AND MUST  BE A VALI D LOT FOR  THE IMMUNI ZATION BEI NG ENTERED .
  14589   "^DD",9000 010.11,900 0010.11,.0 5,12.1)
  14590   S DIC("S") ="I $P(^(0 ),U,3)=0,$ D(^AUTTIML (""C"",$P( ^AUPNVIMM( DA,0),U,1) ,Y))"
  14591   "^DD",9000 010.11,900 0010.11,.0 5,21,0)
  14592   ^^2^2^3140 701^
  14593   "^DD",9000 010.11,900 0010.11,.0 5,21,1,0)
  14594   This India n Health S ervice fie ld indicat es the lot  number as sociated
  14595   "^DD",9000 010.11,900 0010.11,.0 5,21,2,0)
  14596   with this  immunizati on.
  14597   "^DD",9000 010.11,900 0010.11,.0 5,23,0)
  14598   ^.001^5^5^ 3140625^^^
  14599   "^DD",9000 010.11,900 0010.11,.0 5,23,1,0)
  14600   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14601   "^DD",9000 010.11,900 0010.11,.0 5,23,2,0)
  14602   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14603   "^DD",9000 010.11,900 0010.11,.0 5,23,3,0)
  14604   of the fil e.
  14605   "^DD",9000 010.11,900 0010.11,.0 5,23,4,0)
  14606  
  14607   "^DD",9000 010.11,900 0010.11,.0 5,23,5,0)
  14608   APCDALVR V ariable =  APCDALVR(" APCDTLOT")
  14609   "^DD",9000 010.11,900 0010.11,.0 5,"AUDIT")
  14610   y
  14611   "^DD",9000 010.11,900 0010.11,.0 5,"DT")
  14612   3150213
  14613   "^DD",9000 010.11,900 0010.11,.0 6,0)
  14614   REACTION^S a^1:FEVER; 2:IRRITABI LITY;3:LOC AL REACTIO N OR SWELL ING;4:VOMI TING;5:RAS H OR ITCHI NG;6:LETHA RGY;7:CONV ULSIONS;8: ARTHRITIS  OR ARTHRAL GIAS;9:ANA PHYLAXIS O R COLLAPSE ;10:RESPIR ATORY DIST RESS;11:OT HER;0:NONE ;^0;6^Q
  14615   "^DD",9000 010.11,900 0010.11,.0 6,3)
  14616   Enter the  number rep resenting  the patien ts reactio n to the i mmunizatio n.
  14617   "^DD",9000 010.11,900 0010.11,.0 6,21,0)
  14618   ^^2^2^2950 901^
  14619   "^DD",9000 010.11,900 0010.11,.0 6,21,1,0)
  14620   This is th e reaction  that may  have been  observed b y the prov ider as a
  14621   "^DD",9000 010.11,900 0010.11,.0 6,21,2,0)
  14622   result of  the immuni zation giv en.
  14623   "^DD",9000 010.11,900 0010.11,.0 6,"AUDIT")
  14624   y
  14625   "^DD",9000 010.11,900 0010.11,.0 6,"DT")
  14626   3150213
  14627   "^DD",9000 010.11,900 0010.11,.0 7,0)
  14628   CONTRAINDI CATED^Sa^1 :YES (DO N OT REPEAT  THIS VACCI NE).;0:NO  (OK TO USE  IN THE FU TURE);^0;7 ^Q
  14629   "^DD",9000 010.11,900 0010.11,.0 7,3)
  14630   Enter 1 if  this immu nization s hould not  be given t o the pati ent in the  future.
  14631   "^DD",9000 010.11,900 0010.11,.0 7,21,0)
  14632   ^^3^3^2950 901^
  14633   "^DD",9000 010.11,900 0010.11,.0 7,21,1,0)
  14634   This field  allows th e immuniza tion to be  recorded  as contrai ndicated.
  14635   "^DD",9000 010.11,900 0010.11,.0 7,21,2,0)
  14636   Reminders  will inclu de a check  to see if  the previ ous immuni zation was
  14637   "^DD",9000 010.11,900 0010.11,.0 7,21,3,0)
  14638   contraindi cated befo re creatin g reminder s.
  14639   "^DD",9000 010.11,900 0010.11,.0 7,"AUDIT")
  14640   y
  14641   "^DD",9000 010.11,900 0010.11,.0 7,"DT")
  14642   3150213
  14643   "^DD",9000 010.11,900 0010.11,.0 8,0)
  14644   DOSE OVERR IDE^Sa^0:@ ;1:INVALID --BAD STOR AGE;2:INVA LID--DEFEC TIVE;3:INV ALID--EXPI RED;4:INVA LID--ADMIN  ERROR;9:F ORCED VALI D;^0;8^Q
  14645   "^DD",9000 010.11,900 0010.11,.0 8,3)
  14646   Select the  reason fo r this dos e override .
  14647   "^DD",9000 010.11,900 0010.11,.0 8,21,0)
  14648   ^^2^2^3140 701^
  14649   "^DD",9000 010.11,900 0010.11,.0 8,21,1,0)
  14650   This India n Health S ervice fie ld indicat es the dos e override  status of
  14651   "^DD",9000 010.11,900 0010.11,.0 8,21,2,0)
  14652   this immun ization.
  14653   "^DD",9000 010.11,900 0010.11,.0 8,23,0)
  14654   ^.001^3^3^ 3140625^^
  14655   "^DD",9000 010.11,900 0010.11,.0 8,23,1,0)
  14656   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14657   "^DD",9000 010.11,900 0010.11,.0 8,23,2,0)
  14658   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14659   "^DD",9000 010.11,900 0010.11,.0 8,23,3,0)
  14660   of the fil e.
  14661   "^DD",9000 010.11,900 0010.11,.0 8,"AUDIT")
  14662   y
  14663   "^DD",9000 010.11,900 0010.11,.0 8,"DT")
  14664   3150213
  14665   "^DD",9000 010.11,900 0010.11,.0 9,0)
  14666   INJECTION  SITE^Sa^LT I:Left Thi gh IM;LTS: Left Thigh  SQ;RTI:Ri ght Thigh  IM;RTS:Rig ht Thigh S Q;BTI:Both  Thighs IM ;LDI:Left  Delt IM;LA S:Left Arm  SQ;RDI:Ri ght Delt I M;RAS:Righ t Arm SQ;O :Oral;IN:N asal;LID:L eft Arm In tradermal; RID:Right  Arm Intrad ermal;^0;9 ^Q
  14667   "^DD",9000 010.11,900 0010.11,.0 9,3)
  14668   Enter the  body site  where the  injection  was given.
  14669   "^DD",9000 010.11,900 0010.11,.0 9,21,0)
  14670   ^^2^2^3140 701^
  14671   "^DD",9000 010.11,900 0010.11,.0 9,21,1,0)
  14672   This India n Health S ervice fie ld identif ies the bo dy site wh ere the
  14673   "^DD",9000 010.11,900 0010.11,.0 9,21,2,0)
  14674   immunizati on was adm inistered.
  14675   "^DD",9000 010.11,900 0010.11,.0 9,23,0)
  14676   ^.001^3^3^ 3140626^^^
  14677   "^DD",9000 010.11,900 0010.11,.0 9,23,1,0)
  14678   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14679   "^DD",9000 010.11,900 0010.11,.0 9,23,2,0)
  14680   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14681   "^DD",9000 010.11,900 0010.11,.0 9,23,3,0)
  14682   of the fil e.
  14683   "^DD",9000 010.11,900 0010.11,.0 9,"AUDIT")
  14684   y
  14685   "^DD",9000 010.11,900 0010.11,.0 9,"DT")
  14686   3140625
  14687   "^DD",9000 010.11,900 0010.11,.1 1,0)
  14688   VOLUME^NJ4 ,2a^^0;11^ K:+X'=X!(X >5)!(X<0)! (X?.E1"."3 N.N) X
  14689   "^DD",9000 010.11,900 0010.11,.1 1,3)
  14690   Type a Num ber betwee n 0 and 5,  2 Decimal  Digits
  14691   "^DD",9000 010.11,900 0010.11,.1 1,21,0)
  14692   ^^2^2^3140 701^
  14693   "^DD",9000 010.11,900 0010.11,.1 1,21,1,0)
  14694   This India n Health S ervice fie ld indicat es the vol ume of vac cine
  14695   "^DD",9000 010.11,900 0010.11,.1 1,21,2,0)
  14696   administer ed for thi s immuniza tion.
  14697   "^DD",9000 010.11,900 0010.11,.1 1,23,0)
  14698   ^.001^3^3^ 3140626^^^
  14699   "^DD",9000 010.11,900 0010.11,.1 1,23,1,0)
  14700   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14701   "^DD",9000 010.11,900 0010.11,.1 1,23,2,0)
  14702   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14703   "^DD",9000 010.11,900 0010.11,.1 1,23,3,0)
  14704   of the fil e.
  14705   "^DD",9000 010.11,900 0010.11,.1 1,"AUDIT")
  14706   y
  14707   "^DD",9000 010.11,900 0010.11,.1 1,"DT")
  14708   3150213
  14709   "^DD",9000 010.11,900 0010.11,.1 2,0)
  14710   DATE OF VA C INFO STA TEMENT^Da^ ^0;12^S %D T="EX" D ^ %DT S X=Y  K:Y<1 X
  14711   "^DD",9000 010.11,900 0010.11,.1 2,3)
  14712   Enter the  date the v accine inf ormation s tatement f or this va ccine was  offered to  the patie nt.
  14713   "^DD",9000 010.11,900 0010.11,.1 2,21,0)
  14714   ^^3^3^3140 701^
  14715   "^DD",9000 010.11,900 0010.11,.1 2,21,1,0)
  14716   This India n Health S ervice fie ld indicat es the dat e the vacc ine
  14717   "^DD",9000 010.11,900 0010.11,.1 2,21,2,0)
  14718   informatio n statemen t associat ed with th is immuniz ation was
  14719   "^DD",9000 010.11,900 0010.11,.1 2,21,3,0)
  14720   offered/gi ven to the  patient.
  14721   "^DD",9000 010.11,900 0010.11,.1 2,23,0)
  14722   ^.001^3^3^ 3140625^^
  14723   "^DD",9000 010.11,900 0010.11,.1 2,23,1,0)
  14724   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14725   "^DD",9000 010.11,900 0010.11,.1 2,23,2,0)
  14726   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14727   "^DD",9000 010.11,900 0010.11,.1 2,23,3,0)
  14728   of the fil e.
  14729   "^DD",9000 010.11,900 0010.11,.1 2,"AUDIT")
  14730   y
  14731   "^DD",9000 010.11,900 0010.11,.1 2,"DT")
  14732   3150213
  14733   "^DD",9000 010.11,900 0010.11,.1 3,0)
  14734   CREATED BY  V CPT ENT RY^NJ9,0a^ ^0;13^K:+X '=X!(X>999 999999)!(X <0)!(X?.E1 "."1N.N) X
  14735   "^DD",9000 010.11,900 0010.11,.1 3,3)
  14736   Enter the  IEN of the  V CPT ent ry that cr eated this  V Immuniz ation.
  14737   "^DD",9000 010.11,900 0010.11,.1 3,21,0)
  14738   ^^2^2^3140 701^
  14739   "^DD",9000 010.11,900 0010.11,.1 3,21,1,0)
  14740   This India n Health S ervice fie ld identif ies the V  CPT entry,  if any,
  14741   "^DD",9000 010.11,900 0010.11,.1 3,21,2,0)
  14742   that creat ed this V  Immunizati on entry.
  14743   "^DD",9000 010.11,900 0010.11,.1 3,23,0)
  14744   ^.001^3^3^ 3140625^^
  14745   "^DD",9000 010.11,900 0010.11,.1 3,23,1,0)
  14746   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14747   "^DD",9000 010.11,900 0010.11,.1 3,23,2,0)
  14748   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14749   "^DD",9000 010.11,900 0010.11,.1 3,23,3,0)
  14750   of the fil e.
  14751   "^DD",9000 010.11,900 0010.11,.1 3,"AUDIT")
  14752   y
  14753   "^DD",9000 010.11,900 0010.11,.1 3,"DT")
  14754   3150213
  14755   "^DD",9000 010.11,900 0010.11,.1 4,0)
  14756   VAC ELIGIB ILITY^P900 2084.83'a^ BIELIG(^0; 14^Q
  14757   "^DD",9000 010.11,900 0010.11,.1 4,3)
  14758   Enter the  patient's  VFC Eligib ility on t his visit.
  14759   "^DD",9000 010.11,900 0010.11,.1 4,21,0)
  14760   ^^2^2^3140 701^
  14761   "^DD",9000 010.11,900 0010.11,.1 4,21,1,0)
  14762   This India n Health S ervice fie ld indicat es the Vac cine for C hildren
  14763   "^DD",9000 010.11,900 0010.11,.1 4,21,2,0)
  14764   (VFC) Prog ram eligib ility for  this patie nt on this  visit.
  14765   "^DD",9000 010.11,900 0010.11,.1 4,23,0)
  14766   ^.001^6^6^ 3140829^^^
  14767   "^DD",9000 010.11,900 0010.11,.1 4,23,1,0)
  14768   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14769   "^DD",9000 010.11,900 0010.11,.1 4,23,2,0)
  14770   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14771   "^DD",9000 010.11,900 0010.11,.1 4,23,3,0)
  14772   of the fil e.
  14773   "^DD",9000 010.11,900 0010.11,.1 4,23,4,0)
  14774  
  14775   "^DD",9000 010.11,900 0010.11,.1 4,23,5,0)
  14776   This field  points to  Indian He alth Servi ce's BI TA BLE ELIGIB ILITY CODE S file
  14777   "^DD",9000 010.11,900 0010.11,.1 4,23,6,0)
  14778   (#9002084. 83) which  is not use d by the D epartment  of Veteran s Affairs.
  14779   "^DD",9000 010.11,900 0010.11,.1 4,"AUDIT")
  14780   y
  14781   "^DD",9000 010.11,900 0010.11,.1 4,"DT")
  14782   3150213
  14783   "^DD",9000 010.11,900 0010.11,.1 5,0)
  14784   IMPORT FRO M OUTSIDE  REGISTRY^S a^1:IMPORT ED;0:NOT I MPORTED;2: EDITED AFT ER IMPORT; ^0;15^Q
  14785   "^DD",9000 010.11,900 0010.11,.1 5,3)
  14786   Enter 1 if  this immu nization w as importe d from an  outside re gistry.
  14787   "^DD",9000 010.11,900 0010.11,.1 5,21,0)
  14788   ^^2^2^3140 701^
  14789   "^DD",9000 010.11,900 0010.11,.1 5,21,1,0)
  14790   This India n Health S ervice fie ld indicat ed the imp ort status  of this
  14791   "^DD",9000 010.11,900 0010.11,.1 5,21,2,0)
  14792   immunizati on from an  outside r egistry.
  14793   "^DD",9000 010.11,900 0010.11,.1 5,23,0)
  14794   ^.001^3^3^ 3140625^^
  14795   "^DD",9000 010.11,900 0010.11,.1 5,23,1,0)
  14796   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14797   "^DD",9000 010.11,900 0010.11,.1 5,23,2,0)
  14798   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14799   "^DD",9000 010.11,900 0010.11,.1 5,23,3,0)
  14800   of the fil e.
  14801   "^DD",9000 010.11,900 0010.11,.1 5,"AUDIT")
  14802   y
  14803   "^DD",9000 010.11,900 0010.11,.1 5,"DT")
  14804   3150213
  14805   "^DD",9000 010.11,900 0010.11,.1 6,0)
  14806   NDC^P90020 84.95'a^BI NDC(^0;16^ Q
  14807   "^DD",9000 010.11,900 0010.11,.1 6,3)
  14808   Select the  NDC Code  for this i mmunizatio n. Enter
  14809   "^DD",9000 010.11,900 0010.11,.1 6,21,0)
  14810   ^.001^2^2^ 3140829^^^
  14811   "^DD",9000 010.11,900 0010.11,.1 6,21,1,0)
  14812   This India n Health S ervice fie ld identif ies the Na tional Dru g Code
  14813   "^DD",9000 010.11,900 0010.11,.1 6,21,2,0)
  14814   (NDC) for  this vacci ne.
  14815   "^DD",9000 010.11,900 0010.11,.1 6,23,0)
  14816   ^.001^6^6^ 3140829^^^ ^
  14817   "^DD",9000 010.11,900 0010.11,.1 6,23,1,0)
  14818   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14819   "^DD",9000 010.11,900 0010.11,.1 6,23,2,0)
  14820   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14821   "^DD",9000 010.11,900 0010.11,.1 6,23,3,0)
  14822   of the fil e.
  14823   "^DD",9000 010.11,900 0010.11,.1 6,23,4,0)
  14824  
  14825   "^DD",9000 010.11,900 0010.11,.1 6,23,5,0)
  14826   This field  points to  Indian He alth Servi ce's BI TA BLE NDC CO DES file
  14827   "^DD",9000 010.11,900 0010.11,.1 6,23,6,0)
  14828   (#9002084. 95) which  is not use d by the D epartment  of Veteran s Affairs.
  14829   "^DD",9000 010.11,900 0010.11,.1 6,"AUDIT")
  14830   y
  14831   "^DD",9000 010.11,900 0010.11,.1 6,"DT")
  14832   3150213
  14833   "^DD",9000 010.11,900 0010.11,1, 0)
  14834   ADMINISTRA TIVE NOTES ^Fa^^1;1^K :$L(X)>160 !($L(X)<1)  X
  14835   "^DD",9000 010.11,900 0010.11,1, 3)
  14836   Answer mus t be 1-160  character s in lengt h
  14837   "^DD",9000 010.11,900 0010.11,1, 21,0)
  14838   ^^2^2^3140 701^
  14839   "^DD",9000 010.11,900 0010.11,1, 21,1,0)
  14840   This India n Health S ervice fie ld is a fr ee text fi eld used t o document
  14841   "^DD",9000 010.11,900 0010.11,1, 21,2,0)
  14842   administra tive infor mation abo ut this im munization .
  14843   "^DD",9000 010.11,900 0010.11,1, 23,0)
  14844   ^^3^3^3140 625^
  14845   "^DD",9000 010.11,900 0010.11,1, 23,1,0)
  14846   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14847   "^DD",9000 010.11,900 0010.11,1, 23,2,0)
  14848   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  14849   "^DD",9000 010.11,900 0010.11,1, 23,3,0)
  14850   of the fil e.
  14851   "^DD",9000 010.11,900 0010.11,1, "AUDIT")
  14852   y
  14853   "^DD",9000 010.11,900 0010.11,1, "DT")
  14854   3150213
  14855   "^DD",9000 010.11,900 0010.11,2, 0)
  14856   VIS OFFERE D/GIVEN TO  PATIENT^9 000010.112 PA^^2;0
  14857   "^DD",9000 010.11,900 0010.11,2, 21,0)
  14858   ^.001^3^3^ 3150518^^
  14859   "^DD",9000 010.11,900 0010.11,2, 21,1,0)
  14860   This is th e Vaccine  Informatio n Statemen t (VIS) th at was off ered to th e
  14861   "^DD",9000 010.11,900 0010.11,2, 21,2,0)
  14862   patient pr ior to the  administr ation of t he immuniz ation, alo ng with th e
  14863   "^DD",9000 010.11,900 0010.11,2, 21,3,0)
  14864   date/time  it was off ered.
  14865   "^DD",9000 010.11,900 0010.11,3, 0)
  14866   OTHER DIAG NOSIS^9000 010.113P^^ 3;0
  14867   "^DD",9000 010.11,900 0010.11,3, 21,0)
  14868   ^.001^2^2^ 3140626^^
  14869   "^DD",9000 010.11,900 0010.11,3, 21,1,0)
  14870   This is a  list of di agnoses fo r this imm unization  event, in  addition t o
  14871   "^DD",9000 010.11,900 0010.11,3, 21,2,0)
  14872   the Primar y Diagnosi s selected  for this  event.
  14873   "^DD",9000 010.11,900 0010.11,3, 23,0)
  14874   ^.001^3^3^ 3140626^^
  14875   "^DD",9000 010.11,900 0010.11,3, 23,1,0)
  14876   This is a  multiple o f diagnose s for this  immunizat ion event.   They are  in
  14877   "^DD",9000 010.11,900 0010.11,3, 23,2,0)
  14878   addition t o the PRIM ARY DIAGNO SIS.  They  are selec ted from t he ICD
  14879   "^DD",9000 010.11,900 0010.11,3, 23,3,0)
  14880   DIAGNOSIS  file (#80) .
  14881   "^DD",9000 010.11,900 0010.11,11 01,0)
  14882   REMARKS^90 00010.1111 ^^11;0
  14883   "^DD",9000 010.11,900 0010.11,11 01,21,0)
  14884   ^^2^2^2950 901^
  14885   "^DD",9000 010.11,900 0010.11,11 01,21,1,0)
  14886   This is ad ditional c omments or  remarks r elated to  the immuni zation giv en
  14887   "^DD",9000 010.11,900 0010.11,11 01,21,2,0)
  14888   to the pat ient.
  14889   "^DD",9000 010.11,900 0010.11,12 01,0)
  14890   EVENT DATE  AND TIME^ DXa^^12;1^ S %DT="ET"  D ^%DT S  X=Y K:Y<1! $$TIME^PXV UTL X
  14891   "^DD",9000 010.11,900 0010.11,12 01,1,0)
  14892   ^.1^^-1
  14893   "^DD",9000 010.11,900 0010.11,12 01,1,1,0)
  14894   ^^TRIGGER^ 9000010.11 ^1205
  14895   "^DD",9000 010.11,900 0010.11,12 01,1,1,1)
  14896   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVI MM(D0,12)) :^(12),1:" ") S X=$P( Y(1),U,5), X=X S DIU= X K Y S X= DIV N %I,% H,% D NOW^ %DTC S X=%  X ^DD(900 0010.11,12 01,1,1,1.4 )
  14897   "^DD",9000 010.11,900 0010.11,12 01,1,1,1.4 )
  14898   S DIH=$G(^ AUPNVIMM(D IV(0),12)) ,DIV=X S $ P(^(12),U, 5)=DIV,DIH =9000010.1 1,DIG=1205  D ^DICR
  14899   "^DD",9000 010.11,900 0010.11,12 01,1,1,2)
  14900   Q
  14901   "^DD",9000 010.11,900 0010.11,12 01,1,1,"%D ",0)
  14902   ^^3^3^3140 422^
  14903   "^DD",9000 010.11,900 0010.11,12 01,1,1,"%D ",1,0)
  14904   The DATE/T IME RECORD ED field ( #1205) wil l be trigg ered whene ver the
  14905   "^DD",9000 010.11,900 0010.11,12 01,1,1,"%D ",2,0)
  14906   EVENT DATE  AND TIME  field (#12 01) is ent ered or up dated.  Th e triggere d
  14907   "^DD",9000 010.11,900 0010.11,12 01,1,1,"%D ",3,0)
  14908   value will  be NOW.
  14909   "^DD",9000 010.11,900 0010.11,12 01,1,1,"CR EATE VALUE ")
  14910   NOW
  14911   "^DD",9000 010.11,900 0010.11,12 01,1,1,"DE LETE VALUE ")
  14912   NO EFFECT
  14913   "^DD",9000 010.11,900 0010.11,12 01,1,1,"FI ELD")
  14914   DATE/TIME  RECORDED
  14915   "^DD",9000 010.11,900 0010.11,12 01,3)
  14916   Enter the  date and ( optional)  time the i mmunizatio n was give n.
  14917   "^DD",9000 010.11,900 0010.11,12 01,21,0)
  14918   ^^10^10^31 50820^
  14919   "^DD",9000 010.11,900 0010.11,12 01,21,1,0)
  14920   This is th e date and  time the  immunizati on was giv en. This d ate and ti me
  14921   "^DD",9000 010.11,900 0010.11,12 01,21,2,0)
  14922   may be dif ferent fro m the visi t date and  time. For  example,  for clinic
  14923   "^DD",9000 010.11,900 0010.11,12 01,21,3,0)
  14924   appointmen t visits,  the visit  date and t ime is the  date and  time of th e
  14925   "^DD",9000 010.11,900 0010.11,12 01,21,4,0)
  14926   appointmen t, not the  time the  provider p erformed t he clinica l event.
  14927   "^DD",9000 010.11,900 0010.11,12 01,21,5,0)
  14928  
  14929   "^DD",9000 010.11,900 0010.11,12 01,21,6,0)
  14930   The date m ay be an i mprecise d ate such a s for an h istorical
  14931   "^DD",9000 010.11,900 0010.11,12 01,21,7,0)
  14932   immunizati on.
  14933   "^DD",9000 010.11,900 0010.11,12 01,21,8,0)
  14934  
  14935   "^DD",9000 010.11,900 0010.11,12 01,21,9,0)
  14936   Date and t ime may be  within 30  days befo re or afte r the visi t date,
  14937   "^DD",9000 010.11,900 0010.11,12 01,21,10,0 )
  14938   with the r estriction  the date  cannot be  a future d ate.
  14939   "^DD",9000 010.11,900 0010.11,12 01,23,0)
  14940   ^^13^13^31 50820^^
  14941   "^DD",9000 010.11,900 0010.11,12 01,23,1,0)
  14942   The PCE Us er Interfa ce, which  allows man ual entry  of data, w ill be the  primary
  14943   "^DD",9000 010.11,900 0010.11,12 01,23,2,0)
  14944   source of  the immuni zation dat e and time .  The imm unization  date promp t defaults
  14945   "^DD",9000 010.11,900 0010.11,12 01,23,3,0)
  14946   to the vis it date an d the time  is entere d to refle ct the act ual time t he
  14947   "^DD",9000 010.11,900 0010.11,12 01,23,4,0)
  14948   immunizati on was giv en.  The i mmunizatio n date doe s not have  to be the  visit
  14949   "^DD",9000 010.11,900 0010.11,12 01,23,5,0)
  14950   date, but  it must be  within 30  days befo re or afte r the visi t, and not  be a
  14951   "^DD",9000 010.11,900 0010.11,12 01,23,6,0)
  14952   future dat e.
  14953   "^DD",9000 010.11,900 0010.11,12 01,23,7,0)
  14954  
  14955   "^DD",9000 010.11,900 0010.11,12 01,23,8,0)
  14956   If the use r wants to  enter an  historical  immunizat ion, the u ser should  use the
  14957   "^DD",9000 010.11,900 0010.11,12 01,23,9,0)
  14958   Historical  Encounter  entry act ion to doc ument the  historical  immunizat ion.
  14959   "^DD",9000 010.11,900 0010.11,12 01,23,10,0 )
  14960   Historical  entries w ill not be  eligible  for credit .
  14961   "^DD",9000 010.11,900 0010.11,12 01,23,11,0 )
  14962  
  14963   "^DD",9000 010.11,900 0010.11,12 01,23,12,0 )
  14964   PCE data s ources for  automatic  (scanning ) data cap ture will  be blank u nless the
  14965   "^DD",9000 010.11,900 0010.11,12 01,23,13,0 )
  14966   immunizati on date an d time are  passed to  PCE for f iling.
  14967   "^DD",9000 010.11,900 0010.11,12 01,"AUDIT" )
  14968   y
  14969   "^DD",9000 010.11,900 0010.11,12 01,"DT")
  14970   3150820
  14971   "^DD",9000 010.11,900 0010.11,12 02,0)
  14972   ORDERING P ROVIDER^P2 00'a^VA(20 0,^12;2^Q
  14973   "^DD",9000 010.11,900 0010.11,12 02,3)
  14974   Enter the  provider w ho ordered  this immu nization.
  14975   "^DD",9000 010.11,900 0010.11,12 02,21,0)
  14976   ^^2^2^2960 513^
  14977   "^DD",9000 010.11,900 0010.11,12 02,21,1,0)
  14978   The field  can be use d to docum ent the pr ovider who  ordered t he
  14979   "^DD",9000 010.11,900 0010.11,12 02,21,2,0)
  14980   immunizati on.
  14981   "^DD",9000 010.11,900 0010.11,12 02,"AUDIT" )
  14982   y
  14983   "^DD",9000 010.11,900 0010.11,12 02,"DT")
  14984   3150213
  14985   "^DD",9000 010.11,900 0010.11,12 03,0)
  14986   CLINIC^P40 .7'a^DIC(4 0.7,^12;3^ Q
  14987   "^DD",9000 010.11,900 0010.11,12 03,3)
  14988   Select a c linic stop  for this  Immunizati on event.
  14989   "^DD",9000 010.11,900 0010.11,12 03,21,0)
  14990   ^^2^2^3140 702^
  14991   "^DD",9000 010.11,900 0010.11,12 03,21,1,0)
  14992   This India n Health S ervice fie ld indicat es the cli nic stop a ssociated
  14993   "^DD",9000 010.11,900 0010.11,12 03,21,2,0)
  14994   with this  visit.
  14995   "^DD",9000 010.11,900 0010.11,12 03,23,0)
  14996   ^.001^5^5^ 3140702^^^
  14997   "^DD",9000 010.11,900 0010.11,12 03,23,1,0)
  14998   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  14999   "^DD",9000 010.11,900 0010.11,12 03,23,2,0)
  15000   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15001   "^DD",9000 010.11,900 0010.11,12 03,23,3,0)
  15002   of the fil e.
  15003   "^DD",9000 010.11,900 0010.11,12 03,23,4,0)
  15004  
  15005   "^DD",9000 010.11,900 0010.11,12 03,23,5,0)
  15006   APCDALVR V ariable =  APCDALVR(" APCDTCLN")
  15007   "^DD",9000 010.11,900 0010.11,12 03,"AUDIT" )
  15008   y
  15009   "^DD",9000 010.11,900 0010.11,12 03,"DT")
  15010   3150213
  15011   "^DD",9000 010.11,900 0010.11,12 04,0)
  15012   ENCOUNTER  PROVIDER^P 200'a^VA(2 00,^12;4^Q
  15013   "^DD",9000 010.11,900 0010.11,12 04,3)
  15014   Enter the  provider w ho gave th is immuniz ation.
  15015   "^DD",9000 010.11,900 0010.11,12 04,21,0)
  15016   ^.001^2^2^ 3140829^^^ ^
  15017   "^DD",9000 010.11,900 0010.11,12 04,21,1,0)
  15018   This is th e provider  who gave  this
  15019   "^DD",9000 010.11,900 0010.11,12 04,21,2,0)
  15020   immunizati on.
  15021   "^DD",9000 010.11,900 0010.11,12 04,23,0)
  15022   ^.001^1^1^ 3140829^^^
  15023   "^DD",9000 010.11,900 0010.11,12 04,23,1,0)
  15024   This perso n can be a ny person  in the new  person fi le.
  15025   "^DD",9000 010.11,900 0010.11,12 04,"AUDIT" )
  15026   y
  15027   "^DD",9000 010.11,900 0010.11,12 04,"DT")
  15028   3150213
  15029   "^DD",9000 010.11,900 0010.11,12 05,0)
  15030   DATE/TIME  RECORDED^D a^^12;5^S  %DT="ETXR"  D ^%DT S  X=Y K:Y<1  X
  15031   "^DD",9000 010.11,900 0010.11,12 05,.1)
  15032   Date/Time  Recorded
  15033   "^DD",9000 010.11,900 0010.11,12 05,3)
  15034   Enter the  date and t ime of doc umentation  of the ad ministrati on of the  immunizati on.
  15035   "^DD",9000 010.11,900 0010.11,12 05,5,1,0)
  15036   9000010.11 ^1201^1
  15037   "^DD",9000 010.11,900 0010.11,12 05,9)
  15038   ^
  15039   "^DD",9000 010.11,900 0010.11,12 05,21,0)
  15040   ^.001^3^3^ 3140416^^
  15041   "^DD",9000 010.11,900 0010.11,12 05,21,1,0)
  15042   This times tamp field  is the da te and tim e of docum entation o f
  15043   "^DD",9000 010.11,900 0010.11,12 05,21,2,0)
  15044   administra tion of th e immuniza tion. This  field is  set automa tically
  15045   "^DD",9000 010.11,900 0010.11,12 05,21,3,0)
  15046   when the E VENT DATE  AND TIME i s entered.
  15047   "^DD",9000 010.11,900 0010.11,12 05,"AUDIT" )
  15048   y
  15049   "^DD",9000 010.11,900 0010.11,12 05,"DT")
  15050   3150213
  15051   "^DD",9000 010.11,900 0010.11,12 06,0)
  15052   IMMUNIZATI ON DOCUMEN TER^P200'a ^VA(200,^1 2;6^Q
  15053   "^DD",9000 010.11,900 0010.11,12 06,.1)
  15054   Immunizati on Documen ter
  15055   "^DD",9000 010.11,900 0010.11,12 06,3)
  15056   Enter the  person who  documente d this imm unization  in the sys tem.
  15057   "^DD",9000 010.11,900 0010.11,12 06,5,1,0)
  15058   9000010.11 ^.01^2
  15059   "^DD",9000 010.11,900 0010.11,12 06,21,0)
  15060   ^^2^2^3140 422^
  15061   "^DD",9000 010.11,900 0010.11,12 06,21,1,0)
  15062   This is th e person/p rovider wh o document ed this im munization  by enteri ng
  15063   "^DD",9000 010.11,900 0010.11,12 06,21,2,0)
  15064   the data i nto the sy stem by wh atever mea ns.
  15065   "^DD",9000 010.11,900 0010.11,12 06,"AUDIT" )
  15066   y
  15067   "^DD",9000 010.11,900 0010.11,12 06,"DT")
  15068   3150213
  15069   "^DD",9000 010.11,900 0010.11,12 07,0)
  15070   LOT NUMBER ^*P9999999 .41'a^AUTT IML(^12;7^ S DIC("S") ="I '$P(^( 0),U,3),$P (^(0),U,9) '<DT,$$ACT ^PXVXR" D  ^DIC K DIC  S DIC=$G( DIE),X=+Y  K:Y<0 X
  15071   "^DD",9000 010.11,900 0010.11,12 07,.1)
  15072   Lot Number
  15073   "^DD",9000 010.11,900 0010.11,12 07,1,0)
  15074   ^.1
  15075   "^DD",9000 010.11,900 0010.11,12 07,1,1,0)
  15076   9000010.11 ^LN
  15077   "^DD",9000 010.11,900 0010.11,12 07,1,1,1)
  15078   S ^AUPNVIM M("LN",$E( X,1,30),DA )=""
  15079   "^DD",9000 010.11,900 0010.11,12 07,1,1,2)
  15080   K ^AUPNVIM M("LN",$E( X,1,30),DA )
  15081   "^DD",9000 010.11,900 0010.11,12 07,1,1,3)
  15082   Used for l ook-up and  to determ ine if a L ot Number  entry is b eing used.
  15083   "^DD",9000 010.11,900 0010.11,12 07,1,1,"%D ",0)
  15084   ^^3^3^3150 603^
  15085   "^DD",9000 010.11,900 0010.11,12 07,1,1,"%D ",1,0)
  15086   This cross  reference  is used t o determin e if an en try in the
  15087   "^DD",9000 010.11,900 0010.11,12 07,1,1,"%D ",2,0)
  15088   IMMUNIZATI ON LOT fil e is being  used by a n entry in  the V IMM UNIZATION
  15089   "^DD",9000 010.11,900 0010.11,12 07,1,1,"%D ",3,0)
  15090   file. Can  also be us ed for V I MMUNIZATIO N look-ups .
  15091   "^DD",9000 010.11,900 0010.11,12 07,1,1,"DT ")
  15092   3140609
  15093   "^DD",9000 010.11,900 0010.11,12 07,1,2,0)
  15094   9000010.11 ^AF^MUMPS
  15095   "^DD",9000 010.11,900 0010.11,12 07,1,2,1)
  15096   D DECR^PXV XR Q
  15097   "^DD",9000 010.11,900 0010.11,12 07,1,2,2)
  15098   D INCR^PXV XR Q
  15099   "^DD",9000 010.11,900 0010.11,12 07,1,2,"%D ",0)
  15100   ^^2^2^3150 616^
  15101   "^DD",9000 010.11,900 0010.11,12 07,1,2,"%D ",1,0)
  15102   This MUMPS  type cros s referenc e maintain s the numb er of dose s remainin g
  15103   "^DD",9000 010.11,900 0010.11,12 07,1,2,"%D ",2,0)
  15104   unused of  this lot n umber.
  15105   "^DD",9000 010.11,900 0010.11,12 07,1,2,"DT ")
  15106   3150616
  15107   "^DD",9000 010.11,900 0010.11,12 07,3)
  15108   Enter the  lot number  for this  immunizati on.
  15109   "^DD",9000 010.11,900 0010.11,12 07,12)
  15110   Screen req uires sele ction of a ctive lot  for select ed immuniz ation.
  15111   "^DD",9000 010.11,900 0010.11,12 07,12.1)
  15112   S DIC("S") ="I '$P(^( 0),U,3),$P (^(0),U,9) '<DT,$$ACT ^PXVXR"
  15113   "^DD",9000 010.11,900 0010.11,12 07,21,0)
  15114   ^^2^2^3150 824^
  15115   "^DD",9000 010.11,900 0010.11,12 07,21,1,0)
  15116   This is th e lot numb er of the  immunizati on entered  for this  event. If
  15117   "^DD",9000 010.11,900 0010.11,12 07,21,2,0)
  15118   historical  event, en ter lot nu mber (if k nown) in C omments.
  15119   "^DD",9000 010.11,900 0010.11,12 07,"AUDIT" )
  15120   y
  15121   "^DD",9000 010.11,900 0010.11,12 07,"DT")
  15122   3150824
  15123   "^DD",9000 010.11,900 0010.11,12 08,0)
  15124   PARENT^P90 00010.11'a ^AUPNVIMM( ^12;8^Q
  15125   "^DD",9000 010.11,900 0010.11,12 08,3)
  15126   Select the  parent ev ent to thi s one.
  15127   "^DD",9000 010.11,900 0010.11,12 08,21,0)
  15128   ^^3^3^3140 702^
  15129   "^DD",9000 010.11,900 0010.11,12 08,21,1,0)
  15130   This India n Health S ervice fie ld indicat es the par ent immuni zation, if
  15131   "^DD",9000 010.11,900 0010.11,12 08,21,2,0)
  15132   any, assoc iated with  this immu nization,  such as fo r immuniza tions give n
  15133   "^DD",9000 010.11,900 0010.11,12 08,21,3,0)
  15134   in series.
  15135   "^DD",9000 010.11,900 0010.11,12 08,23,0)
  15136   ^.001^5^5^ 3140626^^^
  15137   "^DD",9000 010.11,900 0010.11,12 08,23,1,0)
  15138   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15139   "^DD",9000 010.11,900 0010.11,12 08,23,2,0)
  15140   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15141   "^DD",9000 010.11,900 0010.11,12 08,23,3,0)
  15142   of the fil e.
  15143   "^DD",9000 010.11,900 0010.11,12 08,23,4,0)
  15144  
  15145   "^DD",9000 010.11,900 0010.11,12 08,23,5,0)
  15146   APCDALVR V ariable =  APCDALVR(" APCDTPNT")
  15147   "^DD",9000 010.11,900 0010.11,12 08,"AUDIT" )
  15148   y
  15149   "^DD",9000 010.11,900 0010.11,12 08,"DT")
  15150   3150213
  15151   "^DD",9000 010.11,900 0010.11,12 09,0)
  15152   EXTERNAL K EY^Fa^^12; 9^K:$L(X)> 20!($L(X)< 1) X
  15153   "^DD",9000 010.11,900 0010.11,12 09,3)
  15154   Answer mus t be 1-20  characters  in length .
  15155   "^DD",9000 010.11,900 0010.11,12 09,21,0)
  15156   ^^2^2^3140 702^
  15157   "^DD",9000 010.11,900 0010.11,12 09,21,1,0)
  15158   This India n Health S ervice fre e text fie ld identif ies the ex ternal key
  15159   "^DD",9000 010.11,900 0010.11,12 09,21,2,0)
  15160   associated  with this  immunizat ion.
  15161   "^DD",9000 010.11,900 0010.11,12 09,23,0)
  15162   ^.001^5^5^ 3140625^^
  15163   "^DD",9000 010.11,900 0010.11,12 09,23,1,0)
  15164   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15165   "^DD",9000 010.11,900 0010.11,12 09,23,2,0)
  15166   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15167   "^DD",9000 010.11,900 0010.11,12 09,23,3,0)
  15168   of the fil e.
  15169   "^DD",9000 010.11,900 0010.11,12 09,23,4,0)
  15170  
  15171   "^DD",9000 010.11,900 0010.11,12 09,23,5,0)
  15172   APCDALVR V ariable =  APCDALVR(" APCDTEXK")
  15173   "^DD",9000 010.11,900 0010.11,12 09,"AUDIT" )
  15174   y
  15175   "^DD",9000 010.11,900 0010.11,12 09,"DT")
  15176   3150213
  15177   "^DD",9000 010.11,900 0010.11,12 10,0)
  15178   OUTSIDE PR OVIDER NAM E^Fa^^12;1 0^K:$L(X)> 30!($L(X)< 1) X
  15179   "^DD",9000 010.11,900 0010.11,12 10,3)
  15180   Answer mus t be 1-30  characters  in length .
  15181   "^DD",9000 010.11,900 0010.11,12 10,21,0)
  15182   ^^2^2^3140 702^
  15183   "^DD",9000 010.11,900 0010.11,12 10,21,1,0)
  15184   This India n Health S ervice fie ld contain s the name  of the ou tside
  15185   "^DD",9000 010.11,900 0010.11,12 10,21,2,0)
  15186   provider a ssociated  with this  immunizati on.
  15187   "^DD",9000 010.11,900 0010.11,12 10,23,0)
  15188   ^.001^5^5^ 3140626^^^
  15189   "^DD",9000 010.11,900 0010.11,12 10,23,1,0)
  15190   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15191   "^DD",9000 010.11,900 0010.11,12 10,23,2,0)
  15192   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15193   "^DD",9000 010.11,900 0010.11,12 10,23,3,0)
  15194   of the fil e.
  15195   "^DD",9000 010.11,900 0010.11,12 10,23,4,0)
  15196  
  15197   "^DD",9000 010.11,900 0010.11,12 10,23,5,0)
  15198   APCDALVR V ariable =  APCDALVR(" APCDTOPR")
  15199   "^DD",9000 010.11,900 0010.11,12 10,"AUDIT" )
  15200   y
  15201   "^DD",9000 010.11,900 0010.11,12 10,"DT")
  15202   3150213
  15203   "^DD",9000 010.11,900 0010.11,12 13,0)
  15204   ANCILLARY  POV^P80'a^ ICD9(^12;1 3^Q
  15205   "^DD",9000 010.11,900 0010.11,12 13,3)
  15206   Select an  ancillary  diagnosis  for this e vent.
  15207   "^DD",9000 010.11,900 0010.11,12 13,21,0)
  15208   ^^2^2^3140 702^
  15209   "^DD",9000 010.11,900 0010.11,12 13,21,1,0)
  15210   This India n Health S ervice fie ld indicat ed the anc illary dia gnosis
  15211   "^DD",9000 010.11,900 0010.11,12 13,21,2,0)
  15212   related to  this immu nization.
  15213   "^DD",9000 010.11,900 0010.11,12 13,23,0)
  15214   ^^3^3^3140 625^
  15215   "^DD",9000 010.11,900 0010.11,12 13,23,1,0)
  15216   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15217   "^DD",9000 010.11,900 0010.11,12 13,23,2,0)
  15218   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15219   "^DD",9000 010.11,900 0010.11,12 13,23,3,0)
  15220   of the fil e.
  15221   "^DD",9000 010.11,900 0010.11,12 13,"AUDIT" )
  15222   y
  15223   "^DD",9000 010.11,900 0010.11,12 13,"DT")
  15224   3150213
  15225   "^DD",9000 010.11,900 0010.11,12 14,0)
  15226   USER LAST  UPDATE^P20 0'a^VA(200 ,^12;14^Q
  15227   "^DD",9000 010.11,900 0010.11,12 14,3)
  15228   Enter the  user who l ast update d this imm unization  event.
  15229   "^DD",9000 010.11,900 0010.11,12 14,21,0)
  15230   ^.001^2^2^ 3140819^^
  15231   "^DD",9000 010.11,900 0010.11,12 14,21,1,0)
  15232   This India n Health S ervice fie ld indicat es the use r who last  updated
  15233   "^DD",9000 010.11,900 0010.11,12 14,21,2,0)
  15234   informatio n for this  immunizat ion.
  15235   "^DD",9000 010.11,900 0010.11,12 14,23,0)
  15236   ^.001^3^3^ 3140819^^
  15237   "^DD",9000 010.11,900 0010.11,12 14,23,1,0)
  15238   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15239   "^DD",9000 010.11,900 0010.11,12 14,23,2,0)
  15240   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15241   "^DD",9000 010.11,900 0010.11,12 14,23,3,0)
  15242   of the fil e.
  15243   "^DD",9000 010.11,900 0010.11,12 14,"AUDIT" )
  15244   y
  15245   "^DD",9000 010.11,900 0010.11,12 14,"DT")
  15246   3150213
  15247   "^DD",9000 010.11,900 0010.11,12 15,0)
  15248   ORDERING L OCATION^P4 4'a^SC(^12 ;15^Q
  15249   "^DD",9000 010.11,900 0010.11,12 15,3)
  15250   Select the  location  within thi s medical  center whe re this Im munization  was order ed.
  15251   "^DD",9000 010.11,900 0010.11,12 15,21,0)
  15252   ^^2^2^3140 702^
  15253   "^DD",9000 010.11,900 0010.11,12 15,21,1,0)
  15254   This India n Health S ervice fie ld indicat ed the hos pital loca tion order ing
  15255   "^DD",9000 010.11,900 0010.11,12 15,21,2,0)
  15256   this immun ization.
  15257   "^DD",9000 010.11,900 0010.11,12 15,23,0)
  15258   ^^3^3^3140 625^
  15259   "^DD",9000 010.11,900 0010.11,12 15,23,1,0)
  15260   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15261   "^DD",9000 010.11,900 0010.11,12 15,23,2,0)
  15262   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15263   "^DD",9000 010.11,900 0010.11,12 15,23,3,0)
  15264   of the fil e.
  15265   "^DD",9000 010.11,900 0010.11,12 15,"AUDIT" )
  15266   y
  15267   "^DD",9000 010.11,900 0010.11,12 15,"DT")
  15268   3150213
  15269   "^DD",9000 010.11,900 0010.11,12 16,0)
  15270   DATE/TIME  ENTERED^Da ^^12;16^S  %DT="ESTXR " D ^%DT S  X=Y K:Y<1  X
  15271   "^DD",9000 010.11,900 0010.11,12 16,1,0)
  15272   ^.1
  15273   "^DD",9000 010.11,900 0010.11,12 16,1,1,0)
  15274   ^^TRIGGER^ 9000010.11 ^1217
  15275   "^DD",9000 010.11,900 0010.11,12 16,1,1,1)
  15276   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVI MM(D0,12)) :^(12),1:" ") S X=$P( Y(1),U,17) ,X=X S DIU =X K Y S X =DIV I '$G (APCDVMUX)  S X=DUZ X  ^DD(90000 10.11,1216 ,1,1,1.4)
  15277   "^DD",9000 010.11,900 0010.11,12 16,1,1,1.4 )
  15278   S DIH=$G(^ AUPNVIMM(D IV(0),12)) ,DIV=X S $ P(^(12),U, 17)=DIV,DI H=9000010. 11,DIG=121 7 D ^DICR
  15279   "^DD",9000 010.11,900 0010.11,12 16,1,1,2)
  15280   Q
  15281   "^DD",9000 010.11,900 0010.11,12 16,1,1,"CR EATE VALUE ")
  15282   I '$G(APCD VMUX) S X= DUZ
  15283   "^DD",9000 010.11,900 0010.11,12 16,1,1,"DE LETE VALUE ")
  15284   NO EFFECT
  15285   "^DD",9000 010.11,900 0010.11,12 16,1,1,"DT ")
  15286   3120423
  15287   "^DD",9000 010.11,900 0010.11,12 16,1,1,"FI ELD")
  15288   #1217
  15289   "^DD",9000 010.11,900 0010.11,12 16,1,2,0)
  15290   ^^TRIGGER^ 9000010.11 ^1218
  15291   "^DD",9000 010.11,900 0010.11,12 16,1,2,1)
  15292   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVI MM(D0,12)) :^(12),1:" ") S X=$P( Y(1),U,18) ,X=X S DIU =X K Y S X =DIV I '$G (APCDVMUX)  S X=$$NOW ^XLFDT X ^ DD(9000010 .11,1216,1 ,2,1.4)
  15293   "^DD",9000 010.11,900 0010.11,12 16,1,2,1.4 )
  15294   S DIH=$G(^ AUPNVIMM(D IV(0),12)) ,DIV=X S $ P(^(12),U, 18)=DIV,DI H=9000010. 11,DIG=121 8 D ^DICR
  15295   "^DD",9000 010.11,900 0010.11,12 16,1,2,2)
  15296   Q
  15297   "^DD",9000 010.11,900 0010.11,12 16,1,2,"CR EATE VALUE ")
  15298   I '$G(APCD VMUX) S X= $$NOW^XLFD T
  15299   "^DD",9000 010.11,900 0010.11,12 16,1,2,"DE LETE VALUE ")
  15300   NO EFFECT
  15301   "^DD",9000 010.11,900 0010.11,12 16,1,2,"DT ")
  15302   3120423
  15303   "^DD",9000 010.11,900 0010.11,12 16,1,2,"FI ELD")
  15304   #1218
  15305   "^DD",9000 010.11,900 0010.11,12 16,3)
  15306   Enter the  date and t ime this e vent was e ntered her e.
  15307   "^DD",9000 010.11,900 0010.11,12 16,21,0)
  15308   ^^2^2^3140 702^
  15309   "^DD",9000 010.11,900 0010.11,12 16,21,1,0)
  15310   This India n Health S ervice fie ld indicat es the dat e and time  that this
  15311   "^DD",9000 010.11,900 0010.11,12 16,21,2,0)
  15312   immunizati on informa tion was e ntered int o this rec ord.
  15313   "^DD",9000 010.11,900 0010.11,12 16,23,0)
  15314   ^^3^3^3140 625^
  15315   "^DD",9000 010.11,900 0010.11,12 16,23,1,0)
  15316   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15317   "^DD",9000 010.11,900 0010.11,12 16,23,2,0)
  15318   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15319   "^DD",9000 010.11,900 0010.11,12 16,23,3,0)
  15320   of the fil e.
  15321   "^DD",9000 010.11,900 0010.11,12 16,"AUDIT" )
  15322   y
  15323   "^DD",9000 010.11,900 0010.11,12 16,"DT")
  15324   3150213
  15325   "^DD",9000 010.11,900 0010.11,12 17,0)
  15326   ENTERED BY ^P200'a^VA (200,^12;1 7^Q
  15327   "^DD",9000 010.11,900 0010.11,12 17,3)
  15328   Select the  user who  first ente red this e vent.
  15329   "^DD",9000 010.11,900 0010.11,12 17,5,1,0)
  15330   9000010.11 ^1216^1
  15331   "^DD",9000 010.11,900 0010.11,12 17,21,0)
  15332   ^^2^2^3140 702^
  15333   "^DD",9000 010.11,900 0010.11,12 17,21,1,0)
  15334   This India n Health S ervice fie ld indicat es the use r who ente red this
  15335   "^DD",9000 010.11,900 0010.11,12 17,21,2,0)
  15336   immunizati on record.
  15337   "^DD",9000 010.11,900 0010.11,12 17,23,0)
  15338   ^^3^3^3140 625^
  15339   "^DD",9000 010.11,900 0010.11,12 17,23,1,0)
  15340   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15341   "^DD",9000 010.11,900 0010.11,12 17,23,2,0)
  15342   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15343   "^DD",9000 010.11,900 0010.11,12 17,23,3,0)
  15344   of the fil e.
  15345   "^DD",9000 010.11,900 0010.11,12 17,"AUDIT" )
  15346   y
  15347   "^DD",9000 010.11,900 0010.11,12 17,"DT")
  15348   3150213
  15349   "^DD",9000 010.11,900 0010.11,12 18,0)
  15350   DATE/TIME  LAST MODIF IED^Da^^12 ;18^S %DT= "ESTXR" D  ^%DT S X=Y  K:Y<1 X
  15351   "^DD",9000 010.11,900 0010.11,12 18,1,0)
  15352   ^.1
  15353   "^DD",9000 010.11,900 0010.11,12 18,1,1,0)
  15354   ^^TRIGGER^ 9000010.11 ^1219
  15355   "^DD",9000 010.11,900 0010.11,12 18,1,1,1)
  15356   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVI MM(D0,12)) :^(12),1:" ") S X=$P( Y(1),U,19) ,X=X S DIU =X K Y S X =DIV I '$G (APCDVMUX)  S X=DUZ X  ^DD(90000 10.11,1218 ,1,1,1.4)
  15357   "^DD",9000 010.11,900 0010.11,12 18,1,1,1.4 )
  15358   S DIH=$G(^ AUPNVIMM(D IV(0),12)) ,DIV=X S $ P(^(12),U, 19)=DIV,DI H=9000010. 11,DIG=121 9 D ^DICR
  15359   "^DD",9000 010.11,900 0010.11,12 18,1,1,2)
  15360   Q
  15361   "^DD",9000 010.11,900 0010.11,12 18,1,1,"CR EATE VALUE ")
  15362   I '$G(APCD VMUX) S X= DUZ
  15363   "^DD",9000 010.11,900 0010.11,12 18,1,1,"DE LETE VALUE ")
  15364   NO EFFECT
  15365   "^DD",9000 010.11,900 0010.11,12 18,1,1,"DT ")
  15366   3120423
  15367   "^DD",9000 010.11,900 0010.11,12 18,1,1,"FI ELD")
  15368   #1219
  15369   "^DD",9000 010.11,900 0010.11,12 18,3)
  15370   Enter the  date and t ime this e vent was l ast modifi ed.
  15371   "^DD",9000 010.11,900 0010.11,12 18,5,1,0)
  15372   9000010.11 ^1216^2
  15373   "^DD",9000 010.11,900 0010.11,12 18,21,0)
  15374   ^^2^2^3140 702^
  15375   "^DD",9000 010.11,900 0010.11,12 18,21,1,0)
  15376   This India n Health S ervice fie ld indicat es the dat e and time  this
  15377   "^DD",9000 010.11,900 0010.11,12 18,21,2,0)
  15378   immunizati on record  was last m odified.
  15379   "^DD",9000 010.11,900 0010.11,12 18,23,0)
  15380   ^.001^3^3^ 3140626^^^
  15381   "^DD",9000 010.11,900 0010.11,12 18,23,1,0)
  15382   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15383   "^DD",9000 010.11,900 0010.11,12 18,23,2,0)
  15384   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15385   "^DD",9000 010.11,900 0010.11,12 18,23,3,0)
  15386   of the fil e.
  15387   "^DD",9000 010.11,900 0010.11,12 18,"AUDIT" )
  15388   y
  15389   "^DD",9000 010.11,900 0010.11,12 18,"DT")
  15390   3150213
  15391   "^DD",9000 010.11,900 0010.11,12 19,0)
  15392   LAST MODIF IED BY^P20 0'a^VA(200 ,^12;19^Q
  15393   "^DD",9000 010.11,900 0010.11,12 19,3)
  15394   Select the  user who  last modif ied this e vent.
  15395   "^DD",9000 010.11,900 0010.11,12 19,5,1,0)
  15396   9000010.11 ^1218^1
  15397   "^DD",9000 010.11,900 0010.11,12 19,21,0)
  15398   ^^2^2^3140 702^
  15399   "^DD",9000 010.11,900 0010.11,12 19,21,1,0)
  15400   This India n Health S ervice fie ld indicat es the use r who last  modified
  15401   "^DD",9000 010.11,900 0010.11,12 19,21,2,0)
  15402   this immun ization re cord.
  15403   "^DD",9000 010.11,900 0010.11,12 19,23,0)
  15404   ^.001^3^3^ 3140625^^
  15405   "^DD",9000 010.11,900 0010.11,12 19,23,1,0)
  15406   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15407   "^DD",9000 010.11,900 0010.11,12 19,23,2,0)
  15408   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15409   "^DD",9000 010.11,900 0010.11,12 19,23,3,0)
  15410   of the fil e.
  15411   "^DD",9000 010.11,900 0010.11,12 19,"AUDIT" )
  15412   y
  15413   "^DD",9000 010.11,900 0010.11,12 19,"DT")
  15414   3150213
  15415   "^DD",9000 010.11,900 0010.11,12 20,0)
  15416   WARNING AC KNOWLEDGED ^Sa^1:YES; ^12;20^Q
  15417   "^DD",9000 010.11,900 0010.11,12 20,.1)
  15418   Warning Ac knowledged
  15419   "^DD",9000 010.11,900 0010.11,12 20,3)
  15420   Enter YES  to acknowl edge a war ning of co ntraindica tion/refus al events  associated  with this  immunizat ion.
  15421   "^DD",9000 010.11,900 0010.11,12 20,21,0)
  15422   ^^3^3^3151 207^
  15423   "^DD",9000 010.11,900 0010.11,12 20,21,1,0)
  15424   This field  indicates  acknowled gement of  a contrain dication/r efusal
  15425   "^DD",9000 010.11,900 0010.11,12 20,21,2,0)
  15426   events war ning for t his immuni zation wit h the deci sion to pr oceed with
  15427   "^DD",9000 010.11,900 0010.11,12 20,21,3,0)
  15428   administra tion.
  15429   "^DD",9000 010.11,900 0010.11,12 20,"AUDIT" )
  15430   y
  15431   "^DD",9000 010.11,900 0010.11,12 20,"DT")
  15432   3151207
  15433   "^DD",9000 010.11,900 0010.11,13 01,0)
  15434   EVENT INFO RMATION SO URCE^R*P92 0.1'a^PXV( 920.1,^13; 1^S DIC("S ")="I '$P( ^(0),U,3)"  D ^DIC K  DIC S DIC= DIE,X=+Y K :Y<0 X
  15435   "^DD",9000 010.11,900 0010.11,13 01,.1)
  15436   Informatio n Source
  15437   "^DD",9000 010.11,900 0010.11,13 01,3)
  15438   Select the  source of  this even t's inform ation.
  15439   "^DD",9000 010.11,900 0010.11,13 01,12)
  15440   SOURCE sel ected must  have a ST ATUS of AC TIVE
  15441   "^DD",9000 010.11,900 0010.11,13 01,12.1)
  15442   S DIC("S") ="I '$P(^( 0),U,3)"
  15443   "^DD",9000 010.11,900 0010.11,13 01,21,0)
  15444   ^.001^2^2^ 3140626^^^ ^
  15445   "^DD",9000 010.11,900 0010.11,13 01,21,1,0)
  15446   This is th e source o f the info rmation ob tained for  this immu nization
  15447   "^DD",9000 010.11,900 0010.11,13 01,21,2,0)
  15448   event.  If  this is a  new event  for this  patient, n o entry is  required.
  15449   "^DD",9000 010.11,900 0010.11,13 01,23,0)
  15450   ^.001^3^3^ 3140626^^^
  15451   "^DD",9000 010.11,900 0010.11,13 01,23,1,0)
  15452   This field  is used t o note the  source of  this immu nization e vent.  If  the
  15453   "^DD",9000 010.11,900 0010.11,13 01,23,2,0)
  15454   event is a  new recor d, no entr y is neces sary.  The  options a vailable f or
  15455   "^DD",9000 010.11,900 0010.11,13 01,23,3,0)
  15456   this field  come from  the IMMUN IZATION IN FO SOURCE  file.
  15457   "^DD",9000 010.11,900 0010.11,13 01,"AUDIT" )
  15458   y
  15459   "^DD",9000 010.11,900 0010.11,13 01,"DT")
  15460   3150213
  15461   "^DD",9000 010.11,900 0010.11,13 02,0)
  15462   ROUTE OF A DMINISTRAT ION^*P920. 2'a^PXV(92 0.2,^13;2^ S DIC("S") ="I '$$SCR EEN^XTID(9 20.2,,Y_"" ,"")" D ^D IC K DIC S  DIC=DIE,X =+Y K:Y<0  X
  15463   "^DD",9000 010.11,900 0010.11,13 02,.1)
  15464   Route of A dministrat ion
  15465   "^DD",9000 010.11,900 0010.11,13 02,3)
  15466   Select the  route of  administra tion for t his event.
  15467   "^DD",9000 010.11,900 0010.11,13 02,12)
  15468   Only activ e IMM ADMI NISTRATION  ROUTE ent ries may b e selected .
  15469   "^DD",9000 010.11,900 0010.11,13 02,12.1)
  15470   S DIC("S") ="I '$$SCR EEN^XTID(9 20.2,,Y_"" ,"")"
  15471   "^DD",9000 010.11,900 0010.11,13 02,21,0)
  15472   ^.001^2^2^ 3150813^^^ ^
  15473   "^DD",9000 010.11,900 0010.11,13 02,21,1,0)
  15474   This is th e method t his vaccin e was admi nistered.   Select fr om the lis t
  15475   "^DD",9000 010.11,900 0010.11,13 02,21,2,0)
  15476   provided.
  15477   "^DD",9000 010.11,900 0010.11,13 02,23,0)
  15478   ^.001^3^3^ 3150813^^^
  15479   "^DD",9000 010.11,900 0010.11,13 02,23,1,0)
  15480   This is th e method b y which th e vaccine  was admini stered. Th is is
  15481   "^DD",9000 010.11,900 0010.11,13 02,23,2,0)
  15482   selected f rom a set  of values  in the IMM  ROUTE OF  ADMINISTRA TION
  15483   "^DD",9000 010.11,900 0010.11,13 02,23,3,0)
  15484   file (#920 .2).
  15485   "^DD",9000 010.11,900 0010.11,13 02,"AUDIT" )
  15486   y
  15487   "^DD",9000 010.11,900 0010.11,13 02,"DT")
  15488   3150813
  15489   "^DD",9000 010.11,900 0010.11,13 03,0)
  15490   SITE OF AD MINISTRATI ON (BODY)^ *P920.3'a^ PXV(920.3, ^13;3^S DI C("S")="I  '$$SCREEN^ XTID(920.3 ,,Y_"","") " D ^DIC K  DIC S DIC =$G(DIE),X =+Y K:Y<0  X
  15491   "^DD",9000 010.11,900 0010.11,13 03,.1)
  15492   Site of Ad ministrati on (Body)
  15493   "^DD",9000 010.11,900 0010.11,13 03,3)
  15494   Select the  site the  vaccine wa s administ ered.
  15495   "^DD",9000 010.11,900 0010.11,13 03,12)
  15496   Only activ e IMM ADMI NISTRATION  SITE (BOD Y) entries  may be se lected.
  15497   "^DD",9000 010.11,900 0010.11,13 03,12.1)
  15498   S DIC("S") ="I '$$SCR EEN^XTID(9 20.3,,Y_"" ,"")"
  15499   "^DD",9000 010.11,900 0010.11,13 03,21,0)
  15500   ^.001^2^2^ 3140625^^^
  15501   "^DD",9000 010.11,900 0010.11,13 03,21,1,0)
  15502   This is th e area of  the patien t's body t hrough whi ch the vac cine was
  15503   "^DD",9000 010.11,900 0010.11,13 03,21,2,0)
  15504   administer ed.
  15505   "^DD",9000 010.11,900 0010.11,13 03,23,0)
  15506   ^^3^3^3140 701^
  15507   "^DD",9000 010.11,900 0010.11,13 03,23,1,0)
  15508   This is th e area of  the patien t's body t hrough whi ch the vac cine was
  15509   "^DD",9000 010.11,900 0010.11,13 03,23,2,0)
  15510   administer ed.  It is  selected  from a lis t provided  by the IM M
  15511   "^DD",9000 010.11,900 0010.11,13 03,23,3,0)
  15512   ADMINISTRA TION SITE  (BODY) fil e (#920.3) .
  15513   "^DD",9000 010.11,900 0010.11,13 03,"AUDIT" )
  15514   y
  15515   "^DD",9000 010.11,900 0010.11,13 03,"DT")
  15516   3150226
  15517   "^DD",9000 010.11,900 0010.11,13 04,0)
  15518   PRIMARY DI AGNOSIS^*P 80'Xa^ICD9 (^13;4^S D IC("S")="D  ^AUPNSICD " D ^DIC K  DIC S DIC =DIE,X=+Y  K:Y<0 X I  $D(X),$D(D 0),$$DUPDX ^PXVUTIL(D 0,X) K X
  15519   "^DD",9000 010.11,900 0010.11,13 04,.1)
  15520   Primary Di agnosis
  15521   "^DD",9000 010.11,900 0010.11,13 04,3)
  15522   Select the  primary ( or initial ) diagnosi s for this  immunizat ion.
  15523   "^DD",9000 010.11,900 0010.11,13 04,12)
  15524   Diagnosis  must be ap propriate  and active .
  15525   "^DD",9000 010.11,900 0010.11,13 04,12.1)
  15526   S DIC("S") ="D ^AUPNS ICD"
  15527   "^DD",9000 010.11,900 0010.11,13 04,21,0)
  15528   ^.001^2^2^ 3140620^^^
  15529   "^DD",9000 010.11,900 0010.11,13 04,21,1,0)
  15530   This is th e primary  (or initia l) diagnos is for thi s immuniza tion event . It
  15531   "^DD",9000 010.11,900 0010.11,13 04,21,2,0)
  15532   is selecte d from the  ISC DIAGN OSIS file.
  15533   "^DD",9000 010.11,900 0010.11,13 04,23,0)
  15534   ^.001^4^4^ 3140620^^
  15535   "^DD",9000 010.11,900 0010.11,13 04,23,1,0)
  15536   This is th e primary  diagnosis  for this i mmunizatio n.  This f ield is a
  15537   "^DD",9000 010.11,900 0010.11,13 04,23,2,0)
  15538   pointer to  the ICD D IAGNOSIS f ile (#80).   Selectio n is scree ned to mak e sure
  15539   "^DD",9000 010.11,900 0010.11,13 04,23,3,0)
  15540   it's appro priate and  active.   An immuniz ation even t can have  more than
  15541   "^DD",9000 010.11,900 0010.11,13 04,23,4,0)
  15542   one diagno sis - see  the OTHER  DIAGNOSIS  field (#2) .
  15543   "^DD",9000 010.11,900 0010.11,13 04,"AUDIT" )
  15544   y
  15545   "^DD",9000 010.11,900 0010.11,13 04,"DT")
  15546   3150605
  15547   "^DD",9000 010.11,900 0010.11,13 12,0)
  15548   DOSE^NJ6,2 aO^^13;12^ K:+X'=X!(X >999)!(X<0 )!(X?.E1". "3N.N) X
  15549   "^DD",9000 010.11,900 0010.11,13 12,2)
  15550   S Y(0)=Y S :Y Y=$FN(Y ,",")
  15551   "^DD",9000 010.11,900 0010.11,13 12,2.1)
  15552   S:Y Y=$FN( Y,",")
  15553   "^DD",9000 010.11,900 0010.11,13 12,3)
  15554   Type a num ber betwee n 0 and 99 9, 2 fract ional digi ts.
  15555   "^DD",9000 010.11,900 0010.11,13 12,21,0)
  15556   ^^2^2^3150 819^
  15557   "^DD",9000 010.11,900 0010.11,13 12,21,1,0)
  15558   This is th e amount o f vaccine  product ad ministered  for this  immunizati on.
  15559   "^DD",9000 010.11,900 0010.11,13 12,21,2,0)
  15560   The units  are expres sed in the  DOSE UNIT S field (# 1313).
  15561   "^DD",9000 010.11,900 0010.11,13 12,"AUDIT" )
  15562   y
  15563   "^DD",9000 010.11,900 0010.11,13 12,"DT")
  15564   3150819
  15565   "^DD",9000 010.11,900 0010.11,13 12.5,0)
  15566   DOSAGE^CJ1 0^^ ; ^S X =$$DOSAGE^ PXVUTIL(D0 )
  15567   "^DD",9000 010.11,900 0010.11,13 12.5,9.01)
  15568  
  15569   "^DD",9000 010.11,900 0010.11,13 12.5,9.1)
  15570   S X=$$DOSA GE^PXVUTIL (D0)
  15571   "^DD",9000 010.11,900 0010.11,13 12.5,21,0)
  15572   ^^2^2^3150 819^
  15573   "^DD",9000 010.11,900 0010.11,13 12.5,21,1, 0)
  15574   A computed  field tha t concaten ates the D OSE (#1312 ) and DOSE  UNITS (#1 313)
  15575   "^DD",9000 010.11,900 0010.11,13 12.5,21,2, 0)
  15576   fields. Th e resultin g output w ill look s omething l ikes this:  ".5 mL".
  15577   "^DD",9000 010.11,900 0010.11,13 12.5,"DT")
  15578   3150819
  15579   "^DD",9000 010.11,900 0010.11,13 13,0)
  15580   DOSE UNITS ^P757.5'aO ^LEX(757.5 ,^13;13^Q
  15581   "^DD",9000 010.11,900 0010.11,13 13,2)
  15582   S Y(0)=Y S :Y Y=$P($$ UCUMCODE^L EXMUCUM(Y) ,"^")
  15583   "^DD",9000 010.11,900 0010.11,13 13,2.1)
  15584   S:Y Y=$P($ $UCUMCODE^ LEXMUCUM(Y ),"^")
  15585   "^DD",9000 010.11,900 0010.11,13 13,3)
  15586   Enter the  units that  reflect t he actual  quantity o f the vacc ine produc t administ ered.
  15587   "^DD",9000 010.11,900 0010.11,13 13,21,0)
  15588   ^.001^2^2^ 3150819^^
  15589   "^DD",9000 010.11,900 0010.11,13 13,21,1,0)
  15590   This is th e units th at reflect  the actua l quantity  of the va ccine prod uct
  15591   "^DD",9000 010.11,900 0010.11,13 13,21,2,0)
  15592   administer ed.
  15593   "^DD",9000 010.11,900 0010.11,13 13,"AUDIT" )
  15594   y
  15595   "^DD",9000 010.11,900 0010.11,13 13,"DT")
  15596   3150819
  15597   "^DD",9000 010.11,900 0010.11,14 01,0)
  15598   RESULTS^Sa ^T:TAKE;N: NO TAKE;I: INDETERMIN ATE;^14;1^ Q
  15599   "^DD",9000 010.11,900 0010.11,14 01,.1)
  15600   Inoculatio n Results
  15601   "^DD",9000 010.11,900 0010.11,14 01,3)
  15602   Enter whet her the re sults were  Take, No  Take or In determinat e.
  15603   "^DD",9000 010.11,900 0010.11,14 01,21,0)
  15604   ^.001^1^1^ 3150522^^
  15605   "^DD",9000 010.11,900 0010.11,14 01,21,1,0)
  15606   This is th e interpre tation of  the inocul ation resu lt.
  15607   "^DD",9000 010.11,900 0010.11,14 01,"AUDIT" )
  15608   y
  15609   "^DD",9000 010.11,900 0010.11,14 01,"DT")
  15610   3150522
  15611   "^DD",9000 010.11,900 0010.11,14 02,0)
  15612   READING^NJ 2,0a^^14;2 ^K:+X'=X!( X>40)!(X<0 )!(X?.E1". "1N.N) X
  15613   "^DD",9000 010.11,900 0010.11,14 02,.1)
  15614   Reading in  Millimete rs (mm)
  15615   "^DD",9000 010.11,900 0010.11,14 02,1,0)
  15616   ^.1
  15617   "^DD",9000 010.11,900 0010.11,14 02,1,1,0)
  15618   9000010.11 ^AE
  15619   "^DD",9000 010.11,900 0010.11,14 02,1,1,1)
  15620   S ^AUPNVIM M("AE",$E( X,1,30),DA )=""
  15621   "^DD",9000 010.11,900 0010.11,14 02,1,1,2)
  15622   K ^AUPNVIM M("AE",$E( X,1,30),DA )
  15623   "^DD",9000 010.11,900 0010.11,14 02,1,1,"%D ",0)
  15624   ^^2^2^3150 127^
  15625   "^DD",9000 010.11,900 0010.11,14 02,1,1,"%D ",1,0)
  15626   This cross  reference  searches  on the ino culation r esults acr oss all
  15627   "^DD",9000 010.11,900 0010.11,14 02,1,1,"%D ",2,0)
  15628   patients.
  15629   "^DD",9000 010.11,900 0010.11,14 02,1,1,"DT ")
  15630   3150127
  15631   "^DD",9000 010.11,900 0010.11,14 02,3)
  15632   Enter a wh ole number  between 0  and 40.
  15633   "^DD",9000 010.11,900 0010.11,14 02,21,0)
  15634   ^^1^1^3150 126^
  15635   "^DD",9000 010.11,900 0010.11,14 02,21,1,0)
  15636   This is th e objectiv e, measura ble readin g followin g the inoc ulation.
  15637   "^DD",9000 010.11,900 0010.11,14 02,"AUDIT" )
  15638   y
  15639   "^DD",9000 010.11,900 0010.11,14 02,"DT")
  15640   3150127
  15641   "^DD",9000 010.11,900 0010.11,14 03,0)
  15642   DATE/TIME  READ^DXa^^ 14;3^S %DT ="ET" D ^% DT S X=Y K :Y<1!$$TIM E^PXVUTL X
  15643   "^DD",9000 010.11,900 0010.11,14 03,.1)
  15644   Reading Da te/Time
  15645   "^DD",9000 010.11,900 0010.11,14 03,1,0)
  15646   ^.1^^-1
  15647   "^DD",9000 010.11,900 0010.11,14 03,1,1,0)
  15648   ^^TRIGGER^ 9000010.11 ^1405
  15649   "^DD",9000 010.11,900 0010.11,14 03,1,1,1)
  15650   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVI MM(D0,14)) :^(14),1:" ") S X=$P( Y(1),U,5), X=X S DIU= X K Y S X= DIV N %I,% H,% D NOW^ %DTC S X=%  X ^DD(900 0010.11,14 03,1,1,1.4 )
  15651   "^DD",9000 010.11,900 0010.11,14 03,1,1,1.4 )
  15652   S DIH=$G(^ AUPNVIMM(D IV(0),14)) ,DIV=X S $ P(^(14),U, 5)=DIV,DIH =9000010.1 1,DIG=1405  D ^DICR
  15653   "^DD",9000 010.11,900 0010.11,14 03,1,1,2)
  15654   Q
  15655   "^DD",9000 010.11,900 0010.11,14 03,1,1,"CR EATE VALUE ")
  15656   NOW
  15657   "^DD",9000 010.11,900 0010.11,14 03,1,1,"DE LETE VALUE ")
  15658   NO EFFECT
  15659   "^DD",9000 010.11,900 0010.11,14 03,1,1,"FI ELD")
  15660   READING RE CORDED
  15661   "^DD",9000 010.11,900 0010.11,14 03,3)
  15662   Enter the  date and ( optional)  time the i mmunizatio n was read .
  15663   "^DD",9000 010.11,900 0010.11,14 03,21,0)
  15664   ^^3^3^3150 820^
  15665   "^DD",9000 010.11,900 0010.11,14 03,21,1,0)
  15666   This is th e date and  time of t he reading  of the im munization  results.
  15667   "^DD",9000 010.11,900 0010.11,14 03,21,2,0)
  15668   Time entry  is option al and imp recise dat e is allow ed for his torical
  15669   "^DD",9000 010.11,900 0010.11,14 03,21,3,0)
  15670   immunizati ons.
  15671   "^DD",9000 010.11,900 0010.11,14 03,"AUDIT" )
  15672   y
  15673   "^DD",9000 010.11,900 0010.11,14 03,"DT")
  15674   3150820
  15675   "^DD",9000 010.11,900 0010.11,14 04,0)
  15676   READER^P20 0'a^VA(200 ,^14;4^Q
  15677   "^DD",9000 010.11,900 0010.11,14 04,.1)
  15678   Reader of  Inoculatio n Results
  15679   "^DD",9000 010.11,900 0010.11,14 04,3)
  15680   Enter the  name of th e person w ho read th e inoculat ion result s.
  15681   "^DD",9000 010.11,900 0010.11,14 04,21,0)
  15682   ^.001^2^2^ 3150127^^
  15683   "^DD",9000 010.11,900 0010.11,14 04,21,1,0)
  15684   This is th e name of  the person  who read  and interp reted the  results of
  15685   "^DD",9000 010.11,900 0010.11,14 04,21,2,0)
  15686   the inocul ation.
  15687   "^DD",9000 010.11,900 0010.11,14 04,"AUDIT" )
  15688   y
  15689   "^DD",9000 010.11,900 0010.11,14 04,"DT")
  15690   3150127
  15691   "^DD",9000 010.11,900 0010.11,14 05,0)
  15692   READING RE CORDED^Da^ ^14;5^S %D T="ETXR" D  ^%DT S X= Y K:Y<1 X
  15693   "^DD",9000 010.11,900 0010.11,14 05,.1)
  15694   Date/Time  Reading is  Recorded
  15695   "^DD",9000 010.11,900 0010.11,14 05,3)
  15696   Enter the  date and t ime of the  reading o f the inoc ulation re sults.
  15697   "^DD",9000 010.11,900 0010.11,14 05,5,1,0)
  15698   9000010.11 ^1403^1
  15699   "^DD",9000 010.11,900 0010.11,14 05,9)
  15700   ^
  15701   "^DD",9000 010.11,900 0010.11,14 05,21,0)
  15702   ^^3^3^3150 127^
  15703   "^DD",9000 010.11,900 0010.11,14 05,21,1,0)
  15704   This times tamp field  is the da te and tim e of docum entation o f reading  of
  15705   "^DD",9000 010.11,900 0010.11,14 05,21,2,0)
  15706   the inocul ation resu lts. This  field is s et automat ically whe n the
  15707   "^DD",9000 010.11,900 0010.11,14 05,21,3,0)
  15708   DATE/TIME  READ is en tered.
  15709   "^DD",9000 010.11,900 0010.11,14 05,"AUDIT" )
  15710   y
  15711   "^DD",9000 010.11,900 0010.11,14 05,"DT")
  15712   3150127
  15713   "^DD",9000 010.11,900 0010.11,14 06,0)
  15714   HOURS READ  POST-INOC ULATION^NJ 3,0a^^14;6 ^K:+X'=X!( X>100)!(X< 0)!(X?.E1" ."1N.N) X
  15715   "^DD",9000 010.11,900 0010.11,14 06,.1)
  15716   Hours Betw een Inocul ation and  Reading
  15717   "^DD",9000 010.11,900 0010.11,14 06,3)
  15718   Type a num ber betwee n 0 and 10 0, 0 decim al digits.
  15719   "^DD",9000 010.11,900 0010.11,14 06,21,0)
  15720   ^^2^2^3150 127^
  15721   "^DD",9000 010.11,900 0010.11,14 06,21,1,0)
  15722   This is th e number o f hours be tween the  inoculatio n and the  reading of
  15723   "^DD",9000 010.11,900 0010.11,14 06,21,2,0)
  15724   the result s.
  15725   "^DD",9000 010.11,900 0010.11,14 06,"AUDIT" )
  15726   y
  15727   "^DD",9000 010.11,900 0010.11,14 06,"DT")
  15728   3150818
  15729   "^DD",9000 010.11,900 0010.11,15 01,0)
  15730   READING CO MMENT^Fa^^ 15;1^K:$L( X)>245!($L (X)<1) X
  15731   "^DD",9000 010.11,900 0010.11,15 01,3)
  15732   Enter a re ading comm ent 1-245  characters  in length .
  15733   "^DD",9000 010.11,900 0010.11,15 01,21,0)
  15734   ^^2^2^3150 128^
  15735   "^DD",9000 010.11,900 0010.11,15 01,21,1,0)
  15736   This is a  comment re lated to t he reading  of the pa tient's in oculation.
  15737   "^DD",9000 010.11,900 0010.11,15 01,21,2,0)
  15738   The provid er may ent er this ma nually via  the PCE U ser Interf ace.
  15739   "^DD",9000 010.11,900 0010.11,15 01,"AUDIT" )
  15740   y
  15741   "^DD",9000 010.11,900 0010.11,15 01,"DT")
  15742   3150128
  15743   "^DD",9000 010.11,900 0010.11,16 01,0)
  15744   WARNING OV ERRIDE REA SON^Fa^^16 ;1^K:$L(X) >245!($L(X )<3) X
  15745   "^DD",9000 010.11,900 0010.11,16 01,.1)
  15746   Warning Ov erride Jus tification
  15747   "^DD",9000 010.11,900 0010.11,16 01,3)
  15748   Answer mus t be 3-245  character s in lengt h.
  15749   "^DD",9000 010.11,900 0010.11,16 01,21,0)
  15750   ^^2^2^3160 112^
  15751   "^DD",9000 010.11,900 0010.11,16 01,21,1,0)
  15752   This is th e reason f or overrid ing the wa rning of e xisting
  15753   "^DD",9000 010.11,900 0010.11,16 01,21,2,0)
  15754   contraindi cation and /or refusa l reasons.
  15755   "^DD",9000 010.11,900 0010.11,16 01,"AUDIT" )
  15756   y
  15757   "^DD",9000 010.11,900 0010.11,16 01,"DT")
  15758   3160201
  15759   "^DD",9000 010.11,900 0010.11,26 01,0)
  15760   SNOMED CT^ 9000010.11 26A^^26;0
  15761   "^DD",9000 010.11,900 0010.11,26 01,21,0)
  15762   ^.001^2^2^ 3140829^^^
  15763   "^DD",9000 010.11,900 0010.11,26 01,21,1,0)
  15764   This India n Health S ervice fie ld indicat es the SNO MED Clinic al Terms ( CT)
  15765   "^DD",9000 010.11,900 0010.11,26 01,21,2,0)
  15766   that descr ibe this i mmunizatio n and thei r preferre d terms.
  15767   "^DD",9000 010.11,900 0010.11,26 01,23,0)
  15768   ^.001^3^3^ 3140829^^
  15769   "^DD",9000 010.11,900 0010.11,26 01,23,1,0)
  15770   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15771   "^DD",9000 010.11,900 0010.11,26 01,23,2,0)
  15772   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15773   "^DD",9000 010.11,900 0010.11,26 01,23,3,0)
  15774   of the fil e.
  15775   "^DD",9000 010.11,900 0010.11,27 01,0)
  15776   LOINC CODE S^9000010. 1127A^^27; 0
  15777   "^DD",9000 010.11,900 0010.11,27 01,21,0)
  15778   ^.001^2^2^ 3140829^^
  15779   "^DD",9000 010.11,900 0010.11,27 01,21,1,0)
  15780   This India n Health S ervice fie ld is the  LOINC code s that ide ntifies th is
  15781   "^DD",9000 010.11,900 0010.11,27 01,21,2,0)
  15782   immunizati on, along  with their  descripti ons.
  15783   "^DD",9000 010.11,900 0010.11,27 01,23,0)
  15784   ^.001^3^3^ 3140829^^
  15785   "^DD",9000 010.11,900 0010.11,27 01,23,1,0)
  15786   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  15787   "^DD",9000 010.11,900 0010.11,27 01,23,2,0)
  15788   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  15789   "^DD",9000 010.11,900 0010.11,27 01,23,3,0)
  15790   of the fil e.
  15791   "^DD",9000 010.11,900 0010.11,80 101,0)
  15792   EDITED FLA G^Sa^1:EDI TED;^801;1 ^Q
  15793   "^DD",9000 010.11,900 0010.11,80 101,3)
  15794   Enter 1 if  the origi nal immuni zation dat a is being  edited.
  15795   "^DD",9000 010.11,900 0010.11,80 101,21,0)
  15796   ^.001^2^2^ 3150813^^^
  15797   "^DD",9000 010.11,900 0010.11,80 101,21,1,0 )
  15798   This field  is automa tically se t to 1 if  PCE detect s that any  original
  15799   "^DD",9000 010.11,900 0010.11,80 101,21,2,0 )
  15800   immunizati on data is  being edi ted.
  15801   "^DD",9000 010.11,900 0010.11,80 101,23,0)
  15802   ^.001^2^2^ 3150813^^^
  15803   "^DD",9000 010.11,900 0010.11,80 101,23,1,0 )
  15804   PCE filing  logic aut omatically  compares  the before  and after  pictures  of the
  15805   "^DD",9000 010.11,900 0010.11,80 101,23,2,0 )
  15806   record to  determine  if the edi ted flag s hould be s et to "1".
  15807   "^DD",9000 010.11,900 0010.11,80 101,"AUDIT ")
  15808   y
  15809   "^DD",9000 010.11,900 0010.11,80 101,"DT")
  15810   3150213
  15811   "^DD",9000 010.11,900 0010.11,80 102,0)
  15812   AUDIT TRAI L^Fa^^801; 2^K:$L(X)> 85!($L(X)< 2) X
  15813   "^DD",9000 010.11,900 0010.11,80 102,.1)
  15814   Audit Trai l
  15815   "^DD",9000 010.11,900 0010.11,80 102,3)
  15816   Answer mus t be 2 to  85 charact ers.
  15817   "^DD",9000 010.11,900 0010.11,80 102,21,0)
  15818   ^.001^3^3^ 3150813^^^ ^
  15819   "^DD",9000 010.11,900 0010.11,80 102,21,1,0 )
  15820   This field  is popula ted automa tically by  the PCE f iling logi c.  The fo rmat
  15821   "^DD",9000 010.11,900 0010.11,80 102,21,2,0 )
  15822   of the fie ld is as f ollows:  P ointer to  PCE data s ource file _"-"_A for  Add
  15823   "^DD",9000 010.11,900 0010.11,80 102,21,3,0 )
  15824   or E for E dit_" "_DU Z of the p erson who  entered th e data_";" ...
  15825   "^DD",9000 010.11,900 0010.11,80 102,23,0)
  15826   ^.001^14^1 4^3150813^ ^^^
  15827   "^DD",9000 010.11,900 0010.11,80 102,23,1,0 )
  15828   The PCE fi ling logic  requires  a pointer  to the PCE  data sour ce file.   If this
  15829   "^DD",9000 010.11,900 0010.11,80 102,23,2,0 )
  15830   is not pas sed, the P CE filing  logic will  not proce ss the dat a.
  15831   "^DD",9000 010.11,900 0010.11,80 102,23,3,0 )
  15832  
  15833   "^DD",9000 010.11,900 0010.11,80 102,23,4,0 )
  15834   If the rec ord is a n ew record,  then an " A" is used  to specif y the sour ce that
  15835   "^DD",9000 010.11,900 0010.11,80 102,23,5,0 )
  15836   added the  data.  If  the record  existed p reviously,  PCE filin g logic co mpares
  15837   "^DD",9000 010.11,900 0010.11,80 102,23,6,0 )
  15838   the old an d new reco rds of inf ormation.   An "E" wi ll be auto matically  used if
  15839   "^DD",9000 010.11,900 0010.11,80 102,23,7,0 )
  15840   the filing  logic fin ds the dat a has been  edited.   If "E" is  used, then  the
  15841   "^DD",9000 010.11,900 0010.11,80 102,23,8,0 )
  15842   Edited Fla g field is  automatic ally set t o 1.
  15843   "^DD",9000 010.11,900 0010.11,80 102,23,9,0 )
  15844  
  15845   "^DD",9000 010.11,900 0010.11,80 102,23,10, 0)
  15846   The DUZ is  stored in  its inter nal format  to repres ent the us er who per formed
  15847   "^DD",9000 010.11,900 0010.11,80 102,23,11, 0)
  15848   the adding  or editin g of data  for this r ecord.
  15849   "^DD",9000 010.11,900 0010.11,80 102,23,12, 0)
  15850  
  15851   "^DD",9000 010.11,900 0010.11,80 102,23,13, 0)
  15852   Iterations  of editin g will be  concatenat ed to the  previous d ata source
  15853   "^DD",9000 010.11,900 0010.11,80 102,23,14, 0)
  15854   value, up  to 85 char acters.
  15855   "^DD",9000 010.11,900 0010.11,80 102,"AUDIT ")
  15856   y
  15857   "^DD",9000 010.11,900 0010.11,80 102,"DT")
  15858   3150213
  15859   "^DD",9000 010.11,900 0010.11,81 101,0)
  15860   COMMENTS^F a^^811;1^K :$L(X)>245 !($L(X)<1)  X
  15861   "^DD",9000 010.11,900 0010.11,81 101,3)
  15862   Enter a co mment 1-24 5 characte rs in leng th.
  15863   "^DD",9000 010.11,900 0010.11,81 101,21,0)
  15864   ^^2^2^2950 901^^
  15865   "^DD",9000 010.11,900 0010.11,81 101,21,1,0 )
  15866   This is a  comment re lated to t he patient 's immuniz ation.  Th e provider  may enter
  15867   "^DD",9000 010.11,900 0010.11,81 101,21,2,0 )
  15868   this manua lly via th e PCE User  Interface .
  15869   "^DD",9000 010.11,900 0010.11,81 101,"AUDIT ")
  15870   y
  15871   "^DD",9000 010.11,900 0010.11,81 101,"DT")
  15872   3150213
  15873   "^DD",9000 010.11,900 0010.11,81 201,0)
  15874   VERIFIED^S Ia^1:ELECT RONICALLY  SIGNED;2:V ERIFIED BY  PACKAGE;^ 812;1^Q
  15875   "^DD",9000 010.11,900 0010.11,81 201,3)
  15876   Enter 1 if  verified  by electro nic signat ure or 2 i f verified  by packag e.
  15877   "^DD",9000 010.11,900 0010.11,81 201,21,0)
  15878   ^.001^2^2^ 3150813^^^
  15879   "^DD",9000 010.11,900 0010.11,81 201,21,1,0 )
  15880   This is us ed to note  how the e vent was v erified an d is autom atically
  15881   "^DD",9000 010.11,900 0010.11,81 201,21,2,0 )
  15882   entered by  the softw are.
  15883   "^DD",9000 010.11,900 0010.11,81 201,23,0)
  15884   ^.001^1^1^ 3150813^^^
  15885   "^DD",9000 010.11,900 0010.11,81 201,23,1,0 )
  15886   This is au tomaticall y entered  by the sof tware and  is unedita ble for us ers.
  15887   "^DD",9000 010.11,900 0010.11,81 201,"AUDIT ")
  15888   y
  15889   "^DD",9000 010.11,900 0010.11,81 201,"DT")
  15890   3150213
  15891   "^DD",9000 010.11,900 0010.11,81 202,0)
  15892   PACKAGE^P9 .4'Ia^DIC( 9.4,^812;2 ^Q
  15893   "^DD",9000 010.11,900 0010.11,81 202,.1)
  15894   Package
  15895   "^DD",9000 010.11,900 0010.11,81 202,3)
  15896   Enter the  VistA pack age from w hich this  record ori ginated.
  15897   "^DD",9000 010.11,900 0010.11,81 202,21,0)
  15898   ^^4^4^3150 813^
  15899   "^DD",9000 010.11,900 0010.11,81 202,21,1,0 )
  15900   This is th e VistA pa ckage from  which thi s immuniza tion recor d
  15901   "^DD",9000 010.11,900 0010.11,81 202,21,2,0 )
  15902   originated  through P CE.
  15903   "^DD",9000 010.11,900 0010.11,81 202,21,3,0 )
  15904  
  15905   "^DD",9000 010.11,900 0010.11,81 202,21,4,0 )
  15906   This is au tomaticall y entered  by the sof tware and  uneditable  by users.
  15907   "^DD",9000 010.11,900 0010.11,81 202,"AUDIT ")
  15908   y
  15909   "^DD",9000 010.11,900 0010.11,81 202,"DT")
  15910   3150813
  15911   "^DD",9000 010.11,900 0010.11,81 203,0)
  15912   DATA SOURC E^P839.7'I a^PX(839.7 ,^812;3^Q
  15913   "^DD",9000 010.11,900 0010.11,81 203,3)
  15914   Select the  data sour ce for thi s immuniza tion entry  through P CE.
  15915   "^DD",9000 010.11,900 0010.11,81 203,21,0)
  15916   ^.001^2^2^ 3150213^^^
  15917   "^DD",9000 010.11,900 0010.11,81 203,21,1,0 )
  15918   This is th e data sou rce for th is immuniz ation, aut omatically  entered
  15919   "^DD",9000 010.11,900 0010.11,81 203,21,2,0 )
  15920   through th e PCS soft ware and u neditable  by users.
  15921   "^DD",9000 010.11,900 0010.11,81 203,"AUDIT ")
  15922   y
  15923   "^DD",9000 010.11,900 0010.11,81 203,"DT")
  15924   3150213
  15925   "^DD",9000 010.11,900 0010.1111, 0)
  15926   REMARKS SU B-FIELD^^. 01^1
  15927   "^DD",9000 010.11,900 0010.1111, 0,"NM","RE MARKS")
  15928  
  15929   "^DD",9000 010.11,900 0010.1111, 0,"UP")
  15930   9000010.11
  15931   "^DD",9000 010.11,900 0010.1111, .01,0)
  15932   REMARKS^W^ ^0;1^Q
  15933   "^DD",9000 010.11,900 0010.1111, .01,3)
  15934   Enter comm ents relat ed to the  immunizati on encount er with th e patient.
  15935   "^DD",9000 010.11,900 0010.1111, .01,21,0)
  15936   ^^2^2^2950 901^
  15937   "^DD",9000 010.11,900 0010.1111, .01,21,1,0 )
  15938   This field  can be us ed to ente r comments  related t o the immu nization
  15939   "^DD",9000 010.11,900 0010.1111, .01,21,2,0 )
  15940   encounter  with the p atient.
  15941   "^DD",9000 010.11,900 0010.1111, .01,"DT")
  15942   2861007
  15943   "^DD",9000 010.11,900 0010.112,0 )
  15944   VIS OFFERE D/GIVEN TO  PATIENT S UB-FIELD^^ .02^2
  15945   "^DD",9000 010.11,900 0010.112,0 ,"DT")
  15946   3150827
  15947   "^DD",9000 010.11,900 0010.112,0 ,"IX","B", 9000010.11 2,.01)
  15948  
  15949   "^DD",9000 010.11,900 0010.112,0 ,"IX","D", 9000010.11 2,.02)
  15950  
  15951   "^DD",9000 010.11,900 0010.112,0 ,"NM","VIS  OFFERED/G IVEN TO PA TIENT")
  15952  
  15953   "^DD",9000 010.11,900 0010.112,0 ,"UP")
  15954   9000010.11
  15955   "^DD",9000 010.11,900 0010.112,. 01,0)
  15956   VIS OFFERE D/GIVEN TO  PATIENT^M *P920'a^AU TTIVIS(^0; 1^S DIC("S ")="I $$OF FER^PXVUTI L" D ^DIC  K DIC S DI C=$G(DIE), X=+Y K:Y<0  X
  15957   "^DD",9000 010.11,900 0010.112,. 01,.1)
  15958   VIS Offere d/Given to  the Patie nt
  15959   "^DD",9000 010.11,900 0010.112,. 01,1,0)
  15960   ^.1
  15961   "^DD",9000 010.11,900 0010.112,. 01,1,1,0)
  15962   9000010.11 2^B
  15963   "^DD",9000 010.11,900 0010.112,. 01,1,1,1)
  15964   S ^AUPNVIM M(DA(1),2, "B",$E(X,1 ,30),DA)=" "
  15965   "^DD",9000 010.11,900 0010.112,. 01,1,1,2)
  15966   K ^AUPNVIM M(DA(1),2, "B",$E(X,1 ,30),DA)
  15967   "^DD",9000 010.11,900 0010.112,. 01,2)
  15968   S Y(0)=Y S  Y(0)=Y D  VIS^PXVUTI L
  15969   "^DD",9000 010.11,900 0010.112,. 01,2.1)
  15970   S Y(0)=Y D  VIS^PXVUT IL
  15971   "^DD",9000 010.11,900 0010.112,. 01,3)
  15972   Enter the  VIS offere d /given t o the pati ent.
  15973   "^DD",9000 010.11,900 0010.112,. 01,12)
  15974   Screen all ows select ion of Vac cine Infor mation Sta tements ap propriate  for this i mmunizatio n.
  15975   "^DD",9000 010.11,900 0010.112,. 01,12.1)
  15976   S DIC("S") ="I $$OFFE R^PXVUTIL"
  15977   "^DD",9000 010.11,900 0010.112,. 01,21,0)
  15978   ^.001^2^2^ 3150518^^^ ^
  15979   "^DD",9000 010.11,900 0010.112,. 01,21,1,0)
  15980   This is th e name of  the Vaccin e Informat ion Statem ent offere d to or gi ven
  15981   "^DD",9000 010.11,900 0010.112,. 01,21,2,0)
  15982   to the pat ient befor e administ ration of  the immuni zation.
  15983   "^DD",9000 010.11,900 0010.112,. 01,"AUDIT" )
  15984   y
  15985   "^DD",9000 010.11,900 0010.112,. 01,"AX")
  15986   I $G(DA)>1
  15987   "^DD",9000 010.11,900 0010.112,. 01,"DT")
  15988   3150827
  15989   "^DD",9000 010.11,900 0010.112,. 02,0)
  15990   DATE VIS O FFERED/GIV EN^DXa^^0; 2^S %DT="E XP" D ^%DT  S X=Y K:Y <1 X
  15991   "^DD",9000 010.11,900 0010.112,. 02,.1)
  15992   Date VIS O ffered/Giv en
  15993   "^DD",9000 010.11,900 0010.112,. 02,1,0)
  15994   ^.1
  15995   "^DD",9000 010.11,900 0010.112,. 02,1,1,0)
  15996   9000010.11 2^D
  15997   "^DD",9000 010.11,900 0010.112,. 02,1,1,1)
  15998   S ^AUPNVIM M(DA(1),2, "D",$E(X,1 ,30),DA)=" "
  15999   "^DD",9000 010.11,900 0010.112,. 02,1,1,2)
  16000   K ^AUPNVIM M(DA(1),2, "D",$E(X,1 ,30),DA)
  16001   "^DD",9000 010.11,900 0010.112,. 02,1,1,3)
  16002   USED FOR L OOKUPS
  16003   "^DD",9000 010.11,900 0010.112,. 02,1,1,"%D ",0)
  16004   ^^2^2^3150 220^
  16005   "^DD",9000 010.11,900 0010.112,. 02,1,1,"%D ",1,0)
  16006   This x-ref  is used t o do a (re verse) loo kup for th e latest V IS offered
  16007   "^DD",9000 010.11,900 0010.112,. 02,1,1,"%D ",2,0)
  16008   for this e vent.
  16009   "^DD",9000 010.11,900 0010.112,. 02,1,1,"DT ")
  16010   3150220
  16011   "^DD",9000 010.11,900 0010.112,. 02,3)
  16012   Enter the  date the V IS was off ered/given  to the pa tient.
  16013   "^DD",9000 010.11,900 0010.112,. 02,21,0)
  16014   ^.001^2^2^ 3140507^^
  16015   "^DD",9000 010.11,900 0010.112,. 02,21,1,0)
  16016   This is th e date the  Vaccine I nformation  Statement  was offer ed to or
  16017   "^DD",9000 010.11,900 0010.112,. 02,21,2,0)
  16018   given to t he patient .
  16019   "^DD",9000 010.11,900 0010.112,. 02,"AUDIT" )
  16020   y
  16021   "^DD",9000 010.11,900 0010.112,. 02,"DT")
  16022   3150220
  16023   "^DD",9000 010.11,900 0010.1126, 0)
  16024   SNOMED CT  SUB-FIELD^ ^.019^2
  16025   "^DD",9000 010.11,900 0010.1126, 0,"DT")
  16026   3130222
  16027   "^DD",9000 010.11,900 0010.1126, 0,"IX","B" ,9000010.1 126,.01)
  16028  
  16029   "^DD",9000 010.11,900 0010.1126, 0,"NM","SN OMED CT")
  16030  
  16031   "^DD",9000 010.11,900 0010.1126, 0,"UP")
  16032   9000010.11
  16033   "^DD",9000 010.11,900 0010.1126, .01,0)
  16034   SNOMED CT^ Fa^^0;1^K: $L(X)>30!( $L(X)<1) X
  16035   "^DD",9000 010.11,900 0010.1126, .01,1,0)
  16036   ^.1
  16037   "^DD",9000 010.11,900 0010.1126, .01,1,1,0)
  16038   9000010.11 26^B
  16039   "^DD",9000 010.11,900 0010.1126, .01,1,1,1)
  16040   S ^AUPNVIM M(DA(1),26 ,"B",$E(X, 1,30),DA)= ""
  16041   "^DD",9000 010.11,900 0010.1126, .01,1,1,2)
  16042   K ^AUPNVIM M(DA(1),26 ,"B",$E(X, 1,30),DA)
  16043   "^DD",9000 010.11,900 0010.1126, .01,3)
  16044   Answer mus t be 1-30  characters  in length .
  16045   "^DD",9000 010.11,900 0010.1126, .01,21,0)
  16046   ^^2^2^3140 702^^
  16047   "^DD",9000 010.11,900 0010.1126, .01,21,1,0 )
  16048   This India n Health S ervice fie ld indicat es a SNOME D Clinical  Term (CT)
  16049   "^DD",9000 010.11,900 0010.1126, .01,21,2,0 )
  16050   that descr ibes this  immunizati on.
  16051   "^DD",9000 010.11,900 0010.1126, .01,23,0)
  16052   ^^3^3^3140 701^^
  16053   "^DD",9000 010.11,900 0010.1126, .01,23,1,0 )
  16054   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  16055   "^DD",9000 010.11,900 0010.1126, .01,23,2,0 )
  16056   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  16057   "^DD",9000 010.11,900 0010.1126, .01,23,3,0 )
  16058   of the fil e.
  16059   "^DD",9000 010.11,900 0010.1126, .01,"AUDIT ")
  16060   y
  16061   "^DD",9000 010.11,900 0010.1126, .01,"DT")
  16062   3140702
  16063   "^DD",9000 010.11,900 0010.1126, .019,0)
  16064   SNOMED PRE FERRED TER M^CJ8^^ ;  ^S Y(90000 10.1126,.0 19,1)=$S($ D(^AUPNVIM M(D0,26,D1 ,0)):^(0), 1:"") S X= $P(Y(90000 10.1126,.0 19,1),U,1) ,X=$$CONCP T^AUPNVUTL (X)
  16065   "^DD",9000 010.11,900 0010.1126, .019,9)
  16066   ^
  16067   "^DD",9000 010.11,900 0010.1126, .019,9.01)
  16068   9000010.11 26^.01
  16069   "^DD",9000 010.11,900 0010.1126, .019,9.1)
  16070   AUPNPT(#.0 1)
  16071   "^DD",9000 010.11,900 0010.1126, .019,21,0)
  16072   ^^2^2^3140 702^
  16073   "^DD",9000 010.11,900 0010.1126, .019,21,1, 0)
  16074   This India n Health S ervice fie ld is a pr eferred te rm describ ing the
  16075   "^DD",9000 010.11,900 0010.1126, .019,21,2, 0)
  16076   associated  SNOMED cl inical ter m.
  16077   "^DD",9000 010.11,900 0010.1126, .019,23,0)
  16078   ^^3^3^3140 625^
  16079   "^DD",9000 010.11,900 0010.1126, .019,23,1, 0)
  16080   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  16081   "^DD",9000 010.11,900 0010.1126, .019,23,2, 0)
  16082   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  16083   "^DD",9000 010.11,900 0010.1126, .019,23,3, 0)
  16084   of the fil e.
  16085   "^DD",9000 010.11,900 0010.1126, .019,"DT")
  16086   3140702
  16087   "^DD",9000 010.11,900 0010.1127, 0)
  16088   LOINC CODE S SUB-FIEL D^^.019^2
  16089   "^DD",9000 010.11,900 0010.1127, 0,"DT")
  16090   3130222
  16091   "^DD",9000 010.11,900 0010.1127, 0,"IX","B" ,9000010.1 127,.01)
  16092  
  16093   "^DD",9000 010.11,900 0010.1127, 0,"NM","LO INC CODES" )
  16094  
  16095   "^DD",9000 010.11,900 0010.1127, 0,"UP")
  16096   9000010.11
  16097   "^DD",9000 010.11,900 0010.1127, .01,0)
  16098   LOINC CODE S^Fa^^0;1^ K:$L(X)>30 !($L(X)<1)  X
  16099   "^DD",9000 010.11,900 0010.1127, .01,1,0)
  16100   ^.1
  16101   "^DD",9000 010.11,900 0010.1127, .01,1,1,0)
  16102   9000010.11 27^B
  16103   "^DD",9000 010.11,900 0010.1127, .01,1,1,1)
  16104   S ^AUPNVIM M(DA(1),27 ,"B",$E(X, 1,30),DA)= ""
  16105   "^DD",9000 010.11,900 0010.1127, .01,1,1,2)
  16106   K ^AUPNVIM M(DA(1),27 ,"B",$E(X, 1,30),DA)
  16107   "^DD",9000 010.11,900 0010.1127, .01,3)
  16108   Answer mus t be 1-30  characters  in length .
  16109   "^DD",9000 010.11,900 0010.1127, .01,21,0)
  16110   ^^2^2^3140 702^
  16111   "^DD",9000 010.11,900 0010.1127, .01,21,1,0 )
  16112   This India n Health S ervice fie ld is a LO INC code t hat identi fies this
  16113   "^DD",9000 010.11,900 0010.1127, .01,21,2,0 )
  16114   immunizati on.
  16115   "^DD",9000 010.11,900 0010.1127, .01,23,0)
  16116   ^^3^3^3140 625^
  16117   "^DD",9000 010.11,900 0010.1127, .01,23,1,0 )
  16118   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  16119   "^DD",9000 010.11,900 0010.1127, .01,23,2,0 )
  16120   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  16121   "^DD",9000 010.11,900 0010.1127, .01,23,3,0 )
  16122   of the fil e.
  16123   "^DD",9000 010.11,900 0010.1127, .01,"AUDIT ")
  16124   y
  16125   "^DD",9000 010.11,900 0010.1127, .01,"DT")
  16126   3140702
  16127   "^DD",9000 010.11,900 0010.1127, .019,0)
  16128   LOINC TEXT ^CJ8^^ ; ^ S Y(900001 0.1127,.01 9,1)=$S($D (^AUPNVIMM (D0,27,D1, 0)):^(0),1 :"") S X=$ P(Y(900001 0.1127,.01 9,1),U,1), X=$$LOINCP T^AUPNVUTL (X)
  16129   "^DD",9000 010.11,900 0010.1127, .019,9)
  16130   ^
  16131   "^DD",9000 010.11,900 0010.1127, .019,9.01)
  16132   9000010.11 27^.01
  16133   "^DD",9000 010.11,900 0010.1127, .019,9.1)
  16134   AUPNLOINCP T(#.01)
  16135   "^DD",9000 010.11,900 0010.1127, .019,21,0)
  16136   ^^2^2^3140 702^
  16137   "^DD",9000 010.11,900 0010.1127, .019,21,1, 0)
  16138   This India n Health S ervice fie ld is LOIN C text des cribing th e associat ed
  16139   "^DD",9000 010.11,900 0010.1127, .019,21,2, 0)
  16140   LOINC code .
  16141   "^DD",9000 010.11,900 0010.1127, .019,23,0)
  16142   ^^3^3^3140 625^
  16143   "^DD",9000 010.11,900 0010.1127, .019,23,1, 0)
  16144   This field  is not us ed by the  Department  of Vetera ns Affairs .   It is
  16145   "^DD",9000 010.11,900 0010.1127, .019,23,2, 0)
  16146   included f or backwar d compatib ility with  the India n Health S ervice ver sion
  16147   "^DD",9000 010.11,900 0010.1127, .019,23,3, 0)
  16148   of the fil e.
  16149   "^DD",9000 010.11,900 0010.1127, .019,"DT")
  16150   3140702
  16151   "^DD",9000 010.11,900 0010.113,0 )
  16152   OTHER DIAG NOSIS SUB- FIELD^^.01 ^1
  16153   "^DD",9000 010.11,900 0010.113,0 ,"DT")
  16154   3140701
  16155   "^DD",9000 010.11,900 0010.113,0 ,"IX","B", 9000010.11 3,.01)
  16156  
  16157   "^DD",9000 010.11,900 0010.113,0 ,"NM","OTH ER DIAGNOS IS")
  16158  
  16159   "^DD",9000 010.11,900 0010.113,0 ,"UP")
  16160   9000010.11
  16161   "^DD",9000 010.11,900 0010.113,. 01,0)
  16162   OTHER DIAG NOSIS^M*P8 0'aX^ICD9( ^0;1^S DIC ("S")="D R SETDA^PXVU TIL" D ^DI C K DIC S  DIC=$G(DIE ),X=+Y K:Y <0 X
  16163   "^DD",9000 010.11,900 0010.113,. 01,.1)
  16164   Other Diag nosis
  16165   "^DD",9000 010.11,900 0010.113,. 01,1,0)
  16166   ^.1
  16167   "^DD",9000 010.11,900 0010.113,. 01,1,1,0)
  16168   9000010.11 3^B
  16169   "^DD",9000 010.11,900 0010.113,. 01,1,1,1)
  16170   S ^AUPNVIM M(DA(1),3, "B",$E(X,1 ,30),DA)=" "
  16171   "^DD",9000 010.11,900 0010.113,. 01,1,1,2)
  16172   K ^AUPNVIM M(DA(1),3, "B",$E(X,1 ,30),DA)
  16173   "^DD",9000 010.11,900 0010.113,. 01,3)
  16174   Select a d iagnosis f or this im munization  event.
  16175   "^DD",9000 010.11,900 0010.113,. 01,12)
  16176   Selection  must be ap propriate  and active .
  16177   "^DD",9000 010.11,900 0010.113,. 01,12.1)
  16178   S DIC("S") ="D RSETDA ^PXVUTIL"
  16179   "^DD",9000 010.11,900 0010.113,. 01,21,0)
  16180   ^.001^3^3^ 3140620^^
  16181   "^DD",9000 010.11,900 0010.113,. 01,21,1,0)
  16182   This is a  diagnosis  for this i mmunizatio n event, i n addition  to the
  16183   "^DD",9000 010.11,900 0010.113,. 01,21,2,0)
  16184   PRIMARY DI AGNOSIS.   A primary  diagnosis  should be  selected b efore
  16185   "^DD",9000 010.11,900 0010.113,. 01,21,3,0)
  16186   selecting  one here.
  16187   "^DD",9000 010.11,900 0010.113,. 01,23,0)
  16188   ^^3^3^3140 620^
  16189   "^DD",9000 010.11,900 0010.113,. 01,23,1,0)
  16190   This is a  diagnosis  for this i mmunizatio n event.   It is in a ddition to  the
  16191   "^DD",9000 010.11,900 0010.113,. 01,23,2,0)
  16192   PRIMARY DI AGNOSIS fo r this eve nt.  This  diagnosis  is selecte d from the
  16193   "^DD",9000 010.11,900 0010.113,. 01,23,3,0)
  16194   ICD DIAGNO SIS file ( #80).
  16195   "^DD",9000 010.11,900 0010.113,. 01,"AUDIT" )
  16196   y
  16197   "^DD",9000 010.11,900 0010.113,. 01,"AX")
  16198  
  16199   "^DD",9000 010.11,900 0010.113,. 01,"DT")
  16200   3140821
  16201   "^DD",9000 010.12,900 0010.12,0)
  16202   FIELD^^808 ^29
  16203   "^DD",9000 010.12,900 0010.12,0, "DDA")
  16204   N
  16205   "^DD",9000 010.12,900 0010.12,0, "DT")
  16206   3150813
  16207   "^DD",9000 010.12,900 0010.12,0, "ID",.02)
  16208   W "   ",$S ($D(^DPT(+ $P(^(0),U, 2),0))#2:$ P(^(0),U,1 ),1:""),@( "$E("_DIC_ "Y,0),0)")
  16209   "^DD",9000 010.12,900 0010.12,0, "ID",.03)
  16210   W "   " S  AIHSY=Y,Y= $S($D(^AUP NVSIT(+$P( ^(0),U,3), 0))#2:$P(^ (0),U,1),1 :"") X:Y ^ DD("DD") W  Y S Y=AIH SY K AIHSY  W @("$E(" _DIC_"Y,0) ,0)")
  16211   "^DD",9000 010.12,900 0010.12,0, "IX","AA", 9000010.12 ,.03)
  16212  
  16213   "^DD",9000 010.12,900 0010.12,0, "IX","AATO O",9000010 .12,.01)
  16214  
  16215   "^DD",9000 010.12,900 0010.12,0, "IX","AATO O2",900001 0.12,.02)
  16216  
  16217   "^DD",9000 010.12,900 0010.12,0, "IX","AD", 9000010.12 ,.03)
  16218  
  16219   "^DD",9000 010.12,900 0010.12,0, "IX","AE", 9000010.12 ,.05)
  16220  
  16221   "^DD",9000 010.12,900 0010.12,0, "IX","AV10 ",9000010. 12,.03)
  16222  
  16223   "^DD",9000 010.12,900 0010.12,0, "IX","B",9 000010.12, .01)
  16224  
  16225   "^DD",9000 010.12,900 0010.12,0, "IX","C",9 000010.12, .02)
  16226  
  16227   "^DD",9000 010.12,900 0010.12,0, "NM","V SK IN TEST")
  16228  
  16229   "^DD",9000 010.12,900 0010.12,0, "VRPK")
  16230   PX
  16231   "^DD",9000 010.12,900 0010.12,.0 1,0)
  16232   SKIN TEST^ R*P9999999 .28'a^AUTT SK(^0;1^S  DIC("S")=" I $P(^(0), U,3)'=1" D  ^DIC K DI C S DIC=DI E,X=+Y K:Y <0 X
  16233   "^DD",9000 010.12,900 0010.12,.0 1,1,0)
  16234   ^.1^^-1
  16235   "^DD",9000 010.12,900 0010.12,.0 1,1,1,0)
  16236   9000010.12 ^B
  16237   "^DD",9000 010.12,900 0010.12,.0 1,1,1,1)
  16238   S ^AUPNVSK ("B",$E(X, 1,30),DA)= ""
  16239   "^DD",9000 010.12,900 0010.12,.0 1,1,1,2)
  16240   K ^AUPNVSK ("B",$E(X, 1,30),DA)
  16241   "^DD",9000 010.12,900 0010.12,.0 1,1,3,0)
  16242   9000010.12 ^AATOO^MUM PS
  16243   "^DD",9000 010.12,900 0010.12,.0 1,1,3,1)
  16244   I $P(^AUPN VSK(DA,0), U,2)]"",$P (^(0),U,3) ]"" S ^AUP NVSK("AA", $P(^AUPNVS K(DA,0),U, 2),X,(9999 999-$P(+^A UPNVSIT($P (^AUPNVSK( DA,0),U,3) ,0),".",1) ),DA)=""
  16245   "^DD",9000 010.12,900 0010.12,.0 1,1,3,2)
  16246   I $P(^AUPN VSK(DA,0), U,2)]"",$P (^(0),U,3) ]"" K ^AUP NVSK("AA", $P(^AUPNVS K(DA,0),U, 2),X,(9999 999-$P(+^A UPNVSIT($P (^AUPNVSK( DA,0),U,3) ,0),".",1) ),DA)
  16247   "^DD",9000 010.12,900 0010.12,.0 1,1,3,"%D" ,0)
  16248   ^^4^4^2950 901^
  16249   "^DD",9000 010.12,900 0010.12,.0 1,1,3,"%D" ,1,0)
  16250   This cross  reference  is used f or searche s in seque nce by pat ient, Skin
  16251   "^DD",9000 010.12,900 0010.12,.0 1,1,3,"%D" ,2,0)
  16252   test point er, invert ed Visit d ate, and i nternal en try number .
  16253   "^DD",9000 010.12,900 0010.12,.0 1,1,3,"%D" ,3,0)
  16254  
  16255   "^DD",9000 010.12,900 0010.12,.0 1,1,3,"%D" ,4,0)
  16256       "AA",P ATIENT,SKI N TEST,VIS IT,DA
  16257   "^DD",9000 010.12,900 0010.12,.0 1,3)
  16258   Enter the  Skin Test  that was g iven to th e patient.
  16259   "^DD",9000 010.12,900 0010.12,.0 1,12)
  16260   Allow only  active Sk in Test ty pes to be  selected.
  16261   "^DD",9000 010.12,900 0010.12,.0 1,12.1)
  16262   S DIC("S") ="I $P(^(0 ),U,3)'=1"
  16263   "^DD",9000 010.12,900 0010.12,.0 1,21,0)
  16264   ^.001^2^2^ 3150421^^^ ^
  16265   "^DD",9000 010.12,900 0010.12,.0 1,21,1,0)
  16266   This is th e type of  Skin Test  that was g iven to th e patient  at the
  16267   "^DD",9000 010.12,900 0010.12,.0 1,21,2,0)
  16268   encounter.
  16269   "^DD",9000 010.12,900 0010.12,.0 1,23,0)
  16270   ^.001^2^2^ 3150421^^^ ^
  16271   "^DD",9000 010.12,900 0010.12,.0 1,23,1,0)
  16272   Only activ e Skin Tes t entries  in the Ski n Test Fil e (#999999 9.28) are
  16273   "^DD",9000 010.12,900 0010.12,.0 1,23,2,0)
  16274    selectabl e.
  16275   "^DD",9000 010.12,900 0010.12,.0 1,"AUDIT")
  16276   y
  16277   "^DD",9000 010.12,900 0010.12,.0 1,"DT")
  16278   3150421
  16279   "^DD",9000 010.12,900 0010.12,.0 2,0)
  16280   PATIENT NA ME^RP90000 01'Ia^AUPN PAT(^0;2^Q
  16281   "^DD",9000 010.12,900 0010.12,.0 2,1,0)
  16282   ^.1
  16283   "^DD",9000 010.12,900 0010.12,.0 2,1,2,0)
  16284   9000010.12 ^AATOO2^MU MPS
  16285   "^DD",9000 010.12,900 0010.12,.0 2,1,2,1)
  16286   I $P(^AUPN VSK(DA,0), U,3)]"" S  ^AUPNVSK(" AA",X,+^AU PNVSK(DA,0 ),(9999999 -$P(+^AUPN VSIT($P(^A UPNVSK(DA, 0),U,3),0) ,".",1)),D A)=""
  16287   "^DD",9000 010.12,900 0010.12,.0 2,1,2,2)
  16288   I $P(^AUPN VSK(DA,0), U,3)]"" K  ^AUPNVSK(" AA",X,+^AU PNVSK(DA,0 ),(9999999 -$P(+^AUPN VSIT($P(^A UPNVSK(DA, 0),U,3),0) ,".",1)),D A)
  16289   "^DD",9000 010.12,900 0010.12,.0 2,1,2,"%D" ,0)
  16290   ^^4^4^2950 901^
  16291   "^DD",9000 010.12,900 0010.12,.0 2,1,2,"%D" ,1,0)
  16292   This cross  reference  is used t o search i n sequence  by patien t, skin te st
  16293   "^DD",9000 010.12,900 0010.12,.0 2,1,2,"%D" ,2,0)
  16294   pointer, i nverted vi sit date,  and intern al entry n umber.
  16295   "^DD",9000 010.12,900 0010.12,.0 2,1,2,"%D" ,3,0)
  16296  
  16297   "^DD",9000 010.12,900 0010.12,.0 2,1,2,"%D" ,4,0)
  16298     "AA",PAT IENT,SKIN  TEST,VISIT ,DA
  16299   "^DD",9000 010.12,900 0010.12,.0 2,1,3,0)
  16300   9000010.12 ^C
  16301   "^DD",9000 010.12,900 0010.12,.0 2,1,3,1)
  16302   S ^AUPNVSK ("C",$E(X, 1,30),DA)= ""
  16303   "^DD",9000 010.12,900 0010.12,.0 2,1,3,2)
  16304   K ^AUPNVSK ("C",$E(X, 1,30),DA)
  16305   "^DD",9000 010.12,900 0010.12,.0 2,1,3,"%D" ,0)
  16306   ^^1^1^2950 901^
  16307   "^DD",9000 010.12,900 0010.12,.0 2,1,3,"%D" ,1,0)
  16308   This cross  reference  allows lo ok-up by p atient nam e.
  16309   "^DD",9000 010.12,900 0010.12,.0 2,1,3,"DT" )
  16310   2950901
  16311   "^DD",9000 010.12,900 0010.12,.0 2,3)
  16312   Enter the  patient wh o was give n the skin  test.
  16313   "^DD",9000 010.12,900 0010.12,.0 2,21,0)
  16314   ^^1^1^2950 901^
  16315   "^DD",9000 010.12,900 0010.12,.0 2,21,1,0)
  16316   This is th e patient  who receiv ed the ski n test.
  16317   "^DD",9000 010.12,900 0010.12,.0 2,23,0)
  16318   ^^3^3^2950 901^
  16319   "^DD",9000 010.12,900 0010.12,.0 2,23,1,0)
  16320   This is a  pointer to  the Patie nt/IHS fil e (#900000 1) which i s dinumed  to
  16321   "^DD",9000 010.12,900 0010.12,.0 2,23,2,0)
  16322   the Patien t File (#2 ).  This f ield is al ways stuff ed by the  applicatio n.
  16323   "^DD",9000 010.12,900 0010.12,.0 2,23,3,0)
  16324   No editing  is allowe d.
  16325   "^DD",9000 010.12,900 0010.12,.0 2,"AUDIT")
  16326   y
  16327   "^DD",9000 010.12,900 0010.12,.0 2,"DT")
  16328   3150213
  16329   "^DD",9000 010.12,900 0010.12,.0 3,0)
  16330   VISIT^R*P9 000010'Ia^ AUPNVSIT(^ 0;3^S DIC( "S")="I $P (^(0),U,5) =$P(^AUPNV SK(DA,0),U ,2)" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  16331   "^DD",9000 010.12,900 0010.12,.0 3,1,0)
  16332   ^.1
  16333   "^DD",9000 010.12,900 0010.12,.0 3,1,1,0)
  16334   9000010.12 ^AD
  16335   "^DD",9000 010.12,900 0010.12,.0 3,1,1,1)
  16336   S ^AUPNVSK ("AD",$E(X ,1,30),DA) =""
  16337   "^DD",9000 010.12,900 0010.12,.0 3,1,1,2)
  16338   K ^AUPNVSK ("AD",$E(X ,1,30),DA)
  16339   "^DD",9000 010.12,900 0010.12,.0 3,1,1,"%D" ,0)
  16340   ^^1^1^2950 901^
  16341   "^DD",9000 010.12,900 0010.12,.0 3,1,1,"%D" ,1,0)
  16342   This cross  reference  allows lo ok-up of e ntries by  patient na me.
  16343   "^DD",9000 010.12,900 0010.12,.0 3,1,2,0)
  16344   9000010.12 ^AA^MUMPS
  16345   "^DD",9000 010.12,900 0010.12,.0 3,1,2,1)
  16346   Q:$P(^AUPN VSK(DA,0), U,2)=""  S  ^AUPNVSK( "AA",$P(^A UPNVSK(DA, 0),U,2),+^ AUPNVSK(DA ,0),(99999 99-$P(+^AU PNVSIT(X,0 ),".",1)), DA)=""
  16347   "^DD",9000 010.12,900 0010.12,.0 3,1,2,2)
  16348   Q:$P(^AUPN VSK(DA,0), U,2)=""  K  ^AUPNVSK( "AA",$P(^A UPNVSK(DA, 0),U,2),+^ AUPNVSK(DA ,0),(99999 99-$P(+^AU PNVSIT(X,0 ),".",1)), DA)
  16349   "^DD",9000 010.12,900 0010.12,.0 3,1,2,"%D" ,0)
  16350   ^^4^4^2950 901^
  16351   "^DD",9000 010.12,900 0010.12,.0 3,1,2,"%D" ,1,0)
  16352   This cross  reference  is used f or searche s in seque nce by pat ient, skin
  16353   "^DD",9000 010.12,900 0010.12,.0 3,1,2,"%D" ,2,0)
  16354   test point er, invert ed visit d ate, and i nternal en try number .
  16355   "^DD",9000 010.12,900 0010.12,.0 3,1,2,"%D" ,3,0)
  16356  
  16357   "^DD",9000 010.12,900 0010.12,.0 3,1,2,"%D" ,4,0)
  16358       "AA",P ATIENT,SKI N TEST,VIS IT,DA
  16359   "^DD",9000 010.12,900 0010.12,.0 3,1,3,0)
  16360   9000010.12 ^AV10^MUMP S
  16361   "^DD",9000 010.12,900 0010.12,.0 3,1,3,1)
  16362   D ADD^AUPN VSIT
  16363   "^DD",9000 010.12,900 0010.12,.0 3,1,3,2)
  16364   D SUB^AUPN VSIT
  16365   "^DD",9000 010.12,900 0010.12,.0 3,1,3,"%D" ,0)
  16366   ^^2^2^2940 127^
  16367   "^DD",9000 010.12,900 0010.12,.0 3,1,3,"%D" ,1,0)
  16368   This cross -reference  is for ad ding and s ubtracting  from the  dependent
  16369   "^DD",9000 010.12,900 0010.12,.0 3,1,3,"%D" ,2,0)
  16370   entry coun t in the V ISIT file.
  16371   "^DD",9000 010.12,900 0010.12,.0 3,3)
  16372   Enter the  visit date /time for  the encoun ter where  the skin t est was do ne.
  16373   "^DD",9000 010.12,900 0010.12,.0 3,12)
  16374   VISIT MUST  BE FOR CU RRENT PATI ENT
  16375   "^DD",9000 010.12,900 0010.12,.0 3,12.1)
  16376   S DIC("S") ="I $P(^(0 ),U,5)=$P( ^AUPNVSK(D A,0),U,2)"
  16377   "^DD",9000 010.12,900 0010.12,.0 3,21,0)
  16378   ^^2^2^2950 901^
  16379   "^DD",9000 010.12,900 0010.12,.0 3,21,1,0)
  16380   This is th e encounte r defined  in the Vis it file th at represe nts when a nd
  16381   "^DD",9000 010.12,900 0010.12,.0 3,21,2,0)
  16382   where the  skin test  was done.
  16383   "^DD",9000 010.12,900 0010.12,.0 3,23,0)
  16384   ^^2^2^2950 901^
  16385   "^DD",9000 010.12,900 0010.12,.0 3,23,1,0)
  16386   This is a  pointer to  the Visit  File (#90 00010).  T his field  is stuffed  by
  16387   "^DD",9000 010.12,900 0010.12,.0 3,23,2,0)
  16388   the applic ations.  N o editing  is allowed .
  16389   "^DD",9000 010.12,900 0010.12,.0 3,"AUDIT")
  16390   y
  16391   "^DD",9000 010.12,900 0010.12,.0 3,"DT")
  16392   3150213
  16393   "^DD",9000 010.12,900 0010.12,.0 4,0)
  16394   RESULTS^SX a^P:POSITI VE;N:NEGAT IVE;D:DOUB TFUL;O:NO  TAKE;^0;4^ I X="N",$P (^AUPNVSK( DA,0),U,5) ]"",$P(^AU PNVSK(DA,0 ),U,5)>10  K X
  16395   "^DD",9000 010.12,900 0010.12,.0 4,.1)
  16396   Test Inter pretation
  16397   "^DD",9000 010.12,900 0010.12,.0 4,1,0)
  16398   ^.1^^0
  16399   "^DD",9000 010.12,900 0010.12,.0 4,3)
  16400   Enter whet her the re sults were  positive,  negative,  doubtful  or no take , if known .
  16401   "^DD",9000 010.12,900 0010.12,.0 4,10)
  16402   082/SKREST
  16403   "^DD",9000 010.12,900 0010.12,.0 4,21,0)
  16404   ^^1^1^3150 126^
  16405   "^DD",9000 010.12,900 0010.12,.0 4,21,1,0)
  16406   This is th e interpre tation of  skin test  results.
  16407   "^DD",9000 010.12,900 0010.12,.0 4,"AUDIT")
  16408   y
  16409   "^DD",9000 010.12,900 0010.12,.0 4,"DT")
  16410   3150213
  16411   "^DD",9000 010.12,900 0010.12,.0 5,0)
  16412   READING^NJ 2,0Xa^^0;5 ^K:+X'=X!( X>40)!(X<0 )!(X?.E1". "1N.N) X
  16413   "^DD",9000 010.12,900 0010.12,.0 5,.1)
  16414   Reading in  Millimete rs (mm)
  16415   "^DD",9000 010.12,900 0010.12,.0 5,1,0)
  16416   ^.1^^-1
  16417   "^DD",9000 010.12,900 0010.12,.0 5,1,2,0)
  16418   9000010.12 ^AE
  16419   "^DD",9000 010.12,900 0010.12,.0 5,1,2,1)
  16420   S ^AUPNVSK ("AE",$E(X ,1,30),DA) =""
  16421   "^DD",9000 010.12,900 0010.12,.0 5,1,2,2)
  16422   K ^AUPNVSK ("AE",$E(X ,1,30),DA)
  16423   "^DD",9000 010.12,900 0010.12,.0 5,1,2,"%D" ,0)
  16424   ^^4^4^2950 901^
  16425   "^DD",9000 010.12,900 0010.12,.0 5,1,2,"%D" ,1,0)
  16426   This cross -reference  searches  on the res ults of sk in tests a cross all
  16427   "^DD",9000 010.12,900 0010.12,.0 5,1,2,"%D" ,2,0)
  16428   patients.
  16429   "^DD",9000 010.12,900 0010.12,.0 5,1,2,"%D" ,3,0)
  16430  
  16431   "^DD",9000 010.12,900 0010.12,.0 5,1,2,"%D" ,4,0)
  16432      "AE",RE ADING,DA
  16433   "^DD",9000 010.12,900 0010.12,.0 5,3)
  16434   Enter a wh ole number  between 0  and 40.
  16435   "^DD",9000 010.12,900 0010.12,.0 5,10)
  16436   082/SKREAD
  16437   "^DD",9000 010.12,900 0010.12,.0 5,21,0)
  16438   ^.001^1^1^ 3150126^^^
  16439   "^DD",9000 010.12,900 0010.12,.0 5,21,1,0)
  16440   This is th e indurati on in mill imeters (m m).
  16441   "^DD",9000 010.12,900 0010.12,.0 5,"AUDIT")
  16442   y
  16443   "^DD",9000 010.12,900 0010.12,.0 5,"DT")
  16444   3150213
  16445   "^DD",9000 010.12,900 0010.12,.0 6,0)
  16446   DATE READ^ DXa^^0;6^S  %DT="ET"  D ^%DT S X =Y K:Y<1!$ $TIME^PXVU TL X
  16447   "^DD",9000 010.12,900 0010.12,.0 6,.1)
  16448   Reading Da te/Time
  16449   "^DD",9000 010.12,900 0010.12,.0 6,1,0)
  16450   ^.1^^-1
  16451   "^DD",9000 010.12,900 0010.12,.0 6,1,1,0)
  16452   ^^TRIGGER^ 9000010.12 ^1220
  16453   "^DD",9000 010.12,900 0010.12,.0 6,1,1,1)
  16454   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVS K(D0,12)): ^(12),1:"" ) S X=$P(Y (1),U,20), X=X S DIU= X K Y S X= DIV N %I,% H,% D NOW^ %DTC S X=%  X ^DD(900 0010.12,.0 6,1,1,1.4)
  16455   "^DD",9000 010.12,900 0010.12,.0 6,1,1,1.4)
  16456   S DIH=$G(^ AUPNVSK(DI V(0),12)), DIV=X S $P (^(12),U,2 0)=DIV,DIH =9000010.1 2,DIG=1220  D ^DICR
  16457   "^DD",9000 010.12,900 0010.12,.0 6,1,1,2)
  16458   Q
  16459   "^DD",9000 010.12,900 0010.12,.0 6,1,1,"%D" ,0)
  16460   ^^2^2^3150 728^
  16461   "^DD",9000 010.12,900 0010.12,.0 6,1,1,"%D" ,1,0)
  16462   This trigg er sets th e SKIN TES T READING  RECORDED f ield (#122 0) when th e
  16463   "^DD",9000 010.12,900 0010.12,.0 6,1,1,"%D" ,2,0)
  16464   DATE READ  is entered .
  16465   "^DD",9000 010.12,900 0010.12,.0 6,1,1,"CRE ATE VALUE" )
  16466   NOW
  16467   "^DD",9000 010.12,900 0010.12,.0 6,1,1,"DEL ETE VALUE" )
  16468   NO EFFECT
  16469   "^DD",9000 010.12,900 0010.12,.0 6,1,1,"DT" )
  16470   3150728
  16471   "^DD",9000 010.12,900 0010.12,.0 6,1,1,"FIE LD")
  16472   SKIN TEST  READING RE CORDED
  16473   "^DD",9000 010.12,900 0010.12,.0 6,3)
  16474   Enter the  date and ( optional)  time the s kin test w as read.
  16475   "^DD",9000 010.12,900 0010.12,.0 6,21,0)
  16476   ^^2^2^3150 820^
  16477   "^DD",9000 010.12,900 0010.12,.0 6,21,1,0)
  16478   This is th e date and  time of t he reading  of the sk in test. T ime entry  is
  16479   "^DD",9000 010.12,900 0010.12,.0 6,21,2,0)
  16480   optional a nd impreci se date is  allowed f or histori cal skin t ests.
  16481   "^DD",9000 010.12,900 0010.12,.0 6,"AUDIT")
  16482   y
  16483   "^DD",9000 010.12,900 0010.12,.0 6,"DT")
  16484   3150820
  16485   "^DD",9000 010.12,900 0010.12,.0 7,0)
  16486   READER^P20 0'a^VA(200 ,^0;7^Q
  16487   "^DD",9000 010.12,900 0010.12,.0 7,3)
  16488   Enter the  name of th e person w ho read th e skin tes t.
  16489   "^DD",9000 010.12,900 0010.12,.0 7,21,0)
  16490   ^^2^2^3141 216^
  16491   "^DD",9000 010.12,900 0010.12,.0 7,21,1,0)
  16492   This is th e name of  the person  who read  and interp reted the  results of
  16493   "^DD",9000 010.12,900 0010.12,.0 7,21,2,0)
  16494   the skin t est.
  16495   "^DD",9000 010.12,900 0010.12,.0 7,"AUDIT")
  16496   y
  16497   "^DD",9000 010.12,900 0010.12,.0 7,"DT")
  16498   3150213
  16499   "^DD",9000 010.12,900 0010.12,80 1,0)
  16500   PRIMARY DI AGNOSIS^*P 80'a^ICD9( ^80;1^S DI C("S")="D  ^AUPNSICD"  D ^DIC K  DIC S DIC= DIE,X=+Y K :Y<0 X
  16501   "^DD",9000 010.12,900 0010.12,80 1,.1)
  16502   Primary Di agnosis
  16503   "^DD",9000 010.12,900 0010.12,80 1,3)
  16504   Enter the  primary di agnosis co de associa ted with t his skin t est.
  16505   "^DD",9000 010.12,900 0010.12,80 1,12)
  16506   Diagnosis  cannot be  an inactiv e code and  it must b e appropri ate.
  16507   "^DD",9000 010.12,900 0010.12,80 1,12.1)
  16508   S DIC("S") ="D ^AUPNS ICD"
  16509   "^DD",9000 010.12,900 0010.12,80 1,21,0)
  16510   ^.001^2^2^ 3150730^^^ ^
  16511   "^DD",9000 010.12,900 0010.12,80 1,21,1,0)
  16512   This is th e diagnosi s from the  ICD Diagn osis file  associated  with the
  16513   "^DD",9000 010.12,900 0010.12,80 1,21,2,0)
  16514   skin test  performed.
  16515   "^DD",9000 010.12,900 0010.12,80 1,"AUDIT")
  16516   y
  16517   "^DD",9000 010.12,900 0010.12,80 1,"DT")
  16518   3150730
  16519   "^DD",9000 010.12,900 0010.12,80 2,0)
  16520   DIAGNOSIS  2^*P80'a^I CD9(^80;2^ S DIC("S") ="D ^AUPNS ICD" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  16521   "^DD",9000 010.12,900 0010.12,80 2,.1)
  16522   Diagnosis  2
  16523   "^DD",9000 010.12,900 0010.12,80 2,3)
  16524   Enter the  ICD Diagno sis relate d to the s kin test p erformed.
  16525   "^DD",9000 010.12,900 0010.12,80 2,12)
  16526   Diagnosis  cannot be  an inactiv e code and  it must b e appropri ate.
  16527   "^DD",9000 010.12,900 0010.12,80 2,12.1)
  16528   S DIC("S") ="D ^AUPNS ICD"
  16529   "^DD",9000 010.12,900 0010.12,80 2,21,0)
  16530   ^.001^2^2^ 3150729^^
  16531   "^DD",9000 010.12,900 0010.12,80 2,21,1,0)
  16532   This is th e diagnosi s from the  ICD Diagn osis file  associated  with the
  16533   "^DD",9000 010.12,900 0010.12,80 2,21,2,0)
  16534   skin test  performed.
  16535   "^DD",9000 010.12,900 0010.12,80 2,"AUDIT")
  16536   y
  16537   "^DD",9000 010.12,900 0010.12,80 2,"DT")
  16538   3150729
  16539   "^DD",9000 010.12,900 0010.12,80 3,0)
  16540   DIAGNOSIS  3^*P80'a^I CD9(^80;3^ S DIC("S") ="D ^AUPNS ICD" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  16541   "^DD",9000 010.12,900 0010.12,80 3,.1)
  16542   Diagnosis  3
  16543   "^DD",9000 010.12,900 0010.12,80 3,3)
  16544   Enter the  ICD Diagno sis relate d to the s kin test p erformed.
  16545   "^DD",9000 010.12,900 0010.12,80 3,12)
  16546   Diagnosis  cannot be  an inactiv e code and  it must b e appropri ate.
  16547   "^DD",9000 010.12,900 0010.12,80 3,12.1)
  16548   S DIC("S") ="D ^AUPNS ICD"
  16549   "^DD",9000 010.12,900 0010.12,80 3,21,0)
  16550   ^^2^2^3150 729^
  16551   "^DD",9000 010.12,900 0010.12,80 3,21,1,0)
  16552   This is th e diagnosi s from the  ICD Diagn osis file  associated  with the
  16553   "^DD",9000 010.12,900 0010.12,80 3,21,2,0)
  16554   skin test  performed.
  16555   "^DD",9000 010.12,900 0010.12,80 3,"AUDIT")
  16556   y
  16557   "^DD",9000 010.12,900 0010.12,80 3,"DT")
  16558   3150729
  16559   "^DD",9000 010.12,900 0010.12,80 4,0)
  16560   DIAGNOSIS  4^*P80'a^I CD9(^80;4^ S DIC("S") ="D ^AUPNS ICD" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  16561   "^DD",9000 010.12,900 0010.12,80 4,.1)
  16562   Diagnosis  4
  16563   "^DD",9000 010.12,900 0010.12,80 4,3)
  16564   Enter the  ICD Diagno sis relate d to the s kin test p erformed.
  16565   "^DD",9000 010.12,900 0010.12,80 4,12)
  16566   Diagnosis  cannot be  an inactiv e code and  it must b e appropri ate.
  16567   "^DD",9000 010.12,900 0010.12,80 4,12.1)
  16568   S DIC("S") ="D ^AUPNS ICD"
  16569   "^DD",9000 010.12,900 0010.12,80 4,21,0)
  16570   ^^2^2^3150 729^
  16571   "^DD",9000 010.12,900 0010.12,80 4,21,1,0)
  16572   This is th e diagnosi s from the  ICD Diagn osis file  associated  with the
  16573   "^DD",9000 010.12,900 0010.12,80 4,21,2,0)
  16574   skin test  performed.
  16575   "^DD",9000 010.12,900 0010.12,80 4,"AUDIT")
  16576   y
  16577   "^DD",9000 010.12,900 0010.12,80 4,"DT")
  16578   3150729
  16579   "^DD",9000 010.12,900 0010.12,80 5,0)
  16580   DIAGNOSIS  5^*P80'a^I CD9(^80;5^ S DIC("S") ="D ^AUPNS ICD" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  16581   "^DD",9000 010.12,900 0010.12,80 5,.1)
  16582   Diagnosis  5
  16583   "^DD",9000 010.12,900 0010.12,80 5,3)
  16584   Enter the  ICD Diagno sis relate d to the s kin test p erformed.
  16585   "^DD",9000 010.12,900 0010.12,80 5,12)
  16586   Diagnosis  cannot be  an inactiv e code and  it must b e appropri ate.
  16587   "^DD",9000 010.12,900 0010.12,80 5,12.1)
  16588   S DIC("S") ="D ^AUPNS ICD"
  16589   "^DD",9000 010.12,900 0010.12,80 5,21,0)
  16590   ^^2^2^3150 729^
  16591   "^DD",9000 010.12,900 0010.12,80 5,21,1,0)
  16592   This is th e diagnosi s from the  ICD Diagn osis file  associated  with the
  16593   "^DD",9000 010.12,900 0010.12,80 5,21,2,0)
  16594   skin test  performed.
  16595   "^DD",9000 010.12,900 0010.12,80 5,"AUDIT")
  16596   y
  16597   "^DD",9000 010.12,900 0010.12,80 5,"DT")
  16598   3150729
  16599   "^DD",9000 010.12,900 0010.12,80 6,0)
  16600   DIAGNOSIS  6^*P80'a^I CD9(^80;6^ S DIC("S") ="D ^AUPNS ICD" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  16601   "^DD",9000 010.12,900 0010.12,80 6,.1)
  16602   Diagnosis  6
  16603   "^DD",9000 010.12,900 0010.12,80 6,3)
  16604   Enter the  ICD Diagno sis relate d to the s kin test p erformed.
  16605   "^DD",9000 010.12,900 0010.12,80 6,12)
  16606   Diagnosis  cannot be  an inactiv e code and  it must b e appropri ate.
  16607   "^DD",9000 010.12,900 0010.12,80 6,12.1)
  16608   S DIC("S") ="D ^AUPNS ICD"
  16609   "^DD",9000 010.12,900 0010.12,80 6,21,0)
  16610   ^^2^2^3150 729^
  16611   "^DD",9000 010.12,900 0010.12,80 6,21,1,0)
  16612   This is th e diagnosi s from the  ICD Diagn osis file  associated  with the
  16613   "^DD",9000 010.12,900 0010.12,80 6,21,2,0)
  16614   skin test  performed.
  16615   "^DD",9000 010.12,900 0010.12,80 6,"AUDIT")
  16616   y
  16617   "^DD",9000 010.12,900 0010.12,80 6,"DT")
  16618   3150729
  16619   "^DD",9000 010.12,900 0010.12,80 7,0)
  16620   DIAGNOSIS  7^*P80'a^I CD9(^80;7^ S DIC("S") ="D ^AUPNS ICD" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  16621   "^DD",9000 010.12,900 0010.12,80 7,.1)
  16622   Diagnosis  7
  16623   "^DD",9000 010.12,900 0010.12,80 7,3)
  16624   Enter the  ICD Diagno sis relate d to the s kin test p erformed.
  16625   "^DD",9000 010.12,900 0010.12,80 7,12)
  16626   Diagnosis  cannot be  an inactiv e code and  it must b e appropri ate.
  16627   "^DD",9000 010.12,900 0010.12,80 7,12.1)
  16628   S DIC("S") ="D ^AUPNS ICD"
  16629   "^DD",9000 010.12,900 0010.12,80 7,21,0)
  16630   ^^2^2^3150 729^
  16631   "^DD",9000 010.12,900 0010.12,80 7,21,1,0)
  16632   This is th e diagnosi s from the  ICD Diagn osis file  associated  with the
  16633   "^DD",9000 010.12,900 0010.12,80 7,21,2,0)
  16634   skin test  performed.
  16635   "^DD",9000 010.12,900 0010.12,80 7,"AUDIT")
  16636   y
  16637   "^DD",9000 010.12,900 0010.12,80 7,"DT")
  16638   3150729
  16639   "^DD",9000 010.12,900 0010.12,80 8,0)
  16640   DIAGNOSIS  8^*P80'a^I CD9(^80;8^ S DIC("S") ="D ^AUPNS ICD" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  16641   "^DD",9000 010.12,900 0010.12,80 8,.1)
  16642   Diagnosis  8
  16643   "^DD",9000 010.12,900 0010.12,80 8,3)
  16644   Enter the  ICD Diagno sis relate d to the s kin test p erformed.
  16645   "^DD",9000 010.12,900 0010.12,80 8,12)
  16646   Diagnosis  cannot be  an inactiv e code and  it must b e appropri ate.
  16647   "^DD",9000 010.12,900 0010.12,80 8,12.1)
  16648   S DIC("S") ="D ^AUPNS ICD"
  16649   "^DD",9000 010.12,900 0010.12,80 8,21,0)
  16650   ^^2^2^3150 729^
  16651   "^DD",9000 010.12,900 0010.12,80 8,21,1,0)
  16652   This is th e diagnosi s from the  ICD Diagn osis file  associated  with the
  16653   "^DD",9000 010.12,900 0010.12,80 8,21,2,0)
  16654   skin test  performed.
  16655   "^DD",9000 010.12,900 0010.12,80 8,"AUDIT")
  16656   y
  16657   "^DD",9000 010.12,900 0010.12,80 8,"DT")
  16658   3150729
  16659   "^DD",9000 010.12,900 0010.12,12 01,0)
  16660   EVENT DATE  AND TIME^ DXa^^12;1^ S %DT="ET"  D ^%DT S  X=Y K:Y<1! $$TIME^PXV UTL X
  16661   "^DD",9000 010.12,900 0010.12,12 01,.1)
  16662   Placement  Date and T ime
  16663   "^DD",9000 010.12,900 0010.12,12 01,1,0)
  16664   ^.1^^-1
  16665   "^DD",9000 010.12,900 0010.12,12 01,1,1,0)
  16666   ^^TRIGGER^ 9000010.12 ^1211
  16667   "^DD",9000 010.12,900 0010.12,12 01,1,1,1)
  16668   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVS K(D0,12)): ^(12),1:"" ) S X=$P(Y (1),U,11), X=X S DIU= X K Y S X= DIV N %I,% H,% D NOW^ %DTC S X=%  X ^DD(900 0010.12,12 01,1,1,1.4 )
  16669   "^DD",9000 010.12,900 0010.12,12 01,1,1,1.4 )
  16670   S DIH=$G(^ AUPNVSK(DI V(0),12)), DIV=X S $P (^(12),U,1 1)=DIV,DIH =9000010.1 2,DIG=1211  D ^DICR
  16671   "^DD",9000 010.12,900 0010.12,12 01,1,1,2)
  16672   Q
  16673   "^DD",9000 010.12,900 0010.12,12 01,1,1,"%D ",0)
  16674   ^^3^3^3141 216^
  16675   "^DD",9000 010.12,900 0010.12,12 01,1,1,"%D ",1,0)
  16676   The SKIN T EST PLACEM ENT RECORD ED field ( #1211) wil l be trigg ered
  16677   "^DD",9000 010.12,900 0010.12,12 01,1,1,"%D ",2,0)
  16678   whenever t he EVENT D ATE AND TI ME field ( #1201) is  entered or  updated.
  16679   "^DD",9000 010.12,900 0010.12,12 01,1,1,"%D ",3,0)
  16680   The trigge red value  will be NO W.
  16681   "^DD",9000 010.12,900 0010.12,12 01,1,1,"CR EATE VALUE ")
  16682   NOW
  16683   "^DD",9000 010.12,900 0010.12,12 01,1,1,"DE LETE VALUE ")
  16684   NO EFFECT
  16685   "^DD",9000 010.12,900 0010.12,12 01,1,1,"DT ")
  16686   3141216
  16687   "^DD",9000 010.12,900 0010.12,12 01,1,1,"FI ELD")
  16688   SKIN TEST  PLACEMENT  RECORDED
  16689   "^DD",9000 010.12,900 0010.12,12 01,3)
  16690   Enter the  date and ( optional)  time the s kin test w as placed.
  16691   "^DD",9000 010.12,900 0010.12,12 01,21,0)
  16692   ^^9^9^3150 820^
  16693   "^DD",9000 010.12,900 0010.12,12 01,21,1,0)
  16694   This is th e date and  time the  skin test  was placed . This dat e and time
  16695   "^DD",9000 010.12,900 0010.12,12 01,21,2,0)
  16696   may be dif ferent fro m the visi t date and  time. For  example,  for clinic
  16697   "^DD",9000 010.12,900 0010.12,12 01,21,3,0)
  16698   appointmen t visits,  the visit  date and t ime is the  date and  time of th e
  16699   "^DD",9000 010.12,900 0010.12,12 01,21,4,0)
  16700   appointmen t, not the  time the  provider p erformed t he clinica l event.
  16701   "^DD",9000 010.12,900 0010.12,12 01,21,5,0)
  16702  
  16703   "^DD",9000 010.12,900 0010.12,12 01,21,6,0)
  16704   The date m ay be an i mprecise d ate such a s for an h istorical  skin test.
  16705   "^DD",9000 010.12,900 0010.12,12 01,21,7,0)
  16706  
  16707   "^DD",9000 010.12,900 0010.12,12 01,21,8,0)
  16708   Date and t ime may be  within 30  days befo re or afte r the visi t date,
  16709   "^DD",9000 010.12,900 0010.12,12 01,21,9,0)
  16710   with the r estriction  the date  cannot be  a future d ate.
  16711   "^DD",9000 010.12,900 0010.12,12 01,23,0)
  16712   ^^13^13^31 50820^
  16713   "^DD",9000 010.12,900 0010.12,12 01,23,1,0)
  16714   The PCE Us er Interfa ce, which  allows man ual entry  of data, w ill be the
  16715   "^DD",9000 010.12,900 0010.12,12 01,23,2,0)
  16716   primary so urce of th e event da te and tim e. The eve nt date pr ompt
  16717   "^DD",9000 010.12,900 0010.12,12 01,23,3,0)
  16718   defaults t o the visi t date and  the time  is entered  to reflec t the actu al
  16719   "^DD",9000 010.12,900 0010.12,12 01,23,4,0)
  16720   time the s kin test w as done. T he event d ate does n ot have to  be the
  16721   "^DD",9000 010.12,900 0010.12,12 01,23,5,0)
  16722   visit date , but it m ust be wit hin 30 day s before o r after th e visit, a nd
  16723   "^DD",9000 010.12,900 0010.12,12 01,23,6,0)
  16724   not be a f uture date .
  16725   "^DD",9000 010.12,900 0010.12,12 01,23,7,0)
  16726  
  16727   "^DD",9000 010.12,900 0010.12,12 01,23,8,0)
  16728   If a user  wants to e nter an hi storical s kin test,  the user s hould use
  16729   "^DD",9000 010.12,900 0010.12,12 01,23,9,0)
  16730   the Histor ical Encou nter entry  action to  document  the histor ical skin
  16731   "^DD",9000 010.12,900 0010.12,12 01,23,10,0 )
  16732   test. Hist orical ent ries will  not be eli gible for  workload c redit.
  16733   "^DD",9000 010.12,900 0010.12,12 01,23,11,0 )
  16734  
  16735   "^DD",9000 010.12,900 0010.12,12 01,23,12,0 )
  16736   PCE data s ources for  automatic  (scanning ) data cap ture will  be blank
  16737   "^DD",9000 010.12,900 0010.12,12 01,23,13,0 )
  16738   unless the  event dat e and time  are passe d to PCE f or filing.
  16739   "^DD",9000 010.12,900 0010.12,12 01,"AUDIT" )
  16740   y
  16741   "^DD",9000 010.12,900 0010.12,12 01,"DT")
  16742   3150820
  16743   "^DD",9000 010.12,900 0010.12,12 02,0)
  16744   ORDERING P ROVIDER^P2 00'a^VA(20 0,^12;2^Q
  16745   "^DD",9000 010.12,900 0010.12,12 02,3)
  16746   Enter the  provider w ho ordered  this skin  test.
  16747   "^DD",9000 010.12,900 0010.12,12 02,21,0)
  16748   ^^1^1^2960 513^
  16749   "^DD",9000 010.12,900 0010.12,12 02,21,1,0)
  16750   This field  can be us ed to docu ment the p rovider wh o ordered  the skin t est.
  16751   "^DD",9000 010.12,900 0010.12,12 02,"AUDIT" )
  16752   y
  16753   "^DD",9000 010.12,900 0010.12,12 02,"DT")
  16754   3150213
  16755   "^DD",9000 010.12,900 0010.12,12 04,0)
  16756   ENCOUNTER  PROVIDER^P 200'a^VA(2 00,^12;4^Q
  16757   "^DD",9000 010.12,900 0010.12,12 04,.1)
  16758   Provider P lacing Ski n Test
  16759   "^DD",9000 010.12,900 0010.12,12 04,3)
  16760   Enter the  provider w ho placed  the skin t est.
  16761   "^DD",9000 010.12,900 0010.12,12 04,21,0)
  16762   ^^1^1^3141 216^
  16763   "^DD",9000 010.12,900 0010.12,12 04,21,1,0)
  16764   This is th e provider  who place d the skin  test.
  16765   "^DD",9000 010.12,900 0010.12,12 04,23,0)
  16766   ^.001^1^1^ 3141216^^^
  16767   "^DD",9000 010.12,900 0010.12,12 04,23,1,0)
  16768   This perso n can be a ny person  in the new  person fi le.
  16769   "^DD",9000 010.12,900 0010.12,12 04,"AUDIT" )
  16770   y
  16771   "^DD",9000 010.12,900 0010.12,12 04,"DT")
  16772   3150213
  16773   "^DD",9000 010.12,900 0010.12,12 11,0)
  16774   SKIN TEST  PLACEMENT  RECORDED^D a^^12;11^S  %DT="ETXR " D ^%DT S  X=Y K:Y<1  X
  16775   "^DD",9000 010.12,900 0010.12,12 11,.1)
  16776   Date/Time  Skin Test  Placement  Recorded
  16777   "^DD",9000 010.12,900 0010.12,12 11,3)
  16778   Enter the  date and t ime of doc umentation  of the pl acement of  the skin  test.
  16779   "^DD",9000 010.12,900 0010.12,12 11,5,1,0)
  16780   9000010.12 ^1201^1
  16781   "^DD",9000 010.12,900 0010.12,12 11,21,0)
  16782   ^^3^3^3141 217^
  16783   "^DD",9000 010.12,900 0010.12,12 11,21,1,0)
  16784   This times tamp field  is the da te and tim e of docum entation o f placemen t
  16785   "^DD",9000 010.12,900 0010.12,12 11,21,2,0)
  16786   of the ski n test. Th is field i s set auto matically  when the E VENT DATE
  16787   "^DD",9000 010.12,900 0010.12,12 11,21,3,0)
  16788   AND TIME i s entered.
  16789   "^DD",9000 010.12,900 0010.12,12 11,"AUDIT" )
  16790   y
  16791   "^DD",9000 010.12,900 0010.12,12 11,"DT")
  16792   3150213
  16793   "^DD",9000 010.12,900 0010.12,12 12,0)
  16794   ANATOMIC L OCATION OF  PLACEMENT ^*P920.3'a ^PXV(920.3 ,^12;12^S  DIC("S")=" I '$$SCREE N^XTID(920 .3,,Y_""," ")" D ^DIC  K DIC S D IC=$G(DIE) ,X=+Y K:Y< 0 X
  16795   "^DD",9000 010.12,900 0010.12,12 12,.1)
  16796   Anatomic L ocation of  Skin Test  Placement
  16797   "^DD",9000 010.12,900 0010.12,12 12,3)
  16798   Select the  anatomic  location o f skin tes t placemen t.
  16799   "^DD",9000 010.12,900 0010.12,12 12,12)
  16800   Only activ e IMM ADMI NISTRATION  SITE (BOD Y) entries  may be se lected.
  16801   "^DD",9000 010.12,900 0010.12,12 12,12.1)
  16802   S DIC("S") ="I '$$SCR EEN^XTID(9 20.3,,Y_"" ,"")"
  16803   "^DD",9000 010.12,900 0010.12,12 12,21,0)
  16804   ^.001^1^1^ 3141216^^
  16805   "^DD",9000 010.12,900 0010.12,12 12,21,1,0)
  16806   This is th e area of  the patien t's body w here the s kin test w as placed.
  16807   "^DD",9000 010.12,900 0010.12,12 12,23,0)
  16808   ^^3^3^3141 216^
  16809   "^DD",9000 010.12,900 0010.12,12 12,23,1,0)
  16810   This is th e area of  the patien t's body w here the s kin test w as placed.
  16811   "^DD",9000 010.12,900 0010.12,12 12,23,2,0)
  16812   It is sele cted from  a list of  entries in  the IMM A DMINISTRAT ION SITE
  16813   "^DD",9000 010.12,900 0010.12,12 12,23,3,0)
  16814   (BODY) fil e (#920.3) .
  16815   "^DD",9000 010.12,900 0010.12,12 12,"AUDIT" )
  16816   y
  16817   "^DD",9000 010.12,900 0010.12,12 12,"DT")
  16818   3150226
  16819   "^DD",9000 010.12,900 0010.12,12 14,0)
  16820   HOURS READ  POST-PLAC EMENT^NJ3, 0Ia^^12;14 ^K:+X'=X!( X>100)!(X< 0)!(X?.E1" ."1N.N) X
  16821   "^DD",9000 010.12,900 0010.12,12 14,.1)
  16822   Hours Betw een Placem ent and Re ading
  16823   "^DD",9000 010.12,900 0010.12,12 14,3)
  16824   Type a num ber betwee n 0 and 10 0, 0 decim al digits.
  16825   "^DD",9000 010.12,900 0010.12,12 14,21,0)
  16826   ^.001^2^2^ 3150205^^^
  16827   "^DD",9000 010.12,900 0010.12,12 14,21,1,0)
  16828   This is th e number o f hours be tween the  placement  of the ski n test and
  16829   "^DD",9000 010.12,900 0010.12,12 14,21,2,0)
  16830   the readin g of the s kin test.
  16831   "^DD",9000 010.12,900 0010.12,12 14,23,0)
  16832   ^.001^2^2^ 3150205^^
  16833   "^DD",9000 010.12,900 0010.12,12 14,23,1,0)
  16834   This field  is set by  cross ref erences on  the EVENT  DATE AND  TIME field
  16835   "^DD",9000 010.12,900 0010.12,12 14,23,2,0)
  16836   (#1201) an d the DATE  READ fiel d (#.06).
  16837   "^DD",9000 010.12,900 0010.12,12 14,"AUDIT" )
  16838   y
  16839   "^DD",9000 010.12,900 0010.12,12 14,"DT")
  16840   3150818
  16841   "^DD",9000 010.12,900 0010.12,12 20,0)
  16842   SKIN TEST  READING RE CORDED^Da^ ^12;20^S % DT="ETXR"  D ^%DT S X =Y K:Y<1 X
  16843   "^DD",9000 010.12,900 0010.12,12 20,.1)
  16844   Date/Time  Skin Test  Reading Re corded
  16845   "^DD",9000 010.12,900 0010.12,12 20,3)
  16846   Enter the  date and t ime of doc umentation  of the re ading of t he skin te st.
  16847   "^DD",9000 010.12,900 0010.12,12 20,5,1,0)
  16848   9000010.12 ^.06^1
  16849   "^DD",9000 010.12,900 0010.12,12 20,21,0)
  16850   ^.001^3^3^ 3150728^^
  16851   "^DD",9000 010.12,900 0010.12,12 20,21,1,0)
  16852   This times tamp field  is the da te and tim e of docum entation o f reading
  16853   "^DD",9000 010.12,900 0010.12,12 20,21,2,0)
  16854   of the ski n test. Th is field i s set auto matically  when the D ATE READ i s
  16855   "^DD",9000 010.12,900 0010.12,12 20,21,3,0)
  16856   entered.
  16857   "^DD",9000 010.12,900 0010.12,12 20,"AUDIT" )
  16858   y
  16859   "^DD",9000 010.12,900 0010.12,12 20,"DT")
  16860   3150728
  16861   "^DD",9000 010.12,900 0010.12,13 01,0)
  16862   READING CO MMENTS^Fa^ ^13;1^K:$L (X)>245!($ L(X)<1) X
  16863   "^DD",9000 010.12,900 0010.12,13 01,.1)
  16864   Reading Co mments
  16865   "^DD",9000 010.12,900 0010.12,13 01,3)
  16866   Enter a re ading comm ent 1-245  characters  in length .
  16867   "^DD",9000 010.12,900 0010.12,13 01,21,0)
  16868   ^^2^2^3141 217^
  16869   "^DD",9000 010.12,900 0010.12,13 01,21,1,0)
  16870   This is a  comment re lated to t he reading  of the pa tient's sk in test.
  16871   "^DD",9000 010.12,900 0010.12,13 01,21,2,0)
  16872   The provid er may ent er this ma nually via  the PCE U ser Interf ace.
  16873   "^DD",9000 010.12,900 0010.12,13 01,"AUDIT" )
  16874   y
  16875   "^DD",9000 010.12,900 0010.12,13 01,"DT")
  16876   3150213
  16877   "^DD",9000 010.12,900 0010.12,80 101,0)
  16878   EDITED FLA G^Sa^1:EDI TED;^801;1 ^Q
  16879   "^DD",9000 010.12,900 0010.12,80 101,3)
  16880   Answer is  automatica lly entere d by PCE f iling logi c.
  16881   "^DD",9000 010.12,900 0010.12,80 101,21,0)
  16882   ^.001^2^2^ 3151112^^
  16883   "^DD",9000 010.12,900 0010.12,80 101,21,1,0 )
  16884   This field  is automa tically se t to 1 if  PCE detect s that any  original  skin test
  16885   "^DD",9000 010.12,900 0010.12,80 101,21,2,0 )
  16886   data is be ing edited .
  16887   "^DD",9000 010.12,900 0010.12,80 101,23,0)
  16888   ^.001^2^2^ 3151112^^
  16889   "^DD",9000 010.12,900 0010.12,80 101,23,1,0 )
  16890   PCE filing  logic aut omatically  compares  the before  and after  pictures  of the
  16891   "^DD",9000 010.12,900 0010.12,80 101,23,2,0 )
  16892   record to  determine  if the edi ted flag s hould be s et to "1".
  16893   "^DD",9000 010.12,900 0010.12,80 101,"AUDIT ")
  16894   y
  16895   "^DD",9000 010.12,900 0010.12,80 101,"DT")
  16896   3150213
  16897   "^DD",9000 010.12,900 0010.12,80 102,0)
  16898   AUDIT TRAI L^Fa^^801; 2^K:$L(X)> 85!($L(X)< 2) X
  16899   "^DD",9000 010.12,900 0010.12,80 102,3)
  16900   Answer mus t be 2 to  85 charact ers.
  16901   "^DD",9000 010.12,900 0010.12,80 102,21,0)
  16902   ^.001^4^4^ 3151112^^
  16903   "^DD",9000 010.12,900 0010.12,80 102,21,1,0 )
  16904   This field  is popula ted automa tically be  the PCE f iling logi c. The
  16905   "^DD",9000 010.12,900 0010.12,80 102,21,2,0 )
  16906   format of  the field  is as foll ows:  Poin ter to PCE  data sour ce
  16907   "^DD",9000 010.12,900 0010.12,80 102,21,3,0 )
  16908   file_"-"_A  for Add o r E for Ed it_" "_DUZ  of the pe rson who e ntered the
  16909   "^DD",9000 010.12,900 0010.12,80 102,21,4,0 )
  16910   data_";".. .
  16911   "^DD",9000 010.12,900 0010.12,80 102,23,0)
  16912   ^.001^14^1 4^3151112^ ^^^
  16913   "^DD",9000 010.12,900 0010.12,80 102,23,1,0 )
  16914   The PCE fi ling logic  requires  a pointer  to the PCE  data sour ce file.   If this
  16915   "^DD",9000 010.12,900 0010.12,80 102,23,2,0 )
  16916   is not pas sed, then  PCE filing  logic wil l not proc ess the da ta.
  16917   "^DD",9000 010.12,900 0010.12,80 102,23,3,0 )
  16918  
  16919   "^DD",9000 010.12,900 0010.12,80 102,23,4,0 )
  16920   If the rec ord is a n ew record,  then an " A" is used  to specif y the sour ce that
  16921   "^DD",9000 010.12,900 0010.12,80 102,23,5,0 )
  16922   added the  data.  If  the record  existed p reviously,  PCE filin g logic co mpares
  16923   "^DD",9000 010.12,900 0010.12,80 102,23,6,0 )
  16924   the old an d new reco rds of inf ormation.   An "E" wi ll be auto matically  used if
  16925   "^DD",9000 010.12,900 0010.12,80 102,23,7,0 )
  16926   the filing  logic fin ds the dat a has been  edited.   If "E" is  used, then  the
  16927   "^DD",9000 010.12,900 0010.12,80 102,23,8,0 )
  16928   Edited Fla g field is  automatic ally set t o 1.
  16929   "^DD",9000 010.12,900 0010.12,80 102,23,9,0 )
  16930  
  16931   "^DD",9000 010.12,900 0010.12,80 102,23,10, 0)
  16932   The DUZ is  stored in  its inter nal format  to repres ent the us er who per formed
  16933   "^DD",9000 010.12,900 0010.12,80 102,23,11, 0)
  16934   the adding  or editin g of data  for this r ecord.
  16935   "^DD",9000 010.12,900 0010.12,80 102,23,12, 0)
  16936  
  16937   "^DD",9000 010.12,900 0010.12,80 102,23,13, 0)
  16938   Iterations  of editin g will be  concatenat ed to the  previous d ata source  value,
  16939   "^DD",9000 010.12,900 0010.12,80 102,23,14, 0)
  16940   up to 85 c haracters.
  16941   "^DD",9000 010.12,900 0010.12,80 102,"AUDIT ")
  16942   y
  16943   "^DD",9000 010.12,900 0010.12,80 102,"DT")
  16944   3150213
  16945   "^DD",9000 010.12,900 0010.12,81 101,0)
  16946   PLACEMENT  COMMENTS^F a^^811;1^K :$L(X)>245 !($L(X)<1)  X
  16947   "^DD",9000 010.12,900 0010.12,81 101,.1)
  16948   Placement  Comments
  16949   "^DD",9000 010.12,900 0010.12,81 101,3)
  16950   Enter a pl acement co mment 1-24 5 characte rs in leng th.
  16951   "^DD",9000 010.12,900 0010.12,81 101,21,0)
  16952   ^^2^2^3141 216^
  16953   "^DD",9000 010.12,900 0010.12,81 101,21,1,0 )
  16954   This is a  comment re lated to t he placeme nt of the  patient's  skin test.
  16955   "^DD",9000 010.12,900 0010.12,81 101,21,2,0 )
  16956   The provid er may ent er this ma nually via  the PCE U ser Interf ace.
  16957   "^DD",9000 010.12,900 0010.12,81 101,"AUDIT ")
  16958   y
  16959   "^DD",9000 010.12,900 0010.12,81 101,"DT")
  16960   3150213
  16961   "^DD",9000 010.12,900 0010.12,81 201,0)
  16962   VERIFIED^S Ia^1:ELECT RONICALLY  SIGNED;2:V ERIFIED BY  PACKAGE;^ 812;1^Q
  16963   "^DD",9000 010.12,900 0010.12,81 201,3)
  16964   This is au tomaticall y entered  by the sof tware and  is unedita ble.
  16965   "^DD",9000 010.12,900 0010.12,81 201,21,0)
  16966   ^.001^2^2^ 3150213^^
  16967   "^DD",9000 010.12,900 0010.12,81 201,21,1,0 )
  16968   This is us ed to note  how the e vent was v erified an d is autom atically
  16969   "^DD",9000 010.12,900 0010.12,81 201,21,2,0 )
  16970   entered by  the softw are.
  16971   "^DD",9000 010.12,900 0010.12,81 201,23,0)
  16972   ^.001^1^1^ 3150213^^
  16973   "^DD",9000 010.12,900 0010.12,81 201,23,1,0 )
  16974   This is au tomaticall y entered  by the sof tware and  is unedita ble for us ers.
  16975   "^DD",9000 010.12,900 0010.12,81 201,"AUDIT ")
  16976   y
  16977   "^DD",9000 010.12,900 0010.12,81 201,"DT")
  16978   3150213
  16979   "^DD",9000 010.12,900 0010.12,81 202,0)
  16980   PACKAGE^P9 .4'Ia^DIC( 9.4,^812;2 ^Q
  16981   "^DD",9000 010.12,900 0010.12,81 202,.1)
  16982   Package
  16983   "^DD",9000 010.12,900 0010.12,81 202,3)
  16984   Enter the  VistA pack age from w hich this  record ori ginated.
  16985   "^DD",9000 010.12,900 0010.12,81 202,21,0)
  16986   ^^4^4^3150 813^
  16987   "^DD",9000 010.12,900 0010.12,81 202,21,1,0 )
  16988   This is th e VistA pa ckage from  which thi s skin tes t record
  16989   "^DD",9000 010.12,900 0010.12,81 202,21,2,0 )
  16990   originated  through P CE.
  16991   "^DD",9000 010.12,900 0010.12,81 202,21,3,0 )
  16992  
  16993   "^DD",9000 010.12,900 0010.12,81 202,21,4,0 )
  16994   This is au tomaticall y entered  by the sof tware and  uneditable  by users.
  16995   "^DD",9000 010.12,900 0010.12,81 202,"AUDIT ")
  16996   y
  16997   "^DD",9000 010.12,900 0010.12,81 202,"DT")
  16998   3150813
  16999   "^DD",9000 010.12,900 0010.12,81 203,0)
  17000   DATA SOURC E^P839.7'I a^PX(839.7 ,^812;3^Q
  17001   "^DD",9000 010.12,900 0010.12,81 203,3)
  17002   Select the  data sour ce for thi s skin tes t entry th rough PCE.
  17003   "^DD",9000 010.12,900 0010.12,81 203,21,0)
  17004   ^^2^2^3150 213^
  17005   "^DD",9000 010.12,900 0010.12,81 203,21,1,0 )
  17006   This is th e data sou rce for th is skin te st, automa tically en tered
  17007   "^DD",9000 010.12,900 0010.12,81 203,21,2,0 )
  17008   through th e PCS soft ware and u neditable  by users.
  17009   "^DD",9000 010.12,900 0010.12,81 203,"AUDIT ")
  17010   y
  17011   "^DD",9000 010.12,900 0010.12,81 203,"DT")
  17012   3150213
  17013   "^DD",9000 010.707,90 00010.707, 0)
  17014   FIELD^^120 4^14
  17015   "^DD",9000 010.707,90 00010.707, 0,"DDA")
  17016   N
  17017   "^DD",9000 010.707,90 00010.707, 0,"DT")
  17018   3151231
  17019   "^DD",9000 010.707,90 00010.707, 0,"ID",.02 )
  17020   S %I=Y,Y=$ S('$D(^(0) ):"",$D(^A UPNPAT(+$P (^(0),U,2) ,0))#2:$P( ^(0),U,1), 1:""),C=$P (^DD(90000 01,.01,0), U,2) D Y^D IQ:Y]"" W  "   ",Y,@( "$E("_DIC_ "%I,0),0)" ) S Y=%I K  %I
  17021   "^DD",9000 010.707,90 00010.707, 0,"ID",.03 )
  17022   S %I=Y,Y=$ S('$D(^(0) ):"",$D(^A UPNVSIT(+$ P(^(0),U,3 ),0))#2:$P (^(0),U,1) ,1:""),C=$ P(^DD(9000 010,.01,0) ,U,2) D Y^ DIQ:Y]"" W  "   ",Y,@ ("$E("_DIC _"%I,0),0) ") S Y=%I  K %I
  17023   "^DD",9000 010.707,90 00010.707, 0,"ID",.04 )
  17024   S %I=Y,Y=$ S('$D(^(0) ):"",$D(^A UTTIMM(+$P (^(0),U,4) ,0))#2:$P( ^(0),U,1), 1:""),C=$P (^DD(99999 99.14,.01, 0),U,2) D  Y^DIQ:Y]""  W "   ",Y ,@("$E("_D IC_"%I,0), 0)") S Y=% I K %I
  17025   "^DD",9000 010.707,90 00010.707, 0,"IX","AD ",9000010. 707,.03)
  17026  
  17027   "^DD",9000 010.707,90 00010.707, 0,"IX","AV 10",900001 0.707,.03)
  17028  
  17029   "^DD",9000 010.707,90 00010.707, 0,"IX","B" ,9000010.7 07,.01)
  17030  
  17031   "^DD",9000 010.707,90 00010.707, 0,"IX","C" ,9000010.7 07,.02)
  17032  
  17033   "^DD",9000 010.707,90 00010.707, 0,"NM","V  IMM CONTRA /REFUSAL E VENTS")
  17034  
  17035   "^DD",9000 010.707,90 00010.707, .01,0)
  17036   CONTRAINDI CATION/REF USAL^RVa^^ 0;1^
  17037   "^DD",9000 010.707,90 00010.707, .01,.1)
  17038   Contraindi cation/Ref usal
  17039   "^DD",9000 010.707,90 00010.707, .01,1,0)
  17040   ^.1
  17041   "^DD",9000 010.707,90 00010.707, .01,1,1,0)
  17042   9000010.70 7^B
  17043   "^DD",9000 010.707,90 00010.707, .01,1,1,1)
  17044   S ^AUPNVIC R("B",$E(X ,1,30),DA) =""
  17045   "^DD",9000 010.707,90 00010.707, .01,1,1,2)
  17046   K ^AUPNVIC R("B",$E(X ,1,30),DA)
  17047   "^DD",9000 010.707,90 00010.707, .01,1,2,0)
  17048   ^^TRIGGER^ 9000010.70 7^.06
  17049   "^DD",9000 010.707,90 00010.707, .01,1,2,1)
  17050   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^AUPNVI CR(D0,0)): ^(0),1:"")  S X=$P(Y( 1),U,6),X= X S DIU=X  K Y X ^DD( 9000010.70 7,.01,1,2, 1.1) S DIH =$G(^AUPNV ICR(DIV(0) ,0)),DIV=X  S $P(^(0) ,U,6)=DIV, DIH=900001 0.707,DIG= .06 D ^DIC R
  17051   "^DD",9000 010.707,90 00010.707, .01,1,2,1. 1)
  17052   S X=DIV N  %I,%H,% D  NOW^%DTC S  X=% S X=X ,Y(1)=$G(X ) S X=1,Y( 2)=$G(X) S  X=12,X=$E (Y(1),Y(2) ,X)
  17053   "^DD",9000 010.707,90 00010.707, .01,1,2,2)
  17054   Q
  17055   "^DD",9000 010.707,90 00010.707, .01,1,2,"% D",0)
  17056   ^^3^3^3151 117^
  17057   "^DD",9000 010.707,90 00010.707, .01,1,2,"% D",1,0)
  17058   The DATE/T IME RECORD ED field ( #.06) will  be trigge red whenev er the
  17059   "^DD",9000 010.707,90 00010.707, .01,1,2,"% D",2,0)
  17060   CONTRAINDI CATION/REF USAL field  (#.01) is  entered o r updated.  The
  17061   "^DD",9000 010.707,90 00010.707, .01,1,2,"% D",3,0)
  17062   triggered  value will  be NOW.
  17063   "^DD",9000 010.707,90 00010.707, .01,1,2,"C REATE VALU E")
  17064   $E(NOW,1,1 2)
  17065   "^DD",9000 010.707,90 00010.707, .01,1,2,"D ELETE VALU E")
  17066   NO EFFECT
  17067   "^DD",9000 010.707,90 00010.707, .01,1,2,"D T")
  17068   3151117
  17069   "^DD",9000 010.707,90 00010.707, .01,1,2,"F IELD")
  17070   DATE/TIME  RECORDED
  17071   "^DD",9000 010.707,90 00010.707, .01,3)
  17072   Enter the  Contraindi cation or  Refusal Re ason for t his event.
  17073   "^DD",9000 010.707,90 00010.707, .01,21,0)
  17074   ^^2^2^3151 112^
  17075   "^DD",9000 010.707,90 00010.707, .01,21,1,0 )
  17076   This is th e contrain dication o r refusal  reason for  this
  17077   "^DD",9000 010.707,90 00010.707, .01,21,2,0 )
  17078   non-admini stration e vent.
  17079   "^DD",9000 010.707,90 00010.707, .01,"AUDIT ")
  17080   y
  17081   "^DD",9000 010.707,90 00010.707, .01,"DT")
  17082   3160325
  17083   "^DD",9000 010.707,90 00010.707, .01,"V",0)
  17084   ^.12P^2^2
  17085   "^DD",9000 010.707,90 00010.707, .01,"V",1, 0)
  17086   920.4^Sele ct the Con traindicat ion^1^C^y^ n
  17087   "^DD",9000 010.707,90 00010.707, .01,"V",1, 1)
  17088   S DIC("S") ="I '$$SCR EEN^XTID(9 20.4,,Y_"" ,"")"
  17089   "^DD",9000 010.707,90 00010.707, .01,"V",1, 2)
  17090   Only activ e contrain dication r easons may  be select ed.
  17091   "^DD",9000 010.707,90 00010.707, .01,"V",2, 0)
  17092   920.5^Sele ct the Ref usal Reaso n^2^R^y^n
  17093   "^DD",9000 010.707,90 00010.707, .01,"V",2, 1)
  17094   S DIC("S") ="I '$$SCR EEN^XTID(9 20.5,,Y_"" ,"")"
  17095   "^DD",9000 010.707,90 00010.707, .01,"V",2, 2)
  17096   Only activ e refusal  reasons ma y be selec ted.
  17097   "^DD",9000 010.707,90 00010.707, .02,0)
  17098   PATIENT NA ME^RP90000 01'a^AUPNP AT(^0;2^Q
  17099   "^DD",9000 010.707,90 00010.707, .02,.1)
  17100   Patient Na me
  17101   "^DD",9000 010.707,90 00010.707, .02,1,0)
  17102   ^.1
  17103   "^DD",9000 010.707,90 00010.707, .02,1,1,0)
  17104   9000010.70 7^C
  17105   "^DD",9000 010.707,90 00010.707, .02,1,1,1)
  17106   S ^AUPNVIC R("C",$E(X ,1,30),DA) =""
  17107   "^DD",9000 010.707,90 00010.707, .02,1,1,2)
  17108   K ^AUPNVIC R("C",$E(X ,1,30),DA)
  17109   "^DD",9000 010.707,90 00010.707, .02,1,1,"% D",0)
  17110   ^^1^1^3151 112^
  17111   "^DD",9000 010.707,90 00010.707, .02,1,1,"% D",1,0)
  17112   This cross  reference  allows lo ok-up by p atient nam e.
  17113   "^DD",9000 010.707,90 00010.707, .02,1,1,"D T")
  17114   3151112
  17115   "^DD",9000 010.707,90 00010.707, .02,3)
  17116   Enter the  patient fo r whom the  immunizat ion was co ntraindica ted or ref used.
  17117   "^DD",9000 010.707,90 00010.707, .02,21,0)
  17118   ^.001^2^2^ 3151112^^^
  17119   "^DD",9000 010.707,90 00010.707, .02,21,1,0 )
  17120   This is th e patient  for whom t he immuniz ation was  contraindi cated or
  17121   "^DD",9000 010.707,90 00010.707, .02,21,2,0 )
  17122   refused.
  17123   "^DD",9000 010.707,90 00010.707, .02,23,0)
  17124   ^.001^3^3^ 3151112^^
  17125   "^DD",9000 010.707,90 00010.707, .02,23,1,0 )
  17126   This is a  pointer to  the Patie nt/IHS fil e (#900000 1) which i s dinumed
  17127   "^DD",9000 010.707,90 00010.707, .02,23,2,0 )
  17128   to the Pat ient File  (#2). This  field is  always stu ffed by th e
  17129   "^DD",9000 010.707,90 00010.707, .02,23,3,0 )
  17130   applicatio n.  No edi ting is al lowed.
  17131   "^DD",9000 010.707,90 00010.707, .02,"AUDIT ")
  17132   y
  17133   "^DD",9000 010.707,90 00010.707, .02,"DT")
  17134   3160325
  17135   "^DD",9000 010.707,90 00010.707, .03,0)
  17136   VISIT^R*P9 000010'a^A UPNVSIT(^0 ;3^S DIC(" S")="I $P( ^(0),U,5)= $P(^AUPNVI CR(DA,0),U ,2)" D ^DI C K DIC S  DIC=DIE,X= +Y K:Y<0 X
  17137   "^DD",9000 010.707,90 00010.707, .03,.1)
  17138   Visit
  17139   "^DD",9000 010.707,90 00010.707, .03,1,0)
  17140   ^.1
  17141   "^DD",9000 010.707,90 00010.707, .03,1,1,0)
  17142   9000010.70 7^AD
  17143   "^DD",9000 010.707,90 00010.707, .03,1,1,1)
  17144   S ^AUPNVIC R("AD",$E( X,1,30),DA )=""
  17145   "^DD",9000 010.707,90 00010.707, .03,1,1,2)
  17146   K ^AUPNVIC R("AD",$E( X,1,30),DA )
  17147   "^DD",9000 010.707,90 00010.707, .03,1,1,"% D",0)
  17148   ^^1^1^3151 112^
  17149   "^DD",9000 010.707,90 00010.707, .03,1,1,"% D",1,0)
  17150   This cross  reference  allows lo ok-up of e ntries by  patient na me.
  17151   "^DD",9000 010.707,90 00010.707, .03,1,1,"D T")
  17152   3151112
  17153   "^DD",9000 010.707,90 00010.707, .03,1,2,0)
  17154   9000010.70 7^AV10^MUM PS
  17155   "^DD",9000 010.707,90 00010.707, .03,1,2,1)
  17156   D ADD^AUPN VSIT
  17157   "^DD",9000 010.707,90 00010.707, .03,1,2,2)
  17158   D SUB^AUPN VSIT
  17159   "^DD",9000 010.707,90 00010.707, .03,1,2,"% D",0)
  17160   ^^2^2^3160 325^
  17161   "^DD",9000 010.707,90 00010.707, .03,1,2,"% D",1,0)
  17162   This cross -reference  adds and  subtracts  from the d ependent e ntry count
  17163   "^DD",9000 010.707,90 00010.707, .03,1,2,"% D",2,0)
  17164   in the VIS IT file.
  17165   "^DD",9000 010.707,90 00010.707, .03,1,2,"D T")
  17166   3160325
  17167   "^DD",9000 010.707,90 00010.707, .03,3)
  17168   Enter the  visit date /time for  this encou nter.
  17169   "^DD",9000 010.707,90 00010.707, .03,12)
  17170   Visit must  be for cu rrent pati ent.
  17171   "^DD",9000 010.707,90 00010.707, .03,12.1)
  17172   S DIC("S") ="I $P(^(0 ),U,5)=$P( ^AUPNVICR( DA,0),U,2) "
  17173   "^DD",9000 010.707,90 00010.707, .03,21,0)
  17174   ^.001^2^2^ 3151112^^
  17175   "^DD",9000 010.707,90 00010.707, .03,21,1,0 )
  17176   This is th e encounte r defined  in the Vis it file th at represe nts when a nd
  17177   "^DD",9000 010.707,90 00010.707, .03,21,2,0 )
  17178   where this  immunizat ion contra indication  or refusa l event oc curred.
  17179   "^DD",9000 010.707,90 00010.707, .03,23,0)
  17180   ^.001^2^2^ 3151112^^
  17181   "^DD",9000 010.707,90 00010.707, .03,23,1,0 )
  17182   This is th e pointer  to the VIS IT file (# 9000010).  This field  is stuffe d
  17183   "^DD",9000 010.707,90 00010.707, .03,23,2,0 )
  17184   by the app lications.  No editin g is allow ed.
  17185   "^DD",9000 010.707,90 00010.707, .03,"AUDIT ")
  17186   y
  17187   "^DD",9000 010.707,90 00010.707, .03,"DT")
  17188   3160325
  17189   "^DD",9000 010.707,90 00010.707, .04,0)
  17190   IMMUNIZATI ON^RP99999 99.14'a^AU TTIMM(^0;4 ^Q
  17191   "^DD",9000 010.707,90 00010.707, .04,.1)
  17192   Immunizati on
  17193   "^DD",9000 010.707,90 00010.707, .04,3)
  17194   Enter the  immunizati on contrai ndicated o r refused.
  17195   "^DD",9000 010.707,90 00010.707, .04,21,0)
  17196   ^.001^1^1^ 3151231^^
  17197   "^DD",9000 010.707,90 00010.707, .04,21,1,0 )
  17198   This is th e immuniza tion that  is contrai ndicated o r refused.
  17199   "^DD",9000 010.707,90 00010.707, .04,"AUDIT ")
  17200   y
  17201   "^DD",9000 010.707,90 00010.707, .04,"DT")
  17202   3151231
  17203   "^DD",9000 010.707,90 00010.707, .05,0)
  17204   WARN UNTIL  DATE^Da^^ 0;5^S %DT= "EX" D ^%D T S X=Y K: Y<1 X
  17205   "^DD",9000 010.707,90 00010.707, .05,.1)
  17206   Warn Until  Date
  17207   "^DD",9000 010.707,90 00010.707, .05,3)
  17208   Enter a da te until w hich a war ning shoul d be given  for this  contraindi cation/ref usal.
  17209   "^DD",9000 010.707,90 00010.707, .05,21,0)
  17210   ^^2^2^3151 119^^
  17211   "^DD",9000 010.707,90 00010.707, .05,21,1,0 )
  17212   This is th e date unt il which a  warning o f this con traindicat ion/refusa l
  17213   "^DD",9000 010.707,90 00010.707, .05,21,2,0 )
  17214   should be  presented.
  17215   "^DD",9000 010.707,90 00010.707, .05,"AUDIT ")
  17216   y
  17217   "^DD",9000 010.707,90 00010.707, .05,"DT")
  17218   3151119
  17219   "^DD",9000 010.707,90 00010.707, .06,0)
  17220   DATE/TIME  RECORDED^D aX^^0;6^S  %DT="ETXR"  D ^%DT S  X=Y K:Y<1  X
  17221   "^DD",9000 010.707,90 00010.707, .06,.1)
  17222   Date/Time  Recorded
  17223   "^DD",9000 010.707,90 00010.707, .06,3)
  17224   Enter the  date and t ime this e vent was d ocumented.
  17225   "^DD",9000 010.707,90 00010.707, .06,5,1,0)
  17226   9000010.70 7^.01^2
  17227   "^DD",9000 010.707,90 00010.707, .06,"AUDIT ")
  17228   y
  17229   "^DD",9000 010.707,90 00010.707, .06,"DT")
  17230   3160310
  17231   "^DD",9000 010.707,90 00010.707, 1201,0)
  17232   EVENT DATE  AND TIME^ Da^^12;1^S  %DT="ET"  D ^%DT S X =Y K:Y<1 X
  17233   "^DD",9000 010.707,90 00010.707, 1201,.1)
  17234   Event Date  and Time
  17235   "^DD",9000 010.707,90 00010.707, 1201,3)
  17236   Enter the  date and ( optional)  time if th is contrai ndication/ refusal ev ent.
  17237   "^DD",9000 010.707,90 00010.707, 1201,"AUDI T")
  17238   y
  17239   "^DD",9000 010.707,90 00010.707, 1201,"DT")
  17240   3151112
  17241   "^DD",9000 010.707,90 00010.707, 1204,0)
  17242   ENCOUNTER  PROVIDER^P 200'a^VA(2 00,^12;4^Q
  17243   "^DD",9000 010.707,90 00010.707, 1204,.1)
  17244   Encounter  Provider
  17245   "^DD",9000 010.707,90 00010.707, 1204,3)
  17246   Enter the  provider a ssociated  with this  contraindi cation/ref usal event .
  17247   "^DD",9000 010.707,90 00010.707, 1204,21,0)
  17248   ^^2^2^3151 112^
  17249   "^DD",9000 010.707,90 00010.707, 1204,21,1, 0)
  17250   This is th e provider  associate d with thi s contrain dication/r efusal
  17251   "^DD",9000 010.707,90 00010.707, 1204,21,2, 0)
  17252   event.
  17253   "^DD",9000 010.707,90 00010.707, 1204,23,0)
  17254   ^^1^1^3151 112^
  17255   "^DD",9000 010.707,90 00010.707, 1204,23,1, 0)
  17256   This perso n can be a ny person  in the new  person fi le.
  17257   "^DD",9000 010.707,90 00010.707, 1204,"AUDI T")
  17258   y
  17259   "^DD",9000 010.707,90 00010.707, 1204,"DT")
  17260   3151112
  17261   "^DD",9000 010.707,90 00010.707, 80101,0)
  17262   EDITED FLA G^Sa^1:EDI TED;^801;1 ^Q
  17263   "^DD",9000 010.707,90 00010.707, 80101,3)
  17264   Enter 1 if  this even t data is  being edit ed.
  17265   "^DD",9000 010.707,90 00010.707, 80101,21,0 )
  17266   ^^2^2^3151 112^
  17267   "^DD",9000 010.707,90 00010.707, 80101,21,1 ,0)
  17268   This field  is automa tically se t to 1 if  PCE detect s that any  original
  17269   "^DD",9000 010.707,90 00010.707, 80101,21,2 ,0)
  17270   contraindi cation/ref usal event  data is b eing edite d.
  17271   "^DD",9000 010.707,90 00010.707, 80101,23,0 )
  17272   ^^2^2^3151 112^^
  17273   "^DD",9000 010.707,90 00010.707, 80101,23,1 ,0)
  17274   PCE filing  logic aut omatically  compares  the before  and after  pictures
  17275   "^DD",9000 010.707,90 00010.707, 80101,23,2 ,0)
  17276   of the rec ord to det ermine if  the edited  flag shou ld be set  to "1".
  17277   "^DD",9000 010.707,90 00010.707, 80101,"AUD IT")
  17278   y
  17279   "^DD",9000 010.707,90 00010.707, 80101,"DT" )
  17280   3160310
  17281   "^DD",9000 010.707,90 00010.707, 80102,0)
  17282   AUDIT TRAI L^Fa^^801; 2^K:$L(X)> 85!($L(X)< 2) X
  17283   "^DD",9000 010.707,90 00010.707, 80102,3)
  17284   Answer mus t be 2-85  characters  in length .
  17285   "^DD",9000 010.707,90 00010.707, 80102,21,0 )
  17286   ^^4^4^3151 112^
  17287   "^DD",9000 010.707,90 00010.707, 80102,21,1 ,0)
  17288   This field  is popula ted automa tically be  the PCE f iling logi c. The
  17289   "^DD",9000 010.707,90 00010.707, 80102,21,2 ,0)
  17290   format of  the field  is as foll ows:  Poin ter to PCE  data sour ce
  17291   "^DD",9000 010.707,90 00010.707, 80102,21,3 ,0)
  17292   file_"-"_A  for Add o r E for Ed it_" "_DUZ  of the pe rson who e ntered the
  17293   "^DD",9000 010.707,90 00010.707, 80102,21,4 ,0)
  17294   data_";".. .
  17295   "^DD",9000 010.707,90 00010.707, 80102,23,0 )
  17296   ^^15^15^31 51112^
  17297   "^DD",9000 010.707,90 00010.707, 80102,23,1 ,0)
  17298   The PCE fi ling logic  requires  a pointer  to the PCE  data sour ce file. I f
  17299   "^DD",9000 010.707,90 00010.707, 80102,23,2 ,0)
  17300   this is no t passed,  then PCE f iling logi c will not  process t he data.
  17301   "^DD",9000 010.707,90 00010.707, 80102,23,3 ,0)
  17302  
  17303   "^DD",9000 010.707,90 00010.707, 80102,23,4 ,0)
  17304   If the rec ord is a n ew record,  then an " A" is used  to specif y the
  17305   "^DD",9000 010.707,90 00010.707, 80102,23,5 ,0)
  17306   source tha t added th e data.  I f the reco rd existed  previousl y, PCE
  17307   "^DD",9000 010.707,90 00010.707, 80102,23,6 ,0)
  17308   filing log ic compare s the old  and new re cords of i nformation .  An "E"
  17309   "^DD",9000 010.707,90 00010.707, 80102,23,7 ,0)
  17310   will be au tomaticall y used if  the filing  logic fin ds the dat a has been
  17311   "^DD",9000 010.707,90 00010.707, 80102,23,8 ,0)
  17312   edited.  I f "E" is u sed, then  the Edited  Flag fiel d is autom atically s et
  17313   "^DD",9000 010.707,90 00010.707, 80102,23,9 ,0)
  17314   to 1.
  17315   "^DD",9000 010.707,90 00010.707, 80102,23,1 0,0)
  17316  
  17317   "^DD",9000 010.707,90 00010.707, 80102,23,1 1,0)
  17318   The DUZ is  stored in  its inter nal format  to repres ent the us er who
  17319   "^DD",9000 010.707,90 00010.707, 80102,23,1 2,0)
  17320   performed  the adding  or editin g of data  for this r ecord.
  17321   "^DD",9000 010.707,90 00010.707, 80102,23,1 3,0)
  17322  
  17323   "^DD",9000 010.707,90 00010.707, 80102,23,1 4,0)
  17324   Iterations  of editin g will be  concatenat ed to the  previous d ata source
  17325   "^DD",9000 010.707,90 00010.707, 80102,23,1 5,0)
  17326   value, up  to 85 char acters.
  17327   "^DD",9000 010.707,90 00010.707, 80102,"AUD IT")
  17328   y
  17329   "^DD",9000 010.707,90 00010.707, 80102,"DT" )
  17330   3151112
  17331   "^DD",9000 010.707,90 00010.707, 81101,0)
  17332   COMMENTS^F a^^811;1^K :$L(X)>245 !($L(X)<1)  X
  17333   "^DD",9000 010.707,90 00010.707, 81101,.1)
  17334   Comments
  17335   "^DD",9000 010.707,90 00010.707, 81101,3)
  17336   Answer mus t be 1-245  character s in lengt h.
  17337   "^DD",9000 010.707,90 00010.707, 81101,21,0 )
  17338   ^^2^2^3151 112^
  17339   "^DD",9000 010.707,90 00010.707, 81101,21,1 ,0)
  17340   This is a  comment re lated to t his contra indication /refusal e vent. The
  17341   "^DD",9000 010.707,90 00010.707, 81101,21,2 ,0)
  17342   provider m ay enter t his manual ly via the  PCE User  Interface.
  17343   "^DD",9000 010.707,90 00010.707, 81101,"AUD IT")
  17344   y
  17345   "^DD",9000 010.707,90 00010.707, 81101,"DT" )
  17346   3151112
  17347   "^DD",9000 010.707,90 00010.707, 81201,0)
  17348   VERIFIED^S a^1:ELECTR ONICALLY S IGNED;2:VE RIFIED BY  PACKAGE;^8 12;1^Q
  17349   "^DD",9000 010.707,90 00010.707, 81201,3)
  17350   Enter 1 if  verified  by electro nic signat ure or 2 i f verified  by packag e.
  17351   "^DD",9000 010.707,90 00010.707, 81201,21,0 )
  17352   ^^2^2^3160 310^
  17353   "^DD",9000 010.707,90 00010.707, 81201,21,1 ,0)
  17354   This is us ed to note  how the e vent was v erified an d is autom atically
  17355   "^DD",9000 010.707,90 00010.707, 81201,21,2 ,0)
  17356   entered by  the softw are.
  17357   "^DD",9000 010.707,90 00010.707, 81201,23,0 )
  17358   ^^2^2^3160 310^
  17359   "^DD",9000 010.707,90 00010.707, 81201,23,1 ,0)
  17360   This is au tomaticall y entered  by the sof tware and  is unedita ble by
  17361   "^DD",9000 010.707,90 00010.707, 81201,23,2 ,0)
  17362   users.
  17363   "^DD",9000 010.707,90 00010.707, 81201,"AUD IT")
  17364   y
  17365   "^DD",9000 010.707,90 00010.707, 81201,"DT" )
  17366   3160310
  17367   "^DD",9000 010.707,90 00010.707, 81202,0)
  17368   PACKAGE^P9 .4'a^DIC(9 .4,^812;2^ Q
  17369   "^DD",9000 010.707,90 00010.707, 81202,3)
  17370   Enter the  VistA pack age from w hich this  record ori ginated.
  17371   "^DD",9000 010.707,90 00010.707, 81202,21,0 )
  17372   ^^2^2^3160 310^
  17373   "^DD",9000 010.707,90 00010.707, 81202,21,1 ,0)
  17374   This is th e VistA pa ckage from  which thi s immuniza tion recor d originat ed
  17375   "^DD",9000 010.707,90 00010.707, 81202,21,2 ,0)
  17376   through PC E.
  17377   "^DD",9000 010.707,90 00010.707, 81202,23,0 )
  17378   ^^2^2^3160 310^
  17379   "^DD",9000 010.707,90 00010.707, 81202,23,1 ,0)
  17380   This is au tomaticall y entered  by the sof tware and  is unedita ble by
  17381   "^DD",9000 010.707,90 00010.707, 81202,23,2 ,0)
  17382   users.
  17383   "^DD",9000 010.707,90 00010.707, 81202,"AUD IT")
  17384   y
  17385   "^DD",9000 010.707,90 00010.707, 81202,"DT" )
  17386   3160310
  17387   "^DD",9000 010.707,90 00010.707, 81203,0)
  17388   DATA SOURC E^P839.7'a ^PX(839.7, ^812;3^Q
  17389   "^DD",9000 010.707,90 00010.707, 81203,3)
  17390   Select the  data sour ce for thi s contrain dication/r efusal eve nt.
  17391   "^DD",9000 010.707,90 00010.707, 81203,21,0 )
  17392   ^^2^2^3151 112^
  17393   "^DD",9000 010.707,90 00010.707, 81203,21,1 ,0)
  17394   This is th e data sou rce for th is event,  automatica lly entere d through  the
  17395   "^DD",9000 010.707,90 00010.707, 81203,21,2 ,0)
  17396   PCE softwa re and une ditable by  users.
  17397   "^DD",9000 010.707,90 00010.707, 81203,"AUD IT")
  17398   y
  17399   "^DD",9000 010.707,90 00010.707, 81203,"DT" )
  17400   3151112
  17401   "^DD",9999 999.41,999 9999.41,.1 8,0)
  17402   NDC CODE ( VA)^FaXO^^ 0;18^D P01 ^PXVNDC
  17403   "^DD",9999 999.41,999 9999.41,.1 8,.1)
  17404   NDC Code
  17405   "^DD",9999 999.41,999 9999.41,.1 8,2)
  17406   S Y(0)=Y S :Y Y=$$NDC OUT^PXVNDC (Y)
  17407   "^DD",9999 999.41,999 9999.41,.1 8,2.1)
  17408   S:Y Y=$$ND COUT^PXVND C(Y)
  17409   "^DD",9999 999.41,999 9999.41,.1 8,3)
  17410   Enter the  National D rug Code ( NDC) for t his lot.
  17411   "^DD",9999 999.41,999 9999.41,.1 8,4)
  17412   D QUEST^PX VNDC
  17413   "^DD",9999 999.41,999 9999.41,.1 8,21,0)
  17414   ^^1^1^3160 209^
  17415   "^DD",9999 999.41,999 9999.41,.1 8,21,1,0)
  17416   This is th e National  Drug Code  (NDC) for  this lot.
  17417   "^DD",9999 999.41,999 9999.41,.1 8,"AUDIT")
  17418   y
  17419   "^DD",9999 999.41,999 9999.41,.1 8,"DT")
  17420   3160217
  17421   "^DIC",811 .1,811.1,0 )
  17422   PCE CODE M APPING^811 .1IV
  17423   "^DIC",811 .1,811.1,0 ,"GL")
  17424   ^PXD(811.1 ,
  17425   "^DIC",811 .1,811.1," %",0)
  17426   ^1.005^^0
  17427   "^DIC",811 .1,811.1," %D",0)
  17428   ^^7^7^3160 314^
  17429   "^DIC",811 .1,811.1," %D",1,0)
  17430   This file  is used to  map entri es from tw o differen t file to  each other .
  17431   "^DIC",811 .1,811.1," %D",2,0)
  17432   It functio ns as a ta ble.
  17433   "^DIC",811 .1,811.1," %D",3,0)
  17434  
  17435   "^DIC",811 .1,811.1," %D",4,0)
  17436   NOTE: As o f patch PX *1.0*215,  this file  has been s uperseded.  The mappi ngs
  17437   "^DIC",811 .1,811.1," %D",5,0)
  17438   of immuniz ations and  skin test s to CPT c odes are n ow contain ed in the
  17439   "^DIC",811 .1,811.1," %D",6,0)
  17440   CODING SYS TEM multip le of the  IMMUNIZATI ON (#99999 99.14) and  SKIN TEST
  17441   "^DIC",811 .1,811.1," %D",7,0)
  17442   (#9999999. 28) files  themselves .
  17443   "^DIC",811 .1,"B","PC E CODE MAP PING",811. 1)
  17444  
  17445   "^DIC",920 .05,920.05 ,0)
  17446   IMM DEFAUL T RESPONSE S^920.05
  17447   "^DIC",920 .05,920.05 ,0,"GL")
  17448   ^PXV(920.0 5,
  17449   "^DIC",920 .05,920.05 ,"%",0)
  17450   ^1.005^^0
  17451   "^DIC",920 .05,920.05 ,"%D",0)
  17452   ^1.001^2^2 ^3160307^^
  17453   "^DIC",920 .05,920.05 ,"%D",1,0)
  17454   This file  stores the  facility  default re sponses fo r data pro mpts in th e
  17455   "^DIC",920 .05,920.05 ,"%D",2,0)
  17456   immunizati on data en try proces s.
  17457   "^DIC",920 .05,"B","I MM DEFAULT  RESPONSES ",920.05)
  17458  
  17459   "^DIC",920 .6,920.6,0 )
  17460   IMM ROUTES  TO SITES^ 920.6
  17461   "^DIC",920 .6,920.6,0 ,"GL")
  17462   ^PXV(920.6 ,
  17463   "^DIC",920 .6,920.6," %",0)
  17464   ^1.005^^
  17465   "^DIC",920 .6,920.6," %D",0)
  17466   ^^2^2^3160 114^
  17467   "^DIC",920 .6,920.6," %D",1,0)
  17468   This file  contains a  mapping o f applicab le immuniz ation admi nistration
  17469   "^DIC",920 .6,920.6," %D",2,0)
  17470   sites for  a given ad ministrati on route.
  17471   "^DIC",920 .6,"B","IM M ROUTES T O SITES",9 20.6)
  17472  
  17473   "^DIC",900 0010.11,90 00010.11,0 )
  17474   V IMMUNIZA TION^90000 10.11IP
  17475   "^DIC",900 0010.11,90 00010.11,0 ,"GL")
  17476   ^AUPNVIMM(
  17477   "^DIC",900 0010.11,90 00010.11," %",0)
  17478   ^1.005^^0
  17479   "^DIC",900 0010.11,90 00010.11," %D",0)
  17480   ^^18^18^31 60328^
  17481   "^DIC",900 0010.11,90 00010.11," %D",1,0)
  17482   In order t o preserve  the conti nuity of f iles share d by the I ndian Heal th
  17483   "^DIC",900 0010.11,90 00010.11," %D",2,0)
  17484   Service an d the Depa rtment of  Veterans A ffairs, th is file in cludes fie lds
  17485   "^DIC",900 0010.11,90 00010.11," %D",3,0)
  17486   used by In dian Healt h Service  that will  not be use d by the D epartment  of
  17487   "^DIC",900 0010.11,90 00010.11," %D",4,0)
  17488   Veterans A ffairs. Th ese fields  may point  to other  files and  routines n ot
  17489   "^DIC",900 0010.11,90 00010.11," %D",5,0)
  17490   deployed b y the Depa rtment of  Veterans A ffairs. In clusion of  these fie lds,
  17491   "^DIC",900 0010.11,90 00010.11," %D",6,0)
  17492   as designe d, was app roved by t he DBA.  T hese field s were ini tially
  17493   "^DIC",900 0010.11,90 00010.11," %D",7,0)
  17494   introduced  with the  release of  the VISTA  IMMUNIZAT ION ENHANC EMENTS 1.0
  17495   "^DIC",900 0010.11,90 00010.11," %D",8,0)
  17496   (PX*1*201)  for the V istA Immun ization En hancements  Project.   Additiona l
  17497   "^DIC",900 0010.11,90 00010.11," %D",9,0)
  17498   fields may  be includ ed in late r enhancem ents.
  17499   "^DIC",900 0010.11,90 00010.11," %D",10,0)
  17500  
  17501   "^DIC",900 0010.11,90 00010.11," %D",11,0)
  17502   This file  contains i mmunizatio ns specifi c to a par ticular vi sit for a
  17503   "^DIC",900 0010.11,90 00010.11," %D",12,0)
  17504   particular  patient.   This file  contains  one record  for each  immunizati on.
  17505   "^DIC",900 0010.11,90 00010.11," %D",13,0)
  17506  
  17507   "^DIC",900 0010.11,90 00010.11," %D",14,0)
  17508   In the VA,  if an imm unization  is entered  into PCE  that has a  related C PT
  17509   "^DIC",900 0010.11,90 00010.11," %D",15,0)
  17510   or ICD cod e, then a  V CPT or V  POV entry  will auto matically  be created
  17511   "^DIC",900 0010.11,90 00010.11," %D",16,0)
  17512   with the C PT or ICD  code for t he immuniz ation.  Th e CODING S YSTEM mult iple
  17513   "^DIC",900 0010.11,90 00010.11," %D",17,0)
  17514   of the IMM UNIZATION  file (#999 9999.14) c ontains th e definiti ons of wha t
  17515   "^DIC",900 0010.11,90 00010.11," %D",18,0)
  17516   immunizati on is rela ted to wha t CPT and  ICD codes.
  17517   "^DIC",900 0010.11,"B ","V IMMUN IZATION",9 000010.11)
  17518  
  17519   "^DIC",900 0010.12,90 00010.12,0 )
  17520   V SKIN TES T^9000010. 12IP
  17521   "^DIC",900 0010.12,90 00010.12,0 ,"GL")
  17522   ^AUPNVSK(
  17523   "^DIC",900 0010.12,90 00010.12," %",0)
  17524   ^1.005^^
  17525   "^DIC",900 0010.12,90 00010.12," %D",0)
  17526   ^^14^14^31 60328^
  17527   "^DIC",900 0010.12,90 00010.12," %D",1,0)
  17528   This file  has been d esigned fo r joint us e by the I ndian Heal th Service  and
  17529   "^DIC",900 0010.12,90 00010.12," %D",2,0)
  17530   the Depart ment of Ve teran Affa irs. There  will be o ne record  for each t ype
  17531   "^DIC",900 0010.12,90 00010.12," %D",3,0)
  17532   of skin te st given t o a patien t on a giv en visit.   Data must  exist for  a
  17533   "^DIC",900 0010.12,90 00010.12," %D",4,0)
  17534   patient an d a visit  before dat a can be e ntered her e.  The re cord is
  17535   "^DIC",900 0010.12,90 00010.12," %D",5,0)
  17536   normally c reated whe n a skin t est is giv en, and th e results,  if availa ble,
  17537   "^DIC",900 0010.12,90 00010.12," %D",6,0)
  17538   are entere d at a lat er date an d matched  to the ori ginal reco rd.  If
  17539   "^DIC",900 0010.12,90 00010.12," %D",7,0)
  17540   results ar e entered  and a skin  test give n does not  exist, a  new record  is
  17541   "^DIC",900 0010.12,90 00010.12," %D",8,0)
  17542   created.
  17543   "^DIC",900 0010.12,90 00010.12," %D",9,0)
  17544  
  17545   "^DIC",900 0010.12,90 00010.12," %D",10,0)
  17546   In the VA,  if a skin  test is e ntered int o PCE that  has a rel ated CPT o r
  17547   "^DIC",900 0010.12,90 00010.12," %D",11,0)
  17548   ICD code,  then a CPT  or ICD en try will a utomatical ly be ente red into t he V
  17549   "^DIC",900 0010.12,90 00010.12," %D",12,0)
  17550   CPT or V P OV file.   This suppo rts gettin g workload  credit fr om clinica l
  17551   "^DIC",900 0010.12,90 00010.12," %D",13,0)
  17552   activities . The CODI NG SYSTEM  multiple o f the SKIN  TEST file  (#9999999 .28)
  17553   "^DIC",900 0010.12,90 00010.12," %D",14,0)
  17554   defines th e relation ships betw een Skin T ests and C PT and ICD  codes.
  17555   "^DIC",900 0010.12,"B ","V SKIN  TEST",9000 010.12)
  17556  
  17557   "^DIC",900 0010.707,9 000010.707 ,0)
  17558   V IMM CONT RA/REFUSAL  EVENTS^90 00010.707
  17559   "^DIC",900 0010.707,9 000010.707 ,0,"GL")
  17560   ^AUPNVICR(
  17561   "^DIC",900 0010.707,9 000010.707 ,"%",0)
  17562   ^1.005^^0
  17563   "^DIC",900 0010.707,9 000010.707 ,"%D",0)
  17564   ^^4^4^3151 117^
  17565   "^DIC",900 0010.707,9 000010.707 ,"%D",1,0)
  17566   This file  is used to  document  immunizati on non-adm inistratio n events,
  17567   "^DIC",900 0010.707,9 000010.707 ,"%D",2,0)
  17568   capturing  the reason s for not  administer ing immuni zations, e ither that
  17569   "^DIC",900 0010.707,9 000010.707 ,"%D",3,0)
  17570   administra tion was c ontraindic ated or th at it was  refused by  the
  17571   "^DIC",900 0010.707,9 000010.707 ,"%D",4,0)
  17572   patient.
  17573   "^DIC",900 0010.707," B","V IMM  CONTRA/REF USAL EVENT S",9000010 .707)
  17574  
  17575   "BLD",9218 ,6)
  17576   3^
  17577   **END**
  17578   **END**