2. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 4/19/2019 10:41:57 AM Eastern 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.

2.1 Files compared

# Location File Last Modified
1 Build 11, Sprint 32-36.zip CPEEDI_1_0_014_V3.KIDS Fri Apr 19 12:25:06 2019 UTC
2 Build 11, Sprint 32-36.zip CPEEDI_1_0_014_V3.KIDS Fri Apr 19 12:52:52 2019 UTC

2.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 8 109018
Changed 7 14
Inserted 0 0
Removed 0 0

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

2.4 Active regular expressions

No regular expressions were active.

2.5 Comparison detail

  1   KIDS Distr ibution sa ved on Mar  20, 2019@ 06:59:54
  2   Build supp orts EDI-R eopen defe cts
  3   **KIDS**:C PEEDI*1.0* 014^
  4  
  5   **INSTALL  NAME**
  6   CPEEDI*1.0 *014
  7   "BLD",1004 2,0)
  8   CPEEDI*1.0 *014^^0^31 90320^n
  9   "BLD",1004 2,1,0)
  10   ^^304^304^ 3190319^^
  11   "BLD",1004 2,1,1,0)
  12   The Vetera ns Health  Administra tion Offic e of Commu nity Care  (VHA OCC)
  13   "BLD",1004 2,1,2,0)
  14   in Denver,  Colo., Ch ampVA Heal th Care Be nefits Pro gram, prov ides for
  15   "BLD",1004 2,1,3,0)
  16   the author ization of  benefits  and the su bsequent p rocessing  and paymen t
  17   "BLD",1004 2,1,4,0)
  18   of health  care claim s after a  determinat ion of eli gibility h as been
  19   "BLD",1004 2,1,5,0)
  20   made by th e Denver V A Regional  Office (V ARO).
  21   "BLD",1004 2,1,6,0)
  22    
  23   "BLD",1004 2,1,7,0)
  24   This patch  supports  the follow ing EDI-Re open defec ts:
  25   "BLD",1004 2,1,8,0)
  26    
  27   "BLD",1004 2,1,9,0)
  28   * Defect 9 45962 Defe ct CPE005- 049 - EE S creen Bill /Invoice O rder of 
  29   "BLD",1004 2,1,10,0)
  30   Display_De ntal  FAIL ED
  31   "BLD",1004 2,1,11,0)
  32   * Defect 9 32475 CPE0 05-040 - F C=5, null  original P DI
  33   "BLD",1004 2,1,12,0)
  34   * Defect 9 31401 CPE0 05-024 a2/ b2: Aging  Report_Dat a Validati on" failed
  35   "BLD",1004 2,1,13,0)
  36   for both C VA and SB
  37   "BLD",1004 2,1,14,0)
  38   * Defect 9 29150 CPE0 05-029 and  030 SU Pr oductivity  Report In dividual a nd 
  39   "BLD",1004 2,1,15,0)
  40   Summary -  No file ge nerated
  41   "BLD",1004 2,1,16,0)
  42   * Defect 9 29105 Fail ing Test C ase 'CPEE  FTC SQA_CP E005-100:  Invoke New  
  43   "BLD",1004 2,1,17,0)
  44   Reason Cod e Correcti on to a pr eviously p rocessed s ubmission'
  45   "BLD",1004 2,1,18,0)
  46   --- This D efect requ ires a Man ual Load f or codes 4 05, CORREC TION TO -- -
  47   "BLD",1004 2,1,19,0)
  48   --- SUBMIS SION:, and  406, PAYM ENT PROVID ED PREVIOU SLY:           
  49   "BLD",1004 2,1,20,0)
  50   * Defect 9 19238 CPE0 05-023/023 a Daily Ho urly Proce ssing Repo rt-NO EDI  RO 
  51   "BLD",1004 2,1,21,0)
  52   info on th e screen
  53   "BLD",1004 2,1,22,0)
  54   * Defect 9 17633 Unab le to acce ss CRSR Cl aim Reject  Statistic s Report [ CHM 
  55   "BLD",1004 2,1,23,0)
  56   CLAIM STAT ISTICS] 50 10 277 ACK NOWLEDGEME NT STATIST ICS REPORT  in 
  57   "BLD",1004 2,1,24,0)
  58   TESTACKNOW LEDGEMENT  STATISTICS  REPORT in  TEST
  59   "BLD",1004 2,1,25,0)
  60   * Defect 9 14090 CPE0 05-001 Pro gram Indic ator FTC S QA
  61   "BLD",1004 2,1,26,0)
  62   * Defect 9 13926 EDI  Reopen Tri ggered Rev ersal - Mi ssing PDI  and Claim 
  63   "BLD",1004 2,1,27,0)
  64   statuses:  Voided and  Reversed
  65   "BLD",1004 2,1,28,0)
  66   * Defect 9 13649  CPE 005-038 FC  8 Origina l PDI Not  Started Pr ocessing 
  67   "BLD",1004 2,1,29,0)
  68   CSTAT mess age status  code NOT  right
  69   "BLD",1004 2,1,30,0)
  70   * Defect 9 12808 CPEE  FTC SQA_C PE005-119:  Manual ED I Autoload  Current 
  71   "BLD",1004 2,1,31,0)
  72   PDI_RPP ME NU NOT WOR KING
  73   "BLD",1004 2,1,32,0)
  74   * Defect 9 11078 FC 8  Original  PDI Is Not  Valid no  rejection  code in ED
  75   "BLD",1004 2,1,33,0)
  76   Buffer Fil e Lookup
  77   "BLD",1004 2,1,34,0)
  78   * Defect 9 10446 FC 8  Original  PDI Comple te - No me ssage "Do  you want t
  79   "BLD",1004 2,1,35,0)
  80   initiate a  Reversal?  Y/N:"
  81   "BLD",1004 2,1,36,0)
  82   * Defect 9 08154 "CPE E FTC SQA_ CPE005-040  Original  PDI Null w ith FC5" n ot 
  83   "BLD",1004 2,1,37,0)
  84   generate f ront end e dit
  85   "BLD",1004 2,1,38,0)
  86   * Defect 9 05019 FC=6  should ge nerate a f ront end e dit, and n ot create 
  87   "BLD",1004 2,1,39,0)
  88   ReOpen PDI (97)
  89   "BLD",1004 2,1,40,0)
  90   * Defect 8 88373 Erro r generate d when VE  skipped th e incomple te PDI.
  91   "BLD",1004 2,1,41,0)
  92   * Defect 8 88337 when  select ER  for reope n manual E DI, user n ot able to  
  93   "BLD",1004 2,1,42,0)
  94   tab 2 goin g to next  screen
  95   "BLD",1004 2,1,43,0)
  96   * Defect 8 88251 Vend or info no t showing  on PPR or  CEU vendor  data scre en 
  97   "BLD",1004 2,1,44,0)
  98   for Spina  Bifida cla ims
  99   "BLD",1004 2,1,45,0)
  100   * Defect 8 80250 New  Reason Cod es 404, 40 5, 406 do  not exist  in the SQA  
  101   "BLD",1004 2,1,46,0)
  102   Test Accou nt
  103   "BLD",1004 2,1,47,0)
  104    
  105   "BLD",1004 2,1,48,0)
  106    
  107   "BLD",1004 2,1,49,0)
  108    Patch Com ponents:
  109   "BLD",1004 2,1,50,0)
  110    --------- --------
  111   "BLD",1004 2,1,51,0)
  112    Files & F ields Asso ciated: 
  113   "BLD",1004 2,1,52,0)
  114     
  115   "BLD",1004 2,1,53,0)
  116    File Name  (Number)           F ield Name  (Number)    New/Modif ied/Delete d
  117   "BLD",1004 2,1,54,0)
  118    --------- ---------- -----    - ---------- --------    --------- ---------- -
  119   "BLD",1004 2,1,55,0)
  120    CHAMPVA C LAIMS (741 000)     P L ZIP (800 .105)       New 
  121   "BLD",1004 2,1,56,0)
  122                                  C LAIM STATU S (.02)     Modified
  123   "BLD",1004 2,1,57,0)
  124    
  125   "BLD",1004 2,1,58,0)
  126    CHAMPVA S TORED IMAG ES       S TATUS OF P DI (.06)    Modified
  127   "BLD",1004 2,1,59,0)
  128     (741000. 2)
  129   "BLD",1004 2,1,60,0)
  130                                  D ATE REVERS E           New
  131   "BLD",1004 2,1,61,0)
  132                                      COMPLETE D (.22)
  133   "BLD",1004 2,1,62,0)
  134                                  P REVIOUS PD I (20)      New
  135   "BLD",1004 2,1,63,0)
  136                                  N EW PDI (21 )           New
  137   "BLD",1004 2,1,64,0)
  138                                  R EOPEN FLAG  (22)       New
  139   "BLD",1004 2,1,65,0)
  140    
  141   "BLD",1004 2,1,66,0)
  142    TRACK EDI -PAUSE TIM E        T IME SET TO  EDI-PAUSE  New
  143   "BLD",1004 2,1,67,0)
  144      (741000 .35)                   (.01)   
  145   "BLD",1004 2,1,68,0)
  146                                  D UZ (1)                 New
  147   "BLD",1004 2,1,69,0)
  148                                  T IME REMOVE D FROM      New
  149   "BLD",1004 2,1,70,0)
  150                                      EDI-PAUS E (2)
  151   "BLD",1004 2,1,71,0)
  152                                  O RIG PDI PA Y REQ       New
  153   "BLD",1004 2,1,72,0)
  154                                      CLAIM NU MS (3)
  155   "BLD",1004 2,1,73,0)
  156    
  157   "BLD",1004 2,1,74,0)
  158    CHAMPVA V ENDOR (741 001)     D ATE INACTI VATED       New
  159   "BLD",1004 2,1,75,0)
  160                                      (8.01)
  161   "BLD",1004 2,1,76,0)
  162    
  163   "BLD",1004 2,1,77,0)
  164    
  165   "BLD",1004 2,1,78,0)
  166    CHAMPVA U SER FILE            O RIGINAL PD I (3)       New
  167   "BLD",1004 2,1,79,0)
  168       (74100 2.21)
  169   "BLD",1004 2,1,80,0)
  170                                  D UPLICATE C LEANUP      New
  171   "BLD",1004 2,1,81,0)
  172                                      USER (8. 02)
  173   "BLD",1004 2,1,82,0)
  174    
  175   "BLD",1004 2,1,83,0)
  176    CHAMPVA S TATUS REAS ON 
  177   "BLD",1004 2,1,84,0)
  178    DICTIONAR Y (741002. 22)
  179   "BLD",1004 2,1,85,0)
  180    
  181   "BLD",1004 2,1,86,0)
  182    CHAMPVA R EASON CROS
  183   "BLD",1004 2,1,87,0)
  184    REFERENCE
  185   "BLD",1004 2,1,88,0)
  186          (74 1002.34)      
  187   "BLD",1004 2,1,89,0)
  188    
  189   "BLD",1004 2,1,90,0)
  190    CHAMPVA B ARCODE LAB EL 
  191   "BLD",1004 2,1,91,0)
  192    TYPES (74 1002.93)     
  193   "BLD",1004 2,1,92,0)
  194                            
  195   "BLD",1004 2,1,93,0)
  196    CLAIM ADJ USTMENT GR OUP 
  197   "BLD",1004 2,1,94,0)
  198    CODES (74 1201.15)                               
  199   "BLD",1004 2,1,95,0)
  200    
  201   "BLD",1004 2,1,96,0)
  202    CLAIM ADJ USTMENT RE ASON 
  203   "BLD",1004 2,1,97,0)
  204    CODES (74 1201.16)                              
  205   "BLD",1004 2,1,98,0)
  206    
  207   "BLD",1004 2,1,99,0)
  208    CLAIM PAY MENT REMAR K CODES
  209   "BLD",1004 2,1,100,0)
  210    (741201.5 8)                                  
  211   "BLD",1004 2,1,101,0)
  212    
  213   "BLD",1004 2,1,102,0)
  214    EOB REASO N/X12 CROS S WALK      
  215   "BLD",1004 2,1,103,0)
  216    (741201.7 7)                                    
  217   "BLD",1004 2,1,104,0)
  218    
  219   "BLD",1004 2,1,105,0)
  220    X12 837 V 5010 CLAIM  RECORD 
  221   "BLD",1004 2,1,106,0)
  222    LAYOUT (7 41211.03)                                 
  223   "BLD",1004 2,1,107,0)
  224    
  225   "BLD",1004 2,1,108,0)
  226    Final CST AT Alert ( 741213)                                                 
  227   "BLD",1004 2,1,109,0)
  228    
  229   "BLD",1004 2,1,110,0)
  230    Reversing  835 Alert                                                 
  231   "BLD",1004 2,1,111,0)
  232    (741215)
  233   "BLD",1004 2,1,112,0)
  234    
  235   "BLD",1004 2,1,113,0)
  236    
  237   "BLD",1004 2,1,114,0)
  238    Routine I nformation :
  239   "BLD",1004 2,1,115,0)
  240    --------- ---------- ---------
  241   "BLD",1004 2,1,116,0)
  242                     Che cksums
  243   "BLD",1004 2,1,117,0)
  244   Routine          Old          Ne w        P atch List
  245   "BLD",1004 2,1,118,0)
  246   CH835F1          n/a       77056 1458   **1 ,14**
  247   "BLD",1004 2,1,119,0)
  248   CH835TRG         n/a        1086 165    **1 ,14**
  249   "BLD",1004 2,1,120,0)
  250   CHCSTAT          n/a        1099 344    **1 ,14**
  251   "BLD",1004 2,1,121,0)
  252   CHFBC1           n/a       11807 1981   **1 ,9,14**
  253   "BLD",1004 2,1,122,0)
  254   CHFBC1D          n/a       79160 574    **1 ,14**
  255   "BLD",1004 2,1,123,0)
  256   CHFBC1E          n/a       86804 463    **1 ,14**
  257   "BLD",1004 2,1,124,0)
  258   CHFBC2A          n/a       28422 7801   **1 ,11,14**
  259   "BLD",1004 2,1,125,0)
  260   CHFBCQ           n/a       20670 0247   **1 ,14**
  261   "BLD",1004 2,1,126,0)
  262   CHGAS2           n/a       11549 3168   **1 ,14**
  263   "BLD",1004 2,1,127,0)
  264   CHGAS22          n/a       73431 822    **1 ,11,14**
  265   "BLD",1004 2,1,128,0)
  266   CHGAS23          n/a       63174 125    **1 ,14**
  267   "BLD",1004 2,1,129,0)
  268   CHGASIP          n/a       60716 419    **1 ,11,14**
  269   "BLD",1004 2,1,130,0)
  270   CHGASP           n/a       86304 290    **1 ,11,14**
  271   "BLD",1004 2,1,131,0)
  272   CHGASP1          n/a       40517 172    **1 ,11,14**
  273   "BLD",1004 2,1,132,0)
  274   CHGASP2          n/a       34812 978    **1 ,14**
  275   "BLD",1004 2,1,133,0)
  276   CHGCDC71         n/a       36256 173    **1 ,14**
  277   "BLD",1004 2,1,134,0)
  278   CHGCDC75         n/a       29365 743    **1 ,14**
  279   "BLD",1004 2,1,135,0)
  280   CHGCDP7          n/a       70182 755    **1 ,14**
  281   "BLD",1004 2,1,136,0)
  282   CHGCDP70         n/a       69672 244    **1 ,14**
  283   "BLD",1004 2,1,137,0)
  284   CHGCDP71         n/a        6472 840    **1 ,14**
  285   "BLD",1004 2,1,138,0)
  286   CHGCDP73         n/a        9545 809    **1 ,14**
  287   "BLD",1004 2,1,139,0)
  288   CHGCDV7          n/a       84573 137    **1 ,14**
  289   "BLD",1004 2,1,140,0)
  290   CHGCDV70         n/a       80233 452    **1 ,11,14**
  291   "BLD",1004 2,1,141,0)
  292   CHGCDV71         n/a       97858 452    **1 ,14**
  293   "BLD",1004 2,1,142,0)
  294   CHGCDV73         n/a       41057 918    **1 ,14**
  295   "BLD",1004 2,1,143,0)
  296   CHGCPRD1         n/a       75154 897    **1 4**
  297   "BLD",1004 2,1,144,0)
  298   CHGCPRD3         n/a       55612 408    **1 4**
  299   "BLD",1004 2,1,145,0)
  300   CHGCU136         n/a       38195 134    **1 ,11,14**
  301   "BLD",1004 2,1,146,0)
  302   CHGCU165         n/a       21489 649    **1 ,14**
  303   "BLD",1004 2,1,147,0)
  304   CHGDQ2           n/a       15600 1132   **1 ,11,14**
  305   "BLD",1004 2,1,148,0)
  306   CHGQA2           n/a       10563 5204   **1 ,11,14**
  307   "BLD",1004 2,1,149,0)
  308   CHGVQ370         n/a       19358 8907   **1 ,14**
  309   "BLD",1004 2,1,150,0)
  310   CHGVQ529         n/a       96573 340    **1 ,8,14**
  311   "BLD",1004 2,1,151,0)
  312   CHIGDQ3          n/a       92490 075    **1 ,14**
  313   "BLD",1004 2,1,152,0)
  314   CHIGDQ30         n/a       93005 718    **1 ,14**
  315   "BLD",1004 2,1,153,0)
  316   CHMEAE5          n/a       66632 491    **1 ,7,14**
  317   "BLD",1004 2,1,154,0)
  318   CHMF351D         n/a       92005 416    **1 ,14**
  319   "BLD",1004 2,1,155,0)
  320   CHMF351P         n/a       16058 3754   **1 ,14**
  321   "BLD",1004 2,1,156,0)
  322   CHMF351U         n/a       18859 9366   **1 ,14**
  323   "BLD",1004 2,1,157,0)
  324   CHMFA001         n/a       72728 138    **1 ,8,14**
  325   "BLD",1004 2,1,158,0)
  326   CHMFA002         n/a        6171 486    **1 ,14**
  327   "BLD",1004 2,1,159,0)
  328   CHMFA008         n/a       70659 720    **1 ,14**
  329   "BLD",1004 2,1,160,0)
  330   CHMFA010         n/a       18328 8112   **1 ,14**
  331   "BLD",1004 2,1,161,0)
  332   CHMFA011         n/a       10964 1227   **1 ,8,14**
  333   "BLD",1004 2,1,162,0)
  334   CHMFA012         n/a        5938 662    **1 ,14**
  335   "BLD",1004 2,1,163,0)
  336   CHMFA013         n/a       31867 973    **1 ,14**
  337   "BLD",1004 2,1,164,0)
  338   CHMFA01E         n/a       56185 655    **1 ,8,14**
  339   "BLD",1004 2,1,165,0)
  340   CHMFA01F         n/a       11506 960    **1 ,14**
  341   "BLD",1004 2,1,166,0)
  342   CHMFA020         n/a       46913 361    **1 ,14**
  343   "BLD",1004 2,1,167,0)
  344   CHMFA02E         n/a        1591 638    **1 ,14**
  345   "BLD",1004 2,1,168,0)
  346   CHMFA110         n/a       24048 241    **1 ,14**
  347   "BLD",1004 2,1,169,0)
  348   CHMFA141         n/a       12711 09246  **1 ,14**
  349   "BLD",1004 2,1,170,0)
  350   CHMFA150         n/a       14196 240    **1 ,14**
  351   "BLD",1004 2,1,171,0)
  352   CHMFA801         n/a       48824 212    **1 ,14**
  353   "BLD",1004 2,1,172,0)
  354   CHMFADR1         n/a       12724 2208   **1 ,14**
  355   "BLD",1004 2,1,173,0)
  356   CHMFADR2         n/a       31316 0862   **1 4**
  357   "BLD",1004 2,1,174,0)
  358   CHMFADR4         n/a       26793 4873   **1 ,14**
  359   "BLD",1004 2,1,175,0)
  360   CHMFADRV         n/a       95653 305    **1 ,12,14**
  361   "BLD",1004 2,1,176,0)
  362   CHMFAUT1         n/a       99384 3228   **1 4**
  363   "BLD",1004 2,1,177,0)
  364   CHMFBC1          n/a       71408 427    **1 4**
  365   "BLD",1004 2,1,178,0)
  366   CHMFBC2A         n/a       59668 588    **1 1,14**
  367   "BLD",1004 2,1,179,0)
  368   CHMFEDISTP 1     n/a       26899 310    **1 4**
  369   "BLD",1004 2,1,180,0)
  370   CHMFEDISTP 2     n/a        5893 228    **1 4**
  371   "BLD",1004 2,1,181,0)
  372   CHMFEDISTP 3     n/a       12253 408    **1 4**
  373   "BLD",1004 2,1,182,0)
  374   CHMFEDISTP 5     n/a        8371 200    **1 4**
  375   "BLD",1004 2,1,183,0)
  376   CHMFPDO3         n/a        3983 713    **1 4**
  377   "BLD",1004 2,1,184,0)
  378   CHMFPDO4         n/a        3806 748    **1 ,14**
  379   "BLD",1004 2,1,185,0)
  380   CHMFSR21         n/a       75695 939    **1 ,14**
  381   "BLD",1004 2,1,186,0)
  382   CHMFSRT          n/a       24434 762    **1 ,14**
  383   "BLD",1004 2,1,187,0)
  384   CHMFUTLE         n/a       23505 215    **1 ,14**
  385   "BLD",1004 2,1,188,0)
  386   CHMGA008         n/a        4747 313    **1 4**
  387   "BLD",1004 2,1,189,0)
  388   CHMIS011         n/a       44216 186    **1 4**
  389   "BLD",1004 2,1,190,0)
  390   CHMIS012         n/a       10754 3024   **1 4**
  391   "BLD",1004 2,1,191,0)
  392   CHMIS021         n/a       13420 1726   **1 4**
  393   "BLD",1004 2,1,192,0)
  394   CHMIS023         n/a       76037 373    **1 ,14**
  395   "BLD",1004 2,1,193,0)
  396   CHMKAG5P         n/a       42621 823    **1 4**
  397   "BLD",1004 2,1,194,0)
  398   CHMKAG5Q         n/a       15345 684    **1 ,14**
  399   "BLD",1004 2,1,195,0)
  400   CHMKPDI2         n/a        5463 803    **1 4**
  401   "BLD",1004 2,1,196,0)
  402   CHMKPPR1         n/a       15716 696    **1 ,14**
  403   "BLD",1004 2,1,197,0)
  404   CHMKPPR2         n/a       12433 776    **1 4**
  405   "BLD",1004 2,1,198,0)
  406   CHMRESET         n/a       14943 433    **1 ,14**
  407   "BLD",1004 2,1,199,0)
  408   CHMRGRNT         n/a       43149 143    **1 4**
  409   "BLD",1004 2,1,200,0)
  410   CHMRSQC          n/a       16310 7973   **1 4**
  411   "BLD",1004 2,1,201,0)
  412   CHMRSQC1         n/a       41316 9972   **1 ,14**
  413   "BLD",1004 2,1,202,0)
  414   CHMRSQP          n/a       48317 458    **1 4**
  415   "BLD",1004 2,1,203,0)
  416   CHMXDR01         n/a       18904 0768   **1 4**
  417   "BLD",1004 2,1,204,0)
  418   CHMXF001         n/a       83632 900    **1 ,14**
  419   "BLD",1004 2,1,205,0)
  420   CHMXIN06         n/a       33908 7627   **1 4**
  421   "BLD",1004 2,1,206,0)
  422   CHMXMPD2         n/a        4066 483    **1 4**
  423   "BLD",1004 2,1,207,0)
  424   CHMXMPDI         n/a       20317 696    **1 ,14**
  425   "BLD",1004 2,1,208,0)
  426   CHMXP010         n/a       20054 379    **1 4**
  427   "BLD",1004 2,1,209,0)
  428   CHMXPU03         n/a       99067 882    **1 4**
  429   "BLD",1004 2,1,210,0)
  430   CHMXPU04         n/a       36820 7416   **1 ,14**
  431   "BLD",1004 2,1,211,0)
  432   CHMXPUTL         n/a        8196 849    **1 ,14**
  433   "BLD",1004 2,1,212,0)
  434   CHMXPUTL5        n/a        9219 590    **1 ,14**
  435   "BLD",1004 2,1,213,0)
  436   CHMXQCNT         n/a       88415 948    **1 4**
  437   "BLD",1004 2,1,214,0)
  438   CHMXWBUT         n/a       81701 5517   **1 4**
  439   "BLD",1004 2,1,215,0)
  440   CHPRD1           n/a       36462 532    **1 4**
  441   "BLD",1004 2,1,216,0)
  442   CHTFLIB2         n/a       43683 6247   **1 4**
  443   "BLD",1004 2,1,217,0)
  444    
  445   "BLD",1004 2,1,218,0)
  446   List of pr eceding pa tches: 7,  8, 9, 11,  12
  447   "BLD",1004 2,1,219,0)
  448   Sites shou ld use CHE CK1^XTSUMB LD to veri fy checksu ms.
  449   "BLD",1004 2,1,220,0)
  450    
  451   "BLD",1004 2,1,221,0)
  452    User Stor ies:
  453   "BLD",1004 2,1,222,0)
  454    --------- ---------- ---------
  455   "BLD",1004 2,1,223,0)
  456    N/A
  457   "BLD",1004 2,1,224,0)
  458    
  459   "BLD",1004 2,1,225,0)
  460    Test Envi ronment:
  461   "BLD",1004 2,1,226,0)
  462    --------- --
  463   "BLD",1004 2,1,227,0)
  464    TBD
  465   "BLD",1004 2,1,228,0)
  466    
  467   "BLD",1004 2,1,229,0)
  468    Software  and Docume ntation Re trieval In structions :
  469   "BLD",1004 2,1,230,0)
  470    --------- ---------- ---------- --------
  471   "BLD",1004 2,1,231,0)
  472    The softw are is dis tributed i n a Host f ile genera ted from t he
  473   "BLD",1004 2,1,232,0)
  474    Developme nt Environ ment. Docu mentation  describing  new
  475   "BLD",1004 2,1,233,0)
  476    functiona lity intro duced by t his patch  is availab le from th e
  477   "BLD",1004 2,1,234,0)
  478    developer .
  479   "BLD",1004 2,1,235,0)
  480     
  481   "BLD",1004 2,1,236,0)
  482    Title                                         File Na me              FTP M ode
  483   "BLD",1004 2,1,237,0)
  484    --------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  485   "BLD",1004 2,1,238,0)
  486    KIDS Host  file:  HA C_HFS$:[DS MMANAG.CHA MPVA]CPEED I_1_0_014_ V3.KIDS  A SCII
  487   "BLD",1004 2,1,239,0)
  488    
  489   "BLD",1004 2,1,240,0)
  490    Deploymen t/Installa tion Rollb ack/Backou t Guide
  491   "BLD",1004 2,1,241,0)
  492    --------- ---------- ---------- -
  493   "BLD",1004 2,1,242,0)
  494    It is rec ommended w hen instal ling the K IDS packag e that the  installer
  495   "BLD",1004 2,1,243,0)
  496    choose op tion #5 in  step 3b.  of the bel ow Install ation Inst ructions.
  497   "BLD",1004 2,1,244,0)
  498    If a roll back/backo ut is need ed, the pr ior versio n of the r outines
  499   "BLD",1004 2,1,245,0)
  500    can be re -installed  using the  backup pa ckman mess age create d in
  501   "BLD",1004 2,1,246,0)
  502    step 3b.  However, p lease noti fy the dev elopment t eam if a
  503   "BLD",1004 2,1,247,0)
  504    rollback/ backout of  this patc h is desir ed.
  505   "BLD",1004 2,1,248,0)
  506    
  507   "BLD",1004 2,1,249,0)
  508    Patch Ins tallation:
  509   "BLD",1004 2,1,250,0)
  510      
  511   "BLD",1004 2,1,251,0)
  512    Pre/Post  Installati on Overvie w
  513   "BLD",1004 2,1,252,0)
  514    --------- ---------- ---------- -
  515   "BLD",1004 2,1,253,0)
  516    There are  no Pre-in stallation  routine p rocesses.
  517   "BLD",1004 2,1,254,0)
  518    
  519   "BLD",1004 2,1,255,0)
  520    Pre-Insta llation In structions
  521   "BLD",1004 2,1,256,0)
  522    --------- ---------- ----------
  523   "BLD",1004 2,1,257,0)
  524    This patc h may be i nstalled w ith users  on the sys tem althou gh it is
  525   "BLD",1004 2,1,258,0)
  526    recommend ed that it  be instal led during  non-peak  hours to m inimize
  527   "BLD",1004 2,1,259,0)
  528    potential  disruptio n to users .  This pa tch should  take less  than
  529   "BLD",1004 2,1,260,0)
  530    5 minutes  to instal l.
  531   "BLD",1004 2,1,261,0)
  532     
  533   "BLD",1004 2,1,262,0)
  534    Installat ion Instru ctions
  535   "BLD",1004 2,1,263,0)
  536    --------- ---------- ------
  537   "BLD",1004 2,1,264,0)
  538    1.  Choos e the Load  a Distrib ution opti on from th e Installa tion
  539   "BLD",1004 2,1,265,0)
  540        optio n.
  541   "BLD",1004 2,1,266,0)
  542     
  543   "BLD",1004 2,1,267,0)
  544    2.  At th e Enter a  Host File:  prompt,
  545   "BLD",1004 2,1,268,0)
  546        enter :   HAC_HF S$:[DSMMAN AG.CHAMPVA ]CPEEDI_1_ 0_014_V3.K IDS
  547   "BLD",1004 2,1,269,0)
  548        
  549   "BLD",1004 2,1,270,0)
  550        This  Distributi on contain s Transpor t Globals  for the fo llowing
  551   "BLD",1004 2,1,271,0)
  552        Packa ge(s):   C PEEDI*1.0* 014
  553   "BLD",1004 2,1,272,0)
  554        Distr ibution OK !
  555   "BLD",1004 2,1,273,0)
  556    
  557   "BLD",1004 2,1,274,0)
  558        Want  to Continu e with Loa d? YES// Y ES
  559   "BLD",1004 2,1,275,0)
  560    
  561   "BLD",1004 2,1,276,0)
  562           CP EEDI*1.0*0 14
  563   "BLD",1004 2,1,277,0)
  564        Use I NSTALL NAM E: CPEEDI* 1.0*014 to  install t his Distri bution.
  565   "BLD",1004 2,1,278,0)
  566     
  567   "BLD",1004 2,1,279,0)
  568    3.  You m ay elect t o use the  following  options. W hen prompt ed for
  569   "BLD",1004 2,1,280,0)
  570        the I NSTALL ent er the pat ch #(CPEED I*1.0*014) :
  571   "BLD",1004 2,1,281,0)
  572     
  573   "BLD",1004 2,1,282,0)
  574        a. Op tion #4: C ompare Tra nsport Glo bal to Cur rent Syste m
  575   "BLD",1004 2,1,283,0)
  576              This optio n will all ow you to  view all c hanges tha t will be
  577   "BLD",1004 2,1,284,0)
  578              made when  this patch  is instal led.  It c ompares al l
  579   "BLD",1004 2,1,285,0)
  580              components  of this p atch (rout ines, DD's , template s, etc.).
  581   "BLD",1004 2,1,286,0)
  582        b. Op tion #5: B ackup a Tr ansport Gl obal.
  583   "BLD",1004 2,1,287,0)
  584              As part of  the Deplo yment/Inst allation R ollback/Ba ckout
  585   "BLD",1004 2,1,288,0)
  586              Guide it i s recommen ded when i nstalling  the KIDS p ackage
  587   "BLD",1004 2,1,289,0)
  588              that the i nstaller c hoose opti on #5 to c reate a ba ckup Packm an
  589   "BLD",1004 2,1,290,0)
  590              message:
  591   "BLD",1004 2,1,291,0)
  592    
  593   "BLD",1004 2,1,292,0)
  594    4.  From  the Instal lation Men u, select  the Instal l Package( s) option  and
  595   "BLD",1004 2,1,293,0)
  596        choos e the patc h to insta ll. Enter  CPEEDI*1.0 *014.
  597   "BLD",1004 2,1,294,0)
  598     
  599   "BLD",1004 2,1,295,0)
  600    5.  When  prompted ' Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of
  601   "BLD",1004 2,1,296,0)
  602        Insta ll? NO//',  respond N O.
  603   "BLD",1004 2,1,297,0)
  604     
  605   "BLD",1004 2,1,298,0)
  606    6.  When  prompted ' Want KIDS  to INHIBIT  LOGONs du ring the i nstall? NO //',
  607   "BLD",1004 2,1,299,0)
  608        respo nd NO.
  609   "BLD",1004 2,1,300,0)
  610     
  611   "BLD",1004 2,1,301,0)
  612    7.  When  prompted ' Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd
  613   "BLD",1004 2,1,302,0)
  614        Proto cols? NO// ', respond  NO.
  615   "BLD",1004 2,1,303,0)
  616     
  617   "BLD",1004 2,1,304,0)
  618    8.  If pr ompted 'De lay Instal l (Minutes ):  (0 - 6 0): 0//',  respond 0.
  619   "BLD",1004 2,4,0)
  620   ^9.64PA^74 1002.17^12
  621   "BLD",1004 2,4,741000 ,0)
  622   741000
  623   "BLD",1004 2,4,741000 ,222)
  624   y^y^f^^^^n
  625   "BLD",1004 2,4,741000 .2,0)
  626   741000.2
  627   "BLD",1004 2,4,741000 .2,222)
  628   y^y^f^^^^n
  629   "BLD",1004 2,4,741002 .17,0)
  630   741002.17
  631   "BLD",1004 2,4,741002 .17,222)
  632   y^y^f^^^^n
  633   "BLD",1004 2,4,741002 .22,0)
  634   741002.22
  635   "BLD",1004 2,4,741002 .22,222)
  636   y^y^f^^^^n ^^
  637   "BLD",1004 2,4,741002 .22,224)
  638  
  639   "BLD",1004 2,4,741201 .15,0)
  640   741201.15
  641   "BLD",1004 2,4,741201 .16,0)
  642   741201.16
  643   "BLD",1004 2,4,741201 .32,0)
  644   741201.32
  645   "BLD",1004 2,4,741201 .32,222)
  646   y^y^f^^^^n
  647   "BLD",1004 2,4,741201 .58,0)
  648   741201.58
  649   "BLD",1004 2,4,741201 .77,0)
  650   741201.77
  651   "BLD",1004 2,4,741211 .03,0)
  652   741211.03
  653   "BLD",1004 2,4,741213 ,0)
  654   741213
  655   "BLD",1004 2,4,741215 ,0)
  656   741215
  657   "BLD",1004 2,4,741215 ,222)
  658   y^y^f^^^^n
  659   "BLD",1004 2,4,"B",74 1000,74100 0)
  660  
  661   "BLD",1004 2,4,"B",74 1000.2,741 000.2)
  662  
  663   "BLD",1004 2,4,"B",74 1002.17,74 1002.17)
  664  
  665   "BLD",1004 2,4,"B",74 1002.22,74 1002.22)
  666  
  667   "BLD",1004 2,4,"B",74 1201.15,74 1201.15)
  668  
  669   "BLD",1004 2,4,"B",74 1201.16,74 1201.16)
  670  
  671   "BLD",1004 2,4,"B",74 1201.32,74 1201.32)
  672  
  673   "BLD",1004 2,4,"B",74 1201.58,74 1201.58)
  674  
  675   "BLD",1004 2,4,"B",74 1201.77,74 1201.77)
  676  
  677   "BLD",1004 2,4,"B",74 1211.03,74 1211.03)
  678  
  679   "BLD",1004 2,4,"B",74 1213,74121 3)
  680  
  681   "BLD",1004 2,4,"B",74 1215,74121 5)
  682  
  683   "BLD",1004 2,6.3)
  684   9
  685   "BLD",1004 2,"KRN",0)
  686   ^9.67PA^1. 61^23
  687   "BLD",1004 2,"KRN",.4 ,0)
  688   .4
  689   "BLD",1004 2,"KRN",.4 01,0)
  690   .401
  691   "BLD",1004 2,"KRN",.4 02,0)
  692   .402
  693   "BLD",1004 2,"KRN",.4 03,0)
  694   .403
  695   "BLD",1004 2,"KRN",.5 ,0)
  696   .5
  697   "BLD",1004 2,"KRN",.8 4,0)
  698   .84
  699   "BLD",1004 2,"KRN",1. 6,0)
  700   1.6
  701   "BLD",1004 2,"KRN",1. 61,0)
  702   1.61
  703   "BLD",1004 2,"KRN",1. 62,0)
  704   1.62
  705   "BLD",1004 2,"KRN",3. 6,0)
  706   3.6
  707   "BLD",1004 2,"KRN",3. 8,0)
  708   3.8
  709   "BLD",1004 2,"KRN",9. 2,0)
  710   9.2
  711   "BLD",1004 2,"KRN",9. 2,"NM",0)
  712   ^9.68A^^
  713   "BLD",1004 2,"KRN",9. 8,0)
  714   9.8
  715   "BLD",1004 2,"KRN",9. 8,"NM",0)
  716   ^9.68A^99^ 99
  717   "BLD",1004 2,"KRN",9. 8,"NM",1,0 )
  718   CH835F1^^0 ^B18573909
  719   "BLD",1004 2,"KRN",9. 8,"NM",2,0 )
  720   CHFBC1^^0^ B118071981
  721   "BLD",1004 2,"KRN",9. 8,"NM",3,0 )
  722   CHFBC1D^^0 ^B79160574
  723   "BLD",1004 2,"KRN",9. 8,"NM",4,0 )
  724   CHFBC1E^^0 ^B86804463
  725   "BLD",1004 2,"KRN",9. 8,"NM",5,0 )
  726   CHFBC2A^^0 ^B28422780 1
  727   "BLD",1004 2,"KRN",9. 8,"NM",6,0 )
  728   CHGAS2^^0^ B115493168
  729   "BLD",1004 2,"KRN",9. 8,"NM",7,0 )
  730   CHGAS22^^0 ^B73431822
  731   "BLD",1004 2,"KRN",9. 8,"NM",8,0 )
  732   CHGAS23^^0 ^B63174125
  733   "BLD",1004 2,"KRN",9. 8,"NM",9,0 )
  734   CHGASIP^^0 ^B60716419
  735   "BLD",1004 2,"KRN",9. 8,"NM",10, 0)
  736   CHGASP^^0^ B86304290
  737   "BLD",1004 2,"KRN",9. 8,"NM",11, 0)
  738   CHGASP1^^0 ^B40517172
  739   "BLD",1004 2,"KRN",9. 8,"NM",12, 0)
  740   CHGASP2^^0 ^B34812978
  741   "BLD",1004 2,"KRN",9. 8,"NM",13, 0)
  742   CHGCDC71^^ 0^B3625617 3
  743   "BLD",1004 2,"KRN",9. 8,"NM",14, 0)
  744   CHGCDC75^^ 0^B2936574 3
  745   "BLD",1004 2,"KRN",9. 8,"NM",15, 0)
  746   CHGCDP7^^0 ^B70182755
  747   "BLD",1004 2,"KRN",9. 8,"NM",16, 0)
  748   CHGCDP70^^ 0^B6967224 4
  749   "BLD",1004 2,"KRN",9. 8,"NM",17, 0)
  750   CHGCDP71^^ 0^B6472840
  751   "BLD",1004 2,"KRN",9. 8,"NM",18, 0)
  752   CHGCDP73^^ 0^B9545809
  753   "BLD",1004 2,"KRN",9. 8,"NM",19, 0)
  754   CHGCDV7^^0 ^B84573137
  755   "BLD",1004 2,"KRN",9. 8,"NM",20, 0)
  756   CHGCDV70^^ 0^B8023345 2
  757   "BLD",1004 2,"KRN",9. 8,"NM",21, 0)
  758   CHGCDV71^^ 0^B9785845 2
  759   "BLD",1004 2,"KRN",9. 8,"NM",22, 0)
  760   CHGCU136^^ 0^B3819513 4
  761   "BLD",1004 2,"KRN",9. 8,"NM",23, 0)
  762   CHGCU165^^ 0^B2148964 9
  763   "BLD",1004 2,"KRN",9. 8,"NM",24, 0)
  764   CHGCDV73^^ 0^B4105791 8
  765   "BLD",1004 2,"KRN",9. 8,"NM",25, 0)
  766   CHGDQ2^^0^ B156001132
  767   "BLD",1004 2,"KRN",9. 8,"NM",26, 0)
  768   CHGQA2^^0^ B105635204
  769   "BLD",1004 2,"KRN",9. 8,"NM",27, 0)
  770   CHGVQ370^^ 0^B1935889 07
  771   "BLD",1004 2,"KRN",9. 8,"NM",28, 0)
  772   CHGVQ529^^ 0^B9657334 0
  773   "BLD",1004 2,"KRN",9. 8,"NM",29, 0)
  774   CHIGDQ3^^0 ^B92490075
  775   "BLD",1004 2,"KRN",9. 8,"NM",30, 0)
  776   CHIGDQ30^^ 0^B9300571 8
  777   "BLD",1004 2,"KRN",9. 8,"NM",31, 0)
  778   CHMEAE5^^0 ^B66632491
  779   "BLD",1004 2,"KRN",9. 8,"NM",32, 0)
  780   CHMXF001^^ 0^B8363290 0
  781   "BLD",1004 2,"KRN",9. 8,"NM",33, 0)
  782   CHMF351D^^ 0^B9200541 6
  783   "BLD",1004 2,"KRN",9. 8,"NM",34, 0)
  784   CHMF351P^^ 0^B1605837 54
  785   "BLD",1004 2,"KRN",9. 8,"NM",35, 0)
  786   CHMF351U^^ 0^B1885993 66
  787   "BLD",1004 2,"KRN",9. 8,"NM",36, 0)
  788   CHMFA001^^ 0^B7272813 8
  789   "BLD",1004 2,"KRN",9. 8,"NM",37, 0)
  790   CHMFA008^^ 0^B7065972 0
  791   "BLD",1004 2,"KRN",9. 8,"NM",38, 0)
  792   CHMFA010^^ 0^B1832881 12
  793   "BLD",1004 2,"KRN",9. 8,"NM",39, 0)
  794   CHMFA011^^ 0^B1096412 27
  795   "BLD",1004 2,"KRN",9. 8,"NM",40, 0)
  796   CHMFA012^^ 0^B5938662
  797   "BLD",1004 2,"KRN",9. 8,"NM",41, 0)
  798   CHMFA013^^ 0^B3186797 3
  799   "BLD",1004 2,"KRN",9. 8,"NM",42, 0)
  800   CHMFA01E^^ 0^B5618565 5
  801   "BLD",1004 2,"KRN",9. 8,"NM",43, 0)
  802   CHMFA020^^ 0^B4691336 1
  803   "BLD",1004 2,"KRN",9. 8,"NM",44, 0)
  804   CHMFA02E^^ 0^B1591638
  805   "BLD",1004 2,"KRN",9. 8,"NM",45, 0)
  806   CHMFA110^^ 0^B2404824 1
  807   "BLD",1004 2,"KRN",9. 8,"NM",46, 0)
  808   CHMFA141^^ 0^B1271109 246
  809   "BLD",1004 2,"KRN",9. 8,"NM",47, 0)
  810   CHMFA150^^ 0^B1419624 0
  811   "BLD",1004 2,"KRN",9. 8,"NM",48, 0)
  812   CHMFA801^^ 0^B4882421 2
  813   "BLD",1004 2,"KRN",9. 8,"NM",49, 0)
  814   CHMFADR1^^ 0^B1272422 08
  815   "BLD",1004 2,"KRN",9. 8,"NM",50, 0)
  816   CHMFADR2^^ 0^B3131608 62
  817   "BLD",1004 2,"KRN",9. 8,"NM",51, 0)
  818   CHMFADR4^^ 0^B2679348 73
  819   "BLD",1004 2,"KRN",9. 8,"NM",52, 0)
  820   CHMFADRV^^ 0^B9565330 5
  821   "BLD",1004 2,"KRN",9. 8,"NM",53, 0)
  822   CHMFA01F^^ 0^B1150696 0
  823   "BLD",1004 2,"KRN",9. 8,"NM",54, 0)
  824   CHMFAUT1^^ 0^B9940542 40
  825   "BLD",1004 2,"KRN",9. 8,"NM",55, 0)
  826   CHMFBC1^^0 ^B71408427
  827   "BLD",1004 2,"KRN",9. 8,"NM",56, 0)
  828   CHMFBC2A^^ 0^B5966858 8
  829   "BLD",1004 2,"KRN",9. 8,"NM",57, 0)
  830   CHMFSR21^^ 0^B7569593 9
  831   "BLD",1004 2,"KRN",9. 8,"NM",58, 0)
  832   CHMFSRT^^0 ^B24434762
  833   "BLD",1004 2,"KRN",9. 8,"NM",59, 0)
  834   CHMGA008^^ 0^B4747313
  835   "BLD",1004 2,"KRN",9. 8,"NM",60, 0)
  836   CHMKPDI2^^ 0^B5463803
  837   "BLD",1004 2,"KRN",9. 8,"NM",61, 0)
  838   CHMKPPR1^^ 0^B1571669 6
  839   "BLD",1004 2,"KRN",9. 8,"NM",62, 0)
  840   CHMKPPR2^^ 0^B1243377 6
  841   "BLD",1004 2,"KRN",9. 8,"NM",63, 0)
  842   CHMRESET^^ 0^B1494343 3
  843   "BLD",1004 2,"KRN",9. 8,"NM",64, 0)
  844   CHMRSQC^^0 ^B16310797 3
  845   "BLD",1004 2,"KRN",9. 8,"NM",65, 0)
  846   CHMRSQC1^^ 0^B4131699 72
  847   "BLD",1004 2,"KRN",9. 8,"NM",66, 0)
  848   CHMRSQP^^0 ^B48317458
  849   "BLD",1004 2,"KRN",9. 8,"NM",67, 0)
  850   CHMXDR01^^ 0^B1890407 68
  851   "BLD",1004 2,"KRN",9. 8,"NM",68, 0)
  852   CHMXMPDI^^ 0^B2031769 6
  853   "BLD",1004 2,"KRN",9. 8,"NM",69, 0)
  854   CHMXPU03^^ 0^B1579993 9
  855   "BLD",1004 2,"KRN",9. 8,"NM",70, 0)
  856   CHMXPU04^^ 0^B3682074 16
  857   "BLD",1004 2,"KRN",9. 8,"NM",71, 0)
  858   CHMXQCNT^^ 0^B8841594 8
  859   "BLD",1004 2,"KRN",9. 8,"NM",72, 0)
  860   CHPRD1^^0^ B36462532
  861   "BLD",1004 2,"KRN",9. 8,"NM",73, 0)
  862   CHTFLIB2^^ 0^B8402489
  863   "BLD",1004 2,"KRN",9. 8,"NM",74, 0)
  864   CHFBCQ^^0^ B206700247
  865   "BLD",1004 2,"KRN",9. 8,"NM",75, 0)
  866   CHMIS011^^ 0^B4421618 6
  867   "BLD",1004 2,"KRN",9. 8,"NM",76, 0)
  868   CHMIS012^^ 0^B1075430 24
  869   "BLD",1004 2,"KRN",9. 8,"NM",77, 0)
  870   CHMIS021^^ 0^B1342017 26
  871   "BLD",1004 2,"KRN",9. 8,"NM",78, 0)
  872   CHMIS023^^ 0^B7603737 3
  873   "BLD",1004 2,"KRN",9. 8,"NM",79, 0)
  874   CHMKAG5Q^^ 0^B1534568 4
  875   "BLD",1004 2,"KRN",9. 8,"NM",80, 0)
  876   CHMRGRNT^^ 0^B4314914 3
  877   "BLD",1004 2,"KRN",9. 8,"NM",81, 0)
  878   CH835TRG^^ 0^B1086165
  879   "BLD",1004 2,"KRN",9. 8,"NM",82, 0)
  880   CHCSTAT^^0 ^B1099344
  881   "BLD",1004 2,"KRN",9. 8,"NM",83, 0)
  882   CHMFEDISTP 1^^0^B4601 161
  883   "BLD",1004 2,"KRN",9. 8,"NM",84, 0)
  884   CHMFEDISTP 2^^0^B5893 228
  885   "BLD",1004 2,"KRN",9. 8,"NM",85, 0)
  886   CHMFEDISTP 3^^0^B1225 3408
  887   "BLD",1004 2,"KRN",9. 8,"NM",86, 0)
  888   CHMFEDISTP 5^^0^B8371 200
  889   "BLD",1004 2,"KRN",9. 8,"NM",87, 0)
  890   CHMFPDO3^^ 0^B3983713
  891   "BLD",1004 2,"KRN",9. 8,"NM",88, 0)
  892   CHMFPDO4^^ 0^B3806748
  893   "BLD",1004 2,"KRN",9. 8,"NM",89, 0)
  894   CHMFUTLE^^ 0^B2350521 5
  895   "BLD",1004 2,"KRN",9. 8,"NM",90, 0)
  896   CHMXPUTL^^ 0^B8196849
  897   "BLD",1004 2,"KRN",9. 8,"NM",91, 0)
  898   CHMXPUTL5^ ^0^B921959 0
  899   "BLD",1004 2,"KRN",9. 8,"NM",92, 0)
  900   CHMXMPD2^^ 0^B4066483
  901   "BLD",1004 2,"KRN",9. 8,"NM",93, 0)
  902   CHMFA002^^ 0^B6171486
  903   "BLD",1004 2,"KRN",9. 8,"NM",94, 0)
  904   CHMXWBUT^^ 0^B2928193
  905   "BLD",1004 2,"KRN",9. 8,"NM",95, 0)
  906   CHGCPRD1^^ 0^B7515489 7
  907   "BLD",1004 2,"KRN",9. 8,"NM",96, 0)
  908   CHGCPRD3^^ 0^B5561240 8
  909   "BLD",1004 2,"KRN",9. 8,"NM",97, 0)
  910   CHMKAG5P^^ 0^B4262182 3
  911   "BLD",1004 2,"KRN",9. 8,"NM",98, 0)
  912   CHMXP010^^ 0^B2005437 9
  913   "BLD",1004 2,"KRN",9. 8,"NM",99, 0)
  914   CHMXIN06^^ 0^B3363547 72
  915   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CH835F1" ,1)
  916  
  917   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CH835TRG ",81)
  918  
  919   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHCSTAT" ,82)
  920  
  921   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHFBC1", 2)
  922  
  923   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHFBC1D" ,3)
  924  
  925   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHFBC1E" ,4)
  926  
  927   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHFBC2A" ,5)
  928  
  929   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHFBCQ", 74)
  930  
  931   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGAS2", 6)
  932  
  933   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGAS22" ,7)
  934  
  935   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGAS23" ,8)
  936  
  937   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGASIP" ,9)
  938  
  939   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGASP", 10)
  940  
  941   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGASP1" ,11)
  942  
  943   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGASP2" ,12)
  944  
  945   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDC71 ",13)
  946  
  947   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDC75 ",14)
  948  
  949   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDP7" ,15)
  950  
  951   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDP70 ",16)
  952  
  953   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDP71 ",17)
  954  
  955   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDP73 ",18)
  956  
  957   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDV7" ,19)
  958  
  959   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDV70 ",20)
  960  
  961   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDV71 ",21)
  962  
  963   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCDV73 ",24)
  964  
  965   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCPRD1 ",95)
  966  
  967   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCPRD3 ",96)
  968  
  969   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCU136 ",22)
  970  
  971   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGCU165 ",23)
  972  
  973   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGDQ2", 25)
  974  
  975   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGQA2", 26)
  976  
  977   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGVQ370 ",27)
  978  
  979   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHGVQ529 ",28)
  980  
  981   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHIGDQ3" ,29)
  982  
  983   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHIGDQ30 ",30)
  984  
  985   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMEAE5" ,31)
  986  
  987   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMF351D ",33)
  988  
  989   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMF351P ",34)
  990  
  991   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMF351U ",35)
  992  
  993   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA001 ",36)
  994  
  995   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA002 ",93)
  996  
  997   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA008 ",37)
  998  
  999   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA010 ",38)
  1000  
  1001   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA011 ",39)
  1002  
  1003   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA012 ",40)
  1004  
  1005   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA013 ",41)
  1006  
  1007   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA01E ",42)
  1008  
  1009   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA01F ",53)
  1010  
  1011   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA020 ",43)
  1012  
  1013   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA02E ",44)
  1014  
  1015   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA110 ",45)
  1016  
  1017   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA141 ",46)
  1018  
  1019   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA150 ",47)
  1020  
  1021   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFA801 ",48)
  1022  
  1023   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFADR1 ",49)
  1024  
  1025   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFADR2 ",50)
  1026  
  1027   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFADR4 ",51)
  1028  
  1029   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFADRV ",52)
  1030  
  1031   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFAUT1 ",54)
  1032  
  1033   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFBC1" ,55)
  1034  
  1035   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFBC2A ",56)
  1036  
  1037   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFEDIS TP1",83)
  1038  
  1039   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFEDIS TP2",84)
  1040  
  1041   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFEDIS TP3",85)
  1042  
  1043   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFEDIS TP5",86)
  1044  
  1045   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFPDO3 ",87)
  1046  
  1047   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFPDO4 ",88)
  1048  
  1049   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFSR21 ",57)
  1050  
  1051   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFSRT" ,58)
  1052  
  1053   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMFUTLE ",89)
  1054  
  1055   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMGA008 ",59)
  1056  
  1057   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMIS011 ",75)
  1058  
  1059   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMIS012 ",76)
  1060  
  1061   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMIS021 ",77)
  1062  
  1063   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMIS023 ",78)
  1064  
  1065   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMKAG5P ",97)
  1066  
  1067   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMKAG5Q ",79)
  1068  
  1069   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMKPDI2 ",60)
  1070  
  1071   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMKPPR1 ",61)
  1072  
  1073   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMKPPR2 ",62)
  1074  
  1075   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMRESET ",63)
  1076  
  1077   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMRGRNT ",80)
  1078  
  1079   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMRSQC" ,64)
  1080  
  1081   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMRSQC1 ",65)
  1082  
  1083   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMRSQP" ,66)
  1084  
  1085   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXDR01 ",67)
  1086  
  1087   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXF001 ",32)
  1088  
  1089   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXIN06 ",99)
  1090  
  1091   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXMPD2 ",92)
  1092  
  1093   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXMPDI ",68)
  1094  
  1095   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXP010 ",98)
  1096  
  1097   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXPU03 ",69)
  1098  
  1099   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXPU04 ",70)
  1100  
  1101   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXPUTL ",90)
  1102  
  1103   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXPUTL 5",91)
  1104  
  1105   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXQCNT ",71)
  1106  
  1107   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHMXWBUT ",94)
  1108  
  1109   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHPRD1", 72)
  1110  
  1111   "BLD",1004 2,"KRN",9. 8,"NM","B" ,"CHTFLIB2 ",73)
  1112  
  1113   "BLD",1004 2,"KRN",19 ,0)
  1114   19
  1115   "BLD",1004 2,"KRN",19 ,"NM",0)
  1116   ^9.68A^^0
  1117   "BLD",1004 2,"KRN",19 .1,0)
  1118   19.1
  1119   "BLD",1004 2,"KRN",19 .1,"NM",0)
  1120   ^9.68A^4^4
  1121   "BLD",1004 2,"KRN",19 .1,"NM",1, 0)
  1122   CHMERSK^^0
  1123   "BLD",1004 2,"KRN",19 .1,"NM",2, 0)
  1124   CHMERVK^^0
  1125   "BLD",1004 2,"KRN",19 .1,"NM",3, 0)
  1126   CHMSRSK^^0
  1127   "BLD",1004 2,"KRN",19 .1,"NM",4, 0)
  1128   CHMSRVK^^0
  1129   "BLD",1004 2,"KRN",19 .1,"NM","B ","CHMERSK ",1)
  1130  
  1131   "BLD",1004 2,"KRN",19 .1,"NM","B ","CHMERVK ",2)
  1132  
  1133   "BLD",1004 2,"KRN",19 .1,"NM","B ","CHMSRSK ",3)
  1134  
  1135   "BLD",1004 2,"KRN",19 .1,"NM","B ","CHMSRVK ",4)
  1136  
  1137   "BLD",1004 2,"KRN",10 1,0)
  1138   101
  1139   "BLD",1004 2,"KRN",40 9.61,0)
  1140   409.61
  1141   "BLD",1004 2,"KRN",77 1,0)
  1142   771
  1143   "BLD",1004 2,"KRN",77 9.2,0)
  1144   779.2
  1145   "BLD",1004 2,"KRN",77 9.2,"NM",0 )
  1146   ^9.68A^^
  1147   "BLD",1004 2,"KRN",87 0,0)
  1148   870
  1149   "BLD",1004 2,"KRN",89 89.51,0)
  1150   8989.51
  1151   "BLD",1004 2,"KRN",89 89.52,0)
  1152   8989.52
  1153   "BLD",1004 2,"KRN",89 94,0)
  1154   8994
  1155   "BLD",1004 2,"KRN","B ",.4,.4)
  1156  
  1157   "BLD",1004 2,"KRN","B ",.401,.40 1)
  1158  
  1159   "BLD",1004 2,"KRN","B ",.402,.40 2)
  1160  
  1161   "BLD",1004 2,"KRN","B ",.403,.40 3)
  1162  
  1163   "BLD",1004 2,"KRN","B ",.5,.5)
  1164  
  1165   "BLD",1004 2,"KRN","B ",.84,.84)
  1166  
  1167   "BLD",1004 2,"KRN","B ",1.6,1.6)
  1168  
  1169   "BLD",1004 2,"KRN","B ",1.61,1.6 1)
  1170  
  1171   "BLD",1004 2,"KRN","B ",1.62,1.6 2)
  1172  
  1173   "BLD",1004 2,"KRN","B ",3.6,3.6)
  1174  
  1175   "BLD",1004 2,"KRN","B ",3.8,3.8)
  1176  
  1177   "BLD",1004 2,"KRN","B ",9.2,9.2)
  1178  
  1179   "BLD",1004 2,"KRN","B ",9.8,9.8)
  1180  
  1181   "BLD",1004 2,"KRN","B ",19,19)
  1182  
  1183   "BLD",1004 2,"KRN","B ",19.1,19. 1)
  1184  
  1185   "BLD",1004 2,"KRN","B ",101,101)
  1186  
  1187   "BLD",1004 2,"KRN","B ",409.61,4 09.61)
  1188  
  1189   "BLD",1004 2,"KRN","B ",771,771)
  1190  
  1191   "BLD",1004 2,"KRN","B ",779.2,77 9.2)
  1192  
  1193   "BLD",1004 2,"KRN","B ",870,870)
  1194  
  1195   "BLD",1004 2,"KRN","B ",8989.51, 8989.51)
  1196  
  1197   "BLD",1004 2,"KRN","B ",8989.52, 8989.52)
  1198  
  1199   "BLD",1004 2,"KRN","B ",8994,899 4)
  1200  
  1201   "BLD",1004 2,"QDEF")
  1202   ^^^^NO^^^^ YES^^NO
  1203   "BLD",1004 2,"QUES",0 )
  1204   ^9.62^^
  1205   "BLD",1004 2,"REQB",0 )
  1206   ^9.611^^
  1207   "FIA",7410 00)
  1208   CHAMPVA CL AIMS
  1209   "FIA",7410 00,0)
  1210   ^CHMPAY(
  1211   "FIA",7410 00,0,0)
  1212   741000
  1213   "FIA",7410 00,0,1)
  1214   y^y^f^^^^n
  1215   "FIA",7410 00,0,10)
  1216  
  1217   "FIA",7410 00,0,11)
  1218  
  1219   "FIA",7410 00,0,"RLRO ")
  1220  
  1221   "FIA",7410 00,741000)
  1222   0
  1223   "FIA",7410 00,741000. 01)
  1224   0
  1225   "FIA",7410 00,741000. 01001)
  1226   0
  1227   "FIA",7410 00,741000. 0102)
  1228   0
  1229   "FIA",7410 00,741000. 0141)
  1230   0
  1231   "FIA",7410 00,741000. 0142)
  1232   0
  1233   "FIA",7410 00,741000. 0151)
  1234   0
  1235   "FIA",7410 00,741000. 0153)
  1236   0
  1237   "FIA",7410 00,741000. 0154)
  1238   0
  1239   "FIA",7410 00,741000. 0155)
  1240   0
  1241   "FIA",7410 00,741000. 0156)
  1242   0
  1243   "FIA",7410 00,741000. 0157)
  1244   0
  1245   "FIA",7410 00,741000. 0158)
  1246   0
  1247   "FIA",7410 00,741000. 0161)
  1248   0
  1249   "FIA",7410 00,741000. 0162)
  1250   0
  1251   "FIA",7410 00,741000. 02)
  1252   0
  1253   "FIA",7410 00,741000. 0203)
  1254   0
  1255   "FIA",7410 00,741000. 0205)
  1256   0
  1257   "FIA",7410 00,741000. 0206)
  1258   0
  1259   "FIA",7410 00,741000. 0207)
  1260   0
  1261   "FIA",7410 00,741000. 0242)
  1262   0
  1263   "FIA",7410 00,741000. 0262)
  1264   0
  1265   "FIA",7410 00,741000. 03)
  1266   0
  1267   "FIA",7410 00,741000. 0306)
  1268   0
  1269   "FIA",7410 00,741000. 04)
  1270   0
  1271   "FIA",7410 00,741000. 05)
  1272   0
  1273   "FIA",7410 00,741000. 06)
  1274   0
  1275   "FIA",7410 00,741000. 07)
  1276   0
  1277   "FIA",7410 00,741000. 08)
  1278   0
  1279   "FIA",7410 00,741000. 09)
  1280   0
  1281   "FIA",7410 00,741000. 11)
  1282   0
  1283   "FIA",7410 00,741000. 12)
  1284   0
  1285   "FIA",7410 00,741000. 13)
  1286   0
  1287   "FIA",7410 00,741000. 14)
  1288   0
  1289   "FIA",7410 00,741000. 20631)
  1290   0
  1291   "FIA",7410 00,741000. 20633)
  1292   0
  1293   "FIA",7410 00,741000. 20634)
  1294   0
  1295   "FIA",7410 00,741000. 20642)
  1296   0
  1297   "FIA",7410 00,741000. 20643)
  1298   0
  1299   "FIA",7410 00,741000. 20644)
  1300   0
  1301   "FIA",7410 00,741000. 20645)
  1302   0
  1303   "FIA",7410 00,741000. 20646)
  1304   0
  1305   "FIA",7410 00,741000. 20649)
  1306   0
  1307   "FIA",7410 00,741000. 27)
  1308   0
  1309   "FIA",7410 00,741000. 28)
  1310   0
  1311   "FIA",7410 00,741000. 4001)
  1312   0
  1313   "FIA",7410 00,741000. 41)
  1314   0
  1315   "FIA",7410 00,741000. 4101)
  1316   0
  1317   "FIA",7410 00,741000. 411)
  1318   0
  1319   "FIA",7410 00,741000. 4201)
  1320   0
  1321   "FIA",7410 00,741000. 7)
  1322   0
  1323   "FIA",7410 00,741000. 701)
  1324   0
  1325   "FIA",7410 00.2)
  1326   CHAMPVA ST ORED IMAGE S
  1327   "FIA",7410 00.2,0)
  1328   ^CHMIMG(
  1329   "FIA",7410 00.2,0,0)
  1330   741000.2
  1331   "FIA",7410 00.2,0,1)
  1332   y^y^f^^^^n
  1333   "FIA",7410 00.2,0,10)
  1334  
  1335   "FIA",7410 00.2,0,11)
  1336  
  1337   "FIA",7410 00.2,0,"RL RO")
  1338  
  1339   "FIA",7410 00.2,74100 0.2)
  1340   0
  1341   "FIA",7410 00.2,74100 0.21)
  1342   0
  1343   "FIA",7410 00.2,74100 0.2101)
  1344   0
  1345   "FIA",7410 00.2,74100 0.22)
  1346   0
  1347   "FIA",7410 00.2,74100 0.221)
  1348   0
  1349   "FIA",7410 00.2,74100 0.23)
  1350   0
  1351   "FIA",7410 00.2,74100 0.2301)
  1352   0
  1353   "FIA",7410 00.2,74100 0.24)
  1354   0
  1355   "FIA",7410 00.2,74100 0.25)
  1356   0
  1357   "FIA",7410 00.2,74100 0.26)
  1358   0
  1359   "FIA",7410 00.2,74100 0.35)
  1360   0
  1361   "FIA",7410 00.2,74100 0.353)
  1362   0
  1363   "FIA",7410 02.17)
  1364   CHAMPVA PA YMENT PARA METER
  1365   "FIA",7410 02.17,0)
  1366   ^CHMDIC(74 1002.17,
  1367   "FIA",7410 02.17,0,0)
  1368   741002.17S
  1369   "FIA",7410 02.17,0,1)
  1370   y^y^f^^^^n
  1371   "FIA",7410 02.17,0,10 )
  1372  
  1373   "FIA",7410 02.17,0,11 )
  1374  
  1375   "FIA",7410 02.17,0,"R LRO")
  1376  
  1377   "FIA",7410 02.17,7410 02.17)
  1378   0
  1379   "FIA",7410 02.17,7410 02.17101)
  1380   0
  1381   "FIA",7410 02.17,7410 02.17102)
  1382   0
  1383   "FIA",7410 02.17,7410 02.172)
  1384   0
  1385   "FIA",7410 02.17,7410 02.17301)
  1386   0
  1387   "FIA",7410 02.17,7410 02.1741)
  1388   0
  1389   "FIA",7410 02.17,7410 02.1742)
  1390   0
  1391   "FIA",7410 02.17,7410 02.177)
  1392   0
  1393   "FIA",7410 02.17,7410 02.1777)
  1394   0
  1395   "FIA",7410 02.17,7410 02.17801)
  1396   0
  1397   "FIA",7410 02.17,7410 02.1780110 1)
  1398   0
  1399   "FIA",7410 02.17,7410 02.18)
  1400   0
  1401   "FIA",7410 02.17,7410 02.18102)
  1402   0
  1403   "FIA",7410 02.17,7410 02.19)
  1404   0
  1405   "FIA",7410 02.17,7410 02.19102)
  1406   0
  1407   "FIA",7410 02.17,7410 02.20102)
  1408   0
  1409   "FIA",7410 02.17,7410 02.21102)
  1410   0
  1411   "FIA",7410 02.17,7410 02.22102)
  1412   0
  1413   "FIA",7410 02.17,7410 02.23102)
  1414   0
  1415   "FIA",7410 02.17,7410 02.24102)
  1416   0
  1417   "FIA",7410 02.17,7410 02.25102)
  1418   0
  1419   "FIA",7410 02.17,7410 02.26102)
  1420   0
  1421   "FIA",7410 02.17,7410 02.33)
  1422   0
  1423   "FIA",7410 02.17,7410 02.68)
  1424   0
  1425   "FIA",7410 02.17,7410 02.69)
  1426   0
  1427   "FIA",7410 02.17,7410 02.7)
  1428   0
  1429   "FIA",7410 02.17,7410 02.701)
  1430   0
  1431   "FIA",7410 02.17,7410 02.702)
  1432   0
  1433   "FIA",7410 02.17,7410 02.703)
  1434   0
  1435   "FIA",7410 02.17,7410 02.705)
  1436   0
  1437   "FIA",7410 02.17,7410 02.706)
  1438   0
  1439   "FIA",7410 02.17,7410 02.9)
  1440   0
  1441   "FIA",7410 02.17,7410 02.9001)
  1442   0
  1443   "FIA",7410 02.17,7410 02.9003)
  1444   0
  1445   "FIA",7410 02.17,7410 02.9004)
  1446   0
  1447   "FIA",7410 02.17,7410 02.9007)
  1448   0
  1449   "FIA",7410 02.22)
  1450   CHAMPVA ST ATUS REASO N DICTIONA RY
  1451   "FIA",7410 02.22,0)
  1452   ^CHMDIC(74 1002.22,
  1453   "FIA",7410 02.22,0,0)
  1454   741002.22I
  1455   "FIA",7410 02.22,0,1)
  1456   y^y^f^^^^n ^^
  1457   "FIA",7410 02.22,0,10 )
  1458  
  1459   "FIA",7410 02.22,0,11 )
  1460  
  1461   "FIA",7410 02.22,0,"R LRO")
  1462  
  1463   "FIA",7410 02.22,7410 02.22)
  1464   0
  1465   "FIA",7410 02.22,7410 02.711)
  1466   0
  1467   "FIA",7412 01.15)
  1468   CLAIM ADJU STMENT GRO UP CODES ( 1033)
  1469   "FIA",7412 01.15,0)
  1470   ^CHMXDIC(7 41201.15,
  1471   "FIA",7412 01.15,0,0)
  1472   741201.15
  1473   "FIA",7412 01.15,0,1)
  1474   ^^f
  1475   "FIA",7412 01.15,0,10 )
  1476  
  1477   "FIA",7412 01.15,0,11 )
  1478  
  1479   "FIA",7412 01.15,0,"R LRO")
  1480  
  1481   "FIA",7412 01.15,7412 01.15)
  1482   0
  1483   "FIA",7412 01.16)
  1484   CLAIM ADJU STMENT REA SON CODES  (1034)
  1485   "FIA",7412 01.16,0)
  1486   ^CHMXDIC(7 41201.16,
  1487   "FIA",7412 01.16,0,0)
  1488   741201.16I
  1489   "FIA",7412 01.16,0,1)
  1490   ^^f
  1491   "FIA",7412 01.16,0,10 )
  1492  
  1493   "FIA",7412 01.16,0,11 )
  1494  
  1495   "FIA",7412 01.16,0,"R LRO")
  1496  
  1497   "FIA",7412 01.16,7412 01.16)
  1498   0
  1499   "FIA",7412 01.32)
  1500   HAC EDI 83 7 ERROR CO DES (HAC)
  1501   "FIA",7412 01.32,0)
  1502   ^CHMXDIC(7 41201.32,
  1503   "FIA",7412 01.32,0,0)
  1504   741201.32
  1505   "FIA",7412 01.32,0,1)
  1506   y^y^f^^^^n
  1507   "FIA",7412 01.32,0,10 )
  1508  
  1509   "FIA",7412 01.32,0,11 )
  1510  
  1511   "FIA",7412 01.32,0,"R LRO")
  1512  
  1513   "FIA",7412 01.32,7412 01.32)
  1514   0
  1515   "FIA",7412 01.32,7412 01.32101)
  1516   0
  1517   "FIA",7412 01.58)
  1518   CLAIM PAYM ENT REMARK  CODES (12 7)
  1519   "FIA",7412 01.58,0)
  1520   ^CHMXDIC(7 41201.58,
  1521   "FIA",7412 01.58,0,0)
  1522   741201.58
  1523   "FIA",7412 01.58,0,1)
  1524   ^^f
  1525   "FIA",7412 01.58,0,10 )
  1526  
  1527   "FIA",7412 01.58,0,11 )
  1528  
  1529   "FIA",7412 01.58,0,"R LRO")
  1530  
  1531   "FIA",7412 01.58,7412 01.58)
  1532   0
  1533   "FIA",7412 01.58,7412 01.701)
  1534   0
  1535   "FIA",7412 01.77)
  1536   EOB REASON /X12 CROSS  WALK
  1537   "FIA",7412 01.77,0)
  1538   ^CHMXDIC(7 41201.77,
  1539   "FIA",7412 01.77,0,0)
  1540   741201.77P
  1541   "FIA",7412 01.77,0,1)
  1542   ^^f
  1543   "FIA",7412 01.77,0,10 )
  1544  
  1545   "FIA",7412 01.77,0,11 )
  1546  
  1547   "FIA",7412 01.77,0,"R LRO")
  1548  
  1549   "FIA",7412 01.77,7412 01.77)
  1550   0
  1551   "FIA",7412 11.03)
  1552   X12 837 V5 010 CLAIM  RECORD LAY OUT
  1553   "FIA",7412 11.03,0)
  1554   ^CHMXCRL(7 41211.03,
  1555   "FIA",7412 11.03,0,0)
  1556   741211.03
  1557   "FIA",7412 11.03,0,1)
  1558   ^^f
  1559   "FIA",7412 11.03,0,10 )
  1560  
  1561   "FIA",7412 11.03,0,11 )
  1562  
  1563   "FIA",7412 11.03,0,"R LRO")
  1564  
  1565   "FIA",7412 11.03,7412 11.03)
  1566   0
  1567   "FIA",7412 11.03,7412 11.05)
  1568   0
  1569   "FIA",7412 11.03,7412 11.3101)
  1570   0
  1571   "FIA",7412 11.03,7412 11.3102)
  1572   0
  1573   "FIA",7412 11.03,7412 11.3103)
  1574   0
  1575   "FIA",7412 11.03,7412 11.31031)
  1576   0
  1577   "FIA",7412 11.03,7412 11.3104)
  1578   0
  1579   "FIA",7412 11.03,7412 11.3105)
  1580   0
  1581   "FIA",7412 11.03,7412 11.3106)
  1582   0
  1583   "FIA",7412 11.03,7412 11.3107)
  1584   0
  1585   "FIA",7412 11.03,7412 11.3108)
  1586   0
  1587   "FIA",7412 11.03,7412 11.3109)
  1588   0
  1589   "FIA",7412 11.03,7412 11.3111)
  1590   0
  1591   "FIA",7412 11.03,7412 11.3201)
  1592   0
  1593   "FIA",7412 11.03,7412 11.3201101 )
  1594   0
  1595   "FIA",7412 11.03,7412 11.3201101 1)
  1596   0
  1597   "FIA",7412 13)
  1598   Final CSTA T Alert
  1599   "FIA",7412 13,0)
  1600   ^CHCSTAT(7 41213,
  1601   "FIA",7412 13,0,0)
  1602   741213
  1603   "FIA",7412 13,0,1)
  1604   ^^f
  1605   "FIA",7412 13,0,10)
  1606  
  1607   "FIA",7412 13,0,11)
  1608  
  1609   "FIA",7412 13,0,"RLRO ")
  1610  
  1611   "FIA",7412 13,741213)
  1612   0
  1613   "FIA",7412 15)
  1614   Reversing  835 Alert
  1615   "FIA",7412 15,0)
  1616   ^CH835REV( 741215,
  1617   "FIA",7412 15,0,0)
  1618   741215
  1619   "FIA",7412 15,0,1)
  1620   y^y^f^^^^n
  1621   "FIA",7412 15,0,10)
  1622  
  1623   "FIA",7412 15,0,11)
  1624  
  1625   "FIA",7412 15,0,"RLRO ")
  1626  
  1627   "FIA",7412 15,741215)
  1628   0
  1629   "KRN",19.1 ,933,-1)
  1630   0^1
  1631   "KRN",19.1 ,933,0)
  1632   CHMERSK^CH M EDI REOP EN SUPERVI SOR KEY
  1633   "KRN",19.1 ,934,-1)
  1634   0^2
  1635   "KRN",19.1 ,934,0)
  1636   CHMERVK^CH M EDI REOP EN VE KEY
  1637   "KRN",19.1 ,935,-1)
  1638   0^3
  1639   "KRN",19.1 ,935,0)
  1640   CHMSRSK^CH M EDI SB R EOPEN SUP  KEY
  1641   "KRN",19.1 ,936,-1)
  1642   0^4
  1643   "KRN",19.1 ,936,0)
  1644   CHMSRVK^CH M EDI SB R EOPEN VE K EY
  1645   "MBREQ")
  1646   0
  1647   "ORD",3,19 .1)
  1648   19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
  1649   "ORD",3,19 .1,0)
  1650   SECURITY K EY
  1651   "QUES","XP F1",0)
  1652   Y
  1653   "QUES","XP F1","??")
  1654   ^D REP^XPD H
  1655   "QUES","XP F1","A")
  1656   Shall I wr ite over y our |FLAG|  File
  1657   "QUES","XP F1","B")
  1658   YES
  1659   "QUES","XP F1","M")
  1660   D XPF1^XPD IQ
  1661   "QUES","XP F2",0)
  1662   Y
  1663   "QUES","XP F2","??")
  1664   ^D DTA^XPD H
  1665   "QUES","XP F2","A")
  1666   Want my da ta |FLAG|  yours
  1667   "QUES","XP F2","B")
  1668   YES
  1669   "QUES","XP F2","M")
  1670   D XPF2^XPD IQ
  1671   "QUES","XP I1",0)
  1672   YO
  1673   "QUES","XP I1","??")
  1674   ^D INHIBIT ^XPDH
  1675   "QUES","XP I1","A")
  1676   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  1677   "QUES","XP I1","B")
  1678   NO
  1679   "QUES","XP I1","M")
  1680   D XPI1^XPD IQ
  1681   "QUES","XP M1",0)
  1682   PO^VA(200, :EM
  1683   "QUES","XP M1","??")
  1684   ^D MG^XPDH
  1685   "QUES","XP M1","A")
  1686   Enter the  Coordinato r for Mail  Group '|F LAG|'
  1687   "QUES","XP M1","B")
  1688  
  1689   "QUES","XP M1","M")
  1690   D XPM1^XPD IQ
  1691   "QUES","XP O1",0)
  1692   Y
  1693   "QUES","XP O1","??")
  1694   ^D MENU^XP DH
  1695   "QUES","XP O1","A")
  1696   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  1697   "QUES","XP O1","B")
  1698   YES
  1699   "QUES","XP O1","M")
  1700   D XPO1^XPD IQ
  1701   "QUES","XP Z1",0)
  1702   Y
  1703   "QUES","XP Z1","??")
  1704   ^D OPT^XPD H
  1705   "QUES","XP Z1","A")
  1706   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  1707   "QUES","XP Z1","B")
  1708   NO
  1709   "QUES","XP Z1","M")
  1710   D XPZ1^XPD IQ
  1711   "QUES","XP Z2",0)
  1712   Y
  1713   "QUES","XP Z2","??")
  1714   ^D RTN^XPD H
  1715   "QUES","XP Z2","A")
  1716   Want to MO VE routine s to other  CPUs
  1717   "QUES","XP Z2","B")
  1718   NO
  1719   "QUES","XP Z2","M")
  1720   D XPZ2^XPD IQ
  1721   "RTN")
  1722   99
  1723   "RTN","CH8 35F1")
  1724   0^1^B18573 909
  1725   "RTN","CH8 35F1",1,0)
  1726   CH835F1 ;H AC/AEB;EDI  835 FILE; Feb 06, 20 19@10:53:0 8
  1727   "RTN","CH8 35F1",2,0)
  1728    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  1729   "RTN","CH8 35F1",3,0)
  1730    ;HR-PBM-P HASE 1B-Be gin;;;;;Bu ild 17
  1731   "RTN","CH8 35F1",4,0)
  1732    ;HR - Tea m Track #:  5592
  1733   "RTN","CH8 35F1",5,0)
  1734    ;HR - New  835 Routi ne that re places the  old CHEDI * Routines
  1735   "RTN","CH8 35F1",6,0)
  1736    ;DEV00422 5 1/21/201 0 AEB
  1737   "RTN","CH8 35F1",7,0)
  1738    ; 8/27-28 /2012  MAD E FUNCTION  CALLS FOR  THE RECOR D GENERATI ON BLOCKS  (HDR,BPR,T RN,PLB)
  1739   "RTN","CH8 35F1",8,0)
  1740    ; 10/11/1 2 DLB  DEV 7820 REFAC TORED THE  RECORD GEN ERATION TO  TABLE DRI VEN PROCES S.
  1741   "RTN","CH8 35F1",9,0)
  1742    ; 1/9/201 3 DLB  DEV 7820 MODIF IED FMSLOO P() FUNCTI ON TO PERF ORM STATUS  UPDATES W HEN RECORD
  1743   "RTN","CH8 35F1",10,0 )
  1744    ;                         IS WR ITTEN TO T HE 835 FIL E. (UPDSTA TUS(I))
  1745   "RTN","CH8 35F1",11,0 )
  1746    ; 3/2013  DLB    BAL CHK(PAYI,E DII) REPLA CED WITH T HE CH835BA L.INT ROUT INES TO PE RFORM LINE
  1747   "RTN","CH8 35F1",12,0 )
  1748    ;                         AND C LAIM LEVEL  BALANCE C HECKS
  1749   "RTN","CH8 35F1",13,0 )
  1750    ; 12/10/2 013  DLB   REMOVED TH E CALL TO  DSLA^CHTFL IB2 IN SOR T() BECAUS E IT IS NO T A DATE C HECK AS
  1751   "RTN","CH8 35F1",14,0 )
  1752    ;                        ORIGIN ALLY THOUG HT
  1753   "RTN","CH8 35F1",15,0 )
  1754    ; 12/10/2 013  DLB   INITIALIZE D THE CHEC K/EFT NUMB ER VARIABL E TO THE F MS DOC ID  SO NON-PAY MENT WILL
  1755   "RTN","CH8 35F1",16,0 )
  1756    ;                        NOT BE  "NULL" IN  THE "TRN"  RECORD, F IELD 4
  1757   "RTN","CH8 35F1",17,0 )
  1758    ; 12/11/2 013  DLB   MODIFIED T HE TEST FO R "0" PAYM ENT FROM " 0" TO "0.9 9" IN THE  TRN RECORD  GENERATIO N
  1759   "RTN","CH8 35F1",18,0 )
  1760    ; 07/17/2 014  JAK   CONSOLIDAT ED DED / C AT CAP ADJ USTMENT RO UTINES
  1761   "RTN","CH8 35F1",19,0 )
  1762    ; 12/3/15  SLT MODIF IED TO CHE CK FOR A C LAIM LEVEL  PAID AMOU NT <1$ AND  USE CARC  B5
  1763   "RTN","CH8 35F1",20,0 )
  1764    ;              ALSO  CHECKING F OR ACTIVE  CARCs AND  RARCs
  1765   "RTN","CH8 35F1",21,0 )
  1766    ;MTN02864 8: issue w ith the "B PR" and "S VC" record s needs 9.   DRW 06/1 3/2017
  1767   "RTN","CH8 35F1",22,0 )
  1768    ;MTN02877 2: CHANGIN G ALL LINE S EXCEEDIN G 255 TO L ESS THAN T HIS.  DRW  07/27/2017
  1769   "RTN","CH8 35F1",23,0 )
  1770    ; 02/21/2 018 SBB CC 4002-001,  CC4002-002 , CC4002-0 03 updates  for Rever sal 835 me ssage
  1771   "RTN","CH8 35F1",24,0 )
  1772    ; 05/14/2 018 DLB AD DED CHECK  FOR "AGING " PDIs IN  CHK5010();  PDIs OVER  180 DAYS  IN THE
  1773   "RTN","CH8 35F1",25,0 )
  1774    ;                        PAST A RE REMOVED  FROM THE  "NEEDS SEN T" QUEUE
  1775   "RTN","CH8 35F1",26,0 )
  1776    ; 5/23/20 18  DLB AD DED THE JU LIAN TO FI LEMAN DATE  CONVERSIO N FUNCTION  AS THE FU NCTION
  1777   "RTN","CH8 35F1",27,0 )
  1778    ;                        PREVIO USLY RESID ED IN CHFM LIB1.INT,  WHICH IS N OT IN TEST /PROD
  1779   "RTN","CH8 35F1",28,0 )
  1780    ; 5/23/20 18  DLB RE MOVED REV8 35 VARIABL E FROM THE  CODE:
  1781   "RTN","CH8 35F1",29,0 )
  1782    ; RFE 01/ 09/19 INC3 837109 Add  reporting  mechanism
  1783   "RTN","CH8 35F1",30,0 )
  1784    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  1785   "RTN","CH8 35F1",31,0 )
  1786    ;
  1787   "RTN","CH8 35F1",32,0 )
  1788    Q
  1789   "RTN","CH8 35F1",33,0 )
  1790    ;
  1791   "RTN","CH8 35F1",34,0 )
  1792    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  1793   "RTN","CH8 35F1",35,0 )
  1794    ; SORT IS  CALLED BY  THE CH835 DRV ROUTIN E, IN THE  MAIN() FUN CTION.
  1795   "RTN","CH8 35F1",36,0 )
  1796    ; THIS FU NCTION CRE ATES THE ^ TMP($J,"ED I-835",CLE ARINGHOUSE  ID,^CHMED I(I)) ARRA Y
  1797   "RTN","CH8 35F1",37,0 )
  1798    ; 1) KILL  THE EXIST ING ^TMP($ J,"EDI-835 ") ARRAY ( TARGET ARR AY FOR ^CH MEDI(I)
  1799   "RTN","CH8 35F1",38,0 )
  1800    ;      IN DEXES READ Y FOR 835  PROCESSING )
  1801   "RTN","CH8 35F1",39,0 )
  1802    ; 2) LOOP  THROUGH T HE ^CHMEDI ("G") XREF , RETRIEVI NG ^CHMEDI (I) INDEX  FOR
  1803   "RTN","CH8 35F1",40,0 )
  1804    ;      EN TRIES MATC HING THE F ILE NUMBER  PROVIDED.
  1805   "RTN","CH8 35F1",41,0 )
  1806    ; 3) RETR IEVE THE ^ CHMPAY(I)  INDEX
  1807   "RTN","CH8 35F1",42,0 )
  1808    ; 4) VERI FY THE CLA IM CREATIO N DATE
  1809   "RTN","CH8 35F1",43,0 )
  1810    ;      EX IT IF NOCL EAIM CREAT ION DATE
  1811   "RTN","CH8 35F1",44,0 )
  1812    ; 5) SAVE  ANY CREAT ION DATES  TO ^CHMZHO LD() PRIOR  TO 303101 6
  1813   "RTN","CH8 35F1",45,0 )
  1814    ; 6) CHEC K THE JULI AN DATE FO R PDI, IF  PRIOR TO 2 013133 OR  4010 CLAIM , SKIP 835  PROCESSIN G
  1815   "RTN","CH8 35F1",46,0 )
  1816    ; 7) IF T HE CLAIM W AS REJECTE D, CLEAR P AYMENT, CA T CAP, AND  DEDUCTIBL E AMOUNTS
  1817   "RTN","CH8 35F1",47,0 )
  1818    ; 8) SET  THE CLEARI NGHOUSE ID  (CHPID) A ND ^CHMEDI (I) VALUES  INTO THE
  1819   "RTN","CH8 35F1",48,0 )
  1820    ;      ^T MP($J,"EDI -835",CHPI D,EDII) FO R THE NEXT  PROCESSIN G STEP
  1821   "RTN","CH8 35F1",49,0 )
  1822    ; 9) NOTE  THAT THE  CHPID VALU E IS STORE D DURING T HE SORT SO  THAT DENT AL
  1823   "RTN","CH8 35F1",50,0 )
  1824    ;    CLAI MS THAT AR E SUBMITTE D WITH THE  MEDICAL C LAIMS CAN  BE EXTRACT ED LATER.
  1825   "RTN","CH8 35F1",51,0 )
  1826    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  1827   "RTN","CH8 35F1",52,0 )
  1828    ;
  1829   "RTN","CH8 35F1",53,0 )
  1830   SORT(FILEI ) ; Sort F MS_ID's by  payor and  load into  ^TMP glob al
  1831   "RTN","CH8 35F1",54,0 )
  1832    ; FILEI N EWLY CREAT ED INDEX T O ^CHMEDIF () FILE
  1833   "RTN","CH8 35F1",55,0 )
  1834    N EDII,ED IJ,PAYI,CI CMPDT,CNT, CHPID,PDI, VERDATE,CL MCRDATE
  1835   "RTN","CH8 35F1",56,0 )
  1836    S X=132 X  ^%ZOSF("R M")                                                                                ; SE T THE CACH E DISPLAY  TO 132 CHA RACTERS
  1837   "RTN","CH8 35F1",57,0 )
  1838    K ^TMP($J ,"EDI-835" )
  1839   "RTN","CH8 35F1",58,0 )
  1840    S EDII=0, CNT=0,CHPI D=0
  1841   "RTN","CH8 35F1",59,0 )
  1842    F  S EDII =$O(^CHMED I("G",FILE I,EDII)) Q :(+(EDII)= 0)  D                   ; LOOP T HRU THE "E DI 835 FIL E #"s
  1843   "RTN","CH8 35F1",60,0 )
  1844    .S CICMPD T=""
  1845   "RTN","CH8 35F1",61,0 )
  1846    .S EDIJ=0
  1847   "RTN","CH8 35F1",62,0 )
  1848    .F  S EDI J=$O(^CHME DI(EDII,1, EDIJ)) Q:+ (EDIJ)=0   Q:(CHPID=" ")  D   ;  LOOP THRU  "J" INDEXE S
  1849   "RTN","CH8 35F1",63,0 )
  1850    ..S PAYI= $P($G(^CHM EDI(EDII,1 ,EDIJ,0)), "^",1)                    ; RETR IEVING THE  POINTER-> ^CHMPAY()
  1851   "RTN","CH8 35F1",64,0 )
  1852    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !!,"P AYI VALUE  RETRIEVED:  ",PAYI
  1853   "RTN","CH8 35F1",65,0 )
  1854    ..Q:'PAYI                                                                                                        ; IF N O PAYI IN  ^CHMEDI, S KIP THE CL AIM QUEUE
  1855   "RTN","CH8 35F1",66,0 )
  1856    ..Q:'$$JU LIANDT^CH8 35TMP(PAYI )                                                              ;  RUN ONE DA Y'S CLAIMS  AT A TIME
  1857   "RTN","CH8 35F1",67,0 )
  1858    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"PR OCESSING P AYI: ",PAY I
  1859   "RTN","CH8 35F1",68,0 )
  1860    ..I '$D(G LPAY) D                                                                                       ; MU ST ENSURE  GLPAY IS D EFINED, FU NCTION NEE DS X1=PAYI
  1861   "RTN","CH8 35F1",69,0 )
  1862    ...S X1=P AYI D PROG TYP^CHFCD0 01                                                     ; DSLA FUN CTION NEED S @GLPAY I NDIRECTION  POINTER S ET UP
  1863   "RTN","CH8 35F1",70,0 )
  1864    ..;Q:'$$D SLA^CHTFLI B2(PAYI)                                                          ; DO NOT Q UEUE PRE-S LA CLAIMS  UNTIL LATE R DATE DLB  12/10/201 3
  1865   "RTN","CH8 35F1",71,0 )
  1866    ..S CHPID =$$CHPID^C H835FU1(PA YI)                                                    ; RETRIEVE  CLAIM BUF FER INDEXE S FOR MEDI CAL/PHARMA CY
  1867   "RTN","CH8 35F1",72,0 )
  1868    ..S:$D(^C HMPAY(PAYI ,0)) CICMP DT=$P(^CHM PAY(PAYI,0 ),"^",25)   ; GET THE  CLAIM CRE ATION DATE
  1869   "RTN","CH8 35F1",73,0 )
  1870    ..Q:CICMP DT=""
  1871   "RTN","CH8 35F1",74,0 )
  1872    ..S:CICMP DT<3031016  ^CHMZHOLD ("835_PRE- HIPAA_CLM" ,PAYI,FILE I,EDII)=""  ;RECORD B AD CREATIO N DATE
  1873   "RTN","CH8 35F1",75,0 )
  1874    ..Q:CICMP DT<3031016
  1875   "RTN","CH8 35F1",76,0 )
  1876    ..S VERDA TE=$$CHK50 10(PAYI)                                        ; VALI DATE 5010  CLAIM AND  PDI IS IN  THE "ACTIV E RANGE"
  1877   "RTN","CH8 35F1",77,0 )
  1878    ..I 'VERD ATE  D  Q                                                                    ; 0 INDICA TES FAILED  VALIDATIO N FOR CHK5 010
  1879   "RTN","CH8 35F1",78,0 )
  1880    ...I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"F 1: SORT: H AC CLAIM # : ",$P(^CH MPAY(PAYI, 0),"^",1), " VERSION/ DATE CHECK  FAILED!"
  1881   "RTN","CH8 35F1",79,0 )
  1882    ...D SETA SIDE(EDII)                                                          ; DLB 5/ 14/2018SET  ASIDE THE  CLAIM FOR  THE ^CHME DI(PAYI)
  1883   "RTN","CH8 35F1",80,0 )
  1884    ..I '$D(G LPAY) S X1 =PAYI D PR OGTYP^CHFC D001    ;  DLB 7/11/2 013DEV0078 20 SETS GL PAY IF NOT  DEFINED.
  1885   "RTN","CH8 35F1",81,0 )
  1886    ..I $P(^C HMPAY(PAYI ,0),"^",2) =0 D                                 ; if c laim rejec ted
  1887   "RTN","CH8 35F1",82,0 )
  1888    ...D CLRP MT^CHTFLIB 2(PAYI)                                         ; clea r payment  data
  1889   "RTN","CH8 35F1",83,0 )
  1890    ...I $D(^ CHMPAY(PAY I,1))  D
  1891   "RTN","CH8 35F1",84,0 )
  1892    ....I ($P (^CHMPAY(P AYI,1),"^" ,5)'=""!($ P(^CHMPAY( PAYI,1),"^ ",6)'=""))  D
  1893   "RTN","CH8 35F1",85,0 )
  1894    .....D AD J^CHGRCCD( PAYI,"SUB" )                                             ; revers e cat cap  / deductib le data ;D EV021244 J AK 07/17/1 4
  1895   "RTN","CH8 35F1",86,0 )
  1896    .....D CL RCCD^CHTFL IB2(PAYI)                                       ; clea r cat cap  / deductib le data
  1897   "RTN","CH8 35F1",87,0 )
  1898    ..S ^TMP( $J,"EDI-83 5",CHPID,E DII)="",CN T=CNT+1                            ; SET TH E ^TMP ARR AY WITH ED I POINTERS
  1899   "RTN","CH8 35F1",88,0 )
  1900    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"F1 : SORT: HA C CLAIM #:  ",$P(^CHM PAY(PAYI,0 ),"^",1),"  QUEUED."
  1901   "RTN","CH8 35F1",89,0 )
  1902    Q
  1903   "RTN","CH8 35F1",90,0 )
  1904    ;
  1905   "RTN","CH8 35F1",91,0 )
  1906    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  1907   "RTN","CH8 35F1",92,0 )
  1908    ; CHK5010  IS BOOLEA N CHECK FO R 5010 CLA IMS (DO NO T QUEUE 40 10 CLAIMS  or
  1909   "RTN","CH8 35F1",93,0 )
  1910    ; 5010 CL AIMS PROCE SSED PRIOR  TO SLA UA T LOADS) P ER BUSINES S, JULIAN  DATE 20131 33
  1911   "RTN","CH8 35F1",94,0 )
  1912    ; IS THE  START OF U AT LOADS.
  1913   "RTN","CH8 35F1",95,0 )
  1914    ; ROUTINE  WILL FAIL  FOR NON-5 010 VERSIO N FLAG, OR  IF THE CR OSS-REFERE NCE
  1915   "RTN","CH8 35F1",96,0 )
  1916    ; VALUES  CANNOT BE  SUCCESSFUL LY EXTRACT ED
  1917   "RTN","CH8 35F1",97,0 )
  1918    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  1919   "RTN","CH8 35F1",98,0 )
  1920    ;
  1921   "RTN","CH8 35F1",99,0 )
  1922   CHK5010(PA YI)
  1923   "RTN","CH8 35F1",100, 0)
  1924    N PDI,PCN ,XI,IDXSTR ,VERFLG,EN V,PDIDATE, TODAY,ELAP SED,CUTOFF
  1925   "RTN","CH8 35F1",101, 0)
  1926    ;S ENV=$$ ENVIR^CHTF LIB                                                                       ;  GET THE CU RRENT ENVI RONMENT ID
  1927   "RTN","CH8 35F1",102, 0)
  1928    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1)                        ; RETR IEVE THE P DI FROM ^C HMPAY
  1929   "RTN","CH8 35F1",103, 0)
  1930    S PDIDATE =$E(PDI,1, 7)                                                                ; CCYYDDD  DATE
  1931   "RTN","CH8 35F1",104, 0)
  1932    Q:PDIDATE <2013133 0                                                                   ; SLA UAT  LOAD START  DATE
  1933   "RTN","CH8 35F1",105, 0)
  1934    Q:'$$CHKP DI(PDI) 0                                                                            ;  CHECK PDI  AGAINST TH E CUTOFF D ATE
  1935   "RTN","CH8 35F1",106, 0)
  1936    S PCN=0,P CN=$O(^CHM XCLE("PDI" ,PDI,PCN))                           ; EXTR ACT THE PC N VALUE
  1937   "RTN","CH8 35F1",107, 0)
  1938    Q:(PCN=0) !(PCN="")  0                                                                 ; INVALID  CROSS-REFE RENCE FAIL
  1939   "RTN","CH8 35F1",108, 0)
  1940    S XI=0,XI =$O(^CHMXC LE("PDI",P DI,PCN,XI) )
  1941   "RTN","CH8 35F1",109, 0)
  1942    Q:XI=0                                                                                                           ; INVA LID CROSS- REFERENCE:  FAIL
  1943   "RTN","CH8 35F1",110, 0)
  1944    S IDXSTR= 0,IDXSTR=$ O(^CHMXCLE ("PDI",PDI ,PCN,XI,ID XSTR))
  1945   "RTN","CH8 35F1",111, 0)
  1946    Q:IDXSTR= "" 0                                                                                 ;  INVALID CR OSS-REFERE NCE: FAIL
  1947   "RTN","CH8 35F1",112, 0)
  1948    S AI=$P(I DXSTR,"*", 1)                                                                        ;  TRANSACTIO N BUFFER
  1949   "RTN","CH8 35F1",113, 0)
  1950    Q:AI=0 0                                                                                                ; IN VALID INDE X: FAIL
  1951   "RTN","CH8 35F1",114, 0)
  1952    S VERFLG= $P(^CHMXCL A(AI,0),"^ ",13)                                         ; VERSIO N FLAG
  1953   "RTN","CH8 35F1",115, 0)
  1954    Q $E(VERF LG,1,6)="0 05010"                                                            ; RETURN V ALID/INVAL ID 5010 CH ECK
  1955   "RTN","CH8 35F1",116, 0)
  1956    ;
  1957   "RTN","CH8 35F1",117, 0)
  1958    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1959   "RTN","CH8 35F1",118, 0)
  1960    ; CHKPDI( PDI) RETUR NS TRUE IF  THE PDI D ATE IS WIT HIN A CUTO FF WINDOW  OF
  1961   "RTN","CH8 35F1",119, 0)
  1962    ; THE LAS T 180 DAYS  (TODAY-18 0 DAYS); F ALSE IF OU TSIDE THE  WINDOW
  1963   "RTN","CH8 35F1",120, 0)
  1964    ; THE ^%D TC FUNCTIO N PROVIDES  THE CALCU LATION FOR :
  1965   "RTN","CH8 35F1",121, 0)
  1966    ; PDI DAT E (IN FM F ORMAT) - C UTOFF DATE  (FM)
  1967   "RTN","CH8 35F1",122, 0)
  1968    ; A POSIT IVE RESULT  INDICATES  THE PDI D ATE > CUTO FF DATE; C ONTINUE
  1969   "RTN","CH8 35F1",123, 0)
  1970    ; A NEGAT IVE RESULT  INDICATES  THE PDI D ATE IS BEF ORE CUTOFF ; SET CLAI M ASIDE
  1971   "RTN","CH8 35F1",124, 0)
  1972    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1973   "RTN","CH8 35F1",125, 0)
  1974    ;
  1975   "RTN","CH8 35F1",126, 0)
  1976   CHKPDI(PDI )
  1977   "RTN","CH8 35F1",127, 0)
  1978    ; PDI  TH E PDI OF I NTEREST IN  THE 835 P ROCESS
  1979   "RTN","CH8 35F1",128, 0)
  1980    N FMDATE, CUTFM,PDID ATE
  1981   "RTN","CH8 35F1",129, 0)
  1982    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHKPDI (): PDI= " ,PDI
  1983   "RTN","CH8 35F1",130, 0)
  1984    S PDIDATE =$E(PDI,1, 7)                                                                ; EXTRACT  THE PDI DA TE
  1985   "RTN","CH8 35F1",131, 0)
  1986    D NOW^%DT C
  1987   "RTN","CH8 35F1",132, 0)
  1988    S FMDATE= X                                                                                             ; GE T TODAY'S  DATE IN FM  FORMAT (Y YYDDD)
  1989   "RTN","CH8 35F1",133, 0)
  1990    S CUTOFF= $$CALCWIN( FMDATE)                                                           ; CALCULAT E THE CUTO FF WINDOW  (FM FORMAT ) FOR QUEU EING 835s
  1991   "RTN","CH8 35F1",134, 0)
  1992    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHKPDI (): TODAY  (FM): ",FM DATE," -18 0 DAYS = C UTOFF (FM) = ",CUTOFF
  1993   "RTN","CH8 35F1",135, 0)
  1994    S PDIFM=$ $PDI2FM(PD IDATE)                                                            ; GET PDI  DATE INTO  FM EQUIVAL ENT
  1995   "RTN","CH8 35F1",136, 0)
  1996    U 0 W:$$E NVIR^CHTFL IB="LIVE"  !,"CHKPDI( ): PDIFM D ATE: ",PDI FM
  1997   "RTN","CH8 35F1",137, 0)
  1998    S X1=PDIF M                                                                                             ; PD I FM DATE  (YYYMMDD)
  1999   "RTN","CH8 35F1",138, 0)
  2000    S X2=CUTO FF                                                                                   ;  CUTOFF FM  DATE (YYYM MDD)
  2001   "RTN","CH8 35F1",139, 0)
  2002    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHKPDI ():^%DTC C ALL: PDI D ATE = ",X1 ,"   CUTOF F DATE= ", X2
  2003   "RTN","CH8 35F1",140, 0)
  2004    D ^%DTC                                                                                                 ; SU BTRACT PDI  DATE FROM  CUTOFF DA TE
  2005   "RTN","CH8 35F1",141, 0)
  2006    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHKPDI (): DIFF=  ",X ; FILE MAN RETURN S RESULT I N X
  2007   "RTN","CH8 35F1",142, 0)
  2008    Q:X<0 0
  2009   "RTN","CH8 35F1",143, 0)
  2010    Q 1
  2011   "RTN","CH8 35F1",144, 0)
  2012    ;
  2013   "RTN","CH8 35F1",145, 0)
  2014    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2015   "RTN","CH8 35F1",146, 0)
  2016    ; CALCWIN (FMDATE) U SES THE C^ %DTC FILEM AN FUNCTIO N TO CALCU LATE THE F M
  2017   "RTN","CH8 35F1",147, 0)
  2018    ; CUTOFF  DATE FOR 8 35 QUEUEIN G.
  2019   "RTN","CH8 35F1",148, 0)
  2020    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2021   "RTN","CH8 35F1",149, 0)
  2022    ;
  2023   "RTN","CH8 35F1",150, 0)
  2024   CALCWIN(FM DATE)
  2025   "RTN","CH8 35F1",151, 0)
  2026    ; FMDATE        FM F ORMAT STAR TING DATE  FOR USEIN  THE CUTOFF  DATE CALC ULATION.
  2027   "RTN","CH8 35F1",152, 0)
  2028    S X1=FMDA TE ; USER  PROVIDED F M DATE (YY YDDD FORMA T)
  2029   "RTN","CH8 35F1",153, 0)
  2030    S X2=-180       ; 18 0 DAY WIND OW AS DETE RMINED BY  BUSINESS G ROUP
  2031   "RTN","CH8 35F1",154, 0)
  2032    D C^%DTC        ; SU BTRACT THE  180 DAYS  (BUSINESS  WINDOW FOR  QUEUEING)
  2033   "RTN","CH8 35F1",155, 0)
  2034    Q X             ; RE TURN THE F M FORMAT D ATE FOR CU TOFF
  2035   "RTN","CH8 35F1",156, 0)
  2036    ;
  2037   "RTN","CH8 35F1",157, 0)
  2038    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2039   "RTN","CH8 35F1",158, 0)
  2040    ; PDI2FM( PDIDATE) C ONVERT THE  PDI DATE  "2015027"  TO A FILEM AN DATE "2 0150127"
  2041   "RTN","CH8 35F1",159, 0)
  2042    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2043   "RTN","CH8 35F1",160, 0)
  2044    ;
  2045   "RTN","CH8 35F1",161, 0)
  2046   PDI2FM(PDI DATE) ;CON VERT PDI J ULIAN DATE  (CCYYDDD)  TO FM DAT E (YYYYMMD D)
  2047   "RTN","CH8 35F1",162, 0)
  2048    ; PASS PD IDATE AS A  STRING IF  LEADING Z ERO'S ARE  SIGNIFICAN T
  2049   "RTN","CH8 35F1",163, 0)
  2050    ; FUNCTIO N VALID FO R DATES 1- 1-1950 - 1 2-31-2049
  2051   "RTN","CH8 35F1",164, 0)
  2052    N WDATE,F MBASE,PDIY R,PDIFM
  2053   "RTN","CH8 35F1",165, 0)
  2054    Q:'$D(PDI DATE)
  2055   "RTN","CH8 35F1",166, 0)
  2056    S FMBASE= 2000                                                       ; FILE MAN BASED  ON 2000
  2057   "RTN","CH8 35F1",167, 0)
  2058    S PDIYR=$ E(PDIDATE, 1,4)
  2059   "RTN","CH8 35F1",168, 0)
  2060    S WDATE=( PDIYR-FMBA SE)_$E(PDI DATE,5,7)          ;  APPEND THE  DDD VALUE
  2061   "RTN","CH8 35F1",169, 0)
  2062    S PDIFM=$ $JULFM(WDA TE)
  2063   "RTN","CH8 35F1",170, 0)
  2064    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"PDI2FM (): PDIFM  DATE= ",PD IFM
  2065   "RTN","CH8 35F1",171, 0)
  2066    Q PDIFM
  2067   "RTN","CH8 35F1",172, 0)
  2068    ;
  2069   "RTN","CH8 35F1",173, 0)
  2070    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2071   "RTN","CH8 35F1",174, 0)
  2072    ; FMJUL(F MDATE) RET URNS THE P ROVIDED FM  DATE IN J ULIAN FORM AT CCYYDDD
  2073   "RTN","CH8 35F1",175, 0)
  2074    ; PDI DAT ES ARE IN  THE CCYYDD D JULIAN F ORMAT, SO  THIS FUNCT ION GETS
  2075   "RTN","CH8 35F1",176, 0)
  2076    ; THE CUR RENT DATE  IN THE CCY YDDD FORMA T SO THE C UTOFF DATE  FOR 835
  2077   "RTN","CH8 35F1",177, 0)
  2078    ; QUEUEIN G CAN BE C ALCULATED.
  2079   "RTN","CH8 35F1",178, 0)
  2080    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2081   "RTN","CH8 35F1",179, 0)
  2082    ;
  2083   "RTN","CH8 35F1",180, 0)
  2084   FMJUL(FMDT ) ;CONVERT  FM DATE T O JULIAN D ATE
  2085   "RTN","CH8 35F1",181, 0)
  2086    N D1,D2,D 3,YEAR
  2087   "RTN","CH8 35F1",182, 0)
  2088    Q:'$D(FMD T) 0
  2089   "RTN","CH8 35F1",183, 0)
  2090    S X=$E(FM DT,1,3)_"0 000" D H^% DTC S D2=% H
  2091   "RTN","CH8 35F1",184, 0)
  2092    S X=FMDT  D H^%DTC S  D1=%H
  2093   "RTN","CH8 35F1",185, 0)
  2094    S D3=D1-D 2+1 S:D3<1 00 D3="0"_ D3 S:D3<10  D3="0"_D3
  2095   "RTN","CH8 35F1",186, 0)
  2096    S YEAR=$E (FMDT,1,3)
  2097   "RTN","CH8 35F1",187, 0)
  2098    S D3=YEAR _D3
  2099   "RTN","CH8 35F1",188, 0)
  2100    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"FMJUL( ):  DATE=  ",D3
  2101   "RTN","CH8 35F1",189, 0)
  2102    Q D3
  2103   "RTN","CH8 35F1",190, 0)
  2104    ;
  2105   "RTN","CH8 35F1",191, 0)
  2106    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2107   "RTN","CH8 35F1",192, 0)
  2108    ; CONVERT  THE JULIA N DATE "13 091" TO A  FILEMAN DA TE "313040 1"
  2109   "RTN","CH8 35F1",193, 0)
  2110    ; W $$JUL FM^CHFMLIB 1(13091)     3130401
  2111   "RTN","CH8 35F1",194, 0)
  2112    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2113   "RTN","CH8 35F1",195, 0)
  2114    ;
  2115   "RTN","CH8 35F1",196, 0)
  2116   JULFM(JDT)  ;CONVERT  JULIAN DAT E TO FM DA TE (YYYMMD D)
  2117   "RTN","CH8 35F1",197, 0)
  2118    ; Y2K cha nged to ma ke it comp liant
  2119   "RTN","CH8 35F1",198, 0)
  2120    ;  JDT          JULI AN DATE TO  CONVERT I N "13091"  (YYDDD) FO RMAT
  2121   "RTN","CH8 35F1",199, 0)
  2122    N X,Y
  2123   "RTN","CH8 35F1",200, 0)
  2124    I '$D(JDT ) S JDT=$$ FMJUL(JDT)
  2125   "RTN","CH8 35F1",201, 0)
  2126    S Y=1900  I +$E(JDT, 1,2)<50 S  Y=2000
  2127   "RTN","CH8 35F1",202, 0)
  2128    S X=Y+$E( JDT,1,2)-1 700_"0000"  D H^%DTC
  2129   "RTN","CH8 35F1",203, 0)
  2130    S %H=%H+$ E(JDT,3,5) -1 D YMD^% DTC
  2131   "RTN","CH8 35F1",204, 0)
  2132    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"JULFM( ):  DATE=  ",X
  2133   "RTN","CH8 35F1",205, 0)
  2134    Q X
  2135   "RTN","CH8 35F1",206, 0)
  2136    ;
  2137   "RTN","CH8 35F1",207, 0)
  2138    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2139   "RTN","CH8 35F1",208, 0)
  2140    ; FMSLOOP ()  ID THE  MASIN PRO CESSING LO OP FOR THE  GENERATIO N OF 835 R ECORDS.
  2141   "RTN","CH8 35F1",209, 0)
  2142    ; THE ^TM P("EDI-835 ") ARRAY C REATED IN  "SORT" IS  USED TO CO NTROL THE  CREATION
  2143   "RTN","CH8 35F1",210, 0)
  2144    ; OF RECO RDS FOR TH E 835 STAG ING FILE.
  2145   "RTN","CH8 35F1",211, 0)
  2146    ; TARGET  DIRECTORY:  "HAC_HFS$ :[X12OCR.I N]" (SEE F CREATE^CHM XMDRV)
  2147   "RTN","CH8 35F1",212, 0)
  2148    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2149   "RTN","CH8 35F1",213, 0)
  2150    ; 1) FMSL OOP LOOPS  THROUGH TH E ^TMP($J, "EDI-835", PROVIDER I D,^CHMEDI( I))
  2151   "RTN","CH8 35F1",214, 0)
  2152    ;      AR RAY CREATE D IN "SORT ".
  2153   "RTN","CH8 35F1",215, 0)
  2154    ; 2) THE  ^TMP($J,"E DI_CREATE" ) ARRAY IS  CREATED A NEW FOR EA CH SET OF  835
  2155   "RTN","CH8 35F1",216, 0)
  2156    ;   RECOR DS. THIS A RRAY HAS S EPARATE IN DEXES FOR  EACH OF TH E RECORDS
  2157   "RTN","CH8 35F1",217, 0)
  2158    ;      TO  BE GENERA TED, EACH  LOADED DUR ING THE FU NCTION BY  THE NAME O F
  2159   "RTN","CH8 35F1",218, 0)
  2160    ;      TH E RECORD ( I.E. HDR,  BPR, ETC.)
  2161   "RTN","CH8 35F1",219, 0)
  2162    ; 3) THE  COMMON PAR AMETERS US ED BY THE  INDIVIDUAL  RECORDS A RE RETRIEV ED
  2163   "RTN","CH8 35F1",220, 0)
  2164    ;      BA SED ON THE  ^CHMEDI(I ) AND (J)  INDEXES, A ND PASSED  TO THE REC ORD
  2165   "RTN","CH8 35F1",221, 0)
  2166    ;      GE NERATION F UNCTIONS.
  2167   "RTN","CH8 35F1",222, 0)
  2168    ; 4) A SE PARATE LOO P IS USED  TO CONTROL  GENERATIO N OF THE C LP/CLPCAS  AND
  2169   "RTN","CH8 35F1",223, 0)
  2170    ;      SV C/SVCCAS/S VCLQ RECOR DS. THIS I S DUE TO T HE MULTIPL E ENTRY PO TENTIAL
  2171   "RTN","CH8 35F1",224, 0)
  2172    ;      OF  THESE FOR  A SINGLE  CLAIM.
  2173   "RTN","CH8 35F1",225, 0)
  2174    ; 5) ONCE  ALL RECOR DS FOR THI S CLAIM HA VE BEEN GE NERATED AN D STORED I N
  2175   "RTN","CH8 35F1",226, 0)
  2176    ;      TH EIR RESPEC TIVE NODES  OF THE ^T MP($J,"EDI _CREATE")  ARRAY, THE
  2177   "RTN","CH8 35F1",227, 0)
  2178    ;      RE CORDS ARE  WRITTEN TO  THE OUTPU T FILE.
  2179   "RTN","CH8 35F1",228, 0)
  2180    ; 6) WHEN  THE RECOR DS HAVE BE EN WRITTEN , THE ^CHM EDI STATUS  IS CHANGE D
  2181   "RTN","CH8 35F1",229, 0)
  2182    ;      FR OM "NEEDS  SENT" TO " SENT"
  2183   "RTN","CH8 35F1",230, 0)
  2184    ; 7) CONT INUE TO ST EP 1 UNTIL  ALL CLAIM S HAVE BEE N PROCESSE D.
  2185   "RTN","CH8 35F1",231, 0)
  2186    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2187   "RTN","CH8 35F1",232, 0)
  2188    ; NOT THA T THE CHPI D VALUE IS  EXTRACTED  FROM THE  ARRAY FOR  EACH CLAIM . THIS
  2189   "RTN","CH8 35F1",233, 0)
  2190    ; ENABLES  THE DENTA L CLAIMS T HAT ARE SU BMITTED WI TH THE MED ICAL CLAIM S TO
  2191   "RTN","CH8 35F1",234, 0)
  2192    ; BE EXTR ACTED FOR  THE FINAL  835 OUTPUT .
  2193   "RTN","CH8 35F1",235, 0)
  2194    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  2195   "RTN","CH8 35F1",236, 0)
  2196    ;
  2197   "RTN","CH8 35F1",237, 0)
  2198   FMSLOOP(FI LEI,EI) ;
  2199   "RTN","CH8 35F1",238, 0)
  2200    ; FILEI         FILE  INDEX FOR  THE 835 F ILE TO BE  GENERATED  (USED IN R ECORDS)
  2201   "RTN","CH8 35F1",239, 0)
  2202    ; EI            ENTI TY INDEX F OR RECORDS
  2203   "RTN","CH8 35F1",240, 0)
  2204    N EDII,ED IJ,LJ,STSE Q,NFILE,FM SID,VENI,P YRID,CLMCN T,STATUS,P DI,PLB,PAY I,SVCFLG,R CH,DT,CLAI M,CHPID,OA B6,MAILCT
  2205   "RTN","CH8 35F1",241, 0)
  2206    ; Add MAI LCT to new ed variabl es RFE 01/ 09/19 INC3 837109
  2207   "RTN","CH8 35F1",242, 0)
  2208    S (STSEQ, CLMCNT,PLB ,EDII)=0
  2209   "RTN","CH8 35F1",243, 0)
  2210    D NOW^%DT C S DT=X                                                                                               ; CURR ENT DATE
  2211   "RTN","CH8 35F1",244, 0)
  2212    S CHPID=" "
  2213   "RTN","CH8 35F1",245, 0)
  2214    F  S CHPI D=$O(^TMP( $J,"EDI-83 5",CHPID))  Q:CHPID=" "  D           ; DENT AL COMES I N WITH MED ICAL, MUST  TRACK FOR  NFILE FIE LD
  2215   "RTN","CH8 35F1",246, 0)
  2216    .S PYRID= $P($G(^CHM EDIPA(EI,0 )),"^",8)                                     ; PAYER  ID VALUE S ET ONCE PE R LOOP
  2217   "RTN","CH8 35F1",247, 0)
  2218    .F  S EDI I=$O(^TMP( $J,"EDI-83 5",CHPID,E DII)) Q:+( EDII)=0  D     ; LOOP  THROUGH ^ CHMEDI() " I" INDEXES
  2219   "RTN","CH8 35F1",248, 0)
  2220    ..K ^TMP( $J,"EDI_CR EATE")                                          ; ARRA Y CONTAINI NG THE REC ORD SET FO R THIS ^CH MEDI(I)
  2221   "RTN","CH8 35F1",249, 0)
  2222    ..S NFILE =CHPID_"_" _FILEI                                          ; NFIL E VARIABLE  USED TO I DENTIFY ME DICAL/DENT AL RECORDS
  2223   "RTN","CH8 35F1",250, 0)
  2224    ..S STSEQ =STSEQ+1                                                            ; RECORD  SEQUENCE  COUNTER
  2225   "RTN","CH8 35F1",251, 0)
  2226    ..Q:'$D(^ CHMEDI(EDI I,1))                                           ; EXIT  IF NO POI NTER TO ^C HMPAY() NO DE
  2227   "RTN","CH8 35F1",252, 0)
  2228    ..S FMSID =$P(^CHMED I(EDII,0), "^",1)             ;  RECONCILIA TION NUMBE R USED BY  TRN/PLB RE CORDS
  2229   "RTN","CH8 35F1",253, 0)
  2230    ..S EDIJ= 0,EDIJ=$O( ^CHMEDI(ED II,1,EDIJ) ) Q:+(EDIJ )=0            ; GET  ^CHMEDI PO INTER "J"  INDEX TO R ETRIEVE ^C HMPAY "I"
  2231   "RTN","CH8 35F1",254, 0)
  2232    ..S PAYI= $P($G(^CHM EDI(EDII,1 ,EDIJ,0)), "^",1)                    ; GET  THE ^CHMPA Y "I" POIN TER VALUE  FROM ^CHME DI RECORD
  2233   "RTN","CH8 35F1",255, 0)
  2234    ..S VENI= $P(^CHMEDI (EDII,0)," ^",5)                                ; VEND OR INDEX U SED IN HDR , BPR, AND  PLB RECOR DS
  2235   "RTN","CH8 35F1",256, 0)
  2236    ..S:VENI= "" VENI=$P (^CHMPAY(P AYI,0),"^" ,3)                       ; ALTE RNATE LOCA TION FOR V ENDOR INDE X
  2237   "RTN","CH8 35F1",257, 0)
  2238    ..S PDI=$ P($P(^CHMP AY(PAYI,0) ,"^",4),"* ",1)                      ; CLAI M PDI FOR  THE CURREN T ENTRY
  2239   "RTN","CH8 35F1",258, 0)
  2240    ..S CLAIM =$P(^CHMPA Y(PAYI,0), "^",1)                               ; HAC  CLAIM NUMB ER FOR THE  PDI
  2241   "RTN","CH8 35F1",259, 0)
  2242    ..S ^CHME DI("C",PAY I,EDII,EDI J)=""                                ; SET  THE ^CHMED I XREF FOR  PTR->CHMP AY
  2243   "RTN","CH8 35F1",260, 0)
  2244    ..S STATU S=$$STATUS (PAYI)                                          ; RETR IEVE TEXT  DESC FOR S TATUS
  2245   "RTN","CH8 35F1",261, 0)
  2246    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !!,"* **F1: FMSL OOP:(",CLM CNT,") EDI I: ",EDII, "  PAYI: " ,PAYI,"  C LM #: ",CL AIM,!?10,"    PDI=",P DI,"  STAT US=",STATU S
  2247   "RTN","CH8 35F1",262, 0)
  2248    ..;SBB 02 /21/2018 C C4002-001  SET REV835  variable  to 22 for  voids
  2249   "RTN","CH8 35F1",263, 0)
  2250    ..S REV83 5=0 I $P(^ CHMPAY(PAY I,0),"^",2 )=11 S REV 835=22
  2251   "RTN","CH8 35F1",264, 0)
  2252    ..D HDR(P AYI,NFILE, STSEQ,VENI )                                             ; HEADER  RECORD GE NERATION
  2253   "RTN","CH8 35F1",265, 0)
  2254    ..D BPR(P AYI,NFILE, STSEQ,VENI ,EDII,EI,D T)                        ; BPR  RECORD GEN ERATION
  2255   "RTN","CH8 35F1",266, 0)
  2256    ..D TRN(P AYI,NFILE, STSEQ,FMSI D,EI)                                ; TRN  RECORD GEN ERATION
  2257   "RTN","CH8 35F1",267, 0)
  2258    ..S PAMT= $$CLM^CH83 5F2(EDII,V ENI,NFILE, STSEQ,.OAB 6)                      ; CLP/CL PCAS, SVC/ SVCCAS REC ORD GENERA TION
  2259   "RTN","CH8 35F1",268, 0)
  2260    ..D PLB(N FILE,STSEQ ,VENI,EDII ,DT,PAYI,P AMT)                      ; PLB  RECORD GEN ERATION
  2261   "RTN","CH8 35F1",269, 0)
  2262    ..Q:'$$BA LANCE^CH83 5BAL()                                          ; BALA NCE CHK ON  GENERATED  RECORDS ( ^TMP($J,"E DI-CREATE" )): 0=IMBA LANCE
  2263   "RTN","CH8 35F1",270, 0)
  2264    ..Q:$$ACT CARC^CH835 ACT()!$$AC TRARC^CH83 5ACT()      ; CARCs a nd RARCs n eed to be  active
  2265   "RTN","CH8 35F1",271, 0)
  2266    ..Q:$P(^C HMEDI(EDII ,0),"^",2) =7                                   ; CHEC K THE STAT US FLAG FO R INDEXING  ERROR
  2267   "RTN","CH8 35F1",272, 0)
  2268    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"SU CCESS FOR  CLAIM #: " ,CLAIM,"   IN FILE: " ,NFILE
  2269   "RTN","CH8 35F1",273, 0)
  2270    ..D WRT                                                              ; WRIT E TRANSACT IONS TO FI LE
  2271   "RTN","CH8 35F1",274, 0)
  2272    ..D UPDST ATUS(EDII)                                                 ; UPDA TE THE "NE EDS SENT"  TO "SENT"  STATUS
  2273   "RTN","CH8 35F1",275, 0)
  2274    ..S CLMCN T=CLMCNT+1                                                 ; CLAI M INDEX CO UNTER VARI ABLE
  2275   "RTN","CH8 35F1",276, 0)
  2276    ..D RPTFI GS(PAYI) ;  RFE 01/09 /19 INC383 7109
  2277   "RTN","CH8 35F1",277, 0)
  2278    .Q                                                                   ; QUIT  FOR INNER  FOR LOOP
  2279   "RTN","CH8 35F1",278, 0)
  2280    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"END  OF FILE:  CLMCNT: ", CLMCNT,"   STSEQ: ",S TSEQ
  2281   "RTN","CH8 35F1",279, 0)
  2282    D MAILFIG S ; RFE 01 /09/19 INC 3837109
  2283   "RTN","CH8 35F1",280, 0)
  2284    Q CLMCNT
  2285   "RTN","CH8 35F1",281, 0)
  2286    ;
  2287   "RTN","CH8 35F1",282, 0)
  2288    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2289   "RTN","CH8 35F1",283, 0)
  2290    ; STATUS  FUNCTION R ETURNS THE  TEXT DESC RIPTION FO R THE STAT US VALUE
  2291   "RTN","CH8 35F1",284, 0)
  2292    ; CONTAIN ED IN ^CHM PAY(I,0),  FIELD 2. T HIS VALUE  IS NOT REQ UIRED FOR
  2293   "RTN","CH8 35F1",285, 0)
  2294    ; RECORD  GENERATION .
  2295   "RTN","CH8 35F1",286, 0)
  2296    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2297   "RTN","CH8 35F1",287, 0)
  2298    ;
  2299   "RTN","CH8 35F1",288, 0)
  2300   STATUS(PAY I)
  2301   "RTN","CH8 35F1",289, 0)
  2302    ; PAYI ^C HMPAY(I) I NDEX
  2303   "RTN","CH8 35F1",290, 0)
  2304    N STATUS, STATDESC
  2305   "RTN","CH8 35F1",291, 0)
  2306    S STATDES C=""
  2307   "RTN","CH8 35F1",292, 0)
  2308    S STATUS= $P(^CHMPAY (PAYI,0)," ^",2)                                         ; CLAIM  STATUS
  2309   "RTN","CH8 35F1",293, 0)
  2310    ;CHANGING  STATDESC  TO A BLOCK  FORMAT SO  THAT IT I S LESS THA N 255  MTN 028772
  2311   "RTN","CH8 35F1",294, 0)
  2312    ; BDB 11/ 13/2017 AD DED VOID R EVERSED
  2313   "RTN","CH8 35F1",295, 0)
  2314    S STATDES C=$S(STATU S=0:"REJEC TED",STATU S=1:"IN PR OCESS",
  2315   "RTN","CH8 35F1",296, 0)
  2316      STATUS= 2:"PAYMENT  REQUESTED ",STATUS=3 :"EOB REQU ESTED",
  2317   "RTN","CH8 35F1",297, 0)
  2318      STATUS= 4:"COMPLET E",STATUS= 5:"ADJUDIC ATED",STAT US=6:"PAYM ENT REJECT ED CAPPS/C ALM",
  2319   "RTN","CH8 35F1",298, 0)
  2320      STATUS= 7:"ADMINIS TRATIVE SU SPENSE",ST ATUS=8:"PA YMENT APPR OVED CAPPS /CALM",
  2321   "RTN","CH8 35F1",299, 0)
  2322      STATUS= 9:"MANUALL Y PROCESSE D",STATUS= 10:"DELETE D",STATUS= 11:"VOIDED ",STATUS=1 2:"REVERSE D")
  2323   "RTN","CH8 35F1",300, 0)
  2324    Q STATDES C
  2325   "RTN","CH8 35F1",301, 0)
  2326    ;
  2327   "RTN","CH8 35F1",302, 0)
  2328   RPTFIGS(PA YI) ; Add  total of s ent 835's  broken dow n by progr am type an d COB RFE  01/09/19 I NC3837109
  2329   "RTN","CH8 35F1",303, 0)
  2330    Q:PAYI=""   ; Should n't happen
  2331   "RTN","CH8 35F1",304, 0)
  2332    S RPTSUB= $P($G(^CHM INDEX(PAYI ,0)),U,2)
  2333   "RTN","CH8 35F1",305, 0)
  2334    Q:RPTSUB= ""
  2335   "RTN","CH8 35F1",306, 0)
  2336    ; now, is  it COB?
  2337   "RTN","CH8 35F1",307, 0)
  2338    D
  2339   "RTN","CH8 35F1",308, 0)
  2340    . S PDI=$ P($P(^CHMP AY(PAYI,0) ,"^",4),"* ",1) Q:PDI =""
  2341   "RTN","CH8 35F1",309, 0)
  2342    . S PCN=$ O(^CHMXCLE ("PDI",PDI ,""))  Q:P CN=""  Q:P CN=0
  2343   "RTN","CH8 35F1",310, 0)
  2344    . S XI=$O (^CHMXCLE( "PDI",PDI, PCN,"")) Q :XI=""  Q: XI=0
  2345   "RTN","CH8 35F1",311, 0)
  2346    . S IDXST R=$O(^CHMX CLE("PDI", PDI,PCN,XI ,"")) Q:ID XSTR=""
  2347   "RTN","CH8 35F1",312, 0)
  2348    . S AI=$P (IDXSTR,"* ",1) Q:AI= ""
  2349   "RTN","CH8 35F1",313, 0)
  2350    . S CHTPI =$P($G(^CH MXCLA(AI,1 )),U) Q:CH TPI=""
  2351   "RTN","CH8 35F1",314, 0)
  2352    . S CHTPI =$O(^CHMXT P("C",CHTP I,"")) Q:C HTPI=""
  2353   "RTN","CH8 35F1",315, 0)
  2354    . S IDX=$ O(^CHMX277 ("B",CHTPI ,0))
  2355   "RTN","CH8 35F1",316, 0)
  2356    . S:$P(^C HMX277(IDX ,0),"^",4) ["COB" RPT SUB=RPTSUB _U_1
  2357   "RTN","CH8 35F1",317, 0)
  2358    . Q
  2359   "RTN","CH8 35F1",318, 0)
  2360    S MAILCT( RPTSUB)=1+ $G(MAILCT( RPTSUB))
  2361   "RTN","CH8 35F1",319, 0)
  2362    Q
  2363   "RTN","CH8 35F1",320, 0)
  2364    ;
  2365   "RTN","CH8 35F1",321, 0)
  2366   MAILFIGS ;  RFE 01/09 /19 INC383 7109
  2367   "RTN","CH8 35F1",322, 0)
  2368    S SUBJECT ="835 Sent  for CHAMP VA"
  2369   "RTN","CH8 35F1",323, 0)
  2370    K LXMY
  2371   "RTN","CH8 35F1",324, 0)
  2372    S LXMY(" PII             ")=""
  2373   "RTN","CH8 35F1",325, 0)
  2374    N DUZ
  2375   "RTN","CH8 35F1",326, 0)
  2376    K ZML
  2377   "RTN","CH8 35F1",327, 0)
  2378    S TEXT="Z ML("
  2379   "RTN","CH8 35F1",328, 0)
  2380    I '$D(MAI LCT) D  Q
  2381   "RTN","CH8 35F1",329, 0)
  2382    . S ZML(1 )="No 835' s sent tod ay"
  2383   "RTN","CH8 35F1",330, 0)
  2384    . D VMAIL (SUBJECT,T EXT,.LXMY)
  2385   "RTN","CH8 35F1",331, 0)
  2386    . Q
  2387   "RTN","CH8 35F1",332, 0)
  2388    S LINECT= 0
  2389   "RTN","CH8 35F1",333, 0)
  2390    S RPTSUB= ""
  2391   "RTN","CH8 35F1",334, 0)
  2392    F  S RPTS UB=$O(MAIL CT(RPTSUB) ) Q:'RPTSU B  D
  2393   "RTN","CH8 35F1",335, 0)
  2394    . S PROGT YP=$P(RPTS UB,U)
  2395   "RTN","CH8 35F1",336, 0)
  2396    . S LINEC T=LINECT+1
  2397   "RTN","CH8 35F1",337, 0)
  2398    . S RPTDE SC=$P($G(^ CHMDIC(741 002.94,PRO GTYP,0)),U ,2)
  2399   "RTN","CH8 35F1",338, 0)
  2400    . S COB=" "
  2401   "RTN","CH8 35F1",339, 0)
  2402    . I $P(RP TSUB,U,2)= 1 S COB="C rossovers"
  2403   "RTN","CH8 35F1",340, 0)
  2404    . S ZML(L INECT)=RPT DESC_" "_C OB_" "_MAI LCT(RPTSUB )
  2405   "RTN","CH8 35F1",341, 0)
  2406    . Q
  2407   "RTN","CH8 35F1",342, 0)
  2408    D VMAIL(S UBJECT,TEX T,.LXMY)
  2409   "RTN","CH8 35F1",343, 0)
  2410    Q
  2411   "RTN","CH8 35F1",344, 0)
  2412    ;
  2413   "RTN","CH8 35F1",345, 0)
  2414   VMAIL(SUBJ ECT,TEXT,L XMY) ;
  2415   "RTN","CH8 35F1",346, 0)
  2416    ;  SUBJEC T     SUBJ ECT LINE F OR THE EMA IL
  2417   "RTN","CH8 35F1",347, 0)
  2418    ;  TEXT         TEXT  FOR THE E MAIL
  2419   "RTN","CH8 35F1",348, 0)
  2420    ;    LXMY          TARGETED R ECIPIENTS  FOR THE EM AIL (S LXM Y="DUZ" (M AILMAN),LX MY=" PII                " (MAILMAN ),LXMY("
P
I                  ")=""(OUTL OOK))
  2421   "RTN","CH8 35F1",349, 0)
  2422    N EMLID
  2423   "RTN","CH8 35F1",350, 0)
  2424    S U="^"
  2425   "RTN","CH8 35F1",351, 0)
  2426    S DUZ=.5                                                                      ; DEFAUL T DUZ
  2427   "RTN","CH8 35F1",352, 0)
  2428    S XMDUZ=. 5                                                                   ; POSTMA N DUZ
  2429   "RTN","CH8 35F1",353, 0)
  2430    S XMSUB=S UBJECT                                                     ; SET  SUBJECT LI NE FOR EMA IL
  2431   "RTN","CH8 35F1",354, 0)
  2432    S XMTEXT= TEXT                                                       ; SET  TEXT ARRAY  FOR BODY  OF EMAIL
  2433   "RTN","CH8 35F1",355, 0)
  2434    S EMLID=0
  2435   "RTN","CH8 35F1",356, 0)
  2436    F  S EMLI D=$O(LXMY( EMLID)) Q: EMLID=""   D
  2437   "RTN","CH8 35F1",357, 0)
  2438    .S XMY($S (EMLID?1.N :$P(^VA(20 0,EMLID,0) ,"^",1),1: EMLID))=""
  2439   "RTN","CH8 35F1",358, 0)
  2440    D ^XMD                                                                                 ; SEND IT  OFF
  2441   "RTN","CH8 35F1",359, 0)
  2442    Q
  2443   "RTN","CH8 35F1",360, 0)
  2444    ;
  2445   "RTN","CH8 35F1",361, 0)
  2446    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2447   "RTN","CH8 35F1",362, 0)
  2448    ;
  2449   "RTN","CH8 35F1",363, 0)
  2450    ; THIS FU NCTION HAS  BEEN REPL ACE WITH T HE CH835BA L.INT ROUT INE, WHICH
  2451   "RTN","CH8 35F1",364, 0)
  2452    ; PERFORM S THE LINE  LEVEL AND  CLAIM LEV EL BALANCE  CHECKS JU ST PRIOR
  2453   "RTN","CH8 35F1",365, 0)
  2454    ; TO WRIT ING THE 83 5 RECORDS  TO THE STA GING FILE.  DLB 3/201 3
  2455   "RTN","CH8 35F1",366, 0)
  2456    ;
  2457   "RTN","CH8 35F1",367, 0)
  2458    ; BALCHK( ) DETERMIN ES IF THE  LINE LEVEL  AND CLAIM  LEVEL BIL LED VS
  2459   "RTN","CH8 35F1",368, 0)
  2460    ; PAID/PA TIENT RESP  VALUES BA LANCE. IF  THERE IS A N IMBALANC E, THE
  2461   "RTN","CH8 35F1",369, 0)
  2462    ; CLAIM I S LOGGED I N ^TMP($J, "BALERR"),  AND NO 83 5 RECORD I S GENERATE D.
  2463   "RTN","CH8 35F1",370, 0)
  2464    ; THE IMB ALANCE IS  REPORTED V IA EMAIL T O THE PST  GROUP.
  2465   "RTN","CH8 35F1",371, 0)
  2466    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2467   "RTN","CH8 35F1",372, 0)
  2468    ; BASED O N BRIAN MA TTHEWS' IN PUT, A COM MON BALANC E CHECK OP ERATION CA N
  2469   "RTN","CH8 35F1",373, 0)
  2470    ; BE IMPL EMENTED.
  2471   "RTN","CH8 35F1",374, 0)
  2472    ; 1a)Serv ice Line i s accepted , but HAC  paid amoun t = 0   Th ere are tw o
  2473   "RTN","CH8 35F1",375, 0)
  2474    ; situati ons where  this happe ns. The ex ample give n is for N ON OHI cla ims
  2475   "RTN","CH8 35F1",376, 0)
  2476    ; where t he amount  the HAC wo uld have p aid is app lied to th e deductib le.
  2477   "RTN","CH8 35F1",377, 0)
  2478    ; BALANCE  CHECK= Bi lled Charg es - all c laim adjus tments (to tal of CO,  PR, PI, a nd OA)
  2479   "RTN","CH8 35F1",378, 0)
  2480    ; 1b) OHI  claims ma y have OHI  Service L ine paymen ts + OHI S ervice Lin e
  2481   "RTN","CH8 35F1",379, 0)
  2482    ; adjustm ents that  equal the  Billed cha rges.  In  this case  we would h ave
  2483   "RTN","CH8 35F1",380, 0)
  2484    ; an OA23  adjustmen t for the  total bill ed charges .
  2485   "RTN","CH8 35F1",381, 0)
  2486    ; BALANCE  CHECK: Bi lled Charg es - all c laim adjus tments (to tal of CO,  PR, PI, a nd OA)
  2487   "RTN","CH8 35F1",382, 0)
  2488    ; 2) Serv ice Line i s accepted  and HAC p ays more t han zero.
  2489   "RTN","CH8 35F1",383, 0)
  2490    ; BALANCE  CHECK: Bi lled Charg es - {HAC  payment +  all claim  adjustment s (total o f CO, PR,  PI, and OA )}
  2491   "RTN","CH8 35F1",384, 0)
  2492    ; 3) When  we reject  a line, t he allowab le amount  will be ze ro and the  HAC will  pay zero.
  2493   "RTN","CH8 35F1",385, 0)
  2494    ; BALANCE  CHECK: Bi lled Charg es - all c laim adjus tments (to tal of CO,  PR, PI, a nd OA)
  2495   "RTN","CH8 35F1",386, 0)
  2496    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2497   "RTN","CH8 35F1",387, 0)
  2498    ; 1a, 1b,  AND 3:  H AC PAID AM OUNT SHOUL D BE 0, SO  INCLUDING  THE VARIA BLE HAS NO  EFFECT
  2499   "RTN","CH8 35F1",388, 0)
  2500    ; 2: HAC  PAID AMOUN T IS REPOR TED, SO IT  SHOULD BE  INCLUDED  IN THE CHE CK
  2501   "RTN","CH8 35F1",389, 0)
  2502    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2503   "RTN","CH8 35F1",390, 0)
  2504    ;
  2505   "RTN","CH8 35F1",391, 0)
  2506   BALCHK(PAY I,EDII)
  2507   "RTN","CH8 35F1",392, 0)
  2508    ; PAYI          "I"  INDEX TO T HE ^CHMPAY () GLOBAL
  2509   "RTN","CH8 35F1",393, 0)
  2510    ; EDII          "I"  INDEX FOR  THE ^CHMED I FILE
  2511   "RTN","CH8 35F1",394, 0)
  2512    N SORTDAT A,POHIPD,O HIPR,ADDOH IPD,OHIPRB AL,MDCAIDP D,TPLPD,HA CPD,ALLOHI ,ALLPAID,C HGAMT,ALLO WAMT,BALER R
  2513   "RTN","CH8 35F1",395, 0)
  2514    S BALERR= 0
  2515   "RTN","CH8 35F1",396, 0)
  2516    I '$D(GLP AY) S X1=P AYI D PROG TYP^CHFCD0 01               ;AEB  4 20/2012  DEV007820  SETS GLPA Y IF NOT D EFINED.
  2517   "RTN","CH8 35F1",397, 0)
  2518    I GLPAY=" " S X1=PAY I D PROGTY P^CHFCD001                           ;AEB 4  20/2012 D EV007820 S ETS GLPAY  IF NOT DEF INED.
  2519   "RTN","CH8 35F1",398, 0)
  2520    I $P(@(GL PAY_"PAYI, ""COMMON"" )"),"^",18 )=1!('$$DS LA^CHTFLIB 2(PAYI)) D   ;if auto  distribut e OR claim  prior to  SLA (Servi ce Line Ad judication ) ;JAK 7/2 8/11 DEV00 7820
  2521   "RTN","CH8 35F1",399, 0)
  2522    .D INIT^C HGCUU3(PAY I,"ALLOW", "AUTO")                                       ; AUTO-D ISTRIBUTIO N (creates  LINEID if  not exist ) ;JAK 7/2 8/11 DEV00 7820
  2523   "RTN","CH8 35F1",400, 0)
  2524    E  D
  2525   "RTN","CH8 35F1",401, 0)
  2526    .D INIT^C HGCUU3(PAY I,"ALLOW", "TPLBENE")                           ; MANU AL...distr ibute tpl  & bene pmt s and calc  ohi
  2527   "RTN","CH8 35F1",402, 0)
  2528    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1)                        ; CLAI M PDI FROM  ^CHMPAY(P AYI,0),"^" ,4)
  2529   "RTN","CH8 35F1",403, 0)
  2530    D SORT^CH FBCUTL(PAY I)                                                                ; AEB UTIL  FOR UNITS , ALLOWED  AMOUNT, ET C.
  2531   "RTN","CH8 35F1",404, 0)
  2532    S IMGL=0
  2533   "RTN","CH8 35F1",405, 0)
  2534    F  S IMGL =$O(^TMP($ J,"IMG2PAY ",PAYI,IMG L)) Q:+(IM GL)=0  D ;  LOOP THRO UGH THE SE RVICE LINE S
  2535   "RTN","CH8 35F1",406, 0)
  2536    .S SORTDA TA=^TMP($J ,"LINE",PA YI,IMGL)
  2537   "RTN","CH8 35F1",407, 0)
  2538    .S POHIPD =+$P(SORTD ATA,"^",1)                                               ; PRIMAR Y OHI PAID  VALUE
  2539   "RTN","CH8 35F1",408, 0)
  2540    .S OHIPR= +$P(SORTDA TA,"^",2)                                                ; OHI PA TIENT RESP ONSIBILITY
  2541   "RTN","CH8 35F1",409, 0)
  2542    .S ADDOHI PD=+$P(SOR TDATA,"^", 3)                                            ; RETRIE VE ADDITIO NAL OHI PA ID AMOUNT
  2543   "RTN","CH8 35F1",410, 0)
  2544    .S OHIPRB AL=+$P(SOR TDATA,"^", 4)                                            ; RETRIE VE OHI PR  BALANCE AM OUNT
  2545   "RTN","CH8 35F1",411, 0)
  2546    .S MDCAID PD=+$P(SOR TDATA,"^", 5)                                            ; MEDICA ID PAYMENT S RECEIVED
  2547   "RTN","CH8 35F1",412, 0)
  2548    .S TPLPD= +$P(SORTDA TA,"^",6)                                                ; TPL PA YMENTS REC EIVED
  2549   "RTN","CH8 35F1",413, 0)
  2550    .S HACPD= +$P(SORTDA TA,"^",12)                                               ; ADJUDI CATED PAYM ENT AMOUNT
  2551   "RTN","CH8 35F1",414, 0)
  2552    .S ALLOHI =POHIPD+AD DOHIPD                                                            ; GET OHI  TOTAL PAID
  2553   "RTN","CH8 35F1",415, 0)
  2554    .S ALLPAI D=(ALLOHI+ MDCAIDPD+T PLPD+HACPD )                         ; TOTA L ALL PAYM ENTS RECEI VED + AMT  HAC PAID
  2555   "RTN","CH8 35F1",416, 0)
  2556    .S CHGAMT =+$P(SORTD ATA,"^",8)                                               ; LINE C HARGE FROM  SORT^CHFB CUTL
  2557   "RTN","CH8 35F1",417, 0)
  2558    .S ALLOWA MT=+$P(SOR TDATA,"^", 7)                                            ; ALLOWE D AMOUNT F ROM SORT^C HFBCUTL
  2559   "RTN","CH8 35F1",418, 0)
  2560    .I (CHGAM T-(ALLPAID +OHIPRBAL) '=0) D                               ; LINE  LEVEL BAL ANCE CHECK
  2561   "RTN","CH8 35F1",419, 0)
  2562    ..S BALER R=1                                                                                  ;  RETURN VAL UE
  2563   "RTN","CH8 35F1",420, 0)
  2564    ..D NOW^% DTC                                                                                  ;  GET TODAY' S DATE
  2565   "RTN","CH8 35F1",421, 0)
  2566    ..S TODAY =X                                                                                   ;  DATE BALAN CE ERROR R ECORDED
  2567   "RTN","CH8 35F1",422, 0)
  2568    ..S ARR(. 02)=2                                                                                         ; SE T STATUS T O BALANCE  ERROR
  2569   "RTN","CH8 35F1",423, 0)
  2570    ..S ARR(. 07)=TODAY                                                                            ;  SET DATE B ALANCE ERR OR ENCOUNT ERED
  2571   "RTN","CH8 35F1",424, 0)
  2572    ..S RESUL T=$$UPDATE ^CHHRLIBFM ("CHMEDI(I ,0)",EDII, $$SETDR^CH HRLIBFM("A RR")) ; UP DATE THE ^ CHMEDI FIL E
  2573   "RTN","CH8 35F1",425, 0)
  2574    ..S CHPDI =$P($P($G( ^CHMPAY(PA YI,0)),"^" ,4),"*",1)       ; GE T THE OFFE NDING PDI
  2575   "RTN","CH8 35F1",426, 0)
  2576    ..S HACCL M=$P($G(^C HMPAY(PAYI ,0)),"^",1 )                         ; GET  THE OFFEND ING HAC CL AIM NUMBER
  2577   "RTN","CH8 35F1",427, 0)
  2578    ..S ^TMP( $J,"BALERR ",CHPDI)=C HPDI_"^"_H ACCLM_"^"_ CHGAMT_"^" _ALLPAID_" ^"_OHIPRBA L
  2579   "RTN","CH8 35F1",428, 0)
  2580    ..W !,"LI NE LVL BAL ERR: ",CHP DI_"^"_HAC CLM_"^"_ED II_"^"_TOD AY_"^"_CHG AMT_"^"_AL LPAID_"^"_ OHIPRBAL
  2581   "RTN","CH8 35F1",429, 0)
  2582    W !,"LINE  LEVEL BAL ANCE: ",CH GAMT-(ALLP AID+OHIPRB AL)
  2583   "RTN","CH8 35F1",430, 0)
  2584    W !,"CLAI M LEVEL BA LANCING TB D"
  2585   "RTN","CH8 35F1",431, 0)
  2586    Q BALERR
  2587   "RTN","CH8 35F1",432, 0)
  2588    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2589   "RTN","CH8 35F1",433, 0)
  2590    ; HEADER  RECORDS FO R 835 STAG ING FILE
  2591   "RTN","CH8 35F1",434, 0)
  2592    ; DLB 8/2 8/2012  MA DE THIS A  FUNCTION
  2593   "RTN","CH8 35F1",435, 0)
  2594    ; 1) GATH ER THE HDR  RECORD DA TA FROM TH E CP&E PRO CESSING FI LES
  2595   "RTN","CH8 35F1",436, 0)
  2596    ; 2) THE  RECORD GEN ERATION IS  ACCOMPLIS HED USING  THE COMBIN ATION
  2597   "RTN","CH8 35F1",437, 0)
  2598    ;      OF  THE RECOR D TABLE (H DRTBL) AND  THE FUNCT ION THAT P ROCESSES
  2599   "RTN","CH8 35F1",438, 0)
  2600    ;      TH E TABLE (F ORMATDATA^ CHMXWBUT).
  2601   "RTN","CH8 35F1",439, 0)
  2602    ; 3) EACH  ENTRY IN  HDRTBL DES CRIBES ONE  FIELD IN  THE HDR RE CORD.
  2603   "RTN","CH8 35F1",440, 0)
  2604    ;      TH E DATA FOR  THE FIELD  CAN BE A  CONSTANT D ESCRIBED I N THE TABL E,
  2605   "RTN","CH8 35F1",441, 0)
  2606    ;      RE TRIEVED FR OM A VARIA BLE SET UP  PREVIOUSL Y, OR AS T HE RETURN
  2607   "RTN","CH8 35F1",442, 0)
  2608    ;      FR OM A FUNCT ION CALL ( EXECUTED F ROM THE TA BLE).
  2609   "RTN","CH8 35F1",443, 0)
  2610    ; 4) EACH  FIELD IS  CONCATENAT ED TO THE  PREVIOUS F IELD(S) UN TIL THE
  2611   "RTN","CH8 35F1",444, 0)
  2612    ;      CO MPLETE REC ORD HAS BE EN CREATED .
  2613   "RTN","CH8 35F1",445, 0)
  2614    ; 5) THE  COMPLETED  RECORD IS  STORED IN  ^TMP($J,"E DI_CREATE" ,"HDR",0)
  2615   "RTN","CH8 35F1",446, 0)
  2616    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2617   "RTN","CH8 35F1",447, 0)
  2618    ;
  2619   "RTN","CH8 35F1",448, 0)
  2620   HDR(PAYI,N FILE,STSEQ ,VENI)       ; HEADER  SEGMENT F OR 835 STA GING FILE
  2621   "RTN","CH8 35F1",449, 0)
  2622    ; PAYI          CLAI M INDEX FO R THE CURR ENT CLAIM  IN ^CHMPAY
  2623   "RTN","CH8 35F1",450, 0)
  2624    ; NFILE F ILE IDENTI FIER FOR E ACH RECORD
  2625   "RTN","CH8 35F1",451, 0)
  2626    ; STSEQ S EQUENCE CO UNTER FOR  THE RECORD S
  2627   "RTN","CH8 35F1",452, 0)
  2628    ; VENI          VEND OR ID
  2629   "RTN","CH8 35F1",453, 0)
  2630    N PDI,INH DR,GRPCNTR ,HACID,PAY ERID,CLRHS ID,REC
  2631   "RTN","CH8 35F1",454, 0)
  2632    S PAYERID =$$PID^CH8 35FU1(PAYI )                  ;  PAYER ID
  2633   "RTN","CH8 35F1",455, 0)
  2634    S CLRHSID =$$CHID^CH 835FU1(PAY I)         ; CLEARING  HOUSE ID
  2635   "RTN","CH8 35F1",456, 0)
  2636    S PROVID= $$PROVID^C H835FU1(VE NI)        ; PROVIDER  ID (TIN)
  2637   "RTN","CH8 35F1",457, 0)
  2638    S PDI=$$C LMPDI^CH83 5FU1(PAYI)            ; PDI USED  FOR NPI R ETRIEVAL
  2639   "RTN","CH8 35F1",458, 0)
  2640    S PROVNPI =$$PROVNPI ^CH835FU1( PDI)       ; PROVIDER  NPI
  2641   "RTN","CH8 35F1",459, 0)
  2642    S REC=""
  2643   "RTN","CH8 35F1",460, 0)
  2644    F LN=1:1  S STR=$T(H DRTBL+LN)  Q:STR["END  OF RECORD "  D  ; TA BLE GENERA TED RECORD S
  2645   "RTN","CH8 35F1",461, 0)
  2646    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)
  2647   "RTN","CH8 35F1",462, 0)
  2648    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  2649   "RTN","CH8 35F1",463, 0)
  2650    S ^TMP($J ,"EDI_CREA TE","HDR", 0)=REC
  2651   "RTN","CH8 35F1",464, 0)
  2652    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F1: HDR RE CORD: ",RE C
  2653   "RTN","CH8 35F1",465, 0)
  2654    Q
  2655   "RTN","CH8 35F1",466, 0)
  2656    ;
  2657   "RTN","CH8 35F1",467, 0)
  2658    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2659   "RTN","CH8 35F1",468, 0)
  2660    ; BPR REC ORDS FOR T HE 835 STA GING FILE
  2661   "RTN","CH8 35F1",469, 0)
  2662    ; DLB 8/2 8/2012  MA DE THIS A  FUNCTION
  2663   "RTN","CH8 35F1",470, 0)
  2664    ; THIS FU NCTION GAT HERS THE B PR DATA AN D UTILIZES  THE TABLE  DRIVEN
  2665   "RTN","CH8 35F1",471, 0)
  2666    ; RECORD  GENERATION  CAPABILIT Y TO STORE  THE RECOR D.
  2667   "RTN","CH8 35F1",472, 0)
  2668    ; SEE THE  "HDR" REC ORD DESCRI PTION FOR  THE STEPS  USED TO GE NERATE THE  RECORD.
  2669   "RTN","CH8 35F1",473, 0)
  2670    ; 9/17/20 13  DLB  A DDED "NEW"  FOR "I" V ARIABLE
  2671   "RTN","CH8 35F1",474, 0)
  2672    ; 1/17/20 13  DLB  M ODIFIED PA YMENT AMOU NT REPORTE D FROM ^CH MEDI DATA  TO ^CHMPAY  DATA
  2673   "RTN","CH8 35F1",475, 0)
  2674    ; 2/18/20 14  DLB  M ODIFIED TO  OUTPUT "0 " FOR < $1 .00 ADJUDI CATION AMT
  2675   "RTN","CH8 35F1",476, 0)
  2676    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2677   "RTN","CH8 35F1",477, 0)
  2678    ;
  2679   "RTN","CH8 35F1",478, 0)
  2680   BPR(PAYI,N FILE,STSEQ ,VENI,EDII ,EI,DT)
  2681   "RTN","CH8 35F1",479, 0)
  2682    ; PAYI          INDE X TO ^CHMP AY()
  2683   "RTN","CH8 35F1",480, 0)
  2684    ; NFILE F ILE IDENTI FIER FOR E ACH RECORD
  2685   "RTN","CH8 35F1",481, 0)
  2686    ; STSEQ S EQUENCE CO UNTER FOR  THE RECORD S
  2687   "RTN","CH8 35F1",482, 0)
  2688    ; VENI          VEND OR ID
  2689   "RTN","CH8 35F1",483, 0)
  2690    ; EDII          INDE X FROM ^TM P($J,"EDI- 835",CHPID ,^CHMEDI(I ))
  2691   "RTN","CH8 35F1",484, 0)
  2692    ; EI   EN TITY INDEX  TO ^CHMED IPA()
  2693   "RTN","CH8 35F1",485, 0)
  2694    ; DT   TO DAY'S DATE
  2695   "RTN","CH8 35F1",486, 0)
  2696    N PMETHOD ,PYRDFI,PY RACCT,RCVD FI,RCVACCT ,PDATE,CHK EFDT,REC,I ,CHKAMT
  2697   "RTN","CH8 35F1",487, 0)
  2698    S (PMETHO D,PYRDFI,P YRACCT,RCV DFI,RCVACC T,PDATE,CH KEFDT)=""
  2699   "RTN","CH8 35F1",488, 0)
  2700    S PAMT=0, PMETHOD="" ,CHKAMT=0
  2701   "RTN","CH8 35F1",489, 0)
  2702    S:EI'=""  PYRID=$P($ G(^CHMEDIP A(EI,0))," ^",8) ; HA C PAYER ID
  2703   "RTN","CH8 35F1",490, 0)
  2704    S PAMT=$$ BPRPAMT(PA YI)                                             ; DLB  3/11/2014   MODIFIED  TO SUM AMT  PAID TO V ENDOR
  2705   "RTN","CH8 35F1",491, 0)
  2706    S CHKAMT= $S(PAMT<1. 00:0,1:PAM T)                 ;  DLB 3/11/2 014  CANNO T TRUST CH ECK AMOUNT  FROM ^CHM EDI()
  2707   "RTN","CH8 35F1",492, 0)
  2708    S PMETHOD =$$PMETHOD ^CH835FU1( PAYI,CHKAM T) ; PAYME NT METHOD  (CHK/ACH)( CHECKS FOR  REJECTED  STATUS)
  2709   "RTN","CH8 35F1",493, 0)
  2710    I PMETHOD ="ACH" D                                                   ; "ACH " = AUTOMA TED CLEARI NG HOUSE
  2711   "RTN","CH8 35F1",494, 0)
  2712    .S PYRDFI =111036183                                        ; PA YER (HAC)  EFT BANK N UMBER
  2713   "RTN","CH8 35F1",495, 0)
  2714    .S PYRACC T=36001200 0                                      ; PA YER (HAC)  EFT ACCT N UMBER
  2715   "RTN","CH8 35F1",496, 0)
  2716    .S RCVDFI =$$RCVDFI^ CH835FU1(V ENI)               ;  VENDOR EFT  BANK NUMB ER (^CHMVE N(VENI,3)) ,"^",1))
  2717   "RTN","CH8 35F1",497, 0)
  2718    .S RCVACC T=$P($G(^C HMVEN(VENI ,3)),"^",3 ) ; VENDOR  EFT BANK  ACCT CODE
  2719   "RTN","CH8 35F1",498, 0)
  2720    .S:$D(^CH MPAY(PAYI, 1)) CHKEFD T=$$DTOUT^ CH835FU1($ P(^CHMPAY( PAYI,1),"^ ",4)) ; DA TE OF TREA SURY PAYME NT
  2721   "RTN","CH8 35F1",499, 0)
  2722    I PMETHOD ="CHK"  D
  2723   "RTN","CH8 35F1",500, 0)
  2724    .S:$D(^CH MPAY(PAYI, 1)) CHKEFD T=$$DTOUT^ CH835FU1($ P(^CHMPAY( PAYI,1),"^ ",4)) ; DA TE OF TREA SURY PAYME NT
  2725   "RTN","CH8 35F1",501, 0)
  2726    I CHKEFDT ="" D
  2727   "RTN","CH8 35F1",502, 0)
  2728    .S CHKEFD T=$$FMTE^X LFDT(DT,"5 D")                ;  EFT DATE C ANNOT BE N ULL: IF NO  DATE, SET  TODAY'S D ATE
  2729   "RTN","CH8 35F1",503, 0)
  2730    .S CKMONT H=$P(CHKEF DT,"/",1)
  2731   "RTN","CH8 35F1",504, 0)
  2732    .S CKDAY= $P(CHKEFDT ,"/",2)
  2733   "RTN","CH8 35F1",505, 0)
  2734    .F I=1:1: 2-$L(CKMON TH) S CKMO NTH="0"_CK MONTH
  2735   "RTN","CH8 35F1",506, 0)
  2736    .F I=1:1: 2-$L(CKDAY ) S CKDAY= "0"_CKDAY
  2737   "RTN","CH8 35F1",507, 0)
  2738    .S CHKEFD T=$P(CHKEF DT,"/",3)_ CKMONTH_CK DAY
  2739   "RTN","CH8 35F1",508, 0)
  2740    S REC=""
  2741   "RTN","CH8 35F1",509, 0)
  2742    F LN=1:1  S STR=$T(B PRTBL+LN)  Q:STR["END  OF RECORD "  D ; TAB LE GENERAT ED RECORD
  2743   "RTN","CH8 35F1",510, 0)
  2744    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)
  2745   "RTN","CH8 35F1",511, 0)
  2746    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  2747   "RTN","CH8 35F1",512, 0)
  2748    S ^TMP($J ,"EDI_CREA TE","BPR", 0)=REC
  2749   "RTN","CH8 35F1",513, 0)
  2750    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F1: BPR RE CORD: ",RE C
  2751   "RTN","CH8 35F1",514, 0)
  2752    Q
  2753   "RTN","CH8 35F1",515, 0)
  2754    ;
  2755   "RTN","CH8 35F1",516, 0)
  2756    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2757   "RTN","CH8 35F1",517, 0)
  2758    ; IF THE  ADJUDICATE D AMOUNTS  (SUM OF ^C HMEDI() EN TRIES FOR  ^CHMPAY(I, 0), FIELD  14)
  2759   "RTN","CH8 35F1",518, 0)
  2760    ; IS < $1 .00 REPORT  THE AMOUN T AS 0 IN  THE BPR RE CORD
  2761   "RTN","CH8 35F1",519, 0)
  2762    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2763   "RTN","CH8 35F1",520, 0)
  2764    ;
  2765   "RTN","CH8 35F1",521, 0)
  2766   BPRPAMT(PA YI)
  2767   "RTN","CH8 35F1",522, 0)
  2768    N CALC,PA MT,CHKEFT, IDX,JDX
  2769   "RTN","CH8 35F1",523, 0)
  2770    S CALCPMT =$$CALCPMT (PAYI)                                 ; HA NDLE "GROU PING" OF C LAIMS IF N ECESSARY
  2771   "RTN","CH8 35F1",524, 0)
  2772    S PAMT=$P (CALCPMT," ^",2)                                  ; CA LCPMT() SU MS AMOUNT  TO BE PAID (FIELD 1)_ "^"_SUM OF  VENDOR PA YMENT (FIE LD 14)
  2773   "RTN","CH8 35F1",525, 0)
  2774    S:PAMT<1. 00 PAMT=0                                         ; IF  TOTAL ADJ UDICATED V ENDOR PAYM ENT AMOUNT  < $1.00 R EPORT 0 IN  BPR RECOR D
  2775   "RTN","CH8 35F1",526, 0)
  2776    Q PAMT
  2777   "RTN","CH8 35F1",527, 0)
  2778    ;
  2779   "RTN","CH8 35F1",528, 0)
  2780    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2781   "RTN","CH8 35F1",529, 0)
  2782    ; THIS CO DE PERFORM S A SANITY  CHECK FOR  THE PAYME NT AMOUNT  FOR GROUPE D
  2783   "RTN","CH8 35F1",530, 0)
  2784    ; CLAIMS  AGAINST TH E ^CHMSNA( 741008.17  FILE
  2785   "RTN","CH8 35F1",531, 0)
  2786    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2787   "RTN","CH8 35F1",532, 0)
  2788    ;
  2789   "RTN","CH8 35F1",533, 0)
  2790    ;I PAMT>0 .99  D
  2791   "RTN","CH8 35F1",534, 0)
  2792    ;.I $$PME THOD(CI,PA MT)="CHK"  D                           ; DE TERMINE PM ETHOD FROM  REJECT ST ATUS AND P AYMENT AMO UNT
  2793   "RTN","CH8 35F1",535, 0)
  2794    ;..S CHKE FT=$P(^CHM PAY(PAYI,1 ),"^",16)          ;  RETRIEVE V ENDOR CHEC K NUMBER F OR NON "0"  PAY CLAIM S
  2795   "RTN","CH8 35F1",536, 0)
  2796    ;..S (IDX ,JDX)=0,ID X=$O(^CHMS NA(741008. 17,"C",CKN UM,IDX)),J DX=$O(^CHM SNA(741008 .17,"C",CK NUM,IDX,JD X))
  2797   "RTN","CH8 35F1",537, 0)
  2798    ;..I ($P( ^CHMSNA(74 1008.17,ID X,1,JDX,0) ,"^",1)'=C HKEFT)!($P (^CHMSNA(7 41008.17,I DX,1,JDX,0 ),"^",4)'= PAMT)  D
  2799   "RTN","CH8 35F1",538, 0)
  2800    ;...U 0 W  !,"PAYMEN T AMOUNT ' = CHECK AM OUNT."
  2801   "RTN","CH8 35F1",539, 0)
  2802    ;Q
  2803   "RTN","CH8 35F1",540, 0)
  2804    ;
  2805   "RTN","CH8 35F1",541, 0)
  2806    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2807   "RTN","CH8 35F1",542, 0)
  2808    ; TRN REC ORD GENERA TION
  2809   "RTN","CH8 35F1",543, 0)
  2810    ; DLB 8/2 8/2012  MA DE THIS A  FUNCTION
  2811   "RTN","CH8 35F1",544, 0)
  2812    ; THIS FU NCTION GAT HERS THE T RN DATA AN D UTILIZES  THE TABLE  DRIVEN
  2813   "RTN","CH8 35F1",545, 0)
  2814    ; RECORD  GENERATION  CAPABILIT Y TO STORE  THE RECOR D.
  2815   "RTN","CH8 35F1",546, 0)
  2816    ; THGE OR IGINAL COD E TO GENER ATE THE TR N RECORD:
  2817   "RTN","CH8 35F1",547, 0)
  2818    ; S ^TMP( $J,"EDI_CR EATE","TRN ",0)="TRN" _"^"_NFILE _"^"_STSEQ _"^"_FMSID _"^"_PYRID _"^"_TRSPY MNT
  2819   "RTN","CH8 35F1",548, 0)
  2820    ; DEVELOP ER'S NOTE:  IN CH835D RV.INT THE RE IS A CH ECK TO DET ERMINE
  2821   "RTN","CH8 35F1",549, 0)
  2822    ; IF THE  REQUIRED C HECK NUMBE R HAS BEEN  RECEIVED.  IF NOT, T HE CLAIM
  2823   "RTN","CH8 35F1",550, 0)
  2824    ; IS NOT  "QUE'D" FO R 835 GENE RATION. TH E FACT THA T WE ARE P ROCESSING
  2825   "RTN","CH8 35F1",551, 0)
  2826    ; THE CLA IM AT THIS  POINT MEA NS THAT TH E REQUIRED  INFORMATI ON HAS
  2827   "RTN","CH8 35F1",552, 0)
  2828    ; BEEN VE RIFIED.
  2829   "RTN","CH8 35F1",553, 0)
  2830    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2831   "RTN","CH8 35F1",554, 0)
  2832    ;
  2833   "RTN","CH8 35F1",555, 0)
  2834   TRN(PAYI,N FILE,STSEQ ,FMSID,EI)
  2835   "RTN","CH8 35F1",556, 0)
  2836    ; PAYI          INDE X TO ^CHMP AY CLAIM R ECORD
  2837   "RTN","CH8 35F1",557, 0)
  2838    ; NFILE F ILE IDENTI FIER FOR E ACH RECORD
  2839   "RTN","CH8 35F1",558, 0)
  2840    ; STSEQ S EQUENCE CO UNTER FOR  THE RECORD S
  2841   "RTN","CH8 35F1",559, 0)
  2842    ; FMSID F MS ID FROM  $P(^CHMED I(FMSI,0), "^",1) SEE  FMSLOOP()
  2843   "RTN","CH8 35F1",560, 0)
  2844    ; EI   EN TITY INDEX  TO ^CHMED IPA()
  2845   "RTN","CH8 35F1",561, 0)
  2846    N TRSPYMN T,PYRID,RE C,CHKEFT,R ESULT,APMT ,VPMT
  2847   "RTN","CH8 35F1",562, 0)
  2848    S CHKEFT= FMSID                                                                                         ; IN IT THE CHK /EFT NUMBE R VARIABLE  TO FMS DO C ID AS DE FAULT
  2849   "RTN","CH8 35F1",563, 0)
  2850    S RESULT= $$CALCPMT( PAYI)                                                             ; HANDLE " GROUPING"  OF CLAIMS  IF NECESSA RY
  2851   "RTN","CH8 35F1",564, 0)
  2852    S APMT=$P (RESULT,"^ ",1),VPMT= $P(RESULT, "^",2)           ; SE T AMOUNT O F PAYMENT  AND AMOUNT  PAID TO V ENDOR VARI ABLES
  2853   "RTN","CH8 35F1",565, 0)
  2854    I (APMT>0 .99)&(VPMT >0.99)  D                                                ; AMT TO  BE PAID A ND AMT PAI D TO VENDO R BOTH > 0 .99
  2855   "RTN","CH8 35F1",566, 0)
  2856    .S CHKEFT =$P(^CHMPA Y(PAYI,1), "^",16)                              ; RETR IEVE VENDO R CHECK NU MBER FOR N ON "0" PAY  CLAIMS
  2857   "RTN","CH8 35F1",567, 0)
  2858    S:EI]"" P YRID=$P($G (^CHMEDIPA (EI,0)),"^ ",8)             ; HA C PAYER ID
  2859   "RTN","CH8 35F1",568, 0)
  2860    S:$D(^CHM PAY(PAYI,1 )) TRSPYMN T=$$DTOUT^ CH835FU1($ P(^CHMPAY( PAYI,1),"^ ",4))              ;  DATE OF TR EASURY PAY MENT
  2861   "RTN","CH8 35F1",569, 0)
  2862    S REC=""
  2863   "RTN","CH8 35F1",570, 0)
  2864    F LN=1:1  S STR=$T(T RNTBL+LN)  Q:STR["END  OF RECORD "  D           ; TABL E GENERATE D RECORDS
  2865   "RTN","CH8 35F1",571, 0)
  2866    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)
  2867   "RTN","CH8 35F1",572, 0)
  2868    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  2869   "RTN","CH8 35F1",573, 0)
  2870    S ^TMP($J ,"EDI_CREA TE","TRN", 0)=REC
  2871   "RTN","CH8 35F1",574, 0)
  2872    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F1: TRN RE CORD: ",RE C
  2873   "RTN","CH8 35F1",575, 0)
  2874    Q
  2875   "RTN","CH8 35F1",576, 0)
  2876    ;
  2877   "RTN","CH8 35F1",577, 0)
  2878    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2879   "RTN","CH8 35F1",578, 0)
  2880    ; CALCPMT () FUNCTIO N SUMS THE  "GROUPED"  CLAIMS IN  ^CHMEDI()  TO
  2881   "RTN","CH8 35F1",579, 0)
  2882    ; DETERMI NE THE PAY MENT AMOUN T FOR THE  GROUP.
  2883   "RTN","CH8 35F1",580, 0)
  2884    ; THE ^CH MEDI("C",P AYI,CHMEDI (I)) CROSS REFERENCE  IS USED TO
  2885   "RTN","CH8 35F1",581, 0)
  2886    ; DETERMI NE THE ^CH MEDI INDEX , THEN THE  POINTER T O ^CHMPAY( )
  2887   "RTN","CH8 35F1",582, 0)
  2888    ; FOR EAC H ENTRY IN  ^CHMEDI I S USED TO  GATHER PAY MENT INFO
  2889   "RTN","CH8 35F1",583, 0)
  2890    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2891   "RTN","CH8 35F1",584, 0)
  2892    ;
  2893   "RTN","CH8 35F1",585, 0)
  2894   CALCPMT(PA YI)
  2895   "RTN","CH8 35F1",586, 0)
  2896    ;  PAYI         THE  CURRENT PO INTER TO T HE ^CHMPAY () ENTRY
  2897   "RTN","CH8 35F1",587, 0)
  2898    N EDII,ED IJ,PMT,VPM T,CPAYI
  2899   "RTN","CH8 35F1",588, 0)
  2900    S EDII=0, EDII=$O(^C HMEDI("C", PAYI,EDII) )     ; XR EF TO RETR IEVE ^CHME DI(I)
  2901   "RTN","CH8 35F1",589, 0)
  2902    S EDIJ=0, PMT=0,VPMT =0
  2903   "RTN","CH8 35F1",590, 0)
  2904    I EDII=""  Q PMT_"^" _VPMT                                                     ; EXIT  OF NOT AVA ILABLE
  2905   "RTN","CH8 35F1",591, 0)
  2906    F  S EDIJ =$O(^CHMED I(EDII,1,E DIJ))  Q:+ (EDIJ)=0   D  ; LOOP  THROUGH TH E ^CHMEDI( J) INDICES
  2907   "RTN","CH8 35F1",592, 0)
  2908    .S CPAYI= $P(^CHMEDI (EDII,1,ED IJ,0),"^", 1)                ; G ET THE CUR RENT ^CHMP AY POINTER
  2909   "RTN","CH8 35F1",593, 0)
  2910    .Q:('$D(^ CHMPAY(CPA YI,1)))                                                   ; EXIT  IF NO ^CHM PAY() PAY  NODE (I,1)
  2911   "RTN","CH8 35F1",594, 0)
  2912    .S PMT=PM T+$P(^CHMP AY(CPAYI,1 ),"^",1)                     ; S UM THE AMO UNTS TO BE  PAID
  2913   "RTN","CH8 35F1",595, 0)
  2914    .S VPMT=V PMT+$P(^CH MPAY(CPAYI ,1),"^",14 )                 ; S UM THE AMO UNTS TO BE  PAID TO V ENDOR
  2915   "RTN","CH8 35F1",596, 0)
  2916    Q PMT_"^" _VPMT
  2917   "RTN","CH8 35F1",597, 0)
  2918    ;
  2919   "RTN","CH8 35F1",598, 0)
  2920    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2921   "RTN","CH8 35F1",599, 0)
  2922    ; PLB REC ORD GENERA TION
  2923   "RTN","CH8 35F1",600, 0)
  2924    ; NOTE: T HIS FUNCTI ON USES TH E ^TMP($J, "EDI_CREAT E","CLP",I VAL)
  2925   "RTN","CH8 35F1",601, 0)
  2926    ; DLB 8/2 8/2012  MA DE THIS A  FUNCTION
  2927   "RTN","CH8 35F1",602, 0)
  2928    ; THIS FU NCTION GAT HERS THE P LB DATA AN D UTILIZES  THE TABLE  DRIVEN
  2929   "RTN","CH8 35F1",603, 0)
  2930    ; RECORD  GENERATION  CAPABILIT Y TO STORE  THE RECOR D INTO ^TM P($J,"EDI_ CREATE","P LB",0)
  2931   "RTN","CH8 35F1",604, 0)
  2932    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2933   "RTN","CH8 35F1",605, 0)
  2934    ;
  2935   "RTN","CH8 35F1",606, 0)
  2936   PLB(NFILE, STSEQ,VENI ,EDII,DT,P AYI,PAMT)
  2937   "RTN","CH8 35F1",607, 0)
  2938    ; NFILE F ILE IDENTI FIER FOR E ACH RECORD
  2939   "RTN","CH8 35F1",608, 0)
  2940    ; STSEQ S EQUENCE CO UNTER FOR  THE RECORD S
  2941   "RTN","CH8 35F1",609, 0)
  2942    ; VENI          VEND OR ID
  2943   "RTN","CH8 35F1",610, 0)
  2944    ; EDII          "I"  INDEX FOR  ^CHMEDI()
  2945   "RTN","CH8 35F1",611, 0)
  2946    ; DT   TO DAY'S DATE
  2947   "RTN","CH8 35F1",612, 0)
  2948    ; PAYI          CURR ENT ^CHMPA Y(I) INDEX
  2949   "RTN","CH8 35F1",613, 0)
  2950    ; PAMT          TOTA L OF THE C LP PROVIDE R PAYMENT  FIELDS
  2951   "RTN","CH8 35F1",614, 0)
  2952    N PLBPTID ,PLBENDFY, PLBADJCD,P LBADAMT,PL BRSNCD,BPR 02,PLBTOT, IVAL,REC
  2953   "RTN","CH8 35F1",615, 0)
  2954    N PYMNTAM T,TOTALLOW ,FMSID,REJ I,REJCODE, REJAMT,REJ TYPE
  2955   "RTN","CH8 35F1",616, 0)
  2956    S (BILLAM T,VNDRPMT, CLMADJ,SVC ADJ,PLBTOT ,REJI,REJC ODE,REJAMT )=0          ; INIT T HE PLB TOT AL VARIABL ES
  2957   "RTN","CH8 35F1",617, 0)
  2958    S (PLBPTI D,PLBENDFY ,PLBADJCD, PLBADAMT,P LBRSNCD,RE JTYPE)=""
  2959   "RTN","CH8 35F1",618, 0)
  2960    S PLBPTID =$P($G(^CH MVEN(VENI, 0)),"^",3)  ; PROVIDE R TAX ID N UMBER (TIN )
  2961   "RTN","CH8 35F1",619, 0)
  2962    S PRENDFY =$$FMTE^XL FDT(DT,"5D ")                 ;F ISCAL YEAR : DEC 31 O F CURRENT  YEAR
  2963   "RTN","CH8 35F1",620, 0)
  2964    S PLBENDF Y=$P(PREND FY,"/",3)_ "1231"
  2965   "RTN","CH8 35F1",621, 0)
  2966    S CHKNUM= $P(^CHMEDI (EDII,0)," ^",3)              ;  CHECK NUMB ER
  2967   "RTN","CH8 35F1",622, 0)
  2968    S FMSID=$ P(^CHMEDI( EDII,0),"^ ",1)       ;RECONCILI ATION NUMB ER
  2969   "RTN","CH8 35F1",623, 0)
  2970    S (CLP04T OT,PLBTOT, BPR02)=0                      ;I F CLAIM IS  UNDER 1.0 0 = PAID A MT ELSE 0
  2971   "RTN","CH8 35F1",624, 0)
  2972    S REJI=$S ($P(^CHMPA Y(PAYI,0), "^",2)=0:$ P(^CHMPAY( PAYI,0),"^ ",13),1:"" )
  2973   "RTN","CH8 35F1",625, 0)
  2974    S:REJI RE JTYPE=$$RE JTYPE^CH83 5FU1(REJI)  ; INFORMA TIONAL OR  REJECT TYP E
  2975   "RTN","CH8 35F1",626, 0)
  2976    S:REJTYPE =0 REJCODE =$$REJCD^C H835FU1(RE JI) ; $P($ G(^CHMDIC( 741002.22, I,0)),"^", 1)      PR OBLEM STAT US CODE
  2977   "RTN","CH8 35F1",627, 0)
  2978    I REJCODE  S PLBTOT= 0                                      ; RE JECTED, RE JECT TOTAL  BILLED AM T
  2979   "RTN","CH8 35F1",628, 0)
  2980    ;E  S PLB TOT=$S(PAM T'>0:0,PAM T<1.00:PAM T,PAMT>1.0 0:0,1:0) ;  IF LESS T HAN $1, PL B VLUE = B ILLED AMT
  2981   "RTN","CH8 35F1",629, 0)
  2982    ;U 0 W !, "F1***PLB: PLB VAL: " ,PLBTOT,"  REJCODE: " ,REJCODE,"   VNDR PAI D: ",PAMT
  2983   "RTN","CH8 35F1",630, 0)
  2984    S REC=""
  2985   "RTN","CH8 35F1",631, 0)
  2986    F LN=1:1  S STR=$T(P LBTBL+LN)  Q:STR["END  OF RECORD "  D ; TAB LE GENERAT ED RECORDS
  2987   "RTN","CH8 35F1",632, 0)
  2988    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)
  2989   "RTN","CH8 35F1",633, 0)
  2990    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  2991   "RTN","CH8 35F1",634, 0)
  2992    S ^TMP($J ,"EDI_CREA TE","PLB", 0)=REC
  2993   "RTN","CH8 35F1",635, 0)
  2994    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F1: PLB RE CORD: ",RE C
  2995   "RTN","CH8 35F1",636, 0)
  2996    Q
  2997   "RTN","CH8 35F1",637, 0)
  2998    ;
  2999   "RTN","CH8 35F1",638, 0)
  3000    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  3001   "RTN","CH8 35F1",639, 0)
  3002    ; THE FOL LOWING ROU TINES OUTP UT THE REC ORDS THAT  WERE CREAT ED DURING  THE 835 PR OCESS.
  3003   "RTN","CH8 35F1",640, 0)
  3004    ; THIS RO UTINE IS B YPASSED IF  THERE ARE  BALANCE C HECK ERROR S REPORTED  IN THE CH 835BAL.INT
  3005   "RTN","CH8 35F1",641, 0)
  3006    ; ROUTINE . THIS COD E WAS EXIS TING CODE,  SO IT IS  NOT THE EA SIEST TO F OLLOW. BAS ICALLY,
  3007   "RTN","CH8 35F1",642, 0)
  3008    ; THE REC ORD GENERA TION PROCE SS POPULAT ES THE ARR AYS AS REQ UIRED, AND  THIS ROUT INE OUTPUT S
  3009   "RTN","CH8 35F1",643, 0)
  3010    ; THE DAT A CONTAINE D IN THE ^ TMP($J,"ED I-CREATE"  ARRAY.
  3011   "RTN","CH8 35F1",644, 0)
  3012    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  3013   "RTN","CH8 35F1",645, 0)
  3014    ;
  3015   "RTN","CH8 35F1",646, 0)
  3016   WRT ;Write s lines to  file
  3017   "RTN","CH8 35F1",647, 0)
  3018    I $D(^TMP ($J,"EDI_C REATE","HD R",0)) D
  3019   "RTN","CH8 35F1",648, 0)
  3020    .U FIO W  ^TMP($J,"E DI_CREATE" ,"HDR",0), ! Q              ; WR ITE HDR RE CORD
  3021   "RTN","CH8 35F1",649, 0)
  3022    I $D(^TMP ($J,"EDI_C REATE","BP R",0)) D
  3023   "RTN","CH8 35F1",650, 0)
  3024    .U FIO W  ^TMP($J,"E DI_CREATE" ,"BPR",0), ! Q              ; WR ITE THE BP R RECORD F ROM ^TMP a RRAY
  3025   "RTN","CH8 35F1",651, 0)
  3026    I $D(^TMP ($J,"EDI_C REATE","TR N",0)) D
  3027   "RTN","CH8 35F1",652, 0)
  3028    .U FIO W  ^TMP($J,"E DI_CREATE" ,"TRN",0), ! Q              ; WR ITE THE TR N RECORD
  3029   "RTN","CH8 35F1",653, 0)
  3030    I $D(^TMP ($J,"EDI_C REATE","CL P")) D
  3031   "RTN","CH8 35F1",654, 0)
  3032    .S TI=0
  3033   "RTN","CH8 35F1",655, 0)
  3034    .F  S TI= $O(^TMP($J ,"EDI_CREA TE","CLP", TI)) Q:'TI   D
  3035   "RTN","CH8 35F1",656, 0)
  3036    ..U FIO W  ^TMP($J," EDI_CREATE ","CLP",TI ),!              ; WR ITE MULTIP LE CLP REC ORDS
  3037   "RTN","CH8 35F1",657, 0)
  3038    ..I $D(^T MP($J,"EDI _CREATE"," CLPNAME",T I)) D
  3039   "RTN","CH8 35F1",658, 0)
  3040    ...U FIO  W ^TMP($J, "EDI_CREAT E","CLPNAM E",TI),!
  3041   "RTN","CH8 35F1",659, 0)
  3042    ..I $D(^T MP($J,"EDI _CREATE"," CLPCAS",TI )) D
  3043   "RTN","CH8 35F1",660, 0)
  3044    ...S CLPC TI=0 F  S  CLPCTI=$O( ^TMP($J,"E DI_CREATE" ,"CLPCAS", TI,CLPCTI) ) Q:'CLPCT I  D
  3045   "RTN","CH8 35F1",661, 0)
  3046    ....U FIO  W ^TMP($J ,"EDI_CREA TE","CLPCA S",TI,CLPC TI),!          ; WRIT E MULTIPLE  CLPCAS RE CORDS
  3047   "RTN","CH8 35F1",662, 0)
  3048    ....Q
  3049   "RTN","CH8 35F1",663, 0)
  3050    ..D SVCPT (TI)                                                                                 ;  CALL TO WR ITE SVC RE CORDS
  3051   "RTN","CH8 35F1",664, 0)
  3052    ...Q
  3053   "RTN","CH8 35F1",665, 0)
  3054    ..Q
  3055   "RTN","CH8 35F1",666, 0)
  3056    .Q
  3057   "RTN","CH8 35F1",667, 0)
  3058    I $D(^TMP ($J,"EDI_C REATE","PL B",0)) D
  3059   "RTN","CH8 35F1",668, 0)
  3060    .U FIO W  ^TMP($J,"E DI_CREATE" ,"PLB",0), !                         ; WRIT E THE PLB  RECORDS
  3061   "RTN","CH8 35F1",669, 0)
  3062    .Q
  3063   "RTN","CH8 35F1",670, 0)
  3064    Q
  3065   "RTN","CH8 35F1",671, 0)
  3066    ;
  3067   "RTN","CH8 35F1",672, 0)
  3068    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3069   "RTN","CH8 35F1",673, 0)
  3070    ;PRINT SE RVICE LINE , SERVICE  LINE CAS A ND SERVICE  LINE LQ
  3071   "RTN","CH8 35F1",674, 0)
  3072    ;HR-PBM-P HASE 1B
  3073   "RTN","CH8 35F1",675, 0)
  3074    ; 5591 ch anges for  2 possible  LQ segmen ts - MBJ f or H-R, 12 /24/08
  3075   "RTN","CH8 35F1",676, 0)
  3076    ; ..I $D( ^TMP($J,"E DI_CREATE" ,"SVCLQ",T I,TII)) D      ; old  version
  3077   "RTN","CH8 35F1",677, 0)
  3078    ; ...U FI O W ^TMP($ J,"EDI_CRE ATE","SVCL Q",TI,TII) ,!  ; old  version
  3079   "RTN","CH8 35F1",678, 0)
  3080    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  3081   "RTN","CH8 35F1",679, 0)
  3082   SVCPT(TI)
  3083   "RTN","CH8 35F1",680, 0)
  3084    I $D(^TMP ($J,"EDI_C REATE","SV C",TI)) D
  3085   "RTN","CH8 35F1",681, 0)
  3086    .S TII=0
  3087   "RTN","CH8 35F1",682, 0)
  3088    .F  S TII =$O(^TMP($ J,"EDI_CRE ATE","SVC" ,TI,TII))  Q:'TII  D
  3089   "RTN","CH8 35F1",683, 0)
  3090    ..U FIO W  ^TMP($J," EDI_CREATE ","SVC",TI ,TII),!                   ; WRIT E MULTIPLE  SVC RECOR D
  3091   "RTN","CH8 35F1",684, 0)
  3092    ..I $D(^T MP($J,"EDI _CREATE"," SVCCAS",TI ,TII)) D
  3093   "RTN","CH8 35F1",685, 0)
  3094    ...S TIII =0
  3095   "RTN","CH8 35F1",686, 0)
  3096    ...F  S T III=$O(^TM P($J,"EDI_ CREATE","S VCCAS",TI, TII,TIII))  Q:'TIII   D
  3097   "RTN","CH8 35F1",687, 0)
  3098    ....U FIO  W ^TMP($J ,"EDI_CREA TE","SVCCA S",TI,TII, TIII),! ;  WRITE MULT IPLE SVCCA S RECORDS
  3099   "RTN","CH8 35F1",688, 0)
  3100    ....;U 0  W !,"WROTE  ^TMP(",$J ,",""EDI_C REATE"","" SVCCAS""," ,TI,",",TI I,",",TIII ,")"
  3101   "RTN","CH8 35F1",689, 0)
  3102    ....Q
  3103   "RTN","CH8 35F1",690, 0)
  3104    ..;HR-PBM -PHASE 1B- Begin 5591  new versi on for 2 L Qs
  3105   "RTN","CH8 35F1",691, 0)
  3106    ..I $D(^T MP($J,"EDI _CREATE"," SVCLQ1",TI ,TII)) D         ; CH ANGED FROM  SVCLQ TO  SVCLQ1           
  3107   "RTN","CH8 35F1",692, 0)
  3108    ...U FIO  W ^TMP($J, "EDI_CREAT E","SVCLQ1 ",TI,TII), !   ; WRIT E THE SVCL Q1 RECORD
  3109   "RTN","CH8 35F1",693, 0)
  3110    ..I $D(^T MP($J,"EDI _CREATE"," SVCLQ2",TI ,TII)) D         ; ad ded SVCLQ2  for 2ND L Q segment
  3111   "RTN","CH8 35F1",694, 0)
  3112    ...U FIO  W ^TMP($J, "EDI_CREAT E","SVCLQ2 ",TI,TII), !     ; WR ITE THE SV CLQ2 RECOR DS
  3113   "RTN","CH8 35F1",695, 0)
  3114    ..; end 5 591 modifi cations
  3115   "RTN","CH8 35F1",696, 0)
  3116    ..;HR-PBM -PHASE 1B- End
  3117   "RTN","CH8 35F1",697, 0)
  3118    ..Q
  3119   "RTN","CH8 35F1",698, 0)
  3120    .Q
  3121   "RTN","CH8 35F1",699, 0)
  3122    Q
  3123   "RTN","CH8 35F1",700, 0)
  3124    ;
  3125   "RTN","CH8 35F1",701, 0)
  3126    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3127   "RTN","CH8 35F1",702, 0)
  3128    ; UPDSTAT US UPDATES , ON A REC ORD BY REC ORD BASIS,  THE ^CHME DI STATUS  FOR RECORD S
  3129   "RTN","CH8 35F1",703, 0)
  3130    ; THE FUN CTION IS P ASSED THE  ^CHMEDI(I)  INDEX TO  IDENTIFY T HE RECORD  SENT.
  3131   "RTN","CH8 35F1",704, 0)
  3132    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3133   "RTN","CH8 35F1",705, 0)
  3134    ;
  3135   "RTN","CH8 35F1",706, 0)
  3136   UPDSTATUS( EI)
  3137   "RTN","CH8 35F1",707, 0)
  3138    ; I  ENTI TY INDEX T O ^CHMEDI  FOR THE RE CORD GENER ATED
  3139   "RTN","CH8 35F1",708, 0)
  3140    S $P(^CHM EDI(EI,0), "^",2)=1              ; SET THE  STATUS TO  "835 RECOR D SENT"
  3141   "RTN","CH8 35F1",709, 0)
  3142    S ^CHMEDI ("D",1,EI) =""                           ;  SET THE "D " CROSS RE FERENCE FO R "835 REC ORD SENT"
  3143   "RTN","CH8 35F1",710, 0)
  3144    K ^CHMEDI ("D",0,EI)                       ; KILL THE  "D" CROSS  REFERENCE  FOR "NEED S SENT"
  3145   "RTN","CH8 35F1",711, 0)
  3146    Q
  3147   "RTN","CH8 35F1",712, 0)
  3148    ;
  3149   "RTN","CH8 35F1",713, 0)
  3150    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3151   "RTN","CH8 35F1",714, 0)
  3152    ; SETASID E(EI)  CHA NGES THE " NEED SENT"  STATUS TO  A "SET AS IDE" STATU S, AND KIL LS
  3153   "RTN","CH8 35F1",715, 0)
  3154    ; THE APP ROPRIATE C ROSS-REFER ENCES.
  3155   "RTN","CH8 35F1",716, 0)
  3156    ; THIS FU NCTION PER FORMS THE  REMOVAL OF  THE "NEED S SENT" ST ATUS FOR A NY CLAIM,  BUT
  3157   "RTN","CH8 35F1",717, 0)
  3158    ; IS INTE NDED TO DO  THIS WHEN  A CLAIM F ALLS OUTSI DE OF THE  ACTIVE QUE UEING WIND OW
  3159   "RTN","CH8 35F1",718, 0)
  3160    ; OF THE  CURRENT DA TE - 180 D AYS.
  3161   "RTN","CH8 35F1",719, 0)
  3162    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3163   "RTN","CH8 35F1",720, 0)
  3164    ;
  3165   "RTN","CH8 35F1",721, 0)
  3166   SETASIDE(E I)
  3167   "RTN","CH8 35F1",722, 0)
  3168    ; I  ENTI TY INDEX T O ^CHMEDI  FOR THE RE CORD TO BE  SET ASIDE
  3169   "RTN","CH8 35F1",723, 0)
  3170    I $$ENVIR ^CHTFLIB'= "LIVE" U 0  W !,"SETT ING ASIDE  ^CHMEDI(", EI,")"
  3171   "RTN","CH8 35F1",724, 0)
  3172    S $P(^CHM EDI(EI,0), "^",2)=180            ; SET THE  STATUS TO  "835 RECOR D SET ASID E"
  3173   "RTN","CH8 35F1",725, 0)
  3174    S ^CHMEDI ("D",180,E I)=""                 ; SET THE  "D" CROSS  REFERENCE  FOR "CLAIM  SET ASIDE "
  3175   "RTN","CH8 35F1",726, 0)
  3176    K ^CHMEDI ("D",0,EI)                       ; KILL THE  "D" CROSS  REFERENCE  FOR "NEED S SENT"
  3177   "RTN","CH8 35F1",727, 0)
  3178    Q
  3179   "RTN","CH8 35F1",728, 0)
  3180    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3181   "RTN","CH8 35F1",729, 0)
  3182    ; REFACTO RED THE RE CORD GENER ATION IN O RDER TO SI MPLIFY REC ORD GENERA TION PROCE SS
  3183   "RTN","CH8 35F1",730, 0)
  3184    ; THE FOL LOWING TAB LES PROVID E THE INFO RMATION TO  FORMAT TH E FIELD, T HE SEQUENC E
  3185   "RTN","CH8 35F1",731, 0)
  3186    ; OF THE  FIELDS, AN D THE LOCA TION OF TH E DATA TO  BE PLACED  IN THE FIE LD.
  3187   "RTN","CH8 35F1",732, 0)
  3188    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3189   "RTN","CH8 35F1",733, 0)
  3190    ; S INHDR ="00000001 "
  3191   "RTN","CH8 35F1",734, 0)
  3192    ; S GRPCT NR="1"
  3193   "RTN","CH8 35F1",735, 0)
  3194    ; S HACID ="0"                                              ; FA CILITY ID  (HAC = "0" )
  3195   "RTN","CH8 35F1",736, 0)
  3196    ; S PAYER ID=$$PID^C H835FU1(CI )                  ;  PAYER ID
  3197   "RTN","CH8 35F1",737, 0)
  3198    ; S CLRHS ID=$$CHID^ CH835FU1(C I)         ; CLEARING  HOUSE ID
  3199   "RTN","CH8 35F1",738, 0)
  3200    ; S PROVI D=$$PROVID ^CH835FU1( VENI)      ; PROVIDER  ID (TIN)
  3201   "RTN","CH8 35F1",739, 0)
  3202    ; S PDI=$ $CLMPDI^CH 835FU1(CI)            ; PDI USED  FOR NPI R ETRIEVAL
  3203   "RTN","CH8 35F1",740, 0)
  3204    ; S PROVN PI=$$PROVN PI^CH835FU 1(PDI) ; P ROVIDER NP I
  3205   "RTN","CH8 35F1",741, 0)
  3206    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3207   "RTN","CH8 35F1",742, 0)
  3208    ; HDR REC ORD GENERA TION THE F OLLOWING L INE IS REP LACED WITH  THE $TEXT  TABLE
  3209   "RTN","CH8 35F1",743, 0)
  3210    ; CURRENT  RECORD CR EATION FOR  THE "HDR"  RECORD: 1 0/11/12  D LB
  3211   "RTN","CH8 35F1",744, 0)
  3212    ;S ^TMP($ J,"EDI_CRE ATE","HDR" ,0)=NFILE_ "^"_STSEQ_ "^"_INHDR_ "^"_GRPCTN R_"^"_HACI D_"^"_PAYE RID_"^"_PR OVID_"^"_C LRHSID_"^" _"P"_"^"_" NEW^^"_PRO VNPI
  3213   "RTN","CH8 35F1",745, 0)
  3214    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3215   "RTN","CH8 35F1",746, 0)
  3216    ;
  3217   "RTN","CH8 35F1",747, 0)
  3218   HDRTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  3219   "RTN","CH8 35F1",748, 0)
  3220    ;;1.HEADE R ID;"HDR" ;36;L;;36A N;R;
  3221   "RTN","CH8 35F1",749, 0)
  3222    ;;2.NEW_F ILE_AUTH_N BR;NFILE;3 6;L;;20AN; R;
  3223   "RTN","CH8 35F1",750, 0)
  3224    ;;3.NEW_S T02TXN_CTL _NBR;STSEQ ;9;L;;5N;R ;
  3225   "RTN","CH8 35F1",751, 0)
  3226    ;;4.INHDR ;"00000001 ";15;L;;10 N;R;
  3227   "RTN","CH8 35F1",752, 0)
  3228    ;;5.GRPCT NR;"1";5;L ;;5N;R;
  3229   "RTN","CH8 35F1",753, 0)
  3230    ;;6.FACIL ITY ID;"0" ;1;L;;1A;R ;
  3231   "RTN","CH8 35F1",754, 0)
  3232    ;;7.PAYER  ID;$$PID^ CH835FU1(P AYI);15;L; ;15AN;R;
  3233   "RTN","CH8 35F1",755, 0)
  3234    ;;8.PROVI DER ID;$$P ROVID^CH83 5FU1(VENI) ;15;L;;15A N;R;
  3235   "RTN","CH8 35F1",756, 0)
  3236    ;;9.CLEAR INGHOUSE I D;$$CHID^C H835FU1(PA YI);15;L;; 15AN;R;
  3237   "RTN","CH8 35F1",757, 0)
  3238    ;;10.USAG E INDICATO R;"P";1;L; ;1A;R;
  3239   "RTN","CH8 35F1",758, 0)
  3240    ;;11.CONS TANT;"NEW" ;15;L;;15A N;R;
  3241   "RTN","CH8 35F1",759, 0)
  3242    ;;12.CONS TANT;"";1; L;;1A;R;
  3243   "RTN","CH8 35F1",760, 0)
  3244    ;;13.PROV IDER NPI;$ $PROVNPI^C H835FU1(PD I);20;L;;2 0AN;R;
  3245   "RTN","CH8 35F1",761, 0)
  3246    ;;END OF  RECORD
  3247   "RTN","CH8 35F1",762, 0)
  3248    ;
  3249   "RTN","CH8 35F1",763, 0)
  3250    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3251   "RTN","CH8 35F1",764, 0)
  3252    ; BPR REC ORD GENERA TION THE F OLLOWING L INE IS REP LACED WITH  THE $TEXT  TABLE
  3253   "RTN","CH8 35F1",765, 0)
  3254    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3255   "RTN","CH8 35F1",766, 0)
  3256    ; CURRENT  CREATION  FOR THE "B PR" RECORD :
  3257   "RTN","CH8 35F1",767, 0)
  3258    ;S ^TMP($ J,"EDI_CRE ATE","BPR" ,0)=NFILE_ "^"_STSEQ_ "^"_PAMT_" ^"_PMETHOD _"^"_PYRDF I_"^"_PYRA CCT_"^"_PY RID_"^"_RC VDFI_"^"_R CVACCT_"^" _CHKEFDT
  3259   "RTN","CH8 35F1",768, 0)
  3260    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3261   "RTN","CH8 35F1",769, 0)
  3262    ;
  3263   "RTN","CH8 35F1",770, 0)
  3264    ;SBB 02/2 1/2018 CC4 002-001 up dated BPRT BL to use  REV835 var iable for  voids
  3265   "RTN","CH8 35F1",771, 0)
  3266    ;;4.PAYME NT AMOUNT; $S(REV835= 22:0,1:PAM T);25;L;;1 8.2FPN;R;
  3267   "RTN","CH8 35F1",772, 0)
  3268   BPRTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  3269   "RTN","CH8 35F1",773, 0)
  3270    ;;1.HEADE R ID;"BPR" ;36;L;;36A N;R;
  3271   "RTN","CH8 35F1",774, 0)
  3272    ;;2.FILE_ AUTH_NBR;N FILE;20;L; ;20AN;R;
  3273   "RTN","CH8 35F1",775, 0)
  3274    ;;3.ST02T XN_CTL_NBR ;STSEQ;9;L ;;5N;R;
  3275   "RTN","CH8 35F1",776, 0)
  3276    ;;4.PAYME NT AMOUNT; $S(REV835= 22:0,1:PAM T);25;L;;1 8.2FPN;R;
  3277   "RTN","CH8 35F1",777, 0)
  3278    ;;5.PAYME NT METHOD; PMETHOD;3; L;;3A;R;
  3279   "RTN","CH8 35F1",778, 0)
  3280    ;;6.PAYER  DFI ID;$S (PMETHOD=" ACH":"1110 36183",1:" ");12;L;;1 2AN;R;
  3281   "RTN","CH8 35F1",779, 0)
  3282    ;;7.PAYER  ACCOUNT N UMBER;$S(P METHOD="AC H":"360012 000",1:"") ;35;L;;35A N;R;
  3283   "RTN","CH8 35F1",780, 0)
  3284    ;;8.PAYER  ID;$S(EI' ="":$P($G( ^CHMEDIPA( EI,0)),"^" ,8),1:""); 10;L;;10AN ;O;
  3285   "RTN","CH8 35F1",781, 0)
  3286    ;;9.VENDR  BANK ROUT ING CODE;$ S(PMETHOD= "ACH":$P($ G(^CHMVEN( VENI,3))," ^",1),1:"" );12;L;;12 AN;O;
  3287   "RTN","CH8 35F1",782, 0)
  3288    ;;10.VEND OR BANK AC CT CODE;$S (PMETHOD=" ACH":$P($G (^CHMVEN(V ENI,3)),"^ ",3),1:"") ;35;L;;35A N;O;
  3289   "RTN","CH8 35F1",783, 0)
  3290    ;;11.CLAI M PYMT DAT E;CHKEFDT; 8;L;;DATE; R;
  3291   "RTN","CH8 35F1",784, 0)
  3292    ;;12.END  OF RECORD
  3293   "RTN","CH8 35F1",785, 0)
  3294    ;
  3295   "RTN","CH8 35F1",786, 0)
  3296    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3297   "RTN","CH8 35F1",787, 0)
  3298    ; TRN REC ORD GENERA TION THE F OLLOWING L INE IS REP LACED WITH  THE $TEXT  TABLE
  3299   "RTN","CH8 35F1",788, 0)
  3300    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3301   "RTN","CH8 35F1",789, 0)
  3302    ;  S TRSP YMNT=$$DTO UT^CH835FU 1($P(^CHMP AY(CI,0)," ^",10))                 ; DATE O F TREASURY  PAYMENT
  3303   "RTN","CH8 35F1",790, 0)
  3304    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3305   "RTN","CH8 35F1",791, 0)
  3306    ; CURRENT  RECORD CR EATION FOR  THE "TRN"  RECORD: 1 0/11/12 DL B
  3307   "RTN","CH8 35F1",792, 0)
  3308    ;S ^TMP($ J,"EDI_CRE ATE","TRN" ,0)=NFILE_ "^"_STSEQ_ "^"_FMSID_ "^"_PYRID_ "^"_$$DTOU T^CH835FU1 ($P(CLMLVL (1),"^",4) )
  3309   "RTN","CH8 35F1",793, 0)
  3310    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3311   "RTN","CH8 35F1",794, 0)
  3312    ;
  3313   "RTN","CH8 35F1",795, 0)
  3314   TRNTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  3315   "RTN","CH8 35F1",796, 0)
  3316    ;;1.HEADE R ID;"TRN" ;5;L;;5A;R ;
  3317   "RTN","CH8 35F1",797, 0)
  3318    ;;2.FILE_ AUTH_NBR;N FILE;36;L; ;20AN;R;
  3319   "RTN","CH8 35F1",798, 0)
  3320    ;;3.ST02T XN_CTL_NBR ;STSEQ;9;L ;;5N;R;
  3321   "RTN","CH8 35F1",799, 0)
  3322    ;;4.RECON CILIATION  NUMBER;CHK EFT;18;L;; 10AN;R;
  3323   "RTN","CH8 35F1",800, 0)
  3324    ;;5.HAC P AYER ID NU MBER;PYRID ;10;L;;10A N;R;
  3325   "RTN","CH8 35F1",801, 0)
  3326    ;;6.TREAS URY PYMT D ATE;$$DTOU T^CH835FU1 ($P(^CHMPA Y(PAYI,0), "^",10));8 ;L;;DATE;R ;
  3327   "RTN","CH8 35F1",802, 0)
  3328    ;;END OF  RECORD
  3329   "RTN","CH8 35F1",803, 0)
  3330    ;
  3331   "RTN","CH8 35F1",804, 0)
  3332    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3333   "RTN","CH8 35F1",805, 0)
  3334    ; PLB REC ORD GENERA TION THE F OLLOWING L INE IS REP LACED WITH  THE $TEXT  TABLE
  3335   "RTN","CH8 35F1",806, 0)
  3336    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3337   "RTN","CH8 35F1",807, 0)
  3338    ; CURRENT  RECORD CR EATION FOR  THE "PLB"  RECORD: 1 0/11/12  D LB
  3339   "RTN","CH8 35F1",808, 0)
  3340    ;S ^TMP($ J,"EDI_CRE ATE","PLB" ,0)=NFILE_ "^"_STSEQ_ "^"_PLBPTI D_"^"_PLBE NDFY_"^"_P LBRSNCD_"^ "_PLBADJID _"^"_PLBTO T
  3341   "RTN","CH8 35F1",809, 0)
  3342    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3343   "RTN","CH8 35F1",810, 0)
  3344    ;
  3345   "RTN","CH8 35F1",811, 0)
  3346   PLBTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  3347   "RTN","CH8 35F1",812, 0)
  3348    ;;1.HEADE R ID;"PLB" ;5;L;;5A;R ;
  3349   "RTN","CH8 35F1",813, 0)
  3350    ;;2.NEW_F ILE_AUTH_N BR;NFILE;3 6;L;;36AN; R;
  3351   "RTN","CH8 35F1",814, 0)
  3352    ;;3.NEW_S T02TXN_CTL _NBR;STSEQ ;9;L;;9N;R ;
  3353   "RTN","CH8 35F1",815, 0)
  3354    ;;4.PROVI DER ID;PLB PTID;15;L; ;15AN;O;
  3355   "RTN","CH8 35F1",816, 0)
  3356    ;;5.FISCA L DATE;PLB ENDFY;8;L; ;DATE;O;
  3357   "RTN","CH8 35F1",817, 0)
  3358    ;;6.ADJ R EASON CODE ;"L6";2;L; ;2AN;O;
  3359   "RTN","CH8 35F1",818, 0)
  3360    ;;7.RECON CILIATION  NUMBER;FMS ID;30;L;;3 0AN;O;
  3361   "RTN","CH8 35F1",819, 0)
  3362    ;;8.PROVI DER ADJ TO TAL;PLBTOT ;20;L;;18. 2FP;O;
  3363   "RTN","CH8 35F1",820, 0)
  3364    ;;END OF  RECORD
  3365   "RTN","CH8 35TRG")
  3366   0^81^B1086 165
  3367   "RTN","CH8 35TRG",1,0 )
  3368   CH835TRG ;  FTC/WTC ;  Create 83 5 Trigger  in ^CHMEDI ;Feb 05, 2 019@09:22: 36
  3369   "RTN","CH8 35TRG",2,0 )
  3370    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  3371   "RTN","CH8 35TRG",3,0 )
  3372    ; wtc CPE 005-036 9/ 18/17
  3373   "RTN","CH8 35TRG",4,0 )
  3374    ;
  3375   "RTN","CH8 35TRG",5,0 )
  3376    Q  ;
  3377   "RTN","CH8 35TRG",6,0 )
  3378    ;
  3379   "RTN","CH8 35TRG",7,0 )
  3380   ADD2QUE(PD I) ;
  3381   "RTN","CH8 35TRG",8,0 )
  3382    ;
  3383   "RTN","CH8 35TRG",9,0 )
  3384    ;  Create  entry in  ^CHMEDI fo r 835 reve rsal.
  3385   "RTN","CH8 35TRG",10, 0)
  3386    ;
  3387   "RTN","CH8 35TRG",11, 0)
  3388    ;  Return s 0 if fun ction fail s, 1 other wise.
  3389   "RTN","CH8 35TRG",12, 0)
  3390    ;
  3391   "RTN","CH8 35TRG",13, 0)
  3392    I $G(PDI) ="" Q "0^M issing PDI " ;
  3393   "RTN","CH8 35TRG",14, 0)
  3394    I PDI'?1. 15N Q "0^I nvalid PDI " ;
  3395   "RTN","CH8 35TRG",15, 0)
  3396    I '$D(^CH MIMAGE(PDI )) Q "0^PD I not on f ile" ;
  3397   "RTN","CH8 35TRG",16, 0)
  3398    ;
  3399   "RTN","CH8 35TRG",17, 0)
  3400    N DA,TODA Y ;
  3401   "RTN","CH8 35TRG",18, 0)
  3402    ;
  3403   "RTN","CH8 35TRG",19, 0)
  3404    D NOW^%DT C S TODAY= $P(%,".",1 ) ;
  3405   "RTN","CH8 35TRG",20, 0)
  3406    ;
  3407   "RTN","CH8 35TRG",21, 0)
  3408    S DA=$P(^ CH835REV(7 41215,0)," ^",3)+1,$P (^CH835REV (741215,0) ,"^",3)=DA ,$P(^(0)," ^",4)=$P(^ (0),"^",4) +1 ;
  3409   "RTN","CH8 35TRG",22, 0)
  3410    S ^CH835R EV(741215, DA,0)=PDI_ "^"_TODAY_ "^" ;
  3411   "RTN","CH8 35TRG",23, 0)
  3412    S ^CH835R EV(741215, "B",PDI,DA )="" ;
  3413   "RTN","CH8 35TRG",24, 0)
  3414    S ^CH835R EV(741215, "C",TODAY, DA)="" ;
  3415   "RTN","CH8 35TRG",25, 0)
  3416    ;
  3417   "RTN","CH8 35TRG",26, 0)
  3418    Q "1^"_DA  ;
  3419   "RTN","CH8 35TRG",27, 0)
  3420    ;
  3421   "RTN","CHC STAT")
  3422   0^82^B1099 344
  3423   "RTN","CHC STAT",1,0)
  3424   CHCSTAT ;  wtc/FTC -  CSTAT aler ts;Feb 05,  2019@09:2 3:29
  3425   "RTN","CHC STAT",2,0)
  3426    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  3427   "RTN","CHC STAT",3,0)
  3428    ; CPE005- 041 wtc 9/ 19/17
  3429   "RTN","CHC STAT",4,0)
  3430    ;
  3431   "RTN","CHC STAT",5,0)
  3432    Q  ;
  3433   "RTN","CHC STAT",6,0)
  3434    ;
  3435   "RTN","CHC STAT",7,0)
  3436   PDIFINAL(P DI,STATUS)  ;
  3437   "RTN","CHC STAT",8,0)
  3438    ;
  3439   "RTN","CHC STAT",9,0)
  3440    ;  Functi on that cr eates an a lert for a  PDI to ge nerate Fin al CSTAT m essage.
  3441   "RTN","CHC STAT",10,0 )
  3442    ;  Return s 0^reason  message i f alert is  not creat ed and 1^# 741213 poi nter other wise.
  3443   "RTN","CHC STAT",11,0 )
  3444    ;
  3445   "RTN","CHC STAT",12,0 )
  3446    I $G(PDI) ="" Q "0^M issing PDI " ;
  3447   "RTN","CHC STAT",13,0 )
  3448    I PDI'?1. 15N Q "0^I nvalid PDI " ;
  3449   "RTN","CHC STAT",14,0 )
  3450    I $G(STAT US)="" Q " 0^Missing  Status" ;
  3451   "RTN","CHC STAT",15,0 )
  3452    I $L(STAT US)>30 Q " 0^Invalid  Status" ;
  3453   "RTN","CHC STAT",16,0 )
  3454    ;
  3455   "RTN","CHC STAT",17,0 )
  3456    N DA,TODA Y ;
  3457   "RTN","CHC STAT",18,0 )
  3458    D NOW^%DT C S TODAY= $P(%,".",1 ) ;
  3459   "RTN","CHC STAT",19,0 )
  3460    S DA=$P(^ CHCSTAT(74 1213,0),"^ ",3)+1,$P( ^(0),"^",3 )=DA,$P(^( 0),"^",4)= $P(^(0),"^ ",4)+1 ;
  3461   "RTN","CHC STAT",20,0 )
  3462    S ^CHCSTA T(741213,D A,0)=PDI_" ^"_STATUS_ "^"_TODAY_ "^" ;
  3463   "RTN","CHC STAT",21,0 )
  3464    S ^CHCSTA T(741213," B",PDI,DA) ="" ;
  3465   "RTN","CHC STAT",22,0 )
  3466    S ^CHCSTA T(741213," AC",TODAY, DA)="" ;
  3467   "RTN","CHC STAT",23,0 )
  3468    Q "1^"_DA  ;
  3469   "RTN","CHC STAT",24,0 )
  3470    ;
  3471   "RTN","CHF BC1")
  3472   0^2^B11807 1981
  3473   "RTN","CHF BC1",1,0)
  3474   CHFBC1 ;HA C/CR;ALLOW ABLE CHARG ES FOR INP T CLAIMS -  SB/CHAMPV A;Feb 05,  2019@09:25 :04
  3475   "RTN","CHF BC1",2,0)
  3476    ;;1.0;CHA MPVA SYSTE M;**1,9,14 **;JULY 4,  1990;Buil d 9
  3477   "RTN","CHF BC1",3,0)
  3478    ;CPTS #10 846* - PEJ  8/15/96
  3479   "RTN","CHF BC1",4,0)
  3480    ;CPTS #11 773 BY DTP  (9-MAY-97 )
  3481   "RTN","CHF BC1",5,0)
  3482    ;CPT 9738  7/2/97 *C R*
  3483   "RTN","CHF BC1",6,0)
  3484    ;CPTS #11 959 BY DTP  (16-JUL-9 7)
  3485   "RTN","CHF BC1",7,0)
  3486    ;CPT 1197 3 7/21/97  *CR*, CPTS  #16855 BY  DTP (3-AU G-00)
  3487   "RTN","CHF BC1",8,0)
  3488    ;TT 8583  1/7/10 JEH
  3489   "RTN","CHF BC1",9,0)
  3490    ;JAK 5/10 /10;DEV009 610;ERROR  ON MISSING  DISCHARGE  STATUS BE FORE SENDI NG TO GROU PER
  3491   "RTN","CHF BC1",10,0)
  3492    ;BMJ 5/9/ 11 DEF0120 92
  3493   "RTN","CHF BC1",11,0)
  3494    ;JSE 8/21 /12 MTN014 930 FIX UN DEF ERROR  CK+11
  3495   "RTN","CHF BC1",12,0)
  3496    ;DEF01617 3 BMJ 11/2 6/12 EOB r eason code  283
  3497   "RTN","CHF BC1",13,0)
  3498    ;DEV00369 6 AEB 05/1 2/2012
  3499   "RTN","CHF BC1",14,0)
  3500    ;DEV00782 0 AEB 05/0 1/2013
  3501   "RTN","CHF BC1",15,0)
  3502    ;DEV02161 2 SBB 09/2 3/2014
  3503   "RTN","CHF BC1",16,0)
  3504    ;DEV02161 2 SBB 05/1 4/2015
  3505   "RTN","CHF BC1",17,0)
  3506    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  3507   "RTN","CHF BC1",18,0)
  3508    ;
  3509   "RTN","CHF BC1",19,0)
  3510   A1 S CHMFC HGS=$P(@(G LPAY_"CI," "COMMON"") "),"^")
  3511   "RTN","CHF BC1",20,0)
  3512    K CHSUDFG
  3513   "RTN","CHF BC1",21,0)
  3514    I $G(CHMF QUE)=10 G  END
  3515   "RTN","CHF BC1",22,0)
  3516    S CHMFDOB =$P(@(GLEL G_"AI,100, AJ,0)"),"^ ",3)
  3517   "RTN","CHF BC1",23,0)
  3518    S X=CHMFD OB D H^%DT C S HBD=%H
  3519   "RTN","CHF BC1",24,0)
  3520    S CHMADMD T=$P(REC0, "^",8)
  3521   "RTN","CHF BC1",25,0)
  3522    S CHMFDCD T=$P(@(GLP AY_"CI,""I NP"")"),"^ ")
  3523   "RTN","CHF BC1",26,0)
  3524    S CHMFLOS =$$LOS(CI, CHMADMDT,C HMFDCDT)
  3525   "RTN","CHF BC1",27,0)
  3526    S CHMFRDT =9999999-C HMFDCDT,CH MFRSD=CHMF RDT-1
  3527   "RTN","CHF BC1",28,0)
  3528    S:$E(CHMA DMDT,4,7)> 1000 CHFYR =($E(CHMAD MDT,1,3)+1 )_"0000"
  3529   "RTN","CHF BC1",29,0)
  3530    S:$E(CHMA DMDT,4,7)< 1000 CHFYR =$E(CHMADM DT,1,3)_"0 000"
  3531   "RTN","CHF BC1",30,0)
  3532   DR S VI=$P (REC0,"^", 3)
  3533   "RTN","CHF BC1",31,0)
  3534    G:CHPGPT= 2 DR3
  3535   "RTN","CHF BC1",32,0)
  3536    ;CPE VEND OR STREAML INING repl ace Provid er Zip w/  PL-ZIP GEF
  3537   "RTN","CHF BC1",33,0)
  3538    ;S:VI'=""  VZ=$E($P( ^CHMVEN(VI ,2),"^",5) ,1,5),VST= $P(^(2),"^ ",4)
  3539   "RTN","CHF BC1",34,0)
  3540    S:VI'=""  VST=$P(^CH MVEN(VI,2) ,"^",4)
  3541   "RTN","CHF BC1",35,0)
  3542    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  3543   "RTN","CHF BC1",36,0)
  3544    I VI="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": V ENDOR ID M ISSING" G  END
  3545   "RTN","CHF BC1",37,0)
  3546    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END ; GE F
  3547   "RTN","CHF BC1",38,0)
  3548    I VZ="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP MISS ING" G END
  3549   "RTN","CHF BC1",39,0)
  3550    I VST=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR STA TE MISSING " G END
  3551   "RTN","CHF BC1",40,0)
  3552    S VC=$O(^ CHMSMSA("Z IP",VZ,VST ,0))
  3553   "RTN","CHF BC1",41,0)
  3554    ;I VC=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  UNKNOWN O R INCOMPAT IBLE WITH  STATE" Q ;  GEF
  3555   "RTN","CHF BC1",42,0)
  3556    I VC="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP UNKN OWN OR INC OMPATIBLE  WITH STATE " Q
  3557   "RTN","CHF BC1",43,0)
  3558    S RI=$P(^ CHMSMSA(VS T,1,VC,0), "^",3),PL= $S(RI="":6 ,RI=0:4,1: 2)
  3559   "RTN","CHF BC1",44,0)
  3560    I RI="" S  RE=$O(^CH MSMSA(VST, 3,CHMFRSD) ) S:RE AW= $P(^CHMSMS A(VST,3,RE ,0),"^",2)  G DR2
  3561   "RTN","CHF BC1",45,0)
  3562    S RE=$O(^ CHMSMSA(VS T,1,VC,2,C HMFRSD))
  3563   "RTN","CHF BC1",46,0)
  3564    I 'RE S R E=$O(^CHMS MSA(VST,3, CHMFRSD))  S:RE AW=$P (^CHMSMSA( VST,3,RE,0 ),"^",2)
  3565   "RTN","CHF BC1",47,0)
  3566    E  S:RE A W=$P(^CHMS MSA(VST,1, VC,2,RE,0) ,"^",2)
  3567   "RTN","CHF BC1",48,0)
  3568    ;
  3569   "RTN","CHF BC1",49,0)
  3570   DR2 I CHMF DCDT<30410 01 I '$D(A W) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": AWI INF ORMATION M ISSING" Q    ;SKD, 1- 24-06
  3571   "RTN","CHF BC1",50,0)
  3572    I CHMFDCD T<3041001  I AW="" S  CHMFQUE=10 ,CHMMDP=CH MMDP_": AW I INFORMAT ION MISSIN G" Q  ;SKD , 1-24-06
  3573   "RTN","CHF BC1",51,0)
  3574   DR3 S (CHP SDU,CHRHU, CHRTC)=0
  3575   "RTN","CHF BC1",52,0)
  3576    I $D(^CHM VEN(VI,1))  S FTN=$P( ^CHMVEN(VI ,1),"^",7)  S:FTN=""  FTN=1
  3577   "RTN","CHF BC1",53,0)
  3578    I $D(^CHM VEN(VI,1))  S FT=$P(^ CHMDIC(741 002.11,FTN ,0),"^")
  3579   "RTN","CHF BC1",54,0)
  3580    S CHBGNDT =$O(^CHMVE N(VI,81,CH MFDCDT),-1 ) I CHBGND T D
  3581   "RTN","CHF BC1",55,0)
  3582    .Q:'$D(^C HMVEN(VI,8 1,CHBGNDT, 0))
  3583   "RTN","CHF BC1",56,0)
  3584    .I $P(^(0 ),"^",5)'= "" Q:$P(^( 0),"^",5)< CHMFDCDT
  3585   "RTN","CHF BC1",57,0)
  3586    .S:$P(^(0 ),"^",2)'= "" CHPSDU= 1
  3587   "RTN","CHF BC1",58,0)
  3588    S CHBGNDT =$O(^CHMVE N(VI,82,CH MFDCDT),-1 ) I CHBGND T D
  3589   "RTN","CHF BC1",59,0)
  3590    .Q:'$D(^C HMVEN(VI,8 2,CHBGNDT, 0))
  3591   "RTN","CHF BC1",60,0)
  3592    .I $P(^(0 ),"^",5)'= "" Q:$P(^( 0),"^",5)< CHMFDCDT
  3593   "RTN","CHF BC1",61,0)
  3594    .S:$P(^(0 ),"^",2)'= "" CHRHU=1
  3595   "RTN","CHF BC1",62,0)
  3596    S CHBGNDT =$O(^CHMVE N(VI,83,CH MFDCDT),-1 ) I CHBGND T D
  3597   "RTN","CHF BC1",63,0)
  3598    .Q:'$D(^C HMVEN(VI,8 3,CHBGNDT, 0))
  3599   "RTN","CHF BC1",64,0)
  3600    .I $P(^(0 ),"^",6)'= "" Q:$P(^( 0),"^",6)< CHMFDCDT
  3601   "RTN","CHF BC1",65,0)
  3602    .S:$P(^(0 ),"^",2)'= "" CHRTC=1
  3603   "RTN","CHF BC1",66,0)
  3604    I CHPGPT= 1 I FT="FN " D  G END
  3605   "RTN","CHF BC1",67,0)
  3606    .S $P(@(G LPAY_"CI," "RULE-PROC "",1,0)"), "^")=2,$P( ^(0),"^",2 )=$P(^CHMD IC(741002. 34,1,1),"^ ",17),CHMF CAA=0
  3607   "RTN","CHF BC1",68,0)
  3608    S (DCB,DA B,NM)=0 F   S NM=$O(@ (GLPAY_"CI ,""INP-DX" ",NM)")) Q :NM'?1N.N   S K2="INP -DX",K1="R ULE-DX" D  CK
  3609   "RTN","CHF BC1",69,0)
  3610    S NM=0 F   S NM=$O(@ (GLPAY_"CI ,""INP-PRO C"",NM)"))  Q:NM'?1N. N  S K2="I NP-PROC",K 1="RULE-PR OC" D CK
  3611   "RTN","CHF BC1",70,0)
  3612    K CHGFL S  DN=0 F  S  DN=$O(@(G LPAY_"CI," "RULE-DX"" ,DN)")) Q: 'DN  I $D( ^(DN,0)) I  $P(^(0)," ^",1)'=0 S  CHGFL=1
  3613   "RTN","CHF BC1",71,0)
  3614    S DN=0 F   S DN=$O(@ (GLPAY_"CI ,""INP-DX" ",DN)")) Q :'DN  D
  3615   "RTN","CHF BC1",72,0)
  3616    .I $D(@(G LPAY_"CI," "INP-DX"", DN,0)")) I  $P(@(GLPA Y_"CI,""IN P-DX"",DN, 0)"),"^",1 )'="" I $D (^CHMICDX( $P(@(GLPAY _"CI,""INP -DX"",DN,0 )"),"^",1) ,0)) K:$P( ^(0),"^",2 )="000.00"  CHGFL
  3617   "RTN","CHF BC1",73,0)
  3618    I '$D(CHG FL) S CHMF QUE=12 D P ROC^CHFBC2  G END
  3619   "RTN","CHF BC1",74,0)
  3620    I CHPGPT= 2 S CHMFNP =1 D ^CHFB C1C G END
  3621   "RTN","CHF BC1",75,0)
  3622    ;DEV02161 2 SBB 09/2 3/2014 add ing this l ogic to se nd I/P cla ims to QA  SNF queue  when,
  3623   "RTN","CHF BC1",76,0)
  3624    ; there i s a qualif ier for ve ndor like  K# or if T OB is betw een 210 -  218.
  3625   "RTN","CHF BC1",77,0)
  3626    I $D(CHMF QUE),(CHMF QUE=28) G  END
  3627   "RTN","CHF BC1",78,0)
  3628    ;
  3629   "RTN","CHF BC1",79,0)
  3630    S CHBGNDT =$O(^CHMVE N(VI,80,CH MFDCDT),-1 ) I CHBGND T D  I $D( CHMFNP) G  END:$D(CHM FQUE) D ^C HFBC1C G E ND
  3631   "RTN","CHF BC1",80,0)
  3632    . Q:'$D(^ CHMVEN(VI, 80,CHBGNDT ,0))
  3633   "RTN","CHF BC1",81,0)
  3634    . I $P(^( 0),"^",5)' ="" Q:$P(^ (0),"^",5) <CHMFDCDT
  3635   "RTN","CHF BC1",82,0)
  3636    . S:$P(^( 0),"^",2)= "" CHMFNP= 1
  3637   "RTN","CHF BC1",83,0)
  3638    . ;DEV021 612 SBB 05 /14/2015 A dded chang es to catc h SNF clai ms.
  3639   "RTN","CHF BC1",84,0)
  3640    . Q:$G(CH MFNP)
  3641   "RTN","CHF BC1",85,0)
  3642    . N SNFTO B,IX,TOBA  S SNFTOB=$ P(^CHMPAY( CI,7),"^", 6) F IX=21 0:1:218 S  TOBA(IX)=" "
  3643   "RTN","CHF BC1",86,0)
  3644    . I (SNFT OB'=""),$D (TOBA(SNFT OB)) S CHM FNP=1 Q
  3645   "RTN","CHF BC1",87,0)
  3646    . I ($P(^ CHMVEN(VI, 1),"^",7)= 9)!($P(^CH MVEN(VI,1) ,"^",7)=25 ) S CHMFNP =1
  3647   "RTN","CHF BC1",88,0)
  3648    . Q
  3649   "RTN","CHF BC1",89,0)
  3650    ;
  3651   "RTN","CHF BC1",90,0)
  3652    I $D(^CHM DIC(741002 .97,"B",FT N)) G END: $D(CHMFQUE ) S CHMFNP =1 D ^CHFB C1C G END
  3653   "RTN","CHF BC1",91,0)
  3654    S CHMFIP= 1,(L,PCB,P AB)=0 F  S  L=$O(@(GL PAY_"CI,"" INP-PROC"" ,L)")) Q:L '?1N.N  D
  3655   "RTN","CHF BC1",92,0)
  3656    .I $D(@(G LPAY_"CI," "RULE-PROC "",L,0)"))  I $P(@(GL PAY_"CI,"" RULE-PROC" ",L,0)")," ^",1)'=0 S  NM=$P(@(G LPAY_"CI," "INP-PROC" ",L,0)")," ^") I $D(^ CHMSERV(NM ,0)) S:$P( ^(0),"^",2 )=1 PCB=1  S:$P(^(0), "^",2)=0 P AB=1
  3657   "RTN","CHF BC1",93,0)
  3658    S PTAGYR= ((HADT-HBD )/365.25)\ 1
  3659   "RTN","CHF BC1",94,0)
  3660    S:FT="CH"  PTAGDY=HA DT-HBD
  3661   "RTN","CHF BC1",95,0)
  3662    I (PTAGYR <18),(DCB! PCB) G END :$D(CHMFQU E) S CHMFN P=1 D ^CHF BC1C G END
  3663   "RTN","CHF BC1",96,0)
  3664    I DAB!PAB  G END:$D( CHMFQUE) S  CHMFNP=1  D ^CHFBC1C  G END
  3665   "RTN","CHF BC1",97,0)
  3666    I (PTAGYR <18),(FT=" CH"),(CHMA DMDT<28904 01) G END: $D(CHMFQUE ) S CHMFNP =1 D ^CHFB C1C G END
  3667   "RTN","CHF BC1",98,0)
  3668   ENHBG S CN =$P(REC0," ^")
  3669   "RTN","CHF BC1",99,0)
  3670    I '$D(@(G LPAY_"CI," "COMMON"") "))!(($P(@ (GLPAY_"CI ,""COMMON" ")"),"^",8 )="")!(($P (@(GLPAY_" CI,""COMMO N"")"),"^" ,8)="DRG") )) D   ;JA K 5/10/10; DEV009610;
  3671   "RTN","CHF BC1",100,0 )
  3672    .I $P(^CH MPAY(CI,"I NP"),U,2)= ""  D   ;J AK 5/10/10 ;DEV009610 ; check fo r missing  discharge  status;
  3673   "RTN","CHF BC1",101,0 )
  3674    ..D MISDQ    ;JAK 5/ 10/10;DEV0 09610; put  in missin g data que ue
  3675   "RTN","CHF BC1",102,0 )
  3676    .E  D   ; JAK 5/10/1 0;DEV00961 0;
  3677   "RTN","CHF BC1",103,0 )
  3678    ..D ^CHMJ GRPR ;JAK  5/10/10;DE V009610; g o to the g rouper pro cess  ;AEB  10/25/201 2 CHANGED  FROM GO TO  DO ADDED  NEXT QUIT  LINE DEV 3 696
  3679   "RTN","CHF BC1",104,0 )
  3680    ..Q
  3681   "RTN","CHF BC1",105,0 )
  3682   SECTIM S:$ D(CHD) $P( @(GLPAY_"C I,""COMMON "")"),"^", 8)=CHD
  3683   "RTN","CHF BC1",106,0 )
  3684    S (CHPSDR G,CHRHDRG, CHRTCDRG)= 0,CHMFDRG= $P(@(GLPAY _"CI,""COM MON"")")," ^",8),CHMF DRG=+CHMFD RG
  3685   "RTN","CHF BC1",107,0 )
  3686    S:(+CHMFD RG'=0) CHP SDRG=$$GET PSYFG(CHMF DCDT),CHRH DRG=$P(^CH MDIC(74100 2.16,CHMFD RG,0),"^", 6),CHRTCDR G=$P(^CHMD IC(741002. 16,CHMFDRG ,0),"^",7)     ;SKD,  8-17-09, D EV006223
  3687   "RTN","CHF BC1",108,0 )
  3688    I CHPSDRG ,CHRTC D ^ CHFBC1C G  END
  3689   "RTN","CHF BC1",109,0 )
  3690    I FT="RTC ",CHPSDRG  D ^CHFBC1C  G END
  3691   "RTN","CHF BC1",110,0 )
  3692    I CHPSDRG ,CHPSDU D  ^CHFBC1C G  END
  3693   "RTN","CHF BC1",111,0 )
  3694    I CHRHDRG ,CHRHU D ^ CHFBC1C G  END
  3695   "RTN","CHF BC1",112,0 )
  3696    I FT="PS" ,CHPSDRG D  ^CHFBC1C  G END
  3697   "RTN","CHF BC1",113,0 )
  3698    I FT="RH" ,CHRHDRG D  ^CHFBC1C  G END
  3699   "RTN","CHF BC1",114,0 )
  3700    K CHSUDFG
  3701   "RTN","CHF BC1",115,0 )
  3702    ;I CHMFDR G=900 I FT '="SUD" D  SUDCHK I ' $D(CHSUDFG ) D ^CHFBC 1C G END    ;JEH 1/7/ 10
  3703   "RTN","CHF BC1",116,0 )
  3704    ;I CHMFDR G=901 I FT '="SUD" D  SUDCHK I ' $D(CHSUDFG ) D ^CHFBC 1C G END    ;JEH 1/7/ 10
  3705   "RTN","CHF BC1",117,0 )
  3706    ;I CHMFDR G=900 I FT '="SUD" S  $D(CHSUDFG ) D ^CHFBC 1C G END
  3707   "RTN","CHF BC1",118,0 )
  3708    ;I CHMFDR G=901 I FT '="SUD" S  $D(CHSUDFG ) D ^CHFBC 1C G END
  3709   "RTN","CHF BC1",119,0 )
  3710    ;Followin g line and  subroutin e CTCK add ed 1/13/92  by CR to  allow all
  3711   "RTN","CHF BC1",120,0 )
  3712    ;Maryland  Inp. clai ms to calc  as billed .
  3713   "RTN","CHF BC1",121,0 )
  3714    D:$D(^CHM DIC(741002 .51,"B",$P (^CHMVEN(V I,2),"^",4 ))) CTCK I  $D(CHMFNP ) D ^CHFBC 1C G END
  3715   "RTN","CHF BC1",122,0 )
  3716    S FLG203= 0
  3717   "RTN","CHF BC1",123,0 )
  3718    I $D(@(GL PAY_"CI,"" INP"")"))  S ZD=$P(@( GLPAY_"CI, ""INP"")") ,"^",2) I  ZD'="" I $ D(^CHMDIC( 741002.12, ZD,0)) I $ E($P(^(0), "^",1),1)= 3 D  I FLG 203=1 G EN D
  3719   "RTN","CHF BC1",124,0 )
  3720    .I ($P(@( GLPAY_"CI, ""COMMON"" )"),"^",16 )=3)!($P(@ (GLPAY_"CI ,""COMMON" ")"),"^",1 6)=4) D  Q   ;Added H VMH and LV MH for the  203 code  ;BMJ 5/10/ 11 DEF0120 92
  3721   "RTN","CHF BC1",125,0 )
  3722    ..I $P(@( GLPAY_"CI, 0)"),"^",1 3)=203 S $ P(@(GLPAY_ "CI,0)")," ^",13)=""
  3723   "RTN","CHF BC1",126,0 )
  3724    .I $P(@(G LPAY_"CI," "COMMON"") "),"^",16) ="" D  Q
  3725   "RTN","CHF BC1",127,0 )
  3726    ..I $P(@( GLPAY_"CI, 0)"),"^",1 3)=203 S $ P(@(GLPAY_ "CI,0)")," ^",13)=""
  3727   "RTN","CHF BC1",128,0 )
  3728    .S CHMFQU E=35,$P(@( GLPAY_"CI, 0)"),"^",1 3)=$P(^CHM DIC(741002 .34,1,3)," ^",8),FLG2 03=1
  3729   "RTN","CHF BC1",129,0 )
  3730    I ($P(@(G LPAY_"CI," "COMMON"") "),"^",16) =3)!($P(@( GLPAY_"CI, ""COMMON"" )"),"^",16 )=4) D
  3731   "RTN","CHF BC1",130,0 )
  3732    .S HLTOB= 0 ;DEF0161 73 BMJ Add ed this li ne and the  lines wit h the 114  TOB below.
  3733   "RTN","CHF BC1",131,0 )
  3734    .I '$D(^C HMPAY(CI,7 )) Q
  3735   "RTN","CHF BC1",132,0 )
  3736    .S HLTOB= $P(^CHMPAY (CI,7),"^" ,6)
  3737   "RTN","CHF BC1",133,0 )
  3738    .I HLTOB= 114 D
  3739   "RTN","CHF BC1",134,0 )
  3740    ..I $P(@( GLPAY_"CI, 0)"),"^",1 3)=283 S $ P(@(GLPAY_ "CI,0)")," ^",13)=""
  3741   "RTN","CHF BC1",135,0 )
  3742    I $D(@(GL PAY_"CI,7) ")) S CHVA R=$P(@(GLP AY_"CI,7)" ),"^",6) I  CHVAR'=""  I $D(^CHM XDIC(74120 1.46,"C",0 ,CHVAR)) D   K CHVAR  G END
  3743   "RTN","CHF BC1",136,0 )
  3744    .S CHMFQU E=35,$P(@( GLPAY_"CI, 0)"),"^",1 3)=$P(^CHM DIC(741002 .34,1,3)," ^",13)
  3745   "RTN","CHF BC1",137,0 )
  3746    D ^CHFBC1 D
  3747   "RTN","CHF BC1",138,0 )
  3748   END I $D(@ (GLPAY_"CI ,""INP"")" )) S:$P(@( GLPAY_"CI, ""INP"")") ,"^",10) C HMFCAA=$P( @(GLPAY_"C I,""INP"") "),"^",10)
  3749   "RTN","CHF BC1",139,0 )
  3750    K BDXC,DX ,NDX,BDXA, NP,BPC,BPA ,PAB,PCB,Y R,X,L,Y,NM M,K1,K2,RN
  3751   "RTN","CHF BC1",140,0 )
  3752    K FT,CHMF DOB,CH,PTA GYR,AW,NM, L,P,PL,HBD ,CHMX,EC,C HMFCHGS,CH MADMDT
  3753   "RTN","CHF BC1",141,0 )
  3754    K HDDT,HA DT,VI,VZ,V ST,VC,RI,D L,CHPSDU,C HPSDRG,DAB ,DCB
  3755   "RTN","CHF BC1",142,0 )
  3756    Q
  3757   "RTN","CHF BC1",143,0 )
  3758   CTCK K CHM FNP,CHMSCT C Q:$P(^CH MVEN(VI,1) ,"^",16)=1
  3759   "RTN","CHF BC1",144,0 )
  3760    S CHMSTAT E=$P(^CHMV EN(VI,2)," ^",4)
  3761   "RTN","CHF BC1",145,0 )
  3762    S CTCI=$O (^CHMDIC(7 41002.51," B",CHMSTAT E,0)) Q:'C TCI
  3763   "RTN","CHF BC1",146,0 )
  3764    I $D(^CHM DIC(741002 .51,CTCI,2 )) Q:$D(^C HMDIC(7410 02.51,CTCI ,2,"B",FTN ))
  3765   "RTN","CHF BC1",147,0 )
  3766    S BGDT=CH MADMDT_".9 999999"
  3767   "RTN","CHF BC1",148,0 )
  3768   CTC1 S BGD T=$O(^CHMD IC(741002. 51,CTCI,1, BGDT),-1)  Q:'BGDT
  3769   "RTN","CHF BC1",149,0 )
  3770    Q:'$D(^CH MDIC(74100 2.51,CTCI, 1,BGDT,0))
  3771   "RTN","CHF BC1",150,0 )
  3772    S TERM=$P (^(0),"^", 3) I TERM' ="" G:CHMA DMDT'<TERM  CTC2
  3773   "RTN","CHF BC1",151,0 )
  3774    S CHMFNP= 1,CHMACTC= $P(^(0),"^ ",2),CHMSC TC=1
  3775   "RTN","CHF BC1",152,0 )
  3776   CTC2 K TER M,BGDT,CTC I,CHMSTATE  Q
  3777   "RTN","CHF BC1",153,0 )
  3778   CK K AHTS
  3779   "RTN","CHF BC1",154,0 )
  3780    I K2="INP -DX" Q:'$D (@(GLPAY_" CI,K2,NM,0 )"))  Q:$P (@(GLPAY_" CI,K2,NM,0 )"),"^")=" "
  3781   "RTN","CHF BC1",155,0 )
  3782    I K2="INP -DX" D
  3783   "RTN","CHF BC1",156,0 )
  3784    .I '$D(^C HMICDX($P( @(GLPAY_"C I,K2,NM,0) "),"^"),10 2,CHPGPT,0 )) K AHTS
  3785   "RTN","CHF BC1",157,0 )
  3786    .E  S AHT S=$P(^CHMI CDX($P(@(G LPAY_"CI,K 2,NM,0)"), "^"),102,C HPGPT,0)," ^",2) I AH TS="" K AH TS
  3787   "RTN","CHF BC1",158,0 )
  3788    .I '$D(AH TS) S CHPG PTI=0,CHPG PTI=$O(^CH MDIC(74100 2.94,"C"," CHAMPVA",0 )) S:$D(^C HMICDX($P( @(GLPAY_"C I,K2,NM,0) "),"^"),10 2,CHPGPTI, 0)) AHTS=$ P(^CHMICDX ($P(@(GLPA Y_"CI,K2,N M,0)"),"^" ),102,CHPG PTI,0),"^" ,2)
  3789   "RTN","CHF BC1",159,0 )
  3790    I K2="INP -DX" S KK= $P(@(GLPAY _"CI,K2,NM ,0)"),"^")  I $D(^CHM ICDX(KK,0) ) S:$P(^(0 ),"^",18)= 1 DCB=1 S: $P(^(0),"^ ",18)=0 DA B=1
  3791   "RTN","CHF BC1",160,0 )
  3792    I K2="INP -PROC" D
  3793   "RTN","CHF BC1",161,0 )
  3794    .I '$D(^C HMSERV($P( @(GLPAY_"C I,K2,NM,0) "),"^"),10 2,CHPGPT,0 )) K AHTS
  3795   "RTN","CHF BC1",162,0 )
  3796    .E  S AHT S=$P(^CHMS ERV($P(@(G LPAY_"CI,K 2,NM,0)"), "^"),102,C HPGPT,0)," ^",2) I AH TS="" K AH TS
  3797   "RTN","CHF BC1",163,0 )
  3798    .I '$D(AH TS) S CHPG PTI=0,CHPG PTI=$O(^CH MDIC(74100 2.94,"C"," CHAMPVA",0 )) S:$D(^C HMSERV($P( @(GLPAY_"C I,K2,NM,0) "),"^"),10 2,CHPGPTI, 0)) AHTS=$ P(^(0),"^" ,2)
  3799   "RTN","CHF BC1",164,0 )
  3800    ;I ('$D(A HTS))!(AHT S="") S CH MFQUE=7,CH MMDP=CHMMD P_": NO TE ST",$P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=$P( ^CHMDIC(74 1002.34,1, 1),"^",12) ,$P(@(GLPA Y_"CI,K1,N M,0)"),"^" )=3 Q
  3801   "RTN","CHF BC1",165,0 )
  3802    ;JSE 8/21 /12 MTN014 930 FIX UN DEF ERROR  CK+11
  3803   "RTN","CHF BC1",166,0 )
  3804    I '$D(AHT S) S CHMFQ UE=7,CHMMD P=CHMMDP_" : NO TEST" ,$P(@(GLPA Y_"CI,K1,N M,0)"),"^" ,2)=$P(^CH MDIC(74100 2.34,1,1), "^",12),$P (@(GLPAY_" CI,K1,NM,0 )"),"^")=3  Q
  3805   "RTN","CHF BC1",167,0 )
  3806    I AHTS=""  S CHMFQUE =7,CHMMDP= CHMMDP_":  NO TEST",$ P(@(GLPAY_ "CI,K1,NM, 0)"),"^",2 )=$P(^CHMD IC(741002. 34,1,1),"^ ",12),$P(@ (GLPAY_"CI ,K1,NM,0)" ),"^")=3 Q
  3807   "RTN","CHF BC1",168,0 )
  3808    I '$D(^DI C(AHFILE,A HTS,0)) S  CHMFQUE=7, CHMMDP=CHM MDP_": NO  TEST",$P(@ (GLPAY_"CI ,K1,NM,0)" ),"^",2)=$ P(^CHMDIC( 741002.34, 1,1),"^",1 2),$P(@(GL PAY_"CI,K1 ,NM,0)")," ^")=3 Q
  3809   "RTN","CHF BC1",169,0 )
  3810    S:K2="INP -DX" CHMFC T=1,CHMFJP =NM S:K2=" INP-PROC"  CHMFCT=2,C HMFJP=NM
  3811   "RTN","CHF BC1",170,0 )
  3812    S NMM=NM, KK2=K2 D ^ AHCJAE S N M=NMM,K2=K K2 S $P(@( GLPAY_"CI, K1,NM,0)") ,"^")=AHDA TA(AHSTV,1 ),RN=$O(^D IC(AHNODIC ,"B","REAS ON",0)),AH RTE=$O(^DI C(AHNODIC, "B","ROUTE ",0))
  3813   "RTN","CHF BC1",171,0 )
  3814    I $D(AHDA TA(RN,1))  S $P(@(GLP AY_"CI,K1, NM,0)"),"^ ",2)=AHDAT A(RN,1)
  3815   "RTN","CHF BC1",172,0 )
  3816    S $P(@(GL PAY_"CI,K1 ,NM,0)")," ^",3)=$P(A HLTS,"^"), $P(@(GLPAY _"CI,K1,NM ,0)"),"^", 4)=$P(AHLT S,"^",2)
  3817   "RTN","CHF BC1",173,0 )
  3818    S $P(@(GL PAY_"CI,K1 ,NM,0)")," ^",5)=$P(A HLTS,"^",3 ),$P(@(GLP AY_"CI,K1, NM,0)"),"^ ",6)=$P(AH LTS,"^",4) ,$P(@(GLPA Y_"CI,K1,N M,0)"),"^" ,7)=$P(AHL TS,"^",5)
  3819   "RTN","CHF BC1",174,0 )
  3820    I $D(AHDA TA(AHRTE,1 )) S:AHDAT A(AHRTE,1) =1 CHMFQUE =5
  3821   "RTN","CHF BC1",175,0 )
  3822    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4)) I ($P (@(GLPAY_" CI,K1,NM,0 )"),"^",2) ="")&('$D( AHDATA(AHR TE,1))) S  $P(@(GLPAY _"CI,K1,NM ,0)"),"^", 2)=$P(^CHM DIC(741002 .34,1,1)," ^",13),CHM FQUE=5
  3823   "RTN","CHF BC1",176,0 )
  3824    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4)),$P(@( GLPAY_"CI, K1,NM,0)") ,"^",2)=$P (^CHMDIC(7 41002.34,1 ,1),"^",13 ) S CHMFQU E=5
  3825   "RTN","CHF BC1",177,0 )
  3826    I $D(AHDA TA(AHRTE,1 )),AHDATA( AHRTE,1)=2 ,$D(CHMFQU E),(CHMFQU E'=5) S CH MFQUE=28
  3827   "RTN","CHF BC1",178,0 )
  3828    I $D(AHDA TA(AHRTE,1 )),AHDATA( AHRTE,1)=2 ,'$D(CHMFQ UE) S CHMF QUE=28
  3829   "RTN","CHF BC1",179,0 )
  3830    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4)),$P(@( GLPAY_"CI, K1,NM,0)") ,"^",2)=$P (^CHMDIC(7 41002.34,1 ,1),"^",14 ),$D(CHMFQ UE),(CHMFQ UE'=5) S C HMFQUE=28
  3831   "RTN","CHF BC1",180,0 )
  3832    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4)),$P(@( GLPAY_"CI, K1,NM,0)") ,"^",2)=$P (^CHMDIC(7 41002.34,1 ,1),"^",14 ),'$D(CHMF QUE) S CHM FQUE=28
  3833   "RTN","CHF BC1",181,0 )
  3834    I $D(CHMF QUE),((CHM FQUE=5)!(C HMFQUE=28) ) D:(K2="I NP-DX") DI AG^CHFBC1F  D:(K2="IN P-PROC") P ROC^CHFBC1 F
  3835   "RTN","CHF BC1",182,0 )
  3836    I AHDATA( AHSTV,1)=3  S:'$D(CHM FQUE) CHMF QUE=6,CHMM DP=CHMMDP_ ": FROM TE ST"
  3837   "RTN","CHF BC1",183,0 )
  3838    I AHDATA( AHSTV,1)=- 1 S CHMFQU E=18
  3839   "RTN","CHF BC1",184,0 )
  3840    Q
  3841   "RTN","CHF BC1",185,0 )
  3842   SUDCHK S C HBGNDT=$O( ^CHMVEN(VI ,88,CHMFDC DT),-1) I  CHBGNDT D
  3843   "RTN","CHF BC1",186,0 )
  3844    .Q:'$D(^C HMVEN(VI,8 8,CHBGNDT, 0))
  3845   "RTN","CHF BC1",187,0 )
  3846    .I $P(^(0 ),"^",5)'= "" Q:$P(^( 0),"^",5)< CHMFDCDT
  3847   "RTN","CHF BC1",188,0 )
  3848    .S:$P(^(0 ),"^",2)'= "" CHSUDFG =1
  3849   "RTN","CHF BC1",189,0 )
  3850    Q
  3851   "RTN","CHF BC1",190,0 )
  3852    ;******** ********** ********** ********** ********** *******
  3853   "RTN","CHF BC1",191,0 )
  3854    ;LOS Func tion: CALC ULATES THE  LENGTH OF  STAY
  3855   "RTN","CHF BC1",192,0 )
  3856    ;Input pa rameters:
  3857   "RTN","CHF BC1",193,0 )
  3858    ;   INCLM  - Ivalue  from CHMPA Y
  3859   "RTN","CHF BC1",194,0 )
  3860    ;   CHADM DT - ADMIT TANCE DATE / DATE OF  SERVICE
  3861   "RTN","CHF BC1",195,0 )
  3862    ;     ($P (@(GLPAY_" CI,0)"),"^ ",8))
  3863   "RTN","CHF BC1",196,0 )
  3864    ;   CHDCD T - DISCHA RGE DATE
  3865   "RTN","CHF BC1",197,0 )
  3866    ;               ($P( @(GLPAY_"C I,""INP"") "),"^",1))
  3867   "RTN","CHF BC1",198,0 )
  3868    ;Return v alue:
  3869   "RTN","CHF BC1",199,0 )
  3870    ; CHMFLOS  - RETURNS  THE LENGT H OF STAY  IN DAYS
  3871   "RTN","CHF BC1",200,0 )
  3872    ;******** ********** ********** ********** ********** *******
  3873   "RTN","CHF BC1",201,0 )
  3874   LOS(INCLM, CHADMDT,CH DCDT) ;
  3875   "RTN","CHF BC1",202,0 )
  3876    S CHMFLOS =0
  3877   "RTN","CHF BC1",203,0 )
  3878    S X=CHADM DT D H^%DT C S HADT=% H
  3879   "RTN","CHF BC1",204,0 )
  3880    S X=CHDCD T D H^%DTC  S HDDT=%H
  3881   "RTN","CHF BC1",205,0 )
  3882    S CHMFLOS =HDDT-HADT  S:CHMFLOS <1 CHMFLOS =1
  3883   "RTN","CHF BC1",206,0 )
  3884    I $P(@(GL PAY_"INCLM ,""INP"")" ),"^",2)'= "" D
  3885   "RTN","CHF BC1",207,0 )
  3886    .S:$D(^CH MDIC(74100 2.39,"B",$ P(@(GLPAY_ "INCLM,""I NP"")"),"^ ",2))) CHM FLOS=CHMFL OS+1
  3887   "RTN","CHF BC1",208,0 )
  3888    Q CHMFLOS
  3889   "RTN","CHF BC1",209,0 )
  3890    ;
  3891   "RTN","CHF BC1",210,0 )
  3892   GETPSYFG(D CDT) ;retu rn 1 if ps y DRG, oth erwise ret urn 0  ;SK D, 8-17-09 , DEV00622 3
  3893   "RTN","CHF BC1",211,0 )
  3894    NEW CHFRD T
  3895   "RTN","CHF BC1",212,0 )
  3896    I DCDT=""  Q 0
  3897   "RTN","CHF BC1",213,0 )
  3898    S CHFRDT= 9999999-DC DT
  3899   "RTN","CHF BC1",214,0 )
  3900    S CHJ=0,C HJ=$O(^CHM DIC(741002 .16,CHMFDR G,1,CHFRDT )) I 'CHJ  Q 0
  3901   "RTN","CHF BC1",215,0 )
  3902    I $P($G(^ CHMDIC(741 002.16,CHM FDRG,1,CHJ ,0)),"^",1 1)=1 Q 1
  3903   "RTN","CHF BC1",216,0 )
  3904    E  Q 0
  3905   "RTN","CHF BC1",217,0 )
  3906    ;
  3907   "RTN","CHF BC1",218,0 )
  3908   MISDQ D NO W^%DTC S C HDT=% I $D (^CHMMDQ(" B",CHDT))  G MISDQ    ;JAK 5/10/ 10;DEV0096 10; set da te/time an d make sur e not alre ady in MD  queue
  3909   "RTN","CHF BC1",219,0 )
  3910    S (DIC,DL AYGO)=7410 10.11,DIC( 0)="ML",X= CHDT D ^DI C K DIC I  $P(Y,"^",3 )'=1 G MIS DQ   ;JAK  5/10/10;DE V009610;
  3911   "RTN","CHF BC1",220,0 )
  3912    S CHMMDR= 6,CHMMDP=C HMMDP_": M ISSING DIS CHARGE STA TUS"   ;JA K 5/10/10; DEV009610;  set missi ng claim d ata (6) an d descript ion
  3913   "RTN","CHF BC1",221,0 )
  3914    S DA=+Y,D IE=741010. 11,DR=".02 ////^S X=X 1;.03///^S  X=0;.06// /^S X=CHMM DR;.07///^ S X=CHMMDP " D ^DIE K  DIE,DR    ;JAK 5/10/ 10;DEV0096 10; define  values fr om missing  data glob al
  3915   "RTN","CHF BC1",222,0 )
  3916    S CHMFPP= "SQMSD",CH MFI=X1 D ^ CHMFWK02    ;JAK 5/10 /10;DEV009 610; workf low status  set to "P UT IN TO M ISSING DAT A QUEUE"
  3917   "RTN","CHF BC1",223,0 )
  3918    S CHMQNAM ="CHMMDQ(" ,CHMIN=""  K CHMOUT D  ^CHMIS041    ;JAK 5/ 10/10;DEV0 09610; put  data into  missing d ata que
  3919   "RTN","CHF BC1",224,0 )
  3920    Q
  3921   "RTN","CHF BC1D")
  3922   0^3^B79160 574
  3923   "RTN","CHF BC1D",1,0)
  3924   CHFBC1D ;H AC/CR;DETE RMINES ALL OWABLE CHA RGES FOR D RG'S - CVA /SB;Feb 05 , 2019@09: 26:10
  3925   "RTN","CHF BC1D",2,0)
  3926    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  3927   "RTN","CHF BC1D",3,0)
  3928    ;;CPTS #1 1289* BY D TP (4-DEC- 96), #1582 8* (RLC)
  3929   "RTN","CHF BC1D",4,0)
  3930    ;;CPTS #1 6855 BY DT P (3-AUG-0 0)
  3931   "RTN","CHF BC1D",5,0)
  3932    ;;ENC0028 77: IDME r ewrite to  store ZIP2 WAGE and I DME data i n separate  global  B Y JEH 9/21 /07
  3933   "RTN","CHF BC1D",6,0)
  3934    ;;DEV0058 45: CORREC T CLAIMS G OING TO MD Q FOR IDME   BY JEH 1 0/15/08
  3935   "RTN","CHF BC1D",7,0)
  3936    ;;DEF0083 28; CORREC T CLAIMS G OING TO MD Q FOR IDME  (DIFF ARE A(  BY JEH  10/30/09
  3937   "RTN","CHF BC1D",8,0)
  3938    ;DEV01106 9 1/5/2011  AEB
  3939   "RTN","CHF BC1D",9,0)
  3940    ;DEV00782 0 JAK
  3941   "RTN","CHF BC1D",10,0 )
  3942    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  3943   "RTN","CHF BC1D",11,0 )
  3944   CHMFDRG S  CHMFDRG=+$ P(@(GLPAY_ "CI,""COMM ON"")"),"^ ",8),$P(@( GLPAY_"CI, ""COMMON"" )"),"^",16 )=0,CHGRP= $P(^CHMPAY (CI,"COMMO N"),"^",9)    ;AEB 1/ 12/2011 DE V011069
  3945   "RTN","CHF BC1D",12,0 )
  3946    I '$D(CHM FDRG)&'$D( CHMST) S $ P(@(GLPAY_ "CI,""COMM ON"")"),"^ ",9)=3,$P( @(GLPAY_"C I,""COMMON "")"),"^", 10)=$P(^CH MDIC(74100 2.34,1,1), "^",18),CH MFQUE=10,C HMMDP=$G(C HMMDP)_":  UNKNOWN DR G NUMBER"  G END
  3947   "RTN","CHF BC1D",13,0 )
  3948    I '$D(CHM FDRG)&($D( CHMST)) S: CHMST=1 CH MFCAA=2000  S:CHMST=0  CHMFQUE=1 3 S:(CHMST =2)!(CHMST =4) CHMFQU E=5 S:CHMS T=3 CHMFQU E=11,CHMMD P=CHMMDP_" : BY CHOIC E" G END
  3949   "RTN","CHF BC1D",14,0 )
  3950    I (CHMFDR G="")&('$D (CHMST)) S  $P(@(GLPA Y_"CI,""CO MMON"")"), "^",9)=3,$ P(@(GLPAY_ "CI,""COMM ON"")"),"^ ",10)=$P(^ CHMDIC(741 002.34,1,1 ),"^",18), CHMFQUE=10 ,CHMMDP=$G (CHMMDP)_" : INFORMAT ION FOR DR G INCOMPLE TE" G END
  3951   "RTN","CHF BC1D",15,0 )
  3952    I (CHMFDR G="")&($D( CHMST)) S: CHMST=1 CH MFCAA=2000  S:CHMST=0  CHMFQUE=1 3 S:(CHMST =2)!(CHMST =4) CHMFQU E=5 S:CHMS T=3 CHMFQU E=11,CHMMD P=CHMMDP_" : BY CHOIC E" G END
  3953   "RTN","CHF BC1D",16,0 )
  3954    I ('$D(^C HMDIC(7410 02.16,CHMF DRG,0)))&' $D(CHMST)  S $P(@(GLP AY_"CI,""C OMMON"")") ,"^",9)=3, $P(@(GLPAY _"CI,""COM MON"")")," ^",10)=$P( ^CHMDIC(74 1002.34,1, 1),"^",18) ,CHMFQUE=1 0,CHMMDP=$ G(CHMMDP)_ ": INFORMA TION FOR D RG INCOMPL ETE" G END
  3955   "RTN","CHF BC1D",17,0 )
  3956    I ('$D(^C HMDIC(7410 02.16,CHMF DRG,0)))&( $D(CHMST))  S:CHMST=1  CHMFCAA=2 000 S:CHMS T=0 CHMFQU E=13 S:(CH MST=2)!(CH MST=4) CHM FQUE=5 S:C HMST=3 CHM FQUE=11,CH MMDP=$G(CH MMDP)_": B Y CHOICE"  G END
  3957   "RTN","CHF BC1D",18,0 )
  3958    S AHTS=$P (^CHMDIC(7 41002.16,C HMFDRG,0), "^",2)
  3959   "RTN","CHF BC1D",19,0 )
  3960    I '$D(AHT S)&('$D(CH MST)) S CH MFQUE=7,CH MMDP=CHMMD P_": NO TE ST",$P(@(G LPAY_"CI," "COMMON"") "),"^",10) =$P(^CHMDI C(741002.3 4,1,1),"^" ,12),$P(@( GLPAY_"CI, ""COMMON"" )"),"^",9) =3 G END
  3961   "RTN","CHF BC1D",20,0 )
  3962    I '$D(AHT S)&($D(CHM ST)) G:CHM ST=1 PRCS  S:CHMST=0  CHMFQUE=13  S:(CHMST= 2)!(CHMST= 4) CHMFQUE =5 S:CHMST =3 CHMFQUE =11,CHMMDP =$G(CHMMDP )_": BY CH OICE" G EN D
  3963   "RTN","CHF BC1D",21,0 )
  3964    I (AHTS=" ")&('$D(CH MST)) S CH MFQUE=7,CH MMDP=CHMMD P_": NO TE ST",$P(@(G LPAY_"CI," "COMMON"") "),"^",10) =$P(^CHMDI C(741002.3 4,1,1),"^" ,12),$P(@( GLPAY_"CI, ""COMMON"" )"),"^",9) =3 G END
  3965   "RTN","CHF BC1D",22,0 )
  3966    I (AHTS=" ")&($D(CHM ST)) G:CHM ST=1 PRCS  S:CHMST=0  CHMFQUE=13  S:(CHMST= 2)!(CHMST= 4) CHMFQUE =5 S:CHMST =3 CHMFQUE =11,CHMMDP =$G(CHMMDP )_": BY CH OICE" G EN D
  3967   "RTN","CHF BC1D",23,0 )
  3968    S CHMFCT= 0,CHMFJP=1  D ^AHCJAE
  3969   "RTN","CHF BC1D",24,0 )
  3970    S $P(@(GL PAY_"CI,"" COMMON"")" ),"^",9)=A HDATA(AHST V,1),RN=$O (^DIC(AHNO DIC,"B","R EASON",0)) ,AHRTE=$O( ^DIC(AHNOD IC,"B","RO UTE",0))
  3971   "RTN","CHF BC1D",25,0 )
  3972    I $D(AHDA TA(RN,1))  S $P(@(GLP AY_"CI,""C OMMON"")") ,"^",10)=A HDATA(RN,1 )
  3973   "RTN","CHF BC1D",26,0 )
  3974    S $P(@(GL PAY_"CI,"" COMMON"")" ),"^",11)= $P(AHLTS," ^")_";"_$P (AHLTS,"^" ,2)_";"_$P (AHLTS,"^" ,3)_";"_$P (AHLTS,"^" ,4)_";"_$P (AHLTS,"^" ,5)
  3975   "RTN","CHF BC1D",27,0 )
  3976    I (AHDATA (AHSTV,1)' =0)&(AHDAT A(AHSTV,1) '=1)&(AHDA TA(AHSTV,1 )'=2)&(AHD ATA(AHSTV, 1)'=3)&(AH DATA(AHSTV ,1)'=4) S  AHDATA(AHS TV,1)=-1
  3977   "RTN","CHF BC1D",28,0 )
  3978    I $D(AHDA TA(AHRTE,1 )),AHDATA( AHRTE,1)=1  S CHMFQUE =5 D DRG^C HFBC1F G E ND
  3979   "RTN","CHF BC1D",29,0 )
  3980    I $D(AHDA TA(AHRTE,1 )),AHDATA( AHRTE,1)=2 ,$D(CHMFQU E),(CHMFQU E'=5) S CH MFQUE=28 D  DRG^CHFBC 1F G END
  3981   "RTN","CHF BC1D",30,0 )
  3982    I $D(AHDA TA(AHRTE,1 )),AHDATA( AHRTE,1)=2 ,'$D(CHMFQ UE) S CHMF QUE=28 D D RG^CHFBC1F  G END
  3983   "RTN","CHF BC1D",31,0 )
  3984    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4))&('$D( CHMST)),$P (@(GLPAY_" CI,""COMMO N"")"),"^" ,10)="" S  $P(@(GLPAY _"CI,""COM MON"")")," ^",10)=$P( ^CHMDIC(74 1002.34,1, 1),"^",13) ,CHMFQUE=5  D DRG^CHF BC1F G END
  3985   "RTN","CHF BC1D",32,0 )
  3986    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4))&('$D( CHMST)),$P (@(GLPAY_" CI,""COMMO N"")"),"^" ,10)=$P(^C HMDIC(7410 02.34,1,1) ,"^",13) S  CHMFQUE=5  D DRG^CHF BC1F G END
  3987   "RTN","CHF BC1D",33,0 )
  3988    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4))&('$D( CHMST)),$P (@(GLPAY_" CI,""COMMO N"")"),"^" ,10)=$P(^C HMDIC(7410 02.34,1,1) ,"^",14) S  CHMFQUE=2 8 D DRG^CH FBC1F G EN D
  3989   "RTN","CHF BC1D",34,0 )
  3990    I (AHDATA (AHSTV,1)= 3)&('$D(CH MST)) S:'$ D(CHMFQUE)  CHMFQUE=6 ,CHMMDP=$G (CHMMDP)_" : FROM TES T" G END
  3991   "RTN","CHF BC1D",35,0 )
  3992    I (AHDATA (AHSTV,1)= 3)&($D(CHM ST)) I CHM ST=1 K CHM FQUE S CHM FCAA=2000  G END
  3993   "RTN","CHF BC1D",36,0 )
  3994    I (AHDATA (AHSTV,1)= 0)&('$D(CH MST)) S CH MFQUE=12 D  PROC^CHFB C2 G END
  3995   "RTN","CHF BC1D",37,0 )
  3996    I AHDATA( AHSTV,1)=- 1 S CHMFQU E=18 G END
  3997   "RTN","CHF BC1D",38,0 )
  3998    I $D(CHMS T) S $P(@( GLPAY_"CI, ""COMMON"" )"),"^",9) =CHMST
  3999   "RTN","CHF BC1D",39,0 )
  4000    I $D(CHMS T) I (CHMS T=2)!(CHMS T=4) S CHM FQUE=5 D D RG^CHFBC1F  G END
  4001   "RTN","CHF BC1D",40,0 )
  4002    I $D(CHMS T) I CHMST =3 S CHMFQ UE=11,CHMM DP=$G(CHMM DP)_": BY  CHOICE" G  END
  4003   "RTN","CHF BC1D",41,0 )
  4004    I $D(CHMS T) I CHMST =0 S CHMFQ UE=13 G EN D
  4005   "RTN","CHF BC1D",42,0 )
  4006    I $D(CHMS T) I CHMST =1 K CHMFQ UE
  4007   "RTN","CHF BC1D",43,0 )
  4008   PRCS S RE= $O(^CHMDIC (741002.17 ,1,1,CHMFR SD))
  4009   "RTN","CHF BC1D",44,0 )
  4010    I RE="" S  CHMFQUE=1 0,CHMMDP=$ G(CHMMDP)_ ": ADJUSTE D STANDARD  AMOUNT" G  END
  4011   "RTN","CHF BC1D",45,0 )
  4012    ;***EFF 1 0-1-04 GET  PROV MEDI CARE NO -  PWI,IDME M OD***
  4013   "RTN","CHF BC1D",46,0 )
  4014    I CHMFDCD T>3041000  D GETIDME  G:$D(CHMCQ FG) END
  4015   "RTN","CHF BC1D",47,0 )
  4016    ;
  4017   "RTN","CHF BC1D",48,0 )
  4018    ;***END P WI,IDME MO D********* *
  4019   "RTN","CHF BC1D",49,0 )
  4020    ;
  4021   "RTN","CHF BC1D",50,0 )
  4022    S CHMFLP= $P(^CHMDIC (741002.17 ,1,1,RE,0) ,"^",PL),C HMFNLP=$P( ^CHMDIC(74 1002.17,1, 1,RE,0),"^ ",PL+1)
  4023   "RTN","CHF BC1D",51,0 )
  4024    ;
  4025   "RTN","CHF BC1D",52,0 )
  4026    ;next 2 l ines repla ced for ID ME ;SKD 12 -31-06, ID ME - CHILD REN HOSP L ABOR DIFF
  4027   "RTN","CHF BC1D",53,0 )
  4028    ;I (FT="C H")&(PL<5)  S RE=$O(^ CHMDIC(741 002.17,1,5 ,CHMFRSD)) ,CHMFCLD=$ P(^CHMDIC( 741002.17, 1,5,RE,0), "^",PL),CH MFCNLD=$P( ^CHMDIC(74 1002.17,1, 5,RE,0),"^ ",PL+1)
  4029   "RTN","CHF BC1D",54,0 )
  4030    ;I (FT="C H")&(PL'<5 ) S (CHMFC LD,CHMFCNL D)=0
  4031   "RTN","CHF BC1D",55,0 )
  4032    I CHMFDCD T<3041001  D   ;SKD 1 2-31-06, I DME
  4033   "RTN","CHF BC1D",56,0 )
  4034    .I (FT="C H")&(PL<5)  S RE=$O(^ CHMDIC(741 002.17,1,5 ,CHMFRSD)) ,CHMFCLD=$ P(^CHMDIC( 741002.17, 1,5,RE,0), "^",PL),CH MFCNLD=$P( ^CHMDIC(74 1002.17,1, 5,RE,0),"^ ",PL+1)
  4035   "RTN","CHF BC1D",57,0 )
  4036    .I (FT="C H")&(PL'<5 ) S (CHMFC LD,CHMFCNL D)=0
  4037   "RTN","CHF BC1D",58,0 )
  4038    E  D  ;SK D 12-31-06 , IDME...A FTER 10-1- 04, there  are only o ne CH Labo r diff and  one CH No n labor di ff regardl ess of geo  location
  4039   "RTN","CHF BC1D",59,0 )
  4040    .I FT="CH " S (CHMFC LD,CHMFCNL D)=0 S RE= $O(^CHMDIC (741002.17 ,1,5,CHMFR SD)),CHMFC LD=$P(^CHM DIC(741002 .17,1,5,RE ,0),"^",2) ,CHMFCNLD= $P(^CHMDIC (741002.17 ,1,5,RE,0) ,"^",3)
  4041   "RTN","CHF BC1D",60,0 )
  4042    ;above 5  lines per  SKD 1-4-07 , IDME
  4043   "RTN","CHF BC1D",61,0 )
  4044    ;
  4045   "RTN","CHF BC1D",62,0 )
  4046    S RE=$O(^ CHMDIC(741 002.16,CHM FDRG,1,CHM FRSD))
  4047   "RTN","CHF BC1D",63,0 )
  4048    I RE="" S  CHMFQUE=1 0,CHMMDP=$ G(CHMMDP)_ ": DRG INF ORMATION I NCOMPLETE"  G END
  4049   "RTN","CHF BC1D",64,0 )
  4050    I '$D(^CH MDIC(74100 2.16,CHMFD RG,1,RE,0) ) S CHMFQU E=10,CHMMD P=$G(CHMMD P)_": DRG  INFORMATIO N INCOMPLE TE" G END
  4051   "RTN","CHF BC1D",65,0 )
  4052    I $D(^CHM DIC(741002 .16,CHMFDR G,1,RE,0))  S DL=^CHM DIC(741002 .16,CHMFDR G,1,RE,0)
  4053   "RTN","CHF BC1D",66,0 )
  4054    S CHMFRWT =$P(DL,"^" ,3),CHMGML OS=$P(DL," ^",4),CHMF SST=$P(DL, "^",5),CHM FLST=$P(DL ,"^",6),CH MCHLST=$P( DL,"^",7), CHMAMLOS=$ P(DL,"^",1 0)
  4055   "RTN","CHF BC1D",67,0 )
  4056   PRC1 I (CH MGMLOS="") !(CHMGMLOS =0) S $P(@ (GLPAY_"CI ,""COMMON" ")"),"^",9 )=3,$P(@(G LPAY_"CI," "COMMON"") "),"^",10) =$P(^CHMDI C(741002.3 4,1,1),"^" ,19),CHMFQ UE=10,CHMM DP=$G(CHMM DP)_": DRG  INFORMATI ON INCOMPL ETE" G END
  4057   "RTN","CHF BC1D",68,0 )
  4058    I FT="CH"  S RE=$O(^ CHMVEN(VI, 11,CHMFRSD )) I (RE'= "") I ($P( ^CHMVEN(VI ,11,RE,0), "^",3)'="" )&($P(^CHM VEN(VI,11, RE,0),"^", 4)'="") S  CHMFCLD=$P (^CHMVEN(V I,11,RE,0) ,"^",3),CH MFCNLD=$P( ^CHMVEN(VI ,11,RE,0), "^",4)
  4059   "RTN","CHF BC1D",69,0 )
  4060    ;;Step 1  = total la bor diff
  4061   "RTN","CHF BC1D",70,0 )
  4062    I FT="CH"  S CHMFLP= CHMFLP+CHM FCLD
  4063   "RTN","CHF BC1D",71,0 )
  4064    ;***ADDED  CHMFDCDT< 3041001 FO R NEW ASA  CALC****
  4065   "RTN","CHF BC1D",72,0 )
  4066    ;I CHMFDC DT<3041001  S CHMFLP= CHMFLP*AW    ;eff 304 1001 AW al ready incl uded in AS A
  4067   "RTN","CHF BC1D",73,0 )
  4068    ;;Step 2= Product 1= step1 * pr ovider wag e index
  4069   "RTN","CHF BC1D",74,0 )
  4070    S CHMFLP= CHMFLP*AW    ;;;;CHEC K
  4071   "RTN","CHF BC1D",75,0 )
  4072    I FT="CH"  S CHMFNLP =CHMFNLP+C HMFCNLD
  4073   "RTN","CHF BC1D",76,0 )
  4074    ;;product  2=product  1+ASA non -labor dif f
  4075   "RTN","CHF BC1D",77,0 )
  4076    ;;Step 3= Base DRG=p roduct 2*D RG weight
  4077   "RTN","CHF BC1D",78,0 )
  4078    S CHMFBRT =CHMFRWT*( CHMFLP+CHM FNLP),$P(@ (GLPAY_"CI ,""COMMON" ")"),"^",1 2)=CHMFBRT
  4079   "RTN","CHF BC1D",79,0 )
  4080    D ^CHFBC1 A G:$D(CHM FQUE) END
  4081   "RTN","CHF BC1D",80,0 )
  4082    D ^CHFBC1 B
  4083   "RTN","CHF BC1D",81,0 )
  4084    ;*** add  IDME and E D COST, 1- 20-05,1-1- 07/skd
  4085   "RTN","CHF BC1D",82,0 )
  4086    I CHMFDCD T<3041001! (CHMFDCDT> 3041000&(+ $G(CHIDMEF )=0)) S CH MFCAA=CHMF CAA*1.12 G  END  ;add  education  factor of  12%, per  IDME, skd  1-1-07        ;JEH 6/ 9/07 ADDED  '+'
  4087   "RTN","CHF BC1D",83,0 )
  4088    I CHMFDCD T>3041000  I $G(CHIDM EF)>0 S CH MFCAA=CHMF CAA*(1+CHI DMEF),CHMF CAA=CHMFCA A*1.1 ;add  IDME and  education  factor of  10%, per I DME, skd 1 -1-07
  4089   "RTN","CHF BC1D",84,0 )
  4090   END I CHGR P=5 S $P(^ CHMPAY(CI, "COMMON"), "^",9)=CHG RP   ;AEB  1/12/2011  DEV011069
  4091   "RTN","CHF BC1D",85,0 )
  4092    K ^TMP("Z SKDVAR","M 1"),^CHMZH OLD("ZSKDD RGVAR") ;t hese kills  can be re moved at a  later poi nt JAK
  4093   "RTN","CHF BC1D",86,0 )
  4094    K CHMFCLD ,CHMFCNLD, CHMFRWT,CH MGMLOS,CHM FSST,CHMFL ST,CHMCHLS T,CHMFLP,C HMFNLP,CHM FDRG
  4095   "RTN","CHF BC1D",87,0 )
  4096    K CHMCNO, CHMCWI,CHI DMEF,CHV80 J,CHVIJ,CH VIK,CHVI,C HMEDNO,CHV IJ,AW,CHMC WI,PL   ;S KD, 1-26-0 6
  4097   "RTN","CHF BC1D",88,0 )
  4098    K CHMCQFG ,CHMEDNO,D SD,CHAWFG
  4099   "RTN","CHF BC1D",89,0 )
  4100    Q
  4101   "RTN","CHF BC1D",90,0 )
  4102    ;
  4103   "RTN","CHF BC1D",91,0 )
  4104   GETIDME  ; for PPS ,s kd 1-24-06 , 6-30-06
  4105   "RTN","CHF BC1D",92,0 )
  4106    K CHMCNO, CHMCWI,CHI DMEF,CHMCQ FG,CHMEDNO ,CHVI,DSD
  4107   "RTN","CHF BC1D",93,0 )
  4108    S CHV80J= "A",CHV80J =$O(^CHMVE N(VI,80,CH V80J),-1)
  4109   "RTN","CHF BC1D",94,0 )
  4110    I 'CHV80J  S CHMFQUE =98,CHMMDP =$G(CHMMDP )_": PROVI DER MEDICA RE NUMBER"  S CHMCQFG ="" Q
  4111   "RTN","CHF BC1D",95,0 )
  4112    S CHMCNO= $P($G(^CHM VEN(VI,80, CHV80J,0)) ,U,2)
  4113   "RTN","CHF BC1D",96,0 )
  4114    S CHMCBDT =$P($G(^CH MVEN(VI,80 ,CHV80J,0) ),U,1)      ;JEH 10/1 5/08 DEF00 5845 ADDED  CHMCBDT
  4115   "RTN","CHF BC1D",97,0 )
  4116    I $G(CHMC NO)="" S C HMFQUE=98, CHMMDP=$G( CHMMDP)_":  PROVIDER  MEDICARE N UMBER" S C HMCQFG=""  Q
  4117   "RTN","CHF BC1D",98,0 )
  4118    ;I $$UPPE R^CHTFLIB( $G(CHMCNO) )="YES" S  CHMFQUE=98 ,CHMMDP=$G (CHMMDP)_" : PROVIDER  MEDICARE  NUMBER" S  CHMCQFG=""  Q
  4119   "RTN","CHF BC1D",99,0 )
  4120    I $$UPPER ^CHTFLIB($ G(CHMCNO)) ="YES" S C HMCNO=9999 99
  4121   "RTN","CHF BC1D",100, 0)
  4122    S CHMEDNO =CHMCNO,CH VI=VI,DSD= CHMFDCDT
  4123   "RTN","CHF BC1D",101, 0)
  4124    ;D GETNEW AW^CHFBC1D    ;JEH 9/ 21/07 ENC0 02877  - N OT USED DU E TO NEW D ATA STORAG E AREA
  4125   "RTN","CHF BC1D",102, 0)
  4126    D GTAWID^ CHFBC1D(CH MCBDT)  ;J EH 9/21/07  ENC002877
  4127   "RTN","CHF BC1D",103, 0)
  4128    I '$G(AW)  S CHMFQUE =10,CHMMDP =$G(CHMMDP )_": PROVI DER WAGE I NDEX" S CH MCQFG="" Q
  4129   "RTN","CHF BC1D",104, 0)
  4130    I $G(CHID MEF)="" S  CHMFQUE=10 ,CHMMDP=$G (CHMMDP)_" : PROVIDER  IDME" S C HMCQFG=""  Q
  4131   "RTN","CHF BC1D",105, 0)
  4132    S CHMCWI= AW
  4133   "RTN","CHF BC1D",106, 0)
  4134    Q
  4135   "RTN","CHF BC1D",107, 0)
  4136    ;
  4137   "RTN","CHF BC1D",108, 0)
  4138   GETNEWAW ; Effective  10-1-04, A SA labor n o longer c alculates
  4139   "RTN","CHF BC1D",109, 0)
  4140    ;based on  geographi cal locati on, but ba sed on pro vider wage  index
  4141   "RTN","CHF BC1D",110, 0)
  4142    ;skd, 6-3 0-06
  4143   "RTN","CHF BC1D",111, 0)
  4144    ;SKD 4-20 -07 DEV001 701-01
  4145   "RTN","CHF BC1D",112, 0)
  4146    S CHAWFG= 0
  4147   "RTN","CHF BC1D",113, 0)
  4148    K CHVIJ,C HVIK,AW,PL ,CHIDMEF
  4149   "RTN","CHF BC1D",114, 0)
  4150    Q:$G(CHME DNO)=""  Q :'$G(CHVI)   Q:'$D(^C HMVEN(CHVI ,400))
  4151   "RTN","CHF BC1D",115, 0)
  4152    S CHVIJ=0 ,CHVIJ=$O( ^CHMVEN(CH VI,400,"B" ,CHMEDNO,C HVIJ)) ;Q: '$G(CHVIJ)
  4153   "RTN","CHF BC1D",116, 0)
  4154    I '$G(CHV IJ) S CHVI J=$O(^CHMV EN(CHVI,40 0,"B",9999 99,0)) Q:' $G(CHVIJ)
  4155   "RTN","CHF BC1D",117, 0)
  4156    D GETAW
  4157   "RTN","CHF BC1D",118, 0)
  4158    I '$G(AW)  S CHVIJ=$ O(^CHMVEN( CHVI,400," B",999999, 0)) Q:'$G( CHVIJ)
  4159   "RTN","CHF BC1D",119, 0)
  4160    D GETAW
  4161   "RTN","CHF BC1D",120, 0)
  4162    Q:'$G(AW)
  4163   "RTN","CHF BC1D",121, 0)
  4164    ;I AW>1 S  PL=2  ;PL =place for  ASA LABOR  in CHAMPV A PAYMENT  PARA file,  1 node ;S KD, IDME,  12-30-06
  4165   "RTN","CHF BC1D",122, 0)
  4166    ;E  S PL= 4
  4167   "RTN","CHF BC1D",123, 0)
  4168    ;
  4169   "RTN","CHF BC1D",124, 0)
  4170    I AW>1 S  PL=9  ;PL= place for  ASA LABOR  in CHAMPVA  PAYMENT P ARA file,  1 node  ;S KD, IDME,  12-30-06
  4171   "RTN","CHF BC1D",125, 0)
  4172    E  S PL=1 1
  4173   "RTN","CHF BC1D",126, 0)
  4174    Q
  4175   "RTN","CHF BC1D",127, 0)
  4176    ;
  4177   "RTN","CHF BC1D",128, 0)
  4178   GETAW ;SKD  4-20-07 D EV001701-0 1
  4179   "RTN","CHF BC1D",129, 0)
  4180    S CHVIK=0
  4181   "RTN","CHF BC1D",130, 0)
  4182    F  S CHVI K=$O(^CHMV EN(CHVI,40 0,CHVIJ,1, CHVIK)) Q: 'CHVIK  Q: $G(CHAWFG)   D
  4183   "RTN","CHF BC1D",131, 0)
  4184    .Q:'$D(^C HMVEN(CHVI ,400,CHVIJ ,1,CHVIK,0 ))
  4185   "RTN","CHF BC1D",132, 0)
  4186    .S CHAWDT B="",CHAWD TE=""
  4187   "RTN","CHF BC1D",133, 0)
  4188    .S CHAWDT B=$P($G(^C HMVEN(CHVI ,400,CHVIJ ,1,CHVIK,0 )),U,1) Q: $G(CHAWDTB )=""
  4189   "RTN","CHF BC1D",134, 0)
  4190    .S CHAWDT E=$P($G(^C HMVEN(CHVI ,400,CHVIJ ,1,CHVIK,0 )),U,2) I  CHAWDTE=""  S CHAWDTE =9999999
  4191   "RTN","CHF BC1D",135, 0)
  4192    .I DSD'<C HAWDTB&(DS D'>CHAWDTE ) D
  4193   "RTN","CHF BC1D",136, 0)
  4194    ..S AW=$P ($G(^CHMVE N(CHVI,400 ,CHVIJ,1,C HVIK,0)),U ,4)
  4195   "RTN","CHF BC1D",137, 0)
  4196    ..S CHIDM EF=$P($G(^ CHMVEN(CHV I,400,CHVI J,1,CHVIK, 0)),U,3)
  4197   "RTN","CHF BC1D",138, 0)
  4198    ..S CHAWF G=1
  4199   "RTN","CHF BC1D",139, 0)
  4200    Q
  4201   "RTN","CHF BC1D",140, 0)
  4202    ;
  4203   "RTN","CHF BC1D",141, 0)
  4204   GTAWID(VNM DBDT) ;JEH  9/21/07 E NC002877    JEH 10/15 /08 ADDED  (VNMDBDT)
  4205   "RTN","CHF BC1D",142, 0)
  4206    K IIVAL,T EFFDT,JJVA L,TENDDT,I DME,WAGE
  4207   "RTN","CHF BC1D",143, 0)
  4208    S:'$D(^CH MDIC(74100 6.07,"B",C HMCNO)) CH MCNO=99999 9    ;BY J EH 5/15/08  ENC002877
  4209   "RTN","CHF BC1D",144, 0)
  4210    I CHMCNO' =999999 D
  4211   "RTN","CHF BC1D",145, 0)
  4212    .S IIVAL= 0 S IIVAL= $O(^CHMDIC (741006.07 ,"B",CHMCN O,IIVAL))  Q:'IIVAL     ;WAGE AN D IDME FRO M PROVIDER  GBL
  4213   "RTN","CHF BC1D",146, 0)
  4214    .S TEFFDT =DSD+1 S T EFFDT=$O(^ CHMDIC(741 006.07,IIV AL,1,"B",T EFFDT),-1)  I 'TEFFDT  S CHMCNO= 999999 Q:' TEFFDT  ;J EH 10/30/0 9 DEF00832 8
  4215   "RTN","CHF BC1D",147, 0)
  4216    .S JJVAL= 0 S JJVAL= $O(^CHMDIC (741006.07 ,IIVAL,1," B",TEFFDT, JJVAL)) Q: 'JJVAL
  4217   "RTN","CHF BC1D",148, 0)
  4218    .S TENDDT =$P(^CHMDI C(741006.0 7,IIVAL,1, JJVAL,0)," ^",2)
  4219   "RTN","CHF BC1D",149, 0)
  4220    .I DSD'<T EFFDT&(DSD '>TENDDT)& (VNMDBDT<= DSD) D
  4221   "RTN","CHF BC1D",150, 0)
  4222    ..S IDME= $P(^CHMDIC (741006.07 ,IIVAL,1,J JVAL,0),"^ ",3)
  4223   "RTN","CHF BC1D",151, 0)
  4224    ..S WAGE= $P(^CHMDIC (741006.07 ,IIVAL,1,J JVAL,0),"^ ",4)
  4225   "RTN","CHF BC1D",152, 0)
  4226    ..S CHAWF G=1
  4227   "RTN","CHF BC1D",153, 0)
  4228    .E  S CHM CNO=999999
  4229   "RTN","CHF BC1D",154, 0)
  4230    I CHMCNO= 999999 D
  4231   "RTN","CHF BC1D",155, 0)
  4232    .;CPE VEN DOR STREAM LINING rep lace Provi der Zip w/  PL-ZIP GE F
  4233   "RTN","CHF BC1D",156, 0)
  4234    .;S TZIPC D=0 S TZIP CD=$E($P(^ CHMVEN(CHV I,2),"^",5 ),1,5)   ; CHM PROV Z IP   ;WAGE  AND IDME  FROM ZIP2W AGE GBL
  4235   "RTN","CHF BC1D",157, 0)
  4236    .S TZIPCD =0 S TZIPC D=$E($P($G (^CHMPAY(C I,"VEN-II" )),"^",15) ,1,5)
  4237   "RTN","CHF BC1D",158, 0)
  4238    .S IIVAL= 0 S IIVAL= $O(^CHMDIC (741006.03 ,"B",TZIPC D,IIVAL))  Q:'IIVAL                  ;ZIP C ODE IDME
  4239   "RTN","CHF BC1D",159, 0)
  4240    .S TEFFDT =DSD+1 S T EFFDT=$O(^ CHMDIC(741 006.03,IIV AL,1,"B",T EFFDT),-1)  Q:'TEFFDT
  4241   "RTN","CHF BC1D",160, 0)
  4242    .S JJVAL= 0 S JJVAL= $O(^CHMDIC (741006.03 ,IIVAL,1," B",TEFFDT, JJVAL)) Q: 'JJVAL
  4243   "RTN","CHF BC1D",161, 0)
  4244    .S TENDDT =$P(^CHMDI C(741006.0 3,IIVAL,1, JJVAL,0)," ^",2)
  4245   "RTN","CHF BC1D",162, 0)
  4246    .I DSD'<T EFFDT&(DSD '>TENDDT)  D
  4247   "RTN","CHF BC1D",163, 0)
  4248    ..S IDME= $P(^CHMDIC (741006.03 ,IIVAL,1,J JVAL,0),"^ ",10)
  4249   "RTN","CHF BC1D",164, 0)
  4250    ..S WAGE= $P(^CHMDIC (741006.03 ,IIVAL,1,J JVAL,0),"^ ",6)
  4251   "RTN","CHF BC1D",165, 0)
  4252    ..S CHAWF G=1
  4253   "RTN","CHF BC1D",166, 0)
  4254    Q:'$G(WAG E)
  4255   "RTN","CHF BC1D",167, 0)
  4256    S AW=WAGE
  4257   "RTN","CHF BC1D",168, 0)
  4258    S CHIDMEF =IDME
  4259   "RTN","CHF BC1D",169, 0)
  4260    ;
  4261   "RTN","CHF BC1D",170, 0)
  4262    I AW>1 S  PL=9  ;PL= place for  ASA LABOR  in CHAMPVA  PAYMENT P ARA file,  1 node  ;S KD, IDME,  12-30-06
  4263   "RTN","CHF BC1D",171, 0)
  4264    E  S PL=1 1
  4265   "RTN","CHF BC1D",172, 0)
  4266    Q
  4267   "RTN","CHF BC1E")
  4268   0^4^B86804 463
  4269   "RTN","CHF BC1E",1,0)
  4270   CHFBC1E ;H AC/CR;BC F OR CTC & I TEMIZED CL AIMS - CVA /SB;Feb 05 , 2019@09: 27:31
  4271   "RTN","CHF BC1E",2,0)
  4272    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  4273   "RTN","CHF BC1E",3,0)
  4274    ;;2.0
  4275   "RTN","CHF BC1E",4,0)
  4276    ;CPTS #11 959 BY DTP  (16-JUL-9 7)
  4277   "RTN","CHF BC1E",5,0)
  4278    ;;DEV0064 21 Automat e Hospice  Payment an d flag cla im as Cost  to Charge
  4279   "RTN","CHF BC1E",6,0)
  4280    ;;(CTC).   Added new  section ( DEV006421)  to check  for hospic e payment  - DRW - 07 /03/12
  4281   "RTN","CHF BC1E",7,0)
  4282    ;BUG00642 1-04-07 or iginally p ulling the  most rece nt wage ra te.  Wage  rate shoul d be date  specific n ot by entr y
  4283   "RTN","CHF BC1E",8,0)
  4284    ;order.   DRW 01/04/ 13.
  4285   "RTN","CHF BC1E",9,0)
  4286    ;DEV02195 6 Modify r outine to  allow for  correct wa ge rate to  be applie d when
  4287   "RTN","CHF BC1E",10,0 )
  4288    ;effectiv e date fal ls on the  same day a s Date Of  Service.   DRW 10/22/ 2014
  4289   "RTN","CHF BC1E",11,0 )
  4290    ;DEV02259 2 JSE 3/3/ 15 - FIX S UBSCRIPT E RROR (@ HO SPCALC+11)
  4291   "RTN","CHF BC1E",12,0 )
  4292    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  4293   "RTN","CHF BC1E",13,0 )
  4294    ;
  4295   "RTN","CHF BC1E",14,0 )
  4296   CTC S XS=0 ,FLGHOSP=0 ,CHMSPC="" ,CHMSVC=""
  4297   "RTN","CHF BC1E",15,0 )
  4298    G ITMII:$ P(@(GLPAY_ "CI,""INP" ")"),"^",5 )=1
  4299   "RTN","CHF BC1E",16,0 )
  4300    I $D(@(GL PAY_"CI,"" INP-NC"")" )) S L=0 F   S L=$O(@ (GLPAY_"CI ,""INP-NC" ",L)")) Q: L'?1N.N  D  NC
  4301   "RTN","CHF BC1E",17,0 )
  4302    D HOSPD1                          ;;added  this for D EV006421
  4303   "RTN","CHF BC1E",18,0 )
  4304    G CTC2
  4305   "RTN","CHF BC1E",19,0 )
  4306   NC ;SUBTRA CTS ALL NO N COVERED/ ITEMS FROM  CHMFCHGS
  4307   "RTN","CHF BC1E",20,0 )
  4308    S IN=$P(^ (L,0),"^")
  4309   "RTN","CHF BC1E",21,0 )
  4310    ; REMOVE  FOLLOWING  7 LINES WH EN FILE IS  UPDATED T O REMOVE T HESE ITEMS
  4311   "RTN","CHF BC1E",22,0 )
  4312    Q:'$D(^CH MDIC(74100 2.09,IN,0) )
  4313   "RTN","CHF BC1E",23,0 )
  4314    Q:$P(^CHM DIC(741002 .09,IN,0), "^")="ANES THESIOLOGI ST"
  4315   "RTN","CHF BC1E",24,0 )
  4316    Q:$P(^CHM DIC(741002 .09,IN,0), "^")="PROF . COMPONEN T"
  4317   "RTN","CHF BC1E",25,0 )
  4318    Q:$P(^CHM DIC(741002 .09,IN,0), "^")="NON- PHYS ANEST HETIST"
  4319   "RTN","CHF BC1E",26,0 )
  4320    Q:$P(^CHM DIC(741002 .09,IN,0), "^")="OTHE R"
  4321   "RTN","CHF BC1E",27,0 )
  4322    Q:$P(^CHM DIC(741002 .09,IN,0), "^")="ER R OOM CHARGE S"
  4323   "RTN","CHF BC1E",28,0 )
  4324    Q:$P(^CHM DIC(741002 .09,IN,0), "^")="EYE  BANK CHARG ES"
  4325   "RTN","CHF BC1E",29,0 )
  4326    Q:$P(^CHM DIC(741002 .09,IN,0), "^")="DAY  PASS DAYS"
  4327   "RTN","CHF BC1E",30,0 )
  4328    I $P(^CHM DIC(741002 .09,IN,0), "^")="PERS ONAL ITEMS " D
  4329   "RTN","CHF BC1E",31,0 )
  4330    .S CHMFCH GS=CHMFCHG S-$P(@(GLP AY_"CI,""I NP-NC"",L, 0)"),"^",2 ),$P(@(GLP AY_"CI,""I NP-NC"",L, 0)"),"^",4 )=0 D STRE AS Q
  4331   "RTN","CHF BC1E",32,0 )
  4332    I $P(^CHM DIC(741002 .09,IN,0), "^")="TAKE  HOME ITEM S" S CHMFC HGS=CHMFCH GS-$P(@(GL PAY_"CI,"" INP-NC"",L ,0)"),"^", 2),$P(@(GL PAY_"CI,"" INP-NC"",L ,0)"),"^", 4)=0 Q
  4333   "RTN","CHF BC1E",33,0 )
  4334    I $P(^CHM DIC(741002 .09,IN,0), "^")="BIRT H/NO NURSE RY" S CHMF CHGS=CHMFC HGS-$P(@(G LPAY_"CI," "INP-NC"", L,0)"),"^" ,2),$P(@(G LPAY_"CI," "INP-NC"", L,0)"),"^" ,4)=0 D
  4335   "RTN","CHF BC1E",34,0 )
  4336    .S $P(@(G LPAY_"CI,0 )"),"^",13 )=145 Q
  4337   "RTN","CHF BC1E",35,0 )
  4338    S CHMFCHG S=CHMFCHGS -$P(@(GLPA Y_"CI,""IN P-NC"",L,0 )"),"^",2) ,XS=XS+$P( @(GLPAY_"C I,""INP-NC "",L,0)"), "^",2),$P( @(GLPAY_"C I,""INP-NC "",L,0)"), "^",4)=$P( @(GLPAY_"C I,""INP-NC "",L,0)"), "^",2)
  4339   "RTN","CHF BC1E",36,0 )
  4340    Q
  4341   "RTN","CHF BC1E",37,0 )
  4342   ITMII S $P (@(GLPAY_" CI,""COMMO N"")"),"^" ,16)=2
  4343   "RTN","CHF BC1E",38,0 )
  4344    S CHMFEE= $P(@(GLPAY _"CI,""INP "")"),"^", 6) S:CHMFE E="" CHMFE E=$P(@(GLP AY_"CI,""I NP"")"),"^ ",1)
  4345   "RTN","CHF BC1E",39,0 )
  4346    S CHMFBE= $P(@(GLPAY _"CI,""INP "")"),"^", 9) S:CHMFB E="" CHMFB E=$P(REC0, "^",8)
  4347   "RTN","CHF BC1E",40,0 )
  4348    S LL=0 F   S LL=$O(@ (GLPAY_"CI ,""INP-ITE M"",LL)"))  Q:LL'?1N. N  D CKP
  4349   "RTN","CHF BC1E",41,0 )
  4350    G:$D(CHMF QUE) END
  4351   "RTN","CHF BC1E",42,0 )
  4352    S (CHMFCH GS,LL)=0 F   S LL=$O( @(GLPAY_"C I,""INP-IT EM"",LL)") ) Q:LL'?1N .N  D I2
  4353   "RTN","CHF BC1E",43,0 )
  4354    G CTC2
  4355   "RTN","CHF BC1E",44,0 )
  4356   I2 I (CHMF EE<$P(@(GL PAY_"CI,"" INP-ITEM"" ,LL,0)")," ^")) S $P( @(GLPAY_"C I,""INP-IT EM"",LL,0) "),"^",5)= 0 Q
  4357   "RTN","CHF BC1E",45,0 )
  4358    I (CHMFBE >$P(@(GLPA Y_"CI,""IN P-ITEM"",L L,0)"),"^" )) S $P(@( GLPAY_"CI, ""INP-ITEM "",LL,0)") ,"^",5)=0  Q
  4359   "RTN","CHF BC1E",46,0 )
  4360    S IT=$P(@ (GLPAY_"CI ,""INP-ITE M"",LL,0)" ),"^",2)
  4361   "RTN","CHF BC1E",47,0 )
  4362    I (IT=4), ($P(@(GLPA Y_"CI,""IN P-ITEM"",L L,0)"),"^" ,4)="") S  CHMFCHGS=C HMFCHGS+$P (@(GLPAY_" CI,""INP-I TEM"",LL,0 )"),"^",3) ,$P(@(GLPA Y_"CI,""IN P-ITEM"",L L,0)"),"^" ,5)=$P(@(G LPAY_"CI," "INP-ITEM" ",LL,0)"), "^",3) Q
  4363   "RTN","CHF BC1E",48,0 )
  4364    I (IT=4), ($P(@(GLPA Y_"CI,""IN P-ITEM"",L L,0)"),"^" ,4)'="") I  $P(@(GLPA Y_"CI,""RU LE-PROC"", LL,0)"),"^ ")=1 S CHM FCHGS=CHMF CHGS+$P(@( GLPAY_"CI, ""INP-ITEM "",LL,0)") ,"^",3),$P (@(GLPAY_" CI,""INP-I TEM"",LL,0 )"),"^",5) =$P(^(LL,0 ),"^",3) Q
  4365   "RTN","CHF BC1E",49,0 )
  4366    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="PERS ONAL ITEMS ") S $P(@( GLPAY_"CI, ""INP-ITEM "",LL,0)") ,"^",5)=0  Q
  4367   "RTN","CHF BC1E",50,0 )
  4368    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="TAKE  HOME ITEM S") S $P(@ (GLPAY_"CI ,""INP-ITE M"",LL,0)" ),"^",5)=0  Q
  4369   "RTN","CHF BC1E",51,0 )
  4370    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="DAY  PASS DAYS" ) S $P(@(G LPAY_"CI," "INP-ITEM" ",LL,0)"), "^",5)=0 Q
  4371   "RTN","CHF BC1E",52,0 )
  4372    ;REMOVE F OLLOWING 7  LINES WHE N FILE HAS  BEEN UPDA TED
  4373   "RTN","CHF BC1E",53,0 )
  4374    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="PROF . COMPONEN T") S $P(@ (GLPAY_"CI ,""INP-ITE M"",LL,0)" ),"^",5)=0  Q
  4375   "RTN","CHF BC1E",54,0 )
  4376    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="EYE  BANK CHARG ES") S $P( @(GLPAY_"C I,""INP-IT EM"",LL,0) "),"^",5)= 0 Q
  4377   "RTN","CHF BC1E",55,0 )
  4378    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="ER R OOM CHARGE S") S $P(@ (GLPAY_"CI ,""INP-ITE M"",LL,0)" ),"^",5)=0  Q
  4379   "RTN","CHF BC1E",56,0 )
  4380    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="OTHE R") S $P(@ (GLPAY_"CI ,""INP-ITE M"",LL,0)" ),"^",5)=0  Q
  4381   "RTN","CHF BC1E",57,0 )
  4382    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="ANES THESIOLOGI ST") S $P( @(GLPAY_"C I,""INP-IT EM"",LL,0) "),"^",5)= 0 Q
  4383   "RTN","CHF BC1E",58,0 )
  4384    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="NON- PHYS ANEST HETIST") S  $P(@(GLPA Y_"CI,""IN P-ITEM"",L L,0)"),"^" ,5)=0 Q
  4385   "RTN","CHF BC1E",59,0 )
  4386    I (IT'="" ),($P(^CHM DIC(741002 .09,IT,0), "^")="BIRT H/NO NURSE RY") S $P( @(GLPAY_"C I,""INP-IT EM"",LL,0) "),"^",5)= 0 D
  4387   "RTN","CHF BC1E",60,0 )
  4388    .S $P(@(G LPAY_"CI,0 )"),"^",13 )=145 Q
  4389   "RTN","CHF BC1E",61,0 )
  4390    I (IT'="" ),($D(@(GL PAY_"CI,"" RULE-PROC" ",LL,0)")) ) S:($P(@( GLPAY_"CI, ""RULE-PRO C"",LL,0)" ),"^",1)=1 ) XS=XS+$P (@(GLPAY_" CI,""INP-I TEM"",LL,0 )"),"^",3) ,$P(@(GLPA Y_"CI,""IN P-ITEM"",L L,0)"),"^" ,5)=$P(@(G LPAY_"CI," "INP-ITEM" ",LL,0)"), "^",3) Q
  4391   "RTN","CHF BC1E",62,0 )
  4392    I (IT'="" ) S XS=XS+ $P(@(GLPAY _"CI,""INP -ITEM"",LL ,0)"),"^", 3),$P(@(GL PAY_"CI,"" INP-ITEM"" ,LL,0)")," ^",5)=$P(@ (GLPAY_"CI ,""INP-ITE M"",LL,0)" ),"^",3) Q
  4393   "RTN","CHF BC1E",63,0 )
  4394    I IT="" S  CHMFCHGS= CHMFCHGS+$ P(@(GLPAY_ "CI,""INP- ITEM"",LL, 0)"),"^",3 ),$P(@(GLP AY_"CI,""I NP-ITEM"", LL,0)"),"^ ",5)=$P(@( GLPAY_"CI, ""INP-ITEM "",LL,0)") ,"^",3)
  4395   "RTN","CHF BC1E",64,0 )
  4396    E  S $P(@ (GLPAY_"CI ,""INP-ITE M"",LL,0)" ),"^",5)=0
  4397   "RTN","CHF BC1E",65,0 )
  4398    Q
  4399   "RTN","CHF BC1E",66,0 )
  4400   CKP Q:(CHM FEE<$P(@(G LPAY_"CI," "INP-ITEM" ",LL,0)"), "^"))
  4401   "RTN","CHF BC1E",67,0 )
  4402    Q:(CHMFBE >$P(@(GLPA Y_"CI,""IN P-ITEM"",L L,0)"),"^" ))
  4403   "RTN","CHF BC1E",68,0 )
  4404    S IT=$P(@ (GLPAY_"CI ,""INP-ITE M"",LL,0)" ),"^",2)
  4405   "RTN","CHF BC1E",69,0 )
  4406    Q:(IT'=4)
  4407   "RTN","CHF BC1E",70,0 )
  4408    Q:$P(@(GL PAY_"CI,"" INP-ITEM"" ,LL,0)")," ^",4)=""
  4409   "RTN","CHF BC1E",71,0 )
  4410    S CHMFPRO C=$P(@(GLP AY_"CI,""I NP-ITEM"", LL,0)"),"^ ",4) D
  4411   "RTN","CHF BC1E",72,0 )
  4412    .S:$D(^CH MSERV(CHMF PROC,102,C HPGPT,0))  AHTS=$P(^( 0),"^",2)
  4413   "RTN","CHF BC1E",73,0 )
  4414    .I '$D(AH TS) S CHPG PTI=0,CHPG PTI=$O(^CH MDIC(74100 2.94,"C"," CHAMPVA",0 )) S:$D(^C HMSERV(CHM FPROC,102, CHPGPTI,0) ) AHTS=$P( ^(0),"^",2 )
  4415   "RTN","CHF BC1E",74,0 )
  4416    I '$D(AHT S) S CHMFQ UE=7,CHMMD P=CHMMDP_" : NO TEST" ,$P(@(GLPA Y_"CI,""RU LE-PROC"", LL,0)"),"^ ",2)=$P(^C HMDIC(7410 02.34,1,1) ,"^",12),$ P(@(GLPAY_ "CI,""RULE -PROC"",LL ,0)"),"^") =3 Q
  4417   "RTN","CHF BC1E",75,0 )
  4418    I AHTS=""  S CHMFQUE =7,CHMMDP= CHMMDP_":  NO TEST",$ P(@(GLPAY_ "CI,""RULE -PROC"",LL ,0)"),"^", 2)=$P(^CHM DIC(741002 .34,1,1)," ^",12),$P( @(GLPAY_"C I,""RULE-P ROC"",LL,0 )"),"^")=3  Q
  4419   "RTN","CHF BC1E",76,0 )
  4420    I '$D(^DI C(AHFILE,A HTS,0)) S  CHMFQUE=7, CHMMDP=CHM MDP_": INC OMPLETE DR G INFORMAT ION",$P(@( GLPAY_"CI, ""RULE-PRO C"",LL,0)" ),"^",2)=$ P(^CHMDIC( 741002.34, 1,1),"^",1 2),$P(@(GL PAY_"CI,"" RULE-PROC" ",LL,0)"), "^")=3 Q
  4421   "RTN","CHF BC1E",77,0 )
  4422    S LLL=LL  D ^AHCJAE  S LL=LLL S  $P(@(GLPA Y_"CI,""RU LE-PROC"", LL,0)"),"^ ",2)=AHDAT A(AHSTV,1) ,RN=$O(^DI C(AHNODIC, "B","REASO N",0))
  4423   "RTN","CHF BC1E",78,0 )
  4424    I $D(AHDA TA(RN,1))  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,LL,0)")," ^",2)=AHDA TA(RN,1)
  4425   "RTN","CHF BC1E",79,0 )
  4426    S $P(@(GL PAY_"CI,"" RULE-PROC" ",LL,0)"), "^",3)=AHL TS
  4427   "RTN","CHF BC1E",80,0 )
  4428    S:(AHDATA (AHSTV,1)= 2)!(AHDATA (AHSTV,1)= 4) CHMFQUE =5
  4429   "RTN","CHF BC1E",81,0 )
  4430    I AHDATA( AHSTV,1)=3  S:'$D(CHM FQUE) CHMF QUE=6,CHMM DP=CHMMDP_ ": FROM TE ST"
  4431   "RTN","CHF BC1E",82,0 )
  4432    I AHDATA( AHSTV,1)=- 1 S CHMFQU E=18
  4433   "RTN","CHF BC1E",83,0 )
  4434    Q
  4435   "RTN","CHF BC1E",84,0 )
  4436   CTC2 ;
  4437   "RTN","CHF BC1E",85,0 )
  4438    I $G(HOSP FLG2) > 0  G END
  4439   "RTN","CHF BC1E",86,0 )
  4440    S RE=$O(^ CHMDIC(741 002.17,1,2 1,CHMFRSD) )
  4441   "RTN","CHF BC1E",87,0 )
  4442    I RE="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": C OST-TO-CHA RGE RATIO"  G END
  4443   "RTN","CHF BC1E",88,0 )
  4444    ;Followin g line add ed 1/13/93  by CR  CH MACTC is M aryland pe rcent
  4445   "RTN","CHF BC1E",89,0 )
  4446    ;as defin ed in CHFB C1
  4447   "RTN","CHF BC1E",90,0 )
  4448    S:'$D(CHM ACTC) CHMA CTC=$P(^CH MDIC(74100 2.17,1,21, RE,0),"^", 2)
  4449   "RTN","CHF BC1E",91,0 )
  4450    S CHMFCAA =+$FN(((CH MFCHGS*(CH MACTC/100) )+XS),"",2 )
  4451   "RTN","CHF BC1E",92,0 )
  4452   END K CHMF BE,CHMFEE, AWI,PS,EC, XS,IN,IT,P C
  4453   "RTN","CHF BC1E",93,0 )
  4454       K FLGH OSP,CHMSPC ,CHMSVC
  4455   "RTN","CHF BC1E",94,0 )
  4456       Q
  4457   "RTN","CHF BC1E",95,0 )
  4458   STREAS S C HREAS=$P(^ CHMDIC(741 002.34,1,3 ),"^",11)  I CHREAS'= "" D
  4459   "RTN","CHF BC1E",96,0 )
  4460    .S:'$D(@( GLPAY_"CI, 4,0)")) @( GLPAY_"CI, 4,0)")="^7 41000.701P ^0^0"
  4461   "RTN","CHF BC1E",97,0 )
  4462    .S CHMNEX T=$P(@(GLP AY_"CI,4,0 )"),"^",3) ,CHMNEXT=C HMNEXT+1,$ P(@(GLPAY_ "CI,4,0)") ,"^",3)=CH MNEXT
  4463   "RTN","CHF BC1E",98,0 )
  4464    .S @(GLPA Y_"CI,4,CH MNEXT,0)") =CHREAS
  4465   "RTN","CHF BC1E",99,0 )
  4466    .S @(GLPA Y_"CI,4,"" B"",CHREAS ,CHMNEXT)" )=""
  4467   "RTN","CHF BC1E",100, 0)
  4468    .K CHREAS ,CHMNEXT
  4469   "RTN","CHF BC1E",101, 0)
  4470    Q
  4471   "RTN","CHF BC1E",102, 0)
  4472   HOSPD1  ;; DEV006421  first leve l call
  4473   "RTN","CHF BC1E",103, 0)
  4474    S NM=0,HO SPFLG2=0
  4475   "RTN","CHF BC1E",104, 0)
  4476    I '$D(^CH MPAY(CI,"I NP-PROC"))  G BYPASS
  4477   "RTN","CHF BC1E",105, 0)
  4478   LOOP1 ;
  4479   "RTN","CHF BC1E",106, 0)
  4480    S FLGHOSP =0
  4481   "RTN","CHF BC1E",107, 0)
  4482    S NM=$O(^ CHMPAY(CI, "INP-PROC" ,NM)) G:NM '?1N.N BYP ASS
  4483   "RTN","CHF BC1E",108, 0)
  4484    S CHMSPC= $P(^CHMPAY (CI,"INP-P ROC",NM,0) ,"^",1)     ;;determi ne if ther e is a pro cedure cod e
  4485   "RTN","CHF BC1E",109, 0)
  4486    I CHMSPC= ""  G BYPA SS                                ;;quit wh en there i s no proce dure code
  4487   "RTN","CHF BC1E",110, 0)
  4488    S CHMSVC= $P(^CHMSER V(CHMSPC,0 ),"^",1)               ;;find se rvice code
  4489   "RTN","CHF BC1E",111, 0)
  4490    I CHMSVC= "00.00" S  FLGHOSP=1, HOSPFLG2=1             ;;check s ervice aga inst inpat ient hospi ce valid c odes
  4491   "RTN","CHF BC1E",112, 0)
  4492    I CHMSVC= "00.99" S  FLGHOSP=1, HOSPFLG2=1
  4493   "RTN","CHF BC1E",113, 0)
  4494    I FLGHOSP >0 D HOSPC ALC G LOOP 1
  4495   "RTN","CHF BC1E",114, 0)
  4496   BYPASS  ;
  4497   "RTN","CHF BC1E",115, 0)
  4498    Q
  4499   "RTN","CHF BC1E",116, 0)
  4500   HOSPCALC    ;;DEV0064 21 second  level call
  4501   "RTN","CHF BC1E",117, 0)
  4502    N IEN,NM1 ,CBSA,CBSA IEN,CBSAIE N1,CBSANM, CBSANM1,CB SAWC,CBSAN WA,CBSAWG, CBSAENT,CB SAENT1         ;;DEV0 06421 new  variables  added for  this secti on
  4503   "RTN","CHF BC1E",118, 0)
  4504    N HOSPAMT ,EFFDT
  4505   "RTN","CHF BC1E",119, 0)
  4506    ;CPE VEND OR STREAML INING repl ace Provid er Zip w/  PL-ZIP gef
  4507   "RTN","CHF BC1E",120, 0)
  4508    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G BYPAS S1
  4509   "RTN","CHF BC1E",121, 0)
  4510    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  4511   "RTN","CHF BC1E",122, 0)
  4512    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G BYPASS1
  4513   "RTN","CHF BC1E",123, 0)
  4514    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  4515   "RTN","CHF BC1E",124, 0)
  4516    I VZ="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP MISS ING" G BYP ASS1
  4517   "RTN","CHF BC1E",125, 0)
  4518    S IEN=$O( ^CHMDIC(74 1006.03,"B ",VZ,0))    ;;find th e IEN for  the CBSA c rosswalk b ased on zi p
  4519   "RTN","CHF BC1E",126, 0)
  4520    ;
  4521   "RTN","CHF BC1E",127, 0)
  4522    ;;DEV0225 92 JSE 3/3 /15 WAGE R ATE NEVER  SET CORREC TLY B/C NM 1 WAS NEVE R SET TO T HE CORRECT  DIC LOOKU P
  4523   "RTN","CHF BC1E",128, 0)
  4524    ;;                       COMMEN T OUT HOW  NM1 WAS OR IGINALY SE T & THE AT TEMPTED FI X FROM DEV 021956 (BE LOW)
  4525   "RTN","CHF BC1E",129, 0)
  4526    ;S NM1=$O (^CHMDIC(7 41006.03,I EN,1,CHMFD CDT),-1)                               ;; O RIG CODE I NCORRECT,  CAUSING SU BSCRIPT ER RS
  4527   "RTN","CHF BC1E",130, 0)
  4528    ;CHECKDT;  IF DOS IS  NOT CHECK ED, THE IE N ABOVE MA Y NOT BE T HE CORRECT  CBSA ;; D EV021956 D RW 11/06/2 014                                                          ;;DE V021956 DR W 11/06/20 14
  4529   "RTN","CHF BC1E",131, 0)
  4530    ;S EFFDT= $P(^CHMDIC (741006.03 ,IEN,1,NM1 ,0),"^",1)                             ;; D EV021956 D RW 11/06/2 014
  4531   "RTN","CHF BC1E",132, 0)
  4532    ;I CHMFDC DT<EFFDT S  NM1=NM1-1  G CHECKDT    ;;LOOP  THROUGH UN TIL DOS IS  NO LONGER  LESS THAN  EFFECTIVE  DATE
  4533   "RTN","CHF BC1E",133, 0)
  4534    ;
  4535   "RTN","CHF BC1E",134, 0)
  4536    ;;DEV0225 92 JSE - N EW LOGIC(B ELOW) CORR ECTLY SETS  NM1. THIS  LOGIC REP LACE THE L OGIC ABOVE .
  4537   "RTN","CHF BC1E",135, 0)
  4538    I $D(^CHM DIC(741006 .03,IEN,1, "B",CHMFDC DT)) S CHM FDCDT2=CHM FDCDT  ;;  DEV022592  JSE - IF D OS HAS AN  ENTRY USE  DOS DATE
  4539   "RTN","CHF BC1E",136, 0)
  4540    E  S CHMF DCDT2=$O(^ CHMDIC(741 006.03,IEN ,1,"B",CHM FDCDT),-1)        ;;  DEV022592  JSE - IF N O DOS ENTR Y, USE DAT E B4 DOS
  4541   "RTN","CHF BC1E",137, 0)
  4542    I CHMFDCD T2="" S CH MFDCDT2=$O (^CHMDIC(7 41006.03,I EN,1,"B",0 ))     ;;  DEV022592  JSE - IF D OS IS B4 1 ST ENT, SE T NM1=1ST  ENT
  4543   "RTN","CHF BC1E",138, 0)
  4544    S NM1=$O( ^CHMDIC(74 1006.03,IE N,1,"B",CH MFDCDT2,"" ))                ;;  DEV022592  JSE - SET  NM1 TO ENT RY# 4 SELE CTED DATE
  4545   "RTN","CHF BC1E",139, 0)
  4546    ;
  4547   "RTN","CHF BC1E",140, 0)
  4548    S CBSA=$P (^CHMDIC(7 41006.03,I EN,1,NM1,0 ),"^",5)
  4549   "RTN","CHF BC1E",141, 0)
  4550    ;;once th e CBSA is  found, use  the CBSA  to find th e wage ind ex on glob al ^CHMDIC (741043
  4551   "RTN","CHF BC1E",142, 0)
  4552    S CBSAIEN =$O(^CHMDI C(741043," B",CBSA,0) )
  4553   "RTN","CHF BC1E",143, 0)
  4554    ;S CBSANM =$O(^CHMDI C(741043,C BSAIEN,1," B",CHADOS) ,-1)              ;;  Find the l ast entry  close to t he DOS (re verse orde r)
  4555   "RTN","CHF BC1E",144, 0)
  4556    I $D(^CHM DIC(741043 ,CBSAIEN,1 ,"B",CHMFD CDT)) S CB SANM=CHMFD CDT    ;;  DEV021956  DRW - ADDE D IF/ELSE  FOR EFFECT IVE DATE
  4557   "RTN","CHF BC1E",145, 0)
  4558    E  S CBSA NM=$O(^CHM DIC(741043 ,CBSAIEN,1 ,"B",CHMFD CDT),-1)          ;;  DEV021956  Find last  entry clos est to DOS  (rev. ord er))
  4559   "RTN","CHF BC1E",146, 0)
  4560    I CBSANM= "" S CBSAN M=$O(^CHMD IC(741043, CBSAIEN,1, "B",CHMFDC DT))
  4561   "RTN","CHF BC1E",147, 0)
  4562    S CBSAENT =$O(^CHMDI C(741043,C BSAIEN,1," B",CBSANM, 0))               ;;f ind the ph ysical loc ation of t he entry n umber
  4563   "RTN","CHF BC1E",148, 0)
  4564    S CBSAWG= $P(^CHMDIC (741043,CB SAIEN,1,CB SAENT,0)," ^",6)             ;;w age index  rate for t he hospice  claim
  4565   "RTN","CHF BC1E",149, 0)
  4566    ;;once th e CBSAWG i s found, u se the for mula rate  associated  with the  service co de in
  4567   "RTN","CHF BC1E",150, 0)
  4568    ;;global  ^CHMDIC(74 1045 to de termine th e hospice  per diem r ate
  4569   "RTN","CHF BC1E",151, 0)
  4570    S CBSAIEN 1=$O(^CHMD IC(741045, "B",CHMSVC ,0))
  4571   "RTN","CHF BC1E",152, 0)
  4572    ;S CBSANM 1=$O(^CHMD IC(741045, CBSAIEN1,1 ,"B",CHMFD CDT))
  4573   "RTN","CHF BC1E",153, 0)
  4574    I $D(^CHM DIC(741045 ,CBSAIEN1, 1,"B",CHMF DCDT)) S C BSANM1=CHM FDCDT  ;;D EV021956/D RW ADDED I F/ELSE FOR  EFFECTIVE  DATE
  4575   "RTN","CHF BC1E",154, 0)
  4576    E  S CBSA NM1=$O(^CH MDIC(74104 5,CBSAIEN1 ,1,"B",CHM FDCDT),-1)
  4577   "RTN","CHF BC1E",155, 0)
  4578    I CBSANM1 ="" S CBSA NM1=$O(^CH MDIC(74104 5,CBSAIEN1 ,1,"B",CHM FDCDT))
  4579   "RTN","CHF BC1E",156, 0)
  4580    S CBSAENT 1=$O(^CHMD IC(741045, CBSAIEN1,1 ,"B",CBSAN M1,0))            ;;f ine the en try number  for that  date
  4581   "RTN","CHF BC1E",157, 0)
  4582    S CBSAWC= $P(^CHMDIC (741045,CB SAIEN1,1,C BSAENT1,0) ,"^",4)           ;;f ind the wa ge compone nt
  4583   "RTN","CHF BC1E",158, 0)
  4584    S CBSANWA =$P(^CHMDI C(741045,C BSAIEN1,1, CBSAENT1,0 ),"^",5)          ;;f ind the no n-weighted  amount
  4585   "RTN","CHF BC1E",159, 0)
  4586    S HOSPAMT =(CBSAWC*C BSAWG)+CBS ANWA                          ;; multiply w age compon ent by the  CBSA inde x + non-wi eghted amt
  4587   "RTN","CHF BC1E",160, 0)
  4588    S HOSPAMT =$FN(HOSPA MT,"",2)                                 ;; the $FN fu nction rou nds & sets  to two de cimal plac es
  4589   "RTN","CHF BC1E",161, 0)
  4590    S HOSPAMT =HOSPAMT*C HMFLOS
  4591   "RTN","CHF BC1E",162, 0)
  4592    S CHMFCAA =+HOSPAMT                                           ;; updates th e calculat ed allowab le amount
  4593   "RTN","CHF BC1E",163, 0)
  4594   BYPASS1 ;
  4595   "RTN","CHF BC1E",164, 0)
  4596    Q
  4597   "RTN","CHF BC2A")
  4598   0^5^B28422 7801
  4599   "RTN","CHF BC2A",1,0)
  4600   CHFBC2A ;H AC/CR;GETS  ALLOWABLE  AMOUNTS F OR OP PROC ;Feb 05, 2 019@09:29: 06
  4601   "RTN","CHF BC2A",2,0)
  4602    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  4603   "RTN","CHF BC2A",3,0)
  4604    ;CPTS #10 846*, 1123 3*, #11736 * (DTP,4-2 3-97)
  4605   "RTN","CHF BC2A",4,0)
  4606    ;CPTS #10 292*, 7/8/ 97 *CR*
  4607   "RTN","CHF BC2A",5,0)
  4608    ;CPTS #11 937*  7/11 /97 *CR*
  4609   "RTN","CHF BC2A",6,0)
  4610    ;CPTS #62 98 7/15/97  *CR*
  4611   "RTN","CHF BC2A",7,0)
  4612    ;CPTS #13 733 BY DTP  (13-FEB-9 8)*
  4613   "RTN","CHF BC2A",8,0)
  4614    ;CPTS #14 619 BY JLR *
  4615   "RTN","CHF BC2A",9,0)
  4616    ;CPTS #14 051 BY JLR  (20-JUL-9 8)*
  4617   "RTN","CHF BC2A",10,0 )
  4618    ;CPTS #16 182 (Y2K)  - fixed FN  number fo r prevaili ng fee glo bal - CHMS PF
  4619   "RTN","CHF BC2A",11,0 )
  4620    ;CPTS #16 336 BY DTP  (26-MAR-9 9)*
  4621   "RTN","CHF BC2A",12,0 )
  4622    ;CR MC215  JEH 8/21/ 06 - Modif ied to acc ept new CM AC file fo rmat
  4623   "RTN","CHF BC2A",13,0 )
  4624    ;TT DEF00 4574  JEH  3/25/08 -  Remove fac ility/non- facility c alls to gl obal ^IBE( 353.1 from  CHV routi nes
  4625   "RTN","CHF BC2A",14,0 )
  4626    ;TT ENC00 4843: JEH  2/13/09 -  Payment of  CPT codes  requiring  TC or 26  modifier
  4627   "RTN","CHF BC2A",15,0 )
  4628    ;TT DEF00 8917  JAK  03/31/10 -  Prevailin g rate iss ue on DME  - HAC usag e of CMS D MEPOS fee  schedule o n DMEs
  4629   "RTN","CHF BC2A",16,0 )
  4630    ;DEF00924 8-03 DPT 4 /08/10 edi t range of  dates for  begin and  terminal  dates,BUG0 09248-03,0 4,05
  4631   "RTN","CHF BC2A",17,0 )
  4632    ;;DEV0064 21 DRW 06/ 11/12 - ad ded Hospic e Payment  requiremen ts to calc ulate Hosp ice per di em rate ba sed on CBS A and
  4633   "RTN","CHF BC2A",18,0 )
  4634    ;;type of  service ( outpatient  or inpati ent)  GLOB AL -- 7410 06.03 (CBS A cross wa lk)
  4635   "RTN","CHF BC2A",19,0 )
  4636    ;BUG00642 1-04-07 or iginally p ulling the  most rece nt wage ra te.  Wage  rate shoul d be date  specific n ot by entr y
  4637   "RTN","CHF BC2A",20,0 )
  4638    ;order.   DRW 01/04/ 13.
  4639   "RTN","CHF BC2A",21,0 )
  4640    ;DEF01676 3 DPT 4/28 /14 - REJE CT 196 IF  DOS IS OUT SIDE DATE  RANGE FOR  CODES
  4641   "RTN","CHF BC2A",22,0 )
  4642    ;BUG01676 3 DPT 4/30 /14 - CORR ECT BUG
  4643   "RTN","CHF BC2A",23,0 )
  4644    ;DEV00465 1 2/11/14  EW - FLAG  ADDED SO C MAC CALC C AN BE USED  FOR WIP R EPORT
  4645   "RTN","CHF BC2A",24,0 )
  4646    ;Warning  CHFBC2 and  CHFBC2D m ust have t he above c hange pres ent if thi s routine  has the ch ange
  4647   "RTN","CHF BC2A",25,0 )
  4648    ;DEV02195 6 Modify r outine to  allow for  correct wa ge rate to  be applie d when
  4649   "RTN","CHF BC2A",26,0 )
  4650    ;effectiv e date fal ls on the  same day a s Date Of  Service.   DRW 10/22/ 2014
  4651   "RTN","CHF BC2A",27,0 )
  4652    ;DEV02259 2 JSE 3/3/ 15 - FIX S UBSCRIPT E RROR (NEXT +11)
  4653   "RTN","CHF BC2A",28,0 )
  4654    ;DEV02563 3 RFE 6/30 /16 Correc t subscrip t error in  GETMOD
  4655   "RTN","CHF BC2A",29,0 )
  4656    ;nsd I184 39016FY18  - dpt 1/24 /18
  4657   "RTN","CHF BC2A",30,0 )
  4658    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  4659   "RTN","CHF BC2A",31,0 )
  4660    ;CFS 03/2 2/18 CPE00 1-119 Fix  Undefined  error caus ed by a Na ked Global  Reference .
  4661   "RTN","CHF BC2A",32,0 )
  4662    ;BDB 04/1 2/18 Redef ine CHGRDT 1 for subs cript erro r, add ser vice code  range chec k
  4663   "RTN","CHF BC2A",33,0 )
  4664    ;SBB 05/0 3/18 Fix N DC issue -  Defect 73 0459
  4665   "RTN","CHF BC2A",34,0 )
  4666    ;DYO 12/0 5/18 Fix D ME TRV cla ims going  to missing  data queu e if no PL  ZIP - Def ect 832284 .
  4667   "RTN","CHF BC2A",35,0 )
  4668    ;
  4669   "RTN","CHF BC2A",36,0 )
  4670    S CHMPF=0 ,CHMPFD="" ,HOSPAMT=0  K ALLOW
  4671   "RTN","CHF BC2A",37,0 )
  4672    S CHADOS= $P(REC0,"^ ",8) G PF: CHADOS<292 1001
  4673   "RTN","CHF BC2A",38,0 )
  4674    S VI=$P(R EC0,"^",3)  Q:VI=""
  4675   "RTN","CHF BC2A",39,0 )
  4676    ;I $D(^CH MVEN(VI,1) ) I $P(^(1 ),"^",16)= 1 G END:K2 ="DME-SUPP LY" ; JAK  - 03/31/10  - DEF0089 17
  4677   "RTN","CHF BC2A",40,0 )
  4678    G END:$P( REC0,"^",2 7)=2
  4679   "RTN","CHF BC2A",41,0 )
  4680    S RECC=@( GLPAY_"CI, ""COMMON"" )")
  4681   "RTN","CHF BC2A",42,0 )
  4682    ;
  4683   "RTN","CHF BC2A",43,0 )
  4684   PHP  ;
  4685   "RTN","CHF BC2A",44,0 )
  4686    G HOSPCE: CHADOS<297 0801
  4687   "RTN","CHF BC2A",45,0 )
  4688    G HOSPCE: $P(RECC,"^ ",2)=""                       ;; DEV006421  -- added l ine tag HO SPCE (orgi nally, ASC )
  4689   "RTN","CHF BC2A",46,0 )
  4690    G HOSPCE: $P(^CHMDIC (741002.11 ,$P(RECC," ^",2),0)," ^",1)'="PH P"  ;CHECK ING FACILI TY TYPE
  4691   "RTN","CHF BC2A",47,0 )
  4692    G HOSPCE: '$D(^CHMDI C(741013.1 3,"B",$P(@ (GLPAY_"CI ,K2,NM,0)" ),"^",1)))   ;CHECKIN G PHP CODE S
  4693   "RTN","CHF BC2A",48,0 )
  4694    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef
  4695   "RTN","CHF BC2A",49,0 )
  4696    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END
  4697   "RTN","CHF BC2A",50,0 )
  4698    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  4699   "RTN","CHF BC2A",51,0 )
  4700    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END
  4701   "RTN","CHF BC2A",52,0 )
  4702    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  4703   "RTN","CHF BC2A",53,0 )
  4704    ;Defect 8 32284 STAR T
  4705   "RTN","CHF BC2A",54,0 )
  4706    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  PL-ZIP MIS SING" G EN D
  4707   "RTN","CHF BC2A",55,0 )
  4708    I VZ="" D  CHKPLZIP  G END
  4709   "RTN","CHF BC2A",56,0 )
  4710    ;Defect 8 32284 END
  4711   "RTN","CHF BC2A",57,0 )
  4712    S VC=$O(^ CHMSMSA("Z IP",VZ,0))  G HOSPCE: 'VC
  4713   "RTN","CHF BC2A",58,0 )
  4714    G HOSPCE: '$D(^CHMSM SA(VC,4,0) )
  4715   "RTN","CHF BC2A",59,0 )
  4716    S PHPDAT= $O(^CHMSMS A(VC,4,"B" ,CHADOS),- 1) G HOSPC E:'PHPDAT
  4717   "RTN","CHF BC2A",60,0 )
  4718    S PHPI=$O (^CHMSMSA( VC,4,"B",P HPDAT,0))  G HOSPCE:' PHPI
  4719   "RTN","CHF BC2A",61,0 )
  4720    G HOSPCE: '$D(^CHMSM SA(VC,4,PH PI,0))
  4721   "RTN","CHF BC2A",62,0 )
  4722    S PHPF=$O (^CHMDIC(7 41013.13," B",$P(@(GL PAY_"CI,K2 ,NM,0)")," ^",1),0))  G HOSPCE:' PHPF
  4723   "RTN","CHF BC2A",63,0 )
  4724    S FDHD=$P (^CHMDIC(7 41013.13,P HPF,0),"^" ,2)
  4725   "RTN","CHF BC2A",64,0 )
  4726    S CHMPF=$ P(^CHMSMSA (VC,4,PHPI ,0),"^",FD HD)
  4727   "RTN","CHF BC2A",65,0 )
  4728    G HOSPCE: +CHMPF=0
  4729   "RTN","CHF BC2A",66,0 )
  4730    S CMAC(NM )=CHMPF
  4731   "RTN","CHF BC2A",67,0 )
  4732    S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=5
  4733   "RTN","CHF BC2A",68,0 )
  4734    G END
  4735   "RTN","CHF BC2A",69,0 )
  4736   HOSPCE  ;   DEV006421  incorpora ting a new  payment r equirement  for hospi ce payment
  4737   "RTN","CHF BC2A",70,0 )
  4738    N IEN,NM1 ,CBSA,CBSA IEN,CBSAIE N1,CBSANM, CBSANM1,CB SAWC,CBSAN WA,CBSAWG, CBSAENT,CB SAENT1             ;; DEV006421  new variab les added  for this s ection
  4739   "RTN","CHF BC2A",71,0 )
  4740    G ASC:CHA DOS<297080 1                                                                  ;;this co de from he re to END  is new for  DEV006421  - DRW - 0 6/15/12
  4741   "RTN","CHF BC2A",72,0 )
  4742    G ASC:$P( RECC,"^",1 6)'=5                 ;;5 indica tes outpat ient
  4743   "RTN","CHF BC2A",73,0 )
  4744    S FLG=0
  4745   "RTN","CHF BC2A",74,0 )
  4746    I $P(RECC ,"^",2)=""  G NEXT
  4747   "RTN","CHF BC2A",75,0 )
  4748    I $P(^CHM DIC(741002 .11,$P(REC C,"^",2),0 ),"^",1)=" HPC" S FLG =FLG+1  ;; hospice fa cility typ e
  4749   "RTN","CHF BC2A",76,0 )
  4750   NEXT  ;     in order  to avoid s ubscript e rror if fa cility typ e not defi ned
  4751   "RTN","CHF BC2A",77,0 )
  4752    S CHMSP=$ P(@(GLPAY_ "CI,K2,NM, 0)"),"^"), CHMSPC=$P( ^CHMSERV(C HMSP,0),"^ ",1)    ;; CHMSP cont ains point er to CHMS ERV and CH MSPC is th e service  code retur ned from C HMSERV
  4753   "RTN","CHF BC2A",78,0 )
  4754    G:(CHMSPC '="X7000") &(CHMSPC'= "X7001")&( CHMSPC'="0 0.00")&(CH MSPC'="00. 99") ASC
  4755   "RTN","CHF BC2A",79,0 )
  4756    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef
  4757   "RTN","CHF BC2A",80,0 )
  4758    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END
  4759   "RTN","CHF BC2A",81,0 )
  4760    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  4761   "RTN","CHF BC2A",82,0 )
  4762    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END
  4763   "RTN","CHF BC2A",83,0 )
  4764    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  4765   "RTN","CHF BC2A",84,0 )
  4766    ;Defect 8 32284 STAR T
  4767   "RTN","CHF BC2A",85,0 )
  4768    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  PL-ZIP MIS SING" G EN D
  4769   "RTN","CHF BC2A",86,0 )
  4770    I VZ="" D  CHKPLZIP  G END
  4771   "RTN","CHF BC2A",87,0 )
  4772    ;Defect 8 32284 END
  4773   "RTN","CHF BC2A",88,0 )
  4774    S IEN=$O( ^CHMDIC(74 1006.03,"B ",VZ,0))    ;;find th e IEN for  the CBSA c rosswalk b ased on zi p
  4775   "RTN","CHF BC2A",89,0 )
  4776    ;
  4777   "RTN","CHF BC2A",90,0 )
  4778    ;;DEV0225 92 JSE 3/3 /15 WAGE R ATE NEVER  SET CORREC TLY B/C NM 1 WAS NEVE R SET TO T HE CORRECT  DIC LOOKU P
  4779   "RTN","CHF BC2A",91,0 )
  4780    ;;                       COMMEN T OUT HOW  NM1 WAS OR IGINALY SE T & THE AT TEMPTED FI X FROM DEV 021956 (BE LOW)
  4781   "RTN","CHF BC2A",92,0 )
  4782    ;S NM1=$O (^CHMDIC(7 41006.03,I EN,1,CHADO S),-1)                                 ;; O RIG CODE I NCORRECT,  CAUSING SU BSCRIPT ER RS
  4783   "RTN","CHF BC2A",93,0 )
  4784    ;CHECKDT;  IF DOS IS  NOT CHECK ED, THE IE N ABOVE MA Y NOT BE T HE CORRECT  CBSA ;; D EV021956 D RW 11/06/2 014
  4785   "RTN","CHF BC2A",94,0 )
  4786    ;S EFFDT= $P(^CHMDIC (741006.03 ,IEN,1,NM1 ,0),"^",1)                             ;; D EV021956 D RW 11/06/2 014
  4787   "RTN","CHF BC2A",95,0 )
  4788    ;I CHADOS <EFFDT S N M1=NM1-1 G  CHECKDT      ;;LOOP  THROUGH UN TIL DOS IS  NO LONGER  LESS THAN  EFFECTIVE  DATE
  4789   "RTN","CHF BC2A",96,0 )
  4790    ;
  4791   "RTN","CHF BC2A",97,0 )
  4792    ;;DEV0225 92 JSE - N EW LOGIC(B ELOW) CORR ECTLY SETS  NM1. THIS  LOGIC REP LACE THE L OGIC ABOVE .
  4793   "RTN","CHF BC2A",98,0 )
  4794    I $D(^CHM DIC(741006 .03,IEN,1, "B",CHADOS )) S CHADO S2=CHADOS         ;;  DEV022592  JSE - IF D OS HAS AN  ENTRY USE  DOS DATE
  4795   "RTN","CHF BC2A",99,0 )
  4796    E  S CHAD OS2=$O(^CH MDIC(74100 6.03,IEN,1 ,"B",CHADO S),-1)            ;;  DEV022592  JSE - IF N O DOS ENTR Y, USE DAT E B4 DOS
  4797   "RTN","CHF BC2A",100, 0)
  4798    I CHADOS2 ="" S CHAD OS2=$O(^CH MDIC(74100 6.03,IEN,1 ,"B",0))          ;;  DEV022592  JSE - IF D OS IS B4 T HE 1ST ENT , SET NM1= 1ST ENT
  4799   "RTN","CHF BC2A",101, 0)
  4800    S NM1=$O( ^CHMDIC(74 1006.03,IE N,1,"B",CH ADOS2,""))                   ;;  DEV022592  JSE - SET  NM1 TO ENT RY# 4 SELE CTED DATE
  4801   "RTN","CHF BC2A",102, 0)
  4802    ;
  4803   "RTN","CHF BC2A",103, 0)
  4804    S CBSA=$P (^CHMDIC(7 41006.03,I EN,1,NM1,0 ),"^",5)
  4805   "RTN","CHF BC2A",104, 0)
  4806    ;;once th e CBSA is  found, use  the CBSA  to find th e wage ind ex on glob al ^CHMDIC (741043
  4807   "RTN","CHF BC2A",105, 0)
  4808    S CBSAIEN =$O(^CHMDI C(741043," B",CBSA,0) )
  4809   "RTN","CHF BC2A",106, 0)
  4810    ;S CBSANM =$O(^CHMDI C(741043,C BSAIEN,1," B",CHADOS) ,-1)              ;;  Find the l ast entry  close to t he DOS (re verse orde r))
  4811   "RTN","CHF BC2A",107, 0)
  4812    I $D(^CHM DIC(741043 ,CBSAIEN,1 ,"B",CHADO S)) S CBSA NM=CHADOS         ;;  DEV021956  DRW - ADDE D IF/ELSE  FOR EFFECT IVE DATE
  4813   "RTN","CHF BC2A",108, 0)
  4814    E  S CBSA NM=$O(^CHM DIC(741043 ,CBSAIEN,1 ,"B",CHADO S),-1)            ;;  DEV021956  Find last  entry clos est to DOS  (rev. ord er))
  4815   "RTN","CHF BC2A",109, 0)
  4816    I CBSANM= "" S CBSAN M=$O(^CHMD IC(741043, CBSAIEN,1, "B",CHADOS ))
  4817   "RTN","CHF BC2A",110, 0)
  4818    S CBSAENT =$O(^CHMDI C(741043,C BSAIEN,1," B",CBSANM, 0))               ;;f ind the ph ysical loc ation of t he entry n umber
  4819   "RTN","CHF BC2A",111, 0)
  4820    S CBSAWG= $P(^CHMDIC (741043,CB SAIEN,1,CB SAENT,0)," ^",6)             ;;w age index  rate for t he hospice  claim
  4821   "RTN","CHF BC2A",112, 0)
  4822    ;;once th e CBSAWG i s found, u se the for mula rate  associated  with the  service co de in
  4823   "RTN","CHF BC2A",113, 0)
  4824    ;;global  ^CHMDIC(74 1045 to de termine th e hospice  per diem r ate
  4825   "RTN","CHF BC2A",114, 0)
  4826    S CBSAIEN 1=$O(^CHMD IC(741045, "B",CHMSPC ,0))
  4827   "RTN","CHF BC2A",115, 0)
  4828    ;S CBSANM 1=$O(^CHMD IC(741045, CBSAIEN1,1 ,"B",CHADO S),-1)
  4829   "RTN","CHF BC2A",116, 0)
  4830    I $D(^CHM DIC(741045 ,CBSAIEN1, 1,"B",CHAD OS)) S CBS ANM1=CHADO S      ;;D EV021956 D RW-ADDED I F/ELSE FOR  EFFECTIVE  DATE
  4831   "RTN","CHF BC2A",117, 0)
  4832    E  S CBSA NM1=$O(^CH MDIC(74104 5,CBSAIEN1 ,1,"B",CHA DOS),-1)
  4833   "RTN","CHF BC2A",118, 0)
  4834    I CBSANM1 ="" S CBSA NM1=$O(^CH MDIC(74104 5,CBSAIEN1 ,1,"B",CHA DOS))
  4835   "RTN","CHF BC2A",119, 0)
  4836    S CBSAENT 1=$O(^CHMD IC(741045, CBSAIEN1,1 ,"B",CBSAN M1,0))            ;;f ind the en try locati on of date
  4837   "RTN","CHF BC2A",120, 0)
  4838    S CBSAWC= $P(^CHMDIC (741045,CB SAIEN1,1,C BSAENT1,0) ,"^",4)           ;;f ind the wa ge compone nt
  4839   "RTN","CHF BC2A",121, 0)
  4840    S CBSANWA =$P(^CHMDI C(741045,C BSAIEN1,1, CBSAENT1,0 ),"^",5)          ;;f ind the no n-weighted  amount
  4841   "RTN","CHF BC2A",122, 0)
  4842    S HOSPAMT =(CBSAWC*C BSAWG)+CBS ANWA                           ; ;multiply  wage compo nent by th e CBSA ind ex + non-w eighted am t
  4843   "RTN","CHF BC2A",123, 0)
  4844    I CHMSPC= "X7001" D
  4845   "RTN","CHF BC2A",124, 0)
  4846    . S HOSPA MT=HOSPAMT /24                                       ; ;divide by  the numbe r of hours  in one da y to get d aily rate
  4847   "RTN","CHF BC2A",125, 0)
  4848    S HOSPAMT =$FN(HOSPA MT,"",2)                                  ; ;the $FN f unction ro unds & set s to two d ecimal pla ces
  4849   "RTN","CHF BC2A",126, 0)
  4850    S CHMPF=+ HOSPAMT
  4851   "RTN","CHF BC2A",127, 0)
  4852    S CMAC(NM )=CHMPF
  4853   "RTN","CHF BC2A",128, 0)
  4854    G END
  4855   "RTN","CHF BC2A",129, 0)
  4856   ASC S CHMS P=$P(@(GLP AY_"CI,K2, NM,0)"),"^ "),CHMSPC= $P(^CHMSER V(CHMSP,0) ,"^",1)  ;  Subscript  error 9/3 0/05 mlr
  4857   "RTN","CHF BC2A",130, 0)
  4858    G CMAC:$P (RECC,"^", 2)=""
  4859   "RTN","CHF BC2A",131, 0)
  4860    G CMAC:$P (^CHMDIC(7 41002.11,$ P(RECC,"^" ,2),0),"^" ,1)'="ASC"
  4861   "RTN","CHF BC2A",132, 0)
  4862    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef
  4863   "RTN","CHF BC2A",133, 0)
  4864    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END
  4865   "RTN","CHF BC2A",134, 0)
  4866    G CMAC:$P (^CHMVEN(V I,1),"^",7 )="" S CHF AC=$P(^(1) ,"^",7)
  4867   "RTN","CHF BC2A",135, 0)
  4868    G CMAC:($ P(^CHMDIC( 741002.11, CHFAC,0)," ^",1)'="AS F")&($P(^C HMDIC(7410 02.11,CHFA C,0),"^",1 )'="ASH")
  4869   "RTN","CHF BC2A",136, 0)
  4870    G ASC1:'$ D(^CHMAGP( "B",CHMSPC ))
  4871   "RTN","CHF BC2A",137, 0)
  4872    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef
  4873   "RTN","CHF BC2A",138, 0)
  4874    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  4875   "RTN","CHF BC2A",139, 0)
  4876    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END
  4877   "RTN","CHF BC2A",140, 0)
  4878    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  4879   "RTN","CHF BC2A",141, 0)
  4880    ;Defect 8 32284 STAR T
  4881   "RTN","CHF BC2A",142, 0)
  4882    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  PL-ZIP MIS SING" G EN D
  4883   "RTN","CHF BC2A",143, 0)
  4884    I VZ="" D  CHKPLZIP  G END
  4885   "RTN","CHF BC2A",144, 0)
  4886    ;Defect 8 32284 END
  4887   "RTN","CHF BC2A",145, 0)
  4888    S VC=$O(^ CHMDIC(741 002.82,"B" ,VZ,0)) G  CMAC:'VC
  4889   "RTN","CHF BC2A",146, 0)
  4890    S CHLDT=$ O(^CHMDIC( 741002.82, VC,1,99999 99),-1) G  CMAC:'CHLD T
  4891   "RTN","CHF BC2A",147, 0)
  4892    G CMAC:'$ D(^CHMDIC( 741002.82, VC,1,CHLDT ,0)) S CHM SA=$P(^(0) ,"^",2)
  4893   "RTN","CHF BC2A",148, 0)
  4894    F JJ=$L(C HMSA):1:3  S CHMSA="0 "_CHMSA
  4895   "RTN","CHF BC2A",149, 0)
  4896    S CHMGPN= 0,CHMGPN=$ O(^CHMAGP( "B",CHMSPC ,CHMGPN))
  4897   "RTN","CHF BC2A",150, 0)
  4898    I 'CHMGPN  I $P(^CHM DIC(741002 .11,CHFAC, 0),"^",1)= "ASF" G AS C2 ;nsd I1 8439016FY1 8 - dpt
  4899   "RTN","CHF BC2A",151, 0)
  4900    I 'CHMGPN  I $P(^CHM DIC(741002 .11,CHFAC, 0),"^",1)' ="ASF" G E ND ;:'CHMG PN  ;nsd I 18439016FY 18 - dpt
  4901   "RTN","CHF BC2A",152, 0)
  4902    ;I '$D(^C HMAGP(CHMG PN,1,(CHAD OS+1))) I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F"  G ASC2
  4903   "RTN","CHF BC2A",153, 0)
  4904    ;I '$D(^C HMAGP(CHMG PN,1,(CHAD OS+1))) I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)'="A SF" G CMAC
  4905   "RTN","CHF BC2A",154, 0)
  4906    ;I $D(^CH MAGP(CHMGP N,1,(CHADO S+1))) S C HGRDT=$O(^ CHMAGP(CHM GPN,1,(CHA DOS+1)),-1 ) I CHGRDT ="" D
  4907   "RTN","CHF BC2A",155, 0)
  4908    ;  .I $P( ^CHMDIC(74 1002.11,CH FAC,0),"^" ,1)="ASF"  G ASC2
  4909   "RTN","CHF BC2A",156, 0)
  4910    ;  .I $P( ^CHMDIC(74 1002.11,CH FAC,0),"^" ,1)'="ASF"  G CMAC  ; nsd I18439 016FY18 -  dpt
  4911   "RTN","CHF BC2A",157, 0)
  4912    S CHGRDT= CHADOS+1,M TCHFLG=""
  4913   "RTN","CHF BC2A",158, 0)
  4914   CHCMGP S C HGRDT=$O(^ CHMAGP(CHM GPN,1,CHGR DT),-1) I  'CHGRDT G  CHMTFLG ;n sd I184390 16FY18 - d pt;bdb 4/1 9/18 rev $ o
  4915   "RTN","CHF BC2A",159, 0)
  4916     S CHBEG= $P(^CHMAGP (CHMGPN,1, CHGRDT,0), "^",1) ;ns d I1843901 6FY18 - dp t
  4917   "RTN","CHF BC2A",160, 0)
  4918     S CHGRP= +$P(^CHMAG P(CHMGPN,1 ,CHGRDT,0) ,"^",2) ;D PT 8/18/10  BUG009248 -03
  4919   "RTN","CHF BC2A",161, 0)
  4920     S CHLEDT =+$P(^CHMA GP(CHMGPN, 1,CHGRDT,0 ),"^",3) ; BUG016763- 03-01 DPT  8/18/10
  4921   "RTN","CHF BC2A",162, 0)
  4922     I CHADOS >=CHBEG I  CHLEDT=0 S  CHGRDT1=C HGRDT S MT CHFLG="Y"  G CHMTFLG  ;nsd I1843 9016FY18 -  dpt
  4923   "RTN","CHF BC2A",163, 0)
  4924     I CHADOS <=CHLEDT S  CHGRDT1=C HGRDT S MT CHFLG="Y"  G CHMTFLG  ;nsd I1843 9016FY18 -  dpt
  4925   "RTN","CHF BC2A",164, 0)
  4926    ;S CHGRDT =$O(^CHMAG P(CHMGPN,1 ,9999999), -1)
  4927   "RTN","CHF BC2A",165, 0)
  4928     G CHCMGP
  4929   "RTN","CHF BC2A",166, 0)
  4930   CHMTFLG ;
  4931   "RTN","CHF BC2A",167, 0)
  4932    I MTCHFLG '="Y" I $P (^CHMDIC(7 41002.11,C HFAC,0),"^ ",1)="ASF"  G ASC2  ; ;nsd I1843 9016FY18 -  dpt
  4933   "RTN","CHF BC2A",168, 0)
  4934    I MTCHFLG '="Y" I $P (^CHMDIC(7 41002.11,C HFAC,0),"^ ",1)'="ASF " G END  ; ;nsd I1843 9016FY18 -  dpt
  4935   "RTN","CHF BC2A",169, 0)
  4936    ;I CHADOS <CHBEG  I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F" G ASC2   ;;nsd I18 439016FY18  - dpt DEF 016763 DPT  3/28/11 D EV009248-0 3
  4937   "RTN","CHF BC2A",170, 0)
  4938    ;I CHADOS <CHBEG  I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)'="A SF" G END  ;TEST DPT
  4939   "RTN","CHF BC2A",171, 0)
  4940    ;G CMAC:' $D(^CHMAGP (CHMGPN,1, CHGRDT,0))  S CHGRP=+ $P(^(0),"^ ",2) ;DEAC TIVATE DPT
  4941   "RTN","CHF BC2A",172, 0)
  4942    ;I CHLEDT '=0,CHADOS >CHLEDT I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F"  G ASC2    ;;nsd I 18439016FY 18 - dpt
  4943   "RTN","CHF BC2A",173, 0)
  4944    ;I CHLEDT '=0,CHADOS >CHLEDT I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F" G CMAC  ;;nsd I184 39016FY18  - dpt
  4945   "RTN","CHF BC2A",174, 0)
  4946    S CHMMPN= 0,MTCHFLG= "" ;;nsd I 18439016FY 18 - dpt
  4947   "RTN","CHF BC2A",175, 0)
  4948   CHRATES ;
  4949   "RTN","CHF BC2A",176, 0)
  4950     I $D(^CH MART("B",C HMSA)) S C HMMPN=$O(^ CHMART("B" ,CHMSA,CHM MPN)) ;nsd  I18439016 FY18 - dpt
  4951   "RTN","CHF BC2A",177, 0)
  4952     I 'CHMMP N  I $P(^C HMDIC(7410 02.11,CHFA C,0),"^",1 )="ASF" G  ASC2 ;nsd  I18439016F Y18 - dpt
  4953   "RTN","CHF BC2A",178, 0)
  4954     I 'CHMMP N  I $P(^C HMDIC(7410 02.11,CHFA C,0),"^",1 )'="ASF" G  ASC1 ;bdb  04/13/17
  4955   "RTN","CHF BC2A",179, 0)
  4956     ;S CHMSD T=CHBEG,MT CHFLG=""
  4957   "RTN","CHF BC2A",180, 0)
  4958   CHRATES1 ;
  4959   "RTN","CHF BC2A",181, 0)
  4960    S CHGRDT1 =$O(^CHMAR T(CHMMPN,1 ,(CHADOS+1 )),-1) ;bd b 04122018  redefine  chgrdt1
  4961   "RTN","CHF BC2A",182, 0)
  4962    I '$D(^CH MART(CHMMP N,1,CHGRDT 1)) I $P(^ CHMDIC(741 002.11,CHF AC,0),"^", 1)="ASF" G  ASC2  ; ; nsd I18439 016FY18 -  dpt
  4963   "RTN","CHF BC2A",183, 0)
  4964    I '$D(^CH MART(CHMMP N,1,CHGRDT 1)) I $P(^ CHMDIC(741 002.11,CHF AC,0),"^", 1)'="ASF"  G END  ; ; nsd I18439 016FY18 -  dpt
  4965   "RTN","CHF BC2A",184, 0)
  4966    ;S CHMSDT =$O(^CHMAR T(CHMMPN,1 ,CHMSDT) G  ASC1:'CHM SDT ; DPT  3/28/11  B UG009248-0 5
  4967   "RTN","CHF BC2A",185, 0)
  4968    ;G CMAC:' $D(^CHMART (CHMMPN,1, CHGRDT,100 ,CHGRP,0))
  4969   "RTN","CHF BC2A",186, 0)
  4970    ;G CMAC:' $D(^CHMART (CHMMPN,1, CHMSDT,100 ,CHGRP,0))  S CHMPF=+ $P(^(0),"^ ",1)
  4971   "RTN","CHF BC2A",187, 0)
  4972    ;G CMAC:+ CHMPF=0
  4973   "RTN","CHF BC2A",188, 0)
  4974    S CHMSEDT =+$P(^CHMA RT(CHMMPN, 1,CHGRDT1, 0),"^",2)  ;DPT 8/18/ 10
  4975   "RTN","CHF BC2A",189, 0)
  4976    I CHMSEDT '=0,CHADOS >CHMSEDT   I $P(^CHMD IC(741002. 11,CHFAC,0 ),"^",1)=" ASF" G ASC 2  ; ;nsd  I18439016F Y18 - dpt  DPT 3/28/1 1 DEV00924 8-03
  4977   "RTN","CHF BC2A",190, 0)
  4978    I CHMSEDT '=0,CHADOS >CHMSEDT   I $P(^CHMD IC(741002. 11,CHFAC,0 ),"^",1)'= "ASF" G EN D  ;nsd I1 8439016FY1 8 - dpt
  4979   "RTN","CHF BC2A",191, 0)
  4980    I $D(^CHM ART(CHMMPN ,1,CHGRDT1 ,100,CHGRP )) S CHMPF =$P(^CHMAR T(CHMMPN,1 ,CHGRDT1,1 00,CHGRP,0 ),"^",1) ; nsd I18439 016FY18 -  dpt
  4981   "RTN","CHF BC2A",192, 0)
  4982    S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=3
  4983   "RTN","CHF BC2A",193, 0)
  4984    ;I WRT=1  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)")," ^",9)=3  ; DEV004651  2/11/14 EW  TEST FOR  WRITE FLAG
  4985   "RTN","CHF BC2A",194, 0)
  4986    S CMAC(NM )=CHMPF
  4987   "RTN","CHF BC2A",195, 0)
  4988    S $P(@(GL PAY_"CI,"" COMMON"")" ),"^",16)= 9
  4989   "RTN","CHF BC2A",196, 0)
  4990    ;I WRT=1  S $P(@(GLP AY_"CI,""C OMMON"")") ,"^",16)=9   ;DEV0046 51 2/11/14  EW TEST F OR WRITE F LAG
  4991   "RTN","CHF BC2A",197, 0)
  4992    G END
  4993   "RTN","CHF BC2A",198, 0)
  4994   ASC1 S CHM PF=+$P(@(G LPAY_"CI,K 2,NM,0)"), "^",2),CMA C(NM)=CHMP F
  4995   "RTN","CHF BC2A",199, 0)
  4996    S $P(@(GL PAY_"CI,"" COMMON"")" ),"^",16)= 9
  4997   "RTN","CHF BC2A",200, 0)
  4998    ;I WRT=1  S $P(@(GLP AY_"CI,""C OMMON"")") ,"^",16)=9   ;DEV0046 51 2/11/14  EW TEST F OR WRITE F LAG
  4999   "RTN","CHF BC2A",201, 0)
  5000    G END
  5001   "RTN","CHF BC2A",202, 0)
  5002   ASC2 ;
  5003   "RTN","CHF BC2A",203, 0)
  5004    I (+CHMSP CS>9999)&( +CHMSPCS<7 0000) S CH MPF=0,CMAC (NM)=0,REA =196,$P(@( GLPAY_"CI, ""RULE-PRO C"",NM,0)" ),"^",2)=R EA G END   ;DEF016763  DPT
  5005   "RTN","CHF BC2A",204, 0)
  5006    S CHMPF=0 ,CMAC(NM)= 0,REA=198, $P(@(GLPAY _"CI,""RUL E-PROC"",N M,0)"),"^" ,2)=REA G  END ;bdb 4 /19/17 add  service c ode range  check
  5007   "RTN","CHF BC2A",205, 0)
  5008   CMAC I VI= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ID MISSING " G END
  5009   "RTN","CHF BC2A",206, 0)
  5010    G PF:'$D( ^CHMVEN(VI ,41)) S CH CLS="" D   G PF:CHCLS =""
  5011   "RTN","CHF BC2A",207, 0)
  5012    .S CMJ=$O (^CHMVEN(V I,41,99999 99),-1) Q: 'CMJ
  5013   "RTN","CHF BC2A",208, 0)
  5014    .S CHCLS= $P(^CHMVEN (VI,41,CMJ ,0),"^",3)
  5015   "RTN","CHF BC2A",209, 0)
  5016    G PF:"1^2 ^3"'[CHCLS  S CHMSP=$ P(@(GLPAY_ "CI,K2,NM, 0)"),"^")
  5017   "RTN","CHF BC2A",210, 0)
  5018    S CHMSPC= $P(^CHMSER V(CHMSP,0) ,"^",1)
  5019   "RTN","CHF BC2A",211, 0)
  5020    ;CPE VEND OR STREAML INING repl ace Provid er Zip w/  PL-ZIP gef
  5021   "RTN","CHF BC2A",212, 0)
  5022    ;I '$D(^C HMVEN(VI,2 )) S VZ=""  G C0
  5023   "RTN","CHF BC2A",213, 0)
  5024    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  5025   "RTN","CHF BC2A",214, 0)
  5026    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  5027   "RTN","CHF BC2A",215, 0)
  5028    ;Defect 8 32284 STAR T
  5029   "RTN","CHF BC2A",216, 0)
  5030    ;C0 I VZ= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": PL-ZIP  MISSING" G  END
  5031   "RTN","CHF BC2A",217, 0)
  5032   C0 ;
  5033   "RTN","CHF BC2A",218, 0)
  5034    I VZ="" D  CHKPLZIP  G END
  5035   "RTN","CHF BC2A",219, 0)
  5036    ;Defect 8 32284 END
  5037   "RTN","CHF BC2A",220, 0)
  5038    S VC=$O(^ CHMDIC(741 002.4,"B", VZ,0))
  5039   "RTN","CHF BC2A",221, 0)
  5040    G PF:VC=" "
  5041   "RTN","CHF BC2A",222, 0)
  5042    S CHLDT=9 999999-CHA DOS-1
  5043   "RTN","CHF BC2A",223, 0)
  5044   C1 S CHLDT =$O(^CHMDI C(741002.4 ,VC,1,CHLD T)) G PF:C HLDT'?7N
  5045   "RTN","CHF BC2A",224, 0)
  5046    G PF:'$D( ^CHMDIC(74 1002.4,VC, 1,CHLDT,0) ) S CHLOC= $P(^(0),"^ ",2)
  5047   "RTN","CHF BC2A",225, 0)
  5048    S CHMSPN= $O(^CHMCPF ("B",CHMSP C,0)) G PF :'CHMSPN S  CHX=0
  5049   "RTN","CHF BC2A",226, 0)
  5050   C2 S CHX=$ O(^CHMCPF( CHMSPN,CHX )) G C1:'C HX
  5051   "RTN","CHF BC2A",227, 0)
  5052    G:CHX+8>1 000 C1
  5053   "RTN","CHF BC2A",228, 0)
  5054    G:CHX+8>C HLOC C22
  5055   "RTN","CHF BC2A",229, 0)
  5056    G C2
  5057   "RTN","CHF BC2A",230, 0)
  5058   C22 S CHCM DT=9999999 -CHADOS-1
  5059   "RTN","CHF BC2A",231, 0)
  5060   C3 S CHCMD T=$O(^CHMC PF(CHMSPN, CHX,CHCMDT )) G PF:CH CMDT'?7N
  5061   "RTN","CHF BC2A",232, 0)
  5062    G PF:'$D( ^CHMCPF(CH MSPN,CHX,C HCMDT,0))
  5063   "RTN","CHF BC2A",233, 0)
  5064    S CHLNM=C HLOC#8 S:C HLOC#8=0 C HLNM=8
  5065   "RTN","CHF BC2A",234, 0)
  5066    S CHMREC= $P(^CHMCPF (CHMSPN,CH X,CHCMDT,0 ),"^",2)
  5067   "RTN","CHF BC2A",235, 0)
  5068    S CHPNM=$ P(CHMREC," ,",CHLNM)
  5069   "RTN","CHF BC2A",236, 0)
  5070    D:CHADOS> 3070131 GE TCLP   ; J EH 2/1/07   CUT-OVER  DATE (2/1/ 07) TO NEW  CMAC FORM AT
  5071   "RTN","CHF BC2A",237, 0)
  5072    S CHMPF=$ P(CHPNM,"; ",CHCLS),M OD=""
  5073   "RTN","CHF BC2A",238, 0)
  5074    I K2="OPT -PROC" D       ;JEH 2 /13/09  TT  ENC004843
  5075   "RTN","CHF BC2A",239, 0)
  5076    .S MOD=$$ GTMOD^CHFB C2A(CI,K2, NM,CHMSPC)          ; JEH 2/13/0 9  TT ENC0 04843  ADD ED SUBROUT INE
  5077   "RTN","CHF BC2A",240, 0)
  5078    ;S:K2="OP T-PROC" MO D=$P(@(GLP AY_"CI,K2, NM,0)"),"^ ",4)   ;JE H 2/13/09   TT ENC004 843
  5079   "RTN","CHF BC2A",241, 0)
  5080    S:K2="DEN -PROC" MOD =$P(@(GLPA Y_"CI,K2,N M,0)"),"^" ,6)
  5081   "RTN","CHF BC2A",242, 0)
  5082    D:MOD'=""
  5083   "RTN","CHF BC2A",243, 0)
  5084    .Q:CHADOS <2970701
  5085   "RTN","CHF BC2A",244, 0)
  5086    .Q:('$D(^ CHMDIC(741 002.98,"B" ,MOD)))&(' $D(^CHMDIC (741002.99 ,"B",MOD)) )
  5087   "RTN","CHF BC2A",245, 0)
  5088    .S FILEPT =$S($D(^CH MDIC(74100 2.98,"B",M OD)):"7410 02.98",$D( ^CHMDIC(74 1002.99,"B ",MOD)):"7 41002.99", 1:"")
  5089   "RTN","CHF BC2A",246, 0)
  5090    .Q:FILEPT =""
  5091   "RTN","CHF BC2A",247, 0)
  5092    .I '$D(^C HMCPF(CHMS PN,CHX,CHC MDT,1)) D   Q         ;PRO/TECH
  5093   "RTN","CHF BC2A",248, 0)
  5094    ..S REA=" ",PERC=""
  5095   "RTN","CHF BC2A",249, 0)
  5096    ..S MODI= $O(^CHMDIC (FILEPT,"B ",MOD,0))
  5097   "RTN","CHF BC2A",250, 0)
  5098    ..I MODI' ="" S:$D(^ CHMDIC(FIL EPT,MODI,0 )) REA=$P( ^(0),"^",2 ),PERC=$P( ^(0),"^",3 )
  5099   "RTN","CHF BC2A",251, 0)
  5100    ..S CHMPF =CHMPF*PER C
  5101   "RTN","CHF BC2A",252, 0)
  5102    ..S X1=CI  D PROGTYP ^CHFCD001
  5103   "RTN","CHF BC2A",253, 0)
  5104    ..S $P(@( GLPAY_"CI, K1,NM,0)") ,"^",2)=RE A
  5105   "RTN","CHF BC2A",254, 0)
  5106    ..;I WRT= 1 S $P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=REA   ;DEV0046 51 2/11/14  EW TEST F OR WRITE F LAG
  5107   "RTN","CHF BC2A",255, 0)
  5108    ..;S $P(@ (GLPAY_"CI ,""RULE-PR OC"",NM,0) "),U,2)=RE A
  5109   "RTN","CHF BC2A",256, 0)
  5110    .I CHCLS= 2&(CHADOS< 3070201) D   Q     ;J EH 2/11/07  ADDED 'CH ADOS<30702 01' DUE TO  NEW FORMA T AND CUTO VER DATE
  5111   "RTN","CHF BC2A",257, 0)
  5112    ..S PERC= "",REA=""
  5113   "RTN","CHF BC2A",258, 0)
  5114    ..S MODI= $O(^CHMDIC (FILEPT,"B ",MOD,0))
  5115   "RTN","CHF BC2A",259, 0)
  5116    ..I MODI' ="" S:$D(^ CHMDIC(FIL EPT,MODI,0 )) REA=$P( ^(0),"^",2 ),PERC=$P( ^(0),"^",3 )
  5117   "RTN","CHF BC2A",260, 0)
  5118    ..S CHMPF =CHMPF*PER C
  5119   "RTN","CHF BC2A",261, 0)
  5120    ..S X1=CI  D PROGTYP ^CHFCD001
  5121   "RTN","CHF BC2A",262, 0)
  5122    ..S $P(@( GLPAY_"CI, K1,NM,0)") ,"^",2)=RE A
  5123   "RTN","CHF BC2A",263, 0)
  5124    ..;I WRT= 1 S $P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=REA   ;DEV0046 51 2/11/14  EW TEST F OR WRITE F LAG
  5125   "RTN","CHF BC2A",264, 0)
  5126    ..;S $P(@ (GLPAY_"CI ,""RULE-PR OC"",NM,0) "),U,2)=RE A
  5127   "RTN","CHF BC2A",265, 0)
  5128    .S CHMREC 1=$P(^CHMC PF(CHMSPN, CHX,CHCMDT ,1),"^",2)
  5129   "RTN","CHF BC2A",266, 0)
  5130    .S CHPNM1 =$P(CHMREC 1,",",CHLN M)
  5131   "RTN","CHF BC2A",267, 0)
  5132    .;S:FILEP T=741002.9 8 PT1=CHCL S                        ;CHAMPV A PROF COM PONENT MOD IFIERS
  5133   "RTN","CHF BC2A",268, 0)
  5134    .;S:FILEP T=741002.9 9 PT1=$S(C HCLS=1:2,C HCLS=3:4)     ;CHAMPV A TECH COM PONENT MOD IFIERS
  5135   "RTN","CHF BC2A",269, 0)
  5136    .I FILEPT =741002.98  D                    ;CHAMPVA P ROF. COMPO NENT MODFI ERS   ;JEH  2/11/07 A DDED FOR N EW FORMAT  AND CUTOVE R DATE
  5137   "RTN","CHF BC2A",270, 0)
  5138    ..I CHADO S<3070201  D
  5139   "RTN","CHF BC2A",271, 0)
  5140    ...S PT1= CHCLS
  5141   "RTN","CHF BC2A",272, 0)
  5142    ..E  D
  5143   "RTN","CHF BC2A",273, 0)
  5144    ...S PT1= $S(CHCLS=1 :1,CHCLS=2 :1,CHCLS=3 :3,CHCLS=4 :3)
  5145   "RTN","CHF BC2A",274, 0)
  5146    .I FILEPT =741002.99  D                    ;CHAMPVA T ECH COMPON ENT MODIFI ERS   ;JEH  2/11/07 A DDED FOR N EW FORMAT  AND CUTOVE R DATE
  5147   "RTN","CHF BC2A",275, 0)
  5148    ..I CHADO S<3070201  D
  5149   "RTN","CHF BC2A",276, 0)
  5150    ...S PT1= $S(CHCLS=1 :2,CHCLS=3 :4)
  5151   "RTN","CHF BC2A",277, 0)
  5152    ..E  D
  5153   "RTN","CHF BC2A",278, 0)
  5154    ...S PT1= $S(CHCLS=1 :2,CHCLS=2 :2,CHCLS=3 :4,CHCLS=4 :4)
  5155   "RTN","CHF BC2A",279, 0)
  5156    .S CHMPF= $P(CHPNM1, ";",PT1)
  5157   "RTN","CHF BC2A",280, 0)
  5158    .S REA=""
  5159   "RTN","CHF BC2A",281, 0)
  5160    .S MODI=$ O(^CHMDIC( FILEPT,"B" ,MOD,0))
  5161   "RTN","CHF BC2A",282, 0)
  5162    .I MODI'= "" S:$D(^C HMDIC(FILE PT,MODI,0) ) REA=$P(^ (0),"^",2)
  5163   "RTN","CHF BC2A",283, 0)
  5164    .S X1=CI  D PROGTYP^ CHFCD001
  5165   "RTN","CHF BC2A",284, 0)
  5166    .S $P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=REA
  5167   "RTN","CHF BC2A",285, 0)
  5168    .;I WRT=1  S $P(@(GL PAY_"CI,K1 ,NM,0)")," ^",2)=REA   ;DEV00465 1 2/11/14  EW TEST FO R WRITE FL AG
  5169   "RTN","CHF BC2A",286, 0)
  5170    .;S $P(@( GLPAY_"CI, ""RULE-PRO C"",NM,0)" ),U,2)=REA
  5171   "RTN","CHF BC2A",287, 0)
  5172    G PF:+CHM PF=0
  5173   "RTN","CHF BC2A",288, 0)
  5174    S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=1
  5175   "RTN","CHF BC2A",289, 0)
  5176    ;I WRT=1  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)")," ^",9)=1  ; DEV004651  2/11/14 EW  TEST FOR  WRITE FLAG
  5177   "RTN","CHF BC2A",290, 0)
  5178    S CMAC(NM )=CHMPF
  5179   "RTN","CHF BC2A",291, 0)
  5180    G END
  5181   "RTN","CHF BC2A",292, 0)
  5182   PF S CHMPF =0,CHMDOS= $P(REC0,"^ ",8),CHMRD T=9999999- CHMDOS,CHM RSD=CHMRDT -1
  5183   "RTN","CHF BC2A",293, 0)
  5184    ; Y2K fix
  5185   "RTN","CHF BC2A",294, 0)
  5186    ;S YR=$E( CHMDOS,2,3 ) I $E(YR, 2)="0" S Y R=$E(YR,1)
  5187   "RTN","CHF BC2A",295, 0)
  5188    ;S FN="74 1012."_YR
  5189   "RTN","CHF BC2A",296, 0)
  5190    S YR=$E(C HMDOS,1,3)
  5191   "RTN","CHF BC2A",297, 0)
  5192    S FN=$$FN SET^CHFBC2 A(CHMDOS)
  5193   "RTN","CHF BC2A",298, 0)
  5194    ;
  5195   "RTN","CHF BC2A",299, 0)
  5196    S CHMSPC= $P(@(GLPAY _"CI,K2,NM ,0)"),"^")
  5197   "RTN","CHF BC2A",300, 0)
  5198    S VI=$P(R EC0,"^",3)
  5199   "RTN","CHF BC2A",301, 0)
  5200    I VI="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": V ENDOR ID M ISSING" G  END
  5201   "RTN","CHF BC2A",302, 0)
  5202    ;CPE VEND OR STREAML INING repl ace Provid er Zip w/  PL-ZIP gef
  5203   "RTN","CHF BC2A",303, 0)
  5204    ;I '$D(^C HMVEN(VI,2 )) S VZ=""  G A0
  5205   "RTN","CHF BC2A",304, 0)
  5206    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  5207   "RTN","CHF BC2A",305, 0)
  5208    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  5209   "RTN","CHF BC2A",306, 0)
  5210    ;Defect 8 32284 STAR T
  5211   "RTN","CHF BC2A",307, 0)
  5212    ;A0 I VZ= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": PL-ZIP  MISSING" G  END
  5213   "RTN","CHF BC2A",308, 0)
  5214   A0 ;
  5215   "RTN","CHF BC2A",309, 0)
  5216    I VZ="" D  CHKPLZIP  G END
  5217   "RTN","CHF BC2A",310, 0)
  5218    ;Defect 8 32284 END
  5219   "RTN","CHF BC2A",311, 0)
  5220    S VST=$P( ^CHMVEN(VI ,2),"^",4)   ;CPE001- 119 CFS -  Fix undefi ned error.
  5221   "RTN","CHF BC2A",312, 0)
  5222    I VST=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR STA TE MISSING  " G END
  5223   "RTN","CHF BC2A",313, 0)
  5224    S VC=$O(^ CHMSMSA("Z IP",VZ,VST ,0))
  5225   "RTN","CHF BC2A",314, 0)
  5226    ;SBB 05/0 3/18 Fix N DC issue -  Defect 73 0459
  5227   "RTN","CHF BC2A",315, 0)
  5228    I VC="" S  VST=$O(^C HMSMSA("ZI P",VZ,0))
  5229   "RTN","CHF BC2A",316, 0)
  5230    I VST'=""  S VC=$O(^ CHMSMSA("Z IP",VZ,VST ,0))
  5231   "RTN","CHF BC2A",317, 0)
  5232    I VC="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP UNKN OWN OR INC OMPATIBLE  WITH STATE " G END
  5233   "RTN","CHF BC2A",318, 0)
  5234    S CHMSPN= $O(^CHMSPF (FN,"B",CH MSPC,0)) G :CHMSPN=""  END
  5235   "RTN","CHF BC2A",319, 0)
  5236    I $D(^CHM SPF(FN,CHM SPN,"DEL") ),$P(^("DE L"),"^",1) =1 G END
  5237   "RTN","CHF BC2A",320, 0)
  5238    S CHSMDT= $O(^CHMSMS A(VST,1,VC ,3,CHMRSD) )
  5239   "RTN","CHF BC2A",321, 0)
  5240    I CHSMDT' ?1N.N D GS TSM G A1
  5241   "RTN","CHF BC2A",322, 0)
  5242    S CHMSNUM =$P(^CHMSM SA(VST,1,V C,3,CHSMDT ,0),"^",2)
  5243   "RTN","CHF BC2A",323, 0)
  5244    I (CHMSNU M=0)!(CHMS NUM="") D  GSTSM G A1
  5245   "RTN","CHF BC2A",324, 0)
  5246    S PF=$S(( (CHMSNUM'> 20)&(CHMSN UM>0)):1,( (CHMSNUM'> 40)&(CHMSN UM>20)):2, ((CHMSNUM' >60)&(CHMS NUM>40)):3 ,((CHMSNUM '>80)&(CHM SNUM>60)): 4,((CHMSNU M'>100)&(C HMSNUM>80) ):5,1:6)
  5247   "RTN","CHF BC2A",325, 0)
  5248    I PF=6 D  GSTSM G A1
  5249   "RTN","CHF BC2A",326, 0)
  5250    I CHMSNUM <21,$D(^CH MSPF(FN,CH MSPN,PF))  S:$D(^CHMS PF(FN,CHMS PN,PF)) CH MPFD=$P(^C HMSPF(FN,C HMSPN,PF), ",",CHMSNU M) I CHMPF D'="" S CH MPF=+$P(CH MPFD,";",1 )
  5251   "RTN","CHF BC2A",327, 0)
  5252    E  I $D(^ CHMSPF(FN, CHMSPN,PF) ) S:$D(^CH MSPF(FN,CH MSPN,PF))  CHMPFD=$P( ^CHMSPF(FN ,CHMSPN,PF ),",",(CHM SNUM#(20*( $S(PF=1:1, PF=2:1,PF= 3:2,PF=4:3 ,PF=5:4,1: 1))))) I C HMPFD'=""  S CHMPF=+$ P(CHMPFD," ;",1)
  5253   "RTN","CHF BC2A",328, 0)
  5254    I CHMPF=0  D GSTSM:Y R>293 G EN D:YR<294 G  END:CHMPF =0
  5255   "RTN","CHF BC2A",329, 0)
  5256    S MOD=""
  5257   "RTN","CHF BC2A",330, 0)
  5258    I K2="OPT -PROC" D       ;JEH 2 /13/09  TT  ENC004843
  5259   "RTN","CHF BC2A",331, 0)
  5260    .S TMPSPC =$P(^CHMSE RV(CHMSPC, 0),"^",1)    ;GET COD E
  5261   "RTN","CHF BC2A",332, 0)
  5262    .S MOD=$$ GTMOD^CHFB C2A(CI,K2, NM,TMPSPC)          ; JEH 2/13/0 9  TT ENC0 04843  ADD ED SUBROUT INE
  5263   "RTN","CHF BC2A",333, 0)
  5264    ;S:K2="OP T-PROC" MO D=$P(@(GLP AY_"CI,K2, NM,0)"),"^ ",4)   ;JE H 2/13/09   TT ENC004 843
  5265   "RTN","CHF BC2A",334, 0)
  5266    S:K2="DEN -PROC" MOD =$P(@(GLPA Y_"CI,K2,N M,0)"),"^" ,6)
  5267   "RTN","CHF BC2A",335, 0)
  5268    D:MOD'=""
  5269   "RTN","CHF BC2A",336, 0)
  5270    .Q:CHADOS <2970701
  5271   "RTN","CHF BC2A",337, 0)
  5272    .Q:('$D(^ CHMDIC(741 002.98,"B" ,MOD)))&(' $D(^CHMDIC (741002.99 ,"B",MOD)) )
  5273   "RTN","CHF BC2A",338, 0)
  5274    .S FILEPT =$S($D(^CH MDIC(74100 2.98,"B",M OD)):"7410 02.98",$D( ^CHMDIC(74 1002.99,"B ",MOD)):"7 41002.99", 1:"")
  5275   "RTN","CHF BC2A",339, 0)
  5276    .Q:FILEPT =""
  5277   "RTN","CHF BC2A",340, 0)
  5278    .S PERC=" ",REA=""
  5279   "RTN","CHF BC2A",341, 0)
  5280    .S MODI=$ O(^CHMDIC( FILEPT,"B" ,MOD,0))
  5281   "RTN","CHF BC2A",342, 0)
  5282    .I MODI'= "" S:$D(^C HMDIC(FILE PT,MODI,0) ) REA=$P(^ (0),"^",2) ,PERC=$P(^ (0),"^",3)
  5283   "RTN","CHF BC2A",343, 0)
  5284    .S CHMPF= CHMPF*PERC
  5285   "RTN","CHF BC2A",344, 0)
  5286    .S X1=CI  D PROGTYP^ CHFCD001
  5287   "RTN","CHF BC2A",345, 0)
  5288    .S $P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=REA
  5289   "RTN","CHF BC2A",346, 0)
  5290    .;I WRT=1  S $P(@(GL PAY_"CI,K1 ,NM,0)")," ^",2)=REA   ;DEV00465 1 2/11/14  EW TEST FO R WRITE FL AG
  5291   "RTN","CHF BC2A",347, 0)
  5292    .;S $P(@( GLPAY_"CI, ""RULE-PRO C"",NM,0)" ),U,2)=REA
  5293   "RTN","CHF BC2A",348, 0)
  5294   A1 ;I WRT= 1 S $P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=2   ;DEV00465 1 2/11/14  EW TEST FO R WRITE FL AG
  5295   "RTN","CHF BC2A",349, 0)
  5296    S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=2
  5297   "RTN","CHF BC2A",350, 0)
  5298    S CMAC(NM )=CHMPF
  5299   "RTN","CHF BC2A",351, 0)
  5300   END I (K2= "DME-SUPPL Y")!(K2="O PT-PROC")  D
  5301   "RTN","CHF BC2A",352, 0)
  5302    .Q:$P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=19 6  ;DEF016 763 DPT
  5303   "RTN","CHF BC2A",353, 0)
  5304    .Q:$P(@(G LPAY_"CI,K 2,NM,0)"), "^",5)=""
  5305   "RTN","CHF BC2A",354, 0)
  5306    .S CHMPF= $P(^(0),"^ ",5),CMAC( NM)=CHMPF
  5307   "RTN","CHF BC2A",355, 0)
  5308    .S $P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=4
  5309   "RTN","CHF BC2A",356, 0)
  5310    .;I WRT=1  S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=4   ;DEV004651  2/11/14 E W TEST FOR  WRITE FLA G
  5311   "RTN","CHF BC2A",357, 0)
  5312    .S ALLOW= 1
  5313   "RTN","CHF BC2A",358, 0)
  5314    I K2="DEN -PROC" D
  5315   "RTN","CHF BC2A",359, 0)
  5316    .Q:$P(@(G LPAY_"CI,K 2,NM,0)"), "^",7)=""
  5317   "RTN","CHF BC2A",360, 0)
  5318    .S CHMPF= $P(^(0),"^ ",7),CMAC( NM)=CHMPF
  5319   "RTN","CHF BC2A",361, 0)
  5320    .S $P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=4
  5321   "RTN","CHF BC2A",362, 0)
  5322    .;I WRT=1  S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=4   ;DEV004651  2/11/14 E W TEST FOR  WRITE FLA G
  5323   "RTN","CHF BC2A",363, 0)
  5324    .S ALLOW= 1
  5325   "RTN","CHF BC2A",364, 0)
  5326    K CHMPFD, CHMSPN,CHM SNUM,CHSMD T,VST,VC,V I,VZ,CHMSP ,CHMSPC,CH LDT
  5327   "RTN","CHF BC2A",365, 0)
  5328    K CHMSA,C HMGPN,CHGR DT,CHMMPN, CHMSDT,CHG RP,CHFAC,H OSPAMT Q
  5329   "RTN","CHF BC2A",366, 0)
  5330   GSTSM I VS T>40 I $D( ^CHMSPF(FN ,CHMSPN,0) ) S:$D(^CH MSPF(FN,CH MSPN,103))  CHMPFD=$P (^CHMSPF(F N,CHMSPN,1 03),",",VS T-40) I $G (CHMPFD)'= "" S CHMPF =+$P(CHMPF D,";",1) Q    ;SKD 1- 10-07; I C HMPFD'=""
  5331   "RTN","CHF BC2A",367, 0)
  5332    I (VST>20 )&(VST'>40 ) I $D(^CH MSPF(FN,CH MSPN,0)) S :$D(^CHMSP F(FN,CHMSP N,102)) CH MPFD=$P(^C HMSPF(FN,C HMSPN,102) ,",",VST-2 0) I $G(CH MPFD)'=""  S CHMPF=+$ P(CHMPFD," ;",1) Q    ;SKD 1-10- 07; I CHMP FD'=""
  5333   "RTN","CHF BC2A",368, 0)
  5334    I (VST>0) &(VST'>20)  I $D(^CHM SPF(FN,CHM SPN,0)) S: $D(^CHMSPF (FN,CHMSPN ,101)) CHM PFD=$P(^CH MSPF(FN,CH MSPN,101), ",",VST) I  $G(CHMPFD )'="" S CH MPF=+$P(CH MPFD,";",1 ) Q    ;SK D 1-10-07;  I CHMPFD' =""
  5335   "RTN","CHF BC2A",369, 0)
  5336    Q
  5337   "RTN","CHF BC2A",370, 0)
  5338   GETCLP ;DE TERMINE CM AC RATE PO SITION
  5339   "RTN","CHF BC2A",371, 0)
  5340    Q:$D(^CHM SERV(CHMSP ,4))    ;Q UIT IF ANE THESIA COD E    ; JEH  12/5/06
  5341   "RTN","CHF BC2A",372, 0)
  5342    S CHMFAC= 0   ; Set  default to  Non-facil ity
  5343   "RTN","CHF BC2A",373, 0)
  5344    S CHMPOS= 99  ; Set  default to  Other loc ation
  5345   "RTN","CHF BC2A",374, 0)
  5346    S PTR=""   ;AEB 4/17 /2007
  5347   "RTN","CHF BC2A",375, 0)
  5348    S:$D(@(GL PAY_"CI,"" COMMON"")" )) I=$P(@( GLPAY_"CI, ""COMMON"" )"),"^",2)
  5349   "RTN","CHF BC2A",376, 0)
  5350    ;I I I $D (^CHMDIC(7 41002.11,I ,0)) S PTR =$P(^(0)," ^",5)   ;J EH 3/25/08
  5351   "RTN","CHF BC2A",377, 0)
  5352    ;I PTR I  $D(^IBE(35 3.1,PTR,0) ) S CHMFAC =$P(^(0)," ^",4)   ;G ET FACILIT Y TYPE   ; JEH 3/25/0 8
  5353   "RTN","CHF BC2A",378, 0)
  5354    I I I $D( ^CHMDIC(74 1002.11,I, 0)) S CHMF AC=$P(^(0) ,"^",7)    ;JEH 3/25/ 08
  5355   "RTN","CHF BC2A",379, 0)
  5356    S CHCLS=C HCLS+CHMFA C
  5357   "RTN","CHF BC2A",380, 0)
  5358    Q
  5359   "RTN","CHF BC2A",381, 0)
  5360   FNSET(FMDT ) ;Sets th e correct  FN for pre vailing fe e global ( CHMSPF)
  5361   "RTN","CHF BC2A",382, 0)
  5362    ; FMDT mu st be a fi leman date  (2990101)  or at lea st the
  5363   "RTN","CHF BC2A",383, 0)
  5364    ;      fi rst three  positions  of the fil eman dt (2 99)
  5365   "RTN","CHF BC2A",384, 0)
  5366    ; Y2K - T his was ad ded to mak e global Y 2K complia nt (FN was  741012.99
  5367   "RTN","CHF BC2A",385, 0)
  5368    ;       a nd now is  741012.299 ).  Traili ng zeros w ill be tru ncated in
  5369   "RTN","CHF BC2A",386, 0)
  5370    ;       o rder to be  compatiab le with Fi leman.
  5371   "RTN","CHF BC2A",387, 0)
  5372    ;
  5373   "RTN","CHF BC2A",388, 0)
  5374    N X,Y
  5375   "RTN","CHF BC2A",389, 0)
  5376    S Y=""
  5377   "RTN","CHF BC2A",390, 0)
  5378    I $L(FMDT )>2 D
  5379   "RTN","CHF BC2A",391, 0)
  5380    .S X=$E(F MDT,1,3)
  5381   "RTN","CHF BC2A",392, 0)
  5382    .I $E(X,3 )=0 S X=$E (X,1,2) D
  5383   "RTN","CHF BC2A",393, 0)
  5384    ..I $E(X, 2)=0 S X=$ E(X,1)
  5385   "RTN","CHF BC2A",394, 0)
  5386    .S Y="741 012."_X
  5387   "RTN","CHF BC2A",395, 0)
  5388    Q Y
  5389   "RTN","CHF BC2A",396, 0)
  5390   GTMOD(GCI, GK2,GNM,GC HMSPC)  ;S UBROUTINE  TO DETERMI NE/GET MOD IFIERS FOR  OUTPATIEN T CLAIMS
  5391   "RTN","CHF BC2A",397, 0)
  5392    ;JEH 4/13 /10 ENC004 843
  5393   "RTN","CHF BC2A",398, 0)
  5394    ;GCI = CL AIM POINTE R
  5395   "RTN","CHF BC2A",399, 0)
  5396    ;GK2 = GL OBAL NODE  INDICATOR  - "OPT-PRO C"
  5397   "RTN","CHF BC2A",400, 0)
  5398    ;GNM = J  VALUE FROM  PAY FILE
  5399   "RTN","CHF BC2A",401, 0)
  5400    N MOD,TOB ,POS,TOC,C HMREC,CHPN M,CHMREC1, CHPNM1
  5401   "RTN","CHF BC2A",402, 0)
  5402    S MOD=""  S MOD=$P(@ (GLPAY_"GC I,GK2,GNM, 0)"),"^",4 )
  5403   "RTN","CHF BC2A",403, 0)
  5404    Q:'$D(^CH MCPF("B",G CHMSPC)) M OD   ;QUIT  IF CODE N OT IN CMAC  GLOBAL
  5405   "RTN","CHF BC2A",404, 0)
  5406    Q:MOD=4!( MOD=83) MO D  ;4=26/8 3=TC
  5407   "RTN","CHF BC2A",405, 0)
  5408    S TOC=""  S TOC=$P(@ (GLPAY_"GC I,0)"),"^" ,7)      ; TYPE OF CL AIM 2=OUTP ATIENT
  5409   "RTN","CHF BC2A",406, 0)
  5410    Q:TOC'=2  MOD
  5411   "RTN","CHF BC2A",407, 0)
  5412    Q:CHCMDT= "" MOD                            ; RFE 6/3 0/16 DEV02 5633
  5413   "RTN","CHF BC2A",408, 0)
  5414    I (GCHMSP C>=70000)& (GCHMSPC<= 90000) {
  5415   "RTN","CHF BC2A",409, 0)
  5416       S TOB= ""   ;BILL  TYPE BILL  (013x-HOS P OUTPATIE NT, 014x-H OSP OTHER  PART B)
  5417   "RTN","CHF BC2A",410, 0)
  5418       S:$D(@ (GLPAY_"GC I,7)")) TO B=$P(@(GLP AY_"GCI,7) "),"^",6)
  5419   "RTN","CHF BC2A",411, 0)
  5420       S POS= 0 S POS=$P (@(GLPAY_" GCI,""COMM ON"")"),"^ ",2)  ;PLA CE OF SERV ICE
  5421   "RTN","CHF BC2A",412, 0)
  5422       I TOB' ="" {
  5423   "RTN","CHF BC2A",413, 0)
  5424           I  ("12,13,14 ,22,23,83" [$E(TOB,1, 2))&(POS=2 ) {      ; BILL CODE  TYPE  013x -Hospital  Outpatient /014x-Hosp ital Other  Part B
  5425   "RTN","CHF BC2A",414, 0)
  5426                I $D(^CH MCPF(CHMSP N,CHX,CHCM DT,0)) {
  5427   "RTN","CHF BC2A",415, 0)
  5428                    S CH MREC=$P(^C HMCPF(CHMS PN,CHX,CHC MDT,0),"^" ,2)   ;TEC H
  5429   "RTN","CHF BC2A",416, 0)
  5430                    S CH PNM=$P(CHM REC,",",CH LNM)
  5431   "RTN","CHF BC2A",417, 0)
  5432                    I $P (CHPNM,";" ,4)'=""&($ P(CHPNM,"; ",4)>0) S  MOD=83     ;83=TC
  5433   "RTN","CHF BC2A",418, 0)
  5434                }
  5435   "RTN","CHF BC2A",419, 0)
  5436           }
  5437   "RTN","CHF BC2A",420, 0)
  5438       }
  5439   "RTN","CHF BC2A",421, 0)
  5440       I (TOB =""&(POS=2 ))!(POS=86 ) {   ;2-O P,86-IPP
  5441   "RTN","CHF BC2A",422, 0)
  5442           I  $D(^CHMCPF (CHMSPN,CH X,CHCMDT,1 )) {
  5443   "RTN","CHF BC2A",423, 0)
  5444                S CHMREC 1=$P(^CHMC PF(CHMSPN, CHX,CHCMDT ,1),"^",2)    ;PRO
  5445   "RTN","CHF BC2A",424, 0)
  5446                S CHPNM1 =$P(CHMREC 1,",",CHLN M)
  5447   "RTN","CHF BC2A",425, 0)
  5448                I $P(CHP NM1,";",3) '=""&($P(C HPNM1,";", 3)>0) S MO D=4    ;4= 26
  5449   "RTN","CHF BC2A",426, 0)
  5450           }
  5451   "RTN","CHF BC2A",427, 0)
  5452       }
  5453   "RTN","CHF BC2A",428, 0)
  5454    }
  5455   "RTN","CHF BC2A",429, 0)
  5456    Q MOD
  5457   "RTN","CHF BC2A",430, 0)
  5458   CHKPLZIP ; DEFECT 832 284
  5459   "RTN","CHF BC2A",431, 0)
  5460    I (CHMFTP =4)!(CHMFT P=6) Q  ;4  IS DME an d 6 IS TRA VEL. DME A ND TRAVEL  CALIMS DO  NOT GO TO  MDQ
  5461   "RTN","CHF BC2A",432, 0)
  5462    S CHMFQUE =10,CHMMDP =CHMMDP_":  PL-ZIP MI SSING"
  5463   "RTN","CHF BC2A",433, 0)
  5464    Q
  5465   "RTN","CHF BCQ")
  5466   0^74^B2067 00247
  5467   "RTN","CHF BCQ",1,0)
  5468   CHFBCQ ;HA C/CR;SETS  UP QUEUES; Feb 05, 20 19@09:31:3 6
  5469   "RTN","CHF BCQ",2,0)
  5470    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  5471   "RTN","CHF BCQ",3,0)
  5472    ;CPTS - 1 0920  (AEB ), #11014  BY RLC, 13 920/JLR
  5473   "RTN","CHF BCQ",4,0)
  5474    ;CPTS 158 90 (AEB)
  5475   "RTN","CHF BCQ",5,0)
  5476    ;JSG;06/0 2/08;DEV00 4754-02;Ad d high dol lar reason  (with sec urity) for  Audit Sup port Queue
  5477   "RTN","CHF BCQ",6,0)
  5478    ;DEV00480 5 1/20/201 0 AEB
  5479   "RTN","CHF BCQ",7,0)
  5480    ;DEV01001 8-01 YJK 1 1/26/2010  - Paid Fil e Date Com pleted Ind ex
  5481   "RTN","CHF BCQ",8,0)
  5482    ;DEV01106 9 1/5/2011  AEB
  5483   "RTN","CHF BCQ",9,0)
  5484    ;Producti on fix 1/3 /12 DPT -  looping on  deleted c laims
  5485   "RTN","CHF BCQ",10,0)
  5486    ;DEV02124 4 JAK 09/0 3/14 -clea ring ded/c at cap/cos t share an d payment  informatio n before g oing to qu eue
  5487   "RTN","CHF BCQ",11,0)
  5488    ;ENC01586 3: EDI - C ODE 58 sto p and repl ace - keep  current s ystem logi c  BMJ 10/ 22/13
  5489   "RTN","CHF BCQ",12,0)
  5490    ;CPE005-1 00,102 BDB  12/27/201 7
  5491   "RTN","CHF BCQ",13,0)
  5492   LDQA I $D( @(GLPAY_"C I,""ZEMC"" ,""CMOP"") ")) S CHCM PCLI=CI,CH QNAM="AUDI T SUPPORT" ,CHQURSN=" ASQ/8" D ^ CHMXCPBP I  $D(CHCMPF G) K CHCMP FG G LDQE  ; ADDED BY  DTP (MAY/ 1995) FOR  CMOP PROJE CT
  5493   "RTN","CHF BCQ",14,0)
  5494   LDQA1 S DF N=$P(REC0, "^",21),BF N=$P(REC0, "^",22)
  5495   "RTN","CHF BCQ",15,0)
  5496    D NOW^%DT C S CHDT=%  I $D(^CHM ASQ("B",CH DT)) G LDQ A1
  5497   "RTN","CHF BCQ",16,0)
  5498    S (DIC,DL AYGO)=7410 10.05,DIC( 0)="ML",X= CHDT D ^DI C K DIC
  5499   "RTN","CHF BCQ",17,0)
  5500    G LDQA1:$ P(Y,"^",3) '=1
  5501   "RTN","CHF BCQ",18,0)
  5502    S CHMQNAM ="CHMASQ(" ,CHMIN=""  K CHMOUT D  ^CHMIS041
  5503   "RTN","CHF BCQ",19,0)
  5504    S ZJ=$O(@ (GLPAY_"CI ,""PDI"",9 99)"),-1)  Q:'ZJ
  5505   "RTN","CHF BCQ",20,0)
  5506    S:$D(@(GL PAY_"CI,"" PDI"",ZJ,0 )")) CHMFP DI=$P(^(0) ,"^",1)
  5507   "RTN","CHF BCQ",21,0)
  5508    S DA=+Y,D IE=741010. 05,DR=".02 ////^S X=C I;.03///^S  X=""`""_D UZ;.04///^ S X=CHMFPD I;.06///^S  X=1;.09// //^S X=DFN ;.1////^S  X=BFN"
  5509   "RTN","CHF BCQ",22,0)
  5510    D ^DIE K  DIE S:'$D( ^CHMASQ(DA ,1,0)) ^CH MASQ(DA,1, 0)="^74101 0.08SA^0^0 "
  5511   "RTN","CHF BCQ",23,0)
  5512    ;S:CHMFQU E=2 X=8 S: CHMFQUE=4  X=16 S:CHM FQUE=40 X= 17 D REASO N    ;JSG; DEV004754; See next l ine
  5513   "RTN","CHF BCQ",24,0)
  5514    S X=$S(CH MFQUE=2:$S ($D(HIDOLL AR):9,1:8) ,CHMFQUE=4 :16,CHMFQU E=40:17,1: X) ;JSG;DE V004754;2= 8!9
  5515   "RTN","CHF BCQ",25,0)
  5516    D REVCCD^ CHTFLIBC(C I)                ;re verse & cl ear ded/c. s./cat cap  from clai m DEV02124 4 JAK 08/2 6/14
  5517   "RTN","CHF BCQ",26,0)
  5518    D:(CHMFQU E'=2) CLRP MT^CHTFLIB 2(CI)  ;cl ear out pa yment data  except fo r HIGH dol lar DEV021 244 JAK 08 /26/14
  5519   "RTN","CHF BCQ",27,0)
  5520    D REASON  K HIDOLLAR                 ;JSG; DEV004754; Make sure  high $ fla g good for  only 1 cl aim
  5521   "RTN","CHF BCQ",28,0)
  5522    D ADDASQ
  5523   "RTN","CHF BCQ",29,0)
  5524    K DIC S C HMFPP="SQA UD",CHMFI= CI D ^CHMF WK02
  5525   "RTN","CHF BCQ",30,0)
  5526    Q
  5527   "RTN","CHF BCQ",31,0)
  5528   ADDASQ ; T HE FOLLOWI NG LINES R ETRIEVE TH E IMAGE *C R*
  5529   "RTN","CHF BCQ",32,0)
  5530    ;N (CHCLM ,DUZ)
  5531   "RTN","CHF BCQ",33,0)
  5532    S CHSS=""  I $D(^CHM IMD(741020 .02,"B","P ARAMETER") ) D
  5533   "RTN","CHF BCQ",34,0)
  5534    .S Y=$O(^ CHMIMD(741 020.02,"B" ,"PARAMETE R",0)) Q:Y =""
  5535   "RTN","CHF BCQ",35,0)
  5536    .Q:'$D(^C HMIMD(7410 20.02,Y,11 ))  S CHSS =$P(^(11), "^",4)
  5537   "RTN","CHF BCQ",36,0)
  5538    .Q:CHSS=" "  Q:'$D(^ VA(200,"ZV MS",CHSS))
  5539   "RTN","CHF BCQ",37,0)
  5540    .S CHDUZ= $O(^VA(200 ,"ZVMS",CH SS,0)) Q
  5541   "RTN","CHF BCQ",38,0)
  5542    Q:'$D(CHS S)  Q:CHSS =""  Q:'$D (CI)  Q:CI =""
  5543   "RTN","CHF BCQ",39,0)
  5544    S CHPDIJ= 0,CHDOCID= "",CHMIMFL =1,CHIMMVE =1,CHOPER= "CHIMMVE"
  5545   "RTN","CHF BCQ",40,0)
  5546    F  S CHPD IJ=$O(@(GL PAY_"CI,"" PDI"",CHPD IJ)")) Q:' CHPDIJ  D
  5547   "RTN","CHF BCQ",41,0)
  5548    .Q:'$D(^( CHPDIJ,0))   S CHPDI= $P(^(0),"^ ",1)
  5549   "RTN","CHF BCQ",42,0)
  5550    .Q:'$D(^C HMIMG(CHPD I,"DOC"))   S CHDOCID =$P(^("DOC "),"^",1)  D ADD^CHMM F
  5551   "RTN","CHF BCQ",43,0)
  5552    K CHSS,Y, CHDUZ,CHPD IJ,CHDOCID ,CHIMFL,CH IMMVE,CHOP ER,CHPDI Q
  5553   "RTN","CHF BCQ",44,0)
  5554    ;
  5555   "RTN","CHF BCQ",45,0)
  5556   REASON S D A(1)=DA,(D IC,DLAYGO) ="^CHMASQ( DA(1),1,", DIC(0)="ML " D ^DIC K  DIC Q
  5557   "RTN","CHF BCQ",46,0)
  5558    ;
  5559   "RTN","CHF BCQ",47,0)
  5560   LDQB I $D( @(GLPAY_"C I,""ZEMC"" ,""CMOP"") ")) S CHCM PCLI=CI,CH QNAM="CAPP S",CHQURSN ="EOB/10"  D ^CHMXCPB P I $D(CHC MPFG) K CH CMPFG Q  ;  ADDED BY  DTP (MAY/1 995) FOR C MOP PROJEC T
  5561   "RTN","CHF BCQ",48,0)
  5562    S CHINHCL =CI D ^CHM G281 I $D( CHIHFLG) K  CHIHFLG Q
  5563   "RTN","CHF BCQ",49,0)
  5564    ;
  5565   "RTN","CHF BCQ",50,0)
  5566   LDQB2 S:'$ D(CHPGPT)  CHPGPT=$P( ^CHMINDEX( CI,0),U,1)
  5567   "RTN","CHF BCQ",51,0)
  5568    I CHPGPT= 5 S CLMPT= CI D S2^CH FBCQ1 Q
  5569   "RTN","CHF BCQ",52,0)
  5570    I (CHPGPT =6)!(CHPGP T=7) S REA S=$P(^CHMD IC(741002. 34,1,3),"^ ",15) D RO REAS
  5571   "RTN","CHF BCQ",53,0)
  5572    I CHPGPT< 3 S REAS=3 19 D ROREA S S REAS=3 22 D ROREA S
  5573   "RTN","CHF BCQ",54,0)
  5574    I (+$P(@( GLPAY_"CI, 1)"),"^",1 )=0)!((+$P (@(GLPAY_" CI,1)"),"^ ",14)=0)&( +$P(@(GLPA Y_"CI,1)") ,"^",15)=0 )) S CHMFQ UE=1,$P(@( GLPAY_"CI, 0)"),"^",1 1)=0,$P(@( GLPAY_"CI, 0)"),"^",1 2)=0 G LDQ E
  5575   "RTN","CHF BCQ",55,0)
  5576    I $P(@(GL PAY_"CI,0) "),"^",5)' =1 S CHOUT ="741008.0 5",CHEND=" 01P" D  Q
  5577   "RTN","CHF BCQ",56,0)
  5578    .S $P(@(G LPAY_"CI,0 )"),"^",12 )=0,$P(@(G LPAY_"CI,0 )"),"^",11 )=1 D SSNA Q Q
  5579   "RTN","CHF BCQ",57,0)
  5580    I ($P(@(G LPAY_"CI,0 )"),"^",5) =1)&(+$P(@ (GLPAY_"CI ,1)"),"^", 14)=0) D   Q
  5581   "RTN","CHF BCQ",58,0)
  5582    .S CHOUT= "741008.05 ",CHEND="0 1P",$P(@(G LPAY_"CI,0 )"),"^",12 )=0
  5583   "RTN","CHF BCQ",59,0)
  5584    .S $P(@(G LPAY_"CI,0 )"),"^",11 )=1 D SSNA Q Q
  5585   "RTN","CHF BCQ",60,0)
  5586    I ($P(@(G LPAY_"CI,0 )"),"^",5) =1)&(+$P(@ (GLPAY_"CI ,1)"),"^", 15)=0) D   Q
  5587   "RTN","CHF BCQ",61,0)
  5588    .S CHOUT= "741008.03 ",CHEND="0 1PA",$P(@( GLPAY_"CI, 0)"),"^",1 2)=1
  5589   "RTN","CHF BCQ",62,0)
  5590    .S $P(@(G LPAY_"CI,0 )"),"^",11 )=0 D SSNA Q Q
  5591   "RTN","CHF BCQ",63,0)
  5592    I ($P(@(G LPAY_"CI,0 )"),"^",5) =1)&(+$P(@ (GLPAY_"CI ,1)"),"^", 14)'=0)&($ P(@(GLPAY_ "CI,1)")," ^",15)'=0)  D  Q
  5593   "RTN","CHF BCQ",64,0)
  5594    .S CHOUT= "741008.05 ",CHEND="0 1P",$P(@(G LPAY_"CI,0 )"),"^",12 )=1
  5595   "RTN","CHF BCQ",65,0)
  5596    .S $P(@(G LPAY_"CI,0 )"),"^",11 )=1 D SSNA Q S CHOUT= "741008.03 ",CHEND="0 1PA" D SSN AQ Q
  5597   "RTN","CHF BCQ",66,0)
  5598   SSNAQ I ($ D(^CHMSNA( CHOUT,"C", CI)))!($D( ^CHMSNA(CH OUT,"ARCHI VE",CI)))  D ^CHMFBCC R Q:CHREJ
  5599   "RTN","CHF BCQ",67,0)
  5600    I $P(@(GL PAY_"CI,0) "),"^",2)= 10 Q ;PROD  1/3/12 DP T
  5601   "RTN","CHF BCQ",68,0)
  5602    L ^CHMSNA (CHOUT) S  CHMBTCH=$P (^CHMSNA(C HOUT,0),"^ ",3)
  5603   "RTN","CHF BCQ",69,0)
  5604    I CHOUT=" 741008.05"  S:$D(@(GL PAY_"CI,1) ")) $P(^CH MSNA(CHOUT ,CHMBTCH,0 ),"^",6)=$ P(^CHMSNA( CHOUT,CHMB TCH,0),"^" ,6)+$P(@(G LPAY_"CI,1 )"),"^",15 )
  5605   "RTN","CHF BCQ",70,0)
  5606    I CHOUT=" 741008.03"  S:$D(@(GL PAY_"CI,1) ")) $P(^CH MSNA(CHOUT ,CHMBTCH,0 ),"^",6)=$ P(^CHMSNA( CHOUT,CHMB TCH,0),"^" ,6)+$P(@(G LPAY_"CI,1 )"),"^",14 )
  5607   "RTN","CHF BCQ",71,0)
  5608    S:'$D(^CH MSNA(CHOUT ,CHMBTCH,1 ,0)) ^CHMS NA(CHOUT,C HMBTCH,1,0 )="^"_CHOU T_CHEND_"^ 0^0"
  5609   "RTN","CHF BCQ",72,0)
  5610    S DA(1)=C HMBTCH,DLA YGO=CHOUT
  5611   "RTN","CHF BCQ",73,0)
  5612    S DIC="^C HMSNA("_CH OUT_","_DA (1)_",1,", X=CN,DIC(0 )="ML" D ^ DIC K DIC, DLAYGO L
  5613   "RTN","CHF BCQ",74,0)
  5614    G:$P(Y,"^ ",3)'=1 SS NAQ I $D(C HRSUB) D
  5615   "RTN","CHF BCQ",75,0)
  5616    .Q:'CHRSU B
  5617   "RTN","CHF BCQ",76,0)
  5618    .S I=0,I= $O(^CHMSNA (741008.03 ,"C",CI,I) ) Q:'I  S  J=0
  5619   "RTN","CHF BCQ",77,0)
  5620    .S J=$O(^ CHMSNA(741 008.03,"C" ,CI,I,J))  Q:'J
  5621   "RTN","CHF BCQ",78,0)
  5622    .;S ^CHMS NA(741008. 05,DA(1),1 ,+Y,10)="1 ^"_I_"^"_J
  5623   "RTN","CHF BCQ",79,0)
  5624    .;S ^CHMS NA(741008. 03,I,1,J,1 0)="1^"_DA (1)_"^"_+Y  K CHRSUB  Q
  5625   "RTN","CHF BCQ",80,0)
  5626    ;D NOW^%D TC S CHDT= %,$P(@(GLP AY_"CI,0)" ),"^",10)= CHDT,$P(@( GLPAY_"CI, 0)"),"^",2 )=2 ;DEV01 0018-01 YJ K 11/26/20 10 REPLACE D WITH DIE  CALL:
  5627   "RTN","CHF BCQ",81,0)
  5628    D NOW^%DT C S CHDT=%  S DA=CI S  DIE=74100 0, DR=".02 ///^S X=2; .1///^S X= CHDT" D ^D IE K DIE ; DEV010018- 01 YJK 11/ 26/2010
  5629   "RTN","CHF BCQ",82,0)
  5630    D PAIDRVS L(CI)   ;D EV005311,  SKD, 7-23- 08
  5631   "RTN","CHF BCQ",83,0)
  5632    S:CHOUT=" 741008.05"  CHMFPP="S QCALO" S:C HOUT="7410 08.03" CHM FPP="SQCAP O" S CHMFI =CI D ^CHM FWK02
  5633   "RTN","CHF BCQ",84,0)
  5634    S CHMQNAM ="CHMSNA(" _CHOUT_"," ,CHMIN=""  K CHMOUT D  ^CHMIS041
  5635   "RTN","CHF BCQ",85,0)
  5636    Q
  5637   "RTN","CHF BCQ",86,0)
  5638    ;
  5639   "RTN","CHF BCQ",87,0)
  5640   LDQE I $D( ^CHNVPAY(C I)) I '$D( ^CHMQAQ("D ",CI)) D   Q
  5641   "RTN","CHF BCQ",88,0)
  5642    .S $P(^CH NVPAY(CI,0 ),"^",2)=1
  5643   "RTN","CHF BCQ",89,0)
  5644    .S CHMFQU E=38 D LDQ Q Q
  5645   "RTN","CHF BCQ",90,0)
  5646    I $D(@(GL PAY_"CI,"" ZEMC"",""C MOP"")"))  S CHCMPCLI =CI,CHQNAM ="EOB" D   D ^CHMXCPB P I $D(CHC MPFG) K CH CMPFG Q  ;  ADDED BY  DTP (MAY/1 995) FOR C MOP PROJEC T
  5647   "RTN","CHF BCQ",91,0)
  5648    .S:'$D(CH QURSN) CHQ URSN=$S(CH MFQUE=1:"E OB/2",CHMF QUE=12:"EO B/3",CHMFQ UE=13:"EOB /4",CHMFQU E=15:"EOB/ 6",CHMFQUE =17:"EOB/5 ",CHMFQUE= 25:"EOB/12 ",CHMFQUE= 32:"EOB/6" ,CHMFQUE=3 5:"EOB/3", 1:"EOB/10" )
  5649   "RTN","CHF BCQ",92,0)
  5650    .I (CHMFQ UE=12)!(CH MFQUE=13)! (CHMFQUE=1 5)!(CHMFQU E=16)!(CHM FQUE=25)!( CHMFQUE=32 )!(CHMFQUE =35) S CHR JFG=""
  5651   "RTN","CHF BCQ",93,0)
  5652    S CHINHCL =CI D ^CHM G280 I $D( CHIHFLG) K  CHIHFLG Q
  5653   "RTN","CHF BCQ",94,0)
  5654   LDQEE1 ;
  5655   "RTN","CHF BCQ",95,0)
  5656   LDQEE11 ;A LL OF THIS  WAS COMME NTED OFF I N CHMFBCQ
  5657   "RTN","CHF BCQ",96,0)
  5658   LDQEE2 I $ D(@(GLPAY_ "CI,6)"))  D CKRO
  5659   "RTN","CHF BCQ",97,0)
  5660    I $D(@(GL PAY_"CI,6) ")) D CKRO EDI ;BDB 1 2/27/2017
  5661   "RTN","CHF BCQ",98,0)
  5662    I $D(CHMF RQUE) S CH RSN="REB"  G LDQE1
  5663   "RTN","CHF BCQ",99,0)
  5664    S CHRSN=$ S(CHMFQUE= 1:"ZE",CHM FQUE=12:"D X",CHMFQUE =13:"CH",C HMFQUE=17: "AS",CHMFQ UE=25:"QA" ,CHMFQUE=2 9:"OTH",CH MFQUE=30:" OTH",CHMFQ UE=99:"PAY ",CHMFQUE= 35:"DRG",1 :"OTH")
  5665   "RTN","CHF BCQ",100,0 )
  5666   LDQE1 I $D (@(GLPAY_" CI,""ZEMC" ",""CMOP"" )")) S CHC MPCLI=CI,C HQNAM="EOB " D  D ^CH MXCPBP I $ D(CHCMPFG)  K CHCMPFG  Q  ; ADDE D BY DTP ( MAY/1995)  FOR CMOP P ROJECT
  5667   "RTN","CHF BCQ",101,0 )
  5668    .S:'$D(CH QURSN) CHQ URSN=$S(CH MFQUE=1:"E OB/2",CHMF QUE=12:"EO B/3",CHMFQ UE=13:"EOB /4",CHMFQU E=15:"EOB/ 6",CHMFQUE =17:"EOB/5 ",CHMFQUE= 25:"EOB/12 ",CHMFQUE= 32:"EOB/6" ,CHMFQUE=3 5:"EOB/3", 1:"EOB/10" )
  5669   "RTN","CHF BCQ",102,0 )
  5670    .I (CHMFQ UE=12)!(CH MFQUE=13)! (CHMFQUE=1 5)!(CHMFQU E=16)!(CHM FQUE=25)!( CHMFQUE=32 )!(CHMFQUE =35) S CHR JFG=""
  5671   "RTN","CHF BCQ",103,0 )
  5672    D NOW^%DT C S CHDT=%  I $D(^CHM EOBQ("B",C HDT)) G LD QE1
  5673   "RTN","CHF BCQ",104,0 )
  5674    S CHRES=" "
  5675   "RTN","CHF BCQ",105,0 )
  5676    I $D(@(GL PAY_"CI,0) ")),($P(@( GLPAY_"CI, 0)"),"^",1 3)'="") S  CHRES=CHRE S_": "_$P( @(GLPAY_"C I,0)"),"^" ,13) G LDQ E2
  5677   "RTN","CHF BCQ",106,0 )
  5678    G:$D(CHMF RQUE) LDQE 2
  5679   "RTN","CHF BCQ",107,0 )
  5680    S:CHMFQUE =12 CHRES= CHRES_": " _$P(^CHMDI C(741002.3 4,1,2),"^" ,7)
  5681   "RTN","CHF BCQ",108,0 )
  5682    S:CHMFQUE =13 CHRES= CHRES_": " _$P(^CHMDI C(741002.3 4,1,2),"^" ,3)
  5683   "RTN","CHF BCQ",109,0 )
  5684    S:CHMFQUE =35 CHRES= CHRES_": " _$P(^CHMDI C(741002.3 4,1,3),"^" ,8)
  5685   "RTN","CHF BCQ",110,0 )
  5686   LDQE2 S X1 =CI D PROG TYP^CHFCD0 01
  5687   "RTN","CHF BCQ",111,0 )
  5688    S DLAYGO= +$P(@(GLEO B_"0)"),"^ ",2)
  5689   "RTN","CHF BCQ",112,0 )
  5690    S DIC=GLE OB,DIC(0)= "ML",X=CHD T D ^DIC K  DIC
  5691   "RTN","CHF BCQ",113,0 )
  5692    G LDQE1:$ P(Y,"^",3) '=1
  5693   "RTN","CHF BCQ",114,0 )
  5694    S DA=+Y,D IE=GLEOB,D R=".02//// ^S X=CI;.0 3///^S X=0 ;.04///^S  X=CHRSN;.0 6///^S X=C HRES" D ^D IE K DIE
  5695   "RTN","CHF BCQ",115,0 )
  5696    I $D(@(GL PAY_"CI,"" ZEMC"")"))  S CHMQNAM ="CHMEDIQ( ",CHMOUT=" " K CHMIN  D ^CHMIS04 1
  5697   "RTN","CHF BCQ",116,0 )
  5698    D NOW^%DT C S CHDT=%  S DA=CI S  DIE=74100 0, DR=".1/ //^S X=CHD T" D ^DIE  K DIE ;DEV 010018-01  YJK 11/26/ 2010
  5699   "RTN","CHF BCQ",117,0 )
  5700    I (CHRSN= "ZE")!(CHR SN="OTH")! (CHRSN="PA Y") S $P(@ (GLPAY_"CI ,0)"),"^", 2)=4 D PAI DRVSL(CI)    ;DEV0053 11, SKD, 7 -23-08
  5701   "RTN","CHF BCQ",118,0 )
  5702    S:(CHRSN= "DX")!(CHR SN="CH")!( CHRSN="AS" )!(CHRSN=" QA")!(CHRS N="DRG")!( CHRSN="REB ") $P(@(GL PAY_"CI,0) "),"^",2)= 0
  5703   "RTN","CHF BCQ",119,0 )
  5704    S CHMFPP= "SQEOB",CH MFI=CI D ^ CHMFWK02 K  CHRES
  5705   "RTN","CHF BCQ",120,0 )
  5706    S CHMQNAM ="CHMEOBQ( ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  5707   "RTN","CHF BCQ",121,0 )
  5708    Q
  5709   "RTN","CHF BCQ",122,0 )
  5710    ;
  5711   "RTN","CHF BCQ",123,0 )
  5712   LDQM I $D( @(GLPAY_"C I,""ZEMC"" ,""CMOP"") ")) S CHCM PCLI=CI,CH QNAM="MISS ING DATA"  D ^CHMXCPB P I $D(CHC MPFG) K CH CMPFG G LD QE ; ADDED  BY DTP (M AY/1995) F OR CMOP PR OJECT
  5713   "RTN","CHF BCQ",124,0 )
  5714    S (CHQI,C HEX)=0 F   S CHQI=$O( ^CHMMDQ("C ",CI,CHQI) ) Q:'CHQI   I $D(^CHM MDQ(CHQI,0 )) S:$P(^C HMMDQ(CHQI ,0),"^",3) '=2 CHEX=1
  5715   "RTN","CHF BCQ",125,0 )
  5716    Q:CHEX=1
  5717   "RTN","CHF BCQ",126,0 )
  5718    S (CHREJF LG,CHQI)=0  F  S CHQI =$O(^CHMMD Q("C",CI,C HQI)) Q:'C HQI  I $D( ^CHMMDQ(CH QI,0)) I $ P(^CHMMDQ( CHQI,0),"^ ",3)=2 I $ P(^CHMMDQ( CHQI,0),"^ ",6)=2 S C HREJFLG=1   ;AEB 1/20 /2010 DEV0 04805 REJ  CLAIM IF A LREADY IN  mdq FOR PO A AEB 1/5/ 2011 DEV01 1069
  5719   "RTN","CHF BCQ",127,0 )
  5720    ;I CHREJF LG=1 S CHR EJ=CI,CHGR P="OTH",RE AS=58 D ^C HMFREJ G L DQE   ;AEB  1/20/2010  DEV004805  REJ CLAIM  IF ALREAD Y IN mdq F OR POA
  5721   "RTN","CHF BCQ",128,0 )
  5722    I CHREJFL G=1 S CHRE J=CI,CHGRP ="OTH",REA S=400 D ^C HMFREJ G L DQE   ;ENC 015863: ED I - CODE 5 8 stop and  replace -  keep curr ent system  logic BMJ  04/14/15
  5723   "RTN","CHF BCQ",129,0 )
  5724    S (CHREJF LG,CHQI)=0  F  S CHQI =$O(^CHMMD Q("C",CI,C HQI)) Q:'C HQI  I $D( ^CHMMDQ(CH QI,0)) I $ P(^CHMMDQ( CHQI,0),"^ ",3)=2 I $ P(^CHMMDQ( CHQI,0),"^ ",6)=8 S C HREJFLG=1   ;AEB 1/20 /2010 DEV0 04805 REJ  CLAIM IF A LREADY IN  mdq FOR PO A AEB 1/5/ 2011 DEV01 1069
  5725   "RTN","CHF BCQ",130,0 )
  5726    I CHREJFL G=1 S CHRE J=CI,CHGRP ="OTH",REA S=373 D ^C HMFREJ G L DQE  ;AEB  1/20/2010  DEV004805  REJ CLAIM  IF ALREADY  IN mdq FO R POA
  5727   "RTN","CHF BCQ",131,0 )
  5728    S CHMMDR= $S((CHMFQU E=6)&('$D( @(GLPAY_"C I,""ADD"") "))):0,CHM FQUE=18:0, CHMFQUE=7: 1,CHMFQUE= 10:2,CHMFQ UE=11:3,(C HMFQUE=6)& ($D(@(GLPA Y_"CI,""AD D"")"))):4 ,1:5)
  5729   "RTN","CHF BCQ",132,0 )
  5730    I $P(^CHM PAY(CI,"CO MMON"),"^" ,9)=5 S CH MMDR=8,CHM MDP="POA I S MISSING  OR INVALID "
  5731   "RTN","CHF BCQ",133,0 )
  5732   LDQM1 D NO W^%DTC S C HDT=% I $D (^CHMMDQ(" B",CHDT))  G LDQM1
  5733   "RTN","CHF BCQ",134,0 )
  5734    S (DIC,DL AYGO)=7410 10.11,DIC( 0)="ML",X= CHDT D ^DI C K DIC
  5735   "RTN","CHF BCQ",135,0 )
  5736    G LDQM1:$ P(Y,"^",3) '=1
  5737   "RTN","CHF BCQ",136,0 )
  5738    I '$D(CI)  S DA=+Y,D IE=741010. 11,DR=".03 ///^S X=0; .06///^S X =CHMMDR;.0 7///^S X=C HMMDP" D ^ DIE K DIE, DR Q
  5739   "RTN","CHF BCQ",137,0 )
  5740    S DA=+Y,D IE=741010. 11,DR=".02 ////^S X=C I;.03///^S  X=0;.06// /^S X=CHMM DR;.07///^ S X=CHMMDP " D ^DIE K  DIE,DR
  5741   "RTN","CHF BCQ",138,0 )
  5742    D REVCCD^ CHTFLIBC(C I)  ;rever se & clear  ded/c.s./ cat cap fr om claim D EV021244 J AK 09/03/1 4
  5743   "RTN","CHF BCQ",139,0 )
  5744    D CLRPMT^ CHTFLIB2(C I)  ;clear  payment d ata from c laim DEV02 1244 JAK 0 9/03/14
  5745   "RTN","CHF BCQ",140,0 )
  5746    S CHMFPP= "SQMSD",CH MFI=CI D ^ CHMFWK02
  5747   "RTN","CHF BCQ",141,0 )
  5748    S CHMQNAM ="CHMMDQ(" ,CHMIN=""  K CHMOUT D  ^CHMIS041
  5749   "RTN","CHF BCQ",142,0 )
  5750    Q
  5751   "RTN","CHF BCQ",143,0 )
  5752    ;
  5753   "RTN","CHF BCQ",144,0 )
  5754    ;skd, 1-2 5-06 to re direct fro m MDQ to V Q per IDME  project
  5755   "RTN","CHF BCQ",145,0 )
  5756    ;ADD A NE W ENTRY TO  VQ
  5757   "RTN","CHF BCQ",146,0 )
  5758   LDQV ;ADD  A NEW ENTR Y TO VQ
  5759   "RTN","CHF BCQ",147,0 )
  5760    D NOW^%DT C S X=%
  5761   "RTN","CHF BCQ",148,0 )
  5762    S DIC(0)= "LM"
  5763   "RTN","CHF BCQ",149,0 )
  5764    S (DIC,DL AYGO)=7410 50.01
  5765   "RTN","CHF BCQ",150,0 )
  5766    D ^DIC
  5767   "RTN","CHF BCQ",151,0 )
  5768    I $P(Y,U, 3)'=1 G LD QV
  5769   "RTN","CHF BCQ",152,0 )
  5770    S CHI=+Y
  5771   "RTN","CHF BCQ",153,0 )
  5772    D GVDTA
  5773   "RTN","CHF BCQ",154,0 )
  5774    S STATUS= 0,DA=CHI,D IE=741050. 01
  5775   "RTN","CHF BCQ",155,0 )
  5776    S DR=".02 ///^S X=PV (5);.03/// ^S X=STATU S;.09///^S  X=CHMMDP; .11///^S X =0;1.01/// ^S X=PV(4) "
  5777   "RTN","CHF BCQ",156,0 )
  5778    D ^DIE K  DIE,DR
  5779   "RTN","CHF BCQ",157,0 )
  5780    D SETVDTA ,STKCLM
  5781   "RTN","CHF BCQ",158,0 )
  5782    D REVCCD^ CHTFLIBC(C I)  ;rever se & clear  ded/c.s./ cat cap fr om claim D EV021244 J AK 09/03/1 4
  5783   "RTN","CHF BCQ",159,0 )
  5784    D CLRPMT^ CHTFLIB2(C I)  ;clear  payment d ata from c laim DEV02 1244 JAK 0 9/03/14
  5785   "RTN","CHF BCQ",160,0 )
  5786    S CHMFPP= "SQVEN",CH MFI=CI D ^ CHMFWK02
  5787   "RTN","CHF BCQ",161,0 )
  5788    S CHMQNAM ="CHMQVN(" ,CHMIN=""  K CHMOUT D  ^CHMIS041
  5789   "RTN","CHF BCQ",162,0 )
  5790    Q
  5791   "RTN","CHF BCQ",163,0 )
  5792    ;
  5793   "RTN","CHF BCQ",164,0 )
  5794   GVDTA ;GET  DATA FROM  VENDOR FI LE
  5795   "RTN","CHF BCQ",165,0 )
  5796    S (REC0,R EC1)=""
  5797   "RTN","CHF BCQ",166,0 )
  5798    S VFN=CHV X   ;=VI   ;SKD, 2-21 -06
  5799   "RTN","CHF BCQ",167,0 )
  5800    S REC0=$G (^CHMVEN(V FN,0))
  5801   "RTN","CHF BCQ",168,0 )
  5802    S REC1=$G (^CHMVEN(V FN,1))
  5803   "RTN","CHF BCQ",169,0 )
  5804    F R=1:1:2 1 S PV(R)= ""
  5805   "RTN","CHF BCQ",170,0 )
  5806    S PV(1)=$ G(VFN) ; V ENDOR POIN TER
  5807   "RTN","CHF BCQ",171,0 )
  5808    S PV(2)=$ P(REC0,U,1 4) ; VENDO RIZATION P OINTER
  5809   "RTN","CHF BCQ",172,0 )
  5810    S PV(3)=" " ; VENDOR IZATION ST RING
  5811   "RTN","CHF BCQ",173,0 )
  5812    S PV(4)=$ P(REC0,U,1 ) ; VENDOR  NAME
  5813   "RTN","CHF BCQ",174,0 )
  5814    S PV(5)=$ P(REC0,U,3 ) ; VENDOR  TAX ID
  5815   "RTN","CHF BCQ",175,0 )
  5816    S PV(6)=$ P(REC0,U,7 ) ; SSN
  5817   "RTN","CHF BCQ",176,0 )
  5818    S PV(7)=$ P(REC1,U,1 ) ; ADDR1
  5819   "RTN","CHF BCQ",177,0 )
  5820    S PV(8)=$ P(REC1,U,2 ) ; ADDR2
  5821   "RTN","CHF BCQ",178,0 )
  5822    S PV(9)=$ P(REC1,U,3 ) ; CITY
  5823   "RTN","CHF BCQ",179,0 )
  5824    S PV(10)= $P(REC1,U, 4) ; STATE
  5825   "RTN","CHF BCQ",180,0 )
  5826    S PV(11)= $P(REC1,U, 5) ; ZIP
  5827   "RTN","CHF BCQ",181,0 )
  5828    S PV(12)= $P(REC1,U, 7) ; FACIL ITY TYPE
  5829   "RTN","CHF BCQ",182,0 )
  5830    S PV(13)= $P(REC1,U, 13) ; CLAS SIF. TYPE
  5831   "RTN","CHF BCQ",183,0 )
  5832    S PV(14)= $P(REC1,U, 11) ; SPEC IALTY
  5833   "RTN","CHF BCQ",184,0 )
  5834    S PV(15)= $P(REC1,U, 6) ; PHONE
  5835   "RTN","CHF BCQ",185,0 )
  5836    S PV(16)= $P(REC1,U, 9) ; AUSTI N VERIFY
  5837   "RTN","CHF BCQ",186,0 )
  5838    S PV(17)= $P(REC0,U, 19) ; DISC RETE PSYCH
  5839   "RTN","CHF BCQ",187,0 )
  5840    S PV(18)= $P(REC0,U, 21) ; DISC RETE REHAB
  5841   "RTN","CHF BCQ",188,0 )
  5842    S PV(19)= $P(REC0,U, 22) ; DISC RETE RTC
  5843   "RTN","CHF BCQ",189,0 )
  5844    S PV(20)= $P(REC1,U, 8) ; NON-P PS
  5845   "RTN","CHF BCQ",190,0 )
  5846    I $D(^CHM VEN(VFN,40 )) S PV(21 )=$P(^CHMV EN(VFN,40) ,U,1) ; CM AC
  5847   "RTN","CHF BCQ",191,0 )
  5848    Q
  5849   "RTN","CHF BCQ",192,0 )
  5850    ;
  5851   "RTN","CHF BCQ",193,0 )
  5852   SETVDTA ;S ET DATA FR OM VENDOR  FILE INTO  VQ WORK FI LE
  5853   "RTN","CHF BCQ",194,0 )
  5854    S $P(^CHM QVN(CHI,1) ,U,1)=PV(4 )
  5855   "RTN","CHF BCQ",195,0 )
  5856    S $P(^CHM QVN(CHI,1) ,U,2)=PV(5 )
  5857   "RTN","CHF BCQ",196,0 )
  5858    S $P(^CHM QVN(CHI,1) ,U,3)=PV(6 )
  5859   "RTN","CHF BCQ",197,0 )
  5860    S $P(^CHM QVN(CHI,1) ,U,4)=PV(7 )
  5861   "RTN","CHF BCQ",198,0 )
  5862    S $P(^CHM QVN(CHI,1) ,U,5)=PV(8 )
  5863   "RTN","CHF BCQ",199,0 )
  5864    S $P(^CHM QVN(CHI,1) ,U,6)=PV(9 )
  5865   "RTN","CHF BCQ",200,0 )
  5866    S $P(^CHM QVN(CHI,1) ,U,7)=PV(1 0)
  5867   "RTN","CHF BCQ",201,0 )
  5868    S $P(^CHM QVN(CHI,1) ,U,8)=PV(1 1)
  5869   "RTN","CHF BCQ",202,0 )
  5870    S $P(^CHM QVN(CHI,1) ,U,09)=PV( 15)
  5871   "RTN","CHF BCQ",203,0 )
  5872    S $P(^CHM QVN(CHI,1) ,U,10)=PV( 12)
  5873   "RTN","CHF BCQ",204,0 )
  5874    S $P(^CHM QVN(CHI,1) ,U,11)=PV( 13)
  5875   "RTN","CHF BCQ",205,0 )
  5876    S $P(^CHM QVN(CHI,1) ,U,12)=PV( 14)
  5877   "RTN","CHF BCQ",206,0 )
  5878    S $P(^CHM QVN(CHI,1) ,U,13)=PV( 16)
  5879   "RTN","CHF BCQ",207,0 )
  5880    I PV(17)= "" S $P(^C HMQVN(CHI, 1),U,15)=0
  5881   "RTN","CHF BCQ",208,0 )
  5882    E  S $P(^ CHMQVN(CHI ,1),U,15)= PV(17)
  5883   "RTN","CHF BCQ",209,0 )
  5884    I PV(18)= "" S $P(^C HMQVN(CHI, 1),U,16)=0
  5885   "RTN","CHF BCQ",210,0 )
  5886    E  S $P(^ CHMQVN(CHI ,1),U,16)= PV(18)
  5887   "RTN","CHF BCQ",211,0 )
  5888    I PV(19)= "" S $P(^C HMQVN(CHI, 1),U,17)=0
  5889   "RTN","CHF BCQ",212,0 )
  5890    E  S $P(^ CHMQVN(CHI ,1),U,17)= PV(19)
  5891   "RTN","CHF BCQ",213,0 )
  5892    I PV(20)= "" S $P(^C HMQVN(CHI, 1),U,18)=0
  5893   "RTN","CHF BCQ",214,0 )
  5894    E  S $P(^ CHMQVN(CHI ,1),U,18)= PV(20)
  5895   "RTN","CHF BCQ",215,0 )
  5896    I PV(21)= "" S $P(^C HMQVN(CHI, 1),U,19)=3
  5897   "RTN","CHF BCQ",216,0 )
  5898    E  S $P(^ CHMQVN(CHI ,1),U,19)= PV(21)
  5899   "RTN","CHF BCQ",217,0 )
  5900    Q
  5901   "RTN","CHF BCQ",218,0 )
  5902    ;
  5903   "RTN","CHF BCQ",219,0 )
  5904   STKCLM ;SE T CLAIM IN TO THE VEN DOR QUEUE
  5905   "RTN","CHF BCQ",220,0 )
  5906    Q:CHI=""   Q:'$G(CI)
  5907   "RTN","CHF BCQ",221,0 )
  5908    I '$D(^CH MQVN(CHI,1 0,0)) S ^C HMQVN(CHI, 10,0)="^74 1050.02^0^ 0"
  5909   "RTN","CHF BCQ",222,0 )
  5910    S X=$P(^C HMPAY(CI,0 ),"^",1)
  5911   "RTN","CHF BCQ",223,0 )
  5912    S DA(1)=C HI
  5913   "RTN","CHF BCQ",224,0 )
  5914    S DIC="^C HMQVN("_DA (1)_",10,"
  5915   "RTN","CHF BCQ",225,0 )
  5916    S DIC(0)= "LM"
  5917   "RTN","CHF BCQ",226,0 )
  5918    S DLAYGO= 741050.02
  5919   "RTN","CHF BCQ",227,0 )
  5920    D ^DIC
  5921   "RTN","CHF BCQ",228,0 )
  5922    I $P(Y,U, 3)'=1 G ST KCLM
  5923   "RTN","CHF BCQ",229,0 )
  5924    S DA=+Y
  5925   "RTN","CHF BCQ",230,0 )
  5926    D NOW^%DT C S CHDTTM =%
  5927   "RTN","CHF BCQ",231,0 )
  5928    S (CHI3,C HJ3)=""
  5929   "RTN","CHF BCQ",232,0 )
  5930    S DA(1)=C HI S DIE=" ^CHMQVN("_ DA(1)_",10 ,",CHI3=DA (1),CHJ3=D A
  5931   "RTN","CHF BCQ",233,0 )
  5932    S DR=".02 ///^S X=CH DTTM;.06// /^S X=0;.0 7///^S X=C HMMDP" D ^ DIE
  5933   "RTN","CHF BCQ",234,0 )
  5934    Q
  5935   "RTN","CHF BCQ",235,0 )
  5936    ;
  5937   "RTN","CHF BCQ",236,0 )
  5938   LDQQ I $D( @(GLPAY_"C I,""ZEMC"" ,""CMOP"") ")) S CHCM PCLI=CI,CH QNAM="QUAL ITY ASSURA NCE" D  D  ^CHMXCPBP  I $D(CHCMP FG) K CHCM PFG G LDQE  ; ADDED B Y DTP (MAY /1995) FOR  CMOP PROJ ECT
  5939   "RTN","CHF BCQ",237,0 )
  5940    .S CHQURS N=$S(CHMFQ UE=5:"QAQ/ 1",CHMFQUE =20:"QAQ/2 ",CHMFQUE= 21:"QAQ/3" ,CHMFQUE=2 2:"QAQ/4", CHMFQUE=23 :"QAQ/5",C HMFQUE=24: "QAQ/6",CH MFQUE=28:" QAQ/7",CHM FQUE=33:"Q AQ/8",1:"" )
  5941   "RTN","CHF BCQ",238,0 )
  5942    S CHQI=$O (^CHMQAQ(" D",CI,0))
  5943   "RTN","CHF BCQ",239,0 )
  5944   LDQQ1 S CH MFPDI="" D :$D(@(GLPA Y_"CI,""PD I"")"))
  5945   "RTN","CHF BCQ",240,0 )
  5946    .S X=$O(@ (GLPAY_"CI ,""PDI"",9 99)"),-1)  Q:'X  Q:'$ D(^(X,0))
  5947   "RTN","CHF BCQ",241,0 )
  5948    .S CHMFPD I=$P(^(0), "^",1) Q
  5949   "RTN","CHF BCQ",242,0 )
  5950    D NOW^%DT C S CHDT=%  I $D(^CHM QAQ("B",CH DT)) G LDQ Q1
  5951   "RTN","CHF BCQ",243,0 )
  5952    S (DIC,DL AYGO)=7410 10.07,DIC( 0)="ML",X= CHDT D ^DI C K DIC
  5953   "RTN","CHF BCQ",244,0 )
  5954    G LDQQ1:$ P(Y,"^",3) '=1
  5955   "RTN","CHF BCQ",245,0 )
  5956    S DA=+Y,D IE=741010. 07,DR=".02 ////^S X=C I;.03///^S  X=1;.04// /^S X=""`" "_DUZ;.15/ //^S X=CHM FPDI;1///^ S X=CHMFPD I"
  5957   "RTN","CHF BCQ",246,0 )
  5958    D ^DIE K  DIE S:CHMF PDI'="" ^C HMQAQ("G", 1,CHMFPDI, DA)=""
  5959   "RTN","CHF BCQ",247,0 )
  5960    S:'$D(^CH MQAQ(DA,1, 0)) ^CHMQA Q(DA,1,0)= "^741010.7 SA^0^0"
  5961   "RTN","CHF BCQ",248,0 )
  5962   Q1 S DA(1) =DA,(DIC,D LAYGO)="^C HMQAQ(DA(1 ),1,",DIC( 0)="ML"
  5963   "RTN","CHF BCQ",249,0 )
  5964    S:CHMFQUE =5 X=1 S:C HMFQUE=20  X=2
  5965   "RTN","CHF BCQ",250,0 )
  5966    S:CHMFQUE =21 X=3 S: CHMFQUE=22  X=4
  5967   "RTN","CHF BCQ",251,0 )
  5968    S:CHMFQUE =23 X=5 S: CHMFQUE=24  X=6
  5969   "RTN","CHF BCQ",252,0 )
  5970    S:CHMFQUE =28 X=7 S: CHMFQUE=33  X=8
  5971   "RTN","CHF BCQ",253,0 )
  5972    S:CHMFQUE =37 X=9 S: CHMFQUE=38  X=10
  5973   "RTN","CHF BCQ",254,0 )
  5974    S:CHMFQUE =40 X=11 S :CHMFQUE=3 9 X=12
  5975   "RTN","CHF BCQ",255,0 )
  5976    S:CHMFQUE =44 X=13   ;AEB 12/20 /2006
  5977   "RTN","CHF BCQ",256,0 )
  5978    S:CHMFQUE =45 X=14   ;AEB 5/9/2 007
  5979   "RTN","CHF BCQ",257,0 )
  5980    D ^DIC K  DIC,DR
  5981   "RTN","CHF BCQ",258,0 )
  5982    I (CHMFQU E'=28)&(CH MFQUE'=37) &(CHMFQUE' =38)&(CHMF QUE'=39)&( CHMFQUE'=4 4) D
  5983   "RTN","CHF BCQ",259,0 )
  5984     .S CHMQN AM="CHMQA1 (",CHMIN=" " K CHMOUT  D ^CHMIS0 41  ;AEB 6 /14/2007 A DDED SNF C LAIMS TO Q AQ P&c
  5985   "RTN","CHF BCQ",260,0 )
  5986    I (CHMFQU E=28)!(CHM FQUE=37)!( CHMFQUE=38 )!(CHMFQUE =40)!(CHMF QUE=39)!(C HMFQUE=45)  D
  5987   "RTN","CHF BCQ",261,0 )
  5988     .D REVCC D^CHTFLIBC (CI)  ;rev erse & cle ar ded/c.s ./cat cap  from claim  DEV021244  JAK 09/03 /14
  5989   "RTN","CHF BCQ",262,0 )
  5990     .D CLRPM T^CHTFLIB2 (CI)  ;cle ar payment  data from  claim DEV 021244 JAK  09/03/14
  5991   "RTN","CHF BCQ",263,0 )
  5992     .S CHMQN AM="CHMQA2 (",CHMIN=" " K CHMOUT  D ^CHMIS0 41  ;AEB 6 /14/2007 A DDED UNIT  CHECK CLAI M TO QAQ C PD
  5993   "RTN","CHF BCQ",264,0 )
  5994    S CHMFPP= "SQQA",CHM FI=CI D ^C HMFWK02
  5995   "RTN","CHF BCQ",265,0 )
  5996    D ADDQA
  5997   "RTN","CHF BCQ",266,0 )
  5998    Q
  5999   "RTN","CHF BCQ",267,0 )
  6000    ;
  6001   "RTN","CHF BCQ",268,0 )
  6002   LDQMCR D M AILMES
  6003   "RTN","CHF BCQ",269,0 )
  6004    Q
  6005   "RTN","CHF BCQ",270,0 )
  6006    I $D(^CHN VPAY(CI))  I '$D(^CHM QAQ("D",CI )) D  Q
  6007   "RTN","CHF BCQ",271,0 )
  6008    .S $P(^CH NVPAY(CI,0 ),"^",2)=1
  6009   "RTN","CHF BCQ",272,0 )
  6010    .S CHMFQU E=38 D LDQ Q Q
  6011   "RTN","CHF BCQ",273,0 )
  6012    S CHQI=$O (^CHMCCR(" D",CI,0))  I CHQI'=""  S DA=CHQI ,DIE=74101 0.01,DR=". 03///^S X= 0" D ^DIE  K DIE G MC R1
  6013   "RTN","CHF BCQ",274,0 )
  6014   LDQMCR1 D  NOW^%DTC S  CHDT=% I  $D(^CHMCCR ("B",CHDT) ) G LDQMCR 1
  6015   "RTN","CHF BCQ",275,0 )
  6016    S (DIC,DL AYGO)=7410 10.01,DIC( 0)="ML",X= CHDT D ^DI C K DIC
  6017   "RTN","CHF BCQ",276,0 )
  6018    G LDQMCR1 :$P(Y,"^", 3)'=1
  6019   "RTN","CHF BCQ",277,0 )
  6020    S CHMQNAM ="CHMCCR(" ,CHMIN=""  K CHMOUT D  ^CHMIS041
  6021   "RTN","CHF BCQ",278,0 )
  6022    S DA=+Y,D IE=741010. 01,DR=".02 ////^S X=C I;.03///^S  X=0" D ^D IE K DIE
  6023   "RTN","CHF BCQ",279,0 )
  6024    S:'$D(^CH MCCR(DA,1, 0)) ^CHMCC R(DA,1,0)= "^741010.0 2SA^0^0"
  6025   "RTN","CHF BCQ",280,0 )
  6026   MCR1 S DA( 1)=DA,(DIC ,DLAYGO)=" ^CHMCCR(DA (1),1,",DI C(0)="ML"
  6027   "RTN","CHF BCQ",281,0 )
  6028    S X=4 D ^ DIC K DIC
  6029   "RTN","CHF BCQ",282,0 )
  6030    S CHMFPP= "SQMCCR",C HMFI=CI D  ^CHMFWK02
  6031   "RTN","CHF BCQ",283,0 )
  6032    K DIC,DIE ,DA,DR,XL, CHDIFDED,C HDIFCS Q
  6033   "RTN","CHF BCQ",284,0 )
  6034    ;
  6035   "RTN","CHF BCQ",285,0 )
  6036   CKRO ;CPT  4418 *CR*  8/4/93
  6037   "RTN","CHF BCQ",286,0 )
  6038    Q:$P(@(GL PAY_"CI,6) "),"^",2)= ""
  6039   "RTN","CHF BCQ",287,0 )
  6040    Q:'$D(@(G LPAY_"CI,1 )"))
  6041   "RTN","CHF BCQ",288,0 )
  6042    Q:$P(@(GL PAY_"CI,1) "),"^",1)= ""
  6043   "RTN","CHF BCQ",289,0 )
  6044    S REAS=$P (^CHMDIC(7 41002.34,1 ,2),"^",13 ) D ROREAS
  6045   "RTN","CHF BCQ",290,0 )
  6046    S CIO=$P( @(GLPAY_"C I,6)"),"^" ,2)
  6047   "RTN","CHF BCQ",291,0 )
  6048    Q:'$D(@(G LPAY_"CIO, 1)"))
  6049   "RTN","CHF BCQ",292,0 )
  6050    Q:$P(@(GL PAY_"CIO,1 )"),"^",1) =""
  6051   "RTN","CHF BCQ",293,0 )
  6052    I +$P(@(G LPAY_"CI,1 )"),"^",1) =0 S REAS= $P(^CHMDIC (741002.34 ,1,2),"^", 4) D ROREA S
  6053   "RTN","CHF BCQ",294,0 )
  6054    E  I +$P( @(GLPAY_"C IO,1)"),"^ ",1)>0 S R EAS=$P(^CH MDIC(74100 2.34,1,2), "^",5) D R OREAS
  6055   "RTN","CHF BCQ",295,0 )
  6056    K CIO Q
  6057   "RTN","CHF BCQ",296,0 )
  6058    ;
  6059   "RTN","CHF BCQ",297,0 )
  6060   CKROEDI ;C PE005-100,  CPE005-10 2
  6061   "RTN","CHF BCQ",298,0 )
  6062    ;Q:$P(@(G LPAY_"CI,6 )"),"^",2) =""
  6063   "RTN","CHF BCQ",299,0 )
  6064    ;Q:'$D(@( GLPAY_"CI, 1)"))
  6065   "RTN","CHF BCQ",300,0 )
  6066    ;BDB 1229 2017 Q:$P( @(GLPAY_"C I,1)"),"^" ,1)=""
  6067   "RTN","CHF BCQ",301,0 )
  6068    N CPDI
  6069   "RTN","CHF BCQ",302,0 )
  6070    S CPDI=$O (@(GLPAY_" CI,""PDI"" ,99)"),-1)
  6071   "RTN","CHF BCQ",303,0 )
  6072    Q:'$D(@(G LPAY_"CI," "PDI"",CPD I,0)"))
  6073   "RTN","CHF BCQ",304,0 )
  6074    S CPDI=$P ($G(@(GLPA Y_"CI,""PD I"",CPDI,0 )")),"^",1 )
  6075   "RTN","CHF BCQ",305,0 )
  6076    Q:'CPDI
  6077   "RTN","CHF BCQ",306,0 )
  6078    Q:(($E(CP DI,8,9)'=" 97")&($E(C PDI,8,9)'= "90"))
  6079   "RTN","CHF BCQ",307,0 )
  6080    S CIO=$P( @(GLPAY_"C I,6)"),"^" ,2)
  6081   "RTN","CHF BCQ",308,0 )
  6082    I $D(@(GL PAY_"CI,1) ")) I +$P( @(GLPAY_"C I,1)"),"^" ,1)=0 S RE AS=$P(^CHM DIC(741002 .34,1,2)," ^",4) D RO REAS
  6083   "RTN","CHF BCQ",309,0 )
  6084    I $G(CIO) ,$D(@(GLPA Y_"CIO,1)" )) I +$P(@ (GLPAY_"CI O,1)"),"^" ,1)>0 S RE AS=$P(^CHM DIC(741002 .34,1,2)," ^",5) D RO REAS
  6085   "RTN","CHF BCQ",310,0 )
  6086    S REAS=$P (^CHMDIC(7 41002.34,1 ,3),"^",18 ) D ROREAS
  6087   "RTN","CHF BCQ",311,0 )
  6088    S REAS=$P (^CHMDIC(7 41002.34,1 ,3),"^",19 ) D ROREAS
  6089   "RTN","CHF BCQ",312,0 )
  6090    K CIO Q
  6091   "RTN","CHF BCQ",313,0 )
  6092    ;
  6093   "RTN","CHF BCQ",314,0 )
  6094   ROREAS S:' $D(@(GLPAY _"CI,4,0)" )) @(GLPAY _"CI,4,0)" )="^741000 .701P^0^0"
  6095   "RTN","CHF BCQ",315,0 )
  6096    S CHMNEXT =$P(@(GLPA Y_"CI,4,0) "),"^",3), CHMNEXT=CH MNEXT+1,$P (@(GLPAY_" CI,4,0)"), "^",3)=CHM NEXT
  6097   "RTN","CHF BCQ",316,0 )
  6098    S $P(@(GL PAY_"CI,4, CHMNEXT,0) "),"^",1)= REAS
  6099   "RTN","CHF BCQ",317,0 )
  6100    S @(GLPAY _"CI,4,""B "",REAS,CH MNEXT)")=" "
  6101   "RTN","CHF BCQ",318,0 )
  6102    I CHMNEXT =1 S $P(@( GLPAY_"CI, 4,CHMNEXT, 0)"),"^",2 )="OTH"
  6103   "RTN","CHF BCQ",319,0 )
  6104    K CHMNEXT ,REAS Q
  6105   "RTN","CHF BCQ",320,0 )
  6106    ;
  6107   "RTN","CHF BCQ",321,0 )
  6108   ADDQA ;N ( CI,DUZ)
  6109   "RTN","CHF BCQ",322,0 )
  6110    S CHSS=""  I $D(^CHM IMD(741020 .02,"B","P ARAMETER") ) D
  6111   "RTN","CHF BCQ",323,0 )
  6112    .S Y=$O(^ CHMIMD(741 020.02,"B" ,"PARAMETE R",0)) Q:Y =""
  6113   "RTN","CHF BCQ",324,0 )
  6114    .Q:'$D(^C HMIMD(7410 20.02,Y,11 ))  S CHSS =$P(^(11), "^",3) Q:C HSS=""
  6115   "RTN","CHF BCQ",325,0 )
  6116    .Q:'$D(^V A(200,"ZVM S",CHSS))   S CHDUZ=$ O(^VA(200, "ZVMS",CHS S,0)) Q
  6117   "RTN","CHF BCQ",326,0 )
  6118    Q:'$D(CHS S)  Q:CHSS =""  Q:'$D (CI)  Q:CI =""
  6119   "RTN","CHF BCQ",327,0 )
  6120    S CHPDIJ= 0,CHDOCID= "",CHMIMFL =1,CHIMMVE =1,CHOPER= "CHIMMVE"
  6121   "RTN","CHF BCQ",328,0 )
  6122    F  S CHPD IJ=$O(@(GL PAY_"CI,"" PDI"",CHPD IJ)")) Q:' CHPDIJ  D
  6123   "RTN","CHF BCQ",329,0 )
  6124    .Q:'$D(^( CHPDIJ,0))   S CHPDI= $P(^(0),"^ ",1)
  6125   "RTN","CHF BCQ",330,0 )
  6126    .Q:'$D(^C HMIMG(CHPD I,"DOC"))   S CHDOCID =$P(^("DOC "),"^",1)  D ADD^CHMM F
  6127   "RTN","CHF BCQ",331,0 )
  6128    K CHSS,Y, CHDUZ,CHPD IJ,CHDOCID ,CHIMFL,CH IMMVE,CHOP ER,CHPDI Q
  6129   "RTN","CHF BCQ",332,0 )
  6130   MAILMES S  $P(@(GLPAY _"CI,0)"), "^",2)=4
  6131   "RTN","CHF BCQ",333,0 )
  6132    S ^UTILIT Y($J,"MCCR -OVER-PAY" ,1,1,0)="C laim "_CN_ " has calc ulated as  an overpay ment."
  6133   "RTN","CHF BCQ",334,0 )
  6134    S ^UTILIT Y($J,"MCCR -OVER-PAY" ,1,2,0)="P lease rese arch for p otential r ecoupment. "
  6135   "RTN","CHF BCQ",335,0 )
  6136    S XMDUZ=. 5
  6137   "RTN","CHF BCQ",336,0 )
  6138    S XMSUB=" Possible M CCR Recoup ment"
  6139   "RTN","CHF BCQ",337,0 )
  6140    S XMTEXT= "^UTILITY( $J,""MCCR- OVER-PAY"" ,1,"
  6141   "RTN","CHF BCQ",338,0 )
  6142    D RECIP
  6143   "RTN","CHF BCQ",339,0 )
  6144    M ^TMP("R EV-MAIL",$ J)=^UTILIT Y($J,"MCCR -OVER-PAY" )
  6145   "RTN","CHF BCQ",340,0 )
  6146    S U="^" D  ^XMD
  6147   "RTN","CHF BCQ",341,0 )
  6148    Q
  6149   "RTN","CHF BCQ",342,0 )
  6150   RECIP K XM Y
  6151   "RTN","CHF BCQ",343,0 )
  6152    S JJ=0 F   S JJ=$O(^ CHMDIC(741 002.17,1,8 0,JJ)) Q:' JJ  D
  6153   "RTN","CHF BCQ",344,0 )
  6154    .Q:'$D(^C HMDIC(7410 02.17,1,80 ,JJ,0))
  6155   "RTN","CHF BCQ",345,0 )
  6156    .S MMDUZ= $P(^CHMDIC (741002.17 ,1,80,JJ,0 ),"^",1)
  6157   "RTN","CHF BCQ",346,0 )
  6158    .S XMY(MM DUZ)=""
  6159   "RTN","CHF BCQ",347,0 )
  6160    Q
  6161   "RTN","CHF BCQ",348,0 )
  6162    ;
  6163   "RTN","CHF BCQ",349,0 )
  6164   PAIDRVSL(C ) ;DEV0053 11, SKD, 7 -23-08
  6165   "RTN","CHF BCQ",350,0 )
  6166    ;If MMI r eversed cl aim is pai d by anoth er claim,  set the MM I Reversal  Paid Flag  to 1
  6167   "RTN","CHF BCQ",351,0 )
  6168    ;so that  the next d upe claim  won't bypa ss the dup e check
  6169   "RTN","CHF BCQ",352,0 )
  6170    ;
  6171   "RTN","CHF BCQ",353,0 )
  6172    Q:$G(C)=" "
  6173   "RTN","CHF BCQ",354,0 )
  6174    S CLI=C
  6175   "RTN","CHF BCQ",355,0 )
  6176    I $D(^CHM ZHOLD("ZRK MRDUPE",CL I)) D
  6177   "RTN","CHF BCQ",356,0 )
  6178    .S CHMMIO CL=0,CHMMI OCL=$O(^CH MZHOLD("ZR KMRDUPE",C LI,CHMMIOC L))
  6179   "RTN","CHF BCQ",357,0 )
  6180    .Q:'CHMMI OCL
  6181   "RTN","CHF BCQ",358,0 )
  6182    .Q:'$D(^C HMPAY(CHMM IOCL))
  6183   "RTN","CHF BCQ",359,0 )
  6184    .Q:'$D(^C HMPAY(CHMM IOCL,5))
  6185   "RTN","CHF BCQ",360,0 )
  6186    .S $P(^CH MPAY(CHMMI OCL,5),U,1 1)=1
  6187   "RTN","CHF BCQ",361,0 )
  6188    Q
  6189   "RTN","CHG AS2")
  6190   0^6^B11549 3168
  6191   "RTN","CHG AS2",1,0)
  6192   CHGAS2 ;CV A/RLC;ASQ  SCREEN DIS PLAY CALC  ;Feb 05, 2 019@09:48: 13
  6193   "RTN","CHG AS2",2,0)
  6194    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  6195   "RTN","CHG AS2",3,0)
  6196    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  6197   "RTN","CHG AS2",4,0)
  6198    ;             CHZONE  - SCREEN  REGION
  6199   "RTN","CHG AS2",5,0)
  6200    ;CPTS #10 857* BY RL C, #11567* -RLC, #118 78* (RLC),  #12197 (R LC)
  6201   "RTN","CHG AS2",6,0)
  6202    ;CPTS #13 156 (RLC)
  6203   "RTN","CHG AS2",7,0)
  6204    ; PT #161 10 (Y2K)
  6205   "RTN","CHG AS2",8,0)
  6206    ; PT #168 65 (JBM)
  6207   "RTN","CHG AS2",9,0)
  6208    ; MC284 J EH 9/5/06  Change OHI  Paid amou nt to Pati ent Respon sibility
  6209   "RTN","CHG AS2",10,0)
  6210    ;DEV00480 5 1/20/201 0 AEB
  6211   "RTN","CHG AS2",11,0)
  6212    ;DEV00782 0 EW 3/21/ 11
  6213   "RTN","CHG AS2",12,0)
  6214    ; CPE001- 008 WTC 6/ 19/17
  6215   "RTN","CHG AS2",13,0)
  6216   EN1 N (XY, DFN,CHZONE ,CHCLM,CHM M,CHTYP,GL PAY,GLDFN, GLELG,GLPA YH,GLPAYW, CHPROG,CHP GPT,CHCLM, CLI)
  6217   "RTN","CHG AS2",14,0)
  6218    S:'$D(^UT ILITY($J," ASQ",CHZON E,0)) ^UTI LITY($J,"A SQ",CHZONE ,0)=0
  6219   "RTN","CHG AS2",15,0)
  6220    S CT=^UTI LITY($J,"A SQ",CHZONE ,0),U="^", CHTYP="" ; MTN013163F   EW  BUG  BC63 11/23 /12
  6221   "RTN","CHG AS2",16,0)
  6222    Q:'$D(CHC LM)!(CHCLM ="")
  6223   "RTN","CHG AS2",17,0)
  6224    S:CHCLM'? 1N.N CHCLM =CLI
  6225   "RTN","CHG AS2",18,0)
  6226    S X1=CHCL M D PROGTY P^CHFCD001
  6227   "RTN","CHG AS2",19,0)
  6228    Q:'$D(@(G LPAY_"CHCL M,0)"))  S  REC0=@(GL PAY_"CHCLM ,0)")
  6229   "RTN","CHG AS2",20,0)
  6230    D DTASQ I  CHPDI=""  D GTPDI Q: CHPDI=""
  6231   "RTN","CHG AS2",21,0)
  6232    S CHCLMO= $P(REC0,"^ ",1),CHS=$ P(REC0,"^" ,2),HVFN=$ P(REC0,"^" ,3),CHAOB= $P(REC0,"^ ",5)
  6233   "RTN","CHG AS2",22,0)
  6234    S:CHAOB=0  CHAOB="NO " S:CHAOB= 1 CHAOB="Y ES"
  6235   "RTN","CHG AS2",23,0)
  6236    S CHSTAT= $S(CHS=0:" REJECTED", CHS=1:"IN- PROCESS",C HS=2:"PAYM ENT REQ",C HS=3:"EOB  REQ",CHS=4 :"COMPLETE ",CHS=7:"A DMIN SUSPE NSE",1:"UN KNOWN")
  6237   "RTN","CHG AS2",24,0)
  6238    S CHCLM(C HZONE,CHCL M)="" S:'$ D(CHCLM(CH ZONE,"CT") ) CHCLM(CH ZONE,"CT") =""
  6239   "RTN","CHG AS2",25,0)
  6240    S CHCLM(C HZONE,"CT" )=CHCLM(CH ZONE,"CT") +1
  6241   "RTN","CHG AS2",26,0)
  6242    S CHDOCID ="" I CHPD I'="" S:$D (^CHMIMG(C HPDI,"DOC" )) CHDOCID =$P(^("DOC "),"^",1)
  6243   "RTN","CHG AS2",27,0)
  6244    S (CHPITY ,CHBATCH)= "" I CHPDI '="" S:$D( ^CHMIMG(CH PDI,0)) CH PITY=$P(^C HMIMG(CHPD I,0),U,17) ,CHBATCH=$ P(^CHMIMG( CHPDI,0),U ,19)
  6245   "RTN","CHG AS2",28,0)
  6246    S CHPDITY =$S(CHPITY =1:"IO",CH PITY=2:"MS ",CHPITY=3 :"MM",CHPI TY=4:"EDI" ,1:"UNK")
  6247   "RTN","CHG AS2",29,0)
  6248    D DUZ
  6249   "RTN","CHG AS2",30,0)
  6250    S CHPD="" ,CHPD=CHPD I
  6251   "RTN","CHG AS2",31,0)
  6252    S:CHPDITY '="" CHPDI I=CHPDI_"- "_CHPDITY
  6253   "RTN","CHG AS2",32,0)
  6254    S:CHBATCH ="" CHBATC H=0
  6255   "RTN","CHG AS2",33,0)
  6256    S DFN=$P( REC0,"^",2 1),BFN=$P( REC0,"^",2 2),CHBENE= "",HBFN=BF N
  6257   "RTN","CHG AS2",34,0)
  6258    ;NEXT LIN E CHECKS F OR THE EXI STENCE OF  BENE WATCH  COMMENTS
  6259   "RTN","CHG AS2",35,0)
  6260    D BWATCH^ CHGAS17
  6261   "RTN","CHG AS2",36,0)
  6262    I DFN'=""  S:$D(@(GL ELG_"DFN,0 )")) CHSPO N=$P(@(GLE LG_"DFN,0) "),U,1)
  6263   "RTN","CHG AS2",37,0)
  6264    I DFN'="" !(BFN'="")  S:$D(@(GL ELG_"DFN,1 00,BFN,0)" )) REC1=@( GLELG_"DFN ,100,BFN,0 )")
  6265   "RTN","CHG AS2",38,0)
  6266    S CHTDDT= "" D NOW^% DTC S CHTD DT=$P(%H," ,",1)
  6267   "RTN","CHG AS2",39,0)
  6268    S CHBENE= $P(REC1,U, 1),CHSEX=$ P(REC1,U,2 ),CHDOB=$P (REC1,U,3) ,CHRL=$P(R EC1,U,4),C HSSN=$P(RE C1,U,9)
  6269   "RTN","CHG AS2",40,0)
  6270    S CHSPON= $E(CHSPON, 1,20),CHBE NE=$E(CHBE NE,1,20)
  6271   "RTN","CHG AS2",41,0)
  6272    I CHDOB=" " S CHAGE= "UNK" G EN 2
  6273   "RTN","CHG AS2",42,0)
  6274    S X=CHDOB  D H^%DTC  S CHBRDT=% H
  6275   "RTN","CHG AS2",43,0)
  6276    S CHAGE=( (CHTDDT-CH BRDT)/365. 25)\1
  6277   "RTN","CHG AS2",44,0)
  6278    ; Y2K - c hg'd CHDOB  to print  a four dig it year
  6279   "RTN","CHG AS2",45,0)
  6280    ;S:CHDOB' ="" CHDOB= $$FMTE^XLF DT(CHDOB," 2D")
  6281   "RTN","CHG AS2",46,0)
  6282    S:CHDOB'= "" CHDOB=$ $FMTE^XLFD T(CHDOB,5)
  6283   "RTN","CHG AS2",47,0)
  6284   EN2 S CHRE L=$S(CHRL= "C":"CHILD ",CHRL="S" :"SPOUSE", CHRL="XS": "EX-SPOUSE ",1:"UNKNO WN")
  6285   "RTN","CHG AS2",48,0)
  6286    S REC3=""
  6287   "RTN","CHG AS2",49,0)
  6288    S:$D(@(GL ELG_"DFN,1 00,BFN,1)" )) REC3=@( GLELG_"DFN ,100,BFN,1 )")
  6289   "RTN","CHG AS2",50,0)
  6290    I REC3=""  D  G EN22
  6291   "RTN","CHG AS2",51,0)
  6292    .S (CHBAD 1,CHBAD2,C HBCTY,CHST A,CHBZIP,C HBST)=""
  6293   "RTN","CHG AS2",52,0)
  6294    S CHBAD1= $P(REC3,U, 1),CHBAD2= $P(REC3,U, 2),CHBCTY= $P(REC3,U, 3),CHSTA=$ P(REC3,U,4 ),CHBZIP=$ P(REC3,U,5 )
  6295   "RTN","CHG AS2",53,0)
  6296    S CHBST=" "
  6297   "RTN","CHG AS2",54,0)
  6298    I CHSTA'= "" S:$D(^D IC(5,CHSTA ,0)) CHBST =$P(^DIC(5 ,CHSTA,0), U,2)
  6299   "RTN","CHG AS2",55,0)
  6300   EN22 S CHI D="" S:GLE LG="^CHNVV ET(" CHID= " "
  6301   "RTN","CHG AS2",56,0)
  6302    S:$D(@(GL ELG_"DFN,1 00,BFN,5)" )) CHID=$P (@(GLELG_" DFN,100,BF N,5)"),U,1 )
  6303   "RTN","CHG AS2",57,0)
  6304    S:CHID=""  CHID="UNK NOWN"
  6305   "RTN","CHG AS2",58,0)
  6306    S X=$P(RE C0,"^",8), XDOS=X S C HDOS="" I  X'="" D
  6307   "RTN","CHG AS2",59,0)
  6308    .;Y2K - C hg'd date  format
  6309   "RTN","CHG AS2",60,0)
  6310    .;S CHDOS =$$FMTE^XL FDT(X,"2D" )
  6311   "RTN","CHG AS2",61,0)
  6312    .S CHDOS= $$FMTE^XLF DT(X,"5D")
  6313   "RTN","CHG AS2",62,0)
  6314    S CHTOS=" " S CHTY=$ P(REC0,"^" ,7) I $D(^ CHMDIC(741 002.05,CHT Y,0)) D
  6315   "RTN","CHG AS2",63,0)
  6316    .S CHTOS= $P(^(0),"^ ",2),CHTOS S=$P(^(0), "^",1)
  6317   "RTN","CHG AS2",64,0)
  6318    S (CHVNPG ,CHCMAC,CH MPT,CHMEDP D,CHPCN,CH TOB,CHEXP, CHTPL,CHPZ IP)=""  ;A EB 1/20/20 10 DEV0048 05
  6319   "RTN","CHG AS2",65,0)
  6320    I $D(@(GL PAY_"CHCLM ,7)")) D     ;DEV0078 20 EW 3/21 /11
  6321   "RTN","CHG AS2",66,0)
  6322    .S CHMPT= $P(@(GLPAY _"CHCLM,7) "),U,1),CH MEDPD=$P(@ (GLPAY_"CH CLM,7)"),U ,2),CHPCN= $P(@(GLPAY _"CHCLM,7) "),U,5),CH TOB=$P(@(G LPAY_"CHCL M,7)"),U,6 ),CHPZIP=$ P(@(GLPAY_ "CHCLM,7)" ),U,8)     ;DEV007820  EW 3/21/1 1
  6323   "RTN","CHG AS2",67,0)
  6324    .S:$P(@(G LPAY_"CHCL M,""7"")") ,U,9)'=""  CHTPL=$P(@ (GLPAY_"CH CLM,""7"") "),U,9)     ;MTN01316 3F  EW  BU G ASQ16 2/ 19/13
  6325   "RTN","CHG AS2",68,0)
  6326    S:$D(@(GL PAY_"CHCLM ,9)")) CHV NPG=$P(@(G LPAY_"CHCL M,9)"),U,6 )
  6327   "RTN","CHG AS2",69,0)
  6328    S CHMCCR= ""
  6329   "RTN","CHG AS2",70,0)
  6330    S:$D(@(GL PAY_"CHCLM ,10)")) CH MCCR=$P(@( GLPAY_"CHC LM,10)"),U ,21)
  6331   "RTN","CHG AS2",71,0)
  6332    S:CHMCCR= 0 CHMCCR=" NO" S:CHMC CR=1 CHMCC R="YES"
  6333   "RTN","CHG AS2",72,0)
  6334    S CHOHI=" "
  6335   "RTN","CHG AS2",73,0)
  6336    I $D(@(GL PAY_"CHCLM ,1)")) S C HOHI=$P(@( GLPAY_"CHC LM,1)"),U, 7)
  6337   "RTN","CHG AS2",74,0)
  6338    S CHOHIPR ="" S:$D(@ (GLPAY_"CH CLM,1)"))  CHOHIPR=$P (@(GLPAY_" CHCLM,1)") ,U,29)   ;  MTN013163 F  EW  BUG  ASQ18 2/2 8/13
  6339   "RTN","CHG AS2",75,0)
  6340    I $D(@(GL PAY_"CHCLM ,7)")) I $ P(@(GLPAY_ "CHCLM,7)" ),U,10)'=" " S CHOHIP R=CHOHIPR- $P(@(GLPAY _"CHCLM,7) "),U,10) S  CHOHI=CHO HI+$P(@(GL PAY_"CHCLM ,7)"),U,10 )  ; MTN01 3163F  EW   BUG ASQ18  2/28/13   THIS ADDED  FOR NON-S LA CLAIMS
  6341   "RTN","CHG AS2",76,0)
  6342    I CHOHIPR <0 S CHOHI PR=0   ; M TN013163F   EW  BUG A SQ18 2/28/ 13
  6343   "RTN","CHG AS2",77,0)
  6344    S CHPS=""
  6345   "RTN","CHG AS2",78,0)
  6346    S:$D(@(GL PAY_"CHCLM ,""COMMON" ")")) CHBA MT=$P(@(GL PAY_"CHCLM ,""COMMON" ")"),U,3), CHPS=$P(@( GLPAY_"CHC LM,""COMMO N"")"),U,2 ),CHDRG=$P (@(GLPAY_" CHCLM,""CO MMON"")"), U,8),CHME= $P(@(GLPAY _"CHCLM,"" COMMON"")" ),U,16)
  6347   "RTN","CHG AS2",79,0)
  6348    ;
  6349   "RTN","CHG AS2",80,0)
  6350    ;  GET PL  ZIP WTC 6 /19/17
  6351   "RTN","CHG AS2",81,0)
  6352    ;
  6353   "RTN","CHG AS2",82,0)
  6354    S PLZIP=$ P($G(^CHMP AY(CHCLM," VEN-II")), U,15) ;
  6355   "RTN","CHG AS2",83,0)
  6356    S CHMETH= $S(CHME=0: "PPS",CHME =1:"CTC",C HME=3:"LVM H",CHME=4: "HVMH",1:" ")
  6357   "RTN","CHG AS2",84,0)
  6358    S:CHBAMT= 0 CHBAMT=" "
  6359   "RTN","CHG AS2",85,0)
  6360    ;S CHOHIN UM=0   ; M TN013163F   EW  BUG A SQ18 3/7/1 3
  6361   "RTN","CHG AS2",86,0)
  6362    ;S:CHOHI' ="" CHOHIN UM=CHOHI    ; MTN0131 63F  EW  B UG ASQ18 3 /7/13
  6363   "RTN","CHG AS2",87,0)
  6364    S:CHOHI'= "" CHOHI=" $"_$J($FN( CHOHI,",", 2),9)
  6365   "RTN","CHG AS2",88,0)
  6366    S:CHBAMT' ="" CHBAMT ="$"_$J($F N(CHBAMT," ,",2),9)
  6367   "RTN","CHG AS2",89,0)
  6368    S:CHTPL'= "" CHTPL=" $"_$J($FN( CHTPL,",", 2),9)    ; MTN013163F   EW  BUG  ASQ16 2/19 /13
  6369   "RTN","CHG AS2",90,0)
  6370    I $D(@(GL PAY_"CHCLM ,""COMMON" ")")) D
  6371   "RTN","CHG AS2",91,0)
  6372    .S CHTCB= $FN($P(@(G LPAY_"CHCL M,""COMMON "")"),U,1) ,"",2)
  6373   "RTN","CHG AS2",92,0)
  6374    .S CHTAA= $FN($P(@(G LPAY_"CHCL M,""COMMON "")"),U,7) ,"",2)
  6375   "RTN","CHG AS2",93,0)
  6376    I CHOHIPR '="" D   ;  SETTING O HI PATIENT  RESP   ;  JEH 9/5/06  ADDING OH I PATIENT  RESP
  6377   "RTN","CHG AS2",94,0)
  6378    .S CHOHIP R="$"_$J($ FN(CHOHIPR ,",",2),9)
  6379   "RTN","CHG AS2",95,0)
  6380    ;E  I CHO HI'="" D ; MTN013163F   EW  BUG  ASQ18 2/28 /13
  6381   "RTN","CHG AS2",96,0)
  6382    ;.S CHOHI PR=CHTCB-C HOHINUM K  CHOHINUM ; MTN013163F   EW  BUG  ASQ18 2/28 /13
  6383   "RTN","CHG AS2",97,0)
  6384    ;.S CHOHI PR="$"_$J( $FN(CHOHIP R,",",2),9 ) ;MTN0131 63F  EW  B UG ASQ18 2 /28/13
  6385   "RTN","CHG AS2",98,0)
  6386    S CHPOS=" N/A"
  6387   "RTN","CHG AS2",99,0)
  6388    I CHPS'=" " S:$D(^CH MDIC(74100 2.11,CHPS, 0)) CHPOS= $P(^CHMDIC (741002.11 ,CHPS,0),U ,2),CHPOS= $E(CHPOS,1 ,15)
  6389   "RTN","CHG AS2",100,0 )
  6390    S:CHPOS=" " CHPOS="N /A"
  6391   "RTN","CHG AS2",101,0 )
  6392    S CHTCB=" ",CHTAA=""
  6393   "RTN","CHG AS2",102,0 )
  6394    I $D(@(GL PAY_"CHCLM ,""COMMON" ")")) D
  6395   "RTN","CHG AS2",103,0 )
  6396    .S:$P(@(G LPAY_"CHCL M,""COMMON "")"),U,1) '="" CHTCB =$FN($P(@( GLPAY_"CHC LM,""COMMO N"")"),U,1 ),"",2)      ;DEV0078 20 EW 3/21 /11
  6397   "RTN","CHG AS2",104,0 )
  6398    .S:$P(@(G LPAY_"CHCL M,""COMMON "")"),U,7) '="" CHTAA =$FN($P(@( GLPAY_"CHC LM,""COMMO N"")"),U,7 ),"",2)     ;DEV00782 0 EW 3/21/ 11
  6399   "RTN","CHG AS2",105,0 )
  6400    S (CHOHB, CHOHE,CHOH ,CHOHT)=""  D OHI
  6401   "RTN","CHG AS2",106,0 )
  6402    S CHEDI=0
  6403   "RTN","CHG AS2",107,0 )
  6404    S:$D(@(GL PAY_"CHCLM ,""ZEMC"") ")) CHEDI= $O(@(GLPAY _"CHCLM,"" ZEMC"",CHE DI)"))
  6405   "RTN","CHG AS2",108,0 )
  6406    S:CHEDI=0  CHEDI="NO " ; S:CHED I=1 CHEDI= "YES"
  6407   "RTN","CHG AS2",109,0 )
  6408    ;S:'CHTAA  CHTAA="Un d" ;DEV007 820 EW 3/2 1/11
  6409   "RTN","CHG AS2",110,0 )
  6410    S (CHVEN, CHVTID,CHV TIDP,CHCMA C,CHVAD1,C HVAD2,CHVC TY,CHVST,C HVZIP,CHST E,CHMED,CH ADCDE,CHMD CDE,CHPLVE N,CHRTAD1, CHRTAD2,CH RTVCTY,CHR TVST,CHRTV ZIP,CHEXP) =""
  6411   "RTN","CHG AS2",111,0 )
  6412    S (X,VNPT )=$P(REC0, "^",3) I X '="" D:$D( ^CHMVEN(X, 0))
  6413   "RTN","CHG AS2",112,0 )
  6414    .S CHVEN= $P(^(0),"^ ",1),CHVTI D=$P(^(0), "^",3),CHA DCDE=$P(^( 0),U,23)
  6415   "RTN","CHG AS2",113,0 )
  6416    .S:CHADCD E="" CHADC DE="  "
  6417   "RTN","CHG AS2",114,0 )
  6418    .I $D(^CH MVEN(X,14) ) S CHMDCD E=$P(^(14) ,U,1)
  6419   "RTN","CHG AS2",115,0 )
  6420    .S:CHMDCD E="" CHMDC DE="  "
  6421   "RTN","CHG AS2",116,0 )
  6422    S CHVTIDP =CHVTID_"- "_CHADCDE_ "-"_CHMDCD E
  6423   "RTN","CHG AS2",117,0 )
  6424    I X'="" I  $D(^CHMVE N(X,41)) D
  6425   "RTN","CHG AS2",118,0 )
  6426    .S XJ=$O( ^CHMVEN(X, 41,XDOS),- 1) I 'XJ K  XJ S CHCM AC="" Q
  6427   "RTN","CHG AS2",119,0 )
  6428    .I '$D(^C HMVEN(X,41 ,XJ,0)) K  XJ S CHCMA C="" Q
  6429   "RTN","CHG AS2",120,0 )
  6430    .S CHCMAC =$P(^CHMVE N(X,41,XJ, 0),U,3) K  XJ
  6431   "RTN","CHG AS2",121,0 )
  6432    I X="" S  (CHVEN,CHV TID,CHADCD E,CHMDCDE, CHVTIDP,CH CMAC,CHVAD 1,CHVAD2,C HVCTY,CHVS T,CHVZIP,C HSTE,CHMED )="",(CHPL VEN,CHRTAD 1,CHRTAD2, CHRTVCTY,C HRTVZIP)=" " G VIEW
  6433   "RTN","CHG AS2",122,0 )
  6434    G:'$D(^CH MVEN(X,2))  EN3
  6435   "RTN","CHG AS2",123,0 )
  6436    ;6/20/96  PEJ change  made to u se PL addr ess
  6437   "RTN","CHG AS2",124,0 )
  6438    S REC4=^C HMVEN(X,2)
  6439   "RTN","CHG AS2",125,0 )
  6440    S CHVAD1= $P(REC4,U, 1),CHVAD2= $P(REC4,U, 2),CHVCTY= $P(REC4,U, 3),CHSTE=$ P(REC4,U,4 ),CHVZIP=$ P(REC4,U,5 ),CHPLVEN= $P(REC4,U, 8)
  6441   "RTN","CHG AS2",126,0 )
  6442    S:CHPLVEN ="" CHPLVE N=CHVEN
  6443   "RTN","CHG AS2",127,0 )
  6444    S CHVST=" "
  6445   "RTN","CHG AS2",128,0 )
  6446    I CHSTE'= "" S:$D(^D IC(5,CHSTE ,0)) CHVST =$P(^DIC(5 ,CHSTE,0), U,2)
  6447   "RTN","CHG AS2",129,0 )
  6448    ;3/5/97-R LC now nee d to print /display b oth remit- to and PL  addresses
  6449   "RTN","CHG AS2",130,0 )
  6450   EN3 G:'$D( ^CHMVEN(X, 1)) MED
  6451   "RTN","CHG AS2",131,0 )
  6452    S REC6=^C HMVEN(X,1)
  6453   "RTN","CHG AS2",132,0 )
  6454    S CHRTAD1 =$P(REC6,U ,1),CHRTAD 2=$P(REC6, U,2),CHRTV CTY=$P(REC 6,U,3),CHS TE2=$P(REC 6,U,4),CHR TVZIP=$P(R EC6,U,5)
  6455   "RTN","CHG AS2",133,0 )
  6456    S CHRTVST =""
  6457   "RTN","CHG AS2",134,0 )
  6458    I CHSTE2' ="" S:$D(^ DIC(5,CHST E2,0)) CHR TVST=$P(^( 0),U,2)
  6459   "RTN","CHG AS2",135,0 )
  6460    S CHEXP=$ $POACK^CHT FLIB3(X) S :CHEXP=1 C HEXP="Y" S :CHEXP=0 C HEXP="N"   ;AEB 1/20/ 2010 DEV00 4805
  6461   "RTN","CHG AS2",136,0 )
  6462    ;
  6463   "RTN","CHG AS2",137,0 )
  6464   MED I CHMP T="" S (CH MED,CHMAD1 ,CHMAD2,CH MCTY,CHMST ,CHMZIP,CH MTAX,CHMTA XP,CHMMAC, CHMADCD,CH MMDCD)=""  G VIEW
  6465   "RTN","CHG AS2",138,0 )
  6466    I $D(^CHM VEN(CHMPT, 0)) S CHME D=$P(^CHMV EN(CHMPT,0 ),U,1),CHM TAX=$P(^(0 ),U,3),CHM ADCD=$P(^( 0),U,23)
  6467   "RTN","CHG AS2",139,0 )
  6468    S:$D(^CHM VEN(CHMPT, 14)) CHMMD CD=$P(^(14 ),U,1)
  6469   "RTN","CHG AS2",140,0 )
  6470    S CHMTAXP =CHMTAX_"- "_CHMADCD_ "-"_CHMMDC D
  6471   "RTN","CHG AS2",141,0 )
  6472    S:CHMED=" " CHMED="U NKNOWN"
  6473   "RTN","CHG AS2",142,0 )
  6474    ;6/20/96  PEJ change  made to u se PL addr ess
  6475   "RTN","CHG AS2",143,0 )
  6476    G:'$D(^CH MVEN(CHMPT ,2)) VIEW
  6477   "RTN","CHG AS2",144,0 )
  6478    S REC5=^C HMVEN(CHMP T,2)
  6479   "RTN","CHG AS2",145,0 )
  6480    S CHMAD1= $P(REC5,U, 1),CHMAD2= $P(REC5,U, 2),CHMCTY= $P(REC5,U, 3),CHSTE=$ P(REC5,U,4 ),CHMZIP=$ P(REC5,U,5 )
  6481   "RTN","CHG AS2",146,0 )
  6482    I $D(^CHM VEN(CHMPT, 41)) D
  6483   "RTN","CHG AS2",147,0 )
  6484    .S XJ=$O( ^CHMVEN(CH MPT,41,XDO S),-1) I ' XJ K XJ S  CHCMAC=""  Q
  6485   "RTN","CHG AS2",148,0 )
  6486    .I '$D(^C HMVEN(CHMP T,41,XJ,0) ) K XJ S C HCMAC="" Q
  6487   "RTN","CHG AS2",149,0 )
  6488    .S CHCMAC =$P(^CHMVE N(CHMPT,41 ,XJ,0),U,3 ) K XJ ; C HMMAC
  6489   "RTN","CHG AS2",150,0 )
  6490    S CHMST=" "
  6491   "RTN","CHG AS2",151,0 )
  6492    I CHSTE'= "" I $D(^D IC(5,CHSTE ,0)) S CHM ST=$P(^DIC (5,CHSTE,0 ),U,2)
  6493   "RTN","CHG AS2",152,0 )
  6494    S CHEXP=$ $POACK^CHT FLIB3(CHMP T) S:CHEXP =1 CHEXP=" Y" S:CHEXP =0 CHEXP=" N"  ;AEB 1 /20/2010 D EV004805
  6495   "RTN","CHG AS2",153,0 )
  6496    ;
  6497   "RTN","CHG AS2",154,0 )
  6498   VIEW D BUI LD
  6499   "RTN","CHG AS2",155,0 )
  6500    I CHTOS'= "IPT" D ^C HGAS22 G E ND
  6501   "RTN","CHG AS2",156,0 )
  6502    I CHTOS=" IPT" D ^CH GAS23
  6503   "RTN","CHG AS2",157,0 )
  6504    ;
  6505   "RTN","CHG AS2",158,0 )
  6506   END K I,J, L,U,X,Z,CT ,CHS,RCT,I I,JJ,CHDT, CHBA,CHBAT ,CHRL
  6507   "RTN","CHG AS2",159,0 )
  6508    K CHPS,CH POS,CHME,C HMETH,CHME D,CHMAD1,C HMAD2,CHMC TY,CHMST,C HMZIP,CHID
  6509   "RTN","CHG AS2",160,0 )
  6510    K CHZONE, REC0,REC1, REC2,REC3, REC4,REC5, CHCLMO,CHA OB,REC6
  6511   "RTN","CHG AS2",161,0 )
  6512    K CHSTAT, CHDOCID,CH PITY,CHPDI TY,CHPD,CH SPON,CHBEN E,CHDOB,CH SSN
  6513   "RTN","CHG AS2",162,0 )
  6514    K CHBAD1, CHBAD2,CHB CTY,CHSTA, CHSTE,CHBS T,CHBZIP,C HDOS,CHTOS ,CHTOSS
  6515   "RTN","CHG AS2",163,0 )
  6516    K CHVNPG, CHCMAC,CHM PT,CHBAMT, CHACC,CHOH I,CHOHIF,C HDRG,CHTCB ,CHVTIDP
  6517   "RTN","CHG AS2",164,0 )
  6518    K CHTAA,C HEDI,CHVEN ,CHVTID,CH VAD1,CHVAD 2,CHVST,CH VCTY,CHVZI P,CHMTAX
  6519   "RTN","CHG AS2",165,0 )
  6520    K CHDT,CH RSN,CHRS,C HVE,CHDUZ, CHROPEN,CH TDX,CHTOSP ,CHTPRC,CH CODE,CHDAT A
  6521   "RTN","CHG AS2",166,0 )
  6522    K CHDESC, CHRULEJ,CH TYPE,CHOH, CHOHT,CHOH B,CHOHE
  6523   "RTN","CHG AS2",167,0 )
  6524    K PLZIP ;  WTC 6/19/ 17
  6525   "RTN","CHG AS2",168,0 )
  6526    Q
  6527   "RTN","CHG AS2",169,0 )
  6528    ;
  6529   "RTN","CHG AS2",170,0 )
  6530   DTASQ S I= 0,(CHDT,CH PDI,CHRSN) =""
  6531   "RTN","CHG AS2",171,0 )
  6532   DT1 S I=$O (^CHMASQ(" C",CHCLM,I )) Q:'I
  6533   "RTN","CHG AS2",172,0 )
  6534    G:'$D(^CH MASQ(I,0))  DT1
  6535   "RTN","CHG AS2",173,0 )
  6536    I "1"'[$P (^CHMASQ(I ,0),U,6) G  DT1
  6537   "RTN","CHG AS2",174,0 )
  6538    S CHDT=$P (^CHMASQ(I ,0),U,1),C HPDI=$P(^( 0),U,4)
  6539   "RTN","CHG AS2",175,0 )
  6540   DT2 I '$D( ^CHMASQ(I, 1)) S CHRS N=CHTYP Q  ;ADDED TO  DISPLAY RE ASON IN CO DING QUEUE  (ADDED FO R DEVELOPM ENT COULD  BE REMOVED ) MTN01316 3F  EW  BU G ASQ13 10 /23/12
  6541   "RTN","CHG AS2",176,0 )
  6542    S JJ=0
  6543   "RTN","CHG AS2",177,0 )
  6544   DT3 S JJ=$ O(^CHMASQ( I,1,JJ)) Q :'JJ
  6545   "RTN","CHG AS2",178,0 )
  6546    G:'$D(^CH MASQ(I,1,J J,0)) DT3
  6547   "RTN","CHG AS2",179,0 )
  6548    S CHRS=$P (^CHMASQ(I ,1,JJ,0),U ,1)
  6549   "RTN","CHG AS2",180,0 )
  6550    S CHRSN=$ S(CHRS=6:" NTH",CHRS= 8:"OVER",C HRS=9:"OVE R",CHRS=10 :"XXX",CHR S=11:"EDI" ,CHRS=12:" REOPEN-TF" ,CHRS=13:" OHI (NTH)" ,CHRS=14:" OHI (DD)", CHRS=15:"O HI(OTHER)" ,CHRS=16:" UNUSUAL FE E",CHRS=17 :"MEDICARE  DEDUCT",1 :"")
  6551   "RTN","CHG AS2",181,0 )
  6552    Q
  6553   "RTN","CHG AS2",182,0 )
  6554    ;
  6555   "RTN","CHG AS2",183,0 )
  6556   GTPDI S J= 99999
  6557   "RTN","CHG AS2",184,0 )
  6558    S J=$O(@( GLPAY_"CHC LM,""PDI"" ,J)"),-1)
  6559   "RTN","CHG AS2",185,0 )
  6560    S:$D(@(GL PAY_"CHCLM ,""PDI"",J ,0)")) CHP DI=$P(@(GL PAY_"CHCLM ,""PDI"",J ,0)"),U,1)
  6561   "RTN","CHG AS2",186,0 )
  6562    Q
  6563   "RTN","CHG AS2",187,0 )
  6564    ;
  6565   "RTN","CHG AS2",188,0 )
  6566   DUZ S II=0 ,CHVE="UNK "
  6567   "RTN","CHG AS2",189,0 )
  6568   DZ1 S II=$ O(^CHMIMG( "B",CHPDI, II)) Q:'II
  6569   "RTN","CHG AS2",190,0 )
  6570    G:'$D(^CH MIMG(II,0) ) DZ1
  6571   "RTN","CHG AS2",191,0 )
  6572    S CHDUZ=$ P(^CHMIMG( II,0),U,3)
  6573   "RTN","CHG AS2",192,0 )
  6574    G:CHDUZ=" " DZ1
  6575   "RTN","CHG AS2",193,0 )
  6576    I CHDUZ'= "" I $D(^V A(200,CHDU Z,0)) S CH VE=$P(^VA( 200,CHDUZ, 0),U,2)
  6577   "RTN","CHG AS2",194,0 )
  6578    S CHVE=CH VE_"-"_CHD UZ
  6579   "RTN","CHG AS2",195,0 )
  6580    Q
  6581   "RTN","CHG AS2",196,0 )
  6582    ;
  6583   "RTN","CHG AS2",197,0 )
  6584   OHI S I1=0 ,(CHOHBP,C HOHEP,CHOH ,CHOHTP)=" " Q:XDOS=" "
  6585   "RTN","CHG AS2",198,0 )
  6586   O1 S I1=$O (@(GLDFN_" ""B"",DFN, I1)")) Q:' I1
  6587   "RTN","CHG AS2",199,0 )
  6588    G:'$D(@(G LDFN_"I1,1 00)")) O1
  6589   "RTN","CHG AS2",200,0 )
  6590    S J1=0
  6591   "RTN","CHG AS2",201,0 )
  6592   O2 S J1=$O (@(GLDFN_" I1,100,""B "",BFN,J1) ")) G:'J1  O1
  6593   "RTN","CHG AS2",202,0 )
  6594    G:'$D(@(G LDFN_"I1,1 00,J1,2)") ) O2
  6595   "RTN","CHG AS2",203,0 )
  6596    S K1=XDOS
  6597   "RTN","CHG AS2",204,0 )
  6598   O3 S K1=$O (@(GLDFN_" I1,100,J1, 2,""B"",K1 )"),-1) G: 'K1 O2
  6599   "RTN","CHG AS2",205,0 )
  6600    S K2=0
  6601   "RTN","CHG AS2",206,0 )
  6602   O4 S K2=$O (@(GLDFN_" I1,100,J1, 2,""B"",K1 ,K2)")) G: 'K2 O3
  6603   "RTN","CHG AS2",207,0 )
  6604    G:'$D(@(G LDFN_"I1,1 00,J1,2,K2 ,0)")) O4
  6605   "RTN","CHG AS2",208,0 )
  6606    S RC=@(GL DFN_"I1,10 0,J1,2,K2, 0)")
  6607   "RTN","CHG AS2",209,0 )
  6608    S CHOHBP= $P(RC,U,1) ,CHOHEP=$P (RC,U,2),C HOH=$P(RC, U,3)
  6609   "RTN","CHG AS2",210,0 )
  6610    S CHOHTP= "NO OHI"
  6611   "RTN","CHG AS2",211,0 )
  6612    I CHOH I  $D(^CHMDIC (741002.76 ,CHOH,0))  S CHOHTP=$ P(^(0),"^" ,1)
  6613   "RTN","CHG AS2",212,0 )
  6614    ; Y2K - c hg'd date  format
  6615   "RTN","CHG AS2",213,0 )
  6616    ;S:CHOHBP '="" CHOHB P=$$FMTE^X LFDT(CHOHB P,"2D")
  6617   "RTN","CHG AS2",214,0 )
  6618    ;S:CHOHEP '="" CHOHE P=$$FMTE^X LFDT(CHOHE P,"2D")
  6619   "RTN","CHG AS2",215,0 )
  6620    S:CHOHBP' ="" CHOHBP =$$FMTE^XL FDT(CHOHBP ,"5D")
  6621   "RTN","CHG AS2",216,0 )
  6622    S:CHOHEP' ="" CHOHEP =$$FMTE^XL FDT(CHOHEP ,"5D")
  6623   "RTN","CHG AS2",217,0 )
  6624    Q
  6625   "RTN","CHG AS2",218,0 )
  6626    ;
  6627   "RTN","CHG AS2",219,0 )
  6628   BUILD D ^C HGASU1
  6629   "RTN","CHG AS2",220,0 )
  6630    ;;skd, ch ange next  4 lines to  correct D Y
  6631   "RTN","CHG AS2",221,0 )
  6632    ;;S DX=0, DY=1,$X=DX ,$Y=DY X X Y W @CHBON ,"PDI: ",@ CHBOFF,CHP DII S DX=2 8,$X=DX,$Y =DY X XY W  @CHBON,"C laim #: ", @CHBOFF,CH CLMO S DX= 53,$X=DX,$ Y=DY X XY  W @CHBON," Bene: ",@C HBOFF,CHBE NE
  6633   "RTN","CHG AS2",222,0 )
  6634    ;;S DX=0, DY=2,$X=DX ,$Y=DY X X Y W @CHBON ,"Batch #:  ",@CHBOFF ,CHBATCH S  DX=28,$X= DX,$Y=DY X  XY W @CHB ON,"TOS: " ,@CHBOFF,C HTOSS S DX =53,$X=DX, $Y=DY X XY  W @CHBON, "Spon: ",@ CHBOFF,CHS PON
  6635   "RTN","CHG AS2",223,0 )
  6636    ;;S DX=0, DY=3,$X=DX ,$Y=DY X X Y W @CHBON ,"Doc Id#:  ",@CHBOFF ,CHDOCID S  DX=28,$X= DX,$Y=DY X  XY W @CHB ON,"Status : ",@CHBOF F,CHSTAT S  DX=55,$X= DX,$Y=DY X  XY W @CHB ON,"VE: ", @CHBOFF,CH VE
  6637   "RTN","CHG AS2",224,0 )
  6638    ;;D:'$D(C HPROG) GTP RG S DX=0, DY=5,$X=DX ,$Y=DY X X Y W @CHBON ,"Program:  ",@CHBOFF ,CHPROG
  6639   "RTN","CHG AS2",225,0 )
  6640    S DX=0,DY =2,$X=DX,$ Y=DY X XY  W @CHBON," PDI: ",@CH BOFF,CHPDI I S DX=28, $X=DX,$Y=D Y X XY W @ CHBON,"Cla im #: ",@C HBOFF,CHCL MO S DX=53 ,$X=DX,$Y= DY X XY W  @CHBON,"Be ne: ",@CHB OFF,CHBENE
  6641   "RTN","CHG AS2",226,0 )
  6642    S DX=0,DY =3,$X=DX,$ Y=DY X XY  W @CHBON," Batch #: " ,@CHBOFF,C HBATCH S D X=28,$X=DX ,$Y=DY X X Y W @CHBON ,"TOS: ",@ CHBOFF,CHT OSS S DX=5 3,$X=DX,$Y =DY X XY W  @CHBON,"S pon: ",@CH BOFF,CHSPO N
  6643   "RTN","CHG AS2",227,0 )
  6644    S DX=0,DY =4,$X=DX,$ Y=DY X XY  W @CHBON," Doc Id#: " ,@CHBOFF,C HDOCID S D X=28,$X=DX ,$Y=DY X X Y W @CHBON ,"Status:  ",@CHBOFF, CHSTAT S D X=55,$X=DX ,$Y=DY X X Y W @CHBON ,"VE: ",@C HBOFF,CHVE
  6645   "RTN","CHG AS2",228,0 )
  6646    D:'$D(CHP ROG) GTPRG  S DX=0,DY =5,$X=DX,$ Y=DY X XY  W @CHBON," Program: " ,@CHBOFF,C HPROG
  6647   "RTN","CHG AS2",229,0 )
  6648    Q
  6649   "RTN","CHG AS2",230,0 )
  6650   GTPRG S CH PROG="UNKN OWN"
  6651   "RTN","CHG AS2",231,0 )
  6652    Q:'$D(CHM INDEX("B", CHCLMO))   S CLI=0
  6653   "RTN","CHG AS2",232,0 )
  6654   GTP S CLI= $O(^CHMIND EX("B",CHC LMO,CLI))  Q:'CLI
  6655   "RTN","CHG AS2",233,0 )
  6656    G:'$D(^CH MINDEX(CLI ,0)) GTP S  CHPGPT=$P (^(0),U,2)
  6657   "RTN","CHG AS2",234,0 )
  6658    G:CHPGPT= "" GTP
  6659   "RTN","CHG AS2",235,0 )
  6660    G:'$D(^CH MDIC(74100 2.94,CHPGP T,0)) GTP  S CHPROG=$ P(^(0),U,2 )
  6661   "RTN","CHG AS2",236,0 )
  6662    Q
  6663   "RTN","CHG AS22")
  6664   0^7^B73431 822
  6665   "RTN","CHG AS22",1,0)
  6666   CHGAS22 ;C VA/RLC;ASQ  SCREEN DI SPLAY CALC  - PART 2  ;Feb 05, 2 019@09:51: 25
  6667   "RTN","CHG AS22",2,0)
  6668    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  6669   "RTN","CHG AS22",3,0)
  6670    ;;V2.0;;
  6671   "RTN","CHG AS22",4,0)
  6672    ; PT #161 10 (Y2K)
  6673   "RTN","CHG AS22",5,0)
  6674    ; PT #168 65 (JBM) F ixed indir ection
  6675   "RTN","CHG AS22",6,0)
  6676    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  6677   "RTN","CHG AS22",7,0)
  6678    ;             CHZONE  - SCREEN  REGION
  6679   "RTN","CHG AS22",8,0)
  6680    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 *-RLC, #12 197 (RLC)
  6681   "RTN","CHG AS22",9,0)
  6682    ; MC284 J EH 9/5/06  Change OHI  Paid amou nt to Pati ent Respon sibility
  6683   "RTN","CHG AS22",10,0 )
  6684    ; DEV7820  EW 1/25/1 1 Add paid  by TPL an d totals f or OHI and  MEDICAID
  6685   "RTN","CHG AS22",11,0 )
  6686    ;CFS 07/2 4/2017 - A dd PL ZIP  for User S tory CPE00 1-005.
  6687   "RTN","CHG AS22",12,0 )
  6688    ;DYO 11/2 8/2018 - D efect 8322 84 Not dis play PL ZI P field fo r RX DME a nd TRV cla ims.
  6689   "RTN","CHG AS22",13,0 )
  6690    ;
  6691   "RTN","CHG AS22",14,0 )
  6692    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  6693   "RTN","CHG AS22",15,0 )
  6694   UTIL S X=" X XY W @CH BON,""Date  in ASQ: " ",@CHBOFF, P1 S DX=28 ,$X=DX,$Y= DY X XY W  @CHBON,""R sn in ASQ:  "",@CHBOF F,P2 S DX= 53,$X=DX,$ Y=DY X XY  W @CHBON," "Mailman # : "",@CHBO FF,P3"
  6695   "RTN","CHG AS22",16,0 )
  6696    ; Y2K - C hg'd date  format for  CHDT
  6697   "RTN","CHG AS22",17,0 )
  6698    ;D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= X_U_$$FMTE ^XLFDT(CHD T,"2D")_U_ CHRSN_U_CH MM
  6699   "RTN","CHG AS22",18,0 )
  6700    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_$$FMTE^ XLFDT(+CHD T,"5D")_U_ CHRSN_U_CH MM
  6701   "RTN","CHG AS22",19,0 )
  6702    S X="X XY  W @CHBON, ""DOS: "", @CHBOFF,P1  S DX=28,$ X=DX,$Y=DY  X XY W @C HBON,""POS : "",@CHBO FF,P2 S DX =53,$X=DX, $Y=DY X XY  W @CHBON, ""EDI Clai m: "",@CHB OFF,P3"
  6703   "RTN","CHG AS22",20,0 )
  6704    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHDOS_U _CHPOS_U_C HEDI
  6705   "RTN","CHG AS22",21,0 )
  6706    S X="X XY  W @CHBON, ""MCCR Rev iew: "",@C HBOFF,P1 S  DX=28,$X= DX,$Y=DY X  XY W @CHB ON,""Type  of Bill: " ",@CHBOFF, P2 S DX=53 ,$X=DX,$Y= DY X XY W  @CHBON,""P CN: "",@CH BOFF,P3"
  6707   "RTN","CHG AS22",22,0 )
  6708    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHMCCR_ U_CHTOB_U_ $E(CHPCN,1 ,20)
  6709   "RTN","CHG AS22",23,0 )
  6710    S X="X XY  W @CHBON, ""OHI Type : "",@CHBO FF,P1 S DX =28,$X=DX, $Y=DY X XY  W @CHBON, ""OHI Begi n: "",@CHB OFF,P2 S D X=53,$X=DX ,$Y=DY X X Y W @CHBON ,""OHI End : "",@CHBO FF,P3"
  6711   "RTN","CHG AS22",24,0 )
  6712    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_$E(CHOH TP,1,15)_U _CHOHBP_U_ CHOHEP
  6713   "RTN","CHG AS22",25,0 )
  6714    S X="X XY  W @CHBON, ""OHI Paym t: "",@CHB OFF,P1 S D X=28,$X=DX ,$Y=DY X X Y W @CHBON ,""Bene Pa ymt: "",@C HBOFF,P2"
  6715   "RTN","CHG AS22",26,0 )
  6716    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHOHI_U _CHBAMT    ; JEH 9/5/ 06
  6717   "RTN","CHG AS22",27,0 )
  6718    S X="X XY  W @CHBON, ""OHI PR B al: "",@CH BOFF,P1 S  DX=28,$X=D X,$Y=DY X  XY W @CHBO N,""TPL Pa ymt: "",@C HBOFF,P2"    ;MTN0131 63F  EW  B UG ASQ20 2 /17/13
  6719   "RTN","CHG AS22",28,0 )
  6720    I CHPZIP= "" D UPCT  S ^UTILITY ($J,"ASQ", CHZONE,CT) =X_U_CHOHI PR_U_CHTPL   ;DEV7820  EW 1/25/1 1
  6721   "RTN","CHG AS22",29,0 )
  6722    E  D
  6723   "RTN","CHG AS22",30,0 )
  6724    .S X="X X Y W @CHBON ,""OHI PR  Bal: "",@C HBOFF,P1 S  DX=28,$X= DX,$Y=DY X  XY W @CHB ON,""TPL P aymt: "",@ CHBOFF,P2  S DX=53,$X =DX,$Y=DY  X XY W @CH BON,""POP1 : "",@CHBO FF,P3"   ; MTN013163F   EW  BUG  ASQ18 3/5/ 13
  6725   "RTN","CHG AS22",31,0 )
  6726    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= X_U_CHOHIP R_U_CHTPL_ U_CHPZIP   ;DEV7820 E W 1/25/11
  6727   "RTN","CHG AS22",32,0 )
  6728    ;Defect 8 32284 Star t
  6729   "RTN","CHG AS22",33,0 )
  6730    S CHPLZIP =$P($G(^CH MPAY(CHCLM ,"VEN-II") ),U,15)
  6731   "RTN","CHG AS22",34,0 )
  6732    ;Display  PL ZIP fie ld for OPT  INP and D NT claims  only.
  6733   "RTN","CHG AS22",35,0 )
  6734    I (CHTOS= "OPT")!(CH TOS="IPT") !(CHTOS="D NT") D
  6735   "RTN","CHG AS22",36,0 )
  6736    . S X="X  XY W @CHBO N,""PL ZIP : "",@CHBO FF,P1 S DX =28,$X=DX, $Y=DY"  ;C FS 001-005
  6737   "RTN","CHG AS22",37,0 )
  6738    . D UPCT  S ^UTILITY ($J,"ASQ", CHZONE,CT) =X_U_CHPLZ IP
  6739   "RTN","CHG AS22",38,0 )
  6740    ;
  6741   "RTN","CHG AS22",39,0 )
  6742    ;S CHPLZI P=$P($G(^C HMPAY(CHCL M,"VEN-II" )),U,15)
  6743   "RTN","CHG AS22",40,0 )
  6744    ;Defect 8 32284 End
  6745   "RTN","CHG AS22",41,0 )
  6746    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  6747   "RTN","CHG AS22",42,0 )
  6748    S (CHMODS ,CHMEDPT,C HOHIPDT,CH OHIPRT,CHO HIADT,CHOH IPBT)=""
  6749   "RTN","CHG AS22",43,0 )
  6750    S:CHTOS=" OPT" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  6751   "RTN","CHG AS22",44,0 )
  6752    S:CHTOS=" DUR" CHTDX ="DME-DX", CHTPRC="DM E-SUPPLY"
  6753   "RTN","CHG AS22",45,0 )
  6754    S:CHTOS=" DNT" CHTDX ="DEN-DX", CHTPRC="DE N-PROC"
  6755   "RTN","CHG AS22",46,0 )
  6756    S:CHTOS=" TRV" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  6757   "RTN","CHG AS22",47,0 )
  6758    S CHTOSP= $S(CHTOS=" IPT":CHTOS ,CHTOS="DU R":CHTOS,C HTOS="RXT" :CHTOS,1:" OPT")
  6759   "RTN","CHG AS22",48,0 )
  6760    D:CHTOSP' ="" @CHTOS P^CHGAS3
  6761   "RTN","CHG AS22",49,0 )
  6762    ;-------- ---------- ----DEV782 0 EW 1/25/ 11
  6763   "RTN","CHG AS22",50,0 )
  6764    ;D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=58,$ X=DX,$Y=DY  X XY W "" ---------- "" S DX=70 ,$X=DX,$Y= DY X XY W  ""-------- --"""
  6765   "RTN","CHG AS22",51,0 )
  6766    ;S X="S D X=48,$X=DX ,$Y=DY X X Y W @CHBON ,""Totals" ",@CHBOFF  S DX=58,$X =DX,$Y=DY  X XY W $J( P1,10) S D X=70,$X=DX ,$Y=DY X X Y W $J(P2, 10)"
  6767   "RTN","CHG AS22",52,0 )
  6768    ;D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= X_U_CHTCB_ U_CHTAA
  6769   "RTN","CHG AS22",53,0 )
  6770    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" S DX=1,$X= DX,$Y=DY X  XY W ""To tals------ ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- """  ;MTN0 13163F  EW   BUG ASQ1 3 10/15/12
  6771   "RTN","CHG AS22",54,0 )
  6772    I CHOHIPD T'="" S CH OHIPDT=$FN (CHOHIPDT, "",2)
  6773   "RTN","CHG AS22",55,0 )
  6774    I CHOHIPR T'="" S CH OHIPRT=$FN (CHOHIPRT, "",2)
  6775   "RTN","CHG AS22",56,0 )
  6776    I CHMEDPT '="" S CHM EDPT=$FN(C HMEDPT,"", 2)
  6777   "RTN","CHG AS22",57,0 )
  6778    I CHOHIAD T'="" S CH OHIADT=$FN (CHOHIADT, "",2)
  6779   "RTN","CHG AS22",58,0 )
  6780    I CHOHIPB T'="" S CH OHIPBT=$FN (CHOHIPBT, "",2)
  6781   "RTN","CHG AS22",59,0 )
  6782    S X="S DX =74,$X=DX, $Y=DY X XY  W $J(P1,1 1) S DX=86 ,$X=DX,$Y= DY X XY W  $J(P2,11)  S DX=98,$X =DX,$Y=DY  X XY W $J( P3,11) S D X=110,$X=D X,$Y=DY X  XY W $J(P4 ,11) S DX= 121,$X=DX, $Y=DY X XY  W $J(P5,1 1)"  ;MTN0 13163F  EW   BUG ASQ1 3 10/15/12
  6783   "RTN","CHG AS22",60,0 )
  6784    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHTCB_U _CHTAA_U_C HOHIPDT_U_ CHOHIPRT_U _CHMEDPT   ;MTN013163 F  EW  BUG  ASQ13 10/ 15/12
  6785   "RTN","CHG AS22",61,0 )
  6786    S X="S DX =98,$X=DX, $Y=DY X XY  W $J(P1,1 1) S DX=11 0,$X=DX,$Y =DY X XY W  $J(P2,11) "  ;MTN013 163F  EW   BUG ASQ13  10/15/12
  6787   "RTN","CHG AS22",62,0 )
  6788    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHOHIAD T_U_CHOHIP BT  ;MTN01 3163F  EW   BUG ASQ13  10/15/12
  6789   "RTN","CHG AS22",63,0 )
  6790    ;-------- ---------- -----DEV78 20 EW 1/25 /11
  6791   "RTN","CHG AS22",64,0 )
  6792    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  6793   "RTN","CHG AS22",65,0 )
  6794    D REOPEN^ CHGAS24
  6795   "RTN","CHG AS22",66,0 )
  6796    S X="X XY  W @CHBON, ""Benefici ary Data:" ",@CHBOFF"
  6797   "RTN","CHG AS22",67,0 )
  6798    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X
  6799   "RTN","CHG AS22",68,0 )
  6800    S X="X XY  W @CHBON, ""DOB: "", @CHBOFF,P1  S DX=18,$ X=DX,$Y=DY  X XY W @C HBON,""Age : "",@CHBO FF,P2 S DX =30,$X=DX, $Y=DY X XY  W @CHBON, ""Sex: "", @CHBOFF,P3  S DX=50,$ X=DX,$Y=DY  X XY W @C HBON,""SSN : "",@CHBO FF,P4"
  6801   "RTN","CHG AS22",69,0 )
  6802    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHDOB_U _CHAGE_U_C HSEX_U_CHS SN
  6803   "RTN","CHG AS22",70,0 )
  6804    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=50 ,$X=DX,$Y= DY X XY W  @CHBON,""R elationshi p: "",@CHB OFF,P2"
  6805   "RTN","CHG AS22",71,0 )
  6806    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBAD1_ U_CHREL
  6807   "RTN","CHG AS22",72,0 )
  6808    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1"
  6809   "RTN","CHG AS22",73,0 )
  6810    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBAD2
  6811   "RTN","CHG AS22",74,0 )
  6812    S X="X XY  W @CHBON, ""City: "" ,@CHBOFF,P 1 S DX=28, $X=DX,$Y=D Y X XY W @ CHBON,""St ate: "",@C HBOFF,P2 S  DX=50,$X= DX,$Y=DY X  XY W @CHB ON,""Zip:  "",@CHBOFF ,P3"
  6813   "RTN","CHG AS22",75,0 )
  6814    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBCTY_ U_CHBST_U_ CHBZIP
  6815   "RTN","CHG AS22",76,0 )
  6816    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  6817   "RTN","CHG AS22",77,0 )
  6818    S VPTR=""
  6819   "RTN","CHG AS22",78,0 )
  6820    S:$D(@(GL PAY_"CHCLM ,0)")) VPT R=$P(@(GLP AY_"CHCLM, 0)"),U,3)
  6821   "RTN","CHG AS22",79,0 )
  6822    I VPTR'=" " I $D(^CH MVEN(VPTR, 20)) D
  6823   "RTN","CHG AS22",80,0 )
  6824    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6825   "RTN","CHG AS22",81,0 )
  6826    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=8,$X =DX,$Y=DY  X XY W @CH BON,""***V ENDOR WATC H DATA EXI STS FOR TH IS PROVIDE R***"",@CH BOFF"
  6827   "RTN","CHG AS22",82,0 )
  6828    ;NEXT FEW  LINES DIS PLAY BOTH  THE VENDOR  REMIT-TO  AND PL ADD RESSES
  6829   "RTN","CHG AS22",83,0 )
  6830    S X="X XY  W @CHBON, ""Tax ID:  "",@CHBOFF ,P1 S DX=2 8,$X=DX,$Y =DY X XY W  @CHBON,"" PI: "",@CH BOFF,P2 S  DX=40,$X=D X,$Y=DY X  XY W @CHBO N,""Vendor  Page: "", @CHBOFF,P3  S DX=59,$ X=DX,$Y=DY  X XY W @C HBON,""CMA C: "",@CHB OFF,P4"
  6831   "RTN","CHG AS22",84,0 )
  6832    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHVTIDP _U_CHAOB_U _CHVNPG_U_ CHCMAC
  6833   "RTN","CHG AS22",85,0 )
  6834    S X="X XY  W @CHBON, ""RT Vendo r: "",@CHB OFF,P1 S D X=42,$X=DX ,$Y=DY X X Y W @CHBON ,""PL Vend or: "",@CH BOFF,P2"
  6835   "RTN","CHG AS22",86,0 )
  6836    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHVEN_U _CHPLVEN
  6837   "RTN","CHG AS22",87,0 )
  6838    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""A ddr1: "",@ CHBOFF,P2"
  6839   "RTN","CHG AS22",88,0 )
  6840    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTAD1 _U_CHVAD1
  6841   "RTN","CHG AS22",89,0 )
  6842    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""A ddr2: "",@ CHBOFF,P2"
  6843   "RTN","CHG AS22",90,0 )
  6844    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTAD2 _U_CHVAD2
  6845   "RTN","CHG AS22",91,0 )
  6846    S X="X XY  W @CHBON, ""City:  " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""C ity:  "",@ CHBOFF,P2"
  6847   "RTN","CHG AS22",92,0 )
  6848    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTVCT Y_U_CHVCTY
  6849   "RTN","CHG AS22",93,0 )
  6850    S X="X XY  W @CHBON, ""State: " ",@CHBOFF, P1 S DX=13 ,$X=DX,$Y= DY X XY W  @CHBON,""Z ip: "",@CH BOFF,P2 S  DX=42,$X=D X,$Y=DY X  XY W @CHBO N,""State:  "",@CHBOF F,P3 S DX= 55,$X=DX,$ Y=DY X XY  W @CHBON," "Zip: "",@ CHBOFF,P4"
  6851   "RTN","CHG AS22",94,0 )
  6852    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTVST _U_CHRTVZI P_U_CHVST_ U_CHVZIP
  6853   "RTN","CHG AS22",95,0 )
  6854    I CHMED'= "" D MED^C HGAS24
  6855   "RTN","CHG AS22",96,0 )
  6856    D QUECHK^ CHGAS24
  6857   "RTN","CHG AS22",97,0 )
  6858    S CHPTR=C HCLM D ^CH GASHST,^CH GAS2PP
  6859   "RTN","CHG AS22",98,0 )
  6860    I $D(^CHM CLCOM("B", CHCLMO)) D   S CHCOM= CHCLMO D ^ CHGAS3AA K  CHCOM
  6861   "RTN","CHG AS22",99,0 )
  6862    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6863   "RTN","CHG AS22",100, 0)
  6864    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=33,$X=D X,$Y=DY X  XY W @CHBO N,""Claim  Comments"" ,@CHBOFF S  DX=49,$X= DX,$Y=DY X  XY W @CHB ON,""///// /////"",@C HBOFF"
  6865   "RTN","CHG AS22",101, 0)
  6866    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6867   "RTN","CHG AS22",102, 0)
  6868    I CHPDI'= "" I $D(^C HMCLCOM("B ",$P(CHPDI ,"-",1)))  D  S CHCOM =$P(CHPDI, "-",1) D ^ CHGAS3AB K  CHCOM
  6869   "RTN","CHG AS22",103, 0)
  6870    .I '$D(^C HMCLCOM("B ",CHCLMO))  D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" "
  6871   "RTN","CHG AS22",104, 0)
  6872    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "W "" """
  6873   "RTN","CHG AS22",105, 0)
  6874    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=33,$X=D X,$Y=DY X  XY W @CHBO N,""PDI Co mments"",@ CHBOFF S D X=49,$X=DX ,$Y=DY X X Y W @CHBON ,""/////// ///"",@CHB OFF"
  6875   "RTN","CHG AS22",106, 0)
  6876    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6877   "RTN","CHG AS22",107, 0)
  6878    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D  D ^ CHGAS17
  6879   "RTN","CHG AS22",108, 0)
  6880    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6881   "RTN","CHG AS22",109, 0)
  6882    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=33,$X=D X,$Y=DY X  XY W @CHBO N,""Bene C omments"", @CHBOFF S  DX=49,$X=D X,$Y=DY X  XY W @CHBO N,""////// ////"",@CH BOFF"
  6883   "RTN","CHG AS22",110, 0)
  6884    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6885   "RTN","CHG AS22",111, 0)
  6886    I $D(CHMW AT("BENWAT ")) D  D B ENWAT^CHGA S17
  6887   "RTN","CHG AS22",112, 0)
  6888    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6889   "RTN","CHG AS22",113, 0)
  6890    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=32,$X=D X,$Y=DY X  XY W @CHBO N,""Bene W atch Info" ",@CHBOFF  S DX=49,$X =DX,$Y=DY  X XY W @CH BON,""//// //////"",@ CHBOFF"
  6891   "RTN","CHG AS22",114, 0)
  6892    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6893   "RTN","CHG AS22",115, 0)
  6894    I VPTR'=" " I $D(^CH MVEN(VPTR, 20)) D  D  ^CHGAS18
  6895   "RTN","CHG AS22",116, 0)
  6896    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6897   "RTN","CHG AS22",117, 0)
  6898    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=31,$X=D X,$Y=DY X  XY W @CHBO N,""Vendor  Watch Inf o"",@CHBOF F S DX=49, $X=DX,$Y=D Y X XY W @ CHBON,""// ////////"" ,@CHBOFF"
  6899   "RTN","CHG AS22",118, 0)
  6900    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  6901   "RTN","CHG AS22",119, 0)
  6902    D ^CHGASO HI
  6903   "RTN","CHG AS22",120, 0)
  6904    K I,J,L,U ,X,Z,CT,CH S,RCT,II,J J,CHDT,CHB A,CHBTL,CH BATCH,CHRL
  6905   "RTN","CHG AS22",121, 0)
  6906    K CHPS,CH POS,CHME,C HMETH,CHME D,CHMAD1,C HMAD2,CHMC TY,CHMST,C HMZIP,CHID
  6907   "RTN","CHG AS22",122, 0)
  6908    K CHZONE, CHTYP,REC0 ,REC1,REC2 ,REC3,REC4 ,REC5,CHCL MO,CHAOB
  6909   "RTN","CHG AS22",123, 0)
  6910    K CHSTAT, CHDOCID,CH PITY,CHPDI TY,CHPD,CH SPON,CHBEN E,CHDOB,CH SSN
  6911   "RTN","CHG AS22",124, 0)
  6912    K CHBAD1, CHBAD2,CHB CTY,CHSTA, CHSTE,CHBS T,CHBZIP,C HDOS,CHTOS ,CHTOSS
  6913   "RTN","CHG AS22",125, 0)
  6914    K CHVNPG, CHCMAC,CHM PT,CHMAMT, CHBAMT,CHA CC,CHOHI,C HOHIF,CHDR G,CHTCB,CH OHIPR    ;  JEH 9/5/0 6 ADDED CH OHIPR
  6915   "RTN","CHG AS22",126, 0)
  6916    K CHTAA,C HEDI,CHVEN ,CHVTIDP,C HVAD1,CHVA D2,CHVST,C HVCTY,CHVZ IP,CHMTAX
  6917   "RTN","CHG AS22",127, 0)
  6918    K CHDT,CH RSN,CHRS,C HVE,CHDUZ, CHROPEN,CH TDX,CHTOSP ,CHTPRC,CH CODE,CHDAT A
  6919   "RTN","CHG AS22",128, 0)
  6920    K CHDESC, CHRULEJ,CH TYPE,CHPTR ,CHFLAG,CH COM,CHDC,F LG
  6921   "RTN","CHG AS22",129, 0)
  6922    K CHSOHIP D,CHSOHIPR ,CHSOHIAD, CHSOHIPB,C HSMEDPD,CH SNAU,CHOHI PDT,CHOHIP RT,CHOHIAD T,CHOHIPBT ,CHMEDPT,C HTPL  ; DE V7820 EW 1 /25/11
  6923   "RTN","CHG AS22",130, 0)
  6924    Q
  6925   "RTN","CHG AS22",131, 0)
  6926    ;
  6927   "RTN","CHG AS22",132, 0)
  6928   UPCT S (CT ,^UTILITY( $J,"ASQ",C HZONE,0))= CT+1 Q
  6929   "RTN","CHG AS23")
  6930   0^8^B63174 125
  6931   "RTN","CHG AS23",1,0)
  6932   CHGAS23 ;C VA/RLC;ASQ  SCREEN DI SPLAY CALC  - PART 2  (IN-PAT) ; Feb 05, 20 19@09:57:5 7
  6933   "RTN","CHG AS23",2,0)
  6934    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  6935   "RTN","CHG AS23",3,0)
  6936    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  6937   "RTN","CHG AS23",4,0)
  6938    ;             CHZONE  - SCREEN  REGION
  6939   "RTN","CHG AS23",5,0)
  6940    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 *-RLC, #12 197 (RLC)
  6941   "RTN","CHG AS23",6,0)
  6942    ;CPTS #13 310 (RLC)
  6943   "RTN","CHG AS23",7,0)
  6944    ;PT #1611 0 (Y2K)
  6945   "RTN","CHG AS23",8,0)
  6946    ;PT #1686 5 (JBM) Fi xed indire ction
  6947   "RTN","CHG AS23",9,0)
  6948    ; MC284 J EH 9/5/06  Change OHI  Paid amou nt to Pati ent Respon sibility
  6949   "RTN","CHG AS23",10,0 )
  6950    ;DEV00480 5 1/6/2010  AEB
  6951   "RTN","CHG AS23",11,0 )
  6952    ;CFS 07/1 7/2017 - D isplay PL  ZIP - CPE0 01-005
  6953   "RTN","CHG AS23",12,0 )
  6954    D INPAT^C HGAS24
  6955   "RTN","CHG AS23",13,0 )
  6956    I CHMEDPD '="" S CHM EDPD="$"_$ J($FN(CHME DPD,",",2) ,9)  ;MTN0 13163F  EW   BUG ASQ1 7 2/19/13
  6957   "RTN","CHG AS23",14,0 )
  6958    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  6959   "RTN","CHG AS23",15,0 )
  6960   UTIL S X=" X XY W @CH BON,""Date  in ASQ: " ",@CHBOFF, P1 S DX=28 ,$X=DX,$Y= DY X XY W  @CHBON,""R sn in ASQ:  "",@CHBOF F,P2 S DX= 53,$X=DX,$ Y=DY X XY  W @CHBON," "Mailman # : "",@CHBO FF,P3"
  6961   "RTN","CHG AS23",16,0 )
  6962    ; Y2K - C hg'd date  format for  CHDT
  6963   "RTN","CHG AS23",17,0 )
  6964    ;D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= X_U_$$FMTE ^XLFDT(CHD T,"2D")_U_ CHRSN_U_CH MM
  6965   "RTN","CHG AS23",18,0 )
  6966    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_$$FMTE^ XLFDT(+CHD T,"5D")_U_ CHRSN_U_CH MM
  6967   "RTN","CHG AS23",19,0 )
  6968    S X="X XY  W @CHBON, ""Admissio n: "",@CHB OFF,P1 S D X=28,$X=DX ,$Y=DY X X Y W @CHBON ,""Dischar ge: "",@CH BOFF,P2 S  DX=53,$X=D X,$Y=DY X  XY W @CHBO N,""Dis St atus: "",@ CHBOFF,P3"
  6969   "RTN","CHG AS23",20,0 )
  6970    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHDOS_U _CHDIS_U_C HDSTAT
  6971   "RTN","CHG AS23",21,0 )
  6972    S X="X XY  W @CHBON, ""Fac Disc h to: "",@ CHBOFF,P1  S DX=28,$X =DX,$Y=DY  X XY W @CH BON,""Type  of Bill:  "",@CHBOFF ,P2 S DX=5 3,$X=DX,$Y =DY X XY W  @CHBON,"" MCCR Revie w: "",@CHB OFF,P3"
  6973   "RTN","CHG AS23",22,0 )
  6974    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHFAC_U _CHTOB_U_C HMCCR
  6975   "RTN","CHG AS23",23,0 )
  6976    S X="X XY  W @CHBON, ""OHI Type : "",@CHBO FF,P1 S DX =28,$X=DX, $Y=DY X XY  W @CHBON, ""OHI Begi n: "",@CHB OFF,P2 S D X=53,$X=DX ,$Y=DY X X Y W @CHBON ,""OHI End : "",@CHBO FF,P3"
  6977   "RTN","CHG AS23",24,0 )
  6978    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_$E(CHOH TP,1,15)_U _CHOHBP_U_ CHOHEP
  6979   "RTN","CHG AS23",25,0 )
  6980    S X="X XY  W @CHBON, ""EDI Clai m: "",@CHB OFF,P1 S D X=28,$X=DX ,$Y=DY X X Y W @CHBON ,""OHI Pay mt: "",@CH BOFF,P2 S  DX=53,$X=D X,$Y=DY X  XY W @CHBO N,""Bene P aymt: "",@ CHBOFF,P3"
  6981   "RTN","CHG AS23",26,0 )
  6982    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHEDI_U _CHOHI_U_C HBAMT
  6983   "RTN","CHG AS23",27,0 )
  6984    S X="X XY  W @CHBON, ""TPL Paym t: "",@CHB OFF,P1 S D X=28,$X=DX ,$Y=DY X X Y W @CHBON ,""OHI PR  Bal: "",@C HBOFF,P2 S  DX=53,$X= DX,$Y=DY X  XY W @CHB ON,""Mcaid : "",@CHBO FF,P3"   ; MTN013163F   EW  BUG  ASQ16,17,, 18,20 2/17 /13
  6985   "RTN","CHG AS23",28,0 )
  6986    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHTPL_U _CHOHIPR_U _CHMEDPD   ;MTN013163 F  EW  BUG  ASQ16 & A SQ17 2/19/ 13
  6987   "RTN","CHG AS23",29,0 )
  6988    S X="X XY  W @CHBON, ""DRG: "", @CHBOFF,P1  S DX=28,$ X=DX,$Y=DY  X XY W @C HBON,""Pay mt Method:  "",@CHBOF F,P2 S DX= 53,$X=DX,$ Y=DY X XY  W @CHBON," "PCN: "",@ CHBOFF,P3"
  6989   "RTN","CHG AS23",30,0 )
  6990    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHDRG_U _CHMETH_U_ $E(CHPCN,1 ,20)
  6991   "RTN","CHG AS23",31,0 )
  6992    S X="S DX =53,$X=DX, $Y=DY X XY  W @CHBON, ""PL ZIP:  "",@CHBOFF ,P1"  ;CFS  CPE001-00 5
  6993   "RTN","CHG AS23",32,0 )
  6994    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_PLZIP
  6995   "RTN","CHG AS23",33,0 )
  6996    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  6997   "RTN","CHG AS23",34,0 )
  6998    S X="X XY  W @CHBON, ""Admittin g Dx: "",@ CHBOFF,P1"
  6999   "RTN","CHG AS23",35,0 )
  7000    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHADX
  7001   "RTN","CHG AS23",36,0 )
  7002    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  7003   "RTN","CHG AS23",37,0 )
  7004    S CHTOSP= $S(CHTOS=" IPT":CHTOS ,CHTOS="RX T":CHTOS,1 :"OPT")
  7005   "RTN","CHG AS23",38,0 )
  7006    D:CHTOSP' ="" @CHTOS P^CHGAS3
  7007   "RTN","CHG AS23",39,0 )
  7008    D ROOM^CH GAS24
  7009   "RTN","CHG AS23",40,0 )
  7010    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  7011   "RTN","CHG AS23",41,0 )
  7012    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" S DX=58,$X =DX,$Y=DY  X XY W ""- ---------" " S DX=70, $X=DX,$Y=D Y X XY W " "--------- -"""
  7013   "RTN","CHG AS23",42,0 )
  7014    S X="S DX =48,$X=DX, $Y=DY X XY  W @CHBON, ""Totals"" ,@CHBOFF S  DX=58,$X= DX,$Y=DY X  XY W $J(P 1,10) S DX =70,$X=DX, $Y=DY X XY  W $J(P2,1 0)"
  7015   "RTN","CHG AS23",43,0 )
  7016    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHTCB_U _CHTAA
  7017   "RTN","CHG AS23",44,0 )
  7018    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  7019   "RTN","CHG AS23",45,0 )
  7020    D REOPEN^ CHGAS24
  7021   "RTN","CHG AS23",46,0 )
  7022    S X="X XY  W @CHBON, ""Benefici ary Data:" ",@CHBOFF"
  7023   "RTN","CHG AS23",47,0 )
  7024    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X
  7025   "RTN","CHG AS23",48,0 )
  7026    S X="X XY  W @CHBON, ""DOB: "", @CHBOFF,P1  S DX=18,$ X=DX,$Y=DY  X XY W @C HBON,""Age : "",@CHBO FF,P2 S DX =30,$X=DX, $Y=DY X XY  W @CHBON, ""Sex: "", @CHBOFF,P3  S DX=50,$ X=DX,$Y=DY  X XY W @C HBON,""SSN : "",@CHBO FF,P4"
  7027   "RTN","CHG AS23",49,0 )
  7028    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHDOB_U _CHAGE_U_C HSEX_U_CHS SN
  7029   "RTN","CHG AS23",50,0 )
  7030    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=50 ,$X=DX,$Y= DY X XY W  @CHBON,""R elationshi p: "",@CHB OFF,P2"
  7031   "RTN","CHG AS23",51,0 )
  7032    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBAD1_ U_CHREL
  7033   "RTN","CHG AS23",52,0 )
  7034    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1"
  7035   "RTN","CHG AS23",53,0 )
  7036    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBAD2
  7037   "RTN","CHG AS23",54,0 )
  7038    S X="X XY  W @CHBON, ""City: "" ,@CHBOFF,P 1 S DX=28, $X=DX,$Y=D Y X XY W @ CHBON,""St ate: "",@C HBOFF,P2 S  DX=50,$X= DX,$Y=DY X  XY W @CHB ON,""Zip:  "",@CHBOFF ,P3"
  7039   "RTN","CHG AS23",55,0 )
  7040    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBCTY_ U_CHBST_U_ CHBZIP
  7041   "RTN","CHG AS23",56,0 )
  7042    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  7043   "RTN","CHG AS23",57,0 )
  7044    S VPTR=""
  7045   "RTN","CHG AS23",58,0 )
  7046    S:$D(@(GL PAY_"CHCLM ,0)")) VPT R=$P(@(GLP AY_"CHCLM, 0)"),U,3)
  7047   "RTN","CHG AS23",59,0 )
  7048    I VPTR'=" " I $D(^CH MVEN(VPTR, 20)) D
  7049   "RTN","CHG AS23",60,0 )
  7050    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7051   "RTN","CHG AS23",61,0 )
  7052    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=8,$X =DX,$Y=DY  X XY W @CH BON,""***V ENDOR WATC H DATA EXI STS FOR TH IS PROVIDE R***"",@CH BOFF"
  7053   "RTN","CHG AS23",62,0 )
  7054    ;NEXT FEW  LINES DIS PLAY BOTH  THE VENDOR  REMIT-TO  AND PL ADD RESSES
  7055   "RTN","CHG AS23",63,0 )
  7056    S X="X XY  W @CHBON, ""Tax ID:  "",@CHBOFF ,P1 S DX=2 8,$X=DX,$Y =DY X XY W  @CHBON,"" PI: "",@CH BOFF,P2 S  DX=40,$X=D X,$Y=DY X  XY W @CHBO N,""Vendor  POA Exemp t: "",@CHB OFF,P3 S D X=59,$X=DX ,$Y=DY X X Y W @CHBON ,""CMAC: " ",@CHBOFF, P4"  ;AEB  1/20/1020  DEV004805  CHANGED "V endor Page : " TO Ven dor Exempt
  7057   "RTN","CHG AS23",64,0 )
  7058    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHVTIDP _U_CHAOB_U _CHEXP_U_C HCMAC  ;AE B 1/20/201 0 DEV00480 5 changed  CHVNPG to  CHEXP
  7059   "RTN","CHG AS23",65,0 )
  7060    S X="X XY  W @CHBON, ""RT Vendo r: "",@CHB OFF,P1 S D X=42,$X=DX ,$Y=DY X X Y W @CHBON ,""PL Vend or: "",@CH BOFF,P2"
  7061   "RTN","CHG AS23",66,0 )
  7062    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHVEN_U _CHPLVEN
  7063   "RTN","CHG AS23",67,0 )
  7064    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""A ddr1: "",@ CHBOFF,P2"
  7065   "RTN","CHG AS23",68,0 )
  7066    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTAD1 _U_CHVAD1
  7067   "RTN","CHG AS23",69,0 )
  7068    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""A ddr2: "",@ CHBOFF,P2"
  7069   "RTN","CHG AS23",70,0 )
  7070    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTAD2 _U_CHVAD2
  7071   "RTN","CHG AS23",71,0 )
  7072    S X="X XY  W @CHBON, ""City:  " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""C ity:  "",@ CHBOFF,P2"
  7073   "RTN","CHG AS23",72,0 )
  7074    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTVCT Y_U_CHVCTY
  7075   "RTN","CHG AS23",73,0 )
  7076    S X="X XY  W @CHBON, ""State: " ",@CHBOFF, P1 S DX=13 ,$X=DX,$Y= DY X XY W  @CHBON,""Z ip: "",@CH BOFF,P2 S  DX=42,$X=D X,$Y=DY X  XY W @CHBO N,""State:  "",@CHBOF F,P3 S DX= 55,$X=DX,$ Y=DY X XY  W @CHBON," "Zip: "",@ CHBOFF,P4"
  7077   "RTN","CHG AS23",74,0 )
  7078    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTVST _U_CHRTVZI P_U_CHVST_ U_CHVZIP
  7079   "RTN","CHG AS23",75,0 )
  7080    I CHMED'= "" D MED^C HGAS24
  7081   "RTN","CHG AS23",76,0 )
  7082    D QUECHK^ CHGAS24
  7083   "RTN","CHG AS23",77,0 )
  7084    S CHPTR=C HCLM D ^CH GASHST,^CH GAS2IP
  7085   "RTN","CHG AS23",78,0 )
  7086    I $D(^CHM CLCOM("B", CHCLMO)) D   S CHCOM= CHCLMO D ^ CHGAS3AA K  CHCOM
  7087   "RTN","CHG AS23",79,0 )
  7088    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7089   "RTN","CHG AS23",80,0 )
  7090    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=33,$X=D X,$Y=DY X  XY W @CHBO N,""Claim  Comments"" ,@CHBOFF S  DX=49,$X= DX,$Y=DY X  XY W @CHB ON,""///// /////"",@C HBOFF"
  7091   "RTN","CHG AS23",81,0 )
  7092    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7093   "RTN","CHG AS23",82,0 )
  7094    I CHPDI'= "" I $D(^C HMCLCOM("B ",$P(CHPDI ,"-",1)))  D  S CHCOM =$P(CHPDI, "-",1) D ^ CHGAS3AB K  CHCOM
  7095   "RTN","CHG AS23",83,0 )
  7096    .I '$D(^C HMCLCOM("B ",CHCLMO))  D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" "
  7097   "RTN","CHG AS23",84,0 )
  7098    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "W "" """
  7099   "RTN","CHG AS23",85,0 )
  7100    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=33,$X=D X,$Y=DY X  XY W @CHBO N,""PDI Co mments"",@ CHBOFF S D X=49,$X=DX ,$Y=DY X X Y W @CHBON ,""/////// ///"",@CHB OFF"
  7101   "RTN","CHG AS23",86,0 )
  7102    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7103   "RTN","CHG AS23",87,0 )
  7104    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D  D ^ CHGAS17
  7105   "RTN","CHG AS23",88,0 )
  7106    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7107   "RTN","CHG AS23",89,0 )
  7108    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=33,$X=D X,$Y=DY X  XY W @CHBO N,""Bene C omments"", @CHBOFF S  DX=49,$X=D X,$Y=DY X  XY W @CHBO N,""////// ////"",@CH BOFF"
  7109   "RTN","CHG AS23",90,0 )
  7110    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7111   "RTN","CHG AS23",91,0 )
  7112    I $D(CHMW AT("BENWAT ")) D  D B ENWAT^CHGA S17
  7113   "RTN","CHG AS23",92,0 )
  7114    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7115   "RTN","CHG AS23",93,0 )
  7116    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=32,$X=D X,$Y=DY X  XY W @CHBO N,""Bene W atch Info" ",@CHBOFF  S DX=49,$X =DX,$Y=DY  X XY W @CH BON,""//// //////"",@ CHBOFF"
  7117   "RTN","CHG AS23",94,0 )
  7118    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7119   "RTN","CHG AS23",95,0 )
  7120    I VPTR'=" " I $D(^CH MVEN(VPTR, 20)) D  D  ^CHGAS18
  7121   "RTN","CHG AS23",96,0 )
  7122    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7123   "RTN","CHG AS23",97,0 )
  7124    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "S DX=20,$ X=DX,$Y=DY  X XY W @C HBON,""/// ///////"", @CHBOFF S  DX=31,$X=D X,$Y=DY X  XY W @CHBO N,""Vendor  Watch Inf o"",@CHBOF F S DX=49, $X=DX,$Y=D Y X XY W @ CHBON,""// ////////"" ,@CHBOFF"
  7125   "RTN","CHG AS23",98,0 )
  7126    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  7127   "RTN","CHG AS23",99,0 )
  7128    D ^CHGASO HI
  7129   "RTN","CHG AS23",100, 0)
  7130    K I,J,L,U ,X,Z,CT,CH S,RCT,II,J J,CHDT,CHB A,CHBAT,CH BATCH,CHRL
  7131   "RTN","CHG AS23",101, 0)
  7132    K CHPS,CH POS,CHME,C HMETH,CHME D,CHMAD1,C HMAD2,CHMC TY,CHMST,C HMZIP,CHID
  7133   "RTN","CHG AS23",102, 0)
  7134    K CHZONE, CHTYP,REC0 ,REC1,REC2 ,REC3,REC4 ,REC5,CHCL MO,CHAOB
  7135   "RTN","CHG AS23",103, 0)
  7136    K CHSTAT, CHDOCID,CH PITY,CHPDI TY,CHPD,CH SPON,CHBEN E,CHDOB,CH SSN
  7137   "RTN","CHG AS23",104, 0)
  7138    K CHBAD1, CHBAD2,CHB CTY,CHSTA, CHSTE,CHBS T,CHBZIP,C HDOS,CHTOS ,CHTOSS
  7139   "RTN","CHG AS23",105, 0)
  7140    K CHVNPG, CHCMAC,CHM PT,CHMAMT, CHBAMT,CHA CC,CHOHI,C HOHIF,CHDR G,CHTCB,CH OHIPR   ;  JEH 9/5/06  ADDED CHO HIPR
  7141   "RTN","CHG AS23",106, 0)
  7142    K CHTAA,C HEDI,CHVEN ,CHVTIDP,C HVAD1,CHVA D2,CHVST,C HVCTY,CHVZ IP,CHMTAX
  7143   "RTN","CHG AS23",107, 0)
  7144    K CHDT,CH RSN,CHRS,C HVE,CHDUZ, CHROPEN,CH TDX,CHTOSP ,CHTPRC,CH CODE,CHDAT A
  7145   "RTN","CHG AS23",108, 0)
  7146    K CHDESC, CHRULEJ,CH TYPE,CHPTR ,CHFLAG,CH COM,CHDC,F LG,CHDIS,C HADX
  7147   "RTN","CHG AS23",109, 0)
  7148    K CHDSTAT ,CHFAC,CHR X,CHDPTR,C HADPT,CHAD XCD,CHFPT, J1,CHFLG,C HR2,CHRPT
  7149   "RTN","CHG AS23",110, 0)
  7150    K CHRTP,C HRT,CHRCHG ,CHRMRT,CH RMDAY,CHAA
  7151   "RTN","CHG AS23",111, 0)
  7152    Q
  7153   "RTN","CHG AS23",112, 0)
  7154    ;
  7155   "RTN","CHG AS23",113, 0)
  7156   UPCT S (CT ,^UTILITY( $J,"ASQ",C HZONE,0))= CT+1 Q
  7157   "RTN","CHG ASIP")
  7158   0^9^B60716 419
  7159   "RTN","CHG ASIP",1,0)
  7160   CHGASIP ;C VA/RLC;ASQ  WIP REPOR T PRINT -  IN-PAT CLA IMS ;Feb 0 5, 2019@09 :58:51
  7161   "RTN","CHG ASIP",2,0)
  7162    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  7163   "RTN","CHG ASIP",3,0)
  7164    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 *, #13310  (RLC)
  7165   "RTN","CHG ASIP",4,0)
  7166    ;NOIS CP2 -0203-1017 7 (JEH) Fi xed bene c omments pr inting for  all claim s
  7167   "RTN","CHG ASIP",5,0)
  7168    ;MC284 JE H 9/5/06 C hange OHI  Paid amoun t to Patie nt Respons ibility
  7169   "RTN","CHG ASIP",6,0)
  7170    ;DEV00480 5 1/20/201 0 AEB
  7171   "RTN","CHG ASIP",7,0)
  7172    ;MTN01316 3 11/1/201 1 DGC
  7173   "RTN","CHG ASIP",8,0)
  7174    ;CPE001-0 06 ;05/03/ 2017; AJF
  7175   "RTN","CHG ASIP",9,0)
  7176    ;CPE001-0 08 5/12/20 17 wtc
  7177   "RTN","CHG ASIP",10,0 )
  7178    ;DEFECT 8 61585 - TG H - 11/26/ 18 Correct  PL Zip va riable
  7179   "RTN","CHG ASIP",11,0 )
  7180    ;DEFECT 8 77425 - TG H - 12/4/1 8 Display  PL ZIP onl y if Inpat ient, Outp atient, or  Dental
  7181   "RTN","CHG ASIP",12,0 )
  7182    D HEAD
  7183   "RTN","CHG ASIP",13,0 )
  7184    S REC2=^T MP($J,"WIP ",CHPDI,CH PROG,CHCLM ,2),REC3=^ TMP($J,"WI P",CHPDI,C HPROG,CHCL M,3),REC4= ^TMP($J,"W IP",CHPDI, CHPROG,CHC LM,4),REC5 =^TMP($J," WIP",CHPDI ,CHPROG,CH CLM,5),REC 6=^TMP($J, "WIP",CHPD I,CHPROG,C HCLM,6)
  7185   "RTN","CHG ASIP",14,0 )
  7186    S CHTY=$P (REC1,U,1) ,CHBENE=$P (REC1,U,2) ,CHSPON=$P (REC1,U,3) ,CHDOB=$P( REC1,U,4), CHREL=$P(R EC1,U,5),C HSSN=$P(RE C1,U,6),CH DOS=$P(REC 1,U,7)
  7187   "RTN","CHG ASIP",15,0 )
  7188    S CHAOB=$ P(REC1,U,8 ),CHPCN=$P (REC1,U,9) ,CHTOB=$P( REC1,U,10) ,CHBAMT=$P (REC1,U,11 ),DFN=$P(R EC1,U,12), BFN=$P(REC 1,U,13)
  7189   "RTN","CHG ASIP",16,0 )
  7190    S CHID=$P (REC2,U,1) ,CHBAD1=$P (REC2,U,2) ,CHBAD2=$P (REC2,U,3) ,CHBCTY=$P (REC2,U,4) ,CHBST=$P( REC2,U,5), CHBZIP=$P( REC2,U,6), CHSEX=$P(R EC2,U,7),C HAGE=$P(RE C2,U,8),CH STPLT=$P(R EC2,U,9)   ;DGC 2/20/ 2013 MTN01 3163
  7191   "RTN","CHG ASIP",17,0 )
  7192    S CHVE=$P (REC3,U,1) ,CHPDITY=$ P(REC3,U,2 ),CHBATCH= $P(REC3,U, 3),CHDOC=$ P(REC3,U,4 ),CHDT=$P( REC3,U,5), CHSTS=$P(R EC3,U,6),C HRSN=$P(RE C3,U,7),CH TOS=$P(REC 3,U,8),CHP OS=$P(REC3 ,U,9),CHAM T=$P(REC3, U,10),CHED I=$P(REC3, U,11),CHAL W=$P(REC3, U,12)
  7193   "RTN","CHG ASIP",18,0 )
  7194    ;S CHVEN= $P(REC4,U, 1),CHTAXP= $P(REC4,U, 2),CHVNPG= $P(REC4,U, 3),CHCMAC= $P(REC4,U, 4),CHMCCR= $P(REC4,U, 5),CHOHI=$ P(REC4,U,6 ),CHVAD1=$ P(REC4,U,7 ),CHVAD2=$ P(REC4,U,8 ),CHVCTY=$ P(REC4,U,9 ),CHVST=$P (REC4,U,10 ),CHVZIP=$ P(REC4,U,1 1),CHPLVEN =$P(REC4,U ,12)
  7195   "RTN","CHG ASIP",19,0 )
  7196    ;CJM LINE  LENGTH FO R MIGRATIO N R1 20170 719
  7197   "RTN","CHG ASIP",20,0 )
  7198    S CHVEN=$ P(REC4,U,1 ),CHTAXP=$ P(REC4,U,2 ),CHVNPG=$ P(REC4,U,3 ),CHCMAC=$ P(REC4,U,4 ),CHMCCR=$ P(REC4,U,5 ),CHOHI=$P (REC4,U,6) ,CHVAD1=$P (REC4,U,7) ,CHVAD2=$P (REC4,U,8) ,CHVCTY=$P (REC4,U,9) ,CHVST=$P( REC4,U,10) ,CHVZIP=$P (REC4,U,11 )
  7199   "RTN","CHG ASIP",21,0 )
  7200    S CHPLVEN =$P(REC4,U ,12),CHOHI PR=$P(REC4 ,U,13),CHE XP=$P(REC4 ,U,14)  ;  JEH 9/5/06  ADD CHOHI PR AEB 1/2 0/2010 DEV 004805
  7201   "RTN","CHG ASIP",22,0 )
  7202    S CHMED=$ P(REC5,U,1 ),CHMAD1=$ P(REC5,U,2 ),CHMAD2=$ P(REC5,U,3 ),CHMCTY=$ P(REC5,U,4 ),CHMST=$P (REC5,U,5) ,CHMZIP=$P (REC5,U,6) ,CHDRG=$P( REC5,U,7), CHMETH=$P( REC5,U,8), CHMTAXP=$P (REC5,U,9) ,CHMEDPD=$ P(REC5,U,1 0)
  7203   "RTN","CHG ASIP",23,0 )
  7204    S CHOHT=$ P(REC6,U,1 ),CHOHB=$P (REC6,U,2) ,CHOHE=$P( REC6,U,3), CHRTAD1=$P (REC6,U,4) ,CHRTAD2=$ P(REC6,U,5 ),CHRTVCTY =$P(REC6,U ,6),CHRTVS T=$P(REC6, U,7),CHRTV ZIP=$P(REC 6,U,8)
  7205   "RTN","CHG ASIP",24,0 )
  7206    N CHCLMNU M ;
  7207   "RTN","CHG ASIP",25,0 )
  7208    S CHCLMNU M=$O(^CHMP AY("B",CHC LM,0)),PLZ IP="" ; Ge t pointer  to claim h m 5/17
  7209   "RTN","CHG ASIP",26,0 )
  7210    I CHCLMNU M'="" S PL ZIP=$P($G( ^CHMPAY(CH CLMNUM,"VE N-II")),"^ ",15) ; Ge t Physical  Location  ZIP from C laim wtc 5 /14/17
  7211   "RTN","CHG ASIP",27,0 )
  7212    D INP^CHG ASPU
  7213   "RTN","CHG ASIP",28,0 )
  7214    S:CHCMAC= "" CHCMAC= 3
  7215   "RTN","CHG ASIP",29,0 )
  7216    ;
  7217   "RTN","CHG ASIP",30,0 )
  7218   PRINT W !! ,"PDI:  ", CHPDI,"-", CHPDITY,?2 8,"Claim # : ",CHCLM, ?53,"Bene:  ",CHBENE
  7219   "RTN","CHG ASIP",31,0 )
  7220    W !,"Batc h #:  ",CH BATCH,?28, "TOS:  ",C HTOS,?53," Spon: ",CH SPON
  7221   "RTN","CHG ASIP",32,0 )
  7222    W !,"Doc  Id#:  ",CH DOC,?28,"S tatus:  ", CHSTS,?55, "VE: ",CHV E
  7223   "RTN","CHG ASIP",33,0 )
  7224    W !,"Prog ram:  ",CH PROG
  7225   "RTN","CHG ASIP",34,0 )
  7226    W !!,"Dat e in ASQ:  ",$$FMTE^X LFDT(CHDT, "2D"),?28, "Rsn in AS Q: ",CHRSN ,?53,"Mail man #: ",C HMM
  7227   "RTN","CHG ASIP",35,0 )
  7228    W !,"Admi ssion: ",$ $FMTE^XLFD T(CHDOS,"2 D"),?28,"D ischarge:  ",$$FMTE^X LFDT(CHDIS ,"2D"),?53 ,"Dis Stat us: ",CHDS TAT
  7229   "RTN","CHG ASIP",36,0 )
  7230    W !,"Fac  Disch to:  ",CHFAC,?2 8,"Type of  Bill: ",C HTOB,?53," MCCR Revie w: ",CHMCC R
  7231   "RTN","CHG ASIP",37,0 )
  7232    D OHI^CHG ASP
  7233   "RTN","CHG ASIP",38,0 )
  7234    W !,"OHI  Type: ",$E (CHOHTP,1, 15),?28,"O HI Begin:  ",$$FMTE^X LFDT(CHOHB P,"2D"),?5 3,"OHI End : ",$$FMTE ^XLFDT(CHO HEP,"2D")
  7235   "RTN","CHG ASIP",39,0 )
  7236    W !,"EDI  Claim: ",C HEDI
  7237   "RTN","CHG ASIP",40,0 )
  7238    I CHOHI'= "" W ?28," OHI Paymt:  ","$ ",$J ($FN(CHOHI ,",",2),9)
  7239   "RTN","CHG ASIP",41,0 )
  7240    E  W ?28, "OHI Paymt : ",CHOHI
  7241   "RTN","CHG ASIP",42,0 )
  7242    I CHOHIPR '="" D   ;  JEH 9/5/0 6 ADDED PA TIENT RESP  LOGIC
  7243   "RTN","CHG ASIP",43,0 )
  7244    .W !,"OHI  PR Bal: " ,"$ ",$J($ FN(CHOHIPR ,",",2),9)  ;MTN01316 3F  EW  BU G ASQ20 2/ 17/13
  7245   "RTN","CHG ASIP",44,0 )
  7246    E  I CHOH I'="" D
  7247   "RTN","CHG ASIP",45,0 )
  7248    .S CHOHIP R=CHAMT-CH OHI
  7249   "RTN","CHG ASIP",46,0 )
  7250    .W !,"OHI  PR Bal: " ,"$ ",$J($ FN(CHOHIPR ,",",2),9)  ; MTN0131 63F  EW  B UG ASQ20 2 /17/13
  7251   "RTN","CHG ASIP",47,0 )
  7252    E  I (CHO HI="")!(CH OHIPR="")  D          ;DGC 3/7/2 013 MTN013 163 ASQWIP  2
  7253   "RTN","CHG ASIP",48,0 )
  7254    .W !,"OHI  PR Bal: "                               ;D GC 3/7/201 3 MTN01316 3 ASQWIP 2
  7255   "RTN","CHG ASIP",49,0 )
  7256    I CHBAMT' ="" W ?53, "Bene Paym t:  ","$ " ,$J($FN(CH BAMT,",",2 ),9)
  7257   "RTN","CHG ASIP",50,0 )
  7258    E  W ?53, "Bene Paym t: ",CHBAM T
  7259   "RTN","CHG ASIP",51,0 )
  7260    W !,"TPL  Paymt: "                                                                                      ;DGC  2/20/2013  MTN013163
  7261   "RTN","CHG ASIP",52,0 )
  7262    I CHSTPLT '="" W "$  ",$J($FN(C HSTPLT,"," ,2),9)                             ;DGC 2/2 0/2013 MTN 013163
  7263   "RTN","CHG ASIP",53,0 )
  7264    W !,"Drg:  ",CHDRG,? 28,"Paymt  Method: ", CHMETH,?53 ,"PCN: ",$ E(CHPCN,1, 20)
  7265   "RTN","CHG ASIP",54,0 )
  7266    ;DEFECT 8 77425 - TG H - 12/4/1 8 Display  PL ZIP onl y if Inpat ient, Outp atient, or  Dental
  7267   "RTN","CHG ASIP",55,0 )
  7268    ;W !,?53, "PL ZIP: " ,PLZIP ; w tc 4/25/17
  7269   "RTN","CHG ASIP",56,0 )
  7270    I (CHTOS[ "INPATIENT "!(CHTOS[" OUTPATIENT ")!(CHTOS[ "DENTAL"))  W !,?53," PL ZIP: ", PLZIP ; wt c 4/25/17
  7271   "RTN","CHG ASIP",57,0 )
  7272    W !!,"Adm itting Dx:  ",CHADXCD ,"-",CHADX
  7273   "RTN","CHG ASIP",58,0 )
  7274    W !!,"Cod e/POA",?12 ,"Descript ion",?55," Total Chg" ,?69,"Tota l AA"   ;D GC 11/1/20 11 MTN0131 63
  7275   "RTN","CHG ASIP",59,0 )
  7276    W !,"---- ---------- ---------- ---------- --------", ?54,"----- ------",?6 8,"------- ----"
  7277   "RTN","CHG ASIP",60,0 )
  7278    D DIAG^CH GASPU
  7279   "RTN","CHG ASIP",61,0 )
  7280    D PROC^CH GASPU
  7281   "RTN","CHG ASIP",62,0 )
  7282    D ITEM^CH GASPU
  7283   "RTN","CHG ASIP",63,0 )
  7284    D NC^CHGA SPU
  7285   "RTN","CHG ASIP",64,0 )
  7286    D ROOM^CH GASPU
  7287   "RTN","CHG ASIP",65,0 )
  7288    W !,?54," ---------- -",?68,"-- ---------"
  7289   "RTN","CHG ASIP",66,0 )
  7290    W !,?44," Totals"
  7291   "RTN","CHG ASIP",67,0 )
  7292    I CHAMT'= "" W ?54,$ J($FN(CHAM T,",",2),1 1)
  7293   "RTN","CHG ASIP",68,0 )
  7294    I CHALW'= "" W ?68,$ J($FN(CHAL W,",",2),1 1)
  7295   "RTN","CHG ASIP",69,0 )
  7296    E  S CHAL W="Und" W  ?68,$J(CHA LW,11)
  7297   "RTN","CHG ASIP",70,0 )
  7298    D REOPEN^ CHGASPU
  7299   "RTN","CHG ASIP",71,0 )
  7300    W !!,"Ben eficiary D ata:"
  7301   "RTN","CHG ASIP",72,0 )
  7302    W !,"DOB:  ",$$FMTE^ XLFDT(CHDO B,"2D"),?1 8,"Age: ", CHAGE,?30, "Sex: ",CH SEX,?50,"S SN: ",CHSS N
  7303   "RTN","CHG ASIP",73,0 )
  7304    W !,"Addr 1: ",CHBAD 1,?50,"Rel ationship:  ",CHREL
  7305   "RTN","CHG ASIP",74,0 )
  7306    W !,"Addr 2: ",CHBAD 2
  7307   "RTN","CHG ASIP",75,0 )
  7308    W !,"City : ",CHBCTY ,?28,"Stat e: ",CHBST ,?50,"Zip:  ",CHBZIP
  7309   "RTN","CHG ASIP",76,0 )
  7310    D WATCHK^ CHGASCOM
  7311   "RTN","CHG ASIP",77,0 )
  7312    W:LNFEED= 1 ! W:LNFE ED=2 !!
  7313   "RTN","CHG ASIP",78,0 )
  7314    I CHTOS'= "INPATIENT " W "Tax I D: ",CHTAX P,?28,"PI:  ",CHAOB,? 40,"Vendor  Page: ",C HVNPG,?59, "CMAC: ",C HCMAC
  7315   "RTN","CHG ASIP",79,0 )
  7316    I CHTOS=" INPATIENT"  W "Tax ID : ",CHTAXP ,?28,"PI:  ",CHAOB,?4 0,"Vendor  POA Exempt : ",CHEXP, ?59,"CMAC:  ",CHCMAC   ;AEB 1/20 /2010 DEV0 04805
  7317   "RTN","CHG ASIP",80,0 )
  7318    ;W "Tax I D: ",CHTAX P,?28,"PI:  ",CHAOB,? 40,"Vendor  Page: ",C HVNPG,?59, "CMAC: ",C HCMAC
  7319   "RTN","CHG ASIP",81,0 )
  7320    W !,"RT V endor: ",C HVEN,?42," PL Vendor:  ",CHPLVEN
  7321   "RTN","CHG ASIP",82,0 )
  7322    W !,"Addr 1: ",CHRTA D1,?42,"Ad dr1: ",CHV AD1
  7323   "RTN","CHG ASIP",83,0 )
  7324    W !,"Addr 2: ",CHRTA D2,?42,"Ad dr2: ",CHV AD2
  7325   "RTN","CHG ASIP",84,0 )
  7326    W !,"City :  ",CHRTV CTY,?42,"C ity:  ",CH VCTY
  7327   "RTN","CHG ASIP",85,0 )
  7328    W !,"Stat e: ",CHRTV ST,?13,"Zi p: ",CHRTV ZIP,?42,"S tate: ",CH VST,?55,"Z ip: ",CHVZ IP
  7329   "RTN","CHG ASIP",86,0 )
  7330    ; DEFECT  861585 - T GH - 11/27 /18 Correc t PL Zip v ariable
  7331   "RTN","CHG ASIP",87,0 )
  7332    ; AJF ;CP E001-006
  7333   "RTN","CHG ASIP",88,0 )
  7334    ;W !,"PL  Zip: ",CHP LZIP
  7335   "RTN","CHG ASIP",89,0 )
  7336    I (CHTOS[ "INPATIENT "!(CHTOS[" OUTPATIENT ")!(CHTOS[ "DENTAL"))  W !,"PL Z ip: ",PLZI P
  7337   "RTN","CHG ASIP",90,0 )
  7338    I CHMED'= "" D MED^C HGASPU
  7339   "RTN","CHG ASIP",91,0 )
  7340    D ^CHGASQ P
  7341   "RTN","CHG ASIP",92,0 )
  7342    D ^CHGASH IP
  7343   "RTN","CHG ASIP",93,0 )
  7344    D:$D(^CHM CLCOM("B", CHCLM)) CL AIM^CHGASC OM
  7345   "RTN","CHG ASIP",94,0 )
  7346    D:$D(^CHM CLCOM("B", CHPDI)) PD I^CHGASCOM
  7347   "RTN","CHG ASIP",95,0 )
  7348    ;CHECK FO R BENE WAT CH COMMENT S
  7349   "RTN","CHG ASIP",96,0 )
  7350    D BWATCH^ CHGAS17
  7351   "RTN","CHG ASIP",97,0 )
  7352    I $D(CHMW AT) D
  7353   "RTN","CHG ASIP",98,0 )
  7354    .D BENWAT ^CHGASCOM
  7355   "RTN","CHG ASIP",99,0 )
  7356    .S CHDFN= DFN,CHBFN= BFN
  7357   "RTN","CHG ASIP",100, 0)
  7358    .D BNWATC M^CHGASCOM
  7359   "RTN","CHG ASIP",101, 0)
  7360    I $D(BI)  I BI'="" I  $D(WATCOM ("BENWAT", BI)) D
  7361   "RTN","CHG ASIP",102, 0)
  7362    .S BJ=$P( CHMWAT("BE NWAT"),U,2 )
  7363   "RTN","CHG ASIP",103, 0)
  7364    .S BK=0 F   S BK=$O( WATCOM("BE NWAT",BI,B J,BK)) Q:' BK  S REC2 =WATCOM("B ENWAT",BI, BJ,BK) W ! !,"Watch B egin: ",$P (REC2,U,1) ,?46,"User : ",$P(REC 2,U,2),!," Watch End:  ",$P(REC2 ,U,3),?46, "User: ",$ P(REC2,U,4 ) S BL=0 D
  7365   "RTN","CHG ASIP",104, 0)
  7366    ..F  S BL =$O(WATCOM ("BENWAT", BI,BJ,BK,B L)) Q:'BL   W !,"      ",WATCOM( "BENWAT",B I,BJ,BK,BL )
  7367   "RTN","CHG ASIP",105, 0)
  7368    ;CHECK FO R BENE COM MENTS
  7369   "RTN","CHG ASIP",106, 0)
  7370    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D
  7371   "RTN","CHG ASIP",107, 0)
  7372    .D BENE^C HGASCOM
  7373   "RTN","CHG ASIP",108, 0)
  7374    .S CHDFN= DFN,CHBFN= BFN
  7375   "RTN","CHG ASIP",109, 0)
  7376    .D BENCOM ^CHGASCOM
  7377   "RTN","CHG ASIP",110, 0)
  7378    .D:$D(BEN COM("BEN") )
  7379   "RTN","CHG ASIP",111, 0)
  7380    ..S I1=0  F  S I1=$O (BENCOM("B EN",CHDFN, CHBFN,I1))  Q:'I1  W  !!,"Date:  ",$P(BENCO M("BEN",CH DFN,CHBFN, I1),"^",2) ,?46,"User : ",$P(BEN COM("BEN", CHDFN,CHBF N,I1),"^", 1) S I2=0  D
  7381   "RTN","CHG ASIP",112, 0)
  7382    ...F  S I 2=$O(BENCO M("BEN",CH DFN,CHBFN, I1,I2)) Q: 'I2  W !,"      ",BEN COM("BEN", CHDFN,CHBF N,I1,I2)
  7383   "RTN","CHG ASIP",113, 0)
  7384    S CHVPT=" "
  7385   "RTN","CHG ASIP",114, 0)
  7386    I CHVEN'= "" I $D(^C HMVEN("B", CHVEN)) D
  7387   "RTN","CHG ASIP",115, 0)
  7388    .S CHVPT= 0
  7389   "RTN","CHG ASIP",116, 0)
  7390    .S CHVPT= $O(^CHMVEN ("B",CHVEN ,CHVPT))
  7391   "RTN","CHG ASIP",117, 0)
  7392    .Q
  7393   "RTN","CHG ASIP",118, 0)
  7394    ;CHECK TO  SEE IF VE NDOR IS ON  WATCH
  7395   "RTN","CHG ASIP",119, 0)
  7396    I CHVPT'= "" I $D(^C HMVEN(CHVP T,20)) D
  7397   "RTN","CHG ASIP",120, 0)
  7398    .D VEND^C HGASCOM
  7399   "RTN","CHG ASIP",121, 0)
  7400    .D VENCOM ^CHGASCOM
  7401   "RTN","CHG ASIP",122, 0)
  7402    I CHVPT'= "" I $D(VE NCOM("VEND ",CHVPT))  D
  7403   "RTN","CHG ASIP",123, 0)
  7404    .S VJ=0 F   S VJ=$O( VENCOM("VE ND",CHVPT, VJ)) Q:'VJ   S REC2=V ENCOM("VEN D",CHVPT,V J) W !!,"W atch Begin : ",$P(REC 2,U,1),?46 ,"User: ", $P(REC2,U, 2),!,"Watc h End: ",$ P(REC2,U,3 ),?46,"Use r: ",$P(RE C2,U,4) S  VK=0 D
  7405   "RTN","CHG ASIP",124, 0)
  7406    ..F  S VK =$O(VENCOM ("VEND",CH VPT,VJ,VK) ) Q:'VK  W  !,"     " ,VENCOM("V END",CHVPT ,VJ,VK)
  7407   "RTN","CHG ASIP",125, 0)
  7408    D OHI^CHG ASPU
  7409   "RTN","CHG ASIP",126, 0)
  7410    D PART2^C HGASGOP
  7411   "RTN","CHG ASIP",127, 0)
  7412    Q
  7413   "RTN","CHG ASIP",128, 0)
  7414    ;
  7415   "RTN","CHG ASIP",129, 0)
  7416   NODATA I C HDUZ'="" W  !!!,"THER E ARE NO A CTIVE CLAI MS IN THE  AUDIT SUPP ORT QUEUE  FOR ",CHDZ ,"."
  7417   "RTN","CHG ASIP",130, 0)
  7418    I CHREAS' ="" W !!!, "THERE ARE  NO ACTIVE  ",CHREASN ," IN THE  AUDIT SUPP ORT QUEUE. "
  7419   "RTN","CHG ASIP",131, 0)
  7420   END K REC1 ,REC2,REC3 ,REC4,REC5 ,REC6,REC7 ,REC8,HREC ,CHBENE,CH DOB
  7421   "RTN","CHG ASIP",132, 0)
  7422    K CHSPON, CHREL,CHSS N,CHDOS,CH AOB,CHALL, CHBAMT,CHI D,CHBAD1,C HBAD2,CHBS T
  7423   "RTN","CHG ASIP",133, 0)
  7424    K CHBCTY, CHBZIP,CHV E,CHPDITY, CHBATCH,CH DOC,CHDT,C HSTS,CHRSN ,CHTOS,CHP OS
  7425   "RTN","CHG ASIP",134, 0)
  7426    K CHAMT,C HEDI,CHALW ,CHVEN,CHT AX,CHVNPG, CHCMAC,CHO HIF,CHOHI, CHVAD1,CHV ST,CHOHIPR    ; JEH 9 /5/06 ADDE D CHOHIPR
  7427   "RTN","CHG ASIP",135, 0)
  7428    K CHVAD2, CHVCTY,CHV ZIP,CHMED, CHMAD1,CHM AD2,CHMCTY ,CHMST,CHM ZIP,CHDRG
  7429   "RTN","CHG ASIP",136, 0)
  7430    K CHMETH, CHPSVEN,CH PSTAX,CHPS AD1,CHPSAD 2,CHPSCTY, CHPST,CHPS ZIP,CHDSBE N
  7431   "RTN","CHG ASIP",137, 0)
  7432    K CHDSSN, CHDAD1,CHD AD2,CHDCTY ,CHDST,CHD ZIP,CHDSDO B,CHDSREL, CHNAM,CHTY PE
  7433   "RTN","CHG ASIP",138, 0)
  7434    K CHDIS,C HDSTAT,CHA DX,CHADXCD ,CHFAC,X,C HREC,CHDX, CHDIAG,N,C HRC,CHPROC
  7435   "RTN","CHG ASIP",139, 0)
  7436    K CHDES,C HCHG,CHMOD ,CHPL,CHAL L,CT,CHFLA G,CHFLG1,C HFLG2,CHR, CHIDT,CHIT EM
  7437   "RTN","CHG ASIP",140, 0)
  7438    K CHITAMT ,CHANES,CH ANCST,CHAN ECST,CHPSC D,CHDSC,CN T,CHR1,CHN TEM,CHNAMT
  7439   "RTN","CHG ASIP",141, 0)
  7440    K CHANS,C HPNC,CHDSC R,XX,CHR2, CHRTP,CHRM RT,CHRMDAY ,^TMP($J," WIP")
  7441   "RTN","CHG ASIP",142, 0)
  7442    K PLZIP ;  wtc 5/2/1 7
  7443   "RTN","CHG ASIP",143, 0)
  7444    Q
  7445   "RTN","CHG ASIP",144, 0)
  7446    ;
  7447   "RTN","CHG ASIP",145, 0)
  7448   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  7449   "RTN","CHG ASIP",146, 0)
  7450    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  7451   "RTN","CHG ASIP",147, 0)
  7452    Q
  7453   "RTN","CHG ASIP",148, 0)
  7454   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  7455   "RTN","CHG ASIP",149, 0)
  7456   HEAD W #,D UZ,?33,"CH AMPVA CENT ER",?72,"P age:  ",PG  S PG=PG+1
  7457   "RTN","CHG ASIP",150, 0)
  7458    I CHXREF= "O" W !,TI ME,?30,"Co ding Queue  WIP Repor t",!,$E(DT ,4,7),?80- $L(DATE)/2 ,DATE   ;  JEH 8/6/06
  7459   "RTN","CHG ASIP",151, 0)
  7460    E  W !,TI ME,?25,"Au dit Suppor t Queue WI P Report", !,$E(DT,4, 7),?80-$L( DATE)/2,DA TE
  7461   "RTN","CHG ASIP",152, 0)
  7462    Q
  7463   "RTN","CHG ASP")
  7464   0^10^B8630 4290
  7465   "RTN","CHG ASP",1,0)
  7466   CHGASP ;CV A/RLC;ASQ  WIP REPORT  PRINT - P ART 1 ;Feb  05, 2019@ 10:00:01
  7467   "RTN","CHG ASP",2,0)
  7468    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  7469   "RTN","CHG ASP",3,0)
  7470    ;;V2.0;;
  7471   "RTN","CHG ASP",4,0)
  7472    ;PRINTS M AIN BODY O F WIP REPO RT FOR ALL  CLAIMS EX CEPT IN-PA TIENT.
  7473   "RTN","CHG ASP",5,0)
  7474    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 * (RLC), # 12197* (RL C)
  7475   "RTN","CHG ASP",6,0)
  7476    ;CPTS #13 310 (RLC),  #13477 (R LC)
  7477   "RTN","CHG ASP",7,0)
  7478    ;CPTS #16 865 (JBM)  Fixed indi rection
  7479   "RTN","CHG ASP",8,0)
  7480    ;NOIS CP2 -0203-1017 7 (JEH) Fi xed bene c omments pr inting for  all claim s
  7481   "RTN","CHG ASP",9,0)
  7482    ;MC284 JE H 9/5/06 C hange OHI  Paid amoun t to Patie nt Respons ibility
  7483   "RTN","CHG ASP",10,0)
  7484    ;DEV00782 0 03/15/20 11 DGC SLL A project
  7485   "RTN","CHG ASP",11,0)
  7486    ;MTN01316 3 10/13/20 11 DGC SLL A PROJECT
  7487   "RTN","CHG ASP",12,0)
  7488    ;CPE001-0 08 6/19/20 17 WTC CCS E
  7489   "RTN","CHG ASP",13,0)
  7490    ;DEFECT 8 77425 - TG H- 12/6/18  - Print P L ZIP only  if TOS is  Inpatient , Outpatie nt, or Den tal
  7491   "RTN","CHG ASP",14,0)
  7492    S X=DT D  DTPRT S DA TE=Y,PG=1, X=$P($H,", ",2),H=X\3 600,M=X#36 00\60
  7493   "RTN","CHG ASP",15,0)
  7494    S:M<10 M= 0_M S:H<10  H=0_H S T IME=H_M
  7495   "RTN","CHG ASP",16,0)
  7496    ;
  7497   "RTN","CHG ASP",17,0)
  7498    I CHCNT=0  D HEAD G  NODATA
  7499   "RTN","CHG ASP",18,0)
  7500    S CHPDI=" ",U="^"
  7501   "RTN","CHG ASP",19,0)
  7502   A1 S CHPDI =$O(^TMP($ J,"WIP",CH PDI)) G:CH PDI="" END
  7503   "RTN","CHG ASP",20,0)
  7504    S CHPROG= ""
  7505   "RTN","CHG ASP",21,0)
  7506   A2 S CHPRO G=$O(^TMP( $J,"WIP",C HPDI,CHPRO G)) G:CHPR OG="" A1
  7507   "RTN","CHG ASP",22,0)
  7508    S CHCLM=" "
  7509   "RTN","CHG ASP",23,0)
  7510   A3 S CHCLM =$O(^TMP($ J,"WIP",CH PDI,CHPROG ,CHCLM)) G :CHCLM=""  A2
  7511   "RTN","CHG ASP",24,0)
  7512    S REC1=^( CHCLM,1)
  7513   "RTN","CHG ASP",25,0)
  7514    S U="^"
  7515   "RTN","CHG ASP",26,0)
  7516    S REC2=^T MP($J,"WIP ",CHPDI,CH PROG,CHCLM ,2),REC3=^ TMP($J,"WI P",CHPDI,C HPROG,CHCL M,3),REC4= ^TMP($J,"W IP",CHPDI, CHPROG,CHC LM,4)
  7517   "RTN","CHG ASP",27,0)
  7518    S REC5=^T MP($J,"WIP ",CHPDI,CH PROG,CHCLM ,5),REC6=^ TMP($J,"WI P",CHPDI,C HPROG,CHCL M,6)
  7519   "RTN","CHG ASP",28,0)
  7520    S CHTY=$P (REC1,U,1) ,CHBENE=$P (REC1,U,2) ,CHSPON=$P (REC1,U,3) ,CHDOB=$P( REC1,U,4), CHREL=$P(R EC1,U,5),C HSSN=$P(RE C1,U,6),CH DOS=$P(REC 1,U,7)
  7521   "RTN","CHG ASP",29,0)
  7522    S CHAOB=$ P(REC1,U,8 ),CHPCN=$P (REC1,U,9) ,CHTOB=$P( REC1,U,10) ,CHBAMT=$P (REC1,U,11 ),DFN=$P(R EC1,U,12), BFN=$P(REC 1,U,13)
  7523   "RTN","CHG ASP",30,0)
  7524    S XDOS=""  S:CHDOS'= "" XDOS=CH DOS
  7525   "RTN","CHG ASP",31,0)
  7526    I CHTY=1  D ^CHGASIP  G A3
  7527   "RTN","CHG ASP",32,0)
  7528    ;
  7529   "RTN","CHG ASP",33,0)
  7530    D HEAD
  7531   "RTN","CHG ASP",34,0)
  7532    S CHID=$P (REC2,U,1) ,CHBAD1=$P (REC2,U,2) ,CHBAD2=$P (REC2,U,3) ,CHBCTY=$P (REC2,U,4) ,CHBST=$P( REC2,U,5), CHBZIP=$P( REC2,U,6), CHSEX=$P(R EC2,U,7),C HAGE=$P(RE C2,U,8),CH STPLT=$P(R EC2,U,9),C HSPOP=$P(R EC2,U,10)   ;DGC 01/3 0/11 DEV00 7820
  7533   "RTN","CHG ASP",35,0)
  7534    S CHVE=$P (REC3,U,1) ,CHPDITY=$ P(REC3,U,2 ),CHBATCH= $P(REC3,U, 3),CHDOC=$ P(REC3,U,4 ),CHDT=$P( REC3,U,5), CHSTS=$P(R EC3,U,6),C HRSN=$P(RE C3,U,7),CH TOS=$P(REC 3,U,8),CHP OS=$P(REC3 ,U,9),CHAM T=$P(REC3, U,10),CHED I=$P(REC3, U,11),CHAL W=$P(REC3, U,12)
  7535   "RTN","CHG ASP",36,0)
  7536    ;S CHVEN= $P(REC4,U, 1),CHTAXP= $P(REC4,U, 2),CHVNPG= $P(REC4,U, 3),CHCMAC= $P(REC4,U, 4),CHMCCR= $P(REC4,U, 5),CHOHI=$ P(REC4,U,6 ),CHVAD1=$ P(REC4,U,7 ),CHVAD2=$ P(REC4,U,8 ),CHVCTY=$ P(REC4,U,9 ),CHVST=$P (REC4,U,10 ),CHVZIP=$ P(REC4,U,1 1),CHPLVEN =$P(REC4,U ,12)
  7537   "RTN","CHG ASP",37,0)
  7538    ;CJM LINE  LENGTH FO R MIGRATIO N R1 20170 719
  7539   "RTN","CHG ASP",38,0)
  7540    S CHVEN=$ P(REC4,U,1 ),CHTAXP=$ P(REC4,U,2 ),CHVNPG=$ P(REC4,U,3 ),CHCMAC=$ P(REC4,U,4 ),CHMCCR=$ P(REC4,U,5 ),CHOHI=$P (REC4,U,6) ,CHVAD1=$P (REC4,U,7) ,CHVAD2=$P (REC4,U,8) ,CHVCTY=$P (REC4,U,9) ,CHVST=$P( REC4,U,10)
  7541   "RTN","CHG ASP",39,0)
  7542    S CHVZIP= $P(REC4,U, 11),CHPLVE N=$P(REC4, U,12),CHTO PRB=$P(REC 4,U,13)    ; JEH 9/5/ 06
  7543   "RTN","CHG ASP",40,0)
  7544    S CHMED=$ P(REC5,U,1 ),CHMAD1=$ P(REC5,U,2 ),CHMAD2=$ P(REC5,U,3 ),CHMCTY=$ P(REC5,U,4 ),CHMST=$P (REC5,U,5) ,CHMZIP=$P (REC5,U,6) ,CHDRG=$P( REC5,U,7), CHMETH=$P( REC5,U,8), CHMTAXP=$P (REC5,U,9) ,CHMEDPD=$ P(REC5,U,1 0)
  7545   "RTN","CHG ASP",41,0)
  7546    S CHOHT=$ P(REC6,U,1 ),CHOHB=$P (REC6,U,2) ,CHOHE=$P( REC6,U,3), CHRTAD1=$P (REC6,U,4) ,CHRTAD2=$ P(REC6,U,5 ),CHRTVCTY =$P(REC6,U ,6),CHRTVS T=$P(REC6, U,7),CHRTV ZIP=$P(REC 6,U,8)
  7547   "RTN","CHG ASP",42,0)
  7548    S:CHCMAC= "" CHCMAC= 3
  7549   "RTN","CHG ASP",43,0)
  7550    S CHVEN=$ E(CHVEN,1, 25)
  7551   "RTN","CHG ASP",44,0)
  7552    ;
  7553   "RTN","CHG ASP",45,0)
  7554   PRINT W !! ,"PDI:  ", CHPDI,"-", CHPDITY,?2 8,"Claim # : ",CHCLM, ?53,"Bene:  ",CHBENE
  7555   "RTN","CHG ASP",46,0)
  7556    W !,"Batc h #:  ",CH BATCH,?28, "TOS:  ",C HTOS,?53," Spon: ",CH SPON
  7557   "RTN","CHG ASP",47,0)
  7558    W !,"Doc  Id#:  ",CH DOC,?28,"S tatus:  ", CHSTS,?55, "VE: ",CHV E
  7559   "RTN","CHG ASP",48,0)
  7560    W !,"Prog ram:  ",CH PROG
  7561   "RTN","CHG ASP",49,0)
  7562    W !!,"Dat e in ASQ:  ",$$FMTE^X LFDT(CHDT, "2D"),?28, "Rsn in AS Q: ",CHRSN ,?53,"Mail man #: ",C HMM
  7563   "RTN","CHG ASP",50,0)
  7564    W !,"DOS:  ",$$FMTE^ XLFDT(CHDO S,"2D"),?2 8,"POS:  " ,CHPOS,?53 ,"EDI Clai m: ",CHEDI
  7565   "RTN","CHG ASP",51,0)
  7566    W !,"MCCR  Review: " ,CHMCCR,?2 8,"Type of  Bill: ",C HTOB,?53," PCN: ",$E( CHPCN,1,20 )
  7567   "RTN","CHG ASP",52,0)
  7568    D OHI
  7569   "RTN","CHG ASP",53,0)
  7570    W !,"OHI  Type: ",$E (CHOHTP,1, 15),?28,"O HI Begin:  ",$$FMTE^X LFDT(CHOHB P,"2D"),?5 3,"OHI End : ",$$FMTE ^XLFDT(CHO HEP,"2D")
  7571   "RTN","CHG ASP",54,0)
  7572    I CHOHI'= "" W !,"OH I Paymt:   ","$ ",$J( $FN(CHOHI, ",",2),9)
  7573   "RTN","CHG ASP",55,0)
  7574    E  W !,"O HI Paymt:   ",CHOHI
  7575   "RTN","CHG ASP",56,0)
  7576    I CHTOPRB '="" D   ;  JEH 9/5/0 6 ADDED PA TIENT RESP  LOGIC
  7577   "RTN","CHG ASP",57,0)
  7578    .W !,"OHI  PR BAL: " ,"$ ",$J($ FN(CHTOPRB ,",",2),9)  ;DGC 8/10 /2011 DEV0 07820
  7579   "RTN","CHG ASP",58,0)
  7580    E  I CHOH I'="" D
  7581   "RTN","CHG ASP",59,0)
  7582    .S CHTOPR B=CHAMT-CH OHI
  7583   "RTN","CHG ASP",60,0)
  7584    .W !,"OHI  PR BAL: " ,"$ ",$J($ FN(CHTOPRB ,",",2),9)  ;DGC 8/10 /2011 DEV0 07820
  7585   "RTN","CHG ASP",61,0)
  7586    I CHBAMT' ="" W ?28, "Bene Paym t:  ","$ " ,$J($FN(CH BAMT,",",2 ),9)
  7587   "RTN","CHG ASP",62,0)
  7588    E  W ?28, "Bene Paym t: ",CHBAM T
  7589   "RTN","CHG ASP",63,0)
  7590    I CHSTPLT '="" W ?53 ,"TPL Paym t: ","$ ", $J($FN(CHS TPLT,",",2 ),10)  ;DG C 03/15/11  DEV007820
  7591   "RTN","CHG ASP",64,0)
  7592    E  W ?53, "TPL Paymt : "                         ;DGC  03/15/11  DEV007820
  7593   "RTN","CHG ASP",65,0)
  7594    I CHSPOP' ="" W !,?8 ,"POP: ",C HSPOP            ;DGC  10/25/201 1 MTN01316 3
  7595   "RTN","CHG ASP",66,0)
  7596    ;
  7597   "RTN","CHG ASP",67,0)
  7598    ;  Extrac t PL ZIP f rom Claim  file and d isplay.  w tc 6/19/17
  7599   "RTN","CHG ASP",68,0)
  7600    ;
  7601   "RTN","CHG ASP",69,0)
  7602    S CHCLMNU M=$O(^CHMP AY("B",CHC LM,0)) ;
  7603   "RTN","CHG ASP",70,0)
  7604    ;DEFECT 8 77425 - TG H- 12/6/18  - Print P L ZIP only  if TOS is  Inpatient , Outpatie nt, or Den tal
  7605   "RTN","CHG ASP",71,0)
  7606    ;I CHCLMN UM'="" S P LZIP=$P($G (^CHMPAY(C HCLMNUM,"V EN-II"))," ^",15) W ! ?53,"PL ZI P: ",PLZIP  ; WTC 5/1 9/17
  7607   "RTN","CHG ASP",72,0)
  7608    I CHCLMNU M'="" I (C HTOS["INPA TIENT"!(CH TOS["OUTPA TIENT")!(C HTOS["DENT AL")) D
  7609   "RTN","CHG ASP",73,0)
  7610    . S PLZIP =$P($G(^CH MPAY(CHCLM NUM,"VEN-I I")),"^",1 5) W !?53, "PL ZIP: " ,PLZIP ; W TC 5/19/17
  7611   "RTN","CHG ASP",74,0)
  7612    D COLHEAD
  7613   "RTN","CHG ASP",75,0)
  7614    D DIAG^CH GASPU
  7615   "RTN","CHG ASP",76,0)
  7616    D PROC^CH GASPU
  7617   "RTN","CHG ASP",77,0)
  7618    D DMESUP^ CHGASPU
  7619   "RTN","CHG ASP",78,0)
  7620    D DME^CHG ASPU
  7621   "RTN","CHG ASP",79,0)
  7622    D PHARM^C HGASPU
  7623   "RTN","CHG ASP",80,0)
  7624    ;W !,?56, "--------- --",?68,"- ---------- "  DGC 03/ 15/11 DEV0 07820 BEGI N
  7625   "RTN","CHG ASP",81,0)
  7626    S DC1="-"  W "Totals " F DC2=8: 1:80 W ?DC 2,DC1
  7627   "RTN","CHG ASP",82,0)
  7628    I CHAMT'= "" W !,?47 ,$J($FN(CH AMT,",",2) ,10)
  7629   "RTN","CHG ASP",83,0)
  7630    E  W !
  7631   "RTN","CHG ASP",84,0)
  7632    I CHTOPD' =0 W ?59,$ J($FN(CHTO PD,",",2), 10)
  7633   "RTN","CHG ASP",85,0)
  7634    I CHTOPR' =0 W ?70,$ J($FN(CHTO PR,",",2), 10) ;DGC 1 0/24/2011  MTN013163
  7635   "RTN","CHG ASP",86,0)
  7636    I CHTMEDP '=0 W !,$J ($FN(CHTME DP,",",2), 10)
  7637   "RTN","CHG ASP",87,0)
  7638    E  W !
  7639   "RTN","CHG ASP",88,0)
  7640    I CHALW'= "" W ?47,$ J($FN(CHAL W,",",2),1 0)
  7641   "RTN","CHG ASP",89,0)
  7642    ;E  S CHA LW="Und" W  ?47,$J(CH ALW,10)
  7643   "RTN","CHG ASP",90,0)
  7644    I CHTOHI' =0 W ?59,$ J($FN(CHTO HI,",",2), 10)
  7645   "RTN","CHG ASP",91,0)
  7646    I CHTOPB' =0 W ?70,$ J($FN(CHTO PB,",",2), 10) ;DGC 1 0/24/2011  MTN013163
  7647   "RTN","CHG ASP",92,0)
  7648    ;DGC 03/1 5/11 DEV00 7820 END
  7649   "RTN","CHG ASP",93,0)
  7650    D REOPEN^ CHGASPU
  7651   "RTN","CHG ASP",94,0)
  7652    W !!,"Ben eficiary D ata:"
  7653   "RTN","CHG ASP",95,0)
  7654    W !,"DOB:  ",$$FMTE^ XLFDT(CHDO B,"2D"),?1 8,"Age: ", CHAGE,?30, "Sex: ",CH SEX,?50,"S SN: ",CHSS N
  7655   "RTN","CHG ASP",96,0)
  7656    W !,"Addr 1: ",CHBAD 1,?50,"Rel ationship:  ",CHREL
  7657   "RTN","CHG ASP",97,0)
  7658    W !,"Addr 2: ",CHBAD 2
  7659   "RTN","CHG ASP",98,0)
  7660    W !,"City : ",CHBCTY ,?28,"Stat e: ",CHBST ,?50,"Zip:  ",CHBZIP
  7661   "RTN","CHG ASP",99,0)
  7662    D WATCHK^ CHGASCOM
  7663   "RTN","CHG ASP",100,0 )
  7664    W:LNFEED= 1 ! W:LNFE ED=2 !!
  7665   "RTN","CHG ASP",101,0 )
  7666    W "Tax ID : ",CHTAXP ,?28,"PI:  ",CHAOB,?4 0,"Vendor  Page: ",CH VNPG,?59," CMAC: ",CH CMAC
  7667   "RTN","CHG ASP",102,0 )
  7668    W !,"RT V endor: ",C HVEN,?42," PL Vendor:  ",CHPLVEN
  7669   "RTN","CHG ASP",103,0 )
  7670    W !,"Addr 1: ",CHRTA D1,?42,"Ad dr1: ",CHV AD1
  7671   "RTN","CHG ASP",104,0 )
  7672    W !,"Addr 2: ",CHRTA D2,?42,"Ad dr2: ",CHV AD2
  7673   "RTN","CHG ASP",105,0 )
  7674    W !,"City :  ",CHRTV CTY,?42,"C ity:  ",CH VCTY
  7675   "RTN","CHG ASP",106,0 )
  7676    W !,"Stat e: ",CHRTV ST,?13,"Zi p: ",CHRTV ZIP,?42,"S tate: ",CH VST,?55,"Z ip: ",CHVZ IP
  7677   "RTN","CHG ASP",107,0 )
  7678    I CHMED'= "" D MED^C HGASPU
  7679   "RTN","CHG ASP",108,0 )
  7680    D ^CHGASQ P
  7681   "RTN","CHG ASP",109,0 )
  7682    D ^CHGASH SP
  7683   "RTN","CHG ASP",110,0 )
  7684    ;CHECK FO R CLAIM AN D PDI COMM ENTS
  7685   "RTN","CHG ASP",111,0 )
  7686    I $D(^CHM CLCOM("B", CHCLM)) D  CLAIM^CHGA SCOM
  7687   "RTN","CHG ASP",112,0 )
  7688    I $D(^CHM CLCOM("B", CHPDI)) D  PDI^CHGASC OM
  7689   "RTN","CHG ASP",113,0 )
  7690    ;CHECK FO R BENE COM MENTS
  7691   "RTN","CHG ASP",114,0 )
  7692    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D
  7693   "RTN","CHG ASP",115,0 )
  7694    .D BENE^C HGASCOM
  7695   "RTN","CHG ASP",116,0 )
  7696    .S CHDFN= DFN,CHBFN= BFN
  7697   "RTN","CHG ASP",117,0 )
  7698    .D BENCOM ^CHGASCOM
  7699   "RTN","CHG ASP",118,0 )
  7700    .D:$D(BEN COM("BEN") )
  7701   "RTN","CHG ASP",119,0 )
  7702    ..S I1=0  F  S I1=$O (BENCOM("B EN",CHDFN, CHBFN,I1))  Q:'I1  W  !!,"Date:  ",$P(BENCO M("BEN",CH DFN,CHBFN, I1),"^",2) ,?46,"User : ",$P(BEN COM("BEN", CHDFN,CHBF N,I1),"^", 1) S I2=0  D
  7703   "RTN","CHG ASP",120,0 )
  7704    ...F  S I 2=$O(BENCO M("BEN",CH DFN,CHBFN, I1,I2)) Q: 'I2  W !,"      ",BEN COM("BEN", CHDFN,CHBF N,I1,I2)
  7705   "RTN","CHG ASP",121,0 )
  7706    ;CHECK FO R BENE WAT CH COMMENT S
  7707   "RTN","CHG ASP",122,0 )
  7708    D BWATCH^ CHGAS17
  7709   "RTN","CHG ASP",123,0 )
  7710    I $D(CHMW AT) D
  7711   "RTN","CHG ASP",124,0 )
  7712    .D BENWAT ^CHGASCOM
  7713   "RTN","CHG ASP",125,0 )
  7714    .S CHDFN= DFN,CHBFN= BFN
  7715   "RTN","CHG ASP",126,0 )
  7716    .D BNWATC M^CHGASCOM
  7717   "RTN","CHG ASP",127,0 )
  7718    I $D(BI)  I BI'="" I  $D(WATCOM ("BENWAT", BI)) D
  7719   "RTN","CHG ASP",128,0 )
  7720    .S BJ=$P( CHMWAT("BE NWAT"),U,2 )
  7721   "RTN","CHG ASP",129,0 )
  7722    .S BK=0 F   S BK=$O( WATCOM("BE NWAT",BI,B J,BK)) Q:' BK  S REC2 =WATCOM("B ENWAT",BI, BJ,BK) W ! !,"Watch B egin: ",$P (REC2,U,1) ,?46,"User : ",$P(REC 2,U,2),!," Watch End:  ",$P(REC2 ,U,3),?46, "User: ",$ P(REC2,U,4 ) S BL=0 D
  7723   "RTN","CHG ASP",130,0 )
  7724    ..F  S BL =$O(WATCOM ("BENWAT", BI,BJ,BK,B L)) Q:'BL   W !,"      ",WATCOM( "BENWAT",B I,BJ,BK,BL )
  7725   "RTN","CHG ASP",131,0 )
  7726    S CHVPT=" "
  7727   "RTN","CHG ASP",132,0 )
  7728    I CHVEN'= "" I $D(^C HMVEN("B", CHVEN)) D
  7729   "RTN","CHG ASP",133,0 )
  7730    .S CHVPT= 0
  7731   "RTN","CHG ASP",134,0 )
  7732    .S CHVPT= $O(^CHMVEN ("B",CHVEN ,CHVPT))
  7733   "RTN","CHG ASP",135,0 )
  7734    .Q
  7735   "RTN","CHG ASP",136,0 )
  7736    ;CHECK TO  SEE IF VE NDOR IS ON  WATCH
  7737   "RTN","CHG ASP",137,0 )
  7738    I CHVPT'= "" I $D(^C HMVEN(CHVP T,20)) D
  7739   "RTN","CHG ASP",138,0 )
  7740    .D VEND^C HGASCOM
  7741   "RTN","CHG ASP",139,0 )
  7742    .D VENCOM ^CHGASCOM
  7743   "RTN","CHG ASP",140,0 )
  7744    I CHVPT'= "" I $D(VE NCOM("VEND ",CHVPT))  D
  7745   "RTN","CHG ASP",141,0 )
  7746    .S VJ=0 F   S VJ=$O( VENCOM("VE ND",CHVPT, VJ)) Q:'VJ   S REC2=V ENCOM("VEN D",CHVPT,V J) W !!,"W atch Begin : ",$P(REC 2,U,1),?46 ,"User: ", $P(REC2,U, 2),!,"Watc h End: ",$ P(REC2,U,3 ),?46,"Use r: ",$P(RE C2,U,4) S  VK=0 D
  7747   "RTN","CHG ASP",142,0 )
  7748    ..F  S VK =$O(VENCOM ("VEND",CH VPT,VJ,VK) ) Q:'VK  W  !,"     " ,VENCOM("V END",CHVPT ,VJ,VK)
  7749   "RTN","CHG ASP",143,0 )
  7750    D OHI^CHG ASPU
  7751   "RTN","CHG ASP",144,0 )
  7752    D PART2^C HGASGOP
  7753   "RTN","CHG ASP",145,0 )
  7754    G A3
  7755   "RTN","CHG ASP",146,0 )
  7756    ;
  7757   "RTN","CHG ASP",147,0 )
  7758   NODATA W ! !!,"THERE  ARE NO ACT IVE CLAIMS  IN THE AU DIT SUPPOR T QUEUE FO R ",CHDZ," ."
  7759   "RTN","CHG ASP",148,0 )
  7760    I CHREAS' ="" W !!!, "THERE ARE  NO ACTIVE  ",CHREASN ," IN THE  AUDIT SUPP ORT QUEUE. "
  7761   "RTN","CHG ASP",149,0 )
  7762   END K CHAC C,CHALL,CH ALW,CHAMT, CHAOB,CHAR GE,CHBAD1, CHBAD2,CHB AMT,CHBAT, CHBCTY
  7763   "RTN","CHG ASP",150,0 )
  7764    K CHBATCH ,CHBENE,CH BST,CHBZIP ,CHCHG,CHC LN,CHCMAC, CHCNT,CHDA D1,CHDAD2
  7765   "RTN","CHG ASP",151,0 )
  7766    K CHDC,CH DCTY,CHDES ,CHDIAG,CH DOB,CHDOC, CHDOS,CHDR G,CHDRUG,C HDSBEN,CHD X
  7767   "RTN","CHG ASP",152,0 )
  7768    K CHDSDOB ,CHDSREL,C HDSSN,CHDS T,CHDT,CHD UZ,CHDZ,CH DZIP,CHEDI ,CHID,CHMO D
  7769   "RTN","CHG ASP",153,0 )
  7770    K CHMAD1, CHMAD2,CHM AMT,CHMCTY ,CHMED,CHM ETH,CHMMAC ,CHMST,CHM TAX,CHMZIP
  7771   "RTN","CHG ASP",154,0 )
  7772    K CHNAM,C HNDC,CHOHI ,CHOHIF,CH PDITY,CHPL ,CHPOS,CHP ROC,CHPSAD 1,CHPSAD2, CHTOPRB    ; JEH 9/5/ 06 ADDED C HTOPRB
  7773   "RTN","CHG ASP",155,0 )
  7774    K CHPSCTY ,CHPST,CHP STAX,CHPSV EN,CHPSZIP ,CHRC,CHRC 1,CHREAS,C HREASN,CHR EC
  7775   "RTN","CHG ASP",156,0 )
  7776    K CHREL,C HRSN,CHSPO N,CHSSN,CH STS,CHTAX, CHTOS,CHTY PE,CHVAD1, CHVAD2
  7777   "RTN","CHG ASP",157,0 )
  7778    K CHVCTY, CHVE,CHVEN ,CHVNPG,CH VST,CHVZIP ,FLG,HREC, J,M,N,PG,R EC1
  7779   "RTN","CHG ASP",158,0 )
  7780    K REC2,RE C3,REC4,RE C5,REC6,RE C7,X,Y,ZZ  ;,^TMP($J, "WIP")
  7781   "RTN","CHG ASP",159,0 )
  7782    K CHCLMNU M,PLZIP ;  WTC 6/19/1 7
  7783   "RTN","CHG ASP",160,0 )
  7784    Q
  7785   "RTN","CHG ASP",161,0 )
  7786    ;
  7787   "RTN","CHG ASP",162,0 )
  7788   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  7789   "RTN","CHG ASP",163,0 )
  7790    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  7791   "RTN","CHG ASP",164,0 )
  7792    Q
  7793   "RTN","CHG ASP",165,0 )
  7794   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  7795   "RTN","CHG ASP",166,0 )
  7796   HEAD W #,D UZ,?33,"CH AMPVA CENT ER",?72,"P age:  ",PG  S PG=PG+1
  7797   "RTN","CHG ASP",167,0 )
  7798    I CHXREF= "O" W !,TI ME,?30,"Co ding Queue  WIP Repor t",!,$E(DT ,4,7),?80- $L(DATE)/2 ,DATE   ;  JEH 8/6/06
  7799   "RTN","CHG ASP",168,0 )
  7800    E  W !,TI ME,?25,"Au dit Suppor t Queue WI P Report", !,$E(DT,4, 7),?80-$L( DATE)/2,DA TE
  7801   "RTN","CHG ASP",169,0 )
  7802    Q
  7803   "RTN","CHG ASP",170,0 )
  7804   COLHEAD ;K KAEILL  ;D GC 6/05/11  MTN013163  Begin
  7805   "RTN","CHG ASP",171,0 )
  7806    I CHTY=4  D  Q
  7807   "RTN","CHG ASP",172,0 )
  7808    .W !!,"Co de",?18,"D escription ",?47,"Tot al Chg",?5 9,"OHI #1  PD",?70,"O HI #1 PR"
  7809   "RTN","CHG ASP",173,0 )
  7810    .W !,"Mca id",?18,"U nt/Qty",?2 7,"AlwUnt" ,?33,?47," Total AA", ?59,"Addl  OHI",?70," OHI PR Bal "
  7811   "RTN","CHG ASP",174,0 )
  7812    .W !,"--- ---------- ---------- ---------- ---------- ---",?47," ---------- ",?59,"--- -------",? 70,"------ ----"
  7813   "RTN","CHG ASP",175,0 )
  7814    .Q
  7815   "RTN","CHG ASP",176,0 )
  7816    I CHTY=3  D RXCOL Q
  7817   "RTN","CHG ASP",177,0 )
  7818    W !!,"Cod e",?18,"De scription" ,?47,"Tota l Chg",?59 ,"OHI #1 P D",?70,"OH I #1 PR"
  7819   "RTN","CHG ASP",178,0 )
  7820    W !,"Mcai d",?18,"Un t/Qty",?27 ,"AlwUnt", ?47,"Total  AA",?59," Addl OHI", ?70,"OHI P R Bal"
  7821   "RTN","CHG ASP",179,0 )
  7822    W !,"---- ---------- ---------- ---------- ---------- --",?47,"- ---------" ,?59,"---- ------",?7 0,"------- ---"
  7823   "RTN","CHG ASP",180,0 )
  7824    Q
  7825   "RTN","CHG ASP",181,0 )
  7826   RXCOL I CH PROG'="SPI NA BIFIDA"  D  Q
  7827   "RTN","CHG ASP",182,0 )
  7828    .W !!,"Co de",?18,"D escription ",?47,"Tot al Chg",?5 9,"OHI #1  PD",?70,"O HI #1 PR"
  7829   "RTN","CHG ASP",183,0 )
  7830    .W !,"Mca id",?18,"U nt/Qty",?2 7,"AlwUnt" ,?47,"Tota l AA",?59, "Addl OHI" ,?70,"OHI  PR Bal"
  7831   "RTN","CHG ASP",184,0 )
  7832    .W !,"--- ---------- ---------- ---------- ---------- ---",?47," ---------- ",?59,"--- -------",? 70,"------ ----"
  7833   "RTN","CHG ASP",185,0 )
  7834    I CHPROG= "SPINA BIF IDA" D  Q
  7835   "RTN","CHG ASP",186,0 )
  7836    .W !!,"Co de",?18,"D escription ",?39,"DX  Code",?47, "Total Chg ",?59,"OHI  #1 PD",?7 0,"OHI #1  PR"
  7837   "RTN","CHG ASP",187,0 )
  7838    .W !,"Mca id",?18,"U nt/Qty",?2 7,"AlwUnt" ,?47,"Tota l AA",?59, "Addl OHI" ,?70,"OHI  PR Bal"
  7839   "RTN","CHG ASP",188,0 )
  7840    .W !,"--- ---------- ---------- ---------- ------",?3 6,"------- ",?47,"--- -------",? 59,"------ ----",?70, "--------- -"
  7841   "RTN","CHG ASP",189,0 )
  7842    Q
  7843   "RTN","CHG ASP",190,0 )
  7844    ;DGC 6/05 /11 MTN013 163 End
  7845   "RTN","CHG ASP",191,0 )
  7846   OHI S I1=0
  7847   "RTN","CHG ASP",192,0 )
  7848    S (CHOHBP ,CHOHEP,CH OH,CHOHTP) =""
  7849   "RTN","CHG ASP",193,0 )
  7850   O1 S I1=$O (@(GLDFN_" ""B"",DFN, I1)")) Q:' I1
  7851   "RTN","CHG ASP",194,0 )
  7852    G:'$D(@(G LDFN_"I1,1 00)")) O1
  7853   "RTN","CHG ASP",195,0 )
  7854    S J1=0
  7855   "RTN","CHG ASP",196,0 )
  7856   O2 S J1=$O (@(GLDFN_" I1,100,""B "",BFN,J1) ")) G:'J1  O1
  7857   "RTN","CHG ASP",197,0 )
  7858    G:'$D(@(G LDFN_"I1,1 00,J1,2)") ) O2
  7859   "RTN","CHG ASP",198,0 )
  7860    S K1=XDOS
  7861   "RTN","CHG ASP",199,0 )
  7862   O3 S K1=$O (@(GLDFN_" I1,100,J1, 2,""B"",K1 )"),-1) G: 'K1 O2
  7863   "RTN","CHG ASP",200,0 )
  7864    S K2=0
  7865   "RTN","CHG ASP",201,0 )
  7866   O4 S K2=$O (@(GLDFN_" I1,100,J1, 2,""B"",K1 ,K2)")) G: 'K2 O3
  7867   "RTN","CHG ASP",202,0 )
  7868    G:'$D(@(G LDFN_"I1,1 00,J1,2,K2 ,0)")) O4
  7869   "RTN","CHG ASP",203,0 )
  7870    S RC=@(GL DFN_"I1,10 0,J1,2,K2, 0)")
  7871   "RTN","CHG ASP",204,0 )
  7872    S CHOHBP= $P(RC,U,1) ,CHOHEP=$P (RC,U,2),C HOH=$P(RC, U,3)
  7873   "RTN","CHG ASP",205,0 )
  7874    S CHOHTP= "NO OHI"
  7875   "RTN","CHG ASP",206,0 )
  7876    I CHOH I  $D(^CHMDIC (741002.76 ,CHOH,0))  S CHOHTP=$ P(^(0),"^" ,1)
  7877   "RTN","CHG ASP",207,0 )
  7878    ;S CHOHT= $S(CHOH=1: "NO OHI",C HOH=2:"OHI  PRIMARY", CHOH=3:"MO RE THAN 1  OHI PRIMAR Y",CHOH=4: "MEDICARE  A ONLY",CH OH=5:"MEDI CARE B ONL Y",CHOH=6: "MEDICARE  A and B",C HOH=7:"INP  HOSP ONLY ",CHOH=8:" OHI ?",CHO H=9:"SUPPL EMENTAL",1 :"")
  7879   "RTN","CHG ASP",208,0 )
  7880    Q
  7881   "RTN","CHG ASP1")
  7882   0^11^B4051 7172
  7883   "RTN","CHG ASP1",1,0)
  7884   CHGASP1 ;C VA/RLC;ASQ  WIP REPOR T PRINT -  PART 1 ;Fe b 05, 2019 @10:32:56
  7885   "RTN","CHG ASP1",2,0)
  7886    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  7887   "RTN","CHG ASP1",3,0)
  7888    ;;V1.0;;
  7889   "RTN","CHG ASP1",4,0)
  7890    ;PRINTS M AIN BODY O F WIP REPO RT FOR ALL  CLAIMS EX CEPT IN-PA TIENT.
  7891   "RTN","CHG ASP1",5,0)
  7892    ;CALLS RO UTINE ^CHG ASP2 TO PR INT IN-PAT IENT CLAIM S.
  7893   "RTN","CHG ASP1",6,0)
  7894    ;MC284 JE H 9/5/06 C hange OHI  Paid amoun t to Patie nt Respons ibility
  7895   "RTN","CHG ASP1",7,0)
  7896    ;CPE001-0 08 6/19/20 17 WTC CCS E
  7897   "RTN","CHG ASP1",8,0)
  7898    ;DEFECT 8 77425 - TG H- 12/6/18  - Print P L ZIP only  if TOS is  Inpatient , Outpatie nt, or Den tal
  7899   "RTN","CHG ASP1",9,0)
  7900    S X=DT D  DTPRT S DA TE=Y,PG=1, X=$P($H,", ",2),H=X\3 600,M=X#36 00\60
  7901   "RTN","CHG ASP1",10,0 )
  7902    S:M<10 M= 0_M S:H<10  H=0_M S T IME=H_M
  7903   "RTN","CHG ASP1",11,0 )
  7904    ;
  7905   "RTN","CHG ASP1",12,0 )
  7906    I CHCNT=0  D HEAD,NO DATA G END
  7907   "RTN","CHG ASP1",13,0 )
  7908    S CHPDI=" ",U="^"
  7909   "RTN","CHG ASP1",14,0 )
  7910   A1 S CHPDI =$O(^TMP($ J,"WIP",CH PDI)) G:CH PDI="" END
  7911   "RTN","CHG ASP1",15,0 )
  7912    S CHCLM=" "
  7913   "RTN","CHG ASP1",16,0 )
  7914   A2 S CHCLM =$O(^TMP($ J,"WIP",CH PDI,CHCLM) ) G:CHCLM= "" A1
  7915   "RTN","CHG ASP1",17,0 )
  7916    I CHTY=1  D ^CHGASP2  G A2
  7917   "RTN","CHG ASP1",18,0 )
  7918    S REC1=^( CHCLM,1) D  HEAD
  7919   "RTN","CHG ASP1",19,0 )
  7920    S U="^"
  7921   "RTN","CHG ASP1",20,0 )
  7922    S REC2=^T MP($J,"WIP ",CHPDI,CH CLM,2),REC 3=^TMP($J, "WIP",CHPD I,CHCLM,3) ,REC4=^TMP ($J,"WIP", CHPDI,CHCL M,4),REC5= ^TMP($J,"W IP",CHPDI, CHCLM,5),R EC6=^TMP($ J,"WIP",CH PDI,CHCLM, 6)
  7923   "RTN","CHG ASP1",21,0 )
  7924    S CHBENE= $P(REC1,U, 1),CHSPON= $P(REC1,U, 2),CHDOB=$ P(REC1,U,3 ),CHREL=$P (REC1,U,4) ,CHSSN=$P( REC1,U,5), CHDOS=$P(R EC1,U,6),C HAOB=$P(RE C1,U,7),CH ACC=$P(REC 1,U,8),CHB AMT=$P(REC 1,U,9)
  7925   "RTN","CHG ASP1",22,0 )
  7926    S CHID=$P (REC2,U,1) ,CHBAD1=$P (REC2,U,2) ,CHBAD2=$P (REC2,U,3) ,CHBCTY=$P (REC2,U,4) ,CHBST=$P( REC2,U,5), CHBZIP=$P( REC2,U,6)
  7927   "RTN","CHG ASP1",23,0 )
  7928    S CHVE=$P (REC3,U,1) ,CHPDITY=$ P(REC3,U,2 ),CHBATCH= $P(REC3,U, 3),CHDOC=$ P(REC3,U,4 ),CHDT=$P( REC3,U,5), CHSTS=$P(R EC3,U,6),C HRSN=$P(RE C3,U,7),CH TOS=$P(REC 3,U,8),CHP OS=$P(REC3 ,U,9),CHAM T=$P(REC3, U,10),CHED I=$P(REC3, U,11),CHAL W=$P(REC3, U,12)
  7929   "RTN","CHG ASP1",24,0 )
  7930    S CHVEN=$ P(REC4,U,1 ),CHTAX=$P (REC4,U,2) ,CHVNPG=$P (REC4,U,3) ,CHCMAC=$P (REC4,U,4) ,CHMCCR=$P (REC4,U,5) ,CHOHI=$P( REC4,U,6), CHVAD1=$P( REC4,U,7), CHVAD2=$P( REC4,U,8), CHVCTY=$P( REC4,U,9), CHVST=$P(R EC4,U,10), CHVZIP=$P( REC4,U,11)
  7931   "RTN","CHG ASP1",25,0 )
  7932    ;CJM LINE  LENGTH FO R MIGRATIO N R1 20170 719
  7933   "RTN","CHG ASP1",26,0 )
  7934    S CHVEN=$ P(REC4,U,1 ),CHTAX=$P (REC4,U,2) ,CHVNPG=$P (REC4,U,3) ,CHCMAC=$P (REC4,U,4) ,CHMCCR=$P (REC4,U,5) ,CHOHI=$P( REC4,U,6), CHVAD1=$P( REC4,U,7), CHVAD2=$P( REC4,U,8), CHVCTY=$P( REC4,U,9)
  7935   "RTN","CHG ASP1",27,0 )
  7936    S CHVST=$ P(REC4,U,1 0),CHVZIP= $P(REC4,U, 11),CHOHIP R=$P(REC4, U,13)   ;  JEH 9/5/06
  7937   "RTN","CHG ASP1",28,0 )
  7938    S CHMED=$ P(REC5,U,1 ),CHMAD1=$ P(REC5,U,2 ),CHMAD2=$ P(REC5,U,3 ),CHMCTY=$ P(REC5,U,4 ),CHMST=$P (REC5,U,5) ,CHMZIP=$P (REC5,U,6) ,CHDRG=$P( REC5,U,7), CHMETH=$P( REC5,U,8), CHMTAX=$P( REC5,U,9)
  7939   "RTN","CHG ASP1",29,0 )
  7940    S CHOHT=$ P(REC6,U,1 ),CHOHB=$P (REC6,U,2) ,CHOHE=$P( REC6,U,3)
  7941   "RTN","CHG ASP1",30,0 )
  7942    S:CHCMAC= "" CHCMAC= 3
  7943   "RTN","CHG ASP1",31,0 )
  7944    S CHVEN=$ E(CHVEN,1, 25)
  7945   "RTN","CHG ASP1",32,0 )
  7946    ;
  7947   "RTN","CHG ASP1",33,0 )
  7948   PRINT W !! ,"PDI:  ", CHPDI,"-", CHPDITY,?2 8,"Claim # : ",CHCLM, ?53,"Bene:  ",CHBENE
  7949   "RTN","CHG ASP1",34,0 )
  7950    W !,"Batc h #:  ",CH BATCH,?28, "TOS:  ",C HTOS,?53," Spon: ",CH SPON
  7951   "RTN","CHG ASP1",35,0 )
  7952    W !,"Doc  Id#:  ",CH DOC,?28,"S tatus:  ", CHSTS,?55, "VE: ",CHV E
  7953   "RTN","CHG ASP1",36,0 )
  7954    W !!,"Dat e in ASQ:  ",$$FMTE^X LFDT(CHDT, "2D"),?28, "Rsn in AS Q: ",CHRSN ,?53,"Mail man #: ",C HMM
  7955   "RTN","CHG ASP1",37,0 )
  7956    W !,"DOS:  ",$$FMTE^ XLFDT(CHDO S,"2D"),?2 8,"POS:  " ,CHPOS,?53 ,"EDI Clai m: ",CHEDI
  7957   "RTN","CHG ASP1",38,0 )
  7958    W !,"Inj/ Acc: ",CHA CC,?28,"MC CR Review:  ",CHMCCR
  7959   "RTN","CHG ASP1",39,0 )
  7960    W !,"OHI  Type: ",$E (CHOHT,1,1 5),?28,"OH I Begin: " ,$$FMTE^XL FDT(CHOHB, "2D"),?53, "OHI End:  ",$$FMTE^X LFDT(CHOHE ,"2D")
  7961   "RTN","CHG ASP1",40,0 )
  7962    I CHOHI'= "" W !,"OH I Paymt:   ","$ ",$J( $FN(CHOHI, ",",2),9)
  7963   "RTN","CHG ASP1",41,0 )
  7964    E  W !,"O HI Paymt:   ",CHOHI
  7965   "RTN","CHG ASP1",42,0 )
  7966    I CHOHIPR '="" D   ;  JEH 9/5/0 6 ADDED PA TIENT RESP  LOGIC
  7967   "RTN","CHG ASP1",43,0 )
  7968    .W !,"OHI  PR Bal: " ,"$ ",$J($ FN(CHOHIPR ,",",2),9)  ; MTN0131 63F  EW  B UG ASQ20 2 /17/13
  7969   "RTN","CHG ASP1",44,0 )
  7970    E  D
  7971   "RTN","CHG ASP1",45,0 )
  7972    .S CHOHIP R=CHAMT-CH OHI
  7973   "RTN","CHG ASP1",46,0 )
  7974    .W !,"OHI  PR Bal: " ,"$ ",$J($ FN(CHOHIPR ,",",2),9)  ; MTN0131 63F  EW  B UG ASQ20 2 /17/13
  7975   "RTN","CHG ASP1",47,0 )
  7976    I CHBAMT' ="" W ?28, "Bene Paym t:  ","$ " ,$J($FN(CH BAMT,",",2 ),9)
  7977   "RTN","CHG ASP1",48,0 )
  7978    E  W ?28, "Bene Paym t: ",CHBAM T
  7979   "RTN","CHG ASP1",49,0 )
  7980    ;
  7981   "RTN","CHG ASP1",50,0 )
  7982    ;  Extrac t PL ZIP f rom Claim  file and d isplay.  w tc 6/19/17
  7983   "RTN","CHG ASP1",51,0 )
  7984    ;
  7985   "RTN","CHG ASP1",52,0 )
  7986    S CHCLMNU M=$O(^CHMP AY("B",CHC LM,0)) ;
  7987   "RTN","CHG ASP1",53,0 )
  7988    ;DEFECT 8 77425 - TG H- 12/6/18  - Print P L ZIP only  if TOS is  Inpatient , Outpatie nt, or Den tal
  7989   "RTN","CHG ASP1",54,0 )
  7990    ;I CHCLMN UM'="" S P LZIP=$P($G (^CHMPAY(C HCLMNUM,"V EN-II"))," ^",15) W ! ?53,"PL ZI P: ",PLZIP  ; WTC 5/1 9/17
  7991   "RTN","CHG ASP1",55,0 )
  7992    I CHCLMNU M'="" I (C HTOS["INPA TIENT"!(CH TOS["OUTPA TIENT")!(C HTOS["DENT AL")) D
  7993   "RTN","CHG ASP1",56,0 )
  7994    . S PLZIP =$P($G(^CH MPAY(CHCLM NUM,"VEN-I I")),"^",1 5) W !?53, "PL ZIP: " ,PLZIP ; W TC 5/19/17
  7995   "RTN","CHG ASP1",57,0 )
  7996    D COLHEAD
  7997   "RTN","CHG ASP1",58,0 )
  7998    D DIAG^CH GASP3,PROC ^CHGASP3
  7999   "RTN","CHG ASP1",59,0 )
  8000    D DMESUP, DME,PHARM
  8001   "RTN","CHG ASP1",60,0 )
  8002    W !,?54," ---------- -",?68,"-- ---------"
  8003   "RTN","CHG ASP1",61,0 )
  8004    W !,?44," Totals"
  8005   "RTN","CHG ASP1",62,0 )
  8006    I CHAMT'= "" W ?54,$ J($FN(CHAM T,",",2),1 1)
  8007   "RTN","CHG ASP1",63,0 )
  8008    I CHALW'= "" W ?68,$ J($FN(CHAL W,",",2),1 1)
  8009   "RTN","CHG ASP1",64,0 )
  8010    E  S CHAL W="Und" W  ?68,$J(CHA LW,11)
  8011   "RTN","CHG ASP1",65,0 )
  8012    D ^CHGASP 3
  8013   "RTN","CHG ASP1",66,0 )
  8014    ;
  8015   "RTN","CHG ASP1",67,0 )
  8016   END K CHAC C,CHALL,CH ALW,CHAMT, CHAOB,CHAR GE,CHBAD1, CHBAD2,CHB AMT,CHBAT, CHBCTY
  8017   "RTN","CHG ASP1",68,0 )
  8018    K CHBATCH ,CHBENE,CH BST,CHBZIP ,CHCHG,CHC LN,CHCMAC, CHCNT,CHDA D1,CHDAD2
  8019   "RTN","CHG ASP1",69,0 )
  8020    K CHDC,CH DCTY,CHDES ,CHDIAG,CH DOB,CHDOC, CHDOS,CHDR G,CHDRUG,C HDSBEN,CHD X
  8021   "RTN","CHG ASP1",70,0 )
  8022    K CHDSDOB ,CHDSREL,C HDSSN,CHDS T,CHDT,CHD UZ,CHDZ,CH DZIP,CHEDI ,CHID,CHMO D
  8023   "RTN","CHG ASP1",71,0 )
  8024    K CHMAD1, CHMAD2,CHM AMT,CHMCTY ,CHMED,CHM ETH,CHMMAC ,CHMST,CHM TAX,CHMZIP
  8025   "RTN","CHG ASP1",72,0 )
  8026    K CHNAM,C HNDC,CHOHI ,CHOHIF,CH PDITY,CHPL ,CHPOS,CHP ROC,CHPSAD 1,CHPSAD2, CHOHIPR    ; JEH 9/5/ 06 ADD CHO HIPR
  8027   "RTN","CHG ASP1",73,0 )
  8028    K CHPSCTY ,CHPST,CHP STAX,CHPSV EN,CHPSZIP ,CHRC,CHRC 1,CHREAS,C HREASN,CHR EC
  8029   "RTN","CHG ASP1",74,0 )
  8030    K CHREL,C HRSN,CHSPO N,CHSSN,CH STS,CHTAX, CHTOS,CHTY PE,CHVAD1, CHVAD2
  8031   "RTN","CHG ASP1",75,0 )
  8032    K CHVCTY, CHVE,CHVEN ,CHVNPG,CH VST,CHVZIP ,FLG,HREC, J,M,N,PG,R EC1
  8033   "RTN","CHG ASP1",76,0 )
  8034    K REC2,RE C3,REC4,RE C5,REC6,RE C7,X,Y,ZZ, ^TMP($J,"W IP")
  8035   "RTN","CHG ASP1",77,0 )
  8036    K CHCLMNU M,PLZIP ;  WTC 6/19/1 7
  8037   "RTN","CHG ASP1",78,0 )
  8038    Q
  8039   "RTN","CHG ASP1",79,0 )
  8040    ;
  8041   "RTN","CHG ASP1",80,0 )
  8042   DMESUP S D ST=""
  8043   "RTN","CHG ASP1",81,0 )
  8044   DM1 S DST= $O(^TMP($J ,"WIP",CHP DI,CHCLM," DMESUP",DS T)) Q:'DST
  8045   "RTN","CHG ASP1",82,0 )
  8046    S DREC=^T MP($J,"WIP ",CHPDI,CH CLM,"DMESU P",DST)
  8047   "RTN","CHG ASP1",83,0 )
  8048    S CHSPCDE =$P(DREC,U ,1),CHSPDE S=$P(DREC, U,2),CHSPA MT=$P(DREC ,U,3),CHPL =$P(DREC,U ,4),CHSPAL L=$P(DREC, U,5)
  8049   "RTN","CHG ASP1",84,0 )
  8050    W !,CHSPC DE,?14,CHS PDES,?47,C HPL
  8051   "RTN","CHG ASP1",85,0 )
  8052    I CHSPAMT '="" W ?54 ,$J($FN(CH SPAMT,",", 2),11)
  8053   "RTN","CHG ASP1",86,0 )
  8054    I CHSPALL '="" W ?68 ,$J($FN(CH SPALL,",", 2),11)
  8055   "RTN","CHG ASP1",87,0 )
  8056    E  S CHSP ALL="Und"  W ?68,$J(C HSPALL,11)
  8057   "RTN","CHG ASP1",88,0 )
  8058    G DM1
  8059   "RTN","CHG ASP1",89,0 )
  8060    ;
  8061   "RTN","CHG ASP1",90,0 )
  8062   DME Q:'$D( ^TMP($J,"W IP",CHPDI, CHCLM,"DME "))
  8063   "RTN","CHG ASP1",91,0 )
  8064    S DLEC=^T MP($J,"WIP ",CHPDI,CH CLM,"DME")
  8065   "RTN","CHG ASP1",92,0 )
  8066    S CHSPCD= $P(DLEC,U, 1),CHSPDS= $P(DLEC,U, 2),CHSPCHG =$P(DLEC,U ,3),CHSPAL W=$P(DLEC, U,4)
  8067   "RTN","CHG ASP1",93,0 )
  8068    W !,CHSPC D,?14,CHSP DS
  8069   "RTN","CHG ASP1",94,0 )
  8070    I CHSPCHG '="" W ?54 ,$J($FN(CH SPCHG,",", 2),11)
  8071   "RTN","CHG ASP1",95,0 )
  8072    I CHSPALW '="" W ?68 ,$J($FN(CH SPALW,",", 2),11)
  8073   "RTN","CHG ASP1",96,0 )
  8074    E  S CHSP ALW="Und"  W ?68,$J(C HSPALW,11)
  8075   "RTN","CHG ASP1",97,0 )
  8076    Q
  8077   "RTN","CHG ASP1",98,0 )
  8078    ;
  8079   "RTN","CHG ASP1",99,0 )
  8080   PHARM S ZZ =""
  8081   "RTN","CHG ASP1",100, 0)
  8082   PH1 S ZZ=$ O(^TMP($J, "WIP",CHPD I,CHCLM,"R X",ZZ)) Q: ZZ=""
  8083   "RTN","CHG ASP1",101, 0)
  8084    S CHRC1=^ (ZZ)
  8085   "RTN","CHG ASP1",102, 0)
  8086    S CHNDC=$ P(CHRC1,U, 1),CHDRUG= $P(CHRC1,U ,2),CHARGE =$P(CHRC1, U,3),CHALL =$P(CHRC1, U,4)
  8087   "RTN","CHG ASP1",103, 0)
  8088    W !,CHNDC ,?14,CHDRU G
  8089   "RTN","CHG ASP1",104, 0)
  8090    I CHARGE' ="" W ?54, $J($FN(CHA RGE,",",2) ,11)
  8091   "RTN","CHG ASP1",105, 0)
  8092    I CHALL'= "" W ?68,$ J($FN(CHAL L,",",2),1 1)
  8093   "RTN","CHG ASP1",106, 0)
  8094    E  S CHAL L="Und" W  ?68,$J(CHA LL,11)
  8095   "RTN","CHG ASP1",107, 0)
  8096    G PH1
  8097   "RTN","CHG ASP1",108, 0)
  8098    ;
  8099   "RTN","CHG ASP1",109, 0)
  8100   PRT S N=0, LCT=1,TAB= 5
  8101   "RTN","CHG ASP1",110, 0)
  8102   PT1 S N=$O (PX(N)) I  N="" K PX, LABEL,PC,N ,TAB,LCT Q
  8103   "RTN","CHG ASP1",111, 0)
  8104    S LABEL(L CT)=$P(PX( N),U,1),PC (LCT)=$P(P X(N),U,2)
  8105   "RTN","CHG ASP1",112, 0)
  8106    G:(LABEL( LCT)="")!( PC(LCT)="" ) PT1
  8107   "RTN","CHG ASP1",113, 0)
  8108    W ?TAB,LA BEL,PC
  8109   "RTN","CHG ASP1",114, 0)
  8110    I LCT=3 I  $O(PX(N))  S TAB=5,L CT=1 W !
  8111   "RTN","CHG ASP1",115, 0)
  8112    E  S TAB= TAB+21,LCT =LCT+1
  8113   "RTN","CHG ASP1",116, 0)
  8114    G PT1
  8115   "RTN","CHG ASP1",117, 0)
  8116    ;
  8117   "RTN","CHG ASP1",118, 0)
  8118   NODATA I C HDUZ'="" W  !!!,"THER E ARE NO A CTIVE CLAI MS IN THE  AUDIT SUPP ORT QUEUE  FOR ",CHDZ ,"."
  8119   "RTN","CHG ASP1",119, 0)
  8120    I CHREAS' ="" W !!!, "THERE ARE  NO ACTIVE  ",CHREASN ," IN THE  AUDIT SUPP ORT QUEUE. "
  8121   "RTN","CHG ASP1",120, 0)
  8122    Q
  8123   "RTN","CHG ASP1",121, 0)
  8124    ;
  8125   "RTN","CHG ASP1",122, 0)
  8126   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  8127   "RTN","CHG ASP1",123, 0)
  8128    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  8129   "RTN","CHG ASP1",124, 0)
  8130    Q
  8131   "RTN","CHG ASP1",125, 0)
  8132   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  8133   "RTN","CHG ASP1",126, 0)
  8134   HEAD W #,D UZ,?33,"CH AMPVA CENT ER",?72,"P age:  ",PG  S PG=PG+1
  8135   "RTN","CHG ASP1",127, 0)
  8136    W !,TIME, ?25,"Audit  Support Q ueue WIP R eport",!,$ E(DT,4,7), ?80-$L(DAT E)/2,DATE
  8137   "RTN","CHG ASP1",128, 0)
  8138    Q
  8139   "RTN","CHG ASP1",129, 0)
  8140   COLHEAD I  CHTY=4 D   Q
  8141   "RTN","CHG ASP1",130, 0)
  8142    .W !!,"Co de",?14,"D escription ",?46,"P/L ",?59,"Bil led",?72," Allowed"
  8143   "RTN","CHG ASP1",131, 0)
  8144    .W !,"--- ---------- ---------- ---------- ---------- -",?46,"-- -",?54,"-- ---------" ,?68,"---- -------"
  8145   "RTN","CHG ASP1",132, 0)
  8146    .Q
  8147   "RTN","CHG ASP1",133, 0)
  8148    W !!,"Cod e",?14,"De scription" ,?59,"Bill ed",?72,"A llowed"
  8149   "RTN","CHG ASP1",134, 0)
  8150    W !,"---- ---------- ---------- ---------- ---------- ",?54,"--- --------", ?68,"----- ------"
  8151   "RTN","CHG ASP1",135, 0)
  8152    Q
  8153   "RTN","CHG ASP2")
  8154   0^12^B3481 2978
  8155   "RTN","CHG ASP2",1,0)
  8156   CHGASP2 ;C VA/RLC;ASQ  WIP REPOR T PRINT -  IN-PAT CLA IMS ;Feb 0 5, 2019@10 :33:46
  8157   "RTN","CHG ASP2",2,0)
  8158    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  8159   "RTN","CHG ASP2",3,0)
  8160    ;MC284 JE H 9/5/06 C hange OHI  Paid amoun t to Patie nt Respons ibility
  8161   "RTN","CHG ASP2",4,0)
  8162    ;CPE001-0 08 6/19/20 17 WTC CCS E
  8163   "RTN","CHG ASP2",5,0)
  8164    S X=DT D  DTPRT S DA TE=Y,PG=1, X=$P($H,", ",2),H=X\3 600,M=X#36 00\60
  8165   "RTN","CHG ASP2",6,0)
  8166    S:M<10 M= 0_M S:H<10  H=0_M S T IME=H_M
  8167   "RTN","CHG ASP2",7,0)
  8168    ;
  8169   "RTN","CHG ASP2",8,0)
  8170    S REC1=^( CHCLM,1) D  HEAD
  8171   "RTN","CHG ASP2",9,0)
  8172    S REC2=^T MP($J,"WIP ",CHPDI,CH CLM,2),REC 3=^TMP($J, "WIP",CHPD I,CHCLM,3) ,REC4=^TMP ($J,"WIP", CHPDI,CHCL M,4),REC5= ^TMP($J,"W IP",CHPDI, CHCLM,5),R EC6=^TMP($ J,"WIP",CH PDI,CHCLM, 6)
  8173   "RTN","CHG ASP2",10,0 )
  8174    S CHBENE= $P(REC1,U, 1),CHSPON= $P(REC1,U, 2),CHDOB=$ P(REC1,U,3 ),CHREL=$P (REC1,U,4) ,CHSSN=$P( REC1,U,5), CHDOS=$P(R EC1,U,6),C HAOB=$P(RE C1,U,7),CH ACC=$P(REC 1,U,8),CHB AMT=$P(REC 1,U,9)
  8175   "RTN","CHG ASP2",11,0 )
  8176    S CHID=$P (REC2,U,1) ,CHBAD1=$P (REC2,U,2) ,CHBAD2=$P (REC2,U,3) ,CHBCTY=$P (REC2,U,4) ,CHBST=$P( REC2,U,5), CHBZIP=$P( REC2,U,6)
  8177   "RTN","CHG ASP2",12,0 )
  8178    S CHVE=$P (REC3,U,1) ,CHPDITY=$ P(REC3,U,2 ),CHBATCH= $P(REC3,U, 3),CHDOC=$ P(REC3,U,4 ),CHDT=$P( REC3,U,5), CHSTS=$P(R EC3,U,6),C HRSN=$P(RE C3,U,7),CH TOS=$P(REC 3,U,8),CHP OS=$P(REC3 ,U,9),CHAM T=$P(REC3, U,10),CHED I=$P(REC3, U,11),CHAL W=$P(REC3, U,12)
  8179   "RTN","CHG ASP2",13,0 )
  8180    ;S CHVEN= $P(REC4,U, 1),CHTAX=$ P(REC4,U,2 ),CHVNPG=$ P(REC4,U,3 ),CHCMAC=$ P(REC4,U,4 ),CHMCCR=$ P(REC4,U,5 ),CHOHI=$P (REC4,U,6) ,CHVAD1=$P (REC4,U,7) ,CHVAD2=$P (REC4,U,8) ,CHVCTY=$P (REC4,U,9) ,CHVST=$P( REC4,U,10) ,CHVZIP=$P (REC4,U,11 )
  8181   "RTN","CHG ASP2",14,0 )
  8182    ;CJM LINE  LENGTH FO R MIGRATIO N R1 20170 719
  8183   "RTN","CHG ASP2",15,0 )
  8184    S CHVEN=$ P(REC4,U,1 ),CHTAX=$P (REC4,U,2) ,CHVNPG=$P (REC4,U,3) ,CHCMAC=$P (REC4,U,4) ,CHMCCR=$P (REC4,U,5) ,CHOHI=$P( REC4,U,6), CHVAD1=$P( REC4,U,7), CHVAD2=$P( REC4,U,8), CHVCTY=$P( REC4,U,9), CHVST=$P(R EC4,U,10)
  8185   "RTN","CHG ASP2",16,0 )
  8186    S CHVZIP= $P(REC4,U, 11),CHOHIP R=$P(REC4, U,13)   ;  JEH 9/5/06
  8187   "RTN","CHG ASP2",17,0 )
  8188    S CHMED=$ P(REC5,U,1 ),CHMAD1=$ P(REC5,U,2 ),CHMAD2=$ P(REC5,U,3 ),CHMCTY=$ P(REC5,U,4 ),CHMST=$P (REC5,U,5) ,CHMZIP=$P (REC5,U,6) ,CHDRG=$P( REC5,U,7), CHMETH=$P( REC5,U,8), CHMTAX=$P( REC5,U,9)
  8189   "RTN","CHG ASP2",18,0 )
  8190    S CHOHT=$ P(REC6,U,1 ),CHOHB=$P (REC6,U,2) ,CHOHE=$P( REC6,U,3)
  8191   "RTN","CHG ASP2",19,0 )
  8192    D INP
  8193   "RTN","CHG ASP2",20,0 )
  8194    S:CHCMAC= "" CHCMAC= 3
  8195   "RTN","CHG ASP2",21,0 )
  8196    ;
  8197   "RTN","CHG ASP2",22,0 )
  8198   PRINT W !! ,"PDI:  ", CHPDI,"-", CHPDITY,?2 8,"Claim # : ",CHCLM, ?53,"Bene:  ",CHBENE
  8199   "RTN","CHG ASP2",23,0 )
  8200    W !,"Batc h #:  ",CH BATCH,?28, "TOS:  ",C HTOS,?53," Spon: ",CH SPON
  8201   "RTN","CHG ASP2",24,0 )
  8202    W !,"Doc  Id#:  ",CH DOC,?28,"S tatus:  ", CHSTS,?55, "VE: ",CHV E
  8203   "RTN","CHG ASP2",25,0 )
  8204    W !!,"Dat e in ASQ:  ",$$FMTE^X LFDT(CHDT, "2D"),?28, "Rsn in AS Q: ",CHRSN ,?53,"Mail man #: ",C HMM
  8205   "RTN","CHG ASP2",26,0 )
  8206    W !,"Admi ssion: ",$ $FMTE^XLFD T(CHDOS,"2 D"),?28,"D ischarge:  ",$$FMTE^X LFDT(CHDIS ,"2D"),?53 ,"Dis Stat us: ",CHDS TAT
  8207   "RTN","CHG ASP2",27,0 )
  8208    W !,"Fac  Disch to:  ",CHFAC,?2 8,"Inj/Acc : ",CHACC, ?53,"MCCR  Review: ", CHMCCR
  8209   "RTN","CHG ASP2",28,0 )
  8210    W !,"OHI  Type: ",$E (CHOHT,1,1 5),?28,"OH I Begin: " ,$$FMTE^XL FDT(CHOHB, "2D"),?53, "OHI End:  ",$$FMTE^X LFDT(CHOHE ,"2D")
  8211   "RTN","CHG ASP2",29,0 )
  8212    W !,"EDI  Claim: ",C HEDI
  8213   "RTN","CHG ASP2",30,0 )
  8214    I CHOHI'= "" W ?28," OHI Paymt:  ","$ ",$J ($FN(CHOHI ,",",2),9)
  8215   "RTN","CHG ASP2",31,0 )
  8216    E  W ?28, "OHI Paymt : ",CHOHI
  8217   "RTN","CHG ASP2",32,0 )
  8218    I CHOHIPR '="" D   ;  JEH 9/5/0 6 ADDED PA TIENT RESP  LOGIC
  8219   "RTN","CHG ASP2",33,0 )
  8220    .W !,"OHI  P/R: ","$  ",$J($FN( CHOHIPR,", ",2),9)
  8221   "RTN","CHG ASP2",34,0 )
  8222    E  D
  8223   "RTN","CHG ASP2",35,0 )
  8224    .S CHOHIP R=CHAMT-CH OHI
  8225   "RTN","CHG ASP2",36,0 )
  8226    .W !,"OHI  P/R: ","$  ",$J($FN( CHOHIPR,", ",2),9)
  8227   "RTN","CHG ASP2",37,0 )
  8228    I CHBAMT' ="" W ?53, "Bene Paym t:  ","$ " ,$J($FN(CH BAMT,",",2 ),9)
  8229   "RTN","CHG ASP2",38,0 )
  8230    E  W ?53, "Bene Paym t: ",CHBAM T
  8231   "RTN","CHG ASP2",39,0 )
  8232    ;
  8233   "RTN","CHG ASP2",40,0 )
  8234    ;  Extrac t PL ZIP f rom Claim  file and d isplay.  w tc 6/19/17
  8235   "RTN","CHG ASP2",41,0 )
  8236    ;
  8237   "RTN","CHG ASP2",42,0 )
  8238    S CHCLMNU M=$O(^CHMP AY("B",CHC LM,0)) ;
  8239   "RTN","CHG ASP2",43,0 )
  8240    I CHCLMNU M'="" S PL ZIP=$P($G( ^CHMPAY(CH CLMNUM,"VE N-II")),"^ ",15) W !? 53,"PL ZIP : ",PLZIP  ; WTC 5/19 /17
  8241   "RTN","CHG ASP2",44,0 )
  8242    W !,"Drg:  ",CHDRG,? 28,"Paymt  Method: ", CHMETH
  8243   "RTN","CHG ASP2",45,0 )
  8244    W !!,"Adm itting Dx:  ",CHADXCD ,"-",CHADX
  8245   "RTN","CHG ASP2",46,0 )
  8246    W !!,"Cod e",?12,"De scription" ,?59,"Bill ed",?72,"A llowed"
  8247   "RTN","CHG ASP2",47,0 )
  8248    W !,"---- ---------- ---------- ---------- --------", ?54,"----- ------",?6 8,"------- ----"
  8249   "RTN","CHG ASP2",48,0 )
  8250    D DIAG^CH GASP3,PROC ^CHGASP3
  8251   "RTN","CHG ASP2",49,0 )
  8252    D ITEM,NC ,ROOM
  8253   "RTN","CHG ASP2",50,0 )
  8254    W !,?54," ---------- -",?68,"-- ---------"
  8255   "RTN","CHG ASP2",51,0 )
  8256    W !,?44," Totals"
  8257   "RTN","CHG ASP2",52,0 )
  8258    I CHAMT'= "" W ?54,$ J($FN(CHAM T,",",2),1 1)
  8259   "RTN","CHG ASP2",53,0 )
  8260    I CHALW'= "" W ?68,$ J($FN(CHAL W,",",2),1 1)
  8261   "RTN","CHG ASP2",54,0 )
  8262    E  S CHAL W="Und" W  ?68,$J(CHA LW,11)
  8263   "RTN","CHG ASP2",55,0 )
  8264    D ^CHGASP 3
  8265   "RTN","CHG ASP2",56,0 )
  8266    ;
  8267   "RTN","CHG ASP2",57,0 )
  8268   END K REC1 ,REC2,REC3 ,REC4,REC5 ,REC6,REC7 ,REC8,HREC ,CHBENE,CH DOB
  8269   "RTN","CHG ASP2",58,0 )
  8270    K CHSPON, CHREL,CHSS N,CHDOS,CH AOB,CHALL, CHBAMT,CHI D,CHBAD1,C HBAD2,CHBS T
  8271   "RTN","CHG ASP2",59,0 )
  8272    K CHBCTY, CHBZIP,CHV E,CHPDITY, CHBATCH,CH DOC,CHDT,C HSTS,CHRSN ,CHTOS,CHP OS
  8273   "RTN","CHG ASP2",60,0 )
  8274    K CHAMT,C HEDI,CHALW ,CHVEN,CHT AX,CHVNPG, CHCMAC,CHO HIF,CHOHI, CHVAD1,CHV ST,CHOHIPR    ; JEH 9 /5/06 ADDE D CHOHIPR
  8275   "RTN","CHG ASP2",61,0 )
  8276    K CHVAD2, CHVCTY,CHV ZIP,CHMED, CHMAD1,CHM AD2,CHMCTY ,CHMST,CHM ZIP,CHDRG
  8277   "RTN","CHG ASP2",62,0 )
  8278    K CHMETH, CHPSVEN,CH PSTAX,CHPS AD1,CHPSAD 2,CHPSCTY, CHPST,CHPS ZIP,CHDSBE N
  8279   "RTN","CHG ASP2",63,0 )
  8280    K CHDSSN, CHDAD1,CHD AD2,CHDCTY ,CHDST,CHD ZIP,CHDSDO B,CHDSREL, CHNAM,CHTY PE
  8281   "RTN","CHG ASP2",64,0 )
  8282    K CHDIS,C HDSTAT,CHA DX,CHADXCD ,CHFAC,X,C HREC,CHDX, CHDIAG,N,C HRC,CHPROC
  8283   "RTN","CHG ASP2",65,0 )
  8284    K CHDES,C HCHG,CHMOD ,CHPL,CHAL L,CT,CHFLA G,CHFLG1,C HFLG2,CHR, CHIDT,CHIT EM
  8285   "RTN","CHG ASP2",66,0 )
  8286    K CHITAMT ,CHANES,CH ANCST,CHAN ECST,CHPSC D,CHDSC,CN T,CHR1,CHN TEM,CHNAMT
  8287   "RTN","CHG ASP2",67,0 )
  8288    K CHANS,C HPNC,CHDSC R,XX,CHR2, CHRTP,CHRM RT,CHRMDAY ,^TMP($J," WIP")
  8289   "RTN","CHG ASP2",68,0 )
  8290    K CHCLMNU M,PLZIP ;  WTC 6/19/1 7
  8291   "RTN","CHG ASP2",69,0 )
  8292    Q
  8293   "RTN","CHG ASP2",70,0 )
  8294    ;
  8295   "RTN","CHG ASP2",71,0 )
  8296   INP S CT=0 ,(CHDIS,CH DSTAT,CHAD X,CHADXCD, CHFAC)=""
  8297   "RTN","CHG ASP2",72,0 )
  8298   IN1 S CT=$ O(^TMP($J, "WIP",CHPD I,CHCLM,"I NP",CT)) Q :CT=""
  8299   "RTN","CHG ASP2",73,0 )
  8300    S PC=^(CT )
  8301   "RTN","CHG ASP2",74,0 )
  8302    S CHDIS=$ P(PC,U,1), CHDSTAT=$P (PC,U,2),C HADX=$P(PC ,U,3),CHAD XCD=$P(PC, U,4),CHFAC =$P(PC,U,5 )
  8303   "RTN","CHG ASP2",75,0 )
  8304    G IN1
  8305   "RTN","CHG ASP2",76,0 )
  8306    ;
  8307   "RTN","CHG ASP2",77,0 )
  8308   ITEM S CT= "",CHFLG=0
  8309   "RTN","CHG ASP2",78,0 )
  8310   IT1 S CT=$ O(^TMP($J, "WIP",CHPD I,CHCLM,"I TEM",CT))  Q:CT=""
  8311   "RTN","CHG ASP2",79,0 )
  8312    S CHR=^(C T)
  8313   "RTN","CHG ASP2",80,0 )
  8314    S CHIDT=$ P(CHR,U,1) ,CHITEM=$P (CHR,U,2), CHANES=$P( CHR,U,3),C HANCST=$P( CHR,U,4),C HPSCD=$P(C HR,U,5),CH DSC=$P(CHR ,U,6),CHDS C=$E(CHDSC ,1,14)
  8315   "RTN","CHG ASP2",81,0 )
  8316    D:CHFLG=0  ITEMP
  8317   "RTN","CHG ASP2",82,0 )
  8318    W !,$$FMT E^XLFDT(CH IDT,"2D"), ?13,CHITEM ,?37,CHANE S
  8319   "RTN","CHG ASP2",83,0 )
  8320    I CHANCST '="" W ?43 ,$J($FN(CH ANCST,",", 2),7)
  8321   "RTN","CHG ASP2",84,0 )
  8322    W !,?13,C HPSCD,?20, CHDSC
  8323   "RTN","CHG ASP2",85,0 )
  8324    G IT1
  8325   "RTN","CHG ASP2",86,0 )
  8326    ;
  8327   "RTN","CHG ASP2",87,0 )
  8328   ITEMP W !! ,"Date",?1 3,"Item(s) ",?37,"#", ?43,"Un Co st"
  8329   "RTN","CHG ASP2",88,0 )
  8330    W !,"---- ----",?13, "--------- ---------- --",?37,"- -",?43,"-- -----"
  8331   "RTN","CHG ASP2",89,0 )
  8332    S CHFLG=1
  8333   "RTN","CHG ASP2",90,0 )
  8334    Q
  8335   "RTN","CHG ASP2",91,0 )
  8336    ;
  8337   "RTN","CHG ASP2",92,0 )
  8338   NC S CNT=" ",CHFLG1=0
  8339   "RTN","CHG ASP2",93,0 )
  8340   N1 S CNT=$ O(^TMP($J, "WIP",CHPD I,CHCLM,"N C",CNT)) Q :CNT=""
  8341   "RTN","CHG ASP2",94,0 )
  8342    S CHR1=^( CNT)
  8343   "RTN","CHG ASP2",95,0 )
  8344    S CHNTEM= $P(CHR1,U, 1),CHANS=$ P(CHR1,U,2 ),CHANECST =$P(CHR1,U ,3),CHPNC= $P(CHR1,U, 4),CHDSCR= $P(CHR1,U, 5)
  8345   "RTN","CHG ASP2",96,0 )
  8346    D:CHFLG1= 0 NCP
  8347   "RTN","CHG ASP2",97,0 )
  8348    W !,$E(CH NTEM,1,20)
  8349   "RTN","CHG ASP2",98,0 )
  8350    W ?25,$J( $FN(CHANS, ",",0),5)
  8351   "RTN","CHG ASP2",99,0 )
  8352    I CHANECS T'="" W ?3 5,$J($FN(C HANECST,", ",2),9)
  8353   "RTN","CHG ASP2",100, 0)
  8354    W:(CHPNC' ="")!(CHDS CR'="") !, CHPNC,?12, CHDSCR
  8355   "RTN","CHG ASP2",101, 0)
  8356    G N1
  8357   "RTN","CHG ASP2",102, 0)
  8358    ;
  8359   "RTN","CHG ASP2",103, 0)
  8360   NCP W !!," Non-Covere d Item(s)" ,?25,"Unit s",?35,"Un it Cost"
  8361   "RTN","CHG ASP2",104, 0)
  8362    W !,"---- ---------- ------",?2 5,"-----", ?35,"----- ----"
  8363   "RTN","CHG ASP2",105, 0)
  8364    S CHFLG1= 1
  8365   "RTN","CHG ASP2",106, 0)
  8366    Q
  8367   "RTN","CHG ASP2",107, 0)
  8368    ;
  8369   "RTN","CHG ASP2",108, 0)
  8370   ROOM S XX= "",CHFLG2= 0
  8371   "RTN","CHG ASP2",109, 0)
  8372   RM1 S XX=$ O(^TMP($J, "WIP",CHPD I,CHCLM,"R OOM",XX))  Q:XX=""
  8373   "RTN","CHG ASP2",110, 0)
  8374    S CHR2=^( XX),CHCNT= 0
  8375   "RTN","CHG ASP2",111, 0)
  8376    S CHRTP=$ P(CHR2,U,1 ),CHRMRT=$ P(CHR2,U,2 ),CHRMDAY= $P(CHR2,U, 3)
  8377   "RTN","CHG ASP2",112, 0)
  8378    D:CHFLG2= 0 ROOMP
  8379   "RTN","CHG ASP2",113, 0)
  8380    W !,CHRTP
  8381   "RTN","CHG ASP2",114, 0)
  8382    W ?25,$J( $FN(CHRMDA Y,",",0),7 )
  8383   "RTN","CHG ASP2",115, 0)
  8384    I CHRMRT' ="" W ?35, $J($FN(CHR MRT,",",2) ,9)
  8385   "RTN","CHG ASP2",116, 0)
  8386    G RM1
  8387   "RTN","CHG ASP2",117, 0)
  8388    ;
  8389   "RTN","CHG ASP2",118, 0)
  8390   ROOMP W !! ,"Room Typ e",?25,"#D ays",?35," Room Rate"
  8391   "RTN","CHG ASP2",119, 0)
  8392    W !,"---- ---------- -",?25,"-- ---",?35," ---------"
  8393   "RTN","CHG ASP2",120, 0)
  8394    S CHFLG2= 1
  8395   "RTN","CHG ASP2",121, 0)
  8396    Q
  8397   "RTN","CHG ASP2",122, 0)
  8398    ;
  8399   "RTN","CHG ASP2",123, 0)
  8400   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  8401   "RTN","CHG ASP2",124, 0)
  8402    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  8403   "RTN","CHG ASP2",125, 0)
  8404    Q
  8405   "RTN","CHG ASP2",126, 0)
  8406   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  8407   "RTN","CHG ASP2",127, 0)
  8408   HEAD W #,D UZ,?33,"CH AMPVA CENT ER",?72,"P age:  ",PG  S PG=PG+1
  8409   "RTN","CHG ASP2",128, 0)
  8410    W !,TIME, ?25,"Audit  Support Q ueue WIP R eport",!,$ E(DT,4,7), ?80-$L(DAT E)/2,DATE
  8411   "RTN","CHG ASP2",129, 0)
  8412    Q
  8413   "RTN","CHG CDC71")
  8414   0^13^B3625 6173
  8415   "RTN","CHG CDC71",1,0 )
  8416   CHGCDC71 ; CVA/RLC;CC D INITIAL  INPUT DATA  CALC-MODU LE 7-INPAT IENT ;Feb  05, 2019@1 0:34:52
  8417   "RTN","CHG CDC71",2,0 )
  8418    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  8419   "RTN","CHG CDC71",3,0 )
  8420    ;CPTS #11 673* (RLC) , #11832*  (RLC), #15 437* (RLC)
  8421   "RTN","CHG CDC71",4,0 )
  8422    ;PT #1618 2 (Y2K)
  8423   "RTN","CHG CDC71",5,0 )
  8424    ;BUG01938 8-03-01  E W 1/6/14 F OUND ERROR  WHILE TES TING BUG F IX
  8425   "RTN","CHG CDC71",6,0 )
  8426    ; CPE001- 004 WTC 6/ 20/17
  8427   "RTN","CHG CDC71",7,0 )
  8428    S (XDOS,H DFN,HBFN)= ""
  8429   "RTN","CHG CDC71",8,0 )
  8430    ; Y2K - c hgd all 2  dig yr to  4 dig yr
  8431   "RTN","CHG CDC71",9,0 )
  8432    S CHHSDT= JX,CHHSDT= $$FMTE^XLF DT(CHHSDT, 5),CHDZZ=" ",(HDFN,HB FN,HVEN)=" "
  8433   "RTN","CHG CDC71",10, 0)
  8434    S CHSB=$S (CHTY=1:"I NP-DX",CHT Y=2:"OPT-D X",CHTY=4: "DME-DX",C HTY=5:"DEN -DX",CHTY= 6:"OPT-DX" ,1:"")
  8435   "RTN","CHG CDC71",11, 0)
  8436    S CHSB1=$ S(CHTY=1:" INP-PROC", CHTY=2:"OP T-PROC",CH TY=5:"DEN- PROC",CHTY =6:"OPT-PR OC",1:"")
  8437   "RTN","CHG CDC71",12, 0)
  8438    S:$D(@(GL PAYH_"IVL, 101,JX,99) ")) CHDZZ= $P(@(GLPAY H_"IVL,101 ,JX,99)"), U,1)
  8439   "RTN","CHG CDC71",13, 0)
  8440    S CHDZHS= "UNK"
  8441   "RTN","CHG CDC71",14, 0)
  8442    I CHDZZ'= "" I $D(^V A(200,CHDZ Z,0)) S CH DZHS=$P(^V A(200,CHDZ Z,0),U,2)
  8443   "RTN","CHG CDC71",15, 0)
  8444    S CHDZHS= CHDZHS_"-" _CHDZZ
  8445   "RTN","CHG CDC71",16, 0)
  8446    F SUB=0,1 ,7,9,10,27 ,"COMMON", "DME","INP " D
  8447   "RTN","CHG CDC71",17, 0)
  8448    .K FILE1
  8449   "RTN","CHG CDC71",18, 0)
  8450    .;I SUB?1 .2N S FILE 1="^"_GLPA YH_IVL_",1 01,"_JX_", "_SUB_")"
  8451   "RTN","CHG CDC71",19, 0)
  8452    .;E  S FI LE1="^"_GL PAYH_IVL_" ,101,"_JX_ ","""_SUB_ """)"
  8453   "RTN","CHG CDC71",20, 0)
  8454    .;I '$D(@ FILE1) D L ABEL Q
  8455   "RTN","CHG CDC71",21, 0)
  8456    .I '$D(@( GLPAYH_"IV L,101,JX,S UB)")) I ' $D(@(GLPAY H_"IVL,101 ,JX,"""_SU B_""")"))  D LABEL Q
  8457   "RTN","CHG CDC71",22, 0)
  8458    .I SUB?1. 2N S FILE1 =@(GLPAYH_ "IVL,101,J X,SUB)")
  8459   "RTN","CHG CDC71",23, 0)
  8460    .E  S FIL E1=@(GLPAY H_"IVL,101 ,JX,"""_SU B_""")")
  8461   "RTN","CHG CDC71",24, 0)
  8462    .S OTHFL= 1
  8463   "RTN","CHG CDC71",25, 0)
  8464    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"HIST ",JX)) ^(J X)=CHDZHS_ U_CHHSDT
  8465   "RTN","CHG CDC71",26, 0)
  8466    .I SUB=0  F X=3,5,7, 8,21,22 S  PC=$P(FILE 1,U,X) D:P C'=""
  8467   "RTN","CHG CDC71",27, 0)
  8468    ..S LABEL =$S(X=5:"P ay Provide r: ",X=7:" Type Servi ce: ",X=8: "DOS: ",1: "")
  8469   "RTN","CHG CDC71",28, 0)
  8470    ..I X=3 S  HVEN=PC
  8471   "RTN","CHG CDC71",29, 0)
  8472    ..I X=5 S :PC=0 PC=" NO" S:PC=1  PC="YES"
  8473   "RTN","CHG CDC71",30, 0)
  8474    ..I X=7 I  $D(^CHMDI C(741002.0 5,PC,0)) S  PC=$P(^CH MDIC(74100 2.05,PC,0) ,U,1)
  8475   "RTN","CHG CDC71",31, 0)
  8476    ..I X=8 I  CHTY=1 S  LABEL="Adm ission: "
  8477   "RTN","CHG CDC71",32, 0)
  8478    ..I X=8 S  XDOS=PC,P C=$$FMTE^X LFDT(PC,"5 D")
  8479   "RTN","CHG CDC71",33, 0)
  8480    ..I X=21  S HDFN=PC
  8481   "RTN","CHG CDC71",34, 0)
  8482    ..I X=22  S HBFN=PC
  8483   "RTN","CHG CDC71",35, 0)
  8484    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8485   "RTN","CHG CDC71",36, 0)
  8486    .I SUB=1  F X=7 S PC =$P(FILE1, U,X) D
  8487   "RTN","CHG CDC71",37, 0)
  8488    ..S LABEL ="OHI Paym t: "
  8489   "RTN","CHG CDC71",38, 0)
  8490    ..I PC'=" " S PC=$J( PC,",",2)
  8491   "RTN","CHG CDC71",39, 0)
  8492    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8493   "RTN","CHG CDC71",40, 0)
  8494    .I SUB=7  F X=1,2,5, 6 S PC=$P( FILE1,U,X)  D
  8495   "RTN","CHG CDC71",41, 0)
  8496    ..S LABEL =$S(X=1:"M edicaid Ag ency: ",X= 2:"Medicai d Paid: ", X=5:"PCN/P AN: ",X=6: "Type of B ill: ",1:" ")
  8497   "RTN","CHG CDC71",42, 0)
  8498    ..I X=2 I  PC'="" S  PC=$J(PC," ,",2)
  8499   "RTN","CHG CDC71",43, 0)
  8500    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8501   "RTN","CHG CDC71",44, 0)
  8502    .I SUB=10  F X=21 S  PC=$P(FILE 1,U,X) D:P C'=""
  8503   "RTN","CHG CDC71",45, 0)
  8504    ..S LABEL ="MCCR Rev iew: "
  8505   "RTN","CHG CDC71",46, 0)
  8506    ..S:PC=0  PC="NO" S: PC=1 PC="Y ES"
  8507   "RTN","CHG CDC71",47, 0)
  8508    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8509   "RTN","CHG CDC71",48, 0)
  8510    .I SUB=27  F X=1,2,3  S PC=$P(F ILE1,U,X)  D
  8511   "RTN","CHG CDC71",49, 0)
  8512    ..S LABEL =$S(X=1:"O HI Begin:  ",X=2:"OHI  End: ",X= 3:"OHI Typ e: ",1:"")
  8513   "RTN","CHG CDC71",50, 0)
  8514    ..I (X=1) !(X=2) S P C=$$FMTE^X LFDT(PC,"5 D")
  8515   "RTN","CHG CDC71",51, 0)
  8516    ..I X=3 I  PC I $D(^ CHMDIC(741 002.76,PC, 0)) S PC=$ P(^(0),"^" ,1)
  8517   "RTN","CHG CDC71",52, 0)
  8518    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8519   "RTN","CHG CDC71",53, 0)
  8520    ..I X=3 D  OHI S X=4 ,LABEL="OH I Name: "  S:'$D(OHIF L) PC="N/A "
  8521   "RTN","CHG CDC71",54, 0)
  8522    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8523   "RTN","CHG CDC71",55, 0)
  8524    .I SUB="C OMMON" F X =1,2,3,8 S  PC=$P(FIL E1,U,X) D
  8525   "RTN","CHG CDC71",56, 0)
  8526    ..S LABEL =$S(X=1:"T otal Charg e: ",X=2:" POS: ",X=3 :"Bene Pay mt: ",1:"" )
  8527   "RTN","CHG CDC71",57, 0)
  8528    ..I X=2 I  PC'="" I  $D(^CHMDIC (741002.11 ,PC,0)) S  PC=$P(^CHM DIC(741002 .11,PC,0), U,2),PC=$E (PC,1,15)
  8529   "RTN","CHG CDC71",58, 0)
  8530    ..I X=3 I  PC>0 S PC =$J(PC,"," ,2)
  8531   "RTN","CHG CDC71",59, 0)
  8532    ..I X=3 I  PC'>0 S P C=""
  8533   "RTN","CHG CDC71",60, 0)
  8534    ..I X=8 I  CHTY=1 S  LABEL="DRG : "
  8535   "RTN","CHG CDC71",61, 0)
  8536    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8537   "RTN","CHG CDC71",62, 0)
  8538    .I SUB="D ME" F X=1  S PC=$P(FI LE1,U,X) D
  8539   "RTN","CHG CDC71",63, 0)
  8540    ..S LABEL ="Delivery  Chg: "
  8541   "RTN","CHG CDC71",64, 0)
  8542    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"DMEHST" ,JX)=PC_U_ LABEL
  8543   "RTN","CHG CDC71",65, 0)
  8544    .I SUB="I NP" F X=1, 2,3,7 S PC =$P(FILE1, U,X) D
  8545   "RTN","CHG CDC71",66, 0)
  8546    ..S LABEL =$S(X=1:"D ischarge:  ",X=2:"Dis  Status: " ,X=3:"Admi tting DX:  ",X=7:"Fac  Discharge d to: ",1: "")
  8547   "RTN","CHG CDC71",67, 0)
  8548    ..I X=1 S  PC=$$FMTE ^XLFDT(PC, "5D")
  8549   "RTN","CHG CDC71",68, 0)
  8550    ..I X=2 I  PC'="" I  $D(^CHMDIC (741002.12 ,PC,0)) S  PC=$P(^(0) ,U,1)
  8551   "RTN","CHG CDC71",69, 0)
  8552    ..I X=3 I  PC'="" D
  8553   "RTN","CHG CDC71",70, 0)
  8554    ...I $D(^ CHMICDX(PC ,0)) S P1= $P(^(0),U, 2),P2=$P(^ (0),U,1),P C=P1_"-"_P 2  ;BUG019 388-03-01   EW 1/6/14
  8555   "RTN","CHG CDC71",71, 0)
  8556    ...Q
  8557   "RTN","CHG CDC71",72, 0)
  8558    ..I X=7 I  PC'="" I  $D(^CHMDIC (741002.11 ,PC,0)) S  PC=$P(^(0) ,U,1)
  8559   "RTN","CHG CDC71",73, 0)
  8560    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8561   "RTN","CHG CDC71",74, 0)
  8562    S (BFLAG, VFLAG)=0
  8563   "RTN","CHG CDC71",75, 0)
  8564    D ^CHGCDC 72  ;BENE/ VENDOR DEM OGRAPHICS  INITIAL IN PUT & EDIT S
  8565   "RTN","CHG CDC71",76, 0)
  8566    D ^CHGCDC 73  ;LINE- ITEM DATA  INITIAL IN PUT & EDIT S
  8567   "RTN","CHG CDC71",77, 0)
  8568    ; WTC 6/2 0/17
  8569   "RTN","CHG CDC71",78, 0)
  8570    S TMPCLPT =0,TMPCLPT =$O(^CHMPA Y("B",CHCL M,TMPCLPT) ) ;
  8571   "RTN","CHG CDC71",79, 0)
  8572    S PC=$P($ G(^CHMPAY( TMPCLPT,"V EN-II"))," ^",15) ;
  8573   "RTN","CHG CDC71",80, 0)
  8574    S CHDZHS= "",CHHSDT= "",SUB="VE N-II",X=15 ,LABEL="PL  ZIP: " ;
  8575   "RTN","CHG CDC71",81, 0)
  8576    S ^TMP($J ,"CCD",CHC LM,CHTYPE, "HIST",JX, SUB,X)=PC_ U_LABEL
  8577   "RTN","CHG CDC71",82, 0)
  8578    ;
  8579   "RTN","CHG CDC71",83, 0)
  8580   END K FILE ,FILE1,FIL E2,FILH,FI L0,FIL1,FI L2,FIL3,FI L4,FIL41,F IL22
  8581   "RTN","CHG CDC71",84, 0)
  8582    Q
  8583   "RTN","CHG CDC71",85, 0)
  8584    ;
  8585   "RTN","CHG CDC71",86, 0)
  8586   LABEL I SU B=0 F X=7, 8 S PC=""  D
  8587   "RTN","CHG CDC71",87, 0)
  8588    .S LABEL= $S(X=7:"Ty pe Service : ",X=8:"D OS: ",1:"" )
  8589   "RTN","CHG CDC71",88, 0)
  8590    .I X=8 I  $P(@(GLPAY _"IVL,0)") ,U,7)=1 S  LABEL="Adm ission: "
  8591   "RTN","CHG CDC71",89, 0)
  8592    .I $P(@(G LPAY_"IVL, 0)"),U,7)= 1 S LABEL= "Admission : "
  8593   "RTN","CHG CDC71",90, 0)
  8594    .D SET
  8595   "RTN","CHG CDC71",91, 0)
  8596    I SUB=1 F  X=7 S PC= "" D
  8597   "RTN","CHG CDC71",92, 0)
  8598    .S LABEL= "OHI Payme nt Hist: "
  8599   "RTN","CHG CDC71",93, 0)
  8600    .D SET
  8601   "RTN","CHG CDC71",94, 0)
  8602    .S @(GLPA YH_"IVL,10 1,JX,SUB)" )=""
  8603   "RTN","CHG CDC71",95, 0)
  8604    I SUB=7 F  X=1,2,5,7  S PC="" D
  8605   "RTN","CHG CDC71",96, 0)
  8606    .S LABEL= $S(X=1:"Me dicaid Age ncy: ",X=2 :"Medicaid  Paid: ",X =5:"PCN/PA N: ",X=7:" Type of Bi ll: ",1:"" )
  8607   "RTN","CHG CDC71",97, 0)
  8608    .D SET
  8609   "RTN","CHG CDC71",98, 0)
  8610    .S @(GLPA YH_"IVL,10 1,JX,SUB)" )=""
  8611   "RTN","CHG CDC71",99, 0)
  8612    I SUB=10  F X=20 S P C="" D
  8613   "RTN","CHG CDC71",100 ,0)
  8614    .S LABEL= "MCCR Revi ew: "
  8615   "RTN","CHG CDC71",101 ,0)
  8616    .D SET
  8617   "RTN","CHG CDC71",102 ,0)
  8618    I SUB=27  D OHI F X= 1,2,3 S PC ="" D
  8619   "RTN","CHG CDC71",103 ,0)
  8620    .S LABEL= $S(X=1:"OH I Begin: " ,X=2:"OHI  End: ",X=3 :"OHI Type : ",1:"")
  8621   "RTN","CHG CDC71",104 ,0)
  8622    .I X=1 S  PC=CHOHBHS ,PC=$$FMTE ^XLFDT(PC, "5D") D SE T Q
  8623   "RTN","CHG CDC71",105 ,0)
  8624    .I X=2 S  PC=CHOHEHS ,PC=$$FMTE ^XLFDT(PC, "5D") D SE T Q
  8625   "RTN","CHG CDC71",106 ,0)
  8626    .I X=3 S  PC=CHOHTHS  D SET
  8627   "RTN","CHG CDC71",107 ,0)
  8628    .S X=4,LA BEL="OHI N ame: ",PC= CHOHNAM D  SET
  8629   "RTN","CHG CDC71",108 ,0)
  8630    I SUB="CO MMON" F X= 1,2,3,8 S  PC="" D
  8631   "RTN","CHG CDC71",109 ,0)
  8632    .S LABEL= $S(X=1:"To tal Charge : ",X=2:"P OS: ",X=3: "Bene Paym t: ",1:"")
  8633   "RTN","CHG CDC71",110 ,0)
  8634    .I X=8 I  CHTY=1 S L ABEL="DRG:  "
  8635   "RTN","CHG CDC71",111 ,0)
  8636    .D SET
  8637   "RTN","CHG CDC71",112 ,0)
  8638    .S @(GLPA YH_"IVL,10 1,JX,"""_S UB_""")")= ""
  8639   "RTN","CHG CDC71",113 ,0)
  8640    I SUB="DM E" F X=1 S  PC="" D
  8641   "RTN","CHG CDC71",114 ,0)
  8642    .S LABEL= "Delivery  Chg: "
  8643   "RTN","CHG CDC71",115 ,0)
  8644    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"DMEH ST",JX)) ^ (JX)=CHDZH S_U_CHHSDT
  8645   "RTN","CHG CDC71",116 ,0)
  8646    .S ^TMP($ J,"CCD",CH CLM,CHTYPE ,"DMEHST", JX)=PC_U_L ABEL
  8647   "RTN","CHG CDC71",117 ,0)
  8648    I SUB="IN P" F X=1,2 ,3,7 S PC= "" D
  8649   "RTN","CHG CDC71",118 ,0)
  8650    .S LABEL= $S(X=1:"Di scharge: " ,X=2:"Dis  Status: ", X=3:"Admit ting DX: " ,X=7:"Fac  Discharged  to: ",1:" ")
  8651   "RTN","CHG CDC71",119 ,0)
  8652    .D SET
  8653   "RTN","CHG CDC71",120 ,0)
  8654    Q
  8655   "RTN","CHG CDC71",121 ,0)
  8656    ;
  8657   "RTN","CHG CDC71",122 ,0)
  8658   OHI S (CHO HBHS,CHOHE HS,CHOHS,C HOHTHS,CHO HNAM)=""
  8659   "RTN","CHG CDC71",123 ,0)
  8660    Q:(HDFN=" ")!(HBFN=" ")!(XDOS=" ")
  8661   "RTN","CHG CDC71",124 ,0)
  8662    S IVAL=0
  8663   "RTN","CHG CDC71",125 ,0)
  8664   O1 S IVAL= $O(@(GLDFN _"""B"",HD FN,IVAL)") ) Q:'IVAL
  8665   "RTN","CHG CDC71",126 ,0)
  8666    S JVAL=0
  8667   "RTN","CHG CDC71",127 ,0)
  8668   O2 S JVAL= $O(@(GLDFN _"IVAL,100 ,""B"",HBF N,JVAL)"))  G:'JVAL O 1
  8669   "RTN","CHG CDC71",128 ,0)
  8670    G:'$D(@(G LDFN_"IVAL ,100,JVAL, 2)")) O2
  8671   "RTN","CHG CDC71",129 ,0)
  8672    S KVAL=XD OS
  8673   "RTN","CHG CDC71",130 ,0)
  8674   O3 S KVAL= $O(@(GLDFN _"IVAL,100 ,JVAL,2,"" B"",KVAL)" ),-1) G:'K VAL O2
  8675   "RTN","CHG CDC71",131 ,0)
  8676    S K1=0
  8677   "RTN","CHG CDC71",132 ,0)
  8678   O4 S K1=$O (@(GLDFN_" IVAL,100,J VAL,2,""B" ",KVAL,K1) ")) G:'K1  O3
  8679   "RTN","CHG CDC71",133 ,0)
  8680    G:'$D(@(G LDFN_"IVAL ,100,JVAL, 2,K1,0)"))  O3 S ORC= @(GLDFN_"I VAL,100,JV AL,2,K1,0) ")
  8681   "RTN","CHG CDC71",134 ,0)
  8682    S CHOHBHS =$P(ORC,U, 1),CHOHEHS =$P(ORC,U, 2),CHOHS=$ P(ORC,U,3)
  8683   "RTN","CHG CDC71",135 ,0)
  8684    S CHOHNAM =$P(ORC,U, 7)
  8685   "RTN","CHG CDC71",136 ,0)
  8686    I CHOHS I  $D(^CHMDI C(741002.7 6,CHOHS,0) ) S CHOHTH S=$P(^(0), U,1)
  8687   "RTN","CHG CDC71",137 ,0)
  8688    S:CHOHNAM ="" CHOHNA M="N/A" S  CHOHNAM=$E (CHOHNAM,1 ,20)
  8689   "RTN","CHG CDC71",138 ,0)
  8690    Q
  8691   "RTN","CHG CDC71",139 ,0)
  8692    ;
  8693   "RTN","CHG CDC71",140 ,0)
  8694   SET S:'$D( ^TMP($J,"C CD",CHCLM, CHTYPE,"HI ST",JX)) ^ (JX)=CHDZH S_U_CHHSDT
  8695   "RTN","CHG CDC71",141 ,0)
  8696    S ^TMP($J ,"CCD",CHC LM,CHTYPE, "HIST",JX, SUB,X)=PC_ U_LABEL
  8697   "RTN","CHG CDC71",142 ,0)
  8698    Q
  8699   "RTN","CHG CDC75")
  8700   0^14^B2936 5743
  8701   "RTN","CHG CDC75",1,0 )
  8702   CHGCDC75 ; CVA/RLC;CC D INITIAL  INPUT DATA  CALC-MODU LE 7 - ALL  OTHER TOS  ;Feb 05,  2019@10:35 :47
  8703   "RTN","CHG CDC75",2,0 )
  8704    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  8705   "RTN","CHG CDC75",3,0 )
  8706    ;CPTS #11 673* (RLC) , #11832*  (RLC), #15 437* (RLC)
  8707   "RTN","CHG CDC75",4,0 )
  8708    ;PT #1618 2 (Y2K)
  8709   "RTN","CHG CDC75",5,0 )
  8710    ; Y2K - c hgd all 2  dig yr to  4 dig yr
  8711   "RTN","CHG CDC75",6,0 )
  8712    ;DEV00369 8 4/20/201 0 AEB
  8713   "RTN","CHG CDC75",7,0 )
  8714    ;CFS 03/0 7/2018 - D efect 6863 82 Add PL  ZIP.
  8715   "RTN","CHG CDC75",8,0 )
  8716    S (XDOS,H DFN,HBFN)= ""
  8717   "RTN","CHG CDC75",9,0 )
  8718    S CHHSDT= JX,CHHSDT= $$FMTE^XLF DT(CHHSDT, 5),CHDZZ=" ",(HDFN,HB FN,HVEN)=" "
  8719   "RTN","CHG CDC75",10, 0)
  8720    S CHSB=$S (CHTY=1:"I NP-DX",CHT Y=2:"OPT-D X",CHTY=4: "DME-DX",C HTY=5:"DEN -DX",CHTY= 6:"OPT-DX" ,1:"")
  8721   "RTN","CHG CDC75",11, 0)
  8722    S CHSB1=$ S(CHTY=1:" INP-PROC", CHTY=2:"OP T-PROC",CH TY=4:"DME- SUPPLY",CH TY=5:"DEN- PROC",CHTY =6:"OPT-PR OC",1:"")
  8723   "RTN","CHG CDC75",12, 0)
  8724    S:$D(@(GL PAYH_"IVL, 101,JX,99) ")) CHDZZ= $P(@(GLPAY H_"IVL,101 ,JX,99)"), U,1)
  8725   "RTN","CHG CDC75",13, 0)
  8726    S CHDZHS= "UNK"
  8727   "RTN","CHG CDC75",14, 0)
  8728    I CHDZZ'= "" I $D(^V A(200,CHDZ Z,0)) S CH DZHS=$P(^V A(200,CHDZ Z,0),U,2)
  8729   "RTN","CHG CDC75",15, 0)
  8730    S CHDZHS= CHDZHS_"-" _CHDZZ
  8731   "RTN","CHG CDC75",16, 0)
  8732    F SUB=0,1 ,7,9,10,27 ,"COMMON", "DME","INP " D
  8733   "RTN","CHG CDC75",17, 0)
  8734    .K FILE1
  8735   "RTN","CHG CDC75",18, 0)
  8736    .I '$D(@( GLPAYH_"IV L,101,JX,S UB)")) I ' $D(@(GLPAY H_"IVL,101 ,JX,"""_SU B_""")"))  D LABEL Q
  8737   "RTN","CHG CDC75",19, 0)
  8738    .I SUB?1. 2N S FILE1 =@(GLPAYH_ "IVL,101,J X,SUB)")
  8739   "RTN","CHG CDC75",20, 0)
  8740    .E  S FIL E1=@(GLPAY H_"IVL,101 ,JX,"""_SU B_""")")
  8741   "RTN","CHG CDC75",21, 0)
  8742    .I '$D(FI LE1) D LAB EL Q
  8743   "RTN","CHG CDC75",22, 0)
  8744    .S OTHFL= 1
  8745   "RTN","CHG CDC75",23, 0)
  8746    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"HIST ",JX)) ^(J X)=CHDZHS_ U_CHHSDT
  8747   "RTN","CHG CDC75",24, 0)
  8748    .I SUB=0  F X=3,5,7, 8,21,22 S  PC=$P(FILE 1,U,X) D:P C'=""
  8749   "RTN","CHG CDC75",25, 0)
  8750    ..S LABEL =$S(X=5:"P ay Provide r: ",X=7:" Type Servi ce: ",X=8: "DOS: ",1: "")
  8751   "RTN","CHG CDC75",26, 0)
  8752    ..I X=3 S  HVEN=PC
  8753   "RTN","CHG CDC75",27, 0)
  8754    ..I X=5 S :PC=0 PC=" NO" S:PC=1  PC="YES"
  8755   "RTN","CHG CDC75",28, 0)
  8756    ..I X=7 I  $D(^CHMDI C(741002.0 5,PC,0)) S  PC=$P(^CH MDIC(74100 2.05,PC,0) ,U,1)
  8757   "RTN","CHG CDC75",29, 0)
  8758    ..I X=8 S  XDOS=PC,P C=$$FMTE^X LFDT(PC,"5 D")
  8759   "RTN","CHG CDC75",30, 0)
  8760    ..I X=21  S HDFN=PC
  8761   "RTN","CHG CDC75",31, 0)
  8762    ..I X=22  S HBFN=PC
  8763   "RTN","CHG CDC75",32, 0)
  8764    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8765   "RTN","CHG CDC75",33, 0)
  8766    .I SUB=1  F X=7 S PC =$P(FILE1, U,X) D
  8767   "RTN","CHG CDC75",34, 0)
  8768    ..S LABEL ="OHI Paym t: "
  8769   "RTN","CHG CDC75",35, 0)
  8770    ..I PC'=" " S PC=$J( PC,",",2)
  8771   "RTN","CHG CDC75",36, 0)
  8772    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8773   "RTN","CHG CDC75",37, 0)
  8774    .I SUB=7  F X=1,2,5, 6 S PC=$P( FILE1,U,X)  D
  8775   "RTN","CHG CDC75",38, 0)
  8776    ..S LABEL =$S(X=1:"M edicaid Ag ency: ",X= 2:"Medicai d Paid: ", X=5:"PCN/P AN: ",X=6: "Type of B ill: ",1:" ")
  8777   "RTN","CHG CDC75",39, 0)
  8778    ..I X=2 I  PC'="" S  PC=$J(PC," ,",2)
  8779   "RTN","CHG CDC75",40, 0)
  8780    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8781   "RTN","CHG CDC75",41, 0)
  8782    .I SUB=10  F X=21 S  PC=$P(FILE 1,U,X) D:P C'=""
  8783   "RTN","CHG CDC75",42, 0)
  8784    ..S LABEL ="MCCR Rev iew: "
  8785   "RTN","CHG CDC75",43, 0)
  8786    ..S:PC=0  PC="NO" S: PC=1 PC="Y ES"
  8787   "RTN","CHG CDC75",44, 0)
  8788    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8789   "RTN","CHG CDC75",45, 0)
  8790    .I SUB=27  F X=1,2,3  S PC=$P(F ILE1,U,X)  D
  8791   "RTN","CHG CDC75",46, 0)
  8792    ..S LABEL =$S(X=1:"O HI Begin:  ",X=2:"OHI  End: ",X= 3:"OHI Typ e: ",1:"")
  8793   "RTN","CHG CDC75",47, 0)
  8794    ..I (X=1) !(X=2) S P C=$$FMTE^X LFDT(PC,"5 D")
  8795   "RTN","CHG CDC75",48, 0)
  8796    ..I X=3 I  PC I $D(^ CHMDIC(741 002.76,PC, 0)) S PC=$ P(^(0),"^" ,1)
  8797   "RTN","CHG CDC75",49, 0)
  8798    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8799   "RTN","CHG CDC75",50, 0)
  8800    ..I X=3 D  OHI S X=4 ,LABEL="OH I Name: "  S:'$D(OHIF L) PC="N/A "
  8801   "RTN","CHG CDC75",51, 0)
  8802    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8803   "RTN","CHG CDC75",52, 0)
  8804    .I SUB="C OMMON" F X =1,2,3,8 S  PC=$P(FIL E1,U,X) D
  8805   "RTN","CHG CDC75",53, 0)
  8806    ..S LABEL =$S(X=1:"T otal Charg e: ",X=2:" POS: ",X=3 :"Bene Pay mt: ",1:"" )
  8807   "RTN","CHG CDC75",54, 0)
  8808    ..I X=2 I  PC'="" I  $D(^CHMDIC (741002.11 ,PC,0)) S  PC=$P(^CHM DIC(741002 .11,PC,0), U,2),PC=$E (PC,1,15)
  8809   "RTN","CHG CDC75",55, 0)
  8810    ..I X=3 I  PC>0 S PC =$J(PC,"," ,2)
  8811   "RTN","CHG CDC75",56, 0)
  8812    ..I X=3 I  PC'>0 S P C=""
  8813   "RTN","CHG CDC75",57, 0)
  8814    ..I X=8 I  CHTY=1 S  LABEL="DRG : "
  8815   "RTN","CHG CDC75",58, 0)
  8816    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  8817   "RTN","CHG CDC75",59, 0)
  8818    .I SUB="D ME" F X=1  S PC=$P(FI LE1,U,X) D
  8819   "RTN","CHG CDC75",60, 0)
  8820    ..S LABEL ="Delivery  Chg: "
  8821   "RTN","CHG CDC75",61, 0)
  8822    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"DMEHST" ,JX)=PC_U_ LABEL
  8823   "RTN","CHG CDC75",62, 0)
  8824    S (BFLAG, VFLAG)=0
  8825   "RTN","CHG CDC75",63, 0)
  8826    D ^CHGCDC 72  ;BENE/ VENDOR DEM OGRAPHICS  INITIAL IN PUT & EDIT S
  8827   "RTN","CHG CDC75",64, 0)
  8828    D ^CHGCDC 76  ;LINE- ITEM DATA  INITIAL IN PUT & EDIT S
  8829   "RTN","CHG CDC75",65, 0)
  8830    S PC="" S  TMPCLPT=0 ,TMPCLPT=$ O(^CHMPAY( "B",CHCLM, TMPCLPT))  I TMPCLPT' ="" I $D(^ CHMPAY(TMP CLPT,7)) S  PC=$P(^CH MPAY(TMPCL PT,7),"^", 8)  ;AEB 7 /19/2010 D EV003698
  8831   "RTN","CHG CDC75",66, 0)
  8832    S CHDZHS= "",CHHSDT= "",SUB=7,X =8,LABEL=" POP1: " D  SET  ;AEB  7/19/2010  DEV003698
  8833   "RTN","CHG CDC75",67, 0)
  8834    S CHRPLZI I=$G(CHRPL ZII) S PC= CHRPLZII,S UB=7,X=15, LABEL="PL  ZIP: " D S ET  ;CFS D efect 6863 82
  8835   "RTN","CHG CDC75",68, 0)
  8836    ;
  8837   "RTN","CHG CDC75",69, 0)
  8838   END K FILE ,FILE1,FIL E2,FILH,FI L0,FIL1,FI L2,FIL3,FI L4,FIL41,F IL22
  8839   "RTN","CHG CDC75",70, 0)
  8840    Q
  8841   "RTN","CHG CDC75",71, 0)
  8842    ;
  8843   "RTN","CHG CDC75",72, 0)
  8844   LABEL I SU B=0 F X=7, 8 S PC=""  D
  8845   "RTN","CHG CDC75",73, 0)
  8846    .S LABEL= $S(X=7:"Ty pe Service : ",X=8:"D OS: ",1:"" )
  8847   "RTN","CHG CDC75",74, 0)
  8848    .I X=8 I  $P(@(GLPAY _"IVL,0)") ,U,7)=1 S  LABEL="Adm ission: "
  8849   "RTN","CHG CDC75",75, 0)
  8850    .D SET
  8851   "RTN","CHG CDC75",76, 0)
  8852    I SUB=1 F  X=7 S PC= "" D
  8853   "RTN","CHG CDC75",77, 0)
  8854    .S LABEL= "OHI Payme nt Hist: "
  8855   "RTN","CHG CDC75",78, 0)
  8856    .D SET
  8857   "RTN","CHG CDC75",79, 0)
  8858    .S @(GLPA YH_"IVL,10 1,JX,SUB)" )=""
  8859   "RTN","CHG CDC75",80, 0)
  8860    I SUB=7 F  X=1,2,5,7  S PC="" D
  8861   "RTN","CHG CDC75",81, 0)
  8862    .S LABEL= $S(X=1:"Me dicaid Age ncy: ",X=2 :"Medicaid  Paid: ",X =5:"PCN/PA N: ",X=7:" Type of Bi ll: ",1:"" )
  8863   "RTN","CHG CDC75",82, 0)
  8864    .D SET
  8865   "RTN","CHG CDC75",83, 0)
  8866    .S @(GLPA YH_"IVL,10 1,JX,SUB)" )=""
  8867   "RTN","CHG CDC75",84, 0)
  8868    I SUB=10  F X=20 S P C="" D
  8869   "RTN","CHG CDC75",85, 0)
  8870    .S LABEL= "MCCR Revi ew: "
  8871   "RTN","CHG CDC75",86, 0)
  8872    .D SET
  8873   "RTN","CHG CDC75",87, 0)
  8874    I SUB=27  D OHI F X= 1,2,3 S PC ="" D
  8875   "RTN","CHG CDC75",88, 0)
  8876    .S LABEL= $S(X=1:"OH I Begin: " ,X=2:"OHI  End: ",X=3 :"OHI Type : ",1:"")
  8877   "RTN","CHG CDC75",89, 0)
  8878    .I X=1 S  PC=CHOHBHS ,PC=$$FMTE ^XLFDT(PC, "5D") D SE T Q
  8879   "RTN","CHG CDC75",90, 0)
  8880    .I X=2 S  PC=CHOHEHS ,PC=$$FMTE ^XLFDT(PC, "5D") D SE T Q
  8881   "RTN","CHG CDC75",91, 0)
  8882    .I X=3 S  PC=CHOHTHS  D SET
  8883   "RTN","CHG CDC75",92, 0)
  8884    .S X=4,LA BEL="OHI N ame: ",PC= CHOHNAM D  SET
  8885   "RTN","CHG CDC75",93, 0)
  8886    I SUB="CO MMON" F X= 1,2,3,8 S  PC="" D
  8887   "RTN","CHG CDC75",94, 0)
  8888    .S LABEL= $S(X=1:"To tal Charge : ",X=2:"P OS: ",X=3: "Bene Paym t: ",1:"")
  8889   "RTN","CHG CDC75",95, 0)
  8890    .I X=8 I  CHTY=1 S L ABEL="DRG:  "
  8891   "RTN","CHG CDC75",96, 0)
  8892    .D SET
  8893   "RTN","CHG CDC75",97, 0)
  8894    .S @(GLPA YH_"IVL,10 1,JX,SUB)" )=""
  8895   "RTN","CHG CDC75",98, 0)
  8896    I SUB="DM E" F X=1 S  PC="" D
  8897   "RTN","CHG CDC75",99, 0)
  8898    .S LABEL= "Delivery  Chg: "
  8899   "RTN","CHG CDC75",100 ,0)
  8900    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"DMEH ST",JX)) ^ (JX)=CHDZH S_U_CHHSDT
  8901   "RTN","CHG CDC75",101 ,0)
  8902    .S ^TMP($ J,"CCD",CH CLM,CHTYPE ,"DMEHST", JX)=PC_U_L ABEL
  8903   "RTN","CHG CDC75",102 ,0)
  8904    .D SET
  8905   "RTN","CHG CDC75",103 ,0)
  8906    Q
  8907   "RTN","CHG CDC75",104 ,0)
  8908    ;
  8909   "RTN","CHG CDC75",105 ,0)
  8910   OHI S (CHO HBHS,CHOHE HS,CHOHS,C HOHTHS,CHO HNAM)=""
  8911   "RTN","CHG CDC75",106 ,0)
  8912    Q:(HDFN=" ")!(HBFN=" ")!(XDOS=" ")
  8913   "RTN","CHG CDC75",107 ,0)
  8914    S IVAL=0
  8915   "RTN","CHG CDC75",108 ,0)
  8916   O1 S IVAL= $O(@(GLDFN _"""B"",HD FN,IVAL)") ) Q:'IVAL
  8917   "RTN","CHG CDC75",109 ,0)
  8918    S JVAL=0
  8919   "RTN","CHG CDC75",110 ,0)
  8920   O2 S JVAL= $O(@(GLDFN _"IVAL,100 ,""B"",HBF N,JVAL)"))  G:'JVAL O 1
  8921   "RTN","CHG CDC75",111 ,0)
  8922    G:'$D(@(G LDFN_"IVAL ,100,JVAL, 2)")) O2
  8923   "RTN","CHG CDC75",112 ,0)
  8924    S KVAL=XD OS
  8925   "RTN","CHG CDC75",113 ,0)
  8926   O3 S KVAL= $O(@(GLDFN _"IVAL,100 ,JVAL,2,"" B"",KVAL)" ),-1) G:'K VAL O2
  8927   "RTN","CHG CDC75",114 ,0)
  8928    S K1=0
  8929   "RTN","CHG CDC75",115 ,0)
  8930   O4 S K1=$O (@(GLDFN_" IVAL,100,J VAL,2,""B" ",KVAL,K1) ")) G:'K1  O3
  8931   "RTN","CHG CDC75",116 ,0)
  8932    G:'$D(@(G LDFN_"IVAL ,100,JVAL, 2,K1,0)"))  O3
  8933   "RTN","CHG CDC75",117 ,0)
  8934    S ORC=@(G LDFN_"IVAL ,100,JVAL, 2,K1,0)")
  8935   "RTN","CHG CDC75",118 ,0)
  8936    S CHOHBHS =$P(ORC,U, 1),CHOHEHS =$P(ORC,U, 2),CHOHS=$ P(ORC,U,3)
  8937   "RTN","CHG CDC75",119 ,0)
  8938    S CHOHNAM =$P(ORC,U, 7)
  8939   "RTN","CHG CDC75",120 ,0)
  8940    I CHOHS I  $D(^CHMDI C(741002.7 6,CHOHS,0) ) S CHOHTH S=$P(^(0), U,1)
  8941   "RTN","CHG CDC75",121 ,0)
  8942    S:CHOHNAM ="" CHOHNA M="N/A" S  CHOHNAM=$E (CHOHNAM,1 ,20)
  8943   "RTN","CHG CDC75",122 ,0)
  8944    Q
  8945   "RTN","CHG CDC75",123 ,0)
  8946    ;
  8947   "RTN","CHG CDC75",124 ,0)
  8948   SET S:'$D( ^TMP($J,"C CD",CHCLM, CHTYPE,"HI ST",JX)) ^ (JX)=CHDZH S_U_CHHSDT
  8949   "RTN","CHG CDC75",125 ,0)
  8950    S ^TMP($J ,"CCD",CHC LM,CHTYPE, "HIST",JX, SUB,X)=PC_ U_LABEL
  8951   "RTN","CHG CDC75",126 ,0)
  8952    Q
  8953   "RTN","CHG CDP7")
  8954   0^15^B7018 2755
  8955   "RTN","CHG CDP7",1,0)
  8956   CHGCDP7 ;C VA/RLC;CCD  INIT INPU T/EDIT HIS TORY-MODUL E 7 PRINT  - INPATIEN T ;Feb 05,  2019@10:3 6:58
  8957   "RTN","CHG CDP7",2,0)
  8958    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  8959   "RTN","CHG CDP7",3,0)
  8960    ;CPTS #11 673* (RLC) , #11832*  (RLC), #15 437* (RLC)
  8961   "RTN","CHG CDP7",4,0)
  8962    ; PT #161 82 (Y2K)
  8963   "RTN","CHG CDP7",5,0)
  8964    ;DEV01938 8  EW  11/ 13/13 POA  AND PL PHO NE
  8965   "RTN","CHG CDP7",6,0)
  8966    ;CPE001-0 04 WTC 6/2 6/17
  8967   "RTN","CHG CDP7",7,0)
  8968    I CHTYPE' =1 D ^CHGC DP70 G END
  8969   "RTN","CHG CDP7",8,0)
  8970    S U="^",( JX,CHFL)=0  F Z=1:1:2 0 S ARRAY( Z)="" ; CH ANGED 19 T O 20 WTC 6 /26/17
  8971   "RTN","CHG CDP7",9,0)
  8972   A1 S JX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX))  G:JX="" EN D
  8973   "RTN","CHG CDP7",10,0 )
  8974    S RCZ=^(J X) K HDFL
  8975   "RTN","CHG CDP7",11,0 )
  8976    S CHDZHS= $P(RCZ,U,1 ),CHHSDT=$ P(RCZ,U,2)
  8977   "RTN","CHG CDP7",12,0 )
  8978    D:CHFL=0  HEADING
  8979   "RTN","CHG CDP7",13,0 )
  8980    D:CHFL=1  HDG
  8981   "RTN","CHG CDP7",14,0 )
  8982    I CHFL=0  W !!,"Date : ",CHHSDT ,?32,"VE:  ",CHDZHS W  !
  8983   "RTN","CHG CDP7",15,0 )
  8984    S SUB=""
  8985   "RTN","CHG CDP7",16,0 )
  8986   A2 S SUB=$ O(^TMP($J, "CCD",CHCL M,CHTYPE," HIST",JX,S UB)) I SUB ="" D PRIN T D:CHFL=0  BINIT,VIN IT D LOOP^ CHGCDP72,D EMO S CHFL =CHFL+1 G  A1
  8987   "RTN","CHG CDP7",17,0 )
  8988    S XX=0
  8989   "RTN","CHG CDP7",18,0 )
  8990   A3 S XX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX,SU B,XX)) G:X X="" A2
  8991   "RTN","CHG CDP7",19,0 )
  8992    S RCZZ=^( XX)
  8993   "RTN","CHG CDP7",20,0 )
  8994    I CHFL=0  D BLDII^CH GCDP71 G A 3
  8995   "RTN","CHG CDP7",21,0 )
  8996    I ('$D(HD FL))&(CHFL >0) D HD1  S HDFL=1
  8997   "RTN","CHG CDP7",22,0 )
  8998    S PC=$P(R CZZ,U,1),L ABEL=$P(RC ZZ,U,2)
  8999   "RTN","CHG CDP7",23,0 )
  9000    D ARRIPT^ CHGCDP71
  9001   "RTN","CHG CDP7",24,0 )
  9002    G A3
  9003   "RTN","CHG CDP7",25,0 )
  9004    ;
  9005   "RTN","CHG CDP7",26,0 )
  9006   DEMO S LNF LG=0
  9007   "RTN","CHG CDP7",27,0 )
  9008    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"BENE-D D")) D BEN DD S LNFLG =1
  9009   "RTN","CHG CDP7",28,0 )
  9010    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"PSEUDO -DD")) D P SVNDD S LN FLG=1
  9011   "RTN","CHG CDP7",29,0 )
  9012    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-DD ")) D VEND D S LNFLG= 1
  9013   "RTN","CHG CDP7",30,0 )
  9014    Q
  9015   "RTN","CHG CDP7",31,0 )
  9016    ;
  9017   "RTN","CHG CDP7",32,0 )
  9018   HEADING W  !!,?20,"// ////////", ?33,"INITI AL INPUT", ?49,"///// /////"
  9019   "RTN","CHG CDP7",33,0 )
  9020    Q
  9021   "RTN","CHG CDP7",34,0 )
  9022   HDG W !!,? 20,"////// ////",?34, "EDIT HIST ORY",?49," ////////// "
  9023   "RTN","CHG CDP7",35,0 )
  9024    Q
  9025   "RTN","CHG CDP7",36,0 )
  9026    ;
  9027   "RTN","CHG CDP7",37,0 )
  9028   HD1 I CHFL =0 W ! S C HFL=1
  9029   "RTN","CHG CDP7",38,0 )
  9030    I LNFLG=1  W ! S LNF LG=0
  9031   "RTN","CHG CDP7",39,0 )
  9032    W !!,"Dat e: ",CHHSD T,?28,"Use r: ",CHDZH S W !
  9033   "RTN","CHG CDP7",40,0 )
  9034    Q
  9035   "RTN","CHG CDP7",41,0 )
  9036    ;
  9037   "RTN","CHG CDP7",42,0 )
  9038   PRINT S (Z ,TAB,CHCHG HS)=0,CNTR =1 K XTMP
  9039   "RTN","CHG CDP7",43,0 )
  9040   PR1 S Z=$O (ARRAY(Z))  I Z="" D: $D(LABEL)  CHK K ARRA Y,LABEL,PC ,Z,CNTR,TA B Q
  9041   "RTN","CHG CDP7",44,0 )
  9042    S LABEL=$ P(ARRAY(Z) ,U,1),PC=$ P(ARRAY(Z) ,U,2)
  9043   "RTN","CHG CDP7",45,0 )
  9044    G:LABEL=" " PR1
  9045   "RTN","CHG CDP7",46,0 )
  9046    I LABEL=" PL ZIP: "  D  G PR1 ;  WTC 6/26/ 17
  9047   "RTN","CHG CDP7",47,0 )
  9048    . W LABEL ,PC,! ;
  9049   "RTN","CHG CDP7",48,0 )
  9050    . K LABEL ,PC ; WTC
  9051   "RTN","CHG CDP7",49,0 )
  9052    I LABEL=" Total Char ge: " D  G  PR1
  9053   "RTN","CHG CDP7",50,0 )
  9054    .S CHCHGH S=PC
  9055   "RTN","CHG CDP7",51,0 )
  9056    .K LABEL, PC
  9057   "RTN","CHG CDP7",52,0 )
  9058    I LABEL=" Medicaid A gency: " K  XTEMP D   G PR1
  9059   "RTN","CHG CDP7",53,0 )
  9060    .S (CHMDN M,MTAX,CHM DTX,MDAD,M DMD,MAD1,M AD2,MCTY,M ST,MSTP,MZ IP)=""
  9061   "RTN","CHG CDP7",54,0 )
  9062    .Q:'$D(PC )  Q:PC=""
  9063   "RTN","CHG CDP7",55,0 )
  9064    .S RC=^CH MVEN(PC,0)
  9065   "RTN","CHG CDP7",56,0 )
  9066    .S CHMDNM =$P(RC,U,1 ),MTAX=$P( RC,U,3),MD AD=$P(RC,U ,23)
  9067   "RTN","CHG CDP7",57,0 )
  9068    .S:MDAD=" " MDAD="   "
  9069   "RTN","CHG CDP7",58,0 )
  9070    .S:$D(^CH MVEN(PC,14 )) MDMD=$P (^(14),U,1 )
  9071   "RTN","CHG CDP7",59,0 )
  9072    .S:MDMD=" " MDMD="   "
  9073   "RTN","CHG CDP7",60,0 )
  9074    .S CHMDTX =MTAX_"-"_ MDAD_"-"_M DMD
  9075   "RTN","CHG CDP7",61,0 )
  9076    .I $D(^CH MVEN(PC,1) ) S RC=^(1 ) D
  9077   "RTN","CHG CDP7",62,0 )
  9078    ..S MAD1= $P(RC,U,1) ,MAD2=$P(R C,U,2),MCT Y=$P(RC,U, 3)
  9079   "RTN","CHG CDP7",63,0 )
  9080    ..S MST=$ P(RC,U,4), MZIP=$P(RC ,U,5)
  9081   "RTN","CHG CDP7",64,0 )
  9082    ..I MST'= "" I $D(^D IC(5,MST,0 )) S MSTP= $P(^(0),U, 2)
  9083   "RTN","CHG CDP7",65,0 )
  9084    ..Q
  9085   "RTN","CHG CDP7",66,0 )
  9086    .S XTEMP( CHMDNM)=CH MDTX_U_MAD 1_U_MAD2_U _MCTY_U_MS TP_U_MZIP
  9087   "RTN","CHG CDP7",67,0 )
  9088    .Q
  9089   "RTN","CHG CDP7",68,0 )
  9090    I LABEL=" Medicaid P aid: " S T AB=0,RC=""  D  G PR1
  9091   "RTN","CHG CDP7",69,0 )
  9092    .S CHMDNM =""
  9093   "RTN","CHG CDP7",70,0 )
  9094    .S CHMDNM =$O(XTEMP( CHMDNM)) Q :CHMDNM=""
  9095   "RTN","CHG CDP7",71,0 )
  9096    .S RC=XTE MP(CHMDNM)
  9097   "RTN","CHG CDP7",72,0 )
  9098    .S CHMDTX =$P(RC,U,1 ),MAD1=$P( RC,U,2),MA D2=$P(RC,U ,3)
  9099   "RTN","CHG CDP7",73,0 )
  9100    .S MCTY=$ P(RC,U,4), MSTP=$P(RC ,U,5),MZIP =$P(RC,U,6 )
  9101   "RTN","CHG CDP7",74,0 )
  9102    .W "Medic aid TIN: " ,CHMDTX S  TAB=TAB+32
  9103   "RTN","CHG CDP7",75,0 )
  9104    .W ?TAB,L ABEL,PC
  9105   "RTN","CHG CDP7",76,0 )
  9106    .W !,"Med icaid Agen cy: ",CHMD NM
  9107   "RTN","CHG CDP7",77,0 )
  9108    .W !,"Add r1: ",MAD1
  9109   "RTN","CHG CDP7",78,0 )
  9110    .W !,"Add r2: ",MAD2
  9111   "RTN","CHG CDP7",79,0 )
  9112    .W !,"Cit y: ",MCTY, "    State : ",MSTP,"     Zip: " ,MZIP
  9113   "RTN","CHG CDP7",80,0 )
  9114    .S TAB=0, CNTR=1 W !
  9115   "RTN","CHG CDP7",81,0 )
  9116    .Q
  9117   "RTN","CHG CDP7",82,0 )
  9118    I LABEL=" Admitting  DX: " I CH FL=0 S XTM P(LABEL)=P C G PR1
  9119   "RTN","CHG CDP7",83,0 )
  9120   PR2 W ?TAB ,LABEL,PC
  9121   "RTN","CHG CDP7",84,0 )
  9122    I LABEL=" Fac Discha rged to: "  I CHFL=0  D GTEDI
  9123   "RTN","CHG CDP7",85,0 )
  9124    I CNTR=1  S TAB=TAB+ 32,CNTR=CN TR+1 G PR1
  9125   "RTN","CHG CDP7",86,0 )
  9126    I CNTR=2  S TAB=TAB+ 24,CNTR=CN TR+1 G PR1
  9127   "RTN","CHG CDP7",87,0 )
  9128    I CNTR=3  I $O(ARRAY (Z)) S TAB =0,CNTR=1  W !
  9129   "RTN","CHG CDP7",88,0 )
  9130   PR3 G PR1
  9131   "RTN","CHG CDP7",89,0 )
  9132    ;
  9133   "RTN","CHG CDP7",90,0 )
  9134   CHK Q:(LAB EL="MCCR R eview: ")! (LABEL="Be ne Paymt:  ")
  9135   "RTN","CHG CDP7",91,0 )
  9136    I (CNTR<3 )!(CNTR=4)  W ! Q
  9137   "RTN","CHG CDP7",92,0 )
  9138    W:LABEL=" Bene: " !
  9139   "RTN","CHG CDP7",93,0 )
  9140    Q
  9141   "RTN","CHG CDP7",94,0 )
  9142    ;
  9143   "RTN","CHG CDP7",95,0 )
  9144   GTEDI S (C HSTMTP,CHA DMHR,CHDIS HR,CHRELCS 1,CHRELCS2 ,CHRELCS3) =""
  9145   "RTN","CHG CDP7",96,0 )
  9146    Q:'$D(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","AA"))
  9147   "RTN","CHG CDP7",97,0 )
  9148    S EREC=^T MP($J,"CCD ",CHCLM,CH TYPE,"EDI- II","AA")
  9149   "RTN","CHG CDP7",98,0 )
  9150    S CHSTMTP =$P(EREC,U ,1),CHADMH R=$P(EREC, U,2),CHDIS HR=$P(EREC ,U,3)
  9151   "RTN","CHG CDP7",99,0 )
  9152    S CHRELCS 1=$P(EREC, U,4),CHREL CS2=$P(ERE C,U,5),CHR ELCS3=$P(E REC,U,6)
  9153   "RTN","CHG CDP7",100, 0)
  9154    W !,"Stat ement Cove rage Perio d: ",CHSTM TP
  9155   "RTN","CHG CDP7",101, 0)
  9156    W !,"Admi ssion Hour : ",CHADMH R,?32,"Dis charge Hou r: ",CHDIS HR
  9157   "RTN","CHG CDP7",102, 0)
  9158    Q
  9159   "RTN","CHG CDP7",103, 0)
  9160    ;
  9161   "RTN","CHG CDP7",104, 0)
  9162   BINIT Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," BEN-II"))
  9163   "RTN","CHG CDP7",105, 0)
  9164    S RCX=^(" BEN-II")
  9165   "RTN","CHG CDP7",106, 0)
  9166    S CHBNAM= $P(RCX,U,1 ),CHBSSN=$ P(RCX,U,2) ,CHBNDOB=$ P(RCX,U,3) ,CHBNREL=$ P(RCX,U,4) ,CHBNAD1=$ P(RCX,U,5) ,CHBNAD2=$ P(RCX,U,6) ,CHBNCTY=$ P(RCX,U,7) ,CHBNST=$P (RCX,U,8), CHBNZIP=$P (RCX,U,9), CHBSEX=$P( RCX,U,10), CHBAGE=$P( RCX,U,11)
  9167   "RTN","CHG CDP7",107, 0)
  9168    W !,"Pati ent: ",CHB NAM,?42,"S SN: ",CHBS SN
  9169   "RTN","CHG CDP7",108, 0)
  9170    W !,"DOB:  ",CHBNDOB ,?18,"Age:  ",CHBAGE, ?30,"Sex:  ",CHBSEX,? 42,"Relati onship: ", CHBNREL
  9171   "RTN","CHG CDP7",109, 0)
  9172    W !,"Addr 1: ",CHBNA D1
  9173   "RTN","CHG CDP7",110, 0)
  9174    W !,"Addr 2: ",CHBNA D2
  9175   "RTN","CHG CDP7",111, 0)
  9176    W !,"City : ",CHBNCT Y,?28,"Sta te: ",CHBN ST,?50,"Zi p: ",CHBNZ IP
  9177   "RTN","CHG CDP7",112, 0)
  9178    Q
  9179   "RTN","CHG CDP7",113, 0)
  9180    ;
  9181   "RTN","CHG CDP7",114, 0)
  9182   BENDD Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," BENE-DD"))
  9183   "RTN","CHG CDP7",115, 0)
  9184    I CHFL=0  D HDG W !
  9185   "RTN","CHG CDP7",116, 0)
  9186    S DT1=""
  9187   "RTN","CHG CDP7",117, 0)
  9188   BD1 S DT1= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "BENE-DD", DT1)) I 'D T1 K ^TMP( $J,"CCD",C HCLM,CHTYP E,"BENE-DD ") S CHFL= 1 Q
  9189   "RTN","CHG CDP7",118, 0)
  9190    S RCDD=^( DT1,0)
  9191   "RTN","CHG CDP7",119, 0)
  9192    S CHDDZ=$ P(RCDD,U,1 ),CHDDNM=" UNK"
  9193   "RTN","CHG CDP7",120, 0)
  9194    I CHDDZ'= "" I $D(^V A(200,CHDD Z,0)) S CH DDNM=$P(^V A(200,CHDD Z,0),U,2)
  9195   "RTN","CHG CDP7",121, 0)
  9196    S CHDDNM= CHDDNM_"-" _CHDDZ
  9197   "RTN","CHG CDP7",122, 0)
  9198    W:CHFL=1  !
  9199   "RTN","CHG CDP7",123, 0)
  9200    ; Y2K - c hanged all  2 digit y ear displa ys to 4 di git years
  9201   "RTN","CHG CDP7",124, 0)
  9202    W !,"Date : ",$$FMTE ^XLFDT(DT1 ,5),?28,"B ene Data", ?50,"User:  ",CHDDNM
  9203   "RTN","CHG CDP7",125, 0)
  9204    S DCT=0
  9205   "RTN","CHG CDP7",126, 0)
  9206   BD2 S DCT= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "BENE-DD", DT1,DCT))  I 'DCT S C HFL=1 G BD 1
  9207   "RTN","CHG CDP7",127, 0)
  9208    S RCDE=^( DCT)
  9209   "RTN","CHG CDP7",128, 0)
  9210    S PIC=$P( RCDE,U,1), LAB=$P(RCD E,U,2)
  9211   "RTN","CHG CDP7",129, 0)
  9212    I LAB="St ate: " S P IC=$P(^DIC (5,PIC,0), U,2)
  9213   "RTN","CHG CDP7",130, 0)
  9214    I LAB="DO B: " S PIC =$$FMTE^XL FDT(PIC,"5 D")
  9215   "RTN","CHG CDP7",131, 0)
  9216    I LAB="Re lationship : " S PIC= $S(PIC="S" :"SPOUSE", PIC="C":"C HILD",PIC= "XS":"EX-S POUSE",1:" ")
  9217   "RTN","CHG CDP7",132, 0)
  9218    W !,LAB,P IC
  9219   "RTN","CHG CDP7",133, 0)
  9220    G BD2
  9221   "RTN","CHG CDP7",134, 0)
  9222    ;
  9223   "RTN","CHG CDP7",135, 0)
  9224   VINIT S (R TC,RPC)=""
  9225   "RTN","CHG CDP7",136, 0)
  9226    S:$D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-II ","RT-VEN" )) RTC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"VEN-I I","RT-VEN ")
  9227   "RTN","CHG CDP7",137, 0)
  9228    S:$D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-II ","PL-VEN" )) RPC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"VEN-I I","PL-VEN ")
  9229   "RTN","CHG CDP7",138, 0)
  9230    I RTC=""  D  G VIN
  9231   "RTN","CHG CDP7",139, 0)
  9232    .S (CHVEN RI,CHTAXIP ,CHVADR1,C HVADR2,CHV ADRCY,CHRS TP,CHVNRZP )=""
  9233   "RTN","CHG CDP7",140, 0)
  9234    .S (CHVPH S,CHVNPHN, CHVPGHS)=" "
  9235   "RTN","CHG CDP7",141, 0)
  9236    .Q
  9237   "RTN","CHG CDP7",142, 0)
  9238    S CHVENRI =$P(RTC,U, 1),CHTAXIP =$P(RTC,U, 2),CHVADR1 =$P(RTC,U, 3)
  9239   "RTN","CHG CDP7",143, 0)
  9240    S CHVADR2 =$P(RTC,U, 4),CHVADRC Y=$P(RTC,U ,5),CHRSTP =$P(RTC,U, 6)
  9241   "RTN","CHG CDP7",144, 0)
  9242    S CHVNRZP =$P(RTC,U, 7),CHVNPHN =$P(RTC,U, 8)  ;DEV01 9388  EW   11/13/13
  9243   "RTN","CHG CDP7",145, 0)
  9244   VIN I RPC= "" D  G VI NP
  9245   "RTN","CHG CDP7",146, 0)
  9246    .S (CHVEN PI,CHVADP1 ,CHVADP2,C HVADPCY,CH PSTP,CHVNP ZP,CHVPGHS ,CHCMACII) =""
  9247   "RTN","CHG CDP7",147, 0)
  9248    .S (CHCMA CII,CHTAXI P,CHVNPHN, CHVPOA,CHV PPPN)=""   ;DEV019388   EW  11/1 3/13
  9249   "RTN","CHG CDP7",148, 0)
  9250    .Q
  9251   "RTN","CHG CDP7",149, 0)
  9252    S CHVENPI =$P(RPC,U, 1),CHVADP1 =$P(RPC,U, 2),CHVADP2 =$P(RPC,U, 3)
  9253   "RTN","CHG CDP7",150, 0)
  9254    S CHVADPC Y=$P(RPC,U ,4),CHPSTP =$P(RPC,U, 5),CHVNPZP =$P(RPC,U, 6)
  9255   "RTN","CHG CDP7",151, 0)
  9256    S CHVPPPN =$P(RPC,U, 7),CHVPOA= $P(RPC,U,8 ),CHCMACII =$P(RPC,U, 9)  ;DEV01 9388  EW   11/13/13
  9257   "RTN","CHG CDP7",152, 0)
  9258   VINP W !!, "Tax ID: " ,CHTAXIP,? 32,"Ven PO A Exmpt: " ,CHVPOA,?5 5,"CMAC: " ,CHCMACII   ;DEV01938 8  EW  11/ 13/13
  9259   "RTN","CHG CDP7",153, 0)
  9260    W !,"RT V en: ",CHVE NRI,?40,"P L Ven: ",C HVENPI
  9261   "RTN","CHG CDP7",154, 0)
  9262    W !,"Phon e: ",CHVNP HN,?40,"Ph one: ",CHV PPPN  ;DEV 019388  EW   11/13/13
  9263   "RTN","CHG CDP7",155, 0)
  9264    W !,"Addr 1: ",CHVAD R1,?40,"Ad dr1: ",CHV ADP1
  9265   "RTN","CHG CDP7",156, 0)
  9266    W !,"Addr 2: ",CHVAD R2,?40,"Ad dr2: ",CHV ADP2
  9267   "RTN","CHG CDP7",157, 0)
  9268    W !,"City : ",CHVADR CY,?40,"Ci ty: ",CHVA DPCY
  9269   "RTN","CHG CDP7",158, 0)
  9270    W !,"Stat e: ",CHRST P,"   Zip:  ",CHVNRZP ,?40,"Stat e: ",CHPST P,"   Zip:  ",CHVNPZP
  9271   "RTN","CHG CDP7",159, 0)
  9272    Q
  9273   "RTN","CHG CDP7",160, 0)
  9274    ;
  9275   "RTN","CHG CDP7",161, 0)
  9276   VENDD Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," VEN-DD"))
  9277   "RTN","CHG CDP7",162, 0)
  9278    I CHFL=0  D HDG W !
  9279   "RTN","CHG CDP7",163, 0)
  9280    S CHVDT=" "
  9281   "RTN","CHG CDP7",164, 0)
  9282   VD1 S CHVD T=$O(^TMP( $J,"CCD",C HCLM,CHTYP E,"VEN-DD" ,CHVDT)) I  'CHVDT K  ^TMP($J,"C CD",CHCLM, CHTYPE,"VE N-DD") S C HFL=1 Q
  9283   "RTN","CHG CDP7",165, 0)
  9284    S RCDF=^( CHVDT,0)
  9285   "RTN","CHG CDP7",166, 0)
  9286    S CHVENDZ =$P(RCDF,U ,1),CHVDNM ="UNK"
  9287   "RTN","CHG CDP7",167, 0)
  9288    I CHVENDZ '="" I $D( ^VA(200,CH VENDZ,0))  S CHVDNM=$ P(^VA(200, CHVENDZ,0) ,U,2)
  9289   "RTN","CHG CDP7",168, 0)
  9290    S CHVDNM= CHVDNM_"-" _CHVENDZ
  9291   "RTN","CHG CDP7",169, 0)
  9292    W:CHFL=1  !
  9293   "RTN","CHG CDP7",170, 0)
  9294    W !,"Date : ",$$FMTE ^XLFDT(CHV DT,5),?28, "Vendor Da ta",?50,"U ser: ",CHV DNM
  9295   "RTN","CHG CDP7",171, 0)
  9296    S VCT=0
  9297   "RTN","CHG CDP7",172, 0)
  9298   VD2 S VCT= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "VEN-DD",C HVDT,VCT))  I VCT=""  S:CHFL=0 C HFL=1 G VD 1
  9299   "RTN","CHG CDP7",173, 0)
  9300    S RCDG=^( VCT)
  9301   "RTN","CHG CDP7",174, 0)
  9302    S PIZ=$P( RCDG,U,1), LABL=$P(RC DG,U,2)
  9303   "RTN","CHG CDP7",175, 0)
  9304    I LABL="S tate: " S  PIZ=$P(^DI C(5,PIZ,0) ,U,2)
  9305   "RTN","CHG CDP7",176, 0)
  9306    W !,LABL, PIZ
  9307   "RTN","CHG CDP7",177, 0)
  9308    G VD2
  9309   "RTN","CHG CDP7",178, 0)
  9310   PSVNDD Q:' $D(^TMP($J ,"CCD",CHC LM,CHTYPE, "PSEUDO-DD "))
  9311   "RTN","CHG CDP7",179, 0)
  9312    I CHFL=0  D HDG W !
  9313   "RTN","CHG CDP7",180, 0)
  9314    S CHPDT=" "
  9315   "RTN","CHG CDP7",181, 0)
  9316   PSV1 S CHP DT=$O(^TMP ($J,"CCD", CHCLM,CHTY PE,"PSEUDO -DD",CHPDT )) I 'CHPD T K ^TMP($ J,"CCD",CH CLM,CHTYPE ,"PSEUDO-D D") S CHFL =1 Q
  9317   "RTN","CHG CDP7",182, 0)
  9318    S RCP=^(C HPDT,0)
  9319   "RTN","CHG CDP7",183, 0)
  9320    S CHVENDZ =$P(RCP,U, 1),CHVDNM= "UNK"
  9321   "RTN","CHG CDP7",184, 0)
  9322    I CHVENDZ '="" I $D( ^VA(200,CH VENDZ,0))  S CHVDNM=$ P(^VA(200, CHVENDZ,0) ,U,2)
  9323   "RTN","CHG CDP7",185, 0)
  9324    S CHVDNM= CHVDNM_"-" _CHVENDZ
  9325   "RTN","CHG CDP7",186, 0)
  9326    W:CHFL=1  !
  9327   "RTN","CHG CDP7",187, 0)
  9328    W !,"Date : ",$$FMTE ^XLFDT(CHP DT,5),?28, "Pseudo Ve ndor Data" ,?50,"User : ",CHVDNM
  9329   "RTN","CHG CDP7",188, 0)
  9330    S VCT=0
  9331   "RTN","CHG CDP7",189, 0)
  9332   PSV2 S VCT =$O(^TMP($ J,"CCD",CH CLM,CHTYPE ,"PSEUDO-D D",CHPDT,V CT)) I VCT ="" S:CHFL =0 CHFL=1  G PSV1
  9333   "RTN","CHG CDP7",190, 0)
  9334    S RCDG=^( VCT)
  9335   "RTN","CHG CDP7",191, 0)
  9336    S PIZ=$P( RCDG,U,1), LABL=$P(RC DG,U,2)
  9337   "RTN","CHG CDP7",192, 0)
  9338    I LABL="S tate: " S  PIZ=$P(^DI C(5,PIZ,0) ,U,2)
  9339   "RTN","CHG CDP7",193, 0)
  9340    W !,LABL, PIZ
  9341   "RTN","CHG CDP7",194, 0)
  9342    G PSV2
  9343   "RTN","CHG CDP7",195, 0)
  9344   END K ARRA Y,BFL,VFL, CHACSTHS,C HADXHS,CHA NESHS,CHAN SHS,CHBNAD 1,CHBNAD2
  9345   "RTN","CHG CDP7",196, 0)
  9346    K CHBNAM, CHBNCTY,CH BNDOB,CHBN REL,CHDDZ, CHDISHS,CH DTED,CHDXH S,CHDZHS
  9347   "RTN","CHG CDP7",197, 0)
  9348    K CHFACHS ,CHFL,CHHS DT,CHIDTHS ,CHITAMHS, CHITEMHS,C HN,CHNAMTH S,CHNCSTHS
  9349   "RTN","CHG CDP7",198, 0)
  9350    K CHNTEMH S,CHPLHS,C HPNCHS,CHP RCHS,CHPSC DHS,CHRC,C HRMDYHS,CH RMRTHS,CHR X
  9351   "RTN","CHG CDP7",199, 0)
  9352    K CHRTPHS ,CHRZ,CHST ATHS,CHTXD D,CHVADD1, CHVADD2,CH VDDST,CHVD NM,CHVENDT
  9353   "RTN","CHG CDP7",200, 0)
  9354    K CHVENDZ ,CHVNCTY,C HVNDD,CHVN ST,CHVNZIP ,CNT,CNTR, CT,DCT,FMT E,PXFLG
  9355   "RTN","CHG CDP7",201, 0)
  9356    K LAB,LAB EL,LABL,NC T,PC,PIC,P IZ,PX,RCDD ,RCDE,RCDF ,RCDG,RCX, RCZ,RCZZ
  9357   "RTN","CHG CDP7",202, 0)
  9358    K SUB,TAB ,VCT,X,XCT ,XNT,Y,Z,Z CT,ZNT
  9359   "RTN","CHG CDP7",203, 0)
  9360    Q
  9361   "RTN","CHG CDP70")
  9362   0^16^B6967 2244
  9363   "RTN","CHG CDP70",1,0 )
  9364   CHGCDP70 ; CVA/RLC;CC D INIT INP UT/EDIT HI STORY-MODU LE 7 PRINT -ALL OTHER  TOS ;Feb  05, 2019@1 0:38:21
  9365   "RTN","CHG CDP70",2,0 )
  9366    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  9367   "RTN","CHG CDP70",3,0 )
  9368    ;CPTS #11 673* (RLC) , #11832*  (RLC), #15 437* (RLC)
  9369   "RTN","CHG CDP70",4,0 )
  9370    ; PT #161 82 (Y2K)
  9371   "RTN","CHG CDP70",5,0 )
  9372    ;DEV00369 8 4/20/201 0 AEB
  9373   "RTN","CHG CDP70",6,0 )
  9374    ;DEV01938 8 EW 11/7/ 13  POA
  9375   "RTN","CHG CDP70",7,0 )
  9376    ; CPE001- 004 WTC 6/ 26/17
  9377   "RTN","CHG CDP70",8,0 )
  9378    S U="^",( JX,CHFL)=0  F Z=1:1:1 9 S ARRAY( Z)="" ;
  9379   "RTN","CHG CDP70",9,0 )
  9380   A1 S JX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX))  G:JX="" EN D
  9381   "RTN","CHG CDP70",10, 0)
  9382    S RCZ=^(J X) K HDFL, EDFLG
  9383   "RTN","CHG CDP70",11, 0)
  9384    S CHDZHS= $P(RCZ,U,1 ),CHHSDT=$ P(RCZ,U,2)
  9385   "RTN","CHG CDP70",12, 0)
  9386    D:CHFL=0  HEADING
  9387   "RTN","CHG CDP70",13, 0)
  9388    D:CHFL=1  HDG
  9389   "RTN","CHG CDP70",14, 0)
  9390    I CHFL=0  W !,"Date:  ",CHHSDT, ?32,"VE: " ,CHDZHS W  !
  9391   "RTN","CHG CDP70",15, 0)
  9392    S SUB=""
  9393   "RTN","CHG CDP70",16, 0)
  9394   A2 S SUB=$ O(^TMP($J, "CCD",CHCL M,CHTYPE," HIST",JX,S UB)) I SUB ="" D PRIN T D:CHFL=0  BINIT,VIN IT D LOOP^ CHGCDP73,D EMO S CHFL =CHFL+1 G  A1
  9395   "RTN","CHG CDP70",17, 0)
  9396    S XX=0
  9397   "RTN","CHG CDP70",18, 0)
  9398   A3 S XX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX,SU B,XX)) G:X X="" A2
  9399   "RTN","CHG CDP70",19, 0)
  9400    S RCZZ=^( XX)
  9401   "RTN","CHG CDP70",20, 0)
  9402    I CHFL=0  D BLDII^CH GCDP73 G A 3
  9403   "RTN","CHG CDP70",21, 0)
  9404    I ('$D(HD FL))&(CHFL >0) D HD1  S HDFL=1
  9405   "RTN","CHG CDP70",22, 0)
  9406    S PC=$P(R CZZ,U,1),L ABEL=$P(RC ZZ,U,2)
  9407   "RTN","CHG CDP70",23, 0)
  9408    D ARRIPT^ CHGCDP73
  9409   "RTN","CHG CDP70",24, 0)
  9410    G A3
  9411   "RTN","CHG CDP70",25, 0)
  9412    ;
  9413   "RTN","CHG CDP70",26, 0)
  9414   DEMO S LNF LG=0
  9415   "RTN","CHG CDP70",27, 0)
  9416    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"BENE-D D")) D BEN DD S LNFLG =1
  9417   "RTN","CHG CDP70",28, 0)
  9418    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"PSEUDO -DD")) D P SVNDD S LN FLG=1
  9419   "RTN","CHG CDP70",29, 0)
  9420    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-DD ")) D VEND D S LNFLG= 1
  9421   "RTN","CHG CDP70",30, 0)
  9422    Q
  9423   "RTN","CHG CDP70",31, 0)
  9424    ;
  9425   "RTN","CHG CDP70",32, 0)
  9426   HEADING W  !!,?20,"// ////////", ?33,"INITI AL INPUT", ?49,"///// /////",!
  9427   "RTN","CHG CDP70",33, 0)
  9428    Q
  9429   "RTN","CHG CDP70",34, 0)
  9430   HDG W !!,? 20,"////// ////",?34, "EDIT HIST ORY",?49," ////////// ",!
  9431   "RTN","CHG CDP70",35, 0)
  9432    Q
  9433   "RTN","CHG CDP70",36, 0)
  9434    ;
  9435   "RTN","CHG CDP70",37, 0)
  9436   HD1 I CHFL =0 W ! S C HFL=1
  9437   "RTN","CHG CDP70",38, 0)
  9438    I LNFLG=1  W ! S LNF LG=0
  9439   "RTN","CHG CDP70",39, 0)
  9440    W !,"Date : ",CHHSDT ,?28,"User : ",CHDZHS  W !
  9441   "RTN","CHG CDP70",40, 0)
  9442    Q
  9443   "RTN","CHG CDP70",41, 0)
  9444    ;
  9445   "RTN","CHG CDP70",42, 0)
  9446   PRINT S (Z ,TAB,CHCHG HS)=0,CNTR =1 K XTMP
  9447   "RTN","CHG CDP70",43, 0)
  9448   PR1 S Z=$O (ARRAY(Z))  I Z="" D: $D(LABEL)  CHK K ARRA Y,LABEL,PC ,Z,CNTR,TA B Q
  9449   "RTN","CHG CDP70",44, 0)
  9450    S LABEL=$ P(ARRAY(Z) ,U,1),PC=$ P(ARRAY(Z) ,U,2)
  9451   "RTN","CHG CDP70",45, 0)
  9452    G:LABEL=" " PR1
  9453   "RTN","CHG CDP70",46, 0)
  9454    I LABEL=" PL ZIP: "  D  G PR1 ;  WTC
  9455   "RTN","CHG CDP70",47, 0)
  9456    . W !,LAB EL,PC ;
  9457   "RTN","CHG CDP70",48, 0)
  9458    . K LABEL ,PC ; WTC
  9459   "RTN","CHG CDP70",49, 0)
  9460    I LABEL=" Total Char ge: " D  G  PR1
  9461   "RTN","CHG CDP70",50, 0)
  9462    .S CHCHGH S=PC,EDFLG =""
  9463   "RTN","CHG CDP70",51, 0)
  9464    .K LABEL, PC
  9465   "RTN","CHG CDP70",52, 0)
  9466    I LABEL=" Medicaid A gency: " K  XTEMP D   G PR1
  9467   "RTN","CHG CDP70",53, 0)
  9468    .S (CHMDN M,MTAX,CHM DTX,MDAD,M DMD,MAD1,M AD2,MCTY,M ST,MSTP,MZ IP)=""
  9469   "RTN","CHG CDP70",54, 0)
  9470    .Q:'$D(PC )  Q:PC=""
  9471   "RTN","CHG CDP70",55, 0)
  9472    .S RC=^CH MVEN(PC,0)
  9473   "RTN","CHG CDP70",56, 0)
  9474    .S CHMDNM =$P(RC,U,1 ),MTAX=$P( RC,U,3),MD AD=$P(RC,U ,23)
  9475   "RTN","CHG CDP70",57, 0)
  9476    .S:MDAD=" " MDAD="   "
  9477   "RTN","CHG CDP70",58, 0)
  9478    .S:$D(^CH MVEN(PC,14 )) MDMD=$P (^(14),U,1 )
  9479   "RTN","CHG CDP70",59, 0)
  9480    .S:MDMD=" " MDMD="   "
  9481   "RTN","CHG CDP70",60, 0)
  9482    .S CHMDTX =MTAX_"-"_ MDAD_"-"_M DMD
  9483   "RTN","CHG CDP70",61, 0)
  9484    .I $D(^CH MVEN(PC,1) ) S RC=^(1 ) D
  9485   "RTN","CHG CDP70",62, 0)
  9486    ..S MAD1= $P(RC,U,1) ,MAD2=$P(R C,U,2),MCT Y=$P(RC,U, 3)
  9487   "RTN","CHG CDP70",63, 0)
  9488    ..S MST=$ P(RC,U,4), MZIP=$P(RC ,U,5)
  9489   "RTN","CHG CDP70",64, 0)
  9490    ..I MST'= "" I $D(^D IC(5,MST,0 )) S MSTP= $P(^(0),U, 2)
  9491   "RTN","CHG CDP70",65, 0)
  9492    ..Q
  9493   "RTN","CHG CDP70",66, 0)
  9494    .S XTEMP( CHMDNM)=CH MDTX_U_MAD 1_U_MAD2_U _MCTY_U_MS TP_U_MZIP
  9495   "RTN","CHG CDP70",67, 0)
  9496    .S EDFLG= ""
  9497   "RTN","CHG CDP70",68, 0)
  9498    .Q
  9499   "RTN","CHG CDP70",69, 0)
  9500    I LABEL=" Medicaid P aid: " S T AB=0,RC=""  D  G PR1
  9501   "RTN","CHG CDP70",70, 0)
  9502    .S CHMDNM =""
  9503   "RTN","CHG CDP70",71, 0)
  9504    .S CHMDNM =$O(XTEMP( CHMDNM)) Q :CHMDNM=""
  9505   "RTN","CHG CDP70",72, 0)
  9506    .S RC=XTE MP(CHMDNM)
  9507   "RTN","CHG CDP70",73, 0)
  9508    .S CHMDTX =$P(RC,U,1 ),MAD1=$P( RC,U,2),MA D2=$P(RC,U ,3)
  9509   "RTN","CHG CDP70",74, 0)
  9510    .S MCTY=$ P(RC,U,4), MSTP=$P(RC ,U,5),MZIP =$P(RC,U,6 )
  9511   "RTN","CHG CDP70",75, 0)
  9512    .W "Medic aid TIN: " ,CHMDTX S  TAB=TAB+32
  9513   "RTN","CHG CDP70",76, 0)
  9514    .W ?TAB,L ABEL,PC
  9515   "RTN","CHG CDP70",77, 0)
  9516    .W !,"Med icaid Agen cy: ",CHMD NM
  9517   "RTN","CHG CDP70",78, 0)
  9518    .W !,"Add r1: ",MAD1
  9519   "RTN","CHG CDP70",79, 0)
  9520    .W !,"Add r2: ",MAD2
  9521   "RTN","CHG CDP70",80, 0)
  9522    .W !,"Cit y: ",MCTY, "    State : ",MSTP,"     Zip: " ,MZIP
  9523   "RTN","CHG CDP70",81, 0)
  9524    .S TAB=0, CNTR=1 W !
  9525   "RTN","CHG CDP70",82, 0)
  9526    .S EDFLG= ""
  9527   "RTN","CHG CDP70",83, 0)
  9528    .Q
  9529   "RTN","CHG CDP70",84, 0)
  9530   PR2 W ?TAB ,LABEL,PC
  9531   "RTN","CHG CDP70",85, 0)
  9532    I CNTR=1  S TAB=TAB+ 32,CNTR=CN TR+1,EDFLG ="" G PR1
  9533   "RTN","CHG CDP70",86, 0)
  9534    I CNTR=2  S TAB=TAB+ 24,CNTR=CN TR+1,EDFLG ="" G PR1
  9535   "RTN","CHG CDP70",87, 0)
  9536    I CNTR=3  I $O(ARRAY (Z)) S TAB =0,CNTR=1  W !
  9537   "RTN","CHG CDP70",88, 0)
  9538    S EDFLG=" "
  9539   "RTN","CHG CDP70",89, 0)
  9540   PR3 G PR1
  9541   "RTN","CHG CDP70",90, 0)
  9542    ;
  9543   "RTN","CHG CDP70",91, 0)
  9544   CHK Q:(LAB EL="MCCR R eview: ")! (LABEL="Be ne Paymt:  ")
  9545   "RTN","CHG CDP70",92, 0)
  9546    I (CNTR<3 )!(CNTR=4)  W ! Q
  9547   "RTN","CHG CDP70",93, 0)
  9548    W:LABEL=" Bene: " !
  9549   "RTN","CHG CDP70",94, 0)
  9550    Q
  9551   "RTN","CHG CDP70",95, 0)
  9552    ;
  9553   "RTN","CHG CDP70",96, 0)
  9554   GTEDI S (C HSTMTP,CHA DMHR,CHDIS HR,CHRELCS 1,CHRELCS2 ,CHRELCS3) =""
  9555   "RTN","CHG CDP70",97, 0)
  9556    Q:'$D(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","AA"))
  9557   "RTN","CHG CDP70",98, 0)
  9558    S EREC=^T MP($J,"CCD ",CHCLM,CH TYPE,"EDI- II","AA")
  9559   "RTN","CHG CDP70",99, 0)
  9560    S CHSTMTP =$P(EREC,U ,1),CHADMH R=$P(EREC, U,2),CHDIS HR=$P(EREC ,U,3)
  9561   "RTN","CHG CDP70",100 ,0)
  9562    S CHRELCS 1=$P(EREC, U,4),CHREL CS2=$P(ERE C,U,5),CHR ELCS3=$P(E REC,U,6)
  9563   "RTN","CHG CDP70",101 ,0)
  9564    W !,"Stat ement Cove rage Perio d: ",CHSTM TP
  9565   "RTN","CHG CDP70",102 ,0)
  9566    Q
  9567   "RTN","CHG CDP70",103 ,0)
  9568    ;
  9569   "RTN","CHG CDP70",104 ,0)
  9570   BINIT Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," BEN-II"))
  9571   "RTN","CHG CDP70",105 ,0)
  9572    S RCX=^(" BEN-II")
  9573   "RTN","CHG CDP70",106 ,0)
  9574    S CHBNAM= $P(RCX,U,1 ),CHBSSN=$ P(RCX,U,2) ,CHBNDOB=$ P(RCX,U,3) ,CHBNREL=$ P(RCX,U,4) ,CHBNAD1=$ P(RCX,U,5) ,CHBNAD2=$ P(RCX,U,6) ,CHBNCTY=$ P(RCX,U,7) ,CHBNST=$P (RCX,U,8), CHBNZIP=$P (RCX,U,9), CHBSEX=$P( RCX,U,10), CHBAGE=$P( RCX,U,11)
  9575   "RTN","CHG CDP70",107 ,0)
  9576    W !!,"Pat ient: ",CH BNAM,?42," SSN: ",CHB SSN  ;AEB  7/19/2010  DEV003698
  9577   "RTN","CHG CDP70",108 ,0)
  9578    W !,"DOB:  ",CHBNDOB ,?18,"Age:  ",CHBAGE, ?30,"Sex:  ",CHBSEX,? 42,"Relati onship: ", CHBNREL
  9579   "RTN","CHG CDP70",109 ,0)
  9580    W !,"Addr 1: ",CHBNA D1
  9581   "RTN","CHG CDP70",110 ,0)
  9582    W !,"Addr 2: ",CHBNA D2
  9583   "RTN","CHG CDP70",111 ,0)
  9584    W !,"City : ",CHBNCT Y,?28,"Sta te: ",CHBN ST,?50,"Zi p: ",CHBNZ IP
  9585   "RTN","CHG CDP70",112 ,0)
  9586    Q
  9587   "RTN","CHG CDP70",113 ,0)
  9588    ;
  9589   "RTN","CHG CDP70",114 ,0)
  9590   BENDD Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," BENE-DD"))
  9591   "RTN","CHG CDP70",115 ,0)
  9592    I CHFL=0  D HDG
  9593   "RTN","CHG CDP70",116 ,0)
  9594    S DT1=""
  9595   "RTN","CHG CDP70",117 ,0)
  9596   BD1 S DT1= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "BENE-DD", DT1)) I 'D T1 K ^TMP( $J,"CCD",C HCLM,CHTYP E,"BENE-DD ") S CHFL= 1 Q
  9597   "RTN","CHG CDP70",118 ,0)
  9598    S RCDD=^( DT1,0)
  9599   "RTN","CHG CDP70",119 ,0)
  9600    S CHDDZ=$ P(RCDD,U,1 ),CHDDNM=" UNK"
  9601   "RTN","CHG CDP70",120 ,0)
  9602    I CHDDZ'= "" I $D(^V A(200,CHDD Z,0)) S CH DDNM=$P(^V A(200,CHDD Z,0),U,2)
  9603   "RTN","CHG CDP70",121 ,0)
  9604    S CHDDNM= CHDDNM_"-" _CHDDZ
  9605   "RTN","CHG CDP70",122 ,0)
  9606    W:CHFL=1  !
  9607   "RTN","CHG CDP70",123 ,0)
  9608    ; Y2K - c hanged all  2 digit y ear displa ys to 4 di git years
  9609   "RTN","CHG CDP70",124 ,0)
  9610    W !,"Date : ",$$FMTE ^XLFDT(DT1 ,5),?28,"B ene Data", ?50,"User:  ",CHDDNM
  9611   "RTN","CHG CDP70",125 ,0)
  9612    S DCT=0
  9613   "RTN","CHG CDP70",126 ,0)
  9614   BD2 S DCT= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "BENE-DD", DT1,DCT))  I 'DCT S C HFL=1 G BD 1
  9615   "RTN","CHG CDP70",127 ,0)
  9616    S RCDE=^( DCT)
  9617   "RTN","CHG CDP70",128 ,0)
  9618    S PIC=$P( RCDE,U,1), LAB=$P(RCD E,U,2)
  9619   "RTN","CHG CDP70",129 ,0)
  9620    I LAB="St ate: " S P IC=$P(^DIC (5,PIC,0), U,2)
  9621   "RTN","CHG CDP70",130 ,0)
  9622    I LAB="DO B: " S PIC =$$FMTE^XL FDT(PIC,"5 D")
  9623   "RTN","CHG CDP70",131 ,0)
  9624    I LAB="Re lationship : " S PIC= $S(PIC="S" :"SPOUSE", PIC="C":"C HILD",PIC= "XS":"EX-S POUSE",1:" ")
  9625   "RTN","CHG CDP70",132 ,0)
  9626    W !,LAB,P IC
  9627   "RTN","CHG CDP70",133 ,0)
  9628    G BD2
  9629   "RTN","CHG CDP70",134 ,0)
  9630    ;
  9631   "RTN","CHG CDP70",135 ,0)
  9632   VINIT S (R TC,RPC)=""
  9633   "RTN","CHG CDP70",136 ,0)
  9634    S:$D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-II ","RT-VEN" )) RTC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"VEN-I I","RT-VEN ")
  9635   "RTN","CHG CDP70",137 ,0)
  9636    S:$D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-II ","PL-VEN" )) RPC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"VEN-I I","PL-VEN ")
  9637   "RTN","CHG CDP70",138 ,0)
  9638    I RTC=""  D  G VIN
  9639   "RTN","CHG CDP70",139 ,0)
  9640    .S (CHVEN RI,CHTAXIP ,CHVADR1,C HVADR2,CHV ADRCY,CHRS TP,CHVNRZP )=""
  9641   "RTN","CHG CDP70",140 ,0)
  9642    .S (CHVPH S,CHVNPHN, CHVPGHS)=" "
  9643   "RTN","CHG CDP70",141 ,0)
  9644    .Q
  9645   "RTN","CHG CDP70",142 ,0)
  9646    S CHVENRI =$P(RTC,U, 1),CHTAXIP =$P(RTC,U, 2),CHVADR1 =$P(RTC,U, 3)
  9647   "RTN","CHG CDP70",143 ,0)
  9648    S CHVADR2 =$P(RTC,U, 4),CHVADRC Y=$P(RTC,U ,5),CHRSTP =$P(RTC,U, 6)
  9649   "RTN","CHG CDP70",144 ,0)
  9650    S CHVNRZP =$P(RTC,U, 7),CHVNPHN =$P(RTC,U, 8)  ;DEV01 9388  EW   11/13/13
  9651   "RTN","CHG CDP70",145 ,0)
  9652   VIN I RPC= "" D  G VI NP
  9653   "RTN","CHG CDP70",146 ,0)
  9654    .S (CHVEN PI,CHVADP1 ,CHVADP2,C HVADPCY,CH PSTP,CHVNP ZP,CHVPGHS ,CHCMACII) =""
  9655   "RTN","CHG CDP70",147 ,0)
  9656    .S (CHCMA CII,CHTAXI P,CHVNPHN, CHVPOA,CHV PPPN)=""   ;DEV019388   EW  11/1 3/13
  9657   "RTN","CHG CDP70",148 ,0)
  9658    .Q
  9659   "RTN","CHG CDP70",149 ,0)
  9660    S CHVENPI =$P(RPC,U, 1),CHVADP1 =$P(RPC,U, 2),CHVADP2 =$P(RPC,U, 3)
  9661   "RTN","CHG CDP70",150 ,0)
  9662    S CHVADPC Y=$P(RPC,U ,4),CHPSTP =$P(RPC,U, 5),CHVNPZP =$P(RPC,U, 6)
  9663   "RTN","CHG CDP70",151 ,0)
  9664    S CHVPPPN =$P(RPC,U, 7),CHVPOA= $P(RPC,U,8 ),CHCMACII =$P(RPC,U, 9)  ;DEV01 9388  EW   11/13/13
  9665   "RTN","CHG CDP70",152 ,0)
  9666   VINP W !!, "Tax ID: " ,CHTAXIP,? 32,"Ven PO A Exmpt: " ,CHVPOA,?5 5,"CMAC: " ,CHCMACII   ;,?56,"Ph one: ",CHV NPHN  ;DEV 019388  EW   11/13/13
  9667   "RTN","CHG CDP70",153 ,0)
  9668    W !,"RT V en: ",CHVE NRI,?40,"P L Ven: ",C HVENPI
  9669   "RTN","CHG CDP70",154 ,0)
  9670    W !,"Phon e: ",CHVNP HN,?40,"Ph one: ",CHV PPPN  ;DEV 019388  EW   11/13/13
  9671   "RTN","CHG CDP70",155 ,0)
  9672    W !,"Addr 1: ",CHVAD R1,?40,"Ad dr1: ",CHV ADP1
  9673   "RTN","CHG CDP70",156 ,0)
  9674    W !,"Addr 2: ",CHVAD R2,?40,"Ad dr2: ",CHV ADP2
  9675   "RTN","CHG CDP70",157 ,0)
  9676    W !,"City : ",CHVADR CY,?40,"Ci ty: ",CHVA DPCY
  9677   "RTN","CHG CDP70",158 ,0)
  9678    W !,"Stat e: ",CHRST P,"   Zip:  ",CHVNRZP ,?40,"Stat e: ",CHPST P,"   Zip:  ",CHVNPZP
  9679   "RTN","CHG CDP70",159 ,0)
  9680    Q
  9681   "RTN","CHG CDP70",160 ,0)
  9682    ;
  9683   "RTN","CHG CDP70",161 ,0)
  9684   VENDD Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," VEN-DD"))
  9685   "RTN","CHG CDP70",162 ,0)
  9686    I CHFL=0  D HDG
  9687   "RTN","CHG CDP70",163 ,0)
  9688    S CHVDT=" "
  9689   "RTN","CHG CDP70",164 ,0)
  9690   VD1 S CHVD T=$O(^TMP( $J,"CCD",C HCLM,CHTYP E,"VEN-DD" ,CHVDT)) I  'CHVDT K  ^TMP($J,"C CD",CHCLM, CHTYPE,"VE N-DD") S C HFL=1 Q
  9691   "RTN","CHG CDP70",165 ,0)
  9692    S RCDF=^( CHVDT,0)
  9693   "RTN","CHG CDP70",166 ,0)
  9694    S CHVENDZ =$P(RCDF,U ,1),CHVDNM ="UNK"
  9695   "RTN","CHG CDP70",167 ,0)
  9696    I CHVENDZ '="" I $D( ^VA(200,CH VENDZ,0))  S CHVDNM=$ P(^VA(200, CHVENDZ,0) ,U,2)
  9697   "RTN","CHG CDP70",168 ,0)
  9698    S CHVDNM= CHVDNM_"-" _CHVENDZ
  9699   "RTN","CHG CDP70",169 ,0)
  9700    W:CHFL=1  !
  9701   "RTN","CHG CDP70",170 ,0)
  9702    W !,"Date : ",$$FMTE ^XLFDT(CHV DT,5),?28, "Vendor Da ta",?50,"U ser: ",CHV DNM
  9703   "RTN","CHG CDP70",171 ,0)
  9704    S VCT=0
  9705   "RTN","CHG CDP70",172 ,0)
  9706   VD2 S VCT= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "VEN-DD",C HVDT,VCT))  I VCT=""  S:CHFL=0 C HFL=1 G VD 1
  9707   "RTN","CHG CDP70",173 ,0)
  9708    S RCDG=^( VCT)
  9709   "RTN","CHG CDP70",174 ,0)
  9710    S PIZ=$P( RCDG,U,1), LABL=$P(RC DG,U,2)
  9711   "RTN","CHG CDP70",175 ,0)
  9712    I LABL="S tate: " S  PIZ=$P(^DI C(5,PIZ,0) ,U,2)
  9713   "RTN","CHG CDP70",176 ,0)
  9714    W !,LABL, PIZ
  9715   "RTN","CHG CDP70",177 ,0)
  9716    G VD2
  9717   "RTN","CHG CDP70",178 ,0)
  9718    ;
  9719   "RTN","CHG CDP70",179 ,0)
  9720   PSVNDD Q:' $D(^TMP($J ,"CCD",CHC LM,CHTYPE, "PSEUDO-DD "))
  9721   "RTN","CHG CDP70",180 ,0)
  9722    I CHFL=0  D HDG
  9723   "RTN","CHG CDP70",181 ,0)
  9724    S CHPDT=" "
  9725   "RTN","CHG CDP70",182 ,0)
  9726   PSV1 S CHP DT=$O(^TMP ($J,"CCD", CHCLM,CHTY PE,"PSEUDO -DD",CHPDT )) I 'CHPD T K ^TMP($ J,"CCD",CH CLM,CHTYPE ,"PSEUDO-D D") S CHFL =1 Q
  9727   "RTN","CHG CDP70",183 ,0)
  9728    S RCP=^(C HPDT,0)
  9729   "RTN","CHG CDP70",184 ,0)
  9730    S CHVENDZ =$P(RCP,U, 1),CHVDNM= "UNK"
  9731   "RTN","CHG CDP70",185 ,0)
  9732    I CHVENDZ '="" I $D( ^VA(200,CH VENDZ,0))  S CHVDNM=$ P(^VA(200, CHVENDZ,0) ,U,2)
  9733   "RTN","CHG CDP70",186 ,0)
  9734    S CHVDNM= CHVDNM_"-" _CHVENDZ
  9735   "RTN","CHG CDP70",187 ,0)
  9736    W:CHFL=1  !
  9737   "RTN","CHG CDP70",188 ,0)
  9738    W !,"Date : ",$$FMTE ^XLFDT(CHP DT,5),?28, "Pseudo Ve ndor Data" ,?50,"User : ",CHVDNM
  9739   "RTN","CHG CDP70",189 ,0)
  9740    S VCT=0
  9741   "RTN","CHG CDP70",190 ,0)
  9742   PSV2 S VCT =$O(^TMP($ J,"CCD",CH CLM,CHTYPE ,"PSEUDO-D D",CHPDT,V CT)) I VCT ="" S:CHFL =0 CHFL=1  G PSV1
  9743   "RTN","CHG CDP70",191 ,0)
  9744    S RCDG=^( VCT)
  9745   "RTN","CHG CDP70",192 ,0)
  9746    S PIZ=$P( RCDG,U,1), LABL=$P(RC DG,U,2)
  9747   "RTN","CHG CDP70",193 ,0)
  9748    I LABL="S tate: " S  PIZ=$P(^DI C(5,PIZ,0) ,U,2)
  9749   "RTN","CHG CDP70",194 ,0)
  9750    W !,LABL, PIZ
  9751   "RTN","CHG CDP70",195 ,0)
  9752    G PSV2
  9753   "RTN","CHG CDP70",196 ,0)
  9754   END K ARRA Y,BFL,VFL, CHACSTHS,C HADXHS,CHA NESHS,CHAN SHS,CHBNAD 1,CHBNAD2
  9755   "RTN","CHG CDP70",197 ,0)
  9756    K CHBNAM, CHBNCTY,CH BNDOB,CHBN REL,CHDDZ, CHDISHS,CH DTED,CHDXH S,CHDZHS
  9757   "RTN","CHG CDP70",198 ,0)
  9758    K CHFACHS ,CHFL,CHHS DT,CHIDTHS ,CHITAMHS, CHITEMHS,C HN,CHNAMTH S,CHNCSTHS
  9759   "RTN","CHG CDP70",199 ,0)
  9760    K CHNTEMH S,CHPLHS,C HPNCHS,CHP RCHS,CHPSC DHS,CHRC,C HRMDYHS,CH RMRTHS,CHR X
  9761   "RTN","CHG CDP70",200 ,0)
  9762    K CHRTPHS ,CHRZ,CHST ATHS,CHTXD D,CHVADD1, CHVADD2,CH VDDST,CHVD NM,CHVENDT
  9763   "RTN","CHG CDP70",201 ,0)
  9764    K CHVENDZ ,CHVNCTY,C HVNDD,CHVN ST,CHVNZIP ,CNT,CNTR, CT,DCT,FMT E,PXFLG
  9765   "RTN","CHG CDP70",202 ,0)
  9766    K LAB,LAB EL,LABL,NC T,PC,PIC,P IZ,PX,RCDD ,RCDE,RCDF ,RCDG,RCX, RCZ,RCZZ
  9767   "RTN","CHG CDP70",203 ,0)
  9768    K SUB,TAB ,VCT,X,XCT ,XNT,Y,Z,Z CT,ZNT
  9769   "RTN","CHG CDP70",204 ,0)
  9770    Q
  9771   "RTN","CHG CDP71")
  9772   0^17^B6472 840
  9773   "RTN","CHG CDP71",1,0 )
  9774   CHGCDP71 ; CVA/RLC;CC D INITIAL  INPUT-MODU LE 7 PRINT -2 - INPAT IENT ;Feb  05, 2019@1 0:39:05
  9775   "RTN","CHG CDP71",2,0 )
  9776    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  9777   "RTN","CHG CDP71",3,0 )
  9778    ;CPTS # 1 1673* (RLC ), #11832*  (RLC)
  9779   "RTN","CHG CDP71",4,0 )
  9780    ;CPE001-0 04 WTC 6/2 6/17 CPE00 1-004
  9781   "RTN","CHG CDP71",5,0 )
  9782   BLDII S PC =$P(RCZZ,U ,1),LABEL= $P(RCZZ,U, 2)
  9783   "RTN","CHG CDP71",6,0 )
  9784    S:LABEL=" Type Servi ce: " ARRA Y(1)=LABEL _U_PC
  9785   "RTN","CHG CDP71",7,0 )
  9786    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  9787   "RTN","CHG CDP71",8,0 )
  9788    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  9789   "RTN","CHG CDP71",9,0 )
  9790    S:LABEL=" Admission:  " ARRAY(4 )=LABEL_U_ PC
  9791   "RTN","CHG CDP71",10, 0)
  9792    S:LABEL=" Pay Provid er: " ARRA Y(5)=LABEL _U_PC
  9793   "RTN","CHG CDP71",11, 0)
  9794    S:LABEL=" Dis Status : " ARRAY( 6)=LABEL_U _PC
  9795   "RTN","CHG CDP71",12, 0)
  9796    S:LABEL=" Discharge:  " ARRAY(7 )=LABEL_U_ PC
  9797   "RTN","CHG CDP71",13, 0)
  9798    S:LABEL=" MCCR Revie w: " ARRAY (8)=LABEL_ U_PC
  9799   "RTN","CHG CDP71",14, 0)
  9800    S:LABEL=" Fac Discha rged to: "  ARRAY(9)= LABEL_U_PC
  9801   "RTN","CHG CDP71",15, 0)
  9802    S:LABEL=" OHI Type:  " ARRAY(10 )=LABEL_U_ PC
  9803   "RTN","CHG CDP71",16, 0)
  9804    S:LABEL=" OHI Begin:  " ARRAY(1 1)=LABEL_U _PC
  9805   "RTN","CHG CDP71",17, 0)
  9806    S:LABEL=" OHI End: "  ARRAY(12) =LABEL_U_P C
  9807   "RTN","CHG CDP71",18, 0)
  9808    S:LABEL=" OHI Name:  " ARRAY(13 )=LABEL_U_ PC
  9809   "RTN","CHG CDP71",19, 0)
  9810    S:LABEL=" OHI Paymt:  " ARRAY(1 4)=LABEL_U _PC
  9811   "RTN","CHG CDP71",20, 0)
  9812    S:LABEL=" Bene Paymt : " ARRAY( 15)=LABEL_ U_PC
  9813   "RTN","CHG CDP71",21, 0)
  9814    S:LABEL=" Medicaid A gency: " A RRAY(16)=L ABEL_U_PC
  9815   "RTN","CHG CDP71",22, 0)
  9816    S:LABEL=" Medicaid P aid: " ARR AY(17)=LAB EL_U_PC
  9817   "RTN","CHG CDP71",23, 0)
  9818    S:LABEL=" Admitting  DX: " ARRA Y(18)=LABE L_U_PC
  9819   "RTN","CHG CDP71",24, 0)
  9820    S:LABEL=" Total Char ge: " ARRA Y(19)=LABE L_U_PC
  9821   "RTN","CHG CDP71",25, 0)
  9822    S:LABEL=" PL ZIP: "  ARRAY(20)= LABEL_U_PC  ; WTC 6/2 6/17
  9823   "RTN","CHG CDP71",26, 0)
  9824    K PC,LABE L
  9825   "RTN","CHG CDP71",27, 0)
  9826    Q
  9827   "RTN","CHG CDP71",28, 0)
  9828    ;
  9829   "RTN","CHG CDP71",29, 0)
  9830   ARRIPT S:L ABEL="Type  Service:  " ARRAY(1) =LABEL_U_P C
  9831   "RTN","CHG CDP71",30, 0)
  9832    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  9833   "RTN","CHG CDP71",31, 0)
  9834    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  9835   "RTN","CHG CDP71",32, 0)
  9836    S:LABEL=" Admission:  " ARRAY(4 )=LABEL_U_ PC
  9837   "RTN","CHG CDP71",33, 0)
  9838    S:LABEL=" Pay Provid er: " ARRA Y(5)=LABEL _U_PC
  9839   "RTN","CHG CDP71",34, 0)
  9840    S:LABEL=" Dis Status : " ARRAY( 6)=LABEL_U _PC
  9841   "RTN","CHG CDP71",35, 0)
  9842    S:LABEL=" Discharge:  " ARRAY(7 )=LABEL_U_ PC
  9843   "RTN","CHG CDP71",36, 0)
  9844    S:LABEL=" MCCR Revie w: " ARRAY (8)=LABEL_ U_PC
  9845   "RTN","CHG CDP71",37, 0)
  9846    S:LABEL=" Fac Discha rged to: "  ARRAY(9)= LABEL_U_PC
  9847   "RTN","CHG CDP71",38, 0)
  9848    S:LABEL=" OHI Type:  " ARRAY(10 )=LABEL_U_ PC
  9849   "RTN","CHG CDP71",39, 0)
  9850    S:LABEL=" OHI Begin:  " ARRAY(1 1)=LABEL_U _PC
  9851   "RTN","CHG CDP71",40, 0)
  9852    S:LABEL=" OHI End: "  ARRAY(12) =LABEL_U_P C
  9853   "RTN","CHG CDP71",41, 0)
  9854    S:LABEL=" OHI Name:  " ARRAY(13 )=LABEL_U_ PC
  9855   "RTN","CHG CDP71",42, 0)
  9856    S:LABEL=" OHI Paymt:  " ARRAY(1 4)=LABEL_U _PC
  9857   "RTN","CHG CDP71",43, 0)
  9858    S:LABEL=" Bene Paymt : " ARRAY( 15)=LABEL_ U_PC
  9859   "RTN","CHG CDP71",44, 0)
  9860    S:LABEL=" Medicaid A gency: " A RRAY(16)=L ABEL_U_PC
  9861   "RTN","CHG CDP71",45, 0)
  9862    S:LABEL=" Medicaid P aid: " ARR AY(17)=LAB EL_U_PC
  9863   "RTN","CHG CDP71",46, 0)
  9864    S:LABEL=" Admitting  DX: " ARRA Y(18)=LABE L_U_PC
  9865   "RTN","CHG CDP71",47, 0)
  9866    S:LABEL=" Total Char ge: " ARRA Y(19)=LABE L_U_PC
  9867   "RTN","CHG CDP71",48, 0)
  9868    S:LABEL=" PL ZIP: "  ARRAY(20)= LABEL_U_PC  ; WTC 6/2 6/17
  9869   "RTN","CHG CDP71",49, 0)
  9870    K PC,LABE L
  9871   "RTN","CHG CDP71",50, 0)
  9872    Q
  9873   "RTN","CHG CDP73")
  9874   0^18^B9545 809
  9875   "RTN","CHG CDP73",1,0 )
  9876   CHGCDP73 ; CVA/RLC;CC D EDIT HIS TORY-MODUL E 7 VIEW-2  - ALL OTH ER TOS ;Fe b 05, 2019 @10:39:39
  9877   "RTN","CHG CDP73",2,0 )
  9878    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  9879   "RTN","CHG CDP73",3,0 )
  9880    ;CPTS #11 834 (RLC)
  9881   "RTN","CHG CDP73",4,0 )
  9882    ;DEV00369 8 4/20/201 0 AEB
  9883   "RTN","CHG CDP73",5,0 )
  9884    ; CPE001- 004 WTC 6/ 23/17
  9885   "RTN","CHG CDP73",6,0 )
  9886   BLDII S PC =$P(RCZZ,U ,1),LABEL= $P(RCZZ,U, 2)
  9887   "RTN","CHG CDP73",7,0 )
  9888    S:LABEL=" Type Servi ce: " ARRA Y(1)=LABEL _U_PC
  9889   "RTN","CHG CDP73",8,0 )
  9890    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  9891   "RTN","CHG CDP73",9,0 )
  9892    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  9893   "RTN","CHG CDP73",10, 0)
  9894    S:LABEL=" DOS: " ARR AY(4)=LABE L_U_PC
  9895   "RTN","CHG CDP73",11, 0)
  9896    S:LABEL=" POS: " ARR AY(5)=LABE L_U_PC
  9897   "RTN","CHG CDP73",12, 0)
  9898    S:LABEL=" Pay Provid er: " ARRA Y(6)=LABEL _U_PC
  9899   "RTN","CHG CDP73",13, 0)
  9900    S:LABEL=" MCCR Revie w: " ARRAY (7)=LABEL_ U_PC
  9901   "RTN","CHG CDP73",14, 0)
  9902    S:LABEL=" OHI Type:  " ARRAY(8) =LABEL_U_P C
  9903   "RTN","CHG CDP73",15, 0)
  9904    S:LABEL=" OHI Begin:  " ARRAY(9 )=LABEL_U_ PC
  9905   "RTN","CHG CDP73",16, 0)
  9906    S:LABEL=" OHI End: "  ARRAY(10) =LABEL_U_P C
  9907   "RTN","CHG CDP73",17, 0)
  9908    S:LABEL=" OHI Name:  " ARRAY(11 )=LABEL_U_ PC
  9909   "RTN","CHG CDP73",18, 0)
  9910    S:LABEL=" OHI Paymt:  " ARRAY(1 2)=LABEL_U _PC
  9911   "RTN","CHG CDP73",19, 0)
  9912    S:LABEL=" Bene Paymt : " ARRAY( 13)=LABEL_ U_PC
  9913   "RTN","CHG CDP73",20, 0)
  9914    S:LABEL=" POP1: " AR RAY(14)=LA BEL_U_PC   ;AEB 7/19/ 2010 DEV00 3698
  9915   "RTN","CHG CDP73",21, 0)
  9916    S:LABEL=" Medicaid A gency: " A RRAY(15)=L ABEL_U_PC
  9917   "RTN","CHG CDP73",22, 0)
  9918    S:LABEL=" Medicaid P aid: " ARR AY(16)=LAB EL_U_PC
  9919   "RTN","CHG CDP73",23, 0)
  9920    S:LABEL=" Total Char ge: " ARRA Y(17)=LABE L_U_PC
  9921   "RTN","CHG CDP73",24, 0)
  9922    S:LABEL=" PL ZIP: "  ARRAY(18)= LABEL_U_PC  ; WTC 6/2 3/17
  9923   "RTN","CHG CDP73",25, 0)
  9924    K PC,LABE L
  9925   "RTN","CHG CDP73",26, 0)
  9926    Q
  9927   "RTN","CHG CDP73",27, 0)
  9928    ;
  9929   "RTN","CHG CDP73",28, 0)
  9930   ARRIPT S:L ABEL="Type  Service:  " ARRAY(1) =LABEL_U_P C
  9931   "RTN","CHG CDP73",29, 0)
  9932    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  9933   "RTN","CHG CDP73",30, 0)
  9934    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  9935   "RTN","CHG CDP73",31, 0)
  9936    S:LABEL=" DOS: " ARR AY(4)=LABE L_U_PC
  9937   "RTN","CHG CDP73",32, 0)
  9938    S:LABEL=" POS: " ARR AY(5)=LABE L_U_PC
  9939   "RTN","CHG CDP73",33, 0)
  9940    S:LABEL=" Pay Provid er: " ARRA Y(6)=LABEL _U_PC
  9941   "RTN","CHG CDP73",34, 0)
  9942    S:LABEL=" MCCR Revie w: " ARRAY (7)=LABEL_ U_PC
  9943   "RTN","CHG CDP73",35, 0)
  9944    S:LABEL=" OHI Type:  " ARRAY(8) =LABEL_U_P C
  9945   "RTN","CHG CDP73",36, 0)
  9946    S:LABEL=" OHI Begin:  " ARRAY(9 )=LABEL_U_ PC
  9947   "RTN","CHG CDP73",37, 0)
  9948    S:LABEL=" OHI End: "  ARRAY(10) =LABEL_U_P C
  9949   "RTN","CHG CDP73",38, 0)
  9950    S:LABEL=" OHI Name:  " ARRAY(11 )=LABEL_U_ PC
  9951   "RTN","CHG CDP73",39, 0)
  9952    S:LABEL=" OHI Paymt:  " ARRAY(1 2)=LABEL_U _PC
  9953   "RTN","CHG CDP73",40, 0)
  9954    S:LABEL=" Bene Paymt : " ARRAY( 13)=LABEL_ U_PC
  9955   "RTN","CHG CDP73",41, 0)
  9956    S:LABEL=" Medicaid A gency: " A RRAY(14)=L ABEL_U_PC
  9957   "RTN","CHG CDP73",42, 0)
  9958    S:LABEL=" Medicaid P aid: " ARR AY(15)=LAB EL_U_PC
  9959   "RTN","CHG CDP73",43, 0)
  9960    S:LABEL=" Total Char ge: " ARRA Y(16)=LABE L_U_PC
  9961   "RTN","CHG CDP73",44, 0)
  9962    S:LABEL=" PL ZIP: "  ARRAY(17)= LABEL_U_PC  ; WTC 6/2 6/17
  9963   "RTN","CHG CDP73",45, 0)
  9964    K PC,LABE L
  9965   "RTN","CHG CDP73",46, 0)
  9966    Q
  9967   "RTN","CHG CDP73",47, 0)
  9968   LOOP K VEN FLG
  9969   "RTN","CHG CDP73",48, 0)
  9970    D VENHIS  D:$D(VENFL G) PRT
  9971   "RTN","CHG CDP73",49, 0)
  9972    D ^CHGCDP 74
  9973   "RTN","CHG CDP73",50, 0)
  9974    Q
  9975   "RTN","CHG CDP73",51, 0)
  9976    ;
  9977   "RTN","CHG CDP73",52, 0)
  9978   VENHIS Q:' $D(^TMP($J ,"CCD",CHC LM,CHTYPE, "VENPTHS", JX))
  9979   "RTN","CHG CDP73",53, 0)
  9980    S VX=0,N= 1
  9981   "RTN","CHG CDP73",54, 0)
  9982   VEN1 S VX= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "VENPTHS", JX,VX)) I  VX="" Q
  9983   "RTN","CHG CDP73",55, 0)
  9984    S CHVENHS =$P(^TMP($ J,"CCD",CH CLM,CHTYPE ,"VENPTHS" ,JX,VX),U, 1)
  9985   "RTN","CHG CDP73",56, 0)
  9986    D  I ($D( PX))&('$D( HDFL))&(CH FL>0) D HD 1^CHGCDP7  S (HDFL,CH FL)=1
  9987   "RTN","CHG CDP73",57, 0)
  9988    .I CHVENH S'="" S LA BEL="Vendo r: ",PC=CH VENHS,PX(N )=LABEL_U_ PC,N=N+1
  9989   "RTN","CHG CDP73",58, 0)
  9990    G VEN1
  9991   "RTN","CHG CDP73",59, 0)
  9992    ;
  9993   "RTN","CHG CDP73",60, 0)
  9994   PRT S N=0, CNT=1
  9995   "RTN","CHG CDP73",61, 0)
  9996   P1 S N=$O( PX(N)) I N ="" D:$D(L ABEL) BUIL D K PX,LAB EL,PC,N,CN T Q
  9997   "RTN","CHG CDP73",62, 0)
  9998    S LABEL(C NT)=$P(PX( N),U,1),PC (CNT)=$P(P X(N),U,2)
  9999   "RTN","CHG CDP73",63, 0)
  10000    G:(LABEL( CNT)="")!( PC(CNT)="" ) P1
  10001   "RTN","CHG CDP73",64, 0)
  10002    I CNT=3 D  BUILD S C NT=1 W ! K  LABEL,PC  G P1
  10003   "RTN","CHG CDP73",65, 0)
  10004    S CNT=CNT +1
  10005   "RTN","CHG CDP73",66, 0)
  10006    G P1
  10007   "RTN","CHG CDP73",67, 0)
  10008    ;
  10009   "RTN","CHG CDP73",68, 0)
  10010   BUILD I $D (LABEL(3))  W LABEL(1 ),PC(1),?2 8,LABEL(2) ,PC(2),?56 ,LABEL(3), PC(3) Q
  10011   "RTN","CHG CDP73",69, 0)
  10012    I $D(LABE L(2)) W LA BEL(1),PC( 1),?28,LAB EL(2),PC(2 ) W:(CNT<3 ) ! Q
  10013   "RTN","CHG CDP73",70, 0)
  10014    I $D(LABE L(1)) W LA BEL(1),PC( 1) W:(CNT< 3) !
  10015   "RTN","CHG CDP73",71, 0)
  10016    Q
  10017   "RTN","CHG CDV7")
  10018   0^19^B8457 3137
  10019   "RTN","CHG CDV7",1,0)
  10020   CHGCDV7 ;C VA/RLC;CCD  INITIAL I NPUT/EDITS -MODULE 7  VIEW - INP ATIENT ;Fe b 05, 2019 @10:41:13
  10021   "RTN","CHG CDV7",2,0)
  10022    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  10023   "RTN","CHG CDV7",3,0)
  10024    ;CPTS #11 832* (RLC)
  10025   "RTN","CHG CDV7",4,0)
  10026    ;DEV01938 8 EW  11/0 7/13  POA  and PL pho ne
  10027   "RTN","CHG CDV7",5,0)
  10028    ;MTN02182 9 JSE 09/2 4/14  FIX  UNDEFINED  ERROR VINP +6^CHGCDV7
  10029   "RTN","CHG CDV7",6,0)
  10030    ; CPE001- 004 PL ZIP  - wtc 6/2 0/17
  10031   "RTN","CHG CDV7",7,0)
  10032    ;
  10033   "RTN","CHG CDV7",8,0)
  10034    I CHTYPE' =1 D ^CHGC DV70 G END
  10035   "RTN","CHG CDV7",9,0)
  10036    S U="^",( JX,CHFL)=0  F Z=1:1:2 0 S ARRAY( Z)="" ; Ch anged 19 t o 20 wtc 6 /23/17
  10037   "RTN","CHG CDV7",10,0 )
  10038   A1 S JX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX))  G:JX="" EN D
  10039   "RTN","CHG CDV7",11,0 )
  10040    S RCZ=^(J X) K HDFL
  10041   "RTN","CHG CDV7",12,0 )
  10042    S CHDZHS= $P(RCZ,U,1 ),CHHSDT=$ P(RCZ,U,2)
  10043   "RTN","CHG CDV7",13,0 )
  10044    D:CHFL=0  HEADING
  10045   "RTN","CHG CDV7",14,0 )
  10046    D:CHFL=1  HDG
  10047   "RTN","CHG CDV7",15,0 )
  10048    S SUB=""
  10049   "RTN","CHG CDV7",16,0 )
  10050   A2 S SUB=$ O(^TMP($J, "CCD",CHCL M,CHTYPE," HIST",JX,S UB)) I SUB ="" D PRIN T D:CHFL=0  BINIT,VIN IT D LOOP^ CHGCDV71,D EMO S CHFL =CHFL+1 G  A1
  10051   "RTN","CHG CDV7",17,0 )
  10052    S XX=0
  10053   "RTN","CHG CDV7",18,0 )
  10054   A3 S XX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX,SU B,XX)) G:X X="" A2
  10055   "RTN","CHG CDV7",19,0 )
  10056    S RCZZ=^( XX)
  10057   "RTN","CHG CDV7",20,0 )
  10058    I CHFL=0  D BLDII^CH GCDV71 G A 3
  10059   "RTN","CHG CDV7",21,0 )
  10060    I ('$D(HD FL))&(CHFL >0) D HD1  S HDFL=1
  10061   "RTN","CHG CDV7",22,0 )
  10062    S PC=$P(R CZZ,U,1),L ABEL=$P(RC ZZ,U,2)
  10063   "RTN","CHG CDV7",23,0 )
  10064    D ARRIPT^ CHGCDV71
  10065   "RTN","CHG CDV7",24,0 )
  10066    G A3
  10067   "RTN","CHG CDV7",25,0 )
  10068    ;
  10069   "RTN","CHG CDV7",26,0 )
  10070   DEMO S LNF LG=0
  10071   "RTN","CHG CDV7",27,0 )
  10072    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"BENE-D D")) D BEN DD^CHGCDV7 2 S LNFLG= 1
  10073   "RTN","CHG CDV7",28,0 )
  10074    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"PSEUDO -DD")) D P SVNDD^CHGC DV72 S LNF LG=1
  10075   "RTN","CHG CDV7",29,0 )
  10076    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-DD ")) D VEND D^CHGCDV72  S LNFLG=1
  10077   "RTN","CHG CDV7",30,0 )
  10078    Q
  10079   "RTN","CHG CDV7",31,0 )
  10080    ;
  10081   "RTN","CHG CDV7",32,0 )
  10082   HEADING D  UPCT S ^UT ILITY($J," CCD",CHZON E,CT)=""
  10083   "RTN","CHG CDV7",33,0 )
  10084    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" X XY S DX= 20 X XY W  @CHBON,""/ /////////" ",@CHBOFF  S DX=33 X  XY W @CHBO N,""Initia l Input"", @CHBOFF S  DX=49 X XY  W @CHBON, ""//////// //"",@CHBO FF"
  10085   "RTN","CHG CDV7",34,0 )
  10086    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" "
  10087   "RTN","CHG CDV7",35,0 )
  10088    S X="X XY  W @CHBON, ""Date: "" ,@CHBOFF,P 1 S DX=32  X XY W @CH BON,""VE:  "",@CHBOFF ,P2"
  10089   "RTN","CHG CDV7",36,0 )
  10090    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHHSDT_ U_CHDZHS
  10091   "RTN","CHG CDV7",37,0 )
  10092    Q
  10093   "RTN","CHG CDV7",38,0 )
  10094    ;
  10095   "RTN","CHG CDV7",39,0 )
  10096   HDG D UPCT  S ^UTILIT Y($J,"CCD" ,CHZONE,CT )=""
  10097   "RTN","CHG CDV7",40,0 )
  10098    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" X XY S DX= 20 X XY W  @CHBON,""/ /////////" ",@CHBOFF  S DX=33 X  XY W @CHBO N,""Edit H istory"",@ CHBOFF S D X=49 X XY  W @CHBON," "///////// /"",@CHBOF F"
  10099   "RTN","CHG CDV7",41,0 )
  10100    Q
  10101   "RTN","CHG CDV7",42,0 )
  10102   HD1 D UPCT  S ^UTILIT Y($J,"CCD" ,CHZONE,CT )=""
  10103   "RTN","CHG CDV7",43,0 )
  10104    S X="X XY  W @CHBON, ""Date: "" ,@CHBOFF,P 1 S DX=32  X XY W @CH BON,""User : "",@CHBO FF,P2"
  10105   "RTN","CHG CDV7",44,0 )
  10106    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHHSDT_ U_CHDZHS
  10107   "RTN","CHG CDV7",45,0 )
  10108    Q
  10109   "RTN","CHG CDV7",46,0 )
  10110    ;
  10111   "RTN","CHG CDV7",47,0 )
  10112   PRINT S (Z ,CHCHGHS)= 0,LCT=1 K  XTMP
  10113   "RTN","CHG CDV7",48,0 )
  10114   PR1 S Z=$O (ARRAY(Z))  I Z="" D: $D(LABEL)  BUILD,SPAC E K ARRAY, LABEL,PC,Z ,LCT Q
  10115   "RTN","CHG CDV7",49,0 )
  10116    S LABEL(L CT)=$P(ARR AY(Z),U,1) ,PC(LCT)=$ P(ARRAY(Z) ,U,2)
  10117   "RTN","CHG CDV7",50,0 )
  10118    G:'$D(LAB EL) PR1
  10119   "RTN","CHG CDV7",51,0 )
  10120    I LABEL(L CT)="PL ZI P: " D  G  PR1 ; WTC
  10121   "RTN","CHG CDV7",52,0 )
  10122    . S LABEL (1)=LABEL( LCT),PC(1) =PC(LCT),L ABEL(2)="" ,PC(2)="", LABEL(3)=" ",PC(3)=""  ;
  10123   "RTN","CHG CDV7",53,0 )
  10124    . D BUILD  K LABEL,P C ; WTC
  10125   "RTN","CHG CDV7",54,0 )
  10126    I LABEL(L CT)="Total  Charge: "  D  G PR1
  10127   "RTN","CHG CDV7",55,0 )
  10128    .S CHCHGH S=PC(LCT)
  10129   "RTN","CHG CDV7",56,0 )
  10130    .D BUILD  ;K LABEL,P C ; WTC 6/ 20/17
  10131   "RTN","CHG CDV7",57,0 )
  10132    .K LABEL( LCT),PC(LC T)
  10133   "RTN","CHG CDV7",58,0 )
  10134    .Q
  10135   "RTN","CHG CDV7",59,0 )
  10136    I LABEL(L CT)="Medic aid Agency : " K XTEM P D  G PR1
  10137   "RTN","CHG CDV7",60,0 )
  10138    .S (CHMDN M,MTAX,CHM DTX,MDAD,M DMD,MAD1,M AD2,MCTY,M ST,MSTP,MZ IP)=""
  10139   "RTN","CHG CDV7",61,0 )
  10140    .Q:'$D(PC (LCT))  Q: PC(LCT)=""
  10141   "RTN","CHG CDV7",62,0 )
  10142    .S PC=PC( LCT)
  10143   "RTN","CHG CDV7",63,0 )
  10144    .S RC=^CH MVEN(PC,0)
  10145   "RTN","CHG CDV7",64,0 )
  10146    .S CHMDNM =$P(RC,U,1 ),MTAX=$P( RC,U,3),MD AD=$P(RC,U ,23)
  10147   "RTN","CHG CDV7",65,0 )
  10148    .S:MDAD=" " MDAD="   "
  10149   "RTN","CHG CDV7",66,0 )
  10150    .S:$D(^CH MVEN(RC,14 )) MDMD=$P (^(14),U,1 )
  10151   "RTN","CHG CDV7",67,0 )
  10152    .S:MDMD=" " MDMD="   "
  10153   "RTN","CHG CDV7",68,0 )
  10154    .S CHMDTX =MTAX_"-"_ MDAD_"-"_M DMD
  10155   "RTN","CHG CDV7",69,0 )
  10156    .I $D(^CH MVEN(PC,1) ) S RC=^(1 ) D
  10157   "RTN","CHG CDV7",70,0 )
  10158    ..S MAD1= $P(RC,U,1) ,MAD2=$P(R C,U,2),MCT Y=$P(RC,U, 3)
  10159   "RTN","CHG CDV7",71,0 )
  10160    ..S MST=$ P(RC,U,4), MZIP=$P(RC ,U,5)
  10161   "RTN","CHG CDV7",72,0 )
  10162    ..I MST'= "" I $D(^D IC(5,MST,0 )) S MSTP= $P(^(0),U, 2)
  10163   "RTN","CHG CDV7",73,0 )
  10164    .S XTEMP( CHMDNM)=CH MDTX_U_MAD 1_U_MAD2_U _MCTY_U_MS TP_U_MZIP
  10165   "RTN","CHG CDV7",74,0 )
  10166    .Q
  10167   "RTN","CHG CDV7",75,0 )
  10168    I LABEL(L CT)="Medic aid Paid:  " S RC=""  D  G PR1
  10169   "RTN","CHG CDV7",76,0 )
  10170    .S MEDPAI D=PC(LCT)
  10171   "RTN","CHG CDV7",77,0 )
  10172    .S CHMDNM =""
  10173   "RTN","CHG CDV7",78,0 )
  10174    .S CHMDNM =$O(XTEMP( CHMDNM)) Q :CHMDNM=""
  10175   "RTN","CHG CDV7",79,0 )
  10176    .S RC=XTE MP(CHMDNM)
  10177   "RTN","CHG CDV7",80,0 )
  10178    .S CHMDTX =$P(RC,U,1 ),MAD1=$P( RC,U,2),MA D2=$P(RC,U ,3)
  10179   "RTN","CHG CDV7",81,0 )
  10180    .S MCTY=$ P(RC,U,4), MSTP=$P(RC ,U,5),MZIP =$P(RC,U,6 )
  10181   "RTN","CHG CDV7",82,0 )
  10182    .S X="X X Y W @CHBON ,""Medicai d TIN: "", @CHBOFF,P1  S DX=32 X  XY W @CHB ON,""Medic aid Paid:  "",@CHBOFF ,P2"
  10183   "RTN","CHG CDV7",83,0 )
  10184    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHMDTX _U_MEDPAID
  10185   "RTN","CHG CDV7",84,0 )
  10186    .S X="X X Y W @CHBON ,""Medicai d Agency:  "",@CHBOFF ,P1"
  10187   "RTN","CHG CDV7",85,0 )
  10188    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHMDNM
  10189   "RTN","CHG CDV7",86,0 )
  10190    .S X="X X Y W @CHBON ,""Addr1:  "",@CHBOFF ,P1"
  10191   "RTN","CHG CDV7",87,0 )
  10192    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MAD1
  10193   "RTN","CHG CDV7",88,0 )
  10194    .S X="X X Y W @CHBON ,""Addr2:  "",@CHBOFF ,P2"
  10195   "RTN","CHG CDV7",89,0 )
  10196    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MAD2
  10197   "RTN","CHG CDV7",90,0 )
  10198    .S X="X X Y W @CHBON ,""City: " ",@CHBOFF, P1 S DX=32  X XY W @C HBON,""Sta te: "",@CH BOFF,P2 S  DX=42 X XY  W @CHBON, ""Zip: "", @CHBOFF,P3 "
  10199   "RTN","CHG CDV7",91,0 )
  10200    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MCTY_U _MSTP_U_MZ IP
  10201   "RTN","CHG CDV7",92,0 )
  10202    .S TAB=0, CNTR=1
  10203   "RTN","CHG CDV7",93,0 )
  10204    .S LCT=1  K LABEL,PC
  10205   "RTN","CHG CDV7",94,0 )
  10206    .Q
  10207   "RTN","CHG CDV7",95,0 )
  10208    I LABEL(L CT)="Admit ting DX: "  D  G PR1
  10209   "RTN","CHG CDV7",96,0 )
  10210    .S LAB1=L ABEL(LCT), P1=PC(LCT)
  10211   "RTN","CHG CDV7",97,0 )
  10212    .S XTMP(L AB1)=P1
  10213   "RTN","CHG CDV7",98,0 )
  10214    .S LCT=1  K LABEL,PC
  10215   "RTN","CHG CDV7",99,0 )
  10216    .Q
  10217   "RTN","CHG CDV7",100, 0)
  10218    S SP=""""
  10219   "RTN","CHG CDV7",101, 0)
  10220   PR2 I LCT= 3 I $O(ARR AY(Z)) D B UILD D  G  PR1
  10221   "RTN","CHG CDV7",102, 0)
  10222    .I LABEL( LCT)="Fac  Discharged  to: " I C HFL=0 D GT EDI
  10223   "RTN","CHG CDV7",103, 0)
  10224    .S LCT=1  K LABEL,PC
  10225   "RTN","CHG CDV7",104, 0)
  10226    S LCT=LCT +1
  10227   "RTN","CHG CDV7",105, 0)
  10228    G PR1
  10229   "RTN","CHG CDV7",106, 0)
  10230    ;
  10231   "RTN","CHG CDV7",107, 0)
  10232   BINIT Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," BEN-II"))
  10233   "RTN","CHG CDV7",108, 0)
  10234    S RCX=^(" BEN-II")
  10235   "RTN","CHG CDV7",109, 0)
  10236    S CHBNAM= $P(RCX,U,1 ),CHBSSN=$ P(RCX,U,2) ,CHBNDOB=$ P(RCX,U,3) ,CHBNREL=$ P(RCX,U,4) ,CHBNAD1=$ P(RCX,U,5) ,CHBNAD2=$ P(RCX,U,6) ,CHBNCTY=$ P(RCX,U,7) ,CHBNST=$P (RCX,U,8), CHBNZIP=$P (RCX,U,9), CHBSEX=$P( RCX,U,10), CHBAGE=$P( RCX,U,11)
  10237   "RTN","CHG CDV7",110, 0)
  10238    D WRTLINE
  10239   "RTN","CHG CDV7",111, 0)
  10240    S X="X XY  W @CHBON, ""Patient:  "",@CHBOF F,P1 S DX= 42 X XY W  @CHBON,""S SN: "",@CH BOFF,P2"
  10241   "RTN","CHG CDV7",112, 0)
  10242    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAM_ U_CHBSSN
  10243   "RTN","CHG CDV7",113, 0)
  10244    S X="X XY  W @CHBON, ""DOB: "", @CHBOFF,P1  S DX=18 X  XY W @CHB ON,""Age:  "",@CHBOFF ,P2 S DX=3 0 X XY W @ CHBON,""Se x: "",@CHB OFF,P3 S D X=42 X XY  W @CHBON," "Relations hip: "",@C HBOFF,P4"
  10245   "RTN","CHG CDV7",114, 0)
  10246    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNDOB _U_CHBAGE_ U_CHBSEX_U _CHBNREL
  10247   "RTN","CHG CDV7",115, 0)
  10248    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1"
  10249   "RTN","CHG CDV7",116, 0)
  10250    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAD1
  10251   "RTN","CHG CDV7",117, 0)
  10252    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1"
  10253   "RTN","CHG CDV7",118, 0)
  10254    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAD2
  10255   "RTN","CHG CDV7",119, 0)
  10256    S X="X XY  W @CHBON, ""City: "" ,@CHBOFF,P 1 S DX=28  X XY W @CH BON,""Stat e: "",@CHB OFF,P2 S D X=50 X XY  W @CHBON," "Zip: "",@ CHBOFF,P3"
  10257   "RTN","CHG CDV7",120, 0)
  10258    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNCTY _U_CHBNST_ U_CHBNZIP
  10259   "RTN","CHG CDV7",121, 0)
  10260    Q
  10261   "RTN","CHG CDV7",122, 0)
  10262    ;
  10263   "RTN","CHG CDV7",123, 0)
  10264   VINIT S (R TC,RPC)=""
  10265   "RTN","CHG CDV7",124, 0)
  10266    S:$D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-II ","RT-VEN" )) RTC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"VEN-I I","RT-VEN ")
  10267   "RTN","CHG CDV7",125, 0)
  10268    S:$D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-II ","PL-VEN" )) RPC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"VEN-I I","PL-VEN ")
  10269   "RTN","CHG CDV7",126, 0)
  10270    I RTC=""  D  G VIN
  10271   "RTN","CHG CDV7",127, 0)
  10272    .S (CHVEN RI,CHTAXIP ,CHVADR1,C HVADR2,CHV ADRCY,CHRS TP,CHVNRZP )=""
  10273   "RTN","CHG CDV7",128, 0)
  10274    .S (CHVPH S,CHVNPHN, CHVPGHS)=" "
  10275   "RTN","CHG CDV7",129, 0)
  10276    .Q
  10277   "RTN","CHG CDV7",130, 0)
  10278    S CHVENRI =$P(RTC,U, 1),CHTAXIP =$P(RTC,U, 2),CHVADR1 =$P(RTC,U, 3)
  10279   "RTN","CHG CDV7",131, 0)
  10280    S CHVADR2 =$P(RTC,U, 4),CHVADRC Y=$P(RTC,U ,5),CHRSTP =$P(RTC,U, 6)
  10281   "RTN","CHG CDV7",132, 0)
  10282    S CHVNRZP =$P(RTC,U, 7),CHVPHS= $P(RTC,U,8 ),CHVNPHN= $P(RTC,U,9 )
  10283   "RTN","CHG CDV7",133, 0)
  10284   VIN I RPC= "" D  G VI NP
  10285   "RTN","CHG CDV7",134, 0)
  10286    .;S (CHVE NPI,CHVADP 1,CHVADP2, CHVADPCY,C HPSTP,CHVN PZP,CHVPGH S,CHCMACII )=""
  10287   "RTN","CHG CDV7",135, 0)
  10288    .;S (CHCM ACII,CHTAX IP,CHVNPHN ,CHVPOA)=" "  ;DEV019 388  EW  1 1/13/13
  10289   "RTN","CHG CDV7",136, 0)
  10290    .;
  10291   "RTN","CHG CDV7",137, 0)
  10292    .S (CHVEN PI,CHVADP1 ,CHVADP2,C HVADPCY,CH PSTP,CHVNP ZP,CHVPGHS )=""  ;MTN 021829 JSE  FIX UNDEF  VINP+6^CH GCDV7 (CHV PPPN)
  10293   "RTN","CHG CDV7",138, 0)
  10294    .S (CHVPP PN,CHVPOA, CHCMACII)= ""
  10295   "RTN","CHG CDV7",139, 0)
  10296    .Q
  10297   "RTN","CHG CDV7",140, 0)
  10298    S CHVENPI =$P(RPC,U, 1),CHVADP1 =$P(RPC,U, 2),CHVADP2 =$P(RPC,U, 3)
  10299   "RTN","CHG CDV7",141, 0)
  10300    S CHVADPC Y=$P(RPC,U ,4),CHPSTP =$P(RPC,U, 5),CHVNPZP =$P(RPC,U, 6)
  10301   "RTN","CHG CDV7",142, 0)
  10302    S CHVPPPN =$P(RPC,U, 7),CHVPOA= $P(RPC,U,8 ),CHCMACII =$P(RPC,U, 9)  ;DEV01 9388  EW   11/13/13
  10303   "RTN","CHG CDV7",143, 0)
  10304   VINP D WRT LINE
  10305   "RTN","CHG CDV7",144, 0)
  10306    S X="X XY  W @CHBON, ""Tax ID:  "",@CHBOFF ,P1 S DX=3 2 X XY W @ CHBON,""Ve n POA Exmp t: "",@CHB OFF,P2 S D X=55 X XY  W @CHBON," "CMAC: "", @CHBOFF,P3 "  ;DEV019 388  EW  1 1/13/13
  10307   "RTN","CHG CDV7",145, 0)
  10308    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHTAXIP _U_CHVPOA_ U_CHCMACII   ;_U_CHVN PHN
  10309   "RTN","CHG CDV7",146, 0)
  10310    S X="X XY  W @CHBON, ""RT Ven:  "",@CHBOFF ,P1 S DX=4 0 X XY W @ CHBON,""PL  Ven: "",@ CHBOFF,P2"
  10311   "RTN","CHG CDV7",147, 0)
  10312    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVENRI _U_CHVENPI
  10313   "RTN","CHG CDV7",148, 0)
  10314    S X="X XY  W @CHBON, ""Phone: " ",@CHBOFF, P1 S DX=40  X XY W @C HBON,""Pho ne: "",@CH BOFF,P2"   ;DEV019388   EW  11/1 3/13
  10315   "RTN","CHG CDV7",149, 0)
  10316    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVNPHN _U_CHVPPPN   ;DEV0193 88  EW  11 /13/13
  10317   "RTN","CHG CDV7",150, 0)
  10318    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=40  X XY W @C HBON,""Add r1: "",@CH BOFF,P2"
  10319   "RTN","CHG CDV7",151, 0)
  10320    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADR1 _U_CHVADP1
  10321   "RTN","CHG CDV7",152, 0)
  10322    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1 S DX=40  X XY W @C HBON,""Add r2: "",@CH BOFF,P2"
  10323   "RTN","CHG CDV7",153, 0)
  10324    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADR2 _U_CHVADP2
  10325   "RTN","CHG CDV7",154, 0)
  10326    S X="X XY  W @CHBON, ""City: "" ,@CHBOFF,P 1 S DX=40  X XY W @CH BON,""City : "",@CHBO FF,P2"
  10327   "RTN","CHG CDV7",155, 0)
  10328    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADRC Y_U_CHVADP CY
  10329   "RTN","CHG CDV7",156, 0)
  10330    S X="X XY  W @CHBON, ""State: " ",@CHBOFF, P1 S DX=12  X XY W @C HBON,""Zip : "",@CHBO FF,P2 S DX =40 X XY W  @CHBON,"" State: "", @CHBOFF,P3  S DX=52 X  XY W @CHB ON,""Zip:  "",@CHBOFF ,P4"
  10331   "RTN","CHG CDV7",157, 0)
  10332    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHRSTP_ U_CHVNRZP_ U_CHPSTP_U _CHVNPZP
  10333   "RTN","CHG CDV7",158, 0)
  10334    D WRTLINE
  10335   "RTN","CHG CDV7",159, 0)
  10336    Q
  10337   "RTN","CHG CDV7",160, 0)
  10338    ;
  10339   "RTN","CHG CDV7",161, 0)
  10340   GTEDI S (C HSTMTP,CHA DMHR,CHDIS HR,CHRELCS 1,CHRELCS2 ,CHRELCS3) =""
  10341   "RTN","CHG CDV7",162, 0)
  10342    Q:'$D(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","AA"))
  10343   "RTN","CHG CDV7",163, 0)
  10344    S EREC=^T MP($J,"CCD ",CHCLM,CH TYPE,"EDI- II","AA")
  10345   "RTN","CHG CDV7",164, 0)
  10346    S CHSTMTP =$P(EREC,U ,1),CHADMH R=$P(EREC, U,2),CHDIS HR=$P(EREC ,U,3)
  10347   "RTN","CHG CDV7",165, 0)
  10348    S CHRELCS 1=$P(EREC, U,4),CHREL CS2=$P(ERE C,U,5),CHR ELCS3=$P(E REC,U,6)
  10349   "RTN","CHG CDV7",166, 0)
  10350    S X="X XY  W @CHBON, ""Statemen t Coverage  Period: " ",@CHBOFF, P1"
  10351   "RTN","CHG CDV7",167, 0)
  10352    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHSTMTP
  10353   "RTN","CHG CDV7",168, 0)
  10354    S X="X XY  W @CHBON, ""Admissio n Hour: "" ,@CHBOFF,P 1 S DX=32  X XY W @CH BON,""Disc harge Hour : "",@CHBO FF,P2"
  10355   "RTN","CHG CDV7",169, 0)
  10356    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHADMHR _U_CHDISHR
  10357   "RTN","CHG CDV7",170, 0)
  10358    Q
  10359   "RTN","CHG CDV7",171, 0)
  10360    ;
  10361   "RTN","CHG CDV7",172, 0)
  10362   SPACE I CH FL=0 D UPC T S ^UTILI TY($J,"CCD ",CHZONE,C T)=""
  10363   "RTN","CHG CDV7",173, 0)
  10364    Q
  10365   "RTN","CHG CDV7",174, 0)
  10366    ;
  10367   "RTN","CHG CDV7",175, 0)
  10368   PRT S N=0, LCT=1
  10369   "RTN","CHG CDV7",176, 0)
  10370   PT1 S N=$O (PX(N)) I  N="" D:$D( LABEL) BUI LD K PX,LA BEL,PC,N,L CT Q
  10371   "RTN","CHG CDV7",177, 0)
  10372    S LABEL(L CT)=$P(PX( N),U,1),PC (LCT)=$P(P X(N),U,2)
  10373   "RTN","CHG CDV7",178, 0)
  10374    I LABEL(L CT)="Px Ch arge: " S  LCT=3
  10375   "RTN","CHG CDV7",179, 0)
  10376    I LCT=3 I  $O(PX(N))  D BUILD S  LCT=1 K L ABEL,PC G  PT1
  10377   "RTN","CHG CDV7",180, 0)
  10378    S LCT=LCT +1
  10379   "RTN","CHG CDV7",181, 0)
  10380    G PT1
  10381   "RTN","CHG CDV7",182, 0)
  10382    ;
  10383   "RTN","CHG CDV7",183, 0)
  10384   BUILD S X1 ="X XY W @ CHBON,"
  10385   "RTN","CHG CDV7",184, 0)
  10386    S X2=" S  DX=32 X XY  W @CHBON, "
  10387   "RTN","CHG CDV7",185, 0)
  10388    S X3=" S  DX=56 X XY  W @CHBON, "
  10389   "RTN","CHG CDV7",186, 0)
  10390    S X4=",@C HBOFF,P1", X5=",@CHBO FF,P2",X6= ",@CHBOFF, P3"
  10391   "RTN","CHG CDV7",187, 0)
  10392    I $D(LABE L(3)) S X= X1_SP_LABE L(1)_SP_X4 _X2_SP_LAB EL(2)_SP_X 5_X3_SP_LA BEL(3)_SP_ X6 D UPCT  S ^UTILITY ($J,"CCD", CHZONE,CT) =X_U_PC(1) _U_PC(2)_U _PC(3) Q
  10393   "RTN","CHG CDV7",188, 0)
  10394    I $D(LABE L(2)) S X= X1_SP_LABE L(1)_SP_X4 _X2_SP_LAB EL(2)_SP_X 5 D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_PC(1)_ U_PC(2) Q
  10395   "RTN","CHG CDV7",189, 0)
  10396    I $D(LABE L(1)) S X= X1_SP_LABE L(1)_SP_X4  D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_PC(1)
  10397   "RTN","CHG CDV7",190, 0)
  10398    Q
  10399   "RTN","CHG CDV7",191, 0)
  10400    ;
  10401   "RTN","CHG CDV7",192, 0)
  10402   WRTLINE I  CHFL=0 D U PCT S ^UTI LITY($J,"C CD",CHZONE ,CT)="" Q
  10403   "RTN","CHG CDV7",193, 0)
  10404   UPCT S (CT ,^UTILITY( $J,"CCD",C HZONE,0))= CT+1 Q
  10405   "RTN","CHG CDV7",194, 0)
  10406    ;
  10407   "RTN","CHG CDV7",195, 0)
  10408   END K N,Z, JX,X1,X2,X 3,X4,PC,PX ,SP,RCZ,RC ZZ,SUB,CHD ZHS,CHHSDT ,LABEL,HDF L
  10409   "RTN","CHG CDV7",196, 0)
  10410    K LCT,ARR AY,CHFL
  10411   "RTN","CHG CDV7",197, 0)
  10412    Q
  10413   "RTN","CHG CDV70")
  10414   0^20^B8023 3452
  10415   "RTN","CHG CDV70",1,0 )
  10416   CHGCDV70 ; CVA/RLC;CC D INITIAL  INPUT/EDIT S-MODULE 7  VIEW - AL L OTHER TO S ;Feb 05,  2019@10:4 2:17
  10417   "RTN","CHG CDV70",2,0 )
  10418    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  10419   "RTN","CHG CDV70",3,0 )
  10420    ;CPTS #11 834 (RLC)
  10421   "RTN","CHG CDV70",4,0 )
  10422    ;DEV00369 8 4/20/201 0 AEB
  10423   "RTN","CHG CDV70",5,0 )
  10424    ;DEV01938 8 EW 11/7/ 13  POA an d PL Phone
  10425   "RTN","CHG CDV70",6,0 )
  10426    ;CFS 03/0 8/2018 - D efect 6863 82 Display  PL ZIP.
  10427   "RTN","CHG CDV70",7,0 )
  10428    ;CFS 11/2 9/2018 - D efect 8322 80 Do not  display PL  ZIP for D ME, Travel  or Pharma cy.
  10429   "RTN","CHG CDV70",8,0 )
  10430    S U="^",( JX,CHFL)=0  F Z=1:1:1 5 S ARRAY( Z)=""
  10431   "RTN","CHG CDV70",9,0 )
  10432   A1 S JX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX))  G:JX="" EN D
  10433   "RTN","CHG CDV70",10, 0)
  10434    S RCZ=^(J X) K HDFL, EDFLG
  10435   "RTN","CHG CDV70",11, 0)
  10436    S CHDZHS= $P(RCZ,U,1 ),CHHSDT=$ P(RCZ,U,2)
  10437   "RTN","CHG CDV70",12, 0)
  10438    D:CHFL=0  HEADING
  10439   "RTN","CHG CDV70",13, 0)
  10440    D:CHFL=1  HDG
  10441   "RTN","CHG CDV70",14, 0)
  10442    S SUB=""
  10443   "RTN","CHG CDV70",15, 0)
  10444   A2 S SUB=$ O(^TMP($J, "CCD",CHCL M,CHTYPE," HIST",JX,S UB)) I SUB ="" D PRIN T D:CHFL=0  BINIT,VIN IT D LOOP^ CHGCDV73,D EMO S CHFL =CHFL+1 G  A1
  10445   "RTN","CHG CDV70",16, 0)
  10446    S XX=0
  10447   "RTN","CHG CDV70",17, 0)
  10448   A3 S XX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX,SU B,XX)) G:X X="" A2
  10449   "RTN","CHG CDV70",18, 0)
  10450    S RCZZ=^( XX)
  10451   "RTN","CHG CDV70",19, 0)
  10452    I CHFL=0  D BLDII^CH GCDV73 G A 3
  10453   "RTN","CHG CDV70",20, 0)
  10454    I ('$D(HD FL))&(CHFL >0) D HD1  S HDFL=1
  10455   "RTN","CHG CDV70",21, 0)
  10456    S PC=$P(R CZZ,U,1),L ABEL=$P(RC ZZ,U,2)
  10457   "RTN","CHG CDV70",22, 0)
  10458    D ARRIPT^ CHGCDV73
  10459   "RTN","CHG CDV70",23, 0)
  10460    G A3
  10461   "RTN","CHG CDV70",24, 0)
  10462    ;
  10463   "RTN","CHG CDV70",25, 0)
  10464   DEMO S LNF LG=0
  10465   "RTN","CHG CDV70",26, 0)
  10466    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"BENE-D D")) D BEN DD^CHGCDV7 6 S LNFLG= 1
  10467   "RTN","CHG CDV70",27, 0)
  10468    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"PSEUDO -DD")) D P SVNDD^CHGC DV76 S LNF LG=1
  10469   "RTN","CHG CDV70",28, 0)
  10470    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-DD ")) D VEND D^CHGCDV76  S LNFLG=1
  10471   "RTN","CHG CDV70",29, 0)
  10472    Q
  10473   "RTN","CHG CDV70",30, 0)
  10474    ;
  10475   "RTN","CHG CDV70",31, 0)
  10476   HEADING D  UPCT S ^UT ILITY($J," CCD",CHZON E,CT)=""
  10477   "RTN","CHG CDV70",32, 0)
  10478    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" X XY S DX= 20 X XY W  @CHBON,""/ /////////" ",@CHBOFF  S DX=33 X  XY W @CHBO N,""Initia l Input"", @CHBOFF S  DX=49 X XY  W @CHBON, ""//////// //"",@CHBO FF"
  10479   "RTN","CHG CDV70",33, 0)
  10480    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" "
  10481   "RTN","CHG CDV70",34, 0)
  10482    S X="X XY  W @CHBON, ""Date: "" ,@CHBOFF,P 1 S DX=32  X XY W @CH BON,""VE:  "",@CHBOFF ,P2"
  10483   "RTN","CHG CDV70",35, 0)
  10484    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHHSDT_ U_CHDZHS
  10485   "RTN","CHG CDV70",36, 0)
  10486    Q
  10487   "RTN","CHG CDV70",37, 0)
  10488    ;
  10489   "RTN","CHG CDV70",38, 0)
  10490   HDG D UPCT  S ^UTILIT Y($J,"CCD" ,CHZONE,CT )=""
  10491   "RTN","CHG CDV70",39, 0)
  10492    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" X XY S DX= 20 X XY W  @CHBON,""/ /////////" ",@CHBOFF  S DX=33 X  XY W @CHBO N,""Edit H istory"",@ CHBOFF S D X=49 X XY  W @CHBON," "///////// /"",@CHBOF F"
  10493   "RTN","CHG CDV70",40, 0)
  10494    Q
  10495   "RTN","CHG CDV70",41, 0)
  10496   HD1 D UPCT  S ^UTILIT Y($J,"CCD" ,CHZONE,CT )=""
  10497   "RTN","CHG CDV70",42, 0)
  10498    S X="X XY  W @CHBON, ""Date: "" ,@CHBOFF,P 1 S DX=32  X XY W @CH BON,""User : "",@CHBO FF,P2"
  10499   "RTN","CHG CDV70",43, 0)
  10500    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHHSDT_ U_CHDZHS
  10501   "RTN","CHG CDV70",44, 0)
  10502    Q
  10503   "RTN","CHG CDV70",45, 0)
  10504    ;
  10505   "RTN","CHG CDV70",46, 0)
  10506   PRINT S (Z ,CHCHGHS)= 0,LCT=1 K  XTMP
  10507   "RTN","CHG CDV70",47, 0)
  10508    N TMPLABE L,TMPPC  ; CFS add ne w variable s for Defe ct 686382
  10509   "RTN","CHG CDV70",48, 0)
  10510   PR1 S Z=$O (ARRAY(Z))  I Z="" D: $D(LABEL)  BUILD,SPAC E K ARRAY, LABEL,PC,Z ,LCT,TMPLA BEL,TMPPC  Q
  10511   "RTN","CHG CDV70",49, 0)
  10512    S LABEL(L CT)=$P(ARR AY(Z),U,1) ,PC(LCT)=$ P(ARRAY(Z) ,U,2)
  10513   "RTN","CHG CDV70",50, 0)
  10514    G:'$D(LAB EL) PR1
  10515   "RTN","CHG CDV70",51, 0)
  10516    I LABEL(L CT)="Total  Charge: "  D  ;G PR1    Defect  686382
  10517   "RTN","CHG CDV70",52, 0)
  10518    .S CHCHGH S=PC(LCT)
  10519   "RTN","CHG CDV70",53, 0)
  10520    .;K LABEL (2),PC(2), LABEL(3),P C(3)  ;AEB  7/19/2010  DEV003698   REMOVED  LINE TO AL LOW POP TO  PRINT
  10521   "RTN","CHG CDV70",54, 0)
  10522    .S EDFLG= ""
  10523   "RTN","CHG CDV70",55, 0)
  10524    .Q
  10525   "RTN","CHG CDV70",56, 0)
  10526    ;-- Begin  Defect 68 6382 --
  10527   "RTN","CHG CDV70",57, 0)
  10528    I LABEL(L CT)="PL ZI P: " D  G  PR1
  10529   "RTN","CHG CDV70",58, 0)
  10530    .I CHTOS= "DURABLE M EDICAL"!(C HTOS="TRAV EL")!(CHTO S="PHARMAC Y") K LABE L Q  ;cfs  Defect 832 280
  10531   "RTN","CHG CDV70",59, 0)
  10532    .S LABEL( 2)=LABEL(L CT),PC(2)= PC(LCT),LA BEL(1)="", PC(1)="",L ABEL(3)="" ,PC(3)=""  ;
  10533   "RTN","CHG CDV70",60, 0)
  10534    .D BUILD  K LABEL,PC
  10535   "RTN","CHG CDV70",61, 0)
  10536    .S EDFLG= ""
  10537   "RTN","CHG CDV70",62, 0)
  10538    ;-- End D efect 6863 82 --
  10539   "RTN","CHG CDV70",63, 0)
  10540    I LABEL(L CT)="Medic aid Agency : " K XTEM P D  G PR1
  10541   "RTN","CHG CDV70",64, 0)
  10542    .S (CHMDN M,MTAX,CHM DTX,MDAD,M DMD,MAD1,M AD2,MCTY,M ST,MSTP,MZ IP)=""
  10543   "RTN","CHG CDV70",65, 0)
  10544    .Q:'$D(PC (LCT))  Q: PC(LCT)=""
  10545   "RTN","CHG CDV70",66, 0)
  10546    .S PC=PC( LCT)
  10547   "RTN","CHG CDV70",67, 0)
  10548    .Q:PC=""   Q:PC=" "   ;AEB 4/13 /2009  DEV 007079 ADD ED QUIT TO  ALLOW ROU TINE TO CO NTINUE
  10549   "RTN","CHG CDV70",68, 0)
  10550    .Q:'$D(^C HMVEN(PC,0 ))   ;DTF  FEB 2013 S LLA7820
  10551   "RTN","CHG CDV70",69, 0)
  10552    .S RC=^CH MVEN(PC,0)   ; Undefi ned error  9/2/05 mlr
  10553   "RTN","CHG CDV70",70, 0)
  10554    .S CHMDNM =$P(RC,U,1 ),MTAX=$P( RC,U,3),MD AD=$P(RC,U ,23)
  10555   "RTN","CHG CDV70",71, 0)
  10556    .S:MDAD=" " MDAD="   "
  10557   "RTN","CHG CDV70",72, 0)
  10558    .S:$D(^CH MVEN(RC,14 )) MDMD=$P (^(14),U,1 )
  10559   "RTN","CHG CDV70",73, 0)
  10560    .S:MDMD=" " MDMD="   "
  10561   "RTN","CHG CDV70",74, 0)
  10562    .S CHMDTX =MTAX_"-"_ MDAD_"-"_M DMD
  10563   "RTN","CHG CDV70",75, 0)
  10564    .I $D(^CH MVEN(PC,1) ) S RC=^(1 ) D
  10565   "RTN","CHG CDV70",76, 0)
  10566    ..S MAD1= $P(RC,U,1) ,MAD2=$P(R C,U,2),MCT Y=$P(RC,U, 3)
  10567   "RTN","CHG CDV70",77, 0)
  10568    ..S MST=$ P(RC,U,4), MZIP=$P(RC ,U,5)
  10569   "RTN","CHG CDV70",78, 0)
  10570    ..I MST'= "" I $D(^D IC(5,MST,0 )) S MSTP= $P(^(0),U, 2)
  10571   "RTN","CHG CDV70",79, 0)
  10572    .S XTEMP( CHMDNM)=CH MDTX_U_MAD 1_U_MAD2_U _MCTY_U_MS TP_U_MZIP
  10573   "RTN","CHG CDV70",80, 0)
  10574    .;-- Begi n Defect 6 86382 fix  Medicaid o verwriting  Bene Paym nt and POP 1 --
  10575   "RTN","CHG CDV70",81, 0)
  10576    .I LCT=3  D
  10577   "RTN","CHG CDV70",82, 0)
  10578    ..S TMPLA BEL=LABEL( LCT),TMPPC =PC(LCT)
  10579   "RTN","CHG CDV70",83, 0)
  10580    ..S LABEL (LCT)="",P C(LCT)=""  D BUILD
  10581   "RTN","CHG CDV70",84, 0)
  10582    ..S LABEL (1)=TMPLAB EL,PC(1)=T MPPC,LCT=2
  10583   "RTN","CHG CDV70",85, 0)
  10584    .;-- End  Defect 686 382 --
  10585   "RTN","CHG CDV70",86, 0)
  10586    .S EDFLG= ""
  10587   "RTN","CHG CDV70",87, 0)
  10588    .Q
  10589   "RTN","CHG CDV70",88, 0)
  10590    I LABEL(L CT)="Medic aid Paid:  " S RC=""  D  G PR1
  10591   "RTN","CHG CDV70",89, 0)
  10592    .S MEDPAI D=PC(LCT)
  10593   "RTN","CHG CDV70",90, 0)
  10594    .S CHMDNM =""
  10595   "RTN","CHG CDV70",91, 0)
  10596    .S CHMDNM =$O(XTEMP( CHMDNM)) Q :CHMDNM=""
  10597   "RTN","CHG CDV70",92, 0)
  10598    .S RC=XTE MP(CHMDNM)
  10599   "RTN","CHG CDV70",93, 0)
  10600    .S CHMDTX =$P(RC,U,1 ),MAD1=$P( RC,U,2),MA D2=$P(RC,U ,3)
  10601   "RTN","CHG CDV70",94, 0)
  10602    .S MCTY=$ P(RC,U,4), MSTP=$P(RC ,U,5),MZIP =$P(RC,U,6 )
  10603   "RTN","CHG CDV70",95, 0)
  10604    .S X="X X Y W @CHBON ,""Medicai d TIN: "", @CHBOFF,P1  S DX=32 X  XY W @CHB ON,""Medic aid Paid:  "",@CHBOFF ,P2"
  10605   "RTN","CHG CDV70",96, 0)
  10606    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHMDTX _U_MEDPAID
  10607   "RTN","CHG CDV70",97, 0)
  10608    .S X="X X Y W @CHBON ,""Medicai d Agency:  "",@CHBOFF ,P1"
  10609   "RTN","CHG CDV70",98, 0)
  10610    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHMDNM
  10611   "RTN","CHG CDV70",99, 0)
  10612    .S X="X X Y W @CHBON ,""Addr1:  "",@CHBOFF ,P1"
  10613   "RTN","CHG CDV70",100 ,0)
  10614    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MAD1
  10615   "RTN","CHG CDV70",101 ,0)
  10616    .S X="X X Y W @CHBON ,""Addr2:  "",@CHBOFF ,P2"
  10617   "RTN","CHG CDV70",102 ,0)
  10618    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MAD2
  10619   "RTN","CHG CDV70",103 ,0)
  10620    .S X="X X Y W @CHBON ,""City: " ",@CHBOFF, P1 S DX=32  X XY W @C HBON,""Sta te: "",@CH BOFF,P2 S  DX=42 X XY  W @CHBON, ""Zip: "", @CHBOFF,P3 "
  10621   "RTN","CHG CDV70",104 ,0)
  10622    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MCTY_U _MSTP_U_MZ IP
  10623   "RTN","CHG CDV70",105 ,0)
  10624    .S TAB=0, CNTR=1
  10625   "RTN","CHG CDV70",106 ,0)
  10626    .S LCT=1  K LABEL,PC
  10627   "RTN","CHG CDV70",107 ,0)
  10628    .S EDFLG= ""
  10629   "RTN","CHG CDV70",108 ,0)
  10630    .Q
  10631   "RTN","CHG CDV70",109 ,0)
  10632    S SP=""""
  10633   "RTN","CHG CDV70",110 ,0)
  10634   PR2 I LCT= 3 I $O(ARR AY(Z)) D B UILD S LCT =1,EDFLG=" " G PR1
  10635   "RTN","CHG CDV70",111 ,0)
  10636    S LCT=LCT +1
  10637   "RTN","CHG CDV70",112 ,0)
  10638    S EDFLG=" "
  10639   "RTN","CHG CDV70",113 ,0)
  10640    G PR1
  10641   "RTN","CHG CDV70",114 ,0)
  10642    ;
  10643   "RTN","CHG CDV70",115 ,0)
  10644   BINIT Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," BEN-II"))
  10645   "RTN","CHG CDV70",116 ,0)
  10646    S RCX=^(" BEN-II")
  10647   "RTN","CHG CDV70",117 ,0)
  10648    S CHBNAM= $P(RCX,U,1 ),CHBSSN=$ P(RCX,U,2) ,CHBNDOB=$ P(RCX,U,3) ,CHBNREL=$ P(RCX,U,4) ,CHBNAD1=$ P(RCX,U,5) ,CHBNAD2=$ P(RCX,U,6) ,CHBNCTY=$ P(RCX,U,7) ,CHBNST=$P (RCX,U,8), CHBNZIP=$P (RCX,U,9), CHBSEX=$P( RCX,U,10), CHBAGE=$P( RCX,U,11)
  10649   "RTN","CHG CDV70",118 ,0)
  10650    D WRTLINE
  10651   "RTN","CHG CDV70",119 ,0)
  10652    S X="X XY  W @CHBON, ""Patient:  "",@CHBOF F,P1 S DX= 42 X XY W  @CHBON,""S SN: "",@CH BOFF,P2"
  10653   "RTN","CHG CDV70",120 ,0)
  10654    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAM_ U_CHBSSN
  10655   "RTN","CHG CDV70",121 ,0)
  10656    S X="X XY  W @CHBON, ""DOB: "", @CHBOFF,P1  S DX=18 X  XY W @CHB ON,""Age:  "",@CHBOFF ,P2 S DX=3 0 X XY W @ CHBON,""Se x: "",@CHB OFF,P3 S D X=42 X XY  W @CHBON," "Relations hip: "",@C HBOFF,P4"
  10657   "RTN","CHG CDV70",122 ,0)
  10658    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNDOB _U_CHBAGE_ U_CHBSEX_U _CHBNREL
  10659   "RTN","CHG CDV70",123 ,0)
  10660    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1"
  10661   "RTN","CHG CDV70",124 ,0)
  10662    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAD1
  10663   "RTN","CHG CDV70",125 ,0)
  10664    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1"
  10665   "RTN","CHG CDV70",126 ,0)
  10666    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAD2
  10667   "RTN","CHG CDV70",127 ,0)
  10668    S X="X XY  W @CHBON, ""City: "" ,@CHBOFF,P 1 S DX=28  X XY W @CH BON,""Stat e: "",@CHB OFF,P2 S D X=50 X XY  W @CHBON," "Zip: "",@ CHBOFF,P3"
  10669   "RTN","CHG CDV70",128 ,0)
  10670    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNCTY _U_CHBNST_ U_CHBNZIP
  10671   "RTN","CHG CDV70",129 ,0)
  10672    Q
  10673   "RTN","CHG CDV70",130 ,0)
  10674    ;
  10675   "RTN","CHG CDV70",131 ,0)
  10676   VINIT S (R TC,RPC)=""
  10677   "RTN","CHG CDV70",132 ,0)
  10678    S:$D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-II ","RT-VEN" )) RTC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"VEN-I I","RT-VEN ")
  10679   "RTN","CHG CDV70",133 ,0)
  10680    S:$D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-II ","PL-VEN" )) RPC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"VEN-I I","PL-VEN ")
  10681   "RTN","CHG CDV70",134 ,0)
  10682    I RTC=""  D  G VIN
  10683   "RTN","CHG CDV70",135 ,0)
  10684    .S (CHVEN RI,CHTAXIP ,CHVADR1,C HVADR2,CHV ADRCY,CHRS TP,CHVNRZP )=""
  10685   "RTN","CHG CDV70",136 ,0)
  10686    .S (CHVPH S,CHVNPHN, CHVPGHS)=" "
  10687   "RTN","CHG CDV70",137 ,0)
  10688    .Q
  10689   "RTN","CHG CDV70",138 ,0)
  10690    S CHVENRI =$P(RTC,U, 1),CHTAXIP =$P(RTC,U, 2),CHVADR1 =$P(RTC,U, 3)
  10691   "RTN","CHG CDV70",139 ,0)
  10692    S CHVADR2 =$P(RTC,U, 4),CHVADRC Y=$P(RTC,U ,5),CHRSTP =$P(RTC,U, 6)
  10693   "RTN","CHG CDV70",140 ,0)
  10694    S CHVNRZP =$P(RTC,U, 7),CHVNPHN =$P(RTC,U, 8)
  10695   "RTN","CHG CDV70",141 ,0)
  10696   VIN I RPC= "" D  G VI NP
  10697   "RTN","CHG CDV70",142 ,0)
  10698    .S (CHVEN PI,CHVADP1 ,CHVADP2,C HVADPCY,CH PSTP,CHVNP ZP,CHVPGHS ,CHCMACII) =""
  10699   "RTN","CHG CDV70",143 ,0)
  10700    .S (CHCMA CII,CHTAXI P,CHVNPHN, CHVPOA,CHV PPPN)=""   ;DEV019388   EW  11/1 3/13
  10701   "RTN","CHG CDV70",144 ,0)
  10702    .Q
  10703   "RTN","CHG CDV70",145 ,0)
  10704    S CHVENPI =$P(RPC,U, 1),CHVADP1 =$P(RPC,U, 2),CHVADP2 =$P(RPC,U, 3)
  10705   "RTN","CHG CDV70",146 ,0)
  10706    S CHVADPC Y=$P(RPC,U ,4),CHPSTP =$P(RPC,U, 5),CHVNPZP =$P(RPC,U, 6)
  10707   "RTN","CHG CDV70",147 ,0)
  10708    S CHVPPPN =$P(RPC,U, 7),CHVPOA= $P(RPC,U,8 ),CHCMACII =$P(RPC,U, 9)  ;DEV01 9388  EW   11/13/13
  10709   "RTN","CHG CDV70",148 ,0)
  10710   VINP D WRT LINE
  10711   "RTN","CHG CDV70",149 ,0)
  10712    S X="X XY  W @CHBON, ""Tax ID:  "",@CHBOFF ,P1 S DX=3 2 X XY W @ CHBON,""Ve n POA Exmp t: "",@CHB OFF,P2 S D X=55 X XY  W @CHBON," "CMAC: "", @CHBOFF,P3 "  ;DEV019 388  EW  1 1/13/13
  10713   "RTN","CHG CDV70",150 ,0)
  10714    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHTAXIP _U_CHVPOA_ U_CHCMACII   ;DEV0193 88  EW  11 /13/13
  10715   "RTN","CHG CDV70",151 ,0)
  10716    S X="X XY  W @CHBON, ""RT Ven:  "",@CHBOFF ,P1 S DX=4 0 X XY W @ CHBON,""PL  Ven: "",@ CHBOFF,P2"
  10717   "RTN","CHG CDV70",152 ,0)
  10718    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVENRI _U_CHVENPI
  10719   "RTN","CHG CDV70",153 ,0)
  10720    S X="X XY  W @CHBON, ""Phone: " ",@CHBOFF, P1 S DX=40  X XY W @C HBON,""Pho ne: "",@CH BOFF,P2"   ;DEV019388   EW  11/1 3/13
  10721   "RTN","CHG CDV70",154 ,0)
  10722    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVNPHN _U_CHVPPPN   ;DEV0193 88  EW  11 /13/13
  10723   "RTN","CHG CDV70",155 ,0)
  10724    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=40  X XY W @C HBON,""Add r1: "",@CH BOFF,P2"
  10725   "RTN","CHG CDV70",156 ,0)
  10726    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADR1 _U_CHVADP1
  10727   "RTN","CHG CDV70",157 ,0)
  10728    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1 S DX=40  X XY W @C HBON,""Add r2: "",@CH BOFF,P2"
  10729   "RTN","CHG CDV70",158 ,0)
  10730    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADR2 _U_CHVADP2
  10731   "RTN","CHG CDV70",159 ,0)
  10732    S X="X XY  W @CHBON, ""City: "" ,@CHBOFF,P 1 S DX=40  X XY W @CH BON,""City : "",@CHBO FF,P2"
  10733   "RTN","CHG CDV70",160 ,0)
  10734    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADRC Y_U_CHVADP CY
  10735   "RTN","CHG CDV70",161 ,0)
  10736    S X="X XY  W @CHBON, ""State: " ",@CHBOFF, P1 S DX=12  X XY W @C HBON,""Zip : "",@CHBO FF,P2 S DX =40 X XY W  @CHBON,"" State: "", @CHBOFF,P3  S DX=52 X  XY W @CHB ON,""Zip:  "",@CHBOFF ,P4"
  10737   "RTN","CHG CDV70",162 ,0)
  10738    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHRSTP_ U_CHVNRZP_ U_CHPSTP_U _CHVNPZP
  10739   "RTN","CHG CDV70",163 ,0)
  10740    D WRTLINE
  10741   "RTN","CHG CDV70",164 ,0)
  10742    Q
  10743   "RTN","CHG CDV70",165 ,0)
  10744    ;
  10745   "RTN","CHG CDV70",166 ,0)
  10746   SPACE I CH FL=0 D UPC T S ^UTILI TY($J,"CCD ",CHZONE,C T)=""
  10747   "RTN","CHG CDV70",167 ,0)
  10748    Q
  10749   "RTN","CHG CDV70",168 ,0)
  10750    ;
  10751   "RTN","CHG CDV70",169 ,0)
  10752   PRT S N=0, LCT=1
  10753   "RTN","CHG CDV70",170 ,0)
  10754   PT1 S N=$O (PX(N)) I  N="" D:$D( LABEL) BUI LD K PX,LA BEL,PC,N,L CT Q
  10755   "RTN","CHG CDV70",171 ,0)
  10756    S LABEL(L CT)=$P(PX( N),U,1),PC (LCT)=$P(P X(N),U,2)
  10757   "RTN","CHG CDV70",172 ,0)
  10758    I LABEL(L CT)="Px Ch arge: " S  LCT=3
  10759   "RTN","CHG CDV70",173 ,0)
  10760    I LCT=3 I  $O(PX(N))  D BUILD S  LCT=1 K L ABEL,PC G  PT1
  10761   "RTN","CHG CDV70",174 ,0)
  10762    S LCT=LCT +1
  10763   "RTN","CHG CDV70",175 ,0)
  10764    G PT1
  10765   "RTN","CHG CDV70",176 ,0)
  10766    ;
  10767   "RTN","CHG CDV70",177 ,0)
  10768   BUILD S X1 ="X XY W @ CHBON,"
  10769   "RTN","CHG CDV70",178 ,0)
  10770    S X2=" S  DX=32 X XY  W @CHBON, "
  10771   "RTN","CHG CDV70",179 ,0)
  10772    S X3=" S  DX=56 X XY  W @CHBON, "
  10773   "RTN","CHG CDV70",180 ,0)
  10774    S X4=",@C HBOFF,P1", X5=",@CHBO FF,P2",X6= ",@CHBOFF, P3"
  10775   "RTN","CHG CDV70",181 ,0)
  10776    I $D(LABE L(3)) S X= X1_SP_LABE L(1)_SP_X4 _X2_SP_LAB EL(2)_SP_X 5_X3_SP_LA BEL(3)_SP_ X6 D UPCT  S ^UTILITY ($J,"CCD", CHZONE,CT) =X_U_PC(1) _U_PC(2)_U _PC(3) Q
  10777   "RTN","CHG CDV70",182 ,0)
  10778    I $D(LABE L(2)) S X= X1_SP_LABE L(1)_SP_X4 _X2_SP_LAB EL(2)_SP_X 5 D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_PC(1)_ U_PC(2) Q
  10779   "RTN","CHG CDV70",183 ,0)
  10780    I $D(LABE L(1)) S X= X1_SP_LABE L(1)_SP_X4  D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_PC(1)
  10781   "RTN","CHG CDV70",184 ,0)
  10782    Q
  10783   "RTN","CHG CDV70",185 ,0)
  10784    ;
  10785   "RTN","CHG CDV70",186 ,0)
  10786   WRTLINE I  CHFL=0 D U PCT S ^UTI LITY($J,"C CD",CHZONE ,CT)="" Q
  10787   "RTN","CHG CDV70",187 ,0)
  10788   UPCT S (CT ,^UTILITY( $J,"CCD",C HZONE,0))= CT+1 Q
  10789   "RTN","CHG CDV70",188 ,0)
  10790    ;
  10791   "RTN","CHG CDV70",189 ,0)
  10792   END K N,Z, JX,X1,X2,X 3,X4,PC,PX ,SP,RCZ,RC ZZ,SUB,CHD ZHS,CHHSDT ,LABEL,HDF L
  10793   "RTN","CHG CDV70",190 ,0)
  10794    K LCT,ARR AY,CHFL
  10795   "RTN","CHG CDV70",191 ,0)
  10796    Q
  10797   "RTN","CHG CDV71")
  10798   0^21^B9785 8452
  10799   "RTN","CHG CDV71",1,0 )
  10800   CHGCDV71 ; CVA/RLC;CC D EDIT HIS TORY-MODUL E 7 VIEW-2  ;Feb 05,  2019@11:18 :50
  10801   "RTN","CHG CDV71",2,0 )
  10802    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  10803   "RTN","CHG CDV71",3,0 )
  10804    ;CPTS #11 832* (RLC)
  10805   "RTN","CHG CDV71",4,0 )
  10806    ; CPE001- 004 WTC 6/ 23/17
  10807   "RTN","CHG CDV71",5,0 )
  10808   BLDII S PC =$P(RCZZ,U ,1),LABEL= $P(RCZZ,U, 2)
  10809   "RTN","CHG CDV71",6,0 )
  10810    S:LABEL=" Type Servi ce: " ARRA Y(1)=LABEL _U_PC
  10811   "RTN","CHG CDV71",7,0 )
  10812    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  10813   "RTN","CHG CDV71",8,0 )
  10814    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  10815   "RTN","CHG CDV71",9,0 )
  10816    S:LABEL=" Admission:  " ARRAY(4 )=LABEL_U_ PC
  10817   "RTN","CHG CDV71",10, 0)
  10818    S:LABEL=" Pay Provid er: " ARRA Y(5)=LABEL _U_PC
  10819   "RTN","CHG CDV71",11, 0)
  10820    S:LABEL=" Dis Status : " ARRAY( 6)=LABEL_U _PC
  10821   "RTN","CHG CDV71",12, 0)
  10822    S:LABEL=" Discharge:  " ARRAY(7 )=LABEL_U_ PC
  10823   "RTN","CHG CDV71",13, 0)
  10824    S:LABEL=" MCCR Revie w: " ARRAY (8)=LABEL_ U_PC
  10825   "RTN","CHG CDV71",14, 0)
  10826    S:LABEL=" Fac Discha rged to: "  ARRAY(9)= LABEL_U_PC
  10827   "RTN","CHG CDV71",15, 0)
  10828    S:LABEL=" OHI Type:  " ARRAY(10 )=LABEL_U_ PC
  10829   "RTN","CHG CDV71",16, 0)
  10830    S:LABEL=" OHI Begin:  " ARRAY(1 1)=LABEL_U _PC
  10831   "RTN","CHG CDV71",17, 0)
  10832    S:LABEL=" OHI End: "  ARRAY(12) =LABEL_U_P C
  10833   "RTN","CHG CDV71",18, 0)
  10834    S:LABEL=" OHI Name:  " ARRAY(13 )=LABEL_U_ PC
  10835   "RTN","CHG CDV71",19, 0)
  10836    S:LABEL=" OHI Paymt:  " ARRAY(1 4)=LABEL_U _PC
  10837   "RTN","CHG CDV71",20, 0)
  10838    S:LABEL=" Bene Paymt : " ARRAY( 15)=LABEL_ U_PC
  10839   "RTN","CHG CDV71",21, 0)
  10840    S:LABEL=" Medicaid A gency: " A RRAY(16)=L ABEL_U_PC
  10841   "RTN","CHG CDV71",22, 0)
  10842    S:LABEL=" Medicaid P aid: " ARR AY(17)=LAB EL_U_PC
  10843   "RTN","CHG CDV71",23, 0)
  10844    S:LABEL=" Admitting  DX: " ARRA Y(18)=LABE L_U_PC
  10845   "RTN","CHG CDV71",24, 0)
  10846    S:LABEL=" Total Char ge: " ARRA Y(19)=LABE L_U_PC
  10847   "RTN","CHG CDV71",25, 0)
  10848    S:LABEL=" PL ZIP: "  ARRAY(20)= LABEL_U_PC  ; WTC 6/2 3/17
  10849   "RTN","CHG CDV71",26, 0)
  10850    K PC,LABE L
  10851   "RTN","CHG CDV71",27, 0)
  10852    Q
  10853   "RTN","CHG CDV71",28, 0)
  10854    ;
  10855   "RTN","CHG CDV71",29, 0)
  10856   ARRIPT S:L ABEL="Type  Service:  " ARRAY(1) =LABEL_U_P C
  10857   "RTN","CHG CDV71",30, 0)
  10858    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  10859   "RTN","CHG CDV71",31, 0)
  10860    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  10861   "RTN","CHG CDV71",32, 0)
  10862    S:LABEL=" Admission:  " ARRAY(4 )=LABEL_U_ PC
  10863   "RTN","CHG CDV71",33, 0)
  10864    S:LABEL=" Pay Provid er: " ARRA Y(5)=LABEL _U_PC
  10865   "RTN","CHG CDV71",34, 0)
  10866    S:LABEL=" Dis Status : " ARRAY( 6)=LABEL_U _PC
  10867   "RTN","CHG CDV71",35, 0)
  10868    S:LABEL=" Discharge:  " ARRAY(7 )=LABEL_U_ PC
  10869   "RTN","CHG CDV71",36, 0)
  10870    S:LABEL=" MCCR Revie w: " ARRAY (8)=LABEL_ U_PC
  10871   "RTN","CHG CDV71",37, 0)
  10872    S:LABEL=" Fac Discha rged to: "  ARRAY(9)= LABEL_U_PC
  10873   "RTN","CHG CDV71",38, 0)
  10874    S:LABEL=" OHI Type:  " ARRAY(10 )=LABEL_U_ PC
  10875   "RTN","CHG CDV71",39, 0)
  10876    S:LABEL=" OHI Begin:  " ARRAY(1 1)=LABEL_U _PC
  10877   "RTN","CHG CDV71",40, 0)
  10878    S:LABEL=" OHI End: "  ARRAY(12) =LABEL_U_P C
  10879   "RTN","CHG CDV71",41, 0)
  10880    S:LABEL=" OHI Name:  " ARRAY(13 )=LABEL_U_ PC
  10881   "RTN","CHG CDV71",42, 0)
  10882    S:LABEL=" OHI Paymt:  " ARRAY(1 4)=LABEL_U _PC
  10883   "RTN","CHG CDV71",43, 0)
  10884    S:LABEL=" Bene Paymt : " ARRAY( 15)=LABEL_ U_PC
  10885   "RTN","CHG CDV71",44, 0)
  10886    S:LABEL=" Medicaid A gency: " A RRAY(16)=L ABEL_U_PC
  10887   "RTN","CHG CDV71",45, 0)
  10888    S:LABEL=" Medicaid P aid: " ARR AY(17)=LAB EL_U_PC
  10889   "RTN","CHG CDV71",46, 0)
  10890    S:LABEL=" Admitting  DX: " ARRA Y(18)=LABE L_U_PC
  10891   "RTN","CHG CDV71",47, 0)
  10892    S:LABEL=" Total Char ge: " ARRA Y(19)=LABE L_U_PC
  10893   "RTN","CHG CDV71",48, 0)
  10894    K PC,LABE L
  10895   "RTN","CHG CDV71",49, 0)
  10896    Q
  10897   "RTN","CHG CDV71",50, 0)
  10898   LOOP K ADX FLG,VENFLG
  10899   "RTN","CHG CDV71",51, 0)
  10900    D VENHIS  D:$D(VENFL G) PRT
  10901   "RTN","CHG CDV71",52, 0)
  10902    D:$D(XTMP ) ADMDX
  10903   "RTN","CHG CDV71",53, 0)
  10904    D DX
  10905   "RTN","CHG CDV71",54, 0)
  10906    D PROC
  10907   "RTN","CHG CDV71",55, 0)
  10908    D REVENUE
  10909   "RTN","CHG CDV71",56, 0)
  10910    D NONCOV
  10911   "RTN","CHG CDV71",57, 0)
  10912    D EDICLM
  10913   "RTN","CHG CDV71",58, 0)
  10914    Q
  10915   "RTN","CHG CDV71",59, 0)
  10916    ;
  10917   "RTN","CHG CDV71",60, 0)
  10918   VENHIS Q:' $D(^TMP($J ,"CCD",CHC LM,CHTYPE, "VENPTHS", JX))
  10919   "RTN","CHG CDV71",61, 0)
  10920    I CHFL=0  D HDG^CHGC DV7 S CHFL =1
  10921   "RTN","CHG CDV71",62, 0)
  10922    S VX=0,N= 1
  10923   "RTN","CHG CDV71",63, 0)
  10924   VEN1 S VX= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "VENPTHS", JX,VX)) I  VX="" Q
  10925   "RTN","CHG CDV71",64, 0)
  10926    S CHVENHS =$P(^TMP($ J,"CCD",CH CLM,CHTYPE ,"VENPTHS" ,JX,VX),U, 1)
  10927   "RTN","CHG CDV71",65, 0)
  10928    D  I ($D( PX))&('$D( HDFL))&(CH FL>0) D HD 1^CHGCDP7  S HDFL=1
  10929   "RTN","CHG CDV71",66, 0)
  10930    .I CHVENH S'="" S LA BEL="Vendo r: ",PC=CH VENHS,PX(N )=LABEL_U_ PC,N=N+1
  10931   "RTN","CHG CDV71",67, 0)
  10932    S VENFLG= ""
  10933   "RTN","CHG CDV71",68, 0)
  10934    G VEN1
  10935   "RTN","CHG CDV71",69, 0)
  10936    ;
  10937   "RTN","CHG CDV71",70, 0)
  10938   ADMDX S LA B1=""
  10939   "RTN","CHG CDV71",71, 0)
  10940    S LAB1=$O (XTMP(LAB1 )) Q:LAB1= ""
  10941   "RTN","CHG CDV71",72, 0)
  10942    S PC1=$P( XTMP(LAB1) ,U,1)
  10943   "RTN","CHG CDV71",73, 0)
  10944    S X="X XY  W @CHBON, P1,@CHBOFF  S DX=14 X  XY W P2"
  10945   "RTN","CHG CDV71",74, 0)
  10946    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_LAB1_U_ PC1
  10947   "RTN","CHG CDV71",75, 0)
  10948    S ADXFLG= ""
  10949   "RTN","CHG CDV71",76, 0)
  10950    Q
  10951   "RTN","CHG CDV71",77, 0)
  10952    ;
  10953   "RTN","CHG CDV71",78, 0)
  10954   DX Q:'$D(^ TMP($J,"CC D",CHCLM,C HTYPE,"DXH IST",JX))
  10955   "RTN","CHG CDV71",79, 0)
  10956    D:CHFL=0  DXCOL S DC T=0
  10957   "RTN","CHG CDV71",80, 0)
  10958   D1 S DCT=$ O(^TMP($J, "CCD",CHCL M,CHTYPE," DXHIST",JX ,DCT)) Q:' DCT
  10959   "RTN","CHG CDV71",81, 0)
  10960    S DXREC=^ (DCT)
  10961   "RTN","CHG CDV71",82, 0)
  10962    S CHDXHS= $P(DXREC,U ,1),CHDXHD ES=$P(DXRE C,U,2)
  10963   "RTN","CHG CDV71",83, 0)
  10964    I ('$D(HD FL))&(CHFL >0) D HD1^ CHGCDV7 S  HDFL=1
  10965   "RTN","CHG CDV71",84, 0)
  10966    I CHFL=0  D
  10967   "RTN","CHG CDV71",85, 0)
  10968    .S X="X X Y W P1 S D X=23 X XY  W P2"
  10969   "RTN","CHG CDV71",86, 0)
  10970    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHDXHS _U_$E(CHDX HDES,1,55)
  10971   "RTN","CHG CDV71",87, 0)
  10972    I CHFL>0  D
  10973   "RTN","CHG CDV71",88, 0)
  10974    .S X="X X Y W @CHBON ,""DX Code : "",@CHBO FF,P1 S DX =19 X XY W  ""- "",P2 "
  10975   "RTN","CHG CDV71",89, 0)
  10976    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHDXHS _U_$E(CHDX HDES,1,55)
  10977   "RTN","CHG CDV71",90, 0)
  10978    G D1
  10979   "RTN","CHG CDV71",91, 0)
  10980    ;
  10981   "RTN","CHG CDV71",92, 0)
  10982   DXCOL D UP CT S ^UTIL ITY($J,"CC D",CHZONE, CT)="X XY  W @CHBON,@ CHULON,""D X Codes"", @CHULOFF,@ CHBOFF S D X=12 X XY  W @CHBON,@ CHULON,""S ervice"",@ CHULOFF,@C HBOFF S DX =23 X XY W  @CHBON,@C HULON,""De scription" ",@CHULOFF ,@CHBOFF"
  10983   "RTN","CHG CDV71",93, 0)
  10984    Q
  10985   "RTN","CHG CDV71",94, 0)
  10986    ;
  10987   "RTN","CHG CDV71",95, 0)
  10988   PROC Q:'$D (^TMP($J," CCD",CHCLM ,CHTYPE,"P XHIST",JX) )
  10989   "RTN","CHG CDV71",96, 0)
  10990    S PCT=0
  10991   "RTN","CHG CDV71",97, 0)
  10992   PP1 S PCT= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "PXHIST",J X,PCT)) Q: 'PCT
  10993   "RTN","CHG CDV71",98, 0)
  10994    S PXREC=^ (PCT)
  10995   "RTN","CHG CDV71",99, 0)
  10996    S CHPXHS= $P(PXREC,U ,1),CHPXDS HS=$P(PXRE C,U,2)
  10997   "RTN","CHG CDV71",100 ,0)
  10998    I ('$D(HD FL))&(CHFL >0) D HD1^ CHGCDV7 S  HDFL=1
  10999   "RTN","CHG CDV71",101 ,0)
  11000    I CHFL=0  D
  11001   "RTN","CHG CDV71",102 ,0)
  11002    .S X="S D X=12 X XY  W P1 S DX= 23 X XY W  P2"
  11003   "RTN","CHG CDV71",103 ,0)
  11004    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHPXHS _U_$E(CHPX DSHS,1,55)
  11005   "RTN","CHG CDV71",104 ,0)
  11006    I CHFL>0  D
  11007   "RTN","CHG CDV71",105 ,0)
  11008    .S X="X X Y W @CHBON ,""PX Code : "",@CHBO FF,P1 S DX =19 X XY W  ""- "",P2 "
  11009   "RTN","CHG CDV71",106 ,0)
  11010    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHPXHS _U_$E(CHPX DSHS,1,55)
  11011   "RTN","CHG CDV71",107 ,0)
  11012    G PP1
  11013   "RTN","CHG CDV71",108 ,0)
  11014    ;
  11015   "RTN","CHG CDV71",109 ,0)
  11016   REVENUE D: CHFL=0 REV COL S RCT= 0
  11017   "RTN","CHG CDV71",110 ,0)
  11018    I '$D(^TM P($J,"CCD" ,CHCLM,CHT YPE,"REVHI ST",JX)) D  REVTOT Q
  11019   "RTN","CHG CDV71",111 ,0)
  11020   RV1 S RCT= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "REVHIST", JX,RCT)) I  'RCT D RE VTOT Q
  11021   "RTN","CHG CDV71",112 ,0)
  11022    S RVREC=^ (RCT)
  11023   "RTN","CHG CDV71",113 ,0)
  11024    S CHRVHCD E=$P(RVREC ,U,1),CHRV HDES=$P(RV REC,U,2),C HRVHCHG=$P (RVREC,U,3 )
  11025   "RTN","CHG CDV71",114 ,0)
  11026    I ('$D(HD FL))&(CHFL >0) D HD1^ CHGCDV7 S  HDFL=1
  11027   "RTN","CHG CDV71",115 ,0)
  11028    S X="X XY  W P1 S DX =12 X XY W  P2 S DX=5 2 X XY W P 3 S DX=72  X XY W P4"
  11029   "RTN","CHG CDV71",116 ,0)
  11030    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHRVHCD E_U_CHRVHD ES_U_$J($F N(CHRVHCHG ,",",2),12 )
  11031   "RTN","CHG CDV71",117 ,0)
  11032    G RV1
  11033   "RTN","CHG CDV71",118 ,0)
  11034    ;
  11035   "RTN","CHG CDV71",119 ,0)
  11036   REVCOL Q:C HFL>0
  11037   "RTN","CHG CDV71",120 ,0)
  11038    D WRTLINE
  11039   "RTN","CHG CDV71",121 ,0)
  11040    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" X XY W @CH BON,@CHULO N,""Rev Co des"" S DX =12 X XY W  ""Descrip tion"" S D X=55 X XY  W ""Total  Chg"" S DX =72 X XY W  ""Allowed "",@CHULOF F,@CHBOFF"
  11041   "RTN","CHG CDV71",122 ,0)
  11042    Q
  11043   "RTN","CHG CDV71",123 ,0)
  11044    ;
  11045   "RTN","CHG CDV71",124 ,0)
  11046   REVTOT Q:C HFL>0
  11047   "RTN","CHG CDV71",125 ,0)
  11048    S CHALLOW ="undeterm ined"
  11049   "RTN","CHG CDV71",126 ,0)
  11050    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" S DX=52 X  XY W ""--- ---------" " S DX=67  X XY W ""- ---------- -"""
  11051   "RTN","CHG CDV71",127 ,0)
  11052    S X="S DX =43 X XY W  @CHBON,"" TOTALS"",@ CHBOFF S D X=52 X XY  W $J($FN(P 1,"","",2) ,12) S DX= 67 X XY W  P2"
  11053   "RTN","CHG CDV71",128 ,0)
  11054    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHCHGHS _U_CHALLOW
  11055   "RTN","CHG CDV71",129 ,0)
  11056    Q
  11057   "RTN","CHG CDV71",130 ,0)
  11058    ;
  11059   "RTN","CHG CDV71",131 ,0)
  11060   NONCOV Q:' $D(^TMP($J ,"CCD",CHC LM,CHTYPE, "NCHIST",J X))
  11061   "RTN","CHG CDV71",132 ,0)
  11062    D:CHFL<1  NCOLHD
  11063   "RTN","CHG CDV71",133 ,0)
  11064    S NCT=0
  11065   "RTN","CHG CDV71",134 ,0)
  11066   N1 S NCT=$ O(^TMP($J, "CCD",CHCL M,CHTYPE," NCHIST",JX ,NCT)) Q:' NCT
  11067   "RTN","CHG CDV71",135 ,0)
  11068    S NREC=^( NCT)
  11069   "RTN","CHG CDV71",136 ,0)
  11070    S CHNCITI N=$P(NREC, U,1),CHNCN MIN=$P(NRE C,U,2),CHN CRVIN=$P(N REC,U,3)
  11071   "RTN","CHG CDV71",137 ,0)
  11072    S CHNCUNI N=$P(NREC, U,4),CHDLU NIN=$P(NRE C,U,5),CHN CHGIN=$P(N REC,U,6)
  11073   "RTN","CHG CDV71",138 ,0)
  11074    I ('$D(HD FL))&(CHFL >0) D HD1^ CHGCDV7 S  HDFL=1
  11075   "RTN","CHG CDV71",139 ,0)
  11076    I CHFL>0  D  G N1
  11077   "RTN","CHG CDV71",140 ,0)
  11078    .S X="X X Y W @CHBON ,""Day Pas s Days: "" ,@CHBOFF,P 1"
  11079   "RTN","CHG CDV71",141 ,0)
  11080    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHNCNM IN
  11081   "RTN","CHG CDV71",142 ,0)
  11082    S X="X XY  W P1 S DX =24 X XY W  P2 S DX=3 5 X XY W P 3 S DX=43  X XY W P4  S DX=55 X  XY W P5 S  DX=62 X XY  W P6"
  11083   "RTN","CHG CDV71",143 ,0)
  11084    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_$E(CHNC ITIN,1,20) _U_$J(CHNC RVIN,8)_U_ $J(CHNCUNI N,5)_U_$J( CHDLUNIN,9 )_U_$J(CHN CNMIN,4)_U _$J(CHNCHG IN,9)
  11085   "RTN","CHG CDV71",144 ,0)
  11086    G N1
  11087   "RTN","CHG CDV71",145 ,0)
  11088    ;
  11089   "RTN","CHG CDV71",146 ,0)
  11090   NCOLHD D W RTLINE
  11091   "RTN","CHG CDV71",147 ,0)
  11092    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" X XY W @CH BON,@CHULO N,""Other  Charges""  S DX=24 X  XY W ""Rev  Code"" S  DX=35 X XY  W ""Units "" S DX=45  X XY W "" $/Unit"" S  DX=55 X X Y W ""Days "" S DX=64  X XY W "" Charge"",@ CHULOFF,@C HBOFF"
  11093   "RTN","CHG CDV71",148 ,0)
  11094    Q
  11095   "RTN","CHG CDV71",149 ,0)
  11096    ;
  11097   "RTN","CHG CDV71",150 ,0)
  11098   PRT S N=0, CNT=1
  11099   "RTN","CHG CDV71",151 ,0)
  11100   P1 S N=$O( PX(N)) I N ="" D:$D(L ABEL) BUIL D K PX,LAB EL,PC,N,CN T Q
  11101   "RTN","CHG CDV71",152 ,0)
  11102    S LABEL(C NT)=$P(PX( N),U,1),PC (CNT)=$P(P X(N),U,2)
  11103   "RTN","CHG CDV71",153 ,0)
  11104    G:(LABEL( CNT)="")!( PC(CNT)="" ) P1
  11105   "RTN","CHG CDV71",154 ,0)
  11106   P2 I CNT=3  D BUILD S  CNT=1 W !  K LABEL,P C G P1
  11107   "RTN","CHG CDV71",155 ,0)
  11108    S CNT=CNT +1
  11109   "RTN","CHG CDV71",156 ,0)
  11110    G P1
  11111   "RTN","CHG CDV71",157 ,0)
  11112    ;
  11113   "RTN","CHG CDV71",158 ,0)
  11114   BUILD I $D (LABEL(3))  W LABEL(1 ),PC(1),?2 8,LABEL(2) ,PC(2),?56 ,LABEL(3), PC(3) Q
  11115   "RTN","CHG CDV71",159 ,0)
  11116    I $D(LABE L(2)) W LA BEL(1),PC( 1),?28,LAB EL(2),PC(2 ) W:(CNT<3 ) ! Q
  11117   "RTN","CHG CDV71",160 ,0)
  11118    I $D(LABE L(1)) W LA BEL(1),PC( 1) W:(CNT< 3) !
  11119   "RTN","CHG CDV71",161 ,0)
  11120    Q
  11121   "RTN","CHG CDV71",162 ,0)
  11122   EDICLM S C HOHTYCD=""
  11123   "RTN","CHG CDV71",163 ,0)
  11124   E1 S CHOHT YCD=$O(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD)) Q :CHOHTYCD= ""
  11125   "RTN","CHG CDV71",164 ,0)
  11126    S CHEDOHN M=""
  11127   "RTN","CHG CDV71",165 ,0)
  11128   E2 S CHEDO HNM=$O(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM)) G: CHEDOHNM=" " E1
  11129   "RTN","CHG CDV71",166 ,0)
  11130    D EDIPRT
  11131   "RTN","CHG CDV71",167 ,0)
  11132    S CLADJGR P=""
  11133   "RTN","CHG CDV71",168 ,0)
  11134   E3 S CLADJ GRP=$O(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM,CLAD JGRP)) G:C LADJGRP=""  E2
  11135   "RTN","CHG CDV71",169 ,0)
  11136    W !!,"OHI  Claim Adj ustment Gr oup: ",CLA DJGRP
  11137   "RTN","CHG CDV71",170 ,0)
  11138    S REC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM,CLAD JGRP,1)
  11139   "RTN","CHG CDV71",171 ,0)
  11140    S RCC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM,CLAD JGRP,2)
  11141   "RTN","CHG CDV71",172 ,0)
  11142    S CLAJCD1 =$P(REC,U, 1),CLADJAM 1=$P(REC,U ,2),CLADJQ T1=$P(REC, U,3)
  11143   "RTN","CHG CDV71",173 ,0)
  11144    D:CLAJCD1 '=""
  11145   "RTN","CHG CDV71",174 ,0)
  11146    .S CDI=0, CREC=""
  11147   "RTN","CHG CDV71",175 ,0)
  11148   E31 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD1,CDI))  Q:'CDI
  11149   "RTN","CHG CDV71",176 ,0)
  11150    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E31 S  CREC=^(0)
  11151   "RTN","CHG CDV71",177 ,0)
  11152    .S CLAJCD 1C=$P(CREC ,U,1),CLAJ CD1P=$P(CR EC,U,2)
  11153   "RTN","CHG CDV71",178 ,0)
  11154    .W !?4,"A dj Reason  Code: (",C LAJCD1C,") -"
  11155   "RTN","CHG CDV71",179 ,0)
  11156    .I $L(CLA JCD1P)>55  W ?28,$E(C LAJCD1P,1, 55),!?28,$ E(CLAJCD1P ,56,100)
  11157   "RTN","CHG CDV71",180 ,0)
  11158    .E  W ?28 ,CLAJCD1P
  11159   "RTN","CHG CDV71",181 ,0)
  11160    .W !?4,"A dj Quantit y: ",CLADJ QT1
  11161   "RTN","CHG CDV71",182 ,0)
  11162    .W !?4,"A dj Amount:    ",CLADJ AM1
  11163   "RTN","CHG CDV71",183 ,0)
  11164    .Q
  11165   "RTN","CHG CDV71",184 ,0)
  11166    S CLAJCD2 =$P(REC,U, 4),CLADJAM 2=$P(REC,U ,5),CLADJQ T2=$P(REC, U,6)
  11167   "RTN","CHG CDV71",185 ,0)
  11168    D:CLAJCD2 '=""
  11169   "RTN","CHG CDV71",186 ,0)
  11170    .S CDI=0, CREC=""
  11171   "RTN","CHG CDV71",187 ,0)
  11172   E32 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD2,CDI))  Q:'CDI
  11173   "RTN","CHG CDV71",188 ,0)
  11174    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E32 S  CREC=^(0)
  11175   "RTN","CHG CDV71",189 ,0)
  11176    .S CLAJCD 2C=$P(CREC ,U,1),CLAJ CD2P=$P(CR EC,U,2)
  11177   "RTN","CHG CDV71",190 ,0)
  11178    .W !?4,"A dj Reason  Code: (",C LAJCD2C,") -"
  11179   "RTN","CHG CDV71",191 ,0)
  11180    .I $L(CLA JCD2P)>55  W ?28,$E(C LAJCD2P,1, 55),!?28,$ E(CLAJCD2P ,56,100)
  11181   "RTN","CHG CDV71",192 ,0)
  11182    .E  W ?28 ,CLAJCD2P
  11183   "RTN","CHG CDV71",193 ,0)
  11184    .W !?4,"A dj Quantit y: ",CLADJ QT2
  11185   "RTN","CHG CDV71",194 ,0)
  11186    .W !?4,"A dj Amount:    ",CLADJ AM2
  11187   "RTN","CHG CDV71",195 ,0)
  11188    .Q
  11189   "RTN","CHG CDV71",196 ,0)
  11190    S CLAJCD3 =$P(REC,U, 7),CLADJAM 3=$P(REC,U ,8),CLADJQ T3=$P(REC, U,9)
  11191   "RTN","CHG CDV71",197 ,0)
  11192    D:CLAJCD3 '=""
  11193   "RTN","CHG CDV71",198 ,0)
  11194    .S CDI=0, CREC=""
  11195   "RTN","CHG CDV71",199 ,0)
  11196   E33 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD3,CDI))  Q:'CDI
  11197   "RTN","CHG CDV71",200 ,0)
  11198    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E33 S  CREC=^(0)
  11199   "RTN","CHG CDV71",201 ,0)
  11200    .S CLAJCD 3C=$P(CREC ,U,1),CLAJ CD3P=$P(CR EC,U,2)
  11201   "RTN","CHG CDV71",202 ,0)
  11202    .W !?4,"A dj Reason  Code: (",C LAJCD3C,") -"
  11203   "RTN","CHG CDV71",203 ,0)
  11204    .I $L(CLA JCD3P)>55  W ?28,$E(C LAJCD3P,1, 55),!?28,$ E(CLAJCD3P ,56,100)
  11205   "RTN","CHG CDV71",204 ,0)
  11206    .E  W ?28 ,CLAJCD3P
  11207   "RTN","CHG CDV71",205 ,0)
  11208    .W !?4,"A dj Quantit y: ",CLADJ QT3
  11209   "RTN","CHG CDV71",206 ,0)
  11210    .W !?4,"A dj Amount:    ",CLADJ AM3
  11211   "RTN","CHG CDV71",207 ,0)
  11212    .Q
  11213   "RTN","CHG CDV71",208 ,0)
  11214    S CLAJCD4 =$P(RCC,U, 1),CLADJAM 4=$P(RCC,U ,2),CLADJQ T4=$P(RCC, U,3)
  11215   "RTN","CHG CDV71",209 ,0)
  11216    D:CLAJCD4 '=""
  11217   "RTN","CHG CDV71",210 ,0)
  11218    .S CDI=0, CREC=""
  11219   "RTN","CHG CDV71",211 ,0)
  11220   E34 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD4,CDI))  Q:'CDI
  11221   "RTN","CHG CDV71",212 ,0)
  11222    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E34 S  CREC=^(0)
  11223   "RTN","CHG CDV71",213 ,0)
  11224    .S CLAJCD 4C=$P(CREC ,U,1),CLAJ CD4P=$P(CR EC,U,2)
  11225   "RTN","CHG CDV71",214 ,0)
  11226    .W !?4,"A dj Reason  Code: (",C LAJCD4C,") -"
  11227   "RTN","CHG CDV71",215 ,0)
  11228    .I $L(CLA JCD4P)>55  W ?28,$E(C LAJCD4P,1, 55),!?28,$ E(CLAJCD4P ,56,100)
  11229   "RTN","CHG CDV71",216 ,0)
  11230    .E  W ?28 ,CLAJCD4P
  11231   "RTN","CHG CDV71",217 ,0)
  11232    .W !?4,"A dj Quantit y: ",CLADJ QT4
  11233   "RTN","CHG CDV71",218 ,0)
  11234    .W !?4,"A dj Amount:    ",CLADJ AM4
  11235   "RTN","CHG CDV71",219 ,0)
  11236    .Q
  11237   "RTN","CHG CDV71",220 ,0)
  11238    S CLAJCD5 =$P(RCC,U, 4),CLADJAM 5=$P(RCC,U ,5),CLADJQ T5=$P(RCC, U,6)
  11239   "RTN","CHG CDV71",221 ,0)
  11240    D:CLAJCD5 '=""
  11241   "RTN","CHG CDV71",222 ,0)
  11242    .S CDI=0, CREC=""
  11243   "RTN","CHG CDV71",223 ,0)
  11244   E35 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD5,CDI))  Q:'CDI
  11245   "RTN","CHG CDV71",224 ,0)
  11246    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E35 S  CREC=^(0)
  11247   "RTN","CHG CDV71",225 ,0)
  11248    .S CLAJCD 5C=$P(CREC ,U,1),CLAJ CD5P=$P(CR EC,U,2)
  11249   "RTN","CHG CDV71",226 ,0)
  11250    .W !?4,"A dj Reason  Code: (",C LAJCD5C,") -"
  11251   "RTN","CHG CDV71",227 ,0)
  11252    .I $L(CLA JCD5P)>55  W ?28,$E(C LAJCD5P,1, 55),!?28,$ E(CLAJCD5P ,56,100)
  11253   "RTN","CHG CDV71",228 ,0)
  11254    .E  W ?28 ,CLAJCD5P
  11255   "RTN","CHG CDV71",229 ,0)
  11256    .W !?4,"A dj Quantit y: ",CLADJ QT5
  11257   "RTN","CHG CDV71",230 ,0)
  11258    .W !?4,"A dj Amount:    ",CLADJ AM5
  11259   "RTN","CHG CDV71",231 ,0)
  11260    .Q
  11261   "RTN","CHG CDV71",232 ,0)
  11262    S CLAJCD6 =$P(RCC,U, 7),CLADJAM 6=$P(RCC,U ,8),CLADJQ T6=$P(RCC, U,9)
  11263   "RTN","CHG CDV71",233 ,0)
  11264    D:CLAJCD6 '=""
  11265   "RTN","CHG CDV71",234 ,0)
  11266    .S CDI=0, CREC=""
  11267   "RTN","CHG CDV71",235 ,0)
  11268   E36 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD6,CDI))  Q:'CDI
  11269   "RTN","CHG CDV71",236 ,0)
  11270    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E36 S  CREC=^(0)
  11271   "RTN","CHG CDV71",237 ,0)
  11272    .S CLAJCD 6C=$P(CREC ,U,1),CLAJ CD6P=$P(CR EC,U,2)
  11273   "RTN","CHG CDV71",238 ,0)
  11274    .W !?4,"A dj Reason  Code: (",C LAJCD6C,") -"
  11275   "RTN","CHG CDV71",239 ,0)
  11276    .I $L(CLA JCD6P)>55  W ?28,$E(C LAJCD6P,1, 55),!?28,$ E(CLAJCD6P ,56,100)
  11277   "RTN","CHG CDV71",240 ,0)
  11278    .E  W ?28 ,CLAJCD6P
  11279   "RTN","CHG CDV71",241 ,0)
  11280    .W !?4,"A dj Quantit y: ",CLADJ QT6
  11281   "RTN","CHG CDV71",242 ,0)
  11282    .W !?4,"A dj Amount:    ",CLADJ AM6
  11283   "RTN","CHG CDV71",243 ,0)
  11284    .Q
  11285   "RTN","CHG CDV71",244 ,0)
  11286    G E3
  11287   "RTN","CHG CDV71",245 ,0)
  11288    ;
  11289   "RTN","CHG CDV71",246 ,0)
  11290   EDIPRT S X ="X XY W @ CHBON,""OH I Insuranc e Type Cod e: "",@CHB OFF,P1"
  11291   "RTN","CHG CDV71",247 ,0)
  11292    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHOHTYC D
  11293   "RTN","CHG CDV71",248 ,0)
  11294    S X="S DX =15 X XY W  @CHBON,"" OHI Name:  "",@CHBOFF ,P1"
  11295   "RTN","CHG CDV71",249 ,0)
  11296    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHEDOHN M
  11297   "RTN","CHG CDV71",250 ,0)
  11298    Q
  11299   "RTN","CHG CDV71",251 ,0)
  11300   WRTLINE D  UPCT S ^UT ILITY($J," CCD",CHZON E,CT)="" Q
  11301   "RTN","CHG CDV71",252 ,0)
  11302   UPCT S (CT ,^UTILITY( $J,"CCD",C HZONE,0))= CT+1 Q
  11303   "RTN","CHG CDV73")
  11304   0^24^B4105 7918
  11305   "RTN","CHG CDV73",1,0 )
  11306   CHGCDV73 ; CVA/RLC;CC D EDIT HIS TORY-MODUL E 7 VIEW-2  - ALL OTH ER TOS ;Fe b 05, 2019 @11:20:56
  11307   "RTN","CHG CDV73",2,0 )
  11308    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  11309   "RTN","CHG CDV73",3,0 )
  11310    ;CPTS #11 834 (RLC)
  11311   "RTN","CHG CDV73",4,0 )
  11312    ;DEV00369 8 4/20/201 0 AEB
  11313   "RTN","CHG CDV73",5,0 )
  11314    ;CFS 03/0 7/2018 - D efect 6863 82 Add PL  ZIP.
  11315   "RTN","CHG CDV73",6,0 )
  11316   BLDII S PC =$P(RCZZ,U ,1),LABEL= $P(RCZZ,U, 2)
  11317   "RTN","CHG CDV73",7,0 )
  11318    S:LABEL=" Type Servi ce: " ARRA Y(1)=LABEL _U_PC
  11319   "RTN","CHG CDV73",8,0 )
  11320    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  11321   "RTN","CHG CDV73",9,0 )
  11322    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  11323   "RTN","CHG CDV73",10, 0)
  11324    S:LABEL=" DOS: " ARR AY(4)=LABE L_U_PC
  11325   "RTN","CHG CDV73",11, 0)
  11326    S:LABEL=" POS: " ARR AY(5)=LABE L_U_PC
  11327   "RTN","CHG CDV73",12, 0)
  11328    S:LABEL=" Pay Provid er: " ARRA Y(6)=LABEL _U_PC
  11329   "RTN","CHG CDV73",13, 0)
  11330    S:LABEL=" MCCR Revie w: " ARRAY (7)=LABEL_ U_PC
  11331   "RTN","CHG CDV73",14, 0)
  11332    S:LABEL=" OHI Type:  " ARRAY(8) =LABEL_U_P C
  11333   "RTN","CHG CDV73",15, 0)
  11334    S:LABEL=" OHI Begin:  " ARRAY(9 )=LABEL_U_ PC
  11335   "RTN","CHG CDV73",16, 0)
  11336    S:LABEL=" OHI End: "  ARRAY(10) =LABEL_U_P C
  11337   "RTN","CHG CDV73",17, 0)
  11338    S:LABEL=" OHI Name:  " ARRAY(11 )=LABEL_U_ PC
  11339   "RTN","CHG CDV73",18, 0)
  11340    S:LABEL=" OHI Paymt:  " ARRAY(1 2)=LABEL_U _PC
  11341   "RTN","CHG CDV73",19, 0)
  11342    S:LABEL=" Bene Paymt : " ARRAY( 13)=LABEL_ U_PC
  11343   "RTN","CHG CDV73",20, 0)
  11344    S:LABEL=" POP1: " AR RAY(14)=LA BEL_U_PC   ;AEB 7/19/ 2010 DEV00 3698
  11345   "RTN","CHG CDV73",21, 0)
  11346    S:LABEL=" Medicaid A gency: " A RRAY(15)=L ABEL_U_PC
  11347   "RTN","CHG CDV73",22, 0)
  11348    S:LABEL=" Medicaid P aid: " ARR AY(16)=LAB EL_U_PC
  11349   "RTN","CHG CDV73",23, 0)
  11350    S:LABEL=" Total Char ge: " ARRA Y(17)=LABE L_U_PC
  11351   "RTN","CHG CDV73",24, 0)
  11352    S:LABEL=" PL ZIP: "  ARRAY(18)= LABEL_U_PC   ;Defect  686382 Add  PL ZIP.
  11353   "RTN","CHG CDV73",25, 0)
  11354    K PC,LABE L
  11355   "RTN","CHG CDV73",26, 0)
  11356    Q
  11357   "RTN","CHG CDV73",27, 0)
  11358    ;
  11359   "RTN","CHG CDV73",28, 0)
  11360   ARRIPT S:L ABEL="Type  Service:  " ARRAY(1) =LABEL_U_P C
  11361   "RTN","CHG CDV73",29, 0)
  11362    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  11363   "RTN","CHG CDV73",30, 0)
  11364    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  11365   "RTN","CHG CDV73",31, 0)
  11366    S:LABEL=" DOS: " ARR AY(4)=LABE L_U_PC
  11367   "RTN","CHG CDV73",32, 0)
  11368    S:LABEL=" POS: " ARR AY(5)=LABE L_U_PC
  11369   "RTN","CHG CDV73",33, 0)
  11370    S:LABEL=" Pay Provid er: " ARRA Y(6)=LABEL _U_PC
  11371   "RTN","CHG CDV73",34, 0)
  11372    S:LABEL=" MCCR Revie w: " ARRAY (7)=LABEL_ U_PC
  11373   "RTN","CHG CDV73",35, 0)
  11374    S:LABEL=" OHI Type:  " ARRAY(8) =LABEL_U_P C
  11375   "RTN","CHG CDV73",36, 0)
  11376    S:LABEL=" OHI Begin:  " ARRAY(9 )=LABEL_U_ PC
  11377   "RTN","CHG CDV73",37, 0)
  11378    S:LABEL=" OHI End: "  ARRAY(10) =LABEL_U_P C
  11379   "RTN","CHG CDV73",38, 0)
  11380    S:LABEL=" OHI Name:  " ARRAY(11 )=LABEL_U_ PC
  11381   "RTN","CHG CDV73",39, 0)
  11382    S:LABEL=" OHI Paymt:  " ARRAY(1 2)=LABEL_U _PC
  11383   "RTN","CHG CDV73",40, 0)
  11384    S:LABEL=" Bene Paymt : " ARRAY( 13)=LABEL_ U_PC
  11385   "RTN","CHG CDV73",41, 0)
  11386    S:LABEL=" Medicaid A gency: " A RRAY(14)=L ABEL_U_PC
  11387   "RTN","CHG CDV73",42, 0)
  11388    S:LABEL=" Medicaid P aid: " ARR AY(15)=LAB EL_U_PC
  11389   "RTN","CHG CDV73",43, 0)
  11390    S:LABEL=" Total Char ge: " ARRA Y(16)=LABE L_U_PC
  11391   "RTN","CHG CDV73",44, 0)
  11392    K PC,LABE L
  11393   "RTN","CHG CDV73",45, 0)
  11394    Q
  11395   "RTN","CHG CDV73",46, 0)
  11396   LOOP K VEN FLG
  11397   "RTN","CHG CDV73",47, 0)
  11398    D VENHIS  D:$D(VENFL G) PRT
  11399   "RTN","CHG CDV73",48, 0)
  11400    D ^CHGCDV 74
  11401   "RTN","CHG CDV73",49, 0)
  11402    D EDICLM
  11403   "RTN","CHG CDV73",50, 0)
  11404    G END
  11405   "RTN","CHG CDV73",51, 0)
  11406    ;
  11407   "RTN","CHG CDV73",52, 0)
  11408   END Q
  11409   "RTN","CHG CDV73",53, 0)
  11410    ;
  11411   "RTN","CHG CDV73",54, 0)
  11412   VENHIS Q:' $D(^TMP($J ,"CCD",CHC LM,CHTYPE, "VENPTHS", JX))
  11413   "RTN","CHG CDV73",55, 0)
  11414    I CHFL=0  D HDG^CHGC DV70 S CHF L=1
  11415   "RTN","CHG CDV73",56, 0)
  11416    S VX=0,N= 1
  11417   "RTN","CHG CDV73",57, 0)
  11418   VEN1 S VX= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "VENPTHS", JX,VX)) I  VX="" Q
  11419   "RTN","CHG CDV73",58, 0)
  11420    S CHVENHS =$P(^TMP($ J,"CCD",CH CLM,CHTYPE ,"VENPTHS" ,JX,VX),U, 1)
  11421   "RTN","CHG CDV73",59, 0)
  11422    D  I ($D( PX))&('$D( HDFL))&(CH FL>0) D HD 1^CHGCDP7  S HDFL=1
  11423   "RTN","CHG CDV73",60, 0)
  11424    .I CHVENH S'="" S LA BEL="Vendo r: ",PC=CH VENHS,PX(N )=LABEL_U_ PC,N=N+1
  11425   "RTN","CHG CDV73",61, 0)
  11426    S VENFLG= ""
  11427   "RTN","CHG CDV73",62, 0)
  11428    G VEN1
  11429   "RTN","CHG CDV73",63, 0)
  11430    ;
  11431   "RTN","CHG CDV73",64, 0)
  11432   EDICLM S C HOHTYCD=""
  11433   "RTN","CHG CDV73",65, 0)
  11434   E1 S CHOHT YCD=$O(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD)) Q :CHOHTYCD= ""
  11435   "RTN","CHG CDV73",66, 0)
  11436    S CHEDOHN M=""
  11437   "RTN","CHG CDV73",67, 0)
  11438   E2 S CHEDO HNM=$O(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM)) G: CHEDOHNM=" " E1
  11439   "RTN","CHG CDV73",68, 0)
  11440    D EDIPRT
  11441   "RTN","CHG CDV73",69, 0)
  11442    S CLADJGR P=""
  11443   "RTN","CHG CDV73",70, 0)
  11444   E3 S CLADJ GRP=$O(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM,CLAD JGRP)) G:C LADJGRP=""  E2
  11445   "RTN","CHG CDV73",71, 0)
  11446    W !!,"OHI  Claim Adj ustment Gr oup: ",CLA DJGRP
  11447   "RTN","CHG CDV73",72, 0)
  11448    S REC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM,CLAD JGRP,1)
  11449   "RTN","CHG CDV73",73, 0)
  11450    S RCC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM,CLAD JGRP,2)
  11451   "RTN","CHG CDV73",74, 0)
  11452    S CLAJCD1 =$P(REC,U, 1),CLADJAM 1=$P(REC,U ,2),CLADJQ T1=$P(REC, U,3)
  11453   "RTN","CHG CDV73",75, 0)
  11454    D:CLAJCD1 '=""
  11455   "RTN","CHG CDV73",76, 0)
  11456    .S CDI=0, CREC=""
  11457   "RTN","CHG CDV73",77, 0)
  11458   E31 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD1,CDI))  Q:'CDI
  11459   "RTN","CHG CDV73",78, 0)
  11460    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E31 S  CREC=^(0)
  11461   "RTN","CHG CDV73",79, 0)
  11462    .S CLAJCD 1C=$P(CREC ,U,1),CLAJ CD1P=$P(CR EC,U,2)
  11463   "RTN","CHG CDV73",80, 0)
  11464    .W !?4,"A dj Reason  Code: (",C LAJCD1C,") -"
  11465   "RTN","CHG CDV73",81, 0)
  11466    .I $L(CLA JCD1P)>55  W ?28,$E(C LAJCD1P,1, 55),!?28,$ E(CLAJCD1P ,56,100)
  11467   "RTN","CHG CDV73",82, 0)
  11468    .E  W ?28 ,CLAJCD1P
  11469   "RTN","CHG CDV73",83, 0)
  11470    .W !?4,"A dj Quantit y: ",CLADJ QT1
  11471   "RTN","CHG CDV73",84, 0)
  11472    .W !?4,"A dj Amount:    ",CLADJ AM1
  11473   "RTN","CHG CDV73",85, 0)
  11474    .Q
  11475   "RTN","CHG CDV73",86, 0)
  11476    S CLAJCD2 =$P(REC,U, 4),CLADJAM 2=$P(REC,U ,5),CLADJQ T2=$P(REC, U,6)
  11477   "RTN","CHG CDV73",87, 0)
  11478    D:CLAJCD2 '=""
  11479   "RTN","CHG CDV73",88, 0)
  11480    .S CDI=0, CREC=""
  11481   "RTN","CHG CDV73",89, 0)
  11482   E32 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD2,CDI))  Q:'CDI
  11483   "RTN","CHG CDV73",90, 0)
  11484    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E32 S  CREC=^(0)
  11485   "RTN","CHG CDV73",91, 0)
  11486    .S CLAJCD 2C=$P(CREC ,U,1),CLAJ CD2P=$P(CR EC,U,2)
  11487   "RTN","CHG CDV73",92, 0)
  11488    .W !?4,"A dj Reason  Code: (",C LAJCD2C,") -"
  11489   "RTN","CHG CDV73",93, 0)
  11490    .I $L(CLA JCD2P)>55  W ?28,$E(C LAJCD2P,1, 55),!?28,$ E(CLAJCD2P ,56,100)
  11491   "RTN","CHG CDV73",94, 0)
  11492    .E  W ?28 ,CLAJCD2P
  11493   "RTN","CHG CDV73",95, 0)
  11494    .W !?4,"A dj Quantit y: ",CLADJ QT2
  11495   "RTN","CHG CDV73",96, 0)
  11496    .W !?4,"A dj Amount:    ",CLADJ AM2
  11497   "RTN","CHG CDV73",97, 0)
  11498    .Q
  11499   "RTN","CHG CDV73",98, 0)
  11500    S CLAJCD3 =$P(REC,U, 7),CLADJAM 3=$P(REC,U ,8),CLADJQ T3=$P(REC, U,9)
  11501   "RTN","CHG CDV73",99, 0)
  11502    D:CLAJCD3 '=""
  11503   "RTN","CHG CDV73",100 ,0)
  11504    .S CDI=0, CREC=""
  11505   "RTN","CHG CDV73",101 ,0)
  11506   E33 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD3,CDI))  Q:'CDI
  11507   "RTN","CHG CDV73",102 ,0)
  11508    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E33 S  CREC=^(0)
  11509   "RTN","CHG CDV73",103 ,0)
  11510    .S CLAJCD 3C=$P(CREC ,U,1),CLAJ CD3P=$P(CR EC,U,2)
  11511   "RTN","CHG CDV73",104 ,0)
  11512    .W !?4,"A dj Reason  Code: (",C LAJCD3C,") -"
  11513   "RTN","CHG CDV73",105 ,0)
  11514    .I $L(CLA JCD3P)>55  W ?28,$E(C LAJCD3P,1, 55),!?28,$ E(CLAJCD3P ,56,100)
  11515   "RTN","CHG CDV73",106 ,0)
  11516    .E  W ?28 ,CLAJCD3P
  11517   "RTN","CHG CDV73",107 ,0)
  11518    .W !?4,"A dj Quantit y: ",CLADJ QT3
  11519   "RTN","CHG CDV73",108 ,0)
  11520    .W !?4,"A dj Amount:    ",CLADJ AM3
  11521   "RTN","CHG CDV73",109 ,0)
  11522    .Q
  11523   "RTN","CHG CDV73",110 ,0)
  11524    S CLAJCD4 =$P(RCC,U, 1),CLADJAM 4=$P(RCC,U ,2),CLADJQ T4=$P(RCC, U,3)
  11525   "RTN","CHG CDV73",111 ,0)
  11526    D:CLAJCD4 '=""
  11527   "RTN","CHG CDV73",112 ,0)
  11528    .S CDI=0, CREC=""
  11529   "RTN","CHG CDV73",113 ,0)
  11530   E34 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD4,CDI))  Q:'CDI
  11531   "RTN","CHG CDV73",114 ,0)
  11532    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E34 S  CREC=^(0)
  11533   "RTN","CHG CDV73",115 ,0)
  11534    .S CLAJCD 4C=$P(CREC ,U,1),CLAJ CD4P=$P(CR EC,U,2)
  11535   "RTN","CHG CDV73",116 ,0)
  11536    .W !?4,"A dj Reason  Code: (",C LAJCD4C,") -"
  11537   "RTN","CHG CDV73",117 ,0)
  11538    .I $L(CLA JCD4P)>55  W ?28,$E(C LAJCD4P,1, 55),!?28,$ E(CLAJCD4P ,56,100)
  11539   "RTN","CHG CDV73",118 ,0)
  11540    .E  W ?28 ,CLAJCD4P
  11541   "RTN","CHG CDV73",119 ,0)
  11542    .W !?4,"A dj Quantit y: ",CLADJ QT4
  11543   "RTN","CHG CDV73",120 ,0)
  11544    .W !?4,"A dj Amount:    ",CLADJ AM4
  11545   "RTN","CHG CDV73",121 ,0)
  11546    .Q
  11547   "RTN","CHG CDV73",122 ,0)
  11548    S CLAJCD5 =$P(RCC,U, 4),CLADJAM 5=$P(RCC,U ,5),CLADJQ T5=$P(RCC, U,6)
  11549   "RTN","CHG CDV73",123 ,0)
  11550    D:CLAJCD5 '=""
  11551   "RTN","CHG CDV73",124 ,0)
  11552    .S CDI=0, CREC=""
  11553   "RTN","CHG CDV73",125 ,0)
  11554   E35 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD5,CDI))  Q:'CDI
  11555   "RTN","CHG CDV73",126 ,0)
  11556    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E35 S  CREC=^(0)
  11557   "RTN","CHG CDV73",127 ,0)
  11558    .S CLAJCD 5C=$P(CREC ,U,1),CLAJ CD5P=$P(CR EC,U,2)
  11559   "RTN","CHG CDV73",128 ,0)
  11560    .W !?4,"A dj Reason  Code: (",C LAJCD5C,") -"
  11561   "RTN","CHG CDV73",129 ,0)
  11562    .I $L(CLA JCD5P)>55  W ?28,$E(C LAJCD5P,1, 55),!?28,$ E(CLAJCD5P ,56,100)
  11563   "RTN","CHG CDV73",130 ,0)
  11564    .E  W ?28 ,CLAJCD5P
  11565   "RTN","CHG CDV73",131 ,0)
  11566    .W !?4,"A dj Quantit y: ",CLADJ QT5
  11567   "RTN","CHG CDV73",132 ,0)
  11568    .W !?4,"A dj Amount:    ",CLADJ AM5
  11569   "RTN","CHG CDV73",133 ,0)
  11570    .Q
  11571   "RTN","CHG CDV73",134 ,0)
  11572    S CLAJCD6 =$P(RCC,U, 7),CLADJAM 6=$P(RCC,U ,8),CLADJQ T6=$P(RCC, U,9)
  11573   "RTN","CHG CDV73",135 ,0)
  11574    D:CLAJCD6 '=""
  11575   "RTN","CHG CDV73",136 ,0)
  11576    .S CDI=0, CREC=""
  11577   "RTN","CHG CDV73",137 ,0)
  11578   E36 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD6,CDI))  Q:'CDI
  11579   "RTN","CHG CDV73",138 ,0)
  11580    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E36 S  CREC=^(0)
  11581   "RTN","CHG CDV73",139 ,0)
  11582    .S CLAJCD 6C=$P(CREC ,U,1),CLAJ CD6P=$P(CR EC,U,2)
  11583   "RTN","CHG CDV73",140 ,0)
  11584    .W !?4,"A dj Reason  Code: (",C LAJCD6C,") -"
  11585   "RTN","CHG CDV73",141 ,0)
  11586    .I $L(CLA JCD6P)>55  W ?28,$E(C LAJCD6P,1, 55),!?28,$ E(CLAJCD6P ,56,100)
  11587   "RTN","CHG CDV73",142 ,0)
  11588    .E  W ?28 ,CLAJCD6P
  11589   "RTN","CHG CDV73",143 ,0)
  11590    .W !?4,"A dj Quantit y: ",CLADJ QT6
  11591   "RTN","CHG CDV73",144 ,0)
  11592    .W !?4,"A dj Amount:    ",CLADJ AM6
  11593   "RTN","CHG CDV73",145 ,0)
  11594    .Q
  11595   "RTN","CHG CDV73",146 ,0)
  11596    G E3
  11597   "RTN","CHG CDV73",147 ,0)
  11598    ;
  11599   "RTN","CHG CDV73",148 ,0)
  11600   EDIPRT S X ="X XY W @ CHBON,""OH I Insuranc e Type Cod e: "",@CHB OFF,P1"
  11601   "RTN","CHG CDV73",149 ,0)
  11602    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHOHTYC D
  11603   "RTN","CHG CDV73",150 ,0)
  11604    S X="S DX =15 X XY W  @CHBON,"" OHI Name:  "",@CHBOFF ,P1"
  11605   "RTN","CHG CDV73",151 ,0)
  11606    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHEDOHN M
  11607   "RTN","CHG CDV73",152 ,0)
  11608    Q
  11609   "RTN","CHG CDV73",153 ,0)
  11610    ;
  11611   "RTN","CHG CDV73",154 ,0)
  11612   PRT S N=0, CNT=1
  11613   "RTN","CHG CDV73",155 ,0)
  11614   P1 S N=$O( PX(N)) I N ="" D:$D(L ABEL) BUIL D K PX,LAB EL,PC,N,CN T Q
  11615   "RTN","CHG CDV73",156 ,0)
  11616    S LABEL(C NT)=$P(PX( N),U,1),PC (CNT)=$P(P X(N),U,2)
  11617   "RTN","CHG CDV73",157 ,0)
  11618    G:(LABEL( CNT)="")!( PC(CNT)="" ) P1
  11619   "RTN","CHG CDV73",158 ,0)
  11620   P2 I CNT=3  D BUILD S  CNT=1 W !  K LABEL,P C G P1
  11621   "RTN","CHG CDV73",159 ,0)
  11622    S CNT=CNT +1
  11623   "RTN","CHG CDV73",160 ,0)
  11624    G P1
  11625   "RTN","CHG CDV73",161 ,0)
  11626    ;
  11627   "RTN","CHG CDV73",162 ,0)
  11628   BUILD I $D (LABEL(3))  W LABEL(1 ),PC(1),?2 8,LABEL(2) ,PC(2),?56 ,LABEL(3), PC(3) Q
  11629   "RTN","CHG CDV73",163 ,0)
  11630    I $D(LABE L(2)) W LA BEL(1),PC( 1),?28,LAB EL(2),PC(2 ) W:(CNT<3 ) ! Q
  11631   "RTN","CHG CDV73",164 ,0)
  11632    I $D(LABE L(1)) W LA BEL(1),PC( 1) W:(CNT< 3) !
  11633   "RTN","CHG CDV73",165 ,0)
  11634    Q
  11635   "RTN","CHG CDV73",166 ,0)
  11636    ;
  11637   "RTN","CHG CDV73",167 ,0)
  11638   WRTLINE D  UPCT S ^UT ILITY($J," CCD",CHZON E,CT)="" Q
  11639   "RTN","CHG CDV73",168 ,0)
  11640   UPCT S (CT ,^UTILITY( $J,"CCD",C HZONE,0))= CT+1 Q
  11641   "RTN","CHG CPRD1")
  11642   0^95^B7515 4897
  11643   "RTN","CHG CPRD1",1,0 )
  11644   CHGCPRD1 ; CVA/AHJ;CP D SUSPENSE  UNIT PROD UCTIVITY;0 9/16/97  1 1:44 AM
  11645   "RTN","CHG CPRD1",2,0 )
  11646    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  11647   "RTN","CHG CPRD1",3,0 )
  11648    ;CPTS 111 47
  11649   "RTN","CHG CPRD1",4,0 )
  11650    ; Defect  929150 - T GH - 2/20/ 2019 Only  Set Print  Type with  /W if not  HFS or P-M
  11651   "RTN","CHG CPRD1",5,0 )
  11652    S AA=0 K  TONY
  11653   "RTN","CHG CPRD1",6,0 )
  11654    ;THIS ROU TINE CALLS  CHGCPRD2  FOR SUB-RO UTINES
  11655   "RTN","CHG CPRD1",7,0 )
  11656    ;THIS ROU TINE CALLS  CHGCPRD3  FOR SUMMAR Y REPORT
  11657   "RTN","CHG CPRD1",8,0 )
  11658    S:'$D(DUZ ) DUZ=1,DU Z(0)="" I  '$D(DT) S  %DT="",X=" T" D ^%DT  S DT=Y
  11659   "RTN","CHG CPRD1",9,0 )
  11660    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  11661   "RTN","CHG CPRD1",10, 0)
  11662    I '$D(IOZ ) S %IS="N ",IOP=$I D  ^%ZIS K I OP S IOZ=I O,IOZL=IOS L,IOZW=IOM ,IOZF=IOF, IOZT=IOST, IOZN=ION,I OZS=IOS
  11663   "RTN","CHG CPRD1",11, 0)
  11664   START1 ;
  11665   "RTN","CHG CPRD1",12, 0)
  11666    S PAGE=0
  11667   "RTN","CHG CPRD1",13, 0)
  11668    K ^UTILIT Y($J)
  11669   "RTN","CHG CPRD1",14, 0)
  11670    S (CHCLMD AY,CHSUBDA Y)=0
  11671   "RTN","CHG CPRD1",15, 0)
  11672    F C=1:1:4  D
  11673   "RTN","CHG CPRD1",16, 0)
  11674    .F D=1:1: 11 S CHLIN E(C,D)=0
  11675   "RTN","CHG CPRD1",17, 0)
  11676    F H=1:1:1 8 S CHDAY( H)=0
  11677   "RTN","CHG CPRD1",18, 0)
  11678    F C=1:1:4  D
  11679   "RTN","CHG CPRD1",19, 0)
  11680    .F D=1:1: 2 S CHSUBS UM(C,D)=0
  11681   "RTN","CHG CPRD1",20, 0)
  11682    S (CHTOT( 1),CHTOT(2 ))=0
  11683   "RTN","CHG CPRD1",21, 0)
  11684    S (CHSUB1 ,CHSUB2,CH ARRAY1,CHA RRAY2,CHTO TAL,CHSUBT OT,CHCLMTO T)=0
  11685   "RTN","CHG CPRD1",22, 0)
  11686    W !!,"Do  you want ( A)ll, (I)n dividual,  (S)ummary,  or (Q)uit  //I : " D  SBRS
  11687   "RTN","CHG CPRD1",23, 0)
  11688    I Y="Q" Q
  11689   "RTN","CHG CPRD1",24, 0)
  11690    I Y="" S  Y="I"
  11691   "RTN","CHG CPRD1",25, 0)
  11692    G:$D(DFOU T) CHGCPRD 1
  11693   "RTN","CHG CPRD1",26, 0)
  11694    G:$D(DUOU T) END95   ;IF ^^ ENT ERED
  11695   "RTN","CHG CPRD1",27, 0)
  11696    I $D(DQOU T) D  G ST ART1
  11697   "RTN","CHG CPRD1",28, 0)
  11698    .W !,"If  answer is  Q, routine  will stop  "
  11699   "RTN","CHG CPRD1",29, 0)
  11700    .Q
  11701   "RTN","CHG CPRD1",30, 0)
  11702    I "AISQ"' [Y W *7,"   ??" G STA RT1
  11703   "RTN","CHG CPRD1",31, 0)
  11704    I Y="I" S  CHIND="I"
  11705   "RTN","CHG CPRD1",32, 0)
  11706    I Y="A" S  CHIND="A"
  11707   "RTN","CHG CPRD1",33, 0)
  11708    I Y="S" G  START1^CH GCPRD3
  11709   "RTN","CHG CPRD1",34, 0)
  11710   IND2 ; IND IVIDUAL RE QUEST
  11711   "RTN","CHG CPRD1",35, 0)
  11712    S CHDUZ=D UZ
  11713   "RTN","CHG CPRD1",36, 0)
  11714    I CHIND=" I" D IND3
  11715   "RTN","CHG CPRD1",37, 0)
  11716    I Y="N" G  START1
  11717   "RTN","CHG CPRD1",38, 0)
  11718    D DATE3
  11719   "RTN","CHG CPRD1",39, 0)
  11720    I X="N" G  START1
  11721   "RTN","CHG CPRD1",40, 0)
  11722    D START5
  11723   "RTN","CHG CPRD1",41, 0)
  11724    G START1
  11725   "RTN","CHG CPRD1",42, 0)
  11726    Q
  11727   "RTN","CHG CPRD1",43, 0)
  11728   IND3 ;
  11729   "RTN","CHG CPRD1",44, 0)
  11730    S DIC("A" )="Enter N ame for re port : "
  11731   "RTN","CHG CPRD1",45, 0)
  11732    S DIC=200 ,DIC(0)="A ELMQ" D ^D IC
  11733   "RTN","CHG CPRD1",46, 0)
  11734    S CHNAME= $P(Y,U,2), CHDUZ=$P(Y ,U,1)
  11735   "RTN","CHG CPRD1",47, 0)
  11736    I Y=-1 S  Y="N" Q
  11737   "RTN","CHG CPRD1",48, 0)
  11738    I Y<0 W ! !,"Must en ter name o r exit "
  11739   "RTN","CHG CPRD1",49, 0)
  11740    I Y<0 G I ND3
  11741   "RTN","CHG CPRD1",50, 0)
  11742    Q
  11743   "RTN","CHG CPRD1",51, 0)
  11744   DATE3 ;
  11745   "RTN","CHG CPRD1",52, 0)
  11746    W !! S %D T("A")="In put Ending  Date: or  ""^"" to q uit "
  11747   "RTN","CHG CPRD1",53, 0)
  11748    S %DT="AE NP",%DT(0) ="-T"
  11749   "RTN","CHG CPRD1",54, 0)
  11750    D ^%DT
  11751   "RTN","CHG CPRD1",55, 0)
  11752    K %DT(0)
  11753   "RTN","CHG CPRD1",56, 0)
  11754    I X="^" S  X="N" Q
  11755   "RTN","CHG CPRD1",57, 0)
  11756    I X="^^"  S X="N" Q
  11757   "RTN","CHG CPRD1",58, 0)
  11758    I Y=-1 G  DATE3
  11759   "RTN","CHG CPRD1",59, 0)
  11760    S CHEND=Y
  11761   "RTN","CHG CPRD1",60, 0)
  11762    X ^DD("DD ") S CHEDA Y=Y
  11763   "RTN","CHG CPRD1",61, 0)
  11764    S X1=CHEN D S X2="-1 3" D C^%DT C S CHDT14 =X
  11765   "RTN","CHG CPRD1",62, 0)
  11766    S X1=CHEN D S X2="-3 66" D C^%D TC S CHBEG =X
  11767   "RTN","CHG CPRD1",63, 0)
  11768    S Y=CHDT1 4 X ^DD("D D") S CHBD AY=Y
  11769   "RTN","CHG CPRD1",64, 0)
  11770    S X="NOW" ,%DT="R" D  ^%DT X ^D D("DD") S  CHTODAY=Y
  11771   "RTN","CHG CPRD1",65, 0)
  11772    S Y=""
  11773   "RTN","CHG CPRD1",66, 0)
  11774    Q
  11775   "RTN","CHG CPRD1",67, 0)
  11776   START5 ;
  11777   "RTN","CHG CPRD1",68, 0)
  11778    ;NEXT LIN ES QUE REP ORT
  11779   "RTN","CHG CPRD1",69, 0)
  11780    W !
  11781   "RTN","CHG CPRD1",70, 0)
  11782    S IOP="Q"  D ^%ZIS Q :POP
  11783   "RTN","CHG CPRD1",71, 0)
  11784    ; Defect  929150 - T GH - 2/20/ 2019 Only  Set with / W if not H FS or P-M
  11785   "RTN","CHG CPRD1",72, 0)
  11786    ; I ION'[ "/W" S ION =ION_"/W"
  11787   "RTN","CHG CPRD1",73, 0)
  11788    S ION=ION _$S(ION="H FS":"",ION ="P-MESSAG E-HFS":"", 1:"/W")
  11789   "RTN","CHG CPRD1",74, 0)
  11790    S CHFIO=I ON,ZTSAVE( "CHFIO")=" ",ZTIO=CHF IO
  11791   "RTN","CHG CPRD1",75, 0)
  11792    G:$D(IO(" Q"))!(IO'= IO(0)) QUE UE90
  11793   "RTN","CHG CPRD1",76, 0)
  11794   MAIN8 ;
  11795   "RTN","CHG CPRD1",77, 0)
  11796    S CHSBEG= CHBEG
  11797   "RTN","CHG CPRD1",78, 0)
  11798   NXT10 ;
  11799   "RTN","CHG CPRD1",79, 0)
  11800    S (LEV1,L EV2)=0
  11801   "RTN","CHG CPRD1",80, 0)
  11802    F  S CHSB EG=$O(^CHM PROD(74106 0.02,CHSBE G)) Q:'CHS BEG  Q:$E( CHSBEG,1,7 )>CHEND  D  NXT11
  11803   "RTN","CHG CPRD1",81, 0)
  11804    D QUIT75
  11805   "RTN","CHG CPRD1",82, 0)
  11806    Q
  11807   "RTN","CHG CPRD1",83, 0)
  11808   NXT11 ;
  11809   "RTN","CHG CPRD1",84, 0)
  11810    S LEV2=0
  11811   "RTN","CHG CPRD1",85, 0)
  11812    F  S LEV2 =$O(^CHMPR OD(741060. 02,CHSBEG, 1,LEV2)) Q :'LEV2  D  GOTIT12
  11813   "RTN","CHG CPRD1",86, 0)
  11814    Q
  11815   "RTN","CHG CPRD1",87, 0)
  11816   GOTIT12 ;
  11817   "RTN","CHG CPRD1",88, 0)
  11818    S CHDAT1= $G(^CHMPRO D(741060.0 2,CHSBEG,1 ,LEV2,0))
  11819   "RTN","CHG CPRD1",89, 0)
  11820    Q:CHDAT1= ""
  11821   "RTN","CHG CPRD1",90, 0)
  11822    I CHIND=" I" Q:CHDUZ '=$P(CHDAT 1,U,1)
  11823   "RTN","CHG CPRD1",91, 0)
  11824    S CHACTDU Z=$P(CHDAT 1,U,1) Q:' $D(^CHMDIC (741002.21 ,CHACTDUZ, 0))
  11825   "RTN","CHG CPRD1",92, 0)
  11826    Q:$P(^CHM DIC(741002 .21,CHACTD UZ,0),"^", 16)'=1
  11827   "RTN","CHG CPRD1",93, 0)
  11828    S CHDATE= $E(CHSBEG, 1,7)
  11829   "RTN","CHG CPRD1",94, 0)
  11830    S CHNAME= $P($G(^VA( 200,CHACTD UZ,0)),U,1 )
  11831   "RTN","CHG CPRD1",95, 0)
  11832    I CHNAME= "" S CHNAM E="UNKNOWN "
  11833   "RTN","CHG CPRD1",96, 0)
  11834    S:'$D(CHN AME) CHNAM E="UNKNOWN "
  11835   "RTN","CHG CPRD1",97, 0)
  11836    D ALLNX25
  11837   "RTN","CHG CPRD1",98, 0)
  11838    Q
  11839   "RTN","CHG CPRD1",99, 0)
  11840   ALLNX25 ;
  11841   "RTN","CHG CPRD1",100 ,0)
  11842    S (CHTOT( 1),CHTOT(2 ))=0
  11843   "RTN","CHG CPRD1",101 ,0)
  11844    D ONLY29^ CHGCPRD2
  11845   "RTN","CHG CPRD1",102 ,0)
  11846    D CALC45^ CHGCPRD2,A DDSUM50^CH GCPRD2
  11847   "RTN","CHG CPRD1",103 ,0)
  11848    S CHACTDU Z=$P(CHDAT 1,U,1)
  11849   "RTN","CHG CPRD1",104 ,0)
  11850    ; NEXT LI NE UPDATE  CURRENT DA Y TOTALS
  11851   "RTN","CHG CPRD1",105 ,0)
  11852    D DOA27
  11853   "RTN","CHG CPRD1",106 ,0)
  11854    I '$D(^UT ILITY($J,C HNAME,"B") ) S ^UTILI TY($J,CHNA ME,"B")=0
  11855   "RTN","CHG CPRD1",107 ,0)
  11856    S J=1
  11857   "RTN","CHG CPRD1",108 ,0)
  11858    F I=1:1:4  D
  11859   "RTN","CHG CPRD1",109 ,0)
  11860    .F H=1:1: 11 S $P(CH ARRAY2,U,J )=CHLINE(I ,H) S J=J+ 1
  11861   "RTN","CHG CPRD1",110 ,0)
  11862    .Q
  11863   "RTN","CHG CPRD1",111 ,0)
  11864    S J=0
  11865   "RTN","CHG CPRD1",112 ,0)
  11866    I $D(^UTI LITY($J,CH NAME,"B"))  D DOB28 ; GET PREV " B"
  11867   "RTN","CHG CPRD1",113 ,0)
  11868    S ^UTILIT Y($J,CHNAM E,"B")=CHA RRAY2
  11869   "RTN","CHG CPRD1",114 ,0)
  11870    ;
  11871   "RTN","CHG CPRD1",115 ,0)
  11872    ;D:CHIND= "I" GET60
  11873   "RTN","CHG CPRD1",116 ,0)
  11874    D CLRTOT5 7
  11875   "RTN","CHG CPRD1",117 ,0)
  11876    K CHARRAR 2,CHA
  11877   "RTN","CHG CPRD1",118 ,0)
  11878    Q
  11879   "RTN","CHG CPRD1",119 ,0)
  11880   DOA27 ;
  11881   "RTN","CHG CPRD1",120 ,0)
  11882    Q:CHEND'= CHDATE
  11883   "RTN","CHG CPRD1",121 ,0)
  11884    I '$D(^UT ILITY($J,C HNAME,CHDA TE,"A")) S  ^UTILITY( $J,CHNAME, CHDATE,"A" )=0
  11885   "RTN","CHG CPRD1",122 ,0)
  11886    S CHARRAY 1=$G(^UTIL ITY($J,CHN AME,CHDATE ,"A"))
  11887   "RTN","CHG CPRD1",123 ,0)
  11888    F H=1:1:1 8 S $P(CHA RRAY1,U,H) =$P(CHARRA Y1,U,H)+CH DAY(H)
  11889   "RTN","CHG CPRD1",124 ,0)
  11890    ;DAY SUMM ARY IF END  DAY MATCH ES
  11891   "RTN","CHG CPRD1",125 ,0)
  11892    S ^UTILIT Y($J,CHNAM E,CHDATE," A")=CHARRA Y1
  11893   "RTN","CHG CPRD1",126 ,0)
  11894    Q
  11895   "RTN","CHG CPRD1",127 ,0)
  11896   DOB28 ;
  11897   "RTN","CHG CPRD1",128 ,0)
  11898    S CHGETB= $G(^UTILIT Y($J,CHNAM E,"B"))
  11899   "RTN","CHG CPRD1",129 ,0)
  11900    F H=1:1:4 4 S $P(CHA RRAY2,U,H) =$P(CHARRA Y2,U,H)+$P (CHGETB,U, H)
  11901   "RTN","CHG CPRD1",130 ,0)
  11902    Q
  11903   "RTN","CHG CPRD1",131 ,0)
  11904   CLRTOT57 ;
  11905   "RTN","CHG CPRD1",132 ,0)
  11906    F C=1:1:4  D
  11907   "RTN","CHG CPRD1",133 ,0)
  11908    .F D=1:1: 11 S CHLIN E(C,D)=0
  11909   "RTN","CHG CPRD1",134 ,0)
  11910    F H=1:1:1 8 S CHDAY( H)=0
  11911   "RTN","CHG CPRD1",135 ,0)
  11912    F C=1:1:4  D
  11913   "RTN","CHG CPRD1",136 ,0)
  11914    .F D=1:1: 2 S CHSUBS UM(C,D)=0
  11915   "RTN","CHG CPRD1",137 ,0)
  11916    Q
  11917   "RTN","CHG CPRD1",138 ,0)
  11918   GET60 ;GET  "C" REF S UBMISSIONS /CLAIMS
  11919   "RTN","CHG CPRD1",139 ,0)
  11920    Q:'$D(^UT ILITY($J,C HNAME,"B") )
  11921   "RTN","CHG CPRD1",140 ,0)
  11922    S CHSETSW ="N"
  11923   "RTN","CHG CPRD1",141 ,0)
  11924    F C=1:1:9  S CHSDAT= $P(^UTILIT Y($J,CHNAM E,"B"),U,C ) D CHCHEC K6
  11925   "RTN","CHG CPRD1",142 ,0)
  11926    F C=12:1: 20 S CHSDA T=$P(^UTIL ITY($J,CHN AME,"B"),U ,C) D CHCH ECK6
  11927   "RTN","CHG CPRD1",143 ,0)
  11928    F C=23:1: 31 S CHSDA T=$P(^UTIL ITY($J,CHN AME,"B"),U ,C) D CHCH ECK6
  11929   "RTN","CHG CPRD1",144 ,0)
  11930    F C=34:1: 42 S CHSDA T=$P(^UTIL ITY($J,CHN AME,"B"),U ,C) D CHCH ECK6
  11931   "RTN","CHG CPRD1",145 ,0)
  11932    Q:CHSETSW ="N"
  11933   "RTN","CHG CPRD1",146 ,0)
  11934    S (CHPDI, CHCLMDAY,C HSUBDAY)=0
  11935   "RTN","CHG CPRD1",147 ,0)
  11936    S CHSUBDU Z=0
  11937   "RTN","CHG CPRD1",148 ,0)
  11938    S CHSUB=$ P($E(CHBEG ,1,7),".", 1)
  11939   "RTN","CHG CPRD1",149 ,0)
  11940    F  S CHSU B=$O(^CHMP ROD(741060 .01,CHSUB) ) Q:'CHSUB   Q:$E(CHS UB,1,7)>CH END  D GOT 61
  11941   "RTN","CHG CPRD1",150 ,0)
  11942    Q
  11943   "RTN","CHG CPRD1",151 ,0)
  11944   GOT61 ;
  11945   "RTN","CHG CPRD1",152 ,0)
  11946    S CHSUBI= 0
  11947   "RTN","CHG CPRD1",153 ,0)
  11948    F  S CHSU BI=$O(^CHM PROD(74106 0.01,CHSUB ,100,CHSUB I)) Q:'CHS UBI  D GOT 62
  11949   "RTN","CHG CPRD1",154 ,0)
  11950    Q
  11951   "RTN","CHG CPRD1",155 ,0)
  11952   GOT62 ;
  11953   "RTN","CHG CPRD1",156 ,0)
  11954    Q:'$D(^CH MPROD(7410 60.01,CHSU B,100,CHSU BI,0))
  11955   "RTN","CHG CPRD1",157 ,0)
  11956    S TMPREC1 =^CHMPROD( 741060.01, CHSUB,100, CHSUBI,0)
  11957   "RTN","CHG CPRD1",158 ,0)
  11958    D GOT63
  11959   "RTN","CHG CPRD1",159 ,0)
  11960    Q
  11961   "RTN","CHG CPRD1",160 ,0)
  11962   GOT63 ;
  11963   "RTN","CHG CPRD1",161 ,0)
  11964    S (CHCLMD AY,CHSUBDA Y)=0
  11965   "RTN","CHG CPRD1",162 ,0)
  11966    S CHSUBDU Z=$P(TMPRE C1,"^",1)  Q:CHSUBDUZ =""
  11967   "RTN","CHG CPRD1",163 ,0)
  11968    S CHSUBNA ME=$P($G(^ VA(200,CHS UBDUZ,0)), U,1)
  11969   "RTN","CHG CPRD1",164 ,0)
  11970    Q:'$D(^CH MDIC(74100 2.21,CHSUB DUZ,0))
  11971   "RTN","CHG CPRD1",165 ,0)
  11972    Q:$P(^CHM DIC(741002 .21,CHSUBD UZ,0),"^", 16)'=1
  11973   "RTN","CHG CPRD1",166 ,0)
  11974    I CHIND=" I" Q:CHSUB DUZ'=CHDUZ
  11975   "RTN","CHG CPRD1",167 ,0)
  11976    S CHCLAIM =$P(TMPREC 1,"^",3)+$ P(TMPREC1, "^",6)+$P( TMPREC1,"^ ",9)
  11977   "RTN","CHG CPRD1",168 ,0)
  11978    S CHSUBCT =$P(TMPREC 1,"^",2)+$ P(TMPREC1, "^",5)+$P( TMPREC1,"^ ",8)
  11979   "RTN","CHG CPRD1",169 ,0)
  11980    D GOT64
  11981   "RTN","CHG CPRD1",170 ,0)
  11982    S CHSUBKE Y=$E(CHSUB ,1,7)
  11983   "RTN","CHG CPRD1",171 ,0)
  11984    ;S:'$D(TO NY(CHNAME, CHSUB)) TO NY(CHSUBNA ME,CHSUB)= ""
  11985   "RTN","CHG CPRD1",172 ,0)
  11986    ;S:'$D(TO NY(CHSUBDU Z)) TONY(C HSUBDUZ)=0
  11987   "RTN","CHG CPRD1",173 ,0)
  11988    ;S TONY(C HSUBNAME,C HSUB)=CHSU BCT_"^"_CH CLAIM
  11989   "RTN","CHG CPRD1",174 ,0)
  11990    ;S $P(TON Y(CHSUBDUZ ),"^",1)=$ P(TONY(CHS UBDUZ),"^" ,1)+CHSUBC T
  11991   "RTN","CHG CPRD1",175 ,0)
  11992    ;S $P(TON Y(CHSUBDUZ ),"^",2)=$ P(TONY(CHS UBDUZ),"^" ,2)+CHCLAI M
  11993   "RTN","CHG CPRD1",176 ,0)
  11994    I CHEND=$ E(CHSUB,1, 7) D
  11995   "RTN","CHG CPRD1",177 ,0)
  11996    .I $P(CHC LAIM,U,1)' =1 S CHCLM DAY=CHCLMD AY+CHCLAIM
  11997   "RTN","CHG CPRD1",178 ,0)
  11998    .S CHSUBD AY=CHSUBDA Y+CHSUBCT
  11999   "RTN","CHG CPRD1",179 ,0)
  12000    .I '$D(^U TILITY($J, CHSUBNAME, CHSUBKEY," A")) S ^UT ILITY($J,C HSUBNAME,C HSUBKEY,"A ")=0
  12001   "RTN","CHG CPRD1",180 ,0)
  12002    .S CHSUB1 =$G(^UTILI TY($J,CHSU BNAME,CHSU BKEY,"A"))
  12003   "RTN","CHG CPRD1",181 ,0)
  12004    .S $P(CHS UB1,U,16)= $P(CHSUB1, U,16)+CHSU BDAY
  12005   "RTN","CHG CPRD1",182 ,0)
  12006    .S $P(CHS UB1,U,17)= $P(CHSUB1, U,17)+CHCL MDAY
  12007   "RTN","CHG CPRD1",183 ,0)
  12008    .S ^UTILI TY($J,CHSU BNAME,CHSU BKEY,"A")= CHSUB1
  12009   "RTN","CHG CPRD1",184 ,0)
  12010    F E=CHLOO P:1:4 D
  12011   "RTN","CHG CPRD1",185 ,0)
  12012    .S CHSUBS UM(E,2)=CH SUBSUM(E,2 )+CHCLAIM
  12013   "RTN","CHG CPRD1",186 ,0)
  12014    .S CHTOTA L=CHTOTAL+ CHSUBCT
  12015   "RTN","CHG CPRD1",187 ,0)
  12016    .S CHSUBS UM(E,1)=CH SUBSUM(E,1 )+CHSUBCT
  12017   "RTN","CHG CPRD1",188 ,0)
  12018    D GOT65
  12019   "RTN","CHG CPRD1",189 ,0)
  12020    D CLRTOT5 7
  12021   "RTN","CHG CPRD1",190 ,0)
  12022    Q
  12023   "RTN","CHG CPRD1",191 ,0)
  12024   GOT64 ;
  12025   "RTN","CHG CPRD1",192 ,0)
  12026    ; CALC AG EING DAYS  SET LOOP D AYS
  12027   "RTN","CHG CPRD1",193 ,0)
  12028    S CHLOOP= 4
  12029   "RTN","CHG CPRD1",194 ,0)
  12030    S X1=CHEN D,X2=$E(CH SUB,1,7) D  ^%DTC S C HSUMDT=X
  12031   "RTN","CHG CPRD1",195 ,0)
  12032    Q:CHSUMDT >365
  12033   "RTN","CHG CPRD1",196 ,0)
  12034    I CHSUMDT <8 S CHLOO P=1 Q:CHLO OP=1
  12035   "RTN","CHG CPRD1",197 ,0)
  12036    I CHSUMDT <15 S CHLO OP=2 Q:CHL OOP=2
  12037   "RTN","CHG CPRD1",198 ,0)
  12038    I CHSUMDT <31 S CHLO OP=3 Q:CHL OOP=3
  12039   "RTN","CHG CPRD1",199 ,0)
  12040    S CHLOOP= 4
  12041   "RTN","CHG CPRD1",200 ,0)
  12042    Q
  12043   "RTN","CHG CPRD1",201 ,0)
  12044   GOT65 ;
  12045   "RTN","CHG CPRD1",202 ,0)
  12046    I '$D(^UT ILITY($J,C HSUBNAME," B")) S ^UT ILITY($J,C HSUBNAME," B")=0
  12047   "RTN","CHG CPRD1",203 ,0)
  12048    S CHSUB2= $G(^UTILIT Y($J,CHSUB NAME,"B"))
  12049   "RTN","CHG CPRD1",204 ,0)
  12050    S $P(CHSU B2,U,10)=$ P(CHSUB2,U ,10)+CHSUB SUM(1,1)
  12051   "RTN","CHG CPRD1",205 ,0)
  12052    S $P(CHSU B2,U,11)=$ P(CHSUB2,U ,11)+CHSUB SUM(1,2)
  12053   "RTN","CHG CPRD1",206 ,0)
  12054    S $P(CHSU B2,U,21)=$ P(CHSUB2,U ,21)+CHSUB SUM(2,1)
  12055   "RTN","CHG CPRD1",207 ,0)
  12056    S $P(CHSU B2,U,22)=$ P(CHSUB2,U ,22)+CHSUB SUM(2,2)
  12057   "RTN","CHG CPRD1",208 ,0)
  12058    S $P(CHSU B2,U,32)=$ P(CHSUB2,U ,32)+CHSUB SUM(3,1)
  12059   "RTN","CHG CPRD1",209 ,0)
  12060    S $P(CHSU B2,U,33)=$ P(CHSUB2,U ,33)+CHSUB SUM(3,2)
  12061   "RTN","CHG CPRD1",210 ,0)
  12062    S $P(CHSU B2,U,43)=$ P(CHSUB2,U ,43)+CHSUB SUM(4,1)
  12063   "RTN","CHG CPRD1",211 ,0)
  12064    S $P(CHSU B2,U,44)=$ P(CHSUB2,U ,44)+CHSUB SUM(4,2)
  12065   "RTN","CHG CPRD1",212 ,0)
  12066    S ^UTILIT Y($J,CHSUB NAME,"B")= CHSUB2
  12067   "RTN","CHG CPRD1",213 ,0)
  12068    Q
  12069   "RTN","CHG CPRD1",214 ,0)
  12070   CHCHECK6 ;
  12071   "RTN","CHG CPRD1",215 ,0)
  12072    Q:CHSDAT= 0
  12073   "RTN","CHG CPRD1",216 ,0)
  12074    Q:CHSDAT= ""
  12075   "RTN","CHG CPRD1",217 ,0)
  12076    S:$D(CHSD AT) CHSETS W="Y"
  12077   "RTN","CHG CPRD1",218 ,0)
  12078    Q
  12079   "RTN","CHG CPRD1",219 ,0)
  12080   QUIT75 ;
  12081   "RTN","CHG CPRD1",220 ,0)
  12082    D GET60
  12083   "RTN","CHG CPRD1",221 ,0)
  12084    S CHNAME= ""
  12085   "RTN","CHG CPRD1",222 ,0)
  12086    S CHSBEG= 0
  12087   "RTN","CHG CPRD1",223 ,0)
  12088    F  S CHNA ME=$O(^UTI LITY($J,CH NAME)) Q:C HNAME=""   D HDR80^CH GCPRD2 D N XT77^CHGCP RD2 D TMP1
  12089   "RTN","CHG CPRD1",224 ,0)
  12090    K CHA
  12091   "RTN","CHG CPRD1",225 ,0)
  12092    Q
  12093   "RTN","CHG CPRD1",226 ,0)
  12094   TMP1 ;
  12095   "RTN","CHG CPRD1",227 ,0)
  12096    S X=CHNAM E,DIC=200, DIC(0)="X"  D ^DIC S  EMPL=$P(Y, U,1)
  12097   "RTN","CHG CPRD1",228 ,0)
  12098    ;S EMPL=C HACTDUZ
  12099   "RTN","CHG CPRD1",229 ,0)
  12100    S SDAY=CH END
  12101   "RTN","CHG CPRD1",230 ,0)
  12102    S CWEK=CH DT14
  12103   "RTN","CHG CPRD1",231 ,0)
  12104    D COMM
  12105   "RTN","CHG CPRD1",232 ,0)
  12106   PRT3 I $Y> 58 W @IOF
  12107   "RTN","CHG CPRD1",233 ,0)
  12108    W !!,"COM MENTS:"
  12109   "RTN","CHG CPRD1",234 ,0)
  12110    I '$D(CHA ) W ?12,"N ONE" Q
  12111   "RTN","CHG CPRD1",235 ,0)
  12112    S CHTER=9 99999999
  12113   "RTN","CHG CPRD1",236 ,0)
  12114   PRT1 S CHT ER=$O(CHA( CHTER),-1)  G:'CHTER  END
  12115   "RTN","CHG CPRD1",237 ,0)
  12116    I CHTER<C WEK G PRT1
  12117   "RTN","CHG CPRD1",238 ,0)
  12118    S I1=1,CH TER1=$$FMT E^XLFDT(CH TER,"1D")
  12119   "RTN","CHG CPRD1",239 ,0)
  12120    W ?12,CHT ER1
  12121   "RTN","CHG CPRD1",240 ,0)
  12122   PRT2 S I1= I1+1 I I1> 9 G PRT1
  12123   "RTN","CHG CPRD1",241 ,0)
  12124    I $P(CHA( CHTER),U,I 1)=""!($P( CHA(CHTER) ,"^",I1)=0 ) G PRT2
  12125   "RTN","CHG CPRD1",242 ,0)
  12126    I I1=9 S  CHCOM=0 D  CONCOM W ? 24," ----- - ",CHPRTC OM,?51,$J( $FN($P(CHA (CHTER),"^ ",I1)/60," ",2),6,2), ?58,"HR",!  G PRT2
  12127   "RTN","CHG CPRD1",243 ,0)
  12128    S CHCOM=I 1-1 D CONC OM
  12129   "RTN","CHG CPRD1",244 ,0)
  12130    W ?24," - ----- ",CH PRTCOM,?51 ,$J($FN($P (CHA(CHTER ),"^",I1)/ 60,"",2),6 ,2),?58,"H R",!
  12131   "RTN","CHG CPRD1",245 ,0)
  12132    G PRT2
  12133   "RTN","CHG CPRD1",246 ,0)
  12134    Q
  12135   "RTN","CHG CPRD1",247 ,0)
  12136   END ;
  12137   "RTN","CHG CPRD1",248 ,0)
  12138    K CHA
  12139   "RTN","CHG CPRD1",249 ,0)
  12140    Q
  12141   "RTN","CHG CPRD1",250 ,0)
  12142   COMM ;
  12143   "RTN","CHG CPRD1",251 ,0)
  12144    I '$D(^CH MDIC(74100 2.21,EMPL, 600)) G E1
  12145   "RTN","CHG CPRD1",252 ,0)
  12146    S CHDATE1 =$$FMADD^X LFDT(SDAY, 1,0,0,0)
  12147   "RTN","CHG CPRD1",253 ,0)
  12148   COMM2 ;
  12149   "RTN","CHG CPRD1",254 ,0)
  12150    S CHDATE1 =$O(^CHMDI C(741002.2 1,EMPL,600 ,CHDATE1), -1) G:'CHD ATE1 E1
  12151   "RTN","CHG CPRD1",255 ,0)
  12152    I '$D(^CH MDIC(74100 2.21,EMPL, 600,CHDATE 1,0)) G CO MM2
  12153   "RTN","CHG CPRD1",256 ,0)
  12154    I CHDATE1 <CWEK G E1
  12155   "RTN","CHG CPRD1",257 ,0)
  12156    S CHA(CHD ATE1)=^CHM DIC(741002 .21,EMPL,6 00,CHDATE1 ,0) G COMM 2
  12157   "RTN","CHG CPRD1",258 ,0)
  12158   E1 K CHDAT E1
  12159   "RTN","CHG CPRD1",259 ,0)
  12160    Q
  12161   "RTN","CHG CPRD1",260 ,0)
  12162   CONCOM  ;
  12163   "RTN","CHG CPRD1",261 ,0)
  12164    S V=CHCOM
  12165   "RTN","CHG CPRD1",262 ,0)
  12166    S CHPRTCO M=$S(V=1:" ANNUAL LEA VE",V=2:"S ICK LEAVE" ,V=3:"OTHE R LEAVE",V =4:"MEETIN GS",V=5:"T RAINING",V =6:"SPECIA L PROJECTS ",V=7:"SYS TEM DOWNTI ME",V=0:"O THER")
  12167   "RTN","CHG CPRD1",263 ,0)
  12168    K V Q
  12169   "RTN","CHG CPRD1",264 ,0)
  12170   LAST Q
  12171   "RTN","CHG CPRD1",265 ,0)
  12172   QUEUE90 ;
  12173   "RTN","CHG CPRD1",266 ,0)
  12174    S ZTDTH=$ H
  12175   "RTN","CHG CPRD1",267 ,0)
  12176    S ZTRTN=" MAIN8^CHGC PRD1"
  12177   "RTN","CHG CPRD1",268 ,0)
  12178    S ZTDESC= "SUSPENSE  UNIT PRODU CTIVITY RE PORT"
  12179   "RTN","CHG CPRD1",269 ,0)
  12180    S ZTSAVE( "*")=""
  12181   "RTN","CHG CPRD1",270 ,0)
  12182    D ^%ZTLOA D
  12183   "RTN","CHG CPRD1",271 ,0)
  12184    ;D MAIN8^ CHGCPRD1
  12185   "RTN","CHG CPRD1",272 ,0)
  12186    W !!?5,"R eport queu ed!"
  12187   "RTN","CHG CPRD1",273 ,0)
  12188    D HOME^%Z IS Q
  12189   "RTN","CHG CPRD1",274 ,0)
  12190    Q
  12191   "RTN","CHG CPRD1",275 ,0)
  12192   END95 ;
  12193   "RTN","CHG CPRD1",276 ,0)
  12194    Q
  12195   "RTN","CHG CPRD1",277 ,0)
  12196   SBRS D CSB RS^CHSC2 Q   ; Noline  error on  8/1/05
  12197   "RTN","CHG CPRD1",278 ,0)
  12198    ;R Y:$S($ D(DTIME):D TIME,1:60)
  12199   "RTN","CHG CPRD1",279 ,0)
  12200    I '$T W * 7 R Y:5 G  SBRS:Y="."  S:'$T Y=I OZFO
  12201   "RTN","CHG CPRD1",280 ,0)
  12202   SBRS1 K DF OUT,DUOUT, DQOUT S:'$ D(IOZFO) I OZFO="^^"  S:'$D(IOZB K) IOZBK=" ^"
  12203   "RTN","CHG CPRD1",281 ,0)
  12204    I IOZFO=Y  S (DFOUT, Y)="" Q
  12205   "RTN","CHG CPRD1",282 ,0)
  12206    S:Y=IOZBK  (DUOUT,Y) ="" S:Y?1" ?".E!(Y["^ ") (DQOUT, Y)=""
  12207   "RTN","CHG CPRD1",283 ,0)
  12208    Q
  12209   "RTN","CHG CPRD3")
  12210   0^96^B5561 2408
  12211   "RTN","CHG CPRD3",1,0 )
  12212   CHGCPRD3 ; CVA/AHJ;CP D SUMMARY  UNIT PRODU CTIVITY;08 /22/97  11 :03 AM
  12213   "RTN","CHG CPRD3",2,0 )
  12214    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  12215   "RTN","CHG CPRD3",3,0 )
  12216    ;CPTS 111 47
  12217   "RTN","CHG CPRD3",4,0 )
  12218     ; Defect  929150 -  TGH - 2/20 /2019 Only  Set Print  Type with  /W if not  HFS or P- M
  12219   "RTN","CHG CPRD3",5,0 )
  12220    S AA=0
  12221   "RTN","CHG CPRD3",6,0 )
  12222    ;THIS ROU TINE CALLE D BY CHGCP RD1
  12223   "RTN","CHG CPRD3",7,0 )
  12224    ;THIS ROU TINE CALLS  CHGCPRD4  FOR SUB-RO UTINES
  12225   "RTN","CHG CPRD3",8,0 )
  12226    S:'$D(DUZ ) DUZ=1,DU Z(0)="" I  '$D(DT) S  %DT="",X=" T" D ^%DT  S DT=Y
  12227   "RTN","CHG CPRD3",9,0 )
  12228    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  12229   "RTN","CHG CPRD3",10, 0)
  12230    I '$D(IOZ ) S %IS="N ",IOP=$I D  ^%ZIS K I OP S IOZ=I O,IOZL=IOS L,IOZW=IOM ,IOZF=IOF, IOZT=IOST, IOZN=ION,I OZS=IOS
  12231   "RTN","CHG CPRD3",11, 0)
  12232   START1 ;
  12233   "RTN","CHG CPRD3",12, 0)
  12234    S PAGE=0
  12235   "RTN","CHG CPRD3",13, 0)
  12236    K ^UTILIT Y($J)
  12237   "RTN","CHG CPRD3",14, 0)
  12238    S (CHCLMD AY,CHSUBDA Y)=0
  12239   "RTN","CHG CPRD3",15, 0)
  12240    F C=1:1:4  D
  12241   "RTN","CHG CPRD3",16, 0)
  12242    .F D=1:1: 11 S CHLIN E(C,D)=0
  12243   "RTN","CHG CPRD3",17, 0)
  12244    F H=1:1:1 8 S CHDAY( H)=0
  12245   "RTN","CHG CPRD3",18, 0)
  12246    F C=1:1:4  D
  12247   "RTN","CHG CPRD3",19, 0)
  12248    .F D=1:1: 2 S CHSUBS UM(C,D)=0
  12249   "RTN","CHG CPRD3",20, 0)
  12250    S (CHTOTA L,CHTOT(1) ,CHTOT(2)) =0
  12251   "RTN","CHG CPRD3",21, 0)
  12252   IND2 ; IND IVIDUAL RE QUEST
  12253   "RTN","CHG CPRD3",22, 0)
  12254    S CHDUZ=D UZ
  12255   "RTN","CHG CPRD3",23, 0)
  12256    D DATE3
  12257   "RTN","CHG CPRD3",24, 0)
  12258    I X="N" G  START1^CH GCPRD1
  12259   "RTN","CHG CPRD3",25, 0)
  12260    W ! D STA RT5
  12261   "RTN","CHG CPRD3",26, 0)
  12262    G START1^ CHGCPRD1
  12263   "RTN","CHG CPRD3",27, 0)
  12264    Q
  12265   "RTN","CHG CPRD3",28, 0)
  12266   DATE3 ;
  12267   "RTN","CHG CPRD3",29, 0)
  12268    W !! S %D T("A")="In put Ending  Date: or  ""^"" to q uit "
  12269   "RTN","CHG CPRD3",30, 0)
  12270    S %DT="AE NP",%DT(0) ="-T"
  12271   "RTN","CHG CPRD3",31, 0)
  12272    D ^%DT
  12273   "RTN","CHG CPRD3",32, 0)
  12274    K %DT(0)
  12275   "RTN","CHG CPRD3",33, 0)
  12276    I X="^" S  X="N" Q
  12277   "RTN","CHG CPRD3",34, 0)
  12278    I X="^^"  S X="N" Q
  12279   "RTN","CHG CPRD3",35, 0)
  12280    I Y=-1 G  DATE3
  12281   "RTN","CHG CPRD3",36, 0)
  12282    S CHEND=Y
  12283   "RTN","CHG CPRD3",37, 0)
  12284    X ^DD("DD ") S CHEDA Y=Y
  12285   "RTN","CHG CPRD3",38, 0)
  12286    S X1=CHEN D S X2="-1 3" D C^%DT C S CHDT14 =X
  12287   "RTN","CHG CPRD3",39, 0)
  12288    S X1=CHEN D S X2="-3 66" D C^%D TC S CHBEG =X
  12289   "RTN","CHG CPRD3",40, 0)
  12290    S Y=CHDT1 4 X ^DD("D D") S CHBD AY=Y
  12291   "RTN","CHG CPRD3",41, 0)
  12292    S X="NOW" ,%DT="R" D  ^%DT X ^D D("DD") S  CHTODAY=Y
  12293   "RTN","CHG CPRD3",42, 0)
  12294    S Y=""
  12295   "RTN","CHG CPRD3",43, 0)
  12296    Q
  12297   "RTN","CHG CPRD3",44, 0)
  12298   START5 ;
  12299   "RTN","CHG CPRD3",45, 0)
  12300    ;NEXT LIN ES QUE REP ORT
  12301   "RTN","CHG CPRD3",46, 0)
  12302    S IOP="Q"  D ^%ZIS Q :POP
  12303   "RTN","CHG CPRD3",47, 0)
  12304    ; Defect  929150 - T GH - 2/20/ 2019 Only  Set with / W if not H FS or P-M
  12305   "RTN","CHG CPRD3",48, 0)
  12306    ; I ION'[ "/W" S ION =ION_"/W"
  12307   "RTN","CHG CPRD3",49, 0)
  12308    S ION=ION _$S(ION="H FS":"",ION ="P-MESSAG E-HFS":"", 1:"/W")
  12309   "RTN","CHG CPRD3",50, 0)
  12310    S CHFIO=I ON,ZTSAVE( "CHFIO")=" ",ZTIO=CHF IO
  12311   "RTN","CHG CPRD3",51, 0)
  12312    G:$D(IO(" Q"))!(IO'= IO(0)) QUE UE90
  12313   "RTN","CHG CPRD3",52, 0)
  12314   MAIN8 ;
  12315   "RTN","CHG CPRD3",53, 0)
  12316    S CHSBEG= CHBEG
  12317   "RTN","CHG CPRD3",54, 0)
  12318   NXT10 ;
  12319   "RTN","CHG CPRD3",55, 0)
  12320    S (LEV1,L EV2)=0
  12321   "RTN","CHG CPRD3",56, 0)
  12322    F  S CHSB EG=$O(^CHM PROD(74106 0.02,CHSBE G)) Q:'CHS BEG  Q:$E( CHSBEG,1,7 )>CHEND  D  NXT11
  12323   "RTN","CHG CPRD3",57, 0)
  12324    D QUIT75
  12325   "RTN","CHG CPRD3",58, 0)
  12326    Q
  12327   "RTN","CHG CPRD3",59, 0)
  12328   NXT11 ;
  12329   "RTN","CHG CPRD3",60, 0)
  12330    S LEV2=0
  12331   "RTN","CHG CPRD3",61, 0)
  12332    F  S LEV2 =$O(^CHMPR OD(741060. 02,CHSBEG, 1,LEV2)) Q :'LEV2  D  GOTIT12
  12333   "RTN","CHG CPRD3",62, 0)
  12334    Q
  12335   "RTN","CHG CPRD3",63, 0)
  12336   GOTIT12 ;
  12337   "RTN","CHG CPRD3",64, 0)
  12338    S CHDAT1= $G(^CHMPRO D(741060.0 2,CHSBEG,1 ,LEV2,0))
  12339   "RTN","CHG CPRD3",65, 0)
  12340    Q:CHDAT1= ""
  12341   "RTN","CHG CPRD3",66, 0)
  12342    S CHACTDU Z=$P(CHDAT 1,U,1)
  12343   "RTN","CHG CPRD3",67, 0)
  12344    S CHDATE= $E(CHSBEG, 1,7)
  12345   "RTN","CHG CPRD3",68, 0)
  12346    D ALLNX25
  12347   "RTN","CHG CPRD3",69, 0)
  12348    Q
  12349   "RTN","CHG CPRD3",70, 0)
  12350   ALLNX25 ;
  12351   "RTN","CHG CPRD3",71, 0)
  12352    S (CHTOT( 1),CHTOT(2 ))=0
  12353   "RTN","CHG CPRD3",72, 0)
  12354    D ONLY29^ CHGCPRD4
  12355   "RTN","CHG CPRD3",73, 0)
  12356    D CALC45^ CHGCPRD4,A DDSUM50^CH GCPRD4
  12357   "RTN","CHG CPRD3",74, 0)
  12358    S CHACTDU Z=$P(CHDAT 1,U,1)
  12359   "RTN","CHG CPRD3",75, 0)
  12360    ; NEXT LI NE UPDATE  CURRENT DA Y "TOT"ALS
  12361   "RTN","CHG CPRD3",76, 0)
  12362    D DOA27
  12363   "RTN","CHG CPRD3",77, 0)
  12364    I '$D(^UT ILITY($J," TOT","B"))  S ^UTILIT Y($J,"TOT" ,"B")=0
  12365   "RTN","CHG CPRD3",78, 0)
  12366    S J=1
  12367   "RTN","CHG CPRD3",79, 0)
  12368    F I=1:1:4  D
  12369   "RTN","CHG CPRD3",80, 0)
  12370    .F H=1:1: 11 S $P(CH ARRAY2,U,J )=CHLINE(I ,H) S J=J+ 1
  12371   "RTN","CHG CPRD3",81, 0)
  12372    .Q
  12373   "RTN","CHG CPRD3",82, 0)
  12374    S J=0
  12375   "RTN","CHG CPRD3",83, 0)
  12376    I $D(^UTI LITY($J,"T OT","B"))  D DOB28 ;G ET PREV "B "
  12377   "RTN","CHG CPRD3",84, 0)
  12378    S ^UTILIT Y($J,"TOT" ,"B")=CHAR RAY2
  12379   "RTN","CHG CPRD3",85, 0)
  12380    ;
  12381   "RTN","CHG CPRD3",86, 0)
  12382    ;D:CHIND= "I" GET60
  12383   "RTN","CHG CPRD3",87, 0)
  12384    D CLRTOT5 7
  12385   "RTN","CHG CPRD3",88, 0)
  12386    K CHARRAR 2,CHA
  12387   "RTN","CHG CPRD3",89, 0)
  12388    Q
  12389   "RTN","CHG CPRD3",90, 0)
  12390   DOA27 ;
  12391   "RTN","CHG CPRD3",91, 0)
  12392    Q:CHEND'= CHDATE
  12393   "RTN","CHG CPRD3",92, 0)
  12394    I '$D(^UT ILITY($J," TOT",CHDAT E,"A")) S  ^UTILITY($ J,"TOT",CH DATE,"A")= 0
  12395   "RTN","CHG CPRD3",93, 0)
  12396    S CHARRAY 1=$G(^UTIL ITY($J,"TO T",CHDATE, "A"))
  12397   "RTN","CHG CPRD3",94, 0)
  12398    F H=1:1:1 8 S $P(CHA RRAY1,U,H) =$P(CHARRA Y1,U,H)+CH DAY(H)
  12399   "RTN","CHG CPRD3",95, 0)
  12400    ;DAY SUMM ARY IF END  DAY MATCH ES
  12401   "RTN","CHG CPRD3",96, 0)
  12402    S ^UTILIT Y($J,"TOT" ,CHDATE,"A ")=CHARRAY 1
  12403   "RTN","CHG CPRD3",97, 0)
  12404    Q
  12405   "RTN","CHG CPRD3",98, 0)
  12406   DOB28 ;
  12407   "RTN","CHG CPRD3",99, 0)
  12408    S CHGETB= $G(^UTILIT Y($J,"TOT" ,"B"))
  12409   "RTN","CHG CPRD3",100 ,0)
  12410    F H=1:1:4 4 S $P(CHA RRAY2,U,H) =$P(CHARRA Y2,U,H)+$P (CHGETB,U, H)
  12411   "RTN","CHG CPRD3",101 ,0)
  12412    Q
  12413   "RTN","CHG CPRD3",102 ,0)
  12414   CLRTOT57 ;
  12415   "RTN","CHG CPRD3",103 ,0)
  12416    F C=1:1:4  D
  12417   "RTN","CHG CPRD3",104 ,0)
  12418    .F D=1:1: 11 S CHLIN E(C,D)=0
  12419   "RTN","CHG CPRD3",105 ,0)
  12420    F H=1:1:1 8 S CHDAY( H)=0
  12421   "RTN","CHG CPRD3",106 ,0)
  12422    F C=1:1:4  D
  12423   "RTN","CHG CPRD3",107 ,0)
  12424    .F D=1:1: 2 S CHSUBS UM(C,D)=0
  12425   "RTN","CHG CPRD3",108 ,0)
  12426    Q
  12427   "RTN","CHG CPRD3",109 ,0)
  12428   GET60 ;GET  "C" REF S UBMISSIONS /CLAIMS
  12429   "RTN","CHG CPRD3",110 ,0)
  12430    S (CHPDI, CHCLMDAY,C HSUBDAY)=0
  12431   "RTN","CHG CPRD3",111 ,0)
  12432    S CHSUBDU Z=0
  12433   "RTN","CHG CPRD3",112 ,0)
  12434    S CHSUB=$ P($E(CHBEG ,1,7),".", 1)
  12435   "RTN","CHG CPRD3",113 ,0)
  12436    F  S CHSU B=$O(^CHMP ROD(741060 .01,CHSUB) ) Q:'CHSUB   Q:$E(CHS UB,1,7)>CH END  D GOT 61
  12437   "RTN","CHG CPRD3",114 ,0)
  12438    Q
  12439   "RTN","CHG CPRD3",115 ,0)
  12440   GOT61 ;
  12441   "RTN","CHG CPRD3",116 ,0)
  12442    S CHSUBI= 0
  12443   "RTN","CHG CPRD3",117 ,0)
  12444    F  S CHSU BI=$O(^CHM PROD(74106 0.01,CHSUB ,100,CHSUB I)) Q:'CHS UBI  D GOT 63
  12445   "RTN","CHG CPRD3",118 ,0)
  12446    Q
  12447   "RTN","CHG CPRD3",119 ,0)
  12448    ;GOT62 ;
  12449   "RTN","CHG CPRD3",120 ,0)
  12450    ;Q:'$D(^C HMPROD(741 060.01,CHS UB,100,CHS UBI,0))
  12451   "RTN","CHG CPRD3",121 ,0)
  12452    ;F  S CHP DIIN=$O(^C HMPROD(741 060.01,"C" ,CHSUB,CHS UBDUZ,CHPD IIN)) Q:'C HPDIIN  D  GOT63
  12453   "RTN","CHG CPRD3",122 ,0)
  12454    ;Q
  12455   "RTN","CHG CPRD3",123 ,0)
  12456   GOT63 ;
  12457   "RTN","CHG CPRD3",124 ,0)
  12458    Q:'$D(^CH MPROD(7410 60.01,CHSU B,100,CHSU BI,0))
  12459   "RTN","CHG CPRD3",125 ,0)
  12460    S (CHCLMD AY,CHSUBDA Y)=0
  12461   "RTN","CHG CPRD3",126 ,0)
  12462    S TMPREC1 =^CHMPROD( 741060.01, CHSUB,100, CHSUBI,0)
  12463   "RTN","CHG CPRD3",127 ,0)
  12464    S CHCLAIM =$P(TMPREC 1,"^",3)+$ P(TMPREC1, "^",6)+$P( TMPREC1,"^ ",9)
  12465   "RTN","CHG CPRD3",128 ,0)
  12466    S CHSUBCT =$P(TMPREC 1,"^",2)+$ P(TMPREC1, "^",5)+$P( TMPREC1,"^ ",8)
  12467   "RTN","CHG CPRD3",129 ,0)
  12468    D GOT64 S  CNT1=0
  12469   "RTN","CHG CPRD3",130 ,0)
  12470    S CHSUBKE Y=$E(CHSUB ,1,7)
  12471   "RTN","CHG CPRD3",131 ,0)
  12472    I CHEND=$ E(CHSUB,1, 7) D
  12473   "RTN","CHG CPRD3",132 ,0)
  12474    .S CHCLMD AY=CHCLMDA Y+CHCLAIM
  12475   "RTN","CHG CPRD3",133 ,0)
  12476    .S CHSUBD AY=CHSUBDA Y+CHSUBCT
  12477   "RTN","CHG CPRD3",134 ,0)
  12478    .I '$D(^U TILITY($J, "TOT",CHSU BKEY,"A"))  S ^UTILIT Y($J,"TOT" ,CHSUBKEY, "A")=0
  12479   "RTN","CHG CPRD3",135 ,0)
  12480    .S CHSUB1 =$G(^UTILI TY($J,"TOT ",CHDATE," A"))
  12481   "RTN","CHG CPRD3",136 ,0)
  12482    .S $P(CHS UB1,U,16)= $P(CHSUB1, U,16)+CHSU BDAY
  12483   "RTN","CHG CPRD3",137 ,0)
  12484    .S $P(CHS UB1,U,17)= $P(CHSUB1, U,17)+CHCL MDAY
  12485   "RTN","CHG CPRD3",138 ,0)
  12486    .S ^UTILI TY($J,"TOT ",CHSUBKEY ,"A")=CHSU B1
  12487   "RTN","CHG CPRD3",139 ,0)
  12488    F E=CHLOO P:1:4 D
  12489   "RTN","CHG CPRD3",140 ,0)
  12490    .S CHSUBS UM(E,2)=CH SUBSUM(E,2 )+CHCLAIM
  12491   "RTN","CHG CPRD3",141 ,0)
  12492    .S CHTOTA L=CHTOTAL+ CHSUBCT
  12493   "RTN","CHG CPRD3",142 ,0)
  12494    .S CHSUBS UM(E,1)=CH SUBSUM(E,1 )+CHSUBCT
  12495   "RTN","CHG CPRD3",143 ,0)
  12496    D GOT65
  12497   "RTN","CHG CPRD3",144 ,0)
  12498    D CLRTOT5 7
  12499   "RTN","CHG CPRD3",145 ,0)
  12500    ;S (CHCLM DAY,CHSUBD AY)=0
  12501   "RTN","CHG CPRD3",146 ,0)
  12502    Q
  12503   "RTN","CHG CPRD3",147 ,0)
  12504   GOT64 ;
  12505   "RTN","CHG CPRD3",148 ,0)
  12506    ; CALC AG EING DAYS  SET LOOP D AYS
  12507   "RTN","CHG CPRD3",149 ,0)
  12508    S X1=CHEN D,X2=$E(CH SUB,1,7) D  ^%DTC S C HSUMDT=X
  12509   "RTN","CHG CPRD3",150 ,0)
  12510    S CHLOOP= 4 Q:CHSUMD T>365
  12511   "RTN","CHG CPRD3",151 ,0)
  12512    I CHSUMDT <8 S CHLOO P=1 Q:CHLO OP=1
  12513   "RTN","CHG CPRD3",152 ,0)
  12514    I CHSUMDT <15 S CHLO OP=2 Q:CHL OOP=2
  12515   "RTN","CHG CPRD3",153 ,0)
  12516    I CHSUMDT <31 S CHLO OP=3 Q:CHL OOP=3
  12517   "RTN","CHG CPRD3",154 ,0)
  12518    S CHLOOP= 4
  12519   "RTN","CHG CPRD3",155 ,0)
  12520    Q
  12521   "RTN","CHG CPRD3",156 ,0)
  12522   GOT65 ;
  12523   "RTN","CHG CPRD3",157 ,0)
  12524    I '$D(^UT ILITY($J," TOT","B"))  S ^UTILIT Y($J,"TOT" ,"B")=0
  12525   "RTN","CHG CPRD3",158 ,0)
  12526    S CHSUB2= $G(^UTILIT Y($J,"TOT" ,"B"))
  12527   "RTN","CHG CPRD3",159 ,0)
  12528    S $P(CHSU B2,U,10)=$ P(CHSUB2,U ,10)+CHSUB SUM(1,1)
  12529   "RTN","CHG CPRD3",160 ,0)
  12530    S $P(CHSU B2,U,11)=$ P(CHSUB2,U ,11)+CHSUB SUM(1,2)
  12531   "RTN","CHG CPRD3",161 ,0)
  12532    S $P(CHSU B2,U,21)=$ P(CHSUB2,U ,21)+CHSUB SUM(2,1)
  12533   "RTN","CHG CPRD3",162 ,0)
  12534    S $P(CHSU B2,U,22)=$ P(CHSUB2,U ,22)+CHSUB SUM(2,2)
  12535   "RTN","CHG CPRD3",163 ,0)
  12536    S $P(CHSU B2,U,32)=$ P(CHSUB2,U ,32)+CHSUB SUM(3,1)
  12537   "RTN","CHG CPRD3",164 ,0)
  12538    S $P(CHSU B2,U,33)=$ P(CHSUB2,U ,33)+CHSUB SUM(3,2)
  12539   "RTN","CHG CPRD3",165 ,0)
  12540    S $P(CHSU B2,U,43)=$ P(CHSUB2,U ,43)+CHSUB SUM(4,1)
  12541   "RTN","CHG CPRD3",166 ,0)
  12542    S $P(CHSU B2,U,44)=$ P(CHSUB2,U ,44)+CHSUB SUM(4,2)
  12543   "RTN","CHG CPRD3",167 ,0)
  12544    S ^UTILIT Y($J,"TOT" ,"B")=CHSU B2
  12545   "RTN","CHG CPRD3",168 ,0)
  12546    Q
  12547   "RTN","CHG CPRD3",169 ,0)
  12548   QUIT75 ;
  12549   "RTN","CHG CPRD3",170 ,0)
  12550    D GET60^C HGCPRD3
  12551   "RTN","CHG CPRD3",171 ,0)
  12552    S CHSBEG= 0
  12553   "RTN","CHG CPRD3",172 ,0)
  12554    D HDR80^C HGCPRD4 D  NXT77^CHGC PRD4 D TMP 1
  12555   "RTN","CHG CPRD3",173 ,0)
  12556    K CHA
  12557   "RTN","CHG CPRD3",174 ,0)
  12558    Q
  12559   "RTN","CHG CPRD3",175 ,0)
  12560   TMP1 ;
  12561   "RTN","CHG CPRD3",176 ,0)
  12562    S SDAY=CH END
  12563   "RTN","CHG CPRD3",177 ,0)
  12564    S CWEK=CH DT14
  12565   "RTN","CHG CPRD3",178 ,0)
  12566    D CUMCOM  D PRT3
  12567   "RTN","CHG CPRD3",179 ,0)
  12568    Q
  12569   "RTN","CHG CPRD3",180 ,0)
  12570   CUMCOM ;SE TS UP A LO CAL ARRAY  FOR CUM RE PORT COMME NTS
  12571   "RTN","CHG CPRD3",181 ,0)
  12572    S U="^",E MPL=0
  12573   "RTN","CHG CPRD3",182 ,0)
  12574   CUM1 S EMP L=$O(^CHMD IC(741002. 21,EMPL))  G:'EMPL E2
  12575   "RTN","CHG CPRD3",183 ,0)
  12576    I '$D(^CH MDIC(74100 2.21,EMPL, 0)) G CUM1
  12577   "RTN","CHG CPRD3",184 ,0)
  12578    ;I $P(^CH MDIC(74100 2.21,EMPL, 0),"^",12) '=1 G CUM1
  12579   "RTN","CHG CPRD3",185 ,0)
  12580    I '$D(^CH MDIC(74100 2.21,EMPL, 600)) G CU M1
  12581   "RTN","CHG CPRD3",186 ,0)
  12582    S CHDATE= $$FMADD^XL FDT(SDAY,1 ,0,0,0)
  12583   "RTN","CHG CPRD3",187 ,0)
  12584   CUM2 S CHD ATE=$O(^CH MDIC(74100 2.21,EMPL, 600,CHDATE ),-1) G:'C HDATE CUM1
  12585   "RTN","CHG CPRD3",188 ,0)
  12586    I '$D(^CH MDIC(74100 2.21,EMPL, 600,CHDATE ,0)) G CUM 2
  12587   "RTN","CHG CPRD3",189 ,0)
  12588    I CHDATE< CWEK G CUM 1
  12589   "RTN","CHG CPRD3",190 ,0)
  12590    S REC3=^C HMDIC(7410 02.21,EMPL ,600,CHDAT E,0)
  12591   "RTN","CHG CPRD3",191 ,0)
  12592    I '$D(CHA (CHDATE))  D  G CUM2
  12593   "RTN","CHG CPRD3",192 ,0)
  12594    .F I=2:1: 9 S $P(CHA (CHDATE),U ,I)=$P(REC 3,U,I)
  12595   "RTN","CHG CPRD3",193 ,0)
  12596    S I=1
  12597   "RTN","CHG CPRD3",194 ,0)
  12598   CUM3 S I=I +1 I I>9 G  CUM2
  12599   "RTN","CHG CPRD3",195 ,0)
  12600    ;I I=8&($ P(CHA(CHDA TE),U,I)'= ""!($P(CHA (CHDATE),U ,I)'=0)) G  CUM3
  12601   "RTN","CHG CPRD3",196 ,0)
  12602    S $P(CHA( CHDATE),U, I)=$P(CHA( CHDATE),U, I)+$P(REC3 ,U,I)  
  12603   "RTN","CHG CPRD3",197 ,0)
  12604    G CUM3
  12605   "RTN","CHG CPRD3",198 ,0)
  12606    ;S CHA(CH DATE)=^CHM DIC(741002 .21,EMPL,6 00,CHDATE, 0) G COMM2
  12607   "RTN","CHG CPRD3",199 ,0)
  12608   E2 K CHDAT E Q
  12609   "RTN","CHG CPRD3",200 ,0)
  12610   PRT3 I $Y> 58 W @IOF
  12611   "RTN","CHG CPRD3",201 ,0)
  12612    W !!,"COM MENTS:"
  12613   "RTN","CHG CPRD3",202 ,0)
  12614    I '$D(CHA ) W ?12,"N ONE" Q
  12615   "RTN","CHG CPRD3",203 ,0)
  12616    S CHTER=9 99999999
  12617   "RTN","CHG CPRD3",204 ,0)
  12618   PRT1 S CHT ER=$O(CHA( CHTER),-1)  G:'CHTER  END
  12619   "RTN","CHG CPRD3",205 ,0)
  12620    I CHTER<C WEK G PRT1
  12621   "RTN","CHG CPRD3",206 ,0)
  12622    S I1=1,CH TER1=$$FMT E^XLFDT(CH TER,"1D")
  12623   "RTN","CHG CPRD3",207 ,0)
  12624    W ?12,CHT ER1
  12625   "RTN","CHG CPRD3",208 ,0)
  12626   PRT2 S I1= I1+1 I I1> 9 G PRT1
  12627   "RTN","CHG CPRD3",209 ,0)
  12628    I $P(CHA( CHTER),U,I 1)=""!($P( CHA(CHTER) ,"^",I1)=0 ) G PRT2
  12629   "RTN","CHG CPRD3",210 ,0)
  12630    I I1=9 S  CHCOM=0 D  CONCOM W ? 24," ----- - ",CHPRTC OM,?51,$J( $FN($P(CHA (CHTER),"^ ",I1)/60," ",2),6,2), ?58,"HR",!  G PRT2
  12631   "RTN","CHG CPRD3",211 ,0)
  12632    S CHCOM=I 1-1 D CONC OM
  12633   "RTN","CHG CPRD3",212 ,0)
  12634    W ?24," - ----- ",CH PRTCOM,?51 ,$J($FN($P (CHA(CHTER ),"^",I1)/ 60,"",2),6 ,2),?58,"H R",!
  12635   "RTN","CHG CPRD3",213 ,0)
  12636    G PRT2
  12637   "RTN","CHG CPRD3",214 ,0)
  12638    Q
  12639   "RTN","CHG CPRD3",215 ,0)
  12640   END ;
  12641   "RTN","CHG CPRD3",216 ,0)
  12642    K CHA
  12643   "RTN","CHG CPRD3",217 ,0)
  12644    Q
  12645   "RTN","CHG CPRD3",218 ,0)
  12646   CONCOM  ;
  12647   "RTN","CHG CPRD3",219 ,0)
  12648    S V=CHCOM
  12649   "RTN","CHG CPRD3",220 ,0)
  12650    S CHPRTCO M=$S(V=1:" ANNUAL LEA VE",V=2:"S ICK LEAVE" ,V=3:"OTHE R LEAVE",V =4:"MEETIN GS",V=5:"T RAINING",V =6:"SPECIA L PROJECTS ",V=7:"SYS TEM DOWNTI ME",V=0:"O THER")
  12651   "RTN","CHG CPRD3",221 ,0)
  12652    K V Q
  12653   "RTN","CHG CPRD3",222 ,0)
  12654   LAST Q
  12655   "RTN","CHG CPRD3",223 ,0)
  12656   QUEUE90 ;
  12657   "RTN","CHG CPRD3",224 ,0)
  12658    S ZTDTH=$ H
  12659   "RTN","CHG CPRD3",225 ,0)
  12660    S ZTRTN=" MAIN8^CHGC PRD3"
  12661   "RTN","CHG CPRD3",226 ,0)
  12662    S ZTDESC= "SUSPENSE  UNIT PRODU CTIVITY RE PORT"
  12663   "RTN","CHG CPRD3",227 ,0)
  12664    S ZTSAVE( "*")=""
  12665   "RTN","CHG CPRD3",228 ,0)
  12666    D ^%ZTLOA D
  12667   "RTN","CHG CPRD3",229 ,0)
  12668    ;D MAIN8^ CHGCPRD3
  12669   "RTN","CHG CPRD3",230 ,0)
  12670    W !!?5,"R eport queu ed!"
  12671   "RTN","CHG CPRD3",231 ,0)
  12672    D HOME^%Z IS Q
  12673   "RTN","CHG CPRD3",232 ,0)
  12674    Q
  12675   "RTN","CHG CPRD3",233 ,0)
  12676   END95 ;
  12677   "RTN","CHG CPRD3",234 ,0)
  12678    Q
  12679   "RTN","CHG CPRD3",235 ,0)
  12680   CLMCNT ;
  12681   "RTN","CHG CPRD3",236 ,0)
  12682    S JCLM=0, CNT1=0
  12683   "RTN","CHG CPRD3",237 ,0)
  12684   CLM1 S JCL M=$O(^CHMP AY("C",CHP DIIN,JCLM) ) Q:'JCLM
  12685   "RTN","CHG CPRD3",238 ,0)
  12686    S CNT1=CN T1+1
  12687   "RTN","CHG CPRD3",239 ,0)
  12688    G CLM1
  12689   "RTN","CHG CPRD3",240 ,0)
  12690    Q
  12691   "RTN","CHG CPRD3",241 ,0)
  12692   SBRS R Y:$ S($D(DTIME ):DTIME,1: 60)
  12693   "RTN","CHG CPRD3",242 ,0)
  12694    I '$T W * 7 R Y:5 G  SBRS:Y="."  S:'$T Y=I OZFO
  12695   "RTN","CHG CPRD3",243 ,0)
  12696   SBRS1 K DF OUT,DUOUT, DQOUT S:'$ D(IOZFO) I OZFO="^^"  S:'$D(IOZB K) IOZBK=" ^"
  12697   "RTN","CHG CPRD3",244 ,0)
  12698    I IOZFO=Y  S (DFOUT, Y)="" Q
  12699   "RTN","CHG CPRD3",245 ,0)
  12700    S:Y=IOZBK  (DUOUT,Y) ="" S:Y?1" ?".E!(Y["^ ") (DQOUT, Y)=""
  12701   "RTN","CHG CPRD3",246 ,0)
  12702    Q
  12703   "RTN","CHG CU136")
  12704   0^22^B3819 5134
  12705   "RTN","CHG CU136",1,0 )
  12706   CHGCU136 ; CVA/CR;FOR MAT CEU VE NDOR DATA  SCREEN ;Fe b 06, 2019 @08:43:17
  12707   "RTN","CHG CU136",2,0 )
  12708    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  12709   "RTN","CHG CU136",3,0 )
  12710    ;;2.0
  12711   "RTN","CHG CU136",4,0 )
  12712    ;PT'S - 1 0462*
  12713   "RTN","CHG CU136",5,0 )
  12714    ;CPTS #10 846* 11575 *  #11915
  12715   "RTN","CHG CU136",6,0 )
  12716    ;CPTS #12 599 BY DTP  (12-SEP-9 7)
  12717   "RTN","CHG CU136",7,0 )
  12718    ;BUG7991- 08-01 DRW  - Change o ne line (p hone #) fo r cosmetic  appearanc e for vend or data sc reen - 01/ 28/11.
  12719   "RTN","CHG CU136",8,0 )
  12720    ;CFS 07/2 0/2017 - P L ZIP adde d for User  Story CPE 001-005
  12721   "RTN","CHG CU136",9,0 )
  12722    ;CFS 03/0 6/2018 - D efect 6363 77 Fix PL  ZIP being  saved in P hone Numbe r position  for story  CPE001-00 3.
  12723   "RTN","CHG CU136",10, 0)
  12724    ;CFS 09/2 0/2018 - D efect 8280 50 Change  Vendor Nam e, Address , City, St ate and Zi p
  12725   "RTN","CHG CU136",11, 0)
  12726    ;                  f rom Physic al Locatio n to Remit  To
  12727   "RTN","CHG CU136",12, 0)
  12728    ;DEFECT 8 32270 - TG H- 11/29/1 8 - Preven t PL Zip d isplaying  if Claim T ype is DME , Pharmacy , or Trave l
  12729   "RTN","CHG CU136",13, 0)
  12730   EN1 N (CHN OSEND,CHVP T,DFN,BFN, CHZONE,CHC LM,CHTYP,E DIT,GLPAY, GLDFN,GLEL G,GLPAYW,G LPAYH)
  12731   "RTN","CHG CU136",14, 0)
  12732    S CHTOT=0 ,CHCT=0 K  EDIT
  12733   "RTN","CHG CU136",15, 0)
  12734    S:'$D(^UT ILITY($J," CEU",CHZON E,0)) ^UTI LITY($J,"C EU",CHZONE ,0)=0
  12735   "RTN","CHG CU136",16, 0)
  12736    S CT=^UTI LITY($J,"C EU",CHZONE ,0),U="^"  Q:$D(@(GLP AY_"CHCLM, ""ARCHIVE" ")"))
  12737   "RTN","CHG CU136",17, 0)
  12738    Q:'$D(@(G LPAY_"CHCL M,0)"))  S  REC0=@(GL PAY_"CHCLM ,0)")
  12739   "RTN","CHG CU136",18, 0)
  12740    S REC7=""  S:$D(@(GL PAY_"CHCLM ,7)")) REC 7=^(7)
  12741   "RTN","CHG CU136",19, 0)
  12742    S CHVPT=$ P(REC0,"^" ,3) S:CHVP T="" CHVPT ="PS"
  12743   "RTN","CHG CU136",20, 0)
  12744    S PDIJ=99 99,PDIJ=$O (@(GLPAY_" CHCLM,""PD I"",PDIJ)" ),-1)
  12745   "RTN","CHG CU136",21, 0)
  12746    I PDIJ'=" " S:$D(@(G LPAY_"CHCL M,""PDI"", PDIJ,0)"))  CHPDI=$P( ^(0),"^",1 )
  12747   "RTN","CHG CU136",22, 0)
  12748    I $D(^CHM IMAGE(CHPD I,"P-VEN") ) D:'$D(@( GLPAY_"CHC LM,""VEN"" )"))
  12749   "RTN","CHG CU136",23, 0)
  12750    .S STR=$P (@(GLPAY_" CHCLM,0)") ,"^",4) Q: STR=""
  12751   "RTN","CHG CU136",24, 0)
  12752    .S CHPAGE =$P(STR,"* ",2),CHIMA G=$P(STR," *",3)
  12753   "RTN","CHG CU136",25, 0)
  12754    .Q:'$D(^C HMIMAGE(CH PDI,1,CHPA GE,2,CHIMA G,"VEN"))
  12755   "RTN","CHG CU136",26, 0)
  12756    .S PTR=$P (^("VEN"), "^",14)
  12757   "RTN","CHG CU136",27, 0)
  12758    .Q:PTR=""   Q:'$D(^C HMAGE(CHPD I,"P-VEN", PTR,0))
  12759   "RTN","CHG CU136",28, 0)
  12760    .D NOW^%D TC
  12761   "RTN","CHG CU136",29, 0)
  12762    .S @(GLPA Y_"CHCLM," "VEN"",CHV PT,%,0)")= ^CHMIMAGE( CHPDI,"P-V EN",PTR,0)
  12763   "RTN","CHG CU136",30, 0)
  12764    S REC1=""  S:$D(^CHM VEN(CHVPT, 2)) REC1=^ CHMVEN(CHV PT,2)
  12765   "RTN","CHG CU136",31, 0)
  12766    N RECRT S  RECRT=""  S:$D(^CHMV EN(CHVPT,1 )) RECRT=^ CHMVEN(CHV PT,1)  ;CF S - Defect  828050
  12767   "RTN","CHG CU136",32, 0)
  12768    S RECV=""  S:$D(^CHM VEN(CHVPT, 1)) RECV=^ (0)
  12769   "RTN","CHG CU136",33, 0)
  12770    S CHVEN=" " S:$D(^CH MVEN(CHVPT ,2)) CHVEN =$P(^(2)," ^",8)
  12771   "RTN","CHG CU136",34, 0)
  12772    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  12773   "RTN","CHG CU136",35, 0)
  12774    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",4 )'="" S CH VEN=$P(^(0 ),"^",4) Q
  12775   "RTN","CHG CU136",36, 0)
  12776    ;S CHPRT= $J("Vendor :",20),CHF LD=CHVEN D  SET
  12777   "RTN","CHG CU136",37, 0)
  12778    S CHPRT=$ J("Remit-t o Vendor:" ,20),CHFLD =$P(RECV," ^") D SET   ;CFS - De fect 82805 0
  12779   "RTN","CHG CU136",38, 0)
  12780    S CHTID=$ P(RECV,"^" ,3) I $D(@ (GLPAY_"CH CLM,""VEN" ",CHVPT)") ) D
  12781   "RTN","CHG CU136",39, 0)
  12782    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",5 )'="" S CH TID=$P(^(0 ),"^",5) Q
  12783   "RTN","CHG CU136",40, 0)
  12784    S CHPRT=$ J("Tax ID: ",20),CHFL D=CHTID D  SET
  12785   "RTN","CHG CU136",41, 0)
  12786    I '$D(^CH MVEN(CHVPT ,2)) D:$D( ^CHMVEN(CH VPT,1))
  12787   "RTN","CHG CU136",42, 0)
  12788    .F CC=1:1 :6 S $P(^C HMVEN(CHVP T,2),"^",C C)=$P(^CHM VEN(CHVPT, 1),"^",CC)
  12789   "RTN","CHG CU136",43, 0)
  12790    .S $P(^CH MVEN(CHVPT ,2),"^",10 )=$P(^CHMV EN(CHVPT,1 ),"^",17)
  12791   "RTN","CHG CU136",44, 0)
  12792    .S $P(^CH MVEN(CHVPT ,2),"^",11 )=$P(^CHMV EN(CHVPT,1 ),"^",18)
  12793   "RTN","CHG CU136",45, 0)
  12794    S CHADD1= $P(REC1,"^ ",1)
  12795   "RTN","CHG CU136",46, 0)
  12796    N CHADD1C  S CHADD1C =""
  12797   "RTN","CHG CU136",47, 0)
  12798    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  12799   "RTN","CHG CU136",48, 0)
  12800    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",7 )'="" S CH ADD1C=$P(^ (0),"^",7)  Q
  12801   "RTN","CHG CU136",49, 0)
  12802    ;S CHPRT= $J("Addres s Line 1:" ,20),CHFLD =CHADD1 D  SET
  12803   "RTN","CHG CU136",50, 0)
  12804    S CHPRT=$ J("RT Addr ess Line 1 :",20),CHF LD=$S(CHAD D1C'="":CH ADD1C,1:$P (RECRT,"^" )) D SET   ;CFS - Def ect 828050
  12805   "RTN","CHG CU136",51, 0)
  12806    S CHADD2= $P(REC1,"^ ",2)
  12807   "RTN","CHG CU136",52, 0)
  12808    N CHADD2C  S CHADD2C =""
  12809   "RTN","CHG CU136",53, 0)
  12810    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  12811   "RTN","CHG CU136",54, 0)
  12812    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",8 )'="" S CH ADD2C=$P(^ (0),"^",8)  Q
  12813   "RTN","CHG CU136",55, 0)
  12814    ;S CHPRT= $J("Addres s Line 2:" ,20),CHFLD =CHADD2 D  SET
  12815   "RTN","CHG CU136",56, 0)
  12816    S CHPRT=$ J("RT Addr ess Line 2 :",20),CHF LD=$S(CHAD D2C'="":CH ADD2C,1:$P (RECRT,"^" ,2)) D SET   ;CFS - D efect 8280 50
  12817   "RTN","CHG CU136",57, 0)
  12818    S CHCITY= $P(REC1,"^ ",3)
  12819   "RTN","CHG CU136",58, 0)
  12820    N CHCITYC  S CHCITYC =""
  12821   "RTN","CHG CU136",59, 0)
  12822    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  12823   "RTN","CHG CU136",60, 0)
  12824    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",9 )'="" S CH CITYC=$P(^ (0),"^",9)  Q
  12825   "RTN","CHG CU136",61, 0)
  12826    ;---CFS B egin Defec t 828050
  12827   "RTN","CHG CU136",62, 0)
  12828    ;S CHPRT= $J("City:" ,20),CHFLD =CHCITY D  SET
  12829   "RTN","CHG CU136",63, 0)
  12830    S CHPRT=$ J("RT City :",20),CHF LD=$S(CHCI TYC'="":CH CITYC,1:$P (RECRT,"^" ,3)) D SET   ;CFS - D efect 8280 50
  12831   "RTN","CHG CU136",64, 0)
  12832    S PLST=$P (REC1,"^", 4)
  12833   "RTN","CHG CU136",65, 0)
  12834    N RTST S  RTST=$P(RE CRT,"^",4)
  12835   "RTN","CHG CU136",66, 0)
  12836    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  12837   "RTN","CHG CU136",67, 0)
  12838    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 0)'="" S R TST=$P(^(0 ),"^",10)  Q
  12839   "RTN","CHG CU136",68, 0)
  12840    S CHSTATE ="" I PLST '="" S:$D( ^DIC(5,PLS T,0)) CHST ATE=$P(^(0 ),"^",1)
  12841   "RTN","CHG CU136",69, 0)
  12842    ;S CHPRT= $J("State: ",20),CHFL D=CHSTATE  D SET
  12843   "RTN","CHG CU136",70, 0)
  12844    N RTSTATE
  12845   "RTN","CHG CU136",71, 0)
  12846    S RTSTATE ="" I RTST '="" S:$D( ^DIC(5,RTS T,0)) RTST ATE=$P(^DI C(5,RTST,0 ),"^",1)
  12847   "RTN","CHG CU136",72, 0)
  12848    S CHPRT=$ J("RT Stat e:",20),CH FLD=$S(RTS TATE'="":R TSTATE,1:$ P(RECRT,"^ ",4)) D SE T
  12849   "RTN","CHG CU136",73, 0)
  12850    S CHZIP=$ P(REC1,"^" ,5)
  12851   "RTN","CHG CU136",74, 0)
  12852    N CHZIPC  S CHZIPC=" "
  12853   "RTN","CHG CU136",75, 0)
  12854    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  12855   "RTN","CHG CU136",76, 0)
  12856    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 1)'="" S C HZIPC=$P(^ (0),"^",11 ) Q
  12857   "RTN","CHG CU136",77, 0)
  12858    ;S CHPRT= $J("Zip:", 20),CHFLD= CHZIP D SE T
  12859   "RTN","CHG CU136",78, 0)
  12860    S CHPRT=$ J("RT Zip: ",20),CHFL D=$S(CHZIP C'="":CHZI PC,1:$P(RE CRT,"^",5) ) D SET  ; CFS - Defe ct 828050
  12861   "RTN","CHG CU136",79, 0)
  12862    ;---CFS E nd Defect  828050
  12863   "RTN","CHG CU136",80, 0)
  12864    S CHCMAC= "" D:$D(^C HMVEN(CHVP T,41))
  12865   "RTN","CHG CU136",81, 0)
  12866    .S CJ=$O( ^CHMVEN(CH VPT,41,999 9999),-1)  Q:'CJ
  12867   "RTN","CHG CU136",82, 0)
  12868    .S CHCMAC =$P(^(CJ,0 ),"^",3)
  12869   "RTN","CHG CU136",83, 0)
  12870    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  12871   "RTN","CHG CU136",84, 0)
  12872    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 2)'="" S C HCMAC=$P(^ (0),"^",12 ) Q
  12873   "RTN","CHG CU136",85, 0)
  12874    S CHPRT=$ J("CMAC Co de:",20),C HFLD=CHCMA C D SET
  12875   "RTN","CHG CU136",86, 0)
  12876    S CHVNPG= "" S:$D(@( GLPAY_"CHC LM,9)")) C HVNPG=$P(^ (9),"^",6)
  12877   "RTN","CHG CU136",87, 0)
  12878    S CHPRT=$ J("Vendor  Page:",20) ,CHFLD=CHV NPG D SET
  12879   "RTN","CHG CU136",88, 0)
  12880    S CHASN=$ P(REC0,"^" ,5),CHASN= $S(CHASN=0 :"No",CHAS N=1:"Yes", 1:"No")
  12881   "RTN","CHG CU136",89, 0)
  12882    S CHPRT=$ J("Assignm ent:",20), CHFLD=CHAS N D SET
  12883   "RTN","CHG CU136",90, 0)
  12884    S CHPCN=$ P(REC7,"^" ,5)
  12885   "RTN","CHG CU136",91, 0)
  12886    S CHPRT=$ J("PCN:",2 0),CHFLD=C HPCN D SET
  12887   "RTN","CHG CU136",92, 0)
  12888    S CHTOB=$ P(REC7,"^" ,6)
  12889   "RTN","CHG CU136",93, 0)
  12890    S CHPRT=$ J("TOB:",2 0),CHFLD=C HTOB D SET
  12891   "RTN","CHG CU136",94, 0)
  12892    ;S CHDAMT =$P(REC0," ^",16)
  12893   "RTN","CHG CU136",95, 0)
  12894    ;S CHPRT= $J("Discou nt Amt:",2 0)
  12895   "RTN","CHG CU136",96, 0)
  12896    ;S:CHDAMT '="" CHDAM T="$"_$J($ FN(CHDAMT, "",2),9)
  12897   "RTN","CHG CU136",97, 0)
  12898    ;S CHFLD= CHDAMT D S ET
  12899   "RTN","CHG CU136",98, 0)
  12900    ;S CHFAC= "",RECF=""  S:$D(^CHM VEN(CHVPT, 1)) RECF=^ (1)
  12901   "RTN","CHG CU136",99, 0)
  12902    ;S CHFAC= $P(RECF,"^ ",7)
  12903   "RTN","CHG CU136",100 ,0)
  12904    ;I CHFAC' ="" S:$D(^ CHMDIC(741 002.11,CHF AC,0)) CHF AC=$P(^(0) ,"^",2)
  12905   "RTN","CHG CU136",101 ,0)
  12906    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  12907   "RTN","CHG CU136",102 ,0)
  12908    ;;.S DT=9 999999 F   S DT=$O(@( GLPAY_"CHC LM,""VEN"" ,CHVPT,DT) "),-1) Q:' DT  I $P(^ (DT,0),"^" ,14)'="" S  CHFAC=$P( ^(0),"^",1 4) Q
  12909   "RTN","CHG CU136",103 ,0)
  12910    ;S CHPRT= $J("Facili ty Type:", 20),CHFLD= CHFAC D SE T
  12911   "RTN","CHG CU136",104 ,0)
  12912    ;S CHSP=$ P(RECF,"^" ,11)
  12913   "RTN","CHG CU136",105 ,0)
  12914    ;I CHSP'= "" S:$D(^C HMDIC(7410 02.26,CHSP ,0)) CHSP= $P(^(0),"^ ",1)
  12915   "RTN","CHG CU136",106 ,0)
  12916    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  12917   "RTN","CHG CU136",107 ,0)
  12918    ;;.S DT=9 999999 F   S DT=$O(@( GLPAY_"CHC LM,""VEN"" ,CHVPT,DT) "),-1) Q:' DT  I $P(^ (DT,0),"^" ,15)'="" S  CHSP=$P(^ (0),"^",15 ) Q
  12919   "RTN","CHG CU136",108 ,0)
  12920    ;S CHPRT= $J("Specia lty Type:" ,20),CHFLD =CHSP D SE T
  12921   "RTN","CHG CU136",109 ,0)
  12922    S CHPHON= $P(RECV,"^ ",6) I $D( @(GLPAY_"C HCLM,""VEN "",CHVPT)" )) D
  12923   "RTN","CHG CU136",110 ,0)
  12924    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 3)'="" S C HPHON=$P(^ (0),"^",13 ) Q
  12925   "RTN","CHG CU136",111 ,0)
  12926    S CHPRT=$ J("Phone N umber:",20 ),CHFLD=CH PHON D SET                                       ;;BUG 7991-08-01  DRW - Cha nge Phone  # to Phone  Number: c osmetic ch ange - 01/ 28/11.
  12927   "RTN","CHG CU136",112 ,0)
  12928    ;--Begin  Defect 686 377
  12929   "RTN","CHG CU136",113 ,0)
  12930    S CHPLZIP =""
  12931   "RTN","CHG CU136",114 ,0)
  12932    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D   ;Add PL  ZIP CPE001 -005
  12933   "RTN","CHG CU136",115 ,0)
  12934    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 6)'="" S C HPLZIP=$P( ^(0),"^",1 6) Q
  12935   "RTN","CHG CU136",116 ,0)
  12936    I CHPLZIP ="" D  ;Ge t PL Zip
  12937   "RTN","CHG CU136",117 ,0)
  12938    .I $D(^CH MPAY(CHCLM ,"VEN-II") ) S CHPLZI P=$P(^CHMP AY(CHCLM," VEN-II")," ^",15)
  12939   "RTN","CHG CU136",118 ,0)
  12940    S $P(^CHM PAY(CHCLM, "VEN-II"), U,15)=CHPL ZIP
  12941   "RTN","CHG CU136",119 ,0)
  12942    ;DEFECT 8 32270 - TG H- 11/29/1 8 - Preven t PL Zip d isplaying  if Claim T ype is DME , Pharmacy , or Trave l
  12943   "RTN","CHG CU136",120 ,0)
  12944    ;S CHPRT= $J("PL ZIP :",20),CHF LD=CHPLZIP  D SET
  12945   "RTN","CHG CU136",121 ,0)
  12946    I CHTYP'= "DURABLE M EDICAL"&(C HTYP'="PHA RMACY")&(C HTYP'="TRA VEL") S CH PRT=$J("PL  ZIP:",20) ,CHFLD=CHP LZIP D SET
  12947   "RTN","CHG CU136",122 ,0)
  12948    ;--End De fect 68637 7
  12949   "RTN","CHG CU136",123 ,0)
  12950   END K PDIJ ,ZK,CHPRT, CHFLD,CHAS N,CHDPER,C HDDAY,CHDA MT,CHCMAC, CHVNPG
  12951   "RTN","CHG CU136",124 ,0)
  12952    K CHCITY, CHADD1,CHA DD2,CHTID, CHVEN,ST,C HSTATE Q
  12953   "RTN","CHG CU136",125 ,0)
  12954    ;
  12955   "RTN","CHG CU136",126 ,0)
  12956   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  12957   "RTN","CHG CU136",127 ,0)
  12958    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  12959   "RTN","CHG CU136",128 ,0)
  12960    Q
  12961   "RTN","CHG CU136",129 ,0)
  12962   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  12963   "RTN","CHG CU136",130 ,0)
  12964    ;
  12965   "RTN","CHG CU136",131 ,0)
  12966   SET S CHCT =CHCT+1
  12967   "RTN","CHG CU136",132 ,0)
  12968    ;S X="X X Y W @CHBON ,P1,@CHBOF F S DX=3 X  XY W P2 S  DX=25 X X Y W P3"
  12969   "RTN","CHG CU136",133 ,0)
  12970    S X="X XY  W @CHBON, P1,@CHBOFF  S DX=4 X  XY W P2 S  DX=26 X XY  W P3"   ;  JEH
  12971   "RTN","CHG CU136",134 ,0)
  12972    D UPCT S  ^UTILITY($ J,"CEU",CH ZONE,CT)=X _U_CHCT_U_ CHPRT_U_CH FLD
  12973   "RTN","CHG CU136",135 ,0)
  12974    ;I CT=14  S ABC=ABD
  12975   "RTN","CHG CU136",136 ,0)
  12976    Q
  12977   "RTN","CHG CU136",137 ,0)
  12978    ;
  12979   "RTN","CHG CU136",138 ,0)
  12980   UPCT  ;
  12981   "RTN","CHG CU136",139 ,0)
  12982    ;I CT=14  S ABC=ABD
  12983   "RTN","CHG CU136",140 ,0)
  12984    S (CT,^UT ILITY($J," CEU",CHZON E,0))=CT+1  Q
  12985   "RTN","CHG CU165")
  12986   0^23^B2148 9649
  12987   "RTN","CHG CU165",1,0 )
  12988   CHGCU165 ; CVA/CR;FOR MAT CEU VE NDOR SCREE N FOR CVA  FOREIGN;Fe b 06, 2019 @08:44:45
  12989   "RTN","CHG CU165",2,0 )
  12990    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  12991   "RTN","CHG CU165",3,0 )
  12992    ;;CPTS #1 2599 BY DT P (12-SEP- 97)
  12993   "RTN","CHG CU165",4,0 )
  12994    ;CFS 07/2 0/2017 - P L ZIP adde d for User  Story CPE 001-005
  12995   "RTN","CHG CU165",5,0 )
  12996   EN1 N (CHN OSEND,CHVP T,DFN,BFN, CHZONE,CHC LM,CHTYP,E DIT,GLPAY, GLELG,GLDF N,GLPAYH,G LPAYW)
  12997   "RTN","CHG CU165",6,0 )
  12998    S CHTOT=0 ,CHCT=0 K  EDIT
  12999   "RTN","CHG CU165",7,0 )
  13000    S:'$D(^UT ILITY($J," CEU",CHZON E,0)) ^UTI LITY($J,"C EU",CHZONE ,0)=0
  13001   "RTN","CHG CU165",8,0 )
  13002    S CT=^UTI LITY($J,"C EU",CHZONE ,0),U="^"
  13003   "RTN","CHG CU165",9,0 )
  13004    Q:'$D(@(G LPAY_"CHCL M,0)"))  S  REC0=@(GL PAY_"CHCLM ,0)")
  13005   "RTN","CHG CU165",10, 0)
  13006    S CHVPT=$ P(REC0,"^" ,3) S:CHVP T="" CHVPT ="PS"
  13007   "RTN","CHG CU165",11, 0)
  13008    S PDIJ=99 99,PDIJ=$O (@(GLPAY_" CHCLM,""PD I"",PDIJ)" ),-1)
  13009   "RTN","CHG CU165",12, 0)
  13010    I PDIJ'=" " S:$D(@(G LPAY_"CHCL M,""PDI"", PDIJ,0)"))  CHPDI=$P( ^(0),"^",1 )
  13011   "RTN","CHG CU165",13, 0)
  13012    I $D(^CHM IMAGE(CHPD I,"P-VEN") ) D:'$D(@( GLPAY_"CHC LM,""VEN"" )"))
  13013   "RTN","CHG CU165",14, 0)
  13014    .S STR=$P (@(GLPAY_" CHCLM,0)") ,"^",4) Q: STR=""
  13015   "RTN","CHG CU165",15, 0)
  13016    .S CHPAGE =$P(STR,"* ",2),CHIMA G=$P(STR," *",3)
  13017   "RTN","CHG CU165",16, 0)
  13018    .Q:'$D(^C HMIMAGE(CH PDI,1,CHPA GE,2,CHIMA G,"VEN"))
  13019   "RTN","CHG CU165",17, 0)
  13020    .S PTR=$P (^("VEN"), "^",14)
  13021   "RTN","CHG CU165",18, 0)
  13022    .Q:PTR=""   Q:'$D(^C HMAGE(CHPD I,"P-VEN", PTR,0))
  13023   "RTN","CHG CU165",19, 0)
  13024    .D NOW^%D TC
  13025   "RTN","CHG CU165",20, 0)
  13026    .S @(GLPA Y_"CHCLM," "VEN"",CHV PT,%,0)")= ^CHMIMAGE( CHPDI,"P-V EN",PTR,0)
  13027   "RTN","CHG CU165",21, 0)
  13028    S RECV=""  S:$D(^CHM VEN(CHVPT, 0)) RECV=^ (0)
  13029   "RTN","CHG CU165",22, 0)
  13030    S CHVEN=" " S:$D(^CH MVEN(CHVPT ,2)) CHVEN =$P(^(2)," ^",8)
  13031   "RTN","CHG CU165",23, 0)
  13032    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13033   "RTN","CHG CU165",24, 0)
  13034    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",4 )'="" S CH VEN=$P(^(0 ),"^",4) Q
  13035   "RTN","CHG CU165",25, 0)
  13036    S CHPRT=$ J("Vendor: ",20),CHFL D=CHVEN D  SET
  13037   "RTN","CHG CU165",26, 0)
  13038    S CHTID=$ P(RECV,"^" ,3) I $D(@ (GLPAY_"CH CLM,""VEN" ",CHVPT)") ) D
  13039   "RTN","CHG CU165",27, 0)
  13040    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",5 )'="" S CH TID=$P(^(0 ),"^",5) Q
  13041   "RTN","CHG CU165",28, 0)
  13042    S CHPRT=$ J("Tax ID: ",20),CHFL D=CHTID D  SET
  13043   "RTN","CHG CU165",29, 0)
  13044    S REC1=""  S:$D(^CHM VEN(CHVPT, 2)) REC1=^ (2)
  13045   "RTN","CHG CU165",30, 0)
  13046    S CHADD1= $P(REC1,"^ ",1)
  13047   "RTN","CHG CU165",31, 0)
  13048    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13049   "RTN","CHG CU165",32, 0)
  13050    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",7 )'="" S CH ADD1=$P(^( 0),"^",7)  Q
  13051   "RTN","CHG CU165",33, 0)
  13052    S CHPRT=$ J("Address  Line 1:", 20),CHFLD= CHADD1 D S ET
  13053   "RTN","CHG CU165",34, 0)
  13054    S CHADD2= $P(REC1,"^ ",2)
  13055   "RTN","CHG CU165",35, 0)
  13056    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13057   "RTN","CHG CU165",36, 0)
  13058    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",8 )'="" S CH ADD2=$P(^( 0),"^",8)  Q
  13059   "RTN","CHG CU165",37, 0)
  13060    S CHPRT=$ J("Address  Line 2:", 20),CHFLD= CHADD2 D S ET
  13061   "RTN","CHG CU165",38, 0)
  13062    S CHADD3= "" S:$D(^C HMVEN(CHVP T,5)) CHAD D3=$P(^(5) ,"^",5)
  13063   "RTN","CHG CU165",39, 0)
  13064    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13065   "RTN","CHG CU165",40, 0)
  13066    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 6)'="" S C HADD3=$P(^ (0),"^",16 ) Q
  13067   "RTN","CHG CU165",41, 0)
  13068    S CHPRT=$ J("Address  Line 3:", 20),CHFLD= CHADD3 D S ET
  13069   "RTN","CHG CU165",42, 0)
  13070    S CHCC=""  I $D(^CHM VEN(CHVPT, 2)) D:$P(^ CHMVEN(CHV PT,2),"^", 10)'=""
  13071   "RTN","CHG CU165",43, 0)
  13072    .Q:'$D(^D IC(5,$P(^C HMVEN(CHVP T,2),"^",1 0),0))
  13073   "RTN","CHG CU165",44, 0)
  13074    .S CHCC=$ P(^(0),"^" ,1)
  13075   "RTN","CHG CU165",45, 0)
  13076    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13077   "RTN","CHG CU165",46, 0)
  13078    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 7)'="" S C HCC=$P(^(0 ),"^",17)  S:$D(^DIC( 5,CHCC,0))  CHCC=$P(^ (0),"^",1)  Q
  13079   "RTN","CHG CU165",47, 0)
  13080    S CHPRT=$ J("Country :",20),CHF LD=CHCC D  SET
  13081   "RTN","CHG CU165",48, 0)
  13082    ;S CHCITY =$P(REC1," ^",3)
  13083   "RTN","CHG CU165",49, 0)
  13084    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  13085   "RTN","CHG CU165",50, 0)
  13086    ;.S DT=99 99999 F  S  DT=$O(@(G LPAY_"CHCL M,""VEN"", CHVPT,DT)" ),-1) Q:'D T  I $P(^( DT,0),"^", 9)'="" S C HCITY=$P(^ (0),"^",9)  Q
  13087   "RTN","CHG CU165",51, 0)
  13088    ;S CHPRT= $J("City:" ,20),CHFLD =CHCITY D  SET
  13089   "RTN","CHG CU165",52, 0)
  13090    ;S ST=$P( REC1,"^",4 )
  13091   "RTN","CHG CU165",53, 0)
  13092    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  13093   "RTN","CHG CU165",54, 0)
  13094    ;.S DT=99 99999 F  S  DT=$O(@(G LPAY_"CHCL M,""VEN"", CHVPT,DT)" ),-1) Q:'D T  I $P(^( DT,0),"^", 10)'="" S  ST=$P(^(0) ,"^",10) Q
  13095   "RTN","CHG CU165",55, 0)
  13096    ;S CHSTAT E="" I ST' ="" S:$D(^ DIC(5,ST,0 )) CHSTATE =$P(^(0)," ^",1)
  13097   "RTN","CHG CU165",56, 0)
  13098    ;S CHPRT= $J("State: ",20),CHFL D=CHSTATE  D SET
  13099   "RTN","CHG CU165",57, 0)
  13100    ;S CHZIP= $P(REC1,"^ ",5)
  13101   "RTN","CHG CU165",58, 0)
  13102    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  13103   "RTN","CHG CU165",59, 0)
  13104    ;.S DT=99 99999 F  S  DT=$O(@(G LPAY_"CHCL M,""VEN"", CHVPT,DT)" ),-1) Q:'D T  I $P(^( DT,0),"^", 11)'="" S  CHZIP=$P(^ (0),"^",11 ) Q
  13105   "RTN","CHG CU165",60, 0)
  13106    ;S CHPRT= $J("Zip:", 20),CHFLD= CHZIP D SE T
  13107   "RTN","CHG CU165",61, 0)
  13108    S CHCMAC= "" D:$D(^C HMVEN(CHVP T,41))
  13109   "RTN","CHG CU165",62, 0)
  13110    .S CJ=$O( ^CHMVEN(CH VPT,41,999 9999),-1)  Q:'CJ
  13111   "RTN","CHG CU165",63, 0)
  13112    .S CHCMAC =$P(^(CJ,0 ),"^",3)
  13113   "RTN","CHG CU165",64, 0)
  13114    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13115   "RTN","CHG CU165",65, 0)
  13116    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 2)'="" S C HCMAC=$P(^ (0),"^",12 ) Q
  13117   "RTN","CHG CU165",66, 0)
  13118    S CHPRT=$ J("CMAC Co de:",20),C HFLD=CHCMA C D SET
  13119   "RTN","CHG CU165",67, 0)
  13120    S CHVNPG= "" S:$D(@( GLPAY_"CHC LM,9)")) C HVNPG=$P(^ (9),"^",6)
  13121   "RTN","CHG CU165",68, 0)
  13122    S CHPRT=$ J("Vendor  Page:",20) ,CHFLD=CHV NPG D SET
  13123   "RTN","CHG CU165",69, 0)
  13124    S CHASN=$ P(REC0,"^" ,5),CHASN= $S(CHASN=0 :"No",CHAS N=1:"Yes", 1:"No")
  13125   "RTN","CHG CU165",70, 0)
  13126    S CHPRT=$ J("Assignm ent:",20), CHFLD=CHAS N D SET
  13127   "RTN","CHG CU165",71, 0)
  13128    ;S CHDPER =$P(REC0," ^",14)
  13129   "RTN","CHG CU165",72, 0)
  13130    ;S CHPRT= $J("Discou nt Percent :",20),CHF LD=CHDPER  S:CHFLD'=" " CHFLD=CH FLD_" %" D  SET
  13131   "RTN","CHG CU165",73, 0)
  13132    ;S CHDDAY =$P(REC0," ^",15)
  13133   "RTN","CHG CU165",74, 0)
  13134    ;S CHPRT= $J("Discou nt Days:", 20),CHFLD= CHDDAY D S ET
  13135   "RTN","CHG CU165",75, 0)
  13136    ;S CHDAMT =$P(REC0," ^",16)
  13137   "RTN","CHG CU165",76, 0)
  13138    ;S CHPRT= $J("Discou nt Amt:",2 0)
  13139   "RTN","CHG CU165",77, 0)
  13140    ;S:CHDAMT '="" CHDAM T="$"_$J($ FN(CHDAMT, "",2),9)
  13141   "RTN","CHG CU165",78, 0)
  13142    ;S CHFLD= CHDAMT D S ET
  13143   "RTN","CHG CU165",79, 0)
  13144    ;S CHFAC= "",RECF=""  S:$D(^CHM VEN(CHVPT, 1)) RECF=^ (1)
  13145   "RTN","CHG CU165",80, 0)
  13146    ;S CHFAC= $P(RECF,"^ ",7)
  13147   "RTN","CHG CU165",81, 0)
  13148    ;I CHFAC' ="" S:$D(^ CHMDIC(741 002.11,CHF AC,0)) CHF AC=$P(^(0) ,"^",2)
  13149   "RTN","CHG CU165",82, 0)
  13150    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  13151   "RTN","CHG CU165",83, 0)
  13152    ;.S DT=99 99999 F  S  DT=$O(@(G LPAY_"CHCL M,""VEN"", CHVPT,DT)" ),-1) Q:'D T  I $P(^( DT,0),"^", 14)'="" S  CHFAC=$P(^ (0),"^",14 ) Q
  13153   "RTN","CHG CU165",84, 0)
  13154    ;S CHPRT= $J("Facili ty Type:", 20),CHFLD= CHFAC D SE T
  13155   "RTN","CHG CU165",85, 0)
  13156    ;S CHSP=$ P(RECF,"^" ,11)
  13157   "RTN","CHG CU165",86, 0)
  13158    ;I CHSP'= "" S:$D(^C HMDIC(7410 02.26,CHSP ,0)) CHSP= $P(^(0),"^ ",1)
  13159   "RTN","CHG CU165",87, 0)
  13160    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  13161   "RTN","CHG CU165",88, 0)
  13162    ;.S DT=99 99999 F  S  DT=$O(@(G LPAY_"CHCL M,""VEN"", CHVPT,DT)" ),-1) Q:'D T  I $P(^( DT,0),"^", 15)'="" S  CHSP=$P(^( 0),"^",15)  Q
  13163   "RTN","CHG CU165",89, 0)
  13164    ;S CHPRT= $J("Specia lty Type:" ,20),CHFLD =CHSP D SE T
  13165   "RTN","CHG CU165",90, 0)
  13166    S CHPHON= $P(REC1,"^ ",6)
  13167   "RTN","CHG CU165",91, 0)
  13168    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13169   "RTN","CHG CU165",92, 0)
  13170    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 3)'="" S C HPHON=$P(^ (0),"^",13 ) Q
  13171   "RTN","CHG CU165",93, 0)
  13172    S CHPRT=$ J("Phone N umber:",20 ),CHFLD=CH PHON D SET
  13173   "RTN","CHG CU165",94, 0)
  13174    S CHPLZIP =""
  13175   "RTN","CHG CU165",95, 0)
  13176    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D   ;CPE001- 005 added  PL ZIP
  13177   "RTN","CHG CU165",96, 0)
  13178    .S DT=999 9999 F  S  DT=$O(@(GL PAY_"CHCLM ,""VEN"",C HVPT,DT)") ,-1) Q:'DT   I $P(^(D T,0),"^",1 4)'="" S C HPLZIP=$P( ^(0),"^",1 4) Q
  13179   "RTN","CHG CU165",97, 0)
  13180    S $P(^CHM PAY(CHCLM, "VEN-II"), U,15)=CHPL ZIP
  13181   "RTN","CHG CU165",98, 0)
  13182    S CHPRT=$ J("PL ZIP: ",20),CHFL D=CHPLZIP  D SET
  13183   "RTN","CHG CU165",99, 0)
  13184   END K PDIJ ,ZK,CHPRT, CHFLD,CHAS N,CHDPER,C HDDAY,CHDA MT,CHCMAC, CHVNPG
  13185   "RTN","CHG CU165",100 ,0)
  13186    K CHCITY, CHADD1,CHA DD2,CHTID, CHVEN,ST,C HSTATE Q
  13187   "RTN","CHG CU165",101 ,0)
  13188    ;
  13189   "RTN","CHG CU165",102 ,0)
  13190   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  13191   "RTN","CHG CU165",103 ,0)
  13192    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  13193   "RTN","CHG CU165",104 ,0)
  13194    Q
  13195   "RTN","CHG CU165",105 ,0)
  13196   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  13197   "RTN","CHG CU165",106 ,0)
  13198    ;
  13199   "RTN","CHG CU165",107 ,0)
  13200   SET S CHCT =CHCT+1
  13201   "RTN","CHG CU165",108 ,0)
  13202    ;S X="X X Y W @CHBON ,P1,@CHBOF F S DX=3 X  XY W P2 S  DX=25 X X Y W P3"
  13203   "RTN","CHG CU165",109 ,0)
  13204    S X="X XY  W @CHBON, P1,@CHBOFF  S DX=4 X  XY W P2 S  DX=26 X XY  W P3"   ;  JEH
  13205   "RTN","CHG CU165",110 ,0)
  13206    D UPCT S  ^UTILITY($ J,"CEU",CH ZONE,CT)=X _U_CHCT_U_ CHPRT_U_CH FLD
  13207   "RTN","CHG CU165",111 ,0)
  13208    Q
  13209   "RTN","CHG CU165",112 ,0)
  13210    ;
  13211   "RTN","CHG CU165",113 ,0)
  13212   UPCT S (CT ,^UTILITY( $J,"CEU",C HZONE,0))= CT+1 Q
  13213   "RTN","CHG DQ2")
  13214   0^25^B1560 01132
  13215   "RTN","CHG DQ2",1,0)
  13216   CHGDQ2 ;HB G/DEN;FORM AT DUP CLA IM OUTPUT  FOR DISPLA Y IN QUE;F eb 06, 201 9@09:02:12
  13217   "RTN","CHG DQ2",2,0)
  13218    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  13219   "RTN","CHG DQ2",3,0)
  13220    ;V2.0
  13221   "RTN","CHG DQ2",4,0)
  13222    ; PT 1611 0 (Y2K)
  13223   "RTN","CHG DQ2",5,0)
  13224    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  13225   "RTN","CHG DQ2",6,0)
  13226    ;             CHZONE  - SCREEN  REGION
  13227   "RTN","CHG DQ2",7,0)
  13228    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 *-RLC, #12 202* (RLC)
  13229   "RTN","CHG DQ2",8,0)
  13230    ;CPTS #12 881* BY DT P, #13310*  (RLC)
  13231   "RTN","CHG DQ2",9,0)
  13232    ;CPTS #16 432 (RLC)  - MODIFICA TIONS MADE  FOR IPS S CREEN SCRA PING
  13233   "RTN","CHG DQ2",10,0)
  13234    ;DEV00782 0 5/15/201 1 DGC
  13235   "RTN","CHG DQ2",11,0)
  13236    ;MTN01316 3 11/1/201 1 DGC
  13237   "RTN","CHG DQ2",12,0)
  13238    ;CPE001-0 07 ;05/11/ 2017; AJF
  13239   "RTN","CHG DQ2",13,0)
  13240    ;Defect 8 32284 11/2 8/2018 DYO  Not displ ay PL ZIP  filed for  DME TRV an d RX claim s
  13241   "RTN","CHG DQ2",14,0)
  13242    ;
  13243   "RTN","CHG DQ2",15,0)
  13244    K ^UTILIT Y($J) S CH ZONE=1 D E N1
  13245   "RTN","CHG DQ2",16,0)
  13246    G:'$D(CHC LM) AEND G :'$D(^CHMD PCL(741010 .13,"D",CH CLM)) AEND
  13247   "RTN","CHG DQ2",17,0)
  13248    S I=$O(^C HMDPCL(741 010.13,"D" ,CHCLM,0))
  13249   "RTN","CHG DQ2",18,0)
  13250    G:'$D(^CH MDPCL(7410 10.13,I,1) ) AEND S J =0
  13251   "RTN","CHG DQ2",19,0)
  13252   A S J=$O(^ CHMDPCL(74 1010.13,I, 1,J)) G:'J  AEND
  13253   "RTN","CHG DQ2",20,0)
  13254    G:'$D(^CH MDPCL(7410 10.13,I,1, J,0)) A S  CHCLM=$P(^ (0),"^",1)  D EN1
  13255   "RTN","CHG DQ2",21,0)
  13256   AEND Q
  13257   "RTN","CHG DQ2",22,0)
  13258   EN1 N (CHZ ONE,CHCLM, CHOHIP,GLP AY,GLELG,G LDFN,CHPRO G)
  13259   "RTN","CHG DQ2",23,0)
  13260    ;D CHECK^ CHGDQU2
  13261   "RTN","CHG DQ2",24,0)
  13262    K @(GLPAY _"CHCLM,"" RULE-DUP"" )")
  13263   "RTN","CHG DQ2",25,0)
  13264    S (VNPT,C HTDDT,CHBR DT,CHAGE,C HDB,CHDOB, CHSEX)=""
  13265   "RTN","CHG DQ2",26,0)
  13266    S:'$D(^UT ILITY($J," DUP",CHZON E,0)) ^UTI LITY($J,"D UP",CHZONE ,0)=0
  13267   "RTN","CHG DQ2",27,0)
  13268    S CT=^UTI LITY($J,"D UP",CHZONE ,0),U="^"
  13269   "RTN","CHG DQ2",28,0)
  13270    Q:'$D(@(G LPAY_"CHCL M,0)"))  S  REC0=@(GL PAY_"CHCLM ,0)")
  13271   "RTN","CHG DQ2",29,0)
  13272    S CHCLMO= $P(REC0,"^ ",1),VNPT= $P(REC0,"^ ",3)
  13273   "RTN","CHG DQ2",30,0)
  13274    S (CHBNPY ,CHTLPD,CH VAMT,CHBAM T,RC1)=""  ;DGC 5/15/ 2011 DEV00 7820
  13275   "RTN","CHG DQ2",31,0)
  13276    S:$D(@(GL PAY_"CHCLM ,""COMMON" ")")) CHBN PY=$P(@(GL PAY_"CHCLM ,""COMMON" ")"),U,3)
  13277   "RTN","CHG DQ2",32,0)
  13278    I $D(@(GL PAY_"CHCLM ,1)")) S R C1=@(GLPAY _"CHCLM,1) "),CHTLPD= $P(RC1,U,1 ),CHVAMT=$ P(RC1,U,14 ),CHBAMT=$ P(RC1,U,15 ) ;DGC 8/1 0/2011 DEV 007820
  13279   "RTN","CHG DQ2",33,0)
  13280    S CHVNPG= "" S:$D(@( GLPAY_"CHC LM,9)")) C HVNPG=$P(@ (GLPAY_"CH CLM,9)"),U ,6)
  13281   "RTN","CHG DQ2",34,0)
  13282    S CHCLM(C HZONE,CHCL M)="" S:'$ D(CHCLM(CH ZONE,"CT") ) CHCLM(CH ZONE,"CT") =""
  13283   "RTN","CHG DQ2",35,0)
  13284    S CHCLM(C HZONE,"CT" )=CHCLM(CH ZONE,"CT") +1
  13285   "RTN","CHG DQ2",36,0)
  13286    S (CHPCN, CHTOB,CHST PLB,CHSOHI PB)="" ;DG C 5/15/201 1 DEV00782 0
  13287   "RTN","CHG DQ2",37,0)
  13288    S:$D(@(GL PAY_"CHCLM ,7)")) CHP CN=$P(@(GL PAY_"CHCLM ,7)"),U,5) ,CHTOB=$P( @(GLPAY_"C HCLM,7)"), U,6),CHSTP LB=$P(@(GL PAY_"CHCLM ,7)"),U,9) ,CHSOHIPB= $P(@(GLPAY _"CHCLM,7) "),U,11) ; DGC 8/10/2 011 DEV007 820
  13289   "RTN","CHG DQ2",38,0)
  13290    S CHPDI=" "
  13291   "RTN","CHG DQ2",39,0)
  13292    S J=$O(@( GLPAY_"CHC LM,""PDI"" ,99999)"), -1)
  13293   "RTN","CHG DQ2",40,0)
  13294    I J'="" S :$D(@(GLPA Y_"CHCLM," "PDI"",J,0 )")) CHPDI =$P(@(GLPA Y_"CHCLM," "PDI"",J,0 )"),U,1)
  13295   "RTN","CHG DQ2",41,0)
  13296    S CHDOCID ="" I CHPD I'="" S:$D (^CHMIMG(C HPDI,"DOC" )) CHDOCID =$P(^("DOC "),"^",1)
  13297   "RTN","CHG DQ2",42,0)
  13298    S:CHDOCID '="" CHPDI =CHPDI_"-" _CHDOCID
  13299   "RTN","CHG DQ2",43,0)
  13300    S DFN=$P( REC0,"^",2 1),BFN=$P( REC0,"^",2 2),CHBENE= ""
  13301   "RTN","CHG DQ2",44,0)
  13302    ;THE NEXT  LINE CHEC KS FOR THE  EXISTENCE  OF BENE W ATCH INFO
  13303   "RTN","CHG DQ2",45,0)
  13304    D BWATCH^ CHGDQ3B
  13305   "RTN","CHG DQ2",46,0)
  13306    I DFN'="" !(BFN'="")  S:$D(@(GL ELG_"DFN,1 00,BFN,0)" )) CHBENE= $P(@(GLELG _"DFN,100, BFN,0)")," ^",1),CHSE X=$P(@(GLE LG_"DFN,10 0,BFN,0)") ,U,2),CHDB =$P(@(GLEL G_"DFN,100 ,BFN,0)"), U,3)
  13307   "RTN","CHG DQ2",47,0)
  13308    ; Y2K Cha nged DOB t o display  4 dig year
  13309   "RTN","CHG DQ2",48,0)
  13310    S:CHDB'=" " CHDOB=$$ FMTE^XLFDT (CHDB,5)
  13311   "RTN","CHG DQ2",49,0)
  13312    D NOW^%DT C S CHTDDT =$P(%H,"," ,1)
  13313   "RTN","CHG DQ2",50,0)
  13314    I CHDB=""  S CHAGE=" UNK" G EN2
  13315   "RTN","CHG DQ2",51,0)
  13316    S X=CHDB  D H^%DTC S  CHBRDT=%H
  13317   "RTN","CHG DQ2",52,0)
  13318    S CHAGE=( (CHTDDT-CH BRDT)/365. 25)\1
  13319   "RTN","CHG DQ2",53,0)
  13320   EN2 S X=$P (REC0,"^", 8) S CHDOS ="" I X'=" " D
  13321   "RTN","CHG DQ2",54,0)
  13322    .S CHDOS= $E(X,4,5)_ $E(X,6,7)_ $E(X,2,3)
  13323   "RTN","CHG DQ2",55,0)
  13324    K CMOP S: $D(@(GLPAY _"CHCLM,"" ZEMC"",""C MOP"")"))  CMOP="Yes"
  13325   "RTN","CHG DQ2",56,0)
  13326    S CHTOS=" " S X=$P(R EC0,"^",7)  I $D(^CHM DIC(741002 .05,X,0))  D
  13327   "RTN","CHG DQ2",57,0)
  13328    .S CHTOS= $P(^(0),"^ ",2)
  13329   "RTN","CHG DQ2",58,0)
  13330    I CHTOS=" IPT" S X=" " I $D(@(G LPAY_"CHCL M,""INP"") ")) D  S C HDOS=CHDOS _"-"_X
  13331   "RTN","CHG DQ2",59,0)
  13332    .S X=$P(@ (GLPAY_"CH CLM,""INP" ")"),"^",1 ),X=$E(X,4 ,5)_$E(X,6 ,7)_$E(X,2 ,3)
  13333   "RTN","CHG DQ2",60,0)
  13334    S CHASS=$ S($P(REC0, "^",5):"Y" ,1:"N")
  13335   "RTN","CHG DQ2",61,0)
  13336    S (CHVEN, CHVTID,CHV AC,CHVIM,C HVTIDP)="" ,X=$P(REC0 ,"^",3) I  X'="" D:$D (^CHMVEN(X ,0))
  13337   "RTN","CHG DQ2",62,0)
  13338    .S CHVEN= $P(^(0),"^ ",1),CHVTI D=$P(^(0), "^",3)
  13339   "RTN","CHG DQ2",63,0)
  13340    .;
  13341   "RTN","CHG DQ2",64,0)
  13342    .;8/16/96  - PEJ - m odified to  include V AC and IM  on the dis play.
  13343   "RTN","CHG DQ2",65,0)
  13344    .S CHVAC= $P(^(0),"^ ",23)
  13345   "RTN","CHG DQ2",66,0)
  13346    .S:$D(^CH MVEN(X,14) ) CHVIM=$P (^CHMVEN(X ,14),U,1)
  13347   "RTN","CHG DQ2",67,0)
  13348    .;
  13349   "RTN","CHG DQ2",68,0)
  13350    S:CHVAC=" " CHVAC="   "
  13351   "RTN","CHG DQ2",69,0)
  13352    S:CHVIM=" " CHVIM="   "
  13353   "RTN","CHG DQ2",70,0)
  13354    S CHVTIDP =CHVTID_"- "_CHVAC_"- "_CHVIM
  13355   "RTN","CHG DQ2",71,0)
  13356    S X=$P(RE C0,"^",2)  S CHSTAT=$ P($P($T(ST ATUS),";;" ,2),",",(X +1))
  13357   "RTN","CHG DQ2",72,0)
  13358    S PC1=""
  13359   "RTN","CHG DQ2",73,0)
  13360    S:$D(@(GL PAY_"CHCLM ,""COMMON" ")")) PC1= $P(@(GLPAY _"CHCLM,"" COMMON"")" ),"^",1)
  13361   "RTN","CHG DQ2",74,0)
  13362    S CHTCB=" " S:PC1'=" " CHTCB=$F N(PC1,"",2 )
  13363   "RTN","CHG DQ2",75,0)
  13364    S:CHTOS'= "IPT" X="X  XY W @CHB ON,""Cl: " ",@CHBOFF, P1 S DX=13  X XY W @C HBON,""Ben e: "",@CHB OFF,P2 S D X=46 X XY  W @CHBON," "DOS: "",@ CHBOFF,P3  S DX=59 X  XY W @CHBO N,""TOS: " ",@CHBOFF, P4 S DX=69  X XY W @C HBON,""Sta : "",@CHBO FF,P5"
  13365   "RTN","CHG DQ2",76,0)
  13366    S:CHTOS=" IPT" X="X  XY W @CHBO N,""Cl: "" ,@CHBOFF,P 1 S DX=13  X XY W @CH BON,""Bene : "",@CHBO FF,$E(P2,1 ,19) S DX= 40 X XY W  @CHBON,""D OS: "",@CH BOFF,P3 S  DX=59 X XY  W @CHBON, ""TOS: "", @CHBOFF,P4  S DX=69 X  XY W @CHB ON,""Sta:  "",P5"
  13367   "RTN","CHG DQ2",77,0)
  13368    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHCLMO_ U_$E(CHBEN E,1,25)_U_ CHDOS_U_CH TOS_U_CHST AT
  13369   "RTN","CHG DQ2",78,0)
  13370    S VFLG=""  I VNPT I  $D(^CHMVEN (VNPT,20))  S VFLG="* **VENDOR W ATCH DATA  EXISTS***"
  13371   "RTN","CHG DQ2",79,0)
  13372    S X="X XY  W @CHBON, ""Ven Pg:  "",@CHBOFF ,P1 S DX=1 4 X XY W @ CHBON,""Se x: "",@CHB OFF,P2 S D X=23 X XY  W @CHBON," "DOB: "",@ CHBOFF,P3  S DX=39 X  XY W @CHBO N,""Age: " ",@CHBOFF, P4 S DX=50  X XY W @C HBON,P5,@C HBOFF"
  13373   "RTN","CHG DQ2",80,0)
  13374    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHVNPG_ U_CHSEX_U_ CHDOB_U_CH AGE_U_VFLG
  13375   "RTN","CHG DQ2",81,0)
  13376    I $D(CMOP ) D
  13377   "RTN","CHG DQ2",82,0)
  13378    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13379   "RTN","CHG DQ2",83,0)
  13380    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "S DX=35 X  XY W @CHB ON,""CMOP  CLAIM"""
  13381   "RTN","CHG DQ2",84,0)
  13382    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13383   "RTN","CHG DQ2",85,0)
  13384    ;
  13385   "RTN","CHG DQ2",86,0)
  13386    ;Y2K move d "PI:"/CH ASS one li ne down to  make room  for large r PDI
  13387   "RTN","CHG DQ2",87,0)
  13388    S X="X XY  W @CHBON, ""PDI: "", @CHBOFF,P1  S DX=31 X  XY W @CHB ON,""Ven:" ",@CHBOFF, P2 S DX=58  X XY W @C HBON,""TIN : "",@CHBO FF,P3"
  13389   "RTN","CHG DQ2",88,0)
  13390    ;AJF Vend or DQ 007  - PL ZIP
  13391   "RTN","CHG DQ2",89,0)
  13392    S PLZIP=" "
  13393   "RTN","CHG DQ2",90,0)
  13394    S:$D(@(GL PAY_"CHCLM ,""VEN-II" ")")) PLZI P=$P(@(GLP AY_"CHCLM, ""VEN-II"" )"),U,15)
  13395   "RTN","CHG DQ2",91,0)
  13396    S X="X XY  W @CHBON, ""PDI: "", @CHBOFF,P1  S DX=31 X  XY W @CHB ON,""Ven:" ",@CHBOFF, P2 "
  13397   "RTN","CHG DQ2",92,0)
  13398    ;Defect 8 32284 Star t
  13399   "RTN","CHG DQ2",93,0)
  13400    ;Display  PL ZIP for  INP OUT a nd DNT cla ims only
  13401   "RTN","CHG DQ2",94,0)
  13402    I (CHTOS= "OPT")!(CH TOS="IPT") !(CHTOS="D NT") D
  13403   "RTN","CHG DQ2",95,0)
  13404    .S X=X_"S  DX=58 X X Y W @CHBON ,""TIN: "" ,@CHBOFF,P 3 S DX=85  X XY W @CH BON,""PL Z IP: "",@CH BOFF,P4"
  13405   "RTN","CHG DQ2",96,0)
  13406    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_CHPDI_ U_$E(CHVEN ,1,20)_U_C HVTIDP_U_P LZIP ;_U_C HASS
  13407   "RTN","CHG DQ2",97,0)
  13408    E  D
  13409   "RTN","CHG DQ2",98,0)
  13410    .S X=X_"S  DX=58 X X Y W @CHBON ,""TIN: "" ,@CHBOFF,P 3"
  13411   "RTN","CHG DQ2",99,0)
  13412    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_CHPDI_ U_$E(CHVEN ,1,20)_U_C HVTIDP ;_U _CHASS
  13413   "RTN","CHG DQ2",100,0 )
  13414    ;
  13415   "RTN","CHG DQ2",101,0 )
  13416    ;S DX=75  X XY W@CHB ON,""PI: " ",@CHBOFF, P4"
  13417   "RTN","CHG DQ2",102,0 )
  13418    ;
  13419   "RTN","CHG DQ2",103,0 )
  13420    ;D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_CHPDI_ U_$E(CHVEN ,1,20)_U_C HVTIDP_U_P LZIP ;_U_C HASS
  13421   "RTN","CHG DQ2",104,0 )
  13422    ;Defect 8 32284 End
  13423   "RTN","CHG DQ2",105,0 )
  13424    S X="X XY  W @CHBON, ""Program:  "",@CHBOF F,P1 S DX= 26 X XY W  @CHBON,""T ype Bill:  "",@CHBOFF ,P2 S DX=4 4 X XY W @ CHBON,""PC N: "",@CHB OFF,P3 S D X=75 X XY  W @CHBON," "PI: "",@C HBOFF,P4"
  13425   "RTN","CHG DQ2",106,0 )
  13426    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHPROG_ U_CHTOB_U_ CHPCN_U_CH ASS
  13427   "RTN","CHG DQ2",107,0 )
  13428    ;DGC 11/1 /2011 MTN0 13163 BEGI N
  13429   "RTN","CHG DQ2",108,0 )
  13430    S:CHSOHIP B'="" CHSO HIPB=$J($F N(CHSOHIPB ,",",2),10 )
  13431   "RTN","CHG DQ2",109,0 )
  13432    S:CHSTPLB '="" CHSTP LB=$J($FN( CHSTPLB,", ",2),10)
  13433   "RTN","CHG DQ2",110,0 )
  13434    S X="X XY  W @CHBON, ""OHI PR B AL: "",@CH BOFF,P1 S  DX=26 X XY  W @CHBON, ""TPL PD:  "",@CHBOFF ,P2"
  13435   "RTN","CHG DQ2",111,0 )
  13436    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHSOHIP B_U_CHSTPL B
  13437   "RTN","CHG DQ2",112,0 )
  13438    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=" W """""
  13439   "RTN","CHG DQ2",113,0 )
  13440    I CHTOS=" RXT" I CHP ROG'="SPIN A BIFIDA"  D  G EN3
  13441   "RTN","CHG DQ2",114,0 )
  13442    .;CJM LIN E LENGTH F OR MIGRATI ON R1 2017 0719
  13443   "RTN","CHG DQ2",115,0 )
  13444    .S X="X X Y W @CHBON ,@CHULON," "Rsl"" S D X=5 X XY W  ""Code""  S DX=23 X  XY W ""Des cription""  S DX=59 X  XY W $J(" "Unt/QTY"" ,7) S DX=6 7 X XY W $ J(""AlwUnt "",7)"
  13445   "RTN","CHG DQ2",116,0 )
  13446    .S X=X_"  S DX=75 X  XY W $J("" Total Chg" ",10) S DX =87 X XY W  $J(""Dedu ct  "",10)  S DX=99 X  XY W $J(" "OHI PR BA L"",10) S  DX=111 X X Y W $J(""O HI #1 Pd"" ,10) S DX= 123 X XY W  $J(""Mcai d"",7),@CH BOFF,@CHUL OFF"
  13447   "RTN","CHG DQ2",117,0 )
  13448    .I 'CHZON E D
  13449   "RTN","CHG DQ2",118,0 )
  13450    ..S X="X  XY W @CHBO N,@CHULON, ""Rej"" S  DX=5 X XY  W ""Code""  S DX=23 X  XY W ""De scription" " S DX=59  X XY W $J( ""Unt/QTY" ",7) S DX= 67 X XY W  $J(""AlwUn t"",7) S D X=75 X XY  W $J(""Tot al Chg"",1 0)"
  13451   "RTN","CHG DQ2",119,0 )
  13452    ..S X=X_"  S DX=87 X  XY W $J(" "Deduct  " ",10) S DX =99 X XY W  $J(""OHI  PR BAL"",1 0) S DX=11 1 X XY W $ J(""OHI #1  Pd"",10)  S DX=123 X  XY W $J(" "Mcaid"",7 ),@CHBOFF, @CHULOFF"
  13453   "RTN","CHG DQ2",120,0 )
  13454    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X
  13455   "RTN","CHG DQ2",121,0 )
  13456    .S X="S D X=99 X XY  W @CHBON,@ CHULON,$J( ""OHI #1 P R"",10) S  DX=113 X X Y W $J(""A ddl OHI"", 8),@CHBOFF ,@CHULOFF"
  13457   "RTN","CHG DQ2",122,0 )
  13458    I CHPROG= "SPINA BIF IDA" I CHT OS="RXT" D   G EN3
  13459   "RTN","CHG DQ2",123,0 )
  13460    .S X="X X Y W @CHBON ,@CHULON," "Rsl"" S D X=5 X XY W  ""Code""  S DX=20 X  XY W ""Des cription""  S DX=51 X  XY W ""DX  Code"" S  DX=59 X XY  W $J(""Un t/QTY"",7)  S DX=67 X  XY W $J(" "AlwUnt"", 7)"
  13461   "RTN","CHG DQ2",124,0 )
  13462    .S X=X_"  S DX=75 X  XY W $J("" Total Chg" ",10) S DX =87 X XY W  $J(""Dedu ct  "",10)  S DX=99 X  XY W $J(" "OHI PR BA L"",10) S  DX=111 X X Y W $J(""O HI #1 Pd"" ,10) S DX= 123 X XY W  $J(""Mcai d"",7),@CH BOFF,@CHUL OFF"
  13463   "RTN","CHG DQ2",125,0 )
  13464    .I 'CHZON E D
  13465   "RTN","CHG DQ2",126,0 )
  13466    ..S X="X  XY W @CHBO N,@CHULON, ""Rej"" S  DX=5 X XY  W ""Code""  S DX=20 X  XY W ""De scription" " S DX=51  X XY W ""D X Code"" S  DX=59 X X Y W $J(""U nt/QTY"",7 ) S DX=67  X XY W $J( ""AlwUnt"" ,7) S DX=7 5 X XY W $ J(""Total  Chg"",10)"
  13467   "RTN","CHG DQ2",127,0 )
  13468    ..S X=X_"  S DX=87 X  XY W $J(" "Deduct  " ",10) S DX =99 X XY W  $J(""OHI  PR BAL"",1 0) S DX=11 1 X XY W $ J(""OHI #1  Pd"",10)  S DX=123 X  XY W $J(" "Mcaid"",7 ),@CHBOFF, @CHULOFF"
  13469   "RTN","CHG DQ2",128,0 )
  13470    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X
  13471   "RTN","CHG DQ2",129,0 )
  13472    .S X="S D X=99 X XY  W @CHBON,@ CHULON,$J( ""OHI #1 P R"",10) S  DX=113 X X Y W $J(""A ddl OHI"", 8),@CHBOFF ,@CHULOFF"
  13473   "RTN","CHG DQ2",130,0 )
  13474    I CHTOS=" IPT" D  G  EN3
  13475   "RTN","CHG DQ2",131,0 )
  13476    .S X="X X Y W @CHBON ,@CHULON," "Rsl"" S D X=6 X XY W  ""Code""  S DX=20 X  XY W ""Des cription""  S DX=49 X  XY W ""Un t/QTY"" S  DX=58 X XY  W $J(""To tal Chg"", 9) S DX=69  X XY W $J (""OHI"",1 0),@CHBOFF ,@CHULOFF"                  ;DGC  8/22/2011  DEV007820
  13477   "RTN","CHG DQ2",132,0 )
  13478    .S:'CHZON E X="X XY  W @CHBON,@ CHULON,""R ej"" S DX= 6 X XY W " "Code"" S  DX=20 X XY  W ""Descr iption"" S  DX=49 X X Y W ""Unt/ QTY"" S DX =58 X XY W  $J(""Tota l Chg"",9)  S DX=69 X  XY W $J(" "OHI"",10) ,@CHBOFF,@ CHULOFF"   ;DGC 8/22/ 2011 DEV00 7820
  13479   "RTN","CHG DQ2",133,0 )
  13480    I CHZONE  D
  13481   "RTN","CHG DQ2",134,0 )
  13482    .S X="X X Y W @CHBON ,@CHULON," "Rsl"" S D X=5 X XY W  ""Code""  S DX=23 X  XY W ""Des cription""  S DX=59 X  XY W $J(" "Unt/QTY"" ,7) S DX=6 7 X XY W $ J(""AlwUnt "",7)"
  13483   "RTN","CHG DQ2",135,0 )
  13484    .S X=X_"  S DX=75 X  XY W $J("" Total Chg" ",10) S DX =87 X XY W  $J(""Dedu ct  "",10)  S DX=99 X  XY W $J(" "OHI PR BA L"",10) S  DX=111 X X Y W $J(""O HI #1 Pd"" ,10) S DX= 123 X XY W  $J(""Mcai d"",7),@CH BOFF,@CHUL OFF"
  13485   "RTN","CHG DQ2",136,0 )
  13486    I 'CHZONE  D
  13487   "RTN","CHG DQ2",137,0 )
  13488    .S X="X X Y W @CHBON ,@CHULON," "Rej"" S D X=5 X XY W  ""Code""  S DX=23 X  XY W ""Des cription""  S DX=59 X  XY W $J(" "Unt/QTY"" ,7) S DX=6 7 X XY W $ J(""AlwUnt "",7)"
  13489   "RTN","CHG DQ2",138,0 )
  13490    .S X=X_"  S DX=75 X  XY W $J("" Total Chg" ",10) S DX =87 X XY W  $J(""Dedu ct  "",10)  S DX=99 X  XY W $J(" "OHI PR BA L"",10) S  DX=111 X X Y W $J(""O HI #1 Pd"" ,10) S DX= 123 X XY W  $J(""Mcai d"",7),@CH BOFF,@CHUL OFF"
  13491   "RTN","CHG DQ2",139,0 )
  13492    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X
  13493   "RTN","CHG DQ2",140,0 )
  13494    S X="S DX =99 X XY W  @CHBON,@C HULON,$J(" "OHI #1 PR "",10) S D X=113 X XY  W $J(""Ad dl OHI"",8 ),@CHBOFF, @CHULOFF"
  13495   "RTN","CHG DQ2",141,0 )
  13496    ;DGC 11/1 /2011 MTN0 13163 END
  13497   "RTN","CHG DQ2",142,0 )
  13498   EN3 D UPCT  S ^UTILIT Y($J,"DUP" ,CHZONE,CT )=X
  13499   "RTN","CHG DQ2",143,0 )
  13500    S:CHTOS=" OPT" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  13501   "RTN","CHG DQ2",144,0 )
  13502    S:CHTOS=" DUR" CHTDX ="DME-DX", CHTPRC="DM E-SUPPLY"
  13503   "RTN","CHG DQ2",145,0 )
  13504    S:CHTOS=" DNT" CHTDX ="DEN-DX", CHTPRC="DE N-PROC"
  13505   "RTN","CHG DQ2",146,0 )
  13506    S:CHTOS=" TRV" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  13507   "RTN","CHG DQ2",147,0 )
  13508    S CHTOSP= $S(CHTOS=" IPT":CHTOS ,CHTOS="RX T":CHTOS,1 :"OPT")
  13509   "RTN","CHG DQ2",148,0 )
  13510    S (CHQTY, CHRXDX)=""
  13511   "RTN","CHG DQ2",149,0 )
  13512    D:CHTOSP' ="" @CHTOS P^CHGDQ3
  13513   "RTN","CHG DQ2",150,0 )
  13514    ;DGC 5/15 /2011 DEV0 07820 BEGI N
  13515   "RTN","CHG DQ2",151,0 )
  13516    I CHTOS=" IPT" D
  13517   "RTN","CHG DQ2",152,0 )
  13518    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "S DX=57 X  XY W ""== ========"" "
  13519   "RTN","CHG DQ2",153,0 )
  13520    .S X="S D X=57 X XY  W $J(P1,10 )"
  13521   "RTN","CHG DQ2",154,0 )
  13522    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_CHTCB
  13523   "RTN","CHG DQ2",155,0 )
  13524    I CHTOS'= "IPT" D
  13525   "RTN","CHG DQ2",156,0 )
  13526    .S OPRBT= ^TEMP($J," OPRBT",CHC LM)
  13527   "RTN","CHG DQ2",157,0 )
  13528    .S:OPRBT' ="" OPRBT= $J($FN(OPR BT,"",2),1 0)
  13529   "RTN","CHG DQ2",158,0 )
  13530    .S MEDPDT =^TEMP($J, "MEDPDT",C HCLM)
  13531   "RTN","CHG DQ2",159,0 )
  13532    .S:MEDPDT '="" MEDPD T=$J(MEDPD T,10,2)
  13533   "RTN","CHG DQ2",160,0 )
  13534    .S DEDUCT =^TEMP($J, "DEDUCT",C HCLM)
  13535   "RTN","CHG DQ2",161,0 )
  13536    .S:DEDUCT '="" DEDUC T=$J($FN(D EDUCT,"",2 ),10)
  13537   "RTN","CHG DQ2",162,0 )
  13538    .S OHIPRT =^TEMP($J, "OHIPRT",C HCLM)
  13539   "RTN","CHG DQ2",163,0 )
  13540    .S:OHIPRT '="" OHIPR T=$J($FN(O HIPRT,"",2 ),10)
  13541   "RTN","CHG DQ2",164,0 )
  13542    .S OHIPDT =^TEMP($J, "OHIPDT",C HCLM)
  13543   "RTN","CHG DQ2",165,0 )
  13544    .S:OHIPDT '="" OHIPD T=$J($FN(O HIPDT,"",2 ),10)
  13545   "RTN","CHG DQ2",166,0 )
  13546    .S OHIADT =^TEMP($J, "OHIADT",C HCLM)
  13547   "RTN","CHG DQ2",167,0 )
  13548    .S:OHIADT '="" OHIAD T=$J($FN(O HIADT,"",2 ),10)
  13549   "RTN","CHG DQ2",168,0 )
  13550    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "S DX=75 X  XY W ""== ========""  S DX=87 X  XY W ""== ========""  S DX=99 X  XY W ""== ========""  S DX=111  X XY W ""= =========" " S DX=122  X XY W "" ========== """
  13551   "RTN","CHG DQ2",169,0 )
  13552    .S X="S D X=75 X XY  W $J(P1,10 ) S DX=87  X XY W $J( P2,10) S D X=99 X XY  W P3 S DX= 111 X XY W  P4 S DX=1 22 X XY W  P5"
  13553   "RTN","CHG DQ2",170,0 )
  13554    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_CHTCB_ U_DEDUCT_U _OPRBT_U_O HIPDT_U_ME DPDT
  13555   "RTN","CHG DQ2",171,0 )
  13556    .;
  13557   "RTN","CHG DQ2",172,0 )
  13558    .S X="S D X=99 X XY  W P1 S DX= 111 X XY W  P2"
  13559   "RTN","CHG DQ2",173,0 )
  13560    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_OHIPRT _U_OHIADT
  13561   "RTN","CHG DQ2",174,0 )
  13562    ;DGC 5/15 /2011 DEV0 07820 END
  13563   "RTN","CHG DQ2",175,0 )
  13564    I CHBNPY' ="" D
  13565   "RTN","CHG DQ2",176,0 )
  13566    .S X="X X Y W @CHBON ,""Amount  Paid by Be neficiary  to Vendor:  "",@CHBOF F,P1"
  13567   "RTN","CHG DQ2",177,0 )
  13568    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13569   "RTN","CHG DQ2",178,0 )
  13570    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_$J($FN (CHBNPY,", ",2),10)
  13571   "RTN","CHG DQ2",179,0 )
  13572    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13573   "RTN","CHG DQ2",180,0 )
  13574    I CHTLPD' ="" D
  13575   "RTN","CHG DQ2",181,0 )
  13576    .S X="S D X=17 X XY  W @CHBON," "Total Pai d on Claim : "",@CHBO FF,P1"
  13577   "RTN","CHG DQ2",182,0 )
  13578    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_$J($FN (CHTLPD,", ",2),10)
  13579   "RTN","CHG DQ2",183,0 )
  13580    I CHBAMT' ="" D
  13581   "RTN","CHG DQ2",184,0 )
  13582    .S X="S D X=10 X XY  W @CHBON," "Amount Pa id to Bene ficiary: " ",@CHBOFF, P1"
  13583   "RTN","CHG DQ2",185,0 )
  13584    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_$J($FN (CHBAMT,", ",2),10)
  13585   "RTN","CHG DQ2",186,0 )
  13586    I CHVAMT' ="" D
  13587   "RTN","CHG DQ2",187,0 )
  13588    .S X="S D X=15 X XY  W @CHBON," "Amount Pa id to Vend or: "",@CH BOFF,P1"
  13589   "RTN","CHG DQ2",188,0 )
  13590    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_$J($FN (CHVAMT,", ",2),10)
  13591   "RTN","CHG DQ2",189,0 )
  13592    D REOPEN
  13593   "RTN","CHG DQ2",190,0 )
  13594    I $D(^CHM CLCOM("B", CHCLMO)) D   S CHCOM= CHCLMO D ^ CHGDQ3A K  CHCOM
  13595   "RTN","CHG DQ2",191,0 )
  13596    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13597   "RTN","CHG DQ2",192,0 )
  13598    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Claim Comm ents"",@CH BOFF"
  13599   "RTN","CHG DQ2",193,0 )
  13600    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13601   "RTN","CHG DQ2",194,0 )
  13602    I CHPDI'= "" I $D(^C HMCLCOM("B ",$P(CHPDI ,"-",1)))  D  S CHCOM =$P(CHPDI, "-",1) D ^ CHGDQ3A K  CHCOM
  13603   "RTN","CHG DQ2",195,0 )
  13604    .I '$D(^C HMCLCOM("B ",CHCLMO))  D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=" "
  13605   "RTN","CHG DQ2",196,0 )
  13606    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" PDI Commen ts"",@CHBO FF"
  13607   "RTN","CHG DQ2",197,0 )
  13608    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13609   "RTN","CHG DQ2",198,0 )
  13610    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D  D ^ CHGDQ3B
  13611   "RTN","CHG DQ2",199,0 )
  13612    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13613   "RTN","CHG DQ2",200,0 )
  13614    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "S DX=20 X  XY W @CHB ON,""///// /////"",@C HBOFF S DX =33 X XY W  @CHBON,"" Bene Comme nts"",@CHB OFF S DX=4 9 X XY W @ CHBON,""// ////////"" ,@CHBOFF"
  13615   "RTN","CHG DQ2",201,0 )
  13616    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13617   "RTN","CHG DQ2",202,0 )
  13618    I $D(CHMW AT("BENWAT ")) D  D B ENWAT^CHGD Q3B
  13619   "RTN","CHG DQ2",203,0 )
  13620    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13621   "RTN","CHG DQ2",204,0 )
  13622    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "S DX=20 X  XY W @CHB ON,""///// /////"",@C HBOFF S DX =32 X XY W  @CHBON,"" Bene Watch  Info"",@C HBOFF S DX =49 X XY W  @CHBON,"" ////////// "",@CHBOFF "
  13623   "RTN","CHG DQ2",205,0 )
  13624    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13625   "RTN","CHG DQ2",206,0 )
  13626    I VNPT'=" " I $D(^CH MVEN(VNPT, 20)) D  D  VWATCH^CHG DQ3B
  13627   "RTN","CHG DQ2",207,0 )
  13628    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13629   "RTN","CHG DQ2",208,0 )
  13630    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "S DX=20 X  XY W @CHB ON,""///// /////"",@C HBOFF S DX =33 X XY W  @CHBON,"" Vendor Wat ch"",@CHBO FF S DX=49  X XY W @C HBON,""/// ///////"", @CHBOFF"
  13631   "RTN","CHG DQ2",209,0 )
  13632    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  13633   "RTN","CHG DQ2",210,0 )
  13634    K BFN,CHA SS,CHBENE, CHCLMO,CHD OCID,CHDOS ,CHPDI,CHR OPEN,CHSTA T,CHOHIP
  13635   "RTN","CHG DQ2",211,0 )
  13636    K CHSTAT, CHTCB,CHTD X,CHTOS,CH TOSP,CHTPR C,CHVEN,CH VTID,CT,DF N,I,J,RCT
  13637   "RTN","CHG DQ2",212,0 )
  13638    K CHANS,C HBA,CHBAT, CHCODE,CHD ATA,CHDESC ,CHRULEJ,C HTYPE,RECO ,X,L
  13639   "RTN","CHG DQ2",213,0 )
  13640    K ^TEMP($ J,"DEDUCT" ),^TEMP($J ,"OHIPRT") ,^TEMP($J, "OHIPDT"), ^TEMP($J," OHIADT"),^ TEMP($J,"M EDPDT") Q  ;DGC 5/15/ 2011 DEV00 7820
  13641   "RTN","CHG DQ2",214,0 )
  13642   STATUS ;;R EJ,INPROG, PAY REQ,EO B REQ,CMPL TE,ADJUD,C P REQ,ADM  SUS,CC APR V,MANUAL,D ELETED
  13643   "RTN","CHG DQ2",215,0 )
  13644   REOPEN S O LDPDI="",( J,FLG)=0,( FRSTPDI,CH CLPT,CHCLM R)=""
  13645   "RTN","CHG DQ2",216,0 )
  13646   RE1 S J=$O (@(GLPAY_" CHCLM,""PD I"",J)"))  Q:'J
  13647   "RTN","CHG DQ2",217,0 )
  13648    G:'$D(@(G LPAY_"CHCL M,""PDI"", J,0)")) RE 1 S OLDPDI =$P(@(GLPA Y_"CHCLM," "PDI"",J,0 )"),U,1)
  13649   "RTN","CHG DQ2",218,0 )
  13650    I $D(@(GL PAY_"CHCLM ,6)")) S C HCLPT=$P(@ (GLPAY_"CH CLM,6)"),U ,2)
  13651   "RTN","CHG DQ2",219,0 )
  13652    ;I $D(@(G LPAY_"CHCL M,6)")) S  X1=CHCLPT  D PROGTYP2 ^CHFCD001
  13653   "RTN","CHG DQ2",220,0 )
  13654    I CHCLPT' ="" S X1=C HCLPT D PR OGTYP2^CHF CD001
  13655   "RTN","CHG DQ2",221,0 )
  13656    I CHCLPT' ="" S CHCL MR=$P(@(GL PAY2_"CHCL PT,0)"),U, 1)  ; Unde fined erro r on 8/5/0 5  mlr
  13657   "RTN","CHG DQ2",222,0 )
  13658    S:FRSTPDI ="" FRSTPD I=OLDPDI
  13659   "RTN","CHG DQ2",223,0 )
  13660    G:OLDPDI= $P(CHPDI," -",1) RE1
  13661   "RTN","CHG DQ2",224,0 )
  13662    G:'$D(^CH MIMG(OLDPD I,0)) RE1
  13663   "RTN","CHG DQ2",225,0 )
  13664    S CHBAT=" ",CHBAT=$P (^CHMIMG(O LDPDI,0),U ,19)
  13665   "RTN","CHG DQ2",226,0 )
  13666    S CHDC=""
  13667   "RTN","CHG DQ2",227,0 )
  13668    S:$D(^CHM IMG(OLDPDI ,"DOC")) C HDC=$P(^CH MIMG(OLDPD I,"DOC"),U ,1)
  13669   "RTN","CHG DQ2",228,0 )
  13670    S:CHBAT=" " CHBAT=0  S:CHDC=""  CHDC="UNK"
  13671   "RTN","CHG DQ2",229,0 )
  13672    S OLDPDI= OLDPDI_"-" _CHDC
  13673   "RTN","CHG DQ2",230,0 )
  13674    D:FLG=0 R E2
  13675   "RTN","CHG DQ2",231,0 )
  13676    S X="X XY  W P1 S DX =22 X XY W  ""Batch:  "",P2"
  13677   "RTN","CHG DQ2",232,0 )
  13678    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_OLDPDI_ U_CHBAT
  13679   "RTN","CHG DQ2",233,0 )
  13680    S X="X XY  W P1"
  13681   "RTN","CHG DQ2",234,0 )
  13682    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHCLMR
  13683   "RTN","CHG DQ2",235,0 )
  13684    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=" "
  13685   "RTN","CHG DQ2",236,0 )
  13686    G RE1
  13687   "RTN","CHG DQ2",237,0 )
  13688    ;
  13689   "RTN","CHG DQ2",238,0 )
  13690   RE2 D UPCT  S ^UTILIT Y($J,"DUP" ,CHZONE,CT )=""
  13691   "RTN","CHG DQ2",239,0 )
  13692    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=" X XY W @CH BON,@CHULO N,""Associ ated PDIs/ Claims:"", @CHULOFF,@ CHBOFF"
  13693   "RTN","CHG DQ2",240,0 )
  13694    S FLG=1
  13695   "RTN","CHG DQ2",241,0 )
  13696    Q
  13697   "RTN","CHG DQ2",242,0 )
  13698   UPCT S (CT ,^UTILITY( $J,"DUP",C HZONE,0))= CT+1 Q
  13699   "RTN","CHG QA2")
  13700   0^26^B1056 35204
  13701   "RTN","CHG QA2",1,0)
  13702   CHGQA2 ;CV A/CR;FORMA T QAQ AI1  CLAIM OUTP UT FOR DIS PLAY IN QU E;Feb 06,  2019@09:04 :16
  13703   "RTN","CHG QA2",2,0)
  13704    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 9
  13705   "RTN","CHG QA2",3,0)
  13706    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  13707   "RTN","CHG QA2",4,0)
  13708    ;             CHZONE  - SCREEN  REGION
  13709   "RTN","CHG QA2",5,0)
  13710    ;CPTS #10 857* (RLC) , CPTS #10 873* (RLC) , #11567*  (RLC), #12 195* (RLC)
  13711   "RTN","CHG QA2",6,0)
  13712    ;CPTS #13 561* (RLC) , #16110 ( Y2K)
  13713   "RTN","CHG QA2",7,0)
  13714    ;CPTS #16 432 (RLC)  - MODIFICA TIONS MADE  FOR IPS S CREEN SCRA PING
  13715   "RTN","CHG QA2",8,0)
  13716    ;DEV00480 5 1/20/201 0 AEB
  13717   "RTN","CHG QA2",9,0)
  13718    ;DEV00369 8 4/20/201 0 AEB
  13719   "RTN","CHG QA2",10,0)
  13720    ;DEV00782 0 EW 4/18/ 11
  13721   "RTN","CHG QA2",11,0)
  13722    ;DEFECT 8 32284 PL Z IP showing  up on all  queues fo r DME, TRV  and RXT   11/29/2018  NCD
  13723   "RTN","CHG QA2",12,0)
  13724   EN1 ;N (DF N,CHZONE,C HCLM,CHTYP ,CHI,GLPAY ,GLDFN,GLE LG,GLPAYH, GLPAYW,CHP ROG)
  13725   "RTN","CHG QA2",13,0)
  13726    I '$D(CHP ROG) D GTP ROG Q:'$D( PRGFLG)
  13727   "RTN","CHG QA2",14,0)
  13728    S (CHDB,C HDOB,CHSEX ,CHAGE,CHT DDT,CHBRDT ,CHVNPG,CH EXP)=""  ; AEB 1/20/2 010 DEV004 805
  13729   "RTN","CHG QA2",15,0)
  13730    S:'$D(^UT ILITY($J," QAQ",CHZON E,0)) ^UTI LITY($J,"Q AQ",CHZONE ,0)=0
  13731   "RTN","CHG QA2",16,0)
  13732    S CT=^UTI LITY($J,"Q AQ",CHZONE ,0),U="^"
  13733   "RTN","CHG QA2",17,0)
  13734    Q:'$D(@(G LPAY_"CHCL M,0)"))  S  REC0=@(GL PAY_"CHCLM ,0)")
  13735   "RTN","CHG QA2",18,0)
  13736    S CHCLMO= $P(@(GLPAY _"CHCLM,0) "),U,1)
  13737   "RTN","CHG QA2",19,0)
  13738    S:$D(@(GL PAY_"CHCLM ,9)")) CHV NPG=$P(@(G LPAY_"CHCL M,9)"),U,6 )
  13739   "RTN","CHG QA2",20,0)
  13740    S CHCLM(C HZONE,CHCL M)="" S:'$ D(CHCLM(CH ZONE,"CT") ) CHCLM(CH ZONE,"CT") =""
  13741   "RTN","CHG QA2",21,0)
  13742    S CHCLM(C HZONE,"CT" )=CHCLM(CH ZONE,"CT") +1
  13743   "RTN","CHG QA2",22,0)
  13744    S CHPDI=" " S:$D(@(G LPAY_"CHCL M,""PDI"", 1,0)")) CH PDI=$P(@(G LPAY_"CHCL M,""PDI"", 1,0)"),U,1 )
  13745   "RTN","CHG QA2",23,0)
  13746    S CHDOCID ="" I CHPD I'="" S:$D (^CHMIMG(C HPDI,"DOC" )) CHDOCID =$P(^("DOC "),"^",1)
  13747   "RTN","CHG QA2",24,0)
  13748    S:CHDOCID '="" CHPDI =CHPDI_"-" _CHDOCID
  13749   "RTN","CHG QA2",25,0)
  13750    S DFN=$P( REC0,"^",2 1),BFN=$P( REC0,"^",2 2),CHBENE= ""
  13751   "RTN","CHG QA2",26,0)
  13752    I DFN'="" !(BFN'="")  S:$D(@(GL ELG_"DFN,1 00,BFN,0)" )) CHBENE= $P(@(GLELG _"DFN,100, BFN,0)")," ^",1),CHDB =$P(@(GLEL G_"DFN,100 ,BFN,0)"), "^",3),CHS EX=$P(@(GL ELG_"DFN,1 00,BFN,0)" ),"^",2)
  13753   "RTN","CHG QA2",27,0)
  13754    I CHDB'=" " S CHDOB= $$FMTE^XLF DT(CHDB,5)
  13755   "RTN","CHG QA2",28,0)
  13756    E  S CHDO B=""
  13757   "RTN","CHG QA2",29,0)
  13758    D NOW^%DT C S CHTDDT =$P(%H,"," ,1)
  13759   "RTN","CHG QA2",30,0)
  13760    I CHDB=""  S CHAGE=" UNK" G EN2
  13761   "RTN","CHG QA2",31,0)
  13762    S X=CHDB  D H^%DTC S  CHBRDT=%H
  13763   "RTN","CHG QA2",32,0)
  13764    S CHAGE=( (CHTDDT-CH BRDT)/365. 25)\1
  13765   "RTN","CHG QA2",33,0)
  13766   EN2 S X=$P (REC0,"^", 8) S CHDOS ="" I X'=" " D
  13767   "RTN","CHG QA2",34,0)
  13768    .S CHDOS= $E(X,4,5)_ $E(X,6,7)_ $E(X,2,3)
  13769   "RTN","CHG QA2",35,0)
  13770    S CHTOS=" " S X=$P(R EC0,"^",7)  I $D(^CHM DIC(741002 .05,X,0))  D
  13771   "RTN","CHG QA2",36,0)
  13772    .S CHTOS= $P(^(0),"^ ",2)
  13773   "RTN","CHG QA2",37,0)
  13774    I CHTOS=" IPT" S X=" " I $D(@(G LPAY_"CHCL M,""INP"") ")) D  S C HDOS=CHDOS _"-"_X
  13775   "RTN","CHG QA2",38,0)
  13776    .S X=$P(@ (GLPAY_"CH CLM,""INP" ")"),U,1), X=$E(X,4,5 )_$E(X,6,7 )_$E(X,2,3 )
  13777   "RTN","CHG QA2",39,0)
  13778    S (VNPT,C HVEN,CHVTI D,CHVTIDP, CHADCD,CHM DCD)="",(X ,VNPT)=$P( REC0,"^",3 ) I X'=""  D:$D(^CHMV EN(X,0))
  13779   "RTN","CHG QA2",40,0)
  13780    .S CHVEN= $P(^(0),"^ ",1),CHVTI D=$P(^(0), "^",3),CHA DCD=$P(^(0 ),"^",23)
  13781   "RTN","CHG QA2",41,0)
  13782    .S CHMDCD =""
  13783   "RTN","CHG QA2",42,0)
  13784    .S:$D(^CH MVEN(X,14) ) CHMDCD=$ P(^(14),"^ ",1)
  13785   "RTN","CHG QA2",43,0)
  13786    S CHEXP=$ $POACK^CHT FLIB3(X) S :CHEXP=0 C HEXP="N" S :CHEXP=1 C HEXP="Y"   ;AEB 1/20/ 2010 DEV00 4805
  13787   "RTN","CHG QA2",44,0)
  13788    S:CHADCD= "" CHADCD= "  " S:CHM DCD="" CHM DCD="  "
  13789   "RTN","CHG QA2",45,0)
  13790    S CHVTIDP =CHVTID_"- "_CHADCD_" -"_CHMDCD
  13791   "RTN","CHG QA2",46,0)
  13792    S X=$P(^C HMQAQ(CHI, 0),"^",3)  S CHSTAT=$ P($P($T(ST ATUS),";;" ,2),",",(X +1))
  13793   "RTN","CHG QA2",47,0)
  13794    S (CHPCN, CHTOB)=""
  13795   "RTN","CHG QA2",48,0)
  13796    S:$D(@(GL PAY_"CHCLM ,7)")) CHP CN=$P(@(GL PAY_"CHCLM ,7)"),U,5) ,CHTOB=$P( @(GLPAY_"C HCLM,7)"), U,6)
  13797   "RTN","CHG QA2",49,0)
  13798    S TCB=$P( @(GLPAY_"C HCLM,""COM MON"")"),U ,1),TAA=$P (@(GLPAY_" CHCLM,""CO MMON"")"), U,7)
  13799   "RTN","CHG QA2",50,0)
  13800    S CHTCB=$ FN(TCB,"", 2),CHTAA=$ FN(TAA,"", 2)
  13801   "RTN","CHG QA2",51,0)
  13802    S:'CHTAA  CHTAA="Und "
  13803   "RTN","CHG QA2",52,0)
  13804    I $D(@(GL PAY_"CHCLM ,7)")) S C HTPL=$P(@( GLPAY_"CHC LM,7)"),U, 9)  ;DEV78 20 EW 4/18 /11
  13805   "RTN","CHG QA2",53,0)
  13806    E  S CHTP L=""  ;DEV 7820 EW 4/ 18/11
  13807   "RTN","CHG QA2",54,0)
  13808    S:CHTPL'= "" CHTPL=" $"_$J($FN( CHTPL,",", 2),9)  ;DE V7820 EW 4 /18/11
  13809   "RTN","CHG QA2",55,0)
  13810    S X="X XY  W @CHBON, ""Cl: "",@ CHBOFF,P1  S DX=13 X  XY W @CHBO N,""Progra m: "",@CHB OFF,P2 S D X=37 X XY  W @CHBON," "DOS: "",@ CHBOFF,P3  S DX=57 X  XY W @CHBO N,""TOS: " ",@CHBOFF, P4 S DX=68  X XY W @C HBON,""Sta : "",@CHBO FF,P5"
  13811   "RTN","CHG QA2",56,0)
  13812    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHCLMO_ U_CHPROG_U _CHDOS_U_C HTOS_U_CHS TAT
  13813   "RTN","CHG QA2",57,0)
  13814    S X="X XY  W @CHBON, ""Ven Pg:  "",@CHBOFF ,P1 S DX=1 3 X XY W @ CHBON,""Ty pe Bill: " ",@CHBOFF, P2 S DX=37  X XY W @C HBON,""PCN : "",@CHBO FF,P3 S DX =57 X XY W  @CHBON,"" TPL Paymt:  "",@CHBOF F,P4"
  13815   "RTN","CHG QA2",58,0)
  13816    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHVNPG_ U_CHTOB_U_ CHPCN_U_CH TPL
  13817   "RTN","CHG QA2",59,0)
  13818    S X="X XY  W @CHBON, ""Bene: "" ,@CHBOFF,P 1 S DX=37  X XY W @CH BON,""Sex:  "",@CHBOF F,P2 S DX= 46 X XY W  @CHBON,""D OB: "",@CH BOFF,P3 S  DX=63 X XY  W @CHBON, ""Age: "", @CHBOFF,P4  S DX=73 X  XY W @CHB ON,""Tp: " ",@CHBOFF, P5"
  13819   "RTN","CHG QA2",60,0)
  13820    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHBENE_ U_CHSEX_U_ CHDOB_U_CH AGE_U_CHTY P
  13821   "RTN","CHG QA2",61,0)
  13822    S XVEN=$P (REC0,U,3)
  13823   "RTN","CHG QA2",62,0)
  13824    I XVEN'=" " I $D(^CH MVEN(XVEN, 20)) D
  13825   "RTN","CHG QA2",63,0)
  13826    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "S DX=31 X  XY W @CHB ON,""***VE NDOR WATCH  DATA EXIS TS FOR THI S PROVIDER ***"",@CHB OFF"
  13827   "RTN","CHG QA2",64,0)
  13828    ; Y2K - m oved Tp: u p one line  to make r oom for ne w PDI size
  13829   "RTN","CHG QA2",65,0)
  13830    S X="X XY  W @CHBON, ""PDI: "", @CHBOFF,P1  S DX=32 X  XY W @CHB ON,""Ven:  "",@CHBOFF ,P2 S DX=5 8 X XY W @ CHBON,""TI N: "",@CHB OFF,P3"
  13831   "RTN","CHG QA2",66,0)
  13832    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHPDI_U _$E(CHVEN, 1,20)_U_CH VTIDP
  13833   "RTN","CHG QA2",67,0)
  13834    S X="S DX =58 X XY W  @CHBON,"" PL ZIP: "" ,@CHBOFF,P 1"  ;HM 08 /14/2017 0 01-006 PLZ IP ADDITIO N
  13835   "RTN","CHG QA2",68,0)
  13836    S CHPLZIP =$P($G(^CH MPAY(CHCLM ,"VEN-II") ),U,15)  ; HM 08/14/2 017 001-00 6 PLZIP AD DITION
  13837   "RTN","CHG QA2",69,0)
  13838    I "IPT,OP T,DNT"[CHT OS D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) =X_U_CHPLZ IP   ;HM 0 8/14/2017  001-006 PL ZIP ADDITI ON ;Defect  832284 -  added chec k for TOS  to display  PL ZIP on ly for IPT ,OPT and D NT
  13839   "RTN","CHG QA2",70,0)
  13840    I $P(@(GL PAY_"CHCLM ,0)"),U,7) =1 D  ;AEB  1/20/2010  DEV004805
  13841   "RTN","CHG QA2",71,0)
  13842    .S X="X X Y W @CHBON ,""Vendor  POA Exempt : "",@CHBO FF,P1"  ;A EB 1/20/20 10 DEV0048 05
  13843   "RTN","CHG QA2",72,0)
  13844    .I $D(@(G LPAY_"CHCL M,7)")) I  $P(@(GLPAY _"CHCLM,7) "),U,8)'=" " D  Q  ;A EB 7/20/20 10 DEV0036 98
  13845   "RTN","CHG QA2",73,0)
  13846    ..S CHPZI P="" S CHP ZIP=$P(@(G LPAY_"CHCL M,7)"),U,8 )  ;AEB 7/ 20/2010 DE V003698
  13847   "RTN","CHG QA2",74,0)
  13848    ..S X=" S  DX=37 X X Y W @CHBON ,""POP1: " ",@CHBOFF, P2"  ;AEB  7/20/2010  DEV003698
  13849   "RTN","CHG QA2",75,0)
  13850    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) =X_U_CHEXP _U_CHPZIP   ;AEB 7/20 /2010 DEV0 03698
  13851   "RTN","CHG QA2",76,0)
  13852    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_CHEXP   ;AEB 1/20 /2010 DEV0 04805
  13853   "RTN","CHG QA2",77,0)
  13854    I $P(@(GL PAY_"CHCLM ,0)"),U,7) '=1 D  ;AE B 1/20/201 0 DEV00480 5
  13855   "RTN","CHG QA2",78,0)
  13856    .I $D(@(G LPAY_"CHCL M,7)")) I  $P(@(GLPAY _"CHCLM,7) "),U,8)'=" " D  Q  ;A EB 7/20/20 10 DEV0036 98
  13857   "RTN","CHG QA2",79,0)
  13858    ..S CHPZI P="" S CHP ZIP=$P(@(G LPAY_"CHCL M,7)"),U,8 )  ;AEB 7/ 20/2010 DE V003698
  13859   "RTN","CHG QA2",80,0)
  13860    ..S X="X  XY W @CHBO N,""POP1:  "",@CHBOFF ,P1"  ;AEB  7/20/2010  DEV003698
  13861   "RTN","CHG QA2",81,0)
  13862    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) =X_U_CHPZI P  ;AEB 7/ 20/2010 DE V003698
  13863   "RTN","CHG QA2",82,0)
  13864    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) ="W "" """    ;AEB 7/ 20/2010 DE V003698
  13865   "RTN","CHG QA2",83,0)
  13866    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "W "" """   ;AEB 1/20 /2010 DEV0 04805
  13867   "RTN","CHG QA2",84,0)
  13868    ;-------- ----  STAR T DEV7820  EW 7/11/11  --------- ---------- ----
  13869   "RTN","CHG QA2",85,0)
  13870    I (CHTOS= "IPT") D   G EN21
  13871   "RTN","CHG QA2",86,0)
  13872    .S X="X X Y W @CHBON ,@CHULON," "Rej"" S D X=5 X XY W  ""Rslt""  S DX=11 X  XY W ""Cod e"" S DX=2 5 X XY W " "Descripti on"" S DX= 58 X XY W  $J(""Bille d"",10) S  DX=69 X XY  W $J(""Al lowed"",10 ),@CHBOFF, @CHULOFF"
  13873   "RTN","CHG QA2",87,0)
  13874    I (CHTOS= "RXT")&(CH PGPT=6) D   G EN21
  13875   "RTN","CHG QA2",88,0)
  13876    .S X="X X Y W @CHBON ,@CHULON," "Rej"" S D X=5 X XY W  ""Rslt""  S DX=11 X  XY W ""Cod e"" S DX=2 5 X XY W " "Descripti on"" S DX= 58 X XY W  ""DX Code" " S DX=67  X XY W $J( ""Unt/Qty" ",7)  S DX =75 X XY W  $J(""Bill ed"",10)   S DX=87 X  XY W $J("" Allowed"", 10) S DX=9 9 X XY W $ J(""OHI #1  PD"",10)  S DX=111 X  XY W $J(" "OHI #1 PR "",10) S D X=123 X XY  W $J(""Mc aid"",10), @CHBOFF,@C HULOFF"
  13877   "RTN","CHG QA2",89,0)
  13878    .Q
  13879   "RTN","CHG QA2",90,0)
  13880    S X="X XY  W @CHBON, @CHULON,"" Rej"" S DX =5 X XY W  ""Rslt"" S  DX=11 X X Y W ""Code "" S DX=25  X XY W "" Descriptio n"" S DX=6 7 X XY W $ J(""Unt/Qt y"",7)  S  DX=75 X XY  W $J(""To tal Chg"", 10)  S DX= 87 X XY W  $J(""Total  AA"",10)  S DX=99 X  XY W $J("" OHI #1 PD" ",10) S DX =111 X XY  W $J(""OHI  #1 PR"",1 0) S DX=12 3 X XY W $ J(""Mcaid" ",10),@CHB OFF,@CHULO FF"
  13881   "RTN","CHG QA2",91,0)
  13882    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X
  13883   "RTN","CHG QA2",92,0)
  13884    S X="X XY  W @CHBON, @CHULON,"" "" S DX=99  X XY W $J (""Addl OH I"",10) S  DX=111 X X Y W $J(""O HI PR BAL" ",10),@CHB OFF,@CHULO FF"
  13885   "RTN","CHG QA2",93,0)
  13886    ;-------- ----  END  DEV7820 EW  7/11/11 - ---------- ---------- --
  13887   "RTN","CHG QA2",94,0)
  13888   EN21 D UPC T S ^UTILI TY($J,"QAQ ",CHZONE,C T)=X
  13889   "RTN","CHG QA2",95,0)
  13890    S:CHTOS=" OPT" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  13891   "RTN","CHG QA2",96,0)
  13892    S:CHTOS=" DUR" CHTDX ="DME-DX", CHTPRC="DM E-SUPPLY"
  13893   "RTN","CHG QA2",97,0)
  13894    S:CHTOS=" DNT" CHTDX ="DEN-DX", CHTPRC="DE N-PROC"
  13895   "RTN","CHG QA2",98,0)
  13896    S:CHTOS=" TRV" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  13897   "RTN","CHG QA2",99,0)
  13898    S:CHTOS=" RXT" CHTPR C="PHARM"   ;DEV00782 0 EW 8/2/1 1
  13899   "RTN","CHG QA2",100,0 )
  13900    S CHTOSP= $S(CHTOS=" IPT":CHTOS ,CHTOS="RX T":CHTOS,1 :"OPT")
  13901   "RTN","CHG QA2",101,0 )
  13902    D:CHTOSP' ="" @CHTOS P^CHGQA3
  13903   "RTN","CHG QA2",102,0 )
  13904    ;-------- ----  STAR T DEV7820  EW 7/11/11  --------- ---------- ----
  13905   "RTN","CHG QA2",103,0 )
  13906    I CHTOSP= "IPT" D
  13907   "RTN","CHG QA2",104,0 )
  13908    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "S DX=58 X  XY W ""== ========""  S DX=69 X  XY W ""== ========"" "
  13909   "RTN","CHG QA2",105,0 )
  13910    .S X="S D X=58 X XY  W $J(P1,10 ) S DX=69  X XY W $J( P2,10)"
  13911   "RTN","CHG QA2",106,0 )
  13912    .S ALFL=" " I CHTOS= "IPT" S:$P (@(GLPAY_" CHCLM,""IN P"")"),U,1 0)'="" ALF L="A"
  13913   "RTN","CHG QA2",107,0 )
  13914    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_$FN(CH BAT,"",2)_ ALFL_U_CHT AA  ;MTN01 3163: BUG  FIX QAQ13  SLA EW 11/ 2/12
  13915   "RTN","CHG QA2",108,0 )
  13916    E  D
  13917   "RTN","CHG QA2",109,0 )
  13918    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "S DX=60 X  XY W ""TO TALS  ---- ---------- ---------- ---------- ---------- ---------- ---------- -"""
  13919   "RTN","CHG QA2",110,0 )
  13920    .S X="S D X=75 X XY  W $J(P1,10 ) S DX=87  X XY W $J( P2,10) S D X=99 X XY  W $J(P3,10 ) S DX=111  X XY W $J (P4,10) S  DX=123 X X Y W $J(P5, 10)"
  13921   "RTN","CHG QA2",111,0 )
  13922    .S ALFL=" " I CHTOS= "IPT" S:$P (@(GLPAY_" CHCLM,""IN P"")"),U,1 0)'="" ALF L="A"
  13923   "RTN","CHG QA2",112,0 )
  13924    .;S:CHOHI PDT'="" CH OHIPDT=$J( $FN(CHOHIP DT,"",2),1 0)
  13925   "RTN","CHG QA2",113,0 )
  13926    .;S:CHOHI ADT'="" CH OHIADT=$J( $FN(CHOHIA DT,"",2),1 0)
  13927   "RTN","CHG QA2",114,0 )
  13928    .;S:CHMED PT'="" CHM EDPT=$J($F N(CHMEDPT, "",2),10)
  13929   "RTN","CHG QA2",115,0 )
  13930    .;S:CHBAT '="" CHBAT =$FN(CHBAT ,"",2)
  13931   "RTN","CHG QA2",116,0 )
  13932    .;S:CHTAA '="" CHTAA =$FN(CHTAA ,"",2)
  13933   "RTN","CHG QA2",117,0 )
  13934    .;S:CHOHI PRT'="" CH OHIPRT=$J( $FN(CHOHIP RT,"",2),1 0)
  13935   "RTN","CHG QA2",118,0 )
  13936    .;S:CHOHI PBT'="" CH OHIPBT=$J( $FN(CHOHIP BT,"",2),1 0)
  13937   "RTN","CHG QA2",119,0 )
  13938    .S (CHOHI PRT,CHOHIP DT,CHOHIAD T,CHOHIPBT ,CHMEDPT,C HBAT,CHTAA )="" ;MTN0 13163: BUG  FIX QAQ3  SLA EW 6/2 9/12
  13939   "RTN","CHG QA2",120,0 )
  13940    .S:$P($G( @(GLPAY_"C HCLM,1)")) ,U,7)'=""  CHOHIPDT=$ J($FN($P(@ (GLPAY_"CH CLM,1)"),U ,7),"",2), 10) ;MTN01 3163: BUG  FIX QAQ3 S LA EW 6/29 /12
  13941   "RTN","CHG QA2",121,0 )
  13942    .S:$P($G( @(GLPAY_"C HCLM,7)")) ,U,10)'=""  CHOHIADT= $J($FN($P( @(GLPAY_"C HCLM,7)"), U,10),"",2 ),10) ;MTN 013163: BU G FIX QAQ3  SLA EW 6/ 29/12
  13943   "RTN","CHG QA2",122,0 )
  13944    .S:$P($G( @(GLPAY_"C HCLM,7)")) ,U,2)'=""  CHMEDPT=$J ($FN($P(@( GLPAY_"CHC LM,7)"),U, 2),"",2),1 0) ;MTN013 163: BUG F IX QAQ3 SL A EW 6/29/ 12
  13945   "RTN","CHG QA2",123,0 )
  13946    .S:$P($G( @(GLPAY_"C HCLM,""COM MON"")")), U,1)'="" C HBAT=$J($F N($P(@(GLP AY_"CHCLM, ""COMMON"" )"),U,1)," ",2),10) ; MTN013163:  BUG FIX Q AQ3 SLA EW  6/29/12
  13947   "RTN","CHG QA2",124,0 )
  13948    .S:$P($G( @(GLPAY_"C HCLM,""COM MON"")")), U,7)'="" C HTAA=$J($F N($P(@(GLP AY_"CHCLM, ""COMMON"" )"),U,7)," ",2),10) ; MTN013163:  BUG FIX Q AQ3 SLA EW  6/29/12
  13949   "RTN","CHG QA2",125,0 )
  13950    .S:$P($G( @(GLPAY_"C HCLM,1)")) ,U,29)'=""  CHOHIPRT= $J($FN($P( @(GLPAY_"C HCLM,1)"), U,29),"",2 ),10) ;MTN 013163: BU G FIX QAQ3  SLA EW 6/ 29/12
  13951   "RTN","CHG QA2",126,0 )
  13952    .I CHOHIA DT'="" S:$ P($G(@(GLP AY_"CHCLM, 7)")),U,11 )'="" CHOH IPBT=$J($F N($P(@(GLP AY_"CHCLM, 7)"),U,11) ,"",2),10)  ;MTN01316 3: BUG FIX  QAQ3 SLA  EW 7/26/12
  13953   "RTN","CHG QA2",127,0 )
  13954    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_CHBAT_ U_CHTAA_AL FL_U_CHOHI PDT_U_CHOH IPRT_U_CHM EDPT
  13955   "RTN","CHG QA2",128,0 )
  13956    .S X="S D X=99 X XY  W $J(P1,10 ) S DX=111  X XY W $J (P2,10)"
  13957   "RTN","CHG QA2",129,0 )
  13958    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_CHOHIA DT_U_CHOHI PBT
  13959   "RTN","CHG QA2",130,0 )
  13960    ;-------- ----  END  DEV7820 EW  7/11/11 - ---------- ---------- --
  13961   "RTN","CHG QA2",131,0 )
  13962    D REOPEN
  13963   "RTN","CHG QA2",132,0 )
  13964    I $D(^CHM CLCOM("B", CHCLMO)) D   S CHCOM= CHCLMO D ^ CHGQA3A K  CHCOM
  13965   "RTN","CHG QA2",133,0 )
  13966    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  13967   "RTN","CHG QA2",134,0 )
  13968    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Claim Comm ents"",@CH BOFF"
  13969   "RTN","CHG QA2",135,0 )
  13970    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  13971   "RTN","CHG QA2",136,0 )
  13972    I CHPDI'= "" I $D(^C HMCLCOM("B ",$P(CHPDI ,"-",1)))  D  S CHCOM =$P(CHPDI, "-",1) D ^ CHGQA3A K  CHCOM
  13973   "RTN","CHG QA2",137,0 )
  13974    .I '$D(^C HMCLCOM("B ",CHCLMO))  D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=" "
  13975   "RTN","CHG QA2",138,0 )
  13976    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" PDI Commen ts"",@CHBO FF"
  13977   "RTN","CHG QA2",139,0 )
  13978    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  13979   "RTN","CHG QA2",140,0 )
  13980    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D  D ^ CHGQA17
  13981   "RTN","CHG QA2",141,0 )
  13982    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  13983   "RTN","CHG QA2",142,0 )
  13984    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Bene  Comm ents"",@CH BOFF"
  13985   "RTN","CHG QA2",143,0 )
  13986    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  13987   "RTN","CHG QA2",144,0 )
  13988    I VNPT'=" " I $D(^CH MVEN(VNPT, 20)) D  D  VWATCH^CHG QA17
  13989   "RTN","CHG QA2",145,0 )
  13990    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  13991   "RTN","CHG QA2",146,0 )
  13992    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Vendor Wat ch"",@CHBO FF"
  13993   "RTN","CHG QA2",147,0 )
  13994    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  13995   "RTN","CHG QA2",148,0 )
  13996    D ^CHGQAO HI
  13997   "RTN","CHG QA2",149,0 )
  13998    K BFN,CHB ENE,CHCLMO ,CHDOCID,C HDOS,CHPDI ,CHROPEN,C HSTAT
  13999   "RTN","CHG QA2",150,0 )
  14000    K CHSTAT, CHTCB,CHTD X,CHTOS,CH TOSP,CHTPR C,CHVEN,CH VTID,CT,I, J,RCT
  14001   "RTN","CHG QA2",151,0 )
  14002    K CHANS,C HBA,CHBAT, CHCODE,CHD ATA,CHDESC ,CHRULEJ,C HTYPE,RECO ,X,L Q
  14003   "RTN","CHG QA2",152,0 )
  14004   STATUS ;;P END,INPROG ,CMPLTE,RE J,ADM SUS
  14005   "RTN","CHG QA2",153,0 )
  14006   REOPEN S O LDPDI="",( J,FLG)=0,( FRSTPDI,CH CLPT,CHCLM R)=""
  14007   "RTN","CHG QA2",154,0 )
  14008   RE1 S J=$O (@(GLPAY_" CHCLM,""PD I"",J)"))  I 'J Q
  14009   "RTN","CHG QA2",155,0 )
  14010    G:'$D(@(G LPAY_"CHCL M,""PDI"", J,0)")) RE 1 S OLDPDI =$P(@(GLPA Y_"CHCLM," "PDI"",J,0 )"),U,1)
  14011   "RTN","CHG QA2",156,0 )
  14012    I $D(@(GL PAY_"CHCLM ,6)")) S C HCLPT=$P(@ (GLPAY_"CH CLM,6)"),U ,2)
  14013   "RTN","CHG QA2",157,0 )
  14014    I CHCLPT' ="" S X1=C HCLPT D PR OGTYP2^CHF CD001 S CH CLMR=$P(@( GLPAY2_"CH CLPT,0)"), U,1)
  14015   "RTN","CHG QA2",158,0 )
  14016    S:FRSTPDI ="" FRSTPD I=OLDPDI
  14017   "RTN","CHG QA2",159,0 )
  14018    G:OLDPDI= $P(CHPDI," -",1) RE1
  14019   "RTN","CHG QA2",160,0 )
  14020    G:'$D(^CH MIMG(OLDPD I,0)) RE1
  14021   "RTN","CHG QA2",161,0 )
  14022    S CHBAT=" ",CHBAT=$P (^CHMIMG(O LDPDI,0),U ,19)
  14023   "RTN","CHG QA2",162,0 )
  14024    S CHDC=""
  14025   "RTN","CHG QA2",163,0 )
  14026    S:$D(^CHM IMG(OLDPDI ,"DOC")) C HDC=$P(^CH MIMG(OLDPD I,"DOC"),U ,1)
  14027   "RTN","CHG QA2",164,0 )
  14028    S:CHBAT=" " CHBAT=0  S:CHDC=""  CHDC="UNK"
  14029   "RTN","CHG QA2",165,0 )
  14030    S OLDPDI= OLDPDI_"-" _CHDC
  14031   "RTN","CHG QA2",166,0 )
  14032    D:FLG=0 R E2
  14033   "RTN","CHG QA2",167,0 )
  14034    S X="X XY  W P1 S DX =22 X XY W  ""Batch:  "",P2"
  14035   "RTN","CHG QA2",168,0 )
  14036    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_OLDPDI_ U_CHBAT
  14037   "RTN","CHG QA2",169,0 )
  14038    S X="X XY  W P1"
  14039   "RTN","CHG QA2",170,0 )
  14040    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHCLMR
  14041   "RTN","CHG QA2",171,0 )
  14042    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=" "
  14043   "RTN","CHG QA2",172,0 )
  14044    G RE1
  14045   "RTN","CHG QA2",173,0 )
  14046    ;
  14047   "RTN","CHG QA2",174,0 )
  14048   RE2 D UPCT  S ^UTILIT Y($J,"QAQ" ,CHZONE,CT )=""
  14049   "RTN","CHG QA2",175,0 )
  14050    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=" X XY W @CH BON,@CHULO N,""Associ ated PDIs/ DOC Number s:"",@CHUL OFF,@CHBOF F"
  14051   "RTN","CHG QA2",176,0 )
  14052    S FLG=1
  14053   "RTN","CHG QA2",177,0 )
  14054    Q
  14055   "RTN","CHG QA2",178,0 )
  14056   UPCT S (CT ,^UTILITY( $J,"QAQ",C HZONE,0))= CT+1 Q
  14057   "RTN","CHG QA2",179,0 )
  14058   GTPROG K P RGFLG
  14059   "RTN","CHG QA2",180,0 )
  14060    I $D(CHCL MP)!($D(CH CLM)) D  Q
  14061   "RTN","CHG QA2",181,0 )
  14062    .I $D(^CH MINDEX(CHC LMP,0)) S  CHPGPT=$P( ^(0),U,2)  D GT2 Q
  14063   "RTN","CHG QA2",182,0 )
  14064    .I $D(^CH MINDEX(CHC LM,0)) S C HPGPT=$P(^ (0),U,2) D  GT2 Q
  14065   "RTN","CHG QA2",183,0 )
  14066    .Q
  14067   "RTN","CHG QA2",184,0 )
  14068    I $D(CHCL MO) D  Q
  14069   "RTN","CHG QA2",185,0 )
  14070    .Q:'$D(^C HMINDEX("B ",CHCLMO))
  14071   "RTN","CHG QA2",186,0 )
  14072    .S CI=0
  14073   "RTN","CHG QA2",187,0 )
  14074   GT1 .S CI= $O(^CHMIND EX("B",CHC LMO,CI)) Q :'CI
  14075   "RTN","CHG QA2",188,0 )
  14076    .G:'$D(^C HMINDEX(CI ,0)) GT1 S  CHPGPT=$P (^(0),U,2)
  14077   "RTN","CHG QA2",189,0 )
  14078    .D GT2
  14079   "RTN","CHG QA2",190,0 )
  14080    .Q
  14081   "RTN","CHG QA2",191,0 )
  14082   GT2 Q:CHPG PT=""
  14083   "RTN","CHG QA2",192,0 )
  14084    Q:'$D(^CH MDIC(74100 2.94,CHPGP T,0))  S C HPROG=$P(^ (0),U,2)
  14085   "RTN","CHG QA2",193,0 )
  14086    Q:'$D(^CH MDIC(74100 2.94,CHPGP T,1))  S G LREC=^(1)
  14087   "RTN","CHG QA2",194,0 )
  14088    ;S GLPAY= $P(GLREC,U ,1),GLELG= $P(GLREC,U ,2),GLDFN= $P(GLREC,U ,3)
  14089   "RTN","CHG QA2",195,0 )
  14090    S PRGFLG= ""
  14091   "RTN","CHG QA2",196,0 )
  14092    Q
  14093   "RTN","CHG VQ370")
  14094   0^27^B1935 88907
  14095   "RTN","CHG VQ370",1,0 )
  14096   CHGVQ370 ; CVA/PEJ; V F SELECT -  MAIN SCRE EN;Feb 06,  2019@09:5 5:33
  14097   "RTN","CHG VQ370",2,0 )
  14098    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  14099   "RTN","CHG VQ370",3,0 )
  14100    ;CPTS #10 846 - PEJ  8/15/96
  14101   "RTN","CHG VQ370",4,0 )
  14102    ;CPTS #11 158 - PEJ  10/30/96
  14103   "RTN","CHG VQ370",5,0 )
  14104    ;CPTS #15 932 - (Y2K ) 12/17/98
  14105   "RTN","CHG VQ370",6,0 )
  14106    ;DEV00799 1 10/08/20 10 JAK -VE NDOR LOOKU P utilizin g NPI
  14107   "RTN","CHG VQ370",7,0 )
  14108    ;BUG7991- 08-01 DRW  - User is  having a p roblem whe n putting  in a new v endor in t est. Error  out in th e
  14109   "RTN","CHG VQ370",8,0 )
  14110    ;routine.  Need to i nitialize  field CHXR ZIP (remit  zip) befo re being u sed - 01/2 6/11.
  14111   "RTN","CHG VQ370",9,0 )
  14112    ;CPE001-0 09  HM 06/ 30/2017
  14113   "RTN","CHG VQ370",10, 0)
  14114    ;CPE001-0 09  HM 08/ 01/2017
  14115   "RTN","CHG VQ370",11, 0)
  14116    ;CPE001-0 17 SBB 01/ 18/2018 Ch ange REMIT -TO ADDRES S to BILLI NG/REMIT-T O ADDRESS
  14117   "RTN","CHG VQ370",12, 0)
  14118    ;
  14119   "RTN","CHG VQ370",13, 0)
  14120    ;******** ROUTINE DE SCRIPTION* ****
  14121   "RTN","CHG VQ370",14, 0)
  14122    ;$Y,DX,DY        0 -  23
  14123   "RTN","CHG VQ370",15, 0)
  14124    ;DTM,DBM         1 -  n
  14125   "RTN","CHG VQ370",16, 0)
  14126    ;^ZPEJT10  CONTAINS  FIELD LABE LS
  14127   "RTN","CHG VQ370",17, 0)
  14128    ;^UTILITY ($J CONTAI NS THE SCR EEN CODE I NCLUDING F IELD EXTER NAL DATA
  14129   "RTN","CHG VQ370",18, 0)
  14130    ;CHMVAR(n ) CONTAINS  FIELD INT ERNAL DATA
  14131   "RTN","CHG VQ370",19, 0)
  14132    ;       T HESE FIELD S SHOULD C ONTAIN THE  SAME # OF  ELEMENTS  = SCRLEN
  14133   "RTN","CHG VQ370",20, 0)
  14134    ;THERE SH OULD BE AN  EVAL AND  HELP ROUTI NE FOR EAC H FIELD
  14135   "RTN","CHG VQ370",21, 0)
  14136    ; DISPLAY  LENGTH =  (DBM - DTM ) + 1
  14137   "RTN","CHG VQ370",22, 0)
  14138    ;*
  14139   "RTN","CHG VQ370",23, 0)
  14140    ;INPUT VA RS: SCRLTO P,SCRLBOT
  14141   "RTN","CHG VQ370",24, 0)
  14142    ;RETURN V ARS: CHFVP TR
  14143   "RTN","CHG VQ370",25, 0)
  14144    ;*
  14145   "RTN","CHG VQ370",26, 0)
  14146    ;HM 8/1/2 017 ADDED  LOGIC FIX  VV SCREEN  LOOKUP
  14147   "RTN","CHG VQ370",27, 0)
  14148    ;
  14149   "RTN","CHG VQ370",28, 0)
  14150   LOOKUP ;
  14151   "RTN","CHG VQ370",29, 0)
  14152    NEW CHFUN C,CHFLD,DT M,DBM,SCRL EN,DX,DY,C HPOS
  14153   "RTN","CHG VQ370",30, 0)
  14154    K CHPI
  14155   "RTN","CHG VQ370",31, 0)
  14156    S CHFUNC= "VLKUP"
  14157   "RTN","CHG VQ370",32, 0)
  14158    S SCRLTOP =4
  14159   "RTN","CHG VQ370",33, 0)
  14160    S SCRLBOT =22
  14161   "RTN","CHG VQ370",34, 0)
  14162    S DTM=SCR LTOP+2
  14163   "RTN","CHG VQ370",35, 0)
  14164    S DBM=SCR LBOT
  14165   "RTN","CHG VQ370",36, 0)
  14166    S SCRLEN= DBM-DTM
  14167   "RTN","CHG VQ370",37, 0)
  14168    ;
  14169   "RTN","CHG VQ370",38, 0)
  14170    D ^CHSC3
  14171   "RTN","CHG VQ370",39, 0)
  14172    K ^UTILIT Y($J,"VLUL IST")
  14173   "RTN","CHG VQ370",40, 0)
  14174    K ^UTILIT Y($J,"VLKU P")
  14175   "RTN","CHG VQ370",41, 0)
  14176    S CHVDONE =0
  14177   "RTN","CHG VQ370",42, 0)
  14178    S CHFVPTR =0
  14179   "RTN","CHG VQ370",43, 0)
  14180    ;
  14181   "RTN","CHG VQ370",44, 0)
  14182    D RNGECLR ^CHSCH1(SC RLTOP+5,SC RLBOT,XY,C HEOL) ;PEJ
  14183   "RTN","CHG VQ370",45, 0)
  14184    S CHFLAG= 0
  14185   "RTN","CHG VQ370",46, 0)
  14186    D GETXTID ^CHGVQ371
  14187   "RTN","CHG VQ370",47, 0)
  14188    G:CHFLAG= 2 LU2
  14189   "RTN","CHG VQ370",48, 0)
  14190    S LLEN=0
  14191   "RTN","CHG VQ370",49, 0)
  14192    I CHXTID' ="" D LU1^ CHGVQ529     ;CHXTID  = TAX IDEN TIFICATION
  14193   "RTN","CHG VQ370",50, 0)
  14194    I CHXNPI' ="" D NPI^ CHGVQ529     ;CHXNPI  = NATIONAL  PROVIDER  IDENTIFICA TION        ;DEV00799 1 10/08/20 10 JAK
  14195   "RTN","CHG VQ370",51, 0)
  14196    I CHXPRN' ="" D LOOK 2^CHGVQ529   ;CHXPRN  = REMIT-TO  NAME
  14197   "RTN","CHG VQ370",52, 0)
  14198    D ADDLIST ^CHGVQ529  G LU2  ;HM  8/1/2017  ADDED LOGI C FIX VV S CREEN LOOK UP
  14199   "RTN","CHG VQ370",53, 0)
  14200    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  14201   "RTN","CHG VQ370",54, 0)
  14202    Q
  14203   "RTN","CHG VQ370",55, 0)
  14204    ;
  14205   "RTN","CHG VQ370",56, 0)
  14206   LU2 K CHLV AR,CHXTID, CHTIN,CHXN PI,CHXPRN, CHXIM,CHXP I,CHXACT,C HXSTATE,CH XZIP,CHXRZ IP   ;DEV0 07991 10/0 8/2010 JAK
  14207   "RTN","CHG VQ370",57, 0)
  14208    I LLEN=0  D  G END1
  14209   "RTN","CHG VQ370",58, 0)
  14210    .S:$D(^UT ILITY($J," VLULIST"))  CHFVPTR=$ P(^UTILITY ($J,"VLULI ST",LLEN), U,1)
  14211   "RTN","CHG VQ370",59, 0)
  14212    I LLEN=0  S CHFVPTR= "" G END1
  14213   "RTN","CHG VQ370",60, 0)
  14214    S DX=0 F  XIX=SCRLTO P-1:1:SCRL BOT S DY=X IX S $X=$G (DX),$Y=$G (DY) X XY  W @CHEOL
  14215   "RTN","CHG VQ370",61, 0)
  14216    D SCSET ; SET UP SCR EEN PARAME TERS
  14217   "RTN","CHG VQ370",62, 0)
  14218    D GLOBSET  ;SET UP S CREEN GLOB AL
  14219   "RTN","CHG VQ370",63, 0)
  14220    D RDCHSCR
  14221   "RTN","CHG VQ370",64, 0)
  14222    K ^UTILIT Y($J,CHFUN C,CHZONE," CHFLD")
  14223   "RTN","CHG VQ370",65, 0)
  14224    S CHFLD=" " D SETFLD ^CHSCH2(CH FUNC,CHZON E,.CHFLD)
  14225   "RTN","CHG VQ370",66, 0)
  14226    ;
  14227   "RTN","CHG VQ370",67, 0)
  14228    ;******** DISPLAY SC REEN GLOBA L********* ********** ********** ********** **
  14229   "RTN","CHG VQ370",68, 0)
  14230   LU3 ;
  14231   "RTN","CHG VQ370",69, 0)
  14232    S DTM=SCR LTOP+2
  14233   "RTN","CHG VQ370",70, 0)
  14234    S DBM=SCR LBOT X CHM AR
  14235   "RTN","CHG VQ370",71, 0)
  14236    D SHOW^CH SCH2(CHFUN C,CHZONE,D TM,DBM)
  14237   "RTN","CHG VQ370",72, 0)
  14238    D TOP2
  14239   "RTN","CHG VQ370",73, 0)
  14240    I $P(^UTI LITY($J,"C HSCRN",CHF UNC,CHZONE ,"LAST"),U ,1)<DSPLEN  S DBM=DTM -1+$P(^UTI LITY($J,"C HSCRN",CHF UNC,CHZONE ,"LAST"),U ,1)
  14241   "RTN","CHG VQ370",74, 0)
  14242    ;
  14243   "RTN","CHG VQ370",75, 0)
  14244    S DX=1,DY =SCRLTOP+1  S $X=$G(D X),$Y=$G(D Y)
  14245   "RTN","CHG VQ370",76, 0)
  14246    D EN1^CHG VQ372 ;EDI T
  14247   "RTN","CHG VQ370",77, 0)
  14248    D SCSET
  14249   "RTN","CHG VQ370",78, 0)
  14250    ;RETURN P OINTER ...
  14251   "RTN","CHG VQ370",79, 0)
  14252    S ^DISV(D UZ,"VENDOR ","VLU1")= CHFVPTR ;S AVE FOR SP ACEBAR/RET URN
  14253   "RTN","CHG VQ370",80, 0)
  14254    ;
  14255   "RTN","CHG VQ370",81, 0)
  14256   END1 ;
  14257   "RTN","CHG VQ370",82, 0)
  14258    ;S DX=0 F  DY=SCRLTO P-1:1:SCRL BOT S $X=$ G(DX),$Y=$ G(DY) X XY  W @CHEOL
  14259   "RTN","CHG VQ370",83, 0)
  14260    S DX=1 F  DY=SCRLTOP -2:1:SCRLB OT S $X=$G (DX),$Y=$G (DY) X XY  W @CHEOL    ; JEH
  14261   "RTN","CHG VQ370",84, 0)
  14262    K ^UTILIT Y($J,"VLUL IST"),CHFI OUT,CHLUOU T Q
  14263   "RTN","CHG VQ370",85, 0)
  14264    ;
  14265   "RTN","CHG VQ370",86, 0)
  14266   UPCT S CT= CT+1 ;UPDA TE LINE CO UNTER
  14267   "RTN","CHG VQ370",87, 0)
  14268    S $P(^UTI LITY($J,CH FUNC,CHZON E,0),U,1)= CT
  14269   "RTN","CHG VQ370",88, 0)
  14270    S CHUPT=" ",CHUPT=$O (^UTILITY( $J,CHFUNC, CHZONE,CHU PT),-1)
  14271   "RTN","CHG VQ370",89, 0)
  14272    S $P(^UTI LITY($J,CH FUNC,CHZON E,0),U,2)= CHUPT
  14273   "RTN","CHG VQ370",90, 0)
  14274    Q
  14275   "RTN","CHG VQ370",91, 0)
  14276    ;
  14277   "RTN","CHG VQ370",92, 0)
  14278   END Q
  14279   "RTN","CHG VQ370",93, 0)
  14280    ;
  14281   "RTN","CHG VQ370",94, 0)
  14282    ;  SUBROU TINES
  14283   "RTN","CHG VQ370",95, 0)
  14284    ;
  14285   "RTN","CHG VQ370",96, 0)
  14286    ;
  14287   "RTN","CHG VQ370",97, 0)
  14288    ;******** FIELD EVAL UATION**** ********** ********** ********** ********** **
  14289   "RTN","CHG VQ370",98, 0)
  14290   EVAL1 S:$E (Y,1)="@"  Y="" ;TID
  14291   "RTN","CHG VQ370",99, 0)
  14292    S:$E(Y,1) =" " Y=""
  14293   "RTN","CHG VQ370",100 ,0)
  14294    S $P(^UTI LITY($J,"V ","CHVVAR" ,I),U,1)=Y ,$P(^UTILI TY($J,"V", "CHVVAR",I ),U,2)=1
  14295   "RTN","CHG VQ370",101 ,0)
  14296    S $P(^UTI LITY($J,CH FUNC,CHZON E,I),U,3)= Y
  14297   "RTN","CHG VQ370",102 ,0)
  14298    S DX=1 S  $X=$G(DX), $Y=$G(DY)  D REDOLNE^ CHSC2
  14299   "RTN","CHG VQ370",103 ,0)
  14300    Q
  14301   "RTN","CHG VQ370",104 ,0)
  14302    ;
  14303   "RTN","CHG VQ370",105 ,0)
  14304    ;******** FIELD HELP ********** ********** ********** ********** ********** **
  14305   "RTN","CHG VQ370",106 ,0)
  14306   HELP ;TID
  14307   "RTN","CHG VQ370",107 ,0)
  14308    S TX=5,TY =3,BX=75,B Y=9,VON="" ,VOFF=""
  14309   "RTN","CHG VQ370",108 ,0)
  14310    D BOXF^CH SC1(TX,TY, BX,BY)
  14311   "RTN","CHG VQ370",109 ,0)
  14312    D CLRBOXI ^CHSC1(TX, TY,BX,BY,X Y,VON,VOFF )
  14313   "RTN","CHG VQ370",110 ,0)
  14314    S DX=10,D Y=4 S $X=$ G(DX),$Y=$ G(DY) X XY  W "       Enter TAX  ID:   9 ch aracters"
  14315   "RTN","CHG VQ370",111 ,0)
  14316    S DY=5,DX =(40-($L(X )\2)) S $X =$G(DX),$Y =$G(DY) X  XY W "Pres s <RETURN>  to contin ue..."
  14317   "RTN","CHG VQ370",112 ,0)
  14318    S DX=10,D Y=7 S $X=$ G(DX),$Y=$ G(DY) X XY  W "        Use <HELP > key for  more infor mation abo ut this sc reen"
  14319   "RTN","CHG VQ370",113 ,0)
  14320    R X:10
  14321   "RTN","CHG VQ370",114 ,0)
  14322    D REDOLNS ^CHSCH1(CH FUNC,CHZON E,DTM,DBM, TY,BY,.CHS CRN) Q  X  XY Q
  14323   "RTN","CHG VQ370",115 ,0)
  14324    ;
  14325   "RTN","CHG VQ370",116 ,0)
  14326    ;
  14327   "RTN","CHG VQ370",117 ,0)
  14328   RDCHSCR S  CHRDCNT=0, CHRDPTR=0
  14329   "RTN","CHG VQ370",118 ,0)
  14330   RD1 S CHRD PTR=$O(^UT ILITY($J,C HFUNC,CHZO NE,CHRDPTR )) Q:'CHRD PTR
  14331   "RTN","CHG VQ370",119 ,0)
  14332    S CHRDCNT =CHRDCNT+1
  14333   "RTN","CHG VQ370",120 ,0)
  14334    S ^UTILIT Y($J,"CHSC RN",CHFUNC ,CHZONE,CH RDCNT)=CHR DPTR
  14335   "RTN","CHG VQ370",121 ,0)
  14336    G RD1
  14337   "RTN","CHG VQ370",122 ,0)
  14338    ;
  14339   "RTN","CHG VQ370",123 ,0)
  14340   DSPHDR ;
  14341   "RTN","CHG VQ370",124 ,0)
  14342    ;S DX=1,D Y=SCRLTOP- 2 S $X=$G( DX),$Y=$G( DY) X XY W  "LIST LEN GTH: "_LLE N
  14343   "RTN","CHG VQ370",125 ,0)
  14344    S DX=1,DY =SCRLTOP-1  S $X=$G(D X),$Y=$G(D Y) X XY W  "LIST LENG TH: "_LLEN    ; JEH 8 /25/05
  14345   "RTN","CHG VQ370",126 ,0)
  14346    ;S DX=1,D Y=SCRLTOP- 1 S $X=$G( DX),$Y=$G( DY) X XY W  @CHULON,"                        REMIT-TO  ADDRESS                PROVIDER  PHYSICAL L OCATION  " ,@CHULOFF
  14347   "RTN","CHG VQ370",127 ,0)
  14348    ;S DX=1,D Y=SCRLTOP  S $X=$G(DX ),$Y=$G(DY ) X XY W @ CHULON,"                       R EMIT-TO AD DRESS               P ROVIDER PH YSICAL LOC ATION  ",@ CHULOFF  ;  JEH 8/25/ 05
  14349   "RTN","CHG VQ370",128 ,0)
  14350    ;HM 06/30 /2017 - CP E001-009
  14351   "RTN","CHG VQ370",129 ,0)
  14352    ;S DX=1,D Y=SCRLTOP  S $X=$G(DX ),$Y=$G(DY ) X XY W @ CHULON,"                       P ROVIDER PH YSICAL LOC ATION      REMIT-TO A DDRESS             ", @CHULOFF   ;AEB 7/6/2 007
  14353   "RTN","CHG VQ370",130 ,0)
  14354    ;SBB 1/18 /2018 - CP E001-017
  14355   "RTN","CHG VQ370",131 ,0)
  14356    S DX=1,DY =SCRLTOP S  $X=$G(DX) ,$Y=$G(DY)  X XY W @C HULON,"                                                        BI LLING/REMI T-TO ADDRE SS             ",@CHU LOFF
  14357   "RTN","CHG VQ370",132 ,0)
  14358    Q
  14359   "RTN","CHG VQ370",133 ,0)
  14360   DSPHDR1 ;
  14361   "RTN","CHG VQ370",134 ,0)
  14362    S DX=1,DY =SCRLTOP-1  S $X=$G(D X),$Y=$G(D Y) X XY W  "LIST LENG TH: "_LLEN    ; JEH 8 /25/05
  14363   "RTN","CHG VQ370",135 ,0)
  14364    ;HM 08/1/ 2017 - CPE 001-009 VV  SCREEN
  14365   "RTN","CHG VQ370",136 ,0)
  14366    S DX=1,DY =SCRLTOP S  $X=$G(DX) ,$Y=$G(DY)  X XY W @C HULON,"                       PR OVIDER PHY SICAL LOCA TION     R EMIT-TO AD DRESS             ",@ CHULOFF  ; AEB 7/6/20 07
  14367   "RTN","CHG VQ370",137 ,0)
  14368    Q
  14369   "RTN","CHG VQ370",138 ,0)
  14370   LOOK1 ;
  14371   "RTN","CHG VQ370",139 ,0)
  14372    NEW CHFUN C,CHFLD,DT M,DBM,SCRL EN,DX,DY,C HPOS
  14373   "RTN","CHG VQ370",140 ,0)
  14374    ;S CHPI=$ E(CHMFPDI, 6,7),ZICN= "",ZSTN=""   ;Y2K
  14375   "RTN","CHG VQ370",141 ,0)
  14376    S CHPI=$$ TYPE^CHMFP DI2(CHMFPD I),ZICN="" ,ZSTN=""
  14377   "RTN","CHG VQ370",142 ,0)
  14378    S CHFUNC= "VLKUP"
  14379   "RTN","CHG VQ370",143 ,0)
  14380    S DTM=SCR LTOP+2
  14381   "RTN","CHG VQ370",144 ,0)
  14382    S DBM=SCR LBOT
  14383   "RTN","CHG VQ370",145 ,0)
  14384    S SCRLEN= DBM-DTM
  14385   "RTN","CHG VQ370",146 ,0)
  14386    S CHXACT= ""
  14387   "RTN","CHG VQ370",147 ,0)
  14388    S CHXZIP= "",CHXRZIP =""                                       ; ;BUG7991-0 8-01 DRW -  Defined C HXRZIP (Re mit to Zip ) prior to  being use d in CHGVQ 529 - 01/2 6/11.
  14389   "RTN","CHG VQ370",148 ,0)
  14390    D ^CHSC3
  14391   "RTN","CHG VQ370",149 ,0)
  14392    K ^UTILIT Y($J,"VLUL IST")
  14393   "RTN","CHG VQ370",150 ,0)
  14394    K ^UTILIT Y($J,"VLKU P")
  14395   "RTN","CHG VQ370",151 ,0)
  14396    K ^UTILIT Y("VEN",$J )
  14397   "RTN","CHG VQ370",152 ,0)
  14398    S (ZPSCT, ZOUT,ZC,ZN S,ZPSTOT,Z NO)=0,(ZPS N,X)="",(Z PS,ZPS1)=- 1
  14399   "RTN","CHG VQ370",153 ,0)
  14400    S LLEN=0
  14401   "RTN","CHG VQ370",154 ,0)
  14402    S CHVDONE =0
  14403   "RTN","CHG VQ370",155 ,0)
  14404    S CHFVPTR =0
  14405   "RTN","CHG VQ370",156 ,0)
  14406    ;
  14407   "RTN","CHG VQ370",157 ,0)
  14408    S CHBOGID =$E(Y,1,9)  I CHBOGID '="" I $D( ^CHMVEN("D ",CHBOGID) ) S Y=$E(Y ,1,9)_"*"_ $E(Y,10,11 )
  14409   "RTN","CHG VQ370",158 ,0)
  14410    ;
  14411   "RTN","CHG VQ370",159 ,0)
  14412    S CHXTMP= $P(Y,"/",1 )
  14413   "RTN","CHG VQ370",160 ,0)
  14414    S CHSTATE =""
  14415   "RTN","CHG VQ370",161 ,0)
  14416    S Y=$P(Y, "/",2)
  14417   "RTN","CHG VQ370",162 ,0)
  14418    I Y'="" D
  14419   "RTN","CHG VQ370",163 ,0)
  14420    .S DTMSAV =DTM,DBMSA V=DBM
  14421   "RTN","CHG VQ370",164 ,0)
  14422    .D ^CHMFS ET
  14423   "RTN","CHG VQ370",165 ,0)
  14424    .D ^CHGVQ 034
  14425   "RTN","CHG VQ370",166 ,0)
  14426    .S DTM=DT MSAV,DBM=D BMSAV
  14427   "RTN","CHG VQ370",167 ,0)
  14428    .S:'$D(ZS TN) ZSTN=" "
  14429   "RTN","CHG VQ370",168 ,0)
  14430    .D ^CHSC3
  14431   "RTN","CHG VQ370",169 ,0)
  14432    .S CHTMPS T=$P(ZSTN, U,3)
  14433   "RTN","CHG VQ370",170 ,0)
  14434    .S CHSTAT E=$P(ZSTN, U,1)
  14435   "RTN","CHG VQ370",171 ,0)
  14436    ;
  14437   "RTN","CHG VQ370",172 ,0)
  14438    I CHXTMP= "?" D SN0^ CHGVQ529 I  LLEN>0 G  LOOK1F
  14439   "RTN","CHG VQ370",173 ,0)
  14440    S CHXTID= CHXTMP,CHX PLN="" D L U1^CHGVQ52 9,ADDLIST^ CHGVQ529 I  LLEN>0 G  LOOK1F   ; HM 8/1/201 7 ADDED LO GIC FIX VV  SCREEN LO OKUP
  14441   "RTN","CHG VQ370",174 ,0)
  14442    S CHXPLN= CHXTMP D R N0^CHGVQ52 9
  14443   "RTN","CHG VQ370",175 ,0)
  14444   LOOK1F ;
  14445   "RTN","CHG VQ370",176 ,0)
  14446    I '$D(^UT ILITY($J," VLULIST"))  S ZPSN="" ,Y="" D ^C HMFSET Q
  14447   "RTN","CHG VQ370",177 ,0)
  14448    D LU2
  14449   "RTN","CHG VQ370",178 ,0)
  14450    S ZPSN=""
  14451   "RTN","CHG VQ370",179 ,0)
  14452    G:'CHFVPT R LOOK1E
  14453   "RTN","CHG VQ370",180 ,0)
  14454    S:$D(^CHM VEN(CHFVPT R,0)) REC0 =^CHMVEN(C HFVPTR,0)
  14455   "RTN","CHG VQ370",181 ,0)
  14456    S:$D(^CHM VEN(CHFVPT R,1)) REC1 =^CHMVEN(C HFVPTR,1)
  14457   "RTN","CHG VQ370",182 ,0)
  14458    S ZPSN=$P (REC0,U,1) _"^"_$P(RE C0,U,3)_"^ "_$P(REC1, U,1)_"^"_$ P(REC1,U,2 )_"^"_$P(R EC1,U,3)_" ^"_$P(REC1 ,U,4)_"^"_ $P(REC1,U, 5)_"^"_CHF VPTR_"^"_" B"
  14459   "RTN","CHG VQ370",183 ,0)
  14460    S $P(ZICN ,U,3)=CHFV PTR
  14461   "RTN","CHG VQ370",184 ,0)
  14462   LOOK1E K C HLUOUT,CHF IOUT
  14463   "RTN","CHG VQ370",185 ,0)
  14464    S DX=1 F  XIX=SCRLTO P-1:1:SCRL BOT+1 S DY =XIX S $X= $G(DX),$Y= $G(DY) X X Y W @CHEOL
  14465   "RTN","CHG VQ370",186 ,0)
  14466    Q
  14467   "RTN","CHG VQ370",187 ,0)
  14468   CHKPI ;
  14469   "RTN","CHG VQ370",188 ,0)
  14470    S CHPIPTR =0,CHPIFLG =0
  14471   "RTN","CHG VQ370",189 ,0)
  14472    F  S CHPI PTR=$O(^CH MVEN(CHFVP TR,12,CHPI PTR)) Q:'C HPIPTR  D
  14473   "RTN","CHG VQ370",190 ,0)
  14474    .Q:CHXPI' =$P(^CHMVE N(CHFVPTR, 12,CHPIPTR ,0),U,1)
  14475   "RTN","CHG VQ370",191 ,0)
  14476    .S CHPIFL G=1
  14477   "RTN","CHG VQ370",192 ,0)
  14478    Q
  14479   "RTN","CHG VQ370",193 ,0)
  14480   SCSET ;S S CRLEN=14
  14481   "RTN","CHG VQ370",194 ,0)
  14482    N CHFUNC
  14483   "RTN","CHG VQ370",195 ,0)
  14484    S DSPLEN= SCRLEN+1
  14485   "RTN","CHG VQ370",196 ,0)
  14486    ;S DTM=4  ;TOP MARGI N +1
  14487   "RTN","CHG VQ370",197 ,0)
  14488    ;S DBM=19  ;BOTTOM M ARGIN
  14489   "RTN","CHG VQ370",198 ,0)
  14490    S DTM=5 ; SKD
  14491   "RTN","CHG VQ370",199 ,0)
  14492    S DBM=20  ;SKD
  14493   "RTN","CHG VQ370",200 ,0)
  14494    S CHFUNC= "VLKUP"
  14495   "RTN","CHG VQ370",201 ,0)
  14496    S CHZONE= 0
  14497   "RTN","CHG VQ370",202 ,0)
  14498    S ^UTILIT Y($J,"CHSC RN",CHFUNC ,CHZONE,"B EG")=1
  14499   "RTN","CHG VQ370",203 ,0)
  14500    D ^CHSC3  ;SCREEN SE TUP (INSTE AD OF ^CHM FSET)
  14501   "RTN","CHG VQ370",204 ,0)
  14502    ;D RNGECL R^CHSCH1(S CRLTOP,SCR LBOT,XY,CH EOL)
  14503   "RTN","CHG VQ370",205 ,0)
  14504    D RNGECLR ^CHSCH1(3, 19,XY,CHEO L)
  14505   "RTN","CHG VQ370",206 ,0)
  14506    X CHMAR
  14507   "RTN","CHG VQ370",207 ,0)
  14508    D DSPHDR1
  14509   "RTN","CHG VQ370",208 ,0)
  14510    Q
  14511   "RTN","CHG VQ370",209 ,0)
  14512    ;
  14513   "RTN","CHG VQ370",210 ,0)
  14514   TOP2 S:'$D (CHTITLE)  CHTITLE="V endor File  Lookup"
  14515   "RTN","CHG VQ370",211 ,0)
  14516    S:CHTITLE ="" CHTITL E="Vendor  File Looku p"
  14517   "RTN","CHG VQ370",212 ,0)
  14518    S TL="CHA MPVA Payme nt Center  - "_CHTITL E
  14519   "RTN","CHG VQ370",213 ,0)
  14520    S CHTSP=7 9-($L(TL)) \2
  14521   "RTN","CHG VQ370",214 ,0)
  14522    F I=1:1:C HTSP S TL= " "_TL
  14523   "RTN","CHG VQ370",215 ,0)
  14524    F I=1:1:8 0-$L(TL) S  TL=TL_" "
  14525   "RTN","CHG VQ370",216 ,0)
  14526    S DY=1 S  DX=1 S $X= $G(DX),$Y= $G(DY) X X Y W @CHREV ON,TL,@CHR EVOFF
  14527   "RTN","CHG VQ370",217 ,0)
  14528    Q
  14529   "RTN","CHG VQ370",218 ,0)
  14530   GLOBSET S: '$D(^UTILI TY($J,CHFU NC,CHZONE, 0)) ^UTILI TY($J,CHFU NC,CHZONE, 0)=0
  14531   "RTN","CHG VQ370",219 ,0)
  14532    S CT=^UTI LITY($J,CH FUNC,CHZON E,0)
  14533   "RTN","CHG VQ370",220 ,0)
  14534    S X="X XY  W @CHBON, P1,@CHBOFF  S DX=29 S  $X=$G(DX) ,$Y=$G(DY)  X XY W P2 "
  14535   "RTN","CHG VQ370",221 ,0)
  14536    S LPTR=0
  14537   "RTN","CHG VQ370",222 ,0)
  14538   A1 S LPTR= $O(^UTILIT Y($J,"VLUL IST",LPTR) ) G:'LPTR  A2
  14539   "RTN","CHG VQ370",223 ,0)
  14540    F XIX=1:1 :22 S ^UTI LITY($J,"V ","CHVVAR" ,XIX)=""
  14541   "RTN","CHG VQ370",224 ,0)
  14542    F XIX=1:1 :22 S ^UTI LITY($J,"V ","CHVVAR" ,XIX)=$P(^ UTILITY($J ,"VLULIST" ,LPTR),U,X IX)
  14543   "RTN","CHG VQ370",225 ,0)
  14544    ;AEB 7/10 /2007 SWIT CH PHY INF O WITH REM IT INFO
  14545   "RTN","CHG VQ370",226 ,0)
  14546    S ^UTILIT Y($J,"V"," CHVVAR",2) =$P(^UTILI TY($J,"VLU LIST",LPTR ),U,11)  ; AEB 7/10/2 007 SWITCH  REMIT NAM E WITH PHY  NAME
  14547   "RTN","CHG VQ370",227 ,0)
  14548    S ^UTILIT Y($J,"V"," CHVVAR",11 )=$P(^UTIL ITY($J,"VL ULIST",LPT R),U,2)  ; AEB 7/10/2 007 SWITHC  PHY NAME  WITH REMIT  NAME
  14549   "RTN","CHG VQ370",228 ,0)
  14550    S ^UTILIT Y($J,"V"," CHVVAR",5) =$P(^UTILI TY($J,"VLU LIST",LPTR ),U,12)  ; AEB 7/10/2 007 SWITCH  REMIT AD1  1 WITH PH Y AD1
  14551   "RTN","CHG VQ370",229 ,0)
  14552    S ^UTILIT Y($J,"V"," CHVVAR",12 )=$P(^UTIL ITY($J,"VL ULIST",LPT R),U,5)  ; AEB 7/10/2 007 SWITHC  PHY AD1 W ITH REMIT  AD1
  14553   "RTN","CHG VQ370",230 ,0)
  14554    S ^UTILIT Y($J,"V"," CHVVAR",6) =$P(^UTILI TY($J,"VLU LIST",LPTR ),U,13)  ; AEB 7/10/2 007 SWITCH  REMIT AD1  1 WITH PH Y AD2
  14555   "RTN","CHG VQ370",231 ,0)
  14556    S ^UTILIT Y($J,"V"," CHVVAR",13 )=$P(^UTIL ITY($J,"VL ULIST",LPT R),U,6)  ; AEB 7/10/2 007 SWITHC  PHY AD1 W ITH REMIT  AD2
  14557   "RTN","CHG VQ370",232 ,0)
  14558    S ^UTILIT Y($J,"V"," CHVVAR",7) =$P(^UTILI TY($J,"VLU LIST",LPTR ),U,14)  ; AEB 7/10/2 007 SWITCH  REMIT CIT Y 1 WITH P HY CITY
  14559   "RTN","CHG VQ370",233 ,0)
  14560    S ^UTILIT Y($J,"V"," CHVVAR",14 )=$P(^UTIL ITY($J,"VL ULIST",LPT R),U,7)  ; AEB 7/10/2 007 SWITHC  PHY CITY  WITH REMIT  CITY
  14561   "RTN","CHG VQ370",234 ,0)
  14562    S ^UTILIT Y($J,"V"," CHVVAR",8) =$P(^UTILI TY($J,"VLU LIST",LPTR ),U,15)  ; AEB 7/10/2 007 SWITCH  REMIT AD1  1 WITH PH Y AD1)
  14563   "RTN","CHG VQ370",235 ,0)
  14564    S ^UTILIT Y($J,"V"," CHVVAR",15 )=$P(^UTIL ITY($J,"VL ULIST",LPT R),U,8)  ; AEB 7/10/2 007 SWITHC  PHY AD1 W ITH REMIT  AD1
  14565   "RTN","CHG VQ370",236 ,0)
  14566    S ^UTILIT Y($J,"V"," CHVVAR",9) =$P(^UTILI TY($J,"VLU LIST",LPTR ),U,16)  ; AEB 7/10/2 007 SWITCH  REMIT ZIP  WITH PHY  ZIP
  14567   "RTN","CHG VQ370",237 ,0)
  14568    S ^UTILIT Y($J,"V"," CHVVAR",16 )=$P(^UTIL ITY($J,"VL ULIST",LPT R),U,9)  ; AEB 7/10/2 007 SWITHC  PHY ZIP W ITH REMIT  ZIP
  14569   "RTN","CHG VQ370",238 ,0)
  14570    ;
  14571   "RTN","CHG VQ370",239 ,0)
  14572    S:$L(^UTI LITY($J,"V ","CHVVAR" ,2))>25 ^U TILITY($J, "V","CHVVA R",2)=$E(^ UTILITY($J ,"V","CHVV AR",2),1,2 5)
  14573   "RTN","CHG VQ370",240 ,0)
  14574    S:$L(^UTI LITY($J,"V ","CHVVAR" ,5))>25 ^U TILITY($J, "V","CHVVA R",5)=$E(^ UTILITY($J ,"V","CHVV AR",5),1,2 5)
  14575   "RTN","CHG VQ370",241 ,0)
  14576    S:$L(^UTI LITY($J,"V ","CHVVAR" ,6))>25 ^U TILITY($J, "V","CHVVA R",6)=$E(^ UTILITY($J ,"V","CHVV AR",6),1,2 5)
  14577   "RTN","CHG VQ370",242 ,0)
  14578    S:$L(^UTI LITY($J,"V ","CHVVAR" ,7))>15 ^U TILITY($J, "V","CHVVA R",7)=$E(^ UTILITY($J ,"V","CHVV AR",7),1,1 5)
  14579   "RTN","CHG VQ370",243 ,0)
  14580    S:$L(^UTI LITY($J,"V ","CHVVAR" ,11))>25 ^ UTILITY($J ,"V","CHVV AR",11)=$E (^UTILITY( $J,"V","CH VVAR",11), 1,25)
  14581   "RTN","CHG VQ370",244 ,0)
  14582    S:$L(^UTI LITY($J,"V ","CHVVAR" ,12))>25 ^ UTILITY($J ,"V","CHVV AR",12)=$E (^UTILITY( $J,"V","CH VVAR",12), 1,25)
  14583   "RTN","CHG VQ370",245 ,0)
  14584    S:$L(^UTI LITY($J,"V ","CHVVAR" ,13))>25 ^ UTILITY($J ,"V","CHVV AR",13)=$E (^UTILITY( $J,"V","CH VVAR",13), 1,25)
  14585   "RTN","CHG VQ370",246 ,0)
  14586    S:$L(^UTI LITY($J,"V ","CHVVAR" ,14))>15 ^ UTILITY($J ,"V","CHVV AR",14)=$E (^UTILITY( $J,"V","CH VVAR",14), 1,15)
  14587   "RTN","CHG VQ370",247 ,0)
  14588    S:$L(^UTI LITY($J,"V ","CHVVAR" ,22))>2 ^U TILITY($J, "V","CHVVA R",22)=$E( ^UTILITY($ J,"V","CHV VAR",22),1 ,2)
  14589   "RTN","CHG VQ370",248 ,0)
  14590    S AUSVER= ^UTILITY($ J,"V","CHV VAR",10)
  14591   "RTN","CHG VQ370",249 ,0)
  14592    S AUSVER= $S(AUSVER= 0:"N",AUSV ER=1:"Y",1 :"N")
  14593   "RTN","CHG VQ370",250 ,0)
  14594    S PRVER=^ UTILITY($J ,"V","CHVV AR",17)
  14595   "RTN","CHG VQ370",251 ,0)
  14596    S PRVER=$ S(PRVER=0: "UNVERIFIE D",PRVER=1 :"VERIFIED ",1:"UNVER IFIED")
  14597   "RTN","CHG VQ370",252 ,0)
  14598    S CHLVPTR =^UTILITY( $J,"V","CH VVAR",1)
  14599   "RTN","CHG VQ370",253 ,0)
  14600    S CHLSTAT =$P(^CHMVE N(CHLVPTR, 0),U,8)
  14601   "RTN","CHG VQ370",254 ,0)
  14602    S CHLNPI= $P(^CHMVEN (CHLVPTR,1 ),U,19)      ;DEV0079 91a 10/05/ 10 DRW - a dded this  line to ca pture NPI  loc. 19th  in vendor  global
  14603   "RTN","CHG VQ370",255 ,0)
  14604    S CHLSTAT =$S(CHLSTA T=0:"A",CH LSTAT=1:"I ",CHLSTAT= 2:"M",CHLS TAT=3:"W", 1:"A")
  14605   "RTN","CHG VQ370",256 ,0)
  14606    S VCOM=""  S:$D(^CHM VCOMM(CHLV PTR,101))  VCOM="Y" D  EFTCHECK         ;;D EV011835 - - DRW -- n ew line ta g see belo w
  14607   "RTN","CHG VQ370",257 ,0)
  14608    ;
  14609   "RTN","CHG VQ370",258 ,0)
  14610    S LSPACE= " " I LPTR <10 S LSPA CE="  "
  14611   "RTN","CHG VQ370",259 ,0)
  14612    S L1=LSPA CE_LPTR_")  "_^UTILIT Y($J,"V"," CHVVAR",3) _" "_^UTIL ITY($J,"V" ,"CHVVAR", 4)_" "_^UT ILITY($J," V","CHVVAR ",22)_" "_ ^UTILITY($ J,"V","CHV VAR",2)
  14613   "RTN","CHG VQ370",260 ,0)
  14614    S L2="",$ P(L2," ",5 0-$L(L1))= "" S L1=L1 _L2_"| "_^ UTILITY($J ,"V","CHVV AR",11)
  14615   "RTN","CHG VQ370",261 ,0)
  14616    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_L1
  14617   "RTN","CHG VQ370",262 ,0)
  14618    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  14619   "RTN","CHG VQ370",263 ,0)
  14620    S TST=CT, TEND=CT+6
  14621   "RTN","CHG VQ370",264 ,0)
  14622    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  14623   "RTN","CHG VQ370",265 ,0)
  14624    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  14625   "RTN","CHG VQ370",266 ,0)
  14626    I CHLNPI= ""  D             ;DE V007991a D RW - check  to see if  NPI is pr esent
  14627   "RTN","CHG VQ370",267 ,0)
  14628    .S CHLNPI ="           "    ;DE V007991a D RW - if th ere is no  NPI, ten s paces in t he NPI wil l ensure t hat addres s will for mat correc tly.
  14629   "RTN","CHG VQ370",268 ,0)
  14630    S L1="NPI  "_CHLNPI_ " "_^UTILI TY($J,"V", "CHVVAR",5 )    ;DEV  007991a 10 /05/10 DRW  - appends  NPI along  with a sp ace and te n digits i n front of  vendor ad dress.
  14631   "RTN","CHG VQ370",269 ,0)
  14632    S L2="",$ P(L2," ",4 4-$L(L1))= "" S L1=L1 _L2_"| "_^ UTILITY($J ,"V","CHVV AR",12)  ; DEV 007991 a DRW - ch ange lengt h of line  from 29 to  44.
  14633   "RTN","CHG VQ370",270 ,0)
  14634    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"       "_L1   ;DE V007991a D RW - chang e length t o accomoda te NPI
  14635   "RTN","CHG VQ370",271 ,0)
  14636    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  14637   "RTN","CHG VQ370",272 ,0)
  14638    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  14639   "RTN","CHG VQ370",273 ,0)
  14640    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  14641   "RTN","CHG VQ370",274 ,0)
  14642    ;
  14643   "RTN","CHG VQ370",275 ,0)
  14644    S L1="STA TUS = "_CH LSTAT_"  " _^UTILITY( $J,"V","CH VVAR",6)
  14645   "RTN","CHG VQ370",276 ,0)
  14646    S L2="",$ P(L2," ",4 1-$L(L1))= "" S L1=L1 _L2_"| "_^ UTILITY($J ,"V","CHVV AR",13)
  14647   "RTN","CHG VQ370",277 ,0)
  14648    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"          "_L1
  14649   "RTN","CHG VQ370",278 ,0)
  14650    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  14651   "RTN","CHG VQ370",279 ,0)
  14652    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  14653   "RTN","CHG VQ370",280 ,0)
  14654    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  14655   "RTN","CHG VQ370",281 ,0)
  14656    ;
  14657   "RTN","CHG VQ370",282 ,0)
  14658    S LPSTATE ="" S LPST ATE1=^UTIL ITY($J,"V" ,"CHVVAR", 8)
  14659   "RTN","CHG VQ370",283 ,0)
  14660    I LPSTATE 1>0 I $D(^ DIC(5,LPST ATE1,0)) D
  14661   "RTN","CHG VQ370",284 ,0)
  14662    .S LPSTAT E=$P(^DIC( 5,LPSTATE1 ,0),U,2)
  14663   "RTN","CHG VQ370",285 ,0)
  14664    .I $D(^DI C(5,LPSTAT E1,741001) ) S LPSTAT E=^DIC(5,L PSTATE1,74 1001)_" "_ $P(^DIC(5, LPSTATE1,0 ),U,1)
  14665   "RTN","CHG VQ370",286 ,0)
  14666    S PRSTATE =""  S PRS TATE1=^UTI LITY($J,"V ","CHVVAR" ,15)
  14667   "RTN","CHG VQ370",287 ,0)
  14668    I PRSTATE 1>0 I $D(^ DIC(5,PRST ATE1,0)) D
  14669   "RTN","CHG VQ370",288 ,0)
  14670    .S PRSTAT E=$P(^DIC( 5,PRSTATE1 ,0),U,2)
  14671   "RTN","CHG VQ370",289 ,0)
  14672    .I $D(^DI C(5,PRSTAT E1,741001) ) S PRSTAT E=^DIC(5,P RSTATE1,74 1001)_" "_ $P(^DIC(5, PRSTATE1,0 ),U,1)
  14673   "RTN","CHG VQ370",290 ,0)
  14674    ;
  14675   "RTN","CHG VQ370",291 ,0)
  14676    S L1="AUS T VER = "_ AUSVER_"   "_^UTILITY ($J,"V","C HVVAR",7)_ "  "_LPSTA TE_" "_^UT ILITY($J," V","CHVVAR ",9)
  14677   "RTN","CHG VQ370",292 ,0)
  14678    S L2="",$ P(L2," ",4 3-$L(L1))= "" S L1=L1 _L2_"| "_^ UTILITY($J ,"V","CHVV AR",14)_"   "_PRSTATE _" "_^UTIL ITY($J,"V" ,"CHVVAR", 16)
  14679   "RTN","CHG VQ370",293 ,0)
  14680    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"        "_L1
  14681   "RTN","CHG VQ370",294 ,0)
  14682    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  14683   "RTN","CHG VQ370",295 ,0)
  14684    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  14685   "RTN","CHG VQ370",296 ,0)
  14686    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  14687   "RTN","CHG VQ370",297 ,0)
  14688    ;
  14689   "RTN","CHG VQ370",298 ,0)
  14690    S L1="FAC  TYPE: "_$ E(^UTILITY ($J,"V","C HVVAR",21) ,1,20)_"      DRG: "_ ^UTILITY($ J,"V","CHV VAR",20)_"    CMAC: " _^UTILITY( $J,"V","CH VVAR",19)_ "   VCOM:  "_VCOM
  14691   "RTN","CHG VQ370",299 ,0)
  14692    ; ZPEJ,6/ 16/05 S L1 ="FAC TYPE : "_$E(^UT ILITY($J," V","CHVVAR ",21),1,20 )_"          DRG: "_^ UTILITY($J ,"V","CHVV AR",20)_"    CMAC: "_ ^UTILITY($ J,"V","CHV VAR",19)_"    VCOM: " _VCOM
  14693   "RTN","CHG VQ370",300 ,0)
  14694    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"        "_L1
  14695   "RTN","CHG VQ370",301 ,0)
  14696    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  14697   "RTN","CHG VQ370",302 ,0)
  14698    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  14699   "RTN","CHG VQ370",303 ,0)
  14700    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  14701   "RTN","CHG VQ370",304 ,0)
  14702    ;
  14703   "RTN","CHG VQ370",305 ,0)
  14704    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"------ ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---"
  14705   "RTN","CHG VQ370",306 ,0)
  14706    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  14707   "RTN","CHG VQ370",307 ,0)
  14708    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  14709   "RTN","CHG VQ370",308 ,0)
  14710    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  14711   "RTN","CHG VQ370",309 ,0)
  14712    G A1
  14713   "RTN","CHG VQ370",310 ,0)
  14714    ;
  14715   "RTN","CHG VQ370",311 ,0)
  14716   A2 S DX=0, DY=DTM-1 S  $X=$G(DX) ,$Y=$G(DY)  X XY
  14717   "RTN","CHG VQ370",312 ,0)
  14718    Q
  14719   "RTN","CHG VQ370",313 ,0)
  14720   EFTCHECK   ;;this are a will che ck if the  EFT is pre sent for t he vendor   DEV011836  DRW
  14721   "RTN","CHG VQ370",314 ,0)
  14722    N EFTBNKN ,EFTFLG,EF TACCTN,CNT
  14723   "RTN","CHG VQ370",315 ,0)
  14724    S EFTBNKN =0,EFTFLG= 0,EFTACCTN =0
  14725   "RTN","CHG VQ370",316 ,0)
  14726    S CNT=0
  14727   "RTN","CHG VQ370",317 ,0)
  14728    I '$D(^CH MVEN(CHLVP TR,3)) Q
  14729   "RTN","CHG VQ370",318 ,0)
  14730    S EFTBNKN =$P(^CHMVE N(CHLVPTR, 3),"^",1), EFTFLG=$P( ^CHMVEN(CH LVPTR,3)," ^",2),EFTA CCTN=$P(^C HMVEN(CHLV PTR,3),"^" ,3)
  14731   "RTN","CHG VQ370",319 ,0)
  14732    I EFTBNKN '="" S CNT =CNT+1
  14733   "RTN","CHG VQ370",320 ,0)
  14734    I EFTFLG= 1 S CNT=CN T+1
  14735   "RTN","CHG VQ370",321 ,0)
  14736    I EFTACCT N'="" S CN T=CNT+1
  14737   "RTN","CHG VQ370",322 ,0)
  14738    I CNT=3,V COM="" S V COM="EFT"  Q                   ; ;check cou nter for a ll positiv es and the n set the  display
  14739   "RTN","CHG VQ370",323 ,0)
  14740    I CNT=3,V COM'="" S  VCOM=VCOM_ "/EFT"                   ;;if th ere is som ething in  VCOM alrea dy, append  EFT comme nt
  14741   "RTN","CHG VQ370",324 ,0)
  14742    Q
  14743   "RTN","CHG VQ529")
  14744   0^28^B9657 3340
  14745   "RTN","CHG VQ529",1,0 )
  14746   CHGVQ529 ; CVA/PEJ; V F SELECT -  MAIN SCRE EN;Feb 06,  2019@09:5 6:35
  14747   "RTN","CHG VQ529",2,0 )
  14748    ;;1.0;CHA MPVA SYSTE M;**1,8,14 **;JULY 4,  1990;Buil d 9
  14749   "RTN","CHG VQ529",3,0 )
  14750    ;CPTS #10 846* - PEJ  8/15/96
  14751   "RTN","CHG VQ529",4,0 )
  14752    ;CPTS #11 158* - PEJ  10/30/96
  14753   "RTN","CHG VQ529",5,0 )
  14754    ;CPTS #11 294* - PEJ  12/5/96,  #16483* (R LC)
  14755   "RTN","CHG VQ529",6,0 )
  14756    ;jsg;DEV0 02841-02;0 5/12/09;Au to Vendor  Selection  Process;
  14757   "RTN","CHG VQ529",7,0 )
  14758    ;DEV00799 1 10/08/20 10 JAK --V ENDOR LOOK UP utilizi ng NPI
  14759   "RTN","CHG VQ529",8,0 )
  14760    ;BUG00799 1-07 DRW -  Added com ment on th e Fileman  search ind ex 12/15/1 0
  14761   "RTN","CHG VQ529",9,0 )
  14762    ;BUG00799 1-07-03 DR W - Added  K DIC to N PI line ta g to clear  out the w ork area b efore enga ging in NP I search.   12/16/10
  14763   "RTN","CHG VQ529",10, 0)
  14764    ;HM 06/30 /17 CPE001 -001-T3-52 2242 Modif y code to  use vendor  result if  only one  is returne d.
  14765   "RTN","CHG VQ529",11, 0)
  14766    ;BDB 01/2 5/18 CPE00 1-010 Add  label LU2
  14767   "RTN","CHG VQ529",12, 0)
  14768    ;TGH - 3/ 1/18 CPE00 1-019 Add  logic to u se Billing  Address i f availabl e.  Defaul t to "Remi t to" Addr ess
  14769   "RTN","CHG VQ529",13, 0)
  14770    ;TGH - 3/ 8/18 Defec t 693971 F ix Inactiv e Vendor S earch
  14771   "RTN","CHG VQ529",14, 0)
  14772    ;BDB - 9/ 17/18 Defe ct 824319  - CPE001-0 01 - Vendo r Search r eturns ONE  result -- > use corr ect vendor  result
  14773   "RTN","CHG VQ529",15, 0)
  14774   LU1 ;; loo kup based  on Tax Ide ntificatio n Number   ;DEV007991  10/08/201 0 JAK
  14775   "RTN","CHG VQ529",16, 0)
  14776    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  14777   "RTN","CHG VQ529",17, 0)
  14778   LU2 ;;D RN GECLR^CHSC H1(4,22,XY ,CHEOL)    ;SKD ; ;BD B 01/25/18  CPE001-01 0
  14779   "RTN","CHG VQ529",18, 0)
  14780    S CHLID=C HXTID
  14781   "RTN","CHG VQ529",19, 0)
  14782    S:'$D(CHX PI) CHXPI= ""
  14783   "RTN","CHG VQ529",20, 0)
  14784    S:'$D(CHX NPI) CHXNP I=""  ;AEB  9/18/2007
  14785   "RTN","CHG VQ529",21, 0)
  14786    S:'$D(CHX PRN) CHXPR N=""  ;AEB  9/18/2007
  14787   "RTN","CHG VQ529",22, 0)
  14788    S CHXPI=$ P(CHXPI,U, 2)
  14789   "RTN","CHG VQ529",23, 0)
  14790    ;I $L(CHL ID)>13 G L U2^CHGVQ37 0                  ;D EV007991 1 0/08/2010  JAK -comme nted out
  14791   "RTN","CHG VQ529",24, 0)
  14792    ;
  14793   "RTN","CHG VQ529",25, 0)
  14794    S CHLID1= CHLID
  14795   "RTN","CHG VQ529",26, 0)
  14796    K ^UTILIT Y($J,"CHLU OUT")
  14797   "RTN","CHG VQ529",27, 0)
  14798    ;jsg;5/14 /09;DEV002 841;If AVS , pull lis t of vendo rs from ^C HMIMAGE(PD I,100) AVS  index:  ;
  14799   "RTN","CHG VQ529",28, 0)
  14800    IF $D(CHM FPDI),$D(A SVFLG),$D( ^CHMIMAGE( CHMFPDI,10 0,0)),$P(^ (0),U,3)>1  {
  14801   "RTN","CHG VQ529",29, 0)
  14802        D MUL TIASV^CHMX V005(CHMFP DI,0) K AS VFLG }
  14803   "RTN","CHG VQ529",30, 0)
  14804    ELSE { D  FIND^DIC(7 41001,,,"" ,CHLID1,," H",,,"^UTI LITY($J,"" CHLUOUT"") ") }
  14805   "RTN","CHG VQ529",31, 0)
  14806    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  14807   "RTN","CHG VQ529",32, 0)
  14808    I $P(^UTI LITY($J,"C HLUOUT","D ILIST",0), U,1)<1 Q
  14809   "RTN","CHG VQ529",33, 0)
  14810    D RESORTF ^CHGVQ535              ;DEV00799 1 10/08/20 10 JAK
  14811   "RTN","CHG VQ529",34, 0)
  14812    Q
  14813   "RTN","CHG VQ529",35, 0)
  14814   NPI ;; loo kup based  on Nationa l Provider  Identifie r (NPI)  ; DEV007991  10/08/2010  JAK repla ced physic al locatio n name loo kup
  14815   "RTN","CHG VQ529",36, 0)
  14816    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  14817   "RTN","CHG VQ529",37, 0)
  14818    S CHLID=C HXNPI,CHLI D1=CHXNPI
  14819   "RTN","CHG VQ529",38, 0)
  14820    S:'$D(CHX PI) CHXPI= ""
  14821   "RTN","CHG VQ529",39, 0)
  14822    S:'$D(CHX PRN) CHXPR N=""  ;AEB  9/18/2007
  14823   "RTN","CHG VQ529",40, 0)
  14824    S CHXPI=$ P(CHXPI,U, 2)
  14825   "RTN","CHG VQ529",41, 0)
  14826    ;
  14827   "RTN","CHG VQ529",42, 0)
  14828    K ^UTILIT Y($J,"CHLU OUT"),DIC             ;;BUG7991- 07-03 Adde d DIC fiel d in order  clear the  field bef ore a new  search - 1 2/16/10.
  14829   "RTN","CHG VQ529",43, 0)
  14830    D FIND^DI C(741001,, ,"Q",CHLID 1,,"M",,," ^UTILITY($ J,""CHLUOU T"")")  ;; BUG7991-07  DRW - cha nge "Q" to  "M" for Q uick-searc h on index  rather th an Multi s earch - 12 /08/10.
  14831   "RTN","CHG VQ529",44, 0)
  14832    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  14833   "RTN","CHG VQ529",45, 0)
  14834    I $P(^UTI LITY($J,"C HLUOUT","D ILIST",0), U,1)<1 Q   ;; IF NO N PI MATCHES  FOUND THE N QUIT
  14835   "RTN","CHG VQ529",46, 0)
  14836    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  14837   "RTN","CHG VQ529",47, 0)
  14838    Q
  14839   "RTN","CHG VQ529",48, 0)
  14840   LOOK2 ; lo okup based  on remit- to name  ; DEV007991  10/08/2010  JAK
  14841   "RTN","CHG VQ529",49, 0)
  14842    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  14843   "RTN","CHG VQ529",50, 0)
  14844    S CHLID=C HXPRN
  14845   "RTN","CHG VQ529",51, 0)
  14846    S:'$D(CHX PI) CHXPI= ""
  14847   "RTN","CHG VQ529",52, 0)
  14848    S CHXPI=$ P(CHXPI,U, 2)
  14849   "RTN","CHG VQ529",53, 0)
  14850    ;
  14851   "RTN","CHG VQ529",54, 0)
  14852    S CHLID1= CHLID
  14853   "RTN","CHG VQ529",55, 0)
  14854    K ^UTILIT Y($J,"CHLU OUT")
  14855   "RTN","CHG VQ529",56, 0)
  14856    D FIND^DI C(741001,, ,"M",CHLID 1,,"B",,," ^UTILITY($ J,""CHLUOU T"")")
  14857   "RTN","CHG VQ529",57, 0)
  14858    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  14859   "RTN","CHG VQ529",58, 0)
  14860    I $P(^UTI LITY($J,"C HLUOUT","D ILIST",0), U,1)<1 Q
  14861   "RTN","CHG VQ529",59, 0)
  14862    D RESORTF ^CHGVQ535
  14863   "RTN","CHG VQ529",60, 0)
  14864    ;
  14865   "RTN","CHG VQ529",61, 0)
  14866    ;S CHLUPT R=0  S:'$D (CHTZIP) C HTZIP=""   ;AEB 4/9/2 008 DEF004 723 DEFINE D CHTZIP I F MISSING
  14867   "RTN","CHG VQ529",62, 0)
  14868    ;F  S CHL UPTR=$O(^U TILITY($J, "CHLUOUT", "DILIST",2 ,CHLUPTR))  Q:'CHLUPT R  D
  14869   "RTN","CHG VQ529",63, 0)
  14870    ;.S CHLPT R=^UTILITY ($J,"CHLUO UT","DILIS T",2,CHLUP TR)
  14871   "RTN","CHG VQ529",64, 0)
  14872    ;.Q:'$D(^ CHMVEN(CHL PTR,0))
  14873   "RTN","CHG VQ529",65, 0)
  14874    ;.S CHACI M="" S:$D( ^CHMVEN(CH LPTR,14))  CHACIM=$P( ^CHMVEN(CH LPTR,14),U ,1)    ;;  DETERMINE  AUSTIN MOD IFIER  ;DE V007991 10 /08/2010 J AK
  14875   "RTN","CHG VQ529",66, 0)
  14876    ;.I CHXIM '="" Q:CHA CIM'=CHXIM                                                    ;;  AUSTIN MOD IFIER: QUI T IF '= A. M. PROVIDE D  ;DEV007 991 10/08/ 2010 JAK
  14877   "RTN","CHG VQ529",67, 0)
  14878    ;.S CHSTA T=$P(^CHMV EN(CHLPTR, 0),U,8)                                            ;;  DETERMINE  STATUS  ;D EV007991 1 0/08/2010  JAK
  14879   "RTN","CHG VQ529",68, 0)
  14880    ;.I $D(CH XACT) I CH XACT'="Y"  Q:((CHSTAT =1)!(CHSTA T=2))                        ;;  DETERMINE  TO DISPLAY  ACTIVE OR  ACTIVE/IN ACTIVE  ;D EV007991 1 0/08/2010  JAK
  14881   "RTN","CHG VQ529",69, 0)
  14882    ;.I CHXPI '="" D CHK PI^CHGVQ37 0 Q:CHPIFL G=0                                     ;;  DETERMINE  PROGRAM IN DICATOR  ; DEV007991  10/08/2010  JAK
  14883   "RTN","CHG VQ529",70, 0)
  14884    ;.S:$D(^C HMVEN(CHLP TR,2)) CHT ZIP=$P(^CH MVEN(CHLPT R,2),U,5)
  14885   "RTN","CHG VQ529",71, 0)
  14886    ;.I CHXZI P'="" Q:$E (CHTZIP,1, $L(CHXZIP) )'=CHXZIP                               ;;  PROVIDER Z IP: QUIT I F '= PL ZI P PROVIDED   ;DEV0079 91 10/08/2 010 JAK
  14887   "RTN","CHG VQ529",72, 0)
  14888    ;.S:$D(^C HMVEN(CHLP TR,1)) CHT RZIP=$P(^C HMVEN(CHLP TR,1),U,5)
  14889   "RTN","CHG VQ529",73, 0)
  14890    ;.I CHXRZ IP'="" Q:$ E(CHTRZIP, 1,$L(CHXRZ IP))'=CHXR ZIP                          ;;  REMIT-TO Z IP: QUIT I F '= RT ZI P PROVIDED   ;DEV0079 91 10/08/2 010 JAK
  14891   "RTN","CHG VQ529",74, 0)
  14892    ;.I CHSTA TE>0 Q:'$D (^CHMVEN(C HLPTR,2))   Q:$P(^CHM VEN(CHLPTR ,2),U,4)'= CHSTATE  ; AEB 8/16/2 007 CHANGE  FROM REMI T TO PHY A DDRESS
  14893   "RTN","CHG VQ529",75, 0)
  14894    ;.D ADDLI ST^CHGVQ52 8
  14895   "RTN","CHG VQ529",76, 0)
  14896    Q
  14897   "RTN","CHG VQ529",77, 0)
  14898   RN0 ; ; lo okup based  on physic al locatio n name
  14899   "RTN","CHG VQ529",78, 0)
  14900    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  14901   "RTN","CHG VQ529",79, 0)
  14902    S CHLID=C HXPLN
  14903   "RTN","CHG VQ529",80, 0)
  14904    S:'$D(CHX PI) CHXPI= ""
  14905   "RTN","CHG VQ529",81, 0)
  14906    S CHXPI=$ P(CHXPI,U, 2)
  14907   "RTN","CHG VQ529",82, 0)
  14908    S CHLID1= CHLID
  14909   "RTN","CHG VQ529",83, 0)
  14910    K ^UTILIT Y($J,"CHLU OUT")
  14911   "RTN","CHG VQ529",84, 0)
  14912    D FIND^DI C(741001,, ,"M",CHLID 1,,"J",,," ^UTILITY($ J,""CHLUOU T"")")
  14913   "RTN","CHG VQ529",85, 0)
  14914    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  14915   "RTN","CHG VQ529",86, 0)
  14916    I $P(^UTI LITY($J,"C HLUOUT","D ILIST",0), U,1)<1 Q
  14917   "RTN","CHG VQ529",87, 0)
  14918    D RESORTF ^CHGVQ535
  14919   "RTN","CHG VQ529",88, 0)
  14920    ;S CHLUPT R=0
  14921   "RTN","CHG VQ529",89, 0)
  14922    ;F  S CHL UPTR=$O(^U TILITY($J, "CHLUOUT", "DILIST",2 ,CHLUPTR))  Q:'CHLUPT R  D
  14923   "RTN","CHG VQ529",90, 0)
  14924    ;.S CHLPT R=^UTILITY ($J,"CHLUO UT","DILIS T",2,CHLUP TR)
  14925   "RTN","CHG VQ529",91, 0)
  14926    ;.Q:'$D(^ CHMVEN(CHL PTR,0))
  14927   "RTN","CHG VQ529",92, 0)
  14928    ;.S CHSTA T=$P(^CHMV EN(CHLPTR, 0),U,8)
  14929   "RTN","CHG VQ529",93, 0)
  14930    ;.I $D(CH XACT) I CH XACT'="Y"  Q:((CHSTAT =1)!(CHSTA T=2))
  14931   "RTN","CHG VQ529",94, 0)
  14932    ;.I $D(CH XPI) I CHX PI'="" D C HKPI^CHGVQ 370 Q:CHPI FLG=0
  14933   "RTN","CHG VQ529",95, 0)
  14934    ;.S CHTZI P=$P(^CHMV EN(CHLPTR, 2),U,5)
  14935   "RTN","CHG VQ529",96, 0)
  14936    ;.I $D(CH XZIP) I CH XZIP'="" Q :$E(CHTZIP ,1,$L(CHXZ IP))'=CHXZ IP
  14937   "RTN","CHG VQ529",97, 0)
  14938    ;.I CHSTA TE>0 Q:$P( ^CHMVEN(CH LPTR,2),U, 4)'=CHSTAT E
  14939   "RTN","CHG VQ529",98, 0)
  14940    ;.I $D(CH XPLN) I CH XPLN'="" D   Q:TMPPRI D'=CHXPLN   ;PROV LOC  QUALIFIER
  14941   "RTN","CHG VQ529",99, 0)
  14942    ;..S:'$D( ^CHMVEN(CH LPTR,2)) ^ CHMVEN(CHL PTR,2)=""
  14943   "RTN","CHG VQ529",100 ,0)
  14944    ;..S TMPP RID=$P(^CH MVEN(CHLPT R,2),U,8)
  14945   "RTN","CHG VQ529",101 ,0)
  14946    ;..S TMPP RID=$E(TMP PRID,1,$L( CHXPLN))
  14947   "RTN","CHG VQ529",102 ,0)
  14948    ;.D ADDLI ST^CHGVQ52 8
  14949   "RTN","CHG VQ529",103 ,0)
  14950    Q
  14951   "RTN","CHG VQ529",104 ,0)
  14952   SN0 ;
  14953   "RTN","CHG VQ529",105 ,0)
  14954    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  14955   "RTN","CHG VQ529",106 ,0)
  14956    S DY=SCRL TOP+2,DX=0  S $X=$G(D X),$Y=$G(D Y) X XY
  14957   "RTN","CHG VQ529",107 ,0)
  14958    W "THIS L IST WILL T AKE A VERY  LONG TIME . DO YOU W ANT TO CON TINUE? "
  14959   "RTN","CHG VQ529",108 ,0)
  14960    D CSBRS^C HSC2
  14961   "RTN","CHG VQ529",109 ,0)
  14962    I $E(Y,1) '="Y" Q
  14963   "RTN","CHG VQ529",110 ,0)
  14964    K ^TMP("D ILIST",$J)
  14965   "RTN","CHG VQ529",111 ,0)
  14966    D LIST^DI C(741001,, ,,,,,,"I $ P(^CHMVEN( Y,0),U,8)< 1")
  14967   "RTN","CHG VQ529",112 ,0)
  14968    I '$D(^TM P("DILIST" ,$J)) Q
  14969   "RTN","CHG VQ529",113 ,0)
  14970    I $P(^TMP ("DILIST", $J,0),U,1) <1 Q
  14971   "RTN","CHG VQ529",114 ,0)
  14972    D RESORT1 ^CHGVQ535
  14973   "RTN","CHG VQ529",115 ,0)
  14974    ;
  14975   "RTN","CHG VQ529",116 ,0)
  14976    S CHLUPTR =0
  14977   "RTN","CHG VQ529",117 ,0)
  14978    F  S CHLU PTR=$O(^TM P("DILIST" ,$J,2,CHLU PTR)) Q:'C HLUPTR  D
  14979   "RTN","CHG VQ529",118 ,0)
  14980    .S CHLPTR =^TMP("DIL IST",$J,2, CHLUPTR) Q :'$D(^CHMV EN(CHLPTR, 0))
  14981   "RTN","CHG VQ529",119 ,0)
  14982    .S CHSTAT =$P(^CHMVE N(CHLPTR,0 ),U,8) Q:( (CHSTAT=1) !(CHSTAT=2 ))   ;; DE TERMINE TO  DISPLAY A CTIVE OR A CTIVE/INAC TIVE
  14983   "RTN","CHG VQ529",120 ,0)
  14984    .D ADDLIS T^CHGVQ528
  14985   "RTN","CHG VQ529",121 ,0)
  14986    Q
  14987   "RTN","CHG VQ529",122 ,0)
  14988    ;
  14989   "RTN","CHG VQ529",123 ,0)
  14990    ;******** SET UP SCR EEN PARAME TERS****** ********** ********** ********** **
  14991   "RTN","CHG VQ529",124 ,0)
  14992   SCSET ;S S CRLEN=14
  14993   "RTN","CHG VQ529",125 ,0)
  14994    N CHFUNC
  14995   "RTN","CHG VQ529",126 ,0)
  14996    S DSPLEN= SCRLEN+1
  14997   "RTN","CHG VQ529",127 ,0)
  14998    ;S DTM=4  ;TOP MARGI N +1
  14999   "RTN","CHG VQ529",128 ,0)
  15000    ;S DBM=19  ;BOTTOM M ARGIN
  15001   "RTN","CHG VQ529",129 ,0)
  15002    S DTM=5     ;SKD
  15003   "RTN","CHG VQ529",130 ,0)
  15004    S DBM=20     ;SKD
  15005   "RTN","CHG VQ529",131 ,0)
  15006    S CHFUNC= "VLKUP"
  15007   "RTN","CHG VQ529",132 ,0)
  15008    S CHZONE= 0
  15009   "RTN","CHG VQ529",133 ,0)
  15010    S ^UTILIT Y($J,"CHSC RN",CHFUNC ,CHZONE,"B EG")=1
  15011   "RTN","CHG VQ529",134 ,0)
  15012    D ^CHSC3  ;SCREEN SE TUP (INSTE AD OF ^CHM FSET)
  15013   "RTN","CHG VQ529",135 ,0)
  15014    ;D RNGECL R^CHSCH1(S CRLTOP,SCR LBOT,XY,CH EOL)
  15015   "RTN","CHG VQ529",136 ,0)
  15016    D RNGECLR ^CHSCH1(3, 19,XY,CHEO L)
  15017   "RTN","CHG VQ529",137 ,0)
  15018    X CHMAR
  15019   "RTN","CHG VQ529",138 ,0)
  15020    D DSPHDR^ CHGVQ370
  15021   "RTN","CHG VQ529",139 ,0)
  15022    Q
  15023   "RTN","CHG VQ529",140 ,0)
  15024    ;
  15025   "RTN","CHG VQ529",141 ,0)
  15026   ADDLIST ;H M 7/11/201 7 CALL LOC AL LABEL T O POPULATE  ^UTILITY  GLOBAL TO  GET CORREC T COUNTS
  15027   "RTN","CHG VQ529",142 ,0)
  15028    S CA=0,CL LEN=0,LLEN =0
  15029   "RTN","CHG VQ529",143 ,0)
  15030    S:'$D(CHT ZIP) CHTZI P=""
  15031   "RTN","CHG VQ529",144 ,0)
  15032    S:'$D(CHT RZIP) CHTR ZIP=""
  15033   "RTN","CHG VQ529",145 ,0)
  15034    F  S CA=$ O(^UTILITY ($J,"CHLUO UT","DILIS T",2,CA))  Q:'CA  D
  15035   "RTN","CHG VQ529",146 ,0)
  15036    .S CHL=^U TILITY($J, "CHLUOUT", "DILIST",2 ,CA) Q:'$D (^CHMVEN(C HL,0))
  15037   "RTN","CHG VQ529",147 ,0)
  15038    .S CHSTAT =$P(^CHMVE N(CHL,0),U ,8) ;; SET  VENDOR ST ATUS ;DEV0 07991 10/0 8/2010 JAK
  15039   "RTN","CHG VQ529",148 ,0)
  15040    .I CHSTAT ="" S CHST AT=0
  15041   "RTN","CHG VQ529",149 ,0)
  15042    .; Begin  Defect 693 971
  15043   "RTN","CHG VQ529",150 ,0)
  15044    .;S CHXAC T=$S(CHSTA T=0:"Y",CH STAT=1:"N" ,1:0)
  15045   "RTN","CHG VQ529",151 ,0)
  15046    .;I CHSTA T'=0 Q
  15047   "RTN","CHG VQ529",152 ,0)
  15048    .I $G(CHX ACT)'="Y", CHSTAT'=0  Q
  15049   "RTN","CHG VQ529",153 ,0)
  15050    .I $G(CHX ACT)="Y",C HSTAT>1 Q
  15051   "RTN","CHG VQ529",154 ,0)
  15052    .; End De fect 69397 1
  15053   "RTN","CHG VQ529",155 ,0)
  15054    .;.K ^UTI LITY($J,"C HLUOUT","D ILIST",2,C A),^UTILIT Y($J,"CHLU OUT","DILI ST",1,CA)
  15055   "RTN","CHG VQ529",156 ,0)
  15056    .;.S CHMV TOT=$P($G( ^UTILITY($ J,"CHLUOUT ","DILIST" ,0)),"^",1 ),CHMVTOT= CHMVTOT-1, $P(^UTILIT Y($J,"CHLU OUT","DILI ST",0),"^" ,1)=CHMVTO T
  15057   "RTN","CHG VQ529",157 ,0)
  15058    .; Begin  Defect 693 971
  15059   "RTN","CHG VQ529",158 ,0)
  15060    .;I $D(CH XACT) I CH XACT'="Y"  Q:((CHSTAT =1)!(CHSTA T=2)) ;; D ETERMINE T O DISPLAY  ACTIVE OR  ACTIVE/INA CTIVE ;DEV 007991 10/ 08/2010 JA K
  15061   "RTN","CHG VQ529",159 ,0)
  15062    .;---End  Defect 693 971
  15063   "RTN","CHG VQ529",160 ,0)
  15064    .I CHXPI' ="" D CHKP I^CHGVQ370  Q:CHPIFLG =0 ;; DETE RMINE PROG RAM INDICA TOR ;DEV00 7991 10/08 /2010 JAK
  15065   "RTN","CHG VQ529",161 ,0)
  15066    .S:$D(^CH MVEN(CHL,2 )) CHTZIP= $P(^CHMVEN (CHL,2),U, 5)
  15067   "RTN","CHG VQ529",162 ,0)
  15068    .I CHXZIP '="" Q:$E( CHTZIP,1,$ L(CHXZIP)) '=CHXZIP                   ;; PR OVIDER ZIP : QUIT IF  '= PL ZIP  PROVIDED ; DEV007991  10/08/2010  JAK
  15069   "RTN","CHG VQ529",163 ,0)
  15070    .S:$D(^CH MVEN(CHL,1 )) CHTRZIP =$P(^CHMVE N(CHL,1),U ,5)
  15071   "RTN","CHG VQ529",164 ,0)
  15072    .I CHXRZI P'="" Q:$E (CHTRZIP,1 ,$L(CHXRZI P))'=CHXRZ IP              ;; RE MIT-TO ZIP : QUIT IF  '= RT ZIP  PROVIDED ; DEV007991  10/08/2010  JAK
  15073   "RTN","CHG VQ529",165 ,0)
  15074    .I CHSTAT E>0 Q:'$D( ^CHMVEN(CH L,2))  Q:$ P(^CHMVEN( CHL,2),U,4 )'=CHSTATE   ;AEB 8/1 6/2007 CHA NGE FROM R EMIT TO PH Y ADDRESS
  15075   "RTN","CHG VQ529",166 ,0)
  15076    .I CHXPRN '="" D  Q: TMPPRID'=C HXPRN                                 ;; RE MIT NAME:  QUIT IF '=  REMIT NAM E PROVIDED  ;DEV00799 1 10/08/20 10 JAK
  15077   "RTN","CHG VQ529",167 ,0)
  15078    ..S:'$D(^ CHMVEN(CHL ,0)) ^CHMV EN(CHL,0)= ""
  15079   "RTN","CHG VQ529",168 ,0)
  15080    ..S TMPPR ID=$E($P(^ CHMVEN(CHL ,0),U,1),1 ,$L(CHXPRN ))
  15081   "RTN","CHG VQ529",169 ,0)
  15082    .F XI=1:1 :22 S CHLV AR(XI)=""
  15083   "RTN","CHG VQ529",170 ,0)
  15084    .S:'$D(^C HMVEN(CHL, 0)) ^CHMVE N(CHL,0)=" "
  15085   "RTN","CHG VQ529",171 ,0)
  15086    .S:'$D(^C HMVEN(CHL, 1)) ^CHMVE N(CHL,1)=" "
  15087   "RTN","CHG VQ529",172 ,0)
  15088    .S:'$D(^C HMVEN(CHL, 2)) ^CHMVE N(CHL,2)=" "
  15089   "RTN","CHG VQ529",173 ,0)
  15090    .S CHLVAR (1)=CHL
  15091   "RTN","CHG VQ529",174 ,0)
  15092    .S CHLVAR (2)=$P(^CH MVEN(CHL,0 ),U,1) ;RE MIT NAME
  15093   "RTN","CHG VQ529",175 ,0)
  15094    .S CHLVAR (3)=$P(^CH MVEN(CHL,0 ),U,3) ;TI D
  15095   "RTN","CHG VQ529",176 ,0)
  15096    .S CHLVAR (4)=$P(^CH MVEN(CHL,0 ),U,23) ;V AC
  15097   "RTN","CHG VQ529",177 ,0)
  15098    .; ;TGH -  3/1/18 CP E001-019 S et CHLVAR  items 5 th ru 9 in BI LLREMT
  15099   "RTN","CHG VQ529",178 ,0)
  15100    .D BILLRE MT(CHL,.CH LVAR)
  15101   "RTN","CHG VQ529",179 ,0)
  15102    .;S CHLVA R(5)=$P(^C HMVEN(CHL, 1),U,1) ;R EMIT ADDR  1
  15103   "RTN","CHG VQ529",180 ,0)
  15104    .;S CHLVA R(6)=$P(^C HMVEN(CHL, 1),U,2) ;R EMIT ADDR  2
  15105   "RTN","CHG VQ529",181 ,0)
  15106    .;S CHRTF AF=$P(^CHM VEN(CHL,1) ,U,18)
  15107   "RTN","CHG VQ529",182 ,0)
  15108    .;S:CHRTF AF="" CHRT FAF=0
  15109   "RTN","CHG VQ529",183 ,0)
  15110    .;I CHRTF AF=0 D
  15111   "RTN","CHG VQ529",184 ,0)
  15112    .;.S CHLV AR(7)=$P(^ CHMVEN(CHL ,1),U,3) ; REMIT CITY
  15113   "RTN","CHG VQ529",185 ,0)
  15114    .;.S CHLV AR(8)=$P(^ CHMVEN(CHL ,1),U,4) ; REMIT STAT E
  15115   "RTN","CHG VQ529",186 ,0)
  15116    .;.S CHLV AR(9)=$P(^ CHMVEN(CHL ,1),U,5) ; REMIT ZIP
  15117   "RTN","CHG VQ529",187 ,0)
  15118    .;I CHRTF AF=1 D
  15119   "RTN","CHG VQ529",188 ,0)
  15120    .;.S CHTM P=$P(^CHMV EN(CHL,1), U,17) ;REM IT COUNTRY
  15121   "RTN","CHG VQ529",189 ,0)
  15122    .;.S CHLV AR(8)=CHTM P
  15123   "RTN","CHG VQ529",190 ,0)
  15124    .S CHLVAR (10)=$P(^C HMVEN(CHL, 1),U,9) ;A USTIN VERI FY
  15125   "RTN","CHG VQ529",191 ,0)
  15126    .S CHLVAR (11)=$P(^C HMVEN(CHL, 2),U,8) ;P R NAME
  15127   "RTN","CHG VQ529",192 ,0)
  15128    .S CHLVAR (12)=$P(^C HMVEN(CHL, 2),U,1) ;P R ADDR1
  15129   "RTN","CHG VQ529",193 ,0)
  15130    .S CHLVAR (13)=$P(^C HMVEN(CHL, 2),U,2) ;P R ADDR2
  15131   "RTN","CHG VQ529",194 ,0)
  15132    .S CHPRFA F=$P(^CHMV EN(CHL,2), U,11)
  15133   "RTN","CHG VQ529",195 ,0)
  15134    .S CHPRFA F=$P(^CHMV EN(CHL,2), U,11)
  15135   "RTN","CHG VQ529",196 ,0)
  15136    .S:CHPRFA F="" CHPRF AF=0
  15137   "RTN","CHG VQ529",197 ,0)
  15138    .I CHPRFA F=0 D
  15139   "RTN","CHG VQ529",198 ,0)
  15140    ..S CHLVA R(14)=$P(^ CHMVEN(CHL ,2),U,3) ; PR CITY
  15141   "RTN","CHG VQ529",199 ,0)
  15142    ..S CHLVA R(15)=$P(^ CHMVEN(CHL ,2),U,4) ; PR STATE
  15143   "RTN","CHG VQ529",200 ,0)
  15144    ..S CHLVA R(16)=$P(^ CHMVEN(CHL ,2),U,5) ; PR ZIP
  15145   "RTN","CHG VQ529",201 ,0)
  15146    .I CHPRFA F=1 D
  15147   "RTN","CHG VQ529",202 ,0)
  15148    ..S CHTMP =$P(^CHMVE N(CHL,2),U ,10) ;PR C OUNTRY
  15149   "RTN","CHG VQ529",203 ,0)
  15150    ..S CHLVA R(15)=CHTM P
  15151   "RTN","CHG VQ529",204 ,0)
  15152    .S CHLVAR (17)=$P(^C HMVEN(CHL, 2),U,9) ;P R VERIFY
  15153   "RTN","CHG VQ529",205 ,0)
  15154    .S CHLVAR (18)=" " ; MEDICARE #
  15155   "RTN","CHG VQ529",206 ,0)
  15156    .S CHLVAR (19)="" I  $D(^CHMVEN (CHL,41))  D  ;CMAC
  15157   "RTN","CHG VQ529",207 ,0)
  15158    ..S CMACP TR=9999999 .999999
  15159   "RTN","CHG VQ529",208 ,0)
  15160    ..S CMACP TR=$O(^CHM VEN(CHL,41 ,CMACPTR), -1)
  15161   "RTN","CHG VQ529",209 ,0)
  15162    ..Q:'CMAC PTR
  15163   "RTN","CHG VQ529",210 ,0)
  15164    ..S CHLVA R(19)=$P(^ CHMVEN(CHL ,41,CMACPT R,0),U,3)
  15165   "RTN","CHG VQ529",211 ,0)
  15166    .S CHLVAR (20)=" " I  $D(^CHMVE N(CHL,80))  D  ;DRG
  15167   "RTN","CHG VQ529",212 ,0)
  15168    ..S CMACP TR=9999999 .999999
  15169   "RTN","CHG VQ529",213 ,0)
  15170    ..S CMACP TR=$O(^CHM VEN(CHL,80 ,CMACPTR), -1)
  15171   "RTN","CHG VQ529",214 ,0)
  15172    ..Q:'CMAC PTR
  15173   "RTN","CHG VQ529",215 ,0)
  15174    ..S CHTMP DT=$P(^CHM VEN(CHL,80 ,CMACPTR,0 ),U,1)
  15175   "RTN","CHG VQ529",216 ,0)
  15176    ..S CHLVA R(20)=$P(^ CHMVEN(CHL ,80,CMACPT R,0),U,2)
  15177   "RTN","CHG VQ529",217 ,0)
  15178    ..S CHLVA R(20)=CHLV AR(20)_" "
  15179   "RTN","CHG VQ529",218 ,0)
  15180    ..S CHLVA R(20)=$E(C HLVAR(20), 1,7)
  15181   "RTN","CHG VQ529",219 ,0)
  15182    ..I $E(CH LVAR(20),1 )=" " I CH TMPDT'=""  S CHLVAR(2 0)="NO "
  15183   "RTN","CHG VQ529",220 ,0)
  15184    .S CHLVAR (21)=" " I  $P(^CHMVE N(CHL,1),U ,7)'="" D   ;FACILITY  TYPE
  15185   "RTN","CHG VQ529",221 ,0)
  15186    ..S CHTMP =$P(^CHMVE N(CHL,1),U ,7)
  15187   "RTN","CHG VQ529",222 ,0)
  15188    ..S CHLVA R(21)=$P(^ CHMDIC(741 002.11,CHT MP,0),U,2)
  15189   "RTN","CHG VQ529",223 ,0)
  15190    ..S CHLVA R(21)=CHLV AR(21)_" "
  15191   "RTN","CHG VQ529",224 ,0)
  15192    ..S CHLVA R(21)=$E(C HLVAR(21), 1,20)
  15193   "RTN","CHG VQ529",225 ,0)
  15194    .S CHLVAR (22)="" ;I NTERNAL MO DIFIER
  15195   "RTN","CHG VQ529",226 ,0)
  15196    .S:$D(^CH MVEN(CHL,1 4)) CHLVAR (22)=$P(^C HMVEN(CHL, 14),U,1)
  15197   "RTN","CHG VQ529",227 ,0)
  15198    .S:$L(CHL VAR(22))=' 2 CHLVAR(2 2)=" "
  15199   "RTN","CHG VQ529",228 ,0)
  15200    .S CLLEN= CLLEN+1,LL EN=CLLEN
  15201   "RTN","CHG VQ529",229 ,0)
  15202    .S ^UTILI TY($J,"VLU LIST",CLLE N)=CHLVAR( 1)_"^"_CHL VAR(2)_"^" _CHLVAR(3) _"^"_CHLVA R(4)_"^"_C HLVAR(5)_" ^"_CHLVAR( 6)_"^"_CHL VAR(7)_"^" _CHLVAR(8) _"^"_CHLVA R(9)_"^"_C HLVAR(10)_ "^"_CHLVAR (11)
  15203   "RTN","CHG VQ529",230 ,0)
  15204    .S ^UTILI TY($J,"VLU LIST",CLLE N)=^UTILIT Y($J,"VLUL IST",CLLEN )_"^"_CHLV AR(12)_"^" _CHLVAR(13 )_"^"_CHLV AR(14)_"^" _CHLVAR(15 )_"^"_CHLV AR(16)_"^" _CHLVAR(17 )_"^"_CHLV AR(18)_"^" _CHLVAR(19 )_"^"_CHLV AR(20)_"^" _CHLVAR(21 )_"^"_CHLV AR(22)
  15205   "RTN","CHG VQ529",231 ,0)
  15206    I CLLEN=1  S VFN=CHL VAR(1) ;HM  01/29/201 8 ONLY SET  VFN WHEN  ONE VENDOR  IS FOUND  ;OW,BDB,TG H DEFECT 8 24319 - CP E001-001
  15207   "RTN","CHG VQ529",232 ,0)
  15208    Q
  15209   "RTN","CHG VQ529",233 ,0)
  15210    ;
  15211   "RTN","CHG VQ529",234 ,0)
  15212   BILLREMT(C HL,CHLVAR)   ;TGH - 3 /1/18 CPE0 01-019 Add  logic to  use Billin g Address  if availab le.
  15213   "RTN","CHG VQ529",235 ,0)
  15214    ; Default  to "Remit  to" Addre ss if no B illing Add ress
  15215   "RTN","CHG VQ529",236 ,0)
  15216    N BILL,RE MT,REMIT,C HRTFAF
  15217   "RTN","CHG VQ529",237 ,0)
  15218    S REMT=0
  15219   "RTN","CHG VQ529",238 ,0)
  15220    ; Gather  Billing in fo.  If no  Address s et to use  Remit to A ddress
  15221   "RTN","CHG VQ529",239 ,0)
  15222    S BILL=$P ($G(^CHMVE N(CHL,4)), U,1,8)
  15223   "RTN","CHG VQ529",240 ,0)
  15224    I $P(BILL ,U,2)="" S  REMT=1
  15225   "RTN","CHG VQ529",241 ,0)
  15226    S REMIT=$ G(^CHMVEN( CHL,1))
  15227   "RTN","CHG VQ529",242 ,0)
  15228    ; Gather  Foreign Ad dress Flag
  15229   "RTN","CHG VQ529",243 ,0)
  15230    S CHRTFAF =$S('REMT: $P(BILL,U, 7),1:$P(RE MIT,U,18))   ;Foreign  Address F lag
  15231   "RTN","CHG VQ529",244 ,0)
  15232    S:CHRTFAF ="" CHRTFA F=0
  15233   "RTN","CHG VQ529",245 ,0)
  15234    ; Set dis play varia bles based  upon REMT  variable
  15235   "RTN","CHG VQ529",246 ,0)
  15236    ; Include  Billing N ame instea d of Remit -to Name
  15237   "RTN","CHG VQ529",247 ,0)
  15238    S CHLVAR( 2)=$S('REM T&($P(BILL ,U,1)'="") :$P(BILL,U ,1),1:CHLV AR(2)) ;BI LL/REMIT N AME
  15239   "RTN","CHG VQ529",248 ,0)
  15240    S CHLVAR( 5)=$S('REM T:$P(BILL, U,2),1:$P( REMIT,U,1) ) ;BILL/RE MIT ADDR 1
  15241   "RTN","CHG VQ529",249 ,0)
  15242    S CHLVAR( 6)=$S('REM T:$P(BILL, U,3),1:$P( REMIT,U,2) ) ;BILL/RE MIT ADDR 2
  15243   "RTN","CHG VQ529",250 ,0)
  15244    I CHRTFAF =0 D
  15245   "RTN","CHG VQ529",251 ,0)
  15246    .S CHLVAR (7)=$S('RE MT:$P(BILL ,U,4),1:$P (REMIT,U,3 )) ;BILL/R EMIT CITY
  15247   "RTN","CHG VQ529",252 ,0)
  15248    .S CHLVAR (8)=$S('RE MT:$P(BILL ,U,5),1:$P (REMIT,U,4 )) ;BILL/R EMIT STATE
  15249   "RTN","CHG VQ529",253 ,0)
  15250    .S CHLVAR (9)=$S('RE MT:$P(BILL ,U,6),1:$P (REMIT,U,5 )) ;BILL/R EMIT ZIP
  15251   "RTN","CHG VQ529",254 ,0)
  15252    I CHRTFAF =1 D
  15253   "RTN","CHG VQ529",255 ,0)
  15254    .S CHLVAR (8)=$S('RE MT:$P(BILL ,U,7),1:$P (REMIT,U,1 7)) ;BILL/ REMIT COUN TRY
  15255   "RTN","CHG VQ529",256 ,0)
  15256    Q
  15257   "RTN","CHI GDQ3")
  15258   0^29^B9249 0075
  15259   "RTN","CHI GDQ3",1,0)
  15260   CHIGDQ3 ;D EH/DEN;CHA MVPA POST- PROC CLAIM  REPORT PR INT;Feb 06 , 2019@09: 58:10
  15261   "RTN","CHI GDQ3",2,0)
  15262    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  15263   "RTN","CHI GDQ3",3,0)
  15264    ;CPTS #10 763 BY CAM
  15265   "RTN","CHI GDQ3",4,0)
  15266    ;COPIED F ROM CHMF35 1P
  15267   "RTN","CHI GDQ3",5,0)
  15268    ; CPE001- 004 WTC 5/ 17/17
  15269   "RTN","CHI GDQ3",6,0)
  15270   ENTER ;
  15271   "RTN","CHI GDQ3",7,0)
  15272    K ^CHMZHO LD("NO B X -REF"),VIE WFL S EXFL G=0
  15273   "RTN","CHI GDQ3",8,0)
  15274   V1 I $D(VI EWFL) X CH RESET S EX FLG=0
  15275   "RTN","CHI GDQ3",9,0)
  15276    S CHCLN=" ",CHPG=0 S  %H=$H D Y X^%DTC S C HDATE=$P(Y ,"@",1)
  15277   "RTN","CHI GDQ3",10,0 )
  15278    S IGCNT=0
  15279   "RTN","CHI GDQ3",11,0 )
  15280   L0 W:'$D(V IEWFL) # S  IGCNT=$O( ^TMP($J,"C L",IGCNT))  G END:IGC NT=""
  15281   "RTN","CHI GDQ3",12,0 )
  15282    S CHCLN=" "
  15283   "RTN","CHI GDQ3",13,0 )
  15284   L1 S CHCLN =$O(^TMP($ J,"CL",IGC NT,CHCLN))  G L0:CHCL N=""
  15285   "RTN","CHI GDQ3",14,0 )
  15286    S CHECK=" ",CHECK=$O (^CHMPAY(" B",CHCLN,C HECK)) I C HECK="" S  ^CHMZHOLD( "NO B X-RE F",CHCLN)= "" G L1
  15287   "RTN","CHI GDQ3",15,0 )
  15288    K LIREAS, LNREAS,CLR EAS,RESON, CHECKS
  15289   "RTN","CHI GDQ3",16,0 )
  15290    D HEAD S  X=^TMP($J, "CL",IGCNT ,CHCLN)
  15291   "RTN","CHI GDQ3",17,0 )
  15292    I $P(X,"^ ",3)="Inpa tient" D ^ CHIG351Q G  L1
  15293   "RTN","CHI GDQ3",18,0 )
  15294    S X4="",J =0 F K=0:0  S J=$O(^T MP($J,"PDI ",IGCNT,CH CLN,J)) Q: J'?1N.N  S :X4'="" X4 =X4_"^"_^T MP($J,"PDI ",IGCNT,CH CLN,J) S:X 4="" X4=^T MP($J,"PDI ",IGCNT,CH CLN,J)
  15295   "RTN","CHI GDQ3",19,0 )
  15296    D TOP S J =0 D MIDHE D Q:EXFLG= 1  K CODES
  15297   "RTN","CHI GDQ3",20,0 )
  15298   L3 S J=$O( ^TMP($J,"M P",IGCNT,C HCLN,J)) G  L5:'J
  15299   "RTN","CHI GDQ3",21,0 )
  15300    S X1=^TMP ($J,"MP",I GCNT,CHCLN ,J) D SORT  Q:EXFLG=1   G L3
  15301   "RTN","CHI GDQ3",22,0 )
  15302   L5 D MID D  BOT Q:EXF LG=1
  15303   "RTN","CHI GDQ3",23,0 )
  15304   L6 G:'$D(^ TMP($J,"DE D",IGCNT,C HCLN)) L7
  15305   "RTN","CHI GDQ3",24,0 )
  15306    S X3=^TMP ($J,"DED", IGCNT,CHCL N) D DEDT  S J=0
  15307   "RTN","CHI GDQ3",25,0 )
  15308    ;D MULTI
  15309   "RTN","CHI GDQ3",26,0 )
  15310   L7 S J=$O( ^TMP($J,"Q UE",IGCNT, CHCLN,J))  G:'J L8
  15311   "RTN","CHI GDQ3",27,0 )
  15312    S X2=^TMP ($J,"QUE", IGCNT,CHCL N,J) D QUE UE Q:EXFLG =1  G L7
  15313   "RTN","CHI GDQ3",28,0 )
  15314   L8 D REASO N,CHECKS G  L1
  15315   "RTN","CHI GDQ3",29,0 )
  15316   END K CHCL N,CHPG,CHD ATE,X,X1,X 2,Y,J,CHTI ME Q
  15317   "RTN","CHI GDQ3",30,0 )
  15318   MULTI S ZC L="" S ZCL =$O(^CHMPA Y("B",CHCL N,0)) Q:'Z CL
  15319   "RTN","CHI GDQ3",31,0 )
  15320    Q:'$D(^CH MPAY(ZCL,4 ))  S ZI=" ",ZI=$O(^C HMPAY(ZCL, 4,0)) Q:'Z I
  15321   "RTN","CHI GDQ3",32,0 )
  15322    Q:'$O(^CH MPAY(ZCL,4 ,ZI))  S Z I="",ZHI=0
  15323   "RTN","CHI GDQ3",33,0 )
  15324    F ZI=0:0  S ZI=$O(^T MP($J,"QUE ",IGCNT,CH CLN,ZI)) Q :'ZI  S ZH I=ZI
  15325   "RTN","CHI GDQ3",34,0 )
  15326    S ZI=ZHI+ 1,^TMP($J, "QUE",IGCN T,CHCLN,ZI )="Multipl e Reas" Q
  15327   "RTN","CHI GDQ3",35,0 )
  15328   HEAD S CHP G=CHPG+1
  15329   "RTN","CHI GDQ3",36,0 )
  15330    W "DUZ: " ,DUZ,?34," CHAMPVA Ce nter",?71, "Page: ",C HPG
  15331   "RTN","CHI GDQ3",37,0 )
  15332    W !,"Date : ",CHDATE ,?27,"Post -Processin g Claim Re port"
  15333   "RTN","CHI GDQ3",38,0 )
  15334    W !,"Time : " D TIME  W CHTIME  Q
  15335   "RTN","CHI GDQ3",39,0 )
  15336   TOP ;W !!! ,"      PD I: " S J=1  F K=0:0 Q :X4=""  W: J>1 ! W ?1 4,$P(X4,"^ ",1) S J=J +1,X4=$P(X 4,"^",2,99 9)
  15337   "RTN","CHI GDQ3",40,0 )
  15338    ;
  15339   "RTN","CHI GDQ3",41,0 )
  15340    S CHPVPTR ="",CHPTID ="",CHPVAC ="",CHPIM= ""
  15341   "RTN","CHI GDQ3",42,0 )
  15342    S CHPPTR= "",CHPPTR= $O(^CHMPAY ("B",CHCLN ,CHPPTR))
  15343   "RTN","CHI GDQ3",43,0 )
  15344    S CHPVPTR =$P(^CHMPA Y(CHPPTR,0 ),U,3)
  15345   "RTN","CHI GDQ3",44,0 )
  15346    I CHPVPTR  I $D(^CHM VEN(CHPVPT R,0)) D
  15347   "RTN","CHI GDQ3",45,0 )
  15348    .S CHPTID =$P(^CHMVE N(CHPVPTR, 0),U,3)
  15349   "RTN","CHI GDQ3",46,0 )
  15350    .S CHPVAC =$P(^CHMVE N(CHPVPTR, 0),U,23)
  15351   "RTN","CHI GDQ3",47,0 )
  15352    .S CHPIM= "" S:$D(^C HMVEN(CHPV PTR,14)) C HPIM=$P(^C HMVEN(CHPV PTR,14),U, 1)
  15353   "RTN","CHI GDQ3",48,0 )
  15354    S PDICPT= CHPPTR D P DIS
  15355   "RTN","CHI GDQ3",49,0 )
  15356    W !!,"       PDI: ", CHPDI_"-"_ CHDOC,"  B ATCH: ",CH BATCH
  15357   "RTN","CHI GDQ3",50,0 )
  15358    W ?57,"Cl aim #: ",C HCLN
  15359   "RTN","CHI GDQ3",51,0 )
  15360    I $D(^CHM PAY(CHPPTR ,6)) W ! D  REOPEN
  15361   "RTN","CHI GDQ3",52,0 )
  15362    ;
  15363   "RTN","CHI GDQ3",53,0 )
  15364    ;W !,?7," Batch:  "
  15365   "RTN","CHI GDQ3",54,0 )
  15366    W !,"       EIN: ",C HPTID_"-"_ CHPVAC_"-" _CHPIM
  15367   "RTN","CHI GDQ3",55,0 )
  15368    W ?58,"St atus: ",$P (X,"^",1)
  15369   "RTN","CHI GDQ3",56,0 )
  15370    W !,"   V endor: ",$ P(X,"^",2) ,?60,"Type : ",$P(X," ^",3)
  15371   "RTN","CHI GDQ3",57,0 )
  15372    W !,"Pay  Prov?: ",$ P(X,"^",4) ,?50,"Ser/ Admis Date : ",$P(X," ^",5)
  15373   "RTN","CHI GDQ3",58,0 )
  15374    S CHCMPDT ="" I $P(^ CHMPAY(CHP PTR,0),"^" ,10)'="" D
  15375   "RTN","CHI GDQ3",59,0 )
  15376    .S Y=$P(^ CHMPAY(CHP PTR,0),"^" ,10) X ^DD ("DD") S C HCMPDT=$P( Y,"@",1)
  15377   "RTN","CHI GDQ3",60,0 )
  15378    W !,"  Sp onsor: ",$ P(X,"^",6) ,?54,"Comp . Date: ", CHCMPDT
  15379   "RTN","CHI GDQ3",61,0 )
  15380    W !,"      Bene: ",$ P(X,"^",7) ,?61,"POS:  ",$P(X,"^ ",20)
  15381   "RTN","CHI GDQ3",62,0 )
  15382    W !," Ben e Sex: ",$ P(X,"^",21 ),?15,"Ben e DOB: ",$ P(X,"^",22 )
  15383   "RTN","CHI GDQ3",63,0 )
  15384    W ?58,"PL  ZIP: ",$P ($G(^CHMPA Y(CHPPTR," VEN-II")), U,15) ; WT C - DISPLA Y PL ZIP
  15385   "RTN","CHI GDQ3",64,0 )
  15386    I $P(X,"^ ",19)'=""  W !,?4,"Me dicaid: ", $P(X,"^",1 9)
  15387   "RTN","CHI GDQ3",65,0 )
  15388    W !! Q
  15389   "RTN","CHI GDQ3",66,0 )
  15390   MIDHED I $ D(VIEWFL)  W !!,"Pres s <RETURN>  to contin ue, <^> to  exit." R  XXX S:XXX= "^" EXFLG= 1 W !
  15391   "RTN","CHI GDQ3",67,0 )
  15392    W !,"DX's ",?7,"PX's /NDC's",?2 2,"Unt",?2 7,"Chg/Unt ",?38,"AA/ Unt"
  15393   "RTN","CHI GDQ3",68,0 )
  15394    W ?49,"To tal Chg",? 60,"Total  AA",?71,"R sl",?76,"R eas"
  15395   "RTN","CHI GDQ3",69,0 )
  15396    W !,"---- -- ------- ------  -- -  ------- --  ------ ---  ----- ----  ---- -----  ---   ----" Q
  15397   "RTN","CHI GDQ3",70,0 )
  15398   MID S SORT =""
  15399   "RTN","CHI GDQ3",71,0 )
  15400   MID1 S SOR T=$O(CODES (SORT)) Q: SORT=""  S  CODE=""
  15401   "RTN","CHI GDQ3",72,0 )
  15402   MID2 S COD E=$O(CODES (SORT,CODE )) G:CODE= "" MID1 S  AMT1=""
  15403   "RTN","CHI GDQ3",73,0 )
  15404   MID3 S AMT 1=$O(CODES (SORT,CODE ,AMT1)) G: AMT1="" MI D2 S AMT2= ""
  15405   "RTN","CHI GDQ3",74,0 )
  15406   MID4 S AMT 2=$O(CODES (SORT,CODE ,AMT1,AMT2 )) G:AMT2= "" MID3 S  RESON=""
  15407   "RTN","CHI GDQ3",75,0 )
  15408   MID5 S RES ON=$O(CODE S(SORT,COD E,AMT1,AMT 2,RESON))  G:RESON=""  MID4
  15409   "RTN","CHI GDQ3",76,0 )
  15410    S X1=CODE S(SORT,COD E,AMT1,AMT 2,RESON)
  15411   "RTN","CHI GDQ3",77,0 )
  15412    I $P(X1," ^",2)'=""  W !,$P(X1, "^",2) G M ID6
  15413   "RTN","CHI GDQ3",78,0 )
  15414    I $P(X1," ^",1)'=""  W !,?7,$P( X1,"^",1)  G MID6
  15415   "RTN","CHI GDQ3",79,0 )
  15416    I $P(X1," ^",3)'=""  W !,?7,$P( X1,"^",3)
  15417   "RTN","CHI GDQ3",80,0 )
  15418   MID6 W ?22 ,$J($P(X1, "^",10),3)
  15419   "RTN","CHI GDQ3",81,0 )
  15420    W:$P(X1," ^",4)'["A"  ?27,$J($F N($P(X1,"^ ",4),",",2 ),9)
  15421   "RTN","CHI GDQ3",82,0 )
  15422    W:$P(X1," ^",4)["A"  ?27,"$",$J ($FN($P(X1 ,"^",4),", ",2),9)_"A "
  15423   "RTN","CHI GDQ3",83,0 )
  15424    I $P(X1," ^",5)="" I  ($P(X,"^" ,3)="Inpat ient")!($P (X,"^",3)= "Pharmacy" ) W ?38,"u ndtr."
  15425   "RTN","CHI GDQ3",84,0 )
  15426    I $P(X1," ^",5)="" I  ($P(X,"^" ,3)'="Inpa tient")&($ P(X,"^",3) '="Pharmac y") W ?38, "  "
  15427   "RTN","CHI GDQ3",85,0 )
  15428    I $P(X1," ^",5)'=""  W ?38,$J($ FN($P(X1," ^",5),",", 2),9)
  15429   "RTN","CHI GDQ3",86,0 )
  15430    S TOTCHG= ($P(X1,"^" ,10)*$P(X1 ,"^",4))
  15431   "RTN","CHI GDQ3",87,0 )
  15432    W ?49,$J( $FN(TOTCHG ,",",2),9)
  15433   "RTN","CHI GDQ3",88,0 )
  15434    S TOTAA=( $P(X1,"^", 10)*$P(X1, "^",5))
  15435   "RTN","CHI GDQ3",89,0 )
  15436    W ?60,$J( $FN(TOTAA, ",",2),9)
  15437   "RTN","CHI GDQ3",90,0 )
  15438    I $P(X1," ^",6)="" W  ?71,"und"
  15439   "RTN","CHI GDQ3",91,0 )
  15440    E  W ?71, $P(X1,"^", 6)
  15441   "RTN","CHI GDQ3",92,0 )
  15442    W:$P(X1," ^",8)'=""  ?76,$J($P( X1,"^",8), 4)
  15443   "RTN","CHI GDQ3",93,0 )
  15444    S:$P(X1," ^",8)'=""  LNREAS($P( X1,"^",8)) =""
  15445   "RTN","CHI GDQ3",94,0 )
  15446    G MID5
  15447   "RTN","CHI GDQ3",95,0 )
  15448   SORT S COD E="",SORT= ""
  15449   "RTN","CHI GDQ3",96,0 )
  15450    S RESON=$ P(X1,"^",8 ) S:RESON= "" RESON="  "
  15451   "RTN","CHI GDQ3",97,0 )
  15452    S AMT1=$P (X1,"^",4) ,AMT2=$P(X 1,"^",5)
  15453   "RTN","CHI GDQ3",98,0 )
  15454    S:AMT1=""  AMT1=0 S: AMT2="" AM T2=0
  15455   "RTN","CHI GDQ3",99,0 )
  15456    I $P(X1," ^",1)'=""  S CODE=$P( X1,"^",1), SORT=3 G S RT1
  15457   "RTN","CHI GDQ3",100, 0)
  15458    I $P(X1," ^",2)'=""  S CODE=$P( X1,"^",2), AMT1=0,SOR T=1,AMT2=0  G SRT1
  15459   "RTN","CHI GDQ3",101, 0)
  15460    I $P(X1," ^",3)'=""  S CODE=$P( X1,"^",3), SORT=2
  15461   "RTN","CHI GDQ3",102, 0)
  15462   SRT1 Q:COD E=""
  15463   "RTN","CHI GDQ3",103, 0)
  15464    I '$D(COD ES(SORT,CO DE,AMT1,AM T2,RESON))  S CODES(S ORT,CODE,A MT1,AMT2,R ESON)=X1_" ^^"_1 Q
  15465   "RTN","CHI GDQ3",104, 0)
  15466    S $P(CODE S(SORT,COD E,AMT1,AMT 2,RESON)," ^",10)=$P( CODES(SORT ,CODE,AMT1 ,AMT2,RESO N),"^",10) +1
  15467   "RTN","CHI GDQ3",105, 0)
  15468    Q
  15469   "RTN","CHI GDQ3",106, 0)
  15470   BOT I $D(V IEWFL) W ! !,"Press < RETURN> to  Continue,  <^> to ex it." R XXX  S:XXX="^"  EXFLG=1 W  !
  15471   "RTN","CHI GDQ3",107, 0)
  15472    ;E  I $Y> 52 W # S H X=X D HEAD  S X=HX
  15473   "RTN","CHI GDQ3",108, 0)
  15474    I $P(X,"^ ",8)="" W  !!,?21,"To tal Charge s Billed:   ",?46,"un determined "
  15475   "RTN","CHI GDQ3",109, 0)
  15476    E  D
  15477   "RTN","CHI GDQ3",110, 0)
  15478    .S ALFL=" " I $P(X," ^",3)="Inp atient" D
  15479   "RTN","CHI GDQ3",111, 0)
  15480    ..S CHCLN P=$O(^CHMP AY("B",CHC LN,0)) Q:' CHCLNP
  15481   "RTN","CHI GDQ3",112, 0)
  15482    ..I $D(^C HMPAY(CHCL NP,"INP"))  S:$P(^("I NP"),"^",1 0)'="" ALF L="A"
  15483   "RTN","CHI GDQ3",113, 0)
  15484    .W !!,?21 ,"Total Ch arges Bill ed:  ",?48 ,$J($FN($P (X,"^",8), ",",2),10) _ALFL
  15485   "RTN","CHI GDQ3",114, 0)
  15486    I $P(X,"^ ",9)="" W  !,?14,"Cal culated Al lowable Am ount:  ",? 46,"undete rmined"
  15487   "RTN","CHI GDQ3",115, 0)
  15488    E  W !,?1 4,"Calcula ted Allowa ble Amount :  ",?48,$ J($FN($P(X ,"^",9),", ",2),10)
  15489   "RTN","CHI GDQ3",116, 0)
  15490    D CITI
  15491   "RTN","CHI GDQ3",117, 0)
  15492    D MEDI
  15493   "RTN","CHI GDQ3",118, 0)
  15494    I $P(X,"^ ",10)="" W  !,?13,"Am ount Appli ed to Dedu ctible:  " ,?46,"unde termined"
  15495   "RTN","CHI GDQ3",119, 0)
  15496    E  W !,?1 3,"Amount  Applied to  Deductibl e:  ",?48, $J($FN($P( X,"^",10), ",",2),10)
  15497   "RTN","CHI GDQ3",120, 0)
  15498    I $P(X,"^ ",11)="" W  !,?11,"Co st Share C redited to  Cat Cap:   ",?46,"un determined "
  15499   "RTN","CHI GDQ3",121, 0)
  15500    E  W !,?1 1,"Cost Sh are Credit ed to Cat  Cap:  ",?4 8,$J($FN($ P(X,"^",11 ),",",2),1 0)
  15501   "RTN","CHI GDQ3",122, 0)
  15502    I ($P(X," ^",18)=1)& ($P(X,"^", 17)="") W  !,?16,"Amo unt applie d to Cat C ap:",?46," undetermin ed"
  15503   "RTN","CHI GDQ3",123, 0)
  15504    E  I ($P( X,"^",18)= 1)&($P(X," ^",17)'="" ) W !,?16, "Amount ap plied to C at Cap:",? 48,$J($FN( $P(X,"^",1 7),",",2), 10)
  15505   "RTN","CHI GDQ3",124, 0)
  15506    I $P(X,"^ ",12)="" W  !,?11,"Am ount Paid  by Other I nsurance:   ",?55,"N/ A"
  15507   "RTN","CHI GDQ3",125, 0)
  15508    E  W !,?1 1,"Amount  Paid by Ot her Insura nce:  ",?4 8,$J($FN($ P(X,"^",12 ),",",2),1 0)
  15509   "RTN","CHI GDQ3",126, 0)
  15510    W !,?5,"A mount Paid  by Benefi ciary to V endor:",?4 8,$J($FN($ P(X,"^",14 ),",",2),1 0)
  15511   "RTN","CHI GDQ3",127, 0)
  15512    I $P(X,"^ ",13)="" W  !!,?9,"To tal Amount  to be PAI D on claim :",?46,"un determined "
  15513   "RTN","CHI GDQ3",128, 0)
  15514    E  W !!,? 9,"Total A mount to b e PAID on  claim:  ", ?48,$J($FN ($P(X,"^", 13),",",2) ,10)
  15515   "RTN","CHI GDQ3",129, 0)
  15516    I $P(X,"^ ",15)="" W  !,?20,"Am ount PAID  to Vendor: ",?46,"und etermined"
  15517   "RTN","CHI GDQ3",130, 0)
  15518    E  W !,?2 0,"Amount  PAID to Ve ndor:",?48 ,$J($FN($P (X,"^",15) ,",",2),10 )
  15519   "RTN","CHI GDQ3",131, 0)
  15520    I $P(X,"^ ",16)="" W  !,?15,"Am ount PAID  to Benefic iary:",?46 ,"undeterm ined"
  15521   "RTN","CHI GDQ3",132, 0)
  15522    E  W !,?1 5,"Amount  PAID to Be neficiary: ",?48,$J($ FN($P(X,"^ ",16),",", 2),10)
  15523   "RTN","CHI GDQ3",133, 0)
  15524    D
  15525   "RTN","CHI GDQ3",134, 0)
  15526    .S CHCLNP =$O(^CHMPA Y("B",CHCL N,0)) Q:'C HCLNP
  15527   "RTN","CHI GDQ3",135, 0)
  15528    .Q:'$D(^C HMPAY(CHCL NP,5))  Q: $P(^(5),"^ ",1)=""  S  SR=$P(^(5 ),"^",1)
  15529   "RTN","CHI GDQ3",136, 0)
  15530    .W !,?20, $S(SR=0:"* PENDING RE COUPMENT*" ,SR=1:"*PA RTIAL RECO UPMENT REC EIVED*",SR =2:"*FULL  RECOUPMENT  RECEIVED* ",SR=3:"*N O RECOUPME NT FORTHCO MING*",1:" ")
  15531   "RTN","CHI GDQ3",137, 0)
  15532    Q
  15533   "RTN","CHI GDQ3",138, 0)
  15534   CITI S ZCL ="" S ZCL= $O(^CHMPAY ("B",CHCLN ,0)) Q:'ZC L
  15535   "RTN","CHI GDQ3",139, 0)
  15536    S CITIVN= "" S:$D(^C HMPAY(ZCL, 0)) CITIVN =$P(^CHMPA Y(ZCL,0)," ^",3)
  15537   "RTN","CHI GDQ3",140, 0)
  15538    Q:'CITIVN   Q:'$D(^C HMVEN(CITI VN,1))  Q: $P(^CHMVEN (CITIVN,1) ,"^",16)'= 1
  15539   "RTN","CHI GDQ3",141, 0)
  15540    S CITICA= "" S:$D(^C HMPAY(ZCL, 1)) CITICA =$P(^CHMPA Y(ZCL,1)," ^",28)
  15541   "RTN","CHI GDQ3",142, 0)
  15542    I CITICA= "" W !,?11 ,"CITI Max imum Reimb ursment Ra te:  ",?46 ,"undeterm ined"
  15543   "RTN","CHI GDQ3",143, 0)
  15544    E  W !,?1 1,"CITI Ma ximum Reim bursment R ate:  ",?4 8,$J($FN(C ITICA,",", 2),10)
  15545   "RTN","CHI GDQ3",144, 0)
  15546    Q
  15547   "RTN","CHI GDQ3",145, 0)
  15548    ;
  15549   "RTN","CHI GDQ3",146, 0)
  15550   MEDI S ZCL ="" S ZCL= $O(^CHMPAY ("B",CHCLN ,0)) Q:'ZC L
  15551   "RTN","CHI GDQ3",147, 0)
  15552    Q:'$D(^CH MPAY(ZCL,7 ))
  15553   "RTN","CHI GDQ3",148, 0)
  15554    S MEDIA=$ P(^CHMPAY( ZCL,7),"^" ,2)
  15555   "RTN","CHI GDQ3",149, 0)
  15556    W !,?26," MEDICAID A mount:  ", ?48,$J($FN (MEDIA,"," ,2),10)
  15557   "RTN","CHI GDQ3",150, 0)
  15558    Q
  15559   "RTN","CHI GDQ3",151, 0)
  15560    ;
  15561   "RTN","CHI GDQ3",152, 0)
  15562   DEDT I $D( VIEWFL) W  !!,"Press  <RETURN> t o Continue , <^> to e xit." R XX X S:XXX="^ " EXFLG=1  W !
  15563   "RTN","CHI GDQ3",153, 0)
  15564    ;E  I $Y> 53 W # D H EAD
  15565   "RTN","CHI GDQ3",154, 0)
  15566    W !
  15567   "RTN","CHI GDQ3",155, 0)
  15568    ;W !!,?5, "OCHAMPUS  Beneficiar y Deductib le ",$P(X3 ,"^",10)," :  ",?45," $",$J($FN( $P(X3,"^", 2),"",2),1 0)
  15569   "RTN","CHI GDQ3",156, 0)
  15570    W !,?6,"C HAMPVA Ben eficiary D eductible  ",$P(X3,"^ ",10),":   ",?48,$J($ FN($P(X3," ^",1),"",2 ),10) W:($ P(X3,"^",7 )'=0)&($P( X3,"^",7)' ="") ?60," (satisfied )"
  15571   "RTN","CHI GDQ3",157, 0)
  15572    ;W !!,?10 ,"OCHAMPUS  Family De ductible " ,$P(X3,"^" ,10),":  " ,?45,"$",$ J($FN($P(X 3,"^",4)," ",2),10)
  15573   "RTN","CHI GDQ3",158, 0)
  15574    W !,?11," CHAMPVA Fa mily Deduc tible ",$P (X3,"^",10 ),":  ",?4 8,$J($FN($ P(X3,"^",3 ),"",2),10 ) W:($P(X3 ,"^",8)'=0 )&($P(X3," ^",8)'="")  ?60,"(sat isfied)"
  15575   "RTN","CHI GDQ3",159, 0)
  15576    ;W !!,?4, "OCHAMPUS  Family Cat astrophic  Cap ",$P(X 3,"^",10), ":  ",?45, "$",$J($FN ($P(X3,"^" ,6),"",2), 10)
  15577   "RTN","CHI GDQ3",160, 0)
  15578    S:$P(X3," ^",5)<0 $P (X3,"^",5) =0
  15579   "RTN","CHI GDQ3",161, 0)
  15580    W !,?5,"C HAMPVA Fam ily Catast rophic Cap  ",$P(X3," ^",10),":   ",?48,$J( $FN($P(X3, "^",5),"", 2),10) W:( $P(X3,"^", 9)'=0)&($P (X3,"^",9) '="") ?60, "(satisfie d)" Q
  15581   "RTN","CHI GDQ3",162, 0)
  15582    ;
  15583   "RTN","CHI GDQ3",163, 0)
  15584   REOPEN K R EOPEN,FLAG  S JJ=CHPP TR,II=JJ,C T=1 D:$D(^ CHMPAY(JJ, 6))
  15585   "RTN","CHI GDQ3",164, 0)
  15586    .F  I $D( ^CHMPAY(JJ ,6)) S II= $P(^(6),"^ ",2) Q:II= ""  S REOP EN(CT,II)= "",JJ=II,C T=CT+1
  15587   "RTN","CHI GDQ3",165, 0)
  15588    I $D(REOP EN) D
  15589   "RTN","CHI GDQ3",166, 0)
  15590    .S CT=0
  15591   "RTN","CHI GDQ3",167, 0)
  15592   R1 .S CT=$ O(REOPEN(C T)) Q:'CT   S RECLM=0
  15593   "RTN","CHI GDQ3",168, 0)
  15594   R2 .S RECL M=$O(REOPE N(CT,RECLM )) G:'RECL M R1
  15595   "RTN","CHI GDQ3",169, 0)
  15596    .G:'$D(^C HMPAY(RECL M,0)) R1
  15597   "RTN","CHI GDQ3",170, 0)
  15598    .S PDICPT =RECLM D P DIS
  15599   "RTN","CHI GDQ3",171, 0)
  15600    .W "       PDI: ",CH PDI_"-"_CH DOC,"  BAT CH: ",CHBA TCH
  15601   "RTN","CHI GDQ3",172, 0)
  15602    .I '$D(FL AG) W ?55, "(Reopens) : " S FLAG =1
  15603   "RTN","CHI GDQ3",173, 0)
  15604    .W ?66,$P (^CHMPAY(R ECLM,0),"^ ",1)
  15605   "RTN","CHI GDQ3",174, 0)
  15606    .I $O(REO PEN(CT,REC LM)) W ! G  R2
  15607   "RTN","CHI GDQ3",175, 0)
  15608    .I $O(REO PEN(CT)) W  ! G R2
  15609   "RTN","CHI GDQ3",176, 0)
  15610    .G R2
  15611   "RTN","CHI GDQ3",177, 0)
  15612    Q
  15613   "RTN","CHI GDQ3",178, 0)
  15614   PDIS S CHP DI="",CHDO C="",CHBAT CH=""
  15615   "RTN","CHI GDQ3",179, 0)
  15616    Q:'$D(PDI CPT)  Q:PD ICPT=""
  15617   "RTN","CHI GDQ3",180, 0)
  15618    S JJ="A", JJ=$O(^CHM PAY(PDICPT ,"PDI",JJ) ,-1)
  15619   "RTN","CHI GDQ3",181, 0)
  15620    I JJ I $D (^CHMPAY(P DICPT,"PDI ",JJ,0)) D
  15621   "RTN","CHI GDQ3",182, 0)
  15622    .S CHPDI= $P(^(0),"^ ",1)
  15623   "RTN","CHI GDQ3",183, 0)
  15624    .I CHPDI  I $D(^CHMI MG(CHPDI," DOC")) S C HDOC=$P(^( "DOC"),"^" ,1)
  15625   "RTN","CHI GDQ3",184, 0)
  15626    .I $D(^CH MIMPB("C", CHPDI)) D
  15627   "RTN","CHI GDQ3",185, 0)
  15628    ..S JJJ=0 ,JJJ=$O(^C HMIMPB("C" ,CHPDI,JJJ ))
  15629   "RTN","CHI GDQ3",186, 0)
  15630    ..I JJJ I  $D(^CHMIM PB(JJJ,0))  S CHBATCH =$P(^(0)," ^",1)
  15631   "RTN","CHI GDQ3",187, 0)
  15632    Q
  15633   "RTN","CHI GDQ3",188, 0)
  15634   REASON S R SPT="" S:$ P(^CHMPAY( CHPPTR,0), "^",13)'=" " RSPT=$P( ^(0),"^",1 3)
  15635   "RTN","CHI GDQ3",189, 0)
  15636    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S CLREAS($ P(^(0),"^" ,1))=$E($P (^(0),"^", 2),1,70)
  15637   "RTN","CHI GDQ3",190, 0)
  15638    G:'$D(^CH MPAY(CHPPT R,4)) RS2  S JJ=0
  15639   "RTN","CHI GDQ3",191, 0)
  15640   RS1 S JJ=$ O(^CHMPAY( CHPPTR,4,J J)) G:'JJ  RS2
  15641   "RTN","CHI GDQ3",192, 0)
  15642    G:'$D(^CH MPAY(CHPPT R,4,JJ,0))  RS1
  15643   "RTN","CHI GDQ3",193, 0)
  15644    S RSPT=$P (^CHMPAY(C HPPTR,4,JJ ,0),"^",1)
  15645   "RTN","CHI GDQ3",194, 0)
  15646    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S CLREAS($ P(^(0),"^" ,1))=$E($P (^(0),"^", 2),1,70)
  15647   "RTN","CHI GDQ3",195, 0)
  15648    G RS1
  15649   "RTN","CHI GDQ3",196, 0)
  15650   RS2 W ! G: '$D(CLREAS ) RS4 W !! ,"Claim Re asons:  "  S JJ=0
  15651   "RTN","CHI GDQ3",197, 0)
  15652   RS3 S JJ=$ O(CLREAS(J J)) G:JJ=" " RS4
  15653   "RTN","CHI GDQ3",198, 0)
  15654    W ?20,JJ, " - ",$E(C LREAS(JJ), 1,53),! G  RS3
  15655   "RTN","CHI GDQ3",199, 0)
  15656   RS4 Q:'$D( LNREAS)  S  JJ=0
  15657   "RTN","CHI GDQ3",200, 0)
  15658   RS5 S JJ=$ O(LNREAS(J J)) G:JJ=" " RS6
  15659   "RTN","CHI GDQ3",201, 0)
  15660    G:'$D(^CH MDIC(74100 2.22,"B",J J)) RS3
  15661   "RTN","CHI GDQ3",202, 0)
  15662    S RSPT=0, RSPT=$O(^C HMDIC(7410 02.22,"B", JJ,RSPT))
  15663   "RTN","CHI GDQ3",203, 0)
  15664    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S LIREAS(J J)=$E($P(^ (0),"^",2) ,1,70)
  15665   "RTN","CHI GDQ3",204, 0)
  15666    G RS5
  15667   "RTN","CHI GDQ3",205, 0)
  15668   RS6 Q:'$D( LIREAS)  W  !,"Line I tem Reason s:  " S JJ =0
  15669   "RTN","CHI GDQ3",206, 0)
  15670   RS7 S JJ=$ O(LIREAS(J J)) Q:JJ=" "
  15671   "RTN","CHI GDQ3",207, 0)
  15672    W ?20,JJ, " - ",$E(L IREAS(JJ), 1,53),! G  RS7
  15673   "RTN","CHI GDQ3",208, 0)
  15674   CHECKS S J =0
  15675   "RTN","CHI GDQ3",209, 0)
  15676   CHK1 S J=$ O(^CHMPAY( CHPPTR,102 ,J)) G:'J  CHK2
  15677   "RTN","CHI GDQ3",210, 0)
  15678    Q:'$D(^CH MPAY(CHPPT R,102,J,0) )
  15679   "RTN","CHI GDQ3",211, 0)
  15680    S CHECKS( $P(^(0),"^ ",1))=""
  15681   "RTN","CHI GDQ3",212, 0)
  15682    S:$P(^(0) ,"^",4)=1  CHECKS($P( ^(0),"^",1 ))=" (Ret) "
  15683   "RTN","CHI GDQ3",213, 0)
  15684    G CHK1
  15685   "RTN","CHI GDQ3",214, 0)
  15686   CHK2 Q:'$D (CHECKS)   S CHKNM=""  S CNT=1,T AB=20 W !! ,"Check #' s:"
  15687   "RTN","CHI GDQ3",215, 0)
  15688   CHHK3 S CH KNM=$O(CHE CKS(CHKNM) ) Q:CHKNM= ""
  15689   "RTN","CHI GDQ3",216, 0)
  15690    I CNT=4 S  CNT=1,TAB =20 W !
  15691   "RTN","CHI GDQ3",217, 0)
  15692    W ?TAB,CH KNM,CHECKS (CHKNM)
  15693   "RTN","CHI GDQ3",218, 0)
  15694    S TAB=TAB +17,CNT=CN T+1
  15695   "RTN","CHI GDQ3",219, 0)
  15696    G CHHK3
  15697   "RTN","CHI GDQ3",220, 0)
  15698   TIME S CHD T=$E(DT,4, 7),X=$P($H ,",",2),H= X\3600,M=X #3600\60
  15699   "RTN","CHI GDQ3",221, 0)
  15700    S:M<10 M= "0"_M S CH TIME=H_M Q
  15701   "RTN","CHI GDQ3",222, 0)
  15702   QUEUE I $D (VIEWFL),J =1 W !!,"P ress <RETU RN> to Con tinue, <^>  to exit."  R XXX S:X XX="^" EXF LG=1 W !
  15703   "RTN","CHI GDQ3",223, 0)
  15704    ;E  I (($ Y>52)&(J=1 )) W # D H EAD
  15705   "RTN","CHI GDQ3",224, 0)
  15706    S CHTIL=" Actions fo r Claim:"
  15707   "RTN","CHI GDQ3",225, 0)
  15708    W:J=1 !!! ,CHTIL,!
  15709   "RTN","CHI GDQ3",226, 0)
  15710    W:J#2=1 ! ,?3,J,") " ,X2 Q:J#2= 1
  15711   "RTN","CHI GDQ3",227, 0)
  15712    W:J#2'=1  ?43,J,") " ,X2
  15713   "RTN","CHI GDQ3",228, 0)
  15714    I '$D(VIE WFL),$Y>59  W # D HEA D W !!!,?( 40-($L(CHT IL)\2)),CH TIL,!
  15715   "RTN","CHI GDQ3",229, 0)
  15716    Q
  15717   "RTN","CHI GDQ30")
  15718   0^30^B9300 5718
  15719   "RTN","CHI GDQ30",1,0 )
  15720   CHIGDQ30 ; DEH/DEN;CH AMVPA POST -PROC CLAI M REPORT P RINT;Feb 0 6, 2019@10 :00:07
  15721   "RTN","CHI GDQ30",2,0 )
  15722    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  15723   "RTN","CHI GDQ30",3,0 )
  15724    ;CPTS #10 763 BY CAM
  15725   "RTN","CHI GDQ30",4,0 )
  15726    ;COPIED F ROM CHMF35 1P
  15727   "RTN","CHI GDQ30",5,0 )
  15728    ; CPE001- 004 WTC 5/ 17/17
  15729   "RTN","CHI GDQ30",6,0 )
  15730   ENTER ;
  15731   "RTN","CHI GDQ30",7,0 )
  15732    K ^CHMZHO LD("NO B X -REF"),VIE WFL S EXFL G=0
  15733   "RTN","CHI GDQ30",8,0 )
  15734   V1 I $D(VI EWFL) X CH RESET S EX FLG=0
  15735   "RTN","CHI GDQ30",9,0 )
  15736    S CHCLN=" ",CHPG=0 S  %H=$H D Y X^%DTC S C HDATE=$P(Y ,"@",1)
  15737   "RTN","CHI GDQ30",10, 0)
  15738    S IGCNT=0
  15739   "RTN","CHI GDQ30",11, 0)
  15740   L0 W:'$D(V IEWFL) # S  IGCNT=$O( ^TMP($J,"C L",IGCNT))  G END:IGC NT=""
  15741   "RTN","CHI GDQ30",12, 0)
  15742    S CHCLN=" "
  15743   "RTN","CHI GDQ30",13, 0)
  15744   L1 S CHCLN =$O(^TMP($ J,"CL",IGC NT,CHCLN))  G L0:CHCL N=""
  15745   "RTN","CHI GDQ30",14, 0)
  15746    S CHECK=" ",CHECK=$O (^CHNVPAY( "B",CHCLN, CHECK)) I  CHECK="" S  ^CHMZHOLD ("NO B X-R EF",CHCLN) ="" G L1
  15747   "RTN","CHI GDQ30",15, 0)
  15748    K LIREAS, LNREAS,CLR EAS,RESON, CHECKS
  15749   "RTN","CHI GDQ30",16, 0)
  15750    D HEAD S  X=^TMP($J, "CL",IGCNT ,CHCLN)
  15751   "RTN","CHI GDQ30",17, 0)
  15752    I $P(X,"^ ",3)="Inpa tient" D ^ CHRC351Q G  L1
  15753   "RTN","CHI GDQ30",18, 0)
  15754    S X4="",J =0 F K=0:0  S J=$O(^T MP($J,"PDI ",IGCNT,CH CLN,J)) Q: J'?1N.N  S :X4'="" X4 =X4_"^"_^T MP($J,"PDI ",IGCNT,CH CLN,J) S:X 4="" X4=^T MP($J,"PDI ",IGCNT,CH CLN,J)
  15755   "RTN","CHI GDQ30",19, 0)
  15756    D TOP S J =0 D MIDHE D Q:EXFLG= 1  K CODES
  15757   "RTN","CHI GDQ30",20, 0)
  15758   L3 S J=$O( ^TMP($J,"M P",IGCNT,C HCLN,J)) G  L5:'J
  15759   "RTN","CHI GDQ30",21, 0)
  15760    S X1=^TMP ($J,"MP",I GCNT,CHCLN ,J) D SORT  Q:EXFLG=1   G L3
  15761   "RTN","CHI GDQ30",22, 0)
  15762   L5 D MID D  BOT Q:EXF LG=1
  15763   "RTN","CHI GDQ30",23, 0)
  15764   L6 G:'$D(^ TMP($J,"DE D",IGCNT,C HCLN)) L7
  15765   "RTN","CHI GDQ30",24, 0)
  15766    S X3=^TMP ($J,"DED", IGCNT,CHCL N) D DEDT  S J=0
  15767   "RTN","CHI GDQ30",25, 0)
  15768    ;D MULTI
  15769   "RTN","CHI GDQ30",26, 0)
  15770   L7 S J=$O( ^TMP($J,"Q UE",IGCNT, CHCLN,J))  G:'J L8
  15771   "RTN","CHI GDQ30",27, 0)
  15772    S X2=^TMP ($J,"QUE", IGCNT,CHCL N,J) D QUE UE Q:EXFLG =1  G L7
  15773   "RTN","CHI GDQ30",28, 0)
  15774   L8 D REASO N,CHECKS G  L1
  15775   "RTN","CHI GDQ30",29, 0)
  15776   END K CHCL N,CHPG,CHD ATE,X,X1,X 2,Y,J,CHTI ME Q
  15777   "RTN","CHI GDQ30",30, 0)
  15778   MULTI S ZC L="" S ZCL =$O(^CHNVP AY("B",CHC LN,0)) Q:' ZCL
  15779   "RTN","CHI GDQ30",31, 0)
  15780    Q:'$D(^CH NVPAY(ZCL, 4))  S ZI= "",ZI=$O(^ CHNVPAY(ZC L,4,0)) Q: 'ZI
  15781   "RTN","CHI GDQ30",32, 0)
  15782    Q:'$O(^CH NVPAY(ZCL, 4,ZI))  S  ZI="",ZHI= 0
  15783   "RTN","CHI GDQ30",33, 0)
  15784    F ZI=0:0  S ZI=$O(^T MP($J,"QUE ",IGCNT,CH CLN,ZI)) Q :'ZI  S ZH I=ZI
  15785   "RTN","CHI GDQ30",34, 0)
  15786    S ZI=ZHI+ 1,^TMP($J, "QUE",IGCN T,CHCLN,ZI )="Multipl e Reas" Q
  15787   "RTN","CHI GDQ30",35, 0)
  15788   HEAD S CHP G=CHPG+1
  15789   "RTN","CHI GDQ30",36, 0)
  15790    W "DUZ: " ,DUZ,?34," CHAMPVA Ce nter",?71, "Page: ",C HPG
  15791   "RTN","CHI GDQ30",37, 0)
  15792    W !,"Date : ",CHDATE ,?27,"Post -Processin g Claim Re port"
  15793   "RTN","CHI GDQ30",38, 0)
  15794    W !,"Time : " D TIME  W CHTIME  Q
  15795   "RTN","CHI GDQ30",39, 0)
  15796   TOP ;W !!! ,"      PD I: " S J=1  F K=0:0 Q :X4=""  W: J>1 ! W ?1 4,$P(X4,"^ ",1) S J=J +1,X4=$P(X 4,"^",2,99 9)
  15797   "RTN","CHI GDQ30",40, 0)
  15798    ;
  15799   "RTN","CHI GDQ30",41, 0)
  15800    S CHPVPTR ="",CHPTID ="",CHPVAC ="",CHPIM= ""
  15801   "RTN","CHI GDQ30",42, 0)
  15802    S CHPPTR= "",CHPPTR= $O(^CHNVPA Y("B",CHCL N,CHPPTR))
  15803   "RTN","CHI GDQ30",43, 0)
  15804    S CHPVPTR =$P(^CHNVP AY(CHPPTR, 0),U,3)
  15805   "RTN","CHI GDQ30",44, 0)
  15806    I CHPVPTR  I $D(^CHM VEN(CHPVPT R,0)) D
  15807   "RTN","CHI GDQ30",45, 0)
  15808    .S CHPTID =$P(^CHMVE N(CHPVPTR, 0),U,3)
  15809   "RTN","CHI GDQ30",46, 0)
  15810    .S CHPVAC =$P(^CHMVE N(CHPVPTR, 0),U,23)
  15811   "RTN","CHI GDQ30",47, 0)
  15812    .S CHPIM= "" S:$D(^C HMVEN(CHPV PTR,14)) C HPIM=$P(^C HMVEN(CHPV PTR,14),U, 1)
  15813   "RTN","CHI GDQ30",48, 0)
  15814    S PDICPT= CHPPTR D P DIS
  15815   "RTN","CHI GDQ30",49, 0)
  15816    W !!,"       PDI: ", CHPDI_"-"_ CHDOC,"  B ATCH: ",CH BATCH
  15817   "RTN","CHI GDQ30",50, 0)
  15818    W ?57,"Cl aim #: ",C HCLN
  15819   "RTN","CHI GDQ30",51, 0)
  15820    I $D(^CHN VPAY(CHPPT R,6)) W !  D REOPEN
  15821   "RTN","CHI GDQ30",52, 0)
  15822    ;
  15823   "RTN","CHI GDQ30",53, 0)
  15824    ;W !,?7," Batch:  "
  15825   "RTN","CHI GDQ30",54, 0)
  15826    W !,"       EIN: ",C HPTID_"-"_ CHPVAC_"-" _CHPIM
  15827   "RTN","CHI GDQ30",55, 0)
  15828    W ?58,"St atus: ",$P (X,"^",1)
  15829   "RTN","CHI GDQ30",56, 0)
  15830    W !,"   V endor: ",$ P(X,"^",2) ,?60,"Type : ",$P(X," ^",3)
  15831   "RTN","CHI GDQ30",57, 0)
  15832    W !,"Pay  Prov?: ",$ P(X,"^",4) ,?50,"Ser/ Admis Date : ",$P(X," ^",5)
  15833   "RTN","CHI GDQ30",58, 0)
  15834    S CHCMPDT ="" I $P(^ CHNVPAY(CH PPTR,0),"^ ",10)'=""  D
  15835   "RTN","CHI GDQ30",59, 0)
  15836    .S Y=$P(^ CHNVPAY(CH PPTR,0),"^ ",10) X ^D D("DD") S  CHCMPDT=$P (Y,"@",1)
  15837   "RTN","CHI GDQ30",60, 0)
  15838    W !,"  Sp onsor: ",$ P(X,"^",6) ,?54,"Comp . Date: ", CHCMPDT
  15839   "RTN","CHI GDQ30",61, 0)
  15840    W !,"      Bene: ",$ P(X,"^",7) ,?61,"POS:  ",$P(X,"^ ",20)
  15841   "RTN","CHI GDQ30",62, 0)
  15842    W !," Ben e Sex: ",$ P(X,"^",21 ),?15,"Ben e DOB: ",$ P(X,"^",22 )
  15843   "RTN","CHI GDQ30",63, 0)
  15844    W ?58,"PL  ZIP: ",$P ($G(^CHMPA Y(CHPPTR," VEN-II")), U,15) ; WT C - DISPLA Y PL ZIP
  15845   "RTN","CHI GDQ30",64, 0)
  15846    I $P(X,"^ ",19)'=""  W !,?4,"Me dicaid: ", $P(X,"^",1 9)
  15847   "RTN","CHI GDQ30",65, 0)
  15848    W !! Q
  15849   "RTN","CHI GDQ30",66, 0)
  15850   MIDHED I $ D(VIEWFL)  W !!,"Pres s <RETURN>  to contin ue, <^> to  exit." R  XXX S:XXX= "^" EXFLG= 1 W !
  15851   "RTN","CHI GDQ30",67, 0)
  15852    W !,"DX's ",?7,"PX's /NDC's",?2 2,"Unt",?2 7,"Chg/Unt ",?38,"AA/ Unt"
  15853   "RTN","CHI GDQ30",68, 0)
  15854    W ?49,"To tal Chg",? 60,"Total  AA",?71,"R sl",?76,"R eas"
  15855   "RTN","CHI GDQ30",69, 0)
  15856    W !,"---- -- ------- ------  -- -  ------- --  ------ ---  ----- ----  ---- -----  ---   ----" Q
  15857   "RTN","CHI GDQ30",70, 0)
  15858   MID S SORT =""
  15859   "RTN","CHI GDQ30",71, 0)
  15860   MID1 S SOR T=$O(CODES (SORT)) Q: SORT=""  S  CODE=""
  15861   "RTN","CHI GDQ30",72, 0)
  15862   MID2 S COD E=$O(CODES (SORT,CODE )) G:CODE= "" MID1 S  AMT1=""
  15863   "RTN","CHI GDQ30",73, 0)
  15864   MID3 S AMT 1=$O(CODES (SORT,CODE ,AMT1)) G: AMT1="" MI D2 S AMT2= ""
  15865   "RTN","CHI GDQ30",74, 0)
  15866   MID4 S AMT 2=$O(CODES (SORT,CODE ,AMT1,AMT2 )) G:AMT2= "" MID3 S  RESON=""
  15867   "RTN","CHI GDQ30",75, 0)
  15868   MID5 S RES ON=$O(CODE S(SORT,COD E,AMT1,AMT 2,RESON))  G:RESON=""  MID4
  15869   "RTN","CHI GDQ30",76, 0)
  15870    S X1=CODE S(SORT,COD E,AMT1,AMT 2,RESON)
  15871   "RTN","CHI GDQ30",77, 0)
  15872    I $P(X1," ^",2)'=""  W !,$P(X1, "^",2) G M ID6
  15873   "RTN","CHI GDQ30",78, 0)
  15874    I $P(X1," ^",1)'=""  W !,?7,$P( X1,"^",1)  G MID6
  15875   "RTN","CHI GDQ30",79, 0)
  15876    I $P(X1," ^",3)'=""  W !,?7,$P( X1,"^",3)
  15877   "RTN","CHI GDQ30",80, 0)
  15878   MID6 W ?22 ,$J($P(X1, "^",10),3)
  15879   "RTN","CHI GDQ30",81, 0)
  15880    W:$P(X1," ^",4)'["A"  ?27,$J($F N($P(X1,"^ ",4),",",2 ),9)
  15881   "RTN","CHI GDQ30",82, 0)
  15882    W:$P(X1," ^",4)["A"  ?27,"$",$J ($FN($P(X1 ,"^",4),", ",2),9)_"A "
  15883   "RTN","CHI GDQ30",83, 0)
  15884    I $P(X1," ^",5)="" I  ($P(X,"^" ,3)="Inpat ient")!($P (X,"^",3)= "Pharmacy" ) W ?38,"u ndtr."
  15885   "RTN","CHI GDQ30",84, 0)
  15886    I $P(X1," ^",5)="" I  ($P(X,"^" ,3)'="Inpa tient")&($ P(X,"^",3) '="Pharmac y") W ?38, "  "
  15887   "RTN","CHI GDQ30",85, 0)
  15888    I $P(X1," ^",5)'=""  W ?38,$J($ FN($P(X1," ^",5),",", 2),9)
  15889   "RTN","CHI GDQ30",86, 0)
  15890    S TOTCHG= ($P(X1,"^" ,10)*$P(X1 ,"^",4))
  15891   "RTN","CHI GDQ30",87, 0)
  15892    W ?49,$J( $FN(TOTCHG ,",",2),9)
  15893   "RTN","CHI GDQ30",88, 0)
  15894    S TOTAA=( $P(X1,"^", 10)*$P(X1, "^",5))
  15895   "RTN","CHI GDQ30",89, 0)
  15896    W ?60,$J( $FN(TOTAA, ",",2),9)
  15897   "RTN","CHI GDQ30",90, 0)
  15898    I $P(X1," ^",6)="" W  ?71,"und"
  15899   "RTN","CHI GDQ30",91, 0)
  15900    E  W ?71, $P(X1,"^", 6)
  15901   "RTN","CHI GDQ30",92, 0)
  15902    W:$P(X1," ^",8)'=""  ?76,$J($P( X1,"^",8), 4)
  15903   "RTN","CHI GDQ30",93, 0)
  15904    S:$P(X1," ^",8)'=""  LNREAS($P( X1,"^",8)) =""
  15905   "RTN","CHI GDQ30",94, 0)
  15906    G MID5
  15907   "RTN","CHI GDQ30",95, 0)
  15908   SORT S COD E="",SORT= ""
  15909   "RTN","CHI GDQ30",96, 0)
  15910    S RESON=$ P(X1,"^",8 ) S:RESON= "" RESON="  "
  15911   "RTN","CHI GDQ30",97, 0)
  15912    S AMT1=$P (X1,"^",4) ,AMT2=$P(X 1,"^",5)
  15913   "RTN","CHI GDQ30",98, 0)
  15914    S:AMT1=""  AMT1=0 S: AMT2="" AM T2=0
  15915   "RTN","CHI GDQ30",99, 0)
  15916    I $P(X1," ^",1)'=""  S CODE=$P( X1,"^",1), SORT=3 G S RT1
  15917   "RTN","CHI GDQ30",100 ,0)
  15918    I $P(X1," ^",2)'=""  S CODE=$P( X1,"^",2), AMT1=0,SOR T=1,AMT2=0  G SRT1
  15919   "RTN","CHI GDQ30",101 ,0)
  15920    I $P(X1," ^",3)'=""  S CODE=$P( X1,"^",3), SORT=2
  15921   "RTN","CHI GDQ30",102 ,0)
  15922   SRT1 Q:COD E=""
  15923   "RTN","CHI GDQ30",103 ,0)
  15924    I '$D(COD ES(SORT,CO DE,AMT1,AM T2,RESON))  S CODES(S ORT,CODE,A MT1,AMT2,R ESON)=X1_" ^^"_1 Q
  15925   "RTN","CHI GDQ30",104 ,0)
  15926    S $P(CODE S(SORT,COD E,AMT1,AMT 2,RESON)," ^",10)=$P( CODES(SORT ,CODE,AMT1 ,AMT2,RESO N),"^",10) +1
  15927   "RTN","CHI GDQ30",105 ,0)
  15928    Q
  15929   "RTN","CHI GDQ30",106 ,0)
  15930   BOT I $D(V IEWFL) W ! !,"Press < RETURN> to  Continue,  <^> to ex it." R XXX  S:XXX="^"  EXFLG=1 W  !
  15931   "RTN","CHI GDQ30",107 ,0)
  15932    ;E  I $Y> 52 W # S H X=X D HEAD  S X=HX
  15933   "RTN","CHI GDQ30",108 ,0)
  15934    I $P(X,"^ ",8)="" W  !!,?21,"To tal Charge s Billed:   ",?46,"un determined "
  15935   "RTN","CHI GDQ30",109 ,0)
  15936    E  D
  15937   "RTN","CHI GDQ30",110 ,0)
  15938    .S ALFL=" " I $P(X," ^",3)="Inp atient" D
  15939   "RTN","CHI GDQ30",111 ,0)
  15940    ..S CHCLN P=$O(^CHNV PAY("B",CH CLN,0)) Q: 'CHCLNP
  15941   "RTN","CHI GDQ30",112 ,0)
  15942    ..I $D(^C HNVPAY(CHC LNP,"INP") ) S:$P(^(" INP"),"^", 10)'="" AL FL="A"
  15943   "RTN","CHI GDQ30",113 ,0)
  15944    .W !!,?21 ,"Total Ch arges Bill ed:  ",?48 ,$J($FN($P (X,"^",8), ",",2),10) _ALFL
  15945   "RTN","CHI GDQ30",114 ,0)
  15946    I $P(X,"^ ",9)="" W  !,?14,"Cal culated Al lowable Am ount:  ",? 46,"undete rmined"
  15947   "RTN","CHI GDQ30",115 ,0)
  15948    E  W !,?1 4,"Calcula ted Allowa ble Amount :  ",?48,$ J($FN($P(X ,"^",9),", ",2),10)
  15949   "RTN","CHI GDQ30",116 ,0)
  15950    D CITI
  15951   "RTN","CHI GDQ30",117 ,0)
  15952    D MEDI
  15953   "RTN","CHI GDQ30",118 ,0)
  15954    I $P(X,"^ ",10)="" W  !,?13,"Am ount Appli ed to Dedu ctible:  " ,?46,"unde termined"
  15955   "RTN","CHI GDQ30",119 ,0)
  15956    E  W !,?1 3,"Amount  Applied to  Deductibl e:  ",?48, $J($FN($P( X,"^",10), ",",2),10)
  15957   "RTN","CHI GDQ30",120 ,0)
  15958    I $P(X,"^ ",11)="" W  !,?11,"Co st Share C redited to  Cat Cap:   ",?46,"un determined "
  15959   "RTN","CHI GDQ30",121 ,0)
  15960    E  W !,?1 1,"Cost Sh are Credit ed to Cat  Cap:  ",?4 8,$J($FN($ P(X,"^",11 ),",",2),1 0)
  15961   "RTN","CHI GDQ30",122 ,0)
  15962    I ($P(X," ^",18)=1)& ($P(X,"^", 17)="") W  !,?16,"Amo unt applie d to Cat C ap:",?46," undetermin ed"
  15963   "RTN","CHI GDQ30",123 ,0)
  15964    E  I ($P( X,"^",18)= 1)&($P(X," ^",17)'="" ) W !,?16, "Amount ap plied to C at Cap:",? 48,$J($FN( $P(X,"^",1 7),",",2), 10)
  15965   "RTN","CHI GDQ30",124 ,0)
  15966    I $P(X,"^ ",12)="" W  !,?11,"Am ount Paid  by Other I nsurance:   ",?55,"N/ A"
  15967   "RTN","CHI GDQ30",125 ,0)
  15968    E  W !,?1 1,"Amount  Paid by Ot her Insura nce:  ",?4 8,$J($FN($ P(X,"^",12 ),",",2),1 0)
  15969   "RTN","CHI GDQ30",126 ,0)
  15970    W !,?5,"A mount Paid  by Benefi ciary to V endor:",?4 8,$J($FN($ P(X,"^",14 ),",",2),1 0)
  15971   "RTN","CHI GDQ30",127 ,0)
  15972    I $P(X,"^ ",13)="" W  !!,?9,"To tal Amount  to be PAI D on claim :",?46,"un determined "
  15973   "RTN","CHI GDQ30",128 ,0)
  15974    E  W !!,? 9,"Total A mount to b e PAID on  claim:  ", ?48,$J($FN ($P(X,"^", 13),",",2) ,10)
  15975   "RTN","CHI GDQ30",129 ,0)
  15976    I $P(X,"^ ",15)="" W  !,?20,"Am ount PAID  to Vendor: ",?46,"und etermined"
  15977   "RTN","CHI GDQ30",130 ,0)
  15978    E  W !,?2 0,"Amount  PAID to Ve ndor:",?48 ,$J($FN($P (X,"^",15) ,",",2),10 )
  15979   "RTN","CHI GDQ30",131 ,0)
  15980    I $P(X,"^ ",16)="" W  !,?15,"Am ount PAID  to Benefic iary:",?46 ,"undeterm ined"
  15981   "RTN","CHI GDQ30",132 ,0)
  15982    E  W !,?1 5,"Amount  PAID to Be neficiary: ",?48,$J($ FN($P(X,"^ ",16),",", 2),10)
  15983   "RTN","CHI GDQ30",133 ,0)
  15984    D
  15985   "RTN","CHI GDQ30",134 ,0)
  15986    .S CHCLNP =$O(^CHNVP AY("B",CHC LN,0)) Q:' CHCLNP
  15987   "RTN","CHI GDQ30",135 ,0)
  15988    .Q:'$D(^C HNVPAY(CHC LNP,5))  Q :$P(^(5)," ^",1)=""   S SR=$P(^( 5),"^",1)
  15989   "RTN","CHI GDQ30",136 ,0)
  15990    .W !,?20, $S(SR=0:"* PENDING RE COUPMENT*" ,SR=1:"*PA RTIAL RECO UPMENT REC EIVED*",SR =2:"*FULL  RECOUPMENT  RECEIVED* ",SR=3:"*N O RECOUPME NT FORTHCO MING*",1:" ")
  15991   "RTN","CHI GDQ30",137 ,0)
  15992    Q
  15993   "RTN","CHI GDQ30",138 ,0)
  15994   CITI S ZCL ="" S ZCL= $O(^CHNVPA Y("B",CHCL N,0)) Q:'Z CL
  15995   "RTN","CHI GDQ30",139 ,0)
  15996    S CITIVN= "" S:$D(^C HNVPAY(ZCL ,0)) CITIV N=$P(^CHNV PAY(ZCL,0) ,"^",3)
  15997   "RTN","CHI GDQ30",140 ,0)
  15998    Q:'CITIVN   Q:'$D(^C HMVEN(CITI VN,1))  Q: $P(^CHMVEN (CITIVN,1) ,"^",16)'= 1
  15999   "RTN","CHI GDQ30",141 ,0)
  16000    S CITICA= "" S:$D(^C HNVPAY(ZCL ,1)) CITIC A=$P(^CHNV PAY(ZCL,1) ,"^",28)
  16001   "RTN","CHI GDQ30",142 ,0)
  16002    I CITICA= "" W !,?11 ,"CITI Max imum Reimb ursment Ra te:  ",?46 ,"undeterm ined"
  16003   "RTN","CHI GDQ30",143 ,0)
  16004    E  W !,?1 1,"CITI Ma ximum Reim bursment R ate:  ",?4 8,$J($FN(C ITICA,",", 2),10)
  16005   "RTN","CHI GDQ30",144 ,0)
  16006    Q
  16007   "RTN","CHI GDQ30",145 ,0)
  16008    ;
  16009   "RTN","CHI GDQ30",146 ,0)
  16010   MEDI S ZCL ="" S ZCL= $O(^CHNVPA Y("B",CHCL N,0)) Q:'Z CL
  16011   "RTN","CHI GDQ30",147 ,0)
  16012    Q:'$D(^CH NVPAY(ZCL, 7))
  16013   "RTN","CHI GDQ30",148 ,0)
  16014    S MEDIA=$ P(^CHNVPAY (ZCL,7),"^ ",2)
  16015   "RTN","CHI GDQ30",149 ,0)
  16016    W !,?26," MEDICAID A mount:  ", ?48,$J($FN (MEDIA,"," ,2),10)
  16017   "RTN","CHI GDQ30",150 ,0)
  16018    Q
  16019   "RTN","CHI GDQ30",151 ,0)
  16020    ;
  16021   "RTN","CHI GDQ30",152 ,0)
  16022   DEDT I $D( VIEWFL) W  !!,"Press  <RETURN> t o Continue , <^> to e xit." R XX X S:XXX="^ " EXFLG=1  W !
  16023   "RTN","CHI GDQ30",153 ,0)
  16024    ;E  I $Y> 53 W # D H EAD
  16025   "RTN","CHI GDQ30",154 ,0)
  16026    W !
  16027   "RTN","CHI GDQ30",155 ,0)
  16028    ;W !!,?5, "OCHAMPUS  Beneficiar y Deductib le ",$P(X3 ,"^",10)," :  ",?45," $",$J($FN( $P(X3,"^", 2),"",2),1 0)
  16029   "RTN","CHI GDQ30",156 ,0)
  16030    W !,?6,"C HAMPVA Ben eficiary D eductible  ",$P(X3,"^ ",10),":   ",?48,$J($ FN($P(X3," ^",1),"",2 ),10) W:($ P(X3,"^",7 )'=0)&($P( X3,"^",7)' ="") ?60," (satisfied )"
  16031   "RTN","CHI GDQ30",157 ,0)
  16032    ;W !!,?10 ,"OCHAMPUS  Family De ductible " ,$P(X3,"^" ,10),":  " ,?45,"$",$ J($FN($P(X 3,"^",4)," ",2),10)
  16033   "RTN","CHI GDQ30",158 ,0)
  16034    W !,?11," CHAMPVA Fa mily Deduc tible ",$P (X3,"^",10 ),":  ",?4 8,$J($FN($ P(X3,"^",3 ),"",2),10 ) W:($P(X3 ,"^",8)'=0 )&($P(X3," ^",8)'="")  ?60,"(sat isfied)"
  16035   "RTN","CHI GDQ30",159 ,0)
  16036    ;W !!,?4, "OCHAMPUS  Family Cat astrophic  Cap ",$P(X 3,"^",10), ":  ",?45, "$",$J($FN ($P(X3,"^" ,6),"",2), 10)
  16037   "RTN","CHI GDQ30",160 ,0)
  16038    S:$P(X3," ^",5)<0 $P (X3,"^",5) =0
  16039   "RTN","CHI GDQ30",161 ,0)
  16040    W !,?5,"C HAMPVA Fam ily Catast rophic Cap  ",$P(X3," ^",10),":   ",?48,$J( $FN($P(X3, "^",5),"", 2),10) W:( $P(X3,"^", 9)'=0)&($P (X3,"^",9) '="") ?60, "(satisfie d)" Q
  16041   "RTN","CHI GDQ30",162 ,0)
  16042    ;
  16043   "RTN","CHI GDQ30",163 ,0)
  16044   REOPEN K R EOPEN,FLAG  S JJ=CHPP TR,II=JJ,C T=1 D:$D(^ CHNVPAY(JJ ,6))
  16045   "RTN","CHI GDQ30",164 ,0)
  16046    .F  I $D( ^CHNVPAY(J J,6)) S II =$P(^(6)," ^",2) Q:II =""  S REO PEN(CT,II) ="",JJ=II, CT=CT+1
  16047   "RTN","CHI GDQ30",165 ,0)
  16048    I $D(REOP EN) D
  16049   "RTN","CHI GDQ30",166 ,0)
  16050    .S CT=0
  16051   "RTN","CHI GDQ30",167 ,0)
  16052   R1 .S CT=$ O(REOPEN(C T)) Q:'CT   S RECLM=0
  16053   "RTN","CHI GDQ30",168 ,0)
  16054   R2 .S RECL M=$O(REOPE N(CT,RECLM )) G:'RECL M R1
  16055   "RTN","CHI GDQ30",169 ,0)
  16056    .G:'$D(^C HNVPAY(REC LM,0)) R1
  16057   "RTN","CHI GDQ30",170 ,0)
  16058    .S PDICPT =RECLM D P DIS
  16059   "RTN","CHI GDQ30",171 ,0)
  16060    .W "       PDI: ",CH PDI_"-"_CH DOC,"  BAT CH: ",CHBA TCH
  16061   "RTN","CHI GDQ30",172 ,0)
  16062    .I '$D(FL AG) W ?55, "(Reopens) : " S FLAG =1
  16063   "RTN","CHI GDQ30",173 ,0)
  16064    .W ?66,$P (^CHNVPAY( RECLM,0)," ^",1)
  16065   "RTN","CHI GDQ30",174 ,0)
  16066    .I $O(REO PEN(CT,REC LM)) W ! G  R2
  16067   "RTN","CHI GDQ30",175 ,0)
  16068    .I $O(REO PEN(CT)) W  ! G R2
  16069   "RTN","CHI GDQ30",176 ,0)
  16070    .G R2
  16071   "RTN","CHI GDQ30",177 ,0)
  16072    Q
  16073   "RTN","CHI GDQ30",178 ,0)
  16074   PDIS S CHP DI="",CHDO C="",CHBAT CH=""
  16075   "RTN","CHI GDQ30",179 ,0)
  16076    Q:'$D(PDI CPT)  Q:PD ICPT=""
  16077   "RTN","CHI GDQ30",180 ,0)
  16078    S JJ="A", JJ=$O(^CHN VPAY(PDICP T,"PDI",JJ ),-1)
  16079   "RTN","CHI GDQ30",181 ,0)
  16080    I JJ I $D (^CHNVPAY( PDICPT,"PD I",JJ,0))  D
  16081   "RTN","CHI GDQ30",182 ,0)
  16082    .S CHPDI= $P(^(0),"^ ",1)
  16083   "RTN","CHI GDQ30",183 ,0)
  16084    .I CHPDI  I $D(^CHMI MG(CHPDI," DOC")) S C HDOC=$P(^( "DOC"),"^" ,1)
  16085   "RTN","CHI GDQ30",184 ,0)
  16086    .I $D(^CH MIMPB("C", CHPDI)) D
  16087   "RTN","CHI GDQ30",185 ,0)
  16088    ..S JJJ=0 ,JJJ=$O(^C HMIMPB("C" ,CHPDI,JJJ ))
  16089   "RTN","CHI GDQ30",186 ,0)
  16090    ..I JJJ I  $D(^CHMIM PB(JJJ,0))  S CHBATCH =$P(^(0)," ^",1)
  16091   "RTN","CHI GDQ30",187 ,0)
  16092    Q
  16093   "RTN","CHI GDQ30",188 ,0)
  16094   REASON S R SPT="" S:$ P(^CHNVPAY (CHPPTR,0) ,"^",13)'= "" RSPT=$P (^(0),"^", 13)
  16095   "RTN","CHI GDQ30",189 ,0)
  16096    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S CLREAS($ P(^(0),"^" ,1))=$E($P (^(0),"^", 2),1,70)
  16097   "RTN","CHI GDQ30",190 ,0)
  16098    G:'$D(^CH NVPAY(CHPP TR,4)) RS2  S JJ=0
  16099   "RTN","CHI GDQ30",191 ,0)
  16100   RS1 S JJ=$ O(^CHNVPAY (CHPPTR,4, JJ)) G:'JJ  RS2
  16101   "RTN","CHI GDQ30",192 ,0)
  16102    G:'$D(^CH NVPAY(CHPP TR,4,JJ,0) ) RS1
  16103   "RTN","CHI GDQ30",193 ,0)
  16104    S RSPT=$P (^CHNVPAY( CHPPTR,4,J J,0),"^",1 )
  16105   "RTN","CHI GDQ30",194 ,0)
  16106    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S CLREAS($ P(^(0),"^" ,1))=$E($P (^(0),"^", 2),1,70)
  16107   "RTN","CHI GDQ30",195 ,0)
  16108    G RS1
  16109   "RTN","CHI GDQ30",196 ,0)
  16110   RS2 W ! G: '$D(CLREAS ) RS4 W !! ,"Claim Re asons:  "  S JJ=0
  16111   "RTN","CHI GDQ30",197 ,0)
  16112   RS3 S JJ=$ O(CLREAS(J J)) G:JJ=" " RS4
  16113   "RTN","CHI GDQ30",198 ,0)
  16114    W ?20,JJ, " - ",$E(C LREAS(JJ), 1,53),! G  RS3
  16115   "RTN","CHI GDQ30",199 ,0)
  16116   RS4 Q:'$D( LNREAS)  S  JJ=0
  16117   "RTN","CHI GDQ30",200 ,0)
  16118   RS5 S JJ=$ O(LNREAS(J J)) G:JJ=" " RS6
  16119   "RTN","CHI GDQ30",201 ,0)
  16120    G:'$D(^CH MDIC(74100 2.22,"B",J J)) RS3
  16121   "RTN","CHI GDQ30",202 ,0)
  16122    S RSPT=0, RSPT=$O(^C HMDIC(7410 02.22,"B", JJ,RSPT))
  16123   "RTN","CHI GDQ30",203 ,0)
  16124    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S LIREAS(J J)=$E($P(^ (0),"^",2) ,1,70)
  16125   "RTN","CHI GDQ30",204 ,0)
  16126    G RS5
  16127   "RTN","CHI GDQ30",205 ,0)
  16128   RS6 Q:'$D( LIREAS)  W  !,"Line I tem Reason s:  " S JJ =0
  16129   "RTN","CHI GDQ30",206 ,0)
  16130   RS7 S JJ=$ O(LIREAS(J J)) Q:JJ=" "
  16131   "RTN","CHI GDQ30",207 ,0)
  16132    W ?20,JJ, " - ",$E(L IREAS(JJ), 1,53),! G  RS7
  16133   "RTN","CHI GDQ30",208 ,0)
  16134   CHECKS S J =0
  16135   "RTN","CHI GDQ30",209 ,0)
  16136   CHK1 S J=$ O(^CHNVPAY (CHPPTR,10 2,J)) G:'J  CHK2
  16137   "RTN","CHI GDQ30",210 ,0)
  16138    Q:'$D(^CH NVPAY(CHPP TR,102,J,0 ))
  16139   "RTN","CHI GDQ30",211 ,0)
  16140    S CHECKS( $P(^(0),"^ ",1))=""
  16141   "RTN","CHI GDQ30",212 ,0)
  16142    S:$P(^(0) ,"^",4)=1  CHECKS($P( ^(0),"^",1 ))=" (Ret) "
  16143   "RTN","CHI GDQ30",213 ,0)
  16144    G CHK1
  16145   "RTN","CHI GDQ30",214 ,0)
  16146   CHK2 Q:'$D (CHECKS)   S CHKNM=""  S CNT=1,T AB=20 W !! ,"Check #' s:"
  16147   "RTN","CHI GDQ30",215 ,0)
  16148   CHHK3 S CH KNM=$O(CHE CKS(CHKNM) ) Q:CHKNM= ""
  16149   "RTN","CHI GDQ30",216 ,0)
  16150    I CNT=4 S  CNT=1,TAB =20 W !
  16151   "RTN","CHI GDQ30",217 ,0)
  16152    W ?TAB,CH KNM,CHECKS (CHKNM)
  16153   "RTN","CHI GDQ30",218 ,0)
  16154    S TAB=TAB +17,CNT=CN T+1
  16155   "RTN","CHI GDQ30",219 ,0)
  16156    G CHHK3
  16157   "RTN","CHI GDQ30",220 ,0)
  16158   TIME S CHD T=$E(DT,4, 7),X=$P($H ,",",2),H= X\3600,M=X #3600\60
  16159   "RTN","CHI GDQ30",221 ,0)
  16160    S:M<10 M= "0"_M S CH TIME=H_M Q
  16161   "RTN","CHI GDQ30",222 ,0)
  16162   QUEUE I $D (VIEWFL),J =1 W !!,"P ress <RETU RN> to Con tinue, <^>  to exit."  R XXX S:X XX="^" EXF LG=1 W !
  16163   "RTN","CHI GDQ30",223 ,0)
  16164    ;E  I (($ Y>52)&(J=1 )) W # D H EAD
  16165   "RTN","CHI GDQ30",224 ,0)
  16166    S CHTIL=" Actions fo r Claim:"
  16167   "RTN","CHI GDQ30",225 ,0)
  16168    W:J=1 !!! ,CHTIL,!
  16169   "RTN","CHI GDQ30",226 ,0)
  16170    W:J#2=1 ! ,?3,J,") " ,X2 Q:J#2= 1
  16171   "RTN","CHI GDQ30",227 ,0)
  16172    W:J#2'=1  ?43,J,") " ,X2
  16173   "RTN","CHI GDQ30",228 ,0)
  16174    I '$D(VIE WFL),$Y>59  W # D HEA D W !!!,?( 40-($L(CHT IL)\2)),CH TIL,!
  16175   "RTN","CHI GDQ30",229 ,0)
  16176    Q
  16177   "RTN","CHM EAE5")
  16178   0^31^B6663 2491
  16179   "RTN","CHM EAE5",1,0)
  16180   CHMEAE5 ;C SW/DEN;BEN E VIEW MOD ULES (SCRE EN 1);Feb  06, 2019@1 0:01:52
  16181   "RTN","CHM EAE5",2,0)
  16182    ;;1.0;CHA MPVA SYSTE M;**1,7,14 **;JULY 4,  1990;Buil d 9
  16183   "RTN","CHM EAE5",3,0)
  16184    ;CPTS 100 42 BY CAM
  16185   "RTN","CHM EAE5",4,0)
  16186    ;CPTS 162 82 BY AEB
  16187   "RTN","CHM EAE5",5,0)
  16188    ;AGEFLG -  FLAG THAT  PROVIDES  30DAYS WIN DOW TO 65T H BIRTHDAY  FOR PROJ  188
  16189   "RTN","CHM EAE5",6,0)
  16190    ;DEV01219 7-01 YJK 4 /6/11 CARE GIVER
  16191   "RTN","CHM EAE5",7,0)
  16192    ;DEV01223 8-01 YJK 7 /11/11 <UN DEFINED> M DCR 2^CHME AE5
  16193   "RTN","CHM EAE5",8,0)
  16194    ;GEF 06/0 5/2017 Ben eficiary E dit/Enter  MBI Screen  changes
  16195   "RTN","CHM EAE5",9,0)
  16196    ;JSE 09/1 4/2017 Ben eficiary D elete MBI  for Edit h istory (FT C - 923776 )
  16197   "RTN","CHM EAE5",10,0 )
  16198    ;CFS 02/0 7/2018 Def ect Ration al #653997  Fix Undef ined error .
  16199   "RTN","CHM EAE5",11,0 )
  16200    ;CFS 06/2 8/2018 Rem ove modifi cations -  Rational # 763342.
  16201   "RTN","CHM EAE5",12,0 )
  16202    S DY=2,DX =20 X XY W  @CHEEL,@C HBON,"Ente r/Edit Ben eficiary", @CHBOFF
  16203   "RTN","CHM EAE5",13,0 )
  16204    S DX=1 F  DY=3:1:18  X XY W @CH EOL
  16205   "RTN","CHM EAE5",14,0 )
  16206    S BL="                      " ; 20 SPACES
  16207   "RTN","CHM EAE5",15,0 )
  16208    S BL26="                             " ;26  SPACES
  16209   "RTN","CHM EAE5",16,0 )
  16210   STA ;
  16211   "RTN","CHM EAE5",17,0 )
  16212    S X=$P(CH CD,"^",5)
  16213   "RTN","CHM EAE5",18,0 )
  16214    I X'="" S  X=$P($P(^ DD(554801. 01,.05,0), X_":",2)," ;")
  16215   "RTN","CHM EAE5",19,0 )
  16216    E  S X="I NVALID"
  16217   "RTN","CHM EAE5",20,0 )
  16218    S DY=2,DX =45 X XY W  @CHBON,"S tatus:",@C HBOFF,"  " ,X
  16219   "RTN","CHM EAE5",21,0 )
  16220   NAME ;
  16221   "RTN","CHM EAE5",22,0 )
  16222    S X=$P($P (CHCD,"^") ,"(SN)")_"  "_$P($P(C HCD,"^")," (SN)",2)
  16223   "RTN","CHM EAE5",23,0 )
  16224    S L=$P(X, ","),F1=$T R($P($P(X, ",",2)," " )," ")
  16225   "RTN","CHM EAE5",24,0 )
  16226    ;S F2=$TR ($P($P(X," ,",2)," ", 2,99)," ")
  16227   "RTN","CHM EAE5",25,0 )
  16228    S F2=$$TR IM^CHTFLIB ($P($P(X," ,",2)," ", 2,99))  ;A EB 1-5-201 6
  16229   "RTN","CHM EAE5",26,0 )
  16230    K SPEC S  SP="" F I= 1:1:10 S S P=SP_" " S  SPEC(SP)= " "  ;AEB  1-5-2016
  16231   "RTN","CHM EAE5",27,0 )
  16232    S F2=$$RE PLACE^XLFS TR(F2,.SPE C)  ;AEB 1 -5-2016
  16233   "RTN","CHM EAE5",28,0 )
  16234    S X=F1 S: F2'="" X=X _" "_F2 S  X=X_" "_L
  16235   "RTN","CHM EAE5",29,0 )
  16236    S:$P(CHCD ,"^")["(SN )" X=X_"   (SN)"
  16237   "RTN","CHM EAE5",30,0 )
  16238    I (EE)!(E E1) S DY=3 ,DX=5,Y="" ,$P(Y," ", 20-$L(X))= "" X XY W  @CHREVON," Name:",@CH REVOFF W "   ",X,Y Q
  16239   "RTN","CHM EAE5",31,0 )
  16240    S DY=3,DX =5 X XY W  @CHBON,"Na me:",@CHBO FF,"  ",X
  16241   "RTN","CHM EAE5",32,0 )
  16242   ADDR ;
  16243   "RTN","CHM EAE5",33,0 )
  16244    S X=$P(CH CD1,"^")
  16245   "RTN","CHM EAE5",34,0 )
  16246    I (EE)!(E E1) S DY=4 ,DX=2,Y="" ,$P(Y," ", 31-$L(X))= "" X XY W  @CHREVON," Address:", @CHREVOFF  W "  ",X,Y  Q
  16247   "RTN","CHM EAE5",35,0 )
  16248    S DY=4,DX =2 X XY W  @CHBON,"Ad dress:",@C HBOFF,"  " ,X
  16249   "RTN","CHM EAE5",36,0 )
  16250   ADDR1 ;
  16251   "RTN","CHM EAE5",37,0 )
  16252    S X=$P(CH CD1,"^",2)
  16253   "RTN","CHM EAE5",38,0 )
  16254    I (EE)!(E E1) S DY=5 ,DX=12,Y=" ",$P(Y," " ,20-$L(X)) ="" X XY W  X,Y Q
  16255   "RTN","CHM EAE5",39,0 )
  16256    S DY=5,DX =12 X XY W  @CHEEL,X
  16257   "RTN","CHM EAE5",40,0 )
  16258   ADDR2 ;
  16259   "RTN","CHM EAE5",41,0 )
  16260    I $P(CHCD 1,"^",11)= 1 D  Q:(EE )!(EE1)  G  PHONE ;FO REIGN
  16261   "RTN","CHM EAE5",42,0 )
  16262    .S X=$P(C HCD1,"^",1 2)
  16263   "RTN","CHM EAE5",43,0 )
  16264    .S X1=$P( CHCD1,"^", 13),X2=""  D:X1
  16265   "RTN","CHM EAE5",44,0 )
  16266    ..Q:'$D(^ DIC(5,X1,0 ))
  16267   "RTN","CHM EAE5",45,0 )
  16268    ..S X2=$P (^DIC(5,X1 ,0),"^",1)  Q
  16269   "RTN","CHM EAE5",46,0 )
  16270    .I '$D(X2 ) S X2="", $P(CHCD1," ^",13)=""
  16271   "RTN","CHM EAE5",47,0 )
  16272    .S DY=6,D X=12 X XY  W BL26 X X Y W X S DY =7 X XY W  BL26 X XY  W X2
  16273   "RTN","CHM EAE5",48,0 )
  16274    .Q
  16275   "RTN","CHM EAE5",49,0 )
  16276    S X=$P(CH CD1,"^",3)  ;DOMESTIC
  16277   "RTN","CHM EAE5",50,0 )
  16278    S X1=$S($ D(^DIC(5,+ $P(CHCD1," ^",4),0)): $P(^(0),"^ ",2),1:"")
  16279   "RTN","CHM EAE5",51,0 )
  16280    S X2=$P(C HCD1,"^",5 ) D
  16281   "RTN","CHM EAE5",52,0 )
  16282    .I X2?9N  S X3=$E(X2 ,1,5)_"-"_ $E(X2,6,9)  Q
  16283   "RTN","CHM EAE5",53,0 )
  16284    .S X3=X2
  16285   "RTN","CHM EAE5",54,0 )
  16286    S X4=$P(C HCD1,"^",1 3),X5="" D :X4
  16287   "RTN","CHM EAE5",55,0 )
  16288    .Q:'$D(^D IC(5,X4,0) )
  16289   "RTN","CHM EAE5",56,0 )
  16290    .S X5=$P( ^DIC(5,X4, 0),"^",1)  Q
  16291   "RTN","CHM EAE5",57,0 )
  16292    I (EE)!(E E1) S DY=6 ,DX=12 X X Y W BL X X Y W X W:X1 '="" ", "  W X1 W:X3' ="" "  " W  X3,BL S D Y=7,DX=12  X XY W BL  X XY W X5  Q
  16293   "RTN","CHM EAE5",58,0 )
  16294    S DY=6,DX =12 X XY W  BL X XY W  X W:X1'=" " ", " W X 1 W:X3'=""  "  " W X3 ,BL S DY=7 ,DX=12 X X Y W BL X X Y W X5
  16295   "RTN","CHM EAE5",59,0 )
  16296   PHONE ;
  16297   "RTN","CHM EAE5",60,0 )
  16298    S X=$P(CH CD1,"^",6) ,X=$S($P(C HCD1,"^",1 1):X,(X?10 N.E)!(X?1" FTS".7N):" ("_$E(X,1, 3)_") "_$E (X,4,6)_"- "_$E(X,7,9 9),X?7N.E: $E(X,1,3)_ "-"_$E(X,4 ,99),1:X)
  16299   "RTN","CHM EAE5",61,0 )
  16300    I (EE)!(E E1) S DY=8 ,DX=4,Y="" ,$P(Y," ", 15-$L(X))= "" X XY W  @CHREVON," Phone:",@C HREVOFF W  "  ",X,Y,B L Q
  16301   "RTN","CHM EAE5",62,0 )
  16302    S DY=8,DX =4 X XY W  @CHBON,"Ph one:",@CHB OFF,"  ",X
  16303   "RTN","CHM EAE5",63,0 )
  16304   APDT ;
  16305   "RTN","CHM EAE5",64,0 )
  16306   SSN ;
  16307   "RTN","CHM EAE5",65,0 )
  16308    S X=$P(CH CD,"^",9)  S:X?9N X=$ P(CHCD,"^" ,36)_" "_$ E(X,1,3)_" -"_$E(X,4, 5)_"-"_$E( X,6,9)
  16309   "RTN","CHM EAE5",66,0 )
  16310    I (EE)!(E E1) S DY=9 ,DX=6,Y="" ,$P(Y," ", 10-$L(X))= "" X XY W  @CHREVON," SSN:",@CHR EVOFF W "   ",X,Y Q
  16311   "RTN","CHM EAE5",67,0 )
  16312    S DY=9,DX =6 X XY W  @CHBON,"SS N:",@CHBOF F,"  ",X
  16313   "RTN","CHM EAE5",68,0 )
  16314   REL ;
  16315   "RTN","CHM EAE5",69,0 )
  16316    S X=$P(CH CD,"^",4), Y=$P(CHCD, "^",26)
  16317   "RTN","CHM EAE5",70,0 )
  16318    ;S:X'=""  X=$S(X="C" :"CHILD",X ="XS":"EX- SPOUSE",X= "S":"SPOUS E",1:"INVA LID")   ;D EV012197-0 1 YJK 4/6/ 11
  16319   "RTN","CHM EAE5",71,0 )
  16320    S:X'="" X =$S(X="C": "CHILD",X= "XS":"EX-S POUSE",X=" S":"SPOUSE ",X="CG":" CAREGIVER" ,1:"INVALI D")   ;DEV 012197-01  YJK 4/6/11
  16321   "RTN","CHM EAE5",72,0 )
  16322    I X="CHIL D" S Y=$S( Y="N":"NAT URAL",Y="A ":"ADOPTED ",Y="I":"I LLEGITIMAT E",Y="S":" STEP",1:"N ATURAL")
  16323   "RTN","CHM EAE5",73,0 )
  16324    I X'="CHI LD" S Y=""
  16325   "RTN","CHM EAE5",74,0 )
  16326    I (EE)!(E E1) S DY=1 0,DX=6 X X Y D  Q  ;W AS D  D SE X Q
  16327   "RTN","CHM EAE5",75,0 )
  16328    .I X="CHI LD" S X=X_ " ("_Y_")"
  16329   "RTN","CHM EAE5",76,0 )
  16330    .S $P(X,"  ",20-$L(X ))="" W @C HREVON,"Re l:",@CHREV OFF,"  "
  16331   "RTN","CHM EAE5",77,0 )
  16332    .W BL_"    " S DY=10 ,DX=12 X X Y W X Q
  16333   "RTN","CHM EAE5",78,0 )
  16334    S DY=10,D X=6 X XY W  @CHBON,"R el:",@CHBO FF,"  ",BL _"   " S D Y=10,DX=12  X XY W X  I X="CHILD " W " (",Y ,")"
  16335   "RTN","CHM EAE5",79,0 )
  16336   SEX ;
  16337   "RTN","CHM EAE5",80,0 )
  16338    S X=$P(CH CD,"^",2), X=$S(X="F" :"Female", X="M":"Mal e",1:X)
  16339   "RTN","CHM EAE5",81,0 )
  16340    I (EE)!(E E1) S DY=1 0,DX=35,Y= "",$P(Y,"  ",10-$L(X) )="" X XY  W @CHREVON ,"Sex:",@C HREVOFF,"   ",X,Y Q
  16341   "RTN","CHM EAE5",82,0 )
  16342    S DY=10,D X=35 X XY  W @CHBON," Sex:",@CHB OFF,"  ",X
  16343   "RTN","CHM EAE5",83,0 )
  16344   DOB ;
  16345   "RTN","CHM EAE5",84,0 )
  16346    S X=$P(CH CD,"^",3)  S:X'="" X= $E(X,4,5)_ "/"_$E(X,6 ,7)_"/"_$E (X,2,3)
  16347   "RTN","CHM EAE5",85,0 )
  16348    I (EE)!(E E1) S DY=1 1,DX=6,Y=" ",$P(Y," " ,10-$L(X)) ="" X XY W  @CHREVON, "DOB:",@CH REVOFF W "   ",X,Y Q
  16349   "RTN","CHM EAE5",86,0 )
  16350    S DY=11,D X=6 X XY W  @CHBON,"D OB:",@CHBO FF,"  ",X
  16351   "RTN","CHM EAE5",87,0 )
  16352   DOD ;
  16353   "RTN","CHM EAE5",88,0 )
  16354    S X=$P(CH CD,"^",6), Y="" S:X?7 N.E X=$E(X ,4,5)_"/"_ $E(X,6,7)_ "/"_$E(X,2 ,3)
  16355   "RTN","CHM EAE5",89,0 )
  16356    ;D DTPRT  S X=Y
  16357   "RTN","CHM EAE5",90,0 )
  16358    I (EE)!(E E1) S DY=1 1,DX=35,Y= "",$P(Y,"  ",23-$L(X) )="" X XY  W @CHREVON ,"DOD:",@C HREVOFF W  "  ",X,Y Q
  16359   "RTN","CHM EAE5",91,0 )
  16360    S DY=11,D X=35 X XY  W @CHBON," DOD:",@CHB OFF,"  ",X
  16361   "RTN","CHM EAE5",92,0 )
  16362   EFF ;
  16363   "RTN","CHM EAE5",93,0 )
  16364   R1 ;
  16365   "RTN","CHM EAE5",94,0 )
  16366   MDCR ;
  16367   "RTN","CHM EAE5",95,0 )
  16368    S X=$P(CH CD,"^",3)  S:$E(X,4,7 )="0229" $ E(X,4,7)=" 0228"
  16369   "RTN","CHM EAE5",96,0 )
  16370    ;S DAT65= $P(^AHCHVA (DFN,100,B FN,0),"^", 3)+650000   ;TLH 11/1 4/06 FOR P ROJ 188  ; DEV012238- 01 YJK 7/1 1/11
  16371   "RTN","CHM EAE5",97,0 )
  16372    S CHAGE=$ E(DT,1,3)- $E(X,1,3)  S:$E(X,4,7 )>$E(DT,4, 7) CHAGE=C HAGE-1
  16373   "RTN","CHM EAE5",98,0 )
  16374    S X=$S($P (CHCD,"^", 32)=0:"NO" ,$P(CHCD," ^",32)=1:" MED A ONLY ",$P(CHCD, "^",32)=2: "MED A&B", $P(CHCD,"^ ",32)=3:"M ED B ONLY" ,$P(CHCD," ^",32)="": "NO",1:"NO ")
  16375   "RTN","CHM EAE5",99,0 )
  16376    ;S X=$S($ P(CHCD,"^" ,32)=0:"NO ",$P(CHCD, "^",32)=1: "MED A ONL Y",$P(CHCD ,"^",32)=2 :"MED A&B" ,$P(CHCD," ^",32)=3:" MED B ONLY ",$P(CHCD, "^",32)=4: "MED D",$P (CHCD,"^", 32)="":"NO ",1:"NO")   ;NEW CODE , SKD 4-9- 08 DEV0042 23-01
  16377   "RTN","CHM EAE5",100, 0)
  16378    G MDCR2
  16379   "RTN","CHM EAE5",101, 0)
  16380   MDCR1 ;
  16381   "RTN","CHM EAE5",102, 0)
  16382    S X=$S($P (CHCD,"^", 32)=0:"NO" ,$P(CHCD," ^",32)=1:" MED A ONLY ",$P(CHCD, "^",32)=2: "MED A&B", $P(CHCD,"^ ",32)=3:"M ED B ONLY" ,$P(CHCD," ^",32)="": "YES",1:"Y ES")
  16383   "RTN","CHM EAE5",103, 0)
  16384    ;S X=$S($ P(CHCD,"^" ,32)=0:"NO ",$P(CHCD, "^",32)=1: "MED A ONL Y",$P(CHCD ,"^",32)=2 :"MED A&B" ,$P(CHCD," ^",32)=3:" MED B ONLY ",$P(CHCD, "^",32)=4: "MED D",$P (CHCD,"^", 32)="":"YE S",1:"YES" )  ;NEW CO DE,SKD 4-9 -08 DEV004 223-01
  16385   "RTN","CHM EAE5",104, 0)
  16386   MDCR2 ;
  16387   "RTN","CHM EAE5",105, 0)
  16388    D MDDT S  DY=12,DX=3  X XY W @C HBON,"MDca re:",@CHBO FF,"  ",X
  16389   "RTN","CHM EAE5",106, 0)
  16390   CMPUS ;
  16391   "RTN","CHM EAE5",107, 0)
  16392    S X=$S($P (CHCD,"^", 15)=0:"NO" ,$P(CHCD," ^",15)=1:" YES",1:"")
  16393   "RTN","CHM EAE5",108, 0)
  16394    I (EE)!(E E1) S DY=1 3,DX=2,Y=" ",$P(Y," " ,31-$L(X)) ="" X XY W  @CHBON,"T RICARE:",@ CHBOFF,"   ",X,Y W:EE 2 " *" S D X=43 X XY  W BL Q  ;T LH 12/10/0 7 DEV00291 5 CHG CHAM PUS TO TRI CARE
  16395   "RTN","CHM EAE5",109, 0)
  16396    S DY=13,D X=2 X XY W  @CHBON,"T RICARE:",@ CHBOFF,"   ",X  ;TLH  12/10/07 D EV002915 C HG CHAMPUS  TO TRICAR E
  16397   "RTN","CHM EAE5",110, 0)
  16398   CORRES ;
  16399   "RTN","CHM EAE5",111, 0)
  16400    S DY=14,D X=2,U="^"  X XY W @CH BON,"Alt A dd:",@CHBO FF,"  "
  16401   "RTN","CHM EAE5",112, 0)
  16402    S DY=18,D X=1 X XY W  @CHBON,"A ltPhone:", @CHBOFF,"   "
  16403   "RTN","CHM EAE5",113, 0)
  16404    G:'$D(CHC D9) CONT
  16405   "RTN","CHM EAE5",114, 0)
  16406    S DY=14,D X=12 X XY  W:$P(CHCD9 ,U,1)'=""  $P(CHCD9,U ,1)
  16407   "RTN","CHM EAE5",115, 0)
  16408    S DY=15,D X=12 X XY  W:$P(CHCD9 ,U,2)'=""  $P(CHCD9,U ,2)
  16409   "RTN","CHM EAE5",116, 0)
  16410    I $P(CHCD 9,U,9)=1 D   G CONT ; address fl ag says it  is foreig n
  16411   "RTN","CHM EAE5",117, 0)
  16412    .S DY=16, DX=12 X XY  I $P(CHCD 9,U,3)'=""  W $P(CHCD 9,U,3)
  16413   "RTN","CHM EAE5",118, 0)
  16414    .I $P(CHC D9,U,5)'=" " D
  16415   "RTN","CHM EAE5",119, 0)
  16416    ..S CCODE 9=$P(CHCD9 ,U,5) Q:CC ODE9=""
  16417   "RTN","CHM EAE5",120, 0)
  16418    ..Q:'$D(^ DIC(5,CCOD E9,0))
  16419   "RTN","CHM EAE5",121, 0)
  16420    ..S DY=17 ,DX=12 X X Y W $P(^DI C(5,CCODE9 ,0),U,1) Q
  16421   "RTN","CHM EAE5",122, 0)
  16422    .S DY=18, DX=12 X XY  W $P(CHCD 9,U,10) ;F REE TEXT P HONE NUMBE R
  16423   "RTN","CHM EAE5",123, 0)
  16424    S DY=16,D X=12 X XY
  16425   "RTN","CHM EAE5",124, 0)
  16426    I $P(CHCD 9,U,6)'=""  W $P(CHCD 9,U,6),",  "
  16427   "RTN","CHM EAE5",125, 0)
  16428    I $P(CHCD 9,U,7)'=""  D
  16429   "RTN","CHM EAE5",126, 0)
  16430    .S STCODE 9=$P(CHCD9 ,U,7)
  16431   "RTN","CHM EAE5",127, 0)
  16432    .Q:'$D(^D IC(5,STCOD E9,0))
  16433   "RTN","CHM EAE5",128, 0)
  16434    .W $P(^DI C(5,STCODE 9,0),"^",2 )," "
  16435   "RTN","CHM EAE5",129, 0)
  16436    I $P(CHCD 9,U,8)'?9N  W $P(CHCD 9,U,8) G D OMCNTR
  16437   "RTN","CHM EAE5",130, 0)
  16438    W $E($P(C HCD9,U,8), 1,5),"-",$ E($P(CHCD9 ,U,8),6,9)
  16439   "RTN","CHM EAE5",131, 0)
  16440   DOMCNTR ;
  16441   "RTN","CHM EAE5",132, 0)
  16442    ;DOMESTIC  COUNTRY P RINTED HER E
  16443   "RTN","CHM EAE5",133, 0)
  16444    I $P(CHCD 9,U,5)'=""  D  ;COUNT RY
  16445   "RTN","CHM EAE5",134, 0)
  16446    .S CCODE9 =$P(CHCD9, U,5) Q:CCO DE9=""
  16447   "RTN","CHM EAE5",135, 0)
  16448    .Q:'$D(^D IC(5,CCODE 9,0))
  16449   "RTN","CHM EAE5",136, 0)
  16450    .S DY=17, DX=12 X XY  W $P(^DIC (5,CCODE9, 0),U,1)
  16451   "RTN","CHM EAE5",137, 0)
  16452   ALTPHON ;
  16453   "RTN","CHM EAE5",138, 0)
  16454    S DY=18,D X=12,X=$P( CHCD9,U,10 ) X XY
  16455   "RTN","CHM EAE5",139, 0)
  16456    I X?10N W  "(",$E(X, 1,3),")-", $E(X,4,6), "-",$E(X,7 ,10) G CON T
  16457   "RTN","CHM EAE5",140, 0)
  16458    W X
  16459   "RTN","CHM EAE5",141, 0)
  16460   CONT S DY= 18,DX=2 X  XY
  16461   "RTN","CHM EAE5",142, 0)
  16462    Q
  16463   "RTN","CHM EAE5",143, 0)
  16464    ;
  16465   "RTN","CHM EAE5",144, 0)
  16466    ;beg new  code PER D EV004223-0 1, SKD 1-2 8-08
  16467   "RTN","CHM EAE5",145, 0)
  16468   HICN ; don 't display  the HICN  field if w e are past  the imple mentation  date
  16469   "RTN","CHM EAE5",146, 0)
  16470    ;Remove d ate checks .
  16471   "RTN","CHM EAE5",147, 0)
  16472    ;Q:DT>$P( CHMDT,"^")
  16473   "RTN","CHM EAE5",148, 0)
  16474    ;Q:DT>$P( $G(CHMDT), "^") ;Defe ct Task #6 53997 - Pr event UNDE F Error wi th a $G ar ound CHMDT  variable.
  16475   "RTN","CHM EAE5",149, 0)
  16476    S X=$P(CH CD,"^",39)  S:X'?.12A N X="??"    ;dp;enc00 8413; Exte nd the fie ld & accep t 12 alpha  numeric c haracters
  16477   "RTN","CHM EAE5",150, 0)
  16478    S X=$TR(X ,"abcdefgh ijklmnopqr stuvwxyz", "ABCDEFGHI JKLMNOPQRS TUVWXYZ")    ;DP; Tra nslate low er case to  upper.
  16479   "RTN","CHM EAE5",151, 0)
  16480    ; move HI CN up to l ine 5 duri ng phase-i n period
  16481   "RTN","CHM EAE5",152, 0)
  16482    I (EE)!(E E1) S DY=1 4,DX=64,Y= "" X XY W  @CHREVON," HICN:",@CH REVOFF W X ,Y Q
  16483   "RTN","CHM EAE5",153, 0)
  16484    S DY=14,D X=64 X XY  W @CHBON," HICN:",@CH BOFF,X
  16485   "RTN","CHM EAE5",154, 0)
  16486    Q
  16487   "RTN","CHM EAE5",155, 0)
  16488    ;end new  code PER D EV004223-0 1, SKD 1-2 8-08
  16489   "RTN","CHM EAE5",156, 0)
  16490   MBI ; Repl ace HICN w ith MBI
  16491   "RTN","CHM EAE5",157, 0)
  16492    ;S X=$P(C HCD,"^",40 ) S:X'?.11 AN X="??"                                                            ;JSE 09 /14/2017
  16493   "RTN","CHM EAE5",158, 0)
  16494    S X=$P(CH CD,"^",40)  I X="" S  DY=16,DX=6 4 X XY W @ CHBON,"MBI :",@CHBOFF ,"            " Q        ;JSE 09 /14/2017
  16495   "RTN","CHM EAE5",159, 0)
  16496    S:X'?.11A N X="??"
  16497   "RTN","CHM EAE5",160, 0)
  16498    S X=$TR(X ,"abcdefgh ijklmnopqr stuvwxyz", "ABCDEFGHI JKLMNOPQRS TUVWXYZ")    ; Transl ate lower  case to up per.
  16499   "RTN","CHM EAE5",161, 0)
  16500    I (EE)!(E E1) S DY=1 6,DX=64,Y= "" X XY W  @CHREVON," MBI:",@CHR EVOFF W X, Y Q
  16501   "RTN","CHM EAE5",162, 0)
  16502    S DY=16,D X=64 X XY  W @CHBON," MBI:",@CHB OFF,X
  16503   "RTN","CHM EAE5",163, 0)
  16504    Q
  16505   "RTN","CHM EAE5",164, 0)
  16506    ;
  16507   "RTN","CHM EAE5",165, 0)
  16508   3884SD ;S  X="NONE",T SNT=0,RTN= "" I '$D(^ AHCHVA("RO -3884",DFN )) G 3884S
  16509   "RTN","CHM EAE5",166, 0)
  16510    ;S PT=0,P T=$O(^AHCH VA("RO-388 4",DFN,PT) ) I 'PT S  X="NONE" G  3884S
  16511   "RTN","CHM EAE5",167, 0)
  16512    ;S:$D(^AH CHVA(DFN,1 09,PT,0))  REC=^AHCHV A(DFN,109, PT,0),RTN= $P(REC,"^" ,4)
  16513   "RTN","CHM EAE5",168, 0)
  16514    ;S SDT=$P (REC,"^",8 ) G:$P(SDT ,".",1)'?7 N 3884S S  TSNT=$P(RE C,"^",7)
  16515   "RTN","CHM EAE5",169, 0)
  16516    ;S X=$$FM TE^XLFDT(S DT,"2D")
  16517   "RTN","CHM EAE5",170, 0)
  16518   3884S ;S D Y=15,DX=1  X XY W @CH BON,"3884  Snd:",@CHB OFF,"  ",X ,"  (",TSN T,")"
  16519   "RTN","CHM EAE5",171, 0)
  16520   3884RD ;G: RTN="" 388 4R
  16521   "RTN","CHM EAE5",172, 0)
  16522    ;S RTN=$$ FMTE^XLFDT (RTN,"2D")
  16523   "RTN","CHM EAE5",173, 0)
  16524   3884R ;S D Y=16,DX=1  X XY W @CH BON,"3884  Rcd:",@CHB OFF,"  ",R TN
  16525   "RTN","CHM EAE5",174, 0)
  16526   REA ;S (X, Z)=""
  16527   "RTN","CHM EAE5",175, 0)
  16528    ;S X="" I  $P(CHCD," ^",12)'=""  S X=$O(^A HADIC(5548 01.7,"B",$ P(CHCD,"^" ,12),0)) S :X'="" X=$ P(^AHADIC( 554801.7,X ,0),"^",2)
  16529   "RTN","CHM EAE5",176, 0)
  16530    ;I X="" I  $P(CHCD," ^",13)'=""  S X=$O(^A HADIC(5548 01.6,"B",$ P(CHCD,"^" ,13),0)) S :X'="" X=$ P(^AHADIC( 554801.6,X ,0),"^",2)
  16531   "RTN","CHM EAE5",177, 0)
  16532    ;S:X="" X =""
  16533   "RTN","CHM EAE5",178, 0)
  16534    ;S DY=17, DX=1 X XY  W @CHBON," Stat Rsn:" ,@CHBOFF,"   ",X
  16535   "RTN","CHM EAE5",179, 0)
  16536    ;I X="WID OW(ER)S MA RRIAGE TER MINATED" S  X=$P(CHCD ,"^",7) D  DTPRT W "   (",Y W:Y= "" "NO DAT E ON FILE"  W ")" G M DCR
  16537   "RTN","CHM EAE5",180, 0)
  16538    ;I X="SPO USE MARRIA GE TERMINA TED" S X=$ P(CHCD,"^" ,29) D DTP RT W "  (" ,Y W:Y=""  "NO DATE O N FILE" W  ")" G MDCR
  16539   "RTN","CHM EAE5",181, 0)
  16540    ;I X="REM ARRIED WID OW" S X=$P (CHCD,"^", 8) D DTPRT  W "  (",Y  W:Y="" "N O DATE ON  FILE" W ") "
  16541   "RTN","CHM EAE5",182, 0)
  16542   STDT ;S X= "" S:$P(CH CD,U,11)'= "" X=$$FMT E^XLFDT($P (CHCD,U,11 ),"2D")
  16543   "RTN","CHM EAE5",183, 0)
  16544    ;S DY=18, DX=2 X XY  W @CHBON," Stat Dt:", @CHBOFF,"   ",X
  16545   "RTN","CHM EAE5",184, 0)
  16546   MDDT ;
  16547   "RTN","CHM EAE5",185, 0)
  16548    S (XB,XA) =""
  16549   "RTN","CHM EAE5",186, 0)
  16550    ;I X="MED  B ONLY"!( X="MED A&B ") D   ;SK D 4-9-08 D EV004223-0 1
  16551   "RTN","CHM EAE5",187, 0)
  16552    D MDDDATE ^CHMEAE6F  I 'CHMDD S  X="MED D"   ;SKD 4-9 -08 DEV004 223-01
  16553   "RTN","CHM EAE5",188, 0)
  16554    I X="MED  B ONLY"!(X ="MED A&B" )!(X="MED  D") D   ;S KD 4-9-08  DEV004223- 01
  16555   "RTN","CHM EAE5",189, 0)
  16556    .I '$D(^A HCHVA(DFN, 100,BFN,11 2)) Q
  16557   "RTN","CHM EAE5",190, 0)
  16558    .S MDBDT= 999999999
  16559   "RTN","CHM EAE5",191, 0)
  16560    .S MDBDT= $O(^AHCHVA (DFN,100,B FN,112,MDB DT),-1) Q: 'MDBDT
  16561   "RTN","CHM EAE5",192, 0)
  16562    .I '$D(^A HCHVA(DFN, 100,BFN,11 2,MDBDT))  S X="" Q
  16563   "RTN","CHM EAE5",193, 0)
  16564    .S MDBDT= $P(^AHCHVA (DFN,100,B FN,112,MDB DT,0),"^", 1)
  16565   "RTN","CHM EAE5",194, 0)
  16566    .S MN=$E( MDBDT,4,5) ,YR=$E(MDB DT,2,3)
  16567   "RTN","CHM EAE5",195, 0)
  16568    .I X="MED  B ONLY" S  X="B ONLY  "_MN_"/"_ YR Q
  16569   "RTN","CHM EAE5",196, 0)
  16570    .S XB="B  "_MN_"/"_Y R Q
  16571   "RTN","CHM EAE5",197, 0)
  16572    I X["B ON LY" Q
  16573   "RTN","CHM EAE5",198, 0)
  16574    ;I X="MED  A ONLY"!( X="MED A&B ") D    ;S KD 4-9-08  DEV004223- 01
  16575   "RTN","CHM EAE5",199, 0)
  16576    I X="MED  A ONLY"!(X ="MED A&B" )!(X="MED  D") D   ;S KD 4-9-08  DEV004223- 01
  16577   "RTN","CHM EAE5",200, 0)
  16578    .I '$D(^A HCHVA(DFN, 100,BFN,11 1)) Q
  16579   "RTN","CHM EAE5",201, 0)
  16580    .S MDADT= 999999999
  16581   "RTN","CHM EAE5",202, 0)
  16582    .S MDADT= $O(^AHCHVA (DFN,100,B FN,111,MDA DT),-1) Q: 'MDADT
  16583   "RTN","CHM EAE5",203, 0)
  16584    .I '$D(^A HCHVA(DFN, 100,BFN,11 1,MDADT))  S X="" Q
  16585   "RTN","CHM EAE5",204, 0)
  16586    .S MDADT= $P(^AHCHVA (DFN,100,B FN,111,MDA DT,0),"^", 1)
  16587   "RTN","CHM EAE5",205, 0)
  16588    .S MN=$E( MDADT,4,5) ,YR=$E(MDA DT,2,3)
  16589   "RTN","CHM EAE5",206, 0)
  16590    .I X="MED  A ONLY" S  X="A ONLY  "_MN_"/"_ YR Q
  16591   "RTN","CHM EAE5",207, 0)
  16592    .S XA="A  "_MN_"/"_Y R Q
  16593   "RTN","CHM EAE5",208, 0)
  16594    I X="MED  A&B" D
  16595   "RTN","CHM EAE5",209, 0)
  16596    .S X=XA_"   "_XB Q
  16597   "RTN","CHM EAE5",210, 0)
  16598    ;BEG SKD  4-9-08 DEV 004223-01
  16599   "RTN","CHM EAE5",211, 0)
  16600    I X="MED  D" D    ;S KD 4-9-08  DEV004223- 01
  16601   "RTN","CHM EAE5",212, 0)
  16602    .I '$D(^A HCHVA(DFN, 100,BFN,11 7)) Q
  16603   "RTN","CHM EAE5",213, 0)
  16604    .S MDDDT= 999999999
  16605   "RTN","CHM EAE5",214, 0)
  16606    .S MDDDT= $O(^AHCHVA (DFN,100,B FN,117,MDD DT),-1) Q: 'MDDDT
  16607   "RTN","CHM EAE5",215, 0)
  16608    .I '$D(^A HCHVA(DFN, 100,BFN,11 7,MDDDT))  S X="" Q
  16609   "RTN","CHM EAE5",216, 0)
  16610    .S MDDDT= $P(^AHCHVA (DFN,100,B FN,117,MDD DT,0),"^", 1)
  16611   "RTN","CHM EAE5",217, 0)
  16612    .S MN=$E( MDDDT,4,5) ,YR=$E(MDD DT,2,3)
  16613   "RTN","CHM EAE5",218, 0)
  16614    .S X=$S(X A'="":XA_"   ",1:"")_ $S(XB'="": XB_"  ",1: "")_"D "_M N_"/"_YR Q
  16615   "RTN","CHM EAE5",219, 0)
  16616    ;END SKD  4-9-08 DEV 004223-01
  16617   "RTN","CHM EAE5",220, 0)
  16618    K MDBDT,M N,YR,MDADT ,XB,XA,MDD DT
  16619   "RTN","CHM EAE5",221, 0)
  16620    Q
  16621   "RTN","CHM EAE5",222, 0)
  16622   DTPRT ;
  16623   "RTN","CHM EAE5",223, 0)
  16624    S Y="" Q: X'?7N  S Y =$E(X,1,3) +1700,%M=+ $E(X,4,5), %D=+$E(X,6 ,7)
  16625   "RTN","CHM EAE5",224, 0)
  16626    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  16627   "RTN","CHM EAE5",225, 0)
  16628    Q
  16629   "RTN","CHM EAE5",226, 0)
  16630   JAN ;
  16631   "RTN","CHM EAE5",227, 0)
  16632    ;;JAN FEB  MAR APR M AY JUN JUL  AUG SEP O CT NOV DEC
  16633   "RTN","CHM F351D")
  16634   0^33^B9200 5416
  16635   "RTN","CHM F351D",1,0 )
  16636   CHMF351D ; DEH/DEN;CH AMPVA POST -PROC CLAI M REPORT C ALC;Feb 06 , 2019@10: 02:33
  16637   "RTN","CHM F351D",2,0 )
  16638    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  16639   "RTN","CHM F351D",3,0 )
  16640    ;CPT(S) -  11008*, # 12621 (RLC )
  16641   "RTN","CHM F351D",4,0 )
  16642    ;CPTS #12 531 BY DTP  (5-SEP-97 )
  16643   "RTN","CHM F351D",5,0 )
  16644    ;DEV01106 9 1/13/201 1 AEB
  16645   "RTN","CHM F351D",6,0 )
  16646    ;CR# DEV0 09373 - Mo dified rou tine to fa ctor COB P ART D  5/1 1/2011
  16647   "RTN","CHM F351D",7,0 )
  16648    ;ENC#0093 75 ADDED " CITISXC" E DITYPE AS  PART OF CI TI IMPLEME NTATION
  16649   "RTN","CHM F351D",8,0 )
  16650    ;DEV00782 0  EW 10/6 /11 ADDING  AUTO DIST RIBUTION F LAG
  16651   "RTN","CHM F351D",9,0 )
  16652    ;CFS 10/1 8/2017 CPE 005-095 -  Add total  payments o f all clai ms for Cur rent and O riginal PD I's.
  16653   "RTN","CHM F351D",10, 0)
  16654    ;CFS 02/2 0/208 CPE0 01-020, 02 1 and 022  - Get the  PL ZIP out  of the "V EN-II" nod e of ^CHMP AY.
  16655   "RTN","CHM F351D",11, 0)
  16656   VIEW D RES ET K CHPDI K,FILE
  16657   "RTN","CHM F351D",12, 0)
  16658    S X1=I D  PROGTYP^CH FCD001
  16659   "RTN","CHM F351D",13, 0)
  16660    G:'$D(@(G LPAY_"I,0) ")) END S  X=@(GLPAY_ "I,0)")
  16661   "RTN","CHM F351D",14, 0)
  16662    S CHCLN=$ P(X,"^",1) ,CHCLST=$P (X,"^",2)
  16663   "RTN","CHM F351D",15, 0)
  16664    G END:'$D (^CHMDIC(7 41002.94,C HPGPT,0))  S CHPROG=$ P(^(0),"^" ,2)
  16665   "RTN","CHM F351D",16, 0)
  16666    S VFN=$P( X,"^",3),C HASOB=$P(X ,"^",5),CH TYPE=$P(X, "^",7)
  16667   "RTN","CHM F351D",17, 0)
  16668    S CHDATSE R=$P(X,"^" ,8),DFN=$P (X,"^",21) ,BFN=$P(X, "^",22)
  16669   "RTN","CHM F351D",18, 0)
  16670    S:DFN=""  DFN=-1 S:B FN="" BFN= -1
  16671   "RTN","CHM F351D",19, 0)
  16672    S CHPOS=" " ;,AUTODI ST=""
  16673   "RTN","CHM F351D",20, 0)
  16674    I $D(@(GL PAY_"I,""C OMMON"")") ) D
  16675   "RTN","CHM F351D",21, 0)
  16676    .S POS=$P (@(GLPAY_" I,""COMMON "")"),"^", 2)
  16677   "RTN","CHM F351D",22, 0)
  16678    .;S AUTOD IST=$P(@(G LPAY_"I,"" COMMON"")" ),"^",18)  ;DEV007820   EW 10/6/ 11
  16679   "RTN","CHM F351D",23, 0)
  16680    .;I $$DSL A^CHTFLIB2 (I)=0 S AU TODIST=1 ; IF PRE SLA
  16681   "RTN","CHM F351D",24, 0)
  16682    .I POS I  $D(^CHMDIC (741002.11 ,POS,0)) S  CHPOS=$E( $P(^(0),"^ ",2),1,14)
  16683   "RTN","CHM F351D",25, 0)
  16684    ; UP TO T HIS POINT  HAVE THE 0  NODE
  16685   "RTN","CHM F351D",26, 0)
  16686    ;FOLLOWIN G GET CLAI M #,DED,CO ST,OTHER I NS,TOTAL,C ALC
  16687   "RTN","CHM F351D",27, 0)
  16688    S X=""
  16689   "RTN","CHM F351D",28, 0)
  16690    S:$D(@(GL PAY_"I,1)" )) X=@(GLP AY_"I,1)")
  16691   "RTN","CHM F351D",29, 0)
  16692    S CHPR="" ,CHPR=$P(X ,"^",29)    ;SKD 11-1 -06 MC284
  16693   "RTN","CHM F351D",30, 0)
  16694    S CHCLAMT =$P(X,"^", 1),CHAMTDE D=$P(X,"^" ,5)
  16695   "RTN","CHM F351D",31, 0)
  16696    S CHCOST= $P(X,"^",6 ),CHOTHER= $P(X,"^",7 ),CHVPMT=$ P(X,"^",14 ),CHBPMT=$ P(X,"^",15 ),CHCCA=$P (X,"^",18)
  16697   "RTN","CHM F351D",32, 0)
  16698    ;GETS DED  AND CAT C AP INFO FR OM CLAIM F ORM IF PRE SENT
  16699   "RTN","CHM F351D",33, 0)
  16700    S (CHBDYT D,CHFDYTD, CHFCYTD,CH BDYTDO,CHF DYTDO,CHFC YTDO)="",( CHBDM,CHFD M,CHFCM,CH ICF)=0
  16701   "RTN","CHM F351D",34, 0)
  16702    S CHBDYTD O=$P(X,"^" ,19),CHBDY TD=$P(X,"^ ",20),CHBD M=$P(X,"^" ,21),CHFDY TDO=$P(X," ^",22),CHF DYTD=$P(X, "^",23),CH FDM=$P(X," ^",24),CHF CYTDO=$P(X ,"^",25),C HFCYTD=$P( X,"^",26), CHFCM=$P(X ,"^",27)
  16703   "RTN","CHM F351D",35, 0)
  16704    I (CHBDYT DO'="")!(C HBDYTD'="" )!(CHFDYTD O'="")!(CH FDYTD'="") !(CHFCYTDO '="")!(CHF CYTD'="")  S CHICF=0
  16705   "RTN","CHM F351D",36, 0)
  16706    S XCOM=""  S:$D(@(GL PAY_"I,""C OMMON"")") ) XCOM=@(G LPAY_"I,"" COMMON"")" )
  16707   "RTN","CHM F351D",37, 0)
  16708    S CHTOTAL =$P(XCOM," ^",1),CHBP M=$P(XCOM, "^",3),CHC ALCT=$P(XC OM,"^",7), CHDRG=$P(X COM,"^",8) ,CHDRGOK=$ P(XCOM,"^" ,9)
  16709   "RTN","CHM F351D",38, 0)
  16710    S CHDRGST AT="" I CH DRGOK'=""  S CHDRGSTA T=$S(CHDRG OK=0:"Reje ct",CHDRGO K=1:"Accep t",CHDRGOK =2:"Q. A.  Accept",CH DRGOK=3:"M iss. Data" ,CHDRGOK=4 :"QA REJEC T",CHDRGOK =5:"PAO Is sue",CHDRG OK=-1:"ERR OR",1:"")   ;AEB 1/13 /2011 DEV0 11069  ADD ED 4&5
  16711   "RTN","CHM F351D",39, 0)
  16712    ;FOLLOWIN G GETS THE  PDI NUMBE RS
  16713   "RTN","CHM F351D",40, 0)
  16714    S J=0
  16715   "RTN","CHM F351D",41, 0)
  16716    F K=0:0 S  J=$O(@(GL PAY_"I,""P DI"",J)"))  Q:J'?1N.N   D
  16717   "RTN","CHM F351D",42, 0)
  16718    .Q:'$D(@( GLPAY_"I," "PDI"",J,0 )"))
  16719   "RTN","CHM F351D",43, 0)
  16720    .S ZPDI=$ P(@(GLPAY_ "I,""PDI"" ,J,0)"),"^ ",1) Q:ZPD I=""  S BA T=""
  16721   "RTN","CHM F351D",44, 0)
  16722    .I '$D(PA IDARY) D G ETPYMNT(ZP DI,.PAIDAR Y) ;CPE005 -095
  16723   "RTN","CHM F351D",45, 0)
  16724    .S BI=$O( ^CHMIMPB(" C",ZPDI,0) ) I BI'=""  S:$D(^CHM IMPB(BI,0) ) BAT=$P(^ (0),"^",1)
  16725   "RTN","CHM F351D",46, 0)
  16726    .S CHPDI( J)=ZPDI_"   Batch: "_ BAT
  16727   "RTN","CHM F351D",47, 0)
  16728    ;FOLLOWIN G GETS BEN EFICIARY &  FAMILY DE DUCT & CAT  CAP FROM  DFN FILE I F NEEDED
  16729   "RTN","CHM F351D",48, 0)
  16730    S CHDEDDT =CHDATSER
  16731   "RTN","CHM F351D",49, 0)
  16732    S:$D(@(GL PAY_"I,""I NP"")")) C HDEDDT=$P( @(GLPAY_"I ,""INP"")" ),"^",1)
  16733   "RTN","CHM F351D",50, 0)
  16734    D OLDCAT
  16735   "RTN","CHM F351D",51, 0)
  16736    S CHCYR=+ $E(CHDEDDT ,1,3)+1700
  16737   "RTN","CHM F351D",52, 0)
  16738    G:CHICF=1  L2
  16739   "RTN","CHM F351D",53, 0)
  16740    S (CHBDYT D,CHFDYTD, CHFCYTD,CH BDYTDO,CHF DYTDO,CHFC YTDO)="",( CHBDM,CHFD M,CHFCM)=0
  16741   "RTN","CHM F351D",54, 0)
  16742    S CHRSYR= (9999999-( $E(CHDEDDT ,1,3)_"000 0")) G:CHR SYR="" L2
  16743   "RTN","CHM F351D",55, 0)
  16744    S CHDFNI= 0
  16745   "RTN","CHM F351D",56, 0)
  16746    S CHDFNI= $O(@(GLDFN _"""C"",I, CHDFNI)"))  G:CHDFNI= "" L2
  16747   "RTN","CHM F351D",57, 0)
  16748    S CHDFNJ= 0
  16749   "RTN","CHM F351D",58, 0)
  16750    S CHDFNJ= $O(@(GLDFN _"""C"",I, CHDFNI,CHD FNJ)")) G: CHDFNJ=""  L2
  16751   "RTN","CHM F351D",59, 0)
  16752    S:$D(@(GL DFN_"CHDFN I,10,CHRSY R,0)")) CH FDYTDO=$P( @(GLDFN_"C HDFNI,10,C HRSYR,0)") ,"^",2),CH FCYTDO=$P( @(GLDFN_"C HDFNI,10,C HRSYR,0)") ,"^",4)
  16753   "RTN","CHM F351D",60, 0)
  16754    S:$D(@(GL DFN_"CHDFN I,10,CHRSY R,0)")) CH FDYTD=$P(@ (GLDFN_"CH DFNI,10,CH RSYR,0)"), "^",2),CHF CYTD=$P(@( GLDFN_"CHD FNI,10,CHR SYR,0)")," ^",4)
  16755   "RTN","CHM F351D",61, 0)
  16756    S:$D(@(GL DFN_"CHDFN I,1,CHRSYR ,0)")) CHF DYTDO=$P(@ (GLDFN_"CH DFNI,1,CHR SYR,0)")," ^",2),CHFC YTDO=$P(@( GLDFN_"CHD FNI,1,CHRS YR,0)"),"^ ",4)
  16757   "RTN","CHM F351D",62, 0)
  16758    S:$D(@(GL DFN_"CHDFN I,1,CHRSYR ,0)")) CHF DYTD=$P(@( GLDFN_"CHD FNI,1,CHRS YR,0)"),"^ ",2),CHFCY TD=$P(@(GL DFN_"CHDFN I,1,CHRSYR ,0)"),"^", 4)
  16759   "RTN","CHM F351D",63, 0)
  16760    ;S:$D(@(G LDFN_"CHDF NI,1,CHRSY R,0)")) CH FDYTDO=$P( @(GLDFN_"C HDFNI,1,CH RSYR,0)"), "^",3),CHF CYTDO=$P(@ (GLDFN_"CH DFNI,1,CHR SYR,0)")," ^",5)
  16761   "RTN","CHM F351D",64, 0)
  16762    S:$D(@(GL DFN_"CHDFN I,100,CHDF NJ,10,CHRS YR,0)")) C HBDYTDO=$P (@(GLDFN_" CHDFNI,100 ,CHDFNJ,10 ,CHRSYR,0) "),"^",2)
  16763   "RTN","CHM F351D",65, 0)
  16764    S:$D(@(GL DFN_"CHDFN I,100,CHDF NJ,1,CHRSY R,0)")) CH BDYTD=$P(@ (GLDFN_"CH DFNI,100,C HDFNJ,1,CH RSYR,0)"), "^",2),CHB DM=$P(@(GL DFN_"CHDFN I,100,CHDF NJ,1,CHRSY R,0)"),"^" ,3)
  16765   "RTN","CHM F351D",66, 0)
  16766   L2 ;FOLLOW ING GET NA MES,STATUS ,ASG BENE, DATE
  16767   "RTN","CHM F351D",67, 0)
  16768    S (CHVFNA M,CHDFNAM, CHBFNAM,CH MEDNAM,CHT PL,CHPZIP, CHOHIAD,CH OHIPB,CHME D)=""  ;MT N013163F   EW  BUG BE N39 6/29/1 2
  16769   "RTN","CHM F351D",68, 0)
  16770    I VFN'=""  S:$D(^CHM VEN(VFN,0) ) CHVFNAM= $P(^(0),"^ ",1)
  16771   "RTN","CHM F351D",69, 0)
  16772    D:$D(@(GL PAY_"I,7)" ))
  16773   "RTN","CHM F351D",70, 0)
  16774    .S:$P(@(G LPAY_"I,7) "),"^",11) '="" CHOHI PB=$P(@(GL PAY_"I,7)" ),"^",11)   ;MTN01316 3F  EW  BU G BEN39 6/ 29/12
  16775   "RTN","CHM F351D",71, 0)
  16776    .S:$P(@(G LPAY_"I,7) "),"^",10) '="" CHOHI AD=$P(@(GL PAY_"I,7)" ),"^",10)   ;MTN01316 3F  EW  BU G BEN39 6/ 29/12
  16777   "RTN","CHM F351D",72, 0)
  16778    .S:$P(@(G LPAY_"I,7) "),"^",9)' ="" CHTPL= $P(@(GLPAY _"I,7)")," ^",9)
  16779   "RTN","CHM F351D",73, 0)
  16780    .S:$P(@(G LPAY_"I,7) "),"^",8)' ="" CHPZIP =$P(@(GLPA Y_"I,7)"), "^",8)
  16781   "RTN","CHM F351D",74, 0)
  16782    .S:$P(@(G LPAY_"I,7) "),"^",2)' ="" CHMED= $P(@(GLPAY _"I,7)")," ^",2)  ;MT N013163F   EW  BUG BE N39 6/29/1 2
  16783   "RTN","CHM F351D",75, 0)
  16784    .Q:$P(@(G LPAY_"I,7) "),"^",1)= ""  S MDPT =$P(@(GLPA Y_"I,7)"), "^",1)
  16785   "RTN","CHM F351D",76, 0)
  16786    .S:$D(^CH MVEN(MDPT, 0)) CHMEDN AM=$P(^(0) ,"^",1)
  16787   "RTN","CHM F351D",77, 0)
  16788    I $D(@(GL PAY_"I,""V EN-II"")") ) D  ;CPE0 01-020, 02 1 and 022
  16789   "RTN","CHM F351D",78, 0)
  16790    .S ^TMP($ J,"VEN-II" )=@(GLPAY_ "I,""VEN-I I"")")
  16791   "RTN","CHM F351D",79, 0)
  16792    S:$D(@(GL ELG_"DFN,0 )")) CHDFN AM=$P(@(GL ELG_"DFN,0 )"),"^",1)
  16793   "RTN","CHM F351D",80, 0)
  16794    S (CHBFNA M,CHBSEX,C HBDOB)=""
  16795   "RTN","CHM F351D",81, 0)
  16796    I $D(@(GL ELG_"DFN,1 00,BFN,0)" )) D
  16797   "RTN","CHM F351D",82, 0)
  16798    .S BENREC ="",BENREC =@(GLELG_" DFN,100,BF N,0)")
  16799   "RTN","CHM F351D",83, 0)
  16800    .S CHBFNA M=$P(BENRE C,"^",1)
  16801   "RTN","CHM F351D",84, 0)
  16802    .S CHBSEX =$P(BENREC ,"^",2)
  16803   "RTN","CHM F351D",85, 0)
  16804    .S CHBDOB =$P(BENREC ,"^",3)
  16805   "RTN","CHM F351D",86, 0)
  16806    .S CHBDOB =$E(CHBDOB ,4,5)_"/"_ $E(CHBDOB, 6,7)_"/"_$ E(CHBDOB,2 ,3)
  16807   "RTN","CHM F351D",87, 0)
  16808    I CHCLST' >6 S CHCLS TP=$S(CHCL ST=0:"Reje cted",CHCL ST=1:"In-P rogress",C HCLST=2:"P ayment Req .",CHCLST= 3:"Check I ssued",CHC LST=4:"Com plete",CHC LST=5:"Adj udicated", CHCLST=6:" Rej Capp/C alm",1:"")
  16809   "RTN","CHM F351D",88, 0)
  16810    I CHCLST> 6 S CHCLST P=$S(CHCLS T=7:"Admin . Susp",CH CLST=8:"Ap p Capp/Cal m",CHCLST= 9:"Manual  Proc",CHCL ST=10:"Del eted",CHCL ST=11:"Voi ded",CHCLS T=12:"Reve rsed",1:"" )
  16811   "RTN","CHM F351D",89, 0)
  16812    S CHASOB= $S(CHASOB= 1:"Yes",1: "No")
  16813   "RTN","CHM F351D",90, 0)
  16814    S Y=CHDAT SER X ^DD( "DD") S CH DATSER=Y
  16815   "RTN","CHM F351D",91, 0)
  16816    ; HAVE TH E 1 NODE,  COMMON NOD E. GET THE  TYPE AND  THAT WILL
  16817   "RTN","CHM F351D",92, 0)
  16818    ; DETERMI NE WHAT NO DE TO $O O N TO SET U P THE OTHE R ^%ZTSK N ODE.
  16819   "RTN","CHM F351D",93, 0)
  16820    S (CHTYPE P,CHT,CHS) =""
  16821   "RTN","CHM F351D",94, 0)
  16822    S CHTYPEP =$S(CHTYPE =1:"Inpati ent",CHTYP E=2:"Outpa tient",CHT YPE=3:"Pha rmacy",CHT YPE=4:"Dur able Medj. ",CHTYPE=5 :"Dental", CHTYPE=6:" Travel",1: "Other")
  16823   "RTN","CHM F351D",95, 0)
  16824    ;LOOPING  THRU THE A PPROPRIATE  NODE.
  16825   "RTN","CHM F351D",96, 0)
  16826    S J1=0
  16827   "RTN","CHM F351D",97, 0)
  16828    S CHT=$S( CHTYPE=1:" INP",CHTYP E=2:"OPT", CHTYPE=3:" PHAR",CHTY PE=4:"DME" ,CHTYPE=5: "DEN",CHTY PE=6:"OPT" ,CHTYPE=7: "OPT",1:"" )
  16829   "RTN","CHM F351D",98, 0)
  16830    I CHT="OP T" S CHS=" OPT-DX" D  GETJ S CHS ="OPT-PROC " D GETJ S  CHS="PHAR M" D GETJ  G L5
  16831   "RTN","CHM F351D",99, 0)
  16832    I CHT="IN P" S CHS=" INP-DX" D  GETJ S CHS ="INP-PROC " D GETJ S  CHS="INP- ITEM" D GE TJ S CHS=" INP-NC" D  GETJ G L5
  16833   "RTN","CHM F351D",100 ,0)
  16834    I CHT="DE N" S CHS=" DEN-PROC"  D GETJ S C HS="DEN-DX " D GETJ G  L5
  16835   "RTN","CHM F351D",101 ,0)
  16836    I CHT="DM E" S CHS=" DME" D GET J S CHS="D ME-DX" D G ETJ S CHS= "DME-SUPPL Y" D GETJ  G L5
  16837   "RTN","CHM F351D",102 ,0)
  16838    I CHT="PH AR" S CHS= "PHARM" D  GETJ G L5
  16839   "RTN","CHM F351D",103 ,0)
  16840   L5 S ^TMP( $J,"CL",CH CLN)=CHCLS TP_"^"_CHV FNAM_"^"_C HTYPEP_"^" _CHASOB_"^ "_CHDATSER _"^"_CHDFN AM_"^"_CHB FNAM_"^"_C HTOTAL_"^" _CHCALCT_" ^"_CHAMTDE D_"^"_CHCO ST
  16841   "RTN","CHM F351D",104 ,0)
  16842    ;S ^TMP($ J,"CL",CHC LN)=^TMP($ J,"CL",CHC LN)_"^"_CH OTHER_"^"_ CHCLAMT_"^ "_CHBPM_"^ "_CHVPMT_" ^"_CHBPMT_ "^"_CHCCA_ "^"_CHICF_ "^"_CHMEDN AM_"^"_CHP OS_"^"_CHB SEX_"^"_CH BDOB_"^"_C HPROG_"^"_ CHPR_"^"_C HTPL_"^"_C HPZIP   ;S KD 11-1-06  MC284 CHP R (24P)
  16843   "RTN","CHM F351D",105 ,0)
  16844    S ^TMP($J ,"CL",CHCL N)=^TMP($J ,"CL",CHCL N)_"^"_CHO THER_"^"_C HCLAMT_"^" _CHBPM_"^" _CHVPMT_"^ "_CHBPMT_" ^"_CHCCA_" ^"_CHICF_" ^"_CHMEDNA M_"^"_CHPO S_"^"_CHBS EX_"^"_CHB DOB_"^"_CH PROG_"^"_C HPR_"^"_CH TPL_"^"_CH PZIP_"^"_C HOHIAD_"^" _CHOHIPB_" ^"_CHMED   ;MTN013163 F  EW  BUG  BEN38 6/2 9/12
  16845   "RTN","CHM F351D",106 ,0)
  16846    S:((CHCLS TP'="In-Pr ogress")!( $D(^CHMNHQ ("C",I))))  ^TMP($J," DED",CHCLN )=CHBDYTD_ "^"_CHBDYT DO_"^"_CHF DYTD_"^"_C HFDYTDO_"^ "_CHFCYTD_ "^"_CHFCYT DO_"^"_CHB DM_"^"_CHF DM_"^"_CHF CM_"^"_CHC YR
  16847   "RTN","CHM F351D",107 ,0)
  16848    S DISCH=" "
  16849   "RTN","CHM F351D",108 ,0)
  16850    I CHTYPE= 1 S DISCH= ""
  16851   "RTN","CHM F351D",109 ,0)
  16852    S:$D(@(GL PAY_"I,""I NP"")")) D ISCH=$P(@( GLPAY_"I," "INP"")"), "^",1)
  16853   "RTN","CHM F351D",110 ,0)
  16854    S:DISCH'= "" ^TMP($J ,"DISCH",C HCLN)=DISC H
  16855   "RTN","CHM F351D",111 ,0)
  16856    S (METH,C HMETH)=""
  16857   "RTN","CHM F351D",112 ,0)
  16858    I $D(@(GL PAY_"I,""C OMMON"")") ) I CHTYPE =1 S METH= $P(@(GLPAY _"I,""COMM ON"")"),"^ ",16) S CH METH=$S(ME TH=0:"PPS" ,METH=1:"C TC",METH=2 :"Item",ME TH=3:"LVMH ",METH=4:" HVMH",METH =10:"RTC", 1:"")
  16859   "RTN","CHM F351D",113 ,0)
  16860    S:CHTYPE= 1 ^TMP($J, "INP",CHCL N)=CHDRG_" ^"_CHDRGST AT_"^"_CHM ETH_"^"_ME TH
  16861   "RTN","CHM F351D",114 ,0)
  16862    S J=0 F K =0:0 S J=$ O(CHPDI(J) ) Q:'J  S  ^TMP($J,"P DI",CHCLN, J)=CHPDI(J )
  16863   "RTN","CHM F351D",115 ,0)
  16864    ;D:$P(^TM P($J,1),"^ ",4)'="" Q UE
  16865   "RTN","CHM F351D",116 ,0)
  16866    D ^CHMF35 1F  ;CHECK S FOR AUDI T SUP,EOB, MCCR,MISS  DATA,PROB  SUP,QA
  16867   "RTN","CHM F351D",117 ,0)
  16868    D ^CHMF35 1G  ;CHECK S VENDOR,E LEGIB,SNA  CALM,SNA C APP,REOPEN ,DUPLICATE
  16869   "RTN","CHM F351D",118 ,0)
  16870    D ^CHMF35 1H  ;CHECK S REOPEN Q UEUE,WORKM ANS COMP,G ROUPER OUT ,OBLIGATIO N
  16871   "RTN","CHM F351D",119 ,0)
  16872    D ^CHMF35 1J  ;CHECK S ALL REJE CTION PIEC ES
  16873   "RTN","CHM F351D",120 ,0)
  16874    D EDI
  16875   "RTN","CHM F351D",121 ,0)
  16876   END K I,X, CHCLN,CHCL ST,CHASOB, CHTYPE,CHD ATSER,DFN, BFN,VFN
  16877   "RTN","CHM F351D",122 ,0)
  16878    K CHTOTAL ,CHCALCT,C HVFNAM,CHD FNAM,CHBFN AM,CHCLSTP ,CHDMEDEL
  16879   "RTN","CHM F351D",123 ,0)
  16880    K CHCLAMT ,CHAMTDED, CHCOST,CHO THER,Y,CHT YPEP,CHT,C HS,CHIN,J, J1,J2
  16881   "RTN","CHM F351D",124 ,0)
  16882    K CHPROCE D,CHNDC,CH DIAG,CHCHA RGE,CHALLO W,CHRES,CH RESULT,CHI CF,CHCCA
  16883   "RTN","CHM F351D",125 ,0)
  16884    K CHQSTAT ,CHQNAM,CH DMEDEL,CHD ELAA,CHDRG ,CHDRGOK,C HDRGSTAT,C HVPMT,CHBP MT
  16885   "RTN","CHM F351D",126 ,0)
  16886    K CHBDYDT ,CHFDYDT,C HFCYDT,CHB DM,CHFDM,C HFCM,CHRYR ,CHRSYR,CH DFNI,CHDFN J
  16887   "RTN","CHM F351D",127 ,0)
  16888    K CHSERV, CHPLZIP
  16889   "RTN","CHM F351D",128 ,0)
  16890   Q5 Q
  16891   "RTN","CHM F351D",129 ,0)
  16892    Q:$D(VIEW FL)
  16893   "RTN","CHM F351D",130 ,0)
  16894    S %ZIS="Q ",IOP="Q;" _CHMFION D  ^%ZIS Q:P OP
  16895   "RTN","CHM F351D",131 ,0)
  16896    S ZTRTN=" ^CHMF351P" ,ZTDTH=$H, ZTIO=CHMFI ON,ZTSAVE( "^TMP($J," )=""
  16897   "RTN","CHM F351D",132 ,0)
  16898    D ^%ZTLOA D Q
  16899   "RTN","CHM F351D",133 ,0)
  16900   RESET S (D FN,BFN,VFN ,X)=-1 S V FN=""
  16901   "RTN","CHM F351D",134 ,0)
  16902    S (CHCLN, CHCLST,CHA SOB,CHTYPE ,CHDATSER) =""
  16903   "RTN","CHM F351D",135 ,0)
  16904    S (CHTOTA L,CHCALCT, CHVFNAM,CH DFNAM,CHBF NAM,CHCLST P,CHDMEDEL )="" Q
  16905   "RTN","CHM F351D",136 ,0)
  16906   GETJ I CHS ="DME" I $ D(@(GLPAY_ "I,""DME"" )")) S CHD MEDEL=$P(@ (GLPAY_"I, ""DME"")") ,"^",1),CH DELAA=$P(@ (GLPAY_"I, ""DME"")") ,"^",2) S  J1=J1+1,^T MP($J,"MP" ,CHCLN,J1) ="^^Deliv^ "_CHDMEDEL _"^"_CHDEL AA_"^      " Q
  16907   "RTN","CHM F351D",137 ,0)
  16908    F J=0:0 S  J=$O(@(GL PAY_"I,CHS ,J)")) Q:' J  S J1=J1 +1 D:CHT=" INP" ^CHMF 351I D:CHT '="INP" ^C HMF351E
  16909   "RTN","CHM F351D",138 ,0)
  16910    ;^CHMF351 E GETS PRO CED CODE,C HARGES,DIA GNOS,RESUL T AND SETS  TASK
  16911   "RTN","CHM F351D",139 ,0)
  16912    Q
  16913   "RTN","CHM F351D",140 ,0)
  16914   OLDCAT S P GDT=0
  16915   "RTN","CHM F351D",141 ,0)
  16916    S PGDT=$O (@(GLELG_" DFN,100,BF N,108,PGDT )")) Q:'PG DT
  16917   "RTN","CHM F351D",142 ,0)
  16918    Q:'$D(@(G LELG_"DFN, 100,BFN,10 8,PGDT,0)" ))
  16919   "RTN","CHM F351D",143 ,0)
  16920    S PGDAT=$ P(@(GLELG_ "DFN,100,B FN,108,PGD T,0)"),"^" ,1)
  16921   "RTN","CHM F351D",144 ,0)
  16922    Q:PGDAT<2 921001  Q: PGDAT>2931 232
  16923   "RTN","CHM F351D",145 ,0)
  16924    S PGDOS=$ P(@(GLPAY_ "I,0)"),"^ ",8)
  16925   "RTN","CHM F351D",146 ,0)
  16926    I $P(@(GL PAY_"I,0)" ),"^",7)=1
  16927   "RTN","CHM F351D",147 ,0)
  16928    S:$D(@(GL PAY_"I,""I NP"")")) P GDOS=$P(@( GLPAY_"I," "INP"")"), "^",1)
  16929   "RTN","CHM F351D",148 ,0)
  16930    S:'$D(PGD OS) PGDOS= ""
  16931   "RTN","CHM F351D",149 ,0)
  16932    Q:PGDOS<2 921001  Q: PGDOS>2931 232  S PGD OS=2930101
  16933   "RTN","CHM F351D",150 ,0)
  16934    I PGDAT<2 931001 D   Q
  16935   "RTN","CHM F351D",151 ,0)
  16936    .I (PGDOS >2920930)& (PGDOS<293 1001) S PG DOS=293010 1
  16937   "RTN","CHM F351D",152 ,0)
  16938    .S CHDEDD T=PGDOS
  16939   "RTN","CHM F351D",153 ,0)
  16940    I PGDOS>2 930930 S P GDOS=29401 01,CHDEDDT =PGDOS
  16941   "RTN","CHM F351D",154 ,0)
  16942    Q
  16943   "RTN","CHM F351D",155 ,0)
  16944    ;
  16945   "RTN","CHM F351D",156 ,0)
  16946   EDI S:'$D( ZHI) ZHI=0
  16947   "RTN","CHM F351D",157 ,0)
  16948    n ZRX
  16949   "RTN","CHM F351D",158 ,0)
  16950    S ZCL=""
  16951   "RTN","CHM F351D",159 ,0)
  16952    S ZCL=$O( @(GLPAY_"" "B"",CHCLN ,0)")) Q:' ZCL
  16953   "RTN","CHM F351D",160 ,0)
  16954    Q:'$D(@(G LPAY_"ZCL, ""ZEMC"")" ))
  16955   "RTN","CHM F351D",161 ,0)
  16956    S EDITYP= ""
  16957   "RTN","CHM F351D",162 ,0)
  16958    S EDITYP= $O(@(GLPAY _"ZCL,""ZE MC"",EDITY P)")) S:ED ITYP="" ED ITYP="Unkn own"
  16959   "RTN","CHM F351D",163 ,0)
  16960    ;Start CR # DEV00937 3
  16961   "RTN","CHM F351D",164 ,0)
  16962    ; Determi ne if it's  a COB SXC  Claim
  16963   "RTN","CHM F351D",165 ,0)
  16964    I EDITYP= "SXC" D
  16965   "RTN","CHM F351D",166 ,0)
  16966    .S ZRX=$O (@(GLPAY_" ZCL,""ZEMC "",EDITYP, """")")) Q :ZRX=""
  16967   "RTN","CHM F351D",167 ,0)
  16968    .S ZRX=+$ G(@(GLPAY_ "ZCL,""ZEM C"",EDITYP ,ZRX)"))
  16969   "RTN","CHM F351D",168 ,0)
  16970    .Q:ZRX="" !(ZRX=0)
  16971   "RTN","CHM F351D",169 ,0)
  16972    .I $P($G( ^CHMXRX(ZR X,0)),"^", 8)="Y" S E DITYP="SXC COB"
  16973   "RTN","CHM F351D",170 ,0)
  16974    .I $P($G( ^CHMXRX(ZR X,0)),"^", 8)="K" S E DITYP="MCD SXC"
  16975   "RTN","CHM F351D",171 ,0)
  16976    .I $P($G( ^CHMXRX(ZR X,0)),"^", 8)="Z" S E DITYP="CIT ISXC"  ; A DDED "CITI SXC" EDITY PE 3/8/201 2
  16977   "RTN","CHM F351D",172 ,0)
  16978    ;End CR#  DEV009373
  16979   "RTN","CHM F351D",173 ,0)
  16980    F ZI=0:0  S ZI=$O(^T MP($J,"QUE ",CHCLN,ZI )) Q:'ZI   S ZHI=ZI
  16981   "RTN","CHM F351D",174 ,0)
  16982    S ZI=ZHI+ 1,^TMP($J, "QUE",CHCL N,ZI)="EDI : "_EDITYP
  16983   "RTN","CHM F351D",175 ,0)
  16984    Q
  16985   "RTN","CHM F351D",176 ,0)
  16986    ;
  16987   "RTN","CHM F351D",177 ,0)
  16988   GETPYMNT(P DI,PAIDARY ) ;Get the  total pay ment amoun t of all c laims for  Original &  Current P DIs. CPE00 5-095.
  16989   "RTN","CHM F351D",178 ,0)
  16990    S PDI=$G( PDI),PAIDA RY=$G(PAID ARY)
  16991   "RTN","CHM F351D",179 ,0)
  16992    N ARYCNT, IEN,CHMFPD I,CHMPDI,C HSUM,CHTOT SUM,CURRPD I
  16993   "RTN","CHM F351D",180 ,0)
  16994    I $D(^CHM IMG("A-FIR ST",PDI))  D
  16995   "RTN","CHM F351D",181 ,0)
  16996    .S CHMPDI =$O(^CHMIM G("A-FIRST ",PDI,""))
  16997   "RTN","CHM F351D",182 ,0)
  16998    .S CURRPD I=$O(^CHMI MG("A-ALL" ,CHMPDI,"" ),-1)
  16999   "RTN","CHM F351D",183 ,0)
  17000    .S PAIDAR Y(1)=CURRP DI  ;Curre nt PDI alw ays first.
  17001   "RTN","CHM F351D",184 ,0)
  17002    .I $D(^CH MIMG("A-AL L",CHMPDI) ) D
  17003   "RTN","CHM F351D",185 ,0)
  17004    ..S CHMFP DI=0,ARYCN T=2
  17005   "RTN","CHM F351D",186 ,0)
  17006    ..F  S CH MFPDI=$O(^ CHMIMG("A- ALL",CHMPD I,CHMFPDI) ) Q:CHMFPD I=""  D
  17007   "RTN","CHM F351D",187 ,0)
  17008    ...D TOTP YMNT(CHMFP DI,.ARYCNT ,.PAIDARY)
  17009   "RTN","CHM F351D",188 ,0)
  17010    ...I ARYC NT'=^CHMIM G("A-ALL", CHMPDI,0)  S ARYCNT=A RYCNT+1
  17011   "RTN","CHM F351D",189 ,0)
  17012    ..S PAIDA RY=ARYCNT
  17013   "RTN","CHM F351D",190 ,0)
  17014    I '$D(^CH MIMG("A-FI RST",PDI))  D
  17015   "RTN","CHM F351D",191 ,0)
  17016    .S PAIDAR Y(1)=PDI
  17017   "RTN","CHM F351D",192 ,0)
  17018    .D TOTPYM NT(PDI,.AR YCNT,.PAID ARY)
  17019   "RTN","CHM F351D",193 ,0)
  17020    .S PAIDAR Y=1
  17021   "RTN","CHM F351D",194 ,0)
  17022    Q
  17023   "RTN","CHM F351D",195 ,0)
  17024    ;
  17025   "RTN","CHM F351D",196 ,0)
  17026   TOTPYMNT(C HMFPDI,ARY CNT,PAIDAR Y) ;CPE005 -095
  17027   "RTN","CHM F351D",197 ,0)
  17028    N IEN,CHS UM,CHTOTSU M
  17029   "RTN","CHM F351D",198 ,0)
  17030    S CHTOTSU M=0
  17031   "RTN","CHM F351D",199 ,0)
  17032    S IEN=""  F  S IEN=$ O(^CHMPAY( "C",CHMFPD I,IEN)) Q: IEN=""  D
  17033   "RTN","CHM F351D",200 ,0)
  17034    .S CHSUM= $P($G(^CHM PAY(IEN,1) ),"^")
  17035   "RTN","CHM F351D",201 ,0)
  17036    .S CHTOTS UM=CHTOTSU M+CHSUM  ; Get the su m of all c laims for  this PDI.
  17037   "RTN","CHM F351D",202 ,0)
  17038    I CHMFPDI =$P(PAIDAR Y(1),"^")  S PAIDARY( 1)=PAIDARY (1)_"^"_CH TOTSUM Q   ;Always pu t Current  PDI on top .
  17039   "RTN","CHM F351D",203 ,0)
  17040    S PAIDARY (ARYCNT)=C HMFPDI_"^" _CHTOTSUM
  17041   "RTN","CHM F351D",204 ,0)
  17042    Q
  17043   "RTN","CHM F351P")
  17044   0^34^B1605 83754
  17045   "RTN","CHM F351P",1,0 )
  17046   CHMF351P ; DEH/DEN;CH AMVPA POST -PROC CLAI M REPORT P RINT;Feb 0 6, 2019@10 :03:10
  17047   "RTN","CHM F351P",2,0 )
  17048    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  17049   "RTN","CHM F351P",3,0 )
  17050    ;CPTS #10 846* - PEJ  8/15/96,  11008* - J LR, #12621 * (RLC), # 13367* (RL C)
  17051   "RTN","CHM F351P",4,0 )
  17052    ;CPTS #13 739* (RLC) , #13782*  (RLC), #15 358 (RLC)
  17053   "RTN","CHM F351P",5,0 )
  17054    ;TT 00010 8 JEH 1/4/ 10 - SPLIT  TOS INCID ENTAL DRUG S
  17055   "RTN","CHM F351P",6,0 )
  17056    ;DEV00480 5 1/20/201 0 AEB
  17057   "RTN","CHM F351P",7,0 )
  17058    ;DEV7820  EW 2/23/11  Add line  level data
  17059   "RTN","CHM F351P",8,0 )
  17060    ;DEV00369 6 EW 4/4/1 1
  17061   "RTN","CHM F351P",9,0 )
  17062    ;DEV01938 8 11/5/13  DGC - Chan ge in INP  processing
  17063   "RTN","CHM F351P",10, 0)
  17064    ;CFS 02/2 0/2018 - C PE001-020,  021 and 0 22 Write P L ZIP info rmation.
  17065   "RTN","CHM F351P",11, 0)
  17066   ENTER ;
  17067   "RTN","CHM F351P",12, 0)
  17068   V1 I $D(VI EWFL) X CH RESET S EX FLG=0
  17069   "RTN","CHM F351P",13, 0)
  17070    S (CHCLN, CHTTT)="", (CHPG,NTNU M)=0 S %H= $H D YX^%D TC S CHDAT E=$P(Y,"@" ,1)
  17071   "RTN","CHM F351P",14, 0)
  17072   L1 S CHCLN =$O(^TMP($ J,"CL",CHC LN)) G END :CHCLN=""  W:'$D(VIEW FL) #
  17073   "RTN","CHM F351P",15, 0)
  17074    G:'$D(^CH MINDEX("B" ,CHCLN)) L 1 S CHCCLM =""
  17075   "RTN","CHM F351P",16, 0)
  17076    S CHCCLM= $O(^CHMIND EX("B",CHC LN,CHCCLM) ) G:CHCCLM ="" L1
  17077   "RTN","CHM F351P",17, 0)
  17078    ;D GTPTR^ CHMKPPR1
  17079   "RTN","CHM F351P",18, 0)
  17080    S X1=CHCC LM D PROGT YP^CHFCD00 1
  17081   "RTN","CHM F351P",19, 0)
  17082    G:'$D(@(G LPAY_"""B" ",CHCLN)") ) L1
  17083   "RTN","CHM F351P",20, 0)
  17084    S AUTODIS T=0
  17085   "RTN","CHM F351P",21, 0)
  17086    I $D(@(GL PAY_"CHCCL M,""COMMON "")")) S A UTODIST=$P (@(GLPAY_" CHCCLM,""C OMMON"")") ,"^",18)
  17087   "RTN","CHM F351P",22, 0)
  17088    K LIREAS, LNREAS,CLR EAS,RESON, CHECKS S ( PAMT1,PCHM LN,RND)=""
  17089   "RTN","CHM F351P",23, 0)
  17090    D HEAD ;D GC 11/4/13  DEV019388 8 - ADDED
  17091   "RTN","CHM F351P",24, 0)
  17092    ;I $P(^TM P($J,"CL", CHCLN),"^" ,3)'="Inpa tient" D H EAD  ;MTN0 13163F  EW   BUG PPR3 6 10/5/12  ;DGC 11/4/ 13 DEV0193 888 - REMO VED
  17093   "RTN","CHM F351P",25, 0)
  17094    ;I $P(^TM P($J,"CL", CHCLN),"^" ,3)="Inpat ient" D HE ADI  ;MTN0 13163F  EW   BUG PPR3 6 10/5/12  ;DGC 11/4/ 13 DEV0193 888 - REMO VED
  17095   "RTN","CHM F351P",26, 0)
  17096    S X=^TMP( $J,"CL",CH CLN),CHPRO G=$P(X,"^" ,23)  ;MTN 013163F  E W  BUG PPR 35 10/5/12
  17097   "RTN","CHM F351P",27, 0)
  17098    S CHTTT=$ P(X,"^",3)
  17099   "RTN","CHM F351P",28, 0)
  17100    ;I $P(X," ^",3)="Inp atient" D  ^CHMF351Q  G L1  ;MTN 013163F  E W  BUG PPR 36 10/5/12  ;DGC 11/4 /13 DEV019 3888 - REM OVED
  17101   "RTN","CHM F351P",29, 0)
  17102    S INP=""  S:$D(^TMP( $J,"INP",C HCLN)) INP =(^(CHCLN) )  ;DGC 11 /6/13 DEV0 19388
  17103   "RTN","CHM F351P",30, 0)
  17104    S DISCH=" " S:$D(^TM P($J,"DISC H",CHCLN))  DISCH=(^( CHCLN))  ; DGC 11/6/1 3 DEV01938 8
  17105   "RTN","CHM F351P",31, 0)
  17106    I DISCH'= "" S Y=DIS CH X ^DD(" DD") S DIS CH=Y  ;DGC  11/6/13 D EV019388
  17107   "RTN","CHM F351P",32, 0)
  17108    S X4="",J =0 F K=0:0  S J=$O(^T MP($J,"PDI ",CHCLN,J) ) Q:J'?1N. N  S:X4'=" " X4=X4_"^ "_^TMP($J, "PDI",CHCL N,J) S:X4= "" X4=^TMP ($J,"PDI", CHCLN,J)
  17109   "RTN","CHM F351P",33, 0)
  17110    I $P(^TMP ($J,"CL",C HCLN),"^", 3)="Inpati ent" D  Q   ;DGC 1/13 /14 BUG019 399 - ADDE D TO RESTO RE MID HEA DER TO PRE  SLLA
  17111   "RTN","CHM F351P",34, 0)
  17112    .D TOP
  17113   "RTN","CHM F351P",35, 0)
  17114    .D MIDHED ^CHMF351Q
  17115   "RTN","CHM F351P",36, 0)
  17116    .D L3^CHM F351Q
  17117   "RTN","CHM F351P",37, 0)
  17118    .D BOT^CH MF351U
  17119   "RTN","CHM F351P",38, 0)
  17120    .D L7
  17121   "RTN","CHM F351P",39, 0)
  17122    D TOP S J =0 D MIDHE D Q:EXFLG= 1  K CODES
  17123   "RTN","CHM F351P",40, 0)
  17124   L3 S J=$O( ^TMP($J,"M P",CHCLN,J )) G L5:'J
  17125   "RTN","CHM F351P",41, 0)
  17126    S X1=^TMP ($J,"MP",C HCLN,J)
  17127   "RTN","CHM F351P",42, 0)
  17128    D SORT Q: EXFLG=1  G  L3
  17129   "RTN","CHM F351P",43, 0)
  17130   L5 D MID D  BOT^CHMF3 51U Q:EXFL G=1
  17131   "RTN","CHM F351P",44, 0)
  17132   L6 G:'$D(^ TMP($J,"DE D",CHCLN))  L7
  17133   "RTN","CHM F351P",45, 0)
  17134    S X3=^TMP ($J,"DED", CHCLN) D D EDT S J=0
  17135   "RTN","CHM F351P",46, 0)
  17136    ;D MULTI
  17137   "RTN","CHM F351P",47, 0)
  17138   L7 S J=$O( ^TMP($J,"Q UE",CHCLN, J)) G:'J L 8
  17139   "RTN","CHM F351P",48, 0)
  17140    S X2=^TMP ($J,"QUE", CHCLN,J) D  QUEUE Q:E XFLG=1  G  L7
  17141   "RTN","CHM F351P",49, 0)
  17142   L8 D REASO N,CHECKS G  L1
  17143   "RTN","CHM F351P",50, 0)
  17144   END K CHCL N,CHPG,CHD ATE,X,X1,X 2,Y,J,CHTI ME Q
  17145   "RTN","CHM F351P",51, 0)
  17146   MULTI S ZC L=""
  17147   "RTN","CHM F351P",52, 0)
  17148    S ZCL=$O( @(GLPAY_"" "B"",CHCLN ,0)")) Q:' ZCL
  17149   "RTN","CHM F351P",53, 0)
  17150    Q:'$D(@(G LPAY_"ZCL, 4)"))  S Z I=""
  17151   "RTN","CHM F351P",54, 0)
  17152    S ZI=$O(@ (GLPAY_"ZC L,4,0)"))  Q:'ZI
  17153   "RTN","CHM F351P",55, 0)
  17154    Q:'$O(@(G LPAY_"ZCL, 4,ZI)"))   S ZI="",ZH I=0
  17155   "RTN","CHM F351P",56, 0)
  17156    F ZI=0:0  S ZI=$O(^T MP($J,"QUE ",CHCLN,ZI )) Q:'ZI   S ZHI=ZI
  17157   "RTN","CHM F351P",57, 0)
  17158    S ZI=ZHI+ 1,^TMP($J, "QUE",CHCL N,ZI)="Mul tiple Reas " Q
  17159   "RTN","CHM F351P",58, 0)
  17160   HEAD S CHP G=CHPG+1
  17161   "RTN","CHM F351P",59, 0)
  17162    ;-------- ---------- --------DE V7820 EW 2 /23/11  ST ART
  17163   "RTN","CHM F351P",60, 0)
  17164    S TITLE=" Health Adm inistratio n Center"  S TAB=((13 2-$L(TITLE ))/2)
  17165   "RTN","CHM F351P",61, 0)
  17166    W "DUZ: " ,DUZ,?TAB, TITLE,?123 ,"Page: ", CHPG
  17167   "RTN","CHM F351P",62, 0)
  17168    W !,"Date : ",CHDATE ,?TAB,"Pos t-Processi ng Claim R eport" K T AB,TITLE
  17169   "RTN","CHM F351P",63, 0)
  17170    ;-------- ---------- --------DE V7820 EW 2 /23/11  EN D
  17171   "RTN","CHM F351P",64, 0)
  17172    W !,"Time : " D TIME  W CHTIME  Q
  17173   "RTN","CHM F351P",65, 0)
  17174   HEADI S CH PG=CHPG+1   ;MTN01316 3F  EW  BU G PPR35 10 /5/12
  17175   "RTN","CHM F351P",66, 0)
  17176    S TITLE=" Health Adm inistratio n Center"  S TAB=((80 -$L(TITLE) )/2)  ;MTN 013163F  E W  BUG PPR 35 10/5/12
  17177   "RTN","CHM F351P",67, 0)
  17178    W "DUZ: " ,DUZ,?TAB, TITLE,?73, "Page: ",C HPG  ;MTN0 13163F  EW   BUG PPR3 5 10/5/12
  17179   "RTN","CHM F351P",68, 0)
  17180    W !,"Date : ",CHDATE ,?TAB,"Pos t-Processi ng Claim R eport" K T AB,TITLE   ;MTN013163 F  EW  BUG  PPR35 10/ 5/12
  17181   "RTN","CHM F351P",69, 0)
  17182    W !,"Time : " D TIME  W CHTIME  Q  ;MTN013 163F  EW   BUG PPR35  10/5/12
  17183   "RTN","CHM F351P",70, 0)
  17184   TOP ;W !!! ,"      PD I: " S J=1  F K=0:0 Q :X4=""  W: J>1 ! W ?1 4,$P(X4,"^ ",1) S J=J +1,X4=$P(X 4,"^",2,99 9)
  17185   "RTN","CHM F351P",71, 0)
  17186    ;
  17187   "RTN","CHM F351P",72, 0)
  17188    S CHPVPTR ="",CHPTID ="",CHPVAC ="",CHPIM= "",CHEXP=" UNK"  ;DGC  11/6/13 D EV019388
  17189   "RTN","CHM F351P",73, 0)
  17190    S CHPPTR= 0
  17191   "RTN","CHM F351P",74, 0)
  17192    S CHPPTR= $O(@(GLPAY _"""B"",CH CLN,CHPPTR )"))
  17193   "RTN","CHM F351P",75, 0)
  17194    S CHPVPTR =$P(@(GLPA Y_"CHPPTR, 0)"),U,3)
  17195   "RTN","CHM F351P",76, 0)
  17196    I CHPVPTR  I $D(^CHM VEN(CHPVPT R,0)) D
  17197   "RTN","CHM F351P",77, 0)
  17198    .S CHPTID =$P(^CHMVE N(CHPVPTR, 0),U,3)
  17199   "RTN","CHM F351P",78, 0)
  17200    .S CHPVAC =$P(^CHMVE N(CHPVPTR, 0),U,23)
  17201   "RTN","CHM F351P",79, 0)
  17202    .S CHPIM= "" S:$D(^C HMVEN(CHPV PTR,14)) C HPIM=$P(^C HMVEN(CHPV PTR,14),U, 1)
  17203   "RTN","CHM F351P",80, 0)
  17204    .S CHEXP= $$POACK^CH TFLIB3(CHP VPTR)  ;DG C 11/6/13  DEV019388  - BEGIN
  17205   "RTN","CHM F351P",81, 0)
  17206    S:CHEXP=0  CHEXP="N"  S:CHEXP=1  CHEXP="Y"
  17207   "RTN","CHM F351P",82, 0)
  17208    S CHTOB=" " I $D(@(G LPAY_"CHPP TR,7)")) D   ;DGC 11/ 6/13 DEV01 9388
  17209   "RTN","CHM F351P",83, 0)
  17210    .S CHTOB= $P(@(GLPAY _"CHPPTR,7 )"),U,6)   ;DGC 11/6/ 13 DEV0193 88
  17211   "RTN","CHM F351P",84, 0)
  17212    S CHDISST P="" I $D( @(GLPAY_"C HPPTR,""IN P"")")) D
  17213   "RTN","CHM F351P",85, 0)
  17214    .S CHDISS T=$P(@(GLP AY_"CHPPTR ,""INP"")" ),"^",2)
  17215   "RTN","CHM F351P",86, 0)
  17216    .I CHDISS T I $D(^CH MDIC(74100 2.12,CHDIS ST,0)) D
  17217   "RTN","CHM F351P",87, 0)
  17218    ..S CHDIS STP=$P(^(0 ),"^",1)_"  - "_$E($P (^(0),"^", 2),1,9)  ; DGC 11/6/1 3 DEV01938 8 - END
  17219   "RTN","CHM F351P",88, 0)
  17220    S PDICPT= CHPPTR D P DIS
  17221   "RTN","CHM F351P",89, 0)
  17222    ;COLUMN S ETUP ONLY  NEED TO CH ANGE HERE  FOR TOP DG C 1/15/14  BUG019388  - BEGIN
  17223   "RTN","CHM F351P",90, 0)
  17224    S COL1=10 ,COL2=11,C OL3=40,COL 4=41,COL5= 116,COL6=1 17
  17225   "RTN","CHM F351P",91, 0)
  17226    W !!,?(CO L1-$L("PDI :")),"PDI: ",?COL2,CH PDI_"-"_CH DOC,?(COL3 -$L("BATCH :")),"BATC H:",?COL4, CHBATCH
  17227   "RTN","CHM F351P",92, 0)
  17228    W ?(COL5- $L("Claim  #:")),"Cla im #:",?CO L6,CHCLN
  17229   "RTN","CHM F351P",93, 0)
  17230    I $D(@(GL PAY_"CHPPT R,6)")) W  ! D REOPEN
  17231   "RTN","CHM F351P",94, 0)
  17232    W !,?(COL 1-$L("EIN: ")),"EIN:" ,?COL2,CHP TID_"-"_CH PVAC_"-"_C HPIM
  17233   "RTN","CHM F351P",95, 0)
  17234    W ?(COL5- $L("Status :")),"Stat us:",?COL6 ,$P(X,"^", 1)
  17235   "RTN","CHM F351P",96, 0)
  17236    I $P(^TMP ($J,"CL",C HCLN),"^", 3)="Inpati ent" D
  17237   "RTN","CHM F351P",97, 0)
  17238    .W !,?(CO L1-$L("Pro gram:"))," Program:", ?COL2,CHPR OG,?(COL5- $L("Type:" )),"Type:" ,?COL6,$P( X,"^",3)
  17239   "RTN","CHM F351P",98, 0)
  17240    E  W !,?( COL1-$L("P rogram:")) ,"Program: ",?COL2,CH PROG
  17241   "RTN","CHM F351P",99, 0)
  17242    I $P(^TMP ($J,"CL",C HCLN),"^", 3)="Inpati ent" D
  17243   "RTN","CHM F351P",100 ,0)
  17244    .W !,?(CO L1-$L("Ven dor:")),"V endor:",?C OL2,$E($P( X,"^",2),1 ,20),?(COL 3-$L("      Vendor PO A Exempt:  ")),"      Vendor POA  Exempt: " ,?COL4,CHE XP,?(COL5- $L("Type o f Bill:")) ,"Type of  Bill:",?CO L6,CHTOB
  17245   "RTN","CHM F351P",101 ,0)
  17246    E  W !,?( COL1-$L("V endor:")), "Vendor:", ?COL2,$E($ P(X,"^",2) ,1,20),?(C OL5-$L("Ty pe:")),"Ty pe:",?COL6 ,$P(X,"^", 3) ;DGC 2/ 14/2014 BU G019388
  17247   "RTN","CHM F351P",102 ,0)
  17248    W !,?(COL 1-$L("Pay  Prov?:")), "Pay Prov? :",?COL2,$ P(X,"^",4) ,?(COL5-$L ("Ser/Admi s Date:")) ,"Ser/Admi s Date: ", ?COL6,$P(X ,"^",5)
  17249   "RTN","CHM F351P",103 ,0)
  17250    S CHCMPDT ="" I $P(@ (GLPAY_"CH PPTR,0)"), "^",10)'=" " D
  17251   "RTN","CHM F351P",104 ,0)
  17252    .S Y=$P(@ (GLPAY_"CH PPTR,0)"), "^",10) X  ^DD("DD")  S CHCMPDT= $P(Y,"@",1 )
  17253   "RTN","CHM F351P",105 ,0)
  17254    I $P(^TMP ($J,"CL",C HCLN),"^", 3)="Inpati ent" D
  17255   "RTN","CHM F351P",106 ,0)
  17256    .W !,?(CO L1-$L("Spo nsor:"))," Sponsor:", ?COL2,$P(X ,"^",6),?( COL5-$L("     Disch.  Date:")),"     Disch.  Date:",?C OL6,DISCH
  17257   "RTN","CHM F351P",107 ,0)
  17258    .W !,?(CO L1-$L("Ben e:")),"Ben e:",?COL2, $P(X,"^",7 ),?(COL5-$ L("Disch.  Stat:"))," Disch. Sta t:",?COL6, CHDISSTP
  17259   "RTN","CHM F351P",108 ,0)
  17260    E  D
  17261   "RTN","CHM F351P",109 ,0)
  17262    .W !,?(CO L1-$L("Spo nsor:"))," Sponsor:", ?COL2,$P(X ,"^",6),?( COL5-$L("C omp. Date: ")),"Comp.  Date: ",? COL6
  17263   "RTN","CHM F351P",110 ,0)
  17264    .W:($P(@( GLPAY_"CHP PTR,0)")," ^",2)=0)!( $P(@(GLPAY _"CHPPTR,0 )"),"^",2) =4) CHCMPD T
  17265   "RTN","CHM F351P",111 ,0)
  17266    .W !,?(CO L1-$L("Ben e:")),"Ben e:",?COL2, $P(X,"^",7 ),?(COL5-$ L("POS:")) ,"POS:",?C OL6,$P(X," ^",20)
  17267   "RTN","CHM F351P",112 ,0)
  17268    N CHPLZIP ,CHSERV  ; CPE001-020 , 021 and  022
  17269   "RTN","CHM F351P",113 ,0)
  17270    S CHSERV= $P(^TMP($J ,"CL",CHCL N),"^",3)
  17271   "RTN","CHM F351P",114 ,0)
  17272    I CHSERV= "Inpatient " D
  17273   "RTN","CHM F351P",115 ,0)
  17274    .W !,?(CO L1-$L("Ben e Sex:")), "Bene Sex: ",?COL2,$P (X,"^",21) ,?(COL3-$L ("Bene DOB :")),"Bene  DOB:",?CO L4,$P(X,"^ ",22),?(CO L5-$L("Com p. Date:") ),"Comp. D ate: ",?CO L6
  17275   "RTN","CHM F351P",116 ,0)
  17276    .W:($P(@( GLPAY_"CHP PTR,0)")," ^",2)=0)!( $P(@(GLPAY _"CHPPTR,0 )"),"^",2) =4) CHCMPD T
  17277   "RTN","CHM F351P",117 ,0)
  17278    .I $P(X," ^",19)'="" ,$P(X,"^", 26)'="" D
  17279   "RTN","CHM F351P",118 ,0)
  17280    ..W !,?1, "Medicaid:  ",$P(X,"^ ",19),?(CO L5-$L("POP 1:")),"POP 1:",?COL6, $P(X,"^",2 6)
  17281   "RTN","CHM F351P",119 ,0)
  17282    ..W !,?(C OL5-$L("PL  ZIP:"))," PL ZIP:",? COL6,$E($P ($G(^TMP($ J,"VEN-II" )),"^",15) ,1,5) S CH PLZIP=1  ; CPE001-020 , 021 and  022
  17283   "RTN","CHM F351P",120 ,0)
  17284    .I $P(X," ^",26)'="" ,'$G(CHPLZ IP) W !,?( COL5-$L("P OP1:")),"P OP1:",?COL 6,$P(X,"^" ,26)
  17285   "RTN","CHM F351P",121 ,0)
  17286    .I $P(X," ^",19)'="" ,'$G(CHPLZ IP) W !,?1 ,"Medicaid : ",$P(X," ^",19),?(C OL5-$L("PL  ZIP:"))," PL ZIP:",? COL6,$E($P ($G(^TMP($ J,"VEN-II" )),"^",15) ,1,5) S CH PLZIP=1  ; CPE001-020 , 021 and  022
  17287   "RTN","CHM F351P",122 ,0)
  17288    .I '$G(CH PLZIP) W ! ,$P(X,"^", 19),?(COL5 -$L("PL ZI P:")),"PL  ZIP:",?COL 6,$E($P($G (^TMP($J," VEN-II")), "^",15),1, 5) S CHPLZ IP=1
  17289   "RTN","CHM F351P",123 ,0)
  17290    E  D
  17291   "RTN","CHM F351P",124 ,0)
  17292    .W !,?(CO L1-$L("Ben e Sex:")), "Bene Sex: ",?COL2,$P (X,"^",21) ,?(COL3-$L ("Bene DOB :")),"Bene  DOB:",?CO L4,$P(X,"^ ",22)
  17293   "RTN","CHM F351P",125 ,0)
  17294    .I $P(X," ^",19)'="" ,$P(X,"^", 26)'="" D
  17295   "RTN","CHM F351P",126 ,0)
  17296    ..W ?(COL 5-$L("POP1 :")),"POP1 :",?COL6,$ P(X,"^",26 ),!,?1,"Me dicaid: ", $P(X,"^",1 9) S CHPLZ IP=1
  17297   "RTN","CHM F351P",127 ,0)
  17298    ..I CHSER V'="Pharma cy",CHSERV '="Durable  Medj.",CH SERV'="Tra vel" D
  17299   "RTN","CHM F351P",128 ,0)
  17300    ...W ?(CO L5-$L("PL  ZIP:")),"P L ZIP:",?C OL6,$E($P( $G(^TMP($J ,"VEN-II") ),"^",15), 1,5)
  17301   "RTN","CHM F351P",129 ,0)
  17302    .I $P(X," ^",26)'="" ,'$G(CHPLZ IP) W ?(CO L5-$L("POP 1:")),"POP 1:",?COL6, $P(X,"^",2 6),!
  17303   "RTN","CHM F351P",130 ,0)
  17304    .I $P(X," ^",19)'="" ,$P(X,"^", 26)="" D
  17305   "RTN","CHM F351P",131 ,0)
  17306    ..I CHSER V'="Pharma cy",CHSERV '="Durable  Medj.",CH SERV'="Tra vel",'$G(C HPLZIP) D
  17307   "RTN","CHM F351P",132 ,0)
  17308    ...W ?(CO L5-$L("PL  ZIP:")),"P L ZIP:",?C OL6,$E($P( $G(^TMP($J ,"VEN-II") ),"^",15), 1,5)
  17309   "RTN","CHM F351P",133 ,0)
  17310    ..W !,?1, "Medicaid:  ",$P(X,"^ ",19) S CH PLZIP=1
  17311   "RTN","CHM F351P",134 ,0)
  17312    .I CHSERV '="Pharmac y",CHSERV' ="Durable  Medj.",CHS ERV'="Trav el",'$G(CH PLZIP) D
  17313   "RTN","CHM F351P",135 ,0)
  17314    ..W ?(COL 5-$L("PL Z IP:")),"PL  ZIP:",?CO L6,$E($P($ G(^TMP($J, "VEN-II")) ,"^",15),1 ,5)
  17315   "RTN","CHM F351P",136 ,0)
  17316    W !!! Q   ;DGC 1/15/ 14 BUG0193 88 - END
  17317   "RTN","CHM F351P",137 ,0)
  17318   MIDHED I $ D(VIEWFL)  W !!,"Pres s <RETURN>  to contin ue, <^> to  exit." R  XXX S:XXX= "^" EXFLG= 1 W !
  17319   "RTN","CHM F351P",138 ,0)
  17320    ;-------- ---------- --DEV7820  EW 2/23/11  START
  17321   "RTN","CHM F351P",139 ,0)
  17322    W !,"DX's /Px's/NDC' s P/L",?21 ,"Unt/Qty" ,?30,"Tota l Chg",?43 ,"TotalAA" ,?56,"Mcai d",?69,"OH I #1 PD",? 82,"OHI #1  PR",?95," Deduct",?1 08,"Paymen ts",?121," AI Reas"
  17323   "RTN","CHM F351P",140 ,0)
  17324    W !,?21," AlwUnt",?3 0,"Chg/Unt ",?43,"AA/ Unt",?69," Addl OHI", ?82,"OHI P R Bal",?95 ,"Cst Shar e" ;,?108, "Payments"
  17325   "RTN","CHM F351P",141 ,0)
  17326    W !,"---- ---------- -----  --- ----  ---- -------  - ----------   -------- ---  ----- ------  -- ---------   --------- --  ------ -----  --  ----" Q
  17327   "RTN","CHM F351P",142 ,0)
  17328   MID S SORT ="",CHSOHI PDT="",CHS OHIPRT="", CHSDEDUCTT ="",CHSMED PDT="",CHS OHIADT="", CHSOHIPBT= "",CHSCSAT ="",CHSPAY AT="",SPBI F=0,TCHARG E="",TALLO W=""
  17329   "RTN","CHM F351P",143 ,0)
  17330   MID1 S SOR T=$O(CODES (SORT)) Q: SORT=""  S  USEJ=""
  17331   "RTN","CHM F351P",144 ,0)
  17332   MID11 S US EJ=$O(CODE S(SORT,USE J)) G:USEJ ="" MID1 S  CODE=""
  17333   "RTN","CHM F351P",145 ,0)
  17334   MID2 S COD E=$O(CODES (SORT,USEJ ,CODE)) G: CODE="" MI D11 S AMT1 =""
  17335   "RTN","CHM F351P",146 ,0)
  17336   MID3 S AMT 1=$O(CODES (SORT,USEJ ,CODE,AMT1 )) G:AMT1= "" MID2 S  CHQTY1=""
  17337   "RTN","CHM F351P",147 ,0)
  17338   MID55 S CH QTY1=$O(CO DES(SORT,U SEJ,CODE,A MT1,CHQTY1 )) G:CHQTY 1="" MID3
  17339   "RTN","CHM F351P",148 ,0)
  17340    S X1=CODE S(SORT,USE J,CODE,AMT 1,CHQTY1)
  17341   "RTN","CHM F351P",149 ,0)
  17342    D PARSE
  17343   "RTN","CHM F351P",150 ,0)
  17344    S ADJNUM= 0
  17345   "RTN","CHM F351P",151 ,0)
  17346    I $D(REJL N($J,CODE, AMT1,2)) D
  17347   "RTN","CHM F351P",152 ,0)
  17348    .S (RL,LN )=0,NTNUM= NTNUM+1
  17349   "RTN","CHM F351P",153 ,0)
  17350    .F  S RL= $O(REJLN($ J,CODE,AMT 1,RL)) Q:R L=""  D
  17351   "RTN","CHM F351P",154 ,0)
  17352    ..S REJLN ($J,"NOTE" ,NTNUM,RL) =REJLN($J, CODE,AMT1, RL)
  17353   "RTN","CHM F351P",155 ,0)
  17354    ..I $P(RE JLN($J,COD E,AMT1,RL) ,"^",4)'=0  S ADJNUM= ADJNUM+1
  17355   "RTN","CHM F351P",156 ,0)
  17356    ..I $P(RE JLN($J,COD E,AMT1,RL) ,"^",2)'=" " S LNREAS ($P(REJLN( $J,CODE,AM T1,RL),"^" ,2)_"*"_CH PROCEDM)=C HCCK  ;MTN 013163F  E W  ERROR T RAP 8/23/1 3
  17357   "RTN","CHM F351P",157 ,0)
  17358    .S CHRESU LT="NOTE " _NTNUM,CHR EASN=""
  17359   "RTN","CHM F351P",158 ,0)
  17360    I CHPROCE DM="Deliv"  D  G DSP  ;G MID55
  17361   "RTN","CHM F351P",159 ,0)
  17362    .S CHSCST UT=CHCHARG E,CHSCAA=C HALLOW
  17363   "RTN","CHM F351P",160 ,0)
  17364    .Q
  17365   "RTN","CHM F351P",161 ,0)
  17366    I CHDIAG' ="" G MID6
  17367   "RTN","CHM F351P",162 ,0)
  17368    I CHTTT=" Pharmacy"  I CHPROG=" SPINA BIFI DA" D  G M ID6
  17369   "RTN","CHM F351P",163 ,0)
  17370    .I CHRXDX '="" S CHD IAG=CHRXDX ,SPBIF=1,C HPROCEDM=C HNDC
  17371   "RTN","CHM F351P",164 ,0)
  17372    .E  I CHN DC'="" S C HPROCEDM=C HNDC
  17373   "RTN","CHM F351P",165 ,0)
  17374    .Q
  17375   "RTN","CHM F351P",166 ,0)
  17376    I CHNDC'= "" S CHPRO CEDM=CHNDC
  17377   "RTN","CHM F351P",167 ,0)
  17378   MID6 ;
  17379   "RTN","CHM F351P",168 ,0)
  17380    ;I CHALLO W="" I (CH TTT="Inpat ient")!(CH TTT="Pharm acy") S CH ALLOW="und tr."
  17381   "RTN","CHM F351P",169 ,0)
  17382    I CHALLOW ="" I (CHT TT="Inpati ent") S CH ALLOW="und tr." ;remo ved check  for pharma cy
  17383   "RTN","CHM F351P",170 ,0)
  17384    I CHRESUL T="" S CHR ESULT="un"
  17385   "RTN","CHM F351P",171 ,0)
  17386   DSP I CHRE ASN'="" S  LNREAS(CHR EASN_"*"_C HPROCEDM)= CHCCK
  17387   "RTN","CHM F351P",172 ,0)
  17388    ;CHECK FO R ALLOWABL E AMOUNT D O NOT DISP LAY OHI IF  NULL AND  AUTO DISTR IBUTION
  17389   "RTN","CHM F351P",173 ,0)
  17390    I (CHSCAA ="")&(CHAL LOW="")&(A UTODIST=1)  S (CHSOHI PD,CHSOHIP R,CHSDEDUC T,CHSMEDPD ,CHSOHIAD, CHSOHIPB,C HSPAYA,CHS CSA)=""
  17391   "RTN","CHM F351P",174 ,0)
  17392    ;NO SLA C HARGE PER  UNIT USE U NIT CHARGE   FOR PHAR MACY DO NO T SHOW CHA RGE PER UN IT
  17393   "RTN","CHM F351P",175 ,0)
  17394    ;I (CHSCS TUT="")&(A MT1'="")&( CHTTT'="Ph armacy") S  CHSCSTUT= AMT1
  17395   "RTN","CHM F351P",176 ,0)
  17396    ;TOTAL LI NE ITEMS
  17397   "RTN","CHM F351P",177 ,0)
  17398    I CHSOHIP D'="" S CH SOHIPDT=CH SOHIPDT+CH SOHIPD
  17399   "RTN","CHM F351P",178 ,0)
  17400    I CHSOHIP R'="" S CH SOHIPRT=CH SOHIPRT+CH SOHIPR
  17401   "RTN","CHM F351P",179 ,0)
  17402    I CHSDEDU CT'="" S C HSDEDUCTT= CHSDEDUCTT +CHSDEDUCT
  17403   "RTN","CHM F351P",180 ,0)
  17404    I CHSMEDP D'="" S CH SMEDPDT=CH SMEDPDT+CH SMEDPD
  17405   "RTN","CHM F351P",181 ,0)
  17406    I CHSOHIA D'="" S CH SOHIADT=CH SOHIADT+CH SOHIAD
  17407   "RTN","CHM F351P",182 ,0)
  17408    I CHSOHIP B'="" S CH SOHIPBT=CH SOHIPBT+CH SOHIPB
  17409   "RTN","CHM F351P",183 ,0)
  17410    I CHSCSA' ="" S CHSC SAT=CHSCSA T+CHSCSA
  17411   "RTN","CHM F351P",184 ,0)
  17412    I CHSPAYA '="" S CHS PAYAT=CHSP AYAT+CHSPA YA
  17413   "RTN","CHM F351P",185 ,0)
  17414    I CHCHARG E'="" S TC HARGE=TCHA RGE+CHCHAR GE
  17415   "RTN","CHM F351P",186 ,0)
  17416    I CHALLOW '="" S TAL LOW=TALLOW +CHALLOW ; DGC 11/6/1 3 DEV01938 8
  17417   "RTN","CHM F351P",187 ,0)
  17418    ;FORMAT V ALUES FOR  DISPLAY
  17419   "RTN","CHM F351P",188 ,0)
  17420    I CHCHARG E'["A" S:C HCHARGE'=" " CHCHARGE =$J($FN(CH CHARGE,"," ,2),11)
  17421   "RTN","CHM F351P",189 ,0)
  17422    S:CHCHARG E["A" CHCH ARGE=$J($F N(CHCHARGE ,",",2),11 )_"A"
  17423   "RTN","CHM F351P",190 ,0)
  17424    S:CHSCSTU T'="" CHSC STUT=$J($F N(CHSCSTUT ,",",2),11 )
  17425   "RTN","CHM F351P",191 ,0)
  17426    S:CHSCAA' ="" CHSCAA =$J($FN(CH SCAA,",",2 ),11)
  17427   "RTN","CHM F351P",192 ,0)
  17428    S:CHSOHIP D'="" CHSO HIPD=$J($F N(CHSOHIPD ,",",2),11 )
  17429   "RTN","CHM F351P",193 ,0)
  17430    S:CHSOHIP R'="" CHSO HIPR=$J($F N(CHSOHIPR ,",",2),11 )
  17431   "RTN","CHM F351P",194 ,0)
  17432    S:CHSDEDU CT'="" CHS DEDUCT=$J( $FN(CHSDED UCT,",",2) ,11)
  17433   "RTN","CHM F351P",195 ,0)
  17434    I (CHALLO W'="")&(CH ALLOW'="un dtr.") S C HALLOW=$J( $FN(CHALLO W,",",2),1 1) ;DGC 11 /6/13 DEV0 19388
  17435   "RTN","CHM F351P",196 ,0)
  17436    S ADJAAFL AG="" I CH ADJAA'=""  S ADJAAFLA G="A"
  17437   "RTN","CHM F351P",197 ,0)
  17438    I ADJNUM> 1 S CHSCAA =$J("NOTE  "_NTNUM,11 )
  17439   "RTN","CHM F351P",198 ,0)
  17440    S:CHSMEDP D'="" CHSM EDPD=$J($F N(CHSMEDPD ,",",2),11 )
  17441   "RTN","CHM F351P",199 ,0)
  17442    S:CHSOHIA D'="" CHSO HIAD=$J($F N(CHSOHIAD ,",",2),11 )
  17443   "RTN","CHM F351P",200 ,0)
  17444    S:CHSOHIP B'="" CHSO HIPB=$J($F N(CHSOHIPB ,",",2),11 )
  17445   "RTN","CHM F351P",201 ,0)
  17446    S:CHSCSA' ="" CHSCSA =$J($FN(CH SCSA,",",2 ),11)
  17447   "RTN","CHM F351P",202 ,0)
  17448    S:CHSPAYA '="" CHSPA YA=$J($FN( CHSPAYA,", ",2),11)
  17449   "RTN","CHM F351P",203 ,0)
  17450    S:CHQTY'= "" CHQTY=$ J(CHQTY,7)
  17451   "RTN","CHM F351P",204 ,0)
  17452    S:CHSNAU' ="" CHSNAU =$J(CHSNAU ,7)
  17453   "RTN","CHM F351P",205 ,0)
  17454    S NOBKLIN E=0
  17455   "RTN","CHM F351P",206 ,0)
  17456    I CHSCSTU T="" S CHS CSTUT=CHCH ARGE  ;DEV 007820 PPR  BUG 21 EW   6/1/12
  17457   "RTN","CHM F351P",207 ,0)
  17458    I CHDIAG= "" S CHDIA G=CHPROCED M,NOBKLINE =1
  17459   "RTN","CHM F351P",208 ,0)
  17460    W !,CHDIA G,?21,CHQT Y,?30,CHCH ARGE,?43,C HALLOW,?44 ,ADJAAFLAG ,?56,CHSME DPD,?69,CH SOHIPD,?82 ,CHSOHIPR, ?95,CHSDED UCT,?108,C HSPAYA,?12 1,CHRESULT ,?124,$J(C HREASN,4)
  17461   "RTN","CHM F351P",209 ,0)
  17462    I SPBIF=0  W !,?21,C HSNAU,?30, CHSCSTUT,? 41,RND,?43 ,CHSCAA,?6 9,CHSOHIAD ,?82,CHSOH IPB,?95,CH SCSA ;,?10 8,CHSPAYA
  17463   "RTN","CHM F351P",210 ,0)
  17464    E  W !,CH PROCEDM,?2 1,CHSNAU,? 30,CHSCSTU T,?43,CHSC AA,?69,CHS OHIAD,?82, CHSOHIPB,? 95,CHSCSA  ;,?108,CHS PAYA
  17465   "RTN","CHM F351P",211 ,0)
  17466    I NOBKLIN E=1 W !
  17467   "RTN","CHM F351P",212 ,0)
  17468    G MID55
  17469   "RTN","CHM F351P",213 ,0)
  17470    ;-------- ---------- --------DE V7820 EW 2 /23/11  EN D
  17471   "RTN","CHM F351P",214 ,0)
  17472   SORT S (CO DE,SORT)=" "
  17473   "RTN","CHM F351P",215 ,0)
  17474    S RESON=$ P(X1,"^",8 ) S:RESON= "" RESON="  "
  17475   "RTN","CHM F351P",216 ,0)
  17476    S TEST=$P (X1,"^",6)  S:TEST=""  TEST=" "   ;DEV7820  EW 4/4/11
  17477   "RTN","CHM F351P",217 ,0)
  17478    S ADJAA=$ P(X1,"^",1 0) I ADJAA ="" S ADJA A=$P(X1,"^ ",5)
  17479   "RTN","CHM F351P",218 ,0)
  17480    S AMT1=$P (X1,"^",4) ,AMT2=$P(X 1,"^",5),C HQTY=$P(X1 ,"^",25),C HMLN=$P(X1 ,"^",27)
  17481   "RTN","CHM F351P",219 ,0)
  17482    I (PAMT1' =AMT1)&(PC HMLN=CHMLN )&(CHMLN'= "") S RND= "R" ;TEST  TO SEE IF  CHARGE HAS  CHANGED I N LINE
  17483   "RTN","CHM F351P",220 ,0)
  17484    I CHMLN'= "" S AMT1= CHMLN
  17485   "RTN","CHM F351P",221 ,0)
  17486    I PCHMLN' =CHMLN S R ND=""
  17487   "RTN","CHM F351P",222 ,0)
  17488    S PAMT1=$ P(X1,"^",4 ),PCHMLN=C HMLN
  17489   "RTN","CHM F351P",223 ,0)
  17490    S:AMT1=""  AMT1=0 S: AMT2="" AM T2=0 S:CHQ TY="" CHQT Y="BLNK"
  17491   "RTN","CHM F351P",224 ,0)
  17492    I $P(X1," ^",1)'=""  S CODE=$P( X1,"^",1), SORT=3 G S RT1
  17493   "RTN","CHM F351P",225 ,0)
  17494    I $P(X1," ^",2)'=""  S CODE=$P( X1,"^",2), AMT1=0,SOR T=1,AMT2=0  G SRT1
  17495   "RTN","CHM F351P",226 ,0)
  17496    I $P(X1," ^",3)'=""  S CODE=$P( X1,"^",3), SORT=2
  17497   "RTN","CHM F351P",227 ,0)
  17498   SRT1 ;Q:CO DE=""  DEV 7820 EW 4/ 4/11
  17499   "RTN","CHM F351P",228 ,0)
  17500    S USEJ=0, FLAG=0
  17501   "RTN","CHM F351P",229 ,0)
  17502    F  S USEJ =$O(CODES( SORT,USEJ) ) Q:'USEJ   D
  17503   "RTN","CHM F351P",230 ,0)
  17504    .;------- ---------- ---DEV7820  EW 2/23/1 1 START
  17505   "RTN","CHM F351P",231 ,0)
  17506    .I $D(COD ES(SORT,US EJ,CODE,AM T1,CHQTY))  D
  17507   "RTN","CHM F351P",232 ,0)
  17508    ..;CLAIM  LINES WHIC H HAVE THE  SAME CODE S,AMOUNTS  AND QUANTI ES (IF THE Y OCCURE)
  17509   "RTN","CHM F351P",233 ,0)
  17510    ..;THESE  LINES ARE  ROLLED UP
  17511   "RTN","CHM F351P",234 ,0)
  17512    ..S FLAG= 1
  17513   "RTN","CHM F351P",235 ,0)
  17514    ..S FLD=$ LISTBUILD( 4,5,10,11, 12,13,14,1 5,17,19,20 ,21,22,23, 24,25)
  17515   "RTN","CHM F351P",236 ,0)
  17516    ..F LCNT= 1:1:16 D
  17517   "RTN","CHM F351P",237 ,0)
  17518    ...S FLDN UM=$LIST(F LD,LCNT)
  17519   "RTN","CHM F351P",238 ,0)
  17520    ...I $P(X 1,"^",FLDN UM)'=""  S  $P(CODES( SORT,USEJ, CODE,AMT1, CHQTY),"^" ,FLDNUM)=$ P(CODES(SO RT,USEJ,CO DE,AMT1,CH QTY),"^",F LDNUM)+$P( X1,"^",FLD NUM)
  17521   "RTN","CHM F351P",239 ,0)
  17522    ..S $P(CO DES(SORT,U SEJ,CODE,A MT1,CHQTY) ,"^",28)=R ND ;SET CH AGE/UNIT R OUND INDIC ATOR
  17523   "RTN","CHM F351P",240 ,0)
  17524    ..S (RL,N REJ,LN,DON E)=0
  17525   "RTN","CHM F351P",241 ,0)
  17526    ..F  S RL =$O(REJLN( $J,CODE,AM T1,RL)) Q: (RL="")!(D ONE=1)  D
  17527   "RTN","CHM F351P",242 ,0)
  17528    ...S CHRE SULT1=$P(R EJLN($J,CO DE,AMT1,RL ),"^",1)
  17529   "RTN","CHM F351P",243 ,0)
  17530    ...S CHRE ASN1=$P(RE JLN($J,COD E,AMT1,RL) ,"^",2)
  17531   "RTN","CHM F351P",244 ,0)
  17532    ...S CHAD JAA1=$P(RE JLN($J,COD E,AMT1,RL) ,"^",4)
  17533   "RTN","CHM F351P",245 ,0)
  17534    ...I (TES T=CHRESULT 1)&(RESON= CHREASN1)& (ADJAA=CHA DJAA1) S N REJ=0,$P(R EJLN($J,CO DE,AMT1,RL ),"^",3)=$ P(REJLN($J ,CODE,AMT1 ,RL),"^",3 )+1 S DONE =1 Q
  17535   "RTN","CHM F351P",246 ,0)
  17536    ...I (TES T'=CHRESUL T1)!(RESON '=CHREASN1 )!(ADJAA'= CHADJAA1)  S NREJ=1,L N=RL
  17537   "RTN","CHM F351P",247 ,0)
  17538    ..I NREJ= 1 D  ;TEST  FOR NEW T EST OR RES ULT IF SO  ADD TO LIS T
  17539   "RTN","CHM F351P",248 ,0)
  17540    ...S REJL N($J,CODE, AMT1,LN+1) =TEST_"^"_ RESON_"^"_ 1_"^"_ADJA A   ;3 PIE CE IS FOR  QUANTITY
  17541   "RTN","CHM F351P",249 ,0)
  17542    I FLAG=0  S CODES(SO RT,J,CODE, AMT1,CHQTY )=X1,$P(CO DES(SORT,J ,CODE,AMT1 ,CHQTY),"^ ",23)=1 D
  17543   "RTN","CHM F351P",250 ,0)
  17544    .I $P(X1, "^",25)'=" " S $P(COD ES(SORT,J, CODE,AMT1, CHQTY),"^" ,25)=$P(X1 ,"^",25)
  17545   "RTN","CHM F351P",251 ,0)
  17546    .I $P(X1, "^",26)'=" " S $P(COD ES(SORT,J, CODE,AMT1, CHQTY),"^" ,26)=$P(X1 ,"^",26)
  17547   "RTN","CHM F351P",252 ,0)
  17548    .S REJLN( $J,CODE,AM T1,1)=TEST _"^"_RESON _"^"_CHQTY _"^"_ADJAA
  17549   "RTN","CHM F351P",253 ,0)
  17550    Q
  17551   "RTN","CHM F351P",254 ,0)
  17552    ;-------- ---------- -------DEV 7820 EW 2/ 23/11 END
  17553   "RTN","CHM F351P",255 ,0)
  17554   DEDT D DED T^CHMF351U  Q
  17555   "RTN","CHM F351P",256 ,0)
  17556   REOPEN D R EOPEN^CHMF 351U Q
  17557   "RTN","CHM F351P",257 ,0)
  17558   PDIS D PDI S^CHMF351U  Q
  17559   "RTN","CHM F351P",258 ,0)
  17560   REASON D R EASON^CHMF 351U Q
  17561   "RTN","CHM F351P",259 ,0)
  17562   CHECKS D C HECKS^CHMF 351U Q
  17563   "RTN","CHM F351P",260 ,0)
  17564   TIME  ; AD DED CHECK  FOR DATE V ALUE IN "D T". IF NOT  LOADED, G ET DATE AN D LOAD "DT "  DLB 8/1 4/2013
  17565   "RTN","CHM F351P",261 ,0)
  17566    I '$D(DT)   D
  17567   "RTN","CHM F351P",262 ,0)
  17568    .D NOW^%D TC  S DT=X   ; GET CU RRENT DATE
  17569   "RTN","CHM F351P",263 ,0)
  17570    S CHDT=$E (DT,4,7),X =$P($H,"," ,2),H=X\36 00,M=X#360 0\60
  17571   "RTN","CHM F351P",264 ,0)
  17572    S:M<10 M= "0"_M S CH TIME=H_M Q
  17573   "RTN","CHM F351P",265 ,0)
  17574   QUEUE I $D (VIEWFL),J =1 W !!,"P ress <RETU RN> to Con tinue, <^>  to exit."  R XXX S:X XX="^" EXF LG=1 W !
  17575   "RTN","CHM F351P",266 ,0)
  17576    ;E  I (($ Y>52)&(J=1 )) W @IOF  D HEAD
  17577   "RTN","CHM F351P",267 ,0)
  17578    S CHTIL=" Actions fo r Claim:"
  17579   "RTN","CHM F351P",268 ,0)
  17580    W:J=1 !!! ,CHTIL,!
  17581   "RTN","CHM F351P",269 ,0)
  17582    W:J#2=1 ! ,?3,J,") " ,X2 Q:J#2= 1
  17583   "RTN","CHM F351P",270 ,0)
  17584    W:J#2'=1  ?43,J,") " ,X2
  17585   "RTN","CHM F351P",271 ,0)
  17586    I '$D(VIE WFL),$Y>59  W @IOF D  HEAD W !!! ,?(40-($L( CHTIL)\2)) ,CHTIL,!
  17587   "RTN","CHM F351P",272 ,0)
  17588    Q
  17589   "RTN","CHM F351P",273 ,0)
  17590    ;-------- ---DEV7820  EW 2/23/1 1 START
  17591   "RTN","CHM F351P",274 ,0)
  17592   PARSE S FL D=$LISTBUI LD("CHNDC" ,"CHDIAG", "CHPROCEDM ","CHCHARG E","CHALLO W","CHRESU LT","CH7", "CHREASN", "CHCCK","C HADJAA","C HSOHIPD"," CHSOHIPR", "CHSOHIAD" ,"CHSOHIPB ","CHSMEDP D","CHSCST UT","CHSNA U","CHSCAA ","CHSDEDU CT","CHSCS A","CHSPAY A","CHSCAT CAP","CHST PL","S24", "CHQTY","C HRXDX","CH LCNT","RND ") S RND=" "
  17593   "RTN","CHM F351P",275 ,0)
  17594    F LCNT=1: 1:28 D
  17595   "RTN","CHM F351P",276 ,0)
  17596    .S @$LIST (FLD,LCNT) =$P(X1,"^" ,LCNT)
  17597   "RTN","CHM F351P",277 ,0)
  17598    Q
  17599   "RTN","CHM F351P",278 ,0)
  17600    ;-------- ---DEV7820  EW 2/23/1 1 END
  17601   "RTN","CHM F351U")
  17602   0^35^B1885 99366
  17603   "RTN","CHM F351U",1,0 )
  17604   CHMF351U ; DEH/DEN;UT ILITY FILE  FOR PPR P RINT ;Feb  06, 2019@1 0:03:44
  17605   "RTN","CHM F351U",2,0 )
  17606    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  17607   "RTN","CHM F351U",3,0 )
  17608    ;;V1.0;;
  17609   "RTN","CHM F351U",4,0 )
  17610    ;CPTS #12 621* (RLC) , #13782*  (RLC) , 16 785 (AEB)
  17611   "RTN","CHM F351U",5,0 )
  17612    ;THIS ROU TINE CREAT ED TO DOWN SIZE CHMF3 51P
  17613   "RTN","CHM F351U",6,0 )
  17614    ; DEV7820  EW 3/17/1 1 Add line  level TOT AL data an d notes
  17615   "RTN","CHM F351U",7,0 )
  17616    ;DEV01938 8 11/5/13  DGC - Chan ge in INP  processing
  17617   "RTN","CHM F351U",8,0 )
  17618    ;CFS 10/1 8/2017 CPE 005-095 -  Add total  of all cla ims for Or iginal and  Current P DI's.
  17619   "RTN","CHM F351U",9,0 )
  17620    ;CFS 12/0 7/2017 CPE 005-097 -  Change tit les and re align the  bottom of  the report .
  17621   "RTN","CHM F351U",10, 0)
  17622    ;CFS 12/0 8/2017 CPE 005-128 -  Get the La st PDI Pay ment Diffe rence and  display.
  17623   "RTN","CHM F351U",11, 0)
  17624    ;
  17625   "RTN","CHM F351U",12, 0)
  17626   BOT  ;
  17627   "RTN","CHM F351U",13, 0)
  17628    ;------   DEV7820 EW  8/9/11    START
  17629   "RTN","CHM F351U",14, 0)
  17630    I $P(X,"^ ",3)="Inpa tient" D
  17631   "RTN","CHM F351U",15, 0)
  17632    .S SORT=" ",CHSOHIPD T="",CHSOH IPRT="",CH SDEDUCTT=" ",CHSMEDPD T="",CHSOH IADT="",CH SOHIPBT="" ,CHSCSAT=" ",CHSPAYAT ="",SPBIF= 0,TCHARGE= "",TALLOW= "" ;DGC 1/ 13/14 BUG0 19388
  17633   "RTN","CHM F351U",16, 0)
  17634    .S CHCLNP =$O(@(GLPA Y_"""B"",C HCLN,0)"))  Q:'CHCLNP
  17635   "RTN","CHM F351U",17, 0)
  17636    .I $D(@(G LPAY_"CHCL NP,""INP"" )")) D   ; DGC 11/5/1 3 DEV01938 8
  17637   "RTN","CHM F351U",18, 0)
  17638    ..S:$P(@( GLPAY_"CHC LNP,""INP" ")"),"^",1 0)'="" TCH ARGE=$J($F N($P(X,"^" ,8),",",2) ,11)_"A" ; DGC 11/5/1 3 DEV01938 8
  17639   "RTN","CHM F351U",19, 0)
  17640    ..S:$P(@( GLPAY_"CHC LNP,""INP" ")"),"^",1 0)="" TCHA RGE=$J($FN ($P(X,"^", 8),",",2), 11)   ;DGC  11/5/13 D EV019388
  17641   "RTN","CHM F351U",20, 0)
  17642    E  S TCHA RGE=$J($FN (TCHARGE," ,",2),11)
  17643   "RTN","CHM F351U",21, 0)
  17644    I $P(X,"^ ",3)'="Inp atient" W  !,"------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- --------"  ;DGC 1/13/ 14 BUG0193 88
  17645   "RTN","CHM F351U",22, 0)
  17646    E  W !!   ;DGC 1/13/ 14 BUG0193 88
  17647   "RTN","CHM F351U",23, 0)
  17648    ;IF NO SL A DATA USE  CLAIM
  17649   "RTN","CHM F351U",24, 0)
  17650    S CHTPL=" "
  17651   "RTN","CHM F351U",25, 0)
  17652    I CHSOHIP DT'="" S C HSOHIPDT=$ J($FN(CHSO HIPDT,",", 2),11)
  17653   "RTN","CHM F351U",26, 0)
  17654    I (CHSOHI PDT="")&($ P(X,"^",12 )'="") S C HSOHIPDT=$ J($FN($P(X ,"^",12)," ,",2),11)
  17655   "RTN","CHM F351U",27, 0)
  17656    I CHSOHIP RT'="" S C HSOHIPRT=$ J($FN(CHSO HIPRT,",", 2),11)
  17657   "RTN","CHM F351U",28, 0)
  17658    I (CHSOHI PRT="")&($ P(X,"^",24 )'="") S C HSOHIPRT=$ J($FN($P(X ,"^",24)," ,",2),11)
  17659   "RTN","CHM F351U",29, 0)
  17660    I CHSOHIA DT'="" S C HSOHIADT=$ J($FN(CHSO HIADT,",", 2),11)
  17661   "RTN","CHM F351U",30, 0)
  17662    I (CHSOHI ADT="")&($ P(X,"^",27 )'="") S C HSOHIADT=$ J($FN($P(X ,"^",27)," ,",2),11)   ;MTN01316 3F  EW  BU G BEN39 6/ 29/12
  17663   "RTN","CHM F351U",31, 0)
  17664    I CHSOHIP BT'="" S C HSOHIPBT=$ J($FN(CHSO HIPBT,",", 2),11)
  17665   "RTN","CHM F351U",32, 0)
  17666    I (CHSOHI PBT="")&($ P(X,"^",28 )'="") S C HSOHIPBT=$ J($FN($P(X ,"^",28)," ,",2),11)   ;MTN01316 3F  EW  BU G BEN39 6/ 29/12
  17667   "RTN","CHM F351U",33, 0)
  17668    I CHSOHIA DT="" S CH SOHIPBT=""   ;;MTN013 163F Bene  42 BUG FIX  EW 7/3/12
  17669   "RTN","CHM F351U",34, 0)
  17670    I CHSDEDU CTT'="" S  CHSDEDUCTT =$J($FN(CH SDEDUCTT," ,",2),11)
  17671   "RTN","CHM F351U",35, 0)
  17672    I (CHSDED UCTT="")&( $P(X,"^",1 0)'="") S  CHSDEDUCTT =$J($FN($P (X,"^",10) ,",",2),11 )
  17673   "RTN","CHM F351U",36, 0)
  17674    S CHSDEDT =CHSDEDUCT T I CHSDED T="" S CHS DEDT=$J("N /A",11) ;A mount Appl ied to Ded uctible: J UST FOR TH IS LOCATIO N
  17675   "RTN","CHM F351U",37, 0)
  17676    I TALLOW' ="" S TALL OW=$J($FN( TALLOW,"," ,2),11)
  17677   "RTN","CHM F351U",38, 0)
  17678    I (TALLOW ="")&($P(X ,"^",9)'=" ") S TALLO W=$J($FN($ P(X,"^",9) ,",",2),11 )
  17679   "RTN","CHM F351U",39, 0)
  17680    S TALLW=" "
  17681   "RTN","CHM F351U",40, 0)
  17682    I ($P(X," ^",9)'="")  S TALLW=$ J($FN($P(X ,"^",9),", ",2),11)   ;MTN013163 F  EW  BUG  BC 54 9/7 /12
  17683   "RTN","CHM F351U",41, 0)
  17684    I TALLW=" " S TALLW= $J("N/A",1 1) ;Calcul ated Allow able Amoun t: JUST FO R THIS LOC ATION  MTN 013163F  E W  BUG BC  54 9/7/12
  17685   "RTN","CHM F351U",42, 0)
  17686    I CHSMEDP DT'="" S C HSMEDPDT=$ J($FN(CHSM EDPDT,",", 2),11)
  17687   "RTN","CHM F351U",43, 0)
  17688    I (CHSMED PDT="")&($ P(X,"^",29 )'="") S C HSMEDPDT=$ J($FN($P(X ,"^",29)," ,",2),11)   ;MTN01316 3F  EW  BU G BEN39 6/ 29/12
  17689   "RTN","CHM F351U",44, 0)
  17690    I CHSCSAT '="" S CHS CSAT=$J($F N(CHSCSAT, ",",2),11)
  17691   "RTN","CHM F351U",45, 0)
  17692    I (CHSCSA T="")&($P( X,"^",11)' ="") S CHS CSAT=$J($F N($P(X,"^" ,11),",",2 ),11)
  17693   "RTN","CHM F351U",46, 0)
  17694    S CHCSAT= CHSCSAT I  CHCSAT=""  S CHCSAT=$ J("N/A",11 ) ;Cost Sh are Credit ed to Cat  Cap: JUST  FOR THIS L OCATION
  17695   "RTN","CHM F351U",47, 0)
  17696    I CHSPAYA T'="" S CH SPAYAT=$J( $FN(CHSPAY AT,",",2), 11)
  17697   "RTN","CHM F351U",48, 0)
  17698    E  S CHSP AYAT=$J($F N($P(X,"^" ,13),",",2 ),11)
  17699   "RTN","CHM F351U",49, 0)
  17700    I $P(X,"^ ",25)'=""  S CHTPL=$J ($FN($P(X, "^",25),", ",2),11)   ;Amount Pa id by TPL
  17701   "RTN","CHM F351U",50, 0)
  17702    E  S CHTP L=$J("N/A" ,11)
  17703   "RTN","CHM F351U",51, 0)
  17704    D PRVS
  17705   "RTN","CHM F351U",52, 0)
  17706    I CHDEB'= "" S CHDEB =$J($FN(CH DEB,",",2) ,11)
  17707   "RTN","CHM F351U",53, 0)
  17708    E  S CHDE B=$J("N/A" ,11)
  17709   "RTN","CHM F351U",54, 0)
  17710    I CHCSTSH R'="" S CH CSTSHR=$J( $FN(CHCSTS HR,",",2), 11)
  17711   "RTN","CHM F351U",55, 0)
  17712    E  S CHCS TSHR=$J("N /A",11)
  17713   "RTN","CHM F351U",56, 0)
  17714    I CHPRVSP MT'="" S C HPRVSPMT=$ J($FN(CHPR VSPMT,",", 2),11)
  17715   "RTN","CHM F351U",57, 0)
  17716    E  S CHPR VSPMT=$J(" N/A",11)
  17717   "RTN","CHM F351U",58, 0)
  17718    I $P(X,"^ ",12)'=""  S CHOTHIN= $P(X,"^",1 2)+$P(X,"^ ",27) S CH OTHIN=$J($ FN(CHOTHIN ,",",2),11 ) ;Amount  Paid by Ot her Insura nce: MTN01 3163F  EW   BUG PPR42  12/10/12
  17719   "RTN","CHM F351U",59, 0)
  17720    E  S CHOT HIN=$J("N/ A",11)
  17721   "RTN","CHM F351U",60, 0)
  17722    I CHSOHIP BT'="" S C HPRESP=CHS OHIPBT  ;M TN013163F   EW  BUG P PR39 11/16 /12
  17723   "RTN","CHM F351U",61, 0)
  17724    I ($P(X," ^",24)'="" ) & (CHSOH IPBT="") S  CHPRESP=$ J($FN($P(X ,"^",24)," ,",2),11)  ;Patient R esponsibil ity Amount : JUST FOR  THIS LOCA TION   MTN 013163F  E W  BUG PPR 39 11/16/1 2
  17725   "RTN","CHM F351U",62, 0)
  17726    I ($P(X," ^",24)="")  & (CHSOHI PBT="")  S  CHPRESP=$ J("N/A",11 )  ;MTN013 163F  EW   BUG PPR39  11/16/12
  17727   "RTN","CHM F351U",63, 0)
  17728    I $P(X,"^ ",14)'=""  S CHPBENV= $J($FN($P( X,"^",14), ",",2),11)  ;Amount P aid by Ben eficiary t o Vendor:  JUST FOR T HIS LOCATI ON
  17729   "RTN","CHM F351U",64, 0)
  17730    E  S CHPB ENV=$J("N/ A",11)
  17731   "RTN","CHM F351U",65, 0)
  17732    I $P(X,"^ ",13)'=""  S CHPAIDCL =$J($FN($P (X,"^",13) ,",",2),11 ) ;Total A mount to b e PAID on  claim: JUS T FOR THIS  LOCATION
  17733   "RTN","CHM F351U",66, 0)
  17734    E  S CHPA IDCL=$J("N /A",11)
  17735   "RTN","CHM F351U",67, 0)
  17736    I $P(X,"^ ",15)'=""  S CHPAIDV= $J($FN($P( X,"^",15), ",",2),11)  ;Total Am ount to be  PAID to V endor: JUS T FOR THIS  LOCATION
  17737   "RTN","CHM F351U",68, 0)
  17738    E  S CHPA IDV=$J("N/ A",11)
  17739   "RTN","CHM F351U",69, 0)
  17740    I $P(X,"^ ",16)'=""  S CHPAIDB= $J($FN($P( X,"^",16), ",",2),11)  ;Total Am ount to be  PAID to B eneficiary : JUST FOR  THIS LOCA TION
  17741   "RTN","CHM F351U",70, 0)
  17742    E  S CHPA IDB=$J("N/ A",11)
  17743   "RTN","CHM F351U",71, 0)
  17744    I ($P(X," ^",18)=1)& ($P(X,"^", 17)'="") S  CHCATCAP= $J($FN($P( X,"^",17), ",",2),11)  ;Amount a pplied to  Cat Cap: J UST FOR TH IS LOCATIO N
  17745   "RTN","CHM F351U",72, 0)
  17746    E  S CHCA TCAP=$J("N /A",11)
  17747   "RTN","CHM F351U",73, 0)
  17748    D CITI
  17749   "RTN","CHM F351U",74, 0)
  17750    ;D MEDI
  17751   "RTN","CHM F351U",75, 0)
  17752    I $P(X,"^ ",3)'="Inp atient" D
  17753   "RTN","CHM F351U",76, 0)
  17754    .W !,"Tot als:",?30, TCHARGE,?4 3,TALLOW,? 56,CHSMEDP DT,?69,CHS OHIPDT,?82 ,CHSOHIPRT ,?95,CHSDE DUCTT,?108 ,CHSPAYAT
  17755   "RTN","CHM F351U",77, 0)
  17756    .W !,?69, CHSOHIADT, ?82,CHSOHI PBT,?95,CH SCSAT
  17757   "RTN","CHM F351U",78, 0)
  17758    .W !
  17759   "RTN","CHM F351U",79, 0)
  17760    S NOTE="" ,SCHDL=""
  17761   "RTN","CHM F351U",80, 0)
  17762    F  S NOTE =$O(REJLN( $J,"NOTE", NOTE)) Q:N OTE=""  D
  17763   "RTN","CHM F351U",81, 0)
  17764    .S LN=0 F   S LN=$O( REJLN($J," NOTE",NOTE ,LN)) Q:LN =""  D
  17765   "RTN","CHM F351U",82, 0)
  17766    ..S RESUL T=$P(REJLN ($J,"NOTE" ,NOTE,LN), "^",1)
  17767   "RTN","CHM F351U",83, 0)
  17768    ..S:RESUL T="AC" RES ULT="accep ted"
  17769   "RTN","CHM F351U",84, 0)
  17770    ..S:RESUL T="RE" RES ULT="rejec ted"
  17771   "RTN","CHM F351U",85, 0)
  17772    ..S REASO N=$P(REJLN ($J,"NOTE" ,NOTE,LN), "^",2)
  17773   "RTN","CHM F351U",86, 0)
  17774    ..S QTY=$ P(REJLN($J ,"NOTE",NO TE,LN),"^" ,3)
  17775   "RTN","CHM F351U",87, 0)
  17776    ..S ADJAM T=$P(REJLN ($J,"NOTE" ,NOTE,LN), "^",4)
  17777   "RTN","CHM F351U",88, 0)
  17778    ..S TADJA MT=$FN(QTY *ADJAMT,", ",2),ADJAM T=$FN(ADJA MT,",",2)
  17779   "RTN","CHM F351U",89, 0)
  17780    ..S (LN1, QTY1)=0,AD JAMT1="" F   S LN1=$O (REJLN($J, "NOTE",NOT E,LN1)) Q: LN1=""  D
  17781   "RTN","CHM F351U",90, 0)
  17782    ...S ADJA MT1=$P(REJ LN($J,"NOT E",NOTE,LN 1),"^",4)
  17783   "RTN","CHM F351U",91, 0)
  17784    ...I ADJA MT1>0 S QT Y1=QTY1+1
  17785   "RTN","CHM F351U",92, 0)
  17786    ..I LN=1  W !,?2,"NO TE ",NOTE, " -  ",QTY ," units " ,RESULT W: REASON'="  " " with r eason ",RE ASON W:((A DJAMT'="") !(REASON=" "))&(QTY1' =1) " @ $" ,ADJAMT,"/ unit=$",TA DJAMT
  17787   "RTN","CHM F351U",93, 0)
  17788    ..E  W !, ?12,QTY,"  units ",RE SULT W:REA SON'=" " "  with reas on ",REASO N W:(ADJAM T'="")&(RE ASON=" ")  " @ $",ADJ AMT,"/unit =$",TADJAM T
  17789   "RTN","CHM F351U",94, 0)
  17790    .W !
  17791   "RTN","CHM F351U",95, 0)
  17792    K REJLN($ J) S NTNUM =0
  17793   "RTN","CHM F351U",96, 0)
  17794    I $D(VIEW FL) W !!," Press <RET URN> to Co ntinue, <^ > to exit. " R XXX S: XXX="^" EX FLG=1 W !
  17795   "RTN","CHM F351U",97, 0)
  17796    W !
  17797   "RTN","CHM F351U",98, 0)
  17798    I CHSMEDP DT="" S CH SMEDPDT=$J ("N/A",11)
  17799   "RTN","CHM F351U",99, 0)
  17800    ;TO CHANG E THE COLU MN SPACING  THESE VAL UES ARE TH E ONLY ONE S THAT HAV E TO BE CH ANGED
  17801   "RTN","CHM F351U",100 ,0)
  17802    ;S COL1=4 2,COL2=47, COL3=110,C OL4=113  ; MTN013163F   EW  BUG  PPR42 12/1 0/12
  17803   "RTN","CHM F351U",101 ,0)
  17804    S COL1=38 ,COL2=43,C OL3=117,CO L4=120  ;C FS CPE005- 097
  17805   "RTN","CHM F351U",102 ,0)
  17806    ;DGC 11/6 /13 DEV019 388 - BEGI N
  17807   "RTN","CHM F351U",103 ,0)
  17808    I INP'=""  D
  17809   "RTN","CHM F351U",104 ,0)
  17810    .S:$P(INP ,"^",1)=""  $P(INP,"^ ",1)="unde termined"
  17811   "RTN","CHM F351U",105 ,0)
  17812    .S:$P(INP ,"^",2)=""  $P(INP,"^ ",2)="unde termined"
  17813   "RTN","CHM F351U",106 ,0)
  17814    .S:$P(INP ,"^",4)=""  $P(INP,"^ ",3)="unde termined"
  17815   "RTN","CHM F351U",107 ,0)
  17816    .I ($P(IN P,"^",1)'= "undetermi ned"),($P( INP,"^",4) '=0) S $P( INP,"^",2) ="N/A"
  17817   "RTN","CHM F351U",108 ,0)
  17818    .I $P(INP ,"^",1)="u ndetermine d" W !!,?( COL1-$L("D RG:")),"DR G:",?COL2, $P(INP,"^" ,1)
  17819   "RTN","CHM F351U",109 ,0)
  17820    .E  W !!, ?(COL1-$L( "DRG:"))," DRG:",?COL 2,$P(INP," ^",1)
  17821   "RTN","CHM F351U",110 ,0)
  17822    .I $P(INP ,"^",2)="u ndetermine d" W !,?(C OL1-$L("DR G Status:" )),"DRG St atus:",?CO L2,$P(INP, "^",2)
  17823   "RTN","CHM F351U",111 ,0)
  17824    .E  W !,? (COL1-$L(" DRG Status :")),"DRG  Status:",? COL2,$P(IN P,"^",2)
  17825   "RTN","CHM F351U",112 ,0)
  17826    .I $P(INP ,"^",3)="u ndetermine d" W !,?(C OL1-$L("Me thod of Pa yment:")), "Method of  Payment:" ,?COL2,$P( INP,"^",3)
  17827   "RTN","CHM F351U",113 ,0)
  17828    .E  W !,? (COL1-$L(" Method of  Payment:") ),"Method  of Payment :",?COL2,$ P(INP,"^", 3)
  17829   "RTN","CHM F351U",114 ,0)
  17830    ;DGC 11/6 /13 DEV019 388 - END
  17831   "RTN","CHM F351U",115 ,0)
  17832    W !!,?(CO L1-$L("Tot al Charges  Billed:") ),"Total C harges Bil led:",?COL 2,TCHARGE, ?(COL3-$L( "CITI Maxi mum Reimbu rsement Ra te:")),"CI TI Maximum  Reimburse ment Rate: ",?COL4,CI TICA
  17833   "RTN","CHM F351U",116 ,0)
  17834    W !,?(COL 1-$L("Calc ulated All owable Amo unt:")),"C alculated  Allowable  Amount:",? COL2,TALLW ,?(COL3-$L ("MEDICAID  Amount:") ),"MEDICAI D Amount:" ,?COL4,CHS MEDPDT
  17835   "RTN","CHM F351U",117 ,0)
  17836    W !,?(COL 1-$L("Amou nt Applied  to Deduct ible:"))," Amount App lied to De ductible:" ,?COL2,CHS DEDT,?(COL 3-$L("Amou nt Paid by  TPL:"))," Amount Pai d by TPL:" ,?COL4,CHT PL
  17837   "RTN","CHM F351U",118 ,0)
  17838    W !,?(COL 1-$L("Cost  Share Cre dited to C at Cap:")) ,"Cost Sha re Credite d to Cat C ap:",?COL2 ,CHCSAT,?( COL3-$L("A mount Reve rsed from  Deductible :")),"Amou nt Reverse d from Ded uctible:", ?COL4,CHDE B
  17839   "RTN","CHM F351U",119 ,0)
  17840    W !,?(COL 1-$L("Amou nt Paid by  Other Ins urance(s): ")),"Amoun t Paid by  Other Insu rance(s):" ,?COL2,CHO THIN,?(COL 3-$L("Amou nt Reverse d from Cat  Cap:"))," Amount Rev ersed from  Cat Cap:" ,?COL4,CHC STSHR
  17841   "RTN","CHM F351U",120 ,0)
  17842    W !,?(COL 1-$L("Pati ent Respon sibility A mount:")), "Patient R esponsibil ity Amount :",?COL2,C HPRESP,?(C OL3-$L("Am ount Reduc ed from Pr evious Pay ment:"))," Amount Red uced from  Previous P ayment:",? COL4,CHPRV SPMT
  17843   "RTN","CHM F351U",121 ,0)
  17844    N CHMFLAS T,CHMFPDI, CURRPDI,J, LASTDIFF,L ASTPDI,PDD ATA,TOTPAI D
  17845   "RTN","CHM F351U",122 ,0)
  17846    F J=1:1:3  D  ;CPE00 5-095
  17847   "RTN","CHM F351U",123 ,0)
  17848    .S PDDATA =$G(PAIDAR Y(J))  ;PA IDARY set  up in rout ine GETPYM NT^CHMXF35 1D
  17849   "RTN","CHM F351U",124 ,0)
  17850    .S CHMFPD I=$P(PDDAT A,"^"),TOT PAID=$P(PD DATA,"^",2 )
  17851   "RTN","CHM F351U",125 ,0)
  17852    .I J=1 D   ;CPE005-0 97 Get the  Reopened  Current PD I Number.  It will al ways be th e last ent ry in PAID ARY.
  17853   "RTN","CHM F351U",126 ,0)
  17854    ..S CHMFL AST="" S C HMFLAST=$O (PAIDARY(C HMFLAST),- 1) ;CPE005 -128 Get t he last pa yment made .
  17855   "RTN","CHM F351U",127 ,0)
  17856    ..S LASTP DI=$P(PAID ARY(CHMFLA ST),"^"),L ASTPMNT=$P (PAIDARY(C HMFLAST)," ^",2)
  17857   "RTN","CHM F351U",128 ,0)
  17858    ..S LASTD IFF=TOTPAI D-LASTPMNT   ;CPE005- 128 Calcul ate the La st PDI Pay ment Diffe rence.
  17859   "RTN","CHM F351U",129 ,0)
  17860    .I TOTPAI D'["-",TOT PAID'=0 S  TOTPAID=$J ($FN(TOTPA ID,"+,",2) ,11)
  17861   "RTN","CHM F351U",130 ,0)
  17862    .I TOTPAI D["-",TOTP AID'=0 S T OTPAID=$J( $FN(TOTPAI D,",",2),1 1)
  17863   "RTN","CHM F351U",131 ,0)
  17864    .I TOTPAI D="" S TOT PAID=0
  17865   "RTN","CHM F351U",132 ,0)
  17866    .I TOTPAI D=0 S TOTP AID=$J(TOT PAID,11,2)
  17867   "RTN","CHM F351U",133 ,0)
  17868    .I J=1 D
  17869   "RTN","CHM F351U",134 ,0)
  17870    ..I LASTD IFF'["-",L ASTDIFF'=0  S LASTDIF F=$J($FN(L ASTDIFF,"+ ,",2),11)
  17871   "RTN","CHM F351U",135 ,0)
  17872    ..I LASTD IFF["-",LA STDIFF'=0  S LASTDIFF =$J($FN(LA STDIFF,"," ,2),11)
  17873   "RTN","CHM F351U",136 ,0)
  17874    ..I LASTD IFF="" S L ASTDIFF=0
  17875   "RTN","CHM F351U",137 ,0)
  17876    ..I LASTD IFF=0 S LA STDIFF=$J( LASTDIFF,1 1,2)
  17877   "RTN","CHM F351U",138 ,0)
  17878    ..W !,?(C OL1-$L("Am ount Paid  by Benefic iary to Ve ndor:"))," Amount Pai d by Benef iciary to  Vendor:",? COL2,CHPBE NV
  17879   "RTN","CHM F351U",139 ,0)
  17880    ..W ?(COL 3-$L("Last  PDI Payme nt Differe nce:")),"L ast PDI Pa yment Diff erence:    ",?COL4,LA STDIFF
  17881   "RTN","CHM F351U",140 ,0)
  17882    ..W !,?(C OL1-$L("To tal Amount  to be PAI D on claim :")),"Tota l Amount t o be PAID  on claim:" ,?COL2,CHP AIDCL
  17883   "RTN","CHM F351U",141 ,0)
  17884    ..I PDDAT A'="" W ?( COL3-$L("T otal Payme nt for Cur rent PDI#  NNNNNNNNNN NNNNN:")), "Total Pay ment for C urrent PDI # "_CHMFPD I_":",?COL 4,TOTPAID
  17885   "RTN","CHM F351U",142 ,0)
  17886    .I J=2 D
  17887   "RTN","CHM F351U",143 ,0)
  17888    ..W !,?(C OL1-$L("Am ount PAID  to Vendor: ")),"Amoun t PAID to  Vendor:",? COL2,CHPAI DV
  17889   "RTN","CHM F351U",144 ,0)
  17890    ..I PDDAT A'="" W ?( COL3-$L("T otal Payme nt for Ori ginal PDI#  NNNNNNNNN NNNNNN:")) ,"Total Pa yment for  Original P DI# "_CHMF PDI_":",?C OL4,TOTPAI D
  17891   "RTN","CHM F351U",145 ,0)
  17892    .I J=3 D
  17893   "RTN","CHM F351U",146 ,0)
  17894    ..W !,?(C OL1-$L("Am ount PAID  to Benefic iary:"))," Amount PAI D to Benef iciary:",? COL2,CHPAI DB
  17895   "RTN","CHM F351U",147 ,0)
  17896    ..I PDDAT A'="" D
  17897   "RTN","CHM F351U",148 ,0)
  17898    ...I LAST PDI=CHMFPD I W ?(COL3 -$L("Total  Payment f or Reopene d Current  PDI# NNNNN NNNNNNNNNN :")),"Tota l Payment  for Reopen ed Current  PDI# "_CH MFPDI_":", ?COL4,TOTP AID
  17899   "RTN","CHM F351U",149 ,0)
  17900    ...E  D
  17901   "RTN","CHM F351U",150 ,0)
  17902    ....W ?(C OL3-$L("To tal Paymen t for Reop ened PDI#  NNNNNNNNNN NNNNN:")), "Total Pay ment for R eopened PD I# "_CHMFP DI_":",?CO L4,TOTPAID
  17903   "RTN","CHM F351U",151 ,0)
  17904    I $G(PAID ARY)>3 D   ;CPE005-09 5
  17905   "RTN","CHM F351U",152 ,0)
  17906    .F J=4:1: PAIDARY D
  17907   "RTN","CHM F351U",153 ,0)
  17908    ..S PDDAT A=PAIDARY( J)
  17909   "RTN","CHM F351U",154 ,0)
  17910    ..S CHMFP DI=$P(PDDA TA,"^"),TO TPAID=$P(P DDATA,"^", 2)
  17911   "RTN","CHM F351U",155 ,0)
  17912    ..I TOTPA ID'["-",TO TPAID'=0 S  TOTPAID=$ J($FN(TOTP AID,"+,",2 ),11)
  17913   "RTN","CHM F351U",156 ,0)
  17914    ..I TOTPA ID["-",TOT PAID'=0 S  TOTPAID=$J (TOTPAID,1 1,2)
  17915   "RTN","CHM F351U",157 ,0)
  17916    ..I TOTPA ID="" S TO TPAID=0
  17917   "RTN","CHM F351U",158 ,0)
  17918    ..I TOTPA ID=0 S TOT PAID=$J(TO TPAID,11,2 )
  17919   "RTN","CHM F351U",159 ,0)
  17920    ..I PDDAT A'="" D
  17921   "RTN","CHM F351U",160 ,0)
  17922    ...I LAST PDI=CHMFPD I W !,?(CO L3-$L("Tot al Payment  for Reope ned Curren t PDI# NNN NNNNNNNNNN NN:")),"To tal Paymen t for Reop ened Curre nt PDI# "_ CHMFPDI_": ",?COL4,TO TPAID
  17923   "RTN","CHM F351U",161 ,0)
  17924    ...E  D
  17925   "RTN","CHM F351U",162 ,0)
  17926    ....W !,? (COL3-$L(" Total Paym ent for Re opened PDI # NNNNNNNN NNNNNNN:") ),"Total P ayment for  Reopened  PDI# "_CHM FPDI_":",? COL4,TOTPA ID
  17927   "RTN","CHM F351U",163 ,0)
  17928    D
  17929   "RTN","CHM F351U",164 ,0)
  17930    .S CHCLNP =$O(@(GLPA Y_"""B"",C HCLN,0)"))  Q:'CHCLNP
  17931   "RTN","CHM F351U",165 ,0)
  17932    .Q:'$D(@( GLPAY_"CHC LNP,5)"))   Q:$P(@(GL PAY_"CHCLN P,5)"),"^" ,1)=""
  17933   "RTN","CHM F351U",166 ,0)
  17934    .S SR=$P( @(GLPAY_"C HCLNP,5)") ,"^",1)
  17935   "RTN","CHM F351U",167 ,0)
  17936    .W !,?20, $S(SR=0:"* PENDING RE COUPMENT*" ,SR=1:"*PA RTIAL RECO UPMENT REC EIVED*",SR =2:"*FULL  RECOUPMENT  RECEIVED* ",SR=3:"*N O RECOUPME NT FORTHCO MING*",1:" ")
  17937   "RTN","CHM F351U",168 ,0)
  17938    Q
  17939   "RTN","CHM F351U",169 ,0)
  17940   PRVS S (ZC L,CHPRVSPM T,CHDEB,CH CSTSHR)=""
  17941   "RTN","CHM F351U",170 ,0)
  17942    S ZCL=$O( @(GLPAY_"" "B"",CHCLN ,0)")) Q:' ZCL
  17943   "RTN","CHM F351U",171 ,0)
  17944    S PRV=$$P RVSPMT^CHT FLIB2(ZCL)
  17945   "RTN","CHM F351U",172 ,0)
  17946    S YR=""
  17947   "RTN","CHM F351U",173 ,0)
  17948    F  S YR=$ O(^TMP($J, "PRVSPMT", YR))  Q:YR =""  D
  17949   "RTN","CHM F351U",174 ,0)
  17950    .S CHPRVS PMT=CHPRVS PMT+$P(^TM P($J,"PRVS PMT",YR)," ^",1)
  17951   "RTN","CHM F351U",175 ,0)
  17952    .S CHDEB= CHDEB+$P(^ TMP($J,"PR VSPMT",YR) ,"^",2)
  17953   "RTN","CHM F351U",176 ,0)
  17954    .S CHCSTS HR=CHCSTSH R+$P(^TMP( $J,"PRVSPM T",YR),"^" ,3)
  17955   "RTN","CHM F351U",177 ,0)
  17956    K ^TMP($J ,"PRVSPMT" )
  17957   "RTN","CHM F351U",178 ,0)
  17958    Q
  17959   "RTN","CHM F351U",179 ,0)
  17960    ;------   DEV007820  EW 8/9/11    END
  17961   "RTN","CHM F351U",180 ,0)
  17962   CITI S ZCL ="",CITICA =$J("N/A", 11)
  17963   "RTN","CHM F351U",181 ,0)
  17964    S ZCL=$O( @(GLPAY_"" "B"",CHCLN ,0)")) Q:' ZCL
  17965   "RTN","CHM F351U",182 ,0)
  17966    S CITIVN= "" S:$D(@( GLPAY_"ZCL ,0)")) CIT IVN=$P(@(G LPAY_"ZCL, 0)"),"^",3 )
  17967   "RTN","CHM F351U",183 ,0)
  17968    Q:'CITIVN   Q:'$D(^C HMVEN(CITI VN,1))  Q: $P(^CHMVEN (CITIVN,1) ,"^",16)'= 1
  17969   "RTN","CHM F351U",184 ,0)
  17970    S CITICA= "" S:$D(@( GLPAY_"ZCL ,1)")) CIT ICA=$P(@(G LPAY_"ZCL, 1)"),"^",2 8)
  17971   "RTN","CHM F351U",185 ,0)
  17972    I CITICA' ="" S CITI CA=$J($FN( CITICA,"," ,2),11)
  17973   "RTN","CHM F351U",186 ,0)
  17974    E  S CITI CA=$J("N/A ",11)
  17975   "RTN","CHM F351U",187 ,0)
  17976    ;I CITICA ="" W !,?1 1,"CITI Ma ximum Reim bursment R ate:  ",?4 6,"undeter mined"
  17977   "RTN","CHM F351U",188 ,0)
  17978    ;E  W !,? 11,"CITI M aximum Rei mbursment  Rate:  ",? 48,$J($FN( CITICA,"," ,2),10)
  17979   "RTN","CHM F351U",189 ,0)
  17980    Q
  17981   "RTN","CHM F351U",190 ,0)
  17982    ;
  17983   "RTN","CHM F351U",191 ,0)
  17984   MEDI S ZCL ="",CHSMED PDT=$J("N/ A",11)
  17985   "RTN","CHM F351U",192 ,0)
  17986    S ZCL=$O( @(GLPAY_"" "B"",CHCLN ,0)")) Q:' ZCL
  17987   "RTN","CHM F351U",193 ,0)
  17988    Q:'$D(@(G LPAY_"ZCL, 7)"))
  17989   "RTN","CHM F351U",194 ,0)
  17990    S MEDIA=$ P(@(GLPAY_ "ZCL,7)"), "^",2)
  17991   "RTN","CHM F351U",195 ,0)
  17992    I MEDIA'= "" S CHSME DPDT=$J($F N(MEDIA,", ",2),11)
  17993   "RTN","CHM F351U",196 ,0)
  17994    E  S CHSM EDPDT=$J(" N/A",11)
  17995   "RTN","CHM F351U",197 ,0)
  17996    ;I MEDIA' ="" W !,?2 6,"MEDICAI D Amount:   ",?48,$J( $FN(MEDIA, ",",2),10)
  17997   "RTN","CHM F351U",198 ,0)
  17998    Q
  17999   "RTN","CHM F351U",199 ,0)
  18000    ;
  18001   "RTN","CHM F351U",200 ,0)
  18002   DEDT I $D( VIEWFL) W  !!,"Press  <RETURN> t o Continue , <^> to e xit." R XX X S:XXX="^ " EXFLG=1  W !
  18003   "RTN","CHM F351U",201 ,0)
  18004    ;E  I $Y> 53 W @IOF  D HEAD
  18005   "RTN","CHM F351U",202 ,0)
  18006    W !
  18007   "RTN","CHM F351U",203 ,0)
  18008    ;W !!,?5, "OCHAMPUS  Beneficiar y Deductib le ",$P(X3 ,"^",10)," :  ",?45," $",$J($FN( $P(X3,"^", 2),"",2),1 0)
  18009   "RTN","CHM F351U",204 ,0)
  18010    W !,?6,"C HAMPVA Ben eficiary D eductible  ",$P(X3,"^ ",10),":   ",?48,$J($ FN($P(X3," ^",1),"",2 ),10) W:($ P(X3,"^",7 )'=0)&($P( X3,"^",7)' ="") ?60," (satisfied )"
  18011   "RTN","CHM F351U",205 ,0)
  18012    ;W !!,?10 ,"OCHAMPUS  Family De ductible " ,$P(X3,"^" ,10),":  " ,?45,"$",$ J($FN($P(X 3,"^",4)," ",2),10)
  18013   "RTN","CHM F351U",206 ,0)
  18014    W !,?11," CHAMPVA Fa mily Deduc tible ",$P (X3,"^",10 ),":  ",?4 8,$J($FN($ P(X3,"^",3 ),"",2),10 ) W:($P(X3 ,"^",8)'=0 )&($P(X3," ^",8)'="")  ?60,"(sat isfied)"
  18015   "RTN","CHM F351U",207 ,0)
  18016    ;W !!,?4, "OCHAMPUS  Family Cat astrophic  Cap ",$P(X 3,"^",10), ":  ",?45, "$",$J($FN ($P(X3,"^" ,6),"",2), 10)
  18017   "RTN","CHM F351U",208 ,0)
  18018    S:$P(X3," ^",5)<0 $P (X3,"^",5) =0
  18019   "RTN","CHM F351U",209 ,0)
  18020    W !,?5,"C HAMPVA Fam ily Catast rophic Cap  ",$P(X3," ^",10),":   ",?48,$J( $FN($P(X3, "^",5),"", 2),10) W:( $P(X3,"^", 9)'=0)&($P (X3,"^",9) '="") ?60, "(satisfie d)" Q
  18021   "RTN","CHM F351U",210 ,0)
  18022    ;
  18023   "RTN","CHM F351U",211 ,0)
  18024   REOPEN K R EOPEN,FLAG  S JJ=CHPP TR,II=JJ,C T=1 D:$D(@ (GLPAY_"JJ ,6)"))
  18025   "RTN","CHM F351U",212 ,0)
  18026    .S X1=JJ  D PROGTYP^ CHFCD001    ; Set for  every reo pen claim
  18027   "RTN","CHM F351U",213 ,0)
  18028    .F  S II= $P($G(@(GL PAY_"JJ,6) ")),"^",2)  Q:II=""   S REOPEN(C T,II)="",J J=II,CT=CT +1
  18029   "RTN","CHM F351U",214 ,0)
  18030    I $D(REOP EN) D
  18031   "RTN","CHM F351U",215 ,0)
  18032    .S CT=0
  18033   "RTN","CHM F351U",216 ,0)
  18034   R1 .S CT=$ O(REOPEN(C T)) Q:'CT   S RECLM=0
  18035   "RTN","CHM F351U",217 ,0)
  18036   R2 .S RECL M=$O(REOPE N(CT,RECLM )) G:'RECL M R1
  18037   "RTN","CHM F351U",218 ,0)
  18038    .S X1=REC LM D PROGT YP^CHFCD00 1
  18039   "RTN","CHM F351U",219 ,0)
  18040    .G:'$D(@( GLPAY_"REC LM,0)")) R 1
  18041   "RTN","CHM F351U",220 ,0)
  18042    .S PDICPT =RECLM D P DIS
  18043   "RTN","CHM F351U",221 ,0)
  18044    .I $P(^TM P($J,"CL", CHCLN),"^" ,3)="Inpat ient" S CO L1=10,COL2 =11,COL3=3 5,COL4=36, COL5=65,CO L6=66  ;MT N013163: S LA EW 1/14 /13
  18045   "RTN","CHM F351U",222 ,0)
  18046    .;------- --START  D EV007820   PPR BUG 23   EW 5/30/ 12
  18047   "RTN","CHM F351U",223 ,0)
  18048    .;W "       PDI: ",C HPDI_"-"_C HDOC,"  BA TCH: ",CHB ATCH
  18049   "RTN","CHM F351U",224 ,0)
  18050    .;I '$D(F LAG) W ?55 ,"(Reopens ): " S FLA G=1
  18051   "RTN","CHM F351U",225 ,0)
  18052    .;W ?66,$ P(@(GLPAY_ "RECLM,0)" ),"^",1)
  18053   "RTN","CHM F351U",226 ,0)
  18054    .W ?(COL1 -$L("PDI:" )),"PDI:", ?COL2,CHPD I_"-"_CHDO C,?(COL3-$ L("BATCH:" )),"BATCH: ",?COL4,CH BATCH
  18055   "RTN","CHM F351U",227 ,0)
  18056    .I '$D(FL AG) W ?(CO L5-$L("(Re opens):")) ,"(Reopens ):"  ;MTN0 13163: BUG  FIX PPR34  SLA EW 9/ 17/12
  18057   "RTN","CHM F351U",228 ,0)
  18058    .W ?COL6, $P(@(GLPAY _"RECLM,0) "),"^",1)  S FLAG=1   ;MTN013163 : BUG FIX  PPR34 SLA  EW 9/17/12
  18059   "RTN","CHM F351U",229 ,0)
  18060    .;------- --END  DEV 007820  PP R BUG 23   EW 5/30/12
  18061   "RTN","CHM F351U",230 ,0)
  18062    .I $O(REO PEN(CT,REC LM)) W ! G  R2
  18063   "RTN","CHM F351U",231 ,0)
  18064    .I $O(REO PEN(CT)) W  ! G R2
  18065   "RTN","CHM F351U",232 ,0)
  18066    .G R2
  18067   "RTN","CHM F351U",233 ,0)
  18068   REXIT S X1 =CHPPTR D  PROGTYP^CH FCD001  ;  Set back t o original  claim
  18069   "RTN","CHM F351U",234 ,0)
  18070    Q
  18071   "RTN","CHM F351U",235 ,0)
  18072   PDIS S CHP DI="",CHDO C="",CHBAT CH=""
  18073   "RTN","CHM F351U",236 ,0)
  18074    Q:'$D(PDI CPT)  Q:PD ICPT=""
  18075   "RTN","CHM F351U",237 ,0)
  18076    S JJ=9999 99
  18077   "RTN","CHM F351U",238 ,0)
  18078    S JJ=$O(@ (GLPAY_"PD ICPT,""PDI "",JJ)"),- 1)
  18079   "RTN","CHM F351U",239 ,0)
  18080    I JJ I $D (@(GLPAY_" PDICPT,""P DI"",JJ,0) ")) D
  18081   "RTN","CHM F351U",240 ,0)
  18082    .S CHPDI= $P(@(GLPAY _"PDICPT," "PDI"",JJ, 0)"),"^",1 )
  18083   "RTN","CHM F351U",241 ,0)
  18084    .I CHPDI  I $D(^CHMI MG(CHPDI," DOC")) S C HDOC=$P(^( "DOC"),"^" ,1)
  18085   "RTN","CHM F351U",242 ,0)
  18086    .I $D(^CH MIMPB("C", CHPDI)) D
  18087   "RTN","CHM F351U",243 ,0)
  18088    ..S JJJ=0 ,JJJ=$O(^C HMIMPB("C" ,CHPDI,JJJ ))
  18089   "RTN","CHM F351U",244 ,0)
  18090    ..I JJJ I  $D(^CHMIM PB(JJJ,0))  S CHBATCH =$P(^(0)," ^",1)
  18091   "RTN","CHM F351U",245 ,0)
  18092    Q
  18093   "RTN","CHM F351U",246 ,0)
  18094   REASON S R SPT="" S:$ P(@(GLPAY_ "CHPPTR,0) "),"^",13) '="" RSPT= $P(@(GLPAY _"CHPPTR,0 )"),"^",13 )
  18095   "RTN","CHM F351U",247 ,0)
  18096    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S CLREAS($ P(^(0),"^" ,1))=$E($P (^(0),"^", 2),1,104)   ;USE TO B E LIMITED  TO 70 DEV0 07820  BUG  PPR25  EW  8/2/12
  18097   "RTN","CHM F351U",248 ,0)
  18098    G:'$D(@(G LPAY_"CHPP TR,4)")) R S2 S JJ=0
  18099   "RTN","CHM F351U",249 ,0)
  18100   RS1 S JJ=$ O(@(GLPAY_ "CHPPTR,4, JJ)")) G:' JJ RS2
  18101   "RTN","CHM F351U",250 ,0)
  18102    S FIL0="^ "_GLPAY_CH PPTR_",4," _JJ_",0)"
  18103   "RTN","CHM F351U",251 ,0)
  18104    G:'$D(@(G LPAY_"CHPP TR,4,JJ,0) ")) RS1
  18105   "RTN","CHM F351U",252 ,0)
  18106    S RSPT=$P (@(GLPAY_" CHPPTR,4,J J,0)"),"^" ,1)
  18107   "RTN","CHM F351U",253 ,0)
  18108    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S CLREAS($ P(^(0),"^" ,1))=$E($P (^(0),"^", 2),1,104)   ;USE TO B E LIMITED  TO 70 DEV0 07820  BUG  PPR25  EW  8/2/12
  18109   "RTN","CHM F351U",254 ,0)
  18110    G RS1
  18111   "RTN","CHM F351U",255 ,0)
  18112   RS2 W ! G: '$D(CLREAS ) RS4 W !! ,"Claim Re asons:  "  S JJ=0
  18113   "RTN","CHM F351U",256 ,0)
  18114   RS3 S JJ=$ O(CLREAS(J J)) G:JJ=" " RS4
  18115   "RTN","CHM F351U",257 ,0)
  18116    W ?20,JJ, " - ",$E(C LREAS(JJ), 1,104),! G  RS3  ;USE  TO BE LIM ITED TO 53  DEV007820   BUG PPR2 5  EW 8/2/ 12
  18117   "RTN","CHM F351U",258 ,0)
  18118   RS4 Q:'$D( LNREAS)  S  JJ=""
  18119   "RTN","CHM F351U",259 ,0)
  18120   RS5 S JJ=$ O(LNREAS(J J)) G:JJ=" " RS6
  18121   "RTN","CHM F351U",260 ,0)
  18122    S TJJ=$P( JJ,"*",1), RTNPRO=$P( JJ,"*",2)
  18123   "RTN","CHM F351U",261 ,0)
  18124    G:'$D(^CH MDIC(74100 2.22,"B",T JJ)) RS5
  18125   "RTN","CHM F351U",262 ,0)
  18126    S RSPT=0, RSPT=$O(^C HMDIC(7410 02.22,"B", TJJ,RSPT))
  18127   "RTN","CHM F351U",263 ,0)
  18128    I RSPT I  $D(^CHMDIC (741002.22 ,RSPT,0))  S LIREAS(J J)=$E($P(^ (0),"^",2) ,1,104)  ; USE TO BE  LIMITED TO  70 DEV007 820  BUG P PR25  EW 8 /2/12
  18129   "RTN","CHM F351U",264 ,0)
  18130    G RS5
  18131   "RTN","CHM F351U",265 ,0)
  18132   RS6 Q:'$D( LIREAS)  W  !,"Line I tem Reason s:  " S JJ =""
  18133   "RTN","CHM F351U",266 ,0)
  18134   RS7 S JJ=$ O(LIREAS(J J)) Q:JJ=" "
  18135   "RTN","CHM F351U",267 ,0)
  18136    S TJJ=$P( JJ,"*",1), REASON1=$E (LIREAS(JJ ),1,104)   ;USE TO BE  LIMITED T O 53 DEV00 7820  BUG  PPR25  EW  8/2/12
  18137   "RTN","CHM F351U",268 ,0)
  18138    ;//BEG RE MARK OUT R EBUNDLING,  SKD 3-22- 07 DEV0000 99-01//
  18139   "RTN","CHM F351U",269 ,0)
  18140    ;I (TJJ=1 006)!(TJJ= 1007)!(TJJ =1009) D
  18141   "RTN","CHM F351U",270 ,0)
  18142    ;//END RE MARK OUT R EBUNDLING,  SKD 3-22- 07 DEV0000 99-01//
  18143   "RTN","CHM F351U",271 ,0)
  18144    I (TJJ=10 06)!(TJJ=1 007) D   ; THIS LINE  NEEDS TO B E REPLACED  LATER FOR  REBUNDLIN G
  18145   "RTN","CHM F351U",272 ,0)
  18146    .K SPEC S  SNTPRO=$P (JJ,"*",2) ,SPEC("XXX XX")=SNTPR O
  18147   "RTN","CHM F351U",273 ,0)
  18148    .S REASON 1=$$REPLAC E^XLFSTR(R EASON1,.SP EC) K SPEC
  18149   "RTN","CHM F351U",274 ,0)
  18150    .S RNTPRO =LNREAS(JJ ),SPEC("YY YYY")=RNTP RO
  18151   "RTN","CHM F351U",275 ,0)
  18152    .S REASON 1=$$REPLAC E^XLFSTR(R EASON1,.SP EC) K SPEC
  18153   "RTN","CHM F351U",276 ,0)
  18154    .S REASON 1=$E(REASO N1,1,104)  ;DEV007820   BUG PPR2 5  EW 8/2/ 12
  18155   "RTN","CHM F351U",277 ,0)
  18156    ;//BEG RE MARK OUT R EBUNDLING,  SKD 3-22- 07 DEV0000 99-01//
  18157   "RTN","CHM F351U",278 ,0)
  18158    ;I TJJ=10 10 D  ;SKD  2-21-07 C C8.5
  18159   "RTN","CHM F351U",279 ,0)
  18160    ;.K SPEC  S SNTPRO=$ P(JJ,"*",2 ),SPEC("YY YYY")=SNTP RO
  18161   "RTN","CHM F351U",280 ,0)
  18162    ;.S REASO N1=$$REPLA CE^XLFSTR( REASON1,.S PEC) K SPE C
  18163   "RTN","CHM F351U",281 ,0)
  18164    ;//END RE MARK OUT R EBUNDLING,  SKD 3-22- 07 DEV0000 99-01//
  18165   "RTN","CHM F351U",282 ,0)
  18166    W ?20,TJJ ," - ",REA SON1,! G R S7
  18167   "RTN","CHM F351U",283 ,0)
  18168   CHECKS S J =0
  18169   "RTN","CHM F351U",284 ,0)
  18170   CHK1 S J=$ O(@(GLPAY_ "CHPPTR,10 2,J)")) G: 'J CHK2
  18171   "RTN","CHM F351U",285 ,0)
  18172    Q:'$D(@(G LPAY_"CHPP TR,102,J,0 )"))
  18173   "RTN","CHM F351U",286 ,0)
  18174    S CHECKS( $P(@(GLPAY _"CHPPTR,1 02,J,0)"), "^",1))=""
  18175   "RTN","CHM F351U",287 ,0)
  18176    S:$P(@(GL PAY_"CHPPT R,102,J,0) "),"^",4)= 1 CHECKS($ P(@(GLPAY_ "CHPPTR,10 2,J,0)")," ^",1))=" ( Ret)"
  18177   "RTN","CHM F351U",288 ,0)
  18178    I $P(@(GL PAY_"CHPPT R,102,J,0) "),"^",8)' ="" D
  18179   "RTN","CHM F351U",289 ,0)
  18180    .S REDATE =$P(@(GLPA Y_"CHPPTR, 102,J,0)") ,"^",8)
  18181   "RTN","CHM F351U",290 ,0)
  18182    .S REDATE =$E(REDATE ,4,5)_"/"_ $E(REDATE, 6,7)_"/"_$ E(REDATE,2 ,3)
  18183   "RTN","CHM F351U",291 ,0)
  18184    .S CHECKS ($P(@(GLPA Y_"CHPPTR, 102,J,0)") ,"^",1))="  (Reis) "_ REDATE
  18185   "RTN","CHM F351U",292 ,0)
  18186    G CHK1
  18187   "RTN","CHM F351U",293 ,0)
  18188   CHK2 Q:'$D (CHECKS)   S CHKNM=""  S TAB=12, LLEN=12
  18189   "RTN","CHM F351U",294 ,0)
  18190    W !!,"Che ck #'s:"
  18191   "RTN","CHM F351U",295 ,0)
  18192   CHHK3 S CH KNM=$O(CHE CKS(CHKNM) ) Q:CHKNM= ""
  18193   "RTN","CHM F351U",296 ,0)
  18194    S LLEN=LL EN+$L(CHKN M)+4+$L(CH ECKS(CHKNM ))
  18195   "RTN","CHM F351U",297 ,0)
  18196    I LLEN>80  S TAB=12, LLEN=12 W  !
  18197   "RTN","CHM F351U",298 ,0)
  18198    W ?TAB,CH KNM,CHECKS (CHKNM)
  18199   "RTN","CHM F351U",299 ,0)
  18200    S TAB=TAB +LLEN
  18201   "RTN","CHM F351U",300 ,0)
  18202    G CHHK3
  18203   "RTN","CHM FA001")
  18204   0^36^B7272 8138
  18205   "RTN","CHM FA001",1,0 )
  18206   CHMFA001 ; JLR/DEN;DO CUMENT IDE NTIFICATIO N SCREEN;F eb 06, 201 9@10:04:52
  18207   "RTN","CHM FA001",2,0 )
  18208    ;;1.0;CHA MPVA SYSTE M;**1,8,14 **;JULY 4,  1990;Buil d 9
  18209   "RTN","CHM FA001",3,0 )
  18210    ;;CPTS #1 4989 (RLC)
  18211   "RTN","CHM FA001",4,0 )
  18212    ;;MODIFIE D BY RLC O N 4/13/95  - ADDED OP TION 11) P PR
  18213   "RTN","CHM FA001",5,0 )
  18214    ;;MODIFIE D BY RLC O N 4/28/95  - ADDED OP TION 12) P PRs-PDI
  18215   "RTN","CHM FA001",6,0 )
  18216    ; Clear S creen and  establish  values for  screen ou tput varia bles
  18217   "RTN","CHM FA001",7,0 )
  18218    ;CFS 10/0 1/2017 - C PE005-069  Add logic  for Origin al and Cur rent PDI N umber prom pts. The
  18219   "RTN","CHM FA001",8,0 )
  18220    ; menu op tion "ER"  was added  to allow M anual EDI  Re-open pr ocessing.
  18221   "RTN","CHM FA001",9,0 )
  18222    ;CFS 10/0 1/2017 - C PE005-070  Make Origi nal and Cu rrent PDI  Numbers pr ompts Read  Only
  18223   "RTN","CHM FA001",10, 0)
  18224    ; when ne xt screen  is chosen  from the b ottom menu  in Doc ID  Screen
  18225   "RTN","CHM FA001",11, 0)
  18226    ;BDB 01/0 9/2018 CPE 005-121 Au toload ori ginal PDI  to Current  PDI for M anual EDI
  18227   "RTN","CHM FA001",12, 0)
  18228    ;CFS 01/1 3/2018 CPE 005-122 an d 123 Add  call for b ene check  validation .
  18229   "RTN","CHM FA001",13, 0)
  18230    ;CFS 09/1 8/2018 Def ect 734616  - Allow u ser to ent er in 15 P DI digits  by enterin g command:  S FL=20
  18231   "RTN","CHM FA001",14, 0)
  18232    D CLEAR^C HMFADR2 S  CHTITLE="D OCUMENT ID ENTIFICATI ON SCREEN" ,CHSCREEN= ""
  18233   "RTN","CHM FA001",15, 0)
  18234    ; Query C HMSCRN to  return the  screen nu mber based  on the ab ove title
  18235   "RTN","CHM FA001",16, 0)
  18236    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN))
  18237   "RTN","CHM FA001",17, 0)
  18238    ; If ther e is no id entified s creen numb er, output  message t o user and  quit.
  18239   "RTN","CHM FA001",18, 0)
  18240    I 'CHSCRE EN D NOSCR ^CHMFADR2  G END
  18241   "RTN","CHM FA001",19, 0)
  18242    D TITLE^C HMFA100,LI NE^CHMFA10 0,CHOICE^C HMFA100
  18243   "RTN","CHM FA001",20, 0)
  18244    D SCREEN^ CHMFADR2,E RRORS^CHMF A100
  18245   "RTN","CHM FA001",21, 0)
  18246    D NOW^%DT C S CHMFTM BG=%
  18247   "RTN","CHM FA001",22, 0)
  18248   A0 K CHMFC ,CHMFBAD,C HNOFLAG,CH YESFLG,CHM NNUM,CHMFQ UIT
  18249   "RTN","CHM FA001",23, 0)
  18250    ;---Begin  CPE005-06 9
  18251   "RTN","CHM FA001",24, 0)
  18252   A01 I $G(C HOSEN)'=8, $P(^CHMDIC (741002.21 ,DUZ,0),"^ ",10)=0 D  ^CHMFABTH  G:$D(DDOUT ) END
  18253   "RTN","CHM FA001",25, 0)
  18254    K Y
  18255   "RTN","CHM FA001",26, 0)
  18256   ORIGPDI ;C PE005-069  Original P DI Prompt
  18257   "RTN","CHM FA001",27, 0)
  18258    ;I $D(CHM FPREV)!($D (CHMFNEXT) ),$G(CHMOP DI)'="" G  A1
  18259   "RTN","CHM FA001",28, 0)
  18260    I '$D(NEX TPAGE) S N EXTPAGE=0
  18261   "RTN","CHM FA001",29, 0)
  18262    K F1
  18263   "RTN","CHM FA001",30, 0)
  18264    S QU=8
  18265   "RTN","CHM FA001",31, 0)
  18266    I $G(CHOS EN)'=8 G A 1
  18267   "RTN","CHM FA001",32, 0)
  18268    I $G(CHMO PDI)="",'$ G(VALOPDI) ,'$G(VALBE NE) S CHMO PDI=$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",2)
  18269   "RTN","CHM FA001",33, 0)
  18270    I $G(CHMO PDI)'="",' $G(VALOPDI ) D  I '$G (VALOPDI), '$G(VALBEN E) S CHMFI MAG=1 I NE XTPAGE G A 1
  18271   "RTN","CHM FA001",34, 0)
  18272    .S VALOPD I=$$CHKOPD I^CHMFADR2 ($G(CHMFPD I),CHMOPDI ,CHOSEN,1)
  18273   "RTN","CHM FA001",35, 0)
  18274    D WTOPDI^ CHMFADR2 S  DX=41,$X= DX X XY S  FL=20 D CS BRS^CHSC2  K FL W:Y'= "" @CHEOL   ;CFS - De fect 73461 6 S FL=20
  18275   "RTN","CHM FA001",36, 0)
  18276    G:$D(DFOU T) END
  18277   "RTN","CHM FA001",37, 0)
  18278    I $D(DQOU T) S Y="?"  D QUES^CH MFADR2,WTO PDI^CHMFAD R2 G ORIGP DI
  18279   "RTN","CHM FA001",38, 0)
  18280    I $D(DUOU T) D WTOPD I^CHMFADR2  G END
  18281   "RTN","CHM FA001",39, 0)
  18282    I $D(D1OU T) G ORIGP DI
  18283   "RTN","CHM FA001",40, 0)
  18284    I $D(DDOU T),$D(CHMO PDI) D WTO PDI^CHMFAD R2 G END
  18285   "RTN","CHM FA001",41, 0)
  18286    I $D(DDOU T) G END
  18287   "RTN","CHM FA001",42, 0)
  18288    ;I Y="",$ G(CHMOPDI) '="" S Y=C HMOPDI
  18289   "RTN","CHM FA001",43, 0)
  18290    ;I Y'=""  S CHMOPDI= Y
  18291   "RTN","CHM FA001",44, 0)
  18292    D CHECK^C HMFADR2 I  $G(F1)=1 G  ORIGPDI
  18293   "RTN","CHM FA001",45, 0)
  18294    I $G(CHMO PDI)'="",' $G(VALOPDI ) D WTOPDI ^CHMFADR2  G A1
  18295   "RTN","CHM FA001",46, 0)
  18296    I CHMOPDI ="",'$G(VA LOPDI) D C LEARB^CHMF ADR2 G ORI GPDI
  18297   "RTN","CHM FA001",47, 0)
  18298   A1 K F0,F1  G:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=1  A2
  18299   "RTN","CHM FA001",48, 0)
  18300    ;I $D(CHM FPREV)!($D (CHMFNEXT) ),$G(CHMFP DI)'="" G  A2
  18301   "RTN","CHM FA001",49, 0)
  18302    I $G(CHMF PDI)'="",' $G(VALOPDI ) D  I '$G (VALOPDI), '$G(VALBEN E) S CHMFI MAG=1 I NE XTPAGE G A 2
  18303   "RTN","CHM FA001",50, 0)
  18304    .S VALOPD I=$$CHKOPD I^CHMFADR2 ($G(CHMFPD I),CHMOPDI ,CHOSEN,1)
  18305   "RTN","CHM FA001",51, 0)
  18306    I CHOSEN' =8 D  ;Not  needed fo r Manual R e-open. Ba tch number  not used.
  18307   "RTN","CHM FA001",52, 0)
  18308    .I $D(CHB TCHNO) I C HBTCHNO I  $D(^CHMIMP B(CHBTCHNO )) D ^CHMF A004
  18309   "RTN","CHM FA001",53, 0)
  18310    ;I $D(CHM FPDI) I CH MFPDI'=""  D WTPDI^CH MFADR2 G A 2
  18311   "RTN","CHM FA001",54, 0)
  18312    S QU=$S(C HOSEN=8:9, 1:1)
  18313   "RTN","CHM FA001",55, 0)
  18314    ;---End C PE005-069
  18315   "RTN","CHM FA001",56, 0)
  18316    D WTPDI^C HMFADR2 S  DX=41,$X=D X X XY S F L=20 D CSB RS^CHSC2 W :Y'="" @CH EOL G:$D(D FOUT) END   ;CFS Defe ct 734616  S FL=20
  18317   "RTN","CHM FA001",57, 0)
  18318    I $D(DQOU T) D QUES^ CHMFADR2,W TPDI^CHMFA DR2 G A1
  18319   "RTN","CHM FA001",58, 0)
  18320    I $D(DUOU T) D WTPDI ^CHMFADR2  G END
  18321   "RTN","CHM FA001",59, 0)
  18322    I CHOSEN' =8,$D(D1OU T) D WTPDI ^CHMFADR2  S $P(^CHMD IC(741002. 21,DUZ,0), "^",10)=0  G A01
  18323   "RTN","CHM FA001",60, 0)
  18324    I $D(DDOU T) G END
  18325   "RTN","CHM FA001",61, 0)
  18326    I CHOSEN' =8,Y="" D  CLEARB^CHM FADR2 G A1
  18327   "RTN","CHM FA001",62, 0)
  18328    I CHOSEN= 8,Y="",$G( CHMFPDI)'= "" S Y=CHM FPDI
  18329   "RTN","CHM FA001",63, 0)
  18330    D CHECK^C HMFADR2 I  $G(F1)=1 S  CHMFPDI=Y  G A1
  18331   "RTN","CHM FA001",64, 0)
  18332    I $P($G(^ CHMIMAGE(" LOCK",CHMF PDI)),"^") =DUZ K ^CH MIMAGE("LO CK",CHMFPD I)
  18333   "RTN","CHM FA001",65, 0)
  18334    I CHOSEN' =8 D
  18335   "RTN","CHM FA001",66, 0)
  18336    .D CLEARB ^CHMFADR2  I '$D(^CHM IMG(Y)) S  CHMFPDI=""  D ERR3^CH MFADR2 G A 1
  18337   "RTN","CHM FA001",67, 0)
  18338    .I $D(^CH MPAY("C",Y )) D ERR1^ CHMFADR2 S  CHMFPDI=" " K CHMNNU M S CHMFNM PG="" G A1
  18339   "RTN","CHM FA001",68, 0)
  18340    .I $D(^CH NVPAY("C", Y)) D ERR1 ^CHMFADR2  S CHMFPDI= "" K CHMNN UM S CHMFN MPG="" G A 1
  18341   "RTN","CHM FA001",69, 0)
  18342    .S ZIMGST ="" S:$D(^ CHMIMG(Y,0 )) ZIMGST= $P(^(0),"^ ",6)
  18343   "RTN","CHM FA001",70, 0)
  18344    .I ZIMGST >2 D ERR1^ CHMFADR2 S  CHMFPDI=" " K CHMNNU M S CHMFNM PG="" G A1
  18345   "RTN","CHM FA001",71, 0)
  18346    I CHMFPDI '="" I $D( ^CHMIMAGE( "LOCK",CHM FPDI)) D L OCK^CHMFAD R2 K CHMNN UM S CHMFN MPG="" G A 1
  18347   "RTN","CHM FA001",72, 0)
  18348    S:CHMFPDI '="" ^CHMI MAGE("LOCK ",CHMFPDI) =DUZ D WTP DI^CHMFADR 2,CLEARB^C HMFADR2
  18349   "RTN","CHM FA001",73, 0)
  18350    D INPRC^C HMFIMG
  18351   "RTN","CHM FA001",74, 0)
  18352   A2 D IMAGE ^CHMFADR2
  18353   "RTN","CHM FA001",75, 0)
  18354    ;I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 1 S:CHMFNM PG="" CHMF NMPG="UNK"  D WTNP^CH MFADR2 G A 3
  18355   "RTN","CHM FA001",76, 0)
  18356    S:'$D(CHM FNMPG) CHM FNMPG=""
  18357   "RTN","CHM FA001",77, 0)
  18358    I $G(CHMF PDI)'="",$ D(^CHMIMG( CHMFPDI,0) ) S:CHMFNM PG="" CHMF NMPG=$P(^( 0),"^",2)
  18359   "RTN","CHM FA001",78, 0)
  18360    I $D(CHMF NMPG) I CH MFNMPG'=""  D WTNP^CH MFADR2 G A 3
  18361   "RTN","CHM FA001",79, 0)
  18362    S:'$D(CHM FNMPG) CHM FNMPG=""
  18363   "RTN","CHM FA001",80, 0)
  18364    S:CHMFNMP G="" CHMFN MPG="UNK"
  18365   "RTN","CHM FA001",81, 0)
  18366    S QU=2 D  WTNP^CHMFA DR2 S DX=4 1,$X=DX X  XY D CSBRS ^CHSC2 W:Y '="" @CHEO L
  18367   "RTN","CHM FA001",82, 0)
  18368    G:$D(DFOU T) END I $ D(DQOUT) D  QUES^CHMF ADR2,WTNP^ CHMFADR2 G  A1
  18369   "RTN","CHM FA001",83, 0)
  18370    I $D(DUOU T) D WTNP^ CHMFADR2 G  END
  18371   "RTN","CHM FA001",84, 0)
  18372    I $D(D1OU T) D CHECK ^CHMFADR2, WTNP^CHMFA DR2 G A1
  18373   "RTN","CHM FA001",85, 0)
  18374    I $D(DDOU T) D WTNP^ CHMFADR2 G  END
  18375   "RTN","CHM FA001",86, 0)
  18376    I Y="" D  CLEARB^CHM FADR2 G A3
  18377   "RTN","CHM FA001",87, 0)
  18378    D CHECK^C HMFADR2 G: $D(F1) A2  D WTNP^CHM FADR2,CLEA RB^CHMFADR 2
  18379   "RTN","CHM FA001",88, 0)
  18380   A3 S QU=3  D WTPG^CHM FADR2 S DX =41,$X=DX  X XY D CSB RS^CHSC2 W :Y'="" @CH EOL
  18381   "RTN","CHM FA001",89, 0)
  18382    G:$D(DFOU T) END I $ D(DQOUT) D  QUES^CHMF ADR2,WTPG^ CHMFADR2 G  A1
  18383   "RTN","CHM FA001",90, 0)
  18384    I $D(DUOU T) D WTPG^ CHMFADR2 G  A3
  18385   "RTN","CHM FA001",91, 0)
  18386    I $D(D1OU T) D CHECK ^CHMFADR2, WTPG^CHMFA DR2 G A3
  18387   "RTN","CHM FA001",92, 0)
  18388    I $D(DDOU T) D CHECK ^CHMFADR2  G:$D(F1) A 3 D WTPG^C HMFADR2 G  END
  18389   "RTN","CHM FA001",93, 0)
  18390    D CHECK^C HMFADR2 G: $D(F1) A3  D WTPG^CHM FADR2,CLEA RB^CHMFADR 2
  18391   "RTN","CHM FA001",94, 0)
  18392   A4 S CHMFI MAG=1
  18393   "RTN","CHM FA001",95, 0)
  18394    N VALBENE
  18395   "RTN","CHM FA001",96, 0)
  18396    S VALBENE =$$BENECHK ^CHMFADR2( CHMOPDI,CH MFPDI,CHOS EN,1)  ;CP E005-122 a nd 123
  18397   "RTN","CHM FA001",97, 0)
  18398    I VALBENE  G ORIGPDI
  18399   "RTN","CHM FA001",98, 0)
  18400    ;S QU=4 D  WTIM^CHMF ADR2 S DX= 41 X XY D  CSBRS^CHSC 2
  18401   "RTN","CHM FA001",99, 0)
  18402    ;G:$D(DFO UT) END I  $D(DQOUT)  D QUES^CHM FADR2,WTIM ^CHMFADR2  G A4
  18403   "RTN","CHM FA001",100 ,0)
  18404    ;I $D(DUO UT) D WTIM ^CHMFADR2  G A3
  18405   "RTN","CHM FA001",101 ,0)
  18406    ;I $D(D1O UT) D CHEC K^CHMFADR2  G:$D(F1)  A4 D WTIM^ CHMFADR2 G  A3
  18407   "RTN","CHM FA001",102 ,0)
  18408    ;I $D(DDO UT) D CHEC K^CHMFADR2  G:$D(F1)  A4 D WTIM^ CHMFADR2 G  END
  18409   "RTN","CHM FA001",103 ,0)
  18410    ;D CHECK^ CHMFADR2 G :$D(F1) A4  D WTIM^CH MFADR2,CLE ARB^CHMFAD R2
  18411   "RTN","CHM FA001",104 ,0)
  18412   A6 S QU=6  D WTTYPE^C HMFADR2 S  DX=41,$X=D X X XY D C SBRS^CHSC2
  18413   "RTN","CHM FA001",105 ,0)
  18414    G:$D(DFOU T) END I $ D(DQOUT) S  Y="?" D C HECK^CHMFA DR2 G A6
  18415   "RTN","CHM FA001",106 ,0)
  18416    I $D(DUOU T) D WTTYP E^CHMFADR2  G A3
  18417   "RTN","CHM FA001",107 ,0)
  18418    I $D(D1OU T) D CHECK ^CHMFADR2  G:$D(F1) A 6 D WTTYPE ^CHMFADR2  G A3
  18419   "RTN","CHM FA001",108 ,0)
  18420    I $D(DDOU T) D CHECK ^CHMFADR2  G:$D(F1) A 6 D WTTYPE ^CHMFADR2  G END
  18421   "RTN","CHM FA001",109 ,0)
  18422    D CHECK^C HMFADR2 G: $D(F1) A6  D WTTYPE^C HMFADR2,CL EARB^CHMFA DR2 G ORIG PDI
  18423   "RTN","CHM FA001",110 ,0)
  18424   END D CLEA RB^CHMFADR 2
  18425   "RTN","CHM FA001",111 ,0)
  18426   E1 K NP,CH MFBAD,CHYE SFLG,CHMFK IL,CHMFSOR T,CHMFPRV, CHMFPS,CHM FPAUS,CHMF EXIT,CHMFB DBK
  18427   "RTN","CHM FA001",112 ,0)
  18428    N VALBENE ,VALOPDI
  18429   "RTN","CHM FA001",113 ,0)
  18430    D PRMPT^C HMFA100,AS K^CHMFA100  D CLEARB^ CHMFADR2 S  CHOICE=Y  G:CHOICE=1  A0
  18431   "RTN","CHM FA001",114 ,0)
  18432    G:CHOICE= 5 E1
  18433   "RTN","CHM FA001",115 ,0)
  18434    I CHOICE= 7 D  G E1
  18435   "RTN","CHM FA001",116 ,0)
  18436    .S DY=22, DX=10,$Y=D Y,$X=DX X  XY W @CHEO L
  18437   "RTN","CHM FA001",117 ,0)
  18438    .S DY=22, DX=22,$Y=D Y,$X=DX X  XY W "**** * This opt ion is not  available . *****" R  X:5
  18439   "RTN","CHM FA001",118 ,0)
  18440    .S DY=22, DX=10,$Y=D Y,$X=DX X  XY W @CHEO L
  18441   "RTN","CHM FA001",119 ,0)
  18442    S:CHOICE= 4 CHMFKIL= 1
  18443   "RTN","CHM FA001",120 ,0)
  18444    I CHOICE= 8 I CHMFPD I="" D NOP AUS^CHMFAD R2 G E1
  18445   "RTN","CHM FA001",121 ,0)
  18446    I CHOICE= 8 I CHMFPD I'=""  S C HMFPAUS=1
  18447   "RTN","CHM FA001",122 ,0)
  18448    I CHOICE= 9 D  G:$G( VALOPDI)!$ G(VALBENE)  E1 D ^CHM FA005 G EN D
  18449   "RTN","CHM FA001",123 ,0)
  18450    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q   ;CPE005-06 9
  18451   "RTN","CHM FA001",124 ,0)
  18452    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1)  ;C PE005-122  and 123
  18453   "RTN","CHM FA001",125 ,0)
  18454    I CHOICE= 6 D BDIMCK  G:$D(CHMF BDBK) E1 S  CHMFBAD=1  D ^CHMFAB IM
  18455   "RTN","CHM FA001",126 ,0)
  18456    I CHOICE= 10 D  G:$G (VALOPDI)! ($G(VALBEN E)) E1
  18457   "RTN","CHM FA001",127 ,0)
  18458    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q   ;CPE005-06 9
  18459   "RTN","CHM FA001",128 ,0)
  18460    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1)  ;C PE005-122  and 123
  18461   "RTN","CHM FA001",129 ,0)
  18462    I CHOICE= 10 I '$D(C HBTCHNO) D  NOBTCH^CH MFADR2 G E 1
  18463   "RTN","CHM FA001",130 ,0)
  18464    I CHOICE= 10 I CHBTC HNO="" D N OBTCH^CHMF ADR2 G E1
  18465   "RTN","CHM FA001",131 ,0)
  18466    I CHOICE= 10 D ^CHMF AB2 D  G E 1
  18467   "RTN","CHM FA001",132 ,0)
  18468    .I $D(CHB TCHNO) I C HBTCHNO'=" " I $$BTCH ST^CHMFABU 3(CHBTCHNO )=1 D
  18469   "RTN","CHM FA001",133 ,0)
  18470    ..S $P(^C HMDIC(7410 02.21,DUZ, 0),"^",6)= ""
  18471   "RTN","CHM FA001",134 ,0)
  18472    ..S $P(^C HMIMPB(CHB TCHNO,0)," ^",6)=""
  18473   "RTN","CHM FA001",135 ,0)
  18474    ..S CHMFP P="BATCLSD ",CHMFI=CH BTCHNO D ^ CHMFWK03
  18475   "RTN","CHM FA001",136 ,0)
  18476    ..S J=0 F   S J=$O(^ CHMIMPB(CH BTCHNO,100 ,J)) Q:'J   I $D(^CHM IMPB(CHBTC HNO,100,J, 0)) I ($P( ^(0),"^",3 )=2)!($P(^ (0),"^",3) =3) S CHMF PDI=$P(^(0 ),"^",1) D  SETPROD^C HMFIMG
  18477   "RTN","CHM FA001",137 ,0)
  18478    ..S CHBTC HNO="",CHM FPDI=""
  18479   "RTN","CHM FA001",138 ,0)
  18480    .S CHMFPD I="",CHMFN MPG="" D L INE^CHMFA1 00,SCREEN^ CHMFADR2
  18481   "RTN","CHM FA001",139 ,0)
  18482    I CHOICE= 3 I CHMFPD I'="" D  G :$G(VALOPD I)!$G(VALB ENE) E1 S  CHMFSORT=1
  18483   "RTN","CHM FA001",140 ,0)
  18484    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q   ;CPE005-06 9
  18485   "RTN","CHM FA001",141 ,0)
  18486    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1) I V ALBENE Q   ;CPE005-12 2 and 123
  18487   "RTN","CHM FA001",142 ,0)
  18488    .S X="" S :$D(^CHMIM AGE(CHMFPD I,0)) X=^( 0)
  18489   "RTN","CHM FA001",143 ,0)
  18490    .S $P(X," ^",1)=CHMF PDI,$P(X," ^",2)=CHMF NMPG,$P(X, "^",3)=DUZ
  18491   "RTN","CHM FA001",144 ,0)
  18492    .S $P(X," ^",4)=CHMF TMBG,PDIFL =1
  18493   "RTN","CHM FA001",145 ,0)
  18494    .S ^CHMIM AGE(CHMFPD I,0)=X,^CH MIMAGE("B" ,CHMFPDI,C HMFPDI)=""
  18495   "RTN","CHM FA001",146 ,0)
  18496    .I $P(^CH MIMG(CHMFP DI,0),"^", 4)="" S $P (^CHMIMG(C HMFPDI,0), "^",3)=DUZ ,$P(^CHMIM G(CHMFPDI, 0),"^",4)= CHMFTMBG
  18497   "RTN","CHM FA001",147 ,0)
  18498    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=DUZ
  18499   "RTN","CHM FA001",148 ,0)
  18500    .I '$D(^C HMIMG(CHMF PDI,"PAUSE ")) S $P(^ CHMIMG(CHM FPDI,0),"^ ",4)=CHMFT MBG
  18501   "RTN","CHM FA001",149 ,0)
  18502    I CHOICE= 2 D  G:$D( NP)!($G(VA LOPDI))!($ G(VALBENE) ) E1 D CHK PAG^CHMFAD R2 G:$D(NP ) E1 D ^CH MFA002,RED RAW^CHMFAD R2 G:$D(CH MFPREV) CH MFA001 D N EWPG^CHMFA DR2 G A0
  18503   "RTN","CHM FA001",150 ,0)
  18504    .I CHOSEN '=8 S CHMO PDI="XXXX"
  18505   "RTN","CHM FA001",151 ,0)
  18506    .K NP I ' $D(CHMFPDI )!'$D(CHMO PDI)!'$D(C HMFIMAG)!' $D(CHMFIMT Y)!'$D(CHM FPGNM) S N P="" D NOD ATA^CHMFAD R2 Q
  18507   "RTN","CHM FA001",152 ,0)
  18508    .K NP I ( CHMFPDI="" )!(CHMOPDI ="")!(CHMF IMAG="")!( CHMFIMTY=" ")!(CHMFPG NM="") S N P="" D NOD ATA^CHMFAD R2 Q
  18509   "RTN","CHM FA001",153 ,0)
  18510    .I CHOSEN '=8,CHMOPD I="XXXX" S  CHMOPDI=" "
  18511   "RTN","CHM FA001",154 ,0)
  18512    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q   ;CPE005-06 9
  18513   "RTN","CHM FA001",155 ,0)
  18514    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1) I V ALBENE Q   ;CPE005-12 2 and 123
  18515   "RTN","CHM FA001",156 ,0)
  18516    .I CHOSEN =8 D LOADI MG^CHMFADR 2 ;CPE005- 121 BDB 1/ 9/2018
  18517   "RTN","CHM FA001",157 ,0)
  18518    I CHOICE= 11 D  G E1
  18519   "RTN","CHM FA001",158 ,0)
  18520    .S HCHMFP DI=CHMFPDI
  18521   "RTN","CHM FA001",159 ,0)
  18522    .D ^CHMKP PR1
  18523   "RTN","CHM FA001",160 ,0)
  18524    .S CHMFPD I=HCHMFPDI
  18525   "RTN","CHM FA001",161 ,0)
  18526    .D RNGECL R^CHSC1(1, 18,XY,CHEO L)
  18527   "RTN","CHM FA001",162 ,0)
  18528    .D SETUP^ CHMFADR1
  18529   "RTN","CHM FA001",163 ,0)
  18530    .S CHTITL E="DOCUMEN T IDENTIFI CATION SCR EEN",CHSCR EEN=""
  18531   "RTN","CHM FA001",164 ,0)
  18532    .S CHSCRE EN=$O(^CHM SCRN("B",C HTITLE,CHS CREEN))
  18533   "RTN","CHM FA001",165 ,0)
  18534    .D TITLE^ CHMFA100,L INE^CHMFA1 00,CHOICE^ CHMFA100
  18535   "RTN","CHM FA001",166 ,0)
  18536    .D SCREEN ^CHMFADR2, ERRORS^CHM FA100
  18537   "RTN","CHM FA001",167 ,0)
  18538    I CHOICE= 12 D  G E1
  18539   "RTN","CHM FA001",168 ,0)
  18540    .S HCHMFP DI=CHMFPDI
  18541   "RTN","CHM FA001",169 ,0)
  18542    .D ^CHMKP DI1
  18543   "RTN","CHM FA001",170 ,0)
  18544    .S CHMFPD I=HCHMFPDI
  18545   "RTN","CHM FA001",171 ,0)
  18546    .D RNGECL R^CHSC1(1, 18,XY,CHEO L)
  18547   "RTN","CHM FA001",172 ,0)
  18548    .D SETUP^ CHMFADR1
  18549   "RTN","CHM FA001",173 ,0)
  18550    .S CHTITL E="DOCUMEN T IDENTIFI CATION SCR EEN",CHSCR EEN=""
  18551   "RTN","CHM FA001",174 ,0)
  18552    .S CHSCRE EN=$O(^CHM SCRN("B",C HTITLE,CHS CREEN))
  18553   "RTN","CHM FA001",175 ,0)
  18554    .D TITLE^ CHMFA100,L INE^CHMFA1 00,CHOICE^ CHMFA100
  18555   "RTN","CHM FA001",176 ,0)
  18556    .D SCREEN ^CHMFADR2, ERRORS^CHM FA100
  18557   "RTN","CHM FA001",177 ,0)
  18558    Q
  18559   "RTN","CHM FA001",178 ,0)
  18560    ;
  18561   "RTN","CHM FA001",179 ,0)
  18562   BDIMCK K C HMFBDBK
  18563   "RTN","CHM FA001",180 ,0)
  18564    I $D(^CHM DIC(741002 .21,DUZ,0) ) I $P(^(0 ),"^",10)= 1 Q
  18565   "RTN","CHM FA001",181 ,0)
  18566    S DY=22,D X=10,$Y=DY ,$X=DX X X Y W @CHEOL
  18567   "RTN","CHM FA001",182 ,0)
  18568    S DY=22,D X=22,$Y=DY ,$X=DX X X Y W "***** This optio n is not a vailable.* ****" R X: 5
  18569   "RTN","CHM FA001",183 ,0)
  18570    S DY=22,D X=10,$Y=DY ,$X=DX X X Y W @CHEOL
  18571   "RTN","CHM FA001",184 ,0)
  18572    S CHMFBDB K=""
  18573   "RTN","CHM FA001",185 ,0)
  18574    Q
  18575   "RTN","CHM FA001",186 ,0)
  18576    ;
  18577   "RTN","CHM FA001",187 ,0)
  18578    D CSBRS^C HSC2   S Y ="" U $I X  ^%ZOSF("E OFF") K TL
  18579   "RTN","CHM FA001",188 ,0)
  18580    F I=1:1:3 1 S:I=31 T L=1 R *X:$ S($D(DTIME ):DTIME,1: 60) Q:(X=1 3)!(X=9)!( X=27)  S:X '=127 Y=Y_ $C(X) D:X= 127  S:I=0  Y="" W:X' =127 $C(X)
  18581   "RTN","CHM FA001",189 ,0)
  18582    .S:I=1 I= 0 Q:I=0  S :I'=1 I=I- 2,Y=$E(Y,1 ,I) W *8,* 27," ",*8, *27 Q
  18583   "RTN","CHM FA001",190 ,0)
  18584    D CSBRS^C HSC21  K D FOUT,DUOUT ,DQOUT,DDO UT,D1OUT,D 2OUT
  18585   "RTN","CHM FA001",191 ,0)
  18586    I X=27 F  I=1:1:2 R  *X D:I=2
  18587   "RTN","CHM FA001",192 ,0)
  18588    .S:X=65 D 1OUT="" S: X=66 D2OUT =""
  18589   "RTN","CHM FA001",193 ,0)
  18590    S:X=9 DDO UT="" S:X= 9 DTOUT=""  I Y="^^"  S (DFOUT,Y )=""
  18591   "RTN","CHM FA001",194 ,0)
  18592    S:Y="^" ( DUOUT,Y)=" " S:Y?1"?" .E!(Y["^")  (DQOUT,Y) =""
  18593   "RTN","CHM FA001",195 ,0)
  18594    U $I X ^% ZOSF("EON" ) Q
  18595   "RTN","CHM FA002")
  18596   0^93^B6171 486
  18597   "RTN","CHM FA002",1,0 )
  18598   CHMFA002 ; PJU/DEN;CH AMPVA PAGE  SCREEN;Fe b 06, 2019 @10:06:42
  18599   "RTN","CHM FA002",2,0 )
  18600    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  18601   "RTN","CHM FA002",3,0 )
  18602    ;;V2.0;
  18603   "RTN","CHM FA002",4,0 )
  18604    ;V2.0;JLR /DEN
  18605   "RTN","CHM FA002",5,0 )
  18606    ;JEH 2/1/ 11 DEV0078 20 - SLLA
  18607   "RTN","CHM FA002",6,0 )
  18608    ;CFS 01/2 9/2018 CPE 005-004 Ad d the vari able NEXTP AGE so tha t the
  18609   "RTN","CHM FA002",7,0 )
  18610    ;                            PD I Numbers  become Rea donly on t he DOC ID  Screen.
  18611   "RTN","CHM FA002",8,0 )
  18612    S LN="",$ P(LN," ",8 1)="" F DY =1,2 S DX= 1,$X=DX X  XY W @CHRE VON,LN
  18613   "RTN","CHM FA002",9,0 )
  18614    S NEXTPAG E=1
  18615   "RTN","CHM FA002",10, 0)
  18616    D HEAD^CH MFA100 D @ CHMFIMTY G  EXIT
  18617   "RTN","CHM FA002",11, 0)
  18618   1 D ^CHMFA 003
  18619   "RTN","CHM FA002",12, 0)
  18620    S PC=1 D  BENERTN^CH MFA007 Q:C HRTN=""
  18621   "RTN","CHM FA002",13, 0)
  18622   1A D @CHRT N Q:$D(CHM FKILL)  Q: $D(CHMFPRE V)  Q:$D(C HMFPSBN)
  18623   "RTN","CHM FA002",14, 0)
  18624    G:'$D(DFN ) 1A G:'$D (BFN) 1A G :DFN="" 1A  G:BFN=""  1A
  18625   "RTN","CHM FA002",15, 0)
  18626    ;D ^CHMFA 101
  18627   "RTN","CHM FA002",16, 0)
  18628    Q:$D(DFOU T)  G:$D(D UOUT) 1A Q :$D(CHFIFL AG)
  18629   "RTN","CHM FA002",17, 0)
  18630   1B D ^CHMF A010 Q:$D( CHMFKILL)   G:$D(CHMF PREV) 1A
  18631   "RTN","CHM FA002",18, 0)
  18632    ;D ^ZJLRA 010 Q:$D(C HMFKILL)   G:$D(CHMFP REV) 1A
  18633   "RTN","CHM FA002",19, 0)
  18634    S CHMFSRV C=$P(CHMFB ASC(4),"^" ,3)
  18635   "RTN","CHM FA002",20, 0)
  18636    ;S CHMFRT N=$S(CHMFS RVC=1:"^CH MFA110",CH MFSRVC=2:" ^CHMFA140" ,CHMFSRVC= 3:"^CHMFA1 50",CHMFSR VC=4:"^CHM FA160",CHM FSRVC=5:"^ CHMFA170", CHMFSRVC=6 :"^CHMFA18 0",1:"")   ;JEH 2/1/1 1 DEV00782 0
  18637   "RTN","CHM FA002",21, 0)
  18638    S CHMFRTN =$S(CHMFSR VC=1:"^CHM FA110",CHM FSRVC=2:"^ CHMFA140", CHMFSRVC=3 :"^CHMFA15 0",CHMFSRV C=4:"^CHMF A140",CHMF SRVC=5:"^C HMFA140",C HMFSRVC=6: "^CHMFA140 ",1:"")  ; JEH 2/1/11  DEV007820
  18639   "RTN","CHM FA002",22, 0)
  18640    ;;;I $P(^ CHMVEN(VFN ,1),U,7)=8 8 D ^CHMFA 14O   ;JEH  2/1/11 DE V007820 -  GETTING ME DICAID PAY MENTS IF V ENDOR IS A  MEDICAID  TYPE
  18641   "RTN","CHM FA002",23, 0)
  18642    G:CHMFRTN ="" 1B K C HPHPAY,CHS UM D @CHMF RTN G:$D(C HMFPREV) 1 B Q
  18643   "RTN","CHM FA002",24, 0)
  18644    ;
  18645   "RTN","CHM FA002",25, 0)
  18646    ;CLAIM FO RM ROUTINE  HERE
  18647   "RTN","CHM FA002",26, 0)
  18648   2 K CHMFKI LL,CHMFPRE V,CHMFNEXT
  18649   "RTN","CHM FA002",27, 0)
  18650    D ^CHMFA0 03
  18651   "RTN","CHM FA002",28, 0)
  18652   2A D ^CHMF A020 Q:$D( CHMFKILL)   Q:$D(CHMF PREV)
  18653   "RTN","CHM FA002",29, 0)
  18654   2B D ^CHMF A200 Q:$D( CHMFKILL)   G:$D(CHMF PREV) 2A
  18655   "RTN","CHM FA002",30, 0)
  18656    ;D ^CHMFA 190 Q:$D(C HMFKILL)   G:$D(CHMFP REV) 2B
  18657   "RTN","CHM FA002",31, 0)
  18658    Q
  18659   "RTN","CHM FA002",32, 0)
  18660    ;
  18661   "RTN","CHM FA002",33, 0)
  18662    ;SUPORTIN G DOCUMENT  SCREEN HE RE
  18663   "RTN","CHM FA002",34, 0)
  18664   3 K CHMFKI LL,CHMFPRE V,CHMFNEXT
  18665   "RTN","CHM FA002",35, 0)
  18666    D ^CHMFA0 03
  18667   "RTN","CHM FA002",36, 0)
  18668   3A D ^CHMF A020 Q:$D( CHMFKILL)   Q:$D(CHMF PREV)
  18669   "RTN","CHM FA002",37, 0)
  18670   3B D ^CHMF A300 Q:$D( CHMFKILL)   G:$D(CHMF PREV) 3A
  18671   "RTN","CHM FA002",38, 0)
  18672    ;D ^CHMFA 190 Q:$D(C HMFKILL)   G:$D(CHMFP REV) 3B
  18673   "RTN","CHM FA002",39, 0)
  18674    Q
  18675   "RTN","CHM FA002",40, 0)
  18676    ;
  18677   "RTN","CHM FA002",41, 0)
  18678    ;OCHAMPUS  DEDUCTIBL E SCREEN H ERE
  18679   "RTN","CHM FA002",42, 0)
  18680   6 K CHMFKI LL,CHMFPRE V,CHMFNEXT
  18681   "RTN","CHM FA002",43, 0)
  18682    D ^CHMFA0 03
  18683   "RTN","CHM FA002",44, 0)
  18684   6A D ^CHMF A020 Q:$D( CHMFKILL)   Q:$D(CHMF PREV)
  18685   "RTN","CHM FA002",45, 0)
  18686   6B D ^CHMF A500 Q:$D( CHMFKILL)   G:$D(CHMF PREV) 6A
  18687   "RTN","CHM FA002",46, 0)
  18688    Q
  18689   "RTN","CHM FA002",47, 0)
  18690    ;OHI EOB  SCREEN HER E
  18691   "RTN","CHM FA002",48, 0)
  18692   7 K CHMFKI LL,CHMFPRE V,CHMFNEXT
  18693   "RTN","CHM FA002",49, 0)
  18694    D ^CHMFA0 03,^CHMFA4 00
  18695   "RTN","CHM FA002",50, 0)
  18696    Q
  18697   "RTN","CHM FA002",51, 0)
  18698    ;REOPEN S CREEN HERE
  18699   "RTN","CHM FA002",52, 0)
  18700   8 K CHMFKI LL,CHMFPRE V,CHMFNEXT
  18701   "RTN","CHM FA002",53, 0)
  18702    D ^CHMFA0 03,^CHMFA6 00
  18703   "RTN","CHM FA002",54, 0)
  18704    Q
  18705   "RTN","CHM FA002",55, 0)
  18706    ;CORRESPO NDENCE SCR EEN
  18707   "RTN","CHM FA002",56, 0)
  18708   9 K CHMFKI LL,CHMFPRE V,CHMFNEXT
  18709   "RTN","CHM FA002",57, 0)
  18710    D ^CHMFA0 03,^CHMFA7 00
  18711   "RTN","CHM FA002",58, 0)
  18712    Q
  18713   "RTN","CHM FA002",59, 0)
  18714    ;
  18715   "RTN","CHM FA002",60, 0)
  18716   EXIT S HTY PE=CHMFIMT Y
  18717   "RTN","CHM FA002",61, 0)
  18718   END K TL,L N,CHMFQUIT  Q
  18719   "RTN","CHM FA002",62, 0)
  18720   BADIM S HY =DY,HX=DX, DY=16,DX=2 2,$Y=DY,$X =DX X XY
  18721   "RTN","CHM FA002",63, 0)
  18722    W "Bad Im age Select ion, choos e again!"  S DY=HY,DX =HX,$Y=DY, $X=DX X XY  Q
  18723   "RTN","CHM FA008")
  18724   0^37^B7065 9720
  18725   "RTN","CHM FA008",1,0 )
  18726   CHMFA008 ; JLR/DEN;DO CUMENT IDE NTIFICATIO N SCREEN;F eb 06, 201 9@10:07:31
  18727   "RTN","CHM FA008",2,0 )
  18728    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  18729   "RTN","CHM FA008",3,0 )
  18730    ;;CPTS #1 4989 (RLC)
  18731   "RTN","CHM FA008",4,0 )
  18732    ;;MODIFIE D BY RLC O N 4/13/95  - ADDED OP TION 11) P PR
  18733   "RTN","CHM FA008",5,0 )
  18734    ;;MODIFIE D BY RLC O N 4/28/95  - ADDED OP TION 12) P PRs-PDI
  18735   "RTN","CHM FA008",6,0 )
  18736    ;;;JEH 12 /16/09 MTN 008252 - O CR claim m ultiplicat ion by VE
  18737   "RTN","CHM FA008",7,0 )
  18738    ;;DHS 12/ 17/09 DEV0 05356 unbl ocked the  program ty pe 9 check
  18739   "RTN","CHM FA008",8,0 )
  18740    ;;DEV0053 56 11/29/2 011 DGC
  18741   "RTN","CHM FA008",9,0 )
  18742    ;; change s made to  comment ou t DEV5356  changes to  go live -  RVS 1/11/ 2010
  18743   "RTN","CHM FA008",10, 0)
  18744    ;;CFS 08/ 01/2017 CP E005-004 A dd the Ori ginal PDI  Number pro mpt.
  18745   "RTN","CHM FA008",11, 0)
  18746    ;;CFS 10/ 01/2017 CP E005-069 R emoved set  up of CHO SEN variab le in line  tag A1+1.
  18747   "RTN","CHM FA008",12, 0)
  18748    ;;                            I t is now N ewed and S et in rout ine CHMFAD R4.
  18749   "RTN","CHM FA008",13, 0)
  18750    ;;CFS 01/ 13/2018 CP E005-122 a nd 123 Add  call for  bene check  validatio n.
  18751   "RTN","CHM FA008",14, 0)
  18752    D CLEAR^C HMFADR2
  18753   "RTN","CHM FA008",15, 0)
  18754    S CHTITLE ="DOCUMENT  IDENTIFIC ATION SCRE EN",CHSCRE EN=""
  18755   "RTN","CHM FA008",16, 0)
  18756    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN))
  18757   "RTN","CHM FA008",17, 0)
  18758    I 'CHSCRE EN D NOSCR ^CHMFADR2  G END
  18759   "RTN","CHM FA008",18, 0)
  18760    D TITLE^C HMFA100,LI NE^CHMFA10 0,CHOICE^C HMFA100
  18761   "RTN","CHM FA008",19, 0)
  18762    D SCREEN^ CHMFADR2,E RRORS^CHMF A100
  18763   "RTN","CHM FA008",20, 0)
  18764    D NOW^%DT C S CHMFTM BG=%
  18765   "RTN","CHM FA008",21, 0)
  18766   A0 K CHMFC ,CHMFBAD,C HNOFLAG,CH YESFLG,CHM NNUM,CHMFQ UIT
  18767   "RTN","CHM FA008",22, 0)
  18768   A1 I $G(CH OSEN)'=6,$ G(CHOSEN)' =7 K F0,F1  D WTPDI^C HMFADR2 G  A2
  18769   "RTN","CHM FA008",23, 0)
  18770    K Y
  18771   "RTN","CHM FA008",24, 0)
  18772   ORIGPDI ;C PE005-004  Original P DI prompt.
  18773   "RTN","CHM FA008",25, 0)
  18774    K F0,F1
  18775   "RTN","CHM FA008",26, 0)
  18776    I '$D(NEX TPAGE) S N EXTPAGE=0
  18777   "RTN","CHM FA008",27, 0)
  18778    I NEXTPAG E G A2
  18779   "RTN","CHM FA008",28, 0)
  18780    S QU=7
  18781   "RTN","CHM FA008",29, 0)
  18782    I $G(CHMO PDI)="",'$ G(VALOPDI) ,'$G(VALBE NE) S CHMO PDI=$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",2)
  18783   "RTN","CHM FA008",30, 0)
  18784    I $G(CHMO PDI)'="" D   I '$G(VA LOPDI),'$G (VALBENE)  S CHMFIMAG =1 ;G A2
  18785   "RTN","CHM FA008",31, 0)
  18786    .S VALOPD I=$$CHKOPD I^CHMFADR2 ($G(CHMFPD I),CHMOPDI ,CHOSEN,1)
  18787   "RTN","CHM FA008",32, 0)
  18788    D WTOPDI^ CHMFADR2 S  DX=41,$X= DX X XY D  CSBRS^CHSC 2 W:Y'=""  @CHEOL
  18789   "RTN","CHM FA008",33, 0)
  18790    G:$D(DFOU T) END
  18791   "RTN","CHM FA008",34, 0)
  18792    I $D(DQOU T) S Y="?"  D QUES^CH MFADR2,WTO PDI^CHMFAD R2 G ORIGP DI
  18793   "RTN","CHM FA008",35, 0)
  18794    I $D(DUOU T) D WTOPD I^CHMFADR2  G END
  18795   "RTN","CHM FA008",36, 0)
  18796    I $D(D1OU T) G ORIGP DI
  18797   "RTN","CHM FA008",37, 0)
  18798    I $D(DDOU T),$D(CHMO PDI) D WTO PDI^CHMFAD R2 G END
  18799   "RTN","CHM FA008",38, 0)
  18800    I $D(DDOU T) G END
  18801   "RTN","CHM FA008",39, 0)
  18802    I $D(D2OU T),$G(VALO PDI) G ORI GPDI
  18803   "RTN","CHM FA008",40, 0)
  18804    I Y="",CH MOPDI'=""  S Y=CHMOPD I
  18805   "RTN","CHM FA008",41, 0)
  18806    D CHECK^C HMFADR2 I  $G(F1)=1 S  CHMOPDI=Y  G ORIGPDI
  18807   "RTN","CHM FA008",42, 0)
  18808    I Y="",$G (CHMOPDI)' ="",'$G(VA LOPDI) G A 1
  18809   "RTN","CHM FA008",43, 0)
  18810    I CHMOPDI ="",'$G(VA LOPDI) D C LEARB^CHMF ADR2 G ORI GPDI
  18811   "RTN","CHM FA008",44, 0)
  18812    I Y'="",' $G(VALOPDI ) S CHMOPD I=Y
  18813   "RTN","CHM FA008",45, 0)
  18814   A2 S:'$D(C HMFNMPG) C HMFNMPG=""
  18815   "RTN","CHM FA008",46, 0)
  18816    I $D(^CHM IMG(CHMFPD I,0)) S:CH MFNMPG=""  CHMFNMPG=$ P(^(0),"^" ,2)  ; Sub script err or 9/7/5 m lr
  18817   "RTN","CHM FA008",47, 0)
  18818    I $D(CHMF NMPG) I CH MFNMPG'=""  D WTNP^CH MFADR2 G A 3
  18819   "RTN","CHM FA008",48, 0)
  18820    S:'$D(CHM FNMPG) CHM FNMPG=""
  18821   "RTN","CHM FA008",49, 0)
  18822    S:CHMFNMP G="" CHMFN MPG="UNK"
  18823   "RTN","CHM FA008",50, 0)
  18824    S QU=2 D  WTNP^CHMFA DR2 S DX=4 1,$X=DX X  XY
  18825   "RTN","CHM FA008",51, 0)
  18826    D CSBRS^C HSC2 W:Y'= "" @CHEOL
  18827   "RTN","CHM FA008",52, 0)
  18828    G:$D(DFOU T) END
  18829   "RTN","CHM FA008",53, 0)
  18830    I $D(DQOU T) D QUES^ CHMFADR2,W TNP^CHMFAD R2 G A1
  18831   "RTN","CHM FA008",54, 0)
  18832    I $D(DUOU T) D WTNP^ CHMFADR2 G  END
  18833   "RTN","CHM FA008",55, 0)
  18834    I $D(D1OU T) D CHECK ^CHMFADR2, WTNP^CHMFA DR2 G A1
  18835   "RTN","CHM FA008",56, 0)
  18836    I $D(DDOU T) D WTNP^ CHMFADR2 G  END
  18837   "RTN","CHM FA008",57, 0)
  18838    I Y="" D  CLEARB^CHM FADR2 G A3
  18839   "RTN","CHM FA008",58, 0)
  18840    D CHECK^C HMFADR2
  18841   "RTN","CHM FA008",59, 0)
  18842    G:$D(F1)  A2
  18843   "RTN","CHM FA008",60, 0)
  18844    D WTNP^CH MFADR2,CLE ARB^CHMFAD R2
  18845   "RTN","CHM FA008",61, 0)
  18846   A3 S QU=3
  18847   "RTN","CHM FA008",62, 0)
  18848    D WTPG^CH MFADR2
  18849   "RTN","CHM FA008",63, 0)
  18850    S DX=41,$ X=DX X XY
  18851   "RTN","CHM FA008",64, 0)
  18852    S TMPPGNM =CHMFPGNM, TMPNMPG=CH MFNMPG   ; JEH 12/16/ 09 MTN0082 52 - ADDED  LINE
  18853   "RTN","CHM FA008",65, 0)
  18854    D CSBRS^C HSC2
  18855   "RTN","CHM FA008",66, 0)
  18856    W:Y'="" @ CHEOL
  18857   "RTN","CHM FA008",67, 0)
  18858    I Y>199 S  CHMFPGNM= TMPPGNM,CH MFNMPG=TMP NMPG G A3    ;JEH 12/ 16/09 MTN0 08252 - AD DED LINE
  18859   "RTN","CHM FA008",68, 0)
  18860    G:$D(DFOU T) END
  18861   "RTN","CHM FA008",69, 0)
  18862    I $D(DQOU T) D QUES^ CHMFADR2,W TPG^CHMFAD R2 G A1
  18863   "RTN","CHM FA008",70, 0)
  18864    I $D(DUOU T) D WTPG^ CHMFADR2 G  A3
  18865   "RTN","CHM FA008",71, 0)
  18866    I $D(D1OU T) D CHECK ^CHMFADR2, WTPG^CHMFA DR2 G A3
  18867   "RTN","CHM FA008",72, 0)
  18868    I $D(DDOU T) D CHECK ^CHMFADR2  G:$D(F1) A 3 D WTPG^C HMFADR2 G  END
  18869   "RTN","CHM FA008",73, 0)
  18870    D CHECK^C HMFADR2
  18871   "RTN","CHM FA008",74, 0)
  18872    G:$D(F1)  A3
  18873   "RTN","CHM FA008",75, 0)
  18874    I $D(CHMF PGNM) I CH MFPGNM'=""  I CHMFPGN M>CHMFNMPG  D
  18875   "RTN","CHM FA008",76, 0)
  18876    .S CHMFNM PG=CHMFPGN M,$P(^CHMI MG(CHMFPDI ,0),"^",2) =CHMFPGNM
  18877   "RTN","CHM FA008",77, 0)
  18878    .D WTNP^C HMFADR2
  18879   "RTN","CHM FA008",78, 0)
  18880    D WTPG^CH MFADR2,CLE ARB^CHMFAD R2
  18881   "RTN","CHM FA008",79, 0)
  18882   A4 S CHMFI MAG=1
  18883   "RTN","CHM FA008",80, 0)
  18884    N VALBENE
  18885   "RTN","CHM FA008",81, 0)
  18886    S VALBENE =$$BENECHK ^CHMFADR2( CHMOPDI,CH MFPDI,CHOS EN,1)
  18887   "RTN","CHM FA008",82, 0)
  18888    I VALBENE  G ORIGPDI
  18889   "RTN","CHM FA008",83, 0)
  18890    ;S QU=4
  18891   "RTN","CHM FA008",84, 0)
  18892    ;D WTIM^C HMFADR2
  18893   "RTN","CHM FA008",85, 0)
  18894    ;S DX=41  X XY
  18895   "RTN","CHM FA008",86, 0)
  18896    ;D CSBRS^ CHSC2
  18897   "RTN","CHM FA008",87, 0)
  18898    ;G:$D(DFO UT) END
  18899   "RTN","CHM FA008",88, 0)
  18900    ;I $D(DQO UT) D QUES ^CHMFADR2, WTIM^CHMFA DR2 G A4
  18901   "RTN","CHM FA008",89, 0)
  18902    ;I $D(DUO UT) D WTIM ^CHMFADR2  G A3
  18903   "RTN","CHM FA008",90, 0)
  18904    ;I $D(D1O UT) D CHEC K^CHMFADR2  G:$D(F1)  A4 D WTIM^ CHMFADR2 G  A3
  18905   "RTN","CHM FA008",91, 0)
  18906    ;I $D(DDO UT) D CHEC K^CHMFADR2  G:$D(F1)  A4 D WTIM^ CHMFADR2 G  END
  18907   "RTN","CHM FA008",92, 0)
  18908    ;D CHECK^ CHMFADR2
  18909   "RTN","CHM FA008",93, 0)
  18910    ;G:$D(F1)  A4
  18911   "RTN","CHM FA008",94, 0)
  18912    ;D WTIM^C HMFADR2,CL EARB^CHMFA DR2
  18913   "RTN","CHM FA008",95, 0)
  18914   A6 S QU=6
  18915   "RTN","CHM FA008",96, 0)
  18916    D WTTYPE^ CHMFADR2
  18917   "RTN","CHM FA008",97, 0)
  18918    S DX=41,$ X=DX X XY
  18919   "RTN","CHM FA008",98, 0)
  18920    D CSBRS^C HSC2
  18921   "RTN","CHM FA008",99, 0)
  18922    G:$D(DFOU T) END
  18923   "RTN","CHM FA008",100 ,0)
  18924    I $D(DQOU T) S Y="?"  D CHECK^C HMFADR2 G  A6
  18925   "RTN","CHM FA008",101 ,0)
  18926    I $D(DUOU T) D WTTYP E^CHMFADR2  G A4
  18927   "RTN","CHM FA008",102 ,0)
  18928    I $D(D1OU T) D CHECK ^CHMFADR2  G:$D(F1) A 6 D WTTYPE ^CHMFADR2  G A4
  18929   "RTN","CHM FA008",103 ,0)
  18930    I $D(DDOU T) D CHECK ^CHMFADR2  G:$D(F1) A 6 D WTTYPE ^CHMFADR2  G END
  18931   "RTN","CHM FA008",104 ,0)
  18932    D CHECK^C HMFADR2
  18933   "RTN","CHM FA008",105 ,0)
  18934    G:$D(F1)  A6
  18935   "RTN","CHM FA008",106 ,0)
  18936    D WTTYPE^ CHMFADR2,C LEARB^CHMF ADR2 G A1
  18937   "RTN","CHM FA008",107 ,0)
  18938   END D CLEA RB^CHMFADR 2
  18939   "RTN","CHM FA008",108 ,0)
  18940   E1 K NP,CH MFBAD,CHYE SFLG,CHMFK IL,CHMFSOR T,CHMFPRV, CHMFPS,CHM FPAUS,CHMF EXIT,CHMFB DBK,CHMFPD RV
  18941   "RTN","CHM FA008",109 ,0)
  18942    N VALBENE ,VALOPDI
  18943   "RTN","CHM FA008",110 ,0)
  18944    D PRMPT^C HMFA100,AS K^CHMFA100  D CLEARB^ CHMFADR2 S  CHOICE=Y  G:CHOICE=1  A0
  18945   "RTN","CHM FA008",111 ,0)
  18946    I CHOICE= 5 K FLAG1  D  G:$D(FL AG1) A0
  18947   "RTN","CHM FA008",112 ,0)
  18948    .D RNGECL R^CHSC1(13 ,18,XY,CHE OL) S DX=1 ,DY=14,$Y= DY,$X=DX X  XY
  18949   "RTN","CHM FA008",113 ,0)
  18950    .W "Optio n #5 is NO T AVAILABL E." R X:15
  18951   "RTN","CHM FA008",114 ,0)
  18952    .D CLEAR^ CHMFADR2,S CREEN^CHMF ADR2 S FLA G1=1
  18953   "RTN","CHM FA008",115 ,0)
  18954    .Q
  18955   "RTN","CHM FA008",116 ,0)
  18956    ;S:CHOICE =4 CHMFEXI T=1
  18957   "RTN","CHM FA008",117 ,0)
  18958    S:CHOICE= 4 CHMFKIL= 1
  18959   "RTN","CHM FA008",118 ,0)
  18960    I CHOICE= 8 I CHMFPD I="" D NOP AUS^CHMFAD R2 G E1
  18961   "RTN","CHM FA008",119 ,0)
  18962    I CHOICE= 8 I CHMFPD I'=""  S C HMFPAUS=1
  18963   "RTN","CHM FA008",120 ,0)
  18964    I CHOICE= 9 D  G:$G( VALOPDI)!$ G(VALBENE)  E1 D ^CHM FA005 G EN D
  18965   "RTN","CHM FA008",121 ,0)
  18966    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q
  18967   "RTN","CHM FA008",122 ,0)
  18968    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1)  ;C PE005-122  and 123
  18969   "RTN","CHM FA008",123 ,0)
  18970    I (CHOICE =6)&(IPSUB ="OCR2^CHM FADR4") D   Q  ;DGC 1 1/30/11 DE V005356 BE GIN
  18971   "RTN","CHM FA008",124 ,0)
  18972    .D ^CHMFA BUNR
  18973   "RTN","CHM FA008",125 ,0)
  18974    .I CHMFBA D="" D  G  E1
  18975   "RTN","CHM FA008",126 ,0)
  18976    ..S DX=1  F DY=12:1: 20 X XY W  @CHEOL        ;DGC 11 /30/11 DEV 005356 END
  18977   "RTN","CHM FA008",127 ,0)
  18978    I CHOICE= 6 D BDIMCK  G:$D(CHMF BDBK) E1 S  CHMFBAD=1  D ^CHMFAB IM  ;dhs 1 2/17/09 or iginal lin e prg type =9
  18979   "RTN","CHM FA008",128 ,0)
  18980    ;I CHOICE =6 S CHMFB AD=1 D ^CH MFABIM ;dh s 12/17/09  remove ch eck for pr ogram prg  type=9
  18981   "RTN","CHM FA008",129 ,0)
  18982     I CHOICE =10 D  G:$ G(VALOPDI) !$G(VALBEN E) E1 ;CPE 005-004
  18983   "RTN","CHM FA008",130 ,0)
  18984    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q
  18985   "RTN","CHM FA008",131 ,0)
  18986    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1)  ;C PE005-122  and 123
  18987   "RTN","CHM FA008",132 ,0)
  18988    I CHOICE= 10 I '$D(C HBTCHNO) D  NOBTCH^CH MFADR2 G E 1
  18989   "RTN","CHM FA008",133 ,0)
  18990    I CHOICE= 10 I CHBTC HNO="" D N OBTCH^CHMF ADR2 G E1
  18991   "RTN","CHM FA008",134 ,0)
  18992    I CHOICE= 10 D ^CHMF AB2 D  G E 1
  18993   "RTN","CHM FA008",135 ,0)
  18994    .I $D(CHB TCHNO) I C HBTCHNO'=" " I $$BTCH ST^CHMFABU 3(CHBTCHNO )=1 D
  18995   "RTN","CHM FA008",136 ,0)
  18996    ..S $P(^C HMDIC(7410 02.21,DUZ, 0),"^",6)= ""
  18997   "RTN","CHM FA008",137 ,0)
  18998    ..S $P(^C HMIMPB(CHB TCHNO,0)," ^",6)=""
  18999   "RTN","CHM FA008",138 ,0)
  19000    ..S CHMFP P="BATCLSD ",CHMFI=CH BTCHNO D ^ CHMFWK03
  19001   "RTN","CHM FA008",139 ,0)
  19002    ..S J=0 F   S J=$O(^ CHMIMPB(CH BTCHNO,100 ,J)) Q:'J   I $D(^CHM IMPB(CHBTC HNO,100,J, 0)) I ($P( ^(0),"^",3 )=2)!($P(^ (0),"^",3) =3) S CHMF PDI=$P(^(0 ),"^",1) D  SETPROD^C HMFIMG
  19003   "RTN","CHM FA008",140 ,0)
  19004    ..S CHBTC HNO="",CHM FPDI=""
  19005   "RTN","CHM FA008",141 ,0)
  19006    .S CHMFPD I="",CHMFN MPG="" D L INE^CHMFA1 00,SCREEN^ CHMFADR2
  19007   "RTN","CHM FA008",142 ,0)
  19008    I CHOICE= 3 I CHMFPD I'="" D  G :$G(VALOPD I)!($G(VAL BENE)) E1   S CHMFSOR T=1
  19009   "RTN","CHM FA008",143 ,0)
  19010    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q
  19011   "RTN","CHM FA008",144 ,0)
  19012    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1) I V ALBENE Q   ;CPE005-12 2 and 123
  19013   "RTN","CHM FA008",145 ,0)
  19014    .S X="" S :$D(^CHMIM AGE(CHMFPD I,0)) X=^( 0)
  19015   "RTN","CHM FA008",146 ,0)
  19016    .S $P(X," ^",1)=CHMF PDI,$P(X," ^",2)=CHMF NMPG,$P(X, "^",3)=DUZ
  19017   "RTN","CHM FA008",147 ,0)
  19018    .S $P(X," ^",4)=CHMF TMBG,PDIFL =1
  19019   "RTN","CHM FA008",148 ,0)
  19020    .S ^CHMIM AGE(CHMFPD I,0)=X,^CH MIMAGE("B" ,CHMFPDI,C HMFPDI)=""
  19021   "RTN","CHM FA008",149 ,0)
  19022    .I $P(^CH MIMG(CHMFP DI,0),"^", 4)="" S $P (^CHMIMG(C HMFPDI,0), "^",3)=DUZ ,$P(^CHMIM G(CHMFPDI, 0),"^",4)= CHMFTMBG
  19023   "RTN","CHM FA008",150 ,0)
  19024    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=DUZ
  19025   "RTN","CHM FA008",151 ,0)
  19026    .I '$D(^C HMIMG(CHMF PDI,"PAUSE ")) S $P(^ CHMIMG(CHM FPDI,0),"^ ",4)=CHMFT MBG
  19027   "RTN","CHM FA008",152 ,0)
  19028    I CHOICE= 2 D  G:$D( NP)!($G(VA LOPDI))!($ G(VALBENE) ) E1 D CHK PAG^CHMFAD R2 G:$D(NP ) E1 D ^CH MFA002,RED RAW^CHMFAD R2 G:$D(CH MFPREV) CH MFA008 D G ETDATA,NEW PG^CHMFADR 2 G A0
  19029   "RTN","CHM FA008",153 ,0)
  19030    .I CHOSEN '=6,CHOSEN '=7,CHOSEN '=8 S CHMO PDI="XXXX"
  19031   "RTN","CHM FA008",154 ,0)
  19032    .K NP I ' $D(CHMFPDI )!'$D(CHMO PDI)!'$D(C HMFIMAG)!' $D(CHMFIMT Y)!'$D(CHM FPGNM) S N P="" D NOD ATA^CHMFAD R2 Q
  19033   "RTN","CHM FA008",155 ,0)
  19034    .K NP I ( CHMFPDI="" )!(CHMOPDI ="")!(CHMF IMAG="")!( CHMFIMTY=" ")!(CHMFPG NM="") S N P="" D NOD ATA^CHMFAD R2 Q
  19035   "RTN","CHM FA008",156 ,0)
  19036    .I CHOSEN '=6,CHOSEN '=7,CHOSEN '=8,CHMOPD I="XXXX" S  CHMOPDI=" "
  19037   "RTN","CHM FA008",157 ,0)
  19038    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q
  19039   "RTN","CHM FA008",158 ,0)
  19040    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1)  ;C PE005-122  and 123
  19041   "RTN","CHM FA008",159 ,0)
  19042    I CHOICE= 11 D  G E1
  19043   "RTN","CHM FA008",160 ,0)
  19044    .S HCHMFP DI=CHMFPDI
  19045   "RTN","CHM FA008",161 ,0)
  19046    .D ^CHMKP PR1
  19047   "RTN","CHM FA008",162 ,0)
  19048    .S CHMFPD I=HCHMFPDI
  19049   "RTN","CHM FA008",163 ,0)
  19050    .D RNGECL R^CHSC1(1, 18,XY,CHEO L)
  19051   "RTN","CHM FA008",164 ,0)
  19052    .D SETUP^ CHMFADR1
  19053   "RTN","CHM FA008",165 ,0)
  19054    .S CHTITL E="DOCUMEN T IDENTIFI CATION SCR EEN",CHSCR EEN=""
  19055   "RTN","CHM FA008",166 ,0)
  19056    .S CHSCRE EN=$O(^CHM SCRN("B",C HTITLE,CHS CREEN))
  19057   "RTN","CHM FA008",167 ,0)
  19058    .D TITLE^ CHMFA100,L INE^CHMFA1 00,CHOICE^ CHMFA100
  19059   "RTN","CHM FA008",168 ,0)
  19060    .D SCREEN ^CHMFADR2, ERRORS^CHM FA100
  19061   "RTN","CHM FA008",169 ,0)
  19062    I CHOICE= 12 D  G E1
  19063   "RTN","CHM FA008",170 ,0)
  19064    .S HCHMFP DI=CHMFPDI
  19065   "RTN","CHM FA008",171 ,0)
  19066    .D ^CHMKP DI1
  19067   "RTN","CHM FA008",172 ,0)
  19068    .S CHMFPD I=HCHMFPDI
  19069   "RTN","CHM FA008",173 ,0)
  19070    .D RNGECL R^CHSC1(1, 18,XY,CHEO L)
  19071   "RTN","CHM FA008",174 ,0)
  19072    .D SETUP^ CHMFADR1
  19073   "RTN","CHM FA008",175 ,0)
  19074    .S CHTITL E="DOCUMEN T IDENTIFI CATION SCR EEN",CHSCR EEN=""
  19075   "RTN","CHM FA008",176 ,0)
  19076    .S CHSCRE EN=$O(^CHM SCRN("B",C HTITLE,CHS CREEN))
  19077   "RTN","CHM FA008",177 ,0)
  19078    .D TITLE^ CHMFA100,L INE^CHMFA1 00,CHOICE^ CHMFA100
  19079   "RTN","CHM FA008",178 ,0)
  19080    .D SCREEN ^CHMFADR2, ERRORS^CHM FA100
  19081   "RTN","CHM FA008",179 ,0)
  19082   TEST I CHO ICE=7 D  G :$G(VALOPD I)!($G(VAL BENE)) E1
  19083   "RTN","CHM FA008",180 ,0)
  19084    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q
  19085   "RTN","CHM FA008",181 ,0)
  19086    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1) I V ALBENE Q   ;CPE005-12 2 and 123
  19087   "RTN","CHM FA008",182 ,0)
  19088    .S CHPDIP RL=$$PDITY P^CHMFAUT1 (CHMFPDI)
  19089   "RTN","CHM FA008",183 ,0)
  19090    .Q:'CHPDI PRL
  19091   "RTN","CHM FA008",184 ,0)
  19092    .S $P(^CH MIMG(CHMFP DI,0),"^", 6)=4
  19093   "RTN","CHM FA008",185 ,0)
  19094    .;S ^CHMI MG("EDI/OC R-HOLD",CH MFPDI)=""
  19095   "RTN","CHM FA008",186 ,0)
  19096    .S CHMFPD RV=""
  19097   "RTN","CHM FA008",187 ,0)
  19098    Q
  19099   "RTN","CHM FA008",188 ,0)
  19100   GETDATA S: '$D(CHMFPG NM) CHMFPG NM=0
  19101   "RTN","CHM FA008",189 ,0)
  19102    S:CHMFPGN M="" CHMFP GNM=0
  19103   "RTN","CHM FA008",190 ,0)
  19104    S CHMFPGN M=$O(^CHMI MAGE(CHMFP DI,1,CHMFP GNM))
  19105   "RTN","CHM FA008",191 ,0)
  19106    I 'CHMFPG NM S CHMFP GNM=$O(^CH MIMAGE(CHM FPDI,1,999 99),-1) Q
  19107   "RTN","CHM FA008",192 ,0)
  19108    S CHMFIMA G=0
  19109   "RTN","CHM FA008",193 ,0)
  19110    S CHMFIMA G=$O(^CHMI MAGE(CHMFP DI,1,CHMFP GNM,2,CHMF IMAG))
  19111   "RTN","CHM FA008",194 ,0)
  19112    I CHMFIMA G I $D(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,0))  D
  19113   "RTN","CHM FA008",195 ,0)
  19114    .S II=$P( ^(0),"^",4 )
  19115   "RTN","CHM FA008",196 ,0)
  19116    .I II I $ D(^CHMDIC( 741002.08, II,0)) S C HMFTYPE=$P (^(0),"^", 1)
  19117   "RTN","CHM FA008",197 ,0)
  19118    .S CHMFIM TY=II
  19119   "RTN","CHM FA008",198 ,0)
  19120    Q
  19121   "RTN","CHM FA008",199 ,0)
  19122    ;
  19123   "RTN","CHM FA008",200 ,0)
  19124   BDIMCK S C HPDITY=$$T YPE^CHMFPD I2(CHMFPDI )
  19125   "RTN","CHM FA008",201 ,0)
  19126    Q:CHPDITY =""
  19127   "RTN","CHM FA008",202 ,0)
  19128    I $E(CHPD ITY,1,1)'= 9 Q
  19129   "RTN","CHM FA008",203 ,0)
  19130    S DY=22,D X=10,$Y=DY ,$X=DX X X Y W @CHEOL
  19131   "RTN","CHM FA008",204 ,0)
  19132    S DY=22,D X=22,$Y=DY ,$X=DX X X Y W "***** This optio n is not a vailable.* ****" R X: 5
  19133   "RTN","CHM FA008",205 ,0)
  19134    S DY=22,D X=10,$Y=DY ,$X=DX X X Y W @CHEOL
  19135   "RTN","CHM FA008",206 ,0)
  19136    S CHMFBDB K=""
  19137   "RTN","CHM FA008",207 ,0)
  19138    Q
  19139   "RTN","CHM FA008",208 ,0)
  19140    ;
  19141   "RTN","CHM FA010")
  19142   0^38^B1832 88112
  19143   "RTN","CHM FA010",1,0 )
  19144   CHMFA010 ; JLR/DEN;VE NDOR/INVOI CE DATA SC REEN;Feb 0 6, 2019@10 :09:48
  19145   "RTN","CHM FA010",2,0 )
  19146    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  19147   "RTN","CHM FA010",3,0 )
  19148    ;;2;Vendo r Invoice; ;Dec 21,20 09
  19149   "RTN","CHM FA010",4,0 )
  19150    ;PT'S - 1 0513*
  19151   "RTN","CHM FA010",5,0 )
  19152    ;CPTS #10 846* - PEJ  8/15/96
  19153   "RTN","CHM FA010",6,0 )
  19154    ;TEAM TRA CK #312 RK N 12/11/20 06....SEE  LINE TAGS  CVFN1 AND  CVFN2
  19155   "RTN","CHM FA010",7,0 )
  19156    ;TT MTN00 1142 JEH 1 2/16/06 -  FIX FOR NO  VALUE IN  VTAXID
  19157   "RTN","CHM FA010",8,0 )
  19158    ;jsg;DEV0 02841-02;0 5/12/09;Au to Vendor  Selection  Process;
  19159   "RTN","CHM FA010",9,0 )
  19160    ;DEV00369 8 4/30/201 0 AEB
  19161   "RTN","CHM FA010",10, 0)
  19162    ;DEV00799 1 10/08/20 10 JAK --V ENDOR LOOK UP utilizi ng NPI
  19163   "RTN","CHM FA010",11, 0)
  19164    ;BUG00487 4 12/09/10  DRW - cha nge POP-UP  for user  action (2  places).   The first  pop-up is  associated
  19165   "RTN","CHM FA010",12, 0)
  19166    ;;with an y OCR clai ms and the  second po p-up is fo r any-non  OCR.
  19167   "RTN","CHM FA010",13, 0)
  19168    ;DEF01177 6 4/28/201 1 BMJ - In it the REC 0 var in L oad to fix ed the und efined err or in DSCR P+12
  19169   "RTN","CHM FA010",14, 0)
  19170    ;DEF01373 6 2/14/201 2 BMJ
  19171   "RTN","CHM FA010",15, 0)
  19172    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  19173   "RTN","CHM FA010",16, 0)
  19174    ;CPE001-0 02 7/27/17  & 8/3/17  WTC
  19175   "RTN","CHM FA010",17, 0)
  19176    ;CFS 02/2 0/2018 CPE 001-020, 0 21 and 022  add PL ZI P for Inpa tient, Out patient an d Dental o nly.
  19177   "RTN","CHM FA010",18, 0)
  19178   A   ;LINE  TAG ADDED  BY PAT WIL L NEED TO  TAKE OUT
  19179   "RTN","CHM FA010",19, 0)
  19180    K CHMVEN, DSPFLG,CHS UM
  19181   "RTN","CHM FA010",20, 0)
  19182    D CLEAR
  19183   "RTN","CHM FA010",21, 0)
  19184    D ^CHMFA0 06
  19185   "RTN","CHM FA010",22, 0)
  19186    I CHTYPIN T=2 D ^CHM FA030 G EN D
  19187   "RTN","CHM FA010",23, 0)
  19188    S CHPDIPR L=$$PDITYP ^CHMFAUT1( CHMFPDI)
  19189   "RTN","CHM FA010",24, 0)
  19190       ;
  19191   "RTN","CHM FA010",25, 0)
  19192   CVFN1   ;  ////////// /////////  CHECKS EXI STANCE OF  VENDOR ID  ////////// //////  12 /12/2006 T T # 312 RK N
  19193   "RTN","CHM FA010",26, 0)
  19194       ;CODE  REMARKED O UT PER CPD  (CHARLES  GUSTAFSON)  12/26/200 6 RKN
  19195   "RTN","CHM FA010",27, 0)
  19196       ;TT #  MTN001137- 01: 6875 -  OCR SELEC TING WRONG  VENDOR  1 2/26/2006  RKN
  19197   "RTN","CHM FA010",28, 0)
  19198       ;TT #  MTN001158- 01: 6943 -  The Patie nt Control  Number is  no longer  loading f or all EDI /OCR claim s  12/26/2 006 RKN
  19199   "RTN","CHM FA010",29, 0)
  19200       ;I $D( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN")) D
  19201   "RTN","CHM FA010",30, 0)
  19202       ;.I $P (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"VEN"),"^ ",1)'>"0"  D CVFN2
  19203   "RTN","CHM FA010",31, 0)
  19204       ;.Q
  19205   "RTN","CHM FA010",32, 0)
  19206       ;
  19207   "RTN","CHM FA010",33, 0)
  19208    K ASVFLG    ;jbm; CR #9223; Nee d this var ibles init ialized
  19209   "RTN","CHM FA010",34, 0)
  19210    I CHPDIPR L D  G:VFN  A4
  19211   "RTN","CHM FA010",35, 0)
  19212    .S VFN="" ,CHXTID=""
  19213   "RTN","CHM FA010",36, 0)
  19214    .I $D(MED TEST) Q    ;;BUG00487 4 DRW - th is is a fl ag that wi ll caused  the pop-up  from disp laying a s econd time  - 05/20/1 1
  19215   "RTN","CHM FA010",37, 0)
  19216    .I $D(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"VE N")) D
  19217   "RTN","CHM FA010",38, 0)
  19218    ..S VFN=$ P(^("VEN") ,"^",1)
  19219   "RTN","CHM FA010",39, 0)
  19220    ..S CHXTI DPT=$P(^(" VEN"),"^", 14)
  19221   "RTN","CHM FA010",40, 0)
  19222    ..S CHXTI D=$P(^CHMI MAGE(CHMFP DI,"P-VEN" ,CHXTIDPT, 0),"^",5)
  19223   "RTN","CHM FA010",41, 0)
  19224    .;jsg;DEV 002841;5/1 2/09;Was 1  vendor au to selecte d?  If so,  get vendo r data:
  19225   "RTN","CHM FA010",42, 0)
  19226    .I $D(^CH MIMAGE(CHM FPDI,100,0 )) S ASVFL G=1 D:$P(^ (0),U,3)=1   ;jsg;DEV 002841;5/1 2/09;
  19227   "RTN","CHM FA010",43, 0)
  19228    ..S VFN=^ CHMIMAGE(C HMFPDI,100 ,1,0),ASVF LG=VFN K D SPFLG        ;jsg;DEV 002841;5/1 2/09;
  19229   "RTN","CHM FA010",44, 0)
  19230    .I VFN=""  I $D(CHXT ID) I CHXT ID'="" D   Q
  19231   "RTN","CHM FA010",45, 0)
  19232    ..S:$L(CH XTID)>9 CH XTID=$E(CH XTID,1,9)_ "*"_$E(CHX TID,10,11)
  19233   "RTN","CHM FA010",46, 0)
  19234    ..D GETDA TA
  19235   "RTN","CHM FA010",47, 0)
  19236    ..D ^CHMF A01D
  19237   "RTN","CHM FA010",48, 0)
  19238    ..I $P(RE C1,"^",7)= 88 D    ;J PN CR 4874  ELIMENATE  OPTION FO R MEDICADE
  19239   "RTN","CHM FA010",49, 0)
  19240    ...S TX=2 5,TY=11,BX =75,BY=20, VON="",VOF F="" D BOX F^CHSC1(TX ,TY,BX,BY)
  19241   "RTN","CHM FA010",50, 0)
  19242    ...D CLRB OXI^CHSC1( TX,TY,BX,B Y,XY,VON,V OFF)
  19243   "RTN","CHM FA010",51, 0)
  19244    ...S DY=1 2,DX=26 X  XY W "** M EDICAID VE NODR NOT A LLOWED ON  THIS  **"     ;BUG004 874 DRW -  changed me ssage in P OP-UP 12/0 9/10
  19245   "RTN","CHM FA010",52, 0)
  19246    ...S DY=1 3,DX=26 X  XY W "** S CREEN PLEA SE USE OPT ION 7 TO E NTER  **"     ;BUG004 874 DRW -  changed me ssage for  clarity 12 /09/10
  19247   "RTN","CHM FA010",53, 0)
  19248    ...S DY=1 4,DX=26 X  XY W "** M EDICAID VE NDOR INFOR MATION           **"     ;BUG004 874 DRW -  this is an  additiona l line - 0 3/17/11
  19249   "RTN","CHM FA010",54, 0)
  19250    ...S MEDT EST=""                                                               ;BUG004 874 DRW/BM J - set ME DTEST trig ger to pos itvie - 05 /17/11
  19251   "RTN","CHM FA010",55, 0)
  19252    ...H 4 D  CLRBOXI^CH SC1(TX,TY, BX,BY,XY," ",VOFF),VE N,DISP,DIS P^CHMFA013  S VFN="", CHMFBASC(1 )="",CHVEN NM="" Q       ;;BUG00 4874 DRW/B JM - this  clears out  the pop-u p and will  repaints  the format  prior to  pop-up 05/ 20/11
  19253   "RTN","CHM FA010",56, 0)
  19254    ..Q
  19255   "RTN","CHM FA010",57, 0)
  19256    .I VFN=""  D  I VFN  S DSPFLG=" "
  19257   "RTN","CHM FA010",58, 0)
  19258    ..S OLDPG NM=$O(^CHM IMAGE(CHMF PDI,1,CHMF PGNM),-1)
  19259   "RTN","CHM FA010",59, 0)
  19260    ..I OLDPG NM'="" I $ D(^CHMIMAG E(CHMFPDI, 1,OLDPGNM, 2,CHMFIMAG ,"VEN")) D
  19261   "RTN","CHM FA010",60, 0)
  19262    ...S VFN= $P(^("VEN" ),"^",1)
  19263   "RTN","CHM FA010",61, 0)
  19264    ...S CHMF BASC(6)=$P (^("VEN"), "^",7)
  19265   "RTN","CHM FA010",62, 0)
  19266    ...S CHMF BASC(7)=$P (^("VEN"), "^",17)
  19267   "RTN","CHM FA010",63, 0)
  19268    ...S CHMF BASC(2)=$P (^("VEN"), "^",2)
  19269   "RTN","CHM FA010",64, 0)
  19270    ...;CPE V ENDOR STRE AMLINING U SER STORY  2 PL-ZIP 0 6/01/2017  - default  PL-ZIP for  EDI claim s GEF
  19271   "RTN","CHM FA010",65, 0)
  19272    ...S:$G(C HMFBASC(8) )="" CHMFB ASC(8)=$$Z IPDF(CHMFP DI,$G(VFN) )
  19273   "RTN","CHM FA010",66, 0)
  19274    ...S X=$P (^CHMIMAGE (CHMFPDI,1 ,OLDPGNM,2 ,CHMFIMAG, "VEN"),"^" ,1)
  19275   "RTN","CHM FA010",67, 0)
  19276    ...I 'X S  CHMFBASC( 1)="" G A0 0
  19277   "RTN","CHM FA010",68, 0)
  19278    ...I '$D( ^CHMVEN(X, 0)) S CHMF BASC(1)=""  G A00
  19279   "RTN","CHM FA010",69, 0)
  19280    ...S CHMF BASC(1)=$P (^CHMVEN(X ,0),"^",1) _"^"_X
  19281   "RTN","CHM FA010",70, 0)
  19282   A00 ...I $ D(^CHMIMAG E(CHMFPDI, 1,OLDPGNM, 2,CHMFIMAG ,"AII")) D
  19283   "RTN","CHM FA010",71, 0)
  19284    ....S CHM FBASC(3)=$ P(^("AII") ,"^",4),CH MFBASC(4)= ""
  19285   "RTN","CHM FA010",72, 0)
  19286    .I VFN D
  19287   "RTN","CHM FA010",73, 0)
  19288    ..D ^CHMF SET X CHRE SET D HEAD ^CHMFA100
  19289   "RTN","CHM FA010",74, 0)
  19290    ..S DTM=9 ,DBM=20 X  CHMAR D TI TLE K PV
  19291   "RTN","CHM FA010",75, 0)
  19292    ..F DY=4: 1:20 S DX= 1,$X=DX X  XY W @CHEO L
  19293   "RTN","CHM FA010",76, 0)
  19294    ..D VEN S  DY=4,DX=1 8,$Y=DY,$X =DX X XY W  @CHBON
  19295   "RTN","CHM FA010",77, 0)
  19296    ..D:'$D(D SPFLG) GET DATA
  19297   "RTN","CHM FA010",78, 0)
  19298    ..;D CLEA R
  19299   "RTN","CHM FA010",79, 0)
  19300    ..D DISP
  19301   "RTN","CHM FA010",80, 0)
  19302    ..D DISP^ CHMFA013
  19303   "RTN","CHM FA010",81, 0)
  19304    ..D DATA^ CHMFA013
  19305   "RTN","CHM FA010",82, 0)
  19306    ..S BLNK2 ="" S $P(B LNK2," ",3 1)=""
  19307   "RTN","CHM FA010",83, 0)
  19308    ..K DSPFL G
  19309   "RTN","CHM FA010",84, 0)
  19310   A0 D TITLE  K PV
  19311   "RTN","CHM FA010",85, 0)
  19312   A1 F DY=4: 1:20 S DX= 1,$X=DX X  XY W @CHEO L
  19313   "RTN","CHM FA010",86, 0)
  19314    D VEN S D Y=4,DX=18, $Y=DY,$X=D X X XY W @ CHBON
  19315   "RTN","CHM FA010",87, 0)
  19316    I '$D(CHM FBASC) F Q U=1:1:11 S  CHMFBASC( QU)=""  ;A EB 4/30/20 10 DEV0036 98 CHANGED  10 TO 11
  19317   "RTN","CHM FA010",88, 0)
  19318   A2 W @CHBO FF S VFN=$ P(CHMFBASC (1),"^",2)
  19319   "RTN","CHM FA010",89, 0)
  19320    D DISP,DI SP^CHMFA01 3,DATA^CHM FA013
  19321   "RTN","CHM FA010",90, 0)
  19322   A3 D ^CHMF A01D
  19323   "RTN","CHM FA010",91, 0)
  19324    ;I $D(MED TEST) K ME DTEST G A4      ;Remo ve line DE F013736 2/ 24/2012 BM J
  19325   "RTN","CHM FA010",92, 0)
  19326    I $P(REC1 ,"^",7)=88  D  G A ;J PN CR 4874  ELIMENATE  OPTION FO R MEDICADE
  19327   "RTN","CHM FA010",93, 0)
  19328    .S TX=25, TY=11,BX=7 5,BY=17,VO N="",VOFF= "" D BOXF^ CHSC1(TX,T Y,BX,BY)
  19329   "RTN","CHM FA010",94, 0)
  19330    .D CLRBOX I^CHSC1(TX ,TY,BX,BY, XY,VON,VOF F)
  19331   "RTN","CHM FA010",95, 0)
  19332    .S DY=12, DX=26 X XY  W "** MED ICAID VEND OR NOT ALL OWED ON TH IS  **"      ;BUG0048 74 DRW - c hanged mes sage conte nt 12/09/2 010
  19333   "RTN","CHM FA010",96, 0)
  19334    .S DY=13, DX=26 X XY  W "** SCR EEN PLEASE  USE OPTIO N 7 TO ENT ER  **"      ;BUG0048 74 DRW - c hanged mes sage conte nt for cla rity 12/09 /10
  19335   "RTN","CHM FA010",97, 0)
  19336    .S DY=14, DX=26 X XY  W "** MED ICAID VEND OR INFORMA TION           **"      ;BUG0048 74 DRW - a dded this  line to co mplete mes sage - 03/ 17/11
  19337   "RTN","CHM FA010",98, 0)
  19338    .;S DY=13 ,DX=26 X X Y W " "
  19339   "RTN","CHM FA010",99, 0)
  19340    .S MEDTES T=""               ;; BUG004874  DRW/BMJ -  if flag is  set to ye s or has d ata, do no t re-displ ay pop-up  05/20/11
  19341   "RTN","CHM FA010",100 ,0)
  19342    .H 4 D CL RBOXI^CHSC 1(TX,TY,BX ,BY,XY,"", VOFF),VEN, DISP,DISP^ CHMFA013 D    ;;BUG00 4874 DRW/B MJ - clear s the pop- up and rep aints the  format pri or to pop- up - 05/20 /11
  19343   "RTN","CHM FA010",101 ,0)
  19344    ..S VFN=" ",CHMFBASC (1)="",CHV ENNM=""
  19345   "RTN","CHM FA010",102 ,0)
  19346   A4 D ^CHMF A011
  19347   "RTN","CHM FA010",103 ,0)
  19348    G:$D(D4OU T) A3
  19349   "RTN","CHM FA010",104 ,0)
  19350    K:$D(CHMF PREV)!$D(C HMFKILL) C HMFBASC
  19351   "RTN","CHM FA010",105 ,0)
  19352    D:$D(CHMF NEXT) SET
  19353   "RTN","CHM FA010",106 ,0)
  19354    I '$D(CHM FPREV),'$D (CHMFKILL)  I '$G(VFN ),$G(CHMFB ASC(1))=""  W !,"           **Pl ease selec t a vendor  or create  a pseudo  vendor**                    " H  3 G A  ;SK D 6-21-07  DEV002190- 02
  19355   "RTN","CHM FA010",107 ,0)
  19356   END ;
  19357   "RTN","CHM FA010",108 ,0)
  19358    K CHMFDCV N,CHTITLE, DX,DY,HJ,I ,J,LN,PTR, QU,REC,REC 1,STR,X,DU OUT,D1OUT
  19359   "RTN","CHM FA010",109 ,0)
  19360    K D2OUT,D QOUT,DFOUT ,DTOUT,FLD ,F1,HY,HX, I,NODAT,TL ,TYP,X,X1, X2,ZPSN,ZX
  19361   "RTN","CHM FA010",110 ,0)
  19362    K YY,Y,CH CLRFG,BLNK ,REC0,ST,P ST,PFT,PCL T,FT,CHK,D IC,%DT,ZPS J,ZPSN,ZPS NM
  19363   "RTN","CHM FA010",111 ,0)
  19364    K ZPSTOT, ZX,ZY,ZPSD ES,ZPSCT,Z PSCA,ZPSA, ZPS1,ZPS,Z OUT,ZNS,ZN O,ZI,ZC
  19365   "RTN","CHM FA010",112 ,0)
  19366    K MVFN,ME DVEN,CHMVE N,CHSERV Q
  19367   "RTN","CHM FA010",113 ,0)
  19368   TITLE S CH TITLE="BAS IC INFORMA TION SCREE N",CHSCREE N=0
  19369   "RTN","CHM FA010",114 ,0)
  19370    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN)) I ' CHSCREEN G  END
  19371   "RTN","CHM FA010",115 ,0)
  19372    D TITLE^C HMFA100,CH OICE^CHMFA 100,ERRORS ^CHMFA100  Q
  19373   "RTN","CHM FA010",116 ,0)
  19374   CLEAR S DX =1,$X=DX F  DY=3:1:22  X XY W @C HEOL    ;S KD FR F DY =3:1:20, C LEARED OF  UNNEEDED L INE
  19375   "RTN","CHM FA010",117 ,0)
  19376    Q
  19377   "RTN","CHM FA010",118 ,0)
  19378   DISP S DX= 1,$X=DX F  DY=3:1:4 X  XY W @CHE OL                                ;;BUG0048 74-03 DRW  - Cleans t he top por tion of th e screen ( from row 1  to row 8)
  19379   "RTN","CHM FA010",119 ,0)
  19380    S DY=4,DX =1,$Y=DY,$ X=DX X XY  W @CHBON                                     ;;and rep aints the  screen wit h the fiel d labels -  06/23/11
  19381   "RTN","CHM FA010",120 ,0)
  19382    W !," TAX  ID: ",?39 ,"|    TOS : ",@CHBOF F,$P(CHMFB ASC(4),"^" ,2),@CHBON    ;DEV007 991 10/08/ 2010 JAK r eorganize  screen lab els
  19383   "RTN","CHM FA010",121 ,0)
  19384    W !,"     NPI: ",?39 ,"|   PAYP : ",@CHBOF F                                   ;DEV007 991 10/08/ 2010 JAK r eorganize  screen lab els
  19385   "RTN","CHM FA010",122 ,0)
  19386    W:$P(CHMF BASC(2),"^ ",1)="Y" " Yes"
  19387   "RTN","CHM FA010",123 ,0)
  19388    W:$P(CHMF BASC(2),"^ ",1)="N" " No" W @CHB ON
  19389   "RTN","CHM FA010",124 ,0)
  19390    W !,"RT N AME: ",?39 ,"|   MCCR : ",@CHBOF F                                   ;DEV007 991 10/08/ 2010 JAK r eorganize  screen lab els
  19391   "RTN","CHM FA010",125 ,0)
  19392    W:$P(CHMF BASC(3),"^ ",1)="Y" " Yes"
  19393   "RTN","CHM FA010",126 ,0)
  19394    W:$P(CHMF BASC(3),"^ ",1)="N" " No" W @CHB ON
  19395   "RTN","CHM FA010",127 ,0)
  19396    W !," RT  ZIP: ",?39 ,"|    PCN : ",@CHBOF F,$P(CHMFB ASC(7),"^" ,1),@CHBON    ;DEV007 991 10/08/ 2010 JAK r eorganize  screen lab els
  19397   "RTN","CHM FA010",128 ,0)
  19398    ;W !," PL  ZIP: ",?1 9,"PL ST:  ",?39,"|   TOB: ",@CH BOFF,$P(CH MFBASC(6), "^",1),@CH BON   ;DEV 007991 10/ 08/2010 JA K
  19399   "RTN","CHM FA010",129 ,0)
  19400    W !,?39," |    TOB:  ",@CHBOFF, $P(CHMFBAS C(6),"^",1 ),@CHBON    ;SBB 05/0 2/2017
  19401   "RTN","CHM FA010",130 ,0)
  19402    N CHSERV   ;CPE001-0 20, 021 an d 022.
  19403   "RTN","CHM FA010",131 ,0)
  19404    S CHSERV= $P(CHMFBAS C(4),"^")
  19405   "RTN","CHM FA010",132 ,0)
  19406    I CHSERV= "IPT"!(CHS ERV="OPT") !(CHSERV=" DNT") D
  19407   "RTN","CHM FA010",133 ,0)
  19408    .W !,?39, "| PL ZIP:  ",@CHBOFF ,$P(CHMFBA SC(8),"^", 1),@CHBON    ;SBB 05/ 02/2017
  19409   "RTN","CHM FA010",134 ,0)
  19410    I CHSERV= "TRV" W !, ?39,"|     POP: ",@CH BOFF,$P(CH MFBASC(11) ,"^",1) ;A EB 4/30/20 10 DEV0036 98
  19411   "RTN","CHM FA010",135 ,0)
  19412    S CHXTID= ""
  19413   "RTN","CHM FA010",136 ,0)
  19414    Q
  19415   "RTN","CHM FA010",137 ,0)
  19416   SET  ;
  19417   "RTN","CHM FA010",138 ,0)
  19418    N CHCLM ;  WTC 8/3/1 7
  19419   "RTN","CHM FA010",139 ,0)
  19420    S HVFN=$P (CHMFBASC( 1),"^",2)
  19421   "RTN","CHM FA010",140 ,0)
  19422    S X="",VF N=$P(CHMFB ASC(1),"^" ,2)
  19423   "RTN","CHM FA010",141 ,0)
  19424    I VFN D
  19425   "RTN","CHM FA010",142 ,0)
  19426    .S (VREC0 ,VREC1,VRE C2,VREC5,V REC41)=""
  19427   "RTN","CHM FA010",143 ,0)
  19428    .S:$D(^CH MVEN(VFN,0 )) VREC0=^ (0) S:$D(^ CHMVEN(VFN ,1)) VREC1 =^(1)
  19429   "RTN","CHM FA010",144 ,0)
  19430    .S:$D(^CH MVEN(VFN,2 )) VREC2=^ (2) S:$D(^ CHMVEN(VFN ,5)) VREC5 =^(1)
  19431   "RTN","CHM FA010",145 ,0)
  19432    .S JJ="A" ,JJ=$O(^CH MVEN(VFN,4 1,JJ),-1)
  19433   "RTN","CHM FA010",146 ,0)
  19434    .I JJ I $ D(^CHMVEN( VFN,41,JJ, 0)) S VREC 41=^(0)
  19435   "RTN","CHM FA010",147 ,0)
  19436    .S X1=$P( VREC0,"^", 1)_"^"_$P( VREC0,"^", 3)
  19437   "RTN","CHM FA010",148 ,0)
  19438    .S X2=$P( VREC2,"^", 1)_"^"_$P( VREC2,"^", 2)_"^"_$P( VREC2,"^", 3)_"^"_$P( VREC2,"^", 4)_"^"_$P( VREC2,"^", 5)_"^"_$P( VREC2,"^", 6)
  19439   "RTN","CHM FA010",149 ,0)
  19440    .S X3=$P( VREC1,"^", 7)_"^"_$P( VREC1,"^", 11)
  19441   "RTN","CHM FA010",150 ,0)
  19442    .S X4=$P( VREC5,"^", 5),X5=$P(V REC41,"^", 3)
  19443   "RTN","CHM FA010",151 ,0)
  19444    .S ^CHMIM AGE(CHMFPD I,"VEN-II" ,VFN)=X1_" ^"_X2_"^"_ X3_"^"_X4_ "^"_X5
  19445   "RTN","CHM FA010",152 ,0)
  19446    .S $P(^CH MIMAGE(CHM FPDI,"VEN- II",VFN)," ^",15)=$P( $G(CHMFBAS C(8)),"^", 1)
  19447   "RTN","CHM FA010",153 ,0)
  19448    . ;
  19449   "RTN","CHM FA010",154 ,0)
  19450    . ;  Add  PL ZIP to  claims alr eady assoc iated with  the PDI.   wtc 8/3/1 7
  19451   "RTN","CHM FA010",155 ,0)
  19452    . ;
  19453   "RTN","CHM FA010",156 ,0)
  19454    . S CHCLM =0 F  S CH CLM=$O(^CH MPAY("C",C HMFPDI,CHC LM)) Q:'CH CLM  S $P( ^CHMPAY(CH CLM,"VEN-I I"),"^",15 )=$P($G(CH MFBASC(8)) ,"^",1) ;
  19455   "RTN","CHM FA010",157 ,0)
  19456    S $P(X,"^ ",1)=$P(CH MFBASC(1), "^",2),$P( X,"^",7)=$ P(CHMFBASC (6),"^",1)
  19457   "RTN","CHM FA010",158 ,0)
  19458    S $P(X,"^ ",17)=$P(C HMFBASC(7) ,"^",1),$P (X,"^",3)= $P(CHMFBAS C(2),"^",1 )
  19459   "RTN","CHM FA010",159 ,0)
  19460    S CHMFSER V=$P(CHMFB ASC(4),"^" ,3)
  19461   "RTN","CHM FA010",160 ,0)
  19462    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,0)," ^",5)=CHMF SERV
  19463   "RTN","CHM FA010",161 ,0)
  19464    I $P(CHMF BASC(4),"^ ",1)="TRV"  S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,0)," ^",11)=$P( CHMFBASC(1 1),"^",1)   ;AEB 4/20 /2010 DEV0 03698 STOR E ZIP CODE  TO BE USE D IN BENEF IT CALC
  19465   "RTN","CHM FA010",162 ,0)
  19466    S ^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"VEN")= X
  19467   "RTN","CHM FA010",163 ,0)
  19468    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN "),"^",9)= CHMFSERV
  19469   "RTN","CHM FA010",164 ,0)
  19470    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN "),"^",15) =CHMFPGNM
  19471   "RTN","CHM FA010",165 ,0)
  19472    S X=""
  19473   "RTN","CHM FA010",166 ,0)
  19474    S $P(X,"^ ",1)=$P(CH MFBASC(3), "^",1)
  19475   "RTN","CHM FA010",167 ,0)
  19476    S $P(X,"^ ",4)=$P(CH MFBASC(3), "^",1)
  19477   "RTN","CHM FA010",168 ,0)
  19478    S $P(X,"^ ",2)=$E(OH IIND,1)
  19479   "RTN","CHM FA010",169 ,0)
  19480    S ^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"AII")= X
  19481   "RTN","CHM FA010",170 ,0)
  19482    I VFN'=""  I '$D(CHM VEN) D LOA D
  19483   "RTN","CHM FA010",171 ,0)
  19484    D DSCRP
  19485   "RTN","CHM FA010",172 ,0)
  19486    I $D(MVFN ) I MVFN'= "" S $P(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"V EN"),"^",1 6)=MVFN
  19487   "RTN","CHM FA010",173 ,0)
  19488    I $D(MEDA MT) I MEDA MT'="" S $ P(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"VEN")," ^",18)=MED AMT
  19489   "RTN","CHM FA010",174 ,0)
  19490    Q
  19491   "RTN","CHM FA010",175 ,0)
  19492   DSCRP S ST R="" Q:'$D (VFN)  S S TR="0*0*0* 0*0*0*0*0* 0*0*0*0"
  19493   "RTN","CHM FA010",176 ,0)
  19494    S REC="", REC1="",RE C2="",REC5 ="",REC41= "",PTR=""
  19495   "RTN","CHM FA010",177 ,0)
  19496    S PTR=CHM FPDI_"*"_C HMFPGNM_"* "_CHMFIMAG
  19497   "RTN","CHM FA010",178 ,0)
  19498    I VFN=""  D  Q
  19499   "RTN","CHM FA010",179 ,0)
  19500    .S CT=0
  19501   "RTN","CHM FA010",180 ,0)
  19502    .F I=2:1: 19 S CT=CT +1,PV(CT)= "" S:$D(CH MVEN(I)) P V(CT)=CHMV EN(I)
  19503   "RTN","CHM FA010",181 ,0)
  19504    .S STR=""  D PSEUDO
  19505   "RTN","CHM FA010",182 ,0)
  19506    .S $P(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"VE N"),"^",14 )=J Q
  19507   "RTN","CHM FA010",183 ,0)
  19508    S:$D(^CHM VEN(VFN,0) ) REC=^(0)  S:$D(^CHM VEN(VFN,1) ) REC1=^(1 )
  19509   "RTN","CHM FA010",184 ,0)
  19510    S:$D(^CHM VEN(VFN,2) ) REC2=^(2 ) S:$D(^CH MVEN(VFN,5 )) REC5=^( 5)
  19511   "RTN","CHM FA010",185 ,0)
  19512    S JJ="A", JJ=$O(^CHM VEN(VFN,41 ,JJ),-1)
  19513   "RTN","CHM FA010",186 ,0)
  19514    I JJ I $D (^CHMVEN(V FN,41,JJ,0 )) S REC41 =^(0)
  19515   "RTN","CHM FA010",187 ,0)
  19516    I $P(REC0 ,"^",1)'=C HMVEN(2) S  $P(STR,"* ",1)=1,PV( 1)=CHMVEN( 2)
  19517   "RTN","CHM FA010",188 ,0)
  19518    I $P(REC, "^",3)'=CH MVEN(3) S  $P(STR,"*" ,2)=1,PV(2 )=CHMVEN(3 )
  19519   "RTN","CHM FA010",189 ,0)
  19520    I $P(REC1 ,"^",1)'=C HMVEN(14)  S $P(STR," *",3)=1,PV (3)=CHMVEN (14)
  19521   "RTN","CHM FA010",190 ,0)
  19522    I $P(REC1 ,"^",2)'=C HMVEN(15)  S $P(STR," *",4)=1,PV (4)=CHMVEN (15)
  19523   "RTN","CHM FA010",191 ,0)
  19524    I $P(REC1 ,"^",3)'=C HMVEN(16)  S $P(STR," *",5)=1,PV (5)=CHMVEN (16)
  19525   "RTN","CHM FA010",192 ,0)
  19526    I $P(REC1 ,"^",4)'=C HMVEN(17)  S $P(STR," *",6)=1,PV (6)=CHMVEN (17)
  19527   "RTN","CHM FA010",193 ,0)
  19528    I $P(REC1 ,"^",5)'=C HMVEN(18)  S $P(STR," *",7)=1,PV (7)=CHMVEN (18)
  19529   "RTN","CHM FA010",194 ,0)
  19530    ;I $P(REC 41,"^",3)' =CHMVEN(9)  S $P(STR, "*",8)=1,P V(8)=CHMVE N(9)
  19531   "RTN","CHM FA010",195 ,0)
  19532    ;I $P(REC 2,"^",6)'= CHMVEN(10)  S $P(STR, "*",9)=1,P V(9)=CHMVE N(10)
  19533   "RTN","CHM FA010",196 ,0)
  19534    ;I $P(REC 1,"^",7)'= CHMVEN(11)  S $P(STR, "*",10)=1, PV(10)=CHM VEN(11)
  19535   "RTN","CHM FA010",197 ,0)
  19536    ;I $P(REC 1,"^",11)' =CHMVEN(12 ) S $P(STR ,"*",11)=1 ,PV(11)=CH MVEN(12)
  19537   "RTN","CHM FA010",198 ,0)
  19538    I $P(REC2 ,"^",2)'=C HMVEN(5) S  $P(STR,"* ",12)=1,PV (12)=CHMVE N(5)
  19539   "RTN","CHM FA010",199 ,0)
  19540    S CHPDI=C HMFPDI
  19541   "RTN","CHM FA010",200 ,0)
  19542    S CNT="", CNT=$O(^CH MIMAGE(CHP DI,"VEN-DD ",HVFN,CNT ),-1) S:'C NT CNT=0
  19543   "RTN","CHM FA010",201 ,0)
  19544    S CNT=CNT +1
  19545   "RTN","CHM FA010",202 ,0)
  19546    D NOW^%DT C
  19547   "RTN","CHM FA010",203 ,0)
  19548    F X=1:1:1 2 S:$D(PV( X)) $P(^CH MIMAGE(CHP DI,"VEN-DD ",HVFN,CNT ),"^",X)=$ P(PV(X),"^ ",1)
  19549   "RTN","CHM FA010",204 ,0)
  19550    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",13)=$ P(REC,"^", 1)
  19551   "RTN","CHM FA010",205 ,0)
  19552    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",14)=$ P(REC,"^", 3)
  19553   "RTN","CHM FA010",206 ,0)
  19554    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",15)=$ P(REC2,"^" ,1)
  19555   "RTN","CHM FA010",207 ,0)
  19556    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",16)=$ P(REC2,"^" ,2)
  19557   "RTN","CHM FA010",208 ,0)
  19558    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",17)=$ P(REC2,"^" ,3)
  19559   "RTN","CHM FA010",209 ,0)
  19560    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",18)=$ P(REC2,"^" ,4)
  19561   "RTN","CHM FA010",210 ,0)
  19562    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",19)=$ P(REC2,"^" ,5)
  19563   "RTN","CHM FA010",211 ,0)
  19564    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",20)=$ P(REC41,"^ ",3)
  19565   "RTN","CHM FA010",212 ,0)
  19566    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",21)=$ P(REC2,"^" ,6)
  19567   "RTN","CHM FA010",213 ,0)
  19568    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",22)=$ P(REC1,"^" ,7)
  19569   "RTN","CHM FA010",214 ,0)
  19570    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",23)=$ P(REC1,"^" ,11)
  19571   "RTN","CHM FA010",215 ,0)
  19572    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",24)=$ P(REC5,"^" ,5)
  19573   "RTN","CHM FA010",216 ,0)
  19574    S:$D(PV)  $P(^CHMIMA GE(CHPDI," VEN-DD",HV FN,CNT),"^ ",26)=DUZ
  19575   "RTN","CHM FA010",217 ,0)
  19576    S:$D(PV)  $P(^CHMIMA GE(CHPDI," VEN-DD",HV FN,CNT),"^ ",27)=%
  19577   "RTN","CHM FA010",218 ,0)
  19578    S CHMFDCV N="Y" F I= 1:1:12 S:' $D(PV(I))  PV(I)=""
  19579   "RTN","CHM FA010",219 ,0)
  19580    S:STR'[1  STR="" D P 1
  19581   "RTN","CHM FA010",220 ,0)
  19582    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN "),"^",2)= "Y"
  19583   "RTN","CHM FA010",221 ,0)
  19584    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN "),"^",14) =J Q
  19585   "RTN","CHM FA010",222 ,0)
  19586   PSEUDO ;
  19587   "RTN","CHM FA010",223 ,0)
  19588   P1 S J=0,H J=0 F I=1: 1 S J=$O(^ CHMIMAGE(C HMFPDI,"P- VEN",J)) Q :'J  S HJ= J
  19589   "RTN","CHM FA010",224 ,0)
  19590    S J=HJ+1
  19591   "RTN","CHM FA010",225 ,0)
  19592    F I=3:1:7  I $D(CHMV EN(I+11))  I CHMVEN(I +11)'="" S  PV(I)=CHM VEN(I+11)
  19593   "RTN","CHM FA010",226 ,0)
  19594    S ^CHMIMA GE(CHMFPDI ,"P-VEN",J ,0)=VFN_"^ "_PTR_"^"_ STR_"^"_PV (1)_"^"_PV (2)_"^^"_P V(3)_"^"_P V(4)_"^"_P V(5)_"^"_P V(6)_"^"_P V(7)_"^"_P V(8)_"^"_P V(9)_"^"_P V(10)_"^"_ PV(11)_"^" _PV(12) Q
  19595   "RTN","CHM FA010",227 ,0)
  19596   LOAD S REC ="",REC1=" ",REC2="", REC41="" I  '$D(REC0)  S REC0=""  ;DEF01177 6 added S  REC0="" to  this line  BMJ
  19597   "RTN","CHM FA010",228 ,0)
  19598    S:$D(^CHM VEN(VFN,0) ) REC=^(0)  S:$D(^CHM VEN(VFN,1) ) REC1=^(1 )
  19599   "RTN","CHM FA010",229 ,0)
  19600    S:$D(^CHM VEN(VFN,2) ) REC2=^(2 ) S:$D(^CH MVEN(VFN,5 )) REC5=^( 5)
  19601   "RTN","CHM FA010",230 ,0)
  19602    ;S:$D(^CH MVEN(VFN,0 )) REC0=^( 0)       ; ;DEV4874 D RW - testi ng this po rtion for  undefined  REC0 - 03/ 17/11
  19603   "RTN","CHM FA010",231 ,0)
  19604    S JJ="A", JJ=$O(^CHM VEN(VFN,41 ,JJ),-1)
  19605   "RTN","CHM FA010",232 ,0)
  19606    I JJ S:$D (^CHMVEN(V FN,41,JJ,0 )) REC41=^ (0)
  19607   "RTN","CHM FA010",233 ,0)
  19608    S CHMVEN( 2)=$P(REC, "^",1),CHM VEN(3)=$P( REC,"^",3) ,CHMVEN(1) =$P(REC2," ^",8)
  19609   "RTN","CHM FA010",234 ,0)
  19610    S CHMVEN( 4)=$P(REC2 ,"^",1),CH MVEN(5)=$P (REC2,"^", 2)
  19611   "RTN","CHM FA010",235 ,0)
  19612    S CHMVEN( 6)=$P(REC2 ,"^",3),CH MVEN(7)=$P (REC2,"^", 4)
  19613   "RTN","CHM FA010",236 ,0)
  19614    S CHMVEN( 8)=$P(REC2 ,"^",5),CH MVEN(9)=$P (REC41,"^" ,3)
  19615   "RTN","CHM FA010",237 ,0)
  19616    S CHMVEN( 10)=$P(REC 2,"^",6)
  19617   "RTN","CHM FA010",238 ,0)
  19618    S CHMVEN( 11)=$P(REC 1,"^",7)
  19619   "RTN","CHM FA010",239 ,0)
  19620    S CHMVEN( 12)=$P(REC 1,"^",11), CHMVEN(13) =$P(REC5," ^",5)
  19621   "RTN","CHM FA010",240 ,0)
  19622    F I=1:1:5  I $D(REC1 ) S CHMVEN (I+13)=$P( REC1,"^",I )
  19623   "RTN","CHM FA010",241 ,0)
  19624    Q
  19625   "RTN","CHM FA010",242 ,0)
  19626   VEN S DY=1 2,DX=1,$Y= DY,$X=DX X  XY F LN=1 :1:80 W "- "
  19627   "RTN","CHM FA010",243 ,0)
  19628    ;S DY=11, DX=10,$Y=D Y,$X=DX X  XY
  19629   "RTN","CHM FA010",244 ,0)
  19630    S DY=12,D X=37,$Y=DY ,$X=DX X X Y     ;SBB  05/02/201 7
  19631   "RTN","CHM FA010",245 ,0)
  19632    ;W @CHBON ,"| Remit- to Informa tion        || Physic al Locatio n Informat ion |",@CH BOFF Q
  19633   "RTN","CHM FA010",246 ,0)
  19634    ;W @CHBON ,"| Physic al Locatio n Info      || Remit- to Informa tion           |",@CH BOFF Q  ;A EB 7/2/200 7
  19635   "RTN","CHM FA010",247 ,0)
  19636    W @CHBON, "  || Bill ing/Remit- to Informa tion |",@C HBOFF Q  ; SBB 5/2/20 17
  19637   "RTN","CHM FA010",248 ,0)
  19638       ;
  19639   "RTN","CHM FA010",249 ,0)
  19640   CVFN2   ;   ///////// //////////  SETS UP V ENDOR ID I N GLOBAL / ////////// /////  12/ 12/2006 TT  # 312 RKN
  19641   "RTN","CHM FA010",250 ,0)
  19642       ;CODE  REMARKED O UT PER CPD  (CHARLES  GUSTAFSON)  12/26/200 6 RKN
  19643   "RTN","CHM FA010",251 ,0)
  19644       ;TT #  MTN001137- 01: 6875 -  OCR SELEC TING WRONG  VENDOR  1 2/26/2006  RKN
  19645   "RTN","CHM FA010",252 ,0)
  19646       ;TT #  MTN001158- 01: 6943 -  The Patie nt Control  Number is  no longer  loading f or all EDI /OCR claim s  12/26/2 006 RKN
  19647   "RTN","CHM FA010",253 ,0)
  19648       ;I '$D (^CHMIMAGE (CHMFPDI," P-VEN",1,0 )) Q
  19649   "RTN","CHM FA010",254 ,0)
  19650       ;I $D( ^CHMIMAGE( CHMFPDI,"P -VEN",1,0) ) S VTAXID =$P(^CHMIM AGE(CHMFPD I,"P-VEN", 1,0),"^",5 )
  19651   "RTN","CHM FA010",255 ,0)
  19652       ;Q:VTA XID=""!(VT AXID=" ")    ;JEH 12/ 16/06
  19653   "RTN","CHM FA010",256 ,0)
  19654       ;S VFN =999999999 ,VFN=$O(^C HMVEN("D", VTAXID,VFN ),-1)
  19655   "RTN","CHM FA010",257 ,0)
  19656       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,1)=VFN
  19657   "RTN","CHM FA010",258 ,0)
  19658       ;S $P( ^CHMIMAGE( CHMFPDI,"P -VEN",1,0) ,"^",1)=VF N
  19659   "RTN","CHM FA010",259 ,0)
  19660       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,14)=CHMFP GNM
  19661   "RTN","CHM FA010",260 ,0)
  19662       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,2)="Y"
  19663   "RTN","CHM FA010",261 ,0)
  19664       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,3)="Y"
  19665   "RTN","CHM FA010",262 ,0)
  19666       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,9)="2"
  19667   "RTN","CHM FA010",263 ,0)
  19668       ;S ^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"AI I")="^^^"
  19669   "RTN","CHM FA010",264 ,0)
  19670       ;Q
  19671   "RTN","CHM FA010",265 ,0)
  19672       ;
  19673   "RTN","CHM FA010",266 ,0)
  19674   GETDATA F  QU=1:1:11  S CHMFBASC (QU)=""  ; AEB 4/30/2 010 DEV003 698  CHANG ED 10 TO 1 1
  19675   "RTN","CHM FA010",267 ,0)
  19676    I $D(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,0))  D
  19677   "RTN","CHM FA010",268 ,0)
  19678    .S X=$P(^ (0),"^",5)
  19679   "RTN","CHM FA010",269 ,0)
  19680    .S CHMFBA SC(4)=""
  19681   "RTN","CHM FA010",270 ,0)
  19682    .S CHMFBA SC(11)=$P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, 0),"^",11)   ;AEB 4/3 0/2010 DEV 003698  AD DED TO SET  PLACE HOL DER FOR PO P  LEAVE C OMMENTED O FF
  19683   "RTN","CHM FA010",271 ,0)
  19684    .I X I $D (^CHMDIC(7 41002.05,X ,0)) D
  19685   "RTN","CHM FA010",272 ,0)
  19686    ..S CHMFB ASC(4)=$P( ^(0),"^",2 )_"^"_$P(^ (0),"^",1) _"^"_X_"^" _"B"
  19687   "RTN","CHM FA010",273 ,0)
  19688    I $D(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"AII ")) D
  19689   "RTN","CHM FA010",274 ,0)
  19690    .S CHMFBA SC(3)=$P(^ ("AII"),"^ ",4)
  19691   "RTN","CHM FA010",275 ,0)
  19692    I $D(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN ")) D
  19693   "RTN","CHM FA010",276 ,0)
  19694    .S CHMFBA SC(2)=$P(^ ("VEN"),"^ ",2)
  19695   "RTN","CHM FA010",277 ,0)
  19696    .S CHMFBA SC(6)=$P(^ ("VEN"),"^ ",7)
  19697   "RTN","CHM FA010",278 ,0)
  19698    .S CHMFBA SC(7)=$P(^ ("VEN"),"^ ",17)
  19699   "RTN","CHM FA010",279 ,0)
  19700    .S X=$P(^ ("VEN"),"^ ",1)
  19701   "RTN","CHM FA010",280 ,0)
  19702    .I $D(ASV FLG) S X=A SVFLG                         ;j sg;DEV0028 41;5/12/09 ;
  19703   "RTN","CHM FA010",281 ,0)
  19704    .I 'X S C HMFBASC(1) ="" Q
  19705   "RTN","CHM FA010",282 ,0)
  19706    .I '$D(^C HMVEN(X,0) ) S CHMFBA SC(1)="" Q
  19707   "RTN","CHM FA010",283 ,0)
  19708    .S CHMFBA SC(1)=$P(^ CHMVEN(X,0 ),"^",1)_" ^"_X
  19709   "RTN","CHM FA010",284 ,0)
  19710     .;CPE VE NDOR STREA MLINING US ER STORY 2  PL-ZIP 06 /01/2017 -  default P L-ZIP for  EDI claims  GEF
  19711   "RTN","CHM FA010",285 ,0)
  19712    .S:$G(CHM FBASC(8))= "" CHMFBAS C(8)=$P($G (^CHMIMAGE (CHMFPDI," VEN-II",X) ),"^",15)
  19713   "RTN","CHM FA010",286 ,0)
  19714    S:$G(CHMF BASC(8))=" " CHMFBASC (8)=$$ZIPD F(CHMFPDI, $G(X))
  19715   "RTN","CHM FA010",287 ,0)
  19716    ;
  19717   "RTN","CHM FA010",288 ,0)
  19718    ;  WTC -  Shorten 9  digit zip  codes to 5  digits -  7/27/17
  19719   "RTN","CHM FA010",289 ,0)
  19720    ;
  19721   "RTN","CHM FA010",290 ,0)
  19722    I $L(CHMF BASC(8))>5  S CHMFBAS C(8)=$E(CH MFBASC(8), 1,5) ;
  19723   "RTN","CHM FA010",291 ,0)
  19724    Q
  19725   "RTN","CHM FA010",292 ,0)
  19726   ZIPDF(CHMF PDI,VFN) ;  CPE VENDO R STREAMLI NING USER  STORY 2 PL -ZIP 06/01 /2017 - de fault PL-Z IP for EDI  claims GE F
  19727   "RTN","CHM FA010",293 ,0)
  19728    N CHMFXCL ,CHMFZPD,C HMFPTC,CHM FBE,CHSERV
  19729   "RTN","CHM FA010",294 ,0)
  19730    S CHSERV= $P(CHMFBAS C(4),"^")   ;CPE001-0 20, 021 an d 022
  19731   "RTN","CHM FA010",295 ,0)
  19732    I CHSERV' ="IPT",CHS ERV'="OPT" ,CHSERV'=" DNT" Q ""
  19733   "RTN","CHM FA010",296 ,0)
  19734    S CHMFZPD =""
  19735   "RTN","CHM FA010",297 ,0)
  19736    S:VFN'=""  CHMFZPD=$ P($G(^CHMI MAGE(CHMFP DI,"VEN-II ",VFN)),"^ ",15)
  19737   "RTN","CHM FA010",298 ,0)
  19738    Q:CHMFZPD '="" CHMFZ PD
  19739   "RTN","CHM FA010",299 ,0)
  19740    ; only de fault for  EDI claims
  19741   "RTN","CHM FA010",300 ,0)
  19742    Q:$$TYPE^ CHMFPDI2(C HMFPDI)<90
  19743   "RTN","CHM FA010",301 ,0)
  19744    S CHMFPTC ="" F  S C HMFPTC=$O( ^CHMXCLE(" PDI",CHMFP DI,CHMFPTC )) Q:CHMFP TC=""  D
  19745   "RTN","CHM FA010",302 ,0)
  19746    .S CHMFXC L="" F  S  CHMFXCL=$O (^CHMXCLE( "PDI",CHMF PDI,CHMFPT C,CHMFXCL) ) Q:CHMFXC L=""  D
  19747   "RTN","CHM FA010",303 ,0)
  19748    ..S CHMFB E=$O(^CHMX CLE("PDI", CHMFPDI,CH MFPTC,CHMF XCL,"")) Q :CHMFBE=""
  19749   "RTN","CHM FA010",304 ,0)
  19750    ..Q:CHMFB E=""
  19751   "RTN","CHM FA010",305 ,0)
  19752    ..S CHMFZ PD=$E($P($ G(^CHMXCLE (+$P(CHMFB E,"*",4),6 0)),"^",9) ,1,5) Q:CH MFZPD'=""
  19753   "RTN","CHM FA010",306 ,0)
  19754    ..S CHMFZ PD=$E($P($ G(^CHMXCLB (+$P(CHMFB E,"*",2),0 )),"^",8), 1,5)
  19755   "RTN","CHM FA010",307 ,0)
  19756    Q CHMFZPD
  19757   "RTN","CHM FA011")
  19758   0^39^B1096 41227
  19759   "RTN","CHM FA011",1,0 )
  19760   CHMFA011 ; JLR/DEN;BA SIC DATA E NTER/EDIT  SCREEN;Feb  06, 2019@ 10:10:21;  07 Jul 201 7 6:10 AM
  19761   "RTN","CHM FA011",2,0 )
  19762    ;;1.0;CHA MPVA SYSTE M;**1,8,14 **;JULY 4,  1990;Buil d 9
  19763   "RTN","CHM FA011",3,0 )
  19764    ;CPTS #10 846 - PEJ  8/15/96
  19765   "RTN","CHM FA011",4,0 )
  19766    ;CPTS #11 089 - JLR  10/17/96
  19767   "RTN","CHM FA011",5,0 )
  19768    ;CPTS #12 505 BY DTP  (3-SEP-97 )
  19769   "RTN","CHM FA011",6,0 )
  19770    ;DEV00369 8 4/20/201 0 AEB
  19771   "RTN","CHM FA011",7,0 )
  19772    ;JEH 2/1/ 11 DEV0078 20 - SLLA  - ADDED TO TAL LOGIC  FOR PRI OH I P/R, ADD L OHI PD
  19773   "RTN","CHM FA011",8,0 )
  19774    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  19775   "RTN","CHM FA011",9,0 )
  19776    ;CFS 02/2 2/2018 CPE 001-020, 0 21 and 022  - Fix cur sor moveme nts based  on Type of  Services.
  19777   "RTN","CHM FA011",10, 0)
  19778    ;CFS 09/1 9/2018 Def ect 826304  Clean up  screen aft er user ch ooses the  Type Of Se rvice from  selection  list.
  19779   "RTN","CHM FA011",11, 0)
  19780    ;
  19781   "RTN","CHM FA011",12, 0)
  19782   A2  K F1,D D1OUT,CH1O UT S QU=4, DY=5,DX=50 ,FLD=10,$Y =DY,$X=DX  X XY W BLN K2 X XY
  19783   "RTN","CHM FA011",13, 0)
  19784    W $E($P(C HMFBASC(QU ),"^",2),1 ,20) S DX= 50,$X=DX X  XY D CSBR S^CHSC2
  19785   "RTN","CHM FA011",14, 0)
  19786    I $D(DQOU T) D  G:ZP SN="?" A2  G A21
  19787   "RTN","CHM FA011",15, 0)
  19788    .D CLEAR  S Y="?" D  ^CHMFA016
  19789   "RTN","CHM FA011",16, 0)
  19790    .S DY=5,D X=50,$Y=DY ,$X=DX X X Y W BLNK2  X XY W $E( $P(CHMFBAS C(QU),"^", 2),1,20)
  19791   "RTN","CHM FA011",17, 0)
  19792    .D CLEAR  D REPNT
  19793   "RTN","CHM FA011",18, 0)
  19794    I $D(DUOU T) D  G A2
  19795   "RTN","CHM FA011",19, 0)
  19796    .S DY=5,D X=50,$Y=DY ,$X=DX X X Y W BLNK2
  19797   "RTN","CHM FA011",20, 0)
  19798    .S DX=50, $X=DX X XY  W:CHMFBAS C(QU)'=""  $E($P(CHMF BASC(QU)," ^",2),1,20 )
  19799   "RTN","CHM FA011",21, 0)
  19800    .D:$D(CHC LRFG) CLEA R,REPNT
  19801   "RTN","CHM FA011",22, 0)
  19802    I $D(DDOU T)!$D(DFOU T) G SELCT
  19803   "RTN","CHM FA011",23, 0)
  19804    G:$D(D1OU T) A2
  19805   "RTN","CHM FA011",24, 0)
  19806    Q:$D(D4OU T)
  19807   "RTN","CHM FA011",25, 0)
  19808    I Y="" D: $D(CHCLRFG ) REPNT G  A3
  19809   "RTN","CHM FA011",26, 0)
  19810    I Y=" ",$ D(^DISV(DU Z,"CHTYP") ) S TYP=^( "CHTYP") D  GET1 G A2 1
  19811   "RTN","CHM FA011",27, 0)
  19812    I Y="@" S  CHMFBASC( QU)="" G A 2
  19813   "RTN","CHM FA011",28, 0)
  19814    D ^CHMFA0 16
  19815   "RTN","CHM FA011",29, 0)
  19816   A21 I ZPSN =-1 D  G A 2
  19817   "RTN","CHM FA011",30, 0)
  19818    .S DY=5,D X=50,$Y=DY ,$X=DX X X Y W BLNK2  X XY W *7, " ??"
  19819   "RTN","CHM FA011",31, 0)
  19820    .R X:2 X  XY W BLNK2
  19821   "RTN","CHM FA011",32, 0)
  19822    .X XY W:C HMFBASC(QU )'="" $E($ P(CHMFBASC (QU),"^",2 ),1,20)
  19823   "RTN","CHM FA011",33, 0)
  19824    .D:$D(CHC LRFG) CLEA R,REPNT
  19825   "RTN","CHM FA011",34, 0)
  19826   A22 G:CHMF BASC(QU)=" " A23
  19827   "RTN","CHM FA011",35, 0)
  19828    G:$P(CHMF BASC(QU)," ^",3)=$P(Z PSN,"^",3)  A23
  19829   "RTN","CHM FA011",36, 0)
  19830    S CHPDIPR L=$$PDITYP ^CHMFAUT1( CHMFPDI) G :CHPDIPRL= 0 A23
  19831   "RTN","CHM FA011",37, 0)
  19832    I ($P(CHM FBASC(QU), "^",3)=1)! ($P(ZPSN," ^",3)=1) S  CTFLG=""  D ^CHMFA01 K K CTFLG   G:$D(CH1O UT) A2 G A 23   ;JEH  2/1/11 DEV 007820 - S LLA - ADDE D CHG TOS  FLG
  19833   "RTN","CHM FA011",38, 0)
  19834    I ($P(CHM FBASC(QU), "^",3)=3)! ($P(ZPSN," ^",3)=3) D  TOSMSG G  A2
  19835   "RTN","CHM FA011",39, 0)
  19836    S CTFLG=" "    ;JEH  2/1/11 DEV 007820 - S LLA - ADDE D CHG TOS  FLG
  19837   "RTN","CHM FA011",40, 0)
  19838    D ^CHMFA0 1J ; DO TH E TOS CHAN GE ON OCR/ EDI (CHPDI PRL=1) SUB MISSIONS
  19839   "RTN","CHM FA011",41, 0)
  19840    K CTFLG    ;JEH 2/1/ 11 DEV0078 20 - SLLA  - ADDED CH G TOS FLG
  19841   "RTN","CHM FA011",42, 0)
  19842   A23 S DY=5 ,DX=50,$Y= DY,$X=DX X  XY W BLNK 2
  19843   "RTN","CHM FA011",43, 0)
  19844    X XY W BL NK2 X XY W  $E($P(ZPS N,"^",2),1 ,20)
  19845   "RTN","CHM FA011",44, 0)
  19846    I $P(ZPSN ,"^",3)'=$ P(CHMFBASC (QU),"^",3 ) S REFLG= ""
  19847   "RTN","CHM FA011",45, 0)
  19848    S CHMFBAS C(QU)=ZPSN
  19849   "RTN","CHM FA011",46, 0)
  19850    S ^DISV(D UZ,"CHTYP" )=$P(ZPSN, "^",3) I $ D(REFLG) S  DX=40,DY= 10 X XY W  @CHEOL D C LEAR,REPNT  K REFLG   ;AEB 4/20/ 2010 DEV00 3698
  19851   "RTN","CHM FA011",47, 0)
  19852    D:$D(CHCL RFG) REPNT
  19853   "RTN","CHM FA011",48, 0)
  19854   A3 D ASSIG N K F1,DD1 OUT
  19855   "RTN","CHM FA011",49, 0)
  19856    S QU=2,DY =6,DX=50,F LD=21,$Y=D Y,$X=DX X  XY
  19857   "RTN","CHM FA011",50, 0)
  19858    W:CHMFBAS C(QU)="" B LNK2
  19859   "RTN","CHM FA011",51, 0)
  19860    W:CHMFBAS C(QU)="N"  "No"
  19861   "RTN","CHM FA011",52, 0)
  19862    W:CHMFBAS C(QU)="Y"  "Yes"
  19863   "RTN","CHM FA011",53, 0)
  19864    G:$D(CHAS SOV) A4
  19865   "RTN","CHM FA011",54, 0)
  19866    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19867   "RTN","CHM FA011",55, 0)
  19868    I $D(DQOU T) D  G A3
  19869   "RTN","CHM FA011",56, 0)
  19870    .D QUES X  XY W BLNK 2 X XY
  19871   "RTN","CHM FA011",57, 0)
  19872    .W:CHMFBA SC(QU)="N"  "No"
  19873   "RTN","CHM FA011",58, 0)
  19874    .W:CHMFBA SC(QU)="Y"  "Yes"
  19875   "RTN","CHM FA011",59, 0)
  19876    I $D(DUOU T) D  G A2
  19877   "RTN","CHM FA011",60, 0)
  19878    .S DY=6,D X=50,$Y=DY ,$X=DX X X Y W BLNK2  S DX=50,$X =DX X XY
  19879   "RTN","CHM FA011",61, 0)
  19880    .W:CHMFBA SC(QU)="N"  "No"
  19881   "RTN","CHM FA011",62, 0)
  19882    .W:CHMFBA SC(QU)="Y"  "Yes"
  19883   "RTN","CHM FA011",63, 0)
  19884    .D:$D(CHC LRFG) CLEA R,REPNT
  19885   "RTN","CHM FA011",64, 0)
  19886    S:$D(D1OU T) DD1OUT= 1
  19887   "RTN","CHM FA011",65, 0)
  19888    Q:$D(D4OU T)
  19889   "RTN","CHM FA011",66, 0)
  19890    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A3 G SELCT
  19891   "RTN","CHM FA011",67, 0)
  19892    I Y="@" S  CHMFBASC( QU)="" G A 3
  19893   "RTN","CHM FA011",68, 0)
  19894    I Y'="" D   G:$D(F1)  A3
  19895   "RTN","CHM FA011",69, 0)
  19896    .D ^CHMFA 012
  19897   "RTN","CHM FA011",70, 0)
  19898    .I $D(F1)  S DX=50,D Y=6,$Y=DY, $X=DX X XY  W BLNK2 Q
  19899   "RTN","CHM FA011",71, 0)
  19900    .D:$D(CHC LRFG) CLEA R,REPNT
  19901   "RTN","CHM FA011",72, 0)
  19902    .S DX=50, DY=6,$Y=DY ,$X=DX X X Y W BLNK2  X XY
  19903   "RTN","CHM FA011",73, 0)
  19904    .W:Y="N"  "No" W:Y=" Y" "Yes" S  CHMFBASC( QU)=Y
  19905   "RTN","CHM FA011",74, 0)
  19906    D:$D(CHCL RFG) REPNT
  19907   "RTN","CHM FA011",75, 0)
  19908    G:$D(DD1O UT) A2
  19909   "RTN","CHM FA011",76, 0)
  19910   A4 K F1,DD 1OUT
  19911   "RTN","CHM FA011",77, 0)
  19912    S QU=3,DY =7,DX=50,F LD=21,$Y=D Y,$X=DX X  XY
  19913   "RTN","CHM FA011",78, 0)
  19914    W:CHMFBAS C(QU)="" B LNK2
  19915   "RTN","CHM FA011",79, 0)
  19916    W:CHMFBAS C(QU)="N"  "No"
  19917   "RTN","CHM FA011",80, 0)
  19918    W:CHMFBAS C(QU)="Y"  "Yes"
  19919   "RTN","CHM FA011",81, 0)
  19920    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19921   "RTN","CHM FA011",82, 0)
  19922    I $D(DQOU T) D  G A4
  19923   "RTN","CHM FA011",83, 0)
  19924    .D QUES X  XY W BLNK 2 X XY
  19925   "RTN","CHM FA011",84, 0)
  19926    .W:CHMFBA SC(QU)="N"  "No"
  19927   "RTN","CHM FA011",85, 0)
  19928    .W:CHMFBA SC(QU)="Y"  "Yes"
  19929   "RTN","CHM FA011",86, 0)
  19930    I $D(DUOU T) D  G A3
  19931   "RTN","CHM FA011",87, 0)
  19932    .S DY=7,D X=50,$Y=DY ,$X=DX X X Y W BLNK2  S DX=50,$X =DX X XY
  19933   "RTN","CHM FA011",88, 0)
  19934    .W:CHMFBA SC(QU)="N"  "No"
  19935   "RTN","CHM FA011",89, 0)
  19936    .W:CHMFBA SC(QU)="Y"  "Yes"
  19937   "RTN","CHM FA011",90, 0)
  19938    .D:$D(CHC LRFG) CLEA R,REPNT
  19939   "RTN","CHM FA011",91, 0)
  19940    S:$D(D1OU T) DD1OUT= 1
  19941   "RTN","CHM FA011",92, 0)
  19942    Q:$D(D4OU T)
  19943   "RTN","CHM FA011",93, 0)
  19944    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A4 G SELCT
  19945   "RTN","CHM FA011",94, 0)
  19946    I Y="@" S  CHMFBASC( QU)="" G A 4
  19947   "RTN","CHM FA011",95, 0)
  19948    I Y'="" D   G:$D(F1)  A4
  19949   "RTN","CHM FA011",96, 0)
  19950    .D ^CHMFA 012
  19951   "RTN","CHM FA011",97, 0)
  19952    .I $D(F1)  S DX=50,D Y=7,$Y=DY, $X=DX X XY  W BLNK2 Q
  19953   "RTN","CHM FA011",98, 0)
  19954    .D:$D(CHC LRFG) CLEA R,REPNT
  19955   "RTN","CHM FA011",99, 0)
  19956    .S DX=50, DY=7,$Y=DY ,$X=DX X X Y W BLNK2  X XY
  19957   "RTN","CHM FA011",100 ,0)
  19958    .W:Y="N"  "No" W:Y=" Y" "Yes"
  19959   "RTN","CHM FA011",101 ,0)
  19960    .S CHMFBA SC(QU)=Y
  19961   "RTN","CHM FA011",102 ,0)
  19962    D:$D(CHCL RFG) REPNT
  19963   "RTN","CHM FA011",103 ,0)
  19964    G:$D(DD1O UT) A3
  19965   "RTN","CHM FA011",104 ,0)
  19966   A6 K F1,DD 1OUT,FL
  19967   "RTN","CHM FA011",105 ,0)
  19968    S QU=7,DY =8,DX=50,F LD=30,$Y=D Y,$X=DX X  XY
  19969   "RTN","CHM FA011",106 ,0)
  19970    W BLNK2 X  XY W CHMF BASC(QU)
  19971   "RTN","CHM FA011",107 ,0)
  19972    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19973   "RTN","CHM FA011",108 ,0)
  19974    I $D(DQOU T) D  G A6
  19975   "RTN","CHM FA011",109 ,0)
  19976    .D QUES X  XY
  19977   "RTN","CHM FA011",110 ,0)
  19978    .W BLNK2  X XY W CHM FBASC(QU)
  19979   "RTN","CHM FA011",111 ,0)
  19980    I $D(DUOU T) D  G A4
  19981   "RTN","CHM FA011",112 ,0)
  19982    .S DY=8,D X=50,$Y=DY ,$X=DX X X Y W BLNK2
  19983   "RTN","CHM FA011",113 ,0)
  19984    .S DX=50, $X=DX X XY  W CHMFBAS C(QU)
  19985   "RTN","CHM FA011",114 ,0)
  19986    .D:$D(CHC LRFG) CLEA R,REPNT
  19987   "RTN","CHM FA011",115 ,0)
  19988    S:$D(D1OU T) DD1OUT= 1
  19989   "RTN","CHM FA011",116 ,0)
  19990    Q:$D(D4OU T)
  19991   "RTN","CHM FA011",117 ,0)
  19992    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A6 G SELCT
  19993   "RTN","CHM FA011",118 ,0)
  19994    I Y="@" S  CHMFBASC( QU)="" G A 6
  19995   "RTN","CHM FA011",119 ,0)
  19996    I Y'="" D   G:$D(F1)  A6
  19997   "RTN","CHM FA011",120 ,0)
  19998    .D ^CHMFA 012
  19999   "RTN","CHM FA011",121 ,0)
  20000    .I $D(F1)  S DX=50,D Y=8,$Y=DY, $X=DX X XY  W BLNK2 Q
  20001   "RTN","CHM FA011",122 ,0)
  20002    .D:$D(CHC LRFG) CLEA R,REPNT
  20003   "RTN","CHM FA011",123 ,0)
  20004    .S DX=50, DY=8,$Y=DY ,$X=DX X X Y W BLNK2  X XY W Y
  20005   "RTN","CHM FA011",124 ,0)
  20006    .S CHMFBA SC(QU)=Y
  20007   "RTN","CHM FA011",125 ,0)
  20008    D:$D(CHCL RFG) REPNT  G:$D(DD1O UT) A4
  20009   "RTN","CHM FA011",126 ,0)
  20010   A7 K F1,FL ,DD1OUT
  20011   "RTN","CHM FA011",127 ,0)
  20012    S QU=6,DY =9,DX=50,F LD=30,$Y=D Y,$X=DX X  XY
  20013   "RTN","CHM FA011",128 ,0)
  20014    W BLNK2 X  XY W CHMF BASC(QU)
  20015   "RTN","CHM FA011",129 ,0)
  20016    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  20017   "RTN","CHM FA011",130 ,0)
  20018    I $D(DQOU T) D  G A7
  20019   "RTN","CHM FA011",131 ,0)
  20020    .D QUES X  XY
  20021   "RTN","CHM FA011",132 ,0)
  20022    .W BLNK2  X XY W CHM FBASC(QU)
  20023   "RTN","CHM FA011",133 ,0)
  20024    I $D(DUOU T) D  G A6
  20025   "RTN","CHM FA011",134 ,0)
  20026    .S DY=9,D X=50,$Y=DY ,$X=DX X X Y W BLNK2
  20027   "RTN","CHM FA011",135 ,0)
  20028    .S DX=50, $X=DX X XY  W CHMFBAS C(QU)
  20029   "RTN","CHM FA011",136 ,0)
  20030    .D:$D(CHC LRFG) CLEA R,REPNT
  20031   "RTN","CHM FA011",137 ,0)
  20032    S:$D(D1OU T) DD1OUT= 1
  20033   "RTN","CHM FA011",138 ,0)
  20034    Q:$D(D4OU T)
  20035   "RTN","CHM FA011",139 ,0)
  20036    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A7 G SELCT
  20037   "RTN","CHM FA011",140 ,0)
  20038    I Y="@" S  CHMFBASC( QU)="" G A 7
  20039   "RTN","CHM FA011",141 ,0)
  20040    I Y'="" D   G:$D(F1)  A7
  20041   "RTN","CHM FA011",142 ,0)
  20042    .D ^CHMFA 012
  20043   "RTN","CHM FA011",143 ,0)
  20044    .I $D(F1)  S DX=50,D Y=9,$Y=DY, $X=DX X XY  W BLNK2 Q
  20045   "RTN","CHM FA011",144 ,0)
  20046    .D:$D(CHC LRFG) CLEA R,REPNT
  20047   "RTN","CHM FA011",145 ,0)
  20048    .S DX=50, DY=9,$Y=DY ,$X=DX X X Y W BLNK2  X XY W Y
  20049   "RTN","CHM FA011",146 ,0)
  20050    .S CHMFBA SC(QU)=Y
  20051   "RTN","CHM FA011",147 ,0)
  20052    D:$D(CHCL RFG) REPNT  G:$D(DD1O UT) A6
  20053   "RTN","CHM FA011",148 ,0)
  20054   A71 ;CPE V ENDOR STRE AMLINING U SER STORY  2 PL-ZIP 0 5/24/2017  GEF
  20055   "RTN","CHM FA011",149 ,0)
  20056    N CHSERV   ;CPE001-0 20, 021 an d 022
  20057   "RTN","CHM FA011",150 ,0)
  20058    S CHSERV= $P(CHMFBAS C(4),"^")
  20059   "RTN","CHM FA011",151 ,0)
  20060    I CHSERV= "TRV" G A8
  20061   "RTN","CHM FA011",152 ,0)
  20062    I CHSERV' ="IPT",CHS ERV'="OPT" ,CHSERV'=" DNT" G A2
  20063   "RTN","CHM FA011",153 ,0)
  20064    K F1,FL,D D1OUT
  20065   "RTN","CHM FA011",154 ,0)
  20066    S QU=8,DY =10,DX=50, FLD=9,$Y=D Y,$X=DX X  XY
  20067   "RTN","CHM FA011",155 ,0)
  20068    W BLNK2 X  XY W CHMF BASC(QU)
  20069   "RTN","CHM FA011",156 ,0)
  20070    N FL S FL =5
  20071   "RTN","CHM FA011",157 ,0)
  20072    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  20073   "RTN","CHM FA011",158 ,0)
  20074    I $D(DQOU T) D  G A7 1
  20075   "RTN","CHM FA011",159 ,0)
  20076    .D QUES X  XY
  20077   "RTN","CHM FA011",160 ,0)
  20078    .W BLNK2  X XY W CHM FBASC(QU)
  20079   "RTN","CHM FA011",161 ,0)
  20080    I $D(DUOU T) D  G A7 1
  20081   "RTN","CHM FA011",162 ,0)
  20082    .S DY=10, DX=50,$Y=D Y,$X=DX X  XY W BLNK2
  20083   "RTN","CHM FA011",163 ,0)
  20084    .S DX=50, $X=DX X XY  W CHMFBAS C(QU)
  20085   "RTN","CHM FA011",164 ,0)
  20086    .D:$D(CHC LRFG) CLEA R,REPNT
  20087   "RTN","CHM FA011",165 ,0)
  20088    S:$D(D1OU T) DD1OUT= 1
  20089   "RTN","CHM FA011",166 ,0)
  20090    Q:$D(D4OU T)
  20091   "RTN","CHM FA011",167 ,0)
  20092    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A71 G SELC T
  20093   "RTN","CHM FA011",168 ,0)
  20094    I Y="@" S  CHMFBASC( QU)="" G A 71
  20095   "RTN","CHM FA011",169 ,0)
  20096    I Y'="" D   G:$D(F1)  A71
  20097   "RTN","CHM FA011",170 ,0)
  20098    .D ^CHMFA 012
  20099   "RTN","CHM FA011",171 ,0)
  20100    .I $D(F1)  S DX=50,D Y=10,$Y=DY ,$X=DX X X Y W BLNK2  Q
  20101   "RTN","CHM FA011",172 ,0)
  20102    .D:$D(CHC LRFG) CLEA R,REPNT
  20103   "RTN","CHM FA011",173 ,0)
  20104    .S DX=50, DY=10,$Y=D Y,$X=DX X  XY W BLNK2  X XY W Y
  20105   "RTN","CHM FA011",174 ,0)
  20106    .S CHMFBA SC(8)=Y
  20107   "RTN","CHM FA011",175 ,0)
  20108    D:$D(CHCL RFG) REPNT  G:$D(DD1O UT) A7
  20109   "RTN","CHM FA011",176 ,0)
  20110   A8 I $P(CH MFBASC(4), "^",1)'="T RV" G A2
  20111   "RTN","CHM FA011",177 ,0)
  20112    K F1,FL,D D1OUT  ;AE B 4/30/201 0 DEV00369 8 ADDED AL L OF A8 ST ART
  20113   "RTN","CHM FA011",178 ,0)
  20114    S QU=11,D Y=10,DX=50 ,FLD=9,$Y= DY,$X=DX X  XY  ;CPE0 01-020, 02 1 and 022
  20115   "RTN","CHM FA011",179 ,0)
  20116    W BLNK2 X  XY W CHMF BASC(11)
  20117   "RTN","CHM FA011",180 ,0)
  20118    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  20119   "RTN","CHM FA011",181 ,0)
  20120    I $D(DQOU T) D  G A8
  20121   "RTN","CHM FA011",182 ,0)
  20122    .D QUES X  XY
  20123   "RTN","CHM FA011",183 ,0)
  20124    .W BLNK2  X XY W CHM FBASC(QU)
  20125   "RTN","CHM FA011",184 ,0)
  20126    I $D(DUOU T) D  G A7 1
  20127   "RTN","CHM FA011",185 ,0)
  20128    .S DY=10, DX=50,$Y=D Y,$X=DX X  XY W BLNK2
  20129   "RTN","CHM FA011",186 ,0)
  20130    .S DX=50, $X=DX X XY  W CHMFBAS C(QU)
  20131   "RTN","CHM FA011",187 ,0)
  20132    .D:$D(CHC LRFG) CLEA R,REPNT
  20133   "RTN","CHM FA011",188 ,0)
  20134    S:$D(D1OU T) DD1OUT= 1
  20135   "RTN","CHM FA011",189 ,0)
  20136    Q:$D(D4OU T)
  20137   "RTN","CHM FA011",190 ,0)
  20138    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A8 G SELCT
  20139   "RTN","CHM FA011",191 ,0)
  20140    I Y="@" S  CHMFBASC( QU)="" G A 8
  20141   "RTN","CHM FA011",192 ,0)
  20142    I Y'="" D   G:$D(F1)  A8
  20143   "RTN","CHM FA011",193 ,0)
  20144    .D ^CHMFA 012
  20145   "RTN","CHM FA011",194 ,0)
  20146    .I $D(F1)  S DX=50,D Y=10,$Y=DY ,$X=DX X X Y W BLNK2  Q
  20147   "RTN","CHM FA011",195 ,0)
  20148    .D:$D(CHC LRFG) CLEA R,REPNT
  20149   "RTN","CHM FA011",196 ,0)
  20150    .S DX=50, DY=10,$Y=D Y,$X=DX X  XY W BLNK2  X XY W Y
  20151   "RTN","CHM FA011",197 ,0)
  20152    .S CHMFBA SC(QU)=Y
  20153   "RTN","CHM FA011",198 ,0)
  20154    D:$D(CHCL RFG) REPNT  G:$D(DD1O UT) A71
  20155   "RTN","CHM FA011",199 ,0)
  20156    ;AEB 4/30 /2010 DEV0 03698 ADDE D ALL OF A 8 END
  20157   "RTN","CHM FA011",200 ,0)
  20158    G A2
  20159   "RTN","CHM FA011",201 ,0)
  20160   END Q
  20161   "RTN","CHM FA011",202 ,0)
  20162   ERASE S DY =5,DX=50,$ Y=DY,$X=DX  X XY W BL NK2
  20163   "RTN","CHM FA011",203 ,0)
  20164    F DY=6:1: 9 F DX=50, $X=DX X XY  W BLNK2
  20165   "RTN","CHM FA011",204 ,0)
  20166    F II=2:1: 9 S CHMFBA SC(II)=""
  20167   "RTN","CHM FA011",205 ,0)
  20168    Q
  20169   "RTN","CHM FA011",206 ,0)
  20170   TOSMSG S D Y=5,DX=50, $Y=DY,$X=D X X XY W " TOS chng O PT ONLY on  EDI/OCR"
  20171   "RTN","CHM FA011",207 ,0)
  20172    R X:4 X X Y W BLNK2
  20173   "RTN","CHM FA011",208 ,0)
  20174    X XY W:CH MFBASC(QU) '="" $E($P (CHMFBASC( QU),"^",2) ,1,20)
  20175   "RTN","CHM FA011",209 ,0)
  20176    D:$D(CHCL RFG) CLEAR ,REPNT
  20177   "RTN","CHM FA011",210 ,0)
  20178    Q
  20179   "RTN","CHM FA011",211 ,0)
  20180   REPNT D CL EAR^CHMFA0 11,DISP^CH MFA010,DIS P^CHMFA013 ,DATA^CHMF A013 K CHC LRFG Q
  20181   "RTN","CHM FA011",212 ,0)
  20182   GET1 S ZPS N="" Q:'$D (^CHMDIC(7 41002.05,T YP,0))  S  X=^CHMDIC( 741002.05, TYP,0)
  20183   "RTN","CHM FA011",213 ,0)
  20184    S ZPSN=$P (X,"^",2)_ "^"_$P(X," ^",1)_"^"_ TYP_"^"_"B " Q
  20185   "RTN","CHM FA011",214 ,0)
  20186   QUES S HY= DY,HX=DX D  CLEAR S D Y=12,DX=1, $Y=DY,$X=D X X XY G @ QU
  20187   "RTN","CHM FA011",215 ,0)
  20188   2 W !?14," Enter <Y>e s to pay p rovider or  <N>o to p ay benefic iary." G E XIT
  20189   "RTN","CHM FA011",216 ,0)
  20190    G EXIT
  20191   "RTN","CHM FA011",217 ,0)
  20192   3 W !?12," Enter <Y>e s for MCCR  review or  <N>o for  MCCR not n ecessary."
  20193   "RTN","CHM FA011",218 ,0)
  20194    G EXIT
  20195   "RTN","CHM FA011",219 ,0)
  20196   6 W !?25," Enter Type  of Bill,  3 characte rs, 110-99 9"
  20197   "RTN","CHM FA011",220 ,0)
  20198    G EXIT
  20199   "RTN","CHM FA011",221 ,0)
  20200   7 W !!?19, "Enter Pat ient Contr ol Number,  1 to 30 c haracters. " G EXIT
  20201   "RTN","CHM FA011",222 ,0)
  20202   8 W !,?20, "Enter the  Physical  Location z ip code" G  EXIT
  20203   "RTN","CHM FA011",223 ,0)
  20204   11 W !,?20 ,"Enter th e point of  pickup zi p code" G  EXIT  ;AEB  4/30/2010  DEV003698
  20205   "RTN","CHM FA011",224 ,0)
  20206   EXIT S DY= HY,DX=HX,$ Y=DY,$X=DX  Q
  20207   "RTN","CHM FA011",225 ,0)
  20208   SELCT K CH MFKILL,CHM FNEXT,CHMF PREV,Y,CHM FPSUD,CHMF MEDV
  20209   "RTN","CHM FA011",226 ,0)
  20210    D PRMPT^C HMFA100,AS K^CHMFA100
  20211   "RTN","CHM FA011",227 ,0)
  20212    G:Y=1 A2
  20213   "RTN","CHM FA011",228 ,0)
  20214    I Y=2 K N ODAT D  G: $D(NODAT)  A2 D PAGE  G:$D(VNPGF G) SELCT S  CHMFNEXT= 1 Q
  20215   "RTN","CHM FA011",229 ,0)
  20216    .I '$D(CH MFBASC) D  NODAT S NO DAT=1 Q
  20217   "RTN","CHM FA011",230 ,0)
  20218    .F I=2,4  S:CHMFBASC (I)="" NOD AT=1
  20219   "RTN","CHM FA011",231 ,0)
  20220    .;CPE VEN DOR STREAM LINING USE R STORY 2  PL-ZIP 05/ 24/2017 -  make requi red field  for Dental , IP & OP  ; gef
  20221   "RTN","CHM FA011",232 ,0)
  20222    .I $P(CHM FBASC(4)," ^",3)<3!($ P(CHMFBASC (4),"^",3) =5) S:CHMF BASC(8)=""  NODAT=1
  20223   "RTN","CHM FA011",233 ,0)
  20224    .D:$D(NOD AT) NODAT  Q
  20225   "RTN","CHM FA011",234 ,0)
  20226    I Y=3 S C HMFPREV=1  Q
  20227   "RTN","CHM FA011",235 ,0)
  20228    I Y=4 S C HMFKILL=1  Q
  20229   "RTN","CHM FA011",236 ,0)
  20230    I Y=5 D ^ CHMFA014 G  A2
  20231   "RTN","CHM FA011",237 ,0)
  20232    I Y=6 S V FN="" D CL EAR D ^CHM FA015 G A2
  20233   "RTN","CHM FA011",238 ,0)
  20234    I Y=7 D ^ CHMFA019 Q :$D(CHMFPR EV)!$D(CHM FKILL)  S  DY=1,DX=1, $Y=DY,$X=D X D CLEAR  D DISP^CHM FA010,DISP ^CHMFA013, DATA^CHMFA 013 G SELC T
  20235   "RTN","CHM FA011",239 ,0)
  20236   NODAT D CL EAR S DY=1 4,DX=11,$Y =DY,$X=DX  X XY
  20237   "RTN","CHM FA011",240 ,0)
  20238    ;CPE VEND OR STREAML INING USER  STORY 2 P L-ZIP 05/2 4/2017 - m ake requir ed field f or Dental,  IP & OP ;  GEF
  20239   "RTN","CHM FA011",241 ,0)
  20240    I $P(CHMF BASC(4),"^ ",3)<3!($P (CHMFBASC( 4),"^",3)= 5) I CHMFB ASC(8)=""  W "Vendor,  Type of S ervice, PL -ZIP, and  Assignment  must be e ntered." Q
  20241   "RTN","CHM FA011",242 ,0)
  20242    W "Vendor , Type of  Service, a nd Assignm ent must b e entered. "
  20243   "RTN","CHM FA011",243 ,0)
  20244    Q
  20245   "RTN","CHM FA011",244 ,0)
  20246   PAGE K VNP GFG Q:'$D( CHMFBASC(1 ))  Q:$P(C HMFBASC(1) ,"^",1)=""
  20247   "RTN","CHM FA011",245 ,0)
  20248    S VNPG=$P (CHMFBASC( 1),"^",1)  Q:$D(^CHMI MAGE(CHMFP DI,"VNPG", VNPG))
  20249   "RTN","CHM FA011",246 ,0)
  20250    I $D(VFN)  I VFN Q:$ D(^CHMIMAG E(CHMFPDI, "VNPG",VFN ))
  20251   "RTN","CHM FA011",247 ,0)
  20252    D CLEAR S  DY=12,DX= 20,$Y=DY,$ X=DX X XY  S VNPGFG=1
  20253   "RTN","CHM FA011",248 ,0)
  20254   PG1 ;W !!, ?11,"Enter  the page  that vendo r informat ion can be  found on:  "
  20255   "RTN","CHM FA011",249 ,0)
  20256    ;D CSBRS^ CHSC2 G:$D (DUOUT) PG 2 G:$D(DFO UT) PG2 G: $D(DQOUT)  PG1
  20257   "RTN","CHM FA011",250 ,0)
  20258    ;
  20259   "RTN","CHM FA011",251 ,0)
  20260    ;G:'Y PG1
  20261   "RTN","CHM FA011",252 ,0)
  20262    S Y=""
  20263   "RTN","CHM FA011",253 ,0)
  20264    I CHMFNMP G'="UNK" G :Y>CHMFNMP G PG1
  20265   "RTN","CHM FA011",254 ,0)
  20266    I $D(VFN)  I VFN S ^ CHMIMAGE(C HMFPDI,"VN PG",VFN)=Y  K VNPGFG  G PG2
  20267   "RTN","CHM FA011",255 ,0)
  20268    S ^CHMIMA GE(CHMFPDI ,"VNPG",VN PG)=Y K VN PGFG
  20269   "RTN","CHM FA011",256 ,0)
  20270   PG2 Q
  20271   "RTN","CHM FA011",257 ,0)
  20272   ASSIGN K C HASSOV Q:' $D(CHMFBAS C(4))  Q:C HMFBASC(4) =""
  20273   "RTN","CHM FA011",258 ,0)
  20274    I VFN I $ D(^CHMVEN( VFN,5)) I  $P(^(5),"^ ",1)'="" S :$P(^(5)," ^",1)=0 CH MFBASC(2)= "N" S:$P(^ (5),"^",1) =1 CHMFBAS C(2)="Y" S  CHASSOV=1  Q
  20275   "RTN","CHM FA011",259 ,0)
  20276    I $P(CHMF BASC(4),"^ ",3)=1 D A SSINP Q
  20277   "RTN","CHM FA011",260 ,0)
  20278    I $P(CHMF BASC(4),"^ ",3)=3 D A SSPHR Q
  20279   "RTN","CHM FA011",261 ,0)
  20280    I VFN I $ D(^CHMVEN( VFN,1)) I  $P(^CHMVEN (VFN,1),"^ ",16)=1 S  CHMFBASC(2 )="Y",CHAS SOV=1
  20281   "RTN","CHM FA011",262 ,0)
  20282    Q
  20283   "RTN","CHM FA011",263 ,0)
  20284   ASSINP I V FN I $D(^C HMVEN(VFN, 1)) I $P(^ CHMVEN(VFN ,1),"^",16 )=1 S CHMF BASC(2)="Y ",CHASSOV= 1 Q
  20285   "RTN","CHM FA011",264 ,0)
  20286    S CHMFBAS C(2)="Y" Q
  20287   "RTN","CHM FA011",265 ,0)
  20288   ASSPHR I V FN I $D(^C HMVEN(VFN, 1)) I $P(^ CHMVEN(VFN ,1),"^",16 )=1 S CHMF BASC(2)="Y ",CHASSOV= 1 Q
  20289   "RTN","CHM FA011",266 ,0)
  20290    S CHMFBAS C(2)="Y" Q
  20291   "RTN","CHM FA011",267 ,0)
  20292    ;CFS DEFE CT 826304  change F D Y=12:1:20  to F DY=11 :1:20 to c lean up sc reen.
  20293   "RTN","CHM FA011",268 ,0)
  20294   CLEAR S ZY =DY,ZX=DX  F DY=11:1: 21 S DX=1, $X=DX X XY  W @CHEOL    ;SKD FRO M F DY=12: 1:20
  20295   "RTN","CHM FA011",269 ,0)
  20296    S DY=ZY,D X=ZX,$Y=DY ,$X=DX X X Y S CHCLRF G=1 Q
  20297   "RTN","CHM FA011",270 ,0)
  20298   SBRS D CSB RS^CHSC2 Q
  20299   "RTN","CHM FA011",271 ,0)
  20300    S Y="" S: '$D(FLD) F LD=30 S:FL D="" FLD=3 0 U $I X ^ %ZOSF("EOF F") K TL
  20301   "RTN","CHM FA011",272 ,0)
  20302    F I=1:1:F LD S:I=31  TL=1 R *X: $S($D(DTIM E):DTIME,1 :60) Q:(X= 13)!(X=9)! (X=27)  S: X'=127 Y=Y _$C(X) D:X =127  S:I= 0 Y="" W $ C(X)
  20303   "RTN","CHM FA011",273 ,0)
  20304    .S:I=1 I= 0 Q:I=0  S :I'=1 I=I- 2,Y=$E(Y,1 ,I) W *8,* 27,"[1X" Q
  20305   "RTN","CHM FA011",274 ,0)
  20306   SBRS1 K DF OUT,DUOUT, DQOUT,DDOU T,D1OUT,D2 OUT,D3OUT, D4OUT,DTOU T,DPOUT,DN OUT
  20307   "RTN","CHM FA011",275 ,0)
  20308    I X=27 F  I=1:1:2 R  *X D:I=2
  20309   "RTN","CHM FA011",276 ,0)
  20310    .S:X=65 D 1OUT="" S: X=66 D2OUT ="" S:X=67  D3OUT=""  S:X=68 D4O UT=""
  20311   "RTN","CHM FA011",277 ,0)
  20312    .I (X=54)  R *X S:X= 126 DNOUT= ""
  20313   "RTN","CHM FA011",278 ,0)
  20314    .I (X=53)  R *X S:X= 126 DPOUT= ""
  20315   "RTN","CHM FA011",279 ,0)
  20316    S:X=9 DDO UT="" S:X= 9 DTOUT=""  I Y="^^"  S (DFOUT,Y )=""
  20317   "RTN","CHM FA011",280 ,0)
  20318    S:Y="^" ( DUOUT,Y)=" " S:Y?1"?" .E!(Y["^")  (DQOUT,Y) =""
  20319   "RTN","CHM FA011",281 ,0)
  20320    U $I X ^% ZOSF("EON" ) Q
  20321   "RTN","CHM FA012")
  20322   0^40^B5938 662
  20323   "RTN","CHM FA012",1,0 )
  20324   CHMFA012 ; JLR/DEN;BA SIC INFO D ATA CHECK; Feb 06, 20 19@10:11:3 8
  20325   "RTN","CHM FA012",2,0 )
  20326    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  20327   "RTN","CHM FA012",3,0 )
  20328    ;DEV00369 8 4/20/201 0 AEB
  20329   "RTN","CHM FA012",4,0 )
  20330    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  20331   "RTN","CHM FA012",5,0 )
  20332    K F1 S ZY =DY,ZX=DX  D @QU G EN D
  20333   "RTN","CHM FA012",6,0 )
  20334   2 S Y=$E(Y ,1) S:Y="n " Y="N" S: Y="y" Y="Y "
  20335   "RTN","CHM FA012",7,0 )
  20336    I "NYny"' [Y D CLEAR  S DY=13,D X=14,$Y=DY ,$X=DX X X Y W "Enter  <Y>es to  pay provid er or <N>o  to pay be neficiary. " S F1=1,C HCLRFG=1 Q
  20337   "RTN","CHM FA012",8,0 )
  20338    Q
  20339   "RTN","CHM FA012",9,0 )
  20340   3 S Y=$E(Y ,1) S:Y="n " Y="N" S: Y="y" Y="Y "
  20341   "RTN","CHM FA012",10, 0)
  20342    I "NYny"' [Y D CLEAR  S DY=13,D X=12,$Y=DY ,$X=DX X X Y W "Enter  <Y>es for  MCCR revi ew or <N>o  for MCCR  not necess ary." S F1 =1,CHCLRFG =1 Q
  20343   "RTN","CHM FA012",11, 0)
  20344    Q
  20345   "RTN","CHM FA012",12, 0)
  20346   6 I ($E(Y, 1)=0)!($E( Y,2)=0)!(Y <110)!(Y>9 99) D CLEA R S DY=13, DX=25,$Y=D Y,$X=DX X  XY W "Ente r Type of  Bill, 3 ch aracters,  110-999" S  F1=1,CHCL RFG=1 Q
  20347   "RTN","CHM FA012",13, 0)
  20348    Q
  20349   "RTN","CHM FA012",14, 0)
  20350   7 I $L(Y)> 30 D CLEAR  S DY=13,D X=18,$Y=DY ,$X=DX X X Y W "Enter  Patient C ontrol Num ber, 1 to  30 charact ers." S F1 =1,CHCLRFG =1 Q
  20351   "RTN","CHM FA012",15, 0)
  20352    Q
  20353   "RTN","CHM FA012",16, 0)
  20354   8 ; verify  zip code  entry agai nst file 7 41002.4 -  allow user  to enter  if not in  file - CPE 001-002 PL -ZIP 05/24 /2017 GEF
  20355   "RTN","CHM FA012",17, 0)
  20356    I Y'?5N D  CLEAR S D Y=13,DX=12 ,$Y=DY,$X= DX X XY W  "ZIP MUST  BE A LENGT H OF 5 NUM BERS"  S F 1=1,CHCLRF G=1 Q
  20357   "RTN","CHM FA012",18, 0)
  20358    Q:$D(^CHM DIC(741002 .4,"B",Y))
  20359   "RTN","CHM FA012",19, 0)
  20360    D CLEAR S  DY=13,DX= 1,$Y=DY,$X =DX X XY
  20361   "RTN","CHM FA012",20, 0)
  20362    W "     P L-ZIP DOES  NOT EXIST  IN THE CH AMPVA CMAC  ZIP CODES  FILE.  Yo u may:"
  20363   "RTN","CHM FA012",21, 0)
  20364    W !,"      (T)ry aga in with a  new PL-ZIP  - or - (C )ontinue w ith this o ne:"
  20365   "RTN","CHM FA012",22, 0)
  20366    W !,"                        (T )ry again  or (C)onti nue: C// "
  20367   "RTN","CHM FA012",23, 0)
  20368    R ANS:25
  20369   "RTN","CHM FA012",24, 0)
  20370    I ANS="T"  S F1=1,CH CLRFG=1
  20371   "RTN","CHM FA012",25, 0)
  20372    S:ANS'="T " CHMFBASC (8)=Y
  20373   "RTN","CHM FA012",26, 0)
  20374    D REPNT^C HMFA011
  20375   "RTN","CHM FA012",27, 0)
  20376    Q
  20377   "RTN","CHM FA012",28, 0)
  20378   11 I $L(Y) '=5 I $L(Y )'=9 D CLE AR S DY=13 ,DX=12,$Y= DY,$X=DX X  XY W "ZIP  MUST BE A  LENGTH OF  5 OR 9"   S F1=1,CHC LRFG=1 Q   ;AEB 4/30/ 2010 DEV00 3698
  20379   "RTN","CHM FA012",29, 0)
  20380   END S DY=Z Y,DX=ZX,$Y =DY,$X=DX  X XY Q
  20381   "RTN","CHM FA012",30, 0)
  20382   CLEAR F DY =12:1:20 S  DX=1,$X=D X X XY W @ CHEOL
  20383   "RTN","CHM FA012",31, 0)
  20384    Q
  20385   "RTN","CHM FA013")
  20386   0^41^B3186 7973
  20387   "RTN","CHM FA013",1,0 )
  20388   CHMFA013 ; JLR/DEN;VE NDOR INFOR MATION DIS PLAY;Feb 0 6, 2019@10 :12:12
  20389   "RTN","CHM FA013",2,0 )
  20390    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  20391   "RTN","CHM FA013",3,0 )
  20392    ;PT'S - 1 0462
  20393   "RTN","CHM FA013",4,0 )
  20394    ;CPTS #10 846 - PEJ  8/15/96
  20395   "RTN","CHM FA013",5,0 )
  20396    ;CPTS #11 089 - JLR  10/17/96
  20397   "RTN","CHM FA013",6,0 )
  20398    ;; vendor  informati on display  on bottom  half of b asic infor mation scr een (CHMFA 010)
  20399   "RTN","CHM FA013",7,0 )
  20400    ;DEV00799 1 10/08/20 10 JAK -VE NDOR LOOKU P utilizin g NPI
  20401   "RTN","CHM FA013",8,0 )
  20402    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  20403   "RTN","CHM FA013",9,0 )
  20404    ;CFS CPE0 01-018 Add  Billing/  to display  title.
  20405   "RTN","CHM FA013",10, 0)
  20406    ;CFS CPE0 01-019 Dis play Billi ng Address . If there  is no Bil ling Addre ss then di splay Remi t to Addre ss.
  20407   "RTN","CHM FA013",11, 0)
  20408   DISP S DTM =13,DBM=21  X CHMAR S  DY=13,DX= 4,$Y=DY,$X =DX X XY W  @CHBON    ;SKD
  20409   "RTN","CHM FA013",12, 0)
  20410    ;SBB 05/0 2/2017
  20411   "RTN","CHM FA013",13, 0)
  20412    ;W "Vendo r: ",!,?1, "Tax ID #:  "
  20413   "RTN","CHM FA013",14, 0)
  20414    ;W !,"Add ress 1: ", !,"Address  2: "
  20415   "RTN","CHM FA013",15, 0)
  20416    ;W !,?5," City: ",!, ?4,"State:  ",!,?1,"Z ip Code: "
  20417   "RTN","CHM FA013",16, 0)
  20418    ;W !,"A/V =",?9,"FAC  TYPE=",?5 5,"DRG=",? 64,"CMAC=" ,?72,"EDI= "
  20419   "RTN","CHM FA013",17, 0)
  20420    D VEN  ;H M 07/24/20 17 added c ode to dis play Remit -to Inform ation text  line
  20421   "RTN","CHM FA013",18, 0)
  20422    W !!,"A/V =",!,"FAC  TYPE=",!," DRG=",!,"C MAC=",!,"E DI="
  20423   "RTN","CHM FA013",19, 0)
  20424    W @CHBOFF  Q
  20425   "RTN","CHM FA013",20, 0)
  20426   DATA I '$D (VFN) S RE C1="",REC0 ="",REC2=" ",REC14="" ,REC41="", REC5="",RE C3="",REC8 0="" D CHM VEN G D1      ;DEV007 991 10/08/ 2010 JAK -  REC14
  20427   "RTN","CHM FA013",21, 0)
  20428    I VFN=""  S REC1="", REC0="",RE C14="",REC 41="",REC2 ="",REC5=" ",REC3="", REC80="" D  CHMVEN G  D1           ;DEV0079 91 10/08/2 010 JAK -  REC14
  20429   "RTN","CHM FA013",22, 0)
  20430    Q:'$D(^CH MVEN(VFN,0 ))  S REC0 ="",REC1=" ",REC14="" ,REC41="", REC2="",RE C5="",REC3 ="",REC80= ""            ;DEV007 991 10/08/ 2010 JAK -  REC14
  20431   "RTN","CHM FA013",23, 0)
  20432    S REC0=^C HMVEN(VFN, 0)
  20433   "RTN","CHM FA013",24, 0)
  20434    S:$D(^CHM VEN(VFN,1) ) REC1=^CH MVEN(VFN,1 )
  20435   "RTN","CHM FA013",25, 0)
  20436    I '$D(^CH MVEN(VFN,2 )) D  S RE C2=^CHMVEN (VFN,2)
  20437   "RTN","CHM FA013",26, 0)
  20438    .F X=1:1: 6 S $P(^CH MVEN(VFN,2 ),"^",X)=$ P(^CHMVEN( VFN,1),"^" ,X)
  20439   "RTN","CHM FA013",27, 0)
  20440    .S $P(^CH MVEN(VFN,2 ),"^",10)= $P(^CHMVEN (VFN,1),"^ ",17)
  20441   "RTN","CHM FA013",28, 0)
  20442    .S $P(^CH MVEN(VFN,2 ),"^",11)= $P(^CHMVEN (VFN,1),"^ ",18)
  20443   "RTN","CHM FA013",29, 0)
  20444    I ^CHMVEN (VFN,2)=""  D  S REC2 =^CHMVEN(V FN,2)
  20445   "RTN","CHM FA013",30, 0)
  20446    .F X=1:1: 6 S $P(^CH MVEN(VFN,2 ),"^",X)=$ P(^CHMVEN( VFN,1),"^" ,X)
  20447   "RTN","CHM FA013",31, 0)
  20448    .S $P(^CH MVEN(VFN,2 ),"^",10)= $P(^CHMVEN (VFN,1),"^ ",17)
  20449   "RTN","CHM FA013",32, 0)
  20450    .S $P(^CH MVEN(VFN,2 ),"^",11)= $P(^CHMVEN (VFN,1),"^ ",18)
  20451   "RTN","CHM FA013",33, 0)
  20452    S:$D(^CHM VEN(VFN,2) ) REC2=^CH MVEN(VFN,2 )                ;DEV 007991 10/ 08/2010 JA K - added  $D to make  sure popu lated
  20453   "RTN","CHM FA013",34, 0)
  20454    S:$D(^CHM VEN(VFN,3) ) REC3=^(3 )
  20455   "RTN","CHM FA013",35, 0)
  20456    S:$D(^CHM VEN(VFN,4) ) REC4=^(4 )  ;CPE001 -019
  20457   "RTN","CHM FA013",36, 0)
  20458    S:$D(^CHM VEN(VFN,5) ) REC5=^(5 )
  20459   "RTN","CHM FA013",37, 0)
  20460    S:$D(^CHM VEN(VFN,14 )) REC14=^ CHMVEN(VFN ,14)             ;DEV 007991 10/ 08/2010 JA K - ,14) t o populate  internal  modifier
  20461   "RTN","CHM FA013",38, 0)
  20462    S JJ="A", JJ=$O(^CHM VEN(VFN,41 ,JJ),-1)
  20463   "RTN","CHM FA013",39, 0)
  20464    I JJ S:$D (^CHMVEN(V FN,41,JJ,0 )) REC41=^ (0)
  20465   "RTN","CHM FA013",40, 0)
  20466    S JJ="A", JJ=$O(^CHM VEN(VFN,80 ,JJ),-1)
  20467   "RTN","CHM FA013",41, 0)
  20468    I JJ S:$D (^CHMVEN(V FN,80,JJ,0 )) REC80=^ (0)
  20469   "RTN","CHM FA013",42, 0)
  20470    D CHMVEN
  20471   "RTN","CHM FA013",43, 0)
  20472   D1 S BLNK= "",$P(BLNK ," ",27)=" ",BLNK1="" ,$P(BLNK1, " ",30)=""
  20473   "RTN","CHM FA013",44, 0)
  20474    ;S DY=13, DX=12,$Y=D Y,$X=DX X  XY W BLNK  X XY W $P( REC0,"^",1 )
  20475   "RTN","CHM FA013",45, 0)
  20476    ;S DX=42, $X=DX X XY  W BLNK1 X  XY W $P(R EC2,"^",8)  X XY
  20477   "RTN","CHM FA013",46, 0)
  20478    ;SBB 05/0 2/2017
  20479   "RTN","CHM FA013",47, 0)
  20480    S DY=13
  20481   "RTN","CHM FA013",48, 0)
  20482    ;,DX=12,$ Y=DY,$X=DX  X XY W BL NK X XY W  $P(REC2,"^ ",8)
  20483   "RTN","CHM FA013",49, 0)
  20484    ;---Begin  CPE001-01 8 and 019
  20485   "RTN","CHM FA013",50, 0)
  20486    ;S DX=42, $X=DX X XY  W BLNK1 X  XY W $P(R EC0,"^",1)  X XY
  20487   "RTN","CHM FA013",51, 0)
  20488    S DX=42,$ X=DX X XY  W BLNK1 X  XY W $S($P ($G(REC4), "^",1)'="" :$P(REC4," ^",1),1:$P (REC0,"^", 1)) X XY
  20489   "RTN","CHM FA013",52, 0)
  20490    ;---End C PE001-018  and 019
  20491   "RTN","CHM FA013",53, 0)
  20492    S DY=14
  20493   "RTN","CHM FA013",54, 0)
  20494    ;,DX=12,$ Y=DY,$X=DX  X XY W BL NK X XY
  20495   "RTN","CHM FA013",55, 0)
  20496    ;W:$P(REC 0,"^",3)'= "" $P(REC0 ,"^",3)_"- "_$P(REC0, "^",23)_"- "_$P(REC14 ,"^",1)                   ;DEV00 7991 10/08 /2010 JAK  - concats  the intern al modifer  for displ ay (physic al locatio n)
  20497   "RTN","CHM FA013",56, 0)
  20498    S DX=42,$ X=DX X XY  W BLNK1 X  XY
  20499   "RTN","CHM FA013",57, 0)
  20500    W:$P(REC0 ,"^",3)'=" " $P(REC0, "^",3)_"-" _$P(REC0," ^",23)_"-" _$P(REC14, "^",1)                   ;DEV007 991 10/08/ 2010 JAK -  concats t he interna l modifer  for displa y (remit-t o location )
  20501   "RTN","CHM FA013",58, 0)
  20502    ;S DY=15
  20503   "RTN","CHM FA013",59, 0)
  20504    ;,DX=12,$ Y=DY,$X=DX  X XY W BL NK X XY W  $P(REC2,"^ ",1)
  20505   "RTN","CHM FA013",60, 0)
  20506    ;---Begin  CPE001-01 8 and 019
  20507   "RTN","CHM FA013",61, 0)
  20508    I $P($G(R EC4),"^",2 )'="" D  ; --Display  selected V endor Bill  to Addres s if Bill  to Address  is popula ted.
  20509   "RTN","CHM FA013",62, 0)
  20510    .S DY=15, DX=42,$Y=D Y,$X=DX X  XY W BLNK1  X XY W $P (REC4,"^", 2)
  20511   "RTN","CHM FA013",63, 0)
  20512    .I $P(REC 4,"^",3)'= "" D
  20513   "RTN","CHM FA013",64, 0)
  20514    ..S DY=16 ,DX=42,$X= DX X XY W  BLNK1 X XY  W $P(REC4 ,"^",3)
  20515   "RTN","CHM FA013",65, 0)
  20516    ..S DY=17 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY W $ P(REC4,"^" ,4)
  20517   "RTN","CHM FA013",66, 0)
  20518    ..S DY=18 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY S S T=$P(REC4, "^",5)
  20519   "RTN","CHM FA013",67, 0)
  20520    ..I ST'=" " S:$D(^DI C(5,ST,0))  PST=$P(^( 0),"^",1)  X XY W PST
  20521   "RTN","CHM FA013",68, 0)
  20522    ..S DY=19 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY W $ P(REC4,"^" ,6)
  20523   "RTN","CHM FA013",69, 0)
  20524    .I $P(REC 4,"^",3)=" " D
  20525   "RTN","CHM FA013",70, 0)
  20526    ..S DY=16 ,DX=42,$X= DX X XY W  BLNK1 X XY  W $P(REC4 ,"^",4)
  20527   "RTN","CHM FA013",71, 0)
  20528    ..S DY=17 ,DX=42,$Y= DY,$X=DX X  XY W BLNK  X XY S ST =$P(REC4," ^",5),PST= ""
  20529   "RTN","CHM FA013",72, 0)
  20530    ..I ST'=" " S:$D(^DI C(5,ST,0))  PST=$P(^( 0),"^",1)  X XY W PST
  20531   "RTN","CHM FA013",73, 0)
  20532    ..S DY=18 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY W $ P(REC4,"^" ,6)
  20533   "RTN","CHM FA013",74, 0)
  20534    I $P($G(R EC4),"^",2 )="" D  ;- -Display t he Vendor  Remit to A ddress if  there is n o Bill to  Address.
  20535   "RTN","CHM FA013",75, 0)
  20536    .S DY=15, DX=42,$X=D X X XY W B LNK1 X XY  W $P(REC1, "^",1)
  20537   "RTN","CHM FA013",76, 0)
  20538    .I $P(REC 1,"^",2)'= "" D
  20539   "RTN","CHM FA013",77, 0)
  20540    ..S DY=16 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY W $ P(REC1,"^" ,2)
  20541   "RTN","CHM FA013",78, 0)
  20542    ..S DY=17 ,DX=42,$X= DX X XY W  BLNK1 X XY  W $P(REC1 ,"^",3)
  20543   "RTN","CHM FA013",79, 0)
  20544    ..S DY=18 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY S S T=$P(REC1, "^",4)
  20545   "RTN","CHM FA013",80, 0)
  20546    ..I ST'=" " S:$D(^DI C(5,ST,0))  PST=$P(^( 0),"^",1)  X XY W PST
  20547   "RTN","CHM FA013",81, 0)
  20548    ..S DY=19 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY W $ P(REC1,"^" ,5)
  20549   "RTN","CHM FA013",82, 0)
  20550    .I $P(REC 1,"^",2)=" " D
  20551   "RTN","CHM FA013",83, 0)
  20552    ..S DY=16 ,DX=42,$X= DX X XY W  BLNK1 X XY  W $P(REC1 ,"^",3)
  20553   "RTN","CHM FA013",84, 0)
  20554    ..S DY=17 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY S S T=$P(REC1, "^",4)
  20555   "RTN","CHM FA013",85, 0)
  20556    ..I ST'=" " S:$D(^DI C(5,ST,0))  PST=$P(^( 0),"^",1)  X XY W PST
  20557   "RTN","CHM FA013",86, 0)
  20558    ..S DY=18 ,DX=42,$Y= DY,$X=DX X  XY W BLNK 1 X XY W $ P(REC1,"^" ,5)
  20559   "RTN","CHM FA013",87, 0)
  20560    ;---End C PE001-018  and 019
  20561   "RTN","CHM FA013",88, 0)
  20562    S DY=14,D X=5,$Y=DY, $X=DX X XY  W $E(BLNK ,1,3) X XY  S ST=$P(R EC1,"^",9) ,PST=""
  20563   "RTN","CHM FA013",89, 0)
  20564    I ST'=""  S PST=$S(S T=0:"N",ST =1:"Y",1:" ") X XY W  PST
  20565   "RTN","CHM FA013",90, 0)
  20566    S DY=15,D X=10,$Y=DY ,$X=DX X X Y W $E(BLN K,1,32) X  XY
  20567   "RTN","CHM FA013",91, 0)
  20568    S FT=$P(R EC1,"^",7) ,PFT=""
  20569   "RTN","CHM FA013",92, 0)
  20570    I FT'=""  S:$D(^CHMD IC(741002. 11,FT,0))  PFT=$P(^(0 ),"^",2) W  $E(PFT,1, 32)
  20571   "RTN","CHM FA013",93, 0)
  20572    S DY=16,D X=5,$Y=DY, $X=DX X XY  W $E(BLNK ,1,3) X XY  S ST=$P(R EC80,"^",2 ),PST=""
  20573   "RTN","CHM FA013",94, 0)
  20574    S PST=$S( ST="":"",S T="N":"N", ST="NO":"N ",ST="No": "N",ST="no ":"N",ST=" YES":"Y",S T="Yes":"Y ",ST="yes" :"Y",ST?1N .N:"Y",1:" ")
  20575   "RTN","CHM FA013",95, 0)
  20576    X XY W PS T
  20577   "RTN","CHM FA013",96, 0)
  20578    S DY=17,D X=6,$Y=DY, $X=DX X XY  W $E(BLNK ,1,3) X XY  W $P(REC4 1,"^",3)
  20579   "RTN","CHM FA013",97, 0)
  20580    S DY=18,D X=5,$Y=DY, $X=DX X XY  W $E(BLNK ,1,3) X XY  S ST=$P(R EC3,"^",11 ),PST=""
  20581   "RTN","CHM FA013",98, 0)
  20582    S PST=$S( ST=0:"N",S T=1:"Y",1: "") X XY W  PST
  20583   "RTN","CHM FA013",99, 0)
  20584    ;S DY=20, DX=78 X XY  W $E(BLNK ,1,2) X XY  S ST=""
  20585   "RTN","CHM FA013",100 ,0)
  20586    ;I $D(VFN ) I VFN'=" " I $D(^CH MVCOMM(VFN ,101)) S S T="Y" X XY  W ST
  20587   "RTN","CHM FA013",101 ,0)
  20588    Q
  20589   "RTN","CHM FA013",102 ,0)
  20590    ;HM 07/24 /2017 disp lay Remit- to Informa tion text  line
  20591   "RTN","CHM FA013",103 ,0)
  20592   VEN S DY=1 2,DX=1,$Y= DY,$X=DX X  XY F LN=1 :1:80 W "- "
  20593   "RTN","CHM FA013",104 ,0)
  20594    S DY=12,D X=37,$Y=DY ,$X=DX X X Y
  20595   "RTN","CHM FA013",105 ,0)
  20596    W @CHBON, "  || Bill ing/Remit- to Informa tion |",@C HBOFF  ;CP E001-018 a dd Billing / to displ ay.
  20597   "RTN","CHM FA013",106 ,0)
  20598    Q
  20599   "RTN","CHM FA013",107 ,0)
  20600   CHMVEN I $ D(CHMVEN(2 )) S:CHMVE N(2)'="" $ P(REC0,"^" ,1)=CHMVEN (2)
  20601   "RTN","CHM FA013",108 ,0)
  20602    I $D(CHMV EN(3)) S:C HMVEN(3)'= "" $P(REC0 ,"^",3)=CH MVEN(3)
  20603   "RTN","CHM FA013",109 ,0)
  20604    I $D(CHMV EN(1)) S:C HMVEN(1)'= "" $P(REC2 ,"^",8)=CH MVEN(1)
  20605   "RTN","CHM FA013",110 ,0)
  20606    F I=1:1:5  I $D(CHMV EN(I+3)) S :CHMVEN(I+ 3)'="" $P( REC2,"^",I )=CHMVEN(I +3)
  20607   "RTN","CHM FA013",111 ,0)
  20608    ;NEXT LIN E NEW, NEX T 4 LINES  OLD
  20609   "RTN","CHM FA013",112 ,0)
  20610    ;F I=1:1: 5 I $D(CHM VEN(I+8))  S:CHMVEN(I +8)'="" $P (REC1,"^", I)=CHMVEN( I+8)
  20611   "RTN","CHM FA013",113 ,0)
  20612    I $D(CHMV EN(9)) S:C HMVEN(9)'= "" $P(REC4 1,"^",3)=C HMVEN(9)
  20613   "RTN","CHM FA013",114 ,0)
  20614    I $D(CHMV EN(10)) S: CHMVEN(10) '="" $P(RE C2,"^",6)= CHMVEN(10)
  20615   "RTN","CHM FA013",115 ,0)
  20616    I $D(CHMV EN(11)) S: CHMVEN(11) '="" $P(RE C1,"^",7)= CHMVEN(11)
  20617   "RTN","CHM FA013",116 ,0)
  20618    I $D(CHMV EN(12)) S: CHMVEN(12) '="" $P(RE C1,"^",11) =CHMVEN(12 )
  20619   "RTN","CHM FA013",117 ,0)
  20620    F I=1:1:5  I $D(CHMV EN(I+13))  S:CHMVEN(I +13)'="" $ P(REC1,"^" ,I)=CHMVEN (I+13)
  20621   "RTN","CHM FA013",118 ,0)
  20622    Q
  20623   "RTN","CHM FA01E")
  20624   0^42^B5618 5655
  20625   "RTN","CHM FA01E",1,0 )
  20626   CHMFA01E ; JLR/DEN;VE NDOR PROMP T E/E SCRE EN;Feb 06,  2019@10:1 3:06
  20627   "RTN","CHM FA01E",2,0 )
  20628    ;;1.0;CHA MPVA SYSTE M;**1,8,14 **;JULY 4,  1990;Buil d 9
  20629   "RTN","CHM FA01E",3,0 )
  20630    ;;V2.0
  20631   "RTN","CHM FA01E",4,0 )
  20632    ;DEV00799 1 10/08/20 10 JAK -VE NDOR LOOKU P utilizin g NPI  ;DE V007991 10 /08/2010 J AK -VENDOR  LOOKUP ut ilizing NP I; restruc ture and r elabeled a s well as  logic chan ges
  20633   "RTN","CHM FA01E",5,0 )
  20634    ;BUG00799 1-07-03 DR W - K DIC  in NPI lin e tag befo re using N PI search  12/20/10
  20635   "RTN","CHM FA01E",6,0 )
  20636    ;BUG00799 1-07-06 DR W - Cursor  placement  is shifti ng to next  field at  the end of
  20637   "RTN","CHM FA01E",7,0 )
  20638    ;NPI fiel d. Change  FL for NPI  from 10 t o 11 to st op cursor  at the end  of NPI  0 1/06/11
  20639   "RTN","CHM FA01E",8,0 )
  20640    ;HM 06/30 /17 CPE001 -001-T3-52 2242 Modif y code to  use skip p zip and ps tate field s.
  20641   "RTN","CHM FA01E",9,0 )
  20642    ;TGH 01/2 3/18 CPE00 1-014,CPE0 01-015,CPE 001-016 Cr eate Popup  for Tax I D and dele te entry i f No or Ti me Out
  20643   "RTN","CHM FA01E",10, 0)
  20644    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370  RT Name an d Zip Cosm etic Issue  on IP scr een for Ve ndor Searc h
  20645   "RTN","CHM FA01E",11, 0)
  20646    S BLNK1=" " S $P(BLN K1," ",30) =""
  20647   "RTN","CHM FA01E",12, 0)
  20648    K CHXTID, CHTIN,CHXI M,CHXNPI,C HXPRN,CHST ATE,CHTMPS T,CHXZIP,C HXRZIP      ;DEV00799 1 10/08/20 10 JAK -
  20649   "RTN","CHM FA01E",13, 0)
  20650    S:'$D(CHX TID) CHXTI D=""
  20651   "RTN","CHM FA01E",14, 0)
  20652    S:'$D(CHX NPI) CHXNP I=""    ;D EV007991 1 0/08/2010  JAK -
  20653   "RTN","CHM FA01E",15, 0)
  20654    S:'$D(CHX PRN) CHXPR N=""
  20655   "RTN","CHM FA01E",16, 0)
  20656    S:'$D(CHS TATE) CHST ATE=""
  20657   "RTN","CHM FA01E",17, 0)
  20658    S:'$D(CHT MPST) CHTM PST=""
  20659   "RTN","CHM FA01E",18, 0)
  20660    S:'$D(CHX ZIP) CHXZI P=""
  20661   "RTN","CHM FA01E",19, 0)
  20662    S:'$D(CHX RZIP) CHXR ZIP=""  ;D EV007991 1 0/08/2010  JAK -
  20663   "RTN","CHM FA01E",20, 0)
  20664    S:'$D(CHB DFLG) CHBD FLG=1  ;TL H 7/6/07 D EV00374  ; TLH 9/20/0 7 BUG00037 4
  20665   "RTN","CHM FA01E",21, 0)
  20666   TID ;; TID  DATA ENTR Y
  20667   "RTN","CHM FA01E",22, 0)
  20668    K F1,DD1O UT S QU=90 ,DY=5,DX=1 0,FL=15,$Y =DY,$X=DX  X XY W BLN K1 X XY W  CHXTID   ; DEV007991  10/08/2010  JAK
  20669   "RTN","CHM FA01E",23, 0)
  20670    S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20671   "RTN","CHM FA01E",24, 0)
  20672    G:$D(DUOU T) TID
  20673   "RTN","CHM FA01E",25, 0)
  20674    I $D(DQOU T) D QUES  X XY W BLN K1 W CHXTI D G TID
  20675   "RTN","CHM FA01E",26, 0)
  20676    Q:$D(DDOU T)!$D(DFOU T)
  20677   "RTN","CHM FA01E",27, 0)
  20678    G:$D(D1OU T) TID
  20679   "RTN","CHM FA01E",28, 0)
  20680    I Y="" D: $D(CHCLRFG ) REPNT G  NPI
  20681   "RTN","CHM FA01E",29, 0)
  20682    ;I Y=" ", $D(^DISV(D UZ,"CHVEN" )) S VFN=^ ("CHVEN")  D GET S VF N="" G END
  20683   "RTN","CHM FA01E",30, 0)
  20684    I Y="@" S  CHXTID="" ,VFN="" K  CHMVEN D C LEAR,DISP^ CHMFA013 G  TID
  20685   "RTN","CHM FA01E",31, 0)
  20686    I $L(Y)<3  S DY=5,DX =15,$Y=DY, $X=DX X XY  W BLNK1 X  XY W *7,"    ??" R X :2 X XY W  BLNK1 X XY  W:CHXTID' ="" CHXTID  D:$D(CHCL RFG) CLEAR ,REPNT G T ID
  20687   "RTN","CHM FA01E",32, 0)
  20688    I $L(Y)<= 9 S CHTIN= Y
  20689   "RTN","CHM FA01E",33, 0)
  20690    I $L(Y)>9  S CHTIN=$ E(Y,1,9)_" *"_$E(Y,10 ,11) S CHX IM=$E(Y,12 ,13)
  20691   "RTN","CHM FA01E",34, 0)
  20692    K CHFIOUT
  20693   "RTN","CHM FA01E",35, 0)
  20694    D FIND^DI C(741001,, ,"M",CHTIN ,1,"H",,," ^TMP($J,"" DILIST"")" )  ;HM 07/ 24/2017 mo dified glo bal to ret rieve vend or data
  20695   "RTN","CHM FA01E",36, 0)
  20696    I $P($D(^ TMP($J,"DI LIST","DIL IST",0)),U ,1)<1 D  G  TID  ; Un defined er ror 08/19  and 9/19/0 5 mlr
  20697   "RTN","CHM FA01E",37, 0)
  20698    .D CLEAR  S DY=14,DX =32,$Y=DY, $X=DX X XY  W *7," NO  VENDOR FO UND" S CHC LRFG=1
  20699   "RTN","CHM FA01E",38, 0)
  20700    S CHXTID= CHTIN
  20701   "RTN","CHM FA01E",39, 0)
  20702    ;
  20703   "RTN","CHM FA01E",40, 0)
  20704    N TIN837   ;CPE001-0 14 1/22/20 18 TGH - N ew variabl e and Get  TIN from 8 37
  20705   "RTN","CHM FA01E",41, 0)
  20706    S TIN837= $P($G(^CHM IMAGE(CHMF PDI,"P-VEN ",1,0)),U, 5)
  20707   "RTN","CHM FA01E",42, 0)
  20708    ;CPE001-0 14 1/22/20 18 TGH - I f Tax IDs  do not mat ch, print  Popout and  set New V endor ID t o Null if  reply time d out or a nswered No
  20709   "RTN","CHM FA01E",43, 0)
  20710    I $G(TIN8 37)'="",$E (CHXTID,1, 9)'=$E(TIN 837,1,9),' $$ERR837()  S (CHTIN, CHXTID)=""  D CLEAR,D ISP^CHMFA0 13 G TID
  20711   "RTN","CHM FA01E",44, 0)
  20712    ;
  20713   "RTN","CHM FA01E",45, 0)
  20714    S DX=10,D Y=5,$Y=DY, $X=DX X XY
  20715   "RTN","CHM FA01E",46, 0)
  20716    I $L(Y)<1 2 W CHXTID
  20717   "RTN","CHM FA01E",47, 0)
  20718    E  W CHXT ID_"*"_CHX IM
  20719   "RTN","CHM FA01E",48, 0)
  20720    D:$D(CHCL RFG) REPNT
  20721   "RTN","CHM FA01E",49, 0)
  20722   NPI ;; NPI  DATA ENTR Y  ;DEV007 991 10/08/ 2010 JAK c hange ^uti lity to ^t mp
  20723   "RTN","CHM FA01E",50, 0)
  20724    K F1,DD1O UT S QU=91 ,DY=6,DX=1 0,FL=11,$Y =DY,$X=DX  X XY W BLN K1 X XY W  CHXNPI          ;;BUG 007991-07- 06 DRW - c hange FL f rom 10 to  11 01/06/1 1.
  20725   "RTN","CHM FA01E",51, 0)
  20726    S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20727   "RTN","CHM FA01E",52, 0)
  20728    I $D(DQOU T) D QUES  X XY W BLN K1 W CHXNP I G NPI
  20729   "RTN","CHM FA01E",53, 0)
  20730    I $D(DUOU T) S DY=6, DX=10,$Y=D Y,$X=DX X  XY W BLNK1  S DX=10,$ X=DX X XY  W:CHXNPI'= "" CHXNPI  D:$D(CHCLR FG) CLEAR, REPNT G TI D
  20731   "RTN","CHM FA01E",54, 0)
  20732    Q:$D(DDOU T)!$D(DFOU T)
  20733   "RTN","CHM FA01E",55, 0)
  20734    I $D(D1OU T) D:$D(CH CLRFG) REP NT G TID
  20735   "RTN","CHM FA01E",56, 0)
  20736    I Y="" D: $D(CHCLRFG ) REPNT G  RTNAME
  20737   "RTN","CHM FA01E",57, 0)
  20738    I Y=" ",$ D(^DISV(DU Z,"CHVEN") ) S VFN=^( "CHVEN") D  GET S VFN ="" G END
  20739   "RTN","CHM FA01E",58, 0)
  20740    I Y="@" S  CHXNPI=""  G NPI
  20741   "RTN","CHM FA01E",59, 0)
  20742    I $L(Y)<3  S DY=6,DX =15,$Y=DY, $X=DX X XY  W BLNK1 X  XY W *7,"    ??" R X :2 X XY W  BLNK1 X XY  W:CHXNPI' ="" CHXNPI  D:$D(CHCL RFG) CLEAR ,REPNT G N PI
  20743   "RTN","CHM FA01E",60, 0)
  20744    K ^TMP($J ,"DILIST") ,DIC                                   ;DEV 007991 10/ 08/2010 JA K change ^ utility to  ^tmp
  20745   "RTN","CHM FA01E",61, 0)
  20746    ;BUG00799 1-07-02 DR W - change d the find  dic funti on to use  a Q (quick ) lookup i nstead of  M (multi)  - 12/16/10 .
  20747   "RTN","CHM FA01E",62, 0)
  20748    ;D FIND^D IC(741001, "","","Q", Y,1,"M","" ,"","")       ;DEV007 991 10/08/ 2010 JAK f ind at lea st one NPI  value in  the M cros s referenc e (NPI) VA LUE IN M C ROSS REFER ENCE
  20749   "RTN","CHM FA01E",63, 0)
  20750    ;AJF - st ory 001-00 9
  20751   "RTN","CHM FA01E",64, 0)
  20752    D FIND^DI C(741001,, ,"Q",Y,,"M ",,,"^TMP( $J,""DILIS T"")")  ;H M 07/24/20 17 modifie d global t o retrieve  vendor da ta
  20753   "RTN","CHM FA01E",65, 0)
  20754    I $P($D(^ TMP($J,"DI LIST","DIL IST",0)),U ,1)<1 D  G  NPI
  20755   "RTN","CHM FA01E",66, 0)
  20756    .D CLEAR  S DY=13,DX =32,$Y=DY, $X=DX X XY  W *7," NO  VENDORS F OUND" S CH CLRFG=1
  20757   "RTN","CHM FA01E",67, 0)
  20758    S CHXNPI= Y
  20759   "RTN","CHM FA01E",68, 0)
  20760    S DX=10,D Y=6,$Y=DY, $X=DX X XY  W CHXNPI
  20761   "RTN","CHM FA01E",69, 0)
  20762    D:$D(CHCL RFG) REPNT
  20763   "RTN","CHM FA01E",70, 0)
  20764   RTNAME  ;R EMIT-TO NA ME DATA EN TRY  ;DEV0 07991 10/0 8/2010 JAK
  20765   "RTN","CHM FA01E",71, 0)
  20766    K F1,DD1O UT S QU=92 ,DY=7,DX=1 0,FL=30,$Y =DY,$X=DX  X XY W BLN K1 X XY W  CHXPRN
  20767   "RTN","CHM FA01E",72, 0)
  20768    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370
  20769   "RTN","CHM FA01E",73, 0)
  20770    ;W CHXPRN  S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20771   "RTN","CHM FA01E",74, 0)
  20772    S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20773   "RTN","CHM FA01E",75, 0)
  20774    I $D(DQOU T) D QUES  X XY W BLN K1 W CHXPR N G RTNAME
  20775   "RTN","CHM FA01E",76, 0)
  20776    I $D(DUOU T) S DY=7, DX=10,$Y=D Y,$X=DX X  XY W BLNK1  S DX=10,$ X=DX X XY  W:CHXPRN'= "" CHXPRN  D:$D(CHCLR FG) CLEAR, REPNT G NP I
  20777   "RTN","CHM FA01E",77, 0)
  20778    Q:$D(DDOU T)!$D(DFOU T)
  20779   "RTN","CHM FA01E",78, 0)
  20780    I $D(D1OU T) D:$D(CH CLRFG) REP NT G NPI
  20781   "RTN","CHM FA01E",79, 0)
  20782    I Y="" D: $D(CHCLRFG ) REPNT G  RZIP
  20783   "RTN","CHM FA01E",80, 0)
  20784    I Y=" ",$ D(^DISV(DU Z,"CHVEN") ) S VFN=^( "CHVEN") D  GET S VFN ="" G END
  20785   "RTN","CHM FA01E",81, 0)
  20786    I Y="@" S  CHXPRN=""  G RTNAME
  20787   "RTN","CHM FA01E",82, 0)
  20788    K ^TMP("D ILIST",$J)                  ;DEV 007991 10/ 08/2010 JA K change ^ utility to  ^tmp
  20789   "RTN","CHM FA01E",83, 0)
  20790    D FIND^DI C(741001,, ,"M",Y,1," B",,,"^TMP ($J,""DILI ST"")")  ; HM 07/24/2 017 modifi ed global  to retriev e vendor d ata
  20791   "RTN","CHM FA01E",84, 0)
  20792    I $P($D(^ TMP($J,"DI LIST","DIL IST",0)),U ,1)<1 D  G  RTNAME
  20793   "RTN","CHM FA01E",85, 0)
  20794    .D CLEAR  S DY=13,DX =32,$Y=DY, $X=DX X XY  W *7," NO  VENDOR FO UND" S CHC LRFG=1
  20795   "RTN","CHM FA01E",86, 0)
  20796    S CHXPRN= Y
  20797   "RTN","CHM FA01E",87, 0)
  20798    S DX=10,D Y=7,$Y=DY, $X=DX X XY  W CHXPRN
  20799   "RTN","CHM FA01E",88, 0)
  20800    D:$D(CHCL RFG) REPNT
  20801   "RTN","CHM FA01E",89, 0)
  20802   RZIP  ; RE MIT-TO ZIP  DATA ENTR Y  ;DEV007 991 10/08/ 2010 JAK
  20803   "RTN","CHM FA01E",90, 0)
  20804    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370
  20805   "RTN","CHM FA01E",91, 0)
  20806    ;K F1,DD1 OUT S QU=9 3,DY=8,DX= 10,FL=9,$Y =DY,$X=DX  X XY W BLN K1 W CHXRZ IP
  20807   "RTN","CHM FA01E",92, 0)
  20808    K F1,DD1O UT S QU=93 ,DY=8,DX=1 0,FL=9,$Y= DY,$X=DX X  XY W BLNK 1 X XY W C HXRZIP
  20809   "RTN","CHM FA01E",93, 0)
  20810    S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20811   "RTN","CHM FA01E",94, 0)
  20812    I $D(DQOU T) D QUES  X XY W BLN K1 X XY W  CHXRZIP G  RZIP
  20813   "RTN","CHM FA01E",95, 0)
  20814    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370
  20815   "RTN","CHM FA01E",96, 0)
  20816    ;I $D(DUO UT) S DY=8 ,DX=10,$Y= DY,$X=DX X  XY W BLNK 1 S DX=10, $X=DX X XY  W CHXRZIP  D:$D(CHCL RFG) CLEAR ,REPNT G R TNAME
  20817   "RTN","CHM FA01E",97, 0)
  20818    I $D(DUOU T) S DY=8, DX=10,$Y=D Y,$X=DX X  XY W BLNK1  S DX=10,$ X=DX X XY  W:CHXRZIP' ="" CHXRZI P D:$D(CHC LRFG) CLEA R,REPNT G  RTNAME
  20819   "RTN","CHM FA01E",98, 0)
  20820    I $D(D1OU T) D:$D(CH CLRFG) REP NT G RTNAM E
  20821   "RTN","CHM FA01E",99, 0)
  20822    Q:$D(DDOU T)!$D(DFOU T)
  20823   "RTN","CHM FA01E",100 ,0)
  20824    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370
  20825   "RTN","CHM FA01E",101 ,0)
  20826    I Y="" D: $D(CHCLRFG ) REPNT G  TID
  20827   "RTN","CHM FA01E",102 ,0)
  20828    I Y="@" S  CHXRZIP=" " G RZIP
  20829   "RTN","CHM FA01E",103 ,0)
  20830    S CHXRZIP =Y
  20831   "RTN","CHM FA01E",104 ,0)
  20832    S DX=10,D Y=8,$Y=DY, $X=DX X XY  W CHXRZIP
  20833   "RTN","CHM FA01E",105 ,0)
  20834    D:$D(CHCL RFG) REPNT
  20835   "RTN","CHM FA01E",106 ,0)
  20836    ;HM 7/12/ 2017 COMME NTED OUT C ODE BELOW  BECAUSE SC REEN WAS T ABBING TO  PZIP AND P STATE FIEL DS WHEN LA BELS WERE  REMOVED
  20837   "RTN","CHM FA01E",107 ,0)
  20838    ;PZIP  ;  PHYSICAL L OCATION ZI P DATA ENT RY  ;DEV00 7991 10/08 /2010 JAK
  20839   "RTN","CHM FA01E",108 ,0)
  20840    ;S BLNK1= "" S $P(BL NK1," ",10 )=""
  20841   "RTN","CHM FA01E",109 ,0)
  20842    ;K F1,DD1 OUT S QU=9 4,DY=9,DX= 10,FL=9,$Y =DY,$X=DX  X XY W BLN K1 W CHXZI P
  20843   "RTN","CHM FA01E",110 ,0)
  20844    ;S DX=10, $X=DX X XY  D CSBRS^C HSC2
  20845   "RTN","CHM FA01E",111 ,0)
  20846    ;I $D(DQO UT) D QUES  X XY W BL NK1 X XY W  CHXZIP G  PZIP
  20847   "RTN","CHM FA01E",112 ,0)
  20848    ;I $D(DUO UT) S DY=9 ,DX=10,$Y= DY,$X=DX X  XY W BLNK 1 S DX=10, $X=DX X XY  W CHXZIP  D:$D(CHCLR FG) CLEAR, REPNT G RZ IP
  20849   "RTN","CHM FA01E",113 ,0)
  20850    ;I $D(D1O UT) D:$D(C HCLRFG) RE PNT G RZIP
  20851   "RTN","CHM FA01E",114 ,0)
  20852    ;Q:$D(DDO UT)!$D(DFO UT)
  20853   "RTN","CHM FA01E",115 ,0)
  20854    ;I Y="@"  S CHXZIP=" " G PZIP
  20855   "RTN","CHM FA01E",116 ,0)
  20856    ;S CHXZIP =Y
  20857   "RTN","CHM FA01E",117 ,0)
  20858    ;S DX=10, DY=9,$Y=DY ,$X=DX X X Y W CHXZIP
  20859   "RTN","CHM FA01E",118 ,0)
  20860    ;D:$D(CHC LRFG) REPN T
  20861   "RTN","CHM FA01E",119 ,0)
  20862    ;PSTATE   ; PHYSICAL  LOCATION  STATE DATA  ENTRY (LO C. DY=9 RO LLS, DX=26  COLUMNS).
  20863   "RTN","CHM FA01E",120 ,0)
  20864    ;S BLNK1= "" S $P(BL NK1," ",15 )=""     ; ;DEV 7991a  DRW 10/06 /10 BLNK1  BLANKS OUT  A 15 CHAR . FIELD
  20865   "RTN","CHM FA01E",121 ,0)
  20866    ;K F1,DD1 OUT S QU=9 5,DY=9,DX= 26,FL=2,$Y =DY,$X=DX  X XY W BLN K1 X XY W  CHTMPST
  20867   "RTN","CHM FA01E",122 ,0)
  20868    ;S DX=26, $X=DX X XY  D CSBRS^C HSC2
  20869   "RTN","CHM FA01E",123 ,0)
  20870    ;I $D(DQO UT) D QUES  X XY W BL NK1 X XY W  CHTMPST G  PSTATE
  20871   "RTN","CHM FA01E",124 ,0)
  20872    ;I $D(DUO UT) S DY=9 ,DX=26,$Y= DY,$X=DX X  XY W BLNK 1 S DX=26, $X=DX X XY  W CHTMPST  D:$D(CHCL RFG) CLEAR ,REPNT G P ZIP
  20873   "RTN","CHM FA01E",125 ,0)
  20874    ;I $D(D1O UT) D:$D(C HCLRFG) RE PNT G PZIP
  20875   "RTN","CHM FA01E",126 ,0)
  20876    ;Q:$D(DDO UT)!$D(DFO UT)
  20877   "RTN","CHM FA01E",127 ,0)
  20878    ;I Y'=""  S CHTMPST= "",CHSTATE ="" S DY=9 ,DX=26,$Y= DY,$X=DX X  XY W BLNK 1     ;;DE V 7991a DR W - FILLS  15 SPACES  IN THE STA TE FIELD
  20879   "RTN","CHM FA01E",128 ,0)
  20880    ;I Y="@"  S CHTMPST= "",CHSTATE ="" G PSTA TE
  20881   "RTN","CHM FA01E",129 ,0)
  20882    ;;I Y=""  D:$D(CHCLR FG) REPNT  G A5
  20883   "RTN","CHM FA01E",130 ,0)
  20884    ;D ^CHGVQ 034 D ^CHM FSET,REPNT
  20885   "RTN","CHM FA01E",131 ,0)
  20886    ;I CHBDFL G=0 K CHBD FLG G PSTA TE  ;TLH 7 /6/07 DEV0 00374
  20887   "RTN","CHM FA01E",132 ,0)
  20888    ;S CHTMPS T=$P(Y,"^" ,2)            ;DEV 7 991a DRW -  CHTMPST c ontains th e state na me
  20889   "RTN","CHM FA01E",133 ,0)
  20890    ;S CHSTAT E=$P(Y,"^" ,1)            ;DEV 7 991a DRW -  CHSTATE c ontains th e numeric  country co de
  20891   "RTN","CHM FA01E",134 ,0)
  20892    ;S DX=26, DY=9,$Y=DY ,$X=DX X X Y W CHTMPS T
  20893   "RTN","CHM FA01E",135 ,0)
  20894    ;D:$D(CHC LRFG) REPN T
  20895   "RTN","CHM FA01E",136 ,0)
  20896    G TID
  20897   "RTN","CHM FA01E",137 ,0)
  20898   END ;END
  20899   "RTN","CHM FA01E",138 ,0)
  20900    Q
  20901   "RTN","CHM FA01E",139 ,0)
  20902   REPNT  ;RE PNT
  20903   "RTN","CHM FA01E",140 ,0)
  20904    D CLEAR,D ISP^CHMFA0 13,DATA^CH MFA013 K C HCLRFG Q
  20905   "RTN","CHM FA01E",141 ,0)
  20906   GET    ;GE T
  20907   "RTN","CHM FA01E",142 ,0)
  20908    S ZPSN=""  Q:'$D(^CH MVEN(VFN,0 ))  S X=^C HMVEN(VFN, 0)
  20909   "RTN","CHM FA01E",143 ,0)
  20910    S X2="" S :$D(^CHMVE N(VFN,1))  X1=^(1)
  20911   "RTN","CHM FA01E",144 ,0)
  20912    S:$D(^CHM VEN(VFN,2) ) X2=^(2)
  20913   "RTN","CHM FA01E",145 ,0)
  20914    S ZPSN=$P (X2,"^",8) _"^"_$P(X, "^",3)_"^" _$P(X1,"^" ,1)_"^"_$P (X1,"^",2) _"^"_$P(X1 ,"^",3)_"^ "_$P(X1,"^ ",4)_"^"_$ P(X1,"^",5 )_"^"_VFN_ "^"_"B"
  20915   "RTN","CHM FA01E",146 ,0)
  20916    Q
  20917   "RTN","CHM FA01E",147 ,0)
  20918   QUES   ;DI SPLAYED WH EN ?
  20919   "RTN","CHM FA01E",148 ,0)
  20920    S HY=DY,H X=DX D CLE AR S DY=12 ,DX=1,$Y=D Y,$X=DX X  XY G @QU
  20921   "RTN","CHM FA01E",149 ,0)
  20922   90 W !!,?2 1,"   Ente r Tax ID a nd Vendor  Address co de.  " G E XIT
  20923   "RTN","CHM FA01E",150 ,0)
  20924   91 W !!,?2 1,"Enter t he NPI-Nat ional Prov ider Ident ifier" G E XIT     ;D EV007991 1 0/08/2010  JAK
  20925   "RTN","CHM FA01E",151 ,0)
  20926   92 W !!,?2 1,"        Enter prov ider remit -to name.       " G E XIT
  20927   "RTN","CHM FA01E",152 ,0)
  20928   93 W !!,?2 1,"    Ent er provide r remit-to  zip code.      " G E XIT     ;D EV007991 1 0/08/2010  JAK
  20929   "RTN","CHM FA01E",153 ,0)
  20930   94 W !!,?2 1,"Enter p rovider ph ysical loc ation zip  code." G E XIT
  20931   "RTN","CHM FA01E",154 ,0)
  20932   95 W !!,?2 1," Enter  provider p hysical lo cation sta te.  " G E XIT     ;D EV007991 1 0/08/2010  JAK
  20933   "RTN","CHM FA01E",155 ,0)
  20934   EXIT   ;EX IT
  20935   "RTN","CHM FA01E",156 ,0)
  20936    S DY=HY,D X=HX,$Y=DY ,$X=DX Q
  20937   "RTN","CHM FA01E",157 ,0)
  20938   CLEAR  ;CL EAR
  20939   "RTN","CHM FA01E",158 ,0)
  20940    S ZY=DY,Z X=DX F DY= 12:1:20 S  DX=1,$X=DX  X XY W @C HEOL
  20941   "RTN","CHM FA01E",159 ,0)
  20942    S DY=ZY,D X=ZX,$Y=DY ,$X=DX X X Y S CHCLRF G=1 Q
  20943   "RTN","CHM FA01E",160 ,0)
  20944   CSBRS  ;CS BRS
  20945   "RTN","CHM FA01E",161 ,0)
  20946    S Y="" S: '$D(FLD) F LD=30 S:FL D="" FLD=3 0 U $I X ^ %ZOSF("EOF F") K TL
  20947   "RTN","CHM FA01E",162 ,0)
  20948    F I=1:1:F LD S:I=31  TL=1 R *X: $S($D(DTIM E):DTIME,1 :60) Q:(X= 13)!(X=9)! (X=27)  S: X'=127 Y=Y _$C(X) D:X =127  S:I= 0 Y="" W $ C(X)
  20949   "RTN","CHM FA01E",163 ,0)
  20950    .S:I=1 I= 0 Q:I=0  S :I'=1 I=I- 2,Y=$E(Y,1 ,I) W *8,* 27,"[1X" Q
  20951   "RTN","CHM FA01E",164 ,0)
  20952   CSBRS1 ;CS BRS1
  20953   "RTN","CHM FA01E",165 ,0)
  20954    K DFOUT,D UOUT,DQOUT ,DDOUT,D1O UT,D2OUT,D 3OUT,D4OUT ,DTOUT,DPO UT,DNOUT
  20955   "RTN","CHM FA01E",166 ,0)
  20956    I X=27 F  I=1:1:2 R  *X D:I=2
  20957   "RTN","CHM FA01E",167 ,0)
  20958    .S:X=65 D 1OUT="" S: X=66 D2OUT ="" S:X=67  D3OUT=""  S:X=68 D4O UT=""
  20959   "RTN","CHM FA01E",168 ,0)
  20960    .I (X=54)  R *X S:X= 126 DNOUT= ""
  20961   "RTN","CHM FA01E",169 ,0)
  20962    .I (X=53)  R *X S:X= 126 DPOUT= ""
  20963   "RTN","CHM FA01E",170 ,0)
  20964    S:X=9 DDO UT="" S:X= 9 DTOUT=""  I Y="^^"  S (DFOUT,Y )=""
  20965   "RTN","CHM FA01E",171 ,0)
  20966    S:Y="^" ( DUOUT,Y)=" " S:Y?1"?" .E!(Y["^")  (DQOUT,Y) =""
  20967   "RTN","CHM FA01E",172 ,0)
  20968    U $I X ^% ZOSF("EON" ) Q
  20969   "RTN","CHM FA01E",173 ,0)
  20970   ERR837()   ;CPE001-01 5,CPE001-0 16 1/22/20 18 TGH - P rint Popou t Question  and recei ve reply f or Tax ID
  20971   "RTN","CHM FA01E",174 ,0)
  20972    N OK,ANS
  20973   "RTN","CHM FA01E",175 ,0)
  20974    S OK=0
  20975   "RTN","CHM FA01E",176 ,0)
  20976    F  D ERRT XT Q:OK
  20977   "RTN","CHM FA01E",177 ,0)
  20978    Q ANS
  20979   "RTN","CHM FA01E",178 ,0)
  20980   ERRTXT   ; CPE001-015 ,CPE001-01 6 1/22/201 8 TGH - Pr int Popout  Question  and receiv e reply fo r Tax ID
  20981   "RTN","CHM FA01E",179 ,0)
  20982    D CLEAR S  DY=13,DX= 1,$Y=DY,$X =DX X XY
  20983   "RTN","CHM FA01E",180 ,0)
  20984    W "The Ta x ID enter ed does no t match th e TIN in t he EDI sub mission. "
  20985   "RTN","CHM FA01E",181 ,0)
  20986    W !,"             Do  you wish  to continu e? (Y/N) "
  20987   "RTN","CHM FA01E",182 ,0)
  20988    D CSBRS^C HSC2 S ANS =Y S:ANS=" " ANS=" "  D
  20989   "RTN","CHM FA01E",183 ,0)
  20990    . I $E($T R(ANS,"yes ","YES"),1 ,$L(ANS))= $E("YES",1 ,$L(ANS))  S ANS=1,OK =1 Q
  20991   "RTN","CHM FA01E",184 ,0)
  20992    . I $E($T R(ANS,"no" ,"NO"),1,$ L(ANS))=$E ("NO",1,$L (ANS)) S A NS=0,OK=1  Q
  20993   "RTN","CHM FA01E",185 ,0)
  20994    . I $D(DT OUT) S ANS ="",OK=1 Q
  20995   "RTN","CHM FA01E",186 ,0)
  20996    . W !,"          Ple ase enter  Y or N to  continue.  " H 3 Q
  20997   "RTN","CHM FA01E",187 ,0)
  20998    Q
  20999   "RTN","CHM FA01F")
  21000   0^53^B1150 6960
  21001   "RTN","CHM FA01F",1,0 )
  21002   CHMFA01F ; CHV/JLR;IP  VENDOR LO OKUP PROGR AM;Feb 06,  2019@10:1 3:36
  21003   "RTN","CHM FA01F",2,0 )
  21004    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  21005   "RTN","CHM FA01F",3,0 )
  21006    ;DEV00799 1 10/08/20 10 JAK -VE NDOR LOOKU P utilizin g NPI
  21007   "RTN","CHM FA01F",4,0 )
  21008    ;HM 06/30 /17 CPE001 -001-T3-52 2242 Modif y code to  use vendor  result if  only one  is returne d.
  21009   "RTN","CHM FA01F",5,0 )
  21010   LOOKUP NEW  CHFUNC,CH FLD,DTM,DB M,SCRLEN,D X,DY,CHPOS
  21011   "RTN","CHM FA01F",6,0 )
  21012    K CHPI
  21013   "RTN","CHM FA01F",7,0 )
  21014    S CHFUNC= "VLKUP"
  21015   "RTN","CHM FA01F",8,0 )
  21016    S DTM=SCR LTOP+2
  21017   "RTN","CHM FA01F",9,0 )
  21018    S DBM=SCR LBOT
  21019   "RTN","CHM FA01F",10, 0)
  21020    S SCRLEN= DBM-DTM
  21021   "RTN","CHM FA01F",11, 0)
  21022    ;
  21023   "RTN","CHM FA01F",12, 0)
  21024    K ^UTILIT Y($J,"VLUL IST")
  21025   "RTN","CHM FA01F",13, 0)
  21026    K ^UTILIT Y($J,"VLKU P")
  21027   "RTN","CHM FA01F",14, 0)
  21028    S CHVDONE =0
  21029   "RTN","CHM FA01F",15, 0)
  21030    S CHFVPTR =0
  21031   "RTN","CHM FA01F",16, 0)
  21032    ;
  21033   "RTN","CHM FA01F",17, 0)
  21034    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  21035   "RTN","CHM FA01F",18, 0)
  21036    S CHFLAG= 0
  21037   "RTN","CHM FA01F",19, 0)
  21038    S LLEN=0
  21039   "RTN","CHM FA01F",20, 0)
  21040    S CHXACT= "",CHXIM=" "
  21041   "RTN","CHM FA01F",21, 0)
  21042    I CHXTID' ="" D LU1^ CHGVQ529 ; G LU2
  21043   "RTN","CHM FA01F",22, 0)
  21044    I CHXNPI' ="" D NPI^ CHGVQ529 ; G LU2 ;DEV 007991 10/ 08/2010 JA K -VENDOR  LOOKUP uti lizing NPI  replaced  physical l ocation na me
  21045   "RTN","CHM FA01F",23, 0)
  21046    I CHXPRN' ="" D LOOK 2^CHGVQ529  ;G LU2
  21047   "RTN","CHM FA01F",24, 0)
  21048    D ADDLIST ^CHGVQ529
  21049   "RTN","CHM FA01F",25, 0)
  21050    I CLLEN>1  D
  21051   "RTN","CHM FA01F",26, 0)
  21052    .I VFN=""  S VFN=CHL
  21053   "RTN","CHM FA01F",27, 0)
  21054    .G LU2
  21055   "RTN","CHM FA01F",28, 0)
  21056    I CLLEN=1  D
  21057   "RTN","CHM FA01F",29, 0)
  21058    .I VFN=""  S VFN=$P( ^UTILITY($ J,"VLULIST ",1),"^"), CHTVPTR=VF N,CHL=VFN
  21059   "RTN","CHM FA01F",30, 0)
  21060    .D DISP^C HMFA010,DI SP^CHMFA01 3,DATA^CHM FA013 K CH CLRFG
  21061   "RTN","CHM FA01F",31, 0)
  21062    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  21063   "RTN","CHM FA01F",32, 0)
  21064    Q
  21065   "RTN","CHM FA01F",33, 0)
  21066    ;
  21067   "RTN","CHM FA01F",34, 0)
  21068   LU2 K CHLV AR,CHXTID, CHTIN,CHXN PI,CHXPRN, CHXIM,CHXP I,CHXACT,C HXSTATE,CH XZIP,CHXRZ IP     ;DE V007991 10 /08/2010 J AK
  21069   "RTN","CHM FA01F",35, 0)
  21070    I LLEN=0  D  G END1
  21071   "RTN","CHM FA01F",36, 0)
  21072    .S:$D(^UT ILITY($J," VLULIST"))  CHFVPTR=$ P(^UTILITY ($J,"VLULI ST",LLEN), U,1)
  21073   "RTN","CHM FA01F",37, 0)
  21074    I LLEN=0  S CHFVPTR= "" G END1
  21075   "RTN","CHM FA01F",38, 0)
  21076    S DX=0,$X =DX F XIX= SCRLTOP-1: 1:SCRLBOT  S DY=XIX,$ Y=DY,$X=DX  X XY W @C HEOL
  21077   "RTN","CHM FA01F",39, 0)
  21078    D SCSET^C HGVQ529 ;S ET UP SCRE EN PARAMET ERS
  21079   "RTN","CHM FA01F",40, 0)
  21080    D GLOBSET ^CHGVQ374  ;SET UP SC REEN GLOBA L
  21081   "RTN","CHM FA01F",41, 0)
  21082    D RDCHSCR
  21083   "RTN","CHM FA01F",42, 0)
  21084    K ^UTILIT Y($J,CHFUN C,CHZONE," CHFLD")
  21085   "RTN","CHM FA01F",43, 0)
  21086    S CHFLD=" " D SETFLD ^CHSCH2(CH FUNC,CHZON E,.CHFLD)
  21087   "RTN","CHM FA01F",44, 0)
  21088    ;
  21089   "RTN","CHM FA01F",45, 0)
  21090    ;******** DISPLAY SC REEN GLOBA L********* ********** ********** ********** **
  21091   "RTN","CHM FA01F",46, 0)
  21092    ;
  21093   "RTN","CHM FA01F",47, 0)
  21094    S DTM=6,D BM=22,SRCL TOP=5,SCRL BOT=21   ; SKD
  21095   "RTN","CHM FA01F",48, 0)
  21096    D SHOW^CH SCH2(CHFUN C,CHZONE,D TM,DBM)
  21097   "RTN","CHM FA01F",49, 0)
  21098    I $P(^UTI LITY($J,"C HSCRN",CHF UNC,CHZONE ,"LAST"),U ,1)<DSPLEN  S DBM=DTM -1+$P(^UTI LITY($J,"C HSCRN",CHF UNC,CHZONE ,"LAST"),U ,1)
  21099   "RTN","CHM FA01F",50, 0)
  21100    ;
  21101   "RTN","CHM FA01F",51, 0)
  21102    S DX=0,DY =SCRLTOP+1 ,$Y=DY,$X= DX
  21103   "RTN","CHM FA01F",52, 0)
  21104    D EN1^CHG VQ372 ;EDI T
  21105   "RTN","CHM FA01F",53, 0)
  21106    D SCSET^C HGVQ529
  21107   "RTN","CHM FA01F",54, 0)
  21108    ;RETURN P OINTER ...
  21109   "RTN","CHM FA01F",55, 0)
  21110    I CHFVPTR  D
  21111   "RTN","CHM FA01F",56, 0)
  21112    .Q:'$D(^C HMVEN(CHFV PTR,0))  S  REC0=^CHM VEN(CHFVPT R,0)
  21113   "RTN","CHM FA01F",57, 0)
  21114    .S:$D(^CH MVEN(CHFVP TR,1)) REC 1=^CHMVEN( CHFVPTR,1)
  21115   "RTN","CHM FA01F",58, 0)
  21116    .S ZPSN=$ P(REC0,U,1 )_"^"_$P(R EC0,U,3)_" ^"_$P(REC1 ,U,1)_"^"_ $P(REC1,U, 2)_"^"_$P( REC1,U,3)_ "^"_$P(REC 1,U,4)_"^" _$P(REC1,U ,5)_"^"_CH FVPTR_"^"_ "B"
  21117   "RTN","CHM FA01F",59, 0)
  21118    .S $P(ZIC N,U,3)=CHF VPTR
  21119   "RTN","CHM FA01F",60, 0)
  21120    .S ^DISV( DUZ,"VENDO R","VLU1") =CHFVPTR
  21121   "RTN","CHM FA01F",61, 0)
  21122    .I VFN'=C HFVPTR S V FN=CHFVPTR  D DISP^CH MFA010,DIS P^CHMFA013 ,DATA^CHMF A013 K CHC LRFG  ;HM  1/29/2018  ADDED LINE  WHEN MULI TPLE VENDO R SELECTIO N NOT DISP LAYING COR RECTLY
  21123   "RTN","CHM FA01F",62, 0)
  21124    ;
  21125   "RTN","CHM FA01F",63, 0)
  21126   END1 ;
  21127   "RTN","CHM FA01F",64, 0)
  21128    S DX=0,$X =DX F DY=S CRLTOP-1:1 :SCRLBOT X  XY W @CHE OL
  21129   "RTN","CHM FA01F",65, 0)
  21130    K ^UTILIT Y($J,"VLUL IST"),CHFI OUT,CHLUOU T Q
  21131   "RTN","CHM FA01F",66, 0)
  21132    ;
  21133   "RTN","CHM FA01F",67, 0)
  21134   END Q
  21135   "RTN","CHM FA01F",68, 0)
  21136    ;
  21137   "RTN","CHM FA01F",69, 0)
  21138    ;  SUBROU TINES
  21139   "RTN","CHM FA01F",70, 0)
  21140    ;
  21141   "RTN","CHM FA01F",71, 0)
  21142   RDCHSCR S  CHRDCNT=0, CHRDPTR=0
  21143   "RTN","CHM FA01F",72, 0)
  21144   RD1 S CHRD PTR=$O(^UT ILITY($J,C HFUNC,CHZO NE,CHRDPTR )) Q:'CHRD PTR
  21145   "RTN","CHM FA01F",73, 0)
  21146    S CHRDCNT =CHRDCNT+1
  21147   "RTN","CHM FA01F",74, 0)
  21148    S ^UTILIT Y($J,"CHSC RN",CHFUNC ,CHZONE,CH RDCNT)=CHR DPTR
  21149   "RTN","CHM FA01F",75, 0)
  21150    G RD1
  21151   "RTN","CHM FA01F",76, 0)
  21152    ;
  21153   "RTN","CHM FA020")
  21154   0^43^B4691 3361
  21155   "RTN","CHM FA020",1,0 )
  21156   CHMFA020 ; JLR/DEN;EN TRY OF BEN E SCREEN;F eb 06, 201 9@10:14:38
  21157   "RTN","CHM FA020",2,0 )
  21158    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  21159   "RTN","CHM FA020",3,0 )
  21160    ;;JEH 2/1 /11 DEV007 820 - SLLA
  21161   "RTN","CHM FA020",4,0 )
  21162    ;;CFS 01/ 10/18 CPE0 05-122 and  123 - Do  not allow  Bene chang es on an E DI Reopen.
  21163   "RTN","CHM FA020",5,0 )
  21164    D CLEAR1
  21165   "RTN","CHM FA020",6,0 )
  21166    S CHTITLE ="BENEFICI ARY ID SCR EEN",CHSCR EEN=0
  21167   "RTN","CHM FA020",7,0 )
  21168    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN)) I ' CHSCREEN   G END
  21169   "RTN","CHM FA020",8,0 )
  21170    S (OHICOM M,OHISTDT1 ,OHISTDT2, OHIEDDT1,O HIEDDT2,OH ICODE,OHII ND,OHINAME )=""
  21171   "RTN","CHM FA020",9,0 )
  21172    K CNTRY,C HADDFG
  21173   "RTN","CHM FA020",10, 0)
  21174    I $D(^CHM IMG(CHMFPD I,"TRACK") ) D
  21175   "RTN","CHM FA020",11, 0)
  21176    .S DFN=$P (^("TRACK" ),"^",1),B FN=$P(^("T RACK"),"^" ,2)
  21177   "RTN","CHM FA020",12, 0)
  21178    .Q:DFN=""   Q:BFN=""
  21179   "RTN","CHM FA020",13, 0)
  21180    .S CHDTA= $P(^AHCHVA (DFN,100,B FN,0),"^", 1),DY=5,DX =19,$X=DX, $Y=DY X XY
  21181   "RTN","CHM FA020",14, 0)
  21182    .W CHDTA  S CHBENNM= CHDTA D DA TA Q
  21183   "RTN","CHM FA020",15, 0)
  21184    D TITLE^C HMFA100,CH OICE^CHMFA 100,LINE^C HMFA100,^C HMFA022
  21185   "RTN","CHM FA020",16, 0)
  21186    D DISP^CH MFA022,ERR ORS^CHMFA1 00
  21187   "RTN","CHM FA020",17, 0)
  21188    S:'$D(CHB ENNM) CHBE NNM="" S B LNK1="                      "
  21189   "RTN","CHM FA020",18, 0)
  21190    S DY=12,D X=1,$X=DX, $Y=DY X XY  S DY=8,DX =1,$X=DX,$ Y=DY X XY  F LN=1:1:8 0 W "-"
  21191   "RTN","CHM FA020",19, 0)
  21192   A0 S DY=5, DX=3,$X=DX ,$Y=DY X X Y W @CHBON ,"Benefici ary ID: "
  21193   "RTN","CHM FA020",20, 0)
  21194    S DX=43,$ X=DX X XY  W "Sponsor  ID: ",@CH BOFF
  21195   "RTN","CHM FA020",21, 0)
  21196   A1 K CHSPO N,CHBEN S  QU=1,DY=5, DX=19,$X=D X,$Y=DY X  XY W BLNK1  X XY
  21197   "RTN","CHM FA020",22, 0)
  21198    I CHMFPGN M'=1!($G(C HOSEN)=6)! ($G(CHOSEN )=7)!($G(C HOSEN)=8)  G SELECT    ;JEH 2/1/ 11 DEV0078 20  1-EDI   PREVENTS  BENE CHANG E WHEN EDI  - CPE005- 122
  21199   "RTN","CHM FA020",23, 0)
  21200    X XY W $E (CHBENNM,1 ,20) X XY  D CSBRS^CH SC2 I $D(D QOUT) D HE LP G A1
  21201   "RTN","CHM FA020",24, 0)
  21202    G:$D(DUOU T) A1 G:$D (DFOUT) A1  G:$D(DDOU T) SELECT
  21203   "RTN","CHM FA020",25, 0)
  21204    I Y=" ",' $D(^DISV(D UZ,"^AHCHV A(","BENE" )) W *7 G  A1
  21205   "RTN","CHM FA020",26, 0)
  21206    I Y=" " D    G A11
  21207   "RTN","CHM FA020",27, 0)
  21208    .S DFN=$P (^DISV(DUZ ,"^AHCHVA( ","BENE"), "^",1)
  21209   "RTN","CHM FA020",28, 0)
  21210    .S BFN=$P (^DISV(DUZ ,"^AHCHVA( ","BENE"), "^",2)
  21211   "RTN","CHM FA020",29, 0)
  21212    .S CHDTA= $P(^AHCHVA (DFN,100,B FN,0),"^", 1),DY=5,DX =19,$X=DX, $Y=DY X XY
  21213   "RTN","CHM FA020",30, 0)
  21214    .W CHDTA  S CHBENNM= CHDTA D DA TA Q
  21215   "RTN","CHM FA020",31, 0)
  21216    I Y="" X  XY W BLNK1  G A2
  21217   "RTN","CHM FA020",32, 0)
  21218    I $L(Y)<3  X XY S ZP SN="",CHBE N=1 D CHEC K G A1
  21219   "RTN","CHM FA020",33, 0)
  21220    S LEN=$L( Y) I $E(Y, LEN-1,LEN) ="  " S Y= $E(Y,1,LEN -2) G A10
  21221   "RTN","CHM FA020",34, 0)
  21222    I $E(Y,LE N)=" " S Y =$E(Y,1,LE N-1)
  21223   "RTN","CHM FA020",35, 0)
  21224   A10 S CHBE N=1 K CHSP ON K CHCLR FG D ^CHMF A021
  21225   "RTN","CHM FA020",36, 0)
  21226    I $D(CHCL RFG) D CLE AR,^CHMFA0 22,DISP^CH MFA022
  21227   "RTN","CHM FA020",37, 0)
  21228   A11 D CHEC K K CHMFPS BN,CHMFBDI S G A1
  21229   "RTN","CHM FA020",38, 0)
  21230   A2 S QU=2, DY=5,DX=55 ,$X=DX,$Y= DY X XY D  CSBRS^CHSC 2 W BLNK1  X XY I $D( DQOUT) D H ELP G A2
  21231   "RTN","CHM FA020",39, 0)
  21232    G:$D(DDOU T) SELECT
  21233   "RTN","CHM FA020",40, 0)
  21234    I Y=" ",' $D(^DISV(D UZ,"^AHCHV A(","BENE" )) W *7 G  A1
  21235   "RTN","CHM FA020",41, 0)
  21236    I Y=" " D   G A11
  21237   "RTN","CHM FA020",42, 0)
  21238    .S DFN=$P (^DISV(DUZ ,"^AHCHVA( ","BENE"), "^",1)
  21239   "RTN","CHM FA020",43, 0)
  21240    .S BFN=$P (^DISV(DUZ ,"^AHCHVA( ","BENE"), "^",2)
  21241   "RTN","CHM FA020",44, 0)
  21242    .S CHDTA= $P(^AHCHVA (DFN,100,B FN,0),"^", 1),DY=5,DX =19,$X=DX, $Y=DY X XY
  21243   "RTN","CHM FA020",45, 0)
  21244    .W CHDTA  S CHBENNM= CHDTA D DA TA Q
  21245   "RTN","CHM FA020",46, 0)
  21246    I Y="" X  XY W BLNK1  G A1
  21247   "RTN","CHM FA020",47, 0)
  21248    I $L(Y)<3  X XY S ZP SN="",CHSP ON=1 D CHE CK G A2
  21249   "RTN","CHM FA020",48, 0)
  21250    S LEN=$L( Y) I $E(Y, LEN-1,LEN) ="  " S Y= $E(Y,1,LEN -2) G A20
  21251   "RTN","CHM FA020",49, 0)
  21252    I $E(Y,LE N)=" " S Y =$E(Y,1,LE N-1)
  21253   "RTN","CHM FA020",50, 0)
  21254   A20 S CHSP ON=1 K CHB EN K CHCLR FG D ^CHMF A021 D CHE CK K CHMFP SBN,CHMFBD IS
  21255   "RTN","CHM FA020",51, 0)
  21256    I $D(CHCL RFG) D CLE AR,^CHMFA0 22,DISP^CH MFA022
  21257   "RTN","CHM FA020",52, 0)
  21258    S DY=5,DX =55,$X=DX, $Y=DY X XY  W BLNK1 G :$D(NOSPON ) A2 G A1
  21259   "RTN","CHM FA020",53, 0)
  21260   END D CLEA R1,BENE^CH MFA100
  21261   "RTN","CHM FA020",54, 0)
  21262    I $D(DFN)  I $D(BFN)  I DFN'=""  I BFN'=""  D
  21263   "RTN","CHM FA020",55, 0)
  21264    .S ^DISV( DUZ,"^AHCH VA(","BENE ")=DFN_"^" _BFN
  21265   "RTN","CHM FA020",56, 0)
  21266    .I $D(HLD OHI1) S:HL DOHI1'=""  $P(^CHMIMA GE(CHMFPDI ,"OHI",DFN ,BFN),"^", 3)=OHICODE ,TOCIPE=OH ICODE   ;J EH TT00782 0 ADDED TO CIPE
  21267   "RTN","CHM FA020",57, 0)
  21268    .I $D(HLD OHI2) S:HL DOHI2'=""  $P(^CHMIMA GE(CHMFPDI ,"OHI",DFN ,BFN),"^", 1)=OHISTDT 1
  21269   "RTN","CHM FA020",58, 0)
  21270    .I $D(HLD OHI3) S:HL DOHI3'=""  $P(^CHMIMA GE(CHMFPDI ,"OHI",DFN ,BFN),"^", 2)=OHIEDDT 1
  21271   "RTN","CHM FA020",59, 0)
  21272    .I $D(HLD OHI4) S:HL DOHI4'=""  $P(^CHMIMA GE(CHMFPDI ,"OHI",DFN ,BFN),"^", 4)=OHINAME
  21273   "RTN","CHM FA020",60, 0)
  21274    .S ^CHMIM AGE(CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,10)=DF N_"^"_BFN_ "^"_$E(OHI IND,1)
  21275   "RTN","CHM FA020",61, 0)
  21276    .S REC0=" ",REC1=""
  21277   "RTN","CHM FA020",62, 0)
  21278    .S:$D(^AH CHVA(DFN,1 00,BFN,0))  REC0=^AHC HVA(DFN,10 0,BFN,0)
  21279   "RTN","CHM FA020",63, 0)
  21280    .S:$D(^AH CHVA(DFN,1 00,BFN,1))  REC1=^AHC HVA(DFN,10 0,BFN,1)
  21281   "RTN","CHM FA020",64, 0)
  21282    .S A1=$P( REC0,"^",1 )_"^"_$P(R EC0,"^",9) _"^"_$P(RE C0,"^",3)_ "^"_$P(REC 0,"^",4)
  21283   "RTN","CHM FA020",65, 0)
  21284    .S A2=$P( REC1,"^",1 )_"^"_$P(R EC1,"^",2) _"^"_$P(RE C1,"^",3)_ "^"_$P(REC 1,"^",4)_" ^"_$P(REC1 ,"^",5)
  21285   "RTN","CHM FA020",66, 0)
  21286    .S ^CHMIM AGE(CHMFPD I,"BEN-II" ,DFN,BFN)= A1_"^"_A2  D BUPDT  ; AEB 12/27/ 2007 DEV00 3962
  21287   "RTN","CHM FA020",67, 0)
  21288    I $D(CHMF PSBN) S DF N="",BFN=" " D ^CHMFA 025,^CHMFA 026 G K1
  21289   "RTN","CHM FA020",68, 0)
  21290    D:$D(CHMF BDIS) ^CHM FA027
  21291   "RTN","CHM FA020",69, 0)
  21292   K1 K BLNK1 ,CHSCREEN, CHTITLE,D1 OUT,D2OUT, DDOUT,DUOU T,DFOUT,DQ OUT,LN,ZPS N,ZX
  21293   "RTN","CHM FA020",70, 0)
  21294    K ZY,Y,X, QU,ZPSTOT, ZPSCA,ZPSC T,ZPSDES,Z Y,ZX,ZPSNM ,ZPSN,ZPSJ ,ZPSI,ZOUT
  21295   "RTN","CHM FA020",71, 0)
  21296    K ZPS,ZPS 1,ZNO,ZNS, ZI,ZC,Y,X, ZZ,BLNK,RE C,REC1,REC 0,SSN,ST,X ,Y,DIC,PT
  21297   "RTN","CHM FA020",72, 0)
  21298    K TL,REL, I,CHK,N,CH BAD,CHCORD T,CDFN,CHC ORRI,CHCOR TY,CHMFPP, CBFN,CBN
  21299   "RTN","CHM FA020",73, 0)
  21300    K CADD2,C ADD1,AREC1 ,CVFN,CZIP ,DA,DLAYGO ,DR,CHMFBD IS,HLDOHI1 ,HLDOHI2
  21301   "RTN","CHM FA020",74, 0)
  21302    K OHICOMM ,OHISTDT1, OHISTDT2,O HIEDDT1,OH IEDDT2,OHI CODE,CC,HL DOHI3,HLDO HI4
  21303   "RTN","CHM FA020",75, 0)
  21304    Q
  21305   "RTN","CHM FA020",76, 0)
  21306   DATA S ZPS N="" Q:DFN =""  Q:BFN =""
  21307   "RTN","CHM FA020",77, 0)
  21308    S $P(ZPSN ,"^",1)=$P (^AHCHVA(D FN,0),"^", 1)
  21309   "RTN","CHM FA020",78, 0)
  21310    S $P(ZPSN ,"^",2)=$P (^AHCHVA(D FN,0),"^", 7)
  21311   "RTN","CHM FA020",79, 0)
  21312    S $P(ZPSN ,"^",3)=$P (^AHCHVA(D FN,100,BFN ,0),"^",1)
  21313   "RTN","CHM FA020",80, 0)
  21314    S $P(ZPSN ,"^",4)=$P (^AHCHVA(D FN,100,BFN ,0),"^",9)
  21315   "RTN","CHM FA020",81, 0)
  21316    S:$D(^AHC HVA(DFN,10 0,BFN,5))  $P(ZPSN,"^ ",5)=$P(^( 5),"^",1)
  21317   "RTN","CHM FA020",82, 0)
  21318    S $P(ZPSN ,"^",6)=DF N,$P(ZPSN, "^",7)=BFN ,$P(ZPSN," ^",8)="B"  Q
  21319   "RTN","CHM FA020",83, 0)
  21320   CHECK K:'$ D(DFN) NOB EN  I ZPSN ="" D NOBE N Q
  21321   "RTN","CHM FA020",84, 0)
  21322    K NOSPON, CHMBEN D ^ CHMFA022 I  $D(DFN) I  $P(ZPSN," ^",6)'=DFN  K CHMBEN
  21323   "RTN","CHM FA020",85, 0)
  21324    I $D(BFN)  I $P(ZPSN ,"^",7)'=B FN K CHMBE N
  21325   "RTN","CHM FA020",86, 0)
  21326    S DFN=$P( ZPSN,"^",6 ),BFN=$P(Z PSN,"^",7)
  21327   "RTN","CHM FA020",87, 0)
  21328    D ^CHMFA0 22,DISP^CH MFA022,BEN E^CHMFA100
  21329   "RTN","CHM FA020",88, 0)
  21330    D ^CHMFA0 2E Q
  21331   "RTN","CHM FA020",89, 0)
  21332   NOBEN I $D (CHSPON) S  DY=5,DX=5 5,$X=DX,$Y =DY X XY W  BLNK1 X X Y W "         ??",*7  R X:2 X XY  W BLNK1 S  NOSPON=1  Q
  21333   "RTN","CHM FA020",90, 0)
  21334    I $D(CHBE N) S DY=5, DX=19,$X=D X,$Y=DY X  XY W BLNK1  X XY W "         ??" ,*7 R X:2  Q
  21335   "RTN","CHM FA020",91, 0)
  21336   HELP S ZY= DY,ZX=DX,D Y=7,DX=6,$ X=DX,$Y=DY  X XY W @C HEOL X XY  W @CHBON G  @QU
  21337   "RTN","CHM FA020",92, 0)
  21338   1 W "To id entify a b eneficiary  enter the  bene name , SSN or I D card num ber." G EX IT
  21339   "RTN","CHM FA020",93, 0)
  21340   2 W "To id entify a s ponsor ent er the spo nsor name,  SSN or fi le number. "
  21341   "RTN","CHM FA020",94, 0)
  21342   EXIT W @CH BOFF S DY= ZY,DX=ZX,$ X=DX,$Y=DY  X XY W BL NK1 X XY Q
  21343   "RTN","CHM FA020",95, 0)
  21344   CLEAR S ZY =DY,ZX=DX  F DY=9:1:2 0 S DX=1,$ X=DX,$Y=DY  X XY W @C HEEL
  21345   "RTN","CHM FA020",96, 0)
  21346    S DY=ZY,D X=ZX,$X=DX ,$Y=DY X X Y Q
  21347   "RTN","CHM FA020",97, 0)
  21348   CLEAR1 S D X=1,$X=DX  F DY=3:1:2 0 S DX=1,$ X=DX,$Y=DY  X XY W @C HEEL
  21349   "RTN","CHM FA020",98, 0)
  21350    Q
  21351   "RTN","CHM FA020",99, 0)
  21352   SELECT K C HMFKILL,CH MFNEXT,CHM FPREV,Y D  PRMPT^CHMF A100,ASK^C HMFA100
  21353   "RTN","CHM FA020",100 ,0)
  21354    G:Y=1 A1
  21355   "RTN","CHM FA020",101 ,0)
  21356    I Y=2 S C HMFNEXT=1  G END
  21357   "RTN","CHM FA020",102 ,0)
  21358    I Y=3 S C HMFPREV=1  G END
  21359   "RTN","CHM FA020",103 ,0)
  21360    I Y=4 S C HMFKILL=1  G END
  21361   "RTN","CHM FA020",104 ,0)
  21362    I Y=5 I $ D(CHADDFG)  D NODISC  G SELECT
  21363   "RTN","CHM FA020",105 ,0)
  21364    I Y=5 K N OGO D ^CHM FA023 G A1
  21365   "RTN","CHM FA020",106 ,0)
  21366    K CHMFPSB N I Y=6 D  ^CHMFA024  S CHMFPSBN =1 G A1
  21367   "RTN","CHM FA020",107 ,0)
  21368    I Y=7 D ^ CHMFA029,^ CHMFA022,D ISP^CHMFA0 22 G A1
  21369   "RTN","CHM FA020",108 ,0)
  21370    I Y=8 D ^ CHMFA02A D   D ^CHMFA 022,DISP^C HMFA022 G  A1
  21371   "RTN","CHM FA020",109 ,0)
  21372    .S CHTITL E="BENEFIC IARY ID SC REEN",CHSC REEN=0
  21373   "RTN","CHM FA020",110 ,0)
  21374    .S CHSCRE EN=$O(^CHM SCRN("B",C HTITLE,CHS CREEN))
  21375   "RTN","CHM FA020",111 ,0)
  21376    .D CHOICE ^CHMFA100, ERRORS^CHM FA100
  21377   "RTN","CHM FA020",112 ,0)
  21378    I Y=9 S N OGO=1 D DI SP^CHMFA02 8,^CHMFA02 8,DISP1^CH MFA028 G A 1
  21379   "RTN","CHM FA020",113 ,0)
  21380    I Y=10 D  ^CHMFA02D  G A1
  21381   "RTN","CHM FA020",114 ,0)
  21382    Q
  21383   "RTN","CHM FA020",115 ,0)
  21384   NODISC S D Y=22,DX=10 ,$X=DX,$Y= DY X XY
  21385   "RTN","CHM FA020",116 ,0)
  21386    W "Addres s flag has  been chan ged.  Disc repent Dat a not allo wed."
  21387   "RTN","CHM FA020",117 ,0)
  21388    R X:3 Q
  21389   "RTN","CHM FA020",118 ,0)
  21390   BUPDT  ;CH ANGE THE N ODES IN ^C HMIMAGE GL OBAL TO SH OW CURRENT  SELECTED  BENE
  21391   "RTN","CHM FA020",119 ,0)
  21392    ;AEB 1/3/ 2008  SUBT OUTINE ADD ED FOR DEV 003962
  21393   "RTN","CHM FA020",120 ,0)
  21394    ;Q:'CHMPF DI  ; QUIT  IF NO PDI  NUMBER
  21395   "RTN","CHM FA020",121 ,0)
  21396    Q:'CHMFPD I  ; QUIT  IF NO PDI  NUMBER ;sk d 1-2-08 c orrected t he about l ine
  21397   "RTN","CHM FA020",122 ,0)
  21398    S CHUPDTI =0
  21399   "RTN","CHM FA020",123 ,0)
  21400   UPDT1 S CH UPDTI=$O(^ CHMIMAGE(C HMFPDI,CHU PDTI)) Q:' CHUPDTI
  21401   "RTN","CHM FA020",124 ,0)
  21402    S CHUPDTJ =0
  21403   "RTN","CHM FA020",125 ,0)
  21404   UPDT2 S CH UPDTJ=$O(^ CHMIMAGE(C HMFPDI,CHU PDTI,1,CHU PDTJ)) G:' CHUPDTJ UP DT1
  21405   "RTN","CHM FA020",126 ,0)
  21406    S CHUPDTK =0
  21407   "RTN","CHM FA020",127 ,0)
  21408   UPDT3 S CH UPDTK=$O(^ CHMIMAGE(C HMFPDI,CHU PDTI,1,CHU PDTJ,CHUPD TK)) G:'CH UPDTK UPDT 2
  21409   "RTN","CHM FA020",128 ,0)
  21410    S CHUPDTL =""
  21411   "RTN","CHM FA020",129 ,0)
  21412   UPDT4 S CH UPDTL=$O(^ CHMIMAGE(C HMFPDI,CHU PDTI,1,CHU PDTJ,CHUPD TK,CHUPDTL )) G:CHUPD TL="" UPDT 3
  21413   "RTN","CHM FA020",130 ,0)
  21414    S CHUPDTG =0
  21415   "RTN","CHM FA020",131 ,0)
  21416   UPDT5 S CH UPDTG=$O(^ CHMIMAGE(C HMFPDI,CHU PDTI,1,CHU PDTJ,CHUPD TK,CHUPDTL ,CHUPDTG))  G:'CHUPDT G UPDT4
  21417   "RTN","CHM FA020",132 ,0)
  21418    G:'$D(^CH MIMAGE(CHM FPDI,CHUPD TI,1,CHUPD TJ,CHUPDTK ,CHUPDTL,C HUPDTG,0))  UPDT4
  21419   "RTN","CHM FA020",133 ,0)
  21420    I CHUPDTL ="INP-NS"  D  ;AEB 2/ 4/2008 DEV 004237
  21421   "RTN","CHM FA020",134 ,0)
  21422    .S $P(^CH MIMAGE(CHM FPDI,CHUPD TI,1,CHUPD TJ,CHUPDTK ,CHUPDTL,C HUPDTG,0), "^",1)=DFN   ;AEB 2/4 /2008 DEV0 04237
  21423   "RTN","CHM FA020",135 ,0)
  21424    .S $P(^CH MIMAGE(CHM FPDI,CHUPD TI,1,CHUPD TJ,CHUPDTK ,CHUPDTL,C HUPDTG,0), "^",2)=BFN   ;AEB 2/4 /2008 DEV0 04237
  21425   "RTN","CHM FA020",136 ,0)
  21426    .Q  ;AEB  2/4/2008 D EV004237
  21427   "RTN","CHM FA020",137 ,0)
  21428    I CHUPDTL ="OPT-NS"  D  ;AEB 2/ 4/2008 DEV 004237
  21429   "RTN","CHM FA020",138 ,0)
  21430    .S $P(^CH MIMAGE(CHM FPDI,CHUPD TI,1,CHUPD TJ,CHUPDTK ,CHUPDTL,C HUPDTG,0), "^",3)=DFN   ;AEB 2/4 /2008 DEV0 04237
  21431   "RTN","CHM FA020",139 ,0)
  21432    .S $P(^CH MIMAGE(CHM FPDI,CHUPD TI,1,CHUPD TJ,CHUPDTK ,CHUPDTL,C HUPDTG,0), "^",4)=BFN   ;AEB 2/4 /2008 DEV0 04237
  21433   "RTN","CHM FA020",140 ,0)
  21434    .Q
  21435   "RTN","CHM FA020",141 ,0)
  21436    G UPDT5
  21437   "RTN","CHM FA02E")
  21438   0^44^B1591 638
  21439   "RTN","CHM FA02E",1,0 )
  21440   CHMFA02E ; JLR/DEN;SE T HISTORY  ON BENE CH ANGES;Feb  06, 2019@1 0:15:51
  21441   "RTN","CHM FA02E",2,0 )
  21442    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  21443   "RTN","CHM FA02E",3,0 )
  21444    ;CFS 01/1 0/2018 CPE 005-122 an d 123 - Do  not allow  user to c hange Bene 's on a re open PDI.
  21445   "RTN","CHM FA02E",4,0 )
  21446    Q:'$D(DFN )  Q:'$D(B FN)  Q:DFN =""  Q:BFN =""  Q:'$D (CHMFPDI)   Q:CHMFPDI =""
  21447   "RTN","CHM FA02E",5,0 )
  21448    Q:'$D(^CH MIMG(CHMFP DI,"TRACK" ))
  21449   "RTN","CHM FA02E",6,0 )
  21450    S BDFN=$P (^CHMIMG(C HMFPDI,"TR ACK"),"^", 1)
  21451   "RTN","CHM FA02E",7,0 )
  21452    S BBFN=$P (^CHMIMG(C HMFPDI,"TR ACK"),"^", 2)
  21453   "RTN","CHM FA02E",8,0 )
  21454    I CHOSEN= 6!(CHOSEN= 7)!(CHOSEN =8) D  Q   ;CPE005-12 2
  21455   "RTN","CHM FA02E",9,0 )
  21456    .I BDFN'= DFN S DFN= BDFN
  21457   "RTN","CHM FA02E",10, 0)
  21458    .I BBFN'= BFN S BFN= BBFN
  21459   "RTN","CHM FA02E",11, 0)
  21460    .S NOMATC H=1
  21461   "RTN","CHM FA02E",12, 0)
  21462    I BDFN'=D FN D ROLL  G END
  21463   "RTN","CHM FA02E",13, 0)
  21464    I BBFN'=B FN D ROLL
  21465   "RTN","CHM FA02E",14, 0)
  21466   END Q
  21467   "RTN","CHM FA02E",15, 0)
  21468   ROLL S:'$D (^CHMIMG(C HMFPDI,"TR ACK-HIST", 0)) ^(0)=" ^741000.23 01P^0^0"
  21469   "RTN","CHM FA02E",16, 0)
  21470    L ^CHMIMG (CHMFPDI," TRACK-HIST ",0) S J=$ P(^(0),"^" ,3),J=J+1
  21471   "RTN","CHM FA02E",17, 0)
  21472    F X=3,4 S  $P(^CHMIM G(CHMFPDI, "TRACK-HIS T",0),"^", X)=J
  21473   "RTN","CHM FA02E",18, 0)
  21474    L  D NOW^ %DTC
  21475   "RTN","CHM FA02E",19, 0)
  21476    S ^CHMIMG (CHMFPDI," TRACK-HIST ",J,0)=BDF N_"^"_BBFN _"^^^"_DUZ _"^"_%
  21477   "RTN","CHM FA02E",20, 0)
  21478    S $P(^CHM IMG(CHMFPD I,"TRACK") ,"^",1)=DF N
  21479   "RTN","CHM FA02E",21, 0)
  21480    S $P(^CHM IMG(CHMFPD I,"TRACK") ,"^",2)=BF N Q
  21481   "RTN","CHM FA110")
  21482   0^45^B2404 8241
  21483   "RTN","CHM FA110",1,0 )
  21484   CHMFA110 ; JLR/DEN;IN PATIENT E/ E DRIVER;F eb 06, 201 9@10:16:26
  21485   "RTN","CHM FA110",2,0 )
  21486    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  21487   "RTN","CHM FA110",3,0 )
  21488    ;DEV00480 5 1/20/201 0 AEB
  21489   "RTN","CHM FA110",4,0 )
  21490    ;CCSE CPE 005-012 GE F 6/7/17 -  remove pr ess return  to contin ue prompt
  21491   "RTN","CHM FA110",5,0 )
  21492    S DF=0
  21493   "RTN","CHM FA110",6,0 )
  21494    K CHMFQUI T,CHMFNEXT ,CHMFPREV, CHMFKILL,C HMFBENE,CH MFOTHR,CHM FITEM,FL
  21495   "RTN","CHM FA110",7,0 )
  21496    S CHMFADD A="",CHMFD SDT="" S:' $D(CHMFDAT E) CHMFDAT E=""
  21497   "RTN","CHM FA110",8,0 )
  21498   A1 D CLEAR  S DTM=17, DBM=20 X C HMAR
  21499   "RTN","CHM FA110",9,0 )
  21500    ;I $D(DFN ) I $D(BFN ) G A11
  21501   "RTN","CHM FA110",10, 0)
  21502    ;D ^CHMFA 020 G:$D(C HMFPSBN) E ND G:$D(CH MFKILL) EN D
  21503   "RTN","CHM FA110",11, 0)
  21504    ;G:$D(CHM FPREV) END  G:'$D(DFN ) A1
  21505   "RTN","CHM FA110",12, 0)
  21506    ;D ^CHMFA 101 G:$D(D FOUT) END  G:$D(DUOUT ) A1 G:$D( CHFIFLAG)  END
  21507   "RTN","CHM FA110",13, 0)
  21508   A11 S DX=1 ,$X=DX F D Y=6:1:20 S  $X=DX,$Y= DY X XY W  @CHEEL
  21509   "RTN","CHM FA110",14, 0)
  21510    S CHTITLE ="INPATIEN T E/E SCRE EN",CHSCRE EN=""
  21511   "RTN","CHM FA110",15, 0)
  21512    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN)) I ' CHSCREEN   G END
  21513   "RTN","CHM FA110",16, 0)
  21514    D TITLE^C HMFA100,LI NE^CHMFA10 0,CHOICE^C HMFA100,HE AD,ERRORS^ CHMFA100
  21515   "RTN","CHM FA110",17, 0)
  21516   A12 D ^CHM FA111
  21517   "RTN","CHM FA110",18, 0)
  21518    I $D(CHMF PREV) K CH MFINP(DFN, BFN) G END
  21519   "RTN","CHM FA110",19, 0)
  21520    I $D(CHMF KILL) K CH MFINP,DFN, BFN G END
  21521   "RTN","CHM FA110",20, 0)
  21522    D ^CHMFA1 14 G:CHMFA DDA="" A12  G:CHMFDSD T="" A12
  21523   "RTN","CHM FA110",21, 0)
  21524    I $D(CHMF OTHR) G:$D (CHMFELF1)  OTHER D W RGP1 G A12
  21525   "RTN","CHM FA110",22, 0)
  21526    I $D(CHMF ITEM) G:$D (CHMFELF2)  ITEM D WR GP2 G A12
  21527   "RTN","CHM FA110",23, 0)
  21528    I $D(CHMF DEL8) G A1    ;SKD, 6 -14-07, DE V000197
  21529   "RTN","CHM FA110",24, 0)
  21530    I $D(CHMF ELF2) I '$ D(CHMFINP( DFN,BFN,"I TEM")) D N OITM G A12
  21531   "RTN","CHM FA110",25, 0)
  21532    I $D(CHMF NEXT) I $D (^CHMDIC(7 41002.21,D UZ,0)) I ' $P(^(0),"^ ",14) D  I  '$D(CHMFN EXT) D CLE AR^CHMFA11 1 G A12
  21533   "RTN","CHM FA110",26, 0)
  21534   E2 .S HY=D Y,HX=DX,DY =19,DX=20, $X=DX,$Y=D Y X XY
  21535   "RTN","CHM FA110",27, 0)
  21536    .;CCSE CP E005-012 G EF 6/7/17  - remove p ress retur n to conti nue prompt
  21537   "RTN","CHM FA110",28, 0)
  21538    .;W "Are  you sure y ou want to  continue:  " D CSBRS ^CHSC2
  21539   "RTN","CHM FA110",29, 0)
  21540    .;I $D(DU OUT) K CHM FNEXT Q
  21541   "RTN","CHM FA110",30, 0)
  21542    .;I $D(DF OUT) K CHM FNEXT Q
  21543   "RTN","CHM FA110",31, 0)
  21544    .;G:Y=""  E2 S Y=$E( Y) G:"YNyn "'[Y E2
  21545   "RTN","CHM FA110",32, 0)
  21546    .;I "Nn"[ Y K CHMFNE XT
  21547   "RTN","CHM FA110",33, 0)
  21548    .S DY=HY, DX=HX,$X=D X,$Y=DY Q
  21549   "RTN","CHM FA110",34, 0)
  21550    I $D(CHMF NEXT) D ^C HMFA113 G  END
  21551   "RTN","CHM FA110",35, 0)
  21552    G END
  21553   "RTN","CHM FA110",36, 0)
  21554   OTHER D ^C HMFA123 D  CLEAR G A1 1
  21555   "RTN","CHM FA110",37, 0)
  21556    ;G:$D(CHM FNEXT) END
  21557   "RTN","CHM FA110",38, 0)
  21558    ;I $D(CHM FPREV)!$D( CHMFKILL)  D CLEAR G  A11
  21559   "RTN","CHM FA110",39, 0)
  21560    ;G END
  21561   "RTN","CHM FA110",40, 0)
  21562   ITEM D ^CH MFA125 D C LEAR G A11
  21563   "RTN","CHM FA110",41, 0)
  21564    ;G:$D(CHM FNEXT) END
  21565   "RTN","CHM FA110",42, 0)
  21566    ;I $D(CHM FPREV)!$D( CHMFKILL)  D CLEAR G  A11
  21567   "RTN","CHM FA110",43, 0)
  21568    ;G END
  21569   "RTN","CHM FA110",44, 0)
  21570   END K DF,C HMFADDA,CH MFDSDT,CHM FELF1,CHMF ELF2,CHMFI NP,CHMFITE M
  21571   "RTN","CHM FA110",45, 0)
  21572    K CHMFNOT ,CHMFTOHR, CHMFPSBN,C HMFQUIT,CH SCREEN,CHT ITLE
  21573   "RTN","CHM FA110",46, 0)
  21574    K DBM,DFO UT,DTM,DUO UT,DX,DY,L N,VL1,VL2, VL3,ANS,BL NK1,BLNK2, BLNK3
  21575   "RTN","CHM FA110",47, 0)
  21576    K CHCLRFG ,CHWINHR,C HWINLR,D1O UT,D2OUT,D QOUT,DD1OU T,DDOUT,DI SCD,DISFC
  21577   "RTN","CHM FA110",48, 0)
  21578    K DTOUT,F 1,FLD,HX,H Y,I,ICDCD, QU,TL,X,XX ,Y,YY,ZICN ,ZPSN,ZX,Z Y,CHMFDATE
  21579   "RTN","CHM FA110",49, 0)
  21580    K HNG,N,C HADDT,CHAD MDX,CHBNPA Y,CHDISDT, CHDISST,CH FACDS,CHFC DIS,CHMFIN P
  21581   "RTN","CHM FA110",50, 0)
  21582    K CHTOTCH ,HJ,HL,II, J,JJ,K,L,B D,CHMFELBD ,CHMFELDS, CHMFELED,C HMFNOT,PPS
  21583   "RTN","CHM FA110",51, 0)
  21584    K CHMFPPS ,ED,ELFL,I NFL,NVREL, D3OUT,D4OU T,DNOUT,DP OUT,ECT,HT M,MCT,NODW N
  21585   "RTN","CHM FA110",52, 0)
  21586    K NOUP,RE C,SC,SPC,T BM,CHCN,CT ,CHPHAMT,F LBLNK,AC,C HDAYS,CHMF DOS,CHNDCP T
  21587   "RTN","CHM FA110",53, 0)
  21588    K CHPHNDC ,CHUNITS,C HUNTAMT,PC HD,TYPE,ZZ ,HTYPE,PDA TE,ZICD9,Z ICCT,ZICTO T
  21589   "RTN","CHM FA110",54, 0)
  21590    K ZNO,ZIC 1,ZICA,ZIC ,ZI,ZC,ZNS ,ZOUT,ZICJ ,ZICCA,ZIC NM,ZLUFLG, CFL,HZIC,Z AC
  21591   "RTN","CHM FA110",55, 0)
  21592    K ZCH,CNO ,CD,ZHCNM, ZHCNMP,ZHC PC,ZHCTOT, ZMESAG,ZHC DES,ZHCJ,Z HCCT,ZHC1
  21593   "RTN","CHM FA110",56, 0)
  21594    K ZHC,ZPS ,ZPS1,ZPSA ,ZPSCA,ZPS CT,ZPSDES, ZPSJ,ZPSN, ZPSNM,ZPST OT
  21595   "RTN","CHM FA110",57, 0)
  21596    Q
  21597   "RTN","CHM FA110",58, 0)
  21598   WRGP1 I '$ D(CHMFNOT)  S DY=19,D X=17,$X=DX ,$Y=DY X X Y W "Enter  charges t hrough the  Itemizati on option. ",!?14,"Be neficiarie s's elgibi lity ended  during th e stay."
  21599   "RTN","CHM FA110",59, 0)
  21600    I $D(CHMF NOT) S DY= 19,DX=13,$ X=DX,$Y=DY  X XY W "E ntry of Ot her/Non-co vered char ges is not  necessary ." S DY=20 ,DX=12,$X= DX,$Y=DY X  XY W "Ben eficiary i s not elig ible durin g this len gth of sta y."
  21601   "RTN","CHM FA110",60, 0)
  21602    Q
  21603   "RTN","CHM FA110",61, 0)
  21604   WRGP2 I '$ D(CHMFNOT)  S DY=19,D X=15,$X=DX ,$Y=DY X X Y W "Enter  charges t hrough the  Other/Non -covered o ption.",!? 12,"Benefi ciaries's  elgibility  did not e nd during  the stay."
  21605   "RTN","CHM FA110",62, 0)
  21606    I $D(CHMF NOT) S DY= 19,DX=16,$ X=DX,$Y=DY  X XY W "E ntry of It emization  charges is  not neces sary." S D Y=20,DX=12 ,$X=DX,$Y= DY X XY W  "Beneficia ry is not  eligible d uring this  length of  stay."
  21607   "RTN","CHM FA110",63, 0)
  21608    Q
  21609   "RTN","CHM FA110",64, 0)
  21610   NOITM S DY =19,DX=15, $X=DX,$Y=D Y X XY
  21611   "RTN","CHM FA110",65, 0)
  21612    W "Itemiz ation is m andatory f or this in patient st ay." Q
  21613   "RTN","CHM FA110",66, 0)
  21614   EXIT D PRM PT^CHMFA10 0,ASK^CHMF A100
  21615   "RTN","CHM FA110",67, 0)
  21616   CLEAR S DX =1,$X=DX F  DY=3:1:20  S $X=DX,$ Y=DY X XY  W @CHEOL
  21617   "RTN","CHM FA110",68, 0)
  21618    Q
  21619   "RTN","CHM FA110",69, 0)
  21620   HEAD S DY= 4,DX=1,$X= DX,$Y=DY X  XY W @CHB ON,!,"Stmt  From: ",? 28,"Stmt T o: "
  21621   "RTN","CHM FA110",70, 0)
  21622    W ?53,"Ad m Date: "
  21623   "RTN","CHM FA110",71, 0)
  21624    W !?1,"Di s Stat: ", ?54,"Fac D is: "
  21625   "RTN","CHM FA110",72, 0)
  21626    W !?1,"Ad mit DX: ", ?53,"Tot C hgs: "
  21627   "RTN","CHM FA110",73, 0)
  21628    D CODES W  !!,"   DX /POA: ",VL 1  ;AEB 1/ 20/1020 DE V004805
  21629   "RTN","CHM FA110",74, 0)
  21630    W ?26,"Re v Codes: " ,VL4
  21631   "RTN","CHM FA110",75, 0)
  21632    W ?51,"Pr oc Codes:  ",VL2
  21633   "RTN","CHM FA110",76, 0)
  21634    S LN="" S  $P(LN,"-" ,81)="" S  DY=10,$X=D X,$Y=DY X  XY W LN
  21635   "RTN","CHM FA110",77, 0)
  21636    S LN="" S  $P(LN,"-" ,81)="" S  DY=16,$X=D X,$Y=DY X  XY W LN
  21637   "RTN","CHM FA110",78, 0)
  21638    W @CHBOFF  Q
  21639   "RTN","CHM FA110",79, 0)
  21640   CODES S (V L1,VL2,VL3 ,VL4)="No"  Q:'$D(CHM FINP(DFN,B FN,"INP"))
  21641   "RTN","CHM FA110",80, 0)
  21642    I $D(CHMF INP(DFN,BF N,"INP",7) ) S:CHMFIN P(DFN,BFN, "INP",7)=" Y" VL1="Ye s"
  21643   "RTN","CHM FA110",81, 0)
  21644    I $D(CHMF INP(DFN,BF N,"INP",8) ) S:CHMFIN P(DFN,BFN, "INP",8)=" Y" VL2="Ye s"
  21645   "RTN","CHM FA110",82, 0)
  21646    I $D(CHMF INP(DFN,BF N,"INP",9) ) S:CHMFIN P(DFN,BFN, "INP",9)=" Y" VL3="Ye s"
  21647   "RTN","CHM FA110",83, 0)
  21648    I $D(CHMF INP(DFN,BF N,"INP",10 )) S:CHMFI NP(DFN,BFN ,"INP",10) ="Y" VL4=" Yes"
  21649   "RTN","CHM FA110",84, 0)
  21650    Q
  21651   "RTN","CHM FA110",85, 0)
  21652    ;
  21653   "RTN","CHM FA141")
  21654   0^46^B1271 109246
  21655   "RTN","CHM FA141",1,0 )
  21656   CHMFA141   ;DEN/CJM;O UTPATIENT  ENTER/EDIT ;Feb 06, 2 019@10:16: 59
  21657   "RTN","CHM FA141",2,0 )
  21658    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  21659   "RTN","CHM FA141",3,0 )
  21660    ;;V2.0;;C HAMPVA SYS TEM;;JULY  21, 1999
  21661   "RTN","CHM FA141",4,0 )
  21662    ;PT 15932  (Y2K)
  21663   "RTN","CHM FA141",5,0 )
  21664    ;PT #1606 6* (RLC)
  21665   "RTN","CHM FA141",6,0 )
  21666    ;PLEASE N OTE, FIX M ADE SEPARA TELY IN DE V & TRN FO R #16066 A ND MOVED T O
  21667   "RTN","CHM FA141",7,0 )
  21668    ;LIVE FRO M THE TRAI N ACCOUNT  DUE TO Y2K  CHANGES I N DEV.
  21669   "RTN","CHM FA141",8,0 )
  21670    ;JEH 12/1 2/06 - MOD IFIED FOR  ANESHESIA  CODE RATES
  21671   "RTN","CHM FA141",9,0 )
  21672    ;JEH 7/18 /07 - DEV0 01373-01:  Anesthesia  minute ca lc
  21673   "RTN","CHM FA141",10, 0)
  21674    ;JEH 12/1 6/07 - DEV 003971-01  Subscript  error fix  - missing  ANCDI valu e
  21675   "RTN","CHM FA141",11, 0)
  21676    ;JSG;01/3 1/08;DEV00 3956-02;Ha ndle no DO S in the R EDISP sect ion of cod e
  21677   "RTN","CHM FA141",12, 0)
  21678    ;JSG;02/2 8/08;BUG00 3956-04;Un defined RO W at ENT1+ 25
  21679   "RTN","CHM FA141",13, 0)
  21680    ;JSG;02/2 9/08;BUG00 3956-04;Ha ndle down  arrow with  deleted r ecord
  21681   "RTN","CHM FA141",14, 0)
  21682    ;TT 00010 8 JEH 1/4/ 10 - SPLIT  TOS INCID ENTAL DRUG S
  21683   "RTN","CHM FA141",15, 0)
  21684    ;DRW/JAK  5/17/10;DE V007600 AS C Vendor a nd POS pop -up screen  requiring  ASC or OP  input, no  longer de fault to O P
  21685   "RTN","CHM FA141",16, 0)
  21686    ;JEH 2/1/ 11 DEV0078 20 - SLLA
  21687   "RTN","CHM FA141",17, 0)
  21688    ;DRW/JAK  09/30/11;  DEV010291  ASC POP MO DIFICATION
  21689   "RTN","CHM FA141",18, 0)
  21690    ;JEH 9/13 /13 - ENC0 04389 - PR EVENT 99XX X MULTIPLE  DOS DISCR EPANCIES
  21691   "RTN","CHM FA141",19, 0)
  21692    ;JEH 11/1 2/13 DEF01 9382 - ENT ER OHI TOT ALS BY DOS
  21693   "RTN","CHM FA141",20, 0)
  21694    ;DPT 2/24 /16 DEV241 94-02 - AD D 19 AS VA LID MODIFI Y ASC POP  UP
  21695   "RTN","CHM FA141",21, 0)
  21696    ;JEH 3/4/ 16 DEF0043 89 BUG FIX
  21697   "RTN","CHM FA141",22, 0)
  21698    ;CCSE CPE 005-012 GE F 6/7/17 -  remove pr ess return  to contin ue prompt
  21699   "RTN","CHM FA141",23, 0)
  21700    ;CPEE_ASC _Sprint 1  Task 70752 5 JEH 4/4/ 18
  21701   "RTN","CHM FA141",24, 0)
  21702    ;DEFECT 8 66501 - TG H - 8/19/2 018 - Defi ne HX and  HY for use  in displa y below
  21703   "RTN","CHM FA141",25, 0)
  21704    ;DEFECT 8 66501 - TG H - 8/19/2 018 - Also  repaired  two syntax  errors du ring compi le
  21705   "RTN","CHM FA141",26, 0)
  21706    ;DEFECT 8 66501 - TG H - 8/19/2 018 - Make  Popup ite m readable  by moving  part of l ine up to  first line
  21707   "RTN","CHM FA141",27, 0)
  21708   MAIN ;
  21709   "RTN","CHM FA141",28, 0)
  21710    I $G(RANS )="" D                     ;;BUG 010291 DRW /JAK - mod ified code  to allow  for multip le claim p rocessing
  21711   "RTN","CHM FA141",29, 0)
  21712    .S ASCSW= 0 ;;and se t ASCSW to  zero when  another c laim is en tered to a llow for P OP-UP to a ppear - 10 /31/11.
  21713   "RTN","CHM FA141",30, 0)
  21714    S RANS=""
  21715   "RTN","CHM FA141",31, 0)
  21716    D INIT                            ;,TOTAL   ;AEB 9/5/ 2007  ;        ;JEH 2 /1/11 DEV0 07820
  21717   "RTN","CHM FA141",32, 0)
  21718   M1 D ENTED T
  21719   "RTN","CHM FA141",33, 0)
  21720   END Q
  21721   "RTN","CHM FA141",34, 0)
  21722    ;
  21723   "RTN","CHM FA141",35, 0)
  21724   INIT ;
  21725   "RTN","CHM FA141",36, 0)
  21726    S DTM=7,D BM=14,DX=1 ,$X=DX,DY= 6 X CHMAR  X XY
  21727   "RTN","CHM FA141",37, 0)
  21728    S CHSDY=6 ,CHMDY=17, CHWIN=8,CH LF=8       ;JEH 2/1/1 1 DEV00780  CHG CHMDY =17 TO 19,  CHLF=8 TO  12
  21729   "RTN","CHM FA141",38, 0)
  21730    S CHWINLR =1,CHWINHR =CHWIN,MSG FLG=0
  21731   "RTN","CHM FA141",39, 0)
  21732    S ZANSFLG =0      ;J EH 12/10/0 6 NEW FLAG  FOR ANEST H CODE CAL C
  21733   "RTN","CHM FA141",40, 0)
  21734    S CHBLNKO N="*27,*91 ,*53,*109"     ;SCREE N - BLINKI NG ON ;JEH  2/1/11 DE V007820
  21735   "RTN","CHM FA141",41, 0)
  21736    S CHBLNKO FF="*27,*9 1,*23,*109 "   ;SCREE N - BLINKI NG OFF         ;JEH 2 /1/11 DEV0 07820
  21737   "RTN","CHM FA141",42, 0)
  21738    N CHKFLG    ;JEH 9/1 3/13 - ENC 004389
  21739   "RTN","CHM FA141",43, 0)
  21740   SUBHEAD ;
  21741   "RTN","CHM FA141",44, 0)
  21742    S:'$D(TOC ORG) TOCOR G=""         ;JEH 2/1 /11 DEV007 820
  21743   "RTN","CHM FA141",45, 0)
  21744    S:'$D(TOC IPE) TOCIP E=""         ;JEH 2/1 /11 DEV007 820
  21745   "RTN","CHM FA141",46, 0)
  21746    U 0:0:"^% X364"
  21747   "RTN","CHM FA141",47, 0)
  21748    S DX=8,DY =4 S DX=DX ,$X=DX X X Y W @CHBON ,"OHI TOC: ",@CHBOFF, " ",TOCORG   ;JEH 2/1 /11 DEV007 820
  21749   "RTN","CHM FA141",48, 0)
  21750    S DX=48,D Y=4 S DX=D X,$X=DX X  XY W @CHBO N,"OHI Edi t TOC:",@C HBOFF," ", TOCIPE     ;JEH 2/1/1 1 DEV00782 0
  21751   "RTN","CHM FA141",49, 0)
  21752    S DY=5,FL D=1 D FLDL NG S DX=CF DX,$X=DX X  XY W @CHU LON,"  DOS    "
  21753   "RTN","CHM FA141",50, 0)
  21754    I CHMFSRV C=4 S FLD= 2 D FLDLNG  S DX=CFDX ,$X=DX X X Y W @CHULO FF,"POS",@ CHULON             ;J EH 2/1/11  DEV007820
  21755   "RTN","CHM FA141",51, 0)
  21756    E  S FLD= 2 D FLDLNG  S DX=CFDX ,$X=DX X X Y W "POS"                 ;JEH 2 /1/11 DEV0 07820
  21757   "RTN","CHM FA141",52, 0)
  21758    S FLD=3 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "  ICD    "                       ;JEH 2/1 /11 DEV007 820
  21759   "RTN","CHM FA141",53, 0)
  21760    S FLD=4 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "REV "                            ;JEH 2/1 /11 DEV007 820
  21761   "RTN","CHM FA141",54, 0)
  21762    S FLD=5 D
  21763   "RTN","CHM FA141",55, 0)
  21764    .I CHMFSR VC=4 D FLD LNG S DX=C FDX,$X=DX  X XY W "     SVCS      "  ;JEH 2 /1/11 DEV0 07820
  21765   "RTN","CHM FA141",56, 0)
  21766    .E  D FLD LNG S DX=C FDX,$X=DX  X XY W "   SVCS/NDC    "    ;JEH  2/1/11 DE V007820
  21767   "RTN","CHM FA141",57, 0)
  21768    S FLD=6 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "MODS "                           ;JEH 2/1 /11 DEV007 820
  21769   "RTN","CHM FA141",58, 0)
  21770    S FLD=7 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "UNT/QTY"                         ;JEH 2/1 /11 DEV007 820
  21771   "RTN","CHM FA141",59, 0)
  21772    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "  AMOUNT   "            ;JEH 2 /1/11 DEV0 07820
  21773   "RTN","CHM FA141",60, 0)
  21774    S FLD=16  D FLDLNG S  DX=CFDX,$ X=DX X XY  W " P/R BA L  ",@CHUL OFF   ;JEH  2/1/11 DE V007280
  21775   "RTN","CHM FA141",61, 0)
  21776    D TOTAL
  21777   "RTN","CHM FA141",62, 0)
  21778    S ROW=1,U ="^"
  21779   "RTN","CHM FA141",63, 0)
  21780    I $D(^UTI LITY($J,"C HDME",BEN) ) S CHLR=9 99999999,C HLR=$O(^UT ILITY($J," CHDME",BEN ,CHLR),-1)
  21781   "RTN","CHM FA141",64, 0)
  21782    I '$D(^UT ILITY($J," CHDME",BEN )) D NEWRO W
  21783   "RTN","CHM FA141",65, 0)
  21784    Q
  21785   "RTN","CHM FA141",66, 0)
  21786    ;
  21787   "RTN","CHM FA141",67, 0)
  21788   TOTAL ;
  21789   "RTN","CHM FA141",68, 0)
  21790    W @CHBON  S DY=14,DX =53,$X=DX  X XY W @CH BON,"TOTAL S",@CHBOFF    ;JEH 1/ 15/10 TT 0 108 ADDED  $D CHECK       ;JEH 2 /1/11 DEV0 07820  REM OVED - I ' $D(CHOPRX)
  21791   "RTN","CHM FA141",69, 0)
  21792    F FLD=8,1 4,16 D
  21793   "RTN","CHM FA141",70, 0)
  21794    .S:'$D(CH SUM(FLD))  CHSUM(FLD) =0 S:'$D(D DTOTAL(FLD )) DDTOTAL (FLD)=0 S  TOTSUM(FLD )=DDTOTAL( FLD)+CHSUM (FLD)   ;J EH 2/1/11  DEV007820
  21795   "RTN","CHM FA141",71, 0)
  21796    F FLD=8,1 6 D FLDLNG  S DX=CFDX ,$X=DX X X Y D    ;JE H 2/1/11 D EV007820
  21797   "RTN","CHM FA141",72, 0)
  21798    .W @CHBON ,@CHEOL,$J ($FN(TOTSU M(FLD),"," ,2),FL),@C HBOFF
  21799   "RTN","CHM FA141",73, 0)
  21800    N MVENFLG     ;MEDIC AID VENDOR  PAYMENT F OR OUTPATI ENT FLAG
  21801   "RTN","CHM FA141",74, 0)
  21802    S MVENFLG =""   ;JEH  2/1/11 DE V007820
  21803   "RTN","CHM FA141",75, 0)
  21804    S:$D(^CHM IMAGE(CHMF PDI,1,1,2, 1,"VEN"))  MVENFLG=$P (^CHMIMAGE (CHMFPDI,1 ,1,2,1,"VE N"),"^",16 )
  21805   "RTN","CHM FA141",76, 0)
  21806    S:MVENFLG ="" MVENFL G=VFN
  21807   "RTN","CHM FA141",77, 0)
  21808    I MVENFLG ="" S CHMC FG=0 Q     ;JEH 2/1/1 1 DEV00782 0
  21809   "RTN","CHM FA141",78, 0)
  21810    S CHMCFG= $S($P($G(^ CHMVEN(MVE NFLG,1)),U ,7)=88:1,$ P($G(^CHMV EN(MVENFLG ,1)),U,7)' =88:0,1:"" )    ;MEDI CAID VENDO R TYPE   ; 88-MEDICAI D AGENCY    ;JEH 2/1/ 11 DEV0078 20
  21811   "RTN","CHM FA141",79, 0)
  21812    I CHMCFG= 1 D
  21813   "RTN","CHM FA141",80, 0)
  21814    .S DY=15, DX=46,$X=D X X XY W @ CHBON,"MED ICAID PAID ",@CHBOFF      ;JEH 2 /1/11 DEV0 07820   ;* ** PLACE H OLDER ***
  21815   "RTN","CHM FA141",81, 0)
  21816    .S DY=15, DX=60,$X=D X X XY W @ CHBON,@CHE OL,$J($FN( TOTSUM(14) ,",",2),10 ),@CHBOFF
  21817   "RTN","CHM FA141",82, 0)
  21818    Q
  21819   "RTN","CHM FA141",83, 0)
  21820   ENTEDT ;S: '$D(DDTOTA L) DDTOTAL =0
  21821   "RTN","CHM FA141",84, 0)
  21822    S CHWINLR =1,CHWINHR =CHWIN,ROW =1,FLD=0,C HVAR="^UTI LITY($J,"" CHDME"",BE N,ROW,FLD) "   ;,CHSU M=0,CHSUM= CHSUM+DDTO TAL
  21823   "RTN","CHM FA141",85, 0)
  21824    I $P(^UTI LITY($J,"C HDME",BEN, 1,1),U)'=" " D REDISP  G ENT1
  21825   "RTN","CHM FA141",86, 0)
  21826    S DY=CHSD Y,MSGFLG=0  D FLDLNG  S DX=CFDX, $X=DX
  21827   "RTN","CHM FA141",87, 0)
  21828   ENT0 S $P( ^UTILITY($ J,"CHDME", BEN,ROW,FL D),U,1)=RO W
  21829   "RTN","CHM FA141",88, 0)
  21830    I FLD=8!( FLD=16) X  XY W $J($F N($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U, 1),"",2),F L)
  21831   "RTN","CHM FA141",89, 0)
  21832    E  I FLD= 6 X XY W $ J($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),"* ",1),5)    ;JEH 2/1/1 1 DEV00782 0
  21833   "RTN","CHM FA141",90, 0)
  21834    E  X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)
  21835   "RTN","CHM FA141",91, 0)
  21836    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX
  21837   "RTN","CHM FA141",92, 0)
  21838   ENT1 ;
  21839   "RTN","CHM FA141",93, 0)
  21840    S CHDB=""
  21841   "RTN","CHM FA141",94, 0)
  21842    I $D(ROW)  I ROW'=""  S CHDB=^U TILITY($J, "CHDME",BE N,ROW,FLD)
  21843   "RTN","CHM FA141",95, 0)
  21844    I ROW=""  S ROW=1 D  REDISP ;JS E 3/16/11  MTN011703  <SUBSCR> e rr @ ENT1+ 10 if ROW= ""
  21845   "RTN","CHM FA141",96, 0)
  21846    S SFLD=0
  21847   "RTN","CHM FA141",97, 0)
  21848    I FLD=5 X  XY W $J($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),"* ",2),U,1), FL)
  21849   "RTN","CHM FA141",98, 0)
  21850    E  D
  21851   "RTN","CHM FA141",99, 0)
  21852    .I FLD=6  D  ;JEH 2/ 1/11 DEV00 7820
  21853   "RTN","CHM FA141",100 ,0)
  21854    ..I $L($P (^UTILITY( $J,"CHDME" ,BEN,ROW,F LD),"*",1) )>4 D
  21855   "RTN","CHM FA141",101 ,0)
  21856    ...S SPC= "  ",$P(SP C," ",11-$ L($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),"* ",1)))=""
  21857   "RTN","CHM FA141",102 ,0)
  21858    ...X XY W  $P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),"*" ,1),SPC
  21859   "RTN","CHM FA141",103 ,0)
  21860    ..E  X XY  W $J($E($ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),"*",1 ),1,4),5)
  21861   "RTN","CHM FA141",104 ,0)
  21862    .E  I FLD =8!(FLD=16 ) I ($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1)'="")  X XY W $J ($FN($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1),"",2 ),FL)
  21863   "RTN","CHM FA141",105 ,0)
  21864    .E  X XY  W $J($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1),FL)
  21865   "RTN","CHM FA141",106 ,0)
  21866    I FLD=2&( CHMFSRVC=4 ) D
  21867   "RTN","CHM FA141",107 ,0)
  21868    .I $D(D4O UT) S FLD= FLD-1
  21869   "RTN","CHM FA141",108 ,0)
  21870    .E  S FLD =FLD+1
  21871   "RTN","CHM FA141",109 ,0)
  21872    .D FLDLNG ,CLRMSG S  DX=CFDX,$X =DX ;G ENT 1  ;D:$P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),U)'="" C URSAV,DES1 ,CURRES
  21873   "RTN","CHM FA141",110 ,0)
  21874    I FLD=2&( CHMFSRVC=6 ) D  G ENT 1    ;SET  POS TO 'AM B' IF TRVL      ;JEH  2/1/11 DEV 007820
  21875   "RTN","CHM FA141",111 ,0)
  21876    .S ^UTILI TY($J,"CHD ME",BEN,RO W,FLD)="AM B^10^AMBUL ANCE"
  21877   "RTN","CHM FA141",112 ,0)
  21878    .X XY W $ J($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U, 1),FL)
  21879   "RTN","CHM FA141",113 ,0)
  21880    .I $D(D4O UT) S FLD= FLD-1
  21881   "RTN","CHM FA141",114 ,0)
  21882    .E  S FLD =FLD+1
  21883   "RTN","CHM FA141",115 ,0)
  21884    .D FLDLNG ,CLRMSG S  DX=CFDX,$X =DX ;G ENT 1  ;D:$P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),U)'="" C URSAV,DES1 ,CURRES
  21885   "RTN","CHM FA141",116 ,0)
  21886    I ZANSFLG =1&(FLD=7)  D
  21887   "RTN","CHM FA141",117 ,0)
  21888    .D ANESCD      ;^CHM FA141         ;JEH 12 /08/06 NEW  FOR ANEST H
  21889   "RTN","CHM FA141",118 ,0)
  21890    E  D
  21891   "RTN","CHM FA141",119 ,0)
  21892    .X XY D C SBRS^CHSC2
  21893   "RTN","CHM FA141",120 ,0)
  21894    .S CHLF=8  I $D(^UTI LITY($J,"C HDME",BEN, ROW,3)) D
  21895   "RTN","CHM FA141",121 ,0)
  21896    ..S:$P(^U TILITY($J, "CHDME",BE N,ROW,3),U )'="" CHLF =3
  21897   "RTN","CHM FA141",122 ,0)
  21898    ..Q
  21899   "RTN","CHM FA141",123 ,0)
  21900    .I $D(DFO UT) W *7 G  ENT1
  21901   "RTN","CHM FA141",124 ,0)
  21902    .I $D(DUO UT) W *7 G  ENT1
  21903   "RTN","CHM FA141",125 ,0)
  21904    .I Y'=""  S CHDB=""
  21905   "RTN","CHM FA141",126 ,0)
  21906    .I Y=""&( ^UTILITY($ J,"CHDME", BEN,ROW,FL D)'="") D    ;JEH 2/1 /11 DEV007 820
  21907   "RTN","CHM FA141",127 ,0)
  21908    ..I FLD=6  S Y=$J($P (^UTILITY( $J,"CHDME" ,BEN,ROW,F LD),"*",1) ,5)   ;JEH  2/1/11 DE V007820
  21909   "RTN","CHM FA141",128 ,0)
  21910    ..E  S Y= $P(^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD),U,1)    ;JEH 2/ 1/11 DEV00 7820
  21911   "RTN","CHM FA141",129 ,0)
  21912    .S LNTAG= "GETF"_FLD _"^CHMFA14 2" D @LNTA G
  21913   "RTN","CHM FA141",130 ,0)
  21914    I FLD=6&( Y="@") S Y ="",SFLD=0  D CURSAV, CLRLN,CURR ES G ENT1    ;JEH 2/1 /11 DEV007 820
  21915   "RTN","CHM FA141",131 ,0)
  21916    I SFLD G  ENT1
  21917   "RTN","CHM FA141",132 ,0)
  21918    I $D(ROW) ,ROW'="" D     ;JSG;0 2/28/08;BU G003956 -  Insulate c ode block  from undef ined ROW
  21919   "RTN","CHM FA141",133 ,0)
  21920    .S ^UTILI TY($J,"CHD ME",BEN,RO W,FLD)=Y
  21921   "RTN","CHM FA141",134 ,0)
  21922    .I FLD=8  D
  21923   "RTN","CHM FA141",135 ,0)
  21924    ..I '$D(R PTFLG) D
  21925   "RTN","CHM FA141",136 ,0)
  21926    ...D CHKD STR   ;JEH  2/1/11 DE V007820 -  CHECK FOR  RE-DISTRIB UTION OF P /R
  21927   "RTN","CHM FA141",137 ,0)
  21928    ...D RDPL YPR   ;JEH  2/1/11 DE V007820 -  REDISPLAY  P/R BAL TO TALS
  21929   "RTN","CHM FA141",138 ,0)
  21930    .D CHSMT( 8)   ;CHEC K/DISPLAY  TOTALS
  21931   "RTN","CHM FA141",139 ,0)
  21932    .D CHSMT( 16)  ;CHEC K/DISPLAY  TOTALS
  21933   "RTN","CHM FA141",140 ,0)
  21934    .I ^UTILI TY($J,"CHD ME",BEN,RO W,FLD)'=CH DB D   ;JE H 2/1/11 D EV007820
  21935   "RTN","CHM FA141",141 ,0)
  21936    ..;X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)    ;JEH 2/1/ 11 DEV0078 20  ORIG L INE, COMME NT OUT
  21937   "RTN","CHM FA141",142 ,0)
  21938    ..I FLD=6  X XY W $J ($E($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), "*",1),1,4 ),5),"  "    ;JEH 2/1 /11 DEV007 820
  21939   "RTN","CHM FA141",143 ,0)
  21940    ..E  I FL D=5 X XY W  $J($P($P( ^UTILITY($ J,"CHDME", BEN,ROW,FL D),"*",2), U,1),FL)    ;JEH 2/1/ 11 DEV0078 20
  21941   "RTN","CHM FA141",144 ,0)
  21942    ..E  X XY  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),U,1),FL)
  21943   "RTN","CHM FA141",145 ,0)
  21944    ..I FLD=3  D:$P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U )'="" ICDF IL ;CURSAV ,DESCRP,CU RRES,ICDFI L   ;JEH 2 /1/11 DEV0 07820 COMM ENT OUT CU RSAV,DESCR P,CURRES
  21945   "RTN","CHM FA141",146 ,0)
  21946    ..I FLD=5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U )'="" CURS AV,DES1,CU RRES,ICDFI L
  21947   "RTN","CHM FA141",147 ,0)
  21948    ..X XY
  21949   "RTN","CHM FA141",148 ,0)
  21950    I $G(ROW) &(FLD=8) I  $E($P($P( ^UTILITY($ J,"CHDME", BEN,ROW,5) ,"^",1),"* ",2),1,2)= 99 I $$CDC HK^CHMFAUT 4()=1 S FL D=1 D FLDL NG,CLRMSG  S DX=CFDX, $X=DX G EN T1   ;JEH  05/08/13 -  ENC004389
  21951   "RTN","CHM FA141",149 ,0)
  21952    I $D(DDOU T) D EXIT  Q:$D(CHMFN EXT)  Q:$D (CHMFPREV)   Q:$D(CHM FKILL)  Q: $D(CHMFNEW B)  Q:$D(C HMFOPRX)   G ENT1
  21953   "RTN","CHM FA141",150 ,0)
  21954    I ROW=1&$ D(D1OUT) W  *7 G ENT1
  21955   "RTN","CHM FA141",151 ,0)
  21956    I ROW>1&$ D(D1OUT) D   D UP D F LDLNG,CLRM SG G ENT1     ;JEH 2/ 1/11 DEV00 7820
  21957   "RTN","CHM FA141",152 ,0)
  21958    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  21959   "RTN","CHM FA141",153 ,0)
  21960    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  21961   "RTN","CHM FA141",154 ,0)
  21962    I $D(D4OU T)&(FLD'>1 ) S FLD=CH LF D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  21963   "RTN","CHM FA141",155 ,0)
  21964    I $D(D4OU T)&(FLD=2) &(CHMFSRVC =4) S FLD= FLD-1 D FL DLNG,CLRMS G S DX=CFD X,$X=DX G  ENT1
  21965   "RTN","CHM FA141",156 ,0)
  21966    I $D(D4OU T)&(FLD>1)  D  D FLDL NG,CLRMSG  S DX=CFDX, $X=DX G EN T1   ;JEH  2/1/11 DEV 007820
  21967   "RTN","CHM FA141",157 ,0)
  21968    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  21969   "RTN","CHM FA141",158 ,0)
  21970    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  21971   "RTN","CHM FA141",159 ,0)
  21972    .I FLD=7, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW,5),U)," *")="RX")  S FLD=FLD- 1
  21973   "RTN","CHM FA141",160 ,0)
  21974    .S FLD=FL D-1
  21975   "RTN","CHM FA141",161 ,0)
  21976    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD-1
  21977   "RTN","CHM FA141",162 ,0)
  21978    I $D(D3OU T)&(FLD'<C HLF) S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  21979   "RTN","CHM FA141",163 ,0)
  21980    I $D(D3OU T)&(FLD<CH LF) D  D F LDLNG,CLRM SG S DX=CF DX,$X=DX G  ENT1    ; JEH 2/1/11  DEV007820
  21981   "RTN","CHM FA141",164 ,0)
  21982    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  21983   "RTN","CHM FA141",165 ,0)
  21984    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  21985   "RTN","CHM FA141",166 ,0)
  21986    .I FLD=5, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW,5),U)," *")="RX")  S FLD=FLD+ 1
  21987   "RTN","CHM FA141",167 ,0)
  21988    .S FLD=FL D+1
  21989   "RTN","CHM FA141",168 ,0)
  21990    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  21991   "RTN","CHM FA141",169 ,0)
  21992    I $D(DPOU T) D PREV  D FLDLNG,C LRMSG G EN T1
  21993   "RTN","CHM FA141",170 ,0)
  21994    I $D(DNOU T) D NEXT  D FLDLNG,C LRMSG G EN T1
  21995   "RTN","CHM FA141",171 ,0)
  21996    ; D2OUT O R CR
  21997   "RTN","CHM FA141",172 ,0)
  21998    I '$D(D2O UT)&(FLD<C HLF) D  D  FLDLNG,CLR MSG S DX=C FDX,$X=DX  G ENT1
  21999   "RTN","CHM FA141",173 ,0)
  22000    .I FLD=6  D CURSAV,C LRLN,CURRE S   ;JEH 2 /1/11 DEV0 07820
  22001   "RTN","CHM FA141",174 ,0)
  22002    .I FLD=5, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW,5),U)," *")="RX")  S FLD=FLD+ 1
  22003   "RTN","CHM FA141",175 ,0)
  22004    .S FLD=FL D+1
  22005   "RTN","CHM FA141",176 ,0)
  22006    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  22007   "RTN","CHM FA141",177 ,0)
  22008    .I FLD=7, ROW'="" S: ^UTILITY($ J,"CHDME", BEN,ROW,FL D)=""&(^UT ILITY($J," CHDME",BEN ,ROW,1)="D ELETED") ^ UTILITY($J ,"CHDME",B EN,ROW,FLD )=1
  22009   "RTN","CHM FA141",178 ,0)
  22010    I '$D(D2O UT)&(FLD'< CHLF)&(ROW '=CHLR) D  DOWN D:FLD >5 CURSAV, CLRLN,CURR ES S FLD=1  D FLDLNG, CLRMSG S D X=CFDX,$X= DX G ENT1    ;JEH 2/1 /11 DEV007 820
  22011   "RTN","CHM FA141",179 ,0)
  22012    I ROW=CHL R D DOWN D :FLD>5 CUR SAV,CLRLN, CURRES S F LD=0 D FLD LNG,CLRMSG  S DX=CFDX ,$X=DX G E NT0
  22013   "RTN","CHM FA141",180 ,0)
  22014    D DOWN D: FLD>5 CURS AV,CLRLN,C URRES S:^U TILITY($J, "CHDME",BE N,ROW,1)=" " FLD=1 D  FLDLNG,CLR MSG S DX=C FDX,$X=DX  G ENT1
  22015   "RTN","CHM FA141",181 ,0)
  22016    Q
  22017   "RTN","CHM FA141",182 ,0)
  22018   ANESCD ;AN ESTHESIA C ODE   ;NEW  JEH 12/8/ 06
  22019   "RTN","CHM FA141",183 ,0)
  22020    I $P(^UTI LITY($J,"C HDME",BEN, ROW,3),U)' ="" S Y=""  X XY W $J (Y,FL)
  22021   "RTN","CHM FA141",184 ,0)
  22022    D CURSAV^ CHMFA141,E RAMSG^CHMF A141:MSGFL G,MARMES^C HMFA141 S  IOSL=3,DX= 1,$X=DX,DY =CHMDY X X Y
  22023   "RTN","CHM FA141",185 ,0)
  22024    ;
  22025   "RTN","CHM FA141",186 ,0)
  22026   AN2 ;LOOP
  22027   "RTN","CHM FA141",187 ,0)
  22028    S (TIMU,B ASU,TOTU)= 0
  22029   "RTN","CHM FA141",188 ,0)
  22030    D NOW^%DT C S DMYDT= X
  22031   "RTN","CHM FA141",189 ,0)
  22032    S DIR("A" )="     En ter 'M' fo r minutes,  'U' for U nits, or ' T' for Tim e"   ;JEH  7/18/07 -  DEV001373- 01: Anesth esia minut e calc
  22033   "RTN","CHM FA141",190 ,0)
  22034    S DIR(0)= "F",DIR("B ")="M" D ^ DIR K DIR  S ANS=Y
  22035   "RTN","CHM FA141",191 ,0)
  22036    I ANS="^"  S Y=0 G A NEND
  22037   "RTN","CHM FA141",192 ,0)
  22038    I ANS="@"  D
  22039   "RTN","CHM FA141",193 ,0)
  22040    .S ^UTILI TY($J,"CHD ME",BEN,RO W,FLD)=""
  22041   "RTN","CHM FA141",194 ,0)
  22042    .S Y=0
  22043   "RTN","CHM FA141",195 ,0)
  22044    .S SFLD=1  G ANEND
  22045   "RTN","CHM FA141",196 ,0)
  22046    I ANS=""  S Y=1 G AN END
  22047   "RTN","CHM FA141",197 ,0)
  22048    I ANS'="M "&(ANS'="U ")&(ANS'=" T") D ANHE LP G AN2      ;ESCD    ;JEH 7/18 /07 - DEV0 01373-01:  Anesthesia  minute ca lc
  22049   "RTN","CHM FA141",198 ,0)
  22050    I ANS="U"  D
  22051   "RTN","CHM FA141",199 ,0)
  22052    .S ANS2FL G=1
  22053   "RTN","CHM FA141",200 ,0)
  22054    .W !,?5," Enter the  number of  Units: " R  ANS2
  22055   "RTN","CHM FA141",201 ,0)
  22056    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D
  22057   "RTN","CHM FA141",202 ,0)
  22058    ..S TOTU= 0
  22059   "RTN","CHM FA141",203 ,0)
  22060    ..S ANS2F LG=0
  22061   "RTN","CHM FA141",204 ,0)
  22062    .E  S TIM U=+ANS2
  22063   "RTN","CHM FA141",205 ,0)
  22064    I ANS="M"  D
  22065   "RTN","CHM FA141",206 ,0)
  22066    .S ANS2FL G=1
  22067   "RTN","CHM FA141",207 ,0)
  22068    .W !,?5," Enter the  number of  Minutes: "  R ANS2
  22069   "RTN","CHM FA141",208 ,0)
  22070    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D
  22071   "RTN","CHM FA141",209 ,0)
  22072    ..S TOTU= 0
  22073   "RTN","CHM FA141",210 ,0)
  22074    ..S ANS2F LG=0
  22075   "RTN","CHM FA141",211 ,0)
  22076    .E  D ANC ALC
  22077   "RTN","CHM FA141",212 ,0)
  22078    I ANS="T"  D         ;JEH 7/18/ 07 - DEV00 1373-01: A nesthesia  minute cal c
  22079   "RTN","CHM FA141",213 ,0)
  22080    .S (STRTD T,ENDDT)=" "
  22081   "RTN","CHM FA141",214 ,0)
  22082    .S ANS2FL G=1
  22083   "RTN","CHM FA141",215 ,0)
  22084   SD1 .;STAR T DATE
  22085   "RTN","CHM FA141",216 ,0)
  22086    .W !,"Ent er the STA RT time: "  R ANS2
  22087   "RTN","CHM FA141",217 ,0)
  22088    .I (ANS2= "^") D  Q
  22089   "RTN","CHM FA141",218 ,0)
  22090    ..S TOTU= 0
  22091   "RTN","CHM FA141",219 ,0)
  22092    ..S ANS2F LG=0
  22093   "RTN","CHM FA141",220 ,0)
  22094    .G:ANS2=" "!(ANS2="  ") SD1
  22095   "RTN","CHM FA141",221 ,0)
  22096    .I ANS2=" ?" D HLP^C HTFLIB  G  SD1
  22097   "RTN","CHM FA141",222 ,0)
  22098    .I ANS2=" T" D HLP^C HTFLIB  G  SD1
  22099   "RTN","CHM FA141",223 ,0)
  22100    .I ANS2[" @" D
  22101   "RTN","CHM FA141",224 ,0)
  22102    ..S STRTD 1=$P(ANS2, "@",1)
  22103   "RTN","CHM FA141",225 ,0)
  22104    ..S X=STR TD1 D ^%DT  S:Y'=-1 S TRTD1=Y
  22105   "RTN","CHM FA141",226 ,0)
  22106    ..S STRTT 1=$P(ANS2, "@",2)
  22107   "RTN","CHM FA141",227 ,0)
  22108    ..S STRTT M=$$TIMECN V^CHTFLIB( STRTT1) S  Y=$$MIL^CH TFLIB(STRT TM)
  22109   "RTN","CHM FA141",228 ,0)
  22110    ..S:$L(Y) <4 Y="0"_Y
  22111   "RTN","CHM FA141",229 ,0)
  22112    ..S Y=STR TD1_"."_Y
  22113   "RTN","CHM FA141",230 ,0)
  22114    .E  D
  22115   "RTN","CHM FA141",231 ,0)
  22116    ..S STRTT M=$$TIMECN V^CHTFLIB( ANS2)
  22117   "RTN","CHM FA141",232 ,0)
  22118    ..I '$G(S TRTTM) S Y =-1 Q
  22119   "RTN","CHM FA141",233 ,0)
  22120    ..S Y=$$M IL^CHTFLIB (STRTTM)
  22121   "RTN","CHM FA141",234 ,0)
  22122    ..I Y=-1  Q
  22123   "RTN","CHM FA141",235 ,0)
  22124    ..S:$L(Y) <4 Y="0"_Y
  22125   "RTN","CHM FA141",236 ,0)
  22126    ..S Y=DMY DT_"."_Y      ;DUMMY  DATE
  22127   "RTN","CHM FA141",237 ,0)
  22128    .I Y=""!( Y="?") D H LP^CHTFLIB  G SD1
  22129   "RTN","CHM FA141",238 ,0)
  22130    .I Y=-1 D  HLP^CHTFL IB G SD1
  22131   "RTN","CHM FA141",239 ,0)
  22132    .S STRTDT =Y
  22133   "RTN","CHM FA141",240 ,0)
  22134   ED1 .;END  DATE
  22135   "RTN","CHM FA141",241 ,0)
  22136    .W !,"Ent er the END  time: " R  ANS2
  22137   "RTN","CHM FA141",242 ,0)
  22138    .I (ANS2= "^")!(ANS2 ="@") D  Q
  22139   "RTN","CHM FA141",243 ,0)
  22140    ..S TOTU= 0
  22141   "RTN","CHM FA141",244 ,0)
  22142    ..S ANS2F LG=0
  22143   "RTN","CHM FA141",245 ,0)
  22144    .G:ANS2=" "!(ANS2="  ") SD1
  22145   "RTN","CHM FA141",246 ,0)
  22146    .I ANS2=" ?" D HLP^C HTFLIB  G  ED1
  22147   "RTN","CHM FA141",247 ,0)
  22148    .I ANS2=" T" D HLP^C HTFLIB  G  ED1
  22149   "RTN","CHM FA141",248 ,0)
  22150    .I ANS2[" @" D
  22151   "RTN","CHM FA141",249 ,0)
  22152    ..S ENDD1 =$P(ANS2," @",1)
  22153   "RTN","CHM FA141",250 ,0)
  22154    ..S ENDT1 =$P(ANS2," @",2)
  22155   "RTN","CHM FA141",251 ,0)
  22156    ..S ENDTM =$$TIMECNV ^CHTFLIB(E NDT1) S Y= $$MIL^CHTF LIB(ENDTM)
  22157   "RTN","CHM FA141",252 ,0)
  22158    ..S:$L(Y) <4 Y="0"_Y
  22159   "RTN","CHM FA141",253 ,0)
  22160    ..S Y=END D1_"."_Y
  22161   "RTN","CHM FA141",254 ,0)
  22162    .E  D
  22163   "RTN","CHM FA141",255 ,0)
  22164    ..S ENDTM =$$TIMECNV ^CHTFLIB(A NS2)
  22165   "RTN","CHM FA141",256 ,0)
  22166    ..I '$G(E NDTM) S Y= -1 Q
  22167   "RTN","CHM FA141",257 ,0)
  22168    ..S Y=$$M IL^CHTFLIB (ENDTM)
  22169   "RTN","CHM FA141",258 ,0)
  22170    ..I Y=-1  Q
  22171   "RTN","CHM FA141",259 ,0)
  22172    ..S:$L(Y) <4 Y="0"_Y
  22173   "RTN","CHM FA141",260 ,0)
  22174    ..S Y=DMY DT_"."_Y      ;DUMMY  DATE
  22175   "RTN","CHM FA141",261 ,0)
  22176    .I Y=""!( Y="?") D H LP^CHTFLIB  G ED1
  22177   "RTN","CHM FA141",262 ,0)
  22178    .I Y=-1 D  HLP^CHTFL IB G ED1
  22179   "RTN","CHM FA141",263 ,0)
  22180    .S ENDDT= Y
  22181   "RTN","CHM FA141",264 ,0)
  22182    .I ENDDT< STRTDT D H LP2^CHTFLI B G ED1
  22183   "RTN","CHM FA141",265 ,0)
  22184    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D
  22185   "RTN","CHM FA141",266 ,0)
  22186    ..S TOTU= 0
  22187   "RTN","CHM FA141",267 ,0)
  22188    ..S ANS2F LG=0
  22189   "RTN","CHM FA141",268 ,0)
  22190    .E  D
  22191   "RTN","CHM FA141",269 ,0)
  22192    ..S ANS2= $$CALCMIN^ CHTFLIB(ST RTDT,ENDDT )
  22193   "RTN","CHM FA141",270 ,0)
  22194    ..D ANCAL C
  22195   "RTN","CHM FA141",271 ,0)
  22196    S ANCDE=$ P(^UTILITY ($J,"CHDME ",BEN,ROW, 5),"^",1)   ;GET CODE  FROM SVCS  COLUMN
  22197   "RTN","CHM FA141",272 ,0)
  22198    S ANCDI=$ P(^UTILITY ($J,"CHDME ",BEN,ROW, 5),"^",2)   ;GET CODE  I-VAL
  22199   "RTN","CHM FA141",273 ,0)
  22200    I ANS2FLG =1 D
  22201   "RTN","CHM FA141",274 ,0)
  22202    .I $D(ANC DI)&(ANCDI '="")&(ANC DI'=" ") D          ; JEH 1/2/08  BUG003971 -03-01 - L OGIC FIX F OR SUBSCRI PT ERROR
  22203   "RTN","CHM FA141",275 ,0)
  22204    ..S CHCDE FD=$P(^UTI LITY($J,"C HDME",BEN, ROW,1),"^" ,2)   ;GET  CORRECT R VU FOR DOS
  22205   "RTN","CHM FA141",276 ,0)
  22206    ..S CHCDE FD=$O(^CHM SERV(ANCDI ,4,"B",CHC DEFD),-1)
  22207   "RTN","CHM FA141",277 ,0)
  22208    ..I $G(CH CDEFD) D
  22209   "RTN","CHM FA141",278 ,0)
  22210    ...S CHCJ PTR=0 S CH CJPTR=$O(^ CHMSERV(AN CDI,4,"B", CHCDEFD,CH CJPTR))
  22211   "RTN","CHM FA141",279 ,0)
  22212    ...S BASU =$P(^CHMSE RV(ANCDI,4 ,CHCJPTR,0 ),"^",2)
  22213   "RTN","CHM FA141",280 ,0)
  22214    ...S TOTU =TIMU+BASU
  22215   "RTN","CHM FA141",281 ,0)
  22216    ..E  D
  22217   "RTN","CHM FA141",282 ,0)
  22218    ...W !!!, ?5,"Anesth esia Unit  not availa ble, setti ng default  value.",! ,?5,"Hit < enter> to  continue.. . " R XXX: 5
  22219   "RTN","CHM FA141",283 ,0)
  22220    ...S TOTU =1
  22221   "RTN","CHM FA141",284 ,0)
  22222    .E  S TOT U=0
  22223   "RTN","CHM FA141",285 ,0)
  22224    S Y=+TOTU
  22225   "RTN","CHM FA141",286 ,0)
  22226    K ANS,ANS 2,TIMU,UNI T,ANCDE,BA SU
  22227   "RTN","CHM FA141",287 ,0)
  22228    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  22229   "RTN","CHM FA141",288 ,0)
  22230    S ZANSFLG =0
  22231   "RTN","CHM FA141",289 ,0)
  22232    Q
  22233   "RTN","CHM FA141",290 ,0)
  22234   ANEND ;
  22235   "RTN","CHM FA141",291 ,0)
  22236    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  22237   "RTN","CHM FA141",292 ,0)
  22238    Q
  22239   "RTN","CHM FA141",293 ,0)
  22240   ANHELP ;
  22241   "RTN","CHM FA141",294 ,0)
  22242    W !?5,"Yo u must Ent er 'M' or  'U'."
  22243   "RTN","CHM FA141",295 ,0)
  22244    Q
  22245   "RTN","CHM FA141",296 ,0)
  22246   ANCALC ;CA LCULATE TH E NUMBER O F UNITS FR OM MINUTES  ENTERED
  22247   "RTN","CHM FA141",297 ,0)
  22248    S TIMU=0
  22249   "RTN","CHM FA141",298 ,0)
  22250    S UNIT=AN S2#15
  22251   "RTN","CHM FA141",299 ,0)
  22252    S TIMU=(A NS2-UNIT)/ 15
  22253   "RTN","CHM FA141",300 ,0)
  22254    S:UNIT'=0  TIMU=TIMU +1
  22255   "RTN","CHM FA141",301 ,0)
  22256    Q
  22257   "RTN","CHM FA141",302 ,0)
  22258   SUMDME(SUM FLD) ;SUMS  ARRAY DME  - AMOUNT
  22259   "RTN","CHM FA141",303 ,0)
  22260    N SUM,R
  22261   "RTN","CHM FA141",304 ,0)
  22262    S SUM=0
  22263   "RTN","CHM FA141",305 ,0)
  22264    I $D(ROW)  Q:ROW=""  SUM
  22265   "RTN","CHM FA141",306 ,0)
  22266    ;I '$D(^U TILITY($J, "CHDME",BE N,ROW,SUMF LD))&('$D( ^UTILITY($ J,"CHDME", BEN,ROW1,S UMFLD))) Q  SUM    ;J EH 2/1/11  DEV007820
  22267   "RTN","CHM FA141",307 ,0)
  22268    S R=0
  22269   "RTN","CHM FA141",308 ,0)
  22270    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) G :'R SUMEND  D
  22271   "RTN","CHM FA141",309 ,0)
  22272    .Q:'$D(^U TILITY($J, "CHDME",BE N,R,SUMFLD ))
  22273   "RTN","CHM FA141",310 ,0)
  22274    .S SUM=SU M+^UTILITY ($J,"CHDME ",BEN,R,SU MFLD)
  22275   "RTN","CHM FA141",311 ,0)
  22276   SUMEND Q S UM
  22277   "RTN","CHM FA141",312 ,0)
  22278    ;
  22279   "RTN","CHM FA141",313 ,0)
  22280   SUMDM8() ; SUMS ARRAY  DME - AMO UNT
  22281   "RTN","CHM FA141",314 ,0)
  22282    N SUM,R
  22283   "RTN","CHM FA141",315 ,0)
  22284    S SUM=0
  22285   "RTN","CHM FA141",316 ,0)
  22286    I $D(ROW)  Q:ROW=""  SUM
  22287   "RTN","CHM FA141",317 ,0)
  22288    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,16))  Q SUM
  22289   "RTN","CHM FA141",318 ,0)
  22290    S R=0
  22291   "RTN","CHM FA141",319 ,0)
  22292    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) G :'R SUMEND 8 D
  22293   "RTN","CHM FA141",320 ,0)
  22294    .Q:'$D(^U TILITY($J, "CHDME",BE N,R,16))
  22295   "RTN","CHM FA141",321 ,0)
  22296    .S SUM=SU M+^UTILITY ($J,"CHDME ",BEN,R,16 )
  22297   "RTN","CHM FA141",322 ,0)
  22298   SUMEND8 Q  SUM
  22299   "RTN","CHM FA141",323 ,0)
  22300    ;
  22301   "RTN","CHM FA141",324 ,0)
  22302   SUMDM16()  ;SUMS ARRA Y DME - AM OUNT
  22303   "RTN","CHM FA141",325 ,0)
  22304    N SUM,R
  22305   "RTN","CHM FA141",326 ,0)
  22306    S SUM=0
  22307   "RTN","CHM FA141",327 ,0)
  22308    I $D(ROW)  Q:ROW=""  SUM
  22309   "RTN","CHM FA141",328 ,0)
  22310    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,16))  Q SUM
  22311   "RTN","CHM FA141",329 ,0)
  22312    S R=0
  22313   "RTN","CHM FA141",330 ,0)
  22314    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) G :'R SUMEND 16 D
  22315   "RTN","CHM FA141",331 ,0)
  22316    .Q:'$D(^U TILITY($J, "CHDME",BE N,R,16))
  22317   "RTN","CHM FA141",332 ,0)
  22318    .S SUM=SU M+^UTILITY ($J,"CHDME ",BEN,R,16 )
  22319   "RTN","CHM FA141",333 ,0)
  22320   SUMEND16 Q  SUM
  22321   "RTN","CHM FA141",334 ,0)
  22322    ;
  22323   "RTN","CHM FA141",335 ,0)
  22324   DESCRP ;
  22325   "RTN","CHM FA141",336 ,0)
  22326    S DX=45,$ X=DX
  22327   "RTN","CHM FA141",337 ,0)
  22328    K BF S BF ="",$P(BF, " ",17)=""  X XY W BF    ;JEH 12 /17/06  K  BF S BF="" ,$P(BF," " ,16)="" X  XY W BF
  22329   "RTN","CHM FA141",338 ,0)
  22330    K BF S BF ="",$P(BF, " ",FL+1)= ""
  22331   "RTN","CHM FA141",339 ,0)
  22332    X XY W $E ($P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U,3 ),1,15)
  22333   "RTN","CHM FA141",340 ,0)
  22334    ;
  22335   "RTN","CHM FA141",341 ,0)
  22336   DES1 D ERA MSG
  22337   "RTN","CHM FA141",342 ,0)
  22338    S HOLDDY= DY
  22339   "RTN","CHM FA141",343 ,0)
  22340    S $P(STR, " ",44)=""     ;JEH 2 /1/11 DEV0 07820 CHGD  59 TO 44
  22341   "RTN","CHM FA141",344 ,0)
  22342    S DX=1,$X =DX,DY=15  X XY W STR  X XY
  22343   "RTN","CHM FA141",345 ,0)
  22344    W $E($P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),U,3),1,4 4)    ;JEH  2/1/11 DE V007820 CH GD down TO  44
  22345   "RTN","CHM FA141",346 ,0)
  22346    S MSGFLG= 1
  22347   "RTN","CHM FA141",347 ,0)
  22348    Q
  22349   "RTN","CHM FA141",348 ,0)
  22350    ;
  22351   "RTN","CHM FA141",349 ,0)
  22352   ICDFIL ;
  22353   "RTN","CHM FA141",350 ,0)
  22354    I FLD=3 S  CHLF=3 D
  22355   "RTN","CHM FA141",351 ,0)
  22356    .F FLD=4: 1:18 S ^UT ILITY($J," CHDME",BEN ,ROW,FLD)= ""  ;JEH 4 /4/18 CHGD  4:1:7 TO  4:1:18
  22357   "RTN","CHM FA141",352 ,0)
  22358    .F FLD=4: 1:18 D FLD LNG S DX=C FDX,$X=DX  X XY W $J( $P(^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD),U,1) ,FL)  ;JEH  4/4/18 CH GD 4:1:7 T O 4:1:18
  22359   "RTN","CHM FA141",353 ,0)
  22360    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX
  22361   "RTN","CHM FA141",354 ,0)
  22362    I FLD=5 S  CHLF=8 D
  22363   "RTN","CHM FA141",355 ,0)
  22364    .S ^UTILI TY($J,"CHD ME",BEN,RO W,3)=""
  22365   "RTN","CHM FA141",356 ,0)
  22366    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX X XY  W $J($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1),FL)
  22367   "RTN","CHM FA141",357 ,0)
  22368    .S FLD=5  D FLDLNG S  DX=CFDX,$ X=DX
  22369   "RTN","CHM FA141",358 ,0)
  22370    I FLD=6 S  CHLF=8 D
  22371   "RTN","CHM FA141",359 ,0)
  22372    .S ^UTILI TY($J,"CHD ME",BEN,RO W,3)=""
  22373   "RTN","CHM FA141",360 ,0)
  22374    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX X XY  W $J($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1),FL)
  22375   "RTN","CHM FA141",361 ,0)
  22376    .S FLD=5  D FLDLNG S  DX=CFDX,$ X=DX X XY  W $J($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1),FL)
  22377   "RTN","CHM FA141",362 ,0)
  22378    .S FLD=6  D FLDLNG S  DX=CFDX,$ X=DX
  22379   "RTN","CHM FA141",363 ,0)
  22380    Q
  22381   "RTN","CHM FA141",364 ,0)
  22382    ;
  22383   "RTN","CHM FA141",365 ,0)
  22384   EDITOK ;MO DIFIED BY  DTP TO SKI P REV CODE  EDITS ON  PAPER, BUT  NOT EDI I N LAST LIN E OF SUBRT N
  22385   "RTN","CHM FA141",366 ,0)
  22386    Q:'$D(CHM FPDI)
  22387   "RTN","CHM FA141",367 ,0)
  22388    S X=$$TYP E^CHMFPDI2 (CHMFPDI)
  22389   "RTN","CHM FA141",368 ,0)
  22390    S PT=0,PT =$O(^CHMDI C(741002.9 3,"C",X,PT ))
  22391   "RTN","CHM FA141",369 ,0)
  22392    Q:'PT  Q: '$D(^CHMDI C(741002.9 3,PT,0))
  22393   "RTN","CHM FA141",370 ,0)
  22394    S PTR=$P( ^(0),"^",3 )
  22395   "RTN","CHM FA141",371 ,0)
  22396    Q:'PTR  Q :'$D(^CHMD IC(741002. 94,PTR,2))
  22397   "RTN","CHM FA141",372 ,0)
  22398    S:$P(^(2) ,"^",PC) N OEDIT=1
  22399   "RTN","CHM FA141",373 ,0)
  22400    I (PC=2)& ($E(X,1,1) =9) K NOED IT
  22401   "RTN","CHM FA141",374 ,0)
  22402    Q
  22403   "RTN","CHM FA141",375 ,0)
  22404   BEEPQ X XY  W BF X XY  W *7,"??"  X XY W BF
  22405   "RTN","CHM FA141",376 ,0)
  22406    Q
  22407   "RTN","CHM FA141",377 ,0)
  22408    ;
  22409   "RTN","CHM FA141",378 ,0)
  22410   FLDLNG ;
  22411   "RTN","CHM FA141",379 ,0)
  22412    S FL=$S(F LD=0:3,FLD =1:8,FLD=2 :3,FLD=3:8 ,FLD=4:4,F LD=5:13,FL D=6:8,FLD= 7:7,FLD=8: 10,FLD=16: 10,1:1)    ;JEH 2/1/1 1 DEV00782 0
  22413   "RTN","CHM FA141",380 ,0)
  22414    S CFDX=$S (FLD=0:1,F LD=1:5,FLD =2:14,FLD= 3:18,FLD=4 :27,FLD=5: 32,FLD=6:4 6,FLD=7:52 ,FLD=8:60, FLD=16:71, 1:1)   ;JE H 2/1/11 D EV007820
  22415   "RTN","CHM FA141",381 ,0)
  22416    K BF S BF ="",$P(BF, " ",FL+1)= ""
  22417   "RTN","CHM FA141",382 ,0)
  22418    Q
  22419   "RTN","CHM FA141",383 ,0)
  22420    ;
  22421   "RTN","CHM FA141",384 ,0)
  22422   REPEAT X X Y W BF
  22423   "RTN","CHM FA141",385 ,0)
  22424    I $E(Y)=" R" D RPTML T Q   ;JEH  2/1/11 DE V007820
  22425   "RTN","CHM FA141",386 ,0)
  22426    I $E(Y)=" U" D UBNDL  Q   ;JEH  2/1/11 DEV 007820
  22427   "RTN","CHM FA141",387 ,0)
  22428    I $E(Y)=" /" D DIVID E
  22429   "RTN","CHM FA141",388 ,0)
  22430    S STOP=$E (Y,2,$L(Y) )+(ROW-2), START=ROW, DY=DY-1 F  ROW1=START :1:STOP D
  22431   "RTN","CHM FA141",389 ,0)
  22432    .;S ^UTIL ITY($J,"CH DME",BEN,R OW1,0)=ROW 1 F FLD=1: 1:8,16,17  S ^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD)=^UTI LITY($J,"C HDME",BEN, ROW-1,FLD)
  22433   "RTN","CHM FA141",390 ,0)
  22434    .S $P(^UT ILITY($J," CHDME",BEN ,ROW1,0)," U",1)=ROW1  F FLD=1:1 :18 S ^UTI LITY($J,"C HDME",BEN, ROW1,FLD)= ^UTILITY($ J,"CHDME", BEN,ROW-1, FLD)   ;JE H 2/1/11 D EV007820 B DB CPE005- 009
  22435   "RTN","CHM FA141",391 ,0)
  22436    .S DY=DY+ 1 I DY=(CH SDY+CHWIN)  D
  22437   "RTN","CHM FA141",392 ,0)
  22438    ..S DY=CH SDY+CHWIN- 1,CHWINLR= CHWINLR+1, CHWINHR=CH WINHR+1
  22439   "RTN","CHM FA141",393 ,0)
  22440    ..S DX=1, $X=DX X XY  W !
  22441   "RTN","CHM FA141",394 ,0)
  22442    .F FLD=0: 1:8,16,17  D FLDLNG S  DX=CFDX,$ X=DX X XY  D
  22443   "RTN","CHM FA141",395 ,0)
  22444    ..I FLD=8 !(FLD=16)  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)'="" W  $J($FN($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1)," ",2),FL) Q   ;aeb 1/1 0/2008 DEF 003367 add ed to show  rev code
  22445   "RTN","CHM FA141",396 ,0)
  22446    ..I FLD=5  X XY W $J ($P($P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"*",2),U, 1),FL) Q    ;JEH 2/1/ 11 DEV0078 20
  22447   "RTN","CHM FA141",397 ,0)
  22448    ..I FLD=6  X XY W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),"* ",1),5) Q    ;JEH 2/1 /11 DEV007 820
  22449   "RTN","CHM FA141",398 ,0)
  22450    ..W $J($P (^UTILITY( $J,"CHDME" ,BEN,ROW1, FLD),U,1), FL)
  22451   "RTN","CHM FA141",399 ,0)
  22452    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  22453   "RTN","CHM FA141",400 ,0)
  22454    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1
  22455   "RTN","CHM FA141",401 ,0)
  22456    S SFLD=1
  22457   "RTN","CHM FA141",402 ,0)
  22458    D CHSMT(8 )   ;CHECK /DISPLAY T OTALS
  22459   "RTN","CHM FA141",403 ,0)
  22460    D CHSMT(1 6)  ;CHECK /DISPLAY T OTALS
  22461   "RTN","CHM FA141",404 ,0)
  22462   REPEND Q
  22463   "RTN","CHM FA141",405 ,0)
  22464    ;
  22465   "RTN","CHM FA141",406 ,0)
  22466   DIVIDE S Y 1=^UTILITY ($J,"CHDME ",BEN,ROW- 1,8)/$E(Y, 2,$L(Y))
  22467   "RTN","CHM FA141",407 ,0)
  22468    S Y1=$J(Y 1,$L($P(Y1 ,".",1))+3 ,2)
  22469   "RTN","CHM FA141",408 ,0)
  22470    I ^UTILIT Y($J,"CHDM E",BEN,ROW -1,3)'=""  S Y1=""
  22471   "RTN","CHM FA141",409 ,0)
  22472    S ^UTILIT Y($J,"CHDM E",BEN,ROW -1,8)=Y1
  22473   "RTN","CHM FA141",410 ,0)
  22474    D CURSAV
  22475   "RTN","CHM FA141",411 ,0)
  22476    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX,DY=DY- 1
  22477   "RTN","CHM FA141",412 ,0)
  22478    X XY W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W-1,FLD),U ,1),FL)
  22479   "RTN","CHM FA141",413 ,0)
  22480    D CURRES
  22481   "RTN","CHM FA141",414 ,0)
  22482    X XY
  22483   "RTN","CHM FA141",415 ,0)
  22484    Q
  22485   "RTN","CHM FA141",416 ,0)
  22486   RPTMLT ;RE PEAT GROUP  OF LINES    ;JEH 2/1 /11 DEV007 820
  22487   "RTN","CHM FA141",417 ,0)
  22488    N RPRW,RP NM,RWSV,RW DX,RWSV,RC OL,START,R OW1,CTR,AF LD
  22489   "RTN","CHM FA141",418 ,0)
  22490    Q:$E(Y,1, 1)'="R"
  22491   "RTN","CHM FA141",419 ,0)
  22492    ;I $E(CHM FPDI,8,9)' ="03" S RP FLG="" Q    ;ONLY ALL OW CHAMPVA  STANDARD  {03} TO RE PEAT LINES
  22493   "RTN","CHM FA141",420 ,0)
  22494    K:$D(^UTI LITY($J,"R CHDME")) ^ UTILITY($J ,"RCHDME")
  22495   "RTN","CHM FA141",421 ,0)
  22496    S RPNM=$E (Y,2,$L(Y) )
  22497   "RTN","CHM FA141",422 ,0)
  22498    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,1)) S  RPFLG=1,Y ="" Q
  22499   "RTN","CHM FA141",423 ,0)
  22500    S START=0
  22501   "RTN","CHM FA141",424 ,0)
  22502    S LSTRW=9 9999 S LST RW=$O(^UTI LITY($J,"C HDME",BEN, LSTRW),-1)
  22503   "RTN","CHM FA141",425 ,0)
  22504    S ROW1=0  F  S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) Q:'ROW 1  D
  22505   "RTN","CHM FA141",426 ,0)
  22506    .S RWDX=$ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,3),"^",1)
  22507   "RTN","CHM FA141",427 ,0)
  22508    .S RWSV=$ P($P(^UTIL ITY($J,"CH DME",BEN,R OW1,5),"^" ,1),"*",2)
  22509   "RTN","CHM FA141",428 ,0)
  22510    .Q:RWDX=" "&(RWSV="" )
  22511   "RTN","CHM FA141",429 ,0)
  22512    .F RCOL=0 :1:18 D
  22513   "RTN","CHM FA141",430 ,0)
  22514    ..I RCOL= 0 S ^UTILI TY($J,"RCH DME",BEN,L STRW+ROW1, RCOL)=^UTI LITY($J,"C HDME",BEN, ROW1,RCOL) +LSTRW
  22515   "RTN","CHM FA141",431 ,0)
  22516    ..E  S ^U TILITY($J, "RCHDME",B EN,LSTRW+R OW1,RCOL)= ^UTILITY($ J,"CHDME", BEN,ROW1,R COL)
  22517   "RTN","CHM FA141",432 ,0)
  22518    .S START= ROW1+1         ;START  ROW
  22519   "RTN","CHM FA141",433 ,0)
  22520    I START=0  S SFLD=1  Q
  22521   "RTN","CHM FA141",434 ,0)
  22522    S ROW1=ST ART
  22523   "RTN","CHM FA141",435 ,0)
  22524    F CTR=1:1 :RPNM D
  22525   "RTN","CHM FA141",436 ,0)
  22526    .S RRW=0  F  S RRW=$ O(^UTILITY ($J,"RCHDM E",BEN,RRW )) Q:'RRW   D
  22527   "RTN","CHM FA141",437 ,0)
  22528    ..F FLD=0 :1:18 D
  22529   "RTN","CHM FA141",438 ,0)
  22530    ... ;DEFE CT 866501  - TGH - 8/ 19/2018 -  Also repai red two sy ntax error s during c ompile
  22531   "RTN","CHM FA141",439 ,0)
  22532    ... ;I FL D=0 $P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"U",1)=RO W1
  22533   "RTN","CHM FA141",440 ,0)
  22534    ...I FLD= 0 S $P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"U",1)=RO W1
  22535   "RTN","CHM FA141",441 ,0)
  22536    ...E  S ^ UTILITY($J ,"CHDME",B EN,ROW1,FL D)=^UTILIT Y($J,"RCHD ME",BEN,RR W,FLD)
  22537   "RTN","CHM FA141",442 ,0)
  22538    ..S ROW1= ROW1+1
  22539   "RTN","CHM FA141",443 ,0)
  22540    I '$D(^UT ILITY($J," CHDME",BEN ,ROW1,0))  D
  22541   "RTN","CHM FA141",444 ,0)
  22542    .F FLD=0: 1:18 D
  22543   "RTN","CHM FA141",445 ,0)
  22544    ..I FLD=0  S $P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "^",1)=ROW 1 Q  ;BDB  CPE005-009
  22545   "RTN","CHM FA141",446 ,0)
  22546    ..I FLD<3  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=^UT ILITY($J," CHDME",BEN ,ROW1-1,FL D) Q
  22547   "RTN","CHM FA141",447 ,0)
  22548    ..I FLD=7  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=1 Q
  22549   "RTN","CHM FA141",448 ,0)
  22550    ..I FLD>2  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=""  Q
  22551   "RTN","CHM FA141",449 ,0)
  22552    D INIT,RE DISP
  22553   "RTN","CHM FA141",450 ,0)
  22554    S RPTFLG= ""
  22555   "RTN","CHM FA141",451 ,0)
  22556    Q
  22557   "RTN","CHM FA141",452 ,0)
  22558   UBNDL ;UN- BUNDLE LIN ES   ;JEH  2/1/11 DEV 007820
  22559   "RTN","CHM FA141",453 ,0)
  22560    N UBROW,R PNM,RWDT,R WDX,RWSV,R COL,START, ROW1,CTR,A FLD,LSTRW
  22561   "RTN","CHM FA141",454 ,0)
  22562    Q:$E(Y,1, 1)'="U"
  22563   "RTN","CHM FA141",455 ,0)
  22564    I Y'?1.1A 1.N1" "1.N  S Y=Y_" 1 "
  22565   "RTN","CHM FA141",456 ,0)
  22566    K:$D(^UTI LITY($J,"R CHDME")) ^ UTILITY($J ,"RCHDME")
  22567   "RTN","CHM FA141",457 ,0)
  22568    S UBROW=$ E($P(Y," " ,1),2,$L(Y ))
  22569   "RTN","CHM FA141",458 ,0)
  22570    S RPNM=$P (Y," ",2)
  22571   "RTN","CHM FA141",459 ,0)
  22572    I '$D(^UT ILITY($J," CHDME",BEN ,UBROW,1))  S RPFLG=1 ,Y="" Q
  22573   "RTN","CHM FA141",460 ,0)
  22574    S LSTRW=9 9999 S LST RW=$O(^UTI LITY($J,"C HDME",BEN, LSTRW),-1)
  22575   "RTN","CHM FA141",461 ,0)
  22576    S RWDX=$P (^UTILITY( $J,"CHDME" ,BEN,UBROW ,3),"^",1)
  22577   "RTN","CHM FA141",462 ,0)
  22578    S RWSV=$P ($P(^UTILI TY($J,"CHD ME",BEN,UB ROW,5),"^" ,1),"*",2)
  22579   "RTN","CHM FA141",463 ,0)
  22580    Q:RWDX="" &(RWSV="")
  22581   "RTN","CHM FA141",464 ,0)
  22582    F RCOL=0: 1:18 D
  22583   "RTN","CHM FA141",465 ,0)
  22584    .I RCOL=0  S ^UTILIT Y($J,"RCHD ME",BEN,LS TRW+UBROW, RCOL)=^UTI LITY($J,"C HDME",BEN, UBROW,RCOL )+LSTRW
  22585   "RTN","CHM FA141",466 ,0)
  22586    .E  S ^UT ILITY($J," RCHDME",BE N,LSTRW+UB ROW,RCOL)= ^UTILITY($ J,"CHDME", BEN,UBROW, RCOL)
  22587   "RTN","CHM FA141",467 ,0)
  22588    S ROW1=LS TRW
  22589   "RTN","CHM FA141",468 ,0)
  22590    F CTR=1:1 :RPNM D
  22591   "RTN","CHM FA141",469 ,0)
  22592    .S RRW=0  F  S RRW=$ O(^UTILITY ($J,"RCHDM E",BEN,RRW )) Q:'RRW   D
  22593   "RTN","CHM FA141",470 ,0)
  22594    ..F FLD=0 :1:18 D
  22595   "RTN","CHM FA141",471 ,0)
  22596    ...;DEFEC T 866501 -  TGH - 8/1 9/2018 - A lso repair ed two syn tax errors  during co mpile
  22597   "RTN","CHM FA141",472 ,0)
  22598    ...;I FLD =0 $P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "U",1)=ROW 1  ; CPE00 5-009 Freq uency code  5.  Add b olding to  original i tems
  22599   "RTN","CHM FA141",473 ,0)
  22600    ...I FLD= 0 S $P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"U",1)=RO W1  ; CPE0 05-009 Fre quency cod e 5.  Add  bolding to  original  items
  22601   "RTN","CHM FA141",474 ,0)
  22602    ...E  S ^ UTILITY($J ,"CHDME",B EN,ROW1,FL D)=^UTILIT Y($J,"RCHD ME",BEN,RR W,FLD)
  22603   "RTN","CHM FA141",475 ,0)
  22604    ..S ROW1= ROW1+1
  22605   "RTN","CHM FA141",476 ,0)
  22606    I '$D(^UT ILITY($J," CHDME",BEN ,ROW1,0))  D
  22607   "RTN","CHM FA141",477 ,0)
  22608    .F FLD=0: 1:18 D
  22609   "RTN","CHM FA141",478 ,0)
  22610    ..I FLD=0  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=ROW 1 Q
  22611   "RTN","CHM FA141",479 ,0)
  22612    ..I FLD<3  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=^UT ILITY($J," CHDME",BEN ,ROW1-1,FL D) Q
  22613   "RTN","CHM FA141",480 ,0)
  22614    ..I FLD=7  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=1 Q
  22615   "RTN","CHM FA141",481 ,0)
  22616    ..I FLD>2  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=""  Q
  22617   "RTN","CHM FA141",482 ,0)
  22618    D INIT,RE DISP
  22619   "RTN","CHM FA141",483 ,0)
  22620    S RPTFLG= ""
  22621   "RTN","CHM FA141",484 ,0)
  22622    Q
  22623   "RTN","CHM FA141",485 ,0)
  22624   REDISP ;RE -DISPLAY S CREEN
  22625   "RTN","CHM FA141",486 ,0)
  22626    S DY=CHSD Y-1 F ROW1 =1:1:CHLR  D
  22627   "RTN","CHM FA141",487 ,0)
  22628    .S DY=DY+ 1 I DY=(CH SDY+CHWIN)  D
  22629   "RTN","CHM FA141",488 ,0)
  22630    .. S DY=C HSDY+CHWIN -1,CHWINLR =CHWINLR+1 ,CHWINHR=C HWINHR+1
  22631   "RTN","CHM FA141",489 ,0)
  22632    .. S DX=1 ,$X=DX X X Y W !
  22633   "RTN","CHM FA141",490 ,0)
  22634    .; CPE005 -009 Frequ ency code  5.  Add bo lding to o riginal it ems
  22635   "RTN","CHM FA141",491 ,0)
  22636    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,0)," ^",2)=1 W  @CHBON  ;C PE005-009  BDB
  22637   "RTN","CHM FA141",492 ,0)
  22638    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,0)," ^",2)'=1 W  @CHBOFF   ;CPE005-00 9 BDB
  22639   "RTN","CHM FA141",493 ,0)
  22640    .F FLD=0: 1:8,16 D F LDLNG S DX =CFDX,$X=D X X XY D
  22641   "RTN","CHM FA141",494 ,0)
  22642    ..;I FLD= 2 D CHKPOS  Q   ;JEH  8/1/13 DEV 007820 - P OST SLA FI X
  22643   "RTN","CHM FA141",495 ,0)
  22644    ..Q:'$D(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D))  ;JEH  11/12/13 D EF019382 -  ADD $D CH ECK
  22645   "RTN","CHM FA141",496 ,0)
  22646    ..Q:^UTIL ITY($J,"CH DME",BEN,R OW1,FLD)=" " ;JSG;01/ 31/08;DEV0 03956;Shou ld no long er error w ith UNDEF
  22647   "RTN","CHM FA141",497 ,0)
  22648    ..I FLD=8 !(FLD=16)  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)'="" W  $J($FN($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1)," ",2),FL) Q   ;aeb 1/1 0/2008 DEF 003367 add ed to show  rev code
  22649   "RTN","CHM FA141",498 ,0)
  22650    ..I FLD=5  X XY W $J ($P($P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"*",2),U, 1),FL) Q    ;JEH 2/1/ 11 DEV0078 20
  22651   "RTN","CHM FA141",499 ,0)
  22652    ..I FLD=6  D  Q   ;J EH 2/1/11  DEV007820
  22653   "RTN","CHM FA141",500 ,0)
  22654    ...I $L($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),"*", 1))>4 D
  22655   "RTN","CHM FA141",501 ,0)
  22656    ....W $J( "*"_$E($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),"*",1) ,1,4),5)
  22657   "RTN","CHM FA141",502 ,0)
  22658    ...E  W $ J($E($P(^U TILITY($J, "CHDME",BE N,ROW1,FLD ),"*",1),1 ,4),5)
  22659   "RTN","CHM FA141",503 ,0)
  22660    ..I FLD=7 &($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)[".") D  CHKUNT Q     ;JEH 2/ 1/11 DEV00 7820
  22661   "RTN","CHM FA141",504 ,0)
  22662    ..W @CHEO L,$J($P(^U TILITY($J, "CHDME",BE N,ROW1,FLD ),U,1),FL)
  22663   "RTN","CHM FA141",505 ,0)
  22664    .;JSG;01/ 31/08;DEV0 03956-02;I f DOS="",  stop displ ay and ask  user to d eal with i t
  22665   "RTN","CHM FA141",506 ,0)
  22666    .I $D(^UT ILITY($J," CHDME",BEN ,ROW1,1))  D NODOS:$E ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,1),U))= "_"    ;If  "__/__/__ ", then no  DOS  ;JEH  11/12/13  DEF019382  - ADD $D C HECK
  22667   "RTN","CHM FA141",507 ,0)
  22668    W @CHBOFF
  22669   "RTN","CHM FA141",508 ,0)
  22670    D CHSMT(8 )   ;CHECK /DISPLAY T OTALS
  22671   "RTN","CHM FA141",509 ,0)
  22672    D CHSMT(1 6)   ;CHEC K/DISPLAY  TOTALS
  22673   "RTN","CHM FA141",510 ,0)
  22674    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  22675   "RTN","CHM FA141",511 ,0)
  22676    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1
  22677   "RTN","CHM FA141",512 ,0)
  22678    S SFLD=1
  22679   "RTN","CHM FA141",513 ,0)
  22680    Q
  22681   "RTN","CHM FA141",514 ,0)
  22682    ;
  22683   "RTN","CHM FA141",515 ,0)
  22684   RDPLYPR ;R EDISPLAY P /R TOTALS
  22685   "RTN","CHM FA141",516 ,0)
  22686    Q:$D(RPFL G)
  22687   "RTN","CHM FA141",517 ,0)
  22688    N RDY,RCH SDY,RROW1, RCHLR,RCHW IN,RCHWINL R,RCHWINHR ,RDX,RFLD
  22689   "RTN","CHM FA141",518 ,0)
  22690    S RDY=DY, RCHSDY=CHS DY,RCHLR=C HLR,RCHWIN =CHWIN,RCH WINLR=CHWI NLR,RCHWIN HR=CHWINHR ,RDX=DX,RF LD=FLD
  22691   "RTN","CHM FA141",519 ,0)
  22692    N ROWCTR
  22693   "RTN","CHM FA141",520 ,0)
  22694    S ROWCTR= CHWINHR
  22695   "RTN","CHM FA141",521 ,0)
  22696    S FLD=16  D FLDLNG S  DX=CFDX,$ X=DX X XY
  22697   "RTN","CHM FA141",522 ,0)
  22698    I ROWCTR> CHLR S ROW CTR=CHLR
  22699   "RTN","CHM FA141",523 ,0)
  22700    S DY=CHSD Y-1 F ROW1 =CHWINLR:1 :ROWCTR D
  22701   "RTN","CHM FA141",524 ,0)
  22702    .S DY=DY+ 1
  22703   "RTN","CHM FA141",525 ,0)
  22704    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U,1)'=""  X XY W $J( $FN($P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U,1),"",2 ),FL)
  22705   "RTN","CHM FA141",526 ,0)
  22706    S DY=RDY, CHSDY=RCHS DY,CHLR=RC HLR,CHWIN= RCHWIN,CHW INLR=RCHWI NLR,CHWINH R=RCHWINHR ,DX=RDX,FL D=RFLD
  22707   "RTN","CHM FA141",527 ,0)
  22708    D FLDLNG  S DX=RDX,$ X=DX,DY=RD Y,$Y=DY X  XY
  22709   "RTN","CHM FA141",528 ,0)
  22710    Q
  22711   "RTN","CHM FA141",529 ,0)
  22712   CHKPOS ;CH ECK/DISPLA Y WHEN POS  IS MISSIN G     ;JEH  8/1/13 DE V007820 -  POST FIX
  22713   "RTN","CHM FA141",530 ,0)
  22714    I CHMFSRV C=4 Q   ;D ME DOESN'T  HAVE POS
  22715   "RTN","CHM FA141",531 ,0)
  22716    I ^UTILIT Y($J,"CHDM E",BEN,ROW 1,1)="DELE TED" Q
  22717   "RTN","CHM FA141",532 ,0)
  22718    I ^UTILIT Y($J,"CHDM E",BEN,ROW 1,3)="" I  ^UTILITY($ J,"CHDME", BEN,ROW1,5 )="" I ^UT ILITY($J," CHDME",BEN ,ROW1,2)=" " Q
  22719   "RTN","CHM FA141",533 ,0)
  22720    I $P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,2)="" D
  22721   "RTN","CHM FA141",534 ,0)
  22722    .W @CHBLN KON,$J(" ?  ",FL),@CH BLNKOFF
  22723   "RTN","CHM FA141",535 ,0)
  22724    .D CURSAV ^CHMFA141, ERAMSG^CHM FA141:MSGF LG,MARMES^ CHMFA141 S  IOSL=3,DX =1,$X=DX,D Y=CHMDY X  XY
  22725   "RTN","CHM FA141",536 ,0)
  22726    .W !?2,@C HBLNKON,"* ** ISSUE * **",@CHBLN KOFF," - P LEASE CHEC K 'POS' CO LUMN."
  22727   "RTN","CHM FA141",537 ,0)
  22728    .D MARSCR ^CHMFA141, CURRES^CHM FA141 S IO SL=9,MSGFL G=1
  22729   "RTN","CHM FA141",538 ,0)
  22730    E  D
  22731   "RTN","CHM FA141",539 ,0)
  22732    .W @CHEOL ,$J($P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U,1),FL)
  22733   "RTN","CHM FA141",540 ,0)
  22734    Q
  22735   "RTN","CHM FA141",541 ,0)
  22736   CHKUNT ;CH ECK/DISPLA Y WHEN UNI TS ARE NOT  WHOLE NUM BER     ;J EH 2/1/11  DEV007820
  22737   "RTN","CHM FA141",542 ,0)
  22738    I $P($P(^ UTILITY($J ,"CHDME",B EN,ROW1,5) ,U),"*")=" RX" W $J($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,FL) Q
  22739   "RTN","CHM FA141",543 ,0)
  22740    E  I $L($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) )<3 W @CHB LNKON,"--> ",@CHBLNKO FF," ",$J( $P(^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD),U,1 ),3)
  22741   "RTN","CHM FA141",544 ,0)
  22742    E  W @CHB LNKON,$J($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,FL),@CHBL NKOFF
  22743   "RTN","CHM FA141",545 ,0)
  22744    D CURSAV^ CHMFA141,E RAMSG^CHMF A141:MSGFL G,MARMES^C HMFA141 S  IOSL=3,DX= 1,$X=DX,DY =CHMDY X X Y
  22745   "RTN","CHM FA141",546 ,0)
  22746    W !?2,@CH BLNKON,"** * ISSUE ** *",@CHBLNK OFF," - PL EASE CHECK  'UNT/QTY'  COLUMN."
  22747   "RTN","CHM FA141",547 ,0)
  22748    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  22749   "RTN","CHM FA141",548 ,0)
  22750    Q
  22751   "RTN","CHM FA141",549 ,0)
  22752   NODOS ;JSG ;01/31/08; DEV003956- 02;Ask use r to deal  with recor ds with no  DOS
  22753   "RTN","CHM FA141",550 ,0)
  22754    D F1HELP^ CHMFA142                                        ;Displ ay "Enter  DOS" messa ge
  22755   "RTN","CHM FA141",551 ,0)
  22756    ;
  22757   "RTN","CHM FA141",552 ,0)
  22758   NOJOY S FL D=1,ROW=RO W1 D FLDLN G                              ; Set field,  row & fie ld length
  22759   "RTN","CHM FA141",553 ,0)
  22760         S DX =CFDX,$X=D X X XY D C SBRS^CHSC2                     ; Position o n field an d READ Y
  22761   "RTN","CHM FA141",554 ,0)
  22762         I $D (DFOUT) W  *7 G NOJOY
  22763   "RTN","CHM FA141",555 ,0)
  22764         I $D (DUOUT) W  *7 G NOJOY
  22765   "RTN","CHM FA141",556 ,0)
  22766         D GE TF1^CHMFA1 42                                        ; Process us er entry
  22767   "RTN","CHM FA141",557 ,0)
  22768         I Y= ""!(Y=-1)  X XY W $P( ^UTILITY($ J,"CHDME", BEN,ROW1,1 ),U) G NOJ OY ;Entry  no good
  22769   "RTN","CHM FA141",558 ,0)
  22770         I $E (Y)="@" S  ^UTILITY($ J,"CHDME", BEN,ROW1,8 )=""     ; "@"=delete  record, s o zero $$s
  22771   "RTN","CHM FA141",559 ,0)
  22772         E  S  ^UTILITY( $J,"CHDME" ,BEN,ROW1, 1)=Y                ; Reset DOS  node, if n ot deleted
  22773   "RTN","CHM FA141",560 ,0)
  22774         X XY  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,1) ,U),FL)  ; WRITE upda ted field  on screen
  22775   "RTN","CHM FA141",561 ,0)
  22776         D CU RSAV,ERAMS G,CURRES                                  ; Clear "Ent er DOS" me ssage
  22777   "RTN","CHM FA141",562 ,0)
  22778         Q                                                         ; Go finish  procedure  display
  22779   "RTN","CHM FA141",563 ,0)
  22780    ;
  22781   "RTN","CHM FA141",564 ,0)
  22782   EXIT D CUR SAV,ERAMSG
  22783   "RTN","CHM FA141",565 ,0)
  22784   E1 D PRMPT ^CHMFA140, ASK^CHMFA1 40
  22785   "RTN","CHM FA141",566 ,0)
  22786    I $D(DFOU T)!$D(DUOU T) G E1
  22787   "RTN","CHM FA141",567 ,0)
  22788    K CHMFNEX T,CHMFPREV ,CHMFKILL, CHMFNEWB,C HMFOPRX
  22789   "RTN","CHM FA141",568 ,0)
  22790    I Y=2 D C URSV4 I $$ CDCHK^CHMF AUT4()=1 S  Y=1 D CUR RE4,INIT^C HMFA140,SE TSCR^CHMFA 140,INIT,R EDISP Q  ; JEH 9/13/1 3 ENC00438 9 - PREVEN T 99XXX MU LTIPLE DOS  DISCREPAN CIES
  22791   "RTN","CHM FA141",569 ,0)
  22792    I Y=2&('$ D(DDOUT))  D
  22793   "RTN","CHM FA141",570 ,0)
  22794    .D CURSV4
  22795   "RTN","CHM FA141",571 ,0)
  22796    .I $$PSCH K^CHMFAUT3 ()=1 S Y=1  Q  ;JEH 8 /1/13  ;AD DED MISSIN G POS CHEC K
  22797   "RTN","CHM FA141",572 ,0)
  22798    .I $$BPCH K^CHMFAUT3 ()=1 S Y=6  Q  ;JEH 2 /1/11 DEV0 07820   ;A DDED BENE  PAYMENT CH ECK FOR WH EN POS & D OS CHANGE
  22799   "RTN","CHM FA141",573 ,0)
  22800    .D CURRE4  D FLDLNG
  22801   "RTN","CHM FA141",574 ,0)
  22802    S:Y=2 CHM FNEXT=1 S: Y=3 CHMFPR EV=1 S:Y=4  CHMFKILL= 1 I $G(CHM FPRV2) S C HMFNEXT=1     ;S:Y=6  CHMFOPRX=1     ;JEH 2 /1/11 DEV0 07820 COMM ENTED OUT  Y=6
  22803   "RTN","CHM FA141",575 ,0)
  22804    I Y=3 D R STOR^CHMFA UT3("S",2)            ;JEH 2/1/1 1 DEV00782 0 - CALL R ESTORE FUN CTION (SAV E)
  22805   "RTN","CHM FA141",576 ,0)
  22806    I Y=5 D   Q
  22807   "RTN","CHM FA141",577 ,0)
  22808    .S UMIO=" O" D ^CHMF A14O,ERAMS G,MARSCR
  22809   "RTN","CHM FA141",578 ,0)
  22810    .K:$D(CHM FNEXT) CHM FNEXT K:$D (CHMFPREV)  CHMFPREV        ;JEH  2/1/11 DE V007820  N EW ROUTINE  OHI PAYME NT/MEDICAI D PAYMENTS
  22811   "RTN","CHM FA141",579 ,0)
  22812    .D INIT^C HMFA140,SE TSCR^CHMFA 140,INIT,R EDISP
  22813   "RTN","CHM FA141",580 ,0)
  22814    I Y=6!(Y= 7) D ^CHMF A14N,RSTOR ^CHMFAUT3( "S",24),ER AMSG,MARSC R K:$D(CHM FNEXT) CHM FNEXT K:$D (CHMFPREV)  CHMFPREV     ;BENE P AYMENTS     ;JEH 2/1/ 11 DEV0078 20
  22815   "RTN","CHM FA141",581 ,0)
  22816    I Y=8 D D ELSVCLN^CH MFAUTL K:$ D(CHMFNEXT ) CHMFNEXT  K:$D(CHMF PREV) CHMF PREV D INI T^CHMFA140 ,SETSCR^CH MFA140,INI T,TOTAL,EN TEDT Q   ; SKD, 6-14- 07, DEV000 197
  22817   "RTN","CHM FA141",582 ,0)
  22818    I Y=9 D ^ CHMFA02B,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV     ;OPT-O HI EDIT
  22819   "RTN","CHM FA141",583 ,0)
  22820    I Y=10 D
  22821   "RTN","CHM FA141",584 ,0)
  22822    .I '$D(^U TILITY("RE STORE",$J) ) D
  22823   "RTN","CHM FA141",585 ,0)
  22824    ..D CURSV 2
  22825   "RTN","CHM FA141",586 ,0)
  22826    ..K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV       ;JEH  2/1/11 DE V007820  N EW ROUTINE  OHI PAYME NT/MEDICAI D PAYMENTS
  22827   "RTN","CHM FA141",587 ,0)
  22828    ..D INIT^ CHMFA140,S ETSCR^CHMF A140,INIT, REDISP
  22829   "RTN","CHM FA141",588 ,0)
  22830    ..D CURRE 2 D FLDLNG
  22831   "RTN","CHM FA141",589 ,0)
  22832    .E  D
  22833   "RTN","CHM FA141",590 ,0)
  22834    ..D RSTOR ^CHMFAUT3( "R",CHMFSR VC),ERAMSG ,MARSCR
  22835   "RTN","CHM FA141",591 ,0)
  22836    ..S RSTFL =1
  22837   "RTN","CHM FA141",592 ,0)
  22838    ..K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  22839   "RTN","CHM FA141",593 ,0)
  22840    ..D INIT^ CHMFA140,S ETSCR^CHMF A140,INIT, REDISP
  22841   "RTN","CHM FA141",594 ,0)
  22842    ..D CURSA V,CURRES,F LDLNG
  22843   "RTN","CHM FA141",595 ,0)
  22844    ..I $$POS CHK^CHMFAU T3()=1 D I NIT^CHMFA1 40,SETSCR^ CHMFA140,I NIT,REDISP    ;CHECK  FOR MISSIN G POS
  22845   "RTN","CHM FA141",596 ,0)
  22846    I $D(CHMF NEXT) I $D (^CHMDIC(7 41002.21,D UZ,0)) I ' $P(^(0),"^ ",14) D  G :((RANS="A SC")!(RANS ="OP")!(RA NS="NA"))  MAIN I '$D (CHMFNEXT)  D ERAMSG  G E1  ;;DR W/JAK
  22847   "RTN","CHM FA141",597 ,0)
  22848    .;REMOVE  THE NFOR L OOP, NO LO NGER NEEDE D IF NOT A SKING THE  QUESTION
  22849   "RTN","CHM FA141",598 ,0)
  22850    .;F  D  Q :Y'=""  Q: "YNyn"'[Y   ;; DRW/JA K
  22851   "RTN","CHM FA141",599 ,0)
  22852    .;.S HY=D Y,HX=DX,DY =19,DX=20, $X=DX X XY   ;; DRW/J AK
  22853   "RTN","CHM FA141",600 ,0)
  22854    .;.W "Are  you sure  you want t o continue : " D CSBR S^CHSC2  ; ;DRW/JAK
  22855   "RTN","CHM FA141",601 ,0)
  22856    .;.Q  ;;D RW/JAK .I  $D(DUOUT)  K CHMFNEXT  Q
  22857   "RTN","CHM FA141",602 ,0)
  22858    .;I $D(DF OUT) K CHM FNEXT Q
  22859   "RTN","CHM FA141",603 ,0)
  22860    .;I "Nn"[ Y K CHMFNE XT S DY=HY ,DX=HX,$X= DX Q
  22861   "RTN","CHM FA141",604 ,0)
  22862    .;RESUME  HERE after  removing  continue p rompt
  22863   "RTN","CHM FA141",605 ,0)
  22864    .;DEFECT  866501 - T GH - 8/19/ 2018 - Def ine HX and  HY for us e in displ ay below
  22865   "RTN","CHM FA141",606 ,0)
  22866    .S HY=DY, HX=DX,DY=1 9,DX=20,$X =DX X XY
  22867   "RTN","CHM FA141",607 ,0)
  22868    .;
  22869   "RTN","CHM FA141",608 ,0)
  22870    .Q:'$D(^C HMIMAGE(CH MFPDI,1,1, 2,1,"VEN") )
  22871   "RTN","CHM FA141",609 ,0)
  22872    .S CHVENP T=$P(^CHMI MAGE(CHMFP DI,1,CHMFP GNM,2,1,"V EN"),"^",1 ) Q:CHVENP T=""  ;;DE V014683 DR W 03/23/12
  22873   "RTN","CHM FA141",610 ,0)
  22874    .Q:'$D(^C HMVEN(CHVE NPT,1))  S  CHVIMOD=0  D ^CHMFA1 4T                      ;;DEV010 291 DRW 12 /01/11 Thi s routine  checks for  ASC facil ity type
  22875   "RTN","CHM FA141",611 ,0)
  22876    .S ROW=0, CHPOS=0 F   S ROW=$O( ^UTILITY($ J,"CHDME", BEN,ROW))  Q:'ROW!(CH POS=50)  D
  22877   "RTN","CHM FA141",612 ,0)
  22878    ..I ROW=" " S DY=HY, DX=HX,$X=D X Q
  22879   "RTN","CHM FA141",613 ,0)
  22880    ..S CHPOS =$P(^UTILI TY($J,"CHD ME",BEN,RO W,2),U,2)
  22881   "RTN","CHM FA141",614 ,0)
  22882    .I ((($E( CHVIMOD,1) '="A"&(CHP OS=50))!($ E(CHVIMOD, 1)="A"&(CH POS'=50))) &(($G(ASCS W)'=1))) D   S DY=HY, DX=HX,$X=D X Q   ;;DR W/JAK 5/17 /10;DEV007 600 pop-up  if ASC ve ndor or PO S...switch  added to  restrict p op-up to o ccur only  once
  22883   "RTN","CHM FA141",615 ,0)
  22884    ..F  D  Q :(RANS="AS C"!(RANS=" OP")!(RANS ="NA"))  ; ;DRW/JAK
  22885   "RTN","CHM FA141",616 ,0)
  22886    ...S TX=2 5,TY=9,BX= 75,BY=20,V ON="",VOFF ="" D BOXF ^CHSC1(TX, TY,BX,BY)
  22887   "RTN","CHM FA141",617 ,0)
  22888    ...D CLRB OXI^CHSC1( TX,TY,BX,B Y,XY,VON,V OFF)
  22889   "RTN","CHM FA141",618 ,0)
  22890    ...S DY=1 0,DX=26 X  XY W "PLEA SE CHECK P OS SELECTI ON:"
  22891   "RTN","CHM FA141",619 ,0)
  22892    ...S DY=1 1,DX=26 X  XY W " "                              ;;DRW /JAK 5/17/ 10;DEV0076 00 ASC Ven dor and PO S removed  original i nformation al stmt
  22893   "RTN","CHM FA141",620 ,0)
  22894    ...S DY=1 2,DX=26 X  XY W " "
  22895   "RTN","CHM FA141",621 ,0)
  22896    ...;DEFEC T 866501 -  TGH - 8/1 9/2018 - M ake Popup  item reada ble by mov ing part o f line up  to first l ine
  22897   "RTN","CHM FA141",622 ,0)
  22898    ...;S DY= 13,DX=26 X  XY W " Ch oose POS ( ASC=24, "
  22899   "RTN","CHM FA141",623 ,0)
  22900    ...;S DY= 14,DX=26 X  XY W " OP =22(ON CAM PUS), OR 1 9 (OFF CAM PUS), NA=0 0): " D CS BRS^CHSC2    ;;DPT 2/ 24/16 DEV2 4194-02 DR W/JAK 5/17 /10;DEV007 600 change  display t o ASC or O P
  22901   "RTN","CHM FA141",624 ,0)
  22902    ...S DY=1 3,DX=26 X  XY W " Cho ose POS (A SC=24,  OP =22(ON CAM PUS),"
  22903   "RTN","CHM FA141",625 ,0)
  22904    ...S DY=1 4,DX=26 X  XY W " OR  19 (OFF CA MPUS), NA= 00): " D C SBRS^CHSC2    ;;DPT 2 /24/16 DEV 24194-02 D RW/JAK 5/1 7/10;DEV00 7600 chang e display  to ASC or  OP
  22905   "RTN","CHM FA141",626 ,0)
  22906    ...S Y=$$ UP^XLFSTR( Y)         ;;TT 10291  JAK/DRW 0 8/03/10 sa ve return  value in Y  to (upper case)
  22907   "RTN","CHM FA141",627 ,0)
  22908    ...I Y="0 0"!(Y="NA" ) S RANS=" NA"             ;;TT  10291 JAK/ DRW 08/03/ 10
  22909   "RTN","CHM FA141",628 ,0)
  22910    ...E  D ^ CHMFA143 S  RANS=$P(Z ICN,"^",1)      ;;TT  10291 JAK/ DRW 08/03/ 10 save th e value re turn from  CHMFA143 i n variable  RANS
  22911   "RTN","CHM FA141",629 ,0)
  22912    ...I RANS ="ASC"!(RA NS="OP") D  RESET  ;; DRW/JAK
  22913   "RTN","CHM FA141",630 ,0)
  22914    ...S ASCS W=1
  22915   "RTN","CHM FA141",631 ,0)
  22916    ...Q  ;;D RW/JAK
  22917   "RTN","CHM FA141",632 ,0)
  22918    ..S $P(ST R," ",59)= ""                  ; DRW/JAK BU G010291-05 -02 clear  out the po s descript ion after  popup goes  away
  22919   "RTN","CHM FA141",633 ,0)
  22920    ..S DX=20 ,$X=DX F D Y=9:1:20 X  XY W @CHE OL  ;;DRW/ JAK
  22921   "RTN","CHM FA141",634 ,0)
  22922    ..S DX=1, $X=DX,DY=1 5 X XY W S TR X XY  ; JAK
  22923   "RTN","CHM FA141",635 ,0)
  22924    ..S CHMFN EXT=""
  22925   "RTN","CHM FA141",636 ,0)
  22926    ..S DX=1, DY=16 X XY  W "------ ---------- ---------- ---------- ---------- ---------- ---------- ---------- ----"  ;;D RW/JAK
  22927   "RTN","CHM FA141",637 ,0)
  22928    ..Q  ;; D RW/JAK
  22929   "RTN","CHM FA141",638 ,0)
  22930    .K:$D(^UT ILITY("RES TORE",$J))  ^UTILITY( "RESTORE", $J)
  22931   "RTN","CHM FA141",639 ,0)
  22932    .Q   ;; D RW/JAK
  22933   "RTN","CHM FA141",640 ,0)
  22934    D CURRES  D FLDLNG
  22935   "RTN","CHM FA141",641 ,0)
  22936    K CHKFLG    ;JEH 9/1 3/13 - ENC 004389
  22937   "RTN","CHM FA141",642 ,0)
  22938    Q
  22939   "RTN","CHM FA141",643 ,0)
  22940   DOWN D CUR SAV
  22941   "RTN","CHM FA141",644 ,0)
  22942    I $P(^UTI LITY($J,"C HDME",BEN, ROW,1),U)' ="DELETED" &($P(^UTIL ITY($J,"CH DME",BEN,R OW,3),U)=" ")&($P(^UT ILITY($J," CHDME",BEN ,ROW,4),U) ="")&($P(^ UTILITY($J ,"CHDME",B EN,ROW,5), U)="")&($P (^UTILITY( $J,"CHDME" ,BEN,ROW,6 ),U)="") D  BEEPQ G D OWNEND
  22943   "RTN","CHM FA141",645 ,0)
  22944    I $P(^UTI LITY($J,"C HDME",BEN, ROW,1),U)= "DELETED", '$D(^UTILI TY($J,"CHD ME",BEN,RO W+1)) D BE EPQ G DOWN END ;JSG;2 /29/08;BUG 003956-04; Handle dow n arrow wi th deleted  record
  22945   "RTN","CHM FA141",646 ,0)
  22946    I FLD>5 D    ;JEH 2/ 1/11 DEV00 7820
  22947   "RTN","CHM FA141",647 ,0)
  22948    .D CURSAV ,CLRLN,CUR RES   ;JEH  2/1/11 DE V007820
  22949   "RTN","CHM FA141",648 ,0)
  22950    I $D(^UTI LITY($J,"C HDME",BEN, ROW+1,5))  I FLD=6&($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW+1,5),U) ,"*")="RX" ) S CHCF=F LD,DY=DY+1 ,ROW=ROW+1     ;JEH 2 /1/11 DEV0 07820
  22951   "RTN","CHM FA141",649 ,0)
  22952    S CHCF=FL D,DY=DY+1, ROW=ROW+1
  22953   "RTN","CHM FA141",650 ,0)
  22954    I '$D(^UT ILITY($J," CHDME",BEN ,ROW)) D N EWROW
  22955   "RTN","CHM FA141",651 ,0)
  22956    I DY=(CHS DY+CHWIN)  D UPSCRL
  22957   "RTN","CHM FA141",652 ,0)
  22958    D STAFLG    ;JEH 1/2 3/07
  22959   "RTN","CHM FA141",653 ,0)
  22960   DOWNEND Q
  22961   "RTN","CHM FA141",654 ,0)
  22962   NEWROW F F LD=0:1:18  S ^UTILITY ($J,"CHDME ",BEN,ROW, FLD)="" S: FLD=7 ^UTI LITY($J,"C HDME",BEN, ROW,FLD)=1        ;JE H 2/1/11 D EV007820   CHG 0:1:8  TO 0:1:17
  22963   "RTN","CHM FA141",655 ,0)
  22964    I $D(^UTI LITY($J,"C HDME",BEN, ROW-1)) S  ^UTILITY($ J,"CHDME", BEN,ROW,1) =^UTILITY( $J,"CHDME" ,BEN,ROW-1 ,1),^UTILI TY($J,"CHD ME",BEN,RO W,2)=^UTIL ITY($J,"CH DME",BEN,R OW-1,2)
  22965   "RTN","CHM FA141",656 ,0)
  22966    S CHLR=RO W
  22967   "RTN","CHM FA141",657 ,0)
  22968    Q
  22969   "RTN","CHM FA141",658 ,0)
  22970   UP D CURSA V
  22971   "RTN","CHM FA141",659 ,0)
  22972    I FLD>5 D    ;JEH 2/ 1/11 DEV00 7820
  22973   "RTN","CHM FA141",660 ,0)
  22974    .D CURSAV ,CLRLN,CUR RES   ;JEH  2/1/11 DE V007820
  22975   "RTN","CHM FA141",661 ,0)
  22976    I FLD=6&( $P($P(^UTI LITY($J,"C HDME",BEN, ROW-1,5),U ),"*")="RX ") S:ROW-1 '=1 CHCF=F LD,DY=DY-1 ,ROW=ROW-1        ;JE H 2/1/11 D EV007820
  22977   "RTN","CHM FA141",662 ,0)
  22978    S CHCF=FL D,DY=DY-1, ROW=ROW-1
  22979   "RTN","CHM FA141",663 ,0)
  22980    I DY<CHSD Y D DNSCRL
  22981   "RTN","CHM FA141",664 ,0)
  22982    D STAFLG    ;JEH 1/2 3/07
  22983   "RTN","CHM FA141",665 ,0)
  22984    Q
  22985   "RTN","CHM FA141",666 ,0)
  22986   DNSCRL S D Y=CHSDY,CH WINLR=CHWI NLR-1,CHWI NHR=CHWINH R-1
  22987   "RTN","CHM FA141",667 ,0)
  22988    S ROW1=CH WINLR-1
  22989   "RTN","CHM FA141",668 ,0)
  22990   DN1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1)) G:'RO W1 DN2  G: ROW1>CHWIN HR DN2
  22991   "RTN","CHM FA141",669 ,0)
  22992    S DX=1,$X =DX,DY=CHS DY X XY W  @CHINSL
  22993   "RTN","CHM FA141",670 ,0)
  22994    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  22995   "RTN","CHM FA141",671 ,0)
  22996    .I FLD=0  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,0),"^" ,2)=1 W @C HBON ;CPE0 05-009 BDB  08202017
  22997   "RTN","CHM FA141",672 ,0)
  22998    .I FLD=0  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,0),"^" ,2)'=1 W @ CHBOFF ;CP E005-009 B DB 0820201 7
  22999   "RTN","CHM FA141",673 ,0)
  23000    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"*",1)=""  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),FL ) Q
  23001   "RTN","CHM FA141",674 ,0)
  23002    .I FLD=8! (FLD=16) I  $P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)'="" W $ J($FN($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),"" ,2),FL) Q   ;aeb 1/10 /2008 DEF0 03367 adde d to show  rev code
  23003   "RTN","CHM FA141",675 ,0)
  23004    .I FLD=5  X XY W $J( $P($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "*",2),U,1 ),FL) Q    ;JEH 2/1/1 1 DEV00782 0
  23005   "RTN","CHM FA141",676 ,0)
  23006    .I FLD=6  X XY W $J( $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "*",1),1,4 ),5) Q   ; JEH 2/1/11  DEV007820
  23007   "RTN","CHM FA141",677 ,0)
  23008    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)[".") D  CHKUNT Q     ;JEH 2/1 /11 DEV007 820
  23009   "RTN","CHM FA141",678 ,0)
  23010    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  23011   "RTN","CHM FA141",679 ,0)
  23012    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1),F L)
  23013   "RTN","CHM FA141",680 ,0)
  23014   DN2 D CURR ES S FLD=C HCF
  23015   "RTN","CHM FA141",681 ,0)
  23016    Q
  23017   "RTN","CHM FA141",682 ,0)
  23018   UPSCRL S D Y=CHSDY+CH WIN-1,CHWI NLR=CHWINL R+1,CHWINH R=CHWINHR+ 1
  23019   "RTN","CHM FA141",683 ,0)
  23020    S ROW1=CH WINHR+1
  23021   "RTN","CHM FA141",684 ,0)
  23022   UP1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1),-1) G: 'ROW1 UP2   G:ROW1<CH WINLR UP2
  23023   "RTN","CHM FA141",685 ,0)
  23024    S DX=1,$X =DX X XY W  !
  23025   "RTN","CHM FA141",686 ,0)
  23026    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23027   "RTN","CHM FA141",687 ,0)
  23028    .I FLD=0  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,0),"^" ,2)=1 W @C HBON ;CPE0 05-009 BDB  08202017
  23029   "RTN","CHM FA141",688 ,0)
  23030    .I FLD=0  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,0),"^" ,2)'=1 W @ CHBOFF ;CP E005-009 B DB 0820201 7
  23031   "RTN","CHM FA141",689 ,0)
  23032    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"*",1)=""  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),FL ) Q
  23033   "RTN","CHM FA141",690 ,0)
  23034    .I FLD=8! (FLD=16) I  $P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)'="" W $ J($FN($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),"" ,2),FL) Q   ;aeb 1/10 /2008 DEF0 03367 adde d to show  rev code
  23035   "RTN","CHM FA141",691 ,0)
  23036    .I FLD=5  X XY W $J( $P($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "*",2),U,1 ),FL) Q    ;JEH 2/1/1 1 DEV00782 0
  23037   "RTN","CHM FA141",692 ,0)
  23038    .I FLD=6  X XY W $J( $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "*",1),1,4 ),5) Q   ; JEH 2/1/11  DEV007820
  23039   "RTN","CHM FA141",693 ,0)
  23040    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)[".") D  CHKUNT Q     ;JEH 2/1 /11 DEV007 820
  23041   "RTN","CHM FA141",694 ,0)
  23042    .I FLD=2  D CHKPOS Q   ;JEH 8/1 /13 DEV007 820 - POST  SLA FIX
  23043   "RTN","CHM FA141",695 ,0)
  23044    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1),F L)
  23045   "RTN","CHM FA141",696 ,0)
  23046   UP2 D CURR ES S FLD=C HCF
  23047   "RTN","CHM FA141",697 ,0)
  23048    Q
  23049   "RTN","CHM FA141",698 ,0)
  23050   PREV I CHW INLR<2 W * 7 Q
  23051   "RTN","CHM FA141",699 ,0)
  23052    S CHCDX=D X,CHCF=FLD
  23053   "RTN","CHM FA141",700 ,0)
  23054    S CHWINLR =CHWINLR-C HWIN S:CHW INLR<1 CHW INLR=1
  23055   "RTN","CHM FA141",701 ,0)
  23056    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,RO W1=CHWINLR -1
  23057   "RTN","CHM FA141",702 ,0)
  23058   P1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) G:'ROW 1 P2 G:ROW 1>CHWINHR  P2
  23059   "RTN","CHM FA141",703 ,0)
  23060    S DX=1,$X =DX X XY W  @CHEOL
  23061   "RTN","CHM FA141",704 ,0)
  23062    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23063   "RTN","CHM FA141",705 ,0)
  23064    .I FLD=8! (FLD=16) I  $P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)'="" W $ J($FN($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),"" ,2),FL) Q   ;aeb 1/10 /2008 DEF0 03367 adde d to show  rev code
  23065   "RTN","CHM FA141",706 ,0)
  23066    .I FLD=5  X XY W $J( $P($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "*",2),U,1 ),FL) Q    ;JEH 2/1/1 1 DEV00782 0
  23067   "RTN","CHM FA141",707 ,0)
  23068    .I FLD=6  X XY W $J( $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "*",1),1,4 ),5) Q   ; JEH 2/1/11  DEV007820
  23069   "RTN","CHM FA141",708 ,0)
  23070    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)[".") D  CHKUNT Q     ;JEH 2/1 /11 DEV007 820
  23071   "RTN","CHM FA141",709 ,0)
  23072    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  23073   "RTN","CHM FA141",710 ,0)
  23074    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1),F L)
  23075   "RTN","CHM FA141",711 ,0)
  23076    S DY=DY+1  G P1
  23077   "RTN","CHM FA141",712 ,0)
  23078   P2 S DY=CH SDY,ROW=CH WINLR,DX=C HCDX,$X=DX ,FLD=CHCF
  23079   "RTN","CHM FA141",713 ,0)
  23080    Q
  23081   "RTN","CHM FA141",714 ,0)
  23082   NEXT I '$D (^UTILITY( $J,"CHDME" ,BEN,CHWIN HR+1)) W * 7 Q
  23083   "RTN","CHM FA141",715 ,0)
  23084    S CHCDX=D X,$X=DX,CH CF=FLD
  23085   "RTN","CHM FA141",716 ,0)
  23086    S CHWINLR =CHWINLR+C HWIN S:CHW INLR<1 CHW INLR=1
  23087   "RTN","CHM FA141",717 ,0)
  23088    I CHWINLR +CHWIN>CHL R S CHWINL R=CHLR-(CH WIN-1)
  23089   "RTN","CHM FA141",718 ,0)
  23090    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,RO W1=CHWINLR -1
  23091   "RTN","CHM FA141",719 ,0)
  23092   N1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) I 'ROW 1 D CLEAR2  G N2
  23093   "RTN","CHM FA141",720 ,0)
  23094    G:ROW1>CH WINHR N2
  23095   "RTN","CHM FA141",721 ,0)
  23096    S DX=1,$X =DX X XY W  @CHEOL
  23097   "RTN","CHM FA141",722 ,0)
  23098    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23099   "RTN","CHM FA141",723 ,0)
  23100    .I FLD=8! (FLD=16) I  $P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)'="" W $ J($FN($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),"" ,2),FL) Q   ;aeb 1/10 /2008 DEF0 03367 adde d to show  rev code
  23101   "RTN","CHM FA141",724 ,0)
  23102    .I FLD=5  X XY W $J( $P($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "*",2),U,1 ),FL) Q    ;JEH 2/1/1 1 DEV00782 0
  23103   "RTN","CHM FA141",725 ,0)
  23104    .I FLD=6  X XY W $J( $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "*",1),1,4 ),5) Q   ; JEH 2/1/11  DEV007820
  23105   "RTN","CHM FA141",726 ,0)
  23106    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)[".") D  CHKUNT Q     ;JEH 2/1 /11 DEV007 820
  23107   "RTN","CHM FA141",727 ,0)
  23108    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  23109   "RTN","CHM FA141",728 ,0)
  23110    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1),F L)
  23111   "RTN","CHM FA141",729 ,0)
  23112    S DY=DY+1  G N1
  23113   "RTN","CHM FA141",730 ,0)
  23114   N2 S DY=CH SDY,ROW=CH WINLR,DX=C HCDX,$X=DX ,FLD=CHCF
  23115   "RTN","CHM FA141",731 ,0)
  23116    Q
  23117   "RTN","CHM FA141",732 ,0)
  23118   CLEAR2 S H Y=DY,DX=1, $X=DX F DY =HY:1:CHSD Y+CHWIN-1  X XY W @CH EOL
  23119   "RTN","CHM FA141",733 ,0)
  23120    Q
  23121   "RTN","CHM FA141",734 ,0)
  23122   CURSAV S C HCDX=DX,CH CDY=DY
  23123   "RTN","CHM FA141",735 ,0)
  23124    Q
  23125   "RTN","CHM FA141",736 ,0)
  23126   CURSV2 S C HCDX2=CHCD X,CHCDY2=C HCDY,SVFLD =FLD    ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  23127   "RTN","CHM FA141",737 ,0)
  23128    Q
  23129   "RTN","CHM FA141",738 ,0)
  23130   CURSV3 S C HCDX3=CHCD X,CHCDY3=C HCDY,SVFLD 3=FLD   ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  23131   "RTN","CHM FA141",739 ,0)
  23132    Q
  23133   "RTN","CHM FA141",740 ,0)
  23134   CURSV4 S S VRW=ROW,SV RW1=$G(ROW 1),SVDX=DX ,SVDY=DY,S VFL=FLD     ;JEH 9/13 /13 - ENC0 04389 ;JEH  3/4/16 DE F004389 BU G FIX
  23135   "RTN","CHM FA141",741 ,0)
  23136    Q
  23137   "RTN","CHM FA141",742 ,0)
  23138   CURSV5 S C HCDX5=DX,C HCDY5=DY
  23139   "RTN","CHM FA141",743 ,0)
  23140    Q
  23141   "RTN","CHM FA141",744 ,0)
  23142   CURRES S D X=CHCDX,$X =DX,DY=CHC DY
  23143   "RTN","CHM FA141",745 ,0)
  23144    Q
  23145   "RTN","CHM FA141",746 ,0)
  23146   CURRE2 S D X=CHCDX2,$ X=DX,DY=CH CDY2,FLD=S VFLD    ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  23147   "RTN","CHM FA141",747 ,0)
  23148    Q
  23149   "RTN","CHM FA141",748 ,0)
  23150   CURRE3 S D X=CHCDX3,$ X=DX,DY=CH CDY3,FLD=S VFLD3   ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  23151   "RTN","CHM FA141",749 ,0)
  23152    Q
  23153   "RTN","CHM FA141",750 ,0)
  23154   CURRE4 S R OW=SVRW,RO W1=SVRW1,D X=SVDX,$X= DX,DY=SVDY ,FLD=SVFL  X XY   ;JE H 9/13/13  - ENC00438 9
  23155   "RTN","CHM FA141",751 ,0)
  23156    Q
  23157   "RTN","CHM FA141",752 ,0)
  23158   CURRE5 S D X=CHCDX5,$ X=DX,DY=CH CDY5
  23159   "RTN","CHM FA141",753 ,0)
  23160    Q
  23161   "RTN","CHM FA141",754 ,0)
  23162   MARSCR S D TM=CHSDY+1 ,DBM=CHSDY +CHWIN X C HMAR   ;SK D, DTM=CHS DY,DBM=CHS DY+CHWIN-1
  23163   "RTN","CHM FA141",755 ,0)
  23164    Q
  23165   "RTN","CHM FA141",756 ,0)
  23166   MARMES S D TM=CHMDY+1 ,DBM=21 X  CHMAR    ; JEH 12/6/0 6  S DTM=C HMDY,DBM=2 0 X CHMAR    ;JEH 2/1 /11 DEV007 820 - CHGD  DBM=20 TO  21
  23167   "RTN","CHM FA141",757 ,0)
  23168    Q
  23169   "RTN","CHM FA141",758 ,0)
  23170   ERASCR S D X=1,$X=DX  F DY=CHSDY :1:CHSDY+C HWIN-1 X X Y W @CHEOL
  23171   "RTN","CHM FA141",759 ,0)
  23172    Q
  23173   "RTN","CHM FA141",760 ,0)
  23174   ERAMSG S D X=1,$X=DX  F DY=CHMDY :1:20 X XY  W @CHEOL
  23175   "RTN","CHM FA141",761 ,0)
  23176    Q
  23177   "RTN","CHM FA141",762 ,0)
  23178   CLRMSG I M SGFLG D CU RSAV,ERAMS G,ERROR,CU RRES S MSG FLG=0
  23179   "RTN","CHM FA141",763 ,0)
  23180    Q
  23181   "RTN","CHM FA141",764 ,0)
  23182   CLRLN ;CLE AR & REWRI TE FIELDS  6,7,8,16   ;JEH 2/1/1 1 DEV00780   ADDED SU BROUTINE
  23183   "RTN","CHM FA141",765 ,0)
  23184    N CLFLD
  23185   "RTN","CHM FA141",766 ,0)
  23186    S CLFLD=F LD
  23187   "RTN","CHM FA141",767 ,0)
  23188    ;X XY W @ CHEOL
  23189   "RTN","CHM FA141",768 ,0)
  23190    Q:'$G(ROW )
  23191   "RTN","CHM FA141",769 ,0)
  23192    F FLD=6,7 ,8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23193   "RTN","CHM FA141",770 ,0)
  23194    .I $P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), "*",1)=""  W $J($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1),FL)  Q
  23195   "RTN","CHM FA141",771 ,0)
  23196    .I FLD=6  D  Q
  23197   "RTN","CHM FA141",772 ,0)
  23198    ..I $L($P (^UTILITY( $J,"CHDME" ,BEN,ROW,F LD),"*",1) )>4 D
  23199   "RTN","CHM FA141",773 ,0)
  23200    ...W $J(" *"_$E($P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),"*",1),1 ,4),5)
  23201   "RTN","CHM FA141",774 ,0)
  23202    ..E  W $J ($E($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), "*",1),1,4 ),5)
  23203   "RTN","CHM FA141",775 ,0)
  23204    .I FLD=8  W $J($FN($ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U,1), "",2),FL)  Q
  23205   "RTN","CHM FA141",776 ,0)
  23206    .I FLD=16  W $J($FN( $P(^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD),U,1) ,"",2),FL)  Q
  23207   "RTN","CHM FA141",777 ,0)
  23208    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW,FL D),U,1),FL ) Q
  23209   "RTN","CHM FA141",778 ,0)
  23210    S FLD=CLF LD
  23211   "RTN","CHM FA141",779 ,0)
  23212    Q
  23213   "RTN","CHM FA141",780 ,0)
  23214   ERROR Q
  23215   "RTN","CHM FA141",781 ,0)
  23216    ;
  23217   "RTN","CHM FA141",782 ,0)
  23218   STAFLG ;SE T ZANSFLG  BASED ON C ODE TYPE -  ANETHESIA  CODE - 2/ 1/2007
  23219   "RTN","CHM FA141",783 ,0)
  23220    N ZCDX ;J EH 2/1/11  DEV0078
  23221   "RTN","CHM FA141",784 ,0)
  23222    S ZCDX=$P (^UTILITY( $J,"CHDME" ,BEN,ROW,5 ),U,2)
  23223   "RTN","CHM FA141",785 ,0)
  23224    Q:'$D(ZCD X)!(ZCDX=" ")
  23225   "RTN","CHM FA141",786 ,0)
  23226    I $D(^CHM SERV(ZCDX, 4)) D
  23227   "RTN","CHM FA141",787 ,0)
  23228    .S ZANSFL G=1
  23229   "RTN","CHM FA141",788 ,0)
  23230    E  D
  23231   "RTN","CHM FA141",789 ,0)
  23232    .S ZANSFL G=0
  23233   "RTN","CHM FA141",790 ,0)
  23234    Q
  23235   "RTN","CHM FA141",791 ,0)
  23236   RESET ;SET  ASC PLACE  OF SERVIC E TO DO
  23237   "RTN","CHM FA141",792 ,0)
  23238    ;AEB 9/4/ 2007
  23239   "RTN","CHM FA141",793 ,0)
  23240    I RANS="A SC" D   ;D RW/JAK 5/1 7/10;DEV00 7600 deter mine which  code,POS, &desc to r eset the c laim to
  23241   "RTN","CHM FA141",794 ,0)
  23242    .S TEMPCO DE="ASC",T EMPPOS=50, TEMPDESC=" AMBULATORY  SURGICAL  CENTER (AS C)"   ;DRW /JAK 5/17/ 10;DEV0076 00
  23243   "RTN","CHM FA141",795 ,0)
  23244    E  D   ;D RW/JAK 5/1 7/10;DEV00 7600
  23245   "RTN","CHM FA141",796 ,0)
  23246    .S TEMPCO DE="OP",TE MPPOS=2,TE MPDESC="OU TPATIENT H OSPITAL"    ;DRW/JAK  5/17/10;DE V007600
  23247   "RTN","CHM FA141",797 ,0)
  23248    S TMPROW= 0
  23249   "RTN","CHM FA141",798 ,0)
  23250   R2 S TMPRO W=$O(^UTIL ITY($J,"CH DME",BEN,T MPROW)) G: TMPROW=""  R3
  23251   "RTN","CHM FA141",799 ,0)
  23252    S CHPOS=$ P(^UTILITY ($J,"CHDME ",BEN,TMPR OW,2),U,2)
  23253   "RTN","CHM FA141",800 ,0)
  23254    S $P(^UTI LITY($J,"C HDME",BEN, TMPROW,2), U,1)=TEMPC ODE    ;;D RW/JAK 5/1 7/10;DEV00 7600 ASC o r OP
  23255   "RTN","CHM FA141",801 ,0)
  23256    S $P(^UTI LITY($J,"C HDME",BEN, TMPROW,2), U,2)=TEMPP OS     ;;D RW/JAK 5/1 7/10;DEV00 7600 2(OP)  or 50(ASC )
  23257   "RTN","CHM FA141",802 ,0)
  23258    S $P(^UTI LITY($J,"C HDME",BEN, TMPROW,2), U,3)=TEMPD ESC    ;;D RW/JAK 5/1 7/10;DEV00 7600 descr iption for  ASC or OP
  23259   "RTN","CHM FA141",803 ,0)
  23260    G R2
  23261   "RTN","CHM FA141",804 ,0)
  23262   R3 Q:'$D(C HEQP(BEN))   S TMPI=0
  23263   "RTN","CHM FA141",805 ,0)
  23264   R4 S TMPI= $O(CHEQP(B EN,TMPI))  Q:'TMPI
  23265   "RTN","CHM FA141",806 ,0)
  23266    S TMPJ=0
  23267   "RTN","CHM FA141",807 ,0)
  23268   R5 S TMPJ= $O(CHEQP(B EN,TMPI,TM PJ)) G:'TM PJ R4
  23269   "RTN","CHM FA141",808 ,0)
  23270    G:TMPJ'=2  R5        ;!($P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,2)'=50) R 5       ;; DRW/JAK 5/ 17/10;DEV0 07600
  23271   "RTN","CHM FA141",809 ,0)
  23272    S $P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,1)=TEMPCO DE                ;;D RW/JAK 5/1 7/10;DEV00 7600 ASC(a mbulatory  surgery ce nter) or O P(outpatie nt hospita l)
  23273   "RTN","CHM FA141",810 ,0)
  23274    S $P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,2)=TEMPPO S                 ;;D RW/JAK 5/1 7/10;DEV00 7600
  23275   "RTN","CHM FA141",811 ,0)
  23276    S $P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,3)=TEMPDE SC                ;;D RW/JAK 5/1 7/10;DEV00 7600
  23277   "RTN","CHM FA141",812 ,0)
  23278    G R5
  23279   "RTN","CHM FA141",813 ,0)
  23280    Q
  23281   "RTN","CHM FA141",814 ,0)
  23282   CHSMT(CHST )   ;CHECK /DISPLAY T OTALS
  23283   "RTN","CHM FA141",815 ,0)
  23284    N CHSMT,C HSDTTL
  23285   "RTN","CHM FA141",816 ,0)
  23286    I CHSUM(C HST)'=$$SU MDME(CHST)  S CHSUM(C HST)=$$SUM DME(CHST)  D
  23287   "RTN","CHM FA141",817 ,0)
  23288    .S SVFLD= FLD,FLD=CH ST D CURSA V,FLDLNG S  DX=CFDX,$ X=DX,DY=14
  23289   "RTN","CHM FA141",818 ,0)
  23290    .S:'$D(DD TOTAL(CHST )) DDTOTAL (CHST)=0 S  CHSUM(CHS T)=CHSUM(C HST)+DDTOT AL(CHST)
  23291   "RTN","CHM FA141",819 ,0)
  23292    .S DX=CFD X,$X=DX X  XY W @CHBO N,$J($FN(C HSUM(CHST) ,",",2),FL ),@CHBOFF    ;JEH 5/3 /10 ADD LI NE
  23293   "RTN","CHM FA141",820 ,0)
  23294    .S FLD=SV FLD D FLDL NG D CURRE S X XY   ; JEH 5/3/10  ADD LINE
  23295   "RTN","CHM FA141",821 ,0)
  23296    Q
  23297   "RTN","CHM FA141",822 ,0)
  23298   AFSET() ;C HECK IF AU TOFLAG IS  SET    ;JE H 2/1/11 D EV007820
  23299   "RTN","CHM FA141",823 ,0)
  23300    N AFLD
  23301   "RTN","CHM FA141",824 ,0)
  23302    S AFLD=0
  23303   "RTN","CHM FA141",825 ,0)
  23304    S CFLD=0  F  S CFLD= $O(^UTILIT Y($J,"CHDM E",BEN,CFL D)) Q:'CFL D!(AFLD=1)   D
  23305   "RTN","CHM FA141",826 ,0)
  23306    .Q:$P(^UT ILITY($J," CHDME",BEN ,CFLD,5)," ^",1)=""
  23307   "RTN","CHM FA141",827 ,0)
  23308    .I $P(^UT ILITY($J," CHDME",BEN ,CFLD,17), "^",1)=1 S  AFLD=1
  23309   "RTN","CHM FA141",828 ,0)
  23310    Q AFLD
  23311   "RTN","CHM FA141",829 ,0)
  23312   CHKDSTR ;    ;JEH 2/1 /11 DEV007 820 - CHEC K FOR RE-D ISTRIBUTIO N OF P/R
  23313   "RTN","CHM FA141",830 ,0)
  23314    N TTLCHRG ,AROW,ARAT IO,TLNCHRG ,ADIFF,LNC HRG,CFLD,A FLD,RDFLG
  23315   "RTN","CHM FA141",831 ,0)
  23316    S CFLD=0  F  S CFLD= $O(^UTILIT Y($J,"CHDM E",BEN,CFL D)) Q:'CFL D!($D(AFLD ))  D
  23317   "RTN","CHM FA141",832 ,0)
  23318    .Q:$P(^UT ILITY($J," CHDME",BEN ,CFLD,5)," ^",1)=""
  23319   "RTN","CHM FA141",833 ,0)
  23320    .I $P(^UT ILITY($J," CHDME",BEN ,CFLD,17), "^",1)'=1  S AFLD=""
  23321   "RTN","CHM FA141",834 ,0)
  23322    Q:$D(AFLD )
  23323   "RTN","CHM FA141",835 ,0)
  23324    S TTLCHRG =""    ;SE TTING TOTA L CHARGE
  23325   "RTN","CHM FA141",836 ,0)
  23326    S (TTLPR, TTLAO)=""
  23327   "RTN","CHM FA141",837 ,0)
  23328    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  23329   "RTN","CHM FA141",838 ,0)
  23330    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  23331   "RTN","CHM FA141",839 ,0)
  23332    .S:^UTILI TY($J,"CHD ME",BEN,AR OW,11)'=""  TTLPR=TTL PR+^UTILIT Y($J,"CHDM E",BEN,ARO W,11)
  23333   "RTN","CHM FA141",840 ,0)
  23334    .S:^UTILI TY($J,"CHD ME",BEN,AR OW,12)'=""  TTLAO=TTL AO+^UTILIT Y($J,"CHDM E",BEN,ARO W,12)
  23335   "RTN","CHM FA141",841 ,0)
  23336    D AUTODST (TTLPR,11)
  23337   "RTN","CHM FA141",842 ,0)
  23338    D AUTODST (TTLAO,12)
  23339   "RTN","CHM FA141",843 ,0)
  23340    Q
  23341   "RTN","CHM FA141",844 ,0)
  23342   AUTODST(AO HIP,AFLD)  ;AUTO DIST RIBUTE TOT ALS TO LIN E ITEMS
  23343   "RTN","CHM FA141",845 ,0)
  23344    N TTLCHRG ,AROW,ARAT IO,TLNCHRG ,ADIFF,LNC HRG
  23345   "RTN","CHM FA141",846 ,0)
  23346    S TTLCHRG =0    ;GET TING TOTAL  CHARGE
  23347   "RTN","CHM FA141",847 ,0)
  23348    I AOHIP=" "!(+AOHIP= 0) D  Q
  23349   "RTN","CHM FA141",848 ,0)
  23350    .S AROW=0  F  S AROW =$O(^UTILI TY($J,"CHD ME",BEN,AR OW)) Q:'AR OW  D
  23351   "RTN","CHM FA141",849 ,0)
  23352    ..Q:$P(^U TILITY($J, "CHDME",BE N,AROW,5), "^",1)=""
  23353   "RTN","CHM FA141",850 ,0)
  23354    ..S ^UTIL ITY($J,"CH DME",BEN,A ROW,AFLD)= AOHIP
  23355   "RTN","CHM FA141",851 ,0)
  23356    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  23357   "RTN","CHM FA141",852 ,0)
  23358    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  23359   "RTN","CHM FA141",853 ,0)
  23360    .S TTLCHR G=TTLCHRG+ ^UTILITY($ J,"CHDME", BEN,AROW,8 )
  23361   "RTN","CHM FA141",854 ,0)
  23362    Q:TTLCHRG =0             ;JEH 9 /4/13 - FI X <DIVIDE>  ERROR
  23363   "RTN","CHM FA141",855 ,0)
  23364    S ARATIO= AOHIP/TTLC HRG  ;SETT ING AUTODS T RATIO
  23365   "RTN","CHM FA141",856 ,0)
  23366    S TLNCHRG =0   ;TOTA L LINE CHA RGE
  23367   "RTN","CHM FA141",857 ,0)
  23368    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  23369   "RTN","CHM FA141",858 ,0)
  23370    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  23371   "RTN","CHM FA141",859 ,0)
  23372    .S LNCHRG (AROW)=$FN (ARATIO*^U TILITY($J, "CHDME",BE N,AROW,8), "",2)
  23373   "RTN","CHM FA141",860 ,0)
  23374    .S TLNCHR G=TLNCHRG+ LNCHRG(ARO W)
  23375   "RTN","CHM FA141",861 ,0)
  23376    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  23377   "RTN","CHM FA141",862 ,0)
  23378    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  23379   "RTN","CHM FA141",863 ,0)
  23380    .S ^UTILI TY($J,"CHD ME",BEN,AR OW,AFLD)=L NCHRG(AROW )
  23381   "RTN","CHM FA141",864 ,0)
  23382    .S ^UTILI TY($J,"CHD ME",BEN,AR OW,17)=1    ;SETTING  AUTO DISTR O FLAG
  23383   "RTN","CHM FA141",865 ,0)
  23384    I TLNCHRG >0 D
  23385   "RTN","CHM FA141",866 ,0)
  23386    .I (AOHIP #TLNCHRG)' =0 D
  23387   "RTN","CHM FA141",867 ,0)
  23388    ..S ADIFF =AOHIP-TLN CHRG
  23389   "RTN","CHM FA141",868 ,0)
  23390    ..S AROW= 9999 S ARO W=$O(^UTIL ITY($J,"CH DME",BEN,A ROW),-1)
  23391   "RTN","CHM FA141",869 ,0)
  23392    ..I $P(^U TILITY($J, "CHDME",BE N,AROW,5), "^",1)=""  S AROW=$O( ^UTILITY($ J,"CHDME", BEN,AROW), -1)
  23393   "RTN","CHM FA141",870 ,0)
  23394    ..S ^UTIL ITY($J,"CH DME",BEN,A ROW,AFLD)= ^UTILITY($ J,"CHDME", BEN,AROW,A FLD)+ADIFF
  23395   "RTN","CHM FA141",871 ,0)
  23396    ..S ^UTIL ITY($J,"CH DME",BEN,A ROW,17)=1    ;SETTING  AUTO DIST RO FLAG
  23397   "RTN","CHM FA141",872 ,0)
  23398    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  23399   "RTN","CHM FA141",873 ,0)
  23400    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  23401   "RTN","CHM FA141",874 ,0)
  23402    .S OPR=^U TILITY($J, "CHDME",BE N,AROW,11)
  23403   "RTN","CHM FA141",875 ,0)
  23404    .S AOP=^U TILITY($J, "CHDME",BE N,AROW,12)
  23405   "RTN","CHM FA141",876 ,0)
  23406    .I OPR<AO P D
  23407   "RTN","CHM FA141",877 ,0)
  23408    ..S TTOA= 0
  23409   "RTN","CHM FA141",878 ,0)
  23410    .E  S TTO A=OPR-AOP
  23411   "RTN","CHM FA141",879 ,0)
  23412    .I OPR="" &(AOP="")  S ^UTILITY ($J,"CHDME ",BEN,AROW ,16)=""
  23413   "RTN","CHM FA141",880 ,0)
  23414    .E  S ^UT ILITY($J," CHDME",BEN ,AROW,16)= $FN(TTOA," ",2)
  23415   "RTN","CHM FA141",881 ,0)
  23416    Q
  23417   "RTN","CHM FA150")
  23418   0^47^B1419 6240
  23419   "RTN","CHM FA150",1,0 )
  23420   CHMFA150 ; JLR/DEN;PH ARMACY E/E  DRIVER;Fe b 06, 2019 @10:17:53
  23421   "RTN","CHM FA150",2,0 )
  23422    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  23423   "RTN","CHM FA150",3,0 )
  23424    ;V1.0
  23425   "RTN","CHM FA150",4,0 )
  23426    ;JEH 2/1/ 11 DEV0078 20 - SLLA
  23427   "RTN","CHM FA150",5,0 )
  23428    ;CCSE CPE 005-012 GE F 6/7/17 -  remove pr ess return  to contin ue prompt
  23429   "RTN","CHM FA150",6,0 )
  23430    S DF=0 K  CHMFQUIT,C HHOLD,CHHO LDPY,CHTOB IL,FL
  23431   "RTN","CHM FA150",7,0 )
  23432   A1 D CLEAR  ;
  23433   "RTN","CHM FA150",8,0 )
  23434   A11 S DX=1 ,$X=DX F D Y=6:1:20 X  XY W @CHE EL
  23435   "RTN","CHM FA150",9,0 )
  23436    S CHTITLE ="PHARMACY  E/E SCREE N",CHSCREE N=""
  23437   "RTN","CHM FA150",10, 0)
  23438    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN)) I ' CHSCREEN G  END
  23439   "RTN","CHM FA150",11, 0)
  23440    D TITLE^C HMFA100,LI NE,CHOICE^ CHMFA100,H EAD,NDC,ER RORS^CHMFA 100   ;JEH  2/1/11 DE V007820 -  LINE
  23441   "RTN","CHM FA150",12, 0)
  23442   A12 D ^CHM FA151
  23443   "RTN","CHM FA150",13, 0)
  23444   A2 D PRMPT ^CHMFA100, ASK^CHMFA1 00 G:$D(DU OUT) A1 G: $D(DFOUT)  END
  23445   "RTN","CHM FA150",14, 0)
  23446    G:Y=1 A12  I Y=2 S C HMFNEXT=1  G END
  23447   "RTN","CHM FA150",15, 0)
  23448    I Y=3 D R STOR^CHMFA UT3("S",3)  K CHPHARR (DFN,BFN), CHMFDOS S  CHMFPREV=" " G EXIT   ;JEH 2/1/1 1 DEV00782 0 - CALL R ESTORE FUN CTION (SAV E)
  23449   "RTN","CHM FA150",16, 0)
  23450    I Y=4 K C HPHARR,DFN ,BFN S CHM FKILL="" G  EXIT
  23451   "RTN","CHM FA150",17, 0)
  23452    I Y=5 D   G A1   ;JE H 2/1/11 D EV007820
  23453   "RTN","CHM FA150",18, 0)
  23454    .S UMIO=" P"
  23455   "RTN","CHM FA150",19, 0)
  23456    .S:'$D(BE N) BEN=DFN _"/"_BFN
  23457   "RTN","CHM FA150",20, 0)
  23458    .D ^CHMFA 14O   ;,ER AMSG,MARSC R
  23459   "RTN","CHM FA150",21, 0)
  23460    I Y=6!(Y= 7) S DY=18 ,DX=16,$X= DX X XY D  ^CHMFA155, RSTOR^CHMF AUT3("S",2 4) G:$D(CH MFPREV) EX IT G:$D(CH MFKILL) EX IT G A12
  23461   "RTN","CHM FA150",22, 0)
  23462    I Y=8 D D ELSVCPH^CH MFAUTL K:$ D(CHMFNEXT ) CHMFNEXT  K:$D(CHMF PREV) CHMF PREV G A1    ;SKD, 6- 14-07, DEV 000197
  23463   "RTN","CHM FA150",23, 0)
  23464    I Y=9 S D Y=18,DX=16 ,$X=DX X X Y D ^CHMFA 02B G:$D(C HMFPREV) E XIT G:$D(C HMFKILL) E XIT G A12
  23465   "RTN","CHM FA150",24, 0)
  23466    I Y=10 D   G A1   ;J EH 2/1/11  DEV007820
  23467   "RTN","CHM FA150",25, 0)
  23468    .I $D(^UT ILITY("RES TORE",$J))  D
  23469   "RTN","CHM FA150",26, 0)
  23470    ..D RSTOR ^CHMFAUT3( "R",3)
  23471   "RTN","CHM FA150",27, 0)
  23472    ..S RSTFL =1
  23473   "RTN","CHM FA150",28, 0)
  23474    G A2
  23475   "RTN","CHM FA150",29, 0)
  23476   END I $D(C HMFNEXT) I  $D(^CHMDI C(741002.2 1,DUZ,0))  I '$P(^(0) ,"^",14) D   I '$D(CH MFNEXT) D  CLEAR^CHMF A151 G A2
  23477   "RTN","CHM FA150",30, 0)
  23478   E2 .S HY=D Y,HX=DX,DY =19,DX=20, $X=DX X XY
  23479   "RTN","CHM FA150",31, 0)
  23480    .; CCSE C PE005-012  GEF 6/7/17  - remove  press retu rn to cont inue promp t
  23481   "RTN","CHM FA150",32, 0)
  23482    .;W "Are  you sure y ou want to  continue:  " D CSBRS ^CHSC2
  23483   "RTN","CHM FA150",33, 0)
  23484    .;I $D(DU OUT) K CHM FNEXT Q
  23485   "RTN","CHM FA150",34, 0)
  23486    .;I $D(DF OUT) K CHM FNEXT Q
  23487   "RTN","CHM FA150",35, 0)
  23488    .;G:Y=""  E2 S Y=$E( Y) G:"YNyn "'[Y E2
  23489   "RTN","CHM FA150",36, 0)
  23490    .;I "Nn"[ Y K CHMFNE XT
  23491   "RTN","CHM FA150",37, 0)
  23492    .S DY=HY, DX=HX,$X=D X
  23493   "RTN","CHM FA150",38, 0)
  23494    K DF D:'$ D(CHMFKILL ) ^CHMFA15 4 D CLEAR
  23495   "RTN","CHM FA150",39, 0)
  23496   EXIT K DF  D KILL Q
  23497   "RTN","CHM FA150",40, 0)
  23498   KILL K CHP HARR,CHFIF LAG,CHMFPS BN,CHSCREE N,CHTITLE, DF,DX,DX,L N,Y,QU,BLN K
  23499   "RTN","CHM FA150",41, 0)
  23500    K BLNK3,C HMFDOS,CHM NDCPT,CHPH AMT,CHPHND C,CHWINHR, CHWINLR,CT ,D1OUT
  23501   "RTN","CHM FA150",42, 0)
  23502    K D2OUT,D 3OUT,D4OUT ,DBM,DTM,D DOUT,DNOUT ,DPOUT,DQO UT,DTOUT,D UOUT,ECT
  23503   "RTN","CHM FA150",43, 0)
  23504    K FLD,HCT ,HTM,HX,HY ,I,MCT,N,N ODWN,NOUP, PCHD,REC,S C,TBM,TL,X ,ZNDCN,ZZ
  23505   "RTN","CHM FA150",44, 0)
  23506    K X1,YD,Z BOTL,ZC,ZD ,ZDOSG,ZI, ZLUFLG,ZMA NUF,ZMESAG ,ZNDC,ZNDC 1,ZNDCA
  23507   "RTN","CHM FA150",45, 0)
  23508    K ZNDCCA, ZNDDT,ZNDC DES,ZNDCJ, ZNDCN,ZNDC NM,ZNDCTOT ,ZNO,ZNS,Z OUT,ZPACK
  23509   "RTN","CHM FA150",46, 0)
  23510    K ZPOINT, ZPROD,ZQUA NT,ZUNIT,D OS,HJ,I,II ,J,JJ,K,ND C,RX,F1,FL BLNK,SPC,T L
  23511   "RTN","CHM FA150",47, 0)
  23512    K CHMFQUI T,CHHOLD,C HHOLDPY,CH TOBIL,CHEQ P
  23513   "RTN","CHM FA150",48, 0)
  23514    K HTPRIOP D,TPRIOPD, HTPRIOPR,T PRIOPR,HTA DDOPD,TADD OPD    ;JE H 2/1/11 D EV007820
  23515   "RTN","CHM FA150",49, 0)
  23516    Q
  23517   "RTN","CHM FA150",50, 0)
  23518   CLEAR S DX =1,$X=DX F  DY=3:1:20  X XY W @C HEOL
  23519   "RTN","CHM FA150",51, 0)
  23520    Q
  23521   "RTN","CHM FA150",52, 0)
  23522   HEAD ;
  23523   "RTN","CHM FA150",53, 0)
  23524    S:'$D(TOC ORG) TOCOR G=""  ;JEH  2/1/11 DE V007820
  23525   "RTN","CHM FA150",54, 0)
  23526    S:'$D(TOC IPE) TOCIP E=""  ;JEH  2/1/11 DE V007820
  23527   "RTN","CHM FA150",55, 0)
  23528    U 0:0:"^% X364"
  23529   "RTN","CHM FA150",56, 0)
  23530    S DX=8,DY =4 S DX=DX ,$X=DX X X Y W @CHBON ,"OHI TOC: ",@CHBOFF, " ",TOCORG   ;JEH 2/1 /11 DEV007 820
  23531   "RTN","CHM FA150",57, 0)
  23532    S DX=48,D Y=4 S DX=D X,$X=DX X  XY W @CHBO N,"OHI Edi t TOC:",@C HBOFF," ", TOCIPE  ;J EH 2/1/11  DEV007820
  23533   "RTN","CHM FA150",58, 0)
  23534    S DY=5,DX =5,$X=DX X  XY W @CHU LON,"  DOS    "
  23535   "RTN","CHM FA150",59, 0)
  23536    S DX=14,$ X=DX X XY  W "  ICD    "   ;JEH  2/1/11 DEV 007820 - C HGD 15 to  14
  23537   "RTN","CHM FA150",60, 0)
  23538    S DX=23,$ X=DX X XY  W "             NDC            "
  23539   "RTN","CHM FA150",61, 0)
  23540    S DX=50,$ X=DX X XY  W " Units  "   ;JEH 2 /1/11 DEV0 07820 - CH GD Qty to  Unts, 63 t o 50
  23541   "RTN","CHM FA150",62, 0)
  23542    S DX=58,$ X=DX X XY  W "  Amoun t  "   ;JE H 2/1/11 D EV007820 -  CHGD 70 t o 58
  23543   "RTN","CHM FA150",63, 0)
  23544    S DX=69,$ X=DX X XY  W "  P/R B al ",@CHUL OFF Q   ;J EH 2/1/11  DEV007820
  23545   "RTN","CHM FA150",64, 0)
  23546   NDC S DY=1 6,DX=1,$X= DX X XY F  LN=1:1:78  W "-"   ;J EH 2/1/11  DEV007820  - CHGD 16  TO 17
  23547   "RTN","CHM FA150",65, 0)
  23548    Q
  23549   "RTN","CHM FA150",66, 0)
  23550    ;
  23551   "RTN","CHM FA150",67, 0)
  23552   LINE S DY= 21,DX=1,$X =DX X XY S  LN="" S $ P(LN," ",7 9)="" W @C HULON,LN,@ CHULOFF     ;JEH 2/1/ 11 DEV0078 20
  23553   "RTN","CHM FA150",68, 0)
  23554    Q
  23555   "RTN","CHM FA801")
  23556   0^48^B4882 4212
  23557   "RTN","CHM FA801",1,0 )
  23558   CHMFA801 ; HBG/DEN;CH ECK DATA E /E CLAIM S CREEN;Feb  06, 2019@1 0:18:44
  23559   "RTN","CHM FA801",2,0 )
  23560    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  23561   "RTN","CHM FA801",3,0 )
  23562    ;PT 16182  (Y2K)
  23563   "RTN","CHM FA801",4,0 )
  23564    ;;MODIFIE D BY RLC O N 4/17/95  - TO ALLOW  USERS TO  CHOOSE AN  OPTION
  23565   "RTN","CHM FA801",5,0 )
  23566    ;;WITHOUT  BEING FOR CED TO VIE W ALL PAGE S FIRST.
  23567   "RTN","CHM FA801",6,0 )
  23568    ;;kml - C ommunity C are System  Enhancmem ents (CCSE )  Epic-St ory: 005-0 13
  23569   "RTN","CHM FA801",7,0 )
  23570    N CHRTN
  23571   "RTN","CHM FA801",8,0 )
  23572    S CHRTN=$ $GETYPE(CH MFPDI)
  23573   "RTN","CHM FA801",9,0 )
  23574    I CHRTN=" ^CHMFA802"  D @CHRTN  Q
  23575   "RTN","CHM FA801",10, 0)
  23576   START S CH MFCLNM=0,C =1,U="^" K  ^UTILITY( "CHK",$J)
  23577   "RTN","CHM FA801",11, 0)
  23578   CUTIL S CH MFCLNM=$O( CHMFCLMS(C HMFCLNM))  I CHMFCLNM ="" G:C=1  END G DISP
  23579   "RTN","CHM FA801",12, 0)
  23580    S CL=CHMF CLMS(CHMFC LNM) G:'$D (@(GLPAY_" CL,0)")) C UTIL
  23581   "RTN","CHM FA801",13, 0)
  23582    S REC=^(0 ),TY=$P(RE C,U,7),VN= $P(REC,U,3 ),DOS=$P(R EC,U,8)
  23583   "RTN","CHM FA801",14, 0)
  23584    S DFN=$P( REC,U,21), BFN=$P(REC ,U,22) D T YPE,VENDOR ,DOS,BENE
  23585   "RTN","CHM FA801",15, 0)
  23586    G:BFN=""  CUTIL
  23587   "RTN","CHM FA801",16, 0)
  23588    S ^UTILIT Y("CHK",$J ,C,BFN,TY) =CHMFCLNM_ "^"_VN_"^" _DOS_"^"_C L,A(C)="", C=C+1
  23589   "RTN","CHM FA801",17, 0)
  23590    G CUTIL
  23591   "RTN","CHM FA801",18, 0)
  23592   DISP K CHC ONT,CHEDT, CHKIL,CHRT N,CHQUIT,C HUPS,CHUP
  23593   "RTN","CHM FA801",19, 0)
  23594    S ASKFL=0  D HDR S L N="" S $P( LN,"-",81) =""
  23595   "RTN","CHM FA801",20, 0)
  23596   D0 D CLEAR 2 S I="",C T=0,CT1=0  S DY=19,DX =1 U 0:0:" ^%X364" X  XY W LN    ;SKD, 6-13 -05
  23597   "RTN","CHM FA801",21, 0)
  23598    ;S DTM=9, DBM=18 X C HMAR S DY= 9,DX=1 X X Y
  23599   "RTN","CHM FA801",22, 0)
  23600    S DTM=9,D BM=19 X CH MAR S DY=9 ,DX=1 X XY    ;SKD, 3 -15-06
  23601   "RTN","CHM FA801",23, 0)
  23602   D1 S I=$O( ^UTILITY(" CHK",$J,I) ) G:'I D4  S BFN=""
  23603   "RTN","CHM FA801",24, 0)
  23604   D2 S BFN=$ O(^UTILITY ("CHK",$J, I,BFN)) G  D1:BFN=""  S TY=""
  23605   "RTN","CHM FA801",25, 0)
  23606   D3 S TY=$O (^UTILITY( "CHK",$J,I ,BFN,TY))  G D2:TY=""
  23607   "RTN","CHM FA801",26, 0)
  23608    S REC=^(T Y),CHMFCLN M=$P(REC,U ,1),CL=$P( REC,"^",4)  K FL S A( I)=""
  23609   "RTN","CHM FA801",27, 0)
  23610    W !,I,")" ,?5,CHMFCL NM W:$D(CH PEND(CHMFC LNM)) " (P )"
  23611   "RTN","CHM FA801",28, 0)
  23612    I $D(@(GL PAY_"CL,6) ")) I $P(^ (6),"^",2) '="" S REC L=$P(^(6), "^",2) I R ECL'="" I  $D(@(GLPAY _"RECL,0)" )) W ?15,$ P(^(0),"^" ,1)
  23613   "RTN","CHM FA801",29, 0)
  23614    W:$D(^CHM QCOR("C",C L)) ?15,CH MFCLNM
  23615   "RTN","CHM FA801",30, 0)
  23616    W ?26,$E( BFN,1,15), ?44,$E(TY, 1,3),?50,$ E($P(REC,U ,2),1,10), ?63,$P(REC ,U,3)
  23617   "RTN","CHM FA801",31, 0)
  23618    G D31:CHM CL(CHMFCLN M)="" S L= $L(CHMCL(C HMFCLNM)," *")
  23619   "RTN","CHM FA801",32, 0)
  23620    F P=1:1:L  W:$D(FL)  ! W ?75,$P (CHMCL(CHM FCLNM),"*" ,P) S CT=C T+1,FL=1 D :CT#10=0   Q:$D(CHANC E)
  23621   "RTN","CHM FA801",33, 0)
  23622    .Q:$P(CHM CL(CHMFCLN M),"*",P+1 )=""  K CH ANCE D ASK  Q:$D(CHAN CE)  D CLE AR2 S DY=7 ,DX=1 X XY  K FL
  23623   "RTN","CHM FA801",34, 0)
  23624    .W !,I,") ",?6,CHMFC LNM,?18,$E (BFN,1,15) ,?38,$E(TY ,1,3),?46, $E($P(REC, U,2),1,10) ,?61,$P(RE C,U,3)
  23625   "RTN","CHM FA801",35, 0)
  23626    .Q
  23627   "RTN","CHM FA801",36, 0)
  23628   D31 S CT1= CT1+1 D:'( CT1#10) AS K G:$D(CHC ONT)!($D(C HEDT))!($D (CHKIL)) D 32 Q:$D(CH QUIT)  G D 3
  23629   "RTN","CHM FA801",37, 0)
  23630   D32 K QFL, CHNEWPG
  23631   "RTN","CHM FA801",38, 0)
  23632    G:$D(CHCO NT)!($D(CH EDT))!($D( CHKIL)) D3 3
  23633   "RTN","CHM FA801",39, 0)
  23634    I $D(DQOU T) D ASK G  D33
  23635   "RTN","CHM FA801",40, 0)
  23636    I ASKFL=1  D ASK G:$ D(CHUPS) D 3
  23637   "RTN","CHM FA801",41, 0)
  23638   D33 I Y="2 " S HY=Y D  ASK4 S Y= HY G:$D(CH RENO) D32
  23639   "RTN","CHM FA801",42, 0)
  23640    G:(Y=2)!( $D(DFOUT))  END G:$D( DUOUT) D32
  23641   "RTN","CHM FA801",43, 0)
  23642    I Y=3 D ^ CHMFKILL G :'$D(CHNEW PG) D32 K  CHMCL G EN D
  23643   "RTN","CHM FA801",44, 0)
  23644   D34 D EDIT  G:$D(DFOU T) END G:$ D(QFL) DIS P
  23645   "RTN","CHM FA801",45, 0)
  23646    D ^CHMFA8 00 K CHCON T,CHEDT,CH KIL G STAR T
  23647   "RTN","CHM FA801",46, 0)
  23648   END K CHCO NT,CHEDT,C HKIL,CHREN O,CHREYES, CHQUIT,CHN OSEND Q
  23649   "RTN","CHM FA801",47, 0)
  23650   ASK S FL=3 0 I $D(CHR EOPN) D AS K1 Q
  23651   "RTN","CHM FA801",48, 0)
  23652    D CLEAR S  HY=DY,HX= DX,DY=20,D X=1 X XY
  23653   "RTN","CHM FA801",49, 0)
  23654    K CHCONT, CHEDT,CHKI L,CHRTN,CH QUIT,CHUPS
  23655   "RTN","CHM FA801",50, 0)
  23656    W "Choose  1-3 or Pr ess ",@CHB ON,"<RETUR N>",@CHBOF F," to Vie w next pag e...",!
  23657   "RTN","CHM FA801",51, 0)
  23658    W "          1) Edit ",!,"          2) Con tinue"
  23659   "RTN","CHM FA801",52, 0)
  23660    W !,"          3) Pr ocess New  Page",!!," Choose:  "
  23661   "RTN","CHM FA801",53, 0)
  23662    D CSBRS^C HSC2 G:$D( DQOUT) ASK
  23663   "RTN","CHM FA801",54, 0)
  23664    I $D(DFOU T)!($D(DUO UT)) S CHQ UIT="" Q
  23665   "RTN","CHM FA801",55, 0)
  23666    I Y="" D  CLEAR2,D35  S CHUPS=" " Q
  23667   "RTN","CHM FA801",56, 0)
  23668    G:"123"'[ Y ASK
  23669   "RTN","CHM FA801",57, 0)
  23670    I Y=2 S C HCONT="" Q
  23671   "RTN","CHM FA801",58, 0)
  23672    I Y=3 S C HKIL="" Q
  23673   "RTN","CHM FA801",59, 0)
  23674    I Y=1 S C HEDT=""
  23675   "RTN","CHM FA801",60, 0)
  23676   D35 S DTM= 9,DBM=18 X  CHMAR S D Y=8,DX=1 X  XY Q
  23677   "RTN","CHM FA801",61, 0)
  23678   ASK1 D CLE AR S HY=DY ,HX=DX,DY= 20,DX=1 X  XY
  23679   "RTN","CHM FA801",62, 0)
  23680    K CHCONT, CHEDT,CHUP S
  23681   "RTN","CHM FA801",63, 0)
  23682    W "Choose  1-2 or Pr ess ",@CHB ON,"<RETUR N>",@CHBOF F," to Vie w next pag e...",!
  23683   "RTN","CHM FA801",64, 0)
  23684    W "          1) Edit ",!,"          2) Con tinue"
  23685   "RTN","CHM FA801",65, 0)
  23686    W !!,"Cho ose: "
  23687   "RTN","CHM FA801",66, 0)
  23688    D CSBRS^C HSC2 G:$D( DQOUT) ASK 1
  23689   "RTN","CHM FA801",67, 0)
  23690    I $D(DFOU T)!$D(DUOU T) S CHQUI T="" Q
  23691   "RTN","CHM FA801",68, 0)
  23692    I Y="" D  CLEAR2,D36  S CHUPS=" " Q
  23693   "RTN","CHM FA801",69, 0)
  23694    G:"12"'[Y  ASK1
  23695   "RTN","CHM FA801",70, 0)
  23696    I Y=2 S C HCONT="" Q
  23697   "RTN","CHM FA801",71, 0)
  23698    I Y=1 S C HEDT=""
  23699   "RTN","CHM FA801",72, 0)
  23700   D36 S DTM= 9,DBM=18 X  CHMAR S D Y=9,DX=1 X  XY Q
  23701   "RTN","CHM FA801",73, 0)
  23702   D4 K QFL,C HNEWPG,CHC ONT,CHEDT, CHKIL
  23703   "RTN","CHM FA801",74, 0)
  23704    D ASK2
  23705   "RTN","CHM FA801",75, 0)
  23706    G:$D(CHUP ) DISP
  23707   "RTN","CHM FA801",76, 0)
  23708    G:$D(CHCO NT)!($D(CH EDT))!($D( CHKIL)) D4 1
  23709   "RTN","CHM FA801",77, 0)
  23710    I $D(DQOU T) D ASK2  G D41
  23711   "RTN","CHM FA801",78, 0)
  23712    I ASKFL=1  D ASK2
  23713   "RTN","CHM FA801",79, 0)
  23714   D41 I Y="2 " S HY=Y D  ASK4 S Y= HY G:$D(CH RENO) D4
  23715   "RTN","CHM FA801",80, 0)
  23716    G:(Y=2)!( $D(DFOUT))  END G:$D( DUOUT) D4
  23717   "RTN","CHM FA801",81, 0)
  23718    I Y=3 D ^ CHMFKILL G :'$D(CHNEW PG) D4 K C HMCL G END
  23719   "RTN","CHM FA801",82, 0)
  23720   D42 D EDIT  G:$D(DFOU T) END G:$ D(QFL) D4
  23721   "RTN","CHM FA801",83, 0)
  23722    D ^CHMFA8 00 K CHCON T,CHEDT,CH KIL G STAR T
  23723   "RTN","CHM FA801",84, 0)
  23724   ASK2 S FL= 30 I $D(CH REOPN) D A SK3 Q
  23725   "RTN","CHM FA801",85, 0)
  23726    K CHCONT, CHEDT,CHKI L,CHUP
  23727   "RTN","CHM FA801",86, 0)
  23728    D CLEAR S  DY=20,DX= 1 X XY W " Select:  1 ) Edit",!, "          2) Continu e"
  23729   "RTN","CHM FA801",87, 0)
  23730    W !,"          3) Pr ocess New  Page",!!," Choose:  "
  23731   "RTN","CHM FA801",88, 0)
  23732    D CSBRS^C HSC2 G:$D( DQOUT) ASK 2 Q:$D(DFO UT)
  23733   "RTN","CHM FA801",89, 0)
  23734    I $D(DUOU T) S CHUP= "" Q
  23735   "RTN","CHM FA801",90, 0)
  23736    G:Y="" AS K2
  23737   "RTN","CHM FA801",91, 0)
  23738    G:"123"'[ Y ASK2
  23739   "RTN","CHM FA801",92, 0)
  23740    I Y=2 S C HCONT="" Q
  23741   "RTN","CHM FA801",93, 0)
  23742    I Y=3 S C HKIL="" Q
  23743   "RTN","CHM FA801",94, 0)
  23744    I Y=1 S C HEDT="" Q
  23745   "RTN","CHM FA801",95, 0)
  23746   ASK3 K CHC ONT,CHEDT, CHNEXT
  23747   "RTN","CHM FA801",96, 0)
  23748    D CLEAR S  DY=20,DX= 1 X XY W " Select:  1 ) Edit",!, "          2) Continu e"
  23749   "RTN","CHM FA801",97, 0)
  23750    W !!,"Cho ose:  " D  CSBRS^CHSC 2 G:$D(DQO UT) ASK3 Q :$D(DFOUT)
  23751   "RTN","CHM FA801",98, 0)
  23752    I $D(DUOU T) S CHUP= "" Q
  23753   "RTN","CHM FA801",99, 0)
  23754    G:Y="" AS K3 G:"12"' [Y ASK3
  23755   "RTN","CHM FA801",100 ,0)
  23756    I Y=1 S C HEDT="" Q
  23757   "RTN","CHM FA801",101 ,0)
  23758    I Y=2 S C HCONT="" Q
  23759   "RTN","CHM FA801",102 ,0)
  23760   ASK4 S FL= 30 D CLEAR  I $D(CHRE OPN) G ASK 42
  23761   "RTN","CHM FA801",103 ,0)
  23762   ASK41 K CH RENO,CHREY ES S DY=19 ,DX=1 X XY
  23763   "RTN","CHM FA801",104 ,0)
  23764    W !,"Are  you sure y ou want to  continue?  " D CSBRS ^CHSC2
  23765   "RTN","CHM FA801",105 ,0)
  23766    I $D(DUOU T)!$D(DFOU T) S CHREN O="",ASKFL =1 K CHCON T,CHEDT,CH KIL D ASK4 2 Q
  23767   "RTN","CHM FA801",106 ,0)
  23768    I $D(DQOU T) W !!,"E nter <Y>es  or <N>o."  G ASK41
  23769   "RTN","CHM FA801",107 ,0)
  23770    G:Y="" AS K4 S Y=$E( Y,1) G:"Yy Nn"'[Y ASK 41
  23771   "RTN","CHM FA801",108 ,0)
  23772    I "Nn"[Y  S CHRENO=" ",ASKFL=1  K CHCONT,C HEDT,CHKIL  G ASK42
  23773   "RTN","CHM FA801",109 ,0)
  23774    S:"Yy"[Y  CHREYES=1
  23775   "RTN","CHM FA801",110 ,0)
  23776   ASK42 D CL EAR Q
  23777   "RTN","CHM FA801",111 ,0)
  23778    S DTM=9,D BM=18 X CH MAR S DY=8 ,DX=1 X XY  Q
  23779   "RTN","CHM FA801",112 ,0)
  23780   HDR ;
  23781   "RTN","CHM FA801",113 ,0)
  23782    F DY=1:1: 24 S DX=1  X XY W @CH EOL
  23783   "RTN","CHM FA801",114 ,0)
  23784    W @IOF W  @CHREVON,@ CHBON S DY =1,DX=1 U  0:0:"^%X36 4" X XY    ;SKD, 6-13 -05
  23785   "RTN","CHM FA801",115 ,0)
  23786    W "                                                          "
  23787   "RTN","CHM FA801",116 ,0)
  23788    W "                              "
  23789   "RTN","CHM FA801",117 ,0)
  23790    W !,"                                [Edit  Claim Dat a Screen]"
  23791   "RTN","CHM FA801",118 ,0)
  23792    W "                              "
  23793   "RTN","CHM FA801",119 ,0)
  23794    W !,"                                                          "
  23795   "RTN","CHM FA801",120 ,0)
  23796    W "                              "
  23797   "RTN","CHM FA801",121 ,0)
  23798    ; Y2K - a djusted fi elds to al low full y ear to dis play for D OS
  23799   "RTN","CHM FA801",122 ,0)
  23800    W @CHREVO FF W @CHBO N,!!,"PDI#  ",$G(CHMF PDI)," Rel ated Claim s:",@CHBOF F
  23801   "RTN","CHM FA801",123 ,0)
  23802    W !!,"No. ",?5,"Clai m #",?15," RO Cl #",? 26,"Bene", ?44,"Typ", ?50,"Vendo r",?63,"D. O.S",?75," D/C",!
  23803   "RTN","CHM FA801",124 ,0)
  23804    W "---",? 5,"------- ",?15,"--- ----",?26, "--------- ------",?4 4,"---",?5 0,"------- ---",?63," ---------- ",?75,"--- " Q
  23805   "RTN","CHM FA801",125 ,0)
  23806   TYPE I '$D (^CHMDIC(7 41002.05,T Y,0)) S TY ="UNKNOWN"  Q
  23807   "RTN","CHM FA801",126 ,0)
  23808    S TY=$P(^ (0),U,1) Q
  23809   "RTN","CHM FA801",127 ,0)
  23810   VENDOR ;
  23811   "RTN","CHM FA801",128 ,0)
  23812    ;I VN=""  S VN="UNKN OWN" Q                 ;SKD 11-5 -07 DEV003 626-01,BUG 002654-05- 01
  23813   "RTN","CHM FA801",129 ,0)
  23814    ;I '$D(^C HMVEN(VN,2 )) S VN="U NKNOWN" Q   ;SKD 11-5 -07 DEV003 626-01,BUG 002654-05- 01
  23815   "RTN","CHM FA801",130 ,0)
  23816    ;S VN=$E( $P(^(2),U, 8),1,10) Q             ;SKD 11-5 -07 DEV003 626-01,BUG 002654-05- 01
  23817   "RTN","CHM FA801",131 ,0)
  23818    ;SKD 11-5 -07 DEV003 626-01,BUG 002654-05- 01 lines b elow repla ce the abo ve 3 lines
  23819   "RTN","CHM FA801",132 ,0)
  23820    I $G(VN)' ="" D
  23821   "RTN","CHM FA801",133 ,0)
  23822    .S VN=$P( $G(^CHMVEN (VN,2)),U, 8)
  23823   "RTN","CHM FA801",134 ,0)
  23824    .Q:VN=""
  23825   "RTN","CHM FA801",135 ,0)
  23826    .S VN=$E( $P(^(2),U, 8),1,10)
  23827   "RTN","CHM FA801",136 ,0)
  23828    Q:VN'=""
  23829   "RTN","CHM FA801",137 ,0)
  23830    I VN="" D
  23831   "RTN","CHM FA801",138 ,0)
  23832    .Q:'$G(CL )  Q:'$D(^ CHMPAY(CL, "VEN","PS" ))
  23833   "RTN","CHM FA801",139 ,0)
  23834    .I $D(^CH MPAY(CL,"V EN","PS"))  D
  23835   "RTN","CHM FA801",140 ,0)
  23836    ..S PSVDT ="A",PSVDT =$O(^CHMPA Y(CL,"VEN" ,"PS",PSVD T),-1) Q:' PSVDT
  23837   "RTN","CHM FA801",141 ,0)
  23838    ..S VN=$P ($G(^CHMPA Y(CL,"VEN" ,"PS",PSVD T,0)),U,4)
  23839   "RTN","CHM FA801",142 ,0)
  23840    ..I VN'=" " S VN=$E( VN,1,10)
  23841   "RTN","CHM FA801",143 ,0)
  23842    Q:VN'=""
  23843   "RTN","CHM FA801",144 ,0)
  23844    I VN="" D
  23845   "RTN","CHM FA801",145 ,0)
  23846    .Q:'$G(CL )
  23847   "RTN","CHM FA801",146 ,0)
  23848    .S VN=$P( $G(^CHMPAY (CL,"ZIMAG E")),U,1)
  23849   "RTN","CHM FA801",147 ,0)
  23850    .Q:VN=""
  23851   "RTN","CHM FA801",148 ,0)
  23852    .I VN'=""  S VN=$E(V N,1,10)
  23853   "RTN","CHM FA801",149 ,0)
  23854    Q:VN'=""
  23855   "RTN","CHM FA801",150 ,0)
  23856    I VN="" S  VN="UNKNO WN"
  23857   "RTN","CHM FA801",151 ,0)
  23858    Q
  23859   "RTN","CHM FA801",152 ,0)
  23860    ;
  23861   "RTN","CHM FA801",153 ,0)
  23862   DOS ;
  23863   "RTN","CHM FA801",154 ,0)
  23864    ;Y2K - Q: DOS=""  S  DOS=$E(DOS ,4,5)_"/"_ $E(DOS,6,7 )_"/"_$E(D OS,2,3) Q
  23865   "RTN","CHM FA801",155 ,0)
  23866    Q:DOS=""   S DOS=$$F MTE^XLFDT( DOS,5) Q
  23867   "RTN","CHM FA801",156 ,0)
  23868   BENE I '$D (@(GLELG_" DFN,100,BF N,0)")) S  BFN="" Q
  23869   "RTN","CHM FA801",157 ,0)
  23870    S BFN=$P( ^(0),U) Q
  23871   "RTN","CHM FA801",158 ,0)
  23872   EDIT K B,C
  23873   "RTN","CHM FA801",159 ,0)
  23874   E1 K B D C LEAR S DY= 20,DX=1 X  XY W "Edit : " D CSBR S^CHSC2
  23875   "RTN","CHM FA801",160 ,0)
  23876    I $D(DFOU T)!$D(DUOU T) S QFL=1  K CHEDT Q
  23877   "RTN","CHM FA801",161 ,0)
  23878    S STR=Y G  E6:+STR
  23879   "RTN","CHM FA801",162 ,0)
  23880   E5 G E1:Y' ?1"A".E F  II=0:0 S I I=$O(A(II) ) Q:'II  S  B(II)=""
  23881   "RTN","CHM FA801",163 ,0)
  23882    G E10
  23883   "RTN","CHM FA801",164 ,0)
  23884   E6 G:'$D(^ UTILITY("C HK",$J,Y))  E1
  23885   "RTN","CHM FA801",165 ,0)
  23886    G E1:Y["+ ",E1:Y["=" ,E1:Y[" "
  23887   "RTN","CHM FA801",166 ,0)
  23888    F II=1:1: $L(Y,",")  S:$P(Y,"," ,II)]"" B( $P(Y,",",I I))=""
  23889   "RTN","CHM FA801",167 ,0)
  23890   E7 S II=$O (B(II)) G  E8:II="" I  II["-" K  B(II)
  23891   "RTN","CHM FA801",168 ,0)
  23892    F J=$P(II ,"-"):1:$P (II,"-",2)  S B(J)=""
  23893   "RTN","CHM FA801",169 ,0)
  23894    G E7
  23895   "RTN","CHM FA801",170 ,0)
  23896   E8 S II=0
  23897   "RTN","CHM FA801",171 ,0)
  23898   E9 S II=$O (B(II)) G: 'II E10 I  '$D(A(II))  W *7,!!," Please cho ose from t he above s elections  only!!",!  G E1
  23899   "RTN","CHM FA801",172 ,0)
  23900    G E9
  23901   "RTN","CHM FA801",173 ,0)
  23902   E10 S II=0
  23903   "RTN","CHM FA801",174 ,0)
  23904   E11 S II=$ O(B(II)) G :'II E15 S  BFN=""
  23905   "RTN","CHM FA801",175 ,0)
  23906   E12 S BFN= $O(^UTILIT Y("CHK",$J ,II,BFN))  G:BFN="" E 11 S TY=""
  23907   "RTN","CHM FA801",176 ,0)
  23908   E13 S TY=$ O(^UTILITY ("CHK",$J, II,BFN,TY) ) G:TY=""  E12 S REC= ^(TY)
  23909   "RTN","CHM FA801",177 ,0)
  23910    S CL=$P(R EC,"^"),DO S=$P(REC," ^",3),VN=$ P(REC,"^", 2),IN=$P(R EC,"^",4)
  23911   "RTN","CHM FA801",178 ,0)
  23912    S CHMED(C L)=IN_"^"_ BFN_"^"_VN _"^"_TY_"^ "_DOS G E1 3
  23913   "RTN","CHM FA801",179 ,0)
  23914   E15 ;I CHM CL(CL)=""  D E16 Q
  23915   "RTN","CHM FA801",180 ,0)
  23916    ;I CHMCL( CL)="NCL"  D E17 Q
  23917   "RTN","CHM FA801",181 ,0)
  23918    S DA=IN K  FL S CHNO SEND=1 D ^ CHMG211 D  ^CHMFSET K  CHMED,B,C ,CHDISC S  FL2=0 Q
  23919   "RTN","CHM FA801",182 ,0)
  23920   E16 W *7,! !,"Claim i s complete , editing  is not all owed!!" H  3 Q
  23921   "RTN","CHM FA801",183 ,0)
  23922    ;
  23923   "RTN","CHM FA801",184 ,0)
  23924   E17 W *7,! !,"Claim f orm is mis sing, edit ing is not  allowed!! " H 3 Q
  23925   "RTN","CHM FA801",185 ,0)
  23926    ;
  23927   "RTN","CHM FA801",186 ,0)
  23928   CLEAR F DY =20:1:24 S  DX=1 X XY  W @CHEOL
  23929   "RTN","CHM FA801",187 ,0)
  23930    Q
  23931   "RTN","CHM FA801",188 ,0)
  23932   CLEAR2 F D Y=9:1:18 S  DX=1 X XY  W @CHEOL
  23933   "RTN","CHM FA801",189 ,0)
  23934    Q
  23935   "RTN","CHM FA801",190 ,0)
  23936    ;
  23937   "RTN","CHM FA801",191 ,0)
  23938   GETYPE(CHM FPDI) ; de termine if  current P DI is a Re open and a ssign the  correct ro utine to p rocess
  23939   "RTN","CHM FA801",192 ,0)
  23940    ; input -  current P DI
  23941   "RTN","CHM FA801",193 ,0)
  23942    ; output  - returns  routine na me
  23943   "RTN","CHM FA801",194 ,0)
  23944    N X,ROUTI NE
  23945   "RTN","CHM FA801",195 ,0)
  23946    S X=$E(CH MFPDI,8,9)
  23947   "RTN","CHM FA801",196 ,0)
  23948    S ROUTINE =$S(X=90:" ^CHMFA802" ,X=97:"^CH MFA802",1: "^CHMFA801 ")
  23949   "RTN","CHM FA801",197 ,0)
  23950    Q ROUTINE
  23951   "RTN","CHM FA801",198 ,0)
  23952    ;
  23953   "RTN","CHM FADR1")
  23954   0^49^B1272 42208
  23955   "RTN","CHM FADR1",1,0 )
  23956   CHMFADR1 ; PJU/DEN;UT ILITY PROG RAM # 1 FO R MAIN DRI VER;Feb 06 , 2019@10: 19:49
  23957   "RTN","CHM FADR1",2,0 )
  23958    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  23959   "RTN","CHM FADR1",3,0 )
  23960    ;CPTS #14 989 (RLC)
  23961   "RTN","CHM FADR1",4,0 )
  23962    ;SUBROUTI NES CALLED  IN DRIVER
  23963   "RTN","CHM FADR1",5,0 )
  23964    ;CFS 08/1 6/2017 CPE 005-004 Ad d the "OCR R-READY" a nd "SBOCRR -READY" qu eues.
  23965   "RTN","CHM FADR1",6,0 )
  23966    ;JSE 10/0 6/2017 CPE 005-051 Re strict use rs to the  reopen men us
  23967   "RTN","CHM FADR1",7,0 )
  23968    ;CFS 10/0 8/2017 CPE 005-069 En sure globa l piece is  cleaned u p if not a  Re-open P DI.
  23969   "RTN","CHM FADR1",8,0 )
  23970    ;BDB 1/25 /2018 Adde d CHMFPDI  to the loc al variabl e kill lis t.
  23971   "RTN","CHM FADR1",9,0 )
  23972    ;BDB 2/8/ 2018 Added  CHFC8CIP  to the loc al variabl e kill lis t.
  23973   "RTN","CHM FADR1",10, 0)
  23974    ;CFS 12/2 0/2018 Def ect 888373  - Change  from using  variable  DT to vari able TMPDT  to preven t Undefine d error.
  23975   "RTN","CHM FADR1",11, 0)
  23976   BATCH ;
  23977   "RTN","CHM FADR1",12, 0)
  23978    I '$D(CHB TCHNO) S C HBTCHNO=$P (^CHMDIC(7 41002.21,D UZ,0),"^", 6)
  23979   "RTN","CHM FADR1",13, 0)
  23980    Q:CHBTCHN O=""
  23981   "RTN","CHM FADR1",14, 0)
  23982    I $$BTCHS T^CHMFABU3 (CHBTCHNO) =1 D
  23983   "RTN","CHM FADR1",15, 0)
  23984    .S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",6)=" "
  23985   "RTN","CHM FADR1",16, 0)
  23986    .S CHMFI= CHBTCHNO,C HMFPP="BAT CLSD"
  23987   "RTN","CHM FADR1",17, 0)
  23988    .S $P(^CH MIMPB(CHBT CHNO,0),"^ ",6)=""
  23989   "RTN","CHM FADR1",18, 0)
  23990    .D ^CHMFW K03
  23991   "RTN","CHM FADR1",19, 0)
  23992    .S J=0
  23993   "RTN","CHM FADR1",20, 0)
  23994    .F  S J=$ O(^CHMIMPB (CHBTCHNO, 100,J)) Q: 'J  I $D(^ CHMIMPB(CH BTCHNO,100 ,J,0)) I ( $P(^(0),"^ ",3)=2)!($ P(^(0),"^" ,3)=3) S C HMFPDI=$P( ^(0),"^",1 ) D SETPRO D^CHMFIMG
  23995   "RTN","CHM FADR1",21, 0)
  23996    .S CHBTCH NO=""
  23997   "RTN","CHM FADR1",22, 0)
  23998    Q
  23999   "RTN","CHM FADR1",23, 0)
  24000   COUNT S CL CT=0
  24001   "RTN","CHM FADR1",24, 0)
  24002   CO1 S CLCT =$O(CHMFCL MS(CLCT))  Q:CLCT=""
  24003   "RTN","CHM FADR1",25, 0)
  24004    S CHMQNAM ="CHMPAY(" ,CHMIN=""
  24005   "RTN","CHM FADR1",26, 0)
  24006    K CHOUT D  ^CHMIS041
  24007   "RTN","CHM FADR1",27, 0)
  24008    G CO1
  24009   "RTN","CHM FADR1",28, 0)
  24010   LSTPDI ; I f the DUZ  is unknown , print er ror messag e to scree n and quit
  24011   "RTN","CHM FADR1",29, 0)
  24012    I '$D(^CH MDIC(74100 2.21,DUZ,0 )) D NOUSE  S CHQUIT= 1 Q
  24013   "RTN","CHM FADR1",30, 0)
  24014    ; Determi ne what th e last PDI  entered b y the user  was.
  24015   "RTN","CHM FADR1",31, 0)
  24016    S LSTPDI= $P(^CHMDIC (741002.21 ,DUZ,0),"^ ",5)
  24017   "RTN","CHM FADR1",32, 0)
  24018    ; If LSTP DI is not  nil, do th e followin g.  Otherw ise return  to MANUAL ^CHMFADR4
  24019   "RTN","CHM FADR1",33, 0)
  24020    I LSTPDI' ="" D
  24021   "RTN","CHM FADR1",34, 0)
  24022    .S CHMFPD I=LSTPDI ;  Move the  value of L STPDI to C HMFPDI
  24023   "RTN","CHM FADR1",35, 0)
  24024    .S CHMFNM PG=$P($G(^ CHMIMG(CHM FPDI,0))," ^",2)
  24025   "RTN","CHM FADR1",36, 0)
  24026    .K ^CHMIM G("READY", CHMFPDI)
  24027   "RTN","CHM FADR1",37, 0)
  24028    .K ^CHMIM G("OCR-REA DY",CHMFPD I)
  24029   "RTN","CHM FADR1",38, 0)
  24030    .K ^CHMIM G("SBOCR-R EADY",CHMF PDI)
  24031   "RTN","CHM FADR1",39, 0)
  24032    .K ^CHMIM G("OCR2-RE ADY",CHMFP DI)
  24033   "RTN","CHM FADR1",40, 0)
  24034    .K ^CHMIM G("SBOCR2- READY",CHM FPDI)
  24035   "RTN","CHM FADR1",41, 0)
  24036    .K ^CHMIM G("OCRR-RE ADY",CHMFP DI) ;CPE00 5-004
  24037   "RTN","CHM FADR1",42, 0)
  24038    .K ^CHMIM G("SBOCRR- READY",CHM FPDI) ;CPE 005-004
  24039   "RTN","CHM FADR1",43, 0)
  24040    .D PAUSE
  24041   "RTN","CHM FADR1",44, 0)
  24042    S CHMOPDI =$P($G(^CH MDIC(74100 2.21,DUZ,0 )),"^",2)
  24043   "RTN","CHM FADR1",45, 0)
  24044    S CHMOPDI =$S(CHOSEN =6:CHMOPDI ,CHOSEN=7: CHMOPDI,CH OSEN=8:CHM OPDI,1:"")
  24045   "RTN","CHM FADR1",46, 0)
  24046    I CHMOPDI ="" S $P(^ CHMDIC(741 002.21,DUZ ,0),"^",2) =""  ;CPE0 05-069 Ens ure global  piece is  cleaned up .
  24047   "RTN","CHM FADR1",47, 0)
  24048    ; ;That p iece only  needed for  a Re-open  PDI Numbe r.
  24049   "RTN","CHM FADR1",48, 0)
  24050    ; Return  to routine  CHMFADR4
  24051   "RTN","CHM FADR1",49, 0)
  24052    Q
  24053   "RTN","CHM FADR1",50, 0)
  24054   PAUSE S PA USDT=""
  24055   "RTN","CHM FADR1",51, 0)
  24056    D NOW^%DT C
  24057   "RTN","CHM FADR1",52, 0)
  24058    ; Search  for paused  PDI's
  24059   "RTN","CHM FADR1",53, 0)
  24060   P1 S PAUSD T=$O(^CHMI MG(CHMFPDI ,"PAUSE",P AUSDT)) Q: 'PAUSDT
  24061   "RTN","CHM FADR1",54, 0)
  24062    G:'$D(^CH MIMG(CHMFP DI,"PAUSE" ,PAUSDT,0) ) P1
  24063   "RTN","CHM FADR1",55, 0)
  24064    ; Set PAU SEDT to th e date/tim e stored i n piece 3  of ^CHMIMG (I,"PAUSE" ,J,0)
  24065   "RTN","CHM FADR1",56, 0)
  24066    S PAUSEDT =$P(^CHMIM G(CHMFPDI, "PAUSE",PA USDT,0),"^ ",3)
  24067   "RTN","CHM FADR1",57, 0)
  24068    ; If PAUS EDT is nil , set it t o the curr ent date/t ime retrie ved from N OW^%DTC an d quit
  24069   "RTN","CHM FADR1",58, 0)
  24070    I PAUSEDT ="" S $P(^ CHMIMG(CHM FPDI,"PAUS E",PAUSDT, 0),"^",3)= % Q
  24071   "RTN","CHM FADR1",59, 0)
  24072    G P1
  24073   "RTN","CHM FADR1",60, 0)
  24074   NOUSE W !! ,"USER NOT  DEFINED I N THE CHAM PVA USER F ILE!" Q
  24075   "RTN","CHM FADR1",61, 0)
  24076   SETUP ; Ki ll the fol lowing var iables
  24077   "RTN","CHM FADR1",62, 0)
  24078    K CHMFBN, CHNEWPG
  24079   "RTN","CHM FADR1",63, 0)
  24080    ; TOP^CHM FA100 form ats the to p of the s creen
  24081   "RTN","CHM FADR1",64, 0)
  24082    D TOP^CHM FA100
  24083   "RTN","CHM FADR1",65, 0)
  24084    ; BOTT^CH MFA100 for mats the b ottom of t he screen
  24085   "RTN","CHM FADR1",66, 0)
  24086    D BOTT^CH MFA100
  24087   "RTN","CHM FADR1",67, 0)
  24088    S DTM=4,D BM=20 X CH MAR
  24089   "RTN","CHM FADR1",68, 0)
  24090    ; If ther e is no DU Z, do ERR1  and quit
  24091   "RTN","CHM FADR1",69, 0)
  24092    I '$D(DUZ ) D ERR1 Q
  24093   "RTN","CHM FADR1",70, 0)
  24094    S CHMFDUZ =DUZ
  24095   "RTN","CHM FADR1",71, 0)
  24096    S CHUSER= "UNKNOWN"
  24097   "RTN","CHM FADR1",72, 0)
  24098    I DUZ'=""  S:$D(^VA( 200,DUZ,0) ) CHUSER=$ P(^VA(200, DUZ,0),"^" ,1)
  24099   "RTN","CHM FADR1",73, 0)
  24100    Q
  24101   "RTN","CHM FADR1",74, 0)
  24102   SETUP1 K F 6,CHMFFIN, CHNOFLAG,C HYESFLG,R1 ,R2,R3,R4, R7,CHMFKIL ,CHMFC,CHM FPS
  24103   "RTN","CHM FADR1",75, 0)
  24104    S (CHMFPD I,CHMFIMAG ,CHMFIMTY, CHMFIMNM,C HMFNMPG,CH MFPGNM,CHM FTYPE)=""
  24105   "RTN","CHM FADR1",76, 0)
  24106    S (F1,CHM FIMCT,CHMF PGCT)=""
  24107   "RTN","CHM FADR1",77, 0)
  24108    Q
  24109   "RTN","CHM FADR1",78, 0)
  24110   PSMSG Q
  24111   "RTN","CHM FADR1",79, 0)
  24112    ; SEND TO  PSQ REMOV ED.  CALL  WAS ROUTIN E CHMG172A
  24113   "RTN","CHM FADR1",80, 0)
  24114    ;
  24115   "RTN","CHM FADR1",81, 0)
  24116   KLOCK I $D (CHMFPDI)  K:CHMFPDI' ="" ^CHMIM AGE("LOCK" ,CHMFPDI)
  24117   "RTN","CHM FADR1",82, 0)
  24118    Q
  24119   "RTN","CHM FADR1",83, 0)
  24120   NEWPG D TO P^CHMFA100
  24121   "RTN","CHM FADR1",84, 0)
  24122    D BOTT^CH MFA100
  24123   "RTN","CHM FADR1",85, 0)
  24124    S DTM=4,D BM=20 X CH MAR
  24125   "RTN","CHM FADR1",86, 0)
  24126    Q
  24127   "RTN","CHM FADR1",87, 0)
  24128   REMV D REM V^CHMFPDI
  24129   "RTN","CHM FADR1",88, 0)
  24130    Q
  24131   "RTN","CHM FADR1",89, 0)
  24132   REMV1 D RE MV1^CHMFPD I
  24133   "RTN","CHM FADR1",90, 0)
  24134    Q
  24135   "RTN","CHM FADR1",91, 0)
  24136   DELST1 Q:' $D(^CHMDIC (741002.21 ,DUZ,0))
  24137   "RTN","CHM FADR1",92, 0)
  24138    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",5)=""
  24139   "RTN","CHM FADR1",93, 0)
  24140    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=""
  24141   "RTN","CHM FADR1",94, 0)
  24142    Q
  24143   "RTN","CHM FADR1",95, 0)
  24144   SETPD Q:'$ D(^CHMDIC( 741002.21, DUZ,0))
  24145   "RTN","CHM FADR1",96, 0)
  24146    Q:CHMFPDI =""
  24147   "RTN","CHM FADR1",97, 0)
  24148    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",5)=CH MFPDI
  24149   "RTN","CHM FADR1",98, 0)
  24150    I '$G(VAL OPDI) S $P (^CHMDIC(7 41002.21,D UZ,0),"^", 2)=$G(CHMO PDI)  ;CFS  CPE001-00 4
  24151   "RTN","CHM FADR1",99, 0)
  24152    I $D(CHBT CHNO) I CH BTCHNO'=""  S $P(^CHM IMPB(CHBTC HNO,0),"^" ,6)=""
  24153   "RTN","CHM FADR1",100 ,0)
  24154    S JPD=999 99
  24155   "RTN","CHM FADR1",101 ,0)
  24156    S JPD=$O( ^CHMIMG(CH MFPDI,"PAU SE",JPD),- 1)
  24157   "RTN","CHM FADR1",102 ,0)
  24158    I JPD=""  S JPD=0
  24159   "RTN","CHM FADR1",103 ,0)
  24160    S JPD=JPD +1
  24161   "RTN","CHM FADR1",104 ,0)
  24162    D NOW^%DT C
  24163   "RTN","CHM FADR1",105 ,0)
  24164    S $P(^CHM IMG(CHMFPD I,"PAUSE", JPD,0),"^" ,1)=%
  24165   "RTN","CHM FADR1",106 ,0)
  24166    S $P(^CHM IMG(CHMFPD I,"PAUSE", JPD,0),"^" ,2)=DUZ
  24167   "RTN","CHM FADR1",107 ,0)
  24168    K JPD
  24169   "RTN","CHM FADR1",108 ,0)
  24170    Q
  24171   "RTN","CHM FADR1",109 ,0)
  24172   SKIP S PDI J=0
  24173   "RTN","CHM FADR1",110 ,0)
  24174    Q:'$D(CHB TCHNO)
  24175   "RTN","CHM FADR1",111 ,0)
  24176    Q:'CHBTCH NO
  24177   "RTN","CHM FADR1",112 ,0)
  24178   SK1 S PDIJ =$O(^CHMIM PB(CHBTCHN O,100,PDIJ )) Q:'PDIJ
  24179   "RTN","CHM FADR1",113 ,0)
  24180    G:'$D(^CH MIMPB(CHBT CHNO,100,P DIJ,0)) SK 1
  24181   "RTN","CHM FADR1",114 ,0)
  24182    G:$P(^(0) ,"^",3)'=5  SK1
  24183   "RTN","CHM FADR1",115 ,0)
  24184    S $P(^(0) ,"^",3)=0
  24185   "RTN","CHM FADR1",116 ,0)
  24186    G SK1
  24187   "RTN","CHM FADR1",117 ,0)
  24188   READY Q:'$ D(CHMFPDI)
  24189   "RTN","CHM FADR1",118 ,0)
  24190    Q:CHMFPDI =""
  24191   "RTN","CHM FADR1",119 ,0)
  24192    Q:'$D(^CH MIMG(CHMFP DI,"DOC"))
  24193   "RTN","CHM FADR1",120 ,0)
  24194    S:$D(CHDO CID) ^CHMI MG("READY" ,CHMFPDI)= ""
  24195   "RTN","CHM FADR1",121 ,0)
  24196    Q
  24197   "RTN","CHM FADR1",122 ,0)
  24198   OCRRDY ;FO R CHAMPVA  EDI CLAIMS
  24199   "RTN","CHM FADR1",123 ,0)
  24200    Q:'$D(CHM FPDI)
  24201   "RTN","CHM FADR1",124 ,0)
  24202    Q:CHMFPDI =""
  24203   "RTN","CHM FADR1",125 ,0)
  24204    S ^CHMIMG ("OCR-READ Y",CHMFPDI )=""
  24205   "RTN","CHM FADR1",126 ,0)
  24206    ;NEXT LIN E FOR SYST EM STATIST ICS -- ADD  ONE TO ED I/OCR
  24207   "RTN","CHM FADR1",127 ,0)
  24208    ;S CHMQNA M="EDI/OCR ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  24209   "RTN","CHM FADR1",128 ,0)
  24210    Q
  24211   "RTN","CHM FADR1",129 ,0)
  24212   OCR2RDY ;F OR CHAMPVA  OCR CLAIM S
  24213   "RTN","CHM FADR1",130 ,0)
  24214    Q:'$D(CHM FPDI)
  24215   "RTN","CHM FADR1",131 ,0)
  24216    Q:CHMFPDI =""
  24217   "RTN","CHM FADR1",132 ,0)
  24218    S ^CHMIMG ("OCR2-REA DY",CHMFPD I)=""
  24219   "RTN","CHM FADR1",133 ,0)
  24220    ;NEXT LIN E FOR SYST EM STATIST ICS -- ADD  ONE TO ED I/OCR
  24221   "RTN","CHM FADR1",134 ,0)
  24222    ;S CHMQNA M="EDI/OCR ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  24223   "RTN","CHM FADR1",135 ,0)
  24224    Q
  24225   "RTN","CHM FADR1",136 ,0)
  24226   SBOCRDY ;F OR SB/CWVV  EDI CLAIM S
  24227   "RTN","CHM FADR1",137 ,0)
  24228    Q:'$D(CHM FPDI)  Q:C HMFPDI=""
  24229   "RTN","CHM FADR1",138 ,0)
  24230    S ^CHMIMG ("SBOCR-RE ADY",CHMFP DI)=""
  24231   "RTN","CHM FADR1",139 ,0)
  24232    ;NEXT LIN E FOR SYST EM STATIST ICS -- ADD  ONE TO ED I/OCR
  24233   "RTN","CHM FADR1",140 ,0)
  24234    ;S CHMQNA M="EDI/OCR ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  24235   "RTN","CHM FADR1",141 ,0)
  24236    Q
  24237   "RTN","CHM FADR1",142 ,0)
  24238   SBOCR2DY ; FOR SB/CWV V OCR CLAI MS
  24239   "RTN","CHM FADR1",143 ,0)
  24240    Q:'$D(CHM FPDI)  Q:C HMFPDI=""
  24241   "RTN","CHM FADR1",144 ,0)
  24242    S ^CHMIMG ("SBOCR2-R EADY",CHMF PDI)=""
  24243   "RTN","CHM FADR1",145 ,0)
  24244    ;NEXT LIN E FOR SYST EM STATIST ICS -- ADD  ONE TO ED I/OCR
  24245   "RTN","CHM FADR1",146 ,0)
  24246    ;S CHMQNA M="EDI/OCR ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  24247   "RTN","CHM FADR1",147 ,0)
  24248    Q
  24249   "RTN","CHM FADR1",148 ,0)
  24250   MANL  ;CPE 005-069 FO R MANUAL E DI REOPEN
  24251   "RTN","CHM FADR1",149 ,0)
  24252    Q:'$D(CHM FPDI)
  24253   "RTN","CHM FADR1",150 ,0)
  24254    Q:CHMFPDI =""
  24255   "RTN","CHM FADR1",151 ,0)
  24256    S ^CHMIMG ("MANUAL", CHMFPDI)=" "
  24257   "RTN","CHM FADR1",152 ,0)
  24258    Q
  24259   "RTN","CHM FADR1",153 ,0)
  24260   OCRRRDY ;C PE005-004  FOR CHAMPV A EDI REOP EN
  24261   "RTN","CHM FADR1",154 ,0)
  24262    Q:'$D(CHM FPDI)  Q:C HMFPDI=""
  24263   "RTN","CHM FADR1",155 ,0)
  24264    S ^CHMIMG ("OCRR-REA DY",CHMFPD I)=""
  24265   "RTN","CHM FADR1",156 ,0)
  24266    Q
  24267   "RTN","CHM FADR1",157 ,0)
  24268   SBOCRRDY ; CPE005-004  FOR S/B E DI REOPEN
  24269   "RTN","CHM FADR1",158 ,0)
  24270    Q:'$D(CHM FPDI)  Q:C HMFPDI=""
  24271   "RTN","CHM FADR1",159 ,0)
  24272    S ^CHMIMG ("SBOCRR-R EADY",CHMF PDI)=""
  24273   "RTN","CHM FADR1",160 ,0)
  24274    Q
  24275   "RTN","CHM FADR1",161 ,0)
  24276   ERR1 ; Pri nt out err or message  to termin al and qui t program.
  24277   "RTN","CHM FADR1",162 ,0)
  24278    S DY=5,DX =10 X XY W  "User is  unknown to  system",@ CHEOL
  24279   "RTN","CHM FADR1",163 ,0)
  24280    S DY=6,DX =10 X XY W  "Please L og onto te rminal aga in",@CHEOL
  24281   "RTN","CHM FADR1",164 ,0)
  24282    R RD:2
  24283   "RTN","CHM FADR1",165 ,0)
  24284    Q
  24285   "RTN","CHM FADR1",166 ,0)
  24286   KILALL K A ,BFN,CH,CH CTRD,CHCTR O,CHMFCLMS ,CHMCL,DFN ,CHBENNM,V FN,CHMVEN, CHMFCORR
  24287   "RTN","CHM FADR1",167 ,0)
  24288    K CHMFACC N,CHMFAMNT ,CHMFASDT, CHMFASS,CH MFBFN,CHMF C,CHMFCLIN ,CHMBEN
  24289   "RTN","CHM FADR1",168 ,0)
  24290    K CHFC8CI P,CHMFCOMM ,CHMFCONT, CHMFCOR,CH MFDATE,CHM FDAYS,CHMF DCBN,CHMFD CVN ;bdb 2 /8/2018 ad ded CHFC8C IP
  24291   "RTN","CHM FADR1",169 ,0)
  24292    K CHMFDFN ,CHMFELIG, CHMFFIN,CH MFFL,CHMFF L1,CHMFHCP C,CHMFICD9 ,CHMFIMAG
  24293   "RTN","CHM FADR1",170 ,0)
  24294    K CHMFIMC T,CHMFIMNM ,CHMFIMTY, CHMFINCT,C HMFINTC,CH MFINVD,CHM FINVN
  24295   "RTN","CHM FADR1",171 ,0)
  24296    K CHMFKIL ,CHMFLIST, CHMFLOC,CH MFNMPG,CHM FOUT,CHMFP DI,CHMFPGC T,CHMFPGNM  ;bdb 12/2 5/2017 add ed CHMFPDI
  24297   "RTN","CHM FADR1",172 ,0)
  24298    K CHMFPLA C,CHMFPLPT ,CHMFPRCT, CHMFPS,CHM FPSBN,CHMF REDO,CHMFR EF,CHMFSAM E
  24299   "RTN","CHM FADR1",173 ,0)
  24300    K CHMFSVT Y,CHMFTERM ,CHMFTMBG, CHMFTYPE,C HMFQUIT,CH NB,CHSAME, CHSDX,CHSD Y
  24301   "RTN","CHM FADR1",174 ,0)
  24302    K CHT,CHT Y,CHUP,DBM ,DF,DF1,DF N,DFOUT,DI C,DLAYGO,D R,DTM,F1,F 2,FLAG4,J
  24303   "RTN","CHM FADR1",175 ,0)
  24304    K K,HDA,H LD,HTYPE,I V,NM,NW,PD IFL,SFL,SU RFACE,CHFA RM,TOOTH,T Y,QU,VEN
  24305   "RTN","CHM FADR1",176 ,0)
  24306    K VFN,X,X PLUS,ZCT,Z ICN,CHMCCR FG,CHRXN,C HNDC,CHRXD ,CHRXDP,CH PSN,CHQNT
  24307   "RTN","CHM FADR1",177 ,0)
  24308    K CHBAMT, CHICD9,CHG NIND,CHICD S9,CHDFL,I CD,CHMFGO, CHLTG,ZY,Z X,DY,DX
  24309   "RTN","CHM FADR1",178 ,0)
  24310    K CHUP,CH UPS,CHDOWN ,CHDOWNS,C HOSEN,CHSA ME,CHOUT,C HSDX,CHSDY ,CHANSW,CH LG
  24311   "RTN","CHM FADR1",179 ,0)
  24312    K CHMFQUI T,CHT,DDOU T,X,Y,ZSTN ,CHREDO,ZS TF,ZTM,ZBM K,CHPTC,CH EKR,CHHDFN
  24313   "RTN","CHM FADR1",180 ,0)
  24314    K CHHBFN, CHOUTER,CH ENTRE,CHFC T,CHFIFLAG ,CMENTR,CH MFEDIT,CHM FENTR
  24315   "RTN","CHM FADR1",181 ,0)
  24316    K CHPPX,C HOUTR,CHGN IND,L9,M,M 1,PRXD,STE FL,Y9,TL,F LAG,FLAG1, FLAG2,FLAG 3
  24317   "RTN","CHM FADR1",182 ,0)
  24318    K FLAG4,S 1,Y1,Y2,AN ,L,N,M9,M8 ,CHMFCOT,C H9,CH99,CH CTL1,CHJ,C HJJ,CHKILR
  24319   "RTN","CHM FADR1",183 ,0)
  24320    K CHKIR,C HNUMBR,CHP ,CHPZ,CHSC T,CHSCTS,C HSCTS1,CHS T1,HIP,PCH MFH
  24321   "RTN","CHM FADR1",184 ,0)
  24322    K CHMFBAS C,PV,CHVEN NM,CHBEN,C HBTCHNO,CH TOBIL,A1,A A,ASKFL,AS S,BAD,BL
  24323   "RTN","CHM FADR1",185 ,0)
  24324    K BLNK1,B LNK2,BN,C, CFL,CHASSG N,CHCODE,C HCOMFL,CHD EF,CHDTA,C HHDT,CHIBT CH
  24325   "RTN","CHM FADR1",186 ,0)
  24326    K CHINGOR ,CHMCCR,CH FMCLNM,CHM FI,CHMFNEX T,CHMFPP,C HMFREVS,CH MFRS,CHMFR TN
  24327   "RTN","CHM FADR1",187 ,0)
  24328    K CHMFSER V,CHMFSORT ,CHMFSRVC, CHMFTY,CHM INUS,CHMNE XT,CHMNRTN ,CHNOW,CHO ICE
  24329   "RTN","CHM FADR1",188 ,0)
  24330    K CHORG,C HSUM,CHUPF L,CL,CLT,C HMAC,CNO,C NT,CT,CT1, CTY,D,D0,D A1,DA2,DDE R
  24331   "RTN","CHM FADR1",189 ,0)
  24332    K DI,DN,D OS,DQ,EX,F IPAY,FKIL, HR,HVFN,HX ,HY,I,ID,I MG,LINW,LL ,LN,MEDPTR
  24333   "RTN","CHM FADR1",190 ,0)
  24334    K MIN,NEX TPAGE,OHIA MT,OHIDOS, OHIIND,OHI NAME,OHIRE C,OHITOS,O HITYP,PAY, PG,PLS,PS
  24335   "RTN","CHM FADR1",191 ,0)
  24336    K PT,PVN, PY,REC,REC 40,RNG,RNG BD,RNGED,S DATE,SN,SP ,STR,STR1, SUB,SUB1
  24337   "RTN","CHM FADR1",192 ,0)
  24338    K SUB2,SU B3,SUB4,SU B5,SUB6,SV FLD,TAB1,T AB2,TOTSUM ,TSP,VALOP DI,VDC,VN, VNPG
  24339   "RTN","CHM FADR1",193 ,0)
  24340    K VREC0,V REC1,XX,Z, ZZPDI,ZVFN
  24341   "RTN","CHM FADR1",194 ,0)
  24342   KILPDI I $ D(CHMFPDI) ,CHMFPDI'= "" D
  24343   "RTN","CHM FADR1",195 ,0)
  24344    .K ^CHMIM AGE(CHMFPD I) ;               KI LL PDI
  24345   "RTN","CHM FADR1",196 ,0)
  24346    .K ^CHMIM AGE("AC",C HMFPDI) ;          KI LL CROSS R EF
  24347   "RTN","CHM FADR1",197 ,0)
  24348    .K ^CHMIM AGE(CHMFPD I,"AD") ;          KI LL CROSS R EF
  24349   "RTN","CHM FADR1",198 ,0)
  24350    .K ^CHMIM AGE("B",CH MFPDI) ;           KI LL CROSS R EF
  24351   "RTN","CHM FADR1",199 ,0)
  24352    .K:CHMFPD I'="" ^CHM IMAGE("LOC K",CHMFPDI )
  24353   "RTN","CHM FADR1",200 ,0)
  24354    .S $P(^CH MIMG(CHMFP DI,0),"^", 6)=0
  24355   "RTN","CHM FADR1",201 ,0)
  24356    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  24357   "RTN","CHM FADR1",202 ,0)
  24358    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  24359   "RTN","CHM FADR1",203 ,0)
  24360    I $D(CHBT CHNO) I CH BTCHNO=0 D   Q
  24361   "RTN","CHM FADR1",204 ,0)
  24362    .S:$D(^CH MDIC(74100 2.21,DUZ,0 )) $P(^(0) ,"^",6)=""
  24363   "RTN","CHM FADR1",205 ,0)
  24364    .S CHBTCH NO="" Q
  24365   "RTN","CHM FADR1",206 ,0)
  24366    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=0  I $D(CHBT CHNO) I CH BTCHNO'=""  D
  24367   "RTN","CHM FADR1",207 ,0)
  24368    .S X=$$BT CHST^CHMFA BU3(CHBTCH NO)
  24369   "RTN","CHM FADR1",208 ,0)
  24370    .S X=$$BT CHUP^CHMFA BU3(CHBTCH NO)
  24371   "RTN","CHM FADR1",209 ,0)
  24372    .I 'X S:$ D(^CHMDIC( 741002.21, DUZ,0)) $P (^(0),"^", 6)="" D
  24373   "RTN","CHM FADR1",210 ,0)
  24374    ..S CHMFI =CHBTCHNO, CHMFPP="BA TKILL" D ^ CHMFWK03
  24375   "RTN","CHM FADR1",211 ,0)
  24376    I $D(CHBT CHNO) I CH BTCHNO'=""  S $P(^CHM IMPB(CHBTC HNO,0),"^" ,6)=""
  24377   "RTN","CHM FADR1",212 ,0)
  24378    Q
  24379   "RTN","CHM FADR1",213 ,0)
  24380   SETPROD ;
  24381   "RTN","CHM FADR1",214 ,0)
  24382    S SDATE=$ P(($$HTFM^ XLFDT($H)) ,".",1)
  24383   "RTN","CHM FADR1",215 ,0)
  24384    S TMPTIME =$P(($$HTF M^XLFDT($H )),".",2)
  24385   "RTN","CHM FADR1",216 ,0)
  24386    S HR=$E(T MPTIME,1,2 ),MIN=$E(T MPTIME,3,4 )
  24387   "RTN","CHM FADR1",217 ,0)
  24388    I MIN>29  S MIN=30 G  PROD1
  24389   "RTN","CHM FADR1",218 ,0)
  24390    S MIN=+(0 0)
  24391   "RTN","CHM FADR1",219 ,0)
  24392   PROD1 S TM PDT=+(SDAT E_"."_HR_M IN)
  24393   "RTN","CHM FADR1",220 ,0)
  24394    S:'$D(FKI L) FKIL=0  S:'$D(PS)  PS=0 S:'$D (BAD) BAD= 0 S:'$D(FI PAY) FIPAY =0
  24395   "RTN","CHM FADR1",221 ,0)
  24396    ;S:'$D(^C HMPROD("PR OD-RPT-VE" ,"OTHER",D T,DUZ)) ^C HMPROD("PR OD-RPT-VE" ,"OTHER",T MPDT,DUZ)= 0_"^"_0_"^ "_0_"^"_0
  24397   "RTN","CHM FADR1",222 ,0)
  24398    S:'$D(^CH MPROD("PRO D-RPT-VE", "OTHER",TM PDT,DUZ))  ^CHMPROD(" PROD-RPT-V E","OTHER" ,TMPDT,DUZ )=0_"^"_0_ "^"_0_"^"_ 0  ;CFS De fect 88837 3
  24399   "RTN","CHM FADR1",223 ,0)
  24400    I FKIL=1  I $D(CHMFP DI) I CHMF PDI'="" I  $D(^CHMIMA GE(CHMFPDI ,0)) I $P( ^CHMIMAGE( CHMFPDI,0) ,"^",9)=1  D
  24401   "RTN","CHM FADR1",224 ,0)
  24402    .S $P(^CH MPROD("PRO D-RPT-VE", "OTHER",TM PDT,DUZ)," ^",3)=$P(^ CHMPROD("P ROD-RPT-VE ","OTHER", TMPDT,DUZ) ,"^",3)+FK IL
  24403   "RTN","CHM FADR1",225 ,0)
  24404    .S CHMFI= CHMFPDI,CH MFPP="SKIL " D ^CHMFW K01
  24405   "RTN","CHM FADR1",226 ,0)
  24406    I PS=1 S  $P(^CHMPRO D("PROD-RP T-VE","OTH ER",TMPDT, DUZ),"^",4 )=$P(^CHMP ROD("PROD- RPT-VE","O THER",TMPD T,DUZ),"^" ,4)+PS
  24407   "RTN","CHM FADR1",227 ,0)
  24408    I FIPAY=1  S $P(^CHM PROD("PROD -RPT-VE"," OTHER",TMP DT,DUZ),"^ ",2)=$P(^C HMPROD("PR OD-RPT-VE" ,"OTHER",T MPDT,DUZ), "^",2)+FIP AY
  24409   "RTN","CHM FADR1",228 ,0)
  24410    I BAD=1 S  $P(^CHMPR OD("PROD-R PT-VE","OT HER",TMPDT ,DUZ),"^", 1)=$P(^CHM PROD("PROD -RPT-VE"," OTHER",TMP DT,DUZ),"^ ",1)+BAD
  24411   "RTN","CHM FADR1",229 ,0)
  24412    S (PS,FKI L,FIPAY,BA D)=0
  24413   "RTN","CHM FADR1",230 ,0)
  24414    Q
  24415   "RTN","CHM FADR1",231 ,0)
  24416   OCRKIL ;RE SETS VE PD I CLOCK WH EN PLACING  EDI/OCR C LAIMS IN H OLD Q -- T AB 7
  24417   "RTN","CHM FADR1",232 ,0)
  24418    ;AEB ADDE D LOGIC TO  SET PDI T O COMPLETE  AND ADD P DI COMMENT S 4/20/200 7
  24419   "RTN","CHM FADR1",233 ,0)
  24420    I $D(CHMF PDI),CHMFP DI'="" D
  24421   "RTN","CHM FADR1",234 ,0)
  24422    .D NOW^%D TC I $E(%, 1,10)'=$E( $P(^CHMIMG (CHMFPDI,0 ),"^",4),1 ,10) S $P( ^CHMIMG(CH MFPDI,0)," ^",4)=% R  TMPX:2
  24423   "RTN","CHM FADR1",235 ,0)
  24424    .F I=18:1 :24 S DX=0 ,DY=I X XY  W @CHEOL
  24425   "RTN","CHM FADR1",236 ,0)
  24426    .S DX=2,D Y=18 X XY  W "WARNING : This pro cess will  DELETE EDI /OCR PDIs  from the R EADY queue !!"
  24427   "RTN","CHM FADR1",237 ,0)
  24428    .S DX=2,D Y=19 X XY  W "Do you  want to se t the PDI  status to  COMPLETE?    YES//" D  CSBRS^CHS C2
  24429   "RTN","CHM FADR1",238 ,0)
  24430    .S Y=$E(Y ,1) S:Y=""  Y="Y"
  24431   "RTN","CHM FADR1",239 ,0)
  24432    .S Y=$$UP ^XLFSTR(Y)  I Y="N" D
  24433   "RTN","CHM FADR1",240 ,0)
  24434    ..S $P(^C HMIMG(CHMF PDI,0),"^" ,6)=0
  24435   "RTN","CHM FADR1",241 ,0)
  24436    ..S $P(^C HMIMG(CHMF PDI,0),"^" ,3)=""
  24437   "RTN","CHM FADR1",242 ,0)
  24438    ..S $P(^C HMIMG(CHMF PDI,0),"^" ,4)=""
  24439   "RTN","CHM FADR1",243 ,0)
  24440    ..S ^CHMI MG("EDI/OC R-HOLD",CH MFPDI)=""
  24441   "RTN","CHM FADR1",244 ,0)
  24442    ..Q
  24443   "RTN","CHM FADR1",245 ,0)
  24444    .I Y="Y"  D
  24445   "RTN","CHM FADR1",246 ,0)
  24446    ..S DX=2, DY=20 X XY  W "That P DI has bee n deleted  from the R eady Queue " R X:1
  24447   "RTN","CHM FADR1",247 ,0)
  24448    ..S $P(^C HMIMG(CHMF PDI,0),"^" ,6)=4
  24449   "RTN","CHM FADR1",248 ,0)
  24450    ..D NOW^% DTC S $P(^ CHMIMG(CHM FPDI,0),"^ ",5)=%,$P( ^CHMIMG(CH MFPDI,0)," ^",3)=DUZ
  24451   "RTN","CHM FADR1",249 ,0)
  24452    ..S $P(^C HMIMAGE(CH MFPDI,0)," ^",9)=1
  24453   "RTN","CHM FADR1",250 ,0)
  24454    ..I $D(^C HMIMG("OCR -READY",CH MFPDI)) K  ^CHMIMG("O CR-READY", CHMFPDI)
  24455   "RTN","CHM FADR1",251 ,0)
  24456    ..I $D(^C HMIMG("SBO CR-READY", CHMFPDI))  K ^CHMIMG( "SBOCR-REA DY",CHMFPD I)
  24457   "RTN","CHM FADR1",252 ,0)
  24458    ..I $D(^C HMIMG("OCR 2-READY",C HMFPDI)) K  ^CHMIMG(" OCR2-READY ",CHMFPDI)
  24459   "RTN","CHM FADR1",253 ,0)
  24460    ..I $D(^C HMIMG("SBO CR2-READY" ,CHMFPDI))  K ^CHMIMG ("SBOCR2-R EADY",CHMF PDI)
  24461   "RTN","CHM FADR1",254 ,0)
  24462    ..I $D(^C HMIMG("OCR R-READY",C HMFPDI)) K  ^CHMIMG(" OCRR-READY ",CHMFPDI)  ;CPE005-0 04
  24463   "RTN","CHM FADR1",255 ,0)
  24464    ..I $D(^C HMIMG("SBO CRR-READY" ,CHMFPDI))  K ^CHMIMG ("SBOCRR-R EADY",CHMF PDI) ;CPE0 05-004
  24465   "RTN","CHM FADR1",256 ,0)
  24466    ..S FKIL= 1 D SETPRO D^CHMFIMG   ;GIVE VE  CREDIT FOR  PDI. AEB  7/24/2007  - CHANGED  FROM CHMFA DR1 TO CHM FIMG TO CO UNT AS PRO CESSED PDI  NOT A 'KI LLED' ONE
  24467   "RTN","CHM FADR1",257 ,0)
  24468    ..Q
  24469   "RTN","CHM FADR1",258 ,0)
  24470    .;W @IOF  D ^CHMFSET  S CHONCE= 1,ANS=CHMF PDI D EN1^ CHMLCOMM K  DIR W @IO F D ^CHMFS ET  ;SKD 8 -24-07 DEV 003066
  24471   "RTN","CHM FADR1",259 ,0)
  24472    .W @IOF D  ^CHMFSET  S CHONCE=1 ,ANS=CHMFP DI D EN1^C HMLCOMM K  CHONCE K D IR W @IOF  D ^CHMFSET   ;SKD 8-2 4-07 DEV00 3066
  24473   "RTN","CHM FADR1",260 ,0)
  24474    .Q
  24475   "RTN","CHM FADR1",261 ,0)
  24476    Q
  24477   "RTN","CHM FADR1",262 ,0)
  24478    ;
  24479   "RTN","CHM FADR1",263 ,0)
  24480   SCHK(DUZ)  ;SECURITY  CHECK - VA LIDATE USE R FOR RE-O PEN MENUS
  24481   "RTN","CHM FADR1",264 ,0)
  24482    ;JSE 10/0 6/2017 CPE 005-051
  24483   "RTN","CHM FADR1",265 ,0)
  24484    I '$D(DUZ ) Q 0
  24485   "RTN","CHM FADR1",266 ,0)
  24486    N ALLOW,R OLE,TITLE
  24487   "RTN","CHM FADR1",267 ,0)
  24488    S ALLOW=0
  24489   "RTN","CHM FADR1",268 ,0)
  24490    S TITLE=$ P($G(^CHMD IC(741002. 21,DUZ,0)) ,"^",3),RO LE=$P($G(^ VA(200,DUZ ,0)),"^",9 )
  24491   "RTN","CHM FADR1",269 ,0)
  24492    ;Secondar y programm er access
  24493   "RTN","CHM FADR1",270 ,0)
  24494    I ROLE=15 76 Q 1
  24495   "RTN","CHM FADR1",271 ,0)
  24496    ;CHECK RC  - CHAMPVA  EDI REOPE N
  24497   "RTN","CHM FADR1",272 ,0)
  24498    I Y="RC"  D  Q ALLOW
  24499   "RTN","CHM FADR1",273 ,0)
  24500    .;R&R VEs , PAs, Lea ds, Superv isors
  24501   "RTN","CHM FADR1",274 ,0)
  24502    .I (";R&R  SUPERVISO R;R&R PROG RAM ANALYS T;R&R LEAD ;R&R VE;"[ (";"_TITLE _";")) S A LLOW=1 Q
  24503   "RTN","CHM FADR1",275 ,0)
  24504    .W !!,*7, ?8,TITLE,"  not autho rized to p rocess CHA MPVA EDI R eopen clai ms." R XX: 5
  24505   "RTN","CHM FADR1",276 ,0)
  24506    .;CHECK R S - SB EDI  REOPEN
  24507   "RTN","CHM FADR1",277 ,0)
  24508    I Y="RS"  D  Q ALLOW
  24509   "RTN","CHM FADR1",278 ,0)
  24510    .;SB VEs,  PAs, Lead s, and Sup ervisors
  24511   "RTN","CHM FADR1",279 ,0)
  24512    .I (";PSD  SUPERVISO R;PSD PA;P SD LEAD;PS D SB VE;"[ (";"_TITLE _";")) S A LLOW=1 Q
  24513   "RTN","CHM FADR1",280 ,0)
  24514    .W !!,*7, ?8,TITLE,"  not autho rized to p rocess SB  EDI Reopen  claims."  R XX:5
  24515   "RTN","CHM FADR1",281 ,0)
  24516    ;CHECK ER  - MANUAL  EDI REOPEN
  24517   "RTN","CHM FADR1",282 ,0)
  24518    I Y="ER"  D  Q ALLOW
  24519   "RTN","CHM FADR1",283 ,0)
  24520    .I ";R&R  VE;PSD SB  VE;"[(";"_ TITLE_";")  S ALLOW=1  Q
  24521   "RTN","CHM FADR1",284 ,0)
  24522    .W !!,*7, ?8,TITLE,"  not autho rized to p rocess Man ual EDI Re open claim s." R XX:5
  24523   "RTN","CHM FADR1",285 ,0)
  24524    Q ALLOW
  24525   "RTN","CHM FADR1",286 ,0)
  24526    ;
  24527   "RTN","CHM FADR2")
  24528   0^50^B3131 60862
  24529   "RTN","CHM FADR2",1,0 )
  24530   CHMFADR2 ; JLR/DEN;UT ILITY PROG RAM FOR DO C ID SCREE N;08/20/98   8:16 AM
  24531   "RTN","CHM FADR2",2,0 )
  24532    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  24533   "RTN","CHM FADR2",3,0 )
  24534    ;V2.0;CAL LED FROM C HMF101A;;
  24535   "RTN","CHM FADR2",4,0 )
  24536    ;;MODIFIE D BY RLC O N 4/13/95  - ADDED OP TION 11) P PR
  24537   "RTN","CHM FADR2",5,0 )
  24538    ;;MODIFIE D BY RLC O N 4/28/95  - ADDED OP TION 12) P PRs-PDI
  24539   "RTN","CHM FADR2",6,0 )
  24540    ;PT 15932  (Y2K)
  24541   "RTN","CHM FADR2",7,0 )
  24542    ;JEH 1/8/ 10 TT 8813  vista app lication d isappeared  when inpu tting data
  24543   "RTN","CHM FADR2",8,0 )
  24544    ;JEH 1/8/ 10 PCDUO 5 2308 FIX L OGIC ERROR
  24545   "RTN","CHM FADR2",9,0 )
  24546    ;KEL 05/0 4/17 CPE00 5-007 Add  Type of Bi ll to the  EDI Re-ope n Document  ID Screen
  24547   "RTN","CHM FADR2",10, 0)
  24548    ;CFS 08/1 6/2017 CPE 005-004 Ad d validati ons and sc reen chang es for CHA MPVA and S B EDI Reop en process
  24549   "RTN","CHM FADR2",11, 0)
  24550    ;CFS 10/0 1/2017 CPE 005-069 Ad d Original  and Curre nt PDI Num bers to ED I Manual R e-open Doc  ID Screen .
  24551   "RTN","CHM FADR2",12, 0)
  24552    ;CFS 10/0 1/2017 CPE 005-073, 0 74, 075, 0 76, 077, 0 79, 080 -  Added vali dations.
  24553   "RTN","CHM FADR2",13, 0)
  24554    ;                 ,0 84, 086, 0 87 - all d one in thi s routine.
  24555   "RTN","CHM FADR2",14, 0)
  24556    ;HM 11/13 /2017 CPE0 05-085 Add ed validat ion
  24557   "RTN","CHM FADR2",15, 0)
  24558    ;OTW 12/2 2/2017 CPE 005-126, 1 27 - Added  validatio n for Void ed Origina l PDI stat us
  24559   "RTN","CHM FADR2",16, 0)
  24560    ; Current  and Origa nal PDI Nu mber promp ts.
  24561   "RTN","CHM FADR2",17, 0)
  24562    ;BDB 01/0 3/2018 CPE 005-111,11 2,113,114  Check for  reversed s tatus.
  24563   "RTN","CHM FADR2",18, 0)
  24564    ;CFS 01/0 3/2018 CPE 005-117 an d CPE005-1 18 Write v alidation  message if  there are  no attach ed claims
  24565   "RTN","CHM FADR2",19, 0)
  24566    ;                for  Original  PDI.
  24567   "RTN","CHM FADR2",20, 0)
  24568    ;BDB 01/0 9/2018 CPE 005-121 Au toload ori ginal PDI  to Current  PDI for M anual EDI
  24569   "RTN","CHM FADR2",21, 0)
  24570    ;CFS 01/1 2/2018 CPE 005-122 an d 123 Add  the bene c heck for E DI Reopen.
  24571   "RTN","CHM FADR2",22, 0)
  24572    ;CFS 01/1 7/2018 CPE 005-124 an d 125 Allo w "RC" and  "RS" opti ons to get  the voide d validati on message
  24573   "RTN","CHM FADR2",23, 0)
  24574   CHKPAG K N P
  24575   "RTN","CHM FADR2",24, 0)
  24576    S CHPDIPR L=$$PDITYP ^CHMFAUT1( CHMFPDI)
  24577   "RTN","CHM FADR2",25, 0)
  24578    Q:CHPDIPR L
  24579   "RTN","CHM FADR2",26, 0)
  24580    Q:'$D(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG))
  24581   "RTN","CHM FADR2",27, 0)
  24582    D CLEARB  S DX=1,DY= 15 X XY S  NP=1
  24583   "RTN","CHM FADR2",28, 0)
  24584   PAG1 X XY  W *7,"Page  # ",CHMFP GNM," has  already be en process ed.  Do yo u want to  kill the d ata for th is"
  24585   "RTN","CHM FADR2",29, 0)
  24586    W !,"page  and re-en ter it?  N O// ",@CHE OL S DY=16 ,DX=29 X X Y D CSBRS^ CHSC2
  24587   "RTN","CHM FADR2",30, 0)
  24588    S DX=1,DY =15 X XY G :$D(DQOUT)  PAG1 I $D (DUOUT) D  CLEARB Q
  24589   "RTN","CHM FADR2",31, 0)
  24590    I $D(DFOU T) D CLEAR B Q
  24591   "RTN","CHM FADR2",32, 0)
  24592    S Y=$E(Y, 1) S:Y=""  Y="N" G:"N Y"'[Y PAG1
  24593   "RTN","CHM FADR2",33, 0)
  24594    I Y="Y" D  OHI K NP, ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG)  D OHI
  24595   "RTN","CHM FADR2",34, 0)
  24596    Q
  24597   "RTN","CHM FADR2",35, 0)
  24598   OHI ;
  24599   "RTN","CHM FADR2",36, 0)
  24600    ;I $G(CHM FPDI)'=""  K ^CHMIMAG E(CHMFPDI, "ZOHI")  ; SKD MC284  1-3-07, SK D 2-9-07 R EM OUT
  24601   "RTN","CHM FADR2",37, 0)
  24602    K OHI,OHI AMT  ;SKD  2-9-07
  24603   "RTN","CHM FADR2",38, 0)
  24604    S:$G(DFN) ="" DFN=$P ($G(^CHMIM AGE(CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,1,0)), U,1) Q:$G( DFN)=""  ; SKD MC284  2-9-07
  24605   "RTN","CHM FADR2",39, 0)
  24606    S:$G(BFN) ="" BFN=$P ($G(^CHMIM AGE(CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,1,0)), U,2) Q:$G( BFN)=""  ; SKD MC284  2-9-07
  24607   "RTN","CHM FADR2",40, 0)
  24608    Q:'$G(OHI TOS)!('$G( OHIDOS))   ;SKD MC284  2-9-07
  24609   "RTN","CHM FADR2",41, 0)
  24610    I $G(CHMF PDI)'="" K  ^CHMIMAGE (CHMFPDI," ZOHI",DFN, BFN,OHITOS ,OHIDOS)   ;SKD MC284  2-9-07
  24611   "RTN","CHM FADR2",42, 0)
  24612    Q
  24613   "RTN","CHM FADR2",43, 0)
  24614   REDRAW S D Y=3,DX=1 X  XY W @CHE OL
  24615   "RTN","CHM FADR2",44, 0)
  24616    D CLEAR S  CHTITLE=" DOCUMENT I DENTIFICAT ION SCREEN ",CHSCREEN =""
  24617   "RTN","CHM FADR2",45, 0)
  24618    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN))
  24619   "RTN","CHM FADR2",46, 0)
  24620    D TITLE^C HMFA100,CH OICE^CHMFA 100,ERRORS ^CHMFA100  Q
  24621   "RTN","CHM FADR2",47, 0)
  24622   NEWPG D CL EAR,SCREEN  Q
  24623   "RTN","CHM FADR2",48, 0)
  24624   NOPAUS S D X=20,DY=15  X XY
  24625   "RTN","CHM FADR2",49, 0)
  24626    W *7,@CHB ON,?20,"CA N'T PAUSE  WITHOUT A  PDI ASSIGN ED !!" Q
  24627   "RTN","CHM FADR2",50, 0)
  24628   NOCOMM S D X=20,DY=15  X XY
  24629   "RTN","CHM FADR2",51, 0)
  24630    W *7,@CHB ON,?13,"Yo u must hav e a PDI be fore comme nts can be  entered."  Q
  24631   "RTN","CHM FADR2",52, 0)
  24632   NOSCR S DX =19,DY=15  X XY
  24633   "RTN","CHM FADR2",53, 0)
  24634    W *7,@CHB ON,"No Scr een for th is paticul ar data en try." Q
  24635   "RTN","CHM FADR2",54, 0)
  24636   NODATA S D X=18,DY=15  X XY
  24637   "RTN","CHM FADR2",55, 0)
  24638    W *7,@CHB ON,"All da ta must be  entered b efore cont inuing." Q
  24639   "RTN","CHM FADR2",56, 0)
  24640   NOSORT S D X=23,DY=15  X XY
  24641   "RTN","CHM FADR2",57, 0)
  24642    W *7,@CHB ON,"Data m ust be ent ered befor e sorting. " Q
  24643   "RTN","CHM FADR2",58, 0)
  24644   NOBTCH S D X=10,DY=15  X XY
  24645   "RTN","CHM FADR2",59, 0)
  24646    W *7,@CHB ON,"If doi ng Manual  process, a  batch num ber must b e entered  before",!, "    using  this opti on.  If do ing Image  processing  this opti on is not  allowed."
  24647   "RTN","CHM FADR2",60, 0)
  24648    Q
  24649   "RTN","CHM FADR2",61, 0)
  24650   CLEAR F DY =4:1:20 S  DX=1 X XY  W @CHEOL
  24651   "RTN","CHM FADR2",62, 0)
  24652    Q
  24653   "RTN","CHM FADR2",63, 0)
  24654   CLEARB F D Y=13:1:20  S DX=1 X X Y W @CHEOL
  24655   "RTN","CHM FADR2",64, 0)
  24656    Q
  24657   "RTN","CHM FADR2",65, 0)
  24658   FIN S F2=1  Q
  24659   "RTN","CHM FADR2",66, 0)
  24660   WTOPDI ;CP E005-004 a nd CPE005- 069 Write  Original P DI Number  for EDI Re -open scre ens. 
  24661   "RTN","CHM FADR2",67, 0)
  24662    S DY=5,DX =41 X XY W :$D(CHMOPD I) CHMOPDI  W @CHEOL
  24663   "RTN","CHM FADR2",68, 0)
  24664    Q
  24665   "RTN","CHM FADR2",69, 0)
  24666   WTPDI S DY =6,DX=41 X  XY W:$D(C HMFPDI) CH MFPDI W @C HEOL
  24667   "RTN","CHM FADR2",70, 0)
  24668    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=0  I $D(CHMF PDI) I CHM FPDI'="" D
  24669   "RTN","CHM FADR2",71, 0)
  24670    .;I $D(^C HMIMG(CHMF PDI,"DOC") ) D
  24671   "RTN","CHM FADR2",72, 0)
  24672    ..S CHMNN UM=$P(^CHM IMG(CHMFPD I,"DOC")," ^",10) S D X=55 X XY
  24673   "RTN","CHM FADR2",73, 0)
  24674    ..W:CHMNN UM'="" @CH BON,"(Manu al Number:  ",CHMNNUM ,")",@CHBO FF
  24675   "RTN","CHM FADR2",74, 0)
  24676    Q
  24677   "RTN","CHM FADR2",75, 0)
  24678   WTNP S DY= 7,DX=41 X  XY W:$D(CH MFNMPG) CH MFNMPG W @ CHEOL Q
  24679   "RTN","CHM FADR2",76, 0)
  24680   WTPG S:'$D (CHMFPGNM)  CHMFPGNM= 1 S:CHMFPG NM="" CHMF PGNM=1
  24681   "RTN","CHM FADR2",77, 0)
  24682    S DY=8,DX =41 X XY W :$D(CHMFPG NM) CHMFPG NM W:$D(CH MFNMPG) "  of ",CHMFN MPG W @CHE OL Q
  24683   "RTN","CHM FADR2",78, 0)
  24684   WTIM Q
  24685   "RTN","CHM FADR2",79, 0)
  24686    S:'$D(CHM FIMAG) CHM FIMAG=1 S: CHMFIMAG=" " CHMFIMAG =1
  24687   "RTN","CHM FADR2",80, 0)
  24688    S DY=9,DX =41 X XY W :$D(CHMFIM AG) CHMFIM AG W @CHEO L Q
  24689   "RTN","CHM FADR2",81, 0)
  24690   WTTYPE S D Y=9,DX=41  X XY I $D( CHMFTYPE), CHMFTYPE'= "" S II=0, II=$O(^CHM DIC(741002 .08,"B",CH MFTYPE,II) ) W $E($P( ^CHMDIC(74 1002.08,II ,0),"^",1) ,1,25)
  24691   "RTN","CHM FADR2",82, 0)
  24692    W @CHEOL  Q
  24693   "RTN","CHM FADR2",83, 0)
  24694   QUES S HY= DY,HX=DX G  @QU
  24695   "RTN","CHM FADR2",84, 0)
  24696   1 S DY=14, DX=1 X XY
  24697   "RTN","CHM FADR2",85, 0)
  24698    I CHBTCHN O'=0 S X=$ $INBTCH^CH MFABU3(CHB TCHNO,CHMF PDI,XY,CHE OL) I 'X S  F1=0 Q
  24699   "RTN","CHM FADR2",86, 0)
  24700    W !?4,"PD I must be  15 charact ers long a nd match t he PDI in  IMAGE wind ow.  The"
  24701   "RTN","CHM FADR2",87, 0)
  24702    W !?4,"fi rst 4 digi ts are Fis cal Year,  next 3 are  Julian Da ys, 01-365 .  The"
  24703   "RTN","CHM FADR2",88, 0)
  24704    W !?4,"ne xt 2 digit s show the  scanner n umber ('01 ' or '02') .  The res t of the"
  24705   "RTN","CHM FADR2",89, 0)
  24706    W !?4,"PD I is a seq uential nu mber.  An  example of  a valid P DI is '910 6502131313 '."
  24707   "RTN","CHM FADR2",90, 0)
  24708    G EXIT
  24709   "RTN","CHM FADR2",91, 0)
  24710   2 S DY=15, DX=22 X XY  W "Enter  the Number  of Pages  for this P DI." G EXI T
  24711   "RTN","CHM FADR2",92, 0)
  24712   3 S DY=15, DX=20 X XY  W "Enter  the page t hat is cur rently dis played." G  EXIT
  24713   "RTN","CHM FADR2",93, 0)
  24714   4 S DY=15, DX=13 X XY  W "Enter  the image  number tha t is curre ntly displ ayed" G EX IT
  24715   "RTN","CHM FADR2",94, 0)
  24716   6 S DY=15, DX=20 X XY  W "Enter  Type of do cument or  '?' to see  a list" G  EXIT
  24717   "RTN","CHM FADR2",95, 0)
  24718   7 D CLEARB  S DY=15,D X=8 X XY W  "Enter th e 'Origina l PDI Numb er' based  on the bus iness rule s." G EXIT   ;CPE005- 004
  24719   "RTN","CHM FADR2",96, 0)
  24720   8 D CLEARB  S DY=15,D X=8 X XY W  "Enter th e 'Origina l PDI Numb er' based  on the bus iness rule s." G EXIT   ;CPE005- 069
  24721   "RTN","CHM FADR2",97, 0)
  24722   9 D CLEARB  S DY=15,D X=8 X XY W  "Enter th e 'Current  PDI Numbe r' based o n the busi ness rules ." G EXIT   ;CPE005-0 69
  24723   "RTN","CHM FADR2",98, 0)
  24724   EXIT S DY= HY,DX=HX Q
  24725   "RTN","CHM FADR2",99, 0)
  24726   CHECK K F1  D CLEARB  S LINE="CH K"_QU G @L INE
  24727   "RTN","CHM FADR2",100 ,0)
  24728   CHK1 D MAN UAL
  24729   "RTN","CHM FADR2",101 ,0)
  24730    I '$D(CHM FPDI) S F1 =1 Q   ;JE H 1/8/10 T T 8813
  24731   "RTN","CHM FADR2",102 ,0)
  24732    I $G(CHMF PDI)="" S  F1=1 Q   ; JEH 1/8/10  PCDUO 523 08
  24733   "RTN","CHM FADR2",103 ,0)
  24734    I '$D(CHH AND) S $P( ^CHMIMG(CH MFPDI,0)," ^",17)=2 S  $P(^CHMIM AGE(CHMFPD I,0),"^",8 )=2 S X=$$ INBTCH^CHM FABU3(CHBT CHNO,CHMFP DI,XY,CHEO L) S:'X F1 =0,CHMFPDI ="",CHMNNU M="",$P(^C HMDIC(7410 02.21,DUZ, 0),"^",5)= "",$P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=""  Q  ; Null  subscript  on 8/1/05
  24735   "RTN","CHM FADR2",104 ,0)
  24736    K CHMNNUM  S CHMFNMP G=""
  24737   "RTN","CHM FADR2",105 ,0)
  24738    I PDI I $ D(^CHMIMG( PDI,0)) I  $P(^(0),"^ ",6)>2 D E RR1 S F1=1  Q
  24739   "RTN","CHM FADR2",106 ,0)
  24740    I (Y'?13N )&(Y'?9N)& (Y'?15N) D  QUES S F1 =1 Q
  24741   "RTN","CHM FADR2",107 ,0)
  24742    I $D(^CHM IMPB("C",Y )) I $D(CH BTCHNO) I  CHBTCHNO=0  D INBAT S  F1=1 Q
  24743   "RTN","CHM FADR2",108 ,0)
  24744    I $D(^CHM IMG("READY ",Y)) I $D (CHBTCHNO)  I CHBTCHN O=0 D READ Y S F1=1 Q
  24745   "RTN","CHM FADR2",109 ,0)
  24746    ; Y2K cha nges - Com mented out  per Jim R ichardson
  24747   "RTN","CHM FADR2",110 ,0)
  24748    ;D NOW^%D TC S YR1=$ E(%,2,3),Y R2=$E(Y,1, 2) I YR2>Y R1 D QUES  S F1=1 Q
  24749   "RTN","CHM FADR2",111 ,0)
  24750    ;I YR1-1> YR2 D QUES  S F1=1 Q
  24751   "RTN","CHM FADR2",112 ,0)
  24752    ;I +$E(Y, 3,5)'<366  D QUES S F 1=1 Q
  24753   "RTN","CHM FADR2",113 ,0)
  24754    ;I +$E(Y, 3,5)'>0 D  QUES S F1= 1 Q
  24755   "RTN","CHM FADR2",114 ,0)
  24756    I CHBTCHN O'=0 S X=$ $INBTCH^CH MFABU3(CHB TCHNO,CHMF PDI,XY,CHE OL)
  24757   "RTN","CHM FADR2",115 ,0)
  24758    I 'X I CH BTCHNO'=0  S F1=0 Q
  24759   "RTN","CHM FADR2",116 ,0)
  24760    S $P(^CHM IMG(CHMFPD I,0),"^",1 7)=3  ;SET  SOME PIEC E TO MANUA L MANUAL
  24761   "RTN","CHM FADR2",117 ,0)
  24762    S $P(^CHM IMAGE(CHMF PDI,0),"^" ,8)=3
  24763   "RTN","CHM FADR2",118 ,0)
  24764    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",5)=CH MFPDI Q
  24765   "RTN","CHM FADR2",119 ,0)
  24766   CHK2 Q:Y=" "&(CHMFNMP G'="")  I  (Y'?1N.N)  D QUES S F 1=1 Q
  24767   "RTN","CHM FADR2",120 ,0)
  24768    S CHMFNMP G=Y Q
  24769   "RTN","CHM FADR2",121 ,0)
  24770   CHK3 S:'$D (CHMFPGNM)  CHMFPGNM= "" Q:Y=""
  24771   "RTN","CHM FADR2",122 ,0)
  24772    I CHMFNMP G'="UNK" I  (Y<1)!(Y' ?.N) D QUE S S F1=1 Q
  24773   "RTN","CHM FADR2",123 ,0)
  24774    S:'$D(CHM FPGCT) CHM FPGCT=0 S  CHMFPGNM=Y ,CHMFPGCT= CHMFPGCT+1  Q
  24775   "RTN","CHM FADR2",124 ,0)
  24776   CHK4 S:'$D (CHMFIMAG)  CHMFIMAG= "" Q:Y=""
  24777   "RTN","CHM FADR2",125 ,0)
  24778    I (Y<1)!( Y>7)!(Y'?. N) D QUES  S F1=1 Q
  24779   "RTN","CHM FADR2",126 ,0)
  24780    S CHMFIMA G=Y Q
  24781   "RTN","CHM FADR2",127 ,0)
  24782   CHK6 S:'$D (CHMFTYPE)  CHMFTYPE= "" Q:Y=""
  24783   "RTN","CHM FADR2",128 ,0)
  24784    K CHOUT,C HERR S:$D( DQOUT) Y=" " S CHPRT= Y
  24785   "RTN","CHM FADR2",129 ,0)
  24786    D LIST^DI C(741002.0 8,,".01",, ,,CHPRT,," I $P(^(0), U,3)'=0",, "CHOUT","C HERR")
  24787   "RTN","CHM FADR2",130 ,0)
  24788    I '$D(CHO UT("DILIST ",0)) S DY =10,DX=41  X XY W @CH EOL S F1=1  Q
  24789   "RTN","CHM FADR2",131 ,0)
  24790    I $P(CHOU T("DILIST" ,0),"^",1) '>0 S DY=1 0,DX=41 X  XY W @CHEO L S F1=1 Q
  24791   "RTN","CHM FADR2",132 ,0)
  24792    S DTM=13, DBM=20 X C HMAR S DY= 13,DX=1 X  XY D DISP  Q
  24793   "RTN","CHM FADR2",133 ,0)
  24794   CHK7  ;CPE 005-004
  24795   "RTN","CHM FADR2",134 ,0)
  24796    ;Validati on for "Or iginal" PD I Number f or CHAMPVA  and SB Re -open.
  24797   "RTN","CHM FADR2",135 ,0)
  24798    I Y="",$G (CHMOPDI)= "" S Y="XX XX"
  24799   "RTN","CHM FADR2",136 ,0)
  24800    S VALOPDI =$$CHKOPDI ($G(CHMFPD I),Y,CHOSE N,1) I VAL OPDI S F1= 1
  24801   "RTN","CHM FADR2",137 ,0)
  24802    I Y="XXXX " S Y=""
  24803   "RTN","CHM FADR2",138 ,0)
  24804    Q:$G(F1)= 1
  24805   "RTN","CHM FADR2",139 ,0)
  24806    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=CH MOPDI
  24807   "RTN","CHM FADR2",140 ,0)
  24808    Q
  24809   "RTN","CHM FADR2",141 ,0)
  24810    ;
  24811   "RTN","CHM FADR2",142 ,0)
  24812   CHK8  ;CPE 005-069
  24813   "RTN","CHM FADR2",143 ,0)
  24814    ;Validati on for "Or iginal" PD I Number f or Manual  EDI Re-ope n.
  24815   "RTN","CHM FADR2",144 ,0)
  24816    S VALOPDI =$$CHKOPDI ($G(CHMFPD I),Y,CHOSE N,1) I VAL OPDI S F1= 1 Q
  24817   "RTN","CHM FADR2",145 ,0)
  24818    I Y'="" S  CHMOPDI=Y
  24819   "RTN","CHM FADR2",146 ,0)
  24820    I Y="",CH MOPDI'=""  S Y=CHMOPD I
  24821   "RTN","CHM FADR2",147 ,0)
  24822    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=CH MOPDI
  24823   "RTN","CHM FADR2",148 ,0)
  24824    Q
  24825   "RTN","CHM FADR2",149 ,0)
  24826    ;
  24827   "RTN","CHM FADR2",150 ,0)
  24828   CHK9  ;CPE 005-069
  24829   "RTN","CHM FADR2",151 ,0)
  24830    ;Validati on for "Cu rrent" PDI  Number fo r Manual E DI Re-open .
  24831   "RTN","CHM FADR2",152 ,0)
  24832    I Y="" S  Y="XXXX"
  24833   "RTN","CHM FADR2",153 ,0)
  24834    S VALOPDI =$$CHKOPDI (Y,$G(CHMO PDI),CHOSE N,1) I VAL OPDI S F1= 1
  24835   "RTN","CHM FADR2",154 ,0)
  24836    I Y="XXXX " S Y=""
  24837   "RTN","CHM FADR2",155 ,0)
  24838    Q:$G(F1)= 1
  24839   "RTN","CHM FADR2",156 ,0)
  24840    S CHMFPDI =Y
  24841   "RTN","CHM FADR2",157 ,0)
  24842    I CHMFPDI '="" D
  24843   "RTN","CHM FADR2",158 ,0)
  24844    .S $P(^CH MIMG(CHMFP DI,0),"^", 17)=4 S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=4
  24845   "RTN","CHM FADR2",159 ,0)
  24846    .S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",5)=C HMFPDI
  24847   "RTN","CHM FADR2",160 ,0)
  24848    .S CHMFPP ="SIP" D ^ CHMFWK01
  24849   "RTN","CHM FADR2",161 ,0)
  24850    Q
  24851   "RTN","CHM FADR2",162 ,0)
  24852    ;
  24853   "RTN","CHM FADR2",163 ,0)
  24854   DISP I $P( CHOUT("DIL IST",0),"^ ",1)=1 D   Q
  24855   "RTN","CHM FADR2",164 ,0)
  24856    .S CHMFIM TY=CHOUT(" DILIST",2, 1),CHMFTYP E=CHOUT("D ILIST",1,1 )
  24857   "RTN","CHM FADR2",165 ,0)
  24858    S L1=0,CT =0
  24859   "RTN","CHM FADR2",166 ,0)
  24860   DI1 S L1=$ O(CHOUT("D ILIST",1,L 1)) I 'L1  D SELE1 Q
  24861   "RTN","CHM FADR2",167 ,0)
  24862    S CT=CT+1  W !,L1,"    ",CHOUT( "DILIST",1 ,L1)
  24863   "RTN","CHM FADR2",168 ,0)
  24864    S X="" I  '(CT#5) I  $O(CHOUT(" DILIST",1, L1)) D SEL E
  24865   "RTN","CHM FADR2",169 ,0)
  24866    G:X="" DI 1
  24867   "RTN","CHM FADR2",170 ,0)
  24868    S CHMFIMT Y=CHOUT("D ILIST",2,X )
  24869   "RTN","CHM FADR2",171 ,0)
  24870    S CHMFTYP E=CHOUT("D ILIST",1,X ) Q
  24871   "RTN","CHM FADR2",172 ,0)
  24872   SELE S X=" " W !!,"Se lect a num ber or <RE TURN> for  more: " R  X
  24873   "RTN","CHM FADR2",173 ,0)
  24874    Q:X=""  G :'$D(CHOUT ("DILIST", 1,X)) SELE  Q
  24875   "RTN","CHM FADR2",174 ,0)
  24876   SELE1 S X= "" W !!,"S elect a nu mber: " R  X
  24877   "RTN","CHM FADR2",175 ,0)
  24878    Q:X=""  G :'$D(CHOUT ("DILIST", 1,X)) SELE 1
  24879   "RTN","CHM FADR2",176 ,0)
  24880    S CHMFIMT Y=CHOUT("D ILIST",2,X )
  24881   "RTN","CHM FADR2",177 ,0)
  24882    S CHMFTYP E=CHOUT("D ILIST",1,X ) Q
  24883   "RTN","CHM FADR2",178 ,0)
  24884   MANUAL I $ P(^CHMDIC( 741002.21, DUZ,0),"^" ,10)'=0 Q
  24885   "RTN","CHM FADR2",179 ,0)
  24886    K CHHAND  I $D(CHMFP DI) I CHMF PDI'="" K  ^CHMIMAGE( "LOCK",CHM FPDI) D
  24887   "RTN","CHM FADR2",180 ,0)
  24888    .I $D(CHM NNUM) S ^C HMIMG("MAN UAL",CHMFP DI)="" Q
  24889   "RTN","CHM FADR2",181 ,0)
  24890    S CHMFPDI =Y
  24891   "RTN","CHM FADR2",182 ,0)
  24892    S PDI=0,P DI=$O(^CHM IMG("E",Y, PDI)) I 'P DI S CHHAN D=1 Q
  24893   "RTN","CHM FADR2",183 ,0)
  24894    I '$D(^CH MIMG("MANU AL",PDI))  S CHHAND=1  Q
  24895   "RTN","CHM FADR2",184 ,0)
  24896    S CHMNNUM =Y,Y=PDI,C HMFPDI=PDI ,$P(^CHMDI C(741002.2 1,DUZ,0)," ^",5)=CHMF PDI
  24897   "RTN","CHM FADR2",185 ,0)
  24898    S CHMFNMP G=$P(^CHMI MG(PDI,0), "^",2) K ^ CHMIMG("MA NUAL",PDI)
  24899   "RTN","CHM FADR2",186 ,0)
  24900    Q:$ZF(-1, "DISPLAY_D EVICE")'[" LAT"  ;D A 1^CHMFPDI  Q:$D(CHQUI T)
  24901   "RTN","CHM FADR2",187 ,0)
  24902    S ZZPDI=C HMFPDI,CHM FPP="SIP"  D ^CHMFWK0 1 Q
  24903   "RTN","CHM FADR2",188 ,0)
  24904   SCREEN I $ P(^CHMDIC( 741002.21, DUZ,0),"^" ,10)=0 S D Y=5,DX=27  X XY W "Ba tch Number : " W:$D(C HBTCHNO) C HBTCHNO
  24905   "RTN","CHM FADR2",189 ,0)
  24906    ;BEGIN CP E005-004
  24907   "RTN","CHM FADR2",190 ,0)
  24908    N PDIFNL, NPDI,REVRE SP,OPDI
  24909   "RTN","CHM FADR2",191 ,0)
  24910    I CHOSEN= 6!(CHOSEN= 7)!(CHOSEN =8) D  ;CP E005-069 a dd CHOSEN= 8 check.
  24911   "RTN","CHM FADR2",192 ,0)
  24912    .I $G(CHM OPDI)="",C HOSEN'=8 S  QU=7 N Y  S Y="" D C HECK  ;All ow validat ion messag e to displ ay for inv alid PDI's .
  24913   "RTN","CHM FADR2",193 ,0)
  24914    .S DY=5,D X=20 X XY  W "Origina l PDI Numb er: " W:$D (CHMOPDI)  CHMOPDI
  24915   "RTN","CHM FADR2",194 ,0)
  24916    .S DY=6,D X=21 X XY  W "Current  PDI Numbe r: " W:$D( CHMFPDI) C HMFPDI
  24917   "RTN","CHM FADR2",195 ,0)
  24918    I CHOSEN' =6,CHOSEN' =7,CHOSEN' =8 S DY=6, DX=29 X XY  W "PDI Nu mber: " W: $D(CHMFPDI ) CHMFPDI   ;CPE005-0 69 add CHO SEN'=8.
  24919   "RTN","CHM FADR2",196 ,0)
  24920    ;END CPE0 05-004 
  24921   "RTN","CHM FADR2",197 ,0)
  24922    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=1  I $D(CHDO CID) W:CHD OCID'="" " -",CHDOCID
  24923   "RTN","CHM FADR2",198 ,0)
  24924    ;S CHPDIP RL=$$PDITY P^CHMFAUT1 (CHMFPDI)
  24925   "RTN","CHM FADR2",199 ,0)
  24926    ;D:CHPDIP RL TLPGCNT
  24927   "RTN","CHM FADR2",200 ,0)
  24928    S DY=7,DX =28 X XY W  "Total Pa ges: " W:$ D(CHMFNMPG ) CHMFNMPG
  24929   "RTN","CHM FADR2",201 ,0)
  24930    S DY=8,DX =28 X XY W  "Page Num ber: " W:$ D(CHMFPGNM ) CHMFPGNM
  24931   "RTN","CHM FADR2",202 ,0)
  24932    ;S DY=9,D X=27 X XY  W "Image N umber: " W :$D(CHMFIM AG) CHMFIM AG
  24933   "RTN","CHM FADR2",203 ,0)
  24934    S DY=9,DX =26 X XY W  "Type of  Image: " W :$D(CHMFTY PE) $E(CHM FTYPE,1,21 )
  24935   "RTN","CHM FADR2",204 ,0)
  24936    S DY=10,D X=24 X XY  W "Image A vailable:  " D IMAGE
  24937   "RTN","CHM FADR2",205 ,0)
  24938    S DY=11,D X=1 X XY S  LN="" S $ P(LN,"_",8 0)="" W LN
  24939   "RTN","CHM FADR2",206 ,0)
  24940    I CHOSEN= 6!(CHOSEN= 7) D  ;CPE 005-007
  24941   "RTN","CHM FADR2",207 ,0)
  24942    . S DY=12 ,DX=21 X X Y W "Type  of Bill (T OB): " W $ $TOB(CHMFP DI,CHMFPGN M,CHMFIMAG ) ; KML -  5/4/17
  24943   "RTN","CHM FADR2",208 ,0)
  24944    Q
  24945   "RTN","CHM FADR2",209 ,0)
  24946    ;   
  24947   "RTN","CHM FADR2",210 ,0)
  24948   NOOHI S DY =18,DX=10  X XY
  24949   "RTN","CHM FADR2",211 ,0)
  24950    W "No Bil l Invoice  has been e nterd to a llow entry  of OHI Pa yments."
  24951   "RTN","CHM FADR2",212 ,0)
  24952    Q
  24953   "RTN","CHM FADR2",213 ,0)
  24954    ;
  24955   "RTN","CHM FADR2",214 ,0)
  24956   ERR1 S DY= 15,DX=5 X  XY W *7,*7 ,@CHBON,"T his PDI ha s already  been proce ssed!"
  24957   "RTN","CHM FADR2",215 ,0)
  24958    W " Canno t be modif ied at thi s point!", @CHBOFF
  24959   "RTN","CHM FADR2",216 ,0)
  24960    Q
  24961   "RTN","CHM FADR2",217 ,0)
  24962    ;
  24963   "RTN","CHM FADR2",218 ,0)
  24964   ERR3 D CLE ARB S DY=1 5,DX=8 X X Y
  24965   "RTN","CHM FADR2",219 ,0)
  24966    W "PDI: " ,Y," - has  not been  Scanned or  Manually  entered!"
  24967   "RTN","CHM FADR2",220 ,0)
  24968    W !,?28," Please ver ify this P DI number  and re-ent er." Q 
  24969   "RTN","CHM FADR2",221 ,0)
  24970   INBAT D CL EARB S DY= 15,DX=13 X  XY
  24971   "RTN","CHM FADR2",222 ,0)
  24972    W "This P DI is not  a Manual P DI.  Pleas e Re-enter ."
  24973   "RTN","CHM FADR2",223 ,0)
  24974    Q
  24975   "RTN","CHM FADR2",224 ,0)
  24976    ;
  24977   "RTN","CHM FADR2",225 ,0)
  24978   READY D CL EARB S DY= 15,DX=14 X  XY
  24979   "RTN","CHM FADR2",226 ,0)
  24980    W "This P DI is Imag e processi ng only.   Please Re- enter."
  24981   "RTN","CHM FADR2",227 ,0)
  24982    Q
  24983   "RTN","CHM FADR2",228 ,0)
  24984    ;
  24985   "RTN","CHM FADR2",229 ,0)
  24986   PDI15 D CL EARB S DY= 15,DX=27 X  XY W *7,@ CHBON
  24987   "RTN","CHM FADR2",230 ,0)
  24988    W "PDI Nu mber must  be 15 digi ts.",@CHBO FF
  24989   "RTN","CHM FADR2",231 ,0)
  24990    Q
  24991   "RTN","CHM FADR2",232 ,0)
  24992    ;
  24993   "RTN","CHM FADR2",233 ,0)
  24994   JUL2000 D  CLEARB S D Y=15,DX=21  X XY W *7 ,@CHBON  ; Validation  message f or Julian  Year less  than 2000.
  24995   "RTN","CHM FADR2",234 ,0)
  24996    W "Julian  Year must  be year 2 000 or lat er.",@CHBO FF
  24997   "RTN","CHM FADR2",235 ,0)
  24998    Q
  24999   "RTN","CHM FADR2",236 ,0)
  25000    ;
  25001   "RTN","CHM FADR2",237 ,0)
  25002   JULFUTR D  CLEARB S D Y=15,DX=23  X XY W *7 ,@CHBON  ; Validation  message f or Julian  Year great er than Cu rrent Year .
  25003   "RTN","CHM FADR2",238 ,0)
  25004    W "Julian  Year cann ot be in t he future. ",@CHBOFF
  25005   "RTN","CHM FADR2",239 ,0)
  25006    Q
  25007   "RTN","CHM FADR2",240 ,0)
  25008   JULDAY D C LEARB S DY =15,DX=23  X XY W *7, @CHBON  ;V alidation  message fo r Julian D ay.
  25009   "RTN","CHM FADR2",241 ,0)
  25010    W "Julian  Day must  be 001 thr ough 366." ,@CHBOFF
  25011   "RTN","CHM FADR2",242 ,0)
  25012    Q
  25013   "RTN","CHM FADR2",243 ,0)
  25014    ;
  25015   "RTN","CHM FADR2",244 ,0)
  25016   CHPIMSG D  CLEARB S D Y=15,DX=16  X XY W *7 ,@CHBON  ; Validation  message f or CHAMPVA  Program I ndicator.
  25017   "RTN","CHM FADR2",245 ,0)
  25018    W "PDI Pr ogram Indi cator must  be 91, 97 (CHAMPVA E DI).",@CHB OFF
  25019   "RTN","CHM FADR2",246 ,0)
  25020    Q
  25021   "RTN","CHM FADR2",247 ,0)
  25022   SBPIMSG D  CLEARB S D Y=15,DX=18  X XY W *7 ,@CHBON  ; Validation  message f or Spina B ifida Prog ram Indica tor.
  25023   "RTN","CHM FADR2",248 ,0)
  25024    W "PDI Pr ogram Indi cator must  be 92, 90 (SB EDI)." ,@CHBOFF
  25025   "RTN","CHM FADR2",249 ,0)
  25026    Q
  25027   "RTN","CHM FADR2",250 ,0)
  25028    ;
  25029   "RTN","CHM FADR2",251 ,0)
  25030   CHKOPDI(CH MFPDI,CHMO PDI,CHOSEN ,WRTMSG) ; CPE005-004  
  25031   "RTN","CHM FADR2",252 ,0)
  25032    ;Validati ons for Or iginal and  Current E DI Re-open  PDI Numbe rs.
  25033   "RTN","CHM FADR2",253 ,0)
  25034    ;User Sto ries CPE00 5-073, 074 , 075, 076 , 077 and  080 added  to validat ions.
  25035   "RTN","CHM FADR2",254 ,0)
  25036    ;CHMFPDI  = Current  PDI Number
  25037   "RTN","CHM FADR2",255 ,0)
  25038    ;CHMOPDI  = Original  PDI Numbe r
  25039   "RTN","CHM FADR2",256 ,0)
  25040    ;CHOSEN =  The menu  option the  user chos e from rou tine drive r CHMFADRV .
  25041   "RTN","CHM FADR2",257 ,0)
  25042    ;WRTMSG =  0 or 1 -  0 does not  display m essage to  the screen ; 1 does.
  25043   "RTN","CHM FADR2",258 ,0)
  25044    I $G(CHOS EN)'=6,$G( CHOSEN)'=7 ,$G(CHOSEN )'=8 Q 0 ; Validation s for EDI  Re-open on ly; Menu o ptions "RC ", "RS" an d "ER".
  25045   "RTN","CHM FADR2",259 ,0)
  25046    N ALLCOMP ,BENE,CURD T,CURYR,DY ,DX,ERR,IE N,JDAY,STA TUS
  25047   "RTN","CHM FADR2",260 ,0)
  25048    S CHMFPDI =$G(CHMFPD I),CHMOPDI =$G(CHMOPD I),CHOSEN= $G(CHOSEN) ,WRTMSG=$G (WRTMSG)
  25049   "RTN","CHM FADR2",261 ,0)
  25050    S (BENE,E RR)=0
  25051   "RTN","CHM FADR2",262 ,0)
  25052    I CHOSEN= 8,CHMOPDI= "" Q 0 ;Al low user t o advance  to bottom  menu at th e Original  PDI numbe r prompt i n the "ER"  option.
  25053   "RTN","CHM FADR2",263 ,0)
  25054    I CHMOPDI '?15N!(CHM OPDI="") D   Q ERR ;C PE005-004  and 080
  25055   "RTN","CHM FADR2",264 ,0)
  25056    .I WRTMSG  D PDI15
  25057   "RTN","CHM FADR2",265 ,0)
  25058    .S ERR=1
  25059   "RTN","CHM FADR2",266 ,0)
  25060    I CHOSEN= 8,CHMFPDI' ="",CHMFPD I'?15N D   Q ERR  ;CP E005-080
  25061   "RTN","CHM FADR2",267 ,0)
  25062    .I WRTMSG  D PDI15
  25063   "RTN","CHM FADR2",268 ,0)
  25064    .S ERR=1
  25065   "RTN","CHM FADR2",269 ,0)
  25066    I $E(CHMO PDI,1,4)<2 000 D  Q E RR  ;CPE00 5-004 and  078
  25067   "RTN","CHM FADR2",270 ,0)
  25068    .I WRTMSG  D JUL2000
  25069   "RTN","CHM FADR2",271 ,0)
  25070    .S ERR=1
  25071   "RTN","CHM FADR2",272 ,0)
  25072    I CHOSEN= 8,CHMFPDI' ="",$E(CHM FPDI,1,4)< 2000 D  Q  ERR  ;CPE0 05-080
  25073   "RTN","CHM FADR2",273 ,0)
  25074    .I WRTMSG  D JUL2000
  25075   "RTN","CHM FADR2",274 ,0)
  25076    .S ERR=1
  25077   "RTN","CHM FADR2",275 ,0)
  25078    S CURDT=$ $HTE^XLFDT ($H,7),CUR YR=$E(CURD T,1,4)
  25079   "RTN","CHM FADR2",276 ,0)
  25080    I $E(CHMO PDI,1,4)>C URYR D  Q  ERR  ;CPE0 05-004 and  073
  25081   "RTN","CHM FADR2",277 ,0)
  25082    .I WRTMSG  D JULFUTR
  25083   "RTN","CHM FADR2",278 ,0)
  25084    .S ERR=1
  25085   "RTN","CHM FADR2",279 ,0)
  25086    I CHOSEN= 8,CHMFPDI' ="",$E(CHM FPDI,1,4)> CURYR D  Q  ERR  ;CPE 005-073
  25087   "RTN","CHM FADR2",280 ,0)
  25088    .I WRTMSG  D JULFUTR
  25089   "RTN","CHM FADR2",281 ,0)
  25090    .S ERR=1
  25091   "RTN","CHM FADR2",282 ,0)
  25092    N X,CHJUL
  25093   "RTN","CHM FADR2",283 ,0)
  25094    D NOW^%DT C S:'$D(X)  X=DT
  25095   "RTN","CHM FADR2",284 ,0)
  25096    S X=$E(DT ,1,3)_"000 0" D H^%DT C S CHJUL= ($P($H,"," ,1)-%H)+1
  25097   "RTN","CHM FADR2",285 ,0)
  25098    ;S JDAY=$ E(CHMOPDI, 5,7)
  25099   "RTN","CHM FADR2",286 ,0)
  25100    I $E(CHMO PDI,5,7)<" 001"!($E(C HMOPDI,5,7 )>"366") D   Q ERR  ; CPE005-004  and 074
  25101   "RTN","CHM FADR2",287 ,0)
  25102    .I WRTMSG  D JULDAY
  25103   "RTN","CHM FADR2",288 ,0)
  25104    .S ERR=1
  25105   "RTN","CHM FADR2",289 ,0)
  25106    I CHOSEN= 8,CHMFPDI' ="" D  I E RR Q 1 ;CP E005-074
  25107   "RTN","CHM FADR2",290 ,0)
  25108    .I $E(CHM FPDI,5,7)< "001"!($E( CHMFPDI,5, 7)>"366")  D
  25109   "RTN","CHM FADR2",291 ,0)
  25110    ..I WRTMS G D JULDAY
  25111   "RTN","CHM FADR2",292 ,0)
  25112    ..S ERR=1
  25113   "RTN","CHM FADR2",293 ,0)
  25114    I CHOSEN= 8,CHMOPDI' ="",CHMFPD I'="",$E(C HMOPDI,8,9 )=91,$E(CH MFPDI,8,9) '=97 D  Q  ERR  ;CPE0 05-075
  25115   "RTN","CHM FADR2",294 ,0)
  25116    .I WRTMSG  D CHPIMSG
  25117   "RTN","CHM FADR2",295 ,0)
  25118    .S ERR=1
  25119   "RTN","CHM FADR2",296 ,0)
  25120    I CHOSEN= 8,CHMOPDI' ="",CHMFPD I'="",$E(C HMOPDI,8,9 )=92,$E(CH MFPDI,8,9) '=90 D  Q  ERR  ;CPE0 05-075
  25121   "RTN","CHM FADR2",297 ,0)
  25122    .I WRTMSG  D SBPIMSG
  25123   "RTN","CHM FADR2",298 ,0)
  25124    .S ERR=1
  25125   "RTN","CHM FADR2",299 ,0)
  25126    I CHOSEN= 6,CHMOPDI' ="",$E(CHM OPDI,8,9)' =91,$E(CHM OPDI,8,9)' =97 D  Q E RR  ;CPE00 5-004
  25127   "RTN","CHM FADR2",300 ,0)
  25128    .I WRTMSG  D CHPIMSG
  25129   "RTN","CHM FADR2",301 ,0)
  25130    .S ERR=1
  25131   "RTN","CHM FADR2",302 ,0)
  25132    I CHOSEN= 7,CHMOPDI' ="",$E(CHM OPDI,8,9)' =92,$E(CHM OPDI,8,9)' =90 D  Q E RR  ;CPE00 5-004
  25133   "RTN","CHM FADR2",303 ,0)
  25134    .I WRTMSG  D SBPIMSG
  25135   "RTN","CHM FADR2",304 ,0)
  25136    .S ERR=1
  25137   "RTN","CHM FADR2",305 ,0)
  25138    I CHOSEN= 8,CHMOPDI' ="",$E(CHM OPDI,8,9)' =90,$E(CHM OPDI,8,9)' =91,$E(CHM OPDI,8,9)' =92,$E(CHM OPDI,8,9)' =97 D  Q E RR
  25139   "RTN","CHM FADR2",306 ,0)
  25140    .I WRTMSG  D
  25141   "RTN","CHM FADR2",307 ,0)
  25142    ..D CLEAR B
  25143   "RTN","CHM FADR2",308 ,0)
  25144    ..S DY=15 ,DX=22 X X Y W *7,@CH BON,"Origi nal PDI Pr ogram Indi cator must  be:"
  25145   "RTN","CHM FADR2",309 ,0)
  25146    ..S DY=16 ,DX=31 X X Y W "91 or  97 for CH AMPVA;"
  25147   "RTN","CHM FADR2",310 ,0)
  25148    ..S DY=17 ,DX=28 X X Y W "92 or  90 for Sp ina Bifida .",@CHBOFF
  25149   "RTN","CHM FADR2",311 ,0)
  25150    .S ERR=1
  25151   "RTN","CHM FADR2",312 ,0)
  25152    I CHMOPDI '="" D  I  ERR Q 1  ; CPE005-117  and CPE00 5-118
  25153   "RTN","CHM FADR2",313 ,0)
  25154    .I '$D(^C HMPAY("C", CHMOPDI))  D
  25155   "RTN","CHM FADR2",314 ,0)
  25156    ..I WRTMS G D 
  25157   "RTN","CHM FADR2",315 ,0)
  25158    ...D CLEA RB
  25159   "RTN","CHM FADR2",316 ,0)
  25160    ...S DY=1 5,DX=15 X  XY W *7,@C HBON,"Ther e are no a ttached cl aims to th e Original  PDI numbe r.",@CHBOF F
  25161   "RTN","CHM FADR2",317 ,0)
  25162    ..S ERR=1
  25163   "RTN","CHM FADR2",318 ,0)
  25164    I CHMOPDI '="" D  I  ERR Q 1
  25165   "RTN","CHM FADR2",319 ,0)
  25166    .I $P($G( ^CHMIMG(CH MOPDI,0)), "^",6)=11  D  ;CPE005 -124, 125,  126 and 1 27.
  25167   "RTN","CHM FADR2",320 ,0)
  25168    ..I WRTMS G D
  25169   "RTN","CHM FADR2",321 ,0)
  25170    ...D CLEA RB
  25171   "RTN","CHM FADR2",322 ,0)
  25172    ...S DY=1 5,DX=21 X  XY W *7,@C HBON,"The  Original P DI has a V oided stat us.",@CHBO FF
  25173   "RTN","CHM FADR2",323 ,0)
  25174    ..S ERR=1
  25175   "RTN","CHM FADR2",324 ,0)
  25176    I CHMOPDI '="",$P($G (^CHMIMG(C HMOPDI,"E- REOPEN")), "^",3)=1 D   Q ERR  ; CPE005-004  and 077
  25177   "RTN","CHM FADR2",325 ,0)
  25178    .I WRTMSG  D 
  25179   "RTN","CHM FADR2",326 ,0)
  25180    ..D CLEAR B
  25181   "RTN","CHM FADR2",327 ,0)
  25182    ..S DY=15 ,DX=20 X X Y W *7,@CH BON,"PDI N umber has  already be en reopene d.",@CHBOF F  ;CPE005 -085
  25183   "RTN","CHM FADR2",328 ,0)
  25184    .S ERR=1
  25185   "RTN","CHM FADR2",329 ,0)
  25186    I CHMOPDI '="" D  I  $G(ERR) Q  1 ;CPE005- 079
  25187   "RTN","CHM FADR2",330 ,0)
  25188    .S ALLCOM P=$$CMPCLA IM(CHMOPDI )
  25189   "RTN","CHM FADR2",331 ,0)
  25190    .I 'ALLCO MP D  ;All  claims ha ve been co mpleted. D o not allo w furthur  processing  on Origin al PDI.
  25191   "RTN","CHM FADR2",332 ,0)
  25192    ..I WRTMS G D 
  25193   "RTN","CHM FADR2",333 ,0)
  25194    ...D CLEA RB
  25195   "RTN","CHM FADR2",334 ,0)
  25196    ...S DY=1 5,DX=15 X  XY W *7,@C HBON,"Cann ot ReOpen  PDI. All c laims have  not been  completed. ",@CHBOFF
  25197   "RTN","CHM FADR2",335 ,0)
  25198    ..S ERR=1
  25199   "RTN","CHM FADR2",336 ,0)
  25200    I CHMOPDI '="" D  I  $G(ERR) Q  1 ;CPE005- 111,112,11 3,114
  25201   "RTN","CHM FADR2",337 ,0)
  25202    .S ALLCOM P=$$RVSCLA IM(CHMOPDI )
  25203   "RTN","CHM FADR2",338 ,0)
  25204    .I 'ALLCO MP D  ;No  claims hav e been rev ersed. Do  not allow  furthur pr ocessing o n Original  PDI.
  25205   "RTN","CHM FADR2",339 ,0)
  25206    ..I WRTMS G D 
  25207   "RTN","CHM FADR2",340 ,0)
  25208    ...D CLEA RB
  25209   "RTN","CHM FADR2",341 ,0)
  25210    ...S DY=1 5,DX=22 X  XY W *7,@C HBON,"A pr ior claim  has been r eversed.", @CHBOFF
  25211   "RTN","CHM FADR2",342 ,0)
  25212    ..S ERR=1
  25213   "RTN","CHM FADR2",343 ,0)
  25214    Q ERR
  25215   "RTN","CHM FADR2",344 ,0)
  25216    ;
  25217   "RTN","CHM FADR2",345 ,0)
  25218   BENECHK(CH MOPDI,CHMF PDI,CHOSEN ,WRTMSG)   ;Verify Or iginal and  Current B ene's matc h - CPE005 -122 and 1 23.
  25219   "RTN","CHM FADR2",346 ,0)
  25220    ;Benefici ary valida tion.
  25221   "RTN","CHM FADR2",347 ,0)
  25222    ;CHMFPDI  = Current  PDI Number
  25223   "RTN","CHM FADR2",348 ,0)
  25224    ;CHMOPDI  = Original  PDI Numbe r
  25225   "RTN","CHM FADR2",349 ,0)
  25226    ;CHOSEN =  The menu  option the  user chos e from rou tine drive r CHMFADRV .
  25227   "RTN","CHM FADR2",350 ,0)
  25228    ;WRTMSG =  0 or 1 -  0 does not  display m essage to  the screen ; 1 does.
  25229   "RTN","CHM FADR2",351 ,0)
  25230    N FOUND,P AGENUM1,PA GENUM2
  25231   "RTN","CHM FADR2",352 ,0)
  25232    S CHMOPDI =$G(CHMOPD I),CHMFPDI =$G(CHMFPD I),CHOSEN= $G(CHOSEN) ,WRTMSG=$G (WRTMSG)
  25233   "RTN","CHM FADR2",353 ,0)
  25234    S (ERR,FO UND)=0
  25235   "RTN","CHM FADR2",354 ,0)
  25236    S (PAGENU M1,PAGENUM 2)=""
  25237   "RTN","CHM FADR2",355 ,0)
  25238    I CHMOPDI '="" D
  25239   "RTN","CHM FADR2",356 ,0)
  25240    .I $D(^CH MIMAGE(CHM OPDI,0)) D
  25241   "RTN","CHM FADR2",357 ,0)
  25242    ..S PAGEN UM1=$P($G( ^CHMIMAGE( CHMOPDI,0) ),"^",2)
  25243   "RTN","CHM FADR2",358 ,0)
  25244    ..I PAGEN UM1="UNK"  S PAGENUM1 =1
  25245   "RTN","CHM FADR2",359 ,0)
  25246    ..I CHMFP DI'="" D   ;CPE005-12 2 and 123  Check for  the existe nce of dat a for the  Current PD I before d oing bene  check.
  25247   "RTN","CHM FADR2",360 ,0)
  25248    ...I $D(^ CHMIMAGE(C HMFPDI,0))  D
  25249   "RTN","CHM FADR2",361 ,0)
  25250    ....S PAG ENUM2=$P($ G(^CHMIMAG E(CHMFPDI, 0)),"^",2)
  25251   "RTN","CHM FADR2",362 ,0)
  25252    ....I PAG ENUM2="UNK "!(PAGENUM 2="") S PA GENUM2=1
  25253   "RTN","CHM FADR2",363 ,0)
  25254    ....I $D( ^CHMIMAGE( CHMFPDI,1, PAGENUM2,2 ,1,10)) S  FOUND=1
  25255   "RTN","CHM FADR2",364 ,0)
  25256    ....;I $D (^CHMIMAGE (CHMOPDI,1 ,PAGENUM1, 2,1,10)),' $D(^CHMIMA GE(CHMFPDI ,1,PAGENUM 2,2,1,10))  S FOUND=1
  25257   "RTN","CHM FADR2",365 ,0)
  25258    ...I FOUN D S BENE=$ $CHKBENE(C HMOPDI,CHM FPDI,PAGEN UM1,PAGENU M2) I 'BEN E D
  25259   "RTN","CHM FADR2",366 ,0)
  25260    ....I WRT MSG D
  25261   "RTN","CHM FADR2",367 ,0)
  25262    .....D CL EARB
  25263   "RTN","CHM FADR2",368 ,0)
  25264    .....S DY =15
  25265   "RTN","CHM FADR2",369 ,0)
  25266    .....I CH OSEN=6!(CH OSEN=7) S  DX=14 X XY  W *7,@CHB ON,"Benefi ciary does  not match  - enter t he Origina l PDI Numb er.",@CHBO FF
  25267   "RTN","CHM FADR2",370 ,0)
  25268    .....I CH OSEN=8 S D X=25 X XY  W *7,@CHBO N,"The ben eficiary d oes not ma tch.",@CHB OFF
  25269   "RTN","CHM FADR2",371 ,0)
  25270    ....S ERR =1
  25271   "RTN","CHM FADR2",372 ,0)
  25272    Q ERR
  25273   "RTN","CHM FADR2",373 ,0)
  25274    ;
  25275   "RTN","CHM FADR2",374 ,0)
  25276   CMPCLAIM(P DI) ;Check  to see if  all assoc iated clai ms for Ori ginal PDI  have been  completed.
  25277   "RTN","CHM FADR2",375 ,0)
  25278                  ;If an y of the c laims have  not been  completed,  then a fa lse value  is returne d.
  25279   "RTN","CHM FADR2",376 ,0)
  25280    ;PDI = Or iginal PDI  Number
  25281   "RTN","CHM FADR2",377 ,0)
  25282    S PDI=$G( PDI)
  25283   "RTN","CHM FADR2",378 ,0)
  25284    S COMPLET E=1 ;
  25285   "RTN","CHM FADR2",379 ,0)
  25286    I '$D(^CH MPAY("C",P DI)) Q 0
  25287   "RTN","CHM FADR2",380 ,0)
  25288    S IEN=0 F   S IEN=$O (^CHMPAY(" C",PDI,IEN )) Q:'IEN! ('COMPLETE )  D
  25289   "RTN","CHM FADR2",381 ,0)
  25290    .S STATUS =$P(^CHMPA Y(IEN,0)," ^",2)
  25291   "RTN","CHM FADR2",382 ,0)
  25292    .I STATUS =1!(STATUS =2)!(STATU S=3)!(STAT US=6)!(STA TUS=7)!(ST ATUS=8)!(S TATUS=9) S  COMPLETE= 0
  25293   "RTN","CHM FADR2",383 ,0)
  25294    Q COMPLET E
  25295   "RTN","CHM FADR2",384 ,0)
  25296    ;
  25297   "RTN","CHM FADR2",385 ,0)
  25298   RVSCLAIM(P DI) ;Check  to see if  any assoc iated clai ms for Ori ginal PDI  have been  reversed.
  25299   "RTN","CHM FADR2",386 ,0)
  25300                  ;If an y of the c laims have  been reve rsed, then  a false v alue is re turned.
  25301   "RTN","CHM FADR2",387 ,0)
  25302    ;PDI = Or iginal PDI  Number
  25303   "RTN","CHM FADR2",388 ,0)
  25304    S PDI=$G( PDI)
  25305   "RTN","CHM FADR2",389 ,0)
  25306    S COMPLET E=1 ;
  25307   "RTN","CHM FADR2",390 ,0)
  25308    I '$D(^CH MPAY("C",P DI)) Q 0
  25309   "RTN","CHM FADR2",391 ,0)
  25310    S IEN=0 F   S IEN=$O (^CHMPAY(" C",PDI,IEN )) Q:'IEN! ('COMPLETE )  D
  25311   "RTN","CHM FADR2",392 ,0)
  25312    .S STATUS =$P(^CHMPA Y(IEN,0)," ^",2)
  25313   "RTN","CHM FADR2",393 ,0)
  25314    .I STATUS =12 S COMP LETE=0 ;CP E005-111,1 12,113,114  bdb 01032 018
  25315   "RTN","CHM FADR2",394 ,0)
  25316    Q COMPLET E
  25317   "RTN","CHM FADR2",395 ,0)
  25318    ;
  25319   "RTN","CHM FADR2",396 ,0)
  25320   CHKBENE(CH MOPDI,CHMF PDI,PAGENU M1,PAGENUM 2) ;Check  beneficiar y for vali dation pur poses
  25321   "RTN","CHM FADR2",397 ,0)
  25322    ;CHMOPDI   = Origina l PDI Numb er
  25323   "RTN","CHM FADR2",398 ,0)
  25324    ;CHMFPDI   = Current  PDI Numbe r
  25325   "RTN","CHM FADR2",399 ,0)
  25326    ;PAGENUM1  = Page nu mber for O riginal PD I
  25327   "RTN","CHM FADR2",400 ,0)
  25328    ;PAGENUM2  = Page nu mber for C urrent PDI  
  25329   "RTN","CHM FADR2",401 ,0)
  25330    N BFN,CUR RBEN,D1,D2 ,DATA0,DAT A10,IEN,OR IGBEN,SPON NUM
  25331   "RTN","CHM FADR2",402 ,0)
  25332    S CHMOPDI =$G(CHMOPD I),CHMFPDI =$G(CHMFPD I)
  25333   "RTN","CHM FADR2",403 ,0)
  25334    S (ORIGBE N,CURRBEN, IEN)=""
  25335   "RTN","CHM FADR2",404 ,0)
  25336    I $D(^CHM PAY("C",CH MOPDI)) D
  25337   "RTN","CHM FADR2",405 ,0)
  25338    .S IEN=$O (^CHMPAY(" C",CHMOPDI ,""))
  25339   "RTN","CHM FADR2",406 ,0)
  25340    .S DATA0= ^CHMPAY(IE N,0)
  25341   "RTN","CHM FADR2",407 ,0)
  25342    .S SPONNU M=$P(DATA0 ,"^",21)
  25343   "RTN","CHM FADR2",408 ,0)
  25344    .S BFN=$P (DATA0,"^" ,22)
  25345   "RTN","CHM FADR2",409 ,0)
  25346    .S ORIGBE N=SPONNUM_ "/"_BFN
  25347   "RTN","CHM FADR2",410 ,0)
  25348    I ORIGBEN ="" D
  25349   "RTN","CHM FADR2",411 ,0)
  25350    .I PAGENU M1'="",$D( ^CHMIMAGE( CHMOPDI,1, PAGENUM1,2 ,1,10)) D
  25351   "RTN","CHM FADR2",412 ,0)
  25352    ..S DATA1 0=^CHMIMAG E(CHMOPDI, 1,PAGENUM1 ,2,1,10)
  25353   "RTN","CHM FADR2",413 ,0)
  25354    ..S SPONN UM=$P(DATA 10,"^"),BF N=$P(DATA1 0,"^",2)
  25355   "RTN","CHM FADR2",414 ,0)
  25356    ..S ORIGB EN=SPONNUM _"/"_BFN
  25357   "RTN","CHM FADR2",415 ,0)
  25358    I PAGENUM 2'="",$D(^ CHMIMAGE(C HMFPDI,1,P AGENUM2,2, 1,10)) D
  25359   "RTN","CHM FADR2",416 ,0)
  25360    .S DATA10 =^CHMIMAGE (CHMFPDI,1 ,PAGENUM2, 2,1,10)
  25361   "RTN","CHM FADR2",417 ,0)
  25362    .S SPONNU M=$P(DATA1 0,"^"),BFN =$P(DATA10 ,"^",2)
  25363   "RTN","CHM FADR2",418 ,0)
  25364    .S CURRBE N=SPONNUM_ "/"_BFN
  25365   "RTN","CHM FADR2",419 ,0)
  25366    I ORIGBEN =CURRBEN Q  1
  25367   "RTN","CHM FADR2",420 ,0)
  25368    Q 0
  25369   "RTN","CHM FADR2",421 ,0)
  25370   LOCK S DY= 15,DX=1 X  XY W !,"    PDI: ",CH MFPDI," is  Currently  Being Pro cessed"
  25371   "RTN","CHM FADR2",422 ,0)
  25372    W !,"   B y Another  User, Plea se Enter a  Different  PDI."
  25373   "RTN","CHM FADR2",423 ,0)
  25374    S CHMFPDI ="",CHMFNM PG="" Q
  25375   "RTN","CHM FADR2",424 ,0)
  25376   IMAGE S VA L="No"
  25377   "RTN","CHM FADR2",425 ,0)
  25378    S:'$D(CHM FPDI) CHMF PDI=""
  25379   "RTN","CHM FADR2",426 ,0)
  25380    I CHMFPDI  I $D(^CHM IMG(CHMFPD I,"DOC"))  D
  25381   "RTN","CHM FADR2",427 ,0)
  25382    .S:$P(^CH MIMG(CHMFP DI,"DOC"), "^",3)'=""  VAL="Yes"
  25383   "RTN","CHM FADR2",428 ,0)
  25384    S DY=10,D X=41 X XY  W VAL
  25385   "RTN","CHM FADR2",429 ,0)
  25386    Q
  25387   "RTN","CHM FADR2",430 ,0)
  25388    ;
  25389   "RTN","CHM FADR2",431 ,0)
  25390   TOB(CHMFPD I,CHMFPGNM ,CHMFIMAG)  ;CPE005-0 04
  25391   "RTN","CHM FADR2",432 ,0)
  25392    ; retriev e Type of  Bill and F requency C ode
  25393   "RTN","CHM FADR2",433 ,0)
  25394    ; input -  
  25395   "RTN","CHM FADR2",434 ,0)
  25396    ; CHMFPDI  - PDI ien
  25397   "RTN","CHM FADR2",435 ,0)
  25398    ; CHMFPGN M - page n umber ien
  25399   "RTN","CHM FADR2",436 ,0)
  25400    ; CHMFIMA G - IMAGE  ien
  25401   "RTN","CHM FADR2",437 ,0)
  25402    ; output  -
  25403   "RTN","CHM FADR2",438 ,0)
  25404    ; returns  the Type  of Bill an d Frequenc y code 
  25405   "RTN","CHM FADR2",439 ,0)
  25406    N CHMFTOB
  25407   "RTN","CHM FADR2",440 ,0)
  25408    I '$D(CHM FPDI)!('$D (CHMFPGNM) )!('$D(CHM FIMAG)) Q  "Frequency  Code not  defined"
  25409   "RTN","CHM FADR2",441 ,0)
  25410    I '$D(^CH MIMAGE(+CH MFPDI,1,+C HMFPGNM,2, +CHMFIMAG, "VEN")) Q  "Frequency  Code not  defined"
  25411   "RTN","CHM FADR2",442 ,0)
  25412    S CHMFTOB =$P($G(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"VE N")),"^",7 )
  25413   "RTN","CHM FADR2",443 ,0)
  25414    I $E(CHMF TOB,3)=5 Q  CHMFTOB_"  Late Char ge Only"
  25415   "RTN","CHM FADR2",444 ,0)
  25416    I $E(CHMF TOB,3)=6 Q  CHMFTOB_"  Adjustmen t of Prior  Claim"
  25417   "RTN","CHM FADR2",445 ,0)
  25418    I $E(CHMF TOB,3)=7 Q  CHMFTOB_"  Replaceme nt of Prio r Claim"
  25419   "RTN","CHM FADR2",446 ,0)
  25420    I $E(CHMF TOB,3)=8 Q  CHMFTOB_"  Void / Ca ncel of Pr ior Claim"
  25421   "RTN","CHM FADR2",447 ,0)
  25422    Q $S(CHMF TOB="":"Fr equency Co de not def ined",1:CH MFTOB_" Fr equency Co de not def ined")
  25423   "RTN","CHM FADR2",448 ,0)
  25424    ;  
  25425   "RTN","CHM FADR2",449 ,0)
  25426   PGCNT Q:'$ D(^CHMIMAG E(CHMFPDI, 0))
  25427   "RTN","CHM FADR2",450 ,0)
  25428    S CHMFNMP G=$P(^CHMI MAGE(CHMFP DI,0),"^", 2)
  25429   "RTN","CHM FADR2",451 ,0)
  25430    Q
  25431   "RTN","CHM FADR2",452 ,0)
  25432    ; 
  25433   "RTN","CHM FADR2",453 ,0)
  25434   TLPGCNT Q: '$D(^CHMIM AGE(CHMFPD I,1))
  25435   "RTN","CHM FADR2",454 ,0)
  25436    S TLPGCT= 9999999,TL PGCT=$O(^C HMIMAGE(CH MFPDI,1,TL PGCT),-1)
  25437   "RTN","CHM FADR2",455 ,0)
  25438    S:TLPGCT= "" TLPGCT= 1 S CHMFNM PG=TLPGCT  K TLPGCT Q
  25439   "RTN","CHM FADR2",456 ,0)
  25440    ;
  25441   "RTN","CHM FADR2",457 ,0)
  25442   PDISTAT(PD I) ;PDI St atus CPE00 5-126 and  127
  25443   "RTN","CHM FADR2",458 ,0)
  25444    Q $P($G(^ CHMIMG(PDI ,0)),"^",6 )
  25445   "RTN","CHM FADR2",459 ,0)
  25446    ;
  25447   "RTN","CHM FADR2",460 ,0)
  25448   LOADIMG ;b db 1/9/201 8 cpe005-1 21 load cu rrent imag e files
  25449   "RTN","CHM FADR2",461 ,0)
  25450    N CPDIZER O,OPDZERO, OPDIWF,CPD ZERO,CPDIW F
  25451   "RTN","CHM FADR2",462 ,0)
  25452    Q:'$D(^CH MIMAGE(CHM FPDI,0))
  25453   "RTN","CHM FADR2",463 ,0)
  25454    S CPDIZER O=^CHMIMAG E(CHMFPDI, 0)
  25455   "RTN","CHM FADR2",464 ,0)
  25456    M ^CHMIMA GE(CHMFPDI )=^CHMIMAG E(CHMOPDI)
  25457   "RTN","CHM FADR2",465 ,0)
  25458    S ^CHMIMA GE(CHMFPDI ,0)=CPDIZE RO
  25459   "RTN","CHM FADR2",466 ,0)
  25460    S X="" S: $D(^CHMIMA GE(CHMFPDI ,0)) X=^(0 )
  25461   "RTN","CHM FADR2",467 ,0)
  25462    S $P(X,"^ ",1)=CHMFP DI,$P(X,"^ ",2)=CHMFN MPG,$P(X," ^",3)=DUZ
  25463   "RTN","CHM FADR2",468 ,0)
  25464    S $P(X,"^ ",4)=CHMFT MBG,PDIFL= 1
  25465   "RTN","CHM FADR2",469 ,0)
  25466    S ^CHMIMA GE(CHMFPDI ,0)=X,^CHM IMAGE("B", CHMFPDI,CH MFPDI)=""
  25467   "RTN","CHM FADR2",470 ,0)
  25468    S OPDZERO =^CHMIMG(C HMOPDI,0)
  25469   "RTN","CHM FADR2",471 ,0)
  25470    S CPDZERO =^CHMIMG(C HMFPDI,0)
  25471   "RTN","CHM FADR2",472 ,0)
  25472    M CPDIWF= ^CHMIMG(CH MFPDI,"WF" )
  25473   "RTN","CHM FADR2",473 ,0)
  25474    M ^CHMIMG (CHMFPDI)= ^CHMIMG(CH MOPDI)
  25475   "RTN","CHM FADR2",474 ,0)
  25476    K ^CHMIMG (CHMFPDI," WF")
  25477   "RTN","CHM FADR2",475 ,0)
  25478    M ^CHMIMG (CHMFPDI," WF")=CPDIW F
  25479   "RTN","CHM FADR2",476 ,0)
  25480    S ^CHMIMG (CHMFPDI,0 )=CPDZERO
  25481   "RTN","CHM FADR2",477 ,0)
  25482    S $P(^CHM IMG(CHMFPD I,0),"^",2 )=$P(OPDZE RO,"^",2)
  25483   "RTN","CHM FADR2",478 ,0)
  25484    S $P(^CHM IMG(CHMFPD I,0),"^",1 )=CHMFPDI, ^CHMIMG("B ",CHMFPDI, CHMFPDI)=" "
  25485   "RTN","CHM FADR2",479 ,0)
  25486    S $P(^CHM IMG(CHMFPD I,0),"^",3 )=DUZ,$P(^ CHMIMG(CHM FPDI,0),"^ ",4)=CHMFT MBG
  25487   "RTN","CHM FADR2",480 ,0)
  25488    Q
  25489   "RTN","CHM FADR2",481 ,0)
  25490    ;
  25491   "RTN","CHM FADR4")
  25492   0^51^B2679 34873
  25493   "RTN","CHM FADR4",1,0 )
  25494   CHMFADR4 ; CVA/JLR;UT ILITY PROG RAM #3 FOR  IP DRIVER ;Feb 06, 2 019@10:21: 07
  25495   "RTN","CHM FADR4",2,0 )
  25496    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  25497   "RTN","CHM FADR4",3,0 )
  25498    ;CFS 08/0 9/2017 CPE 005-004 Pu ll Current  and Orign al PDI Num bers. New  line tags  "OCRR" and  "SBOCRR".
  25499   "RTN","CHM FADR4",4,0 )
  25500    ;CFS 08/0 9/2017 CPE 005-004 Fi x bug with  Undefined  errors on  variable  CHDOCID.
  25501   "RTN","CHM FADR4",5,0 )
  25502    ;CFS 10/0 1/2017 CPE 005-069 Ad d the Manu al EDI Re- open Doc I D Screen.
  25503   "RTN","CHM FADR4",6,0 )
  25504    ;CFS 10/0 1/2017 CPE 005-071 De fault CHMF TYPE to BI LL/INVOICE  for the I mage Type.
  25505   "RTN","CHM FADR4",7,0 )
  25506    ;BDB 12/1 1/2017 CPE 005-033
  25507   "RTN","CHM FADR4",8,0 )
  25508    ;CFS 01/0 7/2017 CPE 005-041 Pa ss in TYPE RUN as var iable in l ine tag CH RJ1.
  25509   "RTN","CHM FADR4",9,0 )
  25510    ;CFS 01/1 9/2018 CPE 005-122 an d 123 Do n ot allow t he Kill of  ^CHMIMAGE  for Manua l ER Reope n.
  25511   "RTN","CHM FADR4",10, 0)
  25512    ;CFS 02/0 8/2018 CPE 005-033 Ca ll the new  CSTAT cre ation rout ine CRCSTA T^CHMFUTLE .
  25513   "RTN","CHM FADR4",11, 0)
  25514   SCAN ;SCAN NED CLAIMS  GO HERE
  25515   "RTN","CHM FADR4",12, 0)
  25516    ;
  25517   "RTN","CHM FADR4",13, 0)
  25518    N CHOSEN
  25519   "RTN","CHM FADR4",14, 0)
  25520    S (PS,FKI L,FIPAY,BA D)=0
  25521   "RTN","CHM FADR4",15, 0)
  25522    S CHMFPDI ="",CHOSEN =1
  25523   "RTN","CHM FADR4",16, 0)
  25524    D LSTPDI^ CHMFADR1
  25525   "RTN","CHM FADR4",17, 0)
  25526    D SETUP^C HMFADR1
  25527   "RTN","CHM FADR4",18, 0)
  25528    G:CHMFPDI '="" S01
  25529   "RTN","CHM FADR4",19, 0)
  25530   S0 D SETUP 1^CHMFADR1
  25531   "RTN","CHM FADR4",20, 0)
  25532    D ^CHMFPD I Q:$D(CHQ UIT)
  25533   "RTN","CHM FADR4",21, 0)
  25534   S01 S ZZPD I=CHMFPDI
  25535   "RTN","CHM FADR4",22, 0)
  25536    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  25537   "RTN","CHM FADR4",23, 0)
  25538    S CHMFPP= "SIP" D ^C HMFWK01
  25539   "RTN","CHM FADR4",24, 0)
  25540    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=1
  25541   "RTN","CHM FADR4",25, 0)
  25542    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  25543   "RTN","CHM FADR4",26, 0)
  25544   S1 D ^CHMF A001
  25545   "RTN","CHM FADR4",27, 0)
  25546    I $D(CHYE SFLG) D  G  S0
  25547   "RTN","CHM FADR4",28, 0)
  25548    .D KLOCK^ CHMFADR1
  25549   "RTN","CHM FADR4",29, 0)
  25550    .D REMV^C HMFADR1
  25551   "RTN","CHM FADR4",30, 0)
  25552    .D DELST1 ^CHMFADR1
  25553   "RTN","CHM FADR4",31, 0)
  25554    .D KILALL ^CHMFADR1
  25555   "RTN","CHM FADR4",32, 0)
  25556    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041  Q
  25557   "RTN","CHM FADR4",33, 0)
  25558    I $D(CHMF BAD) D  G  S0
  25559   "RTN","CHM FADR4",34, 0)
  25560    .D KLOCK^ CHMFADR1
  25561   "RTN","CHM FADR4",35, 0)
  25562    .D REMV^C HMFADR1
  25563   "RTN","CHM FADR4",36, 0)
  25564    .D DELST1 ^CHMFADR1
  25565   "RTN","CHM FADR4",37, 0)
  25566    .D KILALL ^CHMFADR1
  25567   "RTN","CHM FADR4",38, 0)
  25568    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  25569   "RTN","CHM FADR4",39, 0)
  25570    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  25571   "RTN","CHM FADR4",40, 0)
  25572    I $D(CHMF PS) D  G S 0
  25573   "RTN","CHM FADR4",41, 0)
  25574    .S PS=1,C HMFI=CHMFP DI,CHMFPP= "SSPS"
  25575   "RTN","CHM FADR4",42, 0)
  25576    .D ^CHMFW K01
  25577   "RTN","CHM FADR4",43, 0)
  25578    .D SETPRO D^CHMFADR1
  25579   "RTN","CHM FADR4",44, 0)
  25580    .D PSMSG^ CHMFADR1
  25581   "RTN","CHM FADR4",45, 0)
  25582    .D KLOCK^ CHMFADR1
  25583   "RTN","CHM FADR4",46, 0)
  25584    .D REMV^C HMFADR1
  25585   "RTN","CHM FADR4",47, 0)
  25586    .D DELST1 ^CHMFADR1
  25587   "RTN","CHM FADR4",48, 0)
  25588    .D KILALL ^CHMFADR1
  25589   "RTN","CHM FADR4",49, 0)
  25590    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  25591   "RTN","CHM FADR4",50, 0)
  25592    .S CHMQNA M="CHMPSQ( ",CHMIN=1  K CHMOUT D  ^CHMIS041  Q
  25593   "RTN","CHM FADR4",51, 0)
  25594    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  25595   "RTN","CHM FADR4",52, 0)
  25596    I $D(CHMF KIL) D  Q
  25597   "RTN","CHM FADR4",53, 0)
  25598    .S FKIL=1
  25599   "RTN","CHM FADR4",54, 0)
  25600    .D SETPRO D^CHMFADR1
  25601   "RTN","CHM FADR4",55, 0)
  25602    .D KLOCK^ CHMFADR1
  25603   "RTN","CHM FADR4",56, 0)
  25604    .D KILPDI ^CHMFADR1
  25605   "RTN","CHM FADR4",57, 0)
  25606    .D DELST1 ^CHMFADR1
  25607   "RTN","CHM FADR4",58, 0)
  25608    .D READY^ CHMFADR1
  25609   "RTN","CHM FADR4",59, 0)
  25610    I $D(DUOU T) D  Q
  25611   "RTN","CHM FADR4",60, 0)
  25612    .D KLOCK^ CHMFADR1
  25613   "RTN","CHM FADR4",61, 0)
  25614    .D READY^ CHMFADR1
  25615   "RTN","CHM FADR4",62, 0)
  25616    .D DELST1 ^CHMFADR1
  25617   "RTN","CHM FADR4",63, 0)
  25618    .D REMV^C HMFADR1
  25619   "RTN","CHM FADR4",64, 0)
  25620    I $D(DFOU T) D  Q
  25621   "RTN","CHM FADR4",65, 0)
  25622    .D KLOCK^ CHMFADR1
  25623   "RTN","CHM FADR4",66, 0)
  25624    .D READY^ CHMFADR1
  25625   "RTN","CHM FADR4",67, 0)
  25626    .D DELST1 ^CHMFADR1
  25627   "RTN","CHM FADR4",68, 0)
  25628    .D REMV^C HMFADR1
  25629   "RTN","CHM FADR4",69, 0)
  25630    Q
  25631   "RTN","CHM FADR4",70, 0)
  25632   MANUAL ;Ma nually pro cessed cla ims start  here.
  25633   "RTN","CHM FADR4",71, 0)
  25634    ; Set var iables to  0 or nil
  25635   "RTN","CHM FADR4",72, 0)
  25636    N CHOSEN
  25637   "RTN","CHM FADR4",73, 0)
  25638    S (CHOSEN ,PS,FKIL,F IPAY,BAD)= 0
  25639   "RTN","CHM FADR4",74, 0)
  25640    S CHMFPDI =""
  25641   "RTN","CHM FADR4",75, 0)
  25642    ; LSTPDI^ CHMFADR1 l ooks for P DI's curre ntly in "P ause" stat us.
  25643   "RTN","CHM FADR4",76, 0)
  25644    D LSTPDI^ CHMFADR1
  25645   "RTN","CHM FADR4",77, 0)
  25646    D SETUP^C HMFADR1
  25647   "RTN","CHM FADR4",78, 0)
  25648    G:CHMFPDI '="" M1
  25649   "RTN","CHM FADR4",79, 0)
  25650   M0 D SETUP 1^CHMFADR1
  25651   "RTN","CHM FADR4",80, 0)
  25652   M1 D ^CHMF A001
  25653   "RTN","CHM FADR4",81, 0)
  25654    I $D(CHYE SFLG) D  G  M0
  25655   "RTN","CHM FADR4",82, 0)
  25656    .D KLOCK^ CHMFADR1
  25657   "RTN","CHM FADR4",83, 0)
  25658    .D REMV^C HMFADR1
  25659   "RTN","CHM FADR4",84, 0)
  25660    .D DELST1 ^CHMFADR1
  25661   "RTN","CHM FADR4",85, 0)
  25662    .D KILALL ^CHMFADR1
  25663   "RTN","CHM FADR4",86, 0)
  25664    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041  Q
  25665   "RTN","CHM FADR4",87, 0)
  25666    I $D(CHMF BAD) D  G  M0
  25667   "RTN","CHM FADR4",88, 0)
  25668    .D KLOCK^ CHMFADR1
  25669   "RTN","CHM FADR4",89, 0)
  25670    .D REMV^C HMFADR1
  25671   "RTN","CHM FADR4",90, 0)
  25672    .D DELST1 ^CHMFADR1
  25673   "RTN","CHM FADR4",91, 0)
  25674    .D KILALL ^CHMFADR1
  25675   "RTN","CHM FADR4",92, 0)
  25676    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041
  25677   "RTN","CHM FADR4",93, 0)
  25678    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  25679   "RTN","CHM FADR4",94, 0)
  25680    I $D(CHMF PS) D  G M 0
  25681   "RTN","CHM FADR4",95, 0)
  25682    .S PS=1,C HMFI=CHMFP DI,CHMFPP= "SSPS"
  25683   "RTN","CHM FADR4",96, 0)
  25684    .D ^CHMFW K01
  25685   "RTN","CHM FADR4",97, 0)
  25686    .D SETPRO D^CHMFADR1
  25687   "RTN","CHM FADR4",98, 0)
  25688    .D PSMSG^ CHMFADR1
  25689   "RTN","CHM FADR4",99, 0)
  25690    .D KLOCK^ CHMFADR1
  25691   "RTN","CHM FADR4",100 ,0)
  25692    .D REMV^C HMFADR1
  25693   "RTN","CHM FADR4",101 ,0)
  25694    .D DELST1 ^CHMFADR1
  25695   "RTN","CHM FADR4",102 ,0)
  25696    .D KILALL ^CHMFADR1
  25697   "RTN","CHM FADR4",103 ,0)
  25698    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041
  25699   "RTN","CHM FADR4",104 ,0)
  25700    .S CHMQNA M="CHMPSQ( ",CHMIN=1  K CHMOUT D  ^CHMIS041  Q
  25701   "RTN","CHM FADR4",105 ,0)
  25702    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  25703   "RTN","CHM FADR4",106 ,0)
  25704    I $D(CHMF KIL) D  Q
  25705   "RTN","CHM FADR4",107 ,0)
  25706    .S FKIL=1
  25707   "RTN","CHM FADR4",108 ,0)
  25708    .D SETPRO D^CHMFADR1
  25709   "RTN","CHM FADR4",109 ,0)
  25710    .D KLOCK^ CHMFADR1
  25711   "RTN","CHM FADR4",110 ,0)
  25712    .D KILPDI ^CHMFADR1
  25713   "RTN","CHM FADR4",111 ,0)
  25714    .D DELST1 ^CHMFADR1
  25715   "RTN","CHM FADR4",112 ,0)
  25716    .D MANL^C HMFADR1
  25717   "RTN","CHM FADR4",113 ,0)
  25718    .D SKIP^C HMFADR1
  25719   "RTN","CHM FADR4",114 ,0)
  25720    I $D(DUOU T) D  Q
  25721   "RTN","CHM FADR4",115 ,0)
  25722    .D KLOCK^ CHMFADR1
  25723   "RTN","CHM FADR4",116 ,0)
  25724    .D MANL^C HMFADR1
  25725   "RTN","CHM FADR4",117 ,0)
  25726    .D DELST1 ^CHMFADR1
  25727   "RTN","CHM FADR4",118 ,0)
  25728    .D REMV^C HMFADR1
  25729   "RTN","CHM FADR4",119 ,0)
  25730    I $D(DFOU T) D  Q
  25731   "RTN","CHM FADR4",120 ,0)
  25732    .D KLOCK^ CHMFADR1
  25733   "RTN","CHM FADR4",121 ,0)
  25734    .D MANL^C HMFADR1
  25735   "RTN","CHM FADR4",122 ,0)
  25736    .D DELST1 ^CHMFADR1
  25737   "RTN","CHM FADR4",123 ,0)
  25738    .D REMV^C HMFADR1
  25739   "RTN","CHM FADR4",124 ,0)
  25740    Q
  25741   "RTN","CHM FADR4",125 ,0)
  25742    ;
  25743   "RTN","CHM FADR4",126 ,0)
  25744   OCR ;CHAMP VA EDI cla ims start  here.
  25745   "RTN","CHM FADR4",127 ,0)
  25746    ;
  25747   "RTN","CHM FADR4",128 ,0)
  25748    N CHOSEN
  25749   "RTN","CHM FADR4",129 ,0)
  25750    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  25751   "RTN","CHM FADR4",130 ,0)
  25752    S CHMFPDI ="",CHOSEN =2
  25753   "RTN","CHM FADR4",131 ,0)
  25754    D LSTPDI^ CHMFADR1
  25755   "RTN","CHM FADR4",132 ,0)
  25756    D SETUP^C HMFADR1
  25757   "RTN","CHM FADR4",133 ,0)
  25758    G:CHMFPDI '="" O01
  25759   "RTN","CHM FADR4",134 ,0)
  25760   O0 D SETUP 1^CHMFADR1
  25761   "RTN","CHM FADR4",135 ,0)
  25762    D ^CHMFPD IO Q:$D(CH QUIT)
  25763   "RTN","CHM FADR4",136 ,0)
  25764   O01 S ZZPD I=CHMFPDI
  25765   "RTN","CHM FADR4",137 ,0)
  25766    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  25767   "RTN","CHM FADR4",138 ,0)
  25768    S CHMFPP= "SIP" D ^C HMFWK01
  25769   "RTN","CHM FADR4",139 ,0)
  25770    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  25771   "RTN","CHM FADR4",140 ,0)
  25772    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  25773   "RTN","CHM FADR4",141 ,0)
  25774    D GETDATA ^CHMFA008
  25775   "RTN","CHM FADR4",142 ,0)
  25776   O1 D ^CHMF A008
  25777   "RTN","CHM FADR4",143 ,0)
  25778    ;I $D(CHY ESFLG) D   G O0
  25779   "RTN","CHM FADR4",144 ,0)
  25780    ;.;D KLOC K^CHMFADR1
  25781   "RTN","CHM FADR4",145 ,0)
  25782    ;.;D REMV ^CHMFADR1
  25783   "RTN","CHM FADR4",146 ,0)
  25784    ;.;D DELS T1^CHMFADR 1
  25785   "RTN","CHM FADR4",147 ,0)
  25786    ;.;D KILA LL^CHMFADR 1
  25787   "RTN","CHM FADR4",148 ,0)
  25788    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1 Q
  25789   "RTN","CHM FADR4",149 ,0)
  25790    I $D(CHMF BAD) D  G  O0
  25791   "RTN","CHM FADR4",150 ,0)
  25792    .D KLOCK^ CHMFADR1
  25793   "RTN","CHM FADR4",151 ,0)
  25794    .D REMV^C HMFADR1
  25795   "RTN","CHM FADR4",152 ,0)
  25796    .D DELST1 ^CHMFADR1
  25797   "RTN","CHM FADR4",153 ,0)
  25798    .D KILALL ^CHMFADR1
  25799   "RTN","CHM FADR4",154 ,0)
  25800    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  25801   "RTN","CHM FADR4",155 ,0)
  25802    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  25803   "RTN","CHM FADR4",156 ,0)
  25804    ;I $D(CHM FPS) D  G  O0
  25805   "RTN","CHM FADR4",157 ,0)
  25806    ;.;S PS=1 ,CHMFI=CHM FPDI,CHMFP P="SSPS"
  25807   "RTN","CHM FADR4",158 ,0)
  25808    ;.;D ^CHM FWK01
  25809   "RTN","CHM FADR4",159 ,0)
  25810    ;.;D SETP ROD^CHMFAD R1
  25811   "RTN","CHM FADR4",160 ,0)
  25812    ;.;D PSMS G^CHMFADR1
  25813   "RTN","CHM FADR4",161 ,0)
  25814    ;.;D KLOC K^CHMFADR1
  25815   "RTN","CHM FADR4",162 ,0)
  25816    ;.;D REMV ^CHMFADR1
  25817   "RTN","CHM FADR4",163 ,0)
  25818    ;.;D DELS T1^CHMFADR 1
  25819   "RTN","CHM FADR4",164 ,0)
  25820    ;.;D KILA LL^CHMFADR 1
  25821   "RTN","CHM FADR4",165 ,0)
  25822    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1
  25823   "RTN","CHM FADR4",166 ,0)
  25824    ;.;S CHMQ NAM="CHMPS Q(",CHMIN= 1 K CHMOUT  D ^CHMIS0 41 Q
  25825   "RTN","CHM FADR4",167 ,0)
  25826    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  25827   "RTN","CHM FADR4",168 ,0)
  25828    ;I $D(CHM FEXIT) D   Q
  25829   "RTN","CHM FADR4",169 ,0)
  25830    ;.;S FKIL =1
  25831   "RTN","CHM FADR4",170 ,0)
  25832    ;.;D SETP ROD^CHMFAD R1
  25833   "RTN","CHM FADR4",171 ,0)
  25834    ;.;D KLOC K^CHMFADR1
  25835   "RTN","CHM FADR4",172 ,0)
  25836    ;.;D DELS T1^CHMFADR 1
  25837   "RTN","CHM FADR4",173 ,0)
  25838    ;.;D OCRR DY^CHMFADR 1
  25839   "RTN","CHM FADR4",174 ,0)
  25840    I $D(CHMF KIL) D  Q
  25841   "RTN","CHM FADR4",175 ,0)
  25842    .S FKIL=1
  25843   "RTN","CHM FADR4",176 ,0)
  25844    .D SETPRO D^CHMFADR1
  25845   "RTN","CHM FADR4",177 ,0)
  25846    .D KLOCK^ CHMFADR1
  25847   "RTN","CHM FADR4",178 ,0)
  25848    .D DELST1 ^CHMFADR1
  25849   "RTN","CHM FADR4",179 ,0)
  25850    .D OCRRDY ^CHMFADR1
  25851   "RTN","CHM FADR4",180 ,0)
  25852    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  25853   "RTN","CHM FADR4",181 ,0)
  25854    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  25855   "RTN","CHM FADR4",182 ,0)
  25856    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  25857   "RTN","CHM FADR4",183 ,0)
  25858    I $D(CHMF PDRV) D  G  O0
  25859   "RTN","CHM FADR4",184 ,0)
  25860    .D KLOCK^ CHMFADR1
  25861   "RTN","CHM FADR4",185 ,0)
  25862    .D REMV^C HMFADR1
  25863   "RTN","CHM FADR4",186 ,0)
  25864    .D DELST1 ^CHMFADR1
  25865   "RTN","CHM FADR4",187 ,0)
  25866    .D OCRKIL ^CHMFADR1
  25867   "RTN","CHM FADR4",188 ,0)
  25868    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  25869   "RTN","CHM FADR4",189 ,0)
  25870    I $D(DUOU T) D  Q
  25871   "RTN","CHM FADR4",190 ,0)
  25872    .D KLOCK^ CHMFADR1
  25873   "RTN","CHM FADR4",191 ,0)
  25874    .D OCRRDY ^CHMFADR1
  25875   "RTN","CHM FADR4",192 ,0)
  25876    .D DELST1 ^CHMFADR1
  25877   "RTN","CHM FADR4",193 ,0)
  25878    .D REMV^C HMFADR1
  25879   "RTN","CHM FADR4",194 ,0)
  25880    I $D(DFOU T) D  Q
  25881   "RTN","CHM FADR4",195 ,0)
  25882    .D KLOCK^ CHMFADR1
  25883   "RTN","CHM FADR4",196 ,0)
  25884    .D OCRRDY ^CHMFADR1
  25885   "RTN","CHM FADR4",197 ,0)
  25886    .D DELST1 ^CHMFADR1
  25887   "RTN","CHM FADR4",198 ,0)
  25888    .D REMV^C HMFADR1
  25889   "RTN","CHM FADR4",199 ,0)
  25890    Q
  25891   "RTN","CHM FADR4",200 ,0)
  25892   OCR2 ;CHAM PVA OCR cl aims start  here.
  25893   "RTN","CHM FADR4",201 ,0)
  25894    ;
  25895   "RTN","CHM FADR4",202 ,0)
  25896    N CHOSEN
  25897   "RTN","CHM FADR4",203 ,0)
  25898    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  25899   "RTN","CHM FADR4",204 ,0)
  25900    S CHMFPDI ="",CHOSEN =4
  25901   "RTN","CHM FADR4",205 ,0)
  25902    ;S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",2)=" "
  25903   "RTN","CHM FADR4",206 ,0)
  25904    D LSTPDI^ CHMFADR1
  25905   "RTN","CHM FADR4",207 ,0)
  25906    D SETUP^C HMFADR1
  25907   "RTN","CHM FADR4",208 ,0)
  25908    G:CHMFPDI '="" OCR20 1
  25909   "RTN","CHM FADR4",209 ,0)
  25910   OCR20 D SE TUP1^CHMFA DR1
  25911   "RTN","CHM FADR4",210 ,0)
  25912    D ^CHMFPD O1 Q:$D(CH QUIT)
  25913   "RTN","CHM FADR4",211 ,0)
  25914   OCR201 S Z ZPDI=CHMFP DI
  25915   "RTN","CHM FADR4",212 ,0)
  25916    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  25917   "RTN","CHM FADR4",213 ,0)
  25918    S CHMFPP= "SIP" D ^C HMFWK01
  25919   "RTN","CHM FADR4",214 ,0)
  25920    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  25921   "RTN","CHM FADR4",215 ,0)
  25922    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  25923   "RTN","CHM FADR4",216 ,0)
  25924    D GETDATA ^CHMFA008
  25925   "RTN","CHM FADR4",217 ,0)
  25926   OCR21 D ^C HMFA008
  25927   "RTN","CHM FADR4",218 ,0)
  25928    ;I $D(CHY ESFLG) D   G OCR20
  25929   "RTN","CHM FADR4",219 ,0)
  25930    ;.;D KLOC K^CHMFADR1
  25931   "RTN","CHM FADR4",220 ,0)
  25932    ;.;D REMV ^CHMFADR1
  25933   "RTN","CHM FADR4",221 ,0)
  25934    ;.;D DELS T1^CHMFADR 1
  25935   "RTN","CHM FADR4",222 ,0)
  25936    ;.;D KILA LL^CHMFADR 1
  25937   "RTN","CHM FADR4",223 ,0)
  25938    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1 Q
  25939   "RTN","CHM FADR4",224 ,0)
  25940    I $D(CHMF BAD) D  G  OCR20
  25941   "RTN","CHM FADR4",225 ,0)
  25942    .D KLOCK^ CHMFADR1
  25943   "RTN","CHM FADR4",226 ,0)
  25944    .D REMV^C HMFADR1
  25945   "RTN","CHM FADR4",227 ,0)
  25946    .D DELST1 ^CHMFADR1
  25947   "RTN","CHM FADR4",228 ,0)
  25948    .D KILALL ^CHMFADR1
  25949   "RTN","CHM FADR4",229 ,0)
  25950    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  25951   "RTN","CHM FADR4",230 ,0)
  25952    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  25953   "RTN","CHM FADR4",231 ,0)
  25954    ;I $D(CHM FPS) D  G  OCR20
  25955   "RTN","CHM FADR4",232 ,0)
  25956    ;.;S PS=1 ,CHMFI=CHM FPDI,CHMFP P="SSPS"
  25957   "RTN","CHM FADR4",233 ,0)
  25958    ;.;D ^CHM FWK01
  25959   "RTN","CHM FADR4",234 ,0)
  25960    ;.;D SETP ROD^CHMFAD R1
  25961   "RTN","CHM FADR4",235 ,0)
  25962    ;.;D PSMS G^CHMFADR1
  25963   "RTN","CHM FADR4",236 ,0)
  25964    ;.;D KLOC K^CHMFADR1
  25965   "RTN","CHM FADR4",237 ,0)
  25966    ;.;D REMV ^CHMFADR1
  25967   "RTN","CHM FADR4",238 ,0)
  25968    ;.;D DELS T1^CHMFADR 1
  25969   "RTN","CHM FADR4",239 ,0)
  25970    ;.;D KILA LL^CHMFADR 1
  25971   "RTN","CHM FADR4",240 ,0)
  25972    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1
  25973   "RTN","CHM FADR4",241 ,0)
  25974    ;.;S CHMQ NAM="CHMPS Q(",CHMIN= 1 K CHMOUT  D ^CHMIS0 41 Q
  25975   "RTN","CHM FADR4",242 ,0)
  25976    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  25977   "RTN","CHM FADR4",243 ,0)
  25978    ;I $D(CHM FEXIT) D   Q
  25979   "RTN","CHM FADR4",244 ,0)
  25980    ;.;S FKIL =1
  25981   "RTN","CHM FADR4",245 ,0)
  25982    ;.;D SETP ROD^CHMFAD R1
  25983   "RTN","CHM FADR4",246 ,0)
  25984    ;.;D KLOC K^CHMFADR1
  25985   "RTN","CHM FADR4",247 ,0)
  25986    ;.;D DELS T1^CHMFADR 1
  25987   "RTN","CHM FADR4",248 ,0)
  25988    ;.;D OCR2 RDY^CHMFAD R1
  25989   "RTN","CHM FADR4",249 ,0)
  25990    I $D(CHMF KIL) D  Q
  25991   "RTN","CHM FADR4",250 ,0)
  25992    .S FKIL=1
  25993   "RTN","CHM FADR4",251 ,0)
  25994    .D SETPRO D^CHMFADR1
  25995   "RTN","CHM FADR4",252 ,0)
  25996    .D KLOCK^ CHMFADR1
  25997   "RTN","CHM FADR4",253 ,0)
  25998    .D DELST1 ^CHMFADR1
  25999   "RTN","CHM FADR4",254 ,0)
  26000    .D OCR2RD Y^CHMFADR1
  26001   "RTN","CHM FADR4",255 ,0)
  26002    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  26003   "RTN","CHM FADR4",256 ,0)
  26004    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  26005   "RTN","CHM FADR4",257 ,0)
  26006    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  26007   "RTN","CHM FADR4",258 ,0)
  26008    I $D(CHMF PDRV) D  G  OCR20
  26009   "RTN","CHM FADR4",259 ,0)
  26010    .D KLOCK^ CHMFADR1
  26011   "RTN","CHM FADR4",260 ,0)
  26012    .D REMV^C HMFADR1
  26013   "RTN","CHM FADR4",261 ,0)
  26014    .D DELST1 ^CHMFADR1
  26015   "RTN","CHM FADR4",262 ,0)
  26016    .D OCRKIL ^CHMFADR1
  26017   "RTN","CHM FADR4",263 ,0)
  26018    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  26019   "RTN","CHM FADR4",264 ,0)
  26020    I $D(DUOU T) D  Q
  26021   "RTN","CHM FADR4",265 ,0)
  26022    .D KLOCK^ CHMFADR1
  26023   "RTN","CHM FADR4",266 ,0)
  26024    .D OCR2RD Y^CHMFADR1
  26025   "RTN","CHM FADR4",267 ,0)
  26026    .D DELST1 ^CHMFADR1
  26027   "RTN","CHM FADR4",268 ,0)
  26028    .D REMV^C HMFADR1
  26029   "RTN","CHM FADR4",269 ,0)
  26030    I $D(DFOU T) D  Q
  26031   "RTN","CHM FADR4",270 ,0)
  26032    .D KLOCK^ CHMFADR1
  26033   "RTN","CHM FADR4",271 ,0)
  26034    .D OCR2RD Y^CHMFADR1
  26035   "RTN","CHM FADR4",272 ,0)
  26036    .D DELST1 ^CHMFADR1
  26037   "RTN","CHM FADR4",273 ,0)
  26038    .D REMV^C HMFADR1
  26039   "RTN","CHM FADR4",274 ,0)
  26040    Q
  26041   "RTN","CHM FADR4",275 ,0)
  26042   SBOCR ;SB/ CWVV EDI c laims star t here.
  26043   "RTN","CHM FADR4",276 ,0)
  26044    ;
  26045   "RTN","CHM FADR4",277 ,0)
  26046    N CHOSEN
  26047   "RTN","CHM FADR4",278 ,0)
  26048    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  26049   "RTN","CHM FADR4",279 ,0)
  26050    S CHMFPDI ="",CHOSEN =3
  26051   "RTN","CHM FADR4",280 ,0)
  26052    D LSTPDI^ CHMFADR1
  26053   "RTN","CHM FADR4",281 ,0)
  26054    D SETUP^C HMFADR1
  26055   "RTN","CHM FADR4",282 ,0)
  26056    G:CHMFPDI '="" SO01
  26057   "RTN","CHM FADR4",283 ,0)
  26058   SO0 D SETU P1^CHMFADR 1
  26059   "RTN","CHM FADR4",284 ,0)
  26060    D ^CHMFPD IS Q:$D(CH QUIT)
  26061   "RTN","CHM FADR4",285 ,0)
  26062   SO01 S ZZP DI=CHMFPDI
  26063   "RTN","CHM FADR4",286 ,0)
  26064    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  26065   "RTN","CHM FADR4",287 ,0)
  26066    S CHMFPP= "SIP" D ^C HMFWK01
  26067   "RTN","CHM FADR4",288 ,0)
  26068    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  26069   "RTN","CHM FADR4",289 ,0)
  26070    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  26071   "RTN","CHM FADR4",290 ,0)
  26072    D GETDATA ^CHMFA008
  26073   "RTN","CHM FADR4",291 ,0)
  26074   SO1 D ^CHM FA008
  26075   "RTN","CHM FADR4",292 ,0)
  26076    ;I $D(CHY ESFLG) D   G SO0
  26077   "RTN","CHM FADR4",293 ,0)
  26078    ;.;D KLOC K^CHMFADR1
  26079   "RTN","CHM FADR4",294 ,0)
  26080    ;.;D REMV ^CHMFADR1
  26081   "RTN","CHM FADR4",295 ,0)
  26082    ;.;D DELS T1^CHMFADR 1
  26083   "RTN","CHM FADR4",296 ,0)
  26084    ;.;D KILA LL^CHMFADR 1
  26085   "RTN","CHM FADR4",297 ,0)
  26086    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1 Q
  26087   "RTN","CHM FADR4",298 ,0)
  26088    I $D(CHMF BAD) D  G  SO0
  26089   "RTN","CHM FADR4",299 ,0)
  26090    .D KLOCK^ CHMFADR1
  26091   "RTN","CHM FADR4",300 ,0)
  26092    .D REMV^C HMFADR1
  26093   "RTN","CHM FADR4",301 ,0)
  26094    .D DELST1 ^CHMFADR1
  26095   "RTN","CHM FADR4",302 ,0)
  26096    .D KILALL ^CHMFADR1
  26097   "RTN","CHM FADR4",303 ,0)
  26098    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  26099   "RTN","CHM FADR4",304 ,0)
  26100    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  26101   "RTN","CHM FADR4",305 ,0)
  26102    ;I $D(CHM FPS) D  G  SO0
  26103   "RTN","CHM FADR4",306 ,0)
  26104    ;.S PS=1, CHMFI=CHMF PDI,CHMFPP ="SSPS"
  26105   "RTN","CHM FADR4",307 ,0)
  26106    ;.;D ^CHM FWK01
  26107   "RTN","CHM FADR4",308 ,0)
  26108    ;.;D SETP ROD^CHMFAD R1
  26109   "RTN","CHM FADR4",309 ,0)
  26110    ;.;D PSMS G^CHMFADR1
  26111   "RTN","CHM FADR4",310 ,0)
  26112    ;.;D KLOC K^CHMFADR1
  26113   "RTN","CHM FADR4",311 ,0)
  26114    ;.;D REMV ^CHMFADR1
  26115   "RTN","CHM FADR4",312 ,0)
  26116    ;.;D DELS T1^CHMFADR 1
  26117   "RTN","CHM FADR4",313 ,0)
  26118    ;.;D KILA LL^CHMFADR 1
  26119   "RTN","CHM FADR4",314 ,0)
  26120    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1
  26121   "RTN","CHM FADR4",315 ,0)
  26122    ;.;S CHMQ NAM="CHMPS Q(",CHMIN= 1 K CHMOUT  D ^CHMIS0 41 Q
  26123   "RTN","CHM FADR4",316 ,0)
  26124    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  26125   "RTN","CHM FADR4",317 ,0)
  26126    ;I $D(CHM FEXIT) D   Q
  26127   "RTN","CHM FADR4",318 ,0)
  26128    ;.;S FKIL =1
  26129   "RTN","CHM FADR4",319 ,0)
  26130    ;.;D SETP ROD^CHMFAD R1
  26131   "RTN","CHM FADR4",320 ,0)
  26132    ;.;D KLOC K^CHMFADR1
  26133   "RTN","CHM FADR4",321 ,0)
  26134    ;.;D DELS T1^CHMFADR 1
  26135   "RTN","CHM FADR4",322 ,0)
  26136    ;.;D SBOC RDY^CHMFAD R1
  26137   "RTN","CHM FADR4",323 ,0)
  26138    I $D(CHMF KIL) D  Q
  26139   "RTN","CHM FADR4",324 ,0)
  26140    .S FKIL=1
  26141   "RTN","CHM FADR4",325 ,0)
  26142    .D SETPRO D^CHMFADR1
  26143   "RTN","CHM FADR4",326 ,0)
  26144    .D KLOCK^ CHMFADR1
  26145   "RTN","CHM FADR4",327 ,0)
  26146    .D DELST1 ^CHMFADR1
  26147   "RTN","CHM FADR4",328 ,0)
  26148    .D SBOCRD Y^CHMFADR1
  26149   "RTN","CHM FADR4",329 ,0)
  26150    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  26151   "RTN","CHM FADR4",330 ,0)
  26152    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  26153   "RTN","CHM FADR4",331 ,0)
  26154    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  26155   "RTN","CHM FADR4",332 ,0)
  26156    I $D(CHMF PDRV) D  G  SO0
  26157   "RTN","CHM FADR4",333 ,0)
  26158    .D KLOCK^ CHMFADR1
  26159   "RTN","CHM FADR4",334 ,0)
  26160    .D REMV^C HMFADR1
  26161   "RTN","CHM FADR4",335 ,0)
  26162    .D DELST1 ^CHMFADR1
  26163   "RTN","CHM FADR4",336 ,0)
  26164    .D OCRKIL ^CHMFADR1
  26165   "RTN","CHM FADR4",337 ,0)
  26166    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  26167   "RTN","CHM FADR4",338 ,0)
  26168    I $D(DUOU T) D  Q
  26169   "RTN","CHM FADR4",339 ,0)
  26170    .D KLOCK^ CHMFADR1
  26171   "RTN","CHM FADR4",340 ,0)
  26172    .D SBOCRD Y^CHMFADR1
  26173   "RTN","CHM FADR4",341 ,0)
  26174    .D DELST1 ^CHMFADR1
  26175   "RTN","CHM FADR4",342 ,0)
  26176    .D REMV^C HMFADR1
  26177   "RTN","CHM FADR4",343 ,0)
  26178    I $D(DFOU T) D  Q
  26179   "RTN","CHM FADR4",344 ,0)
  26180    .D KLOCK^ CHMFADR1
  26181   "RTN","CHM FADR4",345 ,0)
  26182    .D SBOCRD Y^CHMFADR1
  26183   "RTN","CHM FADR4",346 ,0)
  26184    .D DELST1 ^CHMFADR1
  26185   "RTN","CHM FADR4",347 ,0)
  26186    .D REMV^C HMFADR1
  26187   "RTN","CHM FADR4",348 ,0)
  26188    Q
  26189   "RTN","CHM FADR4",349 ,0)
  26190   SBOCR2 ;SB /CWVV OCR  claims sta rt here
  26191   "RTN","CHM FADR4",350 ,0)
  26192    ;
  26193   "RTN","CHM FADR4",351 ,0)
  26194    N CHOSEN
  26195   "RTN","CHM FADR4",352 ,0)
  26196    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  26197   "RTN","CHM FADR4",353 ,0)
  26198    S CHMFPDI ="",CHOSEN =5
  26199   "RTN","CHM FADR4",354 ,0)
  26200    D LSTPDI^ CHMFADR1
  26201   "RTN","CHM FADR4",355 ,0)
  26202    D SETUP^C HMFADR1
  26203   "RTN","CHM FADR4",356 ,0)
  26204    G:CHMFPDI '="" SOCR2 01
  26205   "RTN","CHM FADR4",357 ,0)
  26206   SOCR20 D S ETUP1^CHMF ADR1
  26207   "RTN","CHM FADR4",358 ,0)
  26208    D ^CHMFPD O2 Q:$D(CH QUIT)
  26209   "RTN","CHM FADR4",359 ,0)
  26210   SOCR201 S  ZZPDI=CHMF PDI
  26211   "RTN","CHM FADR4",360 ,0)
  26212    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  26213   "RTN","CHM FADR4",361 ,0)
  26214    S CHMFPP= "SIP" D ^C HMFWK01
  26215   "RTN","CHM FADR4",362 ,0)
  26216    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  26217   "RTN","CHM FADR4",363 ,0)
  26218    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  26219   "RTN","CHM FADR4",364 ,0)
  26220    D GETDATA ^CHMFA008
  26221   "RTN","CHM FADR4",365 ,0)
  26222   SOCR21 D ^ CHMFA008
  26223   "RTN","CHM FADR4",366 ,0)
  26224    ;I $D(CHY ESFLG) D   G SOCR20
  26225   "RTN","CHM FADR4",367 ,0)
  26226    ;.;D KLOC K^CHMFADR1
  26227   "RTN","CHM FADR4",368 ,0)
  26228    ;.;D REMV ^CHMFADR1
  26229   "RTN","CHM FADR4",369 ,0)
  26230    ;.;D DELS T1^CHMFADR 1
  26231   "RTN","CHM FADR4",370 ,0)
  26232    ;.;D KILA LL^CHMFADR 1
  26233   "RTN","CHM FADR4",371 ,0)
  26234    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1 Q
  26235   "RTN","CHM FADR4",372 ,0)
  26236    I $D(CHMF BAD) D  G  SOCR20
  26237   "RTN","CHM FADR4",373 ,0)
  26238    .D KLOCK^ CHMFADR1
  26239   "RTN","CHM FADR4",374 ,0)
  26240    .D REMV^C HMFADR1
  26241   "RTN","CHM FADR4",375 ,0)
  26242    .D DELST1 ^CHMFADR1
  26243   "RTN","CHM FADR4",376 ,0)
  26244    .D KILALL ^CHMFADR1
  26245   "RTN","CHM FADR4",377 ,0)
  26246    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  26247   "RTN","CHM FADR4",378 ,0)
  26248    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  26249   "RTN","CHM FADR4",379 ,0)
  26250    ;I $D(CHM FPS) D  G  SOCR20
  26251   "RTN","CHM FADR4",380 ,0)
  26252    ;.;S PS=1 ,CHMFI=CHM FPDI,CHMFP P="SSPS"
  26253   "RTN","CHM FADR4",381 ,0)
  26254    ;.;D ^CHM FWK01
  26255   "RTN","CHM FADR4",382 ,0)
  26256    ;.;D SETP ROD^CHMFAD R1
  26257   "RTN","CHM FADR4",383 ,0)
  26258    ;.;D PSMS G^CHMFADR1
  26259   "RTN","CHM FADR4",384 ,0)
  26260    ;.;D KLOC K^CHMFADR1
  26261   "RTN","CHM FADR4",385 ,0)
  26262    ;.;D REMV ^CHMFADR1
  26263   "RTN","CHM FADR4",386 ,0)
  26264    ;.;D DELS T1^CHMFADR 1
  26265   "RTN","CHM FADR4",387 ,0)
  26266    ;.;D KILA LL^CHMFADR 1
  26267   "RTN","CHM FADR4",388 ,0)
  26268    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1
  26269   "RTN","CHM FADR4",389 ,0)
  26270    ;.;S CHMQ NAM="CHMPS Q(",CHMIN= 1 K CHMOUT  D ^CHMIS0 41 Q
  26271   "RTN","CHM FADR4",390 ,0)
  26272    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  26273   "RTN","CHM FADR4",391 ,0)
  26274    ;I $D(CHM FEXIT) D   Q
  26275   "RTN","CHM FADR4",392 ,0)
  26276    ;.;S FKIL =1
  26277   "RTN","CHM FADR4",393 ,0)
  26278    ;.;D SETP ROD^CHMFAD R1
  26279   "RTN","CHM FADR4",394 ,0)
  26280    ;.;D KLOC K^CHMFADR1
  26281   "RTN","CHM FADR4",395 ,0)
  26282    ;.;D DELS T1^CHMFADR 1
  26283   "RTN","CHM FADR4",396 ,0)
  26284    ;.;D SBOC R2DY^CHMFA DR1
  26285   "RTN","CHM FADR4",397 ,0)
  26286    I $D(CHMF KIL) D  Q
  26287   "RTN","CHM FADR4",398 ,0)
  26288    .S FKIL=1
  26289   "RTN","CHM FADR4",399 ,0)
  26290    .D SETPRO D^CHMFADR1
  26291   "RTN","CHM FADR4",400 ,0)
  26292    .D KLOCK^ CHMFADR1
  26293   "RTN","CHM FADR4",401 ,0)
  26294    .D DELST1 ^CHMFADR1
  26295   "RTN","CHM FADR4",402 ,0)
  26296    .D SBOCR2 DY^CHMFADR 1
  26297   "RTN","CHM FADR4",403 ,0)
  26298    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  26299   "RTN","CHM FADR4",404 ,0)
  26300    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  26301   "RTN","CHM FADR4",405 ,0)
  26302    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  26303   "RTN","CHM FADR4",406 ,0)
  26304    I $D(CHMF PDRV) D  G  SOCR20
  26305   "RTN","CHM FADR4",407 ,0)
  26306    .D KLOCK^ CHMFADR1
  26307   "RTN","CHM FADR4",408 ,0)
  26308    .D REMV^C HMFADR1
  26309   "RTN","CHM FADR4",409 ,0)
  26310    .D DELST1 ^CHMFADR1
  26311   "RTN","CHM FADR4",410 ,0)
  26312    .D OCRKIL ^CHMFADR1
  26313   "RTN","CHM FADR4",411 ,0)
  26314    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  26315   "RTN","CHM FADR4",412 ,0)
  26316    I $D(DUOU T) D  Q
  26317   "RTN","CHM FADR4",413 ,0)
  26318    .D KLOCK^ CHMFADR1
  26319   "RTN","CHM FADR4",414 ,0)
  26320    .D SBOCR2 DY^CHMFADR 1
  26321   "RTN","CHM FADR4",415 ,0)
  26322    .D DELST1 ^CHMFADR1
  26323   "RTN","CHM FADR4",416 ,0)
  26324    .D REMV^C HMFADR1
  26325   "RTN","CHM FADR4",417 ,0)
  26326    I $D(DFOU T) D  Q
  26327   "RTN","CHM FADR4",418 ,0)
  26328    .D KLOCK^ CHMFADR1
  26329   "RTN","CHM FADR4",419 ,0)
  26330    .D SBOCR2 DY^CHMFADR 1
  26331   "RTN","CHM FADR4",420 ,0)
  26332    .D DELST1 ^CHMFADR1
  26333   "RTN","CHM FADR4",421 ,0)
  26334    .D REMV^C HMFADR1
  26335   "RTN","CHM FADR4",422 ,0)
  26336    Q
  26337   "RTN","CHM FADR4",423 ,0)
  26338   OCRR ;CHV  EDI Re-Ope n Claims s tart here.  -- CPE005 -004
  26339   "RTN","CHM FADR4",424 ,0)
  26340    ;
  26341   "RTN","CHM FADR4",425 ,0)
  26342    N CHOSEN, VALOPDI,CH REJ
  26343   "RTN","CHM FADR4",426 ,0)
  26344    S CHOSEN= 6
  26345   "RTN","CHM FADR4",427 ,0)
  26346    K CHMFPRE V
  26347   "RTN","CHM FADR4",428 ,0)
  26348    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG, VALOPDI)=0
  26349   "RTN","CHM FADR4",429 ,0)
  26350    S CHMFPDI =""
  26351   "RTN","CHM FADR4",430 ,0)
  26352    D LSTPDI^ CHMFADR1
  26353   "RTN","CHM FADR4",431 ,0)
  26354    D SETUP^C HMFADR1
  26355   "RTN","CHM FADR4",432 ,0)
  26356    G:CHMFPDI '="" CR01
  26357   "RTN","CHM FADR4",433 ,0)
  26358   CRO0 D SET UP1^CHMFAD R1
  26359   "RTN","CHM FADR4",434 ,0)
  26360    D ^CHMFPD O3 Q:$D(CH QUIT)
  26361   "RTN","CHM FADR4",435 ,0)
  26362   CR01 ;
  26363   "RTN","CHM FADR4",436 ,0)
  26364    I CHMOPDI ="" S CHMO PDI=$P($G( ^CHMIMG(CH MFPDI,"E-R EOPEN"))," ^")
  26365   "RTN","CHM FADR4",437 ,0)
  26366    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=$G (CHMOPDI)
  26367   "RTN","CHM FADR4",438 ,0)
  26368    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1)
  26369   "RTN","CHM FADR4",439 ,0)
  26370    S CHMFPP= "SIP" D ^C HMFWK01
  26371   "RTN","CHM FADR4",440 ,0)
  26372    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  26373   "RTN","CHM FADR4",441 ,0)
  26374    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  26375   "RTN","CHM FADR4",442 ,0)
  26376    D GETDATA ^CHMFA008
  26377   "RTN","CHM FADR4",443 ,0)
  26378    S CHMFIMT Y=1,CHMFTY PE="BILL/I NVOICE" ;B DB 0517201 7
  26379   "RTN","CHM FADR4",444 ,0)
  26380    N NEXTPAG E
  26381   "RTN","CHM FADR4",445 ,0)
  26382   CH1 D ^CHM FA008
  26383   "RTN","CHM FADR4",446 ,0)
  26384    I $D(CHMF BAD) D  G  CRO0
  26385   "RTN","CHM FADR4",447 ,0)
  26386    .D KLOCK^ CHMFADR1
  26387   "RTN","CHM FADR4",448 ,0)
  26388    .D REMV^C HMFADR1
  26389   "RTN","CHM FADR4",449 ,0)
  26390    .D DELST1 ^CHMFADR1
  26391   "RTN","CHM FADR4",450 ,0)
  26392    .D KILALL ^CHMFADR1
  26393   "RTN","CHM FADR4",451 ,0)
  26394    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  26395   "RTN","CHM FADR4",452 ,0)
  26396    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  26397   "RTN","CHM FADR4",453 ,0)
  26398    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  26399   "RTN","CHM FADR4",454 ,0)
  26400    I $D(CHMF KIL) D  Q
  26401   "RTN","CHM FADR4",455 ,0)
  26402    .N CHMFTO B
  26403   "RTN","CHM FADR4",456 ,0)
  26404    .S CHMFTO B=$$TOB^CH MFADR2(CHM FPDI,CHMFP GNM,CHMFIM AG)
  26405   "RTN","CHM FADR4",457 ,0)
  26406    .I $E(CHM FTOB,3)=8  D  ;bdb cp e005-033 1 2/13/2017  prompt, se t the fina l cstat
  26407   "RTN","CHM FADR4",458 ,0)
  26408    ..N CHR
  26409   "RTN","CHM FADR4",459 ,0)
  26410    ..S DY=15 ,DX=20 X X Y W "Do yo u want to  reject the  Current P DI? Y/N // No " R CHR :600
  26411   "RTN","CHM FADR4",460 ,0)
  26412    ..I $E($$ UP^XLFSTR( $G(CHR)),1 )'="Y" D O CRRRDY^CHM FADR1 Q
  26413   "RTN","CHM FADR4",461 ,0)
  26414    ..D CRCST AT^CHMFUTL E(CHMFPDI, "","E001a" ,"A") ;CFS  Create th e CSTAT me ssage.
  26415   "RTN","CHM FADR4",462 ,0)
  26416    ..S DIE=7 41000.2,DA =CHMFPDI,D R=".06///1 1" D ^DIE  K DIE
  26417   "RTN","CHM FADR4",463 ,0)
  26418    .S FKIL=1
  26419   "RTN","CHM FADR4",464 ,0)
  26420    .D SETPRO D^CHMFADR1
  26421   "RTN","CHM FADR4",465 ,0)
  26422    .D KLOCK^ CHMFADR1
  26423   "RTN","CHM FADR4",466 ,0)
  26424    .D DELST1 ^CHMFADR1
  26425   "RTN","CHM FADR4",467 ,0)
  26426    .I $E(CHM FTOB,3)'=8  D OCRRRDY ^CHMFADR1
  26427   "RTN","CHM FADR4",468 ,0)
  26428    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  26429   "RTN","CHM FADR4",469 ,0)
  26430    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  26431   "RTN","CHM FADR4",470 ,0)
  26432    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  26433   "RTN","CHM FADR4",471 ,0)
  26434    I $D(CHMF PDRV) D  G  CRO0
  26435   "RTN","CHM FADR4",472 ,0)
  26436    .D KLOCK^ CHMFADR1
  26437   "RTN","CHM FADR4",473 ,0)
  26438    .D REMV^C HMFADR1
  26439   "RTN","CHM FADR4",474 ,0)
  26440    .D DELST1 ^CHMFADR1
  26441   "RTN","CHM FADR4",475 ,0)
  26442    .D OCRKIL ^CHMFADR1
  26443   "RTN","CHM FADR4",476 ,0)
  26444    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  26445   "RTN","CHM FADR4",477 ,0)
  26446    I $D(DUOU T) D  Q
  26447   "RTN","CHM FADR4",478 ,0)
  26448    .D KLOCK^ CHMFADR1
  26449   "RTN","CHM FADR4",479 ,0)
  26450    .D OCRRRD Y^CHMFADR1
  26451   "RTN","CHM FADR4",480 ,0)
  26452    .D DELST1 ^CHMFADR1
  26453   "RTN","CHM FADR4",481 ,0)
  26454    .D REMV^C HMFADR1
  26455   "RTN","CHM FADR4",482 ,0)
  26456    I $D(DFOU T) D  Q
  26457   "RTN","CHM FADR4",483 ,0)
  26458    .D KLOCK^ CHMFADR1
  26459   "RTN","CHM FADR4",484 ,0)
  26460    .D OCRRRD Y^CHMFADR1
  26461   "RTN","CHM FADR4",485 ,0)
  26462    .D DELST1 ^CHMFADR1
  26463   "RTN","CHM FADR4",486 ,0)
  26464    .D REMV^C HMFADR1
  26465   "RTN","CHM FADR4",487 ,0)
  26466    Q
  26467   "RTN","CHM FADR4",488 ,0)
  26468   SBOCRR ;SB /CWVV EDI  Re-open cl aims start  here. --  CPE005-004
  26469   "RTN","CHM FADR4",489 ,0)
  26470    ;
  26471   "RTN","CHM FADR4",490 ,0)
  26472    N CHOSEN, VALOPDI,CH REJ
  26473   "RTN","CHM FADR4",491 ,0)
  26474    S CHOSEN= 7
  26475   "RTN","CHM FADR4",492 ,0)
  26476    K CHMFPRE V
  26477   "RTN","CHM FADR4",493 ,0)
  26478    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG, VALOPDI)=0
  26479   "RTN","CHM FADR4",494 ,0)
  26480    S (CHMFPD I,CHMOPDI) =""
  26481   "RTN","CHM FADR4",495 ,0)
  26482    D LSTPDI^ CHMFADR1
  26483   "RTN","CHM FADR4",496 ,0)
  26484    D SETUP^C HMFADR1
  26485   "RTN","CHM FADR4",497 ,0)
  26486    G:CHMFPDI '="" SB01
  26487   "RTN","CHM FADR4",498 ,0)
  26488   SB0 D SETU P1^CHMFADR 1
  26489   "RTN","CHM FADR4",499 ,0)
  26490    D ^CHMFPD O4 Q:$D(CH QUIT)
  26491   "RTN","CHM FADR4",500 ,0)
  26492   SB01 ;
  26493   "RTN","CHM FADR4",501 ,0)
  26494    I CHMOPDI ="" S CHMO PDI=$P($G( ^CHMIMG(CH MFPDI,"E-R EOPEN"))," ^")
  26495   "RTN","CHM FADR4",502 ,0)
  26496    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=$G (CHMOPDI)
  26497   "RTN","CHM FADR4",503 ,0)
  26498    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1)
  26499   "RTN","CHM FADR4",504 ,0)
  26500    S CHMFPP= "SIP" D ^C HMFWK01
  26501   "RTN","CHM FADR4",505 ,0)
  26502    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  26503   "RTN","CHM FADR4",506 ,0)
  26504    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  26505   "RTN","CHM FADR4",507 ,0)
  26506    D GETDATA ^CHMFA008
  26507   "RTN","CHM FADR4",508 ,0)
  26508    S CHMFIMT Y=1,CHMFTY PE="BILL/I NVOICE" ;B DB 0517201 7
  26509   "RTN","CHM FADR4",509 ,0)
  26510    N NEXTPAG E
  26511   "RTN","CHM FADR4",510 ,0)
  26512   SB1 D ^CHM FA008
  26513   "RTN","CHM FADR4",511 ,0)
  26514    I $D(CHMF BAD) D  G  SB0
  26515   "RTN","CHM FADR4",512 ,0)
  26516    .D KLOCK^ CHMFADR1
  26517   "RTN","CHM FADR4",513 ,0)
  26518    .D REMV^C HMFADR1
  26519   "RTN","CHM FADR4",514 ,0)
  26520    .D DELST1 ^CHMFADR1
  26521   "RTN","CHM FADR4",515 ,0)
  26522    .D KILALL ^CHMFADR1
  26523   "RTN","CHM FADR4",516 ,0)
  26524    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  26525   "RTN","CHM FADR4",517 ,0)
  26526    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  26527   "RTN","CHM FADR4",518 ,0)
  26528    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  26529   "RTN","CHM FADR4",519 ,0)
  26530    I $D(CHMF KIL) D  Q
  26531   "RTN","CHM FADR4",520 ,0)
  26532    .N CHMFTO B
  26533   "RTN","CHM FADR4",521 ,0)
  26534    .S CHMFTO B=$$TOB^CH MFADR2(CHM FPDI,CHMFP GNM,CHMFIM AG)
  26535   "RTN","CHM FADR4",522 ,0)
  26536    .I $E(CHM FTOB,3)=8  D  ;bdb 12 /13/2017 c pe005-033  prompt, se t the fina l cstat
  26537   "RTN","CHM FADR4",523 ,0)
  26538    ..N CHR
  26539   "RTN","CHM FADR4",524 ,0)
  26540    ..S DY=15 ,DX=20 X X Y W "Do yo u want to  reject the  Current P DI? Y/N // No " R CHR :600
  26541   "RTN","CHM FADR4",525 ,0)
  26542    ..I $E($$ UP^XLFSTR( $G(CHR)),1 )'="Y" D S BOCRRDY^CH MFADR1 Q
  26543   "RTN","CHM FADR4",526 ,0)
  26544    ..D CRCST AT^CHMFUTL E(CHMFPDI, "","E001a" ,"A") ;CFS  Create th e CSTAT me ssage.
  26545   "RTN","CHM FADR4",527 ,0)
  26546    ..S DIE=7 41000.2,DA =CHMFPDI,D R=".06///1 1" D ^DIE  K DIE
  26547   "RTN","CHM FADR4",528 ,0)
  26548    .S FKIL=1
  26549   "RTN","CHM FADR4",529 ,0)
  26550    .D SETPRO D^CHMFADR1
  26551   "RTN","CHM FADR4",530 ,0)
  26552    .D KLOCK^ CHMFADR1
  26553   "RTN","CHM FADR4",531 ,0)
  26554    .D DELST1 ^CHMFADR1
  26555   "RTN","CHM FADR4",532 ,0)
  26556    .I $E(CHM FTOB,3)'=8  D SBOCRRD Y^CHMFADR1
  26557   "RTN","CHM FADR4",533 ,0)
  26558    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  26559   "RTN","CHM FADR4",534 ,0)
  26560    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  26561   "RTN","CHM FADR4",535 ,0)
  26562    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  26563   "RTN","CHM FADR4",536 ,0)
  26564    I $D(CHMF PDRV) D  G  SB0
  26565   "RTN","CHM FADR4",537 ,0)
  26566    .D KLOCK^ CHMFADR1
  26567   "RTN","CHM FADR4",538 ,0)
  26568    .D REMV^C HMFADR1
  26569   "RTN","CHM FADR4",539 ,0)
  26570    .D DELST1 ^CHMFADR1
  26571   "RTN","CHM FADR4",540 ,0)
  26572    .D OCRKIL ^CHMFADR1
  26573   "RTN","CHM FADR4",541 ,0)
  26574    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  26575   "RTN","CHM FADR4",542 ,0)
  26576    I $D(DUOU T) D  Q
  26577   "RTN","CHM FADR4",543 ,0)
  26578    .D KLOCK^ CHMFADR1
  26579   "RTN","CHM FADR4",544 ,0)
  26580    .D SBOCRR DY^CHMFADR 1
  26581   "RTN","CHM FADR4",545 ,0)
  26582    .D DELST1 ^CHMFADR1
  26583   "RTN","CHM FADR4",546 ,0)
  26584    .D REMV^C HMFADR1
  26585   "RTN","CHM FADR4",547 ,0)
  26586    I $D(DFOU T) D  Q
  26587   "RTN","CHM FADR4",548 ,0)
  26588    .D KLOCK^ CHMFADR1
  26589   "RTN","CHM FADR4",549 ,0)
  26590    .D SBOCRR DY^CHMFADR 1
  26591   "RTN","CHM FADR4",550 ,0)
  26592    .D DELST1 ^CHMFADR1
  26593   "RTN","CHM FADR4",551 ,0)
  26594    .D REMV^C HMFADR1
  26595   "RTN","CHM FADR4",552 ,0)
  26596    Q
  26597   "RTN","CHM FADR4",553 ,0)
  26598    ;
  26599   "RTN","CHM FADR4",554 ,0)
  26600   MANUALR ;M anual EDI  Re-Open pr ocessed cl aims start  here. CPE 005-069
  26601   "RTN","CHM FADR4",555 ,0)
  26602    ; Set var iables to  0 or nil
  26603   "RTN","CHM FADR4",556 ,0)
  26604    N CHOSEN, VALOPDI
  26605   "RTN","CHM FADR4",557 ,0)
  26606    S (PS,FKI L,FIPAY,BA D)=0
  26607   "RTN","CHM FADR4",558 ,0)
  26608    S (CHMFPD I,CHMOPDI) =""
  26609   "RTN","CHM FADR4",559 ,0)
  26610    S CHOSEN= 8
  26611   "RTN","CHM FADR4",560 ,0)
  26612    ; LSTPDI^ CHMFADR1 l ooks for P DI's curre ntly in "P ause" stat us.
  26613   "RTN","CHM FADR4",561 ,0)
  26614    D LSTPDI^ CHMFADR1
  26615   "RTN","CHM FADR4",562 ,0)
  26616    D SETUP^C HMFADR1
  26617   "RTN","CHM FADR4",563 ,0)
  26618    G:CHMFPDI '="" MR1
  26619   "RTN","CHM FADR4",564 ,0)
  26620   MR0 D SETU P1^CHMFADR 1
  26621   "RTN","CHM FADR4",565 ,0)
  26622   MR1 S CHMF IMTY=1,CHM FTYPE="BIL L/INVOICE"   ;CPE005- 071
  26623   "RTN","CHM FADR4",566 ,0)
  26624    N NEXTPAG E
  26625   "RTN","CHM FADR4",567 ,0)
  26626    D ^CHMFA0 01
  26627   "RTN","CHM FADR4",568 ,0)
  26628    I $D(CHYE SFLG) D  G  M0
  26629   "RTN","CHM FADR4",569 ,0)
  26630    .D KLOCK^ CHMFADR1
  26631   "RTN","CHM FADR4",570 ,0)
  26632    .D REMV^C HMFADR1
  26633   "RTN","CHM FADR4",571 ,0)
  26634    .D DELST1 ^CHMFADR1
  26635   "RTN","CHM FADR4",572 ,0)
  26636    .D KILALL ^CHMFADR1
  26637   "RTN","CHM FADR4",573 ,0)
  26638    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041  Q
  26639   "RTN","CHM FADR4",574 ,0)
  26640    I $D(CHMF BAD) D  G  M0
  26641   "RTN","CHM FADR4",575 ,0)
  26642    .D KLOCK^ CHMFADR1
  26643   "RTN","CHM FADR4",576 ,0)
  26644    .D REMV^C HMFADR1
  26645   "RTN","CHM FADR4",577 ,0)
  26646    .D DELST1 ^CHMFADR1
  26647   "RTN","CHM FADR4",578 ,0)
  26648    .D KILALL ^CHMFADR1
  26649   "RTN","CHM FADR4",579 ,0)
  26650    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041
  26651   "RTN","CHM FADR4",580 ,0)
  26652    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  26653   "RTN","CHM FADR4",581 ,0)
  26654    I $D(CHMF PS) D  G M 0
  26655   "RTN","CHM FADR4",582 ,0)
  26656    .S PS=1,C HMFI=CHMFP DI,CHMFPP= "SSPS"
  26657   "RTN","CHM FADR4",583 ,0)
  26658    .D ^CHMFW K01
  26659   "RTN","CHM FADR4",584 ,0)
  26660    .D SETPRO D^CHMFADR1
  26661   "RTN","CHM FADR4",585 ,0)
  26662    .D PSMSG^ CHMFADR1
  26663   "RTN","CHM FADR4",586 ,0)
  26664    .D KLOCK^ CHMFADR1
  26665   "RTN","CHM FADR4",587 ,0)
  26666    .D REMV^C HMFADR1
  26667   "RTN","CHM FADR4",588 ,0)
  26668    .D DELST1 ^CHMFADR1
  26669   "RTN","CHM FADR4",589 ,0)
  26670    .D KILALL ^CHMFADR1
  26671   "RTN","CHM FADR4",590 ,0)
  26672    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041
  26673   "RTN","CHM FADR4",591 ,0)
  26674    .S CHMQNA M="CHMPSQ( ",CHMIN=1  K CHMOUT D  ^CHMIS041  Q
  26675   "RTN","CHM FADR4",592 ,0)
  26676    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  26677   "RTN","CHM FADR4",593 ,0)
  26678    I $D(CHMF KIL) D  Q
  26679   "RTN","CHM FADR4",594 ,0)
  26680    .S FKIL=1
  26681   "RTN","CHM FADR4",595 ,0)
  26682    .D SETPRO D^CHMFADR1
  26683   "RTN","CHM FADR4",596 ,0)
  26684    .D DELST1 ^CHMFADR1
  26685   "RTN","CHM FADR4",597 ,0)
  26686    .D MANL^C HMFADR1
  26687   "RTN","CHM FADR4",598 ,0)
  26688    I $D(DUOU T) D  Q
  26689   "RTN","CHM FADR4",599 ,0)
  26690    .D KLOCK^ CHMFADR1
  26691   "RTN","CHM FADR4",600 ,0)
  26692    .D MANL^C HMFADR1
  26693   "RTN","CHM FADR4",601 ,0)
  26694    .D DELST1 ^CHMFADR1
  26695   "RTN","CHM FADR4",602 ,0)
  26696    .D REMV^C HMFADR1
  26697   "RTN","CHM FADR4",603 ,0)
  26698    I $D(DFOU T) D  Q
  26699   "RTN","CHM FADR4",604 ,0)
  26700    .D KLOCK^ CHMFADR1
  26701   "RTN","CHM FADR4",605 ,0)
  26702    .D MANL^C HMFADR1
  26703   "RTN","CHM FADR4",606 ,0)
  26704    .D DELST1 ^CHMFADR1
  26705   "RTN","CHM FADR4",607 ,0)
  26706    .D REMV^C HMFADR1
  26707   "RTN","CHM FADR4",608 ,0)
  26708    Q
  26709   "RTN","CHM FADRV")
  26710   0^52^B9565 3305
  26711   "RTN","CHM FADRV",1,0 )
  26712   CHMFADRV ; PJU/DEN;MA IN DRIVER  CHAMPVA;De c 14, 2018 @09:45:29
  26713   "RTN","CHM FADRV",2,0 )
  26714    ;;1.0;CHA MPVA SYSTE M;**1,12,1 4**;JULY 4 , 1990;Bui ld 9
  26715   "RTN","CHM FADRV",3,0 )
  26716    ;PT 11392
  26717   "RTN","CHM FADRV",4,0 )
  26718    ;TT 11060  JEH 11/26 /10 - ADDI NG USER LO CK
  26719   "RTN","CHM FADRV",5,0 )
  26720    ;CFS 08/0 1/2017 CPE 005-004 Mo dify the D oc ID Scre en for CHA MPVA and S B EDI Reop en.
  26721   "RTN","CHM FADRV",6,0 )
  26722    ;JSE 10/0 6/2017 CPE 005-051 Re strict use rs to the  reopen men us
  26723   "RTN","CHM FADRV",7,0 )
  26724    ;LEG 10/1 6/2017 CPE 005-001 ad ded "A-ALL " & "A-FIR ST" proces sing in A5 , PDIFIRST , PDIXREFS  and PDICN TS
  26725   "RTN","CHM FADRV",8,0 )
  26726    ;JSG2 10/ 20/2017 CP E005-023 C hanged sta tus to EDI -REOPEN
  26727   "RTN","CHM FADRV",9,0 )
  26728    ;CFS 12/1 1/2018 Tas k #881331  Remove EDI  Reopen Pe rmissions  Restrictio n.
  26729   "RTN","CHM FADRV",10, 0)
  26730    Q:$$IPUSR LK^CHMFADR V(0)=1  ;T T 11060 JE H 11/26/10
  26731   "RTN","CHM FADRV",11, 0)
  26732    K VQAURLF G,CHELQFLG
  26733   "RTN","CHM FADRV",12, 0)
  26734    N CHMFPDI ,CHMOPDI
  26735   "RTN","CHM FADRV",13, 0)
  26736    S PS=0,FK IL=0,FIPAY =0,BAD=0,X =0
  26737   "RTN","CHM FADRV",14, 0)
  26738    ;S X=$ZF( -1,"USERNA ME")
  26739   "RTN","CHM FADRV",15, 0)
  26740    S CHSS=""
  26741   "RTN","CHM FADRV",16, 0)
  26742    ;;S X=$ZF (-1,X,7),C HSS=X
  26743   "RTN","CHM FADRV",17, 0)
  26744    ; Go to C HMFSET and  set scree n variable s
  26745   "RTN","CHM FADRV",18, 0)
  26746    D ^CHMFSE T
  26747   "RTN","CHM FADRV",19, 0)
  26748    ; If ther e is no DU Z info, ou tput an er ror messag e and quit  the routi ne.
  26749   "RTN","CHM FADRV",20, 0)
  26750    I '$D(^CH MDIC(74100 2.21,DUZ,0 )) D NOUSE ^CHMFADR1  G END
  26751   "RTN","CHM FADRV",21, 0)
  26752    ; Determi ne if User  has data  in piece 1 0. If so,  identify I PSUB value  and go to  CALLSUB o therwise c ontinue.
  26753   "RTN","CHM FADRV",22, 0)
  26754    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)'= "" S IPSUB ="" D  G:I PSUB'="" C ALLSUB
  26755   "RTN","CHM FADRV",23, 0)
  26756    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 0 IPSUB="M ANUAL^CHMF ADR4"
  26757   "RTN","CHM FADRV",24, 0)
  26758    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 1 IPSUB="S CAN^CHMFAD R4"
  26759   "RTN","CHM FADRV",25, 0)
  26760    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 2 IPSUB="O CR^CHMFADR 4"
  26761   "RTN","CHM FADRV",26, 0)
  26762    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 3 IPSUB="S BOCR^CHMFA DR4"
  26763   "RTN","CHM FADRV",27, 0)
  26764    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 4 IPSUB="O CR2^CHMFAD R4"
  26765   "RTN","CHM FADRV",28, 0)
  26766    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 5 IPSUB="S BOCR2^CHMF ADR4"
  26767   "RTN","CHM FADRV",29, 0)
  26768    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 6 IPSUB="O CRR^CHMFAD R4"  ;CPE0 05-004
  26769   "RTN","CHM FADRV",30, 0)
  26770    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 7 IPSUB="S BOCRR^CHMF ADR4"  ;CP E005-004
  26771   "RTN","CHM FADRV",31, 0)
  26772    .S:$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 8 IPSUB="M ANUALR^CHM FADR4" ;MA NUAL EDI R EOPEN BDB  07262017
  26773   "RTN","CHM FADRV",32, 0)
  26774    W @IOF       ;SKD
  26775   "RTN","CHM FADRV",33, 0)
  26776   STRT W !!, "Are you e ntering <S >canned, < M>anual, C HAMPVA <E> DI, S<B>/C WVV EDI,"
  26777   "RTN","CHM FADRV",34, 0)
  26778     W !," CH AMPVA <O>C R, SB/C<W> VV OCR, <R C>REOPEN C HAMPVA EDI ,<RS>REOPE N SB EDI,"
  26779   "RTN","CHM FADRV",35, 0)
  26780     W !," or  <ER> REOP EN Manual  EDI submis sions? "
  26781   "RTN","CHM FADRV",36, 0)
  26782    D CSBRS^C HSC2
  26783   "RTN","CHM FADRV",37, 0)
  26784    ; If user  enters "^ ^", goto E ND and qui t routine
  26785   "RTN","CHM FADRV",38, 0)
  26786    G:$D(DUOU T) END
  26787   "RTN","CHM FADRV",39, 0)
  26788    G:$D(DFOU T) END
  26789   "RTN","CHM FADRV",40, 0)
  26790    ; If user  enters no thing and  hits retur n, re-writ e to scree n and retu rn to STRT
  26791   "RTN","CHM FADRV",41, 0)
  26792    ;CPE005-0 04 Add "RC " and "RS"  options t o horizont al menu.
  26793   "RTN","CHM FADRV",42, 0)
  26794    I $D(DQOU T) D  G ST RT
  26795   "RTN","CHM FADRV",43, 0)
  26796    .W !!,"En ter 'S' fo r Scanned,  'M' for M anual, 'E'  for CHV E DI, 'B' fo r SB/CWVV  EDI,"
  26797   "RTN","CHM FADRV",44, 0)
  26798    .W !,"'O'  for CHV O CR, 'W' fo r SB/CWVV  OCR, 'RC'  for REOPEN  CHAMPVA E DI,"
  26799   "RTN","CHM FADRV",45, 0)
  26800    .W !,"'RS ' for REOP EN SB EDI  submission s, or 'ER'  for Manua l EDI ReOp en "
  26801   "RTN","CHM FADRV",46, 0)
  26802    ; Y holds  the first  letter of  whatever  the user e ntered. If  nil, retu rn to STRT
  26803   "RTN","CHM FADRV",47, 0)
  26804    G:Y="" ST RT
  26805   "RTN","CHM FADRV",48, 0)
  26806    I (Y'="M" )&(Y'="E") &(Y'="S")& (Y'="B")&( Y'="O")&(Y '="W")&(Y' ="RC")&(Y' ="RS")&(Y' ="ER") G S TRT
  26807   "RTN","CHM FADRV",49, 0)
  26808    ;CPE005-0 51 Restric t users to  reopen me nu
  26809   "RTN","CHM FADRV",50, 0)
  26810    ;I Y="RC" !(Y="RS")! (Y="ER") S  MCHK=$$SC HK^CHMFADR 1(DUZ) G:M CHK=0 STRT  - CFS Tas k #881331  Remove by  commenting  out.
  26811   "RTN","CHM FADRV",51, 0)
  26812    ; Set the  10th piec e to equal  the user' s entry an d set IPSU B to the a ppropriate  string.
  26813   "RTN","CHM FADRV",52, 0)
  26814    I Y="M" S  $P(^CHMDI C(741002.2 1,DUZ,0)," ^",10)=0 S  IPSUB="MA NUAL^CHMFA DR4" ; MAN UAL
  26815   "RTN","CHM FADRV",53, 0)
  26816    I Y="E" S  $P(^CHMDI C(741002.2 1,DUZ,0)," ^",10)=2 S  IPSUB="OC R^CHMFADR4 " ; CHV ED I
  26817   "RTN","CHM FADRV",54, 0)
  26818    I Y="S" S  $P(^CHMDI C(741002.2 1,DUZ,0)," ^",10)=1 S  IPSUB="SC AN^CHMFADR 4" ; SCANN ED
  26819   "RTN","CHM FADRV",55, 0)
  26820    I Y="B" S  $P(^CHMDI C(741002.2 1,DUZ,0)," ^",10)=3 S  IPSUB="SB OCR^CHMFAD R4" ; SB/C WVV EDI
  26821   "RTN","CHM FADRV",56, 0)
  26822    I Y="O" S  $P(^CHMDI C(741002.2 1,DUZ,0)," ^",10)=4 S  IPSUB="OC R2^CHMFADR 4" ; CHV O CR
  26823   "RTN","CHM FADRV",57, 0)
  26824    I Y="W" S  $P(^CHMDI C(741002.2 1,DUZ,0)," ^",10)=5 S  IPSUB="SB OCR2^CHMFA DR4" ; SB/ CWVV OCR
  26825   "RTN","CHM FADRV",58, 0)
  26826    I Y="RC"  S $P(^CHMD IC(741002. 21,DUZ,0), "^",10)=6  S IPSUB="O CRR^CHMFAD R4" ; CHV  EDI REOPEN  CPE005-00 4
  26827   "RTN","CHM FADRV",59, 0)
  26828    I Y="RS"  S $P(^CHMD IC(741002. 21,DUZ,0), "^",10)=7  S IPSUB="S BOCRR^CHMF ADR4" ; SB /CWVV EDI  REOPEN CPE 005-004
  26829   "RTN","CHM FADRV",60, 0)
  26830    I Y="ER"  S $P(^CHMD IC(741002. 21,DUZ,0), "^",10)=8  S IPSUB="M ANUALR^CHM FADR4" ; M ANUAL EDI  REOPEN
  26831   "RTN","CHM FADRV",61, 0)
  26832    ;
  26833   "RTN","CHM FADRV",62, 0)
  26834   CALLSUB ;
  26835   "RTN","CHM FADRV",63, 0)
  26836    ; Do the  routine na med in the  variable  IPSUB.
  26837   "RTN","CHM FADRV",64, 0)
  26838    D @IPSUB
  26839   "RTN","CHM FADRV",65, 0)
  26840    G:$D(CHQU IT) END
  26841   "RTN","CHM FADRV",66, 0)
  26842    G:$D(CHMF PAUS) END
  26843   "RTN","CHM FADRV",67, 0)
  26844    G:$D(CHMF KIL) END
  26845   "RTN","CHM FADRV",68, 0)
  26846    G:$D(CHMF EXIT) END
  26847   "RTN","CHM FADRV",69, 0)
  26848    G:$D(CHMF PDRV) END
  26849   "RTN","CHM FADRV",70, 0)
  26850    G:$D(DUOU T) END
  26851   "RTN","CHM FADRV",71, 0)
  26852    G:$D(DFOU T) END
  26853   "RTN","CHM FADRV",72, 0)
  26854    ;
  26855   "RTN","CHM FADRV",73, 0)
  26856   CHECK ;CHE CK DATA AN D SORT CAL LED IN HER E
  26857   "RTN","CHM FADRV",74, 0)
  26858    ;
  26859   "RTN","CHM FADRV",75, 0)
  26860    G:CHMFPDI ="" A8
  26861   "RTN","CHM FADRV",76, 0)
  26862   A2 D CMPLT ^CHMFIMG
  26863   "RTN","CHM FADRV",77, 0)
  26864    S CHMFPP= "CIP" D ^C HMFWK01
  26865   "RTN","CHM FADRV",78, 0)
  26866    D KLOCK^C HMFADR1
  26867   "RTN","CHM FADRV",79, 0)
  26868    D DELST1^ CHMFADR1
  26869   "RTN","CHM FADRV",80, 0)
  26870    S CHMFPP= "SST"
  26871   "RTN","CHM FADRV",81, 0)
  26872    D ^CHMFWK 01
  26873   "RTN","CHM FADRV",82, 0)
  26874    D ^CHMFSR T ;SENDS C LAIMS TO C LAIM SORT
  26875   "RTN","CHM FADRV",83, 0)
  26876    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=0  D
  26877   "RTN","CHM FADRV",84, 0)
  26878    .S CHMQNA M="MANUAL( ",CHMOUT=1 ,IPSUB="MA NUAL^CHMFA DR4"
  26879   "RTN","CHM FADRV",85, 0)
  26880    .K CHMIN  D ^CHMIS04 1
  26881   "RTN","CHM FADRV",86, 0)
  26882    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=1  D
  26883   "RTN","CHM FADRV",87, 0)
  26884    .S CHMQNA M="IMAGE(" ,CHMOUT=1, IPSUB="SCA N^CHMFADR4 "
  26885   "RTN","CHM FADRV",88, 0)
  26886    .K CHMIN  D ^CHMIS04 1
  26887   "RTN","CHM FADRV",89, 0)
  26888    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=2  D
  26889   "RTN","CHM FADRV",90, 0)
  26890    .S CHMQNA M="OCR(",C HMOUT=1,IP SUB="OCR^C HMFADR4"
  26891   "RTN","CHM FADRV",91, 0)
  26892    .K CHMIN  D ^CHMIS04 1
  26893   "RTN","CHM FADRV",92, 0)
  26894    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=3  D
  26895   "RTN","CHM FADRV",93, 0)
  26896    .S CHMQNA M="OCR(",C HMOUT=1,IP SUB="SBOCR ^CHMFADR4"
  26897   "RTN","CHM FADRV",94, 0)
  26898    .K CHMIN  D ^CHMIS04 1
  26899   "RTN","CHM FADRV",95, 0)
  26900    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=4  D
  26901   "RTN","CHM FADRV",96, 0)
  26902    .S CHMQNA M="OCR(",C HMOUT=1,IP SUB="OCR2^ CHMFADR4"
  26903   "RTN","CHM FADRV",97, 0)
  26904    .K CHMIN  D ^CHMIS04 1
  26905   "RTN","CHM FADRV",98, 0)
  26906    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=5  D
  26907   "RTN","CHM FADRV",99, 0)
  26908    .S CHMQNA M="OCR(",C HMOUT=1,IP SUB="SBOCR 2^CHMFADR4 "
  26909   "RTN","CHM FADRV",100 ,0)
  26910    .K CHMIN  D ^CHMIS04 1
  26911   "RTN","CHM FADRV",101 ,0)
  26912    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=6  D  ;CPE00 5-004
  26913   "RTN","CHM FADRV",102 ,0)
  26914    .; CPE005 -023 Chang e status t o EDI-REOP EN
  26915   "RTN","CHM FADRV",103 ,0)
  26916    .;S CHMQN AM="OCR(", CHMOUT=1,I PSUB="OCRR ^CHMFADR4"
  26917   "RTN","CHM FADRV",104 ,0)
  26918    .S CHMQNA M="EDI-REO PEN",CHMOU T=1,IPSUB= "OCRR^CHMF ADR4"
  26919   "RTN","CHM FADRV",105 ,0)
  26920    .;
  26921   "RTN","CHM FADRV",106 ,0)
  26922    .K CHMIN  D ^CHMIS04 1
  26923   "RTN","CHM FADRV",107 ,0)
  26924    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=7  D  ;CPE00 5-004
  26925   "RTN","CHM FADRV",108 ,0)
  26926    .S CHMQNA M="OCR(",C HMOUT=1,IP SUB="SBOCR R^CHMFADR4 "
  26927   "RTN","CHM FADRV",109 ,0)
  26928    .K CHMIN  D ^CHMIS04 1
  26929   "RTN","CHM FADRV",110 ,0)
  26930    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=8  D
  26931   "RTN","CHM FADRV",111 ,0)
  26932    .S CHMQNA M="OCR(",C HMOUT=1,IP SUB="MANUA LR^CHMFADR 4"
  26933   "RTN","CHM FADRV",112 ,0)
  26934    .K CHMIN  D ^CHMIS04 1
  26935   "RTN","CHM FADRV",113 ,0)
  26936    S CHMFPP= "CST"
  26937   "RTN","CHM FADRV",114 ,0)
  26938    D ^CHMFWK 01
  26939   "RTN","CHM FADRV",115 ,0)
  26940    S $P(^CHM IMAGE(CHMF PDI,0),"^" ,10)=1
  26941   "RTN","CHM FADRV",116 ,0)
  26942    K CHMFCLM S,CHMFCL,C HMFREJ
  26943   "RTN","CHM FADRV",117 ,0)
  26944    D SORT^CH FCDUTL
  26945   "RTN","CHM FADRV",118 ,0)
  26946    D ^CHFCDD RV ;CALLS  CLAIM EDIT  UTILITY ^ CHMFA801
  26947   "RTN","CHM FADRV",119 ,0)
  26948    I $D(CHNE WPG) D  G  CALLSUB
  26949   "RTN","CHM FADRV",120 ,0)
  26950    .D NEWPG^ CHMFADR1
  26951   "RTN","CHM FADRV",121 ,0)
  26952    .S $P(^CH MIMG(CHMFP DI,0),"^", 6)=1
  26953   "RTN","CHM FADRV",122 ,0)
  26954    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 0 D
  26955   "RTN","CHM FADRV",123 ,0)
  26956    ..S IPSUB ="MANUAL^C HMFADR4"
  26957   "RTN","CHM FADRV",124 ,0)
  26958    ..D PDIUP ^CHMFABU3( CHMFPDI,$P (^CHMIMG(C HMFPDI,0), "^",6))
  26959   "RTN","CHM FADRV",125 ,0)
  26960    ..S CHMQN AM="MANUAL (",CHMIN=1
  26961   "RTN","CHM FADRV",126 ,0)
  26962    ..K CHMOU T D ^CHMIS 041
  26963   "RTN","CHM FADRV",127 ,0)
  26964    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 1 D
  26965   "RTN","CHM FADRV",128 ,0)
  26966    ..S IPSUB ="SCAN^CHM FADR4"
  26967   "RTN","CHM FADRV",129 ,0)
  26968    ..S CHMQN AM="IMAGE( ",CHMIN=1
  26969   "RTN","CHM FADRV",130 ,0)
  26970    ..K CHMOU T D ^CHMIS 041
  26971   "RTN","CHM FADRV",131 ,0)
  26972    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 2 D
  26973   "RTN","CHM FADRV",132 ,0)
  26974    ..S IPSUB ="OCR^CHMF ADR4"
  26975   "RTN","CHM FADRV",133 ,0)
  26976    ..S CHMQN AM="OCR(", CHMIN=1
  26977   "RTN","CHM FADRV",134 ,0)
  26978    ..K CHMOU T D ^CHMIS 041
  26979   "RTN","CHM FADRV",135 ,0)
  26980    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 3 D
  26981   "RTN","CHM FADRV",136 ,0)
  26982    ..S IPSUB ="SBOCR^CH MFADR4"
  26983   "RTN","CHM FADRV",137 ,0)
  26984    ..S CHMQN AM="OCR(", CHMIN=1
  26985   "RTN","CHM FADRV",138 ,0)
  26986    ..K CHMOU T D ^CHMIS 041
  26987   "RTN","CHM FADRV",139 ,0)
  26988    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 4 D
  26989   "RTN","CHM FADRV",140 ,0)
  26990    ..S IPSUB ="OCR2^CHM FADR4"
  26991   "RTN","CHM FADRV",141 ,0)
  26992    ..S CHMQN AM="OCR(", CHMIN=1
  26993   "RTN","CHM FADRV",142 ,0)
  26994    ..K CHMOU T D ^CHMIS 041
  26995   "RTN","CHM FADRV",143 ,0)
  26996    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 5 D
  26997   "RTN","CHM FADRV",144 ,0)
  26998    ..S IPSUB ="SBOCR2^C HMFADR4"
  26999   "RTN","CHM FADRV",145 ,0)
  27000    ..S CHMQN AM="OCR(", CHMIN=1
  27001   "RTN","CHM FADRV",146 ,0)
  27002    ..K CHMOU T D ^CHMIS 041
  27003   "RTN","CHM FADRV",147 ,0)
  27004    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 6 D  ;CPE0 05-004
  27005   "RTN","CHM FADRV",148 ,0)
  27006    ..S IPSUB ="OCRR^CHM FADR4"
  27007   "RTN","CHM FADRV",149 ,0)
  27008    ..; CPE00 5-023 Chan ge status  to EDI-REO PEN
  27009   "RTN","CHM FADRV",150 ,0)
  27010    ..; S CHM QNAM="OCR( ",CHMIN=1
  27011   "RTN","CHM FADRV",151 ,0)
  27012    ..S CHMQN AM="EDI-RE OPEN",CHMI N=1
  27013   "RTN","CHM FADRV",152 ,0)
  27014    ..K CHMOU T D ^CHMIS 041
  27015   "RTN","CHM FADRV",153 ,0)
  27016    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 7 D  ;CPE0 05-004
  27017   "RTN","CHM FADRV",154 ,0)
  27018    ..S IPSUB ="SBOCRR^C HMFADR4"
  27019   "RTN","CHM FADRV",155 ,0)
  27020    ..S CHMQN AM="OCR(", CHMIN=1
  27021   "RTN","CHM FADRV",156 ,0)
  27022    ..K CHMOU T D ^CHMIS 041
  27023   "RTN","CHM FADRV",157 ,0)
  27024    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 8 D
  27025   "RTN","CHM FADRV",158 ,0)
  27026    ..S IPSUB ="MANUALR^ CHMFADR4"
  27027   "RTN","CHM FADRV",159 ,0)
  27028    ..S CHMQN AM="OCR(", CHMIN=1
  27029   "RTN","CHM FADRV",160 ,0)
  27030    ..K CHMOU T D ^CHMIS 041
  27031   "RTN","CHM FADRV",161 ,0)
  27032    .S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",5)=C HMFPDI
  27033   "RTN","CHM FADRV",162 ,0)
  27034    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)'= 0,$P(^CHMD IC(741002. 21,DUZ,0), "^",10)'=8  D REMV1^C HMFADR1
  27035   "RTN","CHM FADRV",163 ,0)
  27036   A5 D NOW^% DTC
  27037   "RTN","CHM FADRV",164 ,0)
  27038    N CHOSEN
  27039   "RTN","CHM FADRV",165 ,0)
  27040    S $P(^CHM IMAGE(CHMF PDI,0),"^" ,5)=%
  27041   "RTN","CHM FADRV",166 ,0)
  27042    S CHOSEN= $P(^CHMDIC (741002.21 ,DUZ,0),"^ ",10)
  27043   "RTN","CHM FADRV",167 ,0)
  27044    I CHOSEN= 6!(CHOSEN= 7)!(CHOSEN =8) D  ;CP E005-004,  CPE005-069
  27045   "RTN","CHM FADRV",168 ,0)
  27046    .I $G(CHM OPDI)'=""  D
  27047   "RTN","CHM FADRV",169 ,0)
  27048    ..I $D(^C HMPAY("C", CHMFPDI))  D  ;Set ED I Reopen f lag. CPE00 5-004
  27049   "RTN","CHM FADRV",170 ,0)
  27050    ...S $P(^ CHMIMG(CHM FPDI,"E-RE OPEN"),"^" )=CHMOPDI, $P(^CHMIMG (CHMFPDI," E-REOPEN") ,"^",3)=0   ;Set flag  to 0 to a llow a reo pen of a r eopen.
  27051   "RTN","CHM FADRV",171 ,0)
  27052    ...S $P(^ CHMIMG(CHM OPDI,"E-RE OPEN"),"^" ,2)=CHMFPD I,$P(^CHMI MG(CHMOPDI ,"E-REOPEN "),"^",3)= 1
  27053   "RTN","CHM FADRV",172 ,0)
  27054    ...; add  ReOpen xre fs: a) "A- FIRST" set s 1st Orig inal for e ach given  subsequent  ReOpen
  27055   "RTN","CHM FADRV",173 ,0)
  27056    ...; b) " A-ALL" set s all ReOp ens xrefed  to 1st Or iginal occ urrence
  27057   "RTN","CHM FADRV",174 ,0)
  27058    ...D PDIF IRST^CHMFU TLE(CHMFPD I) ; (CPE0 05-001)
  27059   "RTN","CHM FADRV",175 ,0)
  27060    ...Q
  27061   "RTN","CHM FADRV",176 ,0)
  27062   A8 D KILAL L^CHMFADR1
  27063   "RTN","CHM FADRV",177 ,0)
  27064    G:$D(CHRS TSRT) END
  27065   "RTN","CHM FADRV",178 ,0)
  27066    D BATCH^C HMFADR1
  27067   "RTN","CHM FADRV",179 ,0)
  27068    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=0  IPSUB="MA NUAL^CHMFA DR4"
  27069   "RTN","CHM FADRV",180 ,0)
  27070    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=2  IPSUB="OC R^CHMFADR4 "
  27071   "RTN","CHM FADRV",181 ,0)
  27072    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=1  IPSUB="SC AN^CHMFADR 4"
  27073   "RTN","CHM FADRV",182 ,0)
  27074    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=3  IPSUB="SB OCR^CHMFAD R4"
  27075   "RTN","CHM FADRV",183 ,0)
  27076    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=4  IPSUB="OC R2^CHMFADR 4"
  27077   "RTN","CHM FADRV",184 ,0)
  27078    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=5  IPSUB="SB OCR2^CHMFA DR4"
  27079   "RTN","CHM FADRV",185 ,0)
  27080    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=6  IPSUB="OC RR^CHMFADR 4"  ;CPE00 5-004
  27081   "RTN","CHM FADRV",186 ,0)
  27082    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=7  IPSUB="SB OCRR^CHMFA DR4"  ;CPE 005-004
  27083   "RTN","CHM FADRV",187 ,0)
  27084    S:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=8  IPSUB="MA NUALR^CHMF ADR4"
  27085   "RTN","CHM FADRV",188 ,0)
  27086    G CALLSUB
  27087   "RTN","CHM FADRV",189 ,0)
  27088    ;
  27089   "RTN","CHM FADRV",190 ,0)
  27090   END I $D(^ CHMDIC(741 002.21,DUZ ,0)) D
  27091   "RTN","CHM FADRV",191 ,0)
  27092    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)' =0,$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)'= 8 D REMV^C HMFADR1
  27093   "RTN","CHM FADRV",192 ,0)
  27094    X CHRESET
  27095   "RTN","CHM FADRV",193 ,0)
  27096    I $D(CHMF PDI) K:CHM FPDI'="" ^ CHMIMAGE(" LOCK",CHMF PDI)
  27097   "RTN","CHM FADRV",194 ,0)
  27098    I '$D(CHM FPAUS) D
  27099   "RTN","CHM FADRV",195 ,0)
  27100    .D KILALL ^CHMFADR1
  27101   "RTN","CHM FADRV",196 ,0)
  27102    .S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",2)=" "
  27103   "RTN","CHM FADRV",197 ,0)
  27104    .S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",5)=" "
  27105   "RTN","CHM FADRV",198 ,0)
  27106    .S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= ""
  27107   "RTN","CHM FADRV",199 ,0)
  27108   QUIT K CHB OFF,CHBON, CHEBOL,CHE EL,CHEOL,C HMAR,CHMAR ESET,CHMFU SER
  27109   "RTN","CHM FADRV",200 ,0)
  27110    K CHREVOF F,CHREVON, CHULOFF,CH ULON,OUTFL G,IPSUB L
  27111   "RTN","CHM FADRV",201 ,0)
  27112    Q:$$IPUSR LK^CHMFADR V(1)=1  ;T T 11060 JE H 11/26/10
  27113   "RTN","CHM FADRV",202 ,0)
  27114    Q
  27115   "RTN","CHM FADRV",203 ,0)
  27116    ;
  27117   "RTN","CHM FADRV",204 ,0)
  27118    ;SUBROUTI NES CALLED  IN DRIVER
  27119   "RTN","CHM FADRV",205 ,0)
  27120    ;
  27121   "RTN","CHM FADRV",206 ,0)
  27122   ERR1 S DY= 5,DX=10 X  XY W "User  is unknow n to syste m",@CHEOL
  27123   "RTN","CHM FADRV",207 ,0)
  27124    S DY=6,DX =10 X XY W  "Please L og onto te rminal aga in",@CHEOL
  27125   "RTN","CHM FADRV",208 ,0)
  27126    R RD:2 Q
  27127   "RTN","CHM FADRV",209 ,0)
  27128    Q
  27129   "RTN","CHM FADRV",210 ,0)
  27130   IPUSRLK(IP FLG) ;USER  LOCK TO P REVENT MUL TIPLE SESS IONS ;TT 1 1060 JEH 1 1/26/10
  27131   "RTN","CHM FADRV",211 ,0)
  27132    Q:$$ENVIR ^CHTFLIB() '="LIVE" 0  ;FOR LIVE  USE ONLY
  27133   "RTN","CHM FADRV",212 ,0)
  27134    N IPLCK    ;SETTING  LOCK TO AL LOW USER T O RUN IP 0 =UNLOCKED/ 1=LOCKED
  27135   "RTN","CHM FADRV",213 ,0)
  27136    N IPMSG    ;LOCKING  MESSAGE
  27137   "RTN","CHM FADRV",214 ,0)
  27138    S IPLCK=0
  27139   "RTN","CHM FADRV",215 ,0)
  27140    I IPFLG=0  D
  27141   "RTN","CHM FADRV",216 ,0)
  27142    .I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",22)= 1 D
  27143   "RTN","CHM FADRV",217 ,0)
  27144    ..S IPMSG ="*** IMAG E PROCESSI NG (IP) IS  CURRENTLY  IN USE, O NLY 1 SESS ION IS ALL OWED ***"
  27145   "RTN","CHM FADRV",218 ,0)
  27146    ..S IPMSG 2="Please  contact yo ur Supervi sor for he lp."
  27147   "RTN","CHM FADRV",219 ,0)
  27148    ..W @IOF, !!,?(80-$L (IPMSG)/2) ,IPMSG,!!, IPMSG2,! H  3
  27149   "RTN","CHM FADRV",220 ,0)
  27150    ..S IPLCK =1
  27151   "RTN","CHM FADRV",221 ,0)
  27152    .E  D
  27153   "RTN","CHM FADRV",222 ,0)
  27154    ..S $P(^C HMDIC(7410 02.21,DUZ, 0),"^",22) =1
  27155   "RTN","CHM FADRV",223 ,0)
  27156    ..S IPLCK =0
  27157   "RTN","CHM FADRV",224 ,0)
  27158    I IPFLG=1  D
  27159   "RTN","CHM FADRV",225 ,0)
  27160    .S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",22)= 0
  27161   "RTN","CHM FADRV",226 ,0)
  27162    .S IPLCK= 1
  27163   "RTN","CHM FADRV",227 ,0)
  27164    Q IPLCK
  27165   "RTN","CHM FADRV",228 ,0)
  27166   IPHLPDSK ; ALLOW OCIO  HELPDESK  TO LOCK/UN LOCK IP FO R USER ;TT  11060 JEH  11/26/10
  27167   "RTN","CHM FADRV",229 ,0)
  27168    N IPHMSG, TMPY,IPDUZ
  27169   "RTN","CHM FADRV",230 ,0)
  27170    S IPHMSG= "LOCK/UNLO CK IMAGE P ROCESSING  (IP) SCREE N FOR USER "
  27171   "RTN","CHM FADRV",231 ,0)
  27172    W #,!!,?( 80-$L(IPHM SG)/2),IPH MSG,!!
  27173   "RTN","CHM FADRV",232 ,0)
  27174    S DIR(0)= "PO^741002 .21:EMZ",D IR("A")="U ser to unl ock" D ^DI R K DIR
  27175   "RTN","CHM FADRV",233 ,0)
  27176    Q:$D(DIRU T)
  27177   "RTN","CHM FADRV",234 ,0)
  27178    Q:Y=-1
  27179   "RTN","CHM FADRV",235 ,0)
  27180    S IPDUZ=+ Y
  27181   "RTN","CHM FADRV",236 ,0)
  27182    I $P(^CHM DIC(741002 .21,+Y,0), "^",22)=0& ($P(^CHMDI C(741002.2 1,+Y,0),"^ ",5)="") D   Q
  27183   "RTN","CHM FADRV",237 ,0)
  27184    .W !!,$P( ^VA(200,+Y ,0),"^",1) ," DOES NO T HAVE AN  OPEN IMAGE  PROCESSIN G (IP) SES SION TO UN LOCK." H 2
  27185   "RTN","CHM FADRV",238 ,0)
  27186    I $P(^CHM DIC(741002 .21,+Y,0), "^",5)'=""  W !!,"USE R HAS SESS ION OPEN W ITH AN ACT IVE PDI, D OUBLE CHEC K BEFORE U NLOCKING." ,!
  27187   "RTN","CHM FADRV",239 ,0)
  27188    S TMPY=+Y
  27189   "RTN","CHM FADRV",240 ,0)
  27190    W !
  27191   "RTN","CHM FADRV",241 ,0)
  27192    S DIR(0)= "Y",DIR("B ")="NO",DI R("A")="OK  TO UNLOCK " D ^DIR K  DIR
  27193   "RTN","CHM FADRV",242 ,0)
  27194    I Y=1 D
  27195   "RTN","CHM FADRV",243 ,0)
  27196    .S $P(^CH MDIC(74100 2.21,TMPY, 0),"^",22) =0
  27197   "RTN","CHM FADRV",244 ,0)
  27198    .D MMMSG
  27199   "RTN","CHM FADRV",245 ,0)
  27200    K DIE,DR, DA,Y
  27201   "RTN","CHM FADRV",246 ,0)
  27202    Q
  27203   "RTN","CHM FADRV",247 ,0)
  27204   MMMSG ;GEN ERATE MM M ESSAGE TO  CPD TOP 4  SPECIALIST  AND USER  NEEDING UN LOCKED
  27205   "RTN","CHM FADRV",248 ,0)
  27206    Q:'$D(IPD UZ)
  27207   "RTN","CHM FADRV",249 ,0)
  27208    N USRNM,U NLDT
  27209   "RTN","CHM FADRV",250 ,0)
  27210    D NOW^%DT C S UNLDT= $$FMTE^XLF DT(%)
  27211   "RTN","CHM FADRV",251 ,0)
  27212    S USRNM=$ P(^VA(200, IPDUZ,0)," ^",1)
  27213   "RTN","CHM FADRV",252 ,0)
  27214    S CNT=1,^ TMP($J,"CH MIPLK",CNT )="",CNT=C NT+1
  27215   "RTN","CHM FADRV",253 ,0)
  27216    S ^TMP($J ,"CHMIPLK" ,CNT)="Use r "_USRNM_ " has been  unlocked  from Image  Processin g (IP).",C NT=CNT+1
  27217   "RTN","CHM FADRV",254 ,0)
  27218    S ^TMP($J ,"CHMIPLK" ,CNT)="",C NT=CNT+1
  27219   "RTN","CHM FADRV",255 ,0)
  27220    S ^TMP($J ,"CHMIPLK" ,CNT)="Unl ock was do ne: "_UNLD T,CNT=CNT+ 1
  27221   "RTN","CHM FADRV",256 ,0)
  27222    S ^TMP($J ,"CHMIPLK" ,CNT)="",C NT=CNT+1
  27223   "RTN","CHM FADRV",257 ,0)
  27224    S XMTEXT= "^TMP($J," "CHMIPLK"" ,"
  27225   "RTN","CHM FADRV",258 ,0)
  27226    S XMDUZ=. 5
  27227   "RTN","CHM FADRV",259 ,0)
  27228    S XMY(IPD UZ)=""   ; COURTESY C OPY FOR US ER NEEDING  UNLOCKED
  27229   "RTN","CHM FADRV",260 ,0)
  27230    S XMY(DUZ )="" ;COPY  FOR USER  UNLOCKING  VE
  27231   "RTN","CHM FADRV",261 ,0)
  27232    ;S XMY("
P II                  ")="" ;CPD  SUPERVISO RS AND LEA DS MAIL GR OUP - FOR  FUTURE USE
  27233   "RTN","CHM FADRV",262 ,0)
  27234    S XMSUB=" IP UNLOCKE D FOR "_US RNM D ^XMD
  27235   "RTN","CHM FADRV",263 ,0)
  27236    Q
  27237   "RTN","CHM FADRV",264 ,0)
  27238    ;
  27239   "RTN","CHM FAUT1")
  27240   0^54^B9940 54240
  27241   "RTN","CHM FAUT1",1,0 )
  27242   CHMFAUT1 ; HAC/JLR;UT ILITY PROG RAM FOR IP  SCREENS;0 1/19/00  1 3:15 PM
  27243   "RTN","CHM FAUT1",2,0 )
  27244    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  27245   "RTN","CHM FAUT1",3,0 )
  27246    ;JSG;01/2 9/08;Modif ications f or DEV0039 56-02;Hand ling null  DOSs (see  PREOUT)
  27247   "RTN","CHM FAUT1",4,0 )
  27248    ;JSG;01/2 9/08;                                 ;OC =  Old Code,  NC = New  Code
  27249   "RTN","CHM FAUT1",5,0 )
  27250    ;JSG;03/1 4/08;DEV00 4525-01;Pr event Inva lid Subscr ipt error
  27251   "RTN","CHM FAUT1",6,0 )
  27252    ;JEH 8/29 /08 TT #DE V005596  A dded code  to prevent  undefined  error whe n missing  %
  27253   "RTN","CHM FAUT1",7,0 )
  27254    ;DEV00480 5 1/20/201 0 AEB
  27255   "RTN","CHM FAUT1",8,0 )
  27256    ;DEV00782 0 10/27/20 10 AEB
  27257   "RTN","CHM FAUT1",9,0 )
  27258    ;DEV00782 0 JEH 2/1/ 11 - SLLA
  27259   "RTN","CHM FAUT1",10, 0)
  27260    ;DEV01207 2 JEH 10/5 /11 - add  icd check
  27261   "RTN","CHM FAUT1",11, 0)
  27262    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if freque ncy code =  5
  27263   "RTN","CHM FAUT1",12, 0)
  27264    ;CPE005-0 48 wtc 7/2 6/17 - sor t DME line s by DOS
  27265   "RTN","CHM FAUT1",13, 0)
  27266    ;CPE005-0 49 kml 8/7 /17 - sort  dental in voice line s by DOS
  27267   "RTN","CHM FAUT1",14, 0)
  27268    ;CPE005-0 08/050 wtc  8/8/17 -  sort outpa tient serv ice lines  by DOS
  27269   "RTN","CHM FAUT1",15, 0)
  27270    ;BDB CPE0 05-009 8/2 0/2017
  27271   "RTN","CHM FAUT1",16, 0)
  27272    ;RALLY US 8440 - TGH  - 3/15/19  Reset Den tal Values  to match  CHMIMAGE
  27273   "RTN","CHM FAUT1",17, 0)
  27274    ;
  27275   "RTN","CHM FAUT1",18, 0)
  27276   PDITYP(PDI ) ;Determi nes PDI ty pe
  27277   "RTN","CHM FAUT1",19, 0)
  27278    ; Returns  0 = not a n OCR clai m
  27279   "RTN","CHM FAUT1",20, 0)
  27280    ;          1 = is an  OCR claim
  27281   "RTN","CHM FAUT1",21, 0)
  27282    ;
  27283   "RTN","CHM FAUT1",22, 0)
  27284    ;Example:  S CHPDIPR L=$$PDITYP ^CHMFAUT1( CHMFPDI)
  27285   "RTN","CHM FAUT1",23, 0)
  27286    ;
  27287   "RTN","CHM FAUT1",24, 0)
  27288    N X,Y,CHP DITY,PTR S  X=0
  27289   "RTN","CHM FAUT1",25, 0)
  27290    ;//////// / START // ////////// ////////// /  RKN 12/ 12/2006 TT #312  this  ensures C HPDIPRL va riable wil l equal 1
  27291   "RTN","CHM FAUT1",26, 0)
  27292    I $E(PDI, 8,9)="92"  S X="1"  ; RKN 12/12/ 2006 TT#31 2  this en sures CHPD IPRL varia ble will e qual 1
  27293   "RTN","CHM FAUT1",27, 0)
  27294    ;The abov e code pre vents this  eroneous  error mess age below  from being  displayed  in routin e PAG1^CHM FADR2
  27295   "RTN","CHM FAUT1",28, 0)
  27296    ;  "Page  # ",CHMFPG NM," has a lready bee n processe d.  Do you  want to k ill the da ta for thi s"
  27297   "RTN","CHM FAUT1",29, 0)
  27298    ;//////// / END //// ////////// ////////// ///// RKN  12/12/2006  TT#312  t his ensure s CHPDIPRL  variable  will equal  1
  27299   "RTN","CHM FAUT1",30, 0)
  27300    G:'$D(PDI ) TYPEXIT
  27301   "RTN","CHM FAUT1",31, 0)
  27302    G:'$D(^CH MIMG(PDI))  TYPEXIT
  27303   "RTN","CHM FAUT1",32, 0)
  27304    S CHPDITY =$$TYPE^CH MFPDI2(PDI )
  27305   "RTN","CHM FAUT1",33, 0)
  27306    G:CHPDITY ="" TYPEXI T
  27307   "RTN","CHM FAUT1",34, 0)
  27308    G:'$D(^CH MDIC(74100 2.93,"C",C HPDITY)) T YPEXIT
  27309   "RTN","CHM FAUT1",35, 0)
  27310    S PTR=$O( ^CHMDIC(74 1002.93,"C ",CHPDITY, 0))
  27311   "RTN","CHM FAUT1",36, 0)
  27312    G:'PTR TY PEXIT
  27313   "RTN","CHM FAUT1",37, 0)
  27314    G:'$D(^CH MDIC(74100 2.93,PTR,0 )) TYPEXIT
  27315   "RTN","CHM FAUT1",38, 0)
  27316    G:'$P(^CH MDIC(74100 2.93,PTR,0 ),"^",7) T YPEXIT
  27317   "RTN","CHM FAUT1",39, 0)
  27318    S X=1
  27319   "RTN","CHM FAUT1",40, 0)
  27320   TYPEXIT Q  X
  27321   "RTN","CHM FAUT1",41, 0)
  27322    ;
  27323   "RTN","CHM FAUT1",42, 0)
  27324   PREOUT ; P reload Out patient pr ocedures
  27325   "RTN","CHM FAUT1",43, 0)
  27326    N L,INFO, DOS,POS,CH G,ICD,MOD, CPT,REV,OH IPYMT,MEDP YMT,BENPYM T,SPBEN,IN FO2          ;JEH 2/1 /11 DEV007 820
  27327   "RTN","CHM FAUT1",44, 0)
  27328    N DOSOUT, POSOUT,ICD OUT,REVOUT ,MODOUT,CP TOUT,PRAMO UNT   ;SKD  9-27-07 D EV003378
  27329   "RTN","CHM FAUT1",45, 0)
  27330    N OHIPDAM T,OHIPRESP ,ADDOHIPY, OHIPRBAL,M EDICDPD,TP LPAID,COST UNT,NMUNTA LL         ;JEH 2/1/1 1 DEV00782 0
  27331   "RTN","CHM FAUT1",46, 0)
  27332    N CALLDAM T,DEDCTAMT ,CSTSHAMT, PYMNTAMT,P ATPDAMT,CC APLAMT,ADI STRO,EDILI D ;JEH 2/1 /11 DEV007 820
  27333   "RTN","CHM FAUT1",47, 0)
  27334    N SVL           ;JEH  2/1/11 DE V007820
  27335   "RTN","CHM FAUT1",48, 0)
  27336    N D3,D4,O PTDOS,CHMO PGNM,CHMOI MAG,CHMOPG IM ; wtc 8 /8/17
  27337   "RTN","CHM FAUT1",49, 0)
  27338    K ^UTILIT Y($J),^TMP ($J) ; wtc  8/8/17
  27339   "RTN","CHM FAUT1",50, 0)
  27340    S (OPTDOS ,SVL)="",D 3=0,L=0 ;  wtc 8/8/17
  27341   "RTN","CHM FAUT1",51, 0)
  27342    ;
  27343   "RTN","CHM FAUT1",52, 0)
  27344    ;  wtc 8/ 8/17
  27345   "RTN","CHM FAUT1",53, 0)
  27346    ;  
  27347   "RTN","CHM FAUT1",54, 0)
  27348    ;  "B" cr oss-refere nce at "OP T-NS" mult iple is no t being cr eated when  image fil e is creat ed
  27349   "RTN","CHM FAUT1",55, 0)
  27350    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  27351   "RTN","CHM FAUT1",56, 0)
  27352    ;
  27353   "RTN","CHM FAUT1",57, 0)
  27354    S SVL=0        ;JEH  2/1/11 DEV 007820
  27355   "RTN","CHM FAUT1",58, 0)
  27356    ;S L=""   ; wtc 8/8/ 17
  27357   "RTN","CHM FAUT1",59, 0)
  27358    I $G(CHMF PDI) F  S  D3=$O(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"OPT -NS",D3))  Q:D3=""  D   ; wtc 8/ 8/17
  27359   "RTN","CHM FAUT1",60, 0)
  27360    . S OPTDO S=$P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"O PT-NS",D3, 0)),"^",1)  ;
  27361   "RTN","CHM FAUT1",61, 0)
  27362    . ;S ^TMP ($J,CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"OPT-N S",OPTDOS, D3)=""
  27363   "RTN","CHM FAUT1",62, 0)
  27364    . S ^TMP( $J,OPTDOS, D3,CHMFPDI )=""
  27365   "RTN","CHM FAUT1",63, 0)
  27366    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  27367   "RTN","CHM FAUT1",64, 0)
  27368    I $G(CHMO PDI),$G(CH MOPGNM),$G (CHMOIMAG) ,$E($P($G( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN")),"^ ",7),3)=5  F  S D3=$O (^CHMIMAGE (CHMOPDI,1 ,CHMOPGNM, 2,CHMOIMAG ,"OPT-NS", D3)) Q:D3= ""  D
  27369   "RTN","CHM FAUT1",65, 0)
  27370    . S OPTDO S=$P($G(^C HMIMAGE(CH MOPDI,1,CH MOPGNM,2,C HMOIMAG,"O PT-NS",D3, 0)),"^",1)  ;
  27371   "RTN","CHM FAUT1",66, 0)
  27372    . ;S ^TMP ($J,CHMOPD I,1,CHMOPG NM,2,CHMOI MAG,"OPT-N S",OPTDOS, D3)=""
  27373   "RTN","CHM FAUT1",67, 0)
  27374    . S ^TMP( $J,OPTDOS, D3,CHMOPDI )=""
  27375   "RTN","CHM FAUT1",68, 0)
  27376    ;
  27377   "RTN","CHM FAUT1",69, 0)
  27378    ;F  S L=$ O(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"OPT-NS" ,L)) Q:L=" "  D S OPT DOS="" ;   wtc 8/8/17
  27379   "RTN","CHM FAUT1",70, 0)
  27380    S OPTDOS= "" ;
  27381   "RTN","CHM FAUT1",71, 0)
  27382    ;F  S OPT DOS=$O(^TM P($J,CHMFP DI,1,CHMFP GNM,2,CHMF IMAG,"OPT- NS",OPTDOS )) Q:OPTDO S=""  D  ;  wtc 8/8/1 7
  27383   "RTN","CHM FAUT1",72, 0)
  27384    ;. F  S D 3=$O(^TMP( $J,CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"OPT-NS ",OPTDOS,D 3)) Q:D3=" "  D  ; wt c 8/8/17
  27385   "RTN","CHM FAUT1",73, 0)
  27386    F  S OPTD OS=$O(^TMP ($J,OPTDOS )) Q:OPTDO S=""  D  ;  wtc 8/8/1 7
  27387   "RTN","CHM FAUT1",74, 0)
  27388    . S D3=""  F  S D3=$ O(^TMP($J, OPTDOS,D3) ) Q:D3=""   D  ; wtc  8/8/17
  27389   "RTN","CHM FAUT1",75, 0)
  27390    .. S D4=" " F  S D4= $O(^TMP($J ,OPTDOS,D3 ,D4)) Q:D4 =""  D  ;b db 8/15/20 176
  27391   "RTN","CHM FAUT1",76, 0)
  27392    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  27393   "RTN","CHM FAUT1",77, 0)
  27394    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=$G(CHMOP DI),CHMFPG N1=$G(CHMO PGNM),CHMF IMA1=$G(CH MOIMAG)
  27395   "RTN","CHM FAUT1",78, 0)
  27396    ...S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  27397   "RTN","CHM FAUT1",79, 0)
  27398    ...S INFO =$G(^CHMIM AGE(CHMFPD I1,1,CHMFP GN1,2,CHMF IMA1,"OPT- NS",D3,0))  ; change  L to D3 wt c 8/8/17
  27399   "RTN","CHM FAUT1",80, 0)
  27400    ...S INFO 2=$G(^CHMI MAGE(CHMFP DI1,1,CHMF PGN1,2,CHM FIMA1,"OPT -NS",D3,1, 1,0)) ;JEH  2/1/11 DE V007820 ;  change L t o D3 wtc 8 /8/17
  27401   "RTN","CHM FAUT1",81, 0)
  27402    ...;&(INF O2="")         ;JEH 2 /1/11 DEV0 07820
  27403   "RTN","CHM FAUT1",82, 0)
  27404    ...Q:INFO =""
  27405   "RTN","CHM FAUT1",83, 0)
  27406    ...S SPBE N=$P(INFO, "^",3)_"/" _$P(INFO," ^",4)
  27407   "RTN","CHM FAUT1",84, 0)
  27408    ...; JSG; 01/29/08;D EV003956-0 2;Make DOS OUT = "__/ __/__^" fo r null DOS
  27409   "RTN","CHM FAUT1",85, 0)
  27410    ...; S DO S=$P(INFO, "^",1) S:D OS]"" DOSO UT=$$DOS^C HMFAUT0(DO S)                  ; JSG;OC
  27411   "RTN","CHM FAUT1",86, 0)
  27412    ...S DOS= $P(INFO,"^ ",1) S DOS OUT=$S(DOS ]"":$$DOS^ CHMFAUT0(D OS),1:"__/ __/__^") ; JSG;NC: St uff it, if  ""
  27413   "RTN","CHM FAUT1",87, 0)
  27414    ...S POS= $P(INFO,"^ ",2) S:POS ="" POS=3  S:POS]"" P OSOUT=$$PO S^CHMFAUT0 (POS)
  27415   "RTN","CHM FAUT1",88, 0)
  27416    ...S CHG= $P(INFO,"^ ",8)
  27417   "RTN","CHM FAUT1",89, 0)
  27418    ...S ICD= $P(INFO,"^ ",10) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  27419   "RTN","CHM FAUT1",90, 0)
  27420    ...S MOD= $P(INFO,"^ ",9) I MOD ]"" S MODO UT=$$MOD^C HMFAUT0(MO D),MOD=$P( MODOUT,"^" ,1)                                          ;JEH 2/1/ 11 DEV0078 20
  27421   "RTN","CHM FAUT1",91, 0)
  27422    ...S MOD2 =$P(INFO," ^",20) I M OD2]"" S M ODOUT=MODO UT_"*"_$$M OD^CHMFAUT 0(MOD2),MO D2=$P($P(M ODOUT,"*", 2),"^",1)      ;JEH 2 /1/11 DEV0 07820
  27423   "RTN","CHM FAUT1",92, 0)
  27424    ...S MOD3 =$P(INFO," ^",21) S:M OD3]"" MOD OUT=MODOUT _"*"_$$MOD ^CHMFAUT0( MOD3),MOD3 =$P($P(MOD OUT,"*",3) ,"^",1)                 ;JEH 2/1 /11 DEV007 820
  27425   "RTN","CHM FAUT1",93, 0)
  27426    ...S MOD4 =$P(INFO," ^",22) S:M OD4]"" MOD OUT=MODOUT _"*"_$$MOD ^CHMFAUT0( MOD4),MOD4 =$P($P(MOD OUT,"*",4) ,"^",1)                 ;JEH 2/1 /11 DEV007 820
  27427   "RTN","CHM FAUT1",94, 0)
  27428    ...S MODO UT=MOD_MOD 2_MOD3_MOD 4_"*"_MODO UT ;JEH 2/ 1/11 DEV00 7820
  27429   "RTN","CHM FAUT1",95, 0)
  27430    ...S:$P(M ODOUT,"*", 1)="" MODO UT="" ;JEH  2/1/11 DE V007820
  27431   "RTN","CHM FAUT1",96, 0)
  27432    ...; S CP T=$P(INFO, "^",7) S:C PT]"" CPTO UT=$$PROC^ CHMFAUT0(C PT,DOS)                  ;JSG;OC
  27433   "RTN","CHM FAUT1",97, 0)
  27434    ...D:$G(% )="" NOW^% DTC ;JEH 8 /29/08 TT  #DEV005596   ADDED LI NE
  27435   "RTN","CHM FAUT1",98, 0)
  27436    ...S CPT= $P(INFO,"^ ",7) S:CPT ]"" CPTOUT ="SV*"_$$P ROC^CHMFAU T0(CPT,$S( DOS]"":DOS ,1:%\1)) ; JSG;NC;Fak e DOS to g et Procedu re            ;JEH 2/ 1/11 DEV00 7820
  27437   "RTN","CHM FAUT1",99, 0)
  27438    ...S REV= $P(INFO,"^ ",14) S:RE V]"" REVOU T=$$REV^CH MFAUT0(REV )
  27439   "RTN","CHM FAUT1",100 ,0)
  27440    ...S EDIL ID=$P(INFO ,"^",16) ; JEH 2/1/11  DEV007820
  27441   "RTN","CHM FAUT1",101 ,0)
  27442    ...S UNT= $P(INFO,"^ ",17)
  27443   "RTN","CHM FAUT1",102 ,0)
  27444    ...S MEDP YMT=$P(INF O,"^",18)
  27445   "RTN","CHM FAUT1",103 ,0)
  27446    ...S BENP YMT=$P(INF O,"^",6)
  27447   "RTN","CHM FAUT1",104 ,0)
  27448    ...S (OHI PDAMT,OHIP RESP,ADDOH IPY,OHIPRB AL,MEDICDP D,TPLPAID, COSTUNT,NM UNTALL,CAL LDAMT,DEDC TAMT,CSTSH AMT,PYMNTA MT,PATPDAM T,CCAPLAMT )="" ;JEH  2/1/11 DEV 007820
  27449   "RTN","CHM FAUT1",105 ,0)
  27450    ...S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT                                       JEH 2/1/ 11 DEV0078 20
  27451   "RTN","CHM FAUT1",106 ,0)
  27452    ...S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y              JEH 2/ 1/11 DEV00 7820
  27453   "RTN","CHM FAUT1",107 ,0)
  27454    ...S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS    JEH  2/1/11 DEV 007820
  27455   "RTN","CHM FAUT1",108 ,0)
  27456    ...S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE                                     JEH 2/1/ 11 DEV0078 20
  27457   "RTN","CHM FAUT1",109 ,0)
  27458    ...S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID                                       JEH 2/1/ 11 DEV0078 20
  27459   "RTN","CHM FAUT1",110 ,0)
  27460    ...S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D                                                   JE H 2/1/11 D EV007820
  27461   "RTN","CHM FAUT1",111 ,0)
  27462    ...S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT                                                  JE H 2/1/11 D EV007820
  27463   "RTN","CHM FAUT1",112 ,0)
  27464    ...S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED                                    JEH 2/1/ 11 DEV0078 20
  27465   "RTN","CHM FAUT1",113 ,0)
  27466    ...S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT                JEH 2/ 1/11 DEV00 7820
  27467   "RTN","CHM FAUT1",114 ,0)
  27468    ...S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT                                 JEH 2/1/ 11 DEV0078 20
  27469   "RTN","CHM FAUT1",115 ,0)
  27470    ...S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT                                     JEH 2/1/ 11 DEV0078 20
  27471   "RTN","CHM FAUT1",116 ,0)
  27472    ...S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT                                     JEH 2/1/ 11 DEV0078 20
  27473   "RTN","CHM FAUT1",117 ,0)
  27474    ...S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T                                  JEH 2/1/ 11 DEV0078 20
  27475   "RTN","CHM FAUT1",118 ,0)
  27476    ...S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT                      JEH 2/ 1/11 DEV00 7820
  27477   "RTN","CHM FAUT1",119 ,0)
  27478    ...S ADIS TRO=$P(^CH MIMAGE(CHM FPDI1,0)," ^",16) ;AU TO DISTRIB UTION  JEH  2/1/11 DE V007820
  27479   "RTN","CHM FAUT1",120 ,0)
  27480    ...; I '$ L($G(DOS)) !'$G(POS)  W !,"*** D OS or POS  missing! * **" H 5 Q  ;JSG;OC;Do n't need
  27481   "RTN","CHM FAUT1",121 ,0)
  27482    ...I DOS] "" D           ;JSG;N C;We only  want to do  this sect ion if DOS  originall y not ""
  27483   "RTN","CHM FAUT1",122 ,0)
  27484    ....S:'$D (CHHOLDPY( DOS,POS))  CHHOLDPY(D OS,POS)=""
  27485   "RTN","CHM FAUT1",123 ,0)
  27486    ....I MED PYMT'="" D
  27487   "RTN","CHM FAUT1",124 ,0)
  27488    .....S $P (CHHOLDPY( DOS,POS)," ^",1)=$P(C HHOLDPY(DO S,POS),"^" ,1)+MEDPYM T
  27489   "RTN","CHM FAUT1",125 ,0)
  27490    ....;I BE NPYMT'=""  I BENPYMT  D     ;JEH  2/1/11 DE V007820
  27491   "RTN","CHM FAUT1",126 ,0)
  27492    ....I BEN PYMT'="" D         ;J EH 2/1/11  DEV007820
  27493   "RTN","CHM FAUT1",127 ,0)
  27494    .....S $P (CHHOLDPY( DOS,POS)," ^",2)=$P(C HHOLDPY(DO S,POS),"^" ,2)+BENPYM T
  27495   "RTN","CHM FAUT1",128 ,0)
  27496    ....S PRA MOUNT=""     ;SKD 9-2 7-07 DEV00 3378
  27497   "RTN","CHM FAUT1",129 ,0)
  27498    ....I $P( CHHOLDPY(D OS,POS),"^ ",3)="" I  VFN'="" I  $D(^CHMIMA GE(CHMFPDI 1,"ZOHI",D FN,BFN,CHM FSERV,DOS, POS,VFN))  D
  27499   "RTN","CHM FAUT1",130 ,0)
  27500    .....;S O HIPYMT=^CH MIMAGE(CHM FPDI1,"ZOH I",DFN,BFN ,CHMFSERV, DOS,POS,VF N)  ;SKD M C284 12-15 -06
  27501   "RTN","CHM FAUT1",131 ,0)
  27502    .....S PR AMOUNT=$P( $G(^CHMIMA GE(CHMFPDI 1,"ZOHI",D FN,BFN,CHM FSERV,DOS, POS,VFN)), U,2)  ;SKD  MC284 12- 15-06
  27503   "RTN","CHM FAUT1",132 ,0)
  27504    .....;S $ P(CHHOLDPY (DOS,POS), "^",3)=$FN (OHIPYMT," ",2)   ;SK D MC284 12 -15-06
  27505   "RTN","CHM FAUT1",133 ,0)
  27506    .....I $G (PRAMOUNT)  S $P(CHHO LDPY(DOS,P OS),"^",3) =$FN(PRAMO UNT,"",2)    ;SKD MC2 84 12-15-0 6
  27507   "RTN","CHM FAUT1",134 ,0)
  27508    ...I TPLP AID'="" I  TPLPAID D
  27509   "RTN","CHM FAUT1",135 ,0)
  27510    ....S $P( CHHOLDPY(D OS,POS),"^ ",4)=$P(CH HOLDPY(DOS ,POS),"^", 4)+TPLPAID
  27511   "RTN","CHM FAUT1",136 ,0)
  27512    ... ;
  27513   "RTN","CHM FAUT1",137 ,0)
  27514    ... ;  Do  not outpu t line if  it has nei ther diagn osis (ICD)  nor reven ue code (R EV) - wtc  8/10/17
  27515   "RTN","CHM FAUT1",138 ,0)
  27516    ... ;
  27517   "RTN","CHM FAUT1",139 ,0)
  27518    ... I ICD '=""!(REV' ="")!(CPT' ="") D  ;
  27519   "RTN","CHM FAUT1",140 ,0)
  27520    ....S L=L +1 D PREOU TL^CHMFAUT 1 ; Increm ent L wtc  8/8/17
  27521   "RTN","CHM FAUT1",141 ,0)
  27522    ....S SVL =L       ; JEH 2/1/11  DEV007820
  27523   "RTN","CHM FAUT1",142 ,0)
  27524    ...Q
  27525   "RTN","CHM FAUT1",143 ,0)
  27526    ;OUTPATIE NT PHARMAC Y DATA  ;J EH 2/1/11  DEV007820
  27527   "RTN","CHM FAUT1",144 ,0)
  27528    Q:SVL=""
  27529   "RTN","CHM FAUT1",145 ,0)
  27530    S L=""
  27531   "RTN","CHM FAUT1",146 ,0)
  27532    N RXDOS ;  
  27533   "RTN","CHM FAUT1",147 ,0)
  27534    S RXDOS=" ",D3=0,L=S VL ; wtc 8 /8/17
  27535   "RTN","CHM FAUT1",148 ,0)
  27536    K ^TMP($J ) ;
  27537   "RTN","CHM FAUT1",149 ,0)
  27538    ;
  27539   "RTN","CHM FAUT1",150 ,0)
  27540    ;  wtc 8/ 8/17
  27541   "RTN","CHM FAUT1",151 ,0)
  27542    ;  
  27543   "RTN","CHM FAUT1",152 ,0)
  27544    ;  "B" cr oss-refere nce at "RX -NS" multi ple is not  being cre ated when  image file  is create d
  27545   "RTN","CHM FAUT1",153 ,0)
  27546    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  27547   "RTN","CHM FAUT1",154 ,0)
  27548    ;
  27549   "RTN","CHM FAUT1",155 ,0)
  27550    I $G(CHMF PDI) F  S  D3=$O(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"RX- NS",D3)) Q :D3=""  D   ; wtc 8/8 /17
  27551   "RTN","CHM FAUT1",156 ,0)
  27552    . S RXDOS =$P($G(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"RX -NS",D3,0) ),"^",1) ;
  27553   "RTN","CHM FAUT1",157 ,0)
  27554    . S ^TMP( $J,RXDOS,D 3,CHMFPDI) =""
  27555   "RTN","CHM FAUT1",158 ,0)
  27556    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  27557   "RTN","CHM FAUT1",159 ,0)
  27558    I $G(CHMO PDI),$G(CH MOPGNM),$G (CHMOIMAG) ,$E($P($G( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN")),"^ ",7),3)=5  F  S D3=$O (^CHMIMAGE (CHMOPDI,1 ,CHMOPGNM, 2,CHMOIMAG ,"RX-NS",D 3)) Q:D3=" "  D
  27559   "RTN","CHM FAUT1",160 ,0)
  27560    . S RXDOS =$P($G(^CH MIMAGE(CHM OPDI,1,CHM OPGNM,2,CH MOIMAG,"RX -NS",D3,0) ),"^",1) ;
  27561   "RTN","CHM FAUT1",161 ,0)
  27562    . S ^TMP( $J,RXDOS,D 3,CHMOPDI) =""
  27563   "RTN","CHM FAUT1",162 ,0)
  27564    ;
  27565   "RTN","CHM FAUT1",163 ,0)
  27566    S RXDOS=" " ;
  27567   "RTN","CHM FAUT1",164 ,0)
  27568    F  S RXDO S=$O(^TMP( $J,RXDOS))  Q:RXDOS=" "  D  ; wt c 8/8/17
  27569   "RTN","CHM FAUT1",165 ,0)
  27570    . S D3=""  F  S D3=$ O(^TMP($J, RXDOS,D3))  Q:D3=""   D  ; wtc 8 /8/17
  27571   "RTN","CHM FAUT1",166 ,0)
  27572    .. S D4=" " F  S D4= $O(^TMP($J ,RXDOS,D3, D4)) Q:D4= ""  D  ;bd b 8/15/201 76
  27573   "RTN","CHM FAUT1",167 ,0)
  27574    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  27575   "RTN","CHM FAUT1",168 ,0)
  27576    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=$G(CHMOP DI),CHMFPG N1=$G(CHMO PGNM),CHMF IMA1=$G(CH MOIMAG)
  27577   "RTN","CHM FAUT1",169 ,0)
  27578    ...S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  27579   "RTN","CHM FAUT1",170 ,0)
  27580    ...S (DOA OUT,DODOUT ,POSOUT,IC DOUT,DSTAT OUT,EDILID )=""       ;JEH 2/1/1 1 DEV00782 0
  27581   "RTN","CHM FAUT1",171 ,0)
  27582    ...S INFO =$G(^CHMIM AGE(CHMFPD I1,1,CHMFP GN1,2,CHMF IMA1,"RX-N S",D3,0))  ; wtc chan ged L to D 3 8/8/17
  27583   "RTN","CHM FAUT1",172 ,0)
  27584    ...S INFO 2=$G(^CHMI MAGE(CHMFP DI1,1,CHMF PGN1,2,CHM FIMA1,"RX- NS",D3,1,1 ,0)) ; wtc  changed L  to D3 8/8 /17
  27585   "RTN","CHM FAUT1",173 ,0)
  27586    ...Q:INFO =""&(INFO2 ="")    ;J EH 2/1/11  DEV007820
  27587   "RTN","CHM FAUT1",174 ,0)
  27588    ...S SPBE N=$P(INFO, "^",2)_"/" _$P(INFO," ^",3)
  27589   "RTN","CHM FAUT1",175 ,0)
  27590    ...S SPON =$P(INFO," ^",2),BEN= $P(INFO,"^ ",3)
  27591   "RTN","CHM FAUT1",176 ,0)
  27592    ...S DOS= $P(INFO,"^ ",1) S:DOS ]"" DOSOUT =$$DOS^CHM FAUT0(DOS)
  27593   "RTN","CHM FAUT1",177 ,0)
  27594    ...S ICD= $P(INFO,"^ ",11) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  27595   "RTN","CHM FAUT1",178 ,0)
  27596    ...S:ICDO UT]"" ICDO UT=$P(ICDO UT,"^")_"^ "_$P(ICDOU T,"^",2)
  27597   "RTN","CHM FAUT1",179 ,0)
  27598    ...S EDIL ID=$P(INFO ,"^",6)          ;JEH  2/1/11 DE V007820
  27599   "RTN","CHM FAUT1",180 ,0)
  27600    ...S CHG= $P(INFO,"^ ",8)
  27601   "RTN","CHM FAUT1",181 ,0)
  27602    ...S PDX= $P(INFO,"^ ",7) S:PDX ]"" CPTOUT =$$PDX^CHM FAUT0(PDX)
  27603   "RTN","CHM FAUT1",182 ,0)
  27604    ...S CPTO UT="RX*"_$ E(CPTOUT,1 ,13)_"^"_$ P(CPTOUT," ^",2)_"^"_ $E(CPTOUT, 17,$L($P(C PTOUT,"^", 1)))
  27605   "RTN","CHM FAUT1",183 ,0)
  27606    ...S UNT= $P(INFO,"^ ",12)                   ;UNT IS  SAME AS QT Y FOR PHAR MACY
  27607   "RTN","CHM FAUT1",184 ,0)
  27608    ...S (OHI PDAMT,OHIP RESP,ADDOH IPY,OHIPRB AL,MEDICDP D,TPLPAID, COSTUNT)=" "   ;JEH 2 /1/11 DEV0 07820
  27609   "RTN","CHM FAUT1",185 ,0)
  27610    ...S (NMU NTALL,CALL DAMT,DEDCT AMT,CSTSHA MT,PYMNTAM T,PATPDAMT ,CCAPLAMT, ADISTRO)=" " ;JEH 2/1 /11 DEV007 820
  27611   "RTN","CHM FAUT1",186 ,0)
  27612    ...S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT
  27613   "RTN","CHM FAUT1",187 ,0)
  27614    ...S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y
  27615   "RTN","CHM FAUT1",188 ,0)
  27616    ...S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS
  27617   "RTN","CHM FAUT1",189 ,0)
  27618    ...S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE
  27619   "RTN","CHM FAUT1",190 ,0)
  27620    ...S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID
  27621   "RTN","CHM FAUT1",191 ,0)
  27622    ...S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D
  27623   "RTN","CHM FAUT1",192 ,0)
  27624    ...S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT
  27625   "RTN","CHM FAUT1",193 ,0)
  27626    ...S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED
  27627   "RTN","CHM FAUT1",194 ,0)
  27628    ...S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT
  27629   "RTN","CHM FAUT1",195 ,0)
  27630    ...S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT
  27631   "RTN","CHM FAUT1",196 ,0)
  27632    ...S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT
  27633   "RTN","CHM FAUT1",197 ,0)
  27634    ...S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT
  27635   "RTN","CHM FAUT1",198 ,0)
  27636    ...S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T
  27637   "RTN","CHM FAUT1",199 ,0)
  27638    ...S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT
  27639   "RTN","CHM FAUT1",200 ,0)
  27640    ...S ADIS TRO=$P(^CH MIMAGE(CHM FPDI1,0)," ^",16) ;AU TO DISTRIB UTION  JEH  2/1/11 DE V007820
  27641   "RTN","CHM FAUT1",201 ,0)
  27642    .. ;
  27643   "RTN","CHM FAUT1",202 ,0)
  27644    .. ; disa bled lines  re: FORL.   Changed  how L is s et.
  27645   "RTN","CHM FAUT1",203 ,0)
  27646    .. ; wtc  8/8/17
  27647   "RTN","CHM FAUT1",204 ,0)
  27648    .. ;
  27649   "RTN","CHM FAUT1",205 ,0)
  27650    ..;S FORL =L
  27651   "RTN","CHM FAUT1",206 ,0)
  27652    ..;S L=L+ SVL
  27653   "RTN","CHM FAUT1",207 ,0)
  27654    ..S L=L+1  D PREOUTL ^CHMFAUT1
  27655   "RTN","CHM FAUT1",208 ,0)
  27656    ..;S L=FO RL
  27657   "RTN","CHM FAUT1",209 ,0)
  27658    ..Q
  27659   "RTN","CHM FAUT1",210 ,0)
  27660    S FORL=L  ;  wtc 8/8 /17
  27661   "RTN","CHM FAUT1",211 ,0)
  27662    Q
  27663   "RTN","CHM FAUT1",212 ,0)
  27664    ;
  27665   "RTN","CHM FAUT1",213 ,0)
  27666   PREOUTL ;   Load outp atient pro cedure int o ^UTILITY
  27667   "RTN","CHM FAUT1",214 ,0)
  27668    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,0)=L
  27669   "RTN","CHM FAUT1",215 ,0)
  27670    ;added af ter refres h ; ajf
  27671   "RTN","CHM FAUT1",216 ,0)
  27672    I CHMFPDI 1=CHMOPDI  S $P(^UTIL ITY($J,"CH DME",SPBEN ,L,0),"^", 2)=1
  27673   "RTN","CHM FAUT1",217 ,0)
  27674    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,1)=DOSOUT
  27675   "RTN","CHM FAUT1",218 ,0)
  27676    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,2)=POSOUT
  27677   "RTN","CHM FAUT1",219 ,0)
  27678    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,3)=ICDOUT
  27679   "RTN","CHM FAUT1",220 ,0)
  27680    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,4)=REVOUT
  27681   "RTN","CHM FAUT1",221 ,0)
  27682    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,5)=CPTOUT
  27683   "RTN","CHM FAUT1",222 ,0)
  27684    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,6)=MODOUT
  27685   "RTN","CHM FAUT1",223 ,0)
  27686    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,8)=CHG
  27687   "RTN","CHM FAUT1",224 ,0)
  27688    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,7)=UNT
  27689   "RTN","CHM FAUT1",225 ,0)
  27690    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,9)=""  ;A EB 10/27/2 010 DEV007 820
  27691   "RTN","CHM FAUT1",226 ,0)
  27692    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,10)=OHIPD AMT   ;AEB  10/27/201 0 DEV00782 0 prim ohi  pd
  27693   "RTN","CHM FAUT1",227 ,0)
  27694    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,11)=OHIPR ESP   ;AEB  10/27/201 0 DEV00782 0 prim ohi  pr
  27695   "RTN","CHM FAUT1",228 ,0)
  27696    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,12)=ADDOH IPY   ;AEB  10/27/201 0 DEV00782 0 add ohi  pd
  27697   "RTN","CHM FAUT1",229 ,0)
  27698    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,13)=PATPD AMT   ;AEB  10/27/201 0 DEV00782 0 bene pd
  27699   "RTN","CHM FAUT1",230 ,0)
  27700    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,14)=MEDIC DPD   ;AEB  10/27/201 0 DEV00782 0 medicad
  27701   "RTN","CHM FAUT1",231 ,0)
  27702    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,15)=TPLPA ID    ;AEB  10/27/201 0 DEV00782 0 tpl
  27703   "RTN","CHM FAUT1",232 ,0)
  27704    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,16)=OHIPR BAL   ;JEH  2/1/2011  DEV007820  p/r bal
  27705   "RTN","CHM FAUT1",233 ,0)
  27706    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,17)=ADIST RO    ;JEH  2/1/2011  DEV007820  auto calc  flag
  27707   "RTN","CHM FAUT1",234 ,0)
  27708    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,18)=EDILI D     ;JEH  2/1/2011  DEV007820  edi line i dentifier
  27709   "RTN","CHM FAUT1",235 ,0)
  27710    I (ICDOUT ="")&(CPTO UT="")&(RE VOUT="") S  ^UTILITY( $J,"CHDME" ,SPBEN,L,2 )=""
  27711   "RTN","CHM FAUT1",236 ,0)
  27712    Q
  27713   "RTN","CHM FAUT1",237 ,0)
  27714   PREIPT ;
  27715   "RTN","CHM FAUT1",238 ,0)
  27716    D TPREIPT ^CHMFAUT8  Q  ;HM 8/1 7/2017 TES T cpe005-0 09 Inpatie nt
  27717   "RTN","CHM FAUT1",239 ,0)
  27718    N L,INFO, SPON,BEN,D OA,DOD,DOA 2,DSTAT,TC HG,ICD,POS ,BENPYMT,M EDPYMT
  27719   "RTN","CHM FAUT1",240 ,0)
  27720    N DOAOUT, DODOUT,ICD OUT,DSTATO UT,POSOUT, PRAMOUNT      ;SKD 9- 27-07 DEV0 03378
  27721   "RTN","CHM FAUT1",241 ,0)
  27722    N CHAOPD, CHPOPD,CHT PTY,CHPRPA Y,CHPRBL,E DILID  ;JE H 2/1/11 D EV007820
  27723   "RTN","CHM FAUT1",242 ,0)
  27724    K CHMFINP
  27725   "RTN","CHM FAUT1",243 ,0)
  27726    S L=""
  27727   "RTN","CHM FAUT1",244 ,0)
  27728    F  S L=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L)) Q:L=""   D
  27729   "RTN","CHM FAUT1",245 ,0)
  27730    .S (DOAOU T,DODOUT,P OSOUT,ICDO UT,DSTATOU T,DOA2OUT) =""
  27731   "RTN","CHM FAUT1",246 ,0)
  27732    .S INFO=$ G(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"INP-NS" ,L,0))
  27733   "RTN","CHM FAUT1",247 ,0)
  27734    .Q:INFO=" "
  27735   "RTN","CHM FAUT1",248 ,0)
  27736    .S SPON=$ P(INFO,"^" ,1),BEN=$P (INFO,"^", 2)
  27737   "RTN","CHM FAUT1",249 ,0)
  27738    .S DOA=$P (INFO,"^", 4) S Y=DOA  D DD^%DT  I Y'="" S  DOAOUT=Y_" ^"_DOA  ;A EB DEF0042 37
  27739   "RTN","CHM FAUT1",250 ,0)
  27740    .S DOD=$P (INFO,"^", 5) S Y=DOD  D DD^%DT  I Y'="" S  DODOUT=Y_" ^"_DOD
  27741   "RTN","CHM FAUT1",251 ,0)
  27742    .S DOA2=$ P(INFO,"^" ,16) S Y=D OA2 D DD^% DT I Y'=""  S DOA2OUT =Y_"^"_DOA 2
  27743   "RTN","CHM FAUT1",252 ,0)
  27744    .S DSTAT= $P(INFO,"^ ",6)
  27745   "RTN","CHM FAUT1",253 ,0)
  27746    .S:DSTAT] "" DSTATOU T=$$DSTAT^ CHMFAUT0(D STAT)
  27747   "RTN","CHM FAUT1",254 ,0)
  27748    .S TCHG=$ P(INFO,"^" ,10)
  27749   "RTN","CHM FAUT1",255 ,0)
  27750    .S ICD=$P (INFO,"^", 7)
  27751   "RTN","CHM FAUT1",256 ,0)
  27752    .S:ICD]""  ICD=$$ICD ^CHMFAUT0( ICD)
  27753   "RTN","CHM FAUT1",257 ,0)
  27754    .S ICDOUT =$P(ICD,"^ ")_"^"_$P( ICD,"^",3) _"^"_$P(IC D,"^",2)
  27755   "RTN","CHM FAUT1",258 ,0)
  27756    .S POS=$P (INFO,"^", 11) S:POS= "" POS=1
  27757   "RTN","CHM FAUT1",259 ,0)
  27758    .S:POS]""  POS=$$POS ^CHMFAUT0( POS)
  27759   "RTN","CHM FAUT1",260 ,0)
  27760    .S POSOUT =$P(POS,"^ ")_"^"_$P( POS,"^",3) _"^"_$P(PO S,"^",2)
  27761   "RTN","CHM FAUT1",261 ,0)
  27762    .S FAC=$P (INFO,"^", 14)
  27763   "RTN","CHM FAUT1",262 ,0)
  27764    .; The $$ FAC line t ag does no t exist in  routine C HMFAUT0 an d the 14th  piece is  not Facili ty anyway,  it is a y es/no fiel d
  27765   "RTN","CHM FAUT1",263 ,0)
  27766    .;S:FAC]" " FAC=$$FA C^CHMFAUT0 (FAC)
  27767   "RTN","CHM FAUT1",264 ,0)
  27768    .S FACOUT =$P(FAC,"^ ")_$P(FAC, "^",3)_$P( FAC,"^",2)
  27769   "RTN","CHM FAUT1",265 ,0)
  27770    .S MEDPYM T=$P(INFO, "^",19)
  27771   "RTN","CHM FAUT1",266 ,0)
  27772    .S CHTPTY =$P(INFO," ^",20)  ;T HIRD PARTY  PAYMENT   ;JEH 2/1/1 1 DEV00782 0
  27773   "RTN","CHM FAUT1",267 ,0)
  27774    .S CHPOPD =$P(INFO," ^",21)  ;P RIMARY OHI  PAID  ;JE H 2/1/11 D EV007820
  27775   "RTN","CHM FAUT1",268 ,0)
  27776    .S CHAOPD =$P(INFO," ^",22)  ;A DD'L OHIs  PAID  ;JEH  2/1/11 DE V007820
  27777   "RTN","CHM FAUT1",269 ,0)
  27778    .S CHPRPA Y=$P(INFO, "^",23)  ; P/R PAY (O HI)  ;JEH  2/1/11 DEV 007820
  27779   "RTN","CHM FAUT1",270 ,0)
  27780    .S CHPRBL =$P(INFO," ^",24)  ;P /R BALLANC E(OHI)  ;J EH 2/1/11  DEV007820
  27781   "RTN","CHM FAUT1",271 ,0)
  27782    .S BENPYM T=$P(INFO, "^",13)
  27783   "RTN","CHM FAUT1",272 ,0)
  27784    .S OHIPYM T=""
  27785   "RTN","CHM FAUT1",273 ,0)
  27786    .S PRAMOU NT=""   ;S KD 9-27-07  DEV003378
  27787   "RTN","CHM FAUT1",274 ,0)
  27788    .I VFN'=" ",DOA'="", $D(^CHMIMA GE(CHMFPDI ,"ZOHI",DF N,BFN,CHMF SERV,DOA,V FN)) D  ;J SG;3/14/08 ;DEV004525 -01
  27789   "RTN","CHM FAUT1",275 ,0)
  27790    ..;S OHIP YMT=^CHMIM AGE(CHMFPD I,"ZOHI",D FN,BFN,CHM FSERV,DOA, VFN)   ;SK D MC284 12 -15-06
  27791   "RTN","CHM FAUT1",276 ,0)
  27792    ..S PRAMO UNT=$P($G( ^CHMIMAGE( CHMFPDI,"Z OHI",DFN,B FN,CHMFSER V,DOA,VFN) ),U,2)     ;SKD MC284  12-15-06
  27793   "RTN","CHM FAUT1",277 ,0)
  27794    .E  S PRA MOUNT=CHPR PAY  ;JEH  2/1/11 DEV 007820
  27795   "RTN","CHM FAUT1",278 ,0)
  27796    .D PREIPT L1
  27797   "RTN","CHM FAUT1",279 ,0)
  27798    .D PREIPT L2
  27799   "RTN","CHM FAUT1",280 ,0)
  27800    .D PREIPT L3
  27801   "RTN","CHM FAUT1",281 ,0)
  27802    .D PREIPT L4
  27803   "RTN","CHM FAUT1",282 ,0)
  27804    .Q
  27805   "RTN","CHM FAUT1",283 ,0)
  27806    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if type o f bill = 1 35/freq co de=5
  27807   "RTN","CHM FAUT1",284 ,0)
  27808    ;I '$G(CH MOPDI) S C HMOPDI=$P( $G(^CHMIMA GE(CHMFPDI ,202)),"^" ,1) ;BDB 8 /14/17
  27809   "RTN","CHM FAUT1",285 ,0)
  27810    ;S:$E($P( $G(^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"VEN")) ,"^",7),3) =5 L=$$LAT E^CHMFAUT5 (CHMFPDI,$ G(CHMOPDI) ,CHMFSRVC, $G(SPBEN), L)
  27811   "RTN","CHM FAUT1",286 ,0)
  27812    Q
  27813   "RTN","CHM FAUT1",287 ,0)
  27814   PREIPTL1 ;  Load "INP ","MED", a nd "PAY" i nto CHMFIN P array
  27815   "RTN","CHM FAUT1",288 ,0)
  27816    S CHMFINP (SPON,BEN, "INP",1)=D OAOUT
  27817   "RTN","CHM FAUT1",289 ,0)
  27818    S CHMFADD A=$P(DOAOU T,"^",2)
  27819   "RTN","CHM FAUT1",290 ,0)
  27820    S CHMFINP (SPON,BEN, "INP",2)=D ODOUT
  27821   "RTN","CHM FAUT1",291 ,0)
  27822    S CHMFDSD T=$P(DODOU T,"^",2)
  27823   "RTN","CHM FAUT1",292 ,0)
  27824    S CHMFINP (SPON,BEN, "INP",3)=D STATOUT
  27825   "RTN","CHM FAUT1",293 ,0)
  27826    S CHMFINP (SPON,BEN, "INP",4)=P OSOUT
  27827   "RTN","CHM FAUT1",294 ,0)
  27828    S CHMFINP (SPON,BEN, "INP",5)=I CDOUT
  27829   "RTN","CHM FAUT1",295 ,0)
  27830    S CHMFINP (SPON,BEN, "INP",6)=T CHG
  27831   "RTN","CHM FAUT1",296 ,0)
  27832    S CHMFINP (SPON,BEN, "INP",7)=" "
  27833   "RTN","CHM FAUT1",297 ,0)
  27834    S CHMFINP (SPON,BEN, "INP",8)=" "
  27835   "RTN","CHM FAUT1",298 ,0)
  27836    S CHMFINP (SPON,BEN, "INP",9)=" "
  27837   "RTN","CHM FAUT1",299 ,0)
  27838    S CHMFINP (SPON,BEN, "INP",10)= ""
  27839   "RTN","CHM FAUT1",300 ,0)
  27840    S CHMFINP (SPON,BEN, "INP",11)= DOA2OUT
  27841   "RTN","CHM FAUT1",301 ,0)
  27842    S CHMFINP (SPON,BEN, "MED")=MED PYMT
  27843   "RTN","CHM FAUT1",302 ,0)
  27844    S CHMFINP (SPON,BEN, "PAY")=BEN PYMT
  27845   "RTN","CHM FAUT1",303 ,0)
  27846    S CHMFINP (SPON,BEN, "TPTY")=CH TPTY  ;JEH  2/1/11 DE V007820
  27847   "RTN","CHM FAUT1",304 ,0)
  27848    S CHMFINP (SPON,BEN, "POPD")=CH POPD  ;JEH  2/1/11 DE V007820
  27849   "RTN","CHM FAUT1",305 ,0)
  27850    S CHMFINP (SPON,BEN, "AOPD")=CH AOPD  ;JEH  2/1/11 DE V007820
  27851   "RTN","CHM FAUT1",306 ,0)
  27852    S CHMFINP (SPON,BEN, "PRPY")=CH PRPAY  ;JE H 2/1/11 D EV007820
  27853   "RTN","CHM FAUT1",307 ,0)
  27854    S CHMFINP (SPON,BEN, "PRBL")=CH PRBL  ;JEH  2/1/11 DE V007820
  27855   "RTN","CHM FAUT1",308 ,0)
  27856    ;S CHMFIN P(SPON,BEN ,"OHI")=OH IPYMT  ;SK D MC284 12 -15-06
  27857   "RTN","CHM FAUT1",309 ,0)
  27858    S CHMFINP (SPON,BEN, "OHI")=""   ;SKD MC28 4 12-15-06
  27859   "RTN","CHM FAUT1",310 ,0)
  27860    I $G(PRAM OUNT) S CH MFINP(SPON ,BEN,"OHI" )=PRAMOUNT   ;SKD MC2 84 12-15-0 6
  27861   "RTN","CHM FAUT1",311 ,0)
  27862    Q
  27863   "RTN","CHM FAUT1",312 ,0)
  27864   PREIPTL2 ; Loads "ICD " into CHM FINP array
  27865   "RTN","CHM FAUT1",313 ,0)
  27866    N M,ICD,I CDOUT S M= ""
  27867   "RTN","CHM FAUT1",314 ,0)
  27868    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,100,M))  Q:M=""  D
  27869   "RTN","CHM FAUT1",315 ,0)
  27870    .S ICD=$P (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,100,M,0) ,"^",1)
  27871   "RTN","CHM FAUT1",316 ,0)
  27872    .S CHPOA= $P(^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"INP-NS ",L,100,M, 0),"^",2)   ;AEB 1/20 /2010 DEV0 04805
  27873   "RTN","CHM FAUT1",317 ,0)
  27874    .S:ICD]""  ICD=$$ICD ^CHMFAUT0( ICD)
  27875   "RTN","CHM FAUT1",318 ,0)
  27876    .S:$P(ICD ,"^",1)=""  $P(ICDOUT ,"^",6)="Y "     ;SET  IP SCREEN  FLAG FOR  ICD CODE       ;DEV01 2072 JEH 1 0/5/11 - a dd icd che ck
  27877   "RTN","CHM FAUT1",319 ,0)
  27878    .S ICDOUT =$P(ICD,"^ ")_"^"_$P( ICD,"^",3) _"^"_$P(IC D,"^",2)_" ^^"_CHPOA   ;AEB 1/20 /2010 DEV0 04805
  27879   "RTN","CHM FAUT1",320 ,0)
  27880    .S CHMFIN P(SPON,BEN ,"ICD",M)= ICDOUT
  27881   "RTN","CHM FAUT1",321 ,0)
  27882    .S CHMFIN P(SPON,BEN ,"INP",7)= "Y"
  27883   "RTN","CHM FAUT1",322 ,0)
  27884    .S:$P(CHM FINP(SPON, BEN,"ICD", M),"^",1)= "" $P(CHMF INP(SPON,B EN,"INP",7 ),"^",2)=" Y"     ;SE T IP SCREE N FLAG FOR  ICD CODE       ;DEV0 12072 JEH  10/5/11 -  add icd ch eck
  27885   "RTN","CHM FAUT1",323 ,0)
  27886    .Q
  27887   "RTN","CHM FAUT1",324 ,0)
  27888    Q
  27889   "RTN","CHM FAUT1",325 ,0)
  27890   PREIPTL3 ; Loads "PRO C" into CH MFINP arra y
  27891   "RTN","CHM FAUT1",326 ,0)
  27892    N M,CPT,C PTOUT S M= ""
  27893   "RTN","CHM FAUT1",327 ,0)
  27894    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,101,M))  Q:M=""  D
  27895   "RTN","CHM FAUT1",328 ,0)
  27896    .S CPT=^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"I NP-NS",L,1 01,M,0)
  27897   "RTN","CHM FAUT1",329 ,0)
  27898    .S:CPT]""  CPT=$$PRO C^CHMFAUT0 (CPT,DOA)
  27899   "RTN","CHM FAUT1",330 ,0)
  27900    .S CPTOUT =$P(CPT,"^ ")_"^"_$P( CPT,"^",3) _"^"_$P(CP T,"^",2)
  27901   "RTN","CHM FAUT1",331 ,0)
  27902    .S CHMFIN P(SPON,BEN ,"PROC",M) =CPTOUT
  27903   "RTN","CHM FAUT1",332 ,0)
  27904    .S CHMFIN P(SPON,BEN ,"INP",8)= "Y"
  27905   "RTN","CHM FAUT1",333 ,0)
  27906    .Q
  27907   "RTN","CHM FAUT1",334 ,0)
  27908    Q
  27909   "RTN","CHM FAUT1",335 ,0)
  27910   PREIPTL4 ; Loads "REV " into CHM FINP array
  27911   "RTN","CHM FAUT1",336 ,0)
  27912    N N,REV,R EVOUT,EDIL ID S M="", EDILID=""   ;JEH 2/1/ 11 DEV0078 20
  27913   "RTN","CHM FAUT1",337 ,0)
  27914    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,102,M))  Q:M=""  D
  27915   "RTN","CHM FAUT1",338 ,0)
  27916    .S REV=^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"I NP-NS",L,1 02,M,0)
  27917   "RTN","CHM FAUT1",339 ,0)
  27918    .S:REV]""  REV=$$REV ^CHMFAUT0( REV)
  27919   "RTN","CHM FAUT1",340 ,0)
  27920    .S EDILID =$P(^CHMIM AGE(CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"INP-N S",L,102,M ,0),"^",3)   ;JEH 2/1 /11 DEV007 820
  27921   "RTN","CHM FAUT1",341 ,0)
  27922    .S REVOUT =$P(REV,"^ ")_"^"_$P( REV,"^",6) _"^"_$P(RE V,"^",2)_" ^^"_$P(REV ,"^",3)_"^ "_EDILID   ;JEH 2/1/1 1 DEV00782 0
  27923   "RTN","CHM FAUT1",342 ,0)
  27924    .S CHMFIN P(SPON,BEN ,"REV",M)= REVOUT
  27925   "RTN","CHM FAUT1",343 ,0)
  27926    .S CHMFIN P(SPON,BEN ,"INP",10) ="Y"
  27927   "RTN","CHM FAUT1",344 ,0)
  27928    .Q
  27929   "RTN","CHM FAUT1",345 ,0)
  27930    Q
  27931   "RTN","CHM FAUT1",346 ,0)
  27932   PREDME ;   Load DME p rocedures
  27933   "RTN","CHM FAUT1",347 ,0)
  27934    N L,INFO, DOS,POS,CH G,ICD,CPT, MEDPYMT,BE NPYMT,DELC HG,PL,SPBE N,SVL
  27935   "RTN","CHM FAUT1",348 ,0)
  27936    N PLOUT,D OSOUT,ICDO UT,CPTOUT, PRAMOUNT,A DISTRO,EDI LID   ;SKD  9-27-07 D EV003378   ;JEH 2/1/1 1 DEV00782 0
  27937   "RTN","CHM FAUT1",349 ,0)
  27938    N D3,DMED OS ; wtc 7 /26/17
  27939   "RTN","CHM FAUT1",350 ,0)
  27940    K ^UTILIT Y($J),^TMP ($J) ; wtc  7/27/17
  27941   "RTN","CHM FAUT1",351 ,0)
  27942    S (D3,DME DOS,SVL)=" ",L=0 ; wt c 7/26/17
  27943   "RTN","CHM FAUT1",352 ,0)
  27944    ;
  27945   "RTN","CHM FAUT1",353 ,0)
  27946    ;  wtc 7/ 27/17
  27947   "RTN","CHM FAUT1",354 ,0)
  27948    ;  
  27949   "RTN","CHM FAUT1",355 ,0)
  27950    ;  "B" cr oss-refere nce at "DM E-NS" mult iple is no t being cr eated when  image fil e is creat ed
  27951   "RTN","CHM FAUT1",356 ,0)
  27952    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  27953   "RTN","CHM FAUT1",357 ,0)
  27954    ;
  27955   "RTN","CHM FAUT1",358 ,0)
  27956    ;ajf ; 8/ 17/17 ; St ory005-004  ; Adding  current PD I with pre vious PDI
  27957   "RTN","CHM FAUT1",359 ,0)
  27958    I $G(CHMF PDI) F  S  D3=$O(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"DME -NS",D3))  Q:D3=""  D   ; wtc 8/ 8/17
  27959   "RTN","CHM FAUT1",360 ,0)
  27960    . S DMEDO S=$P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"D ME-NS",D3, 0)),"^",1)  ;
  27961   "RTN","CHM FAUT1",361 ,0)
  27962    . S ^TMP( $J,DMEDOS, D3,CHMFPDI )=""
  27963   "RTN","CHM FAUT1",362 ,0)
  27964    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  27965   "RTN","CHM FAUT1",363 ,0)
  27966    I $G(CHMO PDI),$G(CH MOPGNM),$G (CHMOIMAG) ,$E($P($G( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN")),"^ ",7),3)=5  D
  27967   "RTN","CHM FAUT1",364 ,0)
  27968    . F  S D3 =$O(^CHMIM AGE(CHMOPD I,1,CHMOPG NM,2,CHMOI MAG,"DME-N S",D3)) Q: D3=""  D
  27969   "RTN","CHM FAUT1",365 ,0)
  27970    ..S DMEDO S=$P($G(^C HMIMAGE(CH MOPDI,1,CH MOPGNM,2,C HMOIMAG,"D ME-NS",D3, 0)),"^",1)  ;
  27971   "RTN","CHM FAUT1",366 ,0)
  27972    ..S ^TMP( $J,DMEDOS, D3,CHMOPDI )="BOLD"
  27973   "RTN","CHM FAUT1",367 ,0)
  27974    ;
  27975   "RTN","CHM FAUT1",368 ,0)
  27976    ;
  27977   "RTN","CHM FAUT1",369 ,0)
  27978    S DMEDOS= "" ;
  27979   "RTN","CHM FAUT1",370 ,0)
  27980    F  S DMED OS=$O(^TMP ($J,DMEDOS )) Q:DMEDO S=""  D
  27981   "RTN","CHM FAUT1",371 ,0)
  27982    . S D3=""  F  S D3=$ O(^TMP($J, DMEDOS,D3) ) Q:D3=""   D
  27983   "RTN","CHM FAUT1",372 ,0)
  27984    .. S D4=" " F  S D4= $O(^TMP($J ,DMEDOS,D3 ,D4)) Q:D4 =""  D
  27985   "RTN","CHM FAUT1",373 ,0)
  27986    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  27987   "RTN","CHM FAUT1",374 ,0)
  27988    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=$G(CHMOP DI),CHMFPG N1=$G(CHMO PGNM),CHMF IMA1=$G(CH MOIMAG)
  27989   "RTN","CHM FAUT1",375 ,0)
  27990    ...S (PLO UT,DOSOUT, POSOUT,ICD OUT,REVOUT ,MODOUT,CP TOUT,EDILI D)=""
  27991   "RTN","CHM FAUT1",376 ,0)
  27992    ...S INFO =$G(^CHMIM AGE(CHMFPD I1,1,CHMFP GN1,2,CHMF IMA1,"DME- NS",D3,0))  ; change  L to D3 wt c 8/8/17
  27993   "RTN","CHM FAUT1",377 ,0)
  27994    ...S INFO 2=$G(^CHMI MAGE(CHMFP DI1,1,CHMF PGN1,2,CHM FIMA1,"DME -NS",D3,1, 1,0)) ;JEH  2/1/11 DE V007820 ;  change L t o D3 wtc 8 /8/17
  27995   "RTN","CHM FAUT1",378 ,0)
  27996    ...Q:INFO =""&(INFO2 ="")
  27997   "RTN","CHM FAUT1",379 ,0)
  27998    ...S SPBE N=$P(INFO, "^",2)_"/" _$P(INFO," ^",3)
  27999   "RTN","CHM FAUT1",380 ,0)
  28000    ...S DOS= $P(INFO,"^ ",1) S:DOS ]"" DOSOUT =$$DOS^CHM FAUT0(DOS)
  28001   "RTN","CHM FAUT1",381 ,0)
  28002    ...S CHG= $P(INFO,"^ ",8)
  28003   "RTN","CHM FAUT1",382 ,0)
  28004    ...S ICD= $P(INFO,"^ ",10) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  28005   "RTN","CHM FAUT1",383 ,0)
  28006    ...S DELC HG=$P(INFO ,"^",6)
  28007   "RTN","CHM FAUT1",384 ,0)
  28008    ...S PL=$ P(INFO,"^" ,9)
  28009   "RTN","CHM FAUT1",385 ,0)
  28010    ...S:PL=" P" PLOUT=" Purch."
  28011   "RTN","CHM FAUT1",386 ,0)
  28012    ...S:PL=" L" PLOUT=" Lease"
  28013   "RTN","CHM FAUT1",387 ,0)
  28014    ...S CPT= $P(INFO,"^ ",7) S:CPT ]"" CPTOUT =$$PROC^CH MFAUT0(CPT ,DOS)
  28015   "RTN","CHM FAUT1",388 ,0)
  28016    ...S UNT= $P(INFO,"^ ",12)
  28017   "RTN","CHM FAUT1",389 ,0)
  28018    ...S REV= $P(INFO,"^ ",13) S:RE V]"" REVOU T=$$REV^CH MFAUT0(REV )
  28019   "RTN","CHM FAUT1",390 ,0)
  28020    ...S EDIL ID=$P(INFO ,"^",14)   ;JEH 2/1/1 1 DEV00782 0
  28021   "RTN","CHM FAUT1",391 ,0)
  28022    ...S MEDP YMT=$P(INF O,"^",11)
  28023   "RTN","CHM FAUT1",392 ,0)
  28024    ...S BENP YMT=$P(INF O,"^",5)
  28025   "RTN","CHM FAUT1",393 ,0)
  28026    ...S W=$P (INFO,"^", 5)
  28027   "RTN","CHM FAUT1",394 ,0)
  28028    ...S MOD= $P(INFO,"^ ",17) I MO D]"" S MOD OUT=$$MOD^ CHMFAUT0(M OD),MOD=$P (MODOUT,"^ ",1)                                          ;JEH 2/1 /11 DEV007 820
  28029   "RTN","CHM FAUT1",395 ,0)
  28030    ...S MOD2 =$P(INFO," ^",18) I M OD2]"" S M ODOUT=MODO UT_"*"_$$M OD^CHMFAUT 0(MOD2),MO D2=$P($P(M ODOUT,"*", 2),"^",1)      ;JEH 2 /1/11 DEV0 07820
  28031   "RTN","CHM FAUT1",396 ,0)
  28032    ...S MOD3 =$P(INFO," ^",19) S:M OD3]"" MOD OUT=MODOUT _"*"_$$MOD ^CHMFAUT0( MOD3),MOD3 =$P($P(MOD OUT,"*",3) ,"^",1)                 ;JEH 2/1 /11 DEV007 820
  28033   "RTN","CHM FAUT1",397 ,0)
  28034    ...S MOD4 =$P(INFO," ^",20) S:M OD4]"" MOD OUT=MODOUT _"*"_$$MOD ^CHMFAUT0( MOD4),MOD4 =$P($P(MOD OUT,"*",4) ,"^",1)                 ;JEH 2/1 /11 DEV007 820
  28035   "RTN","CHM FAUT1",398 ,0)
  28036    ...S MODO UT=MOD_MOD 2_MOD3_MOD 4_"*"_MODO UT         ;JEH 2/1/1 1 DEV00782 0
  28037   "RTN","CHM FAUT1",399 ,0)
  28038    ...S:$P(M ODOUT,"*", 1)="" MODO UT=""        ;JEH 2/1 /11 DEV007 820
  28039   "RTN","CHM FAUT1",400 ,0)
  28040    ...D:$G(% )="" NOW^% DTC  ;JEH  8/29/08 TT  #DEV00559 6  ADDED L INE
  28041   "RTN","CHM FAUT1",401 ,0)
  28042    ...S CPT= $P(INFO,"^ ",7) S:CPT ]"" CPTOUT ="SV*"_$$P ROC^CHMFAU T0(CPT,$S( DOS]"":DOS ,1:%\1)) ; JSG;NC;Fak e DOS to g et Procedu re
  28043   "RTN","CHM FAUT1",402 ,0)
  28044    ...S (OHI PDAMT,OHIP RESP,ADDOH IPY,OHIPRB AL,MEDICDP D,TPLPAID, COSTUNT,NM UNTALL,CAL LDAMT,DEDC TAMT,CSTSH AMT,PYMNTA MT,PATPDAM T,CCAPLAMT )="" ;JEH  2/1/11 DEV 007820
  28045   "RTN","CHM FAUT1",403 ,0)
  28046    ...S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT                                       JEH 2/1/ 11 DEV0078 20
  28047   "RTN","CHM FAUT1",404 ,0)
  28048    ...S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y              JEH 2/ 1/11 DEV00 7820
  28049   "RTN","CHM FAUT1",405 ,0)
  28050    ...S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS    JEH  2/1/11 DEV 007820
  28051   "RTN","CHM FAUT1",406 ,0)
  28052    ...S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE                                     JEH 2/1/ 11 DEV0078 20
  28053   "RTN","CHM FAUT1",407 ,0)
  28054    ...S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID                                       JEH 2/1/ 11 DEV0078 20
  28055   "RTN","CHM FAUT1",408 ,0)
  28056    ...S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D                                                   JE H 2/1/11 D EV007820
  28057   "RTN","CHM FAUT1",409 ,0)
  28058    ...S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT                                                  JE H 2/1/11 D EV007820
  28059   "RTN","CHM FAUT1",410 ,0)
  28060    ...S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED                                    JEH 2/1/ 11 DEV0078 20
  28061   "RTN","CHM FAUT1",411 ,0)
  28062    ...S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT                JEH 2/ 1/11 DEV00 7820
  28063   "RTN","CHM FAUT1",412 ,0)
  28064    ...S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT                                 JEH 2/1/ 11 DEV0078 20
  28065   "RTN","CHM FAUT1",413 ,0)
  28066    ...S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT                                     JEH 2/1/ 11 DEV0078 20
  28067   "RTN","CHM FAUT1",414 ,0)
  28068    ...S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT                                     JEH 2/1/ 11 DEV0078 20
  28069   "RTN","CHM FAUT1",415 ,0)
  28070    ...S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T                                  JEH 2/1/ 11 DEV0078 20
  28071   "RTN","CHM FAUT1",416 ,0)
  28072    ...S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT                      JEH 2/ 1/11 DEV00 7820
  28073   "RTN","CHM FAUT1",417 ,0)
  28074    ...S ADIS TRO=$P($G( ^CHMIMAGE( D4,0)),"^" ,16) ;AUTO  DISTRIBUT ION  JEH 2 /1/11 DEV0 07820
  28075   "RTN","CHM FAUT1",418 ,0)
  28076    ...I DOS' ="" D                                                        ;JSG ;3/14/08;D EV004525-0 1
  28077   "RTN","CHM FAUT1",419 ,0)
  28078    ....S:'$D (CHHOLDPY( DOS)) CHHO LDPY(DOS)= ""                          ;JSG ;Add dot
  28079   "RTN","CHM FAUT1",420 ,0)
  28080    ....I MED PYMT'="" D                                                   ;JSG ;Add dot
  28081   "RTN","CHM FAUT1",421 ,0)
  28082    .....S $P (CHHOLDPY( DOS),"^",1 )=$FN(($P( CHHOLDPY(D OS),"^",1) +MEDPYMT), "",2) ;JSG ;Add dot
  28083   "RTN","CHM FAUT1",422 ,0)
  28084    ....I BEN PYMT'="" D                                                   ;JSG ;Add dot     JEH 2/1/ 11 DEV0078 20 COMMNTD  OFF I BEN PYMT
  28085   "RTN","CHM FAUT1",423 ,0)
  28086    .....S $P (CHHOLDPY( DOS),"^",2 )=$FN(($P( CHHOLDPY(D OS),"^",2) +BENPYMT), "",2) ;JSG ;Add dot
  28087   "RTN","CHM FAUT1",424 ,0)
  28088    ....S PRA MOUNT=""     ;SKD 9-2 7-07 DEV00 3378                                   ;JSG ;Add dot
  28089   "RTN","CHM FAUT1",425 ,0)
  28090    ....I $P( CHHOLDPY(D OS),"^",3) ="" I $G(V FN)'="" I  $D(^CHMIMA GE(D4,"ZOH I",DFN,BFN ,CHMFSERV, DOS,VFN))  D  ;JSG;Ad d dot
  28091   "RTN","CHM FAUT1",426 ,0)
  28092    .....;S O HIPYMT=^CH MIMAGE(CHM FPDI,"ZOHI ",DFN,BFN, CHMFSERV,D OS,VFN)  ; skd MC284  12-15-06
  28093   "RTN","CHM FAUT1",427 ,0)
  28094    .....S PR AMOUNT=$P( $G(^CHMIMA GE(D4,"ZOH I",DFN,BFN ,CHMFSERV, DOS,VFN)), U,2)  ;skd  MC284 12- 15-06;JSG; Add dot
  28095   "RTN","CHM FAUT1",428 ,0)
  28096    .....;S $ P(CHHOLDPY (DOS),"^", 3)=$FN(OHI PYMT,"",2)    ;skd MC 284 12-15- 06
  28097   "RTN","CHM FAUT1",429 ,0)
  28098    .....I $G (PRAMOUNT)  S $P(CHHO LDPY(DOS), "^",3)=$FN (PRAMOUNT, "",2)  ;sk d MC284 12 -15-06;JSG ;Add dot
  28099   "RTN","CHM FAUT1",430 ,0)
  28100    ....I TPL PAID'="" I  TPLPAID D
  28101   "RTN","CHM FAUT1",431 ,0)
  28102    .....S $P (CHHOLDPY( DOS),"^",4 )=$P(CHHOL DPY(DOS)," ^",4)+TPLP AID
  28103   "RTN","CHM FAUT1",432 ,0)
  28104    ...S L=L+ 1 D PREOUT L ;JEH 2/1 /11 DEV007 820 ; wtc  7/26/17
  28105   "RTN","CHM FAUT1",433 ,0)
  28106    ...;D PRE DMEL    ;J EH 2/1/11  DEV007820
  28107   "RTN","CHM FAUT1",434 ,0)
  28108    ...S SVL= L
  28109   "RTN","CHM FAUT1",435 ,0)
  28110    ...Q
  28111   "RTN","CHM FAUT1",436 ,0)
  28112    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if type o f bill = 1 35/freq co de=5
  28113   "RTN","CHM FAUT1",437 ,0)
  28114    ;I '$G(CH MOPDI) S C HMOPDI=$P( $G(^CHMIMA GE(CHMFPDI ,202)),"^" ,1) ;BDB 8 /14/17
  28115   "RTN","CHM FAUT1",438 ,0)
  28116    ;S:$E($P( $G(^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"VEN")) ,"^",7),3) =5 L=$$LAT E^CHMFAUT5 (CHMFPDI,$ G(CHMOPDI) ,CHMFSRVC, $G(SPBEN), SVL)
  28117   "RTN","CHM FAUT1",439 ,0)
  28118    K ^TMP($J ) ; wtc 7/ 27/17
  28119   "RTN","CHM FAUT1",440 ,0)
  28120    Q
  28121   "RTN","CHM FAUT1",441 ,0)
  28122   PREDMEL ;   DME load  into ^UTIL ITY and CH MDME array     ;  ;JE H 2/1/11 D EV007820 -  NOT USED  AFTER SLLA
  28123   "RTN","CHM FAUT1",442 ,0)
  28124    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,0)=L
  28125   "RTN","CHM FAUT1",443 ,0)
  28126    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,1)=DOSOUT
  28127   "RTN","CHM FAUT1",444 ,0)
  28128    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,2)=ICDOUT
  28129   "RTN","CHM FAUT1",445 ,0)
  28130    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,3)=REVOUT
  28131   "RTN","CHM FAUT1",446 ,0)
  28132    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,4)=CPTOUT
  28133   "RTN","CHM FAUT1",447 ,0)
  28134    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,5)=UNT
  28135   "RTN","CHM FAUT1",448 ,0)
  28136    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,6)=CHG
  28137   "RTN","CHM FAUT1",449 ,0)
  28138    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,7)=PLOUT
  28139   "RTN","CHM FAUT1",450 ,0)
  28140    Q
  28141   "RTN","CHM FAUT1",451 ,0)
  28142   PRETRV ;
  28143   "RTN","CHM FAUT1",452 ,0)
  28144    ;.D PREOU TL ;JEH 2/ 1/11 DEV00 7820
  28145   "RTN","CHM FAUT1",453 ,0)
  28146    D PREOUT  Q
  28147   "RTN","CHM FAUT1",454 ,0)
  28148   PREDNT ;De ntal prelo ad
  28149   "RTN","CHM FAUT1",455 ,0)
  28150    N L,INFO, DOS,POS,CH G,ICD,MOD, CPT,REV,OH IPYMT,MEDP YMT,BENPYM T,SPBEN,IN FO2          ;JEH 2/1 /11 DEV007 820
  28151   "RTN","CHM FAUT1",456 ,0)
  28152    N DOSOUT, POSOUT,ICD OUT,REVOUT ,MODOUT,CP TOUT,PRAMO UNT   ;SKD  9-27-07 D EV003378
  28153   "RTN","CHM FAUT1",457 ,0)
  28154    N OHIPDAM T,OHIPRESP ,ADDOHIPY, OHIPRBAL,M EDICDPD,TP LPAID,COST UNT,NMUNTA LL         ;JEH 2/1/1 1 DEV00782 0
  28155   "RTN","CHM FAUT1",458 ,0)
  28156    N CALLDAM T,DEDCTAMT ,CSTSHAMT, PYMNTAMT,P ATPDAMT,CC APLAMT,ADI STRO,EDILI D ;JEH 2/1 /11 DEV007 820
  28157   "RTN","CHM FAUT1",459 ,0)
  28158    N SVL           ;JEH  2/1/11 DE V007820
  28159   "RTN","CHM FAUT1",460 ,0)
  28160    N D3,D4,D ENDOS,CHMO PGNM,CHMOI MAG,CHMOPG IM ; wtc 8 /8/17
  28161   "RTN","CHM FAUT1",461 ,0)
  28162     K ^UTILI TY($J),^TM P($J) ; wt c 8/8/17
  28163   "RTN","CHM FAUT1",462 ,0)
  28164    S (DENDOS ,SVL)="",D 3=0,L=0 ;  wtc 8/8/17
  28165   "RTN","CHM FAUT1",463 ,0)
  28166    ;
  28167   "RTN","CHM FAUT1",464 ,0)
  28168    ;  wtc 8/ 8/17
  28169   "RTN","CHM FAUT1",465 ,0)
  28170    ;  
  28171   "RTN","CHM FAUT1",466 ,0)
  28172    ;  "B" cr oss-refere nce at "DE NTAL-NS" m ultiple is  not being  created w hen image  file is cr eated
  28173   "RTN","CHM FAUT1",467 ,0)
  28174    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  28175   "RTN","CHM FAUT1",468 ,0)
  28176    ;
  28177   "RTN","CHM FAUT1",469 ,0)
  28178    S SVL=0        ;JEH  2/1/11 DEV 007820
  28179   "RTN","CHM FAUT1",470 ,0)
  28180    ;S L=""   ; wtc 8/8/ 17
  28181   "RTN","CHM FAUT1",471 ,0)
  28182    I $G(CHMF PDI) F  S  D3=$O(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"DEN TAL-NS",D3 )) Q:D3=""   D  ; wtc  8/8/17
  28183   "RTN","CHM FAUT1",472 ,0)
  28184    . S DENDO S=$P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"D ENTAL-NS", D3,0)),"^" ,1) ;
  28185   "RTN","CHM FAUT1",473 ,0)
  28186    . ;S ^TMP ($J,CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"DENTA L-NS",DEND OS,D3)=""
  28187   "RTN","CHM FAUT1",474 ,0)
  28188    . S ^TMP( $J,DENDOS, D3,CHMFPDI )=""
  28189   "RTN","CHM FAUT1",475 ,0)
  28190    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  28191   "RTN","CHM FAUT1",476 ,0)
  28192    I $G(CHMO PDI),$G(CH MOPGNM),$G (CHMOIMAG) ,$E($P($G( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN")),"^ ",7),3)=5  F  S D3=$O (^CHMIMAGE (CHMOPDI,1 ,CHMOPGNM, 2,CHMOIMAG ,"DENTAL-N S",D3)) Q: D3=""  D
  28193   "RTN","CHM FAUT1",477 ,0)
  28194    . S DENDO S=$P($G(^C HMIMAGE(CH MOPDI,1,CH MOPGNM,2,C HMOIMAG,"D ENTAL-NS", D3,0)),"^" ,1) ;
  28195   "RTN","CHM FAUT1",478 ,0)
  28196    . ;S ^TMP ($J,CHMOPD I,1,CHMOPG NM,2,CHMOI MAG,"DENTA L-NS",DEND OS,D3)=""
  28197   "RTN","CHM FAUT1",479 ,0)
  28198    . S ^TMP( $J,DENDOS, D3,CHMOPDI )=""
  28199   "RTN","CHM FAUT1",480 ,0)
  28200    ;
  28201   "RTN","CHM FAUT1",481 ,0)
  28202    ;F  S L=$ O(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"DENTAL- NS",L)) Q: L=""  D S  DENDOS=""  ;  wtc 8/8 /17
  28203   "RTN","CHM FAUT1",482 ,0)
  28204    S DENDOS= "" ;
  28205   "RTN","CHM FAUT1",483 ,0)
  28206    ;F  S DEN DOS=$O(^TM P($J,CHMFP DI,1,CHMFP GNM,2,CHMF IMAG,"DENT AL-NS",DEN DOS)) Q:DE NDOS=""  D   ; wtc 8/ 8/17
  28207   "RTN","CHM FAUT1",484 ,0)
  28208    ;. F  S D 3=$O(^TMP( $J,CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"DENTAL -NS",DENDO S,D3)) Q:D 3=""  D  ;  wtc 8/8/1 7
  28209   "RTN","CHM FAUT1",485 ,0)
  28210    F  S DEND OS=$O(^TMP ($J,DENDOS )) Q:DENDO S=""  D  ;  wtc 8/8/1 7
  28211   "RTN","CHM FAUT1",486 ,0)
  28212    . S D3=""  F  S D3=$ O(^TMP($J, DENDOS,D3) ) Q:D3=""   D  ; wtc  8/8/17
  28213   "RTN","CHM FAUT1",487 ,0)
  28214    .. S D4=" " F  S D4= $O(^TMP($J ,DENDOS,D3 ,D4)) Q:D4 =""  D  ;b db 8/15/20 176
  28215   "RTN","CHM FAUT1",488 ,0)
  28216    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  28217   "RTN","CHM FAUT1",489 ,0)
  28218    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=$G(CHMOP DI),CHMFPG N1=$G(CHMO PGNM),CHMF IMA1=$G(CH MOIMAG)
  28219   "RTN","CHM FAUT1",490 ,0)
  28220    ...S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  28221   "RTN","CHM FAUT1",491 ,0)
  28222    ...S INFO =$G(^CHMIM AGE(CHMFPD I1,1,CHMFP GN1,2,CHMF IMA1,"DENT AL-NS",D3, 0)) ; chan ge L to D3  wtc 8/8/1 7
  28223   "RTN","CHM FAUT1",492 ,0)
  28224    ...S INFO 2=$G(^CHMI MAGE(CHMFP DI1,1,CHMF PGN1,2,CHM FIMA1,"DEN TAL-NS",D3 ,1,1,0)) ; JEH 2/1/11  DEV007820  ; change  L to D3 wt c 8/8/17
  28225   "RTN","CHM FAUT1",493 ,0)
  28226    ...;&(INF O2="")         ;JEH 2 /1/11 DEV0 07820
  28227   "RTN","CHM FAUT1",494 ,0)
  28228    ...Q:INFO =""
  28229   "RTN","CHM FAUT1",495 ,0)
  28230    ...S SPBE N=$P(INFO, "^",2)_"/" _$P(INFO," ^",3) ;BDB
  28231   "RTN","CHM FAUT1",496 ,0)
  28232    ...; JSG; 01/29/08;D EV003956-0 2;Make DOS OUT = "__/ __/__^" fo r null DOS
  28233   "RTN","CHM FAUT1",497 ,0)
  28234    ...; S DO S=$P(INFO, "^",1) S:D OS]"" DOSO UT=$$DOS^C HMFAUT0(DO S)                  ; JSG;OC
  28235   "RTN","CHM FAUT1",498 ,0)
  28236    ...S DOS= $P(INFO,"^ ",1) S DOS OUT=$S(DOS ]"":$$DOS^ CHMFAUT0(D OS),1:"__/ __/__^") ; JSG;NC: St uff it, if  ""
  28237   "RTN","CHM FAUT1",499 ,0)
  28238    ...;RALLY  US8440 -  TGH - 3/15 /19 Reset  Dental Val ues to mat ch DENTAL- NS CHMIMAG E
  28239   "RTN","CHM FAUT1",500 ,0)
  28240    ...;S POS =$P(INFO," ^",2) S:PO S="" POS=3  S:POS]""  POSOUT=$$P OS^CHMFAUT 0(POS)
  28241   "RTN","CHM FAUT1",501 ,0)
  28242    ...;S CHG =$P(INFO," ^",8)
  28243   "RTN","CHM FAUT1",502 ,0)
  28244    ...;S ICD =$P(INFO," ^",10) S:I CD]"" ICDO UT=$$ICD^C HMFAUT0(IC D)
  28245   "RTN","CHM FAUT1",503 ,0)
  28246    ...;S MOD =$P(INFO," ^",9) I MO D]"" S MOD OUT=$$MOD^ CHMFAUT0(M OD),MOD=$P (MODOUT,"^ ",1)                                          ;JEH 2/1 /11 DEV007 820
  28247   "RTN","CHM FAUT1",504 ,0)
  28248    ...;S MOD 2=$P(INFO, "^",20) I  MOD2]"" S  MODOUT=MOD OUT_"*"_$$ MOD^CHMFAU T0(MOD2),M OD2=$P($P( MODOUT,"*" ,2),"^",1)      ;JEH  2/1/11 DEV 007820
  28249   "RTN","CHM FAUT1",505 ,0)
  28250    ...;S MOD 3=$P(INFO, "^",21) S: MOD3]"" MO DOUT=MODOU T_"*"_$$MO D^CHMFAUT0 (MOD3),MOD 3=$P($P(MO DOUT,"*",3 ),"^",1)                 ;JEH 2/ 1/11 DEV00 7820
  28251   "RTN","CHM FAUT1",506 ,0)
  28252    ...;S MOD 4=$P(INFO, "^",22) S: MOD4]"" MO DOUT=MODOU T_"*"_$$MO D^CHMFAUT0 (MOD4),MOD 4=$P($P(MO DOUT,"*",4 ),"^",1)                 ;JEH 2/ 1/11 DEV00 7820
  28253   "RTN","CHM FAUT1",507 ,0)
  28254    ...;S MOD OUT=MOD_MO D2_MOD3_MO D4_"*"_MOD OUT ;JEH 2 /1/11 DEV0 07820
  28255   "RTN","CHM FAUT1",508 ,0)
  28256    ...;S:$P( MODOUT,"*" ,1)="" MOD OUT="" ;JE H 2/1/11 D EV007820
  28257   "RTN","CHM FAUT1",509 ,0)
  28258    ...; S CP T=$P(INFO, "^",7) S:C PT]"" CPTO UT=$$PROC^ CHMFAUT0(C PT,DOS)                  ;JSG;OC
  28259   "RTN","CHM FAUT1",510 ,0)
  28260    ...;D:$G( %)="" NOW^ %DTC ;JEH  8/29/08 TT  #DEV00559 6  ADDED L INE
  28261   "RTN","CHM FAUT1",511 ,0)
  28262    ...;S CPT =$P(INFO," ^",7) S:CP T]"" CPTOU T="SV*"_$$ PROC^CHMFA UT0(CPT,$S (DOS]"":DO S,1:%\1))  ;JSG;NC;Fa ke DOS to  get Proced ure            ;JEH 2 /1/11 DEV0 07820
  28263   "RTN","CHM FAUT1",512 ,0)
  28264    ...;S REV =$P(INFO," ^",14) S:R EV]"" REVO UT=$$REV^C HMFAUT0(RE V)
  28265   "RTN","CHM FAUT1",513 ,0)
  28266    ...;S EDI LID=$P(INF O,"^",16)  ;JEH 2/1/1 1 DEV00782 0
  28267   "RTN","CHM FAUT1",514 ,0)
  28268    ...;S UNT =$P(INFO," ^",17)
  28269   "RTN","CHM FAUT1",515 ,0)
  28270    ...;S MED PYMT=$P(IN FO,"^",18)
  28271   "RTN","CHM FAUT1",516 ,0)
  28272    ...;S BEN PYMT=$P(IN FO,"^",6)
  28273   "RTN","CHM FAUT1",517 ,0)
  28274    ...S POS= $P(INFO,"^ ",11) S:PO S="" POS=3  S:POS]""  POSOUT=$$P OS^CHMFAUT 0(POS)
  28275   "RTN","CHM FAUT1",518 ,0)
  28276    ...S CHG= $P(INFO,"^ ",7)
  28277   "RTN","CHM FAUT1",519 ,0)
  28278    ...S ICD= $P(INFO,"^ ",10) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  28279   "RTN","CHM FAUT1",520 ,0)
  28280    ...S MOD= $P(INFO,"^ ",8) I MOD ]"" S MODO UT=$$MOD^C HMFAUT0(MO D),MOD=$P( MODOUT,"^" ,1)  ;JEH  2/1/11 DEV 007820
  28281   "RTN","CHM FAUT1",521 ,0)
  28282    ...S MOD2 =$P(INFO," ^",19) I M OD2]"" S M ODOUT=MODO UT_"*"_$$M OD^CHMFAUT 0(MOD2),MO D2=$P($P(M ODOUT,"*", 2),"^",1)   ;JEH 2/1/ 11 DEV0078 20
  28283   "RTN","CHM FAUT1",522 ,0)
  28284    ...S MOD3 =$P(INFO," ^",20) S:M OD3]"" MOD OUT=MODOUT _"*"_$$MOD ^CHMFAUT0( MOD3),MOD3 =$P($P(MOD OUT,"*",3) ,"^",1)  ; JEH 2/1/11  DEV007820
  28285   "RTN","CHM FAUT1",523 ,0)
  28286    ...S MOD4 =$P(INFO," ^",21) S:M OD4]"" MOD OUT=MODOUT _"*"_$$MOD ^CHMFAUT0( MOD4),MOD4 =$P($P(MOD OUT,"*",4) ,"^",1)  ; JEH 2/1/11  DEV007820
  28287   "RTN","CHM FAUT1",524 ,0)
  28288    ...S MODO UT=MOD_MOD 2_MOD3_MOD 4_"*"_MODO UT  ;JEH 2 /1/11 DEV0 07820
  28289   "RTN","CHM FAUT1",525 ,0)
  28290    ...S:$P(M ODOUT,"*", 1)="" MODO UT=""  ;JE H 2/1/11 D EV007820
  28291   "RTN","CHM FAUT1",526 ,0)
  28292    ...D:$G(% )="" NOW^% DTC ;JEH 8 /29/08 TT  #DEV005596   -- TGH -  RALLY US8 440 ADDED  LINE TO IN SURE DOS A VAILABLE
  28293   "RTN","CHM FAUT1",527 ,0)
  28294    ...S CPT= $P(INFO,"^ ",6) S:CPT ]"" CPTOUT ="SV*"_$$P ROC^CHMFAU T0(CPT,$S( DOS]"":DOS ,1:%\1))   ;JEH 2/1/1 1 DEV00782 0 -- TGH -  RALLY US8 440 ADDED  LINE TO IN SURE DOS A VAILABLE
  28295   "RTN","CHM FAUT1",528 ,0)
  28296    ...S EDIL ID=$P(INFO ,"^",15)   ;JEH 2/1/1 1 DEV00782 0
  28297   "RTN","CHM FAUT1",529 ,0)
  28298    ...S UNT= $P(INFO,"^ ",12)  ;JE H 2/1/11 D EV007820
  28299   "RTN","CHM FAUT1",530 ,0)
  28300    ...S REV= $P(INFO,"^ ",16) S:RE V]"" REVOU T=$$REV^CH MFAUT0(REV )  ;JEH 2/ 1/11 DEV00 7820
  28301   "RTN","CHM FAUT1",531 ,0)
  28302    ...S MEDP YMT=$P(INF O,"^",13)
  28303   "RTN","CHM FAUT1",532 ,0)
  28304    ...S BENP YMT=$P(INF O,"^",5)
  28305   "RTN","CHM FAUT1",533 ,0)
  28306    ...; END  OF RALLY U S8440
  28307   "RTN","CHM FAUT1",534 ,0)
  28308    ...S (OHI PDAMT,OHIP RESP,ADDOH IPY,OHIPRB AL,MEDICDP D,TPLPAID, COSTUNT,NM UNTALL,CAL LDAMT,DEDC TAMT,CSTSH AMT,PYMNTA MT,PATPDAM T,CCAPLAMT )="" ;JEH  2/1/11 DEV 007820
  28309   "RTN","CHM FAUT1",535 ,0)
  28310    ...S (NMU NTALL,CALL DAMT,DEDCT AMT,CSTSHA MT,PYMNTAM T,PATPDAMT ,CCAPLAMT, ADISTRO)=" "  ;JEH 2/ 1/11 DEV00 7820
  28311   "RTN","CHM FAUT1",536 ,0)
  28312    ...S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT                                       JEH 2/1/ 11 DEV0078 20
  28313   "RTN","CHM FAUT1",537 ,0)
  28314    ...S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y              JEH 2/ 1/11 DEV00 7820
  28315   "RTN","CHM FAUT1",538 ,0)
  28316    ...S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS    JEH  2/1/11 DEV 007820
  28317   "RTN","CHM FAUT1",539 ,0)
  28318    ...S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE                                     JEH 2/1/ 11 DEV0078 20
  28319   "RTN","CHM FAUT1",540 ,0)
  28320    ...S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID                                       JEH 2/1/ 11 DEV0078 20
  28321   "RTN","CHM FAUT1",541 ,0)
  28322    ...S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D                                                   JE H 2/1/11 D EV007820
  28323   "RTN","CHM FAUT1",542 ,0)
  28324    ...S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT                                                  JE H 2/1/11 D EV007820
  28325   "RTN","CHM FAUT1",543 ,0)
  28326    ...S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED                                    JEH 2/1/ 11 DEV0078 20
  28327   "RTN","CHM FAUT1",544 ,0)
  28328    ...S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT                JEH 2/ 1/11 DEV00 7820
  28329   "RTN","CHM FAUT1",545 ,0)
  28330    ...S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT                                 JEH 2/1/ 11 DEV0078 20
  28331   "RTN","CHM FAUT1",546 ,0)
  28332    ...S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT                                     JEH 2/1/ 11 DEV0078 20
  28333   "RTN","CHM FAUT1",547 ,0)
  28334    ...S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT                                     JEH 2/1/ 11 DEV0078 20
  28335   "RTN","CHM FAUT1",548 ,0)
  28336    ...S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T                                  JEH 2/1/ 11 DEV0078 20
  28337   "RTN","CHM FAUT1",549 ,0)
  28338    ...S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT                      JEH 2/ 1/11 DEV00 7820
  28339   "RTN","CHM FAUT1",550 ,0)
  28340    ...S ADIS TRO=$P(^CH MIMAGE(CHM FPDI1,0)," ^",16) ;AU TO DISTRIB UTION  JEH  2/1/11 DE V007820
  28341   "RTN","CHM FAUT1",551 ,0)
  28342    ...; I '$ L($G(DOS)) !'$G(POS)  W !,"*** D OS or POS  missing! * **" H 5 Q  ;JSG;OC;Do n't need
  28343   "RTN","CHM FAUT1",552 ,0)
  28344    ...I DOS] "" D           ;JSG;N C;We only  want to do  this sect ion if DOS  originall y not ""
  28345   "RTN","CHM FAUT1",553 ,0)
  28346    ....S:'$D (CHHOLDPY( DOS,POS))  CHHOLDPY(D OS,POS)=""  ;JSG;Add  dot
  28347   "RTN","CHM FAUT1",554 ,0)
  28348    ....I MED PYMT'="" D                                   ;JSG;Add  dot
  28349   "RTN","CHM FAUT1",555 ,0)
  28350    .....S $P (CHHOLDPY( DOS,POS)," ^",1)=$FN( ($P(CHHOLD PY(DOS,POS ),"^",1)+M EDPYMT),"" ,2)  ;JSG; Add dot  ; AEB 2/3/20 09 ADDED A NOTHER .(D OT)
  28351   "RTN","CHM FAUT1",556 ,0)
  28352    ....I BEN PYMT'="" I  BENPYMT D                        ;JSG;Add  dot
  28353   "RTN","CHM FAUT1",557 ,0)
  28354    .....S $P (CHHOLDPY( DOS,POS)," ^",2)=$FN( ($P(CHHOLD PY(DOS,POS ),"^",2)+B ENPYMT),"" ,2) ;JSG;A dd dot
  28355   "RTN","CHM FAUT1",558 ,0)
  28356    ....S PRA MOUNT=""     ;SKD 9-2 7-07 DEV00 3378        ;JSG;Add  dot
  28357   "RTN","CHM FAUT1",559 ,0)
  28358    ....I $P( CHHOLDPY(D OS,POS),"^ ",3)="" I  VFN'="" I  $D(^CHMIMA GE(CHMFPDI ,"ZOHI",DF N,BFN,CHMF SERV,DOS,P OS,VFN)) D   ;JSG;Add  dot
  28359   "RTN","CHM FAUT1",560 ,0)
  28360    .....;S O HIPYMT=^CH MIMAGE(CHM FPDI,"ZOHI ",DFN,BFN, CHMFSERV,D OS,POS,VFN )  ;SKD MC 284 12-15- 06
  28361   "RTN","CHM FAUT1",561 ,0)
  28362    .....S PR AMOUNT=$P( $G(^CHMIMA GE(CHMFPDI ,"ZOHI",DF N,BFN,CHMF SERV,DOS,P OS,VFN)),U ,2)  ;SKD  MC284 12-1 5-06;JSG;A dd dot
  28363   "RTN","CHM FAUT1",562 ,0)
  28364    .....I $G (PRAMOUNT)  S $P(CHHO LDPY(DOS,P OS),"^",3) =$FN(PRAMO UNT,"",2)  ;JSG;Add d ot  ;AEB 2 /3/2009 CH ANGED THE  $$FN FORM  OHIPYMT TO  PRAMOUNT
  28365   "RTN","CHM FAUT1",563 ,0)
  28366    ...I TPLP AID'="" I  TPLPAID D
  28367   "RTN","CHM FAUT1",564 ,0)
  28368    ....S $P( CHHOLDPY(D OS,POS),"^ ",4)=$P(CH HOLDPY(DOS ,POS),"^", 4)+TPLPAID
  28369   "RTN","CHM FAUT1",565 ,0)
  28370    ... ;
  28371   "RTN","CHM FAUT1",566 ,0)
  28372    ... ;  Do  not outpu t line if  it has nei ther diagn osis (ICD)  nor reven ue code (R EV) - wtc  8/10/17
  28373   "RTN","CHM FAUT1",567 ,0)
  28374    ... ;RALL Y US8440 -  TGH - 3/1 5/19 - Use  CPT for D ental rath er than RE V
  28375   "RTN","CHM FAUT1",568 ,0)
  28376    ... ;I IC D'=""!(REV '="") D  ;
  28377   "RTN","CHM FAUT1",569 ,0)
  28378    ...I ICD' =""!(CPT'= "") D
  28379   "RTN","CHM FAUT1",570 ,0)
  28380    ....S L=L +1 D PREOU TL^CHMFAUT 1 ; Increm ent L wtc  8/8/17
  28381   "RTN","CHM FAUT1",571 ,0)
  28382    ....S SVL =L       ; JEH 2/1/11  DEV007820
  28383   "RTN","CHM FAUT1",572 ,0)
  28384    ...Q
  28385   "RTN","CHM FAUT1",573 ,0)
  28386    ..Q
  28387   "RTN","CHM FAUT1",574 ,0)
  28388    .Q
  28389   "RTN","CHM FAUT1",575 ,0)
  28390    Q
  28391   "RTN","CHM FAUT1",576 ,0)
  28392    ;
  28393   "RTN","CHM FAUT1",577 ,0)
  28394   PREDNTL ;   Dental lo ad into ^U TILITY and  CHMDME ar ray   ;JEH  2/1/11 DE V007820 -  NOT USED A FTER SLLA
  28395   "RTN","CHM FAUT1",578 ,0)
  28396    N L,INFO, DOS,POS,CH G,ICD,MOD, CPT,REV,OH IPYMT,MEDP YMT,BENPYM T,SPBEN,IN FO2          ;JEH 2/1 /11 DEV007 820
  28397   "RTN","CHM FAUT1",579 ,0)
  28398    N DOSOUT, POSOUT,ICD OUT,REVOUT ,MODOUT,CP TOUT,PRAMO UNT   ;SKD  9-27-07 D EV003378
  28399   "RTN","CHM FAUT1",580 ,0)
  28400    N OHIPDAM T,OHIPRESP ,ADDOHIPY, OHIPRBAL,M EDICDPD,TP LPAID,COST UNT,NMUNTA LL         ;JEH 2/1/1 1 DEV00782 0
  28401   "RTN","CHM FAUT1",581 ,0)
  28402    N CALLDAM T,DEDCTAMT ,CSTSHAMT, PYMNTAMT,P ATPDAMT,CC APLAMT,ADI STRO,EDILI D ;JEH 2/1 /11 DEV007 820
  28403   "RTN","CHM FAUT1",582 ,0)
  28404    N SVL           ;JEH  2/1/11 DE V007820
  28405   "RTN","CHM FAUT1",583 ,0)
  28406    N D3,D4,D ENDOS,CHMO PGNM,CHMOI MAG,CHMOPG IM ; wtc 8 /8/17
  28407   "RTN","CHM FAUT1",584 ,0)
  28408    K ^UTILIT Y($J),^TMP ($J) ; wtc  8/8/17
  28409   "RTN","CHM FAUT1",585 ,0)
  28410    S (DENDOS ,SVL)="",D 3=0,L=0 ;  wtc 8/8/17
  28411   "RTN","CHM FAUT1",586 ,0)
  28412    ;
  28413   "RTN","CHM FAUT1",587 ,0)
  28414    ;  wtc 8/ 8/17
  28415   "RTN","CHM FAUT1",588 ,0)
  28416    ;  
  28417   "RTN","CHM FAUT1",589 ,0)
  28418    ;  "B" cr oss-refere nce at "DE NTAL-NS" m ultiple is  not being  created w hen image  file is cr eated
  28419   "RTN","CHM FAUT1",590 ,0)
  28420    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  28421   "RTN","CHM FAUT1",591 ,0)
  28422    ;
  28423   "RTN","CHM FAUT1",592 ,0)
  28424    S SVL=0        ;JEH  2/1/11 DEV 007820
  28425   "RTN","CHM FAUT1",593 ,0)
  28426    ;S L=""   ; wtc 8/8/ 17
  28427   "RTN","CHM FAUT1",594 ,0)
  28428    I $G(CHMF PDI) F  S  D3=$O(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"DEN TAL-NS",D3 )) Q:D3=""   D  ; wtc  8/8/17
  28429   "RTN","CHM FAUT1",595 ,0)
  28430    . S DENDO S=$P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"D ENTAL-NS", D3,0)),"^" ,1) ;
  28431   "RTN","CHM FAUT1",596 ,0)
  28432    . ;S ^TMP ($J,CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"DENTA L-NS",DEND OS,D3)=""
  28433   "RTN","CHM FAUT1",597 ,0)
  28434    . S ^TMP( $J,DENDOS, D3,CHMFPDI )=""
  28435   "RTN","CHM FAUT1",598 ,0)
  28436    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  28437   "RTN","CHM FAUT1",599 ,0)
  28438    I $G(CHMO PDI),$G(CH MOPGNM),$G (CHMOIMAG) ,$E($P($G( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN")),"^ ",7),3)=5  F  S D3=$O (^CHMIMAGE (CHMOPDI,1 ,CHMOPGNM, 2,CHMOIMAG ,"DENTAL-N S",D3)) Q: D3=""  D
  28439   "RTN","CHM FAUT1",600 ,0)
  28440    . S DENDO S=$P($G(^C HMIMAGE(CH MOPDI,1,CH MOPGNM,2,C HMOIMAG,"D ENTAL-NS", D3,0)),"^" ,1) ;
  28441   "RTN","CHM FAUT1",601 ,0)
  28442    . ;S ^TMP ($J,CHMOPD I,1,CHMOPG NM,2,CHMOI MAG,"DENTA L-NS",DEND OS,D3)=""
  28443   "RTN","CHM FAUT1",602 ,0)
  28444    . S ^TMP( $J,DENDOS, D3,CHMOPDI )=""
  28445   "RTN","CHM FAUT1",603 ,0)
  28446    ;
  28447   "RTN","CHM FAUT1",604 ,0)
  28448    ;F  S L=$ O(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"DENTAL- NS",L)) Q: L=""  D S  DENDOS=""  ;  wtc 8/8 /17
  28449   "RTN","CHM FAUT1",605 ,0)
  28450    S DENDOS= "" ;
  28451   "RTN","CHM FAUT1",606 ,0)
  28452    ;F  S DEN DOS=$O(^TM P($J,CHMFP DI,1,CHMFP GNM,2,CHMF IMAG,"DENT AL-NS",DEN DOS)) Q:DE NDOS=""  D   ; wtc 8/ 8/17
  28453   "RTN","CHM FAUT1",607 ,0)
  28454    ;. F  S D 3=$O(^TMP( $J,CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"DENTAL -NS",DENDO S,D3)) Q:D 3=""  D  ;  wtc 8/8/1 7
  28455   "RTN","CHM FAUT1",608 ,0)
  28456    F  S DEND OS=$O(^TMP ($J,DENDOS )) Q:DENDO S=""  D  ;  wtc 8/8/1 7
  28457   "RTN","CHM FAUT1",609 ,0)
  28458    . S D3=""  F  S D3=$ O(^TMP($J, DENDOS,D3) ) Q:D3=""   D  ; wtc  8/8/17
  28459   "RTN","CHM FAUT1",610 ,0)
  28460    .. S D4=" " F  S D4= $O(^TMP($J ,DENDOS,D3 ,D4)) Q:D4 =""  D  ;b db 8/15/20 176
  28461   "RTN","CHM FAUT1",611 ,0)
  28462    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  28463   "RTN","CHM FAUT1",612 ,0)
  28464    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=$G(CHMOP DI),CHMFPG N1=$G(CHMO PGNM),CHMF IMA1=$G(CH MOIMAG)
  28465   "RTN","CHM FAUT1",613 ,0)
  28466    ...S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  28467   "RTN","CHM FAUT1",614 ,0)
  28468    ...S INFO =$G(^CHMIM AGE(CHMFPD I1,1,CHMFP GN1,2,CHMF IMA1,"DENT AL-NS",D3, 0)) ; chan ge L to D3  wtc 8/8/1 7
  28469   "RTN","CHM FAUT1",615 ,0)
  28470    ...S INFO 2=$G(^CHMI MAGE(CHMFP DI1,1,CHMF PGN1,2,CHM FIMA1,"DEN TAL-NS",D3 ,1,1,0)) ; JEH 2/1/11  DEV007820  ; change  L to D3 wt c 8/8/17
  28471   "RTN","CHM FAUT1",616 ,0)
  28472    ...;&(INF O2="")         ;JEH 2 /1/11 DEV0 07820
  28473   "RTN","CHM FAUT1",617 ,0)
  28474    ...Q:INFO =""
  28475   "RTN","CHM FAUT1",618 ,0)
  28476    ...S SPBE N=$P(INFO, "^",2)_"/" _$P(INFO," ^",3) ;BDB
  28477   "RTN","CHM FAUT1",619 ,0)
  28478    ...; JSG; 01/29/08;D EV003956-0 2;Make DOS OUT = "__/ __/__^" fo r null DOS
  28479   "RTN","CHM FAUT1",620 ,0)
  28480    ...; S DO S=$P(INFO, "^",1) S:D OS]"" DOSO UT=$$DOS^C HMFAUT0(DO S)                  ; JSG;OC
  28481   "RTN","CHM FAUT1",621 ,0)
  28482    ...S DOS= $P(INFO,"^ ",1) S DOS OUT=$S(DOS ]"":$$DOS^ CHMFAUT0(D OS),1:"__/ __/__^") ; JSG;NC: St uff it, if  ""
  28483   "RTN","CHM FAUT1",622 ,0)
  28484    ...S POS= $P(INFO,"^ ",2) S:POS ="" POS=3  S:POS]"" P OSOUT=$$PO S^CHMFAUT0 (POS)
  28485   "RTN","CHM FAUT1",623 ,0)
  28486    ...S CHG= $P(INFO,"^ ",8)
  28487   "RTN","CHM FAUT1",624 ,0)
  28488    ...S ICD= $P(INFO,"^ ",10) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  28489   "RTN","CHM FAUT1",625 ,0)
  28490    ...S MOD= $P(INFO,"^ ",9) I MOD ]"" S MODO UT=$$MOD^C HMFAUT0(MO D),MOD=$P( MODOUT,"^" ,1)                                          ;JEH 2/1/ 11 DEV0078 20
  28491   "RTN","CHM FAUT1",626 ,0)
  28492    ...S MOD2 =$P(INFO," ^",20) I M OD2]"" S M ODOUT=MODO UT_"*"_$$M OD^CHMFAUT 0(MOD2),MO D2=$P($P(M ODOUT,"*", 2),"^",1)      ;JEH 2 /1/11 DEV0 07820
  28493   "RTN","CHM FAUT1",627 ,0)
  28494    ...S MOD3 =$P(INFO," ^",21) S:M OD3]"" MOD OUT=MODOUT _"*"_$$MOD ^CHMFAUT0( MOD3),MOD3 =$P($P(MOD OUT,"*",3) ,"^",1)                 ;JEH 2/1 /11 DEV007 820
  28495   "RTN","CHM FAUT1",628 ,0)
  28496    ...S MOD4 =$P(INFO," ^",22) S:M OD4]"" MOD OUT=MODOUT _"*"_$$MOD ^CHMFAUT0( MOD4),MOD4 =$P($P(MOD OUT,"*",4) ,"^",1)                 ;JEH 2/1 /11 DEV007 820
  28497   "RTN","CHM FAUT1",629 ,0)
  28498    ...S MODO UT=MOD_MOD 2_MOD3_MOD 4_"*"_MODO UT ;JEH 2/ 1/11 DEV00 7820
  28499   "RTN","CHM FAUT1",630 ,0)
  28500    ...S:$P(M ODOUT,"*", 1)="" MODO UT="" ;JEH  2/1/11 DE V007820
  28501   "RTN","CHM FAUT1",631 ,0)
  28502    ...; S CP T=$P(INFO, "^",7) S:C PT]"" CPTO UT=$$PROC^ CHMFAUT0(C PT,DOS)                  ;JSG;OC
  28503   "RTN","CHM FAUT1",632 ,0)
  28504    ...D:$G(% )="" NOW^% DTC ;JEH 8 /29/08 TT  #DEV005596   ADDED LI NE
  28505   "RTN","CHM FAUT1",633 ,0)
  28506    ...S CPT= $P(INFO,"^ ",7) S:CPT ]"" CPTOUT ="SV*"_$$P ROC^CHMFAU T0(CPT,$S( DOS]"":DOS ,1:%\1)) ; JSG;NC;Fak e DOS to g et Procedu re            ;JEH 2/ 1/11 DEV00 7820
  28507   "RTN","CHM FAUT1",634 ,0)
  28508    ...S REV= $P(INFO,"^ ",14) S:RE V]"" REVOU T=$$REV^CH MFAUT0(REV )
  28509   "RTN","CHM FAUT1",635 ,0)
  28510    ...S EDIL ID=$P(INFO ,"^",16) ; JEH 2/1/11  DEV007820
  28511   "RTN","CHM FAUT1",636 ,0)
  28512    ...S UNT= $P(INFO,"^ ",17)
  28513   "RTN","CHM FAUT1",637 ,0)
  28514    ...S MEDP YMT=$P(INF O,"^",18)
  28515   "RTN","CHM FAUT1",638 ,0)
  28516    ...S BENP YMT=$P(INF O,"^",6)
  28517   "RTN","CHM FAUT1",639 ,0)
  28518    ...S (OHI PDAMT,OHIP RESP,ADDOH IPY,OHIPRB AL,MEDICDP D,TPLPAID, COSTUNT,NM UNTALL,CAL LDAMT,DEDC TAMT,CSTSH AMT,PYMNTA MT,PATPDAM T,CCAPLAMT )="" ;JEH  2/1/11 DEV 007820
  28519   "RTN","CHM FAUT1",640 ,0)
  28520    ...S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT                                       JEH 2/1/ 11 DEV0078 20
  28521   "RTN","CHM FAUT1",641 ,0)
  28522    ...S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y              JEH 2/ 1/11 DEV00 7820
  28523   "RTN","CHM FAUT1",642 ,0)
  28524    ...S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS    JEH  2/1/11 DEV 007820
  28525   "RTN","CHM FAUT1",643 ,0)
  28526    ...S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE                                     JEH 2/1/ 11 DEV0078 20
  28527   "RTN","CHM FAUT1",644 ,0)
  28528    ...S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID                                       JEH 2/1/ 11 DEV0078 20
  28529   "RTN","CHM FAUT1",645 ,0)
  28530    ...S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D                                                   JE H 2/1/11 D EV007820
  28531   "RTN","CHM FAUT1",646 ,0)
  28532    ...S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT                                                  JE H 2/1/11 D EV007820
  28533   "RTN","CHM FAUT1",647 ,0)
  28534    ...S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED                                    JEH 2/1/ 11 DEV0078 20
  28535   "RTN","CHM FAUT1",648 ,0)
  28536    ...S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT                JEH 2/ 1/11 DEV00 7820
  28537   "RTN","CHM FAUT1",649 ,0)
  28538    ...S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT                                 JEH 2/1/ 11 DEV0078 20
  28539   "RTN","CHM FAUT1",650 ,0)
  28540    ...S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT                                     JEH 2/1/ 11 DEV0078 20
  28541   "RTN","CHM FAUT1",651 ,0)
  28542    ...S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT                                     JEH 2/1/ 11 DEV0078 20
  28543   "RTN","CHM FAUT1",652 ,0)
  28544    ...S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T                                  JEH 2/1/ 11 DEV0078 20
  28545   "RTN","CHM FAUT1",653 ,0)
  28546    ...S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT                      JEH 2/ 1/11 DEV00 7820
  28547   "RTN","CHM FAUT1",654 ,0)
  28548    ...S ADIS TRO=$P(^CH MIMAGE(CHM FPDI1,0)," ^",16) ;AU TO DISTRIB UTION  JEH  2/1/11 DE V007820
  28549   "RTN","CHM FAUT1",655 ,0)
  28550    ...; I '$ L($G(DOS)) !'$G(POS)  W !,"*** D OS or POS  missing! * **" H 5 Q  ;JSG;OC;Do n't need
  28551   "RTN","CHM FAUT1",656 ,0)
  28552    ...I DOS] "" D           ;JSG;N C;We only  want to do  this sect ion if DOS  originall y not ""
  28553   "RTN","CHM FAUT1",657 ,0)
  28554    ....S:'$D (CHHOLDPY( DOS,POS))  CHHOLDPY(D OS,POS)=""
  28555   "RTN","CHM FAUT1",658 ,0)
  28556    ....I MED PYMT'="" D
  28557   "RTN","CHM FAUT1",659 ,0)
  28558    .....S $P (CHHOLDPY( DOS,POS)," ^",1)=$P(C HHOLDPY(DO S,POS),"^" ,1)+MEDPYM T
  28559   "RTN","CHM FAUT1",660 ,0)
  28560    ....;I BE NPYMT'=""  I BENPYMT  D     ;JEH  2/1/11 DE V007820
  28561   "RTN","CHM FAUT1",661 ,0)
  28562    ....I BEN PYMT'="" D         ;J EH 2/1/11  DEV007820
  28563   "RTN","CHM FAUT1",662 ,0)
  28564    .....S $P (CHHOLDPY( DOS,POS)," ^",2)=$P(C HHOLDPY(DO S,POS),"^" ,2)+BENPYM T
  28565   "RTN","CHM FAUT1",663 ,0)
  28566    ....S PRA MOUNT=""     ;SKD 9-2 7-07 DEV00 3378
  28567   "RTN","CHM FAUT1",664 ,0)
  28568    ....I $P( CHHOLDPY(D OS,POS),"^ ",3)="" I  VFN'="" I  $D(^CHMIMA GE(CHMFPDI 1,"ZOHI",D FN,BFN,CHM FSERV,DOS, POS,VFN))  D
  28569   "RTN","CHM FAUT1",665 ,0)
  28570    .....;S O HIPYMT=^CH MIMAGE(CHM FPDI1,"ZOH I",DFN,BFN ,CHMFSERV, DOS,POS,VF N)  ;SKD M C284 12-15 -06
  28571   "RTN","CHM FAUT1",666 ,0)
  28572    .....S PR AMOUNT=$P( $G(^CHMIMA GE(CHMFPDI 1,"ZOHI",D FN,BFN,CHM FSERV,DOS, POS,VFN)), U,2)  ;SKD  MC284 12- 15-06
  28573   "RTN","CHM FAUT1",667 ,0)
  28574    .....;S $ P(CHHOLDPY (DOS,POS), "^",3)=$FN (OHIPYMT," ",2)   ;SK D MC284 12 -15-06
  28575   "RTN","CHM FAUT1",668 ,0)
  28576    .....I $G (PRAMOUNT)  S $P(CHHO LDPY(DOS,P OS),"^",3) =$FN(PRAMO UNT,"",2)    ;SKD MC2 84 12-15-0 6
  28577   "RTN","CHM FAUT1",669 ,0)
  28578    ...I TPLP AID'="" I  TPLPAID D
  28579   "RTN","CHM FAUT1",670 ,0)
  28580    ....S $P( CHHOLDPY(D OS,POS),"^ ",4)=$P(CH HOLDPY(DOS ,POS),"^", 4)+TPLPAID
  28581   "RTN","CHM FAUT1",671 ,0)
  28582    ... ;
  28583   "RTN","CHM FAUT1",672 ,0)
  28584    ... ;  Do  not outpu t line if  it has nei ther diagn osis (ICD)  nor reven ue code (R EV) - wtc  8/10/17
  28585   "RTN","CHM FAUT1",673 ,0)
  28586    ... ;
  28587   "RTN","CHM FAUT1",674 ,0)
  28588    ... I ICD '=""!(REV' ="") D  ;
  28589   "RTN","CHM FAUT1",675 ,0)
  28590    ....S L=L +1 D PREOU TL^CHMFAUT 1 ; Increm ent L wtc  8/8/17
  28591   "RTN","CHM FAUT1",676 ,0)
  28592    ....S SVL =L       ; JEH 2/1/11  DEV007820
  28593   "RTN","CHM FAUT1",677 ,0)
  28594    ...Q
  28595   "RTN","CHM FAUT1",678 ,0)
  28596    ..Q
  28597   "RTN","CHM FAUT1",679 ,0)
  28598    .Q
  28599   "RTN","CHM FAUT1",680 ,0)
  28600    Q
  28601   "RTN","CHM FAUT1",681 ,0)
  28602    ;
  28603   "RTN","CHM FAUT1",682 ,0)
  28604   PRERX ; Pr eload RX
  28605   "RTN","CHM FAUT1",683 ,0)
  28606    N L,INFO, SPBEN,SPON ,BEN,DOS,C HGAMT,QTY, CPT,ICD,BE NPYMT,MEDP YMT,OHIPYM T,PRAMOUNT    ;SKD 9- 27-07 DEV0 03378
  28607   "RTN","CHM FAUT1",684 ,0)
  28608    N DOSOUT, CPTOUT,ICD OUT
  28609   "RTN","CHM FAUT1",685 ,0)
  28610    K CHEQP,C HPHARR
  28611   "RTN","CHM FAUT1",686 ,0)
  28612    S L=""
  28613   "RTN","CHM FAUT1",687 ,0)
  28614    F  S L=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"RX-NS",L )) Q:L=""   D
  28615   "RTN","CHM FAUT1",688 ,0)
  28616    .S (DOAOU T,DODOUT,P OSOUT,ICDO UT,DSTATOU T)=""
  28617   "RTN","CHM FAUT1",689 ,0)
  28618    .S INFO=$ G(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"RX-NS", L,0))
  28619   "RTN","CHM FAUT1",690 ,0)
  28620    .Q:INFO=" "
  28621   "RTN","CHM FAUT1",691 ,0)
  28622    .S SPBEN= $P(INFO,"^ ",2)_"/"_$ P(INFO,"^" ,3)
  28623   "RTN","CHM FAUT1",692 ,0)
  28624    .S SPON=$ P(INFO,"^" ,2),BEN=$P (INFO,"^", 3)
  28625   "RTN","CHM FAUT1",693 ,0)
  28626    .S DOS=$P (INFO,"^", 1) S:DOS]" " DOSOUT=$ $DOS^CHMFA UT0(DOS)
  28627   "RTN","CHM FAUT1",694 ,0)
  28628    .S ICD=$P (INFO,"^", 11) S:ICD] "" ICDOUT= $$ICD^CHMF AUT0(ICD)
  28629   "RTN","CHM FAUT1",695 ,0)
  28630    .S:ICDOUT ]"" ICDOUT =$P(ICDOUT ,"^")_"^"_ $P(ICDOUT, "^",2)
  28631   "RTN","CHM FAUT1",696 ,0)
  28632    .S CHGAMT =$P(INFO," ^",8)
  28633   "RTN","CHM FAUT1",697 ,0)
  28634    .S PDX=$P (INFO,"^", 7) S:PDX]" " CPTOUT=$ $PDX^CHMFA UT0(PDX)
  28635   "RTN","CHM FAUT1",698 ,0)
  28636    .S QTY=$P (INFO,"^", 12)
  28637   "RTN","CHM FAUT1",699 ,0)
  28638    .S MEDPYM T=$P(INFO, "^",13)
  28639   "RTN","CHM FAUT1",700 ,0)
  28640    .S BENPYM T=$P(INFO, "^",5)
  28641   "RTN","CHM FAUT1",701 ,0)
  28642    .;S OHIPY MT=$P(INFO ,"^",9)        ;SKD M C284 12-15 -06
  28643   "RTN","CHM FAUT1",702 ,0)
  28644    .S PRAMOU NT=""                     ;SKD 9 -27-07 DEV 003378
  28645   "RTN","CHM FAUT1",703 ,0)
  28646    .S PRAMOU NT=$P($G(I NFO),"^",9 )   ;SKD M C284 12-15 -06
  28647   "RTN","CHM FAUT1",704 ,0)
  28648    .D PRERXL
  28649   "RTN","CHM FAUT1",705 ,0)
  28650    .Q
  28651   "RTN","CHM FAUT1",706 ,0)
  28652    Q
  28653   "RTN","CHM FAUT1",707 ,0)
  28654   PRERXL ;   RX load in to CHEQP a rray
  28655   "RTN","CHM FAUT1",708 ,0)
  28656    S CHEQP(S PBEN,L,0)= L
  28657   "RTN","CHM FAUT1",709 ,0)
  28658    S CHEQP(S PBEN,L,1)= DOSOUT
  28659   "RTN","CHM FAUT1",710 ,0)
  28660    S CHEQP(S PBEN,L,2)= MEDPYMT
  28661   "RTN","CHM FAUT1",711 ,0)
  28662    S CHEQP(S PBEN,L,3)= BENPYMT
  28663   "RTN","CHM FAUT1",712 ,0)
  28664    ;S CHEQP( SPBEN,L,4) =OHIPYMT     ;SKD MC2 84 12-15-0 6
  28665   "RTN","CHM FAUT1",713 ,0)
  28666    S CHEQP(S PBEN,L,4)= $G(PRAMOUN T)    ;SKD  MC284 12- 15-06
  28667   "RTN","CHM FAUT1",714 ,0)
  28668    S CHEQP(S PBEN,L,5)= ""  ; WHAT  NEEDS TO  BE HERE
  28669   "RTN","CHM FAUT1",715 ,0)
  28670    S CHPHARR (SPON,BEN, L)=DOSOUT_ "^"_QTY_"^ ^"_CPTOUT_ "^"_CHGAMT _"^"_ICDOU T
  28671   "RTN","CHM FAUT1",716 ,0)
  28672    Q
  28673   "RTN","CHM FBC1")
  28674   0^55^B7140 8427
  28675   "RTN","CHM FBC1",1,0)
  28676   CHMFBC1 ;S FH/DEN;DET ERMINES AL LOWABLE CH ARGES FOR  INPT CLAIM S;10/15/97   12:08 PM
  28677   "RTN","CHM FBC1",2,0)
  28678    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  28679   "RTN","CHM FBC1",3,0)
  28680    ;CPTS #10 846* - PEJ  8/15/96
  28681   "RTN","CHM FBC1",4,0)
  28682    ;CPTS #11 773 BY DTP  (9-MAY-97 )
  28683   "RTN","CHM FBC1",5,0)
  28684    ;CPT 9738  7/2/97 *C R*
  28685   "RTN","CHM FBC1",6,0)
  28686    ;CPTS #11 959 BY DTP  (16-JUL-9 7)
  28687   "RTN","CHM FBC1",7,0)
  28688    ;CPT 1197 3 7/21/97  *CR*
  28689   "RTN","CHM FBC1",8,0)
  28690    ;G SECTIM :$P(^CHMPA Y(CI,"COMM ON"),"^",8 )'=""
  28691   "RTN","CHM FBC1",9,0)
  28692    ;G ENHBG: $P(^CHMPAY (CI,"COMMO N"),"^",8) ="DRG"
  28693   "RTN","CHM FBC1",10,0 )
  28694    ;BMJ 5/9/ 11 DEF0120 92
  28695   "RTN","CHM FBC1",11,0 )
  28696    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  28697   "RTN","CHM FBC1",12,0 )
  28698   A1 S CHMFC HGS=$P(^CH MPAY(CI,"C OMMON"),"^ ") 
  28699   "RTN","CHM FBC1",13,0 )
  28700    S CHMFDOB =$P(^AHCHV A(AI,100,A J,0),"^",3 )
  28701   "RTN","CHM FBC1",14,0 )
  28702    S X=CHMFD OB D H^%DT C S HBD=%H
  28703   "RTN","CHM FBC1",15,0 )
  28704    S CHMADMD T=$P(^CHMP AY(CI,0)," ^",8),CHPG PT=$P(^(0) ,"^",27)
  28705   "RTN","CHM FBC1",16,0 )
  28706    S X=CHMAD MDT D H^%D TC S HADT= %H
  28707   "RTN","CHM FBC1",17,0 )
  28708    S CHMFDCD T=$P(^CHMP AY(CI,"INP "),"^")
  28709   "RTN","CHM FBC1",18,0 )
  28710    S X=CHMFD CDT D H^%D TC S HDDT= %H
  28711   "RTN","CHM FBC1",19,0 )
  28712    S CHMFLOS =HDDT-HADT  S:CHMFLOS <1 CHMFLOS =1
  28713   "RTN","CHM FBC1",20,0 )
  28714    I $P(^CHM PAY(CI,"IN P"),"^",2) '="" S:$D( ^CHMDIC(74 1002.39,"B ",$P(^CHMP AY(CI,"INP "),"^",2)) ) CHMFLOS= CHMFLOS+1
  28715   "RTN","CHM FBC1",21,0 )
  28716    S CHMFRDT =9999999-C HMFDCDT,CH MFRSD=CHMF RDT-1
  28717   "RTN","CHM FBC1",22,0 )
  28718    S:$E(CHMA DMDT,4,7)> 1000 CHFYR =($E(CHMAD MDT,1,3)+1 )_"0000"
  28719   "RTN","CHM FBC1",23,0 )
  28720    S:$E(CHMA DMDT,4,7)< 1000 CHFYR =$E(CHMADM DT,1,3)_"0 000"
  28721   "RTN","CHM FBC1",24,0 )
  28722   DR S VI=$P (^CHMPAY(C I,0),"^",3 )
  28723   "RTN","CHM FBC1",25,0 )
  28724    G:$P(^CHM PAY(CI,0), "^",27)'=1  DR3
  28725   "RTN","CHM FBC1",26,0 )
  28726    ;CPE VEND OR STREAML INING Repl ace Provid er Zip wit h PL-ZIP -  CPE001-00 2 PL-ZIP 0 5/24/2017  GEF
  28727   "RTN","CHM FBC1",27,0 )
  28728    ;S:VI'=""  VZ=$E($P( ^CHMVEN(VI ,2),"^",5) ,1,5),VST= $P(^(2),"^ ",4)
  28729   "RTN","CHM FBC1",28,0 )
  28730    S:VI'=""  VST=$P(^CH MVEN(VI,2) ,"^",4)
  28731   "RTN","CHM FBC1",29,0 )
  28732    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  28733   "RTN","CHM FBC1",30,0 )
  28734    I VI="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": V ENDOR ID M ISSING" G  END
  28735   "RTN","CHM FBC1",31,0 )
  28736    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END
  28737   "RTN","CHM FBC1",32,0 )
  28738    I VZ="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP MISS ING" G END
  28739   "RTN","CHM FBC1",33,0 )
  28740    I VST=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR STA TE MISSING " G END
  28741   "RTN","CHM FBC1",34,0 )
  28742    S VC=$O(^ CHMSMSA("Z IP",VZ,VST ,0))
  28743   "RTN","CHM FBC1",35,0 )
  28744    I VC="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP UNKN OWN OR INC OMPATIBLE  WITH STATE " Q
  28745   "RTN","CHM FBC1",36,0 )
  28746    S RI=$P(^ CHMSMSA(VS T,1,VC,0), "^",3),PL= $S(RI="":6 ,RI=0:4,1: 2)
  28747   "RTN","CHM FBC1",37,0 )
  28748    I RI="" S  RE=$O(^CH MSMSA(VST, 3,CHMFRSD) ) S:RE AW= $P(^CHMSMS A(VST,3,RE ,0),"^",2)  G DR2
  28749   "RTN","CHM FBC1",38,0 )
  28750    S RE=$O(^ CHMSMSA(VS T,1,VC,2,C HMFRSD))
  28751   "RTN","CHM FBC1",39,0 )
  28752    I 'RE S R E=$O(^CHMS MSA(VST,3, CHMFRSD))  S:RE AW=$P (^CHMSMSA( VST,3,RE,0 ),"^",2)
  28753   "RTN","CHM FBC1",40,0 )
  28754    E  S:RE A W=$P(^CHMS MSA(VST,1, VC,2,RE,0) ,"^",2)
  28755   "RTN","CHM FBC1",41,0 )
  28756   DR2 I '$D( AW) S CHMF QUE=10,CHM MDP=CHMMDP _": AWI IN FORMATION  MISSING" Q
  28757   "RTN","CHM FBC1",42,0 )
  28758    I AW="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": A WI INFORMA TION MISSI NG" Q
  28759   "RTN","CHM FBC1",43,0 )
  28760   DR3 S (CHP SDU,CHRHU, CHRTC)=0
  28761   "RTN","CHM FBC1",44,0 )
  28762    I $D(^CHM VEN(VI,1))  S FTN=$P( ^CHMVEN(VI ,1),"^",7)  S:FTN=""  FTN=1
  28763   "RTN","CHM FBC1",45,0 )
  28764    I $D(^CHM VEN(VI,1))  S FT=$P(^ CHMDIC(741 002.11,FTN ,0),"^")
  28765   "RTN","CHM FBC1",46,0 )
  28766    S CHBGNDT =$O(^CHMVE N(VI,81,CH MFDCDT),-1 ) I CHBGND T D
  28767   "RTN","CHM FBC1",47,0 )
  28768    .Q:'$D(^C HMVEN(VI,8 1,CHBGNDT, 0))
  28769   "RTN","CHM FBC1",48,0 )
  28770    .I $P(^(0 ),"^",5)'= "" Q:$P(^( 0),"^",5)< CHMFDCDT
  28771   "RTN","CHM FBC1",49,0 )
  28772    .S:$P(^(0 ),"^",2)'= "" CHPSDU= 1
  28773   "RTN","CHM FBC1",50,0 )
  28774    S CHBGNDT =$O(^CHMVE N(VI,82,CH MFDCDT),-1 ) I CHBGND T D
  28775   "RTN","CHM FBC1",51,0 )
  28776    .Q:'$D(^C HMVEN(VI,8 2,CHBGNDT, 0))
  28777   "RTN","CHM FBC1",52,0 )
  28778    .I $P(^(0 ),"^",5)'= "" Q:$P(^( 0),"^",5)< CHMFDCDT
  28779   "RTN","CHM FBC1",53,0 )
  28780    .S:$P(^(0 ),"^",2)'= "" CHRHU=1
  28781   "RTN","CHM FBC1",54,0 )
  28782    S CHBGNDT =$O(^CHMVE N(VI,83,CH MFDCDT),-1 ) I CHBGND T D
  28783   "RTN","CHM FBC1",55,0 )
  28784    .Q:'$D(^C HMVEN(VI,8 3,CHBGNDT, 0))
  28785   "RTN","CHM FBC1",56,0 )
  28786    .I $P(^(0 ),"^",6)'= "" Q:$P(^( 0),"^",6)< CHMFDCDT
  28787   "RTN","CHM FBC1",57,0 )
  28788    .S:$P(^(0 ),"^",2)'= "" CHRTC=1
  28789   "RTN","CHM FBC1",58,0 )
  28790    ;S:$D(^CH MVEN(VI,0) ) CHPSDU=+ $P(^CHMVEN (VI,0),"^" ,19),CHRHU =+$P(^CHMV EN(VI,0)," ^",21),CHR TC=+$P(^CH MVEN(VI,0) ,"^",22)
  28791   "RTN","CHM FBC1",59,0 )
  28792    I $P(^CHM PAY(CI,0), "^",27)=1  I FT="FN"  S $P(^CHMP AY(CI,"RUL E-PROC",1, 0),"^")=2, $P(^CHMPAY (CI,"RULE- PROC",1,0) ,"^",2)=$P (^CHMDIC(7 41002.34,1 ,1),"^",17 ),CHMFCAA= 0 G END
  28793   "RTN","CHM FBC1",60,0 )
  28794    S (DCB,DA B,NM)=0 F  ZZZ=0:0 S  NM=$O(^CHM PAY(CI,"IN P-DX",NM))  Q:NM'?1N. N  S K2="I NP-DX",K1= "RULE-DX"  D CK
  28795   "RTN","CHM FBC1",61,0 )
  28796    S NM=0 F  ZZZ=0:0 S  NM=$O(^CHM PAY(CI,"IN P-PROC",NM )) Q:NM'?1 N.N  S K2= "INP-PROC" ,K1="RULE- PROC" D CK
  28797   "RTN","CHM FBC1",62,0 )
  28798    ;D ^CHMFB CSS G END: $D(CHMFQUE )
  28799   "RTN","CHM FBC1",63,0 )
  28800    K CHGFL S  DN=0 F  S  DN=$O(^CH MPAY(CI,"R ULE-DX",DN )) Q:'DN   I $D(^CHMP AY(CI,"RUL E-DX",DN,0 )) I $P(^( 0),"^",1)' =0 S CHGFL =1
  28801   "RTN","CHM FBC1",64,0 )
  28802    S DN=0 F   S DN=$O(^ CHMPAY(CI, "INP-DX",D N)) Q:'DN   I $D(^CHM PAY(CI,"IN P-DX",DN,0 )) I $P(^( 0),"^",1)' ="" I $D(^ CHMICDX($P (^CHMPAY(C I,"INP-DX" ,DN,0),"^" ,1),0)) K: $P(^(0),"^ ",2)="000. 00" CHGFL
  28803   "RTN","CHM FBC1",65,0 )
  28804    I '$D(CHG FL) S CHMF QUE=12 D P ROC^CHMFBC 2 G END
  28805   "RTN","CHM FBC1",66,0 )
  28806    I $P(^CHM PAY(CI,0), "^",27)=2  S CHMFNP=1  D ^CHMFBC 1C G END
  28807   "RTN","CHM FBC1",67,0 )
  28808    S CHBGNDT =$O(^CHMVE N(VI,80,CH MFDCDT),-1 ) I CHBGND T D  I $D( CHMFNP) G  END:$D(CHM FQUE) D ^C HMFBC1C G  END
  28809   "RTN","CHM FBC1",68,0 )
  28810    .Q:'$D(^C HMVEN(VI,8 0,CHBGNDT, 0))
  28811   "RTN","CHM FBC1",69,0 )
  28812    .I $P(^(0 ),"^",5)'= "" Q:$P(^( 0),"^",5)< CHMFDCDT
  28813   "RTN","CHM FBC1",70,0 )
  28814    .S:$P(^(0 ),"^",2)=" " CHMFNP=1
  28815   "RTN","CHM FBC1",71,0 )
  28816    ;I $D(^CH MVEN(VI,1) ),$P(^CHMV EN(VI,1)," ^",8)=1 G  END:$D(CHM FQUE) S CH MFNP=1 D ^ CHMFBC1C G  END
  28817   "RTN","CHM FBC1",72,0 )
  28818    ;I (FT="R H")!(FT="L T")!(FT="S C")!(FT="C N")!(FT="C S")!(FT="S NF")!(FT=" DRU") G EN D:$D(CHMFQ UE) S CHMF NP=1 D ^CH MFBC1C G E ND
  28819   "RTN","CHM FBC1",73,0 )
  28820    I $D(^CHM DIC(741002 .97,"B",FT N)) G END: $D(CHMFQUE ) S CHMFNP =1 D ^CHMF BC1C G END
  28821   "RTN","CHM FBC1",74,0 )
  28822    S CHMFIP= 1,(L,PCB,P AB)=0 F  S  L=$O(^CHM PAY(CI,"IN P-PROC",L) ) Q:L'?1N. N  I $D(^C HMPAY(CI," RULE-PROC" ,L,0)) I $ P(^(0),"^" ,1)'=0 S N M=$P(^CHMP AY(CI,"INP -PROC",L,0 ),"^") I $ D(^CHMSERV (NM,0)) S: $P(^(0),"^ ",2)=1 PCB =1 S:$P(^( 0),"^",2)= 0 PAB=1
  28823   "RTN","CHM FBC1",75,0 )
  28824    S PTAGYR= ((HADT-HBD )/365.25)\ 1
  28825   "RTN","CHM FBC1",76,0 )
  28826    S:FT="CH"  PTAGDY=HA DT-HBD
  28827   "RTN","CHM FBC1",77,0 )
  28828    I (PTAGYR <18),(DCB! PCB) G END :$D(CHMFQU E) S CHMFN P=1 D ^CHM FBC1C G EN D
  28829   "RTN","CHM FBC1",78,0 )
  28830    I DAB!PAB  G END:$D( CHMFQUE) S  CHMFNP=1  D ^CHMFBC1 C G END
  28831   "RTN","CHM FBC1",79,0 )
  28832    I (PTAGYR <18),(FT=" CH"),(CHMA DMDT<28904 01) G END: $D(CHMFQUE ) S CHMFNP =1 D ^CHMF BC1C G END
  28833   "RTN","CHM FBC1",80,0 )
  28834   ENHBG S CN =$P(^CHMPA Y(CI,0),"^ ")
  28835   "RTN","CHM FBC1",81,0 )
  28836    G ^CHMJGR PR:'$D(^CH MPAY(CI,"C OMMON"))
  28837   "RTN","CHM FBC1",82,0 )
  28838    G ^CHMJGR PR:($P(^(" COMMON")," ^",8)="")! ($P(^("COM MON"),"^", 8)="DRG")
  28839   "RTN","CHM FBC1",83,0 )
  28840    ;I $P(^CH MPAY(CI,0) ,"^",27)=2  S CHMFNP= 1 D ^CHMFB C1C G END
  28841   "RTN","CHM FBC1",84,0 )
  28842   SECTIM S:$ D(CHD) $P( ^CHMPAY(CI ,"COMMON") ,"^",8)=CH D
  28843   "RTN","CHM FBC1",85,0 )
  28844    S (CHPSDR G,CHRHDRG, CHRTCDRG)= 0,CHMFDRG= $P(^CHMPAY (CI,"COMMO N"),"^",8) ,CHMFDRG=+ CHMFDRG
  28845   "RTN","CHM FBC1",86,0 )
  28846    ;S:(+CHMF DRG'=0) CH PSDRG=$P(^ CHMDIC(741 002.16,CHM FDRG,0),"^ ",5),CHRHD RG=$P(^CHM DIC(741002 .16,CHMFDR G,0),"^",6 ),CHRTCDRG =$P(^CHMDI C(741002.1 6,CHMFDRG, 0),"^",7)    ;SKD, 8- 17-09, DEV 006223
  28847   "RTN","CHM FBC1",87,0 )
  28848    S:(+CHMFD RG'=0) CHP SDRG=$$GET PSYFG^CHFB C1(CHMFDCD T),CHRHDRG =$P(^CHMDI C(741002.1 6,CHMFDRG, 0),"^",6), CHRTCDRG=$ P(^CHMDIC( 741002.16, CHMFDRG,0) ,"^",7)     ;SKD, 8-1 7-09, DEV0 06223
  28849   "RTN","CHM FBC1",88,0 )
  28850    I CHPSDRG ,CHRTC D ^ CHMFBC1C G  END
  28851   "RTN","CHM FBC1",89,0 )
  28852    I FT="RTC ",CHPSDRG  D ^CHMFBC1 C G END
  28853   "RTN","CHM FBC1",90,0 )
  28854    I CHPSDRG ,CHPSDU D  ^CHMFBC1C  G END
  28855   "RTN","CHM FBC1",91,0 )
  28856    I CHRHDRG ,CHRHU D ^ CHMFBC1C G  END
  28857   "RTN","CHM FBC1",92,0 )
  28858    I FT="PS" ,CHPSDRG D  ^CHMFBC1C  G END
  28859   "RTN","CHM FBC1",93,0 )
  28860    I FT="RH" ,CHRHDRG D  ^CHMFBC1C  G END
  28861   "RTN","CHM FBC1",94,0 )
  28862    ;Followin g line and  subroutin e CTCK add ed 1/13/92  by CR to  allow all
  28863   "RTN","CHM FBC1",95,0 )
  28864    ;Maryland  Inp. clai ms to calc  as billed .
  28865   "RTN","CHM FBC1",96,0 )
  28866    D:$D(^CHM DIC(741002 .51,"B",$P (^CHMVEN(V I,2),"^",4 ))) CTCK I  $D(CHMFNP ) D ^CHMFB C1C G END
  28867   "RTN","CHM FBC1",97,0 )
  28868    S FLG203= 0
  28869   "RTN","CHM FBC1",98,0 )
  28870    I $D(^CHM PAY(CI,"IN P")) S ZD= $P(^("INP" ),"^",2) I  ZD'="" I  $D(^CHMDIC (741002.12 ,ZD,0)) I  $E($P(^(0) ,"^",1),1) =3 D  I FL G203=1 G E ND
  28871   "RTN","CHM FBC1",99,0 )
  28872    .I ($P(@( GLPAY_"CI, ""COMMON"" )"),"^",16 )=3)!($P(@ (GLPAY_"CI ,""COMMON" ")"),"^",1 6)=4) D  Q  ;Added HV MH and LVM H for the  203 code ; BMJ 5/10/1 1 DEF01209 2
  28873   "RTN","CHM FBC1",100, 0)
  28874    ..I $P(@( GLPAY_"CI, 0)"),"^",1 3)=203 S $ P(@(GLPAY_ "CI,0)")," ^",13)=""
  28875   "RTN","CHM FBC1",101, 0)
  28876    .I $P(@(G LPAY_"CI," "COMMON"") "),"^",16) ="" D  Q
  28877   "RTN","CHM FBC1",102, 0)
  28878    ..I $P(@( GLPAY_"CI, 0)"),"^",1 3)=203 S $ P(@(GLPAY_ "CI,0)")," ^",13)=""
  28879   "RTN","CHM FBC1",103, 0)
  28880    .S CHMFQU E=35 S $P( ^CHMPAY(CI ,0),"^",13 )=$P(^CHMD IC(741002. 34,1,3),"^ ",8),FLG20 3=1
  28881   "RTN","CHM FBC1",104, 0)
  28882    I $D(^CHM PAY(CI,7))  S CHVAR=$ P(^CHMPAY( CI,7),"^", 6) I CHVAR '="" I $D( ^CHMXDIC(7 41201.46," C",0,CHVAR )) D  K CH VAR G END
  28883   "RTN","CHM FBC1",105, 0)
  28884    .S CHMFQU E=35,$P(^C HMPAY(CI,0 ),"^",13)= $P(^CHMDIC (741002.34 ,1,3),"^", 13)
  28885   "RTN","CHM FBC1",106, 0)
  28886    D ^CHMFBC 1D
  28887   "RTN","CHM FBC1",107, 0)
  28888   END I $D(^ CHMPAY(CI, "INP")) S: $P(^("INP" ),"^",10)  CHMFCAA=$P (^("INP"), "^",10)
  28889   "RTN","CHM FBC1",108, 0)
  28890    K BDXC,DX ,NDX,BDXA, NP,BPC,BPA ,PAB,PCB,Y R,X,L,Y,NM M,K1,K2,RN
  28891   "RTN","CHM FBC1",109, 0)
  28892    K FT,CHMF DOB,CH,PTA GYR,AW,NM, L,P,PL,HBD ,CHMX,EC,C HMFCHGS,CH MADMDT
  28893   "RTN","CHM FBC1",110, 0)
  28894    K HDDT,HA DT,VI,VZ,V ST,VC,RI,D L,CHPSDU,C HPSDRG,DAB ,DCB
  28895   "RTN","CHM FBC1",111, 0)
  28896    Q
  28897   "RTN","CHM FBC1",112, 0)
  28898   CTCK K CHM FNP,CHMSCT C Q:$P(^CH MVEN(VI,1) ,"^",16)=1
  28899   "RTN","CHM FBC1",113, 0)
  28900    S CHMSTAT E=$P(^CHMV EN(VI,2)," ^",4)
  28901   "RTN","CHM FBC1",114, 0)
  28902    S CTCI=$O (^CHMDIC(7 41002.51," B",CHMSTAT E,0)) Q:'C TCI
  28903   "RTN","CHM FBC1",115, 0)
  28904    I $D(^CHM DIC(741002 .51,CTCI,2 )) Q:$D(^C HMDIC(7410 02.51,CTCI ,2,"B",FTN ))
  28905   "RTN","CHM FBC1",116, 0)
  28906    S BGDT=CH MADMDT_".9 999999"
  28907   "RTN","CHM FBC1",117, 0)
  28908   CTC1 S BGD T=$O(^CHMD IC(741002. 51,CTCI,1, BGDT),-1)  Q:'BGDT
  28909   "RTN","CHM FBC1",118, 0)
  28910    Q:'$D(^CH MDIC(74100 2.51,CTCI, 1,BGDT,0))
  28911   "RTN","CHM FBC1",119, 0)
  28912    S TERM=$P (^(0),"^", 3) I TERM' ="" G:CHMA DMDT'<TERM  CTC2
  28913   "RTN","CHM FBC1",120, 0)
  28914    S CHMFNP= 1,CHMACTC= $P(^(0),"^ ",2),CHMSC TC=1
  28915   "RTN","CHM FBC1",121, 0)
  28916   CTC2 K TER M,BGDT,CTC I,CHMSTATE  Q
  28917   "RTN","CHM FBC1",122, 0)
  28918   CK K AHTS
  28919   "RTN","CHM FBC1",123, 0)
  28920    I K2="INP -DX" Q:'$D (^CHMPAY(C I,K2,NM,0) )  Q:$P(^C HMPAY(CI,K 2,NM,0),"^ ")=""
  28921   "RTN","CHM FBC1",124, 0)
  28922    I K2="INP -DX" D
  28923   "RTN","CHM FBC1",125, 0)
  28924    .S:$D(^CH MICDX($P(^ CHMPAY(CI, "INP-DX",N M,0),"^"), 102,CHPGPT ,0)) AHTS= $P(^(0),"^ ",2)
  28925   "RTN","CHM FBC1",126, 0)
  28926    .I '$D(AH TS) S CHPG PTI=0,CHPG PTI=$O(^CH MDIC(74100 2.94,"C"," CHAMPVA",0 )) S:$D(^C HMICDX($P( ^CHMPAY(CI ,"INP-DX", NM,0),"^") ,102,CHPGP TI)) AHTS= $P(^(CHPGP TI,0),"^", 2)
  28927   "RTN","CHM FBC1",127, 0)
  28928    I K2="INP -DX" S KK= $P(^CHMPAY (CI,"INP-D X",NM,0)," ^") I $D(^ CHMICDX(KK ,0)) S:$P( ^(0),"^",1 8)=1 DCB=1  S:$P(^(0) ,"^",18)=0  DAB=1
  28929   "RTN","CHM FBC1",128, 0)
  28930    I K2="INP -PROC" D  
  28931   "RTN","CHM FBC1",129, 0)
  28932    .S:$D(^CH MSERV($P(^ CHMPAY(CI, "INP-PROC" ,NM,0),"^" ),102,CHPG PT,0)) AHT S=$P(^(0), "^",2)
  28933   "RTN","CHM FBC1",130, 0)
  28934    .I '$D(AH TS) S CHPG PTI=0,CHPG PTI=$O(^CH MDIC(74100 2.94,"C"," CHAMPVA",0 )) S:$D(^C HMSERV($P( ^CHMPAY(CI ,"INP-PROC ",NM,0),"^ "),102,CHP GPTI,0)) A HTS=$P(^(0 ),"^",2)
  28935   "RTN","CHM FBC1",131, 0)
  28936    I '$D(AHT S) S CHMFQ UE=7,CHMMD P=CHMMDP_" : NO TEST" ,$P(^CHMPA Y(CI,K1,NM ,0),"^",2) =$P(^CHMDI C(741002.3 4,1,1),"^" ,12),$P(^C HMPAY(CI,K 1,NM,0),"^ ")=3 Q
  28937   "RTN","CHM FBC1",132, 0)
  28938    I AHTS=""  S CHMFQUE =7,CHMMDP= CHMMDP_":  NO TEST",$ P(^CHMPAY( CI,K1,NM,0 ),"^",2)=$ P(^CHMDIC( 741002.34, 1,1),"^",1 2),$P(^CHM PAY(CI,K1, NM,0),"^") =3 Q
  28939   "RTN","CHM FBC1",133, 0)
  28940    I '$D(^DI C(AHFILE,A HTS,0)) S  CHMFQUE=7, CHMMDP=CHM MDP_": NO  TEST",$P(^ CHMPAY(CI, K1,NM,0)," ^",2)=$P(^ CHMDIC(741 002.34,1,1 ),"^",12), $P(^CHMPAY (CI,K1,NM, 0),"^")=3  Q
  28941   "RTN","CHM FBC1",134, 0)
  28942    S:K2="INP -DX" CHMFC T=1,CHMFJP =NM S:K2=" INP-PROC"  CHMFCT=2,C HMFJP=NM
  28943   "RTN","CHM FBC1",135, 0)
  28944    S NMM=NM, KK2=K2 D ^ AHCJAE S N M=NMM,K2=K K2 S $P(^C HMPAY(CI,K 1,NM,0),"^ ")=AHDATA( AHSTV,1),R N=$O(^DIC( AHNODIC,"B ","REASON" ,0)),AHRTE =$O(^DIC(A HNODIC,"B" ,"ROUTE",0 ))
  28945   "RTN","CHM FBC1",136, 0)
  28946    I $D(AHDA TA(RN,1))  S $P(^CHMP AY(CI,K1,N M,0),"^",2 )=AHDATA(R N,1)
  28947   "RTN","CHM FBC1",137, 0)
  28948    S $P(^CHM PAY(CI,K1, NM,0),"^", 3)=$P(AHLT S,"^"),$P( ^CHMPAY(CI ,K1,NM,0), "^",4)=$P( AHLTS,"^", 2)
  28949   "RTN","CHM FBC1",138, 0)
  28950    S $P(^CHM PAY(CI,K1, NM,0),"^", 5)=$P(AHLT S,"^",3),$ P(^CHMPAY( CI,K1,NM,0 ),"^",6)=$ P(AHLTS,"^ ",4),$P(^C HMPAY(CI,K 1,NM,0),"^ ",7)=$P(AH LTS,"^",5)
  28951   "RTN","CHM FBC1",139, 0)
  28952    I $D(AHDA TA(AHRTE,1 )) S:AHDAT A(AHRTE,1) =1 CHMFQUE =5
  28953   "RTN","CHM FBC1",140, 0)
  28954    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4)) I ($P (^CHMPAY(C I,K1,NM,0) ,"^",2)="" )&('$D(AHD ATA(AHRTE, 1))) S $P( ^CHMPAY(CI ,K1,NM,0), "^",2)=$P( ^CHMDIC(74 1002.34,1, 1),"^",13) ,CHMFQUE=5
  28955   "RTN","CHM FBC1",141, 0)
  28956    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4)),$P(^C HMPAY(CI,K 1,NM,0),"^ ",2)=$P(^C HMDIC(7410 02.34,1,1) ,"^",13) S  CHMFQUE=5
  28957   "RTN","CHM FBC1",142, 0)
  28958    I $D(AHDA TA(AHRTE,1 )),AHDATA( AHRTE,1)=2 ,$D(CHMFQU E),(CHMFQU E'=5) S CH MFQUE=28
  28959   "RTN","CHM FBC1",143, 0)
  28960    I $D(AHDA TA(AHRTE,1 )),AHDATA( AHRTE,1)=2 ,'$D(CHMFQ UE) S CHMF QUE=28
  28961   "RTN","CHM FBC1",144, 0)
  28962    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4)),$P(^C HMPAY(CI,K 1,NM,0),"^ ",2)=$P(^C HMDIC(7410 02.34,1,1) ,"^",14),$ D(CHMFQUE) ,(CHMFQUE' =5) S CHMF QUE=28
  28963   "RTN","CHM FBC1",145, 0)
  28964    I ((AHDAT A(AHSTV,1) =2)!(AHDAT A(AHSTV,1) =4)),$P(^C HMPAY(CI,K 1,NM,0),"^ ",2)=$P(^C HMDIC(7410 02.34,1,1) ,"^",14),' $D(CHMFQUE ) S CHMFQU E=28
  28965   "RTN","CHM FBC1",146, 0)
  28966    I $D(CHMF QUE),((CHM FQUE=5)!(C HMFQUE=28) ) D:(K2="I NP-DX") DI AG^CHMFBC1 F D:(K2="I NP-PROC")  PROC^CHMFB C1F
  28967   "RTN","CHM FBC1",147, 0)
  28968    I AHDATA( AHSTV,1)=3  S:'$D(CHM FQUE) CHMF QUE=6,CHMM DP=CHMMDP_ ": FROM TE ST"
  28969   "RTN","CHM FBC1",148, 0)
  28970    I AHDATA( AHSTV,1)=- 1 S CHMFQU E=18
  28971   "RTN","CHM FBC1",149, 0)
  28972    Q
  28973   "RTN","CHM FBC1",150, 0)
  28974    
  28975   "RTN","CHM FBC2A")
  28976   0^56^B5966 8588
  28977   "RTN","CHM FBC2A",1,0 )
  28978   CHMFBC2A ; SFH/DEN;GE TS SMSA AN D MEI AMOU NTS FOR OP  PROC;08/2 7/97  9:56  AM
  28979   "RTN","CHM FBC2A",2,0 )
  28980    ;;1.0;CHA MPVA SYSTE M;**11,14* *;JULY 4,  1990;Build  9
  28981   "RTN","CHM FBC2A",3,0 )
  28982    ;CPTS #10 846*, 1123 3*, #11736 * (DTP,4-2 3-97)
  28983   "RTN","CHM FBC2A",4,0 )
  28984    ;CPTS #10 292*, 7/8/ 97 *CR*
  28985   "RTN","CHM FBC2A",5,0 )
  28986    ;CPTS #11 937*  7/11 /97 *CR*
  28987   "RTN","CHM FBC2A",6,0 )
  28988    ;CPTS #62 98 7/15/97  *CR*
  28989   "RTN","CHM FBC2A",7,0 )
  28990    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  28991   "RTN","CHM FBC2A",8,0 )
  28992    S CHMPF=0 ,CHMPFD=""  K ALLOW
  28993   "RTN","CHM FBC2A",9,0 )
  28994    S CHADOS= $P(^CHMPAY (CI,0),"^" ,8) G PF:C HADOS<2921 001
  28995   "RTN","CHM FBC2A",10, 0)
  28996    S VI=$P(^ CHMPAY(CI, 0),"^",3)  Q:VI=""
  28997   "RTN","CHM FBC2A",11, 0)
  28998    I $D(^CHM VEN(VI,1))  I $P(^(1) ,"^",16)=1  G END:K2= "DME-SUPPL Y"
  28999   "RTN","CHM FBC2A",12, 0)
  29000    G END:$P( ^CHMPAY(CI ,0),"^",27 )=2
  29001   "RTN","CHM FBC2A",13, 0)
  29002    ;
  29003   "RTN","CHM FBC2A",14, 0)
  29004   PHP G ASC: CHADOS<297 0801
  29005   "RTN","CHM FBC2A",15, 0)
  29006    G ASC:$P( ^CHMPAY(CI ,"COMMON") ,"^",2)=""
  29007   "RTN","CHM FBC2A",16, 0)
  29008    G ASC:$P( ^CHMDIC(74 1002.11,$P (^CHMPAY(C I,"COMMON" ),"^",2),0 ),"^",1)'= "PHP"
  29009   "RTN","CHM FBC2A",17, 0)
  29010    G ASC:'$D (^CHMDIC(7 41013.13," B",$P(^CHM PAY(CI,K2, NM,0),"^", 1)))
  29011   "RTN","CHM FBC2A",18, 0)
  29012    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  GEF
  29013   "RTN","CHM FBC2A",19, 0)
  29014    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END
  29015   "RTN","CHM FBC2A",20, 0)
  29016    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  29017   "RTN","CHM FBC2A",21, 0)
  29018    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  29019   "RTN","CHM FBC2A",22, 0)
  29020    I VZ="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP MISS ING" G END
  29021   "RTN","CHM FBC2A",23, 0)
  29022    S VC=$O(^ CHMSMSA("Z IP",VZ,0))  G ASC:'VC
  29023   "RTN","CHM FBC2A",24, 0)
  29024    G ASC:'$D (^CHMSMSA( VC,4,0))
  29025   "RTN","CHM FBC2A",25, 0)
  29026    S PHPDAT= $O(^CHMSMS A(VC,4,"B" ,CHADOS),- 1) G ASC:' PHPDAT
  29027   "RTN","CHM FBC2A",26, 0)
  29028    S PHPI=$O (^CHMSMSA( VC,4,"B",P HPDAT,0))  G ASC:'PHP I
  29029   "RTN","CHM FBC2A",27, 0)
  29030    G ASC:'$D (^CHMSMSA( VC,4,PHPI, 0))
  29031   "RTN","CHM FBC2A",28, 0)
  29032    S PHPF=$O (^CHMDIC(7 41013.13," B",$P(^CHM PAY(CI,K2, NM,0),"^", 1),0)) G A SC:'PHPF
  29033   "RTN","CHM FBC2A",29, 0)
  29034    S FDHD=$P (^CHMDIC(7 41013.13,P HPF,0),"^" ,2)
  29035   "RTN","CHM FBC2A",30, 0)
  29036    S CHMPF=$ P(^CHMSMSA (VC,4,PHPI ,0),"^",FD HD)
  29037   "RTN","CHM FBC2A",31, 0)
  29038    G ASC:+CH MPF=0
  29039   "RTN","CHM FBC2A",32, 0)
  29040    S CMAC(NM )=CHMPF
  29041   "RTN","CHM FBC2A",33, 0)
  29042    S $P(^CHM PAY(CI,"RU LE-PROC",N M,0),"^",9 )=5
  29043   "RTN","CHM FBC2A",34, 0)
  29044    G END
  29045   "RTN","CHM FBC2A",35, 0)
  29046   ASC S CHMS P=$P(^CHMP AY(CI,K2,N M,0),"^"), CHMSPC=$P( ^CHMSERV(C HMSP,0),"^ ",1)
  29047   "RTN","CHM FBC2A",36, 0)
  29048    G CMAC:$P (^CHMPAY(C I,"COMMON" ),"^",2)=" "
  29049   "RTN","CHM FBC2A",37, 0)
  29050    G CMAC:$P (^CHMDIC(7 41002.11,$ P(^CHMPAY( CI,"COMMON "),"^",2), 0),"^",1)' ="ASC"
  29051   "RTN","CHM FBC2A",38, 0)
  29052    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP   GEF
  29053   "RTN","CHM FBC2A",39, 0)
  29054    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END
  29055   "RTN","CHM FBC2A",40, 0)
  29056    G CMAC:$P (^CHMVEN(V I,1),"^",7 )="" S CHF AC=$P(^(1) ,"^",7)
  29057   "RTN","CHM FBC2A",41, 0)
  29058    G CMAC:($ P(^CHMDIC( 741002.11, CHFAC,0)," ^",1)'="AS F")&($P(^C HMDIC(7410 02.11,CHFA C,0),"^",1 )'="ASH")
  29059   "RTN","CHM FBC2A",42, 0)
  29060    G ASC1:'$ D(^CHMAGP( "B",CHMSPC ))
  29061   "RTN","CHM FBC2A",43, 0)
  29062    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP   GEF
  29063   "RTN","CHM FBC2A",44, 0)
  29064    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  29065   "RTN","CHM FBC2A",45, 0)
  29066    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END
  29067   "RTN","CHM FBC2A",46, 0)
  29068    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  29069   "RTN","CHM FBC2A",47, 0)
  29070    I VZ="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP MISS ING" G END
  29071   "RTN","CHM FBC2A",48, 0)
  29072    S VC=$O(^ CHMDIC(741 002.82,"B" ,VZ,0)) G  CMAC:'VC
  29073   "RTN","CHM FBC2A",49, 0)
  29074    S CHLDT=$ O(^CHMDIC( 741002.82, VC,1,99999 99),-1) G  CMAC:'CHLD T
  29075   "RTN","CHM FBC2A",50, 0)
  29076    G CMAC:'$ D(^CHMDIC( 741002.82, VC,1,CHLDT ,0)) S CHM SA=$P(^(0) ,"^",2)
  29077   "RTN","CHM FBC2A",51, 0)
  29078    F JJ=$L(C HMSA):1:3  S CHMSA="0 "_CHMSA
  29079   "RTN","CHM FBC2A",52, 0)
  29080    S CHMGPN= $O(^CHMAGP ("B",CHMSP C,0)) G CM AC:'CHMGPN
  29081   "RTN","CHM FBC2A",53, 0)
  29082    S CHGRDT= $O(^CHMAGP (CHMGPN,1, (CHADOS+1) ),-1) G CM AC:'CHGRDT
  29083   "RTN","CHM FBC2A",54, 0)
  29084    G CMAC:'$ D(^CHMAGP( CHMGPN,1,C HGRDT,0))  S CHGRP=+$ P(^(0),"^" ,2)
  29085   "RTN","CHM FBC2A",55, 0)
  29086    S CHMMPN= $O(^CHMART ("B",CHMSA ,0)) G CMA C:'CHMMPN
  29087   "RTN","CHM FBC2A",56, 0)
  29088    S CHMSDT= $O(^CHMART (CHMMPN,1, (CHADOS+1) ),-1) G CM AC:'CHMSDT
  29089   "RTN","CHM FBC2A",57, 0)
  29090    G CMAC:'$ D(^CHMART( CHMMPN,1,C HMSDT,100, CHGRP,0))  S CHMPF=+$ P(^(0),"^" ,1)
  29091   "RTN","CHM FBC2A",58, 0)
  29092    G CMAC:+C HMPF=0
  29093   "RTN","CHM FBC2A",59, 0)
  29094    S $P(^CHM PAY(CI,"RU LE-PROC",N M,0),"^",9 )=3,CMAC(N M)=CHMPF
  29095   "RTN","CHM FBC2A",60, 0)
  29096    S $P(^CHM PAY(CI,"CO MMON"),"^" ,16)=9 G E ND
  29097   "RTN","CHM FBC2A",61, 0)
  29098   ASC1 S CHM PF=+$P(^CH MPAY(CI,K2 ,NM,0),"^" ,2),CMAC(N M)=CHMPF
  29099   "RTN","CHM FBC2A",62, 0)
  29100    S $P(^CHM PAY(CI,"CO MMON"),"^" ,16)=5 G E ND
  29101   "RTN","CHM FBC2A",63, 0)
  29102   CMAC I VI= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ID MISSING " G END
  29103   "RTN","CHM FBC2A",64, 0)
  29104    G PF:'$D( ^CHMVEN(VI ,41)) S CH CLS="" D   G PF:CHCLS =""
  29105   "RTN","CHM FBC2A",65, 0)
  29106    .S CMJ=$O (^CHMVEN(V I,41,99999 99),-1) Q: 'CMJ
  29107   "RTN","CHM FBC2A",66, 0)
  29108    .S CHCLS= $P(^CHMVEN (VI,41,CMJ ,0),"^",3)
  29109   "RTN","CHM FBC2A",67, 0)
  29110    G PF:"1^2 ^3"'[CHCLS  S CHMSP=$ P(^CHMPAY( CI,K2,NM,0 ),"^")
  29111   "RTN","CHM FBC2A",68, 0)
  29112    S CHMSPC= $P(^CHMSER V(CHMSP,0) ,"^",1)
  29113   "RTN","CHM FBC2A",69, 0)
  29114    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP   GEF
  29115   "RTN","CHM FBC2A",70, 0)
  29116    ;I '$D(^C HMVEN(VI,2 )) S VZ=""  G C0
  29117   "RTN","CHM FBC2A",71, 0)
  29118    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  29119   "RTN","CHM FBC2A",72, 0)
  29120    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  29121   "RTN","CHM FBC2A",73, 0)
  29122   C0 I VZ=""  S CHMFQUE =10,CHMMDP =CHMMDP_":  PL-ZIP MI SSING" G E ND
  29123   "RTN","CHM FBC2A",74, 0)
  29124    S VC=$O(^ CHMDIC(741 002.4,"B", VZ,0))
  29125   "RTN","CHM FBC2A",75, 0)
  29126    ;I VC=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  UNKNOWN"  G END
  29127   "RTN","CHM FBC2A",76, 0)
  29128    G PF:VC=" "
  29129   "RTN","CHM FBC2A",77, 0)
  29130    S CHLDT=$ O(^CHMDIC( 741002.4,V C,1,0)) G  PF:CHLDT'? 7N
  29131   "RTN","CHM FBC2A",78, 0)
  29132    G PF:'$D( ^CHMDIC(74 1002.4,VC, 1,CHLDT,0) ) S CHLOC= $P(^(0),"^ ",2)
  29133   "RTN","CHM FBC2A",79, 0)
  29134    S CHMSPN= $O(^CHMCPF ("B",CHMSP C,0)) G PF :'CHMSPN S  CHX=0
  29135   "RTN","CHM FBC2A",80, 0)
  29136   C2 S CHX=$ O(^CHMCPF( CHMSPN,CHX )) G PF:'C HX G:CHX+8 >CHLOC C22
  29137   "RTN","CHM FBC2A",81, 0)
  29138    G C2
  29139   "RTN","CHM FBC2A",82, 0)
  29140   C22 S CHCM DT=9999999 -CHADOS
  29141   "RTN","CHM FBC2A",83, 0)
  29142   C3 S CHCMD T=$O(^CHMC PF(CHMSPN, CHX,CHCMDT )) G PF:CH CMDT'?7N
  29143   "RTN","CHM FBC2A",84, 0)
  29144    G PF:'$D( ^CHMCPF(CH MSPN,CHX,C HCMDT,0))
  29145   "RTN","CHM FBC2A",85, 0)
  29146    S CHLNM=C HLOC#8 S:C HLOC#8=0 C HLNM=8
  29147   "RTN","CHM FBC2A",86, 0)
  29148    S CHMREC= $P(^CHMCPF (CHMSPN,CH X,CHCMDT,0 ),"^",2)
  29149   "RTN","CHM FBC2A",87, 0)
  29150    S CHPNM=$ P(CHMREC," ,",CHLNM)
  29151   "RTN","CHM FBC2A",88, 0)
  29152    S CHMPF=$ P(CHPNM,"; ",CHCLS),M OD=""
  29153   "RTN","CHM FBC2A",89, 0)
  29154    S:K2="OPT -PROC" MOD =$P(^CHMPA Y(CI,K2,NM ,0),"^",4)
  29155   "RTN","CHM FBC2A",90, 0)
  29156    S:K2="DEN -PROC" MOD =$P(^CHMPA Y(CI,K2,NM ,0),"^",6)
  29157   "RTN","CHM FBC2A",91, 0)
  29158    D:MOD'=""
  29159   "RTN","CHM FBC2A",92, 0)
  29160    .Q:CHADOS <2970701
  29161   "RTN","CHM FBC2A",93, 0)
  29162    .Q:('$D(^ CHMDIC(741 002.98,"B" ,MOD)))&(' $D(^CHMDIC (741002.99 ,"B",MOD)) )
  29163   "RTN","CHM FBC2A",94, 0)
  29164    .S FILEPT =$S($D(^CH MDIC(74100 2.98,"B",M OD)):"7410 02.98",$D( ^CHMDIC(74 1002.99,"B ",MOD)):"7 41002.99", 1:"")
  29165   "RTN","CHM FBC2A",95, 0)
  29166    .Q:FILEPT =""
  29167   "RTN","CHM FBC2A",96, 0)
  29168    .I '$D(^C HMCPF(CHMS PN,CHX,CHC MDT,1)) D   Q
  29169   "RTN","CHM FBC2A",97, 0)
  29170    ..S REA=" ",PERC=""
  29171   "RTN","CHM FBC2A",98, 0)
  29172    ..S MODI= $O(^CHMDIC (741002.98 ,"B",MOD,0 ))
  29173   "RTN","CHM FBC2A",99, 0)
  29174    ..I MODI' ="" S:$D(^ CHMDIC(FIL EPT,MODI,0 )) REA=$P( ^(0),"^",2 ),PERC=$P( ^(0),"^",3 )
  29175   "RTN","CHM FBC2A",100 ,0)
  29176    ..S CHMPF =CHMPF*PER C
  29177   "RTN","CHM FBC2A",101 ,0)
  29178    ..S $P(^C HMPAY(CI," RULE-PROC" ,NM,0),U,2 )=REA
  29179   "RTN","CHM FBC2A",102 ,0)
  29180    .I CHCLS= 2 D  Q
  29181   "RTN","CHM FBC2A",103 ,0)
  29182    ..S PERC= "",REA=""
  29183   "RTN","CHM FBC2A",104 ,0)
  29184    ..S MODI= $O(^CHMDIC (FILEPT,"B ",MOD,0))
  29185   "RTN","CHM FBC2A",105 ,0)
  29186    ..I MODI' ="" S:$D(^ CHMDIC(FIL EPT,MODI,0 )) REA=$P( ^(0),"^",2 ),PERC=$P( ^(0),"^",3 )
  29187   "RTN","CHM FBC2A",106 ,0)
  29188    ..S CHMPF =CHMPF*PER C
  29189   "RTN","CHM FBC2A",107 ,0)
  29190    ..S $P(^C HMPAY(CI," RULE-PROC" ,NM,0),U,2 )=REA
  29191   "RTN","CHM FBC2A",108 ,0)
  29192    .S CHMREC 1=$P(^CHMC PF(CHMSPN, CHX,CHCMDT ,1),"^",2)
  29193   "RTN","CHM FBC2A",109 ,0)
  29194    .S CHPNM1 =$P(CHMREC 1,",",CHLN M)
  29195   "RTN","CHM FBC2A",110 ,0)
  29196    .S:FILEPT =741002.98  PT1=CHCLS
  29197   "RTN","CHM FBC2A",111 ,0)
  29198    .S:FILEPT =741002.99  PT1=$S(CH CLS=1:2,CH CLS=3:4)
  29199   "RTN","CHM FBC2A",112 ,0)
  29200    .S CHMPF= $P(CHPNM1, ";",PT1)
  29201   "RTN","CHM FBC2A",113 ,0)
  29202    .S REA=""
  29203   "RTN","CHM FBC2A",114 ,0)
  29204    .S MODI=$ O(^CHMDIC( FILEPT,"B" ,MOD,0))
  29205   "RTN","CHM FBC2A",115 ,0)
  29206    .I MODI'= "" S:$D(^C HMDIC(FILE PT,MODI,0) ) REA=$P(^ (0),"^",2)
  29207   "RTN","CHM FBC2A",116 ,0)
  29208    .S $P(^CH MPAY(CI,"R ULE-PROC", NM,0),U,2) =REA
  29209   "RTN","CHM FBC2A",117 ,0)
  29210    G PF:+CHM PF=0
  29211   "RTN","CHM FBC2A",118 ,0)
  29212    S $P(^CHM PAY(CI,"RU LE-PROC",N M,0),"^",9 )=1
  29213   "RTN","CHM FBC2A",119 ,0)
  29214    S CMAC(NM )=CHMPF
  29215   "RTN","CHM FBC2A",120 ,0)
  29216    G END
  29217   "RTN","CHM FBC2A",121 ,0)
  29218   PF S CHMPF =0,CHMDOS= $P(^CHMPAY (CI,0),"^" ,8),CHMRDT =9999999-C HMDOS,CHMR SD=CHMRDT- 1
  29219   "RTN","CHM FBC2A",122 ,0)
  29220    S YR=$E(C HMDOS,2,3)  I $E(YR,2 )="0" S YR =$E(YR,1)
  29221   "RTN","CHM FBC2A",123 ,0)
  29222    S FN="741 012."_YR
  29223   "RTN","CHM FBC2A",124 ,0)
  29224    S CHMSPC= $P(^CHMPAY (CI,K2,NM, 0),"^")
  29225   "RTN","CHM FBC2A",125 ,0)
  29226    S VI=$P(^ CHMPAY(CI, 0),"^",3)
  29227   "RTN","CHM FBC2A",126 ,0)
  29228    I VI="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": V ENDOR ID M ISSING" G  END
  29229   "RTN","CHM FBC2A",127 ,0)
  29230    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP   GEF
  29231   "RTN","CHM FBC2A",128 ,0)
  29232    ;I '$D(^C HMVEN(VI,2 )) S VZ=""  G A0
  29233   "RTN","CHM FBC2A",129 ,0)
  29234    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  29235   "RTN","CHM FBC2A",130 ,0)
  29236    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  29237   "RTN","CHM FBC2A",131 ,0)
  29238   A0 I VZ=""  S CHMFQUE =10,CHMMDP =CHMMDP_":  PL-ZIP MI SSING" G E ND
  29239   "RTN","CHM FBC2A",132 ,0)
  29240    S VST=$P( ^(2),"^",4 )
  29241   "RTN","CHM FBC2A",133 ,0)
  29242    I VST=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR STA TE MISSING  " G END
  29243   "RTN","CHM FBC2A",134 ,0)
  29244    S VC=$O(^ CHMSMSA("Z IP",VZ,VST ,0))
  29245   "RTN","CHM FBC2A",135 ,0)
  29246    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP   GEF
  29247   "RTN","CHM FBC2A",136 ,0)
  29248    ;I VC=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  UNKNOWN O R INCOMPAT IBLE WITH  STATE" G E ND
  29249   "RTN","CHM FBC2A",137 ,0)
  29250    I VC="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP UNKN OWN OR INC OMPATIBLE  WITH STATE " G END
  29251   "RTN","CHM FBC2A",138 ,0)
  29252    S CHMSPN= $O(^CHMSPF (FN,"B",CH MSPC,0)) G :CHMSPN=""  END
  29253   "RTN","CHM FBC2A",139 ,0)
  29254    I $D(^CHM SPF(FN,CHM SPN,"DEL") ),$P(^("DE L"),"^",1) =1 G END
  29255   "RTN","CHM FBC2A",140 ,0)
  29256    S CHSMDT= $O(^CHMSMS A(VST,1,VC ,3,CHMRSD) )
  29257   "RTN","CHM FBC2A",141 ,0)
  29258    I CHSMDT' ?1N.N D GS TSM G A1
  29259   "RTN","CHM FBC2A",142 ,0)
  29260    S CHMSNUM =$P(^CHMSM SA(VST,1,V C,3,CHSMDT ,0),"^",2)
  29261   "RTN","CHM FBC2A",143 ,0)
  29262    I (CHMSNU M=0)!(CHMS NUM="") D  GSTSM G A1
  29263   "RTN","CHM FBC2A",144 ,0)
  29264    S PF=$S(( (CHMSNUM'> 20)&(CHMSN UM>0)):1,( (CHMSNUM'> 40)&(CHMSN UM>20)):2, ((CHMSNUM' >60)&(CHMS NUM>40)):3 ,((CHMSNUM '>80)&(CHM SNUM>60)): 4,((CHMSNU M'>100)&(C HMSNUM>80) ):5,1:6)
  29265   "RTN","CHM FBC2A",145 ,0)
  29266    I PF=6 D  GSTSM G A1
  29267   "RTN","CHM FBC2A",146 ,0)
  29268    I CHMSNUM <21,$D(^CH MSPF(FN,CH MSPN,PF))  S:$D(^CHMS PF(FN,CHMS PN,PF)) CH MPFD=$P(^C HMSPF(FN,C HMSPN,PF), ",",CHMSNU M) I CHMPF D'="" S CH MPF=+$P(CH MPFD,";",1 )
  29269   "RTN","CHM FBC2A",147 ,0)
  29270    E  I $D(^ CHMSPF(FN, CHMSPN,PF) ) S:$D(^CH MSPF(FN,CH MSPN,PF))  CHMPFD=$P( ^CHMSPF(FN ,CHMSPN,PF ),",",(CHM SNUM#(20*( $S(PF=1:1, PF=2:1,PF= 3:2,PF=4:3 ,PF=5:4,1: 1))))) I C HMPFD'=""  S CHMPF=+$ P(CHMPFD," ;",1)
  29271   "RTN","CHM FBC2A",148 ,0)
  29272    I CHMPF=0  D GSTSM:Y R>93 G END :YR<94 G E ND:CHMPF=0
  29273   "RTN","CHM FBC2A",149 ,0)
  29274    S MOD=""
  29275   "RTN","CHM FBC2A",150 ,0)
  29276    S:K2="OPT -PROC" MOD =$P(^CHMPA Y(CI,K2,NM ,0),"^",4)
  29277   "RTN","CHM FBC2A",151 ,0)
  29278    S:K2="DEN -PROC" MOD =$P(^CHMPA Y(CI,K2,NM ,0),"^",6)
  29279   "RTN","CHM FBC2A",152 ,0)
  29280    D:MOD'=""
  29281   "RTN","CHM FBC2A",153 ,0)
  29282    .Q:CHADOS <2970701
  29283   "RTN","CHM FBC2A",154 ,0)
  29284    .Q:('$D(^ CHMDIC(741 002.98,"B" ,MOD)))&(' $D(^CHMDIC (741002.99 ,"B",MOD)) )
  29285   "RTN","CHM FBC2A",155 ,0)
  29286    .S FILEPT =$S($D(^CH MDIC(74100 2.98,"B",M OD)):"7410 02.98",$D( ^CHMDIC(74 1002.99,"B ",MOD)):"7 41002.99", 1:"")
  29287   "RTN","CHM FBC2A",156 ,0)
  29288    .Q:FILEPT =""
  29289   "RTN","CHM FBC2A",157 ,0)
  29290    .S PERC=" ",REA=""
  29291   "RTN","CHM FBC2A",158 ,0)
  29292    .S MODI=$ O(^CHMDIC( FILEPT,"B" ,MOD,0))
  29293   "RTN","CHM FBC2A",159 ,0)
  29294    .I MODI'= "" S:$D(^C HMDIC(FILE PT,MODI,0) ) REA=$P(^ (0),"^",2) ,PERC=$P(^ (0),"^",3)
  29295   "RTN","CHM FBC2A",160 ,0)
  29296    .S CHMPF= CHMPF*PERC
  29297   "RTN","CHM FBC2A",161 ,0)
  29298    .S $P(^CH MPAY(CI,"R ULE-PROC", NM,0),U,2) =REA
  29299   "RTN","CHM FBC2A",162 ,0)
  29300   A1 S $P(^C HMPAY(CI," RULE-PROC" ,NM,0),"^" ,9)=2
  29301   "RTN","CHM FBC2A",163 ,0)
  29302    S CMAC(NM )=CHMPF
  29303   "RTN","CHM FBC2A",164 ,0)
  29304   END I (K2= "DME-SUPPL Y")!(K2="O PT-PROC")  D
  29305   "RTN","CHM FBC2A",165 ,0)
  29306    .Q:$P(^CH MPAY(CI,K2 ,NM,0),"^" ,5)=""
  29307   "RTN","CHM FBC2A",166 ,0)
  29308    .S CHMPF= $P(^(0),"^ ",5),CMAC( NM)=CHMPF, $P(^CHMPAY (CI,"RULE- PROC",NM,0 ),"^",9)=4
  29309   "RTN","CHM FBC2A",167 ,0)
  29310    .S ALLOW= 1
  29311   "RTN","CHM FBC2A",168 ,0)
  29312    I K2="DEN -PROC" D
  29313   "RTN","CHM FBC2A",169 ,0)
  29314    .Q:$P(^CH MPAY(CI,K2 ,NM,0),"^" ,7)=""
  29315   "RTN","CHM FBC2A",170 ,0)
  29316    .S CHMPF= $P(^(0),"^ ",7),CMAC( NM)=CHMPF, $P(^CHMPAY (CI,"RULE- PROC",NM,0 ),"^",9)=4
  29317   "RTN","CHM FBC2A",171 ,0)
  29318    .S ALLOW= 1
  29319   "RTN","CHM FBC2A",172 ,0)
  29320    K CHMPFD, CHMSPN,CHM SNUM,CHSMD T,VST,VC,V I,VZ,CHMSP ,CHMSPC,CH LDT
  29321   "RTN","CHM FBC2A",173 ,0)
  29322    K CHMSA,C HMGPN,CHGR DT,CHMMPN, CHMSDT,CHG RP,CHFAC Q
  29323   "RTN","CHM FBC2A",174 ,0)
  29324   GSTSM I VS T>40 I $D( ^CHMSPF(FN ,CHMSPN,0) ) S:$D(^CH MSPF(FN,CH MSPN,103))  CHMPFD=$P (^CHMSPF(F N,CHMSPN,1 03),",",VS T-40) I CH MPFD'="" S  CHMPF=+$P (CHMPFD,"; ",1) Q
  29325   "RTN","CHM FBC2A",175 ,0)
  29326    I (VST>20 )&(VST'>40 ) I $D(^CH MSPF(FN,CH MSPN,0)) S :$D(^CHMSP F(FN,CHMSP N,102)) CH MPFD=$P(^C HMSPF(FN,C HMSPN,102) ,",",VST-2 0) I CHMPF D'="" S CH MPF=+$P(CH MPFD,";",1 ) Q
  29327   "RTN","CHM FBC2A",176 ,0)
  29328    I (VST>0) &(VST'>20)  I $D(^CHM SPF(FN,CHM SPN,0)) S: $D(^CHMSPF (FN,CHMSPN ,101)) CHM PFD=$P(^CH MSPF(FN,CH MSPN,101), ",",VST) I  CHMPFD'=" " S CHMPF= +$P(CHMPFD ,";",1) Q
  29329   "RTN","CHM FBC2A",177 ,0)
  29330    Q
  29331   "RTN","CHM FEDISTP1")
  29332   0^83^B4601 161
  29333   "RTN","CHM FEDISTP1", 1,0)
  29334   CHMFEDISTP 1 ;HAC/KML  ;SUBMISSI ON STRIP F OR CPD;02/ 02/98  12: 34 PM
  29335   "RTN","CHM FEDISTP1", 2,0)
  29336    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  29337   "RTN","CHM FEDISTP1", 3,0)
  29338     ;
  29339   "RTN","CHM FEDISTP1", 4,0)
  29340    ; USER ST ORY 005-04 2 - An 837  with Freq uency type  code "8"  is receive d.   The O riginal PD I is in pr ocess and  all claims /lines are  in proces s :
  29341   "RTN","CHM FEDISTP1", 5,0)
  29342    ; The sys tem will " strip" the  Original  PDI of all  claims.
  29343   "RTN","CHM FEDISTP1", 6,0)
  29344    ;
  29345   "RTN","CHM FEDISTP1", 7,0)
  29346    ; The CHM FEDISTP* s eries of r outines we re copied  from the C HMFSTP* se ries of ro utines.    The primar y differen ce between  the 2 set s is that 
  29347   "RTN","CHM FEDISTP1", 8,0)
  29348    ; the EDI  version o f the rout ines do no t interact  with the  user; and  the EDI ve rsion will  strip the  PDI when  the claims  are IN PR OCESS rath er 
  29349   "RTN","CHM FEDISTP1", 9,0)
  29350    ; than PA YMENT REQU ESTED
  29351   "RTN","CHM FEDISTP1", 10,0)
  29352     ;
  29353   "RTN","CHM FEDISTP1", 11,0)
  29354   START(OPDI ,CHMSTRIP)  ; OPDI =  Original P DI to be s tripped
  29355   "RTN","CHM FEDISTP1", 12,0)
  29356    ; input -  OPDI = Or iginal PDI  to be str ipped
  29357   "RTN","CHM FEDISTP1", 13,0)
  29358    ;          CHMSTRIP  - passed b y referenc e, 
  29359   "RTN","CHM FEDISTP1", 14,0)
  29360    ;                      0 - was  not stripp ed; 1 - pd i was stri pped
  29361   "RTN","CHM FEDISTP1", 15,0)
  29362    N CHLAND
  29363   "RTN","CHM FEDISTP1", 16,0)
  29364    S CHMSTRI P=0
  29365   "RTN","CHM FEDISTP1", 17,0)
  29366    D CHK^CHM FEDISTP5(O PDI,.CHLAN D)
  29367   "RTN","CHM FEDISTP1", 18,0)
  29368    Q:'CHLAND    ; PDI c annot be s tripped; c laims stil l being pr ocessed
  29369   "RTN","CHM FEDISTP1", 19,0)
  29370    D CHECK(O PDI)  ;ADD  THE DELET ION OF REO PEN HERE
  29371   "RTN","CHM FEDISTP1", 20,0)
  29372    D PROBSQ( OPDI) ;W ! ,"PSQFL: " ,$D(PSQFL)
  29373   "RTN","CHM FEDISTP1", 21,0)
  29374    Q:$D(PSQF L) ; PDI i s in the P roblem Sup port Queue , strippin g not allo wed
  29375   "RTN","CHM FEDISTP1", 22,0)
  29376    D BATCH(O PDI)  ;W ! ,"BATFL: " ,$D(BATFL)
  29377   "RTN","CHM FEDISTP1", 23,0)
  29378    Q:$D(BATF L)
  29379   "RTN","CHM FEDISTP1", 24,0)
  29380    N CHSTAT  S CHSTAT=$ $STATUS(OP DI) ;W !," CHSTAT: ", CHSTAT 
  29381   "RTN","CHM FEDISTP1", 25,0)
  29382    Q:CHSTAT   ; Claims  are comple ted or pay ment reque sted
  29383   "RTN","CHM FEDISTP1", 26,0)
  29384    N CHEOB S  CHEOB=$$E OB(OPDI)   ;W !,"CHEO B: ",CHEOB
  29385   "RTN","CHM FEDISTP1", 27,0)
  29386    Q:CHEOB   ;EOB's hav e been pri nted
  29387   "RTN","CHM FEDISTP1", 28,0)
  29388    N CHPAID  D ^CHMFEDI STP2  ;W ! ,"CHPAID:  ",$D(CHPAI D)
  29389   "RTN","CHM FEDISTP1", 29,0)
  29390    Q:$D(CHPA ID) ; clai ms have be en paid
  29391   "RTN","CHM FEDISTP1", 30,0)
  29392    D VEPROD, BATCH1
  29393   "RTN","CHM FEDISTP1", 31,0)
  29394    ;
  29395   "RTN","CHM FEDISTP1", 32,0)
  29396   EDIENTR D  ^CHMFEDIST P3 S CL=0
  29397   "RTN","CHM FEDISTP1", 33,0)
  29398    F GLOB="^ CHMPAY("," ^CHNVPAY("  D
  29399   "RTN","CHM FEDISTP1", 34,0)
  29400    .I $D(@(G LOB_"""C"" ,OPDI)"))  S CPDI=OPD I,Y=OPDI D  CLMCHK
  29401   "RTN","CHM FEDISTP1", 35,0)
  29402   A2 .S CL=$ O(@(GLOB_" ""C"",OPDI ,CL)")) Q: 'CL
  29403   "RTN","CHM FEDISTP1", 36,0)
  29404    .S CN=$P( @(GLOB_"CL ,0)"),"^", 1) K OHI S  CHMFCLNM= CN
  29405   "RTN","CHM FEDISTP1", 37,0)
  29406    .S X1=CL  D PROGTYP^ CHFCD001 D  ^CHMFUTL2
  29407   "RTN","CHM FEDISTP1", 38,0)
  29408    .D BENE,C LAIM G A2
  29409   "RTN","CHM FEDISTP1", 39,0)
  29410   EXIT    ;P DI has bee n stripped  and claim s deleted
  29411   "RTN","CHM FEDISTP1", 40,0)
  29412    S CHMSTRI P=1
  29413   "RTN","CHM FEDISTP1", 41,0)
  29414    S CHMFPP= "PDIRSTCL"  D ^CHMFWK 01
  29415   "RTN","CHM FEDISTP1", 42,0)
  29416   E1 K CHREA DY
  29417   "RTN","CHM FEDISTP1", 43,0)
  29418    I $D(NOUS ER) D  G E 2
  29419   "RTN","CHM FEDISTP1", 44,0)
  29420    .S CHMQNA M="MANUAL( ",CHMIN=1  K CHMOUT D  ^CHMIS041
  29421   "RTN","CHM FEDISTP1", 45,0)
  29422   E2 K ^CHMI MAGE(OPDI) ,^CHMIMG(O PDI,"PAUSE ")
  29423   "RTN","CHM FEDISTP1", 46,0)
  29424    S $P(^CHM IMG(OPDI,0 ),"^",6)=0
  29425   "RTN","CHM FEDISTP1", 47,0)
  29426    S $P(^CHM IMG(OPDI,0 ),"^",4)=" "
  29427   "RTN","CHM FEDISTP1", 48,0)
  29428    S $P(^CHM IMG(OPDI,0 ),"^",5)=" "
  29429   "RTN","CHM FEDISTP1", 49,0)
  29430    K SN,BN,C P,DIK,DA,Y ,OPDI
  29431   "RTN","CHM FEDISTP1", 50,0)
  29432    Q
  29433   "RTN","CHM FEDISTP1", 51,0)
  29434    ; 
  29435   "RTN","CHM FEDISTP1", 52,0)
  29436   PROBSQ(OPD I)
  29437   "RTN","CHM FEDISTP1", 53,0)
  29438    K PSQFL Q :'$D(^CHMP SQ("PDI",O PDI))
  29439   "RTN","CHM FEDISTP1", 54,0)
  29440    S PSQPT=0
  29441   "RTN","CHM FEDISTP1", 55,0)
  29442   PR1 S PSQP T=$O(^CHMP SQ("PDI",O PDI,PSQPT) ) Q:'PSQPT
  29443   "RTN","CHM FEDISTP1", 56,0)
  29444    G:'$D(^CH MPSQ(PSQPT ,0)) PR1
  29445   "RTN","CHM FEDISTP1", 57,0)
  29446    S PSSTAT= $P(^(0),"^ ",3)
  29447   "RTN","CHM FEDISTP1", 58,0)
  29448    I PSSTAT' =3 S PSQFL =1 Q
  29449   "RTN","CHM FEDISTP1", 59,0)
  29450    G PR1
  29451   "RTN","CHM FEDISTP1", 60,0)
  29452    ;
  29453   "RTN","CHM FEDISTP1", 61,0)
  29454   BATCH(OPDI ) ; 
  29455   "RTN","CHM FEDISTP1", 62,0)
  29456    K BATFL Q :'$D(^CHMI MPB("C",OP DI))
  29457   "RTN","CHM FEDISTP1", 63,0)
  29458    S J=0,J=$ O(^CHMIMPB ("C",OPDI, J)) Q:'J
  29459   "RTN","CHM FEDISTP1", 64,0)
  29460    S K=0,K=$ O(^CHMIMPB ("C",OPDI, J,K)) Q:'K
  29461   "RTN","CHM FEDISTP1", 65,0)
  29462    Q:'$D(^CH MIMPB(J,0) )  I $P(^( 0),"^",6)= 1 S BATFL= 1
  29463   "RTN","CHM FEDISTP1", 66,0)
  29464    Q
  29465   "RTN","CHM FEDISTP1", 67,0)
  29466    ;
  29467   "RTN","CHM FEDISTP1", 68,0)
  29468   BATCH1 ;
  29469   "RTN","CHM FEDISTP1", 69,0)
  29470    Q:'$D(^CH MIMPB("C", OPDI))
  29471   "RTN","CHM FEDISTP1", 70,0)
  29472    S J=0,J=$ O(^CHMIMPB ("C",OPDI, J)) Q:'J
  29473   "RTN","CHM FEDISTP1", 71,0)
  29474    S K=0,K=$ O(^CHMIMPB ("C",OPDI, J,K)) Q:'K
  29475   "RTN","CHM FEDISTP1", 72,0)
  29476    N NOUSER  Q:$P(^CHMI MPB(J,0)," ^",3)=1  S  NOUSER=1
  29477   "RTN","CHM FEDISTP1", 73,0)
  29478    S $P(^CHM IMPB(J,100 ,K,0),"^", 3)=0
  29479   "RTN","CHM FEDISTP1", 74,0)
  29480    S $P(^CHM IMG(OPDI,0 ),"^",6)=0
  29481   "RTN","CHM FEDISTP1", 75,0)
  29482    S ^CHMIMG ("MANUAL", OPDI)="" Q
  29483   "RTN","CHM FEDISTP1", 76,0)
  29484    ;
  29485   "RTN","CHM FEDISTP1", 77,0)
  29486   EOB(OPDI)  ; Determin e if EOBs  have been  printed
  29487   "RTN","CHM FEDISTP1", 78,0)
  29488    ; input -  OPDI = PD I to be st ripped
  29489   "RTN","CHM FEDISTP1", 79,0)
  29490    ; returns  CHEOB  -  0 =  EOBs  have not b een printe d
  29491   "RTN","CHM FEDISTP1", 80,0)
  29492    ;                    1 =  EOBs  have been  printed
  29493   "RTN","CHM FEDISTP1", 81,0)
  29494    S (CL,CHE OB)=0
  29495   "RTN","CHM FEDISTP1", 82,0)
  29496    F GLOB="^ CHMPAY("," ^CHNVPAY("  D  Q:CHEO B=1
  29497   "RTN","CHM FEDISTP1", 83,0)
  29498   EOB1 .S CL =$O(@(GLOB _"""C"",OP DI,CL)"))  Q:'CL
  29499   "RTN","CHM FEDISTP1", 84,0)
  29500    .S GLEOB= $S(GLOB="^ CHMPAY(":" ^CHMEOBQ(" ,GLOB="^CH NVPAY(":"^ CHNVEOBQ(" )
  29501   "RTN","CHM FEDISTP1", 85,0)
  29502    .S J=0,J= $O(@(GLEOB _"""D"",CL ,J)")) G:' J EOB1
  29503   "RTN","CHM FEDISTP1", 86,0)
  29504    .Q:'$D(@( GLEOB_"J,0 )"))
  29505   "RTN","CHM FEDISTP1", 87,0)
  29506    .I $P(@(G LEOB_"J,0) "),"^",3)= 1 S CHEOB= 1
  29507   "RTN","CHM FEDISTP1", 88,0)
  29508    .G EOB1
  29509   "RTN","CHM FEDISTP1", 89,0)
  29510    Q CHEOB
  29511   "RTN","CHM FEDISTP1", 90,0)
  29512    ;
  29513   "RTN","CHM FEDISTP1", 91,0)
  29514   STATUS(OPD I) ; Deter mine if Cl aims are c ompleted o r payment  requested
  29515   "RTN","CHM FEDISTP1", 92,0)
  29516    ; input -  OPDI = PD I to be st ripped
  29517   "RTN","CHM FEDISTP1", 93,0)
  29518    ; returns  CHSTAT -  0 =  claim s are not  completed  or do not  have payme nt request
  29519   "RTN","CHM FEDISTP1", 94,0)
  29520    ;                    1 =  claim s are comp leted or p ayment has  been requ ested
  29521   "RTN","CHM FEDISTP1", 95,0)
  29522    S CHSTAT= 0
  29523   "RTN","CHM FEDISTP1", 96,0)
  29524    F GLOB="^ CHMPAY("," ^CHNVPAY("  S CL=0 D   Q:CHSTAT
  29525   "RTN","CHM FEDISTP1", 97,0)
  29526   S1 .S CL=$ O(@(GLOB_" ""C"",OPDI ,CL)")) Q: 'CL
  29527   "RTN","CHM FEDISTP1", 98,0)
  29528    .G:'$D(@( GLOB_"CL,0 )")) S1
  29529   "RTN","CHM FEDISTP1", 99,0)
  29530    .I $P(@(G LOB_"CL,0) "),"^",2)= 4 S CHSTAT =1 Q
  29531   "RTN","CHM FEDISTP1", 100,0)
  29532    .I GLOB=" ^CHNVPAY("  I $P(@(GL OB_"CL,0)" ),"^",2)=2  S CHSTAT= 1 Q
  29533   "RTN","CHM FEDISTP1", 101,0)
  29534    .G S1
  29535   "RTN","CHM FEDISTP1", 102,0)
  29536    Q CHSTAT
  29537   "RTN","CHM FEDISTP1", 103,0)
  29538    ;
  29539   "RTN","CHM FEDISTP1", 104,0)
  29540   BENE S SN= 0
  29541   "RTN","CHM FEDISTP1", 105,0)
  29542   A6 S SN=$O (@(GLDFN_" ""C"",CL,S N)")) Q:'S N
  29543   "RTN","CHM FEDISTP1", 106,0)
  29544    S BN=0
  29545   "RTN","CHM FEDISTP1", 107,0)
  29546   A7 S BN=$O (@(GLDFN_" ""C"",CL,S N,BN)")) G :'BN A6
  29547   "RTN","CHM FEDISTP1", 108,0)
  29548    S CP=0
  29549   "RTN","CHM FEDISTP1", 109,0)
  29550   A8 S CP=$O (@(GLDFN_" ""C"",CL,S N,BN,CP)") ) G:'CP A7
  29551   "RTN","CHM FEDISTP1", 110,0)
  29552    K @(GLDFN _"SN,100,B N,100,CP,0 )")
  29553   "RTN","CHM FEDISTP1", 111,0)
  29554    K @(GLDFN _"""C"",CL )")
  29555   "RTN","CHM FEDISTP1", 112,0)
  29556    K @(GLDFN _"SN,100,B N,100,""B" ",CL,CP)")
  29557   "RTN","CHM FEDISTP1", 113,0)
  29558    G A8
  29559   "RTN","CHM FEDISTP1", 114,0)
  29560    ;
  29561   "RTN","CHM FEDISTP1", 115,0)
  29562   CLAIM D:$D (@(GLPAY_" CL,6)")) R EOPN
  29563   "RTN","CHM FEDISTP1", 116,0)
  29564    S $P(@(GL PAY_"CL,0) "),"^",2)= 10
  29565   "RTN","CHM FEDISTP1", 117,0)
  29566    S VND=$P( @(GLPAY_"C L,0)"),"^" ,3)
  29567   "RTN","CHM FEDISTP1", 118,0)
  29568    K @(GLPAY _"""B"",CN )")
  29569   "RTN","CHM FEDISTP1", 119,0)
  29570    K @(GLPAY _"""C"",OP DI,CL)")
  29571   "RTN","CHM FEDISTP1", 120,0)
  29572    K ^CHMIMG (OPDI,"PAU SE")
  29573   "RTN","CHM FEDISTP1", 121,0)
  29574    K:VND'=""  @(GLPAY_" ""AD"",VND ,CL)")
  29575   "RTN","CHM FEDISTP1", 122,0)
  29576    D NOW^%DT C
  29577   "RTN","CHM FEDISTP1", 123,0)
  29578    S @(GLPAY _"""ZDEL"" ,CL)")=DUZ _"^"_%
  29579   "RTN","CHM FEDISTP1", 124,0)
  29580    S CHMFI=C L,CHMFPP=" DELCLM" D  ^CHMFWK02  K CHMFI,CH MFPP  ;AEB  9/2/2008  DEV003427
  29581   "RTN","CHM FEDISTP1", 125,0)
  29582    Q
  29583   "RTN","CHM FEDISTP1", 126,0)
  29584    ;
  29585   "RTN","CHM FEDISTP1", 127,0)
  29586   REOPN S CH OLDCL=$P(@ (GLPAY_"CL ,6)"),"^", 2)
  29587   "RTN","CHM FEDISTP1", 128,0)
  29588    Q:CHOLDCL =""
  29589   "RTN","CHM FEDISTP1", 129,0)
  29590    Q:'$D(@(G LPAY_"CHOL DCL,6)"))
  29591   "RTN","CHM FEDISTP1", 130,0)
  29592    S $P(@(GL PAY_"CHOLD CL,6)"),"^ ",1)=""
  29593   "RTN","CHM FEDISTP1", 131,0)
  29594    Q
  29595   "RTN","CHM FEDISTP1", 132,0)
  29596    ;
  29597   "RTN","CHM FEDISTP1", 133,0)
  29598   CHECK(OPDI ) ; kill o ff REOPEN  node
  29599   "RTN","CHM FEDISTP1", 134,0)
  29600    Q:'$D(^CH MIMAGE(OPD I))
  29601   "RTN","CHM FEDISTP1", 135,0)
  29602    S REOPPG= 0
  29603   "RTN","CHM FEDISTP1", 136,0)
  29604   C1 S REOPP G=$O(^CHMI MAGE(OPDI, 1,REOPPG))  Q:'REOPPG   S REOPIM G=0
  29605   "RTN","CHM FEDISTP1", 137,0)
  29606   C2 S REOPI MG=$O(^CHM IMAGE(OPDI ,1,REOPPG, 2,REOPIMG) ) G:'REOPI MG C1
  29607   "RTN","CHM FEDISTP1", 138,0)
  29608    K ^CHMIMA GE(OPDI,1, REOPPG,2,R EOPIMG,"RE OP")
  29609   "RTN","CHM FEDISTP1", 139,0)
  29610    G C2
  29611   "RTN","CHM FEDISTP1", 140,0)
  29612    ;
  29613   "RTN","CHM FEDISTP1", 141,0)
  29614   VEPROD ;SE TS PDI INT O C X-REF  IN CHMPROD
  29615   "RTN","CHM FEDISTP1", 142,0)
  29616    S REC21=^ CHMIMG(OPD I,0)
  29617   "RTN","CHM FEDISTP1", 143,0)
  29618    S TMPDUZ= $P(REC21," ^",3),SDAT E=$P(REC21 ,"^",4)
  29619   "RTN","CHM FEDISTP1", 144,0)
  29620    Q:TMPDUZ= ""
  29621   "RTN","CHM FEDISTP1", 145,0)
  29622    S TME=$E( SDATE,11,1 2) I TME<3 0 S TME=0  G VP3
  29623   "RTN","CHM FEDISTP1", 146,0)
  29624    I TME>30  S TME=3
  29625   "RTN","CHM FEDISTP1", 147,0)
  29626   VP3 S SDAT E=+$E(SDAT E,1,10)_TM E/1
  29627   "RTN","CHM FEDISTP1", 148,0)
  29628    S DODATE= $P(SDATE," .",1)
  29629   "RTN","CHM FEDISTP1", 149,0)
  29630   VEP1 S DOD ATE=$O(^CH MPROD(7410 60.01,"C", DODATE)) G :'DODATE V EP2
  29631   "RTN","CHM FEDISTP1", 150,0)
  29632    S NEWPDI= 0
  29633   "RTN","CHM FEDISTP1", 151,0)
  29634    S NEWPDI= $O(^CHMPRO D(741060.0 1,"C",DODA TE,TMPDUZ, NEWPDI)) G :'NEWPDI V EP1
  29635   "RTN","CHM FEDISTP1", 152,0)
  29636    I NEWPDI= OPDI K ^CH MPROD(7410 60.01,"C", DODATE,TMP DUZ,NEWPDI )
  29637   "RTN","CHM FEDISTP1", 153,0)
  29638   VEP2 S ^CH MPROD(7410 60.01,"C", SDATE,TMPD UZ,OPDI)=1
  29639   "RTN","CHM FEDISTP1", 154,0)
  29640    K TMPDUZ, SDATE,REC2 1
  29641   "RTN","CHM FEDISTP1", 155,0)
  29642    Q
  29643   "RTN","CHM FEDISTP1", 156,0)
  29644    ;
  29645   "RTN","CHM FEDISTP1", 157,0)
  29646   CLMCHK X ^ %ZOSF("UCI ")
  29647   "RTN","CHM FEDISTP1", 158,0)
  29648    S UCI=$P( Y,",",1)
  29649   "RTN","CHM FEDISTP1", 159,0)
  29650    S CPT=0
  29651   "RTN","CHM FEDISTP1", 160,0)
  29652   CLM1 S CPT =$O(@(GLOB _"""C"",CP DI,CPT)"))  Q:'CPT
  29653   "RTN","CHM FEDISTP1", 161,0)
  29654    G:'$D(@(G LOB_"CPT,0 )")) CLM1
  29655   "RTN","CHM FEDISTP1", 162,0)
  29656    I $D(^%ZS TAT("CC",U CI,CPT)) K  ^%ZSTAT(" CC",UCI,CP T)
  29657   "RTN","CHM FEDISTP1", 163,0)
  29658    G CLM1
  29659   "RTN","CHM FEDISTP2")
  29660   0^84^B5893 228
  29661   "RTN","CHM FEDISTP2", 1,0)
  29662   CHMFEDISTP 2 ;HAC/KML ;CHECK FOR  PAID CLAI MS PRIOR T O STRIP;10 /25/93  3: 09 PM
  29663   "RTN","CHM FEDISTP2", 2,0)
  29664    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  29665   "RTN","CHM FEDISTP2", 3,0)
  29666     ;
  29667   "RTN","CHM FEDISTP2", 4,0)
  29668    ; USER ST ORY 005-04 2 - An 837  with Freq uency type  code "8"  is receive d.   The O riginal PD I is in pr ocess and  all claims /lines are  in proces s :
  29669   "RTN","CHM FEDISTP2", 5,0)
  29670    ; The sys tem will " strip" the  Original  PDI of all  claims.
  29671   "RTN","CHM FEDISTP2", 6,0)
  29672    ;
  29673   "RTN","CHM FEDISTP2", 7,0)
  29674    ; The CHM FEDISTP* s eries of r outines we re copied  from the C HMFSTP* se ries of ro utines.    The primar y differen ce between  the 2 set s is that 
  29675   "RTN","CHM FEDISTP2", 8,0)
  29676    ; the EDI  version o f the rout ines do no t interact  with the  user; and  the EDI ve rsion will  strip the  PDI when  the claims  are IN PR OCESS rath er 
  29677   "RTN","CHM FEDISTP2", 9,0)
  29678    ; than PA YMENT REQU ESTED
  29679   "RTN","CHM FEDISTP2", 10,0)
  29680     ;
  29681   "RTN","CHM FEDISTP2", 11,0)
  29682    S CI=0
  29683   "RTN","CHM FEDISTP2", 12,0)
  29684   A1 S CI=$O (^CHMPAY(" C",CHMFPDI ,CI)) G:'C I END
  29685   "RTN","CHM FEDISTP2", 13,0)
  29686    G:'$D(^CH MPAY(CI,0) ) A1 D PAI D G:$D(CHP AID) END K  CHSTRIP,C HMFQ
  29687   "RTN","CHM FEDISTP2", 14,0)
  29688    D CAPP G: $D(CHPAID)  END G A1
  29689   "RTN","CHM FEDISTP2", 15,0)
  29690   END Q
  29691   "RTN","CHM FEDISTP2", 16,0)
  29692   CAPP G:'$D (^CHMSNA(7 41008.03," C",CI)) CA LM
  29693   "RTN","CHM FEDISTP2", 17,0)
  29694    S CHIN=""  S CHIN=$O (^CHMSNA(7 41008.03," C",CI,CHIN )) S:CHIN= "" CHIN=-1
  29695   "RTN","CHM FEDISTP2", 18,0)
  29696    S:$D(^CHM SNA(741008 .03,CHIN,0 )) CHSTATU S=$P(^(0), "^",2)
  29697   "RTN","CHM FEDISTP2", 19,0)
  29698    I CHSTATU S'="" S CH PAID="" Q
  29699   "RTN","CHM FEDISTP2", 20,0)
  29700    S CHJN=""  S CHJN=$O (^CHMSNA(7 41008.03," C",CI,CHIN ,CHJN)) S: 'CHJN CHJN =-1
  29701   "RTN","CHM FEDISTP2", 21,0)
  29702    K:$D(^CHM SNA(741008 .03,"C",CI ,CHIN,CHJN )) ^CHMSNA (741008.03 ,"C",CI,CH IN,CHJN)
  29703   "RTN","CHM FEDISTP2", 22,0)
  29704    K:$D(^CHM SNA(741008 .03,CHIN,1 ,"B",CI,CH JN)) ^CHMS NA(741008. 03,CHIN,1, "B",CI,CHJ N)
  29705   "RTN","CHM FEDISTP2", 23,0)
  29706    K:$D(^CHM SNA(741008 .03,CHIN,1 ,CHJN)) ^C HMSNA(7410 08.03,CHIN ,1,CHJN)
  29707   "RTN","CHM FEDISTP2", 24,0)
  29708    S $P(^CHM SNA(741008 .03,CHIN,1 ,0),"^",4) =$P(^CHMSN A(741008.0 3,CHIN,1,0 ),"^",4)-1
  29709   "RTN","CHM FEDISTP2", 25,0)
  29710   CALM K CHP AID Q:'$D( ^CHMSNA(74 1008.05,"C ",CI))
  29711   "RTN","CHM FEDISTP2", 26,0)
  29712    S CHIN=""  S CHIN=$O (^CHMSNA(7 41008.05," C",CI,CHIN )) S:CHIN= "" CHIN=-1
  29713   "RTN","CHM FEDISTP2", 27,0)
  29714    S:$D(^CHM SNA(741008 .05,CHIN,0 )) CHSTATU S=$P(^(0), "^",2)
  29715   "RTN","CHM FEDISTP2", 28,0)
  29716    I CHSTATU S'="" S CH PAID="" Q
  29717   "RTN","CHM FEDISTP2", 29,0)
  29718    S CHJN=""  S CHJN=$O (^CHMSNA(7 41008.05," C",CI,CHIN ,CHJN)) S: 'CHJN CHJN =-1
  29719   "RTN","CHM FEDISTP2", 30,0)
  29720    K:$D(^CHM SNA(741008 .05,"C",CI ,CHIN,CHJN )) ^CHMSNA (741008.05 ,"C",CI,CH IN,CHJN)
  29721   "RTN","CHM FEDISTP2", 31,0)
  29722    K:$D(^CHM SNA(741008 .05,CHIN,1 ,"B",CI,CH JN)) ^CHMS NA(741008. 05,CHIN,1, "B",CI,CHJ N)
  29723   "RTN","CHM FEDISTP2", 32,0)
  29724    K:$D(^CHM SNA(741008 .05,CHIN,1 ,CHJN)) ^C HMSNA(7410 08.05,CHIN ,1,CHJN)
  29725   "RTN","CHM FEDISTP2", 33,0)
  29726    S $P(^CHM SNA(741008 .05,CHIN,1 ,0),"^",4) =$P(^CHMSN A(741008.0 5,CHIN,1,0 ),"^",4)-1
  29727   "RTN","CHM FEDISTP2", 34,0)
  29728    Q
  29729   "RTN","CHM FEDISTP2", 35,0)
  29730   PAID K CHP AID G:'$D( ^CHMSNA(74 1008.03,"C ",CI)) P1
  29731   "RTN","CHM FEDISTP2", 36,0)
  29732    S CHIN=""  S CHIN=$O (^CHMSNA(7 41008.03," C",CI,CHIN )) S:CHIN= "" CHIN=-1
  29733   "RTN","CHM FEDISTP2", 37,0)
  29734    S:$D(^CHM SNA(741008 .03,CHIN,0 )) CHSTATU S=$P(^(0), "^",2)
  29735   "RTN","CHM FEDISTP2", 38,0)
  29736    I CHSTATU S'="" S CH PAID="" Q
  29737   "RTN","CHM FEDISTP2", 39,0)
  29738   P1 Q:'$D(^ CHMSNA(741 008.05,"C" ,CI))
  29739   "RTN","CHM FEDISTP2", 40,0)
  29740    S CHIN=""  S CHIN=$O (^CHMSNA(7 41008.05," C",CI,CHIN )) S:CHIN= "" CHIN=-1
  29741   "RTN","CHM FEDISTP2", 41,0)
  29742    S:$D(^CHM SNA(741008 .05,CHIN,0 )) CHSTATU S=$P(^(0), "^",2)
  29743   "RTN","CHM FEDISTP2", 42,0)
  29744    S:CHSTATU S'="" CHPA ID="" Q
  29745   "RTN","CHM FEDISTP3")
  29746   0^85^B1225 3408
  29747   "RTN","CHM FEDISTP3", 1,0)
  29748   CHMFEDISTP 3 ;HAC/KML ;REMOVE FR OM QUEUES  PRIOR TO S TRIP;
  29749   "RTN","CHM FEDISTP3", 2,0)
  29750    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  29751   "RTN","CHM FEDISTP3", 3,0)
  29752    ;CI IS TH E POINTER  FOR THE CL AIM THAT I S GETTING  CHECKED
  29753   "RTN","CHM FEDISTP3", 4,0)
  29754    ;
  29755   "RTN","CHM FEDISTP3", 5,0)
  29756    ; USER ST ORY 005-04 2 - An 837  with Freq uency type  code "8"  is receive d.   The O riginal PD I is in pr ocess and  all claims /lines are  in proces s :
  29757   "RTN","CHM FEDISTP3", 6,0)
  29758    ; The sys tem will " strip" the  Original  PDI of all  claims.
  29759   "RTN","CHM FEDISTP3", 7,0)
  29760    ;
  29761   "RTN","CHM FEDISTP3", 8,0)
  29762    ; The CHM FEDISTP* s eries of r outines we re copied  from the C HMFSTP* se ries of ro utines.    The primar y differen ce between  the 2 set s is that 
  29763   "RTN","CHM FEDISTP3", 9,0)
  29764    ; the EDI  version o f the rout ines do no t interact  with the  user; and  the EDI ve rsion will  strip the  PDI when  the claims  are IN PR OCESS rath er 
  29765   "RTN","CHM FEDISTP3", 10,0)
  29766    ; than PA YMENT REQU ESTED
  29767   "RTN","CHM FEDISTP3", 11,0)
  29768    ;
  29769   "RTN","CHM FEDISTP3", 12,0)
  29770    K XXXFLG
  29771   "RTN","CHM FEDISTP3", 13,0)
  29772    F GLPAY=" ^CHMPAY(", "^CHNVPAY( " D LOOP
  29773   "RTN","CHM FEDISTP3", 14,0)
  29774    G END
  29775   "RTN","CHM FEDISTP3", 15,0)
  29776   LOOP S CI= 0
  29777   "RTN","CHM FEDISTP3", 16,0)
  29778   LOOP1 S CI =$O(@(GLPA Y_"""C"",C HMFPDI,CI) ")) Q:'CI
  29779   "RTN","CHM FEDISTP3", 17,0)
  29780   AUDIT G:'$ D(^CHMASQ( "C",CI)) V ENDR S CHI N="",DIK=" ^CHMASQ("
  29781   "RTN","CHM FEDISTP3", 18,0)
  29782    F  S CHIN =$O(^CHMAS Q("C",CI,C HIN)) Q:'C HIN  S DA= CHIN D ^DI K D
  29783   "RTN","CHM FEDISTP3", 19,0)
  29784    .S CHMQNA M="CHMASQ( " D REMOVE
  29785   "RTN","CHM FEDISTP3", 20,0)
  29786   VENDR Q:'$ D(CI)
  29787   "RTN","CHM FEDISTP3", 21,0)
  29788    Q:CI=""   G:'$D(^CHM QVN("G",CI )) QA S CH IN=0
  29789   "RTN","CHM FEDISTP3", 22,0)
  29790   V1 S CHIN= $O(^CHMQVN ("G",CI,CH IN)) G:'CH IN QA S CH JN=0
  29791   "RTN","CHM FEDISTP3", 23,0)
  29792   V2 S CHJN= $O(^CHMQVN ("G",CI,CH IN,CHJN))  G:'CHJN V1
  29793   "RTN","CHM FEDISTP3", 24,0)
  29794    G:'$D(^CH MQVN(CHIN, 10,CHJN,0) ) V2
  29795   "RTN","CHM FEDISTP3", 25,0)
  29796    K ^CHMQVN (CHIN,10,C HJN,0)
  29797   "RTN","CHM FEDISTP3", 26,0)
  29798    K ^CHMQVN (CHIN,10," B",CI,CHJN )
  29799   "RTN","CHM FEDISTP3", 27,0)
  29800    K ^CHMQVN ("G",CI,CH IN,CHJN)
  29801   "RTN","CHM FEDISTP3", 28,0)
  29802    S CLCNT=$ P(^CHMQVN( CHIN,10,0) ,"^",4)
  29803   "RTN","CHM FEDISTP3", 29,0)
  29804    S CLCNT=C LCNT-1
  29805   "RTN","CHM FEDISTP3", 30,0)
  29806    S $P(^CHM QVN(CHIN,1 0,0),"^",4 )=CLCNT
  29807   "RTN","CHM FEDISTP3", 31,0)
  29808    I CLCNT<1  S DIE=741 050.01,DR= ".03///^S  X=2",DA=CH IN D ^DIE
  29809   "RTN","CHM FEDISTP3", 32,0)
  29810    S VPDI=$P (^CHMQVN(C HIN,0),"^" ,17)
  29811   "RTN","CHM FEDISTP3", 33,0)
  29812    S VCLM=$P (^CHMQVN(C HIN,0),"^" ,18)
  29813   "RTN","CHM FEDISTP3", 34,0)
  29814    I VPDI'=" ",VCLM'=""  K ^CHMQVN ("APDI",VP DI,VCLM,CH IN),VCLM,V PDI
  29815   "RTN","CHM FEDISTP3", 35,0)
  29816    S CHMQNAM ="CHMQVN("  D REMOVE
  29817   "RTN","CHM FEDISTP3", 36,0)
  29818    G V2
  29819   "RTN","CHM FEDISTP3", 37,0)
  29820   QA G:'$D(^ CHMQAQ("D" ,CI)) ELIG
  29821   "RTN","CHM FEDISTP3", 38,0)
  29822    S CHIN=$O (^CHMQAQ(" D",CI,9999 ),-1) D
  29823   "RTN","CHM FEDISTP3", 39,0)
  29824    .Q:'CHIN   Q:'$D(^(C HIN,0))
  29825   "RTN","CHM FEDISTP3", 40,0)
  29826    .S:$P(^(0 ),"^",1)'= 7 CHMQNAM= "CHMQA1("
  29827   "RTN","CHM FEDISTP3", 41,0)
  29828    .S:$P(^(0 ),"^",1)=7  CHMQNAM=" CHMQA2("
  29829   "RTN","CHM FEDISTP3", 42,0)
  29830    S CHIN=0, DIK="^CHMQ AQ("
  29831   "RTN","CHM FEDISTP3", 43,0)
  29832    F  S CHIN =$O(^CHMQA Q("D",CI,C HIN)) Q:'C HIN   S DA =CHIN D ^D IK D REMOV E
  29833   "RTN","CHM FEDISTP3", 44,0)
  29834   ELIG G:'$D (^CHMELQ(" C",CI)) PR OBS S CHIN =""
  29835   "RTN","CHM FEDISTP3", 45,0)
  29836   EL1 S CHIN =$O(^CHMEL Q("C",CI,C HIN)) G:'C HIN PROBS
  29837   "RTN","CHM FEDISTP3", 46,0)
  29838    G:'$D(^CH MELQ(CHIN, 0)) EL1 S  ST=$P(^(0) ,"^",6),DA TE=$P(^(0) ,"^",1)
  29839   "RTN","CHM FEDISTP3", 47,0)
  29840    S DFN=$P( ^(0),"^",8 ),BFN=$P(^ (0),"^",9) ,RDATE=$P( DATE,".",1 )
  29841   "RTN","CHM FEDISTP3", 48,0)
  29842    S RDATE=9 999999-RDA TE
  29843   "RTN","CHM FEDISTP3", 49,0)
  29844    K ^CHMELQ (CHIN),^CH MELQ("B",S T,RDATE,CH IN)
  29845   "RTN","CHM FEDISTP3", 50,0)
  29846    K ^CHMELQ ("C",CI,CH IN),^CHMEL Q("D",ST,D FN,BFN,CHI N)
  29847   "RTN","CHM FEDISTP3", 51,0)
  29848    S CHMQNAM ="CHMELQ(" ,CHMOUT=""  K CHMIN D  ^CHMIS041
  29849   "RTN","CHM FEDISTP3", 52,0)
  29850    S CHMQNAM ="CHMELQ("  D REMOVE
  29851   "RTN","CHM FEDISTP3", 53,0)
  29852    G EL1
  29853   "RTN","CHM FEDISTP3", 54,0)
  29854   PROBS G:'$ D(^CHMPSQ( "C",CI)) E OB S CHIN= "",DIK="^C HMPSQ("
  29855   "RTN","CHM FEDISTP3", 55,0)
  29856    F  S CHIN =$O(^CHMPS Q("C",CI,C HIN)) Q:'C HIN  S DA= CHIN D ^DI K D
  29857   "RTN","CHM FEDISTP3", 56,0)
  29858    .S CHMQNA M="CHMPSQ( " D REMOVE
  29859   "RTN","CHM FEDISTP3", 57,0)
  29860   EOB G:'$D( ^CHMEOBQ(" D",CI)) EO B1 S CHIN= "",DIK="^C HMEOBQ("
  29861   "RTN","CHM FEDISTP3", 58,0)
  29862    F  S CHIN =$O(^CHMEO BQ("D",CI, CHIN)) Q:' CHIN  S DA =CHIN D ^D IK D
  29863   "RTN","CHM FEDISTP3", 59,0)
  29864    .S CHMQNA M="CHMEOBQ (" D REMOV E
  29865   "RTN","CHM FEDISTP3", 60,0)
  29866   EOB1 G:'$D (^CHNVEOBQ ("D",CI))  INHQ S CHI N="",DIK=" ^CHNVEOBQ( "
  29867   "RTN","CHM FEDISTP3", 61,0)
  29868    F  S CHIN =$O(^CHNVE OBQ("D",CI ,CHIN)) Q: 'CHIN  S D A=CHIN D ^ DIK
  29869   "RTN","CHM FEDISTP3", 62,0)
  29870   INHQ G:'$D (^CHMIHQ(" C",CI)) DU PCL S CHIN ="",DIK="^ CHMIHQ("
  29871   "RTN","CHM FEDISTP3", 63,0)
  29872    F  S CHIN =$O(^CHMIH Q("C",CI,C HIN)) Q:'C HIN  S DA= CHIN D ^DI K D
  29873   "RTN","CHM FEDISTP3", 64,0)
  29874    .S CHMQNA M="CHMIHQ( " D REMOVE
  29875   "RTN","CHM FEDISTP3", 65,0)
  29876   DUPCL G:'$ D(^CHMDPCL (741010.13 ,"D",CI))  MISD S CHI N="",DIK=" ^CHMDPCL(7 41010.13,"
  29877   "RTN","CHM FEDISTP3", 66,0)
  29878    F  S CHIN =$O(^CHMDP CL(741010. 13,"D",CI, CHIN)) Q:' CHIN  S DA =CHIN D ^D IK D
  29879   "RTN","CHM FEDISTP3", 67,0)
  29880    .S CHMQNA M="CHMDPCL (" D REMOV E
  29881   "RTN","CHM FEDISTP3", 68,0)
  29882   MISD G:'$D (^CHMMDQ(" C",CI)) MC CR S CHIN= "",DIK="^C HMMDQ("
  29883   "RTN","CHM FEDISTP3", 69,0)
  29884    F  S CHIN =$O(^CHMMD Q("C",CI,C HIN)) Q:'C HIN  S DA= CHIN D ^DI K D
  29885   "RTN","CHM FEDISTP3", 70,0)
  29886    .S CHMQNA M="CHMMDQ( " D REMOVE
  29887   "RTN","CHM FEDISTP3", 71,0)
  29888   MCCR I '$D (^CHMCCR(" D",CI)) G: $D(XXXFLG)  END G LOO P1
  29889   "RTN","CHM FEDISTP3", 72,0)
  29890    S CHIN="" ,DIK="^CHM CCR("
  29891   "RTN","CHM FEDISTP3", 73,0)
  29892    F  S CHIN =$O(^CHMCC R("D",CI,C HIN)) Q:'C HIN  S DA= CHIN D ^DI K D
  29893   "RTN","CHM FEDISTP3", 74,0)
  29894    .S CHMQNA M="CHMCCR( " D REMOVE
  29895   "RTN","CHM FEDISTP3", 75,0)
  29896    G:$D(XXXF LG) END
  29897   "RTN","CHM FEDISTP3", 76,0)
  29898    G LOOP1
  29899   "RTN","CHM FEDISTP3", 77,0)
  29900   END K Z,CH IN,CHSTATU S,CHJN,ZZ, CHCLIM,CHT AX,CHVENPT ,XXXFLG Q
  29901   "RTN","CHM FEDISTP3", 78,0)
  29902   REMOVE S C HMOUT="" K  CHMIN D ^ CHMIS041
  29903   "RTN","CHM FEDISTP5")
  29904   0^86^B8371 200
  29905   "RTN","CHM FEDISTP5", 1,0)
  29906   CHMFEDISTP 5 ;HAC/KML ;EDI RE-OP EN - PDI C LAIM STRIP  FOR VOIDE D PDI;
  29907   "RTN","CHM FEDISTP5", 2,0)
  29908    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  29909   "RTN","CHM FEDISTP5", 3,0)
  29910    ;
  29911   "RTN","CHM FEDISTP5", 4,0)
  29912    ; USER ST ORY 005-04 2 - An 837  with Freq uency type  code "8"  is receive d.   The O riginal PD I is in pr ocess and  all claims /lines are  in proces s :
  29913   "RTN","CHM FEDISTP5", 5,0)
  29914    ; The sys tem will " strip" the  Original  PDI of all  claims.
  29915   "RTN","CHM FEDISTP5", 6,0)
  29916    ;
  29917   "RTN","CHM FEDISTP5", 7,0)
  29918    ; The CHM FEDISTP* s eries of r outines we re copied  from the C HMFSTP* se ries of ro utines.    The primar y differen ce between  the 2 set s is that 
  29919   "RTN","CHM FEDISTP5", 8,0)
  29920    ; the EDI  version o f the rout ines do no t interact  with the  user; and  the EDI ve rsion will  strip the  PDI when  the claims  are IN PR OCESS rath er 
  29921   "RTN","CHM FEDISTP5", 9,0)
  29922    ; than PA YMENT REQU ESTED
  29923   "RTN","CHM FEDISTP5", 10,0)
  29924    ;
  29925   "RTN","CHM FEDISTP5", 11,0)
  29926   CHK(OPDI,C HLAND) ; 
  29927   "RTN","CHM FEDISTP5", 12,0)
  29928    ; input -  OPDI = PD I to be st ripped
  29929   "RTN","CHM FEDISTP5", 13,0)
  29930    ;          CHLAND =  passed by  reference,  flag to i ndicate if  PDI can b e stripped
  29931   "RTN","CHM FEDISTP5", 14,0)
  29932    ;                                           0 = canno t be strip ped; 1 = c an be stri pped
  29933   "RTN","CHM FEDISTP5", 15,0)
  29934    S GLPAY=" ^CHMPAY("  D LOOP
  29935   "RTN","CHM FEDISTP5", 16,0)
  29936    G CKEND
  29937   "RTN","CHM FEDISTP5", 17,0)
  29938   LOOP S CI= 0,CHLAND=0
  29939   "RTN","CHM FEDISTP5", 18,0)
  29940   LOOP1 S CI =$O(@(GLPA Y_"""C"",O PDI,CI)"))  Q:'CI
  29941   "RTN","CHM FEDISTP5", 19,0)
  29942    I $P(@(GL PAY_"CI,0) "),"^",2)= 1 S CHLAND =1 Q  ;QUI T IF CLAIM  IS IN PRO CESS
  29943   "RTN","CHM FEDISTP5", 20,0)
  29944   AUDIT ;CHE CKS FOR CL AIM IN ASQ
  29945   "RTN","CHM FEDISTP5", 21,0)
  29946    G:'$D(^CH MASQ("C",C I)) VENDR  S CHIN=0
  29947   "RTN","CHM FEDISTP5", 22,0)
  29948    F  S CHIN =$O(^CHMAS Q("C",CI,C HIN)) Q:'C HIN  D
  29949   "RTN","CHM FEDISTP5", 23,0)
  29950    .Q:'$D(^C HMASQ(CHIN ,0))
  29951   "RTN","CHM FEDISTP5", 24,0)
  29952    .Q:$P(^CH MASQ(CHIN, 0),"^",6)' =1
  29953   "RTN","CHM FEDISTP5", 25,0)
  29954    .S CHLAND =1
  29955   "RTN","CHM FEDISTP5", 26,0)
  29956   VENDR ;CHE KS FOR CLA IM IN VEND OR Q
  29957   "RTN","CHM FEDISTP5", 27,0)
  29958    Q:'$D(CI)
  29959   "RTN","CHM FEDISTP5", 28,0)
  29960    Q:CI=""   G:'$D(^CHM QVN("G",CI )) QA S CH IN=0
  29961   "RTN","CHM FEDISTP5", 29,0)
  29962   V1 S CHIN= $O(^CHMQVN ("G",CI,CH IN)) G:'CH IN QA
  29963   "RTN","CHM FEDISTP5", 30,0)
  29964    G:'$D(^CH MQVN(CHIN, 0)) V1
  29965   "RTN","CHM FEDISTP5", 31,0)
  29966    G:$P(^CHM QVN(CHIN,0 ),"^",3)>1  V1 S CHLA ND=1
  29967   "RTN","CHM FEDISTP5", 32,0)
  29968    G V1
  29969   "RTN","CHM FEDISTP5", 33,0)
  29970   QA ;CHECKS  QA (CPD A ND P&C) QU EUE
  29971   "RTN","CHM FEDISTP5", 34,0)
  29972    G:'$D(^CH MQAQ("D",C I)) ELIG
  29973   "RTN","CHM FEDISTP5", 35,0)
  29974    S CHIN=0
  29975   "RTN","CHM FEDISTP5", 36,0)
  29976    F  S CHIN =$O(^CHMQA Q("D",CI,C HIN)) Q:'C HIN   D
  29977   "RTN","CHM FEDISTP5", 37,0)
  29978    .Q:'$D(^C HMQAQ(CHIN ,0))  Q:$P (^CHMQAQ(C HIN,0),"^" ,3)=2
  29979   "RTN","CHM FEDISTP5", 38,0)
  29980    .S CHLAND =1
  29981   "RTN","CHM FEDISTP5", 39,0)
  29982   ELIG ;CHEC KS ELIG QU EUE
  29983   "RTN","CHM FEDISTP5", 40,0)
  29984    G:'$D(^CH MELQ("C",C I)) PROBS  S CHIN=""
  29985   "RTN","CHM FEDISTP5", 41,0)
  29986   EL1 S CHIN =$O(^CHMEL Q("C",CI,C HIN)) G:'C HIN PROBS
  29987   "RTN","CHM FEDISTP5", 42,0)
  29988    G:'$D(^CH MELQ(CHIN, 0)) EL1 S  ST=$P(^CHM ELQ(CHIN,0 ),"^",6)
  29989   "RTN","CHM FEDISTP5", 43,0)
  29990    G:ST>1 EL 1 S CHLAND =1
  29991   "RTN","CHM FEDISTP5", 44,0)
  29992    G EL1
  29993   "RTN","CHM FEDISTP5", 45,0)
  29994   PROBS ;CHE CKS PROB S UPPORT QUE UE
  29995   "RTN","CHM FEDISTP5", 46,0)
  29996    G:'$D(^CH MPSQ("C",C I)) CKEOB  S CHIN=""
  29997   "RTN","CHM FEDISTP5", 47,0)
  29998    F  S CHIN =$O(^CHMPS Q("C",CI,C HIN)) Q:'C HIN  D
  29999   "RTN","CHM FEDISTP5", 48,0)
  30000    .Q:'$D(^C HMPSQ(CHIN ,0))
  30001   "RTN","CHM FEDISTP5", 49,0)
  30002    .Q:$P(^CH MPSQ(CHIN, 0),"^",3)> 2
  30003   "RTN","CHM FEDISTP5", 50,0)
  30004    .S CHLAND =1
  30005   "RTN","CHM FEDISTP5", 51,0)
  30006   CKEOB ;CHE CKS EOB QU EUE
  30007   "RTN","CHM FEDISTP5", 52,0)
  30008    G:'$D(^CH MEOBQ("D", CI)) CKEOB 1 S CHIN=" "
  30009   "RTN","CHM FEDISTP5", 53,0)
  30010    F  S CHIN =$O(^CHMEO BQ("D",CI, CHIN)) Q:' CHIN  D
  30011   "RTN","CHM FEDISTP5", 54,0)
  30012    .Q:'$D(^C HMEOBQ(CHI N,0))
  30013   "RTN","CHM FEDISTP5", 55,0)
  30014    .Q:$P(^CH MEOBQ(CHIN ,0),"^",3) =1
  30015   "RTN","CHM FEDISTP5", 56,0)
  30016    .S CHLAND =1
  30017   "RTN","CHM FEDISTP5", 57,0)
  30018   CKEOB1 G:' $D(^CHNVEO BQ("D",CI) ) INHQ S C HIN=""
  30019   "RTN","CHM FEDISTP5", 58,0)
  30020    F  S CHIN =$O(^CHNVE OBQ("D",CI ,CHIN)) Q: 'CHIN  S C HLAND=1
  30021   "RTN","CHM FEDISTP5", 59,0)
  30022   INHQ ;CHEC KS IN-HOUS E QUEUE
  30023   "RTN","CHM FEDISTP5", 60,0)
  30024    G:'$D(^CH MIHQ("C",C I)) DUPCL  S CHIN=""
  30025   "RTN","CHM FEDISTP5", 61,0)
  30026    F  S CHIN =$O(^CHMIH Q("C",CI,C HIN)) Q:'C HIN  D
  30027   "RTN","CHM FEDISTP5", 62,0)
  30028    .Q:'$D(^C HMIHQ(CHIN ,0))
  30029   "RTN","CHM FEDISTP5", 63,0)
  30030    .Q:$P(^CH MIHQ(CHIN, 0),"^",2)= 1
  30031   "RTN","CHM FEDISTP5", 64,0)
  30032    .S CHLAND =1
  30033   "RTN","CHM FEDISTP5", 65,0)
  30034   DUPCL ;CHE CKS DUPLIC ATE CLAIM  QUEUE
  30035   "RTN","CHM FEDISTP5", 66,0)
  30036    G:'$D(^CH MDPCL(7410 10.13,"D", CI)) MISD  S CHIN=""
  30037   "RTN","CHM FEDISTP5", 67,0)
  30038    F  S CHIN =$O(^CHMDP CL(741010. 13,"D",CI, CHIN)) Q:' CHIN  D
  30039   "RTN","CHM FEDISTP5", 68,0)
  30040    .Q:'$D(^C HMDPCL(741 010.13,CHI N,0))
  30041   "RTN","CHM FEDISTP5", 69,0)
  30042    .Q:$P(^CH MDPCL(7410 10.13,CHIN ,0),"^",3) >1
  30043   "RTN","CHM FEDISTP5", 70,0)
  30044    .S CHLAND =1
  30045   "RTN","CHM FEDISTP5", 71,0)
  30046   MISD ;CHEC KS MISSING  DATA QUEU E
  30047   "RTN","CHM FEDISTP5", 72,0)
  30048    G:'$D(^CH MMDQ("C",C I)) MCCR S  CHIN=""
  30049   "RTN","CHM FEDISTP5", 73,0)
  30050    F  S CHIN =$O(^CHMMD Q("C",CI,C HIN)) Q:'C HIN  D
  30051   "RTN","CHM FEDISTP5", 74,0)
  30052    .Q:'$D(^C HMMDQ(CHIN ,0))
  30053   "RTN","CHM FEDISTP5", 75,0)
  30054    .Q:$P(^CH MMDQ(CHIN, 0),"^",3)> 1
  30055   "RTN","CHM FEDISTP5", 76,0)
  30056    .S CHLAND =1
  30057   "RTN","CHM FEDISTP5", 77,0)
  30058   MCCR ;CHEC KS MCCR QU EUE
  30059   "RTN","CHM FEDISTP5", 78,0)
  30060    I '$D(^CH MCCR("D",C I)) G LOOP 1
  30061   "RTN","CHM FEDISTP5", 79,0)
  30062    S CHIN=""
  30063   "RTN","CHM FEDISTP5", 80,0)
  30064    F  S CHIN =$O(^CHMCC R("D",CI,C HIN)) Q:'C HIN  D
  30065   "RTN","CHM FEDISTP5", 81,0)
  30066    .Q:'$D(^C HMCCR(CHIN ,0))
  30067   "RTN","CHM FEDISTP5", 82,0)
  30068    .Q:$P(^CH MCCR(CHIN, 0),"^",3)> 2
  30069   "RTN","CHM FEDISTP5", 83,0)
  30070    .S CHLAND =1
  30071   "RTN","CHM FEDISTP5", 84,0)
  30072    G LOOP1
  30073   "RTN","CHM FEDISTP5", 85,0)
  30074   CKEND ;
  30075   "RTN","CHM FEDISTP5", 86,0)
  30076    K Z,CHIN, CHSTATUS,C HJN,ZZ,CHC LIM,CHTAX, CHVENPT
  30077   "RTN","CHM FEDISTP5", 87,0)
  30078    Q
  30079   "RTN","CHM FPDO3")
  30080   0^87^B3983 713
  30081   "RTN","CHM FPDO3",1,0 )
  30082   CHMFPDO3 ; CFS;RETRIE VES PDI AN D DOC # FO R INT PROC ;05/11/17   2:13 PM
  30083   "RTN","CHM FPDO3",2,0 )
  30084    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  30085   "RTN","CHM FPDO3",3,0 )
  30086    ;CFS 05/1 1/17 CPE00 5-004 EDI  Reopen PDI  Retrival  for CHAMPV A.
  30087   "RTN","CHM FPDO3",4,0 )
  30088    ;JSG2 10/ 20/2017 CP E005-023 F ix System  Status for  EDI Reope n
  30089   "RTN","CHM FPDO3",5,0 )
  30090    S (CHMFPD I,CHMOPDI) ="" K CHQU IT
  30091   "RTN","CHM FPDO3",6,0 )
  30092    Q:$P(^CHM DIC(741002 .17,1,0)," ^",18)=1
  30093   "RTN","CHM FPDO3",7,0 )
  30094   A0 I '$D(^ CHMIMG("OC RR-READY") ) D NOPDI  S CHQUIT=1  G END
  30095   "RTN","CHM FPDO3",8,0 )
  30096    L +^CHMIM G("OCRR-RE ADY")
  30097   "RTN","CHM FPDO3",9,0 )
  30098    S CHMFPDI =$O(^CHMIM G("OCRR-RE ADY",CHMFP DI))
  30099   "RTN","CHM FPDO3",10, 0)
  30100    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",5)=CH MFPDI
  30101   "RTN","CHM FPDO3",11, 0)
  30102    K ^CHMIMG ("OCRR-REA DY",CHMFPD I)  ;AEB 2 /7/2007
  30103   "RTN","CHM FPDO3",12, 0)
  30104    L -^CHMIM G("OCRR-RE ADY")
  30105   "RTN","CHM FPDO3",13, 0)
  30106   A1 ; 
  30107   "RTN","CHM FPDO3",14, 0)
  30108    S CHMFNMP G=$P(^CHMI MG(CHMFPDI ,0),"^",2)
  30109   "RTN","CHM FPDO3",15, 0)
  30110    S CHDOCID ="",TYP=$E (CHMFPDI,8 ,9)  ;TLH  11/20/06 F OR DEV0001 15
  30111   "RTN","CHM FPDO3",16, 0)
  30112    ;NEXT LIN E FOR SYST EM STATIST ICS -- SUB TRACT ONE  FROM EDI/O CR
  30113   "RTN","CHM FPDO3",17, 0)
  30114    ; CPE005- 023 Correc t CHAMPVA  System Sta tus
  30115   "RTN","CHM FPDO3",18, 0)
  30116    ; S CHMQN AM="EDI/OC R",CHMOUT= "" K CHMIN  D ^CHMIS0 41  ;TLH 1 1/20/06 FO R DEV00011 5
  30117   "RTN","CHM FPDO3",19, 0)
  30118    S CHMQNAM ="EDI-REOP EN",CHMOUT ="" K CHMI N D ^CHMIS 041  ;TLH  11/20/06 F OR DEV0001 15
  30119   "RTN","CHM FPDO3",20, 0)
  30120    ;
  30121   "RTN","CHM FPDO3",21, 0)
  30122    K CHIMRMV I,CHIMCLMP  S CHIMMVE I=""
  30123   "RTN","CHM FPDO3",22, 0)
  30124   END K CHIM RMVI,CHIMC LMP,CHIMMV EI Q
  30125   "RTN","CHM FPDO3",23, 0)
  30126   NODOC W !! ,"PDI: ",C HMFPDI," i s not set  up for ima ge collect ion." G CO NT
  30127   "RTN","CHM FPDO3",24, 0)
  30128   NOPDI W !! ,"There ar e no PDI's  that curr ently need  image pro cessing."  G CONT
  30129   "RTN","CHM FPDO3",25, 0)
  30130   NODEV W !! ,"Database  corruptio n, Please  contact AD P." G CONT
  30131   "RTN","CHM FPDO3",26, 0)
  30132   CONT W !!, "Press <RE TURN> to c ontinue... ......." R  X:5 Q
  30133   "RTN","CHM FPDO3",27, 0)
  30134   REMV S CHD OCID="" Q: '$D(CHMFPD I)  Q:CHMF PDI=""
  30135   "RTN","CHM FPDO3",28, 0)
  30136    S:$D(^CHM IMG(CHMFPD I,"DOC"))  CHDOCID=$P (^CHMIMG(C HMFPDI,"DO C"),"^",1)
  30137   "RTN","CHM FPDO3",29, 0)
  30138    D RET^CHM MT2 Q:'$D( CHSS)  Q:C HSS=""
  30139   "RTN","CHM FPDO3",30, 0)
  30140    K CHIMCLM P,CHIMMVEI  S CHIMRMV I="" D ENS ET^CHMMW1  Q
  30141   "RTN","CHM FPDO3",31, 0)
  30142   REMV1 S CH DOCID="" Q :'$D(CHMFP DI)  Q:CHM FPDI=""
  30143   "RTN","CHM FPDO3",32, 0)
  30144    S:$D(^CHM IMG(CHMFPD I,"DOC"))  CHDOCID=$P (^CHMIMG(C HMFPDI,"DO C"),"^",1)
  30145   "RTN","CHM FPDO3",33, 0)
  30146    D RET^CHM MT2 Q:'$D( CHSS)  Q:C HSS=""
  30147   "RTN","CHM FPDO3",34, 0)
  30148    K CHIMRMV I,CHIMMVEI  S CHIMCLM P="" D ENS ET^CHMMW1  Q
  30149   "RTN","CHM FPDO4")
  30150   0^88^B3806 748
  30151   "RTN","CHM FPDO4",1,0 )
  30152   CHMFPDO4 ; CFS;RETRIE VES PDI AN D DOC # FO R INT PROC ;05/11/17   2:13 PM
  30153   "RTN","CHM FPDO4",2,0 )
  30154    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  30155   "RTN","CHM FPDO4",3,0 )
  30156    ;CFS 05/1 1/17 CPE00 5-004 EDI  Reopen PDI  Retrieval  for Spina  Bifida.
  30157   "RTN","CHM FPDO4",4,0 )
  30158    S (CHMFPD I,CHMOPDI) ="" K CHQU IT
  30159   "RTN","CHM FPDO4",5,0 )
  30160    Q:$P(^CHM DIC(741002 .17,1,0)," ^",18)=1
  30161   "RTN","CHM FPDO4",6,0 )
  30162   A0 I '$D(^ CHMIMG("SB OCRR-READY ")) D NOPD I S CHQUIT =1 G END
  30163   "RTN","CHM FPDO4",7,0 )
  30164    L +^CHMIM G("SBOCRR- READY")
  30165   "RTN","CHM FPDO4",8,0 )
  30166    S CHMFPDI =$O(^CHMIM G("SBOCRR- READY",CHM FPDI))
  30167   "RTN","CHM FPDO4",9,0 )
  30168    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",5)=CH MFPDI
  30169   "RTN","CHM FPDO4",10, 0)
  30170    K ^CHMIMG ("SBOCRR-R EADY",CHMF PDI)  ;AEB  2/7/2007
  30171   "RTN","CHM FPDO4",11, 0)
  30172    L -^CHMIM G("SBOCRR- READY")
  30173   "RTN","CHM FPDO4",12, 0)
  30174   A1 ;
  30175   "RTN","CHM FPDO4",13, 0)
  30176    S CHMFNMP G=$P(^CHMI MG(CHMFPDI ,0),"^",2)
  30177   "RTN","CHM FPDO4",14, 0)
  30178    S CHDOCID ="",TYP=$E (CHMFPDI,8 ,9)  ;TLH  11/20/06 F OR DEV0001 15
  30179   "RTN","CHM FPDO4",15, 0)
  30180    ;NEXT LIN E FOR SYST EM STATIST ICS -- SUB TRACT ONE  FROM EDI/O CR
  30181   "RTN","CHM FPDO4",16, 0)
  30182    S CHMQNAM ="EDI/OCR" ,CHMOUT=""  K CHMIN D  ^CHMIS041   ;TLH 11/ 20/06 FOR  DEV000115
  30183   "RTN","CHM FPDO4",17, 0)
  30184    ;
  30185   "RTN","CHM FPDO4",18, 0)
  30186    K CHIMRMV I,CHIMCLMP  S CHIMMVE I=""
  30187   "RTN","CHM FPDO4",19, 0)
  30188   END K CHIM RMVI,CHIMC LMP,CHIMMV EI Q
  30189   "RTN","CHM FPDO4",20, 0)
  30190   NODOC W !! ,"PDI: ",C HMFPDI," i s not set  up for ima ge collect ion." G CO NT
  30191   "RTN","CHM FPDO4",21, 0)
  30192   NOPDI W !! ,"There ar e no PDI's  that curr ently need  image pro cessing."  G CONT
  30193   "RTN","CHM FPDO4",22, 0)
  30194   NODEV W !! ,"Database  corruptio n, Please  contact AD P." G CONT
  30195   "RTN","CHM FPDO4",23, 0)
  30196   CONT W !!, "Press <RE TURN> to c ontinue... ......." R  X:5 Q
  30197   "RTN","CHM FPDO4",24, 0)
  30198   REMV S CHD OCID="" Q: '$D(CHMFPD I)  Q:CHMF PDI=""
  30199   "RTN","CHM FPDO4",25, 0)
  30200    S:$D(^CHM IMG(CHMFPD I,"DOC"))  CHDOCID=$P (^CHMIMG(C HMFPDI,"DO C"),"^",1)
  30201   "RTN","CHM FPDO4",26, 0)
  30202    D RET^CHM MT2 Q:'$D( CHSS)  Q:C HSS=""
  30203   "RTN","CHM FPDO4",27, 0)
  30204    K CHIMCLM P,CHIMMVEI  S CHIMRMV I="" D ENS ET^CHMMW1  Q
  30205   "RTN","CHM FPDO4",28, 0)
  30206   REMV1 S CH DOCID="" Q :'$D(CHMFP DI)  Q:CHM FPDI=""
  30207   "RTN","CHM FPDO4",29, 0)
  30208    S:$D(^CHM IMG(CHMFPD I,"DOC"))  CHDOCID=$P (^CHMIMG(C HMFPDI,"DO C"),"^",1)
  30209   "RTN","CHM FPDO4",30, 0)
  30210    D RET^CHM MT2 Q:'$D( CHSS)  Q:C HSS=""
  30211   "RTN","CHM FPDO4",31, 0)
  30212    K CHIMRMV I,CHIMMVEI  S CHIMCLM P="" D ENS ET^CHMMW1  Q
  30213   "RTN","CHM FSR21")
  30214   0^57^B7569 5939
  30215   "RTN","CHM FSR21",1,0 )
  30216   CHMFSR21 ; JLR/DEN;SE TTING OUT  CLAIM INFO  TO CLAIM  FILE;09/22 /97  3:30  PM
  30217   "RTN","CHM FSR21",2,0 )
  30218    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  30219   "RTN","CHM FSR21",3,0 )
  30220    ;PT 11575
  30221   "RTN","CHM FSR21",4,0 )
  30222    ;DEV00369 8 4/20/201 0 AEB
  30223   "RTN","CHM FSR21",5,0 )
  30224    ;DEV00782 0 12/22/20 10 AEB
  30225   "RTN","CHM FSR21",6,0 )
  30226    ; CPE001- 002 WTC 8/ 3/17
  30227   "RTN","CHM FSR21",7,0 )
  30228    ; CPE005- 063 BDB 11 /15/2017
  30229   "RTN","CHM FSR21",8,0 )
  30230   CLAIM L +^ CHMPAY(0)  S N=$P((^C HMPAY(0)), "^",3),N=N +1,$P(^(0) ,"^",3)=N, $P(^(0),"^ ",4)=N L - ^CHMPAY(0)   ;AEB 6/2 /2011 DEV0 07820
  30231   "RTN","CHM FSR21",9,0 )
  30232    G:$D(@(GL PAY_"N)"))  CLAIM
  30233   "RTN","CHM FSR21",10, 0)
  30234    K DIC S D A=N,CPT=DA ,ASS="",DI E=GLPAY D  ^CHMFSRT3  D CLMS
  30235   "RTN","CHM FSR21",11, 0)
  30236    S $P(@(GL PAY_"DA,0) "),"^",1)= CHMFCLNM S  @(GLPAY_" ""B"",CHMF CLNM,DA)") =""
  30237   "RTN","CHM FSR21",12, 0)
  30238    ;
  30239   "RTN","CHM FSR21",13, 0)
  30240    S $P(@(GL HST_"DA,0) "),"^",1)= CHMFCLNM S  @(GLHST_" ""B"",CHMF CLNM,DA)") =""
  30241   "RTN","CHM FSR21",14, 0)
  30242    S $P(@(GL HST_"0)"), U,3)=DA
  30243   "RTN","CHM FSR21",15, 0)
  30244    S $P(@(GL HST_"0)"), U,4)=DA
  30245   "RTN","CHM FSR21",16, 0)
  30246    ;
  30247   "RTN","CHM FSR21",17, 0)
  30248    S ^CHMIND EX(DA,0)=C HMFCLNM_"^ "_PRGTYP
  30249   "RTN","CHM FSR21",18, 0)
  30250    S ^CHMIND EX("B",CHM FCLNM,DA)= ""
  30251   "RTN","CHM FSR21",19, 0)
  30252    ;
  30253   "RTN","CHM FSR21",20, 0)
  30254    D ^CHMFA0 06
  30255   "RTN","CHM FSR21",21, 0)
  30256    S DR=".27 ///^S X=CH TYPINT" D  ^DIE
  30257   "RTN","CHM FSR21",22, 0)
  30258    S DR=".02 ///^S X="" IN PROCESS """ D ^DIE
  30259   "RTN","CHM FSR21",23, 0)
  30260    S DR=".07 ///^S X=TY " D ^DIE
  30261   "RTN","CHM FSR21",24, 0)
  30262    ;S $P(^CH MPAY(DA,0) ,"^",8)=DO S
  30263   "RTN","CHM FSR21",25, 0)
  30264    S DR=".08 ////^S X=D OS" D ^DIE
  30265   "RTN","CHM FSR21",26, 0)
  30266    S DR=".21 ////^S X=D FN" D ^DIE
  30267   "RTN","CHM FSR21",27, 0)
  30268    S DR=".22 ///^S X=BF N" D ^DIE
  30269   "RTN","CHM FSR21",28, 0)
  30270    ;NEXT 1 L INE CJM 8/ 13/92
  30271   "RTN","CHM FSR21",29, 0)
  30272    D NOW^%DT C S DR=".2 5///^S X=% " D ^DIE
  30273   "RTN","CHM FSR21",30, 0)
  30274    S DR="3.0 1///^S X=" "`""_DUZ"
  30275   "RTN","CHM FSR21",31, 0)
  30276    D ^DIE
  30277   "RTN","CHM FSR21",32, 0)
  30278    I ($$TYPE ^CHMFPDI2( CHMFPDI)=9 0)!($$TYPE ^CHMFPDI2( CHMFPDI)=9 7) D  ;bdb  11/15/201 7 add the  re-open po inters
  30279   "RTN","CHM FSR21",33, 0)
  30280    . N CLOPT
  30281   "RTN","CHM FSR21",34, 0)
  30282    . Q:'$G(C HMOPDI)
  30283   "RTN","CHM FSR21",35, 0)
  30284    . S CLOPT ="" F  S C LOPT=$O(@( GLPAY_"""C "",CHMOPDI ,CLOPT)"))  Q:CLOPT=" "  I $P(@( GLPAY_"CLO PT,0)"),"^ ",8)=DOS D   Q
  30285   "RTN","CHM FSR21",36, 0)
  30286    .. S $P(@ (GLPAY_"CL OPT,6)")," ^",1)=DA
  30287   "RTN","CHM FSR21",37, 0)
  30288    .. S $P(@ (GLPAY_"DA ,6)"),"^", 2)=CLOPT
  30289   "RTN","CHM FSR21",38, 0)
  30290    I ((TY=6) !(TY=2)) S  $P(@(GLPA Y_"DA,7)") ,"^",8)=ZI P  ;AEB 4/ 20/2010 DE V003698
  30291   "RTN","CHM FSR21",39, 0)
  30292    I VN I $D (^CHMIMAGE (PDI,"VEN- II",VN)) D
  30293   "RTN","CHM FSR21",40, 0)
  30294    . ;
  30295   "RTN","CHM FSR21",41, 0)
  30296    . ;  Get  PL ZIP fro m image fi le if it w as edited  before sor t was run.   wtc 8/9/ 17
  30297   "RTN","CHM FSR21",42, 0)
  30298    . ;
  30299   "RTN","CHM FSR21",43, 0)
  30300    . N CHMFZ PD ;
  30301   "RTN","CHM FSR21",44, 0)
  30302    . S CHMFZ PD=$P($G(^ CHMIMAGE(P DI,"VEN-II ",VN)),"^" ,15) ;
  30303   "RTN","CHM FSR21",45, 0)
  30304    . ;
  30305   "RTN","CHM FSR21",46, 0)
  30306    . ;  If E DI claim t hen get zi p code fro m buffer f ile.  wtc  8/5/17
  30307   "RTN","CHM FSR21",47, 0)
  30308    . ;
  30309   "RTN","CHM FSR21",48, 0)
  30310    . I CHMFZ PD="",$$TY PE^CHMFPDI 2(PDI)'<90  D  ;
  30311   "RTN","CHM FSR21",49, 0)
  30312    .. N CHFM PTC,CHFMXC L,CHMFBE ;
  30313   "RTN","CHM FSR21",50, 0)
  30314    .. S CHMF PTC="" F   S CHMFPTC= $O(^CHMXCL E("PDI",PD I,CHMFPTC) ) Q:CHMFPT C=""  D  Q :CHMFZPD'= ""  ;
  30315   "RTN","CHM FSR21",51, 0)
  30316    ... S CHM FXCL="" F   S CHMFXCL =$O(^CHMXC LE("PDI",P DI,CHMFPTC ,CHMFXCL))  Q:CHMFXCL =""  D  Q: CHMFZPD'=" "  ;
  30317   "RTN","CHM FSR21",52, 0)
  30318    ....S CHM FBE=$O(^CH MXCLE("PDI ",PDI,CHMF PTC,CHMFXC L,"")) Q:C HMFBE=""
  30319   "RTN","CHM FSR21",53, 0)
  30320    ....S CHM FZPD=$P($G (^CHMXCLE( +$P(CHMFBE ,"*",4),60 )),"^",9)  Q:CHMFZPD' =""
  30321   "RTN","CHM FSR21",54, 0)
  30322    ....S CHM FZPD=$P($G (^CHMXCLB( +$P(CHMFBE ,"*",2),0) ),"^",8)
  30323   "RTN","CHM FSR21",55, 0)
  30324    .. ; 
  30325   "RTN","CHM FSR21",56, 0)
  30326    .. ;  Sto re zip cod e in image  file.  wt c 8/5/17
  30327   "RTN","CHM FSR21",57, 0)
  30328    .. ;
  30329   "RTN","CHM FSR21",58, 0)
  30330    .. I CHMF ZPD'="" S  $P(^CHMIMA GE(PDI,"VE N-II",VN), "^",15)=$E (CHMFZPD,1 ,5) ;
  30331   "RTN","CHM FSR21",59, 0)
  30332    . ;
  30333   "RTN","CHM FSR21",60, 0)
  30334    . ;  Upda te claim f ile.  wtc  8/5/17
  30335   "RTN","CHM FSR21",61, 0)
  30336    . ;
  30337   "RTN","CHM FSR21",62, 0)
  30338    . S @(GLP AY_"DA,""V EN-II"")") =^CHMIMAGE (CHMFPDI," VEN-II",VN )
  30339   "RTN","CHM FSR21",63, 0)
  30340    ;
  30341   "RTN","CHM FSR21",64, 0)
  30342    I '$D(^CH MVEN(VN,0) ) D PSVEN  G A1
  30343   "RTN","CHM FSR21",65, 0)
  30344    S $P(@(GL PAY_"DA,0) "),"^",3)= VN,@(GLPAY _"""AD"",V N,DA)")=""
  30345   "RTN","CHM FSR21",66, 0)
  30346    S:$D(^CHM IMAGE(PDI, "VNPG",VN) ) $P(@(GLP AY_"DA,9)" ),"^",6)=^ CHMIMAGE(P DI,"VNPG", VN)
  30347   "RTN","CHM FSR21",67, 0)
  30348   A1 I $D(ME DPTR) I ME DPTR S $P( @(GLPAY_"D A,7)"),"^" ,1)=MEDPTR ,$P(@(GLPA Y_"DA,0)") ,"^",5)=1
  30349   "RTN","CHM FSR21",68, 0)
  30350    S DIE=GLP AY
  30351   "RTN","CHM FSR21",69, 0)
  30352    G:'$D(^UT ILITY("CLA IMS",$J,"C LFRM",DFN, BFN)) VEN
  30353   "RTN","CHM FSR21",70, 0)
  30354    S J=0 S J =$O(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J))
  30355   "RTN","CHM FSR21",71, 0)
  30356    S X0="" S :$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,0)) X0= ^UTILITY(" CLAIMS",$J ,"CLFRM",D FN,BFN,J,0 )
  30357   "RTN","CHM FSR21",72, 0)
  30358    S X1="" S :$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,1)) X1= ^UTILITY(" CLAIMS",$J ,"CLFRM",D FN,BFN,J,1 )
  30359   "RTN","CHM FSR21",73, 0)
  30360    S X2="" S :$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,2)) X2= ^UTILITY(" CLAIMS",$J ,"CLFRM",D FN,BFN,J,2 )
  30361   "RTN","CHM FSR21",74, 0)
  30362    S X3="" S :$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,3)) X3= ^UTILITY(" CLAIMS",$J ,"CLFRM",D FN,BFN,J,3 )
  30363   "RTN","CHM FSR21",75, 0)
  30364    S X4="" S :$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,4)) X4= ^UTILITY(" CLAIMS",$J ,"CLFRM",D FN,BFN,J,4 )
  30365   "RTN","CHM FSR21",76, 0)
  30366    S X7="" S :$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,"IMG"))  X7=^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,"IMG")
  30367   "RTN","CHM FSR21",77, 0)
  30368    S:$D(^UTI LITY("CLAI MS",$J,"CL FRM",DFN,B FN,J,"ASS" )) ASS=^UT ILITY("CLA IMS",$J,"C LFRM",DFN, BFN,J,"ASS ")
  30369   "RTN","CHM FSR21",78, 0)
  30370    S DR="10. 05///^S X= $P(X0,U,4) ;10.06///^ S X=$P(X0, U,3);10.07 ///^S X=$P (X0,U,6);1 0.08///^S  X=$P(X0,U, 9);10.09// /^S X=$P(X 0,U,11);10 .1///^S X= $P(X0,U,12 )" D ^DIE
  30371   "RTN","CHM FSR21",79, 0)
  30372    S DR="9.0 1///^S X=1 ;10.11///^ S X=$P(X0, U,13);10.1 3///^S X=$ P(X0,U,15) ;10.14///^ S X=$P(X0, U,10);10.1 5///^S X=$ P(X0,U,18) ;10.16///^ S X=$P(X0, U,19);10.1 7///^S X=$ P(X0,U,21) " D ^DIE
  30373   "RTN","CHM FSR21",80, 0)
  30374    ;S DR="9. 01///^S X= 1;10.11/// ^S X=$P(X0 ,U,13);10. 13///^S X= $P(X0,U,15 );10.15/// ^S X=$P(X0 ,U,18);10. 16///^S X= $P(X0,U,19 );10.17/// ^S X=$P(X0 ,U,21)" D  ^DIE
  30375   "RTN","CHM FSR21",81, 0)
  30376    I $D(^UTI LITY("CLAI MS",$J,DFN ,BFN,"NOCL M")) S DR= "9.01///^S  X=0" D ^D IE
  30377   "RTN","CHM FSR21",82, 0)
  30378    S AC="N"  S:$P(X0,"^ ",20)'=""  AC="Y"
  30379   "RTN","CHM FSR21",83, 0)
  30380    S DR="10. 02///^S X= AC;10.03// /^S X=AC"  D ^DIE
  30381   "RTN","CHM FSR21",84, 0)
  30382   WC S DR="1 0.01///^S  X=$P(X0,U, 14);10.12/ //^S X=$P( X0,U,14)"  D ^DIE
  30383   "RTN","CHM FSR21",85, 0)
  30384    G:$P(X0," ^",14)="N"  EMP S DR= "26.01///^ S X=$P(X2, U,2);26.02 ///^S X=$P (X2,U,3);2 6.03///^S  X=$P(X2,U, 4)" D ^DIE
  30385   "RTN","CHM FSR21",86, 0)
  30386    S DR="26. 04///^S X= $P(X2,U,5) ;26.05///^ S X=$P(X2, U,6);26.06 ///^S X=$P (X2,U,7);2 6.07///^S  X=$P(X2,U, 8)" D ^DIE
  30387   "RTN","CHM FSR21",87, 0)
  30388    S $P(@(GL PAY_"DA,26 )"),"^",8) =$P(X2,U,1 )
  30389   "RTN","CHM FSR21",88, 0)
  30390   EMP S EM=" Y" S:X3=""  EM="N" S  DR="10.04/ //^S X=EM"  D ^DIE G: EM="N" INS
  30391   "RTN","CHM FSR21",89, 0)
  30392    S DR="28. 01///^S X= $P(X3,U,1) ;28.02///^ S X=$P(X3, U,2);28.03 ///^S X=$P (X3,U,3);2 8.04///^S  X=$P(X3,U, 4)" D ^DIE
  30393   "RTN","CHM FSR21",90, 0)
  30394    S DR="28. 05///^S X= $P(X3,U,5) ;28.06///^ S X=$P(X3, U,6);28.07 ///^S X=$P (X3,U,7)"  D ^DIE
  30395   "RTN","CHM FSR21",91, 0)
  30396   INS G:X1=" " MIS
  30397   "RTN","CHM FSR21",92, 0)
  30398    S DR="24. 01///^S X= $P(X1,U,2) ;24.02///^ S X=$P(X1, U,3);24.03 ///^S X=$P (X1,U,4);2 4.04///^S  X=$P(X1,U, 5)" D ^DIE
  30399   "RTN","CHM FSR21",93, 0)
  30400    S DR="24. 05///^S X= $P(X1,U,6) ;24.06///^ S X=$P(X1, U,7);24.07 ///^S X=$P (X1,U,8);2 4.08///^S  X=$P(X1,U, 1)" D ^DIE
  30401   "RTN","CHM FSR21",94, 0)
  30402   MIS S DR=" .09///^S X =$P(^UTILI TY(""CLAIM S"",$J,""P DI"",CHMFP DI),U,4)"  D ^DIE
  30403   "RTN","CHM FSR21",95, 0)
  30404    S $P(@(GL PAY_"DA,20 )"),"^",1) =$P(X0,U,5 )
  30405   "RTN","CHM FSR21",96, 0)
  30406    I $P(X0,U ,5)'="" S  DR="10.05/ //^S X=""Y """ D ^DIE
  30407   "RTN","CHM FSR21",97, 0)
  30408    S DR="20. 02///^S X= $P(X0,U,7) " D ^DIE
  30409   "RTN","CHM FSR21",98, 0)
  30410    S DR="20. 03///^S X= $P(X0,U,20 )" D ^DIE
  30411   "RTN","CHM FSR21",99, 0)
  30412    S DR="20. 04///^S X= $P(X0,U,22 )" D ^DIE  D MORE
  30413   "RTN","CHM FSR21",100 ,0)
  30414   PDI S FNUM =$S(GLPAY= "^CHMPAY(" :741000.04 ,GLPAY="^C HNVPAY(":7 413001.04, 1:1)
  30415   "RTN","CHM FSR21",101 ,0)
  30416    S:'$D(@(G LPAY_"DA," "PDI"",0)" )) @(GLPAY _"DA,""PDI "",0)")="^ "_FNUM_"^0 ^0"
  30417   "RTN","CHM FSR21",102 ,0)
  30418    L +@(GLPA Y_"DA,""PD I"",0)") S  J=$P(@(GL PAY_"DA,"" PDI"",0)") ,"^",3)+1, $P(^(0),"^ ",3)=J L - @(GLPAY_"D A,""PDI"", 0)")  ;AEB  6/2/2011  DEV007820
  30419   "RTN","CHM FSR21",103 ,0)
  30420    S @(GLPAY _"DA,""PDI "",J,0)")= $P(X7,"^")
  30421   "RTN","CHM FSR21",104 ,0)
  30422    S @(GLPAY _"DA,""PDI "",""B"",$ P(X7,U),J) ")=""
  30423   "RTN","CHM FSR21",105 ,0)
  30424    S @(GLPAY _"""C"",$P (X7,U),DA, J)")=""
  30425   "RTN","CHM FSR21",106 ,0)
  30426    S FNUM=$S (GLPAY="^C HMPAY(":74 1000.41,GL PAY="^CHNV PAY(":7413 001.41,1:1 )
  30427   "RTN","CHM FSR21",107 ,0)
  30428    S:'$D(@(G LPAY_"DA," "PDI"",J," "PAGE"",0) ")) ^(0)=" ^"_FNUM_"^ 0^0"
  30429   "RTN","CHM FSR21",108 ,0)
  30430    L +@(GLPA Y_"DA,""PD I"",J,""PA GE"",0)")  S J1=$P(^( 0),"^",3)+ 1,$P(^(0), "^",3)=J1  L -@(GLPAY _"DA,""PDI "",J,""PAG E"",0)")   ;AEB 6/2/2 011 DEV007 820
  30431   "RTN","CHM FSR21",109 ,0)
  30432    S @(GLPAY _"DA,""PDI "",J,""PAG E"",J1,0)" )=$P(X7,"^ ",2)
  30433   "RTN","CHM FSR21",110 ,0)
  30434    S @(GLPAY _"DA,""PDI "",J,""PAG E"",""B"", $P(X7,U,2) ,J1)")=""
  30435   "RTN","CHM FSR21",111 ,0)
  30436    S FNUM=$S (GLPAY="^C HMPAY(":74 1000.411,G LPAY="^CHN VPAY(":741 3001.411,1 :1)
  30437   "RTN","CHM FSR21",112 ,0)
  30438    S:'$D(@(G LPAY_"DA," "PDI"",J," "PAGE"",J1 ,""IMAGE"" ,0)")) ^(0 )="^"_FNUM _"^0^0"
  30439   "RTN","CHM FSR21",113 ,0)
  30440    L +@(GLPA Y_"DA,""PD I"",J,""PA GE"",J1,"" IMAGE"",0) ") S J2=$P (^(0),"^", 3)+1,$P(^( 0),"^",3)= J2 L -@(GL PAY_"DA,"" PDI"",J,"" PAGE"",J1, ""IMAGE"", 0)")  ;AEB  6/2/2011  DEV007820
  30441   "RTN","CHM FSR21",114 ,0)
  30442    S @(GLPAY _"DA,""PDI "",J,""PAG E"",J1,""I MAGE"",J2, 0)")=$P(X7 ,"^",3)
  30443   "RTN","CHM FSR21",115 ,0)
  30444    S @(GLPAY _"DA,""PDI "",J,""PAG E"",J1,""I MAGE"",""B "",$P(X7,U ,3),J2)")= ""
  30445   "RTN","CHM FSR21",116 ,0)
  30446   VEN S X5=" "
  30447   "RTN","CHM FSR21",117 ,0)
  30448    S:$D(^UTI LITY("CLAI MS",$J,TY, DFN,BFN,VN ,DOS,PLS," VN")) X5=^ UTILITY("C LAIMS",$J, TY,DFN,BFN ,VN,DOS,PL S,"VN")
  30449   "RTN","CHM FSR21",118 ,0)
  30450    G:X5="" C 1 S PVN=^U TILITY("CL AIMS",$J,T Y,DFN,BFN, VN,DOS,PLS ,"VNP")
  30451   "RTN","CHM FSR21",119 ,0)
  30452    I $P(@(GL PAY_"DA,0) "),U,5)=""  S DR=".05 ///^S X=$P (X5,U,3)"  D ^DIE
  30453   "RTN","CHM FSR21",120 ,0)
  30454    S DR=".06 ///^S X=$P (X5,U,4);. 14///^S X= $P(X5,U,10 );.15///^S  X=$P(X5,U ,11);.16// /^S X=$P(X 5,U,12);.1 7///^S X=$ P(X5,U,13) " D ^DIE
  30455   "RTN","CHM FSR21",121 ,0)
  30456    I $P(@(GL PAY_"DA,0) "),"^",5)= 1 S DR="9. 01///^S X= 1" D ^DIE
  30457   "RTN","CHM FSR21",122 ,0)
  30458    S DR=".23 ///^S X=$P (X5,U,5);. 24///^S X= $P(X5,U,6) " D ^DIE
  30459   "RTN","CHM FSR21",123 ,0)
  30460    S DR="7.0 5///^S X=$ P(X5,U,17) ;7.06///^S  X=$P(X5,U ,7)" D ^DI E
  30461   "RTN","CHM FSR21",124 ,0)
  30462    S DR=".04 ///^S X=$P (PVN,U,2); .18///^S X =$P(PVN,U, 3)" D ^DIE
  30463   "RTN","CHM FSR21",125 ,0)
  30464    I $P(PVN, U,3)'="" I  $D(^CHMIM AGE(CHMFPD I,"P-VEN") ) S ZV=VN  D VSET
  30465   "RTN","CHM FSR21",126 ,0)
  30466   C1 D ASS D  INHOU
  30467   "RTN","CHM FSR21",127 ,0)
  30468    D:$D(^UTI LITY("CLAI MS",$J,TY, DFN,BFN,DO S,PLS,"EOB ")) ^CHMFS R15
  30469   "RTN","CHM FSR21",128 ,0)
  30470    D:$D(^UTI LITY("CLAI MS",$J,TY, DFN,BFN,DO S,PLS,"EOB 1")) ^CHMF SRN8 Q
  30471   "RTN","CHM FSR21",129 ,0)
  30472   CLMS D:'$D (^CHMIMG(C HMFPDI)) ^ CHMFSRT4
  30473   "RTN","CHM FSR21",130 ,0)
  30474    S:'$D(^CH MIMG(CHMFP DI,1,0)) ^ CHMIMG(CHM FPDI,1,0)= "^741000.2 1^0^0"
  30475   "RTN","CHM FSR21",131 ,0)
  30476    L +^CHMIM G(CHMFPDI, 1,0) S J=$ P(^CHMIMG( CHMFPDI,1, 0),"^",3), J=J+1,$P(^ CHMIMG(CHM FPDI,1,0), "^",3)=J L  -^CHMIMG( CHMFPDI,1, 0)  ;AEB 6 /2/2011 DE V007820
  30477   "RTN","CHM FSR21",132 ,0)
  30478    S $P(^CHM IMG(CHMFPD I,1,J,0)," ^",1)=DA Q
  30479   "RTN","CHM FSR21",133 ,0)
  30480   PSVEN S PV N=$P(^UTIL ITY("CLAIM S",$J,TY,D FN,BFN,VN, DOS,PLS,"V NP"),"^",2 ) S DIE=GL PAY ; Unde fined vari able on 7/ 27/05
  30481   "RTN","CHM FSR21",134 ,0)
  30482    S DR=".04 ///^S X=PV N" D ^DIE
  30483   "RTN","CHM FSR21",135 ,0)
  30484    S PVNAM=$ P(^UTILITY ("CLAIMS", $J,TY,DFN, BFN,VN,DOS ,PLS,"VNP" ),"^",4)
  30485   "RTN","CHM FSR21",136 ,0)
  30486    I PVNAM'= "" S:$D(^C HMIMAGE(PD I,"VNPG",P VNAM)) $P( ^CHMPAY(DA ,9),"^",6) =^CHMIMAGE (PDI,"VNPG ",PVNAM)
  30487   "RTN","CHM FSR21",137 ,0)
  30488    I $D(^CHM IMAGE(CHMF PDI,"P-VEN ")) S ZV=" PS" D VSET
  30489   "RTN","CHM FSR21",138 ,0)
  30490    Q
  30491   "RTN","CHM FSR21",139 ,0)
  30492    ;
  30493   "RTN","CHM FSR21",140 ,0)
  30494   VSET Q:$P( @(GLPAY_"D A,0)"),"^" ,4)=""  S  CHVNPT=$P( ^(0),"^",4 )
  30495   "RTN","CHM FSR21",141 ,0)
  30496    S CHPAGE= $P(CHVNPT, "*",2),CHI MAG=$P(CHV NPT,"*",3)
  30497   "RTN","CHM FSR21",142 ,0)
  30498    Q:'$D(^CH MIMAGE(CHM FPDI,1,CHP AGE,2,CHIM AG,"VEN"))
  30499   "RTN","CHM FSR21",143 ,0)
  30500    S PTR=$P( ^("VEN")," ^",14)
  30501   "RTN","CHM FSR21",144 ,0)
  30502    Q:PTR=""   Q:'$D(^CH MIMAGE(CHM FPDI,"P-VE N",PTR,0))
  30503   "RTN","CHM FSR21",145 ,0)
  30504    D NOW^%DT C
  30505   "RTN","CHM FSR21",146 ,0)
  30506    I $D(^CHM IMAGE(CHMF PDI,"VEN-I I",ZV)) S  @(GLPAY_"D A,""VEN-II "")")=^CHM IMAGE(CHMF PDI,"VEN-I I",ZV)
  30507   "RTN","CHM FSR21",147 ,0)
  30508    D NOW^%DT C S @(GLPA Y_"DA,""VE N"",ZV,%,0 )")=^CHMIM AGE(CHMFPD I,"P-VEN", PTR,0)
  30509   "RTN","CHM FSR21",148 ,0)
  30510    Q
  30511   "RTN","CHM FSR21",149 ,0)
  30512    ;
  30513   "RTN","CHM FSR21",150 ,0)
  30514   ASS Q:'$D( @(GLPAY_"D A,0)"))
  30515   "RTN","CHM FSR21",151 ,0)
  30516    I $P(^(0) ,"^",5)=0, '$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN )) S DR="9 .01///^S X =0" D ^DIE  Q
  30517   "RTN","CHM FSR21",152 ,0)
  30518    I $P(@(GL PAY_"DA,0) "),"^",5)= 0 I $D(^UT ILITY("CLA IMS",$J,DF N,BFN,"NOC LM")) S DR ="9.01///^ S X=0" D ^ DIE  Q
  30519   "RTN","CHM FSR21",153 ,0)
  30520    S DR="9.0 1///^S X=1 " D ^DIE Q
  30521   "RTN","CHM FSR21",154 ,0)
  30522   INHOU Q:VN =""  Q:'$D (^CHMVEN(V N,1))  Q:$ P(^(1),"^" ,16)'=1
  30523   "RTN","CHM FSR21",155 ,0)
  30524    Q:'$D(@(G LPAY_"DA,0 )"))
  30525   "RTN","CHM FSR21",156 ,0)
  30526    Q:$P(@(GL PAY_"DA,0) "),"^",5)= 1
  30527   "RTN","CHM FSR21",157 ,0)
  30528    S $P(@(GL PAY_"DA,0) "),"^",5)= 1
  30529   "RTN","CHM FSR21",158 ,0)
  30530    S $P(@(GL PAY_"DA,9) "),"^",1)= 1 Q
  30531   "RTN","CHM FSR21",159 ,0)
  30532   MORE S DIE =GLPAY
  30533   "RTN","CHM FSR21",160 ,0)
  30534   M1 S J=$O( ^UTILITY(" CLAIMS",$J ,"CLFRM",D FN,BFN,J))  Q:'J
  30535   "RTN","CHM FSR21",161 ,0)
  30536    S X0="" S :$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,0)) X0= ^UTILITY(" CLAIMS",$J ,"CLFRM",D FN,BFN,J,0 )
  30537   "RTN","CHM FSR21",162 ,0)
  30538    S X1="" S :$D(^UTILI TY("CLAIMS ",$J,"CLFR M",DFN,BFN ,J,1)) X1= ^UTILITY(" CLAIMS",$J ,"CLFRM",D FN,BFN,J,1 )
  30539   "RTN","CHM FSR21",163 ,0)
  30540    Q:$P(X0," ^",3)="N"
  30541   "RTN","CHM FSR21",164 ,0)
  30542    S DR="10. 06///^S X= $P(X0,U,3) "
  30543   "RTN","CHM FSR21",165 ,0)
  30544    S:$P(X0,U ,9)="Y" DR =DR_";10.0 8///^S X=$ P(X0,U,9)"
  30545   "RTN","CHM FSR21",166 ,0)
  30546    S:$P(X0,U ,11)="Y" D R=DR_";10. 09///^S X= $P(X0,U,11 )"
  30547   "RTN","CHM FSR21",167 ,0)
  30548    S:$P(X0,U ,12)="Y" D R=DR_";10. 1///^S X=$ P(X0,U,12) "
  30549   "RTN","CHM FSR21",168 ,0)
  30550    S:$P(X0,U ,13)="Y" D R=DR_";10. 11///^S X= $P(X0,U,13 )"
  30551   "RTN","CHM FSR21",169 ,0)
  30552    S:$P(X0,U ,10)="Y" D R=DR_";10. 14///^S X= $P(X0,U,10 )"
  30553   "RTN","CHM FSR21",170 ,0)
  30554    S:$P(X0,U ,14)="Y" D R=DR_";10. 12///^S X= $P(X0,U,14 )" D:DR'=" " ^DIE
  30555   "RTN","CHM FSR21",171 ,0)
  30556    G:X1="" M 1
  30557   "RTN","CHM FSR21",172 ,0)
  30558    S DR="24. 01///^S X= $P(X1,U,2) ;24.02///^ S X=$P(X1, U,3);24.03 ///^S X=$P (X1,U,4);2 4.04///^S  X=$P(X1,U, 5)" D ^DIE
  30559   "RTN","CHM FSR21",173 ,0)
  30560    S DR="24. 05///^S X= $P(X1,U,6) ;24.06///^ S X=$P(X1, U,7);24.07 ///^S X=$P (X1,U,8);2 4.08///^S  X=$P(X1,U, 1)" D ^DIE  G M1
  30561   "RTN","CHM FSRT")
  30562   0^58^B2443 4762
  30563   "RTN","CHM FSRT",1,0)
  30564   CHMFSRT ;J LR/DEN;SOR TING IMAGE S TO CLAIM S;09/07/93  2:54 PM
  30565   "RTN","CHM FSRT",2,0)
  30566    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  30567   "RTN","CHM FSRT",3,0)
  30568    ;PT 11575
  30569   "RTN","CHM FSRT",4,0)
  30570    ;CFS CPE0 05-069 Rep opulate ^C HMDIC(7410 02.21 to r edisplay P DI Numbers  in Manual  EDI Re-op en 
  30571   "RTN","CHM FSRT",5,0)
  30572    ; process ing screen .
  30573   "RTN","CHM FSRT",6,0)
  30574    ;BDB CPE0 05-063a Ba ckout dedu ctible and  cat cap f or re-open ed claim
  30575   "RTN","CHM FSRT",7,0)
  30576    ;CFS 01/1 4/2018 CPE 005-034 Mo ved Revers al prompt  from CHMFA DR2 to CHM FSRT
  30577   "RTN","CHM FSRT",8,0)
  30578    ;CFS 01/1 4/2018 CPE 005-035 Fi xed defect  for CSTAT  message.  F3:686 now  going out  in CSTAT  message.
  30579   "RTN","CHM FSRT",9,0)
  30580    ;CFS 01/1 4/2018 CPE 005-041 Fi xed defect  for CSTAT  message.  F0:35 now  going out  in CSTAT m essage.
  30581   "RTN","CHM FSRT",10,0 )
  30582    ;CFS 01/1 4/2018 CPE 005-108 Ap ply a void ed status  to all ass ociated cl aims on a  frequency  code 8.
  30583   "RTN","CHM FSRT",11,0 )
  30584    ;SBB 02/0 8/2018 CPE 005-037 Ad d code for  setting t he reverse d/voided t o ZEOBq, M CCRq, and 
  30585   "RTN","CHM FSRT",12,0 )
  30586    ;                               payment cl aims to EO Bq
  30587   "RTN","CHM FSRT",13,0 )
  30588    ;SBB 02/2 6/2018 CPE 005-036 Cr eated SETV OIDN UNSET VDN for ze ro EOB and  835 creat ion.
  30589   "RTN","CHM FSRT",14,0 )
  30590    ;
  30591   "RTN","CHM FSRT",15,0 )
  30592    N REVERSE  ;CPE005-1 08
  30593   "RTN","CHM FSRT",16,0 )
  30594    G:'$D(^CH MIMAGE(CHM FPDI)) END  D ^CHMFSR 16
  30595   "RTN","CHM FSRT",17,0 )
  30596    G:'$D(^CH MIMAGE(CHM FPDI)) END  K ^UTILIT Y("CLAIMS" ,$J)
  30597   "RTN","CHM FSRT",18,0 )
  30598    I $G(CHMO PDI) D   Q :$G(REVERS E)  ;BDB 1 1/24/2017  CPE005-063 a BACK OUT  THE CAT C AP, DEDUCT  FOR ORIGI NAL PDI IF  CLAIMS NO T REVERSED
  30599   "RTN","CHM FSRT",19,0 )
  30600    . I CHMFP GNM=""!(CH MFIMAG="")  D GETDATA ^CHMFA008
  30601   "RTN","CHM FSRT",20,0 )
  30602    . I CHMFP GNM'="",CH MFIMAG'="" ,$E(+$$TOB ^CHMFADR2( CHMFPDI,CH MFPGNM,CHM FIMAG),3)= 8 D  Q
  30603   "RTN","CHM FSRT",21,0 )
  30604    .. I '$$C MPCLAIM^CH MFADR2(CHM OPDI) Q  ; All claims  must have  a complet ed status.
  30605   "RTN","CHM FSRT",22,0 )
  30606    .. S REVE RSE=$$REV( CHMFPDI,CH MOPDI)
  30607   "RTN","CHM FSRT",23,0 )
  30608    . S DIE=7 41000.2,DA =CHMOPDI,D R=".06///1 2;.22///"_ DT D ^DIE  K DIE
  30609   "RTN","CHM FSRT",24,0 )
  30610    . N IEN
  30611   "RTN","CHM FSRT",25,0 )
  30612    . S IEN=" " F  S IEN =$O(^CHMPA Y("C",CHMO PDI,IEN))  Q:IEN=""   D
  30613   "RTN","CHM FSRT",26,0 )
  30614    .. I $P(^ CHMPAY(IEN ,0),"^",2) '=12 S DIE =741000,DA =IEN,DR=". 02///12" D  ^DIE K DI E D ADJ^CH GRCCD(IEN, "SUB")
  30615   "RTN","CHM FSRT",27,0 )
  30616    D ^CHMFSR T4,^CHMFSR T1,^CHMFSR T2,^CHMFSR T8,^CHMFSR T6,^CHMFSR T7
  30617   "RTN","CHM FSRT",28,0 )
  30618    D ^CHMFSR R1,^CHMFSR TA
  30619   "RTN","CHM FSRT",29,0 )
  30620    I '$D(^CH MPAY("C",C HMFPDI)) D  ^CHMFDOC  G END:$D(C HDOCFL) D  ^CHMG250J
  30621   "RTN","CHM FSRT",30,0 )
  30622    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=8 ,'$D(^CHMP AY("C",CHM FPDI)) D   ;CPE005-06 9
  30623   "RTN","CHM FSRT",31,0 )
  30624    . S $P(^C HMDIC(7410 02.21,DUZ, 0),"^",2)= CHMOPDI
  30625   "RTN","CHM FSRT",32,0 )
  30626    . S $P(^C HMDIC(7410 02.21,DUZ, 0),"^",5)= CHMFPDI
  30627   "RTN","CHM FSRT",33,0 )
  30628   END K AII, DS,HNM,II, J,K,L,M,N, NM,TS,PDI, VN,X,XX,AD ,HM,HN,KK, X1,AC,CPT
  30629   "RTN","CHM FSRT",34,0 )
  30630    K DA,DIC, DIE,DLAYGO ,DR,EM,INP ROCESS,J1, J2,VNM,X0, X1,X2,X3,X 4,X5,X7,I
  30631   "RTN","CHM FSRT",35,0 )
  30632    K IP,IP1, IP2,IP3,IP 4,IP5,JJ,C L,OP,OP1,O P2,PN,RX,D M,DM1,DM2, BN,SN,DOS
  30633   "RTN","CHM FSRT",36,0 )
  30634    K CLM,J3, NN,S1,S2,T I,Y,ZDB,ZD A,X6,MR,P, IA,IM,IO,H DA,AI,SUPP ,CHPDI
  30635   "RTN","CHM FSRT",37,0 )
  30636    K ^UTILIT Y("CLAIMS" ,$J),CHDOC FL
  30637   "RTN","CHM FSRT",38,0 )
  30638    Q
  30639   "RTN","CHM FSRT",39,0 )
  30640   REV(CHMFPD I,CHMOPDI)  ;CFS CPE0 05-108
  30641   "RTN","CHM FSRT",40,0 )
  30642    ;CHMFPDI  = Current  PDI
  30643   "RTN","CHM FSRT",41,0 )
  30644    ;CHMOPDI  = Original  PDI
  30645   "RTN","CHM FSRT",42,0 )
  30646    S CHMFPDI =$G(CHMFPD I),CHMOPDI =$G(CHMOPD I)
  30647   "RTN","CHM FSRT",43,0 )
  30648    Q:'CHMFPD I 0
  30649   "RTN","CHM FSRT",44,0 )
  30650    Q:'CHMOPD I 0
  30651   "RTN","CHM FSRT",45,0 )
  30652    F  D CLEA RB^CHMFADR 2 S DY=14, DX=21 X XY  W "Do you  want to i nitiate a  Reversal?  Y/N:" D  Q :$L(Y)  ;C PE005-034,  CPE005-03 7
  30653   "RTN","CHM FSRT",46,0 )
  30654    . S DX=62 ,$X=DX X X Y D CSBRS^ CHSC2 W:Y' ="" @CHEOL
  30655   "RTN","CHM FSRT",47,0 )
  30656    . I Y'="Y ",Y'="N" S  DY=16,DX= 27 X XY W  "Please en ter 'Y','N '." H 5
  30657   "RTN","CHM FSRT",48,0 )
  30658    S REVRESP =Y
  30659   "RTN","CHM FSRT",49,0 )
  30660    I REVRESP ="Y" D  ;C PE005-035
  30661   "RTN","CHM FSRT",50,0 )
  30662    . S DIE=7 41000.2,DA =CHMOPDI,D R=".06///1 1;.22///"_ DT D ^DIE  K DIE ;BDB  09/19/201 7
  30663   "RTN","CHM FSRT",51,0 )
  30664    . S DIE=7 41000.2,DA =CHMFPDI,D R=".05///" _DT_";.06/ //4" D ^DI E K DIE ;B DB 09/19/2 017
  30665   "RTN","CHM FSRT",52,0 )
  30666    . N ADDQ, IEN
  30667   "RTN","CHM FSRT",53,0 )
  30668    . ;SBB 02 /08/2018 C PE005-037
  30669   "RTN","CHM FSRT",54,0 )
  30670    . S U="^"
  30671   "RTN","CHM FSRT",55,0 )
  30672    . S IEN=" " F  S IEN =$O(^CHMPA Y("C",CHMO PDI,IEN))  Q:IEN=""   D
  30673   "RTN","CHM FSRT",56,0 )
  30674    .. ;moved  down belo w
  30675   "RTN","CHM FSRT",57,0 )
  30676    .. D ADJ^ CHGRCCD(IE N,"SUB") ; BDB 11/22/ 2017 CPE00 5-063a BAC K OUT THE  BENE CALC
  30677   "RTN","CHM FSRT",58,0 )
  30678    .. ;SBB 0 2/08/2018  CPE005-037
  30679   "RTN","CHM FSRT",59,0 )
  30680    .. ;Voide d claim to  ZEOBq
  30681   "RTN","CHM FSRT",60,0 )
  30682    .. S CI=I EN,GLPAY=" ^CHMPAY(", CHMFQUE=1, $P(@(GLPAY _"CI,0)"), U,13)=404
  30683   "RTN","CHM FSRT",61,0 )
  30684    .. ;SBB 0 2/23/2018  CPE005-036
  30685   "RTN","CHM FSRT",62,0 )
  30686    .. ;Setti ng void no de for ZEO B, once th e EOB is p rinted in  CHBPEBSD i t uses VOI D node to  set the
  30687   "RTN","CHM FSRT",63,0 )
  30688    .. ;   va lues back  for 835 to  be balanc ed.
  30689   "RTN","CHM FSRT",64,0 )
  30690    .. D SETV OIDN
  30691   "RTN","CHM FSRT",65,0 )
  30692    .. ; Remo ve from EO B queue if  it exists  already
  30693   "RTN","CHM FSRT",66,0 )
  30694    .. S CL=C I D EOB^CH MFUTL1
  30695   "RTN","CHM FSRT",67,0 )
  30696    .. D QUE^ CHFBC
  30697   "RTN","CHM FSRT",68,0 )
  30698    .. ;Setti ng claim t o MCCR que ue:
  30699   "RTN","CHM FSRT",69,0 )
  30700    .. S CI=I EN,CN=$P(^ CHMPAY(CI, 0),U) I $P (^CHMPAY(C I,0),U,2)= 4 D 
  30701   "RTN","CHM FSRT",70,0 )
  30702    ... S CHM FQUE=19     ;19=REOPE NED CLAIM  FUNDS DUE
  30703   "RTN","CHM FSRT",71,0 )
  30704    ... D QUE ^CHFBC
  30705   "RTN","CHM FSRT",72,0 )
  30706    ... Q 
  30707   "RTN","CHM FSRT",73,0 )
  30708    .. S DIE= 741000,DA= IEN,DR=".0 2///11" D  ^DIE K DIE   ;CPE005- 108
  30709   "RTN","CHM FSRT",74,0 )
  30710    .. Q
  30711   "RTN","CHM FSRT",75,0 )
  30712    . D CRCST AT^CHMFUTL E(CHMFPDI, "","E001b" ,"A") ;Sen d out CSTA T message.
  30713   "RTN","CHM FSRT",76,0 )
  30714    . ;S ADDQ =$$ADD2QUE ^CH835TRG( CHMOPDI) ; HM 09/20/2 017 CPE005 -041
  30715   "RTN","CHM FSRT",77,0 )
  30716    . Q
  30717   "RTN","CHM FSRT",78,0 )
  30718    I REVRESP ="N" D   ; CPE005-041
  30719   "RTN","CHM FSRT",79,0 )
  30720    . S DIE=7 41000.2,DA =CHMFPDI,D R=".06///4 " D ^DIE K  DIE
  30721   "RTN","CHM FSRT",80,0 )
  30722    . D CRCST AT^CHMFUTL E(CHMFPDI, "","E001c" ,"A") ;Sen d out CSTA T message.
  30723   "RTN","CHM FSRT",81,0 )
  30724    Q 1
  30725   "RTN","CHM FSRT",82,0 )
  30726    ;
  30727   "RTN","CHM FSRT",83,0 )
  30728    ;SBB 02/2 3/2018 CPE 005-036
  30729   "RTN","CHM FSRT",84,0 )
  30730   SETVOIDN ;
  30731   "RTN","CHM FSRT",85,0 )
  30732    ;
  30733   "RTN","CHM FSRT",86,0 )
  30734    N IDX1,ID X2,XPROCX
  30735   "RTN","CHM FSRT",87,0 )
  30736    ;SET VOID  under 1 n ode and re move vendo r and bene  payment i nfo from 1  node.
  30737   "RTN","CHM FSRT",88,0 )
  30738    S ^CHMPAY (CI,1,"VOI D")=^CHMPA Y(CI,1)
  30739   "RTN","CHM FSRT",89,0 )
  30740    S $P(^CHM PAY(CI,1), U,14)=""
  30741   "RTN","CHM FSRT",90,0 )
  30742    S $P(^CHM PAY(CI,1), U,15)=""
  30743   "RTN","CHM FSRT",91,0 )
  30744    ;
  30745   "RTN","CHM FSRT",92,0 )
  30746    ;SET VOID  under INP -PROC, OUT -PROC, DEN -PROC, PHA RM, and DM E-SUPPLY n odes
  30747   "RTN","CHM FSRT",93,0 )
  30748    F XPROCX= "INP-PROC" ,"OPT-PROC ","DEN-PRO C","PHARM" ,"DME-SUPP LY" D  
  30749   "RTN","CHM FSRT",94,0 )
  30750    . S IDX1= 0 F  S IDX 1=$O(^CHMP AY(CI,XPRO CX,IDX1))  Q:IDX1=""   D  
  30751   "RTN","CHM FSRT",95,0 )
  30752    . . S IDX 2=0 F  S I DX2=$O(^CH MPAY(CI,XP ROCX,IDX1, 1,IDX2)) Q :IDX2=""   D  
  30753   "RTN","CHM FSRT",96,0 )
  30754    . . . Q:' $D(^CHMPAY (CI,XPROCX ,IDX1,1,ID X2,0))
  30755   "RTN","CHM FSRT",97,0 )
  30756    . . . S ^ CHMPAY(CI, XPROCX,IDX 1,1,IDX2," VOID")=^CH MPAY(CI,XP ROCX,IDX1, 1,IDX2,0)
  30757   "RTN","CHM FSRT",98,0 )
  30758    . . . S $ P(^CHMPAY( CI,XPROCX, IDX1,1,IDX 2,0),U,12) =""
  30759   "RTN","CHM FSRT",99,0 )
  30760    . . . S $ P(^CHMPAY( CI,XPROCX, IDX1,1,IDX 2,0),U,15) =""
  30761   "RTN","CHM FSRT",100, 0)
  30762    . . . S $ P(^CHMPAY( CI,XPROCX, IDX1,1,IDX 2,0),U,16) =""
  30763   "RTN","CHM FSRT",101, 0)
  30764    . . . Q
  30765   "RTN","CHM FSRT",102, 0)
  30766    . . Q
  30767   "RTN","CHM FSRT",103, 0)
  30768    . Q
  30769   "RTN","CHM FSRT",104, 0)
  30770    ;
  30771   "RTN","CHM FSRT",105, 0)
  30772    Q
  30773   "RTN","CHM FSRT",106, 0)
  30774    ;
  30775   "RTN","CHM FSRT",107, 0)
  30776     ;SBB 02/ 23/2018 CP E005-036
  30777   "RTN","CHM FSRT",108, 0)
  30778   UNSETVDN(C I) ;
  30779   "RTN","CHM FSRT",109, 0)
  30780    ;
  30781   "RTN","CHM FSRT",110, 0)
  30782    N IDX1,ID X2,XPROCX
  30783   "RTN","CHM FSRT",111, 0)
  30784    ;SET VOID  under 1 n ode and re move vendo r and bene  payment i nfo from 1  node.
  30785   "RTN","CHM FSRT",112, 0)
  30786    S ^CHMPAY (CI,1)=^CH MPAY(CI,1, "VOID")
  30787   "RTN","CHM FSRT",113, 0)
  30788    K ^CHMPAY (CI,1,"VOI D")
  30789   "RTN","CHM FSRT",114, 0)
  30790    ;
  30791   "RTN","CHM FSRT",115, 0)
  30792    ;SET VOID  under INP -PROC, OUT -PROC, DEN -PROC, PHA RM, and DM E-SUPPLY n odes
  30793   "RTN","CHM FSRT",116, 0)
  30794    F XPROCX= "INP-PROC" ,"OPT-PROC ","DEN-PRO C","PHARM" ,"DME-SUPP LY" D  
  30795   "RTN","CHM FSRT",117, 0)
  30796    . S IDX1= 0 F  S IDX 1=$O(^CHMP AY(CI,XPRO CX,IDX1))  Q:IDX1=""   D  
  30797   "RTN","CHM FSRT",118, 0)
  30798    . . S IDX 2=0 F  S I DX2=$O(^CH MPAY(CI,XP ROCX,IDX1, 1,IDX2)) Q :IDX2=""   D  
  30799   "RTN","CHM FSRT",119, 0)
  30800    . . . Q:' $D(^CHMPAY (CI,XPROCX ,IDX1,1,ID X2,0))
  30801   "RTN","CHM FSRT",120, 0)
  30802    . . . S ^ CHMPAY(CI, XPROCX,IDX 1,1,IDX2,0 )=^CHMPAY( CI,XPROCX, IDX1,1,IDX 2,"VOID")
  30803   "RTN","CHM FSRT",121, 0)
  30804    . . . K ^ CHMPAY(CI, XPROCX,IDX 1,1,IDX2," VOID")
  30805   "RTN","CHM FSRT",122, 0)
  30806    . . . Q
  30807   "RTN","CHM FSRT",123, 0)
  30808    . . Q
  30809   "RTN","CHM FSRT",124, 0)
  30810    . Q
  30811   "RTN","CHM FSRT",125, 0)
  30812    ;
  30813   "RTN","CHM FSRT",126, 0)
  30814    Q
  30815   "RTN","CHM FSRT",127, 0)
  30816    ;
  30817   "RTN","CHM FUTLE")
  30818   0^89^B2350 5215
  30819   "RTN","CHM FUTLE",1,0 )
  30820   CHMFUTLE ; LEG/DEN;ED I X12 ReOp en Utility  Routine;1 0/16/17  0 9:38 AM
  30821   "RTN","CHM FUTLE",2,0 )
  30822    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  30823   "RTN","CHM FUTLE",3,0 )
  30824    ;LEG 10/1 6/2017 CPE 005-001 ad ded "A-ALL " & "A-FIR ST" XREF p rocessing
  30825   "RTN","CHM FUTLE",4,0 )
  30826    ;                in  A5^CHMFADR V   and    in PR2^CHM XF001
  30827   "RTN","CHM FUTLE",5,0 )
  30828    ;CFS 01/0 2/2018 CPE 005-033, 0 35, 038, 0 41, 042 an d 043
  30829   "RTN","CHM FUTLE",6,0 )
  30830    ;                Add ed line ta gs CRCSTAT ,and GETER R for CSTA T processi ng.
  30831   "RTN","CHM FUTLE",7,0 )
  30832    ;CFS 02/0 4/2019 CPE 005-042 an d Defect 9 13649 Chec k the exis tence Orig inal Claim .
  30833   "RTN","CHM FUTLE",8,0 )
  30834    ;                If  the claim  does not e xist, don' t set up ^ CHMIMG(A-A LL or ^CHM IMG("A-FIR ST"
  30835   "RTN","CHM FUTLE",9,0 )
  30836   PDIFIRST(P DI,FIRST,L AST,PREV,N EXT,CLMCMP LT)  ; get s the firs t original  and last  PDIs and s ets xrefs  all in bet ween
  30837   "RTN","CHM FUTLE",10, 0)
  30838    N I,NEXTP DI,PREVPDI ,PREVPDI
  30839   "RTN","CHM FUTLE",11, 0)
  30840    S FIRST=$ O(^CHMIMG( "A-FIRST", PDI,""))
  30841   "RTN","CHM FUTLE",12, 0)
  30842    ;gathers  all EDI Re Open PDI r elated XRE Fs
  30843   "RTN","CHM FUTLE",13, 0)
  30844    I FIRST M  PDI=^CHMI MG("A-ALL" ,FIRST)
  30845   "RTN","CHM FUTLE",14, 0)
  30846    S PDINUM= PDI,PDI(PD I)="" ; ge ts all pre -PDI links
  30847   "RTN","CHM FUTLE",15, 0)
  30848    F  S REOP REC=$G(^CH MIMG(PDINU M,"E-REOPE N")) Q:'$L ($P(REOPRE C,"^"))  S  PDINUM=$P (REOPREC," ^"),PDI(PD INUM)=""
  30849   "RTN","CHM FUTLE",16, 0)
  30850    Q:PDINUM= ""  ;CFS 0 2/04/2019  CPE005-042
  30851   "RTN","CHM FUTLE",17, 0)
  30852    Q:'$D(^CH MPAY("C",P DINUM))  ; CFS 02/04/ 2019 CPE00 5-042
  30853   "RTN","CHM FUTLE",18, 0)
  30854    S PDINUM= PDI ; gets  all post- PDI links
  30855   "RTN","CHM FUTLE",19, 0)
  30856    F  S REOP REC=$G(^CH MIMG(PDINU M,"E-REOPE N")) Q:'$L ($P(REOPRE C,"^",2))   S PDINUM= $P(REOPREC ,"^",2),PD I(PDINUM)= ""
  30857   "RTN","CHM FUTLE",20, 0)
  30858    S FIRST=$ O(PDI(0)), LAST=$O(PD I(""),-1), PREV=$O(PD I(PDI),-1) ,NEXT=$O(P DI(PDI))
  30859   "RTN","CHM FUTLE",21, 0)
  30860    S CLMCMPL T=$$CMPCLA IM^CHMFADR 2(PDI)
  30861   "RTN","CHM FUTLE",22, 0)
  30862    ;
  30863   "RTN","CHM FUTLE",23, 0)
  30864    ;establis hes and se ts all ReO pen XREFs  for all ep isodes con taining th e given ne w PDI
  30865   "RTN","CHM FUTLE",24, 0)
  30866   S  ;
  30867   "RTN","CHM FUTLE",25, 0)
  30868    S PDINUM= 0
  30869   "RTN","CHM FUTLE",26, 0)
  30870    F I=0:1 S  PDINUM=$O (PDI(PDINU M)) Q:PDIN UM=""  D   ;
  30871   "RTN","CHM FUTLE",27, 0)
  30872    . I '$D(^ CHMIMG("A- ALL",FIRST ,PDINUM))  S ^CHMIMG( "A-ALL",FI RST,PDINUM )="" ;U 0  W "..A-",F IRST,"-",P DINUM
  30873   "RTN","CHM FUTLE",28, 0)
  30874    . I '$D(^ CHMIMG("A- FIRST",PDI NUM,FIRST) ) S ^CHMIM G("A-FIRST ",PDINUM,F IRST)="" ; U 0 W "..F -",PDINUM, "-",FIRST
  30875   "RTN","CHM FUTLE",29, 0)
  30876    S ^CHMIMG ("A-ALL",F IRST,0)=I
  30877   "RTN","CHM FUTLE",30, 0)
  30878    Q
  30879   "RTN","CHM FUTLE",31, 0)
  30880   PDIXREFS   ;resets al l PDI E-RE OPEN RELAT ED XREFS
  30881   "RTN","CHM FUTLE",32, 0)
  30882    N I,PDI
  30883   "RTN","CHM FUTLE",33, 0)
  30884    S PDI=202 0999999999 99
  30885   "RTN","CHM FUTLE",34, 0)
  30886    F I=1:1 S  PDI=$O(^C HMIMG(PDI) ,-1) Q:PDI =""  Q:PDI <201700000 000000  W: I#100000=0  "**",I,"* *" I $D(^C HMIMG(PDI, "E-REOPEN" )) D PDIFI RST(PDI)
  30887   "RTN","CHM FUTLE",35, 0)
  30888    Q
  30889   "RTN","CHM FUTLE",36, 0)
  30890   PDICNTS  ; resets/cal culates co unt of all  episodes
  30891   "RTN","CHM FUTLE",37, 0)
  30892    N I,FIRST PDI,PDICNT ,NEXTPDI
  30893   "RTN","CHM FUTLE",38, 0)
  30894    S FIRSTPD I=0
  30895   "RTN","CHM FUTLE",39, 0)
  30896    F I=1:1 S  FIRSTPDI= $O(^CHMIMG ("A-ALL",F IRSTPDI)), (PDICNT,NE XTPDI)=0 Q :'$L(FIRST PDI)  D  I  I#1000=0  W "..",I ;
  30897   "RTN","CHM FUTLE",40, 0)
  30898    . F  S NE XTPDI=$O(^ CHMIMG("A- ALL",FIRST PDI,NEXTPD I)) Q:NEXT PDI=""  S  PDICNT=PDI CNT+1
  30899   "RTN","CHM FUTLE",41, 0)
  30900    . S ^CHMI MG("A-ALL" ,FIRSTPDI, 0)=PDICNT
  30901   "RTN","CHM FUTLE",42, 0)
  30902    W "..",I
  30903   "RTN","CHM FUTLE",43, 0)
  30904    Q
  30905   "RTN","CHM FUTLE",44, 0)
  30906   CHKDUPS(PD I)  ; chec ks if more  than one  PDI points  back to t he same Or iginal PDI
  30907   "RTN","CHM FUTLE",45, 0)
  30908    N ALL
  30909   "RTN","CHM FUTLE",46, 0)
  30910    S ALL=0,P REVPDI=$G( PDI)
  30911   "RTN","CHM FUTLE",47, 0)
  30912    I 'PREVPD I S PREVPD I=20209999 9999999,AL L=1
  30913   "RTN","CHM FUTLE",48, 0)
  30914    F I=1:1 S  PREVPDI=$ O(^CHMIMG( PREVPDI),- 1) Q:'PREV PDI  W:I#1 0000=0 ".. ",I I $D(^ CHMIMG(PRE VPDI,"E-RE OPEN")) D   ;
  30915   "RTN","CHM FUTLE",49, 0)
  30916    . S REORE C=^CHMIMG( PREVPDI,"E -REOPEN"), PREV=$P(RE OREC,"^"), NEXT=$P(RE OREC,"^",2 )
  30917   "RTN","CHM FUTLE",50, 0)
  30918    . S W=0 I  PREV S:$D (^UTILITY( $J,"CHKDUP S","PREV", PREV)) W=1  S ^UTILIT Y($J,"CHKD UPS","PREV ",PREV,PRE VPDI)="" I  W W !! ZW  ^UTILITY( $J,"CHKDUP S","PREV", PREV) R X
  30919   "RTN","CHM FUTLE",51, 0)
  30920    . S W=0 I  NEXT S:$D (^UTILITY( $J,"CHKDUP S","NEXT", NEXT)) W=1  S ^UTILIT Y($J,"CHKD UPS","NEXT ",NEXT,PRE VPDI)="" I  W W !! ZW  ^UTILITY( $J,"CHKDUP S","NEXT", NEXT) R X
  30921   "RTN","CHM FUTLE",52, 0)
  30922    Q
  30923   "RTN","CHM FUTLE",53, 0)
  30924   QUECLN  ;c leans out  Queues for  PDIs that  have same  FIRST and  CURRENT P DIs
  30925   "RTN","CHM FUTLE",54, 0)
  30926    F QUE="OC RR-READY", "SBOCRR-RE ADY" D  ;
  30927   "RTN","CHM FUTLE",55, 0)
  30928    . S PDI=" "
  30929   "RTN","CHM FUTLE",56, 0)
  30930    . F  S PD I=$O(^CHMI MG(QUE,PDI )) Q:PDI=" "  D PDIFI RST^CHMFUT LE(PDI,.FI RST,.LAST)  D  Q:KCQ= "Q"
  30931   "RTN","CHM FUTLE",57, 0)
  30932    . . W !!, QUE,?15,"   PDI: ",PD I,!?15,"FI RST: ",FIR ST,!?15,"  LAST: ",LA ST
  30933   "RTN","CHM FUTLE",58, 0)
  30934    . . R !?5 ,"...(K)il l, (C)onti nue OR (Q) uit <C>",K CQ
  30935   "RTN","CHM FUTLE",59, 0)
  30936    . . I KCQ ="K" K ^CH MIMG(QUE,P DI) W "... Killed"
  30937   "RTN","CHM FUTLE",60, 0)
  30938    Q
  30939   "RTN","CHM FUTLE",61, 0)
  30940   QUESTAT  ; displays i nfo regard ing que en try PDIs
  30941   "RTN","CHM FUTLE",62, 0)
  30942    N PDI,AUE
  30943   "RTN","CHM FUTLE",63, 0)
  30944    F QUE="OC RR-READY", "SBOCRR-RE ADY" D  ;
  30945   "RTN","CHM FUTLE",64, 0)
  30946    . S PDI=" "
  30947   "RTN","CHM FUTLE",65, 0)
  30948    . W !!,QU E,?15
  30949   "RTN","CHM FUTLE",66, 0)
  30950    . F  S PD I=$O(^CHMI MG(QUE,PDI )) Q:PDI=" "  D PDIFI RST^CHMFUT LE(PDI,.FI RST,.LAST, .PREV,.NEX T,.CLMCMPL T) D  ;
  30951   "RTN","CHM FUTLE",67, 0)
  30952    . . I 'CL MCMPLT S N EWIEN=$O(^ CHMPAY("C" ,PREV,""))  S $P(^CHM PAY(NEWIEN ,0),"^",2) =4 ; sets  the comple te flag fo r testing
  30953   "RTN","CHM FUTLE",68, 0)
  30954    . . W !?1 5,"PDI: ", PDI,!?20," FIRST: ",F IRST,?45," LAST: ",LA ST
  30955   "RTN","CHM FUTLE",69, 0)
  30956    . . W !?2 0," PREV:  ",PREV,?45 ,"NEXT: ", NEXT
  30957   "RTN","CHM FUTLE",70, 0)
  30958    . . W !?2 0,"CLAIM C OMPLETE ST ATUS: ",CL MCMPLT
  30959   "RTN","CHM FUTLE",71, 0)
  30960    Q
  30961   "RTN","CHM FUTLE",72, 0)
  30962    ;
  30963   "RTN","CHM FUTLE",73, 0)
  30964   CRCSTAT(PD I,CHXREC,E RRCODE,TYP ERUN)  ;CP E005-033,  035, 038,  041, 042 a nd 043. 
  30965   "RTN","CHM FUTLE",74, 0)
  30966    ;Creates  CSTAT mess age
  30967   "RTN","CHM FUTLE",75, 0)
  30968    ;PDI       = Origina l or Curre nt PDI
  30969   "RTN","CHM FUTLE",76, 0)
  30970    ;CHXREC     = The re cord that  is being l ooked at f rom X12 pr ocessing ( ie. "C000" ,"C005,"E0 00","E015" )
  30971   "RTN","CHM FUTLE",77, 0)
  30972    ;            See the  837 Flat  File Layou t. Default  is the "E 000" recor d if not c alled from  X12 proce ssing.
  30973   "RTN","CHM FUTLE",78, 0)
  30974    ;ERRCODE   = for CST AT in form at (i.e. " F035" )
  30975   "RTN","CHM FUTLE",79, 0)
  30976    ;TYPERUN   = "A" - A cknowledge ment (Gets  created i mmediately )
  30977   "RTN","CHM FUTLE",80, 0)
  30978    ;            "P" - P ending (Go es out in  a batch ca lled by Ta skMan)
  30979   "RTN","CHM FUTLE",81, 0)
  30980    ;            "F" - F inal (Goes  out in a  batch call ed by Task Man)
  30981   "RTN","CHM FUTLE",82, 0)
  30982    ;CLAIMIEN  = The IEN  of the Or iginal PDI  claim (^C HMPAY(IEN) ); Needed  for TYPERU N "P".
  30983   "RTN","CHM FUTLE",83, 0)
  30984    N ERRIEN, PDIXREF,CH EI,ZZ,CHRJ RSN,CHGLBL ,CHFN,CHMX I,AXREF,AX REF6
  30985   "RTN","CHM FUTLE",84, 0)
  30986    S PDI=$G( PDI),CHXRE C=$G(CHXRE C),ERRCODE =$G(ERRCOD E),TYPERUN =$G(TYPERU N)
  30987   "RTN","CHM FUTLE",85, 0)
  30988    Q:('$L(PD I)!'$L(ERR CODE))
  30989   "RTN","CHM FUTLE",86, 0)
  30990    I CHXREC= "" S CHXRE C="E000"
  30991   "RTN","CHM FUTLE",87, 0)
  30992    S ERRIEN= $$GETERR(E RRCODE)
  30993   "RTN","CHM FUTLE",88, 0)
  30994    S PDIXREF =$Q(^CHMXC LE("PDI",P DI))
  30995   "RTN","CHM FUTLE",89, 0)
  30996    S CHEI=$T R($P($P(PD IXREF,"*", 2,99),"*", 3),""")"," ")
  30997   "RTN","CHM FUTLE",90, 0)
  30998    S ZZ=9999 9,ZZ=$O(^C HMXCLE(CHE I,101,ZZ), -1) S:'ZZ  ZZ=0
  30999   "RTN","CHM FUTLE",91, 0)
  31000    S CHRJRSN ="",CHIL=" CHEI",CHGL BL="^CHMXC LE(",CHFN= 741210.121 01
  31001   "RTN","CHM FUTLE",92, 0)
  31002    S CHRCERR (CHXREC,ER RIEN)=""
  31003   "RTN","CHM FUTLE",93, 0)
  31004    D C^CHMXP 003 K CHRC ERR
  31005   "RTN","CHM FUTLE",94, 0)
  31006    S CHMXI=$ P(PDIXREF, ",",4)
  31007   "RTN","CHM FUTLE",95, 0)
  31008    S AXREF=$ Q(^CHMXCLE ("A",CHMXI ))
  31009   "RTN","CHM FUTLE",96, 0)
  31010    I $P(AXRE F,",",3)=2  S AXREF6= AXREF,$P(A XREF6,",", 3)=6,@(AXR EF6)="" K  @(AXREF)
  31011   "RTN","CHM FUTLE",97, 0)
  31012    I TYPERUN ="A" D EPA CK^CHMXWB2 1(CHMXI)
  31013   "RTN","CHM FUTLE",98, 0)
  31014    Q
  31015   "RTN","CHM FUTLE",99, 0)
  31016   GETERR(COD E) ;Get th e IEN out  of Error C ode File 7 41201.32
  31017   "RTN","CHM FUTLE",100 ,0)
  31018    ; CODE =  Error code  from File  741201.32  (ie. "F03 5")
  31019   "RTN","CHM FUTLE",101 ,0)
  31020    N IEN
  31021   "RTN","CHM FUTLE",102 ,0)
  31022    S CODE=$G (CODE)
  31023   "RTN","CHM FUTLE",103 ,0)
  31024    I CODE=""  Q 0
  31025   "RTN","CHM FUTLE",104 ,0)
  31026    S IEN=""
  31027   "RTN","CHM FUTLE",105 ,0)
  31028    S IEN=$O( ^CHMXDIC(7 41201.32," B",CODE,IE N))
  31029   "RTN","CHM FUTLE",106 ,0)
  31030    I IEN=""  Q 0
  31031   "RTN","CHM FUTLE",107 ,0)
  31032    I '$D(^CH MXDIC(7412 01.32,IEN) ) Q 0
  31033   "RTN","CHM FUTLE",108 ,0)
  31034    Q IEN
  31035   "RTN","CHM FUTLE",109 ,0)
  31036    ;
  31037   "RTN","CHM GA008")
  31038   0^59^B4747 313
  31039   "RTN","CHM GA008",1,0 )
  31040   CHMGA008 ; PEJ/DEN;    (V1,1,2)  SELECT VEN D BY CLM N UM;03/26/9 3  11:13 A M
  31041   "RTN","CHM GA008",2,0 )
  31042    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  31043   "RTN","CHM GA008",3,0 )
  31044    ;^UTILITY ("VENQ",$J ,CT)DISPLA Y     CHH= LAST CT DI SPLAYED
  31045   "RTN","CHM GA008",4,0 )
  31046    ;ARRAY ^U TILITY("VE NQ",$J,CT) =PC1_"^"_P C2_"^"_PC3 _"^"_PC4_" ^"_PC5_"^" _PC6
  31047   "RTN","CHM GA008",5,0 )
  31048    ;PC1 = CT       PC2  = VEN NAME       PC3  = DATE/TIM E PUT IN Q UEUE
  31049   "RTN","CHM GA008",6,0 )
  31050    ;PC4 = CL AIM NUMBER     PC5 =  STATUS
  31051   "RTN","CHM GA008",7,0 )
  31052    ;PC6 = IN T NUMBER I N VENDORIZ ATION QUEU E FILE
  31053   "RTN","CHM GA008",8,0 )
  31054    ;PC7 = 1  IF CAME FR OM PROBLEM  SUPPORT ( PRIORITY)
  31055   "RTN","CHM GA008",9,0 )
  31056   MHGTTID ;G ET SPECIFI C CLAIM NU MBER
  31057   "RTN","CHM GA008",10, 0)
  31058    S U="^"
  31059   "RTN","CHM GA008",11, 0)
  31060   MGH1 F DY= 5:1:20 D B LLINE
  31061   "RTN","CHM GA008",12, 0)
  31062    S DY=14,D X=1 X XY W  "ENTER CL AIM NUMBER  "
  31063   "RTN","CHM GA008",13, 0)
  31064    S DY=14,D X=14,FL=9  D SBRS
  31065   "RTN","CHM GA008",14, 0)
  31066    I Y="" Q   
  31067   "RTN","CHM GA008",15, 0)
  31068    S CLAIM=Y
  31069   "RTN","CHM GA008",16, 0)
  31070    S CLMPTR= 0
  31071   "RTN","CHM GA008",17, 0)
  31072    S CLMPTR= $O(^CHMPAY ("B",CLAIM ,CLMPTR))
  31073   "RTN","CHM GA008",18, 0)
  31074    I '$D(CLM PTR) W !," CLAIM NOT  IN CLAIM F ILE" H 2 Q
  31075   "RTN","CHM GA008",19, 0)
  31076    I CLMPTR= "" W !,"CL AIM NOT IN  CLAIM FIL E" H 2 Q
  31077   "RTN","CHM GA008",20, 0)
  31078    I '$D(^CH MQVN("G",C LMPTR)) W  !,"CLAIM N OT IN VEND OR QUEUE"  H 2 Q
  31079   "RTN","CHM GA008",21, 0)
  31080    S V1HPTR= 0,V1HPTR=$ O(^CHMQVN( "G",CLMPTR ,V1HPTR))
  31081   "RTN","CHM GA008",22, 0)
  31082    .;
  31083   "RTN","CHM GA008",23, 0)
  31084    .ZA ^CHMQ VN(V1HPTR, 0):1 I $T= 0 W "SELEC TION CURRE NTLY LOCKE D" H 2 S V 1HPTR="" G  MGH1
  31085   "RTN","CHM GA008",24, 0)
  31086    .;
  31087   "RTN","CHM GA008",25, 0)
  31088    S V1TID=$ P(^CHMQVN( V1HPTR,1), U,2)
  31089   "RTN","CHM GA008",26, 0)
  31090    I (($D(V1 TID))&(V1T ID'="")) S  V1VPTR=0, V1VPTR=$O( ^CHMVEN("D ",V1TID,V1 VPTR))
  31091   "RTN","CHM GA008",27, 0)
  31092    E  S V1VP TR=""
  31093   "RTN","CHM GA008",28, 0)
  31094    D GETIMAG  
  31095   "RTN","CHM GA008",29, 0)
  31096    Q
  31097   "RTN","CHM GA008",30, 0)
  31098    ;
  31099   "RTN","CHM GA008",31, 0)
  31100   SBRS R Y:$ S($D(DTIME ):DTIME,1: 300)
  31101   "RTN","CHM GA008",32, 0)
  31102    I '$T W * 7 R Y:5 G  SBRS:Y="."  S:'$T Y=I OZFO
  31103   "RTN","CHM GA008",33, 0)
  31104   SBRS1 K DF OUT,DUOUT, DQOUT S:'$ D(IOZFO) I OZFO="^^"  S:'$D(IOZB K) IOZBK=" ^"
  31105   "RTN","CHM GA008",34, 0)
  31106    I IOZFO=Y  W:$D(IOZF ) @IOZF S  (DFOUT,Y)= "" Q
  31107   "RTN","CHM GA008",35, 0)
  31108    S:Y=IOZBK  (DUOUT,Y) ="" S:Y?1" ?".E!(Y["^ ") (DQOUT, Y)=""
  31109   "RTN","CHM GA008",36, 0)
  31110    Q
  31111   "RTN","CHM GA008",37, 0)
  31112    ;
  31113   "RTN","CHM GA008",38, 0)
  31114   GETIMAG ;  THE FOLLOW ING LINES  RETRIEVE T HE IMAGE * CR*
  31115   "RTN","CHM GA008",39, 0)
  31116    D RET^CHM MT2 Q:'$D( CHSS)  Q:C HSS=""
  31117   "RTN","CHM GA008",40, 0)
  31118    S CHPDIJ= 0,CHDOCID= "",CHMIMFL =1,CHIMMVE =1
  31119   "RTN","CHM GA008",41, 0)
  31120    F I=1:1 Q :'$D(CHCLM )  Q:CHCLM =""  S CHP DIJ=$O(^CH MPAY(CHCLM ,"PDI",CHP DIJ)) Q:'C HPDIJ  S C HPDI=$P(^( CHPDIJ,0), "^",1) S:$ D(^CHMIMG( CHPDI,"DOC ")) CHDOCI D=$P(^("DO C"),"^",1)  D ENSET^C HMMW1
  31121   "RTN","CHM GA008",42, 0)
  31122    K CHIMMVE  Q
  31123   "RTN","CHM GA008",43, 0)
  31124    ;
  31125   "RTN","CHM GA008",44, 0)
  31126   BLLINE S D X=1 X XY S  LN="" S $ P(LN," ",8 1)="" W LN  Q
  31127   "RTN","CHM IS011")
  31128   0^75^B4421 6186
  31129   "RTN","CHM IS011",1,0 )
  31130   CHMIS011 ; JEA/DEN;CH AMPA SYSTE M STATUS C ALCULATION ;12/16/97   4:12 PM
  31131   "RTN","CHM IS011",2,0 )
  31132    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  31133   "RTN","CHM IS011",3,0 )
  31134    ;;Calls ^ CHMIS012,  ^CHMIS013,  ^CHMIS041
  31135   "RTN","CHM IS011",4,0 )
  31136    ;;Called  by ^CHMIS0 11, ^CHMIS 012, ^CHMI S013, ^CHM ISA11
  31137   "RTN","CHM IS011",5,0 )
  31138    ;;
  31139   "RTN","CHM IS011",6,0 )
  31140    ;;CPTS #1 0589* BY D TP (26-JUL Y-96)
  31141   "RTN","CHM IS011",7,0 )
  31142    ;;CPTS #1 0787* BY D TP (2-AUG- 96)
  31143   "RTN","CHM IS011",8,0 )
  31144    ;;CPTS #1 3212 BY MJ D (8-DEC-9 7)
  31145   "RTN","CHM IS011",9,0 )
  31146    ;;JSG2 10 /14/2017 -  CPE005-02 3 Add in E DI-RO info rmation
  31147   "RTN","CHM IS011",10, 0)
  31148    D ZSET
  31149   "RTN","CHM IS011",11, 0)
  31150   TOP D NOW^ %DTC S TM= +$E(%,1,10 ),CHMI=0,T MPDT=% D C ALEND1
  31151   "RTN","CHM IS011",12, 0)
  31152    S OT="",O T=$O(^CHMS TAT(OT),-1 )
  31153   "RTN","CHM IS011",13, 0)
  31154   A1 S CHCOU NT=1 S CHM I=$O(^CHMD IC(741002. 17,1,101,C HMI)) G EN D:'CHMI,A1 :'$D(^(CHM I,0))
  31155   "RTN","CHM IS011",14, 0)
  31156    S ZTRTN=" EN1^CHMIS0 11",ZTDESC ="STATUS D ISP UPDATE  FOR "_$P( ^(0),"^",1 )
  31157   "RTN","CHM IS011",15, 0)
  31158    S ZTSAVE( "TM")=TM,Z TSAVE("OT" )=OT,ZTSAV E("CHMI")= CHMI,ZTDTH =$H,ZTIO=" "
  31159   "RTN","CHM IS011",16, 0)
  31160    S ZTSAVE( "CHCOUNT") =""
  31161   "RTN","CHM IS011",17, 0)
  31162    D ^%ZTLOA D
  31163   "RTN","CHM IS011",18, 0)
  31164    S ^CHMZHO LD("CHV_SC REEN",CHMI )=TM_"^"_O T_"^"_TMPD T
  31165   "RTN","CHM IS011",19, 0)
  31166    G A1
  31167   "RTN","CHM IS011",20, 0)
  31168    ;
  31169   "RTN","CHM IS011",21, 0)
  31170   ENPAY ; EN TRY POINT  FOR CLAIMS  COUNT ONL Y
  31171   "RTN","CHM IS011",22, 0)
  31172    ;
  31173   "RTN","CHM IS011",23, 0)
  31174    D ZSET
  31175   "RTN","CHM IS011",24, 0)
  31176    D NOW^%DT C S TM=+$E (%,1,10),C HMI=0 D CA LEND1
  31177   "RTN","CHM IS011",25, 0)
  31178    S OT="",O T=$O(^CHMS TAT(OT),-1 )
  31179   "RTN","CHM IS011",26, 0)
  31180    S CHMI=$O (^CHMDIC(7 41002.17,1 ,101,"B"," CHMPAY(",0 )) Q:'CHMI
  31181   "RTN","CHM IS011",27, 0)
  31182    Q:'$D(^CH MDIC(74100 2.17,1,101 ,CHMI,0))
  31183   "RTN","CHM IS011",28, 0)
  31184    S ZTRTN=" EN1^CHMIS0 11",ZTDESC ="STATUS D ISP UPDATE  FOR "_$P( ^(0),"^",1 )
  31185   "RTN","CHM IS011",29, 0)
  31186    S ZTSAVE( "TM")=TM,Z TSAVE("OT" )=OT,ZTSAV E("CHMI")= CHMI,UQDT= $H,ZTIO=""
  31187   "RTN","CHM IS011",30, 0)
  31188    D ^%ZTLOA D Q
  31189   "RTN","CHM IS011",31, 0)
  31190    ;
  31191   "RTN","CHM IS011",32, 0)
  31192   EN1 ; QUEU ED ENTRY P OINT
  31193   "RTN","CHM IS011",33, 0)
  31194    ;
  31195   "RTN","CHM IS011",34, 0)
  31196    ;D ZSET G  END:'$D(Z TSK),END:' $D(^%ZTSK( ZTSK,0))
  31197   "RTN","CHM IS011",35, 0)
  31198    G END:'$D (TM) G END :'$D(OT) G  END:'$D(C HMI) S I=C HMI D CALE ND1
  31199   "RTN","CHM IS011",36, 0)
  31200    S PARAM=^ CHMDIC(741 002.17,1,1 01,I,0)
  31201   "RTN","CHM IS011",37, 0)
  31202    S FI=$P(P ARAM,"^"), Z="",$P(Z, "^",9)=$P( PARAM,"^", 2),P=$P(PA RAM,"^",3)
  31203   "RTN","CHM IS011",38, 0)
  31204    S (CHY,Y) =$P(PARAM, "^",4) K C HFG   ;SKD , 7-31-05  FR S Y=$P. ..
  31205   "RTN","CHM IS011",39, 0)
  31206    I FI="CHM BAR(" S (P DI,IN)=0,( IND,CHFG)= "",CN=0 D  SB5^CHMIS0 12 G END
  31207   "RTN","CHM IS011",40, 0)
  31208    I FI="CHM PAY(" S (P DI,IN)=0,( IND,CHFG)= "" D  G EN D
  31209   "RTN","CHM IS011",41, 0)
  31210    .I $D(^CH MPAY(0)) D  CNSET^CHM IS041 X ^% ZOSF("UCI" ) S:$P(Y," ,",1)'="HA C" CN=0 S  Y=CHY D SB 2^CHMIS012  Q   ;SKD,  7-31-05 F R S:$P($ZU (0),",",1) '="HAC"
  31211   "RTN","CHM IS011",42, 0)
  31212   IMG ;I FI= "IMAGE(" S  PDI=95270 00000000,R IN=0,MIN=0 ,SCIN=0,PU IN=0,RZ="" ,MZ="",SZ= "",PZ="",I ND="" S:$P ($ZU(0),", ",1)'="HAC " PDI=0 D  SB4^CHMIS0 12 G END
  31213   "RTN","CHM IS011",43, 0)
  31214    ;
  31215   "RTN","CHM IS011",44, 0)
  31216    ;
  31217   "RTN","CHM IS011",45, 0)
  31218    ;
  31219   "RTN","CHM IS011",46, 0)
  31220    I FI="IMA GE(" S PDI =0,RIN=0,M IN=0,SCIN= 0,PUIN=0,I ND="" D  D  SB8^CHMIS 012 G END
  31221   "RTN","CHM IS011",47, 0)
  31222    .D NOW^%D TC S %=$P( %,".",1)
  31223   "RTN","CHM IS011",48, 0)
  31224    .S X1=%,X 2=-1 D C^% DTC S I=X
  31225   "RTN","CHM IS011",49, 0)
  31226    .S I=$O(^ CHMSTAT(I) ,-1)
  31227   "RTN","CHM IS011",50, 0)
  31228    .S RZ=""  I I I $D(^ CHMSTAT(I, "IMAGE("))  S RZ=^CHM STAT(I,"IM AGE(") 
  31229   "RTN","CHM IS011",51, 0)
  31230    .S MZ=""  I I I $D(^ CHMSTAT(I, "MANUAL(") ) S MZ=^CH MSTAT(I,"M ANUAL(")
  31231   "RTN","CHM IS011",52, 0)
  31232    .S SZ=""  I I I $D(^ CHMSTAT(I, "SCAN")) S  SZ=^CHMST AT(I,"SCAN ")
  31233   "RTN","CHM IS011",53, 0)
  31234    .S PZ=""  I I I $D(^ CHMSTAT(I, "WAND")) S  PZ=^CHMST AT(I,"WAND ")
  31235   "RTN","CHM IS011",54, 0)
  31236    .F X="RZ" ,"MZ","SZ" ,"PZ" F Y= 1:1:4 S $P (@X,"^",Y) =""
  31237   "RTN","CHM IS011",55, 0)
  31238    .
  31239   "RTN","CHM IS011",56, 0)
  31240    .S X=I D  H^%DTC S C MPWK=(%H-3 )\7,CMPMO= $E(I,1,5), CMPYR=$E(I ,1,3)
  31241   "RTN","CHM IS011",57, 0)
  31242    .S X=+$E( I,4,5)
  31243   "RTN","CHM IS011",58, 0)
  31244    .S CMPQTR =CMPYR_$S( X<4:1,X<7: 2,X<10:3,1 :4)
  31245   "RTN","CHM IS011",59, 0)
  31246    .S CMPYR= CMPYR+$S(X <10:0,1:1)
  31247   "RTN","CHM IS011",60, 0)
  31248    .
  31249   "RTN","CHM IS011",61, 0)
  31250    .;Added a bove line  to calc CH PYR correc tly..JBM 1 1-16-2000
  31251   "RTN","CHM IS011",62, 0)
  31252    .
  31253   "RTN","CHM IS011",63, 0)
  31254    .I WEEK'= CMPWK F X= "RZ","MZ", "SZ","PZ"  S $P(@X,"^ ",5)=""
  31255   "RTN","CHM IS011",64, 0)
  31256    .I MO'=CM PMO F X="R Z","MZ","S Z","PZ" S  $P(@X,"^", 6)=""
  31257   "RTN","CHM IS011",65, 0)
  31258    .I YR'=CM PYR F X="R Z","MZ","S Z","PZ" S  $P(@X,"^", 8)=""
  31259   "RTN","CHM IS011",66, 0)
  31260    .I QTR'=C MPQTR F X= "RZ","MZ", "SZ","PZ"  S $P(@X,"^ ",7)=""
  31261   "RTN","CHM IS011",67, 0)
  31262    .
  31263   "RTN","CHM IS011",68, 0)
  31264    .
  31265   "RTN","CHM IS011",69, 0)
  31266    I FI="MAN UAL(" G EN D
  31267   "RTN","CHM IS011",70, 0)
  31268    I FI="SCA N" G END
  31269   "RTN","CHM IS011",71, 0)
  31270    I FI="WAN D" G END
  31271   "RTN","CHM IS011",72, 0)
  31272    I FI="DIS T(" S MANI D=0,IN=0,I ND="" D SB 3^CHMIS012  G END
  31273   "RTN","CHM IS011",73, 0)
  31274    I FI="EDI /OCR" D ED IOCR^CHMIS 012 G END
  31275   "RTN","CHM IS011",74, 0)
  31276    ; CPE005- 023 ADD CA LL TO EDIR O TAG BASE D UPON CAL L TO EDIOC R TAG
  31277   "RTN","CHM IS011",75, 0)
  31278    I FI="EDI -REOPEN" D  EDIRO^CHM IS012 G EN D
  31279   "RTN","CHM IS011",76, 0)
  31280    ;
  31281   "RTN","CHM IS011",77, 0)
  31282    I (FI="CH MQA1(")!(F I="CHMQA2( ") D QAQ G  END
  31283   "RTN","CHM IS011",78, 0)
  31284    I FI="CHM QVN(" D ^C HMIS013 G  END
  31285   "RTN","CHM IS011",79, 0)
  31286    I FI="CHM EDIL(" S I ND="" D ED IL^CHMIS01 2 G END
  31287   "RTN","CHM IS011",80, 0)
  31288    I FI="CHM SNA(741008 .02," S IN D="" D GRO UP G END
  31289   "RTN","CHM IS011",81, 0)
  31290    I FI="CHM SNA(741008 .03," S IN D="" D CAP PS^CHMIS01 2 G END
  31291   "RTN","CHM IS011",82, 0)
  31292    I FI="CHM SNA(741008 .05," S IN D="" D CAL M^CHMIS012  G END
  31293   "RTN","CHM IS011",83, 0)
  31294    I FI="CHM EDIQ(" D   K %Y G END
  31295   "RTN","CHM IS011",84, 0)
  31296    .S X=TM D  H^%DTC Q: %Y=-1  Q:% Y'=0
  31297   "RTN","CHM IS011",85, 0)
  31298    .S CN=0 S :$D(^CHMDI C(741002.1 7,1,60)) C N=$P(^(60) ,"^",2) X  ^%ZOSF("UC I") S:$P(Y ,",",1)'=" HAC" CN=0  S Y=CHY D  EDIQ^CHMIS 012 Q   ;S KD, 7-31-0 5
  31299   "RTN","CHM IS011",86, 0)
  31300    S Y=CHY    ;SKD, 7-3 1-05, NEW
  31301   "RTN","CHM IS011",87, 0)
  31302    K A F J=1 :1 S X=$P( Y,";",J) Q :X=""  S A (FI,X)=""
  31303   "RTN","CHM IS011",88, 0)
  31304    S CURR=""  S:$D(^CHM STAT(OT,FI )) CURR=$P (^(FI),"^" ) S FN="^" _FI,J=0
  31305   "RTN","CHM IS011",89, 0)
  31306    I FI="CHM EOBQ(" D
  31307   "RTN","CHM IS011",90, 0)
  31308    .D NOW^%D TC S CYR=$ E(X,1,3),C MN=$E(X,4, 5)
  31309   "RTN","CHM IS011",91, 0)
  31310    .I CMN<10  S CYR=CYR -1
  31311   "RTN","CHM IS011",92, 0)
  31312    .S FY=CYR
  31313   "RTN","CHM IS011",93, 0)
  31314    .S J=FY_1 000
  31315   "RTN","CHM IS011",94, 0)
  31316    S:(FI="CH MQA1(")!(F I="CHMQA2( ") FN="^CH MQAQ("
  31317   "RTN","CHM IS011",95, 0)
  31318    S:(FI="CH MASQ1(") F N="^CHMASQ ("  ;AEB 8 /7/2006
  31319   "RTN","CHM IS011",96, 0)
  31320   A2 S J=$O( @(FN_J_")" )) G A3:'J ,A2:'$D(^( J,0)) S RE C=^(0),IND =$P(REC,"^ ",P)
  31321   "RTN","CHM IS011",97, 0)
  31322    I FI="CHM QA1(" S K= $O(^CHMQAQ (J,1,0)) G  A2:'K G A 2:'$D(^(K, 0)) G A2:$ P(^(0),"^" ,1)=7 G A2 :$P(^(0)," ^",1)=9 G  A2:$P(^(0) ,"^",1)=10  G A2:$P(^ (0),"^",1) =14  ;AEB  6/14/2007  QAQ P&C 
  31323   "RTN","CHM IS011",98, 0)
  31324    I FI="CHM QA2(" S K= $O(^CHMQAQ (J,1,0)) G  A2:'K G A 2:'$D(^(K, 0)) G:(($P (^(0),"^", 1)'=7)&($P (^(0),"^", 1)'=9)&($P (^(0),"^", 1)'=10)&($ P(^(0),"^" ,1)'=14))  A2  ;AEB 6 /14/2007 Q AQ CPD
  31325   "RTN","CHM IS011",99, 0)
  31326    I FI="CHM ASQ(" G A2 :$D(^CHMAS Q(J,100,0) )  ;AEB 8/ 7/2006 SKI P IF CHKIN G ASQ AND  HAS CODING  QUE STUFF
  31327   "RTN","CHM IS011",100 ,0)
  31328    I FI="CHM ASQ1(" G A 2:'$D(^CHM ASQ(J,100, 0))  ;AEB  8/7/2006 S KIP IF CHK ING CODING  QUE AND H AS NO CODI NG QUE STU FF
  31329   "RTN","CHM IS011",101 ,0)
  31330    D CALEND2 :IND'="" G  A2
  31331   "RTN","CHM IS011",102 ,0)
  31332   A3 I CURR' ="" S X=$P (Z,"^")-CU RR S:X'<0  $P(Z,"^",2 )=X S:X<0  $P(Z,"^",3 )=-X
  31333   "RTN","CHM IS011",103 ,0)
  31334    D TMUPD S :TM'=TN TM =TN D:'$D( ^CHMSTAT(T M)) SB1^CH MIS041
  31335   "RTN","CHM IS011",104 ,0)
  31336    S ^CHMSTA T(TM,FI)=Z  G END
  31337   "RTN","CHM IS011",105 ,0)
  31338   END K A,CN ,CURR,DT1, FI,FLAG,FN ,I,IN,IND, J,K,MO,MO1 ,OT,P,PARA M,PDI,QTR, QTR1
  31339   "RTN","CHM IS011",106 ,0)
  31340    K REC,TM, TN,WEEK,WE EK1,X,Y,YR ,YR1,Z Q
  31341   "RTN","CHM IS011",107 ,0)
  31342   CALEND1 S  %DT="",X=" T" D ^%DT  S DT=Y,X=+ ($H),WEEK= (X-3)\7,MO =$E(DT,1,5 )
  31343   "RTN","CHM IS011",108 ,0)
  31344    S YR=$E(D T,1,3),X=+ $E(DT,4,5) ,QTR=YR_$S (X<4:1,X<7 :2,X<10:3, 1:4)
  31345   "RTN","CHM IS011",109 ,0)
  31346    S YR=YR+$ S(X<10:0,1 :1) Q
  31347   "RTN","CHM IS011",110 ,0)
  31348    ;
  31349   "RTN","CHM IS011",111 ,0)
  31350    ;
  31351   "RTN","CHM IS011",112 ,0)
  31352    ;This cal culates ED I/OCR day,  week, mon th, quarte r and year  data
  31353   "RTN","CHM IS011",113 ,0)
  31354   CALEND2 S  X=$P(REC," ^"),DT1=+X \1 D H^%DT C S X=+%H, WEEK1=(X-3 )\7,MO1=$E (DT1,1,5)
  31355   "RTN","CHM IS011",114 ,0)
  31356    S YR1=$E( DT1,1,3),X =+$E(DT1,4 ,5),QTR1=Y R1_$S(X<4: 1,X<7:2,X< 10:3,1:4)
  31357   "RTN","CHM IS011",115 ,0)
  31358    S YR1=YR1 +$S(X<10:0 ,1:1)
  31359   "RTN","CHM IS011",116 ,0)
  31360    S:IND=""  $P(Z,"^")= $P(Z,"^")+ CHCOUNT
  31361   "RTN","CHM IS011",117 ,0)
  31362    I IND'=""  D
  31363   "RTN","CHM IS011",118 ,0)
  31364    .S:'$D(A( FI,IND)) $ P(Z,"^")=$ P(Z,"^")+C HCOUNT
  31365   "RTN","CHM IS011",119 ,0)
  31366    S:DT=DT1  $P(Z,"^",4 )=$P(Z,"^" ,4)+CHCOUN T
  31367   "RTN","CHM IS011",120 ,0)
  31368    S:WEEK=WE EK1 $P(Z," ^",5)=$P(Z ,"^",5)+CH COUNT
  31369   "RTN","CHM IS011",121 ,0)
  31370    S:MO=MO1  $P(Z,"^",6 )=$P(Z,"^" ,6)+CHCOUN T
  31371   "RTN","CHM IS011",122 ,0)
  31372    S:QTR=QTR 1 $P(Z,"^" ,7)=$P(Z," ^",7)+CHCO UNT
  31373   "RTN","CHM IS011",123 ,0)
  31374    S:YR=YR1  $P(Z,"^",8 )=$P(Z,"^" ,8)+CHCOUN T
  31375   "RTN","CHM IS011",124 ,0)
  31376    S:$D(CHFG ) $P(Z,"^" ,10)=CN Q
  31377   "RTN","CHM IS011",125 ,0)
  31378    ;
  31379   "RTN","CHM IS011",126 ,0)
  31380    ;
  31381   "RTN","CHM IS011",127 ,0)
  31382    ;
  31383   "RTN","CHM IS011",128 ,0)
  31384   QAQ K A F  J=1:1 S X= $P(Y,";",J ) Q:X=""   S A(FI,X)= ""
  31385   "RTN","CHM IS011",129 ,0)
  31386    S CURR=""  S:$D(^CHM STAT(OT,FI )) CURR=$P (^(FI),"^" ) S J=0
  31387   "RTN","CHM IS011",130 ,0)
  31388    S FN="^CH MQAQ("
  31389   "RTN","CHM IS011",131 ,0)
  31390   Q1 S J=$O( @(FN_J_")" )) G Q3:'J ,Q1:'$D(^( J,0)) S RE C=^(0),IND =$P(REC,"^ ",P)
  31391   "RTN","CHM IS011",132 ,0)
  31392    I FI="CHM QA1(" S K= $O(^CHMQAQ (J,1,0)) G  Q1:'K G Q 1:'$D(^(K, 0)) G Q1:$ P(^(0),"^" ,1)=7 G Q1 :$P(^(0)," ^",1)=9 G  Q1:$P(^(0) ,"^",1)=10
  31393   "RTN","CHM IS011",133 ,0)
  31394    I FI="CHM QA2(" S K= $O(^CHMQAQ (J,1,0)) G  Q1:'K G Q 1:'$D(^(K, 0)) G:(($P (^(0),"^", 1)'=7)&($P (^(0),"^", 1)'=9)&($P (^(0),"^", 1)'=10)) Q 1
  31395   "RTN","CHM IS011",134 ,0)
  31396    D CALEND2 :IND'="" G  Q1
  31397   "RTN","CHM IS011",135 ,0)
  31398   Q3 I CURR' ="" S X=$P (Z,"^")-CU RR S:X'<0  $P(Z,"^",2 )=X S:X<0  $P(Z,"^",3 )=-X
  31399   "RTN","CHM IS011",136 ,0)
  31400    D TMUPD S :TM'=TN TM =TN D:'$D( ^CHMSTAT(T M)) SB1^CH MIS041
  31401   "RTN","CHM IS011",137 ,0)
  31402    S ^CHMSTA T(TM,FI)=Z
  31403   "RTN","CHM IS011",138 ,0)
  31404    Q
  31405   "RTN","CHM IS011",139 ,0)
  31406   GROUP K A  F J=1:1 S  X=$P(Y,";" ,J) Q:X=""   S A(FI,X )=""
  31407   "RTN","CHM IS011",140 ,0)
  31408    S CURR=""  S:$D(^CHM STAT(OT,FI )) CURR=$P (^(FI),"^" )
  31409   "RTN","CHM IS011",141 ,0)
  31410    S FN="^"_ FI,J=0
  31411   "RTN","CHM IS011",142 ,0)
  31412   G1 S J=$O( ^CHMSNA(74 1008.02,J) ) G G3:'J, G1:'$D(^(J ,0))
  31413   "RTN","CHM IS011",143 ,0)
  31414    S K=""
  31415   "RTN","CHM IS011",144 ,0)
  31416   G2 S K=$O( ^CHMSNA(74 1008.02,J, 1,K)) G G1 :K="" G G2 :'$D(^(K,0 )) S REC=^ (0),IND=$P (REC,"^",P )
  31417   "RTN","CHM IS011",145 ,0)
  31418    I $P(^CHM SNA(741008 .02,J,0)," ^",2)'=""  S $P(REC," ^",1)=$P(^ (0),"^",2)
  31419   "RTN","CHM IS011",146 ,0)
  31420    E  S $P(R EC,"^",1)= DT-1
  31421   "RTN","CHM IS011",147 ,0)
  31422    D CALEND2 :IND'="" G  G2
  31423   "RTN","CHM IS011",148 ,0)
  31424   G3 I CURR' ="" S X=$P (Z,"^")-CU RR S:X'<0  $P(Z,"^",2 )=X S:X<0  $P(Z,"^",3 )=-X
  31425   "RTN","CHM IS011",149 ,0)
  31426    D TMUPD S :TM'=TN TM =TN D:'$D( ^CHMSTAT(T M)) SB1^CH MIS041
  31427   "RTN","CHM IS011",150 ,0)
  31428    S ^CHMSTA T(TM,FI)=Z
  31429   "RTN","CHM IS011",151 ,0)
  31430    Q
  31431   "RTN","CHM IS011",152 ,0)
  31432   TMUPD ;  U PDATE DATE  AND TIME  CYYMMDD.HR
  31433   "RTN","CHM IS011",153 ,0)
  31434    D NOW^%DT C S TN=+$E (%,1,10)
  31435   "RTN","CHM IS011",154 ,0)
  31436    Q
  31437   "RTN","CHM IS011",155 ,0)
  31438   ZSET S:'$D (DUZ) DUZ= 1,DUZ(0)=" " I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  31439   "RTN","CHM IS011",156 ,0)
  31440    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  31441   "RTN","CHM IS011",157 ,0)
  31442   ZNAM Q
  31443   "RTN","CHM IS011",158 ,0)
  31444    
  31445   "RTN","CHM IS012")
  31446   0^76^B1075 43024
  31447   "RTN","CHM IS012",1,0 )
  31448   CHMIS012 ; CVA/DTP;CH AMPVA SYST EM STATUS  CALC-UTILI TY RTN FOR  SPLIT;08/ 13/96  10: 54 AM
  31449   "RTN","CHM IS012",2,0 )
  31450    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  31451   "RTN","CHM IS012",3,0 )
  31452    ;;Called  by ^CHMIS0 11
  31453   "RTN","CHM IS012",4,0 )
  31454    ;;Calls ^ CHMIS011,  ^CHMIS041,  
  31455   "RTN","CHM IS012",5,0 )
  31456    ;;
  31457   "RTN","CHM IS012",6,0 )
  31458    ;;CPTS #1 0787 BY DT P (2-AUG-9 6)
  31459   "RTN","CHM IS012",7,0 )
  31460    ;;JSG2 10 /14/2017 -  CPE005-02 3 Add in E DI-RO info rmation
  31461   "RTN","CHM IS012",8,0 )
  31462    ;;CFS 02/ 05/2019 De fect 91923 8 - Preven t Undefine d error wi th $G.
  31463   "RTN","CHM IS012",9,0 )
  31464   SB2 ;CALLE D WHEN FI= CHMPAY
  31465   "RTN","CHM IS012",10, 0)
  31466    S CN=$O(^ CHMPAY(CN) ) G:'CN SB 2END
  31467   "RTN","CHM IS012",11, 0)
  31468    G:$D(^CHM PAY(CN,"ZF I")) SB2 G :'$D(^CHMP AY(CN,0))  SB2
  31469   "RTN","CHM IS012",12, 0)
  31470    S REC=^CH MPAY(CN,0)  G:$P(REC, "^",25)=""  SB2 G:$P( REC,"^",2) =10 SB2
  31471   "RTN","CHM IS012",13, 0)
  31472    S REC=$P( REC,"^",25 ) D CALEND 2^CHMIS011  G SB2
  31473   "RTN","CHM IS012",14, 0)
  31474   SB2END D T MUPD^CHMIS 011 S:TM'= TN TM=TN D :'$D(^CHMS TAT(TM)) S B1^CHMIS04 1
  31475   "RTN","CHM IS012",15, 0)
  31476    S $P(Z,"^ ")="",ZZT= "" I '$P(Z ,"^",10) D
  31477   "RTN","CHM IS012",16, 0)
  31478    .F ZZ=0:0  S ZZT=$O( ^CHMSTAT(Z ZT),-1) Q: 'ZZT  D  Q :$P(Z,"^", 10)
  31479   "RTN","CHM IS012",17, 0)
  31480    ..I $D(^C HMSTAT(ZZT ,FI)),$P(^ (FI),"^",1 0) S $P(Z, "^",10)=$P (^(FI),"^" ,10)
  31481   "RTN","CHM IS012",18, 0)
  31482    S ^CHMSTA T(TM,FI)=Z  K ^UTILIT Y($J),CN,P DI,CHFG,ZZ T,ZZ Q
  31483   "RTN","CHM IS012",19, 0)
  31484   SB3 S MANI D=$O(^CHMI MG("DIST", MANID)) G: 'MANID SB3 END
  31485   "RTN","CHM IS012",20, 0)
  31486    S PDI=$O( ^CHMIMG("D IST",MANID ,0)) G:'PD I SB3
  31487   "RTN","CHM IS012",21, 0)
  31488    G:'$D(^CH MIMG(PDI," DOC")) SB3  S REC=$P( ^("DOC")," ^",3)
  31489   "RTN","CHM IS012",22, 0)
  31490    G SB3:REC ="" S IN=I N+1 D CALE ND2^CHMIS0 11 G SB3
  31491   "RTN","CHM IS012",23, 0)
  31492   SB3END D T MUPD^CHMIS 011 S:TM'= TN TM=TN D :'$D(^CHMS TAT(TM)) S B1^CHMIS04 1
  31493   "RTN","CHM IS012",24, 0)
  31494    S $P(Z,"^ ")=IN,^CHM STAT(TM,FI )=Z K ^UTI LITY($J),C N,PDI
  31495   "RTN","CHM IS012",25, 0)
  31496    Q
  31497   "RTN","CHM IS012",26, 0)
  31498   SB4 ;CALLE D WHEN FI= IMAGE  cur renty not  used
  31499   "RTN","CHM IS012",27, 0)
  31500    S PDI=$O( ^CHMIMG(PD I)) G:'PDI  SB4END
  31501   "RTN","CHM IS012",28, 0)
  31502    S MANID=" " I $D(^CH MIMG(PDI," DOC")) S M ANID=+^("D OC")
  31503   "RTN","CHM IS012",29, 0)
  31504    I MANID G :$D(^CHMIM G("DIST",M ANID,PDI))  SB4
  31505   "RTN","CHM IS012",30, 0)
  31506    S:$D(^CHM IMG("READY ",PDI)) RI N=RIN+1
  31507   "RTN","CHM IS012",31, 0)
  31508    I $D(^CHM IMG("MANUA L",PDI)) I  $D(^CHMIM G(PDI,0))  I $P(^(0), "^",6)=0 I  $D(^CHMIM PB("C",PDI )) S MIN=M IN+1
  31509   "RTN","CHM IS012",32, 0)
  31510    ;I $P(^CH MIMG(PDI,0 ),"^",6)=9  S SCIN=SC IN+1 G SB4
  31511   "RTN","CHM IS012",33, 0)
  31512    ;I $P(^CH MIMG(PDI,0 ),"^",6)=1 0 S PUIN=P UIN+1 D SB 6 G SB4
  31513   "RTN","CHM IS012",34, 0)
  31514    I $P(^CHM IMG(PDI,0) ,"^",6)=9  S PUIN=PUI N+1 D SB6  G SB4
  31515   "RTN","CHM IS012",35, 0)
  31516    G:'$D(^CH MIMG(PDI," DOC")) SB4
  31517   "RTN","CHM IS012",36, 0)
  31518    D SB6,SB7
  31519   "RTN","CHM IS012",37, 0)
  31520    G:$P(^CHM IMG(PDI,0) ,"^",6)<3  SB4
  31521   "RTN","CHM IS012",38, 0)
  31522    G:'$D(^CH MIMAGE(PDI )) SB4
  31523   "RTN","CHM IS012",39, 0)
  31524    G:'$D(^CH MIMAGE(PDI ,0)) SB4
  31525   "RTN","CHM IS012",40, 0)
  31526    S REC=$P( ^CHMIMAGE( PDI,0),"^" ,5)
  31527   "RTN","CHM IS012",41, 0)
  31528    G:REC=""  SB4 S MANI D=$P(^CHMI MG(PDI,"DO C"),"^",10 )
  31529   "RTN","CHM IS012",42, 0)
  31530    I MANID=" " I '$D(^C HMIMPB("C" ,PDI)) D   G SB4
  31531   "RTN","CHM IS012",43, 0)
  31532    .S FI="IM AGE(",Z=RZ  D CALEND2 ^CHMIS011  S RZ=Z
  31533   "RTN","CHM IS012",44, 0)
  31534    I $D(^CHM IMPB("C",P DI)) D  G  SB4
  31535   "RTN","CHM IS012",45, 0)
  31536    .S FI="MA NUAL(",Z=M Z D CALEND 2^CHMIS011  S MZ=Z
  31537   "RTN","CHM IS012",46, 0)
  31538    I $D(^CHM IMG("E",MA NID)) S FI ="MANUAL(" ,Z=MZ D CA LEND2^CHMI S011 S MZ= Z G SB4
  31539   "RTN","CHM IS012",47, 0)
  31540    S FI="IMA GE(",Z=RZ  D CALEND2^ CHMIS011 S  RZ=Z G SB 4
  31541   "RTN","CHM IS012",48, 0)
  31542   SB4END D T MUPD^CHMIS 011 S:TM'= TN TM=TN D :'$D(^CHMS TAT(TM)) S B1^CHMIS04 1
  31543   "RTN","CHM IS012",49, 0)
  31544    S $P(RZ," ^")=RIN,$P (RZ,"^",9) ="IMAGE",^ CHMSTAT(TM ,"IMAGE(") =RZ
  31545   "RTN","CHM IS012",50, 0)
  31546    S $P(MZ," ^")=MIN,$P (MZ,"^",9) ="MANUAL", ^CHMSTAT(T M,"MANUAL( ")=MZ
  31547   "RTN","CHM IS012",51, 0)
  31548    S $P(SZ," ^")=SCIN,$ P(SZ,"^",9 )="SCAN",^ CHMSTAT(TM ,"SCAN")=S Z
  31549   "RTN","CHM IS012",52, 0)
  31550    S $P(PZ," ^")=PUIN,$ P(PZ,"^",9 )="PULL",^ CHMSTAT(TM ,"WAND")=P Z
  31551   "RTN","CHM IS012",53, 0)
  31552    K ^UTILIT Y($J),CN,P DI,RIN,MIN ,MZ,RZ Q
  31553   "RTN","CHM IS012",54, 0)
  31554   SB5 S CN=$ O(^CHMBAR( CN)) G:'CN  SB5END
  31555   "RTN","CHM IS012",55, 0)
  31556    G:'$D(^CH MBAR(CN,0) ) SB5
  31557   "RTN","CHM IS012",56, 0)
  31558    S REC=$P( CN,".",1)
  31559   "RTN","CHM IS012",57, 0)
  31560    S (J,CHCO UNT)=0
  31561   "RTN","CHM IS012",58, 0)
  31562   SB5A S J=$ O(^CHMBAR( CN,100,J))  I 'J D CA LEND2^CHMI S011 G SB5
  31563   "RTN","CHM IS012",59, 0)
  31564    G:'$D(^CH MBAR(CN,10 0,J,0)) SB 5A
  31565   "RTN","CHM IS012",60, 0)
  31566    S CHCOUNT =$P(^CHMBA R(CN,100,J ,0),U,2)-$ P(^CHMBAR( CN,100,J,0 ),U,4)+CHC OUNT
  31567   "RTN","CHM IS012",61, 0)
  31568    G SB5A
  31569   "RTN","CHM IS012",62, 0)
  31570   SB5END S C HCOUNT=1 D  TMUPD^CHM IS011 S:TM '=TN TM=TN  D:'$D(^CH MSTAT(TM))  SB1^CHMIS 041
  31571   "RTN","CHM IS012",63, 0)
  31572    S ^CHMSTA T(TM,FI)=Z  K ^UTILIT Y($J),CN,P DI,RIN,MIN ,MZ,RZ Q
  31573   "RTN","CHM IS012",64, 0)
  31574   SB6 Q:'$D( ^CHMIMG(PD I,"DOC"))   S REC=$P( ^("DOC")," ^",3)
  31575   "RTN","CHM IS012",65, 0)
  31576    Q:REC=""   S Z=SZ,HF I=FI,FI="S CAN" D CAL END2^CHMIS 011 S SZ=Z ,FI=HFI Q
  31577   "RTN","CHM IS012",66, 0)
  31578    ;
  31579   "RTN","CHM IS012",67, 0)
  31580   SB7 Q:'$D( ^CHMIMPB(" C",PDI))
  31581   "RTN","CHM IS012",68, 0)
  31582    S BAT="A" ,BAT=$O(^C HMIMPB("C" ,PDI,BAT), -1) Q:'BAT
  31583   "RTN","CHM IS012",69, 0)
  31584    Q:'$D(^CH MIMPB(BAT, 0))
  31585   "RTN","CHM IS012",70, 0)
  31586    S REC=$P( ^(0),"^",2 ) Q:REC=""
  31587   "RTN","CHM IS012",71, 0)
  31588    S Z=PZ,HF I=FI,FI="W AND"
  31589   "RTN","CHM IS012",72, 0)
  31590    D CALEND2 ^CHMIS011  S PZ=Z,FI= HFI
  31591   "RTN","CHM IS012",73, 0)
  31592    Q
  31593   "RTN","CHM IS012",74, 0)
  31594    ;
  31595   "RTN","CHM IS012",75, 0)
  31596   SB8 D NOW^ %DTC S X1= $P(%,".",1 ),X2=-1 D  C^%DTC S P DIDATE=X
  31597   "RTN","CHM IS012",76, 0)
  31598    S ENDDATE =X_".99999 9"
  31599   "RTN","CHM IS012",77, 0)
  31600   SB81 S PDI DATE=$O(^C HMPROD(741 060.01,"C" ,PDIDATE))
  31601   "RTN","CHM IS012",78, 0)
  31602    G:'PDIDAT E SB8END G :PDIDATE>E NDDATE SB8 END
  31603   "RTN","CHM IS012",79, 0)
  31604    S II=0
  31605   "RTN","CHM IS012",80, 0)
  31606   SB82 S II= $O(^CHMPRO D(741060.0 1,"C",PDID ATE,II)) G :'II SB81
  31607   "RTN","CHM IS012",81, 0)
  31608    S PDI=0
  31609   "RTN","CHM IS012",82, 0)
  31610   SB83 S PDI =$O(^CHMPR OD(741060. 01,"C",PDI DATE,II,PD I)) G:'PDI  SB82
  31611   "RTN","CHM IS012",83, 0)
  31612    ;G:$D(^CH MZHOLD("CO UNTED-PDIS ",PDI)) SB 83
  31613   "RTN","CHM IS012",84, 0)
  31614    ;S ^CHMZH OLD("COUNT ED-PDIS",P DI)=""
  31615   "RTN","CHM IS012",85, 0)
  31616    S MANID=" " I $D(^CH MIMG(PDI," DOC")) S M ANID=+^CHM IMG(PDI,"D OC")
  31617   "RTN","CHM IS012",86, 0)
  31618    I MANID G :$D(^CHMIM G("DIST",M ANID,PDI))  SB83
  31619   "RTN","CHM IS012",87, 0)
  31620    ;S:$D(^CH MIMG("READ Y",PDI)) R IN=RIN+1
  31621   "RTN","CHM IS012",88, 0)
  31622    ;I $D(^CH MIMG("MANU AL",PDI))  I $D(^CHMI MG(PDI,0))  I $P(^(0) ,"^",6)=0  I $D(^CHMI MPB("C",PD I)) S MIN= MIN+1
  31623   "RTN","CHM IS012",89, 0)
  31624    I $P(^CHM IMG(PDI,0) ,"^",6)=9  G SB83
  31625   "RTN","CHM IS012",90, 0)
  31626    I $P(^CHM IMG(PDI,0) ,"^",6)=10  D SB6 G S B83
  31627   "RTN","CHM IS012",91, 0)
  31628    G:'$D(^CH MIMG(PDI," DOC")) SB8 3
  31629   "RTN","CHM IS012",92, 0)
  31630    D SB6,SB7
  31631   "RTN","CHM IS012",93, 0)
  31632    G:$P(^CHM IMG(PDI,0) ,"^",6)<3  SB83
  31633   "RTN","CHM IS012",94, 0)
  31634    G:'$D(^CH MIMAGE(PDI )) SB83
  31635   "RTN","CHM IS012",95, 0)
  31636    G:'$D(^CH MIMAGE(PDI ,0)) SB83
  31637   "RTN","CHM IS012",96, 0)
  31638    S REC=$P( ^CHMIMAGE( PDI,0),"^" ,5)
  31639   "RTN","CHM IS012",97, 0)
  31640    G:REC=""  SB83 S MAN ID=$P(^CHM IMG(PDI,"D OC"),"^",1 0)
  31641   "RTN","CHM IS012",98, 0)
  31642    I MANID=" " I '$D(^C HMIMPB("C" ,PDI)) D   G SB83
  31643   "RTN","CHM IS012",99, 0)
  31644    .S FI="IM AGE(",Z=RZ  D CALEND2 ^CHMIS011  S RZ=Z
  31645   "RTN","CHM IS012",100 ,0)
  31646    I $D(^CHM IMPB("C",P DI)) D  G  SB83
  31647   "RTN","CHM IS012",101 ,0)
  31648    .S FI="MA NUAL(",Z=M Z D CALEND 2^CHMIS011  S MZ=Z
  31649   "RTN","CHM IS012",102 ,0)
  31650    I $D(^CHM IMG("E",MA NID)) S FI ="MANUAL(" ,Z=MZ D CA LEND2^CHMI S011 S MZ= Z G SB83
  31651   "RTN","CHM IS012",103 ,0)
  31652    S FI="IMA GE(",Z=RZ  D CALEND2^ CHMIS011 S  RZ=Z G SB 83
  31653   "RTN","CHM IS012",104 ,0)
  31654   SB8END S P DI=^CHMIMG ("PDI-STAR T")
  31655   "RTN","CHM IS012",105 ,0)
  31656   SB8END1 S  PDI=$O(^CH MIMG(PDI))  G:'PDI SB 8END3
  31657   "RTN","CHM IS012",106 ,0)
  31658    I $D(^CHM IMG("READY ",PDI)) S  RIN=RIN+1  G SB8END2
  31659   "RTN","CHM IS012",107 ,0)
  31660    I $D(^CHM IMG(PDI,0) ) I $P(^(0 ),"^",6)=0  I $D(^CHM IMPB("C",P DI)) S MIN =MIN+1
  31661   "RTN","CHM IS012",108 ,0)
  31662   SB8END2 I  $P($G(^CHM IMG(PDI,0) ),"^",6)=9  S $P(^CHM IMG(PDI,0) ,"^",6)=10 ,SCIN=0  ; CFS 02/05/ 2019 Defec t 919238
  31663   "RTN","CHM IS012",109 ,0)
  31664    I $P($G(^ CHMIMG(PDI ,0)),"^",6 )=10 S PUI N=PUIN+1 G  SB8END1   ;CFS 02/05 /2019 Defe ct 919238
  31665   "RTN","CHM IS012",110 ,0)
  31666    G SB8END1
  31667   "RTN","CHM IS012",111 ,0)
  31668   SB8END3 D  TMUPD^CHMI S011 S:TM' =TN TM=TN  D:'$D(^CHM STAT(TM))  SB1^CHMIS0 41
  31669   "RTN","CHM IS012",112 ,0)
  31670    S $P(RZ," ^")=RIN,$P (RZ,"^",9) ="IMAGE",^ CHMSTAT(TM ,"IMAGE(") =RZ
  31671   "RTN","CHM IS012",113 ,0)
  31672    S $P(MZ," ^")=MIN,$P (MZ,"^",9) ="MANUAL", ^CHMSTAT(T M,"MANUAL( ")=MZ
  31673   "RTN","CHM IS012",114 ,0)
  31674    S $P(SZ," ^")=SCIN,$ P(SZ,"^",9 )="SCAN",^ CHMSTAT(TM ,"SCAN")=S Z
  31675   "RTN","CHM IS012",115 ,0)
  31676    S $P(PZ," ^")=PUIN,$ P(PZ,"^",9 )="PULL",^ CHMSTAT(TM ,"WAND")=P Z
  31677   "RTN","CHM IS012",116 ,0)
  31678    K ^UTILIT Y($J),CN,P DI,RIN,MIN ,MZ,RZ Q
  31679   "RTN","CHM IS012",117 ,0)
  31680    ;
  31681   "RTN","CHM IS012",118 ,0)
  31682   CAPPS K A  F J=1:1 S  X=$P(Y,";" ,J) Q:X=""   S A(FI,X )=""
  31683   "RTN","CHM IS012",119 ,0)
  31684    S CURR=""  S:$D(^CHM STAT(OT,FI )) CURR=$P (^(FI),"^" )
  31685   "RTN","CHM IS012",120 ,0)
  31686    ;S FN="^" _FI,J=0
  31687   "RTN","CHM IS012",121 ,0)
  31688    D
  31689   "RTN","CHM IS012",122 ,0)
  31690    .D NOW^%D TC S CYR=$ E(X,1,3),C MN=$E(X,4, 5)
  31691   "RTN","CHM IS012",123 ,0)
  31692    .I CMN<10  S CYR=CYR -1
  31693   "RTN","CHM IS012",124 ,0)
  31694    .S FY=CYR
  31695   "RTN","CHM IS012",125 ,0)
  31696    .Q
  31697   "RTN","CHM IS012",126 ,0)
  31698    S FN="^"_ FI,J=FY_10 00
  31699   "RTN","CHM IS012",127 ,0)
  31700   CP1 S J=$O (^CHMSNA(7 41008.03,J )) G CP3:' J,CP1:'$D( ^(J,0))
  31701   "RTN","CHM IS012",128 ,0)
  31702    S K=""
  31703   "RTN","CHM IS012",129 ,0)
  31704   CP2 S K=$O (^CHMSNA(7 41008.03,J ,1,K)) G C P1:K="" G  CP2:'$D(^( K,0)) S RE C=^(0),IND =$P(REC,"^ ",P)
  31705   "RTN","CHM IS012",130 ,0)
  31706    I $P(^CHM SNA(741008 .03,J,0)," ^",1)'=""  S $P(REC," ^",1)=$P(^ (0),"^",1)
  31707   "RTN","CHM IS012",131 ,0)
  31708    E  S $P(R EC,"^",1)= DT-1
  31709   "RTN","CHM IS012",132 ,0)
  31710    D CALEND2 ^CHMIS011: IND'="" G  CP2
  31711   "RTN","CHM IS012",133 ,0)
  31712   CP3 I CURR '="" S X=$ P(Z,"^")-C URR S:X'<0  $P(Z,"^", 2)=X S:X<0  $P(Z,"^", 3)=-X
  31713   "RTN","CHM IS012",134 ,0)
  31714    D TMUPD^C HMIS011 S: TM'=TN TM= TN D:'$D(^ CHMSTAT(TM )) SB1^CHM IS041
  31715   "RTN","CHM IS012",135 ,0)
  31716    S ^CHMSTA T(TM,FI)=Z
  31717   "RTN","CHM IS012",136 ,0)
  31718    Q
  31719   "RTN","CHM IS012",137 ,0)
  31720   CALM K A F  J=1:1 S X =$P(Y,";", J) Q:X=""   S A(FI,X) =""
  31721   "RTN","CHM IS012",138 ,0)
  31722    S CURR=""  S:$D(^CHM STAT(OT,FI )) CURR=$P (^(FI),"^" )
  31723   "RTN","CHM IS012",139 ,0)
  31724    ;S FN="^" _FI,J=0
  31725   "RTN","CHM IS012",140 ,0)
  31726    D
  31727   "RTN","CHM IS012",141 ,0)
  31728    .D NOW^%D TC S CYR=$ E(X,1,3),C MN=$E(X,4, 5)
  31729   "RTN","CHM IS012",142 ,0)
  31730    .I CMN<10  S CYR=CYR -1
  31731   "RTN","CHM IS012",143 ,0)
  31732    .S FY=CYR
  31733   "RTN","CHM IS012",144 ,0)
  31734    .Q
  31735   "RTN","CHM IS012",145 ,0)
  31736    S FN="^"_ FI,J=FY_10 00
  31737   "RTN","CHM IS012",146 ,0)
  31738   CL1 S J=$O (^CHMSNA(7 41008.05,J )) G CL3:' J,CL1:'$D( ^(J,0))
  31739   "RTN","CHM IS012",147 ,0)
  31740    S K=""
  31741   "RTN","CHM IS012",148 ,0)
  31742   CL2 S K=$O (^CHMSNA(7 41008.05,J ,1,K)) G C L1:K="" G  CL2:'$D(^( K,0)) S RE C=^(0),IND =$P(REC,"^ ",P)
  31743   "RTN","CHM IS012",149 ,0)
  31744    I $P(^CHM SNA(741008 .05,J,0)," ^",1)'=""  S $P(REC," ^",1)=$P(^ (0),"^",1)
  31745   "RTN","CHM IS012",150 ,0)
  31746    E  S $P(R EC,"^",1)= DT-1
  31747   "RTN","CHM IS012",151 ,0)
  31748    D CALEND2 ^CHMIS011: IND'="" G  CL2
  31749   "RTN","CHM IS012",152 ,0)
  31750   CL3 I CURR '="" S X=$ P(Z,"^")-C URR S:X'<0  $P(Z,"^", 2)=X S:X<0  $P(Z,"^", 3)=-X
  31751   "RTN","CHM IS012",153 ,0)
  31752    D TMUPD^C HMIS011 S: TM'=TN TM= TN D:'$D(^ CHMSTAT(TM )) SB1^CHM IS041
  31753   "RTN","CHM IS012",154 ,0)
  31754    S ^CHMSTA T(TM,FI)=Z
  31755   "RTN","CHM IS012",155 ,0)
  31756    Q
  31757   "RTN","CHM IS012",156 ,0)
  31758   EDIQ ;NEXT  12 LINES  START OF T HE NEW EDI Q PENDING  RECOUNT-DT P (26-JULY -96)
  31759   "RTN","CHM IS012",157 ,0)
  31760    S CURR=""  S:$D(^CHM STAT(OT,FI )) CURR=+$ P(^(FI),"^ ")
  31761   "RTN","CHM IS012",158 ,0)
  31762    S CNT=0 K  A F J=1:1  S X=$P(Y, ";",J) Q:X =""  S A(F I,X)=""
  31763   "RTN","CHM IS012",159 ,0)
  31764   EDIQ1 S CN =$O(^CHMPA Y(CN)) G:' CN EDIQEND
  31765   "RTN","CHM IS012",160 ,0)
  31766    G:'$D(^CH MPAY(CN,"Z EMC")) EDI Q1 G:'$D(^ CHMPAY(CN, 0)) EDIQ1
  31767   "RTN","CHM IS012",161 ,0)
  31768    S REC=^CH MPAY(CN,0)  G:$P(REC, "^",25)=""  EDIQ1 G:$ P(REC,"^", 2)=10 EDIQ 1
  31769   "RTN","CHM IS012",162 ,0)
  31770    S IND=$P( REC,"^",P)  I IND=""  S CNT=CNT+ 1 G EDIQ2
  31771   "RTN","CHM IS012",163 ,0)
  31772    S:'$D(A(F I,IND)) CN T=CNT+1
  31773   "RTN","CHM IS012",164 ,0)
  31774   EDIQ2 S RE C=$P(REC," ^",25) D C ALEND2^CHM IS011
  31775   "RTN","CHM IS012",165 ,0)
  31776    G EDIQ1
  31777   "RTN","CHM IS012",166 ,0)
  31778   EDIQEND S  $P(Z,"^")= CNT I CURR '="" S X=$ P(Z,"^")-C URR S:X'<0  $P(Z,"^", 2)=X S:X<0  $P(Z,"^", 3)=-X
  31779   "RTN","CHM IS012",167 ,0)
  31780    D TMUPD^C HMIS011 S: TM'=TN TM= TN D:'$D(^ CHMSTAT(TM )) SB1^CHM IS041
  31781   "RTN","CHM IS012",168 ,0)
  31782    S ^CHMSTA T(TM,FI)=Z  K CNT Q
  31783   "RTN","CHM IS012",169 ,0)
  31784   EDIL  ;GET  CURRENT C OUNT OF OC R SUBMISSI ONS
  31785   "RTN","CHM IS012",170 ,0)
  31786    ;TLH 11/2 1/06 REMOV ED COMMENT ED OFF COD E - CHANGE D TO COUNT  ONLY OCR  SUBMISSION S NOT MMI  OR CMOP
  31787   "RTN","CHM IS012",171 ,0)
  31788    ;F FN="^C HMXRX(" S  J=0 D EDIL 1 Q  ; CAN  ADD OTHER  EDI VENDO RS WITH NE W FILENAME S(FN) IF I N WPS FORM AT
  31789   "RTN","CHM IS012",172 ,0)
  31790    ;EDIL1 S  J=$O(@(FN_ "J)")) I ' J D EDIL4  Q
  31791   "RTN","CHM IS012",173 ,0)
  31792    ;G:'$D(@( FN_"J,0)") ) EDIL1 S  REC=$P(@(F N_"J,0)"), "^",2),K=0
  31793   "RTN","CHM IS012",174 ,0)
  31794    ;EDIL2 S  K=$O(@(FN_ "J,100,K)" )) G:'K ED IL1 G:'$D( @(FN_"J,10 0,K,0)"))  EDIL2 S L= 0
  31795   "RTN","CHM IS012",175 ,0)
  31796    ;EDIL3 S  L=$O(@(FN_ "J,100,K,1 00,L)")) G :'L EDIL2  G:'$D(@(FN _"J,100,K, 100,L,0)") ) EDIL3
  31797   "RTN","CHM IS012",176 ,0)
  31798    ;G:'$D(@( FN_"J,100, K,100,L,2) ")) EDIL3
  31799   "RTN","CHM IS012",177 ,0)
  31800    ;G:(FN="^ CHMXRX(")& ($P(@(FN_" J,100,K,10 0,L,2)")," ^",1)="")  EDIL3
  31801   "RTN","CHM IS012",178 ,0)
  31802    ;D CALEND 2^CHMIS011  G EDIL3
  31803   "RTN","CHM IS012",179 ,0)
  31804    ;EDIL4 D  TMUPD^CHMI S011 S:TM' =TN TM=TN  D:'$D(^CHM STAT(TM))  SB1^CHMIS0 41
  31805   "RTN","CHM IS012",180 ,0)
  31806    ;S $P(Z," ^")="",^CH MSTAT(TM,F I)=Z Q
  31807   "RTN","CHM IS012",181 ,0)
  31808    F CHEOQUE ="OCR2-REA DY","SBOCR 2-READY" S  CHPDIHLD= 0 D EDIL1   ;TLH 11/2 1/06 CHANG ED TO COUN T OCR SUBM ISSIONS
  31809   "RTN","CHM IS012",182 ,0)
  31810    D TMUPD^C HMIS011 S: TM'=TN TM= TN D:'$D(^ CHMSTAT(TM )) SB1^CHM IS041  ;TL H 11/21/06  CHANGED T O COUNT OC R SUBMISSI ONS
  31811   "RTN","CHM IS012",183 ,0)
  31812    S PDICT(9 4)="",PDIC T(95)="",P DICT(96)=" " F I=4:1: 8 S $P(Z," ^",I)=0 ;T LH 11/21/0 6 CHANGED  TO COUNT O CR SUBMISS IONS 
  31813   "RTN","CHM IS012",184 ,0)
  31814    D PDICNT   ;TLH 11/2 1/06 CHANG ED TO COUN T OCR SUBM ISSIONS
  31815   "RTN","CHM IS012",185 ,0)
  31816    S ^CHMSTA T(TM,FI)=Z  K PDICT Q   ;TLH 11/ 21/06 CHAN GED TO COU NT OCR SUB MISSIONS
  31817   "RTN","CHM IS012",186 ,0)
  31818   EDIL1 S CH PDIHLD=$O( ^CHMIMG(CH EOQUE,CHPD IHLD)) Q:' CHPDIHLD   ;TLH 11/21 /06 CHANGE D TO COUNT  OCR SUBMI SSIONS
  31819   "RTN","CHM IS012",187 ,0)
  31820    G:'$D(^CH MIMG(CHPDI HLD,0)) ED IL1  ;TLH  11/21/06 C HANGED TO  COUNT OCR  SUBMISSION S
  31821   "RTN","CHM IS012",188 ,0)
  31822    S REC=$P( ^CHMIMG(CH PDIHLD,0), "^",4) I R EC="" D  G :REC="" ED IL1  ;TLH  11/21/06 C HANGED TO  COUNT OCR  SUBMISSION S
  31823   "RTN","CHM IS012",189 ,0)
  31824    .S CHWFPT =0 ;TLH 11 /21/06 CHA NGED TO CO UNT OCR SU BMISSIONS 
  31825   "RTN","CHM IS012",190 ,0)
  31826    .Q:'$D(^C HMIMG(CHPD IHLD,"WF") )  ;TLH 11 /21/06 CHA NGED TO CO UNT OCR SU BMISSIONS
  31827   "RTN","CHM IS012",191 ,0)
  31828    .S CHWFPT =$O(^CHMIM G(CHPDIHLD ,"WF",CHWF PT)) Q:CHW FPT=""  ;T LH 11/21/0 6 CHANGED  TO COUNT O CR SUBMISS IONS
  31829   "RTN","CHM IS012",192 ,0)
  31830    .Q:'$D(^C HMIMG(CHPD IHLD,"WF", CHWFPT,0))   ;TLH 11/ 21/06 CHAN GED TO COU NT OCR SUB MISSIONS 
  31831   "RTN","CHM IS012",193 ,0)
  31832    .S REC=$P (^CHMIMG(C HPDIHLD,"W F",CHWFPT, 0),"^",2)   ;TLH 11/2 1/06 CHANG ED TO COUN T OCR SUBM ISSIONS
  31833   "RTN","CHM IS012",194 ,0)
  31834    S IND=""  D CALEND2^ CHMIS011 G  EDIL1  ;T LH 11/21/0 6 CHANGED  TO COUNT O CR SUBMISS IONS
  31835   "RTN","CHM IS012",195 ,0)
  31836    ; 
  31837   "RTN","CHM IS012",196 ,0)
  31838   EDIOCR  ;G ET CURRENT  COUNT FOR  EDI SUBMI SSIONS
  31839   "RTN","CHM IS012",197 ,0)
  31840    ;TLH 11/2 1/06 MODIF IED TO COU NT ONLY ED I SUBMISSI ONS
  31841   "RTN","CHM IS012",198 ,0)
  31842    F CHEOQUE ="OCR-READ Y","SBOCR- READY" S C HPDIHLD=0  D EO1  ;TL H 11/21/06  CHANGED T O COUNT ED I SUBMISSI ONS
  31843   "RTN","CHM IS012",199 ,0)
  31844    D TMUPD^C HMIS011 S: TM'=TN TM= TN D:'$D(^ CHMSTAT(TM )) SB1^CHM IS041  ;TL H 11/21/06  CHANGED T O COUNT ED I SUBMISSI ONS
  31845   "RTN","CHM IS012",200 ,0)
  31846    S PDICT(9 1)="",PDIC T(92)="",P DICT(93)=" " F I=4:1: 8 S $P(Z," ^",I)=0  ; TLH 11/21/ 06 CHANGED  TO COUNT  EDI SUBMIS SIONS
  31847   "RTN","CHM IS012",201 ,0)
  31848    D PDICNT    ;TLH 11/ 21/06 CHAN GED TO COU NT OCR SUB MISSIONS
  31849   "RTN","CHM IS012",202 ,0)
  31850    S ^CHMSTA T(TM,FI)=Z   K PDICT  Q  ;TLH 11 /21/06 CHA NGED TO CO UNT EDI SU BMISSIONS
  31851   "RTN","CHM IS012",203 ,0)
  31852    ; 
  31853   "RTN","CHM IS012",204 ,0)
  31854    ; CPE005- 023 ADD ED IRO TAG BA SED UPON E DIOCR TAG
  31855   "RTN","CHM IS012",205 ,0)
  31856   EDIRO  ;GE T CURRENT  COUNT FOR  EDI-RO SUB MISSIONS
  31857   "RTN","CHM IS012",206 ,0)
  31858    N PDICT
  31859   "RTN","CHM IS012",207 ,0)
  31860    F CHEOQUE ="OCRR-REA DY","SBOCR R-READY" S  CHPDIHLD= 0 D EO1
  31861   "RTN","CHM IS012",208 ,0)
  31862    D TMUPD^C HMIS011 S: TM'=TN TM= TN D:'$D(^ CHMSTAT(TM )) SB1^CHM IS041
  31863   "RTN","CHM IS012",209 ,0)
  31864    S PDICT(9 7)="" F I= 4:1:8 S $P (Z,"^",I)= 0
  31865   "RTN","CHM IS012",210 ,0)
  31866    D PDICNT
  31867   "RTN","CHM IS012",211 ,0)
  31868    S ^CHMSTA T(TM,FI)=Z
  31869   "RTN","CHM IS012",212 ,0)
  31870    Q
  31871   "RTN","CHM IS012",213 ,0)
  31872    ; 
  31873   "RTN","CHM IS012",214 ,0)
  31874   EO1 S CHPD IHLD=$O(^C HMIMG(CHEO QUE,CHPDIH LD)) Q:'CH PDIHLD  ;T LH 11/21/0 6 CHANGED  TO COUNT E DI SUBMISS IONS
  31875   "RTN","CHM IS012",215 ,0)
  31876    G:'$D(^CH MIMG(CHPDI HLD,0)) EO 1  ;TLH 11 /21/06 CHA NGED TO CO UNT OCR SU BMISSIONS
  31877   "RTN","CHM IS012",216 ,0)
  31878    S REC=$P( ^CHMIMG(CH PDIHLD,0), "^",4) I R EC="" D  G :REC="" EO 1 ;TLH 11/ 21/06 CHAN GED TO COU NT EDI SUB MISSIONS 
  31879   "RTN","CHM IS012",217 ,0)
  31880    .S CHWFPT =0  ;TLH 1 1/21/06 CH ANGED TO C OUNT EDI S UBMISSIONS
  31881   "RTN","CHM IS012",218 ,0)
  31882    .Q:'$D(^C HMIMG(CHPD IHLD,"WF") )  ;TLH 11 /21/06 CHA NGED TO CO UNT EDI SU BMISSIONS
  31883   "RTN","CHM IS012",219 ,0)
  31884    .S CHWFPT =$O(^CHMIM G(CHPDIHLD ,"WF",CHWF PT)) Q:CHW FPT=""  ;T LH 11/21/0 6 CHANGED  TO COUNT E DI SUBMISS IONS
  31885   "RTN","CHM IS012",220 ,0)
  31886    .Q:'$D(^C HMIMG(CHPD IHLD,"WF", CHWFPT,0))   ;TLH 11/ 21/06 CHAN GED TO COU NT EDI SUB MISSIONS
  31887   "RTN","CHM IS012",221 ,0)
  31888    .S REC=$P (^CHMIMG(C HPDIHLD,"W F",CHWFPT, 0),"^",2)   ;TLH 11/2 1/06 CHANG ED TO COUN T EDI SUBM ISSIONS
  31889   "RTN","CHM IS012",222 ,0)
  31890    S IND=""  D CALEND2^ CHMIS011 G  EO1  ;TLH  11/21/06  CHANGED TO  COUNT EDI  SUBMISSIO NS
  31891   "RTN","CHM IS012",223 ,0)
  31892    ;
  31893   "RTN","CHM IS012",224 ,0)
  31894   PDICNT   ; CALLED FRO M EDIOCR A ND EDI
  31895   "RTN","CHM IS012",225 ,0)
  31896    ;COUNTS A LL PROCESS ED EDI/OCR  SUBMISSIO NS
  31897   "RTN","CHM IS012",226 ,0)
  31898    ;TLH 11/2 1/06 ADDED  PDICNT SU BROUTINE A DDED FOR T HE EDI AND  OCR COUNT S ON SUBMI SSIONS FOR  THE CHV S CREENS DEV 000115
  31899   "RTN","CHM IS012",227 ,0)
  31900    I '$D(DT)  D NOW^%DT C S DT=X
  31901   "RTN","CHM IS012",228 ,0)
  31902    I DT="" D  NOW^%DTC  S DT=X
  31903   "RTN","CHM IS012",229 ,0)
  31904    S CHSTDT= $E(DT,1,3) _"1001"
  31905   "RTN","CHM IS012",230 ,0)
  31906    S TEST=$E (DT,2,3)-1  I $L(TEST )<2 S TEST ="0"_TEST
  31907   "RTN","CHM IS012",231 ,0)
  31908    I +$E(DT, 4,5)<10 S  CHY=$E(DT, 2,5)-1 S C HSTDT=$E(D T,1)_TEST_ "1001"
  31909   "RTN","CHM IS012",232 ,0)
  31910    S CHSTDT= $$FMADD^XL FDT(CHSTDT ,-180,0,0, 0)
  31911   "RTN","CHM IS012",233 ,0)
  31912    S CHJULDT =$E($$FMJU L^CHTFLIB( CHSTDT),3, 5)
  31913   "RTN","CHM IS012",234 ,0)
  31914    S CHYR="2 0"_$E($$FM JUL^CHTFLI B(CHSTDT), 1,2)
  31915   "RTN","CHM IS012",235 ,0)
  31916    S PDI=CHY R_CHJULDT_ "00000000"
  31917   "RTN","CHM IS012",236 ,0)
  31918   PDICT1 S P DI=$O(^CHM IMG(PDI))  Q:'PDI
  31919   "RTN","CHM IS012",237 ,0)
  31920    G:$P($G(^ CHMIMG(PDI ,0)),"^",6 )'=4 PDICT 1  ;CFS 02 /05/2019 D efect 9192 38
  31921   "RTN","CHM IS012",238 ,0)
  31922    S CHPDITY P=$E(PDI,8 ,9) G:CHPD ITYP="" PD ICT1
  31923   "RTN","CHM IS012",239 ,0)
  31924    I '$D(PDI CT(CHPDITY P)) G PDIC T1
  31925   "RTN","CHM IS012",240 ,0)
  31926   TEST S REC =$P($G(^CH MIMG(PDI,0 )),"^",5)   ;CFS 02/0 5/2019 Def ect 919238
  31927   "RTN","CHM IS012",241 ,0)
  31928    I REC'=""  D
  31929   "RTN","CHM IS012",242 ,0)
  31930    .S X=$P(R EC,"^"),DT 1=+X\1 D H ^%DTC S X= +%H,WEEK1= (X-3)\7,MO 1=$E(DT1,1 ,5)
  31931   "RTN","CHM IS012",243 ,0)
  31932    .S YR1=$E (DT1,1,3), X=+$E(DT1, 4,5),QTR1= YR1_$S(X<4 :1,X<7:2,X <10:3,1:4)
  31933   "RTN","CHM IS012",244 ,0)
  31934    .S YR1=YR 1+$S(X<10: 0,1:1)
  31935   "RTN","CHM IS012",245 ,0)
  31936    .S:DT=DT1  $P(Z,"^", 4)=$P(Z,"^ ",4)+CHCOU NT
  31937   "RTN","CHM IS012",246 ,0)
  31938    .S:WEEK=W EEK1 $P(Z, "^",5)=$P( Z,"^",5)+C HCOUNT
  31939   "RTN","CHM IS012",247 ,0)
  31940    .S:MO=MO1  $P(Z,"^", 6)=$P(Z,"^ ",6)+CHCOU NT
  31941   "RTN","CHM IS012",248 ,0)
  31942    .S:QTR=QT R1 $P(Z,"^ ",7)=$P(Z, "^",7)+CHC OUNT
  31943   "RTN","CHM IS012",249 ,0)
  31944    .S:YR=YR1  $P(Z,"^", 8)=$P(Z,"^ ",8)+CHCOU NT
  31945   "RTN","CHM IS012",250 ,0)
  31946    .S:$D(CHF G) $P(Z,"^ ",10)=CN
  31947   "RTN","CHM IS012",251 ,0)
  31948    .Q
  31949   "RTN","CHM IS012",252 ,0)
  31950    G PDICT1
  31951   "RTN","CHM IS021")
  31952   0^77^B1342 01726
  31953   "RTN","CHM IS021",1,0 )
  31954   CHMIS021 ; JEA/DEN;CH AMPVA SYST EM STATUS  DISPLAY;02 /09/96  12 :51 PM
  31955   "RTN","CHM IS021",2,0 )
  31956    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  31957   "RTN","CHM IS021",3,0 )
  31958    ;;Called  by ^CHMIS0 21, ^CHMIS 022, ^CHMI S023
  31959   "RTN","CHM IS021",4,0 )
  31960    ;;Calls ^ CHMIS021,  ^CHMIS023
  31961   "RTN","CHM IS021",5,0 )
  31962    ;;
  31963   "RTN","CHM IS021",6,0 )
  31964    ;YJK 2/8/ 2010 - DEV 007247-03  Vista Menu  shows the  bottom di splays fro m CHV Moni tor data w hen Quit f rom the ap plication.
  31965   "RTN","CHM IS021",7,0 )
  31966    ;JSG2 10/ 13/2017 -  CPE005-023  Add in ED I-RO infor mation
  31967   "RTN","CHM IS021",8,0 )
  31968   ZSET S:'$D (DUZ) DUZ= 1,DUZ(0)=" " I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  31969   "RTN","CHM IS021",9,0 )
  31970    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  31971   "RTN","CHM IS021",10, 0)
  31972    I '$D(IOZ ) S %IS="N ",IOP=$I D  ^%ZIS K I OP S IOZ=I O,IOZL=IOS L,IOZW=IOM ,IOZF=IOF, IOZT=IOST, IOZN=ION,I OZS=IOS
  31973   "RTN","CHM IS021",11, 0)
  31974   ZNAM ;
  31975   "RTN","CHM IS021",12, 0)
  31976    S LASTMIN ="",THISMI N="",SCREE N=0,SCNMAX =11,MORE=6 ,CHDUZ=DUZ
  31977   "RTN","CHM IS021",13, 0)
  31978   EN1 ;D ^CH MGSET
  31979   "RTN","CHM IS021",14, 0)
  31980    D ^CHMFSE T
  31981   "RTN","CHM IS021",15, 0)
  31982   EN2 D TOP, BOTTOM K P RIOR,CHANG E
  31983   "RTN","CHM IS021",16, 0)
  31984   EN3 D DISP
  31985   "RTN","CHM IS021",17, 0)
  31986    ; CPE005- 023 MAKE R OOM FOR ED I-RO
  31987   "RTN","CHM IS021",18, 0)
  31988    ; EN4 S D Y=20,DX=1, $Y=DY,$X=D X X XY W @ CHEEL X XY  R "<>",X: 30 G EN3:' $T
  31989   "RTN","CHM IS021",19, 0)
  31990   EN4 S DY=2 1,DX=1,$Y= DY,$X=DX X  XY W @CHE EL X XY R  "<>",X:30  G EN3:'$T
  31991   "RTN","CHM IS021",20, 0)
  31992    G END:$E( X)="Q",END :$E(X)="q" ,EN1:$E(X) ="Z",EN1:$ E(X)="z"
  31993   "RTN","CHM IS021",21, 0)
  31994    I $E(X)=" M"!($E(X)= "m") D  D  BOTTOM G E N4
  31995   "RTN","CHM IS021",22, 0)
  31996    .S MORE=M ORE+12 S:M ORE>LASTNU M MORE=5 Q
  31997   "RTN","CHM IS021",23, 0)
  31998    I $E(X)=" B" D  G:'$ D(LASTOVER ) EN3  S L ASTOVER=$O (^CHMSTAT( LASTOVER))  K:'LASTOV ER LASTOVE R G EN2
  31999   "RTN","CHM IS021",24, 0)
  32000    .I $L(X)= 1 D NOW^%D TC S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10)),X2 =-1 D C^%D TC S LASTO VER=X-.000 1 Q
  32001   "RTN","CHM IS021",25, 0)
  32002    .I X?1"B" 1.3N1"@"1. 2N D  Q
  32003   "RTN","CHM IS021",26, 0)
  32004    ..S X2="- "_+$P($P(X ,"B",2),"@ ",1) S CHL D=X D NOW^ %DTC
  32005   "RTN","CHM IS021",27, 0)
  32006    ..S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10))
  32007   "RTN","CHM IS021",28, 0)
  32008    ..I +$E($ P(CHLD,"@" ,2))>24 S  $P(CHLD,"@ ",2)="00"
  32009   "RTN","CHM IS021",29, 0)
  32010    ..S $P(X1 ,".",2)=$P (CHLD,"@", 2) D C^%DT C S LASTOV ER=X-.001
  32011   "RTN","CHM IS021",30, 0)
  32012    .I X?1"B" 1.3N D  Q
  32013   "RTN","CHM IS021",31, 0)
  32014    ..S X2="- "_+$P(X,"B ",2) S CHL D=X D NOW^ %DTC
  32015   "RTN","CHM IS021",32, 0)
  32016    ..S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10))
  32017   "RTN","CHM IS021",33, 0)
  32018    ..D C^%DT C S LASTOV ER=X-.001
  32019   "RTN","CHM IS021",34, 0)
  32020    .K %DT S  %DT="PT",X =$P(X,"B", 2) D ^%DT  D  Q
  32021   "RTN","CHM IS021",35, 0)
  32022    ..I Y=-1  S DX=3,$Y= DY,$X=DX X  XY W @CHE OL D  Q
  32023   "RTN","CHM IS021",36, 0)
  32024    ...X XY W  @CHBON,"I NVALID BAC K DATE FOR MAT",@CHBO FF R X:5
  32025   "RTN","CHM IS021",37, 0)
  32026    ...S:$D(L ASTOVER) L ASTOVER=LA STOVER-.00 1
  32027   "RTN","CHM IS021",38, 0)
  32028    ..S LASTO VER=Y-.001  Q
  32029   "RTN","CHM IS021",39, 0)
  32030    I $E(X)=" F" D  G:'$ D(LASTOVER ) EN2  S L ASTOVER=$O (^CHMSTAT( LASTOVER))  K:'LASTOV ER LASTOVE R G EN2
  32031   "RTN","CHM IS021",40, 0)
  32032    .I $L(X)= 1 Q:'$D(LA STOVER)  D  NOW^%DTC  S CHLD=% S  X1=$S($D( LASTOVER): +$E(LASTOV ER,1,10),1 :+$E(%,1,1 0)),X2=1 D  C^%DTC K: X'<CHLD LA STOVER Q:' $D(LASTOVE R)  S LAST OVER=X-.00 01 Q
  32033   "RTN","CHM IS021",41, 0)
  32034    .I X?1"F" 1.3N1"@"1. 2N D  Q
  32035   "RTN","CHM IS021",42, 0)
  32036    ..S X2=+$ P($P(X,"F" ,2),"@",1)  S CHLD=X  D NOW^%DTC  S CHLD2=%
  32037   "RTN","CHM IS021",43, 0)
  32038    ..S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10))
  32039   "RTN","CHM IS021",44, 0)
  32040    ..I +$E($ P(CHLD,"@" ,2))>24 S  $P(CHLD,"@ ",2)="00"
  32041   "RTN","CHM IS021",45, 0)
  32042    ..S $P(X1 ,".",2)=$P (CHLD,"@", 2) D C^%DT C
  32043   "RTN","CHM IS021",46, 0)
  32044    ..I X'<CH LD2 K LAST OVER Q
  32045   "RTN","CHM IS021",47, 0)
  32046    ..S LASTO VER=X-.001
  32047   "RTN","CHM IS021",48, 0)
  32048    .I X?1"F" 1.3N D  Q
  32049   "RTN","CHM IS021",49, 0)
  32050    ..S X2=+$ P(X,"F",2)  S CHLD=X  D NOW^%DTC  S CHLD2=%
  32051   "RTN","CHM IS021",50, 0)
  32052    ..S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10))
  32053   "RTN","CHM IS021",51, 0)
  32054    ..D C^%DT C
  32055   "RTN","CHM IS021",52, 0)
  32056    ..I X'<CH LD2 K LAST OVER Q
  32057   "RTN","CHM IS021",53, 0)
  32058    ..S LASTO VER=X-.001
  32059   "RTN","CHM IS021",54, 0)
  32060    .K %DT S  %DT="PT",X =$P(X,"F", 2) D ^%DT  D  Q
  32061   "RTN","CHM IS021",55, 0)
  32062    ..I Y=-1  S DX=3,$Y= DY,$X=DX X  XY W @CHE OL D  Q
  32063   "RTN","CHM IS021",56, 0)
  32064    ...X XY W  @CHBON,"I NVALID BAC K DATE FOR MAT",@CHBO FF R X:5
  32065   "RTN","CHM IS021",57, 0)
  32066    ...S:$D(L ASTOVER) L ASTOVER=LA STOVER-.00 1
  32067   "RTN","CHM IS021",58, 0)
  32068    ..S CHLD= Y D NOW^%D TC I Y'<%  K LASTOVER  Q
  32069   "RTN","CHM IS021",59, 0)
  32070    ..S LASTO VER=CHLD-. 001 Q
  32071   "RTN","CHM IS021",60, 0)
  32072    I $E(X)=" H"!($E(X)= "h") G:'$D (LASTOVER)  EN3 K LAS TOVER G EN 2
  32073   "RTN","CHM IS021",61, 0)
  32074    I $E(X)=" " G EN3
  32075   "RTN","CHM IS021",62, 0)
  32076    I $E(X)=" ?" S DX=3, $Y=DY,$X=D X X XY W @ CHEOL D  G  EN2
  32077   "RTN","CHM IS021",63, 0)
  32078    .D BOXF^C HSC1(5,5,7 5,21),CLRB OXI^CHSC1( 5,5,75,21, XY,"","")
  32079   "RTN","CHM IS021",64, 0)
  32080    .S DY=6,D X=6,$Y=DY, $X=DX X XY  W "             Plea se Select  From The L ist Below. ..or..."
  32081   "RTN","CHM IS021",65, 0)
  32082    .S DY=8 X  XY W "                     Ente r: 'M' for  More Opti ons 'Q' to  Quit."
  32083   "RTN","CHM IS021",66, 0)
  32084    .S DY=10  X XY W "   To See Pas t Data Ent er: B, B<n um>, B<num >@<time> ( 2 digit)"
  32085   "RTN","CHM IS021",67, 0)
  32086    .S DY=11  X XY W "                         or: B<file man date f ormat>"
  32087   "RTN","CHM IS021",68, 0)
  32088    .S DY=13  X XY W "      To Go F orward Ent er: F, F<n um>, F<num >@<time> ( 2 digit)"
  32089   "RTN","CHM IS021",69, 0)
  32090    .S DY=14  X XY W "                         or: B<file man date f ormat>"
  32091   "RTN","CHM IS021",70, 0)
  32092    .S DY=16  X XY W " R eturn to C urrent Ent er: H"
  32093   "RTN","CHM IS021",71, 0)
  32094    .S DY=18  X XY W "                      Pr ess any ke y to conti nue..." R  X:20
  32095   "RTN","CHM IS021",72, 0)
  32096    I (X'=+X) !(+X>LASTN UM)!(+X<1) !(X=5)!(X= 6) S DX=3, $Y=DY,$X=D X X XY W @ CHEOL D  G  EN4
  32097   "RTN","CHM IS021",73, 0)
  32098    .S DX=3,$ Y=DY,$X=DX  X XY W @C HEOL X XY  W @CHBON,"  PLEASE SE LECT FROM  THE OPTION S BELOW.   OR ENTER ' ?' FOR ADD ITIONAL OP TIONS",@CH BOFF R X:5  S SCREEN= 0
  32099   "RTN","CHM IS021",74, 0)
  32100    S SNO=+X
  32101   "RTN","CHM IS021",75, 0)
  32102    G ^CHMIS0 21:X=1
  32103   "RTN","CHM IS021",76, 0)
  32104    I X=2 S S CREEN=1 D: '$D(ITEM(S CREEN))  G  EN1
  32105   "RTN","CHM IS021",77, 0)
  32106    .S DX=3,$ Y=DY,$X=DX  X XY W @C HEOL X XY  W @CHBON," CURRENTLY  THERE ARE  NOT ENOUGH  ITEMS FOR  THIS OPTI ON",@CHBOF F R X:5 S  SCREEN=0
  32107   "RTN","CHM IS021",78, 0)
  32108    I X=3 S S CREEN=2 D: '$D(ITEM(S CREEN))  G  EN1
  32109   "RTN","CHM IS021",79, 0)
  32110    .S DX=3,$ Y=DY,$X=DX  X XY W @C HEOL X XY  W @CHBON," CURRENTLY  THERE ARE  NOT ENOUGH  ITEMS FOR  THIS OPTI ON",@CHBOF F R X:5 S  SCREEN=0
  32111   "RTN","CHM IS021",80, 0)
  32112    I X=4 S S CREEN=3 D   G EN1
  32113   "RTN","CHM IS021",81, 0)
  32114    .I '$D(CH DUZ) D WHO RU Q
  32115   "RTN","CHM IS021",82, 0)
  32116    .I CHDUZ= 1 D WHORU  Q
  32117   "RTN","CHM IS021",83, 0)
  32118    .I '$D(^C HMDIC(7410 02.21,CHDU Z,101,0))  D NOUSER Q
  32119   "RTN","CHM IS021",84, 0)
  32120    G ^CHMIS0 23:X'>LAST NUM
  32121   "RTN","CHM IS021",85, 0)
  32122    G EN3
  32123   "RTN","CHM IS021",86, 0)
  32124   END K A,SC REEN,ITEM, LASTOVER,O RDER
  32125   "RTN","CHM IS021",87, 0)
  32126    ;U $I X ^ %ZOSF("EON ") W @CHMA RESE,@CHAL LOFF S DY= 24,DX=1,$Y =DY,$X=DX  X XY Q      ;YJK 2/8/ 2010 - DEV 007247-03
  32127   "RTN","CHM IS021",88, 0)
  32128    U $I X ^% ZOSF("EON" ) W @CHMAR ESE,@CHALL OFF W # Q                                                                     ;YJK 2/8/ 2010 - DEV 007247-03
  32129   "RTN","CHM IS021",89, 0)
  32130   WHORU S DT M=5,DBM=19 ,DX=1 X CH MAR F DY=5 :1:19 S $Y =DY,$X=DX  X XY W @CH EOL
  32131   "RTN","CHM IS021",90, 0)
  32132    S DY=6 X  XY
  32133   "RTN","CHM IS021",91, 0)
  32134    W "Before  you can d isplay you r personal  view of t he queues  you must"
  32135   "RTN","CHM IS021",92, 0)
  32136    W !,"firs t identify  yourself. ",!!
  32137   "RTN","CHM IS021",93, 0)
  32138    S DIC=200 ,DIC(0)="A EQM",DIC(" A")="Pleas e enter yo ur name: E XIT// " D  ^DIC
  32139   "RTN","CHM IS021",94, 0)
  32140    I Y=-1 S  SCREEN=1 Q
  32141   "RTN","CHM IS021",95, 0)
  32142    S CHDUZ=+ Y
  32143   "RTN","CHM IS021",96, 0)
  32144    I '$D(^CH MDIC(74100 2.21,CHDUZ ,101)) D   Q
  32145   "RTN","CHM IS021",97, 0)
  32146    .W !!,"Yo u do not h ave a pers onal view  set up ...  Please cr eate one"
  32147   "RTN","CHM IS021",98, 0)
  32148    .W !,"thr ough your  DHCP menu  option bef ore select ing this o ption"
  32149   "RTN","CHM IS021",99, 0)
  32150    .R X:5 S  SCREEN=0
  32151   "RTN","CHM IS021",100 ,0)
  32152    Q
  32153   "RTN","CHM IS021",101 ,0)
  32154   NOUSER S D TM=5,DBM=1 9,DX=1,$Y= DY,$X=DX X  CHMAR F D Y=5:1:19 S  $Y=DY,$X= DX X XY W  @CHEOL
  32155   "RTN","CHM IS021",102 ,0)
  32156    S DY=6,$Y =DY,$X=DX  X XY
  32157   "RTN","CHM IS021",103 ,0)
  32158    W !!,"You  do not ha ve a perso nal view s et up ...  Please cre ate one"
  32159   "RTN","CHM IS021",104 ,0)
  32160    W !,"thro ugh your D HCP menu o ption befo re selecti ng this op tion"
  32161   "RTN","CHM IS021",105 ,0)
  32162    R X:5 S S CREEN=0
  32163   "RTN","CHM IS021",106 ,0)
  32164    Q
  32165   "RTN","CHM IS021",107 ,0)
  32166   TOP W @IOF ,@CHMARESE  K BL,CHL  S $P(BL,"  ",81)="",$ P(CHL,"-", 81)=""
  32167   "RTN","CHM IS021",108 ,0)
  32168    S UPLINE= "W @CHREVO N,"" "",@C HREVOFF" W  @CHREVON, @CHBON S D X=1,DY=1,$ Y=DY,$X=DX
  32169   "RTN","CHM IS021",109 ,0)
  32170    W $C(27), "+0" S ZPL INE="W $C( 27,79,97)"
  32171   "RTN","CHM IS021",110 ,0)
  32172    X XY W BL  S DX=21,$ Y=DY,$X=DX  X XY W "C HAMPVA PAY MENT CENTE R SYSTEM S TATUS V2.0 "
  32173   "RTN","CHM IS021",111 ,0)
  32174    W @CHBOFF  S DY=2,DX =34,$Y=DY, $X=DX X XY ,UPLINE S  DX=51,$Y=D Y,$X=DX X  XY W @CHUL ON
  32175   "RTN","CHM IS021",112 ,0)
  32176    W "CUMULA TIVE PERIO DS:",@CHUL OFF,@CHREV OFF S DX=1 0,$Y=DY,$X =DX X XY,U PLINE
  32177   "RTN","CHM IS021",113 ,0)
  32178    S DY=3,DX =1,$Y=DY,$ X=DX X XY  W @CHREVON ,BL,@CHREV OFF
  32179   "RTN","CHM IS021",114 ,0)
  32180    S DX=1,$Y =DY,$X=DX  X XY W @CH REVON,"QUE " S DX=12  X XY W "Cu rrent" S D X=24
  32181   "RTN","CHM IS021",115 ,0)
  32182    X XY W "I n" S DX=30 ,$Y=DY,$X= DX X XY W  "Out" S DX =39,$Y=DY, $X=DX X XY  W "Day"
  32183   "RTN","CHM IS021",116 ,0)
  32184    S DX=47,$ Y=DY,$X=DX  X XY W "W eek" S DX= 56,$Y=DY,$ X=DX
  32185   "RTN","CHM IS021",117 ,0)
  32186    X XY W "M onth" S DX =64,$Y=DY, $X=DX X XY  W "Quarte r" S DX=77 ,$Y=DY,$X= DX X XY W  "Year",@CH REVOFF
  32187   "RTN","CHM IS021",118 ,0)
  32188    S X=$S(SC REEN=3:"PE RSONAL VIE W",1:"WORK FLOW "_(SC REEN+1))
  32189   "RTN","CHM IS021",119 ,0)
  32190    S DY=1,DX =67,$Y=DY, $X=DX X XY  W @CHREVO N,@CHBON,X ,@CHREVOFF ,@CHBOFF
  32191   "RTN","CHM IS021",120 ,0)
  32192    ; CPE005- 023 EXTEND  VERTICAL  BARS 1 MOR E ROW FOR  EDI-RO
  32193   "RTN","CHM IS021",121 ,0)
  32194    ; F DX=10 ,34 F DY=4 :1:19 S $Y =DY,$X=DX  X XY,UPLIN E
  32195   "RTN","CHM IS021",122 ,0)
  32196    F DX=10,3 4 F DY=4:1 :20 S $Y=D Y,$X=DX X  XY,UPLINE
  32197   "RTN","CHM IS021",123 ,0)
  32198    Q
  32199   "RTN","CHM IS021",124 ,0)
  32200   DISP S LAS TTIME="",L ASTTIME=$O (^CHMSTAT( LASTTIME), -1) K A Q: 'LASTTIME
  32201   "RTN","CHM IS021",125 ,0)
  32202    I $D(LAST OVER) S (X ,LASTTIME) =LASTOVER  D H^%DTC
  32203   "RTN","CHM IS021",126 ,0)
  32204    S X=$S($D (LASTOVER) :%T,1:$P($ H,",",2)), H=X\3600,M =X#3600\60 ,NAM="" S: M<10 M=0_M
  32205   "RTN","CHM IS021",127 ,0)
  32206    S MERID=$ S(H<12:"AM ",1:"PM"), H=H#12 S:H =0 H=12 S: H<10 H=" " _H
  32207   "RTN","CHM IS021",128 ,0)
  32208    S TIME=H_ ":00 - "_H _":"_M_" " _MERID D N OW^%DTC S: $D(LASTOVE R) X=$P(LA STOVER,"." ,1) D DTPR T S DISPDT =Y
  32209   "RTN","CHM IS021",129 ,0)
  32210    S NOWTIME =+$E(%,1,1 0),DISPTIM E=TIME,DY= 2,DX=17,$Y =DY,$X=DX  X XY W @CH BON,DISPTI ME
  32211   "RTN","CHM IS021",130 ,0)
  32212    S:$D(LAST OVER) NOWT IME=LASTOV ER
  32213   "RTN","CHM IS021",131 ,0)
  32214    S THISMIN =+$E($P(%, ".",2),3,4 ) S DX=36, $Y=DY,$X=D X X XY W D ISPDT,@CHB OFF S DY=3
  32215   "RTN","CHM IS021",132 ,0)
  32216    G:SCREEN= 3 D4
  32217   "RTN","CHM IS021",133 ,0)
  32218    ; CPE005- 023 Add ED I-RO to ex cepted nam es
  32219   "RTN","CHM IS021",134 ,0)
  32220    ; D2 S NA M=$O(^CHMS TAT(LASTTI ME,NAM)) G  D3:NAM="" ,D2:NAM="C HMPAY("!(N AM="IMAGE( ")!(NAM="M ANUAL(")!( NAM="DIST( ")!(NAM="C HMEDIL(")! (NAM="EDI/ OCR")
  32221   "RTN","CHM IS021",135 ,0)
  32222   D2 S NAM=$ O(^CHMSTAT (LASTTIME, NAM)) G D3 :NAM="",D2 :NAM="CHMP AY("!(NAM= "IMAGE(")! (NAM="MANU AL(")!(NAM ="DIST(")! (NAM="CHME DIL(")!(NA M="EDI/OCR ")!(NAM="E DI-REOPEN" )
  32223   "RTN","CHM IS021",136 ,0)
  32224    G:'$D(^CH MDIC(74100 2.17,1,101 ,"B",NAM))  D2
  32225   "RTN","CHM IS021",137 ,0)
  32226    S ORDER=$ O(^CHMDIC( 741002.17, 1,101,"B", NAM,0)) G: 'ORDER D2
  32227   "RTN","CHM IS021",138 ,0)
  32228    G:'$D(^CH MDIC(74100 2.17,1,101 ,ORDER,0))  D2 S ORDE R=$P(^(0), "^",7)
  32229   "RTN","CHM IS021",139 ,0)
  32230    G:ORDER=" " D2 S A(O RDER)=^CHM STAT(LASTT IME,NAM)
  32231   "RTN","CHM IS021",140 ,0)
  32232    S ITEM(0) =0
  32233   "RTN","CHM IS021",141 ,0)
  32234    S I=0,ITE MCT=0 F  S  I=$O(A(I) ) Q:'I  S  ITEMCT=ITE MCT+1 D
  32235   "RTN","CHM IS021",142 ,0)
  32236    .I ITEMCT #SCNMAX=0  S ITEM(ITE MCT\SCNMAX )=I
  32237   "RTN","CHM IS021",143 ,0)
  32238    G D2
  32239   "RTN","CHM IS021",144 ,0)
  32240   D3 S ORDER =ITEM(SCRE EN) F I=1: 1:SCNMAX D   Q:'ORDER
  32241   "RTN","CHM IS021",145 ,0)
  32242    .S ORDER= $O(A(ORDER )) Q:'ORDE R  S Z1=A( ORDER),DY= DY+1 D  Q
  32243   "RTN","CHM IS021",146 ,0)
  32244    ..S NAM=$ P(Z1,"^",9 )
  32245   "RTN","CHM IS021",147 ,0)
  32246    ..S CHANG E(NAM)=Z1  S:'$D(PRIO R(NAM)) PR IOR(NAM)=" "
  32247   "RTN","CHM IS021",148 ,0)
  32248    ..I PRIOR (NAM)'=CHA NGE(NAM) D  COLUMNS S  PRIOR(NAM )=CHANGE(N AM)
  32249   "RTN","CHM IS021",149 ,0)
  32250    I LASTMIN '=0,THISMI N=0 S L=DY -2 F DY=5: 1:L S DX=2 1,$Y=DY,$X =DX X XY W  "     " D
  32251   "RTN","CHM IS021",150 ,0)
  32252    .X XY W $ J("0",5) S  DX=28,$Y= DY,$X=DX X  XY W "      " X XY W  $J("0",5)
  32253   "RTN","CHM IS021",151 ,0)
  32254    S NAM="CH MPAY(",Z1= $S($D(^CHM STAT(LASTT IME,NAM)): ^(NAM),1:" ")
  32255   "RTN","CHM IS021",152 ,0)
  32256    S CHANGE( NAM)=Z1 S: '$D(PRIOR( NAM)) PRIO R(NAM)=""
  32257   "RTN","CHM IS021",153 ,0)
  32258    I PRIOR(N AM)'=CHANG E(NAM) S D Y=15 W @CH BON D COLU MNS S PRIO R(NAM)=CHA NGE(NAM) W  @CHBOFF
  32259   "RTN","CHM IS021",154 ,0)
  32260    I LASTMIN '=0,THISMI N=0 S DX=2 1,$Y=DY,$X =DX X XY W  "     " X  XY W $J(" 0",5)
  32261   "RTN","CHM IS021",155 ,0)
  32262    S NAM="ED I/OCR",Z1= $S($D(^CHM STAT(LASTT IME,NAM)): ^(NAM),1:" ")
  32263   "RTN","CHM IS021",156 ,0)
  32264    S CHANGE( NAM)=Z1 S: '$D(PRIOR( NAM)) PRIO R(NAM)=""
  32265   "RTN","CHM IS021",157 ,0)
  32266    I PRIOR(N AM)'=CHANG E(NAM) S D Y=16 W @CH BON D COLU MNS S PRIO R(NAM)=CHA NGE(NAM) W  @CHBOFF
  32267   "RTN","CHM IS021",158 ,0)
  32268    I LASTMIN '=0,THISMI N=0 S DX=2 1,$Y=DY,$X =DX X XY W  "     " X  XY W $J(" 0",5)
  32269   "RTN","CHM IS021",159 ,0)
  32270     ; CPE005 -023 Add i n EDI-RO h andling
  32271   "RTN","CHM IS021",160 ,0)
  32272    S NAM="ED I-REOPEN", Z1=$S($D(^ CHMSTAT(LA STTIME,NAM )):^(NAM), 1:"")
  32273   "RTN","CHM IS021",161 ,0)
  32274    S CHANGE( NAM)=Z1 S: '$D(PRIOR( NAM)) PRIO R(NAM)=""
  32275   "RTN","CHM IS021",162 ,0)
  32276    I PRIOR(N AM)'=CHANG E(NAM) S D Y=17 W @CH BON D COLU MNS S PRIO R(NAM)=CHA NGE(NAM) W  @CHBOFF
  32277   "RTN","CHM IS021",163 ,0)
  32278    I LASTMIN '=0,THISMI N=0 S DX=2 1,$Y=DY,$X =DX X XY W  "     " X  XY W $J(" 0",5)
  32279   "RTN","CHM IS021",164 ,0)
  32280    ;
  32281   "RTN","CHM IS021",165 ,0)
  32282    S NAM="IM AGE(",Z1=$ S($D(^CHMS TAT(LASTTI ME,NAM)):^ (NAM),1:"" )
  32283   "RTN","CHM IS021",166 ,0)
  32284    S CHANGE( NAM)=Z1 S: '$D(PRIOR( NAM)) PRIO R(NAM)=""
  32285   "RTN","CHM IS021",167 ,0)
  32286     ; CPE005 -023 MAKE  ROOM FOR E DI-RO
  32287   "RTN","CHM IS021",168 ,0)
  32288    ; I PRIOR (NAM)'=CHA NGE(NAM) S  DY=17 W @ CHBON D CO LUMNS S PR IOR(NAM)=C HANGE(NAM)  W @CHBOFF
  32289   "RTN","CHM IS021",169 ,0)
  32290    I PRIOR(N AM)'=CHANG E(NAM) S D Y=18 W @CH BON D COLU MNS S PRIO R(NAM)=CHA NGE(NAM) W  @CHBOFF
  32291   "RTN","CHM IS021",170 ,0)
  32292    I LASTMIN '=0,THISMI N=0 S DX=2 1,$Y=DY,$X =DX X XY W  "     " X  XY W $J(" 0",5)
  32293   "RTN","CHM IS021",171 ,0)
  32294    S NAM="MA NUAL(",Z1= $S($D(^CHM STAT(LASTT IME,NAM)): ^(NAM),1:" ")
  32295   "RTN","CHM IS021",172 ,0)
  32296    S CHANGE( NAM)=Z1 S: '$D(PRIOR( NAM)) PRIO R(NAM)=""
  32297   "RTN","CHM IS021",173 ,0)
  32298     ; CPE005 -023 MAKE  ROOM FOR E DI-RO
  32299   "RTN","CHM IS021",174 ,0)
  32300    ; I PRIOR (NAM)'=CHA NGE(NAM) S  DY=18 W @ CHBON D CO LUMNS S PR IOR(NAM)=C HANGE(NAM)  W @CHBOFF
  32301   "RTN","CHM IS021",175 ,0)
  32302    I PRIOR(N AM)'=CHANG E(NAM) S D Y=19 W @CH BON D COLU MNS S PRIO R(NAM)=CHA NGE(NAM) W  @CHBOFF
  32303   "RTN","CHM IS021",176 ,0)
  32304    I LASTMIN '=0,THISMI N=0 S DX=2 1,$Y=DY,$X =DX X XY W  "     " X  XY W $J(" 0",5)
  32305   "RTN","CHM IS021",177 ,0)
  32306    S NAM="CH MEDIL(",Z1 =$S($D(^CH MSTAT(LAST TIME,NAM)) :^(NAM),1: "")
  32307   "RTN","CHM IS021",178 ,0)
  32308    S CHANGE( NAM)=Z1 S: '$D(PRIOR( NAM)) PRIO R(NAM)=""
  32309   "RTN","CHM IS021",179 ,0)
  32310    ; CPE005- 023 MAKE R OOM FOR ED I-RO
  32311   "RTN","CHM IS021",180 ,0)
  32312    ; I PRIOR (NAM)'=CHA NGE(NAM) S  DY=19 W @ CHBON D CO LUMNS S PR IOR(NAM)=C HANGE(NAM)  W @CHBOFF
  32313   "RTN","CHM IS021",181 ,0)
  32314    I PRIOR(N AM)'=CHANG E(NAM) S D Y=20 W @CH BON D COLU MNS S PRIO R(NAM)=CHA NGE(NAM) W  @CHBOFF
  32315   "RTN","CHM IS021",182 ,0)
  32316    I LASTMIN '=0,THISMI N=0 S DX=2 1,$Y=DY,$X =DX X XY W  "     " X  XY W $J(" 0",5)
  32317   "RTN","CHM IS021",183 ,0)
  32318    S LASTMIN =THISMIN W  @CHBOFF Q
  32319   "RTN","CHM IS021",184 ,0)
  32320   D4 S ORDER =0 F  S OR DER=$O(^CH MDIC(74100 2.21,CHDUZ ,101,ORDER )) Q:'ORDE R  D
  32321   "RTN","CHM IS021",185 ,0)
  32322    .Q:'$D(^C HMDIC(7410 02.21,CHDU Z,101,ORDE R,0))  S N AM=^(0)
  32323   "RTN","CHM IS021",186 ,0)
  32324    .Q:'$D(^C HMDIC(7410 02.36,NAM, 0))  S NAM =$P(^(0)," ^",5)
  32325   "RTN","CHM IS021",187 ,0)
  32326    .Q:'$D(^C HMSTAT(LAS TTIME,NAM) )  S A(ORD ER)=^CHMST AT(LASTTIM E,NAM)
  32327   "RTN","CHM IS021",188 ,0)
  32328    S ORDER=0  F I=1:1:1 5 D  Q:'OR DER
  32329   "RTN","CHM IS021",189 ,0)
  32330    .S ORDER= $O(A(ORDER )) Q:'ORDE R  S Z1=A( ORDER),DY= DY+1 D  Q
  32331   "RTN","CHM IS021",190 ,0)
  32332    ..S NAM=$ P(Z1,"^",9 )
  32333   "RTN","CHM IS021",191 ,0)
  32334    ..S CHANG E(NAM)=Z1  S:'$D(PRIO R(NAM)) PR IOR(NAM)=" "
  32335   "RTN","CHM IS021",192 ,0)
  32336    ..I PRIOR (NAM)'=CHA NGE(NAM) D   D COLUMN S W @CHBOF F S PRIOR( NAM)=CHANG E(NAM)
  32337   "RTN","CHM IS021",193 ,0)
  32338    ...S X=$P (Z1,"^",9)
  32339   "RTN","CHM IS021",194 ,0)
  32340    ...W:X="C LAIMS"!(X= "EDI/OCR I N IP")!(X= "IMAGES")! (X="MANUAL ")!(X="EDI  LINE") @C HBON
  32341   "RTN","CHM IS021",195 ,0)
  32342    I LASTMIN '=0,THISMI N=0 S L=DY -2 F DY=5: 1:L S DX=2 1,$Y=DY,$X =DX X XY W  "     " D
  32343   "RTN","CHM IS021",196 ,0)
  32344    .X XY W $ J("0",5) S  DX=28,$Y= DY,$X=DX X  XY W "      " X XY W  $J("0",5)
  32345   "RTN","CHM IS021",197 ,0)
  32346    Q
  32347   "RTN","CHM IS021",198 ,0)
  32348   COLUMNS S  DX=1,$Y=DY ,$X=DX X X Y W $P(Z1, "^",9)
  32349   "RTN","CHM IS021",199 ,0)
  32350    ;CURRENT  COLUMN
  32351   "RTN","CHM IS021",200 ,0)
  32352    ;I NAM'=" CHMPAY("&( NAM'="CHMB AR(")&(NAM '="CLAIMS" )&(NAM'="C HMEDIL(")& (NAM'="CHM EDIQ(")&(N AM'="CHMBA R(")&(NAM' ="PRESCREE N") S DX=1 2,$Y=DY,$X =DX X XY W  "       "  X XY D  ; TLH 11/21/ 06 REMOVED  SINCE OCR  WAS NOT D ISPLAYING
  32353   "RTN","CHM IS021",201 ,0)
  32354    I NAM'="C HMPAY("&(N AM'="CHMBA R(")&(NAM' ="CLAIMS") &(NAM'="CH MEDIQ(")&( NAM'="CHMB AR(")&(NAM '="PRESCRE EN") S DX= 12,$Y=DY,$ X=DX X XY  W "        " X XY D   ;TLH 11/21 /06 MODIFI ED TO DISP LAY OCR &  CURRENT CO UNT ON CHV  SCREEN
  32355   "RTN","CHM IS021",202 ,0)
  32356    .W $J($FN ($P(Z1,"^" ,1),","),7 )
  32357   "RTN","CHM IS021",203 ,0)
  32358    ;IN
  32359   "RTN","CHM IS021",204 ,0)
  32360    I NAM'="C HMBAR(" I  NAM'="PRES CREEN" D  
  32361   "RTN","CHM IS021",205 ,0)
  32362    .S DX=21, $Y=DY,$X=D X X XY W "      " X X Y
  32363   "RTN","CHM IS021",206 ,0)
  32364    .W $S(NOW TIME'=LAST TIME:$J("0 ",5),1:$J( $FN($P(Z1, "^",2),"," ),5))
  32365   "RTN","CHM IS021",207 ,0)
  32366    ;OUT
  32367   "RTN","CHM IS021",208 ,0)
  32368    I NAM="CH MBAR("!(NA M="PRESCRE EN") S DX= 21,$Y=DY,$ X=DX X XY  W "     "
  32369   "RTN","CHM IS021",209 ,0)
  32370    I NAM'="C HMPAY("&(N AM'="CLAIM S")&(NAM'= "EDI LINE" ) S DX=28, $Y=DY,$X=D X X XY W "      " X X Y D  ;TLH  11/21/06 M ODIFIED TO  DISPLAY O CR & CURRE NT COUNT O N CHV SCRE EN
  32371   "RTN","CHM IS021",210 ,0)
  32372    .W $S(NOW TIME'=LAST TIME:$J("0 ",5),1:$J( $FN($P(Z1, "^",3),"," ),5))
  32373   "RTN","CHM IS021",211 ,0)
  32374    ;DAY
  32375   "RTN","CHM IS021",212 ,0)
  32376    S ZZ="       0"
  32377   "RTN","CHM IS021",213 ,0)
  32378    S:$E(NOWT IME,1,7)=$ E(LASTTIME ,1,7) ZZ=$ J($FN($P(Z 1,"^",4)," ,"),7)
  32379   "RTN","CHM IS021",214 ,0)
  32380    S DX=35,$ Y=DY,$X=DX  X XY W ZZ
  32381   "RTN","CHM IS021",215 ,0)
  32382    ;WEEK
  32383   "RTN","CHM IS021",216 ,0)
  32384    S X=+$E(L ASTTIME,1, 7) D H^%DT C S OLDWK= (%H-3)\7
  32385   "RTN","CHM IS021",217 ,0)
  32386    S X=+$E(N OWTIME,1,7 ) D H^%DTC  S NEWWK=( %H-3)\7
  32387   "RTN","CHM IS021",218 ,0)
  32388    S ZZ="       0"
  32389   "RTN","CHM IS021",219 ,0)
  32390    S:OLDWK=N EWWK ZZ=$J ($FN($P(Z1 ,"^",5),", "),7)
  32391   "RTN","CHM IS021",220 ,0)
  32392    S DX=44,$ Y=DY,$X=DX  X XY W ZZ
  32393   "RTN","CHM IS021",221 ,0)
  32394    ;MONTH
  32395   "RTN","CHM IS021",222 ,0)
  32396    S ZZ="         0"
  32397   "RTN","CHM IS021",223 ,0)
  32398    S:$E(NOWT IME,1,5)=$ E(LASTTIME ,1,5) ZZ=$ J($FN($P(Z 1,"^",6)," ,"),9)
  32399   "RTN","CHM IS021",224 ,0)
  32400    S DX=52,$ Y=DY,$X=DX  X XY W ZZ
  32401   "RTN","CHM IS021",225 ,0)
  32402    ;QUARTER
  32403   "RTN","CHM IS021",226 ,0)
  32404    S X1=+$E( LASTTIME,4 ,5),X2=+$E (NOWTIME,4 ,5)
  32405   "RTN","CHM IS021",227 ,0)
  32406    S OLDQTR= $S(X1<4:1, X1<7:2,X1< 10:3,1:4)
  32407   "RTN","CHM IS021",228 ,0)
  32408    S NEWQTR= $S(X2<4:1, X2<7:2,X2< 10:3,1:4)
  32409   "RTN","CHM IS021",229 ,0)
  32410    S ZZ="         0"
  32411   "RTN","CHM IS021",230 ,0)
  32412    S:OLDQTR= NEWQTR ZZ= $J($FN($P( Z1,"^",7), ","),9)
  32413   "RTN","CHM IS021",231 ,0)
  32414    S DX=62,$ Y=DY,$X=DX  X XY W ZZ
  32415   "RTN","CHM IS021",232 ,0)
  32416    ;YEAR
  32417   "RTN","CHM IS021",233 ,0)
  32418    S OLDYR=$ E(LASTTIME ,1,3),NEWY R=$E(NOWTI ME,1,3)
  32419   "RTN","CHM IS021",234 ,0)
  32420    S OLDYR=O LDYR+$S(X1 <10:0,1:1)
  32421   "RTN","CHM IS021",235 ,0)
  32422    S NEWYR=N EWYR+$S(X2 <10:0,1:1)
  32423   "RTN","CHM IS021",236 ,0)
  32424    S ZZ="         0"
  32425   "RTN","CHM IS021",237 ,0)
  32426    S:OLDYR=N EWYR ZZ=$J ($FN($P(Z1 ,"^",8),", "),9)
  32427   "RTN","CHM IS021",238 ,0)
  32428    S DX=72,$ Y=DY,$X=DX  X XY W ZZ
  32429   "RTN","CHM IS021",239 ,0)
  32430    Q
  32431   "RTN","CHM IS021",240 ,0)
  32432   SBRS S Y=" " U $I X ^ %ZOSF("EOF F")
  32433   "RTN","CHM IS021",241 ,0)
  32434    F I=1:1 R  *X:$S($D( DTIME):DTI ME,1:60) Q :(X=13)!(X =9)!(X=27)   S:X'=127  Y=Y_$C(X)  D:X=127   S:I=0 Y=""  W $C(X)
  32435   "RTN","CHM IS021",242 ,0)
  32436    .S:I=1 I= 0 Q:I=0  S :I'=1 I=I- 2,Y=$E(Y,1 ,I) W *8,* 27,"[1X" Q
  32437   "RTN","CHM IS021",243 ,0)
  32438   SBRS1 K DF OUT,DUOUT, DQOUT,DDOU T,D1OUT,D2 OUT
  32439   "RTN","CHM IS021",244 ,0)
  32440    I X=27 F  I=1:1:2 R  *X D:I=2
  32441   "RTN","CHM IS021",245 ,0)
  32442    .S:X=65 D 1OUT="" S: X=66 D2OUT =""
  32443   "RTN","CHM IS021",246 ,0)
  32444    S:X=9 DDO UT="" I Y= "^^" S (DF OUT,Y)=""
  32445   "RTN","CHM IS021",247 ,0)
  32446    S:Y="^" ( DUOUT,Y)=" " S:Y?1"?" .E!(Y["^")  (DQOUT,Y) =""
  32447   "RTN","CHM IS021",248 ,0)
  32448    U $I X ^% ZOSF("EON" ) Q
  32449   "RTN","CHM IS021",249 ,0)
  32450   DTPRT S Y= "" Q:X'?7N   S Y=(+$E (X,4,5))_" -"_(+$E(X, 6,7))_"-"_ (1700+$E(X ,1,3))
  32451   "RTN","CHM IS021",250 ,0)
  32452    Q
  32453   "RTN","CHM IS021",251 ,0)
  32454   BOTTOM K A  S A(1)="W ORKFLOW1", A(2)="WORK FLOW2",A(3 )="WORKFLO W3",A(4)=" USER SPEC" ,A(5)="QUI T",A(6)="M ORE"
  32455   "RTN","CHM IS021",252 ,0)
  32456    S I=0,CT= 6 W @CHREV ON S DX=1, $Y=DY,$X=D X
  32457   "RTN","CHM IS021",253 ,0)
  32458    ; CPE005- 023 MAKE R OOM FOR ED I-RO
  32459   "RTN","CHM IS021",254 ,0)
  32460    ; F DY=21 :1:23 X XY  W BL
  32461   "RTN","CHM IS021",255 ,0)
  32462    F DY=22:1 :24 X XY W  BL
  32463   "RTN","CHM IS021",256 ,0)
  32464    W @CHREVO N
  32465   "RTN","CHM IS021",257 ,0)
  32466   B1 S I=$O( ^CHMDIC(74 1002.17,1, 101,I)) G  B2:'I G B1 :'$D(^(I,0 )) S X=^(0 )
  32467   "RTN","CHM IS021",258 ,0)
  32468    S GLOB=$P (X,"^"),NA M=$P(X,"^" ,2),AA(NAM )=NAM_"^"_ GLOB G B1
  32469   "RTN","CHM IS021",259 ,0)
  32470   B2 S I=""  F  S I=$O( AA(I)) Q:I =""  S CT= CT+1,A(CT) =AA(I)
  32471   "RTN","CHM IS021",260 ,0)
  32472    K AA S LA STNUM=CT
  32473   "RTN","CHM IS021",261 ,0)
  32474    ; CPE005- 023 MAKE R OOM FOR ED I-RO
  32475   "RTN","CHM IS021",262 ,0)
  32476    ; B3 S DY =21,DX=1,$ Y=DY,$X=DX  X XY F J= 1:1:6 D
  32477   "RTN","CHM IS021",263 ,0)
  32478   B3 S DY=22 ,DX=1,$Y=D Y,$X=DX X  XY F J=1:1 :6 D
  32479   "RTN","CHM IS021",264 ,0)
  32480    .S DX=(J* 13)-12,$Y= DY,$X=DX X  XY W @CHR EVON,@CHBO N W:J<10 "  "
  32481   "RTN","CHM IS021",265 ,0)
  32482    .W $S(A(J )="QUIT":" Q",A(J)="P RINT SUM": "P",A(J)=" MORE":"M", 1:J)_" "
  32483   "RTN","CHM IS021",266 ,0)
  32484    .W @CHBOF F,@CHREVON ,$E($P(A(J ),"^"),1,1 1),$E(BL,1 ,11-$L($P( A(J),"^")) )
  32485   "RTN","CHM IS021",267 ,0)
  32486    S CT=MORE  F I=1:1:2  Q:'CT  F  J=1:1:6 S  CT=$O(A(CT )) Q:'CT   D
  32487   "RTN","CHM IS021",268 ,0)
  32488    .; CPE005 -023 MAKE  ROOM FOR E DI-RO
  32489   "RTN","CHM IS021",269 ,0)
  32490    .; S DX=( J*13)-12,D Y=21+I,$Y= DY,$X=DX X  XY W @CHR EVON,@CHBO N W:CT<10  " "
  32491   "RTN","CHM IS021",270 ,0)
  32492    .S DX=(J* 13)-12,DY= 22+I,$Y=DY ,$X=DX X X Y W @CHREV ON,@CHBON  W:CT<10 "  "
  32493   "RTN","CHM IS021",271 ,0)
  32494    .W CT," "
  32495   "RTN","CHM IS021",272 ,0)
  32496    .W @CHBOF F,@CHREVON ,$E($P(A(C T),"^"),1, 11),$E(BL, 1,11-$L($P (A(CT),"^" )))
  32497   "RTN","CHM IS021",273 ,0)
  32498    W @CHREVO FF Q
  32499   "RTN","CHM IS021",274 ,0)
  32500    
  32501   "RTN","CHM IS023")
  32502   0^78^B7603 7373
  32503   "RTN","CHM IS023",1,0 )
  32504   CHMIS023 ; JEA/DEN;CH AMPVA SYST EM STATUS  DISPLAY;08 /08/94  11 :15 PM
  32505   "RTN","CHM IS023",2,0 )
  32506    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  32507   "RTN","CHM IS023",3,0 )
  32508    ;;Called  by ^CHMIS0 21, ^CHMIS 022
  32509   "RTN","CHM IS023",4,0 )
  32510    ;;Calls ^ CHMIS021 
  32511   "RTN","CHM IS023",5,0 )
  32512    ;;
  32513   "RTN","CHM IS023",6,0 )
  32514    ;YJK 2/8/ 2010 - DEV 007247-03  Vista Menu  shows the  bottom di splays fro m CHV Moni tor data w hen Quit f rom the ap plication.
  32515   "RTN","CHM IS023",7,0 )
  32516    ;JSG2 10/ 18/2017 -  CPE005-023  Make allo wances for  new EDI R O status
  32517   "RTN","CHM IS023",8,0 )
  32518   ZSET S:'$D (DUZ) DUZ= 1,DUZ(0)=" " I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  32519   "RTN","CHM IS023",9,0 )
  32520    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  32521   "RTN","CHM IS023",10, 0)
  32522    I '$D(IOZ ) S %IS="N ",IOP=$I D  ^%ZIS K I OP S IOZ=I O,IOZL=IOS L,IOZW=IOM ,IOZF=IOF, IOZT=IOST, IOZN=ION,I OZS=IOS
  32523   "RTN","CHM IS023",11, 0)
  32524   ZNAM ;
  32525   "RTN","CHM IS023",12, 0)
  32526    S RFRESH= 1,NORFRESH =0,SCRN=RF RESH,SUB=0
  32527   "RTN","CHM IS023",13, 0)
  32528   EN1 ;D ^CH MGSET
  32529   "RTN","CHM IS023",14, 0)
  32530    D ^CHMFSE T
  32531   "RTN","CHM IS023",15, 0)
  32532    D NOW^%DT C S DAYHOL D=X
  32533   "RTN","CHM IS023",16, 0)
  32534   EN2 D TOP  D BOTTOM^C HMIS021:SC RN=RFRESH
  32535   "RTN","CHM IS023",17, 0)
  32536   EN3 D NOW^ %DTC D:X'= DAYHOLD  D  DISP S SC RN=NORFRES H
  32537   "RTN","CHM IS023",18, 0)
  32538    .S DAYHOL D=X,DX=12  F DY=3:1:1 7,$Y=DY,$X =DX X XY W  $E(CHL,1, 66)
  32539   "RTN","CHM IS023",19, 0)
  32540    ; CPE005- 023 Move < > line dow n one
  32541   "RTN","CHM IS023",20, 0)
  32542    ; EN4 S D Y=20,DX=1, $Y=DY,$X=D X X XY W @ CHEEL X XY  R "<>",X: 30 G EN3:' $T
  32543   "RTN","CHM IS023",21, 0)
  32544   EN4 S DY=2 1,DX=1,$Y= DY,$X=DX X  XY W @CHE EL X XY R  "<>",X:30  G EN3:'$T
  32545   "RTN","CHM IS023",22, 0)
  32546    ;
  32547   "RTN","CHM IS023",23, 0)
  32548    G END:$E( X)="Q",END :$E(X)="q"  I $E(X)=" Z"!($E(X)= "z") S SCR N=RFRESH G  EN1
  32549   "RTN","CHM IS023",24, 0)
  32550    I $E(X)=" M"!($E(X)= "m") D  D  BOTTOM^CHM IS021 G EN 4
  32551   "RTN","CHM IS023",25, 0)
  32552    .S MORE=M ORE+12 S:M ORE>LASTNU M MORE=5 Q
  32553   "RTN","CHM IS023",26, 0)
  32554    I $E(X)=" B" D  G:'$ D(LASTOVER ) EN3  S L ASTOVER=$O (^CHMSTAT( LASTOVER))  K:'LASTOV ER LASTOVE R S SCRN=R FRESH G EN 3
  32555   "RTN","CHM IS023",27, 0)
  32556    .I $L(X)= 1 D NOW^%D TC S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10)),X2 =-1 D C^%D TC S LASTO VER=X-.000 1 Q
  32557   "RTN","CHM IS023",28, 0)
  32558    .I X?1"BA " S STEP=1  D AUTOBCK  Q
  32559   "RTN","CHM IS023",29, 0)
  32560    .I X?1"BA "1.2N S ST EP=$P(X,"B A",2) D AU TOBCK Q
  32561   "RTN","CHM IS023",30, 0)
  32562    .I X?1"B" 1.3N1"@"1. 2N D  Q
  32563   "RTN","CHM IS023",31, 0)
  32564    ..S X2="- "_+$P($P(X ,"B",2),"@ ",1) S CHL D=X D NOW^ %DTC
  32565   "RTN","CHM IS023",32, 0)
  32566    ..S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10))
  32567   "RTN","CHM IS023",33, 0)
  32568    ..I +$E($ P(CHLD,"@" ,2))>24 S  $P(CHLD,"@ ",2)="00"
  32569   "RTN","CHM IS023",34, 0)
  32570    ..S $P(X1 ,".",2)=$P (CHLD,"@", 2) D C^%DT C S LASTOV ER=X-.001
  32571   "RTN","CHM IS023",35, 0)
  32572    .I X?1"B" 1.3N D  Q
  32573   "RTN","CHM IS023",36, 0)
  32574    ..S X2="- "_+$P(X,"B ",2) S CHL D=X D NOW^ %DTC
  32575   "RTN","CHM IS023",37, 0)
  32576    ..S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10))
  32577   "RTN","CHM IS023",38, 0)
  32578    ..D C^%DT C S LASTOV ER=X-.001
  32579   "RTN","CHM IS023",39, 0)
  32580    .K %DT S  %DT="PT",X =$P(X,"B", 2) D ^%DT  D  Q
  32581   "RTN","CHM IS023",40, 0)
  32582    ..I Y=-1  S DX=3,$Y= DY,$X=DX X  XY W @CHE OL D  Q
  32583   "RTN","CHM IS023",41, 0)
  32584    ...X XY W  @CHBON,"I NVALID BAC K DATE FOR MAT",@CHBO FF R X:5
  32585   "RTN","CHM IS023",42, 0)
  32586    ...S:$D(L ASTOVER) L ASTOVER=LA STOVER-.00 1
  32587   "RTN","CHM IS023",43, 0)
  32588    ..S LASTO VER=Y-.001  Q
  32589   "RTN","CHM IS023",44, 0)
  32590    I $E(X)=" F" D  G:'$ D(LASTOVER ) EN3  S L ASTOVER=$O (^CHMSTAT( LASTOVER))  K:'LASTOV ER LASTOVE R S SCRN=R FRESH G EN 3
  32591   "RTN","CHM IS023",45, 0)
  32592    .I $L(X)= 1 Q:'$D(LA STOVER)  D  NOW^%DTC  S CHLD=% S  X1=$S($D( LASTOVER): +$E(LASTOV ER,1,10),1 :+$E(%,1,1 0)),X2=1 D  C^%DTC K: X'<CHLD LA STOVER Q:' $D(LASTOVE R)  S LAST OVER=X-.00 01 Q
  32593   "RTN","CHM IS023",46, 0)
  32594    .I X?1"F" 1.3N1"@"1. 2N D  Q
  32595   "RTN","CHM IS023",47, 0)
  32596    ..S X2=+$ P($P(X,"F" ,2),"@",1)  S CHLD=X  D NOW^%DTC  S CHLD2=%
  32597   "RTN","CHM IS023",48, 0)
  32598    ..S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10))
  32599   "RTN","CHM IS023",49, 0)
  32600    ..I +$E($ P(CHLD,"@" ,2))>24 S  $P(CHLD,"@ ",2)="00"
  32601   "RTN","CHM IS023",50, 0)
  32602    ..S $P(X1 ,".",2)=$P (CHLD,"@", 2) D C^%DT C
  32603   "RTN","CHM IS023",51, 0)
  32604    ..I X'<CH LD2 K LAST OVER Q
  32605   "RTN","CHM IS023",52, 0)
  32606    ..S LASTO VER=X-.001
  32607   "RTN","CHM IS023",53, 0)
  32608    .I X?1"F" 1.3N D  Q
  32609   "RTN","CHM IS023",54, 0)
  32610    ..S X2=+$ P(X,"F",2)  S CHLD=X  D NOW^%DTC  S CHLD2=%
  32611   "RTN","CHM IS023",55, 0)
  32612    ..S X1=$S ($D(LASTOV ER):+$E(LA STOVER,1,1 0),1:+$E(% ,1,10))
  32613   "RTN","CHM IS023",56, 0)
  32614    ..D C^%DT C
  32615   "RTN","CHM IS023",57, 0)
  32616    ..I X'<CH LD2 K LAST OVER Q
  32617   "RTN","CHM IS023",58, 0)
  32618    ..S LASTO VER=X-.001
  32619   "RTN","CHM IS023",59, 0)
  32620    .K %DT S  %DT="PT",X =$P(X,"F", 2) D ^%DT  D  Q
  32621   "RTN","CHM IS023",60, 0)
  32622    ..I Y=-1  S DX=3,$Y= DY,$X=DX X  XY W @CHE OL D  Q
  32623   "RTN","CHM IS023",61, 0)
  32624    ...X XY W  @CHBON,"I NVALID BAC K DATE FOR MAT",@CHBO FF R X:5
  32625   "RTN","CHM IS023",62, 0)
  32626    ...S:$D(L ASTOVER) L ASTOVER=LA STOVER-.00 1
  32627   "RTN","CHM IS023",63, 0)
  32628    ..S CHLD= Y D NOW^%D TC I Y'<%  K LASTOVER  Q
  32629   "RTN","CHM IS023",64, 0)
  32630    ..S LASTO VER=CHLD-. 001 Q
  32631   "RTN","CHM IS023",65, 0)
  32632    I $E(X)=" H"!($E(X)= "h") G:'$D (LASTOVER)  EN3 S SCR N=RFRESH K  LASTOVER  G EN3
  32633   "RTN","CHM IS023",66, 0)
  32634    I $E(X)=" " S SCRN=R FRESH G EN 3
  32635   "RTN","CHM IS023",67, 0)
  32636    I $E(X)=" ?" S DX=3, $Y=DY,$X=D X X XY W @ CHEOL D  G  CHMIS023
  32637   "RTN","CHM IS023",68, 0)
  32638    .D BOXF^C HSC1(5,5,7 5,21),CLRB OXI^CHSC1( 5,5,75,21, XY,"","")
  32639   "RTN","CHM IS023",69, 0)
  32640    .S DY=6,D X=6,$Y=DY, $X=DX X XY  W "             Plea se Select  From The L ist Below. ..or..."
  32641   "RTN","CHM IS023",70, 0)
  32642    .S DY=8 X  XY W "                     Ente r: 'M' for  More Opti ons 'Q' to  Quit."
  32643   "RTN","CHM IS023",71, 0)
  32644    .S DY=10  X XY W "   To See Pas t Data Ent er: B, B<n um>, B<num >@<time> ( 2 digit)"
  32645   "RTN","CHM IS023",72, 0)
  32646    .S DY=11  X XY W "                         or: B<file man date f ormat>"
  32647   "RTN","CHM IS023",73, 0)
  32648    .S DY=12  X XY W "                         or: BA to  step back  by 1 day/2  seconds"
  32649   "RTN","CHM IS023",74, 0)
  32650    .S DY=14  X XY W "      To Go F orward Ent er: F, F<n um>, F<num >@<time> ( 2 digit)"
  32651   "RTN","CHM IS023",75, 0)
  32652    .S DY=15  X XY W "                         or: F<file man date f ormat>"
  32653   "RTN","CHM IS023",76, 0)
  32654    .S DY=17  X XY W " R eturn to C urrent Ent er: H"
  32655   "RTN","CHM IS023",77, 0)
  32656    .S DY=19  X XY W "                      Pr ess any ke y to conti nue..." R  X:20
  32657   "RTN","CHM IS023",78, 0)
  32658    I (X'=+X) !(+X>LASTN UM)!(+X<1) !(X=5)!(X= 6) S DX=3, $Y=DY,$X=D X X XY W @ CHEOL D  G  EN4
  32659   "RTN","CHM IS023",79, 0)
  32660    .S DX=3,$ Y=DY,$X=DX  X XY W @C HEOL X XY  W @CHBON,"  PLEASE SE LECT FROM  THE OPTION S BELOW.   OR ENTER ' ?' FOR ADD ITIONAL OP TIONS",@CH BOFF R X:5  S SCREEN= 0
  32661   "RTN","CHM IS023",80, 0)
  32662    S SNO=+X
  32663   "RTN","CHM IS023",81, 0)
  32664    G ^CHMIS0 21:X=1
  32665   "RTN","CHM IS023",82, 0)
  32666    I X=2 S S CREEN=1 D: '$D(ITEM(S CREEN))  G  EN1^CHMIS 021
  32667   "RTN","CHM IS023",83, 0)
  32668    .S DX=3,$ Y=DY,$X=DX  X XY W @C HEOL X XY  W @CHBON," CURRENTLY  THERE ARE  NOT ENOUGH  ITEMS FOR  THIS OPTI ON",@CHBOF F R X:5 S  SCREEN=0
  32669   "RTN","CHM IS023",84, 0)
  32670    I X=3 S S CREEN=2 D: '$D(ITEM(S CREEN))  G  EN1^CHMIS 021
  32671   "RTN","CHM IS023",85, 0)
  32672    .S DX=3,$ Y=DY,$X=DX  X XY W @C HEOL X XY  W @CHBON," CURRENTLY  THERE ARE  NOT ENOUGH  ITEMS FOR  THIS OPTI ON",@CHBOF F R X:5 S  SCREEN=0
  32673   "RTN","CHM IS023",86, 0)
  32674    I X=4 S S CREEN=3 D   G EN1^CHM IS021
  32675   "RTN","CHM IS023",87, 0)
  32676    .I '$D(CH DUZ) D WHO RU^CHMIS02 1 Q
  32677   "RTN","CHM IS023",88, 0)
  32678    .I CHDUZ= 1 D WHORU^ CHMIS021 Q
  32679   "RTN","CHM IS023",89, 0)
  32680    .I '$D(^C HMDIC(7410 02.21,CHDU Z,101,0))  D NOUSER^C HMIS021 Q
  32681   "RTN","CHM IS023",90, 0)
  32682    I X'>LAST NUM S SCRN =RFRESH G  EN3
  32683   "RTN","CHM IS023",91, 0)
  32684    G EN3
  32685   "RTN","CHM IS023",92, 0)
  32686    S SNO=+X  S SCRN=RFR ESH G EN3
  32687   "RTN","CHM IS023",93, 0)
  32688   END 
  32689   "RTN","CHM IS023",94, 0)
  32690    ;U $I X ^ %ZOSF("EON ") W @CHMA RESE,@CHAL LOFF S DY= 23,DX=1,$Y =DY,$X=DX  X XY Q              ; YJK 2/8/20 10 - DEV00 7247-03
  32691   "RTN","CHM IS023",95, 0)
  32692    U $I X ^% ZOSF("EON" ) W @CHMAR ESE,@CHALL OFF S DY=2 3,DX=1,$Y= DY,$X=DX X  XY W # Q                ;YJK 2/ 8/2010 - D EV007247-0 3
  32693   "RTN","CHM IS023",96, 0)
  32694   TOP Q:SCRN =NORFRESH   W @IOF,@C HMARESE K  BL,CHL S $ P(BL," ",8 1)=""
  32695   "RTN","CHM IS023",97, 0)
  32696    S $P(CHL, " ",81)="" ,DX=10,DY= 1,$Y=DY,$X =DX
  32697   "RTN","CHM IS023",98, 0)
  32698    S UPLINE= "W @CHREVO N,"" "",@C HREVOFF" X  XY W @CHR EVON,@CHBO N S DX=25, $Y=DY,$X=D X
  32699   "RTN","CHM IS023",99, 0)
  32700    W $E(BL,1 0,80) S DY =1 X XY W  "CHAMPVA P AYMENT CEN TER SYSTEM  STATUS V2 .0"
  32701   "RTN","CHM IS023",100 ,0)
  32702    W $C(27), "+0" S ZPL INE="W $C( 27,79,97)"
  32703   "RTN","CHM IS023",101 ,0)
  32704    W @CHBOFF  F DX=10,8 0 F DY=2:1 :17 S $Y=D Y,$X=DX X  XY,UPLINE
  32705   "RTN","CHM IS023",102 ,0)
  32706    S DX=10,D Y=18,$Y=DY ,$X=DX X X Y W @CHREV ON,$E(BL,1 0,80) S CT =5
  32707   "RTN","CHM IS023",103 ,0)
  32708    S DX=15,$ Y=DY,$X=DX  X XY W "C URRENT:           DAY  IN:           DAY OU T:",@CHREV OFF,@CHBON  S DY=19
  32709   "RTN","CHM IS023",104 ,0)
  32710    F DX=12:5 :77 S CT=C T+1 S $Y=D Y,$X=DX X  XY W $S(CT <12:CT,CT= 12:"NOON", 1:CT-12)
  32711   "RTN","CHM IS023",105 ,0)
  32712    S DY=1,DX =1,$Y=DY,$ X=DX X XY  W "SCALE", @CHBOFF
  32713   "RTN","CHM IS023",106 ,0)
  32714    F DY=13:1 :18 X XY X  ZPLINE
  32715   "RTN","CHM IS023",107 ,0)
  32716    S DX=2 F  DY=12:1:17  S $Y=DY,$ X=DX X XY  W @CHREVON  X UPLINE  W @CHREVOF F
  32717   "RTN","CHM IS023",108 ,0)
  32718    S DX=1,DY =19,$Y=DY, $X=DX X XY  W @CHBON, @CHREVON," IN",@CHREV OFF,@CHBOF F
  32719   "RTN","CHM IS023",109 ,0)
  32720    S DX=2,DY =18,$Y=DY, $X=DX X XY  W @CHREVO N,"OUT",@C HREVOFF Q
  32721   "RTN","CHM IS023",110 ,0)
  32722   DISP Q:'$D (SNO)  K B  S HIGH=0, NAM=$P(A(S NO),"^"),G LOB=$P(A(S NO),"^",2) ,%DT=""
  32723   "RTN","CHM IS023",111 ,0)
  32724    D NOW^%DT C S X=$S($ D(LASTOVER ):LASTOVER ,1:X)
  32725   "RTN","CHM IS023",112 ,0)
  32726    S X=$E(X, 4,5)_"-"_$ E(X,6,7)_" -"_$E(X,2, 3)
  32727   "RTN","CHM IS023",113 ,0)
  32728    ;HM 10/17 /2017 ADDE D EDI REOP EN
  32729   "RTN","CHM IS023",114 ,0)
  32730    I GLOB="I MAGE("!(GL OB="MANUAL (")!(GLOB= "DIST(")!( GLOB="CHMQ A1(")!(GLO B="CHMQA2( ")!(GLOB=" CHMEDIQ(") !(GLOB="CH MEDIL(")!( GLOB="WAND ")!(GLOB=" SCAN")!(GL OB="EDI/OC R")!(GLOB= "CHMASQ1(" )!(GLOB="E DI-REOPEN" ) D  S GLO BALNM=GLOB ALNM_" @ " _X,L=$L(GL OBALNM) G  DI1
  32731   "RTN","CHM IS023",115 ,0)
  32732    .S GLOBAL NM=""
  32733   "RTN","CHM IS023",116 ,0)
  32734    .S:GLOB=" DIST(" GLO BALNM="IMA GES PENDIN G MANID TO  PDI INTEG RATION" 
  32735   "RTN","CHM IS023",117 ,0)
  32736    .S:GLOB=" IMAGE(" GL OBALNM="IM AGED SUBMI SSIONS AVA ILABLE" 
  32737   "RTN","CHM IS023",118 ,0)
  32738    .S:GLOB=" MANUAL(" G LOBALNM="M ANUAL SUBM ISSIONS AV AILABLE" 
  32739   "RTN","CHM IS023",119 ,0)
  32740    .S:GLOB=" CHMEDIL("  GLOBALNM=" OCR SUBMIS SIONS PROC ESSED"   ; TLH 01/19/ 07
  32741   "RTN","CHM IS023",120 ,0)
  32742    .S:GLOB=" CHMEDIQ("  GLOBALNM=" EDI CLAIMS  PENDING" 
  32743   "RTN","CHM IS023",121 ,0)
  32744    .S:GLOB=" CHMQA1(" G LOBALNM="Q UALITY ASS URANCE QUE UE/QMD"
  32745   "RTN","CHM IS023",122 ,0)
  32746    .S:GLOB=" CHMASQ1("  GLOBALNM=" AUDIT SUPP ORT QUEUE  CODING QUE UE"
  32747   "RTN","CHM IS023",123 ,0)
  32748    .S:GLOB=" CHMQA2(" G LOBALNM="Q UALITY ASS URANCE QUE UE/CPD"
  32749   "RTN","CHM IS023",124 ,0)
  32750    .S:GLOB=" WAND" GLOB ALNM="SUBM ISSIONS PE NDING PULL "
  32751   "RTN","CHM IS023",125 ,0)
  32752    .S:GLOB=" SCAN" GLOB ALNM="SUBM ISSIONS PE NDING SCAN "
  32753   "RTN","CHM IS023",126 ,0)
  32754    .S:GLOB=" EDI/OCR" G LOBALNM="E DI SUBMISS IONS TO PR OCESS"  ;  TLH 1/19/0 7
  32755   "RTN","CHM IS023",127 ,0)
  32756    .S:GLOB=" EDI-REOPEN " GLOBALNM ="EDI REOP EN" ;HM 10 /17/2017
  32757   "RTN","CHM IS023",128 ,0)
  32758    .Q
  32759   "RTN","CHM IS023",129 ,0)
  32760    I GLOB="C HMASQ1(" D   G DI1A
  32761   "RTN","CHM IS023",130 ,0)
  32762    .S GLOBAL ="^CHMASQ( 0)"
  32763   "RTN","CHM IS023",131 ,0)
  32764    .S GLOBAL NM="ASQ -  CODING QUE UE @"_X
  32765   "RTN","CHM IS023",132 ,0)
  32766    .Q
  32767   "RTN","CHM IS023",133 ,0)
  32768    S GLOBAL= "^"_GLOB_" 0)"
  32769   "RTN","CHM IS023",134 ,0)
  32770    S GLOBALN M=$P(@GLOB AL,"^")_"  @ "_X
  32771   "RTN","CHM IS023",135 ,0)
  32772   DI1A S L=$ L(GLOBALNM )
  32773   "RTN","CHM IS023",136 ,0)
  32774   DI1 S DY=2 ,DX=12,$Y= DY,$X=DX X  XY W $E(B L,12,78) S  DX=10+((7 0-L)\2),$Y =DY,$X=DX  X XY
  32775   "RTN","CHM IS023",137 ,0)
  32776    W @CHBON, GLOBALNM,@ CHBOFF S X ="T" D ^%D T S DTT=Y
  32777   "RTN","CHM IS023",138 ,0)
  32778    S:$D(LAST OVER) DTT= $E(LASTOVE R,1,7) S ( CHIN,CHOUT ,CHTOT)=0
  32779   "RTN","CHM IS023",139 ,0)
  32780    F TIME=6: 1:19 S T=T IME S:T<10  T=0_T S T =DTT+(T/10 0) D
  32781   "RTN","CHM IS023",140 ,0)
  32782    .S B(T,"I N")=0 S:$D (^CHMSTAT( T,GLOB)) B (T,"IN")=+ $P(^(GLOB) ,"^",2),CH IN=CHIN+B( T,"IN")
  32783   "RTN","CHM IS023",141 ,0)
  32784    .S B(T,"O UT")=0 S:$ D(^(GLOB))  B(T,"OUT" )=+$P(^(GL OB),"^",3) ,CHOUT=CHO UT+B(T,"OU T"),CHTOT= $P(^(GLOB) ,"^",1)
  32785   "RTN","CHM IS023",142 ,0)
  32786    .S:B(T,"I N")>HIGH H IGH=B(T,"I N") S:B(T, "OUT")>HIG H HIGH=B(T ,"OUT")
  32787   "RTN","CHM IS023",143 ,0)
  32788   D3 S:HIGH# 75'=0 HIGH =HIGH+(75- (HIGH#75))  S DX=3,CT =0,BASE=(H IGH\75)*5, $Y=DY,$X=D X
  32789   "RTN","CHM IS023",144 ,0)
  32790    I SCRN=RF RESH S DX= 12 F DY=3: 1:17 S $Y= DY,$X=DX X  XY W $E(C HL,1,66)
  32791   "RTN","CHM IS023",145 ,0)
  32792    I HIGH=0  S DY=7,DX= 21,$Y=DY,$ X=DX X XY  D  Q
  32793   "RTN","CHM IS023",146 ,0)
  32794    .W "There  has been  no activit y in this  queue toda y."
  32795   "RTN","CHM IS023",147 ,0)
  32796    .S DY=18, DX=24,$Y=D Y,$X=DX X  XY W @CHRE VON,@CHBON ,"       "  S DX=41,$ Y=DY,$X=DX  X XY W "        " S  DX=58,$Y=D Y,$X=DX X  XY W "        ",@CHRE VOFF,@CHBO FF
  32797   "RTN","CHM IS023",148 ,0)
  32798    .S DX=3 F  DY=17:-1: 3 S $Y=DY, $X=DX X XY  W "        "
  32799   "RTN","CHM IS023",149 ,0)
  32800    S DX=3
  32801   "RTN","CHM IS023",150 ,0)
  32802    F DY=17:- 1:3 S $Y=D Y,$X=DX X  XY S CT=CT +1 W @CHBO N,$J($FN(B ASE*CT,"," ),7),@CHBO FF
  32803   "RTN","CHM IS023",151 ,0)
  32804    S T="",CT =0,X="         "
  32805   "RTN","CHM IS023",152 ,0)
  32806    S DY=18,D X=24,$Y=DY ,$X=DX X X Y W @CHREV ON,X S DX= 41,$Y=DY,$ X=DX X XY  W X S DX=5 9,$Y=DY,$X =DX X XY W  X,@CHREVO FF S DX=12 ,$Y=DY,$X= DX
  32807   "RTN","CHM IS023",153 ,0)
  32808    S DY=18,D X=24,$Y=DY ,$X=DX X X Y W @CHREV ON,@CHBON, CHTOT S DX =41,$Y=DY, $X=DX X XY  W CHIN S  DX=59,$Y=D Y,$X=DX X  XY W CHOUT ,@CHREVOFF ,@CHBOFF S  DX=12,$Y= DY,$X=DX
  32809   "RTN","CHM IS023",154 ,0)
  32810   D4 S T=$O( B(T)) Q:T= "" 
  32811   "RTN","CHM IS023",155 ,0)
  32812    S IN=B(T, "IN"),OUT= B(T,"OUT")
  32813   "RTN","CHM IS023",156 ,0)
  32814    S:IN&(IN< BASE) IN=B ASE S:OUT& (OUT<BASE)  OUT=BASE
  32815   "RTN","CHM IS023",157 ,0)
  32816    I IN F DY =17:-1:18- (((IN/BASE )+.5)\1) D
  32817   "RTN","CHM IS023",158 ,0)
  32818    .X XY X Z PLINE
  32819   "RTN","CHM IS023",159 ,0)
  32820    S DX=DX+1  I OUT F D Y=17:-1:18 -(((OUT/BA SE)+.5)\1)  S $Y=DY,$ X=DX  D
  32821   "RTN","CHM IS023",160 ,0)
  32822    .X XY W @ CHREVON X  UPLINE W @ CHREVOFF
  32823   "RTN","CHM IS023",161 ,0)
  32824    S DX=DX+4 ,$Y=DY,$X= DX G D4
  32825   "RTN","CHM IS023",162 ,0)
  32826   AUTOBCK ;G O BACK 1 D AY EVERY 2  SECONDS
  32827   "RTN","CHM IS023",163 ,0)
  32828    S DX=3,$Y =DY,$X=DX  X XY W @CH EOL D  S A CT=0
  32829   "RTN","CHM IS023",164 ,0)
  32830    .X XY W @ CHBON," Pr ess RETURN  To Stop A utomatic R eview..",@ CHBOFF
  32831   "RTN","CHM IS023",165 ,0)
  32832   AUTO1 D NO W^%DTC S X 1=$S($D(LA STOVER):+$ E(LASTOVER ,1,10),1:+ $E(%,1,10) ),X2="-"_S TEP D C^%D TC S LASTO VER=X-.000 1,SCRN=RFR ESH D DISP  R X:2 S A CT=ACT+1
  32833   "RTN","CHM IS023",166 ,0)
  32834    Q:ACT>30   G:'$T AUT O1
  32835   "RTN","CHM IS023",167 ,0)
  32836    Q
  32837   "RTN","CHM IS023",168 ,0)
  32838   SBRS S Y=" " U $I X ^ %ZOSF("EOF F")
  32839   "RTN","CHM IS023",169 ,0)
  32840    F I=1:1 R  *X:$S($D( DTIME):DTI ME,1:60) Q :(X=13)!(X =9)!(X=27)   S:X'=127  Y=Y_$C(X)  D:X=127   S:I=0 Y=""  W $C(X)
  32841   "RTN","CHM IS023",170 ,0)
  32842    .S:I=1 I= 0 Q:I=0  S :I'=1 I=I- 2,Y=$E(Y,1 ,I) W *8,* 27,"[1X" Q
  32843   "RTN","CHM IS023",171 ,0)
  32844   SBRS1 K DF OUT,DUOUT, DQOUT,DDOU T,D1OUT,D2 OUT
  32845   "RTN","CHM IS023",172 ,0)
  32846    I X=27 F  I=1:1:2 R  *X D:I=2
  32847   "RTN","CHM IS023",173 ,0)
  32848    .S:X=65 D 1OUT="" S: X=66 D2OUT =""
  32849   "RTN","CHM IS023",174 ,0)
  32850    S:X=9 DDO UT="" I Y= "^^" S (DF OUT,Y)=""
  32851   "RTN","CHM IS023",175 ,0)
  32852    S:Y="^" ( DUOUT,Y)=" " S:Y?1"?" .E!(Y["^")  (DQOUT,Y) =""
  32853   "RTN","CHM IS023",176 ,0)
  32854    U $I X ^% ZOSF("EON" ) Q
  32855   "RTN","CHM IS023",177 ,0)
  32856   DTPRT S Y= "" Q:X'?7N   S Y=(+$E (X,4,5))_" -"_(+$E(X, 6,7))_"-"_ (1700+$E(X ,1,3))
  32857   "RTN","CHM IS023",178 ,0)
  32858    Q
  32859   "RTN","CHM IS023",179 ,0)
  32860    
  32861   "RTN","CHM KAG5P")
  32862   0^97^B4262 1823
  32863   "RTN","CHM KAG5P",1,0 )
  32864   CHMKAG5P ; CVA/CR;AGI NG OF CLAI MS REPORT  CALC/PRINT ;05/11/98   1:06 PM
  32865   "RTN","CHM KAG5P",2,0 )
  32866    ;;1.0;CHA MPVA SYSTE M;**14**;D ECEMBER 08 , 2010;Bui ld 9
  32867   "RTN","CHM KAG5P",3,0 )
  32868    ;DPT MTN0 16163 3/12 /13 ADD SX C/CATARAMA N, REMOVE  ZZ IN GRP2  
  32869   "RTN","CHM KAG5P",4,0 )
  32870    ;S CHBDT= 3020205
  32871   "RTN","CHM KAG5P",5,0 )
  32872    ;S CHEDT= 3020205
  32873   "RTN","CHM KAG5P",6,0 )
  32874    ;S MENUVA L="3^HAC S UMMARY^CHA MPVA,CITI, CFL,CVAF,C WVV,SB,FMP ^"
  32875   "RTN","CHM KAG5P",7,0 )
  32876    ;CFS 02/2 8/2019 - O riginally  done by Ka thryn Leyv a (KLM) Us er Stories  CPE005-02 4a and 024 b.
  32877   "RTN","CHM KAG5P",8,0 )
  32878    ;                     Add EDI R O as a new  category  to the rep ort.
  32879   "RTN","CHM KAG5P",9,0 )
  32880    K AGEARR
  32881   "RTN","CHM KAG5P",10, 0)
  32882    D COMPILE
  32883   "RTN","CHM KAG5P",11, 0)
  32884    D PRINT
  32885   "RTN","CHM KAG5P",12, 0)
  32886    Q
  32887   "RTN","CHM KAG5P",13, 0)
  32888   COMPILE S  CHDT=(CHBD T\1)-.0001
  32889   "RTN","CHM KAG5P",14, 0)
  32890    S CHBBEG= "",CHBEND= ""
  32891   "RTN","CHM KAG5P",15, 0)
  32892    S PRGMSTR =$P(MENUVA L,"^",3)
  32893   "RTN","CHM KAG5P",16, 0)
  32894    S SUMFLG= +$P(MENUVA L,"^",4)
  32895   "RTN","CHM KAG5P",17, 0)
  32896    F  S CHDT =$O(^CHAGE ("C",CHDT) ) Q:CHDT\1 >CHEDT  Q: 'CHDT  D
  32897   "RTN","CHM KAG5P",18, 0)
  32898    .S CHB=0
  32899   "RTN","CHM KAG5P",19, 0)
  32900    .F  S CHB =$O(^CHAGE ("C",CHDT, CHB)) Q:'C HB  D
  32901   "RTN","CHM KAG5P",20, 0)
  32902    ..S:CHBBE G="" CHBBE G=CHB
  32903   "RTN","CHM KAG5P",21, 0)
  32904    ..S CHBEN D=CHB
  32905   "RTN","CHM KAG5P",22, 0)
  32906    ..F X=1:1  S PRGM=$P (PRGMSTR," ,",X) Q:PR GM=""  D
  32907   "RTN","CHM KAG5P",23, 0)
  32908    ...S PRGM 1=PRGM
  32909   "RTN","CHM KAG5P",24, 0)
  32910    ...S:SUMF LG PRGM1=" SUMMARY"
  32911   "RTN","CHM KAG5P",25, 0)
  32912    ...S GRP= ""
  32913   "RTN","CHM KAG5P",26, 0)
  32914    ...F  S G RP=$O(^CHA GE(CHB,PRG M,GRP)) Q: GRP=""  D
  32915   "RTN","CHM KAG5P",27, 0)
  32916    ....S CAT =""
  32917   "RTN","CHM KAG5P",28, 0)
  32918    ....F  S  CAT=$O(^CH AGE(CHB,PR GM,GRP,CAT )) Q:CAT=" "  D
  32919   "RTN","CHM KAG5P",29, 0)
  32920    .....S TI ME=""
  32921   "RTN","CHM KAG5P",30, 0)
  32922    .....F  S  TIME=$O(^ CHAGE(CHB, PRGM,GRP,C AT,TIME))  Q:TIME=""   D
  32923   "RTN","CHM KAG5P",31, 0)
  32924    ......S C NT1=+$P(^C HAGE(CHB,P RGM,GRP,CA T,TIME),"^ ")
  32925   "RTN","CHM KAG5P",32, 0)
  32926    ......S C NT2=+$P(^C HAGE(CHB,P RGM,GRP,CA T,TIME),"^ ",2)
  32927   "RTN","CHM KAG5P",33, 0)
  32928    ......; D o not coun t time it  time is 0
  32929   "RTN","CHM KAG5P",34, 0)
  32930    ......I T IME I TIME <CHLOW D
  32931   "RTN","CHM KAG5P",35, 0)
  32932    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",1 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",1)+CN T1
  32933   "RTN","CHM KAG5P",36, 0)
  32934    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",4 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",4)+CN T2
  32935   "RTN","CHM KAG5P",37, 0)
  32936    .......S  $P(AGEARR( PRGM1,GRP) ,"^",1)=$P ($G(AGEARR (PRGM1,GRP )),"^",1)+ CNT1
  32937   "RTN","CHM KAG5P",38, 0)
  32938    .......S  $P(AGEARR( PRGM1,GRP) ,"^",4)=$P ($G(AGEARR (PRGM1,GRP )),"^",4)+ CNT2
  32939   "RTN","CHM KAG5P",39, 0)
  32940    ......; D o not coun t time it  time is 0
  32941   "RTN","CHM KAG5P",40, 0)
  32942    ......I T IME I TIME <CHMID D   ;TLH 6/5/0 7 DEV00027 1
  32943   "RTN","CHM KAG5P",41, 0)
  32944    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",2 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",2)+CN T1  ;TLH 6 /5/07 DEV0 00271
  32945   "RTN","CHM KAG5P",42, 0)
  32946    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",5 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",5)+CN T2  ;TLH 6 /5/07 DEV0 00271
  32947   "RTN","CHM KAG5P",43, 0)
  32948    .......S  $P(AGEARR( PRGM1,GRP) ,"^",2)=$P ($G(AGEARR (PRGM1,GRP )),"^",2)+ CNT1  ;TLH  6/5/07 DE V000271
  32949   "RTN","CHM KAG5P",44, 0)
  32950    .......S  $P(AGEARR( PRGM1,GRP) ,"^",5)=$P ($G(AGEARR (PRGM1,GRP )),"^",5)+ CNT2  ;TLH  6/5/07 DE V000271
  32951   "RTN","CHM KAG5P",45, 0)
  32952    ......; D o not coun t time it  time is 0
  32953   "RTN","CHM KAG5P",46, 0)
  32954    ......I T IME I TIME <CHHIGH D
  32955   "RTN","CHM KAG5P",47, 0)
  32956    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",3 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",3)+CN T1
  32957   "RTN","CHM KAG5P",48, 0)
  32958    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",6 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",6)+CN T2
  32959   "RTN","CHM KAG5P",49, 0)
  32960    .......S  $P(AGEARR( PRGM1,GRP) ,"^",3)=$P ($G(AGEARR (PRGM1,GRP )),"^",3)+ CNT1
  32961   "RTN","CHM KAG5P",50, 0)
  32962    .......S  $P(AGEARR( PRGM1,GRP) ,"^",6)=$P ($G(AGEARR (PRGM1,GRP )),"^",6)+ CNT2
  32963   "RTN","CHM KAG5P",51, 0)
  32964    ......S $ P(AGEARR(P RGM1,GRP,C AT),"^",7) =$P($G(AGE ARR(PRGM1, GRP,CAT)), "^",7)+CNT 1
  32965   "RTN","CHM KAG5P",52, 0)
  32966    ......S $ P(AGEARR(P RGM1,GRP,C AT),"^",8) =$P($G(AGE ARR(PRGM1, GRP,CAT)), "^",8)+(CN T1*TIME)
  32967   "RTN","CHM KAG5P",53, 0)
  32968    ......S $ P(AGEARR(P RGM1,GRP,C AT),"^",9) =$P($G(AGE ARR(PRGM1, GRP,CAT)), "^",9)+(CN T2*TIME)
  32969   "RTN","CHM KAG5P",54, 0)
  32970    ......S $ P(AGEARR(P RGM1,GRP), "^",7)=$P( $G(AGEARR( PRGM1,GRP) ),"^",7)+C NT1
  32971   "RTN","CHM KAG5P",55, 0)
  32972    ......S $ P(AGEARR(P RGM1,GRP), "^",8)=$P( $G(AGEARR( PRGM1,GRP) ),"^",8)+( CNT1*TIME)
  32973   "RTN","CHM KAG5P",56, 0)
  32974    ......S $ P(AGEARR(P RGM1,GRP), "^",9)=$P( $G(AGEARR( PRGM1,GRP) ),"^",9)+( CNT2*TIME)
  32975   "RTN","CHM KAG5P",57, 0)
  32976    Q
  32977   "RTN","CHM KAG5P",58, 0)
  32978   PRINT ;
  32979   "RTN","CHM KAG5P",59, 0)
  32980    N PC
  32981   "RTN","CHM KAG5P",60, 0)
  32982    S PG=0
  32983   "RTN","CHM KAG5P",61, 0)
  32984    S PCNT=0
  32985   "RTN","CHM KAG5P",62, 0)
  32986    I SUMFLG  F PRGM="SU MMARY" D P 1
  32987   "RTN","CHM KAG5P",63, 0)
  32988    Q:SUMFLG
  32989   "RTN","CHM KAG5P",64, 0)
  32990    F PC=1:1  S PRGM=$P( PRGMSTR,", ",PC) Q:PR GM=""  D
  32991   "RTN","CHM KAG5P",65, 0)
  32992    .D P1
  32993   "RTN","CHM KAG5P",66, 0)
  32994    Q
  32995   "RTN","CHM KAG5P",67, 0)
  32996   P1 ;  
  32997   "RTN","CHM KAG5P",68, 0)
  32998    ;S PCNT=P CNT+1
  32999   "RTN","CHM KAG5P",69, 0)
  33000    ;I PCNT>2  D HDR S P CNT=1
  33001   "RTN","CHM KAG5P",70, 0)
  33002    D HDR
  33003   "RTN","CHM KAG5P",71, 0)
  33004    W !
  33005   "RTN","CHM KAG5P",72, 0)
  33006    W PRGM
  33007   "RTN","CHM KAG5P",73, 0)
  33008    D GRP1
  33009   "RTN","CHM KAG5P",74, 0)
  33010    D GRP2
  33011   "RTN","CHM KAG5P",75, 0)
  33012    D GRP3
  33013   "RTN","CHM KAG5P",76, 0)
  33014    D GRP4
  33015   "RTN","CHM KAG5P",77, 0)
  33016    W !
  33017   "RTN","CHM KAG5P",78, 0)
  33018    Q
  33019   "RTN","CHM KAG5P",79, 0)
  33020   GRP1 ;
  33021   "RTN","CHM KAG5P",80, 0)
  33022    S GRP=1
  33023   "RTN","CHM KAG5P",81, 0)
  33024    S VAR="AG EARR(PRGM, GRP,CAT)"
  33025   "RTN","CHM KAG5P",82, 0)
  33026    F CAT="PR OVIDER","B ENE","REJE CT" S CATN M=CAT D DE T
  33027   "RTN","CHM KAG5P",83, 0)
  33028    D SUM
  33029   "RTN","CHM KAG5P",84, 0)
  33030    Q
  33031   "RTN","CHM KAG5P",85, 0)
  33032   GRP2 ;
  33033   "RTN","CHM KAG5P",86, 0)
  33034    W !
  33035   "RTN","CHM KAG5P",87, 0)
  33036    S GRP=2
  33037   "RTN","CHM KAG5P",88, 0)
  33038    S VAR="AG EARR(PRGM, GRP,CAT)"
  33039   "RTN","CHM KAG5P",89, 0)
  33040    F CAT="PA PER","EDI" ,"EDI RO", "OCR","CAT AMARAN" S  CATNM=CAT  D DET  ;KM L  user st ory 005-02 4a add EDI  RO catego ry
  33041   "RTN","CHM KAG5P",90, 0)
  33042    D SUM
  33043   "RTN","CHM KAG5P",91, 0)
  33044    Q
  33045   "RTN","CHM KAG5P",92, 0)
  33046   GRP3 ;
  33047   "RTN","CHM KAG5P",93, 0)
  33048    W !
  33049   "RTN","CHM KAG5P",94, 0)
  33050    S GRP=3
  33051   "RTN","CHM KAG5P",95, 0)
  33052    S VAR="AG EARR(PRGM, GRP,CAT)"
  33053   "RTN","CHM KAG5P",96, 0)
  33054    F CAT=1:1 :$P(^CHMDI C(741002.0 5,0),"^",4 ) D
  33055   "RTN","CHM KAG5P",97, 0)
  33056    .S CATNM= $P(^CHMDIC (741002.05 ,CAT,0),"^ ",2)
  33057   "RTN","CHM KAG5P",98, 0)
  33058    .D DET
  33059   "RTN","CHM KAG5P",99, 0)
  33060    D SUM
  33061   "RTN","CHM KAG5P",100 ,0)
  33062    Q
  33063   "RTN","CHM KAG5P",101 ,0)
  33064   GRP4 ;
  33065   "RTN","CHM KAG5P",102 ,0)
  33066    W !
  33067   "RTN","CHM KAG5P",103 ,0)
  33068    S GRP=4
  33069   "RTN","CHM KAG5P",104 ,0)
  33070    S VAR="AG EARR(PRGM, GRP,CAT)"
  33071   "RTN","CHM KAG5P",105 ,0)
  33072    S (CAT,CA TNM)="Not  Covered Sv c" D DET
  33073   "RTN","CHM KAG5P",106 ,0)
  33074    S (CAT,CA TNM)="Form  dt < Svc"  D DET
  33075   "RTN","CHM KAG5P",107 ,0)
  33076    S (CAT,CA TNM)="No D X/PX/NDC"  D DET
  33077   "RTN","CHM KAG5P",108 ,0)
  33078    S (CAT,CA TNM)="Clm  denied-oth " D DET
  33079   "RTN","CHM KAG5P",109 ,0)
  33080    S (CAT,CA TNM)="No O HI EOB" D  DET
  33081   "RTN","CHM KAG5P",110 ,0)
  33082    S (CAT,CA TNM)="No C VA Clm for m" D DET
  33083   "RTN","CHM KAG5P",111 ,0)
  33084    S (CAT,CA TNM)="Clm  not signed " D DET
  33085   "RTN","CHM KAG5P",112 ,0)
  33086    S (CAT,CA TNM)="Inel ig bene" D  DET
  33087   "RTN","CHM KAG5P",113 ,0)
  33088    S (CAT,CA TNM)="No p re-auth" D  DET
  33089   "RTN","CHM KAG5P",114 ,0)
  33090    S (CAT,CA TNM)="Clm  miss info"  D DET
  33091   "RTN","CHM KAG5P",115 ,0)
  33092    S (CAT,CA TNM)="Rej  0 Paid" D  DET
  33093   "RTN","CHM KAG5P",116 ,0)
  33094    S (CAT,CA TNM)="No R sn Cat Id"  D DET
  33095   "RTN","CHM KAG5P",117 ,0)
  33096    W ?8 F X= 1:1:15 W " -"
  33097   "RTN","CHM KAG5P",118 ,0)
  33098    W !
  33099   "RTN","CHM KAG5P",119 ,0)
  33100    S (CAT,CA TNM)="Paid " D DET
  33101   "RTN","CHM KAG5P",120 ,0)
  33102    S (CAT,CA TNM)="0 Pa id w/ rsn"  D DET
  33103   "RTN","CHM KAG5P",121 ,0)
  33104    S (CAT,CA TNM)="0 Pa id w/o rsn " D DET
  33105   "RTN","CHM KAG5P",122 ,0)
  33106    D SUM
  33107   "RTN","CHM KAG5P",123 ,0)
  33108    Q
  33109   "RTN","CHM KAG5P",124 ,0)
  33110   DET ;
  33111   "RTN","CHM KAG5P",125 ,0)
  33112    S (HAC14, HAC21,HAC3 0,AAC14,AA C21,AAC30, CLMTOT,HAC AVG,AACAVG )=0
  33113   "RTN","CHM KAG5P",126 ,0)
  33114    S CLMTOT= +$P($G(@VA R),"^",7)   ;TLH 6/5/ 07 DEV0002 71
  33115   "RTN","CHM KAG5P",127 ,0)
  33116    I CLMTOT> 0 D
  33117   "RTN","CHM KAG5P",128 ,0)
  33118    .S HAC14= $P(@VAR,"^ ",1)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  33119   "RTN","CHM KAG5P",129 ,0)
  33120    .S HAC21= $P(@VAR,"^ ",2)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  33121   "RTN","CHM KAG5P",130 ,0)
  33122    .S HAC30= $P(@VAR,"^ ",3)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  33123   "RTN","CHM KAG5P",131 ,0)
  33124    .S AAC14= $P(@VAR,"^ ",4)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  33125   "RTN","CHM KAG5P",132 ,0)
  33126    .S AAC21= $P(@VAR,"^ ",5)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  33127   "RTN","CHM KAG5P",133 ,0)
  33128    .S AAC30= $P(@VAR,"^ ",6)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  33129   "RTN","CHM KAG5P",134 ,0)
  33130    .S HACAVG =$P(@VAR," ^",8)/CLMT OT  ;TLH 6 /5/07 DEV0 00271
  33131   "RTN","CHM KAG5P",135 ,0)
  33132    .S AACAVG =$P(@VAR," ^",9)/CLMT OT  ;TLH 6 /5/07 DEV0 00271
  33133   "RTN","CHM KAG5P",136 ,0)
  33134    W ?8,$E(C ATNM,1,15)
  33135   "RTN","CHM KAG5P",137 ,0)
  33136    W ?30,$J( HAC14,6,2)   ;TLH 6/5 /07 DEV000 271
  33137   "RTN","CHM KAG5P",138 ,0)
  33138    W ?40,$J( HAC21,6,2)   ;TLH 6/6 /07 DEV000 271
  33139   "RTN","CHM KAG5P",139 ,0)
  33140    W ?50,$J( HAC30,6,2)   ;TLH 6/6 /07 DEV002 71
  33141   "RTN","CHM KAG5P",140 ,0)
  33142    W ?65,$J( AAC14,6,2)   ;TLH 6/6 /07 DEV000 271
  33143   "RTN","CHM KAG5P",141 ,0)
  33144    W ?75,$J( AAC21,6,2)   ;TLH 6/6 /07 DEV000 271
  33145   "RTN","CHM KAG5P",142 ,0)
  33146    W ?85,$J( AAC30,6,2)   ;TLH 6/6 /07 DEV000 271
  33147   "RTN","CHM KAG5P",143 ,0)
  33148    W ?100,$J (HACAVG,6, 1)  ;TLH 6 /6/07 DEV0 00271
  33149   "RTN","CHM KAG5P",144 ,0)
  33150    W ?110,$J (AACAVG,6, 1)  ;TLH 6 /6/07 DEV0 00271
  33151   "RTN","CHM KAG5P",145 ,0)
  33152    W ?121,$J (CLMTOT,9)   ;TLH 6/6 /07 DEV000 271
  33153   "RTN","CHM KAG5P",146 ,0)
  33154    W !
  33155   "RTN","CHM KAG5P",147 ,0)
  33156    Q
  33157   "RTN","CHM KAG5P",148 ,0)
  33158   SUM ;
  33159   "RTN","CHM KAG5P",149 ,0)
  33160    W ?8
  33161   "RTN","CHM KAG5P",150 ,0)
  33162    F X=1:1:1 25 W "-"   ;TLH 6/6/0 7 DEV00027 1
  33163   "RTN","CHM KAG5P",151 ,0)
  33164    W !
  33165   "RTN","CHM KAG5P",152 ,0)
  33166    S CATNM=" TOTAL"
  33167   "RTN","CHM KAG5P",153 ,0)
  33168    S VAR="AG EARR(PRGM, GRP)"
  33169   "RTN","CHM KAG5P",154 ,0)
  33170    D DET
  33171   "RTN","CHM KAG5P",155 ,0)
  33172    Q
  33173   "RTN","CHM KAG5P",156 ,0)
  33174   HDR ;
  33175   "RTN","CHM KAG5P",157 ,0)
  33176    W @IOF
  33177   "RTN","CHM KAG5P",158 ,0)
  33178    S TITLE=" HEALTH ADM INISTRATIO N CENTER"
  33179   "RTN","CHM KAG5P",159 ,0)
  33180    S TAB1=13 2-$L(TITLE )/2  ;TLH  6/6/07 DEV 000271
  33181   "RTN","CHM KAG5P",160 ,0)
  33182    D NOW^%DT C S PG=PG+ 1,PAGE="Pa ge: "_PG
  33183   "RTN","CHM KAG5P",161 ,0)
  33184    W !,$$FMT E^XLFDT(X, "2D"),?TAB 1,TITLE,?1 22,PAGE  ; TLH 6/6/07  DEV000271
  33185   "RTN","CHM KAG5P",162 ,0)
  33186    W !,$E($P (%,".",2), 1,4),?53," Summary Ag ing of Cla ims"  ;TLH  6/6/07 DE V000271
  33187   "RTN","CHM KAG5P",163 ,0)
  33188    S TITLE2= $$FMTE^XLF DT(CHBDT,2 )_" - "_$$ FMTE^XLFDT (CHEDT\1,2 )
  33189   "RTN","CHM KAG5P",164 ,0)
  33190    S TAB1=13 2-$L(TITLE 2)/2  ;TLH  6/6/07 DE V000271
  33191   "RTN","CHM KAG5P",165 ,0)
  33192    W !,?TAB1 ,TITLE2
  33193   "RTN","CHM KAG5P",166 ,0)
  33194    S TITLE2= "Batch: "_ CHBBEG_" -  "_CHBEND
  33195   "RTN","CHM KAG5P",167 ,0)
  33196    S TAB1=13 2-$L(TITLE 2)/2  ;TLH  6/6/07 DE V000271
  33197   "RTN","CHM KAG5P",168 ,0)
  33198    W !,?TAB1 ,TITLE2
  33199   "RTN","CHM KAG5P",169 ,0)
  33200    I SUMFLG  D
  33201   "RTN","CHM KAG5P",170 ,0)
  33202    .S TITLE3 =$P(MENUVA L,"^",2)_"  ("_$P(MEN UVAL,"^",3 )_")"
  33203   "RTN","CHM KAG5P",171 ,0)
  33204    .S TAB1=1 32-$L(TITL E3)/2  ;TL H 6/6/07 D EV000271
  33205   "RTN","CHM KAG5P",172 ,0)
  33206    .W !,?TAB 1,TITLE3
  33207   "RTN","CHM KAG5P",173 ,0)
  33208    W !!,?40, "HAC % Und er",?72,"H AC/AAC % U nder",?105 ,"Avg Days "  ;TLH 6/ 6/07 DEV00 0271
  33209   "RTN","CHM KAG5P",174 ,0)
  33210    W ?124,"T otal",!  ; TLH 6/6/07  DEV000271
  33211   "RTN","CHM KAG5P",175 ,0)
  33212    W "Progra m",?10,"Ca tegory",?3 0,CHLOW_"  Days",?40, CHMID_" Da ys",?50,CH HIGH_" Day s",?65,CHL OW_" Days"   ;TLH 6/6 /07 DEV000 271
  33213   "RTN","CHM KAG5P",176 ,0)
  33214    W ?75,CHM ID_" Days" ,?85,CHHIG H_" Days", ?103,"HAC" ,?110,"HAC /AAC",?124 ,"Claims", !  ;TLH 6/ 6/07 DEV00 0271
  33215   "RTN","CHM KAG5P",177 ,0)
  33216    F X=1:1:1 32 W "-"   ;TLH 6/6/0 7 DEV00027 1
  33217   "RTN","CHM KAG5P",178 ,0)
  33218    Q
  33219   "RTN","CHM KAG5P",179 ,0)
  33220    ;
  33221   "RTN","CHM KAG5Q")
  33222   0^79^B1534 5684
  33223   "RTN","CHM KAG5Q",1,0 )
  33224   CHMKAG5Q ; CVA/CR;AGI NG OF CLAI MS REPORT  QUEUE;05/2 6/98  2:43  PM
  33225   "RTN","CHM KAG5Q",2,0 )
  33226    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  33227   "RTN","CHM KAG5Q",3,0 )
  33228    ;CPTS 104 51 (AEB)
  33229   "RTN","CHM KAG5Q",4,0 )
  33230    ;CFS 02/2 8/2019 Def ect 931401  allow agi ng report  to be prin ted to VMS  directory .
  33231   "RTN","CHM KAG5Q",5,0 )
  33232    ;
  33233   "RTN","CHM KAG5Q",6,0 )
  33234   ZSET S:'$D (DUZ) DUZ= 1,DUZ(0)=" " I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  33235   "RTN","CHM KAG5Q",7,0 )
  33236    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  33237   "RTN","CHM KAG5Q",8,0 )
  33238    I '$D(IOZ ) S %ZIS=" N" S IOP=" HOME" D HO ME^%ZIS S  IOZ=IO,IOZ L=IOSL,IOZ W=IOM,IOZF =IOF,IOZT= IOST,IOZN= ION,IOZS=I OS
  33239   "RTN","CHM KAG5Q",9,0 )
  33240   ZNAM ;
  33241   "RTN","CHM KAG5Q",10, 0)
  33242    N MOPT,OP T,MENUVAL
  33243   "RTN","CHM KAG5Q",11, 0)
  33244   A1 W @IOF  K DTOUT
  33245   "RTN","CHM KAG5Q",12, 0)
  33246   A2 W !,"HE ALTH ADMIN ISTRATION  CENTER Agi ng of Clai ms Report" ,!
  33247   "RTN","CHM KAG5Q",13, 0)
  33248    S MOPT="" ,OPT=""
  33249   "RTN","CHM KAG5Q",14, 0)
  33250    F X=1:1 Q :$TEXT(MEN U+X)'[";;"   D
  33251   "RTN","CHM KAG5Q",15, 0)
  33252    .S OPT=X
  33253   "RTN","CHM KAG5Q",16, 0)
  33254    .W !,$J($ P($P($TEXT (MENU+X)," ^",1),";;" ,2),2)_")"
  33255   "RTN","CHM KAG5Q",17, 0)
  33256    .W ?4,$P( $TEXT(MENU +X),"^",2)
  33257   "RTN","CHM KAG5Q",18, 0)
  33258    .I +$P($T EXT(MENU+X ),"^",4) W  " ("_$P($ TEXT(MENU+ X),"^",3)_ ")"
  33259   "RTN","CHM KAG5Q",19, 0)
  33260    R !!,"Sel ect Report : ",MOPT
  33261   "RTN","CHM KAG5Q",20, 0)
  33262    Q:MOPT=""
  33263   "RTN","CHM KAG5Q",21, 0)
  33264    I MOPT]""  I +MOPT>O PT!(+MOPT< 1) W " ??? " R X:2 G  A1
  33265   "RTN","CHM KAG5Q",22, 0)
  33266    S MENUVAL =$P($TEXT( MENU+MOPT) ,";;",2)
  33267   "RTN","CHM KAG5Q",23, 0)
  33268   A3 ;
  33269   "RTN","CHM KAG5Q",24, 0)
  33270    I DT="" D  NOW^%DTC  S DT=X
  33271   "RTN","CHM KAG5Q",25, 0)
  33272    S CHDEF1= $$FYR^CHTF LIB(DT)
  33273   "RTN","CHM KAG5Q",26, 0)
  33274    S CHDEF=" 10/01/"_$E (CHDEF1,2, 3)
  33275   "RTN","CHM KAG5Q",27, 0)
  33276    S DIR("A" )="SELECT  START DATE  "
  33277   "RTN","CHM KAG5Q",28, 0)
  33278    S DIR("B" )=$$FMTE^X LFDT(CHDEF ,8),DIR(0) ="D^288010 1:DT:EX^"  D ^DIR K D IR
  33279   "RTN","CHM KAG5Q",29, 0)
  33280    G:$D(DTOU T) END G:X ="^" END G :X="^^" EN D G:X="" E ND G:Y=-1  A3
  33281   "RTN","CHM KAG5Q",30, 0)
  33282    S CHBDT=Y  K %DT,XDT OUT
  33283   "RTN","CHM KAG5Q",31, 0)
  33284   A5 W !! K  DIR
  33285   "RTN","CHM KAG5Q",32, 0)
  33286    S DIR("A" )="SELECT  END DATE "
  33287   "RTN","CHM KAG5Q",33, 0)
  33288    S DIR("B" )=$$FMTE^X LFDT(DT,8) ,DIR(0)="D ^2880101:D T:EX^" D ^ DIR K DIR
  33289   "RTN","CHM KAG5Q",34, 0)
  33290    G:$D(DTOU T) END G:X ="^" A3 G: X="^^" END  G:X="" A3  G:Y=-1 A5
  33291   "RTN","CHM KAG5Q",35, 0)
  33292    S CHEDT=Y  K %DT,X,D TOUT
  33293   "RTN","CHM KAG5Q",36, 0)
  33294   A6 W !,"EN TER THE LO WER LIMIT:  14 DAYS//  " D CSBRS ^CHSC2
  33295   "RTN","CHM KAG5Q",37, 0)
  33296      G:$D(DT OUT) END G :$D(DFOUT)  END G:$D( DUOUT) A5
  33297   "RTN","CHM KAG5Q",38, 0)
  33298      I $D(DQ OUT) D  G  A6
  33299   "RTN","CHM KAG5Q",39, 0)
  33300      .W !,"E NTER THE L OWEST NUMB ER OF DAYS  STANDARD"
  33301   "RTN","CHM KAG5Q",40, 0)
  33302      .Q
  33303   "RTN","CHM KAG5Q",41, 0)
  33304      S:Y=""  Y=14  I Y' ?1.2N D  G  A6  ;TLH  6/5/07 DEV 000271
  33305   "RTN","CHM KAG5Q",42, 0)
  33306      .W !,"M UST BE NUM ERIC"
  33307   "RTN","CHM KAG5Q",43, 0)
  33308      .Q
  33309   "RTN","CHM KAG5Q",44, 0)
  33310      I $L(Y) >2 D  G A6
  33311   "RTN","CHM KAG5Q",45, 0)
  33312      .W !,"M UST BE NO  MORE THEN  2 DIGITS"
  33313   "RTN","CHM KAG5Q",46, 0)
  33314      .Q
  33315   "RTN","CHM KAG5Q",47, 0)
  33316      S CHLOW =Y
  33317   "RTN","CHM KAG5Q",48, 0)
  33318   A61 W !,"E NTER THE M IDDLER LIM IT: 21 DAY S// " D CS BRS^CHSC2   ;TLH 6/5/ 07 DEV0027
  33319   "RTN","CHM KAG5Q",49, 0)
  33320      G:$D(DT OUT) END G :$D(DFOUT)  END G:$D( DUOUT) A5   ;TLH 6/5/ 07 DEV0027 1
  33321   "RTN","CHM KAG5Q",50, 0)
  33322      I $D(DQ OUT) D  G  A61  ;TLH  6/5/07 DEV 00271
  33323   "RTN","CHM KAG5Q",51, 0)
  33324      .W !,"E NTER THE M IDDLE NUMB ER OF DAYS  STANDARD"  ;TLH 6/5/ 07 DEV0027
  33325   "RTN","CHM KAG5Q",52, 0)
  33326      .Q  ;TL H 6/5/07 D EV00271
  33327   "RTN","CHM KAG5Q",53, 0)
  33328      S:Y=""  Y=21  I Y' ?1.2N D  G  A61  ;TLH  6/5/07 DE V00271
  33329   "RTN","CHM KAG5Q",54, 0)
  33330      .W !,"M UST BE NUM ERIC"  ;TL H 6/5/07 D EV00271
  33331   "RTN","CHM KAG5Q",55, 0)
  33332      .Q  ;TL H 6/5/07 D EV00271
  33333   "RTN","CHM KAG5Q",56, 0)
  33334      I $L(Y) >2 D  G A6 1  ;TLH 6/ 5/07 DEV00 271
  33335   "RTN","CHM KAG5Q",57, 0)
  33336      .W !,"M UST BE NO  MORE THEN  2 DIGITS"   ;TLH 6/5/ 07 DEV0027 1
  33337   "RTN","CHM KAG5Q",58, 0)
  33338      .Q  ;TL H 6/5/07 D EV00271
  33339   "RTN","CHM KAG5Q",59, 0)
  33340      S CHMID =Y  ;TLH 6 /5/07 DEV0 0271
  33341   "RTN","CHM KAG5Q",60, 0)
  33342   A62  W !," ENTER THE  UPPER LIMI T: 30 DAYS // " D CSB RS^CHSC2
  33343   "RTN","CHM KAG5Q",61, 0)
  33344      G:$D(DT OUT) END G :$D(DFOUT)  END G:$D( DUOUT) A1
  33345   "RTN","CHM KAG5Q",62, 0)
  33346      I $D(DQ OUT) D  G  A62
  33347   "RTN","CHM KAG5Q",63, 0)
  33348      .W !,"E NTER THE L OWEST NUMB ER OF DAYS  STANDARD"
  33349   "RTN","CHM KAG5Q",64, 0)
  33350      .Q
  33351   "RTN","CHM KAG5Q",65, 0)
  33352      S:Y=""  Y=30  I Y' ?1.2N D  G  A62
  33353   "RTN","CHM KAG5Q",66, 0)
  33354      .W !,"M UST BE NUM ERIC"
  33355   "RTN","CHM KAG5Q",67, 0)
  33356      .Q
  33357   "RTN","CHM KAG5Q",68, 0)
  33358      I $L(Y) >2 D  G A6 2
  33359   "RTN","CHM KAG5Q",69, 0)
  33360      .W !,"M UST BE NUM ERIC NO MO RE THEN 2  DIGITS"
  33361   "RTN","CHM KAG5Q",70, 0)
  33362      .Q
  33363   "RTN","CHM KAG5Q",71, 0)
  33364      S CHHIG H=Y
  33365   "RTN","CHM KAG5Q",72, 0)
  33366   A7 W !! S  %DT="AEPX" ,%DT("A")= "SELECT DA TE/TIME TO  RUN: NOW/ /" D ^%DT
  33367   "RTN","CHM KAG5Q",73, 0)
  33368    I X="" D  NOW^%DTC S  RDT=% G A 8
  33369   "RTN","CHM KAG5Q",74, 0)
  33370    G:$D(DTOU T) END G:X ="^" END G :X="^^" EN D G:X="" A 3 G:Y=-1 A 7
  33371   "RTN","CHM KAG5Q",75, 0)
  33372    S RDT=Y K  %DT
  33373   "RTN","CHM KAG5Q",76, 0)
  33374   A8 S ZTDTH =RDT
  33375   "RTN","CHM KAG5Q",77, 0)
  33376    W !,"REPO RT MUST US E A WIDE P RINTER"  ; TLH 6/5/07  DEV000271
  33377   "RTN","CHM KAG5Q",78, 0)
  33378    W ! S IOP ="Q" D ^%Z IS G:POP E ND
  33379   "RTN","CHM KAG5Q",79, 0)
  33380    ;CFS 02/2 8/2014 - A llow to pr int to VMS  directory .
  33381   "RTN","CHM KAG5Q",80, 0)
  33382    ;I ION'[" /W" D  G A 8  ;TLH 6/ 5/07 DEV00 0271
  33383   "RTN","CHM KAG5Q",81, 0)
  33384    ;.W !,"RE PORT MUST  BE WIDE"   ;TLH 6/5/0 7 DEV00027 1
  33385   "RTN","CHM KAG5Q",82, 0)
  33386    ;.Q  ;TLH  6/5/07 DE V000271
  33387   "RTN","CHM KAG5Q",83, 0)
  33388    ;S CHFIO= ION
  33389   "RTN","CHM KAG5Q",84, 0)
  33390    ;S %ZIS=" Q",IOP="Q; "_CHFIO D  ^%ZIS G:PO P END
  33391   "RTN","CHM KAG5Q",85, 0)
  33392    S ION=ION _$S(ION="H FS":"",ION ="P-MESSAG E-HFS":"", 1:"/W")  ; CFS 02/28/ 2019
  33393   "RTN","CHM KAG5Q",86, 0)
  33394    S ZTRTN=" ^CHMKAG5P" ,ZTDESC="D ETAILED AG ING OF CLA IMS REPORT "
  33395   "RTN","CHM KAG5Q",87, 0)
  33396    K ZTIO
  33397   "RTN","CHM KAG5Q",88, 0)
  33398    S ZTSAVE( "CHHIGH")= "",ZTSAVE( "CHLOW")=" ",ZTSAVE(" CHMID")=""   ;TLH 6/5 /07 DEV002 71
  33399   "RTN","CHM KAG5Q",89, 0)
  33400    S ZTSAVE( "MENUVAL") =""
  33401   "RTN","CHM KAG5Q",90, 0)
  33402    S ZTSAVE( "CHBDT")=" ",ZTSAVE(" CHEDT")=""
  33403   "RTN","CHM KAG5Q",91, 0)
  33404    S ZTDTH=$ H
  33405   "RTN","CHM KAG5Q",92, 0)
  33406    D ^%ZTLOA D
  33407   "RTN","CHM KAG5Q",93, 0)
  33408    ;D ^CHMKA G5P
  33409   "RTN","CHM KAG5Q",94, 0)
  33410   END K CHBD T,CHEDT,DI R,ANS,DTOU T,X,Y
  33411   "RTN","CHM KAG5Q",95, 0)
  33412    Q
  33413   "RTN","CHM KAG5Q",96, 0)
  33414   MENU ;Opti on^Title^P rogram to  include in  report^fl ag=1 if su mmary repo rt
  33415   "RTN","CHM KAG5Q",97, 0)
  33416    ;;1^ALL P ROGRAMS^CH AMPVA,CITI ,CFL,CVAF, CWVV,SB,FM P
  33417   "RTN","CHM KAG5Q",98, 0)
  33418    ;;2^CHAMP VA SUMMARY ^CHAMPVA,C ITI,CFL,CV AF^1
  33419   "RTN","CHM KAG5Q",99, 0)
  33420    ;;3^HAC S UMMARY^CHA MPVA,CITI, CFL,CVAF,C WVV,SB,FMP ^1
  33421   "RTN","CHM KAG5Q",100 ,0)
  33422    ;;4^CHAMP VA^CHAMPVA
  33423   "RTN","CHM KAG5Q",101 ,0)
  33424    ;;5^CITI^ CITI
  33425   "RTN","CHM KAG5Q",102 ,0)
  33426    ;;6^CFL^C FL
  33427   "RTN","CHM KAG5Q",103 ,0)
  33428    ;;7^CVAF^ CVAF
  33429   "RTN","CHM KAG5Q",104 ,0)
  33430    ;;8^CWVV^ CWVV
  33431   "RTN","CHM KAG5Q",105 ,0)
  33432    ;;9^SB^SB
  33433   "RTN","CHM KAG5Q",106 ,0)
  33434    ;;10^FMP^ FMP
  33435   "RTN","CHM KAG5Q",107 ,0)
  33436    ;
  33437   "RTN","CHM KPDI2")
  33438   0^60^B5463 803
  33439   "RTN","CHM KPDI2",1,0 )
  33440   CHMKPDI2 ; DEH/DEN;VI EW PPR FOR  PDI;09/24 /97  4:57  PM
  33441   "RTN","CHM KPDI2",2,0 )
  33442    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  33443   "RTN","CHM KPDI2",3,0 )
  33444    ;V1.0
  33445   "RTN","CHM KPDI2",4,0 )
  33446    ;CPTS #12 621 (RLC),  #15932 (Y 2K)
  33447   "RTN","CHM KPDI2",5,0 )
  33448    ;GET PDI
  33449   "RTN","CHM KPDI2",6,0 )
  33450    ;DEV00782 0  EW 3/16 /12
  33451   "RTN","CHM KPDI2",7,0 )
  33452    ;CFS 10/1 8/2017 CPE 005-095 -  Kill PAIDA RY used to  gather to tals of al l claims f or Origina l and Curr ent PDI's.
  33453   "RTN","CHM KPDI2",8,0 )
  33454   Q1 X CHRES ET W "VIEW ING OF PPR " S DX=1,D Y=5 X XY
  33455   "RTN","CHM KPDI2",9,0 )
  33456    S DIC=741 000.2,DIC( 0)="AQME"  D ^DIC K D IC
  33457   "RTN","CHM KPDI2",10, 0)
  33458    G END:$D( DUOUT)
  33459   "RTN","CHM KPDI2",11, 0)
  33460    I Y=-1 I  '$D(^UTILI TY($J,1))  G END
  33461   "RTN","CHM KPDI2",12, 0)
  33462    I Y=-1 I  $D(^UTILIT Y($J,1)) G  END
  33463   "RTN","CHM KPDI2",13, 0)
  33464    ;S CLPDI= $P(Y,U,1), CHPRGPT=$E (CLPDI,6,7 ) D GTPRG^ CHMKPDI1 ; Y2K
  33465   "RTN","CHM KPDI2",14, 0)
  33466    ;S CLPDI= $P(Y,U,1), CHPRGPT=$$ TYPE^CHMFP DI2(CLPDI)  D GTPRG^C HMKPDI1
  33467   "RTN","CHM KPDI2",15, 0)
  33468    S CLPDI=$ P(Y,U,1) S  CHPRGPT=$ $TYPE^CHMF PDI2(CLPDI ) S:CHPRGP T'="" PRGF LG=""
  33469   "RTN","CHM KPDI2",16, 0)
  33470    I '$D(PRG FLG) I '$D (^UTILITY( $J,1)) D   G Q1
  33471   "RTN","CHM KPDI2",17, 0)
  33472    .W !!,"IN VALID PDI  SELECTED.   PLEASE TR Y AGAIN."
  33473   "RTN","CHM KPDI2",18, 0)
  33474    .R X:3
  33475   "RTN","CHM KPDI2",19, 0)
  33476    .X CHRESE T W !,"PRI NTING OF P PR'S FOR A  PDI"
  33477   "RTN","CHM KPDI2",20, 0)
  33478    .Q
  33479   "RTN","CHM KPDI2",21, 0)
  33480    K CLMARRY  D CLMARRY ^CHFCD001( CLPDI)
  33481   "RTN","CHM KPDI2",22, 0)
  33482    I '$D(PRG FLG) I $D( ^UTILITY($ J,1)) G EN D
  33483   "RTN","CHM KPDI2",23, 0)
  33484    ;
  33485   "RTN","CHM KPDI2",24, 0)
  33486    ;GET CLAI MS
  33487   "RTN","CHM KPDI2",25, 0)
  33488    K CHUTIL
  33489   "RTN","CHM KPDI2",26, 0)
  33490    S CHARYPT =0,CCNT=0
  33491   "RTN","CHM KPDI2",27, 0)
  33492   PDI1 ;
  33493   "RTN","CHM KPDI2",28, 0)
  33494    ;K FILE,F ILE0
  33495   "RTN","CHM KPDI2",29, 0)
  33496    ;S FILE=" ^"_GLPAY_" ""C"","_CL PDI_","_CL PDIPTR_")" ,CLPDIPTR= $O(@FILE)  G:'CLPDIPT R PDI2
  33497   "RTN","CHM KPDI2",30, 0)
  33498    ;S CLNUM= CLPDIPTR
  33499   "RTN","CHM KPDI2",31, 0)
  33500    S CHARYPT =$O(CLMARR Y(CHARYPT) ) G:'CHARY PT PDI2
  33501   "RTN","CHM KPDI2",32, 0)
  33502    S CLMPT=C LMARRY(CHA RYPT) G:CL MPT="" PDI 1
  33503   "RTN","CHM KPDI2",33, 0)
  33504    S X1=CLMP T D PROGTY P^CHFCD001
  33505   "RTN","CHM KPDI2",34, 0)
  33506    I $D(@(GL PAY_"CLMPT ,0)")) I $ P(@(GLPAY_ "CLMPT,0)" ),U,2)=10  G PDI1
  33507   "RTN","CHM KPDI2",35, 0)
  33508    S CCNT=CC NT+1
  33509   "RTN","CHM KPDI2",36, 0)
  33510    S CHUTIL( CLMPT)=CLM PT_"^"_$P( @(GLPAY_"C LMPT,0)"), U,1)
  33511   "RTN","CHM KPDI2",37, 0)
  33512    G PDI1
  33513   "RTN","CHM KPDI2",38, 0)
  33514   PDI2 ;VIEW  PPRS
  33515   "RTN","CHM KPDI2",39, 0)
  33516    W !!,"NUM BER OF CLA IMS = "_CC NT
  33517   "RTN","CHM KPDI2",40, 0)
  33518    W !,"PRES S ANY KEY  TO CONTINU E " R X
  33519   "RTN","CHM KPDI2",41, 0)
  33520    S CLNUM=" ",EXFLG=0
  33521   "RTN","CHM KPDI2",42, 0)
  33522    K PAIDARY   ;CPE005- 095
  33523   "RTN","CHM KPDI2",43, 0)
  33524   PDI3 S CLN UM=$O(CHUT IL(CLNUM))  G END:'CL NUM
  33525   "RTN","CHM KPDI2",44, 0)
  33526    K CHMFCLM S,CHMCL,CI ,I
  33527   "RTN","CHM KPDI2",45, 0)
  33528    S CHMFCLM S($P(CHUTI L(CLNUM)," ^",2))=+CH UTIL(CLNUM ),CHMCL($P (CHUTIL(CL NUM),"^",2 ))="",CI=+ CHUTIL(CLN UM)
  33529   "RTN","CHM KPDI2",46, 0)
  33530    S CHMFQQ= $P(CHUTIL( CLNUM),"^" ,2),I=+CHU TIL(CLNUM)
  33531   "RTN","CHM KPDI2",47, 0)
  33532    S CHMFQ(C HMFQQ)=CI, CHCCLM=CI
  33533   "RTN","CHM KPDI2",48, 0)
  33534    S PPRFL=1 ,VIEWFL=1, CL=0 D VIE W G:EXFLG= 1 END
  33535   "RTN","CHM KPDI2",49, 0)
  33536    G PDI3
  33537   "RTN","CHM KPDI2",50, 0)
  33538    Q
  33539   "RTN","CHM KPDI2",51, 0)
  33540    ;
  33541   "RTN","CHM KPDI2",52, 0)
  33542   END D DSPL Y80^CHMKPP R2 X CHRES ET K CHMFQ Q,VIEWFL,P PRFL,PAIDA RY Q  ;DEV 007820  EW  3/16/12
  33543   "RTN","CHM KPDI2",53, 0)
  33544   VIEW K ^TM P($J) D DS PLY^CHMKPP R2,VIEW^CH MF351D,V1^ CHMF351P   ;DEV007820   EW 3/16/ 12
  33545   "RTN","CHM KPDI2",54, 0)
  33546    W !!,"Pre ss <RETURN > to conti nue, <^> t o exit." R  X S:X="^"  EXFLG=1
  33547   "RTN","CHM KPDI2",55, 0)
  33548    Q
  33549   "RTN","CHM KPPR1")
  33550   0^61^B1571 6696
  33551   "RTN","CHM KPPR1",1,0 )
  33552   CHMKPPR1 ; CVA/PEJ;PP R PRINTOUT  LIST;02/1 1/98  11:5 7 AM
  33553   "RTN","CHM KPPR1",2,0 )
  33554    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  33555   "RTN","CHM KPPR1",3,0 )
  33556    ;;V2.0;
  33557   "RTN","CHM KPPR1",4,0 )
  33558    ;CPT(S) 1 1008* JLR,  #12621* ( RLC), #135 78 (RLC)
  33559   "RTN","CHM KPPR1",5,0 )
  33560    ;BMJ DEF0 12830 Fix  the <UNDEF INED>ST3+4 ^CHMKPPR1  error 
  33561   "RTN","CHM KPPR1",6,0 )
  33562    ;DEV7820  EW 3/18/11
  33563   "RTN","CHM KPPR1",7,0 )
  33564    ;CFS 10/1 8/2017 CPE 005-095 -  Kill PAIDA RY used to  gather to tals of al l claims f or Origina l and Curr ent PDI's.
  33565   "RTN","CHM KPPR1",8,0 )
  33566   STARTQ S U ="^" D ^CH MGSET X CH RESET D TI TLE
  33567   "RTN","CHM KPPR1",9,0 )
  33568   ST0 W "<V> IEW OR <P> RINT?  " D  CSBRS^CHS C2
  33569   "RTN","CHM KPPR1",10, 0)
  33570    G END:$D( DFOUT),END :$D(DUOUT)
  33571   "RTN","CHM KPPR1",11, 0)
  33572    I $D(DQOU T) W !!,"P lease ente r 'V' to V iew or 'P'  to Print. ",!! G ST0
  33573   "RTN","CHM KPPR1",12, 0)
  33574    G:Y="" EN D
  33575   "RTN","CHM KPPR1",13, 0)
  33576    I "VvPp"' [Y W *7,*7 ,!!,"Pleas e enter 'V ' to View  or 'P' to  Print." R  X:4 G STAR TQ
  33577   "RTN","CHM KPPR1",14, 0)
  33578    I "Vv"[Y  D ^CHMKPPR 2 G STARTQ
  33579   "RTN","CHM KPPR1",15, 0)
  33580    W ! K ^CH MZHOLD($J)  S CCNT=1
  33581   "RTN","CHM KPPR1",16, 0)
  33582   ST1 W !,"S elect CLAI M OR PDI N UMBER: " D  CSBRS^CHS C2
  33583   "RTN","CHM KPPR1",17, 0)
  33584    S:Y'="" Y =$TR(Y,"ab cdefghijkl mnopqrstuv wxyz","ABC DEFGHIJKLM NOPQRSTUVW XYZ")
  33585   "RTN","CHM KPPR1",18, 0)
  33586    G:($D(DTO UT))!($D(D FOUT))!($D (DUOUT)) E ND
  33587   "RTN","CHM KPPR1",19, 0)
  33588    I $D(DQOU T) W !!,"E nter a val id claim o r PDI numb er." R X:3  D TITLE G  ST1
  33589   "RTN","CHM KPPR1",20, 0)
  33590   ICQ I Y=""  I '$D(^CH MZHOLD($J, 1)) G END
  33591   "RTN","CHM KPPR1",21, 0)
  33592    I Y="" I  $D(^CHMZHO LD($J,1))  G ST4
  33593   "RTN","CHM KPPR1",22, 0)
  33594    I Y=" " D
  33595   "RTN","CHM KPPR1",23, 0)
  33596    .Q:'$D(^D ISV("PPR", DUZ))
  33597   "RTN","CHM KPPR1",24, 0)
  33598    .S Y=$P(^ DISV("PPR" ,DUZ),"^", 1)
  33599   "RTN","CHM KPPR1",25, 0)
  33600    .W Y
  33601   "RTN","CHM KPPR1",26, 0)
  33602    ;I $D(^CH MPAY("C",Y )) S DIC=" ^CHMPAY(", DIC(0)="MN QE",X=Y D  ^DIC G:Y=- 1 ST1 S Y= $P(Y,"^",2 ) G:$D(DUO UT) END
  33603   "RTN","CHM KPPR1",27, 0)
  33604    ;I $D(^CH NVPAY("C", Y)) S DIC= "^CHNVPAY( ",DIC(0)=" MNQE",X=Y  D ^DIC G:Y =-1 ST1 S  Y=$P(Y,"^" ,2) G:$D(D UOUT) END
  33605   "RTN","CHM KPPR1",28, 0)
  33606    I $L(Y)>1 0 D  G:$D( DUOUT) END  G:$D(DFOU T) END
  33607   "RTN","CHM KPPR1",29, 0)
  33608    .K CLMARR Y S TMPPDI =Y D CLMAR RY^CHFCD00 1(Y)
  33609   "RTN","CHM KPPR1",30, 0)
  33610    .Q:'$D(CL MARRY)
  33611   "RTN","CHM KPPR1",31, 0)
  33612    .W !,"#", "  ","     PDI  ","       ","Cla im #"
  33613   "RTN","CHM KPPR1",32, 0)
  33614    .S PT=0
  33615   "RTN","CHM KPPR1",33, 0)
  33616   ST2 .S PT= $O(CLMARRY (PT)) G:'P T ST3
  33617   "RTN","CHM KPPR1",34, 0)
  33618    .S TCLMPT =$P(CLMARR Y(PT),"^", 1) S X1=TC LMPT D PRO GTYP^CHFCD 001
  33619   "RTN","CHM KPPR1",35, 0)
  33620    .S TCLMNU M=$P(@(GLP AY_"TCLMPT ,0)"),"^", 1)
  33621   "RTN","CHM KPPR1",36, 0)
  33622    .W !,PT,"   ",TMPPDI ,"  ",TCLM NUM
  33623   "RTN","CHM KPPR1",37, 0)
  33624    .S LPT=PT  G ST2
  33625   "RTN","CHM KPPR1",38, 0)
  33626   ST3 .W !," Enter the  number to  select: "  D CSBRS^CH SC2
  33627   "RTN","CHM KPPR1",39, 0)
  33628    .I $D(DQO UT) W !,"E nter the n umber to s elect." G  ST3
  33629   "RTN","CHM KPPR1",40, 0)
  33630    .Q:$D(DUO UT)  Q:$D( DFOUT)
  33631   "RTN","CHM KPPR1",41, 0)
  33632    .I (Y<1)! (Y>LPT) W  !,"Enter a  number be tween 1 an d "_LPT G  ST3
  33633   "RTN","CHM KPPR1",42, 0)
  33634    .I '$D(CL MARRY(Y))  W !,"Enter  a number  between 1  and "_LPT  G ST3 ;BMJ  DEF012830  Added thi s line to  fix the un defined er ror   
  33635   "RTN","CHM KPPR1",43, 0)
  33636    .S TCLMPT =$P(CLMARR Y(Y),"^",1 ) S X1=TCL MPT D PROG TYP^CHFCD0 01
  33637   "RTN","CHM KPPR1",44, 0)
  33638    .S Y=$P(@ (GLPAY_"TC LMPT,0)"), "^",1)
  33639   "RTN","CHM KPPR1",45, 0)
  33640    .Q
  33641   "RTN","CHM KPPR1",46, 0)
  33642    I '$D(^CH MINDEX("B" ,Y)) W *7, "  ??" R X :3 D TITLE  G ST1
  33643   "RTN","CHM KPPR1",47, 0)
  33644    S I1=0,I1 =$O(^CHMIN DEX("B",Y, I1)) I 'I1  W *7,"  ? ?" R X:3 D  TITLE G S T1
  33645   "RTN","CHM KPPR1",48, 0)
  33646    I '$D(^CH MINDEX(I1, 0)) W *7,"   ??" R X: 3 D TITLE  G ST1
  33647   "RTN","CHM KPPR1",49, 0)
  33648    ;S CHPGPT =$P(^CHMIN DEX(I1,0), U,2)
  33649   "RTN","CHM KPPR1",50, 0)
  33650    S X1=I1 D  PROGTYP^C HFCD001
  33651   "RTN","CHM KPPR1",51, 0)
  33652    I CHPGPT= "" W *7,"   ??" R X:3  D TITLE G  ST1
  33653   "RTN","CHM KPPR1",52, 0)
  33654    S CLNUM=I 1 S ^CHMZH OLD($J,CCN T,CLNUM)=" " S CCNT=C CNT+1
  33655   "RTN","CHM KPPR1",53, 0)
  33656    S ^DISV(" PPR",DUZ)= Y
  33657   "RTN","CHM KPPR1",54, 0)
  33658    G ST1
  33659   "RTN","CHM KPPR1",55, 0)
  33660   ST4 ;
  33661   "RTN","CHM KPPR1",56, 0)
  33662    W !!
  33663   "RTN","CHM KPPR1",57, 0)
  33664    S IOP="Q"  D ^%ZIS G :POP END
  33665   "RTN","CHM KPPR1",58, 0)
  33666    I ION'["/ W" W !,"TH IS REPORT  REQUIRES A  WIDE PRIN TER" G ST4  ;DEV7820  EW 3/18/11
  33667   "RTN","CHM KPPR1",59, 0)
  33668    S CHFIO=I ON S ZTRTN ="STARTC^C HMKPPR1" S  ZTDESC="P PRS FOR CL AIMS IN LI ST"
  33669   "RTN","CHM KPPR1",60, 0)
  33670    S ZTIO=""  S ZTSAVE( "CHFIO")=" " S ZTSAVE ("^CHMZHOL D($J,")=""
  33671   "RTN","CHM KPPR1",61, 0)
  33672    S ZTSAVE( "GLPAY")=" ",ZTSAVE(" GLDFN")="" ,ZTSAVE("G LELG")=""
  33673   "RTN","CHM KPPR1",62, 0)
  33674    S ZTSAVE( "GLPAYH")= "",ZTSAVE( "GLPAYW")= ""
  33675   "RTN","CHM KPPR1",63, 0)
  33676    D ^%ZTLOA D
  33677   "RTN","CHM KPPR1",64, 0)
  33678    ;D HOME^% ZIS
  33679   "RTN","CHM KPPR1",65, 0)
  33680   END K IOP, CHMFRS,CHM FPDI,CHMFC LMS,CHMCL, CHMCCR,CI, CN,CLNUM,C CNT,CHMFI, CHMFQQ,CHM FPP
  33681   "RTN","CHM KPPR1",66, 0)
  33682    ;W @IOF
  33683   "RTN","CHM KPPR1",67, 0)
  33684    Q
  33685   "RTN","CHM KPPR1",68, 0)
  33686    ;
  33687   "RTN","CHM KPPR1",69, 0)
  33688    ;
  33689   "RTN","CHM KPPR1",70, 0)
  33690   STARTC S U ="^"
  33691   "RTN","CHM KPPR1",71, 0)
  33692    S CHPG=0  S CCNT=0
  33693   "RTN","CHM KPPR1",72, 0)
  33694    K PAIDARY
  33695   "RTN","CHM KPPR1",73, 0)
  33696   SA2 S CCNT =$O(^CHMZH OLD($J,CCN T)) G:'CCN T PQUE
  33697   "RTN","CHM KPPR1",74, 0)
  33698    S CLPTR=0 ,CLPTR=$O( ^CHMZHOLD( $J,CCNT,CL PTR)) S (C HCCLM,I)=C LPTR
  33699   "RTN","CHM KPPR1",75, 0)
  33700    D GTPTR D  ^CHMF351D  G SA2
  33701   "RTN","CHM KPPR1",76, 0)
  33702    ;
  33703   "RTN","CHM KPPR1",77, 0)
  33704   PQUE K BNC LARY,^CHMZ HOLD($J) S  %ZIS="Q"
  33705   "RTN","CHM KPPR1",78, 0)
  33706    S IOP="Q; "_CHFIO D  ^%ZIS G:PO P CEND
  33707   "RTN","CHM KPPR1",79, 0)
  33708    K ZTIO S  ZTRTN="PRI NT^CHMKPPR 1" S ZTSAV E("^TMP($J ,")=""
  33709   "RTN","CHM KPPR1",80, 0)
  33710    S ZTSAVE( "GLPAY")=" ",ZTSAVE(" GLDFN")="" ,ZTSAVE("G LELG")=""
  33711   "RTN","CHM KPPR1",81, 0)
  33712    S ZTSAVE( "GLPAYH")= "",ZTSAVE( "GLPAYW")= ""
  33713   "RTN","CHM KPPR1",82, 0)
  33714    D ^%ZTLOA D
  33715   "RTN","CHM KPPR1",83, 0)
  33716   CEND Q
  33717   "RTN","CHM KPPR1",84, 0)
  33718    ;
  33719   "RTN","CHM KPPR1",85, 0)
  33720    ;
  33721   "RTN","CHM KPPR1",86, 0)
  33722   PRINT ;D ^ CHMKMCR3
  33723   "RTN","CHM KPPR1",87, 0)
  33724    S EXFLG=0  K VIEWFL  D ^CHMF351 P
  33725   "RTN","CHM KPPR1",88, 0)
  33726    K PAIDARY
  33727   "RTN","CHM KPPR1",89, 0)
  33728    Q
  33729   "RTN","CHM KPPR1",90, 0)
  33730    ;
  33731   "RTN","CHM KPPR1",91, 0)
  33732   TITLE W @I OF,!,"PRIN TING OF PP RS",!!
  33733   "RTN","CHM KPPR1",92, 0)
  33734    Q
  33735   "RTN","CHM KPPR1",93, 0)
  33736    ;
  33737   "RTN","CHM KPPR1",94, 0)
  33738   GTPTR Q:'$ D(^CHMINDE X(CHCCLM))
  33739   "RTN","CHM KPPR1",95, 0)
  33740    Q:'$D(^CH MINDEX(CHC CLM,0))
  33741   "RTN","CHM KPPR1",96, 0)
  33742    S X1=CHCC LM D PROGT YP^CHFCD00 1
  33743   "RTN","CHM KPPR1",97, 0)
  33744    Q
  33745   "RTN","CHM KPPR1",98, 0)
  33746    S CHPGPT= $P(^(0),U, 2) Q:CHPGP T=""
  33747   "RTN","CHM KPPR1",99, 0)
  33748    Q:'$D(^CH MDIC(74100 2.94,CHPGP T,0))  S C HPROG=$P(^ (0),U,2)
  33749   "RTN","CHM KPPR1",100 ,0)
  33750    Q:'$D(^CH MDIC(74100 2.94,CHPGP T,1))  S G LREC=^(1)
  33751   "RTN","CHM KPPR1",101 ,0)
  33752    S GLPAY=$ P(GLREC,"^ ",1),GLELG =$P(GLREC, "^",2),GLD FN=$P(GLRE C,"^",3)
  33753   "RTN","CHM KPPR1",102 ,0)
  33754    S GLPAYH= $P(GLREC," ^",4),GLPA YW=$P(GLRE C,"^",5)
  33755   "RTN","CHM KPPR1",103 ,0)
  33756    Q
  33757   "RTN","CHM KPPR2")
  33758   0^62^B1243 3776
  33759   "RTN","CHM KPPR2",1,0 )
  33760   CHMKPPR2 ; DEH/DEN;CH AMPVA SEAR CH CLAIM F ILE SEND T O BC;11/05 /97  4:13  PM
  33761   "RTN","CHM KPPR2",2,0 )
  33762    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  33763   "RTN","CHM KPPR2",3,0 )
  33764    ;V1.0
  33765   "RTN","CHM KPPR2",4,0 )
  33766    ;CPTS # 1 2621 (RLC)
  33767   "RTN","CHM KPPR2",5,0 )
  33768    ;BMJ DEF0 12830 Fix  the <UNDEF INED>ST3+4 ^CHMKPPR1  error
  33769   "RTN","CHM KPPR2",6,0 )
  33770    ;DEV00782 0 EW 2/23/ 11 CHANGE  DISPLAY TO  132 FOR P PR WITH LI NE LEVEL D ATA
  33771   "RTN","CHM KPPR2",7,0 )
  33772    ;CFS 10/1 8/2017 CPE 005-095 -  Kill PAIDA RY used to  gather to tals of al l claims f or Origina l and Curr ent PDI's.
  33773   "RTN","CHM KPPR2",8,0 )
  33774   Q1 X CHRES ET W !,"VI EWING OF P PR"
  33775   "RTN","CHM KPPR2",9,0 )
  33776   ST1 W !!," Select CLA IM OR PDI  NUMBER: "  D CSBRS^CH SC2
  33777   "RTN","CHM KPPR2",10, 0)
  33778    S:Y'="" Y =$TR(Y,"ab cdefghijkl mnopqrstuv wxyz","ABC DEFGHIJKLM NOPQRSTUVW XYZ")
  33779   "RTN","CHM KPPR2",11, 0)
  33780    G:($D(DTO UT))!($D(D FOUT))!($D (DUOUT)) E ND
  33781   "RTN","CHM KPPR2",12, 0)
  33782    I $D(DQOU T) W !!,"E nter a val id claim o r PDI numb er." R X:3  D TITLE G  ST1
  33783   "RTN","CHM KPPR2",13, 0)
  33784    G:Y="" EN D
  33785   "RTN","CHM KPPR2",14, 0)
  33786    I Y=" " D
  33787   "RTN","CHM KPPR2",15, 0)
  33788    .Q:'$D(^D ISV("PPR", DUZ))
  33789   "RTN","CHM KPPR2",16, 0)
  33790    .S Y=$P(^ DISV("PPR" ,DUZ),"^", 1)
  33791   "RTN","CHM KPPR2",17, 0)
  33792    .W Y R X: 1
  33793   "RTN","CHM KPPR2",18, 0)
  33794    ;I $D(^CH MPAY("C",Y )) S DIC=" ^CHMPAY(", DIC(0)="MN QE",X=Y D  ^DIC G:Y=- 1 ST1 S Y= $P(Y,"^",2 ) G:$D(DUO UT) END
  33795   "RTN","CHM KPPR2",19, 0)
  33796    ;I $D(^CH NVPAY("C", Y)) S DIC= "^CHNVPAY( ",DIC(0)=" MNQE",X=Y  D ^DIC G:Y =-1 ST1 S  Y=$P(Y,"^" ,2) G:$D(D UOUT) END
  33797   "RTN","CHM KPPR2",20, 0)
  33798    I $L(Y)>1 0 D  G:$D( DUOUT) END  G:$D(DFOU T) END
  33799   "RTN","CHM KPPR2",21, 0)
  33800    .K CLMARR Y S TMPPDI =Y D CLMAR RY^CHFCD00 1(Y)
  33801   "RTN","CHM KPPR2",22, 0)
  33802    .Q:'$D(CL MARRY)
  33803   "RTN","CHM KPPR2",23, 0)
  33804    .W !,"#", "  ","     PDI  ","       ","Cla im #"
  33805   "RTN","CHM KPPR2",24, 0)
  33806    .S PT=0
  33807   "RTN","CHM KPPR2",25, 0)
  33808   ST2 .S PT= $O(CLMARRY (PT)) G:'P T ST3
  33809   "RTN","CHM KPPR2",26, 0)
  33810    .S TCLMPT =$P(CLMARR Y(PT),"^", 1) S X1=TC LMPT D PRO GTYP^CHFCD 001
  33811   "RTN","CHM KPPR2",27, 0)
  33812    .S TCLMNU M=$P(@(GLP AY_"TCLMPT ,0)"),"^", 1)
  33813   "RTN","CHM KPPR2",28, 0)
  33814    .W !,PT,"   ",TMPPDI ,"  ",TCLM NUM
  33815   "RTN","CHM KPPR2",29, 0)
  33816    .S LPT=PT  G ST2
  33817   "RTN","CHM KPPR2",30, 0)
  33818   ST3 .W !," Enter the  number to  select: "  D CSBRS^CH SC2
  33819   "RTN","CHM KPPR2",31, 0)
  33820    .I $D(DQO UT) W !,"E nter the n umber to s elect." G  ST3
  33821   "RTN","CHM KPPR2",32, 0)
  33822    .Q:$D(DUO UT)  Q:$D( DFOUT)
  33823   "RTN","CHM KPPR2",33, 0)
  33824    .I (Y<1)! (Y>LPT) W  !,"Enter a  number be tween 1 an d "_LPT G  ST3
  33825   "RTN","CHM KPPR2",34, 0)
  33826    .I '$D(CL MARRY(Y))  W !,"Enter  a number  between 1  and "_LPT  G ST3 ;BMJ  DEF012830  Added thi s line to  fix the un defined er ror
  33827   "RTN","CHM KPPR2",35, 0)
  33828    .S TCLMPT =$P(CLMARR Y(Y),"^",1 ) S X1=TCL MPT D PROG TYP^CHFCD0 01
  33829   "RTN","CHM KPPR2",36, 0)
  33830    .S Y=$P(@ (GLPAY_"TC LMPT,0)"), "^",1)
  33831   "RTN","CHM KPPR2",37, 0)
  33832    .Q 
  33833   "RTN","CHM KPPR2",38, 0)
  33834   ST4 I '$D( ^CHMINDEX( "B",Y)) W  *7,"  ??"  R X:3 D TI TLE G ST1
  33835   "RTN","CHM KPPR2",39, 0)
  33836    S I1=0,I1 =$O(^CHMIN DEX("B",Y, I1)) I 'I1  W *7,"  ? ?" R X:3 D  TITLE G S T1
  33837   "RTN","CHM KPPR2",40, 0)
  33838    I '$D(^CH MINDEX(I1, 0)) W *7,"   ??" R X: 3 D TITLE  G ST1
  33839   "RTN","CHM KPPR2",41, 0)
  33840    S X1=I1 D  PROGTYP^C HFCD001
  33841   "RTN","CHM KPPR2",42, 0)
  33842    ;S CHPGPT =$P(^CHMIN DEX(I1,0), U,2)
  33843   "RTN","CHM KPPR2",43, 0)
  33844    I CHPGPT= "" W *7,"   ??" R X:3  D TITLE G  ST1
  33845   "RTN","CHM KPPR2",44, 0)
  33846    I '$D(^CH MDIC(74100 2.94,CHPGP T,0)) W *7 ,"  ??" R  X:3 D TITL E G ST1
  33847   "RTN","CHM KPPR2",45, 0)
  33848    S CHPROG= $P(^CHMDIC (741002.94 ,CHPGPT,0) ,"^",2)
  33849   "RTN","CHM KPPR2",46, 0)
  33850    I '$D(^CH MDIC(74100 2.94,CHPGP T,1)) W *7 ,"  ??" R  X:3 D TITL E G ST1
  33851   "RTN","CHM KPPR2",47, 0)
  33852    ;S GLREC= ^CHMDIC(74 1002.94,CH PGPT,1)
  33853   "RTN","CHM KPPR2",48, 0)
  33854    ;S GLPAY= $P(GLREC," ^",1),GLEL G=$P(GLREC ,"^",2),GL DFN=$P(GLR EC,"^",3)
  33855   "RTN","CHM KPPR2",49, 0)
  33856    ;S GLPAYH =$P(GLREC, "^",4),GLP AYW=$P(GLR EC,"^",5)
  33857   "RTN","CHM KPPR2",50, 0)
  33858    ;K FILE S  FILE="^"_ GLPAY_I1_" ,""ZFI"")"
  33859   "RTN","CHM KPPR2",51, 0)
  33860    I $D(@(GL PAY_"I1,"" ZFI"")"))  W !!,"This  claim is  from Blue  Cross/Blue  Shield!"  R X:3 G Q1
  33861   "RTN","CHM KPPR2",52, 0)
  33862    K CHMFCLM S,CHMCL,CI ,I
  33863   "RTN","CHM KPPR2",53, 0)
  33864    S CHMFCLM S(Y)=I1,CH MCL(Y)="", CI=I1
  33865   "RTN","CHM KPPR2",54, 0)
  33866    S CHMFQQ= Y,I=I1
  33867   "RTN","CHM KPPR2",55, 0)
  33868    S ^DISV(" PPR",DUZ)= Y
  33869   "RTN","CHM KPPR2",56, 0)
  33870    ;COMMENT  OFF THE PR EVIOUS LIN E IF YOU W ANT THE CL AIM TO GO  TO BENE CA LC
  33871   "RTN","CHM KPPR2",57, 0)
  33872   SEND S DX= 1 F DY=1:1 :24 X XY W  @CHEEL
  33873   "RTN","CHM KPPR2",58, 0)
  33874    S DX=3,DY =10 X XY
  33875   "RTN","CHM KPPR2",59, 0)
  33876    R X:4 S C HMFI=CI,CH MFPP="180B " D ^CHMFW K02
  33877   "RTN","CHM KPPR2",60, 0)
  33878    S CHMFQ(C HMFQQ)=CI
  33879   "RTN","CHM KPPR2",61, 0)
  33880    ;COMMENT  OFF THE PR EVIOUS LIN E IF YOU W ANT THE CL AIM TO GO  TO BENE CA LC
  33881   "RTN","CHM KPPR2",62, 0)
  33882    S PPRFL=1 ,VIEWFL=1, CL=0 D VIE W G Q1
  33883   "RTN","CHM KPPR2",63, 0)
  33884   END D DSPL Y80 X CHRE SET K CHMF QQ,VIEWFL, PPRFL,^TMP ($J),REJLN ($J),AUTOD IST Q
  33885   "RTN","CHM KPPR2",64, 0)
  33886    ;VIEW K ^ TMP($J) D  VIEW^CHMF3 51D,V1^CHM F351P  
  33887   "RTN","CHM KPPR2",65, 0)
  33888   VIEW K ^TM P($J),PAID ARY D DSPL Y,VIEW^CHM F351D,V1^C HMF351P  ;   DEV00782 0 EW 1/25/ 11
  33889   "RTN","CHM KPPR2",66, 0)
  33890    K PAIDARY
  33891   "RTN","CHM KPPR2",67, 0)
  33892    W !!,"Pre ss <RETURN > to conti nue." R X  Q
  33893   "RTN","CHM KPPR2",68, 0)
  33894   TITLE W @I OF,!,"VIEW ING OF PPR "
  33895   "RTN","CHM KPPR2",69, 0)
  33896    Q
  33897   "RTN","CHM KPPR2",70, 0)
  33898    ;
  33899   "RTN","CHM KPPR2",71, 0)
  33900   DSPLY ;  D EV007820 E W 1/25/11  CHANGE DIS PLAY TO 13 2 FOR PPR  WITH LINE  LEVEL DATA
  33901   "RTN","CHM KPPR2",72, 0)
  33902    I $D(PFLG ) X ^%ZOSF ("ZSETWIDE ") S X=132  X ^%ZOSF( "RM")
  33903   "RTN","CHM KPPR2",73, 0)
  33904    S:'$D(SCR W) SCRW=""  S:'$D(SCR N) SCRN=""
  33905   "RTN","CHM KPPR2",74, 0)
  33906    I SCRW=""  S SCRW=""  S:$D(^%ZI S(2,IOST(0 ),554001))  SCRW=$P(^ (554001),U ,2)
  33907   "RTN","CHM KPPR2",75, 0)
  33908    I SCRN=""  S SCRN=""  S:$D(^%ZI S(2,IOST(0 ),554001))  SCRN=$P(^ (554001),U ,1)
  33909   "RTN","CHM KPPR2",76, 0)
  33910    S X=132 X  ^%ZOSF("R M") W @SCR W
  33911   "RTN","CHM KPPR2",77, 0)
  33912    Q
  33913   "RTN","CHM KPPR2",78, 0)
  33914   DSPLY80 ;   DEV007820  EW 1/25/1 1 CHANGE D ISPLAY FRO M 132 FOR  PPR WITH L INE LEVEL  DATA
  33915   "RTN","CHM KPPR2",79, 0)
  33916    S:'$D(SCR W) SCRW=""  S:'$D(SCR N) SCRN=""   ;BUG PPR 4  EW 4/11 /12
  33917   "RTN","CHM KPPR2",80, 0)
  33918    I SCRW=""  S SCRW=""  S:$D(^%ZI S(2,IOST(0 ),554001))  SCRW=$P(^ (554001),U ,2)  ;BUG  PPR4  EW 4 /11/12
  33919   "RTN","CHM KPPR2",81, 0)
  33920    S X=80 X  ^%ZOSF("RM ") W @SCRW
  33921   "RTN","CHM KPPR2",82, 0)
  33922    W @$P(^%Z IS(2,IOST( 0),554001) ,"^",1)
  33923   "RTN","CHM KPPR2",83, 0)
  33924    Q
  33925   "RTN","CHM RESET")
  33926   0^63^B1494 3433
  33927   "RTN","CHM RESET",1,0 )
  33928   CHMRESET ; JLR/DEN;DE LETING/RES ETING PDI; 07/29/98   7:18 AM
  33929   "RTN","CHM RESET",2,0 )
  33930    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  33931   "RTN","CHM RESET",3,0 )
  33932    ;CPT 1501 1* - JLR,  #15347 (RL C)
  33933   "RTN","CHM RESET",4,0 )
  33934    ;DEF01158 0  - JSE   2/2011 (At  tag A1+4)
  33935   "RTN","CHM RESET",5,0 )
  33936    ;LEG 12/1 5/17 CPE00 5-119 - Fi le Program  Indicator s 96 and 9 7 in file  741002.21  and force  user into  ER-Manual  EDI Reopen
  33937   "RTN","CHM RESET",6,0 )
  33938    D ^CHMFSE T X CHRESE T
  33939   "RTN","CHM RESET",7,0 )
  33940   A1 W !!,"E nter PDI t o Reset: "  D CSBRS^C HSC2
  33941   "RTN","CHM RESET",8,0 )
  33942    G:$D(DFOU T) END G:$ D(DUOUT) E ND G:$D(DQ OUT) A1 G: Y="" END
  33943   "RTN","CHM RESET",9,0 )
  33944    S CHMFPDI =Y
  33945   "RTN","CHM RESET",10, 0)
  33946    ;JSE-DEF0 11580 GLPA Y not rese t frm prev  L/U & som etimes wil l cause an  UNDEF err or.
  33947   "RTN","CHM RESET",11, 0)
  33948    I $D(GLPA Y) K GLPAY
  33949   "RTN","CHM RESET",12, 0)
  33950    D GTFILES ^CHMFSRT2
  33951   "RTN","CHM RESET",13, 0)
  33952    ;PER #153 47, ADDED  THE NEXT L INE.  ALSO  REMOVED O LD SBRS AN D ZSET
  33953   "RTN","CHM RESET",14, 0)
  33954    I '$D(GLP AY) W !!,* 7,"PDI ent ered was n ot recogni zed by the  system.   Please try  again." R  X:2 G A1
  33955   "RTN","CHM RESET",15, 0)
  33956    S Y=CHMFP DI
  33957   "RTN","CHM RESET",16, 0)
  33958    I $D(@(GL PAY_"""C"" ,Y)")) W ! !,*7,"PDI  HAS CLAIMS , RESETTIN G IS NOT A LLOWED." G  A1
  33959   "RTN","CHM RESET",17, 0)
  33960    D PROBSQ  I $D(PSQFL ) W !!,"PD I is in th e Problem  Support Qu eue, strip ping not a llowed." G  A1
  33961   "RTN","CHM RESET",18, 0)
  33962    D STATUS  I $D(INPFL ) W *7,!!, "PDI is in process, r esetting i s not allo wed." G A1
  33963   "RTN","CHM RESET",19, 0)
  33964    D BATCH I  $D(BATFL)  W *7,!!," PDI is in  an open ba tch, reset ting is no t allowed. " G A1
  33965   "RTN","CHM RESET",20, 0)
  33966    S CHMFPDI =Y I '$D(^ CHMIMG(CHM FPDI)) D N OPDI G A1
  33967   "RTN","CHM RESET",21, 0)
  33968    I '$D(^CH MIMG(CHMFP DI,0)) D N OPDI G A1
  33969   "RTN","CHM RESET",22, 0)
  33970    K CHIMGFG  D IMAGE G :$D(CHIMGF G) A1 D BA TCH1 G:$D( NOUSER) A3
  33971   "RTN","CHM RESET",23, 0)
  33972   A2 W ! S D IC=741002. 21,DIC(0)= "AEQLN",DI C("A")="En ter Vouche r Examiner : "
  33973   "RTN","CHM RESET",24, 0)
  33974    D ^DIC G: +Y=-1 A1 S  USER=$P(Y ,"^",2),NA M="UNKNOWN "
  33975   "RTN","CHM RESET",25, 0)
  33976    I USER'=" " S:$D(^VA (200,USER, 0)) NAM=$P (^VA(200,U SER,0),"^" ,1)
  33977   "RTN","CHM RESET",26, 0)
  33978    S DA=+Y
  33979   "RTN","CHM RESET",27, 0)
  33980    I ($P(^CH MDIC(74100 2.21,DA,0) ,"^",5)'=" ")!($P(^CH MDIC(74100 2.21,DA,0) ,"^",6)'=" ") D NOCAN  G A2
  33981   "RTN","CHM RESET",28, 0)
  33982    S DR=".05 ///^S X=CH MFPDI",DIE ="741002.2 1" D ^DIE  ; updates  CURRENT PD I
  33983   "RTN","CHM RESET",29, 0)
  33984    I $E(CHMF PDI,8,9)=9 0!($E(CHMF PDI,8,9)=9 7) D  ;CPE 005-119
  33985   "RTN","CHM RESET",30, 0)
  33986    . N ORIGP DI S ORIGP DI=$P($G(^ CHMIMG(CHM FPDI,"E-RE OPEN")),"^ ")
  33987   "RTN","CHM RESET",31, 0)
  33988    . S DR="3 ///^S X=OR IGPDI",DIE ="741002.2 1" D ^DIE  ; updates  ORIG PDI;  CPE005-119
  33989   "RTN","CHM RESET",32, 0)
  33990    . ;  upda tes curren t MENU pro cess value
  33991   "RTN","CHM RESET",33, 0)
  33992    . S DR=". 1////8",DI E="741002. 21" D ^DIE  ; NOTE: F ORCED W/O  VALIDATION  due to va lues not u pdated; CP E005-119
  33993   "RTN","CHM RESET",34, 0)
  33994    W !!,"PDI : ",CHMFPD I," Has be en reset f or image p rocessing  for ",NAM
  33995   "RTN","CHM RESET",35, 0)
  33996    S CHMQNAM ="IMAGE(", CHMIN=1 K  CHMOUT D ^ CHMIS041
  33997   "RTN","CHM RESET",36, 0)
  33998    S CHMFPP= "PDIRST" D  ^CHMFWK01
  33999   "RTN","CHM RESET",37, 0)
  34000    S:$D(^CHM IMG(CHMFPD I,"DOC"))  CHDOCID=+^ ("DOC")
  34001   "RTN","CHM RESET",38, 0)
  34002    S:$D(^VA( 200,USER,7 41010)) CH SS=$P(^(74 1010),"^", 1)
  34003   "RTN","CHM RESET",39, 0)
  34004    I $D(CHDO CID) I $D( CHSS) I CH DOCID'=""  I CHSS'=""  S CHIMMVE =1 D ENSET ^CHMMW1 K  CHIMMVE
  34005   "RTN","CHM RESET",40, 0)
  34006   A3 K ^CHMI MAGE(CHMFP DI),^CHMIM G(CHMFPDI, "PAUSE") S  $P(^CHMIM G(CHMFPDI, 0),"^",6)= 0
  34007   "RTN","CHM RESET",41, 0)
  34008    S $P(^CHM IMG(CHMFPD I,0),"^",4 )="",$P(^C HMIMG(CHMF PDI,0),"^" ,5)=""
  34009   "RTN","CHM RESET",42, 0)
  34010   END K SN,B N,CP,DIK,D A,Y Q
  34011   "RTN","CHM RESET",43, 0)
  34012   NOPDI W *7 ,*7,!!,"    INVALID P DI........ .." Q
  34013   "RTN","CHM RESET",44, 0)
  34014   NOCAN W *7 ,*7,!!,"    VE alread y has a PD I assigned  to them,  must be as signed to  a differen t VE" Q
  34015   "RTN","CHM RESET",45, 0)
  34016   PROBSQ K P SQFL Q:'$D (^CHMPSQ(" PDI",Y))
  34017   "RTN","CHM RESET",46, 0)
  34018    S PSQPT=0
  34019   "RTN","CHM RESET",47, 0)
  34020   PR1 S PSQP T=$O(^CHMP SQ("PDI",Y ,PSQPT)) Q :'PSQPT
  34021   "RTN","CHM RESET",48, 0)
  34022    G:'$D(^CH MPSQ(PSQPT ,0)) PR1
  34023   "RTN","CHM RESET",49, 0)
  34024    S PSSTAT= $P(^(0),"^ ",3)
  34025   "RTN","CHM RESET",50, 0)
  34026    I PSSTAT' =3 S PSQFL =1 Q
  34027   "RTN","CHM RESET",51, 0)
  34028    G PR1
  34029   "RTN","CHM RESET",52, 0)
  34030   STATUS S J =0 K INPFL
  34031   "RTN","CHM RESET",53, 0)
  34032   S1 S J=$O( ^CHMDIC(74 1002.21,J) ) Q:'J  G: '$D(^CHMDI C(741002.2 1,J,0)) S1
  34033   "RTN","CHM RESET",54, 0)
  34034    S CURPDI= $P(^CHMDIC (741002.21 ,J,0),"^", 5)
  34035   "RTN","CHM RESET",55, 0)
  34036    I CURPDI= Y S INPFL= 1 Q
  34037   "RTN","CHM RESET",56, 0)
  34038    G S1
  34039   "RTN","CHM RESET",57, 0)
  34040   BATCH K BA TFL Q:'$D( ^CHMIMPB(" C",Y))
  34041   "RTN","CHM RESET",58, 0)
  34042    S J=0,J=$ O(^CHMIMPB ("C",Y,J))  Q:'J
  34043   "RTN","CHM RESET",59, 0)
  34044    S K=0,K=$ O(^CHMIMPB ("C",Y,J,K )) Q:'K
  34045   "RTN","CHM RESET",60, 0)
  34046    Q:'$D(^CH MIMPB(J,0) )  I $P(^( 0),"^",6)= 1 S BATFL= 1
  34047   "RTN","CHM RESET",61, 0)
  34048    Q
  34049   "RTN","CHM RESET",62, 0)
  34050   BATCH1 Q:' $D(^CHMIMP B("C",CHMF PDI))
  34051   "RTN","CHM RESET",63, 0)
  34052    S J=0,J=$ O(^CHMIMPB ("C",CHMFP DI,J)) Q:' J
  34053   "RTN","CHM RESET",64, 0)
  34054    S K=0,K=$ O(^CHMIMPB ("C",CHMFP DI,J,K)) Q :'K
  34055   "RTN","CHM RESET",65, 0)
  34056    K NOUSER  Q:$P(^CHMI MPB(J,0)," ^",3)=1  S  NOUSER=1
  34057   "RTN","CHM RESET",66, 0)
  34058    S $P(^CHM IMPB(J,100 ,K,0),"^", 3)=0
  34059   "RTN","CHM RESET",67, 0)
  34060    S $P(^CHM IMG(CHMFPD I,0),"^",6 )=0
  34061   "RTN","CHM RESET",68, 0)
  34062    S ^CHMIMG ("MANUAL", CHMFPDI)=" "
  34063   "RTN","CHM RESET",69, 0)
  34064    W !!,"PDI  ",CHMFPDI ," has bee n reset fo r Batch ", J,"." Q
  34065   "RTN","CHM RESET",70, 0)
  34066   IMAGE Q:'$ D(^CHMIMG( CHMFPDI,0) )  S STAT= $P(^CHMIMG (CHMFPDI,0 ),"^",6)
  34067   "RTN","CHM RESET",71, 0)
  34068    I STAT=1  I $P(^CHMI MG(CHMFPDI ,0),"^",3) '=9944 S C HIMGFG=1 D  INPROG Q
  34069   "RTN","CHM RESET",72, 0)
  34070    I STAT=2  S CHIMGFG= 1 D INPROG  Q
  34071   "RTN","CHM RESET",73, 0)
  34072    K:$D(^CHM IMG("READY ",CHMFPDI) ) ^CHMIMG( "READY",CH MFPDI) Q
  34073   "RTN","CHM RESET",74, 0)
  34074   INPROG W ! !,"PDI is  already as signed, re setting no t allowed. " Q
  34075   "RTN","CHM RGRNT")
  34076   0^80^B4314 9143
  34077   "RTN","CHM RGRNT",1,0 )
  34078   CHMRGRNT ; SBB;GRANT  SUPERVISOR /VE REOPEN  EDI/SB CL AIMS ACCES S ;06/20/2 017  5:00  PM
  34079   "RTN","CHM RGRNT",2,0 )
  34080    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  34081   "RTN","CHM RGRNT",3,0 )
  34082    ;;SBB 06/ 20/2017 CP E005-007 I NITIAL CRE ATION
  34083   "RTN","CHM RGRNT",4,0 )
  34084    ;;
  34085   "RTN","CHM RGRNT",5,0 )
  34086    ;;
  34087   "RTN","CHM RGRNT",6,0 )
  34088    N DEFINED ,MENUOPT
  34089   "RTN","CHM RGRNT",7,0 )
  34090    D ^CHMFSE T
  34091   "RTN","CHM RGRNT",8,0 )
  34092   A0 ;
  34093   "RTN","CHM RGRNT",9,0 )
  34094    D TITLE K  DIC,DIC(0 ),DIC("A")
  34095   "RTN","CHM RGRNT",10, 0)
  34096    D INIT
  34097   "RTN","CHM RGRNT",11, 0)
  34098    I 'DEFINE D W !!,"ME NU OPTION  <CHMRGRNT>  NOT DEFIN ED IN THE  SYSTEM" H  2 Q
  34099   "RTN","CHM RGRNT",12, 0)
  34100    I '$$MENU CHK(DUZ,ME NUOPT) D E RRMSG H 2  Q
  34101   "RTN","CHM RGRNT",13, 0)
  34102    ; 
  34103   "RTN","CHM RGRNT",14, 0)
  34104    K DIC,DIC (0),DIC("A ")
  34105   "RTN","CHM RGRNT",15, 0)
  34106   A1 ;
  34107   "RTN","CHM RGRNT",16, 0)
  34108    W !!!,"En ter VE's n ame or DUZ : " D CSBR S^CHSC2
  34109   "RTN","CHM RGRNT",17, 0)
  34110    G:$D(DFOU T)!($D(DTO UT))!($D(D UOUT)) END
  34111   "RTN","CHM RGRNT",18, 0)
  34112    I $D(DQOU T) W !!,"A nswer with  VE's name  or DUZ."  G A1
  34113   "RTN","CHM RGRNT",19, 0)
  34114    G:Y="" EN D
  34115   "RTN","CHM RGRNT",20, 0)
  34116    S DIC=200 ,DIC(0)="E QNZ",X=Y D  ^DIC
  34117   "RTN","CHM RGRNT",21, 0)
  34118    I Y=-1 W  !!,"INVALI D INPUT."  G A1
  34119   "RTN","CHM RGRNT",22, 0)
  34120    S CHDUZZ= "" S:X'=""  CHDUZZ=+Y ,CHDZ=$P(Y ,"^",2)
  34121   "RTN","CHM RGRNT",23, 0)
  34122    G:CHDUZZ= "" A0
  34123   "RTN","CHM RGRNT",24, 0)
  34124    K DIC,DIC (0),DIC("A "),X
  34125   "RTN","CHM RGRNT",25, 0)
  34126    R X:2
  34127   "RTN","CHM RGRNT",26, 0)
  34128    ;
  34129   "RTN","CHM RGRNT",27, 0)
  34130   A2 ;
  34131   "RTN","CHM RGRNT",28, 0)
  34132    D TITLE
  34133   "RTN","CHM RGRNT",29, 0)
  34134    S ASGN=0, UASGN=0
  34135   "RTN","CHM RGRNT",30, 0)
  34136    W !!!,"1.  Assign"
  34137   "RTN","CHM RGRNT",31, 0)
  34138    W !,"2. U n-Assign"
  34139   "RTN","CHM RGRNT",32, 0)
  34140    W !!,"Sel ect One: "  D CSBRS^C HSC2
  34141   "RTN","CHM RGRNT",33, 0)
  34142    G:$D(DFOU T)!($D(DTO UT)) END
  34143   "RTN","CHM RGRNT",34, 0)
  34144    G:$D(DUOU T) A0
  34145   "RTN","CHM RGRNT",35, 0)
  34146    I $D(DQOU T) W !!,"S elect 1 or  2." R X:2  G A2
  34147   "RTN","CHM RGRNT",36, 0)
  34148    G:Y="" A0
  34149   "RTN","CHM RGRNT",37, 0)
  34150    I "12"'[Y  W *7,"  ? ?" R X:2 G  A2
  34151   "RTN","CHM RGRNT",38, 0)
  34152    I Y=1 S A SGN=1 G AS SIGN
  34153   "RTN","CHM RGRNT",39, 0)
  34154    I Y=2 S U ASGN=1 G U NASSIGN
  34155   "RTN","CHM RGRNT",40, 0)
  34156    ;
  34157   "RTN","CHM RGRNT",41, 0)
  34158   ASSIGN ;
  34159   "RTN","CHM RGRNT",42, 0)
  34160    D TITLE
  34161   "RTN","CHM RGRNT",43, 0)
  34162    S ASEL=0, CMNT=""
  34163   "RTN","CHM RGRNT",44, 0)
  34164    W !!!,"1.  Assign ED I CHAMPVA  ReOpen Sup ervisor Ke y"
  34165   "RTN","CHM RGRNT",45, 0)
  34166    W !,"2. A ssign EDI  CHAMPVA Re Open VE Ke y"
  34167   "RTN","CHM RGRNT",46, 0)
  34168    W !,"3. A ssign EDI  SB ReOpen  Supervisor  Key"
  34169   "RTN","CHM RGRNT",47, 0)
  34170    W !,"4. A ssign EDI  SB ReOpen  VE Key"
  34171   "RTN","CHM RGRNT",48, 0)
  34172    W !!,"Sel ect One: "  D CSBRS^C HSC2
  34173   "RTN","CHM RGRNT",49, 0)
  34174    G:$D(DFOU T)!($D(DTO UT)) END
  34175   "RTN","CHM RGRNT",50, 0)
  34176    G:$D(DUOU T) A2
  34177   "RTN","CHM RGRNT",51, 0)
  34178    I $D(DQOU T) W !!,"S elect 1, 2 , 3, or 4. " R X:2 G  ASSIGN
  34179   "RTN","CHM RGRNT",52, 0)
  34180    G:Y="" A2
  34181   "RTN","CHM RGRNT",53, 0)
  34182    I "1234"' [Y W *7,"   ??" R X:2  G ASSIGN
  34183   "RTN","CHM RGRNT",54, 0)
  34184    S ASEL=Y
  34185   "RTN","CHM RGRNT",55, 0)
  34186    S CMNT=$S (ASEL=1:"E DI CHAMPVA  ReOpen Su pervisor K ey",ASEL=2 :"EDI CHAM PVA ReOpen  VE Key",A SEL=3:"EDI  SB ReOpen  Superviso r Key",ASE L=4:"EDI S B ReOpen V E Key",1:" ")
  34187   "RTN","CHM RGRNT",56, 0)
  34188    G ASK
  34189   "RTN","CHM RGRNT",57, 0)
  34190    ;
  34191   "RTN","CHM RGRNT",58, 0)
  34192   UNASSIGN ;
  34193   "RTN","CHM RGRNT",59, 0)
  34194    D TITLE
  34195   "RTN","CHM RGRNT",60, 0)
  34196    S USEL=0, CMNTU=""
  34197   "RTN","CHM RGRNT",61, 0)
  34198    W !!!,"1.  Un-Assign  EDI CHAMP VA ReOpen  Supervisor  Key"
  34199   "RTN","CHM RGRNT",62, 0)
  34200    W !,"2. U n-Assign E DI CHAMPVA  ReOpen VE  Key"
  34201   "RTN","CHM RGRNT",63, 0)
  34202    W !,"3. U n-Assign E DI SB ReOp en Supervi sor Key"
  34203   "RTN","CHM RGRNT",64, 0)
  34204    W !,"4. U n-Assign E DI SB ReOp en VE Key"
  34205   "RTN","CHM RGRNT",65, 0)
  34206    W !!,"Sel ect One: "  D CSBRS^C HSC2
  34207   "RTN","CHM RGRNT",66, 0)
  34208    G:$D(DFOU T)!($D(DTO UT)) END
  34209   "RTN","CHM RGRNT",67, 0)
  34210    G:$D(DUOU T) A2
  34211   "RTN","CHM RGRNT",68, 0)
  34212    I $D(DQOU T) W !!,"S elect 1, 2 , 3, or 4. " R X:2 G  UNASSIGN
  34213   "RTN","CHM RGRNT",69, 0)
  34214    G:Y="" A2
  34215   "RTN","CHM RGRNT",70, 0)
  34216    I "1234"' [Y W *7,"   ??" R X:2  G UNASSIG N
  34217   "RTN","CHM RGRNT",71, 0)
  34218    S USEL=Y
  34219   "RTN","CHM RGRNT",72, 0)
  34220    S CMNTU=$ S(USEL=1:" EDI CHAMPV A ReOpen S upervisor  Key",USEL= 2:"EDI CHA MPVA ReOpe n VE Key", USEL=3:"ED I SB ReOpe n Supervis or Key",US EL=4:"EDI  SB ReOpen  VE Key",1: "")
  34221   "RTN","CHM RGRNT",73, 0)
  34222    G ASKU
  34223   "RTN","CHM RGRNT",74, 0)
  34224    ;
  34225   "RTN","CHM RGRNT",75, 0)
  34226   ASK ;
  34227   "RTN","CHM RGRNT",76, 0)
  34228    D TITLE
  34229   "RTN","CHM RGRNT",77, 0)
  34230    W !!!,"Yo u have gra nted "_CMN T_" access "
  34231   "RTN","CHM RGRNT",78, 0)
  34232    W !,"to " ,$P(^VA(20 0,CHDUZZ,0 ),U,1),"."
  34233   "RTN","CHM RGRNT",79, 0)
  34234    W !!,"Is  this corre ct?  Y// "  D CSBRS^C HSC2
  34235   "RTN","CHM RGRNT",80, 0)
  34236    G:$D(DFOU T)!($D(DTO UT)) END
  34237   "RTN","CHM RGRNT",81, 0)
  34238    G:$D(DUOU T) A2
  34239   "RTN","CHM RGRNT",82, 0)
  34240    I $D(DQOU T) W !!,"A nswer with  <Y>es or  <N>o." R X :2 G ASK
  34241   "RTN","CHM RGRNT",83, 0)
  34242    I Y="" S  Y="Y"
  34243   "RTN","CHM RGRNT",84, 0)
  34244    S Y=$E(Y)  I "YyNn"' [Y W *7,"   ??" R X:2  G ASK
  34245   "RTN","CHM RGRNT",85, 0)
  34246    G:Y="N" A SSIGN
  34247   "RTN","CHM RGRNT",86, 0)
  34248    G SET
  34249   "RTN","CHM RGRNT",87, 0)
  34250    ;
  34251   "RTN","CHM RGRNT",88, 0)
  34252   ASKU ;
  34253   "RTN","CHM RGRNT",89, 0)
  34254    D TITLE
  34255   "RTN","CHM RGRNT",90, 0)
  34256    W !!!,"Yo u have rev oked "_CMN TU_" acces s"
  34257   "RTN","CHM RGRNT",91, 0)
  34258    W !,"to " ,$P(^VA(20 0,CHDUZZ,0 ),U,1),"."
  34259   "RTN","CHM RGRNT",92, 0)
  34260    W !!,"Is  this corre ct?  Y// "  D CSBRS^C HSC2
  34261   "RTN","CHM RGRNT",93, 0)
  34262    G:$D(DFOU T)!($D(DTO UT)) END
  34263   "RTN","CHM RGRNT",94, 0)
  34264    G:$D(DUOU T) A2
  34265   "RTN","CHM RGRNT",95, 0)
  34266    I $D(DQOU T) W !!,"A nswer with  <Y>es or  <N>o." R X :2 G ASK
  34267   "RTN","CHM RGRNT",96, 0)
  34268    I Y="" S  Y="Y"
  34269   "RTN","CHM RGRNT",97, 0)
  34270    S Y=$E(Y)  I "YyNn"' [Y W *7,"   ??" R X:2  G ASK
  34271   "RTN","CHM RGRNT",98, 0)
  34272    G:Y="N" U NASSIGN
  34273   "RTN","CHM RGRNT",99, 0)
  34274    G SETU
  34275   "RTN","CHM RGRNT",100 ,0)
  34276    ;
  34277   "RTN","CHM RGRNT",101 ,0)
  34278   SET ;
  34279   "RTN","CHM RGRNT",102 ,0)
  34280    N INC
  34281   "RTN","CHM RGRNT",103 ,0)
  34282    S INC=1
  34283   "RTN","CHM RGRNT",104 ,0)
  34284    K DIC,DIC (0),DIC("A "),Y,AKEY, AUKEY
  34285   "RTN","CHM RGRNT",105 ,0)
  34286    S AKEY=$S (ASEL=1:93 3,ASEL=2:9 34,ASEL=3: 935,ASEL=4 :936,1:"")
  34287   "RTN","CHM RGRNT",106 ,0)
  34288    S AUKEY=$ S(ASEL=2:6 ,ASEL=4:7, 1:"")
  34289   "RTN","CHM RGRNT",107 ,0)
  34290    Q:AKEY=""
  34291   "RTN","CHM RGRNT",108 ,0)
  34292    I $D(^VA( 200,CHDUZZ ,51,AKEY))  D  Q
  34293   "RTN","CHM RGRNT",109 ,0)
  34294    . W !,"Ke y already  assigned ! !" R X:1
  34295   "RTN","CHM RGRNT",110 ,0)
  34296    . Q
  34297   "RTN","CHM RGRNT",111 ,0)
  34298    W !,"Assi gn "_CMNT_ " "_$P(^DI C(19.1,AKE Y,0),"^")  R X:1
  34299   "RTN","CHM RGRNT",112 ,0)
  34300    ;
  34301   "RTN","CHM RGRNT",113 ,0)
  34302    D NOW^%DT C S NOWDT= X K X
  34303   "RTN","CHM RGRNT",114 ,0)
  34304    ;S DA(1)= CHDUZZ,DR= ".01///^S  X=AKEY;.02 ///^S X=DU Z;.03///^S  X=NOWDT", DIE="^VA(2 00,"_DA(1) _",51",DA= AKEY D ^DI E
  34305   "RTN","CHM RGRNT",115 ,0)
  34306    S ^VA(200 ,CHDUZZ,51 ,AKEY,0)=A KEY_"^"_DU Z_"^"_NOWD T
  34307   "RTN","CHM RGRNT",116 ,0)
  34308    S ^VA(200 ,CHDUZZ,51 ,"B",AKEY, AKEY)=""
  34309   "RTN","CHM RGRNT",117 ,0)
  34310    S INC=$P( ^VA(200,CH DUZZ,51,0) ,"^",4),IN C=INC+1
  34311   "RTN","CHM RGRNT",118 ,0)
  34312    S $P(^VA( 200,CHDUZZ ,51,0),"^" ,4)=INC
  34313   "RTN","CHM RGRNT",119 ,0)
  34314    S $P(^CHM DIC(741002 .21,CHDUZZ ,0),"^",10 )=AUKEY
  34315   "RTN","CHM RGRNT",120 ,0)
  34316    G ASSIGN
  34317   "RTN","CHM RGRNT",121 ,0)
  34318    ;
  34319   "RTN","CHM RGRNT",122 ,0)
  34320   SETU ;
  34321   "RTN","CHM RGRNT",123 ,0)
  34322    ;
  34323   "RTN","CHM RGRNT",124 ,0)
  34324    N DEC
  34325   "RTN","CHM RGRNT",125 ,0)
  34326    S DEC=0
  34327   "RTN","CHM RGRNT",126 ,0)
  34328    K DIC,DIC (0),DIC("A "),Y,UKEY, UUKEY
  34329   "RTN","CHM RGRNT",127 ,0)
  34330    S UKEY=$S (USEL=1:93 3,USEL=2:9 34,USEL=3: 935,USEL=4 :936,1:"")
  34331   "RTN","CHM RGRNT",128 ,0)
  34332    S UUKEY=" "
  34333   "RTN","CHM RGRNT",129 ,0)
  34334    Q:UKEY=""
  34335   "RTN","CHM RGRNT",130 ,0)
  34336    W !,"UnAs sign "_CMN TU_" "_$P( ^DIC(19.1, UKEY,0),"^ ") R X:1
  34337   "RTN","CHM RGRNT",131 ,0)
  34338    I '$D(^VA (200,CHDUZ Z,51,UKEY) ) D  Q 
  34339   "RTN","CHM RGRNT",132 ,0)
  34340    . W !,"Ke y already  un-assigne d !!" R X: 1
  34341   "RTN","CHM RGRNT",133 ,0)
  34342    . Q
  34343   "RTN","CHM RGRNT",134 ,0)
  34344    D NOW^%DT C S NOWDT= X K X
  34345   "RTN","CHM RGRNT",135 ,0)
  34346    ;S DA(1)= CHDUZZ,DR= ".01///^S  X=AKEY;.02 ///^S X=DU Z;.03///^S  X=NOWDT", DIE="^VA(2 00,"_DA(1) _",51",DA= AKEY D ^DI E
  34347   "RTN","CHM RGRNT",136 ,0)
  34348    K ^VA(200 ,CHDUZZ,51 ,UKEY,0)
  34349   "RTN","CHM RGRNT",137 ,0)
  34350    K ^VA(200 ,CHDUZZ,51 ,"B",UKEY, UKEY)
  34351   "RTN","CHM RGRNT",138 ,0)
  34352    S DEC=$P( ^VA(200,CH DUZZ,51,0) ,"^",4),DE C=DEC-1
  34353   "RTN","CHM RGRNT",139 ,0)
  34354    I DEC<0 S  DEC=0
  34355   "RTN","CHM RGRNT",140 ,0)
  34356    S $P(^VA( 200,CHDUZZ ,51,0),"^" ,4)=DEC
  34357   "RTN","CHM RGRNT",141 ,0)
  34358    S $P(^CHM DIC(741002 .21,CHDUZZ ,0),"^",10 )=UUKEY
  34359   "RTN","CHM RGRNT",142 ,0)
  34360    G UNASSIG N
  34361   "RTN","CHM RGRNT",143 ,0)
  34362    ;
  34363   "RTN","CHM RGRNT",144 ,0)
  34364   S1 ;
  34365   "RTN","CHM RGRNT",145 ,0)
  34366    S DA=CHDU ZZ
  34367   "RTN","CHM RGRNT",146 ,0)
  34368    I '$D(^CH MDIC(74100 2.21,DA,70 1,0)) S ^C HMDIC(7410 02.21,DA,7 01,0)="^74 1002.21701 D^0^0"
  34369   "RTN","CHM RGRNT",147 ,0)
  34370    D NOW^%DT C S DA(1)= DA,DIC="^C HMDIC(7410 02.21,"_DA _",701,",D IC(0)="ML" ,X=% D ^DI C
  34371   "RTN","CHM RGRNT",148 ,0)
  34372    S DIE=DIC  S DA=+Y
  34373   "RTN","CHM RGRNT",149 ,0)
  34374    S DR=".02 ////^S X=D UZ;.03///^ S X=CHMPDI " D ^DIE
  34375   "RTN","CHM RGRNT",150 ,0)
  34376    K DIE,X,D R
  34377   "RTN","CHM RGRNT",151 ,0)
  34378    Q
  34379   "RTN","CHM RGRNT",152 ,0)
  34380   S2 ;
  34381   "RTN","CHM RGRNT",153 ,0)
  34382    S DA=CHDU ZZ
  34383   "RTN","CHM RGRNT",154 ,0)
  34384    I '$D(^CH MDIC(74100 2.21,DA,70 1,0)) S ^C HMDIC(7410 02.21,DA,7 01,0)="^74 1002.21701 D^0^0"
  34385   "RTN","CHM RGRNT",155 ,0)
  34386    D NOW^%DT C S DA(1)= DA,DIC="^C HMDIC(7410 02.21,"_DA _",701,",D IC(0)="ML" ,X=% D ^DI C
  34387   "RTN","CHM RGRNT",156 ,0)
  34388    S DIE=DIC  S DA=+Y
  34389   "RTN","CHM RGRNT",157 ,0)
  34390    S DR=".02 ////^S X=D UZ;.04///^ S X=CHMCLM " D ^DIE
  34391   "RTN","CHM RGRNT",158 ,0)
  34392    K DIE,X,D R
  34393   "RTN","CHM RGRNT",159 ,0)
  34394    Q
  34395   "RTN","CHM RGRNT",160 ,0)
  34396   END ;
  34397   "RTN","CHM RGRNT",161 ,0)
  34398    K X,Y,CHD Z,CHDUZZ,P DIFL,CLMFL ,DFOUT,DTO UT,DUOUT,D QOUT,CHMCL M,CHMPDI
  34399   "RTN","CHM RGRNT",162 ,0)
  34400    K DIC,DIC (0),DIC("A "),DIE,DR, DA
  34401   "RTN","CHM RGRNT",163 ,0)
  34402    X CHRESET  Q
  34403   "RTN","CHM RGRNT",164 ,0)
  34404    Q
  34405   "RTN","CHM RGRNT",165 ,0)
  34406    ;
  34407   "RTN","CHM RGRNT",166 ,0)
  34408    ; Initial ize the re quired var iables
  34409   "RTN","CHM RGRNT",167 ,0)
  34410   INIT ;
  34411   "RTN","CHM RGRNT",168 ,0)
  34412    ;
  34413   "RTN","CHM RGRNT",169 ,0)
  34414    S DEFINED =0
  34415   "RTN","CHM RGRNT",170 ,0)
  34416    S MENUOPT =$O(^DIC(1 9,"B","CHM RGRNT","") )
  34417   "RTN","CHM RGRNT",171 ,0)
  34418    I MENUOPT '="" S DEF INED=1
  34419   "RTN","CHM RGRNT",172 ,0)
  34420    Q
  34421   "RTN","CHM RGRNT",173 ,0)
  34422    ;
  34423   "RTN","CHM RGRNT",174 ,0)
  34424    ; Check i f the opti on CHMRGRN T is in th e secondar y menu lis t for the  user or no t.
  34425   "RTN","CHM RGRNT",175 ,0)
  34426   MENUCHK(DU Z,MENUOPT)  ;
  34427   "RTN","CHM RGRNT",176 ,0)
  34428    ;
  34429   "RTN","CHM RGRNT",177 ,0)
  34430    N RTN
  34431   "RTN","CHM RGRNT",178 ,0)
  34432    S RTN=0
  34433   "RTN","CHM RGRNT",179 ,0)
  34434    I $D(^VA( 200,DUZ,20 3,"B",MENU OPT)) S RT N=1
  34435   "RTN","CHM RGRNT",180 ,0)
  34436    Q RTN
  34437   "RTN","CHM RGRNT",181 ,0)
  34438    ;
  34439   "RTN","CHM RGRNT",182 ,0)
  34440   ERRMSG ;
  34441   "RTN","CHM RGRNT",183 ,0)
  34442    ;
  34443   "RTN","CHM RGRNT",184 ,0)
  34444    W !!,"Use r "_$P(^VA (200,DUZ,0 ),"^")_" d oes not ha ve the req uired opti on "_$P(^D IC(19,MENU OPT,0),"^" )_" in sec ondary men u list"
  34445   "RTN","CHM RGRNT",185 ,0)
  34446    Q
  34447   "RTN","CHM RGRNT",186 ,0)
  34448    ;
  34449   "RTN","CHM RGRNT",187 ,0)
  34450    ; Title f or the opt ion
  34451   "RTN","CHM RGRNT",188 ,0)
  34452   TITLE ;
  34453   "RTN","CHM RGRNT",189 ,0)
  34454    ;
  34455   "RTN","CHM RGRNT",190 ,0)
  34456    W @IOF,!, ?21,"Assig n/Un-Assig n EDI Re-O pen Access "
  34457   "RTN","CHM RGRNT",191 ,0)
  34458    Q
  34459   "RTN","CHM RGRNT",192 ,0)
  34460    ;
  34461   "RTN","CHM RGRNT",193 ,0)
  34462    ; Used by  sys admin  to set th e option t o user
  34463   "RTN","CHM RGRNT",194 ,0)
  34464   SETMNOPT(D UZ,MENUOPT ) ;
  34465   "RTN","CHM RGRNT",195 ,0)
  34466    ;
  34467   "RTN","CHM RGRNT",196 ,0)
  34468    I '$D(^VA (200,DUZ,0 )) W !!,"N ot a valid  DUZ "_DUZ  Q
  34469   "RTN","CHM RGRNT",197 ,0)
  34470    I '$D(^DI C(19,"B",M ENUOPT)) W  !!,"Not a  valid opt ion "_MENU OPT Q
  34471   "RTN","CHM RGRNT",198 ,0)
  34472    N MENUOPT PTR,NEWNOD E,TOTALNOD ES
  34473   "RTN","CHM RGRNT",199 ,0)
  34474    S MENUOPT PTR=$O(^DI C(19,"B",M ENUOPT,0)) ,NEWNODE=0 ,TOTALNODE S=0
  34475   "RTN","CHM RGRNT",200 ,0)
  34476    S NEWNODE =$P(^VA(20 0,DUZ,203, 0),"^",3)+ 1
  34477   "RTN","CHM RGRNT",201 ,0)
  34478    S TOTALNO DES=$P(^VA (200,DUZ,2 03,0),"^", 4)+1
  34479   "RTN","CHM RGRNT",202 ,0)
  34480    ;//S DR=" .01///^S X =MENUOPTPT R",DIE="^V A(200,DUZ, 203",DA=NE WNODE D ^D IE
  34481   "RTN","CHM RGRNT",203 ,0)
  34482    S $P(^VA( 200,DUZ,20 3,0),"^",3 )=NEWNODE
  34483   "RTN","CHM RGRNT",204 ,0)
  34484    S $P(^VA( 200,DUZ,20 3,0),"^",4 )=TOTALNOD ES
  34485   "RTN","CHM RGRNT",205 ,0)
  34486    S ^VA(200 ,DUZ,203,N EWNODE,0)= MENUOPTPTR
  34487   "RTN","CHM RGRNT",206 ,0)
  34488    S ^VA(200 ,DUZ,203," B",MENUOPT PTR,NEWNOD E)=""
  34489   "RTN","CHM RGRNT",207 ,0)
  34490    Q
  34491   "RTN","CHM RGRNT",208 ,0)
  34492    ;
  34493   "RTN","CHM RSQC")
  34494   0^64^B1631 07973
  34495   "RTN","CHM RSQC",1,0)
  34496   CHMRSQC ;D EN/CJM;SUM MARY AGING  OF QUEUES /MORNING R EPORT - CA LC;09/01/9 8  8:44 AM
  34497   "RTN","CHM RSQC",2,0)
  34498    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  34499   "RTN","CHM RSQC",3,0)
  34500    ; PT 1593 2 (Y2K)
  34501   "RTN","CHM RSQC",4,0)
  34502    ;V1.03;DE N/CJM;UPDA TE VENQ FO R NEW VEND OR PACKAGE ;06/10/93
  34503   "RTN","CHM RSQC",5,0)
  34504    ;V1.02;DE N/CJM;RCR  GLOBAL FOR  CRASH REC OVERY,LOCK  CALC 1 US ER;01/28/9 3
  34505   "RTN","CHM RSQC",6,0)
  34506    ;REVISED  BY RLC;12/ 20/95;ADDE D TOTALS F OR CMOP CL AIMS
  34507   "RTN","CHM RSQC",7,0)
  34508    ;CHANGE R EQUEST DEV 001625:AHJ  6/22/07 A DD CODING  QUEUE
  34509   "RTN","CHM RSQC",8,0)
  34510    ;CHCNT =o ne queue t otal
  34511   "RTN","CHM RSQC",9,0)
  34512    ;CHCNTT=a ll queues  total
  34513   "RTN","CHM RSQC",10,0 )
  34514    ;
  34515   "RTN","CHM RSQC",11,0 )
  34516    ;CHO10 =c laims 1 -  10days in  a queue
  34517   "RTN","CHM RSQC",12,0 )
  34518    ;CHO10T=c laims 1 -  10days in  all queues
  34519   "RTN","CHM RSQC",13,0 )
  34520    ;
  34521   "RTN","CHM RSQC",14,0 )
  34522    ;CHO14 =c laims 11 -  14days in  a queue
  34523   "RTN","CHM RSQC",15,0 )
  34524    ;CHO14T=c laims 11 -  14days in  all queue s
  34525   "RTN","CHM RSQC",16,0 )
  34526    ;
  34527   "RTN","CHM RSQC",17,0 )
  34528    ;CHO21 =c laims 14 -  21days in  a queue
  34529   "RTN","CHM RSQC",18,0 )
  34530    ;CHO21T=c laims 14 -  21days in  all queue s
  34531   "RTN","CHM RSQC",19,0 )
  34532    ;
  34533   "RTN","CHM RSQC",20,0 )
  34534    ;CHO29 =c laims 22 -  29days in  a queue
  34535   "RTN","CHM RSQC",21,0 )
  34536    ;CHO29T=c laims 22 -  29days in  all queue s
  34537   "RTN","CHM RSQC",22,0 )
  34538    ;
  34539   "RTN","CHM RSQC",23,0 )
  34540    ;CHO30 =c laims over  29days in  a queue
  34541   "RTN","CHM RSQC",24,0 )
  34542    ;CHO30T=c laims over  29days in  all queue s
  34543   "RTN","CHM RSQC",25,0 )
  34544    ;
  34545   "RTN","CHM RSQC",26,0 )
  34546    ;I = CITI
  34547   "RTN","CHM RSQC",27,0 )
  34548    ;E = ALL  EDI
  34549   "RTN","CHM RSQC",28,0 )
  34550    ;M = MEDI CAL MATRIX
  34551   "RTN","CHM RSQC",29,0 )
  34552    ;C = CMOP
  34553   "RTN","CHM RSQC",30,0 )
  34554    ;N = NON  VA
  34555   "RTN","CHM RSQC",31,0 )
  34556    ;S = SB
  34557   "RTN","CHM RSQC",32,0 )
  34558    ;H = CHAM PVA/HAC
  34559   "RTN","CHM RSQC",33,0 )
  34560    ;F = X12  & OCR
  34561   "RTN","CHM RSQC",34,0 )
  34562    ;W = CWVV
  34563   "RTN","CHM RSQC",35,0 )
  34564    ;L = CFL
  34565   "RTN","CHM RSQC",36,0 )
  34566    ;X = SXC
  34567   "RTN","CHM RSQC",37,0 )
  34568    ;R = Cham pVA EDI RE OPEN (prog ram indica tor 97)
  34569   "RTN","CHM RSQC",38,0 )
  34570    ;B = SB E DI REOPEN  (program i ndicator 9 0) - WTC 9 .1.17
  34571   "RTN","CHM RSQC",39,0 )
  34572    ;
  34573   "RTN","CHM RSQC",40,0 )
  34574    ;  CPE005 -016A HM 8 .29.17
  34575   "RTN","CHM RSQC",41,0 )
  34576    ;  CPE005 -016B WTC  9.1.17
  34577   "RTN","CHM RSQC",42,0 )
  34578    ;
  34579   "RTN","CHM RSQC",43,0 )
  34580    ;
  34581   "RTN","CHM RSQC",44,0 )
  34582   MAIN D INI T^CHMRSQC1
  34583   "RTN","CHM RSQC",45,0 )
  34584    D CPGLC^C HMRSQC1
  34585   "RTN","CHM RSQC",46,0 )
  34586    F QUE="AU D","DUP"," MIS","COQ" ,"PRO","QA CPD","QAQM D","VEN"," ELG","EOB" ,"CAL","CA P","GRP"," MCCR" D CA LC
  34587   "RTN","CHM RSQC",47,0 )
  34588    D TOTSET^ CHMRSQC1
  34589   "RTN","CHM RSQC",48,0 )
  34590    S ^CHMRSQ 1("MARSQC" ,"RESTART" )=RUNTIME
  34591   "RTN","CHM RSQC",49,0 )
  34592    D CPGLS^C HMRSQC1
  34593   "RTN","CHM RSQC",50,0 )
  34594    D QREP^CH MRSQC1 
  34595   "RTN","CHM RSQC",51,0 )
  34596    D KI^CHMR SQC1
  34597   "RTN","CHM RSQC",52,0 )
  34598   END Q
  34599   "RTN","CHM RSQC",53,0 )
  34600   CALC S CHD TB="",CHDI Q=""
  34601   "RTN","CHM RSQC",54,0 )
  34602    S:$D(^CHM RSQ1("MARS QC",QUE,"O DT")) CHDT B=$P(^CHMR SQ1("MARSQ C",QUE,"OD T"),U,1)
  34603   "RTN","CHM RSQC",55,0 )
  34604    S:CHDTB'= "" CHDIQ=C HDTB-.0000 01
  34605   "RTN","CHM RSQC",56,0 )
  34606    S:CHDTB=" " CHDIQ=RE START
  34607   "RTN","CHM RSQC",57,0 )
  34608    S (CHCNT, CHCNTI,CHC NTE,CHCNTM ,CHCNTC,CH CNTN,CHCNT S,CHCNTH,C HCNTF,CHCN TW,CHCNTL, CHCNTX,CHC NTR,CHCNTB )=0 ; WTC  9.1.17
  34609   "RTN","CHM RSQC",58,0 )
  34610    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  34611   "RTN","CHM RSQC",59,0 )
  34612    ;S (CHO30 ,CHO30I,CH O30E,CHO30 M,CHO30C,C HO30N,CHO3 0S,CHO30H, CHO30F,CHO 30W,CHO30L )=0
  34613   "RTN","CHM RSQC",60,0 )
  34614    ;S (CHO60 ,CHO60I,CH O60E,CHO60 M,CHO60C,C HO60N,CHO6 0S,CHO60H, CHO60F,CHO 60W,CHO60L )=0
  34615   "RTN","CHM RSQC",61,0 )
  34616    ;S (CHO90 ,CHO90I,CH O90E,CHO90 M,CHO90C,C HO90N,CHO9 0S,CHO90H, CHO90F,CHO 90W,CHO90L )=0
  34617   "RTN","CHM RSQC",62,0 )
  34618    ;S (CHO91 ,CHO91I,CH O91E,CHO91 M,CHO91C,C HO91N,CHO9 1S,CHO91H, CHO91F,CHO 91W,CHO91L )=0
  34619   "RTN","CHM RSQC",63,0 )
  34620    ;HR-PBM-P HASE 1-Beg in - SLM
  34621   "RTN","CHM RSQC",64,0 )
  34622    ;Added SX C vars at  the end
  34623   "RTN","CHM RSQC",65,0 )
  34624    ;HM CPE00 5-016a ADD ED EDI REO PEN 08/29/ 2017
  34625   "RTN","CHM RSQC",66,0 )
  34626    ; WTC CPE 005-016B A dded EDI R eOpen for  SB 9/1/17
  34627   "RTN","CHM RSQC",67,0 )
  34628    S (CHO10, CHO10I,CHO 10E,CHO10M ,CHO10C,CH O10N,CHO10 S,CHO10H,C HO10F,CHO1 0W,CHO10L, CHO10X,CHO 10R,CHO10B )=0 ; WTC  9.1.17
  34629   "RTN","CHM RSQC",68,0 )
  34630    S (CHO14, CHO14I,CHO 14E,CHO14M ,CHO14C,CH O14N,CHO14 S,CHO14H,C HO14F,CHO1 4W,CHO14L, CHO14X,CHO 14R,CHO14B )=0 ; WTC  9.1.17
  34631   "RTN","CHM RSQC",69,0 )
  34632    S (CHO21, CHO21I,CHO 21E,CHO21M ,CHO21C,CH O21N,CHO21 S,CHO21H,C HO21F,CHO2 1W,CHO21L, CHO21X,CHO 21R,CHO21B )=0 ; WTC  9.1.17
  34633   "RTN","CHM RSQC",70,0 )
  34634    S (CHO29, CHO29I,CHO 29E,CHO29M ,CHO29C,CH O29N,CHO29 S,CHO29H,C HO29F,CHO2 9W,CHO29L, CHO29X,CHO 29R,CHO29B )=0 ; WTC  9.1.17
  34635   "RTN","CHM RSQC",71,0 )
  34636    S (CHO30, CHO30I,CHO 30E,CHO30M ,CHO30C,CH O30N,CHO30 S,CHO30H,C HO30F,CHO3 0W,CHO30L, CHO30X,CHO 30R,CHO30B )=0 ; WTC  9.1.17
  34637   "RTN","CHM RSQC",72,0 )
  34638    ;HR-PBM-P HASE 1-End
  34639   "RTN","CHM RSQC",73,0 )
  34640    ;END MOD  PER DEV000 272, SKD 6 -27-07
  34641   "RTN","CHM RSQC",74,0 )
  34642    ;
  34643   "RTN","CHM RSQC",75,0 )
  34644    ;HM CPE00 5-016a ADD ED EDI REO PEN 08/29/ 2017
  34645   "RTN","CHM RSQC",76,0 )
  34646    ; WTC CPE 005-016B A dded EDI R eOpen for  SB 9/1/17
  34647   "RTN","CHM RSQC",77,0 )
  34648    S (CHOLD, CHOLDI,CHO LDE,CHOLDM ,CHOLDC,CH OLDN,CHOLD S,CHOLDH,C HOLDF,CHOL DW,CHOLDL, CHOLDX,CHO LDR,CHOLDB )=0 ; WTC  9.1.17
  34649   "RTN","CHM RSQC",78,0 )
  34650    S (CHODT, CHODTI,CHO DTE,CHODTM ,CHODTC,CH ODTN,CHODT S,CHODTH,C HODTF,CHOD TW,CHODTL, CHODTX,CHO DTR,CHODTB )=9999999. 999999 ; W TC 9.1.17
  34651   "RTN","CHM RSQC",79,0 )
  34652    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  34653   "RTN","CHM RSQC",80,0 )
  34654    ;S X1=$P( CHDTE,".", 1),X2=-30  D C^%DTC S  CHDT30=X
  34655   "RTN","CHM RSQC",81,0 )
  34656    ;S X1=$P( CHDTE,".", 1),X2=-60  D C^%DTC S  CHDT60=X
  34657   "RTN","CHM RSQC",82,0 )
  34658    ;S X1=$P( CHDTE,".", 1),X2=-90  D C^%DTC S  CHDT90=X
  34659   "RTN","CHM RSQC",83,0 )
  34660    ;S X1=$P( CHDTE,".", 1),X2=-91  D C^%DTC S  CHDTO90=X
  34661   "RTN","CHM RSQC",84,0 )
  34662    S X1=$P(C HDTE,".",1 ),X2=-10 D  C^%DTC S  CHDT10=X
  34663   "RTN","CHM RSQC",85,0 )
  34664    S X1=$P(C HDTE,".",1 ),X2=-14 D  C^%DTC S  CHDT14=X
  34665   "RTN","CHM RSQC",86,0 )
  34666    S X1=$P(C HDTE,".",1 ),X2=-21 D  C^%DTC S  CHDT21=X
  34667   "RTN","CHM RSQC",87,0 )
  34668    S X1=$P(C HDTE,".",1 ),X2=-29 D  C^%DTC S  CHDT29=X
  34669   "RTN","CHM RSQC",88,0 )
  34670    S X1=$P(C HDTE,".",1 ),X2=-30 D  C^%DTC S  CHDT30=X
  34671   "RTN","CHM RSQC",89,0 )
  34672    ;END MOD  PER DEV000 272, SKD 6 -27-07
  34673   "RTN","CHM RSQC",90,0 )
  34674    ;
  34675   "RTN","CHM RSQC",91,0 )
  34676    I QUE="DU P" D DUP^C HMRSQC1 G  CALC1
  34677   "RTN","CHM RSQC",92,0 )
  34678    I QUE="EO B" D EOB^C HMRSQC1 G  CALC1
  34679   "RTN","CHM RSQC",93,0 )
  34680    I QUE="VE N" D VEN^C HMRSQC1 G  CALC1
  34681   "RTN","CHM RSQC",94,0 )
  34682    I QUE="GR P" D GRP^C HMRSQC1 G  CALC1
  34683   "RTN","CHM RSQC",95,0 )
  34684    I QUE="CA L" D CAL^C HMRSQC1 G  CALC1
  34685   "RTN","CHM RSQC",96,0 )
  34686    I QUE="CA P" D CAP^C HMRSQC1 G  CALC1
  34687   "RTN","CHM RSQC",97,0 )
  34688    D @QUE
  34689   "RTN","CHM RSQC",98,0 )
  34690   CALC1 ;"I"  - INHOUSE            "E" - ALL  EDI (X12,O CR,CMOP,MM ATRIX)
  34691   "RTN","CHM RSQC",99,0 )
  34692    ;"M" - ME DICAL MATR IX   "C" -  CMOP
  34693   "RTN","CHM RSQC",100, 0)
  34694    ;"N" - NO N-VA            "S" -  SPINA BIF IDA
  34695   "RTN","CHM RSQC",101, 0)
  34696    ;"H" - CH AMPVA ONLY      "F" -  EDI ONLY  (no CMOP,  no MMATRIX )
  34697   "RTN","CHM RSQC",102, 0)
  34698    ;"W" - CW VV ONLY        "L" -  CFL ONLY
  34699   "RTN","CHM RSQC",103, 0)
  34700    ;HR-PBM-P HASE 1-Beg in - SLM
  34701   "RTN","CHM RSQC",104, 0)
  34702    ;"X" - SX
  34703   "RTN","CHM RSQC",105, 0)
  34704    ;
  34705   "RTN","CHM RSQC",106, 0)
  34706    S:CHOLD=0  CHOLD=""  S:CHOLDI=0  CHOLDI=""  S:CHOLDE= 0 CHOLDE=" "
  34707   "RTN","CHM RSQC",107, 0)
  34708    S:CHOLDM= 0 CHOLDM=" " S:CHOLDC =0 CHOLDC= "" S:CHOLD N=0 CHOLDN =""
  34709   "RTN","CHM RSQC",108, 0)
  34710    S:CHOLDS= 0 CHOLDS=" " S:CHOLDH =0 CHOLDH= "" S:CHOLD F=0 CHOLDF =""
  34711   "RTN","CHM RSQC",109, 0)
  34712    S:CHOLDW= 0 CHOLDW=" " S:CHOLDL =0 CHOLDL= ""
  34713   "RTN","CHM RSQC",110, 0)
  34714    ;HM EDI R EOPEN CPE0 05-016A 08 /29/2017
  34715   "RTN","CHM RSQC",111, 0)
  34716    S:CHOLDR= 0 CHOLDR=" "
  34717   "RTN","CHM RSQC",112, 0)
  34718    S:CHOLDB= 0 CHOLDB=" " ; WTC 9. 1.17 
  34719   "RTN","CHM RSQC",113, 0)
  34720    S:CHODT=9 999999.999 999 CHODT= "" S:CHODT I=9999999. 999999 CHO DTI=""
  34721   "RTN","CHM RSQC",114, 0)
  34722    S:CHODTE= 9999999.99 9999 CHODT E="" S:CHO DTM=999999 9.999999 C HODTM=""
  34723   "RTN","CHM RSQC",115, 0)
  34724    S:CHODTC= 9999999.99 9999 CHODT C="" S:CHO DTN=999999 9.999999 C HODTN=""
  34725   "RTN","CHM RSQC",116, 0)
  34726    S:CHODTF= 9999999.99 9999 CHODT F="" S:CHO DTX=999999 9.999999 C HODTX=""
  34727   "RTN","CHM RSQC",117, 0)
  34728    S:CHODTW= 9999999.99 9999 CHODT W="" S:CHO DTL=999999 9.999999 C HODTL=""
  34729   "RTN","CHM RSQC",118, 0)
  34730    ;HM EDI R EOPEN CPE0 05-016A 08 /29/2017
  34731   "RTN","CHM RSQC",119, 0)
  34732    S:CHODTR= 9999999.99 9999 CHODT R=""
  34733   "RTN","CHM RSQC",120, 0)
  34734    S:CHODTB= 9999999.99 9999 CHODT B="" ; WTC  9.1.17
  34735   "RTN","CHM RSQC",121, 0)
  34736    S:CHODT=" " CHODT="^ " S:CHODTI ="" CHODTI ="^" S:CHO DTE="" CHO DTE="^"
  34737   "RTN","CHM RSQC",122, 0)
  34738    S:CHODTM= "" CHODTM= "^" S:CHOD TC="" CHOD TC="^" S:C HODTN="" C HODTN="^"
  34739   "RTN","CHM RSQC",123, 0)
  34740    S:CHODTH= "" CHODTH= "^" S:CHOD TS="" CHOD TS="^" S:C HODTF="" C HODTF="^"
  34741   "RTN","CHM RSQC",124, 0)
  34742    S:CHODTW= "" CHODTW= "^" S:CHOD TL="" CHOD TL="^" S:C HODTX="" C HODTX="^"
  34743   "RTN","CHM RSQC",125, 0)
  34744    ;HM EDI R EOPEN CPE0 05-016A 08 /29/2017
  34745   "RTN","CHM RSQC",126, 0)
  34746    S:CHODTR= "" CHODTR= "^"
  34747   "RTN","CHM RSQC",127, 0)
  34748    S:CHODTB= "" CHODTB= "^" ; WTC  9.1.17
  34749   "RTN","CHM RSQC",128, 0)
  34750    ;
  34751   "RTN","CHM RSQC",129, 0)
  34752    S ^CHMRSQ 1("MARSQC" ,QUE,"CNT" )=CHCNT_U_ CHCNTI_U_C HCNTE_U_CH CNTM_U_CHC NTC_U_CHCN TN_U_CHCNT S_U_CHCNTH _U_CHCNTF_ U_CHCNTW_U _CHCNTL_U_ CHCNTX_U_C HCNTR_U_CH ODTB ; WTC  9.1.17
  34753   "RTN","CHM RSQC",130, 0)
  34754    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  34755   "RTN","CHM RSQC",131, 0)
  34756    ;S ^CHMRS Q1("MARSQC ",QUE,"O30 ")=CHO30_U _CHO30I_U_ CHO30E_U_C HO30M_U_CH O30C_U_CHO 30N_U_CHO3 0S_U_CHO30 H_U_CHO30F _U_CHO30W_ U_CHO30L
  34757   "RTN","CHM RSQC",132, 0)
  34758    ;S ^CHMRS Q1("MARSQC ",QUE,"O60 ")=CHO60_U _CHO60I_U_ CHO60E_U_C HO60M_U_CH O60C_U_CHO 60N_U_CHO6 0S_U_CHO60 H_U_CHO60F _U_CHO60W_ U_CHO60L
  34759   "RTN","CHM RSQC",133, 0)
  34760    ;S ^CHMRS Q1("MARSQC ",QUE,"O90 ")=CHO90_U _CHO90I_U_ CHO90E_U_C HO90M_U_CH O90C_U_CHO 90N_U_CHO9 0S_U_CHO90 H_U_CHO90F _U_CHO90W_ U_CHO90L
  34761   "RTN","CHM RSQC",134, 0)
  34762    ;S ^CHMRS Q1("MARSQC ",QUE,"O91 ")=CHO91_U _CHO91I_U_ CHO91E_U_C HO91M_U_CH O91C_U_CHO 91N_U_CHO9 1S_U_CHO91 H_U_CHO91F _U_CHO91W_ U_CHO91L
  34763   "RTN","CHM RSQC",135, 0)
  34764    S ^CHMRSQ 1("MARSQC" ,QUE,"O10" )=CHO10_U_ CHO10I_U_C HO10E_U_CH O10M_U_CHO 10C_U_CHO1 0N_U_CHO10 S_U_CHO10H _U_CHO10F_ U_CHO10W_U _CHO10L_U_ CHO10X_U_C HO10R_U_CH O10B ; WTC  9.1.17
  34765   "RTN","CHM RSQC",136, 0)
  34766    S ^CHMRSQ 1("MARSQC" ,QUE,"O14" )=CHO14_U_ CHO14I_U_C HO14E_U_CH O14M_U_CHO 14C_U_CHO1 4N_U_CHO14 S_U_CHO14H _U_CHO14F_ U_CHO14W_U _CHO14L_U_ CHO14X_U_C HO14R_U_CH O14B ; WTC  9.1.17
  34767   "RTN","CHM RSQC",137, 0)
  34768    S ^CHMRSQ 1("MARSQC" ,QUE,"O21" )=CHO21_U_ CHO21I_U_C HO21E_U_CH O21M_U_CHO 21C_U_CHO2 1N_U_CHO21 S_U_CHO21H _U_CHO21F_ U_CHO21W_U _CHO21L_U_ CHO21X_U_C HO21R_U_CH O21B ; WTC  9.1.17
  34769   "RTN","CHM RSQC",138, 0)
  34770    S ^CHMRSQ 1("MARSQC" ,QUE,"O29" )=CHO29_U_ CHO29I_U_C HO29E_U_CH O29M_U_CHO 29C_U_CHO2 9N_U_CHO29 S_U_CHO29H _U_CHO29F_ U_CHO29W_U _CHO29L_U_ CHO29X_U_C HO29R_U_CH O29B ; WTC  9.1.17
  34771   "RTN","CHM RSQC",139, 0)
  34772    S ^CHMRSQ 1("MARSQC" ,QUE,"O30" )=CHO30_U_ CHO30I_U_C HO30E_U_CH O30M_U_CHO 30C_U_CHO3 0N_U_CHO30 S_U_CHO30H _U_CHO30F_ U_CHO30W_U _CHO30L_U_ CHO30X_U_C HO30R_U_CH O30B ; WTC  9.1.17
  34773   "RTN","CHM RSQC",140, 0)
  34774    ;END MOD  PER DEV000 272, SKD 6 -27-07
  34775   "RTN","CHM RSQC",141, 0)
  34776    S ^CHMRSQ 1("MARSQC" ,QUE,"OLD" )=CHOLD_U_ CHOLDI_U_C HOLDE_U_CH OLDM_U_CHO LDC_U_CHOL DN_U_CHOLD S_U_CHOLDH _U_CHOLDF_ U_CHOLDW_U _CHOLDL_U_ CHOLDX_U_C HOLDR_U_CH OLDB ; WTC  9.1.17
  34777   "RTN","CHM RSQC",142, 0)
  34778    S ^CHMRSQ 1("MARSQC" ,QUE,"ODT" )=CHODT_U_ CHODTI_U_C HODTE_U_CH ODTM_U_CHO DTC_U_CHOD TN_U_CHODT S_U_CHODTH _U_CHODTF_ U_CHODTW_U _CHODTL_U_ CHODTX_U_C HODTR_U_CH ODTB ; WTC  9.1.17
  34779   "RTN","CHM RSQC",143, 0)
  34780   CALCEND Q
  34781   "RTN","CHM RSQC",144, 0)
  34782    ;;HR-PBM- PHASE 1-En d
  34783   "RTN","CHM RSQC",145, 0)
  34784   ELG F CHST AT=0,1,3,4 ,5,6 S CHD FN=0 F  S  CHDFN=$O(^ CHMELQ("D" ,CHSTAT,CH DFN)) Q:'C HDFN  S CH BFN=0 F  S  CHBFN=$O( ^CHMELQ("D ",CHSTAT,C HDFN,CHBFN )) Q:'CHBF N  S CHI=0  F  S CHI= $O(^CHMELQ ("D",CHSTA T,CHDFN,CH BFN,CHI))  Q:'CHI  D  ELG1
  34785   "RTN","CHM RSQC",146, 0)
  34786   ELGEND Q
  34787   "RTN","CHM RSQC",147, 0)
  34788   ELG1 G:'$D (^CHMELQ(C HI,0)) ELG 1END
  34789   "RTN","CHM RSQC",148, 0)
  34790    S QREC=^C HMELQ(CHI, 0)
  34791   "RTN","CHM RSQC",149, 0)
  34792    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,6)
  34793   "RTN","CHM RSQC",150, 0)
  34794    G:QDT>CHD TE ELG1END
  34795   "RTN","CHM RSQC",151, 0)
  34796    G:QCL=""  ELG1END
  34797   "RTN","CHM RSQC",152, 0)
  34798    S X1=QCL  D PROGTYP^ CHFCD001
  34799   "RTN","CHM RSQC",153, 0)
  34800    G:'$D(@(G LPAY_"QCL, 0)")) ELGE ND
  34801   "RTN","CHM RSQC",154, 0)
  34802    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  34803   "RTN","CHM RSQC",155, 0)
  34804    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  34805   "RTN","CHM RSQC",156, 0)
  34806    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  34807   "RTN","CHM RSQC",157, 0)
  34808    .;S QDT=$ $JULFM(TMP QDT)  ;Y2K
  34809   "RTN","CHM RSQC",158, 0)
  34810    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  34811   "RTN","CHM RSQC",159, 0)
  34812    D CNT^CHM RSQC1
  34813   "RTN","CHM RSQC",160, 0)
  34814   ELG1END Q
  34815   "RTN","CHM RSQC",161, 0)
  34816   AUD F CHST AT=0,1 S C HQDT=0 F   S CHQDT=$O (^CHMASQ(" D",CHSTAT, CHQDT)) Q: 'CHQDT  S  CHI=0 F  S  CHI=$O(^C HMASQ("D", CHSTAT,CHQ DT,CHI)) Q :'CHI  D A UD1
  34817   "RTN","CHM RSQC",162, 0)
  34818   AUDEND Q
  34819   "RTN","CHM RSQC",163, 0)
  34820   AUD1 G:'$D (^CHMASQ(C HI,0)) AUD 1END
  34821   "RTN","CHM RSQC",164, 0)
  34822    S QREC=^C HMASQ(CHI, 0)
  34823   "RTN","CHM RSQC",165, 0)
  34824    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,6)
  34825   "RTN","CHM RSQC",166, 0)
  34826    G:QDT>CHD TE AUD1END
  34827   "RTN","CHM RSQC",167, 0)
  34828    G:QCL=""  AUD1END
  34829   "RTN","CHM RSQC",168, 0)
  34830    S X1=QCL  D PROGTYP^ CHFCD001
  34831   "RTN","CHM RSQC",169, 0)
  34832    G:'$D(@(G LPAY_"QCL, 0)")) AUD1 END
  34833   "RTN","CHM RSQC",170, 0)
  34834    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  34835   "RTN","CHM RSQC",171, 0)
  34836    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D  
  34837   "RTN","CHM RSQC",172, 0)
  34838    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  34839   "RTN","CHM RSQC",173, 0)
  34840    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  34841   "RTN","CHM RSQC",174, 0)
  34842    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  34843   "RTN","CHM RSQC",175, 0)
  34844    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  34845   "RTN","CHM RSQC",176, 0)
  34846    D CNT^CHM RSQC1
  34847   "RTN","CHM RSQC",177, 0)
  34848   AUD1END Q
  34849   "RTN","CHM RSQC",178, 0)
  34850   MIS F CHST AT=0,1 S C HQDT=0 F   S CHQDT=$O (^CHMMDQ(" D",CHSTAT, CHQDT)) Q: 'CHQDT  S  CHI=0 F  S  CHI=$O(^C HMMDQ("D", CHSTAT,CHQ DT,CHI)) Q :'CHI  D M IS1
  34851   "RTN","CHM RSQC",179, 0)
  34852   MISEND Q
  34853   "RTN","CHM RSQC",180, 0)
  34854   MIS1 G:'$D (^CHMMDQ(C HI,0)) MIS 1END
  34855   "RTN","CHM RSQC",181, 0)
  34856    S QREC=^C HMMDQ(CHI, 0)
  34857   "RTN","CHM RSQC",182, 0)
  34858    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3),QREA S=$P(QREC, U,6)
  34859   "RTN","CHM RSQC",183, 0)
  34860    G:QDT>CHD TE MIS1END
  34861   "RTN","CHM RSQC",184, 0)
  34862    G:QREAS=7  MIS1END
  34863   "RTN","CHM RSQC",185, 0)
  34864    G:QCL=""  MIS1END
  34865   "RTN","CHM RSQC",186, 0)
  34866    S X1=QCL  D PROGTYP^ CHFCD001
  34867   "RTN","CHM RSQC",187, 0)
  34868    G:'$D(@(G LPAY_"QCL, 0)")) MIS1 END
  34869   "RTN","CHM RSQC",188, 0)
  34870    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  34871   "RTN","CHM RSQC",189, 0)
  34872    ;I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D   
  34873   "RTN","CHM RSQC",190, 0)
  34874    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  34875   "RTN","CHM RSQC",191, 0)
  34876    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  34877   "RTN","CHM RSQC",192, 0)
  34878    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  34879   "RTN","CHM RSQC",193, 0)
  34880    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  34881   "RTN","CHM RSQC",194, 0)
  34882    ;S ^CHMZH OLD("ZSKD" ,"MIS",CHC NT,QCL)=QC L_U_$P(@(G LPAY_"QCL, 0)"),"^",1 )_U_QDT_U_ CHPGPT_U_$ P(@(GLPAY_ "QCL,0)"), U,3)_U_$D( @(GLPAY_"Q CL,""ZEMC" ")"))   ;S KD 7-1-07  REMOVE THE  LINE AFTE R TESTING
  34883   "RTN","CHM RSQC",195, 0)
  34884    D CNT^CHM RSQC1
  34885   "RTN","CHM RSQC",196, 0)
  34886   MIS1END Q
  34887   "RTN","CHM RSQC",197, 0)
  34888    ;
  34889   "RTN","CHM RSQC",198, 0)
  34890    ;
  34891   "RTN","CHM RSQC",199, 0)
  34892    ;COQ F CH STAT=0,1 S  CHQDT=0 F   S CHQDT= $O(^CHMMDQ ("D",CHSTA T,CHQDT))  Q:'CHQDT   S CHI=0 F   S CHI=$O( ^CHMMDQ("D ",CHSTAT,C HQDT,CHI))  Q:'CHI  D  COQ1
  34893   "RTN","CHM RSQC",200, 0)
  34894    ;COQEND Q
  34895   "RTN","CHM RSQC",201, 0)
  34896    ;
  34897   "RTN","CHM RSQC",202, 0)
  34898    ;COQ1 G:' $D(^CHMMDQ (CHI,0)) C OQ1END
  34899   "RTN","CHM RSQC",203, 0)
  34900    ;S QREC=^ CHMMDQ(CHI ,0)
  34901   "RTN","CHM RSQC",204, 0)
  34902    ;S QDT=$P ($P(QREC,U ,1),".",1) ,QCL=$P(QR EC,U,2),QS TAT=$P(QRE C,U,3),QRE AS=$P(QREC ,U,6)
  34903   "RTN","CHM RSQC",205, 0)
  34904    ;G:QDT>CH DTE COQ1EN D
  34905   "RTN","CHM RSQC",206, 0)
  34906    ;G:QREAS' =7 COQ1END
  34907   "RTN","CHM RSQC",207, 0)
  34908    ;G:QCL=""  COQ1END
  34909   "RTN","CHM RSQC",208, 0)
  34910    ;S X1=QCL  D PROGTYP ^CHFCD001
  34911   "RTN","CHM RSQC",209, 0)
  34912    ;G:'$D(@( GLPAY_"QCL ,0)")) COQ 1END
  34913   "RTN","CHM RSQC",210, 0)
  34914    ;S QCLJ=9 99999999,Q CLJ=$O(@(G LPAY_"QCL, ""PDI"",QC LJ)"),-1)
  34915   "RTN","CHM RSQC",211, 0)
  34916    ;I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D   
  34917   "RTN","CHM RSQC",212, 0)
  34918    ;I ;QCLJ' ="",$D(@(G LPAY_"QCL, ""PDI"",QC LJ,0)")) D
  34919   "RTN","CHM RSQC",213, 0)
  34920    ;.S TMPQD T=$P(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)"),"^", 1)
  34921   "RTN","CHM RSQC",214, 0)
  34922    ;.;S QDT= $$JULFM(TM PQDT)  ; Y 2K
  34923   "RTN","CHM RSQC",215, 0)
  34924    ;.S QDT=$ $PDIJULFM^ CHMFPDI2(T MPQDT)
  34925   "RTN","CHM RSQC",216, 0)
  34926    ;D CNT^CH MRSQC1
  34927   "RTN","CHM RSQC",217, 0)
  34928    ;COQ1END  Q
  34929   "RTN","CHM RSQC",218, 0)
  34930    ;
  34931   "RTN","CHM RSQC",219, 0)
  34932    ;THIS SEC TION CODIN G QUEUE RE PLACED PRE VIOUS SECT ION ABOVE  :DEV001625 :AHJ
  34933   "RTN","CHM RSQC",220, 0)
  34934    ;
  34935   "RTN","CHM RSQC",221, 0)
  34936   COQ S CHQS TAT=1 S CH TMPDT="" F   S CHTMPD T=$O(^CHMA SQ("D",CHS TAT,CHTMPD T)) Q:'CHT MPDT  S CH QI=0 F  S  CHQI=$O(^C HMASQ("D", CHQSTAT,CH TMPDT,CHQI )) Q:'CHQI   D COQ1   ;TLH 9/11/ 07 ENC0016 28
  34937   "RTN","CHM RSQC",222, 0)
  34938   COQEND Q
  34939   "RTN","CHM RSQC",223, 0)
  34940    ;
  34941   "RTN","CHM RSQC",224, 0)
  34942   COQ1 G:'$D (^CHMASQ(C HQI,0)) CO Q1END  ;TL H 9/11/07  ENC001628
  34943   "RTN","CHM RSQC",225, 0)
  34944    S QREC=^C HMASQ(CHQI ,0)  ;TLH  9/11/07 EN C0011628
  34945   "RTN","CHM RSQC",226, 0)
  34946    S QSTATUS =$P(QREC,U ,6)
  34947   "RTN","CHM RSQC",227, 0)
  34948    I QSTATUS '=1 G COQ1 END
  34949   "RTN","CHM RSQC",228, 0)
  34950    I '$D(^CH MASQ(CHQI, 100)) G CO Q1END  ;TL H 9/11/07  ENC001628
  34951   "RTN","CHM RSQC",229, 0)
  34952    S QDT=$P( QREC,U,1)
  34953   "RTN","CHM RSQC",230, 0)
  34954    S QDT=$E( QDT,1,7)
  34955   "RTN","CHM RSQC",231, 0)
  34956    S QCL=$P( QREC,U,2)
  34957   "RTN","CHM RSQC",232, 0)
  34958    G:QDT>CHD TE COQ1END
  34959   "RTN","CHM RSQC",233, 0)
  34960    G:QCL=""  COQ1END
  34961   "RTN","CHM RSQC",234, 0)
  34962    S X1=QCL  D PROGTYP^ CHFCD001
  34963   "RTN","CHM RSQC",235, 0)
  34964    G:'$D(@(G LPAY_"QCL, 0)")) COQ1 END
  34965   "RTN","CHM RSQC",236, 0)
  34966    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  34967   "RTN","CHM RSQC",237, 0)
  34968    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  34969   "RTN","CHM RSQC",238, 0)
  34970    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  34971   "RTN","CHM RSQC",239, 0)
  34972    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  34973   "RTN","CHM RSQC",240, 0)
  34974    D CNT^CHM RSQC1
  34975   "RTN","CHM RSQC",241, 0)
  34976   COQ1END Q 
  34977   "RTN","CHM RSQC",242, 0)
  34978    ;
  34979   "RTN","CHM RSQC",243, 0)
  34980   PRO F CHST AT=1,2 S C HQDT=0 F   S CHQDT=$O (^CHMPSQ(" D",CHSTAT, CHQDT)) Q: 'CHQDT  S  CHI=0 F  S  CHI=$O(^C HMPSQ("D", CHSTAT,CHQ DT,CHI)) Q :'CHI  D P RO1
  34981   "RTN","CHM RSQC",244, 0)
  34982   PROEND Q
  34983   "RTN","CHM RSQC",245, 0)
  34984   PRO1 G:'$D (^CHMPSQ(C HI,0)) PRO 1END
  34985   "RTN","CHM RSQC",246, 0)
  34986    S QREC=^C HMPSQ(CHI, 0)
  34987   "RTN","CHM RSQC",247, 0)
  34988    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3),QPDI =$P(QREC,U ,8)
  34989   "RTN","CHM RSQC",248, 0)
  34990    G:QDT>CHD TE PRO1END
  34991   "RTN","CHM RSQC",249, 0)
  34992    G:QCL=""  PRO1A
  34993   "RTN","CHM RSQC",250, 0)
  34994    S X1=QCL  D PROGTYP^ CHFCD001
  34995   "RTN","CHM RSQC",251, 0)
  34996    G:'$D(@(G LPAY_"QCL, 0)")) PRO1 A
  34997   "RTN","CHM RSQC",252, 0)
  34998    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  34999   "RTN","CHM RSQC",253, 0)
  35000    ;I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D
  35001   "RTN","CHM RSQC",254, 0)
  35002    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35003   "RTN","CHM RSQC",255, 0)
  35004    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35005   "RTN","CHM RSQC",256, 0)
  35006    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35007   "RTN","CHM RSQC",257, 0)
  35008    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35009   "RTN","CHM RSQC",258, 0)
  35010    D CNT^CHM RSQC1 G PR O1END
  35011   "RTN","CHM RSQC",259, 0)
  35012   PRO1A G:QP DI="" PRO1 END
  35013   "RTN","CHM RSQC",260, 0)
  35014    G:'$D(^CH MIMG(QPDI, 0)) PRO1EN D
  35015   "RTN","CHM RSQC",261, 0)
  35016    ;S QDT=$$ JULFM(QPDI )  ; Y2K
  35017   "RTN","CHM RSQC",262, 0)
  35018    S QDT=$$P DIJULFM^CH MFPDI2(QPD I)
  35019   "RTN","CHM RSQC",263, 0)
  35020    D CNTPDI^ CHMRSQC1
  35021   "RTN","CHM RSQC",264, 0)
  35022   PRO1END Q
  35023   "RTN","CHM RSQC",265, 0)
  35024   QAQMD F CH STAT=0,1,4 ,5,6 S CHQ DT=0 F  S  CHQDT=$O(^ CHMQAQ("C" ,CHSTAT,CH QDT)) Q:'C HQDT  S CH I=0 F  S C HI=$O(^CHM QAQ("C",CH STAT,CHQDT ,CHI)) Q:' CHI  D QUA 1
  35025   "RTN","CHM RSQC",266, 0)
  35026   QUAEND Q
  35027   "RTN","CHM RSQC",267, 0)
  35028    ;
  35029   "RTN","CHM RSQC",268, 0)
  35030   QUA1 G:'$D (^CHMQAQ(C HI,0)) QUA 1END
  35031   "RTN","CHM RSQC",269, 0)
  35032    S QREC=^C HMQAQ(CHI, 0)
  35033   "RTN","CHM RSQC",270, 0)
  35034    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3)
  35035   "RTN","CHM RSQC",271, 0)
  35036    I QCL=134 58237 
  35037   "RTN","CHM RSQC",272, 0)
  35038    G:QDT>CHD TE QUA1END
  35039   "RTN","CHM RSQC",273, 0)
  35040    S CHJ=0,C HJ=$O(^CHM QAQ(CHI,1, CHJ)),QAI= ""
  35041   "RTN","CHM RSQC",274, 0)
  35042    I CHJ'="" ,$D(^CHMQA Q(CHI,1,CH J,0)) S QA I=^CHMQAQ( CHI,1,CHJ, 0)
  35043   "RTN","CHM RSQC",275, 0)
  35044    G:QAI=7 Q UA1END G:Q AI=10 QUA1 END G:QAI= 9 QUA1END  G:QAI=12 Q UA1END
  35045   "RTN","CHM RSQC",276, 0)
  35046    G:QCL=""  QUA1END
  35047   "RTN","CHM RSQC",277, 0)
  35048    S X1=QCL  D PROGTYP^ CHFCD001
  35049   "RTN","CHM RSQC",278, 0)
  35050    G:'$D(@(G LPAY_"QCL, 0)")) QUA1 END
  35051   "RTN","CHM RSQC",279, 0)
  35052    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35053   "RTN","CHM RSQC",280, 0)
  35054    ;I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D
  35055   "RTN","CHM RSQC",281, 0)
  35056    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35057   "RTN","CHM RSQC",282, 0)
  35058    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35059   "RTN","CHM RSQC",283, 0)
  35060    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35061   "RTN","CHM RSQC",284, 0)
  35062    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35063   "RTN","CHM RSQC",285, 0)
  35064    D CNT^CHM RSQC1
  35065   "RTN","CHM RSQC",286, 0)
  35066   QUA1END Q
  35067   "RTN","CHM RSQC",287, 0)
  35068   QACPD F CH STAT=0,1,4 ,5,6 S CHQ DT=0 F  S  CHQDT=$O(^ CHMQAQ("C" ,CHSTAT,CH QDT)) Q:'C HQDT  S CH I=0 F  S C HI=$O(^CHM QAQ("C",CH STAT,CHQDT ,CHI)) Q:' CHI  D QUA 21
  35069   "RTN","CHM RSQC",288, 0)
  35070   QUA2END Q
  35071   "RTN","CHM RSQC",289, 0)
  35072   QUA21 G:'$ D(^CHMQAQ( CHI,0)) QU A21END
  35073   "RTN","CHM RSQC",290, 0)
  35074    S QREC=^C HMQAQ(CHI, 0)
  35075   "RTN","CHM RSQC",291, 0)
  35076    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3)
  35077   "RTN","CHM RSQC",292, 0)
  35078    G:QDT>CHD TE QUA21EN D
  35079   "RTN","CHM RSQC",293, 0)
  35080    S CHJ=0,C HJ=$O(^CHM QAQ(CHI,1, CHJ)),QAI= ""
  35081   "RTN","CHM RSQC",294, 0)
  35082    I CHJ'="" ,$D(^CHMQA Q(CHI,1,CH J,0)) S QA I=^CHMQAQ( CHI,1,CHJ, 0)
  35083   "RTN","CHM RSQC",295, 0)
  35084    I QAI'=7  I QAI'=10  I QAI'=9 I  QAI'=12 G  QUA21END
  35085   "RTN","CHM RSQC",296, 0)
  35086    I QCL=""  G QUA21END
  35087   "RTN","CHM RSQC",297, 0)
  35088    S X1=QCL  D PROGTYP^ CHFCD001 I  QCL=12171 620 S ^TON Y("CPD-QAQ ",QCL)=CHI
  35089   "RTN","CHM RSQC",298, 0)
  35090    ;I CHPGPT =5 S ^CHMZ HOLD("QAQ- CPD","NVA" ,CHQDT,QCL )=""
  35091   "RTN","CHM RSQC",299, 0)
  35092    I '$D(@(G LPAY_"QCL, 0)")) G QU A21END
  35093   "RTN","CHM RSQC",300, 0)
  35094    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35095   "RTN","CHM RSQC",301, 0)
  35096    ;I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D
  35097   "RTN","CHM RSQC",302, 0)
  35098    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35099   "RTN","CHM RSQC",303, 0)
  35100    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35101   "RTN","CHM RSQC",304, 0)
  35102    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35103   "RTN","CHM RSQC",305, 0)
  35104    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35105   "RTN","CHM RSQC",306, 0)
  35106    D CNT^CHM RSQC1
  35107   "RTN","CHM RSQC",307, 0)
  35108   QUA21END Q
  35109   "RTN","CHM RSQC",308, 0)
  35110   REO F CHST AT=0,1 S C HQDT=0 F   S CHQDT=$O (^CHMREOPQ ("D",CHSTA T,CHQDT))  Q:'CHQDT   S CHI=0 F   S CHI=$O( ^CHMREOPQ( "D",CHSTAT ,CHQDT,CHI )) Q:'CHI   D REO1
  35111   "RTN","CHM RSQC",309, 0)
  35112   REOEND Q
  35113   "RTN","CHM RSQC",310, 0)
  35114   REO1 G:'$D (^CHMREOPQ (CHI,0)) R EO1END
  35115   "RTN","CHM RSQC",311, 0)
  35116    S QREC=^C HMREOPQ(CH I,0)
  35117   "RTN","CHM RSQC",312, 0)
  35118    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3)
  35119   "RTN","CHM RSQC",313, 0)
  35120    G:QDT>CHD TE REO1END
  35121   "RTN","CHM RSQC",314, 0)
  35122    G:QCL=""  REO1END
  35123   "RTN","CHM RSQC",315, 0)
  35124    S X1=QCL  D PROGTYP^ CHFCD001
  35125   "RTN","CHM RSQC",316, 0)
  35126    G:'$D(@(G LPAY_"QCL, 0)")) REO1 END
  35127   "RTN","CHM RSQC",317, 0)
  35128    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35129   "RTN","CHM RSQC",318, 0)
  35130    ;I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D
  35131   "RTN","CHM RSQC",319, 0)
  35132    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35133   "RTN","CHM RSQC",320, 0)
  35134    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35135   "RTN","CHM RSQC",321, 0)
  35136    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35137   "RTN","CHM RSQC",322, 0)
  35138    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35139   "RTN","CHM RSQC",323, 0)
  35140    D CNT^CHM RSQC1
  35141   "RTN","CHM RSQC",324, 0)
  35142   REO1END Q
  35143   "RTN","CHM RSQC",325, 0)
  35144   MCCR F CHS TAT=0,1 S  CHQDT=0 F   S CHQDT=$ O(^CHMCCR( "C",CHSTAT ,CHQDT)) Q :'CHQDT  S  CHI=0 F   S CHI=$O(^ CHMCCR("C" ,CHSTAT,CH QDT,CHI))  Q:'CHI  D  MCCR1
  35145   "RTN","CHM RSQC",326, 0)
  35146   MCCREND Q
  35147   "RTN","CHM RSQC",327, 0)
  35148   MCCR1 G:'$ D(^CHMCCR( CHI,0)) MC R1END
  35149   "RTN","CHM RSQC",328, 0)
  35150    S QREC=^C HMCCR(CHI, 0)
  35151   "RTN","CHM RSQC",329, 0)
  35152    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3)
  35153   "RTN","CHM RSQC",330, 0)
  35154    G:QDT>CHD TE MCR1END
  35155   "RTN","CHM RSQC",331, 0)
  35156    G:QCL=""  MCR1END
  35157   "RTN","CHM RSQC",332, 0)
  35158    S X1=QCL  D PROGTYP^ CHFCD001
  35159   "RTN","CHM RSQC",333, 0)
  35160    ;I CHPGPT =6 S ^CHMZ HOLD("SB_I N_MCCR",QC L)=QDT
  35161   "RTN","CHM RSQC",334, 0)
  35162    G:'$D(@(G LPAY_"QCL, 0)")) MCR1 END
  35163   "RTN","CHM RSQC",335, 0)
  35164    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35165   "RTN","CHM RSQC",336, 0)
  35166    ;I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D
  35167   "RTN","CHM RSQC",337, 0)
  35168    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35169   "RTN","CHM RSQC",338, 0)
  35170    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35171   "RTN","CHM RSQC",339, 0)
  35172    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35173   "RTN","CHM RSQC",340, 0)
  35174    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35175   "RTN","CHM RSQC",341, 0)
  35176    D CNT^CHM RSQC1
  35177   "RTN","CHM RSQC",342, 0)
  35178   MCR1END Q
  35179   "RTN","CHM RSQC",343, 0)
  35180   FMJUL(FDT)  ;CONVERT  FM DATE TO  JULIAN DA TE
  35181   "RTN","CHM RSQC",344, 0)
  35182    N D1,D2,D 3
  35183   "RTN","CHM RSQC",345, 0)
  35184    I '$D(FDT ) S FDT=DT
  35185   "RTN","CHM RSQC",346, 0)
  35186    S X=$E(FD T,1,3)_"00 00" D H^%D TC S D2=%H
  35187   "RTN","CHM RSQC",347, 0)
  35188    S X=FDT D  H^%DTC S  D1=%H
  35189   "RTN","CHM RSQC",348, 0)
  35190    S D3=D1-D 2+1 S:D3<1 00 D3="0"_ D3 S:D3<10  D3="0"_D3
  35191   "RTN","CHM RSQC",349, 0)
  35192    S D3=$E(F DT,2,3)_D3
  35193   "RTN","CHM RSQC",350, 0)
  35194    Q D3
  35195   "RTN","CHM RSQC",351, 0)
  35196   JULFM(JDT)  ;CONVERT  JULIAN DAT E TO FM DA TE
  35197   "RTN","CHM RSQC",352, 0)
  35198    I '$D(JDT ) S JDT=$$ FMJUL(DT)
  35199   "RTN","CHM RSQC",353, 0)
  35200    S X=1900+ $E(JDT,1,2 )-1700_"00 00" D H^%D TC
  35201   "RTN","CHM RSQC",354, 0)
  35202    S %H=%H+$ E(JDT,3,5) -1 D YMD^% DTC
  35203   "RTN","CHM RSQC",355, 0)
  35204    Q X
  35205   "RTN","CHM RSQC",356, 0)
  35206   FYR(FDT) ; RETURN FIS CAL YEAR A S YYY1001  FROM FM DA TE
  35207   "RTN","CHM RSQC",357, 0)
  35208    N Y,M,FYR
  35209   "RTN","CHM RSQC",358, 0)
  35210    I '$D(FDT ) S FDT=DT
  35211   "RTN","CHM RSQC",359, 0)
  35212    S Y=$E(FD T,1,3),M=$ E(FDT,4,5)
  35213   "RTN","CHM RSQC",360, 0)
  35214    S FYR=Y_" 1001" I M< 10 S Y=Y-1 ,FYR=Y_"10 01"
  35215   "RTN","CHM RSQC",361, 0)
  35216    Q FYR
  35217   "RTN","CHM RSQC1")
  35218   0^65^B4131 69972
  35219   "RTN","CHM RSQC1",1,0 )
  35220   CHMRSQC1 ; CVA/AEB;ST ATUS OF QU EUES/MORNI NG REPORT  - CALC SUB ROUTINES;0 9/01/98  8 :44 AM
  35221   "RTN","CHM RSQC1",2,0 )
  35222    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  35223   "RTN","CHM RSQC1",3,0 )
  35224    ;COPY OF  CHMRSQC
  35225   "RTN","CHM RSQC1",4,0 )
  35226    ; CPE005- 016A HM 8/ 29/17
  35227   "RTN","CHM RSQC1",5,0 )
  35228    ; CPE005- 016B WTC 9 /1/17
  35229   "RTN","CHM RSQC1",6,0 )
  35230    ;
  35231   "RTN","CHM RSQC1",7,0 )
  35232   INIT D NOW ^%DTC S RU NTIME=%
  35233   "RTN","CHM RSQC1",8,0 )
  35234    S U="^"
  35235   "RTN","CHM RSQC1",9,0 )
  35236    I '$D(^CH MRSQ1("MAR SQ","RESTA RT")) S ^C HMRSQ1("MA RSQ","REST ART")=$$FY R(DT)
  35237   "RTN","CHM RSQC1",10, 0)
  35238    S RESTART =^CHMRSQ1( "MARSQ","R ESTART")
  35239   "RTN","CHM RSQC1",11, 0)
  35240    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35241   "RTN","CHM RSQC1",12, 0)
  35242    ;S (CHCNT T,CHO30T,C HCNTTI,CHO 30TI,CHCNT TE,CHO30TE ,CHCNTTM,C HO30TM,CHC NTTC,CHO30 TC)=0
  35243   "RTN","CHM RSQC1",13, 0)
  35244    ;S (CHCNT TN,CHO30TN ,CHCNTTS,C HO30TS,CHC NTTH,CHO30 TH,CHCNTTF ,CHO30TF)= 0
  35245   "RTN","CHM RSQC1",14, 0)
  35246    ;S (CHO90 T,CHO60T,C HO91T,CHO9 1TI,CHO60T I,CHO90TC, CHO91TC,CH O60TC)=0
  35247   "RTN","CHM RSQC1",15, 0)
  35248    ;S (CHO91 TH,CHO90TH ,CHO60TH,C HO60TM,CHO 90TM,CHO91 TM)=0
  35249   "RTN","CHM RSQC1",16, 0)
  35250    ;S (CHO91 TE,CHO90TE ,CHO60TE,C HO91TS,CHO 90TS,CHO60 TS)=0
  35251   "RTN","CHM RSQC1",17, 0)
  35252    ;S (CHO91 TN,CHO90TN ,CHO60TN,C HO60TF,CHO 90TF,CHO91 TF)=0
  35253   "RTN","CHM RSQC1",18, 0)
  35254    ;S (CHO91 TI,CHO90TI ,CHO60TI)= 0
  35255   "RTN","CHM RSQC1",19, 0)
  35256    ;S (CHCNT TW,CHO30TW ,CHO60TW,C HO90TW,CHO 91TW)=0
  35257   "RTN","CHM RSQC1",20, 0)
  35258    ;S (CHCNT TL,CHO30TL ,CHO60TL,C HO90TL,CHO 91TL)=0
  35259   "RTN","CHM RSQC1",21, 0)
  35260    S (CHCNTT ,CHO10T,CH O14T,CHO21 T,CHO29T,C HO30T)=0
  35261   "RTN","CHM RSQC1",22, 0)
  35262    S (CHCNTT I,CHO10TI, CHO14TI,CH O21TI,CHO2 9TI,CHO30T I)=0
  35263   "RTN","CHM RSQC1",23, 0)
  35264    S (CHCNTT E,CHO10TE, CHO14TE,CH O21TE,CHO2 9TE,CHO30T E)=0
  35265   "RTN","CHM RSQC1",24, 0)
  35266    S (CHCNTT F,CHO10TF, CHO14TF,CH O21TF,CHO2 9TF,CHO30T F)=0
  35267   "RTN","CHM RSQC1",25, 0)
  35268    S (CHCNTT M,CHO10TM, CHO14TM,CH O21TM,CHO2 9TM,CHO30T M)=0
  35269   "RTN","CHM RSQC1",26, 0)
  35270    S (CHCNTT C,CHO10TC, CHO14TC,CH O21TC,CHO2 9TC,CHO30T C)=0
  35271   "RTN","CHM RSQC1",27, 0)
  35272    S (CHCNTT N,CHO10TN, CHO14TN,CH O21TN,CHO2 9TN,CHO30T N)=0
  35273   "RTN","CHM RSQC1",28, 0)
  35274    S (CHCNTT S,CHO10TS, CHO14TS,CH O21TS,CHO2 9TS,CHO30T S)=0
  35275   "RTN","CHM RSQC1",29, 0)
  35276    S (CHCNTT H,CHO10TH, CHO14TH,CH O21TH,CHO2 9TH,CHO30T H)=0
  35277   "RTN","CHM RSQC1",30, 0)
  35278    S (CHCNTT L,CHO10TL, CHO14TL,CH O21TL,CHO2 9TL,CHO30T L)=0
  35279   "RTN","CHM RSQC1",31, 0)
  35280    S (CHCNTT W,CHO10TW, CHO14TW,CH O21TW,CHO2 9TW,CHO30T W)=0
  35281   "RTN","CHM RSQC1",32, 0)
  35282    ;HR-PBM-P HASE 1-Beg in - SLM
  35283   "RTN","CHM RSQC1",33, 0)
  35284    ;Followin g line add ed for SXC ...
  35285   "RTN","CHM RSQC1",34, 0)
  35286    S (CHCNTT X,CHO10TX, CHO14TX,CH O21TX,CHO2 9TX,CHO30T X)=0
  35287   "RTN","CHM RSQC1",35, 0)
  35288    ;END MOD  PER DEV000 272, SKD 6 -27-07 
  35289   "RTN","CHM RSQC1",36, 0)
  35290    ;HR-PBM-P HASE 1-End
  35291   "RTN","CHM RSQC1",37, 0)
  35292    ;HM CPE00 5-016A 8/2 9/2017
  35293   "RTN","CHM RSQC1",38, 0)
  35294    S (CHCNTT R,CHO10TR, CHO14TR,CH O21TR,CHO2 9TR,CHO30T R)=0
  35295   "RTN","CHM RSQC1",39, 0)
  35296           ;
  35297   "RTN","CHM RSQC1",40, 0)
  35298    ; WTC CPE 005-016B 9 /1/17
  35299   "RTN","CHM RSQC1",41, 0)
  35300    ;
  35301   "RTN","CHM RSQC1",42, 0)
  35302    S (CHCNTT B,CHO10TB, CHO14TB,CH O21TB,CHO2 9TB,CHO30T B)=0 ;
  35303   "RTN","CHM RSQC1",43, 0)
  35304    ;
  35305   "RTN","CHM RSQC1",44, 0)
  35306   INITEND Q
  35307   "RTN","CHM RSQC1",45, 0)
  35308    ;
  35309   "RTN","CHM RSQC1",46, 0)
  35310   CPGLC I '$ D(^CHMRSQ1 ("MARSQ"))  Q
  35311   "RTN","CHM RSQC1",47, 0)
  35312    K ^CHMRSQ 1("MARSQC" )
  35313   "RTN","CHM RSQC1",48, 0)
  35314    S %X="^CH MRSQ1(""MA RSQ"","
  35315   "RTN","CHM RSQC1",49, 0)
  35316    S %Y="^CH MRSQ1(""MA RSQC"","
  35317   "RTN","CHM RSQC1",50, 0)
  35318    D %XY^%RC R
  35319   "RTN","CHM RSQC1",51, 0)
  35320    Q
  35321   "RTN","CHM RSQC1",52, 0)
  35322    ;
  35323   "RTN","CHM RSQC1",53, 0)
  35324   CPGLS I '$ D(^CHMRSQ1 ("MARSQC") ) Q
  35325   "RTN","CHM RSQC1",54, 0)
  35326    K ^CHMRSQ 1("MARSQ")
  35327   "RTN","CHM RSQC1",55, 0)
  35328    S %X="^CH MRSQ1(""MA RSQC"","
  35329   "RTN","CHM RSQC1",56, 0)
  35330    S %Y="^CH MRSQ1(""MA RSQ"","
  35331   "RTN","CHM RSQC1",57, 0)
  35332    D %XY^%RC R
  35333   "RTN","CHM RSQC1",58, 0)
  35334    Q
  35335   "RTN","CHM RSQC1",59, 0)
  35336    ;
  35337   "RTN","CHM RSQC1",60, 0)
  35338   KI ;
  35339   "RTN","CHM RSQC1",61, 0)
  35340    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35341   "RTN","CHM RSQC1",62, 0)
  35342    ;K CHCNT, CHCNTT,CHD IQ,CHDT30, CHI,CHJ,CH O30,CHO30T ,CHO21,CHO 21T,CHO21T I
  35343   "RTN","CHM RSQC1",63, 0)
  35344    ;K CHODT, CHOLD,CHCN TI,CHCNTTI ,CHO30I,CH O30TI,CHOD TI,CHOLDI, CHVENPT
  35345   "RTN","CHM RSQC1",64, 0)
  35346    ;K QCL,QD T,QREC,QST AT,QUE,CHD T21,CHO21I ,CHCNTTE,C HCNTE,CHO2 1E,CHO30E
  35347   "RTN","CHM RSQC1",65, 0)
  35348    ;K CHO21T E,CHO30TE, CHCNTTC,CH CNTC,CHO21 C,CHO30C,C HO21TC,CHO 30TC
  35349   "RTN","CHM RSQC1",66, 0)
  35350    ;K CHCNTT M,CHCNTM,C HO21M,CHO3 0M,CHO30TM ,CHCNTTN,C HCNTF
  35351   "RTN","CHM RSQC1",67, 0)
  35352    ;K CHCNTT S,CHO21TS, CHO30TS,CH CNTTH,CHO2 1TH,CHO30T H,CHO21TN
  35353   "RTN","CHM RSQC1",68, 0)
  35354    ;K CHCNTW ,CHO30W,CH O60W,CHO90 W,CHO91W
  35355   "RTN","CHM RSQC1",69, 0)
  35356    ;K CHCNTL ,CHO30L,CH O60L,CHO90 L,CHO91L
  35357   "RTN","CHM RSQC1",70, 0)
  35358    ;K CHCNTT W,CHO30TW, CHO60TW,CH O90TW,CHO9 1TW
  35359   "RTN","CHM RSQC1",71, 0)
  35360    ;K CHCNTT L,CHO30TL, CHO60TL,CH O90TL,CHO9 1TL
  35361   "RTN","CHM RSQC1",72, 0)
  35362    K CHCNT,C HDIQ,CHI,C HJ,CHODT,C HOLD,CHODT I,CHOLDI,C HVENPT,QCL ,QDT,QREC, QSTAT,QUE
  35363   "RTN","CHM RSQC1",73, 0)
  35364    K CHCNTT, CHO10T,CHO 14T,CHO21T ,CHO29T,CH O30T
  35365   "RTN","CHM RSQC1",74, 0)
  35366    K CHCNTTI ,CHO10TI,C HO14TI,CHO 21TI,CHO29 TI,CHO30TI
  35367   "RTN","CHM RSQC1",75, 0)
  35368    K CHCNTTE ,CHO10TE,C HO14TE,CHO 21TE,CHO29 TE,CHO30TE
  35369   "RTN","CHM RSQC1",76, 0)
  35370    K CHCNTTF ,CHO10TF,C HO14TF,CHO 21TF,CHO29 TF,CHO30TF
  35371   "RTN","CHM RSQC1",77, 0)
  35372    K CHCNTTM ,CHO10TM,C HO14TM,CHO 21TM,CHO29 TM,CHO30TM
  35373   "RTN","CHM RSQC1",78, 0)
  35374    K CHCNTTC ,CHO10TC,C HO14TC,CHO 21TC,CHO29 TC,CHO30TC
  35375   "RTN","CHM RSQC1",79, 0)
  35376    K CHCNTTN ,CHO10TN,C HO14TN,CHO 21TN,CHO29 TN,CHO30TN
  35377   "RTN","CHM RSQC1",80, 0)
  35378    K CHCNTTS ,CHO10TS,C HO14TS,CHO 21TS,CHO29 TS,CHO30TS
  35379   "RTN","CHM RSQC1",81, 0)
  35380    K CHCNTTH ,CHO10TH,C HO14TH,CHO 21TH,CHO29 TH,CHO30TH
  35381   "RTN","CHM RSQC1",82, 0)
  35382    K CHCNTTW ,CHO10TW,C HO14TW,CHO 21TW,CHO29 TW,CHO30TW
  35383   "RTN","CHM RSQC1",83, 0)
  35384    ;HR-PBM-P HASE 1-Beg in - SLM
  35385   "RTN","CHM RSQC1",84, 0)
  35386    ;Followin g lines ad ded for SX C...
  35387   "RTN","CHM RSQC1",85, 0)
  35388    ;K CHCNTX ,CHO10X,CH O14X,CHO21 X,CHO29X,C HO30X
  35389   "RTN","CHM RSQC1",86, 0)
  35390    K CHCNTTX ,CHO10TX,C HO14TX,CHO 21TX,CHO29 TX,CHO30TX
  35391   "RTN","CHM RSQC1",87, 0)
  35392      ;HR-PBM -PHASE 1-E nd
  35393   "RTN","CHM RSQC1",88, 0)
  35394    ;END MOD  PER DEV000 272, SKD 6 -27-07
  35395   "RTN","CHM RSQC1",89, 0)
  35396    ;HM CPE00 5-016A 8/2 9/2017
  35397   "RTN","CHM RSQC1",90, 0)
  35398    K CHCNTTR ,CHO10TR,C HO14TR,CHO 21TR,CHO29 TR,CHO30TR
  35399   "RTN","CHM RSQC1",91, 0)
  35400           ;
  35401   "RTN","CHM RSQC1",92, 0)
  35402    ; WTC CPE 005-016B 9 /1/17
  35403   "RTN","CHM RSQC1",93, 0)
  35404    K CHCNTTB ,CHO10TB,C HO14TB,CHO 21TB,CHO29 TB,CHO30TB  ;
  35405   "RTN","CHM RSQC1",94, 0)
  35406    ;
  35407   "RTN","CHM RSQC1",95, 0)
  35408    Q
  35409   "RTN","CHM RSQC1",96, 0)
  35410    ;
  35411   "RTN","CHM RSQC1",97, 0)
  35412   DUP F CHST AT=0,1 S C HQDT=0 F   S CHQDT=$O (^CHMDPCL( 741010.13, "C",CHSTAT ,CHQDT)) Q :'CHQDT  S  CHI=0 F   S CHI=$O(^ CHMDPCL(74 1010.13,"C ",CHSTAT,C HQDT,CHI))  Q:'CHI  D  DUP1
  35413   "RTN","CHM RSQC1",98, 0)
  35414   DUPEND Q
  35415   "RTN","CHM RSQC1",99, 0)
  35416    ;
  35417   "RTN","CHM RSQC1",100 ,0)
  35418   DUP1 G:'$D (^CHMDPCL( 741010.13, CHI,0)) DU P1END
  35419   "RTN","CHM RSQC1",101 ,0)
  35420    S QREC=^C HMDPCL(741 010.13,CHI ,0)
  35421   "RTN","CHM RSQC1",102 ,0)
  35422    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3)
  35423   "RTN","CHM RSQC1",103 ,0)
  35424    G:QDT>CHD TE DUP1END
  35425   "RTN","CHM RSQC1",104 ,0)
  35426    G:QCL=""  DUP1END S  X1=QCL D P ROGTYP^CHF CD001
  35427   "RTN","CHM RSQC1",105 ,0)
  35428    G:'$D(@(G LPAY_"QCL, 0)")) DUP1 END
  35429   "RTN","CHM RSQC1",106 ,0)
  35430    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35431   "RTN","CHM RSQC1",107 ,0)
  35432    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) 
  35433   "RTN","CHM RSQC1",108 ,0)
  35434    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35435   "RTN","CHM RSQC1",109 ,0)
  35436    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35437   "RTN","CHM RSQC1",110 ,0)
  35438    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35439   "RTN","CHM RSQC1",111 ,0)
  35440    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35441   "RTN","CHM RSQC1",112 ,0)
  35442    ;S QDT=$$ JULFM(@(GL PAY_"QCL," "PDI"",QCL J,0)"))
  35443   "RTN","CHM RSQC1",113 ,0)
  35444    D CNT^CHM RSQC1
  35445   "RTN","CHM RSQC1",114 ,0)
  35446   DUP1END Q
  35447   "RTN","CHM RSQC1",115 ,0)
  35448    ;
  35449   "RTN","CHM RSQC1",116 ,0)
  35450   VEN F CHST AT=0,1,3,4  S CHI=0 F   S CHI=$O (^CHMQVN(" D",CHSTAT, CHI)) Q:'C HI  D VEN1
  35451   "RTN","CHM RSQC1",117 ,0)
  35452   VENEND Q
  35453   "RTN","CHM RSQC1",118 ,0)
  35454    ;
  35455   "RTN","CHM RSQC1",119 ,0)
  35456   VEN1 G:'$D (^CHMQVN(C HI,0)) VEN 1END
  35457   "RTN","CHM RSQC1",120 ,0)
  35458    S QREC=^C HMQVN(CHI, 0)
  35459   "RTN","CHM RSQC1",121 ,0)
  35460    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3)
  35461   "RTN","CHM RSQC1",122 ,0)
  35462    S CHJ=0
  35463   "RTN","CHM RSQC1",123 ,0)
  35464   V1 S CHJ=$ O(^CHMQVN( CHI,10,CHJ )) G:'CHJ  VEN1END
  35465   "RTN","CHM RSQC1",124 ,0)
  35466    G:'$D(^CH MQVN(CHI,1 0,CHJ,0))  V1
  35467   "RTN","CHM RSQC1",125 ,0)
  35468    S QRECJ=^ CHMQVN(CHI ,10,CHJ,0)
  35469   "RTN","CHM RSQC1",126 ,0)
  35470    S QDT=$P( $P(QRECJ,U ,2),".",1) ,QCL=$P(QR ECJ,U,1),Q STATJ=$P(Q RECJ,U,6)
  35471   "RTN","CHM RSQC1",127 ,0)
  35472    G:QSTATJ= 1 V1
  35473   "RTN","CHM RSQC1",128 ,0)
  35474    G:QDT>CHD TE V1
  35475   "RTN","CHM RSQC1",129 ,0)
  35476    G:QCL=""  V1 I QCL=7 845662  
  35477   "RTN","CHM RSQC1",130 ,0)
  35478    S X1=QCL  D PROGTYP^ CHFCD001
  35479   "RTN","CHM RSQC1",131 ,0)
  35480    G:'$D(@(G LPAY_"QCL, 0)")) V1
  35481   "RTN","CHM RSQC1",132 ,0)
  35482    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35483   "RTN","CHM RSQC1",133 ,0)
  35484    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35485   "RTN","CHM RSQC1",134 ,0)
  35486    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35487   "RTN","CHM RSQC1",135 ,0)
  35488    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35489   "RTN","CHM RSQC1",136 ,0)
  35490    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35491   "RTN","CHM RSQC1",137 ,0)
  35492    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35493   "RTN","CHM RSQC1",138 ,0)
  35494    ;S QDT=$$ JULFM(@(GL PAY_"QCL," "PDI"",QCL J,0)"))
  35495   "RTN","CHM RSQC1",139 ,0)
  35496    D CNT^CHM RSQC1
  35497   "RTN","CHM RSQC1",140 ,0)
  35498    G V1
  35499   "RTN","CHM RSQC1",141 ,0)
  35500   VEN1END Q
  35501   "RTN","CHM RSQC1",142 ,0)
  35502    ;
  35503   "RTN","CHM RSQC1",143 ,0)
  35504   EOB S CHST AT=0,CHI=0  F  S CHI= $O(^CHMEOB Q("C",CHST AT,CHI)) Q :'CHI  D E OB1
  35505   "RTN","CHM RSQC1",144 ,0)
  35506    S CHSTAT= 0,CHI=0 F   S CHI=$O( ^CHNVEOBQ( "C",CHSTAT ,CHI)) Q:' CHI  D NEO B
  35507   "RTN","CHM RSQC1",145 ,0)
  35508   EOBEND Q
  35509   "RTN","CHM RSQC1",146 ,0)
  35510    ;
  35511   "RTN","CHM RSQC1",147 ,0)
  35512   EOB1 G:'$D (^CHMEOBQ( CHI,0)) EO B1END
  35513   "RTN","CHM RSQC1",148 ,0)
  35514    S QREC=^C HMEOBQ(CHI ,0)
  35515   "RTN","CHM RSQC1",149 ,0)
  35516    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3)
  35517   "RTN","CHM RSQC1",150 ,0)
  35518    G:QDT>CHD TE EOB1END
  35519   "RTN","CHM RSQC1",151 ,0)
  35520    G:QCL=""  EOB1END
  35521   "RTN","CHM RSQC1",152 ,0)
  35522    S X1=QCL  D PROGTYP^ CHFCD001
  35523   "RTN","CHM RSQC1",153 ,0)
  35524    G:'$D(@(G LPAY_"QCL, 0)")) EOB1 END
  35525   "RTN","CHM RSQC1",154 ,0)
  35526    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35527   "RTN","CHM RSQC1",155 ,0)
  35528    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35529   "RTN","CHM RSQC1",156 ,0)
  35530    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35531   "RTN","CHM RSQC1",157 ,0)
  35532    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35533   "RTN","CHM RSQC1",158 ,0)
  35534    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35535   "RTN","CHM RSQC1",159 ,0)
  35536    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35537   "RTN","CHM RSQC1",160 ,0)
  35538    ;S QDT=$$ JULFM(@(GL PAY_"QCL," "PDI"",QCL J,0)"))
  35539   "RTN","CHM RSQC1",161 ,0)
  35540    D CNT^CHM RSQC1
  35541   "RTN","CHM RSQC1",162 ,0)
  35542   EOB1END Q
  35543   "RTN","CHM RSQC1",163 ,0)
  35544   NEOB G:'$D (^CHNVEOBQ (CHI,0)) E OB1END
  35545   "RTN","CHM RSQC1",164 ,0)
  35546    S QREC=^C HNVEOBQ(CH I,0)
  35547   "RTN","CHM RSQC1",165 ,0)
  35548    S QDT=$P( $P(QREC,U, 1),".",1), QCL=$P(QRE C,U,2),QST AT=$P(QREC ,U,3)
  35549   "RTN","CHM RSQC1",166 ,0)
  35550    G:QDT>CHD TE EOB1END
  35551   "RTN","CHM RSQC1",167 ,0)
  35552    G:QCL=""  EOB1END
  35553   "RTN","CHM RSQC1",168 ,0)
  35554    S X1=QCL  D PROGTYP^ CHFCD001
  35555   "RTN","CHM RSQC1",169 ,0)
  35556    G:'$D(@(G LPAY_"QCL, 0)")) EOB1 END
  35557   "RTN","CHM RSQC1",170 ,0)
  35558    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35559   "RTN","CHM RSQC1",171 ,0)
  35560    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35561   "RTN","CHM RSQC1",172 ,0)
  35562    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35563   "RTN","CHM RSQC1",173 ,0)
  35564    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35565   "RTN","CHM RSQC1",174 ,0)
  35566    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35567   "RTN","CHM RSQC1",175 ,0)
  35568    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35569   "RTN","CHM RSQC1",176 ,0)
  35570    ;S QDT=$$ JULFM(@(GL PAY_"QCL," "PDI"",QCL J,0)"))
  35571   "RTN","CHM RSQC1",177 ,0)
  35572    D CNT^CHM RSQC1
  35573   "RTN","CHM RSQC1",178 ,0)
  35574    Q
  35575   "RTN","CHM RSQC1",179 ,0)
  35576   GRP S GRPJ =$P(^CHMSN A(741008.0 2,0),"^",3 ) Q:'GRPJ
  35577   "RTN","CHM RSQC1",180 ,0)
  35578    Q:'$D(^CH MSNA(74100 8.02,GRPJ, 0))
  35579   "RTN","CHM RSQC1",181 ,0)
  35580    S GRPK=0
  35581   "RTN","CHM RSQC1",182 ,0)
  35582   GRP1 S GRP K=$O(^CHMS NA(741008. 02,GRPJ,1, GRPK)) G:G RPK="" GRP END
  35583   "RTN","CHM RSQC1",183 ,0)
  35584    G:'$D(^CH MSNA(74100 8.02,GRPJ, 1,GRPK,0))  GRP1
  35585   "RTN","CHM RSQC1",184 ,0)
  35586    S QCLM=$P (^CHMSNA(7 41008.02,G RPJ,1,GRPK ,0),U,1)
  35587   "RTN","CHM RSQC1",185 ,0)
  35588    G:QCLM=""  GRP1
  35589   "RTN","CHM RSQC1",186 ,0)
  35590    ;S QCL=$O (^CHMINDEX ("B",QCLM, QCL)) G:'Q CL GRP1    ;SKD 6-29- 07 DEV0002 72
  35591   "RTN","CHM RSQC1",187 ,0)
  35592    S QCL=$O( ^CHMINDEX( "B",QCLM,0 )) G:'QCL  GRP1       ;SKD 6-29- 07 DEV0002 72
  35593   "RTN","CHM RSQC1",188 ,0)
  35594    S X1=QCL  D PROGTYP^ CHFCD001
  35595   "RTN","CHM RSQC1",189 ,0)
  35596    G:'$D(@(G LPAY_"QCL, 0)")) GRP1
  35597   "RTN","CHM RSQC1",190 ,0)
  35598    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35599   "RTN","CHM RSQC1",191 ,0)
  35600    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35601   "RTN","CHM RSQC1",192 ,0)
  35602    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35603   "RTN","CHM RSQC1",193 ,0)
  35604    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35605   "RTN","CHM RSQC1",194 ,0)
  35606    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35607   "RTN","CHM RSQC1",195 ,0)
  35608    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35609   "RTN","CHM RSQC1",196 ,0)
  35610    ;S QDT=$$ JULFM(@(GL PAY_"QCL," "PDI"",QCL J,0)"))
  35611   "RTN","CHM RSQC1",197 ,0)
  35612    D CNT^CHM RSQC1 G GR P1
  35613   "RTN","CHM RSQC1",198 ,0)
  35614   GRPEND Q
  35615   "RTN","CHM RSQC1",199 ,0)
  35616    ;
  35617   "RTN","CHM RSQC1",200 ,0)
  35618   CAL S CHDI Q=$O(^CHMS NA(741008. 05,"B",CHD IQ)) G:'CH DIQ CALEND
  35619   "RTN","CHM RSQC1",201 ,0)
  35620    G:CHDIQ>C HDTE CAL
  35621   "RTN","CHM RSQC1",202 ,0)
  35622    S CHI=0,C HI=$O(^CHM SNA(741008 .05,"B",CH DIQ,CHI))  G:'CHI CAL
  35623   "RTN","CHM RSQC1",203 ,0)
  35624    G:'$D(^CH MSNA(74100 8.05,CHI,0 )) CAL S Q REC=^(0)
  35625   "RTN","CHM RSQC1",204 ,0)
  35626    S QSTAT=$ P(QREC,U,3 ),QCL="",Q DT=$P($P(Q REC,U,1)," .",1)
  35627   "RTN","CHM RSQC1",205 ,0)
  35628    G:QSTAT=2 !(QSTAT=3)  CAL
  35629   "RTN","CHM RSQC1",206 ,0)
  35630    S CHJ=0
  35631   "RTN","CHM RSQC1",207 ,0)
  35632    F  S CHJ= $O(^CHMSNA (741008.05 ,CHI,1,CHJ )) Q:'CHJ   D
  35633   "RTN","CHM RSQC1",208 ,0)
  35634    .S QCL=$P (^CHMSNA(7 41008.05,C HI,1,CHJ,0 ),U,1)
  35635   "RTN","CHM RSQC1",209 ,0)
  35636    .Q:QCL=""
  35637   "RTN","CHM RSQC1",210 ,0)
  35638    .S X1=QCL  D PROGTYP ^CHFCD001
  35639   "RTN","CHM RSQC1",211 ,0)
  35640    .Q:'$D(@( GLPAY_"QCL ,0)"))
  35641   "RTN","CHM RSQC1",212 ,0)
  35642    .S QCLJ=9 99999999,Q CLJ=$O(@(G LPAY_"QCL, ""PDI"",QC LJ)"),-1)
  35643   "RTN","CHM RSQC1",213 ,0)
  35644    .I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D
  35645   "RTN","CHM RSQC1",214 ,0)
  35646    ..S TMPQD T=$P(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)"),"^", 1)
  35647   "RTN","CHM RSQC1",215 ,0)
  35648    ..;S QDT= $$JULFM(TM PQDT)  ;Y2 K
  35649   "RTN","CHM RSQC1",216 ,0)
  35650    ..S QDT=$ $PDIJULFM^ CHMFPDI2(T MPQDT)
  35651   "RTN","CHM RSQC1",217 ,0)
  35652    .D CNT^CH MRSQC1
  35653   "RTN","CHM RSQC1",218 ,0)
  35654    G CAL
  35655   "RTN","CHM RSQC1",219 ,0)
  35656   CALEND D N VABTH
  35657   "RTN","CHM RSQC1",220 ,0)
  35658    Q
  35659   "RTN","CHM RSQC1",221 ,0)
  35660   CAP S CHDI Q=$O(^CHMS NA(741008. 03,"B",CHD IQ)) G:'CH DIQ CAPEND
  35661   "RTN","CHM RSQC1",222 ,0)
  35662    G:CHDIQ>C HDTE CAP
  35663   "RTN","CHM RSQC1",223 ,0)
  35664    S CHI=0,C HI=$O(^CHM SNA(741008 .03,"B",CH DIQ,CHI))  G:'CHI CAP
  35665   "RTN","CHM RSQC1",224 ,0)
  35666    G:'$D(^CH MSNA(74100 8.03,CHI,0 )) CAP S Q REC=^(0)
  35667   "RTN","CHM RSQC1",225 ,0)
  35668    S QSTAT=$ P(QREC,U,3 ),QCL="",Q DT=$P($P(Q REC,U,1)," .",1)
  35669   "RTN","CHM RSQC1",226 ,0)
  35670    G:QSTAT=2 !(QSTAT=3)  CAP
  35671   "RTN","CHM RSQC1",227 ,0)
  35672    S CHJ=0
  35673   "RTN","CHM RSQC1",228 ,0)
  35674    F  S CHJ= $O(^CHMSNA (741008.03 ,CHI,1,CHJ )) Q:'CHJ   D
  35675   "RTN","CHM RSQC1",229 ,0)
  35676    .S QCL=$P (^CHMSNA(7 41008.03,C HI,1,CHJ,0 ),U,1)
  35677   "RTN","CHM RSQC1",230 ,0)
  35678    .Q:QCL=""
  35679   "RTN","CHM RSQC1",231 ,0)
  35680    .S X1=QCL  D PROGTYP ^CHFCD001
  35681   "RTN","CHM RSQC1",232 ,0)
  35682    .Q:'$D(@( GLPAY_"QCL ,0)"))
  35683   "RTN","CHM RSQC1",233 ,0)
  35684    .S QCLJ=9 99999999,Q CLJ=$O(@(G LPAY_"QCL, ""PDI"",QC LJ)"),-1)
  35685   "RTN","CHM RSQC1",234 ,0)
  35686    .I QCLJ'= "",$D(@(GL PAY_"QCL," "PDI"",QCL J,0)")) D
  35687   "RTN","CHM RSQC1",235 ,0)
  35688    ..S TMPQD T=$P(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)"),"^", 1)
  35689   "RTN","CHM RSQC1",236 ,0)
  35690    ..;S QDT= $$JULFM(TM PQDT)  ; Y 2K
  35691   "RTN","CHM RSQC1",237 ,0)
  35692    ..S QDT=$ $PDIJULFM^ CHMFPDI2(T MPQDT)
  35693   "RTN","CHM RSQC1",238 ,0)
  35694    .D CNT^CH MRSQC1
  35695   "RTN","CHM RSQC1",239 ,0)
  35696    G CAP
  35697   "RTN","CHM RSQC1",240 ,0)
  35698   CAPEND D N VABTH
  35699   "RTN","CHM RSQC1",241 ,0)
  35700    Q
  35701   "RTN","CHM RSQC1",242 ,0)
  35702   NVABTH S C HDIQ=$O(^C HHACASF(74 13002.2,"B ",CHDIQ))  G:'CHDIQ N VABED
  35703   "RTN","CHM RSQC1",243 ,0)
  35704    G:CHDIQ>C HDTE NVABT H
  35705   "RTN","CHM RSQC1",244 ,0)
  35706    S CHI=0,C HI=$O(^CHH ACASF(7413 002.2,"B", CHDIQ,CHI) ) G:'CHI N VABTH
  35707   "RTN","CHM RSQC1",245 ,0)
  35708    G:'$D(^CH HACASF(741 3002.2,CHI ,0)) NVABT H
  35709   "RTN","CHM RSQC1",246 ,0)
  35710    G:$P(^CHH ACASF(7413 002.2,CHI, 0),"^",2)= 3 NVABTH 
  35711   "RTN","CHM RSQC1",247 ,0)
  35712    S CHJ=0
  35713   "RTN","CHM RSQC1",248 ,0)
  35714   NVA1 S CHJ =$O(^CHHAC ASF(741300 2.2,CHI,10 0,CHJ)) G: 'CHJ NVABT H
  35715   "RTN","CHM RSQC1",249 ,0)
  35716    G:'$D(^CH HACASF(741 3002.2,CHI ,100,CHJ,0 )) NVA1
  35717   "RTN","CHM RSQC1",250 ,0)
  35718    G:QUE="CA L"&($P(^CH HACASF(741 3002.2,CHI ,100,CHJ,0 ),"^",9)=1 ) NVA1
  35719   "RTN","CHM RSQC1",251 ,0)
  35720    G:QUE="CA P"&($P(^CH HACASF(741 3002.2,CHI ,100,CHJ,0 ),"^",9)=0 ) NVA1
  35721   "RTN","CHM RSQC1",252 ,0)
  35722    S CHK=0
  35723   "RTN","CHM RSQC1",253 ,0)
  35724   NVA2 S CHK =$O(^CHHAC ASF(741300 2.2,CHI,10 0,CHJ,200, CHK)) G:'C HK NVA1
  35725   "RTN","CHM RSQC1",254 ,0)
  35726    G:'$D(^CH HACASF(741 3002.2,CHI ,100,CHJ,2 00,CHK,0))  NVA2
  35727   "RTN","CHM RSQC1",255 ,0)
  35728    S CHL=0
  35729   "RTN","CHM RSQC1",256 ,0)
  35730   NVA3 S CHL =$O(^CHHAC ASF(741300 2.2,CHI,10 0,CHJ,200, CHK,300,CH L)) G:'CHL  NVA2
  35731   "RTN","CHM RSQC1",257 ,0)
  35732    G:'$D(^CH HACASF(741 3002.2,CHI ,100,CHJ,2 00,CHK,300 ,CHL,0)) N VA3
  35733   "RTN","CHM RSQC1",258 ,0)
  35734    S QREC=^C HHACASF(74 13002.2,CH I,100,CHJ, 200,CHK,30 0,CHL,0)
  35735   "RTN","CHM RSQC1",259 ,0)
  35736    S QSTAT=$ P(QREC,"^" ,4),QDT=$P (CHI,".",1 ),QCL=$P(Q REC,"^",1)
  35737   "RTN","CHM RSQC1",260 ,0)
  35738    G:QCL=""  NVA3
  35739   "RTN","CHM RSQC1",261 ,0)
  35740    S X1=QCL  D PROGTYP^ CHFCD001
  35741   "RTN","CHM RSQC1",262 ,0)
  35742    G:'$D(@(G LPAY_"QCL, 0)")) NVA3
  35743   "RTN","CHM RSQC1",263 ,0)
  35744    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  35745   "RTN","CHM RSQC1",264 ,0)
  35746    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  35747   "RTN","CHM RSQC1",265 ,0)
  35748    .S TMPQDT =$P(@(GLPA Y_"QCL,""P DI"",QCLJ, 0)"),"^",1 )
  35749   "RTN","CHM RSQC1",266 ,0)
  35750    .;S QDT=$ $JULFM(TMP QDT)  ; Y2 K
  35751   "RTN","CHM RSQC1",267 ,0)
  35752    .S QDT=$$ PDIJULFM^C HMFPDI2(TM PQDT)
  35753   "RTN","CHM RSQC1",268 ,0)
  35754    D CNT^CHM RSQC1
  35755   "RTN","CHM RSQC1",269 ,0)
  35756    G NVA3
  35757   "RTN","CHM RSQC1",270 ,0)
  35758   NVABED Q
  35759   "RTN","CHM RSQC1",271 ,0)
  35760   CNT Q:QCL= ""
  35761   "RTN","CHM RSQC1",272 ,0)
  35762    S CHCNT=C HCNT+1,CHC NTT=CHCNTT +1
  35763   "RTN","CHM RSQC1",273 ,0)
  35764    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35765   "RTN","CHM RSQC1",274 ,0)
  35766    ;I QDT'<C HDT30 S CH O30=CHO30+ 1,CHO30T=C HO30T+1
  35767   "RTN","CHM RSQC1",275 ,0)
  35768    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60=CHO 60+1,CHO60 T=CHO60T+1
  35769   "RTN","CHM RSQC1",276 ,0)
  35770    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90=CHO 90+1,CHO90 T=CHO90T+1
  35771   "RTN","CHM RSQC1",277 ,0)
  35772    ;I QDT<CH DT90 S CHO 91=CHO91+1 ,CHO91T=CH O91T+1
  35773   "RTN","CHM RSQC1",278 ,0)
  35774    I QDT'<CH DT10 S CHO 10=CHO10+1 ,CHO10T=CH O10T+1
  35775   "RTN","CHM RSQC1",279 ,0)
  35776    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14=CHO1 4+1,CHO14T =CHO14T+1
  35777   "RTN","CHM RSQC1",280 ,0)
  35778    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21=CHO2 1+1,CHO21T =CHO21T+1
  35779   "RTN","CHM RSQC1",281 ,0)
  35780    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29=CHO2 9+1,CHO29T =CHO29T+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  35781   "RTN","CHM RSQC1",282 ,0)
  35782    I QDT<CHD T30 S CHO3 0=CHO30+1, CHO30T=CHO 30T+1  ;AE B 2/2/2009  DEV004170  CHANGED C HDT29 TO C HDT30
  35783   "RTN","CHM RSQC1",283 ,0)
  35784    ;END MOD  PER DEV000 272, SKD 6 -27-07
  35785   "RTN","CHM RSQC1",284 ,0)
  35786    I QDT<CHO DT S CHODT =QDT_U_CHI ,CHOLD=$P( @(GLPAY_"Q CL,0)"),U, 1)
  35787   "RTN","CHM RSQC1",285 ,0)
  35788    D CNTI,CN TEDI,CNTF, CNTMDX,CNT SXC,CNTCMP ,CNTNVA,CN TSB,CNTHAC ,CNTWV,CNT EDIRO,CNTE DISB ; WTC  9/1/17
  35789   "RTN","CHM RSQC1",286 ,0)
  35790   CNTEND Q
  35791   "RTN","CHM RSQC1",287 ,0)
  35792    ;
  35793   "RTN","CHM RSQC1",288 ,0)
  35794   CNTI Q:'$D (@(GLPAY_" QCL,0)"))   I $P(@(GL PAY_"QCL,0 )"),U,3)=" " G CNTIEN D
  35795   "RTN","CHM RSQC1",289 ,0)
  35796    S CHVENPT =$P(@(GLPA Y_"QCL,0)" ),U,3)
  35797   "RTN","CHM RSQC1",290 ,0)
  35798    I '$D(^CH MVEN(CHVEN PT,1)) G C NTIEND
  35799   "RTN","CHM RSQC1",291 ,0)
  35800    I $P(^CHM VEN(CHVENP T,1),U,16) '=1 G CNTI END
  35801   "RTN","CHM RSQC1",292 ,0)
  35802    S CHCNTI= CHCNTI+1,C HCNTTI=CHC NTTI+1
  35803   "RTN","CHM RSQC1",293 ,0)
  35804    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35805   "RTN","CHM RSQC1",294 ,0)
  35806    ;I QDT'<C HDT30 S CH O30I=CHO30 I+1,CHO30T I=CHO30TI+ 1
  35807   "RTN","CHM RSQC1",295 ,0)
  35808    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60I=CH O60I+1,CHO 60TI=CHO60 TI+1
  35809   "RTN","CHM RSQC1",296 ,0)
  35810    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90I=CH O90I+1,CHO 90TI=CHO90 TI+1
  35811   "RTN","CHM RSQC1",297 ,0)
  35812    ;I QDT<CH DT90 S CHO 91I=CHO91I +1,CHO91TI =CHO91TI+1
  35813   "RTN","CHM RSQC1",298 ,0)
  35814    I QDT'<CH DT10 S CHO 10I=CHO10I +1,CHO10TI =CHO10TI+1
  35815   "RTN","CHM RSQC1",299 ,0)
  35816    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14I=CHO 14I+1,CHO1 4TI=CHO14T I+1
  35817   "RTN","CHM RSQC1",300 ,0)
  35818    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21I=CHO 21I+1,CHO2 1TI=CHO21T I+1
  35819   "RTN","CHM RSQC1",301 ,0)
  35820    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29I=CHO 29I+1,CHO2 9TI=CHO29T I+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  35821   "RTN","CHM RSQC1",302 ,0)
  35822    I QDT<CHD T30 S CHO3 0I=CHO30I+ 1,CHO30TI= CHO30TI+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  35823   "RTN","CHM RSQC1",303 ,0)
  35824    ;END MOD  PER DEV000 272, SKD 6 -27-07
  35825   "RTN","CHM RSQC1",304 ,0)
  35826    I QDT<CHO DTI S CHOD TI=QDT_U_C HI,CHOLDI= $P(@(GLPAY _"QCL,0)") ,U,1)
  35827   "RTN","CHM RSQC1",305 ,0)
  35828   CNTIEND Q
  35829   "RTN","CHM RSQC1",306 ,0)
  35830    ;
  35831   "RTN","CHM RSQC1",307 ,0)
  35832   CNTEDI Q:' $D(@(GLPAY _"QCL,""ZE MC"")"))
  35833   "RTN","CHM RSQC1",308 ,0)
  35834    S CHCNTE= CHCNTE+1,C HCNTTE=CHC NTTE+1
  35835   "RTN","CHM RSQC1",309 ,0)
  35836    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35837   "RTN","CHM RSQC1",310 ,0)
  35838    ;I QDT'<C HDT30 S CH O30E=CHO30 E+1,CHO30T E=CHO30TE+ 1
  35839   "RTN","CHM RSQC1",311 ,0)
  35840    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60E=CH O60E+1,CHO 60TE=CHO60 TE+1
  35841   "RTN","CHM RSQC1",312 ,0)
  35842    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90E=CH O90E+1,CHO 90TE=CHO90 TE+1
  35843   "RTN","CHM RSQC1",313 ,0)
  35844    ;I QDT<CH DT90 S CHO 91E=CHO91E +1,CHO91TE =CHO91TE+1
  35845   "RTN","CHM RSQC1",314 ,0)
  35846    I QDT'<CH DT10 S CHO 10E=CHO10E +1,CHO10TE =CHO10TE+1
  35847   "RTN","CHM RSQC1",315 ,0)
  35848    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14E=CHO 14E+1,CHO1 4TE=CHO14T E+1
  35849   "RTN","CHM RSQC1",316 ,0)
  35850    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21E=CHO 21E+1,CHO2 1TE=CHO21T E+1
  35851   "RTN","CHM RSQC1",317 ,0)
  35852    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29E=CHO 29E+1,CHO2 9TE=CHO29T E+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  35853   "RTN","CHM RSQC1",318 ,0)
  35854    I QDT<CHD T30 S CHO3 0E=CHO30E+ 1,CHO30TE= CHO30TE+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  35855   "RTN","CHM RSQC1",319 ,0)
  35856    ;END MOD  PER DEV000 272, SKD 6 -27-07
  35857   "RTN","CHM RSQC1",320 ,0)
  35858    ;
  35859   "RTN","CHM RSQC1",321 ,0)
  35860    I QDT<CHO DTE S CHOD TE=QDT_U_C HI,CHOLDE= $P(@(GLPAY _"QCL,0)") ,U,1)
  35861   "RTN","CHM RSQC1",322 ,0)
  35862    Q
  35863   "RTN","CHM RSQC1",323 ,0)
  35864   CNTF ;COUN T X12 AND  OCR ONLY
  35865   "RTN","CHM RSQC1",324 ,0)
  35866    Q:'$D(@(G LPAY_"QCL, ""ZEMC"")" ))
  35867   "RTN","CHM RSQC1",325 ,0)
  35868    I $D(@(GL PAY_"QCL," "ZEMC"")") ) Q:$D(@(G LPAY_"QCL, ""ZEMC""," "MDMTRX"") "))
  35869   "RTN","CHM RSQC1",326 ,0)
  35870    I $D(@(GL PAY_"QCL," "ZEMC"")") ) Q:$D(@(G LPAY_"QCL, ""ZEMC""," "CMOP"")") )
  35871   "RTN","CHM RSQC1",327 ,0)
  35872    I $D(@(GL PAY_"QCL," "ZEMC"")") ) Q:$D(@(G LPAY_"QCL, ""ZEMC""," "SXC"")"))
  35873   "RTN","CHM RSQC1",328 ,0)
  35874    S CHCNTF= CHCNTF+1,C HCNTTF=CHC NTTF+1
  35875   "RTN","CHM RSQC1",329 ,0)
  35876    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35877   "RTN","CHM RSQC1",330 ,0)
  35878    ;I QDT'<C HDT30 S CH O30F=CHO30 F+1,CHO30T F=CHO30TF+ 1
  35879   "RTN","CHM RSQC1",331 ,0)
  35880    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60F=CH O60F+1,CHO 60TF=CHO60 TF+1
  35881   "RTN","CHM RSQC1",332 ,0)
  35882    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90F=CH O90F+1,CHO 90TF=CHO90 TF+1
  35883   "RTN","CHM RSQC1",333 ,0)
  35884    ;I QDT<CH DT90 S CHO 91F=CHO91F +1,CHO91TF =CHO91TF+1
  35885   "RTN","CHM RSQC1",334 ,0)
  35886    I QDT'<CH DT10 S CHO 10F=CHO10F +1,CHO10TF =CHO10TF+1
  35887   "RTN","CHM RSQC1",335 ,0)
  35888    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14F=CHO 14F+1,CHO1 4TF=CHO14T F+1
  35889   "RTN","CHM RSQC1",336 ,0)
  35890    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21F=CHO 21F+1,CHO2 1TF=CHO21T F+1
  35891   "RTN","CHM RSQC1",337 ,0)
  35892    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29F=CHO 29F+1,CHO2 9TF=CHO29T F+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  35893   "RTN","CHM RSQC1",338 ,0)
  35894    I QDT<CHD T30 S CHO3 0F=CHO30F+ 1,CHO30TF= CHO30TF+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  35895   "RTN","CHM RSQC1",339 ,0)
  35896    ;END MOD  PER DEV000 272, SKD 6 -27-07
  35897   "RTN","CHM RSQC1",340 ,0)
  35898    I QDT<CHO DTF S CHOD TF=QDT_U_C HI,CHOLDF= $P(@(GLPAY _"QCL,0)") ,U,1)
  35899   "RTN","CHM RSQC1",341 ,0)
  35900    Q
  35901   "RTN","CHM RSQC1",342 ,0)
  35902   CNTMDX Q:' $D(@(GLPAY _"QCL,""ZE MC"",""MDM TRX"")"))
  35903   "RTN","CHM RSQC1",343 ,0)
  35904    S CHCNTM= CHCNTM+1,C HCNTTM=CHC NTTM+1
  35905   "RTN","CHM RSQC1",344 ,0)
  35906    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35907   "RTN","CHM RSQC1",345 ,0)
  35908    ;I QDT'<C HDT30 S CH O30M=CHO30 M+1,CHO30T M=CHO30TM+ 1
  35909   "RTN","CHM RSQC1",346 ,0)
  35910    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60M=CH O60M+1,CHO 60TM=CHO60 TM+1
  35911   "RTN","CHM RSQC1",347 ,0)
  35912    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90M=CH O90M+1,CHO 90TM=CHO90 TM+1
  35913   "RTN","CHM RSQC1",348 ,0)
  35914    ;I QDT<CH DT90 S CHO 91M=CHO91M +1,CHO91TM =CHO91TM+1
  35915   "RTN","CHM RSQC1",349 ,0)
  35916    I QDT'<CH DT10 S CHO 10M=CHO10M +1,CHO10TM =CHO10TM+1
  35917   "RTN","CHM RSQC1",350 ,0)
  35918    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14M=CHO 14M+1,CHO1 4TM=CHO14T M+1
  35919   "RTN","CHM RSQC1",351 ,0)
  35920    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21M=CHO 21M+1,CHO2 1TM=CHO21T M+1
  35921   "RTN","CHM RSQC1",352 ,0)
  35922    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29M=CHO 29M+1,CHO2 9TM=CHO29T M+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  35923   "RTN","CHM RSQC1",353 ,0)
  35924    I QDT<CHD T30 S CHO3 0M=CHO30M+ 1,CHO30TM= CHO30TM+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  35925   "RTN","CHM RSQC1",354 ,0)
  35926    ;END MOD  PER DEV000 272, SKD 6 -27-07
  35927   "RTN","CHM RSQC1",355 ,0)
  35928    I QDT<CHO DTM S CHOD TM=QDT_U_C HI,CHOLDM= $P(@(GLPAY _"QCL,0)") ,U,1)
  35929   "RTN","CHM RSQC1",356 ,0)
  35930    Q
  35931   "RTN","CHM RSQC1",357 ,0)
  35932    ;HR-PBM-P HASE 1-Beg in - SLM
  35933   "RTN","CHM RSQC1",358 ,0)
  35934    ;The foll owing subr outine add ed for cou nting SXC  data...
  35935   "RTN","CHM RSQC1",359 ,0)
  35936   CNTSXC Q:' $D(@(GLPAY _"QCL,""ZE MC"",""SXC "")"))
  35937   "RTN","CHM RSQC1",360 ,0)
  35938    S CHCNTX= CHCNTX+1,C HCNTTX=CHC NTTX+1
  35939   "RTN","CHM RSQC1",361 ,0)
  35940    ;the foll owing line  added...  SLM 02/22/ 08
  35941   "RTN","CHM RSQC1",362 ,0)
  35942    ;
  35943   "RTN","CHM RSQC1",363 ,0)
  35944    I QDT'<CH DT10 S CHO 10X=CHO10X +1,CHO10TX =CHO10TX+1
  35945   "RTN","CHM RSQC1",364 ,0)
  35946    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14X=CHO 14X+1,CHO1 4TX=CHO14T X+1
  35947   "RTN","CHM RSQC1",365 ,0)
  35948    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21X=CHO 21X+1,CHO2 1TX=CHO21T X+1
  35949   "RTN","CHM RSQC1",366 ,0)
  35950    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29X=CHO 29X+1,CHO2 9TX=CHO29T X+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  35951   "RTN","CHM RSQC1",367 ,0)
  35952    I QDT<CHD T30 S CHO3 0X=CHO30X+ 1,CHO30TX= CHO30TX+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  35953   "RTN","CHM RSQC1",368 ,0)
  35954    I QDT<CHO DTX S CHOD TX=QDT_U_C HI,CHOLDX= $P(@(GLPAY _"QCL,0)") ,U,1)
  35955   "RTN","CHM RSQC1",369 ,0)
  35956    Q
  35957   "RTN","CHM RSQC1",370 ,0)
  35958    ;HR-PBM-P HASE 1-End
  35959   "RTN","CHM RSQC1",371 ,0)
  35960   CNTCMP Q:' $D(@(GLPAY _"QCL,""ZE MC"",""CMO P"")"))
  35961   "RTN","CHM RSQC1",372 ,0)
  35962    S CHCNTC= CHCNTC+1,C HCNTTC=CHC NTTC+1
  35963   "RTN","CHM RSQC1",373 ,0)
  35964    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35965   "RTN","CHM RSQC1",374 ,0)
  35966    ;I QDT'<C HDT30 S CH O30C=CHO30 C+1,CHO30T C=CHO30TC+ 1
  35967   "RTN","CHM RSQC1",375 ,0)
  35968    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60C=CH O60C+1,CHO 60TC=CHO60 TC+1
  35969   "RTN","CHM RSQC1",376 ,0)
  35970    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90C=CH O90C+1,CHO 90TC=CHO90 TC+1
  35971   "RTN","CHM RSQC1",377 ,0)
  35972    ;I QDT<CH DT90 S CHO 91C=CHO91C +1,CHO91TC =CHO91TC+1
  35973   "RTN","CHM RSQC1",378 ,0)
  35974    I QDT'<CH DT10 S CHO 10C=CHO10C +1,CHO10TC =CHO10TC+1
  35975   "RTN","CHM RSQC1",379 ,0)
  35976    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14C=CHO 14C+1,CHO1 4TC=CHO14T C+1
  35977   "RTN","CHM RSQC1",380 ,0)
  35978    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21C=CHO 21C+1,CHO2 1TC=CHO21T C+1
  35979   "RTN","CHM RSQC1",381 ,0)
  35980    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29C=CHO 29C+1,CHO2 9TC=CHO29T C+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  35981   "RTN","CHM RSQC1",382 ,0)
  35982    I QDT<CHD T30 S CHO3 0C=CHO30C+ 1,CHO30TC= CHO30TC+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  35983   "RTN","CHM RSQC1",383 ,0)
  35984    ;END MOD  PER DEV000 272, SKD 6 -27-07
  35985   "RTN","CHM RSQC1",384 ,0)
  35986    I QDT<CHO DTC S CHOD TC=QDT_U_C HI,CHOLDC= $P(@(GLPAY _"QCL,0)") ,U,1)
  35987   "RTN","CHM RSQC1",385 ,0)
  35988    Q
  35989   "RTN","CHM RSQC1",386 ,0)
  35990   CNTPDI S C HCNT=CHCNT +1,CHCNTT= CHCNTT+1
  35991   "RTN","CHM RSQC1",387 ,0)
  35992    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  35993   "RTN","CHM RSQC1",388 ,0)
  35994    ;I QDT'<C HDT30 S CH O30=CHO30+ 1,CHO30T=C HO30T+1
  35995   "RTN","CHM RSQC1",389 ,0)
  35996    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60=CHO 60+1,CHO60 T=CHO60T+1
  35997   "RTN","CHM RSQC1",390 ,0)
  35998    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90=CHO 90+1,CHO90 T=CHO90T+1
  35999   "RTN","CHM RSQC1",391 ,0)
  36000    ;I QDT<CH DT90 S CHO 91=CHO91+1 ,CHO91T=CH O91T+1
  36001   "RTN","CHM RSQC1",392 ,0)
  36002    I QDT'<CH DT10 S CHO 10=CHO10+1 ,CHO10T=CH O10T+1
  36003   "RTN","CHM RSQC1",393 ,0)
  36004    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14=CHO1 4+1,CHO14T =CHO14T+1
  36005   "RTN","CHM RSQC1",394 ,0)
  36006    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21=CHO2 1+1,CHO21T =CHO21T+1
  36007   "RTN","CHM RSQC1",395 ,0)
  36008    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29=CHO2 9+1,CHO29T =CHO29T+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  36009   "RTN","CHM RSQC1",396 ,0)
  36010    I QDT<CHD T30 S CHO3 0=CHO30+1, CHO30T=CHO 30T+1  ;AE B 2/2/2009  DEV004170  CHANGED C HDT29 TO C HDT30
  36011   "RTN","CHM RSQC1",397 ,0)
  36012    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36013   "RTN","CHM RSQC1",398 ,0)
  36014    I QDT<CHO DT S CHODT =QDT_U_CHI ,CHOLD=QPD I
  36015   "RTN","CHM RSQC1",399 ,0)
  36016    S CHOLD=$ E(CHOLD,8, 13)
  36017   "RTN","CHM RSQC1",400 ,0)
  36018    Q
  36019   "RTN","CHM RSQC1",401 ,0)
  36020   CNTNVA Q:C HPGPT'=5
  36021   "RTN","CHM RSQC1",402 ,0)
  36022    Q:'$D(@(G LPAY_"QCL, 0)"))
  36023   "RTN","CHM RSQC1",403 ,0)
  36024    S CHCNTN= CHCNTN+1,C HCNTTN=CHC NTTN+1
  36025   "RTN","CHM RSQC1",404 ,0)
  36026    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36027   "RTN","CHM RSQC1",405 ,0)
  36028    ;I QDT'<C HDT30 S CH O30N=CHO30 N+1,CHO30T N=CHO30TN+ 1
  36029   "RTN","CHM RSQC1",406 ,0)
  36030    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60N=CH O60N+1,CHO 60TN=CHO60 TN+1
  36031   "RTN","CHM RSQC1",407 ,0)
  36032    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90N=CH O90N+1,CHO 90TN=CHO90 TN+1
  36033   "RTN","CHM RSQC1",408 ,0)
  36034    ;I QDT<CH DT90 S CHO 91N=CHO91N +1,CHO91TN =CHO91TN+1
  36035   "RTN","CHM RSQC1",409 ,0)
  36036    I QDT'<CH DT10 S CHO 10N=CHO10N +1,CHO10TN =CHO10TN+1
  36037   "RTN","CHM RSQC1",410 ,0)
  36038    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14N=CHO 14N+1,CHO1 4TN=CHO14T N+1
  36039   "RTN","CHM RSQC1",411 ,0)
  36040    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21N=CHO 21N+1,CHO2 1TN=CHO21T N+1
  36041   "RTN","CHM RSQC1",412 ,0)
  36042    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29N=CHO 29N+1,CHO2 9TN=CHO29T N+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  36043   "RTN","CHM RSQC1",413 ,0)
  36044    I QDT<CHD T30 S CHO3 0N=CHO30N+ 1,CHO30TN= CHO30TN+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  36045   "RTN","CHM RSQC1",414 ,0)
  36046    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36047   "RTN","CHM RSQC1",415 ,0)
  36048    I QDT<CHO DTN S CHOD TN=QDT_U_C HI,CHOLDN= $P(@(GLPAY _"QCL,0)") ,U,1)
  36049   "RTN","CHM RSQC1",416 ,0)
  36050    Q
  36051   "RTN","CHM RSQC1",417 ,0)
  36052   CNTSB Q:'$ D(@(GLPAY_ "QCL,0)"))   I '$D(CH PGPT) S X1 =QCL D PRO GTYP^CHFCD 001
  36053   "RTN","CHM RSQC1",418 ,0)
  36054    Q:CHPGPT' =6
  36055   "RTN","CHM RSQC1",419 ,0)
  36056    S CHCNTS= CHCNTS+1,C HCNTTS=CHC NTTS+1
  36057   "RTN","CHM RSQC1",420 ,0)
  36058    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36059   "RTN","CHM RSQC1",421 ,0)
  36060    ;I QDT'<C HDT30 S CH O30S=CHO30 S+1,CHO30T S=CHO30TS+ 1
  36061   "RTN","CHM RSQC1",422 ,0)
  36062    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60S=CH O60S+1,CHO 60TS=CHO60 TS+1
  36063   "RTN","CHM RSQC1",423 ,0)
  36064    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90S=CH O90S+1,CHO 90TS=CHO90 TS+1
  36065   "RTN","CHM RSQC1",424 ,0)
  36066    ;I QDT<CH DT90 S CHO 91S=CHO91S +1,CHO91TS =CHO91TS+1
  36067   "RTN","CHM RSQC1",425 ,0)
  36068    I QDT'<CH DT10 S CHO 10S=CHO10S +1,CHO10TS =CHO10TS+1
  36069   "RTN","CHM RSQC1",426 ,0)
  36070    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14S=CHO 14S+1,CHO1 4TS=CHO14T S+1
  36071   "RTN","CHM RSQC1",427 ,0)
  36072    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21S=CHO 21S+1,CHO2 1TS=CHO21T S+1
  36073   "RTN","CHM RSQC1",428 ,0)
  36074    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29S=CHO 29S+1,CHO2 9TS=CHO29T S+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  36075   "RTN","CHM RSQC1",429 ,0)
  36076    I QDT<CHD T30 S CHO3 0S=CHO30S+ 1,CHO30TS= CHO30TS+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  36077   "RTN","CHM RSQC1",430 ,0)
  36078    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36079   "RTN","CHM RSQC1",431 ,0)
  36080    I QDT<CHO DTS S CHOD TS=QDT_U_C HI,CHOLDS= $P(@(GLPAY _"QCL,0)") ,U,1)
  36081   "RTN","CHM RSQC1",432 ,0)
  36082    Q
  36083   "RTN","CHM RSQC1",433 ,0)
  36084   CNTHAC Q:' $D(@(GLPAY _"QCL,0)") )  I '$D(C HPGPT) S X 1=QCL D PR OGTYP^CHFC D001
  36085   "RTN","CHM RSQC1",434 ,0)
  36086    Q:CHPGPT> 2
  36087   "RTN","CHM RSQC1",435 ,0)
  36088    S CHCNTH= CHCNTH+1,C HCNTTH=CHC NTTH+1
  36089   "RTN","CHM RSQC1",436 ,0)
  36090    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36091   "RTN","CHM RSQC1",437 ,0)
  36092    ;I QDT'<C HDT30 S CH O30H=CHO30 H+1,CHO30T H=CHO30TH+ 1
  36093   "RTN","CHM RSQC1",438 ,0)
  36094    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60H=CH O60H+1,CHO 60TH=CHO60 TH+1
  36095   "RTN","CHM RSQC1",439 ,0)
  36096    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90H=CH O90H+1,CHO 90TH=CHO90 TH+1
  36097   "RTN","CHM RSQC1",440 ,0)
  36098    ;I QDT<CH DT90 S CHO 91H=CHO91H +1,CHO91TH =CHO91TH+1
  36099   "RTN","CHM RSQC1",441 ,0)
  36100    I QDT'<CH DT10 S CHO 10H=CHO10H +1,CHO10TH =CHO10TH+1
  36101   "RTN","CHM RSQC1",442 ,0)
  36102    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14H=CHO 14H+1,CHO1 4TH=CHO14T H+1
  36103   "RTN","CHM RSQC1",443 ,0)
  36104    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21H=CHO 21H+1,CHO2 1TH=CHO21T H+1
  36105   "RTN","CHM RSQC1",444 ,0)
  36106    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29H=CHO 29H+1,CHO2 9TH=CHO29T H+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  36107   "RTN","CHM RSQC1",445 ,0)
  36108    I QDT<CHD T30 S CHO3 0H=CHO30H+ 1,CHO30TH= CHO30TH+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  36109   "RTN","CHM RSQC1",446 ,0)
  36110    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36111   "RTN","CHM RSQC1",447 ,0)
  36112    I QDT<CHO DTH S CHOD TH=QDT_U_C HI,CHOLDH= $P(@(GLPAY _"QCL,0)") ,U,1)
  36113   "RTN","CHM RSQC1",448 ,0)
  36114    ;If CHAMP VA claim i s CFL then  count CFL  Claim 
  36115   "RTN","CHM RSQC1",449 ,0)
  36116    I $$CFLCH K^CHTFLIB( QCL) D CNT CFL
  36117   "RTN","CHM RSQC1",450 ,0)
  36118    Q
  36119   "RTN","CHM RSQC1",451 ,0)
  36120   CNTWV Q:'$ D(@(GLPAY_ "QCL,0)"))   I '$D(CH PGPT) S X1 =QCL D PRO GTYP^CHFCD 001
  36121   "RTN","CHM RSQC1",452 ,0)
  36122    Q:CHPGPT' =7
  36123   "RTN","CHM RSQC1",453 ,0)
  36124    S CHCNTW= CHCNTW+1,C HCNTTW=CHC NTTW+1
  36125   "RTN","CHM RSQC1",454 ,0)
  36126    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36127   "RTN","CHM RSQC1",455 ,0)
  36128    ;I QDT'<C HDT30 S CH O30W=CHO30 W+1,CHO30T W=CHO30TW+ 1
  36129   "RTN","CHM RSQC1",456 ,0)
  36130    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60W=CH O60W+1,CHO 60TW=CHO60 TW+1
  36131   "RTN","CHM RSQC1",457 ,0)
  36132    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90W=CH O90W+1,CHO 90TW=CHO90 TW+1
  36133   "RTN","CHM RSQC1",458 ,0)
  36134    ;I QDT<CH DT90 S CHO 91W=CHO91W +1,CHO91TW =CHO91TW+1
  36135   "RTN","CHM RSQC1",459 ,0)
  36136    I QDT'<CH DT10 S CHO 10W=CHO10W +1,CHO10TW =CHO10TW+1
  36137   "RTN","CHM RSQC1",460 ,0)
  36138    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14W=CHO 14W+1,CHO1 4TW=CHO14T W+1
  36139   "RTN","CHM RSQC1",461 ,0)
  36140    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21W=CHO 21W+1,CHO2 1TW=CHO21T W+1
  36141   "RTN","CHM RSQC1",462 ,0)
  36142    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29W=CHO 29W+1,CHO2 9TW=CHO29T W+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  36143   "RTN","CHM RSQC1",463 ,0)
  36144    I QDT<CHD T30 S CHO3 0W=CHO30W+ 1,CHO30TW= CHO30TW+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  36145   "RTN","CHM RSQC1",464 ,0)
  36146    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36147   "RTN","CHM RSQC1",465 ,0)
  36148    I QDT<CHO DTW S CHOD TW=QDT_U_C HI,CHOLDW= $P(@(GLPAY _"QCL,0)") ,U,1)
  36149   "RTN","CHM RSQC1",466 ,0)
  36150    Q
  36151   "RTN","CHM RSQC1",467 ,0)
  36152   CNTCFL N D OS,DOB,AGE ,CLFDFN,CL FBFN
  36153   "RTN","CHM RSQC1",468 ,0)
  36154    S CHCNTL= CHCNTL+1,C HCNTTL=CHC NTTL+1
  36155   "RTN","CHM RSQC1",469 ,0)
  36156    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36157   "RTN","CHM RSQC1",470 ,0)
  36158    ;I QDT'<C HDT30 S CH O30L=CHO30 L+1,CHO30T L=CHO30TL+ 1
  36159   "RTN","CHM RSQC1",471 ,0)
  36160    ;I QDT<CH DT30 I QDT '<CHDT60 S  CHO60L=CH O60L+1,CHO 60TL=CHO60 TL+1
  36161   "RTN","CHM RSQC1",472 ,0)
  36162    ;I QDT<CH DT60 I QDT '<CHDT90 S  CHO90L=CH O90L+1,CHO 90TL=CHO90 TL+1
  36163   "RTN","CHM RSQC1",473 ,0)
  36164    ;I QDT<CH DT90 S CHO 91L=CHO91L +1,CHO91TL =CHO91TL+1
  36165   "RTN","CHM RSQC1",474 ,0)
  36166    I QDT'<CH DT10 S CHO 10L=CHO10L +1,CHO10TL =CHO10TL+1
  36167   "RTN","CHM RSQC1",475 ,0)
  36168    I QDT<CHD T10 I QDT' <CHDT14 S  CHO14L=CHO 14L+1,CHO1 4TL=CHO14T L+1
  36169   "RTN","CHM RSQC1",476 ,0)
  36170    I QDT<CHD T14 I QDT' <CHDT21 S  CHO21L=CHO 21L+1,CHO2 1TL=CHO21T L+1
  36171   "RTN","CHM RSQC1",477 ,0)
  36172    I QDT<CHD T21 I QDT' <CHDT30 S  CHO29L=CHO 29L+1,CHO2 9TL=CHO29T L+1  ;AEB  2/2/2009 D EV004170 C HANGED CHD T29 TO CHD T30
  36173   "RTN","CHM RSQC1",478 ,0)
  36174    I QDT<CHD T30 S CHO3 0L=CHO30L+ 1,CHO30TL= CHO30TL+1   ;AEB 2/2/ 2009 DEV00 4170 CHANG ED CHDT29  TO CHDT30
  36175   "RTN","CHM RSQC1",479 ,0)
  36176    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36177   "RTN","CHM RSQC1",480 ,0)
  36178    I QDT<CHO DTL S CHOD TL=QDT_U_C HI,CHOLDL= $P(@(GLPAY _"QCL,0)") ,U,1)
  36179   "RTN","CHM RSQC1",481 ,0)
  36180    Q
  36181   "RTN","CHM RSQC1",482 ,0)
  36182    ; ;HR-PBM -PHASE 1-B egin - SLM
  36183   "RTN","CHM RSQC1",483 ,0)
  36184   TOTSET S ^ CHMRSQ1("M ARSQC","TO TAL","CNT" )=CHCNTT_U _CHCNTTI_U _CHCNTTE_U _CHCNTTM_U _CHCNTTC_U _CHCNTTN_U _CHCNTTS_U _CHCNTTH_U _CHCNTTF_U _CHCNTTW_U _CHCNTTL_U _CHCNTTX_U _CHCNTTR_U _CHCNTTB ;  WTC 9/1/1 7
  36185   "RTN","CHM RSQC1",484 ,0)
  36186    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36187   "RTN","CHM RSQC1",485 ,0)
  36188    ;S ^CHMRS Q1("MARSQC ","TOTAL", "O30")=CHO 30T_U_CHO3 0TI_U_CHO3 0TE_U_CHO3 0TM_U_CHO3 0TC_U_CHO3 0TN_U_CHO3 0TS_U_CHO3 0TH_U_CHO3 0TF_U_CHO3 0TW_U_CHO3 0TL
  36189   "RTN","CHM RSQC1",486 ,0)
  36190    ;S ^CHMRS Q1("MARSQC ","TOTAL", "O60")=CHO 60T_U_CHO6 0TI_U_CHO6 0TE_U_CHO6 0TM_U_CHO6 0TC_U_CHO6 0TN_U_CHO6 0TS_U_CHO6 0TH_U_CHO6 0TF_U_CHO6 0TW_U_CHO6 0TL
  36191   "RTN","CHM RSQC1",487 ,0)
  36192    ;S ^CHMRS Q1("MARSQC ","TOTAL", "O90")=CHO 90T_U_CHO9 0TI_U_CHO9 0TE_U_CHO9 0TM_U_CHO9 0TC_U_CHO9 0TN_U_CHO9 0TS_U_CHO9 0TH_U_CHO9 0TF_U_CHO9 0TW_U_CHO9 0TL
  36193   "RTN","CHM RSQC1",488 ,0)
  36194    ;S ^CHMRS Q1("MARSQC ","TOTAL", "O91")=CHO 91T_U_CHO9 1TI_U_CHO9 1TE_U_CHO9 1TM_U_CHO9 1TC_U_CHO9 1TN_U_CHO9 1TS_U_CHO9 1TH_U_CHO9 1TF_U_CHO9 1TW_U_CHO9 1TL
  36195   "RTN","CHM RSQC1",489 ,0)
  36196    S ^CHMRSQ 1("MARSQC" ,"TOTAL"," O10")=CHO1 0T_U_CHO10 TI_U_CHO10 TE_U_CHO10 TM_U_CHO10 TC_U_CHO10 TN_U_CHO10 TS_U_CHO10 TH_U_CHO10 TF_U_CHO10 TW_U_CHO10 TL_U_CHO10 TX_U_CHO10 TR_U_CHO10 TB ; WTC 9 /1/17
  36197   "RTN","CHM RSQC1",490 ,0)
  36198    S ^CHMRSQ 1("MARSQC" ,"TOTAL"," O14")=CHO1 4T_U_CHO14 TI_U_CHO14 TE_U_CHO14 TM_U_CHO14 TC_U_CHO14 TN_U_CHO14 TS_U_CHO14 TH_U_CHO14 TF_U_CHO14 TW_U_CHO14 TL_U_CHO14 TX_U_CHO14 TR_U_CHO14 TB ; WTC 9 /1/17
  36199   "RTN","CHM RSQC1",491 ,0)
  36200    S ^CHMRSQ 1("MARSQC" ,"TOTAL"," O21")=CHO2 1T_U_CHO21 TI_U_CHO21 TE_U_CHO21 TM_U_CHO21 TC_U_CHO21 TN_U_CHO21 TS_U_CHO21 TH_U_CHO21 TF_U_CHO21 TW_U_CHO21 TL_U_CHO21 TX_U_CHO21 TR_U_CHO21 TB ; WTC 9 /1/17
  36201   "RTN","CHM RSQC1",492 ,0)
  36202    S ^CHMRSQ 1("MARSQC" ,"TOTAL"," O29")=CHO2 9T_U_CHO29 TI_U_CHO29 TE_U_CHO29 TM_U_CHO29 TC_U_CHO29 TN_U_CHO29 TS_U_CHO29 TH_U_CHO29 TF_U_CHO29 TW_U_CHO29 TL_U_CHO29 TX_U_CHO29 TR_U_CHO29 TB ; WTC 9 /1/17
  36203   "RTN","CHM RSQC1",493 ,0)
  36204    S ^CHMRSQ 1("MARSQC" ,"TOTAL"," O30")=CHO3 0T_U_CHO30 TI_U_CHO30 TE_U_CHO30 TM_U_CHO30 TC_U_CHO30 TN_U_CHO30 TS_U_CHO30 TH_U_CHO30 TF_U_CHO30 TW_U_CHO30 TL_U_CHO30 TX_U_CHO30 TR_U_CHO30 TB ; WTC 9 /1/17
  36205   "RTN","CHM RSQC1",494 ,0)
  36206    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36207   "RTN","CHM RSQC1",495 ,0)
  36208   TOTEND Q
  36209   "RTN","CHM RSQC1",496 ,0)
  36210    ;
  36211   "RTN","CHM RSQC1",497 ,0)
  36212    ;HM CPE00 5-016A 08/ 28/2017
  36213   "RTN","CHM RSQC1",498 ,0)
  36214   CNTEDIRO N  DOS,DOB,A GE,CLFDFN, CLFBFN,TMP QDTR,OCLJ
  36215   "RTN","CHM RSQC1",499 ,0)
  36216    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1)
  36217   "RTN","CHM RSQC1",500 ,0)
  36218    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) 
  36219   "RTN","CHM RSQC1",501 ,0)
  36220    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) D
  36221   "RTN","CHM RSQC1",502 ,0)
  36222    .S TMPQDT R=$P(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)"),"^", 1),PRIND=$ E(TMPQDTR, 8,9)
  36223   "RTN","CHM RSQC1",503 ,0)
  36224    .I PRIND= 97 D
  36225   "RTN","CHM RSQC1",504 ,0)
  36226    ..;HM ADD ED COUNTS  FOR EM CLA IMS SECTIO N FOR ALL  PROGRAM IN DICATORS O F 97
  36227   "RTN","CHM RSQC1",505 ,0)
  36228    ..S CHCNT R=CHCNTR+1 ,CHCNTTR=C HCNTTR+1,C HCNTE=CHCN TE+1,CHCNT TE=CHCNTTE +1 ;HM 10/ 12/2017
  36229   "RTN","CHM RSQC1",506 ,0)
  36230    ..I QDT'< CHDT10 S C HO10R=CHO1 0R+1,CHO10 TR=CHO10TR +1,CHO10E= CHO10E+1,C HO10TE=CHO 10TE+1 ;HM  10/12/201 7
  36231   "RTN","CHM RSQC1",507 ,0)
  36232    ..I QDT<C HDT10 I QD T'<CHDT14  S CHO14R=C HO14R+1,CH O14TR=CHO1 4TR+1,CHO1 4E=CHO14E+ 1,CHO14TE= CHO14TE+1  ;HM 10/12/ 2017
  36233   "RTN","CHM RSQC1",508 ,0)
  36234    ..I QDT<C HDT14 I QD T'<CHDT21  S CHO21R=C HO21R+1,CH O21TR=CHO2 1TR+1,CHO2 1E=CHO21E+ 1,CHO21TE= CHO21TE+1  ;HM 10/12/ 2017
  36235   "RTN","CHM RSQC1",509 ,0)
  36236    ..I QDT<C HDT21 I QD T'<CHDT30  S CHO29R=C HO29R+1,CH O29TR=CHO2 9TR+1,CHO2 9E=CHO29E+ 1,CHO29TE= CHO29TE+1  ;HM 10/12/ 2017
  36237   "RTN","CHM RSQC1",510 ,0)
  36238    ..I QDT<C HDT30 S CH O30R=CHO30 R+1,CHO30T R=CHO30TR+ 1,CHO30E=C HO30E+1,CH O30TE=CHO3 0TE+1 ;HM  10/12/2017
  36239   "RTN","CHM RSQC1",511 ,0)
  36240    Q
  36241   "RTN","CHM RSQC1",512 ,0)
  36242    ;
  36243   "RTN","CHM RSQC1",513 ,0)
  36244   CNTEDISB ;
  36245   "RTN","CHM RSQC1",514 ,0)
  36246    ;
  36247   "RTN","CHM RSQC1",515 ,0)
  36248    ;  CPE005 -016B EDI  Re-Open SB  (program  indicator  90)
  36249   "RTN","CHM RSQC1",516 ,0)
  36250    ;
  36251   "RTN","CHM RSQC1",517 ,0)
  36252    N TMPQDTR ,OCLJ,PRIN D ;
  36253   "RTN","CHM RSQC1",518 ,0)
  36254    S QCLJ=99 9999999,QC LJ=$O(@(GL PAY_"QCL," "PDI"",QCL J)"),-1) ;
  36255   "RTN","CHM RSQC1",519 ,0)
  36256    I QCLJ'=" ",$D(@(GLP AY_"QCL,"" PDI"",QCLJ ,0)")) ;
  36257   "RTN","CHM RSQC1",520 ,0)
  36258           I  QCLJ'="",$ D(@(GLPAY_ "QCL,""PDI "",QCLJ,0) ")) D  ;
  36259   "RTN","CHM RSQC1",521 ,0)
  36260           .S  TMPQDTR=$ P(@(GLPAY_ "QCL,""PDI "",QCLJ,0) "),"^",1), PRIND=$E(T MPQDTR,8,9 ) ;
  36261   "RTN","CHM RSQC1",522 ,0)
  36262           .I  PRIND=90  D  ;
  36263   "RTN","CHM RSQC1",523 ,0)
  36264           .. ;HM ADDED  COUNTS FOR  EM CLAIMS  SECTION F OR ALL PRO GRAM INDIC ATORS OF 9 7
  36265   "RTN","CHM RSQC1",524 ,0)
  36266    ..S CHCNT B=CHCNTB+1 ,CHCNTTB=C HCNTTB+1,C HCNTE=CHCN TE+1,CHCNT TE=CHCNTTE +1 ;HM 10/ 12/2017
  36267   "RTN","CHM RSQC1",525 ,0)
  36268           .. I QDT'<CHD T10 S CHO1 0B=CHO10B+ 1,CHO10TB= CHO10TB+1, CHO10E=CHO 10E+1,CHO1 0TE=CHO10T E+1 ;HM 10 /12/2017
  36269   "RTN","CHM RSQC1",526 ,0)
  36270           .. I QDT<CHDT 10 I QDT'< CHDT14 S C HO14B=CHO1 4B+1,CHO14 TB=CHO14TB +1,CHO14E= CHO14E+1,C HO14TE=CHO 14TE+1 ;HM  10/12/201 7
  36271   "RTN","CHM RSQC1",527 ,0)
  36272           .. I QDT<CHDT 14 I QDT'< CHDT21 S C HO21B=CHO2 1B+1,CHO21 TB=CHO21TB +1,CHO21E= CHO21E+1,C HO21TE=CHO 21TE+1 ;HM  10/12/201 7
  36273   "RTN","CHM RSQC1",528 ,0)
  36274           .. I QDT<CHDT 21 I QDT'< CHDT30 S C HO29B=CHO2 9B+1,CHO29 TB=CHO29TB +1,CHO29E= CHO29E+1,C HO29TE=CHO 29TE+1 ;HM  10/12/201 7
  36275   "RTN","CHM RSQC1",529 ,0)
  36276           .. I QDT<CHDT 30 S CHO30 B=CHO30B+1 ,CHO30TB=C HO30TB+1,C HO30E=CHO3 0E+1,CHO30 TE=CHO30TE +1 ;HM 10/ 12/2017
  36277   "RTN","CHM RSQC1",530 ,0)
  36278           Q
  36279   "RTN","CHM RSQC1",531 ,0)
  36280    ;
  36281   "RTN","CHM RSQC1",532 ,0)
  36282   QREP ;
  36283   "RTN","CHM RSQC1",533 ,0)
  36284    ;I '$D(CH FIO) S CHF IO="HAC_HF S$:[KERMIT ]SOQ"_CHDT E_".RPT" ; ADDED FOR  TESTING
  36285   "RTN","CHM RSQC1",534 ,0)
  36286    S %ZIS="Q ",IOP="Q;" _CHFIO D ^ %ZIS G:POP  QREPEND
  36287   "RTN","CHM RSQC1",535 ,0)
  36288    S ZTRTN=" ^CHMRSQP", ZTDESC="ST ATUS OF QU EUES PRINT ",ZTDTH=$H
  36289   "RTN","CHM RSQC1",536 ,0)
  36290    S ZTSAVE( "CHDT")="" ,ZTSAVE("C HDTB")="", ZTSAVE("CH DTE")="",Z TSAVE("CHF IO")=""
  36291   "RTN","CHM RSQC1",537 ,0)
  36292    K ZTIO
  36293   "RTN","CHM RSQC1",538 ,0)
  36294    D ^%ZTLOA D
  36295   "RTN","CHM RSQC1",539 ,0)
  36296    ;D ^CHMRS QP
  36297   "RTN","CHM RSQC1",540 ,0)
  36298   QREPEND Q
  36299   "RTN","CHM RSQC1",541 ,0)
  36300    ;
  36301   "RTN","CHM RSQC1",542 ,0)
  36302   REP D MAIN ^CHMRSQP
  36303   "RTN","CHM RSQC1",543 ,0)
  36304    Q
  36305   "RTN","CHM RSQC1",544 ,0)
  36306    ;
  36307   "RTN","CHM RSQC1",545 ,0)
  36308   FMJUL(FDT)  ;CONVERT  FM DATE TO  JULIAN DA TE
  36309   "RTN","CHM RSQC1",546 ,0)
  36310    N D1,D2,D 3
  36311   "RTN","CHM RSQC1",547 ,0)
  36312    I '$D(FDT ) S FDT=DT
  36313   "RTN","CHM RSQC1",548 ,0)
  36314    S X=$E(FD T,1,3)_"00 00" D H^%D TC S D2=%H
  36315   "RTN","CHM RSQC1",549 ,0)
  36316    S X=FDT D  H^%DTC S  D1=%H
  36317   "RTN","CHM RSQC1",550 ,0)
  36318    S D3=D1-D 2+1 S:D3<1 00 D3="0"_ D3 S:D3<10  D3="0"_D3
  36319   "RTN","CHM RSQC1",551 ,0)
  36320    S D3=$E(F DT,2,3)_D3
  36321   "RTN","CHM RSQC1",552 ,0)
  36322    Q D3
  36323   "RTN","CHM RSQC1",553 ,0)
  36324    ;
  36325   "RTN","CHM RSQC1",554 ,0)
  36326   JULFM(JDT)  ;CONVERT  JULIAN DAT E TO FM DA TE
  36327   "RTN","CHM RSQC1",555 ,0)
  36328    I '$D(JDT ) S JDT=$$ FMJUL(DT)
  36329   "RTN","CHM RSQC1",556 ,0)
  36330    S X=1900+ $E(JDT,1,2 )-1700_"00 00" D H^%D TC
  36331   "RTN","CHM RSQC1",557 ,0)
  36332    S %H=%H+$ E(JDT,3,5) -1 D YMD^% DTC
  36333   "RTN","CHM RSQC1",558 ,0)
  36334    Q X
  36335   "RTN","CHM RSQC1",559 ,0)
  36336    ;
  36337   "RTN","CHM RSQC1",560 ,0)
  36338   FYR(FDT) ; RETURN FIS CAL YEAR A S YYY1001  FROM FM DA TE
  36339   "RTN","CHM RSQC1",561 ,0)
  36340    N Y,M,FYR
  36341   "RTN","CHM RSQC1",562 ,0)
  36342    I '$D(FDT ) S FDT=DT
  36343   "RTN","CHM RSQC1",563 ,0)
  36344    S Y=$E(FD T,1,3),M=$ E(FDT,4,5)
  36345   "RTN","CHM RSQC1",564 ,0)
  36346    S FYR=Y_" 1001" I M< 10 S Y=Y-1 ,FYR=Y_"10 01"
  36347   "RTN","CHM RSQC1",565 ,0)
  36348    Q FYR
  36349   "RTN","CHM RSQC1",566 ,0)
  36350    ;
  36351   "RTN","CHM RSQP")
  36352   0^66^B4831 7458
  36353   "RTN","CHM RSQP",1,0)
  36354   CHMRSQP ;D EN/CJM;STA TUS OF QUE UES/MORNIN G REPORT -  PRINT;09/ 01/98  8:4 4 AM
  36355   "RTN","CHM RSQP",2,0)
  36356    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  36357   "RTN","CHM RSQP",3,0)
  36358    ;DEN/CJM; V1.03;06/1 1/93
  36359   "RTN","CHM RSQP",4,0)
  36360    ;DEN/CJM; V1.02;01/2 8/93
  36361   "RTN","CHM RSQP",5,0)
  36362    ;REVISED  BY RLC;12/ 20/95;ADDE D SECTION  FOR CMOP C LAIMS
  36363   "RTN","CHM RSQP",6,0)
  36364       ;CPE00 5-016A HM/ WTC 8.30.1 7
  36365   "RTN","CHM RSQP",7,0)
  36366    ;CPE005-0 16B WTC 9. 1.17
  36367   "RTN","CHM RSQP",8,0)
  36368    ;
  36369   "RTN","CHM RSQP",9,0)
  36370   MAIN W @IO F D INIT S  FLG=0
  36371   "RTN","CHM RSQP",10,0 )
  36372    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36373   "RTN","CHM RSQP",11,0 )
  36374    D FOOT
  36375   "RTN","CHM RSQP",12,0 )
  36376    D INIT7
  36377   "RTN","CHM RSQP",13,0 )
  36378    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36379   "RTN","CHM RSQP",14,0 )
  36380    D FOOT
  36381   "RTN","CHM RSQP",15,0 )
  36382    D INIT10
  36383   "RTN","CHM RSQP",16,0 )
  36384    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36385   "RTN","CHM RSQP",17,0 )
  36386    D FOOT
  36387   "RTN","CHM RSQP",18,0 )
  36388    W !,"NOTE  1: CHAMPV A CLAIMS =  CHAMPVA +  CFL + CIT I + EM CLA IMS"
  36389   "RTN","CHM RSQP",19,0 )
  36390    W !,"NOTE  2: ALL CL AIMS = CHA MPVA + CWV V + SPINA  BIFIDA + N ON-VA"
  36391   "RTN","CHM RSQP",20,0 )
  36392    D INIT1
  36393   "RTN","CHM RSQP",21,0 )
  36394    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","E OB" D DETA IL
  36395   "RTN","CHM RSQP",22,0 )
  36396    D FOOT
  36397   "RTN","CHM RSQP",23,0 )
  36398    W !,"NOTE  1: CHAMPV A CLAIMS =  CHAMPVA +  CFL + CIT I + EM CLA IMS"
  36399   "RTN","CHM RSQP",24,0 )
  36400    W !,"NOTE  2: ALL CL AIMS = CHA MPVA + CWV V + SPINA  BIFIDA + N ON-VA"
  36401   "RTN","CHM RSQP",25,0 )
  36402    D INIT9
  36403   "RTN","CHM RSQP",26,0 )
  36404    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36405   "RTN","CHM RSQP",27,0 )
  36406    D FOOT
  36407   "RTN","CHM RSQP",28,0 )
  36408    D INIT6
  36409   "RTN","CHM RSQP",29,0 )
  36410    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36411   "RTN","CHM RSQP",30,0 )
  36412    D FOOT
  36413   "RTN","CHM RSQP",31,0 )
  36414    D INIT5
  36415   "RTN","CHM RSQP",32,0 )
  36416    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36417   "RTN","CHM RSQP",33,0 )
  36418    D FOOT
  36419   "RTN","CHM RSQP",34,0 )
  36420    D INIT2
  36421   "RTN","CHM RSQP",35,0 )
  36422    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36423   "RTN","CHM RSQP",36,0 )
  36424    D FOOT
  36425   "RTN","CHM RSQP",37,0 )
  36426    W !," NOT E3: EM CLA IMS = EDI  + CVA EDI  RO + SB ED I RO + MDM TRX + SXC  + CMOP CLA IMS"
  36427   "RTN","CHM RSQP",38,0 )
  36428    D INIT8
  36429   "RTN","CHM RSQP",39,0 )
  36430    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36431   "RTN","CHM RSQP",40,0 )
  36432    D FOOT
  36433   "RTN","CHM RSQP",41,0 )
  36434    D INIT3
  36435   "RTN","CHM RSQP",42,0 )
  36436    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB"  D D ETAIL
  36437   "RTN","CHM RSQP",43,0 )
  36438    D FOOT
  36439   "RTN","CHM RSQP",44,0 )
  36440    ;HR-PBM-P HASE 1-Beg in - SLM
  36441   "RTN","CHM RSQP",45,0 )
  36442    D INIT11
  36443   "RTN","CHM RSQP",46,0 )
  36444    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36445   "RTN","CHM RSQP",47,0 )
  36446    D FOOT
  36447   "RTN","CHM RSQP",48,0 )
  36448    ;HR-PBM-P HASE 1-End
  36449   "RTN","CHM RSQP",49,0 )
  36450    D INIT4
  36451   "RTN","CHM RSQP",50,0 )
  36452    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB"  D D ETAIL
  36453   "RTN","CHM RSQP",51,0 )
  36454    D FOOT
  36455   "RTN","CHM RSQP",52,0 )
  36456    ;HM CPE00 5-016a EDI  ReOpen Us er Story
  36457   "RTN","CHM RSQP",53,0 )
  36458    D INIT12
  36459   "RTN","CHM RSQP",54,0 )
  36460    F QUE="AU D","COQ"," DUP","ELG" ,"GRP","MC CR","MIS", "PRO","QAC PD","QAQMD ","VEN","C AL","CAP", "EOB" D DE TAIL
  36461   "RTN","CHM RSQP",55,0 )
  36462    D FOOT
  36463   "RTN","CHM RSQP",56,0 )
  36464           ;
  36465   "RTN","CHM RSQP",57,0 )
  36466           ;   WTC CPE00 5-016B EDI  ReOpen SB  User Stor y
  36467   "RTN","CHM RSQP",58,0 )
  36468           ;
  36469   "RTN","CHM RSQP",59,0 )
  36470           D  INIT13
  36471   "RTN","CHM RSQP",60,0 )
  36472           F  QUE="AUD", "COQ","DUP ","ELG","G RP","MCCR" ,"MIS","PR O","QACPD" ,"QAQMD"," VEN","CAL" ,"CAP","EO B" D DETAI L
  36473   "RTN","CHM RSQP",61,0 )
  36474           D  FOOT
  36475   "RTN","CHM RSQP",62,0 )
  36476           ;
  36477   "RTN","CHM RSQP",63,0 )
  36478    D KI
  36479   "RTN","CHM RSQP",64,0 )
  36480    K ^CHMRSQ 1("MARSQCA LC")
  36481   "RTN","CHM RSQP",65,0 )
  36482   END Q
  36483   "RTN","CHM RSQP",66,0 )
  36484    ;
  36485   "RTN","CHM RSQP",67,0 )
  36486   INIT S CHT ITLE="CPD  Morning Re port - Sum mary Aging  of Queues "
  36487   "RTN","CHM RSQP",68,0 )
  36488    S $Y=99,C HPG=0,CHPG L=66,CHPGW =132,U="^"    ;SKD 7- 12-07 DEV0 00272
  36489   "RTN","CHM RSQP",69,0 )
  36490    S CHDTR=$ E(DT,4,7), X=$P($H,", ",2),H=X\3 600,M=X#36 00\60
  36491   "RTN","CHM RSQP",70,0 )
  36492    S:M<10 M= "0"_M S:H< 10 H="0"_H  S CHTM=H_ M,CHSITE=" HEALTH ADM INISTRTION  CENTER"
  36493   "RTN","CHM RSQP",71,0 )
  36494    S Y=$P(CH DTE,".",1)  D DD^%DT  S CHDTL=Y
  36495   "RTN","CHM RSQP",72,0 )
  36496    K CHBL S  $P(CHBL,"- ",CHPGW+1) =""
  36497   "RTN","CHM RSQP",73,0 )
  36498    S CHP=1,C HPO=0,CHST ="ALL CLAI MS"
  36499   "RTN","CHM RSQP",74,0 )
  36500    Q
  36501   "RTN","CHM RSQP",75,0 )
  36502    ;
  36503   "RTN","CHM RSQP",76,0 )
  36504   INIT1 S CH P=2,CHPO=1 ,CHST="CIT I CLAIMS"
  36505   "RTN","CHM RSQP",77,0 )
  36506    D HDING,S UBHD S FLG =1
  36507   "RTN","CHM RSQP",78,0 )
  36508    Q
  36509   "RTN","CHM RSQP",79,0 )
  36510    ;
  36511   "RTN","CHM RSQP",80,0 )
  36512   INIT2 S CH P=3,CHPO=2 ,CHST="EM  CLAIMS"
  36513   "RTN","CHM RSQP",81,0 )
  36514    D SUBHD
  36515   "RTN","CHM RSQP",82,0 )
  36516    Q
  36517   "RTN","CHM RSQP",83,0 )
  36518   INIT3 S CH P=4,CHPO=3 ,CHST="MDM TRX CLAIMS "
  36519   "RTN","CHM RSQP",84,0 )
  36520    D SUBHD
  36521   "RTN","CHM RSQP",85,0 )
  36522    Q
  36523   "RTN","CHM RSQP",86,0 )
  36524   INIT4 S CH P=5,CHPO=4 ,CHST="CMO P CLAIMS"
  36525   "RTN","CHM RSQP",87,0 )
  36526    D HDING,S UBHD
  36527   "RTN","CHM RSQP",88,0 )
  36528    Q
  36529   "RTN","CHM RSQP",89,0 )
  36530   INIT5 S CH P=6,CHPO=5 ,CHST="NON -VA CLAIMS "
  36531   "RTN","CHM RSQP",90,0 )
  36532    D HDING,S UBHD S FLG =2
  36533   "RTN","CHM RSQP",91,0 )
  36534    Q
  36535   "RTN","CHM RSQP",92,0 )
  36536   INIT6 S CH P=7,CHPO=6 ,CHST="SB  CLAIMS"
  36537   "RTN","CHM RSQP",93,0 )
  36538    D SUBHD
  36539   "RTN","CHM RSQP",94,0 )
  36540    Q
  36541   "RTN","CHM RSQP",95,0 )
  36542   INIT7 S CH P=8,CHPO=7 ,CHST="CHA MPVA CLAIM S"
  36543   "RTN","CHM RSQP",96,0 )
  36544    D SUBHD
  36545   "RTN","CHM RSQP",97,0 )
  36546    Q
  36547   "RTN","CHM RSQP",98,0 )
  36548   INIT8 S CH P=9,CHPO=8 ,CHST="EDI  CLAIMS"
  36549   "RTN","CHM RSQP",99,0 )
  36550    D HDING,S UBHD
  36551   "RTN","CHM RSQP",100, 0)
  36552    Q
  36553   "RTN","CHM RSQP",101, 0)
  36554   INIT9 S CH P=10,CHPO= 9,CHST="CW VV CLAIMS"
  36555   "RTN","CHM RSQP",102, 0)
  36556    D SUBHD
  36557   "RTN","CHM RSQP",103, 0)
  36558    Q
  36559   "RTN","CHM RSQP",104, 0)
  36560   INIT10 S C HP=11,CHPO =10,CHST=" CFL CLAIMS "
  36561   "RTN","CHM RSQP",105, 0)
  36562    D SUBHD
  36563   "RTN","CHM RSQP",106, 0)
  36564    Q
  36565   "RTN","CHM RSQP",107, 0)
  36566    ;HR-PBM-P HASE 1-Beg in - SLM
  36567   "RTN","CHM RSQP",108, 0)
  36568   INIT11 S C HP=12,CHPO =11,CHST=" SXC CLAIMS "
  36569   "RTN","CHM RSQP",109, 0)
  36570    D SUBHD
  36571   "RTN","CHM RSQP",110, 0)
  36572    Q
  36573   "RTN","CHM RSQP",111, 0)
  36574    ;HR-PBM-P HASE 1-End
  36575   "RTN","CHM RSQP",112, 0)
  36576    ;
  36577   "RTN","CHM RSQP",113, 0)
  36578    ;HM CPE00 5-016a EDI  ReOpen Us er Story
  36579   "RTN","CHM RSQP",114, 0)
  36580   INIT12 S C HP=13,CHPO =12,CHST=" CVA EDI RO  CLAIMS"
  36581   "RTN","CHM RSQP",115, 0)
  36582    D HDING,S UBHD
  36583   "RTN","CHM RSQP",116, 0)
  36584    Q
  36585   "RTN","CHM RSQP",117, 0)
  36586    ;
  36587   "RTN","CHM RSQP",118, 0)
  36588   INIT13 ;
  36589   "RTN","CHM RSQP",119, 0)
  36590    ;
  36591   "RTN","CHM RSQP",120, 0)
  36592    ; WTC CPE 005-016B E DI ReOpen  SB User St ory
  36593   "RTN","CHM RSQP",121, 0)
  36594    ;
  36595   "RTN","CHM RSQP",122, 0)
  36596    S CHP=14, CHPO=13,CH ST="SB EDI  RO CLAIMS "
  36597   "RTN","CHM RSQP",123, 0)
  36598           D  HDING,SUBH D
  36599   "RTN","CHM RSQP",124, 0)
  36600           Q
  36601   "RTN","CHM RSQP",125, 0)
  36602           ;
  36603   "RTN","CHM RSQP",126, 0)
  36604   KI K CHBL, CHDTL,CHDT R,CHNEWPG, CHPG,CHPGL
  36605   "RTN","CHM RSQP",127, 0)
  36606    K CHPGW,C HSITE,CHTI TLE,CHTITL E1,CHTM,CH CNT,CHO30, CHOLD,CHOD T,QUE
  36607   "RTN","CHM RSQP",128, 0)
  36608    K CHP,FLG
  36609   "RTN","CHM RSQP",129, 0)
  36610    Q
  36611   "RTN","CHM RSQP",130, 0)
  36612    ;
  36613   "RTN","CHM RSQP",131, 0)
  36614   DETAIL B:C HP=10
  36615   "RTN","CHM RSQP",132, 0)
  36616    S CHCNT=$ P(^CHMRSQ1 ("MARSQ",Q UE,"CNT"), U,CHP)
  36617   "RTN","CHM RSQP",133, 0)
  36618    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36619   "RTN","CHM RSQP",134, 0)
  36620    ;S CHO30= $P(^CHMRSQ 1("MARSQ", QUE,"O30") ,U,CHP)
  36621   "RTN","CHM RSQP",135, 0)
  36622    ;S CHO60= $P(^CHMRSQ 1("MARSQ", QUE,"O60") ,U,CHP)
  36623   "RTN","CHM RSQP",136, 0)
  36624    ;S CHO90= $P(^CHMRSQ 1("MARSQ", QUE,"O90") ,U,CHP)
  36625   "RTN","CHM RSQP",137, 0)
  36626    ;S CHO91= $P(^CHMRSQ 1("MARSQ", QUE,"O91") ,U,CHP)
  36627   "RTN","CHM RSQP",138, 0)
  36628    S CHO10=$ P(^CHMRSQ1 ("MARSQ",Q UE,"O10"), U,CHP)
  36629   "RTN","CHM RSQP",139, 0)
  36630    S CHO14=$ P(^CHMRSQ1 ("MARSQ",Q UE,"O14"), U,CHP)
  36631   "RTN","CHM RSQP",140, 0)
  36632    S CHO21=$ P(^CHMRSQ1 ("MARSQ",Q UE,"O21"), U,CHP)
  36633   "RTN","CHM RSQP",141, 0)
  36634    S CHO29=$ P(^CHMRSQ1 ("MARSQ",Q UE,"O29"), U,CHP)
  36635   "RTN","CHM RSQP",142, 0)
  36636    S CHO30=$ P(^CHMRSQ1 ("MARSQ",Q UE,"O30"), U,CHP)
  36637   "RTN","CHM RSQP",143, 0)
  36638    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36639   "RTN","CHM RSQP",144, 0)
  36640    S CHOLD=$ P(^CHMRSQ1 ("MARSQ",Q UE,"OLD"), U,CHP) I C HOLD="" S  CHPGPT=1 G  D1
  36641   "RTN","CHM RSQP",145, 0)
  36642    S CLMPT=0 ,CLMPT=$O( ^CHMINDEX( "B",CHOLD, CLMPT)) I  'CLMPT S C HPGPT=1 G  D1
  36643   "RTN","CHM RSQP",146, 0)
  36644    S X1=CLMP T D PROGTY P^CHFCD001
  36645   "RTN","CHM RSQP",147, 0)
  36646    S:CHPGPT= 1 CHOLD="C V "_CHOLD  S:CHPGPT=2  CHOLD="CV  "_CHOLD
  36647   "RTN","CHM RSQP",148, 0)
  36648    S:CHPGPT= 3 CHOLD="F MP"_CHOLD  S:CHPGPT=4  CHOLD="PG W"_CHOLD
  36649   "RTN","CHM RSQP",149, 0)
  36650    S:CHPGPT= 5 CHOLD="N V "_CHOLD  S:CHPGPT=6  CHOLD="SB  "_CHOLD
  36651   "RTN","CHM RSQP",150, 0)
  36652    S:CHPGPT= 7 CHOLD="W V "_CHOLD
  36653   "RTN","CHM RSQP",151, 0)
  36654   D1 S CHODT =$P(^CHMRS Q1("MARSQ" ,QUE,"ODT" ),U,CHP+CH PO) S:CHOD T["99999"  CHODT=""
  36655   "RTN","CHM RSQP",152, 0)
  36656    ;I CHODT' ="" S Y=CH ODT D DD^% DT S CHODT =$P(Y,"@", 1)
  36657   "RTN","CHM RSQP",153, 0)
  36658    D CKTOP
  36659   "RTN","CHM RSQP",154, 0)
  36660    I QUE="QA CPD" W !," QA-CPD" G  DET1
  36661   "RTN","CHM RSQP",155, 0)
  36662    I QUE="QA QMD" W !," QA-QMD" G  DET1
  36663   "RTN","CHM RSQP",156, 0)
  36664    I QUE="GR P" W !,"GR OUPER" G D ET1
  36665   "RTN","CHM RSQP",157, 0)
  36666    W !,QUE
  36667   "RTN","CHM RSQP",158, 0)
  36668   DET1 W ?25 ,$J(CHCNT, 9)   ;W ?1 5,$J(CHCNT ,9) ; DEV0 00272, SKD  6-27-07
  36669   "RTN","CHM RSQP",159, 0)
  36670    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36671   "RTN","CHM RSQP",160, 0)
  36672    ;W ?26,$J (CHO30,7)
  36673   "RTN","CHM RSQP",161, 0)
  36674    ;W ?36,$J (CHO60,7)
  36675   "RTN","CHM RSQP",162, 0)
  36676    ;W ?46,$J (CHO90,7)
  36677   "RTN","CHM RSQP",163, 0)
  36678    ;W ?56,$J (CHO91,7)
  36679   "RTN","CHM RSQP",164, 0)
  36680    ;S:CHOLD= 0 CHOLD=""  W ?65,CHO LD S:CHOLD ="" CHODT= ""
  36681   "RTN","CHM RSQP",165, 0)
  36682    W ?39,$J( CHO10,7)
  36683   "RTN","CHM RSQP",166, 0)
  36684    W ?54,$J( CHO14,7)
  36685   "RTN","CHM RSQP",167, 0)
  36686    W ?69,$J( CHO21,7)
  36687   "RTN","CHM RSQP",168, 0)
  36688    W ?84,$J( CHO29,7)
  36689   "RTN","CHM RSQP",169, 0)
  36690    W ?99,$J( CHO30,7)
  36691   "RTN","CHM RSQP",170, 0)
  36692    S:CHOLD=0  CHOLD=""  W ?115,CHO LD S:CHOLD ="" CHODT= ""  ;DEV00 0272, SKD  7-13-07;   W ?75,CHOL D
  36693   "RTN","CHM RSQP",171, 0)
  36694    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36695   "RTN","CHM RSQP",172, 0)
  36696    ;W ?60,CH ODT
  36697   "RTN","CHM RSQP",173, 0)
  36698   DETEND Q
  36699   "RTN","CHM RSQP",174, 0)
  36700    ;
  36701   "RTN","CHM RSQP",175, 0)
  36702   FOOT D CKT OP
  36703   "RTN","CHM RSQP",176, 0)
  36704    W !,"   T OTAL"
  36705   "RTN","CHM RSQP",177, 0)
  36706    W ?25,$J( $P(^CHMRSQ 1("MARSQ", "TOTAL","C NT"),U,CHP ),9)
  36707   "RTN","CHM RSQP",178, 0)
  36708    ;BEG MOD  PER DEV000 272, SKD 6 -27-07
  36709   "RTN","CHM RSQP",179, 0)
  36710    ;W ?26,$J ($P(^CHMRS Q1("MARSQ" ,"TOTAL"," O30"),U,CH P),7)
  36711   "RTN","CHM RSQP",180, 0)
  36712    ;W ?36,$J ($P(^CHMRS Q1("MARSQ" ,"TOTAL"," O60"),U,CH P),7)
  36713   "RTN","CHM RSQP",181, 0)
  36714    ;W ?46,$J ($P(^CHMRS Q1("MARSQ" ,"TOTAL"," O90"),U,CH P),7)
  36715   "RTN","CHM RSQP",182, 0)
  36716    ;W ?56,$J ($P(^CHMRS Q1("MARSQ" ,"TOTAL"," O91"),U,CH P),7)
  36717   "RTN","CHM RSQP",183, 0)
  36718    W ?39,$J( $P(^CHMRSQ 1("MARSQ", "TOTAL","O 10"),U,CHP ),7)
  36719   "RTN","CHM RSQP",184, 0)
  36720    W ?54,$J( $P(^CHMRSQ 1("MARSQ", "TOTAL","O 14"),U,CHP ),7)
  36721   "RTN","CHM RSQP",185, 0)
  36722    W ?69,$J( $P(^CHMRSQ 1("MARSQ", "TOTAL","O 21"),U,CHP ),7)
  36723   "RTN","CHM RSQP",186, 0)
  36724    W ?84,$J( $P(^CHMRSQ 1("MARSQ", "TOTAL","O 29"),U,CHP ),7)
  36725   "RTN","CHM RSQP",187, 0)
  36726    W ?99,$J( $P(^CHMRSQ 1("MARSQ", "TOTAL","O 30"),U,CHP ),7)
  36727   "RTN","CHM RSQP",188, 0)
  36728    ;END MOD  PER DEV000 272, SKD 6 -27-07
  36729   "RTN","CHM RSQP",189, 0)
  36730    G:CHST="E DI CLAIMS"  FOOTEND G :CHST="MDM TRX CLAIMS " FOOTEND
  36731   "RTN","CHM RSQP",190, 0)
  36732    G:CHST="C MOP CLAIMS " FOOTEND  G:CHST="EM  CLAIMS" F OOTEND
  36733   "RTN","CHM RSQP",191, 0)
  36734    G:CHST="S XC CLAIMS"  FOOTEND G :CHST="CVA  EDI RO CL AIMS" FOOT END G:CHST ="SB EDI R O CLAIMS"  FOOTEND
  36735   "RTN","CHM RSQP",192, 0)
  36736    ;W !
  36737   "RTN","CHM RSQP",193, 0)
  36738   FOOTEND Q
  36739   "RTN","CHM RSQP",194, 0)
  36740    ;
  36741   "RTN","CHM RSQP",195, 0)
  36742   CKTOP D:$Y >CHPGL HDI NG,SUBHD
  36743   "RTN","CHM RSQP",196, 0)
  36744    Q
  36745   "RTN","CHM RSQP",197, 0)
  36746    ;
  36747   "RTN","CHM RSQP",198, 0)
  36748   HDING S $Y =0,CHPG=CH PG+1,CHSIT E="HEALTH  ADMINISTRA TION CENTE R"
  36749   "RTN","CHM RSQP",199, 0)
  36750    W:CHPG>1  #
  36751   "RTN","CHM RSQP",200, 0)
  36752    W DUZ,?(C HPGW-$L(CH SITE))\2,C HSITE,?(CH PGW-$L(CHP G)-6),"Pag e: ",CHPG
  36753   "RTN","CHM RSQP",201, 0)
  36754    W !,CHDTR ,?(CHPGW-$ L(CHTITLE) )\2,CHTITL E
  36755   "RTN","CHM RSQP",202, 0)
  36756    W !,CHTM, ?(CHPGW-$L (CHDTL))\2 ,CHDTL
  36757   "RTN","CHM RSQP",203, 0)
  36758    Q
  36759   "RTN","CHM RSQP",204, 0)
  36760    ;
  36761   "RTN","CHM RSQP",205, 0)
  36762   SUBHD ;I C HST="ALL C LAIMS" W ! !,CHST G S UB1
  36763   "RTN","CHM RSQP",206, 0)
  36764    ;W !!,CHS T
  36765   "RTN","CHM RSQP",207, 0)
  36766   SUB1 W !!, CHST,?25," Number Of" ,?40,"Clai ms",?55,"C laims",?70 ,"Claims", ?85,"Claim s"
  36767   "RTN","CHM RSQP",208, 0)
  36768    W ?100,"C laims"  ;M OD PER DEV 000272, SK D 6-27-07
  36769   "RTN","CHM RSQP",209, 0)
  36770    ;W !,"Que ues",?15," Claims",?2 6,"1-30 Dy s",?36,"31 -60 Dys",? 46,"61-90  Dys",?56," >90 Dys"    ;;MOD PER  DEV000272 , SKD 6-27 -07
  36771   "RTN","CHM RSQP",210, 0)
  36772    W !,"Queu es",?25,"C laims",?39 ,"1-10 Dys ",?54,"11- 14 Dys",?6 9,"15-21 D ys",?84,"2 2-29 Dys", ?99,">30 D ys"     ;M OD PER DEV 000272, SK D 6-27-07
  36773   "RTN","CHM RSQP",211, 0)
  36774    W !,$E(CH BL,1,14),? 25,$E(CHBL ,1,9),?39, $E(CHBL,1, 8),?54,$E( CHBL,1,9), ?69,$E(CHB L,1,9)
  36775   "RTN","CHM RSQP",212, 0)
  36776    ;W ?56,$E (CHBL,1,7)   ;MOD PER  DEV000272 , SKD 6-27 -07
  36777   "RTN","CHM RSQP",213, 0)
  36778    W ?84,$E( CHBL,1,9), ?99,$E(CHB L,1,8)  ;M OD PER DEV 000272, SK D 6-27-07
  36779   "RTN","CHM RSQP",214, 0)
  36780    Q
  36781   "RTN","CHM RSQP",215, 0)
  36782    ;
  36783   "RTN","CHM XDR01")
  36784   0^67^B1890 40768
  36785   "RTN","CHM XDR01",1,0 )
  36786   CHMXDR01 ; CVA/DTP;X1 2 837 MAIN  DRIVER (H EALTH CARE  CLAIM);04 /15/98  10 :29 AM
  36787   "RTN","CHM XDR01",2,0 )
  36788    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  36789   "RTN","CHM XDR01",3,0 )
  36790    ;;1.0
  36791   "RTN","CHM XDR01",4,0 )
  36792    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  36793   "RTN","CHM XDR01",5,0 )
  36794    ;;
  36795   "RTN","CHM XDR01",6,0 )
  36796    ;;DEV0022 17-01 BY A JM (21-MAY -07) OCR C laims caus ing errone ous tradin g
  36797   "RTN","CHM XDR01",7,0 )
  36798    ;;  partn er not fou nd Vista 2 77 Error m essages be ing sent O CRs don't
  36799   "RTN","CHM XDR01",8,0 )
  36800    ;;  requi re 277 fil e creation .
  36801   "RTN","CHM XDR01",9,0 )
  36802    ;;
  36803   "RTN","CHM XDR01",10, 0)
  36804    ;HR-COB-M edicare-A/ B-Begin-93 72 (22-Mar -2010)
  36805   "RTN","CHM XDR01",11, 0)
  36806    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  36807   "RTN","CHM XDR01",12, 0)
  36808    ;HR-COB-M edicare-A/ B-BEGIN-50 10 (12-JUL Y-2011)
  36809   "RTN","CHM XDR01",13, 0)
  36810    ;  CHANGE D THE ACK  STATUS GEN ERATION FU NCTION.  T HE ROUTINE  FOR 4010
  36811   "RTN","CHM XDR01",14, 0)
  36812    ;  GENERA TED ACK ST ATUS RECOR DS BASED O N A LOOPIN G ACTIVITY  WITHIN
  36813   "RTN","CHM XDR01",15, 0)
  36814    ;  RTN1 A ND RTN2. T HE NEW ACK  RECORD GE NERATION I S CONTAINE D IN THE
  36815   "RTN","CHM XDR01",16, 0)
  36816    ;  CHMXWB 21.INT FUN CTION.  TH E LOOP IN  THIS FUNCT ION HAS BE EN DISABLE D.   
  36817   "RTN","CHM XDR01",17, 0)
  36818    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  36819   "RTN","CHM XDR01",18, 0)
  36820    ;
  36821   "RTN","CHM XDR01",19, 0)
  36822    ;;CALLED  BY: CHMXUT 1 VIA THE  ^CHMDIC(74 1002.75 GL OBAL
  36823   "RTN","CHM XDR01",20, 0)
  36824    ;;
  36825   "RTN","CHM XDR01",21, 0)
  36826    ;;CALLS T HREE MAIN  SUBDRIVERS :
  36827   "RTN","CHM XDR01",22, 0)
  36828    ;;CHMXP00 1 READIN O F DATA FRO M 837 OUTP UT FILE CO MING FROM  AFC
  36829   "RTN","CHM XDR01",23, 0)
  36830    ;;CHMXF00 1 CLAIM CR EATION FRO M 837 DATA  INCLUDING  CALL TO A I SYSTEM
  36831   "RTN","CHM XDR01",24, 0)
  36832    ;;CHMXG00 1 GENERATI ON OF 277  RETURN FIL E
  36833   "RTN","CHM XDR01",25, 0)
  36834    ;;THIS DR IVER MONIT ORS THE ST ATUS VALUE  XREF FOR  THE 837 CL AIM CREATI ON
  36835   "RTN","CHM XDR01",26, 0)
  36836    ;;PROCESS  IN BETWEE N EACH SUB DRIVER.  T HE STATUS  VALUE (SV)  XREF CON-
  36837   "RTN","CHM XDR01",27, 0)
  36838    ;;TAINS T HE FOLLOWI NG FORMAT  AND SUBSCR IPTS:
  36839   "RTN","CHM XDR01",28, 0)
  36840    ;;^CHMXCL E("A",CLI, SV,CLAI,CL M-CTRL-# O R PDI-#,CL BI*CLCI*CL EI)="" WHE RE
  36841   "RTN","CHM XDR01",29, 0)
  36842    ;;    CLI =I-VALUE O F ^CHMXCL  (BATCH OR  FILE LEVEL )
  36843   "RTN","CHM XDR01",30, 0)
  36844    ;;    SV= STATUS VAL US,
  36845   "RTN","CHM XDR01",31, 0)
  36846    ;;    CLM -CTRL-#=CL AIM CONTRO L NO. FROM  THE E000  RECORD OF  OUTPUT FIL E,
  36847   "RTN","CHM XDR01",32, 0)
  36848    ;;    PDI -#=HAC PDI  NO.
  36849   "RTN","CHM XDR01",33, 0)
  36850    ;;    CLA I=I-VALUE  OF ^CHMXCL A (TRANSAC TION BATCH  LEVEL)
  36851   "RTN","CHM XDR01",34, 0)
  36852    ;;    CLB I=I-VALUE  OF ^CHMXCL B (PROVIDE R BATCH LE VEL)
  36853   "RTN","CHM XDR01",35, 0)
  36854    ;;    CLC I=I-VALUE  OF ^CHMXCL C (PATIENT  BATCH LEV EL) AND
  36855   "RTN","CHM XDR01",36, 0)
  36856    ;;    CLE I=I-VALUE  OF ^CHMXCL E (CLAIM L EVEL)
  36857   "RTN","CHM XDR01",37, 0)
  36858    ;;STATUS  VALUES ATT AIN THE FO LLOWING VA LUES AT IN DICATED PO INTS:
  36859   "RTN","CHM XDR01",38, 0)
  36860    ;;SV=0 AS SIGNED AT  READIN OF  CLM DATA I N CORRESPO NDING E000  RECORD
  36861   "RTN","CHM XDR01",39, 0)
  36862    ;;SV=1 AS SIGNED AT  COMPLETION  OF FRONT  EDITS ON T HAT CLM DA TA
  36863   "RTN","CHM XDR01",40, 0)
  36864    ;;SV=2 AS SIGNED WHE N THIS CLM  DATA IS G IVEN A PDI  NO.
  36865   "RTN","CHM XDR01",41, 0)
  36866    ;;SV=3 AS SIGNED WHE N CLAIM(S)  HAVE BEEN  CREATED F ROM THIS C LM DATA
  36867   "RTN","CHM XDR01",42, 0)
  36868    ;;SV=4 AS SIGNED WHE N RETURN R EPORT FOR  THIS CLM D ATA IS GEN ERATED
  36869   "RTN","CHM XDR01",43, 0)
  36870    ;;SV=6 AS SIGNED WHE N THIS CLM  DATA FAIL S A FRONT  END EDIT
  36871   "RTN","CHM XDR01",44, 0)
  36872    ;;SV=7 AS SIGNED WHE N PDI NO.  CANNOT BE  GIVEN
  36873   "RTN","CHM XDR01",45, 0)
  36874    ;;SV=8 AS SIGNED WHE N NO CLAIM  NO(S) HAV E BEEN CRE ATED
  36875   "RTN","CHM XDR01",46, 0)
  36876    ;;MAIN DR IVER MONIT ORS STATUS  OF READIN :  NO SV=0  CAN EXIST  FOR BATCH
  36877   "RTN","CHM XDR01",47, 0)
  36878    ;;AFTER R EADIN--ERR OR MSG SEN T IF THIS  CONDITION  EXISTS
  36879   "RTN","CHM XDR01",48, 0)
  36880    ;;MAIN DR IVER MONIT ORS STATUS  OF CLAIM  CREATION:   NO SV=1 O R SV=2 CAN
  36881   "RTN","CHM XDR01",49, 0)
  36882    ;;EXIST F OR BATCH A FTER CLAIM  CREATION- -ERROR MSG  SENT
  36883   "RTN","CHM XDR01",50, 0)
  36884    ;;MAIN DR IVER MONIT ORS STATUS  OF RETURN  277 FILE:   NO SV=1  OR SV=2 OR
  36885   "RTN","CHM XDR01",51, 0)
  36886    ;;SV=3 CA N EXIST--E RROR MSG S ENT
  36887   "RTN","CHM XDR01",52, 0)
  36888    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  36889   "RTN","CHM XDR01",53, 0)
  36890    ;; 12/17/ 2013  DLB  CROSS-REFE RENCES IN  FILEMAN DE FINITON OF  THE EDI R X BATCH PR OCESS: FIL E #741009
  36891   "RTN","CHM XDR01",54, 0)
  36892    ; ^CHMXRX ("B",EDI R X BATCH NU MBER, I) I S THE BATC H NUMBER C ROSS-REFER ENCE: POPU LATED IN C HMXCLM4,CH MXCH04,CHM XCLP04,CHM XNCP4
  36893   "RTN","CHM XDR01",55, 0)
  36894    ; ^CHMXRX ("C",DATE/ TIME TRANS MITTED,I)  IS THE IDE NTIFIER FO R THE FILE  RECEPTION  TIME/DATE : SET IN C HMXCH01,CH MXCLM1,CHM XCP01,CHMX NCP1.INT
  36895   "RTN","CHM XDR01",56, 0)
  36896    ; ^CHMXRX ("D",EDI C LAIM ID,I, J,K) IS TH E PHARMACY  CLAIM ID  CROSS-REFE RENCE: POP ULATED IN  CHMXCH02,C HMXCLM2,CH MXNCP2.INT
  36897   "RTN","CHM XDR01",57, 0)
  36898    ; ^CHMXRX ("E",SECON DARY RESPO NSE FLAG,I ,J,K) IS T HE SECONDA RY RESPONS E FLAG CRO SS-REFEREN CE: POPULA TED IN CHM XCH09,CHMX CLM9,CHMXC P09,CHMXRP 5C
  36899   "RTN","CHM XDR01",58, 0)
  36900    ; ^CHMXRX ("F",SECON DARY RESPO NSE DATE,I ,J,K) IS T HE DATE OF  THE SECON DARY RESPO NSE CROSS- REFERENCE:  POPULATED  IN CHMXRP 5C.INT
  36901   "RTN","CHM XDR01",59, 0)
  36902    ; ^CHMXRX ("G",SOURC E FLAG,I)  IS THE DEF INED SOURC E FLAG CRO SS-REFEREN CE: POPULA TED IN CHM XNCP4.INT
  36903   "RTN","CHM XDR01",60, 0)
  36904    ; ^CHMXRX ("H",SOURC E FILE NAM E,I) IS TH E SOURCE F ILE CROSS- REFERENCE:  POPULATED  IN CHMXNC P1.INT
  36905   "RTN","CHM XDR01",61, 0)
  36906    ; ^CHMXRX ("I",CHAMP VA CLAIM N UMBER,I) I S THE PTR- >^CHMPAY C ROSS-REFER ENCE: POPU LATED IN C HMXCLM9.IN T
  36907   "RTN","CHM XDR01",62, 0)
  36908    ; ^CHMXRX ("J",PRESC RIPTION NU MBER,I,J,K ) IS THE P RESCRIPTIO N NUMBER C ROSS-REFER ENCE: POPU LATED IN C HMXNCP2.IN T
  36909   "RTN","CHM XDR01",63, 0)
  36910    ; ^CHMXRX ("K",PDI,I ,J,K) IS T HE PDI CRO SS-REFEREN CE:  POPUL ATED IN CH MXCLM8.INT
  36911   "RTN","CHM XDR01",64, 0)
  36912    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  36913   "RTN","CHM XDR01",65, 0)
  36914    ;
  36915   "RTN","CHM XDR01",66, 0)
  36916    ;CFS 01/0 7/2018 - C hange dire ctory CHAM PVA_EDI_US ER:[WEBMD]  to HAC_HF S$:[KERMIT ] to accom odate new  DEV enviro nment.
  36917   "RTN","CHM XDR01",67, 0)
  36918    ;
  36919   "RTN","CHM XDR01",68, 0)
  36920   ZSET S:'$D (DUZ) DUZ= 1,DUZ(0)=" " I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  36921   "RTN","CHM XDR01",69, 0)
  36922    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  36923   "RTN","CHM XDR01",70, 0)
  36924    I '$D(IOZ ) S %ZIS=" N",IOP="HO ME" D HOME ^%ZIS S IO Z=IO,IOZL= IOSL,IOZW= IOM,IOZF=I OF,IOZT=IO ST,IOZN=IO N,IOZS=IOS
  36925   "RTN","CHM XDR01",71, 0)
  36926   ZNAM ;
  36927   "RTN","CHM XDR01",72, 0)
  36928    ;
  36929   "RTN","CHM XDR01",73, 0)
  36930   A U 0 ; Pr e-Cache -  > U 0
  36931   "RTN","CHM XDR01",74, 0)
  36932    ;KKAIEL
  36933   "RTN","CHM XDR01",75, 0)
  36934    ;
  36935   "RTN","CHM XDR01",76, 0)
  36936    ;*******  START chec k pdi to s ee if load ed in the  ^CHMIMAGE  global  ** ********** *****    0 8/03/2006  RKN
  36937   "RTN","CHM XDR01",77, 0)
  36938    D RKNPDI
  36939   "RTN","CHM XDR01",78, 0)
  36940    I $D(XPDI DFLAG) C C HFIO K XFI OLG,XFIOLN ,XDDMMYY,X PDI,XTELE, XPDIFOUND, XOCRTYPE,X PDIDFLAG Q      ;I PD I DUPE FLA G QUIT ROU TINE-DON'T  LOAD FILE  02/28/200 6 RKN
  36941   "RTN","CHM XDR01",79, 0)
  36942    C CHFIO
  36943   "RTN","CHM XDR01",80, 0)
  36944    K XFIOLG, XFIOLN,XDD MMYY,XPDI, XTELE,XPDI FOUND,XOCR TYPE,XPDID FLAG
  36945   "RTN","CHM XDR01",81, 0)
  36946    ;*******  END check  pdi to see  if loaded  in the ^C HMIMAGE gl obal  **** ********** ***    08/ 03/2006 RK N
  36947   "RTN","CHM XDR01",82, 0)
  36948    ;
  36949   "RTN","CHM XDR01",83, 0)
  36950    S $ZE=""    ;SKD, 8- 9-06
  36951   "RTN","CHM XDR01",84, 0)
  36952    S $ZT="ER ROR^CHMXDR 01" ; Remo ved break
  36953   "RTN","CHM XDR01",85, 0)
  36954    D SETUP ;  SETS DUZ= "USER,EDI" , KILLS FL AGS
  36955   "RTN","CHM XDR01",86, 0)
  36956    I '$D(CHF IO) D STOP  S CHFLPRB ="",CHMXUN SR="" G RE ADCHK  ; N O EDI VMS  FILE DEFIN ED
  36957   "RTN","CHM XDR01",87, 0)
  36958    O CHFIO:" R":5 ; Pre -Cache ->  O CHFIO:RE ADONLY:5
  36959   "RTN","CHM XDR01",88, 0)
  36960    I '$T D S TOP G END   ; CANNOT  OPEN EDI V MS FILE
  36961   "RTN","CHM XDR01",89, 0)
  36962    ;HR-COB-M edicare-A/ B-Begin-93 72 (22-Mar -2010)
  36963   "RTN","CHM XDR01",90, 0)
  36964    K CHTP  ;  Ensure no  duplicate s
  36965   "RTN","CHM XDR01",91, 0)
  36966    ;D:$D(CHT P) DEBUG^C HMXDR01("C HMXDR01: A : $D(CHTP) = ",$D(CHT P)) 
  36967   "RTN","CHM XDR01",92, 0)
  36968    ;HR-COB-M edicare-A/ B-End-9372  (22-Mar-2 010)
  36969   "RTN","CHM XDR01",93, 0)
  36970    L ^CHMXCL (0) S:'$D( ^CHMXCL(0) ) ^(0)="X1 2 837 BUFF ER FILE LE VEL^741210 .04D^0^0"
  36971   "RTN","CHM XDR01",94, 0)
  36972    S CHMXCLI =$P(^CHMXC L(0),"^",3 )+1,$P(^(0 ),"^",3)=C HMXCLI
  36973   "RTN","CHM XDR01",95, 0)
  36974    S $P(^CHM XCL(0),"^" ,4)=$P(^(0 ),"^",4)+1  L
  36975   "RTN","CHM XDR01",96, 0)
  36976    S ^CHMXCL ("PROCESSI NG",CHMXCL I)=""
  36977   "RTN","CHM XDR01",97, 0)
  36978    S ^CHMXCL ("CLM CNT" ,CHMXCLI)= 0
  36979   "RTN","CHM XDR01",98, 0)
  36980    D ^CHMXP0 01 ; READI N SUBDRIVE R;   NOTE:  CHTP WILL  BE SET IN  THIS ROUT INE
  36981   "RTN","CHM XDR01",99, 0)
  36982    I $D(XPDI DFLAG) C C HFIO K XFI OLG,XFIOLN ,XDDMMYY,X PDI,XTELE, XPDIFOUND, XOCRTYPE,X PDIDFLAG Q  
  36983   "RTN","CHM XDR01",100 ,0)
  36984    ;D DEBUG^ CHMXDR01(" CHMXDR01:  CHMXP001 R TRN: CHTP=  ",CHTP)
  36985   "RTN","CHM XDR01",101 ,0)
  36986   READCHK I  $D(CHMXUNS R) D ^CHMX MM01 G END  ; UNSUCCE SSFUL READ  MSG ; Rem oved break
  36987   "RTN","CHM XDR01",102 ,0)
  36988    I $D(^CHM XCLE("A",C HMXCLI,0))  S CHSTPRB ="" D ^CHM XMM01 G EN D ; UNSUCC ESSFUL REA D MSG
  36989   "RTN","CHM XDR01",103 ,0)
  36990    I $D(CHAL LRJ) D ^CH MXMM05 G R TNTRNS  ;K KAIEL
  36991   "RTN","CHM XDR01",104 ,0)
  36992    D ^CHMXF0 01 ; CLAIM  CREATION  SUBDRIVER  ; Removed  break
  36993   "RTN","CHM XDR01",105 ,0)
  36994   RSTRT ;KKA IEL
  36995   "RTN","CHM XDR01",106 ,0)
  36996    I $D(CHMX UNCC) D ^C HMXMM02 G: $D(CHNODTA ) RTNTRNS  G END ; Re moved brea k
  36997   "RTN","CHM XDR01",107 ,0)
  36998    I ($D(^CH MXCLE("A", CHMXCLI,0) )!$D(^CHMX CLE("A",CH MXCLI,1)))  S CHCCPRB 2="" D ^CH MXMM02 G E ND ; INCOM PLETE CLAI M CREATION  MSG
  36999   "RTN","CHM XDR01",108 ,0)
  37000   RTNTRNS S  (CHTRI,CHT RNCT,CHTRN FG)=0 K CH 277FLG
  37001   "RTN","CHM XDR01",109 ,0)
  37002   RTN1 S CHT RI=$O(^CHM XCLA("B",C HMXCLI,CHT RI)) G:$D( CHRTNQT) R TN2 I 'CHT RI D:CHTRN FG'=0 TRNC NT G RTN2
  37003   "RTN","CHM XDR01",110 ,0)
  37004    D:CHTRNFG '=0 TRNCNT  S CHTRNFG =1
  37005   "RTN","CHM XDR01",111 ,0)
  37006    ;HR-COB-M edicare-A/ B-Begin-93 72 (22-Mar -2010)
  37007   "RTN","CHM XDR01",112 ,0)
  37008    ;S CHTP=$ P(^CHMXCLA (CHTRI,1), "^")
  37009   "RTN","CHM XDR01",113 ,0)
  37010    ;S CHTPI= 0,CHTPI=$O (^CHMXTP(" C",CHTP,CH TPI)) I 'C HTPI S CHR TNRSN=1,CH RTNQT="" G  RTN2
  37011   "RTN","CHM XDR01",114 ,0)
  37012    ;Brenden  - Modified  to look a t COB flag  - must ma tch on TP  id and COB  flag.  CH MEDCOB var iable cont ains the C OB flag se t at routi ne CHMXWT1 .
  37013   "RTN","CHM XDR01",115 ,0)
  37014    ; It indi cates whet her the ed i file is  a cross ov er file or  not (0 no  - 1 yes).   It then  finds the  trading pa rtner with  the same  TP ID  and
  37015   "RTN","CHM XDR01",116 ,0)
  37016    ; same CO B flag set ting.  Ult imately th is allows  a trading  partner wi th the sam e Sender I D to have  two entry  in the tra ding partn er file,
  37017   "RTN","CHM XDR01",117 ,0)
  37018    ; one wit h a cob fl ag set to  "no" and o ne set to  "yes".  As  a result  any given  TP can sen d COB file s and regu lar X12 fi les under  the same S ender ID.
  37019   "RTN","CHM XDR01",118 ,0)
  37020    S CHTPI=$ $GETCHTPI  ; Needed b y other ro utines, to o.
  37021   "RTN","CHM XDR01",119 ,0)
  37022    ;D DEBUG^ CHMXDR01(" CHMXDR01:  RTN1 CHTP=  ",CHTP) 
  37023   "RTN","CHM XDR01",120 ,0)
  37024    I 'CHTPI  S CHRTNRSN =1,CHRTNQT ="" G RTN2   ; IF NO  CHTPI SET  THE QUIT F LAG AND RE ASON VALUE
  37025   "RTN","CHM XDR01",121 ,0)
  37026    ;
  37027   "RTN","CHM XDR01",122 ,0)
  37028    ;HR-COB-M edicare-A/ B-End-9372
  37029   "RTN","CHM XDR01",123 ,0)
  37030    S CHTPABB R=$P(^CHMX TP(CHTPI,0 ),"^",10)   ; GET TRA DING PARTN ER ABBREVI ATED NAME  VALUE
  37031   "RTN","CHM XDR01",124 ,0)
  37032    G:CHTPABB R="OCR" EN D  ;05-03- 2007 AJM D EV002217-0 1
  37033   "RTN","CHM XDR01",125 ,0)
  37034    S CHTPJ=0 ,CHTPJ=$O( ^CHMXTP(CH TPI,103,"B ","HCCSTS" ,CHTPJ)) I  'CHTPJ S  CHRTNRSN=1 ,CHRTNQT=" "  G RTN2
  37035   "RTN","CHM XDR01",126 ,0)
  37036    S CHTPVRN =$P(^CHMXT P(CHTPI,10 3,CHTPJ,0) ,"^",2),CH RNRTN=$P(^ (0),"^",3, 4),CHNMRTN =$P(^(0)," ^",5,6)
  37037   "RTN","CHM XDR01",127 ,0)
  37038    D DEBUG^C HMXDR01("C HMXDR01: R TN1:  CHRN RTN= ",CHR NRTN)
  37039   "RTN","CHM XDR01",128 ,0)
  37040    ;HR-COB-M edicare-A/ B-BEGIN-50 10 
  37041   "RTN","CHM XDR01",129 ,0)
  37042    D @CHRNRT N  ; GENER ATION OF 2 77 OR OTHE R OTHER RE TURN FILE
  37043   "RTN","CHM XDR01",130 ,0)
  37044    ;G:$D(CHR TNQT) RTN2   ; JUST L ET IT FALL  THROUGH
  37045   "RTN","CHM XDR01",131 ,0)
  37046    ;G RTN1   ; NO LONGE R LOOPING  ON CLAIMS  HERE DLB 7 /12/2011
  37047   "RTN","CHM XDR01",132 ,0)
  37048    ;HR-COB-M edicare-A/ B-END-5010  
  37049   "RTN","CHM XDR01",133 ,0)
  37050   RTN2  ;
  37051   "RTN","CHM XDR01",134 ,0)
  37052    I $D(CHRT NQT) D ^CH MXMM03 G E ND
  37053   "RTN","CHM XDR01",135 ,0)
  37054    I $D(^CHM XCLE("A",C HMXCLI,3))  D ^CHMXMM 03 G END ;  INCOMPLET E RETURN F ILE
  37055   "RTN","CHM XDR01",136 ,0)
  37056    ;MARK NOD E IN THE B UFFER 'FIL E' LEVEL F OR D/T OF  RETURN CRE ATED
  37057   "RTN","CHM XDR01",137 ,0)
  37058    ;CALL SNA  PROCESS T O RETURN T HE 277 FIL E OR INVOK E 2NDARY P ROCESS TO
  37059   "RTN","CHM XDR01",138 ,0)
  37060    ;RETURN P ROPRIETARY  FILE
  37061   "RTN","CHM XDR01",139 ,0)
  37062    D ^CHMXMM 04
  37063   "RTN","CHM XDR01",140 ,0)
  37064    ;
  37065   "RTN","CHM XDR01",141 ,0)
  37066   END  ;
  37067   "RTN","CHM XDR01",142 ,0)
  37068    N EDATA,I DX S EDATA =""
  37069   "RTN","CHM XDR01",143 ,0)
  37070    ;D DEBUG( "CHMXDR01:  END: RECO RDED ERROR S = ",$G(^ ZSC("DEBUG ","RCDERR" )))
  37071   "RTN","CHM XDR01",144 ,0)
  37072    S IDX=0
  37073   "RTN","CHM XDR01",145 ,0)
  37074    ;F  S IDX =$O(^ZSC(" CLM","ERRO R",IDX)) Q :IDX=""  D  DEBUG("CH MXDR01: ER ROR = ",ID X_":"_$G(^ ZSC("DEBUG ","ERROR", IDX)))
  37075   "RTN","CHM XDR01",146 ,0)
  37076    ;C LOGFIL E
  37077   "RTN","CHM XDR01",147 ,0)
  37078    ;K ^ZSC(" DEBUG","RC DERR")
  37079   "RTN","CHM XDR01",148 ,0)
  37080    ;K ^ZSC(" DEBUG","ER ROR")
  37081   "RTN","CHM XDR01",149 ,0)
  37082    K ^CHMXCL ("CLM CNT" ,CHMXCLI), ^CHMXCL("P ROCESSING:  ",CHMXCLI )
  37083   "RTN","CHM XDR01",150 ,0)
  37084    D UNSET,K ILALL ; WI PE OUT ALL  EXTRANEOU S VARIABLE S, RESET D UZ
  37085   "RTN","CHM XDR01",151 ,0)
  37086    Q
  37087   "RTN","CHM XDR01",152 ,0)
  37088    ;
  37089   "RTN","CHM XDR01",153 ,0)
  37090    ;HR-COB-M edicare-A/ B-Begin-93 72 (22-Mar -2010)
  37091   "RTN","CHM XDR01",154 ,0)
  37092   GETCHTPI()   ; Get CH TPI given  CHTP
  37093   "RTN","CHM XDR01",155 ,0)
  37094    ; Also ca lled by ot her routin es
  37095   "RTN","CHM XDR01",156 ,0)
  37096    N CHTPI
  37097   "RTN","CHM XDR01",157 ,0)
  37098    ;D DEBUG^ CHMXDR01(" CHMXDR01:   GETCHTPI( ):  CHTP^C HMEDCOB= " ,CHTP_"^"_ CHMEDCOB)
  37099   "RTN","CHM XDR01",158 ,0)
  37100    I ($G(CHT P)="") D
  37101   "RTN","CHM XDR01",159 ,0)
  37102    .S CHTP=$ P(^CHMXCLA (CHTRI,1), "^"),CHTPI =0
  37103   "RTN","CHM XDR01",160 ,0)
  37104    .F  S CHT PI=$O(^CHM XTP("C",CH TP,CHTPI))  Q:'CHTPI   Q:+$P(^CH MXTP(CHTPI ,0),"^",11 )=+$G(CHME DCOB)
  37105   "RTN","CHM XDR01",161 ,0)
  37106    E  D
  37107   "RTN","CHM XDR01",162 ,0)
  37108    .S CHTPI= 0,CHTPI=$O (^CHMXTP(" C",CHTP,CH TPI))
  37109   "RTN","CHM XDR01",163 ,0)
  37110    ;D DEBUG^ CHMXDR01(" CHMXDR01:  GETCHTPI:   CHTPI= ", CHTPI)
  37111   "RTN","CHM XDR01",164 ,0)
  37112    Q CHTPI
  37113   "RTN","CHM XDR01",165 ,0)
  37114    ;HR-COB-M edicare-A/ B-End-9372
  37115   "RTN","CHM XDR01",166 ,0)
  37116    ;
  37117   "RTN","CHM XDR01",167 ,0)
  37118   SETUP ; SE T UP DUZ=" USER,EDI"
  37119   "RTN","CHM XDR01",168 ,0)
  37120    I '$D(^VA (200,"B"," USER,EDI") ) D
  37121   "RTN","CHM XDR01",169 ,0)
  37122    .;D DEBUG ^CHMXDR01( "CHMXDR01:  SETUP 'US ER,EDI NOT  DEFINED'  ",0) 
  37123   "RTN","CHM XDR01",170 ,0)
  37124    .S $ZE="C HUSER^CHMX DR01: USER ,EDI NOT D EFINED"
  37125   "RTN","CHM XDR01",171 ,0)
  37126    .D ^%ET Q
  37127   "RTN","CHM XDR01",172 ,0)
  37128    ;K ^ZSC(" DEBUG","RC DERR")
  37129   "RTN","CHM XDR01",173 ,0)
  37130    ;K ^ZSC(" DEBUG","ER ROR")
  37131   "RTN","CHM XDR01",174 ,0)
  37132    ;S ^ZSC(" DEBUG","RC DERR")=0
  37133   "RTN","CHM XDR01",175 ,0)
  37134    S CHDUZHL D=DUZ
  37135   "RTN","CHM XDR01",176 ,0)
  37136    S (DUZ,CH MFDUZ)=0,( DUZ,CHMFDU Z)=$O(^VA( 200,"B","U SER,EDI",0 ))
  37137   "RTN","CHM XDR01",177 ,0)
  37138    I 'DUZ S  (DUZ,CHMFD UZ)=9944 ;  DEFAULT D UZ SETTING  FOR EDI
  37139   "RTN","CHM XDR01",178 ,0)
  37140    K CHMXUNS R,CHRCER,C HEDPRB,CHR CVLN,CHPRB ,CHVLN,CHE R,CHSTPRB
  37141   "RTN","CHM XDR01",179 ,0)
  37142    K CHBNPRB ,CHVNPRB,C HFLPRB,CHM XUNCC,CHCC PRB,CHCCPR B2,CH277FL G,CHALLRJ
  37143   "RTN","CHM XDR01",180 ,0)
  37144    Q
  37145   "RTN","CHM XDR01",181 ,0)
  37146    ;
  37147   "RTN","CHM XDR01",182 ,0)
  37148   STOP S $ZE ="NO CHFIO /UNABLE TO  OPEN EDI  VMS FILE-- BATCHED ST OPPED" D ^ %ET
  37149   "RTN","CHM XDR01",183 ,0)
  37150    Q
  37151   "RTN","CHM XDR01",184 ,0)
  37152    ;
  37153   "RTN","CHM XDR01",185 ,0)
  37154   TRNCNT ;RE MARKED OFF , NOT USED  PER DAN P . 10/17/20 04 RKN
  37155   "RTN","CHM XDR01",186 ,0)
  37156    ;I $D(CHT RNCT) S $P (^CHMXCLSA (A,0),"^", 6)=CHTRNCT ,CHTRNCT=0
  37157   "RTN","CHM XDR01",187 ,0)
  37158    Q
  37159   "RTN","CHM XDR01",188 ,0)
  37160    ;
  37161   "RTN","CHM XDR01",189 ,0)
  37162   UNSET S DU Z=CHDUZHLD
  37163   "RTN","CHM XDR01",190 ,0)
  37164    K CHRCVLN ,CHPRB,CHV LN,CHER,CH STPRB,CHBN PRB,CHVNPR B,CHFLPRB, CHMXCLI
  37165   "RTN","CHM XDR01",191 ,0)
  37166    K CHMXUNC C,CHXREC,C HLREC,CHFI O,CHNODTA, CHCCPRB,CH DUZHLD,CHM FDUZ,CHMXU NSR
  37167   "RTN","CHM XDR01",192 ,0)
  37168    K CHRCER, CHEDPRB,CH CCPRB2,CHO IO,CH277FL G,CHALLRJ
  37169   "RTN","CHM XDR01",193 ,0)
  37170    Q
  37171   "RTN","CHM XDR01",194 ,0)
  37172    ;
  37173   "RTN","CHM XDR01",195 ,0)
  37174   KILALL K A ,BFN,CH,CH CTRD,CHCTR O,CHMFCLMS ,CHMCL,DFN ,CHBENNM,V FN,CHMVEN, CHMFCORR
  37175   "RTN","CHM XDR01",196 ,0)
  37176    K CHMFACC N,CHMFAMNT ,CHMFASDT, CHMFASS,CH MFBFN,CHMF C,CHMFCLIN ,CHMBEN
  37177   "RTN","CHM XDR01",197 ,0)
  37178    K CHMFCOM M,CHMFCONT ,CHMFCOR,C HMFDATE,CH MFDAYS,CHM FDCBN,CHMF DCVN
  37179   "RTN","CHM XDR01",198 ,0)
  37180    K CHMFDFN ,CHMFELIG, CHMFFIN,CH MFFL,CHMFF L1,CHMFHCP C,CHMFICD9 ,CHMFIMAG
  37181   "RTN","CHM XDR01",199 ,0)
  37182    K CHMFIMC T,CHMFIMNM ,CHMFIMTY, CHMFINCT,C HMFINTC,CH MFINVD,CHM FINVN
  37183   "RTN","CHM XDR01",200 ,0)
  37184    K CHMFKIL ,CHMFLIST, CHMFLOC,CH MFNMPG,CHM FOUT,CHMFP DI,CHMFPGC T,CHMFPGNM
  37185   "RTN","CHM XDR01",201 ,0)
  37186    K CHMFPLA C,CHMFPLPT ,CHMFPRCT, CHMFPS,CHM FPSBN,CHMF REDO,CHMFR EF,CHMFSAM E
  37187   "RTN","CHM XDR01",202 ,0)
  37188    K CHMFSVT Y,CHMFTERM ,CHMFTMBG, CHMFTYPE,C HMFQUIT,CH NB,CHSAME, CHSDX,CHSD Y
  37189   "RTN","CHM XDR01",203 ,0)
  37190    K CHT,CHT Y,CHUP,DBM ,DF,DF1,DF N,DFOUT,DI C,DLAYGO,D R,DTM,F1,F 2,FLAG4,J
  37191   "RTN","CHM XDR01",204 ,0)
  37192    K K,HDA,H LD,HTYPE,I V,NM,NW,PD IFL,SFL,SU RFACE,CHFA RM,TOOTH,T Y,QU,VEN
  37193   "RTN","CHM XDR01",205 ,0)
  37194    K VFN,X,X PLUS,ZCT,Z ICN,CHMCCR FG,CHRXN,C HNDC,CHRXD ,CHRXDP,CH PSN,CHQNT
  37195   "RTN","CHM XDR01",206 ,0)
  37196    K CHBAMT, CHICD9,CHG NIND,CHICD S9,CHDFL,I CD,CHMFGO, CHLTG,ZY,Z X,DY,DX
  37197   "RTN","CHM XDR01",207 ,0)
  37198    K CHUP,CH UPS,CHDOWN ,CHDOWNS,C HSAME,CHOU T,CHSDX,CH SDY,CHANSW ,CHLG
  37199   "RTN","CHM XDR01",208 ,0)
  37200    K CHMFQUI T,CHT,DDOU T,X,Y,ZSTN ,CHREDO,ZS TF,ZTM,ZBM K,CHPTC,CH EKR,CHHDFN
  37201   "RTN","CHM XDR01",209 ,0)
  37202    K CHHBFN, CHOUTER,CH ENTRE,CHFC T,CHFIFLAG ,CMENTR,CH MFEDIT,CHM FENTR
  37203   "RTN","CHM XDR01",210 ,0)
  37204    K CHPPX,C HOUTR,CHGN IND,L9,M,M 1,PRXD,STE FL,Y9,TL,F LAG,FLAG1, FLAG2,FLAG 3
  37205   "RTN","CHM XDR01",211 ,0)
  37206    K FLAG4,S 1,Y1,Y2,AN ,L,N,M9,M8 ,CHMFCOT,C H9,CH99,CH CTL1,CHJ,C HJJ,CHKILR
  37207   "RTN","CHM XDR01",212 ,0)
  37208    K CHKIR,C HNUMBR,CHP ,CHPZ,CHSC T,CHSCTS,C HSCTS1,CHS T1,HIP,PCH MFH
  37209   "RTN","CHM XDR01",213 ,0)
  37210    K CHMFBAS C,PV,CHVEN NM,CHBEN,C HBTCHNO,CH TOBIL,A1,A A,ASKFL,AS S,BAD,BL
  37211   "RTN","CHM XDR01",214 ,0)
  37212    K BLNK1,B LNK2,BN,C, CFL,CHASSG N,CHCODE,C HCOMFL,CHD EF,CHDTA,C HHDT,CHIBT CH
  37213   "RTN","CHM XDR01",215 ,0)
  37214    K CHINGOR ,CHMCCR,CH FMCLNM,CHM FI,CHMFNEX T,CHMFPP,C HMFREVS,CH MFRS,CHMFR TN
  37215   "RTN","CHM XDR01",216 ,0)
  37216    K CHMFSER V,CHMFSORT ,CHMFSRVC, CHMFTY,CHM INUS,CHMNE XT,CHMNRTN ,CHNOW,CHO ICE
  37217   "RTN","CHM XDR01",217 ,0)
  37218    K CHORG,C HSUM,CHUPF L,CL,CLT,C HMAC,CNO,C NT,CT,CT1, CTY,D,D0,D A1,DA2,DDE R
  37219   "RTN","CHM XDR01",218 ,0)
  37220    K DI,DN,D OS,DQ,EX,F IPAY,FKIL, HR,HVFN,HX ,HY,I,ID,I MG,LINW,LL ,LN,MEDPTR
  37221   "RTN","CHM XDR01",219 ,0)
  37222    K MIN,OHI AMT,OHIDOS ,OHIIND,OH INAME,OHIR EC,OHITOS, OHITYP,PAY ,PG,PLS,PS
  37223   "RTN","CHM XDR01",220 ,0)
  37224    K PT,PVN, PY,REC,REC 40,RNG,RNG BD,RNGED,S DATE,SN,SP ,STR,STR1, SUB,SUB1
  37225   "RTN","CHM XDR01",221 ,0)
  37226    K SUB2,SU B3,SUB4,SU B5,SUB6,SV FLD,TAB1,T AB2,TOTSUM ,TSP,VDC,V N,VNPG
  37227   "RTN","CHM XDR01",222 ,0)
  37228    K VREC0,V REC1,XX,Z, ZZPDI,ZVFN ,CHCHVFG,C HDISC,CHDT ,CHMDT,CHM FDTNM
  37229   "RTN","CHM XDR01",223 ,0)
  37230    K CHTYPIN T,CHDTR,ME DAMT,PD,CH TRNCT,CHTR NFG,CHTPAB BR
  37231   "RTN","CHM XDR01",224 ,0)
  37232    Q
  37233   "RTN","CHM XDR01",225 ,0)
  37234    ;
  37235   "RTN","CHM XDR01",226 ,0)
  37236    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  37237   "RTN","CHM XDR01",227 ,0)
  37238    ; EPTEST   - RUN THE  SPECIFIED  FILE OUTS IDE OF THE  "BATCH" M ODE INITIA TIED BY TH E
  37239   "RTN","CHM XDR01",228 ,0)
  37240    ; "WAIT"  ROUTINE
  37241   "RTN","CHM XDR01",229 ,0)
  37242    ; THE TST FILE NAMIN G CONVENTI ON REQUIRE S THE CLAI M TO BE CO MPATIBLE W ITH THE
  37243   "RTN","CHM XDR01",230 ,0)
  37244    ; ^CHMDIC 741002.75  EDI PARAME TER TABLE.  I.E. IF T HE TEST CL AIMS ARE S TANDARD ME DICAL
  37245   "RTN","CHM XDR01",231 ,0)
  37246    ; CLAIMS,  YOU MUST  MAKE "X12"  A PART OF  THE TEST  FILENAME.  IF THE CLA IMS ARE ME DICAL
  37247   "RTN","CHM XDR01",232 ,0)
  37248    ; "COB" C LAIMS, YOU  MUST INCL UDE "COB"  AS A PART  OF THE TES T FILENAME . THIS IS  SO
  37249   "RTN","CHM XDR01",233 ,0)
  37250    ; THE CLA IM TYPES C AN BE RECO GNIZED AND  ROUTED TH ROUGH THE  PROCESSING  LOGIC COR RECTLY.
  37251   "RTN","CHM XDR01",234 ,0)
  37252    ; THIS WA Y THE CLAI M TYPES AR E INDEPEND ENT OF THE  CLEARING  HOUSE FILE NAMES. IF  THE 
  37253   "RTN","CHM XDR01",235 ,0)
  37254    ; FILENAM E CONTAINS  THE "X12"  STRING, T HE CLAIMS  CAN BE DIF FERENTIATE D FROM A F ILENAME
  37255   "RTN","CHM XDR01",236 ,0)
  37256    ; THAT CO NTAINS THE  "COB" STR ING.
  37257   "RTN","CHM XDR01",237 ,0)
  37258    ; NOTE: T HE STANDAR D MEDICAL  CLAIMS (X1 2.DAT) ARE  THE DEFAU LT. IT IS  ONLY NECES SARY
  37259   "RTN","CHM XDR01",238 ,0)
  37260    ; TO IDEN TIFY "COB"  CLAIMS, W HICH REQUI RE ADDITIO NAL LOGIC  TO PROCESS .
  37261   "RTN","CHM XDR01",239 ,0)
  37262    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  37263   "RTN","CHM XDR01",240 ,0)
  37264    ;
  37265   "RTN","CHM XDR01",241 ,0)
  37266   EPTEST(TST FILE)  ;
  37267   "RTN","CHM XDR01",242 ,0)
  37268    ; TSTFILE               THE DIR ECTORY/NAM E OF THE C LAIM FILE  TO PROCESS
  37269   "RTN","CHM XDR01",243 ,0)
  37270    Q:$$ENVIR ^CHTFLIB() ="LIVE"
  37271   "RTN","CHM XDR01",244 ,0)
  37272    N RCH,FNA ME,FILENAM E,X
  37273   "RTN","CHM XDR01",245 ,0)
  37274    S FNAME=" ",CHFIO=""
  37275   "RTN","CHM XDR01",246 ,0)
  37276    I '$D(TST FILE)  D
  37277   "RTN","CHM XDR01",247 ,0)
  37278    .U 0 W:$$ ENVIR^CHTF LIB()'="LI VE" !,"PLE ASE ENTER  A CLAIM FI LENAME.    FORMAT: DI RECTORY PA TH+FILENAM E+EXT"
  37279   "RTN","CHM XDR01",248 ,0)
  37280    .U 0 W:$$ ENVIR^CHTF LIB()'="LI VE" !!,"EX AMPLE: CHA MPVA_EDI:[ KERMITDEV] X12_120125 _72612.DAT   -OR-  CH AMPVA_EDI: [KERMITDEV ]X12.DAT"
  37281   "RTN","CHM XDR01",249 ,0)
  37282    .U 0 W:$$ ENVIR^CHTF LIB()'="LI VE" !!,"AL L CLAIM FI LES MUST R EPRESENT V ALUES IN ^ CHMDIC(741 002.75 (ED I PARAM FI LE)"
  37283   "RTN","CHM XDR01",250 ,0)
  37284    .U 0 W:$$ ENVIR^CHTF LIB()'="LI VE" !,"THE  DATA IN F IELD 1 OF  THE DICTIO NARY DEFIN ITION MUST  APPEAR IN  THE FILEN AME."
  37285   "RTN","CHM XDR01",251 ,0)
  37286    .U 0 W:$$ ENVIR^CHTF LIB()'="LI VE" !,"I.E . ""X12.DA T"" CAN BE  REPRESENT ED AS ""X1 2TST_1234. DAT"","
  37287   "RTN","CHM XDR01",252 ,0)
  37288    .U 0 W:$$ ENVIR^CHTF LIB()'="LI VE" !,"""C OBX12.DAT" " CAN BE R EPRESENTED  AS ""COBX 12_TST_123 4.DAT""."
  37289   "RTN","CHM XDR01",253 ,0)
  37290    .U 0 W:$$ ENVIR^CHTF LIB()'="LI VE" !!,"PL EASE ENTER  THE DESIR ED FILE: "
  37291   "RTN","CHM XDR01",254 ,0)
  37292    .S FILENA ME=$$ASK()   ; ALLOW  USER TO IN PUT TEST F ILENAME
  37293   "RTN","CHM XDR01",255 ,0)
  37294    E  D
  37295   "RTN","CHM XDR01",256 ,0)
  37296    .S FILENA ME=TSTFILE
  37297   "RTN","CHM XDR01",257 ,0)
  37298    S FNAME=F ILENAME
  37299   "RTN","CHM XDR01",258 ,0)
  37300    I FNAME[" ]" D  ; CH ECK FOR DI RECTORY PA TH
  37301   "RTN","CHM XDR01",259 ,0)
  37302    .I FNAME[ ".DAT" D   ; CHECK FI LE EXTENSI ON (OR WRO NG FILE EX TENSION)
  37303   "RTN","CHM XDR01",260 ,0)
  37304    ..S FNAME =$P(FNAME, "]",2)
  37305   "RTN","CHM XDR01",261 ,0)
  37306    ..I FNAME ["_"  D  ;  REMOVE DA TESTAMP IF  EXISTS
  37307   "RTN","CHM XDR01",262 ,0)
  37308    ...S FNAM E=$P(FNAME ,"_",1)
  37309   "RTN","CHM XDR01",263 ,0)
  37310    ..E  S:FN AME[".DAT"  FNAME=$P( FNAME,".", 1)  ; REMO VE THE FIL E EXTENSIO N
  37311   "RTN","CHM XDR01",264 ,0)
  37312    U 0 W:$$E NVIR^CHTFL IB()'="LIV E" !,"FNAM E= ",FNAME
  37313   "RTN","CHM XDR01",265 ,0)
  37314    I FNAME'= ""  D
  37315   "RTN","CHM XDR01",266 ,0)
  37316    .S X=0
  37317   "RTN","CHM XDR01",267 ,0)
  37318    .F X=$O(^ CHMDIC(741 002.75,X))  Q:X=""  D
  37319   "RTN","CHM XDR01",268 ,0)
  37320    ..Q:FNAME '[$P(^CHMD IC(741002. 75,X,0),"^ ",1) 
  37321   "RTN","CHM XDR01",269 ,0)
  37322    ..S CHFIO =FILENAME   ; MUST BE  REPRESENT ED IN THE  EDI PARAM  FILE
  37323   "RTN","CHM XDR01",270 ,0)
  37324    I ('$D(CH FIO))!(CHF IO="") D   Q  ; EXIT  IF NOT DEF INED OR NU LL
  37325   "RTN","CHM XDR01",271 ,0)
  37326    .U 0 W:$$ ENVIR^CHTF LIB()'="LI VE" !,"*** ERROR*** " "",FNAME," "" WAS NOT  FOUND IN  ^CHMDIC(74 1002.75"
  37327   "RTN","CHM XDR01",272 ,0)
  37328    E  U 0 W: $$ENVIR^CH TFLIB()'=" LIVE" !,"C HFIO= ",CH FIO
  37329   "RTN","CHM XDR01",273 ,0)
  37330    S CHFIO=F ILENAME
  37331   "RTN","CHM XDR01",274 ,0)
  37332    S CHMEDCO B=$S(FILEN AME["COB": 1,1:0)   ; IDENTIFY T HE CLAIMS  AS "COB" C LAIMS FOR  PROCESSING
  37333   "RTN","CHM XDR01",275 ,0)
  37334    G ZSET
  37335   "RTN","CHM XDR01",276 ,0)
  37336    ;
  37337   "RTN","CHM XDR01",277 ,0)
  37338   ASK()  ;
  37339   "RTN","CHM XDR01",278 ,0)
  37340    K CHQUIT, CHRTN,CHRE DO,DTOUT,D FOUT,DUOUT ,DQOUT,DDO UT
  37341   "RTN","CHM XDR01",279 ,0)
  37342    D CSBRS^C HSC2  ; HA NDLE USER  INPUT (ANY THING IS P OSSIBLE)
  37343   "RTN","CHM XDR01",280 ,0)
  37344    S:Y'="" Y =$TR(Y,"ab cdefghijkl mnopqrstuv wxyz","ABC DEFGHIJKLM NOPQRSTUVW XYZ")
  37345   "RTN","CHM XDR01",281 ,0)
  37346    I $D(DFOU T) S CHQUI T=""  ; DF OUT="^^":  MAIN MENU;  Y IS SET  TO "" IN C HSC2.INT
  37347   "RTN","CHM XDR01",282 ,0)
  37348    I $D(DUOU T) S CHRTN =""  ; DUO UT="^" : B ACKUP ONE  FIELD; Y I S SET TO " " IN CHSC2 .IN
  37349   "RTN","CHM XDR01",283 ,0)
  37350    I $D(DTOU T) S CHRED O="",Y=""   ; DTOUT=T IMEOUT;Y I S NOT CLEA RED IN CHS C2.INT
  37351   "RTN","CHM XDR01",284 ,0)
  37352    I $D(DQOU T)  ; DQOU T IS  "?"  REQUEST FO R HELP; Y  IS SET TO  "" IN CHSC 2.IN
  37353   "RTN","CHM XDR01",285 ,0)
  37354    I $D(DDOU T) IF Y]""  K DDOUT   ; DDOUT IS  "TAB" INP UT; Y IS N OT CLEARED  IN CHSC2. INT
  37355   "RTN","CHM XDR01",286 ,0)
  37356    Q Y
  37357   "RTN","CHM XDR01",287 ,0)
  37358    ;
  37359   "RTN","CHM XDR01",288 ,0)
  37360    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  37361   "RTN","CHM XDR01",289 ,0)
  37362    ; ERROR -  CLOSE OUT  PROCESSIN G DUE TO A N ERROR
  37363   "RTN","CHM XDR01",290 ,0)
  37364    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  37365   "RTN","CHM XDR01",291 ,0)
  37366    ;
  37367   "RTN","CHM XDR01",292 ,0)
  37368   ERROR C CH FIO
  37369   "RTN","CHM XDR01",293 ,0)
  37370    ;C LOGFIL E
  37371   "RTN","CHM XDR01",294 ,0)
  37372    D ^%ET
  37373   "RTN","CHM XDR01",295 ,0)
  37374    Q
  37375   "RTN","CHM XDR01",296 ,0)
  37376    ;
  37377   "RTN","CHM XDR01",297 ,0)
  37378    ;******** *******Che ck to see  if PDI's f rom X12 fi le has bee n loaded i nto M  ;07 /26/2006 R KN  ****** *********
  37379   "RTN","CHM XDR01",298 ,0)
  37380   RKNPDI ;
  37381   "RTN","CHM XDR01",299 ,0)
  37382    ;G ENDRKN
  37383   "RTN","CHM XDR01",300 ,0)
  37384    I $D(XPDI DFLAG) K X PDIDFLAG,X PDIFOUND   ;K PDI DUP E FLAG 02/ 28/2006 RK N
  37385   "RTN","CHM XDR01",301 ,0)
  37386    K XFIOLG, XFIOLN,XDD MMYY,XPDI, XTELE,XPDI FOUND,XOCR TYPE,XPDID FLAG
  37387   "RTN","CHM XDR01",302 ,0)
  37388    D NOW^%DT C
  37389   "RTN","CHM XDR01",303 ,0)
  37390    S XDDMMYY =$E(%,4,5) _"/"_$E(%, 6,7)_"/20" _$E(%,2,3)
  37391   "RTN","CHM XDR01",304 ,0)
  37392    S XFIOLG= $L(CHFIO)
  37393   "RTN","CHM XDR01",305 ,0)
  37394    C CHFIO
  37395   "RTN","CHM XDR01",306 ,0)
  37396    O CHFIO:" R":5 Q:'$T
  37397   "RTN","CHM XDR01",307 ,0)
  37398    S $ZE="", $ZT="RK1EN D"   ;SKD,  8-9-06
  37399   "RTN","CHM XDR01",308 ,0)
  37400   RK1 U CHFI O G:$ZE["E NDOFFILE"  RK1END R X FIOLN G:$Z E["ENDOFFI LE" RK1END    ;SKD, 8 -9-06
  37401   "RTN","CHM XDR01",309 ,0)
  37402    I $E(XFIO LN,1,4)="A 015" S XOC RTYPE=$E(X FIOLN,35,3 8)
  37403   "RTN","CHM XDR01",310 ,0)
  37404    I $E(XFIO LN,1,4)'=" E001" G RK 1
  37405   "RTN","CHM XDR01",311 ,0)
  37406    I $E(XFIO LN,1,4)="E 001" S XPD I=$E(XFIOL N,5,19),XT ELE=$E(XFI OLN,122,12 7)
  37407   "RTN","CHM XDR01",312 ,0)
  37408    ;
  37409   "RTN","CHM XDR01",313 ,0)
  37410    I $D(^CHM IMAGE(XPDI ,0)) D  C  CHFIO
  37411   "RTN","CHM XDR01",314 ,0)
  37412    .S XPDIFO UND=1,XPDI DFLAG=1
  37413   "RTN","CHM XDR01",315 ,0)
  37414    .S ^CHMZH OLD("OCRDU PEPDIS",XP DI,XTELE,X DDMMYY,$E( %,9,15))=C HFIO_"^"_X OCRTYPE_"^ "_XTELE_"^ "_XDDMMYY_ "@"_$E(%,9 ,15)
  37415   "RTN","CHM XDR01",316 ,0)
  37416    .S CHNB=2 ,ZML(CHNB) ="",CHNB=C HNB+1,CHNB =CHNB+1,ZM L(CHNB)="  ",CHNB=CHN B+1,ZML(CH NB)="OCR d uplicate P DI's possi ble from t he EDI ser ver side b eing pushe d to M"
  37417   "RTN","CHM XDR01",317 ,0)
  37418    .S CHNB=C HNB+1,ZML( CHNB)=" ", CHNB=CHNB+ 1,ZML(CHNB )="OCR fil e "_CHFIO_ " attempte d to re-pr ocess dupl icate PDI' s..."
  37419   "RTN","CHM XDR01",318 ,0)
  37420    .S CHNB=C HNB+1,ZML( CHNB)=" ", CHNB=CHNB+ 1,ZML(CHNB )="OCR typ e: "_XOCRT YPE_"   PD I: "_XPDI_ "   Telefo rm #: "_XT ELE
  37421   "RTN","CHM XDR01",319 ,0)
  37422    .S CHNB=C HNB+1,ZML( CHNB)=" ", CHNB=CHNB+ 1,ZML(CHNB )="Please  research t his incide nt, PDI's. .reference  ^CHMZHOLD ('OCRDUPEP DIS',"_XPD I_","_XTEL E_") globa l"
  37423   "RTN","CHM XDR01",320 ,0)
  37424    .S XMDUZ= .5
  37425   "RTN","CHM XDR01",321 ,0)
  37426    .S XMY(" PII                   ")=""
  37427   "RTN","CHM XDR01",322 ,0)
  37428    .S XMY("
P II                   ")=""
  37429   "RTN","CHM XDR01",323 ,0)
  37430    .S XMY("
P II                     ")=""
  37431   "RTN","CHM XDR01",324 ,0)
  37432    .S XMY(" P I
I                         ")=""
  37433   "RTN","CHM XDR01",325 ,0)
  37434    .S XMTEXT ="ZML(",XM SUB="OCR d uplicate P DI's possi ble"
  37435   "RTN","CHM XDR01",326 ,0)
  37436    .D ^XMD
  37437   "RTN","CHM XDR01",327 ,0)
  37438    .Q
  37439   "RTN","CHM XDR01",328 ,0)
  37440    ;ENDRKN
  37441   "RTN","CHM XDR01",329 ,0)
  37442   RK1END C C HFIO I $ZE ["ENDOFFIL E" S $ZE=" "  ;SKD 8- 9-06
  37443   "RTN","CHM XDR01",330 ,0)
  37444    S $ZE=""
  37445   "RTN","CHM XDR01",331 ,0)
  37446    Q
  37447   "RTN","CHM XDR01",332 ,0)
  37448    ;******** ******   E ND PDI  ;C K DUPE PDI 's 07/26/2 006 RKN  * ********** *******
  37449   "RTN","CHM XDR01",333 ,0)
  37450    ;
  37451   "RTN","CHM XDR01",334 ,0)
  37452    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  37453   "RTN","CHM XDR01",335 ,0)
  37454    ; DEBUG L OGGING ROU TINE USED  TO LOG THE  FRONT END  EDIT PROC ESS, INCLU DING THE 
  37455   "RTN","CHM XDR01",336 ,0)
  37456    ; RECORDS  READ FROM  THE CLAIM  FILE, THE  FUNCTIONS  CALLED TO  PERFORM T HE EDITS,
  37457   "RTN","CHM XDR01",337 ,0)
  37458    ; AND THE  LOGGING O F THE ERRO RS ENCOUNT ERED FROM  THE EDIT P ROCESS.
  37459   "RTN","CHM XDR01",338 ,0)
  37460    ; THE INT ENDED USE  FOR THIS F UNCTION IS  IN  THE D EVELOPMENT  OR TEST E NVIRONMENT S
  37461   "RTN","CHM XDR01",339 ,0)
  37462    ; AND TO  ENSURE THA T IT IS NO T EXECUTED  IN THE "P RODUCTION"  ENVIRONME NT
  37463   "RTN","CHM XDR01",340 ,0)
  37464    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  37465   "RTN","CHM XDR01",341 ,0)
  37466   DEBUG(STR, VALUE)  ;
  37467   "RTN","CHM XDR01",342 ,0)
  37468    ;STR  A U SER PROVID ED STRING  DESCRIBING  THE VALUE  (I.E. "RE CORD INFOR MATION=",
  37469   "RTN","CHM XDR01",343 ,0)
  37470    ;VALUETHE  VALUE TO  BE DISPLAY ED IN THE  LOG FOR TH E LOGGING  ENTRY.
  37471   "RTN","CHM XDR01",344 ,0)
  37472    ; CHECK T HE CURRENT  WORKING E NVIRONMENT
  37473   "RTN","CHM XDR01",345 ,0)
  37474    Q:$$ENVIR ^CHTFLIB() ="LIVE"
  37475   "RTN","CHM XDR01",346 ,0)
  37476    S X=132 X  ^%ZOSF("R M")  ; SET  THE CACHE  DISPLAY T O 132 CHAR ACTERS
  37477   "RTN","CHM XDR01",347 ,0)
  37478    U 0 W !,S TR,VALUE
  37479   "RTN","CHM XDR01",348 ,0)
  37480    Q
  37481   "RTN","CHM XDR01",349 ,0)
  37482    N TMPIO
  37483   "RTN","CHM XDR01",350 ,0)
  37484    S TMPIO=$ IO  ; SAVE  THE CURRE NT IO VARI ABLE
  37485   "RTN","CHM XDR01",351 ,0)
  37486    I '$D(LOG FILE) D  ;  IF NO LOG FILE CREAT ED, CREATE  ONE
  37487   "RTN","CHM XDR01",352 ,0)
  37488    .S LOGFIL E="HAC_HFS $:[KERMIT] LOGFILE.TX T"  ; TARG ET OUTPUT  DIR/FILENA ME - CFS 0 1/07/2018  change VMS  directory .
  37489   "RTN","CHM XDR01",353 ,0)
  37490    .O LOGFIL E:"NWS":5  ; DEBUG OU TPUT FILE   ; OPEN TH E LOGFILE
  37491   "RTN","CHM XDR01",354 ,0)
  37492    .I $D(CHF IO) U LOGF ILE  W !," TESTFILE=  ",CHFIO  ;  RECORD TH E CLAIM FI LE BEING L OGGED
  37493   "RTN","CHM XDR01",355 ,0)
  37494    .;S ^ZSC( $J,0)=0  ;  INITIALIZ E THE RECO RD ERROR C OUNTER
  37495   "RTN","CHM XDR01",356 ,0)
  37496    U LOGFILE  W !,STR,V ALUE  ; OU TPUT LOGGI NG STATEME NT
  37497   "RTN","CHM XDR01",357 ,0)
  37498    U TMPIO   ; RESTORE  TO THE ORI GINAL IO
  37499   "RTN","CHM XDR01",358 ,0)
  37500    Q
  37501   "RTN","CHM XF001")
  37502   0^32^B8363 2900
  37503   "RTN","CHM XF001",1,0 )
  37504   CHMXF001 ; CVA/DTP;X1 2 837 CLAI M CREATION  DRIVER (H EALTH CARE  CLAIMS);0 2/05/99  8 :18 AM
  37505   "RTN","CHM XF001",2,0 )
  37506    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  37507   "RTN","CHM XF001",3,0 )
  37508    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  37509   "RTN","CHM XF001",4,0 )
  37510    ;PT 15932  (Y2K)
  37511   "RTN","CHM XF001",5,0 )
  37512    ;;CALLED  BY CHMXDR0 1-HC CLAIM  (837) MAI N DRIVER A FTER READI N/EDITS
  37513   "RTN","CHM XF001",6,0 )
  37514    ;KKAIEL
  37515   "RTN","CHM XF001",7,0 )
  37516    ;jsg;DEV0 02841-02;4 /30/09;Cre ate ^CHMIM G("VEN-EDI ") for ASV  procesing  in lieu o f "OCR-REA DY"
  37517   "RTN","CHM XF001",8,0 )
  37518    ;HR-COB-M edicare-A/ B-Begin-93 72 (22-Mar -2010)
  37519   "RTN","CHM XF001",9,0 )
  37520    ;JSG2;CPE 005-023;Ad d in new C HAMPVA SYS TEM STATUS  (EDI-REOP EN)
  37521   "RTN","CHM XF001",10, 0)
  37522    ;CFS 10/2 0/2017 - C PE005-004  Add "OCRR- READY" and  "SBOCRR-R EADY" queu es.
  37523   "RTN","CHM XF001",11, 0)
  37524    ;CFS 12/1 5/2017 - C PE005-001  Get Freque ncy Code f or Re-open  PDI gener ation.
  37525   "RTN","CHM XF001",12, 0)
  37526    ;BDB 02/0 6/2018 - C PE005-042  Set PDI st atus, bloc k ready qu eue
  37527   "RTN","CHM XF001",13, 0)
  37528    ;TGH 02/1 6/2018 - C PE005-043  Set PDI in to EDI-PAU SE and if  entered bl ock the re ady queue
  37529   "RTN","CHM XF001",14, 0)
  37530    ;TGH 02/1 6/2018 - C PE005-043  Check EDI- PAUSE entr ies for co mpletion o r changes  to claims 
  37531   "RTN","CHM XF001",15, 0)
  37532    ;                               at beginni ng of each  routine r un
  37533   "RTN","CHM XF001",16, 0)
  37534    ;BDB 01/1 6/19 Rejec t Frequenc y Code 6
  37535   "RTN","CHM XF001",17, 0)
  37536    ;Q:(CHDUZ HLD'=84)&( CHDUZHLD'= 83)
  37537   "RTN","CHM XF001",18, 0)
  37538    D DEBUG^C HMXDR01("  ARRIVED @  CHMXF001:  CHTP= ",CH TP)
  37539   "RTN","CHM XF001",19, 0)
  37540    ;CPE005-0 43 Check E DI-PAUSE q ueue for c ompletion  or changes  to claims  and remov e from Que ue
  37541   "RTN","CHM XF001",20, 0)
  37542    D PAUSECH K^CHROLIB1
  37543   "RTN","CHM XF001",21, 0)
  37544    K PDIFLG, CHXSTYP,CH XCLTYP,CHX FLVR ; PDI FLG ENSURE S PROCESSI NG FOR ONL Y PDI-ASSO CIATED REC ORDS
  37545   "RTN","CHM XF001",22, 0)
  37546   A2 I '$D(^ CHMXCLE("A ",CHMXCLI, 1)) S CHNO DTA="" G E ND ; LOOP  THRU X12 C LAIM RECOR DS WITH ST ATUS VALUE =1
  37547   "RTN","CHM XF001",23, 0)
  37548    S CHMXI=C HMXCLI
  37549   "RTN","CHM XF001",24, 0)
  37550    S (CHAI,C HACLCT,CHA DLCT)=0
  37551   "RTN","CHM XF001",25, 0)
  37552   LOOP1 S CH AI=$O(^CHM XCLE("A",C HMXI,1,CHA I)) I CHAI ="" D TOTS UM G END1
  37553   "RTN","CHM XF001",26, 0)
  37554    S CHAIHLD =CHAI
  37555   "RTN","CHM XF001",27, 0)
  37556    S CHCL=0
  37557   "RTN","CHM XF001",28, 0)
  37558   LOOP2 S CH CL=$O(^CHM XCLE("A",C HMXI,1,CHA I,CHCL)) I  'CHCL D S UM G LOOP1
  37559   "RTN","CHM XF001",29, 0)
  37560    S CHID=""
  37561   "RTN","CHM XF001",30, 0)
  37562   LOOP3 S CH ID=$O(^CHM XCLE("A",C HMXI,1,CHA I,CHCL,CHI D)) I (CHI D="")&($D( PDIFLG)) D  PROCESS G  LOOP2
  37563   "RTN","CHM XF001",31, 0)
  37564    D:$D(PDIF LG) PROCES S
  37565   "RTN","CHM XF001",32, 0)
  37566    G:CHID=""  LOOP2
  37567   "RTN","CHM XF001",33, 0)
  37568    S CHBI=$P (CHID,"*", 1),CHCI=$P (CHID,"*", 2),CHEI=$P (CHID,"*", 3),CHIDHLD =CHID
  37569   "RTN","CHM XF001",34, 0)
  37570    S:$D(^CHM XCLC(CHCI, 80)) CHPYF ILE="^"_$P (^CHMXCLC( CHCI,80)," ^",4) ; BE NE PAYMENT  FILE DEFI NED
  37571   "RTN","CHM XF001",35, 0)
  37572    S:$D(^CHM XCLA(CHAI, 80)) CHXST YP=$P(^CHM XCLA(CHAI, 80),"^",7)  ; EDI/OCR  FLAG
  37573   "RTN","CHM XF001",36, 0)
  37574    I $D(^CHM XCLE(CHEI, 0)) D  ;CP E005-001 G et Claim F lavor and  Frequency  Code. Clai m Flavor D efined (IN ST/PROF/DE NTAL)
  37575   "RTN","CHM XF001",37, 0)
  37576    .S CHXFLV R=$P(^CHMX CLE(CHEI,0 ),"^",5),C HMFREQ=$P( ^CHMXCLE(C HEI,0),"^" ,6)
  37577   "RTN","CHM XF001",38, 0)
  37578    ;S:$D(^CH MXCLE(CHEI ,0)) CHXFL VR=$P(^CHM XCLE(CHEI, 0),"^",5)  ; CLAIM FL AVOR DEFIN ED (INST/P ROF/DENTAL )
  37579   "RTN","CHM XF001",39, 0)
  37580    ;NEXT 5 L INES DEFIN E CLAIM TY PE FOR IP  LOAD (1=83 7I,2=837P, 3=837D,4=O CR/UB,5=OC R/HCFA)
  37581   "RTN","CHM XF001",40, 0)
  37582    S:CHXFLVR ="C" CHXCL TYP=3
  37583   "RTN","CHM XF001",41, 0)
  37584    S:(CHXFLV R="A")&(CH XSTYP=0) C HXCLTYP=1
  37585   "RTN","CHM XF001",42, 0)
  37586    S:(CHXFLV R="A")&(CH XSTYP=1) C HXCLTYP=4
  37587   "RTN","CHM XF001",43, 0)
  37588    S:(CHXFLV R="B")&(CH XSTYP=0) C HXCLTYP=2
  37589   "RTN","CHM XF001",44, 0)
  37590    S:(CHXFLV R="B")&(CH XSTYP=1) C HXCLTYP=5
  37591   "RTN","CHM XF001",45, 0)
  37592    I $D(CHXC LTYP)  D D EBUG^CHMXD R01("CHMXF 001: LOOP3 : -----CLA IM TYPE--- --: ",$S(C HXCLTYP=1: "INST",CHX CLTYP=2:"P ROF",CHXCL TYP=3:"DEN T",CHXCLTY P=4:"UB",C HXCLTYP=5: "HCFA"))
  37593   "RTN","CHM XF001",46, 0)
  37594    ;HR-COB-M edicare-A/ B-Begin-93 72 (22-Mar -2010)
  37595   "RTN","CHM XF001",47, 0)
  37596    ;S CHTPID =$P(^CHMXC LA(CHAI,1) ,"^") I CH TPID="" S  CHVNPRB=""  G END
  37597   "RTN","CHM XF001",48, 0)
  37598    D DEBUG^C HMXDR01("B EFORE GETC HTPI(): CH TP= ",CHTP )
  37599   "RTN","CHM XF001",49, 0)
  37600    I CHTP=""  S CHVNPRB ="" G END
  37601   "RTN","CHM XF001",50, 0)
  37602    ;S VN=0,V N=$O(^CHMX TP("C",CHT PID,VN)) I  'VN S CHV NPRB="" G  END
  37603   "RTN","CHM XF001",51, 0)
  37604    S VN=$$GE TCHTPI^CHM XDR01
  37605   "RTN","CHM XF001",52, 0)
  37606    D DEBUG^C HMXDR01("D O GETCHTPI (): CHTP^V N= ",CHTP_ "^"_VN)
  37607   "RTN","CHM XF001",53, 0)
  37608    I 'VN S C HVNPRB=""  G END
  37609   "RTN","CHM XF001",54, 0)
  37610    ;HR-COB-M edicare-A/ B-End-9372
  37611   "RTN","CHM XF001",55, 0)
  37612    S CHTPID= $P(^CHMXTP (VN,0),"^" ,10)
  37613   "RTN","CHM XF001",56, 0)
  37614    ;K MXVEN, CHMXVNRC,C HVNFCTP
  37615   "RTN","CHM XF001",57, 0)
  37616    S (MXVEN, CHMXVNRC,C HVNFCTP,CH PSVNM,CHPS VTX,CHPSVA D,CHPSVCY, CHPSVST,CH PSVZP)=""
  37617   "RTN","CHM XF001",58, 0)
  37618    S:$D(^CHM XCLB(CHBI, 80)) CHMXV NRC=^CHMXC LB(CHBI,80 ),MXVEN=$P (CHMXVNRC, "^"),CHVNF CTP=$P(CHM XVNRC,"^", 2)
  37619   "RTN","CHM XF001",59, 0)
  37620    ;I MXVEN= "" S CHVNM MRS=2,^CHM XCLE("VNDR  DELT",CHM XI,CHAI,CH ID)="" K P DIFLG G LO OP3
  37621   "RTN","CHM XF001",60, 0)
  37622    D DEBUG^C HMXDR01("C HMXF001: M XVEN= ",MX VEN)
  37623   "RTN","CHM XF001",61, 0)
  37624    I MXVEN D
  37625   "RTN","CHM XF001",62, 0)
  37626    .S (VREC0 ,VREC1,VRE C2,VREC5,V REC41,X1,X 2,X3,X4,X5 )=""
  37627   "RTN","CHM XF001",63, 0)
  37628    .S:$D(^CH MVEN(MXVEN ,0)) VREC0 =^(0) S:$D (^CHMVEN(M XVEN,1)) V REC1=^(1)
  37629   "RTN","CHM XF001",64, 0)
  37630    .S:$D(^CH MVEN(MXVEN ,2)) VREC2 =^(2) S:$D (^CHMVEN(M XVEN,5)) V REC5=^(1)
  37631   "RTN","CHM XF001",65, 0)
  37632    .S JJ="A" ,JJ=$O(^CH MVEN(MXVEN ,41,JJ),-1 )
  37633   "RTN","CHM XF001",66, 0)
  37634    .I JJ I $ D(^CHMVEN( MXVEN,41,J J,0)) S VR EC41=^(0)
  37635   "RTN","CHM XF001",67, 0)
  37636    .S X1=$P( VREC0,"^", 1)_"^"_$P( VREC0,"^", 3)
  37637   "RTN","CHM XF001",68, 0)
  37638    .S X2=$P( VREC2,"^", 1)_"^"_$P( VREC2,"^", 2)_"^"_$P( VREC2,"^", 3)_"^"_$P( VREC2,"^", 4)_"^"_$P( VREC2,"^", 5)_"^"_$P( VREC2,"^", 6)
  37639   "RTN","CHM XF001",69, 0)
  37640    .S X3=$P( VREC1,"^", 7)_"^"_$P( VREC1,"^", 11)
  37641   "RTN","CHM XF001",70, 0)
  37642    .S X4=$P( VREC5,"^", 5),X5=$P(V REC41,"^", 3)
  37643   "RTN","CHM XF001",71, 0)
  37644    E  D
  37645   "RTN","CHM XF001",72, 0)
  37646    .D DEBUG^ CHMXDR01(" $D(^CHMXCL B(CHBI,0)) = ",'$D(^C HMXCLB(CHB I,0)))
  37647   "RTN","CHM XF001",73, 0)
  37648    .Q:'$D(^C HMXCLB(CHB I,0))  S V REC0=^(0)
  37649   "RTN","CHM XF001",74, 0)
  37650    .S CHPSVN M=$P(VREC0 ,"^",3),CH PSVTX=$P(V REC0,"^",2 )
  37651   "RTN","CHM XF001",75, 0)
  37652    .S CHPSVT XL=$L(CHPS VTX) I CHP SVTXL>9 S  CHPSVTXV=C HPSVTXL-9  S CHPSVTX= $E(CHPSVTX ,CHPSVTXV+ 1,999) Q
  37653   "RTN","CHM XF001",76, 0)
  37654    K CHMXSTS ,CLAIM D   G LP3NXT
  37655   "RTN","CHM XF001",77, 0)
  37656    .I $D(^CH MXCLA(CHAI ,80)) I $P (^CHMXCLA( CHAI,80)," ^",7)=1 D   Q:$D(CHMF PDI)
  37657   "RTN","CHM XF001",78, 0)
  37658    ..I $D(^C HMXCLE(CHE I,100)) I  $P(^CHMXCL E(CHEI,100 ),"^",2)'= "" S CHMFP DI=$P(^CHM XCLE(CHEI, 100),"^",2 ) I (CHMFP DI="")!(CH MFPDI'?15N ) K CHMFPD I Q
  37659   "RTN","CHM XF001",79, 0)
  37660    ..D ^CHMX MPD2
  37661   "RTN","CHM XF001",80, 0)
  37662    .D ^CHMXM PDI ; DO P ROCESS OF  CLAIM ONLY  WHEN PDI  DEFINED AN D IMAGE FI LE COMPLET E, THEN PU LL NEXT PD I
  37663   "RTN","CHM XF001",81, 0)
  37664    ;;NEXT LI NE CONDITI ONALIZE/TU RN BACK ON  WHEN SUBM ISSIONS PA SS THROUGH  AI AND BY PASS IP SC REENS
  37665   "RTN","CHM XF001",82, 0)
  37666   LP3NXT ;S  ^CHMIMAGE( CHMFPDI,"V EN-II",MXV EN)=X1_"^" _X2_"^"_X3 _"^"_X4_"^ "_X5
  37667   "RTN","CHM XF001",83, 0)
  37668    D DEBUG^C HMXDR01("  ARRIVED @  LP3NXT:  " ,0)
  37669   "RTN","CHM XF001",84, 0)
  37670    ;
  37671   "RTN","CHM XF001",85, 0)
  37672    ;
  37673   "RTN","CHM XF001",86, 0)
  37674   RKNCPDI ;L oop back t o LOOP3 Ta g/Label if  PDI is al ready in t he ^CHMIMA GE(  globa l, do not  write data  02/24/06  RKN
  37675   "RTN","CHM XF001",87, 0)
  37676    ;D NOW^%D TC
  37677   "RTN","CHM XF001",88, 0)
  37678    ;I $D(^CH MIMAGE(CHM FPDI)) S ^ CHMZHOLD(" X12_DUPEPD I",CHFIO,% )=CHMFPDI_ "^"_CHFIO  D RKNMAIL^ CHMXDR01 G  LOOP3
  37679   "RTN","CHM XF001",89, 0)
  37680    ;
  37681   "RTN","CHM XF001",90, 0)
  37682    ;
  37683   "RTN","CHM XF001",91, 0)
  37684    D DEBUG^C HMXDR01("C HMXF001:RK NCPDI:  PD I= ",CHMFP DI)
  37685   "RTN","CHM XF001",92, 0)
  37686    I CHMFREQ '=6 D:'$D( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN")) ^C HMXVN02 ;  SET VENDOR  NODE OF I MAGE FILE  ;BDB 01/16 /19 Reject  Frequency  Code 6
  37687   "RTN","CHM XF001",93, 0)
  37688    I '$D(^CH MXCLC(CHCI ,80)) S CH BNPRB="" G  END
  37689   "RTN","CHM XF001",94, 0)
  37690    S BNREC=^ CHMXCLC(CH CI,80),CHD FN=$P(BNRE C,"^"),CHB FN=$P(BNRE C,"^",2)
  37691   "RTN","CHM XF001",95, 0)
  37692    I (CHDFN= "")!(CHBFN ="") S CHB NPRB="" G  END
  37693   "RTN","CHM XF001",96, 0)
  37694    D PDI^CHM XF010 ; IN SERT PDI I N BUFFER F ILE AND "A " XREF
  37695   "RTN","CHM XF001",97, 0)
  37696    D ^CHMXF0 02 ; FUTUR E CALL TO  AI SYSTEM  FOR EDI TO S DECISION S HERE--#1  OPTION
  37697   "RTN","CHM XF001",98, 0)
  37698    D DEBUG^C HMXDR01("R EADY TO GO  TO CHMXF0 03: ",0)
  37699   "RTN","CHM XF001",99, 0)
  37700    D ^CHMXF0 03 G:$D(CH CCPRB) END
  37701   "RTN","CHM XF001",100 ,0)
  37702    G LOOP3
  37703   "RTN","CHM XF001",101 ,0)
  37704    ;
  37705   "RTN","CHM XF001",102 ,0)
  37706   END S:($D( CHNODTA))! ($D(CHVNPR B))!($D(CH BNPRB))!($ D(CHCCPRB) ) CHMXUNCC =""
  37707   "RTN","CHM XF001",103 ,0)
  37708   END1 I $D( CHVNMMRS)  D ^CHMXMM1 0 K ^CHMXC LE("VNDR D ELT")
  37709   "RTN","CHM XF001",104 ,0)
  37710    K PDIFLG, CHMXI,CHAI ,CHACLCT,C HADLCT,CHA I,CHAIHLD, CHCL,CHID, CHIDHLD,CH BI
  37711   "RTN","CHM XF001",105 ,0)
  37712    K CHCI,CH EI,CHTPID, VN,MXVEN,C HMXVNRC,CH VNFCTP,VNR EC,CHPSVNM ,CHARGE,CH FI
  37713   "RTN","CHM XF001",106 ,0)
  37714    K CHPSVTX ,CHPSVAD,C HPSVCY,CHP SVST,CHPSV ZP,BNREC,C HDFN,CHBFN ,AI,CHTOTC L
  37715   "RTN","CHM XF001",107 ,0)
  37716    K CHTOTDL ,CHEJ,CHTO TPG,CHREL, CHREC0,CHT OSJ,CHTOS, CHADM,CHDI S,CHSTS,CH BLD
  37717   "RTN","CHM XF001",108 ,0)
  37718    K CHADMDX ,CHDCFAC,C HBNPD,CHDX ,CHPX,CHI, CHCCRL,CHT OB,CHREV,C HEJJ,SKIPF LG
  37719   "RTN","CHM XF001",109 ,0)
  37720    K CHCCNB, CHMFCLNM,C HCLFG,X12R JFG,CHMXJ, PC,CHMXLN, JJ,CHVNMMR S,CHSTI
  37721   "RTN","CHM XF001",110 ,0)
  37722    K VQAURLF G,VREC0,VR EC1,VREC2, VREC5,VREC 41,X1,X2,X 3,X4,X5
  37723   "RTN","CHM XF001",111 ,0)
  37724    K CHXSTYP ,CHXFLVR,C HXCLTYP,CH MFREQ
  37725   "RTN","CHM XF001",112 ,0)
  37726    Q
  37727   "RTN","CHM XF001",113 ,0)
  37728    ;
  37729   "RTN","CHM XF001",114 ,0)
  37730   PROCESS ;  PROCESS LA ST PDI SET  UP THRU S ORT, CHECK  DATA, BEN EFIT CALC
  37731   "RTN","CHM XF001",115 ,0)
  37732    D DEBUG^C HMXDR01("  ARRIVED @  PROCESS:   ",0)
  37733   "RTN","CHM XF001",116 ,0)
  37734    ;"EDI/OCR " QUEUE IS  NOW COUNT ING ONLY E DI SUBMISS IONS DISPL AYED ON CH V SCREENS
  37735   "RTN","CHM XF001",117 ,0)
  37736    ;"CHMEDIL (" QUEUE I S NOW COUN TING ONLY  OCR SUBMIS SIONS DISP LAYED ON C HV SCREENS
  37737   "RTN","CHM XF001",118 ,0)
  37738    S CHPDIRD Y=$$TYPE^C HMFPDI2(CH MFPDI)
  37739   "RTN","CHM XF001",119 ,0)
  37740    I CHPDIRD Y=91 D  G  PR2
  37741   "RTN","CHM XF001",120 ,0)
  37742    .;jsg;DEV 002841;Upd ate ASV qu eue rather  than "OCR -READY"
  37743   "RTN","CHM XF001",121 ,0)
  37744    .;S ^CHMI MG("OCR-RE ADY",CHMFP DI)="" ; T O PUT INTO  CHAMPVA E DI READY Q UEUE FOR S ELECTION B Y VE
  37745   "RTN","CHM XF001",122 ,0)
  37746    .X ^%ZOSF ("UCI") S  UCI=$P(Y," ,")
  37747   "RTN","CHM XF001",123 ,0)
  37748    .;S ^CHMI MG("VEN-ED I",CHMFPDI )=UCI ; YG , Submissi on Jrules
  37749   "RTN","CHM XF001",124 ,0)
  37750    .S ^CHMIM G("OCR-REA DY",CHMFPD I)=UCI
  37751   "RTN","CHM XF001",125 ,0)
  37752    .;
  37753   "RTN","CHM XF001",126 ,0)
  37754    .S CHMIN= "",CHMQNAM ="EDI/OCR"  K CHMOUT  D ^CHMIS04 1 ; SYSTEM  STATISTIC S
  37755   "RTN","CHM XF001",127 ,0)
  37756    I (CHPDIR DY=92)!(CH PDIRDY=93)  D  G PR2
  37757   "RTN","CHM XF001",128 ,0)
  37758    .S ^CHMIM G("SBOCR-R EADY",CHMF PDI)="" ;  TO PUT INT O SB/CWVV  EDI READY  QUEUE FOR  SELECTION  BY VE
  37759   "RTN","CHM XF001",129 ,0)
  37760    .S CHMIN= "",CHMQNAM ="EDI/OCR"  K CHMOUT  D ^CHMIS04 1 ; SYSTEM  STATISTIC S
  37761   "RTN","CHM XF001",130 ,0)
  37762    I CHPDIRD Y=94 D  G  PR2
  37763   "RTN","CHM XF001",131 ,0)
  37764    .S ^CHMIM G("OCR2-RE ADY",CHMFP DI)="" ; P UT INTO CH AMPVA OCR  READY QUEU E
  37765   "RTN","CHM XF001",132 ,0)
  37766    .;S ^CHMI MG("VEN-OC R2",CHMFPD I)="" ;jsg ;DEV002841 ;Update AS V queue ra ther than  "OCR2-READ Y"
  37767   "RTN","CHM XF001",133 ,0)
  37768    .S CHMIN= "",CHMQNAM ="CHMEDIL( " K CHMOUT  D ^CHMIS0 41  ;TLH 1 1/20/06 FO R DEV00011 5
  37769   "RTN","CHM XF001",134 ,0)
  37770    I (CHPDIR DY=95)!(CH PDIRDY=96)  D  G PR2
  37771   "RTN","CHM XF001",135 ,0)
  37772    .S ^CHMIM G("SBOCR2- READY",CHM FPDI)="" ;  PUT INTO  SB/CWVV OC R READY QU EUE
  37773   "RTN","CHM XF001",136 ,0)
  37774    .S CHMIN= "",CHMQNAM ="CHMEDIL( " K CHMOUT  D ^CHMIS0 41  ;TLH 1 1/20/06 FO R DEV00011 5
  37775   "RTN","CHM XF001",137 ,0)
  37776    I CHPDIRD Y=90 D  G  PR2  ;CPE0 05-001 Spi na Bifida  EDI Re-ope n.
  37777   "RTN","CHM XF001",138 ,0)
  37778    .I $G(CHF C8CIP) D   Q  ;CPE005 -042 Set s tatus to v oid
  37779   "RTN","CHM XF001",139 ,0)
  37780    ..S DIE=7 41000.2,DA =CHMFOPDI, DR=".06/// 11" D ^DIE  K DIE
  37781   "RTN","CHM XF001",140 ,0)
  37782    .;CPE005- 043 Determ ine if PDI  should be  in EDI-PA USE
  37783   "RTN","CHM XF001",141 ,0)
  37784    .N PAUSE  S PAUSE=$$ EDIPAUSE^C HROLIB1(CH MFOPDI,CHM FPDI,1,CHE I,.ERROR)
  37785   "RTN","CHM XF001",142 ,0)
  37786    .I PAUSE  Q
  37787   "RTN","CHM XF001",143 ,0)
  37788    .S ^CHMIM G("SBOCRR- READY",CHM FPDI)=""
  37789   "RTN","CHM XF001",144 ,0)
  37790    .S CHMIN= "",CHMQNAM ="CHMEREOP (" K CHMOU T D ^CHMIS 041
  37791   "RTN","CHM XF001",145 ,0)
  37792    I CHPDIRD Y=97 D  G  PR2  ;CPE0 05-001 CHA MPVA EDI R e-open.
  37793   "RTN","CHM XF001",146 ,0)
  37794    .I $G(CHF C8CIP) D   Q  ;CPE005 -042 Set s tatus to v oid
  37795   "RTN","CHM XF001",147 ,0)
  37796    ..S DIE=7 41000.2,DA =CHMFOPDI, DR=".06/// 11" D ^DIE  K DIE
  37797   "RTN","CHM XF001",148 ,0)
  37798    .;CPE005- 043 Determ ine if PDI  should be  in EDI-PA USE
  37799   "RTN","CHM XF001",149 ,0)
  37800    .N PAUSE  S PAUSE=$$ EDIPAUSE^C HROLIB1(CH MFOPDI,CHM FPDI,1,CHE I,.ERROR)
  37801   "RTN","CHM XF001",150 ,0)
  37802    .I PAUSE  Q
  37803   "RTN","CHM XF001",151 ,0)
  37804    .S ^CHMIM G("OCRR-RE ADY",CHMFP DI)=""
  37805   "RTN","CHM XF001",152 ,0)
  37806    .; CPE005 -023 Corre ct CHMQNAM
  37807   "RTN","CHM XF001",153 ,0)
  37808    .; S CHMI N="",CHMQN AM="CHMERE OP(" K CHM OUT D ^CHM IS041
  37809   "RTN","CHM XF001",154 ,0)
  37810    .S CHMIN= "",CHMQNAM ="EDI-REOP EN" K CHMO UT D ^CHMI S041
  37811   "RTN","CHM XF001",155 ,0)
  37812   PR2 S ^CHM IMG(CHMFPD I,"DOC")=" " ; NEEDED  FOR DOC I D OR INDIC ATION OF N O DOC
  37813   "RTN","CHM XF001",156 ,0)
  37814    S ^CHMIMG (CHMFPDI," TRACK")=CH DFN_"^"_CH BFN ; NEED ED TO TRAC K BENE
  37815   "RTN","CHM XF001",157 ,0)
  37816    S ^CHMIMG ("AV",CHDF N,CHBFN,CH MFPDI)=""   ;AEB adde d to allow  PDI to be  seen in D MD app  11 /3/2005
  37817   "RTN","CHM XF001",158 ,0)
  37818    I $G(CHMF OPDI)'=""  D  ;CPE005 -001 - Fil e the Orig inal PDI N umber.
  37819   "RTN","CHM XF001",159 ,0)
  37820    .S $P(^CH MIMG(CHMFP DI,"E-REOP EN"),"^")= CHMFOPDI,$ P(^CHMIMG( CHMFPDI,"E -REOPEN"), "^",3)=0
  37821   "RTN","CHM XF001",160 ,0)
  37822    .S $P(^CH MIMG(CHMFO PDI,"E-REO PEN"),"^", 2)=CHMFPDI ,$P(^CHMIM G(CHMFOPDI ,"E-REOPEN "),"^",3)= 0
  37823   "RTN","CHM XF001",161 ,0)
  37824    .; add Re Open xrefs : a) "A-FI RST" sets  1st Origin al for eac h given su bsequent R eOpen
  37825   "RTN","CHM XF001",162 ,0)
  37826    .; b) "A- ALL" sets  all ReOpen s xrefed t o 1st Orig inal occur rence
  37827   "RTN","CHM XF001",163 ,0)
  37828    .D PDIFIR ST^CHMFUTL E(CHMFPDI)  ; (CPE005 -001)
  37829   "RTN","CHM XF001",164 ,0)
  37830    ;D COMPLT  S CHMFPP= "CIP" D ^C HMFWK01
  37831   "RTN","CHM XF001",165 ,0)
  37832    ;D KLOCK  S CHMFPP=" SST" D ^CH MFWK01
  37833   "RTN","CHM XF001",166 ,0)
  37834    ;S $ZT="S RTERR^CHMX F001" D ^C HMFSRT
  37835   "RTN","CHM XF001",167 ,0)
  37836    ;;
  37837   "RTN","CHM XF001",168 ,0)
  37838    ;; AAF
  37839   "RTN","CHM XF001",169 ,0)
  37840    ;;
  37841   "RTN","CHM XF001",170 ,0)
  37842    ;; It see ms like ea rlier atte mpt did CO MPLT,KLOCK  and CHMFS RT to go t o sort.  N ow doing f or AAF  
  37843   "RTN","CHM XF001",171 ,0)
  37844    ;; Howeve r, CHICDAA  is appare ntly takin g care of  it, so do  not call i t anymore
  37845   "RTN","CHM XF001",172 ,0)
  37846    ;I $P(^CH MIMAGE(CHM FPDI,0),"^ ",19)=1 D  COMPLT,KLO CK S DUZ=9 944,PDI=CH MFPDI D ^C HICDAA
  37847   "RTN","CHM XF001",173 ,0)
  37848    I $P(^CHM IMAGE(CHMF PDI,0),"^" ,19)=1 S D UZ=9944,PD I=CHMFPDI  D ^CHICDAA
  37849   "RTN","CHM XF001",174 ,0)
  37850    ;;
  37851   "RTN","CHM XF001",175 ,0)
  37852   CHKSTRT ;S  CHMFPP="C ST" D ^CHM FWK01
  37853   "RTN","CHM XF001",176 ,0)
  37854    ;;Y2K- S  CHBRTYP=$$ TYPE^CHMFP DI2(CHMFPD I),BI=0,BI =$O(^CHMDI C(741002.9 3,"C",CHBR TYP,BI)) Q :('BI)!(BI ="")
  37855   "RTN","CHM XF001",177 ,0)
  37856    ;I $D(^CH MDIC(74100 2.93,BI,0) ),$P(^CHMD IC(741002. 93,BI,0)," ^",4)=1 D  ^CHMXCLM9  Q:$D(MXRJF G)  S VQAU RLFG=1 G C HKNXT
  37857   "RTN","CHM XF001",178 ,0)
  37858    ;E  D ^CH MXCP09 Q:$ D(MXRJFG)   S VQAURLF G=1
  37859   "RTN","CHM XF001",179 ,0)
  37860    ;D CLM^CH MXF010 Q:$ D(X12RJFG)   S VQAURL FG=1
  37861   "RTN","CHM XF001",180 ,0)
  37862    S:$P(^CHM XCLE(CHEI, 100),"^",2 )'="" $P(^ CHMXCLE(CH EI,100),"^ ",4)=$P(^C HMXCLE(CHE I,100),"^" ,2) ; ONE  LINE NEEDE D OUT OF C LM^CHMXF01 0
  37863   "RTN","CHM XF001",181 ,0)
  37864    ;;
  37865   "RTN","CHM XF001",182 ,0)
  37866    ;***NEED  TO COUNT T HE CLAIMS  (CHCLCT) H ERE
  37867   "RTN","CHM XF001",183 ,0)
  37868   CHKNXT ;S  $ZT="CHKER R^CHMXF001 "
  37869   "RTN","CHM XF001",184 ,0)
  37870    ;K CHMFCL MS,CHMFCL, CHMFREJ
  37871   "RTN","CHM XF001",185 ,0)
  37872    ;D SORT^C HFCDUTL,^C HFCDDRV
  37873   "RTN","CHM XF001",186 ,0)
  37874    ;I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  37875   "RTN","CHM XF001",187 ,0)
  37876    ;D NOW^%D TC S:'$D(% ) %=DT
  37877   "RTN","CHM XF001",188 ,0)
  37878    ;S $P(^CH MIMAGE(CHM FPDI,0),"^ ",5)=%
  37879   "RTN","CHM XF001",189 ,0)
  37880    ;K CHASFL G,VIEWFL,P DIFLG S CL =0
  37881   "RTN","CHM XF001",190 ,0)
  37882    ;D KILALL ^CHMXDR01
  37883   "RTN","CHM XF001",191 ,0)
  37884    K CHPDIRD Y,PDIFLG Q
  37885   "RTN","CHM XF001",192 ,0)
  37886    ;
  37887   "RTN","CHM XF001",193 ,0)
  37888   SUM ;SUMS  THE NUMBER  OF CLAIMS /DOLLAR AM NT PER TRA NSACTION B ATCH
  37889   "RTN","CHM XF001",194 ,0)
  37890    S $P(^CHM XCLA(CHAIH LD,80),"^" ,3)=CHACLC T,$P(^(80) ,"^",4)=CH ADLCT
  37891   "RTN","CHM XF001",195 ,0)
  37892    S (CHACLC T,CHADLCT) =0
  37893   "RTN","CHM XF001",196 ,0)
  37894    Q
  37895   "RTN","CHM XF001",197 ,0)
  37896    ;
  37897   "RTN","CHM XF001",198 ,0)
  37898   TOTSUM ;SU MS THE NUM BER CLAIMS /DOLLAR AM NT PER ENT IRE BATCH
  37899   "RTN","CHM XF001",199 ,0)
  37900    S (AI,CHT OTCL,CHTOT DL)=0
  37901   "RTN","CHM XF001",200 ,0)
  37902   TOTSUM1 S  AI=$O(^CHM XCLA("B",C HMXI,AI))  G:'AI TOTS UM2
  37903   "RTN","CHM XF001",201 ,0)
  37904    G:'$D(^CH MXCLA(AI,8 0)) TOTSUM 1
  37905   "RTN","CHM XF001",202 ,0)
  37906    S CHTOTCL =CHTOTCL+$ P(^CHMXCLA (AI,80),"^ ",3),CHTOT DL=CHTOTDL +$P(^CHMXC LA(AI,80), "^",4)
  37907   "RTN","CHM XF001",203 ,0)
  37908    G TOTSUM1
  37909   "RTN","CHM XF001",204 ,0)
  37910   TOTSUM2 S  $P(^CHMXCL (CHMXI,80) ,"^",3)=CH TOTCL,$P(^ CHMXCL(CHM XI,80),"^" ,4)=CHTOTD L
  37911   "RTN","CHM XF001",205 ,0)
  37912    Q
  37913   "RTN","CHM XF001",206 ,0)
  37914    ;
  37915   "RTN","CHM XF001",207 ,0)
  37916   COMPLT ; S ET STATUS  OF PDI TO  COMPLETE
  37917   "RTN","CHM XF001",208 ,0)
  37918    S U="^" Q :('$D(CHMF PDI))!(CHM FPDI="")
  37919   "RTN","CHM XF001",209 ,0)
  37920    G:$D(^CHM IMG(CHMFPD I,0)) C1
  37921   "RTN","CHM XF001",210 ,0)
  37922    L ^CHMIMG (0) S $P(^ CHMIMG(0), "^",3)=CHM FPDI,$P(^( 0),"^",4)= $P(^(0),"^ ",4)+1 L
  37923   "RTN","CHM XF001",211 ,0)
  37924    S ^CHMIMG (CHMFPDI,0 )=CHMFPDI
  37925   "RTN","CHM XF001",212 ,0)
  37926   C1 S X=^CH MIMG(CHMFP DI,0),^CHM IMG("B",CH MFPDI,CHMF PDI)=""
  37927   "RTN","CHM XF001",213 ,0)
  37928    S $P(X,"^ ",6)=4,^CH MIMG(CHMFP DI,0)=X Q
  37929   "RTN","CHM XF001",214 ,0)
  37930    ;
  37931   "RTN","CHM XF001",215 ,0)
  37932   KLOCK ; EN SURE CHMIM AGE FILE N OT LOCKED
  37933   "RTN","CHM XF001",216 ,0)
  37934    I $D(CHMF PDI) K:CHM FPDI'="" ^ CHMIMAGE(" LOCK",CHMF PDI)
  37935   "RTN","CHM XF001",217 ,0)
  37936    Q
  37937   "RTN","CHM XF001",218 ,0)
  37938    ;
  37939   "RTN","CHM XF001",219 ,0)
  37940   COUNT ; CO UNTS CLAIM S CREATED  FOR SYSTEM  STATISTIC S
  37941   "RTN","CHM XF001",220 ,0)
  37942    S CLCT=0
  37943   "RTN","CHM XF001",221 ,0)
  37944   CO1 S CLCT =$O(CHMFCL MS(CLCT))  Q:CLCT=""
  37945   "RTN","CHM XF001",222 ,0)
  37946    S CHMQNAM ="CHMPAY(" ,CHMIN=""  K CHOUT D  ^CHMIS041  G CO1
  37947   "RTN","CHM XF001",223 ,0)
  37948    ;
  37949   "RTN","CHM XF001",224 ,0)
  37950   ERROR S $Z E="X12 DRV  "_$ZE D ^ %ET,UNSET  Q
  37951   "RTN","CHM XF001",225 ,0)
  37952    ;
  37953   "RTN","CHM XF001",226 ,0)
  37954   SRTERR S $ ZE="X12 SR T "_$ZE D  ^%ET,UNSET  Q
  37955   "RTN","CHM XF001",227 ,0)
  37956    ;
  37957   "RTN","CHM XF001",228 ,0)
  37958   CHKERR S $ ZE="X12 CH K "_$ZE D  ^%ET,UNSET  Q
  37959   "RTN","CHM XF001",229 ,0)
  37960    ;
  37961   "RTN","CHM XF001",230 ,0)
  37962   UNSET S DU Z=CHDUZHLD  Q
  37963   "RTN","CHM XF001",231 ,0)
  37964    ;
  37965   "RTN","CHM XIN06")
  37966   0^99^B3363 54772
  37967   "RTN","CHM XIN06",1,0 )
  37968   CHMXIN06 ; CVA/DPT;DI SPLAY--EDI  BUFFER FI LE LOOKUP- -CLAIM I;0 6/29/00  4 :12 PM
  37969   "RTN","CHM XIN06",2,0 )
  37970    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 11,201 1;Build 9
  37971   "RTN","CHM XIN06",3,0 )
  37972    ;
  37973   "RTN","CHM XIN06",4,0 )
  37974    ; 10/14/2 011  DLB   NEW DETERM INATION FO R I/P/D RE CORD TYPES
  37975   "RTN","CHM XIN06",5,0 )
  37976    ;                PRE VIOUSLY US ED DETERMI NATION (^C HMXCLE(I,0 ,^14) WAS  NOT CONSIS TENTLY POP ULATED
  37977   "RTN","CHM XIN06",6,0 )
  37978    ;;10/25/2 011   FOR  DLB; AMBUL ANCE DATA  RETRIEVAL  REPLACED N ODE ACCESS  VALUES FR OM CHMXCLE (I,N,0)
  37979   "RTN","CHM XIN06",7,0 )
  37980    ;;               TO  CHMXCLE(I, N)
  37981   "RTN","CHM XIN06",8,0 )
  37982    ;;11/2/20 11    ADDE D PDI DISP LAY TO TIT LE LINES
  37983   "RTN","CHM XIN06",9,0 )
  37984    ;;11/4/20 11    FIXE D HC QUALI FIER DATA  EXTRACT AN D DISPLAY
  37985   "RTN","CHM XIN06",10, 0)
  37986    ;;11/4/20 11    ADDE D A RETURN  TO CONTIN UE BETWEEN  CLAIM AND  AMBULANCE  DISPLAY
  37987   "RTN","CHM XIN06",11, 0)
  37988    ;;11/4/20 11    CHAN GED THE LO OPING STRU CTURE TO C ORRECT A N ON-EXISTEN T NODE VAL UE CRASH
  37989   "RTN","CHM XIN06",12, 0)
  37990    ;;06/19/2 013   EDI  BUFFER FIL E LOOKUP F ORMATTING  CHANGES FO R ICD-10 R CS -lg
  37991   "RTN","CHM XIN06",13, 0)
  37992    ;;RALLY U S8440 - TG H - 3/15/1 9 - Repair  TOOTHDTA  tag to all ow display
  37993   "RTN","CHM XIN06",14, 0)
  37994    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  37995   "RTN","CHM XIN06",15, 0)
  37996    ; CLAIM D ATA / ERRO RS
  37997   "RTN","CHM XIN06",16, 0)
  37998    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  37999   "RTN","CHM XIN06",17, 0)
  38000    ;
  38001   "RTN","CHM XIN06",18, 0)
  38002   CLMDTA  ;
  38003   "RTN","CHM XIN06",19, 0)
  38004    N RTN,XXX
  38005   "RTN","CHM XIN06",20, 0)
  38006    S (CL0REC ,CHCLCOB,C HACCI,CHAC CST,CHCLVA N,CHCLCTRL ,CHPTQUAL, CHTOB,CHPO S,CHFREQ,C HREL1,CHRE L2,CHREL3, CHRELST,CH CLSUB,CHCL STS,CHSBCT RL,CHDELAY ,CHDELAYI, CHPRPAY,CH CLMTYP)=""
  38007   "RTN","CHM XIN06",21, 0)
  38008    I $D(^CHM XCLA(CHAI, 1)) D
  38009   "RTN","CHM XIN06",22, 0)
  38010    .S CHCLCO B=$P($G(^C HMXCLA(CHA I,1)),"^", 3)  ; MEDI CARE CROSS OVER
  38011   "RTN","CHM XIN06",23, 0)
  38012    .S CHCLCO B=$S(CHCLC OB=7416122 29:"Y",1:" N")
  38013   "RTN","CHM XIN06",24, 0)
  38014    I $D(^CHM XCLE(CHEI, 0)) D  ; P ATIENT/SER VICE NODE  (SINGULAR)
  38015   "RTN","CHM XIN06",25, 0)
  38016    .S CL0REC =^CHMXCLE( CHEI,0)  ;  START CLA IM RECORD  (E000)
  38017   "RTN","CHM XIN06",26, 0)
  38018    .S CHACCI =$P(CL0REC ,"^",7)  ;  ACCIDENT  INDICATOR
  38019   "RTN","CHM XIN06",27, 0)
  38020    .S CHACCS T=$P(CL0RE C,"^",10)   ; ACCIDEN T STATE CO DE
  38021   "RTN","CHM XIN06",28, 0)
  38022    .S CHCLVA N=$P(CL0RE C,"^",14)   ; HCCH/VA N NETWORK  TRACE NUMB ER
  38023   "RTN","CHM XIN06",29, 0)
  38024    .S CHCLCT RL=$P(CL0R EC,"^",2)   ; CLAIM/P ATIENT CON TROL NUMBE R
  38025   "RTN","CHM XIN06",30, 0)
  38026    .S CHPTQU AL=$P(CL0R EC,"^",5)   ; PLACE O F SERVICE/ TOB QUALIF IER
  38027   "RTN","CHM XIN06",31, 0)
  38028    .S:CHPTQU AL="A" CHT OB=$P(CL0R EC,"^",4)   ; PLACE O F SERVICE/ TOB
  38029   "RTN","CHM XIN06",32, 0)
  38030    .S:CHPTQU AL="B" CHP OS=$P(CL0R EC,"^",4)
  38031   "RTN","CHM XIN06",33, 0)
  38032    .S CHFREQ =$P(CL0REC ,"^",6)  ;  FREQUENCY  OF SERVIC E
  38033   "RTN","CHM XIN06",34, 0)
  38034    .S CHREL1 =$P(CL0REC ,"^",7)  ;  RELATED C AUSE #1
  38035   "RTN","CHM XIN06",35, 0)
  38036    .S CHREL2 =$P(CL0REC ,"^",8)  ;  RELATED C AUSE #2
  38037   "RTN","CHM XIN06",36, 0)
  38038    .S CHREL3 =$P(CL0REC ,"^",9)  ;  RELATED C AUSE #3
  38039   "RTN","CHM XIN06",37, 0)
  38040    .S CHRELS T=$P(CL0RE C,"^",10)   ; RELATED  CAUSE ACC IDENT STAT E
  38041   "RTN","CHM XIN06",38, 0)
  38042    .S CHCLSU B=$P(CL0RE C,"^",12)   ; CLAIM S UBMISSION  REASON COD E
  38043   "RTN","CHM XIN06",39, 0)
  38044    .S CHCLST S=$P(CL0RE C,"^",13)   ; CLAIM S TATUS CODE
  38045   "RTN","CHM XIN06",40, 0)
  38046    .S CHSBCT RL=$P(CL0R EC,"^",14)   ; SUBMIT TER CLAIM  CONTROL #
  38047   "RTN","CHM XIN06",41, 0)
  38048    .S CHDELA Y=$P(CL0RE C,"^",15)  D  ; DELAY  REASON CO DE
  38049   "RTN","CHM XIN06",42, 0)
  38050    ..Q:CHDEL AY=""
  38051   "RTN","CHM XIN06",43, 0)
  38052    ..Q:'$D(^ CHMXDIC(74 1201.53,"B ",CHDELAY) )
  38053   "RTN","CHM XIN06",44, 0)
  38054    ..S CHDEL AYI=$O(^CH MXDIC(7412 01.53,"B", CHDELAY,0) )
  38055   "RTN","CHM XIN06",45, 0)
  38056    ..Q:'CHDE LAYI
  38057   "RTN","CHM XIN06",46, 0)
  38058    ..S CHDEL AY=$E($P($ G(^CHMXDIC (741201.53 ,CHDELAYI, 0)),"^",2) ,1,80)
  38059   "RTN","CHM XIN06",47, 0)
  38060    .S CHPRPA Y=$P(CL0RE C,"^",16)  S CHPRPAY= $S(CHPRPAY ="Y":"YES" ,CHPRPAY=" N":"NO",1: "UNK") ; A SSIGNMENT  OF BENEFIT S
  38061   "RTN","CHM XIN06",48, 0)
  38062    .S CHCLMT YP=$$GETCL MTYP($P($G (^CHMXCLA( CHAI,0))," ^",13))  ;  DETERMINE  CLAIM TYP E
  38063   "RTN","CHM XIN06",49, 0)
  38064   CLM1 S (CL 1REC,CHACC DT,CHSTFDT ,CHSTTDT,C HADMDT,CHA DMHR,CHDCH R,CHDCDT)= ""
  38065   "RTN","CHM XIN06",50, 0)
  38066    I $D(^CHM XCLE(CHEI, 1)) D  ; C LAIM STATE MENT NODE  (SINGULAR)
  38067   "RTN","CHM XIN06",51, 0)
  38068    .S CL1REC =^CHMXCLE( CHEI,1)  ;  CLAIM DAT E INFO REC ORD (E005)
  38069   "RTN","CHM XIN06",52, 0)
  38070    .S XXX=$P (CL1REC,"^ ",8) D DTC VRT^CHMXIN 04
  38071   "RTN","CHM XIN06",53, 0)
  38072    .S CHACCD T=XXX  ; A CCIDENT DA TE
  38073   "RTN","CHM XIN06",54, 0)
  38074    .S XXX=$P (CL1REC,"^ ",1) D DTC VRT^CHMXIN 04 S CHSTF DT=XXX  ;  STATEMENT  FROM DATE
  38075   "RTN","CHM XIN06",55, 0)
  38076    .S XXX=$P (CL1REC,"^ ",2) D DTC VRT^CHMXIN 04 S CHSTT DT=XXX  ;  STATEMENT  TO DATE
  38077   "RTN","CHM XIN06",56, 0)
  38078    .S XXX=$P (CL1REC,"^ ",3) D DTC VRT^CHMXIN 04
  38079   "RTN","CHM XIN06",57, 0)
  38080    .S CHADMD T=XXX  ; A DMISSION D ATE
  38081   "RTN","CHM XIN06",58, 0)
  38082    .S CHADMH R=$P(CL1RE C,"^",4)   ; ADMISSIO N TIME/HOU R
  38083   "RTN","CHM XIN06",59, 0)
  38084    .S CHDCHR =$P(CL1REC ,"^",6)  ;  DISCHARGE  TIME/HOUR
  38085   "RTN","CHM XIN06",60, 0)
  38086    .S XXX=$P (CL1REC,"^ ",5) D DTC VRT^CHMXIN 04
  38087   "RTN","CHM XIN06",61, 0)
  38088    .S CHDCDT =XXX  ; DI SCHARGEDAT E
  38089   "RTN","CHM XIN06",62, 0)
  38090   CLM2 S (CL 2REC,CHTOT CHR,CHPATP D,CHBALDUE )=""  ; TO TAL CHARGE S BILLED N ODE (SINGU LAR)
  38091   "RTN","CHM XIN06",63, 0)
  38092    I $D(^CHM XCLE(CHEI, 2)) D
  38093   "RTN","CHM XIN06",64, 0)
  38094    .S CL2REC =^CHMXCLE( CHEI,2)  ;  DESTINATI ON PAYER R ECORD (E01 0)
  38095   "RTN","CHM XIN06",65, 0)
  38096    .S XXX=$P (CL2REC,"^ ",1) D AMT CVRT S CHT OTCHR=XXX   ; TOTAL C HARGES BIL LED
  38097   "RTN","CHM XIN06",66, 0)
  38098    .S XXX=$P (CL2REC,"^ ",2) D AMT CVRT S CHP ATPD=XXX   ; PATIENT  AMOUNT PAI D
  38099   "RTN","CHM XIN06",67, 0)
  38100    .S XXX=$P (CL2REC,"^ ",3) D AMT CVRT S CHB ALDUE=XXX   ; PATIENT  BALANCE D UE
  38101   "RTN","CHM XIN06",68, 0)
  38102   CLM3 S (CL 3REC,CHPTD CST,CHNHRE S,CHICNDCN ,CHPREAUT) =""  ; PAT IENT DISCH ARGE STATU S NODE (SI NGULAR)
  38103   "RTN","CHM XIN06",69, 0)
  38104    I $D(^CHM XCLE(CHEI, 3)) D
  38105   "RTN","CHM XIN06",70, 0)
  38106    .S CL3REC =^CHMXCLE( CHEI,3)  ;  MISCELLAN EOUS CLAIM  INFO (E01 5)
  38107   "RTN","CHM XIN06",71, 0)
  38108    .S CHPTDC ST=$P(CL3R EC,"^",1)   ; PATIENT  DISCHARGE  STATUS CO DE
  38109   "RTN","CHM XIN06",72, 0)
  38110    .S CHNHRE S=$P(CL3RE C,"^",2)   ; NURSING  HOME RESID ENT STATUS
  38111   "RTN","CHM XIN06",73, 0)
  38112    .S CHICND CN=$P(CL3R EC,"^",3)   ; ORIGINA L ICN/DCN  REFERENCE  NUMBER
  38113   "RTN","CHM XIN06",74, 0)
  38114    .S CHPREA UT=$P(CL3R EC,"^",4)   ; PREAUTH ORIZATION  NUMBER
  38115   "RTN","CHM XIN06",75, 0)
  38116   CLM35 S (C L35REC,CHA DTC,CHADSC )=""  ; AD MISSION TY PE NODE (S INGULAR)
  38117   "RTN","CHM XIN06",76, 0)
  38118    I $D(^CHM XCLE(CHEI, 3.5)) D
  38119   "RTN","CHM XIN06",77, 0)
  38120    .S CL35RE C=^CHMXCLE (CHEI,3.5)   ; MISCEL LANEOUS CL AIM INFO ( E008)
  38121   "RTN","CHM XIN06",78, 0)
  38122    .S CHADTC =$P(CL35RE C,"^",1)   ; ADMISSIO N TYPE COD E
  38123   "RTN","CHM XIN06",79, 0)
  38124    .S CHADSC =$P(CL35RE C,"^",2)   ; ADMISSIO N SOURCE C ODE
  38125   "RTN","CHM XIN06",80, 0)
  38126   CLM20 S (C L20REC,CHH STDT,CHHPR GCD,CHCRTB G,CHCRTEND ,CHCRTONS) =""  ; HOM E HEALTH P ROGNOSIS N ODE (SINGU LAR)
  38127   "RTN","CHM XIN06",81, 0)
  38128    I $D(^CHM XCLE(CHEI, 20)) D
  38129   "RTN","CHM XIN06",82, 0)
  38130    .S CL20RE C=^CHMXCLE (CHEI,20)   ; HOME HE ALTH CERTI FICATION R ECORD (E05 0)
  38131   "RTN","CHM XIN06",83, 0)
  38132    .S XXX=$P (CL20REC," ^",2) D DT CVRT^CHMXI N04 S CHHS TDT=XXX  ;  HH SERVIC E START DA TE
  38133   "RTN","CHM XIN06",84, 0)
  38134    .S CHHPRG CD=$P(CL20 REC,"^",1)   ; HH PRO GNOSIS COD
  38135   "RTN","CHM XIN06",85, 0)
  38136    .S CHHPRG CD=$S(CHHP RGCD=1:"PO OR",CHHPRG CD=2:"GUAR DED",CHHPR GCD=3:"FAI R",CHHPRGC D=4:"GOOD" ,CHHPRGCD= 5:"VERY GO OD",CHHPRG CD=6:"EXCE LLENT",CHH PRGCD=7:"<  6 MONS TO  LIVE",CHH PRGCD=8:"T ERMINAL",1 :"UNK")
  38137   "RTN","CHM XIN06",86, 0)
  38138    .S XXX=$P (CL20REC," ^",3) D DT CVRT^CHMXI N04 S CHCR TBG=XXX  ;  CERTIFICA TION BEGIN  DATE
  38139   "RTN","CHM XIN06",87, 0)
  38140    .S XXX=$P (CL20REC," ^",4) D DT CVRT^CHMXI N04 S CHCR TEND=XXX   ; CERTIFIC ATION END  DATE
  38141   "RTN","CHM XIN06",88, 0)
  38142    .S XXX=$P (CL20REC," ^",5) D DT CVRT^CHMXI N04 S CHCR TONS=XXX   ; EXACERBA TION ONSET  DATE
  38143   "RTN","CHM XIN06",89, 0)
  38144   CLM21 S (C L21REC,CHH DISC,CHPRE LVS,CHTREL VS,CHHVSQU L,CHHVSTS, CHHFRQUL,C HHFREQ,CHH DRQUL,CHHD URTN,CHHAR RAY)=""
  38145   "RTN","CHM XIN06",90, 0)
  38146    I $D(^CHM XCLE(CHEI, 21)) D  ;  HOME HEALT H NODE (MU LTIPLE)
  38147   "RTN","CHM XIN06",91, 0)
  38148    .S CHEJ=0
  38149   "RTN","CHM XIN06",92, 0)
  38150    .F HHIDX= 1:1 S CHEJ =$O(^CHMXC LE(CHEI,21 ,CHEJ)) Q: 'CHEJ  D
  38151   "RTN","CHM XIN06",93, 0)
  38152    ..Q:'$D(^ CHMXCLE(CH EI,21,CHEJ ,0))
  38153   "RTN","CHM XIN06",94, 0)
  38154    ..S CL21R EC=^CHMXCL E(CHEI,21, CHEJ,0)  ;  HOME HEAL TH ATTENDA NT INFO (E XXX) 
  38155   "RTN","CHM XIN06",95, 0)
  38156    ..S CHHDI SC=$P(CL21 REC,"^",1)    ; HH DI SCIPLINE
  38157   "RTN","CHM XIN06",96, 0)
  38158    ..S CHPRE LVS=$P(CL2 1REC,"^",2 )  ; HH PR IOR VISITS
  38159   "RTN","CHM XIN06",97, 0)
  38160    ..S CHTRE LVS=$P(CL2 1REC,"^",3 )  ; HH NU MBER OF CE RTIFIED VI SITS
  38161   "RTN","CHM XIN06",98, 0)
  38162    ..S CHHVS QUL=$P(CL2 1REC,"^",4 )  ; HH VI SIT QUALIF IER
  38163   "RTN","CHM XIN06",99, 0)
  38164    ..S CHHVS TS=$P(CL21 REC,"^",5)    ; HH NU MBER OF PL ANNED VISI TS
  38165   "RTN","CHM XIN06",100 ,0)
  38166    ..S CHHFR QUL=$P(CL2 1REC,"^",6 )  ; HH FE REQUENCY P ERIOD QUAL IFIER
  38167   "RTN","CHM XIN06",101 ,0)
  38168    ..S CHHFR EQ=$P(CL21 REC,"^",7)    ; HH VI SIT FREQUE NCY
  38169   "RTN","CHM XIN06",102 ,0)
  38170    ..S CHHDR QUL=$P(CL2 1REC,"^",8 )  ; HH TI ME PERIOD  QUALIFIER
  38171   "RTN","CHM XIN06",103 ,0)
  38172    ..S CHHDU RTN=$P(CL2 1REC,"^",9 )  ; HH DU RATION OF  PERIOD
  38173   "RTN","CHM XIN06",104 ,0)
  38174    ..S CHHAR RAY(HHIDX) =CHHDISC_" ^"_CHPRELV S_"^"_CHTR ELVS_"^"_C HHVSQUL_"^ "_CHHVSTS_ "^"_CHHFRQ UL_"^"_CHH FREQ_"^"_C HHDRQUL_"^ "_CHHDURTN
  38175   "RTN","CHM XIN06",105 ,0)
  38176   CLM23 S (C L23REC,CHC NDCAT,CHCN DRSP,CHCON D1,CHCOND2 ,CHCOND3,C HCOND4,CHC OND5,CCARR AY)=""
  38177   "RTN","CHM XIN06",106 ,0)
  38178    I $D(^CHM XCLE(CHEI, 23)) D  ;  CONDITION  CODE NODE  (MULTIPLE)
  38179   "RTN","CHM XIN06",107 ,0)
  38180    .S CHEJ=0
  38181   "RTN","CHM XIN06",108 ,0)
  38182    .F CCIDX= 1:1 S CHEJ =$O(^CHMXC LE(CHEI,23 ,CHEJ)) Q: 'CHEJ  D
  38183   "RTN","CHM XIN06",109 ,0)
  38184    ..Q:'$D(^ CHMXCLE(CH EI,23,CHEJ ,0))
  38185   "RTN","CHM XIN06",110 ,0)
  38186    ..S CL23R EC=^CHMXCL E(CHEI,23, CHEJ,0)  ;  CONDITION  INDICATOR S RECORD ( E055)
  38187   "RTN","CHM XIN06",111 ,0)
  38188    ..S CHCND CAT=$P(CL2 3REC,"^",1 )  ; CONDI TION CODE  CATEGORY
  38189   "RTN","CHM XIN06",112 ,0)
  38190    ..S CHCND RSP=$P(CL2 3REC,"^",2 )  ; CONDI TION INDIC ATOR (Y/N)
  38191   "RTN","CHM XIN06",113 ,0)
  38192    ..S CHCON D1=$P(CL23 REC,"^",3)   ; APPLIC ABLE CONDI TION 1
  38193   "RTN","CHM XIN06",114 ,0)
  38194    ..S CHCON D2=$P(CL23 REC,"^",4)   ; APPLIC ABLE CONDI TION 2
  38195   "RTN","CHM XIN06",115 ,0)
  38196    ..S CHCON D3=$P(CL23 REC,"^",5)   ; APPLIC ABLE CONDI TION 3
  38197   "RTN","CHM XIN06",116 ,0)
  38198    ..S CHCON D4=$P(CL23 REC,"^",6)   ; APPLIC ABLE CONDI TION 4
  38199   "RTN","CHM XIN06",117 ,0)
  38200    ..S CHCON D5=$P(CL23 REC,"^",7)   ; APPLIC ABLE CONDI TION 5
  38201   "RTN","CHM XIN06",118 ,0)
  38202    ..S CCARR AY(CCIDX)= CHCNDCAT_" ^"_CHCNDRS P_"^"_CHCO ND1_"^"_CH COND2_"^"_ CHCOND3_"^ "_CHCOND4_ "^"_CHCOND 5
  38203   "RTN","CHM XIN06",119 ,0)
  38204   CLM40  S C HDXARY=""
  38205   "RTN","CHM XIN06",120 ,0)
  38206    I $D(^CHM XCLE(CHEI, 40)) D
  38207   "RTN","CHM XIN06",121 ,0)
  38208    .S CHEJ=0   ;DIAGNOS IS CODE NO DE (MULTIP LE)
  38209   "RTN","CHM XIN06",122 ,0)
  38210    .F DXCT=1 :1 S CHEJ= $O(^CHMXCL E(CHEI,40, CHEJ)) Q:' CHEJ  D
  38211   "RTN","CHM XIN06",123 ,0)
  38212    ..Q:'$D(^ CHMXCLE(CH EI,40,CHEJ ,0))
  38213   "RTN","CHM XIN06",124 ,0)
  38214    ..I $P(^C HMXCLE(CHE I,40,CHEJ, 0),"^",1)' ="" D
  38215   "RTN","CHM XIN06",125 ,0)
  38216    ...S CHDX ARY(DXCT)= $P(^CHMXCL E(CHEI,40, CHEJ,0),"^ ",1)_"^"_$ P(^CHMXCLE (CHEI,40,C HEJ,0),"^" ,2)
  38217   "RTN","CHM XIN06",126 ,0)
  38218   CLM41 S (C HEJ,PXCT)= 0,CHPXARY= ""  ; PROC EDURE CODE  NODE (MUL TIPLE)
  38219   "RTN","CHM XIN06",127 ,0)
  38220    I $D(^CHM XCLE(CHEI, 41)) D
  38221   "RTN","CHM XIN06",128 ,0)
  38222    .F PXCNT= 1:1 S CHEJ =$O(^CHMXC LE(CHEI,41 ,CHEJ)) Q: ('CHEJ)  D
  38223   "RTN","CHM XIN06",129 ,0)
  38224    ..Q:'$D(^ CHMXCLE(CH EI,41,CHEJ ,0))
  38225   "RTN","CHM XIN06",130 ,0)
  38226    ..D:$P(^C HMXCLE(CHE I,41,CHEJ, 0),"^",1)' =""
  38227   "RTN","CHM XIN06",131 ,0)
  38228    ...S XXX= $P(^CHMXCL E(CHEI,41, CHEJ,0),"^ ",2) D DTC VRT^CHMXIN 04  ; PROC EDURE CODE  DATE
  38229   "RTN","CHM XIN06",132 ,0)
  38230    ...S CHPX ARY(PXCT)= $P(^CHMXCL E(CHEI,41, CHEJ,0),"^ ",1)_"^"_X XX  ; PROC EDURE CODE
  38231   "RTN","CHM XIN06",133 ,0)
  38232   CLM42 S (C HEJ,DXCNT) =0,CHADARY =""  ; ADM ITTING DIA GNOSIS NOD E (MULTIPL E)
  38233   "RTN","CHM XIN06",134 ,0)
  38234    I '$D(^CH MXCLE(CHEI ,42)) D
  38235   "RTN","CHM XIN06",135 ,0)
  38236    .F DXCNT= 1:1  S CHE J=$O(^CHMX CLE(CHEI,4 2,CHEJ)) Q :('CHEJ)   D
  38237   "RTN","CHM XIN06",136 ,0)
  38238    ..Q:'$D(^ CHMXCLE(CH EI,42,CHEJ ,0))
  38239   "RTN","CHM XIN06",137 ,0)
  38240    ..D:$P(^C HMXCLE(CHE I,42,CHEJ, 0),"^",1)' =""
  38241   "RTN","CHM XIN06",138 ,0)
  38242    ...S CHAD ARY(DXCNT) =$P(^CHMXC LE(CHEI,42 ,CHEJ,0)," ^",1)
  38243   "RTN","CHM XIN06",139 ,0)
  38244   CLM43 S (C HEJ,OCCT)= 0,CHOCARY= ""  ; OCCU RRENCE DAT A NODE (MU LTIPLE)
  38245   "RTN","CHM XIN06",140 ,0)
  38246    I '$D(^CH MXCLE(CHEI ,43)) D
  38247   "RTN","CHM XIN06",141 ,0)
  38248    .F OCCT=1 :1 S CHEJ= $O(^CHMXCL E(CHEI,43, CHEJ)) Q:( 'CHEJ)  D
  38249   "RTN","CHM XIN06",142 ,0)
  38250    ..Q:'$D(^ CHMXCLE(CH EI,43,CHEJ ,0))
  38251   "RTN","CHM XIN06",143 ,0)
  38252    ..D:$P(^C HMXCLE(CHE I,43,CHEJ, 0),"^",1)' =""
  38253   "RTN","CHM XIN06",144 ,0)
  38254    ...S XXX= $P(^CHMXCL E(CHEI,43, CHEJ,0),"^ ",2) D DTC VRT^CHMXIN 04 S CHOCS TDT=XXX  ;  OCCURRENC E SPAN COD E FROM DAT E
  38255   "RTN","CHM XIN06",145 ,0)
  38256    ...S XXX= $P(^CHMXCL E(CHEI,43, CHEJ,0),"^ ",3) D DTC VRT^CHMXIN 04  ; OCCU RRENCE SPA N CODE TO  DATE
  38257   "RTN","CHM XIN06",146 ,0)
  38258    ...S CHOC ARY(OCCT)= $P(^CHMXCL E(CHEI,43, CHEJ,0),"^ ",1)_"^"_C HOCSTDT_"^ "_XXX  ; O CCURRENCE  SPAN CODE
  38259   "RTN","CHM XIN06",147 ,0)
  38260   CLM44 S (C HEJ,CNDCT) =0,CHCNDAR Y=""  ; CO NDITION CO DE NODE (M ULTIPLE)
  38261   "RTN","CHM XIN06",148 ,0)
  38262    I $D(^CHM XCLE(CHEI, 44)) D
  38263   "RTN","CHM XIN06",149 ,0)
  38264    .F CNDCT= 1:1 S CHEJ =$O(^CHMXC LE(CHEI,44 ,CHEJ)) Q: 'CHEJ  D
  38265   "RTN","CHM XIN06",150 ,0)
  38266    ..Q:'$D(^ CHMXCLE(CH EI,44,CHEJ ,0))
  38267   "RTN","CHM XIN06",151 ,0)
  38268    ..D:$P(^C HMXCLE(CHE I,44,CHEJ, 0),"^")'=" "
  38269   "RTN","CHM XIN06",152 ,0)
  38270    ...S CHCN DARY(CNDCT )=$P(^CHMX CLE(CHEI,4 4,CHEJ,0), "^",1)  ;  CONDITION  CODE
  38271   "RTN","CHM XIN06",153 ,0)
  38272   CLM45 S (C HEJ,VLCT)= 0,CHVLARY= ""  ; VALU E/CODE AMO UNT NODE ( MULTIPLE)
  38273   "RTN","CHM XIN06",154 ,0)
  38274    I $D(^CHM XCLE(CHEI, 45)) D
  38275   "RTN","CHM XIN06",155 ,0)
  38276    .F VLCNT= 1:1  S CHE J=$O(^CHMX CLE(CHEI,4 5,CHEJ)) Q :'CHEJ  D
  38277   "RTN","CHM XIN06",156 ,0)
  38278    ..Q:'$D(^ CHMXCLE(CH EI,45,CHEJ ,0))
  38279   "RTN","CHM XIN06",157 ,0)
  38280    ..D:$P(^C HMXCLE(CHE I,45,CHEJ, 0),"^",1)' =""  ; VAL UE CODE /  AMOUNT
  38281   "RTN","CHM XIN06",158 ,0)
  38282    ...S XXX= $P($G(^CHM XCLE(CHEI, 45,CHEJ,0) ),"^",2) D  AMTCVRT   ; AMOUNT F OR VALUE C ODE 
  38283   "RTN","CHM XIN06",159 ,0)
  38284    ...S CHVL ARY(VLCT)= $P(^CHMXCL E(CHEI,45, CHEJ,0),"^ ",1)_"^"_X XX
  38285   "RTN","CHM XIN06",160 ,0)
  38286   CLM46 S (C HEJ,VRCT)= 0,CHVRARY= ""  ; REAS ON FOR PAT IENT VISIT  NODE (MUL TIPLE)
  38287   "RTN","CHM XIN06",161 ,0)
  38288    I $D(^CHM XCLE(CHEI, 46)) S CHE J=0  D
  38289   "RTN","CHM XIN06",162 ,0)
  38290    .F VRCT=1 :1  S CHEJ =$O(^CHMXC LE(CHEI,46 ,CHEJ)) Q: 'CHEJ  D
  38291   "RTN","CHM XIN06",163 ,0)
  38292    ..I $D(^C HMXCLE(CHE I,46,CHEJ, 0)) D
  38293   "RTN","CHM XIN06",164 ,0)
  38294    ..I $P(^C HMXCLE(CHE I,46,CHEJ, 0),"^",1)' =""  D  ;  REASON FOR  VISIT
  38295   "RTN","CHM XIN06",165 ,0)
  38296    ...S CHVR ARY(VRCT)= $P(^CHMXCL E(CHEI,46, CHEJ,0),"^ ")
  38297   "RTN","CHM XIN06",166 ,0)
  38298   CLM60 S (C L60REC,CHR PRNM,CHRPR TIN,CHRPRA D1,CHRPRAD 2,CHRPRCTY ,CHRPRST,C HRPRZP,CHR PRCTRY)=""
  38299   "RTN","CHM XIN06",167 ,0)
  38300    I $D(^CHM XCLE(CHEI, 60)) D  ;  SERVICE LO CATION NOD E (SINGULA R)
  38301   "RTN","CHM XIN06",168 ,0)
  38302    .S CL60RE C=^CHMXCLE (CHEI,60)   ; SERVICE  LOCATION  OF CARE (E 205)
  38303   "RTN","CHM XIN06",169 ,0)
  38304    .S CHRPRN M=$P(CL60R EC,"^",1)_ ","_$P(CL6 0REC,"^",2 )_" "_$P(C L60REC,"^" ,3) ;SVC L OCATION NA ME
  38305   "RTN","CHM XIN06",170 ,0)
  38306    .S CHRPRT IN=$P(CL60 REC,"^",4)     ; SERV ICE LOCATI ON TIN
  38307   "RTN","CHM XIN06",171 ,0)
  38308    .S CHRPRA D1=$P(CL60 REC,"^",5)     ; SERV ICE LOCATI ON ADDRESS  1
  38309   "RTN","CHM XIN06",172 ,0)
  38310    .S CHRPRA D2=$P(CL60 REC,"^",6)     ; SERV ICE LOCATI ON ADDRESS  2
  38311   "RTN","CHM XIN06",173 ,0)
  38312    .S CHRPRC TY=$P(CL60 REC,"^",7)     ; SERV ICE LOCATI ON CITY
  38313   "RTN","CHM XIN06",174 ,0)
  38314    .S CHRPRS T=$P(CL60R EC,"^",8)      ; SERV ICE LOCATI ON STATE
  38315   "RTN","CHM XIN06",175 ,0)
  38316    .S CHRPRZ P=$P(CL60R EC,"^",9)      ; SERV ICE LOCATI ON ZIP COD E
  38317   "RTN","CHM XIN06",176 ,0)
  38318    .S CHRPRC TRY=$P(CL6 0REC,"^",1 0)  ; SERV ICE LOCATI ON COUNTRY
  38319   "RTN","CHM XIN06",177 ,0)
  38320   CLM61 S (C L61REC,CHA PRNM,CHAPR TIN,CHAPRA D1,CHAPRAD 2,CHAPRCTY ,CHAPRST,C HAPRZP,CHA PRTXC)=""
  38321   "RTN","CHM XIN06",178 ,0)
  38322    I $D(^CHM XCLE(CHEI, 61)) D  ;  ATTENDING  PHYSICIAN  NODE (SING ULAR)
  38323   "RTN","CHM XIN06",179 ,0)
  38324    .S CL61RE C=^CHMXCLE (CHEI,61)   ; ATTENDI NG PHYSICI AN RECORD  (E206)
  38325   "RTN","CHM XIN06",180 ,0)
  38326    .S CHAPRN M=$P(CL61R EC,"^")_", "_$P(CL61R EC,"^",2)_ " "_$P(CL6 1REC,"^",3 ) ; ATTEND ING DR. NA ME
  38327   "RTN","CHM XIN06",181 ,0)
  38328    .S CHAPRT IN=$P(CL61 REC,"^",4)   ; ATTEND ING PHYSIC IAN TIN
  38329   "RTN","CHM XIN06",182 ,0)
  38330    .S CHAPRA D1=$P(CL61 REC,"^",5)   ; ADDRES S 1
  38331   "RTN","CHM XIN06",183 ,0)
  38332    .S CHAPRA D2=$P(CL61 REC,"^",6)   ; ADDRES S 2
  38333   "RTN","CHM XIN06",184 ,0)
  38334    .S CHAPRC TY=$P(CL61 REC,"^",7)   ; CITY
  38335   "RTN","CHM XIN06",185 ,0)
  38336    .S CHAPRS T=$P(CL61R EC,"^",8)    ; STATE
  38337   "RTN","CHM XIN06",186 ,0)
  38338    .S CHAPRZ P=$P(CL61R EC,"^",9)    ; ZIP CO DE
  38339   "RTN","CHM XIN06",187 ,0)
  38340    .S CHAPRT XC=$P($G(^ CHMXCLE(CH EI,61.5)), "^",1)  ;  ATTENDING  PHYSICIAN  TXONOMY CO DE
  38341   "RTN","CHM XIN06",188 ,0)
  38342   CLM62 S (C L62REC,CHO PRNM,CHOPR TIN)=""  ;  OPERATING  PHYSICIAN  NODE (SIN GULAR)
  38343   "RTN","CHM XIN06",189 ,0)
  38344    I $D(^CHM XCLE(CHEI, 62))  D
  38345   "RTN","CHM XIN06",190 ,0)
  38346    .S CL62RE C=^CHMXCLE (CHEI,62)   ; OPERATI NG PHYSICI AN RECORD
  38347   "RTN","CHM XIN06",191 ,0)
  38348    .S CHOPRN M=$P(CL62R EC,"^",1)_ ","_$P(CL6 2REC,"^",2 )_" "_$P(C L62REC,"^" ,3)  ; OPE RATING DR.  NAME
  38349   "RTN","CHM XIN06",192 ,0)
  38350    .S CHOPRT IN=$P(CL62 REC,"^",4)   ; OPERAT ING PHYSIC IAN TIN
  38351   "RTN","CHM XIN06",193 ,0)
  38352   CLM39  ; H C CODE QUA LIFIER NOD E
  38353   "RTN","CHM XIN06",194 ,0)
  38354    S (CHDXCT ,DXCT)=0
  38355   "RTN","CHM XIN06",195 ,0)
  38356    D GETQC^C HMXIN01(CH EI)  ; GAT HER NODE 3 9 RECORD V ALUES
  38357   "RTN","CHM XIN06",196 ,0)
  38358   CLMDENT S  (CHDENSDT, CHDENEDT)= ""
  38359   "RTN","CHM XIN06",197 ,0)
  38360    I CHCLMTY P="D"  D
  38361   "RTN","CHM XIN06",198 ,0)
  38362    .S CHFI=0 ,CHFI=$O(^ CHMXCLF("B ",CHEI,CHF I))
  38363   "RTN","CHM XIN06",199 ,0)
  38364    .I $D(^CH MXCLF(CHFI ,1)) D
  38365   "RTN","CHM XIN06",200 ,0)
  38366    ..S CHDEN SDT=$P($G( ^CHMXCLF(C HFI,1)),"^ ",11)
  38367   "RTN","CHM XIN06",201 ,0)
  38368    ..S CHDEN EDT=$P($G( ^CHMXCLF(C HFI,1)),"^ ",12)  ; D ENTAL SERV ICE DATE
  38369   "RTN","CHM XIN06",202 ,0)
  38370    ..I (CHDE NEDT="")!( CHDENEDT<C HDENSDT) S  CHDENEDT= CHDENSDT
  38371   "RTN","CHM XIN06",203 ,0)
  38372   CLMDSP W @ IOF D DISP TOP^CHMXIN 05  ; DISP LAY THE CL AIM/DATA E RROR SCREE N
  38373   "RTN","CHM XIN06",204 ,0)
  38374    S TYPE=$S (CHCLMTYP= "I":"INSTI TUTIONAL", CHCLMTYP=" P":"PROFES SIONAL",CH CLMTYP="D" :"DENTAL")
  38375   "RTN","CHM XIN06",205 ,0)
  38376    S TITLE="  CLAIM DAT A/ERRORS      PDI: "
  38377   "RTN","CHM XIN06",206 ,0)
  38378    W ?(80-($ L(TITLE)+$ L(TYPE))/2 ),TYPE,@CH BON,TITLE, @CHBOFF,CH REFN
  38379   "RTN","CHM XIN06",207 ,0)
  38380    I CHCLMTY P="I"  D
  38381   "RTN","CHM XIN06",208 ,0)
  38382    .W !!,"HC CH/VAN NET WORK TRACE  NUMBER:   ",CHCLVAN, !,"MEDICAR E CROSSOVE R:  ",CHCL COB  ;TRAC E:  ,COB:1
  38383   "RTN","CHM XIN06",209 ,0)
  38384    .W !,?39, "Prior Aut h/Referral :  ",CHPRE AUT
  38385   "RTN","CHM XIN06",210 ,0)
  38386    .W !,"PAT IENT CONTR OL NUMBER:  ",CHCLCTR L,?46,"ORI G PDI/CLM  #:",CHREFN   ; PCN:38 , PDI:15
  38387   "RTN","CHM XIN06",211 ,0)
  38388    .W !,"TOT AL SUBMITT ED CHARGES :  $",CHTO TCHR,?40," Stmnt From : ",CHSTFD T,?61,"Stm nt To: ",C HSTTDT  ;T OTAL CHARG ES FIELD W IDTH: 18
  38389   "RTN","CHM XIN06",212 ,0)
  38390    .W !,"TYP E OF BILL:   ",CHTOB, ?22,"FREQU ENCY:  ",C HFREQ  ; T YPE OF BIL L: 2
  38391   "RTN","CHM XIN06",213 ,0)
  38392    .W !,"Adm it Date:   ",CHADMDT, ?25,"Admit  Hr:  ",CH ADMHR,?45, "Dis Hr:   ",CHDCHR
  38393   "RTN","CHM XIN06",214 ,0)
  38394    .W !,"Adm ission Typ e:  ",CHAD TC,?21,"Ad mission So urce:  ",C HADSC,?45, "Patient S tatus:  ", CHPTDCST
  38395   "RTN","CHM XIN06",215 ,0)
  38396    .W !,"ASS IGNMENT OF  BENEFITS:   ",CHPRPA Y
  38397   "RTN","CHM XIN06",216 ,0)
  38398    .W !!,?25 ,"POA  ICD v",?55,"IC Dv" ; ICD1 0-RCS -lg
  38399   "RTN","CHM XIN06",217 ,0)
  38400    .W !,"Pri ncipal Dx:   ",$P($G( QCARR("BK" ,1)),"^",2 ),?26,$P($ G(QCARR("B K",1)),"^" ,7),?31,$S ($P($G(QCA RR("BK",1) ),"^",1)=" ABK":"",1: "*"),?36," Pt Rsn:  " ,$P($G(QCA RR("PR",1) ),"^",2),? 56,$S($P($ G(QCARR("P R",1)),"^" ,1)="APR": "",1:"*")  ; ICD10-RC S -lg
  38401   "RTN","CHM XIN06",218 ,0)
  38402    .W !,"Adm itting Dx:   ",$P($G( QCARR("BJ" ,1)),"^",2 ),?31,$S($ P($G(QCARR ("BJ",1)), "^",1)="AB J":"",1:"* "),?36,"Pt  Rsn:  ",$ P($G(QCARR ("PR",2)), "^",2),?56 ,$S($P($G( QCARR("PR" ,2)),"^",1 )="APR":"" ,1:"*") ;  ICD10-RCS  -lg
  38403   "RTN","CHM XIN06",219 ,0)
  38404    .F IDX=2: 1  Q:IDX>$ G(QCARRN(" PR"))  D
  38405   "RTN","CHM XIN06",220 ,0)
  38406    ..;W !,?3 6,"Pt Rsn:   ",$P($G( QCARR("PR" ,IDX)),"^" ,2),?56,$S ($P($G(QCA RR("PR",ID X)),"^",1) ="APR":"", 1:"*") ;10 -31-13 mov ed next li ne from DE V. is it c orrect? -l g
  38407   "RTN","CHM XIN06",221 ,0)
  38408    ..W !,?34 ,"Pt Rsn:   ",$P($G(Q CARR("PR", IDX)),"^", 2),?50,$S( $P($G(QCAR R("PR",IDX )),"^",1)= "APR":"",1 :"*")
  38409   "RTN","CHM XIN06",222 ,0)
  38410    .D IN2CON T^CHMXIN01
  38411   "RTN","CHM XIN06",223 ,0)
  38412    .W !!," P t",?5,"Dia gnosis",?1 5,"POA",?1 9,"ICDv",? 26,"Pt",?3 0,"Diagnos is",?40,"P OA",?44,"I CDv",?52," E-Codes",? 65,"POA",? 69,"ICDv"
  38413   "RTN","CHM XIN06",224 ,0)
  38414    .F IDX=1: 1:12 D
  38415   "RTN","CHM XIN06",225 ,0)
  38416    ..W !," " ,IDX_".",? 5,$P($G(QC ARR("BF",I DX)),"^",2 ),?16,$P($ G(QCARR("B F",IDX))," ^",7),?20, $S($P($G(Q CARR("BF", IDX)),"^", 1)="ABJ":" ",1:"*")
  38417   "RTN","CHM XIN06",226 ,0)
  38418    ..W ?26,I DX+12_".", ?31,$P($G( QCARR("BF" ,IDX+12)), "^",2),?42 ,$P($G(QCA RR("BF",ID X+12)),"^" ,7),?45,$S ($P($G(QCA RR("BF",ID X+12)),"^" ,1)="ABJ": "",1:"*")  ; ICD10-RC S -lg
  38419   "RTN","CHM XIN06",227 ,0)
  38420    ..W ?52,I DX_".",?55 ,$P($G(QCA RR("BN",ID X)),"^",2) ,?66,$P($G (QCARR("BN ",IDX)),"^ ",7),?70,$ S($P($G(QC ARR("BN",I DX)),"^",1 )="ABN":"" ,1:"*")
  38421   "RTN","CHM XIN06",228 ,0)
  38422    .I $Y>PAG EN D IN2CO NT^CHMXIN0 1
  38423   "RTN","CHM XIN06",229 ,0)
  38424    E  I ((CH CLMTYP="P" )!(CHCLMTY P="D"))  D   ; P/D CL AIM BUFFER  DISPLAY
  38425   "RTN","CHM XIN06",230 ,0)
  38426    .W !!,"HC CH/VAN NET WORK TRACE  NUMBER:   ",CHCLVAN, !,"MEDICAR E CROSSOVE R:  ",CHCL COB  ;TRAC E:  ,COB:1
  38427   "RTN","CHM XIN06",231 ,0)
  38428    .W !,"Pri or Auth/Re ferral:  " ,CHPREAUT, ?46,"ORIG  PDI/CLM #:  ",CHREFN
  38429   "RTN","CHM XIN06",232 ,0)
  38430    .W !,"SUB MITTER ID/ PCN:  ",CH CLCTRL
  38431   "RTN","CHM XIN06",233 ,0)
  38432    .W !,"TOT AL SUBMITT ED CHARGES :  $",CHTO TCHR,?46," ACCIDENT I NDICATOR:   ",CHACCI
  38433   "RTN","CHM XIN06",234 ,0)
  38434    .W !,"PLA CE OF SERV ICE:  ",CH POS,?25,"F REQUENCY:   ",CHFREQ, ?46,"ACCID ENT STATE  CODE:  ",C HACCST   ; Replaced V AR CHRPRST  with CHPO S BMJ 10/2 3/13 MTN01 9401/MTN01 9402
  38435   "RTN","CHM XIN06",235 ,0)
  38436    .W !,?46, "ACCIDENT  DATE:  ",C HACCDT
  38437   "RTN","CHM XIN06",236 ,0)
  38438    .W !,"ASS IGNMENT OF  BENEFITS:   ",CHPRPA Y
  38439   "RTN","CHM XIN06",237 ,0)
  38440    .I CHCLMT YP="D" S X XX=CHDENED T D DTCVRT ^CHMXIN04  W !,"DENTA L SERVICE  DATE:  ",X XX
  38441   "RTN","CHM XIN06",238 ,0)
  38442    .W:CHCLMT YP="P" !," ADMIT DATE :  ",CHADM DT,?37,"DI SCHARGE DA TE:  ",CHD CDT
  38443   "RTN","CHM XIN06",239 ,0)
  38444    .W !,"PRI NCIPAL DIA G: ",$P($G (QCARR("BK ",1)),"^", 2),?23," I CDv: ",$S( $P($G(QCAR R("BK",1)) ,"^",1)="A PR":"",1:" *")
  38445   "RTN","CHM XIN06",240 ,0)
  38446    .W !!,"OT HER DIAG", ?21,"ICDv" ,?46,"ICDv ",?74,"ICD v"
  38447   "RTN","CHM XIN06",241 ,0)
  38448    .F IDX=1: 1:4 D
  38449   "RTN","CHM XIN06",242 ,0)
  38450    ..W !,IDX ,".  ",$P( $G(QCARR(" BF",IDX)), "^",2),?23 ,$S($P($G( QCARR("BF" ,IDX)),"^" ,1)="APR": "",1:"*"), ?27,IDX+4, ".  ",$P($ G(QCARR("B F",IDX+4)) ,"^",2),?4 8,$S($P($G (QCARR("BF ",IDX+4)), "^",1)="AP R":"",1:"* "),?53,IDX +8,".",?58 ,$P($G(QCA RR("BF",ID X+8)),"^", 2),?75,$S( $P($G(QCAR R("BF",IDX +8)),"^",1 )="APR":"" ,1:"*")
  38451   "RTN","CHM XIN06",243 ,0)
  38452    .D IN1CON T^CHMXIN01
  38453   "RTN","CHM XIN06",244 ,0)
  38454    .W !  ; C REATE AN E XTRA LINE  SPACE
  38455   "RTN","CHM XIN06",245 ,0)
  38456    .F IDX=1: 1:4 D
  38457   "RTN","CHM XIN06",246 ,0)
  38458    ..W !,"CO NDITION CO DE:  ",$P( $G(QCARR(" BG",IDX)), "^",2)
  38459   "RTN","CHM XIN06",247 ,0)
  38460    ..W ?29," CONDITION  CODE:  ",$ P($G(QCARR ("BG",IDX+ 4)),"^",2)
  38461   "RTN","CHM XIN06",248 ,0)
  38462    ..W ?58," CONDITION  CODE:  ",$ P($G(QCARR ("BG",IDX+ 8)),"^",2)
  38463   "RTN","CHM XIN06",249 ,0)
  38464    .D IN1CON T^CHMXIN01
  38465   "RTN","CHM XIN06",250 ,0)
  38466    .D:CHCLMT YP="D" TOO THDTA
  38467   "RTN","CHM XIN06",251 ,0)
  38468    .W !,"PAT IENT AMOUN T PAID:  " ,CHPATPD
  38469   "RTN","CHM XIN06",252 ,0)
  38470    .D:CHCLMT YP="P" CLM AMB  ; AMB ULANCE DAT A DISPLAY
  38471   "RTN","CHM XIN06",253 ,0)
  38472    .I $Y>PAG EN D IN2CO NT^CHMXIN0 1
  38473   "RTN","CHM XIN06",254 ,0)
  38474    .D CLMATT ACH  ; ATT ACHMENTS D ATA DISPLA Y
  38475   "RTN","CHM XIN06",255 ,0)
  38476    D CLMERRS   ; CLAIM  ERROR (FRO NT END EDI TS)
  38477   "RTN","CHM XIN06",256 ,0)
  38478    Q 
  38479   "RTN","CHM XIN06",257 ,0)
  38480    ;Q:((IDX> $G(QCARRN( "BF")))&(I DX>$G(QCAR RN("BN"))) )
  38481   "RTN","CHM XIN06",258 ,0)
  38482    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  38483   "RTN","CHM XIN06",259 ,0)
  38484    ; FORMAT  THE $$$.cc  VALUES
  38485   "RTN","CHM XIN06",260 ,0)
  38486    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  38487   "RTN","CHM XIN06",261 ,0)
  38488   AMTCVRT  ;
  38489   "RTN","CHM XIN06",262 ,0)
  38490    S L=$L($P (XXX,".",2 ))
  38491   "RTN","CHM XIN06",263 ,0)
  38492    Q:L=2
  38493   "RTN","CHM XIN06",264 ,0)
  38494    I L>2 S X XX=$FN(XXX ,"-",2) Q
  38495   "RTN","CHM XIN06",265 ,0)
  38496    I L=1 S X XX=XXX_"0"  Q
  38497   "RTN","CHM XIN06",266 ,0)
  38498    I L=0 S X XX=XXX_".0 0" Q
  38499   "RTN","CHM XIN06",267 ,0)
  38500    Q
  38501   "RTN","CHM XIN06",268 ,0)
  38502    ;
  38503   "RTN","CHM XIN06",269 ,0)
  38504    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  38505   "RTN","CHM XIN06",270 ,0)
  38506    ; TOOTH D ATA NODE
  38507   "RTN","CHM XIN06",271 ,0)
  38508    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  38509   "RTN","CHM XIN06",272 ,0)
  38510   TOOTHDTA   ;
  38511   "RTN","CHM XIN06",273 ,0)
  38512    K ORTH11A RR
  38513   "RTN","CHM XIN06",274 ,0)
  38514    N ORTHTN, ORTHSC,CHE J,ORTH11RE C,IDX
  38515   "RTN","CHM XIN06",275 ,0)
  38516    S (ORTHTN ,ORTHSC,CH EJ,ORTH11R EC,IDX)=""
  38517   "RTN","CHM XIN06",276 ,0)
  38518    W @IOF D  DISPTOP^CH MXIN05  ;  DISPLAY TH E CLAIM/DA TA ERROR S CREEN
  38519   "RTN","CHM XIN06",277 ,0)
  38520    S TITLE=" DENTAL DAT A/ERRORS      PDI: "
  38521   "RTN","CHM XIN06",278 ,0)
  38522    W ?(80-$L (TITLE)/2) ,@CHBON,TI TLE,@CHBOF F,CHREFN
  38523   "RTN","CHM XIN06",279 ,0)
  38524    W !,"TOOT H NO/TOOTH  STATUS:"
  38525   "RTN","CHM XIN06",280 ,0)
  38526    S CHEJ=0
  38527   "RTN","CHM XIN06",281 ,0)
  38528    ;RALLY US 8440 - TGH  - 3/15/19  Check if  Orthodonti c level ex ists, if n ot quit
  38529   "RTN","CHM XIN06",282 ,0)
  38530    ;I $D(^CH MXCLE(CHEI ,11,CHEJ))   D  ; BUI LD THE TOO TH ARRAY F ROM ORTH N ODE
  38531   "RTN","CHM XIN06",283 ,0)
  38532    I '$D(^CH MXCLE(CHEI ,11)) Q
  38533   "RTN","CHM XIN06",284 ,0)
  38534    ;RALLY US 8440 - TGH  - 3/15/19  Reset to  proper var iable CHEJ  vs CHFJ a nd provide  for loopi ng thru Or thodontic  level
  38535   "RTN","CHM XIN06",285 ,0)
  38536    ;F IDX=1: 1  S ORTH1 1REC=$O(^C HMXCLE(CHE I,11,CHFJ, 0)) Q:'ORT H11REC  D
  38537   "RTN","CHM XIN06",286 ,0)
  38538    F IDX=1:1   S CHEJ=$ O(^CHMXCLE (CHEI,11,C HEJ)) Q:'+ CHEJ  D
  38539   "RTN","CHM XIN06",287 ,0)
  38540    .S ORTH11 REC=^CHMXC LE(CHEI,11 ,CHEJ,0)
  38541   "RTN","CHM XIN06",288 ,0)
  38542    .S ORTHTN =$P(ORTH11 REC,"^",1)   ; TOOTH  NUMBER
  38543   "RTN","CHM XIN06",289 ,0)
  38544    .S ORTHSC =$P(ORTH11 REC,"^",2)   ; TOOTH  STATUS COD E
  38545   "RTN","CHM XIN06",290 ,0)
  38546    .S ORTH11 ARR(IDX)=O RTHTN_"^"_ ORTHSC
  38547   "RTN","CHM XIN06",291 ,0)
  38548   ORTHDSP  ;
  38549   "RTN","CHM XIN06",292 ,0)
  38550    S IDX=0
  38551   "RTN","CHM XIN06",293 ,0)
  38552    F  S IDX= $O(ORTH11A RR(IDX)) Q :IDX=""  D   ; OUTPUT  ALL VALUE S IN THE A RRAY
  38553   "RTN","CHM XIN06",294 ,0)
  38554    .W:$D(ORT H11ARR(IDX )) ?4,$P(O RTH11ARR(I DX),"^",1) ,"/",$P(OR TH11ARR(ID X),"^",2)
  38555   "RTN","CHM XIN06",295 ,0)
  38556    .W:$D(ORT H11ARR(IDX +4)) ?28,$ P(ORTH11AR R(IDX+4)," ^",1),"/", $P(ORTH11A RR(IDX+4), "^",2)
  38557   "RTN","CHM XIN06",296 ,0)
  38558    .W:$D(ORT H11ARR(IDX +12)) ?40, $P(ORTH11A RR(IDX+8), "^",1),"/" ,$P(ORTH11 ARR(IDX+8) ,"^",2)
  38559   "RTN","CHM XIN06",297 ,0)
  38560    .W:$D(ORT H11ARR(IDX +16)) ?51, $P(ORTH11A RR(IDX+12) ,"^",1),"/ ",$P(ORTH1 1ARR(IDX+1 2),"^",2)
  38561   "RTN","CHM XIN06",298 ,0)
  38562    .W:$D(ORT H11ARR(IDX +20)) ?62, $P(ORTH11A RR(IDX+16) ,"^",1),"/ ",$P(ORTH1 1ARR(IDX+1 6),"^",2)
  38563   "RTN","CHM XIN06",299 ,0)
  38564    .W:$D(ORT H11ARR(IDX +24)) ?73, $P(ORTH11A RR(IDX+20) ,"^",1),"/ ",$P(ORTH1 1ARR(IDX+2 0),"^",2)
  38565   "RTN","CHM XIN06",300 ,0)
  38566    .I $Y>PAG EN D IN1CO NT^CHMXIN0 1
  38567   "RTN","CHM XIN06",301 ,0)
  38568    Q
  38569   "RTN","CHM XIN06",302 ,0)
  38570    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  38571   "RTN","CHM XIN06",303 ,0)
  38572    ; CLAIM E RROR REPOR T INFORMAT ION
  38573   "RTN","CHM XIN06",304 ,0)
  38574    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  38575   "RTN","CHM XIN06",305 ,0)
  38576   CLMERRS  ;
  38577   "RTN","CHM XIN06",306 ,0)
  38578    N CHERCT, CHEJ,XXX
  38579   "RTN","CHM XIN06",307 ,0)
  38580    W !!,@CHB ON,"RETURN ED ERRORS  FOR PDI: " ,@CHBOFF,C HREFN
  38581   "RTN","CHM XIN06",308 ,0)
  38582    I '$D(^CH MXCLE(CHEI ,101)) W "    NONE"   ;D  ; NO E RRORS RECO RDED; QUIT
  38583   "RTN","CHM XIN06",309 ,0)
  38584    S (CHEJ,C HERCT)=0 K  CLERARY
  38585   "RTN","CHM XIN06",310 ,0)
  38586   CLMERL1 S  CHEJ=0  ;  GATHER CLA IM ERROR D ATA
  38587   "RTN","CHM XIN06",311 ,0)
  38588    F  S CHEJ =$O(^CHMXC LE(CHEI,10 1,CHEJ)) Q :'CHEJ  D
  38589   "RTN","CHM XIN06",312 ,0)
  38590    .Q:'$D(^C HMXCLE(CHE I,101,CHEJ ,0))
  38591   "RTN","CHM XIN06",313 ,0)
  38592    .S XXX=$P (^CHMXCLE( CHEI,101,C HEJ,0),"^" ,1)  ; CLA IM REJECT  REASON
  38593   "RTN","CHM XIN06",314 ,0)
  38594    .Q:'$D(^C HMXDIC(741 201.32,XXX ,0))  ; RE JECT REASO N NOT IN D ICTIONARY  ???
  38595   "RTN","CHM XIN06",315 ,0)
  38596    .S CHERCT =CHERCT+1
  38597   "RTN","CHM XIN06",316 ,0)
  38598    .S CHERCT HD=CHERCT
  38599   "RTN","CHM XIN06",317 ,0)
  38600    .S CLERAR Y(CHERCT)= $P(^CHMXDI C(741201.3 2,XXX,0)," ^",1)_"^"_ $P(^CHMXDI C(741201.3 2,XXX,0)," ^",2)_"^"_ XXX
  38601   "RTN","CHM XIN06",318 ,0)
  38602   CLMERDSP   ;Displays  Claim Leve l ERROR In formation
  38603   "RTN","CHM XIN06",319 ,0)
  38604    I $D(CLER ARY) D
  38605   "RTN","CHM XIN06",320 ,0)
  38606    .F IDX=1: 1 Q:IDX>CH ERCT  W !, IDX,")  ", CLERARY(ID X)
  38607   "RTN","CHM XIN06",321 ,0)
  38608   CLMDSPRTN   ;
  38609   "RTN","CHM XIN06",322 ,0)
  38610    I $D(CLER ARY)  D
  38611   "RTN","CHM XIN06",323 ,0)
  38612    .W !!,"Pr ess <RETUR N> to Cont inue, '^'  to BACKUP,  or '^^' t o EXIT,",! ,"or Error  Number fo r HELP on  that error :  " D SBR S^CHMXIN01
  38613   "RTN","CHM XIN06",324 ,0)
  38614    .I '$D(DF OUT)  D  ;  NOT "^^"
  38615   "RTN","CHM XIN06",325 ,0)
  38616    ..I $D(DQ OUT) W !," Enter the  NUMBER of  the Error  as display ed for HEL P on that  Error or", !,"Press < RETURN> to  Continue  Display."  G CLMDSPRT N
  38617   "RTN","CHM XIN06",326 ,0)
  38618    ..I Y'=""   D
  38619   "RTN","CHM XIN06",327 ,0)
  38620    ...I (Y<1 )!(Y>CHERC THD) W *7, *7,!?5,"MU ST Enter S equential  Number of  Error as d isplayed,  from 1 to  ",CHERCTHD   G CLMDSP RTN
  38621   "RTN","CHM XIN06",328 ,0)
  38622    ...S:$D(Y ) CHERLK=$ P(CLERARY( Y),"^",3)
  38623   "RTN","CHM XIN06",329 ,0)
  38624    ...D HLPD SP^CHMXIN1 0 G CLMERD SP
  38625   "RTN","CHM XIN06",330 ,0)
  38626    E  W !,"P ress <RETU RN> to Con tinue, '^'  to BACKUP , or '^^'  to EXIT "  D SBRS^CHM XIN01
  38627   "RTN","CHM XIN06",331 ,0)
  38628    Q 
  38629   "RTN","CHM XIN06",332 ,0)
  38630    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  38631   "RTN","CHM XIN06",333 ,0)
  38632    ; AMBULAN CE INFORMA TION  (E02 5/E026)
  38633   "RTN","CHM XIN06",334 ,0)
  38634    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  38635   "RTN","CHM XIN06",335 ,0)
  38636   AMBHDR  ;
  38637   "RTN","CHM XIN06",336 ,0)
  38638    W @IOF D  DISPTOP^CH MXIN05  ;  DISPLAY TH E CLAIM/DA TA ERROR S CREEN
  38639   "RTN","CHM XIN06",337 ,0)
  38640    S TITLE=" AMBULANCE  DATA/ERROR S     PDI:  "
  38641   "RTN","CHM XIN06",338 ,0)
  38642    W ?(80-$L (TITLE)/2) ,@CHBON,TI TLE,@CHBOF F,CHREFN
  38643   "RTN","CHM XIN06",339 ,0)
  38644    Q
  38645   "RTN","CHM XIN06",340 ,0)
  38646   CLMAMB  ;
  38647   "RTN","CHM XIN06",341 ,0)
  38648    S (AMBTRN SP,AMBTXRS N)=""
  38649   "RTN","CHM XIN06",342 ,0)
  38650    S (AMBAD1 ,AMBAD2,AM BCTY,AMBST ,AMBZP,AMB CNTRY)=""
  38651   "RTN","CHM XIN06",343 ,0)
  38652    S (AMBDNA ME,AMBDAD1 ,AMBDAD2,A MBDCTY,AMB DST,AMBDZP ,AMBDCNTRY )=""
  38653   "RTN","CHM XIN06",344 ,0)
  38654    S (AMBCCI ,AMBCC,AMB DISTC,AMBD IST)=""
  38655   "RTN","CHM XIN06",345 ,0)
  38656    D AMBHDR
  38657   "RTN","CHM XIN06",346 ,0)
  38658    I '$D(^CH MXCLE(CHEI ,4)) W " N /A" Q
  38659   "RTN","CHM XIN06",347 ,0)
  38660    S CL4REC= $G(^CHMXCL E(CHEI,4))   ; AMBULA NCE CERTIF ICATAION R ECORD
  38661   "RTN","CHM XIN06",348 ,0)
  38662    S AMBTRNS P=$P(CL4RE C,"^",1)   ; AMBULANC E TRANSPOR T CODE
  38663   "RTN","CHM XIN06",349 ,0)
  38664    S AMBTXRS N=$P(CL4RE C,"^",2)   ; TRANSPOR T REASON C ODE
  38665   "RTN","CHM XIN06",350 ,0)
  38666    S AMBDIST C=$P(CL4RE C,"^",3)   ; TRANSPOR T DISTANCE  CODE 
  38667   "RTN","CHM XIN06",351 ,0)
  38668    S AMBDIST =$P(CL4REC ,"^",4)  ;  TRANSPORT  DISTANCE
  38669   "RTN","CHM XIN06",352 ,0)
  38670   AMBPICK  ;
  38671   "RTN","CHM XIN06",353 ,0)
  38672    I $D(^CHM XCLE(CHEI, 14)) D
  38673   "RTN","CHM XIN06",354 ,0)
  38674    .S CL14RE C=$G(^CHMX CLE(CHEI,1 4))
  38675   "RTN","CHM XIN06",355 ,0)
  38676    .S AMBAD1 =$P(CL14RE C,"^",3)   ; AMBULANC E PICKUP A DDRESS LIN E 1
  38677   "RTN","CHM XIN06",356 ,0)
  38678    .S AMBAD2 =$P(CL14RE C,"^",4)   ; AMBULANC E PICKUP A DDRESS LIN E 2
  38679   "RTN","CHM XIN06",357 ,0)
  38680    .S AMBCTY =$P(CL14RE C,"^",5)   ; AMBULANC E PICKUP C ITY
  38681   "RTN","CHM XIN06",358 ,0)
  38682    .S AMBST= $P(CL14REC ,"^",6)  ;  AMBULANCE  PICKUP ST ATE
  38683   "RTN","CHM XIN06",359 ,0)
  38684    .S AMBZP= $P(CL14REC ,"^",7)  ;  AMBULANCE  PICKUP ZI P CODE
  38685   "RTN","CHM XIN06",360 ,0)
  38686    .S AMBCNT RY=$P(CL14 REC,"^",8)   ; AMBULA NCE PICKUP  COUNTRY C ODE
  38687   "RTN","CHM XIN06",361 ,0)
  38688   AMBDROP  ;
  38689   "RTN","CHM XIN06",362 ,0)
  38690    I $D(^CHM XCLE(CHEI, 15)) D
  38691   "RTN","CHM XIN06",363 ,0)
  38692    .S CL15RE C=$G(^CHMX CLE(CHEI,1 5))
  38693   "RTN","CHM XIN06",364 ,0)
  38694    .S AMBDNA ME=$P(CL15 REC,"^",3)   ; AMBULA NCE DROP E NTITY NAME
  38695   "RTN","CHM XIN06",365 ,0)
  38696    .S AMBDAD 1=$P(CL15R EC,"^",4)   ; AMBULAN CE DROP AD DRESS LINE  1
  38697   "RTN","CHM XIN06",366 ,0)
  38698    .S AMBDAD 2=$P(CL15R EC,"^",5)   ; AMBULAN CE DROP AD DRESS LINE  2
  38699   "RTN","CHM XIN06",367 ,0)
  38700    .S AMBDCT Y=$P(CL15R EC,"^",6)   ; AMBULAN CE DROP CI TY
  38701   "RTN","CHM XIN06",368 ,0)
  38702    .S AMBDST =$P(CL15RE C,"^",7)   ; AMBULANC E DROP STA TE
  38703   "RTN","CHM XIN06",369 ,0)
  38704    .S AMBDZP =$P(CL15RE C,"^",8)   ; AMBULANC E DROP ZIP  CODE
  38705   "RTN","CHM XIN06",370 ,0)
  38706    .S AMBDCN TRY=$P(CL1 5REC,"^",9 )  ; AMBUL ANCE DROP  COUNTRY CO DE
  38707   "RTN","CHM XIN06",371 ,0)
  38708   AMBCERT  ;
  38709   "RTN","CHM XIN06",372 ,0)
  38710    S CL23REC =$G(^CHMXC LE(CHEI,23 ,1,0))
  38711   "RTN","CHM XIN06",373 ,0)
  38712    S AMBCCI= $P(CL23REC ,"^",2)
  38713   "RTN","CHM XIN06",374 ,0)
  38714    S AMBCC=$ P(CL23REC, "^",3,7)
  38715   "RTN","CHM XIN06",375 ,0)
  38716   AMBDISP  ;
  38717   "RTN","CHM XIN06",376 ,0)
  38718    W !!,"AMB ULANCE TRA NSPORT COD E:  ",AMBT RNSP,?32," REASON COD E:  ",AMBT XRSN  ; AM B CODES
  38719   "RTN","CHM XIN06",377 ,0)
  38720    W !,"PICK UP LOCATIO N:"
  38721   "RTN","CHM XIN06",378 ,0)
  38722    W !,"ADDR ESS LN 1:   ",AMBAD1   ; PICKUP  ADDRESS LI NE 1 FIELD  WIDTH= 30
  38723   "RTN","CHM XIN06",379 ,0)
  38724    W !,"ADDR ESS LN 2:   ",AMBAD2   ; PICKUP  ADDRESS LI NE 2 FIELD  WIDTH= 30
  38725   "RTN","CHM XIN06",380 ,0)
  38726    W !,"CITY :  ",AMBCT Y,?45,"STA TE/PROV:   ",AMBST  ;  CITY:20,  STATE:2,
  38727   "RTN","CHM XIN06",381 ,0)
  38728    W !,?28," PICKUP POS TAL CODE:   ",AMBZP,? 61,"COUNTR Y CODE:  " ,AMBCNTRY   ;ZIP:15,  COUNTRY CO DE:3
  38729   "RTN","CHM XIN06",382 ,0)
  38730    W !!,"AMB ULANCE DRO P OFF:"
  38731   "RTN","CHM XIN06",383 ,0)
  38732    W !,"LAST /ORG NAME: ",AMBDNAME
  38733   "RTN","CHM XIN06",384 ,0)
  38734    W !,"ADDR ESS LN 1:   ",AMBDAD1   ; DROP O FF ADDRESS  LINE 1 FI ELD WIDTH=  30
  38735   "RTN","CHM XIN06",385 ,0)
  38736    W !,"ADDR ESS LN 2:   ",AMBDAD2   ; DROP O FF ADDRESS  LINE 2 FI ELD WIDTH=  30
  38737   "RTN","CHM XIN06",386 ,0)
  38738    W !,"CITY :  ",AMBDC TY,?45,"ST ATE/PROV:   ",AMBDST   ; CITY:20 , STATE:2,
  38739   "RTN","CHM XIN06",387 ,0)
  38740    W !,?28," DROP OFF P OSTAL CODE :  ",AMBDZ P,?61,"COU NTRY CODE:   ",AMBDCN TRY  ;ZIP: 15, COUNTR Y CODE:3
  38741   "RTN","CHM XIN06",388 ,0)
  38742    W:CHCLMTY P="P" !!," AMBULANCE  CERT CONDI TION INDIC ATOR:  ",A MBCCI  ; A MBULANCE C ERT CONDIT ION INDICA TOR
  38743   "RTN","CHM XIN06",389 ,0)
  38744    W:CHCLMTY P="P" !,"C ONDITION C ODE:  ",AM BCC  ; AMB ULANCE CON DITION COD E (PROFESS IONAL)
  38745   "RTN","CHM XIN06",390 ,0)
  38746    Q
  38747   "RTN","CHM XIN06",391 ,0)
  38748    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  38749   "RTN","CHM XIN06",392 ,0)
  38750    ; CLAIM A TTACHMENT  PAPERWORK  INFORMATIO N
  38751   "RTN","CHM XIN06",393 ,0)
  38752    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  38753   "RTN","CHM XIN06",394 ,0)
  38754   CLMATTACH   ;
  38755   "RTN","CHM XIN06",395 ,0)
  38756    N CHATTYP E,CHATTYPI ,CHATRNCD, CHATRNI,CH ATCTRL,CL6 REC,CHEJ
  38757   "RTN","CHM XIN06",396 ,0)
  38758    S (CHATTY PE,CHATTYP I,CHATRNCD ,CHATRNI,C HATCTRL,CL 6REC,CHEJ) =""
  38759   "RTN","CHM XIN06",397 ,0)
  38760    W !,"CLAI M ATTACHME NTS"
  38761   "RTN","CHM XIN06",398 ,0)
  38762    I $D(^CHM XCLE(CHEI, 6))  D
  38763   "RTN","CHM XIN06",399 ,0)
  38764    .S CHEJ=0
  38765   "RTN","CHM XIN06",400 ,0)
  38766    .F  S CHE J=$O(^CHMX CLE(CHEI,6 ,CHEJ)) Q: 'CHEJ  D
  38767   "RTN","CHM XIN06",401 ,0)
  38768    ..I $D(^C HMXCLE(CHE I,6,CHEJ,0 )) D
  38769   "RTN","CHM XIN06",402 ,0)
  38770    ...S CL6R EC=^CHMXCL E(CHEI,6,C HEJ,0)  ;  PAPERWORK  ATTACHMENT  RECORD (E 009)
  38771   "RTN","CHM XIN06",403 ,0)
  38772    ...S CHAT TYP=$P(CL6 REC,"^",1)   ; ATTACH MENT REPOR T TYPE COD E
  38773   "RTN","CHM XIN06",404 ,0)
  38774    ...S CHAT TYPI=$O(^C HMXDIC(741 201.7,"B", CHATTYP,0) )
  38775   "RTN","CHM XIN06",405 ,0)
  38776    ...S:$D(^ CHMXDIC(74 1201.7,CHA TTYPI,0))  CHATTYP=$E ($P(^CHMXD IC(741201. 7,CHATTYPI ,0),"^",2) ,1,80)
  38777   "RTN","CHM XIN06",406 ,0)
  38778    ...S CHAT RNCD=$P(CL 6REC,"^",2 )  ; ATTAC HMENT REPO RT TRANSMI SSION FORM AT
  38779   "RTN","CHM XIN06",407 ,0)
  38780    ...Q:CHAT RNCD=""
  38781   "RTN","CHM XIN06",408 ,0)
  38782    ...Q:'$D( ^CHMXDIC(7 41201,71," B",CHATRNC D))
  38783   "RTN","CHM XIN06",409 ,0)
  38784    ...S CHAT RNI=$O(^CH MXDIC(7412 01.71,"B", CHATRNCD,0 )) Q:'CHAT RNI
  38785   "RTN","CHM XIN06",410 ,0)
  38786    ...S:$D(^ CHMXDIC(74 1201.71,CH ATRNI,0))  CHATRNCD=$ E($P(^(0), "^",2),1,8 0)
  38787   "RTN","CHM XIN06",411 ,0)
  38788    ...S CHAT CTRL=$P(CL 6REC,"^",3 )
  38789   "RTN","CHM XIN06",412 ,0)
  38790    ...W !!," CLAIM SUPP LEMENTAL I NFO:  TYPE  OF ATTACH MENT:  ",C HATTYP,?52 ,"TRANSMIS SION FORMA T:  ",CHAT RNCD
  38791   "RTN","CHM XIN06",413 ,0)
  38792    ...W !,"A TTACHMENT  CONTROL NU MBER:  ",C HATCTRL
  38793   "RTN","CHM XIN06",414 ,0)
  38794    ...I $Y>P AGEN D IN1 CONT^CHMXI N01
  38795   "RTN","CHM XIN06",415 ,0)
  38796    Q
  38797   "RTN","CHM XIN06",416 ,0)
  38798   GETCLMTYP( CHCLMTYP)   ;RETURN T HE CLAIM T YPE BASED  ON THE ^CH MXCLA(I,0) ,"^",13) F IELD
  38799   "RTN","CHM XIN06",417 ,0)
  38800    N RET S R ET=""
  38801   "RTN","CHM XIN06",418 ,0)
  38802    S RET=$S( ((CHCLMTYP ["98")!(CH CLMTYP["22 2")):"P",( (CHCLMTYP[ "96")!(CHC LMTYP["223 ")):"I",(( CHCLMTYP[" 97")!(CHCL MTYP["224" )):"D")
  38803   "RTN","CHM XIN06",419 ,0)
  38804    Q RET
  38805   "RTN","CHM XMPD2")
  38806   0^92^B4066 483
  38807   "RTN","CHM XMPD2",1,0 )
  38808   CHMXMPD2 ; CVA/DTP;SE T UP PDI F OR OCR CLA IMS (HC CL AIM-INST/P ROF);08/27 /02  9:26  AM
  38809   "RTN","CHM XMPD2",2,0 )
  38810    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  38811   "RTN","CHM XMPD2",3,0 )
  38812    ;CALLED B Y CHMXMDRV  (RX) AND  CHMXDR01 ( X12)
  38813   "RTN","CHM XMPD2",4,0 )
  38814    ;BUILDS N EW PDI IN  STANDARD F ASHION EMP LOYING SCA NNER NUMBE R '99'
  38815   "RTN","CHM XMPD2",5,0 )
  38816    ;BEGINS T O BUILD IM AGE FILES
  38817   "RTN","CHM XMPD2",6,0 )
  38818   ZSET ;S:'$ D(DUZ) DUZ =1,DUZ(0)= "" I '$D(D T) S %DT=" ",X="T" D  ^%DT S DT= Y
  38819   "RTN","CHM XMPD2",7,0 )
  38820    ;S:'$D(IO ZFO) IOZFO ="^^" S:'$ D(IOZBK) I OZBK="^" S :'$D(DTIME ) DTIME=60
  38821   "RTN","CHM XMPD2",8,0 )
  38822    ;I '$D(IO Z) S %ZIS= "N",IOP="H OME" D HOM E^%ZIS S I OZ=IO,IOZL =IOSL,IOZW =IOM,IOZF= IOF,IOZT=I OST,IOZN=I ON,IOZS=IO S
  38823   "RTN","CHM XMPD2",9,0 )
  38824   ZNAM ;
  38825   "RTN","CHM XMPD2",10, 0)
  38826    S $ZT="ER ROR"
  38827   "RTN","CHM XMPD2",11, 0)
  38828    S PDIFLG= "",CHMFDTN M=0 ; K CH MFPDI S PD IFLG="",CH MFDTNM=0
  38829   "RTN","CHM XMPD2",12, 0)
  38830   A1 D NOW^% DTC S:'$D( X) X=DT
  38831   "RTN","CHM XMPD2",13, 0)
  38832    ;S PD=X D
  38833   "RTN","CHM XMPD2",14, 0)
  38834    .;S X=$E( PD,1,3)_"0 000" D H^% DTC S CHJU L=($P($H," ,",1)-%H)+ 1
  38835   "RTN","CHM XMPD2",15, 0)
  38836    ;I CHFIO[ "MATRIX" S  CHMDJ=0,C HMDJ=$O(^C HMDIC(7410 02.17,1,80 1,"B","MED ICAL MATRI X INC",0))
  38837   "RTN","CHM XMPD2",16, 0)
  38838    ;I CHFIO[ "CMOP" S C HMDJ=0,CHM DJ=$O(^CHM DIC(741002 .17,1,801, "B","LEAVE NWORTH VA  CMOP",0))
  38839   "RTN","CHM XMPD2",17, 0)
  38840    ;I CHFIO[ "X12" S SN =$P(^CHMXC LC(CHCI,80 ),"^",5) G  A2
  38841   "RTN","CHM XMPD2",18, 0)
  38842    ;S:((CHFI O["MATRIX" )!(CHFIO[" CMOP"))&($ D(^CHMDIC( 741002.17, 1,801,CHMD J,0))) X=$ P(^(0),"^" ,3),SS=""
  38843   "RTN","CHM XMPD2",19, 0)
  38844    ;S:(CHFIO ["X12")&($ D(^CHMXTP( CHMDJ,0)))  X=$P(^(0) ,"^",9),SS =""
  38845   "RTN","CHM XMPD2",20, 0)
  38846    ;S:$D(^CH MIMD(74102 0.02,"B",X )) SS=$O(^ CHMIMD(741 020.02,"B" ,X,0))
  38847   "RTN","CHM XMPD2",21, 0)
  38848    ;S SN=$P( ^CHMIMD(74 1020.02,SS ,0),"^",6)
  38849   "RTN","CHM XMPD2",22, 0)
  38850   A2 ;F J=1: 1:(2-$L(SN )) S SN="0 "_SN
  38851   "RTN","CHM XMPD2",23, 0)
  38852    ;L ^CHMDI C(741002.3 8,PD) I '$ D(^CHMDIC( 741002.38, PD)) S $P( ^CHMDIC(74 1002.38,0) ,"^",3)=PD  D
  38853   "RTN","CHM XMPD2",24, 0)
  38854    .;S $P(^C HMDIC(7410 02.38,0)," ^",4)=$P(^ (0),"^",4) +1
  38855   "RTN","CHM XMPD2",25, 0)
  38856    .;S ^CHMD IC(741002. 38,PD,0)=P D_"^0^0^0^ 0" Q
  38857   "RTN","CHM XMPD2",26, 0)
  38858    ;S $P(^CH MDIC(74100 2.38,PD,0) ,"^",2)=$P (^CHMDIC(7 41002.38,P D,0),"^",2 )+1,DN=$P( ^CHMDIC(74 1002.38,PD ,0),"^",2)  L
  38859   "RTN","CHM XMPD2",27, 0)
  38860    ;F J=1:1: (6-$L(DN))  S DN="0"_ DN
  38861   "RTN","CHM XMPD2",28, 0)
  38862    ;S $P(^CH MDIC(74100 2.38,PD,0) ,"^",4)=$P (^(0),"^", 4)+1
  38863   "RTN","CHM XMPD2",29, 0)
  38864    ;F J=1:1: (3-$L(CHJU L)) S CHJU L="0"_CHJU L
  38865   "RTN","CHM XMPD2",30, 0)
  38866    ;S (CHMFP DI,X)=$E(P D,2,3)_CHJ UL_SN_DN    ; Y2K
  38867   "RTN","CHM XMPD2",31, 0)
  38868    ;S CHMFPD I=$$FMYR^C HTFLIB(PD) _CHJUL_SN_ DN
  38869   "RTN","CHM XMPD2",32, 0)
  38870    ;S (DIC,D LAYGO)=741 000.2,DIC( 0)="ML" D  ^DIC
  38871   "RTN","CHM XMPD2",33, 0)
  38872    ;K DIC
  38873   "RTN","CHM XMPD2",34, 0)
  38874    S $P(^CHM IMG(CHMFPD I,0),"^")= CHMFPDI,$P (^(0),"^", 2)=1,$P(^( 0),"^",6)= 1,$P(^(0), "^",18)=CH MXI,^CHMIM G("F",CHMX I,CHMFPDI) ="",^CHMIM G("B",CHMF PDI,CHMFPD I)=""
  38875   "RTN","CHM XMPD2",35, 0)
  38876    D NOW^%DT C S:'$D(%)  %=DT
  38877   "RTN","CHM XMPD2",36, 0)
  38878    S CHMDT=%
  38879   "RTN","CHM XMPD2",37, 0)
  38880    S $P(^CHM IMG(CHMFPD I,0),"^",3 )=CHMFDUZ, $P(^(0),"^ ",4)=%,$P( ^(0),"^",1 7)=4
  38881   "RTN","CHM XMPD2",38, 0)
  38882    ;NEXT LIN E FOR PDI  TIMELY FIL ING OVERRI DE
  38883   "RTN","CHM XMPD2",39, 0)
  38884    ;S ^CHMIM G(CHMFPDI, 10)=1_"^"_ CHMFDUZ_"^ "_% ; CHAN GE DUZ TO  9960 FOR R OBIN MEYER S, AD SUPV R
  38885   "RTN","CHM XMPD2",40, 0)
  38886    ;S $P(^CH MDIC(74100 2.38,PD,0) ,"^",3)=$P (^(0),"^", 3)+1
  38887   "RTN","CHM XMPD2",41, 0)
  38888    Q:('CHMFP DI)!(CHMFP DI="")
  38889   "RTN","CHM XMPD2",42, 0)
  38890    S ^CHMIMA GE(CHMFPDI ,0)=CHMFPD I_"^"_1_"^ "_CHMFDUZ_ "^"_CHMDT_ "^^^^"_4
  38891   "RTN","CHM XMPD2",43, 0)
  38892    S (CHMFPG NM,CHMFIMA G)=1
  38893   "RTN","CHM XMPD2",44, 0)
  38894    S ^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,0)=CHMFP GNM
  38895   "RTN","CHM XMPD2",45, 0)
  38896    S ^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,0)=CHMF IMAG_"^^^" _1_"^"_3
  38897   "RTN","CHM XMPD2",46, 0)
  38898    S ^CHMIMA GE("B",CHM FPDI,CHMFP DI)="",^CH MIMAGE(CHM FPDI,1,"B" ,CHMFPGNM, CHMFPGNM)= ""
  38899   "RTN","CHM XMPD2",47, 0)
  38900   END K CHJU L,X,SS,SN, DN,DLAYGO, CHMDJ
  38901   "RTN","CHM XMPD2",48, 0)
  38902    S CHMFPP= "SIP" D ^C HMFWK01
  38903   "RTN","CHM XMPD2",49, 0)
  38904    Q
  38905   "RTN","CHM XMPD2",50, 0)
  38906    ;
  38907   "RTN","CHM XMPD2",51, 0)
  38908   ERROR S $Z E="MDMTRX  PDI "_$ZE  D ^%ET Q
  38909   "RTN","CHM XMPDI")
  38910   0^68^B2031 7696
  38911   "RTN","CHM XMPDI",1,0 )
  38912   CHMXMPDI ; CVB/DTP;MO DIFIED MDM TRX PDI AS SIGNMENT;0 5/04/99  7 :40 AM
  38913   "RTN","CHM XMPDI",2,0 )
  38914    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  38915   "RTN","CHM XMPDI",3,0 )
  38916    ;PT 15932  (Y2K)
  38917   "RTN","CHM XMPDI",4,0 )
  38918    ;
  38919   "RTN","CHM XMPDI",5,0 )
  38920    ;CALLED B Y CHMXMDRV
  38921   "RTN","CHM XMPDI",6,0 )
  38922    ;BUILDS N EW PDI IN  STANDARD F ASHION EMP LOYING SCA NNER NUMBE R '99'
  38923   "RTN","CHM XMPDI",7,0 )
  38924    ;BEGINS T O BUILD IM AGE FILES
  38925   "RTN","CHM XMPDI",8,0 )
  38926    ;CFS 12/1 5/2017 - C PE005-001  Generate t he Re-open  PDI Numbe r.
  38927   "RTN","CHM XMPDI",9,0 )
  38928    ;RFE 12/2 1/18 INC36 32736 Prev ent differ ent claims  from gett ing the sa me PDI
  38929   "RTN","CHM XMPDI",10, 0)
  38930    ;CFS 01/1 6/19 Defec t 905019 F ix this S  CHMFPDI=$$ GETPDI(PD, CHJUL,DN,D N) to this  S CHMFPDI =$$GETPDI( PD,CHJUL,S N,DN) in l ine tag A2 +16
  38931   "RTN","CHM XMPDI",11, 0)
  38932    ;CFS 01/1 6/19 Defec t 905019 M ove the lo gic of GET PDI below  the line t ag END to  prevent un defined er rors for v ariables C HMFPGNM an d CHMFIMAG .
  38933   "RTN","CHM XMPDI",12, 0)
  38934    ;CFS 01/2 8/19 Chang e ^AHCHVA( "SB",IEN)  to ^AHCHVA ("SB",IEN, IEN2) to e nsure the  proper Pro gram Indic ator is ge nerated.
  38935   "RTN","CHM XMPDI",13, 0)
  38936   ZSET S:'$D (DUZ) DUZ= 1,DUZ(0)=" " I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  38937   "RTN","CHM XMPDI",14, 0)
  38938    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  38939   "RTN","CHM XMPDI",15, 0)
  38940    ;I '$D(IO Z) S %ZIS= "N",IOP="H OME" D HOM E^%ZIS S I OZ=IO,IOZL =IOSL,IOZW =IOM,IOZF= IOF,IOZT=I OST,IOZN=I ON,IOZS=IO S
  38941   "RTN","CHM XMPDI",16, 0)
  38942   ZNAM ;
  38943   "RTN","CHM XMPDI",17, 0)
  38944    S $ZT="ER ROR"
  38945   "RTN","CHM XMPDI",18, 0)
  38946    K CHMFPDI  S PDIFLG= "",CHMFDTN M=0
  38947   "RTN","CHM XMPDI",19, 0)
  38948   A1 D NOW^% DTC S:'$D( X) X=DT
  38949   "RTN","CHM XMPDI",20, 0)
  38950    S PD=X D
  38951   "RTN","CHM XMPDI",21, 0)
  38952    .S X=$E(P D,1,3)_"00 00" D H^%D TC S CHJUL =($P($H,", ",1)-%H)+1
  38953   "RTN","CHM XMPDI",22, 0)
  38954    ;
  38955   "RTN","CHM XMPDI",23, 0)
  38956    ;S PD=315 0717 D  ;A EB 11/5/20 10  USE TO  RERUN DAT A FILES WI TH OCIO DE FINING THE  PDI DATE
  38957   "RTN","CHM XMPDI",24, 0)
  38958    ;.S TMPDT =$$FMJUL^C HTFLIB(PD)
  38959   "RTN","CHM XMPDI",25, 0)
  38960    ;.S CHJUL =$E(TMPDT, 3,5)  ;AEB  11/5/2010   USE TO R ERUN DATA  FILES WITH  OCIO DEFI NING THE P DI DATE
  38961   "RTN","CHM XMPDI",26, 0)
  38962    ;
  38963   "RTN","CHM XMPDI",27, 0)
  38964    I CHFIO[" MATRIX" S  CHMDJ=0,CH MDJ=$O(^CH MDIC(74100 2.17,1,801 ,"B","MEDI CAL MATRIX  INC",0))
  38965   "RTN","CHM XMPDI",28, 0)
  38966    I CHFIO[" CMOP" S CH MDJ=0,CHMD J=$O(^CHMD IC(741002. 17,1,801," B","LEAVEN WORTH VA C MOP",0))
  38967   "RTN","CHM XMPDI",29, 0)
  38968    ;HR-PBM-P HASE 1-Beg in - JBM
  38969   "RTN","CHM XMPDI",30, 0)
  38970    ;Added lo gic to get  program t ype for SX
  38971   "RTN","CHM XMPDI",31, 0)
  38972    I CHFIO[" SXC" S CHM DJ=0,CHMDJ =$O(^CHMDI C(741002.1 7,1,801,"B ","SXC HEA LTH SOLUTI ONS INC",0 ))
  38973   "RTN","CHM XMPDI",32, 0)
  38974    I CHFIO[" X12" S SN= $P(^CHMXCL C(CHCI,80) ,"^",5) G  A2
  38975   "RTN","CHM XMPDI",33, 0)
  38976    ;S:((CHFI O["MATRIX" )!(CHFIO[" CMOP"))&($ D(^CHMDIC( 741002.17, 1,801,CHMD J,0))) X=$ P(^(0),"^" ,3),SS=""
  38977   "RTN","CHM XMPDI",34, 0)
  38978    S:((CHFIO ["SXC")!(C HFIO["MATR IX")!(CHFI O["CMOP")) &($D(^CHMD IC(741002. 17,1,801,C HMDJ,0)))  X=$P(^(0), "^",3),SS= ""
  38979   "RTN","CHM XMPDI",35, 0)
  38980    ;HR-PBM-P HASE 1-End
  38981   "RTN","CHM XMPDI",36, 0)
  38982    S:(CHFIO[ "X12")&($D (^CHMXTP(C HMDJ,0)))  X=$P(^(0), "^",9),SS= ""
  38983   "RTN","CHM XMPDI",37, 0)
  38984    S:$D(^CHM IMD(741020 .02,"B",X) ) SS=$O(^C HMIMD(7410 20.02,"B", X,0))
  38985   "RTN","CHM XMPDI",38, 0)
  38986    ;SN is ed i scanner  station
  38987   "RTN","CHM XMPDI",39, 0)
  38988    S SN=$P(^ CHMIMD(741 020.02,SS, 0),"^",6)
  38989   "RTN","CHM XMPDI",40, 0)
  38990   A2 F J=1:1 :(2-$L(SN) ) S SN="0" _SN
  38991   "RTN","CHM XMPDI",41, 0)
  38992    L ^CHMDIC (741002.38 ,PD) I '$D (^CHMDIC(7 41002.38,P D)) S $P(^ CHMDIC(741 002.38,0), "^",3)=PD  D
  38993   "RTN","CHM XMPDI",42, 0)
  38994    .S $P(^CH MDIC(74100 2.38,0),"^ ",4)=$P(^( 0),"^",4)+ 1
  38995   "RTN","CHM XMPDI",43, 0)
  38996    .S ^CHMDI C(741002.3 8,PD,0)=PD _"^0^0^0^0 " Q
  38997   "RTN","CHM XMPDI",44, 0)
  38998    S $P(^CHM DIC(741002 .38,PD,0), "^",2)=$P( ^CHMDIC(74 1002.38,PD ,0),"^",2) +1,DN=$P(^ CHMDIC(741 002.38,PD, 0),"^",2)  ;L Comment ed out unl ock, moved  it lower  RFE INC363 2736 
  38999   "RTN","CHM XMPDI",45, 0)
  39000    F J=1:1:( 6-$L(DN))  S DN="0"_D N
  39001   "RTN","CHM XMPDI",46, 0)
  39002    ;S $P(^CH MDIC(74100 2.38,PD,0) ,"^",4)=$P (^(0),"^", 4)+1
  39003   "RTN","CHM XMPDI",47, 0)
  39004    F J=1:1:( 3-$L(CHJUL )) S CHJUL ="0"_CHJUL
  39005   "RTN","CHM XMPDI",48, 0)
  39006    ;S (CHMFP DI,X)=$E(P D,2,3)_CHJ UL_SN_DN    ; Y2K
  39007   "RTN","CHM XMPDI",49, 0)
  39008    ;CPE005-0 01 Check f or Frequen cy Code 5, 6,7 and 8  to generat e a Re-ope n PDI Numb er.
  39009   "RTN","CHM XMPDI",50, 0)
  39010    I CHMFREQ =5!(CHMFRE Q=7)!(CHMF REQ=8) D   ;CPE005-00 1
  39011   "RTN","CHM XMPDI",51, 0)
  39012    .N SSN,IE N,IEN2
  39013   "RTN","CHM XMPDI",52, 0)
  39014    .S SSN=$P (^CHMXCLC( CHCI,0),"^ ",4)
  39015   "RTN","CHM XMPDI",53, 0)
  39016    .S IEN=$O (^AHCHVA(" G",SSN,"") )
  39017   "RTN","CHM XMPDI",54, 0)
  39018    .S IEN2=$ O(^AHCHVA( "G",SSN,IE N,""))  ;C FS 01/28/2 019
  39019   "RTN","CHM XMPDI",55, 0)
  39020    .;S SN=$S ($D(^AHCHV A("SB",IEN )):90,$D(^ AHCHVA("WV ",IEN)):93 ,1:97) ;Pr ogram Indi cator of 9 0 for Spin a or 97 fo r CHAMPVA
  39021   "RTN","CHM XMPDI",56, 0)
  39022    .S SN=$S( $D(^AHCHVA ("SB",IEN, IEN2)):90, $D(^AHCHVA ("WV",IEN, IEN2)):93, 1:97) ;Pro gram Indic ator of 90  for Spina  or 97 for  CHAMPVA
  39023   "RTN","CHM XMPDI",57, 0)
  39024    .I '$G(CH MFOPDI) S  CHMFOPDI=$ P(^CHMXCLE (CHEI,3)," ^",3)
  39025   "RTN","CHM XMPDI",58, 0)
  39026    ;S CHMFPD I=$$FMYR^C HTFLIB(PD) _CHJUL_SN_ DN Comment  RFE 12/21 /18 INC363 2736
  39027   "RTN","CHM XMPDI",59, 0)
  39028    ;S CHMFPD I=$$GETPDI (PD,CHJUL, DN,DN) ; R FE 12/21/1 8 INC36327 36
  39029   "RTN","CHM XMPDI",60, 0)
  39030    S CHMFPDI =$$GETPDI( PD,CHJUL,S N,DN) ; CF S 01/16/19  Defect 90 5019
  39031   "RTN","CHM XMPDI",61, 0)
  39032    L ; RFE 1 2/21/18 IN C3632736
  39033   "RTN","CHM XMPDI",62, 0)
  39034    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHMXMP DI: LINE 5 2 ",CHMFPD I
  39035   "RTN","CHM XMPDI",63, 0)
  39036   B I $D(^UT IL($J,"ZLE GRTN2")) S  ^UTIL($J, "ZLEGRTN2" )=CHMFPDI  ; LEG CPE0 05 to save  PDI being  generated  via ZLEGR TN2 **REMO VE/NOT FOR  HAC**
  39037   "RTN","CHM XMPDI",64, 0)
  39038    I (SN=94) !(SN=95)!( SN=96) S C HMQNAM="CH MEDIL(",CH MIN="" K C HMOUT D ^C HMIS041  ; AEB 1/18/2 007  FIX F OR CHV SCR EEN/OCR IS SUE
  39039   "RTN","CHM XMPDI",65, 0)
  39040    ;S (DIC,D LAYGO)=741 000.2,DIC( 0)="ML" D  ^DIC
  39041   "RTN","CHM XMPDI",66, 0)
  39042    ;K DIC
  39043   "RTN","CHM XMPDI",67, 0)
  39044    S $P(^CHM IMG(CHMFPD I,0),"^")= CHMFPDI,$P (^(0),"^", 2)=1,$P(^( 0),"^",6)= 1,$P(^(0), "^",18)=CH MXI,^CHMIM G("F",CHMX I,CHMFPDI) ="",^CHMIM G("B",CHMF PDI,CHMFPD I)=""
  39045   "RTN","CHM XMPDI",68, 0)
  39046    D NOW^%DT C S:'$D(%)  %=DT
  39047   "RTN","CHM XMPDI",69, 0)
  39048    S CHMDT=%
  39049   "RTN","CHM XMPDI",70, 0)
  39050    S $P(^CHM IMG(CHMFPD I,0),"^",3 )=CHMFDUZ, $P(^(0),"^ ",4)=%,$P( ^(0),"^",1 7)=4
  39051   "RTN","CHM XMPDI",71, 0)
  39052    ;NEXT LIN E FOR PDI  TIMELY FIL ING OVERRI DE
  39053   "RTN","CHM XMPDI",72, 0)
  39054    ;S ^CHMIM G(CHMFPDI, 10)=1_"^"_ CHMFDUZ_"^ "_% ; CHAN GE DUZ TO  9960 FOR R OBIN MEYER S, AD SUPV R
  39055   "RTN","CHM XMPDI",73, 0)
  39056    S $P(^CHM DIC(741002 .38,PD,0), "^",3)=$P( ^(0),"^",3 )+1
  39057   "RTN","CHM XMPDI",74, 0)
  39058    Q:('CHMFP DI)!(CHMFP DI="")
  39059   "RTN","CHM XMPDI",75, 0)
  39060    ;
  39061   "RTN","CHM XMPDI",76, 0)
  39062    ;CFS 01/1 6/2019 - M ove GETPDI  to below  line tag E ND.
  39063   "RTN","CHM XMPDI",77, 0)
  39064    ;GETPDI(P D,CHJUL,SN ,DN) ; RFE  12/21/18  INC3632736  Make sure  we don't  duplicate  PDI
  39065   "RTN","CHM XMPDI",78, 0)
  39066    ;S TMPPDI =$$FMYR^CH TFLIB(PD)_ CHJUL_SN_D N
  39067   "RTN","CHM XMPDI",79, 0)
  39068    ;I ('$D(^ CHMIMG(TMP PDI)))&('$ D(^CHMIMAG E(TMPPDI)) ) Q TMPPDI
  39069   "RTN","CHM XMPDI",80, 0)
  39070    ;N DONE
  39071   "RTN","CHM XMPDI",81, 0)
  39072    ;S DONE=0
  39073   "RTN","CHM XMPDI",82, 0)
  39074    ;F  D  Q: DONE
  39075   "RTN","CHM XMPDI",83, 0)
  39076    ;. S TMPP DI=TMPPDI+ 1
  39077   "RTN","CHM XMPDI",84, 0)
  39078    ;. S $P(^ CHMDIC(741 002.38,PD, 0),"^",2)= $P(^CHMDIC (741002.38 ,PD,0),"^" ,2)+1
  39079   "RTN","CHM XMPDI",85, 0)
  39080    ;. I ('$D (^CHMIMG(T MPPDI)))&( '$D(^CHMIM AGE(TMPPDI ))) S DONE =1
  39081   "RTN","CHM XMPDI",86, 0)
  39082    ;. Q
  39083   "RTN","CHM XMPDI",87, 0)
  39084    ;Q TMPPDI
  39085   "RTN","CHM XMPDI",88, 0)
  39086   RKNCPDI ;Q uit if PDI  is alread y in the ^ CHMIMAGE(   global, d o not writ e data 02/ 24/06 RKN
  39087   "RTN","CHM XMPDI",89, 0)
  39088    ;D NOW^%D TC
  39089   "RTN","CHM XMPDI",90, 0)
  39090    ;I $D(^CH MIMAGE(CHM FPDI)) S ^ CHMZHOLD(" X12_DUPEPD I",CHFIO,% )=CHMFPDI_ "^"_CHFIO  D RKNMAIL^ CHMXDR01 Q
  39091   "RTN","CHM XMPDI",91, 0)
  39092    ;
  39093   "RTN","CHM XMPDI",92, 0)
  39094    S ^CHMIMA GE(CHMFPDI ,0)=CHMFPD I_"^"_1_"^ "_CHMFDUZ_ "^"_CHMDT_ "^^^^"_4
  39095   "RTN","CHM XMPDI",93, 0)
  39096    S (CHMFPG NM,CHMFIMA G)=1
  39097   "RTN","CHM XMPDI",94, 0)
  39098    S ^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,0)=CHMFP GNM
  39099   "RTN","CHM XMPDI",95, 0)
  39100    S ^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,0)=CHMF IMAG_"^^^" _1_"^"_3
  39101   "RTN","CHM XMPDI",96, 0)
  39102    S ^CHMIMA GE("B",CHM FPDI,CHMFP DI)="",^CH MIMAGE(CHM FPDI,1,"B" ,CHMFPGNM, CHMFPGNM)= ""
  39103   "RTN","CHM XMPDI",97, 0)
  39104   END K CHJU L,X,SS,SN, DN,DLAYGO, CHMDJ
  39105   "RTN","CHM XMPDI",98, 0)
  39106    S CHMFPP= "SIP" D ^C HMFWK01
  39107   "RTN","CHM XMPDI",99, 0)
  39108    Q
  39109   "RTN","CHM XMPDI",100 ,0)
  39110    ;
  39111   "RTN","CHM XMPDI",101 ,0)
  39112    ;CFS 01/1 6/19 Defec t 905019 M ove GETPDI  Below lin e tag END.
  39113   "RTN","CHM XMPDI",102 ,0)
  39114   GETPDI(PD, CHJUL,SN,D N) ; RFE 1 2/21/18 IN C3632736 M ake sure w e don't du plicate PD I
  39115   "RTN","CHM XMPDI",103 ,0)
  39116    S TMPPDI= $$FMYR^CHT FLIB(PD)_C HJUL_SN_DN
  39117   "RTN","CHM XMPDI",104 ,0)
  39118    I ('$D(^C HMIMG(TMPP DI)))&('$D (^CHMIMAGE (TMPPDI)))  Q TMPPDI
  39119   "RTN","CHM XMPDI",105 ,0)
  39120    N DONE
  39121   "RTN","CHM XMPDI",106 ,0)
  39122    S DONE=0
  39123   "RTN","CHM XMPDI",107 ,0)
  39124    F  D  Q:D ONE
  39125   "RTN","CHM XMPDI",108 ,0)
  39126    . S TMPPD I=TMPPDI+1
  39127   "RTN","CHM XMPDI",109 ,0)
  39128    . S $P(^C HMDIC(7410 02.38,PD,0 ),"^",2)=$ P(^CHMDIC( 741002.38, PD,0),"^", 2)+1
  39129   "RTN","CHM XMPDI",110 ,0)
  39130    . I ('$D( ^CHMIMG(TM PPDI)))&(' $D(^CHMIMA GE(TMPPDI) )) S DONE= 1
  39131   "RTN","CHM XMPDI",111 ,0)
  39132    . Q
  39133   "RTN","CHM XMPDI",112 ,0)
  39134    Q TMPPDI
  39135   "RTN","CHM XMPDI",113 ,0)
  39136    ;
  39137   "RTN","CHM XMPDI",114 ,0)
  39138   ERROR S $Z E="MDMTRX  PDI "_$ZE  D ^%ET Q
  39139   "RTN","CHM XP010")
  39140   0^98^B2005 4379
  39141   "RTN","CHM XP010",1,0 )
  39142   CHMXP010 ; CVA/DTP;X1 2 837 "E00 0" RECORD  READ (HEAL TH CARE CL AIMS);02/0 6/98  1:34  PM
  39143   "RTN","CHM XP010",2,0 )
  39144    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 11,201 1;Build 9
  39145   "RTN","CHM XP010",3,0 )
  39146    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  39147   "RTN","CHM XP010",4,0 )
  39148    ;;CALLED  INDIRECTLY  BY ^CHMXP 001 (VARIA BLE CHRTN  SET BY PUL LING PROPE R
  39149   "RTN","CHM XP010",5,0 )
  39150    ;;READ RT N FOR EACH  RECORD TY PE FROM ^C HMXCLR--83 7 CLAIM RE CORD FILE)
  39151   "RTN","CHM XP010",6,0 )
  39152    ;; PARAME TERS WHICH  MUST BE S ET UP PRIO R TO THIS  ROUTINE: 
  39153   "RTN","CHM XP010",7,0 )
  39154    ;; CHX12V RS  (3051/ 4010/5010)
  39155   "RTN","CHM XP010",8,0 )
  39156    ;; CHXSTY PE  (EDI/O CR)
  39157   "RTN","CHM XP010",9,0 )
  39158    ;; CHCLAI     (CHMXC LA(I) VALU E
  39159   "RTN","CHM XP010",10, 0)
  39160    ;; CHCLCI     (CHMXC LC(I) VALU E
  39161   "RTN","CHM XP010",11, 0)
  39162    ;; 7/2012  DLB ADDED  CROSS-REF ERENCE SET UPS FOR ^C HMXCLE "E"  AND "F" X REFS DEFIN ED IN FILE MAN
  39163   "RTN","CHM XP010",12, 0)
  39164    ;; 7/2012   DLB PROV IDED FUNCT ION TO REP LACE THE M ANUAL "SET " OF THE ^ CHMXCLE()  BUFFER TO  USE FILEMA N
  39165   "RTN","CHM XP010",13, 0)
  39166    ;;           FUNCTIO NS. THIS W ILL SET UP  THE CROSS -REFERENCE S AUTOMATI CALLY (NOT  CALLED)
  39167   "RTN","CHM XP010",14, 0)
  39168    ;;12/19/1 2 DLB ADDE D CROSS-RE FERENCE FO R ^CHMXCLE  "D" XREFS  DEFINED I N FILEMAN  DEV 7820
  39169   "RTN","CHM XP010",15, 0)
  39170    ;;01/21/1 3 -lg ICD- 10 RCS mod ified $cas e statemen t after re ceiving sy stem error  <illegal  value> dur ing analys is
  39171   "RTN","CHM XP010",16, 0)
  39172    ;;01/30/1 9 CFS Defe ct 914090  add check  for a Reop en PDI Pro gram Indic ator.
  39173   "RTN","CHM XP010",17, 0)
  39174   A ;KKAIEL
  39175   "RTN","CHM XP010",18, 0)
  39176    D:$D(CHSV LN) LNSUM^ CHMXP022
  39177   "RTN","CHM XP010",19, 0)
  39178    I $D(CHXS TYP) I CHX STYP=1 G A NXT ; WHEN  OCR ZERO  NODE SET U P FOR "E00 1" RECORD  READ FIRST  IN CHMXP0 46 SO SKIP  ZERO SET  BELOW
  39179   "RTN","CHM XP010",20, 0)
  39180    L ^CHMXCL E(0) S:'$D (^CHMXCLE( 0)) ^(0)=" X12 837 BU FFER CLAIM  LEVEL^741 210.12P^0^ 0"
  39181   "RTN","CHM XP010",21, 0)
  39182    S CHCLEI= $P(^CHMXCL E(0),"^",3 )+1,$P(^(0 ),"^",3)=C HCLEI
  39183   "RTN","CHM XP010",22, 0)
  39184    S $P(^CHM XCLE(0),"^ ",4)=$P(^( 0),"^",4)+ 1 L
  39185   "RTN","CHM XP010",23, 0)
  39186   ANXT S CHC ODE="" K C HRCERR,CHD TA,CHLVLRJ ("E")
  39187   "RTN","CHM XP010",24, 0)
  39188    D GENREAD ^CHMXPU01   ; LOAD TH E CLAIM RE CORD INTO  CHDTSTR
  39189   "RTN","CHM XP010",25, 0)
  39190    ;KKAIEL
  39191   "RTN","CHM XP010",26, 0)
  39192    Q:$D(CHRC ER)
  39193   "RTN","CHM XP010",27, 0)
  39194   B S:CHX12V RS=1 ^CHMX CLE(CHCLEI ,0)=CHCLCI _"^"_CHDTS TR
  39195   "RTN","CHM XP010",28, 0)
  39196    ;Methodic al-5010 Ch ange-Begin
  39197   "RTN","CHM XP010",29, 0)
  39198    S:(CHX12V RS=2)!(CHX 12VRS=3) ^ CHMXCLE(CH CLEI,0)=CH CLCI_"^"_$ P(CHDTSTR, "^")_"^^"_ $P(CHDTSTR ,"^",2,10) _"^^^"_$P( CHDTSTR,"^ ",11,13)
  39199   "RTN","CHM XP010",30, 0)
  39200    S:(CHX12V RS=3) $P(^ CHMXCLE(CH CLEI,0),"^ ",14)=$P(C HDTSTR,"^" ,14)
  39201   "RTN","CHM XP010",31, 0)
  39202    ;Methodic al-5010 Ch ange-End
  39203   "RTN","CHM XP010",32, 0)
  39204    S ^CHMXCL E("B",CHCL CI,CHCLEI) =""  ; SET  THE BENE  BATCH NUMB ER XREF
  39205   "RTN","CHM XP010",33, 0)
  39206    S ^CHMXCL E("E",$P(C HDTSTR,"^" ,13),CHCLE I)=""  ; S ET THE HDR  CLAIM ID  XREF
  39207   "RTN","CHM XP010",34, 0)
  39208    S ^CHMXCL E("F",$P(C HDTSTR,"^" ,14),CHCLE I)=""  ; S ET THE SUB MITTER CON TROL NUMBE R XREF
  39209   "RTN","CHM XP010",35, 0)
  39210   CLMTYP ;AD DED BY DTP  (AUG-02)  FOR CLAIM  TYPE SEPAR ATION FLAG
  39211   "RTN","CHM XP010",36, 0)
  39212    ;USE OCR- EDI FLAG F ROM A010 R ECORD IN C OMBINATION  WITH INST ./PROF. FL AG
  39213   "RTN","CHM XP010",37, 0)
  39214    ;FROM E00 0 RECORD T O DETERMIN E CLAIM TY PE FLAG
  39215   "RTN","CHM XP010",38, 0)
  39216    ;CHXFLVR= "A" FOR IN STI, "B" F OR PROF, " C" FOR DEN TAL
  39217   "RTN","CHM XP010",39, 0)
  39218    ;CHXCLTYP  = 1 FOR 8 37I, 2 FOR  837P, 3 F OR 837D, 4  FOR OCR/U B, 5 FOR O CR/HCFA
  39219   "RTN","CHM XP010",40, 0)
  39220    ;Methodic al-5010 Ch ange-Begin
  39221   "RTN","CHM XP010",41, 0)
  39222    ;I ('$D(^ CHMXCLE(CH CLEI,0)))! ($P(^CHMXC LE(CHCLEI, 0),"^",5)= "") S CHRC ER="",CHER ="R8" Q
  39223   "RTN","CHM XP010",42, 0)
  39224    I '$D(^CH MXCLE(CHCL EI,0)) S C HRCER="",C HER="R8" Q
  39225   "RTN","CHM XP010",43, 0)
  39226    I $P(^CHM XCLE(CHCLE I,0),"^",5 )="" S CHR CER="",CHE R="R8" Q
  39227   "RTN","CHM XP010",44, 0)
  39228    ;Methodic al-5010 Ch ange-End
  39229   "RTN","CHM XP010",45, 0)
  39230    I ('$D(^C HMXCLA(CHC LAI,80)))! ($P(^CHMXC LA(CHCLAI, 80),"^",7) ="") S CHR CER="",CHE R="R8" Q
  39231   "RTN","CHM XP010",46, 0)
  39232    ;Methodic al-5010 Ch ange-Begin
  39233   "RTN","CHM XP010",47, 0)
  39234    ;S CHXFLV R=$P(^CHMX CLE(CHCLEI ,0),"^",5) ,CHXSTYP=$ P(^CHMXCLA (CHCLAI,80 ),"^",7)
  39235   "RTN","CHM XP010",48, 0)
  39236    ;S:CHXFLV R="C" CHXC LTYP=3
  39237   "RTN","CHM XP010",49, 0)
  39238    ;S:(CHXFL VR="A")&(C HXSTYP=0)  CHXCLTYP=1
  39239   "RTN","CHM XP010",50, 0)
  39240    ;S:(CHXFL VR="A")&(C HXSTYP=1)  CHXCLTYP=4
  39241   "RTN","CHM XP010",51, 0)
  39242    ;S:(CHXFL VR="B")&(C HXSTYP=0)  CHXCLTYP=2
  39243   "RTN","CHM XP010",52, 0)
  39244    ;S:(CHXFL VR="B")&(C HXSTYP=1)  CHXCLTYP=5
  39245   "RTN","CHM XP010",53, 0)
  39246    s CHXFLVR =$$CLMTYPE ()
  39247   "RTN","CHM XP010",54, 0)
  39248    s CHXCLTY P=$case(CH XFLVR,"A": 1,"B":2,"C ":3)
  39249   "RTN","CHM XP010",55, 0)
  39250    ;Methodic al-5010 Ch ange-End
  39251   "RTN","CHM XP010",56, 0)
  39252    S ZZ=9999 9,ZZ=$O(^C HMXCLE(CHC LEI,101,ZZ ),-1) S:'Z Z ZZ=0
  39253   "RTN","CHM XP010",57, 0)
  39254    S CHRJRSN ="",CHIL=" CHCLEI",CH GLBL="^CHM XCLE(",CHF N=741210.1 2101
  39255   "RTN","CHM XP010",58, 0)
  39256    D C^CHMXP 003 S CHSV =6 D STXRE F I $D(CHR CER) S CHE R="R4"  ;  UPDATE THE  CLAIM BUF FER
  39257   "RTN","CHM XP010",59, 0)
  39258   END Q
  39259   "RTN","CHM XP010",60, 0)
  39260    ;
  39261   "RTN","CHM XP010",61, 0)
  39262    ;Methodic al-5010 Ch ange-Begin
  39263   "RTN","CHM XP010",62, 0)
  39264    ;ICD-10 R CS modifie d $case st atement af ter receiv ing system  error <il legal valu e> during  analysis - lg
  39265   "RTN","CHM XP010",63, 0)
  39266   CLMTYPE()  Q $case($e ($p(^CHMXC LA(CHCLAI, 0),U,13),8 ,10),222:" B","097":" B",223:"A" ,"096":"A" ,224:"C"," 098":"C")
  39267   "RTN","CHM XP010",64, 0)
  39268    ;Methodic al-5010 Ch ange-End
  39269   "RTN","CHM XP010",65, 0)
  39270    ;
  39271   "RTN","CHM XP010",66, 0)
  39272   STXREF S C HMXCCNB=""  G:'$D(^CH MXCLE(CHCL EI,0)) STX NXT S CHMX CCNB=$P(^( 0),"^",2)
  39273   "RTN","CHM XP010",67, 0)
  39274   STXNXT ;IF  OCR CLAIM  GET PDI F ROM CHMXCL E(I,100) A ND BYPASS  PSEUDO PDI  SET UP
  39275   "RTN","CHM XP010",68, 0)
  39276    K CHCLCNB  I CHXSTYP =1 S:$D(^C HMXCLE(CHC LEI,100))  CHCLCNB=$P (^(100),"^ ",2) G STX NXT2
  39277   "RTN","CHM XP010",69, 0)
  39278    ;S CHMECT =^CHMXCL(" CLM CNT",C HMXCLI)+1, ^CHMXCL("C LM CNT",CH MXCLI)=CHM ECT,CHCLCN B=CHJUL_CH MXCLI_CHME CT,$P(^CHM XCLE(CHCLE I,100),"^" ,4)=CHCLCN B
  39279   "RTN","CHM XP010",70, 0)
  39280    ;NEXT FEW  LINES DO  A PSEUDO P DI CREATIO N FOR SUBM ISSION
  39281   "RTN","CHM XP010",71, 0)
  39282    S SN="00"
  39283   "RTN","CHM XP010",72, 0)
  39284    L ^CHMDIC (741002.38 ,PD)
  39285   "RTN","CHM XP010",73, 0)
  39286    I '$D(^CH MDIC(74100 2.38,PD))  S $P(^CHMD IC(741002. 38,0),"^", 3)=PD D
  39287   "RTN","CHM XP010",74, 0)
  39288    .S $P(^CH MDIC(74100 2.38,0),"^ ",4)=$P(^( 0),"^",4)+ 1
  39289   "RTN","CHM XP010",75, 0)
  39290    .S ^CHMDI C(741002.3 8,PD,0)=PD _"^0^0^0^0 " Q
  39291   "RTN","CHM XP010",76, 0)
  39292    S $P(^CHM DIC(741002 .38,PD,0), "^",2)=$P( ^CHMDIC(74 1002.38,PD ,0),"^",2) +1,DN=$P(^ CHMDIC(741 002.38,PD, 0),"^",2)
  39293   "RTN","CHM XP010",77, 0)
  39294    L
  39295   "RTN","CHM XP010",78, 0)
  39296    F J=1:1:( 6-$L(DN))  S DN="0"_D N
  39297   "RTN","CHM XP010",79, 0)
  39298    ;S $P(^CH MDIC(74100 2.38,PD,0) ,"^",4)=$P (^(0),"^", 4)+1
  39299   "RTN","CHM XP010",80, 0)
  39300    F J=1:1:( 3-$L(CHJUL )) S CHJUL ="0"_CHJUL
  39301   "RTN","CHM XP010",81, 0)
  39302    S CHCLCNB =$$FMYR^CH TFLIB(PD)_ CHJUL_SN_D N
  39303   "RTN","CHM XP010",82, 0)
  39304    ;N CHFREQ   ;CFS 01/ 30/2019  D efect 9140 90
  39305   "RTN","CHM XP010",83, 0)
  39306    ;S CHFREQ =$P(^CHMXC LE(CHCLEI, 0),"^",6)
  39307   "RTN","CHM XP010",84, 0)
  39308    ;I CHFREQ =5!(CHFREQ =7)!(CHFRE Q=8) D  ;D efect 9140 90; BDB 03 082019 dro pped FC=6
  39309   "RTN","CHM XP010",85, 0)
  39310    ;.;N SSN, IEN,IEN2
  39311   "RTN","CHM XP010",86, 0)
  39312    ;.;S SSN= $P(^CHMXCL C(CHCLCI,0 ),"^",4)
  39313   "RTN","CHM XP010",87, 0)
  39314    ;.;S IEN= $O(^AHCHVA ("G",SSN," "))
  39315   "RTN","CHM XP010",88, 0)
  39316    ;.;S IEN2 =$O(^AHCHV A("G",SSN, IEN,""))   ;CFS 01/28 /2019
  39317   "RTN","CHM XP010",89, 0)
  39318    ;.;S SN=$ S($D(^AHCH VA("SB",IE N,IEN2)):9 0,$D(^AHCH VA("WV",IE N,IEN2)):9 3,1:97) ;P rogram Ind icator of  90 for Spi na or 97 f or CHAMPVA
  39319   "RTN","CHM XP010",90, 0)
  39320    ;.;S $E(C HCLCNB,8,9 )=SN
  39321   "RTN","CHM XP010",91, 0)
  39322    S $P(^CHM XCLE(CHCLE I,100),"^" ,4)=CHCLCN B
  39323   "RTN","CHM XP010",92, 0)
  39324    S ^CHMXCL E("D",CHCL CNB,CHCLEI )=""  ; SE T UP FILEM AN "D" XRE F
  39325   "RTN","CHM XP010",93, 0)
  39326   STXNXT2 ;N EXT FEW LI NES SET UP  PRIMARY S UBMISSION  X-REFS ON  PDI AND PC N
  39327   "RTN","CHM XP010",94, 0)
  39328    S:CHMXCCN B="" CHMXC CNB="NIL"
  39329   "RTN","CHM XP010",95, 0)
  39330    S ^CHMXCL E("CLM-CTR L-NO",CHMX CCNB,CHCLC NB,CHMXCLI ,CHCLAI_"* "_CHCLBI_" *"_CHCLCI_ "*"_CHCLEI )=""
  39331   "RTN","CHM XP010",96, 0)
  39332    S ^CHMXCL E("PDI",CH CLCNB,CHMX CCNB,CHMXC LI,CHCLAI_ "*"_CHCLBI _"*"_CHCLC I_"*"_CHCL EI)=""
  39333   "RTN","CHM XP010",97, 0)
  39334   STXREF0 I  ('$D(CHCLC NB))!(CHCL CNB="") S  CHRCER=""  Q
  39335   "RTN","CHM XP010",98, 0)
  39336    I ($D(CHL VLRJ("A")) !$D(CHLVLR J("B"))!$D (CHLVLRJ(" C"))!$D(CH LVLRJ("E") )) D  K CH SV Q
  39337   "RTN","CHM XP010",99, 0)
  39338    .S SV=""
  39339   "RTN","CHM XP010",100 ,0)
  39340   STXREF1 .S  SV=$O(^CH MXCLE("A", CHMXCLI,SV )) G:SV=""  STXREF2
  39341   "RTN","CHM XP010",101 ,0)
  39342    .K ^CHMXC LE("A",CHM XCLI,SV,CH CLAI,CHCLC NB)
  39343   "RTN","CHM XP010",102 ,0)
  39344    .G STXREF 1
  39345   "RTN","CHM XP010",103 ,0)
  39346   STXREF2 .S  ^CHMXCLE( "A",CHMXCL I,CHSV,CHC LAI,CHCLCN B,CHCLBI_" *"_CHCLCI_ "*"_CHCLEI )=""
  39347   "RTN","CHM XP010",104 ,0)
  39348    E  S ^CHM XCLE("A",C HMXCLI,0,C HCLAI,CHCL CNB,CHCLBI _"*"_CHCLC I_"*"_CHCL EI)="" Q
  39349   "RTN","CHM XP010",105 ,0)
  39350    ; 
  39351   "RTN","CHM XPU03")
  39352   0^69^B1579 9939
  39353   "RTN","CHM XPU03",1,0 )
  39354   CHMXPU03 ; CVA/DTP;X1 2 837 READ  EDIT UTIL ITY #3 (HE ALTH CARE  CLAIMS);02 /06/98  1: 34 PM
  39355   "RTN","CHM XPU03",2,0 )
  39356    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  39357   "RTN","CHM XPU03",3,0 )
  39358    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  39359   "RTN","CHM XPU03",4,0 )
  39360    ;;SPECIAL  EDITS FOR  837 RECOR D READ AT  CLAIM LEVE LS
  39361   "RTN","CHM XPU03",5,0 )
  39362    ;;CALLED  INDIRECTLY  BY GENREA D^CHMXPU01 +15 (CHEDR TN IS DEFI NED)
  39363   "RTN","CHM XPU03",6,0 )
  39364    ;;             
  39365   "RTN","CHM XPU03",7,0 )
  39366    ;;BUG0005 6 - AJM 07 -FEB-2008  modified F E edits pe r ENC00056
  39367   "RTN","CHM XPU03",8,0 )
  39368    ;;DEF0194 02 FE Edit  incorrect ly returne d a claim  BMJ 01/16/ 14 
  39369   "RTN","CHM XPU03",9,0 )
  39370    ;BDB 1/16 /19 CPE005 -039; Reje ct all Fre quency Cod e 6
  39371   "RTN","CHM XPU03",10, 0)
  39372    ; 
  39373   "RTN","CHM XPU03",11, 0)
  39374   ICTYPP ;CH ECKS PRESE NCE OF THE  IC TYPE-- SECOND PAR T OF GS08  DATA
  39375   "RTN","CHM XPU03",12, 0)
  39376    I '$D(CHF LD(CHFLPN) ) D RCDERR ^CHMXPU01  G ICTYPP1
  39377   "RTN","CHM XPU03",13, 0)
  39378    S CHICTYP =$E(CHFLD( CHFLPN),7, 15) I CHIC TYP="" D R CDERR^CHMX PU01 G ICT YPP1
  39379   "RTN","CHM XPU03",14, 0)
  39380   ICTYPP1 K  CHICTYP Q
  39381   "RTN","CHM XPU03",15, 0)
  39382    ; 
  39383   "RTN","CHM XPU03",16, 0)
  39384   ICTYPV ;VA LIDATE IC  TYPE(2ND P ART OF GS0 8) BY LOOK ING UP IN  SET OF COD ES
  39385   "RTN","CHM XPU03",17, 0)
  39386    Q:$D(CHRC ERR(CHXREC ,"A014a"))
  39387   "RTN","CHM XPU03",18, 0)
  39388    S CHFLDHL D=CHFLD(CH FLPN),CHFL D(CHFLPN)= $E(CHFLD(C HFLPN),7,1 5),CHCVFL= "^CHMXDIC( 741201.38, ""C"",1,", CHCVDIR=""
  39389   "RTN","CHM XPU03",19, 0)
  39390    D 5011^CH MXPU01
  39391   "RTN","CHM XPU03",20, 0)
  39392   ICTYPV1 S  CHFLD(CHFL PN)=CHFLDH LD K CHFLD HLD,CHCVDI R Q
  39393   "RTN","CHM XPU03",21, 0)
  39394    ; 
  39395   "RTN","CHM XPU03",22, 0)
  39396   TSVRNP ;CH ECKS PRESE NCE OF THE  TS VERSIO N--FIRST P ART OF GS0 8 DATA
  39397   "RTN","CHM XPU03",23, 0)
  39398    I '$D(CHF LD(CHFLPN) ) D RCDERR ^CHMXPU01  G TSVRNP1
  39399   "RTN","CHM XPU03",24, 0)
  39400    S CHTSVRN =$E(CHFLD( CHFLPN),1, 6) I CHTSV RN="" D RC DERR^CHMXP U01 G TSVR NP1
  39401   "RTN","CHM XPU03",25, 0)
  39402   TSVRNP1 K  CHTSVRN Q
  39403   "RTN","CHM XPU03",26, 0)
  39404    ; 
  39405   "RTN","CHM XPU03",27, 0)
  39406   TSVRNV ;VA LIDATE TS  VERSION (2 ND PART OF  GS08) BY  LOOKING UP  IN SET OF  CODES
  39407   "RTN","CHM XPU03",28, 0)
  39408    Q:$D(CHRC ERR(CHXREC ,"A014b"))
  39409   "RTN","CHM XPU03",29, 0)
  39410    S CHFLDHL D=CHFLD(CH FLPN),CHFL D(CHFLPN)= $E(CHFLD(C HFLPN),1,6 ),CHCVFL=" ^CHMXDIC(7 41201.33,1 ,102,""B"" ,",CHCVDIR =""
  39411   "RTN","CHM XPU03",30, 0)
  39412    D 5011^CH MXPU01
  39413   "RTN","CHM XPU03",31, 0)
  39414   TSVRNV1 S  CHFLD(CHFL PN)=CHFLDH LD K CHFLD HLD Q
  39415   "RTN","CHM XPU03",32, 0)
  39416    ; 
  39417   "RTN","CHM XPU03",33, 0)
  39418   CLTPCD ;CL AIM TYPE C ODE MUST B E PRESENT  IF IC TYPE  = "PHYS"  OR IC TYPE  = "HOSP"
  39419   "RTN","CHM XPU03",34, 0)
  39420    ;AND BILL  TYPE = 13  AND IT MU ST BE FOUN D IN DD FO R DE #1343
  39421   "RTN","CHM XPU03",35, 0)
  39422    D GETIC I  $D(CHEDPR B) S CHPRB =CHEDRJ G  CLTPCD1
  39423   "RTN","CHM XPU03",36, 0)
  39424    I '$D(RCD ) S CHEDPR B="",CHPRB =CHEDRJ G  CLTPCD1
  39425   "RTN","CHM XPU03",37, 0)
  39426    S:CHX12VR S=1 CHZZBE G=42,CHZZE ND=43
  39427   "RTN","CHM XPU03",38, 0)
  39428    ;Methodic al-5010 Ch ange-Begin
  39429   "RTN","CHM XPU03",39, 0)
  39430    S:(CHX12V RS=2)!(CHX 12VRS=3) C HZZBEG=43, CHZZEND=44
  39431   "RTN","CHM XPU03",40, 0)
  39432    ;Methodic al-5010 Ch ange-End
  39433   "RTN","CHM XPU03",41, 0)
  39434    S Y=$E(RC D,CHZZBEG, CHZZEND),C HBLTP=$$TR IM^CHMXPU0 1(Y) I CHB LTP="" S C HEDRJHL=CH EDRJ,CHEDR J="E04a" D  RCDERR^CH MXPU01 S C HEDRJ=CHED RJHL G CLT PCD1
  39435   "RTN","CHM XPU03",42, 0)
  39436    S:CHX12VR S=1 CHZZBE G=44
  39437   "RTN","CHM XPU03",43, 0)
  39438    ;Methodic al-5010 Ch ange-Begin
  39439   "RTN","CHM XPU03",44, 0)
  39440    S:(CHX12V RS=2)!(CHX 12VRS=3) C HZZBEG=45
  39441   "RTN","CHM XPU03",45, 0)
  39442    ;Methodic al-5010 Ch ange-End
  39443   "RTN","CHM XPU03",46, 0)
  39444    S Y=$E(RC D,CHZZBEG) ,CHQLF=$$T RIM^CHMXPU 01(Y) I CH QLF="" S C HEDRJHL=CH EDRJ,CHEDR J="E05a" D  RCDERR^CH MXPU01 S C HEDRJ=CHED RJHL G CLT PCD1
  39445   "RTN","CHM XPU03",47, 0)
  39446    I ((CHICT P="PHYS")& (CHFLD(CHF LPN)=""))! ((CHICTP=" HOSP")&(CH BLTP=13)&( CHQLF="A") &(CHFLD(CH FLPN)=""))  D RCDERR^ CHMXPU01 G  CLTPCD1
  39447   "RTN","CHM XPU03",48, 0)
  39448    Q:CHFLD(C HFLPN)=""
  39449   "RTN","CHM XPU03",49, 0)
  39450    I '$D(CHM XDIC(74120 1.02,"B",C HFLD(CHFLP N))) D RCD ERR^CHMXPU 01 G CLTPC D1
  39451   "RTN","CHM XPU03",50, 0)
  39452   CLTPCD1 K  CHICTP,CHB LTP,CHQLF, CHEDRJHL,C HZZBEG,CHZ ZEND Q
  39453   "RTN","CHM XPU03",51, 0)
  39454    ;
  39455   "RTN","CHM XPU03",52, 0)
  39456    ; ajm - a dded new s ubroutine  BUG00056
  39457   "RTN","CHM XPU03",53, 0)
  39458   BTPOSI ;
  39459   "RTN","CHM XPU03",54, 0)
  39460    NEW CHBTQ LF,POS
  39461   "RTN","CHM XPU03",55, 0)
  39462    Q:$D(CHRC ERR(CHXREC ,"E05a"))
  39463   "RTN","CHM XPU03",56, 0)
  39464    I '$D(RCD ) S CHEDPR B="",CHPRB =CHEDRJ Q
  39465   "RTN","CHM XPU03",57, 0)
  39466    S CHBTQLF =$$GETPOSQ AL(RCD)
  39467   "RTN","CHM XPU03",58, 0)
  39468    Q:'(CHBTQ LF="A")  ; THIS EDIT  ONLY APPLI ES TO INST UTIONAL CL AIMS
  39469   "RTN","CHM XPU03",59, 0)
  39470    IF $D(CHF LD(CHFLPN) ) {
  39471   "RTN","CHM XPU03",60, 0)
  39472     SET POS  = CHFLD(CH FLPN)
  39473   "RTN","CHM XPU03",61, 0)
  39474    }ELSE{
  39475   "RTN","CHM XPU03",62, 0)
  39476     SET POS= ""
  39477   "RTN","CHM XPU03",63, 0)
  39478    }
  39479   "RTN","CHM XPU03",64, 0)
  39480    I (POS="" )||'$D(^CH MXDIC(7412 01.03,"B", POS)) D RC DERR^CHMXP U01
  39481   "RTN","CHM XPU03",65, 0)
  39482    Q
  39483   "RTN","CHM XPU03",66, 0)
  39484    ; 
  39485   "RTN","CHM XPU03",67, 0)
  39486    ; PLACE O F SERVCE C ODE MUST M ATCH A COD E FROM LIS T OF VALID  PLACES OF  SERVCE
  39487   "RTN","CHM XPU03",68, 0)
  39488    ; THIS SU B ROUTINE  ONLY APPLI ES TO PROF ESSIONAL O R DENTAL C LAIMS.
  39489   "RTN","CHM XPU03",69, 0)
  39490   BTPOS ; 
  39491   "RTN","CHM XPU03",70, 0)
  39492    NEW CHBTQ LF, POS
  39493   "RTN","CHM XPU03",71, 0)
  39494    Q:$D(CHRC ERR(CHXREC ,"E04c"))
  39495   "RTN","CHM XPU03",72, 0)
  39496    I '$D(RCD ) S CHEDPR B="",CHPRB =CHEDRJ Q
  39497   "RTN","CHM XPU03",73, 0)
  39498    S CHBTQLF =$$GETPOSQ AL(RCD)
  39499   "RTN","CHM XPU03",74, 0)
  39500    Q:'((CHBT QLF="B")|| (CHBTQLF=" C"))   ;TH IS EDIT ON LY APPLIES  TO PROF O R DENTAL C LAIMS
  39501   "RTN","CHM XPU03",75, 0)
  39502    IF $D(CHF LD(CHFLPN) ) {
  39503   "RTN","CHM XPU03",76, 0)
  39504     SET POS  = CHFLD(CH FLPN)
  39505   "RTN","CHM XPU03",77, 0)
  39506    }ELSE{
  39507   "RTN","CHM XPU03",78, 0)
  39508     SET POS= ""
  39509   "RTN","CHM XPU03",79, 0)
  39510    }
  39511   "RTN","CHM XPU03",80, 0)
  39512    I (POS=41 )!(POS=42)  S ^RREC($ J,"E026")= ""      D  DEBUG^CHMX DR01("POS  REQUIRES E 026 REC FL AG SET",PO S)                    ; PROF AMB ULATORY PO S CODE REQ UIRES E206  RECORD
  39513   "RTN","CHM XPU03",81, 0)
  39514    I (POS="" )||'$D(^CH MXDIC(7412 01.59,"B", POS)) D RC DERR^CHMXP U01
  39515   "RTN","CHM XPU03",82, 0)
  39516    ;I '$D(RC D) S CHEDP RB="",CHPR B=CHEDRJ G  BTPOS1
  39517   "RTN","CHM XPU03",83, 0)
  39518    ;S:CHX12V RS=1 CHZZB EG=44
  39519   "RTN","CHM XPU03",84, 0)
  39520    ;S:CHX12V RS=2 CHZZB EG=45
  39521   "RTN","CHM XPU03",85, 0)
  39522    ;S Y=$E(R CD,CHZZBEG ,CHZZBEG), CHBTQLF=$$ TRIM^CHMXP U01(Y) I C HBTQLF=""  S CHEDRJHL =CHEDRJ,CH EDRJ="E05a " D RCDERR ^CHMXPU01  S CHEDRJ=C HEDRJHL G  BTPOS1
  39523   "RTN","CHM XPU03",86, 0)
  39524    ;I (CHBTQ LF="A")&(' $D(^CHMXDI C(741201.0 3,"B",CHFL D(CHFLPN)) )) D RCDER R^CHMXPU01  G BTPOS1
  39525   "RTN","CHM XPU03",87, 0)
  39526    ;I (CHBTQ LF="B")&(' $D(^CHMXDI C(741201.5 9,"B",CHFL D(CHFLPN)) )) S CHEDR J="E04c" D  RCDERR^CH MXPU01 G B TPOS1
  39527   "RTN","CHM XPU03",88, 0)
  39528    ;I (CHBTQ LF="C")&(' $D(^CHMXDI C(741201.5 9,"B",CHFL D(CHFLPN)) )) S CHEDR J="E04c" D  RCDERR^CH MXPU01 G B TPOS1
  39529   "RTN","CHM XPU03",89, 0)
  39530    Q
  39531   "RTN","CHM XPU03",90, 0)
  39532    ; 
  39533   "RTN","CHM XPU03",91, 0)
  39534    ; 
  39535   "RTN","CHM XPU03",92, 0)
  39536    ;Methodic al-5010 Ch ange-Begin
  39537   "RTN","CHM XPU03",93, 0)
  39538   BTPOSD  ;  Validate D ental plac e of servi ce codes
  39539   "RTN","CHM XPU03",94, 0)
  39540    NEW CHBTQ LF,POS
  39541   "RTN","CHM XPU03",95, 0)
  39542    I '$D(RCD ) S CHEDPR B="",CHPRB =CHEDRJ Q
  39543   "RTN","CHM XPU03",96, 0)
  39544    S CHBTQLF =$$GETPOSQ AL(RCD)
  39545   "RTN","CHM XPU03",97, 0)
  39546    Q:'(CHBTQ LF="C") ;T HIS EDIT O NLY APPLIE S TO DENTA L CLAIMS
  39547   "RTN","CHM XPU03",98, 0)
  39548    IF $D(CHF LD(CHFLPN) ) {
  39549   "RTN","CHM XPU03",99, 0)
  39550     SET POS  = CHFLD(CH FLPN)
  39551   "RTN","CHM XPU03",100 ,0)
  39552    }ELSE{
  39553   "RTN","CHM XPU03",101 ,0)
  39554     SET POS= ""
  39555   "RTN","CHM XPU03",102 ,0)
  39556    }
  39557   "RTN","CHM XPU03",103 ,0)
  39558    I POS=""  D RCDERR^C HMXPU01 Q
  39559   "RTN","CHM XPU03",104 ,0)
  39560    ;POS for  dent
  39561   "RTN","CHM XPU03",105 ,0)
  39562    I POS="01 "!(POS="25 ")!(POS="4 1")!(POS=" 42") D RCD ERR^CHMXPU 01
  39563   "RTN","CHM XPU03",106 ,0)
  39564    Q
  39565   "RTN","CHM XPU03",107 ,0)
  39566    ;Methodic al-5010 Ch ange-End
  39567   "RTN","CHM XPU03",108 ,0)
  39568    ; 
  39569   "RTN","CHM XPU03",109 ,0)
  39570    ; GIVEN T HE "E000"  RECORD WIL L RETURN T HE PLACE O F SERVICE  QUALIFIER
  39571   "RTN","CHM XPU03",110 ,0)
  39572    ; RETURNS : "A" - IN STITUTIONA L
  39573   "RTN","CHM XPU03",111 ,0)
  39574    ;           "B" - PR OFESSIONAL
  39575   "RTN","CHM XPU03",112 ,0)
  39576    ;           "C" - DE NTAL
  39577   "RTN","CHM XPU03",113 ,0)
  39578    ;           ""  - UN DETERMIED  OR NOT PAS SED IN THE  "E000" RE CORD
  39579   "RTN","CHM XPU03",114 ,0)
  39580    ;
  39581   "RTN","CHM XPU03",115 ,0)
  39582    ;  Commen t by MI/JS  on 15-Nov -2011:
  39583   "RTN","CHM XPU03",116 ,0)
  39584    ;  ------ ---------- ---------- ------
  39585   "RTN","CHM XPU03",117 ,0)
  39586    ;  The Pl ace of Ser vice quali fier does  no longer  determine  the claim  type, sinc e both Pro fessional  and Dental
  39587   "RTN","CHM XPU03",118 ,0)
  39588    ;  claims  are now i ndicated w ith B (no  longer C f or dental) .  The fol lowing rou tine was c hanged to  determine
  39589   "RTN","CHM XPU03",119 ,0)
  39590    ;  the cl aim type c orrectly b y calling  an appropr iate funct ion in the  CHMXP010  routine. A lso, this  function
  39591   "RTN","CHM XPU03",120 ,0)
  39592    ;  will n ot return  a null str ing any lo nger.
  39593   "RTN","CHM XPU03",121 ,0)
  39594    ;
  39595   "RTN","CHM XPU03",122 ,0)
  39596   GETPOSQAL( RCD)
  39597   "RTN","CHM XPU03",123 ,0)
  39598    ;Methodic al-5010 Ch ange-Begin
  39599   "RTN","CHM XPU03",124 ,0)
  39600    Q $$CLMTY PE^CHMXP01 0()
  39601   "RTN","CHM XPU03",125 ,0)
  39602    ;Methodic al-5010 Ch ange-End
  39603   "RTN","CHM XPU03",126 ,0)
  39604    NEW CHZZB EG,QLF,RTN  
  39605   "RTN","CHM XPU03",127 ,0)
  39606    ;RETURN N ULL IF NUL L IS PASSE D IN OR RC D IS NOT T HE E000 RE CORD
  39607   "RTN","CHM XPU03",128 ,0)
  39608    Q:($E(RCD ,1,4)'="E0 00") ""
  39609   "RTN","CHM XPU03",129 ,0)
  39610    S:CHX12VR S=1 CHZZBE G=44
  39611   "RTN","CHM XPU03",130 ,0)
  39612    ;Methodic al-5010 Ch ange-Begin
  39613   "RTN","CHM XPU03",131 ,0)
  39614    S:(CHX12V RS=2)!(CHX 12VRS=3) C HZZBEG=45
  39615   "RTN","CHM XPU03",132 ,0)
  39616    ;Methodic al-5010 Ch ange-End
  39617   "RTN","CHM XPU03",133 ,0)
  39618    S QLF=$E( RCD,CHZZBE G,CHZZBEG)
  39619   "RTN","CHM XPU03",134 ,0)
  39620    S RTN=$$T RIM^CHMXPU 01(QLF)
  39621   "RTN","CHM XPU03",135 ,0)
  39622    ; RETURN  NULL IF NO T A RECOGN IZED FACIL ITY TYPE
  39623   "RTN","CHM XPU03",136 ,0)
  39624    IF '((RTN ="A")||(RT N="B")||(R TN="C")) {
  39625   "RTN","CHM XPU03",137 ,0)
  39626     S RTN=""
  39627   "RTN","CHM XPU03",138 ,0)
  39628    }
  39629   "RTN","CHM XPU03",139 ,0)
  39630    Q RTN
  39631   "RTN","CHM XPU03",140 ,0)
  39632    ; 
  39633   "RTN","CHM XPU03",141 ,0)
  39634    ; 
  39635   "RTN","CHM XPU03",142 ,0)
  39636   BTPROC ;IF  QUALIFIER ="A" FOR B ILL TYPE,  CHECK TO S EE IF IT I S A BILL T YPE HAC
  39637   "RTN","CHM XPU03",143 ,0)
  39638    ;IS PROCE SSING
  39639   "RTN","CHM XPU03",144 ,0)
  39640    Q:$D(CHRC ERR(CHXREC ,"E04a"))   Q:$D(CHRC ERR(CHXREC ,"E05"))
  39641   "RTN","CHM XPU03",145 ,0)
  39642    D BTQLF I  $D(CHEDPR B) S CHPRB =CHEDRJ G  BTPROC1
  39643   "RTN","CHM XPU03",146 ,0)
  39644    Q:CHBTQLF '="A"
  39645   "RTN","CHM XPU03",147 ,0)
  39646    I (CHBTQL F="A")&('$ D(^CHMXDIC (741201.03 ,"C",1,CHF LD(CHFLPN) ))) D RCDE RR^CHMXPU0 1 G BTPROC 1
  39647   "RTN","CHM XPU03",148 ,0)
  39648   BTPROC1 K  CHBTQLF Q
  39649   "RTN","CHM XPU03",149 ,0)
  39650    ; 
  39651   "RTN","CHM XPU03",150 ,0)
  39652   FREQA ;CHE CK FOR PRE SENCE OF C LAIM FREQE NCY GIVEN  CERTAIN CO NDITIONS
  39653   "RTN","CHM XPU03",151 ,0)
  39654    Q:$D(CHRC ERR(CHXREC ,"E05a"))   Q:$D(CHRC ERR(CHXREC ,"E05b"))
  39655   "RTN","CHM XPU03",152 ,0)
  39656    D GETIC I  $D(CHEDPR B) S CHPRB =CHEDRJ G  FREQA1
  39657   "RTN","CHM XPU03",153 ,0)
  39658    D BTQLF I  $D(CHEDPR B) S CHPRB =CHEDRJ G  FREQA1
  39659   "RTN","CHM XPU03",154 ,0)
  39660    Q:CHBTQLF '="A"
  39661   "RTN","CHM XPU03",155 ,0)
  39662    I ((CHICT P="HOSP")! (CHBTQLF=" A"))&(CHFL D(CHFLPN)= "") D RCDE RR^CHMXPU0 1 G FREQA1
  39663   "RTN","CHM XPU03",156 ,0)
  39664   FREQA1 K C HICTP,CHBT QLF Q
  39665   "RTN","CHM XPU03",157 ,0)
  39666    ; 
  39667   "RTN","CHM XPU03",158 ,0)
  39668   FREQB ;COD E VALIDATI ON FOR CLA IM FREQUEN CY
  39669   "RTN","CHM XPU03",159 ,0)
  39670    Q:$D(CHRC ERR(CHXREC ,"E06a"))   Q:$D(CHRC ERR(CHXREC ,"E05a"))   Q:$D(CHRC ERR(CHXREC ,"E05b"))
  39671   "RTN","CHM XPU03",160 ,0)
  39672    D GETIC I  $D(CHEDPR B) S CHPRB =CHEDRJ G  FREQA1
  39673   "RTN","CHM XPU03",161 ,0)
  39674    D BTQLF I  $D(CHEDPR B) S CHPRB =CHEDRJ G  FREQB1
  39675   "RTN","CHM XPU03",162 ,0)
  39676    Q:CHBTQLF '="A"
  39677   "RTN","CHM XPU03",163 ,0)
  39678    I ((CHICT P="HOSP")! (CHBTQLF=" A"))&('$D( ^CHMXDIC(7 41201.05," B",CHFLD(C HFLPN))))  D RCDERR^C HMXPU01 G  FREQB1
  39679   "RTN","CHM XPU03",164 ,0)
  39680   FREQB1 K C HICTP,CHBT QLF Q
  39681   "RTN","CHM XPU03",165 ,0)
  39682    ; 
  39683   "RTN","CHM XPU03",166 ,0)
  39684   FREQC ;
  39685   "RTN","CHM XPU03",167 ,0)
  39686    Q
  39687   "RTN","CHM XPU03",168 ,0)
  39688    N CHMOPDI ,CHFREQ
  39689   "RTN","CHM XPU03",169 ,0)
  39690    S CHMOPDI =$P(^CHMXC LE(CHCLEI, 0),"^",2)
  39691   "RTN","CHM XPU03",170 ,0)
  39692    Q:'$G(CHM OPDI)
  39693   "RTN","CHM XPU03",171 ,0)
  39694    S CHFREQ= CHFLD(3)
  39695   "RTN","CHM XPU03",172 ,0)
  39696    Q:CHFREQ' =8
  39697   "RTN","CHM XPU03",173 ,0)
  39698    I $D(^CHM IMG("OCRR- READY",CHM FOPDI)) K  ^CHMIMG("O CRR-READY" ,CHMFOPDI)  D RCDERR^ CHMXPU01 Q
  39699   "RTN","CHM XPU03",174 ,0)
  39700    I $D(^CHM IMG("SBOCR R-READY",C HMFOPDI))  K ^CHMIMG( "SBOCRR-RE ADY",CHMFO PDI) D RCD ERR^CHMXPU 01 Q
  39701   "RTN","CHM XPU03",175 ,0)
  39702   FREQC1  Q
  39703   "RTN","CHM XPU03",176 ,0)
  39704    ;
  39705   "RTN","CHM XPU03",177 ,0)
  39706    ;Methodic al-5010 Ch ange-Begin  - Validat a Frequenc y Code
  39707   "RTN","CHM XPU03",178 ,0)
  39708   FREQE ;FRE QECODE VAL IDATION FO R CLAIM FR EQUENCY fo r Dental a nd Opt
  39709   "RTN","CHM XPU03",179 ,0)
  39710    D DEBUG^C HMXDR01("C HMXPU03: F REQE CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  39711   "RTN","CHM XPU03",180 ,0)
  39712    Q:CHFLD(C HFLPN)=""
  39713   "RTN","CHM XPU03",181 ,0)
  39714    I ('$D(^C HMXDIC(741 201.05,"C" ,1,CHFLD(C HFLPN))))  D RCDERR^C HMXPU01 
  39715   "RTN","CHM XPU03",182 ,0)
  39716    Q
  39717   "RTN","CHM XPU03",183 ,0)
  39718    ;Methodic al-5010 Ch ange-End 
  39719   "RTN","CHM XPU03",184 ,0)
  39720    ;
  39721   "RTN","CHM XPU03",185 ,0)
  39722   FREQF ;BDB  1/16/19 C PE005-039;  Reject al l Frequenc y Code 6
  39723   "RTN","CHM XPU03",186 ,0)
  39724    ;Called f rom the E0 15 node of  #741211.0 3 X12 837  V5010 CLAI M RECORD L AYOUT 
  39725   "RTN","CHM XPU03",187 ,0)
  39726    N CHFREQ, CHMFOPDI
  39727   "RTN","CHM XPU03",188 ,0)
  39728    S CHMFOPD I=CHFLD(CH FLPN)
  39729   "RTN","CHM XPU03",189 ,0)
  39730    Q:CHMFOPD I=""
  39731   "RTN","CHM XPU03",190 ,0)
  39732    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  39733   "RTN","CHM XPU03",191 ,0)
  39734    Q:CHFREQ' =6
  39735   "RTN","CHM XPU03",192 ,0)
  39736    S CHRCERR (CHXREC,"E 06b")="",C HLVLRJ("E" )=""
  39737   "RTN","CHM XPU03",193 ,0)
  39738    ;D CSTAT^ CHMXPUTL(C HMFOPDI,"A 7:21:464")
  39739   "RTN","CHM XPU03",194 ,0)
  39740    Q
  39741   "RTN","CHM XPU03",195 ,0)
  39742    ;  
  39743   "RTN","CHM XPU03",196 ,0)
  39744   BALDUE ;PA TIENT BALA NCE DUE MU ST NOT BE  > TOTAL CH ARGES
  39745   "RTN","CHM XPU03",197 ,0)
  39746    Q:$D(CHRC ERR(CHXREC ,"E21a"))   Q:$D(CHRC ERR(CHXREC ,"E23a"))
  39747   "RTN","CHM XPU03",198 ,0)
  39748    I '$D(RCD ) S CHEDPR B="",CHPRB =CHEDRJ G  BALDUE1
  39749   "RTN","CHM XPU03",199 ,0)
  39750    S:CHX12VR S=1 CHZZBE G=5,CHZZEN D=19
  39751   "RTN","CHM XPU03",200 ,0)
  39752    ;Methodic al-5010 Ch ange-Begin
  39753   "RTN","CHM XPU03",201 ,0)
  39754    S:(CHX12V RS=2)!(CHX 12VRS=3) C HZZBEG=5,C HZZEND=22
  39755   "RTN","CHM XPU03",202 ,0)
  39756    ;Methodic al-5010 Ch ange-End
  39757   "RTN","CHM XPU03",203 ,0)
  39758    S:CHX12VR S=1 CHTOT= +($E(RCD,C HZZBEG,CHZ ZEND)/100)
  39759   "RTN","CHM XPU03",204 ,0)
  39760    ;Methodic al-5010 Ch ange-Begin
  39761   "RTN","CHM XPU03",205 ,0)
  39762    S:(CHX12V RS=2)!(CHX 12VRS=3) C HTOT=+($E( RCD,CHZZBE G,CHZZEND) )
  39763   "RTN","CHM XPU03",206 ,0)
  39764    ;Methodic al-5010 Ch ange-End
  39765   "RTN","CHM XPU03",207 ,0)
  39766    I CHTOT=" " S CHEDPR B="",CHPRB =CHEDRJ G  BALDUE1
  39767   "RTN","CHM XPU03",208 ,0)
  39768    I (+(CHFL D(CHFLPN)) )>CHTOT D  RCDERR^CHM XPU01 G BA LDUE1
  39769   "RTN","CHM XPU03",209 ,0)
  39770   BALDUE1 K  CHZZBEG,CH ZZEND,CHTO T Q
  39771   "RTN","CHM XPU03",210 ,0)
  39772    ; 
  39773   "RTN","CHM XPU03",211 ,0)
  39774   PTDCDP ;CH ECK PRESEN CE OF DISC HARGE STAT US (COND:   BILL TYPE =11/12 OR  IC=HOSP)
  39775   "RTN","CHM XPU03",212 ,0)
  39776    D GETIC I  $D(CHEDPR B) S CHPRB =CHEDRJ G  PTDCDP1
  39777   "RTN","CHM XPU03",213 ,0)
  39778    D RBTQLF  I $D(CHEDP RB) S CHPR B=CHEDRJ G  PTDCDP1
  39779   "RTN","CHM XPU03",214 ,0)
  39780    Q:CHBTQLF '="A"
  39781   "RTN","CHM XPU03",215 ,0)
  39782    ;I ((CHIC TP="HOSP") !(CHBTQLF= "A"))&('$D (CHFLD(CHF LPN))) D R CDERR^CHMX PU01 G PTD CDP1
  39783   "RTN","CHM XPU03",216 ,0)
  39784    I ($D(^CH MXDIC(7412 01.03,"D", 1,CHBTYP)) )&('$D(CHF LD(CHFLPN) )) D RCDER R^CHMXPU01  G PTDCDP1
  39785   "RTN","CHM XPU03",217 ,0)
  39786   PTDCDP1 K  CHICTP,CHB TQLF,CHTYP B Q
  39787   "RTN","CHM XPU03",218 ,0)
  39788    ; 
  39789   "RTN","CHM XPU03",219 ,0)
  39790   PTDCDV ;CH ECK VALIDI TY OF DISC HARGE STAT US (COND:  BILL TYPE= 11/12 OR I C=HOSP)
  39791   "RTN","CHM XPU03",220 ,0)
  39792    Q:CHFLD(C HFLPN)=""
  39793   "RTN","CHM XPU03",221 ,0)
  39794    ;Methodic al-5010 Ch ange-Begin   - Commen t out this  code
  39795   "RTN","CHM XPU03",222 ,0)
  39796      ;Q:$D(C HRCERR(CHX REC,"E31") )
  39797   "RTN","CHM XPU03",223 ,0)
  39798    ;Methodic al-5010 Ch ange-End 
  39799   "RTN","CHM XPU03",224 ,0)
  39800    D GETIC I  $D(CHEDPR B) S CHPRB =CHEDRJ G  PTDCDV1
  39801   "RTN","CHM XPU03",225 ,0)
  39802    D RBTQLF  I $D(CHEDP RB) S CHPR B=CHEDRJ G  PTDCDV1
  39803   "RTN","CHM XPU03",226 ,0)
  39804    Q:CHBTQLF '="A"
  39805   "RTN","CHM XPU03",227 ,0)
  39806    I ((CHICT P="HOSP")! (CHBTQLF=" A"))&('$D( ^CHMDIC(74 1002.12,"B ",CHFLD(CH FLPN)))) D  RCDERR^CH MXPU01 G P TDCDV1
  39807   "RTN","CHM XPU03",228 ,0)
  39808   PTDCDV1 K  CHICTP,CHB TQLF,CHTYP B Q
  39809   "RTN","CHM XPU03",229 ,0)
  39810    ;
  39811   "RTN","CHM XPU03",230 ,0)
  39812   PTDCBT ;IF  BILL FREQ  = 1 OR 4,  PATIENT S TATUS MUST  EQUAL DIS CHARGE FRO M INST.
  39813   "RTN","CHM XPU03",231 ,0)
  39814    Q:CHFLD(C HFLPN)=""
  39815   "RTN","CHM XPU03",232 ,0)
  39816    Q:$D(CHRC ERR(CHXREC ,"E31a"))   I '$D(^CH MXCLE(CHCL EI,0)) S C HEDPRB="", CHPRB=CHED RJ G PTDCB T1
  39817   "RTN","CHM XPU03",233 ,0)
  39818    ;S CHFREQ =$P(^CHMXC LE(CHCLEI, 0),"^",6)
  39819   "RTN","CHM XPU03",234 ,0)
  39820    ;I CHFREQ ="" S CHED PRB="",CHP RB=CHEDRJ  G PTDCBT1
  39821   "RTN","CHM XPU03",235 ,0)
  39822    ;I ((CHFR EQ=1)!(CHF REQ=4))&(' $D(^CHMDIC (741002.12 ,"D",1,CHF LD(CHFLPN) ))) D RCDE RR^CHMXPU0 1 G PTDCBT 1
  39823   "RTN","CHM XPU03",236 ,0)
  39824    D GETIC I  $D(CHEDPR B) S CHPRB =CHEDRJ G  PTDCDP1
  39825   "RTN","CHM XPU03",237 ,0)
  39826    D RBTQLF  I $D(CHEDP RB) S CHPR B=CHEDRJ G  PTDCDP1
  39827   "RTN","CHM XPU03",238 ,0)
  39828    Q:CHBTQLF '="A"
  39829   "RTN","CHM XPU03",239 ,0)
  39830    ;I ((CHIC TP="HOSP") !(CHBTQLF= "A"))&('$D (CHFLD(CHF LPN))) D R CDERR^CHMX PU01 G PTD CDP1
  39831   "RTN","CHM XPU03",240 ,0)
  39832    I ($D(^CH MXDIC(7412 01.03,"E", 1,CHBTYP)) )&('$D(CHF LD(CHFLPN) )) D RCDER R^CHMXPU01  G PTDCBT1
  39833   "RTN","CHM XPU03",241 ,0)
  39834   PTDCBT1 K  CHBTYP Q
  39835   "RTN","CHM XPU03",242 ,0)
  39836    ; 
  39837   "RTN","CHM XPU03",243 ,0)
  39838   NHRSP ;CHE CK PRESENC E OF NH RE SIDENTIAL  STATUS (CO ND: PI=FEE )
  39839   "RTN","CHM XPU03",244 ,0)
  39840    D GETPI I  $D(CHEDPR B) S CHPRB =CHEDRJ G  NHRSP1
  39841   "RTN","CHM XPU03",245 ,0)
  39842    I (CHPI=" VA741-FEE" )&(CHFLD(C HFLPN)="")  D RCDERR^ CHMXPU01 G  NHRSP1
  39843   "RTN","CHM XPU03",246 ,0)
  39844   NHRSP1 K C HPI Q
  39845   "RTN","CHM XPU03",247 ,0)
  39846    ; 
  39847   "RTN","CHM XPU03",248 ,0)
  39848   NHRSV ;VAL IDATE NH R ESIDENTIAL  STATUS CO DE (COND:   PI=FEE)
  39849   "RTN","CHM XPU03",249 ,0)
  39850    Q:$D(CHRC ERR(CHXREC ,"E32"))   Q:CHFLD(CH FLPN)=""
  39851   "RTN","CHM XPU03",250 ,0)
  39852    D GETPI I  $D(CHEDPR B) S CHPRB =CHEDRJ G  NHRSV1
  39853   "RTN","CHM XPU03",251 ,0)
  39854    I (CHPI=" VA741-FEE" )&('$D(^CH MXDIC(7412 01.09,"B", CHFLD(CHFL PN)))) D R CDERR^CHMX PU01 G NHR SV1
  39855   "RTN","CHM XPU03",252 ,0)
  39856   NHRSV1 K C HPI Q
  39857   "RTN","CHM XPU03",253 ,0)
  39858    ; 
  39859   "RTN","CHM XPU03",254 ,0)
  39860   GETIC ;PUL LS IMP CON V TYPE FRO M HEADER G LOBAL
  39861   "RTN","CHM XPU03",255 ,0)
  39862    I '$D(^CH MXCLA(CHCL AI,0)) S C HEDPRB=""  Q
  39863   "RTN","CHM XPU03",256 ,0)
  39864    S CHICTP= $E($P(^CHM XCLA(CHCLA I,0),"^",1 4),7,99)
  39865   "RTN","CHM XPU03",257 ,0)
  39866    Q:CHICTP= ""
  39867   "RTN","CHM XPU03",258 ,0)
  39868    Q
  39869   "RTN","CHM XPU03",259 ,0)
  39870    ; 
  39871   "RTN","CHM XPU03",260 ,0)
  39872   BTQLF ;PUL LS BILL TY PE QUALIFI ER FROM RE CORD JUST  READ
  39873   "RTN","CHM XPU03",261 ,0)
  39874    I '$D(RCD ) S CHEDPR B="",CHPRB =CHEDRJ G  FREQA1
  39875   "RTN","CHM XPU03",262 ,0)
  39876    S:CHX12VR S=1 CHZZBE G=44,CHZZE ND=44
  39877   "RTN","CHM XPU03",263 ,0)
  39878    ;Methodic al-5010 Ch ange-Begin
  39879   "RTN","CHM XPU03",264 ,0)
  39880    S:(CHX12V RS=2)!(CHX 12VRS=3) C HZZBEG=45, CHZZEND=45
  39881   "RTN","CHM XPU03",265 ,0)
  39882    ;Methodic al-5010 Ch ange-End
  39883   "RTN","CHM XPU03",266 ,0)
  39884    S Y=$E(RC D,CHZZBEG, CHZZEND),C HBTQLF=$$T RIM^CHMXPU 01(Y) I CH BTQLF="" S  CHEDPRB=" " G BTQLF1
  39885   "RTN","CHM XPU03",267 ,0)
  39886   BTQLF1 K C HZZBEG,CHZ ZEND Q
  39887   "RTN","CHM XPU03",268 ,0)
  39888    ; 
  39889   "RTN","CHM XPU03",269 ,0)
  39890   RBTQLF ;PU LLS BILL T YPE QUALIF IER FROM S UBMISSION  GLOBAL
  39891   "RTN","CHM XPU03",270 ,0)
  39892    I '$D(^CH MXCLE(CHCL EI,0)) S C HEDPRB=""  Q
  39893   "RTN","CHM XPU03",271 ,0)
  39894    S CHBTQLF =$P(^CHMXC LE(CHCLEI, 0),"^",5)  S:CHBTQLF= "" CHBTQLF ="B"
  39895   "RTN","CHM XPU03",272 ,0)
  39896    I CHBTQLF ="B" S CHT YPB="" G R BTQLF1
  39897   "RTN","CHM XPU03",273 ,0)
  39898    S CHBTYP= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  39899   "RTN","CHM XPU03",274 ,0)
  39900   RBTQLF1 Q
  39901   "RTN","CHM XPU03",275 ,0)
  39902    ; 
  39903   "RTN","CHM XPU03",276 ,0)
  39904   GETPI ;PUL LS PROG IN D FROM HEA DER GLOBAL
  39905   "RTN","CHM XPU03",277 ,0)
  39906    Q:'$D(^CH MXCLA(CHCL AI,1))
  39907   "RTN","CHM XPU03",278 ,0)
  39908    S CHPI=$P (^CHMXCLA( CHCLAI,1), "^",5)
  39909   "RTN","CHM XPU03",279 ,0)
  39910   GETPI1 Q
  39911   "RTN","CHM XPU03",280 ,0)
  39912    ; 
  39913   "RTN","CHM XPU03",281 ,0)
  39914   TRSTYP ;VA LIDATES TH E V4010 TR ANSACTION  TYPE ID 
  39915   "RTN","CHM XPU03",282 ,0)
  39916    I '$D(CHF LD(CHFLPN) ) D RCDERR ^CHMXPU01  G TRSTYP1
  39917   "RTN","CHM XPU03",283 ,0)
  39918    ;Methodic al-5010 Ch ange-Begin
  39919   "RTN","CHM XPU03",284 ,0)
  39920    I CHX12VR S=2 I (CHF LD(CHFLPN) '["4010X09 6")&(CHFLD (CHFLPN)'[ "4010X097" )&(CHFLD(C HFLPN)'["4 010X098")& (CHFLD(CHF LPN)'["401 0OCRB")&(C HFLD(CHFLP N)'["4010O CRA") D RC DERR^CHMXP U01 G TRST YP1
  39921   "RTN","CHM XPU03",285 ,0)
  39922    ;222 = Pr ofessional  223=Insti tutional   224= Denta l
  39923   "RTN","CHM XPU03",286 ,0)
  39924    I CHX12VR S=3 I (CHF LD(CHFLPN) '["5010X22 2")&(CHFLD (CHFLPN)'[ "5010X223" )&(CHFLD(C HFLPN)'["5 010X224")  D RCDERR^C HMXPU01 G  TRSTYP1
  39925   "RTN","CHM XPU03",287 ,0)
  39926    ;Methodic al-5010 Ch ange-End
  39927   "RTN","CHM XPU03",288 ,0)
  39928   TRSTYP1 Q
  39929   "RTN","CHM XPU03",289 ,0)
  39930    ;
  39931   "RTN","CHM XPU03",290 ,0)
  39932    ;Methodic al-5010 Ch ange-Begin
  39933   "RTN","CHM XPU03",291 ,0)
  39934   AMBINFO ;C heck that  AMB inform ation exis ts if POS=  41 or 42
  39935   "RTN","CHM XPU03",292 ,0)
  39936    ;
  39937   "RTN","CHM XPU03",293 ,0)
  39938    K ^RREC($ J,"E026")                                                  ; FLAG  "E026" RE CORD WAS N OT MISSING
  39939   "RTN","CHM XPU03",294 ,0)
  39940    D DEBUG^C HMXDR01("C HMXPU03: A MBINFO: CH FLD(CHFLPN )= ",CHFLD (CHFLPN))
  39941   "RTN","CHM XPU03",295 ,0)
  39942    N POS S P OS=$P(^CHM XCLE(CHCLE I,0),"^",4 )
  39943   "RTN","CHM XPU03",296 ,0)
  39944    D DEBUG^C HMXDR01("C HMXPU03: A MBINFO: PO S= ",POS)
  39945   "RTN","CHM XPU03",297 ,0)
  39946    Q:POS'=41 &(POS'=42)                                        ; Mu st have PO S of 41 or  42
  39947   "RTN","CHM XPU03",298 ,0)
  39948    I (CHFLD( CHFLPN)'=" ") Q                  ;DEF019402  FE Edit i ncorrectly  returned  a claim   
  39949   "RTN","CHM XPU03",299 ,0)
  39950    ;I (CHFLD (CHFLPN)>0 ) Q                                'If  POS  = 41 or 4 2 and POS  QUALIFIER  = "" then  reject in  front end  with an Am bulance Tr ansport In formation  Reason (23 00 CR104)
  39951   "RTN","CHM XPU03",300 ,0)
  39952    D RCDERR^ CHMXPU01
  39953   "RTN","CHM XPU03",301 ,0)
  39954    Q
  39955   "RTN","CHM XPU03",302 ,0)
  39956    ;Methodic al-5010 Ch ange-End
  39957   "RTN","CHM XPU03",303 ,0)
  39958    
  39959   "RTN","CHM XPU03",304 ,0)
  39960   SUBMRSN ;  For Profes sion claim s the clai m submissi on must be  PB
  39961   "RTN","CHM XPU03",305 ,0)
  39962    ;
  39963   "RTN","CHM XPU03",306 ,0)
  39964    ;Methodic al-5010 Ch ange-Begin
  39965   "RTN","CHM XPU03",307 ,0)
  39966    Q:$$CLMTY PE^CHMXP01 0()'="C"   ; Applies  only to De ntal claim s
  39967   "RTN","CHM XPU03",308 ,0)
  39968    ;Methodic al-5010 Ch ange-End
  39969   "RTN","CHM XPU03",309 ,0)
  39970    I CHFLD(C HFLPN)="PB " D RCDERR ^CHMXPU01
  39971   "RTN","CHM XPU03",310 ,0)
  39972    Q
  39973   "RTN","CHM XPU03",311 ,0)
  39974    
  39975   "RTN","CHM XPU03",312 ,0)
  39976   QUALER ;ch eck for In valid qual ifier code  of "ER" f or profess ional clai ms
  39977   "RTN","CHM XPU03",313 ,0)
  39978    ;Methodic al-5010 Ch ange-Begin
  39979   "RTN","CHM XPU03",314 ,0)
  39980    ; FILETYP E=
  39981   "RTN","CHM XPU03",315 ,0)
  39982    ; "A" - I NSTITUTION AL
  39983   "RTN","CHM XPU03",316 ,0)
  39984    ; "B" - P ROFESSIONA L
  39985   "RTN","CHM XPU03",317 ,0)
  39986    ; "C" - D ENTAL
  39987   "RTN","CHM XPU03",318 ,0)
  39988    I CHFLD(C HFLPN)="ER " D RCDERR ^CHMXPU01
  39989   "RTN","CHM XPU03",319 ,0)
  39990    Q
  39991   "RTN","CHM XPU03",320 ,0)
  39992     ;Methodi cal-5010 C hange-End
  39993   "RTN","CHM XPU03",321 ,0)
  39994    
  39995   "RTN","CHM XPU03",322 ,0)
  39996   QUALIV ;ch eck for In valid qual ifier code  of "IV" f or profess ional clai ms
  39997   "RTN","CHM XPU03",323 ,0)
  39998    ;Methodic al-5010 Ch ange-Begin
  39999   "RTN","CHM XPU03",324 ,0)
  40000    ; "A" - I NSTITUTION AL
  40001   "RTN","CHM XPU03",325 ,0)
  40002    ; "B" - P ROFESSIONA L
  40003   "RTN","CHM XPU03",326 ,0)
  40004    ; "C" - D ENTAL
  40005   "RTN","CHM XPU03",327 ,0)
  40006    I CHFLD(C HFLPN)="IV " D RCDERR ^CHMXPU01
  40007   "RTN","CHM XPU03",328 ,0)
  40008    Q
  40009   "RTN","CHM XPU03",329 ,0)
  40010     ;Methodi cal-5010 C hange-End
  40011   "RTN","CHM XPU03",330 ,0)
  40012    ;
  40013   "RTN","CHM XPU03",331 ,0)
  40014   QUALST ; L EG - imbed ded to wor k around 
  40015   "RTN","CHM XPU03",332 ,0)
  40016    ;     Err or has occ urred <NOL INE> in DE V at 12:48  PM  Oct 1 9 2017
  40017   "RTN","CHM XPU03",333 ,0)
  40018    Q 
  40019   "RTN","CHM XPU03",334 ,0)
  40020    ;  
  40021   "RTN","CHM XPU03",335 ,0)
  40022   QUALWK ;ch eck for In valid qual ifier code  of "WK" f or profess ional clai ms
  40023   "RTN","CHM XPU03",336 ,0)
  40024    ;Methodic al-5010 Ch ange-Begin
  40025   "RTN","CHM XPU03",337 ,0)
  40026    ; FILETYP E=
  40027   "RTN","CHM XPU03",338 ,0)
  40028    ; "A" - I NSTITUTION AL
  40029   "RTN","CHM XPU03",339 ,0)
  40030    ; "B" - P ROFESSIONA L
  40031   "RTN","CHM XPU03",340 ,0)
  40032    ; "C" - D ENTAL
  40033   "RTN","CHM XPU03",341 ,0)
  40034    I CHFLD(C HFLPN)="WK " D RCDERR ^CHMXPU01
  40035   "RTN","CHM XPU03",342 ,0)
  40036    Q
  40037   "RTN","CHM XPU03",343 ,0)
  40038     ;Methodi cal-5010 C hange-End
  40039   "RTN","CHM XPU03",344 ,0)
  40040    
  40041   "RTN","CHM XPU04")
  40042   0^70^B3682 07416
  40043   "RTN","CHM XPU04",1,0 )
  40044   CHMXPU04 ; CVA/DTP;X1 2 837 READ  EDIT UTIL ITY #4 (HE ALTH CARE  CLAIMS);03 /10/98  1: 50 PM
  40045   "RTN","CHM XPU04",2,0 )
  40046    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  40047   "RTN","CHM XPU04",3,0 )
  40048    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  40049   "RTN","CHM XPU04",4,0 )
  40050    ;;SPECIAL  EDITS FOR  837 RECOR D READ AT  CLAIM LEVE L
  40051   "RTN","CHM XPU04",5,0 )
  40052    ;;CALLED  INDIRECTLY  BY GENREA D^CHMXPU01 +15 (CHEDR TN IS DEFI NED), CHMX PU07
  40053   "RTN","CHM XPU04",6,0 )
  40054    ;;AJM DEV 5022 (04-J UN-08)
  40055   "RTN","CHM XPU04",7,0 )
  40056    ;;Methodi cal - Chan ged CHHCQL F= TO CHHC QLF[ in or der to han dle ICD-10  or ICD-9  qualifier
  40057   "RTN","CHM XPU04",8,0 )
  40058    ;;ICD-10  RCS -lg Do n't insert  decimal p oint into  ICD-10 Pro cedure Cod es "BR" &  "BQ" HCCQ  check for  ICD9 codes  03/08/13
  40059   "RTN","CHM XPU04",9,0 )
  40060    ;;ICD-10  RCS -lg ad ded "BBQ": "i" to $CA SE stateme nt in case  BBQ not i n file 03/ 25/13
  40061   "RTN","CHM XPU04",10, 0)
  40062    ;;ICD-10  RCS -lg Bu g 28 E cod e decimal  point plac ed after t he 4th cha racter vic e after th e 3rd char acter. HCC Q ABF 6/24 /14
  40063   "RTN","CHM XPU04",11, 0)
  40064    ;; 2/1/20 16 DLB MER GED UPDATE S TO THE F ORMAT ROUT INE FRO IC D-9 DIAGNO SIS CODES.
  40065   "RTN","CHM XPU04",12, 0)
  40066    ;;CPE005- 038 AJF -  Original P DI found i n Ready Qu eue (Freq  code=8)
  40067   "RTN","CHM XPU04",13, 0)
  40068    ;;CPE005- 043 SS - T OB FC 8 Al l Claims L ines Not C omplete (F req code=8 )
  40069   "RTN","CHM XPU04",14, 0)
  40070    ;;CPE005- 042 AJF -  Original P DI in proc ess and al l claims i n process  (Freq code =8)
  40071   "RTN","CHM XPU04",15, 0)
  40072    ;;OTW 11/ 28/2017 CP E005-040 -  Reject if  Original  PDI Number  is null a nd Freq co de=5.
  40073   "RTN","CHM XPU04",16, 0)
  40074    ;;BDB 12/ 4/2017 CPE 005-039 -  Reject Fre quency Cod e 6
  40075   "RTN","CHM XPU04",17, 0)
  40076    ;;BDB 2/2 /2018 CPE0 05-042 - A ll claims  in process
  40077   "RTN","CHM XPU04",18, 0)
  40078    ;;TGH 2/1 5/2018 CPD 005-043 -  Discontinu e use of I CNVOID2
  40079   "RTN","CHM XPU04",19, 0)
  40080    ;;CFS 01/ 31/2019 Se perate ICN VOID and I CN42. ICNV OID goes w ith User S tory CPE00 5-038 and  ICN42 goes  with CPE0 05-042 
  40081   "RTN","CHM XPU04",20, 0)
  40082    ;
  40083   "RTN","CHM XPU04",21, 0)
  40084   HCCDQ ;VAL IDATION OF  HEALTH CA RE CODE QU ALIFIER
  40085   "RTN","CHM XPU04",22, 0)
  40086    D DEBUG^C HMXDR01("C HMXPU04: H CCDQ CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  40087   "RTN","CHM XPU04",23, 0)
  40088    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  40089   "RTN","CHM XPU04",24, 0)
  40090    I '$D(^CH MXDIC(7412 01.1,"B",C HFLD(CHFLP N))) D  ;G  HCCDQ1
  40091   "RTN","CHM XPU04",25, 0)
  40092    . S CHHCQ LF="",CHSU B1=49,CHSU B2=1 D SET DTA
  40093   "RTN","CHM XPU04",26, 0)
  40094    . D DEBUG ^CHMXDR01( "CHMXPU04:  HCCDQ2 CH FLD(CHFLPN )= ",CHFLD (CHFLPN))
  40095   "RTN","CHM XPU04",27, 0)
  40096    . S CHEDR J="E100"_$ CASE(CHFLD (CHFLPN)," ABK":"c"," ABJ":"d"," ABR":"e"," ABN":"f"," ABF":"g"," BBR":"h"," BBQ":"i",: "") ; ICD- 10 RCS -lg  added "BB Q":i 
  40097   "RTN","CHM XPU04",28, 0)
  40098    . D RCDER R^CHMXPU01 :CHEDRJ'=" E100"
  40099   "RTN","CHM XPU04",29, 0)
  40100   HCCDQ1 Q
  40101   "RTN","CHM XPU04",30, 0)
  40102    ;
  40103   "RTN","CHM XPU04",31, 0)
  40104    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  40105   "RTN","CHM XPU04",32, 0)
  40106    ; THE HEA LTH CARE C ODE QUALIF IER VALIDA TION IS US ED FOR BOT H THE ICD- 9 AND ICD- 10 CODES.
  40107   "RTN","CHM XPU04",33, 0)
  40108    ; THE USE  OF THE "[ " (CONTAIN S) VS THE  "=" (EQUAL S) ALLOWS  THE TESTIN G OF THE 
  40109   "RTN","CHM XPU04",34, 0)
  40110    ; "BK,BJ, BF,etc" AN D "ABK,ABJ ,ABF,etc"  USING THIS  SAME FUNC TION.
  40111   "RTN","CHM XPU04",35, 0)
  40112    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  40113   "RTN","CHM XPU04",36, 0)
  40114    ;
  40115   "RTN","CHM XPU04",37, 0)
  40116   HCCDV ;VAL IDATION OF  HEALTH CA RE CODE (F ILE LOOKUP  DEPENDS U PON HC QUA LIFIER)
  40117   "RTN","CHM XPU04",38, 0)
  40118    Q:'$D(CHF LD(CHFLPN) )  ; Q:CHF LD(CHFLPN) ="" 
  40119   "RTN","CHM XPU04",39, 0)
  40120    D DEBUG^C HMXDR01("C HMXPU04: H CCDV ENTRY : CHFLD(CH FLPN)=",CH FLD(CHFLPN ))
  40121   "RTN","CHM XPU04",40, 0)
  40122    S CHDIF=3 ,CHEND=1
  40123   "RTN","CHM XPU04",41, 0)
  40124    D GTHCQLF  I $D(CHED PRB) S CHP RB="E40ZA"  G HCCDV1
  40125   "RTN","CHM XPU04",42, 0)
  40126    ;FOLLOWIN G WAS FE E DIT E40ZD  - AJM DEV5 022
  40127   "RTN","CHM XPU04",43, 0)
  40128    Q:CHHCQLF =""  I CHF LD(CHFLPN) ="" S CHSU B1=49,CHSU B2=1,CHEDR J="NONE" D  SETDTA G  HCCDV1
  40129   "RTN","CHM XPU04",44, 0)
  40130    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"     C HMXPU04: H CCDV: GTHC QLF()=",CH HCQLF,"  $ D(^CHMXDIC (741201.1, ""B"",",CH HCQLF,"))=  ",$D(^CHM XDIC(74120 1.1,"B",CH HCQLF))
  40131   "RTN","CHM XPU04",45, 0)
  40132    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CCDV1
  40133   "RTN","CHM XPU04",46, 0)
  40134    I CHHCQLF ["BJ" D  G  HCCDV1
  40135   "RTN","CHM XPU04",47, 0)
  40136    .S JZ=3 D  STFRMT  ;  SET UP TH E FORMATTI NG FOR THE  CODES 
  40137   "RTN","CHM XPU04",48, 0)
  40138    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40Z B" D SETDT A
  40139   "RTN","CHM XPU04",49, 0)
  40140    .S CHSUB1 =42,CHSUB2 =1 D SETDT A Q
  40141   "RTN","CHM XPU04",50, 0)
  40142    I CHHCQLF ["BK" D  G  HCCDV1
  40143   "RTN","CHM XPU04",51, 0)
  40144    .S JZ=3 D  STFRMT
  40145   "RTN","CHM XPU04",52, 0)
  40146    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E401 a" D SETDT A
  40147   "RTN","CHM XPU04",53, 0)
  40148    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  40149   "RTN","CHM XPU04",54, 0)
  40150    .I ZZTOS' ="" I ($P( ^CHMXCLE(C HCLEI,0)," ^",5)="A") &($D(^CHMX DIC(741201 .03,"D",1, ZZTOS)))&( $D(CHDTA(4 0,1,0))) S  CHEDRJ="E 401b",CHSU B1=49,CHSU B2=1 D SET DTA
  40151   "RTN","CHM XPU04",55, 0)
  40152    .S CHSUB1 =40,CHSUB2 =1 D SETDT A K ZZTOS  Q
  40153   "RTN","CHM XPU04",56, 0)
  40154    I CHHCQLF ["BF" D  G  HCCDV1
  40155   "RTN","CHM XPU04",57, 0)
  40156    .S JZ=3 D  STFRMT
  40157   "RTN","CHM XPU04",58, 0)
  40158    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40J 1" D SETDT A
  40159   "RTN","CHM XPU04",59, 0)
  40160    .S CHSUB1 =40,CHSUB2 =1 D SETDT A Q
  40161   "RTN","CHM XPU04",60, 0)
  40162    I CHHCQLF ["BN" D  G  HCCDV1
  40163   "RTN","CHM XPU04",61, 0)
  40164    .S JZ=3 D  STFRMT
  40165   "RTN","CHM XPU04",62, 0)
  40166    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40Z C" D SETDT A
  40167   "RTN","CHM XPU04",63, 0)
  40168    .S CHSUB1 =40,CHSUB2 =1 D SETDT A Q
  40169   "RTN","CHM XPU04",64, 0)
  40170    I CHHCQLF ["ZZ" D  G  HCCDV1
  40171   "RTN","CHM XPU04",65, 0)
  40172    .S JZ=3 D  STFRMT
  40173   "RTN","CHM XPU04",66, 0)
  40174    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40J 1" D SETDT A
  40175   "RTN","CHM XPU04",67, 0)
  40176    .S CHSUB1 =46,CHSUB2 =1 D SETDT A Q
  40177   "RTN","CHM XPU04",68, 0)
  40178    I CHHCQLF ["BR" D  G  HCCDV1
  40179   "RTN","CHM XPU04",69, 0)
  40180    .I CHHCQL F="BR"  D   ; "BR" IS  AN ICD-9  PROCEDURE  QUALIFIER  IN "E100", "E105","E1 10" RECORD S
  40181   "RTN","CHM XPU04",70, 0)
  40182    ..S JZ=2  D STFRMT   ;ICD-10 RC S -lg
  40183   "RTN","CHM XPU04",71, 0)
  40184    .I '$D(^C HMSERV("BE ",CHFLD(CH FLPN)_"Z") ) S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E411a" D  SETDTA
  40185   "RTN","CHM XPU04",72, 0)
  40186    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  40187   "RTN","CHM XPU04",73, 0)
  40188    .;FOLLOWI NG WAS FE  EDIT E411b   - AJM DE V5022
  40189   "RTN","CHM XPU04",74, 0)
  40190    .I ZZTOS' ="" I ($P( ^CHMXCLE(C HCLEI,0)," ^",5)="A") &($D(^CHMX DIC(741201 .03,"D",1, ZZTOS)))&( $D(CHDTA(4 1,1,0))) S  CHEDRJ="N ONE",CHSUB 1=49,CHSUB 2=1 D SETD TA
  40191   "RTN","CHM XPU04",75, 0)
  40192    .S CHSUB1 =41,CHSUB2 =1 D SETDT A K ZZTOS  Q
  40193   "RTN","CHM XPU04",76, 0)
  40194    I CHHCQLF ["BP" D  G  HCCDV1
  40195   "RTN","CHM XPU04",77, 0)
  40196    .I ('$D(^ CHMSERV("B C",CHFLD(C HFLPN))))& ('$D(^CHMS ERV("BF",C HFLD(CHFLP N)_"Z")))  S CHSUB1=4 9,CHSUB2=1 ,CHEDRJ="E 411a" D SE TDTA
  40197   "RTN","CHM XPU04",78, 0)
  40198    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  40199   "RTN","CHM XPU04",79, 0)
  40200    .;FOLLOWI NG WAS FE  EDIT E411b  - AJM DEV 5022
  40201   "RTN","CHM XPU04",80, 0)
  40202    .I ZZTOS' ="" I ($P( ^CHMXCLE(C HCLEI,0)," ^",5)="A") &($D(^CHMX DIC(741201 .03,"D",1, ZZTOS)))&( $D(CHDTA(4 1,1,0))) S  CHEDRJ="N ONE",CHSUB 1=49,CHSUB 2=1 D SETD TA
  40203   "RTN","CHM XPU04",81, 0)
  40204    .S CHSUB1 =41,CHSUB2 =1 D SETDT A K ZZTOS  Q
  40205   "RTN","CHM XPU04",82, 0)
  40206    I CHHCQLF ["BQ" D  G  HCCDV1
  40207   "RTN","CHM XPU04",83, 0)
  40208    .I CHHCQL F="BQ"  D   ; "BQ" IS  THE ICD-9  PROCEDURE  QUALIFIER  IN "E100" ,"E105","E 110" RECOR DS 
  40209   "RTN","CHM XPU04",84, 0)
  40210    ..S JZ=2  D STFRMT ;  ICD-10 RC S lg
  40211   "RTN","CHM XPU04",85, 0)
  40212    .I '$D(^C HMSERV("BE ",CHFLD(CH FLPN)_"Z") ) S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E41J1" D  SETDTA
  40213   "RTN","CHM XPU04",86, 0)
  40214    .S CHSUB1 =41,CHSUB2 =1 D SETDT A Q
  40215   "RTN","CHM XPU04",87, 0)
  40216    I CHHCQLF ["BO" D  G  HCCDV1
  40217   "RTN","CHM XPU04",88, 0)
  40218    .I ('$D(^ CHMSERV("B C",CHFLD(C HFLPN))))& ('$D(^CHMS ERV("BF",C HFLD(CHFLP N)_"Z")))  S CHSUB1=4 9,CHSUB2=1 ,CHEDRJ="E 41J1" D SE TDTA
  40219   "RTN","CHM XPU04",89, 0)
  40220    .S CHSUB1 =41,CHSUB2 =1 D SETDT A Q
  40221   "RTN","CHM XPU04",90, 0)
  40222    ;Methodic al-5010 Ch ange-Begin  - Added c ode for PR  qualifier  check - P atient Rea son for Vi sit
  40223   "RTN","CHM XPU04",91, 0)
  40224    I CHHCQLF ["PR" D  G  HCCDV1
  40225   "RTN","CHM XPU04",92, 0)
  40226    .S JZ=3 D  STFRMT
  40227   "RTN","CHM XPU04",93, 0)
  40228    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E46b " D SETDTA
  40229   "RTN","CHM XPU04",94, 0)
  40230    .S CHSUB1 =46,CHSUB2 =1 D SETDT A Q
  40231   "RTN","CHM XPU04",95, 0)
  40232    ;Methodic al-5010 Ch ange-End
  40233   "RTN","CHM XPU04",96, 0)
  40234    I CHHCQLF ["BE" D  G  HCCDV1
  40235   "RTN","CHM XPU04",97, 0)
  40236    .I '$D(^C HMXDIC(741 201.4,"B", CHFLD(CHFL PN))) S CH SUB1=49,CH SUB2=1,CHE DRJ="E45a"  D SETDTA
  40237   "RTN","CHM XPU04",98, 0)
  40238    .S CHSUB1 =45,CHSUB2 =1 D SETDT A Q
  40239   "RTN","CHM XPU04",99, 0)
  40240    I CHHCQLF ["BG" D  G  HCCDV1
  40241   "RTN","CHM XPU04",100 ,0)
  40242    .I '$D(^C HMXDIC(741 201.41,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E44a " D SETDTA
  40243   "RTN","CHM XPU04",101 ,0)
  40244    .S CHSUB1 =44,CHSUB2 =1 D SETDT A Q
  40245   "RTN","CHM XPU04",102 ,0)
  40246    I CHHCQLF ["BH" D  G  HCCDV1
  40247   "RTN","CHM XPU04",103 ,0)
  40248    .I '$D(^C HMXDIC(741 201.42,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E43a " D SETDTA
  40249   "RTN","CHM XPU04",104 ,0)
  40250    .S CHSUB1 =43,CHSUB2 =1 D SETDT A Q
  40251   "RTN","CHM XPU04",105 ,0)
  40252    I CHHCQLF ["BI" D  G  HCCDV1
  40253   "RTN","CHM XPU04",106 ,0)
  40254    .I '$D(^C HMXDIC(741 201.43,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E43b " D SETDTA
  40255   "RTN","CHM XPU04",107 ,0)
  40256    .S CHSUB1 =43,CHSUB2 =1 D SETDT A Q
  40257   "RTN","CHM XPU04",108 ,0)
  40258    I CHHCQLF ["TC" D  G  HCCDV1
  40259   "RTN","CHM XPU04",109 ,0)
  40260    .D STTC ;  FORMAT "T C" CODES I F NEEDED
  40261   "RTN","CHM XPU04",110 ,0)
  40262    .I '$D(^C HMXDIC(741 201.85,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E100 b" D SETDT A
  40263   "RTN","CHM XPU04",111 ,0)
  40264    .;S CHSUB 1=48,CHSUB 2=1 D SETD TA Q  ; CO ULD SET IN TO NODE 48  IF DESIRE D
  40265   "RTN","CHM XPU04",112 ,0)
  40266    I CHHCQLF ["DR" D  G  HCCDV1
  40267   "RTN","CHM XPU04",113 ,0)
  40268    .Q
  40269   "RTN","CHM XPU04",114 ,0)
  40270    .D STDR ;  FORMAT "D R" CODES I F NEEDED
  40271   "RTN","CHM XPU04",115 ,0)
  40272    .I '$D(^C HMDIC(7410 02.16,"B", CHFLD(CHFL PN))) S CH SUB1=49,CH SUB2=1,CHE DRJ="E42J1 " D SETDTA  ; COULD C HECK AGAIN ST DRG FIL E
  40273   "RTN","CHM XPU04",116 ,0)
  40274    .S CHSUB1 =47,CHSUB2 =1 D SETDT A Q  ; COU LD SET INT O NODE 47  IF DESIRED
  40275   "RTN","CHM XPU04",117 ,0)
  40276   HCCDV1 K C HHCQLF,CHD IF,CHEND Q
  40277   "RTN","CHM XPU04",118 ,0)
  40278    ; 
  40279   "RTN","CHM XPU04",119 ,0)
  40280   HCDTV ;HEA LTH CARE C ODE DATE M UST BE PRE SENT/VALID  FOR ALL P X CODES (" BR" & "BQ"  FOR ICD9  CODES AND  "BP" & "BO " FOR HCPC S/CPT4 COD ES)
  40281   "RTN","CHM XPU04",120 ,0)
  40282    S:CHX12VR S=1 CHDIF= 13,CHEND=1 1
  40283   "RTN","CHM XPU04",121 ,0)
  40284    S:CHX12VR S=2 CHDIF= 18,CHEND=1 6
  40285   "RTN","CHM XPU04",122 ,0)
  40286    ;Methodic al-5010 Ch ange-Begin
  40287   "RTN","CHM XPU04",123 ,0)
  40288    S:CHX12VR S=3 CHDIF= 34,CHEND=3 2
  40289   "RTN","CHM XPU04",124 ,0)
  40290    ;Methodic al-5010 Ch ange-End
  40291   "RTN","CHM XPU04",125 ,0)
  40292    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTV1
  40293   "RTN","CHM XPU04",126 ,0)
  40294    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTV1
  40295   "RTN","CHM XPU04",127 ,0)
  40296    I (CHHCQL F["BR")!(C HHCQLF["BP ") D  G HC DTV1
  40297   "RTN","CHM XPU04",128 ,0)
  40298    .;I CHFLD (CHFLPN)=" " S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E412a" D  SETDTA Q
  40299   "RTN","CHM XPU04",129 ,0)
  40300    .;S CHDTF L=1 D 201^ CHMXPU01 K  CHDTFL I  Y=-1 S CHS UB1=49,CHS UB2=1,CHED RJ="E412a"  D SETDTA
  40301   "RTN","CHM XPU04",130 ,0)
  40302    .S CHSUB1 =41,CHSUB2 =2 D SETDT A Q
  40303   "RTN","CHM XPU04",131 ,0)
  40304    I (CHHCQL F["BQ")!(C HHCQLF["BO ") D  G HC DTV1
  40305   "RTN","CHM XPU04",132 ,0)
  40306    .;FOLLOWI NG WAS FE  EDIT E41J2 a - AJM DE V5022
  40307   "RTN","CHM XPU04",133 ,0)
  40308    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  40309   "RTN","CHM XPU04",134 ,0)
  40310    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="E41J2a"  D SETDTA
  40311   "RTN","CHM XPU04",135 ,0)
  40312    .S CHSUB1 =41,CHSUB2 =2 D SETDT A Q
  40313   "RTN","CHM XPU04",136 ,0)
  40314    I (CHHCQL F["BH")!(C HHCQLF["BI ") D  G HC DTV1
  40315   "RTN","CHM XPU04",137 ,0)
  40316    .;FOLLOWI NG WAS FE  EDIT E431a  - AJM DEV 5022
  40317   "RTN","CHM XPU04",138 ,0)
  40318    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  40319   "RTN","CHM XPU04",139 ,0)
  40320    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="E431a"  D SETDTA
  40321   "RTN","CHM XPU04",140 ,0)
  40322    .S CHSUB1 =43,CHSUB2 =2 D SETDT A Q
  40323   "RTN","CHM XPU04",141 ,0)
  40324   HCDTV1 K C HHCQLF,CHD IF,CHEND Q
  40325   "RTN","CHM XPU04",142 ,0)
  40326    ; 
  40327   "RTN","CHM XPU04",143 ,0)
  40328   HCDTF ;HEA LTH CARE C ODE DATE M UST NOT BE  FUTURE FO R ALL PX C ODES ("BR"  & "BQ" FO R ICD9 COD ES, "BP" A ND "BO" FO R HCPCS/CP T4 CODES)
  40329   "RTN","CHM XPU04",144 ,0)
  40330    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  40331   "RTN","CHM XPU04",145 ,0)
  40332    S:CHX12VR S=1 CHDIF= 13,CHEND=1 1
  40333   "RTN","CHM XPU04",146 ,0)
  40334    S:CHX12VR S=2 CHDIF= 18,CHEND=1 6
  40335   "RTN","CHM XPU04",147 ,0)
  40336    ;Methodic al-5010 Ch ange-Begin
  40337   "RTN","CHM XPU04",148 ,0)
  40338    S:CHX12VR S=3 CHDIF= 34,CHEND=3 2
  40339   "RTN","CHM XPU04",149 ,0)
  40340    ;Methodic al-5010 Ch ange-End
  40341   "RTN","CHM XPU04",150 ,0)
  40342    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E4OZA"  G HCDTF1
  40343   "RTN","CHM XPU04",151 ,0)
  40344    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTF1
  40345   "RTN","CHM XPU04",152 ,0)
  40346    I (CHHCQL F["BR")!(C HHCQLF["BP ") D  G HC DTF1
  40347   "RTN","CHM XPU04",153 ,0)
  40348    .S CHDTFL =1 D 301^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="E412b"  D SETDTA Q
  40349   "RTN","CHM XPU04",154 ,0)
  40350    I (CHHCQL F["BQ")!(C HHCQLF["BO ") D  G HC DTF1
  40351   "RTN","CHM XPU04",155 ,0)
  40352    .S CHDTFL =1 D 301^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="E41J2b"  D SETDTA  Q
  40353   "RTN","CHM XPU04",156 ,0)
  40354    .;I (CHHC QLF="BH")! (CHHCQLF=" BI") D  G: CHHCQLF="B H" HCDTF1
  40355   "RTN","CHM XPU04",157 ,0)
  40356    .;S CHDTF L=1 D 301^ CHMXPU01 K  CHDTFL I  Y=-1 S CHS UB1=49,CHS UB2=1,CHED RJ="E431b"  D SETDTA  Q
  40357   "RTN","CHM XPU04",158 ,0)
  40358    I CHHCQLF ["BI" D  G  HCDTF1
  40359   "RTN","CHM XPU04",159 ,0)
  40360    .;FOLLOWI NG WAS FE  EDIT E431b  - AJM DEV 5022
  40361   "RTN","CHM XPU04",160 ,0)
  40362    .S CHDIF= -8,CHEND=- 15 D GETHR DT Q:'$D(C HTHRDT)  Q :CHTHRDT=" "  I $D(CH EDPRB) S C HPRB="NONE " G HCDTF1
  40363   "RTN","CHM XPU04",161 ,0)
  40364    .;FOLLOWI NG WAS FE  EDIT E431b  - AJM DEV 5022
  40365   "RTN","CHM XPU04",162 ,0)
  40366    .I CHTHRD T'>CHFLD(C HFLPN) S C HSUB1=49,C HSUB2=1,CH EDRJ="NONE " D SETDTA  Q
  40367   "RTN","CHM XPU04",163 ,0)
  40368   HCDTF1 K C HHCQLF,CHD IF,CHEND,C HTHRDT Q
  40369   "RTN","CHM XPU04",164 ,0)
  40370    ; 
  40371   "RTN","CHM XPU04",165 ,0)
  40372   HCDTV2 ;HE ALTH CARE  CODE DATE2  (OCC SPAN  ONLY) MUS T BE PRESE NT/VALID F OR "BI"
  40373   "RTN","CHM XPU04",166 ,0)
  40374    S:CHX12VR S=1 CHDIF= 21,CHEND=1 9
  40375   "RTN","CHM XPU04",167 ,0)
  40376    S:CHX12VR S=2 CHDIF= 26,CHEND=2 4
  40377   "RTN","CHM XPU04",168 ,0)
  40378    ;Methodic al-5010 Ch ange-End
  40379   "RTN","CHM XPU04",169 ,0)
  40380    S:CHX12VR S=3 CHDIF= 42,CHEND=4 0
  40381   "RTN","CHM XPU04",170 ,0)
  40382    ;Methodic al-5010 Ch ange-End
  40383   "RTN","CHM XPU04",171 ,0)
  40384    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTV21
  40385   "RTN","CHM XPU04",172 ,0)
  40386    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTV21
  40387   "RTN","CHM XPU04",173 ,0)
  40388    I CHHCQLF ["BI" D  G  HCDTV21
  40389   "RTN","CHM XPU04",174 ,0)
  40390    .;FOLLOWI NG WAS FE  EDIT E432a  - AJM DEV 5022
  40391   "RTN","CHM XPU04",175 ,0)
  40392    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  40393   "RTN","CHM XPU04",176 ,0)
  40394    .;FOLLOWI NG WAS FE  EDIT E432a  - AJM DEV 5022
  40395   "RTN","CHM XPU04",177 ,0)
  40396    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="NONE" D  SETDTA
  40397   "RTN","CHM XPU04",178 ,0)
  40398    .S CHSUB1 =43,CHSUB2 =3 D SETDT A Q
  40399   "RTN","CHM XPU04",179 ,0)
  40400   HCDTV21 K  CHHCQLF,CH DIF,CHEND  Q
  40401   "RTN","CHM XPU04",180 ,0)
  40402    ; 
  40403   "RTN","CHM XPU04",181 ,0)
  40404   HCDTF2 ;HE ALTH CARE  CODE DATE  MUST NOT B E FUTURE F OR OCC SPA N THRU DAT E ("BI")
  40405   "RTN","CHM XPU04",182 ,0)
  40406    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  40407   "RTN","CHM XPU04",183 ,0)
  40408    S:CHX12VR S=1 CHDIF= 21,CHEND=1 9
  40409   "RTN","CHM XPU04",184 ,0)
  40410    S:CHX12VR S=2 CHDIF= 26,CHEND=2 4
  40411   "RTN","CHM XPU04",185 ,0)
  40412    S:CHX12VR S=3 CHDIF= 42,CHEND=4 0
  40413   "RTN","CHM XPU04",186 ,0)
  40414    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTF21
  40415   "RTN","CHM XPU04",187 ,0)
  40416    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTF21
  40417   "RTN","CHM XPU04",188 ,0)
  40418    I CHHCQLF ["BI" D  G  HCDTF21
  40419   "RTN","CHM XPU04",189 ,0)
  40420    .;S CHDTF L=1 D 301^ CHMXPU01 K  CHDTFL I  Y=-1 S CHS UB1=49,CHS UB2=1,CHED RJ="E432b"  D SETDTA  Q
  40421   "RTN","CHM XPU04",190 ,0)
  40422    .S CHDIF= 8,CHEND=1  D GETODT Q :'$D(CHTOD T)  Q:CHTO DT=""  I $ D(CHEDPRB)  S CHPRB=" E432b" Q
  40423   "RTN","CHM XPU04",191 ,0)
  40424    .;FOLLOWI NG WAS FE  EDIT E432b  - AJM DEV 5022
  40425   "RTN","CHM XPU04",192 ,0)
  40426    .I CHTODT '<CHFLD(CH FLPN) S CH SUB1=49,CH SUB2=1,CHE DRJ="NONE"  Q
  40427   "RTN","CHM XPU04",193 ,0)
  40428   HCDTF21 K  GETODT,CHH CQLF,CHDIF ,CHEND Q
  40429   "RTN","CHM XPU04",194 ,0)
  40430    ;
  40431   "RTN","CHM XPU04",195 ,0)
  40432     ;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  40433   "RTN","CHM XPU04",196 ,0)
  40434    ; DIAGNOS IS CODE DA TE OF SERV ICE VS ICD  CODE ACTI VE DATES C HECK FOR I NSTITUTION AL CLAIMS.
  40435   "RTN","CHM XPU04",197 ,0)
  40436    ; INSTITU TIONAL CLA IMS LOAD I NTO THE ^C HMXCLE() B UFFER, AND  THE DATE  OF SERVICE  IS REQUIR ED
  40437   "RTN","CHM XPU04",198 ,0)
  40438    ; IN LOOP  2300, WHI CH TRANSLA TES TO THE  "E005" FL AT FILE RE CORD.
  40439   "RTN","CHM XPU04",199 ,0)
  40440    ; FOR ICD -10 THERE  NEEDS TO B E A REAL T IME CHECK  FOR THE AC TIVE ICD-9 /ICD-10 DI AG CODES 
  40441   "RTN","CHM XPU04",200 ,0)
  40442    ; AGAINST  THE DATE  OF SERVICE . THIS FUN CTION WILL  PERFORM T HE CHECK A S PART OF  THE FRONT 
  40443   "RTN","CHM XPU04",201 ,0)
  40444    ; END EDI TS SO THE  CLAIM CAN  BE REJECTE D AND REPO RTED ON TH E CSTAT (U NSOLICITED  STATUS) R EPORT.
  40445   "RTN","CHM XPU04",202 ,0)
  40446    ; THE REJ ECT LOGIC  FOR THE IC D-9/ICD-10  DIAGNOSTI C CODES:
  40447   "RTN","CHM XPU04",203 ,0)
  40448    ; 1) IF D IAG CODE C ANNOT BE C ROSS-REFER ENCED (^CH MICDX("C", DIAG CODE, I), CLAIM  WILL BE RE JECTED
  40449   "RTN","CHM XPU04",204 ,0)
  40450    ; 2) IF T HE DATE OF  SERVICE ( STATEMENT  "TO" DATE)  IS NOT PO PULATED (^ CHMXCLE(CH CLEI,1),"^ ",2)) THE
  40451   "RTN","CHM XPU04",205 ,0)
  40452    ; INSTITU TIONAL CLA IM WILL BE  REJECTED.
  40453   "RTN","CHM XPU04",206 ,0)
  40454    ; 3) THE  DIAGNOSIS  CODE WILL  BE DETERMI NED AS ICD -9 OR ICD- 10 BASED O N THE ^CHM ICDX(I,0), "^",24) FI ELD
  40455   "RTN","CHM XPU04",207 ,0)
  40456    ; 4) IF I CD-10 CODE  TERMINATI ON DATE IS  BLANK, CH ECK AGAINS T ICD-10 " EFFECTIVE"  DATE ONLY . IF THE D OS
  40457   "RTN","CHM XPU04",208 ,0)
  40458    ; IS BEFO RE THE "EF FECTIVE" D ATE, THE C LAIM WILL  BE REJECTE D.
  40459   "RTN","CHM XPU04",209 ,0)
  40460    ; 5) IF I CD-10 TERM INATION DA TE IS POPU LATED, THE  DOS WILL  BE CHECKED  AGAINST T HE ICD-10  "ACTIVE" D ATES 
  40461   "RTN","CHM XPU04",210 ,0)
  40462    ; ^CHMICD X(I,0), FI ELD 22: EF FECTIVE DA TE AND ^CH MICDX(I,0) , FIELD 23 : TERMINAT ION DATE)  FOR THE 
  40463   "RTN","CHM XPU04",211 ,0)
  40464    ; DIAG CO DE. IF THE  DOS FALLS  OUTSIDE T HESE DATES , THE CLAI M WILL BE  REJECTED
  40465   "RTN","CHM XPU04",212 ,0)
  40466    ; 6) IF I CD-9, THE  DOS WILL B E CHECKED  AGAINST TH E ICD-9 TE RMINATION  DATE (^CHM ICDX(I,0),  FIELD 23:  TERMINATI ON DATE) 
  40467   "RTN","CHM XPU04",213 ,0)
  40468    ; IF THE  DOS IS AFT ER THE TER MINATION D ATE, THE C LAIM WILL  BE REJECTE D.
  40469   "RTN","CHM XPU04",214 ,0)
  40470    ; NOTE: I N ORDER TO  VALIDATE  BOTH ICD-9  AND ICD-1 0 QUALIFIE RS IN THIS  FUNCTION,  ("BK" VS  "ABK", ETC .)
  40471   "RTN","CHM XPU04",215 ,0)
  40472    ; THE TES TING LOGIC  CANNOT US E THE "["  (CONTAINS)  OPERAND,  BECAUSE TH E FORMATTI NG FOR THE  
  40473   "RTN","CHM XPU04",216 ,0)
  40474    ; DIAGNOS TIC CODE I S DIFFEREN T BETWEEN  THE ICD-9  AND ICD-10  CODES.
  40475   "RTN","CHM XPU04",217 ,0)
  40476    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  40477   "RTN","CHM XPU04",218 ,0)
  40478    ; 
  40479   "RTN","CHM XPU04",219 ,0)
  40480   DXQUAL   ; CHECKS FOR  INSTITUTI ONAL CLAIM  DX CODES  PROVIDED ( PROF/DENTA L DIAG COD ES ARE IN  SVC LINES)
  40481   "RTN","CHM XPU04",220 ,0)
  40482    N JZ
  40483   "RTN","CHM XPU04",221 ,0)
  40484    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHMXPU 04: DXQUAL : DIAG COD E= ",CHFLD (CHFLPN)
  40485   "RTN","CHM XPU04",222 ,0)
  40486    Q:'$D(CHF LD(CHFLPN) )
  40487   "RTN","CHM XPU04",223 ,0)
  40488    S CHDIF=3 ,CHEND=1,C HSUB2=1,CH EDRJ="NONE "
  40489   "RTN","CHM XPU04",224 ,0)
  40490    D GTHCQLF  I $D(CHED PRB) S CHP RB="E40ZA"  G XDXQUAL                  ; CO DE QUALIFI ER
  40491   "RTN","CHM XPU04",225 ,0)
  40492    D DEBUG^C HMXDR01("  PU04:DXQUA L: QUALIFI ER: "_CHHC QLF_" DIAG  CODE= "_C HFLD(CHFLP N)_" CLMTY PE=",$$CLM TYPE^CHMXP 010())
  40493   "RTN","CHM XPU04",226 ,0)
  40494    Q:CHHCQLF =""                                                         ; EXI T IF NO QU ALIFIER
  40495   "RTN","CHM XPU04",227 ,0)
  40496    Q:(CHHCQL F'["BJ")&( CHHCQLF'[" BK")&(CHHC QLF'["BF") &(CHHCQLF' ["BN")&(CH HCQLF'["PR ")&(CHHCQL F'["ZZ")   ;VALID QUA LIFIERS
  40497   "RTN","CHM XPU04",228 ,0)
  40498    I CHFLD(C HFLPN)=""  S CHSUB1=4 9 D SETDTA  G XDXQUAL
  40499   "RTN","CHM XPU04",229 ,0)
  40500    S JZ=0 ;  ASSUME DIA G CODE IS  FORMATTED  ALREADY
  40501   "RTN","CHM XPU04",230 ,0)
  40502    I ($E(CHH CQLF,1,1)= "A")!(CHHC QLF="BBQ") !(CHHCQLF= "BBR") D       ; ICD- 10 QUALIFI ERS 
  40503   "RTN","CHM XPU04",231 ,0)
  40504    .I CHFLD( CHFLPN)'[" ." D                                             ; IF  NOT FORMAT TED, FORMA T THE DIAG  CODE
  40505   "RTN","CHM XPU04",232 ,0)
  40506    ..S JZ=$S (CHHCQLF[" BK":3,CHHC QLF["BF":3 ,CHHCQLF[" BJ":3,CHHC QLF["PR":3 ,CHHCQLF[" BN":3,CHHC QLF["BQ":2 ,CHHCQLF[" BR":2,1:0)  ; DIAG CO DE "." PLA CEMENT IS  QUALIFIER  DEPENDENT 
  40507   "RTN","CHM XPU04",233 ,0)
  40508    E  D                                                                  ; ICD -9 QUALIFI ERS
  40509   "RTN","CHM XPU04",234 ,0)
  40510    .I CHFLD( CHFLPN)'[" ." D                                             ; IF  NOT FORMAT TED, FORMA T THE DIAG  CODE
  40511   "RTN","CHM XPU04",235 ,0)
  40512    ..S JZ=$S (CHHCQLF=" BK":3,CHHC QLF="BF":3 ,CHHCQLF=" BJ":3,CHHC QLF="PR":3 ,CHHCQLF=" BN":3,CHHC QLF="BQ":2 ,CHHCQLF=" BR":2,1:0)  ; DIAG CO DE "." PLA CEMENT IS  QUALIFIER  DEPENDENT 
  40513   "RTN","CHM XPU04",236 ,0)
  40514    D:JZ STFR MT                                                          ; IF  ALREADY FO RMATTED, S KIP DIAG C ODE FORMAT TING
  40515   "RTN","CHM XPU04",237 ,0)
  40516    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"DXQUAL : FORMATTE D DIAG COD E= ",CHFLD (CHFLPN)
  40517   "RTN","CHM XPU04",238 ,0)
  40518    I '$D(^CH MICDX("C", CHFLD(CHFL PN))) D  Q                            ; DIA GNOSIS COD E NOT CROS S-REFERENC ED, REJECT
  40519   "RTN","CHM XPU04",239 ,0)
  40520    .D DEBUG^ CHMXDR01(" *****DXQUA L^CHMXPU04 : DIAG COD E "_CHFLD( CHFLPN)_",  NOT CROSS -REFERENCE D.","")
  40521   "RTN","CHM XPU04",240 ,0)
  40522    .S CHEDRJ ="E401a" D  RCDERR^CH MXPU01
  40523   "RTN","CHM XPU04",241 ,0)
  40524    N DICI S  DICI=0,DIC I=$O(^CHMI CDX("C",CH FLD(CHFLPN ),DICI)) ;  DIAGNOSIS  CODE INDE X FOR ^CHM ICDX()
  40525   "RTN","CHM XPU04",242 ,0)
  40526    S DOS=$$G ETDOS() ;  DOS IS DET ERMINED DI FFERENTLY  FOR I/P/D  CLAIM TYPE S
  40527   "RTN","CHM XPU04",243 ,0)
  40528    D DEBUG^C HMXDR01("  DXQUAL^CHM XDR01: DOS = "_DOS_"  ICD10 FLAG : "_$P(^CH MICDX(DICI ,0),"^",24 )_" EFF DA TE:"_$P(^C HMICDX(DIC I,0),"^",2 2)_" TERM  DATE:",$P( ^CHMICDX(D ICI,0),"^" ,23))
  40529   "RTN","CHM XPU04",244 ,0)
  40530    I DOS'=""   D                                                         ; IF  WE HAVE A  VALID DOS,  COMPARE A GAINST ICD X DATES
  40531   "RTN","CHM XPU04",245 ,0)
  40532    .I $P(^CH MICDX(DICI ,0),"^",24 ) D                                  ; IF I CD-10 FLAG  IS SET
  40533   "RTN","CHM XPU04",246 ,0)
  40534    ..I $P(^C HMICDX(DIC I,0),"^",2 3)=""  D                              ; NO  TERMINATIO N DATE
  40535   "RTN","CHM XPU04",247 ,0)
  40536    ...I DOS< $P(^CHMICD X(DICI,0), "^",22) D                            ; CHEC K EFFECTIV E DATE AGA INST DOS
  40537   "RTN","CHM XPU04",248 ,0)
  40538    ....D DEB UG^CHMXDR0 1(" DXQUAL ^CHMXPU04  DOS: "_DOS _" BEFORE  ICD-10 EFF ECTIVE DAT E:",$P(^CH MICDX(DICI ,0),"^",22 ))
  40539   "RTN","CHM XPU04",249 ,0)
  40540    ....S CHE DRJ="E41J2 a" D RCDER R^CHMXPU01  ; SET EAR LY REJECT  FOR ICD-10  DIAG/NO T ERM DATE,  DOS BEFORE  EFFECTIVE  DATE
  40541   "RTN","CHM XPU04",250 ,0)
  40542    ..E  I (( DOS<$P(^CH MICDX(DICI ,0),"^",22 ))!(DOS>$P (^CHMICDX( DICI,0),"^ ",23))) D         ; C HECK DOS A GAINST ICD -10 CODE E FFECTIVE/T ERMINATION  DATES
  40543   "RTN","CHM XPU04",251 ,0)
  40544    ...D DEBU G^CHMXDR01 (" DXQUAL^ CHMXPU04 D OS: "_DOS_ " OUTSIDE  ICD-10 EFF /TERM DATE S:",$P(^CH MICDX(DICI ,0),"^",22 )_"/"_$P(^ CHMICDX(DI CI,0),"^", 23))
  40545   "RTN","CHM XPU04",252 ,0)
  40546    ...S CHED RJ="E41J2a " D RCDERR ^CHMXPU01  ; SET EARL Y REJECT I CD-10 DIAG  OUTSIDE E FF/TERM DA TES
  40547   "RTN","CHM XPU04",253 ,0)
  40548    .E  D                                                                ; CODE  IS ICD-9  DIAG CODE
  40549   "RTN","CHM XPU04",254 ,0)
  40550    ..I DOS>$ P(^CHMICDX (DICI,0)," ^",23) D                            ; CHECK  SVC "TO"  DATE AGAIN ST ICD-9 T ERMINATION  DATE
  40551   "RTN","CHM XPU04",255 ,0)
  40552    ...D DEBU G^CHMXDR01 (" DXQUAL^ CHMXPU04 D OS: "_DOS_ " AFTER IC D-9 TERM D ATE:",$P(^ CHMICDX(DI CI,0),"^", 23))
  40553   "RTN","CHM XPU04",256 ,0)
  40554    ...S CHED RJ="E41J2a " D RCDERR ^CHMXPU01  ; SET EARL Y REJECT,  ICD-9 DOS  AFTER TERM NATION DAT E
  40555   "RTN","CHM XPU04",257 ,0)
  40556    E  D
  40557   "RTN","CHM XPU04",258 ,0)
  40558    .I ($$CLM TYPE^CHMXP 010()="A") &(CHXREC[" E") D                       ; "A "=INST,"B" =PROF,C=DN TL
  40559   "RTN","CHM XPU04",259 ,0)
  40560    ..D DEBUG ^CHMXDR01( " DXQUAL^C HMXPU04 IN VALID DOS:  ",DOS)
  40561   "RTN","CHM XPU04",260 ,0)
  40562    ..S CHEDR J="E401a"  D RCDERR^C HMXPU01 ;  SET EARLY  REJECT, IN VALID DOS
  40563   "RTN","CHM XPU04",261 ,0)
  40564   XDXQUAL  K  CHHCQLF,C HDIF,CHEND  Q
  40565   "RTN","CHM XPU04",262 ,0)
  40566    ;
  40567   "RTN","CHM XPU04",263 ,0)
  40568    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  40569   "RTN","CHM XPU04",264 ,0)
  40570    ; GET THE  DATE OF S ERVICE. IF  CLAIM LEV EL RECORDS , GET FROM  ^CHMXCLE;  
  40571   "RTN","CHM XPU04",265 ,0)
  40572    ; OTHERWI SE GET IT  FROM ^CHMX CLF
  40573   "RTN","CHM XPU04",266 ,0)
  40574    ; DETERMI NE IF CLAI M LEVEL OR  LINE LEVE L BY CHXRE C VALUE (" EXXX" VS " FXXX")
  40575   "RTN","CHM XPU04",267 ,0)
  40576    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  40577   "RTN","CHM XPU04",268 ,0)
  40578    ;
  40579   "RTN","CHM XPU04",269 ,0)
  40580   GETDOS()   ;
  40581   "RTN","CHM XPU04",270 ,0)
  40582    N CLMTYPE ,DOS,ERR,C HCLFI
  40583   "RTN","CHM XPU04",271 ,0)
  40584    S DOS="", ERR=0
  40585   "RTN","CHM XPU04",272 ,0)
  40586    S CLMTYPE =$$CLMTYPE ^CHMXP010( ) ; "A"=IN ST,"B"=PRO F,C=DNTL
  40587   "RTN","CHM XPU04",273 ,0)
  40588    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CLAIM  TYPE= ",CL MTYPE
  40589   "RTN","CHM XPU04",274 ,0)
  40590    I CLMTYPE ="A"  D
  40591   "RTN","CHM XPU04",275 ,0)
  40592    .I '$D(^C HMXCLE(CHC LEI)) D  Q                                       ; NEE D TO GET T HE DOS; IF  NO CLAIM  INDEX, REJ ECT
  40593   "RTN","CHM XPU04",276 ,0)
  40594    ..S ERR=1
  40595   "RTN","CHM XPU04",277 ,0)
  40596    ..U 0 W:$ $ENVIR^CHT FLIB'="LIV E" !,"NO ^ CHMXCLE(", CHCLEI,")  NODE"
  40597   "RTN","CHM XPU04",278 ,0)
  40598    .I $P(^CH MXCLE(CHCL EI,1),"^", 2)=""  D   Q
  40599   "RTN","CHM XPU04",279 ,0)
  40600    ..S ERR=1
  40601   "RTN","CHM XPU04",280 ,0)
  40602    ..U 0 W:$ $ENVIR^CHT FLIB'="LIV E" !,"NO S TATEMENT " "TO"" DATE  ENTRY @^C HMXCLE(",C HCLEI,",1) ,""^"",2)"
  40603   "RTN","CHM XPU04",281 ,0)
  40604    .S:'ERR D OS=$P(^CHM XCLE(CHCLE I,1),"^",2 ) ; STATEM ENT DATE F OR INSTITU TIONAL CLA IM
  40605   "RTN","CHM XPU04",282 ,0)
  40606    .S DOS=$$ YR8FMYR^CH TFLIB(DOS)  ; ^CHMXCL E() STORES  DOS AS YY YYMMDD, ^C HMICDX() S TORES AS F M DATE
  40607   "RTN","CHM XPU04",283 ,0)
  40608    E  D
  40609   "RTN","CHM XPU04",284 ,0)
  40610    .U 0 W:$$ ENVIR^CHTF LIB'="LIVE " !,"CHMXP U04: GETDO S: CHCLEI=  ",CHCLEI, " $D(^CHMX CLF(""B"", ",CHCLEI," )= ",$D(^C HMXCLF("B" ,CHCLEI))
  40611   "RTN","CHM XPU04",285 ,0)
  40612    .I CHXREC ["E"  D  Q
  40613   "RTN","CHM XPU04",286 ,0)
  40614    ..U 0 W:$ $ENVIR^CHT FLIB'="LIV E" !,"CHMX PU04: GETD OS: OUTPAT IENT CLAIM  RECORD "" EXXX"" DIA G CODES: N O CLAIM LE VEL DOS."
  40615   "RTN","CHM XPU04",287 ,0)
  40616    .E  I CHX REC["F"  D
  40617   "RTN","CHM XPU04",288 ,0)
  40618    ..I '$D(^ CHMXCLF("B ",CHCLEI))  D  Q                               ; VERIF Y ^CHMXCLF  CROSS-REF ERENCE
  40619   "RTN","CHM XPU04",289 ,0)
  40620    ...S ERR= 1
  40621   "RTN","CHM XPU04",290 ,0)
  40622    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  ^CHMXCLF(" "B"",",CHC LEI,"(^CHM XCLE()INDE X)) XREF"
  40623   "RTN","CHM XPU04",291 ,0)
  40624    ..S CHCLF I=0,CHCLFI =$O(^CHMXC LF("B",CHC LEI,CHCLFI )) ; GET T HE ^CHMXCL F INDEX
  40625   "RTN","CHM XPU04",292 ,0)
  40626    ..I '$D(^ CHMXCLF(CH CLFI,1)) D   Q
  40627   "RTN","CHM XPU04",293 ,0)
  40628    ...S ERR= 1
  40629   "RTN","CHM XPU04",294 ,0)
  40630    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  ^CHMXCLF(" ,CHCLFI,", 1) NODE"              ; CHECK TH E DOS NODE
  40631   "RTN","CHM XPU04",295 ,0)
  40632    ..I ($P(^ CHMXCLF(CH CLFI,1),"^ ",12)="")& ($P(^CHMXC LF(CHCLFI, 1),"^",11) ="") D
  40633   "RTN","CHM XPU04",296 ,0)
  40634    ...S ERR= 1
  40635   "RTN","CHM XPU04",297 ,0)
  40636    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  STATEMENT  ""FROM/TO" " DATES @^ CHMXCLF(", CHCLFI,",1 ),""^"",11 /12)"
  40637   "RTN","CHM XPU04",298 ,0)
  40638    ..I 'ERR   D
  40639   "RTN","CHM XPU04",299 ,0)
  40640    ...S DOS= $P(^CHMXCL F(CHCLFI,1 ),"^",12)  ; SERVICE  LINE STATE MENT "TO"  DATE
  40641   "RTN","CHM XPU04",300 ,0)
  40642    ...S:DOS= "" DOS=$P( ^CHMXCLF(C HCLFI,1)," ^",11) ; S ERVICE LIN E STATEMEN T "FROM" D ATE
  40643   "RTN","CHM XPU04",301 ,0)
  40644    ...S DOS= $$YR8FMYR^ CHTFLIB(DO S) ; SVC L INE STORES  DOS AS YY YYMMDD, ^C HMICDX() S TORES AS F M DATE
  40645   "RTN","CHM XPU04",302 ,0)
  40646    Q DOS
  40647   "RTN","CHM XPU04",303 ,0)
  40648    ; 
  40649   "RTN","CHM XPU04",304 ,0)
  40650    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  40651   "RTN","CHM XPU04",305 ,0)
  40652    ; THE FOL LOWING COD E WAS DISA BLED FOR 5 010 IMPLEM ENTATION
  40653   "RTN","CHM XPU04",306 ,0)
  40654    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  40655   "RTN","CHM XPU04",307 ,0)
  40656    ;
  40657   "RTN","CHM XPU04",308 ,0)
  40658   PDXCD ;THI S CODE INS ERTS THE P RIMARY DIA G CODE INT O ^CHMXCLE (I,42)---D ON'T DO TH AT IN 5010
  40659   "RTN","CHM XPU04",309 ,0)
  40660    Q
  40661   "RTN","CHM XPU04",310 ,0)
  40662    ;INFERS A DM DX FROM  PRINCIPAL  DX IF NO  ADM DX COD E
  40663   "RTN","CHM XPU04",311 ,0)
  40664    D DEBUG^C HMXDR01("C HMXPU04: P DXCD CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  40665   "RTN","CHM XPU04",312 ,0)
  40666    Q:'$D(^CH MXCLE(CHCL EI,0))  Q: $P(^CHMXCL E(CHCLEI,0 ),"^",4)=" "  Q:$P(^C HMXCLE(CHC LEI,0),"^" ,5)=""  S  ZZTOS=$P(^ CHMXCLE(CH CLEI,0),"^ ",4)
  40667   "RTN","CHM XPU04",313 ,0)
  40668    I ZZTOS'= "" I ($P(^ CHMXCLE(CH CLEI,0),"^ ",5)="A")& ($D(^CHMXD IC(741201. 03,"D",1,Z ZTOS))) D   G PDXCD1
  40669   "RTN","CHM XPU04",314 ,0)
  40670    .I '$D(^C HMXCLE(CHC LEI,40)) S  CHSUB1=49 ,CHSUB2=1, CHEDRJ="E4 01a",CHHCQ LF="",CHFL PN=0,CHFLD (CHFLPN)=" " D SETDTA  Q
  40671   "RTN","CHM XPU04",315 ,0)
  40672    .I '$D(^C HMXCLE(CHC LEI,40,1,0 )) S CHSUB 1=49,CHSUB 2=1,CHEDRJ ="E401a",C HHCQLF="", CHFLPN=0,C HFLD(CHFLP N)="" D SE TDTA Q
  40673   "RTN","CHM XPU04",316 ,0)
  40674    .I $P(^CH MXCLE(CHCL EI,40,1,0) ,"^",1)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" E401a",CHH CQLF="",CH FLPN=0,CHF LD(CHFLPN) ="" D SETD TA Q
  40675   "RTN","CHM XPU04",317 ,0)
  40676    .I '$D(^C HMXCLE(CHC LEI,42)) D
  40677   "RTN","CHM XPU04",318 ,0)
  40678    ..S:'$D(^ CHMXCLE(CH CLEI,42,0) ) ^CHMXCLE (CHCLEI,42 ,0)="^7412 10.1242^0^ 0"
  40679   "RTN","CHM XPU04",319 ,0)
  40680    ..S $P(^C HMXCLE(CHC LEI,42,0), "^",3)=$P( ^CHMXCLE(C HCLEI,42,0 ),"^",3)+1 ,EI=$P(^CH MXCLE(CHCL EI,42,0)," ^",3),$P(^ CHMXCLE(CH CLEI,42,0) ,"^",4)=$P (^CHMXCLE( CHCLEI,42, 0),"^",4)+ 1
  40681   "RTN","CHM XPU04",320 ,0)
  40682    ..D DEBUG ^CHMXMDRV( "CHMXPU04:  PDXCD 'J'  = ",EI)
  40683   "RTN","CHM XPU04",321 ,0)
  40684    ..S $P(^C HMXCLE(CHC LEI,42,EI, 0),"^")=$P (^CHMXCLE( CHCLEI,40, 1,0),"^",1 )
  40685   "RTN","CHM XPU04",322 ,0)
  40686    ..S ^CHMX CLE(CHCLEI ,42,"B",$P (^CHMXCLE( CHCLEI,40, 1,0),"^"), EI)=""
  40687   "RTN","CHM XPU04",323 ,0)
  40688   PDXCD1 K C HCODE,ZZTO S Q
  40689   "RTN","CHM XPU04",324 ,0)
  40690    ; 
  40691   "RTN","CHM XPU04",325 ,0)
  40692   GTHCQLF I  '$D(RCD) S  CHEDPRB=" " G GTHCQL F1
  40693   "RTN","CHM XPU04",326 ,0)
  40694    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HHCQLF=$$T RIM^CHMXPU 01(Y)
  40695   "RTN","CHM XPU04",327 ,0)
  40696    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHMXPU 04: GTHCQL F():  CHHC QLF= ",CHH CQLF
  40697   "RTN","CHM XPU04",328 ,0)
  40698    ;I CHHCQL F="" S CHE DPRB="" Q
  40699   "RTN","CHM XPU04",329 ,0)
  40700   GTHCQLF1 K  Y Q
  40701   "RTN","CHM XPU04",330 ,0)
  40702    ;
  40703   "RTN","CHM XPU04",331 ,0)
  40704    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  40705   "RTN","CHM XPU04",332 ,0)
  40706    ; FORMAT  THE DIAGNO STIC CODES  FOR ICD-9  AND ICD-1 0
  40707   "RTN","CHM XPU04",333 ,0)
  40708    ; AT ENTR Y, CHFLD(C HFLPN) CON TAINS THE  DIAGNOSTIC  CODE TO B E FORMATTE D, AND "JZ "
  40709   "RTN","CHM XPU04",334 ,0)
  40710    ; CONTAIN S THE LOCA TION (FROM  THE LEFT)  AT WHICH  TO INSERT  THE "." FO R THE CODE
  40711   "RTN","CHM XPU04",335 ,0)
  40712    ; NOTE: W HEN THE DI AG CODES A RRIVE IN C HMXPU04, T HERE IS A  LEADING "E " IN 
  40713   "RTN","CHM XPU04",336 ,0)
  40714    ; CHFLD(C HFLPN). TH E "E" CODE  IS A SPEC IAL CASE F ROM OSHA(? ) THAT IS  DIFFERENT
  40715   "RTN","CHM XPU04",337 ,0)
  40716    ; FROM AL L OTHER DI AGNOSIS CO DES, THIS  CAUSES THE  $E(CHFLD( CHFLPN)) T O LOCATE T HE 
  40717   "RTN","CHM XPU04",338 ,0)
  40718    ; "." IN  A DIFFEREN T LOCATION  FOR THESE  DIAG CODE S. FOR THI S REASON,  THERE IS A
  40719   "RTN","CHM XPU04",339 ,0)
  40720    ; ADDER T O THE "JZ"  VALUE TO  CORRECTLY  LOCATE THE  DESIRED " ." IN THE  FORMAT. DL B 9/25/201 5
  40721   "RTN","CHM XPU04",340 ,0)
  40722    ; DEBUG F OR DEF0191 58; MODIFI ED THE LOG IC TO ENSU RE THE COR RECT FORMA TTING DLB  10/23/2015   
  40723   "RTN","CHM XPU04",341 ,0)
  40724    ; 2/1/201 6 FIX THE  FORMATTING  ISSUE FOR  "BK" 311  ICD-9 DIAG NOSIS CODE S
  40725   "RTN","CHM XPU04",342 ,0)
  40726    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  40727   "RTN","CHM XPU04",343 ,0)
  40728    ; 
  40729   "RTN","CHM XPU04",344 ,0)
  40730   STFRMT ;SE TS FORMAT  FOR DX/PX  CODES
  40731   "RTN","CHM XPU04",345 ,0)
  40732    D DEBUG^C HMXDR01("  CHMXPU04:  STFRMT():  CHFLD(CHFL PN)="""_CH FLD(CHFLPN )_""" $L(C HFLD(CHFLP N)="_$L(CH FLD(CHFLPN ))_" JZ="_ JZ_" $E(CH FLD(CHFLPN ),1,JZ)=", $E(CHFLD(C HFLPN),1,J Z))
  40733   "RTN","CHM XPU04",346 ,0)
  40734    I $L(CHHC QLF)=2 D   ; ICD-9 CO DE QUALIFI ERS ARE 2  DIGITS
  40735   "RTN","CHM XPU04",347 ,0)
  40736    .I $E(CHF LD(CHFLPN) ,1,1)="E"   D  ; IF T HERE IS A  LEADING "E " FOR DIAG  CODE
  40737   "RTN","CHM XPU04",348 ,0)
  40738    ..S:$L(CH FLD(CHFLPN ))>JZ+1 CH FLD(CHFLPN )=$E(CHFLD (CHFLPN),1 ,JZ+1)_"." _$E(CHFLD( CHFLPN),JZ +2,99)
  40739   "RTN","CHM XPU04",349 ,0)
  40740    .E  S:$L( CHFLD(CHFL PN))>JZ CH FLD(CHFLPN )=$E(CHFLD (CHFLPN),1 ,JZ)_"."_$ E(CHFLD(CH FLPN),JZ+1 ,99)  ; IC D-9; NORMA L FORMATTI NG
  40741   "RTN","CHM XPU04",350 ,0)
  40742    .I (CHFLD (CHFLPN))[ "." D  ; E NSURE THER E IS A "."  IN THE CO DE BEFORE  GOING FORW ARD
  40743   "RTN","CHM XPU04",351 ,0)
  40744    ..I $P(CH FLD(CHFLPN ),".",2)=" " D                         ; IF  NO VALUES  AFTER THE  ".", NO " ." REQUIRE D
  40745   "RTN","CHM XPU04",352 ,0)
  40746    ...S CHFL PNLG=$L(CH FLD(CHFLPN )),CHFLD(C HFLPN)=$E( CHFLD(CHFL PN),1,CHFL PNLG-1)
  40747   "RTN","CHM XPU04",353 ,0)
  40748    ...K CHFL PNLG
  40749   "RTN","CHM XPU04",354 ,0)
  40750    E  S:$L(C HFLD(CHFLP N))>JZ CHF LD(CHFLPN) =$E(CHFLD( CHFLPN),1, JZ)_"."_$E (CHFLD(CHF LPN),JZ+1, 99)   ; IC D-10 QUALI FIERS ARE  3 DIGITS
  40751   "RTN","CHM XPU04",355 ,0)
  40752    D DEBUG^C HMXDR01("  CHMXPU04:  EXIT STFRM T(): CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  40753   "RTN","CHM XPU04",356 ,0)
  40754   STFRMT1 K  JZ Q
  40755   "RTN","CHM XPU04",357 ,0)
  40756    ;
  40757   "RTN","CHM XPU04",358 ,0)
  40758   STTC ;SETS  FORMAT FO R TC CODES
  40759   "RTN","CHM XPU04",359 ,0)
  40760    Q
  40761   "RTN","CHM XPU04",360 ,0)
  40762    ; 
  40763   "RTN","CHM XPU04",361 ,0)
  40764   STDR ;SETS  FORMAT FO R DR CODES
  40765   "RTN","CHM XPU04",362 ,0)
  40766    Q
  40767   "RTN","CHM XPU04",363 ,0)
  40768    ; 
  40769   "RTN","CHM XPU04",364 ,0)
  40770   SETDTA ;SE TS APPROPR IATE HC CO DE DATA UP  IN CHDTA  ARRAYS
  40771   "RTN","CHM XPU04",365 ,0)
  40772    D DEBUG^C HMXDR01("         CHM XPU04: SET DTA CHFLD( CHFLPN)= " "",CHFLD(C HFLPN)_""" ^"_CHSUB1_ "^"_CHSUB2 )
  40773   "RTN","CHM XPU04",366 ,0)
  40774    Q:CHSUB1= "NONE"
  40775   "RTN","CHM XPU04",367 ,0)
  40776    I '$D(CHD TA(CHSUB1, CHSUB2)) S  CHVAR=0 S :CHSUB1'=4 9 CHDTA(CH SUB1,CHSUB 2,CHVAR)=" " D  Q:((C HHCQLF["BK ")!(CHHCQL F["BR")!(C HHCQLF["BP "))&(CHSUB 1'=49)
  40777   "RTN","CHM XPU04",368 ,0)
  40778    .I (CHHCQ LF["BK")!( CHHCQLF["B R")!(CHHCQ LF["BP")!( CHHCQLF["B J"),CHSUB1 '=49 S CHD TA(CHSUB1, CHSUB2,CHV AR)=CHFLD( CHFLPN) Q
  40779   "RTN","CHM XPU04",369 ,0)
  40780    S CHVAR=9 999,CHVAR= $O(CHDTA(C HSUB1,CHSU B2,CHVAR), -1)+1
  40781   "RTN","CHM XPU04",370 ,0)
  40782    I CHSUB1= 49 D  G SE TDTA1
  40783   "RTN","CHM XPU04",371 ,0)
  40784    .;S CHDTA (CHSUB1,CH SUB2,CHVAR )=CHEDRJ_" *"_CHFLD(C HFLPN)
  40785   "RTN","CHM XPU04",372 ,0)
  40786    .I $D(CHX STYP) Q:CH XSTYP=1  ;  QUIT IF O CR -- NO R EJECTS REC ORDED
  40787   "RTN","CHM XPU04",373 ,0)
  40788    .Q:$G(CHE DRJ)="NONE "        ;  QUIT NO E RRORS ARE  TO BE RECO RDED 
  40789   "RTN","CHM XPU04",374 ,0)
  40790    .S CHRCER R(CHXREC,C HEDRJ)="", CHLVLRJ("E ")=""
  40791   "RTN","CHM XPU04",375 ,0)
  40792    S CHDTA(C HSUB1,CHSU B2,CHVAR)= CHFLD(CHFL PN)
  40793   "RTN","CHM XPU04",376 ,0)
  40794   SETDTA1 K  CHSUB1,CHS UB2,CHVAR  Q
  40795   "RTN","CHM XPU04",377 ,0)
  40796    ; 
  40797   "RTN","CHM XPU04",378 ,0)
  40798   BTQICT ;MA TCH BILL T YPE QUALIF IER TO IC  TYPE
  40799   "RTN","CHM XPU04",379 ,0)
  40800    Q:$D(CHRC ERR(CHXREC ,"E05a"))   Q:'$D(^CH MXCLA(CHCL AI,0))
  40801   "RTN","CHM XPU04",380 ,0)
  40802    S CHICTYP =$E($P(^CH MXCLA(CHCL AI,0),"^", 14),7,99)  Q:CHICTYP= ""
  40803   "RTN","CHM XPU04",381 ,0)
  40804    I (CHFLD( CHFLPN)="A ")&(CHICTY P'="HOSP")  D RCDERR^ CHMXPU01 G  BTQICT1
  40805   "RTN","CHM XPU04",382 ,0)
  40806    I (CHFLD( CHFLPN)="B ")&(CHICTY P'="PHYS")  D RCDERR^ CHMXPU01 G  BTQICT1
  40807   "RTN","CHM XPU04",383 ,0)
  40808   BTQICT1 K  CHICTYP Q
  40809   "RTN","CHM XPU04",384 ,0)
  40810    ; 
  40811   "RTN","CHM XPU04",385 ,0)
  40812   GETODT ;PU LLS THE TO  DATE FOR  OCC/OCC SP AN CODES T O COMPARE  TO THRU DA TE
  40813   "RTN","CHM XPU04",386 ,0)
  40814    I '$D(RCD ) S CHEDPR B="" G GET ODT1
  40815   "RTN","CHM XPU04",387 ,0)
  40816    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HTODT=$$TR IM^CHMXPU0 1(Y)
  40817   "RTN","CHM XPU04",388 ,0)
  40818   GETODT1 Q
  40819   "RTN","CHM XPU04",389 ,0)
  40820    ; 
  40821   "RTN","CHM XPU04",390 ,0)
  40822   GETHRDT ;P ULLS THE T HROUGH DAT E FOR OCC/ OCC SPAN C ODES TO CO MPARE TO T O DATE
  40823   "RTN","CHM XPU04",391 ,0)
  40824    I '$D(RCD ) S CHEDPR B="" G GET HRDT1
  40825   "RTN","CHM XPU04",392 ,0)
  40826    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HTHRDT=$$T RIM^CHMXPU 01(Y)
  40827   "RTN","CHM XPU04",393 ,0)
  40828   GETHRDT1 Q
  40829   "RTN","CHM XPU04",394 ,0)
  40830    ; 
  40831   "RTN","CHM XPU04",395 ,0)
  40832   ICNDCNMS ; MISSING IC N/DCN # WH EN CLAIM F REQUENCY =  5,7 OR 8
  40833   "RTN","CHM XPU04",396 ,0)
  40834    Q:$D(CHRC ERR(CHXREC ,"E33a"))   Q:'$D(^CH MXCLE(CHCL EI,0))
  40835   "RTN","CHM XPU04",397 ,0)
  40836    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6) Q :'CHFREQ
  40837   "RTN","CHM XPU04",398 ,0)
  40838    I (((CHFR EQ=7)!(CHF REQ=8))&(C HFLD(CHFLP N)="")) D  RCDERR^CHM XPU01 G IC NDCN1
  40839   "RTN","CHM XPU04",399 ,0)
  40840    I CHFREQ= 8 D  G ICN DCN1
  40841   "RTN","CHM XPU04",400 ,0)
  40842    .Q:'$D(^C HMPAY("B", CHFLD(CHFL PN)))
  40843   "RTN","CHM XPU04",401 ,0)
  40844    .S CHMXCL MI=0,CHMXC LMI=$O(^CH MPAY("B",C HFLD(CHFLP N),CHMXCLM I))
  40845   "RTN","CHM XPU04",402 ,0)
  40846    .Q:CHMXCL MI=""
  40847   "RTN","CHM XPU04",403 ,0)
  40848    .S CHMXCL M=CHFLD(CH FLPN)
  40849   "RTN","CHM XPU04",404 ,0)
  40850    .D ^CHMXM M06 Q
  40851   "RTN","CHM XPU04",405 ,0)
  40852   ICNDCN1 K  CHFREQ,CHM XCLMI,CHMX CLM Q
  40853   "RTN","CHM XPU04",406 ,0)
  40854    ; 
  40855   "RTN","CHM XPU04",407 ,0)
  40856    ;Methodic al-5010 Ch ange-Begin
  40857   "RTN","CHM XPU04",408 ,0)
  40858   ICNBLANK ; BLANK OR N O MATCHING  ICN/DCN #  WHEN CLAI M FREQUENC Y = 7 OR 8
  40859   "RTN","CHM XPU04",409 ,0)
  40860    N CHFREQ
  40861   "RTN","CHM XPU04",410 ,0)
  40862    Q:'$D(^CH MXCLE(CHCL EI,0))
  40863   "RTN","CHM XPU04",411 ,0)
  40864    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6) Q :'CHFREQ
  40865   "RTN","CHM XPU04",412 ,0)
  40866    Q:CHFREQ' =7&(CHFREQ '=8)
  40867   "RTN","CHM XPU04",413 ,0)
  40868    I CHFLD(C HFLPN)=""  D RCDERR^C HMXPU01 Q
  40869   "RTN","CHM XPU04",414 ,0)
  40870    Q:$D(^CHM PAY("B",CH FLD(CHFLPN )))!($D(^C HMIMAGE(CH FLD(CHFLPN ))))
  40871   "RTN","CHM XPU04",415 ,0)
  40872    D RCDERR^ CHMXPU01
  40873   "RTN","CHM XPU04",416 ,0)
  40874    Q
  40875   "RTN","CHM XPU04",417 ,0)
  40876    ;
  40877   "RTN","CHM XPU04",418 ,0)
  40878   ICNVOID  ;  If freque ncy code e quals 8 -  check for  Original P DI in Read y Queue
  40879   "RTN","CHM XPU04",419 ,0)
  40880    ; CPE 005 -038 origi nal PDI fo und in EDI -Reopen Re ady queue  and has no t yet been  worked on  by a VE.
  40881   "RTN","CHM XPU04",420 ,0)
  40882    N CHFREQ, CHMIEN,CHM STAT,CHMCL M,CHMSTRIP ,CHMNOSTP, CHMFOPDI
  40883   "RTN","CHM XPU04",421 ,0)
  40884    ;K CHFC8C IP ;CPE005 -042
  40885   "RTN","CHM XPU04",422 ,0)
  40886    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  40887   "RTN","CHM XPU04",423 ,0)
  40888    S CHMFOPD I=CHFLD(CH FLPN)
  40889   "RTN","CHM XPU04",424 ,0)
  40890    Q:CHFREQ' =8
  40891   "RTN","CHM XPU04",425 ,0)
  40892    Q:CHMFOPD I=""
  40893   "RTN","CHM XPU04",426 ,0)
  40894    Q:$D(^CHM PAY("C",CH MFOPDI))
  40895   "RTN","CHM XPU04",427 ,0)
  40896    ;***Begin  fix CFS 0 1/31/2019
  40897   "RTN","CHM XPU04",428 ,0)
  40898    ;I $D(^CH MIMG("OCR- READY",CHM FOPDI)) K  ^CHMIMG("O CR-READY", CHMFOPDI)  S CHEDRJ=" E001d",CHR CERR(CHXRE C,CHEDRJ)= "",CHLVLRJ ("E")="" D  KILL(CHMF OPDI) S $P (^CHMIMG(C HMFOPDI,0) ,"^",6)=11
  40899   "RTN","CHM XPU04",429 ,0)
  40900    ;I $D(^CH MIMG("SBOC R-READY",C HMFOPDI))  K ^CHMIMG( "SBOCR-REA DY",CHMFOP DI) S CHED RJ="E001d" ,CHRCERR(C HXREC,CHED RJ)="",CHL VLRJ("E")= "" D KILL( CHMFOPDI)  S $P(^CHMI MG(CHMFOPD I,0),"^",6 )=11
  40901   "RTN","CHM XPU04",430 ,0)
  40902    ;I $D(^CH MIMG("OCRR -READY",CH MFOPDI)) K  ^CHMIMG(" OCRR-READY ",CHMFOPDI ) S CHEDRJ ="E001d",C HRCERR(CHX REC,CHEDRJ )="",CHLVL RJ("E")=""  D KILL(CH MFOPDI) S  $P(^CHMIMG (CHMFOPDI, 0),"^",6)= 11
  40903   "RTN","CHM XPU04",431 ,0)
  40904    ;I $D(^CH MIMG("SBOC RR-READY", CHMFOPDI))  K ^CHMIMG ("SBOCRR-R EADY",CHMF OPDI) S CH EDRJ="E001 d",CHRCERR (CHXREC,CH EDRJ)="",C HLVLRJ("E" )="" D KIL L(CHMFOPDI ) S $P(^CH MIMG(CHMFO PDI,0),"^" ,6)=11
  40905   "RTN","CHM XPU04",432 ,0)
  40906    ;
  40907   "RTN","CHM XPU04",433 ,0)
  40908    ;If the O riginal PD I is found  in the Re ady and ha s not been  worked on  by a VE,  Kill it ou t of the R eady queue  and the I mage files
  40909   "RTN","CHM XPU04",434 ,0)
  40910    I $D(^CHM IMG("OCR-R EADY",CHMF OPDI)) K ^ CHMIMG("OC R-READY",C HMFOPDI) S  CHEDRJ="E 001d",CHRC ERR(CHXREC ,CHEDRJ)=" ",CHLVLRJ( "E")=""
  40911   "RTN","CHM XPU04",435 ,0)
  40912    I $D(^CHM IMG("SBOCR -READY",CH MFOPDI)) K  ^CHMIMG(" SBOCR-READ Y",CHMFOPD I) S CHEDR J="E001d", CHRCERR(CH XREC,CHEDR J)="",CHLV LRJ("E")=" "
  40913   "RTN","CHM XPU04",436 ,0)
  40914    I $D(^CHM IMG("OCRR- READY",CHM FOPDI)) K  ^CHMIMG("O CRR-READY" ,CHMFOPDI)  S CHEDRJ= "E001d",CH RCERR(CHXR EC,CHEDRJ) ="",CHLVLR J("E")=""
  40915   "RTN","CHM XPU04",437 ,0)
  40916    I $D(^CHM IMG("SBOCR R-READY",C HMFOPDI))  K ^CHMIMG( "SBOCRR-RE ADY",CHMFO PDI) S CHE DRJ="E001d ",CHRCERR( CHXREC,CHE DRJ)="",CH LVLRJ("E") =""
  40917   "RTN","CHM XPU04",438 ,0)
  40918    S DIK="^C HMIMG(",DA =CHMFOPDI  D ^DIK K D IK
  40919   "RTN","CHM XPU04",439 ,0)
  40920    S DIK="^C HMIMAGE(", DA=CHMFOPD I D ^DIK K  DIK
  40921   "RTN","CHM XPU04",440 ,0)
  40922    K ^CHMIMG ("A-ALL",C HMFOPDI)
  40923   "RTN","CHM XPU04",441 ,0)
  40924    K ^CHMIMG ("A-FIRST" ,CHMFOPDI)
  40925   "RTN","CHM XPU04",442 ,0)
  40926    Q
  40927   "RTN","CHM XPU04",443 ,0)
  40928   ICN42 ;BDB ; CPE005-0 42; Testin g for Orig inal PDI i n process  and all cl aims in pr ocess
  40929   "RTN","CHM XPU04",444 ,0)
  40930    N CHFREQ, CHMFOPDI,C HMIEN,CHMC LM,CHMSTAT ,CHMSTRIP, CHMNOSTP
  40931   "RTN","CHM XPU04",445 ,0)
  40932    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  40933   "RTN","CHM XPU04",446 ,0)
  40934    S CHMFOPD I=CHFLD(CH FLPN)
  40935   "RTN","CHM XPU04",447 ,0)
  40936    Q:CHFREQ' =8
  40937   "RTN","CHM XPU04",448 ,0)
  40938    Q:CHMFOPD I=""
  40939   "RTN","CHM XPU04",449 ,0)
  40940    Q:'$D(^CH MIMG(CHMFO PDI,0))
  40941   "RTN","CHM XPU04",450 ,0)
  40942    Q:'$D(^CH MPAY("C",C HMFOPDI))
  40943   "RTN","CHM XPU04",451 ,0)
  40944    K CHFC8CI P
  40945   "RTN","CHM XPU04",452 ,0)
  40946    S CHMIEN= 0,CHMSTAT= 0,CHMSTRIP =1
  40947   "RTN","CHM XPU04",453 ,0)
  40948    F  S CHMI EN=$O(^CHM PAY("C",CH MFOPDI,CHM IEN)) Q:CH MIEN=""  D
  40949   "RTN","CHM XPU04",454 ,0)
  40950    .; Check  claim stat us
  40951   "RTN","CHM XPU04",455 ,0)
  40952    .S CHMSTA T=$P($G(^C HMPAY(CHMI EN,0)),"^" ,2)
  40953   "RTN","CHM XPU04",456 ,0)
  40954    .S CHMCLM (CHMIEN)=" "
  40955   "RTN","CHM XPU04",457 ,0)
  40956    .S:CHMSTA T'=1 CHMST RIP=0
  40957   "RTN","CHM XPU04",458 ,0)
  40958    Q:CHMSTRI P=0
  40959   "RTN","CHM XPU04",459 ,0)
  40960    ;STRIP Or iginal PDI
  40961   "RTN","CHM XPU04",460 ,0)
  40962    N CHMSTRI P2
  40963   "RTN","CHM XPU04",461 ,0)
  40964    ;Strip PD I as defin d by the S trip Submi ssion Opti on
  40965   "RTN","CHM XPU04",462 ,0)
  40966    S CHMSTRI P2=$$START ^CHMFSTP1E (CHMFOPDI)
  40967   "RTN","CHM XPU04",463 ,0)
  40968    Q:CHMSTRI P2=0
  40969   "RTN","CHM XPU04",464 ,0)
  40970    ;Set STAT US OF Orig inal PDI t o VOIDED
  40971   "RTN","CHM XPU04",465 ,0)
  40972    S DIE=741 000.2,DA=C HMFOPDI,DR =".06///11 " D ^DIE K  DIE ;void ed
  40973   "RTN","CHM XPU04",466 ,0)
  40974    ;Set all  Claim stat us to Void ed
  40975   "RTN","CHM XPU04",467 ,0)
  40976    S CHMIEN= 0
  40977   "RTN","CHM XPU04",468 ,0)
  40978    F  S CHMI EN=$O(CHMC LM(CHMIEN) ) Q:CHMIEN =""  D
  40979   "RTN","CHM XPU04",469 ,0)
  40980    .Q:'$D(^C HMPAY(CHMI EN,0))
  40981   "RTN","CHM XPU04",470 ,0)
  40982    .S DIE=74 1000,DA=CH MIEN,DR=". 02///11" D  ^DIE K DI E ;voided
  40983   "RTN","CHM XPU04",471 ,0)
  40984    S CHFC8CI P=1
  40985   "RTN","CHM XPU04",472 ,0)
  40986    S CHEDRJ= "E001d",CH RCERR(CHXR EC,CHEDRJ) =""
  40987   "RTN","CHM XPU04",473 ,0)
  40988    Q
  40989   "RTN","CHM XPU04",474 ,0)
  40990    ;
  40991   "RTN","CHM XPU04",475 ,0)
  40992   ICNVOID2   ; If frequ ency code  equals 8 -  check for  valid Ori ginal PDI  and reject  all claim s that are  in "in pr ocess"
  40993   "RTN","CHM XPU04",476 ,0)
  40994    ; HM/SS;  cpe005-043  TOB FC 8  All Claims  Lines Not  Complete
  40995   "RTN","CHM XPU04",477 ,0)
  40996    ; Removed  code and  added quit  to preven t use of t his Tag TG H - CPE005 -043 - 2/1 5/18
  40997   "RTN","CHM XPU04",478 ,0)
  40998    Q
  40999   "RTN","CHM XPU04",479 ,0)
  41000    ;
  41001   "RTN","CHM XPU04",480 ,0)
  41002   ICNNULL  ;  CPE005-04 0 - Correc ted claim:  If freque ncy code e quals 5 an d original  PDI is nu ll...
  41003   "RTN","CHM XPU04",481 ,0)
  41004            ;  CPE005-01 4 - Null a nd Frequen cy Code 8
  41005   "RTN","CHM XPU04",482 ,0)
  41006    N CHFREQ
  41007   "RTN","CHM XPU04",483 ,0)
  41008    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  41009   "RTN","CHM XPU04",484 ,0)
  41010    S CHMFOPD I=CHFLD(CH FLPN)
  41011   "RTN","CHM XPU04",485 ,0)
  41012    I CHFREQ' =5,CHFREQ' =7,CHFREQ' =8 Q
  41013   "RTN","CHM XPU04",486 ,0)
  41014    Q:CHMFOPD I'=""
  41015   "RTN","CHM XPU04",487 ,0)
  41016    S CHEDRJ= "E33b"
  41017   "RTN","CHM XPU04",488 ,0)
  41018    S CHRCERR (CHXREC,CH EDRJ)="",C HLVLRJ("E" )=""
  41019   "RTN","CHM XPU04",489 ,0)
  41020    Q
  41021   "RTN","CHM XPU04",490 ,0)
  41022    ;
  41023   "RTN","CHM XPU04",491 ,0)
  41024   KILL(CHMFP DI) ;cpe00 5-038
  41025   "RTN","CHM XPU04",492 ,0)
  41026    D KILPDI^ CHMFADR1
  41027   "RTN","CHM XPU04",493 ,0)
  41028    Q
  41029   "RTN","CHM XPU04",494 ,0)
  41030    ;Methodic al-5010 Ch ange-End
  41031   "RTN","CHM XPUTL")
  41032   0^90^B8196 849
  41033   "RTN","CHM XPUTL",1,0 )
  41034   CHMXPUTL ; HAC/GEF;X1 2 837 UTIL ITIES (HEA LTH CARE C LAIMS);09/ 04/2017 2: 08 PM
  41035   "RTN","CHM XPUTL",2,0 )
  41036    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  41037   "RTN","CHM XPUTL",3,0 )
  41038    ;
  41039   "RTN","CHM XPUTL",4,0 )
  41040    ; An 837  with Frequ ency type  code "8" i s received .
  41041   "RTN","CHM XPUTL",5,0 )
  41042    ;
  41043   "RTN","CHM XPUTL",6,0 )
  41044    ; User St ory CPE005 -033: The  Original P DI is not  valid 
  41045   "RTN","CHM XPUTL",7,0 )
  41046    ;  The sy stem will  determine  the Origin al PDI is  not valid.  (line-tag  = VALD)
  41047   "RTN","CHM XPUTL",8,0 )
  41048    ;   Origi nal PDI is  not blank , is exact ly 15 char acters and  exists in  the CHAMP VA STORED  IMAGES fil e.
  41049   "RTN","CHM XPUTL",9,0 )
  41050    ;
  41051   "RTN","CHM XPUTL",10, 0)
  41052    ; User St ory CPE005 -038:  The  Original  PDI has no t started  initial pr ocessing b y a Vouche r Examiner  (VE) (lin e-tage = P DIP)
  41053   "RTN","CHM XPUTL",11, 0)
  41054    ;  The Or iginal PDI  in the Bu ffer File  (Queue) wi ll be KILL ED.  (line -tag = REM V) 
  41055   "RTN","CHM XPUTL",12, 0)
  41056    ;  
  41057   "RTN","CHM XPUTL",13, 0)
  41058    Q
  41059   "RTN","CHM XPUTL",14, 0)
  41060    ;
  41061   "RTN","CHM XPUTL",15, 0)
  41062   VALD(CHMIC N) ; deter mine if Or iginal PDI  is valid
  41063   "RTN","CHM XPUTL",16, 0)
  41064    ;CHMICN i s original  ICN/DCN R EF NO (HAC  Claim#)
  41065   "RTN","CHM XPUTL",17, 0)
  41066    ;CHMFPDI  IS origina l PDI NUMB ER
  41067   "RTN","CHM XPUTL",18, 0)
  41068    ;Returns  - 0; NOT V ALID PDI
  41069   "RTN","CHM XPUTL",19, 0)
  41070    ;           1; VALID  PDI
  41071   "RTN","CHM XPUTL",20, 0)
  41072    ;
  41073   "RTN","CHM XPUTL",21, 0)
  41074    Q:CHMICN= "" 0
  41075   "RTN","CHM XPUTL",22, 0)
  41076    N CHMFPDI ,CHMCPDI
  41077   "RTN","CHM XPUTL",23, 0)
  41078    S CHMFPDI =$$COPDI(C HMICN),CHM CPDI=$P(CH MFPDI,"^", 2),CHMFPDI =$P(CHMFPD I,"^")
  41079   "RTN","CHM XPUTL",24, 0)
  41080    Q:+CHMFPD I=0 0
  41081   "RTN","CHM XPUTL",25, 0)
  41082    Q:+CHMCPD I=0 1
  41083   "RTN","CHM XPUTL",26, 0)
  41084    I $$CHKOP DI^CHMFADR 2(CHMCPDI, CHMFPDI,"" ,0) D CSTA T(CHMCPDI, "F2:464:73 6") Q 0
  41085   "RTN","CHM XPUTL",27, 0)
  41086    Q 1
  41087   "RTN","CHM XPUTL",28, 0)
  41088    ;  
  41089   "RTN","CHM XPUTL",29, 0)
  41090   REMV(CHMIC N)  ; remo ve Origina l PDI from  all buffe r files
  41091   "RTN","CHM XPUTL",30, 0)
  41092    ;CHMICN i s original  ICN/DCN R EF NO (HAC  Claim#)
  41093   "RTN","CHM XPUTL",31, 0)
  41094    ;CHMFPDI  IS origina l PDI NUMB ER
  41095   "RTN","CHM XPUTL",32, 0)
  41096    ;Returns  - 0; PDI p rocessed,  do NOT rem ove from b uffer
  41097   "RTN","CHM XPUTL",33, 0)
  41098    ;           >0; PDI  not proces sed, remov e from buf fer
  41099   "RTN","CHM XPUTL",34, 0)
  41100    ;
  41101   "RTN","CHM XPUTL",35, 0)
  41102    N CHMFPDI ,CHRLT,CHM CPDI
  41103   "RTN","CHM XPUTL",36, 0)
  41104    S CHMFPDI =$$COPDI(C HMICN),CHM CPDI=$P(CH MFPDI,"^", 2),CHMFPDI =$P(CHMFPD I,"^")
  41105   "RTN","CHM XPUTL",37, 0)
  41106    Q:+CHMFPD I=0 0
  41107   "RTN","CHM XPUTL",38, 0)
  41108    S CHRLT=0
  41109   "RTN","CHM XPUTL",39, 0)
  41110    I $D(^CHM IMG("OCR-R EADY",CHMF PDI)) D    ;CVA EDI
  41111   "RTN","CHM XPUTL",40, 0)
  41112    .K ^CHMIM G("OCR-REA DY",CHMFPD I) S CHRLT =1
  41113   "RTN","CHM XPUTL",41, 0)
  41114    .Q
  41115   "RTN","CHM XPUTL",42, 0)
  41116    I $D(^CHM IMG("OCR2- READY",CHM FPDI)) D   ;CVA OCR
  41117   "RTN","CHM XPUTL",43, 0)
  41118    .K ^CHMIM G("OCR2-RE ADY",CHMFP DI) S CHRL T=2
  41119   "RTN","CHM XPUTL",44, 0)
  41120    .Q
  41121   "RTN","CHM XPUTL",45, 0)
  41122    I $D(^CHM IMG("SBOCR -READY",CH MFPDI)) D   ;SB EDI
  41123   "RTN","CHM XPUTL",46, 0)
  41124    .K ^CHMIM G("SBOCR-R EADY",CHMF PDI) S CHR LT=3
  41125   "RTN","CHM XPUTL",47, 0)
  41126    .Q
  41127   "RTN","CHM XPUTL",48, 0)
  41128    I $D(^CHM IMG("SBOCR 2-READY",C HMFPDI)) D   ;SB OCR
  41129   "RTN","CHM XPUTL",49, 0)
  41130    .K ^CHMIM G("SBOCR2- READY",CHM FPDI) S CH RLT=4
  41131   "RTN","CHM XPUTL",50, 0)
  41132    .Q
  41133   "RTN","CHM XPUTL",51, 0)
  41134    I $D(^CHM IMG("READY ",CHMFPDI) ) D  ;ZIPZ AP QUEUE
  41135   "RTN","CHM XPUTL",52, 0)
  41136    .K ^CHMIM G("READY", CHMFPDI) S  CHRLT=5
  41137   "RTN","CHM XPUTL",53, 0)
  41138    .Q
  41139   "RTN","CHM XPUTL",54, 0)
  41140    I $D(^CHM IMG("OCRR- READY",CHM FPDI)) D    ;Reopen E DI
  41141   "RTN","CHM XPUTL",55, 0)
  41142    .K ^CHMIM G("OCRR-RE ADY",CHMFP DI) S CHRL T=6
  41143   "RTN","CHM XPUTL",56, 0)
  41144    .Q
  41145   "RTN","CHM XPUTL",57, 0)
  41146    I $D(^CHM IMG("SBOCR R-READY",C HMFPDI)) D    ;Reopen  SB EDI
  41147   "RTN","CHM XPUTL",58, 0)
  41148    .K ^CHMIM G("SBOCRR- READY",CHM FPDI) S CH RLT=7
  41149   "RTN","CHM XPUTL",59, 0)
  41150    .Q
  41151   "RTN","CHM XPUTL",60, 0)
  41152    Q:+CHMCPD I=0 CHRLT
  41153   "RTN","CHM XPUTL",61, 0)
  41154    I CHRLT>0  D CSTAT(C HMCPDI,"F0 :686")
  41155   "RTN","CHM XPUTL",62, 0)
  41156    Q CHRLT
  41157   "RTN","CHM XPUTL",63, 0)
  41158    ;
  41159   "RTN","CHM XPUTL",64, 0)
  41160   COPDI(CHMI CN) ; get  current an d original  PDI#'s fr om 837 ICN /DCN REF N O
  41161   "RTN","CHM XPUTL",65, 0)
  41162    ; CHMICN  is origina l claim#
  41163   "RTN","CHM XPUTL",66, 0)
  41164    ; Returns  - 0 ;can' t find PDI
  41165   "RTN","CHM XPUTL",67, 0)
  41166    ;            Origina l PDI#_^_C urrent PDI #
  41167   "RTN","CHM XPUTL",68, 0)
  41168    ;
  41169   "RTN","CHM XPUTL",69, 0)
  41170    S CHMFPDI =$P($P($G( ^CHMPAY(CH MICN,0))," ^",4),"*")  Q:CHMFPDI ="" 0
  41171   "RTN","CHM XPUTL",70, 0)
  41172    S CHMCPDI =$O(^CHMIM G("AE",CHM FPDI,""))
  41173   "RTN","CHM XPUTL",71, 0)
  41174    Q CHMFPDI _"^"_CHMCP DI
  41175   "RTN","CHM XPUTL",72, 0)
  41176    ;
  41177   "RTN","CHM XPUTL",73, 0)
  41178   CSTAT(CHMC PDI,CHEC)  ; send CST AT for CUR RENT PDI
  41179   "RTN","CHM XPUTL",74, 0)
  41180    ; 
  41181   "RTN","CHM XPUTL",75, 0)
  41182    N CHRLT
  41183   "RTN","CHM XPUTL",76, 0)
  41184    Q:CHEC=""
  41185   "RTN","CHM XPUTL",77, 0)
  41186    Q:+CHMCPD I=0
  41187   "RTN","CHM XPUTL",78, 0)
  41188    S CHRLT=$ $PDIFINAL^ CHCSTAT(CH MCPDI,CHEC )
  41189   "RTN","CHM XPUTL",79, 0)
  41190    Q
  41191   "RTN","CHM XPUTL",80, 0)
  41192    ;
  41193   "RTN","CHM XPUTL",81, 0)
  41194   STRIP(CHMF OPDI,CHMFP DI) ;
  41195   "RTN","CHM XPUTL",82, 0)
  41196    ; Input -  CHMFOPDI  = original  PDI#
  41197   "RTN","CHM XPUTL",83, 0)
  41198    ;          CHMFPDI -  current P DI#
  41199   "RTN","CHM XPUTL",84, 0)
  41200    ; returns  0 or 1; 0  = not str ipped; 1 =  stripped
  41201   "RTN","CHM XPUTL",85, 0)
  41202    ; need to  obtain th e Original  PDI so th at it can  be strippe d.  
  41203   "RTN","CHM XPUTL",86, 0)
  41204    ; status  of the Ori ginal PDI  will need  to be set  to VOIDED.
  41205   "RTN","CHM XPUTL",87, 0)
  41206    ; ALERT f or CSTAT m essage wil l need to  be sent fo r the curr ent PDI wi th the ale rt contain ing the VO IDED statu s
  41207   "RTN","CHM XPUTL",88, 0)
  41208    N STRIP
  41209   "RTN","CHM XPUTL",89, 0)
  41210    D START^C HMFEDISTP1 (CHMFOPDI, .STRIP)
  41211   "RTN","CHM XPUTL",90, 0)
  41212    I STRIP D  
  41213   "RTN","CHM XPUTL",91, 0)
  41214    . S $P(^C HMIMG(CHMF OPDI,0),"^ ",6)=11  ;  if the Or iginal PDI  was strip ped set ST ATUS OF PD I (741000. 2,.06) to  VOIDED
  41215   "RTN","CHM XPUTL",92, 0)
  41216    D CSTAT(C HMFPDI,"F0 :686")
  41217   "RTN","CHM XPUTL",93, 0)
  41218    Q STRIP
  41219   "RTN","CHM XPUTL5")
  41220   0^91^B9219 590
  41221   "RTN","CHM XPUTL5",1, 0)
  41222   CHMXPUTL ; HAC/GEF;X1 2 837 UTIL ITIES (HEA LTH CARE C LAIMS);09/ 04/2017 2: 08 PM
  41223   "RTN","CHM XPUTL5",2, 0)
  41224    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  9
  41225   "RTN","CHM XPUTL5",3, 0)
  41226    ;
  41227   "RTN","CHM XPUTL5",4, 0)
  41228    ; An 837  with Frequ ency type  code "8" i s received .
  41229   "RTN","CHM XPUTL5",5, 0)
  41230    ;
  41231   "RTN","CHM XPUTL5",6, 0)
  41232    ; User St ory CPE005 -033: The  Original P DI is not  valid 
  41233   "RTN","CHM XPUTL5",7, 0)
  41234    ;  The sy stem will  determine  the Origin al PDI is  not valid.  (line-tag  = VALD)
  41235   "RTN","CHM XPUTL5",8, 0)
  41236    ;   Origi nal PDI is  not blank , is exact ly 15 char acters and  exists in  the CHAMP VA STORED  IMAGES fil e.
  41237   "RTN","CHM XPUTL5",9, 0)
  41238    ;
  41239   "RTN","CHM XPUTL5",10 ,0)
  41240    ; User St ory CPE005 -038:  The  Original  PDI has no t started  initial pr ocessing b y a Vouche r Examiner  (VE) (lin e-tage = P DIP)
  41241   "RTN","CHM XPUTL5",11 ,0)
  41242    ;  The Or iginal PDI  in the Bu ffer File  (Queue) wi ll be KILL ED.  (line -tag = REM V)
  41243   "RTN","CHM XPUTL5",12 ,0)
  41244    ;
  41245   "RTN","CHM XPUTL5",13 ,0)
  41246    ; User St ory CPE005 -042:  Ori ginal PDI  is in proc ess and al l claims/l ines are i n process.  The syste m will "st rip" the O riginal PD I
  41247   "RTN","CHM XPUTL5",14 ,0)
  41248    ; and set  the statu s of the O riginal PD I to VOIDE D. The sys tem will t rigger an  alert for  CSTAT mess age to be  sent.  The  alert 
  41249   "RTN","CHM XPUTL5",15 ,0)
  41250    ; will be  for the c urrent PDI  and the a lert will  contain th e status o f VOIDED.   (line tag  = STRIP)
  41251   "RTN","CHM XPUTL5",16 ,0)
  41252    ;  
  41253   "RTN","CHM XPUTL5",17 ,0)
  41254    ;
  41255   "RTN","CHM XPUTL5",18 ,0)
  41256    ; An 837  with Frequ ency type  code "5" i s received .
  41257   "RTN","CHM XPUTL5",19 ,0)
  41258    ;
  41259   "RTN","CHM XPUTL5",20 ,0)
  41260    ; User St ory CPE005 -040: The  Original P DI is null  
  41261   "RTN","CHM XPUTL5",21 ,0)
  41262    ;  The sy stem will  determine  the Origin al PDI is  null. (lin e-tag = NU LL)
  41263   "RTN","CHM XPUTL5",22 ,0)
  41264    ;   Origi nal PDI is  not blank , is exact ly 15 char acters and  exists in  the CHAMP VA STORED  IMAGES fil e.
  41265   "RTN","CHM XPUTL5",23 ,0)
  41266    ;
  41267   "RTN","CHM XPUTL5",24 ,0)
  41268    ; Q
  41269   "RTN","CHM XPUTL5",25 ,0)
  41270    ;
  41271   "RTN","CHM XPUTL5",26 ,0)
  41272   VALD(CHMIC N) ; deter mine if Or iginal PDI  is valid
  41273   "RTN","CHM XPUTL5",27 ,0)
  41274    ;CHMICN i s original  ICN/DCN R EF NO (HAC  Claim#)
  41275   "RTN","CHM XPUTL5",28 ,0)
  41276    ;CHMFPDI  IS origina l PDI NUMB ER
  41277   "RTN","CHM XPUTL5",29 ,0)
  41278    ;Returns  - 0; NOT V ALID PDI
  41279   "RTN","CHM XPUTL5",30 ,0)
  41280    ;           1; VALID  PDI
  41281   "RTN","CHM XPUTL5",31 ,0)
  41282    ;
  41283   "RTN","CHM XPUTL5",32 ,0)
  41284    Q:CHMICN= "" 0
  41285   "RTN","CHM XPUTL5",33 ,0)
  41286    N CHMFPDI ,CHMCPDI
  41287   "RTN","CHM XPUTL5",34 ,0)
  41288    S CHMFPDI =$$COPDI(C HMICN),CHM CPDI=$P(CH MFPDI,"^", 2),CHMFPDI =$P(CHMFPD I,"^")
  41289   "RTN","CHM XPUTL5",35 ,0)
  41290    Q:+CHMFPD I=0 0
  41291   "RTN","CHM XPUTL5",36 ,0)
  41292    Q:+CHMCPD I=0 1
  41293   "RTN","CHM XPUTL5",37 ,0)
  41294    I $$CHKOP DI^CHMFADR 2(CHMCPDI, CHMFPDI,"" ,0) D CSTA T(CHMCPDI, "F2:464:73 6") Q 0
  41295   "RTN","CHM XPUTL5",38 ,0)
  41296    Q 1
  41297   "RTN","CHM XPUTL5",39 ,0)
  41298    ;  
  41299   "RTN","CHM XPUTL5",40 ,0)
  41300   REMV(CHMIC N)  ; remo ve Origina l PDI from  all buffe r files
  41301   "RTN","CHM XPUTL5",41 ,0)
  41302    ;CHMICN i s original  ICN/DCN R EF NO (HAC  Claim#)
  41303   "RTN","CHM XPUTL5",42 ,0)
  41304    ;CHMFPDI  IS origina l PDI NUMB ER
  41305   "RTN","CHM XPUTL5",43 ,0)
  41306    ;Returns  - 0; PDI p rocessed,  do NOT rem ove from b uffer
  41307   "RTN","CHM XPUTL5",44 ,0)
  41308    ;           >0; PDI  not proces sed, remov e from buf fer
  41309   "RTN","CHM XPUTL5",45 ,0)
  41310    ;
  41311   "RTN","CHM XPUTL5",46 ,0)
  41312    N CHMFPDI ,CHRLT,CHM CPDI
  41313   "RTN","CHM XPUTL5",47 ,0)
  41314    S CHMFPDI =$$COPDI(C HMICN),CHM CPDI=$P(CH MFPDI,"^", 2),CHMFPDI =$P(CHMFPD I,"^")
  41315   "RTN","CHM XPUTL5",48 ,0)
  41316    Q:+CHMFPD I=0 0
  41317   "RTN","CHM XPUTL5",49 ,0)
  41318    S CHRLT=0
  41319   "RTN","CHM XPUTL5",50 ,0)
  41320    I $D(^CHM IMG("OCR-R EADY",CHMF PDI)) D    ;CVA EDI
  41321   "RTN","CHM XPUTL5",51 ,0)
  41322    .K ^CHMIM G("OCR-REA DY",CHMFPD I) S CHRLT =1
  41323   "RTN","CHM XPUTL5",52 ,0)
  41324    .Q
  41325   "RTN","CHM XPUTL5",53 ,0)
  41326    I $D(^CHM IMG("OCR2- READY",CHM FPDI)) D   ;CVA OCR
  41327   "RTN","CHM XPUTL5",54 ,0)
  41328    .K ^CHMIM G("OCR2-RE ADY",CHMFP DI) S CHRL T=2
  41329   "RTN","CHM XPUTL5",55 ,0)
  41330    .Q
  41331   "RTN","CHM XPUTL5",56 ,0)
  41332    I $D(^CHM IMG("SBOCR -READY",CH MFPDI)) D   ;SB EDI
  41333   "RTN","CHM XPUTL5",57 ,0)
  41334    .K ^CHMIM G("SBOCR-R EADY",CHMF PDI) S CHR LT=3
  41335   "RTN","CHM XPUTL5",58 ,0)
  41336    .Q
  41337   "RTN","CHM XPUTL5",59 ,0)
  41338    I $D(^CHM IMG("SBOCR 2-READY",C HMFPDI)) D   ;SB OCR
  41339   "RTN","CHM XPUTL5",60 ,0)
  41340    .K ^CHMIM G("SBOCR2- READY",CHM FPDI) S CH RLT=4
  41341   "RTN","CHM XPUTL5",61 ,0)
  41342    .Q
  41343   "RTN","CHM XPUTL5",62 ,0)
  41344    I $D(^CHM IMG("READY ",CHMFPDI) ) D  ;ZIPZ AP QUEUE
  41345   "RTN","CHM XPUTL5",63 ,0)
  41346    .K ^CHMIM G("READY", CHMFPDI) S  CHRLT=5
  41347   "RTN","CHM XPUTL5",64 ,0)
  41348    .Q
  41349   "RTN","CHM XPUTL5",65 ,0)
  41350    I $D(^CHM IMG("OCRR- READY",CHM FPDI)) D    ;Reopen E DI
  41351   "RTN","CHM XPUTL5",66 ,0)
  41352    .K ^CHMIM G("OCRR-RE ADY",CHMFP DI) S CHRL T=6
  41353   "RTN","CHM XPUTL5",67 ,0)
  41354    .Q
  41355   "RTN","CHM XPUTL5",68 ,0)
  41356    I $D(^CHM IMG("SBOCR R-READY",C HMFPDI)) D    ;Reopen  SB EDI
  41357   "RTN","CHM XPUTL5",69 ,0)
  41358    .K ^CHMIM G("SBOCRR- READY",CHM FPDI) S CH RLT=7
  41359   "RTN","CHM XPUTL5",70 ,0)
  41360    .Q
  41361   "RTN","CHM XPUTL5",71 ,0)
  41362    Q:+CHMCPD I=0 CHRLT
  41363   "RTN","CHM XPUTL5",72 ,0)
  41364    I CHRLT>0  D CSTAT(C HMCPDI,"F0 :686")
  41365   "RTN","CHM XPUTL5",73 ,0)
  41366    Q CHRLT
  41367   "RTN","CHM XPUTL5",74 ,0)
  41368    ;
  41369   "RTN","CHM XPUTL5",75 ,0)
  41370   COPDI(CHMI CN) ; get  current an d original  PDI#'s fr om 837 ICN /DCN REF N O
  41371   "RTN","CHM XPUTL5",76 ,0)
  41372    ; CHMICN  is origina l claim#
  41373   "RTN","CHM XPUTL5",77 ,0)
  41374    ; Returns  - 0 ;can' t find PDI
  41375   "RTN","CHM XPUTL5",78 ,0)
  41376    ;            Origina l PDI#_^_C urrent PDI #
  41377   "RTN","CHM XPUTL5",79 ,0)
  41378    ;
  41379   "RTN","CHM XPUTL5",80 ,0)
  41380    S CHMFPDI =$P($P($G( ^CHMPAY(CH MICN,0))," ^",4),"*")  Q:CHMFPDI ="" 0
  41381   "RTN","CHM XPUTL5",81 ,0)
  41382    S CHMCPDI =$O(^CHMIM G("AE",CHM FPDI,""))
  41383   "RTN","CHM XPUTL5",82 ,0)
  41384    Q CHMFPDI _"^"_CHMCP DI
  41385   "RTN","CHM XPUTL5",83 ,0)
  41386    ;
  41387   "RTN","CHM XPUTL5",84 ,0)
  41388   CSTAT(CHMC PDI,CHEC)  ; send CST AT for CUR RENT PDI
  41389   "RTN","CHM XPUTL5",85 ,0)
  41390    ; 
  41391   "RTN","CHM XPUTL5",86 ,0)
  41392    N CHRLT
  41393   "RTN","CHM XPUTL5",87 ,0)
  41394    Q:CHEC=""
  41395   "RTN","CHM XPUTL5",88 ,0)
  41396    Q:+CHMCPD I=0
  41397   "RTN","CHM XPUTL5",89 ,0)
  41398    S CHRLT=$ $PDIFINAL^ CHCSTAT(CH MCPDI,CHEC )
  41399   "RTN","CHM XPUTL5",90 ,0)
  41400    Q
  41401   "RTN","CHM XPUTL5",91 ,0)
  41402    ;
  41403   "RTN","CHM XPUTL5",92 ,0)
  41404   STRIP(CHMF PDI) ;
  41405   "RTN","CHM XPUTL5",93 ,0)
  41406    ; need to  obtain th e Original  PDI so th at it can  be strippe d.  
  41407   "RTN","CHM XPUTL5",94 ,0)
  41408    ; status  of the Ori ginal PDI  will need  to be set  to VOIDED.
  41409   "RTN","CHM XPUTL5",95 ,0)
  41410    ; ALERT f or CSTAT m essage wil l need to  be sent fo r the curr ent PDI wi th the ale rt contain ing the VO IDED statu s
  41411   "RTN","CHM XPUTL5",96 ,0)
  41412    Q
  41413   "RTN","CHM XPUTL5",97 ,0)
  41414    ;
  41415   "RTN","CHM XPUTL5",98 ,0)
  41416   NULL(CHMIC N) ; deter mine if Or iginal PDI  is null
  41417   "RTN","CHM XPUTL5",99 ,0)
  41418    ;CHMICN i s original  ICN/DCN R EF NO (HAC  Claim#)
  41419   "RTN","CHM XPUTL5",10 0,0)
  41420    ;CHMFPDI  IS origina l PDI NUMB ER
  41421   "RTN","CHM XPUTL5",10 1,0)
  41422    ;Returns  - 0; NULL  PDI
  41423   "RTN","CHM XPUTL5",10 2,0)
  41424    ;           1; VALID  PDI
  41425   "RTN","CHM XPUTL5",10 3,0)
  41426    ;
  41427   "RTN","CHM XPUTL5",10 4,0)
  41428    Q:CHMICN= "" 0
  41429   "RTN","CHM XPUTL5",10 5,0)
  41430    N CHMFPDI ,CHMCPDI
  41431   "RTN","CHM XPUTL5",10 6,0)
  41432    S CHMFPDI =$$COPDI(C HMICN),CHM CPDI=$P(CH MFPDI,"^", 2),CHMFPDI =$P(CHMFPD I,"^")
  41433   "RTN","CHM XPUTL5",10 7,0)
  41434    Q:+CHMFPD I=0 0
  41435   "RTN","CHM XPUTL5",10 8,0)
  41436    Q:+CHMCPD I=0 1
  41437   "RTN","CHM XPUTL5",10 9,0)
  41438    I $$CHKOP DI^CHMFADR 2(CHMCPDI, CHMFPDI,"" ,0) D CSTA T(CHMCPDI, "A6:21:464 ") Q 0
  41439   "RTN","CHM XPUTL5",11 0,0)
  41440    Q 1
  41441   "RTN","CHM XPUTL5",11 1,0)
  41442    ;  
  41443   "RTN","CHM XQCNT")
  41444   0^71^B8841 5948
  41445   "RTN","CHM XQCNT",1,0 )
  41446   CHMXQCNT ; CVA/DTP;ED I/OCR QUEU E COUNTS B Y PROGRAM; 03/06/03 1 2:08 PM
  41447   "RTN","CHM XQCNT",2,0 )
  41448    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  41449   "RTN","CHM XQCNT",3,0 )
  41450    ;CFS CPE0 05-021a -  Add CHAMPV A EDI ReOp en to scre en copy.
  41451   "RTN","CHM XQCNT",4,0 )
  41452    ;CFS CPE0 05-021b -  Add Spina  Bifida EDI  ReOpen to  screen co py.
  41453   "RTN","CHM XQCNT",5,0 )
  41454    ;CFS CPE0 05-026 - A dd CHAMPVA  EDI ReOpe n and Spin a Bifida R eOpen to h ard copy. 
  41455   "RTN","CHM XQCNT",6,0 )
  41456   START S (C VEDI,CVOCR ,OCRR,SBED I,SBOCR,SB OCRR,SCAN, ELCTOT)=0
  41457   "RTN","CHM XQCNT",7,0 )
  41458    K ^CHMZHO LD($J,"ELE C")
  41459   "RTN","CHM XQCNT",8,0 )
  41460    F QTYPE=" OCR-READY" ,"OCR2-REA DY","OCRR- READY","SB OCRR-READY ","SBOCR-R EADY","SBO CR2-READY" ,"READY" D  COUNT
  41461   "RTN","CHM XQCNT",9,0 )
  41462    D ^CHMFSE T X CHRESE T W @IOF
  41463   "RTN","CHM XQCNT",10, 0)
  41464    S HEADER= "HEALTH AD MINISTRATI ON CENTER"
  41465   "RTN","CHM XQCNT",11, 0)
  41466    S CHBLANK =" "
  41467   "RTN","CHM XQCNT",12, 0)
  41468    W @CHREVO N,@CHBON,? (95-$L(HEA DER)/2),HE ADER,@CHEO L,?79
  41469   "RTN","CHM XQCNT",13, 0)
  41470    W !,@CHRE VON,@CHBON ,CHBLANK
  41471   "RTN","CHM XQCNT",14, 0)
  41472    S TITLE=" EDI/EDI Re Open/OCR/Z Z IMG INVE NTORY COUN T"
  41473   "RTN","CHM XQCNT",15, 0)
  41474    W @CHBON, ?(80-$L(TI TLE)/2),TI TLE,?80,@C HEOL,@CHRE VOFF,@CHBO FF
  41475   "RTN","CHM XQCNT",16, 0)
  41476    W !,"The  number of  CVA EDI su bmissions  in Ready Q ueue: ",CV EDI
  41477   "RTN","CHM XQCNT",17, 0)
  41478    I CVEDI>0  W !,?10," Two Oldest  Dates:"
  41479   "RTN","CHM XQCNT",18, 0)
  41480    D
  41481   "RTN","CHM XQCNT",19, 0)
  41482    .S CHPDT= 0
  41483   "RTN","CHM XQCNT",20, 0)
  41484    .F I=1:1: 2 S CHPDT= $O(^CHMZHO LD($J,"ELE C","OCR-RE ADY",CHPDT )) Q:'CHPD T  D
  41485   "RTN","CHM XQCNT",21, 0)
  41486    ..S CHPFM DT=$E(CHPD T,3,7)
  41487   "RTN","CHM XQCNT",22, 0)
  41488    ..I CVEDI >0 I I=1 W  ?30,$$FMT E^XLFDT(($ $JULFM^CHT FLIB(CHPFM DT)),"1D") ," ",$J(^C HMZHOLD($J ,"ELEC","O CR-READY", CHPDT),6,0 )
  41489   "RTN","CHM XQCNT",23, 0)
  41490    ..I CVEDI >0 I I>1 W  !,?30,$$F MTE^XLFDT( ($$JULFM^C HTFLIB(CHP FMDT)),"1D ")," ",$J( ^CHMZHOLD( $J,"ELEC", "OCR-READY ",CHPDT),6 ,0)
  41491   "RTN","CHM XQCNT",24, 0)
  41492    W !,"The  number of  SB EDI sub missions i n Ready Qu eue: ",SBE DI
  41493   "RTN","CHM XQCNT",25, 0)
  41494    I SBEDI>0  W !,?10," Two Oldest  Dates:"
  41495   "RTN","CHM XQCNT",26, 0)
  41496     D
  41497   "RTN","CHM XQCNT",27, 0)
  41498    .S CHPDT= 0
  41499   "RTN","CHM XQCNT",28, 0)
  41500    .F I=1:1: 2 S CHPDT= $O(^CHMZHO LD($J,"ELE C","SBOCR- READY",CHP DT)) Q:'CH PDT  D
  41501   "RTN","CHM XQCNT",29, 0)
  41502    ..S CHPFM DT=$E(CHPD T,3,7)
  41503   "RTN","CHM XQCNT",30, 0)
  41504    ..I SBEDI >0 I I=1 W  ?30,$$FMT E^XLFDT(($ $JULFM^CHT FLIB(CHPFM DT)),"1D") ," ",$J(^C HMZHOLD($J ,"ELEC","S BOCR-READY ",CHPDT),6 ,0)
  41505   "RTN","CHM XQCNT",31, 0)
  41506    ..I SBEDI >0 I I>1 W  !,?30,$$F MTE^XLFDT( ($$JULFM^C HTFLIB(CHP FMDT)),"1D ")," ",$J( ^CHMZHOLD( $J,"ELEC", "SBOCR-REA DY",CHPDT) ,6,0)
  41507   "RTN","CHM XQCNT",32, 0)
  41508    W !,"The  number of  CVA EDI Re Open submi ssions in  Ready Queu e: ",OCRR   ;CPE005-0 21a
  41509   "RTN","CHM XQCNT",33, 0)
  41510    I CVEDI>0  W !,?10," Two Oldest  Dates:"
  41511   "RTN","CHM XQCNT",34, 0)
  41512    D
  41513   "RTN","CHM XQCNT",35, 0)
  41514    .S CHPDT= 0
  41515   "RTN","CHM XQCNT",36, 0)
  41516    .F I=1:1: 2 S CHPDT= $O(^CHMZHO LD($J,"ELE C","OCRR-R EADY",CHPD T)) Q:'CHP DT  D
  41517   "RTN","CHM XQCNT",37, 0)
  41518    ..S CHPFM DT=$E(CHPD T,3,7)
  41519   "RTN","CHM XQCNT",38, 0)
  41520    ..I CVEDI >0 I I=1 W  ?30,$$FMT E^XLFDT(($ $JULFM^CHT FLIB(CHPFM DT)),"1D") ," ",$J(^C HMZHOLD($J ,"ELEC","O CRR-READY" ,CHPDT),6, 0)
  41521   "RTN","CHM XQCNT",39, 0)
  41522    ..I CVEDI >0 I I>1 W  !,?30,$$F MTE^XLFDT( ($$JULFM^C HTFLIB(CHP FMDT)),"1D ")," ",$J( ^CHMZHOLD( $J,"ELEC", "OCRR-READ Y",CHPDT), 6,0)
  41523   "RTN","CHM XQCNT",40, 0)
  41524    W !,"The  number of  SB EDI ReO pen submis sions in R eady Queue : ",SBOCRR   ;CPE005- 021b
  41525   "RTN","CHM XQCNT",41, 0)
  41526    I CVEDI>0  W !,?10," Two Oldest  Dates:"
  41527   "RTN","CHM XQCNT",42, 0)
  41528    D
  41529   "RTN","CHM XQCNT",43, 0)
  41530    .S CHPDT= 0
  41531   "RTN","CHM XQCNT",44, 0)
  41532    .F I=1:1: 2 S CHPDT= $O(^CHMZHO LD($J,"ELE C","SBOCRR -READY",CH PDT)) Q:'C HPDT  D
  41533   "RTN","CHM XQCNT",45, 0)
  41534    ..S CHPFM DT=$E(CHPD T,3,7)
  41535   "RTN","CHM XQCNT",46, 0)
  41536    ..I CVEDI >0 I I=1 W  ?30,$$FMT E^XLFDT(($ $JULFM^CHT FLIB(CHPFM DT)),"1D") ," ",$J(^C HMZHOLD($J ,"ELEC","S BOCRR-READ Y",CHPDT), 6,0)
  41537   "RTN","CHM XQCNT",47, 0)
  41538    ..I CVEDI >0 I I>1 W  !,?30,$$F MTE^XLFDT( ($$JULFM^C HTFLIB(CHP FMDT)),"1D ")," ",$J( ^CHMZHOLD( $J,"ELEC", "SBOCRR-RE ADY",CHPDT ),6,0)
  41539   "RTN","CHM XQCNT",48, 0)
  41540    W !,"The  number of  CVA OCR su bmissions  in Ready Q ueue: ",CV OCR
  41541   "RTN","CHM XQCNT",49, 0)
  41542    I CVOCR>0  W !,?10," Two Oldest  Dates:"
  41543   "RTN","CHM XQCNT",50, 0)
  41544     D
  41545   "RTN","CHM XQCNT",51, 0)
  41546    .S CHPDT= 0
  41547   "RTN","CHM XQCNT",52, 0)
  41548    .F I=1:1: 2 S CHPDT= $O(^CHMZHO LD($J,"ELE C","OCR2-R EADY",CHPD T)) Q:'CHP DT  D
  41549   "RTN","CHM XQCNT",53, 0)
  41550    ..S CHPFM DT=$E(CHPD T,3,7)
  41551   "RTN","CHM XQCNT",54, 0)
  41552    ..I CVOCR >0 I I=1 W  ?30,$$FMT E^XLFDT(($ $JULFM^CHT FLIB(CHPFM DT)),"1D") ," ",$J(^C HMZHOLD($J ,"ELEC","O CR2-READY" ,CHPDT),6, 0)
  41553   "RTN","CHM XQCNT",55, 0)
  41554    ..I CVOCR >0 I I>1 W  !,?30,$$F MTE^XLFDT( ($$JULFM^C HTFLIB(CHP FMDT)),"1D ")," ",$J( ^CHMZHOLD( $J,"ELEC", "OCR2-READ Y",CHPDT), 6,0)
  41555   "RTN","CHM XQCNT",56, 0)
  41556    W !,"The  number of  SB OCR sub missions i n Ready Qu eue: ",SBO CR
  41557   "RTN","CHM XQCNT",57, 0)
  41558     I SBOCR> 0 W !,?10, "Two Oldes t Dates:"
  41559   "RTN","CHM XQCNT",58, 0)
  41560     D
  41561   "RTN","CHM XQCNT",59, 0)
  41562    .S CHPDT= 0
  41563   "RTN","CHM XQCNT",60, 0)
  41564    .F I=1:1: 2 S CHPDT= $O(^CHMZHO LD($J,"ELE C","SBOCR2 -READY",CH PDT)) Q:'C HPDT  D
  41565   "RTN","CHM XQCNT",61, 0)
  41566    ..S CHPFM DT=$E(CHPD T,3,7)
  41567   "RTN","CHM XQCNT",62, 0)
  41568    ..I SBOCR >0 I I=1 W  ?30,$$FMT E^XLFDT(($ $JULFM^CHT FLIB(CHPFM DT)),"1D") ," ",$J(^C HMZHOLD($J ,"ELEC","S BOCR2-READ Y",CHPDT), 6,0)
  41569   "RTN","CHM XQCNT",63, 0)
  41570    ..I SBOCR >0 I I>1 W  !,?30,$$F MTE^XLFDT( ($$JULFM^C HTFLIB(CHP FMDT)),"1D ")," ",$J( ^CHMZHOLD( $J,"ELEC", "SBOCR2-RE ADY",CHPDT ),6,0)
  41571   "RTN","CHM XQCNT",64, 0)
  41572    W !,"The  number of  CVA ZZ IMG  submissio ns in the  Ready Queu e: ",SCAN
  41573   "RTN","CHM XQCNT",65, 0)
  41574    I SCAN>0  W !,?10,"T wo Oldest  Dates:"
  41575   "RTN","CHM XQCNT",66, 0)
  41576     D
  41577   "RTN","CHM XQCNT",67, 0)
  41578    .S CHPDT= 0
  41579   "RTN","CHM XQCNT",68, 0)
  41580    .F I=1:1: 2 S CHPDT= $O(^CHMZHO LD($J,"ELE C","READY" ,CHPDT)) Q :'CHPDT  D
  41581   "RTN","CHM XQCNT",69, 0)
  41582    ..S CHPFM DT=$E(CHPD T,3,7)
  41583   "RTN","CHM XQCNT",70, 0)
  41584    ..I SCAN> 0 I I=1 W  ?30,$$FMTE ^XLFDT(($$ JULFM^CHTF LIB(CHPFMD T)),"1D"), " ",$J(^CH MZHOLD($J, "ELEC","RE ADY",CHPDT ),6,0)
  41585   "RTN","CHM XQCNT",71, 0)
  41586    ..I SCAN> 0 I I>1 W  !,?30,$$FM TE^XLFDT(( $$JULFM^CH TFLIB(CHPF MDT)),"1D" )," ",$J(^ CHMZHOLD($ J,"ELEC"," READY",CHP DT),6,0)
  41587   "RTN","CHM XQCNT",72, 0)
  41588    W !,"TOTA L NUMBER O F SUBMISSI ONS PENDIN G ",ELCTOT
  41589   "RTN","CHM XQCNT",73, 0)
  41590    W !,"Do y ou wish a  printout?  N//" D CSB RS^CHSC2
  41591   "RTN","CHM XQCNT",74, 0)
  41592    Q:$D(DFOU T)  Q:$D(D UOUT)  Q:$ D(DTOUT)
  41593   "RTN","CHM XQCNT",75, 0)
  41594    I $D(DQOU T) D  R X: 30 G START
  41595   "RTN","CHM XQCNT",76, 0)
  41596    .W !,"ENT ER A 'Y' T O PRINT OR  'N' TO EX IT W/O PRI NTING"
  41597   "RTN","CHM XQCNT",77, 0)
  41598    .Q
  41599   "RTN","CHM XQCNT",78, 0)
  41600    S Y=$$UP^ XLFSTR(Y)  S Y=$E(Y,1 )
  41601   "RTN","CHM XQCNT",79, 0)
  41602    I "YN"'[Y  W !,"ANSW ER MUST BE  'Y' OR 'N '" R X:30  G START
  41603   "RTN","CHM XQCNT",80, 0)
  41604    I Y="Y" D  PRT  K ^C HMZHOLD($J ,"ELEC") Q
  41605   "RTN","CHM XQCNT",81, 0)
  41606    W !!,"Pre ss <RETURN > to Conti nue . . ."  R X:300
  41607   "RTN","CHM XQCNT",82, 0)
  41608    K ^CHMZHO LD($J,"ELE C") Q
  41609   "RTN","CHM XQCNT",83, 0)
  41610    ; 
  41611   "RTN","CHM XQCNT",84, 0)
  41612   COUNT S CH PDIVAR=0
  41613   "RTN","CHM XQCNT",85, 0)
  41614   C1 S CHPDI VAR=$O(^CH MIMG(QTYPE ,CHPDIVAR) ) Q:'CHPDI VAR
  41615   "RTN","CHM XQCNT",86, 0)
  41616    S CHPDIDT =$E(CHPDIV AR,1,7)
  41617   "RTN","CHM XQCNT",87, 0)
  41618    S:'$D(^CH MZHOLD($J, "ELEC",QTY PE,CHPDIDT )) ^CHMZHO LD($J,"ELE C",QTYPE,C HPDIDT)=0
  41619   "RTN","CHM XQCNT",88, 0)
  41620    S ^CHMZHO LD($J,"ELE C",QTYPE,C HPDIDT)=^C HMZHOLD($J ,"ELEC",QT YPE,CHPDID T)+1
  41621   "RTN","CHM XQCNT",89, 0)
  41622    S ELCTOT= ELCTOT+1
  41623   "RTN","CHM XQCNT",90, 0)
  41624    I QTYPE=" OCR-READY"  S CVEDI=C VEDI+1 G C 1
  41625   "RTN","CHM XQCNT",91, 0)
  41626    I QTYPE=" OCR2-READY " S CVOCR= CVOCR+1 G  C1
  41627   "RTN","CHM XQCNT",92, 0)
  41628    I QTYPE=" OCRR-READY " S OCRR=O CRR+1 G C1   ;CPE005- 021a
  41629   "RTN","CHM XQCNT",93, 0)
  41630    I QTYPE=" SBOCRR-REA DY" S SBOC RR=SBOCRR+ 1 G C1  ;C PE005-021b
  41631   "RTN","CHM XQCNT",94, 0)
  41632    I QTYPE=" SBOCR-READ Y" S SBEDI =SBEDI+1 G  C1
  41633   "RTN","CHM XQCNT",95, 0)
  41634    I QTYPE=" SBOCR2-REA DY" S SBOC R=SBOCR+1  G C1
  41635   "RTN","CHM XQCNT",96, 0)
  41636    I QTYPE=" READY" S S CAN=SCAN+1  G C1
  41637   "RTN","CHM XQCNT",97, 0)
  41638    Q
  41639   "RTN","CHM XQCNT",98, 0)
  41640    ;
  41641   "RTN","CHM XQCNT",99, 0)
  41642   PRT ;
  41643   "RTN","CHM XQCNT",100 ,0)
  41644    D NOW^%DT C S RDT=%
  41645   "RTN","CHM XQCNT",101 ,0)
  41646    ;S ZTDTH= RDT
  41647   "RTN","CHM XQCNT",102 ,0)
  41648    K ZTDTH
  41649   "RTN","CHM XQCNT",103 ,0)
  41650    W ! S IOP ="Q" D ^%Z IS G:POP E ND
  41651   "RTN","CHM XQCNT",104 ,0)
  41652    S CHFIO=I ON
  41653   "RTN","CHM XQCNT",105 ,0)
  41654    S %ZIS="Q ",IOP="Q;" _CHFIO D ^ %ZIS G:POP  END
  41655   "RTN","CHM XQCNT",106 ,0)
  41656    S ZTRTN=" P1^CHMXQCN T",ZTDESC= "ELECTRONI C MEDIA CL AIM QUEUES "
  41657   "RTN","CHM XQCNT",107 ,0)
  41658    K ZTIO
  41659   "RTN","CHM XQCNT",108 ,0)
  41660    S ZTSAVE( "^CHMZHOLD ($J,""ELEC "",")="",Z TSAVE("CVE DI")="",ZT SAVE("CVOC R")=""
  41661   "RTN","CHM XQCNT",109 ,0)
  41662    S ZTSAVE( "SBEDI")=" ",ZTSAVE(" SBEDI")="" ,ZTSAVE("S BOCR")=""
  41663   "RTN","CHM XQCNT",110 ,0)
  41664    S ZTSAVE( "SCAN")="" ,ZTSAVE("E LCTOT")=""
  41665   "RTN","CHM XQCNT",111 ,0)
  41666    D ^%ZTLOA D
  41667   "RTN","CHM XQCNT",112 ,0)
  41668    ;D P1^CHM XQCNT
  41669   "RTN","CHM XQCNT",113 ,0)
  41670    Q
  41671   "RTN","CHM XQCNT",114 ,0)
  41672   P1 ;
  41673   "RTN","CHM XQCNT",115 ,0)
  41674    S (CVEDI, CVOCR,OCRR ,SBEDI,SBO CR,SBOCRR, SCAN,ELCTO T)=0 ;AEB  11/15/2010  REMOVED C OMMENT TO  ALLOW RECA LC
  41675   "RTN","CHM XQCNT",116 ,0)
  41676    K ^CHMZHO LD($J,"ELE C") ;AEB 1 1/15/2010  REMOVED CO MMENT TO A LLOW RECAL
  41677   "RTN","CHM XQCNT",117 ,0)
  41678    F QTYPE=" OCR-READY" ,"OCR2-REA DY","OCRR- READY","SB OCRR-READY ","SBOCR-R EADY","SBO CR2-READY" ,"READY" D  COUNT^CHM XQCNT ;AEB  11/15/201 0 REMOVED  COMMENT TO  ALLOW REC ALC
  41679   "RTN","CHM XQCNT",118 ,0)
  41680    S HEADER= "HEALTH AD MINISTRATI ON CENTER"
  41681   "RTN","CHM XQCNT",119 ,0)
  41682    S TAB=(95 -$L(HEADER )/2)-7,PG= 1
  41683   "RTN","CHM XQCNT",120 ,0)
  41684    W ?2,DUZ, ?TAB,HEADE R,?65,"PAG E: ",PG
  41685   "RTN","CHM XQCNT",121 ,0)
  41686    S TITLE=" EDI/EDI RE OPEN/OCR/Z Z IMG INVE NTORY COUN T" D NOW^% DTC S CHTI ME=$P(%,". ",2)
  41687   "RTN","CHM XQCNT",122 ,0)
  41688    W !,?2,$$ FMTE^XLFDT (DT,"5D"), ?TAB,TITLE ,!,?2,$E(C HTIME,1,2) _":"_$E(CH TIME,3,4), !
  41689   "RTN","CHM XQCNT",123 ,0)
  41690    W !,"The  number of  CVA EDI su bmissions  in Ready Q ueue: ",CV EDI
  41691   "RTN","CHM XQCNT",124 ,0)
  41692    I CVEDI>0  W !,?10," Dates:"
  41693   "RTN","CHM XQCNT",125 ,0)
  41694    D
  41695   "RTN","CHM XQCNT",126 ,0)
  41696    .S CHPDT= 0,ICNT=0
  41697   "RTN","CHM XQCNT",127 ,0)
  41698    .F  S CHP DT=$O(^CHM ZHOLD($J," ELEC","OCR -READY",CH PDT)) Q:'C HPDT  D
  41699   "RTN","CHM XQCNT",128 ,0)
  41700    ..S CHPFM DT=$E(CHPD T,3,7),ICN T=ICNT+1
  41701   "RTN","CHM XQCNT",129 ,0)
  41702    ..I CVEDI >0 I ICNT= 1 W ?30,$$ FMTE^XLFDT (($$JULFM^ CHTFLIB(CH PFMDT)),"1 D")," ",$J (^CHMZHOLD ($J,"ELEC" ,"OCR-READ Y",CHPDT), 6,0)
  41703   "RTN","CHM XQCNT",130 ,0)
  41704    ..I CVEDI >0 I ICNT> 1 W !,?30, $$FMTE^XLF DT(($$JULF M^CHTFLIB( CHPFMDT)), "1D")," ", $J(^CHMZHO LD($J,"ELE C","OCR-RE ADY",CHPDT ),6,0)
  41705   "RTN","CHM XQCNT",131 ,0)
  41706    W !!,"The  number of  SB EDI su bmissions  in Ready Q ueue: ",SB EDI
  41707   "RTN","CHM XQCNT",132 ,0)
  41708    I SBEDI>0  W !,?10," Dates:"
  41709   "RTN","CHM XQCNT",133 ,0)
  41710     D
  41711   "RTN","CHM XQCNT",134 ,0)
  41712    .S CHPDT= 0,ICNT=0
  41713   "RTN","CHM XQCNT",135 ,0)
  41714    .F  S CHP DT=$O(^CHM ZHOLD($J," ELEC","SBO CR-READY", CHPDT)) Q: 'CHPDT  D
  41715   "RTN","CHM XQCNT",136 ,0)
  41716    ..S CHPFM DT=$E(CHPD T,3,7),ICN T=ICNT+1
  41717   "RTN","CHM XQCNT",137 ,0)
  41718    ..I SBEDI >0 I ICNT= 1 W ?30,$$ FMTE^XLFDT (($$JULFM^ CHTFLIB(CH PFMDT)),"1 D")," ",$J (^CHMZHOLD ($J,"ELEC" ,"SBOCR-RE ADY",CHPDT ),6,0)
  41719   "RTN","CHM XQCNT",138 ,0)
  41720    ..I SBEDI >0 I ICNT> 1 W !,?30, $$FMTE^XLF DT(($$JULF M^CHTFLIB( CHPFMDT)), "1D")," ", $J(^CHMZHO LD($J,"ELE C","SBOCR- READY",CHP DT),6,0)
  41721   "RTN","CHM XQCNT",139 ,0)
  41722    W !!,"The  number of  CVA EDI R eOpen subm issions in  Ready Que ue: ",OCRR   ;CPE005- 026
  41723   "RTN","CHM XQCNT",140 ,0)
  41724    I CVEDI>0  W !,?10," Dates:"
  41725   "RTN","CHM XQCNT",141 ,0)
  41726    D
  41727   "RTN","CHM XQCNT",142 ,0)
  41728    .S CHPDT= 0,ICNT=0
  41729   "RTN","CHM XQCNT",143 ,0)
  41730    .F  S CHP DT=$O(^CHM ZHOLD($J," ELEC","OCR R-READY",C HPDT)) Q:' CHPDT  D
  41731   "RTN","CHM XQCNT",144 ,0)
  41732    ..S CHPFM DT=$E(CHPD T,3,7),ICN T=ICNT+1
  41733   "RTN","CHM XQCNT",145 ,0)
  41734    ..I CVEDI >0 I ICNT= 1 W ?30,$$ FMTE^XLFDT (($$JULFM^ CHTFLIB(CH PFMDT)),"1 D")," ",$J (^CHMZHOLD ($J,"ELEC" ,"OCRR-REA DY",CHPDT) ,6,0)
  41735   "RTN","CHM XQCNT",146 ,0)
  41736    ..I CVEDI >0 I ICNT> 1 W !,?30, $$FMTE^XLF DT(($$JULF M^CHTFLIB( CHPFMDT)), "1D")," ", $J(^CHMZHO LD($J,"ELE C","OCRR-R EADY",CHPD T),6,0)
  41737   "RTN","CHM XQCNT",147 ,0)
  41738    W !!,"The  number of  SB EDI Re Open submi ssions in  Ready Queu e: ",SBOCR R  ;CPE005 -026
  41739   "RTN","CHM XQCNT",148 ,0)
  41740    I CVEDI>0  W !,?10," Dates:"
  41741   "RTN","CHM XQCNT",149 ,0)
  41742    D
  41743   "RTN","CHM XQCNT",150 ,0)
  41744    .S CHPDT= 0,ICNT=0
  41745   "RTN","CHM XQCNT",151 ,0)
  41746    .F  S CHP DT=$O(^CHM ZHOLD($J," ELEC","SBO CRR-READY" ,CHPDT)) Q :'CHPDT  D
  41747   "RTN","CHM XQCNT",152 ,0)
  41748    ..S CHPFM DT=$E(CHPD T,3,7),ICN T=ICNT+1
  41749   "RTN","CHM XQCNT",153 ,0)
  41750    ..I CVEDI >0 I ICNT= 1 W ?30,$$ FMTE^XLFDT (($$JULFM^ CHTFLIB(CH PFMDT)),"1 D")," ",$J (^CHMZHOLD ($J,"ELEC" ,"SBOCRR-R EADY",CHPD T),6,0)
  41751   "RTN","CHM XQCNT",154 ,0)
  41752    ..I CVEDI >0 I ICNT> 1 W !,?30, $$FMTE^XLF DT(($$JULF M^CHTFLIB( CHPFMDT)), "1D")," ", $J(^CHMZHO LD($J,"ELE C","SBOCRR -READY",CH PDT),6,0)
  41753   "RTN","CHM XQCNT",155 ,0)
  41754    W !!,"The  number of  CVA OCR s ubmissions  in Ready  Queue: ",C VOCR
  41755   "RTN","CHM XQCNT",156 ,0)
  41756    I CVOCR>0  W !,?10," Dates:"
  41757   "RTN","CHM XQCNT",157 ,0)
  41758     D
  41759   "RTN","CHM XQCNT",158 ,0)
  41760    .S CHPDT= 0,ICNT=0
  41761   "RTN","CHM XQCNT",159 ,0)
  41762    .F  S CHP DT=$O(^CHM ZHOLD($J," ELEC","OCR 2-READY",C HPDT)) Q:' CHPDT  D
  41763   "RTN","CHM XQCNT",160 ,0)
  41764    ..S CHPFM DT=$E(CHPD T,3,7),ICN T=ICNT+1
  41765   "RTN","CHM XQCNT",161 ,0)
  41766    ..I CVOCR >0 I ICNT= 1 W ?30,$$ FMTE^XLFDT (($$JULFM^ CHTFLIB(CH PFMDT)),"1 D")," ",$J (^CHMZHOLD ($J,"ELEC" ,"OCR2-REA DY",CHPDT) ,6,0)
  41767   "RTN","CHM XQCNT",162 ,0)
  41768    ..I CVOCR >0 I ICNT> 1 W !,?30, $$FMTE^XLF DT(($$JULF M^CHTFLIB( CHPFMDT)), "1D")," ", $J(^CHMZHO LD($J,"ELE C","OCR2-R EADY",CHPD T),6,0)
  41769   "RTN","CHM XQCNT",163 ,0)
  41770    W !!,"The  number of  SB OCR su bmissions  in Ready Q ueue: ",SB OCR
  41771   "RTN","CHM XQCNT",164 ,0)
  41772     I SBOCR> 0 W !,?10, "Dates:"
  41773   "RTN","CHM XQCNT",165 ,0)
  41774     D
  41775   "RTN","CHM XQCNT",166 ,0)
  41776    .S CHPDT= 0,ICNT=0
  41777   "RTN","CHM XQCNT",167 ,0)
  41778    .F  S CHP DT=$O(^CHM ZHOLD($J," ELEC","SBO CR2-READY" ,CHPDT)) Q :'CHPDT  D
  41779   "RTN","CHM XQCNT",168 ,0)
  41780    ..S CHPFM DT=$E(CHPD T,3,7),ICN T=ICNT+1
  41781   "RTN","CHM XQCNT",169 ,0)
  41782    ..I SBOCR >0 I ICNT= 1 W ?30,$$ FMTE^XLFDT (($$JULFM^ CHTFLIB(CH PFMDT)),"1 D")," ",$J (^CHMZHOLD ($J,"ELEC" ,"SBOCR2-R EADY",CHPD T),6,0)
  41783   "RTN","CHM XQCNT",170 ,0)
  41784    ..I SBOCR >0 I ICNT> 1 W !,?30, $$FMTE^XLF DT(($$JULF M^CHTFLIB( CHPFMDT)), "1D")," ", $J(^CHMZHO LD($J,"ELE C","SBOCR2 -READY",CH PDT),6,0)
  41785   "RTN","CHM XQCNT",171 ,0)
  41786    W !!,"The  number of  CVA ZZ IM G submissi ons in the  Ready Que ue: ",SCAN
  41787   "RTN","CHM XQCNT",172 ,0)
  41788    I SCAN>0  W !,?10,"D ates:"
  41789   "RTN","CHM XQCNT",173 ,0)
  41790    D
  41791   "RTN","CHM XQCNT",174 ,0)
  41792    .S CHPDT= 0,ICNT=0
  41793   "RTN","CHM XQCNT",175 ,0)
  41794    .F  S CHP DT=$O(^CHM ZHOLD($J," ELEC","REA DY",CHPDT) ) Q:'CHPDT   D
  41795   "RTN","CHM XQCNT",176 ,0)
  41796    ..S CHPFM DT=$E(CHPD T,3,7),ICN T=ICNT+1
  41797   "RTN","CHM XQCNT",177 ,0)
  41798    ..I SCAN> 0 I ICNT=1  W ?30,$$F MTE^XLFDT( ($$JULFM^C HTFLIB(CHP FMDT)),"1D ")," ",$J( ^CHMZHOLD( $J,"ELEC", "READY",CH PDT),6,0)
  41799   "RTN","CHM XQCNT",178 ,0)
  41800    ..I SCAN> 0 I ICNT>1  W !,?30,$ $FMTE^XLFD T(($$JULFM ^CHTFLIB(C HPFMDT))," 1D")," ",$ J(^CHMZHOL D($J,"ELEC ","READY", CHPDT),6,0 )
  41801   "RTN","CHM XQCNT",179 ,0)
  41802    W !!,"TOT AL NUMBER  OF SUBMISS IONS PENDI NG ",ELCTO T
  41803   "RTN","CHM XQCNT",180 ,0)
  41804     K ^CHMZH OLD($J,"EL EC")
  41805   "RTN","CHM XQCNT",181 ,0)
  41806     Q
  41807   "RTN","CHM XQCNT",182 ,0)
  41808    ;
  41809   "RTN","CHM XQCNT",183 ,0)
  41810   END ;
  41811   "RTN","CHM XQCNT",184 ,0)
  41812    K ^CHMZHO LD($J,"ELE C")
  41813   "RTN","CHM XQCNT",185 ,0)
  41814    Q
  41815   "RTN","CHM XQCNT",186 ,0)
  41816   PCNT S CHP DIVAR=0
  41817   "RTN","CHM XQCNT",187 ,0)
  41818   PC1 S CHPD IVAR=$O(^C HMIMG(QTYP E,CHPDIVAR )) Q:'CHPD IVAR
  41819   "RTN","CHM XQCNT",188 ,0)
  41820    S CHPDIDT =$E(CHPDIV AR,1,7)
  41821   "RTN","CHM XQCNT",189 ,0)
  41822    S:'$D(^CH MZHOLD($J, "ELEC",QTY PE,CHPDIDT )) ^CHMZHO LD($J,"ELE C",QTYPE,C HPDIDT)=0
  41823   "RTN","CHM XQCNT",190 ,0)
  41824    S ^CHMZHO LD($J,"ELE C",QTYPE,C HPDIDT)=^C HMZHOLD($J ,"ELEC",QT YPE,CHPDID T)+1
  41825   "RTN","CHM XQCNT",191 ,0)
  41826    I QTYPE=" OCR-READY"  S CVEDI=C VEDI+1 G P C1
  41827   "RTN","CHM XQCNT",192 ,0)
  41828    I QTYPE=" OCR2-READY " S CVOCR= CVOCR+1 G  PC1
  41829   "RTN","CHM XQCNT",193 ,0)
  41830    I QTYPE=" OCRR-READY " S OCRR=O CRR+1 G PC 1  ;CPE005 -026
  41831   "RTN","CHM XQCNT",194 ,0)
  41832    I QTYPE=" SBOCRR-REA DY" S SBOC RR=SBOCRR+ 1 G PC1  ; CPE005-026
  41833   "RTN","CHM XQCNT",195 ,0)
  41834    I QTYPE=" SBOCR-READ Y" S SBEDI =SBEDI+1 G  PC1  
  41835   "RTN","CHM XQCNT",196 ,0)
  41836    I QTYPE=" SBOCR2-REA DY" S SBOC R=SBOCR+1  G PC1
  41837   "RTN","CHM XQCNT",197 ,0)
  41838    I QTYPE=" READY" S S CAN=SCAN+1  G PC1
  41839   "RTN","CHM XQCNT",198 ,0)
  41840    S ELCTOT= ELCTOT+1 G  PC1
  41841   "RTN","CHM XQCNT",199 ,0)
  41842    Q
  41843   "RTN","CHM XWBUT")
  41844   0^94^B2928 193
  41845   "RTN","CHM XWBUT",1,0 )
  41846   CHMXWBUT ; HRL/dlb;WE B 277 UTIL ITY FUNCTI ONS;10/20/ 2010 2:08  PM
  41847   "RTN","CHM XWBUT",2,0 )
  41848    ;;1;5010  MODIFICATI ONS;**14** ;OCT 20,20 10;Build 9
  41849   "RTN","CHM XWBUT",3,0 )
  41850    ;; 10/24/ 2011  ADDE D THE GETD TE START/E ND DATE FU NCTION TO  UTILITY RO UTINE.
  41851   "RTN","CHM XWBUT",4,0 )
  41852    ;; 11/1/2 011   ADDE D "FMDUMP"  FUNCTION  FOR THE HC  QUALIFIER  NODES (^C HMXCLE(I,n n,J,0)
  41853   "RTN","CHM XWBUT",5,0 )
  41854    ;; 11/3/2 011  DLB       ADDED  THE "TEST"  UTILITY T HAT WILL D UMP THE CL AIM BUFFER S FOR A
  41855   "RTN","CHM XWBUT",6,0 )
  41856    ;;                                         PROVIDED P DI.
  41857   "RTN","CHM XWBUT",7,0 )
  41858    ;; 11/7/2 011   DLB      ADDED  THE BUFFER  DUMP FOR  THE ^CHMXC L() BATCH  FILE FOR T HE "TEST"  UTILITY
  41859   "RTN","CHM XWBUT",8,0 )
  41860    ;;                                WILL NOT  MOVE INTO  TEST/DEV  UNTIL LATE R DATE
  41861   "RTN","CHM XWBUT",9,0 )
  41862    ;; 11/7/2 011   DLB      ADDED  SAMPLE EXE CUTABLE FU NCTIONS FO R CREATING  A RECORD  FROM A $TE XT DESCRIP TOR
  41863   "RTN","CHM XWBUT",10, 0)
  41864    ;;                                AND TO D OCUMENT TH E $TEXT DE SCRIPTOR A UTOMATICAL LY
  41865   "RTN","CHM XWBUT",11, 0)
  41866    ;; 12/24/ 2013  DLB  MODIFIED T HE GETDTE( ) FUNCTION  TO USE FI LEMAN DATE  ENTRY SO  USER CAN'T  OMIT DATE  ENTRY
  41867   "RTN","CHM XWBUT",12, 0)
  41868    ;;CFS 01/ 24/2018 CP E005-043 -  Added lin e tag GETR ORSN.
  41869   "RTN","CHM XWBUT",13, 0)
  41870    ;;DEF9176 33 BDB 02/ 04/2019 $G (Y)
  41871   "RTN","CHM XWBUT",14, 0)
  41872    ; 
  41873   "RTN","CHM XWBUT",15, 0)
  41874    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  41875   "RTN","CHM XWBUT",16, 0)
  41876    ; TEST EN TRY POINT  FOR THE VE RIFICATION  OF THE LI NE ITEM ST ATUS RECOR DS.                
  41877   "RTN","CHM XWBUT",17, 0)
  41878    ; PROVIDE  THE "I" V ALUE                                                                                                                           
  41879   "RTN","CHM XWBUT",18, 0)
  41880    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  41881   "RTN","CHM XWBUT",19, 0)
  41882    ;DEF01655 4 - modifi ed for new  read and  write func tions -- D RW 01/30/1
  41883   "RTN","CHM XWBUT",20, 0)
  41884   TSTREJ(CHC LFI)
  41885   "RTN","CHM XWBUT",21, 0)
  41886    N IDX,JDX ,CHCLEI,CO UNT,FMDATE ,TIME,DATE STAMP
  41887   "RTN","CHM XWBUT",22, 0)
  41888    S (IDX,JD X,COUNT)=1
  41889   "RTN","CHM XWBUT",23, 0)
  41890    D NOW^%DT C
  41891   "RTN","CHM XWBUT",24, 0)
  41892    S FMDATE= %
  41893   "RTN","CHM XWBUT",25, 0)
  41894    S FMDATE= $$JUSTIFY^ CHMXWBUT(F MDATE,14,0 ,"L")
  41895   "RTN","CHM XWBUT",26, 0)
  41896    S TIME=$$ JUSTIFY^CH MXWBUT($E( FMDATE,9,1 4),6,0,"L" )
  41897   "RTN","CHM XWBUT",27, 0)
  41898    S DATESTA MP=($E(FMD ATE,1,7)+1 7000000)_T IME ; DATE /TIME FILE  CREATED D OWN TO SEC OND
  41899   "RTN","CHM XWBUT",28, 0)
  41900    K CHRJARR
  41901   "RTN","CHM XWBUT",29, 0)
  41902    W !,"TEST  REJ FOR " ,CHCLFI
  41903   "RTN","CHM XWBUT",30, 0)
  41904    S CHCLEI= $G(^CHMXCL F(CHCLFI,0 ))
  41905   "RTN","CHM XWBUT",31, 0)
  41906    D GLINRJR SN^CHMXWBU T(CHCLFI)
  41907   "RTN","CHM XWBUT",32, 0)
  41908    D BLDSTC^ CHMXWB21(" CLM")
  41909   "RTN","CHM XWBUT",33, 0)
  41910    F IDX=1:1  Q:$G(CHRJ ARR(IDX,JD X))=""  D
  41911   "RTN","CHM XWBUT",34, 0)
  41912    .F JDX=1: 1 Q:$G(CHR JARR(IDX,J DX))=""  D
  41913   "RTN","CHM XWBUT",35, 0)
  41914    ..W !,"ID X: ",IDX,"   JDX: ",J DX," = ",$ G(CHRJARR( IDX,JDX))
  41915   "RTN","CHM XWBUT",36, 0)
  41916    Q
  41917   "RTN","CHM XWBUT",37, 0)
  41918   OFILE(DIRF ILE,OFILEM )  ;Perfor ms the FIL E Open fun ction 
  41919   "RTN","CHM XWBUT",38, 0)
  41920    ; DIRFILE   Director y/Filename  to be Ope ned
  41921   "RTN","CHM XWBUT",39, 0)
  41922    ; OFILEM:  File open  descripto r (N=NEW,R =READ,W=WR ITE,L=LOCK ,etc.)       
  41923   "RTN","CHM XWBUT",40, 0)
  41924    ;RETURN:  PASS/FAIL  Indicator
  41925   "RTN","CHM XWBUT",41, 0)
  41926    ;
  41927   "RTN","CHM XWBUT",42, 0)
  41928    N FLAG,TM PIO
  41929   "RTN","CHM XWBUT",43, 0)
  41930    O DIRFILE :OFILEM:5                                ;  Open the f ile with o penfile de scriptors
  41931   "RTN","CHM XWBUT",44, 0)
  41932    S FLAG=$T EST                                      ;         Fin d out if s uccessful
  41933   "RTN","CHM XWBUT",45, 0)
  41934    Q FLAG                                                               ;Retur n Pass/Fai l                                 ;;RETURN  PASS/FAIL
  41935   "RTN","CHM XWBUT",46, 0)
  41936   CLOSEFILE( DIRFILE)
  41937   "RTN","CHM XWBUT",47, 0)
  41938    N TMPIO S  TMPIO=$IO
  41939   "RTN","CHM XWBUT",48, 0)
  41940    C DIRFILE  
  41941   "RTN","CHM XWBUT",49, 0)
  41942    W !,"CLOS ED ",DIRFI LE,!
  41943   "RTN","CHM XWBUT",50, 0)
  41944    Q
  41945   "RTN","CHM XWBUT",51, 0)
  41946           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  41947   "RTN","CHM XWBUT",52, 0)
  41948    ; SUPPORT  FUNCTIONS  FOR THE B LDACK() FU NCTION AND  ON DEMAND  STATISTIC S REPORTIN G                                                                                       ;
  41949   "RTN","CHM XWBUT",53, 0)
  41950    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41951   "RTN","CHM XWBUT",54, 0)
  41952    ; ^CHMDIC (741201.32  FILE IS T HE DEFINIT IONS FILE  FOR THE RE JECTS                                           ;
  41953   "RTN","CHM XWBUT",55, 0)
  41954    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41955   "RTN","CHM XWBUT",56, 0)
  41956     
  41957   "RTN","CHM XWBUT",57, 0)
  41958   GTRXRJRSN( CHCLAI)                          ; TRANSACT ION BUFFER  REJECT RE ASONS
  41959   "RTN","CHM XWBUT",58, 0)
  41960    N RJRSN,C HJVAL
  41961   "RTN","CHM XWBUT",59, 0)
  41962    Q:'CHCLAI  
  41963   "RTN","CHM XWBUT",60, 0)
  41964    S CHJVAL= 0
  41965   "RTN","CHM XWBUT",61, 0)
  41966    I $D(^CHM XCLA(CHCLA I,101,CHJV AL)) D
  41967   "RTN","CHM XWBUT",62, 0)
  41968    .F  S CHJ VAL=$O(^CH MXCLA(CHCL AI,101,CHJ VAL)) Q:'C HJVAL  D
  41969   "RTN","CHM XWBUT",63, 0)
  41970    ..S RJRSN =$P(^CHMXC LA(CHCLAI, 101,CHJVAL ,0),"^",1)
  41971   "RTN","CHM XWBUT",64, 0)
  41972           .. D SORTRJ(R JRSN)
  41973   "RTN","CHM XWBUT",65, 0)
  41974           Q 
  41975   "RTN","CHM XWBUT",66, 0)
  41976    
  41977   "RTN","CHM XWBUT",67, 0)
  41978   GPRORJRSN( CHCLBI)                          ; PROVIDER  BUFFER RE JECT REASO NS
  41979   "RTN","CHM XWBUT",68, 0)
  41980    N RJRSN,C HJVAL
  41981   "RTN","CHM XWBUT",69, 0)
  41982    Q:'CHCLBI  
  41983   "RTN","CHM XWBUT",70, 0)
  41984    S CHJVAL= 0
  41985   "RTN","CHM XWBUT",71, 0)
  41986    I $D(^CHM XCLB(CHCLB I,101,CHJV AL)) D
  41987   "RTN","CHM XWBUT",72, 0)
  41988    .F  S CHJ VAL=$O(^CH MXCLB(CHCL BI,101,CHJ VAL)) Q:'C HJVAL  D
  41989   "RTN","CHM XWBUT",73, 0)
  41990    ..S RJRSN =$P(^CHMXC LB(CHCLBI, 101,CHJVAL ,0),"^",1)
  41991   "RTN","CHM XWBUT",74, 0)
  41992           .. D SORTRJ(R JRSN)
  41993   "RTN","CHM XWBUT",75, 0)
  41994           Q
  41995   "RTN","CHM XWBUT",76, 0)
  41996   GPATRJRSN( CHCLCI)                          ; PATIENT  BUFFER REJ ECT REASON
  41997   "RTN","CHM XWBUT",77, 0)
  41998    N RJRSN,C HJVAL
  41999   "RTN","CHM XWBUT",78, 0)
  42000    Q:'CHCLCI                                                                             
  42001   "RTN","CHM XWBUT",79, 0)
  42002    S CHJVAL= 0
  42003   "RTN","CHM XWBUT",80, 0)
  42004    I $D(^CHM XCLC(CHCLC I,101,CHJV AL)) D 
  42005   "RTN","CHM XWBUT",81, 0)
  42006    .F  S CHJ VAL=$O(^CH MXCLC(CHCL CI,101,CHJ VAL)) Q:'C HJVAL  D       
  42007   "RTN","CHM XWBUT",82, 0)
  42008    ..S RJRSN =$P(^CHMXC LC(CHCLCI, 101,CHJVAL ,0),"^",1)                         
  42009   "RTN","CHM XWBUT",83, 0)
  42010           .. D SORTRJ(R JRSN)                                                            
  42011   "RTN","CHM XWBUT",84, 0)
  42012           Q 
  42013   "RTN","CHM XWBUT",85, 0)
  42014    
  42015   "RTN","CHM XWBUT",86, 0)
  42016   GCLMRJRSN( CHCLEI)                 ; CLAIM  BUFFER REJ ECT REASON
  42017   "RTN","CHM XWBUT",87, 0)
  42018    N RJRSN,C HJVAL
  42019   "RTN","CHM XWBUT",88, 0)
  42020    Q:'CHCLEI                                                                             
  42021   "RTN","CHM XWBUT",89, 0)
  42022           S  CHJVAL=0
  42023   "RTN","CHM XWBUT",90, 0)
  42024           I  $D(^CHMXCL E(CHCLEI,1 01,CHJVAL) ) D 
  42025   "RTN","CHM XWBUT",91, 0)
  42026           .F   S CHJVAL =$O(^CHMXC LE(CHCLEI, 101,CHJVAL )) Q:'CHJV AL  D        
  42027   "RTN","CHM XWBUT",92, 0)
  42028    ..S RJRSN =$P(^CHMXC LE(CHCLEI, 101,CHJVAL ,0),"^",1)                         
  42029   "RTN","CHM XWBUT",93, 0)
  42030           .. D SORTRJ(R JRSN)                                                            
  42031   "RTN","CHM XWBUT",94, 0)
  42032           Q 
  42033   "RTN","CHM XWBUT",95, 0)
  42034           
  42035   "RTN","CHM XWBUT",96, 0)
  42036   GLINRJRSN( CHCLFI)                 ; SERVIC E LINE BUF FER REJECT  REASONS
  42037   "RTN","CHM XWBUT",97, 0)
  42038    N RJRSN,C HJVAL
  42039   "RTN","CHM XWBUT",98, 0)
  42040    Q:'CHCLFI
  42041   "RTN","CHM XWBUT",99, 0)
  42042           S  CHJVAL=0
  42043   "RTN","CHM XWBUT",100 ,0)
  42044    I $D(^CHM XCLF(CHCLF I,101,CHJV AL)) D  
  42045   "RTN","CHM XWBUT",101 ,0)
  42046           .F   S CHJVAL =$O(^CHMXC LF(CHCLFI, 101,CHJVAL )) Q:'CHJV AL  D        
  42047   "RTN","CHM XWBUT",102 ,0)
  42048    ..S RJRSN =$P(^CHMXC LF(CHCLFI, 101,CHJVAL ,0),"^",1)                
  42049   "RTN","CHM XWBUT",103 ,0)
  42050           .. D SORTRJ(R JRSN)
  42051   "RTN","CHM XWBUT",104 ,0)
  42052           Q
  42053   "RTN","CHM XWBUT",105 ,0)
  42054   SORTRJ(RJR SN)  ; SOR T/BUILD RE JECT REASO N ARRAY
  42055   "RTN","CHM XWBUT",106 ,0)
  42056    ;      RJ RSN   THE  VALUE TO B E CHECKED/ ADDED
  42057   "RTN","CHM XWBUT",107 ,0)
  42058    N EXIT,TV AL,IDX,JDX ,REJCODES
  42059   "RTN","CHM XWBUT",108 ,0)
  42060    S TVAL=0, EXIT=0,REJ CODES=0
  42061   "RTN","CHM XWBUT",109 ,0)
  42062    F IDX=1:1  S TVAL=$G (CHRJARR(I DX)) Q:((T VAL="")!(E XIT=1))  D
  42063   "RTN","CHM XWBUT",110 ,0)
  42064    .I TVAL=R JRSN S EXI T=1 
  42065   "RTN","CHM XWBUT",111 ,0)
  42066    I 'EXIT   D
  42067   "RTN","CHM XWBUT",112 ,0)
  42068    .S CHRJAR R(IDX)=RJR SN                                              ; SET  THE REJECT  REASON IN DEX
  42069   "RTN","CHM XWBUT",113 ,0)
  42070    .S CHRJAR R(0)=$G(CH RJARR(0))+ 1                           ; IN CREMENT TH E COUNTER
  42071   "RTN","CHM XWBUT",114 ,0)
  42072    .F JDX=1: 1 Q:REJCOD ES=""  D
  42073   "RTN","CHM XWBUT",115 ,0)
  42074    ..S REJCO DES=$P($G( ^CHMXDIC(7 41201.32,R JRSN,0))," ^",JDX+3)
  42075   "RTN","CHM XWBUT",116 ,0)
  42076    ..S CHRJA RR(IDX,JDX )=REJCODES
  42077   "RTN","CHM XWBUT",117 ,0)
  42078    Q
  42079   "RTN","CHM XWBUT",118 ,0)
  42080   GETRORSN(C HCLEI,ERRS TR,CHRJARR )  ;Get Re open Rejec t Reason.
  42081   "RTN","CHM XWBUT",119 ,0)
  42082       ;ERRST R = Error  string con taining Re open Rejec t Codes (i e. F0*686* ;)
  42083   "RTN","CHM XWBUT",120 ,0)
  42084       N CHJV AL,ERR,REO PRSN,RSNIE N,FOUND
  42085   "RTN","CHM XWBUT",121 ,0)
  42086       S CHJV AL=0 F  S  CHJVAL=$O( ^CHMXCLE(C HCLEI,101, CHJVAL)) Q :'CHJVAL   D
  42087   "RTN","CHM XWBUT",122 ,0)
  42088       .S RSN IEN=$P($G( ^CHMXCLE(C HCLEI,101, CHJVAL,0)) ,"^")
  42089   "RTN","CHM XWBUT",123 ,0)
  42090       .I RSN IEN S REOP RSN=$P($G( ^CHMXDIC(7 41201.32,R SNIEN,0)), "^",4)
  42091   "RTN","CHM XWBUT",124 ,0)
  42092       .I REO PRSN'="" S  ERRARRAY( REOPRSN)=" "
  42093   "RTN","CHM XWBUT",125 ,0)
  42094       S FOUN D=0,REOPRS N=""
  42095   "RTN","CHM XWBUT",126 ,0)
  42096       F ERR= 1:1 S REOP RSN=$P(ERR STR,";",ER R) Q:$P(ER RSTR,";",E RR)=""!(FO UND)  D
  42097   "RTN","CHM XWBUT",127 ,0)
  42098       .I $D( ERRARRAY(R EOPRSN)) S  CHRJARR(1 ,1)=REOPRS N,FOUND=1
  42099   "RTN","CHM XWBUT",128 ,0)
  42100       Q
  42101   "RTN","CHM XWBUT",129 ,0)
  42102   GETIS(BUF, INDEX)
  42103   "RTN","CHM XWBUT",130 ,0)
  42104    N CHCLFI, CHCLEI,CHC LBI,CHCLAI ,CHCLI
  42105   "RTN","CHM XWBUT",131 ,0)
  42106    I BUF="F"   W !,"CHC LFI= ",IND EX  D
  42107   "RTN","CHM XWBUT",132 ,0)
  42108    .S CHCLEI =$P($G(^CH MXCLF(INDE X)),"^",1)  W !,"CHCL EI = ",CHC LEI
  42109   "RTN","CHM XWBUT",133 ,0)
  42110    .S CHCLCI =$P(^CHMXC LE(CHCLEI, 0),"^",1)  W !,"CHCLC I= ",CHCLC I            ;TRAVERS E BACK THR OUGH BUFFE R FILES
  42111   "RTN","CHM XWBUT",134 ,0)
  42112    .S CHCLBI =$P(^CHMXC LC(CHCLCI, 0),"^",1)  W !,"CHCLB I= ",CHCLB I
  42113   "RTN","CHM XWBUT",135 ,0)
  42114    .S CHCLAI =$P(^CHMXC LB(CHCLBI, 0),"^",1)  W !,"CHCLA I= ",CHCLA I
  42115   "RTN","CHM XWBUT",136 ,0)
  42116    .S CHCLI= $P(^CHMXCL A(CHCLAI,0 ),"^",1) W  !,"CHCLI=  ",CHCLI
  42117   "RTN","CHM XWBUT",137 ,0)
  42118    E  I BUF= "E" S CHCL FI=0 F  S  CHCLFI=$O( ^CHMXCLF(" B",CHCLEI, CHCLFI)) W  !,"CHCLFI = ",CHCLFI   D
  42119   "RTN","CHM XWBUT",138 ,0)
  42120    .W !,"CHC LEI= ",CHC LEI
  42121   "RTN","CHM XWBUT",139 ,0)
  42122    .S CHCLCI =$P(^CHMXC LE(CHCLEI, 0),"^",1)  W !,"CHCLC I= ",CHCLC I            ;TRAVERS E BACK THR OUGH BUFFE R FILES
  42123   "RTN","CHM XWBUT",140 ,0)
  42124    .S CHCLBI =$P(^CHMXC LC(CHCLCI, 0),"^",1)  W !,"CHCLB I= ",CHCLB I
  42125   "RTN","CHM XWBUT",141 ,0)
  42126    .S CHCLAI =$P(^CHMXC LB(CHCLBI, 0),"^",1)  W !,"CHCLA I= ",CHCLA I
  42127   "RTN","CHM XWBUT",142 ,0)
  42128    .S CHCLI= $P(^CHMXCL A(CHCLAI,0 ),"^",1) W  !,"CHCLI=  ",CHCLI
  42129   "RTN","CHM XWBUT",143 ,0)
  42130    E  I BUF= "C"  D
  42131   "RTN","CHM XWBUT",144 ,0)
  42132     W !,"CHC LCI= ",CHC LCI
  42133   "RTN","CHM XWBUT",145 ,0)
  42134    .S CHCLBI =$P(^CHMXC LC(CHCLCI, 0),"^",1)  W !,"CHCLB I= ",CHCLB I
  42135   "RTN","CHM XWBUT",146 ,0)
  42136    .S CHCLAI =$P(^CHMXC LB(CHCLBI, 0),"^",1)  W !,"CHCLA I= ",CHCLA I
  42137   "RTN","CHM XWBUT",147 ,0)
  42138    .S CHCLI= $P(^CHMXCL A(CHCLAI,0 ),"^",1) W  !,"CHCLI=  ",CHCLI
  42139   "RTN","CHM XWBUT",148 ,0)
  42140    E  I BUF= "B" W !,"C HCLBI= ",C HCLCI
  42141   "RTN","CHM XWBUT",149 ,0)
  42142    .S CHCLAI =$P(^CHMXC LB(CHCLBI, 0),"^",1)  W !,"CHCLA I= ",CHCLA I
  42143   "RTN","CHM XWBUT",150 ,0)
  42144    .S CHCLI= $P(^CHMXCL A(CHCLAI,0 ),"^",1) W  !,"CHCLI=  ",CHCLI
  42145   "RTN","CHM XWBUT",151 ,0)
  42146    Q
  42147   "RTN","CHM XWBUT",152 ,0)
  42148    
  42149   "RTN","CHM XWBUT",153 ,0)
  42150    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  42151   "RTN","CHM XWBUT",154 ,0)
  42152    ; GETDTE  THIS FUNCT ION PROMPT S THE USER  FOR START  AND END D ATES FOR A  PROCESS.          
  42153   "RTN","CHM XWBUT",155 ,0)
  42154    ; THE ROU TINE CHECK S THE USER  INPUT FOR  VALID STA RT AND END  DATES PRI OR TO RETU RNING
  42155   "RTN","CHM XWBUT",156 ,0)
  42156    ; THE VAL UES TO THE  CALLER.
  42157   "RTN","CHM XWBUT",157 ,0)
  42158    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  42159   "RTN","CHM XWBUT",158 ,0)
  42160    
  42161   "RTN","CHM XWBUT",159 ,0)
  42162   TESTDATES
  42163   "RTN","CHM XWBUT",160 ,0)
  42164    N FROM,TO
  42165   "RTN","CHM XWBUT",161 ,0)
  42166    D GETDTE( .FROM,.TO)
  42167   "RTN","CHM XWBUT",162 ,0)
  42168    W !,"FROM  = ",FROM, "   TO = " ,TO
  42169   "RTN","CHM XWBUT",163 ,0)
  42170    Q
  42171   "RTN","CHM XWBUT",164 ,0)
  42172    
  42173   "RTN","CHM XWBUT",165 ,0)
  42174    
  42175   "RTN","CHM XWBUT",166 ,0)
  42176    G:$D(DFOU T) END^CHM XIN01                                                            
  42177   "RTN","CHM XWBUT",167 ,0)
  42178    ;
  42179   "RTN","CHM XWBUT",168 ,0)
  42180    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  42181   "RTN","CHM XWBUT",169 ,0)
  42182    ; MODS 12 /24/2013 D LB  DATE I NPUR NOW U TILIZES TH E FILEMAN  %DT DATE I NPUT FOR
  42183   "RTN","CHM XWBUT",170 ,0)
  42184    ; GETTING  THE START /END DATES  FROM THE  USER.
  42185   "RTN","CHM XWBUT",171 ,0)
  42186    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  42187   "RTN","CHM XWBUT",172 ,0)
  42188    ;      
  42189   "RTN","CHM XWBUT",173 ,0)
  42190   GETDTE(FRO M,TO)
  42191   "RTN","CHM XWBUT",174 ,0)
  42192    ;      FR OM    MODI FIABLE VAR IABLE FOR  THE "FROM/ START" DAT E
  42193   "RTN","CHM XWBUT",175 ,0)
  42194    ;      TO                MODIFI ABLE VARIA BLE FOR TH E "TO/END"  DATE 
  42195   "RTN","CHM XWBUT",176 ,0)
  42196    N TOSEC 
  42197   "RTN","CHM XWBUT",177 ,0)
  42198    S U="^" 
  42199   "RTN","CHM XWBUT",178 ,0)
  42200    S:$D(DTIM E) TOSEC=D TIME                                            ; IF D TIME WAS V ALID, SAVE  THE ORIGI NAL TIMEOU T VALUE
  42201   "RTN","CHM XWBUT",179 ,0)
  42202    S DTIME=6 00                                                                  ; SET TI MEOUT TO 1 0 MINUTES 
  42203   "RTN","CHM XWBUT",180 ,0)
  42204   SDATE
  42205   "RTN","CHM XWBUT",181 ,0)
  42206           S  FROM=""
  42207   "RTN","CHM XWBUT",182 ,0)
  42208    ;W !!,"En ter the ST ART date:   ",! S X=Y ,%DT="AEPT ",DT(0)="- T" D ^%DT  G:Y=-1 SDA TE
  42209   "RTN","CHM XWBUT",183 ,0)
  42210    W !!,"Ent er the STA RT date:   ",! S X=$G (Y),%DT="A EPT",DT(0) ="-T" D ^% DT G:Y=-1  SDATE ;DEF 917633 BDB  02/04/201 9 $G(Y)
  42211   "RTN","CHM XWBUT",184 ,0)
  42212       S FROM =Y                                                                  ; SET TH E "FROM" R ETURN VARI ABLE TO IN PUT VALUE
  42213   "RTN","CHM XWBUT",185 ,0)
  42214       K %DT                                                                               ; REQUIRED  BY FILEMA N
  42215   "RTN","CHM XWBUT",186 ,0)
  42216   EDATE ;
  42217   "RTN","CHM XWBUT",187 ,0)
  42218           ;W  !!,"Enter  the STOP  date: ",!  S X=Y,%DT= "AEPT",%DT (0)="-T" D  ^%DT G:Y= -1 EDATE
  42219   "RTN","CHM XWBUT",188 ,0)
  42220           W  !!,"Enter  the STOP d ate: ",! S  X=$G(Y),% DT="AEPT", %DT(0)="-T " D ^%DT G :Y=-1 EDAT E ;DEF9176 33 BDB 02/ 04/2019 $G (Y)
  42221   "RTN","CHM XWBUT",189 ,0)
  42222           S  TO=Y                                                                         ; SET THE  "TO" RETUR N VARIABLE  TO THE IN PUT VALUE
  42223   "RTN","CHM XWBUT",190 ,0)
  42224           K  %DT                                                                          ; REQUIRED  BY FILEMA N
  42225   "RTN","CHM XWBUT",191 ,0)
  42226           I  $D(TOSEC)  S DTIME=TO SEC                                  ; REST ORE ORIGIN AL TIMEOUT  VALUE
  42227   "RTN","CHM XWBUT",192 ,0)
  42228           E   K DTIME
  42229   "RTN","CHM XWBUT",193 ,0)
  42230   GETEND Q 
  42231   "RTN","CHM XWBUT",194 ,0)
  42232    
  42233   "RTN","CHM XWBUT",195 ,0)
  42234    
  42235   "RTN","CHM XWBUT",196 ,0)
  42236   DTCVRT(DAT E)
  42237   "RTN","CHM XWBUT",197 ,0)
  42238    N EXTDATE
  42239   "RTN","CHM XWBUT",198 ,0)
  42240           S  EXTDATE=$E (DATE,4,5) _"-"_$E(DA TE,6,7)_"- "_($E(DATE ,1,3)+1700 )
  42241   "RTN","CHM XWBUT",199 ,0)
  42242    Q EXTDATE       
  42243   "RTN","CHM XWBUT",200 ,0)
  42244    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  42245   "RTN","CHM XWBUT",201 ,0)
  42246    ; SUPPORT  ROUTINES  FOR BLDSTC () AND ON  DEMAND STA TISTICS RE PORT                          ;
  42247   "RTN","CHM XWBUT",202 ,0)
  42248    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  42249   "RTN","CHM XWBUT",203 ,0)
  42250    
  42251   "RTN","CHM XWBUT",204 ,0)
  42252    
  42253   "RTN","CHM XWBUT",205 ,0)
  42254    
  42255   "RTN","CHM XWBUT",206 ,0)
  42256    ;******** ********** ********** ********** ********** ********** ********** ********** *****;
  42257   "RTN","CHM XWBUT",207 ,0)
  42258    ; SUPPORT  Subroutin es;  May b e replacea ble with E xisting or  New Libra ries                        ;
  42259   "RTN","CHM XWBUT",208 ,0)
  42260    ;******** ********** ********** ********** ********** ********** ********** ********** *****;
  42261   "RTN","CHM XWBUT",209 ,0)
  42262    
  42263   "RTN","CHM XWBUT",210 ,0)
  42264           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  42265   "RTN","CHM XWBUT",211 ,0)
  42266    ; THIS FU NCTION IS  DESIGNED T O FORMAT D ATA BASED  ON THE FOL LOWING $TE XT FORMAT:                  ;
  42267   "RTN","CHM XWBUT",212 ,0)
  42268    ;                                                                                                                                                                                      ;
  42269   "RTN","CHM XWBUT",213 ,0)
  42270    ; ";;FLD  NAME;TARGE T;LENGTH;J USTIFY;PAD CHAR;DELIM ITER;DATA  DESC;FLD S TART;FLD U SE"     ;
  42271   "RTN","CHM XWBUT",214 ,0)
  42272    ;                                                                                                                                                                                      ;
  42273   "RTN","CHM XWBUT",215 ,0)
  42274    ; THE DEF INITION OF  THE MEMBE RS OF THE  FORMAT STR ING:                                                                ;
  42275   "RTN","CHM XWBUT",216 ,0)
  42276    ;                                                                                                                                                                                      ;
  42277   "RTN","CHM XWBUT",217 ,0)
  42278    ;               ;;                         THIS CONVE NTION DIFF ERENTIATES  TABLE FRO M A COMMEN T FIELD                 ;
  42279   "RTN","CHM XWBUT",218 ,0)
  42280    ;               FLD  NAME         STRING I DENTIFYING  THE FIELD , TYPICALL Y TAKEN FR OM SPEC.                  ;
  42281   "RTN","CHM XWBUT",219 ,0)
  42282    ;               TARG ET           THIS CAN  BE A FIXE D VALUE OR  A FUNCTIO N TO RETUR N THE VALU E              ;
  42283   "RTN","CHM XWBUT",220 ,0)
  42284    ;               LENG TH           FIELD WI DTH SPECIF IED (LONGE R VALUES A LWAYS TRUN CATED)                    ;
  42285   "RTN","CHM XWBUT",221 ,0)
  42286    ;               JUST IFY          SUPPORTS  "L" (LEFT ),"R" (RIG HT), AND " C" (CENTER )                                  ;
  42287   "RTN","CHM XWBUT",222 ,0)
  42288    ;               PADC HAR          ANY PRIN TABLE CHAR ACTER, OR  NO CHAR IF  PADDING N OT DESIRED                ;
  42289   "RTN","CHM XWBUT",223 ,0)
  42290    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42291   "RTN","CHM XWBUT",224 ,0)
  42292    
  42293   "RTN","CHM XWBUT",225 ,0)
  42294   FORMATDATA (STR)          ;Pulls  and Forma ts Data in  EMDEON SP ECIFIED FI ELDS
  42295   "RTN","CHM XWBUT",226 ,0)
  42296    ;      ST R              $TEXT  String des cribing th e record 
  42297   "RTN","CHM XWBUT",227 ,0)
  42298    N VALUE,T MPIO,COLWI DTH,VAR,JU STIFY,PAD, FIELD,DELI M
  42299   "RTN","CHM XWBUT",228 ,0)
  42300    S TMPIO=$ IO,VALUE=" "
  42301   "RTN","CHM XWBUT",229 ,0)
  42302    S COLWIDT H=$P(STR," ;",5),JUST IFY=$P(STR ,";",6)                            ; Get Co lwidth & J ustify val ues
  42303   "RTN","CHM XWBUT",230 ,0)
  42304    S FIELD=$ P(STR,";", 3),PAD=$P( STR,";",7)                                                     ;  Get Field, PadChar
  42305   "RTN","CHM XWBUT",231 ,0)
  42306    S VALUE=" S VAR="_$P (STR,";",4 ) X VALUE                                              ; VAR Now  contains t he desired  value
  42307   "RTN","CHM XWBUT",232 ,0)
  42308    S:FIELD=" SEX" VAR=$ S(VAR="M": "M",VAR="F ":"F",1:"M ")                      ; Defaul t SEX=M if  Undefined
  42309   "RTN","CHM XWBUT",233 ,0)
  42310    S VALUE=$ E($$JUSTIF Y(VAR,COLW IDTH,PAD,J USTIFY),1, COLWIDTH)      ; LEFT /RIGHT/CEN TER JUSTIF ICATION
  42311   "RTN","CHM XWBUT",234 ,0)
  42312    Q VALUE
  42313   "RTN","CHM XWBUT",235 ,0)
  42314    
  42315   "RTN","CHM XWBUT",236 ,0)
  42316    
  42317   "RTN","CHM XWBUT",237 ,0)
  42318    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  42319   "RTN","CHM XWBUT",238 ,0)
  42320    ; JUSTIFY ()   A mul tipurpose  justificat ion functi on that pe rforms Rig ht/Left/Ce nter(LRC)        ;
  42321   "RTN","CHM XWBUT",239 ,0)
  42322    ;                          just ification  in additio n to the t runcation  of the spe cified str ing as                  ;
  42323   "RTN","CHM XWBUT",240 ,0)
  42324    ;                          requ ired to sa tisfy the  width spec ification.  Allows us er to spec ify ANY                 ;
  42325   "RTN","CHM XWBUT",241 ,0)
  42326    ;                          "pad " characte r to be us ed in the  Right/Left /Center ju stificatio n.                      ;
  42327   "RTN","CHM XWBUT",242 ,0)
  42328    ;  NOTE:  If the len gth of the  provided  string is  greater th an the spe cified wid th, the          ;
  42329   "RTN","CHM XWBUT",243 ,0)
  42330    ;      re turn value  is the tr uncated st ring to fi t into the  specified  width.                                       ;
  42331   "RTN","CHM XWBUT",244 ,0)
  42332    ;  NOTE2:  The origi nal MUMPS  $J functio n has some  limitatio ns, i.e. i t provides  R and L                  ;
  42333   "RTN","CHM XWBUT",245 ,0)
  42334    ;               just ification,  but no "c enter" in  field, and  there is  a problem  with the m ath            ;
  42335   "RTN","CHM XWBUT",246 ,0)
  42336    ;               in c alculating  the outpu t if the s tring leng th and col umn width  are the sa me.            ;
  42337   "RTN","CHM XWBUT",247 ,0)
  42338    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  42339   "RTN","CHM XWBUT",248 ,0)
  42340    
  42341   "RTN","CHM XWBUT",249 ,0)
  42342   JUSTIFY(ST R,COLWIDTH ,PAD,LRC)
  42343   "RTN","CHM XWBUT",250 ,0)
  42344    ;      ST R                       Value to  be format ted and ou tput
  42345   "RTN","CHM XWBUT",251 ,0)
  42346    ;      CO LWIDTH         MAX Fi eld Width  of the str ing to be  returned
  42347   "RTN","CHM XWBUT",252 ,0)
  42348    ;      PA D                       Characte r used to  "pad" the  string (Mu st be prin table char  for justi fication)
  42349   "RTN","CHM XWBUT",253 ,0)
  42350    ;      LR C                       Left/Rig ht/Center  Justify th e string i n the colu mn width
  42351   "RTN","CHM XWBUT",254 ,0)
  42352    ;RETURN                           A String  ready for  output
  42353   "RTN","CHM XWBUT",255 ,0)
  42354    N VARLEN, RETURN,PAD STR,LPAD,P DCNT       S (PADSTR, LPAD)=""
  42355   "RTN","CHM XWBUT",256 ,0)
  42356    S VARLEN= $L(STR)                                                                                                ; Get  Length of  the variab le
  42357   "RTN","CHM XWBUT",257 ,0)
  42358    I VARLEN= COLWIDTH S  RETURN=ST R                                                              ;  Same as Sp ecified wi dth
  42359   "RTN","CHM XWBUT",258 ,0)
  42360    E  I VARL EN>COLWIDT H S RETURN =$E(STR,1, COLWIDTH)                          ; IF gre ater, disc ard extra  length
  42361   "RTN","CHM XWBUT",259 ,0)
  42362    E  I (PAD ="") S RET URN=$E(STR ,1,COLWIDT H)                                          ; Else IF  PAD CHARAC TER NOT DE FINED
  42363   "RTN","CHM XWBUT",260 ,0)
  42364    E  D                                                                                                                      ; justif y the vari able in th e string
  42365   "RTN","CHM XWBUT",261 ,0)
  42366    .I LRC="C " S PDCNT= ((COLWIDTH -VARLEN/2) +(COLWIDTH -VARLEN#2) ) D  ; Cen ter the St ring in th e width
  42367   "RTN","CHM XWBUT",262 ,0)
  42368    ..S $P(PA DSTR,PAD,P DCNT)=PAD, RETURN=(PA DSTR_STR_P ADSTR)
  42369   "RTN","CHM XWBUT",263 ,0)
  42370    ..S RETUR N=$E(RETUR N,1,COLWID TH)
  42371   "RTN","CHM XWBUT",264 ,0)
  42372    .E  I LRC ="L" D                                                     ; Left  Justify w /Pad Chara cter
  42373   "RTN","CHM XWBUT",265 ,0)
  42374    ..S $P(PA DSTR,PAD,C OLWIDTH)=P AD                   
  42375   "RTN","CHM XWBUT",266 ,0)
  42376       ..S RE TURN=$E(ST R_PADSTR,1 ,COLWIDTH)
  42377   "RTN","CHM XWBUT",267 ,0)
  42378       .E  S  $P(PADSTR, PAD,(COLWI DTH-$L(STR )+1))="" D                         ; Right  Justify w/ Pad Char
  42379   "RTN","CHM XWBUT",268 ,0)
  42380       ..S RE TURN=PADST R_STR                                                                                       
  42381   "RTN","CHM XWBUT",269 ,0)
  42382    Q RETURN                                                                                                                  ; RETURN  THE FORMA TTED STRIN G
  42383   "RTN","CHM XWBUT",270 ,0)
  42384     
  42385   "RTN","CHM XWBUT",271 ,0)
  42386    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42387   "RTN","CHM XWBUT",272 ,0)
  42388    ; Right a nd Left Ju stify func tions cour tesy of JB M 7/2/2010                                                          ;
  42389   "RTN","CHM XWBUT",273 ,0)
  42390    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42391   "RTN","CHM XWBUT",274 ,0)
  42392    
  42393   "RTN","CHM XWBUT",275 ,0)
  42394   LJ(STR,SIZ E,PAD1) ;
  42395   "RTN","CHM XWBUT",276 ,0)
  42396            N  RET,PAD
  42397   "RTN","CHM XWBUT",277 ,0)
  42398            S  PAD="",RE T=""
  42399   "RTN","CHM XWBUT",278 ,0)
  42400            I  PAD1="" S  RET=$E(ST R,1,SIZE) 
  42401   "RTN","CHM XWBUT",279 ,0)
  42402            E   S $P(PAD ,PAD1,SIZE )=PAD1,RET =$E(STR_PA D,1,SIZE) 
  42403   "RTN","CHM XWBUT",280 ,0)
  42404            Q  RET
  42405   "RTN","CHM XWBUT",281 ,0)
  42406   RJ(STR,SIZ E,PAD1) 
  42407   "RTN","CHM XWBUT",282 ,0)
  42408            N  RET,PAD
  42409   "RTN","CHM XWBUT",283 ,0)
  42410            S  PAD="",RE T=""
  42411   "RTN","CHM XWBUT",284 ,0)
  42412            I  PAD1="" S  RET=$E(ST R,1,SIZE)
  42413   "RTN","CHM XWBUT",285 ,0)
  42414            E   S $P(PAD ,PAD1,(SIZ E-$L(STR)+ 1))="",RET =$E(PAD_ST R,1,SIZE)
  42415   "RTN","CHM XWBUT",286 ,0)
  42416            Q  RET
  42417   "RTN","CHM XWBUT",287 ,0)
  42418            
  42419   "RTN","CHM XWBUT",288 ,0)
  42420            
  42421   "RTN","CHM XWBUT",289 ,0)
  42422            
  42423   "RTN","CHM XWBUT",290 ,0)
  42424           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  42425   "RTN","CHM XWBUT",291 ,0)
  42426           ;        EMDE ONHDR:       Common H eader for  EMDEON STA TUS Files                                                                 ;
  42427   "RTN","CHM XWBUT",292 ,0)
  42428           ;        A si ngle heade r is gener ated for e ach output  file.                                                                    ;
  42429   "RTN","CHM XWBUT",293 ,0)
  42430           ;     DESC: " FIELD NAME ";"LENGTH" ;"JUSTIFY  FLAG";"PAD  CHAR";"DA TA TYPE";                            ;
  42431   "RTN","CHM XWBUT",294 ,0)
  42432           ;                 FIELD  NAME:  EMD EON File F IELD DESCR IPTOR(reco rd # and t ext descri ption)         ;
  42433   "RTN","CHM XWBUT",295 ,0)
  42434           ;                 LENGTH :  EMDEON  FILE SPECI FIED FIELD  WIDTH                                                                             ;
  42435   "RTN","CHM XWBUT",296 ,0)
  42436           ;                 JUSTIF Y FLAG: L= LEFT, R=RI GHT, C= CE NTER                                                                               ;
  42437   "RTN","CHM XWBUT",297 ,0)
  42438           ;                 PAD: P AD CHARACT ER TO BE U SED TO FIL L FIELD WI DTH (ANY P RINTABLE C HARACTER)      ;
  42439   "RTN","CHM XWBUT",298 ,0)
  42440           ;                          NOTE: PA D CHAR=""  IF NO CHAR ACTER IS B ETWEEN THE  SEMICOLON S (I.E. ;; )   ;
  42441   "RTN","CHM XWBUT",299 ,0)
  42442           ;                          NO PADDI NG WILL OC CUR IF THI S IS SET U P THIS WAY                                                     ;
  42443   "RTN","CHM XWBUT",300 ,0)
  42444           ;                 DATA P ATTERN: PA TTERN MATC H DESCRIPT OR DESCRIB ING THE VA LUE                                         ;
  42445   "RTN","CHM XWBUT",301 ,0)
  42446           ;                 FIELD  START LOCA TION: LOCA TION IN RE CORD FOR T HIS FIELD- DOCUMENTAT ION ONLY       ;
  42447   "RTN","CHM XWBUT",302 ,0)
  42448           ;                 FIELD  USE: R=REQ UIRED, C=C ONDITIONAL , O=OPTION AL                                                             ;
  42449   "RTN","CHM XWBUT",303 ,0)
  42450           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  42451   "RTN","CHM XWBUT",304 ,0)
  42452           ;                                                                                                                                                                                        ;
  42453   "RTN","CHM XWBUT",305 ,0)
  42454           ;  FORMATDATA  TREATS TH E PAD CHAR  (;;) AS A  NULL, SO  NO PADDING  OCCURS.                             ;
  42455   "RTN","CHM XWBUT",306 ,0)
  42456           ;  THIS WILL  ALLOW USE  OF THE FOR MATDATA FU NCTION WIT HOUT MODIF ICATION BE TWEEN            ;
  42457   "RTN","CHM XWBUT",307 ,0)
  42458           ;  PADDED AND  NON-PADDE D FIELDS.                                                                                                                    ;
  42459   "RTN","CHM XWBUT",308 ,0)
  42460           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  42461   "RTN","CHM XWBUT",309 ,0)
  42462           ;  8/4/11  DL B "6. CREA TION TIME"  FROM $E(D ATESTAMP,9 ,12) TO $E (DATESTAMP ,9,14)           ;
  42463   "RTN","CHM XWBUT",310 ,0)
  42464           ;  8/15/11 DL B "2. FILE  GROUP ID"  INSERTED  THE DATEST AMP VALUE  TO ENSURE  UNIQUENESS       ;
  42465   "RTN","CHM XWBUT",311 ,0)
  42466           ;  9/7/2011 D LB 12. LOA D TYPE CHA NGED TO PR OVIDE "F"  WHEN HISTO RICAL FILE  GENERATED       ;
  42467   "RTN","CHM XWBUT",312 ,0)
  42468           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  42469   "RTN","CHM XWBUT",313 ,0)
  42470           
  42471   "RTN","CHM XWBUT",314 ,0)
  42472   TSTHDR  ;B UILD HEADE R RECORD
  42473   "RTN","CHM XWBUT",315 ,0)
  42474    N LN,REC, STR,LOADTY PE,DATESTA MP,GROUPID
  42475   "RTN","CHM XWBUT",316 ,0)
  42476    S GROUPID =""
  42477   "RTN","CHM XWBUT",317 ,0)
  42478    S (STR,LN ,REC)="",C OUNT=2                        ;  EMDEON SPE C: REC. CO UNT STARTS  @ 2
  42479   "RTN","CHM XWBUT",318 ,0)
  42480    S DATESTA MP=$$FMDAT E("NOW")
  42481   "RTN","CHM XWBUT",319 ,0)
  42482    F LN=1:1  S STR=$T(S AMPLEHDR+L N) Q:STR[" END OF REC ORD"  D
  42483   "RTN","CHM XWBUT",320 ,0)
  42484    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)            
  42485   "RTN","CHM XWBUT",321 ,0)
  42486    .E  S REC =REC_"|"_$ $FORMATDAT A^CHMXWBUT (STR)
  42487   "RTN","CHM XWBUT",322 ,0)
  42488    W REC,! S  REC=""                                                             
  42489   "RTN","CHM XWBUT",323 ,0)
  42490    Q
  42491   "RTN","CHM XWBUT",324 ,0)
  42492                      
  42493   "RTN","CHM XWBUT",325 ,0)
  42494   SAMPLEHDR  ;"FIELD NA ME";"TARGE T VALUE";" LENGTH";"J USTIFY FLA G";"PAD CH AR";DATA L ENGTH/PATT ERN";FIELD  START LOC ATION;FIEL D USE
  42495   "RTN","CHM XWBUT",326 ,0)
  42496           ;; 1.RECORD I D;"HDR";3; L;;3AN;0;R ;
  42497   "RTN","CHM XWBUT",327 ,0)
  42498           ;; 2.FILE GRO UP ID;$S(G ROUPID'="" :GROUPID,1 :DATESTAMP );20;L;;20 AN;4;R;
  42499   "RTN","CHM XWBUT",328 ,0)
  42500           ;; 3.FILE GRO UP SEQUENC E NUMBER;" FILE NUMBE R";2;R;0;3 N;24;R;
  42501   "RTN","CHM XWBUT",329 ,0)
  42502           ;; 4.FILE GRO UP COUNT;" GROUP NUMB ER";2;R;0; 3N;26;R;
  42503   "RTN","CHM XWBUT",330 ,0)
  42504           ;; 5.CREATION  DATE;$E(D ATESTAMP,1 ,7);8;L;;8 AN;28;R;
  42505   "RTN","CHM XWBUT",331 ,0)
  42506           ;; 6.CREATION  TIME;$E(D ATESTAMP,9 ,14);6;L;; 6N;36;R;
  42507   "RTN","CHM XWBUT",332 ,0)
  42508           ;; 7.TRADING  PARTNER ID ;"VAFNH";1 0;L;;10AN; 42;R;
  42509   "RTN","CHM XWBUT",333 ,0)
  42510           ;; 8.SUBMITTE R NAME;"SU BMITTER NA ME";30;L;; 30AN;53;R;
  42511   "RTN","CHM XWBUT",334 ,0)
  42512           ;; 9.PAYER CO NTACT NAME ;"PAYER CO NTACT NAME ";60;L;;60 AN;83;O;
  42513   "RTN","CHM XWBUT",335 ,0)
  42514           ;; 10.PAYER S UPPORT TEL EPHONE NUM BER;"";10; L;;10N;143 ;O;
  42515   "RTN","CHM XWBUT",336 ,0)
  42516           ;; 11.PAYER S UPPORT EMA IL ADDRESS ;"";80;L;; 80AN;153;O ;
  42517   "RTN","CHM XWBUT",337 ,0)
  42518           ;; 12.LOAD TY PE;"LOADTY PE";1;L;;1 AN;233;R;
  42519   "RTN","CHM XWBUT",338 ,0)
  42520           ;; 13.PAYER U NIQUE FILE  IDENTIFIE R;DATESTAM P;20;L;;20 AN;234;R;
  42521   "RTN","CHM XWBUT",339 ,0)
  42522           ;; 14.FILE TY PE;"CStat" ;5;L;;5AN; 254;R;
  42523   "RTN","CHM XWBUT",340 ,0)
  42524           ;; 15.VERSION  CODE;"03" ;2;L;;2AN; 258;R;
  42525   "RTN","CHM XWBUT",341 ,0)
  42526           ;; 16.RELEASE  CODE;"00" ;2;L;;2AN; 260;R;
  42527   "RTN","CHM XWBUT",342 ,0)
  42528           ;; 18.END OF  RECORD;
  42529   "RTN","CHM XWBUT",343 ,0)
  42530           
  42531   "RTN","CHM XWBUT",344 ,0)
  42532    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  42533   "RTN","CHM XWBUT",345 ,0)
  42534    ; DOCUMEN TREC (UTIL ITY THAT H ELPS IN DO CUMENTING  THE RECORD  GENERATIO N PROCESS)  ;
  42535   "RTN","CHM XWBUT",346 ,0)
  42536    ; CREATES  A FILE TH AT CONTAIN S THE RECO RD INFORMA TION FOR T HE 5010                                ;
  42537   "RTN","CHM XWBUT",347 ,0)
  42538    ; EMDEON  STATUS REC ORDS, INCL UDING THE  HEADER, CL AIM, LINE  ITEM, AND  TRAILER    ;
  42539   "RTN","CHM XWBUT",348 ,0)
  42540    ; RECORDS .  THIS FU NCTION USE S THE FIEL D DESCRIPT ORS TO DOC UMENT EACH  FIELD IN  ;
  42541   "RTN","CHM XWBUT",349 ,0)
  42542    ; THE REC ORDS, I.E. :                                                                                                                              ;
  42543   "RTN","CHM XWBUT",350 ,0)
  42544    ;      1)  RECORD NA ME                                                                                                                                      ;
  42545   "RTN","CHM XWBUT",351 ,0)
  42546    ;      2)  STARTING  LOCATION I N THE RECO RD                                                                                              ;
  42547   "RTN","CHM XWBUT",352 ,0)
  42548    ;      3)  LENGTH (W IDTH) OF T HE FIELD                                                                                                   ;
  42549   "RTN","CHM XWBUT",353 ,0)
  42550    ;      4)  JUSTIFICA TION WITHI N THE FIEL D                                                                                               ;
  42551   "RTN","CHM XWBUT",354 ,0)
  42552    ;      5)  THE VALUE  (HARD COD ED FIELDS)  OR THE CA CHE FILELO CATION FRO M WHICH TH E       ;
  42553   "RTN","CHM XWBUT",355 ,0)
  42554    ;               VALU E IS RETRI EVED.                                                                                                               ;
  42555   "RTN","CHM XWBUT",356 ,0)
  42556    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  42557   "RTN","CHM XWBUT",357 ,0)
  42558    
  42559   "RTN","CHM XWBUT",358 ,0)
  42560   DOCUMENTRE C
  42561   "RTN","CHM XWBUT",359 ,0)
  42562    N DOCFILE ,TMPIO,LN, HTABS,FTAB S,RTYPE,RN AME,CHTYPE ,STR,COLNM S,DATESTAM P
  42563   "RTN","CHM XWBUT",360 ,0)
  42564    S DATESTA MP=$$FMDAT E("XDT")
  42565   "RTN","CHM XWBUT",361 ,0)
  42566    S RTYPE=" SAMPLEHDR"              ; NAMES  OF $TEXT T ABLES
  42567   "RTN","CHM XWBUT",362 ,0)
  42568    S COLNMS= "FIELD NAM E^USE^DESC ^PAD^JUST^ VALUE"           ; CO LUMN HEADE R NAMES
  42569   "RTN","CHM XWBUT",363 ,0)
  42570    S HTABS=" 35^39^45^5 0^57"                         ;  HEADER TAB  STOPS FOR  THE FIELD  DESCRIPTI ONS
  42571   "RTN","CHM XWBUT",364 ,0)
  42572    S FTABS=" 36^39^46^5 2^57"                         ;  FIELD TAB  STOPS FOR  DESCRIPTIO NS
  42573   "RTN","CHM XWBUT",365 ,0)
  42574    S DOCPATH ="SYS$LOGI N:" 
  42575   "RTN","CHM XWBUT",366 ,0)
  42576    S DOCFILE ="DOC277_5 010_"_DATE STAMP_".TX T"      ;  STATUS MAP PING DOCUM ENTATION
  42577   "RTN","CHM XWBUT",367 ,0)
  42578    S DOCFILE =DOCPATH_D OCFILE                                          ; OUTP UT THE $TE XT TO A PR INTABLE FI LE
  42579   "RTN","CHM XWBUT",368 ,0)
  42580    W !,"OUTP UT FILE=", DOCFILE
  42581   "RTN","CHM XWBUT",369 ,0)
  42582    ;S FLAG=$ $OFILE^CHM XWBUT(DOCF ILE,"NWS")
  42583   "RTN","CHM XWBUT",370 ,0)
  42584    S FLAG=$$ OPENFIWR^C HTFLIB9(.D OCFILE,"DO CFILE") 
  42585   "RTN","CHM XWBUT",371 ,0)
  42586    S TMPIO=$ IO U DOCFI LE
  42587   "RTN","CHM XWBUT",372 ,0)
  42588    F CHTYPE= 1:1  S RNA ME=$P(RTYP E,"^",CHTY PE) Q:RNAM E=""  D
  42589   "RTN","CHM XWBUT",373 ,0)
  42590    .W !!,?20 ,"HEALTH C ARE CLEARI NG HOUSE " "",RNAME," ""  RECORD  DEFINITIO NS"        ; TITLE
  42591   "RTN","CHM XWBUT",374 ,0)
  42592    .W !,$P(C OLNMS,"^", 1),?$P(HTA BS,"^",1), $P(COLNMS, "^",2),?$P (HTABS,"^" ,2),$P(COL NMS,"^",3) ,?$P(HTABS ,"^",3),$P (COLNMS,"^ ",4),?$P(H TABS,"^",4 ),$P(COLNM S,"^",5),? $P(HTABS," ^",5),$P(C OLNMS,"^", 6),?$P(HTA BS,"^",6), $P(COLNMS, "^",7)
  42593   "RTN","CHM XWBUT",375 ,0)
  42594    .F LN=1:1  S STR=$T( @RNAME+LN)  Q:STR["EN D OF RECOR D"  D          ; READ  $TEXT DES CRIPTOR
  42595   "RTN","CHM XWBUT",376 ,0)
  42596    ..W !,$P( STR,";",3) ,?$P(FTABS ,"^",1),$P (STR,";",1 0),?$P(FTA BS,"^",2), $P(STR,";" ,8),?$P(FT ABS,"^",3) ,$P(STR,"; ",7),?$P(F TABS,"^",4 ),$P(STR," ;",6),?$P( FTABS,"^", 5),$P(STR, ";",4)
  42597   "RTN","CHM XWBUT",377 ,0)
  42598    U TMPIO 
  42599   "RTN","CHM XWBUT",378 ,0)
  42600    ;D CLOSEF ILE^CHMXWB UT(DOCFILE )                  ;  CLOSE CURR ENT FILE
  42601   "RTN","CHM XWBUT",379 ,0)
  42602    D CLOSEF^ CHTFLIB9(D OCFILE,"DO CFILE")
  42603   "RTN","CHM XWBUT",380 ,0)
  42604    Q
  42605   "RTN","CHM XWBUT",381 ,0)
  42606           
  42607   "RTN","CHM XWBUT",382 ,0)
  42608    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42609   "RTN","CHM XWBUT",383 ,0)
  42610    ; EXTDATE (FMDT) Tak es the fil eman date  and conver ts it to Y YYYMMDD fo rmat                        ;
  42611   "RTN","CHM XWBUT",384 ,0)
  42612    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;  
  42613   "RTN","CHM XWBUT",385 ,0)
  42614    
  42615   "RTN","CHM XWBUT",386 ,0)
  42616   EXTDATE(FM DT)
  42617   "RTN","CHM XWBUT",387 ,0)
  42618    ;      FM DT    The  date in fi leman form at CCYYMMD D (seconds  are ignor ed if sent )
  42619   "RTN","CHM XWBUT",388 ,0)
  42620    ;RETURNS        the  date in EX TERNAL (YY YYMMDD) fo rmat  
  42621   "RTN","CHM XWBUT",389 ,0)
  42622           Q: $G(FMDT)=" " ""
  42623   "RTN","CHM XWBUT",390 ,0)
  42624           S  FMDT=$E(FM DT,1,7)
  42625   "RTN","CHM XWBUT",391 ,0)
  42626           N  X,%H,%Y,%T
  42627   "RTN","CHM XWBUT",392 ,0)
  42628           S  X=FMDT                                   ;  X Must be  set to Fil eman Date  String
  42629   "RTN","CHM XWBUT",393 ,0)
  42630           D  H^%DTC                                   ;  Convert Fi leman to $ H
  42631   "RTN","CHM XWBUT",394 ,0)
  42632           Q  $ZD(%H,8)                                ;  Convert $H  to YYYYMM DD
  42633   "RTN","CHM XWBUT",395 ,0)
  42634    
  42635   "RTN","CHM XWBUT",396 ,0)
  42636    
  42637   "RTN","CHM XWBUT",397 ,0)
  42638   GETDATE(ST R)    ; US ER RESPONS E FOR DATE  INPUT
  42639   "RTN","CHM XWBUT",398 ,0)
  42640    ;      ST R     MESS AGE FOR TH E DATE YOU  WANT ENTE RED (I.E " ENTER STAR T DATE")
  42641   "RTN","CHM XWBUT",399 ,0)
  42642   A3 W !! S  %DT="AEPX" ,%DT("A")= STR D ^%DT  
  42643   "RTN","CHM XWBUT",400 ,0)
  42644           G: X="^" ENDX  G:X="^^"  ENDX G:Y=- 1 A3
  42645   "RTN","CHM XWBUT",401 ,0)
  42646   ENDX Q Y
  42647   "RTN","CHM XWBUT",402 ,0)
  42648    
  42649   "RTN","CHM XWBUT",403 ,0)
  42650    
  42651   "RTN","CHM XWBUT",404 ,0)
  42652    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42653   "RTN","CHM XWBUT",405 ,0)
  42654           ;  FMDATE(WHE N)  Return s ONLY the  FILEMAN f ormat Date  from the  NOW^%DTC F unction          ; 
  42655   "RTN","CHM XWBUT",406 ,0)
  42656    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;; 
  42657   "RTN","CHM XWBUT",407 ,0)
  42658    
  42659   "RTN","CHM XWBUT",408 ,0)
  42660   FMDATE(WHE N)
  42661   "RTN","CHM XWBUT",409 ,0)
  42662    ;      WH EN: Curren tly the op tions, "NO W","TIME"  ONLY,"XD:T " EXTERNAL  DATE:TIME
  42663   "RTN","CHM XWBUT",410 ,0)
  42664    ;RETURN:  Date in Fi leman Form at
  42665   "RTN","CHM XWBUT",411 ,0)
  42666    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42667   "RTN","CHM XWBUT",412 ,0)
  42668    ;Output V ariables f or the NOW ^%DTC                                                                                                               ; 
  42669   "RTN","CHM XWBUT",413 ,0)
  42670    ;      %        VA F ileMan dat e/time dow n to the s econd.                                                                               ;
  42671   "RTN","CHM XWBUT",414 ,0)
  42672    ;      %H       $H d ate/time.                                                                                                                                        ;
  42673   "RTN","CHM XWBUT",415 ,0)
  42674    ;      %I (1)   The  numeric va lue of the  month.                                                                                         ;
  42675   "RTN","CHM XWBUT",416 ,0)
  42676    ;      %I (2)   The  numeric va lue of the  day.                                                                                           ;
  42677   "RTN","CHM XWBUT",417 ,0)
  42678    ;      %I (3)   The  numeric va lue of the  year.                                                                                          ;
  42679   "RTN","CHM XWBUT",418 ,0)
  42680    ;      X                 VA Fil eMan date  only.                                                                                                             ;
  42681   "RTN","CHM XWBUT",419 ,0)
  42682    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42683   "RTN","CHM XWBUT",420 ,0)
  42684    
  42685   "RTN","CHM XWBUT",421 ,0)
  42686    N DATE,TI ME,CHHMM
  42687   "RTN","CHM XWBUT",422 ,0)
  42688    D NOW^%DT C
  42689   "RTN","CHM XWBUT",423 ,0)
  42690    S CHDT=$E (%,1,7),CH FMDTE=$E(% ,4,7)
  42691   "RTN","CHM XWBUT",424 ,0)
  42692       S CMMD D=$E(%,4,7 ),CHHMMSS= $E(%,9,14) ,CHHMM=$E( %,9,12)
  42693   "RTN","CHM XWBUT",425 ,0)
  42694       I $L(C HHMMSS)<6  S CHHMMSS= CHHMMSS_"1 11111",CHH MMSS=$E(CH HMMSS,1,6)
  42695   "RTN","CHM XWBUT",426 ,0)
  42696    S DATE=X, TIME=CHHMM SS 
  42697   "RTN","CHM XWBUT",427 ,0)
  42698           I  WHEN="NOW"     Q %                                                           ;%= FILEMA N DATE+TIM E
  42699   "RTN","CHM XWBUT",428 ,0)
  42700           I  WHEN="DAY"     Q X                                                  ;X= FILE MAN YYMMDD
  42701   "RTN","CHM XWBUT",429 ,0)
  42702    I WHEN="T IME"  S X= % D H^%DTC  Q %T                       ; Re turn the F M format d ate:time
  42703   "RTN","CHM XWBUT",430 ,0)
  42704    I WHEN="X DT"   Q $$ FMTOYYYYMM DD(DATE)_C HHMM ; EXT . DATE WIT H HOUR&MIN UTE
  42705   "RTN","CHM XWBUT",431 ,0)
  42706    I WHEN="D T"    Q:$E (%,1,7)
  42707   "RTN","CHM XWBUT",432 ,0)
  42708    I WHEN="F MD:T" Q:$E (%,4,7)
  42709   "RTN","CHM XWBUT",433 ,0)
  42710    I WHEN="H MS6"  Q:$E (%,9,14)
  42711   "RTN","CHM XWBUT",434 ,0)
  42712    I WHEN="Y EST"           S X1=D ATE,X2=-1  D C^%DTC Q  X    ;YES TERDAY
  42713   "RTN","CHM XWBUT",435 ,0)
  42714    I WHEN="T OM"   S X1 =DATE,X2=1  D C^%DTC  Q X              ;TOM ORROW
  42715   "RTN","CHM XWBUT",436 ,0)
  42716    I WHEN="B 1W"            S X1=D ATE,X2=-7  D C^%DTC Q  X    ;BAC K ONE WEEK
  42717   "RTN","CHM XWBUT",437 ,0)
  42718    I WHEN="F 1W"   S X1 =DATE,X2=7  D C^%DTC  Q X              ;FOR WARD ONE W EEK       
  42719   "RTN","CHM XWBUT",438 ,0)
  42720           Q  0                                                                                             ; 0  return for  non-speci fied "when "     
  42721   "RTN","CHM XWBUT",439 ,0)
  42722           
  42723   "RTN","CHM XWBUT",440 ,0)
  42724    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42725   "RTN","CHM XWBUT",441 ,0)
  42726    ; FMTOYYY YMMDD(FMDT ) Takes th e fileman  date and c onverts it  to yyyymm dd format          ;
  42727   "RTN","CHM XWBUT",442 ,0)
  42728    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;  
  42729   "RTN","CHM XWBUT",443 ,0)
  42730    
  42731   "RTN","CHM XWBUT",444 ,0)
  42732   FMTOYYYYMM DD(FMDT)
  42733   "RTN","CHM XWBUT",445 ,0)
  42734    ;      FM DT    The  date in fi leman form at CCYYMMD D (seconds  are ignor ed if sent )
  42735   "RTN","CHM XWBUT",446 ,0)
  42736    ;RETURN         the  date in YY YYMMDD for mat     
  42737   "RTN","CHM XWBUT",447 ,0)
  42738           Q: $G(FMDT)=" " ""
  42739   "RTN","CHM XWBUT",448 ,0)
  42740           N  X,%H,%Y,%T
  42741   "RTN","CHM XWBUT",449 ,0)
  42742           S  X=FMDT                                   ;  X Must be  set to Fil eman Date  String
  42743   "RTN","CHM XWBUT",450 ,0)
  42744           D  H^%DTC                                   ;  Convert Fi leman to $ H
  42745   "RTN","CHM XWBUT",451 ,0)
  42746           Q  $ZD(%H,8)                                ;  Convert $H  to YYYYMM DD
  42747   "RTN","CHM XWBUT",452 ,0)
  42748           
  42749   "RTN","CHM XWBUT",453 ,0)
  42750   FMTOHHMMSS (FMTIME)
  42751   "RTN","CHM XWBUT",454 ,0)
  42752    ;      FM TIME  THE  Fileman ti me to conv ert to hhm mss format
  42753   "RTN","CHM XWBUT",455 ,0)
  42754    ; RETURN:  THE CONVE RTED TIME
  42755   "RTN","CHM XWBUT",456 ,0)
  42756    N X,%F,CT
  42757   "RTN","CHM XWBUT",457 ,0)
  42758    S X=FMTIM E,%F=0,CT= $$FMTH^XLF DT(X,%F)
  42759   "RTN","CHM XWBUT",458 ,0)
  42760   GETHHMMSS( CT)
  42761   "RTN","CHM XWBUT",459 ,0)
  42762           N  HT,ZT,HH,M M,SS
  42763   "RTN","CHM XWBUT",460 ,0)
  42764           S  HT=$P(CT," ,",2)
  42765   "RTN","CHM XWBUT",461 ,0)
  42766           S  ZT=$ZT(HT, 1,9)         
  42767   "RTN","CHM XWBUT",462 ,0)
  42768           S  HH=$P(ZT," :",1)
  42769   "RTN","CHM XWBUT",463 ,0)
  42770           S  MM=$P(ZT," :",2)
  42771   "RTN","CHM XWBUT",464 ,0)
  42772           S  SS=$P($P(Z T,":",3)," .",1)
  42773   "RTN","CHM XWBUT",465 ,0)
  42774           Q  HH_MM_SS
  42775   "RTN","CHM XWBUT",466 ,0)
  42776    
  42777   "RTN","CHM XWBUT",467 ,0)
  42778    
  42779   "RTN","CHM XWBUT",468 ,0)
  42780    ; FILEMAN  PROGRAMME R MANUAL:  2.3.64 S^% DTC: Date/ Time Utili ty
  42781   "RTN","CHM XWBUT",469 ,0)
  42782    ; This en try takes  the number  of second s from mid night and  turns it 
  42783   "RTN","CHM XWBUT",470 ,0)
  42784    ; into ho urs, minut es, and se conds as a  decimal p art of a V A FileMan  date.     
  42785   "RTN","CHM XWBUT",471 ,0)
  42786   FMSDTC(SEC ONDS)
  42787   "RTN","CHM XWBUT",472 ,0)
  42788    ; SECONDS       THE  ELAPSED SE CONDS VALU E SINCE MI DNIGHT
  42789   "RTN","CHM XWBUT",473 ,0)
  42790    S %=SECON DS                                                                                   ;  USER SPECI FIED NUMBE R OF SECON DS
  42791   "RTN","CHM XWBUT",474 ,0)
  42792    S:SECONDS '>0 %=$P($ H,",",2)                                                 ; NUMBER  OF SECOND S SINCE MI DNIGHT
  42793   "RTN","CHM XWBUT",475 ,0)
  42794    D S^%DTC
  42795   "RTN","CHM XWBUT",476 ,0)
  42796    Q %
  42797   "RTN","CHM XWBUT",477 ,0)
  42798    
  42799   "RTN","CHM XWBUT",478 ,0)
  42800    
  42801   "RTN","CHM XWBUT",479 ,0)
  42802    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  42803   "RTN","CHM XWBUT",480 ,0)
  42804    ; BETWEEN  TESTS A D ATE TO BE  BETWEEN TW O OTHER DA TES.  I.E.  GIVEN TWO  DATES, ;
  42805   "RTN","CHM XWBUT",481 ,0)
  42806    ; "FROM"  DATE AND " TO" DATE,  THIS FUNCT ION RETURN S TRUE IF  THE USER D ATE         ;
  42807   "RTN","CHM XWBUT",482 ,0)
  42808    ; FALLS B ETWEEN THE  FROM AND  TO DATES.                                                                                  ;
  42809   "RTN","CHM XWBUT",483 ,0)
  42810    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  42811   "RTN","CHM XWBUT",484 ,0)
  42812    
  42813   "RTN","CHM XWBUT",485 ,0)
  42814   DATECHK(TD ATE,FDATE, UDATE)
  42815   "RTN","CHM XWBUT",486 ,0)
  42816    ;      TD ATE                     THE "TO"  BOUNDARY  DATE
  42817   "RTN","CHM XWBUT",487 ,0)
  42818    ;      FD ATE                     THE "FRO M BOUNDARY  DATE
  42819   "RTN","CHM XWBUT",488 ,0)
  42820    ;      UD ATE                     THE USER  DATE TO B E TESTED
  42821   "RTN","CHM XWBUT",489 ,0)
  42822    I UDATE>T DATE Q 0                ;FAIL IF  THE USER  DATE MORE  RECENT THA N THE "TO"  BOUNDARY
  42823   "RTN","CHM XWBUT",490 ,0)
  42824    I UDATE'> FDATE Q -1              ; FAIL I F USER DAT E IS BEFOR E/EQUAL TO  "FROM" BO UNDARY
  42825   "RTN","CHM XWBUT",491 ,0)
  42826    Q 1
  42827   "RTN","CHM XWBUT",492 ,0)
  42828    
  42829   "RTN","CHM XWBUT",493 ,0)
  42830    
  42831   "RTN","CHM XWBUT",494 ,0)
  42832    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  42833   "RTN","CHM XWBUT",495 ,0)
  42834    ; UTILITY  FUNCTION  WRITTEN TO  DUMP A ^C HMXCLE(I,n nn,J,0) NO DE.
  42835   "RTN","CHM XWBUT",496 ,0)
  42836    ; WHERE I  IS THE CL AIM INDEX  INTO THE ^ CHMXCLE FI LE
  42837   "RTN","CHM XWBUT",497 ,0)
  42838    ;               nnn  IS THE NOD E NUMBER ( i.e. 39, 4 0, 41, ETC )
  42839   "RTN","CHM XWBUT",498 ,0)
  42840    ;               J IS  THE "J" I NDEX FOR T HE FILEMAN  MULTIPLE  (DUMPS ALL  "J" NODES )
  42841   "RTN","CHM XWBUT",499 ,0)
  42842    ;               "0"  IS THE ASS UMED VALUE  FOR THE L EAST SIGNI FICANT NOD E ADDRESS
  42843   "RTN","CHM XWBUT",500 ,0)
  42844    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  42845   "RTN","CHM XWBUT",501 ,0)
  42846    ; EXAMPLE  OUTPUT 
  42847   "RTN","CHM XWBUT",502 ,0)
  42848    ; (NOTE:  ONLY POPUL ATED FIELD S ARE OUTP UT BY FILE MAN FUNCTI ON)
  42849   "RTN","CHM XWBUT",503 ,0)
  42850    ;
  42851   "RTN","CHM XWBUT",504 ,0)
  42852    ; DUMP NO DE: ^CHMXC LE(1096242 5,39,1,0)
  42853   "RTN","CHM XWBUT",505 ,0)
  42854    ;
  42855   "RTN","CHM XWBUT",506 ,0)
  42856    ; HC CODE  QUALIFIER  #1: BK                  HC CODE  #1: 338.2 9
  42857   "RTN","CHM XWBUT",507 ,0)
  42858    ; HC CODE  AMOUNT #1 : 0                    HC CODE A MOUNT #2:  0
  42859   "RTN","CHM XWBUT",508 ,0)
  42860    ; HC CODE  AMOUNT #3 : 0                    HC CODE A MOUNT #4:  0
  42861   "RTN","CHM XWBUT",509 ,0)
  42862    ; HC CODE  QTY #1: 0                        HC CODE Q TY #2: 0
  42863   "RTN","CHM XWBUT",510 ,0)
  42864    ; HC CODE  QTY #3: 0                        HC CODE Q TY #4: 0
  42865   "RTN","CHM XWBUT",511 ,0)
  42866    ;
  42867   "RTN","CHM XWBUT",512 ,0)
  42868    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42869   "RTN","CHM XWBUT",513 ,0)
  42870    
  42871   "RTN","CHM XWBUT",514 ,0)
  42872   TSTFMDUMP  ; EXAMPLE  FOR USING  THE FMDUMP  FUNCTION
  42873   "RTN","CHM XWBUT",515 ,0)
  42874    N INDEX S  I=1096242 5
  42875   "RTN","CHM XWBUT",516 ,0)
  42876    N NVAL S  N=39
  42877   "RTN","CHM XWBUT",517 ,0)
  42878    D FMDUMP( INDEX,NVAL )
  42879   "RTN","CHM XWBUT",518 ,0)
  42880    Q
  42881   "RTN","CHM XWBUT",519 ,0)
  42882    
  42883   "RTN","CHM XWBUT",520 ,0)
  42884   FMDUMP(IVA L,NODE)
  42885   "RTN","CHM XWBUT",521 ,0)
  42886    ;      IV AL    CLAI M INDEX FO R ^CHMXCLE (I)
  42887   "RTN","CHM XWBUT",522 ,0)
  42888    ;      NO DE    NODE  NUMBER (3 9,40,ETC.)
  42889   "RTN","CHM XWBUT",523 ,0)
  42890    N JVAL,NO DE1  S JVA L=0
  42891   "RTN","CHM XWBUT",524 ,0)
  42892    F  S JVAL =$O(^CHMXC LE(IVAL,NO DE,JVAL))   Q:JVAL'?1 N.N  D
  42893   "RTN","CHM XWBUT",525 ,0)
  42894    .W !,"DUM P NODE: ^C HMXCLE(",I VAL,",",NO DE,",",JVA L,",0)",!!
  42895   "RTN","CHM XWBUT",526 ,0)
  42896    .S DA(1)= IVAL,DA=JV AL 
  42897   "RTN","CHM XWBUT",527 ,0)
  42898    .S DIC="^ CHMXCLE"_" ("_IVAL_", "_NODE_","   
  42899   "RTN","CHM XWBUT",528 ,0)
  42900    .D EN^DIQ
  42901   "RTN","CHM XWBUT",529 ,0)
  42902    Q      
  42903   "RTN","CHM XWBUT",530 ,0)
  42904    
  42905   "RTN","CHM XWBUT",531 ,0)
  42906    
  42907   "RTN","CHM XWBUT",532 ,0)
  42908    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42909   "RTN","CHM XWBUT",533 ,0)
  42910    ; THE FOL LOWING FUN CTION TAKE S THE USER  PROVIDED  PDI, EXTRA CTS THE BU FFER
  42911   "RTN","CHM XWBUT",534 ,0)
  42912    ; INDEXES  FOR THE C LAIM BUFFE RS, THEN M AKES A CAL L TO FILEM AN TO DUMP  THE
  42913   "RTN","CHM XWBUT",535 ,0)
  42914    ; CONTENT S FOR EACH  OF THE CL AIM BUFFER S: ^CHMXCL A(837 TRAN SACTION, ^ CHMXCLB(
  42915   "RTN","CHM XWBUT",536 ,0)
  42916    ; PROVIDE R, ^CHMXCL C(PATIENT,  ^CHMXCLE( CLAIM, AND  ^CHMXCLF( LINE ITEM.  
  42917   "RTN","CHM XWBUT",537 ,0)
  42918    ; THIS SH OULD BE A  USEFUL TOO L FOR QA A ND PST WHE N TESTING/ VERIFYING  DATA
  42919   "RTN","CHM XWBUT",538 ,0)
  42920    ; FOR DAY  TO DAY OP ERATIONS.
  42921   "RTN","CHM XWBUT",539 ,0)
  42922    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  42923   "RTN","CHM XWBUT",540 ,0)
  42924    
  42925   "RTN","CHM XWBUT",541 ,0)
  42926   TEST
  42927   "RTN","CHM XWBUT",542 ,0)
  42928    N ANS,CHR EFN,CHPCN, CHMXCLI,CH MXID,CHAI, CHBTCH,CHB I,CHCI,CHE I,CHFI 
  42929   "RTN","CHM XWBUT",543 ,0)
  42930    W !!,"Ent er REFEREN CE (PDI) N UMBER:  "  D SBRS
  42931   "RTN","CHM XWBUT",544 ,0)
  42932    Q:$D(DUOU T)  Q:$D(D FOUT)
  42933   "RTN","CHM XWBUT",545 ,0)
  42934    I Y=" ",$ D(^DISV(DU Z,"REFNO") ) S ANS=$P (^DISV(DUZ ,"REFNO"), "^",1) W A NS S CHREF N=ANS S CH PCN="" G T EST
  42935   "RTN","CHM XWBUT",546 ,0)
  42936    I $D(DQOU T) D HLP2  G TEST
  42937   "RTN","CHM XWBUT",547 ,0)
  42938    Q:Y=""  I  Y=" ",'$D (^DISV(DUZ ,"REFNO"))  W "No def ault Refer ence Numbe r."
  42939   "RTN","CHM XWBUT",548 ,0)
  42940    I Y'?15N  D HLP3 G T EST
  42941   "RTN","CHM XWBUT",549 ,0)
  42942    S:$D(Y) C HREFN=Y S  ^DISV(DUZ, "REFNO")=Y
  42943   "RTN","CHM XWBUT",550 ,0)
  42944    I '$D(^CH MXCLE("PDI ",CHREFN))  D MSG1 Q
  42945   "RTN","CHM XWBUT",551 ,0)
  42946    S CHPCN=" "
  42947   "RTN","CHM XWBUT",552 ,0)
  42948    S CHPCN=$ O(^CHMXCLE ("PDI",CHR EFN,CHPCN) ) I CHPCN= "" D MSG2  Q ;VALID P DI,NO DATA
  42949   "RTN","CHM XWBUT",553 ,0)
  42950    S CHMXCLI =0
  42951   "RTN","CHM XWBUT",554 ,0)
  42952    S CHMXCLI =$O(^CHMXC LE("PDI",C HREFN,CHPC N,CHMXCLI) ) I 'CHMXC LI D MSG2  Q ;VALID P DI, NO DAT A
  42953   "RTN","CHM XWBUT",555 ,0)
  42954    S CHMXID= ""
  42955   "RTN","CHM XWBUT",556 ,0)
  42956    S CHMXID= $O(^CHMXCL E("PDI",CH REFN,CHPCN ,CHMXCLI,C HMXID)) I  CHMXID=""  D MSG2 Q 
  42957   "RTN","CHM XWBUT",557 ,0)
  42958    S CHAI=$P (CHMXID,"* ",1) W !!, "A(I)= ",C HAI
  42959   "RTN","CHM XWBUT",558 ,0)
  42960    S CHBTCH= $P(^CHMXCL A(CHAI,0), "^",1) 
  42961   "RTN","CHM XWBUT",559 ,0)
  42962    S CHBI=$P (CHMXID,"* ",2) W !," B(I)= ",CH BI
  42963   "RTN","CHM XWBUT",560 ,0)
  42964    S CHCI=$P (CHMXID,"* ",3) W !," C(I)= ",CH CI
  42965   "RTN","CHM XWBUT",561 ,0)
  42966    S CHEI=$P (CHMXID,"* ",4) W !," E(I)= ",CH EI
  42967   "RTN","CHM XWBUT",562 ,0)
  42968    S CHFI=0, CHFI=$O(^C HMXCLF("B" ,CHEI,CHFI )) W !,"F( I)= ",CHFI ,!!!
  42969   "RTN","CHM XWBUT",563 ,0)
  42970    W !,"PDI:  ",CHREFN, " WAS PROC ESSED FROM  BATCH FIL E: ^CHMXCL (",CHBTCH, !!
  42971   "RTN","CHM XWBUT",564 ,0)
  42972    W !,"NOTE :  THE FOL LOWING DAT A IS EXTRA CTED FROM  THE CLAIM  BUFFERS"
  42973   "RTN","CHM XWBUT",565 ,0)
  42974    W !,"        FILEMAN  DOES NOT  OUTPUT EMP TY FIELDS,  SO THE IN FORMATION"
  42975   "RTN","CHM XWBUT",566 ,0)
  42976    W !,"        YOU SEE  REPRESENT S ALL THE  NODES/FIEL DS THAT AR E POPULATE D.",!!
  42977   "RTN","CHM XWBUT",567 ,0)
  42978    D BTCHDUM P(CHBTCH)
  42979   "RTN","CHM XWBUT",568 ,0)
  42980    Q:$D(DUOU T)
  42981   "RTN","CHM XWBUT",569 ,0)
  42982    D ABDUMP( CHAI)
  42983   "RTN","CHM XWBUT",570 ,0)
  42984    Q:$D(DUOU T)
  42985   "RTN","CHM XWBUT",571 ,0)
  42986    D BBDUMP( CHBI)
  42987   "RTN","CHM XWBUT",572 ,0)
  42988    Q:$D(DUOU T)
  42989   "RTN","CHM XWBUT",573 ,0)
  42990    D CBDUMP( CHCI)
  42991   "RTN","CHM XWBUT",574 ,0)
  42992    Q:$D(DUOU T)
  42993   "RTN","CHM XWBUT",575 ,0)
  42994    D EBDUMP( CHEI)
  42995   "RTN","CHM XWBUT",576 ,0)
  42996    Q:$D(DUOU T)
  42997   "RTN","CHM XWBUT",577 ,0)
  42998    D FBDUMP( CHFI)
  42999   "RTN","CHM XWBUT",578 ,0)
  43000    Q
  43001   "RTN","CHM XWBUT",579 ,0)
  43002    
  43003   "RTN","CHM XWBUT",580 ,0)
  43004   BTCHDUMP(I VAL)
  43005   "RTN","CHM XWBUT",581 ,0)
  43006    W !,?10," 837 CLAIM  BATCH FILE  ^CHMXCL(" ,IVAL,",0) ",!!
  43007   "RTN","CHM XWBUT",582 ,0)
  43008    S DA=IVAL
  43009   "RTN","CHM XWBUT",583 ,0)
  43010    S DIC="^C HMXCL"_"("  
  43011   "RTN","CHM XWBUT",584 ,0)
  43012    D EN^DIQ
  43013   "RTN","CHM XWBUT",585 ,0)
  43014    Q 
  43015   "RTN","CHM XWBUT",586 ,0)
  43016    
  43017   "RTN","CHM XWBUT",587 ,0)
  43018   ABDUMP(IVA L)
  43019   "RTN","CHM XWBUT",588 ,0)
  43020    W !,?10," 837 TRANSA CTION BUFF ER ^CHMXCL A(",IVAL," ,0)",!!
  43021   "RTN","CHM XWBUT",589 ,0)
  43022    S DA=IVAL
  43023   "RTN","CHM XWBUT",590 ,0)
  43024    S DIC="^C HMXCLA"_"(
  43025   "RTN","CHM XWBUT",591 ,0)
  43026    D EN^DIQ
  43027   "RTN","CHM XWBUT",592 ,0)
  43028    Q 
  43029   "RTN","CHM XWBUT",593 ,0)
  43030    
  43031   "RTN","CHM XWBUT",594 ,0)
  43032   BBDUMP(IVA L)
  43033   "RTN","CHM XWBUT",595 ,0)
  43034    N NODE  S  NODE=1
  43035   "RTN","CHM XWBUT",596 ,0)
  43036    W !?10,"P ROVIDER BU FFER  ^CHM XCLB(",IVA L,",0)",!!
  43037   "RTN","CHM XWBUT",597 ,0)
  43038    S DA=IVAL
  43039   "RTN","CHM XWBUT",598 ,0)
  43040    S DIC="^C HMXCLB"_"(
  43041   "RTN","CHM XWBUT",599 ,0)
  43042    D EN^DIQ
  43043   "RTN","CHM XWBUT",600 ,0)
  43044    Q 
  43045   "RTN","CHM XWBUT",601 ,0)
  43046    
  43047   "RTN","CHM XWBUT",602 ,0)
  43048   CBDUMP(IVA L)
  43049   "RTN","CHM XWBUT",603 ,0)
  43050    W !,?10," PATIENT BU FFER ^CHMX CLC(",IVAL ,",0)",!!
  43051   "RTN","CHM XWBUT",604 ,0)
  43052    S DA=IVAL
  43053   "RTN","CHM XWBUT",605 ,0)
  43054    S DIC="^C HMXCLC"_"(
  43055   "RTN","CHM XWBUT",606 ,0)
  43056    D EN^DIQ
  43057   "RTN","CHM XWBUT",607 ,0)
  43058    Q 
  43059   "RTN","CHM XWBUT",608 ,0)
  43060    
  43061   "RTN","CHM XWBUT",609 ,0)
  43062   EBDUMP(IVA L)
  43063   "RTN","CHM XWBUT",610 ,0)
  43064    W !,?10," CLAIM BUFF ER ^CHMXCL E(",IVAL," ,0)",!!
  43065   "RTN","CHM XWBUT",611 ,0)
  43066    S DA=IVAL
  43067   "RTN","CHM XWBUT",612 ,0)
  43068    S DIC="^C HMXCLE"_"(
  43069   "RTN","CHM XWBUT",613 ,0)
  43070    D EN^DIQ
  43071   "RTN","CHM XWBUT",614 ,0)
  43072    Q
  43073   "RTN","CHM XWBUT",615 ,0)
  43074    
  43075   "RTN","CHM XWBUT",616 ,0)
  43076   FBDUMP(IVA L)
  43077   "RTN","CHM XWBUT",617 ,0)
  43078    N CLMID,T STVAL,EXIT
  43079   "RTN","CHM XWBUT",618 ,0)
  43080    S CLMID=$ P(^CHMXCLF (IVAL,0)," ^",1),EXIT =0
  43081   "RTN","CHM XWBUT",619 ,0)
  43082    F  S TSTV AL=$P($G(^ CHMXCLF(IV AL,0)),"^" ,1) Q:EXIT   D
  43083   "RTN","CHM XWBUT",620 ,0)
  43084    .I TSTVAL '=CLMID S  EXIT=1 Q
  43085   "RTN","CHM XWBUT",621 ,0)
  43086    .W !,"LIN E ITEM BUF FER ^CHMXC LF(",IVAL, ",0)  CLM  #:",CLMID, "      LIN E NUMBER:  ",$P(^CHMX CLF(IVAL,0 ),"^",2),! !
  43087   "RTN","CHM XWBUT",622 ,0)
  43088    .S DA=IVA L
  43089   "RTN","CHM XWBUT",623 ,0)
  43090    .S DIC="^ CHMXCLF"_" (" 
  43091   "RTN","CHM XWBUT",624 ,0)
  43092    .D EN^DIQ
  43093   "RTN","CHM XWBUT",625 ,0)
  43094    .S IVAL=I VAL+1
  43095   "RTN","CHM XWBUT",626 ,0)
  43096    Q  
  43097   "RTN","CHM XWBUT",627 ,0)
  43098    
  43099   "RTN","CHM XWBUT",628 ,0)
  43100    
  43101   "RTN","CHM XWBUT",629 ,0)
  43102   HLP1 W !!, "Enter eit her 'R' to  look up a n HAC Refe rence Numb er or 'C'  to look up  a",!,"pro vider supp lied Claim /Patient C ontrol Num ber"
  43103   "RTN","CHM XWBUT",630 ,0)
  43104    Q
  43105   "RTN","CHM XWBUT",631 ,0)
  43106    ; 
  43107   "RTN","CHM XWBUT",632 ,0)
  43108   HLP2 W !!, "Enter the  HAC Refer ence Numbe r to look  up."
  43109   "RTN","CHM XWBUT",633 ,0)
  43110    Q
  43111   "RTN","CHM XWBUT",634 ,0)
  43112    ; 
  43113   "RTN","CHM XWBUT",635 ,0)
  43114   HLP3 W !!, "The HAC R eference N umber MUST  be 15 cha racters in  length, e g: 2000158 00000154"
  43115   "RTN","CHM XWBUT",636 ,0)
  43116    W !!,"Pre ss <RETURN > to Conti nue . . .  ." R X:999
  43117   "RTN","CHM XWBUT",637 ,0)
  43118    Q
  43119   "RTN","CHM XWBUT",638 ,0)
  43120    
  43121   "RTN","CHM XWBUT",639 ,0)
  43122   MSG1 W !!, "That HAC  Reference  Number cou ld NOT be  found in t he EDI Buf fer Files. "
  43123   "RTN","CHM XWBUT",640 ,0)
  43124    W !,"Plea se contact  OCIO HELP  DESK if y ou believe  this to b e an error ."
  43125   "RTN","CHM XWBUT",641 ,0)
  43126    Q
  43127   "RTN","CHM XWBUT",642 ,0)
  43128    ; 
  43129   "RTN","CHM XWBUT",643 ,0)
  43130   MSG2 W !!, "While tha t HAC Refe rence Numb er does ex ist, no da ta in the  EDI Buffer  Files",!, "could be  found.  Pl ease conta ct OCIO HE LP DESK."
  43131   "RTN","CHM XWBUT",644 ,0)
  43132    Q
  43133   "RTN","CHM XWBUT",645 ,0)
  43134    ; 
  43135   "RTN","CHM XWBUT",646 ,0)
  43136   SBRS R Y:$ S($D(DTIME ):DTIME,1: 999)
  43137   "RTN","CHM XWBUT",647 ,0)
  43138    I '$T W * 7 R Y:999  G SBRS:Y=" ." S:'$T Y =IOZFO
  43139   "RTN","CHM XWBUT",648 ,0)
  43140   SBRS1 K DF OUT,DUOUT, DQOUT 
  43141   "RTN","CHM XWBUT",649 ,0)
  43142    S:'$D(IOZ FO) IOZFO= "^^" 
  43143   "RTN","CHM XWBUT",650 ,0)
  43144    S:'$D(IOZ BK) IOZBK= "^"
  43145   "RTN","CHM XWBUT",651 ,0)
  43146    I IOZFO=Y  W:$D(IOZF ) @IOZF S  (DFOUT,Y)= "" Q
  43147   "RTN","CHM XWBUT",652 ,0)
  43148    S:Y=IOZBK  (DUOUT,Y) ="" 
  43149   "RTN","CHM XWBUT",653 ,0)
  43150    S:Y?1"?". E!(Y["^")  (DQOUT,Y)= ""
  43151   "RTN","CHM XWBUT",654 ,0)
  43152    Q
  43153   "RTN","CHM XWBUT",655 ,0)
  43154    ;
  43155   "RTN","CHM XWBUT",656 ,0)
  43156    
  43157   "RTN","CHM XWBUT",657 ,0)
  43158    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  43159   "RTN","CHM XWBUT",658 ,0)
  43160    ; MORE_SC ROLL_EXIT  FUNCTION P ROVIDED FO R QA IN RE SPONSE TO  THE STATIS TICS REPOR T
  43161   "RTN","CHM XWBUT",659 ,0)
  43162    ; DATA DI SPLAY.  JE FF N. REQU IRED THIS  CAPABILITY  FOR VIEWI NG THE STA TISTICS
  43163   "RTN","CHM XWBUT",660 ,0)
  43164    ; DETAIL  REPORT WHE N IT HAS B EEN SET TO  "VIEW" MO DE.
  43165   "RTN","CHM XWBUT",661 ,0)
  43166    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  43167   "RTN","CHM XWBUT",662 ,0)
  43168    
  43169   "RTN","CHM XWBUT",663 ,0)
  43170   MOSCREX(PA GE)   ; "M ORE","SCRO LL","EXIT"  ROUTINE
  43171   "RTN","CHM XWBUT",664 ,0)
  43172   GET W !!," ENTER ""M" " -OR- ""< CR>"" FOR  MORE, ""S" " FOR SCRO LL, ""^^""  TO EXIT:   "
  43173   "RTN","CHM XWBUT",665 ,0)
  43174    S Y="" D  SBRS  
  43175   "RTN","CHM XWBUT",666 ,0)
  43176    S PAGE=$S ("Mm"[Y:($ Y+20),"Ss" [Y:0,1:($Y +20))
  43177   "RTN","CHM XWBUT",667 ,0)
  43178    Q PAGE
  43179   "RTN","CHM XWBUT",668 ,0)
  43180    
  43181   "RTN","CHM XWBUT",669 ,0)
  43182    
  43183   "RTN","CHM XWBUT",670 ,0)
  43184    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  43185   "RTN","CHM XWBUT",671 ,0)
  43186    ; OUTPUT  DEBUG STAT EMENTS TO  A LOGFILE. TXT IN THE  TARGET DI RECTORY FO R THE 
  43187   "RTN","CHM XWBUT",672 ,0)
  43188    ; PRIMARY  STATUS. T HIS FUNCTI ON USES A  PREVIOUSLY  CREATED I O ("LOGFIL E"), OR
  43189   "RTN","CHM XWBUT",673 ,0)
  43190    ; IF "LOG FILE" IS N OT DEFINED , OPENS A  FILE AN US ES THAT IO  FOR DEBUG  LOGGING.
  43191   "RTN","CHM XWBUT",674 ,0)
  43192    ; NOTE: T HE SXC (PH ARMACY) CL AIMS ALL U SE THE SAM E OUTPUT D IRECTORY
  43193   "RTN","CHM XWBUT",675 ,0)
  43194    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  43195   "RTN","CHM XWBUT",676 ,0)
  43196    ; EXAMPLE  USAGE: D  DEBUG^CHMX MDRV("DEBU G OUTPUT=  ",VARIABLE )
  43197   "RTN","CHM XWBUT",677 ,0)
  43198    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  43199   "RTN","CHM XWBUT",678 ,0)
  43200    
  43201   "RTN","CHM XWBUT",679 ,0)
  43202    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  43203   "RTN","CHM XWBUT",680 ,0)
  43204    ; DEBUG L OGGING ROU TINE USED  TO LOG THE  FRONT END  EDIT PROC ESS, INCLU DING THE 
  43205   "RTN","CHM XWBUT",681 ,0)
  43206    ; RECORDS  READ FROM  THE CLAIM  FILE, THE  FUNCTIONS  CALLED TO  PERFORM T HE EDITS,
  43207   "RTN","CHM XWBUT",682 ,0)
  43208    ; AND THE  LOGGING O F THE ERRO RS ENCOUNT ERED FROM  THE EDIT P ROCESS.
  43209   "RTN","CHM XWBUT",683 ,0)
  43210    ; THE INT ENDED USE  FOR THIS F UNCTION IS  IN  THE D EVELOPMENT  OR TEST E NVIRONMENT S
  43211   "RTN","CHM XWBUT",684 ,0)
  43212    ; AND TO  ENSURE THA T IT IS NO T EXECUTED  IN THE "P RODUCTION"  ENVIRONME NT
  43213   "RTN","CHM XWBUT",685 ,0)
  43214    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  43215   "RTN","CHM XWBUT",686 ,0)
  43216      
  43217   "RTN","CHM XWBUT",687 ,0)
  43218   DEBUG(STR, VALUE)
  43219   "RTN","CHM XWBUT",688 ,0)
  43220    ;      ST R              A USER  PROVIDED  STRING DES CRIBING TH E VALUE (I .E. "RECOR D INFORMAT ION=",
  43221   "RTN","CHM XWBUT",689 ,0)
  43222    ;   VALUE       THE  VALUE TO B E DISPLAYE D IN THE L OG FOR THE  LOGGING E NTRY.
  43223   "RTN","CHM XWBUT",690 ,0)
  43224    N ENV,TMP IO
  43225   "RTN","CHM XWBUT",691 ,0)
  43226           S  ENV=$$ENVI R^CHTFLIB(
  43227   "RTN","CHM XWBUT",692 ,0)
  43228    Q:ENV["LI VE"                                      ;  CHECK THE  CURRENT WO RKING ENVI RONMENT
  43229   "RTN","CHM XWBUT",693 ,0)
  43230    S TMPIO=$ IO                                                                           ; SAVE THE  CURRENT I O VARIABLE
  43231   "RTN","CHM XWBUT",694 ,0)
  43232    I '$D(LOG FILE) D                                                             ; IF NO  LOGFILE CR EATED, CRE ATE ONE
  43233   "RTN","CHM XWBUT",695 ,0)
  43234    .S LOGFIL E="CHAMPVA _USER:[VHA HACBUNTAD] ACCLOGFILE .TXT" ; TR AGET OUTPU T DIR/FILE NAME
  43235   "RTN","CHM XWBUT",696 ,0)
  43236           .; O LOGFILE: "NWS":5 ;  DEBUG OUTP UT FILE                            ; OPEN T HE LOGFILE
  43237   "RTN","CHM XWBUT",697 ,0)
  43238           .I  '$$OPENFI WR^CHTFLIB 9(.LOGFILE ,"LOGFILE" ) Q        ; DEF01655 4 02/04/20 14
  43239   "RTN","CHM XWBUT",698 ,0)
  43240           U  LOGFILE W  !,STR,VALU E                                                              ;  OUTPUT LOG GING STATE MENT
  43241   "RTN","CHM XWBUT",699 ,0)
  43242           U  TMPIO                                                                                                  ; REST ORE TO THE  ORIGINAL  IO
  43243   "RTN","CHM XWBUT",700 ,0)
  43244           Q
  43245   "RTN","CHM XWBUT",701 ,0)
  43246    
  43247   "RTN","CHM XWBUT",702 ,0)
  43248    
  43249   "RTN","CHM XWBUT",703 ,0)
  43250           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  43251   "RTN","CHM XWBUT",704 ,0)
  43252           ;  A NUMBER O F ROUTINES , IN PARTI CULAR THE  EDI BUFFER  DISPLAY R OUTINE CHM XIN01.INT
  43253   "RTN","CHM XWBUT",705 ,0)
  43254           ;  SET UP SCR EEN PARAME TERS FOR D ISPLAYING  DATA FROM  THE CACHE  GLOBAL FIL ES.  THE
  43255   "RTN","CHM XWBUT",706 ,0)
  43256           ;  PURPOSE OF  THIS ROUT INE IS TO  "RESET" TH E SCREEN T O ALLOW SC ROLLING OF  DATA IN
  43257   "RTN","CHM XWBUT",707 ,0)
  43258           ;  A NORMAL P ROCESS.  T HIS HAS BE EN ADDED T O THIS UTI LITY ROUTI NE TO TO A LLOW A MOR E
  43259   "RTN","CHM XWBUT",708 ,0)
  43260           ;  GENERIC LO CATION FOR  THE FUNCT ION.
  43261   "RTN","CHM XWBUT",709 ,0)
  43262           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  43263   "RTN","CHM XWBUT",710 ,0)
  43264           
  43265   "RTN","CHM XWBUT",711 ,0)
  43266   RESETSCR
  43267   "RTN","CHM XWBUT",712 ,0)
  43268    S (IOF,IO ZF)="#,*27 ,*91,*50,* 74,*27,*91 ,*72"
  43269   "RTN","CHM XWBUT",713 ,0)
  43270    S CHALLOF F="*27,*91 ,*48,*109"     ;SKD
  43271   "RTN","CHM XWBUT",714 ,0)
  43272    S (CHMARE SE,CHMARES ET)="*27,* 91,*114"
  43273   "RTN","CHM XWBUT",715 ,0)
  43274    S CHRESET ="W @CHMAR ESE,@CHALL OFF,#,@IOZ F"   ;SKD
  43275   "RTN","CHM XWBUT",716 ,0)
  43276    XECUTE CH RESET
  43277   "RTN","CHM XWBUT",717 ,0)
  43278    Q
  43279   "RTN","CHM XWBUT",718 ,0)
  43280    
  43281   "RTN","CHM XWBUT",719 ,0)
  43282    
  43283   "RTN","CHM XWBUT",720 ,0)
  43284    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  43285   "RTN","CHM XWBUT",721 ,0)
  43286    ; R2D2 (R EAD 2, DIS PLAY 2) WI LL OUTPUT  THE FIRST  2 LINES OF  THE FILES  SPECIFIED .       
  43287   "RTN","CHM XWBUT",722 ,0)
  43288    ; THIS RO UTINE WAS  PLAGIERIZE D FROM THE  INTERSYST EMS FUNCTI ON RFIRST( ), WHICH
  43289   "RTN","CHM XWBUT",723 ,0)
  43290    ; DISPLAY S THE FIRS T LINE ONL Y OF THE S PECIFIED R OUTINES.   MODIFICATI ONS WERE 
  43291   "RTN","CHM XWBUT",724 ,0)
  43292    ; MADE TO  DISPLAY T HE SECOND  LINE IN OR DER TO CHE CK THE VIS TA "KIDS"  REQUIREMEN T
  43293   "RTN","CHM XWBUT",725 ,0)
  43294    ; FOR THE  FILEMAN B UILD HEADE R. 
  43295   "RTN","CHM XWBUT",726 ,0)
  43296    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;  
  43297   "RTN","CHM XWBUT",727 ,0)
  43298    
  43299   "RTN","CHM XWBUT",728 ,0)
  43300   R2D2 ;Prin t first 2  lines of r outines ;L FT1320 11/ 02/04
  43301   "RTN","CHM XWBUT",729 ,0)
  43302    ;in order  of direct ory, routi ne name, e xtension,  version.
  43303   "RTN","CHM XWBUT",730 ,0)
  43304    ;%sySyste m.inc ; HY Y1347 09/2 0/07
  43305   "RTN","CHM XWBUT",731 ,0)
  43306    ;%sySt.in c  ;HYY134 7 09/20/07
  43307   "RTN","CHM XWBUT",732 ,0)
  43308    ; %system .inc: comp iled for U SEDYNPIDTA B
  43309   "RTN","CHM XWBUT",733 ,0)
  43310    ; %system .inc: comp iled for U SEDYNTTYHA SH
  43311   "RTN","CHM XWBUT",734 ,0)
  43312    ; %system .inc: comp iled for U SETTYHASH
  43313   "RTN","CHM XWBUT",735 ,0)
  43314    /*
  43315   "RTN","CHM XWBUT",736 ,0)
  43316    +-------- ---------- ---------- ---------- ---------- --------+
  43317   "RTN","CHM XWBUT",737 ,0)
  43318    | Copyrig ht 1986-20 08 by Inte rSystems C orporation ,       |
  43319   "RTN","CHM XWBUT",738 ,0)
  43320    | Cambrid ge, Massac husetts, U .S.A.                         |
  43321   "RTN","CHM XWBUT",739 ,0)
  43322    | All rig hts reserv ed.                                      |
  43323   "RTN","CHM XWBUT",740 ,0)
  43324    |                                                             |
  43325   "RTN","CHM XWBUT",741 ,0)
  43326    | Confide ntial, unp ublished p roperty of  InterSyst ems.    |
  43327   "RTN","CHM XWBUT",742 ,0)
  43328    |                                                             |
  43329   "RTN","CHM XWBUT",743 ,0)
  43330    | This me dia contai ns an auth orized cop y or copie s       |
  43331   "RTN","CHM XWBUT",744 ,0)
  43332    | of mate rial copyr ighted by  InterSyste ms and is  the     |
  43333   "RTN","CHM XWBUT",745 ,0)
  43334    | confide ntial, unp ublished p roperty of  InterSyst ems.    |
  43335   "RTN","CHM XWBUT",746 ,0)
  43336    | This co pyright no tice and a ny other c opyright n otices  |
  43337   "RTN","CHM XWBUT",747 ,0)
  43338    | include d in machi ne readabl e copies m ust be rep roduced |
  43339   "RTN","CHM XWBUT",748 ,0)
  43340    | on all  authorized  copies.                                 |
  43341   "RTN","CHM XWBUT",749 ,0)
  43342    +-------- ---------- ---------- ---------- ---------- --------+
  43343   "RTN","CHM XWBUT",750 ,0)
  43344    */
  43345   "RTN","CHM XWBUT",751 ,0)
  43346   NMAX I '$G (NMAX) N N MAX S NMAX =2 ;BB007
  43347   "RTN","CHM XWBUT",752 ,0)
  43348    ;EP with  'NMAX' = #  of top li nes to pri nt
  43349   "RTN","CHM XWBUT",753 ,0)
  43350    I '$D(NMA X) N NMAX  S NMAX=1
  43351   "RTN","CHM XWBUT",754 ,0)
  43352    N POP,%ms ub,SELF,CR T,PAGE,NEW PAGE,DEFDI R
  43353   "RTN","CHM XWBUT",755 ,0)
  43354    N DIRNAM, FROMDN,THR UDN,NOW,DA TES,%TIM
  43355   "RTN","CHM XWBUT",756 ,0)
  43356    N %A,%E,% X,%ANS,IO, IOF,IOM,IO ST,IOT,IOB S,IOPAR,IO SL,RMSDF
  43357   "RTN","CHM XWBUT",757 ,0)
  43358    ;
  43359   "RTN","CHM XWBUT",758 ,0)
  43360    D INT^%T  S NOW=$ZDA TE(+$H,2,, 4)_"  "_%T IM
  43361   "RTN","CHM XWBUT",759 ,0)
  43362    W !,"Prin t first "_ $S(NMAX=1: "line",1:N MAX_" comm ent lines" )
  43363   "RTN","CHM XWBUT",760 ,0)
  43364    W " of se lected rou tines or i nclude fil es.",!
  43365   "RTN","CHM XWBUT",761 ,0)
  43366    ;
  43367   "RTN","CHM XWBUT",762 ,0)
  43368    New %NOWI LDEXT Set  %NOWILDEXT =1
  43369   "RTN","CHM XWBUT",763 ,0)
  43370    D ^%RSETN ("Routine( s): ","SD" ,"MAC,INT, INC,BAS,MV B,MVI","DN EV") G KIL L:POP              ;  DAS462,DAS 472
  43371   "RTN","CHM XWBUT",764 ,0)
  43372    I $O(^mte mp(%msub," "))="" G K ILL
  43373   "RTN","CHM XWBUT",765 ,0)
  43374    ;
  43375   "RTN","CHM XWBUT",766 ,0)
  43376    D DATES ; get FROMDN , THRUDN
  43377   "RTN","CHM XWBUT",767 ,0)
  43378    ;
  43379   "RTN","CHM XWBUT",768 ,0)
  43380    N IOMS s  IOMS=$Syst em.Device. GetRightMa rgin()
  43381   "RTN","CHM XWBUT",769 ,0)
  43382    W !!,"Out put on" D  OUT^%IS G  KILL:POP
  43383   "RTN","CHM XWBUT",770 ,0)
  43384    S SELF=($ I=IO),CRT= ($E(IOST)= "C") S:'SE LF CRT=0
  43385   "RTN","CHM XWBUT",771 ,0)
  43386    S NEWPAGE =1,PAGE="" ,DEFDIR=$$ DEFDIR()
  43387   "RTN","CHM XWBUT",772 ,0)
  43388    ;
  43389   "RTN","CHM XWBUT",773 ,0)
  43390    U IO D DO IT I 'SELF  U IO W @I OF C IO
  43391   "RTN","CHM XWBUT",774 ,0)
  43392    U:SELF IO :IOMS 
  43393   "RTN","CHM XWBUT",775 ,0)
  43394   KILL I $D( %msub) K ^ mtemp(%msu b)
  43395   "RTN","CHM XWBUT",776 ,0)
  43396    U 0 Q
  43397   "RTN","CHM XWBUT",777 ,0)
  43398   DEFDIR() N  %A,%ST,DE ND,DIRNAM, GD,RD,NUMM AP D DEFAU LT^%SYS.FI LE C 63 Q  DIRNAM
  43399   "RTN","CHM XWBUT",778 ,0)
  43400   DOIT ;go t hrough the  selected  routines a nd print o ut the fir st lines
  43401   "RTN","CHM XWBUT",779 ,0)
  43402    N SD,SYS, DIR,EXT,VE R,ROU,BRAC KET,DATE,X ,I,N,T,COU NT
  43403   "RTN","CHM XWBUT",780 ,0)
  43404    S SD=""
  43405   "RTN","CHM XWBUT",781 ,0)
  43406   SD S SD=$O (^mtemp(%m sub,SD)) I  SD="" Q
  43407   "RTN","CHM XWBUT",782 ,0)
  43408    S SYS=$P( SD,"@"),DI R=$P(SD,"@ ",2),ROU=" ",NEWPAGE= 1,COUNT=0
  43409   "RTN","CHM XWBUT",783 ,0)
  43410   ROU S ROU= $O(^mtemp( %msub,SD,R OU)) I ROU ="" G SD
  43411   "RTN","CHM XWBUT",784 ,0)
  43412    S EXT=""  F  S EXT=$ O(^mtemp(% msub,SD,RO U,EXT)) Q: EXT=""  D
  43413   "RTN","CHM XWBUT",785 ,0)
  43414    . S VER=" " F  S VER =$O(^mtemp (%msub,SD, ROU,EXT,VE R)) Q:VER= ""  D EXT
  43415   "RTN","CHM XWBUT",786 ,0)
  43416    Q:POP  G  ROU
  43417   "RTN","CHM XWBUT",787 ,0)
  43418   EXT ;for e ach extens ion, go th rough the  versions
  43419   "RTN","CHM XWBUT",788 ,0)
  43420    S BRACKET =""
  43421   "RTN","CHM XWBUT",789 ,0)
  43422    S:DIR]""  BRACKET=$S (SYS="":"| """_DIR_"" "|",1:"|"" ^"_SYS_"^" _DIR_"""|" )
  43423   "RTN","CHM XWBUT",790 ,0)
  43424    D ONEROU
  43425   "RTN","CHM XWBUT",791 ,0)
  43426    Q
  43427   "RTN","CHM XWBUT",792 ,0)
  43428   VER S VER= $O(^mtemp( %msub,SD,R OU,EXT,VER )) I VER=" " Q
  43429   "RTN","CHM XWBUT",793 ,0)
  43430    D ONEROU  G VER
  43431   "RTN","CHM XWBUT",794 ,0)
  43432   ONEROU ;fo r one rout ine, figur e it all o ut
  43433   "RTN","CHM XWBUT",795 ,0)
  43434    I EXT="IN T" N VER S  VER=0
  43435   "RTN","CHM XWBUT",796 ,0)
  43436    ;DAS351+        
  43437   "RTN","CHM XWBUT",797 ,0)
  43438    I EXT="BA S"!(EXT="M VI") N VER  S VER=0                    ; DA S462,DAS47 2
  43439   "RTN","CHM XWBUT",798 ,0)
  43440    ;DAS351-
  43441   "RTN","CHM XWBUT",799 ,0)
  43442    S DATE=$$ DATE() I F ROMDN]"",D ATE<FROMDN  Q  ;too e arly
  43443   "RTN","CHM XWBUT",800 ,0)
  43444    I THRUDN] "",DATE>TH RUDN Q  ;t oo late
  43445   "RTN","CHM XWBUT",801 ,0)
  43446    ;
  43447   "RTN","CHM XWBUT",802 ,0)
  43448    N NAME S  NAME=ROU_" ."_EXT_$S( VER>1:"."_ VER,1:"")
  43449   "RTN","CHM XWBUT",803 ,0)
  43450    D CHKDY(N MAX+4) Q:P OP
  43451   "RTN","CHM XWBUT",804 ,0)
  43452    S COUNT=C OUNT+1 ;nu mber of ro utines pri nted
  43453   "RTN","CHM XWBUT",805 ,0)
  43454    I 'SELF U  0 W:COUNT -1#5=0 ! W  ?(COUNT-1 #5*15),NAM E_" " U IO
  43455   "RTN","CHM XWBUT",806 ,0)
  43456    ;
  43457   "RTN","CHM XWBUT",807 ,0)
  43458    W !,NAME_ " " ;start  with the  routine na me
  43459   "RTN","CHM XWBUT",808 ,0)
  43460    N NL,NSP  S NSP=$P(B RACKET,"|" ,2),NL=$$L ENGTH^%R(R OU_"."_EXT _"."_VER,N SP)
  43461   "RTN","CHM XWBUT",809 ,0)
  43462    S N=0 F I =1:1:NL S  T=$$LINE^% R(ROU_"."_ EXT_"."_VE R,I,NSP) I  T]"" S N= N+1 D ONET  Q:'N
  43463   "RTN","CHM XWBUT",810 ,0)
  43464    I NMAX>1, $X W ! ;en d with a b lank line
  43465   "RTN","CHM XWBUT",811 ,0)
  43466    Q
  43467   "RTN","CHM XWBUT",812 ,0)
  43468   ONET I N>N MAX S N=0  Q  ;too ma ny lines a lready
  43469   "RTN","CHM XWBUT",813 ,0)
  43470    I N=1 G O UT ;force  printing i t
  43471   "RTN","CHM XWBUT",814 ,0)
  43472    I $P(T,"  ",2,999)?. " "1";".E  G OUT ;it  is a comme nt
  43473   "RTN","CHM XWBUT",815 ,0)
  43474    I T?." "1 "#"1A.E G  OUT ;it's  a compiler  directive
  43475   "RTN","CHM XWBUT",816 ,0)
  43476    S N=0 Q   ;otherwise , skip it
  43477   "RTN","CHM XWBUT",817 ,0)
  43478   OUT ;print  out T on  one or mor e lines, g iven IOM
  43479   "RTN","CHM XWBUT",818 ,0)
  43480    S X=$P(T, " "),X=$E( X_$J("",7) ,1,7)_$E(X ,8,99)_" " _$P(T," ", 2,999)
  43481   "RTN","CHM XWBUT",819 ,0)
  43482    S TB=$S($ X>15:$X,1: 15)
  43483   "RTN","CHM XWBUT",820 ,0)
  43484   LOOP W ?TB ,$E(X,1,IO M-TB-1),!  S X=$E(X,I OM-TB,*),T B=15 I X]" " G LOOP
  43485   "RTN","CHM XWBUT",821 ,0)
  43486    Q
  43487   "RTN","CHM XWBUT",822 ,0)
  43488   CHKDY(Y) I  'NEWPAGE, $Y+Y'>IOSL  Q  ;no ne ed for new  page
  43489   "RTN","CHM XWBUT",823 ,0)
  43490    I CRT,PAG E]"" N C W  ! D MORE  Q:POP  ;BB 008
  43491   "RTN","CHM XWBUT",824 ,0)
  43492    S NEWPAGE =0,COUNT=0 ,PAGE=0 W  @IOF ;skip  to new pa ge
  43493   "RTN","CHM XWBUT",825 ,0)
  43494    D CC("Fir st Line"_$ S(NMAX=1:" ",1:"s")_"  of Select ed Routine s Files")
  43495   "RTN","CHM XWBUT",826 ,0)
  43496    I DATES]" " D CC(DAT ES)
  43497   "RTN","CHM XWBUT",827 ,0)
  43498    S X=$S(DI R="":DEFDI R,1:DIR)_$ S(SYS]"":"   -  Direc tory Set:  "_SYS,1:"" )
  43499   "RTN","CHM XWBUT",828 ,0)
  43500    D CC("Dir ectory: "_ X) I 'CRT  D CC(NOW)
  43501   "RTN","CHM XWBUT",829 ,0)
  43502    W ! Q
  43503   "RTN","CHM XWBUT",830 ,0)
  43504   CC(X) W !? IOM-$L(X)\ 2,X Q
  43505   "RTN","CHM XWBUT",831 ,0)
  43506   MORE R !," --more--", *C I C'=10 ,C'=13,C'= 27,C'=32,C '=53 S POP =1 Q  ;BB0 08 ;BB151
  43507   "RTN","CHM XWBUT",832 ,0)
  43508    Q:C'=63   W "   Retu rn to cont inue ^ to  stop" G MO RE ;BB008
  43509   "RTN","CHM XWBUT",833 ,0)
  43510   DATES ;ask  a from-da te -> upto -date pair
  43511   "RTN","CHM XWBUT",834 ,0)
  43512    N %DS,%DN ,FROMDS,TH RUDS,ERR
  43513   "RTN","CHM XWBUT",835 ,0)
  43514   FROM R !," Find routi nes last m odified si nce date:  ",%DS S:%D S="" FROMD N=""
  43515   "RTN","CHM XWBUT",836 ,0)
  43516    I %DS="?"  W !!?4,"T o include  routines/i nclude fil es last mo dified"
  43517   "RTN","CHM XWBUT",837 ,0)
  43518    I  W !?4, "between s elected da tes, enter  FROM DATE  here.  To "
  43519   "RTN","CHM XWBUT",838 ,0)
  43520    I  W !?4, "include a ll routine s regardle ss of date , leave bl ank.",!
  43521   "RTN","CHM XWBUT",839 ,0)
  43522    I  G FROM
  43523   "RTN","CHM XWBUT",840 ,0)
  43524    I %DS]""  S %DS=$$UP (%DS) D Y2 D^%DATE S  FROMDN=%DN  I %DN<1 W  "  [???]"  G FROM ;B B174
  43525   "RTN","CHM XWBUT",841 ,0)
  43526    I %DS]""  S %DS=$ZDA TE(FROMDN, 2,,4) W "   ("_%DS_") "
  43527   "RTN","CHM XWBUT",842 ,0)
  43528   THRU R !,"                   and  on or bef ore date:  ",%DS S:%D S="" THRUD N=""
  43529   "RTN","CHM XWBUT",843 ,0)
  43530    I %DS="?"  W !!?4,"T o include  routines/i nclude fil es last mo dified"
  43531   "RTN","CHM XWBUT",844 ,0)
  43532    I  W !?4, "between s elected da tes, enter  THROUGH D ATE here.   To"
  43533   "RTN","CHM XWBUT",845 ,0)
  43534    I  W !?4, "include a ll routine s regardle ss of date , "
  43535   "RTN","CHM XWBUT",846 ,0)
  43536    I  W:FROM DN>0 "or s ince "_$ZD ATE(FROMDN ,2,,4)_",  " W ?4,"le ave blank. ",!
  43537   "RTN","CHM XWBUT",847 ,0)
  43538    I  G THRU
  43539   "RTN","CHM XWBUT",848 ,0)
  43540    I %DS]""  S %DS=$$UP (%DS) D Y2 D^%DATE S  THRUDN=%DN  I 1 ;BB17 4
  43541   "RTN","CHM XWBUT",849 ,0)
  43542    I  S ERR= $S(THRUDN< 1:"  [???] ",THRUDN<F ROMDN:"  [ ?backwards ]",1:"")
  43543   "RTN","CHM XWBUT",850 ,0)
  43544    I  I ERR] "" W ERR G  THRU
  43545   "RTN","CHM XWBUT",851 ,0)
  43546    I %DS]""  S %DS=$ZDA TE(THRUDN, 2,,4) W "   ("_%DS_") "
  43547   "RTN","CHM XWBUT",852 ,0)
  43548    I FROMDN_ THRUDN=""  S DATES=""  Q
  43549   "RTN","CHM XWBUT",853 ,0)
  43550    I FROMDN= "" S DATES ="Modified  on or Bef ore "_$ZDA TE(THRUDN, 2,,4) Q
  43551   "RTN","CHM XWBUT",854 ,0)
  43552    I THRUDN= "" S DATES ="Modified  on or Aft er "_$ZDAT E(FROMDN,2 ,,4) Q
  43553   "RTN","CHM XWBUT",855 ,0)
  43554    S DATES=" Modified b etween "_$ ZDATE(FROM DN,2,,4)_"  and "_$ZD ATE(THRUDN ,2,,4) Q
  43555   "RTN","CHM XWBUT",856 ,0)
  43556   DATE() ;gi ven DIR,SY S,VER; loo k for the  date of RO U/EXT
  43557   "RTN","CHM XWBUT",857 ,0)
  43558    n ENV 
  43559   "RTN","CHM XWBUT",858 ,0)
  43560    i SYS=""  s ENV=DIR
  43561   "RTN","CHM XWBUT",859 ,0)
  43562    e  s ENV= "^"_SYS_"^ "_DIR
  43563   "RTN","CHM XWBUT",860 ,0)
  43564    Q $$DATE^ %R(ROU_"." _EXT_"."_V ER,,ENV)
  43565   "RTN","CHM XWBUT",861 ,0)
  43566    Q ""
  43567   "RTN","CHM XWBUT",862 ,0)
  43568   UP(x) Q $z cvt(x,"u")
  43569   "RTN","CHM XWBUT",863 ,0)
  43570    
  43571   "RTN","CHP RD1")
  43572   0^72^B3646 2532
  43573   "RTN","CHP RD1",1,0)
  43574   CHPRD1 ;AE B/CVA;GENE RATES THE  SU PRODUCT IVITY REPO RT;10/10/9 6  3:07 PM
  43575   "RTN","CHP RD1",2,0)
  43576    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  43577   "RTN","CHP RD1",3,0)
  43578    ;CPTS - 1 1061  AEB
  43579   "RTN","CHP RD1",4,0)
  43580    ;; US 005 -029 SBB 1 1/14/2017   - Fixing  Illegal su bscript er ror in CEN D. 
  43581   "RTN","CHP RD1",5,0)
  43582    ;;
  43583   "RTN","CHP RD1",6,0)
  43584   A2B K TMP, TMP1,^TMP1 ($J),^TMP( $J)
  43585   "RTN","CHP RD1",7,0)
  43586    S CHNDAY= 0
  43587   "RTN","CHP RD1",8,0)
  43588    S (DUPTOT ,MDQTOT,PS QTOT,QATOT ,CLMVQTOT, VNDVQTOT,E DTVQTOT,OH ITOT,ASQTO T)=0
  43589   "RTN","CHP RD1",9,0)
  43590    S (EDATE, DAT,CHDAYC K)=$P(STDA T,".",1)
  43591   "RTN","CHP RD1",10,0)
  43592    S CYR=$$F MADD^XLFDT (DAT,-364, 0,0,0),END DT1=ENDDT_ ".99999999 9"
  43593   "RTN","CHP RD1",11,0)
  43594    S EDATE=$ P(ENDDT1," .",1) D OL DCHK^CHPRD 2
  43595   "RTN","CHP RD1",12,0)
  43596   A21 S DAT= $O(^CHMPRO D(741060.0 2,DAT)) G: 'DAT CEND  G:DAT>ENDD T1 CEND
  43597   "RTN","CHP RD1",13,0)
  43598    S:'$D(SDA TE) SDATE= DAT
  43599   "RTN","CHP RD1",14,0)
  43600    S J1=0,CH TYPE="A",A NS="A"
  43601   "RTN","CHP RD1",15,0)
  43602   A22 S (DUP TOT,MDQTOT ,PSQTOT,QA TOT,CLMVQT OT,VNDVQTO T,EDTVQTOT ,OHITOT,AS QTOT)=0
  43603   "RTN","CHP RD1",16,0)
  43604    S J1=$O(^ CHMPROD(74 1060.02,DA T,1,J1)) G :'J1 A21
  43605   "RTN","CHP RD1",17,0)
  43606    I '$D(^CH MPROD(7410 60.02,DAT, 1,J1,0)) G  A22
  43607   "RTN","CHP RD1",18,0)
  43608    S REC1=^C HMPROD(741 060.02,DAT ,1,J1,0)
  43609   "RTN","CHP RD1",19,0)
  43610    S (SDUZ,E MPL)=$P(RE C1,"^",1)
  43611   "RTN","CHP RD1",20,0)
  43612    G:'$D(^CH MDIC(74100 2.21,EMPL) ) A22 G:'$ D(^CHMDIC( 741002.21, EMPL,0)) A 22
  43613   "RTN","CHP RD1",21,0)
  43614    I $P(^CHM DIC(741002 .21,EMPL,0 ),"^",16)' =1 G A22   ;MUST BE S ET AS SU Y ES
  43615   "RTN","CHP RD1",22,0)
  43616    I $P(^CHM DIC(741002 .21,EMPL,0 ),"^",21)= "" G A22   ;MUST BE P A VE OR SV E
  43617   "RTN","CHP RD1",23,0)
  43618    S CHSUCAT =$P(^CHMDI C(741002.2 1,EMPL,0), "^",21)
  43619   "RTN","CHP RD1",24,0)
  43620    I '$D(^CH MDIC(74100 2.21,EMPL, 500)) G A2 2
  43621   "RTN","CHP RD1",25,0)
  43622    S CHPRODT =99999999, CHPRODT=$O (^CHMDIC(7 41002.21,E MPL,500,CH PRODT),-1)  G:'CHPROD T A22
  43623   "RTN","CHP RD1",26,0)
  43624    I '$D(^CH MDIC(74100 2.21,EMPL, 500,CHPROD T,0)) G A2 2
  43625   "RTN","CHP RD1",27,0)
  43626    S GRD=$P( ^CHMDIC(74 1002.21,EM PL,500,CHP RODT,0),"^ ",3)
  43627   "RTN","CHP RD1",28,0)
  43628   ASQ S ASQT OT=ASQTOT+ $P(REC1,"^ ",2)+$P(RE C1,"^",3)+ $P(REC1,"^ ",4)
  43629   "RTN","CHP RD1",29,0)
  43630    S ASQTOT= ASQTOT+$P( REC1,"^",5 )+$P(REC1, "^",6)+$P( REC1,"^",7 )+$P(REC1, "^",8)
  43631   "RTN","CHP RD1",30,0)
  43632    S ASQTOT= ASQTOT+$P( REC1,"^",9 )+$P(REC1, "^",10)+$P (REC1,"^", 11)+$P(REC 1,"^",12)+ $P(REC1,"^ ",13)
  43633   "RTN","CHP RD1",31,0)
  43634    S ASQTOT= ASQTOT+$P( REC1,"^",2 7)+$P(REC1 ,"^",28)   ;aeb 12/31 /2007
  43635   "RTN","CHP RD1",32,0)
  43636   DCQ S DUPT OT=DUPTOT+ $P(REC1,"^ ",14)+$P(R EC1,"^",15 )
  43637   "RTN","CHP RD1",33,0)
  43638   MDQ S MDQT OT=MDQTOT+ $P(REC1,"^ ",25)
  43639   "RTN","CHP RD1",34,0)
  43640   PSQ S PSQT OT=PSQTOT+ $P(REC1,"^ ",26)
  43641   "RTN","CHP RD1",35,0)
  43642   QA S QATOT =QATOT+$P( REC1,"^",1 6)+$P(REC1 ,"^",17)
  43643   "RTN","CHP RD1",36,0)
  43644   CLMVQ S CL MVQTOT=CLM VQTOT+$P(R EC1,"^",20 )+$P(REC1, "^",21)
  43645   "RTN","CHP RD1",37,0)
  43646   VNDVQ S VN DVQTOT=VND VQTOT+$P(R EC1,"^",18 )+$P(REC1, "^",19)
  43647   "RTN","CHP RD1",38,0)
  43648   EDTVQ S ED TVQTOT=EDT VQTOT+$P(R EC1,"^",22 )
  43649   "RTN","CHP RD1",39,0)
  43650   OHICRT S O HITOT=OHIT OT+$P(REC1 ,"^",23)
  43651   "RTN","CHP RD1",40,0)
  43652    I '$D(^VA (200,EMPL, 0)) G A22
  43653   "RTN","CHP RD1",41,0)
  43654    S ENAME=$ P(^VA(200, EMPL,0),"^ ",1)
  43655   "RTN","CHP RD1",42,0)
  43656    ;I DUPTOT =0 I MDQTO T=0 I PSQT OT=0 I QAT OT=0 I CLM VQTOT=0 I  VNDVQTOT=0  I EDTVQTO T=0 I OHIT OT=0 I ASQ TOT=0 G A2 2
  43657   "RTN","CHP RD1",43,0)
  43658    S:'$D(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME)) TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME )=""
  43659   "RTN","CHP RD1",44,0)
  43660    I '$D(^TM P1($J,EMPL ,$P(DAT,". ",1))) D   ;COUNTS TH E NUMBER O F DAYS
  43661   "RTN","CHP RD1",45,0)
  43662    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",20 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",20)+ 1
  43663   "RTN","CHP RD1",46,0)
  43664    .Q
  43665   "RTN","CHP RD1",47,0)
  43666    S TMPASQ= $P(REC1,"^ ",2)+$P(RE C1,"^",3)+ $P(REC1,"^ ",4)+$P(RE C1,"^",5)+ $P(REC1,"^ ",6)+$P(RE C1,"^",7)+ $P(REC1,"^ ",8)+$P(RE C1,"^",9)+ $P(REC1,"^ ",10)+$P(R EC1,"^",11 )+$P(REC1, "^",12)+$P (REC1,"^", 13)+$P(REC 1,"^",27)+ $P(REC1,"^ ",28)  ;ae b 12/31/20 07
  43667   "RTN","CHP RD1",48,0)
  43668    I TMPASQ' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"AS Q")) D  ;A SQ DAY CNT
  43669   "RTN","CHP RD1",49,0)
  43670    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"ASQ")=0
  43671   "RTN","CHP RD1",50,0)
  43672    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",21 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",21)+ 1
  43673   "RTN","CHP RD1",51,0)
  43674    S TMPDCQ= $P(REC1,"^ ",14)+$P(R EC1,"^",15 )
  43675   "RTN","CHP RD1",52,0)
  43676    I TMPDCQ' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"DC Q")) D  ;D CQ DAY CNT
  43677   "RTN","CHP RD1",53,0)
  43678    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"DCQ")=0
  43679   "RTN","CHP RD1",54,0)
  43680    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",22 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",22)+ 1
  43681   "RTN","CHP RD1",55,0)
  43682    .Q
  43683   "RTN","CHP RD1",56,0)
  43684    I +$P(REC 1,"^",25)' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"MD Q")) D  ;M DQ DAY CNT
  43685   "RTN","CHP RD1",57,0)
  43686    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"MDQ")=0
  43687   "RTN","CHP RD1",58,0)
  43688    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",23 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",23)+ 1
  43689   "RTN","CHP RD1",59,0)
  43690    .Q
  43691   "RTN","CHP RD1",60,0)
  43692    I +$P(REC 1,"^",26)' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"PS Q")) D  ;p rob suppor t day cnt
  43693   "RTN","CHP RD1",61,0)
  43694    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"PSQ")=0
  43695   "RTN","CHP RD1",62,0)
  43696    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",24 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",24)+ 1
  43697   "RTN","CHP RD1",63,0)
  43698    .Q
  43699   "RTN","CHP RD1",64,0)
  43700    I +$P(REC 1,"^",16)' =0 I +$P(R EC1,"^",17 )'=0 I '$D (^TMP1($J, EMPL,$P(DA T,".",1)," QAQ")) D   ;QAQ DAY C NT
  43701   "RTN","CHP RD1",65,0)
  43702    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"QAQ")=0
  43703   "RTN","CHP RD1",66,0)
  43704    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",25 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",25)+ 1
  43705   "RTN","CHP RD1",67,0)
  43706    .Q
  43707   "RTN","CHP RD1",68,0)
  43708    I (+$P(RE C1,"^",20) >0)!(+$P(R EC1,"^",21 )>0) I '$D (^TMP1($J, EMPL,$P(DA T,".",1)," VCLM#")) D   ;VNCLMS  DAY CNT
  43709   "RTN","CHP RD1",69,0)
  43710    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"VCLM#") =0
  43711   "RTN","CHP RD1",70,0)
  43712    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",26 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",26)+ 1
  43713   "RTN","CHP RD1",71,0)
  43714    .Q
  43715   "RTN","CHP RD1",72,0)
  43716    I ($P(REC 1,"^",18)> 0)!(+$P(RE C1,"^",19) >0) I '$D( ^TMP1($J,E MPL,$P(DAT ,".",1),"V NQ")) D  ; VNQ DAY CN T
  43717   "RTN","CHP RD1",73,0)
  43718    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"VNQ")=0
  43719   "RTN","CHP RD1",74,0)
  43720    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",27 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",27)+ 1
  43721   "RTN","CHP RD1",75,0)
  43722    .Q
  43723   "RTN","CHP RD1",76,0)
  43724    I +$P(REC 1,"^",22)' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"VN ED")) D  ; VEN EDITS  DAY CNT
  43725   "RTN","CHP RD1",77,0)
  43726    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"VNED")= 0
  43727   "RTN","CHP RD1",78,0)
  43728    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",28 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",28)+ 1
  43729   "RTN","CHP RD1",79,0)
  43730    .Q
  43731   "RTN","CHP RD1",80,0)
  43732    I +$P(REC 1,"^",23)' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"CE RT")) D  ; CERY DAT C NT
  43733   "RTN","CHP RD1",81,0)
  43734    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"CERT")= 0
  43735   "RTN","CHP RD1",82,0)
  43736    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",29 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",29)+ 1
  43737   "RTN","CHP RD1",83,0)
  43738    .Q
  43739   "RTN","CHP RD1",84,0)
  43740   YTOT ;CURR ENT TOTALS
  43741   "RTN","CHP RD1",85,0)
  43742    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",1)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",1)+ASQ TOT
  43743   "RTN","CHP RD1",86,0)
  43744    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",2)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",2)+DUP TOT
  43745   "RTN","CHP RD1",87,0)
  43746    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",3)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",3)+MDQ TOT
  43747   "RTN","CHP RD1",88,0)
  43748    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",4)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",4)+PSQ TOT
  43749   "RTN","CHP RD1",89,0)
  43750    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",5)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",5)+QAT OT
  43751   "RTN","CHP RD1",90,0)
  43752    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",6)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",6)+CLM VQTOT
  43753   "RTN","CHP RD1",91,0)
  43754    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",7)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",7)+VND VQTOT
  43755   "RTN","CHP RD1",92,0)
  43756    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",8)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",8)+EDT VQTOT
  43757   "RTN","CHP RD1",93,0)
  43758    S $P(TMP( "SU-BY-GRA DE",CHSUCA T,GRD,ENAM E),"^",9)= $P(TMP("SU -BY-GRADE" ,CHSUCAT,G RD,ENAME), "^",9)+OHI TOT
  43759   "RTN","CHP RD1",94,0)
  43760    S:'$D(CHD UZL(EMPL))  CHDUZL(EM PL)=GRD_"^ "_ENAME_"^ "_CHSUCAT
  43761   "RTN","CHP RD1",95,0)
  43762    G A22
  43763   "RTN","CHP RD1",96,0)
  43764   CEND K ^TM P1($J)
  43765   "RTN","CHP RD1",97,0)
  43766    D VESTUF^ CHPRD5  ;G ETS SUBS P ROCESSED A ND CLAIMS  CREATED.
  43767   "RTN","CHP RD1",98,0)
  43768    ;SBB 11/1 4/2017 bug  fix
  43769   "RTN","CHP RD1",99,0)
  43770    ;K CHDUZL (EMPL)
  43771   "RTN","CHP RD1",100,0 )
  43772    I $G(EMPL )'="" K CH DUZL(EMPL)
  43773   "RTN","CHP RD1",101,0 )
  43774    I '$D(PFL G) G DSPLY ^CHPRD2
  43775   "RTN","CHP RD1",102,0 )
  43776    S %ZIS="Q ",IOP="Q;" _CHFIO D ^ %ZIS G:POP  END
  43777   "RTN","CHP RD1",103,0 )
  43778    S ZTRTN=" DSPLY^CHPR D2",ZTDTH= $H,ZTSAVE( "PFLG")="" ,ZTSAVE("S DATE")=""
  43779   "RTN","CHP RD1",104,0 )
  43780    S ZTSAVE( "EDATE")=" ",ZTSAVE(" TMP(""SU-B Y-GRADE"", ")="",ZTSA VE("STDAT" )=""
  43781   "RTN","CHP RD1",105,0 )
  43782    S ZTSAVE( "ENDDT1")= "" K ZTIO
  43783   "RTN","CHP RD1",106,0 )
  43784    D ^%ZTLOA D
  43785   "RTN","CHP RD1",107,0 )
  43786    Q
  43787   "RTN","CHP RD1",108,0 )
  43788   END ;
  43789   "RTN","CHP RD1",109,0 )
  43790    K TIM1,IO SUBS,IOCLM S,IOTIME,M SSUBS,MSCL MS,MSTIME, MMSUBS,MMC LMS,MMTIME
  43791   "RTN","CHP RD1",110,0 )
  43792    K DIOPDI, DIOCLM,DIO TIM,DMSPDI ,DMSCLM,DM STIM,DMMPD I,DMMCLM,D MMTIM,I1,J 1
  43793   "RTN","CHP RD1",111,0 )
  43794    Q
  43795   "RTN","CHT FLIB2")
  43796   0^73^B8402 489
  43797   "RTN","CHT FLIB2",1,0 )
  43798   CHTFLIB2 ; CVA/AEB;CH AMPVA TOOL S FUNCTION  LIBRARY;0 2/01/97  9 :24 AM
  43799   "RTN","CHT FLIB2",2,0 )
  43800    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 9
  43801   "RTN","CHT FLIB2",3,0 )
  43802       ;DEV00 7820 EW 4/ 18/11
  43803   "RTN","CHT FLIB2",4,0 )
  43804       ;DEV00 7820 - JAK  - 08/3/11   SLA - ut ility to a dd Adjuste d Allowabl e for clai m
  43805   "RTN","CHT FLIB2",5,0 )
  43806       ;DEV00 7820 - JAK  - 04/20/1 2  SLA - u tility to  add accumu late unit  values to  claim leve l
  43807   "RTN","CHT FLIB2",6,0 )
  43808       ;DEV01 9086 - AEB  11/6/2013  REOPENED  CLAIM NOT  CALCULATIN G CORRETCL Y
  43809   "RTN","CHT FLIB2",7,0 )
  43810       ;DEV01 9516 - DGC  - 06/27/2 014 - POST  SLLA FIX  FOR CEU
  43811   "RTN","CHT FLIB2",8,0 )
  43812       ;MTN02 2926 - JSE  - 04/13/2 015 - FIX  UNDEFINED  ERROR CDER U2+47
  43813   "RTN","CHT FLIB2",9,0 )
  43814       ;ENC02 2643 - DGC  - 01/27/1 6 - ACA IR S LETTERS
  43815   "RTN","CHT FLIB2",10, 0)
  43816       ;DEV02 5393 - JAK  - 02/24/1 6  reject  informatio n stored i n temporar y global
  43817   "RTN","CHT FLIB2",11, 0)
  43818       ;BDB 1 1/13/2017  $G ADDED F OR MISSING  6 NODE
  43819   "RTN","CHT FLIB2",12, 0)
  43820   CHCOI(DUZ, DFN,BFN,CH APP)  ;CHE CKS FOR CO NFLICT OF  INTEREST ( coi)
  43821   "RTN","CHT FLIB2",13, 0)
  43822       ;input
  43823   "RTN","CHT FLIB2",14, 0)
  43824       ;DUZ -  user duz
  43825   "RTN","CHT FLIB2",15, 0)
  43826       ;DFN -  sponsor p ointer
  43827   "RTN","CHT FLIB2",16, 0)
  43828       ;BFN -  bene poin ter
  43829   "RTN","CHT FLIB2",17, 0)
  43830       ;CHAPP  - pointer  to ^CHHAC APS(741062 .03) calli ng applica tion
  43831   "RTN","CHT FLIB2",18, 0)
  43832       ;
  43833   "RTN","CHT FLIB2",19, 0)
  43834       ;retur ns
  43835   "RTN","CHT FLIB2",20, 0)
  43836        ;0 FO R NO ACCES S
  43837   "RTN","CHT FLIB2",21, 0)
  43838        ;1 FO R ACCESS T O BENE REC ORDS
  43839   "RTN","CHT FLIB2",22, 0)
  43840        ;
  43841   "RTN","CHT FLIB2",23, 0)
  43842       I '$D( DT) D NOW^ %DTC S DT= X
  43843   "RTN","CHT FLIB2",24, 0)
  43844       I DT=" " D NOW^%D TC S DT=X
  43845   "RTN","CHT FLIB2",25, 0)
  43846       S RTN= 1  ;DEFAUL T TO GIVE  ACCESS
  43847   "RTN","CHT FLIB2",26, 0)
  43848       G:'$D( ^CHCOI(741 062.01,"B" ,DUZ)) CHC OIE
  43849   "RTN","CHT FLIB2",27, 0)
  43850       S IVAL =0
  43851   "RTN","CHT FLIB2",28, 0)
  43852   CHCOI1 S I VAL=$O(^CH COI(741062 .01,"B",DU Z,IVAL)) G :'IVAL CHC OIE
  43853   "RTN","CHT FLIB2",29, 0)
  43854       G:'$D( ^CHCOI(741 062.01,IVA L,100)) CH COIE  ;NO  COI ENTERE D
  43855   "RTN","CHT FLIB2",30, 0)
  43856       S JVAL =0
  43857   "RTN","CHT FLIB2",31, 0)
  43858   CHCOI2 S J VAL=$O(^CH COI(741062 .01,IVAL,1 00,JVAL))  G:'JVAL CH COI1
  43859   "RTN","CHT FLIB2",32, 0)
  43860       G:'$D( ^CHCOI(741 062.01,IVA L,100,JVAL ,0)) CHCOI 2 S CHCOIR EC=^CHCOI( 741062.01, IVAL,100,J VAL,0)
  43861   "RTN","CHT FLIB2",33, 0)
  43862       I $P(C HCOIREC,"^ ",2)'=DFN  G CHCOI2
  43863   "RTN","CHT FLIB2",34, 0)
  43864       I BFN' ="" I $P(C HCOIREC,"^ ",3)'=BFN  G CHCOI2
  43865   "RTN","CHT FLIB2",35, 0)
  43866       I DT'< $P(CHCOIRE C,"^",4) I  DT'>$P(CH COIREC,"^" ,5) D  G C HCOI2  ;SK IP IF TODA Y IS GREAT ER THENTHE  START DAT E AND LESS  THE THE E ND DATE
  43867   "RTN","CHT FLIB2",36, 0)
  43868       .S RTN =0 D COIAD D
  43869   "RTN","CHT FLIB2",37, 0)
  43870       G CHCO I2
  43871   "RTN","CHT FLIB2",38, 0)
  43872   CHCOIE  Q  RTN
  43873   "RTN","CHT FLIB2",39, 0)
  43874       ;
  43875   "RTN","CHT FLIB2",40, 0)
  43876   COIADD  ;S TORES CONF LICT OF IN TEREST VIO LATIONS.
  43877   "RTN","CHT FLIB2",41, 0)
  43878       ;NEEDS  DUZ,POINT ER TO ^CHH ACAPS,DFN, BFN TO STO RE DATA
  43879   "RTN","CHT FLIB2",42, 0)
  43880       S:'$D( ^CHPCIOL(7 41062.03,0 )) ^CHPCIO L(741062.0 3,0)="HAC  COI VIOLAT IONS^74106 2.02D^0^0"
  43881   "RTN","CHT FLIB2",43, 0)
  43882       D NOW^ %DTC
  43883   "RTN","CHT FLIB2",44, 0)
  43884       L ^CHP CIOL(74106 2.02,0)
  43885   "RTN","CHT FLIB2",45, 0)
  43886       S CHNV AL=$P(^CHP CIOL(74106 2.02,0),"^ ",3)+1
  43887   "RTN","CHT FLIB2",46, 0)
  43888       S $P(^ CHPCIOL(74 1062.02,0) ,"^",3)=CH NVAL
  43889   "RTN","CHT FLIB2",47, 0)
  43890       S $P(^ CHPCIOL(74 1062.02,0) ,"^",4)=CH NVAL L
  43891   "RTN","CHT FLIB2",48, 0)
  43892       S $P(^ CHPCIOL(74 1062.02,CH NVAL,0),"^ ",1)=%
  43893   "RTN","CHT FLIB2",49, 0)
  43894       S $P(^ CHPCIOL(74 1062.02,CH NVAL,0),"^ ",2)=DUZ
  43895   "RTN","CHT FLIB2",50, 0)
  43896       S $P(^ CHPCIOL(74 1062.02,CH NVAL,0),"^ ",3)=CHAPP
  43897   "RTN","CHT FLIB2",51, 0)
  43898       S $P(^ CHPCIOL(74 1062.02,CH NVAL,0),"^ ",4)=DFN
  43899   "RTN","CHT FLIB2",52, 0)
  43900       S $P(^ CHPCIOL(74 1062.02,CH NVAL,0),"^ ",5)=BFN
  43901   "RTN","CHT FLIB2",53, 0)
  43902       S ^CHP CIOL(74106 2.02,"B",% ,CHNVAL)=" "
  43903   "RTN","CHT FLIB2",54, 0)
  43904       S ^CHP CIOL(74106 2.02,"C",D UZ,CHNVAL) =""
  43905   "RTN","CHT FLIB2",55, 0)
  43906       Q
  43907   "RTN","CHT FLIB2",56, 0)
  43908       ;
  43909   "RTN","CHT FLIB2",57, 0)
  43910    ;-------- ---------- --------     DEV00782 0 EW 4/18/ 11 START   ---------- ---------- -------
  43911   "RTN","CHT FLIB2",58, 0)
  43912   CDERU2(CHP TR,CHSUB,S PLTADJ)
  43913   "RTN","CHT FLIB2",59, 0)
  43914    ;THIS ROU TINE IS SI MILAR TO C DERU^CHTFL IB BUT SPL ITS ON ADJ USTED AMOU NT
  43915   "RTN","CHT FLIB2",60, 0)
  43916    ;ROLLS UP  MULTIPLE  PROCEDURE  CODES AND  TOTALS SER VICE LINE  VALUES FOR  REPORTS
  43917   "RTN","CHT FLIB2",61, 0)
  43918    ;INPUT:   CHPTR - PO INTER TO I  VALUE IN  ^CHMPAY
  43919   "RTN","CHT FLIB2",62, 0)
  43920    ;         CHSUB - PO INTER TO S ERVICE VAL UE IN ^CHM PAY
  43921   "RTN","CHT FLIB2",63, 0)
  43922    ;         SPLTADJ -  SPLIT ROLL UP BY ADJU STED AMOUN T (1=YES 0 =NO)
  43923   "RTN","CHT FLIB2",64, 0)
  43924    ;OUTPUT:  RTN - 0 FO R TEMP GLO BAL NOT BU ILT
  43925   "RTN","CHT FLIB2",65, 0)
  43926    ;         RTN - 1 FO R TEMP GLO BAL IS BUI LT
  43927   "RTN","CHT FLIB2",66, 0)
  43928    ;         TEMP GLOBA LS - ^TEMP ($J,"CDERU 2",CHPTR,C HSUB,CHPRC ,PLID,MOD( 1-4),TEST, P/L,REASON ,ADJAMT)=" PQTY^CHTAL L^(PO1^THR U P14)^Emp ty^CHCHG^" J"/Procedu re #^Adjus ted Allowa ble,QA Rec ommendatio n
  43929   "RTN","CHT FLIB2",67, 0)
  43930    ;         CHPRC - PR OCEDURE CO DE
  43931   "RTN","CHT FLIB2",68, 0)
  43932    ;         CHCHG - CH ARGE FOR S ERVICE
  43933   "RTN","CHT FLIB2",69, 0)
  43934    ;         PLID - LIN E NUMBER O R IF NO LI NE NUMBER  CHARGE/UNI T
  43935   "RTN","CHT FLIB2",70, 0)
  43936    ;         CHMD - CON TAINS MODI FIERS(MOD1 ,MOD2,MOD3 ,MOD4)
  43937   "RTN","CHT FLIB2",71, 0)
  43938    ;         PQTY - TOT AL NUMBER  OF PROCEDU RES
  43939   "RTN","CHT FLIB2",72, 0)
  43940    ;         CHTALL - T OTAL AMT A LLOWED FOR  PROCEDURE
  43941   "RTN","CHT FLIB2",73, 0)
  43942    ;         P01 THRU P 14 LINE LE VEL QUANTI TIES
  43943   "RTN","CHT FLIB2",74, 0)
  43944    ;         CHTST - RU LE PROC LA ST TEST
  43945   "RTN","CHT FLIB2",75, 0)
  43946    ;         CHRES - RU LE PROC RE SULT CODE  (for QAQ t he RULE-PR OC will no t be set i f rejected  in QUE so  check RUL E-QA)
  43947   "RTN","CHT FLIB2",76, 0)
  43948    ;         ADJAMT - A DJUSTED AL LOWABLE AM OUNT
  43949   "RTN","CHT FLIB2",77, 0)
  43950    K ^TEMP($ J,"CDERU2" ),^TEMP($J ,"ADJAMT")
  43951   "RTN","CHT FLIB2",78, 0)
  43952    N CHPRC,C HCHG,PLID, CHMD,PQTY, CHTALL,CHT ST,CHRES,A DJAMT,CHAL L,CHRULQA
  43953   "RTN","CHT FLIB2",79, 0)
  43954    S (J2,RTN )=0,CHS="R ULE-PROC", CHRQA="RUL E-QA"
  43955   "RTN","CHT FLIB2",80, 0)
  43956    F  S J2=$ O(^CHMPAY( CHPTR,CHSU B,J2)) Q:' J2  D
  43957   "RTN","CHT FLIB2",81, 0)
  43958    .Q:'$D(^C HMPAY(CHPT R,CHSUB,J2 ,0))
  43959   "RTN","CHT FLIB2",82, 0)
  43960    .S CHPRC= $P(^CHMPAY (CHPTR,CHS UB,J2,0)," ^",1) S:CH PRC="" CHP RC=$E(CHSU B,1,3)
  43961   "RTN","CHT FLIB2",83, 0)
  43962    .S CHCHG= $P(^CHMPAY (CHPTR,CHS UB,J2,0)," ^",2)
  43963   "RTN","CHT FLIB2",84, 0)
  43964    .;I CHCHG ="" S CHCH G="NA"
  43965   "RTN","CHT FLIB2",85, 0)
  43966    .;E  I CH CHG'["."   S CHCHG=CH CHG_".00"
  43967   "RTN","CHT FLIB2",86, 0)
  43968    .S PLID=" "
  43969   "RTN","CHT FLIB2",87, 0)
  43970    .I $D(^CH MPAY(CHPTR ,CHSUB,J2, 1,1,0)) D
  43971   "RTN","CHT FLIB2",88, 0)
  43972    ..S PLID= $P(^CHMPAY (CHPTR,CHS UB,J2,1,1, 0),"^",17)
  43973   "RTN","CHT FLIB2",89, 0)
  43974    .S:PLID=" " PLID=CHC HG
  43975   "RTN","CHT FLIB2",90, 0)
  43976    .S:PLID=" " PLID="NA "
  43977   "RTN","CHT FLIB2",91, 0)
  43978    .S CHRES= "NA"
  43979   "RTN","CHT FLIB2",92, 0)
  43980    .S CHTST= "NA"
  43981   "RTN","CHT FLIB2",93, 0)
  43982    .S ADJAMT ="NA",ADJA MTV=""
  43983   "RTN","CHT FLIB2",94, 0)
  43984    .I $D(^CH MPAY(CHPTR ,CHS,J2,0) )  D
  43985   "RTN","CHT FLIB2",95, 0)
  43986    ..S CHTST =$P(^CHMPA Y(CHPTR,CH S,J2,0),"^ ",4)
  43987   "RTN","CHT FLIB2",96, 0)
  43988    ..I '$D(C HTST) S CH TST="NA" Q
  43989   "RTN","CHT FLIB2",97, 0)
  43990    ..S CHTST =$P(^DIC(7 41100,CHTS T,0),"^",1 ),CHTST=$P (CHTST,"#" ,2)
  43991   "RTN","CHT FLIB2",98, 0)
  43992    ..;I $P(^ CHMPAY(CHP TR,CHS,J2, 0),"^",2)' ="" S CHRE S=$P(^CHMP AY(CHPTR,C HS,J2,0)," ^",2) Q
  43993   "RTN","CHT FLIB2",99, 0)
  43994    ..S X=$P( ^CHMPAY(CH PTR,CHS,J2 ,0),"^",1)
  43995   "RTN","CHT FLIB2",100 ,0)
  43996    ..S CHRES =$S(X=0:$P (^CHMPAY(C HPTR,CHS,J 2,0),"^",2 ),X=1:"Acc ",X=2:"QAA ",X=3:"MsD ",X=4:"QAR ",X=5:"Und ",1:"Err")
  43997   "RTN","CHT FLIB2",101 ,0)
  43998    .I $D(^CH MPAY(CHPTR ,CHRQA,0))  D
  43999   "RTN","CHT FLIB2",102 ,0)
  44000    ..S J3=0
  44001   "RTN","CHT FLIB2",103 ,0)
  44002    ..;I (CHR ES="Acc")! (CHRES="QA A")!(CHRES ="MsD")!(C HRES="Und" )!(CHRES=" Err")!(CHR ES="NA") D
  44003   "RTN","CHT FLIB2",104 ,0)
  44004    ..;F  S J 3=$O(^CHMP AY(CHPTR,C HRQA,J3))  Q:J3=""  D        ;MT N022926 -  JSE - FIX  UNDEF ERRO R
  44005   "RTN","CHT FLIB2",105 ,0)
  44006    ..F  S J3 =$O(^CHMPA Y(CHPTR,CH RQA,J3)) Q :'J3  D
  44007   "RTN","CHT FLIB2",106 ,0)
  44008    ...I ($P( ^CHMPAY(CH PTR,CHRQA, J3,0),"^", 3)=J2)&($P (^CHMPAY(C HPTR,CHRQA ,J3,0),"^" ,1)=2) S X =$P(^CHMPA Y(CHPTR,CH RQA,J3,0), "^",4) S C HRES=$S(X= 0:$P(^CHMP AY(CHPTR,C HRQA,J3,0) ,"^",7),X= 1:"Acc",X= 2:"QAA",X= 3:"MsD",X= 4:"QAR",X= 5:"Und",1: "Err")
  44009   "RTN","CHT FLIB2",107 ,0)
  44010    .I CHSUB= "DEN-PROC"  D
  44011   "RTN","CHT FLIB2",108 ,0)
  44012    ..S:$P(^C HMPAY(CHPT R,CHSUB,J2 ,0),"^",7) '="" ADJAM T=$P(^CHMP AY(CHPTR,C HSUB,J2,0) ,"^",7)
  44013   "RTN","CHT FLIB2",109 ,0)
  44014    ..S CHTAL L=$P(^CHMP AY(CHPTR,C HSUB,J2,0) ,"^",5)
  44015   "RTN","CHT FLIB2",110 ,0)
  44016    ..S (CHMD 1,CHMD2,CH MD3,CHMD4) =""
  44017   "RTN","CHT FLIB2",111 ,0)
  44018    ..S CHMD1 =$P(^CHMPA Y(CHPTR,CH SUB,J2,0), "^",6),CHM D2=$P(^CHM PAY(CHPTR, CHSUB,J2,0 ),"^",22), CHMD3=$P(^ CHMPAY(CHP TR,CHSUB,J 2,0),"^",2 3),CHMD4=$ P(^CHMPAY( CHPTR,CHSU B,J2,0),"^ ",24)
  44019   "RTN","CHT FLIB2",112 ,0)
  44020    ..S CHDME PL="N"
  44021   "RTN","CHT FLIB2",113 ,0)
  44022    .I CHSUB= "INP-PROC"  S CHTALL= "",CHDMEPL ="N"
  44023   "RTN","CHT FLIB2",114 ,0)
  44024    .I CHSUB= "OPT-PROC"  D
  44025   "RTN","CHT FLIB2",115 ,0)
  44026    ..S:$P(^C HMPAY(CHPT R,CHSUB,J2 ,0),"^",5) '="" ADJAM T=$P(^CHMP AY(CHPTR,C HSUB,J2,0) ,"^",5)
  44027   "RTN","CHT FLIB2",116 ,0)
  44028    ..S CHTAL L=$P(^CHMP AY(CHPTR,C HSUB,J2,0) ,"^",3)
  44029   "RTN","CHT FLIB2",117 ,0)
  44030    ..S (CHMD 1,CHMD2,CH MD3,CHMD4) =""
  44031   "RTN","CHT FLIB2",118 ,0)
  44032    ..S CHMD1 =$P(^CHMPA Y(CHPTR,CH SUB,J2,0), "^",4),CHM D2=$P(^CHM PAY(CHPTR, CHSUB,J2,0 ),"^",25), CHMD3=$P(^ CHMPAY(CHP TR,CHSUB,J 2,0),"^",2 6),CHMD4=$ P(^CHMPAY( CHPTR,CHSU B,J2,0),"^ ",27)
  44033   "RTN","CHT FLIB2",119 ,0)
  44034    ..S CHDME PL="N"
  44035   "RTN","CHT FLIB2",120 ,0)
  44036    .I CHSUB= "DME-SUPPL Y" D
  44037   "RTN","CHT FLIB2",121 ,0)
  44038    ..S:$P(^C HMPAY(CHPT R,CHSUB,J2 ,0),"^",5) '="" ADJAM T=$P(^CHMP AY(CHPTR,C HSUB,J2,0) ,"^",5)
  44039   "RTN","CHT FLIB2",122 ,0)
  44040    ..S CHTAL L=$P(^CHMP AY(CHPTR,C HSUB,J2,0) ,"^",4)
  44041   "RTN","CHT FLIB2",123 ,0)
  44042    ..S CHDME PL=$P(^CHM PAY(CHPTR, CHSUB,J2,0 ),"^",3)
  44043   "RTN","CHT FLIB2",124 ,0)
  44044    ..S:CHDME PL="" CHDM EPL="N"
  44045   "RTN","CHT FLIB2",125 ,0)
  44046    ..S (CHMD 1,CHMD2,CH MD3,CHMD4) =""
  44047   "RTN","CHT FLIB2",126 ,0)
  44048    ..S CHMD1 =$P(^CHMPA Y(CHPTR,CH SUB,J2,0), "^",13),CH MD2=$P(^CH MPAY(CHPTR ,CHSUB,J2, 0),"^",14) ,CHMD3=$P( ^CHMPAY(CH PTR,CHSUB, J2,0),"^", 15),CHMD4= $P(^CHMPAY (CHPTR,CHS UB,J2,0)," ^",16)
  44049   "RTN","CHT FLIB2",127 ,0)
  44050    .S (CHMOD ,CHMOD2,CH MOD3,CHMOD 4)="00"
  44051   "RTN","CHT FLIB2",128 ,0)
  44052    .I CHMD1' ="" I $D(^ CHMDIC(741 002.37,CHM D1,0)) S C HMOD=$P(^C HMDIC(7410 02.37,CHMD 1,0),U,1)
  44053   "RTN","CHT FLIB2",129 ,0)
  44054    .I CHMD2' ="" I $D(^ CHMDIC(741 002.37,CHM D2,0)) S C HMOD2=$P(^ CHMDIC(741 002.37,CHM D2,0),U,1)
  44055   "RTN","CHT FLIB2",130 ,0)
  44056    .I CHMD3' ="" I $D(^ CHMDIC(741 002.37,CHM D3,0)) S C HMOD3=$P(^ CHMDIC(741 002.37,CHM D3,0),U,1)
  44057   "RTN","CHT FLIB2",131 ,0)
  44058    .I CHMD4' ="" I $D(^ CHMDIC(741 002.37,CHM D4,0)) S C HMOD4=$P(^ CHMDIC(741 002.37,CHM D4,0),U,1)
  44059   "RTN","CHT FLIB2",132 ,0)
  44060    .S CHMD=C HMOD_CHMOD 2_CHMOD3_C HMOD4
  44061   "RTN","CHT FLIB2",133 ,0)
  44062    .S PQTY=1
  44063   "RTN","CHT FLIB2",134 ,0)
  44064    .I ADJAMT ="NA" S AD JAMT2=""
  44065   "RTN","CHT FLIB2",135 ,0)
  44066    .I ADJAMT '="NA" S A DJAMT2=ADJ AMT
  44067   "RTN","CHT FLIB2",136 ,0)
  44068    .I SPLTAD J=0 D
  44069   "RTN","CHT FLIB2",137 ,0)
  44070    ..I $D(^T EMP($J,"AD JAMT",CHPT R,CHSUB,CH PRC,PLID,C HMD,CHTST, CHDMEPL,CH RES,ADJAMT )) D
  44071   "RTN","CHT FLIB2",138 ,0)
  44072    ...S ^TEM P($J,"ADJA MT",CHPTR, CHSUB,CHPR C,PLID,CHM D,CHTST,CH DMEPL,CHRE S,ADJAMT)= ^TEMP($J," ADJAMT",CH PTR,CHSUB, CHPRC,PLID ,CHMD,CHTS T,CHDMEPL, CHRES,ADJA MT)+1
  44073   "RTN","CHT FLIB2",139 ,0)
  44074    ..E  S ^T EMP($J,"AD JAMT",CHPT R,CHSUB,CH PRC,PLID,C HMD,CHTST, CHDMEPL,CH RES,ADJAMT )=1
  44075   "RTN","CHT FLIB2",140 ,0)
  44076    ..S ADJAM T="A"
  44077   "RTN","CHT FLIB2",141 ,0)
  44078    .I $D(^TE MP($J,"CDE RU2",CHPTR ,CHSUB,CHP RC,PLID,CH MD,CHTST,C HDMEPL,CHR ES,ADJAMT) ) D
  44079   "RTN","CHT FLIB2",142 ,0)
  44080    ..S PQTY= $P(^TEMP($ J,"CDERU2" ,CHPTR,CHS UB,CHPRC,P LID,CHMD,C HTST,CHDME PL,CHRES,A DJAMT),"^" ,1)+1
  44081   "RTN","CHT FLIB2",143 ,0)
  44082    ..I ADJAM T2'="" S A DJAMT2=$P( ^TEMP($J," CDERU2",CH PTR,CHSUB, CHPRC,PLID ,CHMD,CHTS T,CHDMEPL, CHRES,ADJA MT),"^",20 )+ADJAMT2
  44083   "RTN","CHT FLIB2",144 ,0)
  44084    ..I CHCHG '="" S $P( ^TEMP($J," CDERU2",CH PTR,CHSUB, CHPRC,PLID ,CHMD,CHTS T,CHDMEPL, CHRES,ADJA MT),"^",18 )=$P(^TEMP ($J,"CDERU 2",CHPTR,C HSUB,CHPRC ,PLID,CHMD ,CHTST,CHD MEPL,CHRES ,ADJAMT)," ^",18)+CHC HG
  44085   "RTN","CHT FLIB2",145 ,0)
  44086    ..I CHTAL L'="" S $P (^TEMP($J, "CDERU2",C HPTR,CHSUB ,CHPRC,PLI D,CHMD,CHT ST,CHDMEPL ,CHRES,ADJ AMT),"^",2 )=$P(^TEMP ($J,"CDERU 2",CHPTR,C HSUB,CHPRC ,PLID,CHMD ,CHTST,CHD MEPL,CHRES ,ADJAMT)," ^",2)+CHTA LL
  44087   "RTN","CHT FLIB2",146 ,0)
  44088    ..S $P(^T EMP($J,"CD ERU2",CHPT R,CHSUB,CH PRC,PLID,C HMD,CHTST, CHDMEPL,CH RES,ADJAMT ),"^",1)=P QTY
  44089   "RTN","CHT FLIB2",147 ,0)
  44090    ..S $P(^T EMP($J,"CD ERU2",CHPT R,CHSUB,CH PRC,PLID,C HMD,CHTST, CHDMEPL,CH RES,ADJAMT ),"^",19)= J2
  44091   "RTN","CHT FLIB2",148 ,0)
  44092    ..S:ADJAM T2'="" $P( ^TEMP($J," CDERU2",CH PTR,CHSUB, CHPRC,PLID ,CHMD,CHTS T,CHDMEPL, CHRES,ADJA MT),"^",20 )=ADJAMT2
  44093   "RTN","CHT FLIB2",149 ,0)
  44094    .E  S ^TE MP($J,"CDE RU2",CHPTR ,CHSUB,CHP RC,PLID,CH MD,CHTST,C HDMEPL,CHR ES,ADJAMT) =PQTY_"^"_ CHTALL_"^^ ^^^^^^^^^^ ^^^^"_CHCH G_"^"_J2_" ^"_ADJAMT2  ;_"^"_CHT ALL
  44095   "RTN","CHT FLIB2",150 ,0)
  44096    .Q:'$D(^C HMPAY(CHPT R,CHSUB,J2 ,1,1,0))
  44097   "RTN","CHT FLIB2",151 ,0)
  44098    .F AB=3:1 :8 I $P(^C HMPAY(CHPT R,CHSUB,J2 ,1,1,0),"^ ",(AB-2))' ="" S $P(^ TEMP($J,"C DERU2",CHP TR,CHSUB,C HPRC,PLID, CHMD,CHTST ,CHDMEPL,C HRES,ADJAM T),"^",AB) =$P(^TEMP( $J,"CDERU2 ",CHPTR,CH SUB,CHPRC, PLID,CHMD, CHTST,CHDM EPL,CHRES, ADJAMT),"^ ",AB)+$P(^ CHMPAY(CHP TR,CHSUB,J 2,1,1,0)," ^",(AB-2))
  44099   "RTN","CHT FLIB2",152 ,0)
  44100    .F AB=10: 1:18 I $P( ^CHMPAY(CH PTR,CHSUB, J2,1,1,0), "^",(AB-2) )'="" S $P (^TEMP($J, "CDERU2",C HPTR,CHSUB ,CHPRC,PLI D,CHMD,CHT ST,CHDMEPL ,CHRES,ADJ AMT),"^",A B)=$P(^TEM P($J,"CDER U2",CHPTR, CHSUB,CHPR C,PLID,CHM D,CHTST,CH DMEPL,CHRE S,ADJAMT), "^",AB)+$P (^CHMPAY(C HPTR,CHSUB ,J2,1,1,0) ,"^",(AB-2 ))
  44101   "RTN","CHT FLIB2",153 ,0)
  44102    .S AB=9 I  $P(^CHMPA Y(CHPTR,CH SUB,J2,1,1 ,0),"^",(A B-2))'=""  S $P(^TEMP ($J,"CDERU 2",CHPTR,C HSUB,CHPRC ,PLID,CHMD ,CHTST,CHD MEPL,CHRES ,ADJAMT)," ^",AB)=$P( ^CHMPAY(CH PTR,CHSUB, J2,1,1,0), "^",(AB-2) )
  44103   "RTN","CHT FLIB2",154 ,0)
  44104    .S RTN=1
  44105   "RTN","CHT FLIB2",155 ,0)
  44106    Q RTN
  44107   "RTN","CHT FLIB2",156 ,0)
  44108   PRVSPMT(CH PTR) ;PREV IOUS PAYME NT
  44109   "RTN","CHT FLIB2",157 ,0)
  44110    ;INPUT:   CHPTR - PO INTER TO I  VALUE IN  ^CHMPAY
  44111   "RTN","CHT FLIB2",158 ,0)
  44112    ;OUTPUT:   RNT - CHP RVSPMT^CHD EB^CHCSTSH R^CHVENPMT ^CHBENPMT^ CHDOS
  44113   "RTN","CHT FLIB2",159 ,0)
  44114    ;                    CHPRVSPMT  - AMOUNT P REVIOUS PA ID
  44115   "RTN","CHT FLIB2",160 ,0)
  44116    ;                    CHDEB - PR EVIOUS AMO UNT APPLIE D TO DEDUC TIBLE
  44117   "RTN","CHT FLIB2",161 ,0)
  44118    ;                    CHCSTSHR -  PREVIOUS  COST SHARE  AMOUNT
  44119   "RTN","CHT FLIB2",162 ,0)
  44120    ;                                 CHVENPMT  - AMOUNT  PAID TO VE NDOR
  44121   "RTN","CHT FLIB2",163 ,0)
  44122    ;                                 CHBENPMT  - AMOUNT  PAID TO BE NE
  44123   "RTN","CHT FLIB2",164 ,0)
  44124    ;                    YR - DATE  OF SERVICE  OR DISCHA RGE DATE F OR INPATIE NT
  44125   "RTN","CHT FLIB2",165 ,0)
  44126    N CHPRVSP MT,CHDEB,C HCSTSHR,RN T,CHTOS,CH TPRC,CHDOS ,YR,CHVENP MT,CHBENPM T
  44127   "RTN","CHT FLIB2",166 ,0)
  44128    S (CHTPRC ,YR,CHSLA) =""
  44129   "RTN","CHT FLIB2",167 ,0)
  44130    K ^TMP($J ,"PRVSPMT" )
  44131   "RTN","CHT FLIB2",168 ,0)
  44132    I $D(^CHM PAY(CHPTR, 6)) D
  44133   "RTN","CHT FLIB2",169 ,0)
  44134    .F  S CHF IDX=$P($G( ^CHMPAY(CH PTR,6)),"^ ",2)  Q:(C HFIDX="")! (CHSLA=1)   D ;CHFIDX -FROM CLAI M POINTER  MTN013163:  BUG IP104  EW 3/12/1 3;BDB 11/1 3/2017 $G  ADDED
  44135   "RTN","CHT FLIB2",170 ,0)
  44136    ..S (CHPR VSPMT,CHDE B,CHCSTSHR ,CHBENPMT, CHVENPMT)= ""
  44137   "RTN","CHT FLIB2",171 ,0)
  44138    ..S CHDOS =9999999-$ P(^CHMPAY( CHFIDX,0), "^",8)  ;D OS NON INP ATIENT
  44139   "RTN","CHT FLIB2",172 ,0)
  44140    ..I $P(^C HMPAY(CHFI DX,0),"^", 7)=1 S CHD OS=9999999 -$P(^CHMPA Y(CHFIDX," INP"),"^", 1)  ;DISCH ARGE DATE  INPATIENT
  44141   "RTN","CHT FLIB2",173 ,0)
  44142    ..S YR=$E (CHDOS,1,3 )_"9999"
  44143   "RTN","CHT FLIB2",174 ,0)
  44144    ..I $D(^C HMPAY(CHFI DX,1)) D
  44145   "RTN","CHT FLIB2",175 ,0)
  44146    ...S CHSL A=$$DSLA(C HFIDX)
  44147   "RTN","CHT FLIB2",176 ,0)
  44148    ...I (CHS LA=1)&($P( ^CHMPAY(CH FIDX,0),"^ ",2)'=0) D     ;SLA   MTN013163:  BUG BC132  EW 3/26/1 3
  44149   "RTN","CHT FLIB2",177 ,0)
  44150    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",1)>0 S C HPRVSPMT=$ P(^CHMPAY( CHFIDX,1), "^",1)+$P( ^CHMPAY(CH FIDX,1),"^ ",30)+$P(^ CHMPAY(CHF IDX,1),"^" ,31) ;MTN0 13163: BUG  IP104 EW  3/12/13
  44151   "RTN","CHT FLIB2",178 ,0)
  44152    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",1)<=0 S  CHPRVSPMT= $P(^CHMPAY (CHFIDX,1) ,"^",30)+$ P(^CHMPAY( CHFIDX,1), "^",31) ;M TN013163:  BUG IP104  EW 3/12/13
  44153   "RTN","CHT FLIB2",179 ,0)
  44154    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",5)>0 S C HDEB=$P(^C HMPAY(CHFI DX,1),"^", 5)
  44155   "RTN","CHT FLIB2",180 ,0)
  44156    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",6)>0 S C HCSTSHR=$P (^CHMPAY(C HFIDX,1)," ^",6)
  44157   "RTN","CHT FLIB2",181 ,0)
  44158    ....S CHV ENPMT=$P(^ CHMPAY(CHF IDX,1),"^" ,14)+$P(^C HMPAY(CHFI DX,1),"^", 30) ;MTN01 3163: BUG  IP104 EW 3 /12/13
  44159   "RTN","CHT FLIB2",182 ,0)
  44160    ....S CHB ENPMT=$P(^ CHMPAY(CHF IDX,1),"^" ,15)+$P(^C HMPAY(CHFI DX,1),"^", 31) ;MTN01 3163: BUG  IP104 EW 3 /12/13
  44161   "RTN","CHT FLIB2",183 ,0)
  44162    ....I $D( ^TMP($J,"P RVSPMT",YR )) D
  44163   "RTN","CHT FLIB2",184 ,0)
  44164    .....S:CH PRVSPMT'=" " $P(^TMP( $J,"PRVSPM T",YR),"^" ,1)=$P(^TM P($J,"PRVS PMT",YR)," ^",1)+CHPR VSPMT
  44165   "RTN","CHT FLIB2",185 ,0)
  44166    .....S:CH DEB'="" $P (^TMP($J," PRVSPMT",Y R),"^",2)= $P(^TMP($J ,"PRVSPMT" ,YR),"^",2 )+CHDEB
  44167   "RTN","CHT FLIB2",186 ,0)
  44168    .....S:CH CSTSHR'=""  $P(^TMP($ J,"PRVSPMT ",YR),"^", 3)=$P(^TMP ($J,"PRVSP MT",YR),"^ ",3)+CHCST SHR
  44169   "RTN","CHT FLIB2",187 ,0)
  44170    .....S:CH VENPMT'=""  $P(^TMP($ J,"PRVSPMT ",YR),"^", 4)=$P(^TMP ($J,"PRVSP MT",YR),"^ ",4)+CHVEN PMT
  44171   "RTN","CHT FLIB2",188 ,0)
  44172    .....S:CH BENPMT'=""  $P(^TMP($ J,"PRVSPMT ",YR),"^", 5)=$P(^TMP ($J,"PRVSP MT",YR),"^ ",5)+CHBEN PMT
  44173   "RTN","CHT FLIB2",189 ,0)
  44174    ....E  S  ^TMP($J,"P RVSPMT",YR )=CHPRVSPM T_"^"_CHDE B_"^"_CHCS TSHR_"^"_C HVENPMT_"^ "_CHBENPMT _"^"_CHDOS
  44175   "RTN","CHT FLIB2",190 ,0)
  44176    ...E  I ( CHSLA=1)&( $D(^TMP($J ,"PRVSPMT" ,YR))=0) S  ^TMP($J," PRVSPMT",Y R)=CHPRVSP MT_"^"_CHD EB_"^"_CHC STSHR_"^"_ CHVENPMT_" ^"_CHBENPM T_"^"_CHDO S ;MTN0131 63: ISSUE  #36 EW 8/2 8/13
  44177   "RTN","CHT FLIB2",191 ,0)
  44178    ...I (CHS LA=0)&($P( ^CHMPAY(CH FIDX,0),"^ ",2)'=0) D  ;NO SLA    MTN013163 : BUG BC13 2 EW 3/26/ 13
  44179   "RTN","CHT FLIB2",192 ,0)
  44180    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",1)>0 S C HPRVSPMT=$ P(^CHMPAY( CHFIDX,1), "^",1)
  44181   "RTN","CHT FLIB2",193 ,0)
  44182    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",5)>0 S C HDEB=$P(^C HMPAY(CHFI DX,1),"^", 5)
  44183   "RTN","CHT FLIB2",194 ,0)
  44184    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",6)>0 S C HCSTSHR=$P (^CHMPAY(C HFIDX,1)," ^",6)
  44185   "RTN","CHT FLIB2",195 ,0)
  44186    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",14)>0 S  CHVENPMT=$ P(^CHMPAY( CHFIDX,1), "^",14)
  44187   "RTN","CHT FLIB2",196 ,0)
  44188    ....I $P( ^CHMPAY(CH FIDX,1),"^ ",15)>0 S  CHBENPMT=$ P(^CHMPAY( CHFIDX,1), "^",15)
  44189   "RTN","CHT FLIB2",197 ,0)
  44190    ....I $D( ^TMP($J,"P RVSPMT",YR )) D
  44191   "RTN","CHT FLIB2",198 ,0)
  44192    .....S:CH PRVSPMT'=" " $P(^TMP( $J,"PRVSPM T",YR),"^" ,1)=$P(^TM P($J,"PRVS PMT",YR)," ^",1)+CHPR VSPMT
  44193   "RTN","CHT FLIB2",199 ,0)
  44194    .....S:CH DEB'="" $P (^TMP($J," PRVSPMT",Y R),"^",2)= $P(^TMP($J ,"PRVSPMT" ,YR),"^",2 )+CHDEB
  44195   "RTN","CHT FLIB2",200 ,0)
  44196    .....S:CH CSTSHR'=""  $P(^TMP($ J,"PRVSPMT ",YR),"^", 3)=$P(^TMP ($J,"PRVSP MT",YR),"^ ",3)+CHCST SHR
  44197   "RTN","CHT FLIB2",201 ,0)
  44198    .....S:CH VENPMT'=""  $P(^TMP($ J,"PRVSPMT ",YR),"^", 4)=$P(^TMP ($J,"PRVSP MT",YR),"^ ",4)+CHVEN PMT
  44199   "RTN","CHT FLIB2",202 ,0)
  44200    .....S:CH BENPMT'=""  $P(^TMP($ J,"PRVSPMT ",YR),"^", 5)=$P(^TMP ($J,"PRVSP MT",YR),"^ ",5)+CHBEN PMT
  44201   "RTN","CHT FLIB2",203 ,0)
  44202    ....E  S  ^TMP($J,"P RVSPMT",YR )=CHPRVSPM T_"^"_CHDE B_"^"_CHCS TSHR_"^"_C HVENPMT_"^ "_CHBENPMT _"^"_CHDOS
  44203   "RTN","CHT FLIB2",204 ,0)
  44204    ...E  I ( CHSLA=0)&( $D(^TMP($J ,"PRVSPMT" ,YR))=0) S  ^TMP($J," PRVSPMT",Y R)=CHPRVSP MT_"^"_CHD EB_"^"_CHC STSHR_"^"_ CHVENPMT_" ^"_CHBENPM T_"^"_CHDO S ;MTN0131 63: ISSUE  #36 EW 8/2 8/13
  44205   "RTN","CHT FLIB2",205 ,0)
  44206    ..;Q:CHSL A=1 DEV782 0 BUG IP23  EW 5/2/12
  44207   "RTN","CHT FLIB2",206 ,0)
  44208    ..S CHPTR =CHFIDX,CH SLA=""  ;A EB 11/6/20 13 DEV0190 68 ADDED C HSLA="" TO  THIS SET  COMMAND
  44209   "RTN","CHT FLIB2",207 ,0)
  44210    S RNT=1
  44211   "RTN","CHT FLIB2",208 ,0)
  44212    Q RNT
  44213   "RTN","CHT FLIB2",209 ,0)
  44214    ;-------- ---------- --------     DEV00782 0 EW 4/18/ 11 END  -- ---------- ---------- -----
  44215   "RTN","CHT FLIB2",210 ,0)
  44216    ;******** ********** ********** ********** ********** *******
  44217   "RTN","CHT FLIB2",211 ,0)
  44218    ;ADJA Fun ction: ITE RATE THROU GH ALL THE  TYPES OF  CLAIMS
  44219   "RTN","CHT FLIB2",212 ,0)
  44220    ;  OBTAIN  CLAIM TOT AL OF ALLO WED AMOUNT  + ADJUSTE D ALLOWABL E
  44221   "RTN","CHT FLIB2",213 ,0)
  44222    ;Input pa rameters:
  44223   "RTN","CHT FLIB2",214 ,0)
  44224    ;INCLM -  Ivalue fro m CHMPAY
  44225   "RTN","CHT FLIB2",215 ,0)
  44226    ;Return v alue:
  44227   "RTN","CHT FLIB2",216 ,0)
  44228    ; TAA - t otal allow ed amount  + adjusted  allowed a mounts
  44229   "RTN","CHT FLIB2",217 ,0)
  44230    ;******** ********** ********** ********** ********** *******
  44231   "RTN","CHT FLIB2",218 ,0)
  44232   ADJA(INCLM ) ; JAK DE V007820 ca lculate cl aim adjust ed allowab le amount  DEV007820
  44233   "RTN","CHT FLIB2",219 ,0)
  44234    S TAA=0   ;initializ e return v alue
  44235   "RTN","CHT FLIB2",220 ,0)
  44236    N AA,ADJA ,AAJ
  44237   "RTN","CHT FLIB2",221 ,0)
  44238    F TC="OPT -PROC","DE N-PROC","D ME-SUPPLY" ,"PHARM" D
  44239   "RTN","CHT FLIB2",222 ,0)
  44240     .S AAJ=0  F  S AAJ= $O(@(GLPAY _"INCLM,TC ,AAJ)")) Q :'AAJ  D
  44241   "RTN","CHT FLIB2",223 ,0)
  44242     ..Q:'$D( @(GLPAY_"I NCLM,TC,AA J)"))
  44243   "RTN","CHT FLIB2",224 ,0)
  44244     ..I TC=" OPT-PROC"  D  S AA=3, ADJA=5
  44245   "RTN","CHT FLIB2",225 ,0)
  44246     ..I TC=" DEN-PROC"  D  S AA=5, ADJA=7
  44247   "RTN","CHT FLIB2",226 ,0)
  44248     ..I TC=" DME-SUPPLY " D  S AA= 4,ADJA=5
  44249   "RTN","CHT FLIB2",227 ,0)
  44250     ..I TC=" PHARM" D   S AA=5,ADJ A=10
  44251   "RTN","CHT FLIB2",228 ,0)
  44252     ..I $P(@ (GLPAY_"IN CLM,TC,AAJ ,0)"),"^", ADJA)'=""& &('$$ISREJ ^CHTFLIB2( INCLM,TC,A AJ)) D   ; if adjust  allowed am ount exits  AND not r ejected
  44253   "RTN","CHT FLIB2",229 ,0)
  44254           .. .S TAA=TAA +$P(@(GLPA Y_"INCLM,T C,AAJ,0)") ,"^",ADJA)
  44255   "RTN","CHT FLIB2",230 ,0)
  44256     ..E  D   ;if only a llowed amo unt exits
  44257   "RTN","CHT FLIB2",231 ,0)
  44258           .. .I $P(@(GL PAY_"INCLM ,TC,AAJ,0) "),"^",AA) '="" D
  44259   "RTN","CHT FLIB2",232 ,0)
  44260                    .... S TAA=TAA+ $P(@(GLPAY _"INCLM,TC ,AAJ,0)"), "^",AA)
  44261   "RTN","CHT FLIB2",233 ,0)
  44262    Q TAA
  44263   "RTN","CHT FLIB2",234 ,0)
  44264    ;******** ********** ********** ********** ********** *******
  44265   "RTN","CHT FLIB2",235 ,0)
  44266    ;ABILL Fu nction: IT ERATE THRO UGH ALL TH E TYPES OF  CLAIMS
  44267   "RTN","CHT FLIB2",236 ,0)
  44268    ;  OBTAIN  CLAIM TOT AL OF BILL ED AMOUNT
  44269   "RTN","CHT FLIB2",237 ,0)
  44270    ;Input pa rameters:
  44271   "RTN","CHT FLIB2",238 ,0)
  44272    ;INCLM -  I value fr om CHMPAY
  44273   "RTN","CHT FLIB2",239 ,0)
  44274    ;Return v alue:
  44275   "RTN","CHT FLIB2",240 ,0)
  44276    ; TBILL -  total all owed amoun t + adjust ed allowed  amounts
  44277   "RTN","CHT FLIB2",241 ,0)
  44278    ;******** ********** ********** ********** ********** *******
  44279   "RTN","CHT FLIB2",242 ,0)
  44280   ABILL(INCL M) ; JAK D EV007820 c alculate c laim bille d amount D EV007820
  44281   "RTN","CHT FLIB2",243 ,0)
  44282    S TBILL=0   ;initial ize return  value
  44283   "RTN","CHT FLIB2",244 ,0)
  44284    N BILL,B
  44285   "RTN","CHT FLIB2",245 ,0)
  44286    F TC="OPT -PROC","DE N-PROC","D ME-SUPPLY" ,"PHARM" D
  44287   "RTN","CHT FLIB2",246 ,0)
  44288     .S B=0 F   S B=$O(@ (GLPAY_"IN CLM,TC,B)" )) Q:'B  D
  44289   "RTN","CHT FLIB2",247 ,0)
  44290           .. Q:'$D(@(GL PAY_"INCLM ,TC,B)"))
  44291   "RTN","CHT FLIB2",248 ,0)
  44292           .. I TC="PHAR M" D
  44293   "RTN","CHT FLIB2",249 ,0)
  44294                    ...S  BILL=4
  44295   "RTN","CHT FLIB2",250 ,0)
  44296           .. E  D
  44297   "RTN","CHT FLIB2",251 ,0)
  44298                    ...S  BILL=2
  44299   "RTN","CHT FLIB2",252 ,0)
  44300           .. I $P(@(GLP AY_"INCLM, TC,B,0)"), "^",BILL)' ="" D   ;i f billed a mount exis t at unit  level then  add it to  claim tot al
  44301   "RTN","CHT FLIB2",253 ,0)
  44302                    ...S  TBILL=TBI LL+$P(@(GL PAY_"INCLM ,TC,B,0)") ,"^",BILL)
  44303   "RTN","CHT FLIB2",254 ,0)
  44304    Q TBILL
  44305   "RTN","CHT FLIB2",255 ,0)
  44306    ;******** ********** ********** ********** ********** *******
  44307   "RTN","CHT FLIB2",256 ,0)
  44308    ;DSLA Fun ction: DET ERMINE IF  PRE OR POS T SLA (SER VICE LINE
  44309   "RTN","CHT FLIB2",257 ,0)
  44310    ;                ADJ UDICATION)
  44311   "RTN","CHT FLIB2",258 ,0)
  44312    ;Input pa rameters:
  44313   "RTN","CHT FLIB2",259 ,0)
  44314    ;INCLM -  I value fr om CHMPAY
  44315   "RTN","CHT FLIB2",260 ,0)
  44316    ;Return v alue:
  44317   "RTN","CHT FLIB2",261 ,0)
  44318    ; RET = 0  PRE SLA
  44319   "RTN","CHT FLIB2",262 ,0)
  44320    ;     = 1  POST SLA
  44321   "RTN","CHT FLIB2",263 ,0)
  44322    ;******** ********** ********** ********** ********** *******
  44323   "RTN","CHT FLIB2",264 ,0)
  44324   DSLA(INCLM ) N TC,T ;  JAK DEV00 7820 DETER MINE IF PR E OR POST  SLA
  44325   "RTN","CHT FLIB2",265 ,0)
  44326    S RTN=0
  44327   "RTN","CHT FLIB2",266 ,0)
  44328    F TC="OPT -PROC","DE N-PROC","D ME-SUPPLY" ,"PHARM" D              ; iterat e through  units to c lear for d istributio n from the  line
  44329   "RTN","CHT FLIB2",267 ,0)
  44330     .S T=0 F   S T=$O(@ (GLPAY_"IN CLM,TC,T)" ))  Q:'T!( RTN=1)  D
  44331   "RTN","CHT FLIB2",268 ,0)
  44332           .. I $D(@(GLP AY_"INCLM, TC,T,1,1,0 )")) S RTN =1
  44333   "RTN","CHT FLIB2",269 ,0)
  44334    Q RTN
  44335   "RTN","CHT FLIB2",270 ,0)
  44336    ;******** ********** ********** ********** ********** *******
  44337   "RTN","CHT FLIB2",271 ,0)
  44338    ;ISREJ Fu nction: DE TERMINE IF  UNIT LEVE L IS REJEC TED - MAIN LY
  44339   "RTN","CHT FLIB2",272 ,0)
  44340    ;                FOR  DISTRIBUT ION PURPOS ES DEV0078 20
  44341   "RTN","CHT FLIB2",273 ,0)
  44342    ;Input pa rameters:
  44343   "RTN","CHT FLIB2",274 ,0)
  44344    ;INCLM -  I value fr om CHMPAY
  44345   "RTN","CHT FLIB2",275 ,0)
  44346    ;PROC - T YPE OF PRO CEDURE (PH ARM,OPT-PR OC,etc.)
  44347   "RTN","CHT FLIB2",276 ,0)
  44348    ;JVAL  -  J value fr om CHMPAY  (unit leve l)
  44349   "RTN","CHT FLIB2",277 ,0)
  44350    ;Return v alue:
  44351   "RTN","CHT FLIB2",278 ,0)
  44352    ; ISREJ =  0 NOT REJ ECTED
  44353   "RTN","CHT FLIB2",279 ,0)
  44354    ;       =  1 REJECT
  44355   "RTN","CHT FLIB2",280 ,0)
  44356    ;DEV02539 3 - JAK -  02/24/16 r edesigned  functional ity
  44357   "RTN","CHT FLIB2",281 ,0)
  44358    ;to speed  processin g;it will  create tem p storage  of
  44359   "RTN","CHT FLIB2",282 ,0)
  44360    ;reject i nformation  for easy  retrival l ater;
  44361   "RTN","CHT FLIB2",283 ,0)
  44362    ;drastic  increase i n processi ng speeds  for claims  of >5k un its
  44363   "RTN","CHT FLIB2",284 ,0)
  44364    ;claims t hat would  take hours  are reduc ed to seco nds
  44365   "RTN","CHT FLIB2",285 ,0)
  44366    ;******** ********** ********** ********** ********** *******
  44367   "RTN","CHT FLIB2",286 ,0)
  44368   ISREJ(INCL M,PROC,JVA L)
  44369   "RTN","CHT FLIB2",287 ,0)
  44370    N TEMPVAR
  44371   "RTN","CHT FLIB2",288 ,0)
  44372    S ISREJ=0
  44373   "RTN","CHT FLIB2",289 ,0)
  44374    ; DETERMI NE IF RULE -PROC REJE CT
  44375   "RTN","CHT FLIB2",290 ,0)
  44376    S TEMPVAR ="RULE-PHA RM"
  44377   "RTN","CHT FLIB2",291 ,0)
  44378    I PROC'=" PHARM" S T EMPVAR="RU LE-PROC"
  44379   "RTN","CHT FLIB2",292 ,0)
  44380    D:'$D(^RE J($J,INCLM )) SREJA(I NCLM)
  44381   "RTN","CHT FLIB2",293 ,0)
  44382    S:$D(^REJ ($J,INCLM, TEMPVAR,JV AL)) ISREJ =1  ;AEB 4 -3-2108
  44383   "RTN","CHT FLIB2",294 ,0)
  44384    Q ISREJ
  44385   "RTN","CHT FLIB2",295 ,0)
  44386   SREJA(INCL M) //setup  reject ar ray
  44387   "RTN","CHT FLIB2",296 ,0)
  44388    N PROCCD, DUP,QA
  44389   "RTN","CHT FLIB2",297 ,0)
  44390    S ^REJ($J ,INCLM)=""  //ensures  that if n o errors a re found t hat it won 't iterate  through a ll units a gain
  44391   "RTN","CHT FLIB2",298 ,0)
  44392    I $D(@(GL PAY_"INCLM ,TEMPVAR)" )) D
  44393   "RTN","CHT FLIB2",299 ,0)
  44394     .S UNIT= 0 F  S UNI T=$O(@(GLP AY_"INCLM, TEMPVAR,UN IT)")) D   Q:UNIT=""! ('UNIT)
  44395   "RTN","CHT FLIB2",300 ,0)
  44396     ..Q:UNIT =""!('UNIT )
  44397   "RTN","CHT FLIB2",301 ,0)
  44398           .. I $D(@(GLP AY_"INCLM, TEMPVAR,UN IT,0)")) D
  44399   "RTN","CHT FLIB2",302 ,0)
  44400           .. .S PROCCD= $P(@(GLPAY _"INCLM,TE MPVAR,UNIT ,0)"),"^", 1)
  44401   "RTN","CHT FLIB2",303 ,0)
  44402           .. .S:(PROCCD =0!((PROCC D=3)!(PROC CD=4))) ^R EJ($J,INCL M,TEMPVAR, UNIT)=""   ;AEB 4-3-2 018
  44403   "RTN","CHT FLIB2",304 ,0)
  44404    I $D(@(GL PAY_"INCLM ,""RULE-DU P"")")) D
  44405   "RTN","CHT FLIB2",305 ,0)
  44406     .S DUP=0  F  S DUP= $O(@(GLPAY _"INCLM,"" RULE-DUP"" ,DUP)")) D   Q:DUP="" !('DUP)
  44407   "RTN","CHT FLIB2",306 ,0)
  44408           .. Q:DUP=""!( 'DUP)
  44409   "RTN","CHT FLIB2",307 ,0)
  44410           .. I $D(@(GLP AY_"INCLM, ""RULE-DUP "",DUP,0)" )) D
  44411   "RTN","CHT FLIB2",308 ,0)
  44412           .. .I $P(@(GL PAY_"INCLM ,""RULE-DU P"",DUP,0) "),"^",6)= 0 D //REJE CT
  44413   "RTN","CHT FLIB2",309 ,0)
  44414                    .... I $P(@(GLP AY_"INCLM, ""RULE-DUP "",DUP,0)" ),"^",1)'= 1 D //not  a diagnosi s code
  44415   "RTN","CHT FLIB2",310 ,0)
  44416                             .....S  ^REJ($J,I NCLM,"RULE -DUP",$P(@ (GLPAY_"IN CLM,""RULE -DUP"",DUP ,0)"),"^", 3))=""  ;A EB 4-3-201 8
  44417   "RTN","CHT FLIB2",311 ,0)
  44418    I $D(@(GL PAY_"INCLM ,""RULE-QA "")")) D
  44419   "RTN","CHT FLIB2",312 ,0)
  44420     .S QA=0  F  S QA=$O (@(GLPAY_" INCLM,""RU LE-QA"",QA )")) D  Q: QA=""!('QA )
  44421   "RTN","CHT FLIB2",313 ,0)
  44422           .. Q:QA=""!(( 'QA))
  44423   "RTN","CHT FLIB2",314 ,0)
  44424           .. I $D(@(GLP AY_"INCLM, ""RULE-QA" ",QA,0)"))  D
  44425   "RTN","CHT FLIB2",315 ,0)
  44426           .. .I ($P(@(G LPAY_"INCL M,""RULE-Q A"",QA,0)" ),"^",4)=0 !($P(@(GLP AY_"INCLM, ""RULE-QA" ",QA,0)"), "^",4)=4))  D //REJEC T
  44427   "RTN","CHT FLIB2",316 ,0)
  44428                    .... I $P(@(GLP AY_"INCLM, ""RULE-QA" ",QA,0)"), "^",1)'=1  //not a di agnosis co de
  44429   "RTN","CHT FLIB2",317 ,0)
  44430                             .....S  ^REJ($J,I NCLM,"RULE -QA",$P(@( GLPAY_"INC LM,""RULE- QA"",QA,0) "),"^",3)) =""  ;AEB  3-3-2018
  44431   "RTN","CHT FLIB2",318 ,0)
  44432    Q
  44433   "RTN","CHT FLIB2",319 ,0)
  44434    ;******** ********** ********** ********** ********** *******
  44435   "RTN","CHT FLIB2",320 ,0)
  44436    ;ACCUMU F unction: A CCUMULATE  ALL SERVIC E LEVEL LI NES TO
  44437   "RTN","CHT FLIB2",321 ,0)
  44438    ;       T HE CLAIM L EVEL FOR I NTERMEDIAT E UPDATES  PRIOR TO
  44439   "RTN","CHT FLIB2",322 ,0)
  44440    ;       B ENE CALC;  IF ALL UNI T AMOUNTS  HAVE BEEN  DELETED
  44441   "RTN","CHT FLIB2",323 ,0)
  44442    ;       C LAIM LEVEL  AMOUNT WI LL BE DELE TED
  44443   "RTN","CHT FLIB2",324 ,0)
  44444    ;Input pa rameters:
  44445   "RTN","CHT FLIB2",325 ,0)
  44446    ;INCLM -  I value fr om CHMPAY
  44447   "RTN","CHT FLIB2",326 ,0)
  44448    ;Return v alue:
  44449   "RTN","CHT FLIB2",327 ,0)
  44450    ; no retu rn value b ut will up date claim  level inf ormation
  44451   "RTN","CHT FLIB2",328 ,0)
  44452    ; @(GLPAY _"INCLM,1) ,@(GLPAY_" INCLM,7),@ (GLPAY_"CH CLM,""COMM ON"")
  44453   "RTN","CHT FLIB2",329 ,0)
  44454    ;******** ********** ********** ********** ********** *******
  44455   "RTN","CHT FLIB2",330 ,0)
  44456   ACCUMU(INC LM) ;ACCUM ULATE UNIT  LEVEL TO  CLAIM LEVE L JAK DEV0 07820
  44457   "RTN","CHT FLIB2",331 ,0)
  44458    N CHCAMT, P,K2,J2
  44459   "RTN","CHT FLIB2",332 ,0)
  44460    S U="^"
  44461   "RTN","CHT FLIB2",333 ,0)
  44462    F P=1:1:7 ,9:1:16 D                                                                            ;D GC 6/19/20 14 BUG0195 16 - BEGIN
  44463   "RTN","CHT FLIB2",334 ,0)
  44464     .S CHCAM T(P)=""
  44465   "RTN","CHT FLIB2",335 ,0)
  44466    F K2="OPT -PROC","PH ARM","DEN- PROC","DME -SUPPLY" D
  44467   "RTN","CHT FLIB2",336 ,0)
  44468     .S J2=0   F  S J2=$ O(@(GLPAY_ "INCLM,K2, J2)")) Q:' J2  D
  44469   "RTN","CHT FLIB2",337 ,0)
  44470      ..F P=1 :1:7,9:1:1 6 D
  44471   "RTN","CHT FLIB2",338 ,0)
  44472       ...I $ D(@(GLPAY_ "INCLM,K2, J2,1,1,0)" )) D
  44473   "RTN","CHT FLIB2",339 ,0)
  44474        ....I  $P(@(GLPA Y_"INCLM,K 2,J2,1,1,0 )"),"^",P) '="" D
  44475   "RTN","CHT FLIB2",340 ,0)
  44476         .... .I P=9 S $ P(@(GLPAY_ "INCLM,K2, J2,1,1,0)" ),"^",P)=" "  Q  ;DGC  6/19/2014  BUG019516  - END
  44477   "RTN","CHT FLIB2",341 ,0)
  44478           .. ...S CHCAM T(P)=CHCAM T(P)+$P(@( GLPAY_"INC LM,K2,J2,1 ,1,0)"),"^ ",P)
  44479   "RTN","CHT FLIB2",342 ,0)
  44480    I CHCAMT( 1)="" D                          ;primary o hi paid am t
  44481   "RTN","CHT FLIB2",343 ,0)
  44482    .S $P(@(G LPAY_"INCL M,1)"),U,7 )=""
  44483   "RTN","CHT FLIB2",344 ,0)
  44484    E  D
  44485   "RTN","CHT FLIB2",345 ,0)
  44486    .S $P(@(G LPAY_"INCL M,1)"),U,7 )=CHCAMT(1 )
  44487   "RTN","CHT FLIB2",346 ,0)
  44488    I CHCAMT( 2)="" D                          ;primary o hi pr (pat ient repon sibility)
  44489   "RTN","CHT FLIB2",347 ,0)
  44490    .S $P(@(G LPAY_"INCL M,1)"),U,2 9)=""
  44491   "RTN","CHT FLIB2",348 ,0)
  44492    E  D
  44493   "RTN","CHT FLIB2",349 ,0)
  44494    .S $P(@(G LPAY_"INCL M,1)"),U,2 9)=CHCAMT( 2)
  44495   "RTN","CHT FLIB2",350 ,0)
  44496    I CHCAMT( 3)="" D                          ;additiona l ohi amts
  44497   "RTN","CHT FLIB2",351 ,0)
  44498    .S $P(@(G LPAY_"INCL M,7)"),U,1 0)=""
  44499   "RTN","CHT FLIB2",352 ,0)
  44500    E  D
  44501   "RTN","CHT FLIB2",353 ,0)
  44502    .S $P(@(G LPAY_"INCL M,7)"),U,1 0)=CHCAMT( 3)
  44503   "RTN","CHT FLIB2",354 ,0)
  44504    I CHCAMT( 4)="" D                          ;ohi pr ba lance
  44505   "RTN","CHT FLIB2",355 ,0)
  44506    .S $P(@(G LPAY_"INCL M,7)"),U,1 1)=""
  44507   "RTN","CHT FLIB2",356 ,0)
  44508    E  D
  44509   "RTN","CHT FLIB2",357 ,0)
  44510    .S $P(@(G LPAY_"INCL M,7)"),U,1 1)=CHCAMT( 4)
  44511   "RTN","CHT FLIB2",358 ,0)
  44512    I CHCAMT( 5)="" D                          ;medicaid  paid amt
  44513   "RTN","CHT FLIB2",359 ,0)
  44514    .S $P(@(G LPAY_"INCL M,7)"),U,2 )=""
  44515   "RTN","CHT FLIB2",360 ,0)
  44516    E  D
  44517   "RTN","CHT FLIB2",361 ,0)
  44518    .S $P(@(G LPAY_"INCL M,7)"),U,2 )=CHCAMT(5 )
  44519   "RTN","CHT FLIB2",362 ,0)
  44520    I CHCAMT( 6)="" D                          ;tpl amt
  44521   "RTN","CHT FLIB2",363 ,0)
  44522    .S $P(@(G LPAY_"INCL M,7)"),U,9 )=""
  44523   "RTN","CHT FLIB2",364 ,0)
  44524    E  D
  44525   "RTN","CHT FLIB2",365 ,0)
  44526    .S $P(@(G LPAY_"INCL M,7)"),U,9 )=CHCAMT(6 )
  44527   "RTN","CHT FLIB2",366 ,0)
  44528    I CHCAMT( 7)="" D                          ;billed am ount
  44529   "RTN","CHT FLIB2",367 ,0)
  44530    .S $P(@(G LPAY_"INCL M,""COMMON "")"),U,1) =""
  44531   "RTN","CHT FLIB2",368 ,0)
  44532    E  D
  44533   "RTN","CHT FLIB2",369 ,0)
  44534    .S $P(@(G LPAY_"INCL M,""COMMON "")"),U,1) =CHCAMT(7)
  44535   "RTN","CHT FLIB2",370 ,0)
  44536    ;I CHCAMT (9)'="" S  $P(@(GLPAY _"INCLM,"" COMMON"")" ),U,7)=CHC AMT(9)  ;a llowed amo unt
  44537   "RTN","CHT FLIB2",371 ,0)
  44538    I CHCAMT( 10)="" D                         ;deductibl e amt
  44539   "RTN","CHT FLIB2",372 ,0)
  44540    .S $P(@(G LPAY_"INCL M,1)"),U,5 )=""
  44541   "RTN","CHT FLIB2",373 ,0)
  44542    E  D
  44543   "RTN","CHT FLIB2",374 ,0)
  44544    .S $P(@(G LPAY_"INCL M,1)"),U,5 )=CHCAMT(1 0)
  44545   "RTN","CHT FLIB2",375 ,0)
  44546    I CHCAMT( 11)="" D                         ;cost shar e amt
  44547   "RTN","CHT FLIB2",376 ,0)
  44548    .S $P(@(G LPAY_"INCL M,1)"),U,6 )=""
  44549   "RTN","CHT FLIB2",377 ,0)
  44550    E  D
  44551   "RTN","CHT FLIB2",378 ,0)
  44552    .S $P(@(G LPAY_"INCL M,1)"),U,6 )=CHCAMT(1 1)
  44553   "RTN","CHT FLIB2",379 ,0)
  44554    I CHCAMT( 12)="" D                         ;payment a mt (total  amount pai d)
  44555   "RTN","CHT FLIB2",380 ,0)
  44556    .S $P(@(G LPAY_"INCL M,1)"),U,1 )=""
  44557   "RTN","CHT FLIB2",381 ,0)
  44558    E  D
  44559   "RTN","CHT FLIB2",382 ,0)
  44560    .S $P(@(G LPAY_"INCL M,1)"),U,1 )=CHCAMT(1 2)
  44561   "RTN","CHT FLIB2",383 ,0)
  44562    I CHCAMT( 13)="" D                         ;patient p aid amt (b ene paid a mt)
  44563   "RTN","CHT FLIB2",384 ,0)
  44564    .S $P(@(G LPAY_"INCL M,""COMMON "")"),U,3) =""
  44565   "RTN","CHT FLIB2",385 ,0)
  44566    E  D
  44567   "RTN","CHT FLIB2",386 ,0)
  44568    .S $P(@(G LPAY_"INCL M,""COMMON "")"),U,3) =CHCAMT(13 )
  44569   "RTN","CHT FLIB2",387 ,0)
  44570    I CHCAMT( 14)="" D                         ;cat cap a mt
  44571   "RTN","CHT FLIB2",388 ,0)
  44572    .S $P(@(G LPAY_"INCL M,1)"),U,1 8)=""
  44573   "RTN","CHT FLIB2",389 ,0)
  44574    E  D
  44575   "RTN","CHT FLIB2",390 ,0)
  44576    .S $P(@(G LPAY_"INCL M,1)"),U,1 8)=CHCAMT( 14)
  44577   "RTN","CHT FLIB2",391 ,0)
  44578    I CHCAMT( 15)="" D                         ;amount pa id to bene
  44579   "RTN","CHT FLIB2",392 ,0)
  44580    .S $P(@(G LPAY_"INCL M,1)"),U,1 4)=""
  44581   "RTN","CHT FLIB2",393 ,0)
  44582    E  D
  44583   "RTN","CHT FLIB2",394 ,0)
  44584    .S $P(@(G LPAY_"INCL M,1)"),U,1 4)=CHCAMT( 15)
  44585   "RTN","CHT FLIB2",395 ,0)
  44586    I CHCAMT( 16)="" D ; amount pai d to vendo r
  44587   "RTN","CHT FLIB2",396 ,0)
  44588    .S $P(@(G LPAY_"INCL M,1)"),U,1 5)=""
  44589   "RTN","CHT FLIB2",397 ,0)
  44590    E  D
  44591   "RTN","CHT FLIB2",398 ,0)
  44592    .S $P(@(G LPAY_"INCL M,1)"),U,1 5)=CHCAMT( 16)
  44593   "RTN","CHT FLIB2",399 ,0)
  44594    Q
  44595   "RTN","CHT FLIB2",400 ,0)
  44596    ;******** ********** ********** ********** ********** *******
  44597   "RTN","CHT FLIB2",401 ,0)
  44598    ;LINEID F unction: C REAT LINEI DS FOR TRA NSITIONAL  CLAIMS
  44599   "RTN","CHT FLIB2",402 ,0)
  44600    ;   THAT  ARE IN PRO GRESS DURI NG IMPLEME NTATION OF  DEV007820
  44601   "RTN","CHT FLIB2",403 ,0)
  44602    ;   LINEI D IS UTILI ZED IN SLA  LOGIC SO  PRE-SLA CL AIMS NEED
  44603   "RTN","CHT FLIB2",404 ,0)
  44604    ;   TO BE  ASSIGNED  NEW LINEID  IN ORDER  TO FUNCTIO N PROPERLY
  44605   "RTN","CHT FLIB2",405 ,0)
  44606    ;   LINE  ID BASED U PON PROCED URE, MODS,  P/L,
  44607   "RTN","CHT FLIB2",406 ,0)
  44608    ;   BILLE D AMOUNT ( CHARGE/UNI T), AND TY PE OF CLAI M
  44609   "RTN","CHT FLIB2",407 ,0)
  44610    ;Input pa rameters:
  44611   "RTN","CHT FLIB2",408 ,0)
  44612    ;INCLM -  I value fr om CHMPAY
  44613   "RTN","CHT FLIB2",409 ,0)
  44614    ;Return v alue:
  44615   "RTN","CHT FLIB2",410 ,0)
  44616    ; no retu rn value u pdates $P( @(GLPAY_"I NCLM,LK2,J ,1,1,0)"), U,17)
  44617   "RTN","CHT FLIB2",411 ,0)
  44618    ; with ge nerated li ne id
  44619   "RTN","CHT FLIB2",412 ,0)
  44620    ;******** ********** ********** ********** ********** *******
  44621   "RTN","CHT FLIB2",413 ,0)
  44622   LINEID(INC LM) ;JAK D EV007820
  44623   "RTN","CHT FLIB2",414 ,0)
  44624    N CHMOD,C HMOD1,CHMO D2,CHMOD3, CHMOD3,CHM OD4,M1,M2, M3,M4,MOD, CHPL,CHGU, K2,J,NEXTI D,REC
  44625   "RTN","CHT FLIB2",415 ,0)
  44626    N CHCS,CH AA,CHOLIN, CHLINE,LK2 ,PT,UNIT
  44627   "RTN","CHT FLIB2",416 ,0)
  44628    S U="^"
  44629   "RTN","CHT FLIB2",417 ,0)
  44630    F K2="OPT -PROC","DE N-PROC","D ME-SUPPLY" ,"PHARM" D
  44631   "RTN","CHT FLIB2",418 ,0)
  44632     .S J=0 F   S J=$O(@ (GLPAY_"IN CLM,K2,J)" )) Q:'J  D
  44633   "RTN","CHT FLIB2",419 ,0)
  44634           .. I '$D(@(GL PAY_"INCLM ,K2,J,1,1, 0)"))!($P( $G(@(GLPAY _"INCLM,K2 ,J,1,1,0)" )),U,17)=" ") D
  44635   "RTN","CHT FLIB2",420 ,0)
  44636                    ...S  CHPL="",M OD="",CHMO D="",CHMOD 1="",CHMOD 2="",CHMOD 3="",CHMOD 4=""
  44637   "RTN","CHT FLIB2",421 ,0)
  44638           .. .S REC=(@( GLPAY_"INC LM,K2,J,0) "))
  44639   "RTN","CHT FLIB2",422 ,0)
  44640                    ...I  K2="OPT-P ROC" S M1= 4,M2=25,M3 =26,M4=27, PT=$P(REC, U,1),CHCS= $P(REC,U,2 ),CHAA=$P( REC,U,3)
  44641   "RTN","CHT FLIB2",423 ,0)
  44642                    ...I  K2="DEN-P ROC" S M1= 6,M2=22,M3 =23,M4=24, PT=$P(REC, U,1),CHCS= $P(REC,U,2 ),CHAA=$P( REC,U,5)
  44643   "RTN","CHT FLIB2",424 ,0)
  44644           .. .I K2="DME -SUPPLY" S  CHPL=$P(@ (GLPAY_"IN CLM,""DME- SUPPLY"",J ,0)"),"^", 3),M1=13,M 2=14,M3=15 ,M4=16,PT= $P(REC,U,1 ),CHCS=$P( REC,U,2),C HAA=$P(REC ,U,4)
  44645   "RTN","CHT FLIB2",425 ,0)
  44646                    ...I  K2="PHARM " D  S MOD ="M",PT=$P (REC,U,2), CHCS=$P(RE C,U,4),CHA A=$P(REC,U ,5)
  44647   "RTN","CHT FLIB2",426 ,0)
  44648           .. .E  D
  44649   "RTN","CHT FLIB2",427 ,0)
  44650                             ....S  CHMOD1=$P( @(GLPAY_"I NCLM,K2,J, 0)"),U,M1)  D:CHMOD1' =""
  44651   "RTN","CHT FLIB2",428 ,0)
  44652                                      .....Q:' $D(^CHMDIC (741002.37 ,CHMOD1))
  44653   "RTN","CHT FLIB2",429 ,0)
  44654                                      .....S C HMOD1=$P(^ CHMDIC(741 002.37,CHM OD1,0),U,1 )
  44655   "RTN","CHT FLIB2",430 ,0)
  44656                             ....S  CHMOD2=$P( @(GLPAY_"I NCLM,K2,J, 0)"),U,M2)  D:CHMOD2' =""
  44657   "RTN","CHT FLIB2",431 ,0)
  44658                                      .....Q:' $D(^CHMDIC (741002.37 ,CHMOD2))
  44659   "RTN","CHT FLIB2",432 ,0)
  44660                                      .....S C HMOD2=$P(^ CHMDIC(741 002.37,CHM OD2,0),U,1 )
  44661   "RTN","CHT FLIB2",433 ,0)
  44662                             ....S  CHMOD3=$P( @(GLPAY_"I NCLM,K2,J, 0)"),U,M3)  D:CHMOD3' =""
  44663   "RTN","CHT FLIB2",434 ,0)
  44664                                      .....Q:' $D(^CHMDIC (741002.37 ,CHMOD3))
  44665   "RTN","CHT FLIB2",435 ,0)
  44666                                      .....S C HMOD3=$P(^ CHMDIC(741 002.37,CHM OD3,0),U,1 )
  44667   "RTN","CHT FLIB2",436 ,0)
  44668                             ....S  CHMOD4=$P( @(GLPAY_"I NCLM,K2,J, 0)"),U,M4)  D:CHMOD4' =""
  44669   "RTN","CHT FLIB2",437 ,0)
  44670                                      .....Q:' $D(^CHMDIC (741002.37 ,CHMOD4))
  44671   "RTN","CHT FLIB2",438 ,0)
  44672                                      .....S C HMOD4=$P(^ CHMDIC(741 002.37,CHM OD4,0),U,1 )
  44673   "RTN","CHT FLIB2",439 ,0)
  44674                             ....S  CHMOD=$J(C HMOD1,2)_"  "_$J(CHMO D2,2)_" "_ $J(CHMOD3, 2)_" "_$J( CHMOD4,2)     ;modifi ers
  44675   "RTN","CHT FLIB2",440 ,0)
  44676                             ....S  MOD=CHPL_C HMOD
  44677   "RTN","CHT FLIB2",441 ,0)
  44678                    ...I  CHCS="" D
  44679   "RTN","CHT FLIB2",442 ,0)
  44680                             ....S  CHCS=0   ; if billed  amount doe s not exis t then ass ume 0 for  line creat ion
  44681   "RTN","CHT FLIB2",443 ,0)
  44682                    ...I  PT="" D
  44683   "RTN","CHT FLIB2",444 ,0)
  44684                             ....S  PT=CHCS  ; if procedu re does no t exist us e the char ge for ser vice inste ad
  44685   "RTN","CHT FLIB2",445 ,0)
  44686                    ...I  '$D(CHLIN E(PT,MOD,C HCS,K2)) D
  44687   "RTN","CHT FLIB2",446 ,0)
  44688                             ....S  CHLINE(PT, MOD,CHCS,K 2)=J  ; j  value of f irst unit  of one lin e
  44689   "RTN","CHT FLIB2",447 ,0)
  44690                    ...E   D
  44691   "RTN","CHT FLIB2",448 ,0)
  44692                             ....S  CHLINE(PT, MOD,CHCS,K 2)=CHLINE( PT,MOD,CHC S,K2)_U_J    ; concat enate rema ining j va lues of on e line
  44693   "RTN","CHT FLIB2",449 ,0)
  44694    S PT=0 F   S PT=$O(C HLINE(PT))  Q:'PT  D   ;reorder  to keep in  original  line order
  44695   "RTN","CHT FLIB2",450 ,0)
  44696     .S MOD=" " F  S MOD =$O(CHLINE (PT,MOD))  Q:MOD=""   D
  44697   "RTN","CHT FLIB2",451 ,0)
  44698           .. S CHGU=""  F  S CHGU= $O(CHLINE( PT,MOD,CHG U)) Q:CHGU =""  D
  44699   "RTN","CHT FLIB2",452 ,0)
  44700                    ...S  LK2="" F   S LK2=$O( CHLINE(PT, MOD,CHGU,L K2)) Q:LK2 =""  D
  44701   "RTN","CHT FLIB2",453 ,0)
  44702                             ....S  CHOLIN($P( CHLINE(PT, MOD,CHGU,L K2),"^",1) ,PT,MOD,CH GU,LK2)=CH LINE(PT,MO D,CHGU,LK2 )
  44703   "RTN","CHT FLIB2",454 ,0)
  44704    S J=0 F   S J=$O(CHO LIN(J)) Q: 'J  D       ; from th e ordered  lines crea te line id s
  44705   "RTN","CHT FLIB2",455 ,0)
  44706     .S PT=0  F  S PT=$O (CHOLIN(J, PT)) Q:'PT   D
  44707   "RTN","CHT FLIB2",456 ,0)
  44708           .. S MOD="" F   S MOD=$O (CHOLIN(J, PT,MOD)) Q :MOD=""  D
  44709   "RTN","CHT FLIB2",457 ,0)
  44710                    ...S  CHGU="" F   S CHGU=$ O(CHOLIN(J ,PT,MOD,CH GU)) Q:CHG U=""  D
  44711   "RTN","CHT FLIB2",458 ,0)
  44712                             ....S  LK2="" F   S LK2=$O(C HOLIN(J,PT ,MOD,CHGU, LK2)) Q:LK 2=""  D
  44713   "RTN","CHT FLIB2",459 ,0)
  44714                                      .....S N EXTID=$$PL ID^CHTFLIB (INCLM)     ;get the  next LINE  ID availab le
  44715   "RTN","CHT FLIB2",460 ,0)
  44716                                       .....F  T=1:1:$L(C HOLIN(J,PT ,MOD,CHGU, LK2),U) D     ;go thr ough all t he j value s to popul ate the ne xt LINE ID
  44717   "RTN","CHT FLIB2",461 ,0)
  44718                                                       .. ....S UNIT =$P(CHOLIN (J,PT,MOD, CHGU,LK2), U,T),$P(@( GLPAY_"INC LM,LK2,UNI T,1,1,0)") ,U,17)=NEX TID
  44719   "RTN","CHT FLIB2",462 ,0)
  44720    Q
  44721   "RTN","CHT FLIB2",463 ,0)
  44722    ;******** ********** ********** ********** ********** *******
  44723   "RTN","CHT FLIB2",464 ,0)
  44724    ;DELIV Fu nction: DE TERMINE IF  DELIVERY  CHARGES NE ED TO BE
  44725   "RTN","CHT FLIB2",465 ,0)
  44726    ;   REJEC TED, ONLY  DO SO IF A LL OTHER L INES HAVE  BEEN
  44727   "RTN","CHT FLIB2",466 ,0)
  44728    ;   REJEC TED.
  44729   "RTN","CHT FLIB2",467 ,0)
  44730    ;Input pa rameters:
  44731   "RTN","CHT FLIB2",468 ,0)
  44732    ; CI
  44733   "RTN","CHT FLIB2",469 ,0)
  44734    ;Return v alue:
  44735   "RTN","CHT FLIB2",470 ,0)
  44736    ; RFLG^IV AL
  44737   "RTN","CHT FLIB2",471 ,0)
  44738    ; RFLG -  "YES" THEN  DELIVERY  CHARGE SHO ULD BE REJ ECTED
  44739   "RTN","CHT FLIB2",472 ,0)
  44740    ;      -  "NO" THEN  DELIVERY C HARGE SHOU LD REMAIN  ACCEPTED
  44741   "RTN","CHT FLIB2",473 ,0)
  44742    ; IVAL -  THE UNIT I NDICATOR O F THE DELI VERY CHARG E
  44743   "RTN","CHT FLIB2",474 ,0)
  44744    ;******** ********** ********** ********** ********** *******
  44745   "RTN","CHT FLIB2",475 ,0)
  44746   DLVREJ(CI)   ;determi ne if deli very charg e needs to  be reject ed JAK DEV 007820
  44747   "RTN","CHT FLIB2",476 ,0)
  44748       N NM,P CODE,RFLG, IVAL
  44749   "RTN","CHT FLIB2",477 ,0)
  44750    S RFLG="Y ES",IVAL=" "
  44751   "RTN","CHT FLIB2",478 ,0)
  44752     S NM=0 F   S NM=$O( @(GLPAY_"C I,""DME-SU PPLY"",NM) ")) Q:'NM   D
  44753   "RTN","CHT FLIB2",479 ,0)
  44754           .I  '$$ISREJ^ CHTFLIB2(C I,"DME-SUP PLY",NM) D       ; ac cepted uni t JAK DEV0 07820
  44755   "RTN","CHT FLIB2",480 ,0)
  44756                    ..S  PCODE=$P(@ (GLPAY_"CI ,""DME-SUP PLY"",NM,0 )"),"^",1)  I PCODE=" " S IVAL=N M G DLV1   ;AEB 2/14/ 2013 DEV00 7820 ADDED  CHK ON PC ODE=""
  44757   "RTN","CHT FLIB2",481 ,0)
  44758                    ..I  $D(^CHMDIC (741052.1, "B",PCODE) ) S IVAL=N M   ;deliv ery charge  then get  unit indic ator JAK D EV007820
  44759   "RTN","CHT FLIB2",482 ,0)
  44760                    ..I  '$D(^CHMDI C(741052.1 ,"B",PCODE )) S RFLG= "NO" Q  ;n ot a deliv ery charge  then do n ot reject
  44761   "RTN","CHT FLIB2",483 ,0)
  44762    I IVAL=""  S RFLG="N O"  ;AEB 1 1/21/2012  DEV007820  ; IF EVERY  REJECTED  THEN SET F LAG TO NO
  44763   "RTN","CHT FLIB2",484 ,0)
  44764   DLV1 Q RFL G_"^"_IVAL
  44765   "RTN","CHT FLIB2",485 ,0)
  44766    ;******** ********** ********** ********** ********** *******
  44767   "RTN","CHT FLIB2",486 ,0)
  44768    ;MODCHK F unction: D ETERMINE I F A MODIFI ER EXISTS  ON A GIVEN  UNIT
  44769   "RTN","CHT FLIB2",487 ,0)
  44770    ;Input pa rameters:
  44771   "RTN","CHT FLIB2",488 ,0)
  44772    ;INCLM  -  claim poi nter in ^C HMPAY
  44773   "RTN","CHT FLIB2",489 ,0)
  44774    ;  MOD  -  TEXT or P OINTER val ue of the  modifier
  44775   "RTN","CHT FLIB2",490 ,0)
  44776    ;    I  -  the J val ue to indi cate which  unit to l ook at
  44777   "RTN","CHT FLIB2",491 ,0)
  44778    ; PORT  -  pointer o r text : d efaults to  TEXT if t ext is inp ut then
  44779   "RTN","CHT FLIB2",492 ,0)
  44780    ;          the point er value w ill be loo ked up
  44781   "RTN","CHT FLIB2",493 ,0)
  44782    ;Return v alue:
  44783   "RTN","CHT FLIB2",494 ,0)
  44784    ; CHMODB  - returns  1 if modif ier exists  on any mo difier pos ition
  44785   "RTN","CHT FLIB2",495 ,0)
  44786    ;         - returns  0 if modif ier is not  found at  any positi on
  44787   "RTN","CHT FLIB2",496 ,0)
  44788    ;******** ********** ********** ********** ********** *******
  44789   "RTN","CHT FLIB2",497 ,0)
  44790   MODCHK(INC LM,MOD,I,P ORT)
  44791   "RTN","CHT FLIB2",498 ,0)
  44792     N M1,M2, M3,M4,K2,C HMOD,CHMOD B
  44793   "RTN","CHT FLIB2",499 ,0)
  44794     S CHMODB =0  ;defau lts to mod ifier not  found
  44795   "RTN","CHT FLIB2",500 ,0)
  44796     I '$G(PO RT)'="" S  PORT="T" ; default to  text
  44797   "RTN","CHT FLIB2",501 ,0)
  44798     I PORT=" T" D
  44799   "RTN","CHT FLIB2",502 ,0)
  44800      .S CHMO D=0,CHMOD= $O(^CHMDIC (741002.37 ,"B",MOD,C HMOD))
  44801   "RTN","CHT FLIB2",503 ,0)
  44802     E  D
  44803   "RTN","CHT FLIB2",504 ,0)
  44804      .S CHMO D=MOD ;poi nter is al ready know n
  44805   "RTN","CHT FLIB2",505 ,0)
  44806     F K2="OP T-PROC","D EN-PROC"," DME-SUPPLY " D
  44807   "RTN","CHT FLIB2",506 ,0)
  44808      .Q:'$D( @(GLPAY_"I NCLM,K2,I, 0)"))              ;q uit if uni t does not  exist
  44809   "RTN","CHT FLIB2",507 ,0)
  44810      .Q:'$D( ^CHMDIC(74 1002.37,CH MOD))              ;q uit if mod ifier is n ot defined
  44811   "RTN","CHT FLIB2",508 ,0)
  44812      .I K2=" OPT-PROC"  S M1=4,M2= 25,M3=26,M 4=27    ;s et up modi fier posit ions
  44813   "RTN","CHT FLIB2",509 ,0)
  44814      .I K2=" DEN-PROC"  S M1=6,M2= 22,M3=23,M 4=24    ;s et up modi fier posit ions
  44815   "RTN","CHT FLIB2",510 ,0)
  44816      .I K2=" DME-SUPPLY " S M1=13, M2=14,M3=1 5,M4=16 ;s et up modi fier posit ions
  44817   "RTN","CHT FLIB2",511 ,0)
  44818      .I $P(@ (GLPAY_"IN CLM,K2,I,0 )"),"^",M1 )=CHMOD S  CHMODB=1 ; modifier f ound on 1s t modifier
  44819   "RTN","CHT FLIB2",512 ,0)
  44820      .I $P(@ (GLPAY_"IN CLM,K2,I,0 )"),"^",M2 )=CHMOD S  CHMODB=1 ; modifier f ound on 2n d modifier
  44821   "RTN","CHT FLIB2",513 ,0)
  44822      .I $P(@ (GLPAY_"IN CLM,K2,I,0 )"),"^",M3 )=CHMOD S  CHMODB=1 ; modifier f ound on 3r d modifier
  44823   "RTN","CHT FLIB2",514 ,0)
  44824      .I $P(@ (GLPAY_"IN CLM,K2,I,0 )"),"^",M4 )=CHMOD S  CHMODB=1 ; modifier f ound on 4t h modifier
  44825   "RTN","CHT FLIB2",515 ,0)
  44826     Q CHMODB
  44827   "RTN","CHT FLIB2",516 ,0)
  44828    ;******** ********** ********** ********** ********** *******
  44829   "RTN","CHT FLIB2",517 ,0)
  44830    ;CLRCCD F unction: C LEAR OUT C AT CAP AND  DEDUCTIBL ES FROM
  44831   "RTN","CHT FLIB2",518 ,0)
  44832    ;         CLAIM SO T HAT THEY R ECALC IN B ENE CALC
  44833   "RTN","CHT FLIB2",519 ,0)
  44834    ;Input pa rameters:
  44835   "RTN","CHT FLIB2",520 ,0)
  44836    ;INCLM -  I value fr om CHMPAY
  44837   "RTN","CHT FLIB2",521 ,0)
  44838    ;******** ********** ********** ********** ********** *******
  44839   "RTN","CHT FLIB2",522 ,0)
  44840   CLRCCD(INC LM) N P,TC ,T ; JAK D EV007820
  44841   "RTN","CHT FLIB2",523 ,0)
  44842    I $D(@(GL PAY_"INCLM ,1)")) D
  44843   "RTN","CHT FLIB2",524 ,0)
  44844     .F P=5,6 ,18:1:27 D
  44845   "RTN","CHT FLIB2",525 ,0)
  44846           .. S $P(@(GLP AY_"INCLM, 1)"),"^",P )=""
  44847   "RTN","CHT FLIB2",526 ,0)
  44848    Q:$P(@(GL PAY_"INCLM ,0)"),"^", 7)=1 ;QUIT  IF INPATI ENT
  44849   "RTN","CHT FLIB2",527 ,0)
  44850    F TC="OPT -PROC","DE N-PROC","D ME-SUPPLY" ,"PHARM" D     ; iter ate throug h units to  clear cat  cap, ded,  cost shar e
  44851   "RTN","CHT FLIB2",528 ,0)
  44852     .S T=0 F   S T=$O(@ (GLPAY_"IN CLM,TC,T)" ))  Q:'T   D
  44853   "RTN","CHT FLIB2",529 ,0)
  44854           .. I $D(@(GLP AY_"INCLM, TC,T,1,1,0 )")) D
  44855   "RTN","CHT FLIB2",530 ,0)
  44856                    ...F  P=10,11,1 4 D
  44857   "RTN","CHT FLIB2",531 ,0)
  44858                                      ....S $P (@(GLPAY_" INCLM,TC,T ,1,1,0)"), "^",P)=""
  44859   "RTN","CHT FLIB2",532 ,0)
  44860    Q
  44861   "RTN","CHT FLIB2",533 ,0)
  44862    ;******** ********** ********** ********** ********** *******
  44863   "RTN","CHT FLIB2",534 ,0)
  44864    ;CLRPMT F unction: C LEAR OUT P AYMENT INF ORMATION O F CLAIM
  44865   "RTN","CHT FLIB2",535 ,0)
  44866    ;       T YPICALLY U SED ON REJ ECTED CLAI MS SO PMT  INFO
  44867   "RTN","CHT FLIB2",536 ,0)
  44868    ;       N OT REPORTE D OR INCLU DED IN EDI  INFO BALA NCING
  44869   "RTN","CHT FLIB2",537 ,0)
  44870    ;Input pa rameters:
  44871   "RTN","CHT FLIB2",538 ,0)
  44872    ;INCLM -  I value fr om CHMPAY
  44873   "RTN","CHT FLIB2",539 ,0)
  44874    ;******** ********** ********** ********** ********** *******
  44875   "RTN","CHT FLIB2",540 ,0)
  44876   CLRPMT(INC LM) N P,TC ,T ; JAK D EV007820
  44877   "RTN","CHT FLIB2",541 ,0)
  44878    I $D(@(GL PAY_"INCLM ,1)")) D
  44879   "RTN","CHT FLIB2",542 ,0)
  44880     .F P=1,1 4,15 D
  44881   "RTN","CHT FLIB2",543 ,0)
  44882           .. S $P(@(GLP AY_"INCLM, 1)"),"^",P )=""
  44883   "RTN","CHT FLIB2",544 ,0)
  44884    Q:$P(@(GL PAY_"INCLM ,0)"),"^", 7)=1 ;QUIT  IF INPATI ENT
  44885   "RTN","CHT FLIB2",545 ,0)
  44886    F TC="OPT -PROC","DE N-PROC","D ME-SUPPLY" ,"PHARM" D     ; iter ate throug h units to  clear cat  cap, ded,  cost shar e
  44887   "RTN","CHT FLIB2",546 ,0)
  44888     .S T=0 F   S T=$O(@ (GLPAY_"IN CLM,TC,T)" ))  Q:'T   D
  44889   "RTN","CHT FLIB2",547 ,0)
  44890           .. I $D(@(GLP AY_"INCLM, TC,T,1,1,0 )")) D
  44891   "RTN","CHT FLIB2",548 ,0)
  44892                    ...F  P=12,15,1 6 D
  44893   "RTN","CHT FLIB2",549 ,0)
  44894                                      ....S $P (@(GLPAY_" INCLM,TC,T ,1,1,0)"), "^",P)=""
  44895   "RTN","CHT FLIB2",550 ,0)
  44896    Q
  44897   "RTN","CHT FLIB2",551 ,0)
  44898    ;
  44899   "RTN","CHT FLIB2",552 ,0)
  44900   ACAIRSRT(D FNBFN)
  44901   "RTN","CHT FLIB2",553 ,0)
  44902    ;Pass DFN , BFN info rmation.
  44903   "RTN","CHT FLIB2",554 ,0)
  44904    ;Returns  SPONSOR NA ME & SSN A ND BENE NA ME & BENE  SSN
  44905   "RTN","CHT FLIB2",555 ,0)
  44906    ;
  44907   "RTN","CHT FLIB2",556 ,0)
  44908    S U="^"
  44909   "RTN","CHT FLIB2",557 ,0)
  44910    S DFN=$P( DFNBFN,"-" ,1)
  44911   "RTN","CHT FLIB2",558 ,0)
  44912    S BFN=$P( DFNBFN,"-" ,2)
  44913   "RTN","CHT FLIB2",559 ,0)
  44914    I (DFN="" ) W !,"Mis sing DFN "  Q
  44915   "RTN","CHT FLIB2",560 ,0)
  44916    I (BFN="" ) W !,"MIS SING BFN "  Q
  44917   "RTN","CHT FLIB2",561 ,0)
  44918    I '$D(^AH CHVA(DFN))  W !,"NO S PONSOR FOU ND " Q
  44919   "RTN","CHT FLIB2",562 ,0)
  44920    S SPNAM=$ P(^AHCHVA( DFN,0),U,1 ),SPSSN=$P (^AHCHVA(D FN,0),U,9)
  44921   "RTN","CHT FLIB2",563 ,0)
  44922    ;
  44923   "RTN","CHT FLIB2",564 ,0)
  44924    I '$D(^AH CHVA(DFN,1 00,BFN)) W  !,"NO BEN E FOUND" Q
  44925   "RTN","CHT FLIB2",565 ,0)
  44926    S BNAM=$P (^AHCHVA(D FN,100,BFN ,0),U,1),B SSN=$P(^AH CHVA(DFN,1 00,BFN,0), U,9)
  44927   "RTN","CHT FLIB2",566 ,0)
  44928    ;
  44929   "RTN","CHT FLIB2",567 ,0)
  44930    Q DFN_U_B FN_U_SPNAM _U_SPSSN_U _BNAM_U_BS SN
  44931   "SEC","^DI C",741000, 741000,0," DD")
  44932   @
  44933   "SEC","^DI C",741000, 741000,0," DEL")
  44934   @
  44935   "SEC","^DI C",741000, 741000,0," LAYGO")
  44936   @
  44937   "SEC","^DI C",741000, 741000,0," RD")
  44938   Z
  44939   "SEC","^DI C",741000, 741000,0," WR")
  44940   @
  44941   "SEC","^DI C",741000. 2,741000.2 ,0,"DD")
  44942   @
  44943   "SEC","^DI C",741000. 2,741000.2 ,0,"DEL")
  44944   @
  44945   "SEC","^DI C",741000. 2,741000.2 ,0,"LAYGO" )
  44946   @
  44947   "SEC","^DI C",741000. 2,741000.2 ,0,"RD")
  44948   @
  44949   "SEC","^DI C",741000. 2,741000.2 ,0,"WR")
  44950   @
  44951   "SEC","^DI C",741002. 17,741002. 17,0,"DD")
  44952   @
  44953   "SEC","^DI C",741002. 17,741002. 17,0,"DEL" )
  44954   @
  44955   "SEC","^DI C",741002. 17,741002. 17,0,"LAYG O")
  44956   @
  44957   "SEC","^DI C",741002. 17,741002. 17,0,"RD")
  44958   Z
  44959   "SEC","^DI C",741002. 17,741002. 17,0,"WR")
  44960   @
  44961   "SEC","^DI C",741002. 22,741002. 22,0,"DD")
  44962   @
  44963   "SEC","^DI C",741002. 22,741002. 22,0,"DEL" )
  44964   @
  44965   "SEC","^DI C",741002. 22,741002. 22,0,"LAYG O")
  44966   Z
  44967   "SEC","^DI C",741002. 22,741002. 22,0,"RD")
  44968   Z
  44969   "SEC","^DI C",741002. 22,741002. 22,0,"WR")
  44970   Z
  44971   "SEC","^DI C",741215, 741215,0," AUDIT")
  44972   @
  44973   "SEC","^DI C",741215, 741215,0," DD")
  44974   @
  44975   "SEC","^DI C",741215, 741215,0," DEL")
  44976   @
  44977   "SEC","^DI C",741215, 741215,0," LAYGO")
  44978   @
  44979   "SEC","^DI C",741215, 741215,0," RD")
  44980   @
  44981   "SEC","^DI C",741215, 741215,0," WR")
  44982   @
  44983   "VER")
  44984   8.0^22.2
  44985   "^DD",7410 00,741000, 0)
  44986   FIELD^^158 ^303
  44987   "^DD",7410 00,741000, 0,"DDA")
  44988   N
  44989   "^DD",7410 00,741000, 0,"DT")
  44990   3180518
  44991   "^DD",7410 00,741000, 0,"IX","AD ",741000,. 03)
  44992  
  44993   "^DD",7410 00,741000, 0,"IX","AE ",741000,7 .01)
  44994  
  44995   "^DD",7410 00,741000, 0,"IX","B" ,741000,.0 1)
  44996  
  44997   "^DD",7410 00,741000, 0,"IX","C" ,741000.04 ,.01)
  44998  
  44999   "^DD",7410 00,741000, 0,"IX","D" ,741000,.2 1)
  45000  
  45001   "^DD",7410 00,741000, 0,"IX","E" ,741000,.1 )
  45002  
  45003   "^DD",7410 00,741000, 0,"IX","F" ,741000,80 0.105)
  45004  
  45005   "^DD",7410 00,741000, 0,"IX","M" ,741000,10 .23)
  45006  
  45007   "^DD",7410 00,741000, 0,"NM","CH AMPVA CLAI MS")
  45008  
  45009   "^DD",7410 00,741000, 0,"PT",741 000,6.01)
  45010  
  45011   "^DD",7410 00,741000, 0,"PT",741 000,6.02)
  45012  
  45013   "^DD",7410 00,741000, 0,"PT",741 000,9.08)
  45014  
  45015   "^DD",7410 00,741000, 0,"PT",741 000.21,.01 )
  45016  
  45017   "^DD",7410 00,741000, 0,"PT",741 000.4001,. 01)
  45018  
  45019   "^DD",7410 00,741000, 0,"PT",741 000.4201,. 01)
  45020  
  45021   "^DD",7410 00,741000, 0,"PT",741 000.9003,. 01)
  45022  
  45023   "^DD",7410 00,741000, 0,"PT",741 000.9009,. 01)
  45024  
  45025   "^DD",7410 00,741000, 0,"PT",741 002.03,.03 )
  45026  
  45027   "^DD",7410 00,741000, 0,"PT",741 002.0401,. 01)
  45028  
  45029   "^DD",7410 00,741000, 0,"PT",741 002.17,.37 )
  45030  
  45031   "^DD",7410 00,741000, 0,"PT",741 002.21701, .04)
  45032  
  45033   "^DD",7410 00,741000, 0,"PT",741 002.43,.02 )
  45034  
  45035   "^DD",7410 00,741000, 0,"PT",741 002.9006,. 02)
  45036  
  45037   "^DD",7410 00,741000, 0,"PT",741 008.0301,. 01)
  45038  
  45039   "^DD",7410 00,741000, 0,"PT",741 008.0501,. 01)
  45040  
  45041   "^DD",7410 00,741000, 0,"PT",741 008.1301,. 07)
  45042  
  45043   "^DD",7410 00,741000, 0,"PT",741 008.1801,. 01)
  45044  
  45045   "^DD",7410 00,741000, 0,"PT",741 008.2511,. 01)
  45046  
  45047   "^DD",7410 00,741000, 0,"PT",741 008.27,.02 )
  45048  
  45049   "^DD",7410 00,741000, 0,"PT",741 008.311,.0 1)
  45050  
  45051   "^DD",7410 00,741000, 0,"PT",741 008.6,.02)
  45052  
  45053   "^DD",7410 00,741000, 0,"PT",741 009.021,2. 01)
  45054  
  45055   "^DD",7410 00,741000, 0,"PT",741 010.01,.02 )
  45056  
  45057   "^DD",7410 00,741000, 0,"PT",741 010.06,.02 )
  45058  
  45059   "^DD",7410 00,741000, 0,"PT",741 010.1,.02)
  45060  
  45061   "^DD",7410 00,741000, 0,"PT",741 010.11,.02 )
  45062  
  45063   "^DD",7410 00,741000, 0,"PT",741 010.12,1)
  45064  
  45065   "^DD",7410 00,741000, 0,"PT",741 010.13,.02 )
  45066  
  45067   "^DD",7410 00,741000, 0,"PT",741 010.14,.02 )
  45068  
  45069   "^DD",7410 00,741000, 0,"PT",741 010.18,.03 )
  45070  
  45071   "^DD",7410 00,741000, 0,"PT",741 010.19,.02 )
  45072  
  45073   "^DD",7410 00,741000, 0,"PT",741 010.2,.05)
  45074  
  45075   "^DD",7410 00,741000, 0,"PT",741 010.22,.03 )
  45076  
  45077   "^DD",7410 00,741000, 0,"PT",741 010.31,.03 )
  45078  
  45079   "^DD",7410 00,741000, 0,"PT",741 010.9,.01)
  45080  
  45081   "^DD",7410 00,741000, 0,"PT",741 030.1111,. 01)
  45082  
  45083   "^DD",7410 00,741000, 0,"PT",741 050.01,.18 )
  45084  
  45085   "^DD",7410 00,741000, 0,"PT",741 050.02,.01 )
  45086  
  45087   "^DD",7410 00,741000, 0,"PT",741 050.03,.02 )
  45088  
  45089   "^DD",7410 00,741000, 0,"PT",741 070.02,.02 )
  45090  
  45091   "^DD",7410 00,741000, 0,"PT",741 111.06,.01 )
  45092  
  45093   "^DD",7410 00,741000, 0,"PT",741 205.01,.02 )
  45094  
  45095   "^DD",7410 00,741000, 0,"PT",741 207.011,.0 1)
  45096  
  45097   "^DD",7410 00,741000, 0,"PT",741 210.12,3.0 3)
  45098  
  45099   "^DD",7410 00,741000, 0,"PT",741 210.128,.0 1)
  45100  
  45101   "^DD",7410 00,741000, 0,"PT",741 210.14,80. 01)
  45102  
  45103   "^DD",7410 00,741000, 0,"PT",741 210.232,.0 4)
  45104  
  45105   "^DD",7410 00,741000, 0,"PT",741 210.232,.0 5)
  45106  
  45107   "^DD",7410 00,741000, 0,"PT",741 500.02,.01 )
  45108  
  45109   "^DD",7410 00,741000, 0,"PT",741 501.101,1. 01)
  45110  
  45111   "^DD",7410 00,741000, 0,"PT",741 700.01,.01 )
  45112  
  45113   "^DD",7410 00,741000, 0,"PT",741 3000.9009, .01)
  45114  
  45115   "^DD",7410 00,741000, 0,"VRPK")
  45116   CH
  45117   "^DD",7410 00,741000, .01,0)
  45118   CLAIM NUMB ER^RF^^0;1 ^K:X[""""! ($A(X)=45)  X I $D(X)  K:$L(X)>3 0!($L(X)<1 )!'(X'?1P. E) X
  45119   "^DD",7410 00,741000, .01,1,0)
  45120   ^.1
  45121   "^DD",7410 00,741000, .01,1,1,0)
  45122   741000^B
  45123   "^DD",7410 00,741000, .01,1,1,1)
  45124   S ^CHMPAY( "B",$E(X,1 ,30),DA)=" "
  45125   "^DD",7410 00,741000, .01,1,1,2)
  45126   K ^CHMPAY( "B",$E(X,1 ,30),DA)
  45127   "^DD",7410 00,741000, .01,1,1,"D T")
  45128   2930624
  45129   "^DD",7410 00,741000, .01,3)
  45130   Answer mus t be 1-30  characters  in length .
  45131   "^DD",7410 00,741000, .01,"DT")
  45132   2930624
  45133   "^DD",7410 00,741000, .02,0)
  45134   CLAIM STAT US^S^0:REJ ECTED;1:IN  PROCESS;2 :PAYMENT R EQUESTED;3 :EOB REQUE STED;4:COM PLETE;5:AD JUDICATED; 6:PAYMENT  REJECTED C APPS/CALM; 7:ADMIN SU SPENSE;8:P AYMENT APP ROVED CAPP S/CALM;9:M ANUALLY PR OCESSED;10 :DELETED;1 1:VOIDED;1 2:REVERSED ;^0;2^Q
  45135   "^DD",7410 00,741000, .02,3)
  45136  
  45137   "^DD",7410 00,741000, .02,"DT")
  45138   3170925
  45139   "^DD",7410 00,741000, .03,0)
  45140   VENDOR ID^ P741001'^C HMVEN(^0;3 ^Q
  45141   "^DD",7410 00,741000, .03,1,0)
  45142   ^.1
  45143   "^DD",7410 00,741000, .03,1,1,0)
  45144   741000^AD
  45145   "^DD",7410 00,741000, .03,1,1,1)
  45146   S ^CHMPAY( "AD",$E(X, 1,30),DA)= ""
  45147   "^DD",7410 00,741000, .03,1,1,2)
  45148   K ^CHMPAY( "AD",$E(X, 1,30),DA)
  45149   "^DD",7410 00,741000, .03,1,1,"D T")
  45150   2910408
  45151   "^DD",7410 00,741000, .03,"DT")
  45152   3150409
  45153   "^DD",7410 00,741000, .04,0)
  45154   VENDORIZAT ION POINTE R^F^^0;4^K :$L(X)>20! ($L(X)<1)  X
  45155   "^DD",7410 00,741000, .04,3)
  45156   Answer mus t be 1-20  characters  in length .
  45157   "^DD",7410 00,741000, .04,"DT")
  45158   2900914
  45159   "^DD",7410 00,741000, .05,0)
  45160   ASSIGNMENT  OF BENEFI TS^S^1:YES ;0:NO;^0;5 ^Q
  45161   "^DD",7410 00,741000, .06,0)
  45162   DATE OF AS SIGNMENT^D ^^0;6^S %D T="E" D ^% DT S X=Y K :Y<1 X
  45163   "^DD",7410 00,741000, .07,0)
  45164   TYPE OF CL AIM^P74100 2.05^CHMDI C(741002.0 5,^0;7^Q
  45165   "^DD",7410 00,741000, .07,3)
  45166  
  45167   "^DD",7410 00,741000, .07,"DT")
  45168   2970911
  45169   "^DD",7410 00,741000, .08,0)
  45170   DATE OF SE RVICE/STMT  FROM DATE ^RD^^0;8^S  %DT="EX"  D ^%DT S X =Y K:Y<1 X
  45171   "^DD",7410 00,741000, .08,1,0)
  45172   ^.1^^0
  45173   "^DD",7410 00,741000, .08,"DT")
  45174   3150409
  45175   "^DD",7410 00,741000, .09,0)
  45176   DATE INITI ALLY RECEI VED^D^^0;9 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  45177   "^DD",7410 00,741000, .09,"DT")
  45178   2921110
  45179   "^DD",7410 00,741000, .1,0)
  45180   DATE DETER MINED COMP LETE^D^^0; 10^S %DT=" EST" D ^%D T S X=Y K: Y<1 X
  45181   "^DD",7410 00,741000, .1,1,0)
  45182   ^.1^^-1
  45183   "^DD",7410 00,741000, .1,1,1,0)
  45184   741000^E
  45185   "^DD",7410 00,741000, .1,1,1,1)
  45186   S ^CHMPAY( "E",$E(X,1 ,30),DA)=" "
  45187   "^DD",7410 00,741000, .1,1,1,2)
  45188   K ^CHMPAY( "E",$E(X,1 ,30),DA)
  45189   "^DD",7410 00,741000, .1,1,1,"DT ")
  45190   3081008
  45191   "^DD",7410 00,741000, .1,"DT")
  45192   3081114
  45193   "^DD",7410 00,741000, .11,0)
  45194   CALM PROCE SSING STAT US^S^0:NO  BENE PORTI ON;1:PEND  PATCH PROC ESS;2:CALM  REQUEST S UBMITTED;3 :ACCEPT BY  CALM;4:RE JECT BY CA LM;5:EOB Q UE'D CALM  PORTION;6: CHK ISSUED /CALM PORT ION;99:BAD  DATA SENT  TO PS;98: BAD DATA-I N VENDOR;9 :NO CHK <  1.00;^0;11 ^Q
  45195   "^DD",7410 00,741000, .11,.1)
  45196  
  45197   "^DD",7410 00,741000, .11,3)
  45198  
  45199   "^DD",7410 00,741000, .11,"DT")
  45200   2950619
  45201   "^DD",7410 00,741000, .12,0)
  45202   CAPP PROCE SSING STAT US^S^0:NO  VENDOR POR TION;1:PEN D BATCH;2: SUB CAPP;3 :ACC CAPP/ PEND CALM; 4:REJ CAPP ;5:ACC CAL M;6:REJ CA LM;7:EOB Q UE'D CAPP; 8:CHK ISSU ED CAPP;99 :BAD DATA/ PS;98:BAD  DATA/VENDO R;9:NO CHK  < 1.00;^0 ;12^Q
  45203   "^DD",7410 00,741000, .12,3)
  45204  
  45205   "^DD",7410 00,741000, .12,"DT")
  45206   2950619
  45207   "^DD",7410 00,741000, .13,0)
  45208   REJECTION  REASON^P74 1002.22'^C HMDIC(7410 02.22,^0;1 3^Q
  45209   "^DD",7410 00,741000, .13,3)
  45210  
  45211   "^DD",7410 00,741000, .13,"DT")
  45212   2910529
  45213   "^DD",7410 00,741000, .14,0)
  45214   VENDOR DIS COUNT PERC ENT^NJ6,2^ ^0;14^K:+X '=X!(X>100 )!(X<0)!(X ?.E1"."3N. N) X
  45215   "^DD",7410 00,741000, .14,3)
  45216   Type a Num ber betwee n 0 and 10 0, 2 Decim al Digits
  45217   "^DD",7410 00,741000, .14,"DT")
  45218   2900826
  45219   "^DD",7410 00,741000, .15,0)
  45220   VENDOR DIS COUNT DAYS ^NJ3,0^^0; 15^K:+X'=X !(X>999)!( X<0)!(X?.E 1"."1N.N)  X
  45221   "^DD",7410 00,741000, .15,3)
  45222   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  45223   "^DD",7410 00,741000, .15,"DT")
  45224   2900826
  45225   "^DD",7410 00,741000, .16,0)
  45226   VENDOR DIS COUNT AMOU NT^NJ8,2^^ 0;16^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9)!(X<0) X
  45227   "^DD",7410 00,741000, .16,3)
  45228   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  45229   "^DD",7410 00,741000, .16,"DT")
  45230   2900826
  45231   "^DD",7410 00,741000, .17,0)
  45232   VENDOR DIS COUNT TERM S^S^X:BLAN K;P:PAYMEN T;E:ESTIMA TE;^0;17^Q
  45233   "^DD",7410 00,741000, .17,"DT")
  45234   2900826
  45235   "^DD",7410 00,741000, .18,0)
  45236   VENDORIZAT ION STRING ^F^^0;18^K :$L(X)>30! ($L(X)<1)  X
  45237   "^DD",7410 00,741000, .18,3)
  45238   Answer mus t be 1-30  characters  in length .
  45239   "^DD",7410 00,741000, .18,"DT")
  45240   2900914
  45241   "^DD",7410 00,741000, .19,0)
  45242   STATUS OF  MCCR ACTIO N^S^O:PEND ING RECOUP MENT;1:PAR TIAL RECOU PMENT;2:FU LL RECOUPM ENT;3:NO R ECOUPMENT; ^0;19^Q
  45243   "^DD",7410 00,741000, .19,"DT")
  45244   3170925
  45245   "^DD",7410 00,741000, .2,0)
  45246   LAST DUZ S ETTING MCC R STATUS^P 200'^VA(20 0,^0;20^Q
  45247   "^DD",7410 00,741000, .2,"DT")
  45248   2951010
  45249   "^DD",7410 00,741000, .21,0)
  45250   SPONSOR^P5 54801'^AHC HVA(^0;21^ Q
  45251   "^DD",7410 00,741000, .21,1,0)
  45252   ^.1
  45253   "^DD",7410 00,741000, .21,1,1,0)
  45254   741000^D
  45255   "^DD",7410 00,741000, .21,1,1,1)
  45256   S ^CHMPAY( "D",$E(X,1 ,30),DA)=" "
  45257   "^DD",7410 00,741000, .21,1,1,2)
  45258   K ^CHMPAY( "D",$E(X,1 ,30),DA)
  45259   "^DD",7410 00,741000, .21,1,1,"D T")
  45260   3070510
  45261   "^DD",7410 00,741000, .21,3)
  45262  
  45263   "^DD",7410 00,741000, .21,"DT")
  45264   3070510
  45265   "^DD",7410 00,741000, .22,0)
  45266   BFN^NJ2,0^ ^0;22^K:+X '=X!(X>99) !(X<0)!(X? .E1"."1N.N ) X
  45267   "^DD",7410 00,741000, .22,1,0)
  45268   ^.1^^0
  45269   "^DD",7410 00,741000, .22,3)
  45270   Type a Num ber betwee n 0 and 99 , 0 Decima l Digits
  45271   "^DD",7410 00,741000, .22,"DT")
  45272   3070510
  45273   "^DD",7410 00,741000, .23,0)
  45274   INVOICE NU MBER^F^^0; 23^K:$L(X) >16!($L(X) <1) X
  45275   "^DD",7410 00,741000, .23,3)
  45276   Answer mus t be 1-16  characters  in length .
  45277   "^DD",7410 00,741000, .23,"AUDIT ")
  45278  
  45279   "^DD",7410 00,741000, .23,"DT")
  45280   2910830
  45281   "^DD",7410 00,741000, .24,0)
  45282   INVOICE DA TE^D^^0;24 ^S %DT="E"  D ^%DT S  X=Y K:Y<1  X
  45283   "^DD",7410 00,741000, .24,"DT")
  45284   2901001
  45285   "^DD",7410 00,741000, .25,0)
  45286   CLAIM CREA TION DATE^ D^^0;25^S  %DT="EST"  D ^%DT S X =Y K:Y<1 X
  45287   "^DD",7410 00,741000, .25,"DT")
  45288   2920813
  45289   "^DD",7410 00,741000, .27,0)
  45290   TYPE OF PR OCESSING F LAG^P74100 2.94'^CHMD IC(741002. 94,^0;27^Q
  45291   "^DD",7410 00,741000, .27,"DT")
  45292   2960220
  45293   "^DD",7410 00,741000, .28,0)
  45294   VENDOR PAY  CODE FLAG ^S^1:YES;0 :NO;^0;28^ Q
  45295   "^DD",7410 00,741000, .28,"DT")
  45296   2970618
  45297   "^DD",7410 00,741000, 1.01,0)
  45298   AMOUNT TO  BE PAID ON  CLAIM^NJ1 0,2^^1;1^K :+X'=X!(X> 9999999)!( X<0)!(X?.E 1"."3N.N)  X
  45299   "^DD",7410 00,741000, 1.01,3)
  45300   Type a Num ber betwee n 0 and 99 99999, 2 D ecimal Dig its
  45301   "^DD",7410 00,741000, 1.01,"DT")
  45302   2950821
  45303   "^DD",7410 00,741000, 1.02,0)
  45304   CAPPS/CALM  BATCH DAT E/TIME^D^^ 1;2^S %DT= "ESTXR" D  ^%DT S X=Y  K:Y<1 X
  45305   "^DD",7410 00,741000, 1.02,1,0)
  45306   ^.1^^0
  45307   "^DD",7410 00,741000, 1.02,3)
  45308  
  45309   "^DD",7410 00,741000, 1.02,"DT")
  45310   2910126
  45311   "^DD",7410 00,741000, 1.03,0)
  45312   CAPP PAYME NT DIFFERE NTIAL^NJ10 ,2^^1;3^S: X["$" X=$P (X,"$",2)  K:X'?."-". N.1".".2N! (X>9999999 )!(X<-9999 999) X
  45313   "^DD",7410 00,741000, 1.03,3)
  45314   Type a Dol lar Amount  between - 9999999 an d 9999999,  2 Decimal  Digits
  45315   "^DD",7410 00,741000, 1.03,"DT")
  45316   2920609
  45317   "^DD",7410 00,741000, 1.04,0)
  45318   DATE OF TR EASURY PAY MENT^D^^1; 4^S %DT="E " D ^%DT S  X=Y K:Y<1  X
  45319   "^DD",7410 00,741000, 1.04,"DT")
  45320   2910126
  45321   "^DD",7410 00,741000, 1.05,0)
  45322   AMT APPLIE D TO DEDUC TIBLE^NJ6, 2^^1;5^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>10 0)!(X<0) X
  45323   "^DD",7410 00,741000, 1.05,3)
  45324   Type a Dol lar Amount  between 0  and 100,  2 Decimal  Digits
  45325   "^DD",7410 00,741000, 1.05,"DT")
  45326   2901012
  45327   "^DD",7410 00,741000, 1.06,0)
  45328   COST SHARE  AMOUNT^NJ 9,2^^1;6^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 999999)!(X <0) X
  45329   "^DD",7410 00,741000, 1.06,3)
  45330   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  45331   "^DD",7410 00,741000, 1.06,"DT")
  45332   2901012
  45333   "^DD",7410 00,741000, 1.07,0)
  45334   AMOUNT PAI D BY OTHER  INSURANCE ^NJ9,2^^1; 7^S:X["$"  X=$P(X,"$" ,2) K:X'?. "-".N.1"." .2N!(X>999 999)!(X<-9 99999) X
  45335   "^DD",7410 00,741000, 1.07,3)
  45336   Type a dol lar amount  between - 999999 and  999999, 2  decimal d igits.
  45337   "^DD",7410 00,741000, 1.07,"DT")
  45338   3130422
  45339   "^DD",7410 00,741000, 1.08,0)
  45340   TOT AMT CH ARGED FOR  ALLOW DAYS ^NJ8,2^^1; 8^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>99999)! (X<0) X
  45341   "^DD",7410 00,741000, 1.08,3)
  45342   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  45343   "^DD",7410 00,741000, 1.08,"DT")
  45344   2901221
  45345   "^DD",7410 00,741000, 1.09,0)
  45346   AMT PAID B Y OHI FOR  ALLOW DAYS ^NJ8,2^^1; 9^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>99999)! (X<0) X
  45347   "^DD",7410 00,741000, 1.09,3)
  45348   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  45349   "^DD",7410 00,741000, 1.09,"DT")
  45350   2901018
  45351   "^DD",7410 00,741000, 1.1,0)
  45352   OTH INS AM T PD FOR F ACILITY^NJ 8,2^^1;10^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >99999)!(X <0) X
  45353   "^DD",7410 00,741000, 1.1,3)
  45354   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  45355   "^DD",7410 00,741000, 1.1,"DT")
  45356   2901226
  45357   "^DD",7410 00,741000, 1.11,0)
  45358   MENTAL HEA LTH ALLOWA BLE DAYS^N J3,0^^1;11 ^K:+X'=X!( X>999)!(X< 0)!(X?.E1" ."1N.N) X
  45359   "^DD",7410 00,741000, 1.11,3)
  45360   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  45361   "^DD",7410 00,741000, 1.11,"DT")
  45362   2901221
  45363   "^DD",7410 00,741000, 1.12,0)
  45364   ALCOHOL AL LOWABLE DA YS^NJ3,0^^ 1;12^K:+X' =X!(X>999) !(X<0)!(X? .E1"."1N.N ) X
  45365   "^DD",7410 00,741000, 1.12,3)
  45366   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  45367   "^DD",7410 00,741000, 1.12,"DT")
  45368   2901221
  45369   "^DD",7410 00,741000, 1.13,0)
  45370   CAPPS/CALM  ACC/REJ S TATUS^S^0: REJECTED;1 :ACCEPTED; ^1;13^Q
  45371   "^DD",7410 00,741000, 1.13,"DT")
  45372   2910209
  45373   "^DD",7410 00,741000, 1.14,0)
  45374   AMT PAID T O VENDOR^N J10,2^^1;1 4^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 )!(X<0) X
  45375   "^DD",7410 00,741000, 1.14,3)
  45376   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45377   "^DD",7410 00,741000, 1.14,"DT")
  45378   2910306
  45379   "^DD",7410 00,741000, 1.15,0)
  45380   AMT PAID T O BENE^NJ9 ,2^^1;15^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 999999)!(X <0) X
  45381   "^DD",7410 00,741000, 1.15,3)
  45382   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  45383   "^DD",7410 00,741000, 1.15,"DT")
  45384   2910306
  45385   "^DD",7410 00,741000, 1.16,0)
  45386   VENDOR TRE ASURY CHEC K NUMBER^F ^^1;16^K:$ L(X)>9!($L (X)<1) X
  45387   "^DD",7410 00,741000, 1.16,1,0)
  45388   ^.1^^0
  45389   "^DD",7410 00,741000, 1.16,3)
  45390   Answer mus t be 1-9 c haracters  in length.
  45391   "^DD",7410 00,741000, 1.16,"DT")
  45392   2920929
  45393   "^DD",7410 00,741000, 1.17,0)
  45394   BENE. TREA SURY CHECK  NUMBER^NJ 9,0^^1;17^ K:+X'=X!(X >999999999 )!(X<0)!(X ?.E1"."1N. N) X
  45395   "^DD",7410 00,741000, 1.17,1,0)
  45396   ^.1^^0
  45397   "^DD",7410 00,741000, 1.17,3)
  45398   Type a Num ber betwee n 0 and 99 9999999, 0  Decimal D igits
  45399   "^DD",7410 00,741000, 1.17,"DT")
  45400   2910608
  45401   "^DD",7410 00,741000, 1.18,0)
  45402   AMT APPLIE D TO CAT C AP^NJ8,2^^ 1;18^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9)!(X<0) X
  45403   "^DD",7410 00,741000, 1.18,3)
  45404   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  45405   "^DD",7410 00,741000, 1.18,"DT")
  45406   2910716
  45407   "^DD",7410 00,741000, 1.19,0)
  45408   OCH BENE D ED BALANCE ^NJ6,2^^1; 19^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999)!( X<0) X
  45409   "^DD",7410 00,741000, 1.19,3)
  45410   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  45411   "^DD",7410 00,741000, 1.19,"DT")
  45412   2910717
  45413   "^DD",7410 00,741000, 1.2,0)
  45414   CHV BENE D ED BALANCE ^NJ6,2^^1; 20^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999)!( X<0) X
  45415   "^DD",7410 00,741000, 1.2,3)
  45416   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  45417   "^DD",7410 00,741000, 1.2,"DT")
  45418   2910717
  45419   "^DD",7410 00,741000, 1.21,0)
  45420   BEN DED ME T^S^0:NOT  MET;1:MET; ^1;21^Q
  45421   "^DD",7410 00,741000, 1.21,3)
  45422  
  45423   "^DD",7410 00,741000, 1.21,"DT")
  45424   2910716
  45425   "^DD",7410 00,741000, 1.22,0)
  45426   OCH FAM DE D BALANCE^ NJ6,2^^1;2 2^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>999)!(X <0) X
  45427   "^DD",7410 00,741000, 1.22,3)
  45428   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  45429   "^DD",7410 00,741000, 1.22,"DT")
  45430   2910717
  45431   "^DD",7410 00,741000, 1.23,0)
  45432   CHV FAM DE D BALANCE^ NJ6,2^^1;2 3^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>999)!(X <0) X
  45433   "^DD",7410 00,741000, 1.23,3)
  45434   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  45435   "^DD",7410 00,741000, 1.23,"DT")
  45436   2910717
  45437   "^DD",7410 00,741000, 1.24,0)
  45438   FAMILY DED  MET^S^0:N OT MET;1:M ET;^1;24^Q
  45439   "^DD",7410 00,741000, 1.24,3)
  45440  
  45441   "^DD",7410 00,741000, 1.24,"DT")
  45442   2910716
  45443   "^DD",7410 00,741000, 1.25,0)
  45444   OCH FAM CA T CAP BALA NCE^NJ8,2^ ^1;25^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 99)!(X<0)  X
  45445   "^DD",7410 00,741000, 1.25,3)
  45446   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  45447   "^DD",7410 00,741000, 1.25,"DT")
  45448   2910717
  45449   "^DD",7410 00,741000, 1.26,0)
  45450   CHV FAM CA T CAP BALA NCE^NJ8,2^ ^1;26^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 99)!(X<0)  X
  45451   "^DD",7410 00,741000, 1.26,3)
  45452   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  45453   "^DD",7410 00,741000, 1.26,"DT")
  45454   2910717
  45455   "^DD",7410 00,741000, 1.27,0)
  45456   FAMILY CAT  CAP MET^S ^0:NOT MET ;1:MET;^1; 27^Q
  45457   "^DD",7410 00,741000, 1.27,"DT")
  45458   2910716
  45459   "^DD",7410 00,741000, 1.28,0)
  45460   CITI MAX R EIMB RATE^ NJ7,0^^1;2 8^K:+X'=X! (X>9999999 )!(X<0)!(X ?.E1"."1N. N) X
  45461   "^DD",7410 00,741000, 1.28,3)
  45462   Type a Num ber betwee n 0 and 99 99999, 0 D ecimal Dig its
  45463   "^DD",7410 00,741000, 1.28,"DT")
  45464   2930419
  45465   "^DD",7410 00,741000, 1.29,0)
  45466   OHI PATIEN T RESPONSI BILITY^NJ1 0,2^^1;29^ K:+X'=X!(X >9999999)! (X<0)!(X?. E1"."3N.N)  X
  45467   "^DD",7410 00,741000, 1.29,3)
  45468   Type a Num ber betwee n 0 and 99 99999, 2 D ecimal Dig its
  45469   "^DD",7410 00,741000, 1.29,"DT")
  45470   3061017
  45471   "^DD",7410 00,741000, 1.3,0)
  45472   PRIOR VEND OR PAY AMT ^NJ12,2^^1 ;30^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 9999)!(X<0 ) X
  45473   "^DD",7410 00,741000, 1.3,3)
  45474   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  45475   "^DD",7410 00,741000, 1.3,"DT")
  45476   3110812
  45477   "^DD",7410 00,741000, 1.31,0)
  45478   PRIOR BENE  PAY AMT^N J12,2^^1;3 1^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 99)!(X<0)  X
  45479   "^DD",7410 00,741000, 1.31,3)
  45480   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  45481   "^DD",7410 00,741000, 1.31,"DT")
  45482   3110812
  45483   "^DD",7410 00,741000, 3.01,0)
  45484   INITIAL PR OCESSING U SER (DUZ)^ P200'^VA(2 00,^3;1^Q
  45485   "^DD",7410 00,741000, 3.01,"DT")
  45486   2951010
  45487   "^DD",7410 00,741000, 3.02,0)
  45488   DATE START  ADMIN. SU SPENSE^D^^ 3;2^S %DT= "ESTX" D ^ %DT S X=Y  K:Y<1 X
  45489   "^DD",7410 00,741000, 3.02,"DT")
  45490   2910326
  45491   "^DD",7410 00,741000, 3.03,0)
  45492   DUZ START  ADMIN. SUS PENSE^P200 '^VA(200,^ 3;3^Q
  45493   "^DD",7410 00,741000, 3.03,"DT")
  45494   2951010
  45495   "^DD",7410 00,741000, 3.04,0)
  45496   REASON FOR  ADMIN. SU SPENSE^F^^ 3;4^K:$L(X )>200!($L( X)<1) X
  45497   "^DD",7410 00,741000, 3.04,3)
  45498   Answer mus t be 1-200  character s in lengt h.
  45499   "^DD",7410 00,741000, 3.04,"DT")
  45500   2910326
  45501   "^DD",7410 00,741000, 3.05,0)
  45502   DATE CLEAR  ADMIN. SU SPENSE^D^^ 3;5^S %DT= "ESTX" D ^ %DT S X=Y  K:Y<1 X
  45503   "^DD",7410 00,741000, 3.05,"DT")
  45504   2910326
  45505   "^DD",7410 00,741000, 3.06,0)
  45506   DUZ CLEAR  ADMIN. SUS PENSE^P200 '^VA(200,^ 3;6^Q
  45507   "^DD",7410 00,741000, 3.06,"DT")
  45508   2951010
  45509   "^DD",7410 00,741000, 3.07,0)
  45510   REJ CLAIM  IN ELIG OR  VENDOR^S^ 1:YES;^3;7 ^Q
  45511   "^DD",7410 00,741000, 3.07,"DT")
  45512   3131119
  45513   "^DD",7410 00,741000, 4.01,0)
  45514   REJECTION  REASONS^74 1000.701P^ ^4;0
  45515   "^DD",7410 00,741000, 5.01,0)
  45516   MCCR RECOU PMENT STAT US^S^0:PEN DING RECOU PMENT;1:PA RTIAL RECO UPMENT;2:F ULL RECOUP MENT;3:NO  RECOUPMENT ;^5;1^Q
  45517   "^DD",7410 00,741000, 5.01,"DT")
  45518   2950516
  45519   "^DD",7410 00,741000, 5.02,0)
  45520   AMOUNT REQ UESTED^NJ1 0,2^^5;2^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 9999999)!( X<0) X
  45521   "^DD",7410 00,741000, 5.02,3)
  45522   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45523   "^DD",7410 00,741000, 5.02,"DT")
  45524   2950512
  45525   "^DD",7410 00,741000, 5.03,0)
  45526   AMOUNT REC OUPED^NJ10 ,2^^5;3^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999999)!(X <0) X
  45527   "^DD",7410 00,741000, 5.03,3)
  45528   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45529   "^DD",7410 00,741000, 5.03,"DT")
  45530   2950512
  45531   "^DD",7410 00,741000, 5.04,0)
  45532   BENE CAT C AP BEFORE  RESET^NJ12 ,2^^5;4^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  45533   "^DD",7410 00,741000, 5.04,3)
  45534   Type a Dol lar Amount  between 0  and 99999 9999, 2 De cimal Digi ts
  45535   "^DD",7410 00,741000, 5.04,"DT")
  45536   2950512
  45537   "^DD",7410 00,741000, 5.05,0)
  45538   BENE CAT C AP AFTER R ESET^NJ10, 2^^5;5^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 99999)!(X< 0) X
  45539   "^DD",7410 00,741000, 5.05,3)
  45540   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45541   "^DD",7410 00,741000, 5.05,"DT")
  45542   2950628
  45543   "^DD",7410 00,741000, 5.06,0)
  45544   MCCR RESET  FLAG^S^0: NOT RESET; 1:RESET;^5 ;6^Q
  45545   "^DD",7410 00,741000, 5.06,"DT")
  45546   2950606
  45547   "^DD",7410 00,741000, 5.07,0)
  45548   BENE CAT C AP AMT SUB T^NJ10,2^^ 5;7^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 99)!(X<0)  X
  45549   "^DD",7410 00,741000, 5.07,3)
  45550   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45551   "^DD",7410 00,741000, 5.07,"DT")
  45552   2950628
  45553   "^DD",7410 00,741000, 5.08,0)
  45554   BENE DED B EFORE RESE T^NJ6,2^^5 ;8^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999)!( X<0) X
  45555   "^DD",7410 00,741000, 5.08,3)
  45556   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  45557   "^DD",7410 00,741000, 5.08,"DT")
  45558   2950628
  45559   "^DD",7410 00,741000, 5.09,0)
  45560   BENE DED A FTER RESET ^NJ7,2^^5; 9^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999)!( X<0) X
  45561   "^DD",7410 00,741000, 5.09,3)
  45562   Type a Dol lar Amount  between 0  and 9999,  2 Decimal  Digits
  45563   "^DD",7410 00,741000, 5.09,"DT")
  45564   2950628
  45565   "^DD",7410 00,741000, 5.1,0)
  45566   BENE DED A MT SUBT^NJ 6,2^^5;10^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >999)!(X<0 ) X
  45567   "^DD",7410 00,741000, 5.1,3)
  45568   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  45569   "^DD",7410 00,741000, 5.1,"DT")
  45570   2950628
  45571   "^DD",7410 00,741000, 5.11,0)
  45572   MMI REVERS AL PAID FL AG^S^0:NOT  PAID;1:PA ID;^5;11^Q
  45573   "^DD",7410 00,741000, 5.11,21,0)
  45574   ^^2^2^3080 722^
  45575   "^DD",7410 00,741000, 5.11,21,1, 0)
  45576   If this fl ag is set  to 1, it m eans the M MI reverse d claim ha s been pai
  45577   "^DD",7410 00,741000, 5.11,21,2, 0)
  45578   by another  MMI dupe  claim and  won't bypa ss the dup e check.
  45579   "^DD",7410 00,741000, 5.11,"DT")
  45580   3080722
  45581   "^DD",7410 00,741000, 6.01,0)
  45582   TO CLAIM P OINTER^P74 1000'^CHMP AY(^6;1^Q
  45583   "^DD",7410 00,741000, 6.01,"DT")
  45584   2910212
  45585   "^DD",7410 00,741000, 6.02,0)
  45586   FROM CLAIM  POINTER^P 741000'^CH MPAY(^6;2^ Q
  45587   "^DD",7410 00,741000, 6.02,"DT")
  45588   2910212
  45589   "^DD",7410 00,741000, 6.03,0)
  45590   RE-OPEN CA LCULATION  FLAG^S^0:Y ES;^6;3^Q
  45591   "^DD",7410 00,741000, 6.03,"DT")
  45592   2910620
  45593   "^DD",7410 00,741000, 6.04,0)
  45594   RE-OPENED  FLAG^S^0:N O;1:YES;^6 ;4^Q
  45595   "^DD",7410 00,741000, 6.04,"DT")
  45596   2911126
  45597   "^DD",7410 00,741000, 6.05,0)
  45598   MEDICAID R EOPEN EDIT  FLAG^S^0: NO EDIT;1: EDIT;^6;5^ Q
  45599   "^DD",7410 00,741000, 6.05,"DT")
  45600   2940815
  45601   "^DD",7410 00,741000, 7.01,0)
  45602   MEDICAID A GENCY^P741 001'^CHMVE N(^7;1^Q
  45603   "^DD",7410 00,741000, 7.01,1,0)
  45604   ^.1
  45605   "^DD",7410 00,741000, 7.01,1,1,0 )
  45606   741000^AE
  45607   "^DD",7410 00,741000, 7.01,1,1,1 )
  45608   S ^CHMPAY( "AE",$E(X, 1,30),DA)= ""
  45609   "^DD",7410 00,741000, 7.01,1,1,2 )
  45610   K ^CHMPAY( "AE",$E(X, 1,30),DA)
  45611   "^DD",7410 00,741000, 7.01,1,1," DT")
  45612   2990505
  45613   "^DD",7410 00,741000, 7.01,"DT")
  45614   2990505
  45615   "^DD",7410 00,741000, 7.02,0)
  45616   MEDICAID A MOUNT PAID ^NJ10,2^^7 ;2^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 9)!(X<0) X
  45617   "^DD",7410 00,741000, 7.02,3)
  45618   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45619   "^DD",7410 00,741000, 7.02,"DT")
  45620   2940316
  45621   "^DD",7410 00,741000, 7.03,0)
  45622   VENDOR FMS  DOC ID +  LN NUM^F^^ 7;3^K:$L(X )>15!($L(X )<11) X
  45623   "^DD",7410 00,741000, 7.03,1,0)
  45624   ^.1^^0
  45625   "^DD",7410 00,741000, 7.03,3)
  45626   Answer mus t be 11-15  character s in lengt h.
  45627   "^DD",7410 00,741000, 7.03,"DT")
  45628   2951004
  45629   "^DD",7410 00,741000, 7.04,0)
  45630   BENE FMS D OC ID +LN  NUM^F^^7;4 ^K:$L(X)>1 5!($L(X)<1 1) X
  45631   "^DD",7410 00,741000, 7.04,1,0)
  45632   ^.1^^0
  45633   "^DD",7410 00,741000, 7.04,3)
  45634   Answer mus t be 11-15  character s in lengt h.
  45635   "^DD",7410 00,741000, 7.04,"DT")
  45636   2951004
  45637   "^DD",7410 00,741000, 7.05,0)
  45638   PATIENT CO NTROL NUMB ER^F^^7;5^ K:$L(X)>30 !($L(X)<1)  X
  45639   "^DD",7410 00,741000, 7.05,3)
  45640   Answer mus t be 1-30  characters  in length .
  45641   "^DD",7410 00,741000, 7.05,"DT")
  45642   2961213
  45643   "^DD",7410 00,741000, 7.06,0)
  45644   TYPE OF BI LL^F^^7;6^ K:$L(X)>3! ($L(X)<1)  X
  45645   "^DD",7410 00,741000, 7.06,3)
  45646   Answer mus t be 1-3 c haracters  in length.
  45647   "^DD",7410 00,741000, 7.06,"DT")
  45648   2961213
  45649   "^DD",7410 00,741000, 7.07,0)
  45650   EFT INDICA TOR^S^1:VE NDOR ONLY; 2:BENE ONL Y;3:BOTH;^ 7;7^Q
  45651   "^DD",7410 00,741000, 7.07,"DT")
  45652   2990504
  45653   "^DD",7410 00,741000, 7.08,0)
  45654   PAY LOCATI ON^F^^7;8^ K:$L(X)>15 !($L(X)<1)  X
  45655   "^DD",7410 00,741000, 7.08,3)
  45656   Answer mus t be 1-15  characters  in length .
  45657   "^DD",7410 00,741000, 7.08,21,0)
  45658   ^^2^2^3100 429^
  45659   "^DD",7410 00,741000, 7.08,21,1, 0)
  45660   USED IN DE TERMINING  ALLOWABLE  AMOUNT.
  45661   "^DD",7410 00,741000, 7.08,21,2, 0)
  45662  
  45663   "^DD",7410 00,741000, 7.08,"DT")
  45664   3100429
  45665   "^DD",7410 00,741000, 7.09,0)
  45666   TOTAL TPL  AMT^NJ12,2 ^^7;9^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 999999)!(X <0) X
  45667   "^DD",7410 00,741000, 7.09,3)
  45668   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  45669   "^DD",7410 00,741000, 7.09,"DT")
  45670   3110315
  45671   "^DD",7410 00,741000, 7.1,0)
  45672   OTHER OHI  PAID^NJ12, 2^^7;10^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  45673   "^DD",7410 00,741000, 7.1,3)
  45674   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  45675   "^DD",7410 00,741000, 7.1,"DT")
  45676   3111005
  45677   "^DD",7410 00,741000, 7.11,0)
  45678   OHI PR BAL ^NJ12,2^^7 ;11^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 9999)!(X<0 ) X
  45679   "^DD",7410 00,741000, 7.11,3)
  45680   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  45681   "^DD",7410 00,741000, 7.11,"DT")
  45682   3120605
  45683   "^DD",7410 00,741000, 8,0)
  45684   AUTO DISTR IBUTION^S^ 1:YES;0:NO ;^COMMON;1 8^Q
  45685   "^DD",7410 00,741000, 8,21,0)
  45686   ^^1^1^3110 705^
  45687   "^DD",7410 00,741000, 8,21,1,0)
  45688   AUTO DISTR IBUTION OF  PR
  45689   "^DD",7410 00,741000, 8,"DT")
  45690   3110705
  45691   "^DD",7410 00,741000, 8.01,0)
  45692   PAYMENT LE SS THAN $1 .00^S^0:CH ECK ISSUED ;1:NO CHEC K ISSUED;^ 8;1^Q
  45693   "^DD",7410 00,741000, 8.01,"DT")
  45694   2950619
  45695   "^DD",7410 00,741000, 9.01,0)
  45696   CLAIM FORM  SENT^S^0: NO;1:YES;^ 9;1^Q
  45697   "^DD",7410 00,741000, 9.01,"DT")
  45698   2901206
  45699   "^DD",7410 00,741000, 9.02,0)
  45700   MISSING DA TA STRING^ F^^9;2^K:$ L(X)>30!($ L(X)<1) X
  45701   "^DD",7410 00,741000, 9.02,3)
  45702   Answer mus t be 1-30  characters  in length .
  45703   "^DD",7410 00,741000, 9.02,"DT")
  45704   2910314
  45705   "^DD",7410 00,741000, 9.03,0)
  45706   DUPLICATE  CLAIM CHEC K^S^0:NO;1 :YES;^9;3^ Q
  45707   "^DD",7410 00,741000, 9.03,"DT")
  45708   2910319
  45709   "^DD",7410 00,741000, 9.05,0)
  45710   AUDIT SUPP ORT FLAG^S ^1:YES;0:N O;^9;5^Q
  45711   "^DD",7410 00,741000, 9.05,"DT")
  45712   2911025
  45713   "^DD",7410 00,741000, 9.06,0)
  45714   PAGE FOR V ENDORIZATI ON^NJ4,0^^ 9;6^K:+X'= X!(X>9999) !(X<0)!(X? .E1"."1N.N ) X
  45715   "^DD",7410 00,741000, 9.06,3)
  45716   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  45717   "^DD",7410 00,741000, 9.06,"DT")
  45718   2930126
  45719   "^DD",7410 00,741000, 9.07,0)
  45720   COMMENTS P OINTER^P74 1000.8'^CH MCLCOM(^9; 7^Q
  45721   "^DD",7410 00,741000, 9.07,"DT")
  45722   2930226
  45723   "^DD",7410 00,741000, 9.08,0)
  45724   REJECTED D UPE POINTE R^P741000' ^CHMPAY(^9 ;8^Q
  45725   "^DD",7410 00,741000, 9.08,"DT")
  45726   2950104
  45727   "^DD",7410 00,741000, 9.09,0)
  45728   CHSTRIP FL AG^S^0:NO  STRIP;1:ST RIP;^9;9^Q
  45729   "^DD",7410 00,741000, 9.09,"DT")
  45730   2970326
  45731   "^DD",7410 00,741000, 10.01,0)
  45732   WORK RELAT ED ACC/ILL ^S^1:YES;0 :NO;^10;1^ Q
  45733   "^DD",7410 00,741000, 10.02,0)
  45734   AUTO ACCID ENT^S^1:YE S;0:NO;^10 ;2^Q
  45735   "^DD",7410 00,741000, 10.03,0)
  45736   OTHER ACCI DENT^S^1:Y ES;0:NO;^1 0;3^Q
  45737   "^DD",7410 00,741000, 10.04,0)
  45738   EMPLOYED^S ^1:YES;0:N O;^10;4^Q
  45739   "^DD",7410 00,741000, 10.05,0)
  45740   RELEASE OF  INFOR LIM IT FLAG^S^ 1:YES;0:NO ;^10;5^Q
  45741   "^DD",7410 00,741000, 10.06,0)
  45742   OTHER HEAL TH INSURAN CE FLAG^S^ 1:YES;0:NO ;^10;6^Q
  45743   "^DD",7410 00,741000, 10.07,0)
  45744   CLAIM SIGN ATURE FLAG ^S^1:YES;0 :NO;^10;7^ Q
  45745   "^DD",7410 00,741000, 10.08,0)
  45746   GROUP HEAL TH FLAG^S^ 1:YES;0:NO ;^10;8^Q
  45747   "^DD",7410 00,741000, 10.09,0)
  45748   MEDICAID F LAG^S^1:YE S;0:NO;^10 ;9^Q
  45749   "^DD",7410 00,741000, 10.1,0)
  45750   PRIVATE/NO N-GROUP FL AG^S^1:YES ;0:NO;^10; 10^Q
  45751   "^DD",7410 00,741000, 10.11,0)
  45752   CHAMPVA SU PPLEMENT F LAG^S^1:YE S;0:NO;^10 ;11^Q
  45753   "^DD",7410 00,741000, 10.12,0)
  45754   WORKERS CO MPENSATION  FLAG^S^1: YES;0:NO;^ 10;12^Q
  45755   "^DD",7410 00,741000, 10.13,0)
  45756   NONE CHECK ED FLAG^S^ 1:YES;0:NO ;^10;13^Q
  45757   "^DD",7410 00,741000, 10.14,0)
  45758   MEDICARE F LAG^S^1:YE S;0:NO;^10 ;14^Q
  45759   "^DD",7410 00,741000, 10.15,0)
  45760   NON-OCCUPA TIONAL INJ URY FLAG^S ^1:YES;0:N O;^10;15^Q
  45761   "^DD",7410 00,741000, 10.16,0)
  45762   MULTI CAUS AL ACCIDEN T FLAG^S^1 :YES;0:NO; ^10;16^Q
  45763   "^DD",7410 00,741000, 10.17,0)
  45764   ADDIT. ACC IDENT COMM ENTS FLAG^ S^1:YES;0: NO;^10;17^ Q
  45765   "^DD",7410 00,741000, 10.18,0)
  45766   WC DETAILS  FLAG^S^1: YES;0:NO;^ 10;18^Q
  45767   "^DD",7410 00,741000, 10.19,0)
  45768   INDICATION S OF INJUR Y/ACCIDENT ^S^1:YES;0 :NO;^10;19 ^Q
  45769   "^DD",7410 00,741000, 10.2,0)
  45770   INDICATION S OF OTHER  INSURANCE ^S^1:YES;0 :NO;^10;20 ^Q
  45771   "^DD",7410 00,741000, 10.21,0)
  45772   MCCR REVIE W WARRANTE D^S^1:YES; 0:NO;^10;2 1^Q
  45773   "^DD",7410 00,741000, 10.22,0)
  45774   CIRCUMSTAN CES FLAG^S ^1:YES;0:N O;^10;22^Q
  45775   "^DD",7410 00,741000, 10.23,0)
  45776   FILE RUN T IME^D^^10; 23^S %DT=" ETXR" D ^% DT S X=Y K :Y<1 X
  45777   "^DD",7410 00,741000, 10.23,1,0)
  45778   ^.1
  45779   "^DD",7410 00,741000, 10.23,1,1, 0)
  45780   741000^M
  45781   "^DD",7410 00,741000, 10.23,1,1, 1)
  45782   S ^CHMPAY( "M",$E(X,1 ,30),DA)=" "
  45783   "^DD",7410 00,741000, 10.23,1,1, 2)
  45784   K ^CHMPAY( "M",$E(X,1 ,30),DA)
  45785   "^DD",7410 00,741000, 10.23,1,1, "DT")
  45786   3140210
  45787   "^DD",7410 00,741000, 10.23,21,0 )
  45788   ^.001^1^1^ 3140219^^^
  45789   "^DD",7410 00,741000, 10.23,21,1 ,0)
  45790   LAST FILE  RUN TIME
  45791   "^DD",7410 00,741000, 10.23,"DT" )
  45792   3140210
  45793   "^DD",7410 00,741000, 14.01,0)
  45794   CMOP PSEUD O REJECT^F ^^14;1^K:$ L(X)>30!($ L(X)<1) X
  45795   "^DD",7410 00,741000, 14.01,3)
  45796   Answer mus t be 1-30  characters  in length .
  45797   "^DD",7410 00,741000, 14.01,"DT" )
  45798   2960109
  45799   "^DD",7410 00,741000, 16.01,0)
  45800   BENE CANCE LLED CHECK  REASON^P7 41502'^CHM DIC(741502 ,^16;1^Q
  45801   "^DD",7410 00,741000, 16.01,"DT" )
  45802   2960517
  45803   "^DD",7410 00,741000, 16.02,0)
  45804   VENDOR CAN CELLED CHE CK REASON^ P741502'^C HMDIC(7415 02,^16;2^Q
  45805   "^DD",7410 00,741000, 16.02,"DT" )
  45806   2960517
  45807   "^DD",7410 00,741000, 16.1,0)
  45808   BENE CANCE LLED CHECK  REASON^S^ A:AMT INCO RRECT;B:BE TTER ADDR; D:DUPL PAY MENT;E:DEC EASED;I:PA YMENT ID;L :LIM PAYAB ILITY;N:NO T ENTITLED ;O:SUPPL/S ERV CANC;P :PARTIAL W RONG PAYEE ;S:MIS-SPE LLED NAME; U:UNK;W:WR ONG PAYEE; X:CONVERSI ON CANC RE AS;^16;1^Q
  45809   "^DD",7410 00,741000, 16.1,"DT")
  45810   2960410
  45811   "^DD",7410 00,741000, 16.2,0)
  45812   VENDOR CAN CELLED CHE CK REASON^ S^A:AMT IN CORRECT;B: BETTER ADD R;D:DUPL P AYMENT;E:D ECEASED;I: PAYMENT ID ;L:LIM PAY ABILITY;N: NOT ENTITL ED;O:SUPPL /SERV CANC ;P:PARTIAL  WRONG PAY EE;S:MIS-S PELLED NAM E;U:UNK;W: WRONG PAYE E;X:CONVER SION CANC  REAS;^16;2 ^Q
  45813   "^DD",7410 00,741000, 16.2,"DT")
  45814   2960410
  45815   "^DD",7410 00,741000, 20.01,0)
  45816   REL OF INF OR LIMIT T ERM DATE^D ^^20;1^S % DT="E" D ^ %DT S X=Y  K:Y<1 X
  45817   "^DD",7410 00,741000, 20.02,0)
  45818   SIGNATURE  DATE^D^^20 ;2^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X
  45819   "^DD",7410 00,741000, 20.03,0)
  45820   DATE OF AC CIDENT^D^^ 20;3^S %DT ="E" D ^%D T S X=Y K: Y<1 X
  45821   "^DD",7410 00,741000, 20.04,0)
  45822   SIGNATURE  ON CLAIM F ORM^F^^20; 4^K:$L(X)> 20!($L(X)< 1) X
  45823   "^DD",7410 00,741000, 20.04,3)
  45824   Answer mus t be 1-20  characters  in length .
  45825   "^DD",7410 00,741000, 24.01,0)
  45826   OTHER INSU RANCE CARR IER NAME^F ^^24;1^K:$ L(X)>30!($ L(X)<1) X
  45827   "^DD",7410 00,741000, 24.01,3)
  45828   Answer mus t be 1-30  characters  in length .
  45829   "^DD",7410 00,741000, 24.02,0)
  45830   OTHER INSU RANCE CARR IER ADDR1^ F^^24;2^K: $L(X)>50!( $L(X)<1) X
  45831   "^DD",7410 00,741000, 24.02,3)
  45832   Answer mus t be 1-50  characters  in length .
  45833   "^DD",7410 00,741000, 24.03,0)
  45834   OTHER INSU RANCE CARR IER ADDR2^ F^^24;3^K: $L(X)>50!( $L(X)<1) X
  45835   "^DD",7410 00,741000, 24.03,3)
  45836   Answer mus t be 1-50  characters  in length .
  45837   "^DD",7410 00,741000, 24.04,0)
  45838   OTHER INSU RANCE CARR IER CITY^F ^^24;4^K:$ L(X)>25!($ L(X)<1) X
  45839   "^DD",7410 00,741000, 24.04,3)
  45840   Answer mus t be 1-25  characters  in length .
  45841   "^DD",7410 00,741000, 24.05,0)
  45842   OTHER INSU RANCE CARR IER STATE^ P5'^DIC(5, ^24;5^Q
  45843   "^DD",7410 00,741000, 24.06,0)
  45844   OTHER INSU RANCE CARR IER ZIP^F^ ^24;6^K:$L (X)>10!($L (X)<1) X
  45845   "^DD",7410 00,741000, 24.06,3)
  45846   Answer mus t be 1-10  characters  in length .
  45847   "^DD",7410 00,741000, 24.06,"DT" )
  45848   2910503
  45849   "^DD",7410 00,741000, 24.07,0)
  45850   OTHER INSU RANCE CARR IER PHONE^ F^^24;7^K: $L(X)>16!( $L(X)<1) X
  45851   "^DD",7410 00,741000, 24.07,3)
  45852   Answer mus t be 1-16  characters  in length .
  45853   "^DD",7410 00,741000, 24.07,"DT" )
  45854   2910503
  45855   "^DD",7410 00,741000, 24.08,0)
  45856   OTHER INS  CARRIER PO LICY ID^F^ ^24;8^K:$L (X)>20!($L (X)<1) X
  45857   "^DD",7410 00,741000, 24.08,3)
  45858   Answer mus t be 1-20  characters  in length .
  45859   "^DD",7410 00,741000, 24.09,0)
  45860   OHI EOB^S^ 1:YES;0:NO ;^24;9^Q
  45861   "^DD",7410 00,741000, 24.09,"DT" )
  45862   3120411
  45863   "^DD",7410 00,741000, 26.01,0)
  45864   WC CARRIER  NAME^F^^2 6;1^K:$L(X )>30!($L(X )<1) X
  45865   "^DD",7410 00,741000, 26.01,3)
  45866   Answer mus t be 1-30  characters  in length .
  45867   "^DD",7410 00,741000, 26.02,0)
  45868   WC CARRIER  ADDR1^F^^ 26;2^K:$L( X)>50!($L( X)<1) X
  45869   "^DD",7410 00,741000, 26.02,3)
  45870   Answer mus t be 1-50  characters  in length .
  45871   "^DD",7410 00,741000, 26.03,0)
  45872   WC CARRIER  ADDR2^F^^ 26;3^K:$L( X)>50!($L( X)<1) X
  45873   "^DD",7410 00,741000, 26.03,3)
  45874   Answer mus t be 1-50  characters  in length .
  45875   "^DD",7410 00,741000, 26.04,0)
  45876   WC CARRIER  CITY^F^^2 6;4^K:$L(X )>25!($L(X )<1) X
  45877   "^DD",7410 00,741000, 26.04,3)
  45878   Answer mus t be 1-25  characters  in length .
  45879   "^DD",7410 00,741000, 26.05,0)
  45880   WC CARRIER  STATE^P5' ^DIC(5,^26 ;5^Q
  45881   "^DD",7410 00,741000, 26.06,0)
  45882   WC CARRIER  ZIP^NJ9,0 X^^26;6^K: (X'?5N)&(X '?9N) X
  45883   "^DD",7410 00,741000, 26.06,3)
  45884   Enter a 5  or 9 digit  zip code.
  45885   "^DD",7410 00,741000, 26.06,"DT" )
  45886   2910318
  45887   "^DD",7410 00,741000, 26.07,0)
  45888   WC CARRIER  PHONE^F^^ 26;7^K:$L( X)>15!($L( X)<1) X
  45889   "^DD",7410 00,741000, 26.07,3)
  45890   Answer mus t be 1-15  characters  in length .
  45891   "^DD",7410 00,741000, 26.07,"DT" )
  45892   2910606
  45893   "^DD",7410 00,741000, 26.08,0)
  45894   WC ACCIDEN T/INJURY D ATE^D^^26; 8^S %DT="E " D ^%DT S  X=Y K:Y<1  X
  45895   "^DD",7410 00,741000, 26.08,3)
  45896   Enter a da te less th an or equa l to TODAY .
  45897   "^DD",7410 00,741000, 26.08,"DT" )
  45898   2910429
  45899   "^DD",7410 00,741000, 26.09,0)
  45900   WORKMANS C OMP AMOUNT ^NJ10,2^^2 6;9^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 99)!(X<0)  X
  45901   "^DD",7410 00,741000, 26.09,3)
  45902   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45903   "^DD",7410 00,741000, 26.09,"DT" )
  45904   2910709
  45905   "^DD",7410 00,741000, 27,0)
  45906   SCANNED OR  MANUAL^S^ 0:SCANNED; 1:MANUAL;^ 9;4^Q
  45907   "^DD",7410 00,741000, 27,"DT")
  45908   2910626
  45909   "^DD",7410 00,741000, 27.01,0)
  45910   OHI BEGIN  DATE^D^^27 ;1^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X
  45911   "^DD",7410 00,741000, 27.01,"DT" )
  45912   2950216
  45913   "^DD",7410 00,741000, 27.02,0)
  45914   OHI END DA TE^D^^27;2 ^S %DT="E"  D ^%DT S  X=Y K:Y<1  X
  45915   "^DD",7410 00,741000, 27.02,"DT" )
  45916   2950216
  45917   "^DD",7410 00,741000, 27.03,0)
  45918   OHI TYPE^P 741002.76' ^CHMDIC(74 1002.76,^2 7;3^Q
  45919   "^DD",7410 00,741000, 27.03,3)
  45920  
  45921   "^DD",7410 00,741000, 27.03,21,0 )
  45922   ^.001^1^1^ 3120410^^^ ^
  45923   "^DD",7410 00,741000, 27.03,21,1 ,0)
  45924    
  45925   "^DD",7410 00,741000, 27.03,"DT" )
  45926   3120410
  45927   "^DD",7410 00,741000, 27.04,0)
  45928   OHI EDIT F LAG^S^0:NO  ASQ;1:TO  ASQ;2:TO E LGQ;^27;4^ Q
  45929   "^DD",7410 00,741000, 27.04,"DT" )
  45930   2950811
  45931   "^DD",7410 00,741000, 27.05,0)
  45932   OHI NAME^F ^^27;5^K:$ L(X)>32!($ L(X)<1) X
  45933   "^DD",7410 00,741000, 27.05,3)
  45934   Answer mus t be 1-32  characters  in length .
  45935   "^DD",7410 00,741000, 27.05,"DT" )
  45936   2950823
  45937   "^DD",7410 00,741000, 28.01,0)
  45938   EMPLOYER N AME^F^^28; 1^K:$L(X)> 30!($L(X)< 1) X
  45939   "^DD",7410 00,741000, 28.01,3)
  45940   Answer mus t be 1-30  characters  in length .
  45941   "^DD",7410 00,741000, 28.02,0)
  45942   EMPLOYER A DDR1^F^^28 ;2^K:$L(X) >50!($L(X) <1) X
  45943   "^DD",7410 00,741000, 28.02,3)
  45944   Answer mus t be 1-50  characters  in length .
  45945   "^DD",7410 00,741000, 28.03,0)
  45946   EMPLOYER A DDR2^F^^28 ;3^K:$L(X) >50!($L(X) <1) X
  45947   "^DD",7410 00,741000, 28.03,3)
  45948   Answer mus t be 1-50  characters  in length .
  45949   "^DD",7410 00,741000, 28.04,0)
  45950   EMPLOYER C ITY^F^^28; 4^K:$L(X)> 25!($L(X)< 1) X
  45951   "^DD",7410 00,741000, 28.04,3)
  45952   Answer mus t be 1-25  characters  in length .
  45953   "^DD",7410 00,741000, 28.05,0)
  45954   EMPLOYER S TATE^P5'^D IC(5,^28;5 ^Q
  45955   "^DD",7410 00,741000, 28.06,0)
  45956   EMPLOYER Z IP^NJ9,0X^ ^28;6^K:(X '?5N)&(X'? 9N) X
  45957   "^DD",7410 00,741000, 28.06,3)
  45958   Enter a 5  or 9 digit  zip code.
  45959   "^DD",7410 00,741000, 28.06,"DT" )
  45960   2910318
  45961   "^DD",7410 00,741000, 28.07,0)
  45962   EMPLOYER P HONE^NJ10, 0^^28;7^K: +X'=X!(X>9 999999999) !(X<0)!(X? .E1"."1N.N ) X
  45963   "^DD",7410 00,741000, 28.07,3)
  45964   Type a Num ber betwee n 0 and 99 99999999,  0 Decimal  Digits
  45965   "^DD",7410 00,741000, 30.01,0)
  45966   DATE/TIME  EDITED^741 000.7D^^ED IT;0
  45967   "^DD",7410 00,741000, 40,0)
  45968   EOB-CLAIMS ^741000.40 01P^^EOB-C LAIMS;0
  45969   "^DD",7410 00,741000, 41,0)
  45970   EOB-CATCAP P/DEDUCTIB LE^741000. 4101D^^EOB -CAT/DED;0
  45971   "^DD",7410 00,741000, 42,0)
  45972   EOB-CLAIMS /PROV^7410 00.4201P^^ EOB-CLAIMS /PROV;0
  45973   "^DD",7410 00,741000, 100,0)
  45974   EPISODE OF  CARE^NJ5, 0^^A-EOC;1 ^K:+X'=X!( X>99999)!( X<0)!(X?.E 1"."1N.N)  X
  45975   "^DD",7410 00,741000, 100,3)
  45976   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  45977   "^DD",7410 00,741000, 102,0)
  45978   HAC RETURN ED CHECKS^ 741000.010 2A^^102;0
  45979   "^DD",7410 00,741000, 110,0)
  45980   MISSING DA TA INFORMA TION^74100 0.01SA^^AD D;0
  45981   "^DD",7410 00,741000, 110,"DT")
  45982   2910123
  45983   "^DD",7410 00,741000, 120.01,0)
  45984   TOTAL CHAR GES BILLED ^NJ10,2^^C OMMON;1^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999999)!(X <0) X
  45985   "^DD",7410 00,741000, 120.01,3)
  45986   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45987   "^DD",7410 00,741000, 120.02,0)
  45988   PLACE OF S ERVICE^P74 1002.11'^C HMDIC(7410 02.11,^COM MON;2^Q
  45989   "^DD",7410 00,741000, 120.03,0)
  45990   PAYMENTS^N J10,2^^COM MON;3^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 9999)!(X<0 ) X
  45991   "^DD",7410 00,741000, 120.03,3)
  45992   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  45993   "^DD",7410 00,741000, 120.04,0)
  45994   PRESCRIBIN G PHYSICIA N^F^^COMMO N;4^K:$L(X )>30!($L(X )<1) X
  45995   "^DD",7410 00,741000, 120.04,3)
  45996   Answer mus t be 1-30  characters  in length .
  45997   "^DD",7410 00,741000, 120.05,0)
  45998   REFERRING  PHYSICIAN^ F^^COMMON; 5^K:$L(X)> 30!($L(X)< 1) X
  45999   "^DD",7410 00,741000, 120.05,3)
  46000   Answer mus t be 1-30  characters  in length .
  46001   "^DD",7410 00,741000, 120.06,0)
  46002   DAYS OR UN ITS^F^^COM MON;6^K:$L (X)>20!($L (X)<1) X
  46003   "^DD",7410 00,741000, 120.06,3)
  46004   Answer mus t be 1-20  characters  in length .
  46005   "^DD",7410 00,741000, 120.07,0)
  46006   CALC ALLOW ABLE AMT^N J11,2^^COM MON;7^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 99999)!(X< 0) X
  46007   "^DD",7410 00,741000, 120.07,3)
  46008   Type a dol lar amount  between 0  and 99999 999, 2 dec imal digit s.
  46009   "^DD",7410 00,741000, 120.07,"DT ")
  46010   3140310
  46011   "^DD",7410 00,741000, 120.08,0)
  46012   DRG ASSIGN ED ^NJ4,0^ ^COMMON;8^ K:+X'=X!(X >9999)!(X< 0)!(X?.E1" ."1N.N) X
  46013   "^DD",7410 00,741000, 120.08,3)
  46014   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  46015   "^DD",7410 00,741000, 120.08,"DT ")
  46016   2901012
  46017   "^DD",7410 00,741000, 120.09,0)
  46018   DRG COVERA GE CODE^S^ 0:REJECT;1 :ACCEPT;2: QA ACCEPT; 3:MISSING  DATA;4:QA  REJECT;5:G RP REJECT  FOR POA;^C OMMON;9^Q
  46019   "^DD",7410 00,741000, 120.09,"DT ")
  46020   3110112
  46021   "^DD",7410 00,741000, 120.1,0)
  46022   AI REASON^ P741002.22 '^CHMDIC(7 41002.22,^ COMMON;10^ Q
  46023   "^DD",7410 00,741000, 120.1,3)
  46024  
  46025   "^DD",7410 00,741000, 120.1,"DT" )
  46026   2901106
  46027   "^DD",7410 00,741000, 120.11,0)
  46028   RULE FAILU RE^F^^COMM ON;11^K:$L (X)>50!($L (X)<1) X
  46029   "^DD",7410 00,741000, 120.11,3)
  46030   Answer mus t be 1-50  characters  in length .
  46031   "^DD",7410 00,741000, 120.11,"DT ")
  46032   2901012
  46033   "^DD",7410 00,741000, 120.12,0)
  46034   DRG BASE A MT^NJ11,2^ ^COMMON;12 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>99999999 )!(X<0) X
  46035   "^DD",7410 00,741000, 120.12,3)
  46036   Type a Dol lar Amount  between 0  and 99999 999, 2 Dec imal Digit s
  46037   "^DD",7410 00,741000, 120.12,"DT ")
  46038   3110315
  46039   "^DD",7410 00,741000, 120.13,0)
  46040   TRANSFER O UTLIER AMT ^NJ8,2^^CO MMON;13^S: X["$" X=$P (X,"$",2)  K:X'?."-". N.1".".2N! (X>99999)! (X<-99999)  X
  46041   "^DD",7410 00,741000, 120.13,3)
  46042   Type a Dol lar Amount  between - 99999 and  99999, 2 D ecimal Dig its
  46043   "^DD",7410 00,741000, 120.13,"DT ")
  46044   3110315
  46045   "^DD",7410 00,741000, 120.14,0)
  46046   COST OUTLI ER AMT^NJ8 ,2^^COMMON ;14^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 )!(X<0) X
  46047   "^DD",7410 00,741000, 120.14,3)
  46048   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  46049   "^DD",7410 00,741000, 120.14,"DT ")
  46050   3110315
  46051   "^DD",7410 00,741000, 120.15,0)
  46052   STAY OUTLI ER AMT^NJ8 ,2^^COMMON ;15^S:X["$ " X=$P(X," $",2) K:X' ?."-".N.1" .".2N!(X>9 9999)!(X<- 99999) X
  46053   "^DD",7410 00,741000, 120.15,3)
  46054   Type a Dol lar Amount  between - 99999 and  99999, 2 D ecimal Dig its
  46055   "^DD",7410 00,741000, 120.15,"DT ")
  46056   3110315
  46057   "^DD",7410 00,741000, 120.16,0)
  46058   CALCULATIO N METHOD U SED^S^0:IN PATIENT PP S;1:COST-T O-CHARGE;2 :INPATIENT  ITEMIZED; 3:IP LOW V OL MH;4:IP  HIGH VOL  MH;5:OUTPA TIENT;6:PH ARMACY;7:D ENTAL;8:DM E;9:ASC;10 :RTC;^COMM ON;16^Q
  46059   "^DD",7410 00,741000, 120.16,"DT ")
  46060   2950508
  46061   "^DD",7410 00,741000, 120.17,0)
  46062   RTC PER DI EM^NJ8,2^^ COMMON;17^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >99999)!(X <0) X
  46063   "^DD",7410 00,741000, 120.17,3)
  46064   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  46065   "^DD",7410 00,741000, 120.17,"DT ")
  46066   2950508
  46067   "^DD",7410 00,741000, 120.18,0)
  46068   AUTO DISTR IBUTION^S^ 1:YES;0:NO ;^COMMON;1 8^Q
  46069   "^DD",7410 00,741000, 120.18,"DT ")
  46070   3140317
  46071   "^DD",7410 00,741000, 120.7,0)
  46072   CALCULATED  ALLOWABLE  AMOUNT^NJ 11,2^^COMM ON;7^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9999)!(X<0 ) X
  46073   "^DD",7410 00,741000, 120.7,3)
  46074   Type a Dol lar Amount  between 0  and 99999 999, 2 Dec imal Digit s
  46075   "^DD",7410 00,741000, 120.7,"DT" )
  46076   2900914
  46077   "^DD",7410 00,741000, 130.01,0)
  46078   DENTAL PRO CEDURE^741 000.02P^^D EN-PROC;0
  46079   "^DD",7410 00,741000, 130.02,0)
  46080   DENTAL DIA GNOSIS^741 000.12P^^D EN-DX;0
  46081   "^DD",7410 00,741000, 140.01,0)
  46082   DME DELIVE RY CHARGES ^NJ10,2^^D ME;1^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 999)!(X<0)  X
  46083   "^DD",7410 00,741000, 140.01,3)
  46084   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  46085   "^DD",7410 00,741000, 140.02,0)
  46086   DME DELIVE RY ALLOWAB LE AMOUNT^ NJ9,2^^DME ;2^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 )!(X<0) X
  46087   "^DD",7410 00,741000, 140.02,3)
  46088   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  46089   "^DD",7410 00,741000, 140.02,"DT ")
  46090   2910222
  46091   "^DD",7410 00,741000, 141,0)
  46092   DIAGNOSIS  REQUIRING  DME^741000 .0141P^^DM E-DX;0
  46093   "^DD",7410 00,741000, 142,0)
  46094   DME SUPPLY  CODE^7410 00.0142P^^ DME-SUPPLY ;0
  46095   "^DD",7410 00,741000, 150.01,0)
  46096   DISCHARGE  DATE^RDX^^ INP;1^S %D T="E" D ^% DT S X=Y K :Y<1 X I X <$P(^CHMPA Y(DA,0),U, 8) W !!,"D ischarge D ate must b e after Ad mission Da te.",! S F L=1
  46097   "^DD",7410 00,741000, 150.01,3)
  46098  
  46099   "^DD",7410 00,741000, 150.01,4)
  46100  
  46101   "^DD",7410 00,741000, 150.01,"DT ")
  46102   2910207
  46103   "^DD",7410 00,741000, 150.02,0)
  46104   DISCHARGE  STATUS^P74 1002.12^CH MDIC(74100 2.12,^INP; 2^Q
  46105   "^DD",7410 00,741000, 150.03,0)
  46106   ADMITTING  DIAGNOSIS^ P741006.05 '^CHMICDX( ^INP;3^Q
  46107   "^DD",7410 00,741000, 150.03,"DT ")
  46108   2901025
  46109   "^DD",7410 00,741000, 150.04,0)
  46110   DISCHARGIN G PHYSICIA N^F^^INP;4 ^K:$L(X)>3 0!($L(X)<1 ) X
  46111   "^DD",7410 00,741000, 150.04,3)
  46112   Answer mus t be 1-30  characters  in length .
  46113   "^DD",7410 00,741000, 150.05,0)
  46114   ELIGIBILIT Y END DURI NG STAY^S^ 1:YES;0:NO ;^INP;5^Q
  46115   "^DD",7410 00,741000, 150.06,0)
  46116   ELIGIBILIT Y END DATE ^D^^INP;6^ S %DT="E"  D ^%DT S X =Y K:Y<1 X
  46117   "^DD",7410 00,741000, 150.07,0)
  46118   FAC TYPE D ISCHARGED  TO^P741002 .11'^CHMDI C(741002.1 1,^INP;7^Q
  46119   "^DD",7410 00,741000, 150.08,0)
  46120   ELIGIBILIT Y BEGUN DU RING STAY^ S^1:YES;0: NO;^INP;8^ Q
  46121   "^DD",7410 00,741000, 150.08,"DT ")
  46122   2910508
  46123   "^DD",7410 00,741000, 150.09,0)
  46124   ELIGIBILIT Y BEGUN DA TE^D^^INP; 9^S %DT="E " D ^%DT S  X=Y K:Y<1  X
  46125   "^DD",7410 00,741000, 150.09,"DT ")
  46126   2910508
  46127   "^DD",7410 00,741000, 150.1,0)
  46128   ADJUSTED A LLOWABLE A MOUNT^NJ12 ,2^^INP;10 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>99999999 9)!(X<0) X
  46129   "^DD",7410 00,741000, 150.1,3)
  46130   Type a Dol lar Amount  between 0  and 99999 9999, 2 De cimal Digi ts
  46131   "^DD",7410 00,741000, 150.1,"DT" )
  46132   2950313
  46133   "^DD",7410 00,741000, 150.11,0)
  46134   ADJUSTED A LLOWABLE D UZ^P200'^V A(200,^INP ;11^Q
  46135   "^DD",7410 00,741000, 150.11,"DT ")
  46136   2950313
  46137   "^DD",7410 00,741000, 150.12,0)
  46138   ADJUSTED A LLOWABLE D ATE/TIME^D ^^INP;12^S  %DT="EST"  D ^%DT S  X=Y K:Y<1  X
  46139   "^DD",7410 00,741000, 150.12,"DT ")
  46140   2950313
  46141   "^DD",7410 00,741000, 150.13,0)
  46142   ADMISSION  DATE^D^^IN P;13^S %DT ="E" D ^%D T S X=Y K: Y<1 X
  46143   "^DD",7410 00,741000, 150.13,"DT ")
  46144   2970915
  46145   "^DD",7410 00,741000, 150.14,0)
  46146   ADMISSION  TIME^NJ2,0 ^^INP;14^K :+X'=X!(X> 99)!(X<0)! (X?.E1"."1 N.N) X
  46147   "^DD",7410 00,741000, 150.14,3)
  46148   Type a Num ber betwee n 0 and 99 , 0 Decima l Digits
  46149   "^DD",7410 00,741000, 150.14,"DT ")
  46150   2970915
  46151   "^DD",7410 00,741000, 150.15,0)
  46152   DISCHARGE  TIME^NJ2,0 ^^INP;15^K :+X'=X!(X> 99)!(X<0)! (X?.E1"."1 N.N) X
  46153   "^DD",7410 00,741000, 150.15,3)
  46154   Type a Num ber betwee n 0 and 99 , 0 Decima l Digits
  46155   "^DD",7410 00,741000, 150.15,"DT ")
  46156   2970915
  46157   "^DD",7410 00,741000, 150.16,0)
  46158   MEDICARE D EDUCTIBLE  CLAIM^S^1: YES;0:NO;^ INP;16^Q
  46159   "^DD",7410 00,741000, 150.16,"DT ")
  46160   2990111
  46161   "^DD",7410 00,741000, 151,0)
  46162   DISCHARGE  DIAGNOSIS^ 741000.015 1P^^INP-DX ;0
  46163   "^DD",7410 00,741000, 152.01,0)
  46164   DATE OF IT EMIZED CHA RGE^741000 .03DA^^INP -ITEM;0
  46165   "^DD",7410 00,741000, 153,0)
  46166   NON-COVERE D/OTHER IT EM^741000. 0153P^^INP -NC;0
  46167   "^DD",7410 00,741000, 154,0)
  46168   PROCEDURES  PERFORMED ^741000.01 54P^^INP-P ROC;0
  46169   "^DD",7410 00,741000, 155,0)
  46170   TYPE OF RO OM^741000. 0155PA^^IN P-ROOM;0
  46171   "^DD",7410 00,741000, 156,0)
  46172   REVENUE CO DE^741000. 0156P^^INP -REV;0
  46173   "^DD",7410 00,741000, 157,0)
  46174   OCCURRENCE  CODE^7410 00.0157P^^ INP-OCCR;0
  46175   "^DD",7410 00,741000, 158,0)
  46176   OCCURRENCE  SPAN CODE ^741000.01 58P^^INP-S PAN;0
  46177   "^DD",7410 00,741000, 160.01,0)
  46178   OUTPATIENT  CLINICIAN ^F^^OPT;1^ K:$L(X)>30 !($L(X)<1)  X
  46179   "^DD",7410 00,741000, 160.01,3)
  46180   Answer mus t be 1-30  characters  in length .
  46181   "^DD",7410 00,741000, 160.02,0)
  46182   REFERRING  CLINICIAN^ F^^OPT;2^K :$L(X)>30! ($L(X)<1)  X
  46183   "^DD",7410 00,741000, 160.02,3)
  46184   Answer mus t be 1-30  characters  in length .
  46185   "^DD",7410 00,741000, 161,0)
  46186   OUTPATIENT  DIAGNOSIS ^741000.01 61P^^OPT-D X;0
  46187   "^DD",7410 00,741000, 162,0)
  46188   OUTPATIENT  SERVICE^7 41000.0162 P^^OPT-PRO C;0
  46189   "^DD",7410 00,741000, 170,0)
  46190   PHARMACY N AME^F^^PHA R;1^K:$L(X )>30!($L(X )<1) X
  46191   "^DD",7410 00,741000, 170,3)
  46192   Answer mus t be 1-30  characters  in length .
  46193   "^DD",7410 00,741000, 170.02,0)
  46194   RX NUMBER^ 741000.05A ^^PHARM;0
  46195   "^DD",7410 00,741000, 170.02,"DT ")
  46196   2910204
  46197   "^DD",7410 00,741000, 180.01,0)
  46198   QUALITY AS SURANCE IN FORMATION^ 741000.07S ^^RULE-QA; 0
  46199   "^DD",7410 00,741000, 200,0)
  46200   COVERAGE C ODE (DX)^7 41000.06SA ^^RULE-DX; 0
  46201   "^DD",7410 00,741000, 203,0)
  46202   COVERAGE C ODE (PHARM )^741000.0 203S^^RULE -PHARM;0
  46203   "^DD",7410 00,741000, 205,0)
  46204   COVERAGE C ODE (PROC, DME)^74100 0.0205SA^^ RULE-PROC; 0
  46205   "^DD",7410 00,741000, 205,"DT")
  46206   2910502
  46207   "^DD",7410 00,741000, 206,0)
  46208   DATE OF HI STORY CHAN GE^741000. 0206DA^^10 1;0
  46209   "^DD",7410 00,741000, 207,0)
  46210   WORK FLOW  STATUS^741 000.0207PA ^^2;0
  46211   "^DD",7410 00,741000, 300.01,0)
  46212   OS AMOUNT  TO BE PAID  ON CLAIM^ NJ10,2^^30 0;1^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 99)!(X<0)  X
  46213   "^DD",7410 00,741000, 300.01,3)
  46214   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  46215   "^DD",7410 00,741000, 300.01,"DT ")
  46216   2910607
  46217   "^DD",7410 00,741000, 300.02,0)
  46218   OS CAPPS/C ALM BATCH  DATE/TIME^ D^^300;2^S  %DT="ESTX R" D ^%DT  S X=Y K:Y< 1 X
  46219   "^DD",7410 00,741000, 300.02,"DT ")
  46220   2910607
  46221   "^DD",7410 00,741000, 300.03,0)
  46222   OS CAPP PA YMENT DIFF ERENTIAL^N J10,2^^300 ;3^S:X["$"  X=$P(X,"$ ",2) K:X'? ."-".N.1". ".2N!(X>99 99999)!(X< -9999999)  X
  46223   "^DD",7410 00,741000, 300.03,3)
  46224   Type a Dol lar Amount  between - 9999999 an d 9999999,  2 Decimal  Digits
  46225   "^DD",7410 00,741000, 300.03,"DT ")
  46226   2910607
  46227   "^DD",7410 00,741000, 300.04,0)
  46228   OS DATE OF  TREASURY  PAYMENT^D^ ^300;4^S % DT="E" D ^ %DT S X=Y  K:Y<1 X
  46229   "^DD",7410 00,741000, 300.04,"DT ")
  46230   2910607
  46231   "^DD",7410 00,741000, 300.05,0)
  46232   OS AMT APP LIED TO DE DUCTIBLE^N J6,2^^300; 5^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>100)!(X <0) X
  46233   "^DD",7410 00,741000, 300.05,3)
  46234   Type a Dol lar Amount  between 0  and 100,  2 Decimal  Digits
  46235   "^DD",7410 00,741000, 300.05,"DT ")
  46236   2910607
  46237   "^DD",7410 00,741000, 300.06,0)
  46238   OS COST SH ARE AMOUNT ^NJ9,2^^30 0;6^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 9)!(X<0) X
  46239   "^DD",7410 00,741000, 300.06,3)
  46240   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  46241   "^DD",7410 00,741000, 300.06,"DT ")
  46242   2910607
  46243   "^DD",7410 00,741000, 300.07,0)
  46244   OS AMOUNT  PAID BY OT HER INS^NJ 9,2^^300;7 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>999999)! (X<0) X
  46245   "^DD",7410 00,741000, 300.07,3)
  46246   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  46247   "^DD",7410 00,741000, 300.07,"DT ")
  46248   2910607
  46249   "^DD",7410 00,741000, 300.08,0)
  46250   OS TOT AMT  CHARGED A LLOW DAYS^ NJ8,2^^300 ;8^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>99999) !(X<0) X
  46251   "^DD",7410 00,741000, 300.08,3)
  46252   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  46253   "^DD",7410 00,741000, 300.08,"DT ")
  46254   2910607
  46255   "^DD",7410 00,741000, 300.09,0)
  46256   OS AMT PAI D BY OHI A LLOW DAYS^ NJ8,2^^300 ;9^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>99999) !(X<0) X
  46257   "^DD",7410 00,741000, 300.09,3)
  46258   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  46259   "^DD",7410 00,741000, 300.09,"DT ")
  46260   2910607
  46261   "^DD",7410 00,741000, 300.1,0)
  46262   OS OTH INS  AMT PD FO R FACIL^NJ 8,2^^300;1 0^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>99999)! (X<0) X
  46263   "^DD",7410 00,741000, 300.1,3)
  46264   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  46265   "^DD",7410 00,741000, 300.1,"DT" )
  46266   2910607
  46267   "^DD",7410 00,741000, 300.11,0)
  46268   OS MENTAL  HEALTH ALL OW DAYS^NJ 3,0^^300;1 1^K:+X'=X! (X>999)!(X <0)!(X?.E1 "."1N.N) X
  46269   "^DD",7410 00,741000, 300.11,3)
  46270   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  46271   "^DD",7410 00,741000, 300.11,"DT ")
  46272   2910607
  46273   "^DD",7410 00,741000, 300.12,0)
  46274   OS ALCOHOL  ALLOWABLE  DAYS^NJ3, 0^^300;12^ K:+X'=X!(X >999)!(X<0 )!(X?.E1". "1N.N) X
  46275   "^DD",7410 00,741000, 300.12,3)
  46276   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  46277   "^DD",7410 00,741000, 300.12,"DT ")
  46278   2910607
  46279   "^DD",7410 00,741000, 300.13,0)
  46280   OS CAPPS/C ALM ACC/RE J STATUS^S ^0:REJECTE D;1:ACCEPT ED;^300;13 ^Q
  46281   "^DD",7410 00,741000, 300.13,"DT ")
  46282   2910607
  46283   "^DD",7410 00,741000, 300.14,0)
  46284   OS AMT PAI D TO VENDO R^NJ10,2^^ 300;14^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 99999)!(X< 0) X
  46285   "^DD",7410 00,741000, 300.14,3)
  46286   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  46287   "^DD",7410 00,741000, 300.14,"DT ")
  46288   2910607
  46289   "^DD",7410 00,741000, 300.15,0)
  46290   OS AMT PAI D TO BENE^ NJ9,2^^300 ;15^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 9)!(X<0) X
  46291   "^DD",7410 00,741000, 300.15,3)
  46292   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  46293   "^DD",7410 00,741000, 300.15,"DT ")
  46294   2910607
  46295   "^DD",7410 00,741000, 302.01,0)
  46296   OS TOTAL C HARGES BIL LED^NJ10,2 ^^302;1^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999999)!(X <0) X
  46297   "^DD",7410 00,741000, 302.01,3)
  46298   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  46299   "^DD",7410 00,741000, 302.01,"DT ")
  46300   2910607
  46301   "^DD",7410 00,741000, 302.02,0)
  46302   OS PLACE O F SERVICE^ P741002.11 '^CHMDIC(7 41002.11,^ 302;2^Q
  46303   "^DD",7410 00,741000, 302.02,"DT ")
  46304   2910607
  46305   "^DD",7410 00,741000, 302.03,0)
  46306   OS PAYMENT S^NJ10,2^^ 302;3^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 9999)!(X<0 ) X
  46307   "^DD",7410 00,741000, 302.03,3)
  46308   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  46309   "^DD",7410 00,741000, 302.03,"DT ")
  46310   2910607
  46311   "^DD",7410 00,741000, 302.04,0)
  46312   OS PRESCRI BING PHYSI CIAN^F^^30 2;4^K:$L(X )>30!($L(X )<1) X
  46313   "^DD",7410 00,741000, 302.04,3)
  46314   Answer mus t be 1-30  characters  in length .
  46315   "^DD",7410 00,741000, 302.04,"DT ")
  46316   2910607
  46317   "^DD",7410 00,741000, 302.05,0)
  46318   OS REFERRI NG PHYSICI AN^F^^302; 5^K:$L(X)> 30!($L(X)< 1) X
  46319   "^DD",7410 00,741000, 302.05,3)
  46320   Answer mus t be 1-30  characters  in length .
  46321   "^DD",7410 00,741000, 302.05,"DT ")
  46322   2910607
  46323   "^DD",7410 00,741000, 302.06,0)
  46324   OS DAYS OR  UNITS^F^^ 302;6^K:$L (X)>20!($L (X)<1) X
  46325   "^DD",7410 00,741000, 302.06,3)
  46326   Answer mus t be 1-20  characters  in length .
  46327   "^DD",7410 00,741000, 302.06,"DT ")
  46328   2910607
  46329   "^DD",7410 00,741000, 302.07,0)
  46330   OS CALCULA TED ALLOWA BLE AMOUNT ^NJ11,2^^3 02;7^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9999)!(X<0 ) X
  46331   "^DD",7410 00,741000, 302.07,3)
  46332   Type a Dol lar Amount  between 0  and 99999 999, 2 Dec imal Digit s
  46333   "^DD",7410 00,741000, 302.07,"DT ")
  46334   2910607
  46335   "^DD",7410 00,741000, 302.08,0)
  46336   OS DRG ASS IGNED^NJ4, 0^^302;8^K :+X'=X!(X> 9999)!(X<0 )!(X?.E1". "1N.N) X
  46337   "^DD",7410 00,741000, 302.08,3)
  46338   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  46339   "^DD",7410 00,741000, 302.08,"DT ")
  46340   2910607
  46341   "^DD",7410 00,741000, 302.09,0)
  46342   OS DRG COV ERAGE CODE ^S^0:REJEC T;1:ACCEPT ;2:QA ACCE PT;3:MISSI NG DATA;4: QA REJECT; ^302;9^Q
  46343   "^DD",7410 00,741000, 302.09,"DT ")
  46344   2910607
  46345   "^DD",7410 00,741000, 302.1,0)
  46346   OS AI REAS ON^P741002 .22'^CHMDI C(741002.2 2,^302;10^ Q
  46347   "^DD",7410 00,741000, 302.1,"DT" )
  46348   2910607
  46349   "^DD",7410 00,741000, 302.11,0)
  46350   OS RULE FA ILURE^F^^3 02;11^K:$L (X)>50!($L (X)<1) X
  46351   "^DD",7410 00,741000, 302.11,3)
  46352   Answer mus t be 1-50  characters  in length .
  46353   "^DD",7410 00,741000, 302.11,"DT ")
  46354   2910607
  46355   "^DD",7410 00,741000, 302.12,0)
  46356   OS DRG BAS E AMOUNT^N J11,2^^302 ;12^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 999)!(X<0)  X
  46357   "^DD",7410 00,741000, 302.12,3)
  46358   Type a Dol lar Amount  between 0  and 99999 999, 2 Dec imal Digit s
  46359   "^DD",7410 00,741000, 302.12,"DT ")
  46360   2910607
  46361   "^DD",7410 00,741000, 302.13,0)
  46362   OS TRANSFE R OUTLIER  AMOUNT^NJ8 ,2^^302;13 ^S:X["$" X =$P(X,"$", 2) K:X'?." -".N.1".". 2N!(X>9999 9)!(X<-999 99) X
  46363   "^DD",7410 00,741000, 302.13,3)
  46364   Type a Dol lar Amount  between - 99999 and  99999, 2 D ecimal Dig its
  46365   "^DD",7410 00,741000, 302.13,"DT ")
  46366   2910607
  46367   "^DD",7410 00,741000, 302.14,0)
  46368   OS COST OU TLIER AMOU NT^NJ8,2^^ 302;14^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 999)!(X<0)  X
  46369   "^DD",7410 00,741000, 302.14,3)
  46370   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  46371   "^DD",7410 00,741000, 302.14,"DT ")
  46372   2910607
  46373   "^DD",7410 00,741000, 302.15,0)
  46374   OS STAY OU TLIER AMOU NT^NJ8,2^^ 302;15^S:X ["$" X=$P( X,"$",2) K :X'?."-".N .1".".2N!( X>99999)!( X<-99999)  X
  46375   "^DD",7410 00,741000, 302.15,3)
  46376   Type a Dol lar Amount  between - 99999 and  99999, 2 D ecimal Dig its
  46377   "^DD",7410 00,741000, 302.15,"DT ")
  46378   2910607
  46379   "^DD",7410 00,741000, 400.01,0)
  46380   VENDOR NAM E^F^^ZIMAG E;1^K:$L(X )>30!($L(X )<3) X
  46381   "^DD",7410 00,741000, 400.01,3)
  46382   Answer mus t be 3-30  characters  in length .
  46383   "^DD",7410 00,741000, 400.01,"DT ")
  46384   2930506
  46385   "^DD",7410 00,741000, 400.02,0)
  46386   VENDOR TAX  ID^F^^ZIM AGE;2^K:$L (X)>9!($L( X)<9) X
  46387   "^DD",7410 00,741000, 400.02,3)
  46388   Answer mus t be 9 cha racters in  length.
  46389   "^DD",7410 00,741000, 400.02,"DT ")
  46390   2930506
  46391   "^DD",7410 00,741000, 400.03,0)
  46392   SSN^F^^ZIM AGE;3^K:$L (X)>9!($L( X)<9) X
  46393   "^DD",7410 00,741000, 400.03,3)
  46394   Answer mus t be 9 cha racters in  length.
  46395   "^DD",7410 00,741000, 400.03,"DT ")
  46396   2930506
  46397   "^DD",7410 00,741000, 400.04,0)
  46398   ADDRESS LI NE 1^F^^ZI MAGE;4^K:$ L(X)>30!($ L(X)<3) X
  46399   "^DD",7410 00,741000, 400.04,3)
  46400   Answer mus t be 3-30  characters  in length .
  46401   "^DD",7410 00,741000, 400.04,"DT ")
  46402   2930506
  46403   "^DD",7410 00,741000, 400.05,0)
  46404   ADDRESS LI NE 2^F^^ZI MAGE;5^K:$ L(X)>30!($ L(X)<3) X
  46405   "^DD",7410 00,741000, 400.05,3)
  46406   Answer mus t be 3-30  characters  in length .
  46407   "^DD",7410 00,741000, 400.05,"DT ")
  46408   2930506
  46409   "^DD",7410 00,741000, 400.06,0)
  46410   CITY^F^^ZI MAGE;6^K:$ L(X)>30!($ L(X)<3) X
  46411   "^DD",7410 00,741000, 400.06,3)
  46412   Answer mus t be 3-30  characters  in length .
  46413   "^DD",7410 00,741000, 400.06,"DT ")
  46414   2930506
  46415   "^DD",7410 00,741000, 400.07,0)
  46416   STATE^P5'^ DIC(5,^ZIM AGE;7^Q
  46417   "^DD",7410 00,741000, 400.07,"DT ")
  46418   2930506
  46419   "^DD",7410 00,741000, 400.08,0)
  46420   ZIP CODE^F ^^ZIMAGE;8 ^K:$L(X)>1 0!($L(X)<5 ) X
  46421   "^DD",7410 00,741000, 400.08,3)
  46422   Answer mus t be 5-10  characters  in length .
  46423   "^DD",7410 00,741000, 400.08,"DT ")
  46424   3170511
  46425   "^DD",7410 00,741000, 400.09,0)
  46426   PHONE^F^^Z IMAGE;9^K: $L(X)>30!( $L(X)<3) X
  46427   "^DD",7410 00,741000, 400.09,3)
  46428   Answer mus t be 3-30  characters  in length .
  46429   "^DD",7410 00,741000, 400.09,"DT ")
  46430   2930506
  46431   "^DD",7410 00,741000, 400.1,0)
  46432   FACILITY T YPE^P74100 2.11'^CHMD IC(741002. 11,^ZIMAGE ;10^Q
  46433   "^DD",7410 00,741000, 400.1,"DT" )
  46434   3110913
  46435   "^DD",7410 00,741000, 400.11,0)
  46436   CLASSIFICA TION TYPE^ S^N:NATURA L (Medical  Provider) ;O:OTHER ( Non Medica l Provider );^ZIMAGE; 11^Q
  46437   "^DD",7410 00,741000, 400.11,"DT ")
  46438   2930506
  46439   "^DD",7410 00,741000, 400.12,0)
  46440   SPECIALTY^ P741002.26 '^CHMDIC(7 41002.26,^ ZIMAGE;12^ Q
  46441   "^DD",7410 00,741000, 400.12,"DT ")
  46442   3120417
  46443   "^DD",7410 00,741000, 400.13,0)
  46444   AUSTIN VER IFY FLAG^S ^0:NO;1:YE S;^ZIMAGE; 13^Q
  46445   "^DD",7410 00,741000, 400.13,"DT ")
  46446   2930506
  46447   "^DD",7410 00,741000, 400.14,0)
  46448   ADMIN SUSP ENSION FLA G^S^0:NO;1 :YES;^ZIMA GE;14^Q
  46449   "^DD",7410 00,741000, 400.14,"DT ")
  46450   2930506
  46451   "^DD",7410 00,741000, 400.15,0)
  46452   DISCRETE P SYCH FLAG^ S^0:NO;1:Y ES;^ZIMAGE ;15^Q
  46453   "^DD",7410 00,741000, 400.15,"DT ")
  46454   2930506
  46455   "^DD",7410 00,741000, 400.16,0)
  46456   DISCRETE R EHAB FLAG^ S^0:NO;1:Y ES;^ZIMAGE ;16^Q
  46457   "^DD",7410 00,741000, 400.16,"DT ")
  46458   2930506
  46459   "^DD",7410 00,741000, 400.17,0)
  46460   DISCRETE R TC FLAG^S^ 0:NO;1:YES ;^ZIMAGE;1 7^Q
  46461   "^DD",7410 00,741000, 400.17,"DT ")
  46462   2930506
  46463   "^DD",7410 00,741000, 400.18,0)
  46464   NON PPS FL AG^S^0:NO; 1:YES;^ZIM AGE;18^Q
  46465   "^DD",7410 00,741000, 400.18,"DT ")
  46466   2930506
  46467   "^DD",7410 00,741000, 400.19,0)
  46468   CMAC CLASS  CODE^S^1: PHYSICIAN; 2:CLINICAL  PSYCHOLOG IST;3:ALL  OTHERS;^ZI MAGE;19^Q
  46469   "^DD",7410 00,741000, 400.19,"DT ")
  46470   2930506
  46471   "^DD",7410 00,741000, 600,0)
  46472   CMAC PROCE SSING DATE ^741000.11 D^^ZCMAC-P D;0
  46473   "^DD",7410 00,741000, 700,0)
  46474   CORRESPOND ENCE DATE  TIME^74100 0.13D^^COR R;0
  46475   "^DD",7410 00,741000, 800,0)
  46476   REMIT-TO N AME^F^^VEN -II;1^K:$L (X)>30!($L (X)<3) X
  46477   "^DD",7410 00,741000, 800,3)
  46478   Answer mus t be 3-30  characters  in length .
  46479   "^DD",7410 00,741000, 800,"DT")
  46480   3110913
  46481   "^DD",7410 00,741000, 800.01,0)
  46482   TAX ID #^F ^^VEN-II;2 ^K:$L(X)>9 !($L(X)<9)  X
  46483   "^DD",7410 00,741000, 800.01,3)
  46484   Answer mus t be 9 cha racters in  length.
  46485   "^DD",7410 00,741000, 800.01,"DT ")
  46486   3110913
  46487   "^DD",7410 00,741000, 800.02,0)
  46488   PROVIDER A DDRESS LN  1^F^^VEN-I I;3^K:$L(X )>30!($L(X )<1) X
  46489   "^DD",7410 00,741000, 800.02,3)
  46490   Answer mus t be 1-30  characters  in length .
  46491   "^DD",7410 00,741000, 800.02,"DT ")
  46492   3110913
  46493   "^DD",7410 00,741000, 800.03,0)
  46494   PROVIDER A DDRESS LN  2^F^^VEN-I I;4^K:$L(X )>30!($L(X )<1) X
  46495   "^DD",7410 00,741000, 800.03,3)
  46496   Answer mus t be 1-30  characters  in length .
  46497   "^DD",7410 00,741000, 800.03,"DT ")
  46498   3110913
  46499   "^DD",7410 00,741000, 800.04,0)
  46500   PROVIDER C ITY^F^^VEN -II;5^K:$L (X)>30!($L (X)<1) X
  46501   "^DD",7410 00,741000, 800.04,3)
  46502   Answer mus t be 1-30  characters  in length .
  46503   "^DD",7410 00,741000, 800.04,"DT ")
  46504   3110913
  46505   "^DD",7410 00,741000, 800.05,0)
  46506   PROVIDER S TATE^P5'^D IC(5,^VEN- II;6^Q
  46507   "^DD",7410 00,741000, 800.05,"DT ")
  46508   3110913
  46509   "^DD",7410 00,741000, 800.06,0)
  46510   PROVIDER Z IP^F^^VEN- II;7^K:$L( X)>10!($L( X)<5) X
  46511   "^DD",7410 00,741000, 800.06,3)
  46512   Answer mus t be 5-10  characters  in length .
  46513   "^DD",7410 00,741000, 800.06,"DT ")
  46514   3110913
  46515   "^DD",7410 00,741000, 800.07,0)
  46516   PROVIDER P H NUM^F^^V EN-II;8^K: $L(X)>30!( $L(X)<7) X
  46517   "^DD",7410 00,741000, 800.07,3)
  46518   Answer mus t be 7-30  characters  in length .
  46519   "^DD",7410 00,741000, 800.07,"DT ")
  46520   3110913
  46521   "^DD",7410 00,741000, 800.08,0)
  46522   VENDOR FAC ILITY TYPE ^P741002.1 1'^CHMDIC( 741002.11, ^VEN-II;9^ Q
  46523   "^DD",7410 00,741000, 800.08,"DT ")
  46524   3110913
  46525   "^DD",7410 00,741000, 800.09,0)
  46526   VENDOR SPE CIALTY^P74 1002.26'^C HMDIC(7410 02.26,^VEN -II;10^Q
  46527   "^DD",7410 00,741000, 800.09,"DT ")
  46528   3110913
  46529   "^DD",7410 00,741000, 800.1,0)
  46530   PROVIDER A DDRESS LN  3 ^F^^VEN- II;11^K:$L (X)>30!($L (X)<1) X
  46531   "^DD",7410 00,741000, 800.1,3)
  46532   Answer mus t be 1-30  characters  in length .
  46533   "^DD",7410 00,741000, 800.1,"DT" )
  46534   3111111
  46535   "^DD",7410 00,741000, 800.105,0)
  46536   PL ZIP^FJ1 0^^VEN-II; 15^K:$L(X) >10!($L(X) <5) X
  46537   "^DD",7410 00,741000, 800.105,1, 0)
  46538   ^.1
  46539   "^DD",7410 00,741000, 800.105,1, 1,0)
  46540   741000^F
  46541   "^DD",7410 00,741000, 800.105,1, 1,1)
  46542   S ^CHMPAY( "F",$E(X,1 ,30),DA)=" "
  46543   "^DD",7410 00,741000, 800.105,1, 1,2)
  46544   K ^CHMPAY( "F",$E(X,1 ,30),DA)
  46545   "^DD",7410 00,741000, 800.105,1, 1,"DT")
  46546   3170518
  46547   "^DD",7410 00,741000, 800.105,3)
  46548   Answer mus t be 5-10  characters  in length .
  46549   "^DD",7410 00,741000, 800.105,"D T")
  46550   3170620
  46551   "^DD",7410 00,741000, 800.11,0)
  46552   CMAC CLASS  CODE^S^1: PHYSICIAN; 2:CLINICAL  PSYCHOLOG IST;3:ALL  OTHERS;^VE N-II;12^Q
  46553   "^DD",7410 00,741000, 800.11,"DT ")
  46554   3111111
  46555   "^DD",7410 00,741000, 1000,0)
  46556   PDI NUMBER ^741000.04 ^^PDI;0
  46557   "^DD",7410 00,741000, 1001,0)
  46558   DUPE CODE  TYPE^74100 0.01001S^^ RULE-DUP;0
  46559   "^DD",7410 00,741000. 01,0)
  46560   MISSING DA TA INFORMA TION SUB-F IELD^^.06^ 6
  46561   "^DD",7410 00,741000. 01,0,"DT")
  46562   2910123
  46563   "^DD",7410 00,741000. 01,0,"IX", "B",741000 .01,.01)
  46564  
  46565   "^DD",7410 00,741000. 01,0,"NM", "MISSING D ATA INFORM ATION")
  46566  
  46567   "^DD",7410 00,741000. 01,0,"UP")
  46568   741000
  46569   "^DD",7410 00,741000. 01,.01,0)
  46570   CODE TYPE^ S^0:DRG;1: DIAGNOSIS; 2:PROCEDUR E;^0;1^Q
  46571   "^DD",7410 00,741000. 01,.01,1,0 )
  46572   ^.1^^0
  46573   "^DD",7410 00,741000. 01,.01,1,1 ,0)
  46574   741000.01^ B
  46575   "^DD",7410 00,741000. 01,.01,1,1 ,1)
  46576   S ^CHMPAY( DA(1),"ADD ","B",$E(X ,1,30),DA) =""
  46577   "^DD",7410 00,741000. 01,.01,1,1 ,2)
  46578   K ^CHMPAY( DA(1),"ADD ","B",$E(X ,1,30),DA)
  46579   "^DD",7410 00,741000. 01,.01,3)
  46580  
  46581   "^DD",7410 00,741000. 01,.01,"DT ")
  46582   2910212
  46583   "^DD",7410 00,741000. 01,.02,0)
  46584   CODE NUMBE R^F^^0;2^K :$L(X)>15! ($L(X)<1)  X
  46585   "^DD",7410 00,741000. 01,.02,3)
  46586   Answer mus t be 1-15  characters  in length .
  46587   "^DD",7410 00,741000. 01,.02,"DT ")
  46588   2910123
  46589   "^DD",7410 00,741000. 01,.03,0)
  46590   RULE J VAL UE^NJ3,0^^ 0;3^K:+X'= X!(X>999)! (X<1)!(X?. E1"."1N.N)  X
  46591   "^DD",7410 00,741000. 01,.03,3)
  46592   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  46593   "^DD",7410 00,741000. 01,.03,"DT ")
  46594   2910123
  46595   "^DD",7410 00,741000. 01,.04,0)
  46596   TEST RESUL TING IN RE QUEST^NJ4, 0^^0;4^K:+ X'=X!(X>99 99)!(X<1)! (X?.E1"."1 N.N) X
  46597   "^DD",7410 00,741000. 01,.04,3)
  46598   Type a Num ber betwee n 1 and 99 99, 0 Deci mal Digits
  46599   "^DD",7410 00,741000. 01,.04,"DT ")
  46600   2910123
  46601   "^DD",7410 00,741000. 01,.05,0)
  46602   MISSING NO UN NUMBER^ NJ4,0^^0;5 ^K:+X'=X!( X>9999)!(X <1)!(X?.E1 "."1N.N) X
  46603   "^DD",7410 00,741000. 01,.05,3)
  46604   Type a Num ber betwee n 1 and 99 99, 0 Deci mal Digits
  46605   "^DD",7410 00,741000. 01,.05,"DT ")
  46606   2910123
  46607   "^DD",7410 00,741000. 01,.06,0)
  46608   NOUN VALUE (S)^741000 .09A^^NOUN ;0
  46609   "^DD",7410 00,741000. 01001,0)
  46610   DUPE CODE  TYPE SUB-F IELD^^.06^ 6
  46611   "^DD",7410 00,741000. 01001,0,"D T")
  46612   2930625
  46613   "^DD",7410 00,741000. 01001,0,"I X","B",741 000.01001, .01)
  46614  
  46615   "^DD",7410 00,741000. 01001,0,"N M","DUPE C ODE TYPE")
  46616  
  46617   "^DD",7410 00,741000. 01001,0,"U P")
  46618   741000
  46619   "^DD",7410 00,741000. 01001,.01, 0)
  46620   DUPE CODE  TYPE^MS^1: DIAGNOSIS; 2:PROCEDUR E;3:PHARMA CY;^0;1^Q
  46621   "^DD",7410 00,741000. 01001,.01, 1,0)
  46622   ^.1
  46623   "^DD",7410 00,741000. 01001,.01, 1,1,0)
  46624   741000.010 01^B
  46625   "^DD",7410 00,741000. 01001,.01, 1,1,1)
  46626   S ^CHMPAY( DA(1),"RUL E-DUP","B" ,$E(X,1,30 ),DA)=""
  46627   "^DD",7410 00,741000. 01001,.01, 1,1,2)
  46628   K ^CHMPAY( DA(1),"RUL E-DUP","B" ,$E(X,1,30 ),DA)
  46629   "^DD",7410 00,741000. 01001,.01, "DT")
  46630   2930625
  46631   "^DD",7410 00,741000. 01001,.02, 0)
  46632   DUPE CODE^ F^^0;2^K:$ L(X)>15!($ L(X)<1) X
  46633   "^DD",7410 00,741000. 01001,.02, 3)
  46634   Answer mus t be 1-15  characters  in length .
  46635   "^DD",7410 00,741000. 01001,.02, "DT")
  46636   2930610
  46637   "^DD",7410 00,741000. 01001,.03, 0)
  46638   RULE J VAL UE^NJ3,0^^ 0;3^K:+X'= X!(X>999)! (X<1)!(X?. E1"."1N.N)  X
  46639   "^DD",7410 00,741000. 01001,.03, 3)
  46640   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  46641   "^DD",7410 00,741000. 01001,.03, "DT")
  46642   2930610
  46643   "^DD",7410 00,741000. 01001,.04, 0)
  46644   DUZ OF DUP E REVIEW^P 3'^DIC(3,^ 0;4^Q
  46645   "^DD",7410 00,741000. 01001,.04, "DT")
  46646   2930610
  46647   "^DD",7410 00,741000. 01001,.05, 0)
  46648   REASON FOR  REJECTION ^P741002.2 2'^CHMDIC( 741002.22, ^0;5^Q
  46649   "^DD",7410 00,741000. 01001,.05, "DT")
  46650   2930610
  46651   "^DD",7410 00,741000. 01001,.06, 0)
  46652   DUPE RECOM MENDATION^ S^0:REJECT ;1:ACCEPT; ^0;6^Q
  46653   "^DD",7410 00,741000. 01001,.06, "DT")
  46654   2930610
  46655   "^DD",7410 00,741000. 0102,0)
  46656   HAC RETURN ED CHECKS  SUB-FIELD^ ^.08^8
  46657   "^DD",7410 00,741000. 0102,0,"DT ")
  46658   3000119
  46659   "^DD",7410 00,741000. 0102,0,"IX ","B",7410 00.0102,.0 1)
  46660  
  46661   "^DD",7410 00,741000. 0102,0,"NM ","HAC RET URNED CHEC KS")
  46662  
  46663   "^DD",7410 00,741000. 0102,0,"UP ")
  46664   741000
  46665   "^DD",7410 00,741000. 0102,.01,0 )
  46666   HAC RETURN ED CHECKS^ NJ8,0^^0;1 ^K:+X'=X!( X>99999999 )!(X<1)!(X ?.E1"."1N. N) X
  46667   "^DD",7410 00,741000. 0102,.01,1 ,0)
  46668   ^.1
  46669   "^DD",7410 00,741000. 0102,.01,1 ,1,0)
  46670   741000.010 2^B
  46671   "^DD",7410 00,741000. 0102,.01,1 ,1,1)
  46672   S ^CHMPAY( DA(1),102, "B",$E(X,1 ,30),DA)=" "
  46673   "^DD",7410 00,741000. 0102,.01,1 ,1,2)
  46674   K ^CHMPAY( DA(1),102, "B",$E(X,1 ,30),DA)
  46675   "^DD",7410 00,741000. 0102,.01,3 )
  46676   Type a Num ber betwee n 1 and 99 999999, 0  Decimal Di gits
  46677   "^DD",7410 00,741000. 0102,.01," DT")
  46678   2960509
  46679   "^DD",7410 00,741000. 0102,.02,0 )
  46680   DATE OF CH ECK^D^^0;2 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  46681   "^DD",7410 00,741000. 0102,.02," DT")
  46682   2960509
  46683   "^DD",7410 00,741000. 0102,.03,0 )
  46684   CHECK TYPE ^S^B:BENEF ICIARY;V:V ENDOR;^0;3 ^Q
  46685   "^DD",7410 00,741000. 0102,.03," DT")
  46686   2960509
  46687   "^DD",7410 00,741000. 0102,.04,0 )
  46688   CHECK RETU RN FLAG^S^ 0:NO;1:YES ;^0;4^Q
  46689   "^DD",7410 00,741000. 0102,.04," DT")
  46690   2960509
  46691   "^DD",7410 00,741000. 0102,.05,0 )
  46692   DATE CHECK  RETURNED^ D^^0;5^S % DT="EST" D  ^%DT S X= Y K:Y<1 X
  46693   "^DD",7410 00,741000. 0102,.05," DT")
  46694   2960509
  46695   "^DD",7410 00,741000. 0102,.06,0 )
  46696   REASON COD E^P741502' ^CHMDIC(74 1502,^0;6^ Q
  46697   "^DD",7410 00,741000. 0102,.06," DT")
  46698   2960509
  46699   "^DD",7410 00,741000. 0102,.07,0 )
  46700   CHECK REIS SUE USER^P 200'^VA(20 0,^0;7^Q
  46701   "^DD",7410 00,741000. 0102,.07," DT")
  46702   3000119
  46703   "^DD",7410 00,741000. 0102,.08,0 )
  46704   CHECK REIS SUE DATE^D ^^0;8^S %D T="EST" D  ^%DT S X=Y  K:Y<1 X
  46705   "^DD",7410 00,741000. 0102,.08," DT")
  46706   3000119
  46707   "^DD",7410 00,741000. 0141,0)
  46708   DIAGNOSIS  REQUIRING  DME SUB-FI ELD^^.01^1
  46709   "^DD",7410 00,741000. 0141,0,"IX ","B",7410 00.0141,.0 1)
  46710  
  46711   "^DD",7410 00,741000. 0141,0,"NM ","DIAGNOS IS REQUIRI NG DME")
  46712  
  46713   "^DD",7410 00,741000. 0141,0,"UP ")
  46714   741000
  46715   "^DD",7410 00,741000. 0141,.01,0 )
  46716   DIAGNOSIS  REQUIRING  DME^P74100 6.05'^CHMI CDX(^0;1^Q
  46717   "^DD",7410 00,741000. 0141,.01,1 ,0)
  46718   ^.1^^0
  46719   "^DD",7410 00,741000. 0141,.01,1 ,1,0)
  46720   741000.014 1^B
  46721   "^DD",7410 00,741000. 0141,.01,1 ,1,1)
  46722   S ^CHMPAY( DA(1),"DME -DX","B",$ E(X,1,30), DA)=""
  46723   "^DD",7410 00,741000. 0141,.01,1 ,1,2)
  46724   K ^CHMPAY( DA(1),"DME -DX","B",$ E(X,1,30), DA)
  46725   "^DD",7410 00,741000. 0141,.01," DT")
  46726   2901106
  46727   "^DD",7410 00,741000. 0142,0)
  46728   DME SUPPLY  CODE SUB- FIELD^^.12 ^17
  46729   "^DD",7410 00,741000. 0142,0,"DT ")
  46730   3110713
  46731   "^DD",7410 00,741000. 0142,0,"IX ","B",7410 00.0142,.0 1)
  46732  
  46733   "^DD",7410 00,741000. 0142,0,"NM ","DME SUP PLY CODE")
  46734  
  46735   "^DD",7410 00,741000. 0142,0,"UP ")
  46736   741000
  46737   "^DD",7410 00,741000. 0142,.01,0 )
  46738   DME SUPPLY  CODE^P741 006^CHMSER V(^0;1^Q
  46739   "^DD",7410 00,741000. 0142,.01,1 ,0)
  46740   ^.1^^0
  46741   "^DD",7410 00,741000. 0142,.01,1 ,1,0)
  46742   741000.014 2^B
  46743   "^DD",7410 00,741000. 0142,.01,1 ,1,1)
  46744   S ^CHMPAY( DA(1),"DME -SUPPLY"," B",$E(X,1, 30),DA)=""
  46745   "^DD",7410 00,741000. 0142,.01,1 ,1,2)
  46746   K ^CHMPAY( DA(1),"DME -SUPPLY"," B",$E(X,1, 30),DA)
  46747   "^DD",7410 00,741000. 0142,.01," DT")
  46748   2901214
  46749   "^DD",7410 00,741000. 0142,.02,0 )
  46750   SUPPLY CHA RGE^NJ11,2 ^^0;2^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 99999)!(X< 0) X
  46751   "^DD",7410 00,741000. 0142,.02,3 )
  46752   Type a Dol lar Amount  between 0  and 99999 999, 2 Dec imal Digit s
  46753   "^DD",7410 00,741000. 0142,.03,0 )
  46754   PURCHASE/L EASE^S^P:P URCHASE;L: LEASE;^0;3 ^Q
  46755   "^DD",7410 00,741000. 0142,.03," DT")
  46756   2910226
  46757   "^DD",7410 00,741000. 0142,.04,0 )
  46758   DME ALLOWA BLE AMOUNT ^NJ8,2^^0; 4^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>99999)! (X<0) X
  46759   "^DD",7410 00,741000. 0142,.04,3 )
  46760   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  46761   "^DD",7410 00,741000. 0142,.04," DT")
  46762   2910226
  46763   "^DD",7410 00,741000. 0142,.05,0 )
  46764   ADJUSTED A LLOWABLE A MT^NJ9,2^^ 0;5^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 9)!(X<0) X
  46765   "^DD",7410 00,741000. 0142,.05,3 )
  46766   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  46767   "^DD",7410 00,741000. 0142,.05," DT")
  46768   2950223
  46769   "^DD",7410 00,741000. 0142,.06,0 )
  46770   DUZ CHANGI NG ALLOW A MT^P200'^V A(200,^0;6 ^Q
  46771   "^DD",7410 00,741000. 0142,.06," DT")
  46772   2950223
  46773   "^DD",7410 00,741000. 0142,.07,0 )
  46774   DATE/TIME  CHANGE ALL OW AMT^D^^ 0;7^S %DT= "EST" D ^% DT S X=Y K :Y<1 X
  46775   "^DD",7410 00,741000. 0142,.07," DT")
  46776   2950309
  46777   "^DD",7410 00,741000. 0142,.12,0 )
  46778   4TH CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;16^Q
  46779   "^DD",7410 00,741000. 0142,.12," DT")
  46780   3110330
  46781   "^DD",7410 00,741000. 0142,.13,0 )
  46782   1ST CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;13^Q
  46783   "^DD",7410 00,741000. 0142,.13," DT")
  46784   3110330
  46785   "^DD",7410 00,741000. 0142,.14,0 )
  46786   2ND CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;14^Q
  46787   "^DD",7410 00,741000. 0142,.14," DT")
  46788   3110330
  46789   "^DD",7410 00,741000. 0142,.15,0 )
  46790   3RD CPR-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;15^Q
  46791   "^DD",7410 00,741000. 0142,.15," DT")
  46792   3110330
  46793   "^DD",7410 00,741000. 0142,.16,0 )
  46794   REVENUE CO DE (DME FR OM UB92)^P 741201.39' ^CHMXDIC(7 41201.39,^ 0;8^Q
  46795   "^DD",7410 00,741000. 0142,.16," DT")
  46796   3030921
  46797   "^DD",7410 00,741000. 0142,.17,0 )
  46798   EDI ASSOCI ATED LINE  CHARGE^NJ1 5,0^^0;9^K :+X'=X!(X> 9999999999 99999)!(X< 0)!(X?.E1" ."1N.N) X
  46799   "^DD",7410 00,741000. 0142,.17,3 )
  46800   Type a Num ber betwee n 0 and 99 9999999999 999, 0 Dec imal Digit s
  46801   "^DD",7410 00,741000. 0142,.17," DT")
  46802   3030921
  46803   "^DD",7410 00,741000. 0142,.18,0 )
  46804   EDI LINE I DENTIFIER^ NJ5,0^^0;1 0^K:+X'=X! (X>99999)! (X<1)!(X?. E1"."1N.N)  X
  46805   "^DD",7410 00,741000. 0142,.18,3 )
  46806   Type a Num ber betwee n 1 and 99 999, 0 Dec imal Digit s
  46807   "^DD",7410 00,741000. 0142,.18," DT")
  46808   3030921
  46809   "^DD",7410 00,741000. 0142,.19,0 )
  46810   UNITS^NJ10 ,0^^0;11^K :+X'=X!(X> 9999999999 )!(X<0)!(X ?.E1"."1N. N) X
  46811   "^DD",7410 00,741000. 0142,.19,3 )
  46812   Type a Num ber betwee n 0 and 99 99999999,  0 Decimal  Digits
  46813   "^DD",7410 00,741000. 0142,.19," DT")
  46814   3030921
  46815   "^DD",7410 00,741000. 0142,.2,0)
  46816   ORIGINAL P X CODE FOR  LINE^P741 006'^CHMSE RV(^0;12^Q
  46817   "^DD",7410 00,741000. 0142,.2,"D T")
  46818   3030921
  46819   "^DD",7410 00,741000. 0142,.21,0 )
  46820   OHI PAYMEN T AMT^7410 00.0242A^^ 1;0
  46821   "^DD",7410 00,741000. 0142,.21,2 1,0)
  46822   ^^1^1^3110 204^
  46823   "^DD",7410 00,741000. 0142,.21,2 1,1,0)
  46824   LINE LEVEL  OHI DATA  ADDED BY E NC7820
  46825   "^DD",7410 00,741000. 0142,.21,2 3,0)
  46826   ^^1^1^3110 204^
  46827   "^DD",7410 00,741000. 0142,.21,2 3,1,0)
  46828   THIS MULTI PLE WAS AD DED FOR EN C7820
  46829   "^DD",7410 00,741000. 0151,0)
  46830   DISCHARGE  DIAGNOSIS  SUB-FIELD^ ^.03^3
  46831   "^DD",7410 00,741000. 0151,0,"DT ")
  46832   3100125
  46833   "^DD",7410 00,741000. 0151,0,"IX ","B",7410 00.0151,.0 1)
  46834  
  46835   "^DD",7410 00,741000. 0151,0,"NM ","DISCHAR GE DIAGNOS IS")
  46836  
  46837   "^DD",7410 00,741000. 0151,0,"UP ")
  46838   741000
  46839   "^DD",7410 00,741000. 0151,.01,0 )
  46840   DISCHARGE  DIAGNOSIS^ P741006.05 '^CHMICDX( ^0;1^Q
  46841   "^DD",7410 00,741000. 0151,.01,1 ,0)
  46842   ^.1^^0
  46843   "^DD",7410 00,741000. 0151,.01,1 ,1,0)
  46844   741000.015 1^B
  46845   "^DD",7410 00,741000. 0151,.01,1 ,1,1)
  46846   S ^CHMPAY( DA(1),"INP -DX","B",$ E(X,1,30), DA)=""
  46847   "^DD",7410 00,741000. 0151,.01,1 ,1,2)
  46848   K ^CHMPAY( DA(1),"INP -DX","B",$ E(X,1,30), DA)
  46849   "^DD",7410 00,741000. 0151,.01," DT")
  46850   2901106
  46851   "^DD",7410 00,741000. 0151,.02,0 )
  46852   COVERED DI AGNOSIS FL AG^S^1:YES ;0:NO;^0;2 ^Q
  46853   "^DD",7410 00,741000. 0151,.02," DT")
  46854   2900914
  46855   "^DD",7410 00,741000. 0151,.03,0 )
  46856   POA INDICA TOR^F^^0;3 ^K:$L(X)>2 !($L(X)<1)  X
  46857   "^DD",7410 00,741000. 0151,.03,3 )
  46858   Answer mus t be 1-2 c haracters  in length.
  46859   "^DD",7410 00,741000. 0151,.03," DT")
  46860   3100330
  46861   "^DD",7410 00,741000. 0153,0)
  46862   NON-COVERE D/OTHER IT EM SUB-FIE LD^^.07^7
  46863   "^DD",7410 00,741000. 0153,0,"DT ")
  46864   2970801
  46865   "^DD",7410 00,741000. 0153,0,"IX ","B",7410 00.0153,.0 1)
  46866  
  46867   "^DD",7410 00,741000. 0153,0,"NM ","NON-COV ERED/OTHER  ITEM")
  46868  
  46869   "^DD",7410 00,741000. 0153,0,"UP ")
  46870   741000
  46871   "^DD",7410 00,741000. 0153,.01,0 )
  46872   NON-COVERE D/OTHER IT EM^P741002 .09'^CHMDI C(741002.0 9,^0;1^Q
  46873   "^DD",7410 00,741000. 0153,.01,1 ,0)
  46874   ^.1^^0
  46875   "^DD",7410 00,741000. 0153,.01,1 ,1,0)
  46876   741000.015 3^B
  46877   "^DD",7410 00,741000. 0153,.01,1 ,1,1)
  46878   S ^CHMPAY( DA(1),"INP -NC","B",$ E(X,1,30), DA)=""
  46879   "^DD",7410 00,741000. 0153,.01,1 ,1,2)
  46880   K ^CHMPAY( DA(1),"INP -NC","B",$ E(X,1,30), DA)
  46881   "^DD",7410 00,741000. 0153,.01," DT")
  46882   2901106
  46883   "^DD",7410 00,741000. 0153,.02,0 )
  46884   NON-COV/OT HER CHARGE  OR DAYS^N J10,2^^0;2 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>9999999) !(X<0) X
  46885   "^DD",7410 00,741000. 0153,.02,3 )
  46886   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  46887   "^DD",7410 00,741000. 0153,.02," DT")
  46888   2910418
  46889   "^DD",7410 00,741000. 0153,.03,0 )
  46890   PROFESSION AL SERVICE  CODE^P741 006'^CHMSE RV(^0;3^Q
  46891   "^DD",7410 00,741000. 0153,.03," DT")
  46892   2900914
  46893   "^DD",7410 00,741000. 0153,.04,0 )
  46894   NON-COVERE D ALLOWABL E AMT^NJ10 ,2^^0;4^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999999)!(X <0) X
  46895   "^DD",7410 00,741000. 0153,.04,3 )
  46896   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  46897   "^DD",7410 00,741000. 0153,.04," DT")
  46898   2910222
  46899   "^DD",7410 00,741000. 0153,.05,0 )
  46900   NUMBER ANE STHESIA UN ITS^NJ8,2^ ^0;5^K:+X' =X!(X>9999 9)!(X<0)!( X?.E1"."3N .N) X
  46901   "^DD",7410 00,741000. 0153,.05,3 )
  46902   Type a Num ber betwee n 0 and 99 999, 2 Dec imal Digit s
  46903   "^DD",7410 00,741000. 0153,.05," DT")
  46904   2910222
  46905   "^DD",7410 00,741000. 0153,.06,0 )
  46906   ANESTHESIA  COST/UNIT ^NJ10,2^^0 ;6^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 9)!(X<0) X
  46907   "^DD",7410 00,741000. 0153,.06,3 )
  46908   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  46909   "^DD",7410 00,741000. 0153,.06," DT")
  46910   2910222
  46911   "^DD",7410 00,741000. 0153,.07,0 )
  46912   REVENUE CO DE^P741201 .39'^CHMXD IC(741201. 39,^0;7^Q
  46913   "^DD",7410 00,741000. 0153,.07," DT")
  46914   2970801
  46915   "^DD",7410 00,741000. 0154,0)
  46916   PROCEDURES  PERFORMED  SUB-FIELD ^^.02^2
  46917   "^DD",7410 00,741000. 0154,0,"IX ","B",7410 00.0154,.0 1)
  46918  
  46919   "^DD",7410 00,741000. 0154,0,"NM ","PROCEDU RES PERFOR MED")
  46920  
  46921   "^DD",7410 00,741000. 0154,0,"UP ")
  46922   741000
  46923   "^DD",7410 00,741000. 0154,.01,0 )
  46924   PROCEDURES  PERFORMED ^P741006'^ CHMSERV(^0 ;1^Q
  46925   "^DD",7410 00,741000. 0154,.01,1 ,0)
  46926   ^.1^^0
  46927   "^DD",7410 00,741000. 0154,.01,1 ,1,0)
  46928   741000.015 4^B
  46929   "^DD",7410 00,741000. 0154,.01,1 ,1,1)
  46930   S ^CHMPAY( DA(1),"INP -PROC","B" ,$E(X,1,30 ),DA)=""
  46931   "^DD",7410 00,741000. 0154,.01,1 ,1,2)
  46932   K ^CHMPAY( DA(1),"INP -PROC","B" ,$E(X,1,30 ),DA)
  46933   "^DD",7410 00,741000. 0154,.01," DT")
  46934   2901106
  46935   "^DD",7410 00,741000. 0154,.02,0 )
  46936   COVERED IC D9 PROCEDU RE FLAG^S^ 1:YES;0:NO ;^0;2^Q
  46937   "^DD",7410 00,741000. 0154,.02," DT")
  46938   2900914
  46939   "^DD",7410 00,741000. 0155,0)
  46940   TYPE OF RO OM SUB-FIE LD^^.03^3
  46941   "^DD",7410 00,741000. 0155,0,"DT ")
  46942   2910326
  46943   "^DD",7410 00,741000. 0155,0,"IX ","B",7410 00.0155,.0 1)
  46944  
  46945   "^DD",7410 00,741000. 0155,0,"NM ","TYPE OF  ROOM")
  46946  
  46947   "^DD",7410 00,741000. 0155,0,"UP ")
  46948   741000
  46949   "^DD",7410 00,741000. 0155,.01,0 )
  46950   TYPE OF RO OM^P741002 .29^CHMDIC (741002.29 ,^0;1^Q
  46951   "^DD",7410 00,741000. 0155,.01,1 ,0)
  46952   ^.1^^0
  46953   "^DD",7410 00,741000. 0155,.01,1 ,1,0)
  46954   741000.015 5^B
  46955   "^DD",7410 00,741000. 0155,.01,1 ,1,1)
  46956   S ^CHMPAY( DA(1),"INP -ROOM","B" ,$E(X,1,30 ),DA)=""
  46957   "^DD",7410 00,741000. 0155,.01,1 ,1,2)
  46958   K ^CHMPAY( DA(1),"INP -ROOM","B" ,$E(X,1,30 ),DA)
  46959   "^DD",7410 00,741000. 0155,.01,3 )
  46960  
  46961   "^DD",7410 00,741000. 0155,.01," DT")
  46962   2910326
  46963   "^DD",7410 00,741000. 0155,.02,0 )
  46964   ROOM RATE^ NJ8,2^^0;2 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>99999)!( X<0) X
  46965   "^DD",7410 00,741000. 0155,.02,3 )
  46966   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  46967   "^DD",7410 00,741000. 0155,.03,0 )
  46968   NUMBER OF  DAYS IN RO OM^NJ3,0^^ 0;3^K:+X'= X!(X>999)! (X<0)!(X?. E1"."1N.N)  X
  46969   "^DD",7410 00,741000. 0155,.03,3 )
  46970   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  46971   "^DD",7410 00,741000. 0156,0)
  46972   REVENUE CO DE SUB-FIE LD^^.06^6
  46973   "^DD",7410 00,741000. 0156,0,"DT ")
  46974   3180517
  46975   "^DD",7410 00,741000. 0156,0,"IX ","B",7410 00.0156,.0 1)
  46976  
  46977   "^DD",7410 00,741000. 0156,0,"NM ","REVENUE  CODE")
  46978  
  46979   "^DD",7410 00,741000. 0156,0,"UP ")
  46980   741000
  46981   "^DD",7410 00,741000. 0156,.01,0 )
  46982   REVENUE CO DE^MP74120 1.39'^CHMX DIC(741201 .39,^0;1^Q
  46983   "^DD",7410 00,741000. 0156,.01,1 ,0)
  46984   ^.1
  46985   "^DD",7410 00,741000. 0156,.01,1 ,1,0)
  46986   741000.015 6^B
  46987   "^DD",7410 00,741000. 0156,.01,1 ,1,1)
  46988   S ^CHMPAY( DA(1),"INP -REV","B", $E(X,1,30) ,DA)=""
  46989   "^DD",7410 00,741000. 0156,.01,1 ,1,2)
  46990   K ^CHMPAY( DA(1),"INP -REV","B", $E(X,1,30) ,DA)
  46991   "^DD",7410 00,741000. 0156,.01," DT")
  46992   2970425
  46993   "^DD",7410 00,741000. 0156,.02,0 )
  46994   ASSOCIATED  LINE CHAR GE^NJ11,2^ ^0;2^K:+X' =X!(X>9999 9999)!(X<0 )!(X?.E1". "3N.N) X
  46995   "^DD",7410 00,741000. 0156,.02,3 )
  46996   Type a Num ber betwee n 0 and 99 999999, 2  Decimal Di gits
  46997   "^DD",7410 00,741000. 0156,.02," DT")
  46998   2970418
  46999   "^DD",7410 00,741000. 0156,.03,0 )
  47000   EDI LINE I DENTIFIER^ NJ4,0^^0;3 ^K:+X'=X!( X>9999)!(X <1)!(X?.E1 "."1N.N) X
  47001   "^DD",7410 00,741000. 0156,.03,3 )
  47002   Type a Num ber betwee n 1 and 99 99, 0 Deci mal Digits
  47003   "^DD",7410 00,741000. 0156,.03," DT")
  47004   2970418
  47005   "^DD",7410 00,741000. 0156,.04,0 )
  47006   ASSOCIATED  LINE NO.  OF UNITS^N J5,0^^0;4^ K:+X'=X!(X >99999)!(X <0)!(X?.E1 "."1N.N) X
  47007   "^DD",7410 00,741000. 0156,.04,3 )
  47008   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  47009   "^DD",7410 00,741000. 0156,.04," DT")
  47010   2970801
  47011   "^DD",7410 00,741000. 0156,.05,0 )
  47012   ORIGINAL P X CODE FOR  LINE^P741 006'^CHMSE RV(^0;5^Q
  47013   "^DD",7410 00,741000. 0156,.05," DT")
  47014   3030921
  47015   "^DD",7410 00,741000. 0156,.06,0 )
  47016   HIPPS RATE  CODE^P741 201.86'^CH MXDIC(7412 01.86,^0;6 ^Q
  47017   "^DD",7410 00,741000. 0156,.06,3 )
  47018   ENTER THE  HIPPS RATE  CODE FOR  THIS REVEN UE CODE.
  47019   "^DD",7410 00,741000. 0156,.06,2 1,0)
  47020   ^^1^1^3180 516^
  47021   "^DD",7410 00,741000. 0156,.06,2 1,1,0)
  47022   THE HIPPS  CODE FOR T HIS REVENU E CODE.
  47023   "^DD",7410 00,741000. 0156,.06," DT")
  47024   3180516
  47025   "^DD",7410 00,741000. 0157,0)
  47026   OCCURRENCE  CODE SUB- FIELD^^.02 ^2
  47027   "^DD",7410 00,741000. 0157,0,"DT ")
  47028   3180518
  47029   "^DD",7410 00,741000. 0157,0,"IX ","B",7410 00.0157,.0 1)
  47030  
  47031   "^DD",7410 00,741000. 0157,0,"NM ","OCCURRE NCE CODE")
  47032  
  47033   "^DD",7410 00,741000. 0157,0,"UP ")
  47034   741000
  47035   "^DD",7410 00,741000. 0157,.01,0 )
  47036   OCCURRENCE  CODE^MP74 1201.42'^C HMXDIC(741 201.42,^0; 1^Q
  47037   "^DD",7410 00,741000. 0157,.01,1 ,0)
  47038   ^.1
  47039   "^DD",7410 00,741000. 0157,.01,1 ,1,0)
  47040   741000.015 7^B
  47041   "^DD",7410 00,741000. 0157,.01,1 ,1,1)
  47042   S ^CHMPAY( DA(1),"INP -OCCR","B" ,$E(X,1,30 ),DA)=""
  47043   "^DD",7410 00,741000. 0157,.01,1 ,1,2)
  47044   K ^CHMPAY( DA(1),"INP -OCCR","B" ,$E(X,1,30 ),DA)
  47045   "^DD",7410 00,741000. 0157,.01,3 )
  47046   Enter Occu rrence Cod e for this  Claim
  47047   "^DD",7410 00,741000. 0157,.01,2 1,0)
  47048   ^^1^1^3180 518^
  47049   "^DD",7410 00,741000. 0157,.01,2 1,1,0)
  47050   OCCURRENCE  CODE FOR  THIS CLAIM
  47051   "^DD",7410 00,741000. 0157,.01," DT")
  47052   3180518
  47053   "^DD",7410 00,741000. 0157,.02,0 )
  47054   OCCURRENCE  CODE DATE ^D^^0;2^S  %DT="E" D  ^%DT S X=Y  K:X<1 X
  47055   "^DD",7410 00,741000. 0157,.02,3 )
  47056   Enter Occu rrence Cod e Date for  this Clai m
  47057   "^DD",7410 00,741000. 0157,.02,2 1,0)
  47058   ^^1^1^3180 518^
  47059   "^DD",7410 00,741000. 0157,.02,2 1,1,0)
  47060   OCCURRENCE  CODE DATE  FOR THIS  CLAIM
  47061   "^DD",7410 00,741000. 0157,.02," DT")
  47062   3180518
  47063   "^DD",7410 00,741000. 0158,0)
  47064   OCCURRENCE  SPAN CODE  SUB-FIELD ^^.03^3
  47065   "^DD",7410 00,741000. 0158,0,"DT ")
  47066   3180518
  47067   "^DD",7410 00,741000. 0158,0,"IX ","B",7410 00.0158,.0 1)
  47068  
  47069   "^DD",7410 00,741000. 0158,0,"NM ","OCCURRE NCE SPAN C ODE")
  47070  
  47071   "^DD",7410 00,741000. 0158,0,"UP ")
  47072   741000
  47073   "^DD",7410 00,741000. 0158,.01,0 )
  47074   OCCURRENCE  SPAN CODE ^MP741201. 43'^CHMXDI C(741201.4 3,^0;1^Q
  47075   "^DD",7410 00,741000. 0158,.01,1 ,0)
  47076   ^.1
  47077   "^DD",7410 00,741000. 0158,.01,1 ,1,0)
  47078   741000.015 8^B
  47079   "^DD",7410 00,741000. 0158,.01,1 ,1,1)
  47080   S ^CHMPAY( DA(1),"INP -SPAN","B" ,$E(X,1,30 ),DA)=""
  47081   "^DD",7410 00,741000. 0158,.01,1 ,1,2)
  47082   K ^CHMPAY( DA(1),"INP -SPAN","B" ,$E(X,1,30 ),DA)
  47083   "^DD",7410 00,741000. 0158,.01,3 )
  47084   Enter an O ccurrence  Span Code  for this C laim
  47085   "^DD",7410 00,741000. 0158,.01,2 1,0)
  47086   ^^1^1^3180 518^
  47087   "^DD",7410 00,741000. 0158,.01,2 1,1,0)
  47088   OCCURRENCE  SPAN CODE
  47089   "^DD",7410 00,741000. 0158,.01," DT")
  47090   3180518
  47091   "^DD",7410 00,741000. 0158,.02,0 )
  47092   OCCURRENCE  SPAN CODE  FROM DATE ^D^^0;2^S  %DT="E" D  ^%DT S X=Y  K:X<1 X
  47093   "^DD",7410 00,741000. 0158,.02,3 )
  47094   Enter Occu rrence Spa n Code for  this Clai m
  47095   "^DD",7410 00,741000. 0158,.02,2 1,0)
  47096   ^^1^1^3180 518^
  47097   "^DD",7410 00,741000. 0158,.02,2 1,1,0)
  47098   OCCURRENCE  SPAN CODE  FROM DATE  FOR THIS  CLAIM
  47099   "^DD",7410 00,741000. 0158,.02," DT")
  47100   3180518
  47101   "^DD",7410 00,741000. 0158,.03,0 )
  47102   OCCURRENCE  SPAN CODE  THRU DATE ^D^^0;3^S  %DT="E" D  ^%DT S X=Y  K:X<1 X
  47103   "^DD",7410 00,741000. 0158,.03,3 )
  47104   Enter Occu rrence Spa n Code Thr ough Date  for this C laim
  47105   "^DD",7410 00,741000. 0158,.03,2 1,0)
  47106   ^^1^1^3180 518^
  47107   "^DD",7410 00,741000. 0158,.03,2 1,1,0)
  47108   OCCURRENCE  CODE SPAN  CODE THRO UGH DATE F OR THIS CL AIM
  47109   "^DD",7410 00,741000. 0158,.03," DT")
  47110   3180518
  47111   "^DD",7410 00,741000. 0161,0)
  47112   OUTPATIENT  DIAGNOSIS  SUB-FIELD ^^.02^2
  47113   "^DD",7410 00,741000. 0161,0,"IX ","B",7410 00.0161,.0 1)
  47114  
  47115   "^DD",7410 00,741000. 0161,0,"NM ","OUTPATI ENT DIAGNO SIS")
  47116  
  47117   "^DD",7410 00,741000. 0161,0,"UP ")
  47118   741000
  47119   "^DD",7410 00,741000. 0161,.01,0 )
  47120   OUTPATIENT  DIAGNOSIS ^P741006.0 5'^CHMICDX (^0;1^Q
  47121   "^DD",7410 00,741000. 0161,.01,1 ,0)
  47122   ^.1^^0
  47123   "^DD",7410 00,741000. 0161,.01,1 ,1,0)
  47124   741000.016 1^B
  47125   "^DD",7410 00,741000. 0161,.01,1 ,1,1)
  47126   S ^CHMPAY( DA(1),"OPT -DX","B",$ E(X,1,30), DA)=""
  47127   "^DD",7410 00,741000. 0161,.01,1 ,1,2)
  47128   K ^CHMPAY( DA(1),"OPT -DX","B",$ E(X,1,30), DA)
  47129   "^DD",7410 00,741000. 0161,.01," DT")
  47130   2901106
  47131   "^DD",7410 00,741000. 0161,.02,0 )
  47132   COVERED DI AGNOSIS FL AG^S^1:YES ;0:NO;^0;2 ^Q
  47133   "^DD",7410 00,741000. 0161,.02," DT")
  47134   2900914
  47135   "^DD",7410 00,741000. 0162,0)
  47136   OUTPATIENT  SERVICE S UB-FIELD^^ .27^27
  47137   "^DD",7410 00,741000. 0162,0,"DT ")
  47138   3120924
  47139   "^DD",7410 00,741000. 0162,0,"IX ","B",7410 00.0162,.0 1)
  47140  
  47141   "^DD",7410 00,741000. 0162,0,"NM ","OUTPATI ENT SERVIC E")
  47142  
  47143   "^DD",7410 00,741000. 0162,0,"UP ")
  47144   741000
  47145   "^DD",7410 00,741000. 0162,.01,0 )
  47146   OUTPATIENT  SERVICE^P 741006'^CH MSERV(^0;1 ^Q
  47147   "^DD",7410 00,741000. 0162,.01,1 ,0)
  47148   ^.1^^0
  47149   "^DD",7410 00,741000. 0162,.01,1 ,1,0)
  47150   741000.016 2^B
  47151   "^DD",7410 00,741000. 0162,.01,1 ,1,1)
  47152   S ^CHMPAY( DA(1),"OPT -PROC","B" ,$E(X,1,30 ),DA)=""
  47153   "^DD",7410 00,741000. 0162,.01,1 ,1,2)
  47154   K ^CHMPAY( DA(1),"OPT -PROC","B" ,$E(X,1,30 ),DA)
  47155   "^DD",7410 00,741000. 0162,.01," DT")
  47156   2901214
  47157   "^DD",7410 00,741000. 0162,.02,0 )
  47158   CHARGE FOR  SERVICE^N J11,2^^0;2 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>99999999 )!(X<0) X
  47159   "^DD",7410 00,741000. 0162,.02,3 )
  47160   Type a Dol lar Amount  between 0  and 99999 999, 2 Dec imal Digit s
  47161   "^DD",7410 00,741000. 0162,.03,0 )
  47162   OUTPATIENT  ALLOWABLE  AMOUNT^NJ 10,2^^0;3^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >9999999)! (X<0) X
  47163   "^DD",7410 00,741000. 0162,.03,3 )
  47164   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  47165   "^DD",7410 00,741000. 0162,.03," DT")
  47166   2910222
  47167   "^DD",7410 00,741000. 0162,.04,0 )
  47168   1ST CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;4^Q
  47169   "^DD",7410 00,741000. 0162,.04," DT")
  47170   3110111
  47171   "^DD",7410 00,741000. 0162,.05,0 )
  47172   ADJUSTED A LLOWABLE A MT^NJ9,2^^ 0;5^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 9)!(X<0) X
  47173   "^DD",7410 00,741000. 0162,.05,3 )
  47174   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  47175   "^DD",7410 00,741000. 0162,.05," DT")
  47176   2950223
  47177   "^DD",7410 00,741000. 0162,.06,0 )
  47178   DUZ CHANGI NG ALLOW A MT^P200'^V A(200,^0;6 ^Q
  47179   "^DD",7410 00,741000. 0162,.06," DT")
  47180   2950223
  47181   "^DD",7410 00,741000. 0162,.07,0 )
  47182   DATE/TIME  CHANGE ALL OW AMT^D^^ 0;7^S %DT= "EST" D ^% DT S X=Y K :Y<1 X
  47183   "^DD",7410 00,741000. 0162,.07," DT")
  47184   2950309
  47185   "^DD",7410 00,741000. 0162,.08,0 )
  47186   CLAIMCHECK  RESULT^F^ ^0;8^K:$L( X)>7!($L(X )<1) X
  47187   "^DD",7410 00,741000. 0162,.08,3 )
  47188   Answer mus t be 1-7 c haracters  in length
  47189   "^DD",7410 00,741000. 0162,.08," DT")
  47190   3070112
  47191   "^DD",7410 00,741000. 0162,.09,0 )
  47192   COMPLETED  CLAIMCHECK ^S^1:YES;0 :NO;^0;9^Q
  47193   "^DD",7410 00,741000. 0162,.09," DT")
  47194   2951214
  47195   "^DD",7410 00,741000. 0162,.1,0)
  47196   CLAIMCHECK  SEX CONFL ICT^F^^0;1 0^K:$L(X)> 2!($L(X)<1 ) X
  47197   "^DD",7410 00,741000. 0162,.1,3)
  47198   Answer mus t be 1-2 c haracters  in length.
  47199   "^DD",7410 00,741000. 0162,.1,"D T")
  47200   2960307
  47201   "^DD",7410 00,741000. 0162,.11,0 )
  47202   CLAIMCHECK  COSMETIC/ UNLISTED^F ^^0;11^K:$ L(X)>2!($L (X)<1) X
  47203   "^DD",7410 00,741000. 0162,.11,3 )
  47204   Answer mus t be 1-2 c haracters  in length.
  47205   "^DD",7410 00,741000. 0162,.11," DT")
  47206   2960307
  47207   "^DD",7410 00,741000. 0162,.12,0 )
  47208   CLAIMCHECK  AGE CONFL ICT^F^^0;1 2^K:$L(X)> 2!($L(X)<1 ) X
  47209   "^DD",7410 00,741000. 0162,.12,3 )
  47210   Answer mus t be 1-2 c haracters  in length.
  47211   "^DD",7410 00,741000. 0162,.12," DT")
  47212   2960307
  47213   "^DD",7410 00,741000. 0162,.13,0 )
  47214   CLAIMCHECK  EXPERIMEN TAL PROC^F ^^0;13^K:$ L(X)>2!($L (X)<1) X
  47215   "^DD",7410 00,741000. 0162,.13,3 )
  47216   Answer mus t be 1-2 c haracters  in length.
  47217   "^DD",7410 00,741000. 0162,.13," DT")
  47218   2960307
  47219   "^DD",7410 00,741000. 0162,.14,0 )
  47220   CLAIMCHECK  OBSOLETE  PROC^F^^0; 14^K:$L(X) >2!($L(X)< 1) X
  47221   "^DD",7410 00,741000. 0162,.14,3 )
  47222   Answer mus t be 1-2 c haracters  in length.
  47223   "^DD",7410 00,741000. 0162,.14," DT")
  47224   2960307
  47225   "^DD",7410 00,741000. 0162,.15,0 )
  47226   CLAIMCHECK  ASST SURG ^F^^0;15^K :$L(X)>2!( $L(X)<1) X
  47227   "^DD",7410 00,741000. 0162,.15,3 )
  47228   Answer mus t be 1-2 c haracters  in length.
  47229   "^DD",7410 00,741000. 0162,.15," DT")
  47230   2960307
  47231   "^DD",7410 00,741000. 0162,.16,0 )
  47232   REVENUE CO DE^P741201 .39'^CHMXD IC(741201. 39,^0;16^Q
  47233   "^DD",7410 00,741000. 0162,.16," DT")
  47234   2970425
  47235   "^DD",7410 00,741000. 0162,.17,0 )
  47236   ASSOCIATED  LINE CHAR GE^NJ10,2^ ^0;17^K:+X '=X!(X>999 9999)!(X<0 )!(X?.E1". "3N.N) X
  47237   "^DD",7410 00,741000. 0162,.17,3 )
  47238   Type a Num ber betwee n 0 and 99 99999, 2 D ecimal Dig its
  47239   "^DD",7410 00,741000. 0162,.17," DT")
  47240   2970418
  47241   "^DD",7410 00,741000. 0162,.18,0 )
  47242   EDI LINE I DENTIFIER^ NJ4,0^^0;1 8^K:+X'=X! (X>9999)!( X<1)!(X?.E 1"."1N.N)  X
  47243   "^DD",7410 00,741000. 0162,.18,3 )
  47244   Type a Num ber betwee n 1 and 99 99, 0 Deci mal Digits
  47245   "^DD",7410 00,741000. 0162,.18," DT")
  47246   2970418
  47247   "^DD",7410 00,741000. 0162,.19,0 )
  47248   UNITS^NJ6, 0^^0;19^K: +X'=X!(X>9 99999)!(X< 0)!(X?.E1" ."1N.N) X
  47249   "^DD",7410 00,741000. 0162,.19,3 )
  47250   Type a Num ber betwee n 0 and 99 9999, 0 De cimal Digi ts
  47251   "^DD",7410 00,741000. 0162,.19," DT")
  47252   2970904
  47253   "^DD",7410 00,741000. 0162,.2,0)
  47254   CLAIMCHECK  OUTPUT ME SSAGE^F^^0 ;20^K:$L(X )>36!($L(X )<1) X
  47255   "^DD",7410 00,741000. 0162,.2,3)
  47256   Answer mus t be 1-36  characters  in length .
  47257   "^DD",7410 00,741000. 0162,.2,"D T")
  47258   3000427
  47259   "^DD",7410 00,741000. 0162,.21,0 )
  47260   ORIGINAL P X CODE FOR  LINE^P741 006'^CHMSE RV(^0;21^Q
  47261   "^DD",7410 00,741000. 0162,.21," DT")
  47262   3030921
  47263   "^DD",7410 00,741000. 0162,.22,0 )
  47264   CLAIMCHECK  LINE ORIG INATION^F^ ^0;22^K:$L (X)>5!($L( X)<1) X
  47265   "^DD",7410 00,741000. 0162,.22,3 )
  47266   Answer mus t be 1-5 c haracters  in length
  47267   "^DD",7410 00,741000. 0162,.22,2 1,0)
  47268   ^^2^2^3070 111^
  47269   "^DD",7410 00,741000. 0162,.22,2 1,1,0)
  47270   Indicates  if the lin e item ori ginally ca me with th e claim or  was a new  
  47271   "^DD",7410 00,741000. 0162,.22,2 1,2,0)
  47272   line creat ed during  the Claim  Check proc ess.
  47273   "^DD",7410 00,741000. 0162,.22," DT")
  47274   3070111
  47275   "^DD",7410 00,741000. 0162,.23,0 )
  47276   NEW LINE A DDED BY CL AIMCHECK^S ^1:YES;^0; 23^Q
  47277   "^DD",7410 00,741000. 0162,.23," DT")
  47278   3070308
  47279   "^DD",7410 00,741000. 0162,.24,0 )
  47280   OHI PAID A MT^741000. 0262^^1;0
  47281   "^DD",7410 00,741000. 0162,.24,2 1,0)
  47282   ^.001^1^1^ 3120404^^
  47283   "^DD",7410 00,741000. 0162,.24,2 1,1,0)
  47284   LINE LEVEL  OHI DATA  ADDED BY E NC7820
  47285   "^DD",7410 00,741000. 0162,.24,2 3,0)
  47286   ^.001^1^1^ 3120404^^
  47287   "^DD",7410 00,741000. 0162,.24,2 3,1,0)
  47288   THIS MULTI PLE WAS AD DED FOR EN C7820
  47289   "^DD",7410 00,741000. 0162,.25,0 )
  47290   2ND CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;25^Q
  47291   "^DD",7410 00,741000. 0162,.25," DT")
  47292   3110111
  47293   "^DD",7410 00,741000. 0162,.26,0 )
  47294   3RD CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;26^Q
  47295   "^DD",7410 00,741000. 0162,.26," DT")
  47296   3110111
  47297   "^DD",7410 00,741000. 0162,.27,0 )
  47298   4TH CPT4 M ODIFIER^P7 41002.37'^ CHMDIC(741 002.37,^0; 27^Q
  47299   "^DD",7410 00,741000. 0162,.27," DT")
  47300   3110111
  47301   "^DD",7410 00,741000. 02,0)
  47302   DENTAL PRO CEDURE SUB -FIELD^^.2 4^18
  47303   "^DD",7410 00,741000. 02,0,"DT")
  47304   3110713
  47305   "^DD",7410 00,741000. 02,0,"IX", "B",741000 .02,.01)
  47306  
  47307   "^DD",7410 00,741000. 02,0,"NM", "DENTAL PR OCEDURE")
  47308  
  47309   "^DD",7410 00,741000. 02,0,"UP")
  47310   741000
  47311   "^DD",7410 00,741000. 02,.01,0)
  47312   DENTAL PRO CEDURE^P74 1006'^CHMS ERV(^0;1^Q
  47313   "^DD",7410 00,741000. 02,.01,1,0 )
  47314   ^.1^^0
  47315   "^DD",7410 00,741000. 02,.01,1,1 ,0)
  47316   741000.02^ B
  47317   "^DD",7410 00,741000. 02,.01,1,1 ,1)
  47318   S ^CHMPAY( DA(1),"DEN -PROC","B" ,$E(X,1,30 ),DA)=""
  47319   "^DD",7410 00,741000. 02,.01,1,1 ,2)
  47320   K ^CHMPAY( DA(1),"DEN -PROC","B" ,$E(X,1,30 ),DA)
  47321   "^DD",7410 00,741000. 02,.01,"DT ")
  47322   2901214
  47323   "^DD",7410 00,741000. 02,.02,0)
  47324   PROCEDURE  CHARGE^NJ1 0,2^^0;2^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 9999999)!( X<0) X
  47325   "^DD",7410 00,741000. 02,.02,3)
  47326   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  47327   "^DD",7410 00,741000. 02,.03,0)
  47328   TOOTH NUMB ER^P741002 .14^CHMDIC (741002.14 ,^0;3^Q
  47329   "^DD",7410 00,741000. 02,.04,0)
  47330   SURFACE^F^ ^0;4^K:$L( X)>20!($L( X)<1) X
  47331   "^DD",7410 00,741000. 02,.04,3)
  47332   Answer mus t be 1-20  characters  in length .
  47333   "^DD",7410 00,741000. 02,.05,0)
  47334   DENTAL ALL OWABLE AMO UNT^NJ10,2 ^^0;5^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 9999)!(X<0 ) X
  47335   "^DD",7410 00,741000. 02,.05,3)
  47336   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  47337   "^DD",7410 00,741000. 02,.05,"DT ")
  47338   2910222
  47339   "^DD",7410 00,741000. 02,.06,0)
  47340   1ST CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;6^Q
  47341   "^DD",7410 00,741000. 02,.06,"DT ")
  47342   3110111
  47343   "^DD",7410 00,741000. 02,.07,0)
  47344   ADJUSTED A LLOWABLE A MT^NJ9,2^^ 0;7^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 9)!(X<0) X
  47345   "^DD",7410 00,741000. 02,.07,3)
  47346   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  47347   "^DD",7410 00,741000. 02,.07,"DT ")
  47348   2950223
  47349   "^DD",7410 00,741000. 02,.08,0)
  47350   DUZ CHANGI NG ALLOW A MT^P200'^V A(200,^0;8 ^Q
  47351   "^DD",7410 00,741000. 02,.08,"DT ")
  47352   2950223
  47353   "^DD",7410 00,741000. 02,.09,0)
  47354   DATE/TIME  CHANGE ALL OW AMT^D^^ 0;9^S %DT= "EST" D ^% DT S X=Y K :Y<1 X
  47355   "^DD",7410 00,741000. 02,.09,"DT ")
  47356   2950309
  47357   "^DD",7410 00,741000. 02,.16,0)
  47358   REVENUE CO DE (DNTL F ROM UB92)^ P741201.39 '^CHMXDIC( 741201.39, ^0;10^Q
  47359   "^DD",7410 00,741000. 02,.16,"DT ")
  47360   3030921
  47361   "^DD",7410 00,741000. 02,.17,0)
  47362   EDI ASSOCI ATED LINE  CHARGE^NJ1 5,0^^0;11^ K:+X'=X!(X >999999999 999999)!(X <0)!(X?.E1 "."1N.N) X
  47363   "^DD",7410 00,741000. 02,.17,3)
  47364   Type a Num ber betwee n 0 and 99 9999999999 999, 0 Dec imal Digit s
  47365   "^DD",7410 00,741000. 02,.17,"DT ")
  47366   3030921
  47367   "^DD",7410 00,741000. 02,.18,0)
  47368   EDI LINE I DENTIFIER^ NJ5,0^^0;1 2^K:+X'=X! (X>99999)! (X<1)!(X?. E1"."1N.N)  X
  47369   "^DD",7410 00,741000. 02,.18,3)
  47370   Type a Num ber betwee n 1 and 99 999, 0 Dec imal Digit s
  47371   "^DD",7410 00,741000. 02,.18,"DT ")
  47372   3030921
  47373   "^DD",7410 00,741000. 02,.19,0)
  47374   UNITS^NJ10 ,0^^0;13^K :+X'=X!(X> 9999999999 )!(X<0)!(X ?.E1"."1N. N) X
  47375   "^DD",7410 00,741000. 02,.19,3)
  47376   Type a Num ber betwee n 0 and 99 99999999,  0 Decimal  Digits
  47377   "^DD",7410 00,741000. 02,.19,"DT ")
  47378   3030921
  47379   "^DD",7410 00,741000. 02,.2,0)
  47380   ORIGINAL P X CODE FOR  LINE^P741 006'^CHMSE RV(^0;14^Q
  47381   "^DD",7410 00,741000. 02,.2,"DT" )
  47382   3030921
  47383   "^DD",7410 00,741000. 02,.21,0)
  47384   OHI PAID A MT^741000. 27A^^1;0
  47385   "^DD",7410 00,741000. 02,.21,21, 0)
  47386   ^^1^1^3110 204^
  47387   "^DD",7410 00,741000. 02,.21,21, 1,0)
  47388   LINE LEVEL  OHI DATA  ADDED BY E NC7820
  47389   "^DD",7410 00,741000. 02,.21,23, 0)
  47390   ^^1^1^3110 127^
  47391   "^DD",7410 00,741000. 02,.21,23, 1,0)
  47392   THIS MULTI PLE WAS AD DED FOR EN C7820
  47393   "^DD",7410 00,741000. 02,.21,"DT ")
  47394   3110127
  47395   "^DD",7410 00,741000. 02,.22,0)
  47396   2ND CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;22^Q
  47397   "^DD",7410 00,741000. 02,.22,"DT ")
  47398   3110111
  47399   "^DD",7410 00,741000. 02,.23,0)
  47400   3RD CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;23^Q
  47401   "^DD",7410 00,741000. 02,.23,"DT ")
  47402   3110111
  47403   "^DD",7410 00,741000. 02,.24,0)
  47404   4TH CPT-4  MODIFIER^P 741002.37' ^CHMDIC(74 1002.37,^0 ;24^Q
  47405   "^DD",7410 00,741000. 02,.24,"DT ")
  47406   3110111
  47407   "^DD",7410 00,741000. 0203,0)
  47408   COVERAGE C ODE (PHARM ) SUB-FIEL D^^.08^7
  47409   "^DD",7410 00,741000. 0203,0,"DT ")
  47410   2910429
  47411   "^DD",7410 00,741000. 0203,0,"IX ","B",7410 00.0203,.0 1)
  47412  
  47413   "^DD",7410 00,741000. 0203,0,"NM ","COVERAG E CODE (PH ARM)")
  47414  
  47415   "^DD",7410 00,741000. 0203,0,"UP ")
  47416   741000
  47417   "^DD",7410 00,741000. 0203,.01,0 )
  47418   COVERAGE C ODE (PHARM )^S^0:REJE CT;1:ACCEP T;2:QA ACC EPT;3:MISS ING DATA;4 :QA REJECT ;^0;1^Q
  47419   "^DD",7410 00,741000. 0203,.01,1 ,0)
  47420   ^.1
  47421   "^DD",7410 00,741000. 0203,.01,1 ,1,0)
  47422   741000.020 3^B
  47423   "^DD",7410 00,741000. 0203,.01,1 ,1,1)
  47424   S ^CHMPAY( DA(1),"RUL E-PHARM"," B",$E(X,1, 30),DA)=""
  47425   "^DD",7410 00,741000. 0203,.01,1 ,1,2)
  47426   K ^CHMPAY( DA(1),"RUL E-PHARM"," B",$E(X,1, 30),DA)
  47427   "^DD",7410 00,741000. 0203,.01," DT")
  47428   2910429
  47429   "^DD",7410 00,741000. 0203,.02,0 )
  47430   AI REASON  (PHARM)^P7 41002.22'^ CHMDIC(741 002.22,^0; 2^Q
  47431   "^DD",7410 00,741000. 0203,.02," DT")
  47432   2910429
  47433   "^DD",7410 00,741000. 0203,.03,0 )
  47434   FILE USED^ F^^0;3^K:$ L(X)>20!($ L(X)<1) X
  47435   "^DD",7410 00,741000. 0203,.03,3 )
  47436   Answer mus t be 1-20  characters  in length .
  47437   "^DD",7410 00,741000. 0203,.03," DT")
  47438   2910429
  47439   "^DD",7410 00,741000. 0203,.04,0 )
  47440   LAST TEST^ F^^0;4^K:$ L(X)>20!($ L(X)<1) X
  47441   "^DD",7410 00,741000. 0203,.04,3 )
  47442   Answer mus t be 1-20  characters  in length .
  47443   "^DD",7410 00,741000. 0203,.04," DT")
  47444   2910429
  47445   "^DD",7410 00,741000. 0203,.05,0 )
  47446   LAST RULE^ F^^0;5^K:$ L(X)>15!($ L(X)<1) X
  47447   "^DD",7410 00,741000. 0203,.05,3 )
  47448   Answer mus t be 1-15  characters  in length .
  47449   "^DD",7410 00,741000. 0203,.05," DT")
  47450   2910429
  47451   "^DD",7410 00,741000. 0203,.07,0 )
  47452   LAST ELEME NT^F^^0;6^ K:$L(X)>7! ($L(X)<1)  X
  47453   "^DD",7410 00,741000. 0203,.07,3 )
  47454   Answer mus t be 1-7 c haracters  in length.
  47455   "^DD",7410 00,741000. 0203,.07," DT")
  47456   2910429
  47457   "^DD",7410 00,741000. 0203,.08,0 )
  47458   OUTCOME^F^ ^0;7^K:$L( X)>7!($L(X )<1) X
  47459   "^DD",7410 00,741000. 0203,.08,3 )
  47460   Answer mus t be 1-7 c haracters  in length.
  47461   "^DD",7410 00,741000. 0203,.08," DT")
  47462   2910429
  47463   "^DD",7410 00,741000. 0205,0)
  47464   COVERAGE C ODE (PROC, DME) SUB-F IELD^^.1^1 0
  47465   "^DD",7410 00,741000. 0205,0,"DT ")
  47466   3000427
  47467   "^DD",7410 00,741000. 0205,0,"IX ","B",7410 00.0205,.0 1)
  47468  
  47469   "^DD",7410 00,741000. 0205,0,"NM ","COVERAG E CODE (PR OC,DME)")
  47470  
  47471   "^DD",7410 00,741000. 0205,0,"UP ")
  47472   741000
  47473   "^DD",7410 00,741000. 0205,.01,0 )
  47474   COVERAGE C ODE (PROC, DME)^S^0:R EJECT;1:AC CEPT;2:QA  ACCEPT;3:M ISSING DAT A;4:QA REJ ECT;^0;1^Q
  47475   "^DD",7410 00,741000. 0205,.01,1 ,0)
  47476   ^.1^^0
  47477   "^DD",7410 00,741000. 0205,.01,1 ,1,0)
  47478   741000.020 5^B
  47479   "^DD",7410 00,741000. 0205,.01,1 ,1,1)
  47480   S ^CHMPAY( DA(1),"RUL E-PROC","B ",$E(X,1,3 0),DA)=""
  47481   "^DD",7410 00,741000. 0205,.01,1 ,1,2)
  47482   K ^CHMPAY( DA(1),"RUL E-PROC","B ",$E(X,1,3 0),DA)
  47483   "^DD",7410 00,741000. 0205,.01," DT")
  47484   2910429
  47485   "^DD",7410 00,741000. 0205,.02,0 )
  47486   AI REASON  (PROC,DME) ^P741002.2 2^CHMDIC(7 41002.22,^ 0;2^Q
  47487   "^DD",7410 00,741000. 0205,.02,3 )
  47488  
  47489   "^DD",7410 00,741000. 0205,.02," DT")
  47490   2910429
  47491   "^DD",7410 00,741000. 0205,.03,0 )
  47492   FILE USED^ F^^0;3^K:$ L(X)>20!($ L(X)<1) X
  47493   "^DD",7410 00,741000. 0205,.03,3 )
  47494   Answer mus t be 1-20  characters  in length .
  47495   "^DD",7410 00,741000. 0205,.03," DT")
  47496   2901014
  47497   "^DD",7410 00,741000. 0205,.04,0 )
  47498   LAST TEST^ F^^0;4^K:$ L(X)>20!($ L(X)<1) X
  47499   "^DD",7410 00,741000. 0205,.04,3 )
  47500   Answer mus t be 1-20  characters  in length .
  47501   "^DD",7410 00,741000. 0205,.04," DT")
  47502   2901014
  47503   "^DD",7410 00,741000. 0205,.05,0 )
  47504   LAST RULE^ F^^0;5^K:$ L(X)>15!($ L(X)<1) X
  47505   "^DD",7410 00,741000. 0205,.05,3 )
  47506   Answer mus t be 1-15  characters  in length .
  47507   "^DD",7410 00,741000. 0205,.05," DT")
  47508   2901014
  47509   "^DD",7410 00,741000. 0205,.06,0 )
  47510   LAST ELEME NT^F^^0;6^ K:$L(X)>7! ($L(X)<1)  X
  47511   "^DD",7410 00,741000. 0205,.06,3 )
  47512   Answer mus t be 1-7 c haracters  in length.
  47513   "^DD",7410 00,741000. 0205,.06," DT")
  47514   2901014
  47515   "^DD",7410 00,741000. 0205,.07,0 )
  47516   OUTCOME^F^ ^0;7^K:$L( X)>7!($L(X )<1) X
  47517   "^DD",7410 00,741000. 0205,.07,3 )
  47518   Answer mus t be 1-7 c haracters  in length.
  47519   "^DD",7410 00,741000. 0205,.07," DT")
  47520   2901014
  47521   "^DD",7410 00,741000. 0205,.08,0 )
  47522   SPECIAL PA YMENT METH OD^NJ3,0^^ 0;8^K:+X'= X!(X>999)! (X<1)!(X?. E1"."1N.N)  X
  47523   "^DD",7410 00,741000. 0205,.08,3 )
  47524   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  47525   "^DD",7410 00,741000. 0205,.08," DT")
  47526   2910502
  47527   "^DD",7410 00,741000. 0205,.09,0 )
  47528   PAYMENT ME THOD^S^1:C MAC;2:PREV AILING FEE ;3:ASC;5:P HP;^0;9^Q
  47529   "^DD",7410 00,741000. 0205,.09," DT")
  47530   2970715
  47531   "^DD",7410 00,741000. 0205,.1,0)
  47532   REBUNDLE T O CODE^F^^ 0;10^K:$L( X)>6!($L(X )<4) X
  47533   "^DD",7410 00,741000. 0205,.1,3)
  47534   Answer mus t be 4-6 c haracters  in length.
  47535   "^DD",7410 00,741000. 0205,.1,"D T")
  47536   3000427
  47537   "^DD",7410 00,741000. 0206,0)
  47538   DATE OF HI STORY CHAN GE SUB-FIE LD^^50^110
  47539   "^DD",7410 00,741000. 0206,0,"DT ")
  47540   2950111
  47541   "^DD",7410 00,741000. 0206,0,"IX ","B",7410 00.0206,.0 1)
  47542  
  47543   "^DD",7410 00,741000. 0206,0,"NM ","DATE OF  HISTORY C HANGE")
  47544  
  47545   "^DD",7410 00,741000. 0206,0,"UP ")
  47546   741000
  47547   "^DD",7410 00,741000. 0206,.01,0 )
  47548   CLAIM NUMB ER HIST^DX ^^0;1^S %D T="ESTR" D  ^%DT S X= Y K:Y<1 X  S:$D(X) DI NUM=X
  47549   "^DD",7410 00,741000. 0206,.01,1 ,0)
  47550   ^.1^^0
  47551   "^DD",7410 00,741000. 0206,.01,1 ,1,0)
  47552   741000.020 6^B
  47553   "^DD",7410 00,741000. 0206,.01,1 ,1,1)
  47554   S ^CHMPAY( DA(1),101, "B",$E(X,1 ,30),DA)=" "
  47555   "^DD",7410 00,741000. 0206,.01,1 ,1,2)
  47556   K ^CHMPAY( DA(1),101, "B",$E(X,1 ,30),DA)
  47557   "^DD",7410 00,741000. 0206,.01,3 )
  47558  
  47559   "^DD",7410 00,741000. 0206,.01," DT")
  47560   2910404
  47561   "^DD",7410 00,741000. 0206,.02,0 )
  47562   CLAIM STAT US HIST^S^ O:REJECTED ;1:IN PROC ESS;2:PAYM ENT REQUES TED;3:CHEC K ISSUED;4 :COMPLETE; 5:ADJUDICA TED;6:PAYM ENT REJECT ED CAPPS/C ALM;7:ADMI NISTRATIVE  SUSPENSE; ^0;2^Q
  47563   "^DD",7410 00,741000. 0206,.02," DT")
  47564   2910404
  47565   "^DD",7410 00,741000. 0206,.03,0 )
  47566   VENDOR ID  HIST^P7410 01'^CHMVEN (^0;3^Q
  47567   "^DD",7410 00,741000. 0206,.03," DT")
  47568   2910404
  47569   "^DD",7410 00,741000. 0206,.04,0 )
  47570   VENDORIZAT ION POINTE R HIST^F^^ 0;4^K:$L(X )>20!($L(X )<1) X
  47571   "^DD",7410 00,741000. 0206,.04,3 )
  47572   Answer mus t be 1-20  characters  in length .
  47573   "^DD",7410 00,741000. 0206,.04," DT")
  47574   2910404
  47575   "^DD",7410 00,741000. 0206,.05,0 )
  47576   ASSIGN OF  BENEFITS H IST^S^1:YE S;0:NO;^0; 5^Q
  47577   "^DD",7410 00,741000. 0206,.05," DT")
  47578   2910404
  47579   "^DD",7410 00,741000. 0206,.06,0 )
  47580   DATE OF AS SIGN HIST^ D^^0;6^S % DT="E" D ^ %DT S X=Y  K:Y<1 X
  47581   "^DD",7410 00,741000. 0206,.06," DT")
  47582   2910404
  47583   "^DD",7410 00,741000. 0206,.07,0 )
  47584   TYPE OF CL AIM HIST^P 741002.05' ^CHMDIC(74 1002.05,^0 ;7^Q
  47585   "^DD",7410 00,741000. 0206,.07," DT")
  47586   2910404
  47587   "^DD",7410 00,741000. 0206,.08,0 )
  47588   DATE OF SE RV/ADMISSI ON HIST^D^ ^0;8^S %DT ="E" D ^%D T S X=Y K: Y<1 X
  47589   "^DD",7410 00,741000. 0206,.08," DT")
  47590   2920609
  47591   "^DD",7410 00,741000. 0206,.09,0 )
  47592   DATE INITI ALLY RECEI VED HIST.^ D^^0;9^S % DT="ESTR"  D ^%DT S X =Y K:Y<1 X
  47593   "^DD",7410 00,741000. 0206,.09," DT")
  47594   2910426
  47595   "^DD",7410 00,741000. 0206,.1,0)
  47596   DATE DETER MINED COMP . HIST.^D^ ^0;10^S %D T="ESTR" D  ^%DT S X= Y K:Y<1 X
  47597   "^DD",7410 00,741000. 0206,.1,"D T")
  47598   2910404
  47599   "^DD",7410 00,741000. 0206,.11,0 )
  47600   CLAIM STAT US EXPLAN.  CODE HIST ^F^^0;11^K :$L(X)>20! ($L(X)<1)  X
  47601   "^DD",7410 00,741000. 0206,.11,3 )
  47602   Answer mus t be 1-20  characters  in length .
  47603   "^DD",7410 00,741000. 0206,.11," DT")
  47604   2910404
  47605   "^DD",7410 00,741000. 0206,.12,0 )
  47606   WORK FLOW  INDICATOR  HIST^P7410 02.23'^CHM DIC(741002 .23,^0;12^ Q
  47607   "^DD",7410 00,741000. 0206,.12," DT")
  47608   2910404
  47609   "^DD",7410 00,741000. 0206,.13,0 )
  47610   UNASSIGNED  HIST^F^^0 ;13^K:$L(X )>2!($L(X) <1) X
  47611   "^DD",7410 00,741000. 0206,.13,3 )
  47612   Answer mus t be 1-2 c haracters  in length.
  47613   "^DD",7410 00,741000. 0206,.13," DT")
  47614   2910404
  47615   "^DD",7410 00,741000. 0206,.14,0 )
  47616   VENDOR DIS COUNT PERC ENT HIST^N J3,0^^0;14 ^K:+X'=X!( X>100)!(X< 0)!(X?.E1" ."1N.N) X
  47617   "^DD",7410 00,741000. 0206,.14,3 )
  47618   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  47619   "^DD",7410 00,741000. 0206,.14," DT")
  47620   2910404
  47621   "^DD",7410 00,741000. 0206,.15,0 )
  47622   VENDOR DIS COUNT DAYS  HIST^NJ3, 0^^0;15^K: +X'=X!(X>9 99)!(X<0)! (X?.E1"."1 N.N) X
  47623   "^DD",7410 00,741000. 0206,.15,3 )
  47624   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  47625   "^DD",7410 00,741000. 0206,.15," DT")
  47626   2910404
  47627   "^DD",7410 00,741000. 0206,.16,0 )
  47628   VENDOR DIS COUNT AMOU NT HIST^NJ 5,0^^0;16^ K:+X'=X!(X >99999)!(X <0)!(X?.E1 "."1N.N) X
  47629   "^DD",7410 00,741000. 0206,.16,3 )
  47630   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  47631   "^DD",7410 00,741000. 0206,.16," DT")
  47632   2910404
  47633   "^DD",7410 00,741000. 0206,.17,0 )
  47634   VENDOR DIS COUNT TERM S HIST^S^X :BLANK;P:P AYMENT;E:E STIMATE;^0 ;17^Q
  47635   "^DD",7410 00,741000. 0206,.17," DT")
  47636   2910404
  47637   "^DD",7410 00,741000. 0206,.18,0 )
  47638   VENDORIZAT ION STRING  HIST^F^^0 ;18^K:$L(X )>30!($L(X )<1) X
  47639   "^DD",7410 00,741000. 0206,.18,3 )
  47640   Answer mus t be 1-30  characters  in length .
  47641   "^DD",7410 00,741000. 0206,.18," DT")
  47642   2910404
  47643   "^DD",7410 00,741000. 0206,.19,0 )
  47644   STATUS OF  MCCR ACTIO N HIST^S^0 :MCCR NOT  NECESSARY; 1:PENDING  SELECTION  FROM QUEUE ;2:IN PROG RESS;^0;19 ^Q
  47645   "^DD",7410 00,741000. 0206,.19," DT")
  47646   2910404
  47647   "^DD",7410 00,741000. 0206,.2,0)
  47648   LAST SETTI NG DUZ MCC R ST. HIST ^P3'^DIC(3 ,^0;20^Q
  47649   "^DD",7410 00,741000. 0206,.2,"D T")
  47650   2910404
  47651   "^DD",7410 00,741000. 0206,.21,0 )
  47652   SPONSOR HI ST^P554801 '^AHCHVA(^ 0;21^Q
  47653   "^DD",7410 00,741000. 0206,.21," DT")
  47654   2910404
  47655   "^DD",7410 00,741000. 0206,.22,0 )
  47656   BFN HIST^N J2,0^^0;22 ^K:+X'=X!( X>99)!(X<0 )!(X?.E1". "1N.N) X
  47657   "^DD",7410 00,741000. 0206,.22,3 )
  47658   Type a Num ber betwee n 0 and 99 , 0 Decima l Digits
  47659   "^DD",7410 00,741000. 0206,.22," DT")
  47660   2910404
  47661   "^DD",7410 00,741000. 0206,.23,0 )
  47662   INVOICE NU MBER HIST^ F^^0;23^K: $L(X)>16!( $L(X)<1) X
  47663   "^DD",7410 00,741000. 0206,.23,3 )
  47664   Answer mus t be 1-16  characters  in length .
  47665   "^DD",7410 00,741000. 0206,.23," DT")
  47666   2910404
  47667   "^DD",7410 00,741000. 0206,.24,0 )
  47668   INVOICE DA TE HIST^D^ ^0;24^S %D T="E" D ^% DT S X=Y K :Y<1 X
  47669   "^DD",7410 00,741000. 0206,.24," DT")
  47670   2910404
  47671   "^DD",7410 00,741000. 0206,1.07, 0)
  47672   OHI PAYMEN T HIST^NJ6 ,0^^1;7^K: +X'=X!(X>9 99999)!(X< 0)!(X?.E1" ."1N.N) X
  47673   "^DD",7410 00,741000. 0206,1.07, 3)
  47674   Type a Num ber betwee n 0 and 99 9999, 0 De cimal Digi ts
  47675   "^DD",7410 00,741000. 0206,1.07, "DT")
  47676   2941122
  47677   "^DD",7410 00,741000. 0206,9.06, 0)
  47678   VENDOR PAG E HIST^NJ4 ,0^^9;6^K: +X'=X!(X>9 999)!(X<0) !(X?.E1"." 1N.N) X
  47679   "^DD",7410 00,741000. 0206,9.06, 3)
  47680   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  47681   "^DD",7410 00,741000. 0206,9.06, "DT")
  47682   2941122
  47683   "^DD",7410 00,741000. 0206,10.01 ,0)
  47684   WORK RELAT ED ACC/ILL  HIST^S^1: YES;0:NO;^ 10;1^Q
  47685   "^DD",7410 00,741000. 0206,10.01 ,"DT")
  47686   2901018
  47687   "^DD",7410 00,741000. 0206,10.02 ,0)
  47688   AUTO ACCID ENT HIST^S ^1:YES;0:N O;^10;2^Q
  47689   "^DD",7410 00,741000. 0206,10.02 ,"DT")
  47690   2901018
  47691   "^DD",7410 00,741000. 0206,10.03 ,0)
  47692   OTHER ACCI DENT HIST^ S^1:YES;0: NO;^10;3^Q
  47693   "^DD",7410 00,741000. 0206,10.03 ,"DT")
  47694   2901018
  47695   "^DD",7410 00,741000. 0206,10.04 ,0)
  47696   EMPLOYED H IST^S^1:YE S;0:NO;^10 ;4^Q
  47697   "^DD",7410 00,741000. 0206,10.04 ,"DT")
  47698   2901018
  47699   "^DD",7410 00,741000. 0206,10.05 ,0)
  47700   REL OF INF O LIMIT HI ST^S^1:YES ;0:NO;^10; 5^Q
  47701   "^DD",7410 00,741000. 0206,10.05 ,"DT")
  47702   2901018
  47703   "^DD",7410 00,741000. 0206,10.06 ,0)
  47704   OTHER HEAL TH INSUR H IST^S^1:YE S;0:NO;^10 ;6^Q
  47705   "^DD",7410 00,741000. 0206,10.06 ,"DT")
  47706   2901018
  47707   "^DD",7410 00,741000. 0206,10.07 ,0)
  47708   CLAIM FORM  SIGNATURE  HIST^S^1: YES;0:NO;^ 10;7^Q
  47709   "^DD",7410 00,741000. 0206,10.07 ,"DT")
  47710   2901018
  47711   "^DD",7410 00,741000. 0206,10.08 ,0)
  47712   GROUP HEAL TH HIST^S^ 1:YES;0:NO ;^10;8^Q
  47713   "^DD",7410 00,741000. 0206,10.08 ,"DT")
  47714   2901018
  47715   "^DD",7410 00,741000. 0206,10.09 ,0)
  47716   MEDICAID H IST^S^1:YE S;0:NO;^10 ;9^Q
  47717   "^DD",7410 00,741000. 0206,10.09 ,"DT")
  47718   2901018
  47719   "^DD",7410 00,741000. 0206,10.1, 0)
  47720   PRIVATE/NO N-GROUP HI ST^S^1:YES ;0:NO;^10; 10^Q
  47721   "^DD",7410 00,741000. 0206,10.1, "DT")
  47722   2901018
  47723   "^DD",7410 00,741000. 0206,10.11 ,0)
  47724   CHAMPVA SU PPLEMENT H IST^S^1:YE S;0:NO;^10 ;11^Q
  47725   "^DD",7410 00,741000. 0206,10.11 ,"DT")
  47726   2901018
  47727   "^DD",7410 00,741000. 0206,10.12 ,0)
  47728   WORKERS CO MP HIST^S^ 1:YES;0:NO ;^10;12^Q
  47729   "^DD",7410 00,741000. 0206,10.12 ,"DT")
  47730   2901018
  47731   "^DD",7410 00,741000. 0206,10.13 ,0)
  47732   NONE CHECK ED HIST^S^ 1:YES;0:NO ;^10;13^Q
  47733   "^DD",7410 00,741000. 0206,10.13 ,"DT")
  47734   2901018
  47735   "^DD",7410 00,741000. 0206,10.14 ,0)
  47736   MEDICARE H IST^S^1:YE S;0:NO;^10 ;14^Q
  47737   "^DD",7410 00,741000. 0206,10.14 ,"DT")
  47738   2901018
  47739   "^DD",7410 00,741000. 0206,10.15 ,0)
  47740   NON-OCCUPA TIONAL INJ URY HIST^S ^1:YES;0:N O;^10;15^Q
  47741   "^DD",7410 00,741000. 0206,10.15 ,"DT")
  47742   2901018
  47743   "^DD",7410 00,741000. 0206,10.16 ,0)
  47744   MULTI CAUS AL ACCIDEN T HIST^S^1 :YES;0:NO; ^10;16^Q
  47745   "^DD",7410 00,741000. 0206,10.16 ,"DT")
  47746   2901018
  47747   "^DD",7410 00,741000. 0206,10.17 ,0)
  47748   ADDIT. ACC IDENT COMM ENTS HIST^ S^1:YES;0: NO;^10;17^ Q
  47749   "^DD",7410 00,741000. 0206,10.17 ,"DT")
  47750   2901018
  47751   "^DD",7410 00,741000. 0206,10.18 ,0)
  47752   WC DETAILS  HIST^S^1: YES;0:NO;^ 10;18^Q
  47753   "^DD",7410 00,741000. 0206,10.18 ,"DT")
  47754   2901018
  47755   "^DD",7410 00,741000. 0206,10.19 ,0)
  47756   INDICATION S OF INJUR Y/ACC HIST ^S^1:YES;0 :NO;^10;19 ^Q
  47757   "^DD",7410 00,741000. 0206,10.19 ,"DT")
  47758   2901018
  47759   "^DD",7410 00,741000. 0206,10.2, 0)
  47760   MCCR REVIE W WARR HIS T^S^1:YES; 0:NO;^10;2 0^Q
  47761   "^DD",7410 00,741000. 0206,10.2, "DT")
  47762   2901018
  47763   "^DD",7410 00,741000. 0206,10.21 ,0)
  47764   CIRCUMSTAN CES HIST^S ^1:YES;0:N O;^10;21^Q
  47765   "^DD",7410 00,741000. 0206,10.21 ,"DT")
  47766   2901018
  47767   "^DD",7410 00,741000. 0206,20.01 ,0)
  47768   REL OF INF O LIMIT DA TE HIST^D^ ^20;1^S %D T="E" D ^% DT S X=Y K :Y<1 X
  47769   "^DD",7410 00,741000. 0206,20.01 ,"DT")
  47770   2901018
  47771   "^DD",7410 00,741000. 0206,20.02 ,0)
  47772   SIGNATURE  DATE HIST^ D^^20;2^S  %DT="E" D  ^%DT S X=Y  K:Y<1 X
  47773   "^DD",7410 00,741000. 0206,20.02 ,"DT")
  47774   2901018
  47775   "^DD",7410 00,741000. 0206,20.03 ,0)
  47776   DATE OF AC CIDENT HIS T^D^^20;3^ S %DT="E"  D ^%DT S X =Y K:Y<1 X
  47777   "^DD",7410 00,741000. 0206,20.03 ,"DT")
  47778   2901018
  47779   "^DD",7410 00,741000. 0206,20.04 ,0)
  47780   SIGNATURE  ON CLAIM F ORM HIST^F ^^20;4^K:$ L(X)>20!($ L(X)<1) X
  47781   "^DD",7410 00,741000. 0206,20.04 ,3)
  47782   Answer mus t be 1-20  characters  in length .
  47783   "^DD",7410 00,741000. 0206,20.04 ,"DT")
  47784   2901018
  47785   "^DD",7410 00,741000. 0206,24.01 ,0)
  47786   OTHER INSU R NAME HIS T^F^^24;1^ K:$L(X)>30 !($L(X)<1)  X
  47787   "^DD",7410 00,741000. 0206,24.01 ,3)
  47788   Answer mus t be 1-30  characters  in length .
  47789   "^DD",7410 00,741000. 0206,24.01 ,"DT")
  47790   2901018
  47791   "^DD",7410 00,741000. 0206,24.02 ,0)
  47792   OTHER INSU R ADDR1 HI ST^F^^24;2 ^K:$L(X)>5 0!($L(X)<1 ) X
  47793   "^DD",7410 00,741000. 0206,24.02 ,3)
  47794   Answer mus t be 1-50  characters  in length .
  47795   "^DD",7410 00,741000. 0206,24.02 ,"DT")
  47796   2901018
  47797   "^DD",7410 00,741000. 0206,24.03 ,0)
  47798   OTHER INSU R ADDR2 HI ST^F^^24;3 ^K:$L(X)>5 0!($L(X)<1 ) X
  47799   "^DD",7410 00,741000. 0206,24.03 ,3)
  47800   Answer mus t be 1-50  characters  in length .
  47801   "^DD",7410 00,741000. 0206,24.03 ,"DT")
  47802   2901018
  47803   "^DD",7410 00,741000. 0206,24.04 ,0)
  47804   OTHER INSU R CITY HIS TORY^F^^24 ;4^K:$L(X) >25!($L(X) <1) X
  47805   "^DD",7410 00,741000. 0206,24.04 ,3)
  47806   Answer mus t be 1-25  characters  in length .
  47807   "^DD",7410 00,741000. 0206,24.04 ,"DT")
  47808   2901018
  47809   "^DD",7410 00,741000. 0206,24.05 ,0)
  47810   OTHER INSU R STATE HI ST^P5'^DIC (5,^24;5^Q
  47811   "^DD",7410 00,741000. 0206,24.05 ,"DT")
  47812   2901018
  47813   "^DD",7410 00,741000. 0206,24.06 ,0)
  47814   OTHER INSU R ZIP HIST ^NJ9,0^^24 ;6^K:+X'=X !(X>999999 999)!(X<0) !(X?.E1"." 1N.N) X
  47815   "^DD",7410 00,741000. 0206,24.06 ,3)
  47816   Type a Num ber betwee n 0 and 99 9999999, 0  Decimal D igits
  47817   "^DD",7410 00,741000. 0206,24.06 ,"DT")
  47818   2901018
  47819   "^DD",7410 00,741000. 0206,24.07 ,0)
  47820   OTHER INSU R PHONE HI ST^NJ10,0^ ^24;7^K:+X '=X!(X>999 9999999)!( X<0)!(X?.E 1"."1N.N)  X
  47821   "^DD",7410 00,741000. 0206,24.07 ,3)
  47822   Type a Num ber betwee n 0 and 99 99999999,  0 Decimal  Digits
  47823   "^DD",7410 00,741000. 0206,24.07 ,"DT")
  47824   2901018
  47825   "^DD",7410 00,741000. 0206,24.08 ,0)
  47826   OTHER INSU R POLICY I D HIST^F^^ 24;8^K:$L( X)>20!($L( X)<1) X
  47827   "^DD",7410 00,741000. 0206,24.08 ,3)
  47828   Answer mus t be 1-20  characters  in length .
  47829   "^DD",7410 00,741000. 0206,24.08 ,"DT")
  47830   2901018
  47831   "^DD",7410 00,741000. 0206,26.01 ,0)
  47832   WC CARRIER  NAME HIST ^F^^26;1^K :$L(X)>30! ($L(X)<1)  X
  47833   "^DD",7410 00,741000. 0206,26.01 ,3)
  47834   Answer mus t be 1-30  characters  in length .
  47835   "^DD",7410 00,741000. 0206,26.01 ,"DT")
  47836   2901018
  47837   "^DD",7410 00,741000. 0206,26.02 ,0)
  47838   WC CARRIER  ADDR1 HIS T^F^^26;2^ K:$L(X)>50 !($L(X)<1)  X
  47839   "^DD",7410 00,741000. 0206,26.02 ,3)
  47840   Answer mus t be 1-50  characters  in length .
  47841   "^DD",7410 00,741000. 0206,26.02 ,"DT")
  47842   2901018
  47843   "^DD",7410 00,741000. 0206,26.03 ,0)
  47844   WC CARRIER  ADDR2 HIS T^F^^26;3^ K:$L(X)>50 !($L(X)<1)  X
  47845   "^DD",7410 00,741000. 0206,26.03 ,3)
  47846   Answer mus t be 1-50  characters  in length .
  47847   "^DD",7410 00,741000. 0206,26.03 ,"DT")
  47848   2901018
  47849   "^DD",7410 00,741000. 0206,26.04 ,0)
  47850   WC CARRIER  CITY HIST ^F^^26;4^K :$L(X)>25! ($L(X)<1)  X
  47851   "^DD",7410 00,741000. 0206,26.04 ,3)
  47852   Answer mus t be 1-25  characters  in length .
  47853   "^DD",7410 00,741000. 0206,26.04 ,"DT")
  47854   2901018
  47855   "^DD",7410 00,741000. 0206,26.05 ,0)
  47856   WC CARRIER  STATE HIS T^P5'^DIC( 5,^26;5^Q
  47857   "^DD",7410 00,741000. 0206,26.05 ,"DT")
  47858   2901018
  47859   "^DD",7410 00,741000. 0206,26.06 ,0)
  47860   WC CARRIER  ZIP HIST^ NJ9,0^^26; 6^K:+X'=X! (X>9999999 99)!(X<0)! (X?.E1"."1 N.N) X
  47861   "^DD",7410 00,741000. 0206,26.06 ,3)
  47862   Type a Num ber betwee n 0 and 99 9999999, 0  Decimal D igits
  47863   "^DD",7410 00,741000. 0206,26.06 ,"DT")
  47864   2901018
  47865   "^DD",7410 00,741000. 0206,26.07 ,0)
  47866   WC CARRIER  PHONE HIS T^NJ10,0^^ 26;7^K:+X' =X!(X>9999 999999)!(X <0)!(X?.E1 "."1N.N) X
  47867   "^DD",7410 00,741000. 0206,26.07 ,3)
  47868   Type a Num ber betwee n 0 and 99 99999999,  0 Decimal  Digits
  47869   "^DD",7410 00,741000. 0206,26.07 ,"DT")
  47870   2901018
  47871   "^DD",7410 00,741000. 0206,26.08 ,0)
  47872   WC ACC/INJ URY DATE H IST^D^^26; 8^S %DT="E " D ^%DT S  X=Y K:Y<1  X
  47873   "^DD",7410 00,741000. 0206,26.08 ,"DT")
  47874   2901018
  47875   "^DD",7410 00,741000. 0206,28.01 ,0)
  47876   EMPLOYER N AME HIST^F ^^28;1^K:$ L(X)>30!($ L(X)<1) X
  47877   "^DD",7410 00,741000. 0206,28.01 ,3)
  47878   Answer mus t be 1-30  characters  in length .
  47879   "^DD",7410 00,741000. 0206,28.01 ,"DT")
  47880   2901018
  47881   "^DD",7410 00,741000. 0206,28.02 ,0)
  47882   EMPLOYER A DDR1 HIST^ F^^28;2^K: $L(X)>50!( $L(X)<1) X
  47883   "^DD",7410 00,741000. 0206,28.02 ,3)
  47884   Answer mus t be 1-50  characters  in length .
  47885   "^DD",7410 00,741000. 0206,28.02 ,"DT")
  47886   2901018
  47887   "^DD",7410 00,741000. 0206,28.03 ,0)
  47888   EMPLOYER A DDR2 HIST^ F^^28;3^K: $L(X)>50!( $L(X)<1) X
  47889   "^DD",7410 00,741000. 0206,28.03 ,3)
  47890   Answer mus t be 1-50  characters  in length .
  47891   "^DD",7410 00,741000. 0206,28.03 ,"DT")
  47892   2901018
  47893   "^DD",7410 00,741000. 0206,28.04 ,0)
  47894   EMPLOYER C ITY HIST^F ^^28;4^K:$ L(X)>25!($ L(X)<1) X
  47895   "^DD",7410 00,741000. 0206,28.04 ,3)
  47896   Answer mus t be 1-25  characters  in length .
  47897   "^DD",7410 00,741000. 0206,28.04 ,"DT")
  47898   2901018
  47899   "^DD",7410 00,741000. 0206,28.05 ,0)
  47900   EMPLOYER S TATE HIST^ P5'^DIC(5, ^28;5^Q
  47901   "^DD",7410 00,741000. 0206,28.05 ,"DT")
  47902   2901018
  47903   "^DD",7410 00,741000. 0206,28.06 ,0)
  47904   EMPLOYER Z IP HIST^NJ 9,0^^28;6^ K:+X'=X!(X >999999999 )!(X<0)!(X ?.E1"."1N. N) X
  47905   "^DD",7410 00,741000. 0206,28.06 ,3)
  47906   Type a Num ber betwee n 0 and 99 9999999, 0  Decimal D igits
  47907   "^DD",7410 00,741000. 0206,28.06 ,"DT")
  47908   2901018
  47909   "^DD",7410 00,741000. 0206,28.07 ,0)
  47910   EMPLOYER P HONE HIST^ NJ10,0^^28 ;7^K:+X'=X !(X>999999 9999)!(X<0 )!(X?.E1". "1N.N) X
  47911   "^DD",7410 00,741000. 0206,28.07 ,3)
  47912   Type a Num ber betwee n 0 and 99 99999999,  0 Decimal  Digits
  47913   "^DD",7410 00,741000. 0206,28.07 ,"DT")
  47914   2901018
  47915   "^DD",7410 00,741000. 0206,29,0)
  47916   ACTION QUE UE HISTORY ^S^1:AUDIT  SUPPORT;2 :DUPLICATE  CLAIM;3:E LIGIBILITY ;4:EOB;5:M CCR;6:MISS ING DATA;7 :PROBLEM S UPPORT;8:Q A;9:VENDOR IZATION;10 :REOPEN CL AIM;11:N.H . QUEUE;^5 0;1^Q
  47917   "^DD",7410 00,741000. 0206,29,"D T")
  47918   2910612
  47919   "^DD",7410 00,741000. 0206,30,0)
  47920   LAST SETTI NG DUZ HIS TORY^P3'^D IC(3,^99;1 ^Q
  47921   "^DD",7410 00,741000. 0206,30,"D T")
  47922   2910227
  47923   "^DD",7410 00,741000. 0206,30.01 ,0)
  47924   TOTAL CHAR GES BILLED  HIST^NJ7, 0^^COMMON; 1^K:+X'=X! (X>9999999 )!(X<0)!(X ?.E1"."1N. N) X
  47925   "^DD",7410 00,741000. 0206,30.01 ,3)
  47926   Type a Num ber betwee n 0 and 99 99999, 0 D ecimal Dig its
  47927   "^DD",7410 00,741000. 0206,30.01 ,"DT")
  47928   2901018
  47929   "^DD",7410 00,741000. 0206,30.02 ,0)
  47930   PLACE OF S ERVICE HIS T^P741002. 11'^CHMDIC (741002.11 ,^COMMON;2 ^Q
  47931   "^DD",7410 00,741000. 0206,30.02 ,"DT")
  47932   2901018
  47933   "^DD",7410 00,741000. 0206,30.03 ,0)
  47934   PAYMENTS H IST^NJ7,0^ ^COMMON;3^ K:+X'=X!(X >9999999)! (X<0)!(X?. E1"."1N.N)  X
  47935   "^DD",7410 00,741000. 0206,30.03 ,3)
  47936   Type a Num ber betwee n 0 and 99 99999, 0 D ecimal Dig its
  47937   "^DD",7410 00,741000. 0206,30.03 ,"DT")
  47938   2901018
  47939   "^DD",7410 00,741000. 0206,30.04 ,0)
  47940   PRESCRIBIN G PHYSICIA N HIST^F^^ COMMON;4^K :$L(X)>30! ($L(X)<1)  X
  47941   "^DD",7410 00,741000. 0206,30.04 ,3)
  47942   Answer mus t be 1-30  characters  in length .
  47943   "^DD",7410 00,741000. 0206,30.04 ,"DT")
  47944   2901018
  47945   "^DD",7410 00,741000. 0206,30.05 ,0)
  47946   REFERRING  PHYSICIAN  HIST^F^^CO MMON;5^K:$ L(X)>30!($ L(X)<1) X
  47947   "^DD",7410 00,741000. 0206,30.05 ,3)
  47948   Answer mus t be 1-30  characters  in length .
  47949   "^DD",7410 00,741000. 0206,30.05 ,"DT")
  47950   2901018
  47951   "^DD",7410 00,741000. 0206,30.06 ,0)
  47952   DAYS OR UN ITS HIST^F ^^COMMON;6 ^K:$L(X)>2 0!($L(X)<1 ) X
  47953   "^DD",7410 00,741000. 0206,30.06 ,3)
  47954   Answer mus t be 1-20  characters  in length .
  47955   "^DD",7410 00,741000. 0206,30.06 ,"DT")
  47956   2901018
  47957   "^DD",7410 00,741000. 0206,30.07 ,0)
  47958   CALC ALLOW ABLE AMONU T HIST^NJ8 ,0^^COMMON ;7^K:+X'=X !(X>999999 99)!(X<0)! (X?.E1"."1 N.N) X
  47959   "^DD",7410 00,741000. 0206,30.07 ,3)
  47960   Type a Num ber betwee n 0 and 99 999999, 0  Decimal Di gits
  47961   "^DD",7410 00,741000. 0206,30.07 ,"DT")
  47962   2901018
  47963   "^DD",7410 00,741000. 0206,30.08 ,0)
  47964   DRG ASSIGN ED HIST^NJ 4,0^^COMMO N;8^K:+X'= X!(X>9999) !(X<0)!(X? .E1"."1N.N ) X
  47965   "^DD",7410 00,741000. 0206,30.08 ,3)
  47966   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  47967   "^DD",7410 00,741000. 0206,30.08 ,"DT")
  47968   2901018
  47969   "^DD",7410 00,741000. 0206,30.09 ,0)
  47970   DRG COVERA GE CODE HI ST^S^0:REJ ECT;1:ACCE PT;2:QUALI TY ASSURAN CE;3:MISSI NG DATA;^C OMMON;9^Q
  47971   "^DD",7410 00,741000. 0206,30.09 ,"DT")
  47972   2901018
  47973   "^DD",7410 00,741000. 0206,30.1, 0)
  47974   AI REASON  HIST^P7410 02.22'^CHM DIC(741002 .22,^COMMO N;10^Q
  47975   "^DD",7410 00,741000. 0206,30.1, 3)
  47976  
  47977   "^DD",7410 00,741000. 0206,30.1, "DT")
  47978   2901106
  47979   "^DD",7410 00,741000. 0206,30.11 ,0)
  47980   RULE FAILU RE HIST^F^ ^COMMON;11 ^K:$L(X)>5 0!($L(X)<1 ) X
  47981   "^DD",7410 00,741000. 0206,30.11 ,3)
  47982   Answer mus t be 1-50  characters  in length .
  47983   "^DD",7410 00,741000. 0206,30.11 ,"DT")
  47984   2901018
  47985   "^DD",7410 00,741000. 0206,30.12 ,0)
  47986   RESULT OF  QA REVIEW^ S^0:REJECT ;1:ACCEPT; 2:NO ACTIO N;^COMMON; 12^Q
  47987   "^DD",7410 00,741000. 0206,30.12 ,"DT")
  47988   2901031
  47989   "^DD",7410 00,741000. 0206,30.13 ,0)
  47990   DUZ OF QA  REVIEW^P3' ^DIC(3,^CO MMON;13^Q
  47991   "^DD",7410 00,741000. 0206,30.13 ,"DT")
  47992   2901031
  47993   "^DD",7410 00,741000. 0206,30.14 ,0)
  47994   DATE OF QA  REVIEW^D^ ^COMMON;14 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  47995   "^DD",7410 00,741000. 0206,30.14 ,"DT")
  47996   2901031
  47997   "^DD",7410 00,741000. 0206,31,0)
  47998   DENTAL PRO CEDURE HIS T^741000.2 0631P^^DEN -PROC;0
  47999   "^DD",7410 00,741000. 0206,32,0)
  48000   DME DELIVE RY CHARGES  HIST^NJ7, 0^^DME;1^K :+X'=X!(X> 9999999)!( X<0)!(X?.E 1"."1N.N)  X
  48001   "^DD",7410 00,741000. 0206,32,3)
  48002   Type a Num ber betwee n 0 and 99 99999, 0 D ecimal Dig its
  48003   "^DD",7410 00,741000. 0206,32,"D T")
  48004   2901019
  48005   "^DD",7410 00,741000. 0206,33,0)
  48006   DIAGNOSIS  REQUIRING  DME HIST^7 41000.2063 3P^^DME-DX ;0
  48007   "^DD",7410 00,741000. 0206,34,0)
  48008   DME SUPPLY  CODE HIST ^741000.20 634P^^DME- SUPPLY;0
  48009   "^DD",7410 00,741000. 0206,35,0)
  48010   DISCHARGE  DATE HIST^ D^^INP;1^S  %DT="E" D  ^%DT S X= Y K:Y<1 X
  48011   "^DD",7410 00,741000. 0206,35,"D T")
  48012   2901019
  48013   "^DD",7410 00,741000. 0206,36,0)
  48014   DISCHARGE  STATUS HIS T^P741002. 12'^CHMDIC (741002.12 ,^INP;2^Q
  48015   "^DD",7410 00,741000. 0206,36,"D T")
  48016   2901019
  48017   "^DD",7410 00,741000. 0206,37,0)
  48018   ADMITTING  DIAGNOSIS  HIST^P7410 06.05'^CHM ICDX(^INP; 3^Q
  48019   "^DD",7410 00,741000. 0206,37,"D T")
  48020   2901025
  48021   "^DD",7410 00,741000. 0206,38,0)
  48022   DISCHARGIN G PHYSICIA N HIST^F^^ INP;4^K:$L (X)>30!($L (X)<1) X
  48023   "^DD",7410 00,741000. 0206,38,3)
  48024   Answer mus t be 1-30  characters  in length .
  48025   "^DD",7410 00,741000. 0206,38,"D T")
  48026   2901019
  48027   "^DD",7410 00,741000. 0206,39,0)
  48028   ELIGIBILIT Y END DURI NG STAY H^ S^1:YES;0: NO;^INP;5^ Q
  48029   "^DD",7410 00,741000. 0206,39,"D T")
  48030   2901019
  48031   "^DD",7410 00,741000. 0206,40,0)
  48032   ELIGIBILIT Y END DATE  HIST^D^^I NP;6^S %DT ="E" D ^%D T S X=Y K: Y<1 X
  48033   "^DD",7410 00,741000. 0206,40,"D T")
  48034   2901019
  48035   "^DD",7410 00,741000. 0206,41,0)
  48036   FAC TYPE D ISCHARGED  TO HIST^P7 41002.11'^ CHMDIC(741 002.11,^IN P;7^Q
  48037   "^DD",7410 00,741000. 0206,41,"D T")
  48038   2910408
  48039   "^DD",7410 00,741000. 0206,42,0)
  48040   DISCHARGE  DIAGNOSIS  HIST^74100 0.20642P^^ INP-DX;0
  48041   "^DD",7410 00,741000. 0206,43,0)
  48042   DATE OF IT EMIZED CHA RGE HIST^7 41000.2064 3DA^^INP-I TEM;0
  48043   "^DD",7410 00,741000. 0206,44,0)
  48044   NON-COVERE D/OTHER IT EM HIST^74 1000.20644 P^^INP-NC; 0
  48045   "^DD",7410 00,741000. 0206,45,0)
  48046   PROCEDURES  PERFORMED  HIST^7410 00.20645P^ ^INP-PROC; 0
  48047   "^DD",7410 00,741000. 0206,46,0)
  48048   TYPE OF RO OM HIST^74 1000.20646 SA^^INP-RO OM;0
  48049   "^DD",7410 00,741000. 0206,47,0)
  48050   OUTPATIENT  CLINICIAN  HIST^F^^O PT;1^K:$L( X)>30!($L( X)<1) X
  48051   "^DD",7410 00,741000. 0206,47,3)
  48052   Answer mus t be 1-30  characters  in length .
  48053   "^DD",7410 00,741000. 0206,47,"D T")
  48054   2901022
  48055   "^DD",7410 00,741000. 0206,48,0)
  48056   REFERRING  CLINICIAN  HIST^F^^OP T;2^K:$L(X )>30!($L(X )<1) X
  48057   "^DD",7410 00,741000. 0206,48,3)
  48058   Answer mus t be 1-30  characters  in length .
  48059   "^DD",7410 00,741000. 0206,48,"D T")
  48060   2901022
  48061   "^DD",7410 00,741000. 0206,49,0)
  48062   OUTPATIENT  DIAGNOSIS  HIST^7410 00.20649PA ^^OPT-DX;0
  48063   "^DD",7410 00,741000. 0206,50,0)
  48064   OUTPATIENT  SERVICE H IST^741000 .0306P^^OP T-PROC;0
  48065   "^DD",7410 00,741000. 0207,0)
  48066   WORK FLOW  STATUS SUB -FIELD^^.0 3^3
  48067   "^DD",7410 00,741000. 0207,0,"DT ")
  48068   2920306
  48069   "^DD",7410 00,741000. 0207,0,"IX ","B",7410 00.0207,.0 1)
  48070  
  48071   "^DD",7410 00,741000. 0207,0,"NM ","WORK FL OW STATUS" )
  48072  
  48073   "^DD",7410 00,741000. 0207,0,"UP ")
  48074   741000
  48075   "^DD",7410 00,741000. 0207,.01,0 )
  48076   WORK FLOW  STATUS^P74 1002.25^CH MDIC(74100 2.25,^0;1^ Q
  48077   "^DD",7410 00,741000. 0207,.01,1 ,0)
  48078   ^.1^^0
  48079   "^DD",7410 00,741000. 0207,.01,1 ,1,0)
  48080   741000.020 7^B
  48081   "^DD",7410 00,741000. 0207,.01,1 ,1,1)
  48082   S ^CHMPAY( DA(1),2,"B ",$E(X,1,3 0),DA)=""
  48083   "^DD",7410 00,741000. 0207,.01,1 ,1,2)
  48084   K ^CHMPAY( DA(1),2,"B ",$E(X,1,3 0),DA)
  48085   "^DD",7410 00,741000. 0207,.01,3 )
  48086  
  48087   "^DD",7410 00,741000. 0207,.01," DT")
  48088   2901106
  48089   "^DD",7410 00,741000. 0207,.02,0 )
  48090   WORK FLOW  DATE^D^^0; 2^S %DT="E " D ^%DT S  X=Y K:Y<1  X
  48091   "^DD",7410 00,741000. 0207,.02," DT")
  48092   2901018
  48093   "^DD",7410 00,741000. 0207,.03,0 )
  48094   WORKFLOW D UZ^P3'^DIC (3,^0;3^Q
  48095   "^DD",7410 00,741000. 0207,.03," DT")
  48096   2920306
  48097   "^DD",7410 00,741000. 0242,0)
  48098   OHI PAYMEN T AMT SUB- FIELD^^.18 ^18
  48099   "^DD",7410 00,741000. 0242,0,"DT ")
  48100   3170927
  48101   "^DD",7410 00,741000. 0242,0,"IX ","B",7410 00.0242,.0 1)
  48102  
  48103   "^DD",7410 00,741000. 0242,0,"NM ","OHI PAY MENT AMT")
  48104  
  48105   "^DD",7410 00,741000. 0242,0,"UP ")
  48106   741000.014 2
  48107   "^DD",7410 00,741000. 0242,.01,0 )
  48108   OHI PAID A MT^NJ12,2^ ^0;1^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  48109   "^DD",7410 00,741000. 0242,.01,1 ,0)
  48110   ^.1
  48111   "^DD",7410 00,741000. 0242,.01,1 ,1,0)
  48112   741000.024 2^B
  48113   "^DD",7410 00,741000. 0242,.01,1 ,1,1)
  48114   S ^CHMPAY( DA(2),"DME -SUPPLY",D A(1),1,"B" ,$E(X,1,30 ),DA)=""
  48115   "^DD",7410 00,741000. 0242,.01,1 ,1,2)
  48116   K ^CHMPAY( DA(2),"DME -SUPPLY",D A(1),1,"B" ,$E(X,1,30 ),DA)
  48117   "^DD",7410 00,741000. 0242,.01,3 )
  48118   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48119   "^DD",7410 00,741000. 0242,.01,2 1,0)
  48120   ^^1^1^3110 204^
  48121   "^DD",7410 00,741000. 0242,.01,2 1,1,0)
  48122   PRIMARY OH I PAID AT  LINE LEVEL
  48123   "^DD",7410 00,741000. 0242,.01," DT")
  48124   3110204
  48125   "^DD",7410 00,741000. 0242,.02,0 )
  48126   OHI PATIEN T RESPONSI BILITY^NJ1 2,2^^0;2^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 999999999) !(X<0) X
  48127   "^DD",7410 00,741000. 0242,.02,3 )
  48128   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48129   "^DD",7410 00,741000. 0242,.02,2 1,0)
  48130   ^^1^1^3110 204^
  48131   "^DD",7410 00,741000. 0242,.02,2 1,1,0)
  48132   PRIMARY OH I PATIENT  RESPONSIBI LITY
  48133   "^DD",7410 00,741000. 0242,.02," DT")
  48134   3110204
  48135   "^DD",7410 00,741000. 0242,.03,0 )
  48136   ALL ADDITI ONAL OHI A MTS^NJ12,2 ^^0;3^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 999999)!(X <0) X
  48137   "^DD",7410 00,741000. 0242,.03,3 )
  48138   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48139   "^DD",7410 00,741000. 0242,.03,2 1,0)
  48140   ^^1^1^3110 204^
  48141   "^DD",7410 00,741000. 0242,.03,2 1,1,0)
  48142   ALL ADDITI ONAL OHI P AYMENTS FO R THE LINE  LEVEL
  48143   "^DD",7410 00,741000. 0242,.03," DT")
  48144   3110204
  48145   "^DD",7410 00,741000. 0242,.04,0 )
  48146   OHI PR BAL ANCE^NJ12, 2^^0;4^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 9999999)!( X<0) X
  48147   "^DD",7410 00,741000. 0242,.04,3 )
  48148   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48149   "^DD",7410 00,741000. 0242,.04,2 1,0)
  48150   ^^1^1^3110 204^
  48151   "^DD",7410 00,741000. 0242,.04,2 1,1,0)
  48152   OHI PATIEN T RESPONSI BILITY BAL ANCE FOR L INE LEVEL
  48153   "^DD",7410 00,741000. 0242,.04," DT")
  48154   3110204
  48155   "^DD",7410 00,741000. 0242,.05,0 )
  48156   MEDICAD PA ID^NJ12,2^ ^0;5^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0) X
  48157   "^DD",7410 00,741000. 0242,.05,3 )
  48158   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48159   "^DD",7410 00,741000. 0242,.05,2 1,0)
  48160   ^^1^1^3110 204^
  48161   "^DD",7410 00,741000. 0242,.05,2 1,1,0)
  48162   MEDICAD PA ID AT LINE  LEVEL
  48163   "^DD",7410 00,741000. 0242,.05," DT")
  48164   3110204
  48165   "^DD",7410 00,741000. 0242,.06,0 )
  48166   TPL PAID^N J12,2^^0;6 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>99999999 9)!(X<0) X
  48167   "^DD",7410 00,741000. 0242,.06,3 )
  48168   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48169   "^DD",7410 00,741000. 0242,.06,2 1,0)
  48170   ^^3^3^3110 204^
  48171   "^DD",7410 00,741000. 0242,.06,2 1,1,0)
  48172   IF A TPL A MOUNT WAS  ENTERED AT  THE CLAIM  OR SUBMIS SION LEVEL , THE SYST EM 
  48173   "^DD",7410 00,741000. 0242,.06,2 1,2,0)
  48174   SHALL AUTO MATICALLY  DISTRIBUTE  TPL TO TH E LINE LEV EL USING A  WEIGHTED 
  48175   "^DD",7410 00,741000. 0242,.06,2 1,3,0)
  48176   CALULATION .
  48177   "^DD",7410 00,741000. 0242,.06," DT")
  48178   3110204
  48179   "^DD",7410 00,741000. 0242,.07,0 )
  48180   COST/UNIT^ NJ12,2^^0; 7^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 99)!(X<0)! (X?.E1"."3 .N) X
  48181   "^DD",7410 00,741000. 0242,.07,3 )
  48182   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48183   "^DD",7410 00,741000. 0242,.07,2 1,0)
  48184   ^^1^1^3110 204^
  48185   "^DD",7410 00,741000. 0242,.07,2 1,1,0)
  48186   COST/UNIT  OR COST/QU ANTITY FOR  THE LINE  LEVEL
  48187   "^DD",7410 00,741000. 0242,.07," DT")
  48188   3110204
  48189   "^DD",7410 00,741000. 0242,.08,0 )
  48190   # UNITS AL LOWED^NJ7, 0^^0;8^K:+ X'=X!(X>99 99999)!(X< 0)!(X?.E1" ."1.N) X
  48191   "^DD",7410 00,741000. 0242,.08,3 )
  48192   Type a num ber betwee n 0 and 99 99999, 0 d ecimal dig its.
  48193   "^DD",7410 00,741000. 0242,.08,2 1,0)
  48194   ^^1^1^3110 204^
  48195   "^DD",7410 00,741000. 0242,.08,2 1,1,0)
  48196   NUMBER OF  UNITS OR Q UANTITY AL LOWED FOR  THE LINE L EVEL
  48197   "^DD",7410 00,741000. 0242,.08," DT")
  48198   3110204
  48199   "^DD",7410 00,741000. 0242,.09,0 )
  48200   CALCULATED  ALLOWED A MT^NJ12,2^ ^0;9^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  48201   "^DD",7410 00,741000. 0242,.09,3 )
  48202   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48203   "^DD",7410 00,741000. 0242,.09," DT")
  48204   3110204
  48205   "^DD",7410 00,741000. 0242,.1,0)
  48206   DEDUCTIBLE  AMT^NJ12, 2^^0;10^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  48207   "^DD",7410 00,741000. 0242,.1,3)
  48208   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48209   "^DD",7410 00,741000. 0242,.1,"D T")
  48210   3110111
  48211   "^DD",7410 00,741000. 0242,.11,0 )
  48212   COST SHARE  AMT^NJ12, 2^^0;11^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0)!(X?. E1"."3.N)  X
  48213   "^DD",7410 00,741000. 0242,.11,3 )
  48214   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48215   "^DD",7410 00,741000. 0242,.11," DT")
  48216   3110204
  48217   "^DD",7410 00,741000. 0242,.12,0 )
  48218   PAYMENT AM T^NJ12,2^^ 0;12^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  48219   "^DD",7410 00,741000. 0242,.12,3 )
  48220   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48221   "^DD",7410 00,741000. 0242,.12," DT")
  48222   3110204
  48223   "^DD",7410 00,741000. 0242,.13,0 )
  48224   PATIENT PA ID AMT^NJ1 2,2^^0;13^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >999999999 )!(X<0) X
  48225   "^DD",7410 00,741000. 0242,.13,3 )
  48226   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48227   "^DD",7410 00,741000. 0242,.13," DT")
  48228   3110111
  48229   "^DD",7410 00,741000. 0242,.14,0 )
  48230   CAT CAP AM T^NJ12,2^^ 0;14^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  48231   "^DD",7410 00,741000. 0242,.14,3 )
  48232   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48233   "^DD",7410 00,741000. 0242,.14," DT")
  48234   3110204
  48235   "^DD",7410 00,741000. 0242,.15,0 )
  48236   AMT PD TO  PROVIDER^N J13,2^^0;1 5^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 999)!(X<0)  X
  48237   "^DD",7410 00,741000. 0242,.15,3 )
  48238   Type a dol lar amount  between 0  and 99999 99999, 2 d ecimal dig its.
  48239   "^DD",7410 00,741000. 0242,.15," DT")
  48240   3110531
  48241   "^DD",7410 00,741000. 0242,.16,0 )
  48242   AMT PD TO  BENE^NJ13, 2^^0;16^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999999999) !(X<0) X
  48243   "^DD",7410 00,741000. 0242,.16,3 )
  48244   Type a dol lar amount  between 0  and 99999 99999, 2 d ecimal dig its.
  48245   "^DD",7410 00,741000. 0242,.16," DT")
  48246   3110531
  48247   "^DD",7410 00,741000. 0242,.17,0 )
  48248   PT TO CHMI MAGE LINE^ NJ8,0^^0;1 7^K:+X'=X! (X>9999999 9)!(X<1)!( X?.E1"."1N .N) X
  48249   "^DD",7410 00,741000. 0242,.17,3 )
  48250   Type a num ber betwee n 1 and 99 999999, 0  decimal di gits.
  48251   "^DD",7410 00,741000. 0242,.17," DT")
  48252   3110713
  48253   "^DD",7410 00,741000. 0242,.18,0 )
  48254   DED WAVIER ^S^1:YES;^ 0;18^Q
  48255   "^DD",7410 00,741000. 0242,.18,3 )
  48256   1 MEANS DE D AND COST  SHARE WAI VED, OTERW ISE NOT WA IVED
  48257   "^DD",7410 00,741000. 0242,.18,2 1,0)
  48258   ^^2^2^3170 927^
  48259   "^DD",7410 00,741000. 0242,.18,2 1,1,0)
  48260   1 MEANS DE D AND COST  SHARE WAI VED, OTHER WISE NOT W AIVED
  48261   "^DD",7410 00,741000. 0242,.18,2 1,2,0)
  48262  
  48263   "^DD",7410 00,741000. 0242,.18," DT")
  48264   3170927
  48265   "^DD",7410 00,741000. 0262,0)
  48266   OHI PAID A MT SUB-FIE LD^^.18^18
  48267   "^DD",7410 00,741000. 0262,0,"DT ")
  48268   3170927
  48269   "^DD",7410 00,741000. 0262,0,"IX ","B",7410 00.0262,.0 1)
  48270  
  48271   "^DD",7410 00,741000. 0262,0,"NM ","OHI PAI D AMT")
  48272  
  48273   "^DD",7410 00,741000. 0262,0,"UP ")
  48274   741000.016 2
  48275   "^DD",7410 00,741000. 0262,.01,0 )
  48276   OHI PAID A MT^NJ12,2^ ^0;1^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  48277   "^DD",7410 00,741000. 0262,.01,1 ,0)
  48278   ^.1
  48279   "^DD",7410 00,741000. 0262,.01,1 ,1,0)
  48280   741000.026 2^B
  48281   "^DD",7410 00,741000. 0262,.01,1 ,1,1)
  48282   S ^CHMPAY( DA(2),"OPT -PROC",DA( 1),1,"B",$ E(X,1,30), DA)=""
  48283   "^DD",7410 00,741000. 0262,.01,1 ,1,2)
  48284   K ^CHMPAY( DA(2),"OPT -PROC",DA( 1),1,"B",$ E(X,1,30), DA)
  48285   "^DD",7410 00,741000. 0262,.01,3 )
  48286   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48287   "^DD",7410 00,741000. 0262,.01,2 1,0)
  48288   ^^1^1^3110 207^
  48289   "^DD",7410 00,741000. 0262,.01,2 1,1,0)
  48290   PRIMARY OH I PAID AT  LINE LEVEL
  48291   "^DD",7410 00,741000. 0262,.01," DT")
  48292   3110207
  48293   "^DD",7410 00,741000. 0262,.02,0 )
  48294   OHI PATIEN T RESPONSI BILITY^NJ1 2,2^^0;2^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 999999999) !(X<0)!(X? .E1"."3.N)  X
  48295   "^DD",7410 00,741000. 0262,.02,3 )
  48296   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48297   "^DD",7410 00,741000. 0262,.02,2 1,0)
  48298   ^^1^1^3110 207^
  48299   "^DD",7410 00,741000. 0262,.02,2 1,1,0)
  48300   PRIMARY OH I PATIENT  RESPONSIBI LITY FOR T HE LINE LE VEL
  48301   "^DD",7410 00,741000. 0262,.02," DT")
  48302   3110207
  48303   "^DD",7410 00,741000. 0262,.03,0 )
  48304   ALL ADDITI ONAL OHI A MTS^NJ12,2 ^^0;3^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 999999)!(X <0)!(X?.E1 "."3.N) X
  48305   "^DD",7410 00,741000. 0262,.03,3 )
  48306   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48307   "^DD",7410 00,741000. 0262,.03,2 1,0)
  48308   ^^1^1^3110 207^
  48309   "^DD",7410 00,741000. 0262,.03,2 1,1,0)
  48310   ALL ADDITI ONAL OHI P AYMENTS FO R THE LINE  LEVEL
  48311   "^DD",7410 00,741000. 0262,.03," DT")
  48312   3110207
  48313   "^DD",7410 00,741000. 0262,.04,0 )
  48314   OHI PR BAL ANCE^NJ12, 2^^0;4^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 9999999)!( X<0) X
  48315   "^DD",7410 00,741000. 0262,.04,3 )
  48316   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48317   "^DD",7410 00,741000. 0262,.04,2 1,0)
  48318   ^^1^1^3110 207^
  48319   "^DD",7410 00,741000. 0262,.04,2 1,1,0)
  48320   OHI PATIEN T RESPONSI BILITY BAL ANCE FOR L INE LEVEL
  48321   "^DD",7410 00,741000. 0262,.04," DT")
  48322   3110207
  48323   "^DD",7410 00,741000. 0262,.05,0 )
  48324   MEDICAID P AID^NJ12,2 ^^0;5^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 999999)!(X <0) X
  48325   "^DD",7410 00,741000. 0262,.05,3 )
  48326   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48327   "^DD",7410 00,741000. 0262,.05,2 1,0)
  48328   ^^1^1^3110 207^
  48329   "^DD",7410 00,741000. 0262,.05,2 1,1,0)
  48330   MEDICAD PA ID AT LINE  LEVEL
  48331   "^DD",7410 00,741000. 0262,.05," DT")
  48332   3120924
  48333   "^DD",7410 00,741000. 0262,.06,0 )
  48334   TPL PAID^N J12,2^^0;6 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>99999999 9)!(X<0)!( X?.E1"."3. N) X
  48335   "^DD",7410 00,741000. 0262,.06,3 )
  48336   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48337   "^DD",7410 00,741000. 0262,.06,2 1,0)
  48338   ^^3^3^3110 207^
  48339   "^DD",7410 00,741000. 0262,.06,2 1,1,0)
  48340   IF A TPL A MOUNT WAS  ENTERED AT  THE CLAIM  OR SUBMIS SION LEVEL , THE SYST EM 
  48341   "^DD",7410 00,741000. 0262,.06,2 1,2,0)
  48342   SHALL AUTO MATICALLY  DISTRIBUTE  TPL TO TH E LINE LEV EL USING A  WEIGHTED 
  48343   "^DD",7410 00,741000. 0262,.06,2 1,3,0)
  48344   CALCULATIO N.
  48345   "^DD",7410 00,741000. 0262,.06," DT")
  48346   3110207
  48347   "^DD",7410 00,741000. 0262,.07,0 )
  48348   COST/UNIT^ NJ12,2^^0; 7^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 99)!(X<0)! (X?.E1"."3 .N) X
  48349   "^DD",7410 00,741000. 0262,.07,3 )
  48350   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48351   "^DD",7410 00,741000. 0262,.07,2 1,0)
  48352   ^^1^1^3110 207^
  48353   "^DD",7410 00,741000. 0262,.07,2 1,1,0)
  48354   COST/UNIT  OR COST/QU ANTITY FOR  THE LINE  LEVEL
  48355   "^DD",7410 00,741000. 0262,.07," DT")
  48356   3110207
  48357   "^DD",7410 00,741000. 0262,.08,0 )
  48358   # ALLOWED  UNITS^NJ7, 0^^0;8^K:+ X'=X!(X>99 99999)!(X< 0)!(X?.E1" ."1N.N) X
  48359   "^DD",7410 00,741000. 0262,.08,3 )
  48360   Type a num ber betwee n 0 and 99 99999, 0 d ecimal dig its.
  48361   "^DD",7410 00,741000. 0262,.08,2 1,0)
  48362   ^^1^1^3110 207^
  48363   "^DD",7410 00,741000. 0262,.08,2 1,1,0)
  48364   NUMBER OF  UNITS OR Q UANTITY AL LOWED FOR  LINE LEVEL
  48365   "^DD",7410 00,741000. 0262,.08," DT")
  48366   3110207
  48367   "^DD",7410 00,741000. 0262,.09,0 )
  48368   CALCULATED  ALLOWED A MT^NJ12,2^ ^0;9^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  48369   "^DD",7410 00,741000. 0262,.09,3 )
  48370   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48371   "^DD",7410 00,741000. 0262,.09," DT")
  48372   3110207
  48373   "^DD",7410 00,741000. 0262,.1,0)
  48374   DEDUCTIBLE  AMT^NJ12, 2^^0;10^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0)!(X?. E1"."3.N)  X
  48375   "^DD",7410 00,741000. 0262,.1,3)
  48376   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48377   "^DD",7410 00,741000. 0262,.1,"D T")
  48378   3110207
  48379   "^DD",7410 00,741000. 0262,.11,0 )
  48380   COST SHARE  AMT^NJ12, 2^^0;11^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  48381   "^DD",7410 00,741000. 0262,.11,3 )
  48382   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48383   "^DD",7410 00,741000. 0262,.11," DT")
  48384   3110111
  48385   "^DD",7410 00,741000. 0262,.12,0 )
  48386   PAYMENT AM OUNT^NJ12, 2^^0;12^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0)!(X?. E1"."3.N)  X
  48387   "^DD",7410 00,741000. 0262,.12,3 )
  48388   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48389   "^DD",7410 00,741000. 0262,.12," DT")
  48390   3110207
  48391   "^DD",7410 00,741000. 0262,.13,0 )
  48392   PATIENT PA ID AMT^NJ1 2,2^^0;13^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >999999999 )!(X<0)!(X ?.E1"."3.N ) X
  48393   "^DD",7410 00,741000. 0262,.13,3 )
  48394   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48395   "^DD",7410 00,741000. 0262,.13," DT")
  48396   3110207
  48397   "^DD",7410 00,741000. 0262,.14,0 )
  48398   CAT CAP AP PLIED AMT^ NJ12,2^^0; 14^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 999)!(X<0)  X
  48399   "^DD",7410 00,741000. 0262,.14,3 )
  48400   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  48401   "^DD",7410 00,741000. 0262,.14," DT")
  48402   3110111
  48403   "^DD",7410 00,741000. 0262,.15,0 )
  48404   AMT PD TO  PROVIDER^N J13,2^^0;1 5^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 999)!(X<0)  X
  48405   "^DD",7410 00,741000. 0262,.15,3 )
  48406   Type a dol lar amount  between 0  and 99999 99999, 2 d ecimal dig its.
  48407   "^DD",7410 00,741000. 0262,.15," DT")
  48408   3110531
  48409   "^DD",7410 00,741000. 0262,.16,0 )
  48410   AMT PD TO  BENE^NJ13, 2^^0;16^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999999999) !(X<0) X
  48411   "^DD",7410 00,741000. 0262,.16,3 )
  48412   Type a dol lar amount  between 0  and 99999 99999, 2 d ecimal dig its.
  48413   "^DD",7410 00,741000. 0262,.16," DT")
  48414   3110531
  48415   "^DD",7410 00,741000. 0262,.17,0 )
  48416   PT TO CHMI MAGE LINE^ NJ8,0^^0;1 7^K:+X'=X! (X>9999999 9)!(X<1)!( X?.E1"."1N .N) X
  48417   "^DD",7410 00,741000. 0262,.17,3 )
  48418   Type a num ber betwee n 1 and 99 999999, 0  decimal di gits.
  48419   "^DD",7410 00,741000. 0262,.17," DT")
  48420   3110713
  48421   "^DD",7410 00,741000. 0262,.18,0 )
  48422   DED WAIVER ^S^1:YES;^ 0;18^Q
  48423   "^DD",7410 00,741000. 0262,.18,3 )
  48424   1 MEANS DE D AND COST  SHARE WAI VED, OTHER WISE NOT W AIVED
  48425   "^DD",7410 00,741000. 0262,.18,2 1,0)
  48426   ^^2^2^3170 927^
  48427   "^DD",7410 00,741000. 0262,.18,2 1,1,0)
  48428   1 MEANS DE D AND COST  SHARE WAI VED, OTHER WISE NOT W AIVED
  48429   "^DD",7410 00,741000. 0262,.18,2 1,2,0)
  48430  
  48431   "^DD",7410 00,741000. 0262,.18," DT")
  48432   3170927
  48433   "^DD",7410 00,741000. 03,0)
  48434   DATE OF IT EMIZED CHA RGE SUB-FI ELD^^.07^7
  48435   "^DD",7410 00,741000. 03,0,"DT")
  48436   2910222
  48437   "^DD",7410 00,741000. 03,0,"IX", "B",741000 .03,.01)
  48438  
  48439   "^DD",7410 00,741000. 03,0,"NM", "DATE OF I TEMIZED CH ARGE")
  48440  
  48441   "^DD",7410 00,741000. 03,0,"UP")
  48442   741000
  48443   "^DD",7410 00,741000. 03,.01,0)
  48444   DATE OF IT EMIZED CHA RGE^DX^^0; 1^S %DT="E X" D ^%DT  S X=Y K:Y< 1 X
  48445   "^DD",7410 00,741000. 03,.01,1,0 )
  48446   ^.1^^0
  48447   "^DD",7410 00,741000. 03,.01,1,1 ,0)
  48448   741000.03^ B
  48449   "^DD",7410 00,741000. 03,.01,1,1 ,1)
  48450   S ^CHMPAY( DA(1),"INP -ITEM","B" ,$E(X,1,30 ),DA)=""
  48451   "^DD",7410 00,741000. 03,.01,1,1 ,2)
  48452   K ^CHMPAY( DA(1),"INP -ITEM","B" ,$E(X,1,30 ),DA)
  48453   "^DD",7410 00,741000. 03,.01,"DT ")
  48454   2910207
  48455   "^DD",7410 00,741000. 03,.02,0)
  48456   ITEM TYPE^ P741002.09 '^CHMDIC(7 41002.09,^ 0;2^Q
  48457   "^DD",7410 00,741000. 03,.03,0)
  48458   CHARGE FOR  ITEM^NJ10 ,2^^0;3^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999999)!(X <0) X
  48459   "^DD",7410 00,741000. 03,.03,3)
  48460   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  48461   "^DD",7410 00,741000. 03,.04,0)
  48462   PROFESSION AL SERVICE  CODE^P741 006^CHMSER V(^0;4^Q
  48463   "^DD",7410 00,741000. 03,.04,"DT ")
  48464   2900914
  48465   "^DD",7410 00,741000. 03,.05,0)
  48466   ITEMIZED C HARGE ALLO WABLE AMT^ NJ10,2^^0; 5^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 )!(X<0) X
  48467   "^DD",7410 00,741000. 03,.05,3)
  48468   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  48469   "^DD",7410 00,741000. 03,.05,"DT ")
  48470   2910222
  48471   "^DD",7410 00,741000. 03,.06,0)
  48472   NUMBER ANE STHESIA UN ITS^NJ7,2^ ^0;6^K:+X' =X!(X>9999 )!(X<0)!(X ?.E1"."3N. N) X
  48473   "^DD",7410 00,741000. 03,.06,3)
  48474   Type a Num ber betwee n 0 and 99 99, 2 Deci mal Digits
  48475   "^DD",7410 00,741000. 03,.06,"DT ")
  48476   2910222
  48477   "^DD",7410 00,741000. 03,.07,0)
  48478   ANESTHESIA  COST/UNIT ^NJ8,2^^0; 7^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>99999)! (X<0) X
  48479   "^DD",7410 00,741000. 03,.07,3)
  48480   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  48481   "^DD",7410 00,741000. 03,.07,"DT ")
  48482   2910222
  48483   "^DD",7410 00,741000. 0306,0)
  48484   OUTPATIENT  SERVICE H IST SUB-FI ELD^^1^2
  48485   "^DD",7410 00,741000. 0306,0,"IX ","B",7410 00.0306,.0 1)
  48486  
  48487   "^DD",7410 00,741000. 0306,0,"NM ","OUTPATI ENT SERVIC E HIST")
  48488  
  48489   "^DD",7410 00,741000. 0306,0,"UP ")
  48490   741000.020 6
  48491   "^DD",7410 00,741000. 0306,.01,0 )
  48492   OUTPATIENT  SERVICE H IST^P74100 6'^CHMSERV (^0;1^Q
  48493   "^DD",7410 00,741000. 0306,.01,1 ,0)
  48494   ^.1^^0
  48495   "^DD",7410 00,741000. 0306,.01,1 ,1,0)
  48496   741000.030 6^B
  48497   "^DD",7410 00,741000. 0306,.01,1 ,1,1)
  48498   S ^CHMPAY( DA(2),101, DA(1),"OPT -PROC","B" ,$E(X,1,30 ),DA)=""
  48499   "^DD",7410 00,741000. 0306,.01,1 ,1,2)
  48500   K ^CHMPAY( DA(2),101, DA(1),"OPT -PROC","B" ,$E(X,1,30 ),DA)
  48501   "^DD",7410 00,741000. 0306,.01," DT")
  48502   2901214
  48503   "^DD",7410 00,741000. 0306,1,0)
  48504   CHARGE FOR  SERVICE H IST^NJ11,2 ^^0;2^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 99999)!(X< 0) X
  48505   "^DD",7410 00,741000. 0306,1,3)
  48506   Type a Dol lar Amount  between 0  and 99999 999, 2 Dec imal Digit s
  48507   "^DD",7410 00,741000. 0306,1,"DT ")
  48508   2901022
  48509   "^DD",7410 00,741000. 04,0)
  48510   PDI NUMBER  SUB-FIELD ^^1^3
  48511   "^DD",7410 00,741000. 04,0,"DT")
  48512   2940516
  48513   "^DD",7410 00,741000. 04,0,"IX", "B",741000 .04,.01)
  48514  
  48515   "^DD",7410 00,741000. 04,0,"NM", "PDI NUMBE R")
  48516  
  48517   "^DD",7410 00,741000. 04,0,"UP")
  48518   741000
  48519   "^DD",7410 00,741000. 04,.01,0)
  48520   PDI NUMBER ^MNJ15,0a^ ^0;1^K:+X' =X!(X>9999 9999999999 9)!(X<0)!( X?.E1"."1N .N) X
  48521   "^DD",7410 00,741000. 04,.01,1,0 )
  48522   ^.1
  48523   "^DD",7410 00,741000. 04,.01,1,1 ,0)
  48524   741000^C
  48525   "^DD",7410 00,741000. 04,.01,1,1 ,1)
  48526   S ^CHMPAY( "C",$E(X,1 ,30),DA(1) ,DA)=""
  48527   "^DD",7410 00,741000. 04,.01,1,1 ,2)
  48528   K ^CHMPAY( "C",$E(X,1 ,30),DA(1) ,DA)
  48529   "^DD",7410 00,741000. 04,.01,3)
  48530   Type a Num ber betwee n 0 and 99 9999999999 999, 0 Dec imal Digit s
  48531   "^DD",7410 00,741000. 04,.01,"AU DIT")
  48532   y
  48533   "^DD",7410 00,741000. 04,.01,"DT ")
  48534   3170501
  48535   "^DD",7410 00,741000. 04,.02,0)
  48536   CORR PDI^S ^1:PDI FRO M CORR;0:R EOPEN PDI; ^0;2^Q
  48537   "^DD",7410 00,741000. 04,.02,"DT ")
  48538   2940516
  48539   "^DD",7410 00,741000. 04,1,0)
  48540   PAGE NUMBE R^741000.4 1^^PAGE;0
  48541   "^DD",7410 00,741000. 05,0)
  48542   RX NUMBER  SUB-FIELD^ ^.21^16
  48543   "^DD",7410 00,741000. 05,0,"DT")
  48544   3110713
  48545   "^DD",7410 00,741000. 05,0,"IX", "B",741000 .05,.01)
  48546  
  48547   "^DD",7410 00,741000. 05,0,"NM", "RX NUMBER ")
  48548  
  48549   "^DD",7410 00,741000. 05,0,"UP")
  48550   741000
  48551   "^DD",7410 00,741000. 05,.01,0)
  48552   RX NUMBER^ F^^0;1^K:$ L(X)>20!($ L(X)<1) X
  48553   "^DD",7410 00,741000. 05,.01,1,0 )
  48554   ^.1^^0
  48555   "^DD",7410 00,741000. 05,.01,1,1 ,0)
  48556   741000.05^ B
  48557   "^DD",7410 00,741000. 05,.01,1,1 ,1)
  48558   S ^CHMPAY( DA(1),"PHA RM","B",$E (X,1,30),D A)=""
  48559   "^DD",7410 00,741000. 05,.01,1,1 ,2)
  48560   K ^CHMPAY( DA(1),"PHA RM","B",$E (X,1,30),D A)
  48561   "^DD",7410 00,741000. 05,.01,3)
  48562   Answer mus t be 1-20  characters  in length .
  48563   "^DD",7410 00,741000. 05,.01,"DT ")
  48564   2901106
  48565   "^DD",7410 00,741000. 05,.02,0)
  48566   NDC CODE/D RUG PROVID ED^P741004 '^CHMPDX(^ 0;2^Q
  48567   "^DD",7410 00,741000. 05,.02,3)
  48568   Answer mus t be 1-20  characters  in length .
  48569   "^DD",7410 00,741000. 05,.02,"DT ")
  48570   2900912
  48571   "^DD",7410 00,741000. 05,.03,0)
  48572   FILL DATE^ D^^0;3^S % DT="EX" D  ^%DT S X=Y  K:Y<1 X
  48573   "^DD",7410 00,741000. 05,.03,"DT ")
  48574   2900912
  48575   "^DD",7410 00,741000. 05,.04,0)
  48576   CHARGED AM OUNT^NJ10, 2^^0;4^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 99999)!(X< 0) X
  48577   "^DD",7410 00,741000. 05,.04,3)
  48578   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  48579   "^DD",7410 00,741000. 05,.04,"DT ")
  48580   2900912
  48581   "^DD",7410 00,741000. 05,.05,0)
  48582   ALLOWABLE  AMOUNT^NJ1 0,2^^0;5^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 9999999)!( X<0) X
  48583   "^DD",7410 00,741000. 05,.05,3)
  48584   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  48585   "^DD",7410 00,741000. 05,.05,"DT ")
  48586   2900912
  48587   "^DD",7410 00,741000. 05,.06,0)
  48588   QUANTITY^N J5,0^^0;6^ K:+X'=X!(X >99999)!(X <0)!(X?.E1 "."1N.N) X
  48589   "^DD",7410 00,741000. 05,.06,3)
  48590   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  48591   "^DD",7410 00,741000. 05,.06,"DT ")
  48592   2900912
  48593   "^DD",7410 00,741000. 05,.07,0)
  48594   GENERIC IN DICATOR^S^ 1:YES;0:NO ;^0;7^Q
  48595   "^DD",7410 00,741000. 05,.07,"DT ")
  48596   2900912
  48597   "^DD",7410 00,741000. 05,.08,0)
  48598   PHARMACY D IAGNOSIS^7 41000.08P^ ^RX-DX;0
  48599   "^DD",7410 00,741000. 05,.08,"DT ")
  48600   2900926
  48601   "^DD",7410 00,741000. 05,.09,0)
  48602   PRESCRIBIN G PHYSICIA N^F^^0;8^K :$L(X)>30! ($L(X)<1)  X
  48603   "^DD",7410 00,741000. 05,.09,3)
  48604   Answer mus t be 1-30  characters  in length .
  48605   "^DD",7410 00,741000. 05,.09,"DT ")
  48606   2910204
  48607   "^DD",7410 00,741000. 05,.1,0)
  48608   CMOP DEFAU LT NDC^S^0 :NO;1:YES; ^0;9^Q
  48609   "^DD",7410 00,741000. 05,.1,"DT" )
  48610   2951113
  48611   "^DD",7410 00,741000. 05,.11,0)
  48612   ADJUSTED A LLOWABLE A MT^NJ9,2^^ 0;10^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99)!(X<0)  X
  48613   "^DD",7410 00,741000. 05,.11,3)
  48614   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  48615   "^DD",7410 00,741000. 05,.11,"DT ")
  48616   2970903
  48617   "^DD",7410 00,741000. 05,.12,0)
  48618   DUZ CHANGI NG ALLOW A MT^P200'^V A(200,^0;1 1^Q
  48619   "^DD",7410 00,741000. 05,.12,"DT ")
  48620   2970903
  48621   "^DD",7410 00,741000. 05,.13,0)
  48622   DATE/TIME  CHANGE ALL OW AMT^D^^ 0;12^S %DT ="E" D ^%D T S X=Y K: Y<1 X
  48623   "^DD",7410 00,741000. 05,.13,"DT ")
  48624   2970903
  48625   "^DD",7410 00,741000. 05,.14,0)
  48626   ICD-9 CODE ^P741006.0 5'^CHMICDX (^0;14^Q
  48627   "^DD",7410 00,741000. 05,.14,"DT ")
  48628   2970904
  48629   "^DD",7410 00,741000. 05,.15,0)
  48630   QUANTITY^N J6,0^^0;15 ^K:+X'=X!( X>999999)! (X<0)!(X?. E1"."1N.N)  X
  48631   "^DD",7410 00,741000. 05,.15,3)
  48632   Type a Num ber betwee n 0 and 99 9999, 0 De cimal Digi ts
  48633   "^DD",7410 00,741000. 05,.15,"DT ")
  48634   2970904
  48635   "^DD",7410 00,741000. 05,.21,0)
  48636   OHI PAID A MT^741000. 28A^^1;0
  48637   "^DD",7410 00,741000. 05,.21,21, 0)
  48638   ^^1^1^3110 207^
  48639   "^DD",7410 00,741000. 05,.21,21, 1,0)
  48640   LINE LEVEL  OHI DATA  ADDED BY E NC7820
  48641   "^DD",7410 00,741000. 05,.21,23, 0)
  48642   ^^1^1^3110 207^
  48643   "^DD",7410 00,741000. 05,.21,23, 1,0)
  48644   THIS MULTI PLE WAS AD DED FOR EN C7820
  48645   "^DD",7410 00,741000. 06,0)
  48646   COVERAGE C ODE (DX) S UB-FIELD^^ .07^7
  48647   "^DD",7410 00,741000. 06,0,"DT")
  48648   2910130
  48649   "^DD",7410 00,741000. 06,0,"IX", "B",741000 .06,.01)
  48650  
  48651   "^DD",7410 00,741000. 06,0,"NM", "COVERAGE  CODE (DX)" )
  48652  
  48653   "^DD",7410 00,741000. 06,0,"UP")
  48654   741000
  48655   "^DD",7410 00,741000. 06,.01,0)
  48656   COVERAGE C ODE (DX)^S ^0:REJECT; 1:ACCEPT;2 :QA ACCEPT ;3:MISSING  DATA;4:QA  REJECT;^0 ;1^Q
  48657   "^DD",7410 00,741000. 06,.01,1,0 )
  48658   ^.1^^0
  48659   "^DD",7410 00,741000. 06,.01,1,1 ,0)
  48660   741000.06^ B
  48661   "^DD",7410 00,741000. 06,.01,1,1 ,1)
  48662   S ^CHMPAY( DA(1),"RUL E-DX","B", $E(X,1,30) ,DA)=""
  48663   "^DD",7410 00,741000. 06,.01,1,1 ,2)
  48664   K ^CHMPAY( DA(1),"RUL E-DX","B", $E(X,1,30) ,DA)
  48665   "^DD",7410 00,741000. 06,.01,"DT ")
  48666   2910130
  48667   "^DD",7410 00,741000. 06,.02,0)
  48668   AI REASON  (DX)^P7410 02.22'^CHM DIC(741002 .22,^0;2^Q
  48669   "^DD",7410 00,741000. 06,.02,3)
  48670  
  48671   "^DD",7410 00,741000. 06,.02,"DT ")
  48672   2901106
  48673   "^DD",7410 00,741000. 06,.03,0)
  48674   FILE USED^ F^^0;3^K:$ L(X)>20!($ L(X)<1) X
  48675   "^DD",7410 00,741000. 06,.03,3)
  48676   Answer mus t be 1-20  characters  in length .
  48677   "^DD",7410 00,741000. 06,.03,"DT ")
  48678   2901014
  48679   "^DD",7410 00,741000. 06,.04,0)
  48680   LAST TEST^ F^^0;4^K:$ L(X)>20!($ L(X)<1) X
  48681   "^DD",7410 00,741000. 06,.04,3)
  48682   Answer mus t be 1-20  characters  in length .
  48683   "^DD",7410 00,741000. 06,.04,"DT ")
  48684   2901014
  48685   "^DD",7410 00,741000. 06,.05,0)
  48686   LAST RULE^ F^^0;5^K:$ L(X)>15!($ L(X)<1) X
  48687   "^DD",7410 00,741000. 06,.05,3)
  48688   Answer mus t be 1-15  characters  in length .
  48689   "^DD",7410 00,741000. 06,.05,"DT ")
  48690   2901014
  48691   "^DD",7410 00,741000. 06,.06,0)
  48692   LAST ELEME NT^F^^0;6^ K:$L(X)>5! ($L(X)<1)  X
  48693   "^DD",7410 00,741000. 06,.06,3)
  48694   Answer mus t be 1-5 c haracters  in length.
  48695   "^DD",7410 00,741000. 06,.06,"DT ")
  48696   2901014
  48697   "^DD",7410 00,741000. 06,.07,0)
  48698   OUTCOME^F^ ^0;7^K:$L( X)>7!($L(X )<1) X
  48699   "^DD",7410 00,741000. 06,.07,3)
  48700   Answer mus t be 1-7 c haracters  in length.
  48701   "^DD",7410 00,741000. 06,.07,"DT ")
  48702   2901014
  48703   "^DD",7410 00,741000. 07,0)
  48704   QUALITY AS SURANCE IN FORMATION  SUB-FIELD^ ^.07^7
  48705   "^DD",7410 00,741000. 07,0,"DT")
  48706   2910131
  48707   "^DD",7410 00,741000. 07,0,"IX", "B",741000 .07,.01)
  48708  
  48709   "^DD",7410 00,741000. 07,0,"NM", "QUALITY A SSURANCE I NFORMATION ")
  48710  
  48711   "^DD",7410 00,741000. 07,0,"UP")
  48712   741000
  48713   "^DD",7410 00,741000. 07,.01,0)
  48714   CODE TYPE^ S^0:DRG;1: DIAGNOSIS; 2:PROCEDUR E;3:PHARMA CY;^0;1^Q
  48715   "^DD",7410 00,741000. 07,.01,1,0 )
  48716   ^.1^^0
  48717   "^DD",7410 00,741000. 07,.01,1,1 ,0)
  48718   741000.07^ B
  48719   "^DD",7410 00,741000. 07,.01,1,1 ,1)
  48720   S ^CHMPAY( DA(1),"RUL E-QA","B", $E(X,1,30) ,DA)=""
  48721   "^DD",7410 00,741000. 07,.01,1,1 ,2)
  48722   K ^CHMPAY( DA(1),"RUL E-QA","B", $E(X,1,30) ,DA)
  48723   "^DD",7410 00,741000. 07,.01,"DT ")
  48724   2910212
  48725   "^DD",7410 00,741000. 07,.02,0)
  48726   DX/RX/DRG/ PROC CODE^ F^^0;2^K:$ L(X)>15!($ L(X)<1) X
  48727   "^DD",7410 00,741000. 07,.02,3)
  48728   Answer mus t be 1-15  characters  in length .
  48729   "^DD",7410 00,741000. 07,.02,"DT ")
  48730   2901101
  48731   "^DD",7410 00,741000. 07,.03,0)
  48732   RULE J VAL UE^NJ3,0^^ 0;3^K:+X'= X!(X>999)! (X<1)!(X?. E1"."1N.N)  X
  48733   "^DD",7410 00,741000. 07,.03,3)
  48734   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  48735   "^DD",7410 00,741000. 07,.03,"DT ")
  48736   2901101
  48737   "^DD",7410 00,741000. 07,.04,0)
  48738   QA RECOMME NDATION^S^ 0:REJECT;1 :APPROVE;2 :QA ACCEPT ;4:QA REJE CT;^0;4^Q
  48739   "^DD",7410 00,741000. 07,.04,3)
  48740  
  48741   "^DD",7410 00,741000. 07,.04,"DT ")
  48742   2910131
  48743   "^DD",7410 00,741000. 07,.05,0)
  48744   DUZ OF QA  REVIEW^P3^ DIC(3,^0;5 ^Q
  48745   "^DD",7410 00,741000. 07,.05,3)
  48746  
  48747   "^DD",7410 00,741000. 07,.05,"DT ")
  48748   2901101
  48749   "^DD",7410 00,741000. 07,.06,0)
  48750   COMMENTS^F ^^0;6^K:$L (X)>30!($L (X)<1) X
  48751   "^DD",7410 00,741000. 07,.06,3)
  48752   Answer mus t be 1-30  characters  in length .
  48753   "^DD",7410 00,741000. 07,.06,"DT ")
  48754   2901101
  48755   "^DD",7410 00,741000. 07,.07,0)
  48756   REASON FOR  CHANGING  STATUS^P74 1002.22'^C HMDIC(7410 02.22,^0;7 ^Q
  48757   "^DD",7410 00,741000. 07,.07,"DT ")
  48758   2910131
  48759   "^DD",7410 00,741000. 08,0)
  48760   PHARMACY D IAGNOSIS S UB-FIELD^^ .01^1
  48761   "^DD",7410 00,741000. 08,0,"NM", "PHARMACY  DIAGNOSIS" )
  48762  
  48763   "^DD",7410 00,741000. 08,0,"UP")
  48764   741000.05
  48765   "^DD",7410 00,741000. 08,.01,0)
  48766   PHARMACY D IAGNOSIS^P 741006.05' ^CHMICDX(^ 0;1^Q
  48767   "^DD",7410 00,741000. 08,.01,1,0 )
  48768   ^.1^^0
  48769   "^DD",7410 00,741000. 08,.01,"DT ")
  48770   2901106
  48771   "^DD",7410 00,741000. 09,0)
  48772   NOUN VALUE (S) SUB-FI ELD^^.01^1
  48773   "^DD",7410 00,741000. 09,0,"DT")
  48774   2910123
  48775   "^DD",7410 00,741000. 09,0,"IX", "B",741000 .09,.01)
  48776  
  48777   "^DD",7410 00,741000. 09,0,"NM", "NOUN VALU E(S)")
  48778  
  48779   "^DD",7410 00,741000. 09,0,"UP")
  48780   741000.01
  48781   "^DD",7410 00,741000. 09,.01,0)
  48782   NOUN VALUE (S)^F^^0;1 ^K:$L(X)>3 0!($L(X)<1 ) X
  48783   "^DD",7410 00,741000. 09,.01,1,0 )
  48784   ^.1^^0
  48785   "^DD",7410 00,741000. 09,.01,1,1 ,0)
  48786   741000.09^ B
  48787   "^DD",7410 00,741000. 09,.01,1,1 ,1)
  48788   S ^CHMPAY( DA(2),"ADD ",DA(1),"N OUN","B",$ E(X,1,30), DA)=""
  48789   "^DD",7410 00,741000. 09,.01,1,1 ,2)
  48790   K ^CHMPAY( DA(2),"ADD ",DA(1),"N OUN","B",$ E(X,1,30), DA)
  48791   "^DD",7410 00,741000. 09,.01,3)
  48792   Answer mus t be 1-30  characters  in length .
  48793   "^DD",7410 00,741000. 09,.01,"DT ")
  48794   2910212
  48795   "^DD",7410 00,741000. 11,0)
  48796   CMAC PROCE SSING DATE  SUB-FIELD ^^.02^2
  48797   "^DD",7410 00,741000. 11,0,"DT")
  48798   2961114
  48799   "^DD",7410 00,741000. 11,0,"IX", "B",741000 .11,.01)
  48800  
  48801   "^DD",7410 00,741000. 11,0,"NM", "CMAC PROC ESSING DAT E")
  48802  
  48803   "^DD",7410 00,741000. 11,0,"UP")
  48804   741000
  48805   "^DD",7410 00,741000. 11,.01,0)
  48806   CMAC PROCE SSING DATE ^DX^^0;1^S  %DT="EST"  D ^%DT S  X=Y K:Y<1  X S:$D(X)  DINUM=X
  48807   "^DD",7410 00,741000. 11,.01,1,0 )
  48808   ^.1
  48809   "^DD",7410 00,741000. 11,.01,1,1 ,0)
  48810   741000.11^ B
  48811   "^DD",7410 00,741000. 11,.01,1,1 ,1)
  48812   S ^CHMPAY( DA(1),"ZCM AC-PD","B" ,$E(X,1,30 ),DA)=""
  48813   "^DD",7410 00,741000. 11,.01,1,1 ,2)
  48814   K ^CHMPAY( DA(1),"ZCM AC-PD","B" ,$E(X,1,30 ),DA)
  48815   "^DD",7410 00,741000. 11,.01,"DT ")
  48816   2920928
  48817   "^DD",7410 00,741000. 11,.02,0)
  48818   CMAC SETTI NG DUZ^P20 0'^VA(200, ^0;2^Q
  48819   "^DD",7410 00,741000. 11,.02,"DT ")
  48820   2961114
  48821   "^DD",7410 00,741000. 12,0)
  48822   DENTAL DIA GNOSIS SUB -FIELD^^.0 1^1
  48823   "^DD",7410 00,741000. 12,0,"DT")
  48824   2921120
  48825   "^DD",7410 00,741000. 12,0,"IX", "B",741000 .12,.01)
  48826  
  48827   "^DD",7410 00,741000. 12,0,"NM", "DENTAL DI AGNOSIS")
  48828  
  48829   "^DD",7410 00,741000. 12,0,"UP")
  48830   741000
  48831   "^DD",7410 00,741000. 12,.01,0)
  48832   DENTAL DIA GNOSIS^P74 1006.05'^C HMICDX(^0; 1^Q
  48833   "^DD",7410 00,741000. 12,.01,1,0 )
  48834   ^.1
  48835   "^DD",7410 00,741000. 12,.01,1,1 ,0)
  48836   741000.12^ B
  48837   "^DD",7410 00,741000. 12,.01,1,1 ,1)
  48838   S ^CHMPAY( DA(1),"DEN -DX","B",$ E(X,1,30), DA)=""
  48839   "^DD",7410 00,741000. 12,.01,1,1 ,2)
  48840   K ^CHMPAY( DA(1),"DEN -DX","B",$ E(X,1,30), DA)
  48841   "^DD",7410 00,741000. 12,.01,"DT ")
  48842   2921120
  48843   "^DD",7410 00,741000. 13,0)
  48844   CORRESPOND ENCE DATE  TIME SUB-F IELD^^.02^ 2
  48845   "^DD",7410 00,741000. 13,0,"DT")
  48846   2930201
  48847   "^DD",7410 00,741000. 13,0,"IX", "B",741000 .13,.01)
  48848  
  48849   "^DD",7410 00,741000. 13,0,"NM", "CORRESPON DENCE DATE  TIME")
  48850  
  48851   "^DD",7410 00,741000. 13,0,"UP")
  48852   741000
  48853   "^DD",7410 00,741000. 13,.01,0)
  48854   CORRESPOND ENCE DATE  TIME^DX^^0 ;1^S %DT=" EST" D ^%D T S X=Y K: Y<1 X S:X' ="" DINUM= X
  48855   "^DD",7410 00,741000. 13,.01,1,0 )
  48856   ^.1
  48857   "^DD",7410 00,741000. 13,.01,1,1 ,0)
  48858   741000.13^ B
  48859   "^DD",7410 00,741000. 13,.01,1,1 ,1)
  48860   S ^CHMPAY( DA(1),"COR R","B",$E( X,1,30),DA )=""
  48861   "^DD",7410 00,741000. 13,.01,1,1 ,2)
  48862   K ^CHMPAY( DA(1),"COR R","B",$E( X,1,30),DA )
  48863   "^DD",7410 00,741000. 13,.01,"DT ")
  48864   2930201
  48865   "^DD",7410 00,741000. 13,.02,0)
  48866   CORRESPOND ENCE REASO N^741000.1 4^^1;0
  48867   "^DD",7410 00,741000. 14,0)
  48868   CORRESPOND ENCE REASO N SUB-FIEL D^^.01^1
  48869   "^DD",7410 00,741000. 14,0,"DT")
  48870   2930201
  48871   "^DD",7410 00,741000. 14,0,"IX", "B",741000 .14,.01)
  48872  
  48873   "^DD",7410 00,741000. 14,0,"NM", "CORRESPON DENCE REAS ON")
  48874  
  48875   "^DD",7410 00,741000. 14,0,"UP")
  48876   741000.13
  48877   "^DD",7410 00,741000. 14,.01,0)
  48878   CORRESPOND ENCE REASO N^F^^0;1^K :$L(X)>30! ($L(X)<1)  X
  48879   "^DD",7410 00,741000. 14,.01,1,0 )
  48880   ^.1
  48881   "^DD",7410 00,741000. 14,.01,1,1 ,0)
  48882   741000.14^ B
  48883   "^DD",7410 00,741000. 14,.01,1,1 ,1)
  48884   S ^CHMPAY( DA(2),"COR R",DA(1),1 ,"B",$E(X, 1,30),DA)= ""
  48885   "^DD",7410 00,741000. 14,.01,1,1 ,2)
  48886   K ^CHMPAY( DA(2),"COR R",DA(1),1 ,"B",$E(X, 1,30),DA)
  48887   "^DD",7410 00,741000. 14,.01,3)
  48888   Answer mus t be 1-30  characters  in length .
  48889   "^DD",7410 00,741000. 14,.01,"DT ")
  48890   2930201
  48891   "^DD",7410 00,741000. 20631,0)
  48892   DENTAL PRO CEDURE HIS T SUB-FIEL D^^3^4
  48893   "^DD",7410 00,741000. 20631,0,"I X","B",741 000.20631, .01)
  48894  
  48895   "^DD",7410 00,741000. 20631,0,"N M","DENTAL  PROCEDURE  HIST")
  48896  
  48897   "^DD",7410 00,741000. 20631,0,"U P")
  48898   741000.020 6
  48899   "^DD",7410 00,741000. 20631,.01, 0)
  48900   DENTAL PRO CEDURE HIS T^P741006' ^CHMSERV(^ 0;1^Q
  48901   "^DD",7410 00,741000. 20631,.01, 1,0)
  48902   ^.1^^0
  48903   "^DD",7410 00,741000. 20631,.01, 1,1,0)
  48904   741000.206 31^B
  48905   "^DD",7410 00,741000. 20631,.01, 1,1,1)
  48906   S ^CHMPAY( DA(2),101, DA(1),"DEN -PROC","B" ,$E(X,1,30 ),DA)=""
  48907   "^DD",7410 00,741000. 20631,.01, 1,1,2)
  48908   K ^CHMPAY( DA(2),101, DA(1),"DEN -PROC","B" ,$E(X,1,30 ),DA)
  48909   "^DD",7410 00,741000. 20631,.01, "DT")
  48910   2901214
  48911   "^DD",7410 00,741000. 20631,1,0)
  48912   PROCEDURE  CHARGE HIS T^NJ7,0^^0 ;2^K:+X'=X !(X>999999 9)!(X<0)!( X?.E1"."1N .N) X
  48913   "^DD",7410 00,741000. 20631,1,3)
  48914   Type a Num ber betwee n 0 and 99 99999, 0 D ecimal Dig its
  48915   "^DD",7410 00,741000. 20631,1,"D T")
  48916   2901019
  48917   "^DD",7410 00,741000. 20631,2,0)
  48918   TOOTH NUMB ER HIST^P7 41002.14'^ CHMDIC(741 002.14,^0; 3^Q
  48919   "^DD",7410 00,741000. 20631,2,"D T")
  48920   2901019
  48921   "^DD",7410 00,741000. 20631,3,0)
  48922   SURFACE HI ST^F^^0;4^ K:$L(X)>20 !($L(X)<1)  X
  48923   "^DD",7410 00,741000. 20631,3,3)
  48924   Answer mus t be 1-20  characters  in length .
  48925   "^DD",7410 00,741000. 20631,3,"D T")
  48926   2901019
  48927   "^DD",7410 00,741000. 20633,0)
  48928   DIAGNOSIS  REQUIRING  DME HIST S UB-FIELD^^ .01^1
  48929   "^DD",7410 00,741000. 20633,0,"I X","B",741 000.20633, .01)
  48930  
  48931   "^DD",7410 00,741000. 20633,0,"N M","DIAGNO SIS REQUIR ING DME HI ST")
  48932  
  48933   "^DD",7410 00,741000. 20633,0,"U P")
  48934   741000.020 6
  48935   "^DD",7410 00,741000. 20633,.01, 0)
  48936   DIAGNOSIS  REQUIRING  DME HIST^P 741006.05' ^CHMICDX(^ 0;1^Q
  48937   "^DD",7410 00,741000. 20633,.01, 1,0)
  48938   ^.1^^0
  48939   "^DD",7410 00,741000. 20633,.01, 1,1,0)
  48940   741000.206 33^B
  48941   "^DD",7410 00,741000. 20633,.01, 1,1,1)
  48942   S ^CHMPAY( DA(2),101, DA(1),"DME -DX","B",$ E(X,1,30), DA)=""
  48943   "^DD",7410 00,741000. 20633,.01, 1,1,2)
  48944   K ^CHMPAY( DA(2),101, DA(1),"DME -DX","B",$ E(X,1,30), DA)
  48945   "^DD",7410 00,741000. 20633,.01, "DT")
  48946   2901106
  48947   "^DD",7410 00,741000. 20634,0)
  48948   DME SUPPLY  CODE HIST  SUB-FIELD ^^2^3
  48949   "^DD",7410 00,741000. 20634,0,"I X","B",741 000.20634, .01)
  48950  
  48951   "^DD",7410 00,741000. 20634,0,"N M","DME SU PPLY CODE  HIST")
  48952  
  48953   "^DD",7410 00,741000. 20634,0,"U P")
  48954   741000.020 6
  48955   "^DD",7410 00,741000. 20634,.01, 0)
  48956   DME SUPPLY  CODE HIST ^P741006'^ CHMSERV(^0 ;1^Q
  48957   "^DD",7410 00,741000. 20634,.01, 1,0)
  48958   ^.1^^0
  48959   "^DD",7410 00,741000. 20634,.01, 1,1,0)
  48960   741000.206 34^B
  48961   "^DD",7410 00,741000. 20634,.01, 1,1,1)
  48962   S ^CHMPAY( DA(2),101, DA(1),"DME -SUPPLY"," B",$E(X,1, 30),DA)=""
  48963   "^DD",7410 00,741000. 20634,.01, 1,1,2)
  48964   K ^CHMPAY( DA(2),101, DA(1),"DME -SUPPLY"," B",$E(X,1, 30),DA)
  48965   "^DD",7410 00,741000. 20634,.01, "DT")
  48966   2901214
  48967   "^DD",7410 00,741000. 20634,1,0)
  48968   SUPPLY CHA RGE HIST^N J10,2^^0;2 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>9999999) !(X<0) X
  48969   "^DD",7410 00,741000. 20634,1,3)
  48970   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  48971   "^DD",7410 00,741000. 20634,1,"D T")
  48972   2901019
  48973   "^DD",7410 00,741000. 20634,2,0)
  48974   PURCHASE/L EASE HIST^ S^P:PURCHA SE;L:LEASE ;^0;3^Q
  48975   "^DD",7410 00,741000. 20634,2,"D T")
  48976   2901019
  48977   "^DD",7410 00,741000. 20642,0)
  48978   DISCHARGE  DIAGNOSIS  HIST SUB-F IELD^^.01^ 1
  48979   "^DD",7410 00,741000. 20642,0,"I X","B",741 000.20642, .01)
  48980  
  48981   "^DD",7410 00,741000. 20642,0,"N M","DISCHA RGE DIAGNO SIS HIST")
  48982  
  48983   "^DD",7410 00,741000. 20642,0,"U P")
  48984   741000.020 6
  48985   "^DD",7410 00,741000. 20642,.01, 0)
  48986   DISCHARGE  DIAGNOSIS  HIST^P7410 06.05'^CHM ICDX(^0;1^ Q
  48987   "^DD",7410 00,741000. 20642,.01, 1,0)
  48988   ^.1^^0
  48989   "^DD",7410 00,741000. 20642,.01, 1,1,0)
  48990   741000.206 42^B
  48991   "^DD",7410 00,741000. 20642,.01, 1,1,1)
  48992   S ^CHMPAY( DA(2),101, DA(1),"INP -DX","B",$ E(X,1,30), DA)=""
  48993   "^DD",7410 00,741000. 20642,.01, 1,1,2)
  48994   K ^CHMPAY( DA(2),101, DA(1),"INP -DX","B",$ E(X,1,30), DA)
  48995   "^DD",7410 00,741000. 20642,.01, "DT")
  48996   2901106
  48997   "^DD",7410 00,741000. 20643,0)
  48998   DATE OF IT EMIZED CHA RGE HIST S UB-FIELD^^ 3^4
  48999   "^DD",7410 00,741000. 20643,0,"I X","B",741 000.20643, .01)
  49000  
  49001   "^DD",7410 00,741000. 20643,0,"N M","DATE O F ITEMIZED  CHARGE HI ST")
  49002  
  49003   "^DD",7410 00,741000. 20643,0,"U P")
  49004   741000.020 6
  49005   "^DD",7410 00,741000. 20643,.01, 0)
  49006   DATE OF IT EMIZED CHA RGE HIST^D ^^0;1^S %D T="E" D ^% DT S X=Y K :Y<1 X
  49007   "^DD",7410 00,741000. 20643,.01, 1,0)
  49008   ^.1^^0
  49009   "^DD",7410 00,741000. 20643,.01, 1,1,0)
  49010   741000.206 43^B
  49011   "^DD",7410 00,741000. 20643,.01, 1,1,1)
  49012   S ^CHMPAY( DA(2),101, DA(1),"INP -ITEM","B" ,$E(X,1,30 ),DA)=""
  49013   "^DD",7410 00,741000. 20643,.01, 1,1,2)
  49014   K ^CHMPAY( DA(2),101, DA(1),"INP -ITEM","B" ,$E(X,1,30 ),DA)
  49015   "^DD",7410 00,741000. 20643,.01, "DT")
  49016   2901106
  49017   "^DD",7410 00,741000. 20643,1,0)
  49018   ITEM TYPE  HIST^P7410 02.09'^CHM DIC(741002 .09,^0;2^Q
  49019   "^DD",7410 00,741000. 20643,1,"D T")
  49020   2901019
  49021   "^DD",7410 00,741000. 20643,2,0)
  49022   CHARGE FOR  ITEM HIST ^NJ10,2^^0 ;3^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 9)!(X<0) X
  49023   "^DD",7410 00,741000. 20643,2,3)
  49024   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  49025   "^DD",7410 00,741000. 20643,2,"D T")
  49026   2901019
  49027   "^DD",7410 00,741000. 20643,3,0)
  49028   PROFESSION AL SERVICE  CODE HIST ^P741006'^ CHMSERV(^0 ;4^Q
  49029   "^DD",7410 00,741000. 20643,3,"D T")
  49030   2901019
  49031   "^DD",7410 00,741000. 20644,0)
  49032   NON-COVERE D/OTHER IT EM HIST SU B-FIELD^^2 ^3
  49033   "^DD",7410 00,741000. 20644,0,"I X","B",741 000.20644, .01)
  49034  
  49035   "^DD",7410 00,741000. 20644,0,"N M","NON-CO VERED/OTHE R ITEM HIS T")
  49036  
  49037   "^DD",7410 00,741000. 20644,0,"U P")
  49038   741000.020 6
  49039   "^DD",7410 00,741000. 20644,.01, 0)
  49040   NON-COVERE D/OTHER IT EM HIST^P7 41002.09'^ CHMDIC(741 002.09,^0; 1^Q
  49041   "^DD",7410 00,741000. 20644,.01, 1,0)
  49042   ^.1^^0
  49043   "^DD",7410 00,741000. 20644,.01, 1,1,0)
  49044   741000.206 44^B
  49045   "^DD",7410 00,741000. 20644,.01, 1,1,1)
  49046   S ^CHMPAY( DA(2),101, DA(1),"INP -NC","B",$ E(X,1,30), DA)=""
  49047   "^DD",7410 00,741000. 20644,.01, 1,1,2)
  49048   K ^CHMPAY( DA(2),101, DA(1),"INP -NC","B",$ E(X,1,30), DA)
  49049   "^DD",7410 00,741000. 20644,.01, "DT")
  49050   2901106
  49051   "^DD",7410 00,741000. 20644,1,0)
  49052   NON-COVERE D/OTHER CH ARGE HIST^ NJ7,0^^0;2 ^K:+X'=X!( X>9999999) !(X<0)!(X? .E1"."1N.N ) X
  49053   "^DD",7410 00,741000. 20644,1,3)
  49054   Type a Num ber betwee n 0 and 99 99999, 0 D ecimal Dig its
  49055   "^DD",7410 00,741000. 20644,1,"D T")
  49056   2901019
  49057   "^DD",7410 00,741000. 20644,2,0)
  49058   PROFESSION AL SERVICE  CODE HIST ^P741006'^ CHMSERV(^0 ;3^Q
  49059   "^DD",7410 00,741000. 20644,2,"D T")
  49060   2901019
  49061   "^DD",7410 00,741000. 20645,0)
  49062   PROCEDURES  PERFORMED  HIST SUB- FIELD^^.01 ^1
  49063   "^DD",7410 00,741000. 20645,0,"I X","B",741 000.20645, .01)
  49064  
  49065   "^DD",7410 00,741000. 20645,0,"N M","PROCED URES PERFO RMED HIST" )
  49066  
  49067   "^DD",7410 00,741000. 20645,0,"U P")
  49068   741000.020 6
  49069   "^DD",7410 00,741000. 20645,.01, 0)
  49070   PROCEDURES  PERFORMED  HIST^P741 006'^CHMSE RV(^0;1^Q
  49071   "^DD",7410 00,741000. 20645,.01, 1,0)
  49072   ^.1^^0
  49073   "^DD",7410 00,741000. 20645,.01, 1,1,0)
  49074   741000.206 45^B
  49075   "^DD",7410 00,741000. 20645,.01, 1,1,1)
  49076   S ^CHMPAY( DA(2),101, DA(1),"INP -PROC","B" ,$E(X,1,30 ),DA)=""
  49077   "^DD",7410 00,741000. 20645,.01, 1,1,2)
  49078   K ^CHMPAY( DA(2),101, DA(1),"INP -PROC","B" ,$E(X,1,30 ),DA)
  49079   "^DD",7410 00,741000. 20645,.01, "DT")
  49080   2901106
  49081   "^DD",7410 00,741000. 20646,0)
  49082   TYPE OF RO OM HIST SU B-FIELD^^2 ^3
  49083   "^DD",7410 00,741000. 20646,0,"I X","B",741 000.20646, .01)
  49084  
  49085   "^DD",7410 00,741000. 20646,0,"N M","TYPE O F ROOM HIS T")
  49086  
  49087   "^DD",7410 00,741000. 20646,0,"U P")
  49088   741000.020 6
  49089   "^DD",7410 00,741000. 20646,.01, 0)
  49090   TYPE OF RO OM HIST^S^ 1:INTENSIV E CARE;2:C ORONARY CA RE;3:ISOLA TION;4:WAR D ROOM;5:S EMI-PRIVAT E;6:PRIVAT E;7:OTHER; ^0;1^Q
  49091   "^DD",7410 00,741000. 20646,.01, 1,0)
  49092   ^.1^^0
  49093   "^DD",7410 00,741000. 20646,.01, 1,1,0)
  49094   741000.206 46^B
  49095   "^DD",7410 00,741000. 20646,.01, 1,1,1)
  49096   S ^CHMPAY( DA(2),101, DA(1),"INP -ROOM","B" ,$E(X,1,30 ),DA)=""
  49097   "^DD",7410 00,741000. 20646,.01, 1,1,2)
  49098   K ^CHMPAY( DA(2),101, DA(1),"INP -ROOM","B" ,$E(X,1,30 ),DA)
  49099   "^DD",7410 00,741000. 20646,.01, "DT")
  49100   2901106
  49101   "^DD",7410 00,741000. 20646,1,0)
  49102   ROOM RATE  HIST^NJ5,0 ^^0;2^K:+X '=X!(X>999 99)!(X<0)! (X?.E1"."1 N.N) X
  49103   "^DD",7410 00,741000. 20646,1,3)
  49104   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  49105   "^DD",7410 00,741000. 20646,1,"D T")
  49106   2901019
  49107   "^DD",7410 00,741000. 20646,2,0)
  49108   NUMBER OF  DAYS IN RO OM HIST^NJ 3,0^^0;3^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X
  49109   "^DD",7410 00,741000. 20646,2,3)
  49110   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  49111   "^DD",7410 00,741000. 20646,2,"D T")
  49112   2901019
  49113   "^DD",7410 00,741000. 20649,0)
  49114   OUTPATIENT  DIAGNOSIS  HIST SUB- FIELD^^.01 ^1
  49115   "^DD",7410 00,741000. 20649,0,"I X","B",741 000.20649, .01)
  49116  
  49117   "^DD",7410 00,741000. 20649,0,"N M","OUTPAT IENT DIAGN OSIS HIST" )
  49118  
  49119   "^DD",7410 00,741000. 20649,0,"U P")
  49120   741000.020 6
  49121   "^DD",7410 00,741000. 20649,.01, 0)
  49122   OUTPATIENT  DIAGNOSIS  HIST^P741 006.05'^CH MICDX(^0;1 ^Q
  49123   "^DD",7410 00,741000. 20649,.01, 1,0)
  49124   ^.1^^0
  49125   "^DD",7410 00,741000. 20649,.01, 1,1,0)
  49126   741000.206 49^B
  49127   "^DD",7410 00,741000. 20649,.01, 1,1,1)
  49128   S ^CHMPAY( DA(2),101, DA(1),"OPT -DX","B",$ E(X,1,30), DA)=""
  49129   "^DD",7410 00,741000. 20649,.01, 1,1,2)
  49130   K ^CHMPAY( DA(2),101, DA(1),"OPT -DX","B",$ E(X,1,30), DA)
  49131   "^DD",7410 00,741000. 20649,.01, "DT")
  49132   2901106
  49133   "^DD",7410 00,741000. 27,0)
  49134   OHI PAID A MT SUB-FIE LD^^.18^18
  49135   "^DD",7410 00,741000. 27,0,"DT")
  49136   3170927
  49137   "^DD",7410 00,741000. 27,0,"IX", "B",741000 .27,.01)
  49138  
  49139   "^DD",7410 00,741000. 27,0,"NM", "OHI PAID  AMT")
  49140  
  49141   "^DD",7410 00,741000. 27,0,"UP")
  49142   741000.02
  49143   "^DD",7410 00,741000. 27,.01,0)
  49144   OHI PAID A MT^NJ12,2^ ^0;1^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0) X
  49145   "^DD",7410 00,741000. 27,.01,1,0 )
  49146   ^.1
  49147   "^DD",7410 00,741000. 27,.01,1,1 ,0)
  49148   741000.27^ B
  49149   "^DD",7410 00,741000. 27,.01,1,1 ,1)
  49150   S ^CHMPAY( DA(2),"DEN -PROC",DA( 1),1,"B",$ E(X,1,30), DA)=""
  49151   "^DD",7410 00,741000. 27,.01,1,1 ,2)
  49152   K ^CHMPAY( DA(2),"DEN -PROC",DA( 1),1,"B",$ E(X,1,30), DA)
  49153   "^DD",7410 00,741000. 27,.01,3)
  49154   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49155   "^DD",7410 00,741000. 27,.01,21, 0)
  49156   ^^1^1^3110 127^^
  49157   "^DD",7410 00,741000. 27,.01,21, 1,0)
  49158   PRIMARY OH I PAID AT  LINE LEVEL
  49159   "^DD",7410 00,741000. 27,.01,"DT ")
  49160   3110127
  49161   "^DD",7410 00,741000. 27,.02,0)
  49162   OHI PATIEN T RESPONSI BILITY^NJ1 2,2^^0;2^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 999999999) !(X<0) X
  49163   "^DD",7410 00,741000. 27,.02,3)
  49164   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49165   "^DD",7410 00,741000. 27,.02,21, 0)
  49166   ^^1^1^3110 127^^
  49167   "^DD",7410 00,741000. 27,.02,21, 1,0)
  49168   PRIMARY OH I PATIENT  RESPONSIBI LITY FOR T HE LINE LE VEL
  49169   "^DD",7410 00,741000. 27,.02,"DT ")
  49170   3110127
  49171   "^DD",7410 00,741000. 27,.03,0)
  49172   ALL ADDITI ONAL OHI P AYMENTS^NJ 12,2^^0;3^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >999999999 )!(X<0) X
  49173   "^DD",7410 00,741000. 27,.03,3)
  49174   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49175   "^DD",7410 00,741000. 27,.03,21, 0)
  49176   ^^1^1^3110 127^
  49177   "^DD",7410 00,741000. 27,.03,21, 1,0)
  49178   ALL ADDITI ONAL OHI P AYMENTS FO R THE LINE  LEVEL
  49179   "^DD",7410 00,741000. 27,.03,"DT ")
  49180   3110127
  49181   "^DD",7410 00,741000. 27,.04,0)
  49182   OHI PR BAL ANCE^NJ12, 2^^0;4^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 9999999)!( X<0) X
  49183   "^DD",7410 00,741000. 27,.04,3)
  49184   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49185   "^DD",7410 00,741000. 27,.04,21, 0)
  49186   ^^1^1^3110 127^
  49187   "^DD",7410 00,741000. 27,.04,21, 1,0)
  49188   OHI PATIEN T RESPONSI BILITY BAL ANCE FOR L INE LEVEL
  49189   "^DD",7410 00,741000. 27,.04,"DT ")
  49190   3110127
  49191   "^DD",7410 00,741000. 27,.05,0)
  49192   MEDICAD PA ID^NJ12,2^ ^0;5^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0) X
  49193   "^DD",7410 00,741000. 27,.05,3)
  49194   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49195   "^DD",7410 00,741000. 27,.05,21, 0)
  49196   ^^1^1^3110 204^^
  49197   "^DD",7410 00,741000. 27,.05,21, 1,0)
  49198   MEDICAD PA ID AT LINE  LEVEL
  49199   "^DD",7410 00,741000. 27,.05,"DT ")
  49200   3110204
  49201   "^DD",7410 00,741000. 27,.06,0)
  49202   TPL PAID^N J12,2^^0;6 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>99999999 9)!(X<0)!( X?.E1"."3. N) X
  49203   "^DD",7410 00,741000. 27,.06,3)
  49204   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49205   "^DD",7410 00,741000. 27,.06,21, 0)
  49206   ^^2^2^3110 204^
  49207   "^DD",7410 00,741000. 27,.06,21, 1,0)
  49208   IF A TPL A MOUNT WAS  ENTERED AT  THE CLAIM  OR SUBMIS SION LEVEL , THE SYST EM SHALL
  49209   "^DD",7410 00,741000. 27,.06,21, 2,0)
  49210   AUTOMATICA LLY DISTRI BUTE TPL T O THE LINE  LEVEL USI NG A WEIGH TED CALCUL ATION.
  49211   "^DD",7410 00,741000. 27,.06,"DT ")
  49212   3110204
  49213   "^DD",7410 00,741000. 27,.07,0)
  49214   COST/UNIT^ NJ12,2^^0; 7^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 99)!(X<0)! (X?.E1"."3 .N) X
  49215   "^DD",7410 00,741000. 27,.07,3)
  49216   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49217   "^DD",7410 00,741000. 27,.07,21, 0)
  49218   ^^1^1^3110 204^
  49219   "^DD",7410 00,741000. 27,.07,21, 1,0)
  49220   COST/UNIT  OR COST/QU ANTITY FOR  THE LINE  LEVEL
  49221   "^DD",7410 00,741000. 27,.07,"DT ")
  49222   3110204
  49223   "^DD",7410 00,741000. 27,.08,0)
  49224   # UNITS AL LOWED^NJ7, 0^^0;8^K:+ X'=X!(X>99 99999)!(X< 0)!(X?.E1" ."1.N) X
  49225   "^DD",7410 00,741000. 27,.08,3)
  49226   Type a num ber betwee n 0 and 99 99999, 0 d ecimal dig its.
  49227   "^DD",7410 00,741000. 27,.08,21, 0)
  49228   ^^1^1^3110 204^
  49229   "^DD",7410 00,741000. 27,.08,21, 1,0)
  49230   NUMBER OF  UNITS OR Q UANTITY AL LOWED FOR  LINE LEVEL
  49231   "^DD",7410 00,741000. 27,.08,"DT ")
  49232   3110204
  49233   "^DD",7410 00,741000. 27,.09,0)
  49234   CALCULATED  ALLOWED A MOUNT^NJ12 ,2^^0;9^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  49235   "^DD",7410 00,741000. 27,.09,3)
  49236   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49237   "^DD",7410 00,741000. 27,.09,"DT ")
  49238   3110120
  49239   "^DD",7410 00,741000. 27,.1,0)
  49240   DEDUCTIBLE  AMT^NJ12, 2^^0;10^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  49241   "^DD",7410 00,741000. 27,.1,3)
  49242   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49243   "^DD",7410 00,741000. 27,.1,"DT" )
  49244   3110120
  49245   "^DD",7410 00,741000. 27,.11,0)
  49246   COST SHARE  AMT^NJ12, 2^^0;11^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  49247   "^DD",7410 00,741000. 27,.11,3)
  49248   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49249   "^DD",7410 00,741000. 27,.11,"DT ")
  49250   3110120
  49251   "^DD",7410 00,741000. 27,.12,0)
  49252   PAYMENT AM OUNT^NJ12, 2^^0;12^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  49253   "^DD",7410 00,741000. 27,.12,3)
  49254   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49255   "^DD",7410 00,741000. 27,.12,"DT ")
  49256   3110120
  49257   "^DD",7410 00,741000. 27,.13,0)
  49258   PATIENT PA ID AMT^NJ1 2,2^^0;13^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >999999999 )!(X<0) X
  49259   "^DD",7410 00,741000. 27,.13,3)
  49260   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49261   "^DD",7410 00,741000. 27,.13,"DT ")
  49262   3110204
  49263   "^DD",7410 00,741000. 27,.14,0)
  49264   CAT CAP AP PLIED AMT^ NJ12,2^^0; 14^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 999)!(X<0)  X
  49265   "^DD",7410 00,741000. 27,.14,3)
  49266   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49267   "^DD",7410 00,741000. 27,.14,"DT ")
  49268   3110111
  49269   "^DD",7410 00,741000. 27,.15,0)
  49270   AMT PD TO  PROVIDER^N J13,2^^0;1 5^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 999)!(X<0)  X
  49271   "^DD",7410 00,741000. 27,.15,3)
  49272   Type a dol lar amount  between 0  and 99999 99999, 2 d ecimal dig its.
  49273   "^DD",7410 00,741000. 27,.15,"DT ")
  49274   3110531
  49275   "^DD",7410 00,741000. 27,.16,0)
  49276   AMT PD TO  BENE^NJ11, 2^^0;16^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 9999999)!( X<0) X
  49277   "^DD",7410 00,741000. 27,.16,3)
  49278   Type a dol lar amount  between 0  and 99999 999, 2 dec imal digit s.
  49279   "^DD",7410 00,741000. 27,.16,"DT ")
  49280   3110531
  49281   "^DD",7410 00,741000. 27,.17,0)
  49282   PT TO CHMI MAGE LINE^ NJ8,0^^0;1 7^K:+X'=X! (X>9999999 9)!(X<1)!( X?.E1"."1N .N) X
  49283   "^DD",7410 00,741000. 27,.17,3)
  49284   Type a num ber betwee n 1 and 99 999999, 0  decimal di gits.
  49285   "^DD",7410 00,741000. 27,.17,"DT ")
  49286   3110713
  49287   "^DD",7410 00,741000. 27,.18,0)
  49288   DED WAVIER ^S^1:YES;^ 0;18^Q
  49289   "^DD",7410 00,741000. 27,.18,"DT ")
  49290   3170927
  49291   "^DD",7410 00,741000. 28,0)
  49292   OHI PAID A MT SUB-FIE LD^^.18^18
  49293   "^DD",7410 00,741000. 28,0,"DT")
  49294   3170927
  49295   "^DD",7410 00,741000. 28,0,"IX", "B",741000 .28,.01)
  49296  
  49297   "^DD",7410 00,741000. 28,0,"NM", "OHI PAID  AMT")
  49298  
  49299   "^DD",7410 00,741000. 28,0,"UP")
  49300   741000.05
  49301   "^DD",7410 00,741000. 28,.01,0)
  49302   OHI PAID A MT^NJ12,2^ ^0;1^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  49303   "^DD",7410 00,741000. 28,.01,1,0 )
  49304   ^.1
  49305   "^DD",7410 00,741000. 28,.01,1,1 ,0)
  49306   741000.28^ B
  49307   "^DD",7410 00,741000. 28,.01,1,1 ,1)
  49308   S ^CHMPAY( DA(2),"PHA RM",DA(1), 1,"B",$E(X ,1,30),DA) =""
  49309   "^DD",7410 00,741000. 28,.01,1,1 ,2)
  49310   K ^CHMPAY( DA(2),"PHA RM",DA(1), 1,"B",$E(X ,1,30),DA)
  49311   "^DD",7410 00,741000. 28,.01,3)
  49312   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49313   "^DD",7410 00,741000. 28,.01,21, 0)
  49314   ^^1^1^3110 207^
  49315   "^DD",7410 00,741000. 28,.01,21, 1,0)
  49316   PRIMARY OH I PAID AT  LINE LEVEL
  49317   "^DD",7410 00,741000. 28,.01,"DT ")
  49318   3110207
  49319   "^DD",7410 00,741000. 28,.02,0)
  49320   OHI PATIEN T RESPONSI BILITY^NJ1 2,2^^0;2^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 999999999) !(X<0) X
  49321   "^DD",7410 00,741000. 28,.02,3)
  49322   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49323   "^DD",7410 00,741000. 28,.02,21, 0)
  49324   ^^1^1^3110 207^
  49325   "^DD",7410 00,741000. 28,.02,21, 1,0)
  49326   PRIMARY OH I PATIENT  RESPONSIBI LITY FOR L INE LEVEL
  49327   "^DD",7410 00,741000. 28,.02,"DT ")
  49328   3110207
  49329   "^DD",7410 00,741000. 28,.03,0)
  49330   ALL ADDITI ONAL OHI A MTS^NJ9,0^ ^0;3^K:+X' =X!(X>9999 99999)!(X< 0)!(X?.E1" ."1.N) X
  49331   "^DD",7410 00,741000. 28,.03,3)
  49332   Type a num ber betwee n 0 and 99 9999999, 0  decimal d igits.
  49333   "^DD",7410 00,741000. 28,.03,21, 0)
  49334   ^^1^1^3110 207^
  49335   "^DD",7410 00,741000. 28,.03,21, 1,0)
  49336   ALL ADDITI ONAL OHI P AYMENTS FO R THE LINE  LEVEL
  49337   "^DD",7410 00,741000. 28,.03,"DT ")
  49338   3110207
  49339   "^DD",7410 00,741000. 28,.04,0)
  49340   OHI PR BAL ANCE^NJ12, 2^^0;4^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 9999999)!( X<0)!(X?.E 1"."3.N) X
  49341   "^DD",7410 00,741000. 28,.04,3)
  49342   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49343   "^DD",7410 00,741000. 28,.04,21, 0)
  49344   ^^1^1^3110 207^
  49345   "^DD",7410 00,741000. 28,.04,21, 1,0)
  49346   OHI PATIEN T RESPONSI BILITY BAL ANCE FOR L INE LEVEL
  49347   "^DD",7410 00,741000. 28,.04,"DT ")
  49348   3110207
  49349   "^DD",7410 00,741000. 28,.05,0)
  49350   MEDICAD PA ID^NJ12,2^ ^0;5^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  49351   "^DD",7410 00,741000. 28,.05,3)
  49352   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49353   "^DD",7410 00,741000. 28,.05,21, 0)
  49354   ^^1^1^3110 207^
  49355   "^DD",7410 00,741000. 28,.05,21, 1,0)
  49356   MEDICAD PA ID AT LINE  LEVEL
  49357   "^DD",7410 00,741000. 28,.05,"DT ")
  49358   3110207
  49359   "^DD",7410 00,741000. 28,.06,0)
  49360   TPL PAID^N J12,2^^0;6 ^S:X["$" X =$P(X,"$", 2) K:X'?.N .1".".2N!( X>99999999 9)!(X<0)!( X?.E1"."3. N) X
  49361   "^DD",7410 00,741000. 28,.06,3)
  49362   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49363   "^DD",7410 00,741000. 28,.06,21, 0)
  49364   ^^3^3^3110 207^
  49365   "^DD",7410 00,741000. 28,.06,21, 1,0)
  49366   IF A TPL A MOUNT WAS  ENTERED AT  THE CLAIM  OR SUBMIS SION LEVE,  THE SYSTE
  49367   "^DD",7410 00,741000. 28,.06,21, 2,0)
  49368   CHALL AUTO MATICALLY  DISTRIBUTE  TPL TO TH E LINE LEV EL USING A  WEIGHTED 
  49369   "^DD",7410 00,741000. 28,.06,21, 3,0)
  49370   CALCULATIO N.
  49371   "^DD",7410 00,741000. 28,.06,"DT ")
  49372   3110207
  49373   "^DD",7410 00,741000. 28,.07,0)
  49374   COST/UNIT^ NJ12,2^^0; 7^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 99)!(X<0)! (X?.E1"."3 .N) X
  49375   "^DD",7410 00,741000. 28,.07,3)
  49376   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49377   "^DD",7410 00,741000. 28,.07,21, 0)
  49378   ^^1^1^3110 207^
  49379   "^DD",7410 00,741000. 28,.07,21, 1,0)
  49380   COST/UNIT  OR COSTQUA NTITY FOR  THE LINE L EVEL
  49381   "^DD",7410 00,741000. 28,.07,"DT ")
  49382   3110207
  49383   "^DD",7410 00,741000. 28,.08,0)
  49384   # UNITS AL LOWED^NJ7, 0^^0;8^K:+ X'=X!(X>99 99999)!(X< 0)!(X?.E1" ."1.N) X
  49385   "^DD",7410 00,741000. 28,.08,3)
  49386   Type a num ber betwee n 0 and 99 99999, 0 d ecimal dig its.
  49387   "^DD",7410 00,741000. 28,.08,21, 0)
  49388   ^^1^1^3110 207^
  49389   "^DD",7410 00,741000. 28,.08,21, 1,0)
  49390   NUMBER OF  UNITS OR Q UANTITY AL LOWED FOR  LINE LEVEL
  49391   "^DD",7410 00,741000. 28,.08,"DT ")
  49392   3110207
  49393   "^DD",7410 00,741000. 28,.09,0)
  49394   CALCULATED  ALLOWED A MT^NJ12,2^ ^0;9^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  49395   "^DD",7410 00,741000. 28,.09,3)
  49396   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49397   "^DD",7410 00,741000. 28,.09,"DT ")
  49398   3110207
  49399   "^DD",7410 00,741000. 28,.1,0)
  49400   DEDUCTIBLE  AMT^NJ12, 2^^0;10^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  49401   "^DD",7410 00,741000. 28,.1,3)
  49402   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49403   "^DD",7410 00,741000. 28,.1,"DT" )
  49404   3110111
  49405   "^DD",7410 00,741000. 28,.11,0)
  49406   COST SHARE  AMT^NJ12, 2^^0;11^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999999)! (X<0) X
  49407   "^DD",7410 00,741000. 28,.11,3)
  49408   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49409   "^DD",7410 00,741000. 28,.11,"DT ")
  49410   3110111
  49411   "^DD",7410 00,741000. 28,.12,0)
  49412   PAYMENT AM T^NJ12,2^^ 0;12^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 99999)!(X< 0)!(X?.E1" ."3.N) X
  49413   "^DD",7410 00,741000. 28,.12,3)
  49414   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49415   "^DD",7410 00,741000. 28,.12,"DT ")
  49416   3110207
  49417   "^DD",7410 00,741000. 28,.13,0)
  49418   PATIENT PA ID AMT^NJ1 2,2^^0;13^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >999999999 )!(X<0)!(X ?.E1"."3.N ) X
  49419   "^DD",7410 00,741000. 28,.13,3)
  49420   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49421   "^DD",7410 00,741000. 28,.13,"DT ")
  49422   3110207
  49423   "^DD",7410 00,741000. 28,.14,0)
  49424   CAT CAP AP PLIED AMT^ NJ12,2^^0; 14^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 999)!(X<0) !(X?.E1"." 3.N) X
  49425   "^DD",7410 00,741000. 28,.14,3)
  49426   Type a dol lar amount  between 0  and 99999 9999, 2 de cimal digi ts.
  49427   "^DD",7410 00,741000. 28,.14,"DT ")
  49428   3110207
  49429   "^DD",7410 00,741000. 28,.15,0)
  49430   AMT PD TO  PROVIDER^N J13,2^^0;1 5^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999999 999)!(X<0)  X
  49431   "^DD",7410 00,741000. 28,.15,3)
  49432   Type a dol lar amount  between 0  and 99999 99999, 2 d ecimal dig its.
  49433   "^DD",7410 00,741000. 28,.15,"DT ")
  49434   3110531
  49435   "^DD",7410 00,741000. 28,.16,0)
  49436   AMT PD TO  BENE^NJ13, 2^^0;16^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999999999) !(X<0) X
  49437   "^DD",7410 00,741000. 28,.16,3)
  49438   Type a dol lar amount  between 0  and 99999 99999, 2 d ecimal dig its.
  49439   "^DD",7410 00,741000. 28,.16,"DT ")
  49440   3110531
  49441   "^DD",7410 00,741000. 28,.17,0)
  49442   PT TO CHMI MAGE LINE^ NJ8,0^^0;1 7^K:+X'=X! (X>9999999 9)!(X<1)!( X?.E1"."1N .N) X
  49443   "^DD",7410 00,741000. 28,.17,3)
  49444   Type a num ber betwee n 1 and 99 999999, 0  decimal di gits.
  49445   "^DD",7410 00,741000. 28,.17,"DT ")
  49446   3110713
  49447   "^DD",7410 00,741000. 28,.18,0)
  49448   DED WAIVED ^S^1:YES;^ 0;18^Q
  49449   "^DD",7410 00,741000. 28,.18,3)
  49450   1 MEANS DE D AND COST  SHARE WAI VED, OTHER WISE NOT W AIVED
  49451   "^DD",7410 00,741000. 28,.18,21, 0)
  49452   ^^2^2^3170 927^
  49453   "^DD",7410 00,741000. 28,.18,21, 1,0)
  49454   1 MEANS DE D AND COST  SHARE WAI VED, OTHER WISE NOT W AIVED
  49455   "^DD",7410 00,741000. 28,.18,21, 2,0)
  49456  
  49457   "^DD",7410 00,741000. 28,.18,"DT ")
  49458   3170927
  49459   "^DD",7410 00,741000. 4001,0)
  49460   EOB-CLAIMS  SUB-FIELD ^^.01^1
  49461   "^DD",7410 00,741000. 4001,0,"DT ")
  49462   2940518
  49463   "^DD",7410 00,741000. 4001,0,"IX ","B",7410 00.4001,.0 1)
  49464  
  49465   "^DD",7410 00,741000. 4001,0,"NM ","EOB-CLA IMS")
  49466  
  49467   "^DD",7410 00,741000. 4001,0,"UP ")
  49468   741000
  49469   "^DD",7410 00,741000. 4001,.01,0 )
  49470   EOB-CLAIMS ^MP741000' ^CHMPAY(^0 ;1^Q
  49471   "^DD",7410 00,741000. 4001,.01,1 ,0)
  49472   ^.1
  49473   "^DD",7410 00,741000. 4001,.01,1 ,1,0)
  49474   741000.400 1^B
  49475   "^DD",7410 00,741000. 4001,.01,1 ,1,1)
  49476   S ^CHMPAY( DA(1),"EOB -CLAIMS"," B",$E(X,1, 30),DA)=""
  49477   "^DD",7410 00,741000. 4001,.01,1 ,1,2)
  49478   K ^CHMPAY( DA(1),"EOB -CLAIMS"," B",$E(X,1, 30),DA)
  49479   "^DD",7410 00,741000. 4001,.01,2 1,0)
  49480   ^^1^1^2940 518^
  49481   "^DD",7410 00,741000. 4001,.01,2 1,1,0)
  49482   All claims  printed o n Benefici ary ID alo ng with th is claim.
  49483   "^DD",7410 00,741000. 4001,.01," DT")
  49484   2940518
  49485   "^DD",7410 00,741000. 41,0)
  49486   PAGE NUMBE R SUB-FIEL D^^1^2
  49487   "^DD",7410 00,741000. 41,0,"IX", "B",741000 .41,.01)
  49488  
  49489   "^DD",7410 00,741000. 41,0,"NM", "PAGE NUMB ER")
  49490  
  49491   "^DD",7410 00,741000. 41,0,"UP")
  49492   741000.04
  49493   "^DD",7410 00,741000. 41,.01,0)
  49494   PAGE NUMBE R^MNJ3,0^^ 0;1^K:+X'= X!(X>999)! (X<0)!(X?. E1"."1N.N)  X
  49495   "^DD",7410 00,741000. 41,.01,1,0 )
  49496   ^.1
  49497   "^DD",7410 00,741000. 41,.01,1,1 ,0)
  49498   741000.41^ B
  49499   "^DD",7410 00,741000. 41,.01,1,1 ,1)
  49500   S ^CHMPAY( DA(2),"PDI ",DA(1),"P AGE","B",$ E(X,1,30), DA)=""
  49501   "^DD",7410 00,741000. 41,.01,1,1 ,2)
  49502   K ^CHMPAY( DA(2),"PDI ",DA(1),"P AGE","B",$ E(X,1,30), DA)
  49503   "^DD",7410 00,741000. 41,.01,3)
  49504   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  49505   "^DD",7410 00,741000. 41,.01,"DT ")
  49506   2900920
  49507   "^DD",7410 00,741000. 41,1,0)
  49508   IMAGE NUMB ER^741000. 411^^IMAGE ;0
  49509   "^DD",7410 00,741000. 4101,0)
  49510   EOB-CATCAP P/DEDUCTIB LE SUB-FIE LD^^.05^5
  49511   "^DD",7410 00,741000. 4101,0,"DT ")
  49512   2940511
  49513   "^DD",7410 00,741000. 4101,0,"IX ","B",7410 00.4101,.0 1)
  49514  
  49515   "^DD",7410 00,741000. 4101,0,"NM ","EOB-CAT CAPP/DEDUC TIBLE")
  49516  
  49517   "^DD",7410 00,741000. 4101,0,"UP ")
  49518   741000
  49519   "^DD",7410 00,741000. 4101,.01,0 )
  49520   YEAR^MD^^0 ;1^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X
  49521   "^DD",7410 00,741000. 4101,.01,1 ,0)
  49522   ^.1
  49523   "^DD",7410 00,741000. 4101,.01,1 ,1,0)
  49524   741000.410 1^B
  49525   "^DD",7410 00,741000. 4101,.01,1 ,1,1)
  49526   S ^CHMPAY( DA(1),"EOB -CAT/DED", "B",$E(X,1 ,30),DA)=" "
  49527   "^DD",7410 00,741000. 4101,.01,1 ,1,2)
  49528   K ^CHMPAY( DA(1),"EOB -CAT/DED", "B",$E(X,1 ,30),DA)
  49529   "^DD",7410 00,741000. 4101,.01,2 1,0)
  49530   ^^1^1^2940 518^^^^
  49531   "^DD",7410 00,741000. 4101,.01,2 1,1,0)
  49532   Year print ed on EOB  for Cat/Ca pp period  store as f ileman dat e.
  49533   "^DD",7410 00,741000. 4101,.01," DT")
  49534   2940511
  49535   "^DD",7410 00,741000. 4101,.02,0 )
  49536   INDIVIDUAL  DEDUCTIBL E^NJ9,2^^0 ;2^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 .99)!(X<0)  X
  49537   "^DD",7410 00,741000. 4101,.02,3 )
  49538   Type a Dol lar Amount  between 0  and 99999 9.99, 2 De cimal Digi ts
  49539   "^DD",7410 00,741000. 4101,.02," DT")
  49540   2940511
  49541   "^DD",7410 00,741000. 4101,.03,0 )
  49542   FAMILY DED UCTIBLE^NJ 9,2^^0;3^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 999999.99) !(X<0) X
  49543   "^DD",7410 00,741000. 4101,.03,3 )
  49544   Type a Dol lar Amount  between 0  and 99999 9.99, 2 De cimal Digi ts
  49545   "^DD",7410 00,741000. 4101,.03," DT")
  49546   2940511
  49547   "^DD",7410 00,741000. 4101,.04,0 )
  49548   CAT CAPP A CCRUAL^NJ9 ,2^^0;4^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99999.99)! (X<0) X
  49549   "^DD",7410 00,741000. 4101,.04,3 )
  49550   Type a Dol lar Amount  between 0  and 99999 9.99, 2 De cimal Digi ts
  49551   "^DD",7410 00,741000. 4101,.04," DT")
  49552   2940511
  49553   "^DD",7410 00,741000. 4101,.05,0 )
  49554   EOB DATE^D ^^0;5^S %D T="EX" D ^ %DT S X=Y  K:Y<1 X
  49555   "^DD",7410 00,741000. 4101,.05," DT")
  49556   2940511
  49557   "^DD",7410 00,741000. 411,0)
  49558   IMAGE NUMB ER SUB-FIE LD^^.02^2
  49559   "^DD",7410 00,741000. 411,0,"IX" ,"B",74100 0.411,.01)
  49560  
  49561   "^DD",7410 00,741000. 411,0,"NM" ,"IMAGE NU MBER")
  49562  
  49563   "^DD",7410 00,741000. 411,0,"UP" )
  49564   741000.41
  49565   "^DD",7410 00,741000. 411,.01,0)
  49566   IMAGE NUMB ER^MNJ3,0^ ^0;1^K:+X' =X!(X>999) !(X<0)!(X? .E1"."1N.N ) X
  49567   "^DD",7410 00,741000. 411,.01,1, 0)
  49568   ^.1
  49569   "^DD",7410 00,741000. 411,.01,1, 1,0)
  49570   741000.411 ^B
  49571   "^DD",7410 00,741000. 411,.01,1, 1,1)
  49572   S ^CHMPAY( DA(3),"PDI ",DA(2),"P AGE",DA(1) ,"IMAGE"," B",$E(X,1, 30),DA)=""
  49573   "^DD",7410 00,741000. 411,.01,1, 1,2)
  49574   K ^CHMPAY( DA(3),"PDI ",DA(2),"P AGE",DA(1) ,"IMAGE"," B",$E(X,1, 30),DA)
  49575   "^DD",7410 00,741000. 411,.01,3)
  49576   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  49577   "^DD",7410 00,741000. 411,.01,"D T")
  49578   2900920
  49579   "^DD",7410 00,741000. 411,.02,0)
  49580   CONTRIBUTI ON STRING^ F^^0;2^K:$ L(X)>200!( $L(X)<1) X
  49581   "^DD",7410 00,741000. 411,.02,3)
  49582   Answer mus t be 1-200  character s in lengt h.
  49583   "^DD",7410 00,741000. 4201,0)
  49584   EOB-CLAIMS /PROV SUB- FIELD^^.01 ^1
  49585   "^DD",7410 00,741000. 4201,0,"DT ")
  49586   2940601
  49587   "^DD",7410 00,741000. 4201,0,"IX ","B",7410 00.4201,.0 1)
  49588  
  49589   "^DD",7410 00,741000. 4201,0,"NM ","EOB-CLA IMS/PROV")
  49590  
  49591   "^DD",7410 00,741000. 4201,0,"UP ")
  49592   741000
  49593   "^DD",7410 00,741000. 4201,.01,0 )
  49594   EOB-CLAIMS /PROV^MP74 1000'^CHMP AY(^0;1^Q
  49595   "^DD",7410 00,741000. 4201,.01,1 ,0)
  49596   ^.1
  49597   "^DD",7410 00,741000. 4201,.01,1 ,1,0)
  49598   741000.420 1^B
  49599   "^DD",7410 00,741000. 4201,.01,1 ,1,1)
  49600   S ^CHMPAY( DA(1),"EOB -CLAIMS/PR OV","B",$E (X,1,30),D A)=""
  49601   "^DD",7410 00,741000. 4201,.01,1 ,1,2)
  49602   K ^CHMPAY( DA(1),"EOB -CLAIMS/PR OV","B",$E (X,1,30),D A)
  49603   "^DD",7410 00,741000. 4201,.01,2 1,0)
  49604   ^^1^1^2940 601^
  49605   "^DD",7410 00,741000. 4201,.01,2 1,1,0)
  49606   Claim poin ters of mu ltiple cla ims on pro vider EOB
  49607   "^DD",7410 00,741000. 4201,.01," DT")
  49608   2940601
  49609   "^DD",7410 00,741000. 7,0)
  49610   DATE/TIME  EDITED SUB -FIELD^^.0 3^3
  49611   "^DD",7410 00,741000. 7,0,"DT")
  49612   2920110
  49613   "^DD",7410 00,741000. 7,0,"IX"," B",741000. 7,.01)
  49614  
  49615   "^DD",7410 00,741000. 7,0,"NM"," DATE/TIME  EDITED")
  49616  
  49617   "^DD",7410 00,741000. 7,0,"UP")
  49618   741000
  49619   "^DD",7410 00,741000. 7,.01,0)
  49620   DATE/TIME  EDITED^DX^ ^0;1^S %DT ="EST" D ^ %DT S X=Y  K:Y<1 X S: $D(X) DINU M=X
  49621   "^DD",7410 00,741000. 7,.01,1,0)
  49622   ^.1
  49623   "^DD",7410 00,741000. 7,.01,1,1, 0)
  49624   741000.7^B
  49625   "^DD",7410 00,741000. 7,.01,1,1, 1)
  49626   S ^CHMPAY( DA(1),"EDI T","B",$E( X,1,30),DA )=""
  49627   "^DD",7410 00,741000. 7,.01,1,1, 2)
  49628   K ^CHMPAY( DA(1),"EDI T","B",$E( X,1,30),DA )
  49629   "^DD",7410 00,741000. 7,.01,"DT" )
  49630   2920110
  49631   "^DD",7410 00,741000. 7,.02,0)
  49632   EDITING US ER^P3'^DIC (3,^0;2^Q
  49633   "^DD",7410 00,741000. 7,.02,"DT" )
  49634   2920110
  49635   "^DD",7410 00,741000. 7,.03,0)
  49636   CLAIM EDIT ED?^S^Y:ED ITED;^0;3^ Q
  49637   "^DD",7410 00,741000. 7,.03,"DT" )
  49638   2920110
  49639   "^DD",7410 00,741000. 701,0)
  49640   REJECTION  REASONS SU B-FIELD^^. 02^2
  49641   "^DD",7410 00,741000. 701,0,"DT" )
  49642   2920417
  49643   "^DD",7410 00,741000. 701,0,"IX" ,"B",74100 0.701,.01)
  49644  
  49645   "^DD",7410 00,741000. 701,0,"NM" ,"REJECTIO N REASONS" )
  49646  
  49647   "^DD",7410 00,741000. 701,0,"UP" )
  49648   741000
  49649   "^DD",7410 00,741000. 701,.01,0)
  49650   REJECTION  REASONS^P7 41002.22'^ CHMDIC(741 002.22,^0; 1^Q
  49651   "^DD",7410 00,741000. 701,.01,1, 0)
  49652   ^.1
  49653   "^DD",7410 00,741000. 701,.01,1, 1,0)
  49654   741000.701 ^B
  49655   "^DD",7410 00,741000. 701,.01,1, 1,1)
  49656   S ^CHMPAY( DA(1),4,"B ",$E(X,1,3 0),DA)=""
  49657   "^DD",7410 00,741000. 701,.01,1, 1,2)
  49658   K ^CHMPAY( DA(1),4,"B ",$E(X,1,3 0),DA)
  49659   "^DD",7410 00,741000. 701,.01,"D T")
  49660   2920416
  49661   "^DD",7410 00,741000. 701,.02,0)
  49662   TYPE OF RE ASON^F^^0; 2^K:$L(X)> 10!($L(X)< 1) X
  49663   "^DD",7410 00,741000. 701,.02,3)
  49664   Answer mus t be 1-10  characters  in length .
  49665   "^DD",7410 00,741000. 701,.02,"D T")
  49666   2920417
  49667   "^DD",7410 00.2,74100 0.2,0)
  49668   FIELD^^45^ 55
  49669   "^DD",7410 00.2,74100 0.2,0,"DDA ")
  49670   N
  49671   "^DD",7410 00.2,74100 0.2,0,"DT" )
  49672   3180215
  49673   "^DD",7410 00.2,74100 0.2,0,"IX" ,"AC",7410 00.2,20.03 )
  49674  
  49675   "^DD",7410 00.2,74100 0.2,0,"IX" ,"AD",7410 00.2,.21)
  49676  
  49677   "^DD",7410 00.2,74100 0.2,0,"IX" ,"AE",7410 00.2,20)
  49678  
  49679   "^DD",7410 00.2,74100 0.2,0,"IX" ,"AF",7410 00.2,21)
  49680  
  49681   "^DD",7410 00.2,74100 0.2,0,"IX" ,"AU",7410 00.2,30.03 )
  49682  
  49683   "^DD",7410 00.2,74100 0.2,0,"IX" ,"B",74100 0.2,.01)
  49684  
  49685   "^DD",7410 00.2,74100 0.2,0,"IX" ,"C",74100 0.2,.12)
  49686  
  49687   "^DD",7410 00.2,74100 0.2,0,"IX" ,"D",74100 0.2,20.01)
  49688  
  49689   "^DD",7410 00.2,74100 0.2,0,"IX" ,"E",74100 0.2,20.1)
  49690  
  49691   "^DD",7410 00.2,74100 0.2,0,"IX" ,"EDIPAUSE ",741000.3 5,.01)
  49692  
  49693   "^DD",7410 00.2,74100 0.2,0,"IX" ,"F",74100 0.2,.18)
  49694  
  49695   "^DD",7410 00.2,74100 0.2,0,"IX" ,"G",74100 0.2,30.07)
  49696  
  49697   "^DD",7410 00.2,74100 0.2,0,"IX" ,"H",74100 0.2,.22)
  49698  
  49699   "^DD",7410 00.2,74100 0.2,0,"IX" ,"ZCPD",74 1000.2,.04 )
  49700  
  49701   "^DD",7410 00.2,74100 0.2,0,"NM" ,"CHAMPVA  STORED IMA GES")
  49702  
  49703   "^DD",7410 00.2,74100 0.2,0,"PT" ,741002.21 2,.01)
  49704  
  49705   "^DD",7410 00.2,74100 0.2,0,"PT" ,741002.21 701,.03)
  49706  
  49707   "^DD",7410 00.2,74100 0.2,0,"PT" ,741026.02 01,.01)
  49708  
  49709   "^DD",7410 00.2,74100 0.2,0,"PT" ,741850.02 ,400)
  49710  
  49711   "^DD",7410 00.2,74100 0.2,.01,0)
  49712   PRIMARY DO CUMENT IND EX (PDI)^R NJ15,0X^^0 ;1^K:+X'=X !(X>999999 999999999) !(X<0)!(X? .E1"."1N.N ) X S:$D(X ) DINUM=X
  49713   "^DD",7410 00.2,74100 0.2,.01,1, 0)
  49714   ^.1^^-1
  49715   "^DD",7410 00.2,74100 0.2,.01,1, 1,0)
  49716   741000.2^B
  49717   "^DD",7410 00.2,74100 0.2,.01,1, 1,1)
  49718   S ^CHMIMG( "B",$E(X,1 ,30),DA)=" "
  49719   "^DD",7410 00.2,74100 0.2,.01,1, 1,2)
  49720   K ^CHMIMG( "B",$E(X,1 ,30),DA)
  49721   "^DD",7410 00.2,74100 0.2,.01,3)
  49722   Type a Num ber betwee n 0 and 99 9999999999 999, 0 Dec imal Digit s
  49723   "^DD",7410 00.2,74100 0.2,.01,"D T")
  49724   3180206
  49725   "^DD",7410 00.2,74100 0.2,.02,0)
  49726   NUMBER OF  PAGES^RNJ3 ,0^^0;2^K: +X'=X!(X>9 99)!(X<0)! (X?.E1"."1 N.N) X
  49727   "^DD",7410 00.2,74100 0.2,.02,3)
  49728   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  49729   "^DD",7410 00.2,74100 0.2,.02,"D T")
  49730   2901011
  49731   "^DD",7410 00.2,74100 0.2,.03,0)
  49732   IMAGES ASS IGNED TO^R P200'^VA(2 00,^0;3^Q
  49733   "^DD",7410 00.2,74100 0.2,.03,"D T")
  49734   2951011
  49735   "^DD",7410 00.2,74100 0.2,.04,0)
  49736   DATE/TIME  BEGUN^RD^^ 0;4^S %DT= "ETX" D ^% DT S X=Y K :Y<1 X
  49737   "^DD",7410 00.2,74100 0.2,.04,1, 0)
  49738   ^.1
  49739   "^DD",7410 00.2,74100 0.2,.04,1, 1,0)
  49740   741000.2^Z CPD^MUMPS
  49741   "^DD",7410 00.2,74100 0.2,.04,1, 1,1)
  49742   S:$P(^CHMI MG(DA,0),U ,1)'="" ^C HMIMG("ZCP D",X,$P(^C HMIMG(DA,0 ),U,1),DA) =""
  49743   "^DD",7410 00.2,74100 0.2,.04,1, 1,2)
  49744   K:$P(^CHMI MG(DA,0),U ,1)'="" ^C HMIMG("ZCP D",X,$P(^C HMIMG(DA,0 ),U,1),DA)
  49745   "^DD",7410 00.2,74100 0.2,.04,1, 1,"DT")
  49746   2930817
  49747   "^DD",7410 00.2,74100 0.2,.04,"D T")
  49748   2930817
  49749   "^DD",7410 00.2,74100 0.2,.05,0)
  49750   DATE/TIME  COMPLETED^ D^^0;5^S % DT="ETX" D  ^%DT S X= Y K:Y<1 X
  49751   "^DD",7410 00.2,74100 0.2,.05,"D T")
  49752   2901011
  49753   "^DD",7410 00.2,74100 0.2,.06,0)
  49754   STATUS OF  PDI^S^0:UN ASSIGNED;1 :ASSIGNED; 2:INPROCES S;3:UNREAD ABLE;4:COM PLETED;5:T OTAL FI PA Y;6:PENDIN G;7:UNDONE ;8:PAGE DI SCREPENCY; 9:PRESCREE N;10:SCANN ED;11:VOID ED;12:REVE RSED;^0;6^ Q
  49755   "^DD",7410 00.2,74100 0.2,.06,"D T")
  49756   3170919
  49757   "^DD",7410 00.2,74100 0.2,.07,0)
  49758   PRIMARY VO LUME SET^F ^^0;7^K:$L (X)>8!($L( X)<8) X
  49759   "^DD",7410 00.2,74100 0.2,.07,3)
  49760   Answer mus t be 8 cha racters in  length.
  49761   "^DD",7410 00.2,74100 0.2,.07,"D T")
  49762   2910322
  49763   "^DD",7410 00.2,74100 0.2,.08,0)
  49764   SECONDARY  VOLUME SET ^F^^0;8^K: $L(X)>8!($ L(X)<8) X
  49765   "^DD",7410 00.2,74100 0.2,.08,3)
  49766   Answer mus t be 8 cha racters in  length.
  49767   "^DD",7410 00.2,74100 0.2,.09,0)
  49768   BYTE COUNT ^NJ6,0^^0; 9^K:+X'=X! (X>999999) !(X<1)!(X? .E1"."1N.N ) X
  49769   "^DD",7410 00.2,74100 0.2,.09,3)
  49770   Type a Num ber betwee n 1 and 99 9999, 0 De cimal Digi ts
  49771   "^DD",7410 00.2,74100 0.2,.09,"D T")
  49772   2910322
  49773   "^DD",7410 00.2,74100 0.2,.1,0)
  49774   TOTAL PAGE S SCANNED^ NJ2,0^^0;1 0^K:+X'=X! (X>99)!(X< 1)!(X?.E1" ."1N.N) X
  49775   "^DD",7410 00.2,74100 0.2,.1,3)
  49776   Type a Num ber betwee n 1 and 99 , 0 Decima l Digits
  49777   "^DD",7410 00.2,74100 0.2,.1,"DT ")
  49778   2910322
  49779   "^DD",7410 00.2,74100 0.2,.11,0)
  49780   RETRIEVAL  STATION SE NT TO^P741 002.24'^CH MDIC(74100 2.24,^0;11 ^Q
  49781   "^DD",7410 00.2,74100 0.2,.11,"D T")
  49782   2910322
  49783   "^DD",7410 00.2,74100 0.2,.12,0)
  49784   SCANNED OR  MANUAL^S^ 0:SCANNED; 1:MAN SCAN NED;^0;12^ Q
  49785   "^DD",7410 00.2,74100 0.2,.12,1, 0)
  49786   ^.1
  49787   "^DD",7410 00.2,74100 0.2,.12,1, 1,0)
  49788   741000.2^C ^MUMPS
  49789   "^DD",7410 00.2,74100 0.2,.12,1, 1,1)
  49790   S:$P(^CHMI MG(DA,0)," ^",12)=1 ^ CHMIMG("C" ,$P(^CHMIM G(DA,0),"^ ",1),DA)=" "
  49791   "^DD",7410 00.2,74100 0.2,.12,1, 1,2)
  49792   K:$P(^CHMI MG(DA,0)," ^",12)=1 ^ CHMIMG("C" ,$P(^CHMIM G(DA,0),"^ ",1),DA)
  49793   "^DD",7410 00.2,74100 0.2,.12,1, 1,"DT")
  49794   2910619
  49795   "^DD",7410 00.2,74100 0.2,.12,"D T")
  49796   2931026
  49797   "^DD",7410 00.2,74100 0.2,.13,0)
  49798   AUTO ROUTE  SLIP PRIN TED^S^0:NO T PRINTED; 1:PRINTED; ^0;13^Q
  49799   "^DD",7410 00.2,74100 0.2,.13,"D T")
  49800   2910627
  49801   "^DD",7410 00.2,74100 0.2,.14,0)
  49802   CHECKED IN  OR OUT^S^ 0:CHECKED  OUT;1:CHEC KED IN;^0; 14^Q
  49803   "^DD",7410 00.2,74100 0.2,.14,"D T")
  49804   3170919
  49805   "^DD",7410 00.2,74100 0.2,.15,0)
  49806   POINTER TO  LAST CHEC KED OUT^NJ 3,0^^0;15^ K:+X'=X!(X >999)!(X<1 )!(X?.E1". "1N.N) X
  49807   "^DD",7410 00.2,74100 0.2,.15,3)
  49808   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  49809   "^DD",7410 00.2,74100 0.2,.15,"D T")
  49810   2910628
  49811   "^DD",7410 00.2,74100 0.2,.16,0)
  49812   SET BY CHM K2VE^S^0:N O;1:YES;^0 ;16^Q
  49813   "^DD",7410 00.2,74100 0.2,.16,"D T")
  49814   2930922
  49815   "^DD",7410 00.2,74100 0.2,.17,0)
  49816   TYPE OF PD I PROCESSI NG^S^1:IMA GE ONLY (I O);2:MAN S CANNED (MS );3:MAN MA NUAL (MM); 4:EDI MANU AL (EDI);^ 0;17^Q
  49817   "^DD",7410 00.2,74100 0.2,.17,"D T")
  49818   2940718
  49819   "^DD",7410 00.2,74100 0.2,.18,0)
  49820   MEDICAL MA TRIX BATCH  NUMBER^P7 41009'^CHM XRX(^0;18^ Q
  49821   "^DD",7410 00.2,74100 0.2,.18,1, 0)
  49822   ^.1
  49823   "^DD",7410 00.2,74100 0.2,.18,1, 1,0)
  49824   741000.2^F
  49825   "^DD",7410 00.2,74100 0.2,.18,1, 1,1)
  49826   S ^CHMIMG( "F",$E(X,1 ,30),DA)=" "
  49827   "^DD",7410 00.2,74100 0.2,.18,1, 1,2)
  49828   K ^CHMIMG( "F",$E(X,1 ,30),DA)
  49829   "^DD",7410 00.2,74100 0.2,.18,1, 1,"%D",0)
  49830   ^^1^1^2940 618^^^^
  49831   "^DD",7410 00.2,74100 0.2,.18,1, 1,"%D",1,0 )
  49832   Used to cr oss-refere nce MDMTRX  Batch No.  to PDI.
  49833   "^DD",7410 00.2,74100 0.2,.18,1, 1,"DT")
  49834   2940422
  49835   "^DD",7410 00.2,74100 0.2,.18,3)
  49836   Enter Medi cal Matrix  Batch Num ber if thi s submissi on relates  to Medica l Matrix
  49837   "^DD",7410 00.2,74100 0.2,.18,"D T")
  49838   2940422
  49839   "^DD",7410 00.2,74100 0.2,.19,0)
  49840   PROCESSING  BATCH NUM BER^P74102 6.02'^CHMI MPB(^0;19^ Q
  49841   "^DD",7410 00.2,74100 0.2,.19,"D T")
  49842   2940708
  49843   "^DD",7410 00.2,74100 0.2,.2,0)
  49844   DUZ WHO CR EATED PDI^ P200'^VA(2 00,^0;20^Q
  49845   "^DD",7410 00.2,74100 0.2,.2,"DT ")
  49846   2950713
  49847   "^DD",7410 00.2,74100 0.2,.21,0)
  49848   D/T PDI GE NERATED^D^ ^0;21^S %D T="ESTX" D  ^%DT S X= Y K:Y<1 X
  49849   "^DD",7410 00.2,74100 0.2,.21,1, 0)
  49850   ^.1
  49851   "^DD",7410 00.2,74100 0.2,.21,1, 1,0)
  49852   741000.2^A D
  49853   "^DD",7410 00.2,74100 0.2,.21,1, 1,1)
  49854   S ^CHMIMG( "AD",$E(X, 1,30),DA)= ""
  49855   "^DD",7410 00.2,74100 0.2,.21,1, 1,2)
  49856   K ^CHMIMG( "AD",$E(X, 1,30),DA)
  49857   "^DD",7410 00.2,74100 0.2,.21,1, 1,"DT")
  49858   2960121
  49859   "^DD",7410 00.2,74100 0.2,.21,"D T")
  49860   2960121
  49861   "^DD",7410 00.2,74100 0.2,.22,0)
  49862   DATE REVER SE COMPLET ED^D^^0;22 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  49863   "^DD",7410 00.2,74100 0.2,.22,1, 0)
  49864   ^.1
  49865   "^DD",7410 00.2,74100 0.2,.22,1, 1,0)
  49866   741000.2^H
  49867   "^DD",7410 00.2,74100 0.2,.22,1, 1,1)
  49868   S ^CHMIMG( "H",$E(X,1 ,30),DA)=" "
  49869   "^DD",7410 00.2,74100 0.2,.22,1, 1,2)
  49870   K ^CHMIMG( "H",$E(X,1 ,30),DA)
  49871   "^DD",7410 00.2,74100 0.2,.22,1, 1,"%D",0)
  49872   ^^1^1^3170 704^
  49873   "^DD",7410 00.2,74100 0.2,.22,1, 1,"%D",1,0 )
  49874   CROSS-REFE RENCE FOR  CSTAT LOOK UP
  49875   "^DD",7410 00.2,74100 0.2,.22,1, 1,"DT")
  49876   3170704
  49877   "^DD",7410 00.2,74100 0.2,.22,21 ,0)
  49878   ^.001^1^1^ 3170704^^^ ^
  49879   "^DD",7410 00.2,74100 0.2,.22,21 ,1,0)
  49880   DATE OF RE VERSAL COM PLETED.
  49881   "^DD",7410 00.2,74100 0.2,.22,"D T")
  49882   3170704
  49883   "^DD",7410 00.2,74100 0.2,1,0)
  49884   CLAIMS CRE ATED/AUGME NT BY PDI^ 741000.21P ^^1;0
  49885   "^DD",7410 00.2,74100 0.2,2,0)
  49886   PAGE^74100 0.22^^2;0
  49887   "^DD",7410 00.2,74100 0.2,5.01,0 )
  49888   FOLDER MAN AGEMENT DI ST.^741000 .23D^^5;0
  49889   "^DD",7410 00.2,74100 0.2,10.01, 0)
  49890   OVERRIDE T IMELY FILI NG FLAG^S^ 1:YES;0:NO ;^10;1^Q
  49891   "^DD",7410 00.2,74100 0.2,10.01, "DT")
  49892   2920102
  49893   "^DD",7410 00.2,74100 0.2,10.02, 0)
  49894   DUZ FOR OV ERRIDE^P20 0'^VA(200, ^10;2^Q
  49895   "^DD",7410 00.2,74100 0.2,10.02, "DT")
  49896   2951011
  49897   "^DD",7410 00.2,74100 0.2,10.03, 0)
  49898   DATE/TIME  OF OVERRID E^D^^10;3^ S %DT="EST " D ^%DT S  X=Y K:Y<1  X
  49899   "^DD",7410 00.2,74100 0.2,10.03, "DT")
  49900   2920102
  49901   "^DD",7410 00.2,74100 0.2,15.01, 0)
  49902   BARDCODE D ATE^741000 .26DA^^BAR CODE;0
  49903   "^DD",7410 00.2,74100 0.2,20,0)
  49904   PREVIOUS P DI^NJ15,0^ ^E-REOPEN; 1^K:+X'=X! (X>9999999 99999999)! (X<0)!(X?. E1"."1N.N)  X
  49905   "^DD",7410 00.2,74100 0.2,20,1,0 )
  49906   ^.1
  49907   "^DD",7410 00.2,74100 0.2,20,1,1 ,0)
  49908   741000.2^A E
  49909   "^DD",7410 00.2,74100 0.2,20,1,1 ,1)
  49910   S ^CHMIMG( "AE",$E(X, 1,30),DA)= ""
  49911   "^DD",7410 00.2,74100 0.2,20,1,1 ,2)
  49912   K ^CHMIMG( "AE",$E(X, 1,30),DA)
  49913   "^DD",7410 00.2,74100 0.2,20,1,1 ,"DT")
  49914   3170816
  49915   "^DD",7410 00.2,74100 0.2,20,3)
  49916   Type a num ber betwee n 0 and 99 9999999999 999, 0 dec imal digit s.
  49917   "^DD",7410 00.2,74100 0.2,20,21, 0)
  49918   ^^2^2^3170 816^
  49919   "^DD",7410 00.2,74100 0.2,20,21, 1,0)
  49920   This field  will poin t back to  the previo us PDI. Th is field i s utilized  
  49921   "^DD",7410 00.2,74100 0.2,20,21, 2,0)
  49922   during the  reopen pr ocess.
  49923   "^DD",7410 00.2,74100 0.2,20,"DT ")
  49924   3170816
  49925   "^DD",7410 00.2,74100 0.2,20.01, 0)
  49926   DOCUMENT N UMBER^NJ12 ,0^^DOC;1^ K:+X'=X!(X >999999999 999)!(X<0) !(X?.E1"." 1N.N) X
  49927   "^DD",7410 00.2,74100 0.2,20.01, 1,0)
  49928   ^.1
  49929   "^DD",7410 00.2,74100 0.2,20.01, 1,1,0)
  49930   741000.2^D
  49931   "^DD",7410 00.2,74100 0.2,20.01, 1,1,1)
  49932   S ^CHMIMG( "D",$E(X,1 ,30),DA)=" "
  49933   "^DD",7410 00.2,74100 0.2,20.01, 1,1,2)
  49934   K ^CHMIMG( "D",$E(X,1 ,30),DA)
  49935   "^DD",7410 00.2,74100 0.2,20.01, 1,1,"DT")
  49936   2920728
  49937   "^DD",7410 00.2,74100 0.2,20.01, 3)
  49938   Type a Num ber betwee n 0 and 99 9999999999 , 0 Decima l Digits
  49939   "^DD",7410 00.2,74100 0.2,20.01, "DT")
  49940   2920728
  49941   "^DD",7410 00.2,74100 0.2,20.02, 0)
  49942   DOC NUMBER  OF PAGES^ NJ3,0^^DOC ;2^K:+X'=X !(X>999)!( X<0)!(X?.E 1"."1N.N)  X
  49943   "^DD",7410 00.2,74100 0.2,20.02, 3)
  49944   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  49945   "^DD",7410 00.2,74100 0.2,20.02, "DT")
  49946   2920514
  49947   "^DD",7410 00.2,74100 0.2,20.03, 0)
  49948   DOC CREATI ON DATE^D^ ^DOC;3^S % DT="ESTXR"  D ^%DT S  X=Y K:Y<1  X
  49949   "^DD",7410 00.2,74100 0.2,20.03, 1,0)
  49950   ^.1
  49951   "^DD",7410 00.2,74100 0.2,20.03, 1,1,0)
  49952   741000.2^A C
  49953   "^DD",7410 00.2,74100 0.2,20.03, 1,1,1)
  49954   S ^CHMIMG( "AC",+$E(X ,1,30),DA) =""
  49955   "^DD",7410 00.2,74100 0.2,20.03, 1,1,2)
  49956   K ^CHMIMG( "AC",+$E(X ,1,30),DA)
  49957   "^DD",7410 00.2,74100 0.2,20.03, 1,1,"%D",0 )
  49958   ^^1^1^2921 127^^
  49959   "^DD",7410 00.2,74100 0.2,20.03, 1,1,"%D",1 ,0)
  49960   CROSS REFE RENCE ON D OCUMENT SC AN DATE IN DEPENDENT  OF PDI JUL IAN DATE
  49961   "^DD",7410 00.2,74100 0.2,20.03, 1,1,"DT")
  49962   2921125
  49963   "^DD",7410 00.2,74100 0.2,20.03, 3)
  49964  
  49965   "^DD",7410 00.2,74100 0.2,20.03, "DT")
  49966   2921125
  49967   "^DD",7410 00.2,74100 0.2,20.04, 0)
  49968   DOC ORIGIN AL SCAN ST ATION^P741 020.02'^CH MIMD(74102 0.02,^DOC; 4^Q
  49969   "^DD",7410 00.2,74100 0.2,20.04, "DT")
  49970   2920514
  49971   "^DD",7410 00.2,74100 0.2,20.05, 0)
  49972   DEX DOCUME NT INDEX 1 ^F^^DOC;5^ K:$L(X)>30 !($L(X)<1)  X
  49973   "^DD",7410 00.2,74100 0.2,20.05, 3)
  49974   Answer mus t be 1-30  characters  in length .
  49975   "^DD",7410 00.2,74100 0.2,20.05, "DT")
  49976   2960111
  49977   "^DD",7410 00.2,74100 0.2,20.06, 0)
  49978   DEX DOCUME NT INDEX 2 ^F^^DOC;6^ K:$L(X)>30 !($L(X)<1)  X
  49979   "^DD",7410 00.2,74100 0.2,20.06, 3)
  49980   Answer mus t be 1-30  characters  in length .
  49981   "^DD",7410 00.2,74100 0.2,20.06, "DT")
  49982   2960111
  49983   "^DD",7410 00.2,74100 0.2,20.07, 0)
  49984   DEX DOCUME NT INDEX 3 ^F^^DOC;7^ K:$L(X)>30 !($L(X)<1)  X
  49985   "^DD",7410 00.2,74100 0.2,20.07, 3)
  49986   Answer mus t be 1-30  characters  in length .
  49987   "^DD",7410 00.2,74100 0.2,20.07, "DT")
  49988   2960111
  49989   "^DD",7410 00.2,74100 0.2,20.08, 0)
  49990   DEX DOCUME NT INDEX 4 ^F^^DOC;8^ K:$L(X)>30 !($L(X)<1)  X
  49991   "^DD",7410 00.2,74100 0.2,20.08, 3)
  49992   Answer mus t be 1-30  characters  in length .
  49993   "^DD",7410 00.2,74100 0.2,20.08, "DT")
  49994   2960111
  49995   "^DD",7410 00.2,74100 0.2,20.09, 0)
  49996   DEX DOCUME NT INDEX 5 ^F^^DOC;9^ K:$L(X)>30 !($L(X)<1)  X
  49997   "^DD",7410 00.2,74100 0.2,20.09, 3)
  49998   Answer mus t be 1-30  characters  in length .
  49999   "^DD",7410 00.2,74100 0.2,20.09, "DT")
  50000   2960111
  50001   "^DD",7410 00.2,74100 0.2,20.1,0 )
  50002   MANUAL DOC UMENT ID^N J10,0^^DOC ;10^K:+X'= X!(X>99999 99999)!(X< 0)!(X?.E1" ."1N.N) X
  50003   "^DD",7410 00.2,74100 0.2,20.1,1 ,0)
  50004   ^.1
  50005   "^DD",7410 00.2,74100 0.2,20.1,1 ,1,0)
  50006   741000.2^E
  50007   "^DD",7410 00.2,74100 0.2,20.1,1 ,1,1)
  50008   S ^CHMIMG( "E",$E(X,1 ,30),DA)=" "
  50009   "^DD",7410 00.2,74100 0.2,20.1,1 ,1,2)
  50010   K ^CHMIMG( "E",$E(X,1 ,30),DA)
  50011   "^DD",7410 00.2,74100 0.2,20.1,1 ,1,"DT")
  50012   2930210
  50013   "^DD",7410 00.2,74100 0.2,20.1,3 )
  50014   Type a Num ber betwee n 0 and 99 99999999,  0 Decimal  Digits
  50015   "^DD",7410 00.2,74100 0.2,20.1," DT")
  50016   2930210
  50017   "^DD",7410 00.2,74100 0.2,20.11, 0)
  50018   WAND DATE^ D^^DOC;11^ S %DT="EST " D ^%DT S  X=Y K:Y<1  X
  50019   "^DD",7410 00.2,74100 0.2,20.11, "DT")
  50020   3000211
  50021   "^DD",7410 00.2,74100 0.2,21,0)
  50022   NEW PDI^NJ 15,0^^E-RE OPEN;2^K:+ X'=X!(X>99 9999999999 999)!(X<0) !(X?.E1"." 1N.N) X
  50023   "^DD",7410 00.2,74100 0.2,21,1,0 )
  50024   ^.1
  50025   "^DD",7410 00.2,74100 0.2,21,1,1 ,0)
  50026   741000.2^A F
  50027   "^DD",7410 00.2,74100 0.2,21,1,1 ,1)
  50028   S ^CHMIMG( "AF",$E(X, 1,30),DA)= ""
  50029   "^DD",7410 00.2,74100 0.2,21,1,1 ,2)
  50030   K ^CHMIMG( "AF",$E(X, 1,30),DA)
  50031   "^DD",7410 00.2,74100 0.2,21,1,1 ,"DT")
  50032   3170816
  50033   "^DD",7410 00.2,74100 0.2,21,3)
  50034   Type a num ber betwee n 0 and 99 9999999999 999, 0 dec imal digit s.
  50035   "^DD",7410 00.2,74100 0.2,21,21, 0)
  50036   ^^2^2^3170 816^
  50037   "^DD",7410 00.2,74100 0.2,21,21, 1,0)
  50038   This field  points fo rward to t he new PDI .  This fi eld will b e utilized  in 
  50039   "^DD",7410 00.2,74100 0.2,21,21, 2,0)
  50040   the reopen  process.
  50041   "^DD",7410 00.2,74100 0.2,21,"DT ")
  50042   3170816
  50043   "^DD",7410 00.2,74100 0.2,22,0)
  50044   REOPEN FLA G^S^1:Star ted reopen  process;0 :Not start ed reopen  process;^E -REOPEN;3^ Q
  50045   "^DD",7410 00.2,74100 0.2,22,"DT ")
  50046   3170816
  50047   "^DD",7410 00.2,74100 0.2,30.01, 0)
  50048   SUBMIS TRA CKING DFN^ P554801'^A HCHVA(^TRA CK;1^Q
  50049   "^DD",7410 00.2,74100 0.2,30.01, "DT")
  50050   2930218
  50051   "^DD",7410 00.2,74100 0.2,30.02, 0)
  50052   SUBMIS TRA CKING BFN^ NJ3,0^^TRA CK;2^K:+X' =X!(X>999) !(X<1)!(X? .E1"."1N.N ) X
  50053   "^DD",7410 00.2,74100 0.2,30.02, 3)
  50054   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  50055   "^DD",7410 00.2,74100 0.2,30.02, "DT")
  50056   2930218
  50057   "^DD",7410 00.2,74100 0.2,30.03, 0)
  50058   SUBMIS TRA CKING VEND OR^F^^TRAC K;3^K:X["" ""!($A(X)= 45) X I $D (X) K:$L(X )>25!($L(X )<1) X
  50059   "^DD",7410 00.2,74100 0.2,30.03, 1,0)
  50060   ^.1
  50061   "^DD",7410 00.2,74100 0.2,30.03, 1,1,0)
  50062   741000.2^A U
  50063   "^DD",7410 00.2,74100 0.2,30.03, 1,1,1)
  50064   S ^CHMIMG( "AU",$E(X, 1,30),DA)= ""
  50065   "^DD",7410 00.2,74100 0.2,30.03, 1,1,2)
  50066   K ^CHMIMG( "AU",$E(X, 1,30),DA)
  50067   "^DD",7410 00.2,74100 0.2,30.03, 1,1,"DT")
  50068   2930222
  50069   "^DD",7410 00.2,74100 0.2,30.03, 3)
  50070   Answer mus t be 1-25  characters  in length .
  50071   "^DD",7410 00.2,74100 0.2,30.03, "DT")
  50072   2930222
  50073   "^DD",7410 00.2,74100 0.2,30.04, 0)
  50074   INIT PROCE SS MANUAL/ IMAGE^S^M: MANUAL;I:I MAGE;^TRAC K;4^Q
  50075   "^DD",7410 00.2,74100 0.2,30.04, "DT")
  50076   2930218
  50077   "^DD",7410 00.2,74100 0.2,30.05, 0)
  50078   DUZ SETTIN G IMAGE TR ACKING^P20 0'^VA(200, ^TRACK;5^Q
  50079   "^DD",7410 00.2,74100 0.2,30.05, "DT")
  50080   2951011
  50081   "^DD",7410 00.2,74100 0.2,30.06, 0)
  50082   DATE/TIME  TRACKING S ET^D^^TRAC K;6^S %DT= "ESTXR" D  ^%DT S X=Y  K:Y<1 X
  50083   "^DD",7410 00.2,74100 0.2,30.06, "DT")
  50084   2930218
  50085   "^DD",7410 00.2,74100 0.2,30.07, 0)
  50086   IMAGE JOB  TYPE^S^Z:Z IPZAP;^TRA CK;7^Q
  50087   "^DD",7410 00.2,74100 0.2,30.07, 1,0)
  50088   ^.1
  50089   "^DD",7410 00.2,74100 0.2,30.07, 1,1,0)
  50090   741000.2^G
  50091   "^DD",7410 00.2,74100 0.2,30.07, 1,1,1)
  50092   S ^CHMIMG( "G",$E(X,1 ,30),DA)=" "
  50093   "^DD",7410 00.2,74100 0.2,30.07, 1,1,2)
  50094   K ^CHMIMG( "G",$E(X,1 ,30),DA)
  50095   "^DD",7410 00.2,74100 0.2,30.07, 1,1,"DT")
  50096   3060621
  50097   "^DD",7410 00.2,74100 0.2,30.07, "DT")
  50098   3060621
  50099   "^DD",7410 00.2,74100 0.2,40,0)
  50100   TRACK PAUS E TIME^741 000.25DA^^ PAUSE;0
  50101   "^DD",7410 00.2,74100 0.2,45,0)
  50102   TRACK EDI- PAUSE TIME ^741000.35 DA^^EDI-PA USE;0
  50103   "^DD",7410 00.2,74100 0.2,100,0)
  50104   COMMENTS^7 41000.24^^ ZCOM;0
  50105   "^DD",7410 00.2,74100 0.2,101,0)
  50106   WORK FLOW  STATUS^741 000.2101P^ ^WF;0
  50107   "^DD",7410 00.2,74100 0.2,301,0)
  50108   TRACKING H ISTORY^741 000.2301P^ ^TRACK-HIS T;0
  50109   "^DD",7410 00.2,74100 0.21,0)
  50110   CLAIMS CRE ATED/AUGME NT BY PDI  SUB-FIELD^ ^.01^1
  50111   "^DD",7410 00.2,74100 0.21,0,"DT ")
  50112   2910305
  50113   "^DD",7410 00.2,74100 0.21,0,"IX ","B",7410 00.21,.01)
  50114  
  50115   "^DD",7410 00.2,74100 0.21,0,"NM ","CLAIMS  CREATED/AU GMENT BY P DI")
  50116  
  50117   "^DD",7410 00.2,74100 0.21,0,"UP ")
  50118   741000.2
  50119   "^DD",7410 00.2,74100 0.21,.01,0 )
  50120   CLAIMS CRE ATED/AUGME NT BY PDI^ P741000'^C HMPAY(^0;1 ^Q
  50121   "^DD",7410 00.2,74100 0.21,.01,1 ,0)
  50122   ^.1
  50123   "^DD",7410 00.2,74100 0.21,.01,1 ,1,0)
  50124   741000.21^ B
  50125   "^DD",7410 00.2,74100 0.21,.01,1 ,1,1)
  50126   S ^CHMIMG( DA(1),1,"B ",$E(X,1,3 0),DA)=""
  50127   "^DD",7410 00.2,74100 0.21,.01,1 ,1,2)
  50128   K ^CHMIMG( DA(1),1,"B ",$E(X,1,3 0),DA)
  50129   "^DD",7410 00.2,74100 0.21,.01," DT")
  50130   2901004
  50131   "^DD",7410 00.2,74100 0.2101,0)
  50132   WORK FLOW  STATUS SUB -FIELD^^.0 3^3
  50133   "^DD",7410 00.2,74100 0.2101,0," DT")
  50134   2951011
  50135   "^DD",7410 00.2,74100 0.2101,0," IX","B",74 1000.2101, .01)
  50136  
  50137   "^DD",7410 00.2,74100 0.2101,0," NM","WORK  FLOW STATU S")
  50138  
  50139   "^DD",7410 00.2,74100 0.2101,0," UP")
  50140   741000.2
  50141   "^DD",7410 00.2,74100 0.2101,.01 ,0)
  50142   WORK FLOW  STATUS^P74 1002.25'^C HMDIC(7410 02.25,^0;1 ^Q
  50143   "^DD",7410 00.2,74100 0.2101,.01 ,1,0)
  50144   ^.1
  50145   "^DD",7410 00.2,74100 0.2101,.01 ,1,1,0)
  50146   741000.210 1^B
  50147   "^DD",7410 00.2,74100 0.2101,.01 ,1,1,1)
  50148   S ^CHMIMG( DA(1),"WF" ,"B",$E(X, 1,30),DA)= ""
  50149   "^DD",7410 00.2,74100 0.2101,.01 ,1,1,2)
  50150   K ^CHMIMG( DA(1),"WF" ,"B",$E(X, 1,30),DA)
  50151   "^DD",7410 00.2,74100 0.2101,.01 ,"DT")
  50152   2931022
  50153   "^DD",7410 00.2,74100 0.2101,.02 ,0)
  50154   WORK FLOW  DATE^D^^0; 2^S %DT="E ST" D ^%DT  S X=Y K:Y <1 X
  50155   "^DD",7410 00.2,74100 0.2101,.02 ,"DT")
  50156   2931022
  50157   "^DD",7410 00.2,74100 0.2101,.03 ,0)
  50158   USER PERFO RMING WORK ^P200'^VA( 200,^0;3^Q
  50159   "^DD",7410 00.2,74100 0.2101,.03 ,"DT")
  50160   2951011
  50161   "^DD",7410 00.2,74100 0.22,0)
  50162   PAGE SUB-F IELD^^1^3
  50163   "^DD",7410 00.2,74100 0.22,0,"DT ")
  50164   2910306
  50165   "^DD",7410 00.2,74100 0.22,0,"IX ","B",7410 00.22,.01)
  50166  
  50167   "^DD",7410 00.2,74100 0.22,0,"NM ","PAGE")
  50168  
  50169   "^DD",7410 00.2,74100 0.22,0,"UP ")
  50170   741000.2
  50171   "^DD",7410 00.2,74100 0.22,.01,0 )
  50172   PAGE^NJ3,0 X^^0;1^K:+ X'=X!(X>99 9)!(X<0)!( X?.E1"."1N .N) X S:$D (X) DINUM= X
  50173   "^DD",7410 00.2,74100 0.22,.01,1 ,0)
  50174   ^.1
  50175   "^DD",7410 00.2,74100 0.22,.01,1 ,1,0)
  50176   741000.22^ B
  50177   "^DD",7410 00.2,74100 0.22,.01,1 ,1,1)
  50178   S ^CHMIMG( DA(1),2,"B ",$E(X,1,3 0),DA)=""
  50179   "^DD",7410 00.2,74100 0.22,.01,1 ,1,2)
  50180   K ^CHMIMG( DA(1),2,"B ",$E(X,1,3 0),DA)
  50181   "^DD",7410 00.2,74100 0.22,.01,3 )
  50182   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  50183   "^DD",7410 00.2,74100 0.22,.01," DT")
  50184   2901006
  50185   "^DD",7410 00.2,74100 0.22,.02,0 )
  50186   FI PAYMENT  FLAG^S^0: NO;1:YES;^ 0;2^Q
  50187   "^DD",7410 00.2,74100 0.22,.02," DT")
  50188   2910306
  50189   "^DD",7410 00.2,74100 0.22,1,0)
  50190   IMAGE^7410 00.221^^1; 0
  50191   "^DD",7410 00.2,74100 0.221,0)
  50192   IMAGE SUB- FIELD^^.04 ^4
  50193   "^DD",7410 00.2,74100 0.221,0,"I X","B",741 000.221,.0 1)
  50194  
  50195   "^DD",7410 00.2,74100 0.221,0,"N M","IMAGE" )
  50196  
  50197   "^DD",7410 00.2,74100 0.221,0,"U P")
  50198   741000.22
  50199   "^DD",7410 00.2,74100 0.221,.01, 0)
  50200   IMAGE^NJ3, 0^^0;1^K:+ X'=X!(X>99 9)!(X<0)!( X?.E1"."1N .N) X
  50201   "^DD",7410 00.2,74100 0.221,.01, 1,0)
  50202   ^.1
  50203   "^DD",7410 00.2,74100 0.221,.01, 1,1,0)
  50204   741000.221 ^B
  50205   "^DD",7410 00.2,74100 0.221,.01, 1,1,1)
  50206   S ^CHMIMG( DA(2),2,DA (1),1,"B", $E(X,1,30) ,DA)=""
  50207   "^DD",7410 00.2,74100 0.221,.01, 1,1,2)
  50208   K ^CHMIMG( DA(2),2,DA (1),1,"B", $E(X,1,30) ,DA)
  50209   "^DD",7410 00.2,74100 0.221,.01, 3)
  50210   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  50211   "^DD",7410 00.2,74100 0.221,.01, "DT")
  50212   2901004
  50213   "^DD",7410 00.2,74100 0.221,.02, 0)
  50214   TYPE OF IM AGE^P74100 2.08'^CHMD IC(741002. 08,^0;2^Q
  50215   "^DD",7410 00.2,74100 0.221,.02, "DT")
  50216   2901004
  50217   "^DD",7410 00.2,74100 0.221,.03, 0)
  50218   IMAGE DATA  ASSIGNED  TO CLAIM^S ^0:NO;1:YE S;^0;3^Q
  50219   "^DD",7410 00.2,74100 0.221,.03, "DT")
  50220   2901004
  50221   "^DD",7410 00.2,74100 0.221,.04, 0)
  50222   TYPE OF SU PP DOC^P74 1002.1'^CH MDIC(74100 2.1,^0;4^Q
  50223   "^DD",7410 00.2,74100 0.221,.04, "DT")
  50224   2901010
  50225   "^DD",7410 00.2,74100 0.23,0)
  50226   FOLDER MAN AGEMENT DI ST. SUB-FI ELD^^.04^4
  50227   "^DD",7410 00.2,74100 0.23,0,"DT ")
  50228   2951011
  50229   "^DD",7410 00.2,74100 0.23,0,"IX ","B",7410 00.23,.01)
  50230  
  50231   "^DD",7410 00.2,74100 0.23,0,"NM ","FOLDER  MANAGEMENT  DIST.")
  50232  
  50233   "^DD",7410 00.2,74100 0.23,0,"UP ")
  50234   741000.2
  50235   "^DD",7410 00.2,74100 0.23,.01,0 )
  50236   CHECK OUT  DATE^D^^0; 1^S %DT="E STR" D ^%D T S X=Y K: Y<1 X
  50237   "^DD",7410 00.2,74100 0.23,.01,1 ,0)
  50238   ^.1
  50239   "^DD",7410 00.2,74100 0.23,.01,1 ,1,0)
  50240   741000.23^ B
  50241   "^DD",7410 00.2,74100 0.23,.01,1 ,1,1)
  50242   S ^CHMIMG( DA(1),5,"B ",$E(X,1,3 0),DA)=""
  50243   "^DD",7410 00.2,74100 0.23,.01,1 ,1,2)
  50244   K ^CHMIMG( DA(1),5,"B ",$E(X,1,3 0),DA)
  50245   "^DD",7410 00.2,74100 0.23,.01," DT")
  50246   2910628
  50247   "^DD",7410 00.2,74100 0.23,.02,0 )
  50248   DATE CHECK ED IN^D^^0 ;2^S %DT=" ESTR" D ^% DT S X=Y K :Y<1 X
  50249   "^DD",7410 00.2,74100 0.23,.02," DT")
  50250   2910628
  50251   "^DD",7410 00.2,74100 0.23,.03,0 )
  50252   CLAIM SUPP ORT UNIT^P 741002.36' ^CHMDIC(74 1002.36,^0 ;3^Q
  50253   "^DD",7410 00.2,74100 0.23,.03," DT")
  50254   2910628
  50255   "^DD",7410 00.2,74100 0.23,.04,0 )
  50256   DUZ^P200'^ VA(200,^0; 4^Q
  50257   "^DD",7410 00.2,74100 0.23,.04," DT")
  50258   2951011
  50259   "^DD",7410 00.2,74100 0.2301,0)
  50260   TRACKING H ISTORY SUB -FIELD^^.0 6^4
  50261   "^DD",7410 00.2,74100 0.2301,0," DT")
  50262   2960111
  50263   "^DD",7410 00.2,74100 0.2301,0," IX","B",74 1000.2301, .01)
  50264  
  50265   "^DD",7410 00.2,74100 0.2301,0," NM","TRACK ING HISTOR Y")
  50266  
  50267   "^DD",7410 00.2,74100 0.2301,0," UP")
  50268   741000.2
  50269   "^DD",7410 00.2,74100 0.2301,.01 ,0)
  50270   SUBMIS TRA CKING DFN  HIST^P5548 01'^AHCHVA (^0;1^Q
  50271   "^DD",7410 00.2,74100 0.2301,.01 ,1,0)
  50272   ^.1
  50273   "^DD",7410 00.2,74100 0.2301,.01 ,1,1,0)
  50274   741000.230 1^B
  50275   "^DD",7410 00.2,74100 0.2301,.01 ,1,1,1)
  50276   S ^CHMIMG( DA(1),"TRA CK-HIST"," B",$E(X,1, 30),DA)=""
  50277   "^DD",7410 00.2,74100 0.2301,.01 ,1,1,2)
  50278   K ^CHMIMG( DA(1),"TRA CK-HIST"," B",$E(X,1, 30),DA)
  50279   "^DD",7410 00.2,74100 0.2301,.01 ,"DT")
  50280   2960111
  50281   "^DD",7410 00.2,74100 0.2301,.02 ,0)
  50282   SUBMIS TRA CKING BFN  HIST^NJ3,0 ^^0;2^K:+X '=X!(X>999 )!(X<1)!(X ?.E1"."1N. N) X
  50283   "^DD",7410 00.2,74100 0.2301,.02 ,3)
  50284   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  50285   "^DD",7410 00.2,74100 0.2301,.02 ,"DT")
  50286   2960111
  50287   "^DD",7410 00.2,74100 0.2301,.05 ,0)
  50288   DUZ SETTIN G TRACKING  HISTORY^P 200'^VA(20 0,^0;5^Q
  50289   "^DD",7410 00.2,74100 0.2301,.05 ,"DT")
  50290   2960111
  50291   "^DD",7410 00.2,74100 0.2301,.06 ,0)
  50292   DATE/TIME  TRACKING H ISTORY SET ^D^^0;6^S  %DT="EST"  D ^%DT S X =Y K:Y<1 X
  50293   "^DD",7410 00.2,74100 0.2301,.06 ,"DT")
  50294   2960111
  50295   "^DD",7410 00.2,74100 0.24,0)
  50296   COMMENTS S UB-FIELD^^ .01^1
  50297   "^DD",7410 00.2,74100 0.24,0,"DT ")
  50298   2930714
  50299   "^DD",7410 00.2,74100 0.24,0,"NM ","COMMENT S")
  50300  
  50301   "^DD",7410 00.2,74100 0.24,0,"UP ")
  50302   741000.2
  50303   "^DD",7410 00.2,74100 0.24,.01,0 )
  50304   COMMENTS^W ^^0;1^Q
  50305   "^DD",7410 00.2,74100 0.24,.01," DT")
  50306   2930714
  50307   "^DD",7410 00.2,74100 0.25,0)
  50308   TRACK PAUS E TIME SUB -FIELD^^2^ 3
  50309   "^DD",7410 00.2,74100 0.25,0,"DT ")
  50310   2951011
  50311   "^DD",7410 00.2,74100 0.25,0,"IX ","B",7410 00.25,.01)
  50312  
  50313   "^DD",7410 00.2,74100 0.25,0,"NM ","TRACK P AUSE TIME" )
  50314  
  50315   "^DD",7410 00.2,74100 0.25,0,"UP ")
  50316   741000.2
  50317   "^DD",7410 00.2,74100 0.25,.01,0 )
  50318   TIME SET T O PAUSE^D^ ^0;1^S %DT ="EST" D ^ %DT S X=Y  K:Y<1 X
  50319   "^DD",7410 00.2,74100 0.25,.01,1 ,0)
  50320   ^.1
  50321   "^DD",7410 00.2,74100 0.25,.01,1 ,1,0)
  50322   741000.25^ B
  50323   "^DD",7410 00.2,74100 0.25,.01,1 ,1,1)
  50324   S ^CHMIMG( DA(1),"PAU SE","B",$E (X,1,30),D A)=""
  50325   "^DD",7410 00.2,74100 0.25,.01,1 ,1,2)
  50326   K ^CHMIMG( DA(1),"PAU SE","B",$E (X,1,30),D A)
  50327   "^DD",7410 00.2,74100 0.25,.01,3 )
  50328  
  50329   "^DD",7410 00.2,74100 0.25,.01," DT")
  50330   2940214
  50331   "^DD",7410 00.2,74100 0.25,1,0)
  50332   DUZ^P200'^ VA(200,^0; 2^Q
  50333   "^DD",7410 00.2,74100 0.25,1,"DT ")
  50334   2951011
  50335   "^DD",7410 00.2,74100 0.25,2,0)
  50336   TIME REMOV ED FROM PA USE^D^^0;3 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  50337   "^DD",7410 00.2,74100 0.25,2,"DT ")
  50338   2940214
  50339   "^DD",7410 00.2,74100 0.26,0)
  50340   BARDCODE D ATE SUB-FI ELD^^.06^6
  50341   "^DD",7410 00.2,74100 0.26,0,"DT ")
  50342   2950915
  50343   "^DD",7410 00.2,74100 0.26,0,"IX ","B",7410 00.26,.01)
  50344  
  50345   "^DD",7410 00.2,74100 0.26,0,"NM ","BARDCOD E DATE")
  50346  
  50347   "^DD",7410 00.2,74100 0.26,0,"UP ")
  50348   741000.2
  50349   "^DD",7410 00.2,74100 0.26,.01,0 )
  50350   BARDCODE D ATE^D^^0;1 ^S %DT="E"  D ^%DT S  X=Y K:Y<1  X
  50351   "^DD",7410 00.2,74100 0.26,.01,1 ,0)
  50352   ^.1
  50353   "^DD",7410 00.2,74100 0.26,.01,1 ,1,0)
  50354   741000.26^ B
  50355   "^DD",7410 00.2,74100 0.26,.01,1 ,1,1)
  50356   S ^CHMIMG( DA(1),"BAR CODE","B", $E(X,1,30) ,DA)=""
  50357   "^DD",7410 00.2,74100 0.26,.01,1 ,1,2)
  50358   K ^CHMIMG( DA(1),"BAR CODE","B", $E(X,1,30) ,DA)
  50359   "^DD",7410 00.2,74100 0.26,.01," DT")
  50360   2950915
  50361   "^DD",7410 00.2,74100 0.26,.02,0 )
  50362   WHO BARCOD ED^P200'^V A(200,^0;2 ^Q
  50363   "^DD",7410 00.2,74100 0.26,.02," DT")
  50364   2950915
  50365   "^DD",7410 00.2,74100 0.26,.03,0 )
  50366   DATE SCANN ED^D^^0;3^ S %DT="E"  D ^%DT S X =Y K:Y<1 X
  50367   "^DD",7410 00.2,74100 0.26,.03," DT")
  50368   2950915
  50369   "^DD",7410 00.2,74100 0.26,.04,0 )
  50370   WHO SCANNE D^P200'^VA (200,^0;4^ Q
  50371   "^DD",7410 00.2,74100 0.26,.04," DT")
  50372   2950915
  50373   "^DD",7410 00.2,74100 0.26,.05,0 )
  50374   DATE WANDE D^D^^0;5^S  %DT="E" D  ^%DT S X= Y K:Y<1 X
  50375   "^DD",7410 00.2,74100 0.26,.05," DT")
  50376   2950915
  50377   "^DD",7410 00.2,74100 0.26,.06,0 )
  50378   WHO WANDED  ^P200'^VA (200,^0;6^ Q
  50379   "^DD",7410 00.2,74100 0.26,.06," DT")
  50380   2950915
  50381   "^DD",7410 00.2,74100 0.35,0)
  50382   TRACK EDI- PAUSE TIME  SUB-FIELD ^^3^4
  50383   "^DD",7410 00.2,74100 0.35,0,"DT ")
  50384   3180215
  50385   "^DD",7410 00.2,74100 0.35,0,"IX ","B",7410 00.35,.01)
  50386  
  50387   "^DD",7410 00.2,74100 0.35,0,"NM ","TRACK E DI-PAUSE T IME")
  50388  
  50389   "^DD",7410 00.2,74100 0.35,0,"UP ")
  50390   741000.2
  50391   "^DD",7410 00.2,74100 0.35,.01,0 )
  50392   TIME SET T O EDI-PAUS E^D^^0;1^S  %DT="EST"  D ^%DT S  X=Y K:Y<1  X
  50393   "^DD",7410 00.2,74100 0.35,.01,1 ,0)
  50394   ^.1
  50395   "^DD",7410 00.2,74100 0.35,.01,1 ,1,0)
  50396   741000.35^ B
  50397   "^DD",7410 00.2,74100 0.35,.01,1 ,1,1)
  50398   S ^CHMIMG( DA(1),"EDI -PAUSE","B ",$E(X,1,3 0),DA)=""
  50399   "^DD",7410 00.2,74100 0.35,.01,1 ,1,2)
  50400   K ^CHMIMG( DA(1),"EDI -PAUSE","B ",$E(X,1,3 0),DA)
  50401   "^DD",7410 00.2,74100 0.35,.01,1 ,2,0)
  50402   741000.2^E DIPAUSE^MU MPS
  50403   "^DD",7410 00.2,74100 0.35,.01,1 ,2,1)
  50404   S ^CHMIMG( "EDIPAUSE" ,DA(1))=""
  50405   "^DD",7410 00.2,74100 0.35,.01,1 ,2,2)
  50406   K ^CHMIMG( "EDIPAUSE" ,DA(1))
  50407   "^DD",7410 00.2,74100 0.35,.01,1 ,2,"DT")
  50408   3180206
  50409   "^DD",7410 00.2,74100 0.35,.01,3 )
  50410   Enter Date  and Time  of entry i nto EDI-PA USE
  50411   "^DD",7410 00.2,74100 0.35,.01," DT")
  50412   3180206
  50413   "^DD",7410 00.2,74100 0.35,1,0)
  50414   DUZ^P200'^ VA(200,^0; 2^Q
  50415   "^DD",7410 00.2,74100 0.35,1,3)
  50416   Enter the  DUZ of the  New Perso n
  50417   "^DD",7410 00.2,74100 0.35,1,"DT ")
  50418   3180206
  50419   "^DD",7410 00.2,74100 0.35,2,0)
  50420   TIME REMOV ED FROM ED I-PAUSE^DX ^^0;3^S %D T="EST" D  ^%DT S X=Y  K:X<1 X
  50421   "^DD",7410 00.2,74100 0.35,2,3)
  50422   Enter Time  Removed f rom EDI-PA USE for a  single IEN
  50423   "^DD",7410 00.2,74100 0.35,2,21, 0)
  50424   ^^1^1^3180 206^
  50425   "^DD",7410 00.2,74100 0.35,2,21, 1,0)
  50426   Date and T ime of sto p for a si ngle IEN t o "EDI-PAU SE" file
  50427   "^DD",7410 00.2,74100 0.35,2,"DT ")
  50428   3180206
  50429   "^DD",7410 00.2,74100 0.35,3,0)
  50430   ORIG PDI P AY REQ CLA IM NUMS^74 1000.353A^ ^1;0
  50431   "^DD",7410 00.2,74100 0.35,3,21, 0)
  50432   ^^3^3^3180 215^
  50433   "^DD",7410 00.2,74100 0.35,3,21, 1,0)
  50434   This is th e Original  PDI's Pay ment Reque sted Claim  Numbers f or this
  50435   "^DD",7410 00.2,74100 0.35,3,21, 2,0)
  50436   Current PD I. Origina l Claim wi ll be vali dated to a llow for r elease of
  50437   "^DD",7410 00.2,74100 0.35,3,21, 3,0)
  50438   Current PD I.
  50439   "^DD",7410 00.2,74100 0.35,3,"DT ")
  50440   3180215
  50441   "^DD",7410 00.2,74100 0.353,0)
  50442   ORIG PDI P AY REQ CLA IM NUMS SU B-FIELD^^. 01^1
  50443   "^DD",7410 00.2,74100 0.353,0,"D T")
  50444   3180215
  50445   "^DD",7410 00.2,74100 0.353,0,"I X","B",741 000.353,.0 1)
  50446  
  50447   "^DD",7410 00.2,74100 0.353,0,"N M","ORIG P DI PAY REQ  CLAIM NUM S")
  50448  
  50449   "^DD",7410 00.2,74100 0.353,0,"U P")
  50450   741000.35
  50451   "^DD",7410 00.2,74100 0.353,.01, 0)
  50452   ORIG PDI P AY REQ CLA IM NUMS^FJ 99^^0;1^K: $L(X)>99!( $L(X)<1) X
  50453   "^DD",7410 00.2,74100 0.353,.01, 1,0)
  50454   ^.1
  50455   "^DD",7410 00.2,74100 0.353,.01, 1,1,0)
  50456   741000.353 ^B
  50457   "^DD",7410 00.2,74100 0.353,.01, 1,1,1)
  50458   S ^CHMIMG( DA(2),"EDI -PAUSE",DA (1),1,"B", $E(X,1,30) ,DA)=""
  50459   "^DD",7410 00.2,74100 0.353,.01, 1,1,2)
  50460   K ^CHMIMG( DA(2),"EDI -PAUSE",DA (1),1,"B", $E(X,1,30) ,DA)
  50461   "^DD",7410 00.2,74100 0.353,.01, 3)
  50462   Enter the  Original P DI's Payme nt Request ed Claim N umber
  50463   "^DD",7410 00.2,74100 0.353,.01, "DT")
  50464   3180215
  50465   "^DD",7410 02.17,7410 02.17,0)
  50466   FIELD^^.37 ^104
  50467   "^DD",7410 02.17,7410 02.17,0,"D DA")
  50468   N
  50469   "^DD",7410 02.17,7410 02.17,0,"D T")
  50470   3130903
  50471   "^DD",7410 02.17,7410 02.17,0,"N M","CHAMPV A PAYMENT  PARAMETER" )
  50472  
  50473   "^DD",7410 02.17,7410 02.17,0,"V RPK")
  50474   CH
  50475   "^DD",7410 02.17,7410 02.17,.01, 0)
  50476   MCCR DATA  COLLECTION  FLAG^S^0: MCCR UNIT  RESP.;1:DA TA ENTRY C LERK RESP. ;^0;1^Q
  50477   "^DD",7410 02.17,7410 02.17,.01, .1)
  50478  
  50479   "^DD",7410 02.17,7410 02.17,.01, 1,0)
  50480   ^.1^^0
  50481   "^DD",7410 02.17,7410 02.17,.01, 3)
  50482  
  50483   "^DD",7410 02.17,7410 02.17,.01, "DT")
  50484   2900927
  50485   "^DD",7410 02.17,7410 02.17,.02, 0)
  50486   STATUS OVE RRIDE ^S^1 :YES;0:NO; ^0;2^Q
  50487   "^DD",7410 02.17,7410 02.17,.02, "DT")
  50488   2910107
  50489   "^DD",7410 02.17,7410 02.17,.03, 0)
  50490   VENDOR OVE RRIDE FOR  TEST ONLY^ P741001^CH MVEN(^0;3^ Q
  50491   "^DD",7410 02.17,7410 02.17,.03, 3)
  50492  
  50493   "^DD",7410 02.17,7410 02.17,.03, "DT")
  50494   2910120
  50495   "^DD",7410 02.17,7410 02.17,.04, 0)
  50496   MAXIMUM CA LM TRANS P ER BATCH^N J2,0^^0;4^ K:+X'=X!(X >99)!(X<2) !(X?.E1"." 1N.N) X
  50497   "^DD",7410 02.17,7410 02.17,.04, 3)
  50498   Type a Num ber betwee n 2 and 99 , 0 Decima l Digits
  50499   "^DD",7410 02.17,7410 02.17,.04, "DT")
  50500   2910207
  50501   "^DD",7410 02.17,7410 02.17,.05, 0)
  50502   CURRENT CO RRES BATCH ^F^^0;5^K: $L(X)>10!( $L(X)<1)!' (X?1N.E) X
  50503   "^DD",7410 02.17,7410 02.17,.05, 3)
  50504   Answer mus t be 1-10  characters  in length .
  50505   "^DD",7410 02.17,7410 02.17,.05, "DT")
  50506   2910211
  50507   "^DD",7410 02.17,7410 02.17,.06, 0)
  50508   CURRENT QA  REVIEW FA CTOR^NJ6,4 ^^0;6^K:+X '=X!(X>1)! (X<0)!(X?. E1"."5N.N)  X
  50509   "^DD",7410 02.17,7410 02.17,.06, 3)
  50510   Type a Num ber betwee n 0 and 1,  4 Decimal  Digits
  50511   "^DD",7410 02.17,7410 02.17,.06, "DT")
  50512   2910305
  50513   "^DD",7410 02.17,7410 02.17,.07, 0)
  50514   UNUSUAL FE E UPPER LI MIT^NJ5,2^ ^0;7^K:+X' =X!(X>99)! (X<1)!(X?. E1"."3N.N)  X
  50515   "^DD",7410 02.17,7410 02.17,.07, 3)
  50516   Type a Num ber betwee n 1 and 99 , 2 Decima l Digits
  50517   "^DD",7410 02.17,7410 02.17,.07, "DT")
  50518   2920605
  50519   "^DD",7410 02.17,7410 02.17,.08, 0)
  50520   MCCR ACTIV E PERIOD^N J3,0^^0;8^ K:+X'=X!(X >999)!(X<1 )!(X?.E1". "1N.N) X
  50521   "^DD",7410 02.17,7410 02.17,.08, 3)
  50522   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  50523   "^DD",7410 02.17,7410 02.17,.08, "DT")
  50524   2910307
  50525   "^DD",7410 02.17,7410 02.17,.09, 0)
  50526   AUTO FUNDS  TRANSFER  ACTIVATED^ S^0:OFF;1: ON;^0;9^Q
  50527   "^DD",7410 02.17,7410 02.17,.09, "DT")
  50528   2910320
  50529   "^DD",7410 02.17,7410 02.17,.1,0 )
  50530   DATE OF LA ST UPDATE^ NJ5,0^^0;1 0^K:+X'=X! (X>99999)! (X<0)!(X?. E1"."1N.N)  X
  50531   "^DD",7410 02.17,7410 02.17,.1,3 )
  50532   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  50533   "^DD",7410 02.17,7410 02.17,.1," DT")
  50534   2910401
  50535   "^DD",7410 02.17,7410 02.17,.11, 0)
  50536   CAPPS/CALM  SUBMISSIO N APPROVED ^S^0:NO;1: YES;^0;11^ Q
  50537   "^DD",7410 02.17,7410 02.17,.11, "DT")
  50538   2910519
  50539   "^DD",7410 02.17,7410 02.17,.12, 0)
  50540   UCI SUBMIT TING CAPP/ CALM DATA^ S^DEV:DEV; TRN:TRN;AU D:AUD;VAH: VAH;^0;12^ Q
  50541   "^DD",7410 02.17,7410 02.17,.12, "DT")
  50542   2910519
  50543   "^DD",7410 02.17,7410 02.17,.13, 0)
  50544   START TIME  CAPPS/CAL M RETURN^N J5,0^^0;13 ^K:+X'=X!( X>86000)!( X<0)!(X?.E 1"."1N.N)  X
  50545   "^DD",7410 02.17,7410 02.17,.13, 3)
  50546   Type a Num ber betwee n 0 and 86 000, 0 Dec imal Digit s
  50547   "^DD",7410 02.17,7410 02.17,.13, "DT")
  50548   2910520
  50549   "^DD",7410 02.17,7410 02.17,.14, 0)
  50550   START TIME :CAPPS/CAL M PICKUP^N J5,0^^0;14 ^K:+X'=X!( X>86000)!( X<0)!(X?.E 1"."1N.N)  X
  50551   "^DD",7410 02.17,7410 02.17,.14, 3)
  50552   Type a Num ber betwee n 0 and 86 000, 0 Dec imal Digit s
  50553   "^DD",7410 02.17,7410 02.17,.14, "DT")
  50554   2910520
  50555   "^DD",7410 02.17,7410 02.17,.15, 0)
  50556   BATCH PROC ESSING ON/ OFF^S^0:OF F;1:ON;2:O N BLANK DA TA SET ONL Y;^0;15^Q
  50557   "^DD",7410 02.17,7410 02.17,.15, "DT")
  50558   2910624
  50559   "^DD",7410 02.17,7410 02.17,.16, 0)
  50560   PROCESSING  BEGIN DAY ^S^0:SUNDA Y;1:MONDAY ;2:TUESDAY ;3:WEDNESD AY;4:THURS DAY;5:FRID AY;6:SATUR DAY;^0;16^ Q
  50561   "^DD",7410 02.17,7410 02.17,.16, "DT")
  50562   2910622
  50563   "^DD",7410 02.17,7410 02.17,.17, 0)
  50564   PROCESSING  END DAY^S ^0:SUNDAY; 1:MONDAY;2 :TUESDAY;3 :WEDNESDAY ;4:THURSDA Y;5:FRIDAY ;6:SATURDA Y;^0;17^Q
  50565   "^DD",7410 02.17,7410 02.17,.17, "DT")
  50566   2910622
  50567   "^DD",7410 02.17,7410 02.17,.18, 0)
  50568   MANUAL ON/ OFF FLAG^S ^0:OFF;1:O N;^0;18^Q
  50569   "^DD",7410 02.17,7410 02.17,.18, "DT")
  50570   2910627
  50571   "^DD",7410 02.17,7410 02.17,.19, 0)
  50572   PRINTER FO R ROUTING  SLIP^F^^0; 19^K:$L(X) >30!($L(X) <3) X
  50573   "^DD",7410 02.17,7410 02.17,.19, 3)
  50574   Answer mus t be 3-30  characters  in length .
  50575   "^DD",7410 02.17,7410 02.17,.19, "DT")
  50576   2910627
  50577   "^DD",7410 02.17,7410 02.17,.21, 0)
  50578   POST PROCE SSING REP  PRINTER^F^ ^0;21^K:$L (X)>30!($L (X)<3) X
  50579   "^DD",7410 02.17,7410 02.17,.21, 3)
  50580   Answer mus t be 3-30  characters  in length .
  50581   "^DD",7410 02.17,7410 02.17,.21, "DT")
  50582   2910628
  50583   "^DD",7410 02.17,7410 02.17,.22, 0)
  50584   DME AMOUNT  FOR REJEC TION^NJ7,2 ^^0;22^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 99)!(X<0)  X
  50585   "^DD",7410 02.17,7410 02.17,.22, 3)
  50586   Type a Dol lar Amount  between 0  and 9999,  2 Decimal  Digits
  50587   "^DD",7410 02.17,7410 02.17,.22, "DT")
  50588   2911018
  50589   "^DD",7410 02.17,7410 02.17,.25, 0)
  50590   MH DAYS LI MIT^NJ3,0^ ^0;25^K:+X '=X!(X>365 )!(X<0)!(X ?.E1"."1N. N) X
  50591   "^DD",7410 02.17,7410 02.17,.25, 3)
  50592   Type a Num ber betwee n 0 and 36 5, 0 Decim al Digits
  50593   "^DD",7410 02.17,7410 02.17,.25, "DT")
  50594   2920207
  50595   "^DD",7410 02.17,7410 02.17,.26, 0)
  50596   ALCOHOL DA YS LIMIT^N J3,0^^0;26 ^K:+X'=X!( X>365)!(X< 0)!(X?.E1" ."1N.N) X
  50597   "^DD",7410 02.17,7410 02.17,.26, 3)
  50598   Type a Num ber betwee n 0 and 36 5, 0 Decim al Digits
  50599   "^DD",7410 02.17,7410 02.17,.26, "DT")
  50600   2920207
  50601   "^DD",7410 02.17,7410 02.17,.27, 0)
  50602   BATCH PROC  TRACKING  FLAG^S^0:O FF;1:ON;^0 ;27^Q
  50603   "^DD",7410 02.17,7410 02.17,.27, "DT")
  50604   2920514
  50605   "^DD",7410 02.17,7410 02.17,.28, 0)
  50606   UNUSUAL FE E LOWER LI MIT^NJ7,2^ ^0;28^K:+X '=X!(X>999 9)!(X<0)!( X?.E1"."3N .N) X
  50607   "^DD",7410 02.17,7410 02.17,.28, 3)
  50608   Type a Num ber betwee n 0 and 99 99, 2 Deci mal Digits
  50609   "^DD",7410 02.17,7410 02.17,.28, "DT")
  50610   2920605
  50611   "^DD",7410 02.17,7410 02.17,.29, 0)
  50612   INP VENDOR  FLAG^S^0: NO VENDOR; 1:GO TO VE NDOR;^0;29 ^Q
  50613   "^DD",7410 02.17,7410 02.17,.29, "DT")
  50614   2920616
  50615   "^DD",7410 02.17,7410 02.17,.3,0 )
  50616   MH DAYS UN DER 19^NJ3 ,0^^0;30^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X
  50617   "^DD",7410 02.17,7410 02.17,.3,3 )
  50618   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  50619   "^DD",7410 02.17,7410 02.17,.3," DT")
  50620   2930402
  50621   "^DD",7410 02.17,7410 02.17,.31, 0)
  50622   VENDOR MAX  RETURNS T O BATCH^NJ 2,0^^0;31^ K:+X'=X!(X >99)!(X<0) !(X?.E1"." 1N.N) X
  50623   "^DD",7410 02.17,7410 02.17,.31, 3)
  50624   Type a Num ber betwee n 0 and 99 , 0 Decima l Digits
  50625   "^DD",7410 02.17,7410 02.17,.31, "DT")
  50626   2931105
  50627   "^DD",7410 02.17,7410 02.17,.32, 0)
  50628   MAIL MANAG ER ON/OFF^ S^0:OFF;1: ON;^2;4^Q
  50629   "^DD",7410 02.17,7410 02.17,.32, "DT")
  50630   2940202
  50631   "^DD",7410 02.17,7410 02.17,.33, 0)
  50632   MAIL MANAG ER DISK NA ME^F^^2;5^ K:$L(X)>50 !($L(X)<1)  X
  50633   "^DD",7410 02.17,7410 02.17,.33, 3)
  50634   Answer mus t be 1-50  characters  in length .
  50635   "^DD",7410 02.17,7410 02.17,.33, "DT")
  50636   2940211
  50637   "^DD",7410 02.17,7410 02.17,.34, 0)
  50638   MAIL MANAG ER IMPORT  FILE NAME^ F^^2;6^K:$ L(X)>80!($ L(X)<1) X
  50639   "^DD",7410 02.17,7410 02.17,.34, 3)
  50640   Answer mus t be 1-80  characters  in length .
  50641   "^DD",7410 02.17,7410 02.17,.34, "DT")
  50642   2940225
  50643   "^DD",7410 02.17,7410 02.17,.35, 0)
  50644   EOB BARCOD E ON/OFF^S ^0:OFF;1:O N;^2;7^Q
  50645   "^DD",7410 02.17,7410 02.17,.35, "DT")
  50646   2940407
  50647   "^DD",7410 02.17,7410 02.17,.36, 0)
  50648   BA ASSIGNE D TO GENER AL CORRES^ P741002.81 '^CHMDIC(7 41002.81,^ 0;36^Q
  50649   "^DD",7410 02.17,7410 02.17,.36, "DT")
  50650   2940622
  50651   "^DD",7410 02.17,7410 02.17,.37, 0)
  50652   START LIMB O CLM #^P7 41000'^CHM PAY(^0;37^ Q
  50653   "^DD",7410 02.17,7410 02.17,.37, "DT")
  50654   3070104
  50655   "^DD",7410 02.17,7410 02.17,.4,0 )
  50656   CORR DAYS  PEND BEFOR E REJECT^N J3,0^^3;1^ K:+X'=X!(X >999)!(X<0 )!(X?.E1". "1N.N) X
  50657   "^DD",7410 02.17,7410 02.17,.4,3 )
  50658   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  50659   "^DD",7410 02.17,7410 02.17,.4," DT")
  50660   2940207
  50661   "^DD",7410 02.17,7410 02.17,.41, 0)
  50662   REMOVE CKS <THIS AMT  FROM BATCH ^NJ9,2^^0; 41^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>999999 )!(X<0) X
  50663   "^DD",7410 02.17,7410 02.17,.41, 3)
  50664   Type a Dol lar Amount  between 0  and 99999 9, 2 Decim al Digits
  50665   "^DD",7410 02.17,7410 02.17,.41, "DT")
  50666   2950912
  50667   "^DD",7410 02.17,7410 02.17,1,0)
  50668   # SECONDS  TO DELAY P RINTING^NJ 6,0^^0;20^ K:+X'=X!(X >999999)!( X<1)!(X?.E 1"."1N.N)  X
  50669   "^DD",7410 02.17,7410 02.17,1,3)
  50670   Type a Num ber betwee n 1 and 99 9999, 0 De cimal Digi ts
  50671   "^DD",7410 02.17,7410 02.17,1,"D T")
  50672   2910628
  50673   "^DD",7410 02.17,7410 02.17,1.01 ,0)
  50674   ASA EFFECT IVE END DA TE^741002. 18D^^1;0
  50675   "^DD",7410 02.17,7410 02.17,2,0)
  50676   PRINTER FO R INPROG R OUTE SLIP^ F^^0;23^K: $L(X)>30!( $L(X)<3) X
  50677   "^DD",7410 02.17,7410 02.17,2,3)
  50678   Answer mus t be 3-30  characters  in length .
  50679   "^DD",7410 02.17,7410 02.17,2,"D T")
  50680   2911113
  50681   "^DD",7410 02.17,7410 02.17,2.01 ,0)
  50682   EFFECTIVE  END DATE ( C H DIFF)^ 741002.19D ^^5;0
  50683   "^DD",7410 02.17,7410 02.17,2.08 ,0)
  50684   EOB MAXIMU M PAGES^NJ 3,0^^2;8^K :+X'=X!(X> 100)!(X<1) !(X?.E1"." 1N.N) X
  50685   "^DD",7410 02.17,7410 02.17,2.08 ,3)
  50686   Type a Num ber betwee n 1 and 10 0, 0 Decim al Digits
  50687   "^DD",7410 02.17,7410 02.17,2.08 ,"DT")
  50688   2940502
  50689   "^DD",7410 02.17,7410 02.17,2.09 ,0)
  50690   PREVIOUS R UNS LAST P ULL LIST # ^F^^2;9^K: $L(X)>10!( $L(X)<1) X
  50691   "^DD",7410 02.17,7410 02.17,2.09 ,3)
  50692   Answer mus t be 1-10  characters  in length .
  50693   "^DD",7410 02.17,7410 02.17,2.09 ,"DT")
  50694   2970220
  50695   "^DD",7410 02.17,7410 02.17,2.1, 0)
  50696   FTP # of m inutes to  wait^NJ5,0 ^^2;10^K:+ X'=X!(X>99 999)!(X<0) !(X?.E1"." 1N.N) X
  50697   "^DD",7410 02.17,7410 02.17,2.1, 3)
  50698   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  50699   "^DD",7410 02.17,7410 02.17,2.1, "DT")
  50700   2991210
  50701   "^DD",7410 02.17,7410 02.17,3,0)
  50702   PRINTING O F PPR FLAG ^S^0:OFF ; 1:ON;^0;24 ^Q
  50703   "^DD",7410 02.17,7410 02.17,3,"D T")
  50704   2911114
  50705   "^DD",7410 02.17,7410 02.17,3.01 ,0)
  50706   EFFECTIVE  END DATE ( LVMH)^7410 02.7D^^10; 0
  50707   "^DD",7410 02.17,7410 02.17,3.02 ,0)
  50708   % OHI CLAI MS W/AMT T O ASQ^NJ3, 0^^3;2^K:+ X'=X!(X>10 0)!(X<0)!( X?.E1"."1N .N) X
  50709   "^DD",7410 02.17,7410 02.17,3.02 ,3)
  50710   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  50711   "^DD",7410 02.17,7410 02.17,3.02 ,"DT")
  50712   2950410
  50713   "^DD",7410 02.17,7410 02.17,3.03 ,0)
  50714   DOC ID # F OR FMS PAY MENT^F^^3; 3^K:$L(X)> 7!($L(X)<1 ) X
  50715   "^DD",7410 02.17,7410 02.17,3.03 ,3)
  50716   Answer mus t be 1-7 c haracters  in length.
  50717   "^DD",7410 02.17,7410 02.17,3.03 ,"DT")
  50718   3061107
  50719   "^DD",7410 02.17,7410 02.17,3.04 ,0)
  50720   CURRENT FI SCAL YR^NJ 3,0^^3;4^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X
  50721   "^DD",7410 02.17,7410 02.17,3.04 ,3)
  50722   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  50723   "^DD",7410 02.17,7410 02.17,3.04 ,"DT")
  50724   2950522
  50725   "^DD",7410 02.17,7410 02.17,3.05 ,0)
  50726   FMS BATCH  NUMBER^NJ3 ,0^^3;5^K: +X'=X!(X>9 99)!(X<0)! (X?.E1"."1 N.N) X
  50727   "^DD",7410 02.17,7410 02.17,3.05 ,3)
  50728   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  50729   "^DD",7410 02.17,7410 02.17,3.05 ,"DT")
  50730   2950522
  50731   "^DD",7410 02.17,7410 02.17,3.06 ,0)
  50732   % INPT OHI  CLAIMS W/ AMT TO ASQ ^NJ3,0^^3; 6^K:+X'=X! (X>100)!(X <0)!(X?.E1 "."1N.N) X
  50733   "^DD",7410 02.17,7410 02.17,3.06 ,3)
  50734   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  50735   "^DD",7410 02.17,7410 02.17,3.06 ,"DT")
  50736   2950710
  50737   "^DD",7410 02.17,7410 02.17,3.07 ,0)
  50738   OHI STACKI NG FLAG FO R ASQ^S^1: ON;0:OFF;^ 3;7^Q
  50739   "^DD",7410 02.17,7410 02.17,3.07 ,"DT")
  50740   2950821
  50741   "^DD",7410 02.17,7410 02.17,3.08 ,0)
  50742   BARCODE #  OF PDIS ON  PULL LIST ^NJ3,0^^3; 8^K:+X'=X! (X>150)!(X <0)!(X?.E1 "."1N.N) X
  50743   "^DD",7410 02.17,7410 02.17,3.08 ,3)
  50744   Type a Num ber betwee n 0 and 15 0, 0 Decim al Digits
  50745   "^DD",7410 02.17,7410 02.17,3.08 ,"DT")
  50746   2950925
  50747   "^DD",7410 02.17,7410 02.17,3.09 ,0)
  50748   BARCODE OL DEST DATE  RECEIVED ^ D^^3;9^S % DT="E" D ^ %DT S X=Y  K:Y<1 X
  50749   "^DD",7410 02.17,7410 02.17,3.09 ,"DT")
  50750   2951002
  50751   "^DD",7410 02.17,7410 02.17,3.1, 0)
  50752   MANUAL BAT CH PROC^S^ 0:NO;1:YES ;^3;10^Q
  50753   "^DD",7410 02.17,7410 02.17,3.1, "DT")
  50754   2951005
  50755   "^DD",7410 02.17,7410 02.17,3.11 ,0)
  50756   # CLAIMS T O BE SENT  TO AUSTIN^ NJ6,0^^3;1 1^K:+X'=X! (X>999999) !(X<0)!(X? .E1"."1N.N ) X
  50757   "^DD",7410 02.17,7410 02.17,3.11 ,3)
  50758   Type a Num ber betwee n 0 and 99 9999, 0 De cimal Digi ts
  50759   "^DD",7410 02.17,7410 02.17,3.11 ,"DT")
  50760   2951011
  50761   "^DD",7410 02.17,7410 02.17,3.12 ,0)
  50762   BLOCK WAND ING TO PUL L LIST^S^0 :DON'T BLO CK;1:BLOCK ;^3;12^Q
  50763   "^DD",7410 02.17,7410 02.17,3.12 ,3)
  50764   Enter '1'  if wanding  of PDI sh ould be bl ocked if n o Doc ID.
  50765   "^DD",7410 02.17,7410 02.17,3.12 ,21,0)
  50766   ^^2^2^2960 202^
  50767   "^DD",7410 02.17,7410 02.17,3.12 ,21,1,0)
  50768   If this fl ag is set,  wanding o f a PDI on to a pull  list will  be
  50769   "^DD",7410 02.17,7410 02.17,3.12 ,21,2,0)
  50770   blocked if  no Doc ID  ('DOC' no de in ^CHM IMG) exist s for that  PDI.
  50771   "^DD",7410 02.17,7410 02.17,3.12 ,"DT")
  50772   2960202
  50773   "^DD",7410 02.17,7410 02.17,3.13 ,0)
  50774   3884S # OF  SUSPENSE  DAYS^NJ4,0 ^^3;13^K:+ X'=X!(X>99 99)!(X<1)! (X?.E1"."1 N.N) X
  50775   "^DD",7410 02.17,7410 02.17,3.13 ,3)
  50776   Type a Num ber betwee n 1 and 99 99, 0 Deci mal Digits
  50777   "^DD",7410 02.17,7410 02.17,3.13 ,"DT")
  50778   2970619
  50779   "^DD",7410 02.17,7410 02.17,3.14 ,0)
  50780   DATE FOR N ON-VA DOS  CHECK^D^^3 ;14^S %DT= "E" D ^%DT  S X=Y K:Y <1 X
  50781   "^DD",7410 02.17,7410 02.17,3.14 ,"DT")
  50782   2971021
  50783   "^DD",7410 02.17,7410 02.17,3.15 ,0)
  50784   SECURITY N OTIFICATIO N ON/OFF^S ^0:ON;1:OF F;^3;15^Q
  50785   "^DD",7410 02.17,7410 02.17,3.15 ,"DT")
  50786   2990405
  50787   "^DD",7410 02.17,7410 02.17,3.16 ,0)
  50788   MEDICARE D EDUCTIBLE  SWITCH^S^1 :ON;0:OFF; ^3;16^Q
  50789   "^DD",7410 02.17,7410 02.17,3.16 ,"DT")
  50790   2990520
  50791   "^DD",7410 02.17,7410 02.17,3.17 ,0)
  50792   MCCR BACK  DATE DAYS^ NJ3,0^^3;1 7^K:+X'=X! (X>999)!(X <0)!(X?.E1 "."1N.N) X
  50793   "^DD",7410 02.17,7410 02.17,3.17 ,3)
  50794   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  50795   "^DD",7410 02.17,7410 02.17,3.17 ,"DT")
  50796   2991101
  50797   "^DD",7410 02.17,7410 02.17,3.18 ,0)
  50798   MCCR FORWA RD DATE DA YS^NJ3,0^^ 3;18^K:+X' =X!(X>999) !(X<0)!(X? .E1"."1N.N ) X
  50799   "^DD",7410 02.17,7410 02.17,3.18 ,3)
  50800   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  50801   "^DD",7410 02.17,7410 02.17,3.18 ,"DT")
  50802   2991101
  50803   "^DD",7410 02.17,7410 02.17,3.5, 0)
  50804   EOB BARCOD E ON/OFF^S ^0:OFF;1:O N;^2;7^Q
  50805   "^DD",7410 02.17,7410 02.17,3.5, "DT")
  50806   2940408
  50807   "^DD",7410 02.17,7410 02.17,4,0)
  50808   PENDING EO B BATCH^NJ 9,0^^2;1^K :+X'=X!(X> 999999999) !(X<1)!(X? .E1"."1N.N ) X
  50809   "^DD",7410 02.17,7410 02.17,4,3)
  50810   Type a Num ber betwee n 1 and 99 9999999, 0  Decimal D igits
  50811   "^DD",7410 02.17,7410 02.17,4,"D T")
  50812   2920228
  50813   "^DD",7410 02.17,7410 02.17,4.01 ,0)
  50814   EFFECTIVE  END DATE ( KID ACQ)^7 41002.701D ^^15;0
  50815   "^DD",7410 02.17,7410 02.17,5,0)
  50816   FINALIZED  EOB BATCH^ NJ9,0^^2;2 ^K:+X'=X!( X>99999999 9)!(X<1)!( X?.E1"."1N .N) X
  50817   "^DD",7410 02.17,7410 02.17,5,3)
  50818   Type a Num ber betwee n 1 and 99 9999999, 0  Decimal D igits
  50819   "^DD",7410 02.17,7410 02.17,5,"D T")
  50820   2920228
  50821   "^DD",7410 02.17,7410 02.17,5.01 ,0)
  50822   EFFECTIVE  END DATE ( OUTLIERS)^ 741002.9D^ ^20;0
  50823   "^DD",7410 02.17,7410 02.17,6,0)
  50824   FINALIZED  EOB BATCH^ NJ7,0^^2;3 ^K:+X'=X!( X>9999999) !(X<1)!(X? .E1"."1N.N ) X
  50825   "^DD",7410 02.17,7410 02.17,6,3)
  50826   Type a Num ber betwee n 1 and 99 99999, 0 D ecimal Dig its
  50827   "^DD",7410 02.17,7410 02.17,6,"D T")
  50828   2920220
  50829   "^DD",7410 02.17,7410 02.17,6.01 ,0)
  50830   EFFECTIVE  END DATE ( CTC)^74100 2.9001D^^2 1;0
  50831   "^DD",7410 02.17,7410 02.17,7.01 ,0)
  50832   EFFECTIVE  END DATE ( EDUC)^7410 02.702D^^2 2;0
  50833   "^DD",7410 02.17,7410 02.17,8.01 ,0)
  50834   EFFECTIVE  END DATE ( DED/CS)^74 1002.9003D A^^25;0
  50835   "^DD",7410 02.17,7410 02.17,9.01 ,0)
  50836   EFFECTIVE  BEGIN DATE  (MEI)^741 002.703D^^ 30;0
  50837   "^DD",7410 02.17,7410 02.17,9.01 ,"DT")
  50838   2910429
  50839   "^DD",7410 02.17,7410 02.17,40.0 1,0)
  50840   MENTAL HEA LTH PROCS  FISCAL YR^ 741002.900 7D^^40;0
  50841   "^DD",7410 02.17,7410 02.17,40.0 1,"DT")
  50842   2941026
  50843   "^DD",7410 02.17,7410 02.17,41,0 )
  50844   SUBSTANCE  ABUSE PROC S FY^74100 2.1741D^^4 1;0
  50845   "^DD",7410 02.17,7410 02.17,42,0 )
  50846   FAMILY THE RAPY PROCS  FY^741002 .1742D^^42 ;0
  50847   "^DD",7410 02.17,7410 02.17,50.0 1,0)
  50848   ASSIST SUR G MOD PERC ENT DATE^7 41002.69D^ ^50;0
  50849   "^DD",7410 02.17,7410 02.17,60.0 1,0)
  50850   G.EDI VEND OR GROUP^F ^^60;1^K:$ L(X)>30!($ L(X)<1) X
  50851   "^DD",7410 02.17,7410 02.17,60.0 1,3)
  50852   Answer mus t be 1-30  characters  in length .
  50853   "^DD",7410 02.17,7410 02.17,60.0 1,"DT")
  50854   2940719
  50855   "^DD",7410 02.17,7410 02.17,60.0 2,0)
  50856   EDI PEND C NT-FY PAY  START^NJ10 ,0^^60;2^K :+X'=X!(X> 9999999999 )!(X<99999 )!(X?.E1". "1N.N) X
  50857   "^DD",7410 02.17,7410 02.17,60.0 2,3)
  50858   Type a Num ber betwee n 99999 an d 99999999 99, 0 Deci mal Digits
  50859   "^DD",7410 02.17,7410 02.17,60.0 2,"DT")
  50860   2960801
  50861   "^DD",7410 02.17,7410 02.17,60.0 3,0)
  50862   EDI PEND C NT DATE SE T^D^^60;3^ S %DT="EX"  D ^%DT S  X=Y K:Y<1  X
  50863   "^DD",7410 02.17,7410 02.17,60.0 3,"DT")
  50864   2960802
  50865   "^DD",7410 02.17,7410 02.17,60.0 4,0)
  50866   EDI TECH M AIL GROUP^ F^^60;4^K: $L(X)>30!( $L(X)<3) X
  50867   "^DD",7410 02.17,7410 02.17,60.0 4,3)
  50868   Answer mus t be 3-30  characters  in length .
  50869   "^DD",7410 02.17,7410 02.17,60.0 4,"DT")
  50870   2970129
  50871   "^DD",7410 02.17,7410 02.17,70,0 )
  50872   MEDICARE D EDUCTIBLE^ 741002.177 D^^70;0
  50873   "^DD",7410 02.17,7410 02.17,70," DT")
  50874   2990112
  50875   "^DD",7410 02.17,7410 02.17,80.0 1,0)
  50876   MCCR Q MM  RECIEPENT^ 741002.68P ^^80;0
  50877   "^DD",7410 02.17,7410 02.17,100. 01,0)
  50878   MCCR LETTE R^P741010. 18'^CHMCOR Q(^100;1^Q
  50879   "^DD",7410 02.17,7410 02.17,100. 01,"DT")
  50880   2910609
  50881   "^DD",7410 02.17,7410 02.17,100. 02,0)
  50882   MISSING DA TA LETTER^ P741010.18 '^CHMCORQ( ^100;2^Q
  50883   "^DD",7410 02.17,7410 02.17,100. 02,"DT")
  50884   2910609
  50885   "^DD",7410 02.17,7410 02.17,100. 03,0)
  50886   ADDITIONAL  VENDOR IN FO LETTER^ P741010.18 '^CHMCORQ( ^100;3^Q
  50887   "^DD",7410 02.17,7410 02.17,100. 03,"DT")
  50888   2910609
  50889   "^DD",7410 02.17,7410 02.17,100. 04,0)
  50890   NO CLAIM F ORM LETTER ^P741010.1 8'^CHMCORQ (^100;4^Q
  50891   "^DD",7410 02.17,7410 02.17,100. 04,"DT")
  50892   2910609
  50893   "^DD",7410 02.17,7410 02.17,101, 0)
  50894   SYSTEM STA TUS PARAME TERS^74100 2.17101A^^ 101;0
  50895   "^DD",7410 02.17,7410 02.17,101, "DT")
  50896   2930225
  50897   "^DD",7410 02.17,7410 02.17,102, 0)
  50898   EDIT HIST^ 741002.171 02A^^102;0
  50899   "^DD",7410 02.17,7410 02.17,200. 01,0)
  50900   PAYEE REVI EW ZIP COD E^741002.1 72^^200;0
  50901   "^DD",7410 02.17,7410 02.17,200. 01,"DT")
  50902   2910314
  50903   "^DD",7410 02.17,7410 02.17,300, 0)
  50904   OBLIG. STA TUS ALERT  RECIPIENT^ 741002.900 4P^^300;0
  50905   "^DD",7410 02.17,7410 02.17,301, 0)
  50906   FMP MESSAG E RECEIPIE NTS^741002 .17301PA^^ 301;0
  50907   "^DD",7410 02.17,7410 02.17,400, 0)
  50908   MM SENDEE  NAME^74100 2.705P^^40 0;0
  50909   "^DD",7410 02.17,7410 02.17,400, "DT")
  50910   2910919
  50911   "^DD",7410 02.17,7410 02.17,500, 0)
  50912   AUSTIN MM  SENDEE NAM E^741002.7 06P^^500;0
  50913   "^DD",7410 02.17,7410 02.17,600. 01,0)
  50914   VENDOR QUE  REVIEW PC NT^NJ3,0^^ 600;1^K:+X '=X!(X>100 )!(X<0)!(X ?.E1"."1N. N) X
  50915   "^DD",7410 02.17,7410 02.17,600. 01,3)
  50916   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  50917   "^DD",7410 02.17,7410 02.17,600. 01,"DT")
  50918   2930318
  50919   "^DD",7410 02.17,7410 02.17,600. 02,0)
  50920   DATE/TIME  SET^D^^600 ;2^S %DT=" EST" D ^%D T S X=Y K: Y<1 X
  50921   "^DD",7410 02.17,7410 02.17,600. 02,"DT")
  50922   2930318
  50923   "^DD",7410 02.17,7410 02.17,600. 03,0)
  50924   DUZ SET^P2 00'^VA(200 ,^600;3^Q
  50925   "^DD",7410 02.17,7410 02.17,600. 03,"DT")
  50926   2951011
  50927   "^DD",7410 02.17,7410 02.17,700, 0)
  50928   VENDOR BAT CH REJECT  CODE^74100 2.33A^^700 ;0
  50929   "^DD",7410 02.17,7410 02.17,801, 0)
  50930   EDI TRADIN G PARTNER^ 741002.178 01A^^801;0
  50931   "^DD",7410 02.17,7410 02.17,1000 .01,0)
  50932   CURRENT SC AN DATE^D^ ^SCAN-DATE ;1^S %DT=" EX" D ^%DT  S X=Y K:Y <1 X
  50933   "^DD",7410 02.17,7410 02.17,1000 .01,.1)
  50934   Enter the  date of th e mail cur rently bei ng scanned
  50935   "^DD",7410 02.17,7410 02.17,1000 .01,1,0)
  50936   ^.1
  50937   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,0)
  50938   ^^TRIGGER^ 741002.17^ 1000.03
  50939   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,1)
  50940   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^CHMDIC (741002.17 ,D0,"SCAN- DATE")):^( "SCAN-DATE "),1:"") S  X=$P(Y(1) ,U,3),X=X  S DIU=X K  Y S X=DIV  S:$D(DUZ)  X=DUZ X ^D D(741002.1 7,1000.01, 1,1,1.4)
  50941   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,1. 4)
  50942   S DIH=$S($ D(^CHMDIC( 741002.17, DIV(0),"SC AN-DATE")) :^("SCAN-D ATE"),1:"" ),DIV=X S  $P(^("SCAN -DATE"),U, 3)=DIV,DIH =741002.17 ,DIG=1000. 03 D ^DICR :$N(^DD(DI H,DIG,1,0) )>0
  50943   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,2)
  50944   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^CHMDIC (741002.17 ,D0,"SCAN- DATE")):^( "SCAN-DATE "),1:"") S  X=$P(Y(1) ,U,3),X=X  S DIU=X K  Y S X="" X  ^DD(74100 2.17,1000. 01,1,1,2.4 )
  50945   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,2. 4)
  50946   S DIH=$S($ D(^CHMDIC( 741002.17, DIV(0),"SC AN-DATE")) :^("SCAN-D ATE"),1:"" ),DIV=X S  $P(^("SCAN -DATE"),U, 3)=DIV,DIH =741002.17 ,DIG=1000. 03 D ^DICR :$N(^DD(DI H,DIG,1,0) )>0
  50947   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,"C REATE VALU E")
  50948   S:$D(DUZ)  X=DUZ
  50949   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,"D ELETE VALU E")
  50950   S X=""
  50951   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,"D T")
  50952   2921125
  50953   "^DD",7410 02.17,7410 02.17,1000 .01,1,1,"F IELD")
  50954   USER SETTI NG SCAN DA TE
  50955   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,0)
  50956   ^^TRIGGER^ 741002.17^ 1000.04
  50957   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,1)
  50958   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^CHMDIC (741002.17 ,D0,"SCAN- DATE")):^( "SCAN-DATE "),1:"") S  X=$P(Y(1) ,U,4),X=X  S DIU=X K  Y S X=DIV  D NOW^%DTC  S X=% X ^ DD(741002. 17,1000.01 ,1,2,1.4)
  50959   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,1. 4)
  50960   S DIH=$S($ D(^CHMDIC( 741002.17, DIV(0),"SC AN-DATE")) :^("SCAN-D ATE"),1:"" ),DIV=X S  $P(^("SCAN -DATE"),U, 4)=DIV,DIH =741002.17 ,DIG=1000. 04 D ^DICR :$N(^DD(DI H,DIG,1,0) )>0
  50961   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,2)
  50962   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^CHMDIC (741002.17 ,D0,"SCAN- DATE")):^( "SCAN-DATE "),1:"") S  X=$P(Y(1) ,U,4),X=X  S DIU=X K  Y S X="" X  ^DD(74100 2.17,1000. 01,1,2,2.4 )
  50963   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,2. 4)
  50964   S DIH=$S($ D(^CHMDIC( 741002.17, DIV(0),"SC AN-DATE")) :^("SCAN-D ATE"),1:"" ),DIV=X S  $P(^("SCAN -DATE"),U, 4)=DIV,DIH =741002.17 ,DIG=1000. 04 D ^DICR :$N(^DD(DI H,DIG,1,0) )>0
  50965   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,"C REATE VALU E")
  50966   D NOW^%DTC  S X=%
  50967   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,"D ELETE VALU E")
  50968   S X=""
  50969   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,"D T")
  50970   2921125
  50971   "^DD",7410 02.17,7410 02.17,1000 .01,1,2,"F IELD")
  50972   DATE/TIME  SCAN DATE  SET
  50973   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,0)
  50974   ^^TRIGGER^ 741002.17^ 1000.02
  50975   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,1)
  50976   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^CHMDIC (741002.17 ,D0,"SCAN- DATE")):^( "SCAN-DATE "),1:"") S  X=$P(Y(1) ,U,2),X=X  S DIU=X K  Y X ^DD(74 1002.17,10 00.01,1,3, 1.1) X ^DD (741002.17 ,1000.01,1 ,3,1.4)
  50977   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,1. 1)
  50978   S X=DIV S  X=$E(DC,1, 3)_"0000"  D H^%DTC S  H1=%H S X =DC D H^%D TC S X=($P (%H,"^",1) -H1)+1
  50979   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,1. 4)
  50980   S DIH=$S($ D(^CHMDIC( 741002.17, DIV(0),"SC AN-DATE")) :^("SCAN-D ATE"),1:"" ),DIV=X S  $P(^("SCAN -DATE"),U, 2)=DIV,DIH =741002.17 ,DIG=1000. 02 D ^DICR :$N(^DD(DI H,DIG,1,0) )>0
  50981   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,2)
  50982   K DIV S DI V=X,D0=DA, DIV(0)=D0  S Y(1)=$S( $D(^CHMDIC (741002.17 ,D0,"SCAN- DATE")):^( "SCAN-DATE "),1:"") S  X=$P(Y(1) ,U,2),X=X  S DIU=X K  Y S X="" X  ^DD(74100 2.17,1000. 01,1,3,2.4 )
  50983   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,2. 4)
  50984   S DIH=$S($ D(^CHMDIC( 741002.17, DIV(0),"SC AN-DATE")) :^("SCAN-D ATE"),1:"" ),DIV=X S  $P(^("SCAN -DATE"),U, 2)=DIV,DIH =741002.17 ,DIG=1000. 02 D ^DICR :$N(^DD(DI H,DIG,1,0) )>0
  50985   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,"C REATE VALU E")
  50986   S X=$E(DC, 1,3)_"0000 " D H^%DTC  S H1=%H S  X=DC D H^ %DTC S X=( $P(%H,"^", 1)-H1)+1
  50987   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,"D ELETE VALU E")
  50988   S X=""
  50989   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,"D T")
  50990   2930111
  50991   "^DD",7410 02.17,7410 02.17,1000 .01,1,3,"F IELD")
  50992   JULIAN CON VERSION OF  SCAN DATE
  50993   "^DD",7410 02.17,7410 02.17,1000 .01,3)
  50994   TYPE A DAT E BETWEEN  1/11/1992  AND 1/11/1 993
  50995   "^DD",7410 02.17,7410 02.17,1000 .01,22)
  50996  
  50997   "^DD",7410 02.17,7410 02.17,1000 .01,23,0)
  50998   ^^1^1^2921 127^
  50999   "^DD",7410 02.17,7410 02.17,1000 .01,23,1,0 )
  51000    ^
  51001   "^DD",7410 02.17,7410 02.17,1000 .01,"DT")
  51002   2930215
  51003   "^DD",7410 02.17,7410 02.17,1000 .02,0)
  51004   JULIAN CON VERSION OF  SCAN DATE ^NJ3,0^^SC AN-DATE;2^ K:+X'=X!(X >999)!(X<0 )!(X?.E1". "1N.N) X
  51005   "^DD",7410 02.17,7410 02.17,1000 .02,3)
  51006   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51007   "^DD",7410 02.17,7410 02.17,1000 .02,5,1,0)
  51008   741002.17^ 1000.01^3
  51009   "^DD",7410 02.17,7410 02.17,1000 .02,"DT")
  51010   2921125
  51011   "^DD",7410 02.17,7410 02.17,1000 .03,0)
  51012   USER SETTI NG SCAN DA TE^P200'^V A(200,^SCA N-DATE;3^Q
  51013   "^DD",7410 02.17,7410 02.17,1000 .03,5,1,0)
  51014   741002.17^ 1000.01^1
  51015   "^DD",7410 02.17,7410 02.17,1000 .03,"DT")
  51016   2951011
  51017   "^DD",7410 02.17,7410 02.17,1000 .04,0)
  51018   DATE/TIME  SCAN DATE  SET^D^^SCA N-DATE;4^S  %DT="ESTX R" D ^%DT  S X=Y K:Y< 1 X
  51019   "^DD",7410 02.17,7410 02.17,1000 .04,5,1,0)
  51020   741002.17^ 1000.01^2
  51021   "^DD",7410 02.17,7410 02.17,1000 .04,"DT")
  51022   2921125
  51023   "^DD",7410 02.17,7410 02.17,1000 .05,0)
  51024   MANID LOWE R NUMERIC  LIMIT^NJ7, 0^^SCAN-DA TE;5^K:+X' =X!(X>9999 999)!(X<0) !(X?.E1"." 1N.N) X
  51025   "^DD",7410 02.17,7410 02.17,1000 .05,3)
  51026   Type a Num ber betwee n 0 and 99 99999, 0 D ecimal Dig its
  51027   "^DD",7410 02.17,7410 02.17,1000 .05,"DT")
  51028   2930822
  51029   "^DD",7410 02.17,7410 02.17,1000 .06,0)
  51030   MANID UPPE R NUMERIC  LIMIT^NJ7, 0^^SCAN-DA TE;6^K:+X' =X!(X>9999 999)!(X<0) !(X?.E1"." 1N.N) X
  51031   "^DD",7410 02.17,7410 02.17,1000 .06,3)
  51032   Type a Num ber betwee n 0 and 99 99999, 0 D ecimal Dig its
  51033   "^DD",7410 02.17,7410 02.17,1000 .06,"DT")
  51034   2930822
  51035   "^DD",7410 02.17,7410 02.17101,0 )
  51036   SYSTEM STA TUS PARAME TERS SUB-F IELD^^.08^ 6
  51037   "^DD",7410 02.17,7410 02.17101,0 ,"DT")
  51038   2930225
  51039   "^DD",7410 02.17,7410 02.17101,0 ,"IX","B", 741002.171 01,.01)
  51040  
  51041   "^DD",7410 02.17,7410 02.17101,0 ,"NM","SYS TEM STATUS  PARAMETER S")
  51042  
  51043   "^DD",7410 02.17,7410 02.17101,0 ,"UP")
  51044   741002.17
  51045   "^DD",7410 02.17,7410 02.17101,. 01,0)
  51046   INTERNAL R EFERENCE^F ^^0;1^K:$L (X)>30!($L (X)<3) X
  51047   "^DD",7410 02.17,7410 02.17101,. 01,1,0)
  51048   ^.1
  51049   "^DD",7410 02.17,7410 02.17101,. 01,1,1,0)
  51050   741002.171 01^B
  51051   "^DD",7410 02.17,7410 02.17101,. 01,1,1,1)
  51052   S ^CHMDIC( 741002.17, DA(1),101, "B",$E(X,1 ,30),DA)=" "
  51053   "^DD",7410 02.17,7410 02.17101,. 01,1,1,2)
  51054   K ^CHMDIC( 741002.17, DA(1),101, "B",$E(X,1 ,30),DA)
  51055   "^DD",7410 02.17,7410 02.17101,. 01,3)
  51056   Answer mus t be 3-30  characters  in length .
  51057   "^DD",7410 02.17,7410 02.17101,. 01,"DT")
  51058   2910802
  51059   "^DD",7410 02.17,7410 02.17101,. 02,0)
  51060   SHORT DESC RIPTION^F^ ^0;2^K:$L( X)>15!($L( X)<1) X
  51061   "^DD",7410 02.17,7410 02.17101,. 02,3)
  51062   Answer mus t be 1-15  characters  in length .
  51063   "^DD",7410 02.17,7410 02.17101,. 02,"DT")
  51064   2910802
  51065   "^DD",7410 02.17,7410 02.17101,. 03,0)
  51066   PIECE^NJ2, 0^^0;3^K:+ X'=X!(X>99 )!(X<1)!(X ?.E1"."1N. N) X
  51067   "^DD",7410 02.17,7410 02.17101,. 03,3)
  51068   Type a Num ber betwee n 1 and 99 , 0 Decima l Digits
  51069   "^DD",7410 02.17,7410 02.17101,. 03,"DT")
  51070   2910802
  51071   "^DD",7410 02.17,7410 02.17101,. 04,0)
  51072   VALUES^F^^ 0;4^K:$L(X )>30!($L(X )<1) X
  51073   "^DD",7410 02.17,7410 02.17101,. 04,3)
  51074   Answer mus t be 1-30  characters  in length .
  51075   "^DD",7410 02.17,7410 02.17101,. 04,"DT")
  51076   2910802
  51077   "^DD",7410 02.17,7410 02.17101,. 07,0)
  51078   PRINT ORDE R^NJ2,0^^0 ;7^K:+X'=X !(X>99)!(X <1)!(X?.E1 "."1N.N) X
  51079   "^DD",7410 02.17,7410 02.17101,. 07,3)
  51080   Type a Num ber betwee n 1 and 99 , 0 Decima l Digits
  51081   "^DD",7410 02.17,7410 02.17101,. 07,"DT")
  51082   2910802
  51083   "^DD",7410 02.17,7410 02.17101,. 08,0)
  51084   COUNT AS I N OR OUT^S ^1:IN;-1:O UT;^0;8^Q
  51085   "^DD",7410 02.17,7410 02.17101,. 08,"DT")
  51086   2930225
  51087   "^DD",7410 02.17,7410 02.17102,0 )
  51088   EDIT HIST  SUB-FIELD^ ^70.01^11
  51089   "^DD",7410 02.17,7410 02.17102,0 ,"DT")
  51090   2990112
  51091   "^DD",7410 02.17,7410 02.17102,0 ,"IX","B", 741002.171 02,.01)
  51092  
  51093   "^DD",7410 02.17,7410 02.17102,0 ,"NM","EDI T HIST")
  51094  
  51095   "^DD",7410 02.17,7410 02.17102,0 ,"UP")
  51096   741002.17
  51097   "^DD",7410 02.17,7410 02.17102,. 01,0)
  51098   EDIT HIST^ F^^0;1^K:$ L(X)>30!($ L(X)<1) X
  51099   "^DD",7410 02.17,7410 02.17102,. 01,1,0)
  51100   ^.1
  51101   "^DD",7410 02.17,7410 02.17102,. 01,1,1,0)
  51102   741002.171 02^B
  51103   "^DD",7410 02.17,7410 02.17102,. 01,1,1,1)
  51104   S ^CHMDIC( 741002.17, DA(1),102, "B",$E(X,1 ,30),DA)=" "
  51105   "^DD",7410 02.17,7410 02.17102,. 01,1,1,2)
  51106   K ^CHMDIC( 741002.17, DA(1),102, "B",$E(X,1 ,30),DA)
  51107   "^DD",7410 02.17,7410 02.17102,. 01,3)
  51108   Answer mus t be 1-30  characters  in length .
  51109   "^DD",7410 02.17,7410 02.17102,. 01,"DT")
  51110   2910912
  51111   "^DD",7410 02.17,7410 02.17102,1 .01,0)
  51112   BEGIN DATE  (ASA)^741 002.19102D A^^1;0
  51113   "^DD",7410 02.17,7410 02.17102,5 .01,0)
  51114   BEGIN DATE  (CH DIFF)  HIST^7410 02.20102DA ^^5;0
  51115   "^DD",7410 02.17,7410 02.17102,1 0.01,0)
  51116   BEGIN DATE  (LVMH) HI ST^741002. 18102DA^^1 0;0
  51117   "^DD",7410 02.17,7410 02.17102,1 5.01,0)
  51118   BEGIN DATE  (KID ACQ)  HIST^7410 02.21102DA ^^15;0
  51119   "^DD",7410 02.17,7410 02.17102,2 0.01,0)
  51120   BEGIN DATE  (OUTL) HI ST^741002. 22102DA^^2 0;0
  51121   "^DD",7410 02.17,7410 02.17102,2 1.01,0)
  51122   BEGIN DATE  (CTC) HIS T^741002.2 3102DA^^21 ;0
  51123   "^DD",7410 02.17,7410 02.17102,2 2.01,0)
  51124   BEGIN DATE  (EDUC) HI ST^741002. 24102DA^^2 2;0
  51125   "^DD",7410 02.17,7410 02.17102,2 5.01,0)
  51126   BEGIN DATE  (DED/CS)  HIST^74100 2.25102DA^ ^25;0
  51127   "^DD",7410 02.17,7410 02.17102,3 0.01,0)
  51128   BEGIN DATE  (MEI) HIS T^741002.2 6102DA^^30 ;0
  51129   "^DD",7410 02.17,7410 02.17102,7 0.01,0)
  51130   MEDICARE D EDUCTIBLE  HIST^74100 2.1777D^^7 0;0
  51131   "^DD",7410 02.17,7410 02.172,0)
  51132   PAYEE REVI EW ZIP COD E SUB-FIEL D^^.03^3
  51133   "^DD",7410 02.17,7410 02.172,0," DT")
  51134   2910318
  51135   "^DD",7410 02.17,7410 02.172,0," NM","PAYEE  REVIEW ZI P CODE")
  51136  
  51137   "^DD",7410 02.17,7410 02.172,0," UP")
  51138   741002.17
  51139   "^DD",7410 02.17,7410 02.172,.01 ,0)
  51140   PAYEE IDEN TIFICATION ^MF^^0;1^K :$L(X)>5!( $L(X)<5) X
  51141   "^DD",7410 02.17,7410 02.172,.01 ,1,0)
  51142   ^.1
  51143   "^DD",7410 02.17,7410 02.172,.01 ,1,1,0)
  51144   ^^TRIGGER^ 741002.172 ^.02
  51145   "^DD",7410 02.17,7410 02.172,.01 ,1,1,1)
  51146   K DIV S DI V=X,D0=DA( 1),DIV(0)= D0,D1=DA,D IV(1)=D1 S  Y(1)=$S($ D(^CHMDIC( 741002.17, D0,200,D1, 0)):^(0),1 :"") S X=$ P(Y(1),U,2 ),X=X S DI U=X K Y S  X=DIV S X= DUZ X ^DD( 741002.172 ,.01,1,1,1 .4)
  51147   "^DD",7410 02.17,7410 02.172,.01 ,1,1,1.4)
  51148   S DIH=$S($ D(^CHMDIC( 741002.17, DIV(0),200 ,DIV(1),0) ):^(0),1:" "),DIV=X S  $P(^(0),U ,2)=DIV,DI H=741002.1 72,DIG=.02  D ^DICR:$ N(^DD(DIH, DIG,1,0))> 0
  51149   "^DD",7410 02.17,7410 02.172,.01 ,1,1,2)
  51150   Q
  51151   "^DD",7410 02.17,7410 02.172,.01 ,1,1,"CREA TE VALUE")
  51152   S X=DUZ
  51153   "^DD",7410 02.17,7410 02.172,.01 ,1,1,"DELE TE VALUE")
  51154   NO EFFECT
  51155   "^DD",7410 02.17,7410 02.172,.01 ,1,1,"DT")
  51156   2910314
  51157   "^DD",7410 02.17,7410 02.172,.01 ,1,1,"FIEL D")
  51158   USER DISIG NATING ZIP  CODE
  51159   "^DD",7410 02.17,7410 02.172,.01 ,1,2,0)
  51160   ^^TRIGGER^ 741002.172 ^.03
  51161   "^DD",7410 02.17,7410 02.172,.01 ,1,2,1)
  51162   K DIV S DI V=X,D0=DA( 1),DIV(0)= D0,D1=DA,D IV(1)=D1 S  Y(1)=$S($ D(^CHMDIC( 741002.17, D0,200,D1, 0)):^(0),1 :"") S X=$ P(Y(1),U,3 ),X=X S DI U=X K Y S  X=DIV S X= DT X ^DD(7 41002.172, .01,1,2,1. 4)
  51163   "^DD",7410 02.17,7410 02.172,.01 ,1,2,1.4)
  51164   S DIH=$S($ D(^CHMDIC( 741002.17, DIV(0),200 ,DIV(1),0) ):^(0),1:" "),DIV=X S  $P(^(0),U ,3)=DIV,DI H=741002.1 72,DIG=.03  D ^DICR:$ N(^DD(DIH, DIG,1,0))> 0
  51165   "^DD",7410 02.17,7410 02.172,.01 ,1,2,2)
  51166   Q
  51167   "^DD",7410 02.17,7410 02.172,.01 ,1,2,"CREA TE VALUE")
  51168   S X=DT
  51169   "^DD",7410 02.17,7410 02.172,.01 ,1,2,"DELE TE VALUE")
  51170   NO EFFECT
  51171   "^DD",7410 02.17,7410 02.172,.01 ,1,2,"DT")
  51172   2910314
  51173   "^DD",7410 02.17,7410 02.172,.01 ,1,2,"FIEL D")
  51174   DATE DESIG NATED FOR  REVIEW
  51175   "^DD",7410 02.17,7410 02.172,.01 ,3)
  51176   Answer mus t be 5 cha racters in  length.
  51177   "^DD",7410 02.17,7410 02.172,.01 ,"DT")
  51178   2910318
  51179   "^DD",7410 02.17,7410 02.172,.02 ,0)
  51180   USER DISIG NATING ZIP  CODE^P3'^ DIC(3,^0;2 ^Q
  51181   "^DD",7410 02.17,7410 02.172,.02 ,5,1,0)
  51182   741002.172 ^.01^1
  51183   "^DD",7410 02.17,7410 02.172,.02 ,"DT")
  51184   2910314
  51185   "^DD",7410 02.17,7410 02.172,.03 ,0)
  51186   DATE DESIG NATED FOR  REVIEW^D^^ 0;3^S %DT= "ETX" D ^% DT S X=Y K :Y<1 X
  51187   "^DD",7410 02.17,7410 02.172,.03 ,5,1,0)
  51188   741002.172 ^.01^2
  51189   "^DD",7410 02.17,7410 02.172,.03 ,"DT")
  51190   2910314
  51191   "^DD",7410 02.17,7410 02.17301,0 )
  51192   FMP MESSAG E RECEIPIE NTS SUB-FI ELD^^.03^3
  51193   "^DD",7410 02.17,7410 02.17301,0 ,"DT")
  51194   2941006
  51195   "^DD",7410 02.17,7410 02.17301,0 ,"IX","B", 741002.173 01,.01)
  51196  
  51197   "^DD",7410 02.17,7410 02.17301,0 ,"NM","FMP  MESSAGE R ECEIPIENTS ")
  51198  
  51199   "^DD",7410 02.17,7410 02.17301,0 ,"NM","FMP  MESSAGE R ECIPIENTS" )
  51200  
  51201   "^DD",7410 02.17,7410 02.17301,0 ,"UP")
  51202   741002.17
  51203   "^DD",7410 02.17,7410 02.17301,. 01,0)
  51204   FMP MESSAG E RECEIPIE NTS^P200'^ VA(200,^0; 1^Q
  51205   "^DD",7410 02.17,7410 02.17301,. 01,1,0)
  51206   ^.1
  51207   "^DD",7410 02.17,7410 02.17301,. 01,1,1,0)
  51208   741002.173 01^B
  51209   "^DD",7410 02.17,7410 02.17301,. 01,1,1,1)
  51210   S ^CHMDIC( 741002.17, DA(1),301, "B",$E(X,1 ,30),DA)=" "
  51211   "^DD",7410 02.17,7410 02.17301,. 01,1,1,2)
  51212   K ^CHMDIC( 741002.17, DA(1),301, "B",$E(X,1 ,30),DA)
  51213   "^DD",7410 02.17,7410 02.17301,. 01,"DT")
  51214   2941006
  51215   "^DD",7410 02.17,7410 02.17301,. 02,0)
  51216   D/T ENTERE D^D^^0;2^S  %DT="ESTX " D ^%DT S  X=Y K:Y<1  X
  51217   "^DD",7410 02.17,7410 02.17301,. 02,"DT")
  51218   2941006
  51219   "^DD",7410 02.17,7410 02.17301,. 03,0)
  51220   ASSIGNED B Y^P200'^VA (200,^0;3^ Q
  51221   "^DD",7410 02.17,7410 02.17301,. 03,"DT")
  51222   2941006
  51223   "^DD",7410 02.17,7410 02.1741,0)
  51224   SUBSTANCE  ABUSE PROC S FY SUB-F IELD^^.04^ 4
  51225   "^DD",7410 02.17,7410 02.1741,0, "DT")
  51226   2960517
  51227   "^DD",7410 02.17,7410 02.1741,0, "IX","B",7 41002.1741 ,.01)
  51228  
  51229   "^DD",7410 02.17,7410 02.1741,0, "NM","SUBS TANCE ABUS E PROCS FY ")
  51230  
  51231   "^DD",7410 02.17,7410 02.1741,0, "UP")
  51232   741002.17
  51233   "^DD",7410 02.17,7410 02.1741,.0 1,0)
  51234   SUBSTANCE  ABUSE PROC S FY^RDX^^ 0;1^S %DT= "E" D ^%DT  S X=Y K:Y <1 X S:$D( X) DINUM=9 999999-X
  51235   "^DD",7410 02.17,7410 02.1741,.0 1,1,0)
  51236   ^.1
  51237   "^DD",7410 02.17,7410 02.1741,.0 1,1,1,0)
  51238   741002.174 1^B
  51239   "^DD",7410 02.17,7410 02.1741,.0 1,1,1,1)
  51240   S ^CHMDIC( 741002.17, DA(1),41," B",$E(X,1, 30),DA)=""
  51241   "^DD",7410 02.17,7410 02.1741,.0 1,1,1,2)
  51242   K ^CHMDIC( 741002.17, DA(1),41," B",$E(X,1, 30),DA)
  51243   "^DD",7410 02.17,7410 02.1741,.0 1,"DT")
  51244   2960521
  51245   "^DD",7410 02.17,7410 02.1741,.0 2,0)
  51246   SA INITIAL  VISITS^RN J4,0^^0;2^ K:+X'=X!(X >9999)!(X< -9999)!(X? .E1"."1N.N ) X
  51247   "^DD",7410 02.17,7410 02.1741,.0 2,3)
  51248   Type a Num ber betwee n -9999 an d 9999, 0  Decimal Di gits
  51249   "^DD",7410 02.17,7410 02.1741,.0 2,"DT")
  51250   2960517
  51251   "^DD",7410 02.17,7410 02.1741,.0 3,0)
  51252   USER ADDIN G SA INIT  VISITS^RP2 00'^VA(200 ,^0;3^Q
  51253   "^DD",7410 02.17,7410 02.1741,.0 3,"DT")
  51254   2960517
  51255   "^DD",7410 02.17,7410 02.1741,.0 4,0)
  51256   DATE SA IN IT VALUE A DDED^RD^^0 ;4^S %DT=" EST" D ^%D T S X=Y K: Y<1 X
  51257   "^DD",7410 02.17,7410 02.1741,.0 4,"DT")
  51258   2960517
  51259   "^DD",7410 02.17,7410 02.1742,0)
  51260   FAMILY THE RAPY PROCS  FY SUB-FI ELD^^.04^4
  51261   "^DD",7410 02.17,7410 02.1742,0, "DT")
  51262   2960517
  51263   "^DD",7410 02.17,7410 02.1742,0, "IX","B",7 41002.1742 ,.01)
  51264  
  51265   "^DD",7410 02.17,7410 02.1742,0, "NM","FAMI LY THERAPY  PROCS FY" )
  51266  
  51267   "^DD",7410 02.17,7410 02.1742,0, "UP")
  51268   741002.17
  51269   "^DD",7410 02.17,7410 02.1742,.0 1,0)
  51270   FAMILY THE RAPY PROCS  FY^RDX^^0 ;1^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X S:$D(X ) DINUM=99 99999-X
  51271   "^DD",7410 02.17,7410 02.1742,.0 1,1,0)
  51272   ^.1
  51273   "^DD",7410 02.17,7410 02.1742,.0 1,1,1,0)
  51274   741002.174 2^B
  51275   "^DD",7410 02.17,7410 02.1742,.0 1,1,1,1)
  51276   S ^CHMDIC( 741002.17, DA(1),42," B",$E(X,1, 30),DA)=""
  51277   "^DD",7410 02.17,7410 02.1742,.0 1,1,1,2)
  51278   K ^CHMDIC( 741002.17, DA(1),42," B",$E(X,1, 30),DA)
  51279   "^DD",7410 02.17,7410 02.1742,.0 1,"DT")
  51280   2960521
  51281   "^DD",7410 02.17,7410 02.1742,.0 2,0)
  51282   FT INITIAL  VISITS^RN J4,0^^0;2^ K:+X'=X!(X >9999)!(X< -9999)!(X? .E1"."1N.N ) X
  51283   "^DD",7410 02.17,7410 02.1742,.0 2,3)
  51284   Type a Num ber betwee n -9999 an d 9999, 0  Decimal Di gits
  51285   "^DD",7410 02.17,7410 02.1742,.0 2,"DT")
  51286   2960517
  51287   "^DD",7410 02.17,7410 02.1742,.0 3,0)
  51288   USER ADDIN G FT INIT  VISITS^RP2 00'^VA(200 ,^0;3^Q
  51289   "^DD",7410 02.17,7410 02.1742,.0 3,"DT")
  51290   2960517
  51291   "^DD",7410 02.17,7410 02.1742,.0 4,0)
  51292   DATE FT IN IT VALUE A DDED^RD^^0 ;4^S %DT=" EST" D ^%D T S X=Y K: Y<1 X
  51293   "^DD",7410 02.17,7410 02.1742,.0 4,"DT")
  51294   2960517
  51295   "^DD",7410 02.17,7410 02.177,0)
  51296   MEDICARE D EDUCTIBLE  SUB-FIELD^ ^.03^3
  51297   "^DD",7410 02.17,7410 02.177,0," DT")
  51298   2990112
  51299   "^DD",7410 02.17,7410 02.177,0," IX","B",74 1002.177,. 01)
  51300  
  51301   "^DD",7410 02.17,7410 02.177,0," NM","MEDIC ARE DEDUCT IBLE")
  51302  
  51303   "^DD",7410 02.17,7410 02.177,0," UP")
  51304   741002.17
  51305   "^DD",7410 02.17,7410 02.177,.01 ,0)
  51306   MEDICARE D EDUCTIBLE  BEGIN DATE ^MDaX^^0;1 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X S:$D(X ) DINUM=99 99999-X
  51307   "^DD",7410 02.17,7410 02.177,.01 ,1,0)
  51308   ^.1
  51309   "^DD",7410 02.17,7410 02.177,.01 ,1,1,0)
  51310   741002.177 ^B
  51311   "^DD",7410 02.17,7410 02.177,.01 ,1,1,1)
  51312   S ^CHMDIC( 741002.17, DA(1),70," B",$E(X,1, 30),DA)=""
  51313   "^DD",7410 02.17,7410 02.177,.01 ,1,1,2)
  51314   K ^CHMDIC( 741002.17, DA(1),70," B",$E(X,1, 30),DA)
  51315   "^DD",7410 02.17,7410 02.177,.01 ,"AUDIT")
  51316   y
  51317   "^DD",7410 02.17,7410 02.177,.01 ,"DT")
  51318   2990112
  51319   "^DD",7410 02.17,7410 02.177,.02 ,0)
  51320   MEDICARE D EDUCTIBLE  AMOUNT^NJ1 0,2a^^0;2^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >9999999)! (X<0) X
  51321   "^DD",7410 02.17,7410 02.177,.02 ,3)
  51322   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  51323   "^DD",7410 02.17,7410 02.177,.02 ,"AUDIT")
  51324   y
  51325   "^DD",7410 02.17,7410 02.177,.02 ,"DT")
  51326   2990112
  51327   "^DD",7410 02.17,7410 02.177,.03 ,0)
  51328   MEDICARE D EDUCTIBLE  END DATE^D a^^0;3^S % DT="EST" D  ^%DT S X= Y K:Y<1 X
  51329   "^DD",7410 02.17,7410 02.177,.03 ,"AUDIT")
  51330   y
  51331   "^DD",7410 02.17,7410 02.177,.03 ,"DT")
  51332   2990112
  51333   "^DD",7410 02.17,7410 02.1777,0)
  51334   MEDICARE D EDUCTIBLE  HIST SUB-F IELD^^.04^ 4
  51335   "^DD",7410 02.17,7410 02.1777,0, "DT")
  51336   2990112
  51337   "^DD",7410 02.17,7410 02.1777,0, "IX","B",7 41002.1777 ,.01)
  51338  
  51339   "^DD",7410 02.17,7410 02.1777,0, "NM","MEDI CARE DEDUC TIBLE HIST ")
  51340  
  51341   "^DD",7410 02.17,7410 02.1777,0, "UP")
  51342   741002.171 02
  51343   "^DD",7410 02.17,7410 02.1777,.0 1,0)
  51344   MEDICARE D ED BEGIN D ATE HIST^M D^^0;1^S % DT="EST" D  ^%DT S X= Y K:Y<1 X
  51345   "^DD",7410 02.17,7410 02.1777,.0 1,1,0)
  51346   ^.1
  51347   "^DD",7410 02.17,7410 02.1777,.0 1,1,1,0)
  51348   741002.177 7^B
  51349   "^DD",7410 02.17,7410 02.1777,.0 1,1,1,1)
  51350   S ^CHMDIC( 741002.17, DA(2),102, DA(1),70," B",$E(X,1, 30),DA)=""
  51351   "^DD",7410 02.17,7410 02.1777,.0 1,1,1,2)
  51352   K ^CHMDIC( 741002.17, DA(2),102, DA(1),70," B",$E(X,1, 30),DA)
  51353   "^DD",7410 02.17,7410 02.1777,.0 1,"DT")
  51354   2990112
  51355   "^DD",7410 02.17,7410 02.1777,.0 2,0)
  51356   MEDICARE D ED AMOUNT  HIST^NJ10, 2^^0;2^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 99999)!(X< 0) X
  51357   "^DD",7410 02.17,7410 02.1777,.0 2,3)
  51358   Type a Dol lar Amount  between 0  and 99999 99, 2 Deci mal Digits
  51359   "^DD",7410 02.17,7410 02.1777,.0 2,"DT")
  51360   2990112
  51361   "^DD",7410 02.17,7410 02.1777,.0 3,0)
  51362   MEDICARE D ED END DAT E HIST^D^^ 0;3^S %DT= "EST" D ^% DT S X=Y K :Y<1 X
  51363   "^DD",7410 02.17,7410 02.1777,.0 3,"DT")
  51364   2990112
  51365   "^DD",7410 02.17,7410 02.1777,.0 4,0)
  51366   EDITING DU Z^P200'^VA (200,^0;4^ Q
  51367   "^DD",7410 02.17,7410 02.1777,.0 4,"DT")
  51368   2990112
  51369   "^DD",7410 02.17,7410 02.17801,0 )
  51370   EDI TRADIN G PARTNER  SUB-FIELD^ ^101^13
  51371   "^DD",7410 02.17,7410 02.17801,0 ,"DT")
  51372   3030506
  51373   "^DD",7410 02.17,7410 02.17801,0 ,"IX","B", 741002.178 01,.01)
  51374  
  51375   "^DD",7410 02.17,7410 02.17801,0 ,"IX","C", 741002.178 01,.02)
  51376  
  51377   "^DD",7410 02.17,7410 02.17801,0 ,"NM","EDI  TRADING P ARTNER")
  51378  
  51379   "^DD",7410 02.17,7410 02.17801,0 ,"UP")
  51380   741002.17
  51381   "^DD",7410 02.17,7410 02.17801,. 01,0)
  51382   EDI TRADIN G PARTNER^ F^^0;1^K:$ L(X)>30!($ L(X)<1) X
  51383   "^DD",7410 02.17,7410 02.17801,. 01,1,0)
  51384   ^.1
  51385   "^DD",7410 02.17,7410 02.17801,. 01,1,1,0)
  51386   741002.178 01^B
  51387   "^DD",7410 02.17,7410 02.17801,. 01,1,1,1)
  51388   S ^CHMDIC( 741002.17, DA(1),801, "B",$E(X,1 ,30),DA)=" "
  51389   "^DD",7410 02.17,7410 02.17801,. 01,1,1,2)
  51390   K ^CHMDIC( 741002.17, DA(1),801, "B",$E(X,1 ,30),DA)
  51391   "^DD",7410 02.17,7410 02.17801,. 01,3)
  51392   Answer mus t be 1-30  characters  in length .
  51393   "^DD",7410 02.17,7410 02.17801,. 01,"DT")
  51394   2951212
  51395   "^DD",7410 02.17,7410 02.17801,. 02,0)
  51396   EDI TRADIN G PARTNER  ID NUMBER^ F^^0;2^K:$ L(X)>20!($ L(X)<1) X
  51397   "^DD",7410 02.17,7410 02.17801,. 02,1,0)
  51398   ^.1
  51399   "^DD",7410 02.17,7410 02.17801,. 02,1,1,0)
  51400   741002.178 01^C
  51401   "^DD",7410 02.17,7410 02.17801,. 02,1,1,1)
  51402   S ^CHMDIC( 741002.17, DA(1),801, "C",$E(X,1 ,30),DA)=" "
  51403   "^DD",7410 02.17,7410 02.17801,. 02,1,1,2)
  51404   K ^CHMDIC( 741002.17, DA(1),801, "C",$E(X,1 ,30),DA)
  51405   "^DD",7410 02.17,7410 02.17801,. 02,1,1,"DT ")
  51406   2951213
  51407   "^DD",7410 02.17,7410 02.17801,. 02,3)
  51408   Answer mus t be 1-20  characters  in length .
  51409   "^DD",7410 02.17,7410 02.17801,. 02,"DT")
  51410   2951213
  51411   "^DD",7410 02.17,7410 02.17801,. 03,0)
  51412   EDI SCANNE R NAME^F^^ 0;3^K:$L(X )>15!($L(X )<1) X
  51413   "^DD",7410 02.17,7410 02.17801,. 03,3)
  51414   Answer mus t be 1-15  characters  in length .
  51415   "^DD",7410 02.17,7410 02.17801,. 03,"DT")
  51416   2951212
  51417   "^DD",7410 02.17,7410 02.17801,. 04,0)
  51418   EDI TRADIN G PARTNER  ADDRESS1^F ^^0;4^K:$L (X)>30!($L (X)<1) X
  51419   "^DD",7410 02.17,7410 02.17801,. 04,3)
  51420   Answer mus t be 1-30  characters  in length .
  51421   "^DD",7410 02.17,7410 02.17801,. 04,"DT")
  51422   2951212
  51423   "^DD",7410 02.17,7410 02.17801,. 05,0)
  51424   EDI TRADIN G PARTNER  ADDRESS2^F ^^0;5^K:$L (X)>30!($L (X)<1) X
  51425   "^DD",7410 02.17,7410 02.17801,. 05,3)
  51426   Answer mus t be 1-30  characters  in length .
  51427   "^DD",7410 02.17,7410 02.17801,. 05,"DT")
  51428   2951212
  51429   "^DD",7410 02.17,7410 02.17801,. 06,0)
  51430   EDI TRADIN G PARTNER  CITY^F^^0; 6^K:$L(X)> 20!($L(X)< 1) X
  51431   "^DD",7410 02.17,7410 02.17801,. 06,3)
  51432   Answer mus t be 1-20  characters  in length .
  51433   "^DD",7410 02.17,7410 02.17801,. 06,"DT")
  51434   2951212
  51435   "^DD",7410 02.17,7410 02.17801,. 07,0)
  51436   EDI TRADIN G PARTNER  STATE^RP5' ^DIC(5,^0; 7^Q
  51437   "^DD",7410 02.17,7410 02.17801,. 07,"DT")
  51438   3030506
  51439   "^DD",7410 02.17,7410 02.17801,. 08,0)
  51440   EDI TRADIN G PARTNER  ZIP CODE^F ^^0;8^K:$L (X)>10!($L (X)<5) X
  51441   "^DD",7410 02.17,7410 02.17801,. 08,3)
  51442   Answer mus t be 5-10  characters  in length .
  51443   "^DD",7410 02.17,7410 02.17801,. 08,"DT")
  51444   2951212
  51445   "^DD",7410 02.17,7410 02.17801,. 09,0)
  51446   EDI TRADIN G PARTNER  TELEPHONE^ F^^0;9^K:$ L(X)>12!($ L(X)<3) X
  51447   "^DD",7410 02.17,7410 02.17801,. 09,3)
  51448   Answer mus t be 3-12  characters  in length .
  51449   "^DD",7410 02.17,7410 02.17801,. 09,"DT")
  51450   2951212
  51451   "^DD",7410 02.17,7410 02.17801,. 1,0)
  51452   EDI TRADIN G PARTNER  CONTACT^F^ ^0;10^K:$L (X)>30!($L (X)<1) X
  51453   "^DD",7410 02.17,7410 02.17801,. 1,3)
  51454   Answer mus t be 1-30  characters  in length .
  51455   "^DD",7410 02.17,7410 02.17801,. 1,"DT")
  51456   2951212
  51457   "^DD",7410 02.17,7410 02.17801,. 11,0)
  51458   EDI PARTNE R E-MAIL N AME^F^^0;1 1^K:$L(X)> 30!($L(X)< 1) X
  51459   "^DD",7410 02.17,7410 02.17801,. 11,3)
  51460   Answer mus t be 1-30  characters  in length .
  51461   "^DD",7410 02.17,7410 02.17801,. 11,"DT")
  51462   2951218
  51463   "^DD",7410 02.17,7410 02.17801,. 12,0)
  51464   EDI TRADIN G PARTNER  TYPE^S^1:C MOP SVC CT R;2:CMOP;3 :EDI;^0;12 ^Q
  51465   "^DD",7410 02.17,7410 02.17801,. 12,"DT")
  51466   2980508
  51467   "^DD",7410 02.17,7410 02.17801,1 01,0)
  51468   EDI PARTNE R TDA BASE  AMNT^7410 02.1780110 1^^101;0
  51469   "^DD",7410 02.17,7410 02.1780110 1,0)
  51470   EDI PARTNE R TDA BASE  AMNT SUB- FIELD^^.05 ^5
  51471   "^DD",7410 02.17,7410 02.1780110 1,0,"DT")
  51472   2990922
  51473   "^DD",7410 02.17,7410 02.1780110 1,0,"IX"," B",741002. 17801101,. 01)
  51474  
  51475   "^DD",7410 02.17,7410 02.1780110 1,0,"NM"," EDI PARTNE R TDA BASE  AMNT")
  51476  
  51477   "^DD",7410 02.17,7410 02.1780110 1,0,"UP")
  51478   741002.178 01
  51479   "^DD",7410 02.17,7410 02.1780110 1,.01,0)
  51480   EDI PARTNE R TDA BASE  AMNT^NJ9, 2^^0;1^K:+ X'=X!(X>99 9999)!(X<0 )!(X?.E1". "3N.N) X
  51481   "^DD",7410 02.17,7410 02.1780110 1,.01,1,0)
  51482   ^.1
  51483   "^DD",7410 02.17,7410 02.1780110 1,.01,1,1, 0)
  51484   741002.178 01101^B
  51485   "^DD",7410 02.17,7410 02.1780110 1,.01,1,1, 1)
  51486   S ^CHMDIC( 741002.17, DA(2),801, DA(1),101, "B",$E(X,1 ,30),DA)=" "
  51487   "^DD",7410 02.17,7410 02.1780110 1,.01,1,1, 2)
  51488   K ^CHMDIC( 741002.17, DA(2),801, DA(1),101, "B",$E(X,1 ,30),DA)
  51489   "^DD",7410 02.17,7410 02.1780110 1,.01,3)
  51490   Type a Num ber betwee n 0 and 99 9999, 2 De cimal Digi ts
  51491   "^DD",7410 02.17,7410 02.1780110 1,.01,"DT" )
  51492   2990922
  51493   "^DD",7410 02.17,7410 02.1780110 1,.02,0)
  51494   DATE/TIME  TDA BASE A MNT SET^D^ ^0;2^S %DT ="EST" D ^ %DT S X=Y  K:Y<1 X
  51495   "^DD",7410 02.17,7410 02.1780110 1,.02,"DT" )
  51496   2951212
  51497   "^DD",7410 02.17,7410 02.1780110 1,.03,0)
  51498   DUZ SETTIN G TDA BASE  AMNT^P200 '^VA(200,^ 0;3^Q
  51499   "^DD",7410 02.17,7410 02.1780110 1,.03,"DT" )
  51500   2951212
  51501   "^DD",7410 02.17,7410 02.1780110 1,.04,0)
  51502   TDA MONTH  OFFSET^S^0 :NO;1:YES; ^0;4^Q
  51503   "^DD",7410 02.17,7410 02.1780110 1,.04,"DT" )
  51504   2960213
  51505   "^DD",7410 02.17,7410 02.1780110 1,.05,0)
  51506   TDA DAY OF  MONTH TO  RUN^NJ2,0^ ^0;5^K:+X' =X!(X>31)! (X<1)!(X?. E1"."1N.N)  X
  51507   "^DD",7410 02.17,7410 02.1780110 1,.05,3)
  51508   Type a Num ber betwee n 1 and 31 , 0 Decima l Digits
  51509   "^DD",7410 02.17,7410 02.1780110 1,.05,"DT" )
  51510   2960213
  51511   "^DD",7410 02.17,7410 02.18,0)
  51512   ASA EFFECT IVE END DA TE SUB-FIE LD^^.12^12
  51513   "^DD",7410 02.17,7410 02.18,0,"D T")
  51514   3061218
  51515   "^DD",7410 02.17,7410 02.18,0,"I X","B",741 002.18,.01 )
  51516  
  51517   "^DD",7410 02.17,7410 02.18,0,"N M","ASA EF FECTIVE EN D DATE")
  51518  
  51519   "^DD",7410 02.17,7410 02.18,0,"U P")
  51520   741002.17
  51521   "^DD",7410 02.17,7410 02.18,.01, 0)
  51522   EFFECTIVE  BEGIN DATE  (ASA)^MDX a^^0;1^S % DT="E" D ^ %DT S X=Y  K:Y<1 X S: $D(X) DINU M=9999999- X
  51523   "^DD",7410 02.17,7410 02.18,.01, 1,0)
  51524   ^.1
  51525   "^DD",7410 02.17,7410 02.18,.01, 1,1,0)
  51526   741002.18^ B
  51527   "^DD",7410 02.17,7410 02.18,.01, 1,1,1)
  51528   S ^CHMDIC( 741002.17, DA(1),1,"B ",$E(X,1,3 0),DA)=""
  51529   "^DD",7410 02.17,7410 02.18,.01, 1,1,2)
  51530   K ^CHMDIC( 741002.17, DA(1),1,"B ",$E(X,1,3 0),DA)
  51531   "^DD",7410 02.17,7410 02.18,.01, 1,1,"DT")
  51532   2910426
  51533   "^DD",7410 02.17,7410 02.18,.01, "AUDIT")
  51534   y
  51535   "^DD",7410 02.17,7410 02.18,.01, "DT")
  51536   2910912
  51537   "^DD",7410 02.17,7410 02.18,.02, 0)
  51538   ASA LARGE  URBAN LABO R^NJ8,2a^^ 0;2^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 )!(X<0) X
  51539   "^DD",7410 02.17,7410 02.18,.02, 3)
  51540   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51541   "^DD",7410 02.17,7410 02.18,.02, "AUDIT")
  51542   y
  51543   "^DD",7410 02.17,7410 02.18,.02, "DT")
  51544   2910912
  51545   "^DD",7410 02.17,7410 02.18,.03, 0)
  51546   ASA LARGE  URBAN NON- LABOR^NJ7, 2a^^0;3^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 999)!(X<0)  X
  51547   "^DD",7410 02.17,7410 02.18,.03, 3)
  51548   Type a Dol lar Amount  between 0  and 9999,  2 Decimal  Digits
  51549   "^DD",7410 02.17,7410 02.18,.03, "AUDIT")
  51550   y
  51551   "^DD",7410 02.17,7410 02.18,.03, "DT")
  51552   2910912
  51553   "^DD",7410 02.17,7410 02.18,.04, 0)
  51554   ASA URBAN  LABOR^NJ8, 2a^^0;4^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 9999)!(X<0 ) X
  51555   "^DD",7410 02.17,7410 02.18,.04, 3)
  51556   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51557   "^DD",7410 02.17,7410 02.18,.04, "AUDIT")
  51558   y
  51559   "^DD",7410 02.17,7410 02.18,.04, "DT")
  51560   2910912
  51561   "^DD",7410 02.17,7410 02.18,.05, 0)
  51562   ASA URBAN  NON-LABOR^ NJ7,2a^^0; 5^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999)!( X<0) X
  51563   "^DD",7410 02.17,7410 02.18,.05, 3)
  51564   Type a Dol lar Amount  between 0  and 9999,  2 Decimal  Digits
  51565   "^DD",7410 02.17,7410 02.18,.05, "AUDIT")
  51566   y
  51567   "^DD",7410 02.17,7410 02.18,.05, "DT")
  51568   2910912
  51569   "^DD",7410 02.17,7410 02.18,.06, 0)
  51570   ASA RURAL  LABOR^NJ8, 2a^^0;6^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 9999)!(X<0 ) X
  51571   "^DD",7410 02.17,7410 02.18,.06, 3)
  51572   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51573   "^DD",7410 02.17,7410 02.18,.06, "AUDIT")
  51574   y
  51575   "^DD",7410 02.17,7410 02.18,.06, "DT")
  51576   2910912
  51577   "^DD",7410 02.17,7410 02.18,.07, 0)
  51578   ASA RURAL  NON-LABOR^ NJ7,2a^^0; 7^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>9999)!( X<0) X
  51579   "^DD",7410 02.17,7410 02.18,.07, 3)
  51580   Type a Dol lar Amount  between 0  and 9999,  2 Decimal  Digits
  51581   "^DD",7410 02.17,7410 02.18,.07, "AUDIT")
  51582   y
  51583   "^DD",7410 02.17,7410 02.18,.07, "DT")
  51584   2910912
  51585   "^DD",7410 02.17,7410 02.18,.08, 0)
  51586   EFFECTIVE  END DATE ( ASA)^Da^^0 ;8^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X
  51587   "^DD",7410 02.17,7410 02.18,.08, "AUDIT")
  51588   y
  51589   "^DD",7410 02.17,7410 02.18,.08, "DT")
  51590   2910912
  51591   "^DD",7410 02.17,7410 02.18,.09, 0)
  51592   WAGE INDEX  GT 1.0 LA BOR^NJ8,2^ ^0;9^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9)!(X<0) X
  51593   "^DD",7410 02.17,7410 02.18,.09, 3)
  51594   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51595   "^DD",7410 02.17,7410 02.18,.09, "DT")
  51596   3061218
  51597   "^DD",7410 02.17,7410 02.18,.1,0 )
  51598   WAGE INDEX  GT 1.0 NO N LABOR^NJ 8,2^^0;10^ S:X["$" X= $P(X,"$",2 ) K:X'?.N. 1".".2N!(X >99999)!(X <0) X
  51599   "^DD",7410 02.17,7410 02.18,.1,3 )
  51600   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51601   "^DD",7410 02.17,7410 02.18,.1," DT")
  51602   3061218
  51603   "^DD",7410 02.17,7410 02.18,.11, 0)
  51604   WAGE INDEX  LT OR EQ  1.0 LABOR^ NJ8,2^^0;1 1^S:X["$"  X=$P(X,"$" ,2) K:X'?. N.1".".2N! (X>99999)! (X<0) X
  51605   "^DD",7410 02.17,7410 02.18,.11, 3)
  51606   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51607   "^DD",7410 02.17,7410 02.18,.11, "DT")
  51608   3061218
  51609   "^DD",7410 02.17,7410 02.18,.12, 0)
  51610   WAGE INDEX  LT/EQ 1.0  NON LABOR ^NJ8,2^^0; 12^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>99999) !(X<0) X
  51611   "^DD",7410 02.17,7410 02.18,.12, 3)
  51612   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51613   "^DD",7410 02.17,7410 02.18,.12, "DT")
  51614   3061218
  51615   "^DD",7410 02.17,7410 02.18102,0 )
  51616   BEGIN DATE  (LVMH) HI ST SUB-FIE LD^^.04^4
  51617   "^DD",7410 02.17,7410 02.18102,0 ,"DT")
  51618   2951011
  51619   "^DD",7410 02.17,7410 02.18102,0 ,"IX","B", 741002.181 02,.01)
  51620  
  51621   "^DD",7410 02.17,7410 02.18102,0 ,"NM","BEG IN DATE (L VMH) HIST" )
  51622  
  51623   "^DD",7410 02.17,7410 02.18102,0 ,"UP")
  51624   741002.171 02
  51625   "^DD",7410 02.17,7410 02.18102,. 01,0)
  51626   BEGIN DATE  (LVMH) HI ST^D^^0;1^ S %DT="EST " D ^%DT S  X=Y K:Y<1  X
  51627   "^DD",7410 02.17,7410 02.18102,. 01,1,0)
  51628   ^.1
  51629   "^DD",7410 02.17,7410 02.18102,. 01,1,1,0)
  51630   741002.181 02^B
  51631   "^DD",7410 02.17,7410 02.18102,. 01,1,1,1)
  51632   S ^CHMDIC( 741002.17, DA(2),102, DA(1),10," B",$E(X,1, 30),DA)=""
  51633   "^DD",7410 02.17,7410 02.18102,. 01,1,1,2)
  51634   K ^CHMDIC( 741002.17, DA(2),102, DA(1),10," B",$E(X,1, 30),DA)
  51635   "^DD",7410 02.17,7410 02.18102,. 01,"DT")
  51636   2910912
  51637   "^DD",7410 02.17,7410 02.18102,. 02,0)
  51638   LABOR PERC ENTAGE HIS T^NJ3,0^^0 ;2^K:+X'=X !(X>100)!( X<0)!(X?.E 1"."1N.N)  X
  51639   "^DD",7410 02.17,7410 02.18102,. 02,3)
  51640   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  51641   "^DD",7410 02.17,7410 02.18102,. 02,"DT")
  51642   2910912
  51643   "^DD",7410 02.17,7410 02.18102,. 03,0)
  51644   END DATE ( LVMH) HIST ^D^^0;3^S  %DT="EST"  D ^%DT S X =Y K:Y<1 X
  51645   "^DD",7410 02.17,7410 02.18102,. 03,"DT")
  51646   2910912
  51647   "^DD",7410 02.17,7410 02.18102,. 04,0)
  51648   DUZ^P200'^ VA(200,^0; 4^Q
  51649   "^DD",7410 02.17,7410 02.18102,. 04,"DT")
  51650   2951011
  51651   "^DD",7410 02.17,7410 02.19,0)
  51652   EFFECTIVE  END DATE ( C H DIFF)  SUB-FIELD^ ^.06^6
  51653   "^DD",7410 02.17,7410 02.19,0,"D T")
  51654   2910912
  51655   "^DD",7410 02.17,7410 02.19,0,"I X","B",741 002.19,.01 )
  51656  
  51657   "^DD",7410 02.17,7410 02.19,0,"N M","EFFECT IVE END DA TE (C H DI FF)")
  51658  
  51659   "^DD",7410 02.17,7410 02.19,0,"U P")
  51660   741002.17
  51661   "^DD",7410 02.17,7410 02.19,.01, 0)
  51662   EFFECT BEG IN DATE (C  H DIFF)^M DXa^^0;1^S  %DT="E" D  ^%DT S X= Y K:Y<1 X  S:$D(X) DI NUM=999999 9-X
  51663   "^DD",7410 02.17,7410 02.19,.01, 1,0)
  51664   ^.1
  51665   "^DD",7410 02.17,7410 02.19,.01, 1,1,0)
  51666   741002.19^ B
  51667   "^DD",7410 02.17,7410 02.19,.01, 1,1,1)
  51668   S ^CHMDIC( 741002.17, DA(1),5,"B ",$E(X,1,3 0),DA)=""
  51669   "^DD",7410 02.17,7410 02.19,.01, 1,1,2)
  51670   K ^CHMDIC( 741002.17, DA(1),5,"B ",$E(X,1,3 0),DA)
  51671   "^DD",7410 02.17,7410 02.19,.01, 1,1,"DT")
  51672   2910429
  51673   "^DD",7410 02.17,7410 02.19,.01, "AUDIT")
  51674   y
  51675   "^DD",7410 02.17,7410 02.19,.01, "DT")
  51676   2910912
  51677   "^DD",7410 02.17,7410 02.19,.02, 0)
  51678   C H DIFF L ARGE URBAN  LABOR^NJ8 ,2a^^0;2^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 99999)!(X< 0) X
  51679   "^DD",7410 02.17,7410 02.19,.02, 3)
  51680   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51681   "^DD",7410 02.17,7410 02.19,.02, "AUDIT")
  51682   y
  51683   "^DD",7410 02.17,7410 02.19,.02, "DT")
  51684   2910912
  51685   "^DD",7410 02.17,7410 02.19,.03, 0)
  51686   C H DIFF L ARGE URBAN  NON-LABOR ^NJ7,2a^^0 ;3^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>9999)! (X<0) X
  51687   "^DD",7410 02.17,7410 02.19,.03, 3)
  51688   Type a Dol lar Amount  between 0  and 9999,  2 Decimal  Digits
  51689   "^DD",7410 02.17,7410 02.19,.03, "AUDIT")
  51690   y
  51691   "^DD",7410 02.17,7410 02.19,.03, "DT")
  51692   2910912
  51693   "^DD",7410 02.17,7410 02.19,.04, 0)
  51694   C H DIFF U RBAN LABOR ^NJ8,2a^^0 ;4^S:X["$"  X=$P(X,"$ ",2) K:X'? .N.1".".2N !(X>99999) !(X<0) X
  51695   "^DD",7410 02.17,7410 02.19,.04, 3)
  51696   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  51697   "^DD",7410 02.17,7410 02.19,.04, "AUDIT")
  51698   y
  51699   "^DD",7410 02.17,7410 02.19,.04, "DT")
  51700   2910912
  51701   "^DD",7410 02.17,7410 02.19,.05, 0)
  51702   C H DIFF U RBAN NON-L ABOR^NJ7,2 a^^0;5^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 99)!(X<0)  X
  51703   "^DD",7410 02.17,7410 02.19,.05, 3)
  51704   Type a Dol lar Amount  between 0  and 9999,  2 Decimal  Digits
  51705   "^DD",7410 02.17,7410 02.19,.05, "AUDIT")
  51706   y
  51707   "^DD",7410 02.17,7410 02.19,.05, "DT")
  51708   2910912
  51709   "^DD",7410 02.17,7410 02.19,.06, 0)
  51710   EFFECTIVE  END DATE ( C H DIFF)^ Da^^0;6^S  %DT="E" D  ^%DT S X=Y  K:Y<1 X
  51711   "^DD",7410 02.17,7410 02.19,.06, "AUDIT")
  51712   y
  51713   "^DD",7410 02.17,7410 02.19,.06, "DT")
  51714   2910912
  51715   "^DD",7410 02.17,7410 02.19102,0 )
  51716   BEGIN DATE  (ASA) SUB -FIELD^^.0 9^9
  51717   "^DD",7410 02.17,7410 02.19102,0 ,"DT")
  51718   2951011
  51719   "^DD",7410 02.17,7410 02.19102,0 ,"IX","B", 741002.191 02,.01)
  51720  
  51721   "^DD",7410 02.17,7410 02.19102,0 ,"NM","BEG IN DATE (A SA)")
  51722  
  51723   "^DD",7410 02.17,7410 02.19102,0 ,"UP")
  51724   741002.171 02
  51725   "^DD",7410 02.17,7410 02.19102,. 01,0)
  51726   BEGIN DATE  (ASA) HIS T^D^^0;1^S  %DT="EST"  D ^%DT S  X=Y K:Y<1  X
  51727   "^DD",7410 02.17,7410 02.19102,. 01,1,0)
  51728   ^.1
  51729   "^DD",7410 02.17,7410 02.19102,. 01,1,1,0)
  51730   741002.191 02^B
  51731   "^DD",7410 02.17,7410 02.19102,. 01,1,1,1)
  51732   S ^CHMDIC( 741002.17, DA(2),102, DA(1),1,"B ",$E(X,1,3 0),DA)=""
  51733   "^DD",7410 02.17,7410 02.19102,. 01,1,1,2)
  51734   K ^CHMDIC( 741002.17, DA(2),102, DA(1),1,"B ",$E(X,1,3 0),DA)
  51735   "^DD",7410 02.17,7410 02.19102,. 01,"AUDIT" )
  51736  
  51737   "^DD",7410 02.17,7410 02.19102,. 01,"DT")
  51738   2910912
  51739   "^DD",7410 02.17,7410 02.19102,. 02,0)
  51740   ASA LARGE  URBAN LABO R HIST^NJ5 ,0^^0;2^K: +X'=X!(X>9 9999)!(X<0 )!(X?.E1". "1N.N) X
  51741   "^DD",7410 02.17,7410 02.19102,. 02,3)
  51742   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51743   "^DD",7410 02.17,7410 02.19102,. 02,"DT")
  51744   2910912
  51745   "^DD",7410 02.17,7410 02.19102,. 03,0)
  51746   ASA LARGE  URBAN NON- LABOR^NJ4, 0^^0;3^K:+ X'=X!(X>99 99)!(X<0)! (X?.E1"."1 N.N) X
  51747   "^DD",7410 02.17,7410 02.19102,. 03,3)
  51748   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  51749   "^DD",7410 02.17,7410 02.19102,. 03,"DT")
  51750   2910912
  51751   "^DD",7410 02.17,7410 02.19102,. 04,0)
  51752   ASA URBAN  LABOR HIST ^NJ5,0^^0; 4^K:+X'=X! (X>99999)! (X<0)!(X?. E1"."1N.N)  X
  51753   "^DD",7410 02.17,7410 02.19102,. 04,3)
  51754   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51755   "^DD",7410 02.17,7410 02.19102,. 04,"DT")
  51756   2910912
  51757   "^DD",7410 02.17,7410 02.19102,. 05,0)
  51758   ASA URBAN  NON-LABOR  HIST^NJ4,0 ^^0;5^K:+X '=X!(X>999 9)!(X<0)!( X?.E1"."1N .N) X
  51759   "^DD",7410 02.17,7410 02.19102,. 05,3)
  51760   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  51761   "^DD",7410 02.17,7410 02.19102,. 05,"DT")
  51762   2910912
  51763   "^DD",7410 02.17,7410 02.19102,. 06,0)
  51764   ASA RURAL  LABOR HIST ^NJ5,0^^0; 6^K:+X'=X! (X>99999)! (X<0)!(X?. E1"."1N.N)  X
  51765   "^DD",7410 02.17,7410 02.19102,. 06,3)
  51766   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51767   "^DD",7410 02.17,7410 02.19102,. 06,"DT")
  51768   2910912
  51769   "^DD",7410 02.17,7410 02.19102,. 07,0)
  51770   ASA RURAL  NON-LABOR^ NJ4,0^^0;7 ^K:+X'=X!( X>9999)!(X <0)!(X?.E1 "."1N.N) X
  51771   "^DD",7410 02.17,7410 02.19102,. 07,3)
  51772   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  51773   "^DD",7410 02.17,7410 02.19102,. 07,"DT")
  51774   2910912
  51775   "^DD",7410 02.17,7410 02.19102,. 08,0)
  51776   EFFECTIVE  END DATE ( ASA)^D^^0; 8^S %DT="E ST" D ^%DT  S X=Y K:Y <1 X
  51777   "^DD",7410 02.17,7410 02.19102,. 08,"DT")
  51778   2910912
  51779   "^DD",7410 02.17,7410 02.19102,. 09,0)
  51780   DUZ^P200'^ VA(200,^0; 9^Q
  51781   "^DD",7410 02.17,7410 02.19102,. 09,"DT")
  51782   2951011
  51783   "^DD",7410 02.17,7410 02.20102,0 )
  51784   BEGIN DATE  (CH DIFF)  HIST SUB- FIELD^^.07 ^7
  51785   "^DD",7410 02.17,7410 02.20102,0 ,"DT")
  51786   2951011
  51787   "^DD",7410 02.17,7410 02.20102,0 ,"IX","B", 741002.201 02,.01)
  51788  
  51789   "^DD",7410 02.17,7410 02.20102,0 ,"NM","BEG IN DATE (C H DIFF) HI ST")
  51790  
  51791   "^DD",7410 02.17,7410 02.20102,0 ,"UP")
  51792   741002.171 02
  51793   "^DD",7410 02.17,7410 02.20102,. 01,0)
  51794   BEGIN DATE  (CH DIFF)  HIST^D^^0 ;1^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X
  51795   "^DD",7410 02.17,7410 02.20102,. 01,1,0)
  51796   ^.1
  51797   "^DD",7410 02.17,7410 02.20102,. 01,1,1,0)
  51798   741002.201 02^B
  51799   "^DD",7410 02.17,7410 02.20102,. 01,1,1,1)
  51800   S ^CHMDIC( 741002.17, DA(2),102, DA(1),5,"B ",$E(X,1,3 0),DA)=""
  51801   "^DD",7410 02.17,7410 02.20102,. 01,1,1,2)
  51802   K ^CHMDIC( 741002.17, DA(2),102, DA(1),5,"B ",$E(X,1,3 0),DA)
  51803   "^DD",7410 02.17,7410 02.20102,. 01,"DT")
  51804   2910912
  51805   "^DD",7410 02.17,7410 02.20102,. 02,0)
  51806   CH DIFF LA RGE URBAN  LABOR HIST ^NJ5,0^^0; 2^K:+X'=X! (X>99999)! (X<0)!(X?. E1"."1N.N)  X
  51807   "^DD",7410 02.17,7410 02.20102,. 02,3)
  51808   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51809   "^DD",7410 02.17,7410 02.20102,. 02,"DT")
  51810   2910912
  51811   "^DD",7410 02.17,7410 02.20102,. 03,0)
  51812   CH DIFF LG  URB NON-L ABOR HIST^ NJ4,0^^0;3 ^K:+X'=X!( X>9999)!(X <0)!(X?.E1 "."1N.N) X
  51813   "^DD",7410 02.17,7410 02.20102,. 03,3)
  51814   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  51815   "^DD",7410 02.17,7410 02.20102,. 03,"DT")
  51816   2910912
  51817   "^DD",7410 02.17,7410 02.20102,. 04,0)
  51818   CH DIFF UR BAN LABOR  HIST^NJ5,0 ^^0;4^K:+X '=X!(X>999 99)!(X<0)! (X?.E1"."1 N.N) X
  51819   "^DD",7410 02.17,7410 02.20102,. 04,3)
  51820   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51821   "^DD",7410 02.17,7410 02.20102,. 04,"DT")
  51822   2910912
  51823   "^DD",7410 02.17,7410 02.20102,. 05,0)
  51824   CH DIFF UR BAN NON-LA BOR HIST^N J4,0^^0;5^ K:+X'=X!(X >9999)!(X< 0)!(X?.E1" ."1N.N) X
  51825   "^DD",7410 02.17,7410 02.20102,. 05,3)
  51826   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  51827   "^DD",7410 02.17,7410 02.20102,. 05,"DT")
  51828   2910912
  51829   "^DD",7410 02.17,7410 02.20102,. 06,0)
  51830   END DATE ( CH DIFF) H IST^D^^0;6 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  51831   "^DD",7410 02.17,7410 02.20102,. 06,"DT")
  51832   2910912
  51833   "^DD",7410 02.17,7410 02.20102,. 07,0)
  51834   DUZ^P200'^ VA(200,^0; 7^Q
  51835   "^DD",7410 02.17,7410 02.20102,. 07,"DT")
  51836   2951011
  51837   "^DD",7410 02.17,7410 02.21102,0 )
  51838   BEGIN DATE  (KID ACQ)  HIST SUB- FIELD^^.04 ^4
  51839   "^DD",7410 02.17,7410 02.21102,0 ,"DT")
  51840   2951011
  51841   "^DD",7410 02.17,7410 02.21102,0 ,"IX","B", 741002.211 02,.01)
  51842  
  51843   "^DD",7410 02.17,7410 02.21102,0 ,"NM","BEG IN DATE (K ID ACQ) HI ST")
  51844  
  51845   "^DD",7410 02.17,7410 02.21102,0 ,"UP")
  51846   741002.171 02
  51847   "^DD",7410 02.17,7410 02.21102,. 01,0)
  51848   BEGIN DATE  (KID ACQ)  HIST^D^^0 ;1^S %DT=" EST" D ^%D T S X=Y K: Y<1 X
  51849   "^DD",7410 02.17,7410 02.21102,. 01,1,0)
  51850   ^.1
  51851   "^DD",7410 02.17,7410 02.21102,. 01,1,1,0)
  51852   741002.211 02^B
  51853   "^DD",7410 02.17,7410 02.21102,. 01,1,1,1)
  51854   S ^CHMDIC( 741002.17, DA(2),102, DA(1),15," B",$E(X,1, 30),DA)=""
  51855   "^DD",7410 02.17,7410 02.21102,. 01,1,1,2)
  51856   K ^CHMDIC( 741002.17, DA(2),102, DA(1),15," B",$E(X,1, 30),DA)
  51857   "^DD",7410 02.17,7410 02.21102,. 01,"DT")
  51858   2910912
  51859   "^DD",7410 02.17,7410 02.21102,. 02,0)
  51860   ALLOW KID  ACQ COST H IST^NJ5,0^ ^0;2^K:+X' =X!(X>9999 9)!(X<0)!( X?.E1"."1N .N) X
  51861   "^DD",7410 02.17,7410 02.21102,. 02,3)
  51862   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51863   "^DD",7410 02.17,7410 02.21102,. 02,"DT")
  51864   2910912
  51865   "^DD",7410 02.17,7410 02.21102,. 03,0)
  51866   END DATE ( KID ACQ) H IST^D^^0;3 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  51867   "^DD",7410 02.17,7410 02.21102,. 03,"DT")
  51868   2910912
  51869   "^DD",7410 02.17,7410 02.21102,. 04,0)
  51870   DUZ^P200'^ VA(200,^0; 4^Q
  51871   "^DD",7410 02.17,7410 02.21102,. 04,"DT")
  51872   2951011
  51873   "^DD",7410 02.17,7410 02.22102,0 )
  51874   BEGIN DATE  (OUTL) HI ST SUB-FIE LD^^1^16
  51875   "^DD",7410 02.17,7410 02.22102,0 ,"DT")
  51876   2951011
  51877   "^DD",7410 02.17,7410 02.22102,0 ,"IX","B", 741002.221 02,.01)
  51878  
  51879   "^DD",7410 02.17,7410 02.22102,0 ,"NM","BEG IN DATE (O UTL) HIST" )
  51880  
  51881   "^DD",7410 02.17,7410 02.22102,0 ,"UP")
  51882   741002.171 02
  51883   "^DD",7410 02.17,7410 02.22102,. 01,0)
  51884   BEGIN DATE  (OUTL) HI ST^D^^0;1^ S %DT="EST " D ^%DT S  X=Y K:Y<1  X
  51885   "^DD",7410 02.17,7410 02.22102,. 01,1,0)
  51886   ^.1
  51887   "^DD",7410 02.17,7410 02.22102,. 01,1,1,0)
  51888   741002.221 02^B
  51889   "^DD",7410 02.17,7410 02.22102,. 01,1,1,1)
  51890   S ^CHMDIC( 741002.17, DA(2),102, DA(1),20," B",$E(X,1, 30),DA)=""
  51891   "^DD",7410 02.17,7410 02.22102,. 01,1,1,2)
  51892   K ^CHMDIC( 741002.17, DA(2),102, DA(1),20," B",$E(X,1, 30),DA)
  51893   "^DD",7410 02.17,7410 02.22102,. 01,"DT")
  51894   2910913
  51895   "^DD",7410 02.17,7410 02.22102,. 02,0)
  51896   PERCENT LO S OUTL CHI LD HIST^NJ 3,0^^0;2^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X
  51897   "^DD",7410 02.17,7410 02.22102,. 02,3)
  51898   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51899   "^DD",7410 02.17,7410 02.22102,. 02,"DT")
  51900   2910913
  51901   "^DD",7410 02.17,7410 02.22102,. 03,0)
  51902   PERCENT LO S OUTL BUR N HIST^NJ3 ,0^^0;3^K: +X'=X!(X>9 99)!(X<0)! (X?.E1"."1 N.N) X
  51903   "^DD",7410 02.17,7410 02.22102,. 03,3)
  51904   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51905   "^DD",7410 02.17,7410 02.22102,. 03,"DT")
  51906   2910913
  51907   "^DD",7410 02.17,7410 02.22102,. 04,0)
  51908   PERCENT LO S OUTL OTH ER HIST^NJ 3,0^^0;4^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X
  51909   "^DD",7410 02.17,7410 02.22102,. 04,3)
  51910   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51911   "^DD",7410 02.17,7410 02.22102,. 04,"DT")
  51912   2910913
  51913   "^DD",7410 02.17,7410 02.22102,. 05,0)
  51914   COST OUTL  CAP CHILD  HIST^NJ5,0 ^^0;5^K:+X '=X!(X>999 99)!(X<0)! (X?.E1"."1 N.N) X
  51915   "^DD",7410 02.17,7410 02.22102,. 05,3)
  51916   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51917   "^DD",7410 02.17,7410 02.22102,. 05,"DT")
  51918   2910913
  51919   "^DD",7410 02.17,7410 02.22102,. 06,0)
  51920   COST OUTL  CAP OTHER  HIST^NJ5,0 ^^0;6^K:+X '=X!(X>999 99)!(X<0)! (X?.E1"."1 N.N) X
  51921   "^DD",7410 02.17,7410 02.22102,. 06,3)
  51922   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51923   "^DD",7410 02.17,7410 02.22102,. 06,"DT")
  51924   2910913
  51925   "^DD",7410 02.17,7410 02.22102,. 07,0)
  51926   PERCENT CO ST OUTL CH ILD HIST^N J3,0^^0;7^ K:+X'=X!(X >999)!(X<0 )!(X?.E1". "1N.N) X
  51927   "^DD",7410 02.17,7410 02.22102,. 07,3)
  51928   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51929   "^DD",7410 02.17,7410 02.22102,. 07,"DT")
  51930   2910913
  51931   "^DD",7410 02.17,7410 02.22102,. 08,0)
  51932   PERCENT CO ST OUTL BU RN HIST^NJ 3,0^^0;8^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X
  51933   "^DD",7410 02.17,7410 02.22102,. 08,3)
  51934   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51935   "^DD",7410 02.17,7410 02.22102,. 08,"DT")
  51936   2910913
  51937   "^DD",7410 02.17,7410 02.22102,. 09,0)
  51938   PERCENT CO ST OUTL OT HER HIST^N J3,0^^0;9^ K:+X'=X!(X >999)!(X<0 )!(X?.E1". "1N.N) X
  51939   "^DD",7410 02.17,7410 02.22102,. 09,3)
  51940   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51941   "^DD",7410 02.17,7410 02.22102,. 09,"DT")
  51942   2910913
  51943   "^DD",7410 02.17,7410 02.22102,. 11,0)
  51944   PER TRANSF  OUTL NEON ATE HIST^N J3,0^^0;11 ^K:+X'=X!( X>999)!(X< 0)!(X?.E1" ."1N.N) X
  51945   "^DD",7410 02.17,7410 02.22102,. 11,3)
  51946   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51947   "^DD",7410 02.17,7410 02.22102,. 11,"DT")
  51948   2910913
  51949   "^DD",7410 02.17,7410 02.22102,. 12,0)
  51950   PERCENT TR NSF OUTL O THER HIST^ NJ3,0^^0;1 2^K:+X'=X! (X>999)!(X <0)!(X?.E1 "."1N.N) X
  51951   "^DD",7410 02.17,7410 02.22102,. 12,3)
  51952   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51953   "^DD",7410 02.17,7410 02.22102,. 12,"DT")
  51954   2910913
  51955   "^DD",7410 02.17,7410 02.22102,. 13,0)
  51956   END DATE ( OUTL) HIST ^D^^0;13^S  %DT="EST"  D ^%DT S  X=Y K:Y<1  X
  51957   "^DD",7410 02.17,7410 02.22102,. 13,"DT")
  51958   2910913
  51959   "^DD",7410 02.17,7410 02.22102,. 14,0)
  51960   COST OUTL  CAP BURN H IST^NJ5,0^ ^0;14^K:+X '=X!(X>999 99)!(X<0)! (X?.E1"."1 N.N) X
  51961   "^DD",7410 02.17,7410 02.22102,. 14,3)
  51962   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  51963   "^DD",7410 02.17,7410 02.22102,. 14,"DT")
  51964   2910913
  51965   "^DD",7410 02.17,7410 02.22102,. 15,0)
  51966   DUZ^P200'^ VA(200,^0; 15^Q
  51967   "^DD",7410 02.17,7410 02.22102,. 15,3)
  51968   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  51969   "^DD",7410 02.17,7410 02.22102,. 15,"DT")
  51970   2951011
  51971   "^DD",7410 02.17,7410 02.22102,. 16,0)
  51972   DUZ^P200'^ VA(200,^0; 16^Q
  51973   "^DD",7410 02.17,7410 02.22102,. 16,"DT")
  51974   2951011
  51975   "^DD",7410 02.17,7410 02.22102,1 ,0)
  51976   PERCENT SH ORT STAY O UTL HIST^N J3,0^^0;10 ^K:+X'=X!( X>999)!(X< 0)!(X?.E1" ."1N.N) X
  51977   "^DD",7410 02.17,7410 02.22102,1 ,3)
  51978   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  51979   "^DD",7410 02.17,7410 02.22102,1 ,"DT")
  51980   2910913
  51981   "^DD",7410 02.17,7410 02.23102,0 )
  51982   BEGIN DATE  (CTC) HIS T SUB-FIEL D^^.04^4
  51983   "^DD",7410 02.17,7410 02.23102,0 ,"DT")
  51984   2951011
  51985   "^DD",7410 02.17,7410 02.23102,0 ,"IX","B", 741002.231 02,.01)
  51986  
  51987   "^DD",7410 02.17,7410 02.23102,0 ,"NM","BEG IN DATE (C TC) HIST")
  51988  
  51989   "^DD",7410 02.17,7410 02.23102,0 ,"UP")
  51990   741002.171 02
  51991   "^DD",7410 02.17,7410 02.23102,. 01,0)
  51992   BEGIN DATE  (CTC) HIS T^D^^0;1^S  %DT="EST"  D ^%DT S  X=Y K:Y<1  X
  51993   "^DD",7410 02.17,7410 02.23102,. 01,1,0)
  51994   ^.1
  51995   "^DD",7410 02.17,7410 02.23102,. 01,1,1,0)
  51996   741002.231 02^B
  51997   "^DD",7410 02.17,7410 02.23102,. 01,1,1,1)
  51998   S ^CHMDIC( 741002.17, DA(2),102, DA(1),21," B",$E(X,1, 30),DA)=""
  51999   "^DD",7410 02.17,7410 02.23102,. 01,1,1,2)
  52000   K ^CHMDIC( 741002.17, DA(2),102, DA(1),21," B",$E(X,1, 30),DA)
  52001   "^DD",7410 02.17,7410 02.23102,. 01,"DT")
  52002   2910913
  52003   "^DD",7410 02.17,7410 02.23102,. 02,0)
  52004   COST TO CH ARGE RATIO  HIST^NJ3, 0^^0;2^K:+ X'=X!(X>10 0)!(X<0)!( X?.E1"."1N .N) X
  52005   "^DD",7410 02.17,7410 02.23102,. 02,3)
  52006   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  52007   "^DD",7410 02.17,7410 02.23102,. 02,"DT")
  52008   2910913
  52009   "^DD",7410 02.17,7410 02.23102,. 03,0)
  52010   END DATE ( CTC) HIST^ D^^0;3^S % DT="EST" D  ^%DT S X= Y K:Y<1 X
  52011   "^DD",7410 02.17,7410 02.23102,. 03,"DT")
  52012   2910913
  52013   "^DD",7410 02.17,7410 02.23102,. 04,0)
  52014   DUZ^P200'^ VA(200,^0; 4^Q
  52015   "^DD",7410 02.17,7410 02.23102,. 04,"DT")
  52016   2951011
  52017   "^DD",7410 02.17,7410 02.24102,0 )
  52018   BEGIN DATE  (EDUC) HI ST SUB-FIE LD^^.04^4
  52019   "^DD",7410 02.17,7410 02.24102,0 ,"DT")
  52020   2951011
  52021   "^DD",7410 02.17,7410 02.24102,0 ,"IX","B", 741002.241 02,.01)
  52022  
  52023   "^DD",7410 02.17,7410 02.24102,0 ,"NM","BEG IN DATE (E DUC) HIST" )
  52024  
  52025   "^DD",7410 02.17,7410 02.24102,0 ,"UP")
  52026   741002.171 02
  52027   "^DD",7410 02.17,7410 02.24102,. 01,0)
  52028   BEGIN DATE  (EDUC) HI ST^D^^0;1^ S %DT="EST " D ^%DT S  X=Y K:Y<1  X
  52029   "^DD",7410 02.17,7410 02.24102,. 01,1,0)
  52030   ^.1
  52031   "^DD",7410 02.17,7410 02.24102,. 01,1,1,0)
  52032   741002.241 02^B
  52033   "^DD",7410 02.17,7410 02.24102,. 01,1,1,1)
  52034   S ^CHMDIC( 741002.17, DA(2),102, DA(1),22," B",$E(X,1, 30),DA)=""
  52035   "^DD",7410 02.17,7410 02.24102,. 01,1,1,2)
  52036   K ^CHMDIC( 741002.17, DA(2),102, DA(1),22," B",$E(X,1, 30),DA)
  52037   "^DD",7410 02.17,7410 02.24102,. 01,"DT")
  52038   2910913
  52039   "^DD",7410 02.17,7410 02.24102,. 02,0)
  52040   EDUC COST  PERCENT HI ST^NJ3,0^^ 0;2^K:+X'= X!(X>100)! (X<0)!(X?. E1"."1N.N)  X
  52041   "^DD",7410 02.17,7410 02.24102,. 02,3)
  52042   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  52043   "^DD",7410 02.17,7410 02.24102,. 02,"DT")
  52044   2910913
  52045   "^DD",7410 02.17,7410 02.24102,. 03,0)
  52046   END DATE ( EDUC) HIST ^D^^0;3^S  %DT="EST"  D ^%DT S X =Y K:Y<1 X
  52047   "^DD",7410 02.17,7410 02.24102,. 03,"DT")
  52048   2910913
  52049   "^DD",7410 02.17,7410 02.24102,. 04,0)
  52050   DUZ^P200'^ VA(200,^0; 4^Q
  52051   "^DD",7410 02.17,7410 02.24102,. 04,"DT")
  52052   2951011
  52053   "^DD",7410 02.17,7410 02.25102,0 )
  52054   BEGIN DATE  (DED/CS)  HIST SUB-F IELD^^.11^ 11
  52055   "^DD",7410 02.17,7410 02.25102,0 ,"DT")
  52056   2951011
  52057   "^DD",7410 02.17,7410 02.25102,0 ,"IX","B", 741002.251 02,.01)
  52058  
  52059   "^DD",7410 02.17,7410 02.25102,0 ,"NM","BEG IN DATE (D ED/CS) HIS T")
  52060  
  52061   "^DD",7410 02.17,7410 02.25102,0 ,"UP")
  52062   741002.171 02
  52063   "^DD",7410 02.17,7410 02.25102,. 01,0)
  52064   BEGIN DATE  (DED/CS)  HIST^D^^0; 1^S %DT="E ST" D ^%DT  S X=Y K:Y <1 X
  52065   "^DD",7410 02.17,7410 02.25102,. 01,1,0)
  52066   ^.1
  52067   "^DD",7410 02.17,7410 02.25102,. 01,1,1,0)
  52068   741002.251 02^B
  52069   "^DD",7410 02.17,7410 02.25102,. 01,1,1,1)
  52070   S ^CHMDIC( 741002.17, DA(2),102, DA(1),25," B",$E(X,1, 30),DA)=""
  52071   "^DD",7410 02.17,7410 02.25102,. 01,1,1,2)
  52072   K ^CHMDIC( 741002.17, DA(2),102, DA(1),25," B",$E(X,1, 30),DA)
  52073   "^DD",7410 02.17,7410 02.25102,. 01,"DT")
  52074   2910913
  52075   "^DD",7410 02.17,7410 02.25102,. 02,0)
  52076   FAM DED LI MIT HIST^N J3,0^^0;2^ K:+X'=X!(X >999)!(X<0 )!(X?.E1". "1N.N) X
  52077   "^DD",7410 02.17,7410 02.25102,. 02,3)
  52078   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52079   "^DD",7410 02.17,7410 02.25102,. 02,"DT")
  52080   2910913
  52081   "^DD",7410 02.17,7410 02.25102,. 03,0)
  52082   FAM CAT CA P HIST^NJ5 ,0^^0;3^K: +X'=X!(X>9 9999)!(X<0 )!(X?.E1". "1N.N) X
  52083   "^DD",7410 02.17,7410 02.25102,. 03,3)
  52084   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  52085   "^DD",7410 02.17,7410 02.25102,. 03,"DT")
  52086   2910913
  52087   "^DD",7410 02.17,7410 02.25102,. 04,0)
  52088   BENE DED L IMIT HIST^ NJ3,0^^0;4 ^K:+X'=X!( X>999)!(X< 0)!(X?.E1" ."1N.N) X
  52089   "^DD",7410 02.17,7410 02.25102,. 04,3)
  52090   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52091   "^DD",7410 02.17,7410 02.25102,. 04,"DT")
  52092   2910913
  52093   "^DD",7410 02.17,7410 02.25102,. 05,0)
  52094   BENE CAT C AP HIST^NJ 5,0^^0;5^K :+X'=X!(X> 99999)!(X< 0)!(X?.E1" ."1N.N) X
  52095   "^DD",7410 02.17,7410 02.25102,. 05,3)
  52096   Type a Num ber betwee n 0 and 99 999, 0 Dec imal Digit s
  52097   "^DD",7410 02.17,7410 02.25102,. 05,"DT")
  52098   2910913
  52099   "^DD",7410 02.17,7410 02.25102,. 06,0)
  52100   COST SHARE  PERCENTAG E HIST^NJ3 ,0^^0;6^K: +X'=X!(X>1 00)!(X<0)! (X?.E1"."1 N.N) X
  52101   "^DD",7410 02.17,7410 02.25102,. 06,3)
  52102   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  52103   "^DD",7410 02.17,7410 02.25102,. 06,"DT")
  52104   2910913
  52105   "^DD",7410 02.17,7410 02.25102,. 07,0)
  52106   CS PER DIE M INP HIST ^NJ4,0^^0; 7^K:+X'=X! (X>9999)!( X<0)!(X?.E 1"."1N.N)  X
  52107   "^DD",7410 02.17,7410 02.25102,. 07,3)
  52108   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  52109   "^DD",7410 02.17,7410 02.25102,. 07,"DT")
  52110   2910913
  52111   "^DD",7410 02.17,7410 02.25102,. 08,0)
  52112   CS PER DIE M LVMH HIS T^NJ3,0^^0 ;8^K:+X'=X !(X>999)!( X<0)!(X?.E 1"."1N.N)  X
  52113   "^DD",7410 02.17,7410 02.25102,. 08,3)
  52114   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52115   "^DD",7410 02.17,7410 02.25102,. 08,"DT")
  52116   2910913
  52117   "^DD",7410 02.17,7410 02.25102,. 09,0)
  52118   CS PER DIE M CTC HIST ^NJ3,0^^0; 9^K:+X'=X! (X>999)!(X <0)!(X?.E1 "."1N.N) X
  52119   "^DD",7410 02.17,7410 02.25102,. 09,3)
  52120   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52121   "^DD",7410 02.17,7410 02.25102,. 09,"DT")
  52122   2910913
  52123   "^DD",7410 02.17,7410 02.25102,. 1,0)
  52124   END DATE ( DED/CS) HI ST^D^^0;10 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  52125   "^DD",7410 02.17,7410 02.25102,. 1,"DT")
  52126   2910913
  52127   "^DD",7410 02.17,7410 02.25102,. 11,0)
  52128   DUZ^P200'^ VA(200,^0; 11^Q
  52129   "^DD",7410 02.17,7410 02.25102,. 11,"DT")
  52130   2951011
  52131   "^DD",7410 02.17,7410 02.26102,0 )
  52132   BEGIN DATE  (MEI) HIS T SUB-FIEL D^^.05^5
  52133   "^DD",7410 02.17,7410 02.26102,0 ,"DT")
  52134   2951011
  52135   "^DD",7410 02.17,7410 02.26102,0 ,"IX","B", 741002.261 02,.01)
  52136  
  52137   "^DD",7410 02.17,7410 02.26102,0 ,"NM","BEG IN DATE (M EI) HIST")
  52138  
  52139   "^DD",7410 02.17,7410 02.26102,0 ,"UP")
  52140   741002.171 02
  52141   "^DD",7410 02.17,7410 02.26102,. 01,0)
  52142   BEGIN DATE  (MEI) HIS T^D^^0;1^S  %DT="EST"  D ^%DT S  X=Y K:Y<1  X
  52143   "^DD",7410 02.17,7410 02.26102,. 01,1,0)
  52144   ^.1
  52145   "^DD",7410 02.17,7410 02.26102,. 01,1,1,0)
  52146   741002.261 02^B
  52147   "^DD",7410 02.17,7410 02.26102,. 01,1,1,1)
  52148   S ^CHMDIC( 741002.17, DA(2),102, DA(1),30," B",$E(X,1, 30),DA)=""
  52149   "^DD",7410 02.17,7410 02.26102,. 01,1,1,2)
  52150   K ^CHMDIC( 741002.17, DA(2),102, DA(1),30," B",$E(X,1, 30),DA)
  52151   "^DD",7410 02.17,7410 02.26102,. 01,"DT")
  52152   2910913
  52153   "^DD",7410 02.17,7410 02.26102,. 02,0)
  52154   PRIMARY CA RE MEI HIS T^NJ5,2^^0 ;2^K:+X'=X !(X>99.99) !(X<0)!(X? .E1"."3N.N ) X
  52155   "^DD",7410 02.17,7410 02.26102,. 02,3)
  52156   Type a Num ber betwee n 0 and 99 .99, 2 Dec imal Digit s
  52157   "^DD",7410 02.17,7410 02.26102,. 02,"DT")
  52158   2910913
  52159   "^DD",7410 02.17,7410 02.26102,. 03,0)
  52160   OTHER PROF  SERVICE M EI HIST^NJ 5,2^^0;3^K :+X'=X!(X> 99.99)!(X< 0)!(X?.E1" ."3N.N) X
  52161   "^DD",7410 02.17,7410 02.26102,. 03,3)
  52162   Type a Num ber betwee n 0 and 99 .99, 2 Dec imal Digit s
  52163   "^DD",7410 02.17,7410 02.26102,. 03,"DT")
  52164   2910913
  52165   "^DD",7410 02.17,7410 02.26102,. 04,0)
  52166   END DATE ( MEI) HIST^ D^^0;4^S % DT="EST" D  ^%DT S X= Y K:Y<1 X
  52167   "^DD",7410 02.17,7410 02.26102,. 04,"DT")
  52168   2910913
  52169   "^DD",7410 02.17,7410 02.26102,. 05,0)
  52170   DUZ^P200'^ VA(200,^0; 5^Q
  52171   "^DD",7410 02.17,7410 02.26102,. 05,"DT")
  52172   2951011
  52173   "^DD",7410 02.17,7410 02.33,0)
  52174   VENDOR BAT CH REJECT  CODE SUB-F IELD^^.03^ 3
  52175   "^DD",7410 02.17,7410 02.33,0,"D DA")
  52176   N
  52177   "^DD",7410 02.17,7410 02.33,0,"D T")
  52178   2951207
  52179   "^DD",7410 02.17,7410 02.33,0,"I X","B",741 002.33,.01 )
  52180  
  52181   "^DD",7410 02.17,7410 02.33,0,"I X","C",741 002.33,.02 )
  52182  
  52183   "^DD",7410 02.17,7410 02.33,0,"N M","CHAMPV A DRG INDI CATOR")
  52184  
  52185   "^DD",7410 02.17,7410 02.33,0,"P T",741001, .18)
  52186  
  52187   "^DD",7410 02.17,7410 02.33,0,"U P")
  52188   741002.17
  52189   "^DD",7410 02.17,7410 02.33,.01, 0)
  52190   VENDOR BAT CH REJECT  CODE^F^^0; 1^K:$L(X)> 15!($L(X)< 1) X
  52191   "^DD",7410 02.17,7410 02.33,.01, 1,0)
  52192   ^.1
  52193   "^DD",7410 02.17,7410 02.33,.01, 1,1,0)
  52194   741002.33^ B
  52195   "^DD",7410 02.17,7410 02.33,.01, 1,1,1)
  52196   S ^CHMDIC( 741002.17, DA(1),700, "B",$E(X,1 ,30),DA)=" "
  52197   "^DD",7410 02.17,7410 02.33,.01, 1,1,2)
  52198   K ^CHMDIC( 741002.17, DA(1),700, "B",$E(X,1 ,30),DA)
  52199   "^DD",7410 02.17,7410 02.33,.01, 3)
  52200   Answer mus t be 1-15  characters  in length .
  52201   "^DD",7410 02.17,7410 02.33,.01, 21,0)
  52202   ^^3^3^2951 215^^^^
  52203   "^DD",7410 02.17,7410 02.33,.01, 21,1,0)
  52204   THESE CODE S WILL ORI GINATE FRO M AND BE D EALT WITH  DURING THE  PROCESSIN G OF
  52205   "^DD",7410 02.17,7410 02.33,.01, 21,2,0)
  52206   THE PROVID ER FILE UP DATE TAPES  SENT TO U S FROM BLU E CROSS/BL UE SHIELD  OF
  52207   "^DD",7410 02.17,7410 02.33,.01, 21,3,0)
  52208   SOUTH CARO LINA BEGIN NING SOMET IME IN MAY  OF '91.
  52209   "^DD",7410 02.17,7410 02.33,.01, "DT")
  52210   2951207
  52211   "^DD",7410 02.17,7410 02.33,.02, 0)
  52212   ACTIVE/INA CTIVE^S^0: ACTIVE;1:I NACTIVE;^0 ;2^Q
  52213   "^DD",7410 02.17,7410 02.33,.02, 1,0)
  52214   ^.1
  52215   "^DD",7410 02.17,7410 02.33,.02, 1,1,0)
  52216   741002.33^ C
  52217   "^DD",7410 02.17,7410 02.33,.02, 1,1,1)
  52218   S ^CHMDIC( 741002.33, "C",$E(X,1 ,30),DA)=" "
  52219   "^DD",7410 02.17,7410 02.33,.02, 1,1,2)
  52220   K ^CHMDIC( 741002.33, "C",$E(X,1 ,30),DA)
  52221   "^DD",7410 02.17,7410 02.33,.02, 1,1,"DT")
  52222   2910606
  52223   "^DD",7410 02.17,7410 02.33,.02, 3)
  52224   Answer mus t be 1 cha racter in  length.
  52225   "^DD",7410 02.17,7410 02.33,.02, "DT")
  52226   2931105
  52227   "^DD",7410 02.17,7410 02.33,.03, 0)
  52228   REJECT REA SON^F^^0;3 ^K:$L(X)>2 4!($L(X)<1 ) X
  52229   "^DD",7410 02.17,7410 02.33,.03, 3)
  52230   Answer mus t be 1-24  characters  in length .
  52231   "^DD",7410 02.17,7410 02.33,.03, "DT")
  52232   2931105
  52233   "^DD",7410 02.17,7410 02.68,0)
  52234   MCCR Q MM  RECIEPENT  SUB-FIELD^ ^.01^1
  52235   "^DD",7410 02.17,7410 02.68,0,"D T")
  52236   2991027
  52237   "^DD",7410 02.17,7410 02.68,0,"I X","B",741 002.68,.01 )
  52238  
  52239   "^DD",7410 02.17,7410 02.68,0,"N M","MCCR Q  MM RECIEP ENT")
  52240  
  52241   "^DD",7410 02.17,7410 02.68,0,"U P")
  52242   741002.17
  52243   "^DD",7410 02.17,7410 02.68,.01, 0)
  52244   MCCR Q MM  RECIEPENT^ P200'^VA(2 00,^0;1^Q
  52245   "^DD",7410 02.17,7410 02.68,.01, 1,0)
  52246   ^.1
  52247   "^DD",7410 02.17,7410 02.68,.01, 1,1,0)
  52248   741002.68^ B
  52249   "^DD",7410 02.17,7410 02.68,.01, 1,1,1)
  52250   S ^CHMDIC( 741002.17, DA(1),80," B",$E(X,1, 30),DA)=""
  52251   "^DD",7410 02.17,7410 02.68,.01, 1,1,2)
  52252   K ^CHMDIC( 741002.17, DA(1),80," B",$E(X,1, 30),DA)
  52253   "^DD",7410 02.17,7410 02.68,.01, "DT")
  52254   2991027
  52255   "^DD",7410 02.17,7410 02.69,0)
  52256   ASSIST SUR G MOD PERC ENT DATE S UB-FIELD^^ .05^5
  52257   "^DD",7410 02.17,7410 02.69,0,"D T")
  52258   2930913
  52259   "^DD",7410 02.17,7410 02.69,0,"I X","B",741 002.69,.01 )
  52260  
  52261   "^DD",7410 02.17,7410 02.69,0,"N M","ASSIST  SURG MOD  PERCENT DA TE")
  52262  
  52263   "^DD",7410 02.17,7410 02.69,0,"U P")
  52264   741002.17
  52265   "^DD",7410 02.17,7410 02.69,.01, 0)
  52266   ASSIST SUR G MOD PERC ENT DATE^M DX^^0;1^S: X'="" DINU M=X S %DT= "E" D ^%DT  S X=Y K:Y <1 X
  52267   "^DD",7410 02.17,7410 02.69,.01, 1,0)
  52268   ^.1
  52269   "^DD",7410 02.17,7410 02.69,.01, 1,1,0)
  52270   741002.69^ B
  52271   "^DD",7410 02.17,7410 02.69,.01, 1,1,1)
  52272   S ^CHMDIC( 741002.17, DA(1),50," B",$E(X,1, 30),DA)=""
  52273   "^DD",7410 02.17,7410 02.69,.01, 1,1,2)
  52274   K ^CHMDIC( 741002.17, DA(1),50," B",$E(X,1, 30),DA)
  52275   "^DD",7410 02.17,7410 02.69,.01, "DT")
  52276   2930826
  52277   "^DD",7410 02.17,7410 02.69,.02, 0)
  52278   PERCENTAGE ^NJ4,2^^0; 2^K:+X'=X! (X>1)!(X<0 )!(X?.E1". "3N.N) X
  52279   "^DD",7410 02.17,7410 02.69,.02, 3)
  52280   Type a Num ber betwee n 0 and 1,  2 Decimal  Digits
  52281   "^DD",7410 02.17,7410 02.69,.02, "DT")
  52282   2930902
  52283   "^DD",7410 02.17,7410 02.69,.03, 0)
  52284   DUZ SETTIN G USER^P3' ^DIC(3,^0; 3^Q
  52285   "^DD",7410 02.17,7410 02.69,.03, "DT")
  52286   2930826
  52287   "^DD",7410 02.17,7410 02.69,.04, 0)
  52288   DATE/TIME  SET^D^^0;4 ^S %DT="ES T" D ^%DT  S X=Y K:Y< 1 X
  52289   "^DD",7410 02.17,7410 02.69,.04, "DT")
  52290   2930826
  52291   "^DD",7410 02.17,7410 02.69,.05, 0)
  52292   REASON^P74 1002.22'^C HMDIC(7410 02.22,^0;5 ^Q
  52293   "^DD",7410 02.17,7410 02.69,.05, "DT")
  52294   2930913
  52295   "^DD",7410 02.17,7410 02.7,0)
  52296   EFFECTIVE  END DATE ( LVMH) SUB- FIELD^^.07 ^7
  52297   "^DD",7410 02.17,7410 02.7,0,"DT ")
  52298   3100322
  52299   "^DD",7410 02.17,7410 02.7,0,"IX ","B",7410 02.7,.01)
  52300  
  52301   "^DD",7410 02.17,7410 02.7,0,"NM ","EFFECTI VE END DAT E (LVMH)")
  52302  
  52303   "^DD",7410 02.17,7410 02.7,0,"UP ")
  52304   741002.17
  52305   "^DD",7410 02.17,7410 02.7,.01,0 )
  52306   EFFECTIVE  BEGIN DATE  (LVMH)^MD Xa^^0;1^S  %DT="E" D  ^%DT S X=Y  K:Y<1 X S :$D(X) DIN UM=9999999 -X
  52307   "^DD",7410 02.17,7410 02.7,.01,1 ,0)
  52308   ^.1
  52309   "^DD",7410 02.17,7410 02.7,.01,1 ,1,0)
  52310   741002.7^B
  52311   "^DD",7410 02.17,7410 02.7,.01,1 ,1,1)
  52312   S ^CHMDIC( 741002.17, DA(1),10," B",$E(X,1, 30),DA)=""
  52313   "^DD",7410 02.17,7410 02.7,.01,1 ,1,2)
  52314   K ^CHMDIC( 741002.17, DA(1),10," B",$E(X,1, 30),DA)
  52315   "^DD",7410 02.17,7410 02.7,.01,1 ,1,"DT")
  52316   2910429
  52317   "^DD",7410 02.17,7410 02.7,.01," AUDIT")
  52318   y
  52319   "^DD",7410 02.17,7410 02.7,.01," DT")
  52320   2910912
  52321   "^DD",7410 02.17,7410 02.7,.02,0 )
  52322   LABOR PERC ^NJ6,2a^^0 ;2^K:+X'=X !(X>100)!( X<0)!(X?.E 1"."3N.N)  X
  52323   "^DD",7410 02.17,7410 02.7,.02,3 )
  52324   Type a Num ber betwee n 0 and 10 0, 2 Decim al Digits
  52325   "^DD",7410 02.17,7410 02.7,.02," AUDIT")
  52326   y
  52327   "^DD",7410 02.17,7410 02.7,.02," DT")
  52328   3100322
  52329   "^DD",7410 02.17,7410 02.7,.03,0 )
  52330   EFFECTIVE  END DATE ( LVMH)^Da^^ 0;3^S %DT= "E" D ^%DT  S X=Y K:Y <1 X
  52331   "^DD",7410 02.17,7410 02.7,.03," AUDIT")
  52332   y
  52333   "^DD",7410 02.17,7410 02.7,.03," DT")
  52334   2910912
  52335   "^DD",7410 02.17,7410 02.7,.04,0 )
  52336   LABOR PERC  WI GT 1^N J6,2^^0;4^ K:+X'=X!(X >100)!(X<0 )!(X?.E1". "3N.N) X
  52337   "^DD",7410 02.17,7410 02.7,.04,3 )
  52338   Type a Num ber betwee n 0 and 10 0, 2 Decim al Digits
  52339   "^DD",7410 02.17,7410 02.7,.04," DT")
  52340   3100322
  52341   "^DD",7410 02.17,7410 02.7,.05,0 )
  52342   NON-LABOR  PERC WI GT  1^NJ6,2^^ 0;5^K:+X'= X!(X>100)! (X<0)!(X?. E1"."3N.N)  X
  52343   "^DD",7410 02.17,7410 02.7,.05,3 )
  52344   Type a Num ber betwee n 0 and 10 0, 2 Decim al Digits
  52345   "^DD",7410 02.17,7410 02.7,.05," DT")
  52346   3100322
  52347   "^DD",7410 02.17,7410 02.7,.06,0 )
  52348   LABOR PERC  WI LE 1^N J6,2^^0;6^ K:+X'=X!(X >100)!(X<0 )!(X?.E1". "3N.N) X
  52349   "^DD",7410 02.17,7410 02.7,.06,3 )
  52350   Type a Num ber betwee n 0 and 10 0, 2 Decim al Digits
  52351   "^DD",7410 02.17,7410 02.7,.06," DT")
  52352   3100322
  52353   "^DD",7410 02.17,7410 02.7,.07,0 )
  52354   NON-LABOR  PERC WI LE  1^NJ6,2^^ 0;7^K:+X'= X!(X>100)! (X<0)!(X?. E1"."3N.N)  X
  52355   "^DD",7410 02.17,7410 02.7,.07,3 )
  52356   Type a num ber betwee n 0 and 10 0, 2 decim al digits.
  52357   "^DD",7410 02.17,7410 02.7,.07," DT")
  52358   3100322
  52359   "^DD",7410 02.17,7410 02.701,0)
  52360   EFFECTIVE  END DATE ( KID ACQ) S UB-FIELD^^ .03^3
  52361   "^DD",7410 02.17,7410 02.701,0," DT")
  52362   2910912
  52363   "^DD",7410 02.17,7410 02.701,0," IX","B",74 1002.701,. 01)
  52364  
  52365   "^DD",7410 02.17,7410 02.701,0," NM","EFFEC TIVE END D ATE (KID A CQ)")
  52366  
  52367   "^DD",7410 02.17,7410 02.701,0," UP")
  52368   741002.17
  52369   "^DD",7410 02.17,7410 02.701,.01 ,0)
  52370   EFFECT BEG IN DATE (K ID ACQ)^MD Xa^^0;1^S  %DT="E" D  ^%DT S X=Y  K:Y<1 X S :$D(X) DIN UM=9999999 -X
  52371   "^DD",7410 02.17,7410 02.701,.01 ,1,0)
  52372   ^.1
  52373   "^DD",7410 02.17,7410 02.701,.01 ,1,1,0)
  52374   741002.701 ^B
  52375   "^DD",7410 02.17,7410 02.701,.01 ,1,1,1)
  52376   S ^CHMDIC( 741002.17, DA(1),15," B",$E(X,1, 30),DA)=""
  52377   "^DD",7410 02.17,7410 02.701,.01 ,1,1,2)
  52378   K ^CHMDIC( 741002.17, DA(1),15," B",$E(X,1, 30),DA)
  52379   "^DD",7410 02.17,7410 02.701,.01 ,1,1,"DT")
  52380   2910429
  52381   "^DD",7410 02.17,7410 02.701,.01 ,"AUDIT")
  52382   y
  52383   "^DD",7410 02.17,7410 02.701,.01 ,"DT")
  52384   2910912
  52385   "^DD",7410 02.17,7410 02.701,.02 ,0)
  52386   ALLOWABLE  KIDNEY ACQ  COST^NJ8, 2a^^0;2^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 9999)!(X<0 ) X
  52387   "^DD",7410 02.17,7410 02.701,.02 ,3)
  52388   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  52389   "^DD",7410 02.17,7410 02.701,.02 ,"AUDIT")
  52390   y
  52391   "^DD",7410 02.17,7410 02.701,.02 ,"DT")
  52392   2910912
  52393   "^DD",7410 02.17,7410 02.701,.03 ,0)
  52394   EFFECTIVE  END DATE ( KID ACQ)^D a^^0;3^S % DT="E" D ^ %DT S X=Y  K:Y<1 X
  52395   "^DD",7410 02.17,7410 02.701,.03 ,"AUDIT")
  52396   y
  52397   "^DD",7410 02.17,7410 02.701,.03 ,"DT")
  52398   2910912
  52399   "^DD",7410 02.17,7410 02.702,0)
  52400   EFFECTIVE  END DATE ( EDUC) SUB- FIELD^^.03 ^3
  52401   "^DD",7410 02.17,7410 02.702,0," DT")
  52402   2910429
  52403   "^DD",7410 02.17,7410 02.702,0," IX","B",74 1002.702,. 01)
  52404  
  52405   "^DD",7410 02.17,7410 02.702,0," NM","EFFEC TIVE END D ATE (EDUC) ")
  52406  
  52407   "^DD",7410 02.17,7410 02.702,0," UP")
  52408   741002.17
  52409   "^DD",7410 02.17,7410 02.702,.01 ,0)
  52410   EFFECTIVE  BEGIN DATE  (EDUC)^MD Xa^^0;1^S  %DT="E" D  ^%DT S X=Y  K:Y<1 X S :$D(X) DIN UM=9999999 -X
  52411   "^DD",7410 02.17,7410 02.702,.01 ,1,0)
  52412   ^.1
  52413   "^DD",7410 02.17,7410 02.702,.01 ,1,1,0)
  52414   741002.702 ^B
  52415   "^DD",7410 02.17,7410 02.702,.01 ,1,1,1)
  52416   S ^CHMDIC( 741002.17, DA(1),22," B",$E(X,1, 30),DA)=""
  52417   "^DD",7410 02.17,7410 02.702,.01 ,1,1,2)
  52418   K ^CHMDIC( 741002.17, DA(1),22," B",$E(X,1, 30),DA)
  52419   "^DD",7410 02.17,7410 02.702,.01 ,1,1,"DT")
  52420   2910429
  52421   "^DD",7410 02.17,7410 02.702,.01 ,"AUDIT")
  52422   y
  52423   "^DD",7410 02.17,7410 02.702,.01 ,"DT")
  52424   2910913
  52425   "^DD",7410 02.17,7410 02.702,.02 ,0)
  52426   EDUCATION  COST PERCE NTAGE^NJ3, 0a^^0;2^K: +X'=X!(X>1 00)!(X<0)! (X?.E1"."1 N.N) X
  52427   "^DD",7410 02.17,7410 02.702,.02 ,3)
  52428   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  52429   "^DD",7410 02.17,7410 02.702,.02 ,"AUDIT")
  52430   y
  52431   "^DD",7410 02.17,7410 02.702,.02 ,"DT")
  52432   2910913
  52433   "^DD",7410 02.17,7410 02.702,.03 ,0)
  52434   EFFECTIVE  END DATE ( EDUC)^Da^^ 0;3^S %DT= "E" D ^%DT  S X=Y K:Y <1 X
  52435   "^DD",7410 02.17,7410 02.702,.03 ,"AUDIT")
  52436   y
  52437   "^DD",7410 02.17,7410 02.702,.03 ,"DT")
  52438   2910913
  52439   "^DD",7410 02.17,7410 02.703,0)
  52440   EFFECTIVE  BEGIN DATE  (MEI) SUB -FIELD^^.0 4^4
  52441   "^DD",7410 02.17,7410 02.703,0," DT")
  52442   2910913
  52443   "^DD",7410 02.17,7410 02.703,0," IX","B",74 1002.703,. 01)
  52444  
  52445   "^DD",7410 02.17,7410 02.703,0," NM","EFFEC TIVE BEGIN  DATE (MEI )")
  52446  
  52447   "^DD",7410 02.17,7410 02.703,0," UP")
  52448   741002.17
  52449   "^DD",7410 02.17,7410 02.703,.01 ,0)
  52450   EFFECTIVE  BEGIN DATE  (MEI)^MDX a^^0;1^S % DT="E" D ^ %DT S X=Y  K:Y<1 X S: $D(X) DINU M=9999999- X
  52451   "^DD",7410 02.17,7410 02.703,.01 ,1,0)
  52452   ^.1
  52453   "^DD",7410 02.17,7410 02.703,.01 ,1,1,0)
  52454   741002.703 ^B
  52455   "^DD",7410 02.17,7410 02.703,.01 ,1,1,1)
  52456   S ^CHMDIC( 741002.17, DA(1),30," B",$E(X,1, 30),DA)=""
  52457   "^DD",7410 02.17,7410 02.703,.01 ,1,1,2)
  52458   K ^CHMDIC( 741002.17, DA(1),30," B",$E(X,1, 30),DA)
  52459   "^DD",7410 02.17,7410 02.703,.01 ,"AUDIT")
  52460   y
  52461   "^DD",7410 02.17,7410 02.703,.01 ,"DT")
  52462   2910913
  52463   "^DD",7410 02.17,7410 02.703,.02 ,0)
  52464   PRIMARY CA RE MEI^NJ5 ,2a^^0;2^K :+X'=X!(X> 99.99)!(X< 0)!(X?.E1" ."3N.N) X
  52465   "^DD",7410 02.17,7410 02.703,.02 ,3)
  52466   Type a Num ber betwee n 0 and 99 .99, 2 Dec imal Digit s
  52467   "^DD",7410 02.17,7410 02.703,.02 ,"AUDIT")
  52468   y
  52469   "^DD",7410 02.17,7410 02.703,.02 ,"DT")
  52470   2910913
  52471   "^DD",7410 02.17,7410 02.703,.03 ,0)
  52472   OTHER PROF ESSIONAL S ERVICE MEI ^NJ5,2a^^0 ;3^K:+X'=X !(X>99.99) !(X<0)!(X? .E1"."3N.N ) X
  52473   "^DD",7410 02.17,7410 02.703,.03 ,3)
  52474   Type a Num ber betwee n 0 and 99 .99, 2 Dec imal Digit s
  52475   "^DD",7410 02.17,7410 02.703,.03 ,"AUDIT")
  52476   y
  52477   "^DD",7410 02.17,7410 02.703,.03 ,"DT")
  52478   2910913
  52479   "^DD",7410 02.17,7410 02.703,.04 ,0)
  52480   EFFECTIVE  END DATEE  (MEI)^Da^^ 0;4^S %DT= "E" D ^%DT  S X=Y K:Y <1 X
  52481   "^DD",7410 02.17,7410 02.703,.04 ,"AUDIT")
  52482   y
  52483   "^DD",7410 02.17,7410 02.703,.04 ,"DT")
  52484   2910913
  52485   "^DD",7410 02.17,7410 02.705,0)
  52486   MM SENDEE  NAME SUB-F IELD^^.01^ 1
  52487   "^DD",7410 02.17,7410 02.705,0," DT")
  52488   2910919
  52489   "^DD",7410 02.17,7410 02.705,0," IX","B",74 1002.705,. 01)
  52490  
  52491   "^DD",7410 02.17,7410 02.705,0," NM","MM SE NDEE NAME" )
  52492  
  52493   "^DD",7410 02.17,7410 02.705,0," UP")
  52494   741002.17
  52495   "^DD",7410 02.17,7410 02.705,.01 ,0)
  52496   MM SENDEE  NAME^MP3^D IC(3,^0;1^ Q
  52497   "^DD",7410 02.17,7410 02.705,.01 ,1,0)
  52498   ^.1
  52499   "^DD",7410 02.17,7410 02.705,.01 ,1,1,0)
  52500   741002.705 ^B
  52501   "^DD",7410 02.17,7410 02.705,.01 ,1,1,1)
  52502   S ^CHMDIC( 741002.17, DA(1),400, "B",$E(X,1 ,30),DA)=" "
  52503   "^DD",7410 02.17,7410 02.705,.01 ,1,1,2)
  52504   K ^CHMDIC( 741002.17, DA(1),400, "B",$E(X,1 ,30),DA)
  52505   "^DD",7410 02.17,7410 02.705,.01 ,"DT")
  52506   2910919
  52507   "^DD",7410 02.17,7410 02.706,0)
  52508   AUSTIN MM  SENDEE NAM E SUB-FIEL D^^.01^1
  52509   "^DD",7410 02.17,7410 02.706,0," DT")
  52510   2910924
  52511   "^DD",7410 02.17,7410 02.706,0," IX","B",74 1002.706,. 01)
  52512  
  52513   "^DD",7410 02.17,7410 02.706,0," NM","AUSTI N MM SENDE E NAME")
  52514  
  52515   "^DD",7410 02.17,7410 02.706,0," UP")
  52516   741002.17
  52517   "^DD",7410 02.17,7410 02.706,.01 ,0)
  52518   AUSTIN MM  SENDEE NAM E^P3^DIC(3 ,^0;1^Q
  52519   "^DD",7410 02.17,7410 02.706,.01 ,1,0)
  52520   ^.1
  52521   "^DD",7410 02.17,7410 02.706,.01 ,1,1,0)
  52522   741002.706 ^B
  52523   "^DD",7410 02.17,7410 02.706,.01 ,1,1,1)
  52524   S ^CHMDIC( 741002.17, DA(1),500, "B",$E(X,1 ,30),DA)=" "
  52525   "^DD",7410 02.17,7410 02.706,.01 ,1,1,2)
  52526   K ^CHMDIC( 741002.17, DA(1),500, "B",$E(X,1 ,30),DA)
  52527   "^DD",7410 02.17,7410 02.706,.01 ,"DT")
  52528   2910924
  52529   "^DD",7410 02.17,7410 02.9,0)
  52530   EFFECTIVE  END DATE ( OUTLIERS)  SUB-FIELD^ ^.17^17
  52531   "^DD",7410 02.17,7410 02.9,0,"DT ")
  52532   3130903
  52533   "^DD",7410 02.17,7410 02.9,0,"IX ","B",7410 02.9,.01)
  52534  
  52535   "^DD",7410 02.17,7410 02.9,0,"NM ","EFFECTI VE END DAT E (OUTLIER S)")
  52536  
  52537   "^DD",7410 02.17,7410 02.9,0,"UP ")
  52538   741002.17
  52539   "^DD",7410 02.17,7410 02.9,.01,0 )
  52540   EFFECTIVE  BEGIN DATE  (OUTL)^MD Xa^^0;1^S  %DT="E" D  ^%DT S X=Y  K:Y<1 X S :$D(X) DIN UM=9999999 -X
  52541   "^DD",7410 02.17,7410 02.9,.01,1 ,0)
  52542   ^.1
  52543   "^DD",7410 02.17,7410 02.9,.01,1 ,1,0)
  52544   741002.9^B
  52545   "^DD",7410 02.17,7410 02.9,.01,1 ,1,1)
  52546   S ^CHMDIC( 741002.17, DA(1),20," B",$E(X,1, 30),DA)=""
  52547   "^DD",7410 02.17,7410 02.9,.01,1 ,1,2)
  52548   K ^CHMDIC( 741002.17, DA(1),20," B",$E(X,1, 30),DA)
  52549   "^DD",7410 02.17,7410 02.9,.01,1 ,1,"DT")
  52550   2910429
  52551   "^DD",7410 02.17,7410 02.9,.01," AUDIT")
  52552   y
  52553   "^DD",7410 02.17,7410 02.9,.01," DT")
  52554   2910913
  52555   "^DD",7410 02.17,7410 02.9,.02,0 )
  52556   PERCENT FO R LOS OUTL IER CHILD^ NJ3,0a^^0; 2^K:+X'=X! (X>999)!(X <0)!(X?.E1 "."1N.N) X
  52557   "^DD",7410 02.17,7410 02.9,.02,3 )
  52558   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52559   "^DD",7410 02.17,7410 02.9,.02," AUDIT")
  52560   y
  52561   "^DD",7410 02.17,7410 02.9,.02," DT")
  52562   2910913
  52563   "^DD",7410 02.17,7410 02.9,.03,0 )
  52564   PERCENT FO R LOS OUTL IER BURN^N J3,0a^^0;3 ^K:+X'=X!( X>999)!(X< 0)!(X?.E1" ."1N.N) X
  52565   "^DD",7410 02.17,7410 02.9,.03,3 )
  52566   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52567   "^DD",7410 02.17,7410 02.9,.03," AUDIT")
  52568   y
  52569   "^DD",7410 02.17,7410 02.9,.03," DT")
  52570   2910913
  52571   "^DD",7410 02.17,7410 02.9,.04,0 )
  52572   PERCENT FO R LOS OUTL IER OTHER^ NJ3,0a^^0; 4^K:+X'=X! (X>999)!(X <0)!(X?.E1 "."1N.N) X
  52573   "^DD",7410 02.17,7410 02.9,.04,3 )
  52574   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52575   "^DD",7410 02.17,7410 02.9,.04," AUDIT")
  52576   y
  52577   "^DD",7410 02.17,7410 02.9,.04," DT")
  52578   2910913
  52579   "^DD",7410 02.17,7410 02.9,.05,0 )
  52580   COST OUTLI ER CAP CHI LD^NJ8,2a^ ^0;5^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9)!(X<0) X
  52581   "^DD",7410 02.17,7410 02.9,.05,3 )
  52582   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  52583   "^DD",7410 02.17,7410 02.9,.05," AUDIT")
  52584   y
  52585   "^DD",7410 02.17,7410 02.9,.05," DT")
  52586   2910913
  52587   "^DD",7410 02.17,7410 02.9,.06,0 )
  52588   COST OUTLI ER CAP OTH ER^NJ8,2a^ ^0;6^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9)!(X<0) X
  52589   "^DD",7410 02.17,7410 02.9,.06,3 )
  52590   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  52591   "^DD",7410 02.17,7410 02.9,.06," AUDIT")
  52592   y
  52593   "^DD",7410 02.17,7410 02.9,.06," DT")
  52594   2910913
  52595   "^DD",7410 02.17,7410 02.9,.07,0 )
  52596   PERCENT CO ST OUTLIER  CHILD^NJ3 ,0a^^0;7^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X
  52597   "^DD",7410 02.17,7410 02.9,.07,3 )
  52598   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52599   "^DD",7410 02.17,7410 02.9,.07," AUDIT")
  52600   y
  52601   "^DD",7410 02.17,7410 02.9,.07," DT")
  52602   2910913
  52603   "^DD",7410 02.17,7410 02.9,.08,0 )
  52604   PERCENT CO ST OUTLIER  BURN^NJ3, 0a^^0;8^K: +X'=X!(X>9 99)!(X<0)! (X?.E1"."1 N.N) X
  52605   "^DD",7410 02.17,7410 02.9,.08,3 )
  52606   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52607   "^DD",7410 02.17,7410 02.9,.08," AUDIT")
  52608   y
  52609   "^DD",7410 02.17,7410 02.9,.08," DT")
  52610   2910913
  52611   "^DD",7410 02.17,7410 02.9,.09,0 )
  52612   PERCENT CO ST OUTLIER  OTHER^NJ3 ,0a^^0;9^K :+X'=X!(X> 999)!(X<0) !(X?.E1"." 1N.N) X
  52613   "^DD",7410 02.17,7410 02.9,.09,3 )
  52614   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52615   "^DD",7410 02.17,7410 02.9,.09," AUDIT")
  52616   y
  52617   "^DD",7410 02.17,7410 02.9,.09," DT")
  52618   2910913
  52619   "^DD",7410 02.17,7410 02.9,.1,0)
  52620   PERCENT SH ORT STAY O UTLIER^NJ3 ,0a^^0;10^ K:+X'=X!(X >999)!(X<0 )!(X?.E1". "1N.N) X
  52621   "^DD",7410 02.17,7410 02.9,.1,3)
  52622   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52623   "^DD",7410 02.17,7410 02.9,.1,"A UDIT")
  52624   y
  52625   "^DD",7410 02.17,7410 02.9,.1,"D T")
  52626   2910913
  52627   "^DD",7410 02.17,7410 02.9,.11,0 )
  52628   PERCENT TR NSF OUTLIE R NEONATE^ NJ3,0a^^0; 11^K:+X'=X !(X>999)!( X<0)!(X?.E 1"."1N.N)  X
  52629   "^DD",7410 02.17,7410 02.9,.11,3 )
  52630   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52631   "^DD",7410 02.17,7410 02.9,.11," AUDIT")
  52632   y
  52633   "^DD",7410 02.17,7410 02.9,.11," DT")
  52634   2910913
  52635   "^DD",7410 02.17,7410 02.9,.12,0 )
  52636   PERCENT TR NSF OUTLIE R OTHER^NJ 3,0a^^0;12 ^K:+X'=X!( X>999)!(X< 0)!(X?.E1" ."1N.N) X
  52637   "^DD",7410 02.17,7410 02.9,.12,3 )
  52638   Type a Num ber betwee n 0 and 99 9, 0 Decim al Digits
  52639   "^DD",7410 02.17,7410 02.9,.12," AUDIT")
  52640   y
  52641   "^DD",7410 02.17,7410 02.9,.12," DT")
  52642   2910913
  52643   "^DD",7410 02.17,7410 02.9,.13,0 )
  52644   EFFECTIVE  END DATE ( OUTLIERS)^ Da^^0;13^S  %DT="E" D  ^%DT S X= Y K:Y<1 X
  52645   "^DD",7410 02.17,7410 02.9,.13," AUDIT")
  52646   y
  52647   "^DD",7410 02.17,7410 02.9,.13," DT")
  52648   2910913
  52649   "^DD",7410 02.17,7410 02.9,.14,0 )
  52650   COST OUTLI ER CAP BUR N^NJ8,2a^^ 0;14^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9)!(X<0) X
  52651   "^DD",7410 02.17,7410 02.9,.14,3 )
  52652   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  52653   "^DD",7410 02.17,7410 02.9,.14," AUDIT")
  52654   y
  52655   "^DD",7410 02.17,7410 02.9,.14," DT")
  52656   2910913
  52657   "^DD",7410 02.17,7410 02.9,.15,0 )
  52658   C-T-C RATI O FOR COST  OUTLIERS^ NJ5,0^^0;1 5^K:+X'=X! (X>10000)! (X<999)!(X ?.E1"."1N. N) X
  52659   "^DD",7410 02.17,7410 02.9,.15,3 )
  52660   Type a num ber betwee n 999 and  10000, 0 d ecimal dig its.
  52661   "^DD",7410 02.17,7410 02.9,.15," DT")
  52662   3130903
  52663   "^DD",7410 02.17,7410 02.9,.16,0 )
  52664   CTC RATIO  CHILD HOSP  OUTLIERS^ NJ5,0^^0;1 6^K:+X'=X! (X>10000)! (X<999)!(X ?.E1"."1N. N) X
  52665   "^DD",7410 02.17,7410 02.9,.16,3 )
  52666   Type a num ber betwee n 999 and  10000, 0 d ecimal dig its.
  52667   "^DD",7410 02.17,7410 02.9,.16," DT")
  52668   3130903
  52669   "^DD",7410 02.17,7410 02.9,.17,0 )
  52670   COST OUTLI ER CLD HOS P/NEONATAL ^NJ3,0^^0; 17^K:+X'=X !(X>999)!( X<100)!(X? .E1"."1N.N ) X
  52671   "^DD",7410 02.17,7410 02.9,.17,3 )
  52672   Type a num ber betwee n 100 and  999, 0 dec imal digit s.
  52673   "^DD",7410 02.17,7410 02.9,.17,2 1,0)
  52674   ^^1^1^3130 903^
  52675   "^DD",7410 02.17,7410 02.9,.17,2 1,1,0)
  52676   CHILDREN'S  HOSPITAL  OR NEONATA L OUTLIER  ADJUSTMENT  FACTOR
  52677   "^DD",7410 02.17,7410 02.9,.17," DT")
  52678   3130903
  52679   "^DD",7410 02.17,7410 02.9001,0)
  52680   EFFECTIVE  END DATE ( CTC) SUB-F IELD^^.04^ 4
  52681   "^DD",7410 02.17,7410 02.9001,0, "DT")
  52682   2970908
  52683   "^DD",7410 02.17,7410 02.9001,0, "IX","B",7 41002.9001 ,.01)
  52684  
  52685   "^DD",7410 02.17,7410 02.9001,0, "NM","EFFE CTIVE END  DATE (CTC) ")
  52686  
  52687   "^DD",7410 02.17,7410 02.9001,0, "UP")
  52688   741002.17
  52689   "^DD",7410 02.17,7410 02.9001,.0 1,0)
  52690   EFFECTIVE  BEGIN DATE  (CTC)^MDX a^^0;1^S % DT="E" D ^ %DT S X=Y  K:Y<1 X S: $D(X) DINU M=9999999- X
  52691   "^DD",7410 02.17,7410 02.9001,.0 1,1,0)
  52692   ^.1
  52693   "^DD",7410 02.17,7410 02.9001,.0 1,1,1,0)
  52694   741002.900 1^B
  52695   "^DD",7410 02.17,7410 02.9001,.0 1,1,1,1)
  52696   S ^CHMDIC( 741002.17, DA(1),21," B",$E(X,1, 30),DA)=""
  52697   "^DD",7410 02.17,7410 02.9001,.0 1,1,1,2)
  52698   K ^CHMDIC( 741002.17, DA(1),21," B",$E(X,1, 30),DA)
  52699   "^DD",7410 02.17,7410 02.9001,.0 1,1,1,"DT" )
  52700   2910429
  52701   "^DD",7410 02.17,7410 02.9001,.0 1,"AUDIT")
  52702   y
  52703   "^DD",7410 02.17,7410 02.9001,.0 1,"DT")
  52704   2910913
  52705   "^DD",7410 02.17,7410 02.9001,.0 2,0)
  52706   CHAMPVA CT C RATIO^NJ 3,0a^^0;2^ K:+X'=X!(X >100)!(X<0 )!(X?.E1". "1N.N) X
  52707   "^DD",7410 02.17,7410 02.9001,.0 2,3)
  52708   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  52709   "^DD",7410 02.17,7410 02.9001,.0 2,"AUDIT")
  52710   y
  52711   "^DD",7410 02.17,7410 02.9001,.0 2,"DT")
  52712   2970908
  52713   "^DD",7410 02.17,7410 02.9001,.0 3,0)
  52714   EFFECTIVE  END DATE ( CTC)^Da^^0 ;3^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X
  52715   "^DD",7410 02.17,7410 02.9001,.0 3,"AUDIT")
  52716   y
  52717   "^DD",7410 02.17,7410 02.9001,.0 3,"DT")
  52718   2910913
  52719   "^DD",7410 02.17,7410 02.9001,.0 4,0)
  52720   NON-VA CTC  RATIO^NJ6 ,2a^^0;4^K :+X'=X!(X> 100)!(X<0) !(X?.E1"." 3N.N) X
  52721   "^DD",7410 02.17,7410 02.9001,.0 4,3)
  52722   Type a Num ber betwee n 0 and 10 0, 2 Decim al Digits
  52723   "^DD",7410 02.17,7410 02.9001,.0 4,"AUDIT")
  52724   y
  52725   "^DD",7410 02.17,7410 02.9001,.0 4,"DT")
  52726   2970908
  52727   "^DD",7410 02.17,7410 02.9003,0)
  52728   EFFECTIVE  END DATE ( DED/CS) SU B-FIELD^^. 1^10
  52729   "^DD",7410 02.17,7410 02.9003,0, "IX","B",7 41002.9003 ,.01)
  52730  
  52731   "^DD",7410 02.17,7410 02.9003,0, "NM","EFFE CTIVE END  DATE (DED/ CS)")
  52732  
  52733   "^DD",7410 02.17,7410 02.9003,0, "UP")
  52734   741002.17
  52735   "^DD",7410 02.17,7410 02.9003,.0 1,0)
  52736   EFFECTIVE  BEGIN DATE  (DED/CS)^ DXa^^0;1^S  %DT="E" D  ^%DT S X= Y K:Y<1 X  S:$D(X) DI NUM=999999 9-X
  52737   "^DD",7410 02.17,7410 02.9003,.0 1,1,0)
  52738   ^.1
  52739   "^DD",7410 02.17,7410 02.9003,.0 1,1,1,0)
  52740   741002.900 3^B
  52741   "^DD",7410 02.17,7410 02.9003,.0 1,1,1,1)
  52742   S ^CHMDIC( 741002.17, DA(1),25," B",$E(X,1, 30),DA)=""
  52743   "^DD",7410 02.17,7410 02.9003,.0 1,1,1,2)
  52744   K ^CHMDIC( 741002.17, DA(1),25," B",$E(X,1, 30),DA)
  52745   "^DD",7410 02.17,7410 02.9003,.0 1,"AUDIT")
  52746   y
  52747   "^DD",7410 02.17,7410 02.9003,.0 1,"DT")
  52748   2910913
  52749   "^DD",7410 02.17,7410 02.9003,.0 2,0)
  52750   FAM DED LI MIT^NJ6,2a ^^0;2^S:X[ "$" X=$P(X ,"$",2) K: X'?.N.1"." .2N!(X>999 )!(X<0) X
  52751   "^DD",7410 02.17,7410 02.9003,.0 2,3)
  52752   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  52753   "^DD",7410 02.17,7410 02.9003,.0 2,"AUDIT")
  52754   y
  52755   "^DD",7410 02.17,7410 02.9003,.0 2,"DT")
  52756   2910913
  52757   "^DD",7410 02.17,7410 02.9003,.0 3,0)
  52758   FAM CAT CA P^NJ8,2a^^ 0;3^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>99999 )!(X<0) X
  52759   "^DD",7410 02.17,7410 02.9003,.0 3,3)
  52760   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  52761   "^DD",7410 02.17,7410 02.9003,.0 3,"AUDIT")
  52762   y
  52763   "^DD",7410 02.17,7410 02.9003,.0 3,"DT")
  52764   2910913
  52765   "^DD",7410 02.17,7410 02.9003,.0 4,0)
  52766   BENE DED L IMIT^NJ6,2 a^^0;4^S:X ["$" X=$P( X,"$",2) K :X'?.N.1". ".2N!(X>99 9)!(X<0) X
  52767   "^DD",7410 02.17,7410 02.9003,.0 4,3)
  52768   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  52769   "^DD",7410 02.17,7410 02.9003,.0 4,"AUDIT")
  52770   y
  52771   "^DD",7410 02.17,7410 02.9003,.0 4,"DT")
  52772   2910913
  52773   "^DD",7410 02.17,7410 02.9003,.0 5,0)
  52774   BENE CAT C AP^NJ8,2a^ ^0;5^S:X[" $" X=$P(X, "$",2) K:X '?.N.1".". 2N!(X>9999 9)!(X<0) X
  52775   "^DD",7410 02.17,7410 02.9003,.0 5,3)
  52776   Type a Dol lar Amount  between 0  and 99999 , 2 Decima l Digits
  52777   "^DD",7410 02.17,7410 02.9003,.0 5,"AUDIT")
  52778   y
  52779   "^DD",7410 02.17,7410 02.9003,.0 5,"DT")
  52780   2910913
  52781   "^DD",7410 02.17,7410 02.9003,.0 6,0)
  52782   COST SHARE  PERCENTAG E^NJ3,0a^^ 0;6^K:+X'= X!(X>100)! (X<0)!(X?. E1"."1N.N)  X
  52783   "^DD",7410 02.17,7410 02.9003,.0 6,3)
  52784   Type a Num ber betwee n 0 and 10 0, 0 Decim al Digits
  52785   "^DD",7410 02.17,7410 02.9003,.0 6,"AUDIT")
  52786   y
  52787   "^DD",7410 02.17,7410 02.9003,.0 6,"DT")
  52788   2910913
  52789   "^DD",7410 02.17,7410 02.9003,.0 7,0)
  52790   CS PER DIE M INPATIEN T^NJ7,2a^^ 0;7^S:X["$ " X=$P(X," $",2) K:X' ?.N.1".".2 N!(X>9999) !(X<0) X
  52791   "^DD",7410 02.17,7410 02.9003,.0 7,3)
  52792   Type a Dol lar Amount  between 0  and 9999,  2 Decimal  Digits
  52793   "^DD",7410 02.17,7410 02.9003,.0 7,"AUDIT")
  52794   y
  52795   "^DD",7410 02.17,7410 02.9003,.0 7,"DT")
  52796   2910913
  52797   "^DD",7410 02.17,7410 02.9003,.0 8,0)
  52798   CS PER DIE M LVMH^NJ6 ,2a^^0;8^S :X["$" X=$ P(X,"$",2)  K:X'?.N.1 ".".2N!(X> 999)!(X<0)  X
  52799   "^DD",7410 02.17,7410 02.9003,.0 8,3)
  52800   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  52801   "^DD",7410 02.17,7410 02.9003,.0 8,"AUDIT")
  52802   y
  52803   "^DD",7410 02.17,7410 02.9003,.0 8,"DT")
  52804   2910913
  52805   "^DD",7410 02.17,7410 02.9003,.0 9,0)
  52806   CS PER DIE M CTC^NJ6, 2a^^0;9^S: X["$" X=$P (X,"$",2)  K:X'?.N.1" .".2N!(X>9 99)!(X<0)  X
  52807   "^DD",7410 02.17,7410 02.9003,.0 9,3)
  52808   Type a Dol lar Amount  between 0  and 999,  2 Decimal  Digits
  52809   "^DD",7410 02.17,7410 02.9003,.0 9,"AUDIT")
  52810   y
  52811   "^DD",7410 02.17,7410 02.9003,.0 9,"DT")
  52812   2910913
  52813   "^DD",7410 02.17,7410 02.9003,.1 ,0)
  52814   EFFECTIVE  END DATE ( DED/CS)^Da ^^0;10^S % DT="E" D ^ %DT S X=Y  K:Y<1 X
  52815   "^DD",7410 02.17,7410 02.9003,.1 ,"AUDIT")
  52816   y
  52817   "^DD",7410 02.17,7410 02.9003,.1 ,"DT")
  52818   2910913
  52819   "^DD",7410 02.17,7410 02.9004,0)
  52820   OBLIG. STA TUS ALERT  RECIPIENT  SUB-FIELD^ ^.03^3
  52821   "^DD",7410 02.17,7410 02.9004,0, "DT")
  52822   3031023
  52823   "^DD",7410 02.17,7410 02.9004,0, "IX","B",7 41002.9004 ,.01)
  52824  
  52825   "^DD",7410 02.17,7410 02.9004,0, "NM","OBLI G. STATUS  ALERT RECI PIENT")
  52826  
  52827   "^DD",7410 02.17,7410 02.9004,0, "UP")
  52828   741002.17
  52829   "^DD",7410 02.17,7410 02.9004,.0 1,0)
  52830   OBLIG. STA TUS ALERT  RECIPIENT^ MP200^VA(2 00,^0;1^Q
  52831   "^DD",7410 02.17,7410 02.9004,.0 1,1,0)
  52832   ^.1
  52833   "^DD",7410 02.17,7410 02.9004,.0 1,1,1,0)
  52834   741002.900 4^B
  52835   "^DD",7410 02.17,7410 02.9004,.0 1,1,1,1)
  52836   S ^CHMDIC( 741002.17, DA(1),300, "B",$E(X,1 ,30),DA)=" "
  52837   "^DD",7410 02.17,7410 02.9004,.0 1,1,1,2)
  52838   K ^CHMDIC( 741002.17, DA(1),300, "B",$E(X,1 ,30),DA)
  52839   "^DD",7410 02.17,7410 02.9004,.0 1,"DT")
  52840   3031023
  52841   "^DD",7410 02.17,7410 02.9004,.0 2,0)
  52842   DATE/TIME  ENTERED^D^ ^0;2^S %DT ="EST" D ^ %DT S X=Y  K:Y<1 X
  52843   "^DD",7410 02.17,7410 02.9004,.0 2,"DT")
  52844   2910320
  52845   "^DD",7410 02.17,7410 02.9004,.0 3,0)
  52846   ASSIGNING  MANAGER^P2 00'^VA(200 ,^0;3^Q
  52847   "^DD",7410 02.17,7410 02.9004,.0 3,"DT")
  52848   3031023
  52849   "^DD",7410 02.17,7410 02.9007,0)
  52850   MENTAL HEA LTH PROCS  FISCAL YR  SUB-FIELD^ ^.04^4
  52851   "^DD",7410 02.17,7410 02.9007,0, "DT")
  52852   2920330
  52853   "^DD",7410 02.17,7410 02.9007,0, "IX","B",7 41002.9007 ,.01)
  52854  
  52855   "^DD",7410 02.17,7410 02.9007,0, "NM","MENT AL HEALTH  PROCS FISC AL YR")
  52856  
  52857   "^DD",7410 02.17,7410 02.9007,0, "UP")
  52858   741002.17
  52859   "^DD",7410 02.17,7410 02.9007,.0 1,0)
  52860   MENTAL HEA LTH PROCS  CAL YR^MDX ^^0;1^S %D T="E" D ^% DT S X=Y K :Y<1 X S:$ D(X) DINUM =9999999-X
  52861   "^DD",7410 02.17,7410 02.9007,.0 1,1,0)
  52862   ^.1
  52863   "^DD",7410 02.17,7410 02.9007,.0 1,1,1,0)
  52864   741002.900 7^B
  52865   "^DD",7410 02.17,7410 02.9007,.0 1,1,1,1)
  52866   S ^CHMDIC( 741002.17, DA(1),40," B",$E(X,1, 30),DA)=""
  52867   "^DD",7410 02.17,7410 02.9007,.0 1,1,1,2)
  52868   K ^CHMDIC( 741002.17, DA(1),40," B",$E(X,1, 30),DA)
  52869   "^DD",7410 02.17,7410 02.9007,.0 1,"DT")
  52870   2920407
  52871   "^DD",7410 02.17,7410 02.9007,.0 2,0)
  52872   MH INITIAL  VISITS^RN J4,0^^0;2^ K:+X'=X!(X >9999)!(X< -9999)!(X? .E1"."1N.N ) X
  52873   "^DD",7410 02.17,7410 02.9007,.0 2,3)
  52874   Type a Num ber betwee n -9999 an d 9999, 0  Decimal Di gits
  52875   "^DD",7410 02.17,7410 02.9007,.0 2,"DT")
  52876   2920330
  52877   "^DD",7410 02.17,7410 02.9007,.0 3,0)
  52878   USER ADDIN G MH INIT  VISITS^P3' ^DIC(3,^0; 3^Q
  52879   "^DD",7410 02.17,7410 02.9007,.0 3,"DT")
  52880   2920330
  52881   "^DD",7410 02.17,7410 02.9007,.0 4,0)
  52882   DATE MH IN IT VALUE A DDED^D^^0; 4^S %DT="E " D ^%DT S  X=Y K:Y<1  X
  52883   "^DD",7410 02.17,7410 02.9007,.0 4,"DT")
  52884   2920330
  52885   "^DD",7410 02.22,7410 02.22,0)
  52886   FIELD^NL^1 .02^9
  52887   "^DD",7410 02.22,7410 02.22,0,"D DA")
  52888   N
  52889   "^DD",7410 02.22,7410 02.22,0,"D T")
  52890   3190208
  52891   "^DD",7410 02.22,7410 02.22,0,"I D",.02)
  52892   W "   ",$P (^(0),U,2)
  52893   "^DD",7410 02.22,7410 02.22,0,"I X","B",741 002.22,.01 )
  52894  
  52895   "^DD",7410 02.22,7410 02.22,0,"I X","C",741 002.22,.02 )
  52896  
  52897   "^DD",7410 02.22,7410 02.22,0,"N M","CHAMPV A STATUS R EASON DICT IONARY")
  52898  
  52899   "^DD",7410 02.22,7410 02.22,0,"P T",741000, .13)
  52900  
  52901   "^DD",7410 02.22,7410 02.22,0,"P T",741000, 120.1)
  52902  
  52903   "^DD",7410 02.22,7410 02.22,0,"P T",741000, 302.1)
  52904  
  52905   "^DD",7410 02.22,7410 02.22,0,"P T",741000. 01001,.05)
  52906  
  52907   "^DD",7410 02.22,7410 02.22,0,"P T",741000. 0203,.02)
  52908  
  52909   "^DD",7410 02.22,7410 02.22,0,"P T",741000. 0205,.02)
  52910  
  52911   "^DD",7410 02.22,7410 02.22,0,"P T",741000. 0206,30.1)
  52912  
  52913   "^DD",7410 02.22,7410 02.22,0,"P T",741000. 06,.02)
  52914  
  52915   "^DD",7410 02.22,7410 02.22,0,"P T",741000. 07,.07)
  52916  
  52917   "^DD",7410 02.22,7410 02.22,0,"P T",741000. 601101,30. 1)
  52918  
  52919   "^DD",7410 02.22,7410 02.22,0,"P T",741000. 701,.01)
  52920  
  52921   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.02)
  52922  
  52923   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.03)
  52924  
  52925   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.04)
  52926  
  52927   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.05)
  52928  
  52929   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.06)
  52930  
  52931   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.07)
  52932  
  52933   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.08)
  52934  
  52935   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.09)
  52936  
  52937   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.1)
  52938  
  52939   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.11)
  52940  
  52941   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.12)
  52942  
  52943   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.13)
  52944  
  52945   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.14)
  52946  
  52947   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.15)
  52948  
  52949   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.16)
  52950  
  52951   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.17)
  52952  
  52953   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.18)
  52954  
  52955   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.19)
  52956  
  52957   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.2)
  52958  
  52959   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.21)
  52960  
  52961   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.22)
  52962  
  52963   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.23)
  52964  
  52965   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.24)
  52966  
  52967   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.25)
  52968  
  52969   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.26)
  52970  
  52971   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.27)
  52972  
  52973   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.28)
  52974  
  52975   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.29)
  52976  
  52977   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.3)
  52978  
  52979   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.31)
  52980  
  52981   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.32)
  52982  
  52983   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.33)
  52984  
  52985   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.34)
  52986  
  52987   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.35)
  52988  
  52989   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.36)
  52990  
  52991   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.37)
  52992  
  52993   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.38)
  52994  
  52995   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.39)
  52996  
  52997   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.4)
  52998  
  52999   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.41)
  53000  
  53001   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.42)
  53002  
  53003   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.43)
  53004  
  53005   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.44)
  53006  
  53007   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.45)
  53008  
  53009   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.46)
  53010  
  53011   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.47)
  53012  
  53013   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.48)
  53014  
  53015   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.49)
  53016  
  53017   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.5)
  53018  
  53019   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.51)
  53020  
  53021   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.52)
  53022  
  53023   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.53)
  53024  
  53025   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.54)
  53026  
  53027   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,.55)
  53028  
  53029   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,1)
  53030  
  53031   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,2)
  53032  
  53033   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,2.12)
  53034  
  53035   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3)
  53036  
  53037   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.01)
  53038  
  53039   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.02)
  53040  
  53041   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.03)
  53042  
  53043   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.04)
  53044  
  53045   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.05)
  53046  
  53047   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.06)
  53048  
  53049   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.07)
  53050  
  53051   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.08)
  53052  
  53053   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.09)
  53054  
  53055   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.1)
  53056  
  53057   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.11)
  53058  
  53059   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.12)
  53060  
  53061   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.13)
  53062  
  53063   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.14)
  53064  
  53065   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.15)
  53066  
  53067   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.16)
  53068  
  53069   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.18)
  53070  
  53071   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,3.19)
  53072  
  53073   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,4)
  53074  
  53075   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 34,5)
  53076  
  53077   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 411,.01)
  53078  
  53079   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 4111,.01)
  53080  
  53081   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 4112,.01)
  53082  
  53083   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 412,.01)
  53084  
  53085   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 413,.01)
  53086  
  53087   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 414,.01)
  53088  
  53089   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 415,.01)
  53090  
  53091   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 416,.01)
  53092  
  53093   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 417,.01)
  53094  
  53095   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 418,.01)
  53096  
  53097   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 419,.01)
  53098  
  53099   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 42,.01)
  53100  
  53101   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 46,.02)
  53102  
  53103   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 53,.01)
  53104  
  53105   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 69,.05)
  53106  
  53107   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 9402,.01)
  53108  
  53109   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 9501,.01)
  53110  
  53111   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 98,.02)
  53112  
  53113   "^DD",7410 02.22,7410 02.22,0,"P T",741002. 99,.02)
  53114  
  53115   "^DD",7410 02.22,7410 02.22,0,"P T",741006, .06)
  53116  
  53117   "^DD",7410 02.22,7410 02.22,0,"P T",741009. 021,2.07)
  53118  
  53119   "^DD",7410 02.22,7410 02.22,0,"P T",741010. 1301,.01)
  53120  
  53121   "^DD",7410 02.22,7410 02.22,0,"P T",741050. 06,.01)
  53122  
  53123   "^DD",7410 02.22,7410 02.22,0,"P T",741201. 16,.05)
  53124  
  53125   "^DD",7410 02.22,7410 02.22,0,"P T",741201. 77,.01)
  53126  
  53127   "^DD",7410 02.22,7410 02.22,0,"P T",741301. 03,.01)
  53128  
  53129   "^DD",7410 02.22,7410 02.22,0,"P T",741301. 04,.01)
  53130  
  53131   "^DD",7410 02.22,7410 02.22,0,"P T",741800. 11999101,. 03)
  53132  
  53133   "^DD",7410 02.22,7410 02.22,0,"P T",741850. 0204,.01)
  53134  
  53135   "^DD",7410 02.22,7410 02.22,0,"P T",741850. 20001,.06)
  53136  
  53137   "^DD",7410 02.22,7410 02.22,0,"P T",7413000 .601101,30 .1)
  53138  
  53139   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 ,.13)
  53140  
  53141   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 ,120.1)
  53142  
  53143   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 ,302.1)
  53144  
  53145   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 .01001,.05 )
  53146  
  53147   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 .0203,.02)
  53148  
  53149   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 .0205,.02)
  53150  
  53151   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 .0206,30.1 )
  53152  
  53153   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 .06,.02)
  53154  
  53155   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 .07,.07)
  53156  
  53157   "^DD",7410 02.22,7410 02.22,0,"P T",7413001 .701,.01)
  53158  
  53159   "^DD",7410 02.22,7410 02.22,0,"V RPK")
  53160   CH
  53161   "^DD",7410 02.22,7410 02.22,.01, 0)
  53162   PROBLM STA TUS CODE^R NJ4,0X^^0; 1^K:+X'=X! (X>9999)!( X<0)!(X?.E 1"."1N.N)  X S:$D(X)  DINUM=X
  53163   "^DD",7410 02.22,7410 02.22,.01, 1,0)
  53164   ^.1
  53165   "^DD",7410 02.22,7410 02.22,.01, 1,1,0)
  53166   741002.22^ B
  53167   "^DD",7410 02.22,7410 02.22,.01, 1,1,1)
  53168   S ^CHMDIC( 741002.22, "B",$E(X,1 ,30),DA)=" "
  53169   "^DD",7410 02.22,7410 02.22,.01, 1,1,2)
  53170   K ^CHMDIC( 741002.22, "B",$E(X,1 ,30),DA)
  53171   "^DD",7410 02.22,7410 02.22,.01, 3)
  53172   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  53173   "^DD",7410 02.22,7410 02.22,.01, "DT")
  53174   2910604
  53175   "^DD",7410 02.22,7410 02.22,.02, 0)
  53176   STATUS REA SON DESCRI PTION^F^^0 ;2^K:X[""" "!($A(X)=4 5) X I $D( X) K:$L(X) >200!($L(X )<1) X
  53177   "^DD",7410 02.22,7410 02.22,.02, 1,0)
  53178   ^.1
  53179   "^DD",7410 02.22,7410 02.22,.02, 1,1,0)
  53180   741002.22^ C
  53181   "^DD",7410 02.22,7410 02.22,.02, 1,1,1)
  53182   S ^CHMDIC( 741002.22, "C",$E(X,1 ,30),DA)=" "
  53183   "^DD",7410 02.22,7410 02.22,.02, 1,1,2)
  53184   K ^CHMDIC( 741002.22, "C",$E(X,1 ,30),DA)
  53185   "^DD",7410 02.22,7410 02.22,.02, 1,1,"DT")
  53186   2910131
  53187   "^DD",7410 02.22,7410 02.22,.02, 3)
  53188   Answer mus t be 1-200  character s in lengt h.
  53189   "^DD",7410 02.22,7410 02.22,.02, "DT")
  53190   3170815
  53191   "^DD",7410 02.22,7410 02.22,.03, 0)
  53192   DEACTIVATI ON OF CODE ^S^0:ACTIV E CODE;1:N ON-ACTIVE  CODE;^0;3^ Q
  53193   "^DD",7410 02.22,7410 02.22,.03, "DT")
  53194   2920618
  53195   "^DD",7410 02.22,7410 02.22,.04, 0)
  53196   LETTER POI NTER^P7410 02.64'^CHM DIC(741002 .64,^0;4^Q
  53197   "^DD",7410 02.22,7410 02.22,.04, "DT")
  53198   2930729
  53199   "^DD",7410 02.22,7410 02.22,.05, 0)
  53200   ENCLOSURE  POINTER^P7 41002.56'^ CHMDIC(741 002.56,^0; 5^Q
  53201   "^DD",7410 02.22,7410 02.22,.05, "DT")
  53202   2930805
  53203   "^DD",7410 02.22,7410 02.22,.06, 0)
  53204   WHAT TO PR INT ON?^S^ 0:PRINT ON  EOB & PPR ;1:PRINT O N PPR ONLY ;2:PRINT O N EOB ONLY ;3:NO EOB  OR PPR;^0; 6^Q
  53205   "^DD",7410 02.22,7410 02.22,.06, "DT")
  53206   2961015
  53207   "^DD",7410 02.22,7410 02.22,.07, 0)
  53208   TYPE OF RE ASON^S^1:I NFORMATION AL;0:REJEC T;^0;7^Q
  53209   "^DD",7410 02.22,7410 02.22,.07, "DT")
  53210   2981127
  53211   "^DD",7410 02.22,7410 02.22,1.01 ,0)
  53212   CORRESPOND ENCE REASO N^F^^1;1^K :$L(X)>200 !($L(X)<1)  X
  53213   "^DD",7410 02.22,7410 02.22,1.01 ,3)
  53214   Answer mus t be 1-200  character s in lengt h.
  53215   "^DD",7410 02.22,7410 02.22,1.01 ,"DT")
  53216   2930811
  53217   "^DD",7410 02.22,7410 02.22,1.02 ,0)
  53218   PROGRAMS^7 41002.711P ^^2;0
  53219   "^DD",7410 02.22,7410 02.711,0)
  53220   PROGRAMS S UB-FIELD^^ .01^1
  53221   "^DD",7410 02.22,7410 02.711,0," DT")
  53222   2970817
  53223   "^DD",7410 02.22,7410 02.711,0," IX","B",74 1002.711,. 01)
  53224  
  53225   "^DD",7410 02.22,7410 02.711,0," NM","PROGR AMS")
  53226  
  53227   "^DD",7410 02.22,7410 02.711,0," UP")
  53228   741002.22
  53229   "^DD",7410 02.22,7410 02.711,.01 ,0)
  53230   PROGRAMS^M P741002.94 '^CHMDIC(7 41002.94,^ 0;1^Q
  53231   "^DD",7410 02.22,7410 02.711,.01 ,1,0)
  53232   ^.1
  53233   "^DD",7410 02.22,7410 02.711,.01 ,1,1,0)
  53234   741002.711 ^B
  53235   "^DD",7410 02.22,7410 02.711,.01 ,1,1,1)
  53236   S ^CHMDIC( 741002.22, DA(1),2,"B ",$E(X,1,3 0),DA)=""
  53237   "^DD",7410 02.22,7410 02.711,.01 ,1,1,2)
  53238   K ^CHMDIC( 741002.22, DA(1),2,"B ",$E(X,1,3 0),DA)
  53239   "^DD",7410 02.22,7410 02.711,.01 ,"DT")
  53240   2970817
  53241   "^DD",7412 01.15,7412 01.15,0)
  53242   FIELD^^.02 ^2
  53243   "^DD",7412 01.15,7412 01.15,0,"D DA")
  53244   N
  53245   "^DD",7412 01.15,7412 01.15,0,"D T")
  53246   2970210
  53247   "^DD",7412 01.15,7412 01.15,0,"I X","B",741 201.15,.01 )
  53248  
  53249   "^DD",7412 01.15,7412 01.15,0,"N M","CLAIM  ADJUSTMENT  GROUP COD ES (1033)" )
  53250  
  53251   "^DD",7412 01.15,7412 01.15,0,"P T",741201. 77,.02)
  53252  
  53253   "^DD",7412 01.15,7412 01.15,0,"P T",741201. 77,.04)
  53254  
  53255   "^DD",7412 01.15,7412 01.15,0,"V RPK")
  53256   CH
  53257   "^DD",7412 01.15,7412 01.15,.01, 0)
  53258   CODE^RF^^0 ;1^K:$L(X) >3!($L(X)< 1)!'(X'?1P .E) X
  53259   "^DD",7412 01.15,7412 01.15,.01, 1,0)
  53260   ^.1
  53261   "^DD",7412 01.15,7412 01.15,.01, 1,1,0)
  53262   741201.15^ B
  53263   "^DD",7412 01.15,7412 01.15,.01, 1,1,1)
  53264   S ^CHMXDIC (741201.15 ,"B",$E(X, 1,30),DA)= ""
  53265   "^DD",7412 01.15,7412 01.15,.01, 1,1,2)
  53266   K ^CHMXDIC (741201.15 ,"B",$E(X, 1,30),DA)
  53267   "^DD",7412 01.15,7412 01.15,.01, 3)
  53268   Answer mus t be 1-3 c haracters  in length.
  53269   "^DD",7412 01.15,7412 01.15,.01, "DT")
  53270   2970210
  53271   "^DD",7412 01.15,7412 01.15,.02, 0)
  53272   DESCRIPTIO N^F^^0;2^K :$L(X)>35! ($L(X)<3)  X
  53273   "^DD",7412 01.15,7412 01.15,.02, 3)
  53274   Answer mus t be 3-35  characters  in length .
  53275   "^DD",7412 01.15,7412 01.15,.02, "DT")
  53276   2970207
  53277   "^DD",7412 01.16,7412 01.16,0)
  53278   FIELD^NL^. 05^5
  53279   "^DD",7412 01.16,7412 01.16,0,"D DA")
  53280   N
  53281   "^DD",7412 01.16,7412 01.16,0,"D T")
  53282   3181214
  53283   "^DD",7412 01.16,7412 01.16,0,"I D",.02)
  53284   W "   ",$P (^(0),U,2)
  53285   "^DD",7412 01.16,7412 01.16,0,"I X","B",741 201.16,.01 )
  53286  
  53287   "^DD",7412 01.16,7412 01.16,0,"I X","C",741 201.16,.05 )
  53288  
  53289   "^DD",7412 01.16,7412 01.16,0,"N M","CLAIM  ADJUSTMENT  REASON CO DES (1034) ")
  53290  
  53291   "^DD",7412 01.16,7412 01.16,0,"P T",741201. 77,.03)
  53292  
  53293   "^DD",7412 01.16,7412 01.16,0,"P T",741201. 77,.05)
  53294  
  53295   "^DD",7412 01.16,7412 01.16,0,"V RPK")
  53296   CH
  53297   "^DD",7412 01.16,7412 01.16,.01, 0)
  53298   CODE^RF^^0 ;1^K:$L(X) >4!($L(X)< 1)!'(X'?1P .E) X
  53299   "^DD",7412 01.16,7412 01.16,.01, 1,0)
  53300   ^.1^^-1
  53301   "^DD",7412 01.16,7412 01.16,.01, 1,1,0)
  53302   741201.16^ B
  53303   "^DD",7412 01.16,7412 01.16,.01, 1,1,1)
  53304   S ^CHMXDIC (741201.16 ,"B",$E(X, 1,30),DA)= ""
  53305   "^DD",7412 01.16,7412 01.16,.01, 1,1,2)
  53306   K ^CHMXDIC (741201.16 ,"B",$E(X, 1,30),DA)
  53307   "^DD",7412 01.16,7412 01.16,.01, 3)
  53308   Answer mus t be 1-4 c haracters  in length.
  53309   "^DD",7412 01.16,7412 01.16,.01, "DT")
  53310   3170815
  53311   "^DD",7412 01.16,7412 01.16,.02, 0)
  53312   DESCRIPTIO N^F^^0;2^K :$L(X)>225 !($L(X)<5)  X
  53313   "^DD",7412 01.16,7412 01.16,.02, 3)
  53314   Answer mus t be 5-225  character s in lengt h.
  53315   "^DD",7412 01.16,7412 01.16,.02, "DT")
  53316   3170831
  53317   "^DD",7412 01.16,7412 01.16,.03, 0)
  53318   ACTIVE STA RT DATE^D^ ^0;3^S %DT ="E" D ^%D T S X=Y K: X<1 X
  53319   "^DD",7412 01.16,7412 01.16,.03, .1)
  53320  
  53321   "^DD",7412 01.16,7412 01.16,.03, 1,0)
  53322   ^.1^^0
  53323   "^DD",7412 01.16,7412 01.16,.03, 3)
  53324   Enter the  date this  code becom es active
  53325   "^DD",7412 01.16,7412 01.16,.03, 21,0)
  53326   ^^1^1^3181 214^
  53327   "^DD",7412 01.16,7412 01.16,.03, 21,1,0)
  53328   This is th e date the  Claim Adj ustment Re ason Code  becomes ac tive.
  53329   "^DD",7412 01.16,7412 01.16,.03, "DT")
  53330   3181214
  53331   "^DD",7412 01.16,7412 01.16,.04, 0)
  53332   ACTIVE END  DATE^D^^0 ;4^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X
  53333   "^DD",7412 01.16,7412 01.16,.04, 3)
  53334   Enter the  date this  code is no  longer ac tive
  53335   "^DD",7412 01.16,7412 01.16,.04, 21,0)
  53336   ^^1^1^3150 818^
  53337   "^DD",7412 01.16,7412 01.16,.04, 21,1,0)
  53338   This is th e date the  Claim Adj ustment Re ason Code  is no long er active.
  53339   "^DD",7412 01.16,7412 01.16,.04, "DT")
  53340   3150818
  53341   "^DD",7412 01.16,7412 01.16,.05, 0)
  53342   PR DENIAL  REASON^*P7 41002.22'^ CHMDIC(741 002.22,^0; 5^S DIC("S ")="I $P(^ (0),U,3)'= 1" D ^DIC  K DIC S DI C=$G(DIE), X=+Y K:Y<0  X
  53343   "^DD",7412 01.16,7412 01.16,.05, 1,0)
  53344   ^.1
  53345   "^DD",7412 01.16,7412 01.16,.05, 1,1,0)
  53346   741201.16^ C^MUMPS
  53347   "^DD",7412 01.16,7412 01.16,.05, 1,1,1)
  53348   S ^CHMXDIC (741201.16 ,"AD",DA,$ E(X,1,30)) =""
  53349   "^DD",7412 01.16,7412 01.16,.05, 1,1,2)
  53350   K ^CHMXDIC (741201.16 ,"AD",DA,$ E(X,1,30))
  53351   "^DD",7412 01.16,7412 01.16,.05, 1,1,"%D",0 )
  53352   ^^2^2^3181 214^
  53353   "^DD",7412 01.16,7412 01.16,.05, 1,1,"%D",1 ,0)
  53354   This cross -reference  is used t o identify  CARCs to  deny when  used with  PR
  53355   "^DD",7412 01.16,7412 01.16,.05, 1,1,"%D",2 ,0)
  53356   (Patient R esponsibil ity).
  53357   "^DD",7412 01.16,7412 01.16,.05, 1,1,"DT")
  53358   3181214
  53359   "^DD",7412 01.16,7412 01.16,.05, 3)
  53360   Enter a PR  denial re ason, if a pplicable.
  53361   "^DD",7412 01.16,7412 01.16,.05, 12)
  53362   Non-Active  Codes are  not allow ed.
  53363   "^DD",7412 01.16,7412 01.16,.05, 12.1)
  53364   S DIC("S") ="I $P(^(0 ),U,3)'=1"
  53365   "^DD",7412 01.16,7412 01.16,.05, 21,0)
  53366   ^^3^3^3181 214^
  53367   "^DD",7412 01.16,7412 01.16,.05, 21,1,0)
  53368   If this CA RC code is  used with  a group c ode of PR  (Patient R esponsibil ity)
  53369   "^DD",7412 01.16,7412 01.16,.05, 21,2,0)
  53370   and a deni al reason  is entered , this por tion of th e PR will  not be pai d on
  53371   "^DD",7412 01.16,7412 01.16,.05, 21,3,0)
  53372   the claim.
  53373   "^DD",7412 01.16,7412 01.16,.05, "DT")
  53374   3181214
  53375   "^DD",7412 01.32,7412 01.32,0)
  53376   FIELD^^101 ^14
  53377   "^DD",7412 01.32,7412 01.32,0,"D DA")
  53378   N
  53379   "^DD",7412 01.32,7412 01.32,0,"D T")
  53380   3000707
  53381   "^DD",7412 01.32,7412 01.32,0,"I X","B",741 201.32,.01 )
  53382  
  53383   "^DD",7412 01.32,7412 01.32,0,"N M","HAC ED I 837 ERRO R CODES (H AC)")
  53384  
  53385   "^DD",7412 01.32,7412 01.32,0,"P T",741210. 06101,.01)
  53386  
  53387   "^DD",7412 01.32,7412 01.32,0,"P T",741210. 08101,.01)
  53388  
  53389   "^DD",7412 01.32,7412 01.32,0,"P T",741210. 1101,.01)
  53390  
  53391   "^DD",7412 01.32,7412 01.32,0,"P T",741210. 12101,.01)
  53392  
  53393   "^DD",7412 01.32,7412 01.32,0,"P T",741210. 1249,.01)
  53394  
  53395   "^DD",7412 01.32,7412 01.32,0,"P T",741210. 14101,.01)
  53396  
  53397   "^DD",7412 01.32,7412 01.32,0,"P T",741210. 8102,.01)
  53398  
  53399   "^DD",7412 01.32,7412 01.32,0,"V RPK")
  53400   CH
  53401   "^DD",7412 01.32,7412 01.32,.01, 0)
  53402   ERROR CODE ^RF^^0;1^K :$L(X)>15! ($L(X)<1)! '(X'?1P.E)  X
  53403   "^DD",7412 01.32,7412 01.32,.01, 1,0)
  53404   ^.1
  53405   "^DD",7412 01.32,7412 01.32,.01, 1,1,0)
  53406   741201.32^ B
  53407   "^DD",7412 01.32,7412 01.32,.01, 1,1,1)
  53408   S ^CHMXDIC (741201.32 ,"B",$E(X, 1,30),DA)= ""
  53409   "^DD",7412 01.32,7412 01.32,.01, 1,1,2)
  53410   K ^CHMXDIC (741201.32 ,"B",$E(X, 1,30),DA)
  53411   "^DD",7412 01.32,7412 01.32,.01, 3)
  53412   Answer mus t be 1-15  characters  in length .
  53413   "^DD",7412 01.32,7412 01.32,.01, "DT")
  53414   2970821
  53415   "^DD",7412 01.32,7412 01.32,.02, 0)
  53416   ERROR MESS AGE^F^^0;2 ^K:$L(X)>8 0!($L(X)<5 ) X
  53417   "^DD",7412 01.32,7412 01.32,.02, 3)
  53418   Answer mus t be 5-80  characters  in length .
  53419   "^DD",7412 01.32,7412 01.32,.02, "DT")
  53420   2980123
  53421   "^DD",7412 01.32,7412 01.32,.03, 0)
  53422   MESSAGING  TEXT^F^^0; 3^K:$L(X)> 60!($L(X)< 5) X
  53423   "^DD",7412 01.32,7412 01.32,.03, 3)
  53424   Answer mus t be 5-60  characters  in length .
  53425   "^DD",7412 01.32,7412 01.32,.03, 21,0)
  53426   ^^1^1^2970 206^
  53427   "^DD",7412 01.32,7412 01.32,.03, 21,1,0)
  53428   Text used  in email m essages re garding 83 7 processi ng.
  53429   "^DD",7412 01.32,7412 01.32,.03, "DT")
  53430   2970206
  53431   "^DD",7412 01.32,7412 01.32,.04, 0)
  53432   X12 277 1S T STATUS C OMPOSITE^F ^^0;4^K:$L (X)>24!($L (X)<2) X
  53433   "^DD",7412 01.32,7412 01.32,.04, 3)
  53434   Answer mus t be 2-24  characters  in length .
  53435   "^DD",7412 01.32,7412 01.32,.04, "DT")
  53436   2970711
  53437   "^DD",7412 01.32,7412 01.32,.05, 0)
  53438   X12 277 2N D STATUS C OMPOSITE^F ^^0;5^K:$L (X)>24!($L (X)<2) X
  53439   "^DD",7412 01.32,7412 01.32,.05, 3)
  53440   Answer mus t be 2-24  characters  in length .
  53441   "^DD",7412 01.32,7412 01.32,.05, "DT")
  53442   2970711
  53443   "^DD",7412 01.32,7412 01.32,.06, 0)
  53444   X12 277 3R D STATUS C OMPOSITE^F ^^0;6^K:$L (X)>24!($L (X)<2) X
  53445   "^DD",7412 01.32,7412 01.32,.06, 3)
  53446   Answer mus t be 2-24  characters  in length .
  53447   "^DD",7412 01.32,7412 01.32,.06, "DT")
  53448   2970711
  53449   "^DD",7412 01.32,7412 01.32,1.01 ,0)
  53450   HELP MESSA GE TYPE^RS ^1:PRESENC E;2:PRESEN CE/FORMAT; 3:PRESENCE /CODE;4:PR ESENCE/FUT URE DT;5:P RESENCE/DA TE;6:PRESE NCE/HOUR;7 :FORMAT;8: CODE;9:FUT URE DT;10: DATE;11:HO UR;12:PRES ENCE/HC CO DE;13:HC C ODE;14:SPE CIAL;15:PR ESENCE/VAL ID;16:BLAN K;17:NIL;^ 1;1^Q
  53451   "^DD",7412 01.32,7412 01.32,1.01 ,"DT")
  53452   3000707
  53453   "^DD",7412 01.32,7412 01.32,1.02 ,0)
  53454   FILE REF F OR CODE LI ST^F^^1;2^ K:$L(X)>25 !($L(X)<3)  X
  53455   "^DD",7412 01.32,7412 01.32,1.02 ,3)
  53456   Answer mus t be 3-25  characters  in length .
  53457   "^DD",7412 01.32,7412 01.32,1.02 ,"DT")
  53458   3000629
  53459   "^DD",7412 01.32,7412 01.32,1.03 ,0)
  53460   SUBSCRIPT^ F^^1;3^K:$ L(X)>10!($ L(X)<1) X
  53461   "^DD",7412 01.32,7412 01.32,1.03 ,3)
  53462   Answer mus t be 1-10  characters  in length .
  53463   "^DD",7412 01.32,7412 01.32,1.03 ,"DT")
  53464   3000629
  53465   "^DD",7412 01.32,7412 01.32,1.04 ,0)
  53466   PIECE^NJ4, 0^^1;4^K:+ X'=X!(X>99 99)!(X<0)! (X?.E1"."1 N.N) X
  53467   "^DD",7412 01.32,7412 01.32,1.04 ,3)
  53468   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  53469   "^DD",7412 01.32,7412 01.32,1.04 ,"DT")
  53470   3000629
  53471   "^DD",7412 01.32,7412 01.32,1.05 ,0)
  53472   FORMAT TEX T^F^^1;5^K :$L(X)>45! ($L(X)<5)  X
  53473   "^DD",7412 01.32,7412 01.32,1.05 ,3)
  53474   Answer mus t be 5-45  characters  in length .
  53475   "^DD",7412 01.32,7412 01.32,1.05 ,"DT")
  53476   3000629
  53477   "^DD",7412 01.32,7412 01.32,1.06 ,0)
  53478   LINE TAG^F ^^1;6^K:$L (X)>10!($L (X)<3) X
  53479   "^DD",7412 01.32,7412 01.32,1.06 ,3)
  53480   Answer mus t be 3-10  characters  in length .
  53481   "^DD",7412 01.32,7412 01.32,1.06 ,"DT")
  53482   3000705
  53483   "^DD",7412 01.32,7412 01.32,1.07 ,0)
  53484   ROUTINE^F^ ^1;7^K:$L( X)>8!($L(X )<3) X
  53485   "^DD",7412 01.32,7412 01.32,1.07 ,3)
  53486   Answer mus t be 3-8 c haracters  in length.
  53487   "^DD",7412 01.32,7412 01.32,1.07 ,"DT")
  53488   3000705
  53489   "^DD",7412 01.32,7412 01.32,101, 0)
  53490   HELP TEXT  MESSAGES^7 41201.3210 1^^101;0
  53491   "^DD",7412 01.32,7412 01.32101,0 )
  53492   HELP TEXT  MESSAGES S UB-FIELD^^ .01^1
  53493   "^DD",7412 01.32,7412 01.32101,0 ,"DT")
  53494   3000629
  53495   "^DD",7412 01.32,7412 01.32101,0 ,"NM","HEL P TEXT MES SAGES")
  53496  
  53497   "^DD",7412 01.32,7412 01.32101,0 ,"UP")
  53498   741201.32
  53499   "^DD",7412 01.32,7412 01.32101,. 01,0)
  53500   HELP TEXT  MESSAGES^W ^^0;1^Q
  53501   "^DD",7412 01.32,7412 01.32101,. 01,"DT")
  53502   3000629
  53503   "^DD",7412 01.58,7412 01.58,0)
  53504   FIELD^^100 ^6
  53505   "^DD",7412 01.58,7412 01.58,0,"D DA")
  53506   N
  53507   "^DD",7412 01.58,7412 01.58,0,"D T")
  53508   3190208
  53509   "^DD",7412 01.58,7412 01.58,0,"I X","B",741 201.58,.01 )
  53510  
  53511   "^DD",7412 01.58,7412 01.58,0,"N M","CLAIM  PAYMENT RE MARK CODES  (127)")
  53512  
  53513   "^DD",7412 01.58,7412 01.58,0,"P T",741201. 77,.06)
  53514  
  53515   "^DD",7412 01.58,7412 01.58,0,"P T",741201. 77,.07)
  53516  
  53517   "^DD",7412 01.58,7412 01.58,0,"V RPK")
  53518   CH
  53519   "^DD",7412 01.58,7412 01.58,.01, 0)
  53520   CLAIM PAYM ENT REMARK  CODE^RF^^ 0;1^K:$L(X )>5!($L(X) <2)!'(X'?1 P.E) X
  53521   "^DD",7412 01.58,7412 01.58,.01, 1,0)
  53522   ^.1
  53523   "^DD",7412 01.58,7412 01.58,.01, 1,1,0)
  53524   741201.58^ B
  53525   "^DD",7412 01.58,7412 01.58,.01, 1,1,1)
  53526   S ^CHMXDIC (741201.58 ,"B",$E(X, 1,30),DA)= ""
  53527   "^DD",7412 01.58,7412 01.58,.01, 1,1,2)
  53528   K ^CHMXDIC (741201.58 ,"B",$E(X, 1,30),DA)
  53529   "^DD",7412 01.58,7412 01.58,.01, 3)
  53530   Answer mus t be 2-5 c haracters  in length
  53531   "^DD",7412 01.58,7412 01.58,.01, "DT")
  53532   3011113
  53533   "^DD",7412 01.58,7412 01.58,.02, 0)
  53534   DESCRIPTIO N^F^^0;2^K :$L(X)>225 !($L(X)<1)  X
  53535   "^DD",7412 01.58,7412 01.58,.02, 3)
  53536   Answer mus t be 1-225  character s in lengt h.
  53537   "^DD",7412 01.58,7412 01.58,.02, "DT")
  53538   3090318
  53539   "^DD",7412 01.58,7412 01.58,.03, 0)
  53540   STATUS^S^0 :NOT ACTIV E;1:ACTIVE ;^0;3^Q
  53541   "^DD",7412 01.58,7412 01.58,.03, "DT")
  53542   3020813
  53543   "^DD",7412 01.58,7412 01.58,.04, 0)
  53544   ACTIVE STA RT DATE^D^ ^0;4^S %DT ="E" D ^%D T S X=Y K: Y<1 X
  53545   "^DD",7412 01.58,7412 01.58,.04, 3)
  53546   Enter the  date this  code becom es active.
  53547   "^DD",7412 01.58,7412 01.58,.04, 21,0)
  53548   ^^1^1^3150 827^
  53549   "^DD",7412 01.58,7412 01.58,.04, 21,1,0)
  53550   This is th e date the  Claim Pay ment Remar k Code bec omes Activ e.
  53551   "^DD",7412 01.58,7412 01.58,.04, "DT")
  53552   3150827
  53553   "^DD",7412 01.58,7412 01.58,.05, 0)
  53554   ACTIVE END  DATE^D^^0 ;5^S %DT=" E" D ^%DT  S X=Y K:Y< 1 X
  53555   "^DD",7412 01.58,7412 01.58,.05, 3)
  53556   Enter the  date this  code is no  longer ac tive.
  53557   "^DD",7412 01.58,7412 01.58,.05, 21,0)
  53558   ^^1^1^3150 827^
  53559   "^DD",7412 01.58,7412 01.58,.05, 21,1,0)
  53560   This is th e date the  Claim Pay ment Remar k Code is  no longer  active.
  53561   "^DD",7412 01.58,7412 01.58,.05, "DT")
  53562   3150827
  53563   "^DD",7412 01.58,7412 01.58,100, 0)
  53564   DATE-RELAT ED DESCRIP TION^74120 1.701D^^10 0;0
  53565   "^DD",7412 01.58,7412 01.58,100, "DT")
  53566   3031003
  53567   "^DD",7412 01.58,7412 01.701,0)
  53568   DATE-RELAT ED DESCRIP TION SUB-F IELD^^.03^ 3
  53569   "^DD",7412 01.58,7412 01.701,0," DT")
  53570   3090318
  53571   "^DD",7412 01.58,7412 01.701,0," IX","B",74 1201.701,. 01)
  53572  
  53573   "^DD",7412 01.58,7412 01.701,0," NM","DATE- RELATED DE SCRIPTION" )
  53574  
  53575   "^DD",7412 01.58,7412 01.701,0," UP")
  53576   741201.58
  53577   "^DD",7412 01.58,7412 01.701,.01 ,0)
  53578   DATE FOR D ESCRIPTION ^RD^^0;1^S  %DT="EX"  D ^%DT S X =Y K:Y<1 X
  53579   "^DD",7412 01.58,7412 01.701,.01 ,1,0)
  53580   ^.1
  53581   "^DD",7412 01.58,7412 01.701,.01 ,1,1,0)
  53582   741201.701 ^B
  53583   "^DD",7412 01.58,7412 01.701,.01 ,1,1,1)
  53584   S ^CHMXDIC (741201.58 ,DA(1),100 ,"B",$E(X, 1,30),DA)= ""
  53585   "^DD",7412 01.58,7412 01.701,.01 ,1,1,2)
  53586   K ^CHMXDIC (741201.58 ,DA(1),100 ,"B",$E(X, 1,30),DA)
  53587   "^DD",7412 01.58,7412 01.701,.01 ,"DT")
  53588   3031003
  53589   "^DD",7412 01.58,7412 01.701,.02 ,0)
  53590   CODE DESCR IPTION^F^^ 0;2^K:$L(X )>225!($L( X)<1) X
  53591   "^DD",7412 01.58,7412 01.701,.02 ,3)
  53592   Answer mus t be 1-225  character s in lengt h.
  53593   "^DD",7412 01.58,7412 01.701,.02 ,"DT")
  53594   3090318
  53595   "^DD",7412 01.58,7412 01.701,.03 ,0)
  53596   END DATE F OR DESCRIP TION^D^^0; 3^S %DT="E X" D ^%DT  S X=Y K:Y< 1 X
  53597   "^DD",7412 01.58,7412 01.701,.03 ,"DT")
  53598   3031003
  53599   "^DD",7412 01.77,7412 01.77,0)
  53600   FIELD^^1.0 1^10
  53601   "^DD",7412 01.77,7412 01.77,0,"D T")
  53602   3190208
  53603   "^DD",7412 01.77,7412 01.77,0,"I X","B",741 201.77,.01 )
  53604  
  53605   "^DD",7412 01.77,7412 01.77,0,"I X","C",741 201.77,.03 )
  53606  
  53607   "^DD",7412 01.77,7412 01.77,0,"I X","D",741 201.77,.05 )
  53608  
  53609   "^DD",7412 01.77,7412 01.77,0,"I X","E",741 201.77,.06 )
  53610  
  53611   "^DD",7412 01.77,7412 01.77,0,"I X","F",741 201.77,.07 )
  53612  
  53613   "^DD",7412 01.77,7412 01.77,0,"I X","G",741 201.77,.08 )
  53614  
  53615   "^DD",7412 01.77,7412 01.77,0,"I X","H",741 201.77,.09 )
  53616  
  53617   "^DD",7412 01.77,7412 01.77,0,"N M","EOB RE ASON/X12 C ROSS WALK" )
  53618  
  53619   "^DD",7412 01.77,7412 01.77,0,"V RPK")
  53620   CH
  53621   "^DD",7412 01.77,7412 01.77,.01, 0)
  53622   HAC REASON  CODE^RP74 1002.22^CH MDIC(74100 2.22,^0;1^ Q
  53623   "^DD",7412 01.77,7412 01.77,.01, 1,0)
  53624   ^.1
  53625   "^DD",7412 01.77,7412 01.77,.01, 1,1,0)
  53626   741201.77^ B
  53627   "^DD",7412 01.77,7412 01.77,.01, 1,1,1)
  53628   S ^CHMXDIC (741201.77 ,"B",$E(X, 1,30),DA)= ""
  53629   "^DD",7412 01.77,7412 01.77,.01, 1,1,2)
  53630   K ^CHMXDIC (741201.77 ,"B",$E(X, 1,30),DA)
  53631   "^DD",7412 01.77,7412 01.77,.01, 3)
  53632  
  53633   "^DD",7412 01.77,7412 01.77,.01, "DT")
  53634   3030814
  53635   "^DD",7412 01.77,7412 01.77,.02, 0)
  53636   CLAIM ADJ  GRP CODE 1 ^P741201.1 5'^CHMXDIC (741201.15 ,^0;2^Q
  53637   "^DD",7412 01.77,7412 01.77,.02, "DT")
  53638   3030814
  53639   "^DD",7412 01.77,7412 01.77,.03, 0)
  53640   CLAIM ADJ  RSN CODE 1 ^P741201.1 6'^CHMXDIC (741201.16 ,^0;3^Q
  53641   "^DD",7412 01.77,7412 01.77,.03, 1,0)
  53642   ^.1
  53643   "^DD",7412 01.77,7412 01.77,.03, 1,1,0)
  53644   741201.77^ C^MUMPS
  53645   "^DD",7412 01.77,7412 01.77,.03, 1,1,1)
  53646   S ^CHMXDIC (741201.77 ,"C",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)=""
  53647   "^DD",7412 01.77,7412 01.77,.03, 1,1,2)
  53648   K ^CHMXDIC (741201.77 ,"C",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)
  53649   "^DD",7412 01.77,7412 01.77,.03, 1,1,"DT")
  53650   3030814
  53651   "^DD",7412 01.77,7412 01.77,.03, "DT")
  53652   3030814
  53653   "^DD",7412 01.77,7412 01.77,.04, 0)
  53654   CLAIM ADJ  GRP CODE 2 ^P741201.1 5'^CHMXDIC (741201.15 ,^0;4^Q
  53655   "^DD",7412 01.77,7412 01.77,.04, "DT")
  53656   3030814
  53657   "^DD",7412 01.77,7412 01.77,.05, 0)
  53658   CLAIM ADJ  RSN CODE 2 ^P741201.1 6'^CHMXDIC (741201.16 ,^0;5^Q
  53659   "^DD",7412 01.77,7412 01.77,.05, 1,0)
  53660   ^.1
  53661   "^DD",7412 01.77,7412 01.77,.05, 1,1,0)
  53662   741201.77^ D^MUMPS
  53663   "^DD",7412 01.77,7412 01.77,.05, 1,1,1)
  53664   S ^CHMXDIC (741201.77 ,"D",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)=""
  53665   "^DD",7412 01.77,7412 01.77,.05, 1,1,2)
  53666   K ^CHMXDIC (741201.77 ,"D",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)
  53667   "^DD",7412 01.77,7412 01.77,.05, 1,1,"DT")
  53668   3030814
  53669   "^DD",7412 01.77,7412 01.77,.05, "DT")
  53670   3030814
  53671   "^DD",7412 01.77,7412 01.77,.06, 0)
  53672   CLAIM REMA RK CODE 1^ P741201.58 '^CHMXDIC( 741201.58, ^0;6^Q
  53673   "^DD",7412 01.77,7412 01.77,.06, 1,0)
  53674   ^.1
  53675   "^DD",7412 01.77,7412 01.77,.06, 1,1,0)
  53676   741201.77^ E^MUMPS
  53677   "^DD",7412 01.77,7412 01.77,.06, 1,1,1)
  53678   S ^CHMXDIC (741201.77 ,"E",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)=""
  53679   "^DD",7412 01.77,7412 01.77,.06, 1,1,2)
  53680   K ^CHMXDIC (741201.77 ,"E",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)
  53681   "^DD",7412 01.77,7412 01.77,.06, 1,1,"DT")
  53682   3030814
  53683   "^DD",7412 01.77,7412 01.77,.06, "DT")
  53684   3030814
  53685   "^DD",7412 01.77,7412 01.77,.07, 0)
  53686   CLAIM REMA RK CODE 2^ P741201.58 '^CHMXDIC( 741201.58, ^0;7^Q
  53687   "^DD",7412 01.77,7412 01.77,.07, 1,0)
  53688   ^.1
  53689   "^DD",7412 01.77,7412 01.77,.07, 1,1,0)
  53690   741201.77^ F^MUMPS
  53691   "^DD",7412 01.77,7412 01.77,.07, 1,1,1)
  53692   S ^CHMXDIC (741201.77 ,"F",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)=""
  53693   "^DD",7412 01.77,7412 01.77,.07, 1,1,2)
  53694   K ^CHMXDIC (741201.77 ,"F",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)
  53695   "^DD",7412 01.77,7412 01.77,.07, 1,1,"DT")
  53696   3030814
  53697   "^DD",7412 01.77,7412 01.77,.07, "DT")
  53698   3030814
  53699   "^DD",7412 01.77,7412 01.77,.08, 0)
  53700   NCPDP REJE CT CODE #1 ^P741201.7 9'^CHMXDIC (741201.79 ,^0;8^Q
  53701   "^DD",7412 01.77,7412 01.77,.08, 1,0)
  53702   ^.1
  53703   "^DD",7412 01.77,7412 01.77,.08, 1,1,0)
  53704   741201.77^ G^MUMPS
  53705   "^DD",7412 01.77,7412 01.77,.08, 1,1,1)
  53706   S ^CHMXDIC (741201.77 ,"G",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)=""
  53707   "^DD",7412 01.77,7412 01.77,.08, 1,1,2)
  53708   K ^CHMXDIC (741201.77 ,"G",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)
  53709   "^DD",7412 01.77,7412 01.77,.08, 1,1,"DT")
  53710   3030922
  53711   "^DD",7412 01.77,7412 01.77,.08, "DT")
  53712   3030925
  53713   "^DD",7412 01.77,7412 01.77,.09, 0)
  53714   NCPDP REJE CT CODE #2 ^P741201.7 9'^CHMXDIC (741201.79 ,^0;9^Q
  53715   "^DD",7412 01.77,7412 01.77,.09, 1,0)
  53716   ^.1
  53717   "^DD",7412 01.77,7412 01.77,.09, 1,1,0)
  53718   741201.77^ H^MUMPS
  53719   "^DD",7412 01.77,7412 01.77,.09, 1,1,1)
  53720   S ^CHMXDIC (741201.77 ,"H",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)=""
  53721   "^DD",7412 01.77,7412 01.77,.09, 1,1,2)
  53722   K ^CHMXDIC (741201.77 ,"H",X,$P( ^CHMXDIC(7 41201.77,D A,0),U,1), DA)
  53723   "^DD",7412 01.77,7412 01.77,.09, 1,1,"DT")
  53724   3030922
  53725   "^DD",7412 01.77,7412 01.77,.09, "DT")
  53726   3030925
  53727   "^DD",7412 01.77,7412 01.77,1.01 ,0)
  53728   DATE OF LA ST UPDATE^ D^^1;1^S % DT="E" D ^ %DT S X=Y  K:Y<1 X
  53729   "^DD",7412 01.77,7412 01.77,1.01 ,"DT")
  53730   3030814
  53731   "^DD",7412 11.03,7412 11.03,0)
  53732   FIELD^^.06 ^23
  53733   "^DD",7412 11.03,7412 11.03,0,"D T")
  53734   3111110
  53735   "^DD",7412 11.03,7412 11.03,0,"I X","B",741 211.03,.01 )
  53736  
  53737   "^DD",7412 11.03,7412 11.03,0,"N M","X12 83 7 V5010 CL AIM RECORD  LAYOUT")
  53738  
  53739   "^DD",7412 11.03,7412 11.03,0,"V RPK")
  53740   CH
  53741   "^DD",7412 11.03,7412 11.03,.01, 0)
  53742   CLAIM RECO RD NAME^RF ^^0;1^K:$L (X)>8!($L( X)<4)!'(X' ?1P.E) X
  53743   "^DD",7412 11.03,7412 11.03,.01, 1,0)
  53744   ^.1
  53745   "^DD",7412 11.03,7412 11.03,.01, 1,1,0)
  53746   741211.03^ B
  53747   "^DD",7412 11.03,7412 11.03,.01, 1,1,1)
  53748   S ^CHMXCRL (741211.03 ,"B",$E(X, 1,30),DA)= ""
  53749   "^DD",7412 11.03,7412 11.03,.01, 1,1,2)
  53750   K ^CHMXCRL (741211.03 ,"B",$E(X, 1,30),DA)
  53751   "^DD",7412 11.03,7412 11.03,.01, 3)
  53752   Answer mus t be 4-8 c haracters  in length.
  53753   "^DD",7412 11.03,7412 11.03,.01, 21,0)
  53754   ^^1^1^3010 202^
  53755   "^DD",7412 11.03,7412 11.03,.01, 21,1,0)
  53756   This is th e record l ayout for  the X12 83 7 v.4010 H ealth Care  Claim
  53757   "^DD",7412 11.03,7412 11.03,.01, "DT")
  53758   3010202
  53759   "^DD",7412 11.03,7412 11.03,.02, 0)
  53760   READ ROUTI NE^F^^0;2^ K:$L(X)>8! ($L(X)<6)  X
  53761   "^DD",7412 11.03,7412 11.03,.02, 3)
  53762   Answer mus t be 6-8 c haracters  in length.
  53763   "^DD",7412 11.03,7412 11.03,.02, "DT")
  53764   3010202
  53765   "^DD",7412 11.03,7412 11.03,.03, 0)
  53766   TEST ROUTI NE^F^^0;3^ K:$L(X)>8! ($L(X)<6)  X
  53767   "^DD",7412 11.03,7412 11.03,.03, 3)
  53768   Answer mus t be 6-8 c haracters  in length.
  53769   "^DD",7412 11.03,7412 11.03,.03, "DT")
  53770   3010202
  53771   "^DD",7412 11.03,7412 11.03,.04, 0)
  53772   NEXT RECOR D DEFAULT^ RF^^0;4^K: $L(X)>6!($ L(X)<4) X
  53773   "^DD",7412 11.03,7412 11.03,.04, 3)
  53774   Answer mus t be 4-6 c haracters  in length.
  53775   "^DD",7412 11.03,7412 11.03,.04, "DT")
  53776   3010202
  53777   "^DD",7412 11.03,7412 11.03,.05, 0)
  53778   CLAIM RECO RD PRINT N AME^F^^0;5 ^K:$L(X)>3 0!($L(X)<5 ) X
  53779   "^DD",7412 11.03,7412 11.03,.05, 3)
  53780   Answer mus t be 5-30  characters  in length .
  53781   "^DD",7412 11.03,7412 11.03,.05, "DT")
  53782   3010202
  53783   "^DD",7412 11.03,7412 11.03,.06, 0)
  53784   BUFFER GLO BAL NAME^R F^^0;6^K:$ L(X)>7!($L (X)<7)!'(X ?7U) X
  53785   "^DD",7412 11.03,7412 11.03,.06, 3)
  53786   Answer mus t be 7 cha racters in  length.
  53787   "^DD",7412 11.03,7412 11.03,.06, 21,0)
  53788   ^.001^1^1^ 3110802^^
  53789   "^DD",7412 11.03,7412 11.03,.06, 21,1,0)
  53790   This field  defines t he buffer  global nam e (^CHMXCL x).
  53791   "^DD",7412 11.03,7412 11.03,.06, "DT")
  53792   3110802
  53793   "^DD",7412 11.03,7412 11.03,1.01 ,0)
  53794   RECORD DEF AULT 837I^ F^^1;1^K:$ L(X)>6!($L (X)<4) X
  53795   "^DD",7412 11.03,7412 11.03,1.01 ,3)
  53796   Answer mus t be 4-6 c haracters  in length.
  53797   "^DD",7412 11.03,7412 11.03,1.01 ,"DT")
  53798   3020816
  53799   "^DD",7412 11.03,7412 11.03,1.02 ,0)
  53800   RECORD DEF AULT 837P^ F^^1;2^K:$ L(X)>6!($L (X)<4) X
  53801   "^DD",7412 11.03,7412 11.03,1.02 ,3)
  53802   Answer mus t be 4-6 c haracters  in length.
  53803   "^DD",7412 11.03,7412 11.03,1.02 ,"DT")
  53804   3020816
  53805   "^DD",7412 11.03,7412 11.03,1.03 ,0)
  53806   RECORD DEF AULT 837D^ F^^1;3^K:$ L(X)>6!($L (X)<4) X
  53807   "^DD",7412 11.03,7412 11.03,1.03 ,3)
  53808   Answer mus t be 4-6 c haracters  in length.
  53809   "^DD",7412 11.03,7412 11.03,1.03 ,"DT")
  53810   3020816
  53811   "^DD",7412 11.03,7412 11.03,1.04 ,0)
  53812   RECORD DEF AULT UB^F^ ^1;4^K:$L( X)>6!($L(X )<4) X
  53813   "^DD",7412 11.03,7412 11.03,1.04 ,3)
  53814   Answer mus t be 4-6 c haracters  in length.
  53815   "^DD",7412 11.03,7412 11.03,1.04 ,"DT")
  53816   3020816
  53817   "^DD",7412 11.03,7412 11.03,1.05 ,0)
  53818   RECORD DEF AULT HCFA^ F^^1;5^K:$ L(X)>6!($L (X)<4) X
  53819   "^DD",7412 11.03,7412 11.03,1.05 ,3)
  53820   Answer mus t be 4-6 c haracters  in length.
  53821   "^DD",7412 11.03,7412 11.03,1.05 ,"DT")
  53822   3020816
  53823   "^DD",7412 11.03,7412 11.03,101, 0)
  53824   PRECEDING  RECORD ALL OWED^74121 1.3101^^10 1;0
  53825   "^DD",7412 11.03,7412 11.03,102, 0)
  53826   SUCCEEDING  RECORD AL LOWED^7412 11.3102^^1 02;0
  53827   "^DD",7412 11.03,7412 11.03,102, "DT")
  53828   3110729
  53829   "^DD",7412 11.03,7412 11.03,103, 0)
  53830   RECORD EDI T NAME^741 211.3103^^ 103;0
  53831   "^DD",7412 11.03,7412 11.03,104, 0)
  53832   PRECEDING  RECORD ALL OWED 837P^ 741211.310 4^^104;0
  53833   "^DD",7412 11.03,7412 11.03,105, 0)
  53834   SUCCEEDING  RECORD AL LOWED 837P ^741211.31 05^^105;0
  53835   "^DD",7412 11.03,7412 11.03,106, 0)
  53836   PRECEDING  RECORD ALL OWED 837D^ 741211.310 6^^106;0
  53837   "^DD",7412 11.03,7412 11.03,107, 0)
  53838   SUCCEEDING  RECORD AL LOWED 837D ^741211.31 07^^107;0
  53839   "^DD",7412 11.03,7412 11.03,107, "DT")
  53840   3110729
  53841   "^DD",7412 11.03,7412 11.03,108, 0)
  53842   PRECEDING  RECORD ALL OWED UB^74 1211.3108^ ^108;0
  53843   "^DD",7412 11.03,7412 11.03,109, 0)
  53844   SUCCEEDING  RECORD AL LOWED UB^7 41211.3109 ^^109;0
  53845   "^DD",7412 11.03,7412 11.03,109, "DT")
  53846   3110729
  53847   "^DD",7412 11.03,7412 11.03,110, 0)
  53848   PRECEDING  RECORD ALL OWED HCFA^ 741211.05^ ^110;0
  53849   "^DD",7412 11.03,7412 11.03,111, 0)
  53850   SUCCEEDING  RECORD AL LOWED HCFA ^741211.31 11^^111;0
  53851   "^DD",7412 11.03,7412 11.03,111, "DT")
  53852   3110729
  53853   "^DD",7412 11.03,7412 11.03,201, 0)
  53854   DATA FIELD  NAME^7412 11.3201^^2 01;0
  53855   "^DD",7412 11.03,7412 11.05,0)
  53856   PRECEDING  RECORD ALL OWED HCFA  SUB-FIELD^ ^.01^1
  53857   "^DD",7412 11.03,7412 11.05,0,"D T")
  53858   3020816
  53859   "^DD",7412 11.03,7412 11.05,0,"I X","B",741 211.05,.01 )
  53860  
  53861   "^DD",7412 11.03,7412 11.05,0,"N M","PRECED ING RECORD  ALLOWED H CFA")
  53862  
  53863   "^DD",7412 11.03,7412 11.05,0,"U P")
  53864   741211.03
  53865   "^DD",7412 11.03,7412 11.05,.01, 0)
  53866   PRECEDING  RECORD ALL OWED HCFA^ MF^^0;1^K: $L(X)>6!($ L(X)<4) X
  53867   "^DD",7412 11.03,7412 11.05,.01, 1,0)
  53868   ^.1
  53869   "^DD",7412 11.03,7412 11.05,.01, 1,1,0)
  53870   741211.05^ B
  53871   "^DD",7412 11.03,7412 11.05,.01, 1,1,1)
  53872   S ^CHMXCRL (741211.03 ,DA(1),110 ,"B",$E(X, 1,30),DA)= ""
  53873   "^DD",7412 11.03,7412 11.05,.01, 1,1,2)
  53874   K ^CHMXCRL (741211.03 ,DA(1),110 ,"B",$E(X, 1,30),DA)
  53875   "^DD",7412 11.03,7412 11.05,.01, 3)
  53876   Answer mus t be 4-6 c haracters  in length.
  53877   "^DD",7412 11.03,7412 11.05,.01, "DT")
  53878   3020816
  53879   "^DD",7412 11.03,7412 11.3101,0)
  53880   PRECEDING  RECORD ALL OWED SUB-F IELD^^.01^ 1
  53881   "^DD",7412 11.03,7412 11.3101,0, "DT")
  53882   3020816
  53883   "^DD",7412 11.03,7412 11.3101,0, "IX","B",7 41211.3101 ,.01)
  53884  
  53885   "^DD",7412 11.03,7412 11.3101,0, "NM","PREC EDING RECO RD ALLOWED ")
  53886  
  53887   "^DD",7412 11.03,7412 11.3101,0, "UP")
  53888   741211.03
  53889   "^DD",7412 11.03,7412 11.3101,.0 1,0)
  53890   PRECEDING  RECORD ALL OWED 837I^ MF^^0;1^K: $L(X)>6!($ L(X)<4) X
  53891   "^DD",7412 11.03,7412 11.3101,.0 1,1,0)
  53892   ^.1
  53893   "^DD",7412 11.03,7412 11.3101,.0 1,1,1,0)
  53894   741211.310 1^B
  53895   "^DD",7412 11.03,7412 11.3101,.0 1,1,1,1)
  53896   S ^CHMXCRL (741211.03 ,DA(1),101 ,"B",$E(X, 1,30),DA)= ""
  53897   "^DD",7412 11.03,7412 11.3101,.0 1,1,1,2)
  53898   K ^CHMXCRL (741211.03 ,DA(1),101 ,"B",$E(X, 1,30),DA)
  53899   "^DD",7412 11.03,7412 11.3101,.0 1,3)
  53900   Answer mus t be 4-6 c haracters  in length.
  53901   "^DD",7412 11.03,7412 11.3101,.0 1,"DT")
  53902   3020816
  53903   "^DD",7412 11.03,7412 11.3102,0)
  53904   SUCCEEDING  RECORD AL LOWED SUB- FIELD^^.01 ^1
  53905   "^DD",7412 11.03,7412 11.3102,0, "DT")
  53906   3010202
  53907   "^DD",7412 11.03,7412 11.3102,0, "IX","B",7 41211.3102 ,.01)
  53908  
  53909   "^DD",7412 11.03,7412 11.3102,0, "NM","SUCC EEDING REC ORD ALLOWE D")
  53910  
  53911   "^DD",7412 11.03,7412 11.3102,0, "UP")
  53912   741211.03
  53913   "^DD",7412 11.03,7412 11.3102,.0 1,0)
  53914   SUCEEDING  RECORDS AL LOWED 837I ^MF^^0;1^K :$L(X)>6!( $L(X)<4) X
  53915   "^DD",7412 11.03,7412 11.3102,.0 1,1,0)
  53916   ^.1
  53917   "^DD",7412 11.03,7412 11.3102,.0 1,1,1,0)
  53918   741211.310 2^B
  53919   "^DD",7412 11.03,7412 11.3102,.0 1,1,1,1)
  53920   S ^CHMXCRL (741211.03 ,DA(1),102 ,"B",$E(X, 1,30),DA)= ""
  53921   "^DD",7412 11.03,7412 11.3102,.0 1,1,1,2)
  53922   K ^CHMXCRL (741211.03 ,DA(1),102 ,"B",$E(X, 1,30),DA)
  53923   "^DD",7412 11.03,7412 11.3102,.0 1,3)
  53924   Answer mus t be 4-6 c haracters  in length.
  53925   "^DD",7412 11.03,7412 11.3102,.0 1,"DT")
  53926   3020816
  53927   "^DD",7412 11.03,7412 11.3103,0)
  53928   RECORD EDI T NAME SUB -FIELD^^1^ 5
  53929   "^DD",7412 11.03,7412 11.3103,0, "DT")
  53930   3100222
  53931   "^DD",7412 11.03,7412 11.3103,0, "IX","B",7 41211.3103 ,.01)
  53932  
  53933   "^DD",7412 11.03,7412 11.3103,0, "NM","RECO RD EDIT NA ME")
  53934  
  53935   "^DD",7412 11.03,7412 11.3103,0, "UP")
  53936   741211.03
  53937   "^DD",7412 11.03,7412 11.3103,.0 1,0)
  53938   RECORD EDI T NAME^F^^ 0;1^K:$L(X )>20!($L(X )<3) X
  53939   "^DD",7412 11.03,7412 11.3103,.0 1,1,0)
  53940   ^.1
  53941   "^DD",7412 11.03,7412 11.3103,.0 1,1,1,0)
  53942   741211.310 3^B
  53943   "^DD",7412 11.03,7412 11.3103,.0 1,1,1,1)
  53944   S ^CHMXCRL (741211.03 ,DA(1),103 ,"B",$E(X, 1,30),DA)= ""
  53945   "^DD",7412 11.03,7412 11.3103,.0 1,1,1,2)
  53946   K ^CHMXCRL (741211.03 ,DA(1),103 ,"B",$E(X, 1,30),DA)
  53947   "^DD",7412 11.03,7412 11.3103,.0 1,3)
  53948   Answer mus t be 3-20  characters  in length .
  53949   "^DD",7412 11.03,7412 11.3103,.0 1,"DT")
  53950   3010202
  53951   "^DD",7412 11.03,7412 11.3103,.0 2,0)
  53952   EDIT FLAG^ S^0:OFF;1: ON;^0;2^Q
  53953   "^DD",7412 11.03,7412 11.3103,.0 2,"DT")
  53954   3010202
  53955   "^DD",7412 11.03,7412 11.3103,.0 3,0)
  53956   SUBROUTINE  NAME^F^^0 ;3^K:$L(X) >8!($L(X)< 2) X
  53957   "^DD",7412 11.03,7412 11.3103,.0 3,3)
  53958   Answer mus t be 2-8 c haracters  in length.
  53959   "^DD",7412 11.03,7412 11.3103,.0 3,"DT")
  53960   3010202
  53961   "^DD",7412 11.03,7412 11.3103,.0 4,0)
  53962   ROUTINE NA ME^F^^0;4^ K:$L(X)>8! ($L(X)<4)  X
  53963   "^DD",7412 11.03,7412 11.3103,.0 4,3)
  53964   Answer mus t be 4-8 c haracters  in length.
  53965   "^DD",7412 11.03,7412 11.3103,.0 4,"DT")
  53966   3010202
  53967   "^DD",7412 11.03,7412 11.3103,1, 0)
  53968   TP RECORD  EDIT OVERR IDE^741211 .31031P^^1 ;0
  53969   "^DD",7412 11.03,7412 11.3103,1, "DT")
  53970   3100223
  53971   "^DD",7412 11.03,7412 11.3104,0)
  53972   PRECEDING  RECORD ALL OWED 837P  SUB-FIELD^ ^.01^1
  53973   "^DD",7412 11.03,7412 11.3104,0, "DT")
  53974   3020816
  53975   "^DD",7412 11.03,7412 11.3104,0, "IX","B",7 41211.3104 ,.01)
  53976  
  53977   "^DD",7412 11.03,7412 11.3104,0, "NM","PREC EDING RECO RD ALLOWED  837P")
  53978  
  53979   "^DD",7412 11.03,7412 11.3104,0, "UP")
  53980   741211.03
  53981   "^DD",7412 11.03,7412 11.3104,.0 1,0)
  53982   PRECEDING  RECORD ALL OWED 837P^ MF^^0;1^K: $L(X)>6!($ L(X)<4) X
  53983   "^DD",7412 11.03,7412 11.3104,.0 1,1,0)
  53984   ^.1
  53985   "^DD",7412 11.03,7412 11.3104,.0 1,1,1,0)
  53986   741211.310 4^B
  53987   "^DD",7412 11.03,7412 11.3104,.0 1,1,1,1)
  53988   S ^CHMXCRL (741211.03 ,DA(1),104 ,"B",$E(X, 1,30),DA)= ""
  53989   "^DD",7412 11.03,7412 11.3104,.0 1,1,1,2)
  53990   K ^CHMXCRL (741211.03 ,DA(1),104 ,"B",$E(X, 1,30),DA)
  53991   "^DD",7412 11.03,7412 11.3104,.0 1,3)
  53992   Answer mus t be 4-6 c haracters  in length.
  53993   "^DD",7412 11.03,7412 11.3104,.0 1,"DT")
  53994   3020816
  53995   "^DD",7412 11.03,7412 11.3105,0)
  53996   SUCCEEDING  RECORD AL LOWED 837P  SUB-FIELD ^^.01^1
  53997   "^DD",7412 11.03,7412 11.3105,0, "DT")
  53998   3020816
  53999   "^DD",7412 11.03,7412 11.3105,0, "IX","B",7 41211.3105 ,.01)
  54000  
  54001   "^DD",7412 11.03,7412 11.3105,0, "NM","SUCC EEDING REC ORD ALLOWE D 837P")
  54002  
  54003   "^DD",7412 11.03,7412 11.3105,0, "UP")
  54004   741211.03
  54005   "^DD",7412 11.03,7412 11.3105,.0 1,0)
  54006   SUCCEEDING  RECORD AL LOWED 837P ^MF^^0;1^K :$L(X)>6!( $L(X)<4) X
  54007   "^DD",7412 11.03,7412 11.3105,.0 1,1,0)
  54008   ^.1
  54009   "^DD",7412 11.03,7412 11.3105,.0 1,1,1,0)
  54010   741211.310 5^B
  54011   "^DD",7412 11.03,7412 11.3105,.0 1,1,1,1)
  54012   S ^CHMXCRL (741211.03 ,DA(1),105 ,"B",$E(X, 1,30),DA)= ""
  54013   "^DD",7412 11.03,7412 11.3105,.0 1,1,1,2)
  54014   K ^CHMXCRL (741211.03 ,DA(1),105 ,"B",$E(X, 1,30),DA)
  54015   "^DD",7412 11.03,7412 11.3105,.0 1,3)
  54016   Answer mus t be 4-6 c haracters  in length.
  54017   "^DD",7412 11.03,7412 11.3105,.0 1,"DT")
  54018   3020816
  54019   "^DD",7412 11.03,7412 11.3106,0)
  54020   PRECEDING  RECORD ALL OWED 837D  SUB-FIELD^ ^.01^1
  54021   "^DD",7412 11.03,7412 11.3106,0, "DT")
  54022   3020816
  54023   "^DD",7412 11.03,7412 11.3106,0, "IX","B",7 41211.3106 ,.01)
  54024  
  54025   "^DD",7412 11.03,7412 11.3106,0, "NM","PREC EDING RECO RD ALLOWED  837D")
  54026  
  54027   "^DD",7412 11.03,7412 11.3106,0, "UP")
  54028   741211.03
  54029   "^DD",7412 11.03,7412 11.3106,.0 1,0)
  54030   PRECEDING  RECORD ALL OWED 837D^ MF^^0;1^K: $L(X)>6!($ L(X)<4) X
  54031   "^DD",7412 11.03,7412 11.3106,.0 1,1,0)
  54032   ^.1
  54033   "^DD",7412 11.03,7412 11.3106,.0 1,1,1,0)
  54034   741211.310 6^B
  54035   "^DD",7412 11.03,7412 11.3106,.0 1,1,1,1)
  54036   S ^CHMXCRL (741211.03 ,DA(1),106 ,"B",$E(X, 1,30),DA)= ""
  54037   "^DD",7412 11.03,7412 11.3106,.0 1,1,1,2)
  54038   K ^CHMXCRL (741211.03 ,DA(1),106 ,"B",$E(X, 1,30),DA)
  54039   "^DD",7412 11.03,7412 11.3106,.0 1,3)
  54040   Answer mus t be 4-6 c haracters  in length.
  54041   "^DD",7412 11.03,7412 11.3106,.0 1,"DT")
  54042   3020816
  54043   "^DD",7412 11.03,7412 11.3107,0)
  54044   SUCCEEDING  RECORD AL LOWED 837D  SUB-FIELD ^^.01^1
  54045   "^DD",7412 11.03,7412 11.3107,0, "DT")
  54046   3020816
  54047   "^DD",7412 11.03,7412 11.3107,0, "IX","B",7 41211.3107 ,.01)
  54048  
  54049   "^DD",7412 11.03,7412 11.3107,0, "NM","SUCC EEDING REC ORD ALLOWE D 837D")
  54050  
  54051   "^DD",7412 11.03,7412 11.3107,0, "UP")
  54052   741211.03
  54053   "^DD",7412 11.03,7412 11.3107,.0 1,0)
  54054   SUCEEDING  RECORD ALL OWED 837D^ MF^^0;1^K: $L(X)>6!($ L(X)<4) X
  54055   "^DD",7412 11.03,7412 11.3107,.0 1,1,0)
  54056   ^.1
  54057   "^DD",7412 11.03,7412 11.3107,.0 1,1,1,0)
  54058   741211.310 7^B
  54059   "^DD",7412 11.03,7412 11.3107,.0 1,1,1,1)
  54060   S ^CHMXCRL (741211.03 ,DA(1),107 ,"B",$E(X, 1,30),DA)= ""
  54061   "^DD",7412 11.03,7412 11.3107,.0 1,1,1,2)
  54062   K ^CHMXCRL (741211.03 ,DA(1),107 ,"B",$E(X, 1,30),DA)
  54063   "^DD",7412 11.03,7412 11.3107,.0 1,3)
  54064   Answer mus t be 4-6 c haracters  in length.
  54065   "^DD",7412 11.03,7412 11.3107,.0 1,"DT")
  54066   3020816
  54067   "^DD",7412 11.03,7412 11.3108,0)
  54068   PRECEDING  RECORD ALL OWED UB SU B-FIELD^^. 01^1
  54069   "^DD",7412 11.03,7412 11.3108,0, "DT")
  54070   3020816
  54071   "^DD",7412 11.03,7412 11.3108,0, "IX","B",7 41211.3108 ,.01)
  54072  
  54073   "^DD",7412 11.03,7412 11.3108,0, "NM","PREC EDING RECO RD ALLOWED  UB")
  54074  
  54075   "^DD",7412 11.03,7412 11.3108,0, "UP")
  54076   741211.03
  54077   "^DD",7412 11.03,7412 11.3108,.0 1,0)
  54078   PRECEDING  RECORD ALL OWED UB^MF ^^0;1^K:$L (X)>6!($L( X)<4) X
  54079   "^DD",7412 11.03,7412 11.3108,.0 1,1,0)
  54080   ^.1
  54081   "^DD",7412 11.03,7412 11.3108,.0 1,1,1,0)
  54082   741211.310 8^B
  54083   "^DD",7412 11.03,7412 11.3108,.0 1,1,1,1)
  54084   S ^CHMXCRL (741211.03 ,DA(1),108 ,"B",$E(X, 1,30),DA)= ""
  54085   "^DD",7412 11.03,7412 11.3108,.0 1,1,1,2)
  54086   K ^CHMXCRL (741211.03 ,DA(1),108 ,"B",$E(X, 1,30),DA)
  54087   "^DD",7412 11.03,7412 11.3108,.0 1,3)
  54088   Answer mus t be 4-6 c haracters  in length.
  54089   "^DD",7412 11.03,7412 11.3108,.0 1,"DT")
  54090   3020816
  54091   "^DD",7412 11.03,7412 11.3109,0)
  54092   SUCCEEDING  RECORD AL LOWED UB S UB-FIELD^^ .01^1
  54093   "^DD",7412 11.03,7412 11.3109,0, "DT")
  54094   3020816
  54095   "^DD",7412 11.03,7412 11.3109,0, "IX","B",7 41211.3109 ,.01)
  54096  
  54097   "^DD",7412 11.03,7412 11.3109,0, "NM","SUCC EEDING REC ORD ALLOWE D UB")
  54098  
  54099   "^DD",7412 11.03,7412 11.3109,0, "UP")
  54100   741211.03
  54101   "^DD",7412 11.03,7412 11.3109,.0 1,0)
  54102   SUCEEDING  RECORD ALL OWED UB^MF ^^0;1^K:$L (X)>6!($L( X)<4) X
  54103   "^DD",7412 11.03,7412 11.3109,.0 1,1,0)
  54104   ^.1
  54105   "^DD",7412 11.03,7412 11.3109,.0 1,1,1,0)
  54106   741211.310 9^B
  54107   "^DD",7412 11.03,7412 11.3109,.0 1,1,1,1)
  54108   S ^CHMXCRL (741211.03 ,DA(1),109 ,"B",$E(X, 1,30),DA)= ""
  54109   "^DD",7412 11.03,7412 11.3109,.0 1,1,1,2)
  54110   K ^CHMXCRL (741211.03 ,DA(1),109 ,"B",$E(X, 1,30),DA)
  54111   "^DD",7412 11.03,7412 11.3109,.0 1,3)
  54112   Answer mus t be 4-6 c haracters  in length.
  54113   "^DD",7412 11.03,7412 11.3109,.0 1,"DT")
  54114   3020816
  54115   "^DD",7412 11.03,7412 11.3111,0)
  54116   SUCCEEDING  RECORD AL LOWED HCFA  SUB-FIELD ^^.01^1
  54117   "^DD",7412 11.03,7412 11.3111,0, "DT")
  54118   3020816
  54119   "^DD",7412 11.03,7412 11.3111,0, "IX","B",7 41211.3111 ,.01)
  54120  
  54121   "^DD",7412 11.03,7412 11.3111,0, "NM","SUCC EEDING REC ORD ALLOWE D HCFA")
  54122  
  54123   "^DD",7412 11.03,7412 11.3111,0, "UP")
  54124   741211.03
  54125   "^DD",7412 11.03,7412 11.3111,.0 1,0)
  54126   SUCEEDING  RECORD ALL OWED HCFA^ MF^^0;1^K: $L(X)>6!($ L(X)<4) X
  54127   "^DD",7412 11.03,7412 11.3111,.0 1,1,0)
  54128   ^.1
  54129   "^DD",7412 11.03,7412 11.3111,.0 1,1,1,0)
  54130   741211.311 1^B
  54131   "^DD",7412 11.03,7412 11.3111,.0 1,1,1,1)
  54132   S ^CHMXCRL (741211.03 ,DA(1),111 ,"B",$E(X, 1,30),DA)= ""
  54133   "^DD",7412 11.03,7412 11.3111,.0 1,1,1,2)
  54134   K ^CHMXCRL (741211.03 ,DA(1),111 ,"B",$E(X, 1,30),DA)
  54135   "^DD",7412 11.03,7412 11.3111,.0 1,3)
  54136   Answer mus t be 4-6 c haracters  in length.
  54137   "^DD",7412 11.03,7412 11.3111,.0 1,"DT")
  54138   3020816
  54139   "^DD",7412 11.03,7412 11.3201,0)
  54140   DATA FIELD  NAME SUB- FIELD^^.09 ^10
  54141   "^DD",7412 11.03,7412 11.3201,0, "DT")
  54142   3110818
  54143   "^DD",7412 11.03,7412 11.3201,0, "IX","B",7 41211.3201 ,.01)
  54144  
  54145   "^DD",7412 11.03,7412 11.3201,0, "NM","DATA  FIELD NAM E")
  54146  
  54147   "^DD",7412 11.03,7412 11.3201,0, "UP")
  54148   741211.03
  54149   "^DD",7412 11.03,7412 11.3201,.0 1,0)
  54150   DATA FIELD  NAME^MRF^ ^0;1^K:$L( X)>30!($L( X)<3) X
  54151   "^DD",7412 11.03,7412 11.3201,.0 1,1,0)
  54152   ^.1
  54153   "^DD",7412 11.03,7412 11.3201,.0 1,1,1,0)
  54154   741211.320 1^B
  54155   "^DD",7412 11.03,7412 11.3201,.0 1,1,1,1)
  54156   S ^CHMXCRL (741211.03 ,DA(1),201 ,"B",$E(X, 1,30),DA)= ""
  54157   "^DD",7412 11.03,7412 11.3201,.0 1,1,1,2)
  54158   K ^CHMXCRL (741211.03 ,DA(1),201 ,"B",$E(X, 1,30),DA)
  54159   "^DD",7412 11.03,7412 11.3201,.0 1,3)
  54160   Answer mus t be 3-30  characters  in length .
  54161   "^DD",7412 11.03,7412 11.3201,.0 1,"DT")
  54162   3010202
  54163   "^DD",7412 11.03,7412 11.3201,.0 2,0)
  54164   DATA FIELD  TYPE^S^AN :ALPHANUME RIC;N0:NUM ERIC;N2:MO NETARY NUM ERIC;CY:CE NTURY YEAR  DATE;YY:Y EAR DATE;^ 0;2^Q
  54165   "^DD",7412 11.03,7412 11.3201,.0 2,"DT")
  54166   3010202
  54167   "^DD",7412 11.03,7412 11.3201,.0 3,0)
  54168   DATA FIELD  LENGTH^NJ 3,0^^0;3^K :+X'=X!(X> 120)!(X<1) !(X?.E1"." 1.N) X
  54169   "^DD",7412 11.03,7412 11.3201,.0 3,3)
  54170   Type a num ber betwee n 1 and 12 0, 0 Decim al Digits
  54171   "^DD",7412 11.03,7412 11.3201,.0 3,"DT")
  54172   3110729
  54173   "^DD",7412 11.03,7412 11.3201,.0 4,0)
  54174   DATA FIELD  START POS ITION^NJ3, 0^^0;4^K:+ X'=X!(X>50 1)!(X<5)!( X?.E1"."1N .N) X
  54175   "^DD",7412 11.03,7412 11.3201,.0 4,3)
  54176   Type a num ber betwee n 5 and 50 1, 0 decim al digits.
  54177   "^DD",7412 11.03,7412 11.3201,.0 4,"DT")
  54178   3100219
  54179   "^DD",7412 11.03,7412 11.3201,.0 5,0)
  54180   DATA FIELD  MANDATORY ^S^0:NO;1: YES;^0;5^Q
  54181   "^DD",7412 11.03,7412 11.3201,.0 5,"DT")
  54182   3010202
  54183   "^DD",7412 11.03,7412 11.3201,.0 6,0)
  54184   BUFFER FIL E POSITION ^NJ2,0^^0; 6^K:+X'=X! (X>99)!(X< 1)!(X?.E1" ."1N.N) X
  54185   "^DD",7412 11.03,7412 11.3201,.0 6,3)
  54186   Type a Num ber betwee n 1 and 99 , 0 Decima l Digits
  54187   "^DD",7412 11.03,7412 11.3201,.0 6,"DT")
  54188   3110802
  54189   "^DD",7412 11.03,7412 11.3201,.0 7,0)
  54190   BUFFER GLO BAL SUBNOD E^F^^0;7^K :$L(X)>16! ($L(X)<1)  X
  54191   "^DD",7412 11.03,7412 11.3201,.0 7,3)
  54192   Answer mus t be 1-16  characters  in length .
  54193   "^DD",7412 11.03,7412 11.3201,.0 7,"DT")
  54194   3110802
  54195   "^DD",7412 11.03,7412 11.3201,.0 8,0)
  54196   BUFFER GLO BAL POSITI ON^NJ2,0^^ 0;8^K:+X'= X!(X>99)!( X<1)!(X?.E 1"."1N.N)  X
  54197   "^DD",7412 11.03,7412 11.3201,.0 8,3)
  54198   Type a Num ber betwee n 1 and 99 , 0 Decima l Digits
  54199   "^DD",7412 11.03,7412 11.3201,.0 8,"DT")
  54200   3110802
  54201   "^DD",7412 11.03,7412 11.3201,.0 9,0)
  54202   X12 FIELD  NAME^F^^0; 9^K:$L(X)> 50!($L(X)< 4) X
  54203   "^DD",7412 11.03,7412 11.3201,.0 9,3)
  54204   Answer mus t be 4-50  characters  in length .
  54205   "^DD",7412 11.03,7412 11.3201,.0 9,"DT")
  54206   3110818
  54207   "^DD",7412 11.03,7412 11.3201,10 1,0)
  54208   EDIT NUMBE R^741211.3 201101^^10 1;0
  54209   "^DD",7412 11.03,7412 11.3201101 ,0)
  54210   EDIT NUMBE R SUB-FIEL D^^1^19
  54211   "^DD",7412 11.03,7412 11.3201101 ,0,"DT")
  54212   3100222
  54213   "^DD",7412 11.03,7412 11.3201101 ,0,"IX","B ",741211.3 201101,.01 )
  54214  
  54215   "^DD",7412 11.03,7412 11.3201101 ,0,"NM","E DIT NUMBER ")
  54216  
  54217   "^DD",7412 11.03,7412 11.3201101 ,0,"UP")
  54218   741211.320 1
  54219   "^DD",7412 11.03,7412 11.3201101 ,.01,0)
  54220   EDIT NUMBE R^MRNJ3,0^ ^0;1^K:+X' =X!(X>999) !(X<1)!(X? .E1"."1N.N ) X
  54221   "^DD",7412 11.03,7412 11.3201101 ,.01,1,0)
  54222   ^.1
  54223   "^DD",7412 11.03,7412 11.3201101 ,.01,1,1,0 )
  54224   741211.320 1101^B
  54225   "^DD",7412 11.03,7412 11.3201101 ,.01,1,1,1 )
  54226   S ^CHMXCRL (741211.03 ,DA(2),201 ,DA(1),101 ,"B",$E(X, 1,30),DA)= ""
  54227   "^DD",7412 11.03,7412 11.3201101 ,.01,1,1,2 )
  54228   K ^CHMXCRL (741211.03 ,DA(2),201 ,DA(1),101 ,"B",$E(X, 1,30),DA)
  54229   "^DD",7412 11.03,7412 11.3201101 ,.01,3)
  54230   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  54231   "^DD",7412 11.03,7412 11.3201101 ,.01,"DT")
  54232   3010719
  54233   "^DD",7412 11.03,7412 11.3201101 ,.02,0)
  54234   EDIT FLAG^ RS^0:OFF;1 :ON;^0;2^Q
  54235   "^DD",7412 11.03,7412 11.3201101 ,.02,"DT")
  54236   3010719
  54237   "^DD",7412 11.03,7412 11.3201101 ,.03,0)
  54238   EDIT SUBRO UTINE^RF^^ 0;3^K:$L(X )>16!($L(X )<3) X
  54239   "^DD",7412 11.03,7412 11.3201101 ,.03,3)
  54240   Answer mus t be 3-16  characters  in length .
  54241   "^DD",7412 11.03,7412 11.3201101 ,.03,"DT")
  54242   3010719
  54243   "^DD",7412 11.03,7412 11.3201101 ,.04,0)
  54244   EDIT ROUTI NE^RF^^0;4 ^K:$L(X)>8 !($L(X)<6)  X
  54245   "^DD",7412 11.03,7412 11.3201101 ,.04,3)
  54246   Answer mus t be 6-8 c haracters  in length.
  54247   "^DD",7412 11.03,7412 11.3201101 ,.04,"DT")
  54248   3010719
  54249   "^DD",7412 11.03,7412 11.3201101 ,.05,0)
  54250   EDIT FAILU RE REJECT  CODE^RF^^0 ;5^K:$L(X) >9!($L(X)< 3) X
  54251   "^DD",7412 11.03,7412 11.3201101 ,.05,3)
  54252   Answer mus t be 3-9 c haracters  in length.
  54253   "^DD",7412 11.03,7412 11.3201101 ,.05,"DT")
  54254   3010719
  54255   "^DD",7412 11.03,7412 11.3201101 ,.06,0)
  54256   PRESENCE E DIT CONDIT ION^S^0:NO ;1:FILE;2: NEGATIVE;3 :STRING;^0 ;6^Q
  54257   "^DD",7412 11.03,7412 11.3201101 ,.06,"DT")
  54258   3010719
  54259   "^DD",7412 11.03,7412 11.3201101 ,.07,0)
  54260   FILE LOCAT ION^F^^0;7 ^K:$L(X)>2 8!($L(X)<3 ) X
  54261   "^DD",7412 11.03,7412 11.3201101 ,.07,3)
  54262   Answer mus t be 3-28  characters  in length
  54263   "^DD",7412 11.03,7412 11.3201101 ,.07,"DT")
  54264   3010802
  54265   "^DD",7412 11.03,7412 11.3201101 ,.08,0)
  54266   PIECE^NJ3, 0^^0;8^K:+ X'=X!(X>99 9)!(X<1)!( X?.E1"."1N .N) X
  54267   "^DD",7412 11.03,7412 11.3201101 ,.08,3)
  54268   Type a Num ber betwee n 1 and 99 9, 0 Decim al Digits
  54269   "^DD",7412 11.03,7412 11.3201101 ,.08,"DT")
  54270   3010719
  54271   "^DD",7412 11.03,7412 11.3201101 ,.09,0)
  54272   COMPARISON  VALUE^F^^ 0;9^K:$L(X )>20!($L(X )<1) X
  54273   "^DD",7412 11.03,7412 11.3201101 ,.09,3)
  54274   Answer mus t be 1-20  characters  in length .
  54275   "^DD",7412 11.03,7412 11.3201101 ,.09,"DT")
  54276   3010719
  54277   "^DD",7412 11.03,7412 11.3201101 ,.1,0)
  54278   FORMAT PAT TERN MATCH ^F^^0;10^K :$L(X)>75! ($L(X)<1)  X
  54279   "^DD",7412 11.03,7412 11.3201101 ,.1,3)
  54280   Answer mus t be 1-75  characters  in length .
  54281   "^DD",7412 11.03,7412 11.3201101 ,.1,"DT")
  54282   3010719
  54283   "^DD",7412 11.03,7412 11.3201101 ,.11,0)
  54284   LOWEST POS SIBLE NUMB ER^NJ8,0^^ 0;11^K:+X' =X!(X>9999 9999)!(X<0 )!(X?.E1". "1N.N) X
  54285   "^DD",7412 11.03,7412 11.3201101 ,.11,3)
  54286   Type a Num ber betwee n 0 and 99 999999, 0  Decimal Di gits
  54287   "^DD",7412 11.03,7412 11.3201101 ,.11,"DT")
  54288   3010719
  54289   "^DD",7412 11.03,7412 11.3201101 ,.12,0)
  54290   HIGHEST PO SSIBLE NUM BER^NJ10,0 ^^0;12^K:+ X'=X!(X>99 99999999)! (X<0)!(X?. E1"."1N.N)  X
  54291   "^DD",7412 11.03,7412 11.3201101 ,.12,3)
  54292   Type a Num ber betwee n 0 and 99 99999999,  0 Decimal  Digits
  54293   "^DD",7412 11.03,7412 11.3201101 ,.12,"DT")
  54294   3020613
  54295   "^DD",7412 11.03,7412 11.3201101 ,.13,0)
  54296   FILE REFER ENCE (CODE )^F^^0;13^ K:$L(X)>40 !($L(X)<3)  X
  54297   "^DD",7412 11.03,7412 11.3201101 ,.13,3)
  54298   Answer mus t be 3-40  characters  in length .
  54299   "^DD",7412 11.03,7412 11.3201101 ,.13,"DT")
  54300   3010719
  54301   "^DD",7412 11.03,7412 11.3201101 ,.14,0)
  54302   TYPE OF ED IT^RS^1:PR ESENCE;2:D ATE;3:FUTU RE DATE;4: FORMAT VAL IDATION;5: CODE VALID ATION;6:DU PLICATE;7: SPECIAL;8: HOUR;9:PAS S-THRU;^0; 14^Q
  54303   "^DD",7412 11.03,7412 11.3201101 ,.14,"DT")
  54304   3010719
  54305   "^DD",7412 11.03,7412 11.3201101 ,.15,0)
  54306   VARIABLE N AME^F^^0;1 5^K:$L(X)> 6!($L(X)<2 ) X
  54307   "^DD",7412 11.03,7412 11.3201101 ,.15,3)
  54308   Answer mus t be 2-6 c haracters  in length.
  54309   "^DD",7412 11.03,7412 11.3201101 ,.15,"DT")
  54310   3010719
  54311   "^DD",7412 11.03,7412 11.3201101 ,.16,0)
  54312   SUBSCRIPT  VALUE^NJ2, 0^^0;16^K: +X'=X!(X>9 9)!(X<0)!( X?.E1"."1N .N) X
  54313   "^DD",7412 11.03,7412 11.3201101 ,.16,3)
  54314   Type a Num ber betwee n 0 and 99 , 0 Decima l Digits
  54315   "^DD",7412 11.03,7412 11.3201101 ,.16,"DT")
  54316   3010719
  54317   "^DD",7412 11.03,7412 11.3201101 ,.17,0)
  54318   CODE VALID ATION DIRE CTION^S^0: NOT DATA E RR;1:DATA  ERR;^0;17^ Q
  54319   "^DD",7412 11.03,7412 11.3201101 ,.17,"DT")
  54320   3010719
  54321   "^DD",7412 11.03,7412 11.3201101 ,.18,0)
  54322   ALTERNATE  EDIT FLAG^ S^0:OFF;1: ON;^0;18^Q
  54323   "^DD",7412 11.03,7412 11.3201101 ,.18,"DT")
  54324   3020823
  54325   "^DD",7412 11.03,7412 11.3201101 ,1,0)
  54326   TP FIELD E DIT OVERRI DE^741211. 32011011P^ ^1;0
  54327   "^DD",7412 11.03,7412 11.3201101 ,1,"DT")
  54328   3100223
  54329   "^DD",7412 11.03,7412 11.3201101 1,0)
  54330   TP FIELD E DIT OVERRI DE SUB-FIE LD^^.01^1
  54331   "^DD",7412 11.03,7412 11.3201101 1,0,"DT")
  54332   3100222
  54333   "^DD",7412 11.03,7412 11.3201101 1,0,"IX"," B",741211. 32011011,. 01)
  54334  
  54335   "^DD",7412 11.03,7412 11.3201101 1,0,"NM"," TP FIELD E DIT OVERRI DE")
  54336  
  54337   "^DD",7412 11.03,7412 11.3201101 1,0,"UP")
  54338   741211.320 1101
  54339   "^DD",7412 11.03,7412 11.3201101 1,.01,0)
  54340   TP FIELD E DIT OVERRI DE^P741211 .01'^CHMXT P(^0;1^Q
  54341   "^DD",7412 11.03,7412 11.3201101 1,.01,1,0)
  54342   ^.1
  54343   "^DD",7412 11.03,7412 11.3201101 1,.01,1,1, 0)
  54344   741211.320 11011^B
  54345   "^DD",7412 11.03,7412 11.3201101 1,.01,1,1, 1)
  54346   S ^CHMXCRL (741211.03 ,DA(3),201 ,DA(2),101 ,DA(1),1," B",$E(X,1, 30),DA)=""
  54347   "^DD",7412 11.03,7412 11.3201101 1,.01,1,1, 2)
  54348   K ^CHMXCRL (741211.03 ,DA(3),201 ,DA(2),101 ,DA(1),1," B",$E(X,1, 30),DA)
  54349   "^DD",7412 11.03,7412 11.3201101 1,.01,"DT" )
  54350   3100222
  54351   "^DD",7412 13,741213, 0)
  54352   FIELD^^3^4
  54353   "^DD",7412 13,741213, 0,"DT")
  54354   3180123
  54355   "^DD",7412 13,741213, 0,"IX","AC ",741213,2 )
  54356  
  54357   "^DD",7412 13,741213, 0,"IX","B" ,741213,.0 1)
  54358  
  54359   "^DD",7412 13,741213, 0,"NM","Fi nal CSTAT  Alert")
  54360  
  54361   "^DD",7412 13,741213, .01,0)
  54362   PDI^RNJ15, 0^^0;1^K:+ X'=X!(X>99 9999999999 999)!(X<0) !(X?.E1"." 1N.N) X
  54363   "^DD",7412 13,741213, .01,1,0)
  54364   ^.1
  54365   "^DD",7412 13,741213, .01,1,1,0)
  54366   741213^B
  54367   "^DD",7412 13,741213, .01,1,1,1)
  54368   S ^CHCSTAT (741213,"B ",$E(X,1,3 0),DA)=""
  54369   "^DD",7412 13,741213, .01,1,1,2)
  54370   K ^CHCSTAT (741213,"B ",$E(X,1,3 0),DA)
  54371   "^DD",7412 13,741213, .01,3)
  54372   Type a num ber betwee n 0 and 99 9999999999 999, 0 dec imal digit s.
  54373   "^DD",7412 13,741213, .01,"DT")
  54374   3170919
  54375   "^DD",7412 13,741213, 1,0)
  54376   STATUS^FJ3 0^^0;2^K:$ L(X)>30!($ L(X)<1) X
  54377   "^DD",7412 13,741213, 1,3)
  54378   Answer mus t be 1-30  characters  in length .
  54379   "^DD",7412 13,741213, 1,"DT")
  54380   3170919
  54381   "^DD",7412 13,741213, 2,0)
  54382   DATE ADDED ^D^^0;3^S  %DT="EX" D  ^%DT S X= Y K:Y<1 X
  54383   "^DD",7412 13,741213, 2,1,0)
  54384   ^.1
  54385   "^DD",7412 13,741213, 2,1,1,0)
  54386   741213^AC
  54387   "^DD",7412 13,741213, 2,1,1,1)
  54388   S ^CHCSTAT (741213,"A C",$E(X,1, 30),DA)=""
  54389   "^DD",7412 13,741213, 2,1,1,2)
  54390   K ^CHCSTAT (741213,"A C",$E(X,1, 30),DA)
  54391   "^DD",7412 13,741213, 2,1,1,"DT" )
  54392   3170919
  54393   "^DD",7412 13,741213, 2,"DT")
  54394   3170919
  54395   "^DD",7412 13,741213, 3,0)
  54396   DATE PROCE SSED^D^^0; 4^S %DT="E STX" D ^%D T S X=Y K: Y<1 X
  54397   "^DD",7412 13,741213, 3,"DT")
  54398   3170919
  54399   "^DD",7412 15,741215, 0)
  54400   FIELD^^2^3
  54401   "^DD",7412 15,741215, 0,"DT")
  54402   3180123
  54403   "^DD",7412 15,741215, 0,"IX","B" ,741215,.0 1)
  54404  
  54405   "^DD",7412 15,741215, 0,"IX","C" ,741215,1)
  54406  
  54407   "^DD",7412 15,741215, 0,"NM","Re versing 83 5 Alert")
  54408  
  54409   "^DD",7412 15,741215, .01,0)
  54410   PDI^RNJ15, 0^^0;1^K:+ X'=X!(X>99 9999999999 999)!(X<0) !(X?.E1"." 1N.N) X
  54411   "^DD",7412 15,741215, .01,1,0)
  54412   ^.1
  54413   "^DD",7412 15,741215, .01,1,1,0)
  54414   741215^B
  54415   "^DD",7412 15,741215, .01,1,1,1)
  54416   S ^CH835RE V(741215," B",$E(X,1, 30),DA)=""
  54417   "^DD",7412 15,741215, .01,1,1,2)
  54418   K ^CH835RE V(741215," B",$E(X,1, 30),DA)
  54419   "^DD",7412 15,741215, .01,3)
  54420   Type a num ber betwee n 0 and 99 9999999999 999, 0 dec imal digit s.
  54421   "^DD",7412 15,741215, .01,"DT")
  54422   3170920
  54423   "^DD",7412 15,741215, 1,0)
  54424   DATE ADDED ^D^^0;2^S  %DT="EX" D  ^%DT S X= Y K:Y<1 X
  54425   "^DD",7412 15,741215, 1,1,0)
  54426   ^.1
  54427   "^DD",7412 15,741215, 1,1,1,0)
  54428   741215^C
  54429   "^DD",7412 15,741215, 1,1,1,1)
  54430   S ^CH835RE V(741215," C",$E(X,1, 30),DA)=""
  54431   "^DD",7412 15,741215, 1,1,1,2)
  54432   K ^CH835RE V(741215," C",$E(X,1, 30),DA)
  54433   "^DD",7412 15,741215, 1,1,1,"DT" )
  54434   3170920
  54435   "^DD",7412 15,741215, 1,"DT")
  54436   3170920
  54437   "^DD",7412 15,741215, 2,0)
  54438   DATE PROCE SSED^D^^0; 3^S %DT="E STX" D ^%D T S X=Y K: Y<1 X
  54439   "^DD",7412 15,741215, 2,"DT")
  54440   3170920
  54441   "^DIC",741 000,741000 ,0)
  54442   CHAMPVA CL AIMS^74100 0
  54443   "^DIC",741 000,741000 ,0,"GL")
  54444   ^CHMPAY(
  54445   "^DIC",741 000,"B","C HAMPVA CLA IMS",74100 0)
  54446  
  54447   "^DIC",741 000.2,7410 00.2,0)
  54448   CHAMPVA ST ORED IMAGE S^741000.2
  54449   "^DIC",741 000.2,7410 00.2,0,"GL ")
  54450   ^CHMIMG(
  54451   "^DIC",741 000.2,"B", "CHAMPVA S TORED IMAG ES",741000 .2)
  54452  
  54453   "^DIC",741 002.17,741 002.17,0)
  54454   CHAMPVA PA YMENT PARA METER^7410 02.17S
  54455   "^DIC",741 002.17,741 002.17,0," GL")
  54456   ^CHMDIC(74 1002.17,
  54457   "^DIC",741 002.17,741 002.17,"%" ,0)
  54458   ^1.005^^0
  54459   "^DIC",741 002.17,"B" ,"CHAMPVA  PAYMENT PA RAMETER",7 41002.17)
  54460  
  54461   "^DIC",741 002.22,741 002.22,0)
  54462   CHAMPVA ST ATUS REASO N DICTIONA RY^741002. 22
  54463   "^DIC",741 002.22,741 002.22,0," GL")
  54464   ^CHMDIC(74 1002.22,
  54465   "^DIC",741 002.22,"B" ,"CHAMPVA  STATUS REA SON DICTIO NA",741002 .22)
  54466  
  54467   "^DIC",741 201.15,741 201.15,0)
  54468   CLAIM ADJU STMENT GRO UP CODES ( 1033)^7412 01.15
  54469   "^DIC",741 201.15,741 201.15,0," GL")
  54470   ^CHMXDIC(7 41201.15,
  54471   "^DIC",741 201.15,"B" ,"CLAIM AD JUSTMENT G ROUP CODES  (",741201 .15)
  54472  
  54473   "^DIC",741 201.16,741 201.16,0)
  54474   CLAIM ADJU STMENT REA SON CODES  (1034)^741 201.16
  54475   "^DIC",741 201.16,741 201.16,0," GL")
  54476   ^CHMXDIC(7 41201.16,
  54477   "^DIC",741 201.16,"B" ,"CLAIM AD JUSTMENT R EASON CODE S ",741201 .16)
  54478  
  54479   "^DIC",741 201.32,741 201.32,0)
  54480   HAC EDI 83 7 ERROR CO DES (HAC)^ 741201.32
  54481   "^DIC",741 201.32,741 201.32,0," GL")
  54482   ^CHMXDIC(7 41201.32,
  54483   "^DIC",741 201.32,"B" ,"HAC EDI  837 ERROR  CODES (HAC )",741201. 32)
  54484  
  54485   "^DIC",741 201.58,741 201.58,0)
  54486   CLAIM PAYM ENT REMARK  CODES (12 7)^741201. 58
  54487   "^DIC",741 201.58,741 201.58,0," GL")
  54488   ^CHMXDIC(7 41201.58,
  54489   "^DIC",741 201.58,"B" ,"CLAIM PA YMENT REMA RK CODES ( 12",741201 .58)
  54490  
  54491   "^DIC",741 201.77,741 201.77,0)
  54492   EOB REASON /X12 CROSS  WALK^7412 01.77
  54493   "^DIC",741 201.77,741 201.77,0," GL")
  54494   ^CHMXDIC(7 41201.77,
  54495   "^DIC",741 201.77,"B" ,"EOB REAS ON/X12 CRO SS WALK",7 41201.77)
  54496  
  54497   "^DIC",741 211.03,741 211.03,0)
  54498   X12 837 V5 010 CLAIM  RECORD LAY OUT^741211 .03
  54499   "^DIC",741 211.03,741 211.03,0," GL")
  54500   ^CHMXCRL(7 41211.03,
  54501   "^DIC",741 211.03,"B" ,"X12 837  V5010 CLAI M RECORD L AY",741211 .03)
  54502  
  54503   "^DIC",741 213,741213 ,0)
  54504   Final CSTA T Alert^74 1213
  54505   "^DIC",741 213,741213 ,0,"GL")
  54506   ^CHCSTAT(7 41213,
  54507   "^DIC",741 213,"B","F inal CSTAT  Alert",74 1213)
  54508  
  54509   "^DIC",741 215,741215 ,0)
  54510   Reversing  835 Alert^ 741215
  54511   "^DIC",741 215,741215 ,0,"GL")
  54512   ^CH835REV( 741215,
  54513   "^DIC",741 215,"B","R eversing 8 35 Alert", 741215)
  54514  
  54515   **END**
  54516   **END**