3. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 4/19/2019 10:42:05 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.

3.1 Files compared

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

3.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 10 86506
Changed 9 18
Inserted 0 0
Removed 0 0

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

3.4 Active regular expressions

No regular expressions were active.

3.5 Comparison detail

  1   KIDS Distr ibution sa ved on Mar  20, 2019@ 07:01:44
  2   Build inco rporates a ll previou s Vendor S treamlinin g Builds
  3   **KIDS**:C PEVS*1.0*0 15^
  4  
  5   **INSTALL  NAME**
  6   CPEVS*1.0* 015
  7   "BLD",1007 0,0)
  8   CPEVS*1.0* 015^^0^319 0320^n
  9   "BLD",1007 0,1,0)
  10   ^^190^190^ 3190319^
  11   "BLD",1007 0,1,1,0)
  12   The Vetera ns Health  Administra tion Offic e of Commu nity Care  (VHA OCC)
  13   "BLD",1007 0,1,2,0)
  14   in Denver,  Colo., Ch ampVA Heal th Care Be nefits Pro gram, prov ides for
  15   "BLD",1007 0,1,3,0)
  16   the author ization of  benefits  and the su bsequent p rocessing  and paymen t
  17   "BLD",1007 0,1,4,0)
  18   of health  care claim s after a  determinat ion of eli gibility h as been
  19   "BLD",1007 0,1,5,0)
  20   made by th e Denver V A Regional  Office (V ARO).
  21   "BLD",1007 0,1,6,0)
  22    
  23   "BLD",1007 0,1,7,0)
  24   This patch  incorpora tes all pr evious Ven dor Stream lining Bui lds into a  
  25   "BLD",1007 0,1,8,0)
  26   single Bui ld and inc ludes all  routines a nd data di ctionary 
  27   "BLD",1007 0,1,9,0)
  28   changes re quired for  the Vendo r Streamli ning Proje ct.  Routi nes are ma rked
  29   "BLD",1007 0,1,10,0)
  30   only with  their orig inal build  as this b uild has m ade no cod e changes.
  31   "BLD",1007 0,1,11,0)
  32    
  33   "BLD",1007 0,1,12,0)
  34    
  35   "BLD",1007 0,1,13,0)
  36    Patch Com ponents:
  37   "BLD",1007 0,1,14,0)
  38    --------- --------
  39   "BLD",1007 0,1,15,0)
  40    Files & F ields Asso ciated: 
  41   "BLD",1007 0,1,16,0)
  42     
  43   "BLD",1007 0,1,17,0)
  44    File Name  (Number)           F ield Name  (Number)    New/Modif ied/Delete d
  45   "BLD",1007 0,1,18,0)
  46    --------- ---------- -----    - ---------- --------    --------- ---------- -
  47   "BLD",1007 0,1,19,0)
  48    CHAMPVA C LAIMS (741 000)     P L ZIP (800 .105)       New 
  49   "BLD",1007 0,1,20,0)
  50    CHAMPVA S TORED IMAG ES       E DI-PAUSE               New
  51   "BLD",1007 0,1,21,0)
  52         (741 000.2)
  53   "BLD",1007 0,1,22,0)
  54    CHAMPVA V ENDOR (741 001)     D ATE INACTI VATED       New
  55   "BLD",1007 0,1,23,0)
  56                                  ( 8.01)
  57   "BLD",1007 0,1,24,0)
  58                                  D UPLICATE C LEANUP      New
  59   "BLD",1007 0,1,25,0)
  60                                  U SER (8.02)
  61   "BLD",1007 0,1,26,0)
  62    
  63   "BLD",1007 0,1,27,0)
  64    Routine I nformation :
  65   "BLD",1007 0,1,28,0)
  66    --------- ---------- ---------
  67   "BLD",1007 0,1,29,0)
  68    ;;1.0;CHA MPVA SYSTE M;**[Patch  List]**;J ULY 4, 199 0;Build 10
  69   "BLD",1007 0,1,30,0)
  70    
  71   "BLD",1007 0,1,31,0)
  72                     Che cksums
  73   "BLD",1007 0,1,32,0)
  74   Routine          Old          Ne w        P atch List
  75   "BLD",1007 0,1,33,0)
  76   CH835F1          n/a       77056 1458   **1 ,14** <<<N o 15
  77   "BLD",1007 0,1,34,0)
  78   CH835F2          n/a       43670 3483   **2 ** <<<No 1 5
  79   "BLD",1007 0,1,35,0)
  80   CH835F3          n/a       85763 1061   **2 ** <<<No 1 5
  81   "BLD",1007 0,1,36,0)
  82   CH835FU1         n/a       96986 6689   **2 ** <<<No 1 5
  83   "BLD",1007 0,1,37,0)
  84   CHBPEBSD         n/a       12081 6035   **2 ** <<<No 1 5
  85   "BLD",1007 0,1,38,0)
  86   CHFBC2A          n/a       28422 7801   **1 ,11,14** < <<No 15
  87   "BLD",1007 0,1,39,0)
  88   CHFBCQ           n/a       20670 0247   **1 ,14** <<<N o 15
  89   "BLD",1007 0,1,40,0)
  90   CHFBCUTL         n/a       17563 0513   **1 ** <<<No 1 5
  91   "BLD",1007 0,1,41,0)
  92   CHGAS22          n/a       73431 822    **1 ,11,14** < <<No 15
  93   "BLD",1007 0,1,42,0)
  94   CHGASIP          n/a       60716 419    **1 ,11,14** < <<No 15
  95   "BLD",1007 0,1,43,0)
  96   CHGASP           n/a       86304 290    **1 ,11,14** < <<No 15
  97   "BLD",1007 0,1,44,0)
  98   CHGASP1          n/a       40517 172    **1 ,11,14** < <<No 15
  99   "BLD",1007 0,1,45,0)
  100   CHGCDC7          n/a       18087 010    **2 ** <<<No 1 5
  101   "BLD",1007 0,1,46,0)
  102   CHGCDC72         n/a       84855 070    **2 ** <<<No 1 5
  103   "BLD",1007 0,1,47,0)
  104   CHGCDV70         n/a       80233 452    **1 ,11,14** < <<No 15
  105   "BLD",1007 0,1,48,0)
  106   CHGCDV73         n/a       41057 918    **1 ,14** <<<N o 15
  107   "BLD",1007 0,1,49,0)
  108   CHGCP2           n/a       11561 1366   **1 1** <<<No  15
  109   "BLD",1007 0,1,50,0)
  110   CHGCU130         n/a       13827 194    **9 ** <<<No 1 5
  111   "BLD",1007 0,1,51,0)
  112   CHGCU133         n/a       40838 286    **1 1** <<<No  15
  113   "BLD",1007 0,1,52,0)
  114   CHGCU136         n/a       38195 134    **1 ,11,14** < <<No 15
  115   "BLD",1007 0,1,53,0)
  116   CHGCU137         n/a       90992 077    **9 ** <<<No 1 5
  117   "BLD",1007 0,1,54,0)
  118   CHGDQ2           n/a       15600 1132   **1 ,11,14** < <<No 15
  119   "BLD",1007 0,1,55,0)
  120   CHGQA2           n/a       10563 5204   **1 ,11,14** < <<No 15
  121   "BLD",1007 0,1,56,0)
  122   CHGVQ370         n/a       19358 8907   **1 ,14** <<<N o 15
  123   "BLD",1007 0,1,57,0)
  124   CHGVQ374         n/a       52486 016    **8 ** <<<No 1 5
  125   "BLD",1007 0,1,58,0)
  126   CHGVQ529         n/a       96573 340    **1 ,8,14** << <No 15
  127   "BLD",1007 0,1,59,0)
  128   CHGVQ600         n/a       50077 321    **2 ** <<<No 1 5
  129   "BLD",1007 0,1,60,0)
  130   CHICDAA          n/a       21795 998    **8 ** <<<No 1 5
  131   "BLD",1007 0,1,61,0)
  132   CHMEAE5          n/a       66632 491    **1 ,7,14** << <No 15
  133   "BLD",1007 0,1,62,0)
  134   CHMF211          n/a       19437 100    **8 ** <<<No 1 5
  135   "BLD",1007 0,1,63,0)
  136   CHMF351D         n/a       92005 416    **1 ,14** <<<N o 15
  137   "BLD",1007 0,1,64,0)
  138   CHMF351P         n/a       16058 3754   **1 ,14** <<<N o 15
  139   "BLD",1007 0,1,65,0)
  140   CHMFA001         n/a       72728 138    **1 ,8,14** << <No 15
  141   "BLD",1007 0,1,66,0)
  142   CHMFA010         n/a       18328 8112   **1 ,14** <<<N o 15
  143   "BLD",1007 0,1,67,0)
  144   CHMFA011         n/a       10964 1227   **1 ,8,14** << <No 15
  145   "BLD",1007 0,1,68,0)
  146   CHMFA01D         n/a        5815 956    **2 ** <<<No 1 5
  147   "BLD",1007 0,1,69,0)
  148   CHMFA01E         n/a       56185 655    **1 ,8,14** << <No 15
  149   "BLD",1007 0,1,70,0)
  150   CHMFA117         n/a       18605 118    **8 ** <<<No 1 5
  151   "BLD",1007 0,1,71,0)
  152   CHMFA141         n/a       12711 09246  **1 ,14** <<<N o 15
  153   "BLD",1007 0,1,72,0)
  154   CHMFA14V         n/a       12596 38550  **8 ** <<<No 1 5
  155   "BLD",1007 0,1,73,0)
  156   CHMFA161         n/a       12526 8710   **8 ** <<<No 1 5
  157   "BLD",1007 0,1,74,0)
  158   CHMFA171         n/a       14446 2687   **8 ** <<<No 1 5
  159   "BLD",1007 0,1,75,0)
  160   CHMFA181         n/a       14474 9004   **8 ** <<<No 1 5
  161   "BLD",1007 0,1,76,0)
  162   CHMFA802         n/a       65124 332    **8 ** <<<No 1 5
  163   "BLD",1007 0,1,77,0)
  164   CHMFADR1         n/a       12724 2208   **1 ,14** <<<N o 15
  165   "BLD",1007 0,1,78,0)
  166   CHMFADR4         n/a       26793 4873   **1 ,14** <<<N o 15
  167   "BLD",1007 0,1,79,0)
  168   CHMFAUT5         n/a         869 373    **8 ** <<<No 1 5
  169   "BLD",1007 0,1,80,0)
  170   CHMFAUT6         n/a       19873 430    **8 ** <<<No 1 5
  171   "BLD",1007 0,1,81,0)
  172   CHMFAUT7         n/a       56188 5712   **8 ** <<<No 1 5
  173   "BLD",1007 0,1,82,0)
  174   CHMFAUT8         n/a       82440 393    **8 ** <<<No 1 5
  175   "BLD",1007 0,1,83,0)
  176   CHMFCLNC         n/a        1633 009    **8 ** <<<No 1 5
  177   "BLD",1007 0,1,84,0)
  178   CHMFSRT          n/a       24434 762    **1 ,14** <<<N o 15
  179   "BLD",1007 0,1,85,0)
  180   CHMFSTP1E        n/a       50545 843    **8 ** <<<No 1 5
  181   "BLD",1007 0,1,86,0)
  182   CHMFSTP1F        n/a       50316 510    **8 ** <<<No 1 5
  183   "BLD",1007 0,1,87,0)
  184   CHMFUTLE         n/a       23505 215    **1 ,14** <<<N o 15
  185   "BLD",1007 0,1,88,0)
  186   CHMFUTLE2        n/a        8032 653    **8 ** <<<No 1 5
  187   "BLD",1007 0,1,89,0)
  188   CHMKAG5P         n/a       42621 823    **1 4** <<<No  15
  189   "BLD",1007 0,1,90,0)
  190   CHMXF001         n/a       83632 900    **1 ,14** <<<N o 15
  191   "BLD",1007 0,1,91,0)
  192   CHMXF004         n/a       39610 261    **8 ** <<<No 1 5
  193   "BLD",1007 0,1,92,0)
  194   CHMXF005         n/a       62033 224    **8 ** <<<No 1 5
  195   "BLD",1007 0,1,93,0)
  196   CHMXF006         n/a       79465 935    **8 ** <<<No 1 5
  197   "BLD",1007 0,1,94,0)
  198   CHMXF008         n/a       67312 527    **8 ** <<<No 1 5
  199   "BLD",1007 0,1,95,0)
  200   CHMXF009         n/a       66632 527    **8 ** <<<No 1 5
  201   "BLD",1007 0,1,96,0)
  202   CHMXG001         n/a       44193 226    **2 ** <<<No 1 5
  203   "BLD",1007 0,1,97,0)
  204   CHMXPU04         n/a       36820 7416   **1 ,14** <<<N o 15
  205   "BLD",1007 0,1,98,0)
  206   CHMXPU041        n/a       33215 3380   **8 ** <<<No 1 5
  207   "BLD",1007 0,1,99,0)
  208   CHMXWB21         n/a       50243 88986  **0 03** <<<No  15
  209   "BLD",1007 0,1,100,0)
  210   CHMXWB24         n/a       19877 9379   **0 03** <<<No  15
  211   "BLD",1007 0,1,101,0)
  212   CHMXWBUT         n/a       81701 5517   **1 4** <<<No  15
  213   "BLD",1007 0,1,102,0)
  214   CHPRD1           n/a       36462 532    **1 4** <<<No  15
  215   "BLD",1007 0,1,103,0)
  216   CHROLIB1         n/a       70799 522    **8 ** <<<No 1 5
  217   "BLD",1007 0,1,104,0)
  218   CHRPBAR21        n/a       15993 577    **8 ** <<<No 1 5
  219   "BLD",1007 0,1,105,0)
  220    
  221   "BLD",1007 0,1,106,0)
  222    
  223   "BLD",1007 0,1,107,0)
  224    User Stor ies:
  225   "BLD",1007 0,1,108,0)
  226    --------- ---------- ---------
  227   "BLD",1007 0,1,109,0)
  228    N/A
  229   "BLD",1007 0,1,110,0)
  230    
  231   "BLD",1007 0,1,111,0)
  232    Test Envi ronment:
  233   "BLD",1007 0,1,112,0)
  234    --------- --
  235   "BLD",1007 0,1,113,0)
  236    TBD
  237   "BLD",1007 0,1,114,0)
  238    
  239   "BLD",1007 0,1,115,0)
  240    Software  and Docume ntation Re trieval In structions :
  241   "BLD",1007 0,1,116,0)
  242    --------- ---------- ---------- --------
  243   "BLD",1007 0,1,117,0)
  244    The softw are is dis tributed i n a Host f ile genera ted from t he
  245   "BLD",1007 0,1,118,0)
  246    Developme nt Environ ment. Docu mentation  describing  new
  247   "BLD",1007 0,1,119,0)
  248    functiona lity intro duced by t his patch  is availab le from th e
  249   "BLD",1007 0,1,120,0)
  250    developer .
  251   "BLD",1007 0,1,121,0)
  252     
  253   "BLD",1007 0,1,122,0)
  254    Title                                         File Na me              FTP M ode
  255   "BLD",1007 0,1,123,0)
  256    --------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  257   "BLD",1007 0,1,124,0)
  258    KIDS Host  file:  HA C_HFS$:[DS MMANAG.CHA MPVA]CPEVS _1_0_015_V 2.KIDS  AS CII
  259   "BLD",1007 0,1,125,0)
  260    
  261   "BLD",1007 0,1,126,0)
  262    Deploymen t/Installa tion Rollb ack/Backou t Guide
  263   "BLD",1007 0,1,127,0)
  264    --------- ---------- ---------- -
  265   "BLD",1007 0,1,128,0)
  266    It is rec ommended w hen instal ling the K IDS packag e that the  installer
  267   "BLD",1007 0,1,129,0)
  268    choose op tion #5 in  step 3b.  of the bel ow Install ation Inst ructions.
  269   "BLD",1007 0,1,130,0)
  270    If a roll back/backo ut is need ed, the pr ior versio n of the r outines
  271   "BLD",1007 0,1,131,0)
  272    can be re -installed  using the  backup pa ckman mess age create d in
  273   "BLD",1007 0,1,132,0)
  274    step 3b.  However, p lease noti fy the dev elopment t eam if a
  275   "BLD",1007 0,1,133,0)
  276    rollback/ backout of  this patc h is desir ed.
  277   "BLD",1007 0,1,134,0)
  278    
  279   "BLD",1007 0,1,135,0)
  280    Patch Ins tallation:
  281   "BLD",1007 0,1,136,0)
  282      
  283   "BLD",1007 0,1,137,0)
  284    Pre/Post  Installati on Overvie w
  285   "BLD",1007 0,1,138,0)
  286    --------- ---------- ---------- -
  287   "BLD",1007 0,1,139,0)
  288    There is  no Pre-ins tallation  routine pr ocesses.
  289   "BLD",1007 0,1,140,0)
  290    
  291   "BLD",1007 0,1,141,0)
  292    Pre-Insta llation In structions
  293   "BLD",1007 0,1,142,0)
  294    --------- ---------- ----------
  295   "BLD",1007 0,1,143,0)
  296    This patc h may be i nstalled w ith users  on the sys tem althou gh it is
  297   "BLD",1007 0,1,144,0)
  298    recommend ed that it  be instal led during  non-peak  hours to m inimize
  299   "BLD",1007 0,1,145,0)
  300    potential  disruptio n to users .  This pa tch should  take less  than
  301   "BLD",1007 0,1,146,0)
  302    5 minutes  to instal l.
  303   "BLD",1007 0,1,147,0)
  304     
  305   "BLD",1007 0,1,148,0)
  306    Installat ion Instru ctions
  307   "BLD",1007 0,1,149,0)
  308    --------- ---------- ------
  309   "BLD",1007 0,1,150,0)
  310    1.  Choos e the Load  a Distrib ution opti on from th e Installa tion
  311   "BLD",1007 0,1,151,0)
  312        optio n.
  313   "BLD",1007 0,1,152,0)
  314     
  315   "BLD",1007 0,1,153,0)
  316    2.  At th e Enter a  Host File:  prompt,
  317   "BLD",1007 0,1,154,0)
  318        enter :   HAC_HF S$:[DSMMAN AG.CHAMPVA ]CPEVS_1_0 _015_V2.KI DS
  319   "BLD",1007 0,1,155,0)
  320        
  321   "BLD",1007 0,1,156,0)
  322        This  Distributi on contain s Transpor t Globals  for the fo llowing
  323   "BLD",1007 0,1,157,0)
  324        Packa ge(s):   C PEVS*1.0*0 15
  325   "BLD",1007 0,1,158,0)
  326        Distr ibution OK !
  327   "BLD",1007 0,1,159,0)
  328    
  329   "BLD",1007 0,1,160,0)
  330        Want  to Continu e with Loa d? YES// Y ES
  331   "BLD",1007 0,1,161,0)
  332    
  333   "BLD",1007 0,1,162,0)
  334           CP EVS*1.0*01 5
  335   "BLD",1007 0,1,163,0)
  336        Use I NSTALL NAM E: CPEVS*1 .0*015 to  install th is Distrib ution.
  337   "BLD",1007 0,1,164,0)
  338     
  339   "BLD",1007 0,1,165,0)
  340    3.  You m ay elect t o use the  following  options. W hen prompt ed for
  341   "BLD",1007 0,1,166,0)
  342        the I NSTALL ent er the pat ch #(CPEVS *1.0*015):
  343   "BLD",1007 0,1,167,0)
  344     
  345   "BLD",1007 0,1,168,0)
  346        a. Op tion #4:       Compar e Transpor t Global t o Current  System
  347   "BLD",1007 0,1,169,0)
  348              This optio n will all ow you to  view all c hanges tha t will be
  349   "BLD",1007 0,1,170,0)
  350              made when  this patch  is instal led.  It c ompares al l
  351   "BLD",1007 0,1,171,0)
  352              components  of this p atch (rout ines, DD's , template s, etc.).
  353   "BLD",1007 0,1,172,0)
  354        b. Op tion #5:       Backup  a Transpo rt Global.
  355   "BLD",1007 0,1,173,0)
  356              As part of  the Deplo yment/Inst allation R ollback/Ba ckout
  357   "BLD",1007 0,1,174,0)
  358              Guide it i s recommen ded when i nstalling  the KIDS p ackage
  359   "BLD",1007 0,1,175,0)
  360              that the i nstaller c hoose opti on #5 to c reate a ba ckup Packm an
  361   "BLD",1007 0,1,176,0)
  362              message:
  363   "BLD",1007 0,1,177,0)
  364    
  365   "BLD",1007 0,1,178,0)
  366    4.  From  the Instal lation Men u, select  the Instal l Package( s) option  and
  367   "BLD",1007 0,1,179,0)
  368        choos e the patc h to insta ll. Enter  CPEVS*1.0* 015.
  369   "BLD",1007 0,1,180,0)
  370     
  371   "BLD",1007 0,1,181,0)
  372    5.  When  prompted ' Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of
  373   "BLD",1007 0,1,182,0)
  374        Insta ll? NO//',  respond N O.
  375   "BLD",1007 0,1,183,0)
  376     
  377   "BLD",1007 0,1,184,0)
  378    6.  When  prompted ' Want KIDS  to INHIBIT  LOGONs du ring the i nstall? NO //',
  379   "BLD",1007 0,1,185,0)
  380        respo nd NO.
  381   "BLD",1007 0,1,186,0)
  382     
  383   "BLD",1007 0,1,187,0)
  384    7.  When  prompted ' Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd
  385   "BLD",1007 0,1,188,0)
  386        Proto cols? NO// ', respond  NO.
  387   "BLD",1007 0,1,189,0)
  388     
  389   "BLD",1007 0,1,190,0)
  390    8.  If pr ompted 'De lay Instal l (Minutes ):  (0 - 6 0): 0//',  respond 0.
  391   "BLD",1007 0,4,0)
  392   ^9.64PA^74 1001^3
  393   "BLD",1007 0,4,741000 ,0)
  394   741000
  395   "BLD",1007 0,4,741000 ,2,0)
  396   ^9.641^741 000^1
  397   "BLD",1007 0,4,741000 ,2,741000, 0)
  398   CHAMPVA CL AIMS  (Fil e-top leve l)
  399   "BLD",1007 0,4,741000 ,2,741000, 1,0)
  400   ^9.6411^80 0.105^1
  401   "BLD",1007 0,4,741000 ,2,741000, 1,800.105, 0)
  402   PL ZIP
  403   "BLD",1007 0,4,741000 ,222)
  404   y^y^p^^^^n ^^n
  405   "BLD",1007 0,4,741000 ,224)
  406  
  407   "BLD",1007 0,4,741000 .2,0)
  408   741000.2
  409   "BLD",1007 0,4,741000 .2,2,0)
  410   ^9.641^741 000.35^1
  411   "BLD",1007 0,4,741000 .2,2,74100 0.35,0)
  412   TRACK EDI- PAUSE TIME   (sub-fil e)
  413   "BLD",1007 0,4,741000 .2,2,74100 0.35,1,0)
  414   ^9.6411^^
  415   "BLD",1007 0,4,741000 .2,222)
  416   y^y^p^^^^n ^^n
  417   "BLD",1007 0,4,741000 .2,224)
  418  
  419   "BLD",1007 0,4,741001 ,0)
  420   741001
  421   "BLD",1007 0,4,741001 ,2,0)
  422   ^9.641^741 001^1
  423   "BLD",1007 0,4,741001 ,2,741001, 0)
  424   CHAMPVA VE NDOR  (Fil e-top leve l)
  425   "BLD",1007 0,4,741001 ,2,741001, 1,0)
  426   ^9.6411^8. 02^2
  427   "BLD",1007 0,4,741001 ,2,741001, 1,8.01,0)
  428   DATE INACT IVATED
  429   "BLD",1007 0,4,741001 ,2,741001, 1,8.02,0)
  430   DUPLICATE  CLEANUP US ER
  431   "BLD",1007 0,4,741001 ,222)
  432   y^y^p^^^^n ^^n
  433   "BLD",1007 0,4,741001 ,224)
  434  
  435   "BLD",1007 0,4,"APDD" ,741000,74 1000)
  436  
  437   "BLD",1007 0,4,"APDD" ,741000,74 1000,800.1 05)
  438  
  439   "BLD",1007 0,4,"APDD" ,741000.2, 741000.35)
  440  
  441   "BLD",1007 0,4,"APDD" ,741001,74 1001)
  442  
  443   "BLD",1007 0,4,"APDD" ,741001,74 1001,8.01)
  444  
  445   "BLD",1007 0,4,"APDD" ,741001,74 1001,8.02)
  446  
  447   "BLD",1007 0,4,"B",74 1000,74100 0)
  448  
  449   "BLD",1007 0,4,"B",74 1000.2,741 000.2)
  450  
  451   "BLD",1007 0,4,"B",74 1001,74100 1)
  452  
  453   "BLD",1007 0,6.3)
  454   5
  455   "BLD",1007 0,"INID")
  456   ^n
  457   "BLD",1007 0,"INIT")
  458  
  459   "BLD",1007 0,"KRN",0)
  460   ^9.67PA^1. 5^24
  461   "BLD",1007 0,"KRN",.4 ,0)
  462   .4
  463   "BLD",1007 0,"KRN",.4 01,0)
  464   .401
  465   "BLD",1007 0,"KRN",.4 02,0)
  466   .402
  467   "BLD",1007 0,"KRN",.4 03,0)
  468   .403
  469   "BLD",1007 0,"KRN",.5 ,0)
  470   .5
  471   "BLD",1007 0,"KRN",.8 4,0)
  472   .84
  473   "BLD",1007 0,"KRN",1. 5,0)
  474   1.5
  475   "BLD",1007 0,"KRN",1. 6,0)
  476   1.6
  477   "BLD",1007 0,"KRN",1. 61,0)
  478   1.61
  479   "BLD",1007 0,"KRN",1. 62,0)
  480   1.62
  481   "BLD",1007 0,"KRN",3. 6,0)
  482   3.6
  483   "BLD",1007 0,"KRN",3. 8,0)
  484   3.8
  485   "BLD",1007 0,"KRN",9. 2,0)
  486   9.2
  487   "BLD",1007 0,"KRN",9. 2,"NM",0)
  488   ^9.68A^^
  489   "BLD",1007 0,"KRN",9. 8,0)
  490   9.8
  491   "BLD",1007 0,"KRN",9. 8,"NM",0)
  492   ^9.68A^72^ 72
  493   "BLD",1007 0,"KRN",9. 8,"NM",1,0 )
  494   CHMFADR1^^ 0^B1272422 08
  495   "BLD",1007 0,"KRN",9. 8,"NM",2,0 )
  496   CH835F1^^0 ^B18573909
  497   "BLD",1007 0,"KRN",9. 8,"NM",3,0 )
  498   CH835F2^^0 ^B777476
  499   "BLD",1007 0,"KRN",9. 8,"NM",4,0 )
  500   CH835F3^^0 ^B85763106 1
  501   "BLD",1007 0,"KRN",9. 8,"NM",5,0 )
  502   CH835FU1^^ 0^B9698666 89
  503   "BLD",1007 0,"KRN",9. 8,"NM",6,0 )
  504   CHBPEBSD^^ 0^B1208160 35
  505   "BLD",1007 0,"KRN",9. 8,"NM",7,0 )
  506   CHFBC2A^^0 ^B28422780 1
  507   "BLD",1007 0,"KRN",9. 8,"NM",8,0 )
  508   CHGASP^^0^ B86304290
  509   "BLD",1007 0,"KRN",9. 8,"NM",9,0 )
  510   CHMEAE5^^0 ^B66632491
  511   "BLD",1007 0,"KRN",9. 8,"NM",10, 0)
  512   CHMF351P^^ 0^B1605837 54
  513   "BLD",1007 0,"KRN",9. 8,"NM",11, 0)
  514   CHMFA001^^ 0^B7272813 8
  515   "BLD",1007 0,"KRN",9. 8,"NM",12, 0)
  516   CHMFSTP1E^ ^0^B505458 43
  517   "BLD",1007 0,"KRN",9. 8,"NM",13, 0)
  518   CHMFSTP1F^ ^0^B503165 10
  519   "BLD",1007 0,"KRN",9. 8,"NM",14, 0)
  520   CHMKAG5P^^ 0^B4262182 3
  521   "BLD",1007 0,"KRN",9. 8,"NM",15, 0)
  522   CHMXF001^^ 0^B8363290 0
  523   "BLD",1007 0,"KRN",9. 8,"NM",16, 0)
  524   CHMXF004^^ 0^B3961026 1
  525   "BLD",1007 0,"KRN",9. 8,"NM",17, 0)
  526   CHMXF005^^ 0^B6203322 4
  527   "BLD",1007 0,"KRN",9. 8,"NM",18, 0)
  528   CHMXF006^^ 0^B7946593 5
  529   "BLD",1007 0,"KRN",9. 8,"NM",19, 0)
  530   CHMXF008^^ 0^B6731252 7
  531   "BLD",1007 0,"KRN",9. 8,"NM",20, 0)
  532   CHMXF009^^ 0^B6663252 7
  533   "BLD",1007 0,"KRN",9. 8,"NM",21, 0)
  534   CHMXG001^^ 0^B4419322 6
  535   "BLD",1007 0,"KRN",9. 8,"NM",22, 0)
  536   CHFBCQ^^0^ B206700247
  537   "BLD",1007 0,"KRN",9. 8,"NM",23, 0)
  538   CHFBCUTL^^ 0^B1756305 13
  539   "BLD",1007 0,"KRN",9. 8,"NM",24, 0)
  540   CHGAS22^^0 ^B73431822
  541   "BLD",1007 0,"KRN",9. 8,"NM",25, 0)
  542   CHGASP1^^0 ^B40517172
  543   "BLD",1007 0,"KRN",9. 8,"NM",26, 0)
  544   CHGCDC7^^0 ^B18087010
  545   "BLD",1007 0,"KRN",9. 8,"NM",27, 0)
  546   CHGCDC72^^ 0^B8485507 0
  547   "BLD",1007 0,"KRN",9. 8,"NM",28, 0)
  548   CHGCDV70^^ 0^B8023345 2
  549   "BLD",1007 0,"KRN",9. 8,"NM",29, 0)
  550   CHGCDV73^^ 0^B4105791 8
  551   "BLD",1007 0,"KRN",9. 8,"NM",30, 0)
  552   CHGCP2^^0^ B115611366
  553   "BLD",1007 0,"KRN",9. 8,"NM",31, 0)
  554   CHGCU130^^ 0^B1382719 4
  555   "BLD",1007 0,"KRN",9. 8,"NM",32, 0)
  556   CHGCU133^^ 0^B4083828 6
  557   "BLD",1007 0,"KRN",9. 8,"NM",33, 0)
  558   CHGCU136^^ 0^B3819513 4
  559   "BLD",1007 0,"KRN",9. 8,"NM",34, 0)
  560   CHGCU137^^ 0^B9099207 7
  561   "BLD",1007 0,"KRN",9. 8,"NM",35, 0)
  562   CHGDQ2^^0^ B156001132
  563   "BLD",1007 0,"KRN",9. 8,"NM",36, 0)
  564   CHGVQ370^^ 0^B1935889 07
  565   "BLD",1007 0,"KRN",9. 8,"NM",37, 0)
  566   CHGVQ374^^ 0^B5243092 0
  567   "BLD",1007 0,"KRN",9. 8,"NM",38, 0)
  568   CHGVQ529^^ 0^B9657334 0
  569   "BLD",1007 0,"KRN",9. 8,"NM",39, 0)
  570   CHGVQ600^^ 0^B5007732 1
  571   "BLD",1007 0,"KRN",9. 8,"NM",40, 0)
  572   CHICDAA^^0 ^B21795998
  573   "BLD",1007 0,"KRN",9. 8,"NM",41, 0)
  574   CHMF211^^0 ^B19437100
  575   "BLD",1007 0,"KRN",9. 8,"NM",42, 0)
  576   CHMF351D^^ 0^B9200541 6
  577   "BLD",1007 0,"KRN",9. 8,"NM",43, 0)
  578   CHMFA010^^ 0^B1832881 12
  579   "BLD",1007 0,"KRN",9. 8,"NM",44, 0)
  580   CHMFA011^^ 0^B1096412 27
  581   "BLD",1007 0,"KRN",9. 8,"NM",45, 0)
  582   CHMFA01D^^ 0^B5815956
  583   "BLD",1007 0,"KRN",9. 8,"NM",46, 0)
  584   CHMFA01E^^ 0^B5618565 5
  585   "BLD",1007 0,"KRN",9. 8,"NM",47, 0)
  586   CHMFA117^^ 0^B1860511 8
  587   "BLD",1007 0,"KRN",9. 8,"NM",48, 0)
  588   CHMFA141^^ 0^B1271109 246
  589   "BLD",1007 0,"KRN",9. 8,"NM",49, 0)
  590   CHMFA14V^^ 0^B1259638 550
  591   "BLD",1007 0,"KRN",9. 8,"NM",50, 0)
  592   CHMFA161^^ 0^B1252687 10
  593   "BLD",1007 0,"KRN",9. 8,"NM",51, 0)
  594   CHMFA171^^ 0^B1444626 87
  595   "BLD",1007 0,"KRN",9. 8,"NM",52, 0)
  596   CHMFA181^^ 0^B1447490 04
  597   "BLD",1007 0,"KRN",9. 8,"NM",53, 0)
  598   CHMFA802^^ 0^B6512433 2
  599   "BLD",1007 0,"KRN",9. 8,"NM",54, 0)
  600   CHMFADR4^^ 0^B2679348 73
  601   "BLD",1007 0,"KRN",9. 8,"NM",55, 0)
  602   CHMFAUT5^^ 0^B869373
  603   "BLD",1007 0,"KRN",9. 8,"NM",56, 0)
  604   CHMFAUT6^^ 0^B1987343 0
  605   "BLD",1007 0,"KRN",9. 8,"NM",57, 0)
  606   CHMFAUT7^^ 0^B5618857 12
  607   "BLD",1007 0,"KRN",9. 8,"NM",58, 0)
  608   CHMFAUT8^^ 0^B8244039 3
  609   "BLD",1007 0,"KRN",9. 8,"NM",59, 0)
  610   CHMFCLNC^^ 0^B1633009
  611   "BLD",1007 0,"KRN",9. 8,"NM",60, 0)
  612   CHMFSRT^^0 ^B24434762
  613   "BLD",1007 0,"KRN",9. 8,"NM",61, 0)
  614   CHMFUTLE^^ 0^B2350521 5
  615   "BLD",1007 0,"KRN",9. 8,"NM",62, 0)
  616   CHMFUTLE2^ ^0^B803265 3
  617   "BLD",1007 0,"KRN",9. 8,"NM",63, 0)
  618   CHMXPU04^^ 0^B3682074 16
  619   "BLD",1007 0,"KRN",9. 8,"NM",64, 0)
  620   CHMXPU041^ ^0^B332153 380
  621   "BLD",1007 0,"KRN",9. 8,"NM",65, 0)
  622   CHMXWB21^^ 0^B1706402 409
  623   "BLD",1007 0,"KRN",9. 8,"NM",66, 0)
  624   CHMXWB24^^ 0^B1987793 79
  625   "BLD",1007 0,"KRN",9. 8,"NM",67, 0)
  626   CHMXWBUT^^ 0^B2928193
  627   "BLD",1007 0,"KRN",9. 8,"NM",68, 0)
  628   CHPRD1^^0^ B36462532
  629   "BLD",1007 0,"KRN",9. 8,"NM",69, 0)
  630   CHRPBAR21^ ^0^B159935 77
  631   "BLD",1007 0,"KRN",9. 8,"NM",70, 0)
  632   CHGASIP^^0 ^B60716419
  633   "BLD",1007 0,"KRN",9. 8,"NM",71, 0)
  634   CHGQA2^^0^ B105635204
  635   "BLD",1007 0,"KRN",9. 8,"NM",72, 0)
  636   CHROLIB1^^ 0^B7079952 2
  637   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CH835F1" ,2)
  638  
  639   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CH835F2" ,3)
  640  
  641   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CH835F3" ,4)
  642  
  643   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CH835FU1 ",5)
  644  
  645   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHBPEBSD ",6)
  646  
  647   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHFBC2A" ,7)
  648  
  649   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHFBCQ", 22)
  650  
  651   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHFBCUTL ",23)
  652  
  653   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGAS22" ,24)
  654  
  655   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGASIP" ,70)
  656  
  657   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGASP", 8)
  658  
  659   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGASP1" ,25)
  660  
  661   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCDC7" ,26)
  662  
  663   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCDC72 ",27)
  664  
  665   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCDV70 ",28)
  666  
  667   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCDV73 ",29)
  668  
  669   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCP2", 30)
  670  
  671   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCU130 ",31)
  672  
  673   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCU133 ",32)
  674  
  675   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCU136 ",33)
  676  
  677   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGCU137 ",34)
  678  
  679   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGDQ2", 35)
  680  
  681   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGQA2", 71)
  682  
  683   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGVQ370 ",36)
  684  
  685   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGVQ374 ",37)
  686  
  687   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGVQ529 ",38)
  688  
  689   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHGVQ600 ",39)
  690  
  691   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHICDAA" ,40)
  692  
  693   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMEAE5" ,9)
  694  
  695   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMF211" ,41)
  696  
  697   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMF351D ",42)
  698  
  699   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMF351P ",10)
  700  
  701   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA001 ",11)
  702  
  703   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA010 ",43)
  704  
  705   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA011 ",44)
  706  
  707   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA01D ",45)
  708  
  709   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA01E ",46)
  710  
  711   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA117 ",47)
  712  
  713   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA141 ",48)
  714  
  715   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA14V ",49)
  716  
  717   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA161 ",50)
  718  
  719   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA171 ",51)
  720  
  721   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA181 ",52)
  722  
  723   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFA802 ",53)
  724  
  725   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFADR1 ",1)
  726  
  727   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFADR4 ",54)
  728  
  729   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFAUT5 ",55)
  730  
  731   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFAUT6 ",56)
  732  
  733   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFAUT7 ",57)
  734  
  735   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFAUT8 ",58)
  736  
  737   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFCLNC ",59)
  738  
  739   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFSRT" ,60)
  740  
  741   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFSTP1 E",12)
  742  
  743   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFSTP1 F",13)
  744  
  745   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFUTLE ",61)
  746  
  747   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMFUTLE 2",62)
  748  
  749   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMKAG5P ",14)
  750  
  751   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXF001 ",15)
  752  
  753   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXF004 ",16)
  754  
  755   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXF005 ",17)
  756  
  757   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXF006 ",18)
  758  
  759   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXF008 ",19)
  760  
  761   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXF009 ",20)
  762  
  763   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXG001 ",21)
  764  
  765   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXPU04 ",63)
  766  
  767   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXPU04 1",64)
  768  
  769   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXWB21 ",65)
  770  
  771   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXWB24 ",66)
  772  
  773   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHMXWBUT ",67)
  774  
  775   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHPRD1", 68)
  776  
  777   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHROLIB1 ",72)
  778  
  779   "BLD",1007 0,"KRN",9. 8,"NM","B" ,"CHRPBAR2 1",69)
  780  
  781   "BLD",1007 0,"KRN",19 ,0)
  782   19
  783   "BLD",1007 0,"KRN",19 .1,0)
  784   19.1
  785   "BLD",1007 0,"KRN",10 1,0)
  786   101
  787   "BLD",1007 0,"KRN",40 9.61,0)
  788   409.61
  789   "BLD",1007 0,"KRN",77 1,0)
  790   771
  791   "BLD",1007 0,"KRN",77 9.2,0)
  792   779.2
  793   "BLD",1007 0,"KRN",87 0,0)
  794   870
  795   "BLD",1007 0,"KRN",89 89.51,0)
  796   8989.51
  797   "BLD",1007 0,"KRN",89 89.52,0)
  798   8989.52
  799   "BLD",1007 0,"KRN",89 94,0)
  800   8994
  801   "BLD",1007 0,"KRN","B ",.4,.4)
  802  
  803   "BLD",1007 0,"KRN","B ",.401,.40 1)
  804  
  805   "BLD",1007 0,"KRN","B ",.402,.40 2)
  806  
  807   "BLD",1007 0,"KRN","B ",.403,.40 3)
  808  
  809   "BLD",1007 0,"KRN","B ",.5,.5)
  810  
  811   "BLD",1007 0,"KRN","B ",.84,.84)
  812  
  813   "BLD",1007 0,"KRN","B ",1.5,1.5)
  814  
  815   "BLD",1007 0,"KRN","B ",1.6,1.6)
  816  
  817   "BLD",1007 0,"KRN","B ",1.61,1.6 1)
  818  
  819   "BLD",1007 0,"KRN","B ",1.62,1.6 2)
  820  
  821   "BLD",1007 0,"KRN","B ",3.6,3.6)
  822  
  823   "BLD",1007 0,"KRN","B ",3.8,3.8)
  824  
  825   "BLD",1007 0,"KRN","B ",9.2,9.2)
  826  
  827   "BLD",1007 0,"KRN","B ",9.8,9.8)
  828  
  829   "BLD",1007 0,"KRN","B ",19,19)
  830  
  831   "BLD",1007 0,"KRN","B ",19.1,19. 1)
  832  
  833   "BLD",1007 0,"KRN","B ",101,101)
  834  
  835   "BLD",1007 0,"KRN","B ",409.61,4 09.61)
  836  
  837   "BLD",1007 0,"KRN","B ",771,771)
  838  
  839   "BLD",1007 0,"KRN","B ",779.2,77 9.2)
  840  
  841   "BLD",1007 0,"KRN","B ",870,870)
  842  
  843   "BLD",1007 0,"KRN","B ",8989.51, 8989.51)
  844  
  845   "BLD",1007 0,"KRN","B ",8989.52, 8989.52)
  846  
  847   "BLD",1007 0,"KRN","B ",8994,899 4)
  848  
  849   "BLD",1007 0,"QDEF")
  850   ^^^^NO^^^^ NO^^NO
  851   "BLD",1007 0,"QUES",0 )
  852   ^9.62^^
  853   "BLD",1007 0,"REQB",0 )
  854   ^9.611^^
  855   "FIA",7410 00)
  856   CHAMPVA CL AIMS
  857   "FIA",7410 00,0)
  858   ^CHMPAY(
  859   "FIA",7410 00,0,0)
  860   741000
  861   "FIA",7410 00,0,1)
  862   y^y^p^^^^n ^^n
  863   "FIA",7410 00,0,10)
  864  
  865   "FIA",7410 00,0,11)
  866  
  867   "FIA",7410 00,0,"RLRO ")
  868  
  869   "FIA",7410 00,741000)
  870   1
  871   "FIA",7410 00,741000, 800.105)
  872  
  873   "FIA",7410 00.2)
  874   CHAMPVA ST ORED IMAGE S
  875   "FIA",7410 00.2,0)
  876   ^CHMIMG(
  877   "FIA",7410 00.2,0,0)
  878   741000.2
  879   "FIA",7410 00.2,0,1)
  880   y^y^p^^^^n ^^n
  881   "FIA",7410 00.2,0,10)
  882  
  883   "FIA",7410 00.2,0,11)
  884  
  885   "FIA",7410 00.2,0,"RL RO")
  886  
  887   "FIA",7410 00.2,74100 0.2)
  888   1
  889   "FIA",7410 00.2,74100 0.2,45)
  890  
  891   "FIA",7410 00.2,74100 0.35)
  892   0
  893   "FIA",7410 00.2,74100 0.353)
  894   0
  895   "FIA",7410 01)
  896   CHAMPVA VE NDOR
  897   "FIA",7410 01,0)
  898   ^CHMVEN(
  899   "FIA",7410 01,0,0)
  900   741001
  901   "FIA",7410 01,0,1)
  902   y^y^p^^^^n ^^n
  903   "FIA",7410 01,0,10)
  904  
  905   "FIA",7410 01,0,11)
  906  
  907   "FIA",7410 01,0,"RLRO ")
  908  
  909   "FIA",7410 01,741001)
  910   1
  911   "FIA",7410 01,741001, 8.01)
  912  
  913   "FIA",7410 01,741001, 8.02)
  914  
  915   "MBREQ")
  916   0
  917   "QUES","XP F1",0)
  918   Y
  919   "QUES","XP F1","??")
  920   ^D REP^XPD H
  921   "QUES","XP F1","A")
  922   Shall I wr ite over y our |FLAG|  File
  923   "QUES","XP F1","B")
  924   YES
  925   "QUES","XP F1","M")
  926   D XPF1^XPD IQ
  927   "QUES","XP F2",0)
  928   Y
  929   "QUES","XP F2","??")
  930   ^D DTA^XPD H
  931   "QUES","XP F2","A")
  932   Want my da ta |FLAG|  yours
  933   "QUES","XP F2","B")
  934   YES
  935   "QUES","XP F2","M")
  936   D XPF2^XPD IQ
  937   "QUES","XP I1",0)
  938   YO
  939   "QUES","XP I1","??")
  940   ^D INHIBIT ^XPDH
  941   "QUES","XP I1","A")
  942   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  943   "QUES","XP I1","B")
  944   NO
  945   "QUES","XP I1","M")
  946   D XPI1^XPD IQ
  947   "QUES","XP M1",0)
  948   PO^VA(200, :EM
  949   "QUES","XP M1","??")
  950   ^D MG^XPDH
  951   "QUES","XP M1","A")
  952   Enter the  Coordinato r for Mail  Group '|F LAG|'
  953   "QUES","XP M1","B")
  954  
  955   "QUES","XP M1","M")
  956   D XPM1^XPD IQ
  957   "QUES","XP O1",0)
  958   Y
  959   "QUES","XP O1","??")
  960   ^D MENU^XP DH
  961   "QUES","XP O1","A")
  962   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  963   "QUES","XP O1","B")
  964   NO
  965   "QUES","XP O1","M")
  966   D XPO1^XPD IQ
  967   "QUES","XP Z1",0)
  968   Y
  969   "QUES","XP Z1","??")
  970   ^D OPT^XPD H
  971   "QUES","XP Z1","A")
  972   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  973   "QUES","XP Z1","B")
  974   NO
  975   "QUES","XP Z1","M")
  976   D XPZ1^XPD IQ
  977   "QUES","XP Z2",0)
  978   Y
  979   "QUES","XP Z2","??")
  980   ^D RTN^XPD H
  981   "QUES","XP Z2","A")
  982   Want to MO VE routine s to other  CPUs
  983   "QUES","XP Z2","B")
  984   NO
  985   "QUES","XP Z2","M")
  986   D XPZ2^XPD IQ
  987   "RTN")
  988   72
  989   "RTN","CH8 35F1")
  990   0^2^B18573 909
  991   "RTN","CH8 35F1",1,0)
  992   CH835F1 ;H AC/AEB;EDI  835 FILE; Feb 06, 20 19@10:53:0 8
  993   "RTN","CH8 35F1",2,0)
  994    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  995   "RTN","CH8 35F1",3,0)
  996    ;HR-PBM-P HASE 1B-Be gin;;;;;Bu ild 17
  997   "RTN","CH8 35F1",4,0)
  998    ;HR - Tea m Track #:  5592
  999   "RTN","CH8 35F1",5,0)
  1000    ;HR - New  835 Routi ne that re places the  old CHEDI * Routines
  1001   "RTN","CH8 35F1",6,0)
  1002    ;DEV00422 5 1/21/201 0 AEB
  1003   "RTN","CH8 35F1",7,0)
  1004    ; 8/27-28 /2012  MAD E FUNCTION  CALLS FOR  THE RECOR D GENERATI ON BLOCKS  (HDR,BPR,T RN,PLB)
  1005   "RTN","CH8 35F1",8,0)
  1006    ; 10/11/1 2 DLB  DEV 7820 REFAC TORED THE  RECORD GEN ERATION TO  TABLE DRI VEN PROCES S.
  1007   "RTN","CH8 35F1",9,0)
  1008    ; 1/9/201 3 DLB  DEV 7820 MODIF IED FMSLOO P() FUNCTI ON TO PERF ORM STATUS  UPDATES W HEN RECORD
  1009   "RTN","CH8 35F1",10,0 )
  1010    ;                         IS WR ITTEN TO T HE 835 FIL E. (UPDSTA TUS(I))
  1011   "RTN","CH8 35F1",11,0 )
  1012    ; 3/2013  DLB    BAL CHK(PAYI,E DII) REPLA CED WITH T HE CH835BA L.INT ROUT INES TO PE RFORM LINE
  1013   "RTN","CH8 35F1",12,0 )
  1014    ;                         AND C LAIM LEVEL  BALANCE C HECKS
  1015   "RTN","CH8 35F1",13,0 )
  1016    ; 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
  1017   "RTN","CH8 35F1",14,0 )
  1018    ;                        ORIGIN ALLY THOUG HT
  1019   "RTN","CH8 35F1",15,0 )
  1020    ; 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
  1021   "RTN","CH8 35F1",16,0 )
  1022    ;                        NOT BE  "NULL" IN  THE "TRN"  RECORD, F IELD 4
  1023   "RTN","CH8 35F1",17,0 )
  1024    ; 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
  1025   "RTN","CH8 35F1",18,0 )
  1026    ; 07/17/2 014  JAK   CONSOLIDAT ED DED / C AT CAP ADJ USTMENT RO UTINES
  1027   "RTN","CH8 35F1",19,0 )
  1028    ; 12/3/15  SLT MODIF IED TO CHE CK FOR A C LAIM LEVEL  PAID AMOU NT <1$ AND  USE CARC  B5
  1029   "RTN","CH8 35F1",20,0 )
  1030    ;              ALSO  CHECKING F OR ACTIVE  CARCs AND  RARCs
  1031   "RTN","CH8 35F1",21,0 )
  1032    ;MTN02864 8: issue w ith the "B PR" and "S VC" record s needs 9.   DRW 06/1 3/2017
  1033   "RTN","CH8 35F1",22,0 )
  1034    ;MTN02877 2: CHANGIN G ALL LINE S EXCEEDIN G 255 TO L ESS THAN T HIS.  DRW  07/27/2017
  1035   "RTN","CH8 35F1",23,0 )
  1036    ; 02/21/2 018 SBB CC 4002-001,  CC4002-002 , CC4002-0 03 updates  for Rever sal 835 me ssage
  1037   "RTN","CH8 35F1",24,0 )
  1038    ; 05/14/2 018 DLB AD DED CHECK  FOR "AGING " PDIs IN  CHK5010();  PDIs OVER  180 DAYS  IN THE
  1039   "RTN","CH8 35F1",25,0 )
  1040    ;                        PAST A RE REMOVED  FROM THE  "NEEDS SEN T" QUEUE
  1041   "RTN","CH8 35F1",26,0 )
  1042    ; 5/23/20 18  DLB AD DED THE JU LIAN TO FI LEMAN DATE  CONVERSIO N FUNCTION  AS THE FU NCTION
  1043   "RTN","CH8 35F1",27,0 )
  1044    ;                        PREVIO USLY RESID ED IN CHFM LIB1.INT,  WHICH IS N OT IN TEST /PROD
  1045   "RTN","CH8 35F1",28,0 )
  1046    ; 5/23/20 18  DLB RE MOVED REV8 35 VARIABL E FROM THE  CODE:
  1047   "RTN","CH8 35F1",29,0 )
  1048    ; RFE 01/ 09/19 INC3 837109 Add  reporting  mechanism
  1049   "RTN","CH8 35F1",30,0 )
  1050    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  1051   "RTN","CH8 35F1",31,0 )
  1052    ;
  1053   "RTN","CH8 35F1",32,0 )
  1054    Q
  1055   "RTN","CH8 35F1",33,0 )
  1056    ;
  1057   "RTN","CH8 35F1",34,0 )
  1058    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  1059   "RTN","CH8 35F1",35,0 )
  1060    ; SORT IS  CALLED BY  THE CH835 DRV ROUTIN E, IN THE  MAIN() FUN CTION.
  1061   "RTN","CH8 35F1",36,0 )
  1062    ; THIS FU NCTION CRE ATES THE ^ TMP($J,"ED I-835",CLE ARINGHOUSE  ID,^CHMED I(I)) ARRA Y
  1063   "RTN","CH8 35F1",37,0 )
  1064    ; 1) KILL  THE EXIST ING ^TMP($ J,"EDI-835 ") ARRAY ( TARGET ARR AY FOR ^CH MEDI(I)
  1065   "RTN","CH8 35F1",38,0 )
  1066    ;      IN DEXES READ Y FOR 835  PROCESSING )
  1067   "RTN","CH8 35F1",39,0 )
  1068    ; 2) LOOP  THROUGH T HE ^CHMEDI ("G") XREF , RETRIEVI NG ^CHMEDI (I) INDEX  FOR
  1069   "RTN","CH8 35F1",40,0 )
  1070    ;      EN TRIES MATC HING THE F ILE NUMBER  PROVIDED.
  1071   "RTN","CH8 35F1",41,0 )
  1072    ; 3) RETR IEVE THE ^ CHMPAY(I)  INDEX
  1073   "RTN","CH8 35F1",42,0 )
  1074    ; 4) VERI FY THE CLA IM CREATIO N DATE
  1075   "RTN","CH8 35F1",43,0 )
  1076    ;      EX IT IF NOCL EAIM CREAT ION DATE
  1077   "RTN","CH8 35F1",44,0 )
  1078    ; 5) SAVE  ANY CREAT ION DATES  TO ^CHMZHO LD() PRIOR  TO 303101 6
  1079   "RTN","CH8 35F1",45,0 )
  1080    ; 6) CHEC K THE JULI AN DATE FO R PDI, IF  PRIOR TO 2 013133 OR  4010 CLAIM , SKIP 835  PROCESSIN G
  1081   "RTN","CH8 35F1",46,0 )
  1082    ; 7) IF T HE CLAIM W AS REJECTE D, CLEAR P AYMENT, CA T CAP, AND  DEDUCTIBL E AMOUNTS
  1083   "RTN","CH8 35F1",47,0 )
  1084    ; 8) SET  THE CLEARI NGHOUSE ID  (CHPID) A ND ^CHMEDI (I) VALUES  INTO THE
  1085   "RTN","CH8 35F1",48,0 )
  1086    ;      ^T MP($J,"EDI -835",CHPI D,EDII) FO R THE NEXT  PROCESSIN G STEP
  1087   "RTN","CH8 35F1",49,0 )
  1088    ; 9) NOTE  THAT THE  CHPID VALU E IS STORE D DURING T HE SORT SO  THAT DENT AL
  1089   "RTN","CH8 35F1",50,0 )
  1090    ;    CLAI MS THAT AR E SUBMITTE D WITH THE  MEDICAL C LAIMS CAN  BE EXTRACT ED LATER.
  1091   "RTN","CH8 35F1",51,0 )
  1092    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  1093   "RTN","CH8 35F1",52,0 )
  1094    ;
  1095   "RTN","CH8 35F1",53,0 )
  1096   SORT(FILEI ) ; Sort F MS_ID's by  payor and  load into  ^TMP glob al
  1097   "RTN","CH8 35F1",54,0 )
  1098    ; FILEI N EWLY CREAT ED INDEX T O ^CHMEDIF () FILE
  1099   "RTN","CH8 35F1",55,0 )
  1100    N EDII,ED IJ,PAYI,CI CMPDT,CNT, CHPID,PDI, VERDATE,CL MCRDATE
  1101   "RTN","CH8 35F1",56,0 )
  1102    S X=132 X  ^%ZOSF("R M")                                                                                ; SE T THE CACH E DISPLAY  TO 132 CHA RACTERS
  1103   "RTN","CH8 35F1",57,0 )
  1104    K ^TMP($J ,"EDI-835" )
  1105   "RTN","CH8 35F1",58,0 )
  1106    S EDII=0, CNT=0,CHPI D=0
  1107   "RTN","CH8 35F1",59,0 )
  1108    F  S EDII =$O(^CHMED I("G",FILE I,EDII)) Q :(+(EDII)= 0)  D                   ; LOOP T HRU THE "E DI 835 FIL E #"s
  1109   "RTN","CH8 35F1",60,0 )
  1110    .S CICMPD T=""
  1111   "RTN","CH8 35F1",61,0 )
  1112    .S EDIJ=0
  1113   "RTN","CH8 35F1",62,0 )
  1114    .F  S EDI J=$O(^CHME DI(EDII,1, EDIJ)) Q:+ (EDIJ)=0   Q:(CHPID=" ")  D   ;  LOOP THRU  "J" INDEXE S
  1115   "RTN","CH8 35F1",63,0 )
  1116    ..S PAYI= $P($G(^CHM EDI(EDII,1 ,EDIJ,0)), "^",1)                    ; RETR IEVING THE  POINTER-> ^CHMPAY()
  1117   "RTN","CH8 35F1",64,0 )
  1118    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !!,"P AYI VALUE  RETRIEVED:  ",PAYI
  1119   "RTN","CH8 35F1",65,0 )
  1120    ..Q:'PAYI                                                                                                        ; IF N O PAYI IN  ^CHMEDI, S KIP THE CL AIM QUEUE
  1121   "RTN","CH8 35F1",66,0 )
  1122    ..Q:'$$JU LIANDT^CH8 35TMP(PAYI )                                                              ;  RUN ONE DA Y'S CLAIMS  AT A TIME
  1123   "RTN","CH8 35F1",67,0 )
  1124    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"PR OCESSING P AYI: ",PAY I
  1125   "RTN","CH8 35F1",68,0 )
  1126    ..I '$D(G LPAY) D                                                                                       ; MU ST ENSURE  GLPAY IS D EFINED, FU NCTION NEE DS X1=PAYI
  1127   "RTN","CH8 35F1",69,0 )
  1128    ...S X1=P AYI D PROG TYP^CHFCD0 01                                                     ; DSLA FUN CTION NEED S @GLPAY I NDIRECTION  POINTER S ET UP
  1129   "RTN","CH8 35F1",70,0 )
  1130    ..;Q:'$$D SLA^CHTFLI B2(PAYI)                                                          ; DO NOT Q UEUE PRE-S LA CLAIMS  UNTIL LATE R DATE DLB  12/10/201 3
  1131   "RTN","CH8 35F1",71,0 )
  1132    ..S CHPID =$$CHPID^C H835FU1(PA YI)                                                    ; RETRIEVE  CLAIM BUF FER INDEXE S FOR MEDI CAL/PHARMA CY
  1133   "RTN","CH8 35F1",72,0 )
  1134    ..S:$D(^C HMPAY(PAYI ,0)) CICMP DT=$P(^CHM PAY(PAYI,0 ),"^",25)   ; GET THE  CLAIM CRE ATION DATE
  1135   "RTN","CH8 35F1",73,0 )
  1136    ..Q:CICMP DT=""
  1137   "RTN","CH8 35F1",74,0 )
  1138    ..S:CICMP DT<3031016  ^CHMZHOLD ("835_PRE- HIPAA_CLM" ,PAYI,FILE I,EDII)=""  ;RECORD B AD CREATIO N DATE
  1139   "RTN","CH8 35F1",75,0 )
  1140    ..Q:CICMP DT<3031016
  1141   "RTN","CH8 35F1",76,0 )
  1142    ..S VERDA TE=$$CHK50 10(PAYI)                                        ; VALI DATE 5010  CLAIM AND  PDI IS IN  THE "ACTIV E RANGE"
  1143   "RTN","CH8 35F1",77,0 )
  1144    ..I 'VERD ATE  D  Q                                                                    ; 0 INDICA TES FAILED  VALIDATIO N FOR CHK5 010
  1145   "RTN","CH8 35F1",78,0 )
  1146    ...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!"
  1147   "RTN","CH8 35F1",79,0 )
  1148    ...D SETA SIDE(EDII)                                                          ; DLB 5/ 14/2018SET  ASIDE THE  CLAIM FOR  THE ^CHME DI(PAYI)
  1149   "RTN","CH8 35F1",80,0 )
  1150    ..I '$D(G LPAY) S X1 =PAYI D PR OGTYP^CHFC D001    ;  DLB 7/11/2 013DEV0078 20 SETS GL PAY IF NOT  DEFINED.
  1151   "RTN","CH8 35F1",81,0 )
  1152    ..I $P(^C HMPAY(PAYI ,0),"^",2) =0 D                                 ; if c laim rejec ted
  1153   "RTN","CH8 35F1",82,0 )
  1154    ...D CLRP MT^CHTFLIB 2(PAYI)                                         ; clea r payment  data
  1155   "RTN","CH8 35F1",83,0 )
  1156    ...I $D(^ CHMPAY(PAY I,1))  D
  1157   "RTN","CH8 35F1",84,0 )
  1158    ....I ($P (^CHMPAY(P AYI,1),"^" ,5)'=""!($ P(^CHMPAY( PAYI,1),"^ ",6)'=""))  D
  1159   "RTN","CH8 35F1",85,0 )
  1160    .....D AD J^CHGRCCD( PAYI,"SUB" )                                             ; revers e cat cap  / deductib le data ;D EV021244 J AK 07/17/1 4
  1161   "RTN","CH8 35F1",86,0 )
  1162    .....D CL RCCD^CHTFL IB2(PAYI)                                       ; clea r cat cap  / deductib le data
  1163   "RTN","CH8 35F1",87,0 )
  1164    ..S ^TMP( $J,"EDI-83 5",CHPID,E DII)="",CN T=CNT+1                            ; SET TH E ^TMP ARR AY WITH ED I POINTERS
  1165   "RTN","CH8 35F1",88,0 )
  1166    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"F1 : SORT: HA C CLAIM #:  ",$P(^CHM PAY(PAYI,0 ),"^",1),"  QUEUED."
  1167   "RTN","CH8 35F1",89,0 )
  1168    Q
  1169   "RTN","CH8 35F1",90,0 )
  1170    ;
  1171   "RTN","CH8 35F1",91,0 )
  1172    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  1173   "RTN","CH8 35F1",92,0 )
  1174    ; CHK5010  IS BOOLEA N CHECK FO R 5010 CLA IMS (DO NO T QUEUE 40 10 CLAIMS  or
  1175   "RTN","CH8 35F1",93,0 )
  1176    ; 5010 CL AIMS PROCE SSED PRIOR  TO SLA UA T LOADS) P ER BUSINES S, JULIAN  DATE 20131 33
  1177   "RTN","CH8 35F1",94,0 )
  1178    ; IS THE  START OF U AT LOADS.
  1179   "RTN","CH8 35F1",95,0 )
  1180    ; ROUTINE  WILL FAIL  FOR NON-5 010 VERSIO N FLAG, OR  IF THE CR OSS-REFERE NCE
  1181   "RTN","CH8 35F1",96,0 )
  1182    ; VALUES  CANNOT BE  SUCCESSFUL LY EXTRACT ED
  1183   "RTN","CH8 35F1",97,0 )
  1184    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  1185   "RTN","CH8 35F1",98,0 )
  1186    ;
  1187   "RTN","CH8 35F1",99,0 )
  1188   CHK5010(PA YI)
  1189   "RTN","CH8 35F1",100, 0)
  1190    N PDI,PCN ,XI,IDXSTR ,VERFLG,EN V,PDIDATE, TODAY,ELAP SED,CUTOFF
  1191   "RTN","CH8 35F1",101, 0)
  1192    ;S ENV=$$ ENVIR^CHTF LIB                                                                       ;  GET THE CU RRENT ENVI RONMENT ID
  1193   "RTN","CH8 35F1",102, 0)
  1194    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1)                        ; RETR IEVE THE P DI FROM ^C HMPAY
  1195   "RTN","CH8 35F1",103, 0)
  1196    S PDIDATE =$E(PDI,1, 7)                                                                ; CCYYDDD  DATE
  1197   "RTN","CH8 35F1",104, 0)
  1198    Q:PDIDATE <2013133 0                                                                   ; SLA UAT  LOAD START  DATE
  1199   "RTN","CH8 35F1",105, 0)
  1200    Q:'$$CHKP DI(PDI) 0                                                                            ;  CHECK PDI  AGAINST TH E CUTOFF D ATE
  1201   "RTN","CH8 35F1",106, 0)
  1202    S PCN=0,P CN=$O(^CHM XCLE("PDI" ,PDI,PCN))                           ; EXTR ACT THE PC N VALUE
  1203   "RTN","CH8 35F1",107, 0)
  1204    Q:(PCN=0) !(PCN="")  0                                                                 ; INVALID  CROSS-REFE RENCE FAIL
  1205   "RTN","CH8 35F1",108, 0)
  1206    S XI=0,XI =$O(^CHMXC LE("PDI",P DI,PCN,XI) )
  1207   "RTN","CH8 35F1",109, 0)
  1208    Q:XI=0                                                                                                           ; INVA LID CROSS- REFERENCE:  FAIL
  1209   "RTN","CH8 35F1",110, 0)
  1210    S IDXSTR= 0,IDXSTR=$ O(^CHMXCLE ("PDI",PDI ,PCN,XI,ID XSTR))
  1211   "RTN","CH8 35F1",111, 0)
  1212    Q:IDXSTR= "" 0                                                                                 ;  INVALID CR OSS-REFERE NCE: FAIL
  1213   "RTN","CH8 35F1",112, 0)
  1214    S AI=$P(I DXSTR,"*", 1)                                                                        ;  TRANSACTIO N BUFFER
  1215   "RTN","CH8 35F1",113, 0)
  1216    Q:AI=0 0                                                                                                ; IN VALID INDE X: FAIL
  1217   "RTN","CH8 35F1",114, 0)
  1218    S VERFLG= $P(^CHMXCL A(AI,0),"^ ",13)                                         ; VERSIO N FLAG
  1219   "RTN","CH8 35F1",115, 0)
  1220    Q $E(VERF LG,1,6)="0 05010"                                                            ; RETURN V ALID/INVAL ID 5010 CH ECK
  1221   "RTN","CH8 35F1",116, 0)
  1222    ;
  1223   "RTN","CH8 35F1",117, 0)
  1224    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1225   "RTN","CH8 35F1",118, 0)
  1226    ; CHKPDI( PDI) RETUR NS TRUE IF  THE PDI D ATE IS WIT HIN A CUTO FF WINDOW  OF
  1227   "RTN","CH8 35F1",119, 0)
  1228    ; THE LAS T 180 DAYS  (TODAY-18 0 DAYS); F ALSE IF OU TSIDE THE  WINDOW
  1229   "RTN","CH8 35F1",120, 0)
  1230    ; THE ^%D TC FUNCTIO N PROVIDES  THE CALCU LATION FOR :
  1231   "RTN","CH8 35F1",121, 0)
  1232    ; PDI DAT E (IN FM F ORMAT) - C UTOFF DATE  (FM)
  1233   "RTN","CH8 35F1",122, 0)
  1234    ; A POSIT IVE RESULT  INDICATES  THE PDI D ATE > CUTO FF DATE; C ONTINUE
  1235   "RTN","CH8 35F1",123, 0)
  1236    ; A NEGAT IVE RESULT  INDICATES  THE PDI D ATE IS BEF ORE CUTOFF ; SET CLAI M ASIDE
  1237   "RTN","CH8 35F1",124, 0)
  1238    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1239   "RTN","CH8 35F1",125, 0)
  1240    ;
  1241   "RTN","CH8 35F1",126, 0)
  1242   CHKPDI(PDI )
  1243   "RTN","CH8 35F1",127, 0)
  1244    ; PDI  TH E PDI OF I NTEREST IN  THE 835 P ROCESS
  1245   "RTN","CH8 35F1",128, 0)
  1246    N FMDATE, CUTFM,PDID ATE
  1247   "RTN","CH8 35F1",129, 0)
  1248    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHKPDI (): PDI= " ,PDI
  1249   "RTN","CH8 35F1",130, 0)
  1250    S PDIDATE =$E(PDI,1, 7)                                                                ; EXTRACT  THE PDI DA TE
  1251   "RTN","CH8 35F1",131, 0)
  1252    D NOW^%DT C
  1253   "RTN","CH8 35F1",132, 0)
  1254    S FMDATE= X                                                                                             ; GE T TODAY'S  DATE IN FM  FORMAT (Y YYDDD)
  1255   "RTN","CH8 35F1",133, 0)
  1256    S CUTOFF= $$CALCWIN( FMDATE)                                                           ; CALCULAT E THE CUTO FF WINDOW  (FM FORMAT ) FOR QUEU EING 835s
  1257   "RTN","CH8 35F1",134, 0)
  1258    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHKPDI (): TODAY  (FM): ",FM DATE," -18 0 DAYS = C UTOFF (FM) = ",CUTOFF
  1259   "RTN","CH8 35F1",135, 0)
  1260    S PDIFM=$ $PDI2FM(PD IDATE)                                                            ; GET PDI  DATE INTO  FM EQUIVAL ENT
  1261   "RTN","CH8 35F1",136, 0)
  1262    U 0 W:$$E NVIR^CHTFL IB="LIVE"  !,"CHKPDI( ): PDIFM D ATE: ",PDI FM
  1263   "RTN","CH8 35F1",137, 0)
  1264    S X1=PDIF M                                                                                             ; PD I FM DATE  (YYYMMDD)
  1265   "RTN","CH8 35F1",138, 0)
  1266    S X2=CUTO FF                                                                                   ;  CUTOFF FM  DATE (YYYM MDD)
  1267   "RTN","CH8 35F1",139, 0)
  1268    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHKPDI ():^%DTC C ALL: PDI D ATE = ",X1 ,"   CUTOF F DATE= ", X2
  1269   "RTN","CH8 35F1",140, 0)
  1270    D ^%DTC                                                                                                 ; SU BTRACT PDI  DATE FROM  CUTOFF DA TE
  1271   "RTN","CH8 35F1",141, 0)
  1272    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHKPDI (): DIFF=  ",X ; FILE MAN RETURN S RESULT I N X
  1273   "RTN","CH8 35F1",142, 0)
  1274    Q:X<0 0
  1275   "RTN","CH8 35F1",143, 0)
  1276    Q 1
  1277   "RTN","CH8 35F1",144, 0)
  1278    ;
  1279   "RTN","CH8 35F1",145, 0)
  1280    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1281   "RTN","CH8 35F1",146, 0)
  1282    ; CALCWIN (FMDATE) U SES THE C^ %DTC FILEM AN FUNCTIO N TO CALCU LATE THE F M
  1283   "RTN","CH8 35F1",147, 0)
  1284    ; CUTOFF  DATE FOR 8 35 QUEUEIN G.
  1285   "RTN","CH8 35F1",148, 0)
  1286    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1287   "RTN","CH8 35F1",149, 0)
  1288    ;
  1289   "RTN","CH8 35F1",150, 0)
  1290   CALCWIN(FM DATE)
  1291   "RTN","CH8 35F1",151, 0)
  1292    ; FMDATE        FM F ORMAT STAR TING DATE  FOR USEIN  THE CUTOFF  DATE CALC ULATION.
  1293   "RTN","CH8 35F1",152, 0)
  1294    S X1=FMDA TE ; USER  PROVIDED F M DATE (YY YDDD FORMA T)
  1295   "RTN","CH8 35F1",153, 0)
  1296    S X2=-180       ; 18 0 DAY WIND OW AS DETE RMINED BY  BUSINESS G ROUP
  1297   "RTN","CH8 35F1",154, 0)
  1298    D C^%DTC        ; SU BTRACT THE  180 DAYS  (BUSINESS  WINDOW FOR  QUEUEING)
  1299   "RTN","CH8 35F1",155, 0)
  1300    Q X             ; RE TURN THE F M FORMAT D ATE FOR CU TOFF
  1301   "RTN","CH8 35F1",156, 0)
  1302    ;
  1303   "RTN","CH8 35F1",157, 0)
  1304    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  1305   "RTN","CH8 35F1",158, 0)
  1306    ; PDI2FM( PDIDATE) C ONVERT THE  PDI DATE  "2015027"  TO A FILEM AN DATE "2 0150127"
  1307   "RTN","CH8 35F1",159, 0)
  1308    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  1309   "RTN","CH8 35F1",160, 0)
  1310    ;
  1311   "RTN","CH8 35F1",161, 0)
  1312   PDI2FM(PDI DATE) ;CON VERT PDI J ULIAN DATE  (CCYYDDD)  TO FM DAT E (YYYYMMD D)
  1313   "RTN","CH8 35F1",162, 0)
  1314    ; PASS PD IDATE AS A  STRING IF  LEADING Z ERO'S ARE  SIGNIFICAN T
  1315   "RTN","CH8 35F1",163, 0)
  1316    ; FUNCTIO N VALID FO R DATES 1- 1-1950 - 1 2-31-2049
  1317   "RTN","CH8 35F1",164, 0)
  1318    N WDATE,F MBASE,PDIY R,PDIFM
  1319   "RTN","CH8 35F1",165, 0)
  1320    Q:'$D(PDI DATE)
  1321   "RTN","CH8 35F1",166, 0)
  1322    S FMBASE= 2000                                                       ; FILE MAN BASED  ON 2000
  1323   "RTN","CH8 35F1",167, 0)
  1324    S PDIYR=$ E(PDIDATE, 1,4)
  1325   "RTN","CH8 35F1",168, 0)
  1326    S WDATE=( PDIYR-FMBA SE)_$E(PDI DATE,5,7)          ;  APPEND THE  DDD VALUE
  1327   "RTN","CH8 35F1",169, 0)
  1328    S PDIFM=$ $JULFM(WDA TE)
  1329   "RTN","CH8 35F1",170, 0)
  1330    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"PDI2FM (): PDIFM  DATE= ",PD IFM
  1331   "RTN","CH8 35F1",171, 0)
  1332    Q PDIFM
  1333   "RTN","CH8 35F1",172, 0)
  1334    ;
  1335   "RTN","CH8 35F1",173, 0)
  1336    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1337   "RTN","CH8 35F1",174, 0)
  1338    ; FMJUL(F MDATE) RET URNS THE P ROVIDED FM  DATE IN J ULIAN FORM AT CCYYDDD
  1339   "RTN","CH8 35F1",175, 0)
  1340    ; PDI DAT ES ARE IN  THE CCYYDD D JULIAN F ORMAT, SO  THIS FUNCT ION GETS
  1341   "RTN","CH8 35F1",176, 0)
  1342    ; THE CUR RENT DATE  IN THE CCY YDDD FORMA T SO THE C UTOFF DATE  FOR 835
  1343   "RTN","CH8 35F1",177, 0)
  1344    ; QUEUEIN G CAN BE C ALCULATED.
  1345   "RTN","CH8 35F1",178, 0)
  1346    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1347   "RTN","CH8 35F1",179, 0)
  1348    ;
  1349   "RTN","CH8 35F1",180, 0)
  1350   FMJUL(FMDT ) ;CONVERT  FM DATE T O JULIAN D ATE
  1351   "RTN","CH8 35F1",181, 0)
  1352    N D1,D2,D 3,YEAR
  1353   "RTN","CH8 35F1",182, 0)
  1354    Q:'$D(FMD T) 0
  1355   "RTN","CH8 35F1",183, 0)
  1356    S X=$E(FM DT,1,3)_"0 000" D H^% DTC S D2=% H
  1357   "RTN","CH8 35F1",184, 0)
  1358    S X=FMDT  D H^%DTC S  D1=%H
  1359   "RTN","CH8 35F1",185, 0)
  1360    S D3=D1-D 2+1 S:D3<1 00 D3="0"_ D3 S:D3<10  D3="0"_D3
  1361   "RTN","CH8 35F1",186, 0)
  1362    S YEAR=$E (FMDT,1,3)
  1363   "RTN","CH8 35F1",187, 0)
  1364    S D3=YEAR _D3
  1365   "RTN","CH8 35F1",188, 0)
  1366    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"FMJUL( ):  DATE=  ",D3
  1367   "RTN","CH8 35F1",189, 0)
  1368    Q D3
  1369   "RTN","CH8 35F1",190, 0)
  1370    ;
  1371   "RTN","CH8 35F1",191, 0)
  1372    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  1373   "RTN","CH8 35F1",192, 0)
  1374    ; CONVERT  THE JULIA N DATE "13 091" TO A  FILEMAN DA TE "313040 1"
  1375   "RTN","CH8 35F1",193, 0)
  1376    ; W $$JUL FM^CHFMLIB 1(13091)     3130401
  1377   "RTN","CH8 35F1",194, 0)
  1378    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  1379   "RTN","CH8 35F1",195, 0)
  1380    ;
  1381   "RTN","CH8 35F1",196, 0)
  1382   JULFM(JDT)  ;CONVERT  JULIAN DAT E TO FM DA TE (YYYMMD D)
  1383   "RTN","CH8 35F1",197, 0)
  1384    ; Y2K cha nged to ma ke it comp liant
  1385   "RTN","CH8 35F1",198, 0)
  1386    ;  JDT          JULI AN DATE TO  CONVERT I N "13091"  (YYDDD) FO RMAT
  1387   "RTN","CH8 35F1",199, 0)
  1388    N X,Y
  1389   "RTN","CH8 35F1",200, 0)
  1390    I '$D(JDT ) S JDT=$$ FMJUL(JDT)
  1391   "RTN","CH8 35F1",201, 0)
  1392    S Y=1900  I +$E(JDT, 1,2)<50 S  Y=2000
  1393   "RTN","CH8 35F1",202, 0)
  1394    S X=Y+$E( JDT,1,2)-1 700_"0000"  D H^%DTC
  1395   "RTN","CH8 35F1",203, 0)
  1396    S %H=%H+$ E(JDT,3,5) -1 D YMD^% DTC
  1397   "RTN","CH8 35F1",204, 0)
  1398    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"JULFM( ):  DATE=  ",X
  1399   "RTN","CH8 35F1",205, 0)
  1400    Q X
  1401   "RTN","CH8 35F1",206, 0)
  1402    ;
  1403   "RTN","CH8 35F1",207, 0)
  1404    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1405   "RTN","CH8 35F1",208, 0)
  1406    ; FMSLOOP ()  ID THE  MASIN PRO CESSING LO OP FOR THE  GENERATIO N OF 835 R ECORDS.
  1407   "RTN","CH8 35F1",209, 0)
  1408    ; THE ^TM P("EDI-835 ") ARRAY C REATED IN  "SORT" IS  USED TO CO NTROL THE  CREATION
  1409   "RTN","CH8 35F1",210, 0)
  1410    ; OF RECO RDS FOR TH E 835 STAG ING FILE.
  1411   "RTN","CH8 35F1",211, 0)
  1412    ; TARGET  DIRECTORY:  "HAC_HFS$ :[X12OCR.I N]" (SEE F CREATE^CHM XMDRV)
  1413   "RTN","CH8 35F1",212, 0)
  1414    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  1415   "RTN","CH8 35F1",213, 0)
  1416    ; 1) FMSL OOP LOOPS  THROUGH TH E ^TMP($J, "EDI-835", PROVIDER I D,^CHMEDI( I))
  1417   "RTN","CH8 35F1",214, 0)
  1418    ;      AR RAY CREATE D IN "SORT ".
  1419   "RTN","CH8 35F1",215, 0)
  1420    ; 2) THE  ^TMP($J,"E DI_CREATE" ) ARRAY IS  CREATED A NEW FOR EA CH SET OF  835
  1421   "RTN","CH8 35F1",216, 0)
  1422    ;   RECOR DS. THIS A RRAY HAS S EPARATE IN DEXES FOR  EACH OF TH E RECORDS
  1423   "RTN","CH8 35F1",217, 0)
  1424    ;      TO  BE GENERA TED, EACH  LOADED DUR ING THE FU NCTION BY  THE NAME O F
  1425   "RTN","CH8 35F1",218, 0)
  1426    ;      TH E RECORD ( I.E. HDR,  BPR, ETC.)
  1427   "RTN","CH8 35F1",219, 0)
  1428    ; 3) THE  COMMON PAR AMETERS US ED BY THE  INDIVIDUAL  RECORDS A RE RETRIEV ED
  1429   "RTN","CH8 35F1",220, 0)
  1430    ;      BA SED ON THE  ^CHMEDI(I ) AND (J)  INDEXES, A ND PASSED  TO THE REC ORD
  1431   "RTN","CH8 35F1",221, 0)
  1432    ;      GE NERATION F UNCTIONS.
  1433   "RTN","CH8 35F1",222, 0)
  1434    ; 4) A SE PARATE LOO P IS USED  TO CONTROL  GENERATIO N OF THE C LP/CLPCAS  AND
  1435   "RTN","CH8 35F1",223, 0)
  1436    ;      SV C/SVCCAS/S VCLQ RECOR DS. THIS I S DUE TO T HE MULTIPL E ENTRY PO TENTIAL
  1437   "RTN","CH8 35F1",224, 0)
  1438    ;      OF  THESE FOR  A SINGLE  CLAIM.
  1439   "RTN","CH8 35F1",225, 0)
  1440    ; 5) ONCE  ALL RECOR DS FOR THI S CLAIM HA VE BEEN GE NERATED AN D STORED I N
  1441   "RTN","CH8 35F1",226, 0)
  1442    ;      TH EIR RESPEC TIVE NODES  OF THE ^T MP($J,"EDI _CREATE")  ARRAY, THE
  1443   "RTN","CH8 35F1",227, 0)
  1444    ;      RE CORDS ARE  WRITTEN TO  THE OUTPU T FILE.
  1445   "RTN","CH8 35F1",228, 0)
  1446    ; 6) WHEN  THE RECOR DS HAVE BE EN WRITTEN , THE ^CHM EDI STATUS  IS CHANGE D
  1447   "RTN","CH8 35F1",229, 0)
  1448    ;      FR OM "NEEDS  SENT" TO " SENT"
  1449   "RTN","CH8 35F1",230, 0)
  1450    ; 7) CONT INUE TO ST EP 1 UNTIL  ALL CLAIM S HAVE BEE N PROCESSE D.
  1451   "RTN","CH8 35F1",231, 0)
  1452    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  1453   "RTN","CH8 35F1",232, 0)
  1454    ; NOT THA T THE CHPI D VALUE IS  EXTRACTED  FROM THE  ARRAY FOR  EACH CLAIM . THIS
  1455   "RTN","CH8 35F1",233, 0)
  1456    ; ENABLES  THE DENTA L CLAIMS T HAT ARE SU BMITTED WI TH THE MED ICAL CLAIM S TO
  1457   "RTN","CH8 35F1",234, 0)
  1458    ; BE EXTR ACTED FOR  THE FINAL  835 OUTPUT .
  1459   "RTN","CH8 35F1",235, 0)
  1460    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  1461   "RTN","CH8 35F1",236, 0)
  1462    ;
  1463   "RTN","CH8 35F1",237, 0)
  1464   FMSLOOP(FI LEI,EI) ;
  1465   "RTN","CH8 35F1",238, 0)
  1466    ; FILEI         FILE  INDEX FOR  THE 835 F ILE TO BE  GENERATED  (USED IN R ECORDS)
  1467   "RTN","CH8 35F1",239, 0)
  1468    ; EI            ENTI TY INDEX F OR RECORDS
  1469   "RTN","CH8 35F1",240, 0)
  1470    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
  1471   "RTN","CH8 35F1",241, 0)
  1472    ; Add MAI LCT to new ed variabl es RFE 01/ 09/19 INC3 837109
  1473   "RTN","CH8 35F1",242, 0)
  1474    S (STSEQ, CLMCNT,PLB ,EDII)=0
  1475   "RTN","CH8 35F1",243, 0)
  1476    D NOW^%DT C S DT=X                                                                                               ; CURR ENT DATE
  1477   "RTN","CH8 35F1",244, 0)
  1478    S CHPID=" "
  1479   "RTN","CH8 35F1",245, 0)
  1480    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
  1481   "RTN","CH8 35F1",246, 0)
  1482    .S PYRID= $P($G(^CHM EDIPA(EI,0 )),"^",8)                                     ; PAYER  ID VALUE S ET ONCE PE R LOOP
  1483   "RTN","CH8 35F1",247, 0)
  1484    .F  S EDI I=$O(^TMP( $J,"EDI-83 5",CHPID,E DII)) Q:+( EDII)=0  D     ; LOOP  THROUGH ^ CHMEDI() " I" INDEXES
  1485   "RTN","CH8 35F1",248, 0)
  1486    ..K ^TMP( $J,"EDI_CR EATE")                                          ; ARRA Y CONTAINI NG THE REC ORD SET FO R THIS ^CH MEDI(I)
  1487   "RTN","CH8 35F1",249, 0)
  1488    ..S NFILE =CHPID_"_" _FILEI                                          ; NFIL E VARIABLE  USED TO I DENTIFY ME DICAL/DENT AL RECORDS
  1489   "RTN","CH8 35F1",250, 0)
  1490    ..S STSEQ =STSEQ+1                                                            ; RECORD  SEQUENCE  COUNTER
  1491   "RTN","CH8 35F1",251, 0)
  1492    ..Q:'$D(^ CHMEDI(EDI I,1))                                           ; EXIT  IF NO POI NTER TO ^C HMPAY() NO DE
  1493   "RTN","CH8 35F1",252, 0)
  1494    ..S FMSID =$P(^CHMED I(EDII,0), "^",1)             ;  RECONCILIA TION NUMBE R USED BY  TRN/PLB RE CORDS
  1495   "RTN","CH8 35F1",253, 0)
  1496    ..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"
  1497   "RTN","CH8 35F1",254, 0)
  1498    ..S PAYI= $P($G(^CHM EDI(EDII,1 ,EDIJ,0)), "^",1)                    ; GET  THE ^CHMPA Y "I" POIN TER VALUE  FROM ^CHME DI RECORD
  1499   "RTN","CH8 35F1",255, 0)
  1500    ..S VENI= $P(^CHMEDI (EDII,0)," ^",5)                                ; VEND OR INDEX U SED IN HDR , BPR, AND  PLB RECOR DS
  1501   "RTN","CH8 35F1",256, 0)
  1502    ..S:VENI= "" VENI=$P (^CHMPAY(P AYI,0),"^" ,3)                       ; ALTE RNATE LOCA TION FOR V ENDOR INDE X
  1503   "RTN","CH8 35F1",257, 0)
  1504    ..S PDI=$ P($P(^CHMP AY(PAYI,0) ,"^",4),"* ",1)                      ; CLAI M PDI FOR  THE CURREN T ENTRY
  1505   "RTN","CH8 35F1",258, 0)
  1506    ..S CLAIM =$P(^CHMPA Y(PAYI,0), "^",1)                               ; HAC  CLAIM NUMB ER FOR THE  PDI
  1507   "RTN","CH8 35F1",259, 0)
  1508    ..S ^CHME DI("C",PAY I,EDII,EDI J)=""                                ; SET  THE ^CHMED I XREF FOR  PTR->CHMP AY
  1509   "RTN","CH8 35F1",260, 0)
  1510    ..S STATU S=$$STATUS (PAYI)                                          ; RETR IEVE TEXT  DESC FOR S TATUS
  1511   "RTN","CH8 35F1",261, 0)
  1512    ..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
  1513   "RTN","CH8 35F1",262, 0)
  1514    ..;SBB 02 /21/2018 C C4002-001  SET REV835  variable  to 22 for  voids
  1515   "RTN","CH8 35F1",263, 0)
  1516    ..S REV83 5=0 I $P(^ CHMPAY(PAY I,0),"^",2 )=11 S REV 835=22
  1517   "RTN","CH8 35F1",264, 0)
  1518    ..D HDR(P AYI,NFILE, STSEQ,VENI )                                             ; HEADER  RECORD GE NERATION
  1519   "RTN","CH8 35F1",265, 0)
  1520    ..D BPR(P AYI,NFILE, STSEQ,VENI ,EDII,EI,D T)                        ; BPR  RECORD GEN ERATION
  1521   "RTN","CH8 35F1",266, 0)
  1522    ..D TRN(P AYI,NFILE, STSEQ,FMSI D,EI)                                ; TRN  RECORD GEN ERATION
  1523   "RTN","CH8 35F1",267, 0)
  1524    ..S PAMT= $$CLM^CH83 5F2(EDII,V ENI,NFILE, STSEQ,.OAB 6)                      ; CLP/CL PCAS, SVC/ SVCCAS REC ORD GENERA TION
  1525   "RTN","CH8 35F1",268, 0)
  1526    ..D PLB(N FILE,STSEQ ,VENI,EDII ,DT,PAYI,P AMT)                      ; PLB  RECORD GEN ERATION
  1527   "RTN","CH8 35F1",269, 0)
  1528    ..Q:'$$BA LANCE^CH83 5BAL()                                          ; BALA NCE CHK ON  GENERATED  RECORDS ( ^TMP($J,"E DI-CREATE" )): 0=IMBA LANCE
  1529   "RTN","CH8 35F1",270, 0)
  1530    ..Q:$$ACT CARC^CH835 ACT()!$$AC TRARC^CH83 5ACT()      ; CARCs a nd RARCs n eed to be  active
  1531   "RTN","CH8 35F1",271, 0)
  1532    ..Q:$P(^C HMEDI(EDII ,0),"^",2) =7                                   ; CHEC K THE STAT US FLAG FO R INDEXING  ERROR
  1533   "RTN","CH8 35F1",272, 0)
  1534    ..I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"SU CCESS FOR  CLAIM #: " ,CLAIM,"   IN FILE: " ,NFILE
  1535   "RTN","CH8 35F1",273, 0)
  1536    ..D WRT                                                              ; WRIT E TRANSACT IONS TO FI LE
  1537   "RTN","CH8 35F1",274, 0)
  1538    ..D UPDST ATUS(EDII)                                                 ; UPDA TE THE "NE EDS SENT"  TO "SENT"  STATUS
  1539   "RTN","CH8 35F1",275, 0)
  1540    ..S CLMCN T=CLMCNT+1                                                 ; CLAI M INDEX CO UNTER VARI ABLE
  1541   "RTN","CH8 35F1",276, 0)
  1542    ..D RPTFI GS(PAYI) ;  RFE 01/09 /19 INC383 7109
  1543   "RTN","CH8 35F1",277, 0)
  1544    .Q                                                                   ; QUIT  FOR INNER  FOR LOOP
  1545   "RTN","CH8 35F1",278, 0)
  1546    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"END  OF FILE:  CLMCNT: ", CLMCNT,"   STSEQ: ",S TSEQ
  1547   "RTN","CH8 35F1",279, 0)
  1548    D MAILFIG S ; RFE 01 /09/19 INC 3837109
  1549   "RTN","CH8 35F1",280, 0)
  1550    Q CLMCNT
  1551   "RTN","CH8 35F1",281, 0)
  1552    ;
  1553   "RTN","CH8 35F1",282, 0)
  1554    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1555   "RTN","CH8 35F1",283, 0)
  1556    ; STATUS  FUNCTION R ETURNS THE  TEXT DESC RIPTION FO R THE STAT US VALUE
  1557   "RTN","CH8 35F1",284, 0)
  1558    ; CONTAIN ED IN ^CHM PAY(I,0),  FIELD 2. T HIS VALUE  IS NOT REQ UIRED FOR
  1559   "RTN","CH8 35F1",285, 0)
  1560    ; RECORD  GENERATION .
  1561   "RTN","CH8 35F1",286, 0)
  1562    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  1563   "RTN","CH8 35F1",287, 0)
  1564    ;
  1565   "RTN","CH8 35F1",288, 0)
  1566   STATUS(PAY I)
  1567   "RTN","CH8 35F1",289, 0)
  1568    ; PAYI ^C HMPAY(I) I NDEX
  1569   "RTN","CH8 35F1",290, 0)
  1570    N STATUS, STATDESC
  1571   "RTN","CH8 35F1",291, 0)
  1572    S STATDES C=""
  1573   "RTN","CH8 35F1",292, 0)
  1574    S STATUS= $P(^CHMPAY (PAYI,0)," ^",2)                                         ; CLAIM  STATUS
  1575   "RTN","CH8 35F1",293, 0)
  1576    ;CHANGING  STATDESC  TO A BLOCK  FORMAT SO  THAT IT I S LESS THA N 255  MTN 028772
  1577   "RTN","CH8 35F1",294, 0)
  1578    ; BDB 11/ 13/2017 AD DED VOID R EVERSED
  1579   "RTN","CH8 35F1",295, 0)
  1580    S STATDES C=$S(STATU S=0:"REJEC TED",STATU S=1:"IN PR OCESS",
  1581   "RTN","CH8 35F1",296, 0)
  1582      STATUS= 2:"PAYMENT  REQUESTED ",STATUS=3 :"EOB REQU ESTED",
  1583   "RTN","CH8 35F1",297, 0)
  1584      STATUS= 4:"COMPLET E",STATUS= 5:"ADJUDIC ATED",STAT US=6:"PAYM ENT REJECT ED CAPPS/C ALM",
  1585   "RTN","CH8 35F1",298, 0)
  1586      STATUS= 7:"ADMINIS TRATIVE SU SPENSE",ST ATUS=8:"PA YMENT APPR OVED CAPPS /CALM",
  1587   "RTN","CH8 35F1",299, 0)
  1588      STATUS= 9:"MANUALL Y PROCESSE D",STATUS= 10:"DELETE D",STATUS= 11:"VOIDED ",STATUS=1 2:"REVERSE D")
  1589   "RTN","CH8 35F1",300, 0)
  1590    Q STATDES C
  1591   "RTN","CH8 35F1",301, 0)
  1592    ;
  1593   "RTN","CH8 35F1",302, 0)
  1594   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
  1595   "RTN","CH8 35F1",303, 0)
  1596    Q:PAYI=""   ; Should n't happen
  1597   "RTN","CH8 35F1",304, 0)
  1598    S RPTSUB= $P($G(^CHM INDEX(PAYI ,0)),U,2)
  1599   "RTN","CH8 35F1",305, 0)
  1600    Q:RPTSUB= ""
  1601   "RTN","CH8 35F1",306, 0)
  1602    ; now, is  it COB?
  1603   "RTN","CH8 35F1",307, 0)
  1604    D
  1605   "RTN","CH8 35F1",308, 0)
  1606    . S PDI=$ P($P(^CHMP AY(PAYI,0) ,"^",4),"* ",1) Q:PDI =""
  1607   "RTN","CH8 35F1",309, 0)
  1608    . S PCN=$ O(^CHMXCLE ("PDI",PDI ,""))  Q:P CN=""  Q:P CN=0
  1609   "RTN","CH8 35F1",310, 0)
  1610    . S XI=$O (^CHMXCLE( "PDI",PDI, PCN,"")) Q :XI=""  Q: XI=0
  1611   "RTN","CH8 35F1",311, 0)
  1612    . S IDXST R=$O(^CHMX CLE("PDI", PDI,PCN,XI ,"")) Q:ID XSTR=""
  1613   "RTN","CH8 35F1",312, 0)
  1614    . S AI=$P (IDXSTR,"* ",1) Q:AI= ""
  1615   "RTN","CH8 35F1",313, 0)
  1616    . S CHTPI =$P($G(^CH MXCLA(AI,1 )),U) Q:CH TPI=""
  1617   "RTN","CH8 35F1",314, 0)
  1618    . S CHTPI =$O(^CHMXT P("C",CHTP I,"")) Q:C HTPI=""
  1619   "RTN","CH8 35F1",315, 0)
  1620    . S IDX=$ O(^CHMX277 ("B",CHTPI ,0))
  1621   "RTN","CH8 35F1",316, 0)
  1622    . S:$P(^C HMX277(IDX ,0),"^",4) ["COB" RPT SUB=RPTSUB _U_1
  1623   "RTN","CH8 35F1",317, 0)
  1624    . Q
  1625   "RTN","CH8 35F1",318, 0)
  1626    S MAILCT( RPTSUB)=1+ $G(MAILCT( RPTSUB))
  1627   "RTN","CH8 35F1",319, 0)
  1628    Q
  1629   "RTN","CH8 35F1",320, 0)
  1630    ;
  1631   "RTN","CH8 35F1",321, 0)
  1632   MAILFIGS ;  RFE 01/09 /19 INC383 7109
  1633   "RTN","CH8 35F1",322, 0)
  1634    S SUBJECT ="835 Sent  for CHAMP VA"
  1635   "RTN","CH8 35F1",323, 0)
  1636    K LXMY
  1637   "RTN","CH8 35F1",324, 0)
  1638    S LXMY(" PII             ")=""
  1639   "RTN","CH8 35F1",325, 0)
  1640    N DUZ
  1641   "RTN","CH8 35F1",326, 0)
  1642    K ZML
  1643   "RTN","CH8 35F1",327, 0)
  1644    S TEXT="Z ML("
  1645   "RTN","CH8 35F1",328, 0)
  1646    I '$D(MAI LCT) D  Q
  1647   "RTN","CH8 35F1",329, 0)
  1648    . S ZML(1 )="No 835' s sent tod ay"
  1649   "RTN","CH8 35F1",330, 0)
  1650    . D VMAIL (SUBJECT,T EXT,.LXMY)
  1651   "RTN","CH8 35F1",331, 0)
  1652    . Q
  1653   "RTN","CH8 35F1",332, 0)
  1654    S LINECT= 0
  1655   "RTN","CH8 35F1",333, 0)
  1656    S RPTSUB= ""
  1657   "RTN","CH8 35F1",334, 0)
  1658    F  S RPTS UB=$O(MAIL CT(RPTSUB) ) Q:'RPTSU B  D
  1659   "RTN","CH8 35F1",335, 0)
  1660    . S PROGT YP=$P(RPTS UB,U)
  1661   "RTN","CH8 35F1",336, 0)
  1662    . S LINEC T=LINECT+1
  1663   "RTN","CH8 35F1",337, 0)
  1664    . S RPTDE SC=$P($G(^ CHMDIC(741 002.94,PRO GTYP,0)),U ,2)
  1665   "RTN","CH8 35F1",338, 0)
  1666    . S COB=" "
  1667   "RTN","CH8 35F1",339, 0)
  1668    . I $P(RP TSUB,U,2)= 1 S COB="C rossovers"
  1669   "RTN","CH8 35F1",340, 0)
  1670    . S ZML(L INECT)=RPT DESC_" "_C OB_" "_MAI LCT(RPTSUB )
  1671   "RTN","CH8 35F1",341, 0)
  1672    . Q
  1673   "RTN","CH8 35F1",342, 0)
  1674    D VMAIL(S UBJECT,TEX T,.LXMY)
  1675   "RTN","CH8 35F1",343, 0)
  1676    Q
  1677   "RTN","CH8 35F1",344, 0)
  1678    ;
  1679   "RTN","CH8 35F1",345, 0)
  1680   VMAIL(SUBJ ECT,TEXT,L XMY) ;
  1681   "RTN","CH8 35F1",346, 0)
  1682    ;  SUBJEC T     SUBJ ECT LINE F OR THE EMA IL
  1683   "RTN","CH8 35F1",347, 0)
  1684    ;  TEXT         TEXT  FOR THE E MAIL
  1685   "RTN","CH8 35F1",348, 0)
  1686    ;    LXMY          TARGETED R ECIPIENTS  FOR THE EM AIL (S LXM Y="DUZ" (M AILMAN),LX MY=" PII                " (MAILMAN ),LXMY("
P
I                  ")=""(OUTL OOK))
  1687   "RTN","CH8 35F1",349, 0)
  1688    N EMLID
  1689   "RTN","CH8 35F1",350, 0)
  1690    S U="^"
  1691   "RTN","CH8 35F1",351, 0)
  1692    S DUZ=.5                                                                      ; DEFAUL T DUZ
  1693   "RTN","CH8 35F1",352, 0)
  1694    S XMDUZ=. 5                                                                   ; POSTMA N DUZ
  1695   "RTN","CH8 35F1",353, 0)
  1696    S XMSUB=S UBJECT                                                     ; SET  SUBJECT LI NE FOR EMA IL
  1697   "RTN","CH8 35F1",354, 0)
  1698    S XMTEXT= TEXT                                                       ; SET  TEXT ARRAY  FOR BODY  OF EMAIL
  1699   "RTN","CH8 35F1",355, 0)
  1700    S EMLID=0
  1701   "RTN","CH8 35F1",356, 0)
  1702    F  S EMLI D=$O(LXMY( EMLID)) Q: EMLID=""   D
  1703   "RTN","CH8 35F1",357, 0)
  1704    .S XMY($S (EMLID?1.N :$P(^VA(20 0,EMLID,0) ,"^",1),1: EMLID))=""
  1705   "RTN","CH8 35F1",358, 0)
  1706    D ^XMD                                                                                 ; SEND IT  OFF
  1707   "RTN","CH8 35F1",359, 0)
  1708    Q
  1709   "RTN","CH8 35F1",360, 0)
  1710    ;
  1711   "RTN","CH8 35F1",361, 0)
  1712    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  1713   "RTN","CH8 35F1",362, 0)
  1714    ;
  1715   "RTN","CH8 35F1",363, 0)
  1716    ; THIS FU NCTION HAS  BEEN REPL ACE WITH T HE CH835BA L.INT ROUT INE, WHICH
  1717   "RTN","CH8 35F1",364, 0)
  1718    ; PERFORM S THE LINE  LEVEL AND  CLAIM LEV EL BALANCE  CHECKS JU ST PRIOR
  1719   "RTN","CH8 35F1",365, 0)
  1720    ; TO WRIT ING THE 83 5 RECORDS  TO THE STA GING FILE.  DLB 3/201 3
  1721   "RTN","CH8 35F1",366, 0)
  1722    ;
  1723   "RTN","CH8 35F1",367, 0)
  1724    ; BALCHK( ) DETERMIN ES IF THE  LINE LEVEL  AND CLAIM  LEVEL BIL LED VS
  1725   "RTN","CH8 35F1",368, 0)
  1726    ; PAID/PA TIENT RESP  VALUES BA LANCE. IF  THERE IS A N IMBALANC E, THE
  1727   "RTN","CH8 35F1",369, 0)
  1728    ; CLAIM I S LOGGED I N ^TMP($J, "BALERR"),  AND NO 83 5 RECORD I S GENERATE D.
  1729   "RTN","CH8 35F1",370, 0)
  1730    ; THE IMB ALANCE IS  REPORTED V IA EMAIL T O THE PST  GROUP.
  1731   "RTN","CH8 35F1",371, 0)
  1732    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  1733   "RTN","CH8 35F1",372, 0)
  1734    ; BASED O N BRIAN MA TTHEWS' IN PUT, A COM MON BALANC E CHECK OP ERATION CA N
  1735   "RTN","CH8 35F1",373, 0)
  1736    ; BE IMPL EMENTED.
  1737   "RTN","CH8 35F1",374, 0)
  1738    ; 1a)Serv ice Line i s accepted , but HAC  paid amoun t = 0   Th ere are tw o
  1739   "RTN","CH8 35F1",375, 0)
  1740    ; situati ons where  this happe ns. The ex ample give n is for N ON OHI cla ims
  1741   "RTN","CH8 35F1",376, 0)
  1742    ; where t he amount  the HAC wo uld have p aid is app lied to th e deductib le.
  1743   "RTN","CH8 35F1",377, 0)
  1744    ; BALANCE  CHECK= Bi lled Charg es - all c laim adjus tments (to tal of CO,  PR, PI, a nd OA)
  1745   "RTN","CH8 35F1",378, 0)
  1746    ; 1b) OHI  claims ma y have OHI  Service L ine paymen ts + OHI S ervice Lin e
  1747   "RTN","CH8 35F1",379, 0)
  1748    ; adjustm ents that  equal the  Billed cha rges.  In  this case  we would h ave
  1749   "RTN","CH8 35F1",380, 0)
  1750    ; an OA23  adjustmen t for the  total bill ed charges .
  1751   "RTN","CH8 35F1",381, 0)
  1752    ; BALANCE  CHECK: Bi lled Charg es - all c laim adjus tments (to tal of CO,  PR, PI, a nd OA)
  1753   "RTN","CH8 35F1",382, 0)
  1754    ; 2) Serv ice Line i s accepted  and HAC p ays more t han zero.
  1755   "RTN","CH8 35F1",383, 0)
  1756    ; BALANCE  CHECK: Bi lled Charg es - {HAC  payment +  all claim  adjustment s (total o f CO, PR,  PI, and OA )}
  1757   "RTN","CH8 35F1",384, 0)
  1758    ; 3) When  we reject  a line, t he allowab le amount  will be ze ro and the  HAC will  pay zero.
  1759   "RTN","CH8 35F1",385, 0)
  1760    ; BALANCE  CHECK: Bi lled Charg es - all c laim adjus tments (to tal of CO,  PR, PI, a nd OA)
  1761   "RTN","CH8 35F1",386, 0)
  1762    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  1763   "RTN","CH8 35F1",387, 0)
  1764    ; 1a, 1b,  AND 3:  H AC PAID AM OUNT SHOUL D BE 0, SO  INCLUDING  THE VARIA BLE HAS NO  EFFECT
  1765   "RTN","CH8 35F1",388, 0)
  1766    ; 2: HAC  PAID AMOUN T IS REPOR TED, SO IT  SHOULD BE  INCLUDED  IN THE CHE CK
  1767   "RTN","CH8 35F1",389, 0)
  1768    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  1769   "RTN","CH8 35F1",390, 0)
  1770    ;
  1771   "RTN","CH8 35F1",391, 0)
  1772   BALCHK(PAY I,EDII)
  1773   "RTN","CH8 35F1",392, 0)
  1774    ; PAYI          "I"  INDEX TO T HE ^CHMPAY () GLOBAL
  1775   "RTN","CH8 35F1",393, 0)
  1776    ; EDII          "I"  INDEX FOR  THE ^CHMED I FILE
  1777   "RTN","CH8 35F1",394, 0)
  1778    N SORTDAT A,POHIPD,O HIPR,ADDOH IPD,OHIPRB AL,MDCAIDP D,TPLPD,HA CPD,ALLOHI ,ALLPAID,C HGAMT,ALLO WAMT,BALER R
  1779   "RTN","CH8 35F1",395, 0)
  1780    S BALERR= 0
  1781   "RTN","CH8 35F1",396, 0)
  1782    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.
  1783   "RTN","CH8 35F1",397, 0)
  1784    I GLPAY=" " S X1=PAY I D PROGTY P^CHFCD001                           ;AEB 4  20/2012 D EV007820 S ETS GLPAY  IF NOT DEF INED.
  1785   "RTN","CH8 35F1",398, 0)
  1786    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
  1787   "RTN","CH8 35F1",399, 0)
  1788    .D INIT^C HGCUU3(PAY I,"ALLOW", "AUTO")                                       ; AUTO-D ISTRIBUTIO N (creates  LINEID if  not exist ) ;JAK 7/2 8/11 DEV00 7820
  1789   "RTN","CH8 35F1",400, 0)
  1790    E  D
  1791   "RTN","CH8 35F1",401, 0)
  1792    .D INIT^C HGCUU3(PAY I,"ALLOW", "TPLBENE")                           ; MANU AL...distr ibute tpl  & bene pmt s and calc  ohi
  1793   "RTN","CH8 35F1",402, 0)
  1794    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1)                        ; CLAI M PDI FROM  ^CHMPAY(P AYI,0),"^" ,4)
  1795   "RTN","CH8 35F1",403, 0)
  1796    D SORT^CH FBCUTL(PAY I)                                                                ; AEB UTIL  FOR UNITS , ALLOWED  AMOUNT, ET C.
  1797   "RTN","CH8 35F1",404, 0)
  1798    S IMGL=0
  1799   "RTN","CH8 35F1",405, 0)
  1800    F  S IMGL =$O(^TMP($ J,"IMG2PAY ",PAYI,IMG L)) Q:+(IM GL)=0  D ;  LOOP THRO UGH THE SE RVICE LINE S
  1801   "RTN","CH8 35F1",406, 0)
  1802    .S SORTDA TA=^TMP($J ,"LINE",PA YI,IMGL)
  1803   "RTN","CH8 35F1",407, 0)
  1804    .S POHIPD =+$P(SORTD ATA,"^",1)                                               ; PRIMAR Y OHI PAID  VALUE
  1805   "RTN","CH8 35F1",408, 0)
  1806    .S OHIPR= +$P(SORTDA TA,"^",2)                                                ; OHI PA TIENT RESP ONSIBILITY
  1807   "RTN","CH8 35F1",409, 0)
  1808    .S ADDOHI PD=+$P(SOR TDATA,"^", 3)                                            ; RETRIE VE ADDITIO NAL OHI PA ID AMOUNT
  1809   "RTN","CH8 35F1",410, 0)
  1810    .S OHIPRB AL=+$P(SOR TDATA,"^", 4)                                            ; RETRIE VE OHI PR  BALANCE AM OUNT
  1811   "RTN","CH8 35F1",411, 0)
  1812    .S MDCAID PD=+$P(SOR TDATA,"^", 5)                                            ; MEDICA ID PAYMENT S RECEIVED
  1813   "RTN","CH8 35F1",412, 0)
  1814    .S TPLPD= +$P(SORTDA TA,"^",6)                                                ; TPL PA YMENTS REC EIVED
  1815   "RTN","CH8 35F1",413, 0)
  1816    .S HACPD= +$P(SORTDA TA,"^",12)                                               ; ADJUDI CATED PAYM ENT AMOUNT
  1817   "RTN","CH8 35F1",414, 0)
  1818    .S ALLOHI =POHIPD+AD DOHIPD                                                            ; GET OHI  TOTAL PAID
  1819   "RTN","CH8 35F1",415, 0)
  1820    .S ALLPAI D=(ALLOHI+ MDCAIDPD+T PLPD+HACPD )                         ; TOTA L ALL PAYM ENTS RECEI VED + AMT  HAC PAID
  1821   "RTN","CH8 35F1",416, 0)
  1822    .S CHGAMT =+$P(SORTD ATA,"^",8)                                               ; LINE C HARGE FROM  SORT^CHFB CUTL
  1823   "RTN","CH8 35F1",417, 0)
  1824    .S ALLOWA MT=+$P(SOR TDATA,"^", 7)                                            ; ALLOWE D AMOUNT F ROM SORT^C HFBCUTL
  1825   "RTN","CH8 35F1",418, 0)
  1826    .I (CHGAM T-(ALLPAID +OHIPRBAL) '=0) D                               ; LINE  LEVEL BAL ANCE CHECK
  1827   "RTN","CH8 35F1",419, 0)
  1828    ..S BALER R=1                                                                                  ;  RETURN VAL UE
  1829   "RTN","CH8 35F1",420, 0)
  1830    ..D NOW^% DTC                                                                                  ;  GET TODAY' S DATE
  1831   "RTN","CH8 35F1",421, 0)
  1832    ..S TODAY =X                                                                                   ;  DATE BALAN CE ERROR R ECORDED
  1833   "RTN","CH8 35F1",422, 0)
  1834    ..S ARR(. 02)=2                                                                                         ; SE T STATUS T O BALANCE  ERROR
  1835   "RTN","CH8 35F1",423, 0)
  1836    ..S ARR(. 07)=TODAY                                                                            ;  SET DATE B ALANCE ERR OR ENCOUNT ERED
  1837   "RTN","CH8 35F1",424, 0)
  1838    ..S RESUL T=$$UPDATE ^CHHRLIBFM ("CHMEDI(I ,0)",EDII, $$SETDR^CH HRLIBFM("A RR")) ; UP DATE THE ^ CHMEDI FIL E
  1839   "RTN","CH8 35F1",425, 0)
  1840    ..S CHPDI =$P($P($G( ^CHMPAY(PA YI,0)),"^" ,4),"*",1)       ; GE T THE OFFE NDING PDI
  1841   "RTN","CH8 35F1",426, 0)
  1842    ..S HACCL M=$P($G(^C HMPAY(PAYI ,0)),"^",1 )                         ; GET  THE OFFEND ING HAC CL AIM NUMBER
  1843   "RTN","CH8 35F1",427, 0)
  1844    ..S ^TMP( $J,"BALERR ",CHPDI)=C HPDI_"^"_H ACCLM_"^"_ CHGAMT_"^" _ALLPAID_" ^"_OHIPRBA L
  1845   "RTN","CH8 35F1",428, 0)
  1846    ..W !,"LI NE LVL BAL ERR: ",CHP DI_"^"_HAC CLM_"^"_ED II_"^"_TOD AY_"^"_CHG AMT_"^"_AL LPAID_"^"_ OHIPRBAL
  1847   "RTN","CH8 35F1",429, 0)
  1848    W !,"LINE  LEVEL BAL ANCE: ",CH GAMT-(ALLP AID+OHIPRB AL)
  1849   "RTN","CH8 35F1",430, 0)
  1850    W !,"CLAI M LEVEL BA LANCING TB D"
  1851   "RTN","CH8 35F1",431, 0)
  1852    Q BALERR
  1853   "RTN","CH8 35F1",432, 0)
  1854    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  1855   "RTN","CH8 35F1",433, 0)
  1856    ; HEADER  RECORDS FO R 835 STAG ING FILE
  1857   "RTN","CH8 35F1",434, 0)
  1858    ; DLB 8/2 8/2012  MA DE THIS A  FUNCTION
  1859   "RTN","CH8 35F1",435, 0)
  1860    ; 1) GATH ER THE HDR  RECORD DA TA FROM TH E CP&E PRO CESSING FI LES
  1861   "RTN","CH8 35F1",436, 0)
  1862    ; 2) THE  RECORD GEN ERATION IS  ACCOMPLIS HED USING  THE COMBIN ATION
  1863   "RTN","CH8 35F1",437, 0)
  1864    ;      OF  THE RECOR D TABLE (H DRTBL) AND  THE FUNCT ION THAT P ROCESSES
  1865   "RTN","CH8 35F1",438, 0)
  1866    ;      TH E TABLE (F ORMATDATA^ CHMXWBUT).
  1867   "RTN","CH8 35F1",439, 0)
  1868    ; 3) EACH  ENTRY IN  HDRTBL DES CRIBES ONE  FIELD IN  THE HDR RE CORD.
  1869   "RTN","CH8 35F1",440, 0)
  1870    ;      TH E DATA FOR  THE FIELD  CAN BE A  CONSTANT D ESCRIBED I N THE TABL E,
  1871   "RTN","CH8 35F1",441, 0)
  1872    ;      RE TRIEVED FR OM A VARIA BLE SET UP  PREVIOUSL Y, OR AS T HE RETURN
  1873   "RTN","CH8 35F1",442, 0)
  1874    ;      FR OM A FUNCT ION CALL ( EXECUTED F ROM THE TA BLE).
  1875   "RTN","CH8 35F1",443, 0)
  1876    ; 4) EACH  FIELD IS  CONCATENAT ED TO THE  PREVIOUS F IELD(S) UN TIL THE
  1877   "RTN","CH8 35F1",444, 0)
  1878    ;      CO MPLETE REC ORD HAS BE EN CREATED .
  1879   "RTN","CH8 35F1",445, 0)
  1880    ; 5) THE  COMPLETED  RECORD IS  STORED IN  ^TMP($J,"E DI_CREATE" ,"HDR",0)
  1881   "RTN","CH8 35F1",446, 0)
  1882    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  1883   "RTN","CH8 35F1",447, 0)
  1884    ;
  1885   "RTN","CH8 35F1",448, 0)
  1886   HDR(PAYI,N FILE,STSEQ ,VENI)       ; HEADER  SEGMENT F OR 835 STA GING FILE
  1887   "RTN","CH8 35F1",449, 0)
  1888    ; PAYI          CLAI M INDEX FO R THE CURR ENT CLAIM  IN ^CHMPAY
  1889   "RTN","CH8 35F1",450, 0)
  1890    ; NFILE F ILE IDENTI FIER FOR E ACH RECORD
  1891   "RTN","CH8 35F1",451, 0)
  1892    ; STSEQ S EQUENCE CO UNTER FOR  THE RECORD S
  1893   "RTN","CH8 35F1",452, 0)
  1894    ; VENI          VEND OR ID
  1895   "RTN","CH8 35F1",453, 0)
  1896    N PDI,INH DR,GRPCNTR ,HACID,PAY ERID,CLRHS ID,REC
  1897   "RTN","CH8 35F1",454, 0)
  1898    S PAYERID =$$PID^CH8 35FU1(PAYI )                  ;  PAYER ID
  1899   "RTN","CH8 35F1",455, 0)
  1900    S CLRHSID =$$CHID^CH 835FU1(PAY I)         ; CLEARING  HOUSE ID
  1901   "RTN","CH8 35F1",456, 0)
  1902    S PROVID= $$PROVID^C H835FU1(VE NI)        ; PROVIDER  ID (TIN)
  1903   "RTN","CH8 35F1",457, 0)
  1904    S PDI=$$C LMPDI^CH83 5FU1(PAYI)            ; PDI USED  FOR NPI R ETRIEVAL
  1905   "RTN","CH8 35F1",458, 0)
  1906    S PROVNPI =$$PROVNPI ^CH835FU1( PDI)       ; PROVIDER  NPI
  1907   "RTN","CH8 35F1",459, 0)
  1908    S REC=""
  1909   "RTN","CH8 35F1",460, 0)
  1910    F LN=1:1  S STR=$T(H DRTBL+LN)  Q:STR["END  OF RECORD "  D  ; TA BLE GENERA TED RECORD S
  1911   "RTN","CH8 35F1",461, 0)
  1912    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)
  1913   "RTN","CH8 35F1",462, 0)
  1914    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  1915   "RTN","CH8 35F1",463, 0)
  1916    S ^TMP($J ,"EDI_CREA TE","HDR", 0)=REC
  1917   "RTN","CH8 35F1",464, 0)
  1918    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F1: HDR RE CORD: ",RE C
  1919   "RTN","CH8 35F1",465, 0)
  1920    Q
  1921   "RTN","CH8 35F1",466, 0)
  1922    ;
  1923   "RTN","CH8 35F1",467, 0)
  1924    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  1925   "RTN","CH8 35F1",468, 0)
  1926    ; BPR REC ORDS FOR T HE 835 STA GING FILE
  1927   "RTN","CH8 35F1",469, 0)
  1928    ; DLB 8/2 8/2012  MA DE THIS A  FUNCTION
  1929   "RTN","CH8 35F1",470, 0)
  1930    ; THIS FU NCTION GAT HERS THE B PR DATA AN D UTILIZES  THE TABLE  DRIVEN
  1931   "RTN","CH8 35F1",471, 0)
  1932    ; RECORD  GENERATION  CAPABILIT Y TO STORE  THE RECOR D.
  1933   "RTN","CH8 35F1",472, 0)
  1934    ; SEE THE  "HDR" REC ORD DESCRI PTION FOR  THE STEPS  USED TO GE NERATE THE  RECORD.
  1935   "RTN","CH8 35F1",473, 0)
  1936    ; 9/17/20 13  DLB  A DDED "NEW"  FOR "I" V ARIABLE
  1937   "RTN","CH8 35F1",474, 0)
  1938    ; 1/17/20 13  DLB  M ODIFIED PA YMENT AMOU NT REPORTE D FROM ^CH MEDI DATA  TO ^CHMPAY  DATA
  1939   "RTN","CH8 35F1",475, 0)
  1940    ; 2/18/20 14  DLB  M ODIFIED TO  OUTPUT "0 " FOR < $1 .00 ADJUDI CATION AMT
  1941   "RTN","CH8 35F1",476, 0)
  1942    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  1943   "RTN","CH8 35F1",477, 0)
  1944    ;
  1945   "RTN","CH8 35F1",478, 0)
  1946   BPR(PAYI,N FILE,STSEQ ,VENI,EDII ,EI,DT)
  1947   "RTN","CH8 35F1",479, 0)
  1948    ; PAYI          INDE X TO ^CHMP AY()
  1949   "RTN","CH8 35F1",480, 0)
  1950    ; NFILE F ILE IDENTI FIER FOR E ACH RECORD
  1951   "RTN","CH8 35F1",481, 0)
  1952    ; STSEQ S EQUENCE CO UNTER FOR  THE RECORD S
  1953   "RTN","CH8 35F1",482, 0)
  1954    ; VENI          VEND OR ID
  1955   "RTN","CH8 35F1",483, 0)
  1956    ; EDII          INDE X FROM ^TM P($J,"EDI- 835",CHPID ,^CHMEDI(I ))
  1957   "RTN","CH8 35F1",484, 0)
  1958    ; EI   EN TITY INDEX  TO ^CHMED IPA()
  1959   "RTN","CH8 35F1",485, 0)
  1960    ; DT   TO DAY'S DATE
  1961   "RTN","CH8 35F1",486, 0)
  1962    N PMETHOD ,PYRDFI,PY RACCT,RCVD FI,RCVACCT ,PDATE,CHK EFDT,REC,I ,CHKAMT
  1963   "RTN","CH8 35F1",487, 0)
  1964    S (PMETHO D,PYRDFI,P YRACCT,RCV DFI,RCVACC T,PDATE,CH KEFDT)=""
  1965   "RTN","CH8 35F1",488, 0)
  1966    S PAMT=0, PMETHOD="" ,CHKAMT=0
  1967   "RTN","CH8 35F1",489, 0)
  1968    S:EI'=""  PYRID=$P($ G(^CHMEDIP A(EI,0))," ^",8) ; HA C PAYER ID
  1969   "RTN","CH8 35F1",490, 0)
  1970    S PAMT=$$ BPRPAMT(PA YI)                                             ; DLB  3/11/2014   MODIFIED  TO SUM AMT  PAID TO V ENDOR
  1971   "RTN","CH8 35F1",491, 0)
  1972    S CHKAMT= $S(PAMT<1. 00:0,1:PAM T)                 ;  DLB 3/11/2 014  CANNO T TRUST CH ECK AMOUNT  FROM ^CHM EDI()
  1973   "RTN","CH8 35F1",492, 0)
  1974    S PMETHOD =$$PMETHOD ^CH835FU1( PAYI,CHKAM T) ; PAYME NT METHOD  (CHK/ACH)( CHECKS FOR  REJECTED  STATUS)
  1975   "RTN","CH8 35F1",493, 0)
  1976    I PMETHOD ="ACH" D                                                   ; "ACH " = AUTOMA TED CLEARI NG HOUSE
  1977   "RTN","CH8 35F1",494, 0)
  1978    .S PYRDFI =111036183                                        ; PA YER (HAC)  EFT BANK N UMBER
  1979   "RTN","CH8 35F1",495, 0)
  1980    .S PYRACC T=36001200 0                                      ; PA YER (HAC)  EFT ACCT N UMBER
  1981   "RTN","CH8 35F1",496, 0)
  1982    .S RCVDFI =$$RCVDFI^ CH835FU1(V ENI)               ;  VENDOR EFT  BANK NUMB ER (^CHMVE N(VENI,3)) ,"^",1))
  1983   "RTN","CH8 35F1",497, 0)
  1984    .S RCVACC T=$P($G(^C HMVEN(VENI ,3)),"^",3 ) ; VENDOR  EFT BANK  ACCT CODE
  1985   "RTN","CH8 35F1",498, 0)
  1986    .S:$D(^CH MPAY(PAYI, 1)) CHKEFD T=$$DTOUT^ CH835FU1($ P(^CHMPAY( PAYI,1),"^ ",4)) ; DA TE OF TREA SURY PAYME NT
  1987   "RTN","CH8 35F1",499, 0)
  1988    I PMETHOD ="CHK"  D
  1989   "RTN","CH8 35F1",500, 0)
  1990    .S:$D(^CH MPAY(PAYI, 1)) CHKEFD T=$$DTOUT^ CH835FU1($ P(^CHMPAY( PAYI,1),"^ ",4)) ; DA TE OF TREA SURY PAYME NT
  1991   "RTN","CH8 35F1",501, 0)
  1992    I CHKEFDT ="" D
  1993   "RTN","CH8 35F1",502, 0)
  1994    .S CHKEFD T=$$FMTE^X LFDT(DT,"5 D")                ;  EFT DATE C ANNOT BE N ULL: IF NO  DATE, SET  TODAY'S D ATE
  1995   "RTN","CH8 35F1",503, 0)
  1996    .S CKMONT H=$P(CHKEF DT,"/",1)
  1997   "RTN","CH8 35F1",504, 0)
  1998    .S CKDAY= $P(CHKEFDT ,"/",2)
  1999   "RTN","CH8 35F1",505, 0)
  2000    .F I=1:1: 2-$L(CKMON TH) S CKMO NTH="0"_CK MONTH
  2001   "RTN","CH8 35F1",506, 0)
  2002    .F I=1:1: 2-$L(CKDAY ) S CKDAY= "0"_CKDAY
  2003   "RTN","CH8 35F1",507, 0)
  2004    .S CHKEFD T=$P(CHKEF DT,"/",3)_ CKMONTH_CK DAY
  2005   "RTN","CH8 35F1",508, 0)
  2006    S REC=""
  2007   "RTN","CH8 35F1",509, 0)
  2008    F LN=1:1  S STR=$T(B PRTBL+LN)  Q:STR["END  OF RECORD "  D ; TAB LE GENERAT ED RECORD
  2009   "RTN","CH8 35F1",510, 0)
  2010    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)
  2011   "RTN","CH8 35F1",511, 0)
  2012    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  2013   "RTN","CH8 35F1",512, 0)
  2014    S ^TMP($J ,"EDI_CREA TE","BPR", 0)=REC
  2015   "RTN","CH8 35F1",513, 0)
  2016    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F1: BPR RE CORD: ",RE C
  2017   "RTN","CH8 35F1",514, 0)
  2018    Q
  2019   "RTN","CH8 35F1",515, 0)
  2020    ;
  2021   "RTN","CH8 35F1",516, 0)
  2022    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2023   "RTN","CH8 35F1",517, 0)
  2024    ; IF THE  ADJUDICATE D AMOUNTS  (SUM OF ^C HMEDI() EN TRIES FOR  ^CHMPAY(I, 0), FIELD  14)
  2025   "RTN","CH8 35F1",518, 0)
  2026    ; IS < $1 .00 REPORT  THE AMOUN T AS 0 IN  THE BPR RE CORD
  2027   "RTN","CH8 35F1",519, 0)
  2028    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2029   "RTN","CH8 35F1",520, 0)
  2030    ;
  2031   "RTN","CH8 35F1",521, 0)
  2032   BPRPAMT(PA YI)
  2033   "RTN","CH8 35F1",522, 0)
  2034    N CALC,PA MT,CHKEFT, IDX,JDX
  2035   "RTN","CH8 35F1",523, 0)
  2036    S CALCPMT =$$CALCPMT (PAYI)                                 ; HA NDLE "GROU PING" OF C LAIMS IF N ECESSARY
  2037   "RTN","CH8 35F1",524, 0)
  2038    S PAMT=$P (CALCPMT," ^",2)                                  ; CA LCPMT() SU MS AMOUNT  TO BE PAID (FIELD 1)_ "^"_SUM OF  VENDOR PA YMENT (FIE LD 14)
  2039   "RTN","CH8 35F1",525, 0)
  2040    S:PAMT<1. 00 PAMT=0                                         ; IF  TOTAL ADJ UDICATED V ENDOR PAYM ENT AMOUNT  < $1.00 R EPORT 0 IN  BPR RECOR D
  2041   "RTN","CH8 35F1",526, 0)
  2042    Q PAMT
  2043   "RTN","CH8 35F1",527, 0)
  2044    ;
  2045   "RTN","CH8 35F1",528, 0)
  2046    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2047   "RTN","CH8 35F1",529, 0)
  2048    ; THIS CO DE PERFORM S A SANITY  CHECK FOR  THE PAYME NT AMOUNT  FOR GROUPE D
  2049   "RTN","CH8 35F1",530, 0)
  2050    ; CLAIMS  AGAINST TH E ^CHMSNA( 741008.17  FILE
  2051   "RTN","CH8 35F1",531, 0)
  2052    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  2053   "RTN","CH8 35F1",532, 0)
  2054    ;
  2055   "RTN","CH8 35F1",533, 0)
  2056    ;I PAMT>0 .99  D
  2057   "RTN","CH8 35F1",534, 0)
  2058    ;.I $$PME THOD(CI,PA MT)="CHK"  D                           ; DE TERMINE PM ETHOD FROM  REJECT ST ATUS AND P AYMENT AMO UNT
  2059   "RTN","CH8 35F1",535, 0)
  2060    ;..S CHKE FT=$P(^CHM PAY(PAYI,1 ),"^",16)          ;  RETRIEVE V ENDOR CHEC K NUMBER F OR NON "0"  PAY CLAIM S
  2061   "RTN","CH8 35F1",536, 0)
  2062    ;..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))
  2063   "RTN","CH8 35F1",537, 0)
  2064    ;..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
  2065   "RTN","CH8 35F1",538, 0)
  2066    ;...U 0 W  !,"PAYMEN T AMOUNT ' = CHECK AM OUNT."
  2067   "RTN","CH8 35F1",539, 0)
  2068    ;Q
  2069   "RTN","CH8 35F1",540, 0)
  2070    ;
  2071   "RTN","CH8 35F1",541, 0)
  2072    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2073   "RTN","CH8 35F1",542, 0)
  2074    ; TRN REC ORD GENERA TION
  2075   "RTN","CH8 35F1",543, 0)
  2076    ; DLB 8/2 8/2012  MA DE THIS A  FUNCTION
  2077   "RTN","CH8 35F1",544, 0)
  2078    ; THIS FU NCTION GAT HERS THE T RN DATA AN D UTILIZES  THE TABLE  DRIVEN
  2079   "RTN","CH8 35F1",545, 0)
  2080    ; RECORD  GENERATION  CAPABILIT Y TO STORE  THE RECOR D.
  2081   "RTN","CH8 35F1",546, 0)
  2082    ; THGE OR IGINAL COD E TO GENER ATE THE TR N RECORD:
  2083   "RTN","CH8 35F1",547, 0)
  2084    ; S ^TMP( $J,"EDI_CR EATE","TRN ",0)="TRN" _"^"_NFILE _"^"_STSEQ _"^"_FMSID _"^"_PYRID _"^"_TRSPY MNT
  2085   "RTN","CH8 35F1",548, 0)
  2086    ; DEVELOP ER'S NOTE:  IN CH835D RV.INT THE RE IS A CH ECK TO DET ERMINE
  2087   "RTN","CH8 35F1",549, 0)
  2088    ; IF THE  REQUIRED C HECK NUMBE R HAS BEEN  RECEIVED.  IF NOT, T HE CLAIM
  2089   "RTN","CH8 35F1",550, 0)
  2090    ; IS NOT  "QUE'D" FO R 835 GENE RATION. TH E FACT THA T WE ARE P ROCESSING
  2091   "RTN","CH8 35F1",551, 0)
  2092    ; THE CLA IM AT THIS  POINT MEA NS THAT TH E REQUIRED  INFORMATI ON HAS
  2093   "RTN","CH8 35F1",552, 0)
  2094    ; BEEN VE RIFIED.
  2095   "RTN","CH8 35F1",553, 0)
  2096    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2097   "RTN","CH8 35F1",554, 0)
  2098    ;
  2099   "RTN","CH8 35F1",555, 0)
  2100   TRN(PAYI,N FILE,STSEQ ,FMSID,EI)
  2101   "RTN","CH8 35F1",556, 0)
  2102    ; PAYI          INDE X TO ^CHMP AY CLAIM R ECORD
  2103   "RTN","CH8 35F1",557, 0)
  2104    ; NFILE F ILE IDENTI FIER FOR E ACH RECORD
  2105   "RTN","CH8 35F1",558, 0)
  2106    ; STSEQ S EQUENCE CO UNTER FOR  THE RECORD S
  2107   "RTN","CH8 35F1",559, 0)
  2108    ; FMSID F MS ID FROM  $P(^CHMED I(FMSI,0), "^",1) SEE  FMSLOOP()
  2109   "RTN","CH8 35F1",560, 0)
  2110    ; EI   EN TITY INDEX  TO ^CHMED IPA()
  2111   "RTN","CH8 35F1",561, 0)
  2112    N TRSPYMN T,PYRID,RE C,CHKEFT,R ESULT,APMT ,VPMT
  2113   "RTN","CH8 35F1",562, 0)
  2114    S CHKEFT= FMSID                                                                                         ; IN IT THE CHK /EFT NUMBE R VARIABLE  TO FMS DO C ID AS DE FAULT
  2115   "RTN","CH8 35F1",563, 0)
  2116    S RESULT= $$CALCPMT( PAYI)                                                             ; HANDLE " GROUPING"  OF CLAIMS  IF NECESSA RY
  2117   "RTN","CH8 35F1",564, 0)
  2118    S APMT=$P (RESULT,"^ ",1),VPMT= $P(RESULT, "^",2)           ; SE T AMOUNT O F PAYMENT  AND AMOUNT  PAID TO V ENDOR VARI ABLES
  2119   "RTN","CH8 35F1",565, 0)
  2120    I (APMT>0 .99)&(VPMT >0.99)  D                                                ; AMT TO  BE PAID A ND AMT PAI D TO VENDO R BOTH > 0 .99
  2121   "RTN","CH8 35F1",566, 0)
  2122    .S CHKEFT =$P(^CHMPA Y(PAYI,1), "^",16)                              ; RETR IEVE VENDO R CHECK NU MBER FOR N ON "0" PAY  CLAIMS
  2123   "RTN","CH8 35F1",567, 0)
  2124    S:EI]"" P YRID=$P($G (^CHMEDIPA (EI,0)),"^ ",8)             ; HA C PAYER ID
  2125   "RTN","CH8 35F1",568, 0)
  2126    S:$D(^CHM PAY(PAYI,1 )) TRSPYMN T=$$DTOUT^ CH835FU1($ P(^CHMPAY( PAYI,1),"^ ",4))              ;  DATE OF TR EASURY PAY MENT
  2127   "RTN","CH8 35F1",569, 0)
  2128    S REC=""
  2129   "RTN","CH8 35F1",570, 0)
  2130    F LN=1:1  S STR=$T(T RNTBL+LN)  Q:STR["END  OF RECORD "  D           ; TABL E GENERATE D RECORDS
  2131   "RTN","CH8 35F1",571, 0)
  2132    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)
  2133   "RTN","CH8 35F1",572, 0)
  2134    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  2135   "RTN","CH8 35F1",573, 0)
  2136    S ^TMP($J ,"EDI_CREA TE","TRN", 0)=REC
  2137   "RTN","CH8 35F1",574, 0)
  2138    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F1: TRN RE CORD: ",RE C
  2139   "RTN","CH8 35F1",575, 0)
  2140    Q
  2141   "RTN","CH8 35F1",576, 0)
  2142    ;
  2143   "RTN","CH8 35F1",577, 0)
  2144    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2145   "RTN","CH8 35F1",578, 0)
  2146    ; CALCPMT () FUNCTIO N SUMS THE  "GROUPED"  CLAIMS IN  ^CHMEDI()  TO
  2147   "RTN","CH8 35F1",579, 0)
  2148    ; DETERMI NE THE PAY MENT AMOUN T FOR THE  GROUP.
  2149   "RTN","CH8 35F1",580, 0)
  2150    ; THE ^CH MEDI("C",P AYI,CHMEDI (I)) CROSS REFERENCE  IS USED TO
  2151   "RTN","CH8 35F1",581, 0)
  2152    ; DETERMI NE THE ^CH MEDI INDEX , THEN THE  POINTER T O ^CHMPAY( )
  2153   "RTN","CH8 35F1",582, 0)
  2154    ; FOR EAC H ENTRY IN  ^CHMEDI I S USED TO  GATHER PAY MENT INFO
  2155   "RTN","CH8 35F1",583, 0)
  2156    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2157   "RTN","CH8 35F1",584, 0)
  2158    ;
  2159   "RTN","CH8 35F1",585, 0)
  2160   CALCPMT(PA YI)
  2161   "RTN","CH8 35F1",586, 0)
  2162    ;  PAYI         THE  CURRENT PO INTER TO T HE ^CHMPAY () ENTRY
  2163   "RTN","CH8 35F1",587, 0)
  2164    N EDII,ED IJ,PMT,VPM T,CPAYI
  2165   "RTN","CH8 35F1",588, 0)
  2166    S EDII=0, EDII=$O(^C HMEDI("C", PAYI,EDII) )     ; XR EF TO RETR IEVE ^CHME DI(I)
  2167   "RTN","CH8 35F1",589, 0)
  2168    S EDIJ=0, PMT=0,VPMT =0
  2169   "RTN","CH8 35F1",590, 0)
  2170    I EDII=""  Q PMT_"^" _VPMT                                                     ; EXIT  OF NOT AVA ILABLE
  2171   "RTN","CH8 35F1",591, 0)
  2172    F  S EDIJ =$O(^CHMED I(EDII,1,E DIJ))  Q:+ (EDIJ)=0   D  ; LOOP  THROUGH TH E ^CHMEDI( J) INDICES
  2173   "RTN","CH8 35F1",592, 0)
  2174    .S CPAYI= $P(^CHMEDI (EDII,1,ED IJ,0),"^", 1)                ; G ET THE CUR RENT ^CHMP AY POINTER
  2175   "RTN","CH8 35F1",593, 0)
  2176    .Q:('$D(^ CHMPAY(CPA YI,1)))                                                   ; EXIT  IF NO ^CHM PAY() PAY  NODE (I,1)
  2177   "RTN","CH8 35F1",594, 0)
  2178    .S PMT=PM T+$P(^CHMP AY(CPAYI,1 ),"^",1)                     ; S UM THE AMO UNTS TO BE  PAID
  2179   "RTN","CH8 35F1",595, 0)
  2180    .S VPMT=V PMT+$P(^CH MPAY(CPAYI ,1),"^",14 )                 ; S UM THE AMO UNTS TO BE  PAID TO V ENDOR
  2181   "RTN","CH8 35F1",596, 0)
  2182    Q PMT_"^" _VPMT
  2183   "RTN","CH8 35F1",597, 0)
  2184    ;
  2185   "RTN","CH8 35F1",598, 0)
  2186    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2187   "RTN","CH8 35F1",599, 0)
  2188    ; PLB REC ORD GENERA TION
  2189   "RTN","CH8 35F1",600, 0)
  2190    ; NOTE: T HIS FUNCTI ON USES TH E ^TMP($J, "EDI_CREAT E","CLP",I VAL)
  2191   "RTN","CH8 35F1",601, 0)
  2192    ; DLB 8/2 8/2012  MA DE THIS A  FUNCTION
  2193   "RTN","CH8 35F1",602, 0)
  2194    ; THIS FU NCTION GAT HERS THE P LB DATA AN D UTILIZES  THE TABLE  DRIVEN
  2195   "RTN","CH8 35F1",603, 0)
  2196    ; RECORD  GENERATION  CAPABILIT Y TO STORE  THE RECOR D INTO ^TM P($J,"EDI_ CREATE","P LB",0)
  2197   "RTN","CH8 35F1",604, 0)
  2198    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  2199   "RTN","CH8 35F1",605, 0)
  2200    ;
  2201   "RTN","CH8 35F1",606, 0)
  2202   PLB(NFILE, STSEQ,VENI ,EDII,DT,P AYI,PAMT)
  2203   "RTN","CH8 35F1",607, 0)
  2204    ; NFILE F ILE IDENTI FIER FOR E ACH RECORD
  2205   "RTN","CH8 35F1",608, 0)
  2206    ; STSEQ S EQUENCE CO UNTER FOR  THE RECORD S
  2207   "RTN","CH8 35F1",609, 0)
  2208    ; VENI          VEND OR ID
  2209   "RTN","CH8 35F1",610, 0)
  2210    ; EDII          "I"  INDEX FOR  ^CHMEDI()
  2211   "RTN","CH8 35F1",611, 0)
  2212    ; DT   TO DAY'S DATE
  2213   "RTN","CH8 35F1",612, 0)
  2214    ; PAYI          CURR ENT ^CHMPA Y(I) INDEX
  2215   "RTN","CH8 35F1",613, 0)
  2216    ; PAMT          TOTA L OF THE C LP PROVIDE R PAYMENT  FIELDS
  2217   "RTN","CH8 35F1",614, 0)
  2218    N PLBPTID ,PLBENDFY, PLBADJCD,P LBADAMT,PL BRSNCD,BPR 02,PLBTOT, IVAL,REC
  2219   "RTN","CH8 35F1",615, 0)
  2220    N PYMNTAM T,TOTALLOW ,FMSID,REJ I,REJCODE, REJAMT,REJ TYPE
  2221   "RTN","CH8 35F1",616, 0)
  2222    S (BILLAM T,VNDRPMT, CLMADJ,SVC ADJ,PLBTOT ,REJI,REJC ODE,REJAMT )=0          ; INIT T HE PLB TOT AL VARIABL ES
  2223   "RTN","CH8 35F1",617, 0)
  2224    S (PLBPTI D,PLBENDFY ,PLBADJCD, PLBADAMT,P LBRSNCD,RE JTYPE)=""
  2225   "RTN","CH8 35F1",618, 0)
  2226    S PLBPTID =$P($G(^CH MVEN(VENI, 0)),"^",3)  ; PROVIDE R TAX ID N UMBER (TIN )
  2227   "RTN","CH8 35F1",619, 0)
  2228    S PRENDFY =$$FMTE^XL FDT(DT,"5D ")                 ;F ISCAL YEAR : DEC 31 O F CURRENT  YEAR
  2229   "RTN","CH8 35F1",620, 0)
  2230    S PLBENDF Y=$P(PREND FY,"/",3)_ "1231"
  2231   "RTN","CH8 35F1",621, 0)
  2232    S CHKNUM= $P(^CHMEDI (EDII,0)," ^",3)              ;  CHECK NUMB ER
  2233   "RTN","CH8 35F1",622, 0)
  2234    S FMSID=$ P(^CHMEDI( EDII,0),"^ ",1)       ;RECONCILI ATION NUMB ER
  2235   "RTN","CH8 35F1",623, 0)
  2236    S (CLP04T OT,PLBTOT, BPR02)=0                      ;I F CLAIM IS  UNDER 1.0 0 = PAID A MT ELSE 0
  2237   "RTN","CH8 35F1",624, 0)
  2238    S REJI=$S ($P(^CHMPA Y(PAYI,0), "^",2)=0:$ P(^CHMPAY( PAYI,0),"^ ",13),1:"" )
  2239   "RTN","CH8 35F1",625, 0)
  2240    S:REJI RE JTYPE=$$RE JTYPE^CH83 5FU1(REJI)  ; INFORMA TIONAL OR  REJECT TYP E
  2241   "RTN","CH8 35F1",626, 0)
  2242    S:REJTYPE =0 REJCODE =$$REJCD^C H835FU1(RE JI) ; $P($ G(^CHMDIC( 741002.22, I,0)),"^", 1)      PR OBLEM STAT US CODE
  2243   "RTN","CH8 35F1",627, 0)
  2244    I REJCODE  S PLBTOT= 0                                      ; RE JECTED, RE JECT TOTAL  BILLED AM T
  2245   "RTN","CH8 35F1",628, 0)
  2246    ;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
  2247   "RTN","CH8 35F1",629, 0)
  2248    ;U 0 W !, "F1***PLB: PLB VAL: " ,PLBTOT,"  REJCODE: " ,REJCODE,"   VNDR PAI D: ",PAMT
  2249   "RTN","CH8 35F1",630, 0)
  2250    S REC=""
  2251   "RTN","CH8 35F1",631, 0)
  2252    F LN=1:1  S STR=$T(P LBTBL+LN)  Q:STR["END  OF RECORD "  D ; TAB LE GENERAT ED RECORDS
  2253   "RTN","CH8 35F1",632, 0)
  2254    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)
  2255   "RTN","CH8 35F1",633, 0)
  2256    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  2257   "RTN","CH8 35F1",634, 0)
  2258    S ^TMP($J ,"EDI_CREA TE","PLB", 0)=REC
  2259   "RTN","CH8 35F1",635, 0)
  2260    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F1: PLB RE CORD: ",RE C
  2261   "RTN","CH8 35F1",636, 0)
  2262    Q
  2263   "RTN","CH8 35F1",637, 0)
  2264    ;
  2265   "RTN","CH8 35F1",638, 0)
  2266    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  2267   "RTN","CH8 35F1",639, 0)
  2268    ; THE FOL LOWING ROU TINES OUTP UT THE REC ORDS THAT  WERE CREAT ED DURING  THE 835 PR OCESS.
  2269   "RTN","CH8 35F1",640, 0)
  2270    ; THIS RO UTINE IS B YPASSED IF  THERE ARE  BALANCE C HECK ERROR S REPORTED  IN THE CH 835BAL.INT
  2271   "RTN","CH8 35F1",641, 0)
  2272    ; ROUTINE . THIS COD E WAS EXIS TING CODE,  SO IT IS  NOT THE EA SIEST TO F OLLOW. BAS ICALLY,
  2273   "RTN","CH8 35F1",642, 0)
  2274    ; THE REC ORD GENERA TION PROCE SS POPULAT ES THE ARR AYS AS REQ UIRED, AND  THIS ROUT INE OUTPUT S
  2275   "RTN","CH8 35F1",643, 0)
  2276    ; THE DAT A CONTAINE D IN THE ^ TMP($J,"ED I-CREATE"  ARRAY.
  2277   "RTN","CH8 35F1",644, 0)
  2278    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  2279   "RTN","CH8 35F1",645, 0)
  2280    ;
  2281   "RTN","CH8 35F1",646, 0)
  2282   WRT ;Write s lines to  file
  2283   "RTN","CH8 35F1",647, 0)
  2284    I $D(^TMP ($J,"EDI_C REATE","HD R",0)) D
  2285   "RTN","CH8 35F1",648, 0)
  2286    .U FIO W  ^TMP($J,"E DI_CREATE" ,"HDR",0), ! Q              ; WR ITE HDR RE CORD
  2287   "RTN","CH8 35F1",649, 0)
  2288    I $D(^TMP ($J,"EDI_C REATE","BP R",0)) D
  2289   "RTN","CH8 35F1",650, 0)
  2290    .U FIO W  ^TMP($J,"E DI_CREATE" ,"BPR",0), ! Q              ; WR ITE THE BP R RECORD F ROM ^TMP a RRAY
  2291   "RTN","CH8 35F1",651, 0)
  2292    I $D(^TMP ($J,"EDI_C REATE","TR N",0)) D
  2293   "RTN","CH8 35F1",652, 0)
  2294    .U FIO W  ^TMP($J,"E DI_CREATE" ,"TRN",0), ! Q              ; WR ITE THE TR N RECORD
  2295   "RTN","CH8 35F1",653, 0)
  2296    I $D(^TMP ($J,"EDI_C REATE","CL P")) D
  2297   "RTN","CH8 35F1",654, 0)
  2298    .S TI=0
  2299   "RTN","CH8 35F1",655, 0)
  2300    .F  S TI= $O(^TMP($J ,"EDI_CREA TE","CLP", TI)) Q:'TI   D
  2301   "RTN","CH8 35F1",656, 0)
  2302    ..U FIO W  ^TMP($J," EDI_CREATE ","CLP",TI ),!              ; WR ITE MULTIP LE CLP REC ORDS
  2303   "RTN","CH8 35F1",657, 0)
  2304    ..I $D(^T MP($J,"EDI _CREATE"," CLPNAME",T I)) D
  2305   "RTN","CH8 35F1",658, 0)
  2306    ...U FIO  W ^TMP($J, "EDI_CREAT E","CLPNAM E",TI),!
  2307   "RTN","CH8 35F1",659, 0)
  2308    ..I $D(^T MP($J,"EDI _CREATE"," CLPCAS",TI )) D
  2309   "RTN","CH8 35F1",660, 0)
  2310    ...S CLPC TI=0 F  S  CLPCTI=$O( ^TMP($J,"E DI_CREATE" ,"CLPCAS", TI,CLPCTI) ) Q:'CLPCT I  D
  2311   "RTN","CH8 35F1",661, 0)
  2312    ....U FIO  W ^TMP($J ,"EDI_CREA TE","CLPCA S",TI,CLPC TI),!          ; WRIT E MULTIPLE  CLPCAS RE CORDS
  2313   "RTN","CH8 35F1",662, 0)
  2314    ....Q
  2315   "RTN","CH8 35F1",663, 0)
  2316    ..D SVCPT (TI)                                                                                 ;  CALL TO WR ITE SVC RE CORDS
  2317   "RTN","CH8 35F1",664, 0)
  2318    ...Q
  2319   "RTN","CH8 35F1",665, 0)
  2320    ..Q
  2321   "RTN","CH8 35F1",666, 0)
  2322    .Q
  2323   "RTN","CH8 35F1",667, 0)
  2324    I $D(^TMP ($J,"EDI_C REATE","PL B",0)) D
  2325   "RTN","CH8 35F1",668, 0)
  2326    .U FIO W  ^TMP($J,"E DI_CREATE" ,"PLB",0), !                         ; WRIT E THE PLB  RECORDS
  2327   "RTN","CH8 35F1",669, 0)
  2328    .Q
  2329   "RTN","CH8 35F1",670, 0)
  2330    Q
  2331   "RTN","CH8 35F1",671, 0)
  2332    ;
  2333   "RTN","CH8 35F1",672, 0)
  2334    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2335   "RTN","CH8 35F1",673, 0)
  2336    ;PRINT SE RVICE LINE , SERVICE  LINE CAS A ND SERVICE  LINE LQ
  2337   "RTN","CH8 35F1",674, 0)
  2338    ;HR-PBM-P HASE 1B
  2339   "RTN","CH8 35F1",675, 0)
  2340    ; 5591 ch anges for  2 possible  LQ segmen ts - MBJ f or H-R, 12 /24/08
  2341   "RTN","CH8 35F1",676, 0)
  2342    ; ..I $D( ^TMP($J,"E DI_CREATE" ,"SVCLQ",T I,TII)) D      ; old  version
  2343   "RTN","CH8 35F1",677, 0)
  2344    ; ...U FI O W ^TMP($ J,"EDI_CRE ATE","SVCL Q",TI,TII) ,!  ; old  version
  2345   "RTN","CH8 35F1",678, 0)
  2346    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  2347   "RTN","CH8 35F1",679, 0)
  2348   SVCPT(TI)
  2349   "RTN","CH8 35F1",680, 0)
  2350    I $D(^TMP ($J,"EDI_C REATE","SV C",TI)) D
  2351   "RTN","CH8 35F1",681, 0)
  2352    .S TII=0
  2353   "RTN","CH8 35F1",682, 0)
  2354    .F  S TII =$O(^TMP($ J,"EDI_CRE ATE","SVC" ,TI,TII))  Q:'TII  D
  2355   "RTN","CH8 35F1",683, 0)
  2356    ..U FIO W  ^TMP($J," EDI_CREATE ","SVC",TI ,TII),!                   ; WRIT E MULTIPLE  SVC RECOR D
  2357   "RTN","CH8 35F1",684, 0)
  2358    ..I $D(^T MP($J,"EDI _CREATE"," SVCCAS",TI ,TII)) D
  2359   "RTN","CH8 35F1",685, 0)
  2360    ...S TIII =0
  2361   "RTN","CH8 35F1",686, 0)
  2362    ...F  S T III=$O(^TM P($J,"EDI_ CREATE","S VCCAS",TI, TII,TIII))  Q:'TIII   D
  2363   "RTN","CH8 35F1",687, 0)
  2364    ....U FIO  W ^TMP($J ,"EDI_CREA TE","SVCCA S",TI,TII, TIII),! ;  WRITE MULT IPLE SVCCA S RECORDS
  2365   "RTN","CH8 35F1",688, 0)
  2366    ....;U 0  W !,"WROTE  ^TMP(",$J ,",""EDI_C REATE"","" SVCCAS""," ,TI,",",TI I,",",TIII ,")"
  2367   "RTN","CH8 35F1",689, 0)
  2368    ....Q
  2369   "RTN","CH8 35F1",690, 0)
  2370    ..;HR-PBM -PHASE 1B- Begin 5591  new versi on for 2 L Qs
  2371   "RTN","CH8 35F1",691, 0)
  2372    ..I $D(^T MP($J,"EDI _CREATE"," SVCLQ1",TI ,TII)) D         ; CH ANGED FROM  SVCLQ TO  SVCLQ1           
  2373   "RTN","CH8 35F1",692, 0)
  2374    ...U FIO  W ^TMP($J, "EDI_CREAT E","SVCLQ1 ",TI,TII), !   ; WRIT E THE SVCL Q1 RECORD
  2375   "RTN","CH8 35F1",693, 0)
  2376    ..I $D(^T MP($J,"EDI _CREATE"," SVCLQ2",TI ,TII)) D         ; ad ded SVCLQ2  for 2ND L Q segment
  2377   "RTN","CH8 35F1",694, 0)
  2378    ...U FIO  W ^TMP($J, "EDI_CREAT E","SVCLQ2 ",TI,TII), !     ; WR ITE THE SV CLQ2 RECOR DS
  2379   "RTN","CH8 35F1",695, 0)
  2380    ..; end 5 591 modifi cations
  2381   "RTN","CH8 35F1",696, 0)
  2382    ..;HR-PBM -PHASE 1B- End
  2383   "RTN","CH8 35F1",697, 0)
  2384    ..Q
  2385   "RTN","CH8 35F1",698, 0)
  2386    .Q
  2387   "RTN","CH8 35F1",699, 0)
  2388    Q
  2389   "RTN","CH8 35F1",700, 0)
  2390    ;
  2391   "RTN","CH8 35F1",701, 0)
  2392    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2393   "RTN","CH8 35F1",702, 0)
  2394    ; UPDSTAT US UPDATES , ON A REC ORD BY REC ORD BASIS,  THE ^CHME DI STATUS  FOR RECORD S
  2395   "RTN","CH8 35F1",703, 0)
  2396    ; THE FUN CTION IS P ASSED THE  ^CHMEDI(I)  INDEX TO  IDENTIFY T HE RECORD  SENT.
  2397   "RTN","CH8 35F1",704, 0)
  2398    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2399   "RTN","CH8 35F1",705, 0)
  2400    ;
  2401   "RTN","CH8 35F1",706, 0)
  2402   UPDSTATUS( EI)
  2403   "RTN","CH8 35F1",707, 0)
  2404    ; I  ENTI TY INDEX T O ^CHMEDI  FOR THE RE CORD GENER ATED
  2405   "RTN","CH8 35F1",708, 0)
  2406    S $P(^CHM EDI(EI,0), "^",2)=1              ; SET THE  STATUS TO  "835 RECOR D SENT"
  2407   "RTN","CH8 35F1",709, 0)
  2408    S ^CHMEDI ("D",1,EI) =""                           ;  SET THE "D " CROSS RE FERENCE FO R "835 REC ORD SENT"
  2409   "RTN","CH8 35F1",710, 0)
  2410    K ^CHMEDI ("D",0,EI)                       ; KILL THE  "D" CROSS  REFERENCE  FOR "NEED S SENT"
  2411   "RTN","CH8 35F1",711, 0)
  2412    Q
  2413   "RTN","CH8 35F1",712, 0)
  2414    ;
  2415   "RTN","CH8 35F1",713, 0)
  2416    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2417   "RTN","CH8 35F1",714, 0)
  2418    ; SETASID E(EI)  CHA NGES THE " NEED SENT"  STATUS TO  A "SET AS IDE" STATU S, AND KIL LS
  2419   "RTN","CH8 35F1",715, 0)
  2420    ; THE APP ROPRIATE C ROSS-REFER ENCES.
  2421   "RTN","CH8 35F1",716, 0)
  2422    ; THIS FU NCTION PER FORMS THE  REMOVAL OF  THE "NEED S SENT" ST ATUS FOR A NY CLAIM,  BUT
  2423   "RTN","CH8 35F1",717, 0)
  2424    ; IS INTE NDED TO DO  THIS WHEN  A CLAIM F ALLS OUTSI DE OF THE  ACTIVE QUE UEING WIND OW
  2425   "RTN","CH8 35F1",718, 0)
  2426    ; OF THE  CURRENT DA TE - 180 D AYS.
  2427   "RTN","CH8 35F1",719, 0)
  2428    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2429   "RTN","CH8 35F1",720, 0)
  2430    ;
  2431   "RTN","CH8 35F1",721, 0)
  2432   SETASIDE(E I)
  2433   "RTN","CH8 35F1",722, 0)
  2434    ; I  ENTI TY INDEX T O ^CHMEDI  FOR THE RE CORD TO BE  SET ASIDE
  2435   "RTN","CH8 35F1",723, 0)
  2436    I $$ENVIR ^CHTFLIB'= "LIVE" U 0  W !,"SETT ING ASIDE  ^CHMEDI(", EI,")"
  2437   "RTN","CH8 35F1",724, 0)
  2438    S $P(^CHM EDI(EI,0), "^",2)=180            ; SET THE  STATUS TO  "835 RECOR D SET ASID E"
  2439   "RTN","CH8 35F1",725, 0)
  2440    S ^CHMEDI ("D",180,E I)=""                 ; SET THE  "D" CROSS  REFERENCE  FOR "CLAIM  SET ASIDE "
  2441   "RTN","CH8 35F1",726, 0)
  2442    K ^CHMEDI ("D",0,EI)                       ; KILL THE  "D" CROSS  REFERENCE  FOR "NEED S SENT"
  2443   "RTN","CH8 35F1",727, 0)
  2444    Q
  2445   "RTN","CH8 35F1",728, 0)
  2446    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2447   "RTN","CH8 35F1",729, 0)
  2448    ; REFACTO RED THE RE CORD GENER ATION IN O RDER TO SI MPLIFY REC ORD GENERA TION PROCE SS
  2449   "RTN","CH8 35F1",730, 0)
  2450    ; THE FOL LOWING TAB LES PROVID E THE INFO RMATION TO  FORMAT TH E FIELD, T HE SEQUENC E
  2451   "RTN","CH8 35F1",731, 0)
  2452    ; OF THE  FIELDS, AN D THE LOCA TION OF TH E DATA TO  BE PLACED  IN THE FIE LD.
  2453   "RTN","CH8 35F1",732, 0)
  2454    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2455   "RTN","CH8 35F1",733, 0)
  2456    ; S INHDR ="00000001 "
  2457   "RTN","CH8 35F1",734, 0)
  2458    ; S GRPCT NR="1"
  2459   "RTN","CH8 35F1",735, 0)
  2460    ; S HACID ="0"                                              ; FA CILITY ID  (HAC = "0" )
  2461   "RTN","CH8 35F1",736, 0)
  2462    ; S PAYER ID=$$PID^C H835FU1(CI )                  ;  PAYER ID
  2463   "RTN","CH8 35F1",737, 0)
  2464    ; S CLRHS ID=$$CHID^ CH835FU1(C I)         ; CLEARING  HOUSE ID
  2465   "RTN","CH8 35F1",738, 0)
  2466    ; S PROVI D=$$PROVID ^CH835FU1( VENI)      ; PROVIDER  ID (TIN)
  2467   "RTN","CH8 35F1",739, 0)
  2468    ; S PDI=$ $CLMPDI^CH 835FU1(CI)            ; PDI USED  FOR NPI R ETRIEVAL
  2469   "RTN","CH8 35F1",740, 0)
  2470    ; S PROVN PI=$$PROVN PI^CH835FU 1(PDI) ; P ROVIDER NP I
  2471   "RTN","CH8 35F1",741, 0)
  2472    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  2473   "RTN","CH8 35F1",742, 0)
  2474    ; HDR REC ORD GENERA TION THE F OLLOWING L INE IS REP LACED WITH  THE $TEXT  TABLE
  2475   "RTN","CH8 35F1",743, 0)
  2476    ; CURRENT  RECORD CR EATION FOR  THE "HDR"  RECORD: 1 0/11/12  D LB
  2477   "RTN","CH8 35F1",744, 0)
  2478    ;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
  2479   "RTN","CH8 35F1",745, 0)
  2480    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  2481   "RTN","CH8 35F1",746, 0)
  2482    ;
  2483   "RTN","CH8 35F1",747, 0)
  2484   HDRTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  2485   "RTN","CH8 35F1",748, 0)
  2486    ;;1.HEADE R ID;"HDR" ;36;L;;36A N;R;
  2487   "RTN","CH8 35F1",749, 0)
  2488    ;;2.NEW_F ILE_AUTH_N BR;NFILE;3 6;L;;20AN; R;
  2489   "RTN","CH8 35F1",750, 0)
  2490    ;;3.NEW_S T02TXN_CTL _NBR;STSEQ ;9;L;;5N;R ;
  2491   "RTN","CH8 35F1",751, 0)
  2492    ;;4.INHDR ;"00000001 ";15;L;;10 N;R;
  2493   "RTN","CH8 35F1",752, 0)
  2494    ;;5.GRPCT NR;"1";5;L ;;5N;R;
  2495   "RTN","CH8 35F1",753, 0)
  2496    ;;6.FACIL ITY ID;"0" ;1;L;;1A;R ;
  2497   "RTN","CH8 35F1",754, 0)
  2498    ;;7.PAYER  ID;$$PID^ CH835FU1(P AYI);15;L; ;15AN;R;
  2499   "RTN","CH8 35F1",755, 0)
  2500    ;;8.PROVI DER ID;$$P ROVID^CH83 5FU1(VENI) ;15;L;;15A N;R;
  2501   "RTN","CH8 35F1",756, 0)
  2502    ;;9.CLEAR INGHOUSE I D;$$CHID^C H835FU1(PA YI);15;L;; 15AN;R;
  2503   "RTN","CH8 35F1",757, 0)
  2504    ;;10.USAG E INDICATO R;"P";1;L; ;1A;R;
  2505   "RTN","CH8 35F1",758, 0)
  2506    ;;11.CONS TANT;"NEW" ;15;L;;15A N;R;
  2507   "RTN","CH8 35F1",759, 0)
  2508    ;;12.CONS TANT;"";1; L;;1A;R;
  2509   "RTN","CH8 35F1",760, 0)
  2510    ;;13.PROV IDER NPI;$ $PROVNPI^C H835FU1(PD I);20;L;;2 0AN;R;
  2511   "RTN","CH8 35F1",761, 0)
  2512    ;;END OF  RECORD
  2513   "RTN","CH8 35F1",762, 0)
  2514    ;
  2515   "RTN","CH8 35F1",763, 0)
  2516    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2517   "RTN","CH8 35F1",764, 0)
  2518    ; BPR REC ORD GENERA TION THE F OLLOWING L INE IS REP LACED WITH  THE $TEXT  TABLE
  2519   "RTN","CH8 35F1",765, 0)
  2520    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  2521   "RTN","CH8 35F1",766, 0)
  2522    ; CURRENT  CREATION  FOR THE "B PR" RECORD :
  2523   "RTN","CH8 35F1",767, 0)
  2524    ;S ^TMP($ J,"EDI_CRE ATE","BPR" ,0)=NFILE_ "^"_STSEQ_ "^"_PAMT_" ^"_PMETHOD _"^"_PYRDF I_"^"_PYRA CCT_"^"_PY RID_"^"_RC VDFI_"^"_R CVACCT_"^" _CHKEFDT
  2525   "RTN","CH8 35F1",768, 0)
  2526    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  2527   "RTN","CH8 35F1",769, 0)
  2528    ;
  2529   "RTN","CH8 35F1",770, 0)
  2530    ;SBB 02/2 1/2018 CC4 002-001 up dated BPRT BL to use  REV835 var iable for  voids
  2531   "RTN","CH8 35F1",771, 0)
  2532    ;;4.PAYME NT AMOUNT; $S(REV835= 22:0,1:PAM T);25;L;;1 8.2FPN;R;
  2533   "RTN","CH8 35F1",772, 0)
  2534   BPRTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  2535   "RTN","CH8 35F1",773, 0)
  2536    ;;1.HEADE R ID;"BPR" ;36;L;;36A N;R;
  2537   "RTN","CH8 35F1",774, 0)
  2538    ;;2.FILE_ AUTH_NBR;N FILE;20;L; ;20AN;R;
  2539   "RTN","CH8 35F1",775, 0)
  2540    ;;3.ST02T XN_CTL_NBR ;STSEQ;9;L ;;5N;R;
  2541   "RTN","CH8 35F1",776, 0)
  2542    ;;4.PAYME NT AMOUNT; $S(REV835= 22:0,1:PAM T);25;L;;1 8.2FPN;R;
  2543   "RTN","CH8 35F1",777, 0)
  2544    ;;5.PAYME NT METHOD; PMETHOD;3; L;;3A;R;
  2545   "RTN","CH8 35F1",778, 0)
  2546    ;;6.PAYER  DFI ID;$S (PMETHOD=" ACH":"1110 36183",1:" ");12;L;;1 2AN;R;
  2547   "RTN","CH8 35F1",779, 0)
  2548    ;;7.PAYER  ACCOUNT N UMBER;$S(P METHOD="AC H":"360012 000",1:"") ;35;L;;35A N;R;
  2549   "RTN","CH8 35F1",780, 0)
  2550    ;;8.PAYER  ID;$S(EI' ="":$P($G( ^CHMEDIPA( EI,0)),"^" ,8),1:""); 10;L;;10AN ;O;
  2551   "RTN","CH8 35F1",781, 0)
  2552    ;;9.VENDR  BANK ROUT ING CODE;$ S(PMETHOD= "ACH":$P($ G(^CHMVEN( VENI,3))," ^",1),1:"" );12;L;;12 AN;O;
  2553   "RTN","CH8 35F1",782, 0)
  2554    ;;10.VEND OR BANK AC CT CODE;$S (PMETHOD=" ACH":$P($G (^CHMVEN(V ENI,3)),"^ ",3),1:"") ;35;L;;35A N;O;
  2555   "RTN","CH8 35F1",783, 0)
  2556    ;;11.CLAI M PYMT DAT E;CHKEFDT; 8;L;;DATE; R;
  2557   "RTN","CH8 35F1",784, 0)
  2558    ;;12.END  OF RECORD
  2559   "RTN","CH8 35F1",785, 0)
  2560    ;
  2561   "RTN","CH8 35F1",786, 0)
  2562    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2563   "RTN","CH8 35F1",787, 0)
  2564    ; TRN REC ORD GENERA TION THE F OLLOWING L INE IS REP LACED WITH  THE $TEXT  TABLE
  2565   "RTN","CH8 35F1",788, 0)
  2566    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2567   "RTN","CH8 35F1",789, 0)
  2568    ;  S TRSP YMNT=$$DTO UT^CH835FU 1($P(^CHMP AY(CI,0)," ^",10))                 ; DATE O F TREASURY  PAYMENT
  2569   "RTN","CH8 35F1",790, 0)
  2570    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2571   "RTN","CH8 35F1",791, 0)
  2572    ; CURRENT  RECORD CR EATION FOR  THE "TRN"  RECORD: 1 0/11/12 DL B
  2573   "RTN","CH8 35F1",792, 0)
  2574    ;S ^TMP($ J,"EDI_CRE ATE","TRN" ,0)=NFILE_ "^"_STSEQ_ "^"_FMSID_ "^"_PYRID_ "^"_$$DTOU T^CH835FU1 ($P(CLMLVL (1),"^",4) )
  2575   "RTN","CH8 35F1",793, 0)
  2576    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  2577   "RTN","CH8 35F1",794, 0)
  2578    ;
  2579   "RTN","CH8 35F1",795, 0)
  2580   TRNTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  2581   "RTN","CH8 35F1",796, 0)
  2582    ;;1.HEADE R ID;"TRN" ;5;L;;5A;R ;
  2583   "RTN","CH8 35F1",797, 0)
  2584    ;;2.FILE_ AUTH_NBR;N FILE;36;L; ;20AN;R;
  2585   "RTN","CH8 35F1",798, 0)
  2586    ;;3.ST02T XN_CTL_NBR ;STSEQ;9;L ;;5N;R;
  2587   "RTN","CH8 35F1",799, 0)
  2588    ;;4.RECON CILIATION  NUMBER;CHK EFT;18;L;; 10AN;R;
  2589   "RTN","CH8 35F1",800, 0)
  2590    ;;5.HAC P AYER ID NU MBER;PYRID ;10;L;;10A N;R;
  2591   "RTN","CH8 35F1",801, 0)
  2592    ;;6.TREAS URY PYMT D ATE;$$DTOU T^CH835FU1 ($P(^CHMPA Y(PAYI,0), "^",10));8 ;L;;DATE;R ;
  2593   "RTN","CH8 35F1",802, 0)
  2594    ;;END OF  RECORD
  2595   "RTN","CH8 35F1",803, 0)
  2596    ;
  2597   "RTN","CH8 35F1",804, 0)
  2598    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2599   "RTN","CH8 35F1",805, 0)
  2600    ; PLB REC ORD GENERA TION THE F OLLOWING L INE IS REP LACED WITH  THE $TEXT  TABLE
  2601   "RTN","CH8 35F1",806, 0)
  2602    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  2603   "RTN","CH8 35F1",807, 0)
  2604    ; CURRENT  RECORD CR EATION FOR  THE "PLB"  RECORD: 1 0/11/12  D LB
  2605   "RTN","CH8 35F1",808, 0)
  2606    ;S ^TMP($ J,"EDI_CRE ATE","PLB" ,0)=NFILE_ "^"_STSEQ_ "^"_PLBPTI D_"^"_PLBE NDFY_"^"_P LBRSNCD_"^ "_PLBADJID _"^"_PLBTO T
  2607   "RTN","CH8 35F1",809, 0)
  2608    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  2609   "RTN","CH8 35F1",810, 0)
  2610    ;
  2611   "RTN","CH8 35F1",811, 0)
  2612   PLBTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  2613   "RTN","CH8 35F1",812, 0)
  2614    ;;1.HEADE R ID;"PLB" ;5;L;;5A;R ;
  2615   "RTN","CH8 35F1",813, 0)
  2616    ;;2.NEW_F ILE_AUTH_N BR;NFILE;3 6;L;;36AN; R;
  2617   "RTN","CH8 35F1",814, 0)
  2618    ;;3.NEW_S T02TXN_CTL _NBR;STSEQ ;9;L;;9N;R ;
  2619   "RTN","CH8 35F1",815, 0)
  2620    ;;4.PROVI DER ID;PLB PTID;15;L; ;15AN;O;
  2621   "RTN","CH8 35F1",816, 0)
  2622    ;;5.FISCA L DATE;PLB ENDFY;8;L; ;DATE;O;
  2623   "RTN","CH8 35F1",817, 0)
  2624    ;;6.ADJ R EASON CODE ;"L6";2;L; ;2AN;O;
  2625   "RTN","CH8 35F1",818, 0)
  2626    ;;7.RECON CILIATION  NUMBER;FMS ID;30;L;;3 0AN;O;
  2627   "RTN","CH8 35F1",819, 0)
  2628    ;;8.PROVI DER ADJ TO TAL;PLBTOT ;20;L;;18. 2FP;O;
  2629   "RTN","CH8 35F1",820, 0)
  2630    ;;END OF  RECORD
  2631   "RTN","CH8 35F2")
  2632   0^3^B77747 6
  2633   "RTN","CH8 35F2",1,0)
  2634   CH835F2 ;H AC/AEB;EDI  835 FILE  EXTRACT- c laim loop;  06-15-200 1;
  2635   "RTN","CH8 35F2",2,0)
  2636    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  2637   "RTN","CH8 35F2",3,0)
  2638    ;;DEV0042 25 1/12/20 10 AEB
  2639   "RTN","CH8 35F2",4,0)
  2640    ;HR-PBM-P HASE 1B-Be gin
  2641   "RTN","CH8 35F2",5,0)
  2642    ;   This  routines l oops thru  each claim  within an  FMS-ID an d load
  2643   "RTN","CH8 35F2",6,0)
  2644    ;       8 35 data in  TMP globa l ^TMP($J, "EDI_CREAT E")
  2645   "RTN","CH8 35F2",7,0)
  2646    ;HR - Tea m Track #:  5592
  2647   "RTN","CH8 35F2",8,0)
  2648    ;HR - New  835 Routi ne that re places the  old CHEDI * Routines
  2649   "RTN","CH8 35F2",9,0)
  2650    ;DEV00422 5 1/21/201 0 AEB
  2651   "RTN","CH8 35F2",10,0 )
  2652    ;DEV01396 2-01 1/24/ 11 JEH - E DI - CARC  42 display ing in the  835 inste ad of 45
  2653   "RTN","CH8 35F2",11,0 )
  2654    ;MTN01545 9 6/29/12  BMJ EDI -  Code Chang e - incorr ect Claim  Adjustment  Group cod e
  2655   "RTN","CH8 35F2",12,0 )
  2656    ;TST15525   11/27/20 12 DLB  NE W RELEASE  FOR 835 FL AT FILE GE NERATION
  2657   "RTN","CH8 35F2",13,0 )
  2658    ;MTN01676 2 12/05/20 12 JSE  Fi x <SUBSCRI PT> Error  CLPCASCO+8 ^CH835F2
  2659   "RTN","CH8 35F2",14,0 )
  2660    ;DEV7820  835 REFACT OR  12/17/ 2012  DLB   FOR THE U PGRADED 83 5 AND SLA  REQUIREMEN TS
  2661   "RTN","CH8 35F2",15,0 )
  2662    ; 5/7/201 3 DLB ONLY  IPT CLAIM S GET A CL PCAS RECOR D GENERATE D PER BRIA N
  2663   "RTN","CH8 35F2",16,0 )
  2664    ; 6/6/201 3 DLB MODI FIED THE C LM() AND C LPCAS() FU NCTIONS TO  RETURN PA TIENT RESP ONSIBILITY  FROM "PR"  ADJUSTMEN TS
  2665   "RTN","CH8 35F2",17,0 )
  2666    ; 6/7/13   DLB  REMO VED THE OA -68 ADJUST MENT PER B USINESS: " The code 6 8 was deac tivated in  2003."
  2667   "RTN","CH8 35F2",18,0 )
  2668    ; 6/7/13  DLB MOD TO  GENERATE  0A-23 ADJU STMENT FOR  REJECT AN D NON-REJE CT STATUS
  2669   "RTN","CH8 35F2",19,0 )
  2670    ; 6/7/13  DLB MOD TO  REJECT/0  PAY TO REF LECT THE B ILLED AMOU NT-ALL OHI  PAID VALU E
  2671   "RTN","CH8 35F2",20,0 )
  2672    ; 4/21/20 14 DLB MOD IFIED TO V ERIFY TOS  AND PDI TY PE FOR RXT  SERVICES
  2673   "RTN","CH8 35F2",21,0 )
  2674    ;                        EDI CL AIMS ARE B EING MYSTE RIOUSLY CH ANGED TO " RXT", CAUS ING TOS TO
  2675   "RTN","CH8 35F2",22,0 )
  2676    ;                        NO LON GER CORREC TLY REFLEC T THE INCO MING TYPE.  (APPROX L INE 63)
  2677   "RTN","CH8 35F2",23,0 )
  2678    ; 12/3/15  SLT MODIF IED TO CHE CK FOR A C LAIM LEVEL  PAID AMOU NT <1$ AND  USE CARC  B5
  2679   "RTN","CH8 35F2",24,0 )
  2680    ; 02/21/2 018 SBB CC 4002-001,  CC4002-002 , CC4002-0 03 updates  for Rever sal 835 me ssage
  2681   "RTN","CH8 35F2",25,0 )
  2682    ;
  2683   "RTN","CH8 35F2",26,0 )
  2684    Q
  2685   "RTN","CH8 35F2",27,0 )
  2686    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2687   "RTN","CH8 35F2",28,0 )
  2688    ; CLM PRO CESSES THE  ^CHMPAY " I" RECORD  PROVIDED F ROM THE FM SLOOP^CH83 5F1() FUNC TION.
  2689   "RTN","CH8 35F2",29,0 )
  2690    ; 1) GATH ER THE DAT A FOR THE  CLP,CLPCAS , AND CLPN AME RECORD S AS REQUI RED. THE M AJORITY
  2691   "RTN","CH8 35F2",30,0 )
  2692    ;               OF T HIS DATA I S HOUSED I N THE CLML VL() ARRAY , CREATED  ANEW FOR E ACH CALL F ROM THE 
  2693   "RTN","CH8 35F2",31,0 )
  2694    ;               FMSL OOP() FUNC TION. 6/6/ 13 THE PAT IENT RESPO NSIBILITY  AMOUNT IS  NO LONGER  TAKEN FROM
  2695   "RTN","CH8 35F2",32,0 )
  2696    ;               ^CHM PAY, BUT I S TOTALLED  IN CLPCAS () FROM AL L "PR" ADJ USTMENTS
  2697   "RTN","CH8 35F2",33,0 )
  2698    ; 2) CLPC AS DETERMI NES IF THE  CLPCAS RE CORD IS TO  BE GENERA TED, AND I F SO, CREA TES THE
  2699   "RTN","CH8 35F2",34,0 )
  2700    ;               CAS  ARRAY TO B E USED IN  RECORD GEN ERATION. T HIS FUNCTI ON ALSO FL AGS THE ME DICAL CLAI M
  2701   "RTN","CH8 35F2",35,0 )
  2702    ;               SVC  RECORD REQ UIREMENT ( SVCFLG). N OTE: PHARM ACY CLAIMS  ALWAYS RE QUIRE SVC  RECORDS.
  2703   "RTN","CH8 35F2",36,0 )
  2704    ;      CL PCAS RETUR NS THE TOT AL OF ALL  REPORTED " PR" ADJUST MENTS
  2705   "RTN","CH8 35F2",37,0 )
  2706    ; 3) CLP( ) GATHERS  ADDITIONAL  DATA FROM  MULTIPLE  CLAIM BUFF ERS CONTAI NING DATA  RELATED TO  THE 
  2707   "RTN","CH8 35F2",38,0 )
  2708    ;               CLAI M BEING PR OCESSED (C LAIM ID, A UTH/FILE A UTH, GROUP  CONTROL,  AND PATIEN T CONTROL  #).
  2709   "RTN","CH8 35F2",39,0 )
  2710    ; 4) IF A  CAS ARRAY  WAS CREAT ED BY CLPC AS(), THE  CLPCAS REC ORD IS GEN ERATED BY  THE CLPCAS L() FUNCTI ON.
  2711   "RTN","CH8 35F2",40,0 )
  2712    ; 5) THE  CLP RECORD  IS GENERA TED USING  THE CLPTBL  AND FORMA TDATA^CHMX WBUT() FUN CTION.
  2713   "RTN","CH8 35F2",41,0 )
  2714    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  2715   "RTN","CH8 35F2",42,0 )
  2716    ; 7/31/20 13  DLB AD DED EDI "I " INDEX TO  SVCREC()  CALL SO CH MEDI STATU S CAN BE S ET IF PAY- >IMG INDEX  ERROR 
  2717   "RTN","CH8 35F2",43,0 )
  2718    ;
  2719   "RTN","CH8 35F2",44,0 )
  2720   CLM(EDII,V ENI,NFILE, STSEQ,OAB6 )
  2721   "RTN","CH8 35F2",45,0 )
  2722    ; EDII          ^CHM PAY(I) IND EX FOR THE  CLAIM TO  BE PROCESS ED
  2723   "RTN","CH8 35F2",46,0 )
  2724    ; VENI          VEND OR INDEX
  2725   "RTN","CH8 35F2",47,0 )
  2726    ; NFILE         FILE  IDENTIFIE R FOR EACH  RECORD OU TPUT 
  2727   "RTN","CH8 35F2",48,0 )
  2728    ; STSEQ         SEQU ENCE COUNT ER FOR THE  RECORD OU TPUT
  2729   "RTN","CH8 35F2",49,0 )
  2730    ; OAB6      FLAG IND ICATING <1 $ AMOUNT
  2731   "RTN","CH8 35F2",50,0 )
  2732    ;
  2733   "RTN","CH8 35F2",51,0 )
  2734    N SVCFLG, PATRESP,CA S,CLMLVL,E DIJ,PAYI,C LPI                                 ; CLPI          CL P INDEX FO R CLP,CLPC AS,SVC,SVC CAS RECORD S
  2735   "RTN","CH8 35F2",52,0 )
  2736    N CLMID,A UTH,GRPCTL ,TXNCTL,FI LEAUTH,PTC TL,STR,PTP AID,PRVPMT ,TOS,PDI
  2737   "RTN","CH8 35F2",53,0 )
  2738    S (CLMID, AUTH,GRPCT L,TXNCTL,F ILEAUTH,PT CTL,PTPAID ,PRVPMT,TO S)=""
  2739   "RTN","CH8 35F2",54,0 )
  2740    S (EDIJ,P ATRESP,CLP I)=0
  2741   "RTN","CH8 35F2",55,0 )
  2742    ;ERA Comp liance
  2743   "RTN","CH8 35F2",56,0 )
  2744    S OAB6=$$ LESS1(EDII )
  2745   "RTN","CH8 35F2",57,0 )
  2746    ;
  2747   "RTN","CH8 35F2",58,0 )
  2748    F CNT=1:1   S EDIJ=$ O(^CHMEDI( EDII,1,EDI J)) Q:+(ED IJ)=0  D ;  GET ^CHME DI POINTER  "J" INDEX  TO RETRIE VE ^CHMPAY  "I"
  2749   "RTN","CH8 35F2",59,0 )
  2750    .;I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"F2 : CLM: ^CH MEDI(",EDI I,",1,",ED IJ,",0)=", ^CHMEDI(ED II,1,EDIJ, 0)
  2751   "RTN","CH8 35F2",60,0 )
  2752    .S PAYI=$ P($G(^CHME DI(EDII,1, EDIJ,0))," ^",1)                     ; GET  THE ^CHMPA Y "I" POIN TER VALUE  FROM ^CHME DI RECORD
  2753   "RTN","CH8 35F2",61,0 )
  2754    .Q:'$D(^C HMPAY(PAYI ,0))                                                                      ;  SKIP TO NE XT INDEX I F NOT DEFI NED 
  2755   "RTN","CH8 35F2",62,0 )
  2756    .Q:'$D(^C HMPAY("B", $P(^CHMPAY (PAYI,0)," ^",1)))                   ; MTN0 16762 JSE  - Fix <SUB SCRIPT> CL PCASCO+8^C H835F2
  2757   "RTN","CH8 35F2",63,0 )
  2758    .S CLPI=C LPI+1                                                                                         ; SE T UP THE C LAIM INDEX
  2759   "RTN","CH8 35F2",64,0 )
  2760    .I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"REA DY TO SET  UP CLMLVL  ARRAY"
  2761   "RTN","CH8 35F2",65,0 )
  2762    .N CLMLVL                                                                                                        ; CLEA R THE CLML VL ARRAY
  2763   "RTN","CH8 35F2",66,0 )
  2764    .D CLMLVL ^CH835FU2( PAYI,.CLML VL)                                                    ; SET UP N EW CLMLVL  ARRAY
  2765   "RTN","CH8 35F2",67,0 )
  2766    .S PRVPMT =PRVPMT+(+ ($P($G(^CH MPAY(PAYI, 1)),"^",1) ))    ; PR OVIDER PAY MENT FOR T HIS CLAIM   DLB 5/8/2 013
  2767   "RTN","CH8 35F2",68,0 )
  2768    .S TOS=$$ TOS^CH835F U1($P($G(^ CHMPAY(PAY I,0)),"^", 7))   Q:TO S=0          ; TYPE O F SERVICE
  2769   "RTN","CH8 35F2",69,0 )
  2770    .S PDI=$P ($P(^CHMPA Y(PAYI,0), "^",4),"*" ,1)                                ; MUST R ETRIEVE TH E PDI IN O RDER TO CH ECK TOS
  2771   "RTN","CH8 35F2",70,0 )
  2772    .S CHQTY= 1                                                                                                      ; SET  UP FOR N0N -PHARMACY  CLAIM TOS
  2773   "RTN","CH8 35F2",71,0 )
  2774    .I (TOS=" RXT")&(($E (PDI,8,9)= "99")!($E( PDI,8,9)=" 98"))  D       ; IF T YPE OF SER VICE= PHAR MACY AND P DI TYPE IS  SXC SET P HARM QTY
  2775   "RTN","CH8 35F2",72,0 )
  2776    ..S SVCFL G=1                                                                                           ; PH ARMACY SVC  RECORD GE NERATION
  2777   "RTN","CH8 35F2",73,0 )
  2778    ..;S:TOS= "IPT" PATR ESP=+$P($G (^CHMPAY(P AYI,1)),"^ ",29) ; DL B 6/6/13 R EMOVED OHI  PATIENT R ESPONSIBIL ITY FOR CL P RECORD D LB 4/17/13
  2779   "RTN","CH8 35F2",74,0 )
  2780    ..S CHQTY =$$PHARMQT Y(PAYI)                                                                   ;  SET THE QT Y VALUE FO R PHARMACY  
  2781   "RTN","CH8 35F2",75,0 )
  2782    .D CLP(NF ILE,STSEQ, PAYI,TOS,C LPI,.CLMID ,.AUTH,.GR PCTL,.TXNC TL,.FILEAU TH,.PTCTL, .PTPAID) ;  DATA GATH ERING
  2783   "RTN","CH8 35F2",76,0 )
  2784    .I TOS="I PT"  D                                                                                        ; ON LY INPATIE NT CLAIMS  GET CLPCAS
  2785   "RTN","CH8 35F2",77,0 )
  2786    ..S PATRE SP=PATRESP +$$CLPCAS( PAYI,CLPI, .CAS,.CLML VL,TOS,PTP AID,CHQTY, OAB6)      ; CREATE C AS SEGMENT S FOR CLAI M LEVEL
  2787   "RTN","CH8 35F2",78,0 )
  2788    ..D:$D(CA S(CLPI)) C LPCASL(.CA S,NFILE,ST SEQ,CLMID, CLPI,CHQTY )            ; USE TA BLES TO DE FINE CAS R ECORDS
  2789   "RTN","CH8 35F2",79,0 )
  2790    .E  S PAT RESP=PATRE SP+$$SVCRE C^CH835F3( PAYI,VENI, CLPI,NFILE ,STSEQ,CHQ TY,EDII)           ;  DLB 3/27/1 3 MOVE SVC  RECORDS O N/OFF LOGI C TO SVCRE C
  2791   "RTN","CH8 35F2",80,0 )
  2792    .S REC=""
  2793   "RTN","CH8 35F2",81,0 )
  2794    .;SBB 02/ 21/2018 CC 4002-002 u pdated CLP TBL to use  REV835 va riable to  set -ve va lues for v oids
  2795   "RTN","CH8 35F2",82,0 )
  2796    .F LN=1:1  S STR=$T( CLPTBL+LN)  Q:STR["EN D OF RECOR D"  D  ; T ABLE GENER ATED CLP R ECORDS
  2797   "RTN","CH8 35F2",83,0 )
  2798    ..I LN=1  S REC=REC_ $$FORMATDA TA^CHMXWBU T(STR)           
  2799   "RTN","CH8 35F2",84,0 )
  2800    ..E  S RE C=REC_"^"_ $$FORMATDA TA^CHMXWBU T(STR)
  2801   "RTN","CH8 35F2",85,0 )
  2802    .S ^TMP($ J,"EDI_CRE ATE","CLP" ,CLPI)=REC
  2803   "RTN","CH8 35F2",86,0 )
  2804    .;I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"F2 : CLM: CLP  RECORD: ^ TMP($J,""E DI_CREATE" ",""CLP"", ",CLPI,")=  ",^TMP($J ,"EDI_CREA TE","CLP", CLPI)
  2805   "RTN","CH8 35F2",87,0 )
  2806    Q PRVPMT
  2807   "RTN","CH8 35F2",88,0 )
  2808    ;
  2809   "RTN","CH8 35F2",89,0 )
  2810   LESS1(EDII ) ;SUM(AMT  PAID TO V ENDOR) < $ 1 - ERA Co mpliance
  2811   "RTN","CH8 35F2",90,0 )
  2812    ; return:
  2813   "RTN","CH8 35F2",91,0 )
  2814    ;  vendor  total <$1  "^" bene  total <$1  e.g. 1^0
  2815   "RTN","CH8 35F2",92,0 )
  2816    N EDIJ,AT BV,PAYI,TO T,ATBB
  2817   "RTN","CH8 35F2",93,0 )
  2818    S (TOTV,T OTB,EDIJ)= 0
  2819   "RTN","CH8 35F2",94,0 )
  2820    F  S EDIJ =$O(^CHMED I(EDII,1,E DIJ)) Q:+( EDIJ)=0  D
  2821   "RTN","CH8 35F2",95,0 )
  2822    . S PAYI= $P($G(^CHM EDI(EDII,1 ,EDIJ,0)), U)
  2823   "RTN","CH8 35F2",96,0 )
  2824    . Q:'$D(^ CHMPAY(PAY I,0))
  2825   "RTN","CH8 35F2",97,0 )
  2826    . Q:'$D(^ CHMPAY("B" ,$P(^CHMPA Y(PAYI,0), U)))
  2827   "RTN","CH8 35F2",98,0 )
  2828    . S ATBV= $P($G(^CHM PAY(PAYI,1 )),U,14)
  2829   "RTN","CH8 35F2",99,0 )
  2830    . S ATBB= $P($G(^CHM PAY(PAYI,1 )),U,15)
  2831   "RTN","CH8 35F2",100, 0)
  2832    . S TOTV= TOTV+ATBV, TOTB=TOTB+ ATBB
  2833   "RTN","CH8 35F2",101, 0)
  2834    Q ((TOTV> 0)&(TOTV<1 ))_"^"_((T OTB>0)&(TO TB<1))
  2835   "RTN","CH8 35F2",102, 0)
  2836    ;
  2837   "RTN","CH8 35F2",103, 0)
  2838    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  2839   "RTN","CH8 35F2",104, 0)
  2840    ; CLPCASL () GENERAT ES THE CLP CAS RECORD S FROM THE  DATA GATH ERED IN TH E CLPCAS()
  2841   "RTN","CH8 35F2",105, 0)
  2842    ; FUNCTIO N. THE DAT A IS ESTRA CTED FROM  THE CAS AR RAY AND US ED TO CREA TE
  2843   "RTN","CH8 35F2",106, 0)
  2844    ; THE CLP CAS RECORD S.
  2845   "RTN","CH8 35F2",107, 0)
  2846    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  2847   "RTN","CH8 35F2",108, 0)
  2848    ;
  2849   "RTN","CH8 35F2",109, 0)
  2850   CLPCASL(CA S,NFILE,ST SEQ,CLMID, CLPI,CHQTY )
  2851   "RTN","CH8 35F2",110, 0)
  2852    ; CAS           ARRA Y CONTAINI NG THE CAS  RECORDS T O REPORT
  2853   "RTN","CH8 35F2",111, 0)
  2854    ; NFILE         FILE  NUMBER FO R RECORD O UTPUT
  2855   "RTN","CH8 35F2",112, 0)
  2856    ; STSEQ         RECO RD SEQUENC E NUMBER
  2857   "RTN","CH8 35F2",113, 0)
  2858    ; CLMID         36 C HARACTER C LAIM ID FO R RECORD O UTPUT
  2859   "RTN","CH8 35F2",114, 0)
  2860    ; CLPI          CLAI M LEVEL IN DEX TO CLP ,CLPCAS,SV C,SVCCAS R ECORDS
  2861   "RTN","CH8 35F2",115, 0)
  2862    ; CHQTY         QTY  VALUE FOR  THE CAS SE GMENT(S)
  2863   "RTN","CH8 35F2",116, 0)
  2864    ; 
  2865   "RTN","CH8 35F2",117, 0)
  2866    N GRP,CAS TI,RECI
  2867   "RTN","CH8 35F2",118, 0)
  2868    S GRP="", (CASTI,REC I)=1
  2869   "RTN","CH8 35F2",119, 0)
  2870    F  S GRP= $O(CAS(CLP I,CASTI,GR P)) Q:GRP= ""  D
  2871   "RTN","CH8 35F2",120, 0)
  2872    .S CASLN= $$CASLN^CH 835FU1(CLP I,CASTI,GR P)
  2873   "RTN","CH8 35F2",121, 0)
  2874    .;I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"    ***F2: CL PCASL: CAS LN(",CLPI, ",",CASTI, ",",GRP,")  =",CASLN
  2875   "RTN","CH8 35F2",122, 0)
  2876    .S REC=""
  2877   "RTN","CH8 35F2",123, 0)
  2878    .F LN=1:1  S STR=$T( CLPCASTBL+ LN) Q:STR[ "END OF RE CORD"  D
  2879   "RTN","CH8 35F2",124, 0)
  2880    ..I LN=1  S REC=REC_ $$FORMATDA TA^CHMXWBU T(STR)           
  2881   "RTN","CH8 35F2",125, 0)
  2882    ..E  S RE C=REC_"^"_ $$FORMATDA TA^CHMXWBU T(STR)
  2883   "RTN","CH8 35F2",126, 0)
  2884    .S ^TMP($ J,"EDI_CRE ATE","CLPC AS",CLPI,R ECI)=REC
  2885   "RTN","CH8 35F2",127, 0)
  2886    .;I $$ENV IR^CHTFLIB '="LIVE" U  0 W !,"    F2: CLPCA SL: ^TMP($ J,""EDI-CR EATE"",""C LPCAS"",", CLPI,",",R ECI,")= ", REC
  2887   "RTN","CH8 35F2",128, 0)
  2888    .S RECI=R ECI+1                                                      ; INCR EMENT RECO RD COUNT I NDEX FOR B ALANCE CHE CK
  2889   "RTN","CH8 35F2",129, 0)
  2890    Q
  2891   "RTN","CH8 35F2",130, 0)
  2892    ;
  2893   "RTN","CH8 35F2",131, 0)
  2894    ; ..;D SV CLVL^CH835 FU2(CI,EDI I,TOS,.SVC LVL)                                ; UPDAT E THE SERV ICE LEVEL  DATA 
  2895   "RTN","CH8 35F2",132, 0)
  2896    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2897   "RTN","CH8 35F2",133, 0)
  2898    ; CLP FUN CTION SETS  UP PARAME TERS BASED  ON CLAIM,  PHARMACY  OR NON-PHA RMACY
  2899   "RTN","CH8 35F2",134, 0)
  2900    ; IN PART ICULAR, IT  SETS UP T HE PRE-DEF INED VARIA BLES AUTH, GRPCTL,TXN CTL,
  2901   "RTN","CH8 35F2",135, 0)
  2902    ; FILEAUT H,AND PTCT L VARIABLE S
  2903   "RTN","CH8 35F2",136, 0)
  2904    ; IF PHAR MACY CLAIM , THIS FUN CTION CREA TES THE CL PNAME RECO RD.
  2905   "RTN","CH8 35F2",137, 0)
  2906    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  2907   "RTN","CH8 35F2",138, 0)
  2908    ;
  2909   "RTN","CH8 35F2",139, 0)
  2910   CLP(NFILE, STSEQ,CI,T OS,CLPI,CL MID,AUTH,G RPCTL,TXNC TL,FILEAUT H,PTCTL,PT PAID)
  2911   "RTN","CH8 35F2",140, 0)
  2912    ; -> NFIL E              OUTPUT  FILE NAME  (STARTS E ACH RECORD )
  2913   "RTN","CH8 35F2",141, 0)
  2914    ; -> STSE Q              STATUS  SEQUENCE  NUMBER
  2915   "RTN","CH8 35F2",142, 0)
  2916    ; -> CI                  ^CHMPA Y CLAIM IN DEX VALUE
  2917   "RTN","CH8 35F2",143, 0)
  2918    ; -> TOS                 TYPE O F SERVICE  FOR THE CU RRENT CLAI M (IPT,OPT ,RXT,DUR,D NT,TRV)
  2919   "RTN","CH8 35F2",144, 0)
  2920    ; -> CLPI                CLP IN DEX TO CLP ,CLPCAS,SV C,SVCCAS R ECORDS
  2921   "RTN","CH8 35F2",145, 0)
  2922    ; <- CLMI D              CLAIM  ID NUMBER  TO BE RETU RNED
  2923   "RTN","CH8 35F2",146, 0)
  2924    ; <- AUTH                AUTHOR IZATION #  TO BE RETU RNED
  2925   "RTN","CH8 35F2",147, 0)
  2926    ; <- GRPC TL    GROU P CONTROL  NUMBER TO  BE RETURNE D
  2927   "RTN","CH8 35F2",148, 0)
  2928    ; <- TXNC TL    TRAN SACTION CO NTROL NUMB ER
  2929   "RTN","CH8 35F2",149, 0)
  2930    ; <- FILE AUTH  FILE  AUTHORIZA TION NUMBE R
  2931   "RTN","CH8 35F2",150, 0)
  2932    ; <- PTCT L              PATIEN T CONTROL  NUMBER
  2933   "RTN","CH8 35F2",151, 0)
  2934    ; <- PTPA ID    PATI ENT PAID A MOUNT FROM  CLAIM LEV EL
  2935   "RTN","CH8 35F2",152, 0)
  2936    N RX,INFO ,TMPIO,ZEM CARR,LCNT, PDI
  2937   "RTN","CH8 35F2",153, 0)
  2938    S (CLI,CL AI,CLBI,CL CI,CLEI,RI ,RXI,RXJ,R XK)="",CLP =1
  2939   "RTN","CH8 35F2",154, 0)
  2940    D EDICLM^ CH835FU1(C I,.ZEMCARR )                                                              ;  CREATE THE  "ZEMCARR"  ARRAY
  2941   "RTN","CH8 35F2",155, 0)
  2942    S INFO=$P (ZEMCARR," ^",1)                                                                              ; GE T THE BUFF ER INDEX V ALUES
  2943   "RTN","CH8 35F2",156, 0)
  2944    S PDI=$P( $P(^CHMPAY (CI,0),"^" ,4),"*",1)                                             ; RETRIEVE  THE PDI
  2945   "RTN","CH8 35F2",157, 0)
  2946    I (TOS="R XT")&($E(P DI,8,9)="9 9")  D                                                 ; IF TYPE  OF SERVICE = PHARMACY  AND PDI T YPE IS SXC
  2947   "RTN","CH8 35F2",158, 0)
  2948    .S RXI=$P (INFO,"*", 1),RXJ=$P( INFO,"*",2 ),RXK=$P(I NFO,"*",3)  ; RETRIEV E THE ^CHM XRX INDEX  VALUES
  2949   "RTN","CH8 35F2",159, 0)
  2950    .D CLPNAM E(NFILE,ST SEQ,RXI,RX J,RXK,CLPI )                                           ; PHARMACY  RECORD ON LY REPORTS  PROVIDER  NAME
  2951   "RTN","CH8 35F2",160, 0)
  2952    .S CLMID= $P(^CHMXRX (RXI,100,R XJ,100,RXK ,1),"^",1)                         ; PHARM  PRESCRIPTI ON NUMBER
  2953   "RTN","CH8 35F2",161, 0)
  2954    .I $P($G( ^CHMXRX(RX I,0)),"^", 8)="X" S A UTH="SXC" 
  2955   "RTN","CH8 35F2",162, 0)
  2956    .S:AUTH=" " AUTH="AU TH"                                                                                                  ; PHARM  AUTH
  2957   "RTN","CH8 35F2",163, 0)
  2958    .S GRPCTL =$P($G(^CH MXRX(RXI,0 )),"^",1)_ $E($P($G(^ CHMXRX(RXI ,0)),"^",9 ),4,6)
  2959   "RTN","CH8 35F2",164, 0)
  2960    .S:GRPCTL ="" GRPCTL ="GRPCTL"                                                                                   ; GROU P CONTROL  VALUE
  2961   "RTN","CH8 35F2",165, 0)
  2962    .S:TXNCTL ="" TXNCTL ="0" F I=1 :1:9-$L(TX NCTL) S TX NCTL="0"_T XNCTL        ;TRANSAC TION CONTR OL ENTRY
  2963   "RTN","CH8 35F2",166, 0)
  2964    .I $P($G( ^CHMXRX(RX I,0)),"^", 8)="X" S F ILEAUTH="S XC"
  2965   "RTN","CH8 35F2",167, 0)
  2966    .S:FILEAU TH="" FILE AUTH="FILE AUTH"
  2967   "RTN","CH8 35F2",168, 0)
  2968    .S PTCTL= $P($G(^CHM XRX(RXI,10 0,RXJ,100, RXK,1)),"^ ",1)                             ; PATIENT  CONTROL NU MBER
  2969   "RTN","CH8 35F2",169, 0)
  2970    .S:PTCTL= "" PTCTL=" PTCTL" 
  2971   "RTN","CH8 35F2",170, 0)
  2972    E  D   ;  ALL NON-PH ARMACY CLA IMS (AND P HARMACY SU BMITTED VI A EDI)
  2973   "RTN","CH8 35F2",171, 0)
  2974    .S CLI=$P (INFO,"*", 1),CLAI=$P (INFO,"*", 2),CLBI=$P (INFO,"*", 3),CLCI=$P (INFO,"*", 4),CLEI=$P (INFO,"*", 5)
  2975   "RTN","CH8 35F2",172, 0)
  2976    .S CLMID= $P($G(^CHM XCLE(CLEI, 0)),"^",17 )                                           ; 36 CHARA CTER HAC C LAIM ID
  2977   "RTN","CH8 35F2",173, 0)
  2978    .S:CLMID= "" CLMID=C I
  2979   "RTN","CH8 35F2",174, 0)
  2980    .S AUTH=$ P($G(^CHMX CLA(CLAI,0 )),"^",19)                                             ; SET UP A UTHORIZATI ON
  2981   "RTN","CH8 35F2",175, 0)
  2982    .S:AUTH=" " AUTH="AU TH"
  2983   "RTN","CH8 35F2",176, 0)
  2984    .S GRPCTL =$P($G(^CH MXCLA(CLAI ,0)),"^",6 )                                           ; SET UP G ROUP CONTR OL
  2985   "RTN","CH8 35F2",177, 0)
  2986    .S:GRPCTL ="" GRPCTL ="GRPCTL"
  2987   "RTN","CH8 35F2",178, 0)
  2988    .S TXNCTL =+$P($G(^C HMXCLA(CLA I,0)),"^", 9)                                          ; TXN CONT ROL
  2989   "RTN","CH8 35F2",179, 0)
  2990    .S:TXNCTL ="" TXNCTL ="0" 
  2991   "RTN","CH8 35F2",180, 0)
  2992    .F I=1:1: 9-$L(TXNCT L) S TXNCT L="0"_TXNC TL
  2993   "RTN","CH8 35F2",181, 0)
  2994    .S FILEAU TH=AUTH_"- T"                                                                                 ; FI LEAUTH
  2995   "RTN","CH8 35F2",182, 0)
  2996    .S PTCTL= $P($G(^CHM XCLE(CLEI, 0)),"^",2)                                             ; SET UP P ATIENT CTL  #
  2997   "RTN","CH8 35F2",183, 0)
  2998    .S PTPAID =$P($G(^CH MXCLE(CLEI ,2)),"^",2 )                                           ; CLAIM LE VEL PATIEN T PAID AMO UNT
  2999   "RTN","CH8 35F2",184, 0)
  3000    Q
  3001   "RTN","CH8 35F2",185, 0)
  3002    ;
  3003   "RTN","CH8 35F2",186, 0)
  3004    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  3005   "RTN","CH8 35F2",187, 0)
  3006    ; PHARMQT Y(PAYI) RE TURNS THE  QUANTITY V ALUE FROM  THE ^CHMPA Y() NODE F OR THIS
  3007   "RTN","CH8 35F2",188, 0)
  3008    ; CLAIM.
  3009   "RTN","CH8 35F2",189, 0)
  3010    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  3011   "RTN","CH8 35F2",190, 0)
  3012   PHARMQTY(P AYI)
  3013   "RTN","CH8 35F2",191, 0)
  3014    ; PAYI "I " INDEX IN TO ^CHMPAY () FOR THI S CLAIM
  3015   "RTN","CH8 35F2",192, 0)
  3016    ;
  3017   "RTN","CH8 35F2",193, 0)
  3018    N PAYJ
  3019   "RTN","CH8 35F2",194, 0)
  3020    S PAYJ=0, PAYJ=$O(^C HMPAY(PAYI ,"PHARM",P AYJ))                     ; PHAR MACY CLAIM S ARE 1 CL AIM PER PR ESCRIPTION
  3021   "RTN","CH8 35F2",195, 0)
  3022    Q $P(^CHM PAY(PAYI," PHARM",PAY J,0),"^",1 5)                                 ; RETRUN  THE QUANT ITY VALUE  FOR THE CL AIM
  3023   "RTN","CH8 35F2",196, 0)
  3024    ;
  3025   "RTN","CH8 35F2",197, 0)
  3026    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  3027   "RTN","CH8 35F2",198, 0)
  3028    ; CLPCAS  ARRAY GENE RATION
  3029   "RTN","CH8 35F2",199, 0)
  3030    ; 1) IF T HERE IS A  PATIENT PA ID AMOUNT  >0 -OR- TH E CLAIM IS  "IPT" (IN PATIENT)
  3031   "RTN","CH8 35F2",200, 0)
  3032    ;               CHEC K TO DETER MINE IF CL PCAS RECOR D IS TO BE  GENERATED . UNLESS T HERE IS A 
  3033   "RTN","CH8 35F2",201, 0)
  3034    ;               PATI ENT PAID A MOUNT NO C LPCAS RECO RDS SHOULD  BE GENERA TED FOR AN YTHING
  3035   "RTN","CH8 35F2",202, 0)
  3036    ;               EXCE PT THE INP ATIENT CLA IMS.
  3037   "RTN","CH8 35F2",203, 0)
  3038    ; THIS FU NCTION GEN ERATES THE  CAS RECOR D AMOUNTS  THAT WILL  BE OUTPUT  AS CLPCAS 
  3039   "RTN","CH8 35F2",204, 0)
  3040    ; RECORDS  FOR THE C LAIM. IF T HERE IS NO  CAS CREAT ED, NO OUT PUT WILL B E GENERATE D
  3041   "RTN","CH8 35F2",205, 0)
  3042    ; FOR THE  835.
  3043   "RTN","CH8 35F2",206, 0)
  3044    ; 6/6/13  THIS FUNCT ION RETURN S THE SUM  OF ALL "PR " ADJUSTME NTS 
  3045   "RTN","CH8 35F2",207, 0)
  3046    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  3047   "RTN","CH8 35F2",208, 0)
  3048    ; CLMLVL  ARRAY IS P OPULATED I N CH835FU1 .INT
  3049   "RTN","CH8 35F2",209, 0)
  3050    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  3051   "RTN","CH8 35F2",210, 0)
  3052    ; 
  3053   "RTN","CH8 35F2",211, 0)
  3054   CLPCAS(PAY I,CLPI,CAS ,CLMLVL,TO S,PTPAID,C HQTY,OAB6)  ; CAS seg ment for t he claim l evel
  3055   "RTN","CH8 35F2",212, 0)
  3056    ; PAYI          ^CHM PAY(I) IND EX
  3057   "RTN","CH8 35F2",213, 0)
  3058    ; CLPI          CLAI M LEVEL IN DEX TO CLP ,CLPCAS,SV C,SVCCAS R ECORDS
  3059   "RTN","CH8 35F2",214, 0)
  3060    ; CAS           DEST INATION AR RAY
  3061   "RTN","CH8 35F2",215, 0)
  3062    ; CLMLVL        SOUR CE ARRAY F OR THE CLA IM DATA
  3063   "RTN","CH8 35F2",216, 0)
  3064    ; TOS           TYPE  OF SERVIC E FOR THE  CURRENT CL AIM (IPT,O PT,RXT,DUR ,DNT,TRV)
  3065   "RTN","CH8 35F2",217, 0)
  3066    ; PTPAID        AMOU NT PATIENT  PAID UP F RONT ON CL AIM 
  3067   "RTN","CH8 35F2",218, 0)
  3068    ; CHQTY         QUAN TITY VALUE  TO BE OUT PUT AS PAR T OF THE C AS REPORT
  3069   "RTN","CH8 35F2",219, 0)
  3070    ; OAB6      Flag ind icating an d <1$ amou nt
  3071   "RTN","CH8 35F2",220, 0)
  3072    ;
  3073   "RTN","CH8 35F2",221, 0)
  3074    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F2: CLPCAS : PAYI ",P AYI," CLPI = ",CLPI,"   CLMRJAMT :",CLMLVL( "CLMRJAMT" ),"  SVC D EF:",$D(^T MP($J,"EDI _CREATE"," SVC")),"   OHIPD:",CL MLVL("OHIP D"),"  BIL LAMT:",CLM LVL("BILLA MT"),"  AL LOWED:",CL MLVL("TOTA LLOW")
  3075   "RTN","CH8 35F2",222, 0)
  3076    N CLMSTAT ,CASI,DICI ,DEF,GRP,R SN,HACPYMT ,DEDAMT,PA TRESP
  3077   "RTN","CH8 35F2",223, 0)
  3078    S (HACPYM T,PATRESP) =0
  3079   "RTN","CH8 35F2",224, 0)
  3080    I (PTPAID >0)!(TOS=" IPT")  D
  3081   "RTN","CH8 35F2",225, 0)
  3082    .S CLMSTA T=$P(^CHMP AY(PAYI,0) ,"^",2),CA SI=1                                                ;  CLAIM STAT US 0=REJEC T
  3083   "RTN","CH8 35F2",226, 0)
  3084    .S:$D(^CH MPAY(PAYI, 1)) HACPYM T=$P(^CHMP AY(PAYI,1) ,"^",1)                          ; CALCULAT ED HAC PAY MENT AMOUN T
  3085   "RTN","CH8 35F2",227, 0)
  3086    .S CO45AM T=CLMLVL(" BILLAMT")- CLMLVL("OH IPD")-HACP YMT-CLMLVL ("BENEPD") -CLMLVL("D EDAMT")-CL MLVL("CSHR AMT")
  3087   "RTN","CH8 35F2",228, 0)
  3088    .; ERA Co mpliance
  3089   "RTN","CH8 35F2",229, 0)
  3090    .I (+OAB6 )&(CLMSTAT >0)&($G(CL MLVL("VPYM T"))>0)&($ G(CLMLVL(" VPYMT"))<1 ) D  ;paid  amount le ss than $1 .00
  3091   "RTN","CH8 35F2",230, 0)
  3092    ..S CAS(C LPI,CASI," OA","209") =CLMLVL("V PYMT") ;^C HMXDIC(741 201.16,"B" ,"209",242 )="", ^CHM XDIC(74120 1.58,"B"," MA22",166) =""
  3093   "RTN","CH8 35F2",231, 0)
  3094    ..;I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"  F2: CLPCAS : WROTE CA S(",CLPI," ,",CASI,", ""0A"",""2 09"")=",CA S(CLPI,CAS I,"OA","20 9")
  3095   "RTN","CH8 35F2",232, 0)
  3096    .;
  3097   "RTN","CH8 35F2",233, 0)
  3098    .I (CLMST AT>0)&(CLM LVL("DEDAM T")>0)  D
  3099   "RTN","CH8 35F2",234, 0)
  3100    ..S CAS(C LPI,CASI," PR",1)=CLM LVL("DEDAM T")              ; AD JUSTMENT R ECORD FOR  DEDUCTIBLE   DLB 4/17 /13
  3101   "RTN","CH8 35F2",235, 0)
  3102    ..S PATRE SP=PATRESP +CLMLVL("D EDAMT")                     ; DL B 6/6/13 T ALLY THE P ATIENT RES PONSIBILIT Y $$
  3103   "RTN","CH8 35F2",236, 0)
  3104    ..;I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"   F2: CLPCA S: WROTE C AS(",CLPI, ",",CASI," ,""PR"",", 1,")= ",CA S(CLPI,CAS I,"PR",1)
  3105   "RTN","CH8 35F2",237, 0)
  3106    .I (CLMST AT>0)&(CLM LVL("CSHRA MT")>0)  D
  3107   "RTN","CH8 35F2",238, 0)
  3108    ..S CAS(C LPI,CASI," PR",2)=CLM LVL("CSHRA MT")    ;  ADJUSTMENT  RECORD FO R COST SHA RE  DLB 4/ 17/13
  3109   "RTN","CH8 35F2",239, 0)
  3110    ..S PATRE SP=PATRESP +CLMLVL("C SHRAMT")                    ; DL B 6/6/13 T ALLY THE P ATIENT RES PONSIBILIT Y $$
  3111   "RTN","CH8 35F2",240, 0)
  3112    ..;I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"    F2: CLPC AS: WROTE  CAS(",CLPI ,",",CASI, ",""PR""," ,2,")= ",C AS(CLPI,CA SI,"PR",2)
  3113   "RTN","CH8 35F2",241, 0)
  3114    .I (CLMST AT>0)&(CLM LVL("BPYMT ")>0)  D
  3115   "RTN","CH8 35F2",242, 0)
  3116    ..S CAS(C LPI,CASI," OA",100)=C LMLVL("BPY MT")    ;  ADJUSTMENT  RECORD FO R BENE PMT  AMT  DLB  5/24/13
  3117   "RTN","CH8 35F2",243, 0)
  3118    ..;I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"    F2: CLPC AS: WROTE  CAS(",CLPI ,",",CASI, ",""0A""," ,100,")=", CAS(CLPI,C ASI,"OA",1 00)
  3119   "RTN","CH8 35F2",244, 0)
  3120    .I CLMLVL ("OHIPD")' =0  D                                                    ; OA-23  IS GENERAT ED FOR BOT H REJECT A NDNON-REJE CT STATUS
  3121   "RTN","CH8 35F2",245, 0)
  3122    ..S CAS(C LPI,CASI," OA",23)=CL MLVL("OHIP D")              ; AD JUSTMENT R ECORD FOR  OHI PMT AM T  DLB 4/1 7/13
  3123   "RTN","CH8 35F2",246, 0)
  3124    ..;I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"F 2: CLPCAS:  WROTE CAS (",CLPI,", ",CASI,"," "OA"",",23 ,")= ",CAS (CLPI,CASI ,"OA",23)
  3125   "RTN","CH8 35F2",247, 0)
  3126    .I (CLMST AT>0)&(CO4 5AMT>0)&(C LMLVL("TOT ALLOW")>0)   D
  3127   "RTN","CH8 35F2",248, 0)
  3128    ..S CAS(C LPI,CASI," CO",45)=CO 45AMT                                ; ADJU STMENT REC ORD FOR CO NTRACTUAL  OBLIGATION  AMT  DLB  5/24/13
  3129   "RTN","CH8 35F2",249, 0)
  3130    ..;I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"    F2: WROT E CAS(",CL PI,",",CAS I,",""CO"" ,",45,")=  ",CAS(CLPI ,CASI,"CO" ,45)
  3131   "RTN","CH8 35F2",250, 0)
  3132    .I (CLMST AT=0)!((CL MLVL("BILL AMT")>0)&( +(HACPYMT) =0)&(CLMLV L("TOTALLO W")=0))  D  ; REJECTE D OR ZERO  PAY CLAIM
  3133   "RTN","CH8 35F2",251, 0)
  3134    ..;I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"    F2: CLPC AS: DENIAL  RJRSN= ", CLMLVL("CL MRJCD"),"    BILLAMT:  ",CLMLVL( "BILLAMT") ,"  HACPD:  ",HACPYMT ,"  ALLOWE D AMT: ",  CLMLVL("TO TALLOW"),"   REJAMT:  ",CLMLVL(" CLMRJAMT")
  3135   "RTN","CH8 35F2",252, 0)
  3136    ..Q:(CLML VL("CLMRJC D")=0)!(CL MLVL("CLMR JCD")="")                                                    ; WO N'T GENERA TE CAS WIT HOUT REJEC T REASON ( ZERO PAY;  NOT A REJE CT)
  3137   "RTN","CH8 35F2",253, 0)
  3138    ..S DICI= 0,DICI=$O( ^CHMXDIC(7 41201.77," B",CLMLVL( "CLMRJCD") ,DICI))               ; RETRIEVE  THE STATU S INDEX 
  3139   "RTN","CH8 35F2",254, 0)
  3140    ..S DEF=$ G(^CHMXDIC (741201.77 ,DICI,0))                                                                        ;U 0 W  !,"   F2:  DENIAL DE F= ",DEF
  3141   "RTN","CH8 35F2",255, 0)
  3142    ..S GRP=$ P($G(^CHMX DIC(741201 .15,$P(DEF ,"^",2),0) ),"^",1)                                 ;U  0 W !,"    F2: DENIA L GRP= ",G RP 
  3143   "RTN","CH8 35F2",256, 0)
  3144    ..S RSN=$ P($G(^CHMX DIC(741201 .16,$P(DEF ,"^",3),0) ),"^",1)                                 ;U  0 W !,"    F2: DENIA L RSN= ",R SN
  3145   "RTN","CH8 35F2",257, 0)
  3146    ..S CAS(C LPI,CASI,G RP,RSN)=CL MLVL("BILL AMT")-CLML VL("OHIPD" )                     ; 6/7/13 D LB AMT VAL UE PER BUS INESS BILL ED AMT-ALL  OHI PD
  3147   "RTN","CH8 35F2",258, 0)
  3148    ..I GRP=" PR" S PATR ESP=PATRES P+CLMLVL(" BILLAMT")- CLMLVL("OH IPD")                 ; DLB 6/6/ 13 TALLY T HE PATIENT  RESPONSIB ILITY $$
  3149   "RTN","CH8 35F2",259, 0)
  3150    ..;I $$EN VIR^CHTFLI B'="LIVE"  U 0 W !,"    F2: CLPC AS: WROTE  CAS(",CLPI ,",",CASI, ",",GRP,", ",RSN,")=  ",CAS(CLPI ,CASI,GRP, RSN)
  3151   "RTN","CH8 35F2",260, 0)
  3152    Q PATRESP
  3153   "RTN","CH8 35F2",261, 0)
  3154    ;
  3155   "RTN","CH8 35F2",262, 0)
  3156    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3157   "RTN","CH8 35F2",263, 0)
  3158    ; REJECT  CODE TO GR OUP/REASON  CODE CONV ERSION
  3159   "RTN","CH8 35F2",264, 0)
  3160    ; UTILITY  TO CONVER T THE REJE CT CODE TO  THE 835 G ROUP AND R EASON CODE S
  3161   "RTN","CH8 35F2",265, 0)
  3162    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3163   "RTN","CH8 35F2",266, 0)
  3164    ; THIS UT ILITY IS N OT USED IN  THE 835 G ENEERATION , SOLE PUR POSE IS TO
  3165   "RTN","CH8 35F2",267, 0)
  3166    ; HELP IN  DEBUG/TES T
  3167   "RTN","CH8 35F2",268, 0)
  3168    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3169   "RTN","CH8 35F2",269, 0)
  3170    ;
  3171   "RTN","CH8 35F2",270, 0)
  3172   CNVRJCD(RJ CD)
  3173   "RTN","CH8 35F2",271, 0)
  3174    ; RJCD          INTE RNAL HAC R EJECT CODE  VALUE
  3175   "RTN","CH8 35F2",272, 0)
  3176    N DICI,DE F,GRP,RSN, GRPDESC,RS NDESC
  3177   "RTN","CH8 35F2",273, 0)
  3178    S DICI=0, DICI=$O(^C HMXDIC(741 201.77,"B" ,RJCD,DICI ))             ; RETR IEVE THE S TATUS INDE
  3179   "RTN","CH8 35F2",274, 0)
  3180    S DEF=$G( ^CHMXDIC(7 41201.77,D ICI,0))                                       
  3181   "RTN","CH8 35F2",275, 0)
  3182    S GRP=$P( $G(^CHMXDI C(741201.1 5,$P(DEF," ^",2),0)), "^",1)         
  3183   "RTN","CH8 35F2",276, 0)
  3184    S GRPDESC =$P($G(^CH MXDIC(7412 01.15,$P(D EF,"^",2), 0)),"^",2)  
  3185   "RTN","CH8 35F2",277, 0)
  3186    S RSN=$P( $G(^CHMXDI C(741201.1 6,$P(DEF," ^",3),0)), "^",1)         
  3187   "RTN","CH8 35F2",278, 0)
  3188    S RSNDESC =$P($G(^CH MXDIC(7412 01.16,$P(D EF,"^",3), 0)),"^",2)  
  3189   "RTN","CH8 35F2",279, 0)
  3190    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !," RE JECT CODE  RECEIVED =  ",RJCD
  3191   "RTN","CH8 35F2",280, 0)
  3192    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !," IN DEX FROM ^ CHMXDIC(74 1201.77,", ",""B"",", RJCD,")= " ,DICI
  3193   "RTN","CH8 35F2",281, 0)
  3194    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !," GR OUP/REASON  INDEXES:  (^CHMXDIC( 741201.77, ",DICI,",0 ))= ",DEF
  3195   "RTN","CH8 35F2",282, 0)
  3196    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !," GR OUP (^CHMX DIC(741201 .15,",$P(D EF,"^",2), ",0))= ",G RP,": ",GR PDESC
  3197   "RTN","CH8 35F2",283, 0)
  3198    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !," RE ASON (^CHM XDIC(74120 1.16,",$P( DEF,"^",3) ,",0))= ", RSN,": ",R SNDESC
  3199   "RTN","CH8 35F2",284, 0)
  3200    Q
  3201   "RTN","CH8 35F2",285, 0)
  3202    ;
  3203   "RTN","CH8 35F2",286, 0)
  3204    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  3205   "RTN","CH8 35F2",287, 0)
  3206    ; CLPNAME  IS A PHAR MACY RECOR D ONLY
  3207   "RTN","CH8 35F2",288, 0)
  3208    ; ORIGINA L RECORD G ENERATION  CODE
  3209   "RTN","CH8 35F2",289, 0)
  3210    ; S ^TMP( $J,"EDI_CR EATE","CLP NAME",0)=" CLPNAME"_" ^"_NFILE_" ^"_STSEQ_" ^"_"PHARM  CLAIM"_"^" _LNM_"^"_F NM_"^"_SSN
  3211   "RTN","CH8 35F2",290, 0)
  3212    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  3213   "RTN","CH8 35F2",291, 0)
  3214    ;
  3215   "RTN","CH8 35F2",292, 0)
  3216   CLPNAME(NF ILE,STSEQ, RXI,RXJ,RX K,CLPI)
  3217   "RTN","CH8 35F2",293, 0)
  3218    ;HR-PBM-P HASE 1B-Be gin
  3219   "RTN","CH8 35F2",294, 0)
  3220    N DATA,LN M,FNM,SSN, NAM
  3221   "RTN","CH8 35F2",295, 0)
  3222    S DATA=$G (^CHMXRX(R XI,100,RXJ ,100,RXK,0 ))
  3223   "RTN","CH8 35F2",296, 0)
  3224    S NAM=$P( DATA,"^",5 ),LNM=$P(N AM,",",1), FNM=$P(NAM ,",",2),SS N=$P(DATA, "^",4)
  3225   "RTN","CH8 35F2",297, 0)
  3226    ;HR-PBM-P HASE 1B-En d
  3227   "RTN","CH8 35F2",298, 0)
  3228    S REC=""
  3229   "RTN","CH8 35F2",299, 0)
  3230    F LN=1:1  S STR=$T(C LPNAM+LN)  Q:STR["END  OF RECORD "  D           ; TABL E GENERATE D RECORD
  3231   "RTN","CH8 35F2",300, 0)
  3232    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)            
  3233   "RTN","CH8 35F2",301, 0)
  3234    .E  S REC =REC_"^"_$ $FORMATDAT A^CHMXWBUT (STR)
  3235   "RTN","CH8 35F2",302, 0)
  3236    S ^TMP($J ,"EDI_CREA TE","CLPNA ME",CLPI)= REC
  3237   "RTN","CH8 35F2",303, 0)
  3238    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    F2: CLPMNA ME: WROTE  ^TMP($J,"" EDI_CREATE "",""CLPNA ME"",",CLP I,")= ",^T MP($J,"EDI _CREATE"," CLPNAME",C LPI)
  3239   "RTN","CH8 35F2",304, 0)
  3240    Q
  3241   "RTN","CH8 35F2",305, 0)
  3242    ;
  3243   "RTN","CH8 35F2",306, 0)
  3244    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  3245   "RTN","CH8 35F2",307, 0)
  3246    ; THESE F UNCTIONS R EPLACED BY  THE CLPCA S() CODE A BOVE 4/4/2 013  DLB
  3247   "RTN","CH8 35F2",308, 0)
  3248    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  3249   "RTN","CH8 35F2",309, 0)
  3250    .;D CLPCA SOH(PAYI,T MPI,.CAS,. CLMLVL,TOS ,CHQTY)                                     ; OHI PAYM ENTS
  3251   "RTN","CH8 35F2",310, 0)
  3252    .;D CLPCA SCO(PAYI,T MPI,.CAS,. CLMLVL,TOS ,CHQTY)                            ; CONTRA CTUAL OBLI GATIONS        
  3253   "RTN","CH8 35F2",311, 0)
  3254    .;D CLPCA SPR(PAYI,T MPI,.CAS,. CLMLVL,TOS ,PTPAID,CH QTY)           ; RECO RD "PR", " OA" ADJUST MENTS
  3255   "RTN","CH8 35F2",312, 0)
  3256    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  3257   "RTN","CH8 35F2",313, 0)
  3258    ;
  3259   "RTN","CH8 35F2",314, 0)
  3260     ;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  3261   "RTN","CH8 35F2",315, 0)
  3262    ; PATIENT  RESPONSIB ILITY DETE RMINATION
  3263   "RTN","CH8 35F2",316, 0)
  3264    ; CLMLVL( "DEDAMT")                                                           ; $P(^CH MPAY(I,1), "^",5)
  3265   "RTN","CH8 35F2",317, 0)
  3266    ; CLMLVL( "CSHRAMT")                                                 ; $P(^ CHMPAY(I,1 ),"^",6)
  3267   "RTN","CH8 35F2",318, 0)
  3268    ; CLMLVL( "BENEPD")                                                           ; $P(^CH MPAY(I,1), "^",15)
  3269   "RTN","CH8 35F2",319, 0)
  3270    ; CLMLVL( "TOTALLOW" )                                               ; $P(^ CHMPAY(I," COMMON")," ^",7)
  3271   "RTN","CH8 35F2",320, 0)
  3272    ; CLMLVL( "BILLAMT")                                                 ; $P(^ CHMPAY(I," COMMON")," ^",1
  3273   "RTN","CH8 35F2",321, 0)
  3274    ; CLMLVL( "VPYMT")                                                            ; $P(^CH MPAY(I,1), "^",14)
  3275   "RTN","CH8 35F2",322, 0)
  3276    ; CLMLVL( "TOS")                                                              ; $$TOS^ CH835FU1($ P(^CHMPAY( I,0),"^",7 )
  3277   "RTN","CH8 35F2",323, 0)
  3278    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  3279   "RTN","CH8 35F2",324, 0)
  3280    ;
  3281   "RTN","CH8 35F2",325, 0)
  3282   CLPCASPR ; Claim ajus tments for  Patient R esponsibil ity
  3283   "RTN","CH8 35F2",326, 0)
  3284    N DED,COS TSHR,BENEP YMT
  3285   "RTN","CH8 35F2",327, 0)
  3286    S DED=CLM LVL("DEDAM T")                                                      ; $P(^CH MPAY(I,1), "^",5)
  3287   "RTN","CH8 35F2",328, 0)
  3288    S COSTSHR =CLMLVL("C SHRAMT")                                        ; $P(^ CHMPAY(I,1 ),"^",6)
  3289   "RTN","CH8 35F2",329, 0)
  3290    S BENEPYM T=CLMLVL(" BENEPD")                                        ; $P(^ CHMPAY(I,1 ),"^",15)
  3291   "RTN","CH8 35F2",330, 0)
  3292    I CLMLVL( "TOS")="IP T"  D 
  3293   "RTN","CH8 35F2",331, 0)
  3294    .I CLMLVL ("TOTALLOW ")>CLMLVL( "BILLAMT")  D
  3295   "RTN","CH8 35F2",332, 0)
  3296    ..S CAS(C LPI,0,"OA" ,68)=(CLML VL("BILLAM T")-CLMLVL ("VPYMT"))
  3297   "RTN","CH8 35F2",333, 0)
  3298    I CLMLVL( "DEDAMT")> 0 S CAS(CL PI,0,"PR", 1)=CLMLVL( "DEDAMT")
  3299   "RTN","CH8 35F2",334, 0)
  3300    I CLMLVL( "CSHRAMT") >0 S CAS(C LPI,0,"PR" ,3)=CLMLVL ("CSHRAMT" )
  3301   "RTN","CH8 35F2",335, 0)
  3302    I CLMLVL( "BENEPD")> 0 S CAS(CL PI,0,"OA", 100)=CLMLV L("BENEPD" )
  3303   "RTN","CH8 35F2",336, 0)
  3304    Q
  3305   "RTN","CH8 35F2",337, 0)
  3306    ;
  3307   "RTN","CH8 35F2",338, 0)
  3308    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3309   "RTN","CH8 35F2",339, 0)
  3310    ; CLPCASO H  OHI ADJ USTMENT
  3311   "RTN","CH8 35F2",340, 0)
  3312    ; THE ADJ USTMENTS T HAT CAN BE  REPORTED  WHEN OHI P AYMENT OCC URS ARE
  3313   "RTN","CH8 35F2",341, 0)
  3314    ; OHI PAY MENT AND B ENE PAYMEN T
  3315   "RTN","CH8 35F2",342, 0)
  3316    ; 1) IF N O OHI PAYM ENT, NOTHI NG TO ADJU ST
  3317   "RTN","CH8 35F2",343, 0)
  3318    ; 2) CLPC AS ONLY GE NERATED FO R INPATIEN T CLAIMS
  3319   "RTN","CH8 35F2",344, 0)
  3320    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3321   "RTN","CH8 35F2",345, 0)
  3322    ;
  3323   "RTN","CH8 35F2",346, 0)
  3324   CLPCASOH(P AYI,TMPI,C AS,CLMLVL, TOS,CHQTY)  ; OHI adj ustment
  3325   "RTN","CH8 35F2",347, 0)
  3326    ; ^CHMPAY (I) INDEX
  3327   "RTN","CH8 35F2",348, 0)
  3328    ; TMPI          INDE X VALUE FO R CAS ARRA Y
  3329   "RTN","CH8 35F2",349, 0)
  3330    ; CAS           TARG ET DESTINA TION ARRAY
  3331   "RTN","CH8 35F2",350, 0)
  3332    ; CLMLVL        CLAI M DATA SOU RCE ARRAY  FROM CH835 FU2.INT
  3333   "RTN","CH8 35F2",351, 0)
  3334    ; TOS           TYPE  OF SERVIC E
  3335   "RTN","CH8 35F2",352, 0)
  3336    ; CHQTY         QUAN TITY VALUE  FOR THE C AS SEGMENT S
  3337   "RTN","CH8 35F2",353, 0)
  3338    ; 
  3339   "RTN","CH8 35F2",354, 0)
  3340    N TMPBILL ED,TMPOHI, TMPALLOW,T MPCOSTS,SV CFLAG,CLMI ,CLMSTAT
  3341   "RTN","CH8 35F2",355, 0)
  3342    S CLMI=0
  3343   "RTN","CH8 35F2",356, 0)
  3344    S TMPBILL ED=CLMLVL( "BILLAMT")                             ; ^C HMPAY(I,"C OMMON"),"^ ",1)  AMOU NT TO BE P AID ON CLA IM
  3345   "RTN","CH8 35F2",357, 0)
  3346    S TMPOHI= CLMLVL("OH IPD")                                           ; ^CHM PAY(I,1)), "^",7)         AMOUNT  PAID BY O THER INSUR ANCE
  3347   "RTN","CH8 35F2",358, 0)
  3348    S TMPALLO W=CLMLVL(" TOTALLOW")                             ; ^C HMPAY(I,"C OMMON"),"^ ",7   CALC  ALLOWABLE  AMONUT HI ST
  3349   "RTN","CH8 35F2",359, 0)
  3350    S TMPCOST S=CLMLVL(" CSHRAMT")                              ; ^C HMPAY(I,1) ,"^",6)               COST SHARE  AMOUNT
  3351   "RTN","CH8 35F2",360, 0)
  3352    ;add pr p ayment met hod here
  3353   "RTN","CH8 35F2",361, 0)
  3354    ;
  3355   "RTN","CH8 35F2",362, 0)
  3356    Q:TOS'="I PT"   
  3357   "RTN","CH8 35F2",363, 0)
  3358    I (CLMLVL ("BILLAMT" )-CLMLVL(" OHIPD"))=C LMLVL("VPY MT") D  Q      ; IF B ILLED AMT- OHIPD=AMOU NT PAID BY  VENDOR RE PORT "OA", 23
  3359   "RTN","CH8 35F2",364, 0)
  3360    .S CAS(TM PI,CLMI,"O A",23)=CLM LVL("OHIPD ")_"^"_CHQ TY,CLMI=CL MI+1
  3361   "RTN","CH8 35F2",365, 0)
  3362    I (CLMLVL ("BILLAMT" )-CLMLVL(" OHIPD"))>( CLMLVL("TO TALLOW")-C LMLVL("CSH RAMT")) D   Q      ;  IF BILLED  AMT-OHIPD  > TOTAL AL LOWED-COST  SHARE AMT
  3363   "RTN","CH8 35F2",366, 0)
  3364    .S CAS(TM PI,CLMI,"O A",23)=CLM LVL("CSHRA MT")_"^"_C HQTY,CLMI= CLMI+1
  3365   "RTN","CH8 35F2",367, 0)
  3366    I CLMLVL( "BPYMT")>0  D  Q                                                                                       ; IF P YMT TO BEN E >0  
  3367   "RTN","CH8 35F2",368, 0)
  3368    .S CAS(TM PI,CLMI,"O A",100)=CL MLVL("BPYM T")_"^"_CH QTY,CLMI=C LMI+1
  3369   "RTN","CH8 35F2",369, 0)
  3370    I CLMLVL( "STATUS")' =0 D                                                                                                 ; OHI ad justment ; MTN015459  6/29/12 BM J CHANGED  "PI" TO "O A"
  3371   "RTN","CH8 35F2",370, 0)
  3372    .S CAS(TM PI,CLMI,"O A",23)=CLM LVL("OHIPD ")_"^"_CHQ TY,CLMI=CL MI+1
  3373   "RTN","CH8 35F2",371, 0)
  3374    Q 
  3375   "RTN","CH8 35F2",372, 0)
  3376    ;
  3377   "RTN","CH8 35F2",373, 0)
  3378    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  3379   "RTN","CH8 35F2",374, 0)
  3380    ; CLPCASR :   THIS R OUTINE IS  NOT USED
  3381   "RTN","CH8 35F2",375, 0)
  3382    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  3383   "RTN","CH8 35F2",376, 0)
  3384    ;
  3385   "RTN","CH8 35F2",377, 0)
  3386   CLPCASR(TM PI,CLMLVL, QTY) ; Cla im level R ejects
  3387   "RTN","CH8 35F2",378, 0)
  3388    ; TMPI          INDE X VALUE FO
  3389   "RTN","CH8 35F2",379, 0)
  3390    N REJCD,A MT                                                         ; REJI =$S(^CHMPA Y(I,0),"^" ,2)=0:$P(^ CHMPAY(I,0 ),"^",13), 1:"")   RE JECT REASO N CODE IND EX        
  3391   "RTN","CH8 35F2",380, 0)
  3392    S REJCD=C LMLVL("CLM RJCD")                                 ; CL MRJCD=$$RE JCD^CH835F U1(REJI)                           
  3393   "RTN","CH8 35F2",381, 0)
  3394    S AMT=CLM LVL("CLMRJ AMT")                                  ; I  CLMRJCD]""  S CLMRJAM T=BILLAMT
  3395   "RTN","CH8 35F2",382, 0)
  3396    ;U 0 W !, "   F2: CL PCASR: REJ CD=",REJCD ,"  REJ AM T=",AMT
  3397   "RTN","CH8 35F2",383, 0)
  3398    D REJ^CH8 35FU1(TMPI ,0,REJCD,A MT,QTY)    ; SET UP C AS SEGMENT S FOR THE  CLAIM
  3399   "RTN","CH8 35F2",384, 0)
  3400    Q
  3401   "RTN","CH8 35F2",385, 0)
  3402    ;
  3403   "RTN","CH8 35F2",386, 0)
  3404    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3405   "RTN","CH8 35F2",387, 0)
  3406    ; this ad justs for  DRG paymen ts since a mt billed  is not use d in
  3407   "RTN","CH8 35F2",388, 0)
  3408    ; payment  calculati on.
  3409   "RTN","CH8 35F2",389, 0)
  3410    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  3411   "RTN","CH8 35F2",390, 0)
  3412    ;
  3413   "RTN","CH8 35F2",391, 0)
  3414   CLPCASCO(T MPI,CAS,CL MLVL,TOS,C HQTY)                                         ; DRG ad justment
  3415   "RTN","CH8 35F2",392, 0)
  3416    ; TMPI          INDE X FOR THE  DESTINATIO N ARRAY
  3417   "RTN","CH8 35F2",393, 0)
  3418    ; CAS           TARG ET DESTINA TION ARRAY
  3419   "RTN","CH8 35F2",394, 0)
  3420    ; CLMLVL        SOUR CE ARRAY C ONTAINING  THE CLAIM  DATA
  3421   "RTN","CH8 35F2",395, 0)
  3422    ; TOS           TYPE  OF SERVIC E FOR THE  CURRENT CL AIM (IPT,O PT,RXT,DUR ,DNT,TRV)
  3423   "RTN","CH8 35F2",396, 0)
  3424    ; CHQTY         QTY  VALUE FOR  THE CAS SE GMENT(S)
  3425   "RTN","CH8 35F2",397, 0)
  3426    ;
  3427   "RTN","CH8 35F2",398, 0)
  3428    N PAYI,CL MRJCD,DICI ,DEF,CASGR P,CASRSN,C ASDESC,CO4 5AMT
  3429   "RTN","CH8 35F2",399, 0)
  3430    Q:TOS'="I PT"                                                                                                    ; NO C LPCAS FOR  RXT,DME,OP T,TRV
  3431   "RTN","CH8 35F2",400, 0)
  3432    S CO45AMT =CLMLVL("B ILLAMT")-C LMLVL("OHI PD")-CLMLV L("VPYMT") -CLMLVL("B PYMT")-CLM LVL("TOTAL LOW")
  3433   "RTN","CH8 35F2",401, 0)
  3434    ;/// STAR T CHGS FOR  CAS GROUP /REASON CO DE - RKN 1 1/01/2006  - TTRK # D EV000055-0 1: Fix 835  Qualifier  (Formerly  MC130)  / //
  3435   "RTN","CH8 35F2",402, 0)
  3436    ;K XPIVA, XHDRCD,XHI VAL,XCASGR P,XCASREA, XCIVAL,XCA SDESC,XRIV AL,TMPPT ; AEB 1/12/2 010 DEV004 225 
  3437   "RTN","CH8 35F2",403, 0)
  3438    S CASGRP= "CO",CASRS N="45"                ;set defau lt CAS gro up and rea son code     ;DEV0139 62-01 1/24 /11 JEH CH G 42 TO 45
  3439   "RTN","CH8 35F2",404, 0)
  3440    S PAYI=0, PAYI=$O(^C HMPAY("B", CLMLVL("CL M"),PAYI))                                  ; RETRIEVE  THE ^CHMP AY(I) INDE X
  3441   "RTN","CH8 35F2",405, 0)
  3442    S CLMRJCD =CLMLVL("C LMRJCD")                                                                           ; CL M LVL REJE CT REASON  CODE
  3443   "RTN","CH8 35F2",406, 0)
  3444    I (CLMRJC D'="")&($D (^CHMDIC(7 41002.22," B",CLMRJCD )))  D                  ; REJ CO DE=NULL US E DEFAULT  GRP,RSN=CO 45
  3445   "RTN","CH8 35F2",407, 0)
  3446    .S DICI=0 ,DICI=$O(^ CHMXDIC(74 1201.77,"B ",CLMRJCD, DICI))                  ; RETRIE VE THE DIC TIONARY IN DEX
  3447   "RTN","CH8 35F2",408, 0)
  3448    .S DEF=$G (^CHMXDIC( 741201.77, DICI,0))                                                       ;  STRING CON TAINS THE  GROUP&REAS ON INDEXES
  3449   "RTN","CH8 35F2",409, 0)
  3450    .Q:$P(DEF ,"^",3)=1                                                                                              ; HAC  REASON INA CTIVE, USE  DEFAULTS
  3451   "RTN","CH8 35F2",410, 0)
  3452    .S:$P(DEF ,"^",2)'=" " CASGRP=$ P(^CHMXDIC (741201.15 ,$P(DEF,"^ ",2),0),"^ ",1)       ; GROUP CO DE
  3453   "RTN","CH8 35F2",411, 0)
  3454    .S:$P(DEF ,"^",2)'=" " CASDESC= $P(^CHMXDI C(741201.1 6,$P(DEF," ^",2),0)," ^",2) ; GR OUP DESCRI PTION 
  3455   "RTN","CH8 35F2",412, 0)
  3456    .S:$P(DEF ,"^",3)=""  CASRSN=$P (^CHMXDIC( 741201.16, $P(DEF,"^" ,3),0),"^" ,1)        ; REASON C ODE
  3457   "RTN","CH8 35F2",413, 0)
  3458    .S CO45AM T=CLMLVL(" BILLAMT")                                                                          ; RE JECT: AMT= BILLED AMT
  3459   "RTN","CH8 35F2",414, 0)
  3460   WCAS 
  3461   "RTN","CH8 35F2",415, 0)
  3462    S CAS(TMP I,0,CASGRP ,CASRSN)=C O45AMT_"^" _CHQTY   ;  ^CHMPAY(I ,"COMMON") ,"^",1)(TO TAL CHARGE S BILLED)  - CHMPAY(I ,"COMMON") ,"^",7) (C ALC ALLOWA BLE AMT)
  3463   "RTN","CH8 35F2",416, 0)
  3464    ;I $$ENVI R^CHTFLIB' ="LIVE" U  0 W !,"    ***F2:CLPC ASO: CAS(" ,TMPI,",0, ",CASGRP," ,",CASRSN, ")= ",CAS( TMPI,0,CAS GRP,CASRSN )
  3465   "RTN","CH8 35F2",417, 0)
  3466    ;S CAS(TM PI,0,"CO", 42)=$P(CLM LVL(2),"^" ,1)-$P(CLM LVL(2),"^" ,2) ; DRG  adjust             ;o ld code re marked out  RKN 11/01 /2006
  3467   "RTN","CH8 35F2",418, 0)
  3468    ;/// END  CHGS FOR C AS GROUP/R EASON CODE  - RKN 11/ 01/2006 -  TTRK # DEV 000055-01:  Fix 835 Q ualifier ( Formerly M C130)  ///
  3469   "RTN","CH8 35F2",419, 0)
  3470    Q
  3471   "RTN","CH8 35F2",420, 0)
  3472    ;
  3473   "RTN","CH8 35F2",421, 0)
  3474    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  3475   "RTN","CH8 35F2",422, 0)
  3476    ; 1) RETR IEVE BENE  DEDUCTIBLE , BENE COS T SHARE,BE NE PAYMENT  FROM ^CHM PAY(I,1)
  3477   "RTN","CH8 35F2",423, 0)
  3478    ; 2) IF T OS=INPATIE NT AND TOT AL ALLOWED  AMOUNT >  CLAIM CHAR GE AMOUNT
  3479   "RTN","CH8 35F2",424, 0)
  3480    ;               SET  CAS(TMPI,0 ,"OA",68)=  CLAIM CHA RGE AMOUNT  - VENDOR  PAYMENT
  3481   "RTN","CH8 35F2",425, 0)
  3482    ; 3) IF B ENE DEDUCT IBLE > 0  
  3483   "RTN","CH8 35F2",426, 0)
  3484    ;               SET  CAS(TMPI,0 ,"PR",1) =  BENE DEDU CTIBLE
  3485   "RTN","CH8 35F2",427, 0)
  3486    ; 4) IF B ENE COST S HARE > 0
  3487   "RTN","CH8 35F2",428, 0)
  3488    ;               SET  CAS(TMPI,0 ,"PR",3) =  BENE COST  SHARE
  3489   "RTN","CH8 35F2",429, 0)
  3490    ; 5) IF B ENE PAYMEN T >0
  3491   "RTN","CH8 35F2",430, 0)
  3492    ;               SET  CAS(TMPI,0 ,"OA",100) = BENE PAY MENT
  3493   "RTN","CH8 35F2",431, 0)
  3494    ; 
  3495   "RTN","CH8 35F2",432, 0)
  3496    ; $P(^CHM PAY(CI,0), "^",5)="IP T"         ^05   ASSI GNMENT OF  BENEFITS S ET 1/0
  3497   "RTN","CH8 35F2",433, 0)
  3498    ; $P(^CHM PAY(CI,"CO MMON"),"^" ,1)        ^01   TOTA L CHARGES  BILLED HIS T
  3499   "RTN","CH8 35F2",434, 0)
  3500    ; $P(^CHM PAY(CI,"CO MMON"),"^" ,7)   ^07    CALC ALL OWABLE AMO NUT HIST
  3501   "RTN","CH8 35F2",435, 0)
  3502    ; $P(^CHM PAY(CI,1), "^",14)                       ^1 4   AMT PA ID TO VEND OR 
  3503   "RTN","CH8 35F2",436, 0)
  3504    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  3505   "RTN","CH8 35F2",437, 0)
  3506    ;
  3507   "RTN","CH8 35F2",438, 0)
  3508   CLPCASPR1( TMPI,CAS,C LMLVL,TOS, PTPAID,CHQ TY) ;Claim  ajustment s for Pati ent Respon sibility
  3509   "RTN","CH8 35F2",439, 0)
  3510    ; TMPI          INDE X FOR THE  CAS DESTIN ATION ARRA Y
  3511   "RTN","CH8 35F2",440, 0)
  3512    ; CAS           TARG ET DESTINA TION ARRAY
  3513   "RTN","CH8 35F2",441, 0)
  3514    ; CLMLVL        SOUR CE ARRAY F OR CLAIM D ATA
  3515   "RTN","CH8 35F2",442, 0)
  3516    ; TOS           TYPE  OF SERVIC E FOR THE  CURRENT CL AIM (IPT,O PT,RXT,DUR ,DNT,TRV)
  3517   "RTN","CH8 35F2",443, 0)
  3518    ; CHQTY         QTY  VALUE FOR  THE CAS SE GMENT(S)
  3519   "RTN","CH8 35F2",444, 0)
  3520    ;
  3521   "RTN","CH8 35F2",445, 0)
  3522    ;U 0 W !, "   F2: CL PCASPR: BI LLAMT:",CL MLVL("BILL AMT"),"  T OTALLOW:", CLMLVL("TO TALLOW"),"   VPYMNT:" ,CLMLVL("V PYMT")
  3523   "RTN","CH8 35F2",446, 0)
  3524    ;U 0 W !, "   F2: CL PCASPR: DE DAMT:",CLM LVL("DEDAM T"),"  COS T SHARE:", CLMLVL("CS HRAMT"),"   BENE PYMT :",CLMLVL( "BPYMT")
  3525   "RTN","CH8 35F2",447, 0)
  3526    I (CLMLVL ("TOS")="I PT")&(CLML VL("TOTALL OW")>CLMLV L("BILLAMT ")) D  Q     ; ^CHMPA Y(I,"COMMO N")),"^",7 )   CALC A LLOWABLE A MT
  3527   "RTN","CH8 35F2",448, 0)
  3528    .S CAS(TM PI,0,"OA", 68)=CLMLVL ("BILLAMT" )-CLMLVL(" VPYMT")_"^ "_CHQTY               ; ^CHMPAY( I,1),"^",1 4)  AMT PA ID TO VEND OR
  3529   "RTN","CH8 35F2",449, 0)
  3530    ;I CLMLVL ("DEDAMT") >0 S CAS(T MPI,0,"PR" ,1)=CLMLVL ("DEDAMT") _"^"_CHQTY   ; ^CHMPA Y(I,1),"^" ,5)   AMT  APPLIED TO  DEDUCTIBL E
  3531   "RTN","CH8 35F2",450, 0)
  3532    ;I CLMLVL ("CSHRAMT" )>0 S CAS( TMPI,0,"PR ",3)=CLMLV L("CSHRAMT ")_"^"_CHQ TY         ; ^CHMPAY( I,1),"^",6 )   COST S HARE AMOUN T
  3533   "RTN","CH8 35F2",451, 0)
  3534    ;I CLMLVL ("BPYMT")> 0 S CAS(TM PI,0,"OA", 100)=CLMLV L("BPYMT") _"^"_CHQTY   ; ^CHMPA Y(I,1),"^" ,15)  AMT  PAID TO BE NE
  3535   "RTN","CH8 35F2",452, 0)
  3536    ;I CLMLVL ("BENEPD") >0 S CAS(T MPI,0,"OA" ,23)=CLMLV L("BENEPD" )_"^"_CHQT Y ; BENE P AID AMOUNT  ADJUSTMEN T  Q
  3537   "RTN","CH8 35F2",453, 0)
  3538    I PTPAID> 0 S CAS(TM PI,0,"OA", 23)=PTPAID _"^"_CHQTY
  3539   "RTN","CH8 35F2",454, 0)
  3540    Q
  3541   "RTN","CH8 35F2",455, 0)
  3542    ;
  3543   "RTN","CH8 35F2",456, 0)
  3544   PTPRCAS(I)  ;PATIENT  RESPONSIBI LITY AT CL AIM LEVEL   
  3545   "RTN","CH8 35F2",457, 0)
  3546    N X
  3547   "RTN","CH8 35F2",458, 0)
  3548    S TI="",X =0
  3549   "RTN","CH8 35F2",459, 0)
  3550   PRTCAS1 S  TI=$O(CAS( TI)) G:TI= "" PTPRED
  3551   "RTN","CH8 35F2",460, 0)
  3552    G:'$D(CAS (TI,0,"PR" )) PRTCAS1
  3553   "RTN","CH8 35F2",461, 0)
  3554    S TRE=0
  3555   "RTN","CH8 35F2",462, 0)
  3556   PRTCAS2 S  TRE=$O(CAS (TI,0,"PR" ,TRE)) G:' TRE PRTCAS 1
  3557   "RTN","CH8 35F2",463, 0)
  3558    S X=X+CAS (TI,0,"PR" ,TRE)
  3559   "RTN","CH8 35F2",464, 0)
  3560    G PRTCAS2
  3561   "RTN","CH8 35F2",465, 0)
  3562   PTPRED D S VCAS
  3563   "RTN","CH8 35F2",466, 0)
  3564    Q X
  3565   "RTN","CH8 35F2",467, 0)
  3566   SVCAS ;ADD  IN SERVIC E LINE CAS  TO PATIEN T RESPONSI BILITY
  3567   "RTN","CH8 35F2",468, 0)
  3568    S STI=0
  3569   "RTN","CH8 35F2",469, 0)
  3570   SVC1 S STI =$O(CAS(ST I)) Q:'STI
  3571   "RTN","CH8 35F2",470, 0)
  3572    S STJ=0
  3573   "RTN","CH8 35F2",471, 0)
  3574   SVC2 S STJ =$O(CAS(ST I,STJ)) G: 'STJ SVC1
  3575   "RTN","CH8 35F2",472, 0)
  3576    S STK=0
  3577   "RTN","CH8 35F2",473, 0)
  3578   SVC3 S STK =$O(CAS(ST I,STJ,STK) ) G:'STK S VC2
  3579   "RTN","CH8 35F2",474, 0)
  3580    G:'$D(CAS (STI,STJ,S TK,"PR"))  SVC3
  3581   "RTN","CH8 35F2",475, 0)
  3582    S TRE=0
  3583   "RTN","CH8 35F2",476, 0)
  3584   SVC4 S TRE =$O(CAS(ST I,STJ,STK, "PR",TRE))  G:'TRE SV C3
  3585   "RTN","CH8 35F2",477, 0)
  3586    S X=X+CAS (STI,STJ,S TK,"PR",TR E)
  3587   "RTN","CH8 35F2",478, 0)
  3588    G SVC4
  3589   "RTN","CH8 35F2",479, 0)
  3590    ;HR-PBM-P HASE 1B-En d
  3591   "RTN","CH8 35F2",480, 0)
  3592    ;
  3593   "RTN","CH8 35F2",481, 0)
  3594    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  3595   "RTN","CH8 35F2",482, 0)
  3596    ; END OF  REPLACED C ODE
  3597   "RTN","CH8 35F2",483, 0)
  3598    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  3599   "RTN","CH8 35F2",484, 0)
  3600    ; START O F TABLES F OR RECORD  GENERATION
  3601   "RTN","CH8 35F2",485, 0)
  3602    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  3603   "RTN","CH8 35F2",486, 0)
  3604    ;
  3605   "RTN","CH8 35F2",487, 0)
  3606    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  3607   "RTN","CH8 35F2",488, 0)
  3608    ; CLPTBL  DEFINES TH E "CLP" RE CORD GENER ATION, REP LACES THE  FOLLOWING  LINES OF C ODE:
  3609   "RTN","CH8 35F2",489, 0)
  3610    ; .S ^TMP ($J,"EDI_C REATE","CL P",TMPI)=N FILE_"^"
  3611   "RTN","CH8 35F2",490, 0)
  3612    ;      _S TSEQ_"^"
  3613   "RTN","CH8 35F2",491, 0)
  3614    ;      _C LMID_"^"
  3615   "RTN","CH8 35F2",492, 0)
  3616    ;      _A UTH_"^"
  3617   "RTN","CH8 35F2",493, 0)
  3618    ;      _G RPCTL_"^"
  3619   "RTN","CH8 35F2",494, 0)
  3620    ;      _T XNCTL_"^"
  3621   "RTN","CH8 35F2",495, 0)
  3622    ;      _F ILEAUTH_"^ "
  3623   "RTN","CH8 35F2",496, 0)
  3624    ;      _P TCTL_"^"
  3625   "RTN","CH8 35F2",497, 0)
  3626    ;      _$ P(CLMLVL(2 ),"^",1)_" ^"                                   CLAIM  CHARGE AMO UNT     ^C HMPAY(CI," COMMON")
  3627   "RTN","CH8 35F2",498, 0)
  3628    ;      _$ P(CLMLVL(2 ),"^",3)_" ^"                                   TOTAL  ALLOWED AM OUNT    ^C HMPAY(CI," COMMON")
  3629   "RTN","CH8 35F2",499, 0)
  3630    ;      $$ PTPRCAS^CH 835F2($P(C LMLVL(2)," ^",1))  CL AIM CHARGE  AMOUNT               ^CHMPAY(CI ,"COMMON")
  3631   "RTN","CH8 35F2",500, 0)
  3632    ;  _$P(CL MLVL(1),"^ ",1)_"^"                               CLAI M NUMBER                      ^C HMPAY(CI,0 )
  3633   "RTN","CH8 35F2",501, 0)
  3634    ;      _$ P(CLMLVL(1 ),"^",6)_" ^"                                   DRUG C ODE                                  ^CHMPA Y(CI,0)
  3635   "RTN","CH8 35F2",502, 0)
  3636    ;      _$ P(CLMLVL(1 ),"^",7)_" ^"                                   DRUG W EIGHT                                $$DRGW T(DRGCD,DO S)
  3637   "RTN","CH8 35F2",503, 0)
  3638    ;      _$ $DTOUT^CH8 35FU1($P(C LMLVL(1)," ^",3))_"^"   CREATE D ATE                   ^CHMPAY(CI ,0)
  3639   "RTN","CH8 35F2",504, 0)
  3640    ;      _" NEW"_"^"
  3641   "RTN","CH8 35F2",505, 0)
  3642    ;      _" 1"
  3643   "RTN","CH8 35F2",506, 0)
  3644    ; ORIGINA L RECORD G ENERATION  CODE:
  3645   "RTN","CH8 35F2",507, 0)
  3646    ;S ^TMP($ J,"EDI_CRE ATE","CLP" ,TMPI)="," CLP"_"^"_N FILE_"^"_S TSEQ_"^"_C LMID_"^"_A UTH_"^"_GR PCTL_"^"_T XNCTL_"^"_ FILEAUTH_" ^"_PTCTL_" ^"_CLMLVL( "BILLAMT") _"^"_CLMLV L("VPYMT") _"^"_$$PTP RCAS^CH835 F2(CLMLVL( "BILLAMT") )
  3647   "RTN","CH8 35F2",508, 0)
  3648    ;S ^TMP($ J,"EDI_CRE ATE","CLP" ,TMPI)=^TM P($J,"EDI_ CREATE","C LP",TMPI)_ "^"_CLMLVL ("CLM")_"^ "_CLMLVL(" DRGCD")_"^ "_CLMLVL(" DRGWT")_"^ "_$$DTOUT^ CH835FU1(C LMLVL("CDT "))_"^"_"N EW"_"^"_"1 "
  3649   "RTN","CH8 35F2",509, 0)
  3650    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  3651   "RTN","CH8 35F2",510, 0)
  3652    ;
  3653   "RTN","CH8 35F2",511, 0)
  3654    ;SBB 02/2 1/2018 CC4 002-002 up dated CLPT BL to use  REV835 var iable to s et -ve val ues for vo ids
  3655   "RTN","CH8 35F2",512, 0)
  3656   CLPTBL ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  3657   "RTN","CH8 35F2",513, 0)
  3658    ;;1.RECOR D ID;"CLP" ;5;L;;5A;R ;
  3659   "RTN","CH8 35F2",514, 0)
  3660    ;;2.FILE  NUMBER;NFI LE;36;L;;3 6AN;R;
  3661   "RTN","CH8 35F2",515, 0)
  3662    ;;3.TRX S EQUENCE NU MBER;STSEQ ;9;L;;9N;R ;
  3663   "RTN","CH8 35F2",516, 0)
  3664    ;;4.CLAIM  KEY;CLMID ;36;L;;36A N;R;
  3665   "RTN","CH8 35F2",517, 0)
  3666    ;;5.AUTHO RIZATION;A UTH;25;L;; 25AN;R;
  3667   "RTN","CH8 35F2",518, 0)
  3668    ;;6.GROUP  CTRL NUMB ER;GRPCTL; 10;L;;10N; R;
  3669   "RTN","CH8 35F2",519, 0)
  3670    ;;7.TRANS ACTION CTR L NUMBER;T XNCTL;12;L ;;12AN;R;
  3671   "RTN","CH8 35F2",520, 0)
  3672    ;;8.FILE  AUTHORIZAT ION;FILEAU TH;25;L;;2 5AN;R;
  3673   "RTN","CH8 35F2",521, 0)
  3674    ;;9.PATIE NT CONTROL  NUMBER;PT CTL;20;L;; 20AN;R;
  3675   "RTN","CH8 35F2",522, 0)
  3676    ;;10.BILL ED AMOUNT; $S(REV835= 22:-CLMLVL ("BILLAMT" ),1:CLMLVL ("BILLAMT" ));20;L;;1 8N;R;
  3677   "RTN","CH8 35F2",523, 0)
  3678    ;;11.PAID  TO VENDOR ;$S((CLMLV L("VPYMT") <1)&OAB6:0 ,REV835=22 :-CLMLVL(" VPYMT"),1: CLMLVL("VP YMT"));20; L;;18N;R;
  3679   "RTN","CH8 35F2",524, 0)
  3680    ;;12.PATI ENT RESPON SIBILITY;$ S(REV835=2 2:"",1:PAT RESP);20;L ;;18N;R;
  3681   "RTN","CH8 35F2",525, 0)
  3682    ;;13.CLAI M NUMBER;$ P($G(^CHMP AY(PAYI,0) ),"^");30; L;;30AN;R;
  3683   "RTN","CH8 35F2",526, 0)
  3684    ;;14.DRUG  CODE;CLML VL("DRGCD" );4;L;;4AN ;R;
  3685   "RTN","CH8 35F2",527, 0)
  3686    ;;15.DRUG  WEIGHT;CL MLVL("DRGW T");10;L;; 10N;R;
  3687   "RTN","CH8 35F2",528, 0)
  3688    ;;16.CLAI M CREATION  DATE;$$DT OUT^CH835F U1($P(^CHM PAY(PAYI,0 ),"^",25)) ;8;L;;DATE ;R;
  3689   "RTN","CH8 35F2",529, 0)
  3690    ;;17.?;"N EW";5;L;;5 A;R;
  3691   "RTN","CH8 35F2",530, 0)
  3692    ;;18.CLAI M STATUS C ODE;$S(REV 835=22:"22 ",1:"01"); 2;L;;2N;R;
  3693   "RTN","CH8 35F2",531, 0)
  3694    ;;19.PDI; PDI;15;L;; 15N;R
  3695   "RTN","CH8 35F2",532, 0)
  3696    ;;20.TOTA L ALLOWED  AMOUNT INP ATIENT;$S( TOS="IPT": CLMLVL("TO TALLOW"),1 :"");20;L; ;18N;R
  3697   "RTN","CH8 35F2",533, 0)
  3698    ;;END OF  RECORD
  3699   "RTN","CH8 35F2",534, 0)
  3700    ;;19.SVC  START DATE ;$P(^CHMPA Y(PAYI,0), "^",8);8;L ;;DATE;R
  3701   "RTN","CH8 35F2",535, 0)
  3702    ;;20.SVC  END DATE;$ S(TOS="INP ":$P(^CHMP AY(PAYI,"I NP"),"^",1 ),1:$P(^CH MPAY(PAYI, 0),"^",8)) ;8;L;;DATE ;R
  3703   "RTN","CH8 35F2",536, 0)
  3704    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  3705   "RTN","CH8 35F2",537, 0)
  3706    ;
  3707   "RTN","CH8 35F2",538, 0)
  3708   CLPNAM ;;" FIELD NAME ";"TARGET  VALUE";"LE NGTH";"JUS TIFY FLAG" ;"PAD CHAR ";"DATA PA TTERN";FIE LD USE
  3709   "RTN","CH8 35F2",539, 0)
  3710    ;;1.RECOR D ID;"CLPN AME";7;L;; 7A;R;
  3711   "RTN","CH8 35F2",540, 0)
  3712    ;;2.FILE  NUMBER;NFI LE;36;L;;3 6AN;R;
  3713   "RTN","CH8 35F2",541, 0)
  3714    ;;3.TRX S EQUENCE NU MBER;STSEQ ;9;L;;9N;R ;
  3715   "RTN","CH8 35F2",542, 0)
  3716    ;;4.PHARM ACY;"PHARM  CLAIM";15 ;L;;15A;R;
  3717   "RTN","CH8 35F2",543, 0)
  3718    ;;5.BENE  LAST NAME; LNM;30;L;; 30A;R;
  3719   "RTN","CH8 35F2",544, 0)
  3720    ;;6.BENE  FIRST NAME ;FNM;30;L; ;30A;R;
  3721   "RTN","CH8 35F2",545, 0)
  3722    ;;7.BENE  SSN;SSN;9; L;;9N;R;
  3723   "RTN","CH8 35F2",546, 0)
  3724    ;;END OF  RECORD
  3725   "RTN","CH8 35F2",547, 0)
  3726    ;
  3727   "RTN","CH8 35F2",548, 0)
  3728    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  3729   "RTN","CH8 35F2",549, 0)
  3730    ; CLPCAS  CREATES TH E CLAIM AD JUSTMENT R ECORD. REP LACES THE  FOLLOWING  LINES:
  3731   "RTN","CH8 35F2",550, 0)
  3732    ; S ^TMP( $J,"EDI_CR EATE","CLP CAS",TMPI, CASTI)=NFI LE_"^"_STS EQ_"^"_CLM ID_"^"_$P( CLMLVL(1), "^",1)_"^" _GRP
  3733   "RTN","CH8 35F2",551, 0)
  3734    ; S ^TMP( $J,"EDI_CR EATE","CLP CAS",TMPI, CASTI)=^TM P($J,"EDI_ CREATE","C LPCAS",TMP I,CASTI)_" ^"_$P($P(C ASLN,"^",1 ),";",1)_" ^"_$P($P(C ASLN,"^",1 ),";",2)_" ^"_$P($P(C ASLN,"^",2 ),";",1)_" ^"_$P($P(C ASLN,"^",2 ),";",2)_" ^"_$P($P(C ASLN,"^",3 ),";",1)
  3735   "RTN","CH8 35F2",552, 0)
  3736    ; S ^TMP( $J,"EDI_CR EATE","CLP CAS",TMPI, CASTI)=^TM P($J,"EDI_ CREATE","C LPCAS",TMP I,CASTI)_" ^"_$P($P(C ASLN,"^",3 ),";",2)_" ^"_$P($P(C ASLN,"^",4 ),";",1)_" ^"_$P($P(C ASLN,"^",4 ),";",2)_" ^"_$P($P(C ASLN,"^",5 ),";",1)_" ^"_$P($P(C ASLN,"^",5 ),";",2)
  3737   "RTN","CH8 35F2",553, 0)
  3738    ; S ^TMP( $J,"EDI_CR EATE","CLP CAS",TMPI, CASTI)=^TM P($J,"EDI_ CREATE","C LPCAS",TMP I,CASTI)_" ^"_$P($P(C ASLN,"^",6 ),";",1)_" ^"_$P($P(C ASLN,"^",6 ),";",2)
  3739   "RTN","CH8 35F2",554, 0)
  3740    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  3741   "RTN","CH8 35F2",555, 0)
  3742    ; 
  3743   "RTN","CH8 35F2",556, 0)
  3744    ;SBB 02/2 1/2018 CC4 002-002 up dated CLPC ASTBL to u se REV835  variable t o set -ve  values for  voids
  3745   "RTN","CH8 35F2",557, 0)
  3746   CLPCASTBL  ;;"FIELD N AME";"TARG ET VALUE"; "LENGTH";" JUSTIFY FL AG";"PAD C HAR";"DATA  PATTERN"; FIELD USE
  3747   "RTN","CH8 35F2",558, 0)
  3748    ;;1.REC_I D;"CLPCAS" ;10;L;;10A ;R;
  3749   "RTN","CH8 35F2",559, 0)
  3750    ;;2.FILE  NUMBER;NFI LE;36;L;;3 6AN;R;
  3751   "RTN","CH8 35F2",560, 0)
  3752    ;;3.TRX S EQUENCE NU MBER;STSEQ ;9;L;;9N;R ;
  3753   "RTN","CH8 35F2",561, 0)
  3754    ;;4.CLAIM  KEY;CLMID ;36;L;;36A N;R;
  3755   "RTN","CH8 35F2",562, 0)
  3756    ;;5.HAC C LAIM NUMBE R;CLMLVL(" CLM");10;L ;;10AN;R;
  3757   "RTN","CH8 35F2",563, 0)
  3758    ;;6.CLAIM  ADJ GRP(C AS01);GRP; 4;L;;4N;R;
  3759   "RTN","CH8 35F2",564, 0)
  3760    ;;7.CLAIM  ADJ_REASO N1(CAS02); $P($P(CASL N,"^",1)," :",1);5;L; ;5AN;R;
  3761   "RTN","CH8 35F2",565, 0)
  3762    ;;8.CLAIM  ADJ_AMT(C AS03);$S(R EV835=22:- $P($P(CASL N,"^",1)," :",2),1:$P ($P(CASLN, "^",1),":" ,2));20;L; ;18.2FP;R;
  3763   "RTN","CH8 35F2",566, 0)
  3764    ;;9.CLAIM  ADJ QTY1( CAS04);$P( $P(CASLN," ^",1),":", 3);5;L;;5A N;R; 
  3765   "RTN","CH8 35F2",567, 0)
  3766    ;;10.CLAI M ADJ RSN2 (CAS05);$P ($P(CASLN, "^",2),":" ,1);5;L;;5 AN;O;
  3767   "RTN","CH8 35F2",568, 0)
  3768    ;;11.CLAI M ADJ AMT2 (CAS06);$S (REV835=22 :-$P($P(CA SLN,"^",2) ,":",2),1: $P($P(CASL N,"^",2)," :",2));20; L;;18.2FP; O;
  3769   "RTN","CH8 35F2",569, 0)
  3770    ;;12.CLAI M ADJ QTY2 (CAS07);$P ($P(CASLN, "^",2),":" ,3);5;L;;5 AN;O;  
  3771   "RTN","CH8 35F2",570, 0)
  3772    ;;13.CLAI M ADJ RSN3 (CAS08);$P ($P(CASLN, "^",3),":" ,1);5;L;;5 AN;O;
  3773   "RTN","CH8 35F2",571, 0)
  3774    ;;14.CLAI M ADJ AMT3 (CAS09);$S (REV835=22 :-$P($P(CA SLN,"^",3) ,":",2),1: $P($P(CASL N,"^",3)," :",2));20; L;;18.2FP; O;
  3775   "RTN","CH8 35F2",572, 0)
  3776    ;;15.CLAI M ADJ QTY3 (CAS07);$P ($P(CASLN, "^",3),":" ,3);5;L;;5 AN;O;  
  3777   "RTN","CH8 35F2",573, 0)
  3778    ;;16.CLAI M ADJ RSN4 (CAS11);$P ($P(CASLN, "^",4),":" ,1);5;L;;5 AN;O;
  3779   "RTN","CH8 35F2",574, 0)
  3780    ;;17.CLAI M ADJ AMT4 (CAS12);$S (REV835=22 :-$P($P(CA SLN,"^",4) ,":",2),1: $P($P(CASL N,"^",4)," :",2));20; L;;18.2FP; O;
  3781   "RTN","CH8 35F2",575, 0)
  3782    ;;18.CLAI M ADJ QTY4 (CAS13);$P ($P(CASLN, "^",4),":" ,3);5;L;;5 AN;O;  
  3783   "RTN","CH8 35F2",576, 0)
  3784    ;;19.CLAI M ADJ RSN5 (CAS14);$P ($P(CASLN, "^",5),":" ,1);5;L;;5 AN;O;
  3785   "RTN","CH8 35F2",577, 0)
  3786    ;;20.CLAI M ADJ AMT5 (CAS15);$S (REV835=22 :-$P($P(CA SLN,"^",5) ,":",2),1: $P($P(CASL N,"^",5)," :",2));20; L;;18.2FP; O;
  3787   "RTN","CH8 35F2",578, 0)
  3788    ;;21.CLAI M ADJ QTY5 (CAS16);$P ($P(CASLN, "^",5),":" ,3);5;L;;5 AN;O;  
  3789   "RTN","CH8 35F2",579, 0)
  3790    ;;22.CLAI M_ADJ RSN6 (CAS17);$P ($P(CASLN, "^",6),":" ,1);5;L;;5 AN;O;
  3791   "RTN","CH8 35F2",580, 0)
  3792    ;;23.CLAI M ADJ AMT6 (CAS18);$S (REV835=22 :-$P($P(CA SLN,"^",6) ,":",2),1: $P($P(CASL N,"^",6)," :",2));20; L;;18.2FP; O;
  3793   "RTN","CH8 35F2",581, 0)
  3794    ;;24.CLAI M ADJ QTY6 (CAS19);$P ($P(CASLN, "^",6),":" ,3);5;L;;5 AN;O;  
  3795   "RTN","CH8 35F2",582, 0)
  3796    ;;END OF  RECORD
  3797   "RTN","CH8 35F2",583, 0)
  3798    ;;*** 
  3799   "RTN","CH8 35F2",584, 0)
  3800    
  3801   "RTN","CH8 35F3")
  3802   0^4^B85763 1061
  3803   "RTN","CH8 35F3",1,0)
  3804   CH835F3  ; HAC/AEB;ED I 835 FILE  EXTRACT-  Service li ne loop; 0 6-15-2001;
  3805   "RTN","CH8 35F3",2,0)
  3806    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  3807   "RTN","CH8 35F3",3,0)
  3808    ;HR-PBM-P HASE 1B-Be gin;;;;;Bu ild 17
  3809   "RTN","CH8 35F3",4,0)
  3810    ;HR - Tea m Track #:  5592
  3811   "RTN","CH8 35F3",5,0)
  3812    ;HR - New  835 Routi ne that re places the  old CHEDI * Routines
  3813   "RTN","CH8 35F3",6,0)
  3814    ;COPIED F ROM CH835F 3  (JBM)  
  3815   "RTN","CH8 35F3",7,0)
  3816    ;DEV01396 2-01 1/24/ 11 JEH - E DI - CARC  42 display ing in the  835 inste ad of 45
  3817   "RTN","CH8 35F3",8,0)
  3818    ; 6/6/201 2 DEV7820  DLB ADDED  THE LINE I TEM CONTRO L NUMBER T O THE CACH E OUTPUT F ILE BUFFER
  3819   "RTN","CH8 35F3",9,0)
  3820    ;
  3821   "RTN","CH8 35F3",10,0 )
  3822    ;MTN02864 8: issue w ith the "B PR" and "S VC" record s needs 9.   DRW 06/1 3/2017
  3823   "RTN","CH8 35F3",11,0 )
  3824    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3825   "RTN","CH8 35F3",12,0 )
  3826    ; SVCREC( ) PERFORMS  THE LOOPI NG TO GENE RATE THE " SVC","SVCC AS", AND
  3827   "RTN","CH8 35F3",13,0 )
  3828    ; SVCLQ R ECORDS FOR  A GIVEN C LAIM (CHMP AY(I))
  3829   "RTN","CH8 35F3",14,0 )
  3830    ; 1) DETE RMINE THE  TYPE OF SE RVICE SO T HAT THE CO RRECT DATA  CAN BE
  3831   "RTN","CH8 35F3",15,0 )
  3832    ;               RETR IEVED FOR  THE TARGET  RECORD.
  3833   "RTN","CH8 35F3",16,0 )
  3834    ; 2) CREA TE THE ^TE MP() ARRAY  IN CDERU^ CHTFLIB
  3835   "RTN","CH8 35F3",17,0 )
  3836    ;               CDER U ROLLS UP  MULTIPLE  PROCEDURE  CODES AND  TOTALS SER VICE LINE  VALUES FOR  REPORTS
  3837   "RTN","CH8 35F3",18,0 )
  3838    ;               INPU T:  CHPTR  - POINTER  TO I VALUE  IN ^CHMPA Y
  3839   "RTN","CH8 35F3",19,0 )
  3840    ;         CHSUB - PO INTER TO S ERVICE VAL UE IN ^CHM PAY
  3841   "RTN","CH8 35F3",20,0 )
  3842    ;         JX - REQUR IED FOR HI ST FILE ON LY - HISTO RY FILE TI ME STAMP
  3843   "RTN","CH8 35F3",21,0 )
  3844    ;               OUTP UT: RTN -  0 FOR TEMP  GLOBAL NO T BUILT
  3845   "RTN","CH8 35F3",22,0 )
  3846    ;         RTN - 1 FO R TEMP GLO BAL IS BUI LT
  3847   "RTN","CH8 35F3",23,0 )
  3848    ;         TEMP GLOBA LS - ^TEMP ($J,"CDERU ",CHPTR,CH SUB,CHPRC, CHCHG,CHMD )="PQTY^CH TALL^(PO1^ THRU P14)^ CHTST^CHRE S
  3849   "RTN","CH8 35F3",24,0 )
  3850    ;                         ^TEMP ($J,"HCDER U",CHPTR,C HSUB,CHPRC ,CHCHG,CHM D)="PQTY^C HTALL^PO1^ THRU P14
  3851   "RTN","CH8 35F3",25,0 )
  3852    ;         CHPRC - PR OCEDURE CO DE
  3853   "RTN","CH8 35F3",26,0 )
  3854    ;         CHCHG - CH ARGE FOR S ERVICE
  3855   "RTN","CH8 35F3",27,0 )
  3856    ;         CHMD - CON TAINS MODI FIERS(MOD1 ,MOD2,MOD3 ,MOD4)
  3857   "RTN","CH8 35F3",28,0 )
  3858    ;         PQTY - TOT AL NUMBER  OF PROCEDU RES
  3859   "RTN","CH8 35F3",29,0 )
  3860    ;         CHTALL - T OTAL AMT A LLOWED FOR  PROCEDURE
  3861   "RTN","CH8 35F3",30,0 )
  3862    ;         P01 THRU P 14 LINE LE VEL QUANTI TIES
  3863   "RTN","CH8 35F3",31,0 )
  3864    ;         CHTST - RU LE PROC LA ST TEST
  3865   "RTN","CH8 35F3",32,0 )
  3866    ;         CHRES - RU LE PROC RE SULT CODE
  3867   "RTN","CH8 35F3",33,0 )
  3868    ; 3) PERF ORM "SORT"  ON THE CL AIM (^CHMP AY(I) INDE X) T0 RETR IEVE UNIT  COUNT/ALLO WED UNIT/H AC PAID CO UNT
  3869   "RTN","CH8 35F3",34,0 )
  3870    ; 4) FOR  EACH LINE/ PROC, CREA TE A CAS A RRAY
  3871   "RTN","CH8 35F3",35,0 )
  3872    ; 5) CREA TE THE SVC /SVCCAS/SV CLQ RECORD S FOR THE  LINE
  3873   "RTN","CH8 35F3",36,0 )
  3874    ; 6) RETU RN THE PAT IENT RESPO NSIBILITY  AMOUNT (SU M OF THE S VCCAS "PR"  ADJUSTMEN TS)
  3875   "RTN","CH8 35F3",37,0 )
  3876    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3877   "RTN","CH8 35F3",38,0 )
  3878    ;^TMP($J, "IMG2PAY", PAYI,IMGL) =CVGCODE_" ^"_AIRSN_" ^"_UNITCNT _"^"_SERVI _"^"_UNITC HG_"^"_UNI TCOST_"^"_ UNITACCPT_ "^"_UNITAL LW_"^"_URE JAMT
  3879   "RTN","CH8 35F3",39,0 )
  3880    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3881   "RTN","CH8 35F3",40,0 )
  3882    ; 4/26/13   DLB MODI FIED THE I NDEX 3 FOR  SVCCAS (S VCCTI) TO  ELIMINATE  OVERWRITIN G SVCCAS W HEN MULTIP LE CLAIMS  IN A SUBMI SSION
  3883   "RTN","CH8 35F3",41,0 )
  3884    ; 6/6/201 3 DLB MODI FIED THE S VC() FUNCT ION TO RET URN PATIEN T RESPONSI BILITY AMO UNT FROM T HE "PR" AD JUSTMENTS
  3885   "RTN","CH8 35F3",42,0 )
  3886    ; 6/6/13  DLB THE SV CREC() FUN CTION RETU RNS THE PA TIENT RESP ONSIBILITY  AMOUNT TO  CLM^CH835 F2 SO THE  VALUE CAN
  3887   "RTN","CH8 35F3",43,0 )
  3888    ;         BE OUTPUT  IN THE CLP  RECORD
  3889   "RTN","CH8 35F3",44,0 )
  3890    ; 7/5/201 3 DLB CLEA N UP DEBUG  STATEMENT S, ALLOW O UTPUT ONLY  IN NON-LI VE ENVIRON MENTS
  3891   "RTN","CH8 35F3",45,0 )
  3892    ; 7/31/20 13  DLB  M ODS TO SUP PORT NEW P AY->IMG CO RRELATION
  3893   "RTN","CH8 35F3",46,0 )
  3894    ; 3/19/20 14  DLB    PHARMACY O R CMOP PDI  LABEL TYP E CHECK @  LINE 152
  3895   "RTN","CH8 35F3",47,0 )
  3896    ; 4/1/201 4       DL B  TST0192 32-02: DET ERMINATION  OF INDEXI NG ISSUE B ETWEEN ^CH MPAY AND ^ CHMIMAGE 
  3897   "RTN","CH8 35F3",48,0 )
  3898    ;                                          ADDED RETU RN VALUE ( PATRESP) T O EARLY EX ITS FOR SV CREC() (LI NES 70,84)
  3899   "RTN","CH8 35F3",49,0 )
  3900    ; 8/25/20 14  DLB  L INEID^CHTF LIB5() ISS UES FOR V. E. MODIFIE D CLAIMS.   ADDED INP ATIENT PRO C FOR GTPA YTOS() FUN CTION,
  3901   "RTN","CH8 35F3",50,0 )
  3902    ;                                          ADDED UNIT  COUNT TO  GETIMG() R ETURN
  3903   "RTN","CH8 35F3",51,0 )
  3904    ; 4/23/20 15  DLB        RE: DE F19231 (11 /23/2013)  "ADDED TOS  TO THE LI ST OF "NEW " VARIABLE S (LINE 65 )
  3905   "RTN","CH8 35F3",52,0 )
  3906    ; 12/3/15  SLT MODIF IED TO CHE CK FOR A C LAIM LEVEL  PAID AMOU NT <1$ AND  USE CARC  B5
  3907   "RTN","CH8 35F3",53,0 )
  3908    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  3909   "RTN","CH8 35F3",54,0 )
  3910    ; THIS FU NCTION CRE ATES THE S VC AND SVC CAS RECORD S
  3911   "RTN","CH8 35F3",55,0 )
  3912    ; ^TMP($J ,"IMG2PAY" ,PAYI,IMGL )=CVGCODE_ "^"_AIRSN_ "^"_UNITCN T_"^"_SERV I_"^"_UNIT CHG_"^"_UN ITCOST_"^" _UNITACCPT _"^"_UNITA LLW_"^"_UR EJAMT
  3913   "RTN","CH8 35F3",56,0 )
  3914   SVCREC(PAY I,VENI,CLP I,NFILE,ST SEQ,CHQTY, EDII) 
  3915   "RTN","CH8 35F3",57,0 )
  3916    ; PAYI          CURR ENT  ^CHMP AY(I)
  3917   "RTN","CH8 35F3",58,0 )
  3918    ; VENI          VEND OR INDEX
  3919   "RTN","CH8 35F3",59,0 )
  3920    ; CLPI          CLP  INDEX FOR  CLP,CLPCAS ,SVC,SVCCA S RECORDS
  3921   "RTN","CH8 35F3",60,0 )
  3922    ; NFILE         NAME  OF OUTPUT  FILE (FOR  RECORD)
  3923   "RTN","CH8 35F3",61,0 )
  3924    ; STSEQ         STAT US SEQUENC E NUMBER ( FOR RECORD )
  3925   "RTN","CH8 35F3",62,0 )
  3926    ; CHQTY         QTY  VALUE FOR  THE SVCCAS  RECORD(S)
  3927   "RTN","CH8 35F3",63,0 )
  3928    ; EDII          ^CHM EDI() FILE  "I" INDEX  FOR STATU S ACCESS
  3929   "RTN","CH8 35F3",64,0 )
  3930    ;
  3931   "RTN","CH8 35F3",65,0 )
  3932    N CNT,LIN NUM,PROCVA L,SVCLVL,I DXSTR,CLMI D,ZEMCARR, IMGTOS,PAY TOS,STATUS ,PDI,PAYAD D,PAYJ,PAY K,SVCPROC, CAS,TOS,SV C03
  3933   "RTN","CH8 35F3",66,0 )
  3934    I '$D(%DB G835) S %D BG835=($$E NVIR^CHTFL IB'="LIVE" )
  3935   "RTN","CH8 35F3",67,0 )
  3936    S (LINNUM ,PROCVAL)= 0,TOS=""
  3937   "RTN","CH8 35F3",68,0 )
  3938    N LN,LINE ,SVCTI,SVC CASI,PAYK, CHQTY,REJC D,REJI,REJ TYPE,LICTR L,RENDNPI, PATRESP
  3939   "RTN","CH8 35F3",69,0 )
  3940    S (SVCTI, SVCCASI)=1 ,PATRESP=0
  3941   "RTN","CH8 35F3",70,0 )
  3942    S CLMNUM= $P(^CHMPAY (PAYI,0)," ^",1)                                                  ; HAC CLAI M NUMBER
  3943   "RTN","CH8 35F3",71,0 )
  3944    S STATUS= $P(^CHMPAY (PAYI,0)," ^",2)
  3945   "RTN","CH8 35F3",72,0 )
  3946    S TOS=$$T OS^CH835FU 1($P(^CHMP AY(PAYI,0) ,"^",7))                  ; TYPE  OF SERVIC E
  3947   "RTN","CH8 35F3",73,0 )
  3948    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1)                                 ; RETRIE VE THE PDI  FOR CLAIM  TYPE VERI FICATION
  3949   "RTN","CH8 35F3",74,0 )
  3950    S CHQTY=1                                                                                                        ; ASSU ME NON-PHA RMACY CLAI M QTY
  3951   "RTN","CH8 35F3",75,0 )
  3952    I (TOS="R XT")&(($E( PDI,8,9)=" 99")!($E(P DI,8,9)="9 8"))  D        ; IF T YPE OF SER VICE= PHAR MACY AND P DI TYPE IS  SXC SET P HARM QTY
  3953   "RTN","CH8 35F3",76,0 )
  3954    .S CHQTY= $$PHARMQTY ^CH835F2(P AYI)                                                   ; SET THE  QTY VALUE  FOR PHARMA CY
  3955   "RTN","CH8 35F3",77,0 )
  3956    Q:(TOS="I NP")!(TOS= "IPT") PAT RESP                                                   ; NO SVC L EVEL REPOR TING FOR I NPATIENT
  3957   "RTN","CH8 35F3",78,0 )
  3958    S PAYTOS= $$GTPAYTOS (TOS)                                                                     ;  ^CHMPAY TO S MARKER
  3959   "RTN","CH8 35F3",79,0 )
  3960    S IMGTOS= $$GTIMGTOS (TOS)                                                                     ;  ^CHMIMAGE  TOS MARKER
  3961   "RTN","CH8 35F3",80,0 )
  3962    I '$D(GLP AY) S X1=P AYI D PROG TYP^CHFCD0 01                        ;4 20/ 2012 DEV00 7820 SETS  GLPAY IF N OT DEFINED .
  3963   "RTN","CH8 35F3",81,0 )
  3964    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     
  3965   "RTN","CH8 35F3",82,0 )
  3966    .D INIT^C HGCUU3(PAY I,"ALLOW", "AUTO")                                       ; AUTO-D ISTRIBUTIO N (creates  LINEID if  not exist ) ;JAK 7/2 8/11 DEV00 7820      
  3967   "RTN","CH8 35F3",83,0 )
  3968    E  D
  3969   "RTN","CH8 35F3",84,0 )
  3970    .D INIT^C HGCUU3(PAY I,"ALLOW", "TPLBENE")                                    ; MANUAL ...distrib ute tpl &  bene pmts  and calc o hi
  3971   "RTN","CH8 35F3",85,0 )
  3972    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1)                                 ; CLAIM  PDI FROM ^ CHMPAY(PAY I,0),"^",4 )
  3973   "RTN","CH8 35F3",86,0 )
  3974    D SORT(PA YI)                                                                                           ; CL ONE FOR SU MMING ^CHM PAY UNITS,  SETS UP T HE ^TMP($J ,"IMGPAY")  ARRAY
  3975   "RTN","CH8 35F3",87,0 )
  3976    S PAYJ=99 999999,IMG L=""
  3977   "RTN","CH8 35F3",88,0 )
  3978    F  S PAYJ =$O(^TMP($ J,"IMGPAY" ,PAYI,PAYJ ),-1) Q:+( PAYJ)=0  Q :IMGL="*"   D         ; RETRIEVE  THE PAYJ  VALUES RET URNED FROM  LINEID()
  3979   "RTN","CH8 35F3",89,0 )
  3980    .S IMGL=^ TMP($J,"IM GPAY",PAYI ,PAYJ)                                        ; RETRIE VE THE IMG L VALUES R ETURNED FR OM LINEID( )
  3981   "RTN","CH8 35F3",90,0 )
  3982    S:IMGL="* " $P(^CHME DI(EDII,0) ,"^",2)=7, ^CHMEDI("D ",7,EDII)= "" ; SET T HE STATUS  FLAG FOR I NDEXING ER ROR
  3983   "RTN","CH8 35F3",91,0 )
  3984    Q:IMGL="* " PATRESP                                                                                     ; DO N'T ATTEMP T TO GENER ATE 835 IF  INDEXING  HAS ERRORS
  3985   "RTN","CH8 35F3",92,0 )
  3986    D IMG2PAY (PAYI,TOS)                                                                           ;  PAY TO IMG  CORRELATI ON, BUILDS  DATA ARRA Y FOR 835  DATA
  3987   "RTN","CH8 35F3",93,0 )
  3988    S IMGL=0
  3989   "RTN","CH8 35F3",94,0 )
  3990    F LINE=1: 1 S IMGL=$ O(^TMP($J, "IMG2PAY", PAYI,IMGL) ) Q:+(IMGL )=0  D       ; LOOP T HROUGH THE  SERVICE L INES
  3991   "RTN","CH8 35F3",95,0 )
  3992    .Q:'$D(^C HMIMAGE(PD I,1,1,2,1, IMGTOS,IMG L))              ; EX IT LOOP IF  ^CHMIMAGE  INDEX IS  INVALID
  3993   "RTN","CH8 35F3",96,0 )
  3994    .S I2PDAT A=^TMP($J, "IMG2PAY", PAYI,IMGL)                           ; UNIT  INFORMATI ON FROM ^C HMPAY() FO R THIS LIN E
  3995   "RTN","CH8 35F3",97,0 )
  3996    .S SORTDA TA=^TMP($J ,"LINE",PA YI,IMGL)                    ; SO RT FROM TO NY BYRUM'S  FUNCTION  FOR THIS L INE
  3997   "RTN","CH8 35F3",98,0 )
  3998    .S IMGDAT A=$$GETIMG (PAYI,IMGT OS,IMGL)           ;  ^CHMIMAGE  DATA FOR T HE "L"  NO DE FOR SVC  RECORD
  3999   "RTN","CH8 35F3",99,0 )
  4000    .S MODDAT A=$$GTMODS (IMGTOS,IM GL)                                                    ; MODIFIER  FIELDS DI FFERENT FO R EACH TYP E OF SERVI CE
  4001   "RTN","CH8 35F3",100, 0)
  4002    .S PATRES P=PATRESP+ $$SVC(IMGL ,I2PDATA,S ORTDATA,CL PI,.CAS,SV CTI,CHQTY, EDII)      ; POPULATE  THE SVC L INE CAS AR RAY
  4003   "RTN","CH8 35F3",101, 0)
  4004    .S SERVI= $P(I2PDATA ,"^",4)                                                                   ;  RETRIEVE T HE SVC PRO CEDURE VAL UE
  4005   "RTN","CH8 35F3",102, 0)
  4006    .S LICTRL =$S(TOS'=" RXT":$S($P (IMGDATA," ^",3)="":1 ,1:$P(IMGD ATA,"^",3) ),1:1)
  4007   "RTN","CH8 35F3",103, 0)
  4008    .S RENDNP I=$$GETREN D^CH835FU1 (PAYI,LICT RL)
  4009   "RTN","CH8 35F3",104, 0)
  4010    .S REC=""
  4011   "RTN","CH8 35F3",105, 0)
  4012    .F LN=1:1  S STR=$T( SVCTBL+LN)  Q:STR["EN D OF RECOR D"  D ; US E THE $TEX T "SVCTBL"  TO CREATE  SVC RECOR DS
  4013   "RTN","CH8 35F3",106, 0)
  4014    ..I LN=1  S REC=REC_ $$FORMATDA TA^CHMXWBU T(STR)   
  4015   "RTN","CH8 35F3",107, 0)
  4016    ..E  S RE C=REC_"^"_ $$FORMATDA TA^CHMXWBU T(STR)
  4017   "RTN","CH8 35F3",108, 0)
  4018    .S ^TMP($ J,"EDI_CRE ATE","SVC" ,CLPI,SVCT I)=REC
  4019   "RTN","CH8 35F3",109, 0)
  4020    .D SVCCAS L(CLPI,IMG L,SVCTI,PA YI,CHQTY)                            ; GENE RATE SVCCA S RECORDS  AS REQUIRE D
  4021   "RTN","CH8 35F3",110, 0)
  4022    .S SVCTI= SVCTI+1                                                                              ;  INCREMENT  THE SVC RE CORD INDEX  AFTER REC ORDING ADJ USTMENTS
  4023   "RTN","CH8 35F3",111, 0)
  4024    .S REJCD= $P(I2PDATA ,"^",2)                                                           ; REJECT R EASON CODE  DETERMINE S IF "LQ"  RECORDS AR E GENERATE D
  4025   "RTN","CH8 35F3",112, 0)
  4026    .D:REJCD' ="" LQ(PAY I,IMGL,NFI LE,STSEQ,C LMID,REJCD ,CLPI,TOS, LINE)                 ; DO LQ
  4027   "RTN","CH8 35F3",113, 0)
  4028   SVCEND   
  4029   "RTN","CH8 35F3",114, 0)
  4030    Q PATRESP                         ; RETURN  SUM OF AL L "PR" ADJ USTMENTS F OR OUTPUT  IN "CLP" R ECORD
  4031   "RTN","CH8 35F3",115, 0)
  4032    ;
  4033   "RTN","CH8 35F3",116, 0)
  4034    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  4035   "RTN","CH8 35F3",117, 0)
  4036    ; RETRIEV E THE ^CHM IMAGE() DA TA FOR THE  TYPE OF S ERVICE
  4037   "RTN","CH8 35F3",118, 0)
  4038    ; 8/25/20 14 DLB  AD DED UNIT V ALUE TO TH E RETURN F OR IMG DAT A
  4039   "RTN","CH8 35F3",119, 0)
  4040    ; THE RET URN VALUE  CONTAINS T HE VALUES:  DATE OF S ERVICE_"^" _REVENUE C ODE_"^"_ED I LINE IDE NTIFIER_"^ "_UNITS
  4041   "RTN","CH8 35F3",120, 0)
  4042    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  4043   "RTN","CH8 35F3",121, 0)
  4044    ;
  4045   "RTN","CH8 35F3",122, 0)
  4046   GETIMG(PAY I,TOS,IMGL
  4047   "RTN","CH8 35F3",123, 0)
  4048    N JDX,KDX ,IMG,RESUL T,PDI
  4049   "RTN","CH8 35F3",124, 0)
  4050    S (JDX,KD X)=1,IMG=" ",RESULT=" "
  4051   "RTN","CH8 35F3",125, 0)
  4052    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1)                                 ; CLAIM  PDI FROM ^ CHMPAY(PAY I,0),"^",4 )
  4053   "RTN","CH8 35F3",126, 0)
  4054    S IMG=^CH MIMAGE(PDI ,1,JDX,2,K DX,TOS,IMG L,0)
  4055   "RTN","CH8 35F3",127, 0)
  4056    I TOS="RX -NS"  D
  4057   "RTN","CH8 35F3",128, 0)
  4058    .S RESULT =$P(IMG,"^ ",1)_"^"_" "_"^"_""
  4059   "RTN","CH8 35F3",129, 0)
  4060    I TOS="OP T-NS"  D
  4061   "RTN","CH8 35F3",130, 0)
  4062    .S RESULT =$P(IMG,"^ ",1)_"^"_$ P(IMG,"^", 14)_"^"_$P (IMG,"^",1 6)_"^"_$P( IMG,"^",17 )       ;  ^CHMIMAGE  DATA FIELD  INDEXES A RE DIFFERE NT FOR EAC H TOS
  4063   "RTN","CH8 35F3",131, 0)
  4064    I TOS="DM E-NS"  D
  4065   "RTN","CH8 35F3",132, 0)
  4066    .S RESULT =$P(IMG,"^ ",1)_"^"_$ P(IMG,"^", 15)_"^"_$P (IMG,"^",1 4)_"^"_$P( IMG,"^",12 )       ;  ^CHMIMAGE  DATA FIELD  INDEXES A RE DIFFERE NT FOR EAC H TOS
  4067   "RTN","CH8 35F3",133, 0)
  4068    I TOS="DE NTAL-NS" D
  4069   "RTN","CH8 35F3",134, 0)
  4070    .S RESULT =$P(IMG,"^ ",1)_"^"_$ P(IMG,"^", 16)_"^"_$P (IMG,"^",1 5)_"^"_$P( IMG,"^",12 )       ;  ^CHMIMAGE  DATA FIELD  INDEXES A RE DIFFERE NT FOR EAC H TOS
  4071   "RTN","CH8 35F3",135, 0)
  4072    Q RESULT
  4073   "RTN","CH8 35F3",136, 0)
  4074    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  4075   "RTN","CH8 35F3",137, 0)
  4076    ; RETRIEV E THE CLAI M ID (OR P RESCRIPTIO N NUMBER)  FOR SVC/SV CCAS RECOR DS
  4077   "RTN","CH8 35F3",138, 0)
  4078    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  4079   "RTN","CH8 35F3",139, 0)
  4080    ;
  4081   "RTN","CH8 35F3",140, 0)
  4082   GTCLMID(PA YI,TOS) 
  4083   "RTN","CH8 35F3",141, 0)
  4084    N ZEMCARR ,CHTPID,PD I,PDITYPE, CHEI,IDXST R
  4085   "RTN","CH8 35F3",142, 0)
  4086    D EDICLM^ CH835FU1(P AYI,.ZEMCA RR)                                                    ;GET INDEX ES FOR CLA IM BUFFERS  INTO ZEMC ARR
  4087   "RTN","CH8 35F3",143, 0)
  4088    S IDXSTR= $P(ZEMCARR ,"^",1)
  4089   "RTN","CH8 35F3",144, 0)
  4090    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1),PDITYPE =$E(PDI,8, 9)  ; RETR IEVE THE P DI, EXTRAC T THE LABE L TYPE
  4091   "RTN","CH8 35F3",145, 0)
  4092    S CHTPID= $P(ZEMCARR ,"^",5)                                                                   ;  THE CHTPID  WAS ADDED  TO LAST F IELD OF TH E ^CHMPAY( I,"ZEMC",J ,K) CROSSR EFERENCE
  4093   "RTN","CH8 35F3",146, 0)
  4094    I (TOS="R XT")&((PDI TYPE="99") !(PDITYPE= "98"))  D                 ; DLB  3/19/2014    PHARMACY  OR CMOP P DI LABEL T YPE
  4095   "RTN","CH8 35F3",147, 0)
  4096    .S RXI=$P (IDXSTR,"* ",1),RXJ=$ P(IDXSTR," *",2),RXK= $P(IDXSTR, "*",3)                ; RETRIEVE  THE ^CHMX RX(I,J,K)  INDEX 
  4097   "RTN","CH8 35F3",148, 0)
  4098    .S CLMID= $P(^CHMXRX (RXI,100,R XJ,100,RXK ,1),"^",1)                ; PRES CRIPTION N UMBER
  4099   "RTN","CH8 35F3",149, 0)
  4100    .S DOS=$P (^CHMXRX(R XI,100,RXJ ,100,RXK,1 ),"^",2)                  ; DATE  OF SERVIC E
  4101   "RTN","CH8 35F3",150, 0)
  4102    E  D
  4103   "RTN","CH8 35F3",151, 0)
  4104    .S CHEI=$ P(IDXSTR," *",5)
  4105   "RTN","CH8 35F3",152, 0)
  4106    .S CLMID= $P($G(^CHM XCLE(CHEI, 0)),"^",17 )                                  ; 36 CHA RACTER HAC  CLM ID FO R 835 RECO RDS
  4107   "RTN","CH8 35F3",153, 0)
  4108    Q CLMID
  4109   "RTN","CH8 35F3",154, 0)
  4110    ;
  4111   "RTN","CH8 35F3",155, 0)
  4112    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  4113   "RTN","CH8 35F3",156, 0)
  4114    ; GETSVCP ROC RETRUN S THE SERV ICE PROCED URE VALUE
  4115   "RTN","CH8 35F3",157, 0)
  4116    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  4117   "RTN","CH8 35F3",158, 0)
  4118    ;
  4119   "RTN","CH8 35F3",159, 0)
  4120   GTSERVI(PA YI,TOS) 
  4121   "RTN","CH8 35F3",160, 0)
  4122    ; PAYI          CLAI M POINTER
  4123   "RTN","CH8 35F3",161, 0)
  4124    ; TOS           CLAI M TYPE OF  SERVICE (I PT,OPT,DUR ,DEN,RXT)
  4125   "RTN","CH8 35F3",162, 0)
  4126    S PAYTOS= $$GTPAYTOS (TOS)                                                                              ; TY PE OF SERV  FOR ^CHMP AY FILE
  4127   "RTN","CH8 35F3",163, 0)
  4128    S PAYJ=0, PAYK=0
  4129   "RTN","CH8 35F3",164, 0)
  4130    F  S PAYJ =$O(^CHMPA Y(PAYI,PAY TOS,PAYJ))  Q:+(PAYJ) =0  D          ; GET  THE "UNITS " LEVEL "J " INDEX
  4131   "RTN","CH8 35F3",165, 0)
  4132    N IMGTOS, PAYTOS,SER VI
  4133   "RTN","CH8 35F3",166, 0)
  4134    S SERVI=" "
  4135   "RTN","CH8 35F3",167, 0)
  4136    S IMGTOS= $$GTIMGTOS (TOS)
  4137   "RTN","CH8 35F3",168, 0)
  4138    S SERVI=$ P(I2PDATA, "^",7)                                                            ; $P(^CHMP AY(I,SVC T YPE,J,0)," ^",1)
  4139   "RTN","CH8 35F3",169, 0)
  4140    ;U 0 W !, "   F3:GTS ERVI: SERV I= ",SERVI
  4141   "RTN","CH8 35F3",170, 0)
  4142    Q SERVI
  4143   "RTN","CH8 35F3",171, 0)
  4144    ;
  4145   "RTN","CH8 35F3",172, 0)
  4146   GTPAYTOS(T OS)   ; TY PE OF SERV ICE TITLES  ARE DIFFE RENT BETWE EN ^CHMPAY  AND ^CHMI MAGE
  4147   "RTN","CH8 35F3",173, 0)
  4148    N PAYTOS
  4149   "RTN","CH8 35F3",174, 0)
  4150    S PAYTOS= $S(TOS="OP T":"OPT-PR OC",TOS="T RV":"OPT-P ROC",TOS=" DUR":"DME- SUPPLY",TO S="RXT":"P HARM",TOS= "DNT":"DEN -PROC",TOS ="IPT":"IN P-PROC")
  4151   "RTN","CH8 35F3",175, 0)
  4152    Q PAYTOS
  4153   "RTN","CH8 35F3",176, 0)
  4154   GTIMGTOS(T OS)   ; TY PE OF SERV ICE TITLES  ARE DIFFE RENT BETWE EN ^CHMPAY  AND ^CHMI MAGE
  4155   "RTN","CH8 35F3",177, 0)
  4156    N IMGTOS
  4157   "RTN","CH8 35F3",178, 0)
  4158    S IMGTOS= $S(TOS="OP T":"OPT-NS ",TOS="TRV ":"OPT-NS" ,TOS="DUR" :"DME-NS", TOS="DNT": "DENTAL-NS ",TOS="IPT ":"INP-NS" ,TOS="RXT" :"RX-NS")  ; GET THE  ^CHMIMAGE  TOS INDEX* FIELD 
  4159   "RTN","CH8 35F3",179, 0)
  4160    Q IMGTOS
  4161   "RTN","CH8 35F3",180, 0)
  4162    ;
  4163   "RTN","CH8 35F3",181, 0)
  4164    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  4165   "RTN","CH8 35F3",182, 0)
  4166    ; PROCEDU RE MODIFIE R VALUE RE TRIEVAL
  4167   "RTN","CH8 35F3",183, 0)
  4168    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  4169   "RTN","CH8 35F3",184, 0)
  4170    ;
  4171   "RTN","CH8 35F3",185, 0)
  4172   GTMODS(IMG TOS,IMGL) 
  4173   "RTN","CH8 35F3",186, 0)
  4174    ; IMGTOS        STRI NG INDEX F OR ^CHMIMA GE TOS NOD E
  4175   "RTN","CH8 35F3",187, 0)
  4176    ; IMGL          "L"  INDEX IN ^ CHMIMAGE F OR CURRENT  PROCESS
  4177   "RTN","CH8 35F3",188, 0)
  4178    ;
  4179   "RTN","CH8 35F3",189, 0)
  4180    N MOD1I,M OD2I,MOD3I ,MOD4I,DIC 1,DIC2,DIC 3,DIC4,MOD 1,MOD2,MOD 3,MOD4
  4181   "RTN","CH8 35F3",190, 0)
  4182    S (MOD1I, MOD2I,MOD3 I,MOD4I,DI C1,DIC2,DI C3,DIC4,MO D1,MOD2,MO D3,MOD4)=" "
  4183   "RTN","CH8 35F3",191, 0)
  4184    I IMGTOS= "OPT-NS"   D
  4185   "RTN","CH8 35F3",192, 0)
  4186    .S MOD1I= 9,MOD2I=20 ,MOD3I=21, MOD4I=22
  4187   "RTN","CH8 35F3",193, 0)
  4188    E  I IMGT OS="DENTAL -NS"  D
  4189   "RTN","CH8 35F3",194, 0)
  4190    .S MOD1I= 8,MOD2I=19 ,MOD3I=20, MOD4I=21
  4191   "RTN","CH8 35F3",195, 0)
  4192    E  I IMGT OS="DME-NS "  D
  4193   "RTN","CH8 35F3",196, 0)
  4194    .S MOD1I= 17,MOD2I=1 8,MOD3I=19 ,MOD4I=20
  4195   "RTN","CH8 35F3",197, 0)
  4196    S:+(MOD1I )>0 DIC1=$ P(^CHMIMAG E(PDI,1,1, 2,1,IMGTOS ,IMGL,0)," ^",MOD1I)
  4197   "RTN","CH8 35F3",198, 0)
  4198    S:+(MOD2I )>0 DIC2=$ P(^CHMIMAG E(PDI,1,1, 2,1,IMGTOS ,IMGL,0)," ^",MOD2I)
  4199   "RTN","CH8 35F3",199, 0)
  4200    S:+(MOD3I )>0 DIC3=$ P(^CHMIMAG E(PDI,1,1, 2,1,IMGTOS ,IMGL,0)," ^",MOD3I)
  4201   "RTN","CH8 35F3",200, 0)
  4202    S:+(MOD4I )>0 DIC4=$ P(^CHMIMAG E(PDI,1,1, 2,1,IMGTOS ,IMGL,0)," ^",MOD4I)
  4203   "RTN","CH8 35F3",201, 0)
  4204    S:+(DIC1) >0 MOD1=$P ($G(^CHMDI C(741002.3 7,DIC1,0)) ,"^",1)
  4205   "RTN","CH8 35F3",202, 0)
  4206    S:+(DIC2) >0 MOD2=$P ($G(^CHMDI C(741002.3 7,DIC2,0)) ,"^",1)
  4207   "RTN","CH8 35F3",203, 0)
  4208    S:+(DIC3) >0 MOD3=$P ($G(^CHMDI C(741002.3 7,DIC3,0)) ,"^",1)
  4209   "RTN","CH8 35F3",204, 0)
  4210    S:+(DIC4) >0 MOD4=$P ($G(^CHMDI C(741002.3 7,DIC4,0)) ,"^",1)
  4211   "RTN","CH8 35F3",205, 0)
  4212    Q MOD1_"^ "_MOD2_"^" _MOD3_"^"_ MOD4
  4213   "RTN","CH8 35F3",206, 0)
  4214    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  4215   "RTN","CH8 35F3",207, 0)
  4216    ; SVC() P ERFORMS LI NE LEVEL A DJUSTMENT  AND REJECT  PROCESSES  FOR THE
  4217   "RTN","CH8 35F3",208, 0)
  4218    ; "SVCCAS " RECORD G ENERATION
  4219   "RTN","CH8 35F3",209, 0)
  4220    ;TMP($J," LINE",CI,S ORTV)  SOR TV LINE EN TRY IN ^CH MIMAGE OR  GROUP INDI CATOR FROM  CEU
  4221   "RTN","CH8 35F3",210, 0)
  4222    ;                     1  - OHI  PAID
  4223   "RTN","CH8 35F3",211, 0)
  4224    ;                     2  - OHI  PATIENT RE SPON
  4225   "RTN","CH8 35F3",212, 0)
  4226    ;                     3  - ALL  OTHER OHI  PAYMENTS
  4227   "RTN","CH8 35F3",213, 0)
  4228    ;                     4  - OHI  OHI PR BAL ANCE
  4229   "RTN","CH8 35F3",214, 0)
  4230    ;                     5  - MEDI CAD PAYMEN TS
  4231   "RTN","CH8 35F3",215, 0)
  4232    ;                     6  - TPL
  4233   "RTN","CH8 35F3",216, 0)
  4234    ;                     7  - ALLO WED AMOUNT
  4235   "RTN","CH8 35F3",217, 0)
  4236    ;                     8  - BILL ED AMOUNT
  4237   "RTN","CH8 35F3",218, 0)
  4238    ;                     9  - DED  AMT
  4239   "RTN","CH8 35F3",219, 0)
  4240    ;                     10 - CAT  CAP AMT
  4241   "RTN","CH8 35F3",220, 0)
  4242    ;                     11 - COST  SHARE
  4243   "RTN","CH8 35F3",221, 0)
  4244    ;                     12 - AMT  TO PAY
  4245   "RTN","CH8 35F3",222, 0)
  4246    ;                     13 - AMT  TO PAY BEN E
  4247   "RTN","CH8 35F3",223, 0)
  4248    ;                     14 - AMT  TO PAY PRO VIDER
  4249   "RTN","CH8 35F3",224, 0)
  4250    ;                     15 - PATI ENT PAID A MT
  4251   "RTN","CH8 35F3",225, 0)
  4252    ;                     16 - # OF  UNITS
  4253   "RTN","CH8 35F3",226, 0)
  4254    ;                     17 - # AC CEPTED UNI TS
  4255   "RTN","CH8 35F3",227, 0)
  4256    ;                     18 - CITI  MAX RATE  - POPULATE D IN CHFBC 8A
  4257   "RTN","CH8 35F3",228, 0)
  4258    ;                                           19 - SPAR E
  4259   "RTN","CH8 35F3",229, 0)
  4260    ;                                           20 - # OF  UNITS FOR  WHICH HAC  PAID $$
  4261   "RTN","CH8 35F3",230, 0)
  4262    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  4263   "RTN","CH8 35F3",231, 0)
  4264    ; SVCLVL( LINE#)=P1. ..
  4265   "RTN","CH8 35F3",232, 0)
  4266    ;   LINE: is the edi  associate d line # o r "NA" if  this field  is blank
  4267   "RTN","CH8 35F3",233, 0)
  4268    ;   CODE: is the ext ernal code  value fro m HCPCS,IC D9...
  4269   "RTN","CH8 35F3",234, 0)
  4270    ;      P1 -Service C ode
  4271   "RTN","CH8 35F3",235, 0)
  4272    ;       P 2-Procedur e Descript ion
  4273   "RTN","CH8 35F3",236, 0)
  4274    ;       P 3-Service  Qualifier
  4275   "RTN","CH8 35F3",237, 0)
  4276    ;       P 4-Modifier 1
  4277   "RTN","CH8 35F3",238, 0)
  4278    ;       P 5-Rev Code
  4279   "RTN","CH8 35F3",239, 0)
  4280    ;       P 6-Charge A mount
  4281   "RTN","CH8 35F3",240, 0)
  4282    ;       P 7-PAID AMO UNT  ;  Al lowable Am ount
  4283   "RTN","CH8 35F3",241, 0)
  4284    ;       P 8-Paid amo unt
  4285   "RTN","CH8 35F3",242, 0)
  4286    ;       P 9-Reject A MT
  4287   "RTN","CH8 35F3",243, 0)
  4288    ;       P 10-Units
  4289   "RTN","CH8 35F3",244, 0)
  4290    ;       P 11-Units P aid
  4291   "RTN","CH8 35F3",245, 0)
  4292    ;       P 12-Reject  Units
  4293   "RTN","CH8 35F3",246, 0)
  4294    ;       P 13-Reject  Code
  4295   "RTN","CH8 35F3",247, 0)
  4296    ;                P14 -Line Item  Control N umber            6/6/ 2012  DLB  ADDED LINE  ITEM CONT ROL NUMBER  TO SVCLVL ()
  4297   "RTN","CH8 35F3",248, 0)
  4298    ;.I CLMLV L("TOTALLO W")>CLMLVL ("BILLAMT" ) D  Q
  4299   "RTN","CH8 35F3",249, 0)
  4300    ;..S CAS( TMPI,0,"OA ",68)=(CLM LVL("BILLA MT")-CLMLV L("VPYMT") )            ; ADJUST MENT RECOR D FOR VEND OR PAYMENT
  4301   "RTN","CH8 35F3",250, 0)
  4302    ;.I CLMLV L("DEDAMT" )>0 S CAS( TMPI,0,"PR ",1)=CLMLV L("DEDAMT" )            ; ADJUST MENT RECOR D FOR DEDU CTIBLE
  4303   "RTN","CH8 35F3",251, 0)
  4304    ;.I CLMLV L("CSHRAMT ")>0 S CAS (TMPI,0,"P R",3)=CLML VL("CSHRAM T")          ; ADJUST MENT RECOR D FOR COST  SHARE
  4305   "RTN","CH8 35F3",252, 0)
  4306    ;.I CLMLV L("BENEPD" )>0 S CAS( TMPI,0,"OA ",100)=CLM LVL("BENEP D")          ; ADJUST MENT RECOR D FOR BENE  PMT RECEI VED
  4307   "RTN","CH8 35F3",253, 0)
  4308    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  4309   "RTN","CH8 35F3",254, 0)
  4310    ;^TMP($J, "IMG2PAY", PAYI,IMGL) =CVGCODE_" ^"_AIRSN_" ^"_UNITCNT _"^"_SERVI _"^"_UNITC HG_"^"_UNI TCOST_"^"_ UNITACCPT_ "^"_UNITAL LW_"^"_URE JAMT
  4311   "RTN","CH8 35F3",255, 0)
  4312    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  4313   "RTN","CH8 35F3",256, 0)
  4314    ; 3/27/13   DLB ADDE D TEST FOR  HAC DENIA L
  4315   "RTN","CH8 35F3",257, 0)
  4316    ; IF THE  CO45 CALCU LATED AMOU NT IS EQUA L TO LINE  CHARGE AMO UNT, DO NO T GENERATE  CO-45 REC ORD
  4317   "RTN","CH8 35F3",258, 0)
  4318    ; IF THE  CO45 CALCU LATED AMOU NT IS EQUA L TO 0, DO  NOT GENER ATE CO-45  RECORD
  4319   "RTN","CH8 35F3",259, 0)
  4320    ; IF THE  CALCULATED  CO45 VALU E IS >0 -A ND- <LINE  CHARGE AMO UNT  -AND-  THE ALLOW EDAMT>OR=0
  4321   "RTN","CH8 35F3",260, 0)
  4322    ;    GENE RATE CO-45  RECORDS 
  4323   "RTN","CH8 35F3",261, 0)
  4324    ; 6/6/13  DLB SUM TH E AMOUNT F OR THE "PR " ADJUSTME NTS AND RE TURN AMT T O CALLER
  4325   "RTN","CH8 35F3",262, 0)
  4326    ; 6/6/13  DLB CHANGE D THE OA-2 3 AMOUNT T O BE GENER ATED FOR R EJ AND NON -REJ CLAIM S
  4327   "RTN","CH8 35F3",263, 0)
  4328    ; 6/7/13  DLB REMOVE D THE OA-6 8 ADJUSTME NT GENERAT ION PER BU SINESS: "T he code 68  was deact ivated in  2003."
  4329   "RTN","CH8 35F3",264, 0)
  4330    ; 7/30/20 13  DLB  A DDED SETTI NG GRP AND  RSN CODES  TO "ZZ" I F THE DICT IONARIES D O NOT POPU LATE VARIA BLES
  4331   "RTN","CH8 35F3",265, 0)
  4332    ; 10/16/2 014 DLB  M ODIFIED LI NES 299-30 0 TO CORRE CT THE CO: 45 ADJUSTM ENT IF THE  CLAIM WAS  REJECTED
  4333   "RTN","CH8 35F3",266, 0)
  4334    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  4335   "RTN","CH8 35F3",267, 0)
  4336    ;
  4337   "RTN","CH8 35F3",268, 0)
  4338   SVC(IMGL,I 2PDATA,SOR TDATA,CLPI ,CAS,SVCTI ,CHQTY,EDI I)             ;line  level allo wance adju stment
  4339   "RTN","CH8 35F3",269, 0)
  4340    ; IMGL          CURR ENT WORKIN G ^CHMIMAG E(L) INDEX
  4341   "RTN","CH8 35F3",270, 0)
  4342    ; I2PDATA   UNIT LEV EL DATA FO R 835 REPO RTING
  4343   "RTN","CH8 35F3",271, 0)
  4344    ; SORTDAT A     LINE  $DATA (SU MMED FROM  UNIT DATA  IN SORT^CH FBCUTL)
  4345   "RTN","CH8 35F3",272, 0)
  4346    ; CLPI          INDE X FOR THE  CAS ARRAY  (BUILT IN  CH835F2.IN T)
  4347   "RTN","CH8 35F3",273, 0)
  4348    ; CAS           ARRA Y CONTAINI NG THE RES ULTS OF TH E ADJUSTME NTS
  4349   "RTN","CH8 35F3",274, 0)
  4350    ; SVCTI         SERV ICE LINE A DJUSTMENT  ARRAY INDE X
  4351   "RTN","CH8 35F3",275, 0)
  4352    ; CHQTY         QTY  VALUE FOR  THE SVC AD JUSTMENT S EGMENT(S)
  4353   "RTN","CH8 35F3",276, 0)
  4354    ; EDII      IEN TO T HE CURRENT  NODE IN ^ CHMEDI()
  4355   "RTN","CH8 35F3",277, 0)
  4356    ;
  4357   "RTN","CH8 35F3",278, 0)
  4358    N NETALLO W,STATUS,R EJI,CHGAMT ,ALLOWAMT, POHIPD,ADD OHIPD,ALLO HI,CO45AMT ,MDCAIDPD, TPLPD,HACP D,ALLPAID
  4359   "RTN","CH8 35F3",279, 0)
  4360    N DEDAMT, CSTSHR,BEN EPD,PROVPM T,PATRESP, OA23AMT,EN VIR
  4361   "RTN","CH8 35F3",280, 0)
  4362    N UNITSTA T,RJRSN,RE JAMT,DICI, DEF,GRP,RS N,OAB6
  4363   "RTN","CH8 35F3",281, 0)
  4364    I '$D(%DB G835) S %D BG835=($$E NVIR^CHTFL IB'="LIVE" )
  4365   "RTN","CH8 35F3",282, 0)
  4366    S (REJAMT ,CHGAMT,AL LOWAMT,PAT RESP,OA23A MT)=0
  4367   "RTN","CH8 35F3",283, 0)
  4368    S POHIPD= +$P(SORTDA TA,"^",1)                                       ; PRIM ARY OHI PA ID VALUE
  4369   "RTN","CH8 35F3",284, 0)
  4370    S ADDOHIP D=+$P(SORT DATA,"^",3 )                                    ; RETR IEVE ADDIT IONAL OHI  PAID AMOUN T
  4371   "RTN","CH8 35F3",285, 0)
  4372    S MDCAIDP D=+$P(SORT DATA,"^",5 )                                    ; MEDI CAID PAYME NTS RECEIV ED
  4373   "RTN","CH8 35F3",286, 0)
  4374    S TPLPD=+ $P(SORTDAT A,"^",6)                                        ; TPL  PAYMENTS R ECEIVED
  4375   "RTN","CH8 35F3",287, 0)
  4376    S DEDAMT= +$P(SORTDA TA,"^",9)                                       ; AMOU NT APPLIED  TO BENE D EDUCTIBLE
  4377   "RTN","CH8 35F3",288, 0)
  4378    S CSTSHR= +$P(SORTDA TA,"^",11)                                      ; BENE FICIARY CO ST SHARE
  4379   "RTN","CH8 35F3",289, 0)
  4380    S BENEPMT =+$P(SORTD ATA,"^",13 )                                    ; AMT  PAID TO BE NE
  4381   "RTN","CH8 35F3",290, 0)
  4382    S PROVPMT =+$P(SORTD ATA,"^",14 )                                    ; AMT  PAID TO PR OVIDER
  4383   "RTN","CH8 35F3",291, 0)
  4384    S HACPD=+ $P(SORTDAT A,"^",12)                                       ; ADJU DICATED PA YMENT AMOU NT
  4385   "RTN","CH8 35F3",292, 0)
  4386    S ALLOHI= POHIPD+ADD OHIPD                                                    ; GET OH I TOTAL PA ID
  4387   "RTN","CH8 35F3",293, 0)
  4388    S ALLPAID =(ALLOHI+M DCAIDPD+TP LPD+HACPD+ DEDAMT+CST SHR) ; TOT AL ALL PAY MENTS RECE IVED + AMT  HAC PAID
  4389   "RTN","CH8 35F3",294, 0)
  4390    I $G(%DBG 835) U 0 W  !,"   F3: SVC: ALLPA ID (",ALLP AID,")= SO RTDATA VAL UES: ALLOH I + MDCAID PD + TPLPD  + HACPD +  DEDAMT +  CSTSHR"
  4391   "RTN","CH8 35F3",295, 0)
  4392    I $G(%DBG 835) U 0 W  !,"   F3: SVC: ALLPA ID (",ALLP AID,")= ", ALLOHI,"+" ,MDCAIDPD, "+",TPLPD, "+",HACPD, "+",DEDAMT ,"+",CSTSH R
  4393   "RTN","CH8 35F3",296, 0)
  4394    S CHGAMT= +$P(SORTDA TA,"^",8)                                       ; LINE  CHARGE FR OM SORT^CH FBCUTL
  4395   "RTN","CH8 35F3",297, 0)
  4396    I $G(%DBG 835) U 0 W  !,"   F3: SVC: BILLE D AMT= ",C HGAMT
  4397   "RTN","CH8 35F3",298, 0)
  4398    S ALLOWAM T=+$P(SORT DATA,"^",7 )                                    ; ALLO WED AMOUNT  FROM SORT ^CHFBCUTL
  4399   "RTN","CH8 35F3",299, 0)
  4400    S CO45AMT =CHGAMT-AL LPAID                                                    ; LINE L EVEL CONTR ACTUAL OBL IGATION AD JUSTMENT A MOUNT
  4401   "RTN","CH8 35F3",300, 0)
  4402    I $G(%DBG 835) U 0 W  !,"   F3: SVC: CO45A MT (",CO45 AMT,") = C HGAMT ",CH GAMT,"- AL LPAID ",AL LPAID
  4403   "RTN","CH8 35F3",301, 0)
  4404    S UNITSTA T=$P(I2PDA TA,"^",1)                                       ; UNIT  STATUS VA LUE (0=REJ ECT)
  4405   "RTN","CH8 35F3",302, 0)
  4406    S RJRSN=$ P(I2PDATA, "^",2)                                                   ; UNIT R EJECT REAS ON 
  4407   "RTN","CH8 35F3",303, 0)
  4408    I $G(%DBG 835) U 0 W  !,"   F3: SVC: RJRSN = ",RJRSN
  4409   "RTN","CH8 35F3",304, 0)
  4410    ;S REJAMT =$P(I2PDAT A,"^",9)                                                 ; UNIT R EJECT AMOU NT
  4411   "RTN","CH8 35F3",305, 0)
  4412    ;S:CO45AM T=CHGAMT C O45AMT=0                                                 ; CO45=C HGAMT ONLY  IF HAC DE NIAL OCCUR RED
  4413   "RTN","CH8 35F3",306, 0)
  4414    S:RJRSN'= "" REJAMT= $P(I2PDATA ,"^",9)                              ; REJE CT AMOUNT  IS TOTAL L INE CHARGE  IF REJECT ED  DLB 10 /16/2014
  4415   "RTN","CH8 35F3",307, 0)
  4416    S:CO45AMT =REJAMT CO 45AMT=0                                                           ; CO45AMT  IS ADJUSTE D ONLY IF  HAC DENIAL  OCCURRED  DLB 10/16/ 2014
  4417   "RTN","CH8 35F3",308, 0)
  4418    I (UNITST AT)&(DEDAM T>0)  D
  4419   "RTN","CH8 35F3",309, 0)
  4420    .S CAS(CL PI,IMGL,SV CTI,"PR",1 )=DEDAMT_" ^"_CHQTY                  ; POST  THE DEDUC TIBLE AMOU NT  DLB 4/ 17/13
  4421   "RTN","CH8 35F3",310, 0)
  4422    .S PATRES P=PATRESP+ DEDAMT                                                                    ;  DLB 6/6/20 13 TALLY T HE PATIENT  RESPONSIB ILITY $$
  4423   "RTN","CH8 35F3",311, 0)
  4424    .I $G(%DB G835) U 0  W !,"   F3 :SVC: WROT E PR:1 CAS (",CLPI,", ",IMGL,"," ,SVCTI,",P R,",1,")=" ,DEDAMT
  4425   "RTN","CH8 35F3",312, 0)
  4426    I (UNITST AT)&(CSTSH R>0)  D
  4427   "RTN","CH8 35F3",313, 0)
  4428    .S CAS(CL PI,IMGL,SV CTI,"PR",2 )=CSTSHR_" ^"_CHQTY                  ; POST  THE COST  SHARE AMOU NT  DLB 4/ 17/13
  4429   "RTN","CH8 35F3",314, 0)
  4430    .S PATRES P=PATRESP+ CSTSHR                                                                    ;  DLB 6/6/20 13 TALLY T HE PATIENT  RESPONSIB ILITY $$
  4431   "RTN","CH8 35F3",315, 0)
  4432    .I $G(%DB G835) U 0  W !,"   F3 :SVC: WROT E PR:2 CAS (",CLPI,", ",IMGL,"," ,SVCTI,",P R,",2,")=" ,CSTSHR
  4433   "RTN","CH8 35F3",316, 0)
  4434    I (UNITST AT)&(BENEP MT>0)  D                                                          ; BENE OVE RPAYMENT A DJUSTMENT
  4435   "RTN","CH8 35F3",317, 0)
  4436    .S CAS(CL PI,IMGL,SV CTI,"OA",1 00)=BENEPM T_"^"_CHQT Y              ; POST  THE BENE  PAYMENT AM OUNT DLB 4 /17/13
  4437   "RTN","CH8 35F3",318, 0)
  4438    .I $G(%DB G835) U 0  W !,"   F3 :WROTE OA: 100 CAS(", CLPI,",",I MGL,",",SV CTI,",OA," ,100,")=", BENEPMT,"  BENE OVERP AID= ",BEN EPMT
  4439   "RTN","CH8 35F3",319, 0)
  4440    I (ALLOHI '=0)  D                                           ; SE T 0A-23 CA S IF PRIMA RY OHIPD +  ADDITIONA L OHI PAID  AMOUNTS ' = 0
  4441   "RTN","CH8 35F3",320, 0)
  4442    .S CAS(CL PI,IMGL,SV CTI,"OA",2 3)=ALLOHI_ "^"_CHQTY                 ; POST  THE OHI P AID ADJUST MENT
  4443   "RTN","CH8 35F3",321, 0)
  4444    .I $G(%DB G835) U 0  W !,"   F3 :SVC: WROT E OA:23 CA S(",CLPI," ,",IMGL,", ",SVCTI,", OA,",23,") =",ALLOHI
  4445   "RTN","CH8 35F3",322, 0)
  4446    ;ERA Comp liance
  4447   "RTN","CH8 35F3",323, 0)
  4448    S OAB6=$$ LESS1^CH83 5F2(EDII)
  4449   "RTN","CH8 35F3",324, 0)
  4450    I UNITSTA T,+OAB6,PR OVPMT>0,PR OVPMT<1 D
  4451   "RTN","CH8 35F3",325, 0)
  4452    .S CAS(CL PI,IMGL,SV CTI,"OA",2 09)=PROVPM T_U_CHQTY
  4453   "RTN","CH8 35F3",326, 0)
  4454    .I $G(%DB G835) U 0  W !,"   F3 :SVC: WROT E OA:209 C AS(",CLPI, ",",IMGL," ,",SVCTI," ,OA,","209 ",")=",PRO VPMT
  4455   "RTN","CH8 35F3",327, 0)
  4456    ;
  4457   "RTN","CH8 35F3",328, 0)
  4458    I (UNITST AT)&(CO45A MT>0)&(ALL OWAMT>0) D                                    ; GENERA TE A CO-45  ADJUSTMEN T IF CHGAM T-ALL PAYM ENTS > 0
  4459   "RTN","CH8 35F3",329, 0)
  4460    .S CAS(CL PI,IMGL,SV CTI,"CO",4 5)=CO45AMT _"^"_CHQTY  
  4461   "RTN","CH8 35F3",330, 0)
  4462    .I $G(%DB G835) U 0  W !,"   F3 :SVC: WROT E CO:45 CA S(",CLPI," ,",IMGL,", ",SVCTI,", CO,",45,") =",CO45AMT  
  4463   "RTN","CH8 35F3",331, 0)
  4464    E  I ('UN ITSTAT)!(( CHGAMT>0)& (HACPD=0)& (ALLOWAMT= 0))  D         ; HAC  DENIAL/REJ ECT
  4465   "RTN","CH8 35F3",332, 0)
  4466    .I $G(%DB G835) U 0  W !,"   F3 :SVC: DENI AL RJRSN=  ",RJRSN
  4467   "RTN","CH8 35F3",333, 0)
  4468    .Q:+(RJRS N)=0                                                                ; WON'T  GENERATE C AS WITHOUT  REJECT RE ASON (ZERO  PAY; NOT  A REJECT)
  4469   "RTN","CH8 35F3",334, 0)
  4470    .S DICI=0 ,DICI=$O(^ CHMXDIC(74 1201.77,"B ",RJRSN,DI CI))           ; RETR IEVE THE S TATUS INDE X
  4471   "RTN","CH8 35F3",335, 0)
  4472    .S DEF=$G (^CHMXDIC( 741201.77, DICI,0))                                               ;U 0 W !,"    F3: DEN IAL DEF= " ,DEF
  4473   "RTN","CH8 35F3",336, 0)
  4474    .I $P(DEF ,"^",2)=""  S GRP="ZZ "                                                              ;  7/29/2013  FIX A NULL  INDEX FOR  GRP CODE
  4475   "RTN","CH8 35F3",337, 0)
  4476    .E  S GRP =$P($G(^CH MXDIC(7412 01.15,$P(D EF,"^",2), 0)),"^",1)     ;U 0 W  !,"   F3:  DENIAL GR P= ",GRP
  4477   "RTN","CH8 35F3",338, 0)
  4478    .I $P(DEF ,"^",3)=""  S RSN="ZZ "                                                              ;  7/29/2013  FIX A NULL  INDEX FOR  RSN CODE
  4479   "RTN","CH8 35F3",339, 0)
  4480    .E  S RSN =$P($G(^CH MXDIC(7412 01.16,$P(D EF,"^",3), 0)),"^",1)     ;U 0 W  !,"   F3:  DENIAL RS N= ",RSN
  4481   "RTN","CH8 35F3",340, 0)
  4482    .I ((CHGA MT-ALLOHI) '=0) D                                          ; 7/11 /2013  DLB  ADD CODE  TO INHIBIT  ADJ. RECO RDS WITH " 0" AMOUNT
  4483   "RTN","CH8 35F3",341, 0)
  4484    ..I (GRP= "ZZ")!(RSN ="ZZ") S C AS(CLPI,IM GL,SVCTI,G RP,RSN)=(C HGAMT)_"^" _CHQTY  ;  7/29/2013  DLB FORCE  BALANCE ER ROR
  4485   "RTN","CH8 35F3",342, 0)
  4486    ..E  S CA S(CLPI,IMG L,SVCTI,GR P,RSN)=(CH GAMT-ALLOH I)_"^"_CHQ TY  ; 6/6/ 13 DLB ADJ USTMENT RE FLECTS OHI  PAYMENTS  5.4.30b &  HAC PAID 5 .4.30c
  4487   "RTN","CH8 35F3",343, 0)
  4488    ..I $G(%D BG835) U 0  W !,"   F 3:SVC: WRO TE ",GRP," :",RSN," C AS(",CLPI, ",",IMGL," ,",SVCTI," ,",GRP,"," ,RSN,")=", (CHGAMT-AL LOHI)
  4489   "RTN","CH8 35F3",344, 0)
  4490    .I GRP="P R" S PATRE SP=PATRESP +(CHGAMT-A LLOHI)                             ; DLB 6/ 6/2013 TAL LY THE PAT IENT RESPO NSIBILITY  $$ 
  4491   "RTN","CH8 35F3",345, 0)
  4492    Q PATRESP
  4493   "RTN","CH8 35F3",346, 0)
  4494    ;
  4495   "RTN","CH8 35F3",347, 0)
  4496   INIT     ; Initialize s variable s for serv ice line
  4497   "RTN","CH8 35F3",348, 0)
  4498    ;S (SVCKE Y,SVCQUAL, PROC,MOD1, MOD2,MOD3, MOD4,PROCD ESC,CHGAMT ,PRVDPYMT) =""
  4499   "RTN","CH8 35F3",349, 0)
  4500    S (REVCD, UNITPAID,U NITSVC,DTM QUAL1,DTFL D1,DTMQUAL 2,DTFLD2,A DTLID)=""
  4501   "RTN","CH8 35F3",350, 0)
  4502    Q
  4503   "RTN","CH8 35F3",351, 0)
  4504    ;
  4505   "RTN","CH8 35F3",352, 0)
  4506    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  4507   "RTN","CH8 35F3",353, 0)
  4508    ; SORT(PA YI) IS A C LONE OF TH E BENE CAL C SORT ROU TINE, CHAN GED SLIGHT LY
  4509   "RTN","CH8 35F3",354, 0)
  4510    ; HERE TO  ENSURE TH AT AN INDE X ERROR BE TWEEN ^CHM PAY AND ^C HMIMAGE DO ES 
  4511   "RTN","CH8 35F3",355, 0)
  4512    ; NOT CRE ATE RECORD S THAT GO  OUT TO THE  835.
  4513   "RTN","CH8 35F3",356, 0)
  4514    ; THE ^CH MPAY "J" I NDEXES FOR  LOOPING A RE RETRIEV ED FROM TH
  4515   "RTN","CH8 35F3",357, 0)
  4516    ; ^TMP($J ,"IMGPAY", PAYI,PAYJ) =IMGL ARRA Y. 
  4517   "RTN","CH8 35F3",358, 0)
  4518    ; IMPLEME NTED THIS  LOCAL FUNC TION 7/31/ 2013
  4519   "RTN","CH8 35F3",359, 0)
  4520    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  4521   "RTN","CH8 35F3",360, 0)
  4522    ;
  4523   "RTN","CH8 35F3",361, 0)
  4524   SORT(CI)    ;
  4525   "RTN","CH8 35F3",362, 0)
  4526    ;CHMFTP -   TYPE OF  SERVICE
  4527   "RTN","CH8 35F3",363, 0)
  4528    ;CHMFTP=1  INPATINT
  4529   "RTN","CH8 35F3",364, 0)
  4530    ;CHMFTP=2  OUTPATIEN T
  4531   "RTN","CH8 35F3",365, 0)
  4532    ;CHMFTP=3  PHARMACY
  4533   "RTN","CH8 35F3",366, 0)
  4534    ;CHMFTP=4  DME
  4535   "RTN","CH8 35F3",367, 0)
  4536    ;CHMFTP=5  DENTAL
  4537   "RTN","CH8 35F3",368, 0)
  4538    ;CHMFTP=6  TRAVEL
  4539   "RTN","CH8 35F3",369, 0)
  4540    ;AAMT - U NIT LEVEL  ALLOWED AM T
  4541   "RTN","CH8 35F3",370, 0)
  4542    ;TMP($J," LINE",CI,S ORTV)  SOR TV LINE EN TRY IN ^CH MIMAGE OR  GROUP INDI CATOR FROM  CEU
  4543   "RTN","CH8 35F3",371, 0)
  4544    ;                     1  -  OHI  PAID
  4545   "RTN","CH8 35F3",372, 0)
  4546    ;                     2  - OHI  PATIENT RE SPON
  4547   "RTN","CH8 35F3",373, 0)
  4548    ;                     3  - ALL  OTHER OHI  PAYMENTS
  4549   "RTN","CH8 35F3",374, 0)
  4550    ;                     4  - OHI  OHI PR BAL ANCE
  4551   "RTN","CH8 35F3",375, 0)
  4552    ;                     5  - MEDI CAD PAYMEN TS
  4553   "RTN","CH8 35F3",376, 0)
  4554    ;                     6  - TPL
  4555   "RTN","CH8 35F3",377, 0)
  4556    ;                     7  - ALLO WED AMOUNT
  4557   "RTN","CH8 35F3",378, 0)
  4558    ;                     8  - BILL ED AMOUNT
  4559   "RTN","CH8 35F3",379, 0)
  4560    ;                     9  - DED  AMT
  4561   "RTN","CH8 35F3",380, 0)
  4562    ;                     10 - CAT  CAP AMT
  4563   "RTN","CH8 35F3",381, 0)
  4564    ;                     11 - COST  SHARE
  4565   "RTN","CH8 35F3",382, 0)
  4566    ;                     12 - AMT  TO PAY
  4567   "RTN","CH8 35F3",383, 0)
  4568    ;                     13 - AMT  TO PAY BEN E
  4569   "RTN","CH8 35F3",384, 0)
  4570    ;                     14 - AMT  TO PAY PRO VIDER
  4571   "RTN","CH8 35F3",385, 0)
  4572    ;                     15 - PATI ENT PAID A MT
  4573   "RTN","CH8 35F3",386, 0)
  4574    ;                     16 - # OF  UNITS
  4575   "RTN","CH8 35F3",387, 0)
  4576    ;                     17 - # AC CEPTED UNI TS
  4577   "RTN","CH8 35F3",388, 0)
  4578    ;                     18 - CITI  MAX RATE  - POPULATE D IN CHFBC 8A
  4579   "RTN","CH8 35F3",389, 0)
  4580    ;                                           19 - CHAR GE / UNIT   DLB 6/5/2 014
  4581   "RTN","CH8 35F3",390, 0)
  4582    ;                                           20 - # OF  UNITS WIT H HAC PAYM ENT
  4583   "RTN","CH8 35F3",391, 0)
  4584    S CHMFPP= "SCLINE" D  ^CHMFWK02
  4585   "RTN","CH8 35F3",392, 0)
  4586    ;U 0 W !, "CH835F3:  SORT: $J=  ",$J
  4587   "RTN","CH8 35F3",393, 0)
  4588    K SORTV K  ^TMP($J," LINE",CI)
  4589   "RTN","CH8 35F3",394, 0)
  4590    D LINEID^ CHTFLIB5(C I)                                                       ; CREATE  THE ^TMP( $J,"IMGPAY ",PAYI,PAY J)=IMGL AR RAY
  4591   "RTN","CH8 35F3",395, 0)
  4592    N REC,REC ,REC110,K2 ,JJJ,AAMT, BAMT,K3
  4593   "RTN","CH8 35F3",396, 0)
  4594    Q:'$D(^CH MPAY(CI,0) )
  4595   "RTN","CH8 35F3",397, 0)
  4596    F K2="OPT -PROC","DE N-PROC","D ME-SUPPLY" ,"PHARM" D
  4597   "RTN","CH8 35F3",398, 0)
  4598    .S JJJ=0  F  S JJJ=$ O(^TMP($J, "IMGPAY",C I,JJJ)) Q: 'JJJ  Q:^T MP($J,"IMG PAY",CI,JJ J)="*"  D                 ; USE  THE "J" IN DEXES FROM  THE LINEI D() ARRAY
  4599   "RTN","CH8 35F3",399, 0)
  4600    ..Q:'$D(^ CHMPAY(CI, K2,JJJ,0))
  4601   "RTN","CH8 35F3",400, 0)
  4602    ..S REC=^ CHMPAY(CI, K2,JJJ,0) 
  4603   "RTN","CH8 35F3",401, 0)
  4604    ..Q:'$D(^ CHMPAY(CI, K2,JJJ,1,1 ,0))
  4605   "RTN","CH8 35F3",402, 0)
  4606    ..S REC11 0=^CHMPAY( CI,K2,JJJ, 1,1,0) 
  4607   "RTN","CH8 35F3",403, 0)
  4608    ..S SORTV =^TMP($J," IMGPAY",CI ,JJJ) Q:SO RTV=""                                      ; DLB  8/2 /2013 SORT V VALUE FR OM JASON'S  SORT
  4609   "RTN","CH8 35F3",404, 0)
  4610    ..I '$D(^ TMP($J,"LI NE",CI,SOR TV)) S ^TM P($J,"LINE ",CI,SORTV )="^^^^^^" ,$P(^TMP($ J,"LINE",C I,SORTV)," ^",20)=0
  4611   "RTN","CH8 35F3",405, 0)
  4612    ..S:$P(RE C110,"^",1 )'="" $P(^ TMP($J,"LI NE",CI,SOR TV),"^",1) =$P(^TMP($ J,"LINE",C I,SORTV)," ^",1)+$P(R EC110,"^", 1)  ;OHI P AID
  4613   "RTN","CH8 35F3",406, 0)
  4614    ..S:$P(RE C110,"^",2 )'="" $P(^ TMP($J,"LI NE",CI,SOR TV),"^",2) =$P(^TMP($ J,"LINE",C I,SORTV)," ^",2)+$P(R EC110,"^", 2)  ;OHI P ATIENT RES PON
  4615   "RTN","CH8 35F3",407, 0)
  4616    ..S:$P(RE C110,"^",3 )'="" $P(^ TMP($J,"LI NE",CI,SOR TV),"^",3) =$P(^TMP($ J,"LINE",C I,SORTV)," ^",3)+$P(R EC110,"^", 3)  ;ALL O THER OHI P AYMENTS
  4617   "RTN","CH8 35F3",408, 0)
  4618    ..S:$P(RE C110,"^",4 )'="" $P(^ TMP($J,"LI NE",CI,SOR TV),"^",4) =$P(^TMP($ J,"LINE",C I,SORTV)," ^",4)+$P(R EC110,"^", 4)  ;OHI P R BALANCE
  4619   "RTN","CH8 35F3",409, 0)
  4620    ..S:$P(RE C110,"^",5 )'="" $P(^ TMP($J,"LI NE",CI,SOR TV),"^",5) =$P(^TMP($ J,"LINE",C I,SORTV)," ^",5)+$P(R EC110,"^", 5)  ;MEDIC AD PAYMENT S
  4621   "RTN","CH8 35F3",410, 0)
  4622    ..S:$P(RE C110,"^",6 )'="" $P(^ TMP($J,"LI NE",CI,SOR TV),"^",6) =$P(^TMP($ J,"LINE",C I,SORTV)," ^",6)+$P(R EC110,"^", 6)  ;TPL
  4623   "RTN","CH8 35F3",411, 0)
  4624    ..S:$P(RE C110,"^",1 0)'="" $P( ^TMP($J,"L INE",CI,SO RTV),"^",9 )=$P(^TMP( $J,"LINE", CI,SORTV), "^",9)+$P( REC110,"^" ,10)  ;DED
  4625   "RTN","CH8 35F3",412, 0)
  4626    ..S:$P(RE C110,"^",1 4)'="" $P( ^TMP($J,"L INE",CI,SO RTV),"^",1 0)=$P(^TMP ($J,"LINE" ,CI,SORTV) ,"^",10)+$ P(REC110," ^",14)  ;C AT CAP
  4627   "RTN","CH8 35F3",413, 0)
  4628    ..S:$P(RE C110,"^",1 1)'="" $P( ^TMP($J,"L INE",CI,SO RTV),"^",1 1)=$P(^TMP ($J,"LINE" ,CI,SORTV) ,"^",11)+$ P(REC110," ^",11)  ;C OST SHARE
  4629   "RTN","CH8 35F3",414, 0)
  4630    ..S:$P(RE C110,"^",1 2)'="" $P( ^TMP($J,"L INE",CI,SO RTV),"^",1 2)=$P(^TMP ($J,"LINE" ,CI,SORTV) ,"^",12)+$ P(REC110," ^",12)  ;c lm amt to  pay
  4631   "RTN","CH8 35F3",415, 0)
  4632    ..S:$P(RE C110,"^",1 6)'="" $P( ^TMP($J,"L INE",CI,SO RTV),"^",1 3)=$P(^TMP ($J,"LINE" ,CI,SORTV) ,"^",13)+$ P(REC110," ^",16)  ;b ene amt to  pay
  4633   "RTN","CH8 35F3",416, 0)
  4634    ..S:$P(RE C110,"^",1 5)'="" $P( ^TMP($J,"L INE",CI,SO RTV),"^",1 4)=$P(^TMP ($J,"LINE" ,CI,SORTV) ,"^",14)+$ P(REC110," ^",15)  ;v endor amt  to pay
  4635   "RTN","CH8 35F3",417, 0)
  4636    ..S:$P(RE C110,"^",1 3)'="" $P( ^TMP($J,"L INE",CI,SO RTV),"^",1 5)=$P(^TMP ($J,"LINE" ,CI,SORTV) ,"^",15)+$ P(REC110," ^",13)  ;B ENE PAID A MT
  4637   "RTN","CH8 35F3",418, 0)
  4638    ..S $P(^T MP($J,"LIN E",CI,SORT V),"^",16) =$P(^TMP($ J,"LINE",C I,SORTV)," ^",16)+1   ;COUNT# OF  UNITS
  4639   "RTN","CH8 35F3",419, 0)
  4640    ..S $P(^T MP($J,"LIN E",CI,SORT V),"^",19) =+($P(REC1 10,"^",7))                                        ; CO ST/UNIT VA LUE  DLB 6 /5/2014
  4641   "RTN","CH8 35F3",420, 0)
  4642    ..I K2="O PT-PROC" D
  4643   "RTN","CH8 35F3",421, 0)
  4644    ...S AAMT =$S($P(REC ,"^",5)'=" ":$P(REC," ^",5),1:$P (REC,"^",3 ))  ; dete rmine allo wed amount  or adjust ed allowed  amount
  4645   "RTN","CH8 35F3",422, 0)
  4646    ...S BAMT =$P(REC,"^ ",2)
  4647   "RTN","CH8 35F3",423, 0)
  4648    ..I K2="P HARM" D
  4649   "RTN","CH8 35F3",424, 0)
  4650    ...S AAMT =$S($P(REC ,"^",10)'= "":$P(REC, "^",10),1: $P(REC,"^" ,5))  ; de termine al lowed amou nt or adju sted allow ed amount
  4651   "RTN","CH8 35F3",425, 0)
  4652    ...S BAMT =$P(REC,"^ ",4)
  4653   "RTN","CH8 35F3",426, 0)
  4654    ..I K2="D ME-SUPPLY"  D
  4655   "RTN","CH8 35F3",427, 0)
  4656    ...S AAMT =$S($P(REC ,"^",5)'=" ":$P(REC," ^",5),1:$P (REC,"^",4 ))  ; dete rmine allo wed amount  or adjust ed allowed  amount
  4657   "RTN","CH8 35F3",428, 0)
  4658    ...S BAMT =$P(REC,"^ ",2)
  4659   "RTN","CH8 35F3",429, 0)
  4660    ..I K2="D EN-PROC" D
  4661   "RTN","CH8 35F3",430, 0)
  4662    ...S AAMT =$S($P(REC ,"^",7)'=" ":$P(REC," ^",7),1:$P (REC,"^",5 ))  ; dete rmine allo wed amount  or adjust ed allowed  amount
  4663   "RTN","CH8 35F3",431, 0)
  4664    ...S BAMT =$P(REC,"^ ",2)
  4665   "RTN","CH8 35F3",432, 0)
  4666    ..S $P(^T MP($J,"LIN E",CI,SORT V),"^",8)= $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",8)+BAMT  ;BILLED AM T
  4667   "RTN","CH8 35F3",433, 0)
  4668    ..I '$$IS REJ^CHTFLI B2(CI,K2,J JJ) I AAMT '="" S $P( ^TMP($J,"L INE",CI,SO RTV),"^",7 )=$P(^TMP( $J,"LINE", CI,SORTV), "^",7)+AAM T  ;ALLOWE D AMOUNT
  4669   "RTN","CH8 35F3",434, 0)
  4670    ..I '$$IS REJ^CHTFLI B2(CI,K2,J JJ) S $P(^ TMP($J,"LI NE",CI,SOR TV),"^",17 )=$P(^TMP( $J,"LINE", CI,SORTV), "^",17)+1  ;# UNITS A CCEPTED
  4671   "RTN","CH8 35F3",435, 0)
  4672    ..I '$$IS REJ^CHTFLI B2(CI,K2,J JJ)&($P(RE C110,"^",1 2)>0) S $P (^TMP($J," LINE",CI,S ORTV),"^", 20)=$P(^TM P($J,"LINE ",CI,SORTV ),"^",20)+ 1 ; DLB 6/ 6/2013 # U NITS W/HAC  PMT
  4673   "RTN","CH8 35F3",436, 0)
  4674    Q 
  4675   "RTN","CH8 35F3",437, 0)
  4676    ;
  4677   "RTN","CH8 35F3",438, 0)
  4678    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  4679   "RTN","CH8 35F3",439, 0)
  4680    ; SVCCASL () LOADS A LL CAS REC ORDS FOR S ERVICE LIN E LEVEL AN D CREATES  THE
  4681   "RTN","CH8 35F3",440, 0)
  4682    ; SVCCASL  RECORDS I N THE ^TMP ($J,"EDI-C REATE","SV CCAS" ARRA Y. THE IND EXES:
  4683   "RTN","CH8 35F3",441, 0)
  4684    ; "CLPI"  TIES THIS  SVCCAS REC ORD TO A C LAIM
  4685   "RTN","CH8 35F3",442, 0)
  4686    ; "SVCTI"  TIES THIS  SVCCAS RE CORD TO A  LINE ITEM
  4687   "RTN","CH8 35F3",443, 0)
  4688    ; "SVCCAS I" IS THE  COUNT FOR  THE NUMBER  OF SVCCAS  RECORDS F OR THE LIN E ITEM
  4689   "RTN","CH8 35F3",444, 0)
  4690    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  4691   "RTN","CH8 35F3",445, 0)
  4692    ;
  4693   "RTN","CH8 35F3",446, 0)
  4694   SVCCASL(CL PI,LN,SVCT I,PAYI,CHQ TY) 
  4695   "RTN","CH8 35F3",447, 0)
  4696    ; CLPI          CLP  INDEX FOR  CLP,CLPCAS ,SVC,SVCCA S RECORDS
  4697   "RTN","CH8 35F3",448, 0)
  4698    ; LN            IMAG E LINE POI NTS TO CAS  RECORD
  4699   "RTN","CH8 35F3",449, 0)
  4700    ; SVCTI         SVC  INDEX SVC, SVCCAS REC ORDS
  4701   "RTN","CH8 35F3",450, 0)
  4702    ; PAYI          ^CHM PAY(I) IND EX
  4703   "RTN","CH8 35F3",451, 0)
  4704    ;U 0 W !, "F3:SVCCAS L: INPUT:  CLPI: ",CL PI,"  LN:" ,LN,"  SVC CTI:",SVCT I,"  SVCCA SI:",SVCCA SI,"  CLML VL FOR REC ORD GEN"
  4705   "RTN","CH8 35F3",452, 0)
  4706    N GRP,LIN E,RSN,SVCC ASI
  4707   "RTN","CH8 35F3",453, 0)
  4708    S GRP="", SVCCASI=0
  4709   "RTN","CH8 35F3",454, 0)
  4710    F  S GRP= $O(CAS(CLP I,LN,SVCTI ,GRP)) Q:G RP=""  D         ; GR P IS THE S ECOND LEVE L INDEX FO R CAS ARRA Y
  4711   "RTN","CH8 35F3",455, 0)
  4712    .S SVCCAS I=SVCCASI+ 1                                                                 ; INCREMEN T THE SVCC AS INDEX
  4713   "RTN","CH8 35F3",456, 0)
  4714    .S RSN=0, RSN=$O(CAS (CLPI,LN,S VCTI,GRP,R SN))             ; RS N IS THE T HIRD LEVEL  INDEX FOR  CAS ARRAY
  4715   "RTN","CH8 35F3",457, 0)
  4716    .;U 0 W ! ," F3:SVCC ASL: CAS(" ,CLPI,",", LN,",",SVC TI,",",GRP ,")= ",CAS (CLPI,LN,S VCTI,GRP,R SN)
  4717   "RTN","CH8 35F3",458, 0)
  4718    .S SCASLN =$$SCASLN( CLPI,LN,SV CTI,GRP,CH QTY)
  4719   "RTN","CH8 35F3",459, 0)
  4720    .S REC=""
  4721   "RTN","CH8 35F3",460, 0)
  4722    .F LINE=1 :1 S STR=$ T(SVCCASTB +LINE) Q:S TR["END OF  RECORD"   D   ; USE  $TEXT "SVC CASTBL" TO  CREATE RE CORDS
  4723   "RTN","CH8 35F3",461, 0)
  4724    ..I LINE= 1 S REC=RE C_$$FORMAT DATA^CHMXW BUT(STR)    
  4725   "RTN","CH8 35F3",462, 0)
  4726    ..E  S RE C=REC_"^"_ $$FORMATDA TA^CHMXWBU T(STR)
  4727   "RTN","CH8 35F3",463, 0)
  4728    .S ^TMP($ J,"EDI_CRE ATE","SVCC AS",CLPI,S VCTI,SVCCA SI)=REC
  4729   "RTN","CH8 35F3",464, 0)
  4730    .;I $G(%D BG835) U 0  W !," F3:  SVCCASL:  ^TMP(",$J, ",""EDI_CR EATE"",""S VCCAS"",", CLPI,",",S VCTI,",",S VCCASI,")=  ",!,^TMP( $J,"EDI_CR EATE","SVC CAS",CLPI, SVCTI,SVCC ASI)
  4731   "RTN","CH8 35F3",465, 0)
  4732    Q 
  4733   "RTN","CH8 35F3",466, 0)
  4734    ;
  4735   "RTN","CH8 35F3",467, 0)
  4736   SCASLN(CLP I,LN,SVCTI ,GRP,QTY)    ;
  4737   "RTN","CH8 35F3",468, 0)
  4738    N X,RSN,V ALUES
  4739   "RTN","CH8 35F3",469, 0)
  4740    S X=""
  4741   "RTN","CH8 35F3",470, 0)
  4742    S RSN=""
  4743   "RTN","CH8 35F3",471, 0)
  4744    F  S RSN= $O(CAS(CLP I,LN,SVCTI ,GRP,RSN))  Q:RSN=""   D    ; RS N IS THE T HIRD LEVEL  INDEX FOR  CAS ARRAY
  4745   "RTN","CH8 35F3",472, 0)
  4746    .S VALUES =CAS(CLPI, LN,SVCTI,G RP,RSN)
  4747   "RTN","CH8 35F3",473, 0)
  4748    .;I $G(%D BG835) U 0  W !,"   F 3: SCASLN:  CLPI:",CL PI,"  LINE :",LN,"  S VCTI: ",SV CTI," GRP: ",GRP,"  R SN:",RSN,"   VALUES:" ,VALUES
  4749   "RTN","CH8 35F3",474, 0)
  4750    .S AMT=$P (VALUES,"^ ",1),QTY=$ P(VALUES," ^",2)
  4751   "RTN","CH8 35F3",475, 0)
  4752    .S:AMT=""  QTY=""
  4753   "RTN","CH8 35F3",476, 0)
  4754    .S X=X_RS N_":"_AMT_ ":"_QTY_"^ "
  4755   "RTN","CH8 35F3",477, 0)
  4756    Q X
  4757   "RTN","CH8 35F3",478, 0)
  4758    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  4759   "RTN","CH8 35F3",479, 0)
  4760    ; LQ() SE TS UP THE  PARAMETERS  AND CREAT ES THE SVC LQ RECORDS  FOR SERVI CE LINE
  4761   "RTN","CH8 35F3",480, 0)
  4762    ;S ^TMP($ J,"EDI_CRE ATE",SVCLQ ,TMPI,LN)= NFILE_"^"_ STSEQ_"^"_ CLMID_"^"_ CLMLVL("CL M")_"^"_LN _"^"_CDQUA L_"^"_REMC D
  4763   "RTN","CH8 35F3",481, 0)
  4764    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  4765   "RTN","CH8 35F3",482, 0)
  4766    ;
  4767   "RTN","CH8 35F3",483, 0)
  4768   LQ(PAYI,IM GL,NFILE,S TSEQ,CLMID ,REJCD,CLP I,TOS,SVCL INE) 
  4769   "RTN","CH8 35F3",484, 0)
  4770    ; PAYI          ^CHM PAY(I) IND EX
  4771   "RTN","CH8 35F3",485, 0)
  4772    ; IMGL          ^CHM IMAGE (L)  INDEX
  4773   "RTN","CH8 35F3",486, 0)
  4774    ; NFILE         FILE  NUMBER FO R RECORD
  4775   "RTN","CH8 35F3",487, 0)
  4776    ; STSEQ         SEQU ENCE NUMBE R FOR RECO RD
  4777   "RTN","CH8 35F3",488, 0)
  4778    ; CLMID         CLAI M ID VALUE  FOR RECOR D
  4779   "RTN","CH8 35F3",489, 0)
  4780    ; REJCD         REJE CT CODE FO R RECORD
  4781   "RTN","CH8 35F3",490, 0)
  4782    ; CLPI          INDE X INTO CAS  ARRAYS 
  4783   "RTN","CH8 35F3",491, 0)
  4784    ; TOS           TYPE  OF SERVIC E TO RETRI EVE REMARK S
  4785   "RTN","CH8 35F3",492, 0)
  4786    ; SVCLINE       LINE  NUMBER FO R SVC
  4787   "RTN","CH8 35F3",493, 0)
  4788    ;
  4789   "RTN","CH8 35F3",494, 0)
  4790    N REMARKS ,CDQUAL,RE MCD,LINE
  4791   "RTN","CH8 35F3",495, 0)
  4792    Q:+(REJCD )=0                                                                          ; NO REJEC T CODE, EX IT
  4793   "RTN","CH8 35F3",496, 0)
  4794    S CDQUAL= "HE"
  4795   "RTN","CH8 35F3",497, 0)
  4796    S:TOS="RX T" CDQUAL= "RX"
  4797   "RTN","CH8 35F3",498, 0)
  4798    I '$D(%DB G835) S %D BG835=($$E NVIR^CHTFL IB'="LIVE" )
  4799   "RTN","CH8 35F3",499, 0)
  4800    S REMARKS =$$REMARKS ^CH835FU1( TOS,REJCD)                  ; RE TRIEVE REM ARKS FOR T HE TYPE OF  SERVICE &  REJECT CO DE
  4801   "RTN","CH8 35F3",500, 0)
  4802    N REMCD1, REMCD2,REM 1FLG,SVCLQ
  4803   "RTN","CH8 35F3",501, 0)
  4804    S REMCD1= $P(REMARKS ,"^",1)
  4805   "RTN","CH8 35F3",502, 0)
  4806    S REMCD2= $P(REMARKS ,"^",2)
  4807   "RTN","CH8 35F3",503, 0)
  4808    I REMCD1= "",REMCD2= "" Q
  4809   "RTN","CH8 35F3",504, 0)
  4810    S SVCLQ=" SVCLQ1"
  4811   "RTN","CH8 35F3",505, 0)
  4812    S REM1FLG =0
  4813   "RTN","CH8 35F3",506, 0)
  4814    I REMCD1' ="" D                                                                        ; IF REMAR KS, GENERA TE LQ RECO RDS
  4815   "RTN","CH8 35F3",507, 0)
  4816    .S REMCD= REMCD1,REM 1FLG=1
  4817   "RTN","CH8 35F3",508, 0)
  4818    .S REC=""
  4819   "RTN","CH8 35F3",509, 0)
  4820    .F LINE=1 :1 S STR=$ T(SVCLQTB+ LINE) Q:ST R["END OF  RECORD"  D     ; USE  $TEXT "SVC LQTB" TO C REATE RECO RDS
  4821   "RTN","CH8 35F3",510, 0)
  4822    ..I LINE= 1 S REC=RE C_$$FORMAT DATA^CHMXW BUT(STR)    
  4823   "RTN","CH8 35F3",511, 0)
  4824    ..E  S RE C=REC_"^"_ $$FORMATDA TA^CHMXWBU T(STR)
  4825   "RTN","CH8 35F3",512, 0)
  4826    .S ^TMP($ J,"EDI_CRE ATE",SVCLQ ,CLPI,SVCL INE)=REC
  4827   "RTN","CH8 35F3",513, 0)
  4828    .I $G(%DB G835) U 0  W !,"F3: S VCLQ1: ^TM P($J,""EDI _CREATE"", ",SVCLQ,", ",CLPI,"," ,SVCLINE," )=",REC
  4829   "RTN","CH8 35F3",514, 0)
  4830    I REMCD2' ="",REMCD2 '=REMCD1 D                                                                         ; MU LTIPLE REM ARKS, GENE RATE ADD'L  LQ RECORD S
  4831   "RTN","CH8 35F3",515, 0)
  4832    .S REMCD= REMCD2
  4833   "RTN","CH8 35F3",516, 0)
  4834    .I REM1FL G S SVCLQ= "SVCLQ2"
  4835   "RTN","CH8 35F3",517, 0)
  4836    .S REC=""
  4837   "RTN","CH8 35F3",518, 0)
  4838    .F LINE=1 :1 S STR=$ T(SVCLQTB+ LINE) Q:ST R["END OF  RECORD"  D     ; USE  $TEXT "SVC LQTB" TO C REATE RECO RDS
  4839   "RTN","CH8 35F3",519, 0)
  4840    ..I LINE= 1 S REC=RE C_$$FORMAT DATA^CHMXW BUT(STR)    
  4841   "RTN","CH8 35F3",520, 0)
  4842    ..E  S RE C=REC_"^"_ $$FORMATDA TA^CHMXWBU T(STR)
  4843   "RTN","CH8 35F3",521, 0)
  4844    .S ^TMP($ J,"EDI_CRE ATE",SVCLQ ,CLPI,SVCL INE)=REC
  4845   "RTN","CH8 35F3",522, 0)
  4846    .I $G(%DB G835) U 0  W !,"F3: S VCLQ2: ^TM P($J,""EDI _CREATE"", ",SVCLQ,", ",CLPI,"," ,SVCLINE," )=",REC
  4847   "RTN","CH8 35F3",523, 0)
  4848    ; end 559 1 changes
  4849   "RTN","CH8 35F3",524, 0)
  4850    ;HR-PBM-P HASE 1B-En d
  4851   "RTN","CH8 35F3",525, 0)
  4852    Q
  4853   "RTN","CH8 35F3",526, 0)
  4854    ;
  4855   "RTN","CH8 35F3",527, 0)
  4856    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  4857   "RTN","CH8 35F3",528, 0)
  4858    ; IMG2PAY () CREATES  AN ARRAY  OF THE "UN ITS" IN ^C HMPAY LINK ED TO THE  LINE IN IM AGE
  4859   "RTN","CH8 35F3",529, 0)
  4860    ; THE FUN CTION RECE IVES THE ^ CHMPAY(I)  INDEX AND  THE "L" IN DEX TO ^CH MIMAGE()
  4861   "RTN","CH8 35F3",530, 0)
  4862    ; THE ^CH MIMAGE "L"  INDEX IS  RETURNED I N AEB'S SO RT FUNCTIO N: SORT^CH FBCUTL().
  4863   "RTN","CH8 35F3",531, 0)
  4864    ; THE PUR POSE OF TH IS FUNCTIO N IS TO "L INK" THE ^ CHMPAY AND  ^CHMIMAGE  FILES BAS ED
  4865   "RTN","CH8 35F3",532, 0)
  4866    ; ON THE  ^CHMPAY(I, SVC TYPE,J ,1,K,0) FI ELD 17 (PT R TO THE ^ CHMIMAGE F ILE AT THE
  4867   "RTN","CH8 35F3",533, 0)
  4868    ; "L" IND EX AT ^CHM IMAGE(I,1, J,2,K,SVC  TYPE,L,0).  
  4869   "RTN","CH8 35F3",534, 0)
  4870    ; THIS DA TA DESCRIB ES THE SVC  LEVEL AND  UNIT LEVE L SERVICES /PRICING/P AYMENT INF ORMATION.
  4871   "RTN","CH8 35F3",535, 0)
  4872    ; EACH ^C HMPAY(I) I NDEX CONTA INS DATA P ERTAINING  TO THE HAC  CLAIM NUM BER
  4873   "RTN","CH8 35F3",536, 0)
  4874    ; (^CHMPA Y(I,0), FI ELD 1), TH E "J" MULT IPLE CONTA INS SERVIC E LINE DAT A FOR THAT  CLAIM,
  4875   "RTN","CH8 35F3",537, 0)
  4876    ; AND THE  "K" INDEX  CONTAINS  OHI PAYMEN T DATA, IN CLUDING UN IT INFORMA TION. 
  4877   "RTN","CH8 35F3",538, 0)
  4878    ; IMG2PAY () LOOPS T HROUGH THE SE INDEXES , CREATING  AN ARRAY( I2PDATA) C ONTAINING  THE
  4879   "RTN","CH8 35F3",539, 0)
  4880    ; DATA LI NKED BETWE EN THE ^CH MPAY AND ^ CHMIMAGE F ILES. THIS  DATA IS U SED TO GEN ERATE
  4881   "RTN","CH8 35F3",540, 0)
  4882    ; THE SVC  RECORD, S VCCAS RECO RD AND SVC LQ RECORDS
  4883   "RTN","CH8 35F3",541, 0)
  4884    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  4885   "RTN","CH8 35F3",542, 0)
  4886    ; THE RES ULTING ARR AY (^TMP($ J,"IMG2PAY ",PAYI,IMG L)) CONTAI NS THE  UN IT LEVEL
  4887   "RTN","CH8 35F3",543, 0)
  4888    ; VALUES  FOR UNIT S TATUS_"^"_ UNIT REJ C ODE_"^"_UN IT CHARGE_ "^"_UNIT A LLOWED AMO UNT
  4889   "RTN","CH8 35F3",544, 0)
  4890    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  4891   "RTN","CH8 35F3",545, 0)
  4892    ; TEST FO R REJECT R EASON DETE RMINATION
  4893   "RTN","CH8 35F3",546, 0)
  4894    ; ..I $D( ^CHMPAY(PA YI,"RULE-P ROC",PAYJ) )  D
  4895   "RTN","CH8 35F3",547, 0)
  4896    ;...S CVG CODE=$P(^C HMPAY(PAYI ,"RULE-PRO C",PAYJ,0) ,"^",1)        ; UNIT  STATUS CO DE
  4897   "RTN","CH8 35F3",548, 0)
  4898    ;...S IDX =$P(^CHMPA Y(PAYI,"RU LE-PROC",P AYJ,0),"^" ,2)            ; REJE CT REASON  INDEX FROM  AI
  4899   "RTN","CH8 35F3",549, 0)
  4900    ;...S:IDX  AIRSN=$P( ^CHMDIC(74 1002.22,ID X,0),"^",1 )                       ; AI REJ ECT REASON  FROM DICT IONARY
  4901   "RTN","CH8 35F3",550, 0)
  4902    ;  7/31/2 013 DLB  A DDED CHECK  FOR THE ^ TMP($J,"IM GPAY",PAYI ,PAYJ)=IMG L. IF THE  VALUE CONT AINED 
  4903   "RTN","CH8 35F3",551, 0)
  4904    ;                        IN THE  ARRAY IS  A "*", IT  INDICATES  THAT AN IN DEXING ERR OR BETWEEN  ^CHMPAY()  AND ^CHMI MAGE()
  4905   "RTN","CH8 35F3",552, 0)
  4906    ;                                 EXISTS.
  4907   "RTN","CH8 35F3",553, 0)
  4908    ;
  4909   "RTN","CH8 35F3",554, 0)
  4910   IMG2PAY(PA YI,TOS) 
  4911   "RTN","CH8 35F3",555, 0)
  4912    ; PAYI                   ^CHMPA Y("I") IND EX
  4913   "RTN","CH8 35F3",556, 0)
  4914    ; TOS                    TYPE O F SERVICE
  4915   "RTN","CH8 35F3",557, 0)
  4916    N PAYJ,PA YK,PDI,PAY TOS,IMGTOS ,PAYJREC,P AYKREC,CVG CODE,AIRSN ,UNITCNT,S ERVI,UNITC HG,UNITCOS T,UNITACCP T
  4917   "RTN","CH8 35F3",558, 0)
  4918    N UNITALL W,UREJAMT, STATUS,RES ULT,IMGL,E XIT
  4919   "RTN","CH8 35F3",559, 0)
  4920    S (UREJAM T,UNITALLW ,UNITCHG,U NITACCPT,U NITCOST,UN ITCHG,UNIT CNT)=0,(CV GCODE,AIRS N,SERVI)=" "
  4921   "RTN","CH8 35F3",560, 0)
  4922    K ^TMP($J ,"IMG2PAY" )
  4923   "RTN","CH8 35F3",561, 0)
  4924    S ^TMP($J ,"IMG2PAY" ,PAYI,0,0) =CVGCODE_" ^"_AIRSN_" ^"_UNITCNT _"^"_SERVI _"^"_UNITC HG_"^"_UNI TCOST_"^"_ UNITACCPT_ "^"_UNITAL LW_"^"_URE JAMT 
  4925   "RTN","CH8 35F3",562, 0)
  4926    I '$D(^TM P($J,"IMGP AY",PAYI))   D                                                            ;  NEED THE A RRAY TO RE TRIEVE THE  ^CHMPAY()  "J" INDEX ES
  4927   "RTN","CH8 35F3",563, 0)
  4928    .;U 0 W:' LIVE !,"IM G2PAY():   ^TMP($J,"" IMGPAY""," ,PAYI,") M UST BE CRE ATED"
  4929   "RTN","CH8 35F3",564, 0)
  4930    .D LINEID ^CHTFLIB5( PAYI)                                                                              ; IF  NOT DEFIN ED, CREATE  THE ARRAY
  4931   "RTN","CH8 35F3",565, 0)
  4932    S PDI=$P( $P(^CHMPAY (PAYI,0)," ^",4),"*", 1)                                          ; CLAIM PD I
  4933   "RTN","CH8 35F3",566, 0)
  4934    S PAYTOS= $$GTPAYTOS (TOS)                                                                              ; TY PE OF SERV  FOR ^CHMP AY FILE
  4935   "RTN","CH8 35F3",567, 0)
  4936    S IMGTOS= $$GTIMGTOS (TOS)                                                                              ; TY PE OF SERV ICE FOR ^C HMIMAGE FI LE
  4937   "RTN","CH8 35F3",568, 0)
  4938    S PAYJ=0, PAYK=0,EXI T=0
  4939   "RTN","CH8 35F3",569, 0)
  4940    F  S PAYJ =$O(^TMP($ J,"IMGPAY" ,PAYI,PAYJ )) Q:(+(PA YJ)=0)!(EX IT)  D       ; GET TH E "J" INDE X FROM ^TM P ARRAY CR EATED IN S ORT()
  4941   "RTN","CH8 35F3",570, 0)
  4942    .;U 0 W:' LIVE !,"IM G2PAY():   ^TMP($J,"" IMGPAY""," ,PAYI,",", PAYJ,")= " ,^TMP($J," IMGPAY",PA YI,PAYJ)
  4943   "RTN","CH8 35F3",571, 0)
  4944    .S:^TMP($ J,"IMGPAY" ,PAYI,PAYJ )="*" EXIT =1
  4945   "RTN","CH8 35F3",572, 0)
  4946    .S IMGL=^ TMP($J,"IM GPAY",PAYI ,PAYJ)                                                 ; PTR TO ^ CHMIMAGE " L" NODE
  4947   "RTN","CH8 35F3",573, 0)
  4948    .S RESULT =$$REJ^CHT FLIB5(PAYI ,PAYJ)                                                 ; DETERMIN E IF REJEC T & RETRIE VE REJECT  REASON
  4949   "RTN","CH8 35F3",574, 0)
  4950    .S AIRSN= $P(RESULT, "^",1)                                                                             ; RE JECT REASO N RETURNED
  4951   "RTN","CH8 35F3",575, 0)
  4952    .S CVGCOD E=$P(RESUL T,"^",2)                                                                  ;  STATUS RET URNED
  4953   "RTN","CH8 35F3",576, 0)
  4954    .S PAYK=0 ,UREJAMT=0
  4955   "RTN","CH8 35F3",577, 0)
  4956    .F  S PAY K=$O(^CHMP AY(PAYI,PA YTOS,PAYJ, 1,PAYK)) Q :+(PAYK)=0   D
  4957   "RTN","CH8 35F3",578, 0)
  4958    ..S PAYJR EC=^CHMPAY (PAYI,PAYT OS,PAYJ,0)
  4959   "RTN","CH8 35F3",579, 0)
  4960    ..S PAYKR EC=^CHMPAY (PAYI,PAYT OS,PAYJ,1, PAYK,0)
  4961   "RTN","CH8 35F3",580, 0)
  4962    ..S IMGL= $P(PAYKREC ,"^",17)
  4963   "RTN","CH8 35F3",581, 0)
  4964    ..S UNITC NT=$S(TOS' ="RXT":$P( PAYJREC,"^ ",19),1:$P (PAYJREC," ^",6))       ; NUMBER  OF UNITS
  4965   "RTN","CH8 35F3",582, 0)
  4966    ..S SERVI =$P(PAYJRE C,"^",1)                                                 ; SERVIC E PROCEDUR E/RX NUMBE R
  4967   "RTN","CH8 35F3",583, 0)
  4968    ..S UNITC HG=$P(PAYJ REC,"^",2)                                               ; UNIT C HARGE
  4969   "RTN","CH8 35F3",584, 0)
  4970    ..S UNITC OST=$P(PAY KREC,"^",7 )                                             ; COST P ER UNIT
  4971   "RTN","CH8 35F3",585, 0)
  4972    ..S UNITA CCPT=$P(PA YKREC,"^", 8)                                            ; NUM UN ITS ALLOWE D
  4973   "RTN","CH8 35F3",586, 0)
  4974    ..S UNITA LLW=$S($P( PAYJREC,"^ ",5)>0:$P( PAYJREC,"^ ",5),1:$P( PAYJREC,"^ ",3))  ; A LLOWED/ADJ USTED ALLO WABLE
  4975   "RTN","CH8 35F3",587, 0)
  4976    ..S:AIRSN '="" UREJA MT=UNITCHG                                               ; REJECT ED AMOUNT  FOR THE UN IT
  4977   "RTN","CH8 35F3",588, 0)
  4978    ..S ^TMP( $J,"IMG2PA Y",PAYI,IM GL)=CVGCOD E_"^"_AIRS N_"^"_UNIT CNT_"^"_SE RVI_"^"_UN ITCHG_"^"_ UNITCOST_" ^"_UNITACC PT_"^"_UNI TALLW_"^"_ UREJAMT
  4979   "RTN","CH8 35F3",589, 0)
  4980    ..;U 0 W: 'LIVE !,"I MG2PAY:PAY J",PAYJ,"   TMP(",$J, ",",PAYI," ,",IMGL,") = ",^TMP($ J,"IMG2PAY ",PAYI,IMG L)
  4981   "RTN","CH8 35F3",590, 0)
  4982   I2PEND   
  4983   "RTN","CH8 35F3",591, 0)
  4984    Q 
  4985   "RTN","CH8 35F3",592, 0)
  4986    ;
  4987   "RTN","CH8 35F3",593, 0)
  4988    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  4989   "RTN","CH8 35F3",594, 0)
  4990    ; $TEXT T ABLES FOR  THE GENERA TION OF TH E 835 STAG ING FILE R ECORDS
  4991   "RTN","CH8 35F3",595, 0)
  4992    ; THE $TE XT TABLE S TARTS WITH  2 SEMICOL ONS ";;" T O INDICATE  TO THE CA CHE COMPIL ER
  4993   "RTN","CH8 35F3",596, 0)
  4994    ; THAT TH IS IS A TA BLE, NOT A  "COMMENT" .
  4995   "RTN","CH8 35F3",597, 0)
  4996    ; THE TAB LE DEFINIT ION FOR TH E FIELDS I S AS FOLLO WS:
  4997   "RTN","CH8 35F3",598, 0)
  4998    ; ;;"FIEL D NAME";"T ARGET VALU E";"LENGTH ";"JUSTIFY  FLAG";"PA D CHAR";"D ATA PATTER N";FIELD S TART LOCAT ION;FIELD  USE
  4999   "RTN","CH8 35F3",599, 0)
  5000    ; THIS FO RMAT UTILI ZES A COMM ON ROUTINE D TO FORMA T THE DATA  FOR THE R ECORD: I.E . FORMATDA TA(STR)
  5001   "RTN","CH8 35F3",600, 0)
  5002    ; WHERE " STR" IS TH E STRING F OR THE FIE LD AS READ  FROM THE  $TEXT TABL E.
  5003   "RTN","CH8 35F3",601, 0)
  5004    ; EXAMPLE  RECORD EN TRY IN THE  $TEXT TAB LE:
  5005   "RTN","CH8 35F3",602, 0)
  5006    ;
  5007   "RTN","CH8 35F3",603, 0)
  5008    ; [;;1.PA TIENT CONT ROL NUMBER ;$P(EREC0, "^",2);20; L;;;0;R;;  PATIENT CO NTROL NUMB ER]
  5009   "RTN","CH8 35F3",604, 0)
  5010    ; SEE CHM XWBUT.INT  FOR A FULL  DESCRITPI ON OF EACH  FIELD
  5011   "RTN","CH8 35F3",605, 0)
  5012    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  5013   "RTN","CH8 35F3",606, 0)
  5014    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  5015   "RTN","CH8 35F3",607, 0)
  5016    ; IN ORDE R TO MINIM IZE HITS O N THE DATA BASE, TWO  VARIABLES  (CHMPAYI0  AND CHMPAY I1)
  5017   "RTN","CH8 35F3",608, 0)
  5018    ; ARE USE D FOR ^CHM PAY(I,0) A ND ^CHMPAY (I,1) NODE S. THESE A RE THEN US ED TO EXTR ACT DATA 
  5019   "RTN","CH8 35F3",609, 0)
  5020    ; FOR THE  835 FIELD S. 
  5021   "RTN","CH8 35F3",610, 0)
  5022    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  5023   "RTN","CH8 35F3",611, 0)
  5024    ; 4/29/13   DLB MODI FIED CHARG E AMOUNT T O NOT ALLO W NULL VAL UE (NULL W ILL OUTPUT  0)
  5025   "RTN","CH8 35F3",612, 0)
  5026    ; 6/27/13   DLB MOD  SVC07 FIEL D OUTPUT:  IF ALLOWED  UNITS=UNI TS RECEIVE D OUTPUT " ", ELSE OU TPUT # UNI TS RECEIVE D
  5027   "RTN","CH8 35F3",613, 0)
  5028    ; 7/8/13    DLB REMO VED $S($P( SORTDATA," ^",16)=$P( SORTDATA," ^",17):"", 1:$P(SORTD ATA,"^",16 ));10;L;;1 0N;R;,
  5029   "RTN","CH8 35F3",614, 0)
  5030    ;                        CHANGE D BACK TO  ORIGINAL U NITS RECEI VED VALUE
  5031   "RTN","CH8 35F3",615, 0)
  5032    ; 7/17/20 13 DLB PER  BUSINESS,  WE PREFER  FIELD 20  FOR THE NU MBER OF UN ITS PAID.  DEVELOPMEN T
  5033   "RTN","CH8 35F3",616, 0)
  5034    ;                        WILL I NVESTIGATE  THE TALLY  FOR # OF  UNITS HAC  PAID.
  5035   "RTN","CH8 35F3",617, 0)
  5036    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  5037   "RTN","CH8 35F3",618, 0)
  5038    ; D DEBUG ^CH835DRV( "CH835F3:  SVCLVL("_L N_")= ",SV CLVL(LN))
  5039   "RTN","CH8 35F3",619, 0)
  5040    ; S ^TMP( $J,"EDI_CR EATE","SVC ",TMPI,SVC TI)=NFILE_ "^"_STSEQ_ "^"_CLMID_ "^"_$P(CLM LVL(1),"^" ,1)_"^"_LN _"^"_$P(SV CLVL(LN)," ^",1)_"^"_ $P(SVCLVL( LN),"^",3) _"^"_$P(SV CLVL(LN)," ^",4)_"^^^ ^"_$E($P(S VCLVL(LN), "^",2),1,8 0)
  5041   "RTN","CH8 35F3",620, 0)
  5042    ; S ^TMP( $J,"EDI_CR EATE","SVC ",TMPI,SVC TI)=^TMP($ J,"EDI_CRE ATE","SVC" ,TMPI,SVCT I)_"^"_$P( SVCLVL(LN) ,"^",7)_"^ "_$P(SVCLV L(LN),"^", 5)_"^"_$P( SVCLVL(LN) ,"^",11)_" ^"_$P(SVCL VL(LN),"^" ,10)_"^"_4 72_"^"_$$D TOUT^CH835 F)
  5043   "RTN","CH8 35F3",621, 0)
  5044    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  5045   "RTN","CH8 35F3",622, 0)
  5046    ; SORT RO UTINE ARRA Y FIELD IN DEX DEFINI TIONS
  5047   "RTN","CH8 35F3",623, 0)
  5048    ;                     1  - OHI  PAID
  5049   "RTN","CH8 35F3",624, 0)
  5050    ;                     2  - OHI  PATIENT RE SPON
  5051   "RTN","CH8 35F3",625, 0)
  5052    ;                     3  - ALL  OTHER OHI  PAYMENTS
  5053   "RTN","CH8 35F3",626, 0)
  5054    ;                     4  - OHI  OHI PR BAL ANCE
  5055   "RTN","CH8 35F3",627, 0)
  5056    ;                     5  - MEDI CAD PAYMEN TS
  5057   "RTN","CH8 35F3",628, 0)
  5058    ;                     6  - TPL
  5059   "RTN","CH8 35F3",629, 0)
  5060    ;                     7  - ALLO WED AMOUNT
  5061   "RTN","CH8 35F3",630, 0)
  5062    ;                     8  - BILL ED AMOUNT
  5063   "RTN","CH8 35F3",631, 0)
  5064    ;                     9  - DED  AMT
  5065   "RTN","CH8 35F3",632, 0)
  5066    ;                     10 - CAT  CAP AMT
  5067   "RTN","CH8 35F3",633, 0)
  5068    ;                     11 - COST  SHARE
  5069   "RTN","CH8 35F3",634, 0)
  5070    ;                     12 - AMT  TO PAY
  5071   "RTN","CH8 35F3",635, 0)
  5072    ;                     13 - AMT  TO PAY BEN E
  5073   "RTN","CH8 35F3",636, 0)
  5074    ;                     14 - AMT  TO PAY PRO VIDER
  5075   "RTN","CH8 35F3",637, 0)
  5076    ;                     15 - PATI ENT PAID A MT
  5077   "RTN","CH8 35F3",638, 0)
  5078    ;                     16 - # OF  UNITS
  5079   "RTN","CH8 35F3",639, 0)
  5080    ;                     17 - # AC CEPTED UNI TS
  5081   "RTN","CH8 35F3",640, 0)
  5082    ;                     18 - CITI  MAX RATE  - POPULATE D IN CHFBC 8A
  5083   "RTN","CH8 35F3",641, 0)
  5084    ;                                           19 - SPAR E
  5085   "RTN","CH8 35F3",642, 0)
  5086    ;                                           20 - # OF  UNITS FOR  WHICH HAC  PAID $$
  5087   "RTN","CH8 35F3",643, 0)
  5088    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  5089   "RTN","CH8 35F3",644, 0)
  5090    ;
  5091   "RTN","CH8 35F3",645, 0)
  5092   SVCTBL   ; ;"FIELD NA ME";"TARGE T VALUE";" LENGTH";"J USTIFY FLA G";"PAD CH AR";"DATA  PATTERN";F IELD USE
  5093   "RTN","CH8 35F3",646, 0)
  5094    ;;1.REC_I D;"SVC";3; L;;3A;0;R;
  5095   "RTN","CH8 35F3",647, 0)
  5096    ;;2.NEW_F ILE_AUTH_N BR;NFILE;2 0;L;;20AN; R;
  5097   "RTN","CH8 35F3",648, 0)
  5098    ;;3.NEW_S T02TXN_CTL _NBR;STSEQ ;9;L;;5N;R ;
  5099   "RTN","CH8 35F3",649, 0)
  5100    ;;4.HDR_C LM_ID;$$GT CLMID^CH83 5F3(PAYI,T OS);36;L;; 36AN;R;
  5101   "RTN","CH8 35F3",650, 0)
  5102    ;;5.PYR_C LM_NBR;$P( ^CHMPAY(PA YI,0),"^", 1);20;L;;2 0AN;R;
  5103   "RTN","CH8 35F3",651, 0)
  5104    ;;6.SVC_K EY;IMGL;10 ;L;;10N;R;
  5105   "RTN","CH8 35F3",652, 0)
  5106    ;;7.SVC01 PROC_CD;$S ((TOS'="RX T")&(SERVI '=""):$$PR OC^CH835FU 1($P(I2PDA TA,"^",4)) ,SERVI="": "X999",1:S ERVI);20;L ;;20AN;R; 
  5107   "RTN","CH8 35F3",653, 0)
  5108    ;;8.SVC01 SVC_ID_QUA L;$S((TOS' ="RXT")&(S ERVI'=""): $$SVCQUAL^ CH835FU1(S ERVI),1:"" );5;L;;5AN ;R;
  5109   "RTN","CH8 35F3",654, 0)
  5110    ;;9.SVC01 PROC_MOD1; $P(MODDATA ,"^",1);10 ;L;;10AN;R ;
  5111   "RTN","CH8 35F3",655, 0)
  5112    ;;10.SVC0 1PROC_MOD2 ;$P(MODDAT A,"^",2);1 0;L;;10AN; O;
  5113   "RTN","CH8 35F3",656, 0)
  5114    ;;11.SVC0 1PROC_MOD3 ;$P(MODDAT A,"^",3);1 0;L;;10AN; O;
  5115   "RTN","CH8 35F3",657, 0)
  5116    ;;12.SVC0 1PROC_MOD4 ;$P(MODDAT A,"^",4);1 0;L;;10AN; O;
  5117   "RTN","CH8 35F3",658, 0)
  5118    ;;13.SVC0 1PROC_CD_D ESC;$S((TO S'="RXT")& (SERVI'="" ):$$PROCDE SC^CH835FU 1(SERVI),1 :"");80;L; ;80AN;R;
  5119   "RTN","CH8 35F3",659, 0)
  5120    ;;14.SVC0 2CHRG_AMT; $S($P(SORT DATA,"^",8 )="":0,1:$ P(SORTDATA ,"^",8));2 0;L;;18.2F P;R;
  5121   "RTN","CH8 35F3",660, 0)
  5122    ;;15.SVC0 3PRVD_PMT; $S($P(SORT DATA,"^",1 4)="":0,$G (CAS(CLPI, IMGL,SVCTI ,"OA",209) ):0,1:$P(S ORTDATA,"^ ",14));20; L;;18.2FP; R;
  5123   "RTN","CH8 35F3",661, 0)
  5124    ;;16.SVC0 4NUBC_REVN U_CD;$S($P (IMGDATA," ^",2)="":" ",1:$P(^CH MXDIC(7412 01.39,$P(I MGDATA,"^" ,2),0),"^" ,1));20;L; ;18.2FP;R;
  5125   "RTN","CH8 35F3",662, 0)
  5126    ;;17.SVC0 5UNIT_SVC_ PAID;$S($P (SORTDATA, "^",20)="" :0,1:$P(SO RTDATA,"^" ,20));10;L ;;10N;R;
  5127   "RTN","CH8 35F3",663, 0)
  5128    ;;18.SVC0 7ORGNUNIT_ SVC;$S($P( SORTDATA," ^",16)="": 0,1:$P(SOR TDATA,"^", 16));10;L; ;10N;R;
  5129   "RTN","CH8 35F3",664, 0)
  5130    ;;19.DTM0 1DDTM_QUAL ;"472";5;L ;;5N;R;
  5131   "RTN","CH8 35F3",665, 0)
  5132    ;;20.DTM0 1DT_FLD;$$ DTOUT^CH83 5FU1($P(IM GDATA,"^", 1));8;L;;D ATE;R;
  5133   "RTN","CH8 35F3",666, 0)
  5134    ;;21.DDTM _QUAL;"";1 5;L;;15AN; R;
  5135   "RTN","CH8 35F3",667, 0)
  5136    ;;22.DT_F LD;"";15;L ;;15N;R;
  5137   "RTN","CH8 35F3",668, 0)
  5138    ;;23.ADTL _ID;LICTRL ;20;L;;20A N;R;
  5139   "RTN","CH8 35F3",669, 0)
  5140    ;;24.REND _ID;RENDNP I;20;L;;20 AN;R;
  5141   "RTN","CH8 35F3",670, 0)
  5142    ;;25.ALLO WED AMT;$S ($P(SORTDA TA,"^",7)= "":0,1:$P( SORTDATA," ^",7));20; L;;18.2FP; R;
  5143   "RTN","CH8 35F3",671, 0)
  5144    ;;END OF  RECORD
  5145   "RTN","CH8 35F3",672, 0)
  5146    ;
  5147   "RTN","CH8 35F3",673, 0)
  5148    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  5149   "RTN","CH8 35F3",674, 0)
  5150    ; SVCCASX  DESCRIBES  THE SVC L INE ADJUST MENTS. THI S TABLE RE PLACES THE  FOLLOWING  CODE:
  5151   "RTN","CH8 35F3",675, 0)
  5152    ; S ^TMP( $J,"EDI_CR EATE","SVC CAS",TMPI, SVCTI,SVCC TI)=NFILE_ "^"_STSEQ_ "^"_CLMID_ "^"_$P(CLM LVL(1),"^" ,1)_"^"_LN _"^"_GRP_" ^"_$P($P(S CASLN,"^", 1),";",1)_ "^"_$P($P( SCASLN,"^" ,1),";",2)
  5153   "RTN","CH8 35F3",676, 0)
  5154    ; S ^TMP( $J,"EDI_CR EATE","SVC CAS",TMPI, SVCTI,SVCC TI)=^TMP($ J,"EDI_CRE ATE","SVCC AS",TMPI,S VCTI,SVCCT I)_"^"_$P( $P(SCASLN, "^",2),";" ,1)_"^"_$P ($P(SCASLN ,"^",2),"; ",2)_"^"_$ P($P(SCASL N,"^",3)," ;",1)
  5155   "RTN","CH8 35F3",677, 0)
  5156    ; S ^TMP( $J,"EDI_CR EATE","SVC CAS",TMPI, SVCTI,SVCC TI)=^TMP($ J,"EDI_CRE ATE","SVCC AS",TMPI,S VCTI,SVCCT I)_"^"_$P( $P(SCASLN, "^",3),";" ,2)
  5157   "RTN","CH8 35F3",678, 0)
  5158    ; S ^TMP( $J,"EDI_CR EATE","SVC CAS",TMPI, SVCTI,SVCC TI)=^TMP($ J,"EDI_CRE ATE","SVCC AS",TMPI,S VCTI,SVCCT I)_"^"_$P( $P(SCASLN, "^",4),";" ,1)_"^"_$P ($P(SCASLN ,"^",4),"; ",2)_"^"_$ P($P(SCASL N,"^",5)," ;",1)
  5159   "RTN","CH8 35F3",679, 0)
  5160    ; S ^TMP( $J,"EDI_CR EATE","SVC CAS",TMPI, SVCTI,SVCC TI)=^TMP($ J,"EDI_CRE ATE","SVCC AS",TMPI,S VCTI,SVCCT I)_"^"_$P( $P(SCASLN, "^",5),";" ,2)_"^"_$P ($P(SCASLN ,"^",6),"; ",1)_"^"_$ P($P(SCASL N,"^",6)," ;",2)
  5161   "RTN","CH8 35F3",680, 0)
  5162    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  5163   "RTN","CH8 35F3",681, 0)
  5164    ;
  5165   "RTN","CH8 35F3",682, 0)
  5166   SVCCASTB ; ;"FIELD NA ME";"TARGE T VALUE";" LENGTH";"J USTIFY FLA G";"PAD CH AR";"DATA  PATTERN";F IELD USE
  5167   "RTN","CH8 35F3",683, 0)
  5168    ;;1.REC_I D;"SVCCAS" ;10;L;;10A ;0;R;
  5169   "RTN","CH8 35F3",684, 0)
  5170    ;;2.NEW_F ILE_AUTH_N BR;NFILE;2 0;L;;20AN; R;
  5171   "RTN","CH8 35F3",685, 0)
  5172    ;;3.NEW_S T02TXN_CTL _NBR;STSEQ ;9;L;;5N;R ;
  5173   "RTN","CH8 35F3",686, 0)
  5174    ;;4.HDR_C LM_ID;$$GT CLMID^CH83 5F3(PAYI,T OS);36;L;; 36AN;R;
  5175   "RTN","CH8 35F3",687, 0)
  5176    ;;5.PYR_C LM_NBR;$P( ^CHMPAY(PA YI,0),"^", 1);20;L;;2 0AN;R;
  5177   "RTN","CH8 35F3",688, 0)
  5178    ;;6.SVC_K EY;IMGL;10 ;L;;10N;R;
  5179   "RTN","CH8 35F3",689, 0)
  5180    ;;7.CLM_A DJ_GRP(CAS 01);GRP;5; L;;5N;R;
  5181   "RTN","CH8 35F3",690, 0)
  5182    ;;8.CLM A DJ RSN1(CA S02);$P($P (SCASLN,"^ ",1),":",1 );5;L;;5AN ;O;
  5183   "RTN","CH8 35F3",691, 0)
  5184    ;;9.CLM A DJ AMT1(CA S03);$P($P (SCASLN,"^ ",1),":",2 );20;L;;18 .2FP;O;
  5185   "RTN","CH8 35F3",692, 0)
  5186    ;;10.CLM  ADJ QTY1(C AS04);$P($ P(SCASLN," ^",1),":", 3);5;L;;5N ;O
  5187   "RTN","CH8 35F3",693, 0)
  5188    ;;11.CLM  ADJ RSN2(C AS05);$P($ P(SCASLN," ^",2),":", 1);5;L;;5A N;O;
  5189   "RTN","CH8 35F3",694, 0)
  5190    ;;12.CLM  ADJ_AMT2(C AS06);$P($ P(SCASLN," ^",2),":", 2);20;L;;1 8.2FP;O;
  5191   "RTN","CH8 35F3",695, 0)
  5192    ;;13.CLM  ADJ QTY1(C AS04);$P($ P(SCASLN," ^",2),":", 3);5;L;;5N ;O
  5193   "RTN","CH8 35F3",696, 0)
  5194    ;;14.CLM_ ADJ_RSN3(C AS08);$P($ P(SCASLN," ^",3),":", 1);5;L;;5A N;O;
  5195   "RTN","CH8 35F3",697, 0)
  5196    ;;15.CLM  ADJ_AMT3(C AS09);$P($ P(SCASLN," ^",3),":", 2);20;L;;1 8.2FP;O;
  5197   "RTN","CH8 35F3",698, 0)
  5198    ;;16.CLM  ADJ QTY1(C AS04);$P($ P(SCASLN," ^",3),":", 3);5;L;;5N ;O
  5199   "RTN","CH8 35F3",699, 0)
  5200    ;;17.CLM_ ADJ_RSN4(C AS11);$P($ P(SCASLN," ^",4),":", 1);5;L;;5A N;O;
  5201   "RTN","CH8 35F3",700, 0)
  5202    ;;18.CLM  ADJ_AMT4(C AS12);$P($ P(SCASLN," ^",4),":", 2);20;L;;1 8.2FP;O;
  5203   "RTN","CH8 35F3",701, 0)
  5204    ;;19.CLM  ADJ QTY1(C AS04);$P($ P(SCASLN," ^",4),":", 3);5;L;;5N ;O
  5205   "RTN","CH8 35F3",702, 0)
  5206    ;;20.CLM_ ADJ_RSN5(C AS14);$P($ P(SCASLN," ^",5),":", 1);5;L;;5A N;O;
  5207   "RTN","CH8 35F3",703, 0)
  5208    ;;21.CLM  ADJ_AMT5(C AS15);$P($ P(SCASLN," ^",5),":", 2);20;L;;1 8.2FP;O;
  5209   "RTN","CH8 35F3",704, 0)
  5210    ;;22.CLM  ADJ QTY1(C AS04);$P($ P(SCASLN," ^",5),":", 3);5;L;;5N ;O
  5211   "RTN","CH8 35F3",705, 0)
  5212    ;;23.CLM_ ADJ_RSN6(C AS17);$P($ P(SCASLN," ^",6),":", 1);5;L;;5A N;O;
  5213   "RTN","CH8 35F3",706, 0)
  5214    ;;24.CLM  ADJ_AMT6(C AS18);$P($ P(SCASLN," ^",6),":", 2);20;L;;1 8.2FP;O;
  5215   "RTN","CH8 35F3",707, 0)
  5216    ;;25.CLM  ADJ QTY1(C AS04);$P($ P(SCASLN," ^",6),":", 3);5;L;;5N ;O
  5217   "RTN","CH8 35F3",708, 0)
  5218    ;;END OF  RECORD
  5219   "RTN","CH8 35F3",709, 0)
  5220    ;
  5221   "RTN","CH8 35F3",710, 0)
  5222    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  5223   "RTN","CH8 35F3",711, 0)
  5224    ; SVCLQ T ABLE DEFIN ES THE LQ  RECORD. TH IS TABLE R EPLACES TH E FOLLOWIN G CODE:
  5225   "RTN","CH8 35F3",712, 0)
  5226    ; S ^TMP( $J,"EDI_CR EATE",SVCL Q,TMPI,LN) =NFILE_"^" _STSEQ_"^" _CLMID_"^" _HACCLM_"^ "_LN_"^"_C DQUAL_"^"_ REMCD
  5227   "RTN","CH8 35F3",713, 0)
  5228    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  5229   "RTN","CH8 35F3",714, 0)
  5230    ;
  5231   "RTN","CH8 35F3",715, 0)
  5232   SVCLQTB  ; ;"FIELD NA ME";"TARGE T VALUE";" LENGTH";"J USTIFY FLA G";"PAD CH AR";"DATA  PATTERN";F IELD USE
  5233   "RTN","CH8 35F3",716, 0)
  5234    ;;1.REC_I D;"SVCLQ"; 8;L;;8A;0; R;
  5235   "RTN","CH8 35F3",717, 0)
  5236    ;;2.NEW_F ILE_AUTH_N BR;NFILE;2 0;L;;20AN; R;
  5237   "RTN","CH8 35F3",718, 0)
  5238    ;;3.NEW_S T02TXN_CTL _NBR;STSEQ ;9;L;;5N;R ;
  5239   "RTN","CH8 35F3",719, 0)
  5240    ;;4.HDR_C LM_ID;$$GT CLMID^CH83 5F3(PAYI,T OS);36;L;; 36AN;R;
  5241   "RTN","CH8 35F3",720, 0)
  5242    ;;5.PYR_C LM_NBR(CLP 07);$P(^CH MPAY(PAYI, 0),"^",1); 20;L;;20AN ;R;
  5243   "RTN","CH8 35F3",721, 0)
  5244    ;;6.SVC_K EY;IMGL;10 ;L;;10N;R;
  5245   "RTN","CH8 35F3",722, 0)
  5246    ;;7.CD_QU AL(LQ01);C DQUAL;80;L ;;80AN;O;
  5247   "RTN","CH8 35F3",723, 0)
  5248    ;;8.RMK_C D(LQ02);RE MCD;80;L;; 80AN;O;
  5249   "RTN","CH8 35F3",724, 0)
  5250    ;;END OF  RECORD
  5251   "RTN","CH8 35F3",725, 0)
  5252    ;;***         
  5253   "RTN","CH8 35F3",726, 0)
  5254   TSTREJCD(G RPX,RSNX) 
  5255   "RTN","CH8 35F3",727, 0)
  5256    N REJCD,I ,EXIT,INFO GRP,RSN,RC H
  5257   "RTN","CH8 35F3",728, 0)
  5258    S I=0
  5259   "RTN","CH8 35F3",729, 0)
  5260    F REJCD=1 :1  Q:I=""   D
  5261   "RTN","CH8 35F3",730, 0)
  5262    .S I=$O(^ CHMXDIC(74 1201.77,"B ",REJCD,I) ) Q:+(I)=0
  5263   "RTN","CH8 35F3",731, 0)
  5264    .S INFO=^ CHMXDIC(74 1201.77,I, 0)
  5265   "RTN","CH8 35F3",732, 0)
  5266    .S GRP=$P (INFO,"^", 2) S:GRP'= "" GRP=$P( $G(^CHMXDI C(741201.1 5,GRP,0)), "^",1) 
  5267   "RTN","CH8 35F3",733, 0)
  5268    .S RSN=$P (INFO,"^", 3) S:RSN'= "" RSN=$P( $G(^CHMXDI C(741201.1 6,RSN,0)), "^",1)
  5269   "RTN","CH8 35F3",734, 0)
  5270    .I '$D(RS NX)  D
  5271   "RTN","CH8 35F3",735, 0)
  5272    ..I GRPX= GRP  D
  5273   "RTN","CH8 35F3",736, 0)
  5274    ...I $G(% DBG835) U  0 W !,"REJ CD:",REJCD ,"  I:",I, "  GRP:",G RP,"  RSN: ",RSN
  5275   "RTN","CH8 35F3",737, 0)
  5276    .E  I (GR PX=GRP)&(R SNX=RSN)   D
  5277   "RTN","CH8 35F3",738, 0)
  5278    ..I $G(%D BG835) U 0  W !,"REJC D:",REJCD, "  I:",I,"   GRP:",GR P,"  RSN:" ,RSN
  5279   "RTN","CH8 35F3",739, 0)
  5280    ..I $G(%D BG835) R R CH
  5281   "RTN","CH8 35F3",740, 0)
  5282    Q
  5283   "RTN","CH8 35F3",741, 0)
  5284   TSTREJ(CI, J) ;DLB 12 /19/2012     MODIFIED  TO ACCEPT  THE ^CHMP AY "I" IND EX WITH "J " INDEX
  5285   "RTN","CH8 35F3",742, 0)
  5286    N X,Y S ( X,Y)=""
  5287   "RTN","CH8 35F3",743, 0)
  5288    I '$D(%DB G835) S %D BG835=($$E NVIR^CHTFL IB'="LIVE" )
  5289   "RTN","CH8 35F3",744, 0)
  5290    I $D(^CHM PAY(CI,"RU LE-PROC",J ,0))  D
  5291   "RTN","CH8 35F3",745, 0)
  5292    .S Y=$P($ G(^CHMPAY( CI,"RULE-P ROC",J,0)) ,"^",1)          ; AI  STATUS
  5293   "RTN","CH8 35F3",746, 0)
  5294    .I $G(%DB G835) U 0  W !,"RULE- PROC: Y= " ,Y
  5295   "RTN","CH8 35F3",747, 0)
  5296    .S:'Y X=$ P($G(^CHMP AY(CI,"RUL E-PROC",J, 0)),"^",2)       ; AI  RSN I: PT R->CHMDIC( 741002.22
  5297   "RTN","CH8 35F3",748, 0)
  5298    .I $G(%DB G835) U 0  W !,"RULE- PROC:  X=  ",X
  5299   "RTN","CH8 35F3",749, 0)
  5300    I X="" D                                                                                                ; no  reject re ason from  AI "RULE-P ROC" 
  5301   "RTN","CH8 35F3",750, 0)
  5302    .N CLMRJC D,JDX,REJI ,REJTYPE S  CLMRJCD=" "
  5303   "RTN","CH8 35F3",751, 0)
  5304    .S Y=$P(^ CHMPAY(CI, 0),"^",2)                                                ; STATUS  (REJECT/N ON-REJECT)
  5305   "RTN","CH8 35F3",752, 0)
  5306    .I 'Y  D                                                                                                ; if  claim lev el reject,  apply to  SVC LINE
  5307   "RTN","CH8 35F3",753, 0)
  5308    ..Q:'$D(^ CHMPAY(CI, 4))                                                               ; EXIT IF  NO ^CHMPAY () REJECT  REASON NOD E
  5309   "RTN","CH8 35F3",754, 0)
  5310    ..S JDX=0
  5311   "RTN","CH8 35F3",755, 0)
  5312    ..F  S JD X=$O(^CHMP AY(CI,4,JD X)) Q:'JDX   Q:CLMRJC D]""  D        ; LOOP  THROUGH A LL REJECT  REASON NOD ES
  5313   "RTN","CH8 35F3",756, 0)
  5314    ...S REJI =$P($G(^CH MPAY(CI,4, JDX,0)),"^ ",1) Q:REJ I=""  ;REJ ECT RSN IN DEX FOR ^C HMDIC(7410 02.22,REJI ,0)
  5315   "RTN","CH8 35F3",757, 0)
  5316    ...I $G(% DBG835) U  0 W !,"I,4 ,J  REJI=  ",REJI
  5317   "RTN","CH8 35F3",758, 0)
  5318    ...S REJT YPE=+$P($G (^CHMDIC(7 41002.22,R EJI,0)),"^ ",7)  ;REJ TYPE=$P($G (^CHMDIC(7 41002.22,R EJI,0)),"^ ",7) ( 0:R EJECT,1:IN FORMATIONA L )
  5319   "RTN","CH8 35F3",759, 0)
  5320    ...I $G(% DBG835) U  0 W !,"I,4 ,J  REJTYP E= ",REJTY PE
  5321   "RTN","CH8 35F3",760, 0)
  5322    ...S:REJT YPE=0 CLMR JCD=$P($G( ^CHMDIC(74 1002.22,RE JI,0)),"^" ,1) ; CLMR JCD=$P($G( ^CHMDIC(74 1002.22,RE JI,0)),"^" ,1) ( PROB LEM STATUS  CODE )
  5323   "RTN","CH8 35F3",761, 0)
  5324    ...I $G(% DBG835) U  0 W !,"I,4 ,J  CLMRJC D= ",CLMRJ CD
  5325   "RTN","CH8 35F3",762, 0)
  5326    .I CLMRJC D]"" S X=C LMRJCD
  5327   "RTN","CH8 35F3",763, 0)
  5328    I $G(%DBG 835) U 0 W  !,"RETURN  VALUES X=  ",X,"  Y=  ",Y
  5329   "RTN","CH8 35F3",764, 0)
  5330    Q
  5331   "RTN","CH8 35F3",765, 0)
  5332    ;
  5333   "RTN","CH8 35FU1")
  5334   0^5^B96986 6689
  5335   "RTN","CH8 35FU1",1,0 )
  5336   CH835FU1 ; HAC/JBM;Ut ility for  extracting  edi data  for 835;
  5337   "RTN","CH8 35FU1",2,0 )
  5338    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  5339   "RTN","CH8 35FU1",3,0 )
  5340            ; HR-COB-Med icare-A/B- Begin-9372  (19-Mar-2 010)
  5341   "RTN","CH8 35FU1",4,0 )
  5342            ; HR-PBM-PHA SE 1B-Begi n;;;;;Buil d 17
  5343   "RTN","CH8 35FU1",5,0 )
  5344            ; HR - Team  Track #: 5 592
  5345   "RTN","CH8 35FU1",6,0 )
  5346            ; HR - New 8 35 Routine  that repl aces the o ld CHEDI*  Routines
  5347   "RTN","CH8 35FU1",7,0 )
  5348            ; ;DEV004225  1/12/2010  AEB
  5349   "RTN","CH8 35FU1",8,0 )
  5350            ;  6/6/2012  DLB ADDED  FUNCTION T O RETRIEVE  LINE ITEM  CONTROL N UMBER FOR  CLAIM PDI  "GTLICTL(C I)"
  5351   "RTN","CH8 35FU1",9,0 )
  5352            ;  8/28/2012  DLB MODIF IED THE GT LICTL() FU NCTION TO  "MATCH" TH E SERVICE  CODE AND B ILLED AMT  SO
  5353   "RTN","CH8 35FU1",10, 0)
  5354            ;                         THE CORR ECT LICTL/ LN IS OUTP UT TO THE  835 STAGIN G FILE
  5355   "RTN","CH8 35FU1",11, 0)
  5356            ;  8/28/2012  DLB ADDED  A UTILITY  FUNCTION  TO (XREF(H AC CLM #)  TO OUTPUT  THE POTENT IAL LICTL/ LN
  5357   "RTN","CH8 35FU1",12, 0)
  5358            ;                         VALUES F ROM THE HA C CLAIM NU MBER FROM  THE SVC LI NE IN THE  835 STAGIN G FILE
  5359   "RTN","CH8 35FU1",13, 0)
  5360            ;  8/28/2012  DLB ADDED  DOS TO TH E GTLICTL( ) FUNCTION  TO ENSURE  THE CORRE CT LINE CT RL/LINE #
  5361   "RTN","CH8 35FU1",14, 0)
  5362            ;                         IS REPOR TED FOR TH E CLAIM.
  5363   "RTN","CH8 35FU1",15, 0)
  5364            ;  8/28/2012  DLB ADDED  DOS TO TH E GETPRESC () FUNCTIO N TO ENSUR E CORRECT  LINE CTRL/ NUMBER RET URNED
  5365   "RTN","CH8 35FU1",16, 0)
  5366            ;  8/28/2012  DLB DEBUG  OF THE GT LICTL() FU NCTION COM PLETED, AD DED TSTLIC TL() FUNCT ION TO TES
  5367   "RTN","CH8 35FU1",17, 0)
  5368            ;                         GTLICTL( ) BASED ON  THE HAC C LM #, CHMP AY(J) INDE X, BILLED  AMOUNT, AN D DATE OF  SERVICE.
  5369   "RTN","CH8 35FU1",18, 0)
  5370            ;  10/25/201 2 DLB CHAN GED THE VE RIFICATION  VALUE FOR  THE PHARM ACY CLAIMS  FROM NDC  TO PDI
  5371   "RTN","CH8 35FU1",19, 0)
  5372            ;                         POTENTIA L FOR MODI FICATION T O THE NDC  IS MUCH GR EATER THAN  PDI
  5373   "RTN","CH8 35FU1",20, 0)
  5374            ;  12/17/201 2 DEV7820  DLB ADDED  FUNCTIONS  TO RETURN  RCVDFI(VEN I), CHKEFT (CI,PMETHO D), GETDRG WT(CI),
  5375   "RTN","CH8 35FU1",21, 0)
  5376            ;                         PMETHOD( CI), CLMRE J(CI), AND  GTLICTL(C I,SERVI)
  5377   "RTN","CH8 35FU1",22, 0)
  5378            ;  3/17/2014   DLB        ;  MOD T O EDICLM()  FUNCTION  TO ADD THE  CHTPID VA LUE TO THE  ^CHMPAY(I ,"ZEMC") C ROSSREFERE NCE
  5379   "RTN","CH8 35FU1",23, 0)
  5380            ;                         TO ENSUR E THE PROV IDER CAN B E IDENTIFI ED WITH TH E TARGET I NDEXES FOR  DATA RETR IEVAL. THE  "J" INDEX
  5381   "RTN","CH8 35FU1",24, 0)
  5382            ;                         FOR ^CHM PAY(I,"ZEM C",J) REFL ECTS THE I NCOMING FI LE TYPE, A ND IS STOR ED AT THE  SAME TIME  THE CROSSR EFERENCE
  5383   "RTN","CH8 35FU1",25, 0)
  5384            ;                         IS BUILT , SO CONFI DENCE IS H IGH THAT U SING THIS  VALUE ENSU RES THE CO RRECT INDE XES ARE ID ENTIFIED.
  5385   "RTN","CH8 35FU1",26, 0)
  5386            ;  11/4/2015   DLB        ADDED RE TIREVAL FO R ^CHMIMAG E() "J" AN D "K" INDE XES FOR "I MGL"
  5387   "RTN","CH8 35FU1",27, 0)
  5388            ;                         MULTIPLE  ROUTINES  AFFECTED:  GETIMGLI() ,GETPHPN()
  5389   "RTN","CH8 35FU1",28, 0)
  5390                 ; 10/20 /16 RFE DE V026722 Al low for IC D10 in PRO CDESC
  5391   "RTN","CH8 35FU1",29, 0)
  5392                 ; 06/12 /17 YMG 83 5 reversal
  5393   "RTN","CH8 35FU1",30, 0)
  5394                 ; 02/23 /2018 SBB  CC4002-001 , CC4002-0 02, CC4002 -003 updat es for Rev ersal 835  message
  5395   "RTN","CH8 35FU1",31, 0)
  5396            ;
  5397   "RTN","CH8 35FU1",32, 0)
  5398            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  5399   "RTN","CH8 35FU1",33, 0)
  5400            ;  EDICLM()  CREATES TH E "ZEMCARR " FROM THE  ^CHMPAY(" I,"ZEMC",T RADING PAR TNER ID, C HIDHLD),
  5401   "RTN","CH8 35FU1",34, 0)
  5402            ;  AN UNDOCU MENTED NOD E FOR ^CHM PAY.  THE  DATA STORE D IN THIS  NODE IS TH E SET OF I NDEXES
  5403   "RTN","CH8 35FU1",35, 0)
  5404            ;  FOR THE C LAIM. CHMX I_"*"_CHAI _"*"_CHBI_ "*"_CHCCI_ "*"_CHEI_" ^"_%_"^"_C HMFDUZ_CHZ PYRID
  5405   "RTN","CH8 35FU1",36, 0)
  5406            ;  TRADING P ARTNER ID=  TRADING P ARTNER IDE NTIFIER (S UBMITTING  THE CLAIM)
  5407   "RTN","CH8 35FU1",37, 0)
  5408            ;  CHIDHLD=C HBI_"*"_CH CCI_"*"_CH EI
  5409   "RTN","CH8 35FU1",38, 0)
  5410            ;  CHMXI=FIL E FUFFER I NDEX
  5411   "RTN","CH8 35FU1",39, 0)
  5412            ;  CHAI=TRAN SACTION BU FFER INDEX
  5413   "RTN","CH8 35FU1",40, 0)
  5414            ;  CHBI=PROV IDER BUFFE R INDEX 
  5415   "RTN","CH8 35FU1",41, 0)
  5416            ;  CHCCI=PAT IENT BUFFE R INDEX
  5417   "RTN","CH8 35FU1",42, 0)
  5418            ;  CHEI=CLAI M BUFFER I NDEX. 
  5419   "RTN","CH8 35FU1",43, 0)
  5420            ;  THE "%" I S THE FILE MAN DATE:T IME
  5421   "RTN","CH8 35FU1",44, 0)
  5422            ;  CHMFDUZ I S THE USER  DUZ PROCE SSING CLAI M
  5423   "RTN","CH8 35FU1",45, 0)
  5424            ;  CHZPYRID  IS THE PAY ER ID.
  5425   "RTN","CH8 35FU1",46, 0)
  5426            ;  THE ^CHMP AY("I,"ZEM C",TRADING  PARTNER I D, CHIDHLD ) NODE IS  INSTANTIAT ED IN CHMX F010.INT
  5427   "RTN","CH8 35FU1",47, 0)
  5428            ;  AT LINE 5 1. 
  5429   "RTN","CH8 35FU1",48, 0)
  5430            ;  MEDICAL C LAIM "ZEMC ":  ^CHMPA Y(CHCI,"ZE MC",CHTPID ,CHIDHLD)= CHMXI_"*"_ CHAI_"*"_C HBI_"*"_CH CCI_"*"_CH EI_"^"_%_" ^"_CHMFDUZ _"^"_CHZPY RID_"^"_CH TPID
  5431   "RTN","CH8 35FU1",49, 0)
  5432            ;
  5433   "RTN","CH8 35FU1",50, 0)
  5434            ;  PHARMACY  CLAIMS UTI LIZE THE ^ CHMPAY(I," ZEMC",J) C ROSSREFERE NCE TO STO RE THE ^CH MXRX() IND EXES.
  5435   "RTN","CH8 35FU1",51, 0)
  5436            ;                                          S  @(GLPAY_"C HCI,""ZEMC "",CHTPID, C)")=CHMXI _"*"_CHMXJ _"*"_CHMXK _"^"_%_"^" _CHMFDUZ_" ^"_CHZPYRI D_"^"_CHTP ID
  5437   "RTN","CH8 35FU1",52, 0)
  5438            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;  
  5439   "RTN","CH8 35FU1",53, 0)
  5440            ;
  5441   "RTN","CH8 35FU1",54, 0)
  5442   EDICLM(CI, ZEMCARR) ; returns al l nodes fo r zemc nod es for a c laim into  array ZEMC ARR
  5443   "RTN","CH8 35FU1",55, 0)
  5444            N  J,K,CNT
  5445   "RTN","CH8 35FU1",56, 0)
  5446            ; New CHFCD0 01 VARS
  5447   "RTN","CH8 35FU1",57, 0)
  5448            N  CHEXT,CHP GPT,CHSYS, CHUCI,CHUC IPT,GLDFN, GLELG,GLEO B,GLPAY,GL PAYH
  5449   "RTN","CH8 35FU1",58, 0)
  5450            N  GLPAYW,GL PAY2,U,X1, CNT,OLDARR
  5451   "RTN","CH8 35FU1",59, 0)
  5452            S  X1=CI
  5453   "RTN","CH8 35FU1",60, 0)
  5454            D  PROGTYP^C HFCD001
  5455   "RTN","CH8 35FU1",61, 0)
  5456            Q :'$D(^CHMP AY(CI,"ZEM C"))
  5457   "RTN","CH8 35FU1",62, 0)
  5458            S  J=0 S J=$ O(^CHMPAY( CI,"ZEMC", J)) Q:J=""
  5459   "RTN","CH8 35FU1",63, 0)
  5460            ; HR-PBM-PHA SE 1B-Begi n
  5461   "RTN","CH8 35FU1",64, 0)
  5462            ; Allow SXC  to go thro ugh
  5463   "RTN","CH8 35FU1",65, 0)
  5464            ; Q:J="CMOP" !(J="MDMTR X")!(J="SX C")
  5465   "RTN","CH8 35FU1",66, 0)
  5466            Q :J="CMOP"
  5467   "RTN","CH8 35FU1",67, 0)
  5468            ; HR-PBM-PHA SE 1B-End
  5469   "RTN","CH8 35FU1",68, 0)
  5470            ;
  5471   "RTN","CH8 35FU1",69, 0)
  5472            S  K=0,K=$O( ^CHMPAY(CI ,"ZEMC",J, K))                       ; LOOP  THROUGH T HE "K" IND EXES FOR T HE CLAIM
  5473   "RTN","CH8 35FU1",70, 0)
  5474            S  ZEMCARR=^ CHMPAY(CI, "ZEMC",J,K )                                  ; BUILD  THE "ZEMCA RR" WITH T HE "K" DAT A
  5475   "RTN","CH8 35FU1",71, 0)
  5476                     S Z EMCARR=ZEM CARR_"^"_J                                                     ;  DLB 3/17/2 014  ADD T HE CHTPID  VALUE TO T HE END OF  THE STRING
  5477   "RTN","CH8 35FU1",72, 0)
  5478            ; I $$ENVIR^ CHTFLIB'=" LIVE" U 0  W !,"CH835 FU1:EDICLM : SET UP " "ZEMC"" NO DE: ^CHMPA Y(",CI,",Z EMC,",J,", ",K,")  ZE MCARR() =  ",ZEMCARR 
  5479   "RTN","CH8 35FU1",73, 0)
  5480            Q
  5481   "RTN","CH8 35FU1",74, 0)
  5482            ;
  5483   "RTN","CH8 35FU1",75, 0)
  5484   CHPID(CI)  ;Clearing  house shor tname and  payer id
  5485   "RTN","CH8 35FU1",76, 0)
  5486            N  X,Y,ZEMCA RR
  5487   "RTN","CH8 35FU1",77, 0)
  5488            S  X=""
  5489   "RTN","CH8 35FU1",78, 0)
  5490            D  EDICLM(CI ,.ZEMCARR)  G:'$D(ZEM CARR) CHPI DX
  5491   "RTN","CH8 35FU1",79, 0)
  5492            ; I $$ENVIR^ CHTFLIB'=" LIVE" U 0  W !,"CH835 FU1: CHPID : ZEMCARR( )= ",ZEMCA RR
  5493   "RTN","CH8 35FU1",80, 0)
  5494            S  X=$P(ZEMC ARR,"^",4)  
  5495   "RTN","CH8 35FU1",81, 0)
  5496            S  Y=$E(X,1)  
  5497   "RTN","CH8 35FU1",82, 0)
  5498            ;
  5499   "RTN","CH8 35FU1",83, 0)
  5500            ; HR-PBM-PHA SE 1B-Begi n
  5501   "RTN","CH8 35FU1",84, 0)
  5502            ; Change to  allow for  X="S" whic h is for S XC RX clai ms
  5503   "RTN","CH8 35FU1",85, 0)
  5504            ;  N or M =  Medical ma trix
  5505   "RTN","CH8 35FU1",86, 0)
  5506            ;  W = Envoy
  5507   "RTN","CH8 35FU1",87, 0)
  5508            ;  S = SXC
  5509   "RTN","CH8 35FU1",88, 0)
  5510            ;  C = Medic are COB cl aims
  5511   "RTN","CH8 35FU1",89, 0)
  5512            ; HR-COB-Med icare-A/B- Begin-9372  (19-Mar-2 010)
  5513   "RTN","CH8 35FU1",90, 0)
  5514              I Y'?1(1"N ",1"W",1"S ",1"M",1"C ") S X=""
  5515   "RTN","CH8 35FU1",91, 0)
  5516            ; HR-COB-Med icare-A/B- End-9372
  5517   "RTN","CH8 35FU1",92, 0)
  5518            ; HR-PBM-PHA SE 1B-End
  5519   "RTN","CH8 35FU1",93, 0)
  5520   CHPIDX   
  5521   "RTN","CH8 35FU1",94, 0)
  5522            ; I $$ENVIR^ CHTFLIB'=" LIVE" U 0  W !,"CH835 FU1: CHPID : CHPID($P (ZEMCARR," "^"",4)= " ,X
  5523   "RTN","CH8 35FU1",95, 0)
  5524            Q  X
  5525   "RTN","CH8 35FU1",96, 0)
  5526            ;
  5527   "RTN","CH8 35FU1",97, 0)
  5528   CH(CI)   ; Clear hous e short na me W for W MD and M f or medical  matrix
  5529   "RTN","CH8 35FU1",98, 0)
  5530            N  X S X=""
  5531   "RTN","CH8 35FU1",99, 0)
  5532            S  X=$E($$CH PID(CI),1)
  5533   "RTN","CH8 35FU1",100 ,0)
  5534            Q  X
  5535   "RTN","CH8 35FU1",101 ,0)
  5536            ;
  5537   "RTN","CH8 35FU1",102 ,0)
  5538   PID(CI)  ; PAYER ID
  5539   "RTN","CH8 35FU1",103 ,0)
  5540            N  X,Y S X=" "
  5541   "RTN","CH8 35FU1",104 ,0)
  5542            S  Y=$$CHPID (CI)
  5543   "RTN","CH8 35FU1",105 ,0)
  5544            S  X=$E(Y,2, $L(Y))
  5545   "RTN","CH8 35FU1",106 ,0)
  5546            Q  X
  5547   "RTN","CH8 35FU1",107 ,0)
  5548            ;
  5549   "RTN","CH8 35FU1",108 ,0)
  5550   CHID(CI) ; Clearing h ouse id
  5551   "RTN","CH8 35FU1",109 ,0)
  5552            N  X,Y S X=" "
  5553   "RTN","CH8 35FU1",110 ,0)
  5554            S  Y=$$CH(CI )
  5555   "RTN","CH8 35FU1",111 ,0)
  5556            I  Y="M" S X =403400000
  5557   "RTN","CH8 35FU1",112 ,0)
  5558            I  Y="M" S X =403400000
  5559   "RTN","CH8 35FU1",113 ,0)
  5560            I  Y="W" S X =133052274
  5561   "RTN","CH8 35FU1",114 ,0)
  5562            ; HR-PBM-PHA SE 1B-Begi n
  5563   "RTN","CH8 35FU1",115 ,0)
  5564            ; SXC cleari ng house I D - CR 559 1
  5565   "RTN","CH8 35FU1",116 ,0)
  5566            I  Y="S" S X =752578509
  5567   "RTN","CH8 35FU1",117 ,0)
  5568            ; HR-PBM-PHA SE 1B-End
  5569   "RTN","CH8 35FU1",118 ,0)
  5570            ;
  5571   "RTN","CH8 35FU1",119 ,0)
  5572            ; HR-COB-Med icare-A/B- Begin-9372  (19-Mar-2 010)
  5573   "RTN","CH8 35FU1",120 ,0)
  5574            ; Medicare C OB clearin g house ID
  5575   "RTN","CH8 35FU1",121 ,0)
  5576            I  Y="C" S X =14330
  5577   "RTN","CH8 35FU1",122 ,0)
  5578            ; HR-COB-Med icare-A/B- End-9372
  5579   "RTN","CH8 35FU1",123 ,0)
  5580            Q  X
  5581   "RTN","CH8 35FU1",124 ,0)
  5582            ;
  5583   "RTN","CH8 35FU1",125 ,0)
  5584   PROVID(VEN I) ;TIN fo r the prov ider
  5585   "RTN","CH8 35FU1",126 ,0)
  5586            N  X,Y S X=" "
  5587   "RTN","CH8 35FU1",127 ,0)
  5588            S  X=$P($G(^ CHMVEN(VEN I,0)),"^", 3)
  5589   "RTN","CH8 35FU1",128 ,0)
  5590            Q  X
  5591   "RTN","CH8 35FU1",129 ,0)
  5592            ;
  5593   "RTN","CH8 35FU1",130 ,0)
  5594            ;  RETURN TH E VENDOR N PI AS FOUN D IN THE E DI BUFFER  FILES
  5595   "RTN","CH8 35FU1",131 ,0)
  5596            ;  FOR THE G IVEN PDI.   This is t he most re liable way  to get th e
  5597   "RTN","CH8 35FU1",132 ,0)
  5598            ;  PDI that  was sent i n the 837.   There is  an NPI fi eld in the
  5599   "RTN","CH8 35FU1",133 ,0)
  5600            ;  vendor gl obal but i t's not re liably ent ered. AJM  05-21-2008
  5601   "RTN","CH8 35FU1",134 ,0)
  5602   PROVNPI(PD I) ;NPI fo r the prov ider
  5603   "RTN","CH8 35FU1",135 ,0)
  5604            N  CNTNB,CHC LI,X,CHCLB I,NPI
  5605   "RTN","CH8 35FU1",136 ,0)
  5606            Q :($G(PDI)= "") ""  ;R ETURN NULL  STRING ON  BAD INPUT
  5607   "RTN","CH8 35FU1",137 ,0)
  5608            S  CNTNB=$O( ^CHMXCLE(" PDI",PDI," ")) Q:CNTN B="" ""
  5609   "RTN","CH8 35FU1",138 ,0)
  5610            S  CHCLI=$O( ^CHMXCLE(" PDI",PDI,C NTNB,""))  Q:CHCLI=""  ""
  5611   "RTN","CH8 35FU1",139 ,0)
  5612            S  X=$O(^CHM XCLE("PDI" ,PDI,CNTNB ,CHCLI,"") )
  5613   "RTN","CH8 35FU1",140 ,0)
  5614            S  CHCLBI=$P (X,"*",2)  Q:CHCLBI=" " ""
  5615   "RTN","CH8 35FU1",141 ,0)
  5616            S  NPI=$P($G (^CHMXCLB( CHCLBI,0)) ,"^",13)
  5617   "RTN","CH8 35FU1",142 ,0)
  5618            S :'(NPI?10N ) NPI=""   ;IF NOT 10  DIGITS, N OT NPI, RE TURN ""
  5619   "RTN","CH8 35FU1",143 ,0)
  5620            Q  NPI
  5621   "RTN","CH8 35FU1",144 ,0)
  5622            ;
  5623   "RTN","CH8 35FU1",145 ,0)
  5624            ;  RETURN TH E LATEST P DI FOR THE  GIVEN CLA IM INDEX.   The lates t
  5625   "RTN","CH8 35FU1",146 ,0)
  5626            ;  would be  the either  the only  or new pdi  for a reo pened clai m.
  5627   "RTN","CH8 35FU1",147 ,0)
  5628   CLMPDI(CI)  
  5629   "RTN","CH8 35FU1",148 ,0)
  5630            N  PDI,TMP
  5631   "RTN","CH8 35FU1",149 ,0)
  5632            Q :($G(CI)=" ") "" ;QUI T ON BAD I NPUT
  5633   "RTN","CH8 35FU1",150 ,0)
  5634            S  PDI=""
  5635   "RTN","CH8 35FU1",151 ,0)
  5636            ;  REVERSE O RDER SEARC H: THE MOS T RECENT P DI IS THE  ONE WE'RE  INTERESTED  IN
  5637   "RTN","CH8 35FU1",152 ,0)
  5638            S  TMP=99
  5639   "RTN","CH8 35FU1",153 ,0)
  5640            S  TMP=$O(^C HMPAY(CI," PDI",TMP), -1) Q:(TMP ="") "" ;C AN'T FIND  PDI FOR CL AIM IVAL
  5641   "RTN","CH8 35FU1",154 ,0)
  5642            S :$D(^CHMPA Y(CI,"PDI" ,TMP,0)) P DI=$P(^CHM PAY(CI,"PD I",TMP,0), "^",1)
  5643   "RTN","CH8 35FU1",155 ,0)
  5644            Q  PDI
  5645   "RTN","CH8 35FU1",156 ,0)
  5646            ;
  5647   "RTN","CH8 35FU1",157 ,0)
  5648   DTOUT(VAL)  ;
  5649   "RTN","CH8 35FU1",158 ,0)
  5650            N  X,X
  5651   "RTN","CH8 35FU1",159 ,0)
  5652            S  X=""
  5653   "RTN","CH8 35FU1",160 ,0)
  5654            S  VAL=$P(VA L,".",1)
  5655   "RTN","CH8 35FU1",161 ,0)
  5656            I  $L(+VAL)= 7 S X=$$FM YR^CHTFLIB (VAL)_$E(V AL,4,7)
  5657   "RTN","CH8 35FU1",162 ,0)
  5658            Q  X
  5659   "RTN","CH8 35FU1",163 ,0)
  5660   TOS(I)   ; returns sh ort name f or claim t ype if ser vice
  5661   "RTN","CH8 35FU1",164 ,0)
  5662            N  X,Y S X=0
  5663   "RTN","CH8 35FU1",165 ,0)
  5664            I  I]"" S X= $P($G(^CHM DIC(741002 .05,I,0)), "^",2)
  5665   "RTN","CH8 35FU1",166 ,0)
  5666            Q  X
  5667   "RTN","CH8 35FU1",167 ,0)
  5668   CASLN(TMPI ,LN,GRP)    ;
  5669   "RTN","CH8 35FU1",168 ,0)
  5670            N  X,RSN,VAL UES,AMT,QT Y
  5671   "RTN","CH8 35FU1",169 ,0)
  5672            S  X=""
  5673   "RTN","CH8 35FU1",170 ,0)
  5674            S  RSN=""
  5675   "RTN","CH8 35FU1",171 ,0)
  5676            F   S RSN=$O (CAS(TMPI, LN,GRP,RSN )) Q:RSN=" "  D
  5677   "RTN","CH8 35FU1",172 ,0)
  5678            . S VALUES=C AS(TMPI,LN ,GRP,RSN)
  5679   "RTN","CH8 35FU1",173 ,0)
  5680            . ;U 0 W !,"    FU1:CAS LN: TMPI:" ,TMPI,"  L INE:",LN,"  GRP:",GRP ,"  RSN:", RSN,"  VAL UES:",VALU ES
  5681   "RTN","CH8 35FU1",174 ,0)
  5682            . S AMT=$P(V ALUES,"^", 1),QTY=$P( VALUES,"^" ,2)
  5683   "RTN","CH8 35FU1",175 ,0)
  5684            . S:AMT="" Q TY=""
  5685   "RTN","CH8 35FU1",176 ,0)
  5686            . ;[YMG] 835  reversal
  5687   "RTN","CH8 35FU1",177 ,0)
  5688            . I +$G(REV8 35),+AMT>0  S AMT=-AM T ; negate  amount fo r 835 reve rsal, REV8 35 is set  in ^CH835F 1
  5689   "RTN","CH8 35FU1",178 ,0)
  5690            . ;
  5691   "RTN","CH8 35FU1",179 ,0)
  5692            . S X=X_RSN_ ":"_AMT_": "_QTY_"^"
  5693   "RTN","CH8 35FU1",180 ,0)
  5694            Q  X
  5695   "RTN","CH8 35FU1",181 ,0)
  5696   SCASLN(TMP I,LN,IVAL, GRP,QTY)    ;
  5697   "RTN","CH8 35FU1",182 ,0)
  5698            N  X,RSN,VAL UES
  5699   "RTN","CH8 35FU1",183 ,0)
  5700            S  X=""
  5701   "RTN","CH8 35FU1",184 ,0)
  5702            S  RSN=""
  5703   "RTN","CH8 35FU1",185 ,0)
  5704            F   S RSN=$O (CAS(TMPI, LN,IVAL,GR P,RSN)) Q: RSN=""  D
  5705   "RTN","CH8 35FU1",186 ,0)
  5706            . S VALUES=C AS(TMPI,LN ,IVAL,GRP, RSN)
  5707   "RTN","CH8 35FU1",187 ,0)
  5708            . ;U 0 W !,"    FU1:SCA SLN: TMPI: ",TMPI,"   LINE:",LN, " GRP:",GR P,"  RSN:" ,RSN,"  VA LUES:",VAL UES
  5709   "RTN","CH8 35FU1",188 ,0)
  5710            . S AMT=$P(V ALUES,"^", 1),QTY=$P( VALUES,"^" ,2)
  5711   "RTN","CH8 35FU1",189 ,0)
  5712            . S:AMT="" Q TY=""
  5713   "RTN","CH8 35FU1",190 ,0)
  5714            . ;[YMG] 835  reversal
  5715   "RTN","CH8 35FU1",191 ,0)
  5716            . I +$G(REV8 35),+AMT>0  S AMT=-AM T ; negate  amount fo r 835 reve rsal, REV8 35 is set  in ^CH835F 1
  5717   "RTN","CH8 35FU1",192 ,0)
  5718            . ;
  5719   "RTN","CH8 35FU1",193 ,0)
  5720            . S X=X_RSN_ ":"_AMT_": "_QTY_"^"
  5721   "RTN","CH8 35FU1",194 ,0)
  5722            Q  X
  5723   "RTN","CH8 35FU1",195 ,0)
  5724            ;
  5725   "RTN","CH8 35FU1",196 ,0)
  5726            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  5727   "RTN","CH8 35FU1",197 ,0)
  5728            ;  REJ() SET S UP THE C AS ARRAY
  5729   "RTN","CH8 35FU1",198 ,0)
  5730            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  5731   "RTN","CH8 35FU1",199 ,0)
  5732            ;
  5733   "RTN","CH8 35FU1",200 ,0)
  5734   REJ(TMPI,L INE,REJCD, AMT,CHQTY)  ;
  5735   "RTN","CH8 35FU1",201 ,0)
  5736            ; load rejec tion into  CAS array.
  5737   "RTN","CH8 35FU1",202 ,0)
  5738            ; line 0 wou ld be clai m level re jects and
  5739   "RTN","CH8 35FU1",203 ,0)
  5740            ; 1 thru nth  line woul d be line  level reje cts
  5741   "RTN","CH8 35FU1",204 ,0)
  5742            ; PASS IN LI NE,AMT,AND  REJI
  5743   "RTN","CH8 35FU1",205 ,0)
  5744            ;
  5745   "RTN","CH8 35FU1",206 ,0)
  5746            ; U 0 W !,"F U1:REJ: TM PI=",TMPI, "  LINE=", LINE,"  RE JCD=",REJC D,"  AMT=" ,AMT,"  QT Y=",CHQTY
  5747   "RTN","CH8 35FU1",207 ,0)
  5748            N  I,INFO
  5749   "RTN","CH8 35FU1",208 ,0)
  5750            N  GRP1,GRP2 ,RSN1,RSN2
  5751   "RTN","CH8 35FU1",209 ,0)
  5752            N  AMT1,AMT2 ,SPLITFLG
  5753   "RTN","CH8 35FU1",210 ,0)
  5754            ;
  5755   "RTN","CH8 35FU1",211 ,0)
  5756            S  AMT1=$J(A MT/2,0,2)   ;this cau ses it to  round to t he cent
  5757   "RTN","CH8 35FU1",212 ,0)
  5758            S  AMT2=AMT- AMT1
  5759   "RTN","CH8 35FU1",213 ,0)
  5760            S  I=0,I=$O( ^CHMXDIC(7 41201.77," B",REJCD,I ))
  5761   "RTN","CH8 35FU1",214 ,0)
  5762            ; BEG MOD PE R DEV00268 6,SKD 7-9- 07
  5763   "RTN","CH8 35FU1",215 ,0)
  5764            ; S INFO=^CH MXDIC(7412 01.77,I,0)
  5765   "RTN","CH8 35FU1",216 ,0)
  5766            ; S GRP1=$P( INFO,"^",2 )
  5767   "RTN","CH8 35FU1",217 ,0)
  5768            ; S RSN1=$P( INFO,"^",3 )
  5769   "RTN","CH8 35FU1",218 ,0)
  5770            ; S GRP2=$P( INFO,"^",4 )
  5771   "RTN","CH8 35FU1",219 ,0)
  5772            ; S RSN2=$P( INFO,"^",5 )
  5773   "RTN","CH8 35FU1",220 ,0)
  5774            S  INFO="",( GRP1,RSN1, GRP2,RSN2) =""
  5775   "RTN","CH8 35FU1",221 ,0)
  5776            I  $G(I) D
  5777   "RTN","CH8 35FU1",222 ,0)
  5778            . S INFO=^CH MXDIC(7412 01.77,I,0)
  5779   "RTN","CH8 35FU1",223 ,0)
  5780            . ;U 0 W !,"    FU1:REJ : INFO=",I NFO
  5781   "RTN","CH8 35FU1",224 ,0)
  5782            . S GRP1=$P( INFO,"^",2 ) S:GRP1'= "" GRP1=$P ($G(^CHMXD IC(741201. 15,GRP1,0) ),"^",1)   ;AEB 1/12/ 2010 DEV00 4225
  5783   "RTN","CH8 35FU1",225 ,0)
  5784            . S RSN1=$P( INFO,"^",3 ) S:RSN1'= "" RSN1=$P ($G(^CHMXD IC(741201. 16,RSN1,0) ),"^",1)   ;AEB 1/12/ 2010 DEV00 4225
  5785   "RTN","CH8 35FU1",226 ,0)
  5786            . S GRP2=$P( INFO,"^",4 ) S:GRP2'= "" GRP2=$P ($G(^CHMXD IC(741201. 15,GRP2,0) ),"^",1)   ;AEB 1/12/ 2010 DEV00 4225
  5787   "RTN","CH8 35FU1",227 ,0)
  5788            . S RSN2=$P( INFO,"^",5 ) S:RSN2'= "" RSN2=$P ($G(^CHMXD IC(741201. 16,RSN2,0) ),"^",1)   ;AEB 1/12/ 2010 DEV00 4225
  5789   "RTN","CH8 35FU1",228 ,0)
  5790            I  GRP1="" S  GRP1="ZZ"
  5791   "RTN","CH8 35FU1",229 ,0)
  5792            I  RSN1="" S  RSN1="ZZ"
  5793   "RTN","CH8 35FU1",230 ,0)
  5794            ; END MOD PE R DEV00268 6,SKD 7-9- 07
  5795   "RTN","CH8 35FU1",231 ,0)
  5796            S  SPLITFLG= 0
  5797   "RTN","CH8 35FU1",232 ,0)
  5798            ;  flag indi cates more  than 1 eo b rsn for  hac rsn; s plits rej  amt
  5799   "RTN","CH8 35FU1",233 ,0)
  5800            ;  between t he two eob  reason, R S1 and rsn 2)
  5801   "RTN","CH8 35FU1",234 ,0)
  5802            ; I GRP2]""  I RSN2]""  I RSN1'=RS N2 S SPLIT FLG=1  ;DE V002686, S KD 7-9-07
  5803   "RTN","CH8 35FU1",235 ,0)
  5804            I  $G(GRP2)] "" I $G(RS N2)]"" I $ G(RSN1)'=$ G(RSN2) S  SPLITFLG=1    ;DEV002 686, SKD 7 -9-07
  5805   "RTN","CH8 35FU1",236 ,0)
  5806            ; U 0 W !,"    FU1:REJ:  GRP1:",GR P1,"  RSN1 :",RSN1,"   AMT:",AMT ,"  QTY:", CHQTY
  5807   "RTN","CH8 35FU1",237 ,0)
  5808            I  SPLITFLG= 0 D
  5809   "RTN","CH8 35FU1",238 ,0)
  5810            . S:AMT="" C HQTY=""
  5811   "RTN","CH8 35FU1",239 ,0)
  5812            . S CAS(TMPI ,LINE,GRP1 ,RSN1)=AMT _"^"_CHQTY
  5813   "RTN","CH8 35FU1",240 ,0)
  5814            I  SPLITFLG= 1 D
  5815   "RTN","CH8 35FU1",241 ,0)
  5816            . S CAS(TMPI ,LINE,GRP1 ,RSN1)=AMT 1_"^"_CHQT Y
  5817   "RTN","CH8 35FU1",242 ,0)
  5818            . S CAS(TMPI ,LINE,GRP2 ,RSN2)=AMT 2_"^"_CHQT Y
  5819   "RTN","CH8 35FU1",243 ,0)
  5820            Q
  5821   "RTN","CH8 35FU1",244 ,0)
  5822   SREJ(CAS,T MPI,LINE,S CASLN,REJC D,AMT,CHQT Y) ;
  5823   "RTN","CH8 35FU1",245 ,0)
  5824            ;  CAS           ARRAY  CONTAINING  THE SVC " SVCCAS" RE CORDS
  5825   "RTN","CH8 35FU1",246 ,0)
  5826            ;  TMPI          FIRST  INDEX INTO  CAS ARRAY
  5827   "RTN","CH8 35FU1",247 ,0)
  5828            ;  LINE          SECOND  INDEX INT O CAS ARRA Y
  5829   "RTN","CH8 35FU1",248 ,0)
  5830            ;  SCASLN        THIRD  LEVEL INDE X INTO CAS  ARRAY
  5831   "RTN","CH8 35FU1",249 ,0)
  5832            ;  REJCD         REJECT  CODE TO B E REPORTED
  5833   "RTN","CH8 35FU1",250 ,0)
  5834            ;  AMT           REJECT  AMOUNT TO  BE REPORT ED
  5835   "RTN","CH8 35FU1",251 ,0)
  5836            ;  CHQTY         QUANTI TY VALUE T O BE REPOR TED
  5837   "RTN","CH8 35FU1",252 ,0)
  5838            ; load rejec tion into  CAS array.
  5839   "RTN","CH8 35FU1",253 ,0)
  5840            ; line 0 wou ld be clai m level re jects and
  5841   "RTN","CH8 35FU1",254 ,0)
  5842            ; 1 thru nth  line woul d be line  level reje cts
  5843   "RTN","CH8 35FU1",255 ,0)
  5844            ; PASS IN LI NE,AMT,AND  REJI
  5845   "RTN","CH8 35FU1",256 ,0)
  5846            ;
  5847   "RTN","CH8 35FU1",257 ,0)
  5848            ; U 0 W !,"F U1:SREJ: T MPI=",TMPI ,"  LINE=" ,LINE,"  R EJCD=",REJ CD,"  AMT= ",AMT,"  Q TY=",CHQTY
  5849   "RTN","CH8 35FU1",258 ,0)
  5850            Q :REJCD=""
  5851   "RTN","CH8 35FU1",259 ,0)
  5852            Q :'$D(^CHMX DIC(741201 .77,"B",RE JCD))
  5853   "RTN","CH8 35FU1",260 ,0)
  5854            N  I,INFO
  5855   "RTN","CH8 35FU1",261 ,0)
  5856            N  GRP1,GRP2 ,RSN1,RSN2
  5857   "RTN","CH8 35FU1",262 ,0)
  5858            N  AMT1,AMT2 ,SPLITFLG
  5859   "RTN","CH8 35FU1",263 ,0)
  5860            ;
  5861   "RTN","CH8 35FU1",264 ,0)
  5862            S  AMT1=$J(A MT/2,0,2)   ;this cau ses it to  round to t he cent
  5863   "RTN","CH8 35FU1",265 ,0)
  5864            S  AMT2=AMT- AMT1
  5865   "RTN","CH8 35FU1",266 ,0)
  5866            S  I=0 S I=$ O(^CHMXDIC (741201.77 ,"B",REJCD ,I)) 
  5867   "RTN","CH8 35FU1",267 ,0)
  5868            ; BEG MOD PE R DEV00268 6,SKD 7-5- 07
  5869   "RTN","CH8 35FU1",268 ,0)
  5870            ; S INFO=^CH MXDIC(7412 01.77,I,0)
  5871   "RTN","CH8 35FU1",269 ,0)
  5872            ; S GRP1=$P( INFO,"^",2 )
  5873   "RTN","CH8 35FU1",270 ,0)
  5874            ; S RSN1=$P( INFO,"^",3 )
  5875   "RTN","CH8 35FU1",271 ,0)
  5876            ; S GRP2=$P( INFO,"^",4 )
  5877   "RTN","CH8 35FU1",272 ,0)
  5878            ; S RSN2=$P( INFO,"^",5 )
  5879   "RTN","CH8 35FU1",273 ,0)
  5880            S  INFO="",( GRP1,RSN1, GRP2,RSN2) =""
  5881   "RTN","CH8 35FU1",274 ,0)
  5882            I  $D(^CHMXD IC(741201. 77,I)) D
  5883   "RTN","CH8 35FU1",275 ,0)
  5884            . S INFO=^CH MXDIC(7412 01.77,I,0)
  5885   "RTN","CH8 35FU1",276 ,0)
  5886            . S GRP1=$P( INFO,"^",2 ) S:GRP1'= "" GRP1=$P ($G(^CHMXD IC(741201. 15,GRP1,0) ),"^",1)   ;AEB 1/12/ 2010 DEV00 4225
  5887   "RTN","CH8 35FU1",277 ,0)
  5888            . S RSN1=$P( INFO,"^",3 ) S:RSN1'= "" RSN1=$P ($G(^CHMXD IC(741201. 16,RSN1,0) ),"^",1)   ;AEB 1/12/ 2010 DEV00 4225
  5889   "RTN","CH8 35FU1",278 ,0)
  5890            . S GRP2=$P( INFO,"^",4 ) S:GRP2'= "" GRP2=$P ($G(^CHMXD IC(741201. 15,GRP2,0) ),"^",1)   ;AEB 1/12/ 2010 DEV00 4225
  5891   "RTN","CH8 35FU1",279 ,0)
  5892            . S RSN2=$P( INFO,"^",5 ) S:RSN2'= "" RSN2=$P ($G(^CHMXD IC(741201. 16,RSN2,0) ),"^",1)   ;AEB 1/12/ 2010 DEV00 4225
  5893   "RTN","CH8 35FU1",280 ,0)
  5894            I  GRP1="" S  GRP1="ZZ"
  5895   "RTN","CH8 35FU1",281 ,0)
  5896            I  RSN1="" S  RSN1="ZZ"
  5897   "RTN","CH8 35FU1",282 ,0)
  5898            ; END MOD PE R DEV00268 6,SKD 7-5- 07
  5899   "RTN","CH8 35FU1",283 ,0)
  5900            S  SPLITFLG= 0
  5901   "RTN","CH8 35FU1",284 ,0)
  5902            ;  flag indi cates more  than 1 eo b rsn for  hac rsn; s plits rej  amt
  5903   "RTN","CH8 35FU1",285 ,0)
  5904            ;  between t he two eob  reason, R S1 and rsn 2)
  5905   "RTN","CH8 35FU1",286 ,0)
  5906            ; I GRP2]""  I RSN2]""  I RSN1'=RS N2 S SPLIT FLG=1  ;DE V002686, S KD 7-5-07
  5907   "RTN","CH8 35FU1",287 ,0)
  5908            I  $G(GRP2)] "" I $G(RS N2)]"" I $ G(RSN1)'=$ G(RSN2) S  SPLITFLG=1    ;DEV002 686, SKD 7 -5-07
  5909   "RTN","CH8 35FU1",288 ,0)
  5910            ; U 0 W !,"    FU1:SREJ : GRP1:",G RP1,"  RSN 1:",RSN1,"   AMT:",AM T,"  QTY:" ,CHQTY
  5911   "RTN","CH8 35FU1",289 ,0)
  5912            I  SPLITFLG= 0 D
  5913   "RTN","CH8 35FU1",290 ,0)
  5914            . S:AMT="" C HQTY=""                                                                            ; IF  NO AMOUNT  VALUE, QT Y=""
  5915   "RTN","CH8 35FU1",291 ,0)
  5916            . S CAS(TMPI ,LINE,SCAS LN,GRP1,RS N1)=AMT_"^ "_CHQTY
  5917   "RTN","CH8 35FU1",292 ,0)
  5918            I  SPLITFLG= 1 D
  5919   "RTN","CH8 35FU1",293 ,0)
  5920            . S CAS(TMPI ,LINE,SCAS LN,GRP1,RS N1)=AMT1_" ^"_CHQTY
  5921   "RTN","CH8 35FU1",294 ,0)
  5922            . S CAS(TMPI ,LINE,SCAS LN,GRP2,RS N2)=AMT2_" ^"_CHQTY
  5923   "RTN","CH8 35FU1",295 ,0)
  5924            ; U 0 W !,"F U1:SREJ: C AS(",TMPI, ",",LINE," ,",SCASLN, ",",GRP1," ,",RSN1,") = ",CAS(TM PI,LINE,SC ASLN,GRP1, RSN1)
  5925   "RTN","CH8 35FU1",296 ,0)
  5926            Q
  5927   "RTN","CH8 35FU1",297 ,0)
  5928            ;
  5929   "RTN","CH8 35FU1",298 ,0)
  5930            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  5931   "RTN","CH8 35FU1",299 ,0)
  5932            ;  LQ REMARK S CODE RET RIEVAL
  5933   "RTN","CH8 35FU1",300 ,0)
  5934            ;  THE REMAR K CODE IND EXES  RETR IEVED FROM  ^CHMXDIC( 741201.77    EOB/X12  CROSSWALK
  5935   "RTN","CH8 35FU1",301 ,0)
  5936            ;  NON-PHARM ACY REMARK S RETRIEVE D FROM ^CH MXDIC(7412 01.58   CL AIM PAYMEN T REMARK C ODES
  5937   "RTN","CH8 35FU1",302 ,0)
  5938            ;  PHARMACY  REMARKS RE TRIEVED FR OM ^CHMXDI C(741201.7 9   WPS OH I REJECT R EASON CODE S
  5939   "RTN","CH8 35FU1",303 ,0)
  5940            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  5941   "RTN","CH8 35FU1",304 ,0)
  5942            ;
  5943   "RTN","CH8 35FU1",305 ,0)
  5944   REMARKS(TO S,REJCD) ;
  5945   "RTN","CH8 35FU1",306 ,0)
  5946            N  X,Y,I,INF O,REMARKS
  5947   "RTN","CH8 35FU1",307 ,0)
  5948            S  X="",REMA RKS=""
  5949   "RTN","CH8 35FU1",308 ,0)
  5950            S  I=0 S I=$ O(^CHMXDIC (741201.77 ,"B",REJCD ,I))
  5951   "RTN","CH8 35FU1",309 ,0)
  5952            I  'I Q X     ;DEV00268 6,SKD 7-9- 07
  5953   "RTN","CH8 35FU1",310 ,0)
  5954            S  INFO=$G(^ CHMXDIC(74 1201.77,I, 0))
  5955   "RTN","CH8 35FU1",311 ,0)
  5956            I  TOS'="RXT "  D                                                                               ; NO N-PHARMACY  LQ REMARK S
  5957   "RTN","CH8 35FU1",312 ,0)
  5958            . S X=$P(INF O,"^",6),Y =$P(INFO," ^",7)                              ; REMARK  CODE INDE XES FROM ^ CHMXDIC(74 1201.77
  5959   "RTN","CH8 35FU1",313 ,0)
  5960            . S:X REMARK S=$P(^CHMX DIC(741201 .58,X,0)," ^",1)          ; IF X  INDEX EXI STS, GET R EMARK
  5961   "RTN","CH8 35FU1",314 ,0)
  5962            . S:Y REMARK S=REMARKS_ "^"_$P(^CH MXDIC(7412 01.58,Y,0) ,"^",1)  ;  IF Y INDE X GET REMA RKS FROM ^ CHMXDIC(74 1201.58
  5963   "RTN","CH8 35FU1",315 ,0)
  5964            E   I TOS="R XT"  D                                                                             ; PH ARMACY LQ  REMARKS
  5965   "RTN","CH8 35FU1",316 ,0)
  5966            . S X=$P(INF O,"^",8),Y =$P(INFO," ^",9)                              ; REMARK  CODE INDE XES FROM ^ CHMXDIC(74 1201.77
  5967   "RTN","CH8 35FU1",317 ,0)
  5968            . S:X REMARK S=$P(^CHMX DIC(741201 .79,X,0)," ^",1)
  5969   "RTN","CH8 35FU1",318 ,0)
  5970            . S:Y REMARK S=REMARKS_ "^"_$P(^CH MXDIC(7412 01.79,Y,0) ,"^",1)  ;  REMARKS F ROM ^CHMXD IC(741201. 79
  5971   "RTN","CH8 35FU1",319 ,0)
  5972            ; U 0 W !,"F U1: REMARK S: REJCD=  ",REJCD,"   DIC DATA=  ",INFO,"   REMARKS=  ",REMARKS   
  5973   "RTN","CH8 35FU1",320 ,0)
  5974            Q  REMARKS
  5975   "RTN","CH8 35FU1",321 ,0)
  5976            ;
  5977   "RTN","CH8 35FU1",322 ,0)
  5978   DRGWT(DRGC D,DOS) ;
  5979   "RTN","CH8 35FU1",323 ,0)
  5980            N  X,EFFDT,J ,I
  5981   "RTN","CH8 35FU1",324 ,0)
  5982            S  I=+DRGCD
  5983   "RTN","CH8 35FU1",325 ,0)
  5984            S  X=""
  5985   "RTN","CH8 35FU1",326 ,0)
  5986            S  EFFDT=DOS +.01  ; Ad ded +.01 f or rev $or der
  5987   "RTN","CH8 35FU1",327 ,0)
  5988            G :'$D(^CHMD IC(741002. 16,I,1,"B" )) DRGWTX
  5989   "RTN","CH8 35FU1",328 ,0)
  5990            S  EFFDT=$O( ^CHMDIC(74 1002.16,I, 1,"B",EFFD T),-1)
  5991   "RTN","CH8 35FU1",329 ,0)
  5992            S :EFFDT=""  EFFDT=$O(^ CHMDIC(741 002.16,I,1 ,"B",EFFDT ))
  5993   "RTN","CH8 35FU1",330 ,0)
  5994            G :EFFDT=""  DRGWTX
  5995   "RTN","CH8 35FU1",331 ,0)
  5996            S  J=0 S J=$ O(^CHMDIC( 741002.16, I,1,"B",EF FDT,J))
  5997   "RTN","CH8 35FU1",332 ,0)
  5998            S  X=$P($G(^ CHMDIC(741 002.16,I,1 ,J,0)),"^" ,3)
  5999   "RTN","CH8 35FU1",333 ,0)
  6000   DRGWTX   Q  X
  6001   "RTN","CH8 35FU1",334 ,0)
  6002            ;
  6003   "RTN","CH8 35FU1",335 ,0)
  6004            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  6005   "RTN","CH8 35FU1",336 ,0)
  6006            ;  FUNCTION  TO RETRIEV E FIELDS F OR THE DAT A TO BE RE TRIEVED FO R 835 REPO RTS
  6007   "RTN","CH8 35FU1",337 ,0)
  6008            ;  ADDED 12/ 19/2012
  6009   "RTN","CH8 35FU1",338 ,0)
  6010            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  6011   "RTN","CH8 35FU1",339 ,0)
  6012            ;
  6013   "RTN","CH8 35FU1",340 ,0)
  6014   GETFIELD(D ESC,CLTYPE )            ; 835 DA TA RETRIEV AL 
  6015   "RTN","CH8 35FU1",341 ,0)
  6016            ;  DESC DESC RIPTION ST RING FOR T HE FIELD T O RETURN
  6017   "RTN","CH8 35FU1",342 ,0)
  6018            ;  CLTYPE CL AIM TYPE U SED TO DET ERMINE THE  NODE TO W ORK WITH
  6019   "RTN","CH8 35FU1",343 ,0)
  6020            I  (CLTYPE=" OPT")!(CLT YPE="TRV")   D
  6021   "RTN","CH8 35FU1",344 ,0)
  6022            . I DESC="MO DI" S RETU RN=4 Q                      ; 1R ST CPT-4 M ODIFIER FO R OUTPATIE NT
  6023   "RTN","CH8 35FU1",345 ,0)
  6024            . I DESC="AL LOWD" S RE TURN=3 Q                    ; AL LOWED AMOU NT OR ADJU STED ALLOW ED AMOUNT
  6025   "RTN","CH8 35FU1",346 ,0)
  6026            I  CLTYPE="D UR"  D
  6027   "RTN","CH8 35FU1",347 ,0)
  6028            . I DESC="MO DI" S RETU RN=13 Q                     ; 1R ST CPT-4 M ODIFIER FO R DME SUPP LIES
  6029   "RTN","CH8 35FU1",348 ,0)
  6030            . I DESC="AL LOWD" S RE TURN=4 Q                    ; AL LOWED AMOU NT OR ADJU STED ALLOW ED AMOUNT
  6031   "RTN","CH8 35FU1",349 ,0)
  6032            I  CLTYPE="D EN"  D
  6033   "RTN","CH8 35FU1",350 ,0)
  6034            . I DESC="MO DI" S RETU RN=6 Q                      ; 1R ST CPT-4 M ODIFIER FO R DENTAL
  6035   "RTN","CH8 35FU1",351 ,0)
  6036            . I DESC="AL LOWD" S RE TURN=5 Q                    ; AL LOWED AMOU NT OR ADJU STED ALLOW ED AMOUNT
  6037   "RTN","CH8 35FU1",352 ,0)
  6038            Q  RETURN
  6039   "RTN","CH8 35FU1",353 ,0)
  6040            ;
  6041   "RTN","CH8 35FU1",354 ,0)
  6042   MOD(I)   ;
  6043   "RTN","CH8 35FU1",355 ,0)
  6044            N  X S X=""
  6045   "RTN","CH8 35FU1",356 ,0)
  6046            S  X=$P($G(^ CHMDIC(741 002.37,I,0 )),"^",1)
  6047   "RTN","CH8 35FU1",357 ,0)
  6048            Q  X
  6049   "RTN","CH8 35FU1",358 ,0)
  6050   SVCQUAL(I)  ;
  6051   "RTN","CH8 35FU1",359 ,0)
  6052            N  X,TYPE S  X=""
  6053   "RTN","CH8 35FU1",360 ,0)
  6054            Q :I="" X
  6055   "RTN","CH8 35FU1",361 ,0)
  6056            S  TYPE=$P($ G(^CHMSERV (I,0)),"^" ,5)
  6057   "RTN","CH8 35FU1",362 ,0)
  6058            S :TYPE="HCP CS" X="HC"
  6059   "RTN","CH8 35FU1",363 ,0)
  6060            S :TYPE="CPT " X="HC"
  6061   "RTN","CH8 35FU1",364 ,0)
  6062            S :TYPE="ADA " X="AD"
  6063   "RTN","CH8 35FU1",365 ,0)
  6064            S :TYPE="ICD -9" X="ID"
  6065   "RTN","CH8 35FU1",366 ,0)
  6066            Q  X
  6067   "RTN","CH8 35FU1",367 ,0)
  6068   RXCODE(I)  ;                                                 NDC  CODE (0037 8-0222-01)  FOR ^CHMP DX
  6069   "RTN","CH8 35FU1",368 ,0)
  6070            N  X S X=""
  6071   "RTN","CH8 35FU1",369 ,0)
  6072            S  X=$P($G(^ CHMPDX(I,1 )),"^",1)
  6073   "RTN","CH8 35FU1",370 ,0)
  6074            Q  X
  6075   "RTN","CH8 35FU1",371 ,0)
  6076   RXDESC(I)  ;                                                 DRUG  NAME (CHL ORTHALIDON E)
  6077   "RTN","CH8 35FU1",372 ,0)
  6078            N  X S X=""
  6079   "RTN","CH8 35FU1",373 ,0)
  6080            S  X=$P($G(^ CHMPDX(I,0 )),"^",1)
  6081   "RTN","CH8 35FU1",374 ,0)
  6082            Q  X
  6083   "RTN","CH8 35FU1",375 ,0)
  6084   PROC(I)  ;
  6085   "RTN","CH8 35FU1",376 ,0)
  6086            N  X S X=""
  6087   "RTN","CH8 35FU1",377 ,0)
  6088            Q :I="" X
  6089   "RTN","CH8 35FU1",378 ,0)
  6090            S  X=$P($G(^ CHMSERV(I, 0)),"^",1)
  6091   "RTN","CH8 35FU1",379 ,0)
  6092            Q  X
  6093   "RTN","CH8 35FU1",380 ,0)
  6094   PROCDESC(I ) ;
  6095   "RTN","CH8 35FU1",381 ,0)
  6096            N  X,TYPE,NO DE,J S X=" "
  6097   "RTN","CH8 35FU1",382 ,0)
  6098            Q :I="" X
  6099   "RTN","CH8 35FU1",383 ,0)
  6100            S  TYPE=$P($ G(^CHMSERV (I,0)),"^" ,5)
  6101   "RTN","CH8 35FU1",384 ,0)
  6102            S :TYPE="HCP CS" NODE=1
  6103   "RTN","CH8 35FU1",385 ,0)
  6104            S :TYPE="CPT " NODE=40
  6105   "RTN","CH8 35FU1",386 ,0)
  6106            S :TYPE="ADA " NODE=20
  6107   "RTN","CH8 35FU1",387 ,0)
  6108            S :TYPE="ICD -9" NODE=3 0
  6109   "RTN","CH8 35FU1",388 ,0)
  6110            S :TYPE="ICD -10" NODE= 30  ; RFE  10/20/16 D EV026722
  6111   "RTN","CH8 35FU1",389 ,0)
  6112            G :TYPE="" P ROCDX
  6113   "RTN","CH8 35FU1",390 ,0)
  6114            G :'$D(NODE)  PROCDX
  6115   "RTN","CH8 35FU1",391 ,0)
  6116            S  J=0
  6117   "RTN","CH8 35FU1",392 ,0)
  6118            S  J=$O(^CHM SERV(I,1,J ))
  6119   "RTN","CH8 35FU1",393 ,0)
  6120            G :'J PROCDX
  6121   "RTN","CH8 35FU1",394 ,0)
  6122            S  X=$P($G(^ CHMSERV(I, 1,J,NODE)) ,"^",1)
  6123   "RTN","CH8 35FU1",395 ,0)
  6124   PROCDX   Q  X
  6125   "RTN","CH8 35FU1",396 ,0)
  6126            ;
  6127   "RTN","CH8 35FU1",397 ,0)
  6128   REVCD(I) ;
  6129   "RTN","CH8 35FU1",398 ,0)
  6130            N  X S X=""
  6131   "RTN","CH8 35FU1",399 ,0)
  6132            S  X=$P($G(^ CHMXDIC(74 1201.39,I, 0)),"^",1)
  6133   "RTN","CH8 35FU1",400 ,0)
  6134            Q  X
  6135   "RTN","CH8 35FU1",401 ,0)
  6136   REJCD(I) ;
  6137   "RTN","CH8 35FU1",402 ,0)
  6138            N  X S X=""
  6139   "RTN","CH8 35FU1",403 ,0)
  6140            S  X=$P($G(^ CHMDIC(741 002.22,I,0 )),"^",1)        ; PR OBLEM STAT US CODE
  6141   "RTN","CH8 35FU1",404 ,0)
  6142            Q  X
  6143   "RTN","CH8 35FU1",405 ,0)
  6144   REJTYPE(I)  ;
  6145   "RTN","CH8 35FU1",406 ,0)
  6146            N  X S X=""
  6147   "RTN","CH8 35FU1",407 ,0)
  6148            S  X=$P($G(^ CHMDIC(741 002.22,I,0 )),"^",7)        ; TY PE OF REAS ON (INFORM ATION/REJE CT)
  6149   "RTN","CH8 35FU1",408 ,0)
  6150            Q  X
  6151   "RTN","CH8 35FU1",409 ,0)
  6152   CD9CODE(I)  ;
  6153   "RTN","CH8 35FU1",410 ,0)
  6154            N  X S X=""
  6155   "RTN","CH8 35FU1",411 ,0)
  6156            S  X=$P($G(^ CHMICDX(I, 0)),"^",2)
  6157   "RTN","CH8 35FU1",412 ,0)
  6158            Q  X
  6159   "RTN","CH8 35FU1",413 ,0)
  6160   CD9DESC(I)  ;
  6161   "RTN","CH8 35FU1",414 ,0)
  6162            N  X S X=""
  6163   "RTN","CH8 35FU1",415 ,0)
  6164            S  X=$P($G(^ CHMICDX(I, 0)),"^",1)
  6165   "RTN","CH8 35FU1",416 ,0)
  6166            Q  X
  6167   "RTN","CH8 35FU1",417 ,0)
  6168            ;
  6169   "RTN","CH8 35FU1",418 ,0)
  6170   PMETHOD(CI ,PAMT)                                                                       ; DETERMIN E PMETHOD  FROM REJEC T STATUS A ND PAYMENT  AMOUNT
  6171   "RTN","CH8 35FU1",419 ,0)
  6172            N  PMETHOD
  6173   "RTN","CH8 35FU1",420 ,0)
  6174            S  PMETHOD=" NON"
  6175   "RTN","CH8 35FU1",421 ,0)
  6176            ; SBB 02/23/ 2018 CC400 2-003 chan ge for FC  8 on void  we pay not hing.
  6177   "RTN","CH8 35FU1",422 ,0)
  6178            I  (REV835=2 2) Q PMETH OD
  6179   "RTN","CH8 35FU1",423 ,0)
  6180            I  $P(^CHMPA Y(CI,0),"^ ",2)'=0  D                                             ; NOT REJE CTED STATU S
  6181   "RTN","CH8 35FU1",424 ,0)
  6182            . I PAMT>0   D                                                                                  ; PA YMENT AMOU NT FROM ^C HMEDI FILE
  6183   "RTN","CH8 35FU1",425 ,0)
  6184            . .S PMETHOD ="CHK"
  6185   "RTN","CH8 35FU1",426 ,0)
  6186            . .S:$P($G(^ CHMPAY(CI, 7)),"^",7) '="" PMETH OD="ACH"                ; EFT IN DICATOR
  6187   "RTN","CH8 35FU1",427 ,0)
  6188            Q  PMETHOD
  6189   "RTN","CH8 35FU1",428 ,0)
  6190            ;
  6191   "RTN","CH8 35FU1",429 ,0)
  6192   RCVDFI(VEN I)                                                                           ; VENDOR B ANK DFI
  6193   "RTN","CH8 35FU1",430 ,0)
  6194            N  DFI
  6195   "RTN","CH8 35FU1",431 ,0)
  6196            S  DFI=$P($G (^CHMVEN(V ENI,3)),"^ ",3)
  6197   "RTN","CH8 35FU1",432 ,0)
  6198            I  DFI'="" S  DFI=$$STR IP^XLFSTR( DFI," ")                           ; REMOVE  SPACES FR OM DFI
  6199   "RTN","CH8 35FU1",433 ,0)
  6200            Q  DFI
  6201   "RTN","CH8 35FU1",434 ,0)
  6202            ;
  6203   "RTN","CH8 35FU1",435 ,0)
  6204            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  6205   "RTN","CH8 35FU1",436 ,0)
  6206            ;  LINE ITEM  CONTROL N UMBER RETR IEVAL. THE  LICTL# IS  A VALUE P ROVIDED BY  THE
  6207   "RTN","CH8 35FU1",437 ,0)
  6208            ;  VENDOR AN D STORED I N THE ^CHM XCLF() BUF FER. THE P URPOSE OF  THE LICTL#  IS
  6209   "RTN","CH8 35FU1",438 ,0)
  6210            ;  TO ENABLE  THE VENDO R TO IDENT IFY THE LI NE ITEM IN  THE 835 R EPORT. THE  HAC
  6211   "RTN","CH8 35FU1",439 ,0)
  6212            ;  DOES NOT  USE THE LI CTL#, BUT  AN INTERNA LLY ASSIGN ED PDI#. T HIS ROUTIN E USES
  6213   "RTN","CH8 35FU1",440 ,0)
  6214            ;  THE HAC P DI TO RETR IEVE THE L ICTL#. THE  PSEUDO PD I IS GENER ATED IN CH MXP010.INT .
  6215   "RTN","CH8 35FU1",441 ,0)
  6216            ;  8/28/2012  DLB ADDED  SERVICE C ODE, BILLA MT AND DOS  TO MATCH  TEST FOR L INE CTRL/N UMBER RETU RN
  6217   "RTN","CH8 35FU1",442 ,0)
  6218            ;  1/9/2013  DLB MODIFI ED THE FUN CTION TO R ETRIEVE TH E ^CHMIMAG E() "L" IN DEX FROM ^ CHMPAY
  6219   "RTN","CH8 35FU1",443 ,0)
  6220            ;                                  AND THEN P ULL THE LI NE ITEM CT RL #/SVC L INE # FROM  ^CHMIMAGE
  6221   "RTN","CH8 35FU1",444 ,0)
  6222            ;  PROCESS:  1) RETRIEV E THE PDI  FROM ^CHMP AY(CI,0)," ^",4)
  6223   "RTN","CH8 35FU1",445 ,0)
  6224            ;                         2) EXTRA CT THE PDI TYPE FROM  THE PDI
  6225   "RTN","CH8 35FU1",446 ,0)
  6226            ;                         3) IF TH E PDI IS A  MEDICAL E DI CLAIM P DI
  6227   "RTN","CH8 35FU1",447 ,0)
  6228            ;                                  A) IF THE  PDI WAS CR EATED AFTE R THE GO-L IVE DATE
  6229   "RTN","CH8 35FU1",448 ,0)
  6230            ;                                          a)  REETRIEVE  THE LINE  ITEM CONTR OL NUMBER  FROM ^CHMI MAGE()
  6231   "RTN","CH8 35FU1",449 ,0)
  6232            ;                                  B) IF THE  PDI WAS CR EATED PRIO R TO THE G O-LIVE DAT E
  6233   "RTN","CH8 35FU1",450 ,0)
  6234            ;                                          a)  RETRIEVE  THE LINE I TEM CONTRO L NUMBER F ROM ^CHMXC LE()
  6235   "RTN","CH8 35FU1",451 ,0)
  6236            ;                         4) IF TH E PDI IS A  PHARMACY  CLAIM PDI
  6237   "RTN","CH8 35FU1",452 ,0)
  6238            ;                                  A) RETRIEV E THE PRES CRIPTION N UMBER FROM  ^CHMXRX()  
  6239   "RTN","CH8 35FU1",453 ,0)
  6240            ;                         5) RETRU N THE RETR IEVED VALU E TO CALLE R
  6241   "RTN","CH8 35FU1",454 ,0)
  6242            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  6243   "RTN","CH8 35FU1",455 ,0)
  6244            ;
  6245   "RTN","CH8 35FU1",456 ,0)
  6246   GTLICTL(CI ,JI,TOS,LI NE)          ; 6/6/20 12 DLB  AD DED FUNCTI ON TO RETR IEVE LINE  ITEM CONTR OL NUMBER  FOR ^CHMPA Y CLAIM IN DEX
  6247   "RTN","CH8 35FU1",457 ,0)
  6248            ;  CI            "I" IN DEX FOR ^C HMPAY
  6249   "RTN","CH8 35FU1",458 ,0)
  6250            ;  JI            "J" IN DEX FOR ^C HMPAY
  6251   "RTN","CH8 35FU1",459 ,0)
  6252            ;  TOS           TYPE O F SERVICE
  6253   "RTN","CH8 35FU1",460 ,0)
  6254            ;  SERVICE L INE # FOR  PRE-SLA CL AIMS
  6255   "RTN","CH8 35FU1",461 ,0)
  6256            N  PDI,PDITY PE,LINCTL, IMGL
  6257   "RTN","CH8 35FU1",462 ,0)
  6258            ; U 0 W !,"      FU1: G TLICTL: CH MPAY(I)= " ,CI,"  PAY J= ",JI,"   TOS= ",TO S,"  SVC L INE= ",LIN E
  6259   "RTN","CH8 35FU1",463 ,0)
  6260            S  (CLMTYP,P DI,KI,LIDX ,INFO,IMGT YP,IMGFLD, PAYFLD)="" ,LINCTL="N O LICTL"
  6261   "RTN","CH8 35FU1",464 ,0)
  6262            S  PDI=$P($P (^CHMPAY(C I,0),"^",4 ),"*",1)                           ; PDI FR OM ^CHMPAY
  6263   "RTN","CH8 35FU1",465 ,0)
  6264            S  PDITYPE=$ E(PDI,8,9)                                                                ;  GET CLAIM  TYPE FROM  PDI
  6265   "RTN","CH8 35FU1",466 ,0)
  6266            ; U 0 W !,"      FU1: G TLICTL: PD I / PDI TY PE= ",PDI_ " / "_PDIT YPE
  6267   "RTN","CH8 35FU1",467 ,0)
  6268            I  (PDITYPE= 91)!(PDITY PE=92)!(PD ITYPE=93)   D             ; MEDI CAL EDI CL AIMS
  6269   "RTN","CH8 35FU1",468 ,0)
  6270            . I $$SLADAT E(PDI)  D                                                                 ;  CHECK CLAI M DATE VS  SLA ACTIVE  DATE
  6271   "RTN","CH8 35FU1",469 ,0)
  6272            . .S LINCTL= $$GETIMGLI (PDI,CI,JI ,TOS)                              ; ROUTIN E TO RETRI EVE ^CHMIM AGE LICTL
  6273   "RTN","CH8 35FU1",470 ,0)
  6274            . .;U 0 W !, "     FU1:  GTLICTL:   ^CHMIMAGE  LICTL=",L INCTL
  6275   "RTN","CH8 35FU1",471 ,0)
  6276            . E  D                                                                                                   ; NEW  CLAIMS GET  LICTL FRO M ^CHMIMAG E
  6277   "RTN","CH8 35FU1",472 ,0)
  6278            . .S LINCTL= $$GETCLBLI (PDI,LINE)                                             ; OLD CLAI MS GET LIC TL FROM CL AIM BUFFER S
  6279   "RTN","CH8 35FU1",473 ,0)
  6280            . .;U 0 W !, "     FU1:  GTLICTL:   ^CLAIM BU FFER LICTL =",LINCTL
  6281   "RTN","CH8 35FU1",474 ,0)
  6282            E   I PDITYP E=99  D                                                                            ; PH ARMACY CLA IMS (NOT D ATE SENSIT IVE)
  6283   "RTN","CH8 35FU1",475 ,0)
  6284                     ..S  IMGL=$P(^ CHMPAY(CI, "PHARM",JI ,1,1,0),"^ ",17)
  6285   "RTN","CH8 35FU1",476 ,0)
  6286            . .S LINCTL= $$GETPHPN( PDI,"RX-NS ",IMGL)                                                      ; PH ARMACY PRE SC. NUMBER
  6287   "RTN","CH8 35FU1",477 ,0)
  6288            Q  LINCTL
  6289   "RTN","CH8 35FU1",478 ,0)
  6290            ;
  6291   "RTN","CH8 35FU1",479 ,0)
  6292            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  6293   "RTN","CH8 35FU1",480 ,0)
  6294            ;  GETIMGLI( ) RETURNS  THE LINE I TEM CONTRO L NUMBER F ROM ^CHMIM AGE
  6295   "RTN","CH8 35FU1",481 ,0)
  6296            ;  PROCESS:   1) THE TO S IS USED  TO DETERMI NE THE COR RECT ^CHMP AY() NODE/ FIELD ADDR ESS 
  6297   "RTN","CH8 35FU1",482 ,0)
  6298            ;                         2) RETRI EVE THE "K " INDEX FO R ^CHMPAY( )
  6299   "RTN","CH8 35FU1",483 ,0)
  6300            ;                         3) FIELD  17 CONTAI NS THE ^CH MIMAGE "L"  INDEX
  6301   "RTN","CH8 35FU1",484 ,0)
  6302            ;                         4) THE T OS IS USED  TO DETERM INE THE CO RRECT ^CHM IMAGE NODE /FIELD ADD RESSING
  6303   "RTN","CH8 35FU1",485 ,0)
  6304            ;                         5) THE L ICTL IS RE TRIEVED FR OM ^CHMIMA GE()
  6305   "RTN","CH8 35FU1",486 ,0)
  6306            ;                         6) THE L INCTL IS S TORED TO T HE ^CHMPAY (CI,CLMTYP ,JI,0) EDI  LINE IDEN TIFIER FIE LD
  6307   "RTN","CH8 35FU1",487 ,0)
  6308            ;  11/4/2015   DLB ADDE D RETRIEVA L FOR ^CHM IMAGE() "J " AND "K"  INDEXES FO R "IMGL"
  6309   "RTN","CH8 35FU1",488 ,0)
  6310            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  6311   "RTN","CH8 35FU1",489 ,0)
  6312            ;
  6313   "RTN","CH8 35FU1",490 ,0)
  6314   GETIMGLI(P DI,PAYI,PA YJ,TOS) 
  6315   "RTN","CH8 35FU1",491 ,0)
  6316            ;  PDI           HAC IN TERNAL CLA IM IDENTIF IER
  6317   "RTN","CH8 35FU1",492 ,0)
  6318            ;  PAYI          "I" IN DEX TO ^CH MPAY()
  6319   "RTN","CH8 35FU1",493 ,0)
  6320            ;  PAYJ          "J" IN DEX YO ^CH MPAY()
  6321   "RTN","CH8 35FU1",494 ,0)
  6322            ;  TOS           "OPT", "TRV","DUR ","DEN" CL AIM DESCRI PTOR
  6323   "RTN","CH8 35FU1",495 ,0)
  6324                     N P AYK,IMGL,I MGINFO,PAY INFO,PAYTY P,PAYFLD,I MGTYP,IMGF LD,LINCTL, IDXS,JDX,K DX
  6325   "RTN","CH8 35FU1",496 ,0)
  6326            S  LINCTL="N /A"
  6327   "RTN","CH8 35FU1",497 ,0)
  6328            S  PAYINFO=$ S(TOS="OPT ":"OPT-PRO C*18",TOS= "TRV":"OPT -PROC*18", TOS="DUR": "DME-SUPPL Y:10",TOS= "DEN":"DEN -PROC:12")  ; GET THE  ^CHMPAY T OS INDEX
  6329   "RTN","CH8 35FU1",498 ,0)
  6330            S  PAYTYP=$P (PAYINFO," *",1),PAYF LD=$P(PAYI NFO,"*",2)              ; GET TH E CORRECT  NODE/FIELD  ADDRESSIN G
  6331   "RTN","CH8 35FU1",499 ,0)
  6332            S  PAYK=0
  6333   "RTN","CH8 35FU1",500 ,0)
  6334            F   S PAYK=$ O(^CHMPAY( PAYI,PAYTY P,JI,1,PAY K))   Q:+( PAYK)=0  D   ; ^CHMPA Y "K" INDE X CONTAINS  ^CHMIMAGE  "L" INDEX
  6335   "RTN","CH8 35FU1",501 ,0)
  6336            . S IMGL=$P( ^CHMPAY(PA YI,PAYTYP, PAYJ,1,PAY K,0),"^",1 7)                            ;  PT TO CHMI MAGE LINE  ("L" INDEX )
  6337   "RTN","CH8 35FU1",502 ,0)
  6338            . I IMGL=""  ;U 0 W !,"      FU1:  GETIMGLI:   ^CHMPAY(" ,CI,",",PA YTYP,",",P AYJ,",1,", PAYK,",0)=  ",^CHMPAY (PAYI,PAYT YP,PAYJ,1, PAYK,0) 
  6339   "RTN","CH8 35FU1",503 ,0)
  6340            . S IMGINFO= $S(TOS="OP T":"OPT-NS *16",TOS=" TRV":"OPT- NS*16",TOS ="DUR":"DM E-NS*14",T OS="DEN":" DENTAL-NS* 15") ; GET  THE ^CHMI MAGE TOS I NDEX*FIELD
  6341   "RTN","CH8 35FU1",504 ,0)
  6342            . S IMGTYP=$ P(IMGINFO, "*",1),IMG FLD=$P(IMG INFO,"*",2 )            ; EXTRAC T THE CLAI M TYPE/FIE LD INFO
  6343   "RTN","CH8 35FU1",505 ,0)
  6344                     .S  IDXS=$$GET IDX^CHTFLI B5(PDI,IMG TYP,IMGL)                                                  ; GET  THE ^CHMIM AGE "J" AN D "K" INDE XES FOR "I MGL"
  6345   "RTN","CH8 35FU1",506 ,0)
  6346                     .S  JDX=$P(IDX S,"^",1),K DX=$P(IDXS ,"^",2)
  6347   "RTN","CH8 35FU1",507 ,0)
  6348                     .I  $D(^CHMIMA GE(PDI,1,J DX,2,KDX,I MGTYP,IMGL ,0))  D
  6349   "RTN","CH8 35FU1",508 ,0)
  6350                     ..S  LINCTL=$P (^CHMIMAGE (PDI,1,JDX ,2,KDX,IMG TYP,IMGL,0 ),"^",IMGF LD)     ;  LINE ITEM  CTRL # OR  SVC LINE #
  6351   "RTN","CH8 35FU1",509 ,0)
  6352                     ..I  LINCTL=""  ;U 0 W !, "     FU1:  GETIMGLI:  ^CHMIMAGE (",PDI,",1 ,",JDX,",2 ,",KDX,"," ,IMGTYP,", ",IMGL,",0 ) = ",^CHM IMAGE(PDI, 1,JDX,2,KD X,IMGTYP,I MGL,0)
  6353   "RTN","CH8 35FU1",510 ,0)
  6354            . S $P(^CHMP AY(CI,PAYT YP,JI,0)," ^",PAYFLD) =LINCTL_"^ "_PDI_"*"_ 1_"*"_1_"* "_IMGTYP_" *"_LIDX                 ; WRITE  THE EDI LI NE ID TO ^ CHMPAY()
  6355   "RTN","CH8 35FU1",511 ,0)
  6356            ; U 0 W !,"      FU1: P OST SLA GO -LIVE ^CHM IMAGE LICT L: LINCTL=  ",$S(LINC TL="": "NU LL",1:LINC TL)
  6357   "RTN","CH8 35FU1",512 ,0)
  6358            Q  LINCTL
  6359   "RTN","CH8 35FU1",513 ,0)
  6360            ;
  6361   "RTN","CH8 35FU1",514 ,0)
  6362            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  6363   "RTN","CH8 35FU1",515 ,0)
  6364            ;  SLADATE()  FUNCTION  IS USED TO  DETERMINE  IF THE CL AIM WAS IN  THE CP&E  SYSTEM
  6365   "RTN","CH8 35FU1",516 ,0)
  6366            ;  PRIOR TO  THE GO-ACT IVE DATE F OR SERVICE  LINE ADJU DICATION.  THE JULIAN  DATE
  6367   "RTN","CH8 35FU1",517 ,0)
  6368            ;  WILL HAVE  TO BE SET  TO THE GO -ACTIVE DA TE PRIOR T O RELEASE.  THE TEST  UTILIZES T HE
  6369   "RTN","CH8 35FU1",518 ,0)
  6370            ;  PDI JULIA N DATE AS  THE DETERM INING FACT OR.
  6371   "RTN","CH8 35FU1",519 ,0)
  6372            ;  PROCESS:   1) SET TH E GO-ACTIV E DATE FOR  SERVICE L INE ADJUDI CATION (AC TDATE)
  6373   "RTN","CH8 35FU1",520 ,0)
  6374            ;                         2) IF PD I CREATED  BEFORE 201 3, RETRUN  0
  6375   "RTN","CH8 35FU1",521 ,0)
  6376            ;                         3) IF PD I CREATED  ON OR AFTE R GO-ACTIV E DATE RET URN 1
  6377   "RTN","CH8 35FU1",522 ,0)
  6378            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  6379   "RTN","CH8 35FU1",523 ,0)
  6380            ;
  6381   "RTN","CH8 35FU1",524 ,0)
  6382   SLADATE(PD I) 
  6383   "RTN","CH8 35FU1",525 ,0)
  6384            ;  PDI  CLAI M PDI FROM  ^CHMPAY
  6385   "RTN","CH8 35FU1",526 ,0)
  6386            N  VDATE,ACT DATE,RETUR N
  6387   "RTN","CH8 35FU1",527 ,0)
  6388                     S A CTDATE=188                                                        ; JULIAN D ATE FOR SL A GO-LIVE
  6389   "RTN","CH8 35FU1",528 ,0)
  6390            S  RETURN=0                                ;  ASSUME THE  CLAIM DOE S NOT MEET  SLA DATE  REQUIREMEN T
  6391   "RTN","CH8 35FU1",529 ,0)
  6392            I  $E(PDI,1, 4)'<2013   D                  ;  IF OLDER T HAN 2013 D ON'T TEST  JULIAN DAT E
  6393   "RTN","CH8 35FU1",530 ,0)
  6394                     .I  $E(PDI,5,7 )'<ACTDATE   D                                ; IF BEF ORE THE SL A GO-LIVE  JULIAN DAT E
  6395   "RTN","CH8 35FU1",531 ,0)
  6396            . .S RETURN= 1                             ;  VALID SLA  CLAIM BASE D ON DATE
  6397   "RTN","CH8 35FU1",532 ,0)
  6398            Q  RETURN
  6399   "RTN","CH8 35FU1",533 ,0)
  6400            ;
  6401   "RTN","CH8 35FU1",534 ,0)
  6402            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  6403   "RTN","CH8 35FU1",535 ,0)
  6404            ;  GETCLBLI( ) ATTEMPTS  TO RETURN  THE LINE  ITEM CONTR OL NUMBER  FROM THE
  6405   "RTN","CH8 35FU1",536 ,0)
  6406            ;  CLAIM BUF FERS. THIS  IS USED F OR CLAIMS  PROCESSED  PRIOR TO T HE GO-ACTI VE
  6407   "RTN","CH8 35FU1",537 ,0)
  6408            ;  FOR SERVI CE LINE AD JUDICATION .  THE "L"  INDEX POI NTER FOR ^ CHMIMAGE 
  6409   "RTN","CH8 35FU1",538 ,0)
  6410            ;  WILL NOT  BE POPULAT ED IN ^CHM PAY() UNTI L SLA IS A CTIVE.
  6411   "RTN","CH8 35FU1",539 ,0)
  6412            ;  PROCESS:  1) GET CLA IM BUFFER  INDEXES VI A UNDOCUME NTED ^CHMX CLE("PDI", PDI,PCN,XI ,IDXSTR) X REF
  6413   "RTN","CH8 35FU1",540 ,0)
  6414            ;                         2) EXTRA CT THE ^CH MXCLE(I) I NDEX
  6415   "RTN","CH8 35FU1",541 ,0)
  6416            ;                         3) LOOP  THROUGH TH E LINE ITE MS VIA THE  ^CHMXCLF( "B", ^CHMX CLE(I)) XR EF
  6417   "RTN","CH8 35FU1",542 ,0)
  6418            ;                         4) FIND  THE ^CHMXC LF() LINE  ENTRY MATC HING THE T ARGET LINE  ENTRY
  6419   "RTN","CH8 35FU1",543 ,0)
  6420            ;                         5) RETRI EVE THE LI NE ITEM CO NTROL NUMB ER
  6421   "RTN","CH8 35FU1",544 ,0)
  6422            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  6423   "RTN","CH8 35FU1",545 ,0)
  6424            ;
  6425   "RTN","CH8 35FU1",546 ,0)
  6426   GETCLBLI(P DI,LINE)                                          ; GE T LINE ITE M CTRL # F ROM ^CHMXC LE() CLAIM  BUFFER
  6427   "RTN","CH8 35FU1",547 ,0)
  6428            ;  PDI  TARG ETED CLAIM  PDI
  6429   "RTN","CH8 35FU1",548 ,0)
  6430            ;  LINE TARG ETED LINE  NUMBER
  6431   "RTN","CH8 35FU1",549 ,0)
  6432            ;
  6433   "RTN","CH8 35FU1",550 ,0)
  6434            ; U 0 W !,"      FU1: P RE-SLA: GE TCLBLI: PD I: ",PDI,"    TARGET  LINE: ",LI NE 
  6435   "RTN","CH8 35FU1",551 ,0)
  6436            N  IDXSTR,CH EI,CHFI,LI NCTL,CNT,M ATCH
  6437   "RTN","CH8 35FU1",552 ,0)
  6438            S  LINCTL="N /A",MATCH= 0
  6439   "RTN","CH8 35FU1",553 ,0)
  6440            S  IDXSTR=$$ GETCLMI(PD I)                                                                      ; GE T THE CLAI M BUFFER I NDEXES
  6441   "RTN","CH8 35FU1",554 ,0)
  6442            I  IDXSTR'=" "  D
  6443   "RTN","CH8 35FU1",555 ,0)
  6444            . S CHEI=$P( IDXSTR,"*" ,4) Q:+(CH EI)=0                                       ; CLAIM BU FFER
  6445   "RTN","CH8 35FU1",556 ,0)
  6446            . S CHFI=0,R ESULT=""                                                                           ; RE ADY TO RET RIEVE ^CHM XCLF(I) FO R LINE
  6447   "RTN","CH8 35FU1",557 ,0)
  6448            . F  S CHFI= $O(^CHMXCL F("B",CHEI ,CHFI)) Q: +(CHFI)=0   D  ; GET  THE CORREC T LINE NUM BER
  6449   "RTN","CH8 35FU1",558 ,0)
  6450            . .I $P(^CHM XCLF(CHFI, 0),"^",2)= LINE  D
  6451   "RTN","CH8 35FU1",559 ,0)
  6452            . ..S MATCH= 1
  6453   "RTN","CH8 35FU1",560 ,0)
  6454            . ..;U 0 W ! ,"     FU1 : CLM BUFF ER I = ",C HEI,"  LIN E BUFFER:  I= ",CHFI  ; NOTE THE  LINE THAT  MATCHES T HE TARGET  LINE 
  6455   "RTN","CH8 35FU1",561 ,0)
  6456            . ..S LINCTL =$P(^CHMXC LF(CHFI,1) ,"^",23)                                    ; RETRIEVE  THE LINE  ITEM CONTR OL NUMBER
  6457   "RTN","CH8 35FU1",562 ,0)
  6458            ; U 0 W !,"      ***FU1 : GETCLBLI : LINE: ", LINE," MAT CH= ",MATC H,"  LICTL = ",$S(LIN CTL="":"NU LL",1:LINC TL)
  6459   "RTN","CH8 35FU1",563 ,0)
  6460            Q  LINCTL
  6461   "RTN","CH8 35FU1",564 ,0)
  6462            ;
  6463   "RTN","CH8 35FU1",565 ,0)
  6464            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  6465   "RTN","CH8 35FU1",566 ,0)
  6466            ;  GETREND()  RETURNS T HE RENDERI NG PHYSICI AN TIN FOR  A LINE FR OM THE ^CH MXCLF() BU FFER
  6467   "RTN","CH8 35FU1",567 ,0)
  6468            ;  THE LICTR L VALUE PR OVIDED TO  THIS FUNCT ION IS PUL LED FROM ^ CHMIMAGE ( VALUE SET  DURING 
  6469   "RTN","CH8 35FU1",568 ,0)
  6470            ;  THE LOAD/ FRONT END  EDIT PROCE SS, AND IS  1) THE PR OVIDED LIN E ITME CON TROL NUMBE R, OR
  6471   "RTN","CH8 35FU1",569 ,0)
  6472            ;  2) IF THE  SUBMITTER  DID NOT P ROVIDE A V ALUE, IT I S ASSIGNED  TO THE HA C LINE NUM BER ASSIGN ED
  6473   "RTN","CH8 35FU1",570 ,0)
  6474            ;  DURING TH E LOADING  PROCESS.
  6475   "RTN","CH8 35FU1",571 ,0)
  6476            ;  IF THE PR OVIDER DID  NOT PROVI DE A LICTR L NUMBER,  THEN THE L INE NUMBER  (^CHMXCLF (I,0),"^", 2)
  6477   "RTN","CH8 35FU1",572 ,0)
  6478            ;  IS PREPEN DED WITH " HAC", MARK ING THE VA LUE SO PRO GRAMMERS C AN TELL A  PROVIDED N UMBER FROM
  6479   "RTN","CH8 35FU1",573 ,0)
  6480            ;  AN INTERN ALLY GENER ATED LINE  ITEM CONTR OL NUMBER  THIS VALUE  ("HAC"_LI NE NUMBER)  IS STORED  
  6481   "RTN","CH8 35FU1",574 ,0)
  6482            ;  IN THE LI NE ITEM CO NTROL NUMB ER FIELD ( ^CHMXCLF(I ,1),"^",23 )
  6483   "RTN","CH8 35FU1",575 ,0)
  6484            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  6485   "RTN","CH8 35FU1",576 ,0)
  6486            ;
  6487   "RTN","CH8 35FU1",577 ,0)
  6488   GETREND(PA YI,LICTRL)  
  6489   "RTN","CH8 35FU1",578 ,0)
  6490            ;  PAYI INDE X FOR RETR IEVAL OF P DI
  6491   "RTN","CH8 35FU1",579 ,0)
  6492            ;  LICTRL TA RGETED LIN E CONTROL  NUMBER
  6493   "RTN","CH8 35FU1",580 ,0)
  6494            ;
  6495   "RTN","CH8 35FU1",581 ,0)
  6496            N  IDXSTR,CH EI,CHFI,RE NDTIN,CNT, PDI,LINEID ,EXIT
  6497   "RTN","CH8 35FU1",582 ,0)
  6498            S  RENDTIN=" ",EXIT=0
  6499   "RTN","CH8 35FU1",583 ,0)
  6500            S  PDI=$P($P (^CHMPAY(P AYI,0),"^" ,4),"*",1)                                  ; RETRIEVE  THE PDI F ROM ^CHMPA Y
  6501   "RTN","CH8 35FU1",584 ,0)
  6502            S  IDXSTR=$$ GETCLMI(PD I)                                                                      ; GE T THE CLAI M BUFFER I NDEXES
  6503   "RTN","CH8 35FU1",585 ,0)
  6504            I  IDXSTR'=" "  D
  6505   "RTN","CH8 35FU1",586 ,0)
  6506            . S CHEI=$P( IDXSTR,"*" ,4) Q:+(CH EI)=0                                       ; CLAIM BU FFER
  6507   "RTN","CH8 35FU1",587 ,0)
  6508            . S CHFI=0                                                                                                        ; READY  TO RETRIEV E ^CHMXCLF (I) FOR RE NDERING PH YSICIAN
  6509   "RTN","CH8 35FU1",588 ,0)
  6510            . F  S CHFI= $O(^CHMXCL F("B",CHEI ,CHFI)) Q: +(CHFI)=0   Q:EXIT  D   ; GET TH E CURRENT  LINE NUMBE R
  6511   "RTN","CH8 35FU1",589 ,0)
  6512            . .S LINEID= $P(^CHMXCL F(CHFI,1), "^",23)                                     ; RETRIEVE  THE PROVI DED/ASSIGN ED LINE IT EM CTRL NU MBER
  6513   "RTN","CH8 35FU1",590 ,0)
  6514            . .I $E(LINE ID,1,3)="H AC" S LINE ID=$E(LINE ID,4,$L(LI NEID))       ; REMOVE  THE "HAC"  IDENTIFIE R
  6515   "RTN","CH8 35FU1",591 ,0)
  6516            . .I LINEID= LICTRL  D
  6517   "RTN","CH8 35FU1",592 ,0)
  6518            . ..S:$D(^CH MXCLF(CHFI ,64)) REND TIN=$P(^CH MXCLF(CHFI ,64),"^",4 ),EXIT=1           ;  RENDERING  PHYSICIAN  TIN
  6519   "RTN","CH8 35FU1",593 ,0)
  6520            Q  RENDTIN
  6521   "RTN","CH8 35FU1",594 ,0)
  6522            ;
  6523   "RTN","CH8 35FU1",595 ,0)
  6524            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  6525   "RTN","CH8 35FU1",596 ,0)
  6526            ;  GETPHPN()  RETURNS T HE PRESCRI PTION NUMB ER FOR PHA RMACY CLAI MS IN LIEU  OF THE
  6527   "RTN","CH8 35FU1",597 ,0)
  6528            ;  LINE ITEM  CONTROL N UMBER.
  6529   "RTN","CH8 35FU1",598 ,0)
  6530                     ; 1 1/4/2015   DLB ADDED  RETRIEVAL  FOR ^CHMIM AGE() "J"  AND "K" IN DEXES FOR  "IMGL" (GE TIDX^CHTFL IB5())
  6531   "RTN","CH8 35FU1",599 ,0)
  6532            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  6533   "RTN","CH8 35FU1",600 ,0)
  6534            ;
  6535   "RTN","CH8 35FU1",601 ,0)
  6536   GETPHPN(PD I,IMGTOS,I MGL)                          ;  PHARMACY P RESC. NUMB ER
  6537   "RTN","CH8 35FU1",602 ,0)
  6538                     ; P DI           CLAIM PD I ASSIGNED  
  6539   "RTN","CH8 35FU1",603 ,0)
  6540                     N P RNUM,IDXS, JDX,KDX
  6541   "RTN","CH8 35FU1",604 ,0)
  6542                     S P RNUM="PHAR MACY"
  6543   "RTN","CH8 35FU1",605 ,0)
  6544                     S I DXS=$$GETI DX^CHTFLIB 5(PDI,IMGT OS,IMGL)                                          ; GE T THE ^CHM IMAGE "J"  AND "K" IN DEXES FOR  "LIDX"
  6545   "RTN","CH8 35FU1",606 ,0)
  6546                     S J DX=$P(IDXS ,"^",1),KD X=$P(IDXS, "^",2)
  6547   "RTN","CH8 35FU1",607 ,0)
  6548                     I $ D(^CHMIMAG E(PDI,1,JD X,2,KDX,"R X-NS",IMGL ))  D
  6549   "RTN","CH8 35FU1",608 ,0)
  6550                     .S  PRNUM=$P(^ CHMIMAGE(P DI,1,1,2,1 ,"RX-NS",I MGL,0),"^" ,6)
  6551   "RTN","CH8 35FU1",609 ,0)
  6552            ; U 0 W !,"F U1: GETPHP N: PRESCRI PTION NUMB ER= ",PRNU M
  6553   "RTN","CH8 35FU1",610 ,0)
  6554            Q  PRNUM
  6555   "RTN","CH8 35FU1",611 ,0)
  6556            ;
  6557   "RTN","CH8 35FU1",612 ,0)
  6558            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  6559   "RTN","CH8 35FU1",613 ,0)
  6560            ;  GETCLMI()  RETURNS T HE CLAIM B UFFER INDE XES EXTRAC TED FROM T HE UNDOCUM ENTED
  6561   "RTN","CH8 35FU1",614 ,0)
  6562            ;  ^CHMXCLE( "PDI",PDI, PCN,XI))FI LE BUFFER  INDEX.
  6563   "RTN","CH8 35FU1",615 ,0)
  6564            ;  PROCESS:   1) THE PD I IS USED  IN THE XRE F TO RETRI EVE THE CL AIM BUFFER  INDEX STR ING
  6565   "RTN","CH8 35FU1",616 ,0)
  6566            ;                         2) RETUR N THE STRI NG INTACT
  6567   "RTN","CH8 35FU1",617 ,0)
  6568            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  6569   "RTN","CH8 35FU1",618 ,0)
  6570            ;
  6571   "RTN","CH8 35FU1",619 ,0)
  6572   GETCLMI(PD I) 
  6573   "RTN","CH8 35FU1",620 ,0)
  6574            ;  PDI  INTE RNAL HAC C LAIM ID
  6575   "RTN","CH8 35FU1",621 ,0)
  6576            N  PCN,XI,ID XSTR
  6577   "RTN","CH8 35FU1",622 ,0)
  6578            S  IDXSTR=""
  6579   "RTN","CH8 35FU1",623 ,0)
  6580            S  PCN="",PC N=$O(^CHMX CLE("PDI", PDI,PCN))                                   ; EXTRACT  THE PCN VA LUE
  6581   "RTN","CH8 35FU1",624 ,0)
  6582            I  PCN  D
  6583   "RTN","CH8 35FU1",625 ,0)
  6584            . S XI="",XI =$O(^CHMXC LE("PDI",P DI,PCN,XI) )                                ; FILE BUF FER INDEX
  6585   "RTN","CH8 35FU1",626 ,0)
  6586            . S:XI IDXST R=0,IDXSTR =$O(^CHMXC LE("PDI",P DI,PCN,XI, IDXSTR)) ;  A->E CLAI M BUFFER I NDEXES
  6587   "RTN","CH8 35FU1",627 ,0)
  6588            Q  IDXSTR
  6589   "RTN","CH8 35FU1",628 ,0)
  6590            ;
  6591   "RTN","CH8 35FU1",629 ,0)
  6592            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  6593   "RTN","CH8 35FU1",630 ,0)
  6594            ;  TSTLICTL( ) PROCIDES  A MEANS T O TEST THE  GTLICTL()  FUNCTION
  6595   "RTN","CH8 35FU1",631 ,0)
  6596            ;  NOTE: THE RE IS NO R EVERSE XRE F FOR THE  SERVICE CO DE STORED  IN ^CHMXCL F,
  6597   "RTN","CH8 35FU1",632 ,0)
  6598            ;  SO YOU MU ST CONVERT  THE ^CHMP AY SERVICE  CODE IN O RDER TO CO MPARE.
  6599   "RTN","CH8 35FU1",633 ,0)
  6600            ;  THIS IS D ONE IN THE  GTLICTL()  FUNCTION.
  6601   "RTN","CH8 35FU1",634 ,0)
  6602            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  6603   "RTN","CH8 35FU1",635 ,0)
  6604            ;
  6605   "RTN","CH8 35FU1",636 ,0)
  6606   TSTLICTL(H ACNUM) 
  6607   "RTN","CH8 35FU1",637 ,0)
  6608            ;  HACNUM                 HAC CLAI M NUMBER F ROM ^CHMPA Y (AAA1234 )
  6609   "RTN","CH8 35FU1",638 ,0)
  6610            N  CI,LICTL, PCN,SERVI, PDI,J
  6611   "RTN","CH8 35FU1",639 ,0)
  6612            S  (CI,J)=0
  6613   "RTN","CH8 35FU1",640 ,0)
  6614            S  CI=$O(^CH MPAY("B",H ACNUM,CI))                                                     ;  GET ^CHMPA Y "I" INDE X
  6615   "RTN","CH8 35FU1",641 ,0)
  6616            F   S J=$O(^ CHMPAY(CI, "OPT-PROC" ,J)) Q:'J   D                      ; DO ALL  "Js" (TYP ICALLY 1 E NTRY)
  6617   "RTN","CH8 35FU1",642 ,0)
  6618            . S SERVI=$P (^CHMPAY(C I,"OPT-PRO C",J,0),"^ ",1)                    ; RETRIE VE THE ^CH MPAY "SERV I"
  6619   "RTN","CH8 35FU1",643 ,0)
  6620            . ;U 0 W !," TSTLICTL:  HACNUM= ", HACNUM,"   J= ",J,"   PDI= ",PDI ,"  PCN= " ,PCN,"  SE RVI= ",SER VI
  6621   "RTN","CH8 35FU1",644 ,0)
  6622            . S LICTL=$$ GTLICTL(CI ,SERVI)
  6623   "RTN","CH8 35FU1",645 ,0)
  6624            . ;U 0 W !," LICTL= ",L ICTL
  6625   "RTN","CH8 35FU1",646 ,0)
  6626            Q
  6627   "RTN","CH8 35FU1",647 ,0)
  6628            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  6629   "RTN","CH8 35FU1",648 ,0)
  6630            ;  NDC RETRI EVAL. THE  PRESCRIPTI ON# IS THE  UNIQUE VA LUE PROVID ED 
  6631   "RTN","CH8 35FU1",649 ,0)
  6632            ;  BY THE VE NDOR AND S TORED IN T HE ^CHMXRX () BUFFER.  THE PURPO SE OF THE  RETURNING
  6633   "RTN","CH8 35FU1",650 ,0)
  6634            ;  THE PRESC RIPTION# I S TO ENABL E THE VEND OR TO IDEN TIFY THE L INE ITEM I N THE 835 
  6635   "RTN","CH8 35FU1",651 ,0)
  6636            ;  REPORT. T HE HAC DOE S NOT USE  THE PRESCR IPTION#, B UT AN INTE RNALLY ASS IGNED PDI# .
  6637   "RTN","CH8 35FU1",652 ,0)
  6638            ;  THIS ROUT INE USES T HE HAC PDI  TO RETRIE VE THE PRE SCRIPTION#
  6639   "RTN","CH8 35FU1",653 ,0)
  6640            ;  8/28/2012  DLB ADDED  MATCH CHE CK FOR NDC ,DOS, AND  BILL AMT F OR LINE IT EM SEARCH
  6641   "RTN","CH8 35FU1",654 ,0)
  6642            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  6643   "RTN","CH8 35FU1",655 ,0)
  6644            ;
  6645   "RTN","CH8 35FU1",656 ,0)
  6646   GTPRESC(CI ,XPDI,CHGA MT,DOS)      ; 6/6/20 12 DLB  AD DED FUNCTI ON TO RETR IEVE PRESC RIPTION NU MBER FOR ^ CHMPAY CLA IM INDEX
  6647   "RTN","CH8 35FU1",657 ,0)
  6648            ;  CI            CLAIM  INDEX VALU E FOR ^CHM PAY
  6649   "RTN","CH8 35FU1",658 ,0)
  6650            ;  XPDI          PDI NU MBER FROM  ^CHMPAY
  6651   "RTN","CH8 35FU1",659 ,0)
  6652            ;  CHGAMT        CHARGE  AMOUNT FR OM ^CHMPAY
  6653   "RTN","CH8 35FU1",660 ,0)
  6654            ;  DOS           DATE O F SERVICE
  6655   "RTN","CH8 35FU1",661 ,0)
  6656            N  RXI,RXJ,R XK,INFO,TM PIO,BPDI,B DOS,BILLAM T,RXNUM,ZE MCARR
  6657   "RTN","CH8 35FU1",662 ,0)
  6658            S  (RXI,RXJ, RXK)=""
  6659   "RTN","CH8 35FU1",663 ,0)
  6660            D  EDICLM(CI ,.ZEMCARR)
  6661   "RTN","CH8 35FU1",664 ,0)
  6662            S  INFO=$P(Z EMCARR,"^" ,1) 
  6663   "RTN","CH8 35FU1",665 ,0)
  6664            S  RXI=$P(IN FO,"*",1), RXJ=$P(INF O,"*",2),R XK=$P(INFO ,"*",3)               ; RETRIEVE  THE ^CHMX RX(I,J,K)  INDEX
  6665   "RTN","CH8 35FU1",666 ,0)
  6666            S  BPDI=$P($ G(^CHMXRX( RXI,100,RX J,100,RXK, 2)),"^",8)                       ; PDI NUMB ER
  6667   "RTN","CH8 35FU1",667 ,0)
  6668            S  BDOS=$P($ G(^CHMXRX( RXI,100,RX J,100,RXK, 1)),"^",2)                       ; DATE OF  SERVICE
  6669   "RTN","CH8 35FU1",668 ,0)
  6670            S  BILLAMT=$ P($G(^CHMX RX(RXI,100 ,RXJ,100,R XK,1)),"^" ,4)                   ; TOTAL AM OUNT BILLE D
  6671   "RTN","CH8 35FU1",669 ,0)
  6672            S  RXNUM=$P( $G(^CHMXRX (RXI,100,R XJ,100,RXK ,1)),"^",1 )                     ; PRESCRIP TION NUMBE R
  6673   "RTN","CH8 35FU1",670 ,0)
  6674            I  ((XPDI'=B PDI)!(DOS' =BDOS)!(CH GAMT'=BILL AMT)) S RX NUM="-X-"    ; MARK I SSUE BY NO  RXNUM
  6675   "RTN","CH8 35FU1",671 ,0)
  6676            ; U 0 W !,"      FU1: G TPRESC: RX NUM= ",RXN UM
  6677   "RTN","CH8 35FU1",672 ,0)
  6678            Q  RXNUM
  6679   "RTN","CH8 35FU1",673 ,0)
  6680            ; HR-PBM-PHA SE 1B-End
  6681   "RTN","CH8 35FU1",674 ,0)
  6682            
  6683   "RTN","CH8 35FU1",675 ,0)
  6684            
  6685   "RTN","CH8 35FU1",676 ,0)
  6686            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  6687   "RTN","CH8 35FU1",677 ,0)
  6688            ;  UTILITY R OUTINES FO R VERIFYIN G THE GTLI CTL() AND  GETPRESC()  FUNCTIONS
  6689   "RTN","CH8 35FU1",678 ,0)
  6690            
  6691   "RTN","CH8 35FU1",679 ,0)
  6692            
  6693   "RTN","CH8 35FU1",680 ,0)
  6694            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  6695   "RTN","CH8 35FU1",681 ,0)
  6696            ;  THIS IS A  UTILITY F UNCTION US ED TO RETU RN THE POS SIBLE LINE  ITEM CONT ROL
  6697   "RTN","CH8 35FU1",682 ,0)
  6698            ;  NUMBERS/L INE NUMBER S FOR A GI VEN HAC CL AIM NUMBER . THIS IS  USED TO 
  6699   "RTN","CH8 35FU1",683 ,0)
  6700            ;  VERIFY TH E LICTL/LN  VALUES OU TPUT TO TH E 835 STAG ING FILE
  6701   "RTN","CH8 35FU1",684 ,0)
  6702            ; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  6703   "RTN","CH8 35FU1",685 ,0)
  6704            ;  
  6705   "RTN","CH8 35FU1",686 ,0)
  6706   XREF(HACNU M) 
  6707   "RTN","CH8 35FU1",687 ,0)
  6708            N  BIDX,CLEI ,PAYI,CLFI ,LICTL,LIN ENUM,LIDOS ,CHGAMT,XP DI
  6709   "RTN","CH8 35FU1",688 ,0)
  6710            S  PAYI=0,PA YI=$O(^CHM PAY("B",HA CNUM,PAYI) ) W !,"PAY I= ",PAYI             ; RETRIEVE  THE ^CHMP AY I FOR H AC CLAIM N UMBER
  6711   "RTN","CH8 35FU1",689 ,0)
  6712            S  XPDI=$P($ P(^CHMPAY( PAYI,0),"^ ",4),"*",1 ) W !,"PDI = ",XPDI              ; RETRIEVE  PDI FROM  ^CHMPAY
  6713   "RTN","CH8 35FU1",690 ,0)
  6714            S  BIDX=$$PD ITOBI^CHMX WBUT(XPDI)  W !,"BIDX : ",BIDX                                                                             ;  RETRIEVE T HE BUFFER  INDICES
  6715   "RTN","CH8 35FU1",691 ,0)
  6716            S  CLEI=$P(B IDX,"*",5) ,(LINENUM, CLFI)=0 W  !,"CLEI= " ,CLEI                         ;  RETRIEVE T HE ^CHMXCL F(I) INDEX
  6717   "RTN","CH8 35FU1",692 ,0)
  6718            F  CNT=1:1 S  CLFI=$O(^ CHMXCLF("B ",CLEI,CLF I)) Q:EXIT   Q:'CLFI   D         ; STEP THR OUGH THE L INE BUFFER
  6719   "RTN","CH8 35FU1",693 ,0)
  6720            . S SVCCODE= $P(^CHMXCL F(CLFI,1), "^",3)  W  !,"^CHMXCL F(",CLFI," ,1)  FLD 3 (SERVI)= " ,SVCCODE
  6721   "RTN","CH8 35FU1",694 ,0)
  6722            . S CHGAMT=$ P(^CHMXCLF (CLFI,1)," ^",6)  W ! ,"^CHMXCLF (",CLFI,", 1)  FLD 6( BILLED AMT )= ",CHGAM T
  6723   "RTN","CH8 35FU1",695 ,0)
  6724            . S LIDOS=$P (^CHMXCLF( CLFI,1),"^ ",11) W !, "^CHMXCLF( ",CLFI,",1 )  FLD 11( DOS)= ",LI DOS
  6725   "RTN","CH8 35FU1",696 ,0)
  6726            . S LICTL=$P ($G(^CHMXC LF(CLFI,1) ),"^",23)   W !,"^CHM XCLF(",CLF I,",1)  FL D 23(LICTL )= ",LICTL
  6727   "RTN","CH8 35FU1",697 ,0)
  6728            . S LIDOS=$P ($G(^CHMXC LF(CLFI,1) ),"^",11)   W !,"^CHM XCLF(",CLF I,",1)  FL D 11(DOS)=  ",LIDOS
  6729   "RTN","CH8 35FU1",698 ,0)
  6730            . W !,"^CHMX CLF(",CLFI ,",1)= ",^ CHMXCLF(CL FI,1)
  6731   "RTN","CH8 35FU1",699 ,0)
  6732            . I LICTL=""  D
  6733   "RTN","CH8 35FU1",700 ,0)
  6734            . .S LINENUM =$P($G(^CH MXCLF(CLFI ,0)),"^",2 ) W !,"^CH MXCLF(",CL FI,",0)  F LD 2(LINE  NUMBER)= " ,LINENUM
  6735   "RTN","CH8 35FU1",701 ,0)
  6736            . .W !,"^CHM XCLF(",CLF I,",0)= ", ^CHMXCLF(C LFI,0)
  6737   "RTN","CH8 35FU1",702 ,0)
  6738            W  !,"SEARCH  FOR ^CHMP AY() RECOR D SVCCODE:  ",SVCCODE
  6739   "RTN","CH8 35FU1",703 ,0)
  6740            W  !,"  OUTP ATIENT PRO CEDURES"
  6741   "RTN","CH8 35FU1",704 ,0)
  6742            S  J=0
  6743   "RTN","CH8 35FU1",705 ,0)
  6744            F   S J=$O(^ CHMPAY(PAY I,"OPT-PRO C",J)) Q:' J  D
  6745   "RTN","CH8 35FU1",706 ,0)
  6746            . S SERVI=$P (^CHMPAY(P AYI,"OPT-P ROC",J,0), "^",1) ;W  !,J,". OPT -PROC SERV I= ",SERVI ," : ",$P( ^CHMSERV(S ERVI,0),"^ ",1) 
  6747   "RTN","CH8 35FU1",707 ,0)
  6748            . I SVCCODE= $P(^CHMSER V(SERVI,0) ,"^",1)  W  !,"  ",J, " SERVI= " ,$P(^CHMSE RV(SERVI,0 ),"^",1)," : ",^CHMPA Y(PAYI,"OP T-PROC",J, 0)
  6749   "RTN","CH8 35FU1",708 ,0)
  6750            W  !,"  DME  PROCEDURES "
  6751   "RTN","CH8 35FU1",709 ,0)
  6752            S  J=0
  6753   "RTN","CH8 35FU1",710 ,0)
  6754            F   S J=$O(^ CHMPAY(PAY I,"DME-SUP PLY",J)) Q :'J  D
  6755   "RTN","CH8 35FU1",711 ,0)
  6756            . S SERVI=$P (^CHMPAY(P AYI,"DME-S UPPLY",J,0 ),"^",1)   ;W !,J,".  DME SUPPLY  SERVI= ", SERVI," :  ",$P(^CHMS ERV(SERVI, 0),"^",1) 
  6757   "RTN","CH8 35FU1",712 ,0)
  6758            . I SVCCODE= $P(^CHMSER V(SERVI,0) ,"^",1)  W  !,"  ",J, " SERVI= " ,$P(^CHMSE RV(SERVI,0 ),"^",1)," : ",^CHMPA Y(PAYI,"DM E-SUPPLY", J,0)
  6759   "RTN","CH8 35FU1",713 ,0)
  6760            W  !,"  DENT AL PROCEDU RES"
  6761   "RTN","CH8 35FU1",714 ,0)
  6762            S  J=0
  6763   "RTN","CH8 35FU1",715 ,0)
  6764            F   S J=$O(^ CHMPAY(PAY I,"DEN-PRO C",J)) Q:' J  D
  6765   "RTN","CH8 35FU1",716 ,0)
  6766            . S SERVI=$P (^CHMPAY(P AYI,"DEN-P ROC",J,0), "^",1)  ;W  !,J,".DEN -PROC SERV I= ",SERVI ," : ",$P( ^CHMSERV(S ERVI,0),"^ ",1) 
  6767   "RTN","CH8 35FU1",717 ,0)
  6768            . I SVCCODE= $P(^CHMSER V(SERVI,0) ,"^",1)  W  !,"  ",J, " SERVI= " ,$P(^CHMSE RV(SERVI,0 ),"^",1)," : ",^CHMPA Y(PAYI,"DE N-PROC",J, 0)  
  6769   "RTN","CH8 35FU1",718 ,0)
  6770            Q
  6771   "RTN","CH8 35FU1",719 ,0)
  6772            ;
  6773   "RTN","CH8 35FU1",720 ,0)
  6774    
  6775   "RTN","CHB PEBSD")
  6776   0^6^B12081 6035
  6777   "RTN","CHB PEBSD",1,0 )
  6778   CHBPEBSD ; CVA/AEB;PR INT ZERO C HAMPVA EOB S;09/06/96   11:31 AM
  6779   "RTN","CHB PEBSD",2,0 )
  6780    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  6781   "RTN","CHB PEBSD",3,0 )
  6782    ;CPTS - 1 0283,10852   (AEB)
  6783   "RTN","CHB PEBSD",4,0 )
  6784    ;DEV01285 3-02 YJK 8 /19/11 STO P VENDOR Z EOB PRINT  WHEN EOB P RINT FLAG= 0
  6785   "RTN","CHB PEBSD",5,0 )
  6786    ;DEV00920 1-06 DGC 3 /27/12 STO P BENE PRI NT FOR BAD  ADD OR DE ATH
  6787   "RTN","CHB PEBSD",6,0 )
  6788    ;SBB 02/2 3/2018 CC4 002-001, C C4002-002,  CC4002-00 3 updates  for Revers al 835 mes sage
  6789   "RTN","CHB PEBSD",7,0 )
  6790    ;
  6791   "RTN","CHB PEBSD",8,0 )
  6792    S MAXPG=+ $P(^CHMDIC (741002.17 ,1,2),U,8)  S:MAXPG=0  MAXPG=1
  6793   "RTN","CHB PEBSD",9,0 )
  6794    S MAXPG=5
  6795   "RTN","CHB PEBSD",10, 0)
  6796    S MAXCT=2 000000000  S:$D(^CHEO BQ("MAXCT" )) MAXCT=^ CHEOBQ("MA XCT")
  6797   "RTN","CHB PEBSD",11, 0)
  6798    K ^TMP($J ),^CHMZHOL D("EOB")
  6799   "RTN","CHB PEBSD",12, 0)
  6800   AO ;
  6801   "RTN","CHB PEBSD",13, 0)
  6802    ;IF THE P FLG=0 THE  PRINT WILL  OCCUR TO  THE SCREEN
  6803   "RTN","CHB PEBSD",14, 0)
  6804    ;       P FLG=1 THE  PRINT WILL  OCCUR TO  A VMS FILE
  6805   "RTN","CHB PEBSD",15, 0)
  6806    ;IOVAR US ED TO ALLO W THE PRIN ITNG OF PR OVIDER EOB  TO ONE FI LE (IOEOB)
  6807   "RTN","CHB PEBSD",16, 0)
  6808    ;AND ITS  CORRESPOND ING BENE E OB TO ANOT HER FILE ( IOEOB1).
  6809   "RTN","CHB PEBSD",17, 0)
  6810    ;PFLG MUS T BE PASSE D BY THE C ALLING ROU TINE.
  6811   "RTN","CHB PEBSD",18, 0)
  6812    ;AFLG IS  USED TO PR INT BENE E OBS FROM A SSIGNMENT  YES CLAIMS .
  6813   "RTN","CHB PEBSD",19, 0)
  6814    S DFN=0,F MSDOCID=74 100000000, COUNT=0,CH QI="",CHEL CT=0
  6815   "RTN","CHB PEBSD",20, 0)
  6816    S IOVAR=E OBFIL,FILE ="BEN",PG= 0,PGLIMIT= 0,CTZ=0,PR OVFL=0
  6817   "RTN","CHB PEBSD",21, 0)
  6818   A1 S DFN=$ O(^CHMZHOL D($J,"BEN" ,DFN)) G V :'DFN
  6819   "RTN","CHB PEBSD",22, 0)
  6820    S BFN=0
  6821   "RTN","CHB PEBSD",23, 0)
  6822   A2 S BFN=$ O(^CHMZHOL D($J,"BEN" ,DFN,BFN))  G:'BFN A1
  6823   "RTN","CHB PEBSD",24, 0)
  6824    S CTZ=CTZ +1 I CTZ>M AXCT G END
  6825   "RTN","CHB PEBSD",25, 0)
  6826    S CHCLPT= 0,FMSDOCID =FMSDOCID+ 1
  6827   "RTN","CHB PEBSD",26, 0)
  6828   A3 S CHCLP T=$O(^CHMZ HOLD($J,"B EN",DFN,BF N,CHCLPT))  I 'CHCLPT  D EOB K C HEOBBTH G  A2
  6829   "RTN","CHB PEBSD",27, 0)
  6830    D ^CHBPEB 01 I (PGLI MIT=1) D
  6831   "RTN","CHB PEBSD",28, 0)
  6832    .S O1DFN= DFN D EOB  K CHEOBBTH ,TMP("PAY- EOB")
  6833   "RTN","CHB PEBSD",29, 0)
  6834    .S DFN=O1 DFN,PGLIMI T=0,FMSDOC ID=FMSDOCI D+1 K O1DF N
  6835   "RTN","CHB PEBSD",30, 0)
  6836    .Q
  6837   "RTN","CHB PEBSD",31, 0)
  6838    S CHEOBBT H(CHCLPT)= ""
  6839   "RTN","CHB PEBSD",32, 0)
  6840    S TMP("PA Y-EOB",CHC LPT)=""
  6841   "RTN","CHB PEBSD",33, 0)
  6842    S X1=CHCL PT D PROGT YP^CHFCD00 1
  6843   "RTN","CHB PEBSD",34, 0)
  6844    D SET^CHB PEBN
  6845   "RTN","CHB PEBSD",35, 0)
  6846    G A3
  6847   "RTN","CHB PEBSD",36, 0)
  6848   V S COUNT= 0,CHQI="", CHELCT=0,V NPT="",FIL E="VEN",PR OVFL=1
  6849   "RTN","CHB PEBSD",37, 0)
  6850   V1 S VNPT= $O(^CHMZHO LD($J,"VEN ",VNPT)) G  END:VNPT= ""
  6851   "RTN","CHB PEBSD",38, 0)
  6852    S DFN=0
  6853   "RTN","CHB PEBSD",39, 0)
  6854   V2 S DFN=$ O(^CHMZHOL D($J,"VEN" ,VNPT,DFN) ) G:'DFN V 1
  6855   "RTN","CHB PEBSD",40, 0)
  6856    S BFN=0
  6857   "RTN","CHB PEBSD",41, 0)
  6858   V3 S BFN=$ O(^CHMZHOL D($J,"VEN" ,VNPT,DFN, BFN)) G:'B FN V2
  6859   "RTN","CHB PEBSD",42, 0)
  6860    S CHCLPT= 0,FMSDOCID =FMSDOCID+ 1
  6861   "RTN","CHB PEBSD",43, 0)
  6862   V4 S CHCLP T=$O(^CHMZ HOLD($J,"V EN",VNPT,D FN,BFN,CHC LPT)) I 'C HCLPT D EO B K CHEOBB TH G V3
  6863   "RTN","CHB PEBSD",44, 0)
  6864    D ^CHBPEB 02 I (PGLI MIT=1) D
  6865   "RTN","CHB PEBSD",45, 0)
  6866    .S O1DFN= DFN D EOB  K CHEOBBTH ,TMP("PAY- EOB"),TMP( "PAY-EOB", "PROV")
  6867   "RTN","CHB PEBSD",46, 0)
  6868    .S DFN=O1 DFN,PGLIMI T=0,FMSDOC ID=FMSDOCI D+1 K O1DF N
  6869   "RTN","CHB PEBSD",47, 0)
  6870    .Q
  6871   "RTN","CHB PEBSD",48, 0)
  6872    S CHEOBBT H(CHCLPT)= ""
  6873   "RTN","CHB PEBSD",49, 0)
  6874    S TMP("PA Y-EOB",CHC LPT)=""
  6875   "RTN","CHB PEBSD",50, 0)
  6876    S TMP("PA Y-EOB","PR OV",CHCLPT )=""
  6877   "RTN","CHB PEBSD",51, 0)
  6878    S X1=CHCL PT D PROGT YP^CHFCD00 1
  6879   "RTN","CHB PEBSD",52, 0)
  6880    D SET^CHB PEBN
  6881   "RTN","CHB PEBSD",53, 0)
  6882    G V4
  6883   "RTN","CHB PEBSD",54, 0)
  6884   END K BEN, BFN,CHAI,C HARY,CHCI, CHCN,CHPCI ,CHPUID,CH QI,CHTAI,C HTCI
  6885   "RTN","CHB PEBSD",55, 0)
  6886    K CHUID,C T05,DET,DE TO,DETTOT, DEVICE,DFN ,DIS,DOS,E OBTYPE
  6887   "RTN","CHB PEBSD",56, 0)
  6888    K MAXPG,N 1,REM,REMO ,REMTOT,TM P,TY,ZCT
  6889   "RTN","CHB PEBSD",57, 0)
  6890    K CAT,CAT YR,D0,DI,D IC,DQ,DTCA LC,FAM,IND ,REA,REASO N
  6891   "RTN","CHB PEBSD",58, 0)
  6892    Q
  6893   "RTN","CHB PEBSD",59, 0)
  6894    ;
  6895   "RTN","CHB PEBSD",60, 0)
  6896   EOB Q:'$D( CHEOBBTH)
  6897   "RTN","CHB PEBSD",61, 0)
  6898    S ^TMP($J ,"EOB",0)= FMSDOCID
  6899   "RTN","CHB PEBSD",62, 0)
  6900    D:FILE="B EN"
  6901   "RTN","CHB PEBSD",63, 0)
  6902    .S PROVFL =0,CHSTTYP =1,CHSTTYP 1=1,CHPRGI D=0,CHCKIN C=0,CHELCT =0
  6903   "RTN","CHB PEBSD",64, 0)
  6904    .I CHPGPT =6 S CHSTT YP1=7,CHPR GID=3
  6905   "RTN","CHB PEBSD",65, 0)
  6906    .I CHPGPT =7 S CHSTT YP1="B",CH PRGID=5
  6907   "RTN","CHB PEBSD",66, 0)
  6908    I FILE="V EN" D
  6909   "RTN","CHB PEBSD",67, 0)
  6910    .S PROVFL =1,CHSTTYP =0,CHSTTYP 1=0,CHPRGI D=0,CHCKIN C=0
  6911   "RTN","CHB PEBSD",68, 0)
  6912    .I CHPGPT =6 S CHSTT YP1=6,CHPR GID=3
  6913   "RTN","CHB PEBSD",69, 0)
  6914    .I CHPGPT =7 S CHSTT YP1="A",CH PRGID=5
  6915   "RTN","CHB PEBSD",70, 0)
  6916    .D EDI835
  6917   "RTN","CHB PEBSD",71, 0)
  6918    .;K DFN
  6919   "RTN","CHB PEBSD",72, 0)
  6920    D EOBD^CH BPEBS1
  6921   "RTN","CHB PEBSD",73, 0)
  6922   EOBA S CHU ID="",(PAG ES,DETTOT, REMTOT,BAR CODE,CHPG) =0 K AFLG
  6923   "RTN","CHB PEBSD",74, 0)
  6924    S CHCI=0  D ^CHMG431 1 S (LN,RL N)=0,INDFL G=1
  6925   "RTN","CHB PEBSD",75, 0)
  6926   EOB1 S CHC I=$O(CHEOB BTH(CHCI))  I 'CHCI D    S CHELC T=0 G:$D(A FLG) EOBA  Q
  6927   "RTN","CHB PEBSD",76, 0)
  6928    .K AFLG D  CH431 D E PRNT
  6929   "RTN","CHB PEBSD",77, 0)
  6930    .I (FILE= "VEN")&(PR OVFL=1) D
  6931   "RTN","CHB PEBSD",78, 0)
  6932    ..S CHSTT YP1=1,CHCK INC=0,PROV FL=0,AFLG= ""
  6933   "RTN","CHB PEBSD",79, 0)
  6934    ..I CHPGP T=6 S CHST TYP1=7,CHP RGID=3
  6935   "RTN","CHB PEBSD",80, 0)
  6936    ..I CHPGP T=7 S CHST TYP1="B",C HPRGID=5
  6937   "RTN","CHB PEBSD",81, 0)
  6938    ..S FMSDO CID=FMSDOC ID+1
  6939   "RTN","CHB PEBSD",82, 0)
  6940    ..I PFLG= 1 S CHELCT =0,^TMP($J ,"EOB",0)= FMSDOCID
  6941   "RTN","CHB PEBSD",83, 0)
  6942    .Q
  6943   "RTN","CHB PEBSD",84, 0)
  6944    G:'$D(^AH CHVA(DFN,1 00,BFN,1))  EOB1 D
  6945   "RTN","CHB PEBSD",85, 0)
  6946    .Q:'$D(^C HMEOBQ("D" ,CHCI))  S  CHQI=0,CH QI=$O(^CHM EOBQ("D",C HCI,CHQI))
  6947   "RTN","CHB PEBSD",86, 0)
  6948    S ODFN=DF N,OBFN=BFN  D EOB^CHM G430 S DFN =ODFN,BFN= OBFN K ODF N,OBFN
  6949   "RTN","CHB PEBSD",87, 0)
  6950    ;SBB 02/2 3/2018 CC4 002-001 re move void  node befor e setting  to 835 que ue
  6951   "RTN","CHB PEBSD",88, 0)
  6952    I $P(^CHM PAY(CHCI,0 ),"^",2)=1 1 I $D(^CH MPAY(CHCI, 1,"VOID"))  D UNSETVD N^CHMFSRT( CHCI)
  6953   "RTN","CHB PEBSD",89, 0)
  6954    G EOB1
  6955   "RTN","CHB PEBSD",90, 0)
  6956   CH431 ;--- FORM 63 LI NES BY 132  CHARACTER S (0-62, 0 -131)
  6957   "RTN","CHB PEBSD",91, 0)
  6958    ;---PUT T ERMINAL IN  WIDE MODE  FOR TESTI NG
  6959   "RTN","CHB PEBSD",92, 0)
  6960    I PFLG=1  G RW
  6961   "RTN","CHB PEBSD",93, 0)
  6962    S SCRW=""  S:$D(^%ZI S(2,IOST(0 ),554001))  SCRW=$P(^ (554001),U ,2)
  6963   "RTN","CHB PEBSD",94, 0)
  6964    S SCRN=""  S:$D(^%ZI S(2,IOST(0 ),554001))  SCRN=$P(^ (554001),U ,1)
  6965   "RTN","CHB PEBSD",95, 0)
  6966    S X=132 X  ^%ZOSF("R M") W @SCR W W #
  6967   "RTN","CHB PEBSD",96, 0)
  6968    ;H 15 S X =80 X ^%ZO SF("RM") W  @SCRN
  6969   "RTN","CHB PEBSD",97, 0)
  6970   RW ;MAIN R EAD WRITE  LOOP
  6971   "RTN","CHB PEBSD",98, 0)
  6972    D C1
  6973   "RTN","CHB PEBSD",99, 0)
  6974    D DETAIL  ; UNTIL NO  MORE RECO RDS
  6975   "RTN","CHB PEBSD",100 ,0)
  6976    D FTR2
  6977   "RTN","CHB PEBSD",101 ,0)
  6978    D FTR3
  6979   "RTN","CHB PEBSD",102 ,0)
  6980    D FTR1 W: PFLG=0 #
  6981   "RTN","CHB PEBSD",103 ,0)
  6982    I PFLG=0  H 5 S X=80  X ^%ZOSF( "RM") W @S CRN
  6983   "RTN","CHB PEBSD",104 ,0)
  6984    ;I PFLG=1  S CHELCT= CHELCT+1,^ TMP($J,"EO B",CHELCT) ="#"
  6985   "RTN","CHB PEBSD",105 ,0)
  6986    Q
  6987   "RTN","CHB PEBSD",106 ,0)
  6988   CHECKTOP ; ---CHECK F OR TOP OF  FORM
  6989   "RTN","CHB PEBSD",107 ,0)
  6990    S NY=+Y
  6991   "RTN","CHB PEBSD",108 ,0)
  6992    S CHELCT1 =CHELCT-(( CHPG-1)*66 )
  6993   "RTN","CHB PEBSD",109 ,0)
  6994    S:CHELCT1 <0 CHELCT1 =CHELCT
  6995   "RTN","CHB PEBSD",110 ,0)
  6996    N X,Y
  6997   "RTN","CHB PEBSD",111 ,0)
  6998    I $D(CHEO B("DET1",N Y,0)),CHEO B("DET1",N Y,0)["CHV" ,CHELCT1+4 >CHBM D C1
  6999   "RTN","CHB PEBSD",112 ,0)
  7000    I CHELCT1 >CHBM D C1
  7001   "RTN","CHB PEBSD",113 ,0)
  7002    Q
  7003   "RTN","CHB PEBSD",114 ,0)
  7004   C1 D:CHPG> 0 BARCD,FT R1 S CHPG= CHPG+1,CHE OB("HDR1", 1,120)=CHP G D HDR1,H DR2 D:CHPG =1 HDR3 D  HDR4
  7005   "RTN","CHB PEBSD",115 ,0)
  7006    S $P(^TMP ($J,"EOB", 0),"^",2)= CHPG
  7007   "RTN","CHB PEBSD",116 ,0)
  7008    Q
  7009   "RTN","CHB PEBSD",117 ,0)
  7010   BARCD F N1 =(CHELCT-( (CHPG-1)*6 6)):1:59
  7011   "RTN","CHB PEBSD",118 ,0)
  7012    I PFLG=0  W ! D BARC DA
  7013   "RTN","CHB PEBSD",119 ,0)
  7014    I PFLG=1  S CHELCT=C HELCT+1 S  ^TMP($J,"E OB",CHELCT )="" D BAR CDA
  7015   "RTN","CHB PEBSD",120 ,0)
  7016    Q
  7017   "RTN","CHB PEBSD",121 ,0)
  7018   BARCDA I C HPG=1,CHEL CT=60,PROV FL W:PFLG= 0 ?113,CHB ARCD I PFL G=1 D
  7019   "RTN","CHB PEBSD",122 ,0)
  7020    .S ETAB=" " F I=1:1: 113 S ETAB =ETAB_" "
  7021   "RTN","CHB PEBSD",123 ,0)
  7022    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=ETAB_CHB ARCD
  7023   "RTN","CHB PEBSD",124 ,0)
  7024    I CHPG=1, CHELCT=61, 'PROVFL W: PFLG=0 ?11 3,CHBARCD  I PFLG=1 D
  7025   "RTN","CHB PEBSD",125 ,0)
  7026    .S ETAB=" " F I=1:1: 113 S ETAB =ETAB_" "
  7027   "RTN","CHB PEBSD",126 ,0)
  7028    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=ETAB_CHB ARCD
  7029   "RTN","CHB PEBSD",127 ,0)
  7030    I CHPG=1, CHELCT=62  W:PFLG=0 ? 113,CHBARC D I PFLG=1  D
  7031   "RTN","CHB PEBSD",128 ,0)
  7032    .S ETAB=" " F I=1:1: 113 S ETAB =ETAB_" "
  7033   "RTN","CHB PEBSD",129 ,0)
  7034    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=ETAB_CHB ARCD
  7035   "RTN","CHB PEBSD",130 ,0)
  7036    Q
  7037   "RTN","CHB PEBSD",131 ,0)
  7038   HDR1 I CHP G>1 D
  7039   "RTN","CHB PEBSD",132 ,0)
  7040    .;W:CHPG> 1 #
  7041   "RTN","CHB PEBSD",133 ,0)
  7042    .;S CHELC T=CHELCT+1 ,^TMP($J," EOB",CHELC T)="#"
  7043   "RTN","CHB PEBSD",134 ,0)
  7044    S $Y=0,Y= ""
  7045   "RTN","CHB PEBSD",135 ,0)
  7046    F  S Y=$O (CHEOB("HD R1",Y)) Q: Y=""  S X= "" F  S X= $O(CHEOB(" HDR1",Y,X) ) Q:X=""   W:PFLG=0 ? X,CHEOB("H DR1",Y,X)  I PFLG=1 D
  7047   "RTN","CHB PEBSD",136 ,0)
  7048    .I X=0 S  CHELCT=CHE LCT+1,^TMP ($J,"EOB", CHELCT)=CH EOB("HDR1" ,Y,X) D
  7049   "RTN","CHB PEBSD",137 ,0)
  7050    ..S ^TMP( $J,"EOB",C HELCT)=""
  7051   "RTN","CHB PEBSD",138 ,0)
  7052    ..F I=1:1 :132 S ^TM P($J,"EOB" ,CHELCT)=^ TMP($J,"EO B",CHELCT) _" "
  7053   "RTN","CHB PEBSD",139 ,0)
  7054    .S ^TMP($ J,"EOB",CH ELCT)=$E(^ TMP($J,"EO B",CHELCT) ,1,X)_CHEO B("HDR1",Y ,X)
  7055   "RTN","CHB PEBSD",140 ,0)
  7056    .F I=1:1: 132-$L(^TM P($J,"EOB" ,CHELCT))  S ^TMP($J, "EOB",CHEL CT)=^TMP($ J,"EOB",CH ELCT)_" "
  7057   "RTN","CHB PEBSD",141 ,0)
  7058    Q
  7059   "RTN","CHB PEBSD",142 ,0)
  7060   HDR2 S CHP RST=CHELCT
  7061   "RTN","CHB PEBSD",143 ,0)
  7062    ;F N1=CHE LCT:1:CHPR ST W:PFLG= 0 ! I PFLG =1 D
  7063   "RTN","CHB PEBSD",144 ,0)
  7064    F N1=CHEL CT:1:CHPRS T W:PFLG=0  !
  7065   "RTN","CHB PEBSD",145 ,0)
  7066    S Y=""
  7067   "RTN","CHB PEBSD",146 ,0)
  7068    F  S Y=$O (CHEOB("HD R2",Y)) Q: Y=""  S X= "" F  S X= $O(CHEOB(" HDR2",Y,X) ) Q:X=""   W:(X=0)&(P FLG=0) ! W :PFLG=0 ?X ,CHEOB("HD R2",Y,X) I  PFLG=1 D
  7069   "RTN","CHB PEBSD",147 ,0)
  7070    .I X=0 S  CHELCT=CHE LCT+1,^TMP ($J,"EOB", CHELCT)=CH EOB("HDR2" ,Y,X) D
  7071   "RTN","CHB PEBSD",148 ,0)
  7072    ..I CHEOB ("HDR2",Y, X)'="" Q
  7073   "RTN","CHB PEBSD",149 ,0)
  7074    ..S ^TMP( $J,"EOB",C HELCT)=""
  7075   "RTN","CHB PEBSD",150 ,0)
  7076    ..F I=1:1 :132 S ^TM P($J,"EOB" ,CHELCT)=^ TMP($J,"EO B",CHELCT) _" "
  7077   "RTN","CHB PEBSD",151 ,0)
  7078    .S ^TMP($ J,"EOB",CH ELCT)=$E(^ TMP($J,"EO B",CHELCT) ,1,X)_CHEO B("HDR2",Y ,X)
  7079   "RTN","CHB PEBSD",152 ,0)
  7080    .F I=1:1: 132-$L(^TM P($J,"EOB" ,CHELCT))  S ^TMP($J, "EOB",CHEL CT)=^TMP($ J,"EOB",CH ELCT)_" "
  7081   "RTN","CHB PEBSD",153 ,0)
  7082    Q
  7083   "RTN","CHB PEBSD",154 ,0)
  7084   HDR3 S CHP RST=CHELCT -1
  7085   "RTN","CHB PEBSD",155 ,0)
  7086    ;F N1=(CH ELCT-((CHP G-1)*66)): 1:CHPRST W :PFLG=0 !  I PFLG=1 D
  7087   "RTN","CHB PEBSD",156 ,0)
  7088    ;.S CHELC T=CHELCT+1 ,^TMP($J," EOB",CHELC T)=""
  7089   "RTN","CHB PEBSD",157 ,0)
  7090    F N1=(CHE LCT-((CHPG -1)*66)):1 :CHPRST W: PFLG=0 !
  7091   "RTN","CHB PEBSD",158 ,0)
  7092    S Y=""
  7093   "RTN","CHB PEBSD",159 ,0)
  7094    F  S Y=$O (CHEOB("HD R3",Y)) Q: Y=""  S X= "" F  S X= $O(CHEOB(" HDR3",Y,X) ) Q:X=""   W:(X=0)&(P FLG=0) ! W :PFLG=0 ?X ,CHEOB("HD R3",Y,X) I  PFLG=1 D
  7095   "RTN","CHB PEBSD",160 ,0)
  7096    .I X=0 S  CHELCT=CHE LCT+1,^TMP ($J,"EOB", CHELCT)=CH EOB("HDR3" ,Y,X) D
  7097   "RTN","CHB PEBSD",161 ,0)
  7098    ..S ^TMP( $J,"EOB",C HELCT)=""
  7099   "RTN","CHB PEBSD",162 ,0)
  7100    ..F I=1:1 :132 S ^TM P($J,"EOB" ,CHELCT)=^ TMP($J,"EO B",CHELCT) _" "
  7101   "RTN","CHB PEBSD",163 ,0)
  7102    .S ^TMP($ J,"EOB",CH ELCT)=$E(^ TMP($J,"EO B",CHELCT) ,1,X)_CHEO B("HDR3",Y ,X)
  7103   "RTN","CHB PEBSD",164 ,0)
  7104    .F I=1:1: 132-$L(^TM P($J,"EOB" ,CHELCT))  S ^TMP($J, "EOB",CHEL CT)=^TMP($ J,"EOB",CH ELCT)_" "
  7105   "RTN","CHB PEBSD",165 ,0)
  7106    Q
  7107   "RTN","CHB PEBSD",166 ,0)
  7108   HDR4 S:(PR OVFL&('CHV IM)) CHEOB ("HDR4",3, 13)=""
  7109   "RTN","CHB PEBSD",167 ,0)
  7110    I CHPG=1  S CHPRST=C HELCT-1
  7111   "RTN","CHB PEBSD",168 ,0)
  7112    I CHPG>1  S CHPRST=C HELCT+6
  7113   "RTN","CHB PEBSD",169 ,0)
  7114    F N1=CHEL CT:1:CHPRS T W:PFLG=0  ! I PFLG= 1 D
  7115   "RTN","CHB PEBSD",170 ,0)
  7116    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=""
  7117   "RTN","CHB PEBSD",171 ,0)
  7118    S Y=""
  7119   "RTN","CHB PEBSD",172 ,0)
  7120    F  S Y=$O (CHEOB("HD R4",Y)) Q: Y=""  S X= "" F  S X= $O(CHEOB(" HDR4",Y,X) ) Q:X=""   W:(X=0)&(P FLG=0) ! W :PFLG=0 ?X ,CHEOB("HD R4",Y,X) I  PFLG=1 D
  7121   "RTN","CHB PEBSD",173 ,0)
  7122    .I X=0 S  CHELCT=CHE LCT+1,^TMP ($J,"EOB", CHELCT)=CH EOB("HDR4" ,Y,X) D
  7123   "RTN","CHB PEBSD",174 ,0)
  7124    ..S ^TMP( $J,"EOB",C HELCT)=""
  7125   "RTN","CHB PEBSD",175 ,0)
  7126    ..F I=1:1 :132 S ^TM P($J,"EOB" ,CHELCT)=^ TMP($J,"EO B",CHELCT) _" "
  7127   "RTN","CHB PEBSD",176 ,0)
  7128    .S ^TMP($ J,"EOB",CH ELCT)=$E(^ TMP($J,"EO B",CHELCT) ,1,X)_CHEO B("HDR4",Y ,X)
  7129   "RTN","CHB PEBSD",177 ,0)
  7130    .F I=1:1: 132-$L(^TM P($J,"EOB" ,CHELCT))  S ^TMP($J, "EOB",CHEL CT)=^TMP($ J,"EOB",CH ELCT)_" "
  7131   "RTN","CHB PEBSD",178 ,0)
  7132    Q
  7133   "RTN","CHB PEBSD",179 ,0)
  7134   FTR1 S CHP RST=62-2 S :CHPG>1 CH PRST=64-2  I (CHELCT- ((CHPG-1)* 66))=61 D
  7135   "RTN","CHB PEBSD",180 ,0)
  7136    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=""
  7137   "RTN","CHB PEBSD",181 ,0)
  7138    .D BARCDA  Q
  7139   "RTN","CHB PEBSD",182 ,0)
  7140    F N1=(CHE LCT-((CHPG -1)*66)):1 :CHPRST W: PFLG=0 ! D :PFLG=1  D  BARCDA
  7141   "RTN","CHB PEBSD",183 ,0)
  7142    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=""
  7143   "RTN","CHB PEBSD",184 ,0)
  7144    S Y=""
  7145   "RTN","CHB PEBSD",185 ,0)
  7146    F  S Y=$O (CHEOB("FT R1",Y)) Q: Y=""  S X= "" F  S X= $O(CHEOB(" FTR1",Y,X) ) Q:X=""   W:(X=0)&(P FLG=0) ! W :PFLG=0 ?X ,CHEOB("FT R1",Y,X) D :PFLG=1  D  BARCDA
  7147   "RTN","CHB PEBSD",186 ,0)
  7148    .I X=0 S  CHELCT=CHE LCT+1,^TMP ($J,"EOB", CHELCT)=CH EOB("FTR1" ,Y,X) D
  7149   "RTN","CHB PEBSD",187 ,0)
  7150    ..S ^TMP( $J,"EOB",C HELCT)=""
  7151   "RTN","CHB PEBSD",188 ,0)
  7152    ..F I=1:1 :132 S ^TM P($J,"EOB" ,CHELCT)=^ TMP($J,"EO B",CHELCT) _" "
  7153   "RTN","CHB PEBSD",189 ,0)
  7154    .S ^TMP($ J,"EOB",CH ELCT)=$E(^ TMP($J,"EO B",CHELCT) ,1,X)_CHEO B("FTR1",Y ,X)
  7155   "RTN","CHB PEBSD",190 ,0)
  7156    .F I=1:1: 132-$L(^TM P($J,"EOB" ,CHELCT))  S ^TMP($J, "EOB",CHEL CT)=^TMP($ J,"EOB",CH ELCT)_" "
  7157   "RTN","CHB PEBSD",191 ,0)
  7158    S CHELCT= CHELCT+1,^ TMP($J,"EO B",CHELCT) ="#"
  7159   "RTN","CHB PEBSD",192 ,0)
  7160    Q
  7161   "RTN","CHB PEBSD",193 ,0)
  7162   DETAIL ;-- -DETAIL LI NES HERE
  7163   "RTN","CHB PEBSD",194 ,0)
  7164    S CHBM=49  D CHECKTO P
  7165   "RTN","CHB PEBSD",195 ,0)
  7166    S CHPRST= CHELCT-1
  7167   "RTN","CHB PEBSD",196 ,0)
  7168    F N1=(CHE LCT-((CHPG -1)*66)):1 :CHPRST W: PFLG=0 ! I  PFLG=1 D
  7169   "RTN","CHB PEBSD",197 ,0)
  7170    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=""
  7171   "RTN","CHB PEBSD",198 ,0)
  7172    S Y=""
  7173   "RTN","CHB PEBSD",199 ,0)
  7174    F  S Y=$O (CHEOB("DE T1",Y)) Q: Y=""  S X= "" F  S X= $O(CHEOB(" DET1",Y,X) ) Q:X=""   D:X=0 CHEC KTOP W:(X= 0)&(PFLG=0 ) ! W:PFLG =0 ?X,CHEO B("DET1",Y ,X) I PFLG =1 D
  7175   "RTN","CHB PEBSD",200 ,0)
  7176    .I X=0 S  CHELCT=CHE LCT+1,^TMP ($J,"EOB", CHELCT)=CH EOB("DET1" ,Y,X) D
  7177   "RTN","CHB PEBSD",201 ,0)
  7178    ..S ^TMP( $J,"EOB",C HELCT)=""
  7179   "RTN","CHB PEBSD",202 ,0)
  7180    ..F I=1:1 :132 S ^TM P($J,"EOB" ,CHELCT)=^ TMP($J,"EO B",CHELCT) _" "
  7181   "RTN","CHB PEBSD",203 ,0)
  7182    .S ^TMP($ J,"EOB",CH ELCT)=$E(^ TMP($J,"EO B",CHELCT) ,1,X)_CHEO B("DET1",Y ,X)
  7183   "RTN","CHB PEBSD",204 ,0)
  7184    .F I=1:1: 132-$L(^TM P($J,"EOB" ,CHELCT))  S ^TMP($J, "EOB",CHEL CT)=^TMP($ J,"EOB",CH ELCT)_" "
  7185   "RTN","CHB PEBSD",205 ,0)
  7186    Q
  7187   "RTN","CHB PEBSD",206 ,0)
  7188   FTR2 S CHB M=50 D CHE CKTOP
  7189   "RTN","CHB PEBSD",207 ,0)
  7190    S CHPRST= (CHELCT-(( CHPG-1)*66 ))
  7191   "RTN","CHB PEBSD",208 ,0)
  7192    F N1=(CHE LCT-((CHPG -1)*66)):1 :CHPRST W: PFLG=0 ! I  PFLG=1 D
  7193   "RTN","CHB PEBSD",209 ,0)
  7194    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=""
  7195   "RTN","CHB PEBSD",210 ,0)
  7196    S Y=""
  7197   "RTN","CHB PEBSD",211 ,0)
  7198    F  S Y=$O (CHEOB("FT R2",Y)) Q: Y=""  S X= "" F  S X= $O(CHEOB(" FTR2",Y,X) ) Q:X=""   W:(X=0)&(P FLG=0) ! W :PFLG=0 ?X ,CHEOB("FT R2",Y,X) I  PFLG=1 D
  7199   "RTN","CHB PEBSD",212 ,0)
  7200    .I X=0 S  CHELCT=CHE LCT+1,^TMP ($J,"EOB", CHELCT)=CH EOB("FTR2" ,Y,X) D
  7201   "RTN","CHB PEBSD",213 ,0)
  7202    ..S ^TMP( $J,"EOB",C HELCT)=""
  7203   "RTN","CHB PEBSD",214 ,0)
  7204    ..F I=1:1 :132 S ^TM P($J,"EOB" ,CHELCT)=^ TMP($J,"EO B",CHELCT) _" "
  7205   "RTN","CHB PEBSD",215 ,0)
  7206    .S ^TMP($ J,"EOB",CH ELCT)=$E(^ TMP($J,"EO B",CHELCT) ,1,X)_CHEO B("FTR2",Y ,X)
  7207   "RTN","CHB PEBSD",216 ,0)
  7208    .F I=1:1: 132-$L(^TM P($J,"EOB" ,CHELCT))  S ^TMP($J, "EOB",CHEL CT)=^TMP($ J,"EOB",CH ELCT)_" "
  7209   "RTN","CHB PEBSD",217 ,0)
  7210    Q
  7211   "RTN","CHB PEBSD",218 ,0)
  7212   FTR3 S CHB M=58 D CHE CKTOP
  7213   "RTN","CHB PEBSD",219 ,0)
  7214    S CHPRST= CHELCT+1
  7215   "RTN","CHB PEBSD",220 ,0)
  7216    F N1=(CHE LCT-((CHPG -1)*66)):1 :CHPRST D: PFLG=0
  7217   "RTN","CHB PEBSD",221 ,0)
  7218    .W ! D BA RCDA
  7219   "RTN","CHB PEBSD",222 ,0)
  7220    D:PFLG=1
  7221   "RTN","CHB PEBSD",223 ,0)
  7222    .S CHELCT =CHELCT+1, ^TMP($J,"E OB",CHELCT )=""
  7223   "RTN","CHB PEBSD",224 ,0)
  7224    S Y=""
  7225   "RTN","CHB PEBSD",225 ,0)
  7226    F  S Y=$O (CHEOB("FT R3",Y)) Q: Y=""  S X= "" F  S X= $O(CHEOB(" FTR3",Y,X) ) Q:X=""   D:X=0 CHEC KTOP W:(X= 0)&(PFLG=0 ) ! D
  7227   "RTN","CHB PEBSD",226 ,0)
  7228    .I ($Y>50 )&(PFLG=0)  W ?X,CHEO B("FTR3",Y ,X) D BARC DA
  7229   "RTN","CHB PEBSD",227 ,0)
  7230    .I (CHELC T>50)&(PFL G=1) D
  7231   "RTN","CHB PEBSD",228 ,0)
  7232    ..S ETAB= "" F I=1:1 :X S ETAB= ETAB_" "
  7233   "RTN","CHB PEBSD",229 ,0)
  7234    ..S CHELC T=CHELCT+1 ,^TMP($J," EOB",CHELC T)=ETAB_CH EOB("FTR3" ,Y,X)
  7235   "RTN","CHB PEBSD",230 ,0)
  7236    .I ($Y<51 )&(PFLG=0)  W ?X,$E(C HEOB("FTR3 ",Y,X),1,1 32)
  7237   "RTN","CHB PEBSD",231 ,0)
  7238    .I (CHELC T<51)&(PFL G=1) D
  7239   "RTN","CHB PEBSD",232 ,0)
  7240    ..S ETAB= "" F I=1:1 :X S ETAB= ETAB_" "
  7241   "RTN","CHB PEBSD",233 ,0)
  7242    ..S CHELC T=CHELCT+1 ,^TMP($J," EOB",CHELC T)=ETAB_$E (CHEOB("FT R3",Y,X),1 ,132)
  7243   "RTN","CHB PEBSD",234 ,0)
  7244    Q
  7245   "RTN","CHB PEBSD",235 ,0)
  7246    ;EPRNT PR INTS THE T MP ARRAY K ILLS THE A RRATY AND  QUITS.
  7247   "RTN","CHB PEBSD",236 ,0)
  7248   EPRNT S CO NTR=0
  7249   "RTN","CHB PEBSD",237 ,0)
  7250    S PRTEOB= 1            ;DEV0128 53-02 YJK  8/19/11 
  7251   "RTN","CHB PEBSD",238 ,0)
  7252    I PROVFL  D CKPRTFLG   ;FOR VEN DOR ZEOB,  CHECK ^CHM VEN(I,5) F OR EOB PRI NT FLAG ;D EV012853-0 2 YJK 8/19 /11 
  7253   "RTN","CHB PEBSD",239 ,0)
  7254    I 'PROVFL  D CKPRTFL G2 ;DGC 7/ 31/2012 DE V009201
  7255   "RTN","CHB PEBSD",240 ,0)
  7256    I 'PRTEOB  G EPRTED    ;DEV0128 53-02 YJK  8/19/11   
  7257   "RTN","CHB PEBSD",241 ,0)
  7258    S CHPAGES =$P(^TMP($ J,"EOB",0) ,"^",2)
  7259   "RTN","CHB PEBSD",242 ,0)
  7260    S CHDLINE S=CHPAGES* 65,CHPG=1
  7261   "RTN","CHB PEBSD",243 ,0)
  7262    D ^CHBPEB 06
  7263   "RTN","CHB PEBSD",244 ,0)
  7264    ;U IOVAR  W CHFMSHDR ,!
  7265   "RTN","CHB PEBSD",245 ,0)
  7266   EBP1 S CON TR=$O(^TMP ($J,"EOB", CONTR)) G: 'CONTR EPR TED
  7267   "RTN","CHB PEBSD",246 ,0)
  7268    I ^TMP($J ,"EOB",CON TR)="" D   G EBP1
  7269   "RTN","CHB PEBSD",247 ,0)
  7270    .;U IOVAR  W ! Q  ;  JEH
  7271   "RTN","CHB PEBSD",248 ,0)
  7272    .S TMPLN= "" D ZWCHA R^CHMSNUTL (IOVAR,TMP LN) Q   ;  JEH
  7273   "RTN","CHB PEBSD",249 ,0)
  7274    I ^TMP($J ,"EOB",CON TR)="#" D   G EBP1
  7275   "RTN","CHB PEBSD",250 ,0)
  7276    .;U IOVAR  W # Q   ;  JEH
  7277   "RTN","CHB PEBSD",251 ,0)
  7278    .S TMPLN= $C(12) D Z WCHAR^CHMS NUTL(IOVAR ,TMPLN) Q    ; JEH
  7279   "RTN","CHB PEBSD",252 ,0)
  7280    I ^TMP($J ,"EOB",CON TR)["DEPAR TMENT OF V ETERANS AF FAIRS" D   G EBP1
  7281   "RTN","CHB PEBSD",253 ,0)
  7282    .S CHPG=+ $E(^TMP($J ,"EOB",CON TR),121,12 3)
  7283   "RTN","CHB PEBSD",254 ,0)
  7284    .;D TRESI D^CHBPEB06  U IOVAR W  CHTRID_$E (^TMP($J," EOB",CONTR ),$L(CHTRI D)+1,132), !   ; JEH
  7285   "RTN","CHB PEBSD",255 ,0)
  7286    .D TRESID ^CHBPEB06    ; JEH
  7287   "RTN","CHB PEBSD",256 ,0)
  7288    .D ZWCHAR ^CHMSNUTL( IOVAR,CHTR ID_$E(^TMP ($J,"EOB", CONTR),$L( CHTRID)+1, 132))   ;  JEH
  7289   "RTN","CHB PEBSD",257 ,0)
  7290    I ^TMP($J ,"EOB",CON TR)["HEALT H ADMINIST RATION" D   G EBP1
  7291   "RTN","CHB PEBSD",258 ,0)
  7292    .;U IOVAR  W FMSDOCI D_$E(^TMP( $J,"EOB",C ONTR),$L(F MSDOCID)+1 ,132),!    ; JEH
  7293   "RTN","CHB PEBSD",259 ,0)
  7294    .D ZWCHAR ^CHMSNUTL( IOVAR,FMSD OCID_$E(^T MP($J,"EOB ",CONTR),$ L(FMSDOCID )+1,132))    ; JEH
  7295   "RTN","CHB PEBSD",260 ,0)
  7296    ;U IOVAR  W $E(^TMP( $J,"EOB",C ONTR),1,13 2),!   ; J EH
  7297   "RTN","CHB PEBSD",261 ,0)
  7298    D ZWCHAR^ CHMSNUTL(I OVAR,$E(^T MP($J,"EOB ",CONTR),1 ,132))   ;  JEH
  7299   "RTN","CHB PEBSD",262 ,0)
  7300    G EBP1
  7301   "RTN","CHB PEBSD",263 ,0)
  7302   EPRTED ;
  7303   "RTN","CHB PEBSD",264 ,0)
  7304    K ^TMP($J ,"EOB")
  7305   "RTN","CHB PEBSD",265 ,0)
  7306    Q
  7307   "RTN","CHB PEBSD",266 ,0)
  7308   EDI835 ;
  7309   "RTN","CHB PEBSD",267 ,0)
  7310    S TMPCLPT =0
  7311   "RTN","CHB PEBSD",268 ,0)
  7312    S CHDOCID =$E(FMSDOC ID,1,3)_"R "_DT_$E(FM SDOCID,5,1 1)
  7313   "RTN","CHB PEBSD",269 ,0)
  7314   E835 S TMP CLPT=$O(TM P("PAY-EOB ","PROV",T MPCLPT)) Q :'TMPCLPT
  7315   "RTN","CHB PEBSD",270 ,0)
  7316    ;S CHDOCI D=$E(FMSDO CID,1,3)_" R"_$E(FMSD OCID,5,11)   ;AEB 5/1 6/2006 NEE D TO HAVE  UNIQUE ID  IN ^CHMEDI
  7317   "RTN","CHB PEBSD",271 ,0)
  7318    S CHAMT=0
  7319   "RTN","CHB PEBSD",272 ,0)
  7320    S X1=TMPC LPT D PROG TYP^CHFCD0 01
  7321   "RTN","CHB PEBSD",273 ,0)
  7322    G:'$D(@(G LPAY_"TMPC LPT,0)"))  E835
  7323   "RTN","CHB PEBSD",274 ,0)
  7324    S VENPT=$ P(@(GLPAY_ "TMPCLPT,0 )"),"^",3)
  7325   "RTN","CHB PEBSD",275 ,0)
  7326    ;Team Tra ck #: 5592  - HIPAA R EADY
  7327   "RTN","CHB PEBSD",276 ,0)
  7328    ;Changed  to call ne w 835 rout ine...this  routine p hase out
  7329   "RTN","CHB PEBSD",277 ,0)
  7330    ;S EDITYP =$$CHPID^C HEDIFU1(TM PCLPT) I E DITYP'=""  S CHCLM=TM PCLPT D SE T^CHBPRD6
  7331   "RTN","CHB PEBSD",278 ,0)
  7332    S EDITYP= $$CHPID^CH 835FU1(TMP CLPT) I ED ITYP'="" S  CHCLM=TMP CLPT D SET ^CHBPRD6
  7333   "RTN","CHB PEBSD",279 ,0)
  7334    G E835
  7335   "RTN","CHB PEBSD",280 ,0)
  7336   CKPRTFLG ; SET PRTEOB =0 IF ^CHM VEN(I,5) E OB PRINT F LAG=0 (DO  NOT PRINT  EOB)  ;DEV 012853-02  YJK 8/19/1
  7337   "RTN","CHB PEBSD",281 ,0)
  7338    Q:'$D(VEN PT)
  7339   "RTN","CHB PEBSD",282 ,0)
  7340    Q:VENPT=" "
  7341   "RTN","CHB PEBSD",283 ,0)
  7342    Q:'$D(^CH MVEN(VENPT ,5))
  7343   "RTN","CHB PEBSD",284 ,0)
  7344    I $P(^CHM VEN(VENPT, 5),"^",2)= 0 S PRTEOB =0 
  7345   "RTN","CHB PEBSD",285 ,0)
  7346    Q
  7347   "RTN","CHB PEBSD",286 ,0)
  7348   CKPRTFLG2  ;CHK FOR B ENE BAD AD D FLAG OR  DEATH & DO  NOT PRINT  EOB - DGC  3/27/2012  DEV009201  BEGIN
  7349   "RTN","CHB PEBSD",287 ,0)
  7350    Q:PRTEOB= 0
  7351   "RTN","CHB PEBSD",288 ,0)
  7352    S ADDFLG= $P(^AHCHVA (DFN,100,B FN,1),"^", 10),DODTH= $P(^AHCHVA (DFN,100,B FN,0),"^", 6)
  7353   "RTN","CHB PEBSD",289 ,0)
  7354    I (ADDFLG =0)!(DODTH '="") S PR TEOB=0 Q
  7355   "RTN","CHB PEBSD",290 ,0)
  7356    Q ;DGC 3/ 27/2012 DE V009201 EN D
  7357   "RTN","CHF BC2A")
  7358   0^7^B28422 7801
  7359   "RTN","CHF BC2A",1,0)
  7360   CHFBC2A ;H AC/CR;GETS  ALLOWABLE  AMOUNTS F OR OP PROC ;Feb 05, 2 019@09:29: 06
  7361   "RTN","CHF BC2A",2,0)
  7362    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  7363   "RTN","CHF BC2A",3,0)
  7364    ;CPTS #10 846*, 1123 3*, #11736 * (DTP,4-2 3-97)
  7365   "RTN","CHF BC2A",4,0)
  7366    ;CPTS #10 292*, 7/8/ 97 *CR*
  7367   "RTN","CHF BC2A",5,0)
  7368    ;CPTS #11 937*  7/11 /97 *CR*
  7369   "RTN","CHF BC2A",6,0)
  7370    ;CPTS #62 98 7/15/97  *CR*
  7371   "RTN","CHF BC2A",7,0)
  7372    ;CPTS #13 733 BY DTP  (13-FEB-9 8)*
  7373   "RTN","CHF BC2A",8,0)
  7374    ;CPTS #14 619 BY JLR *
  7375   "RTN","CHF BC2A",9,0)
  7376    ;CPTS #14 051 BY JLR  (20-JUL-9 8)*
  7377   "RTN","CHF BC2A",10,0 )
  7378    ;CPTS #16 182 (Y2K)  - fixed FN  number fo r prevaili ng fee glo bal - CHMS PF
  7379   "RTN","CHF BC2A",11,0 )
  7380    ;CPTS #16 336 BY DTP  (26-MAR-9 9)*
  7381   "RTN","CHF BC2A",12,0 )
  7382    ;CR MC215  JEH 8/21/ 06 - Modif ied to acc ept new CM AC file fo rmat
  7383   "RTN","CHF BC2A",13,0 )
  7384    ;TT DEF00 4574  JEH  3/25/08 -  Remove fac ility/non- facility c alls to gl obal ^IBE( 353.1 from  CHV routi nes
  7385   "RTN","CHF BC2A",14,0 )
  7386    ;TT ENC00 4843: JEH  2/13/09 -  Payment of  CPT codes  requiring  TC or 26  modifier
  7387   "RTN","CHF BC2A",15,0 )
  7388    ;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
  7389   "RTN","CHF BC2A",16,0 )
  7390    ;DEF00924 8-03 DPT 4 /08/10 edi t range of  dates for  begin and  terminal  dates,BUG0 09248-03,0 4,05
  7391   "RTN","CHF BC2A",17,0 )
  7392    ;;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
  7393   "RTN","CHF BC2A",18,0 )
  7394    ;;type of  service ( outpatient  or inpati ent)  GLOB AL -- 7410 06.03 (CBS A cross wa lk)
  7395   "RTN","CHF BC2A",19,0 )
  7396    ;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
  7397   "RTN","CHF BC2A",20,0 )
  7398    ;order.   DRW 01/04/ 13.
  7399   "RTN","CHF BC2A",21,0 )
  7400    ;DEF01676 3 DPT 4/28 /14 - REJE CT 196 IF  DOS IS OUT SIDE DATE  RANGE FOR  CODES
  7401   "RTN","CHF BC2A",22,0 )
  7402    ;BUG01676 3 DPT 4/30 /14 - CORR ECT BUG
  7403   "RTN","CHF BC2A",23,0 )
  7404    ;DEV00465 1 2/11/14  EW - FLAG  ADDED SO C MAC CALC C AN BE USED  FOR WIP R EPORT
  7405   "RTN","CHF BC2A",24,0 )
  7406    ;Warning  CHFBC2 and  CHFBC2D m ust have t he above c hange pres ent if thi s routine  has the ch ange
  7407   "RTN","CHF BC2A",25,0 )
  7408    ;DEV02195 6 Modify r outine to  allow for  correct wa ge rate to  be applie d when
  7409   "RTN","CHF BC2A",26,0 )
  7410    ;effectiv e date fal ls on the  same day a s Date Of  Service.   DRW 10/22/ 2014
  7411   "RTN","CHF BC2A",27,0 )
  7412    ;DEV02259 2 JSE 3/3/ 15 - FIX S UBSCRIPT E RROR (NEXT +11)
  7413   "RTN","CHF BC2A",28,0 )
  7414    ;DEV02563 3 RFE 6/30 /16 Correc t subscrip t error in  GETMOD
  7415   "RTN","CHF BC2A",29,0 )
  7416    ;nsd I184 39016FY18  - dpt 1/24 /18
  7417   "RTN","CHF BC2A",30,0 )
  7418    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  7419   "RTN","CHF BC2A",31,0 )
  7420    ;CFS 03/2 2/18 CPE00 1-119 Fix  Undefined  error caus ed by a Na ked Global  Reference .
  7421   "RTN","CHF BC2A",32,0 )
  7422    ;BDB 04/1 2/18 Redef ine CHGRDT 1 for subs cript erro r, add ser vice code  range chec k
  7423   "RTN","CHF BC2A",33,0 )
  7424    ;SBB 05/0 3/18 Fix N DC issue -  Defect 73 0459
  7425   "RTN","CHF BC2A",34,0 )
  7426    ;DYO 12/0 5/18 Fix D ME TRV cla ims going  to missing  data queu e if no PL  ZIP - Def ect 832284 .
  7427   "RTN","CHF BC2A",35,0 )
  7428    ;
  7429   "RTN","CHF BC2A",36,0 )
  7430    S CHMPF=0 ,CHMPFD="" ,HOSPAMT=0  K ALLOW
  7431   "RTN","CHF BC2A",37,0 )
  7432    S CHADOS= $P(REC0,"^ ",8) G PF: CHADOS<292 1001
  7433   "RTN","CHF BC2A",38,0 )
  7434    S VI=$P(R EC0,"^",3)  Q:VI=""
  7435   "RTN","CHF BC2A",39,0 )
  7436    ;I $D(^CH MVEN(VI,1) ) I $P(^(1 ),"^",16)= 1 G END:K2 ="DME-SUPP LY" ; JAK  - 03/31/10  - DEF0089 17
  7437   "RTN","CHF BC2A",40,0 )
  7438    G END:$P( REC0,"^",2 7)=2
  7439   "RTN","CHF BC2A",41,0 )
  7440    S RECC=@( GLPAY_"CI, ""COMMON"" )")
  7441   "RTN","CHF BC2A",42,0 )
  7442    ;
  7443   "RTN","CHF BC2A",43,0 )
  7444   PHP  ;
  7445   "RTN","CHF BC2A",44,0 )
  7446    G HOSPCE: CHADOS<297 0801
  7447   "RTN","CHF BC2A",45,0 )
  7448    G HOSPCE: $P(RECC,"^ ",2)=""                       ;; DEV006421  -- added l ine tag HO SPCE (orgi nally, ASC )
  7449   "RTN","CHF BC2A",46,0 )
  7450    G HOSPCE: $P(^CHMDIC (741002.11 ,$P(RECC," ^",2),0)," ^",1)'="PH P"  ;CHECK ING FACILI TY TYPE
  7451   "RTN","CHF BC2A",47,0 )
  7452    G HOSPCE: '$D(^CHMDI C(741013.1 3,"B",$P(@ (GLPAY_"CI ,K2,NM,0)" ),"^",1)))   ;CHECKIN G PHP CODE S
  7453   "RTN","CHF BC2A",48,0 )
  7454    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef
  7455   "RTN","CHF BC2A",49,0 )
  7456    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END
  7457   "RTN","CHF BC2A",50,0 )
  7458    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  7459   "RTN","CHF BC2A",51,0 )
  7460    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END
  7461   "RTN","CHF BC2A",52,0 )
  7462    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  7463   "RTN","CHF BC2A",53,0 )
  7464    ;Defect 8 32284 STAR T
  7465   "RTN","CHF BC2A",54,0 )
  7466    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  PL-ZIP MIS SING" G EN D
  7467   "RTN","CHF BC2A",55,0 )
  7468    I VZ="" D  CHKPLZIP  G END
  7469   "RTN","CHF BC2A",56,0 )
  7470    ;Defect 8 32284 END
  7471   "RTN","CHF BC2A",57,0 )
  7472    S VC=$O(^ CHMSMSA("Z IP",VZ,0))  G HOSPCE: 'VC
  7473   "RTN","CHF BC2A",58,0 )
  7474    G HOSPCE: '$D(^CHMSM SA(VC,4,0) )
  7475   "RTN","CHF BC2A",59,0 )
  7476    S PHPDAT= $O(^CHMSMS A(VC,4,"B" ,CHADOS),- 1) G HOSPC E:'PHPDAT
  7477   "RTN","CHF BC2A",60,0 )
  7478    S PHPI=$O (^CHMSMSA( VC,4,"B",P HPDAT,0))  G HOSPCE:' PHPI
  7479   "RTN","CHF BC2A",61,0 )
  7480    G HOSPCE: '$D(^CHMSM SA(VC,4,PH PI,0))
  7481   "RTN","CHF BC2A",62,0 )
  7482    S PHPF=$O (^CHMDIC(7 41013.13," B",$P(@(GL PAY_"CI,K2 ,NM,0)")," ^",1),0))  G HOSPCE:' PHPF
  7483   "RTN","CHF BC2A",63,0 )
  7484    S FDHD=$P (^CHMDIC(7 41013.13,P HPF,0),"^" ,2)
  7485   "RTN","CHF BC2A",64,0 )
  7486    S CHMPF=$ P(^CHMSMSA (VC,4,PHPI ,0),"^",FD HD)
  7487   "RTN","CHF BC2A",65,0 )
  7488    G HOSPCE: +CHMPF=0
  7489   "RTN","CHF BC2A",66,0 )
  7490    S CMAC(NM )=CHMPF
  7491   "RTN","CHF BC2A",67,0 )
  7492    S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=5
  7493   "RTN","CHF BC2A",68,0 )
  7494    G END
  7495   "RTN","CHF BC2A",69,0 )
  7496   HOSPCE  ;   DEV006421  incorpora ting a new  payment r equirement  for hospi ce payment
  7497   "RTN","CHF BC2A",70,0 )
  7498    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
  7499   "RTN","CHF BC2A",71,0 )
  7500    G ASC:CHA DOS<297080 1                                                                  ;;this co de from he re to END  is new for  DEV006421  - DRW - 0 6/15/12
  7501   "RTN","CHF BC2A",72,0 )
  7502    G ASC:$P( RECC,"^",1 6)'=5                 ;;5 indica tes outpat ient
  7503   "RTN","CHF BC2A",73,0 )
  7504    S FLG=0
  7505   "RTN","CHF BC2A",74,0 )
  7506    I $P(RECC ,"^",2)=""  G NEXT
  7507   "RTN","CHF BC2A",75,0 )
  7508    I $P(^CHM DIC(741002 .11,$P(REC C,"^",2),0 ),"^",1)=" HPC" S FLG =FLG+1  ;; hospice fa cility typ e
  7509   "RTN","CHF BC2A",76,0 )
  7510   NEXT  ;     in order  to avoid s ubscript e rror if fa cility typ e not defi ned
  7511   "RTN","CHF BC2A",77,0 )
  7512    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
  7513   "RTN","CHF BC2A",78,0 )
  7514    G:(CHMSPC '="X7000") &(CHMSPC'= "X7001")&( CHMSPC'="0 0.00")&(CH MSPC'="00. 99") ASC
  7515   "RTN","CHF BC2A",79,0 )
  7516    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef
  7517   "RTN","CHF BC2A",80,0 )
  7518    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END
  7519   "RTN","CHF BC2A",81,0 )
  7520    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  7521   "RTN","CHF BC2A",82,0 )
  7522    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END
  7523   "RTN","CHF BC2A",83,0 )
  7524    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  7525   "RTN","CHF BC2A",84,0 )
  7526    ;Defect 8 32284 STAR T
  7527   "RTN","CHF BC2A",85,0 )
  7528    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  PL-ZIP MIS SING" G EN D
  7529   "RTN","CHF BC2A",86,0 )
  7530    I VZ="" D  CHKPLZIP  G END
  7531   "RTN","CHF BC2A",87,0 )
  7532    ;Defect 8 32284 END
  7533   "RTN","CHF BC2A",88,0 )
  7534    S IEN=$O( ^CHMDIC(74 1006.03,"B ",VZ,0))    ;;find th e IEN for  the CBSA c rosswalk b ased on zi p
  7535   "RTN","CHF BC2A",89,0 )
  7536    ;
  7537   "RTN","CHF BC2A",90,0 )
  7538    ;;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
  7539   "RTN","CHF BC2A",91,0 )
  7540    ;;                       COMMEN T OUT HOW  NM1 WAS OR IGINALY SE T & THE AT TEMPTED FI X FROM DEV 021956 (BE LOW)
  7541   "RTN","CHF BC2A",92,0 )
  7542    ;S NM1=$O (^CHMDIC(7 41006.03,I EN,1,CHADO S),-1)                                 ;; O RIG CODE I NCORRECT,  CAUSING SU BSCRIPT ER RS
  7543   "RTN","CHF BC2A",93,0 )
  7544    ;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
  7545   "RTN","CHF BC2A",94,0 )
  7546    ;S EFFDT= $P(^CHMDIC (741006.03 ,IEN,1,NM1 ,0),"^",1)                             ;; D EV021956 D RW 11/06/2 014
  7547   "RTN","CHF BC2A",95,0 )
  7548    ;I CHADOS <EFFDT S N M1=NM1-1 G  CHECKDT      ;;LOOP  THROUGH UN TIL DOS IS  NO LONGER  LESS THAN  EFFECTIVE  DATE
  7549   "RTN","CHF BC2A",96,0 )
  7550    ;
  7551   "RTN","CHF BC2A",97,0 )
  7552    ;;DEV0225 92 JSE - N EW LOGIC(B ELOW) CORR ECTLY SETS  NM1. THIS  LOGIC REP LACE THE L OGIC ABOVE .
  7553   "RTN","CHF BC2A",98,0 )
  7554    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
  7555   "RTN","CHF BC2A",99,0 )
  7556    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
  7557   "RTN","CHF BC2A",100, 0)
  7558    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
  7559   "RTN","CHF BC2A",101, 0)
  7560    S NM1=$O( ^CHMDIC(74 1006.03,IE N,1,"B",CH ADOS2,""))                   ;;  DEV022592  JSE - SET  NM1 TO ENT RY# 4 SELE CTED DATE
  7561   "RTN","CHF BC2A",102, 0)
  7562    ;
  7563   "RTN","CHF BC2A",103, 0)
  7564    S CBSA=$P (^CHMDIC(7 41006.03,I EN,1,NM1,0 ),"^",5)
  7565   "RTN","CHF BC2A",104, 0)
  7566    ;;once th e CBSA is  found, use  the CBSA  to find th e wage ind ex on glob al ^CHMDIC (741043
  7567   "RTN","CHF BC2A",105, 0)
  7568    S CBSAIEN =$O(^CHMDI C(741043," B",CBSA,0) )
  7569   "RTN","CHF BC2A",106, 0)
  7570    ;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))
  7571   "RTN","CHF BC2A",107, 0)
  7572    I $D(^CHM DIC(741043 ,CBSAIEN,1 ,"B",CHADO S)) S CBSA NM=CHADOS         ;;  DEV021956  DRW - ADDE D IF/ELSE  FOR EFFECT IVE DATE
  7573   "RTN","CHF BC2A",108, 0)
  7574    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))
  7575   "RTN","CHF BC2A",109, 0)
  7576    I CBSANM= "" S CBSAN M=$O(^CHMD IC(741043, CBSAIEN,1, "B",CHADOS ))
  7577   "RTN","CHF BC2A",110, 0)
  7578    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
  7579   "RTN","CHF BC2A",111, 0)
  7580    S CBSAWG= $P(^CHMDIC (741043,CB SAIEN,1,CB SAENT,0)," ^",6)             ;;w age index  rate for t he hospice  claim
  7581   "RTN","CHF BC2A",112, 0)
  7582    ;;once th e CBSAWG i s found, u se the for mula rate  associated  with the  service co de in
  7583   "RTN","CHF BC2A",113, 0)
  7584    ;;global  ^CHMDIC(74 1045 to de termine th e hospice  per diem r ate
  7585   "RTN","CHF BC2A",114, 0)
  7586    S CBSAIEN 1=$O(^CHMD IC(741045, "B",CHMSPC ,0))
  7587   "RTN","CHF BC2A",115, 0)
  7588    ;S CBSANM 1=$O(^CHMD IC(741045, CBSAIEN1,1 ,"B",CHADO S),-1)
  7589   "RTN","CHF BC2A",116, 0)
  7590    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
  7591   "RTN","CHF BC2A",117, 0)
  7592    E  S CBSA NM1=$O(^CH MDIC(74104 5,CBSAIEN1 ,1,"B",CHA DOS),-1)
  7593   "RTN","CHF BC2A",118, 0)
  7594    I CBSANM1 ="" S CBSA NM1=$O(^CH MDIC(74104 5,CBSAIEN1 ,1,"B",CHA DOS))
  7595   "RTN","CHF BC2A",119, 0)
  7596    S CBSAENT 1=$O(^CHMD IC(741045, CBSAIEN1,1 ,"B",CBSAN M1,0))            ;;f ind the en try locati on of date
  7597   "RTN","CHF BC2A",120, 0)
  7598    S CBSAWC= $P(^CHMDIC (741045,CB SAIEN1,1,C BSAENT1,0) ,"^",4)           ;;f ind the wa ge compone nt
  7599   "RTN","CHF BC2A",121, 0)
  7600    S CBSANWA =$P(^CHMDI C(741045,C BSAIEN1,1, CBSAENT1,0 ),"^",5)          ;;f ind the no n-weighted  amount
  7601   "RTN","CHF BC2A",122, 0)
  7602    S HOSPAMT =(CBSAWC*C BSAWG)+CBS ANWA                           ; ;multiply  wage compo nent by th e CBSA ind ex + non-w eighted am t
  7603   "RTN","CHF BC2A",123, 0)
  7604    I CHMSPC= "X7001" D
  7605   "RTN","CHF BC2A",124, 0)
  7606    . S HOSPA MT=HOSPAMT /24                                       ; ;divide by  the numbe r of hours  in one da y to get d aily rate
  7607   "RTN","CHF BC2A",125, 0)
  7608    S HOSPAMT =$FN(HOSPA MT,"",2)                                  ; ;the $FN f unction ro unds & set s to two d ecimal pla ces
  7609   "RTN","CHF BC2A",126, 0)
  7610    S CHMPF=+ HOSPAMT
  7611   "RTN","CHF BC2A",127, 0)
  7612    S CMAC(NM )=CHMPF
  7613   "RTN","CHF BC2A",128, 0)
  7614    G END
  7615   "RTN","CHF BC2A",129, 0)
  7616   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
  7617   "RTN","CHF BC2A",130, 0)
  7618    G CMAC:$P (RECC,"^", 2)=""
  7619   "RTN","CHF BC2A",131, 0)
  7620    G CMAC:$P (^CHMDIC(7 41002.11,$ P(RECC,"^" ,2),0),"^" ,1)'="ASC"
  7621   "RTN","CHF BC2A",132, 0)
  7622    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef
  7623   "RTN","CHF BC2A",133, 0)
  7624    ;I '$D(^C HMVEN(VI,2 )) S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ZIP MISSIN G" G END
  7625   "RTN","CHF BC2A",134, 0)
  7626    G CMAC:$P (^CHMVEN(V I,1),"^",7 )="" S CHF AC=$P(^(1) ,"^",7)
  7627   "RTN","CHF BC2A",135, 0)
  7628    G CMAC:($ P(^CHMDIC( 741002.11, CHFAC,0)," ^",1)'="AS F")&($P(^C HMDIC(7410 02.11,CHFA C,0),"^",1 )'="ASH")
  7629   "RTN","CHF BC2A",136, 0)
  7630    G ASC1:'$ D(^CHMAGP( "B",CHMSPC ))
  7631   "RTN","CHF BC2A",137, 0)
  7632    ; CPE VEN DOR STREAM LINING Rep lace Provi der zip wi th PL-ZIP  gef
  7633   "RTN","CHF BC2A",138, 0)
  7634    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  7635   "RTN","CHF BC2A",139, 0)
  7636    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR ZIP  MISSING"  G END
  7637   "RTN","CHF BC2A",140, 0)
  7638    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  7639   "RTN","CHF BC2A",141, 0)
  7640    ;Defect 8 32284 STAR T
  7641   "RTN","CHF BC2A",142, 0)
  7642    ;I VZ=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  PL-ZIP MIS SING" G EN D
  7643   "RTN","CHF BC2A",143, 0)
  7644    I VZ="" D  CHKPLZIP  G END
  7645   "RTN","CHF BC2A",144, 0)
  7646    ;Defect 8 32284 END
  7647   "RTN","CHF BC2A",145, 0)
  7648    S VC=$O(^ CHMDIC(741 002.82,"B" ,VZ,0)) G  CMAC:'VC
  7649   "RTN","CHF BC2A",146, 0)
  7650    S CHLDT=$ O(^CHMDIC( 741002.82, VC,1,99999 99),-1) G  CMAC:'CHLD T
  7651   "RTN","CHF BC2A",147, 0)
  7652    G CMAC:'$ D(^CHMDIC( 741002.82, VC,1,CHLDT ,0)) S CHM SA=$P(^(0) ,"^",2)
  7653   "RTN","CHF BC2A",148, 0)
  7654    F JJ=$L(C HMSA):1:3  S CHMSA="0 "_CHMSA
  7655   "RTN","CHF BC2A",149, 0)
  7656    S CHMGPN= 0,CHMGPN=$ O(^CHMAGP( "B",CHMSPC ,CHMGPN))
  7657   "RTN","CHF BC2A",150, 0)
  7658    I 'CHMGPN  I $P(^CHM DIC(741002 .11,CHFAC, 0),"^",1)= "ASF" G AS C2 ;nsd I1 8439016FY1 8 - dpt
  7659   "RTN","CHF BC2A",151, 0)
  7660    I 'CHMGPN  I $P(^CHM DIC(741002 .11,CHFAC, 0),"^",1)' ="ASF" G E ND ;:'CHMG PN  ;nsd I 18439016FY 18 - dpt
  7661   "RTN","CHF BC2A",152, 0)
  7662    ;I '$D(^C HMAGP(CHMG PN,1,(CHAD OS+1))) I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F"  G ASC2
  7663   "RTN","CHF BC2A",153, 0)
  7664    ;I '$D(^C HMAGP(CHMG PN,1,(CHAD OS+1))) I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)'="A SF" G CMAC
  7665   "RTN","CHF BC2A",154, 0)
  7666    ;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
  7667   "RTN","CHF BC2A",155, 0)
  7668    ;  .I $P( ^CHMDIC(74 1002.11,CH FAC,0),"^" ,1)="ASF"  G ASC2
  7669   "RTN","CHF BC2A",156, 0)
  7670    ;  .I $P( ^CHMDIC(74 1002.11,CH FAC,0),"^" ,1)'="ASF"  G CMAC  ; nsd I18439 016FY18 -  dpt
  7671   "RTN","CHF BC2A",157, 0)
  7672    S CHGRDT= CHADOS+1,M TCHFLG=""
  7673   "RTN","CHF BC2A",158, 0)
  7674   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
  7675   "RTN","CHF BC2A",159, 0)
  7676     S CHBEG= $P(^CHMAGP (CHMGPN,1, CHGRDT,0), "^",1) ;ns d I1843901 6FY18 - dp t
  7677   "RTN","CHF BC2A",160, 0)
  7678     S CHGRP= +$P(^CHMAG P(CHMGPN,1 ,CHGRDT,0) ,"^",2) ;D PT 8/18/10  BUG009248 -03
  7679   "RTN","CHF BC2A",161, 0)
  7680     S CHLEDT =+$P(^CHMA GP(CHMGPN, 1,CHGRDT,0 ),"^",3) ; BUG016763- 03-01 DPT  8/18/10
  7681   "RTN","CHF BC2A",162, 0)
  7682     I CHADOS >=CHBEG I  CHLEDT=0 S  CHGRDT1=C HGRDT S MT CHFLG="Y"  G CHMTFLG  ;nsd I1843 9016FY18 -  dpt
  7683   "RTN","CHF BC2A",163, 0)
  7684     I CHADOS <=CHLEDT S  CHGRDT1=C HGRDT S MT CHFLG="Y"  G CHMTFLG  ;nsd I1843 9016FY18 -  dpt
  7685   "RTN","CHF BC2A",164, 0)
  7686    ;S CHGRDT =$O(^CHMAG P(CHMGPN,1 ,9999999), -1)
  7687   "RTN","CHF BC2A",165, 0)
  7688     G CHCMGP
  7689   "RTN","CHF BC2A",166, 0)
  7690   CHMTFLG ;
  7691   "RTN","CHF BC2A",167, 0)
  7692    I MTCHFLG '="Y" I $P (^CHMDIC(7 41002.11,C HFAC,0),"^ ",1)="ASF"  G ASC2  ; ;nsd I1843 9016FY18 -  dpt
  7693   "RTN","CHF BC2A",168, 0)
  7694    I MTCHFLG '="Y" I $P (^CHMDIC(7 41002.11,C HFAC,0),"^ ",1)'="ASF " G END  ; ;nsd I1843 9016FY18 -  dpt
  7695   "RTN","CHF BC2A",169, 0)
  7696    ;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
  7697   "RTN","CHF BC2A",170, 0)
  7698    ;I CHADOS <CHBEG  I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)'="A SF" G END  ;TEST DPT
  7699   "RTN","CHF BC2A",171, 0)
  7700    ;G CMAC:' $D(^CHMAGP (CHMGPN,1, CHGRDT,0))  S CHGRP=+ $P(^(0),"^ ",2) ;DEAC TIVATE DPT
  7701   "RTN","CHF BC2A",172, 0)
  7702    ;I CHLEDT '=0,CHADOS >CHLEDT I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F"  G ASC2    ;;nsd I 18439016FY 18 - dpt
  7703   "RTN","CHF BC2A",173, 0)
  7704    ;I CHLEDT '=0,CHADOS >CHLEDT I  $P(^CHMDIC (741002.11 ,CHFAC,0), "^",1)="AS F" G CMAC  ;;nsd I184 39016FY18  - dpt
  7705   "RTN","CHF BC2A",174, 0)
  7706    S CHMMPN= 0,MTCHFLG= "" ;;nsd I 18439016FY 18 - dpt
  7707   "RTN","CHF BC2A",175, 0)
  7708   CHRATES ;
  7709   "RTN","CHF BC2A",176, 0)
  7710     I $D(^CH MART("B",C HMSA)) S C HMMPN=$O(^ CHMART("B" ,CHMSA,CHM MPN)) ;nsd  I18439016 FY18 - dpt
  7711   "RTN","CHF BC2A",177, 0)
  7712     I 'CHMMP N  I $P(^C HMDIC(7410 02.11,CHFA C,0),"^",1 )="ASF" G  ASC2 ;nsd  I18439016F Y18 - dpt
  7713   "RTN","CHF BC2A",178, 0)
  7714     I 'CHMMP N  I $P(^C HMDIC(7410 02.11,CHFA C,0),"^",1 )'="ASF" G  ASC1 ;bdb  04/13/17
  7715   "RTN","CHF BC2A",179, 0)
  7716     ;S CHMSD T=CHBEG,MT CHFLG=""
  7717   "RTN","CHF BC2A",180, 0)
  7718   CHRATES1 ;
  7719   "RTN","CHF BC2A",181, 0)
  7720    S CHGRDT1 =$O(^CHMAR T(CHMMPN,1 ,(CHADOS+1 )),-1) ;bd b 04122018  redefine  chgrdt1
  7721   "RTN","CHF BC2A",182, 0)
  7722    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
  7723   "RTN","CHF BC2A",183, 0)
  7724    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
  7725   "RTN","CHF BC2A",184, 0)
  7726    ;S CHMSDT =$O(^CHMAR T(CHMMPN,1 ,CHMSDT) G  ASC1:'CHM SDT ; DPT  3/28/11  B UG009248-0 5
  7727   "RTN","CHF BC2A",185, 0)
  7728    ;G CMAC:' $D(^CHMART (CHMMPN,1, CHGRDT,100 ,CHGRP,0))
  7729   "RTN","CHF BC2A",186, 0)
  7730    ;G CMAC:' $D(^CHMART (CHMMPN,1, CHMSDT,100 ,CHGRP,0))  S CHMPF=+ $P(^(0),"^ ",1)
  7731   "RTN","CHF BC2A",187, 0)
  7732    ;G CMAC:+ CHMPF=0
  7733   "RTN","CHF BC2A",188, 0)
  7734    S CHMSEDT =+$P(^CHMA RT(CHMMPN, 1,CHGRDT1, 0),"^",2)  ;DPT 8/18/ 10
  7735   "RTN","CHF BC2A",189, 0)
  7736    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
  7737   "RTN","CHF BC2A",190, 0)
  7738    I CHMSEDT '=0,CHADOS >CHMSEDT   I $P(^CHMD IC(741002. 11,CHFAC,0 ),"^",1)'= "ASF" G EN D  ;nsd I1 8439016FY1 8 - dpt
  7739   "RTN","CHF BC2A",191, 0)
  7740    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
  7741   "RTN","CHF BC2A",192, 0)
  7742    S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=3
  7743   "RTN","CHF BC2A",193, 0)
  7744    ;I WRT=1  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)")," ^",9)=3  ; DEV004651  2/11/14 EW  TEST FOR  WRITE FLAG
  7745   "RTN","CHF BC2A",194, 0)
  7746    S CMAC(NM )=CHMPF
  7747   "RTN","CHF BC2A",195, 0)
  7748    S $P(@(GL PAY_"CI,"" COMMON"")" ),"^",16)= 9
  7749   "RTN","CHF BC2A",196, 0)
  7750    ;I WRT=1  S $P(@(GLP AY_"CI,""C OMMON"")") ,"^",16)=9   ;DEV0046 51 2/11/14  EW TEST F OR WRITE F LAG
  7751   "RTN","CHF BC2A",197, 0)
  7752    G END
  7753   "RTN","CHF BC2A",198, 0)
  7754   ASC1 S CHM PF=+$P(@(G LPAY_"CI,K 2,NM,0)"), "^",2),CMA C(NM)=CHMP F
  7755   "RTN","CHF BC2A",199, 0)
  7756    S $P(@(GL PAY_"CI,"" COMMON"")" ),"^",16)= 9
  7757   "RTN","CHF BC2A",200, 0)
  7758    ;I WRT=1  S $P(@(GLP AY_"CI,""C OMMON"")") ,"^",16)=9   ;DEV0046 51 2/11/14  EW TEST F OR WRITE F LAG
  7759   "RTN","CHF BC2A",201, 0)
  7760    G END
  7761   "RTN","CHF BC2A",202, 0)
  7762   ASC2 ;
  7763   "RTN","CHF BC2A",203, 0)
  7764    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
  7765   "RTN","CHF BC2A",204, 0)
  7766    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
  7767   "RTN","CHF BC2A",205, 0)
  7768   CMAC I VI= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": VENDOR  ID MISSING " G END
  7769   "RTN","CHF BC2A",206, 0)
  7770    G PF:'$D( ^CHMVEN(VI ,41)) S CH CLS="" D   G PF:CHCLS =""
  7771   "RTN","CHF BC2A",207, 0)
  7772    .S CMJ=$O (^CHMVEN(V I,41,99999 99),-1) Q: 'CMJ
  7773   "RTN","CHF BC2A",208, 0)
  7774    .S CHCLS= $P(^CHMVEN (VI,41,CMJ ,0),"^",3)
  7775   "RTN","CHF BC2A",209, 0)
  7776    G PF:"1^2 ^3"'[CHCLS  S CHMSP=$ P(@(GLPAY_ "CI,K2,NM, 0)"),"^")
  7777   "RTN","CHF BC2A",210, 0)
  7778    S CHMSPC= $P(^CHMSER V(CHMSP,0) ,"^",1)
  7779   "RTN","CHF BC2A",211, 0)
  7780    ;CPE VEND OR STREAML INING repl ace Provid er Zip w/  PL-ZIP gef
  7781   "RTN","CHF BC2A",212, 0)
  7782    ;I '$D(^C HMVEN(VI,2 )) S VZ=""  G C0
  7783   "RTN","CHF BC2A",213, 0)
  7784    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  7785   "RTN","CHF BC2A",214, 0)
  7786    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  7787   "RTN","CHF BC2A",215, 0)
  7788    ;Defect 8 32284 STAR T
  7789   "RTN","CHF BC2A",216, 0)
  7790    ;C0 I VZ= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": PL-ZIP  MISSING" G  END
  7791   "RTN","CHF BC2A",217, 0)
  7792   C0 ;
  7793   "RTN","CHF BC2A",218, 0)
  7794    I VZ="" D  CHKPLZIP  G END
  7795   "RTN","CHF BC2A",219, 0)
  7796    ;Defect 8 32284 END
  7797   "RTN","CHF BC2A",220, 0)
  7798    S VC=$O(^ CHMDIC(741 002.4,"B", VZ,0))
  7799   "RTN","CHF BC2A",221, 0)
  7800    G PF:VC=" "
  7801   "RTN","CHF BC2A",222, 0)
  7802    S CHLDT=9 999999-CHA DOS-1
  7803   "RTN","CHF BC2A",223, 0)
  7804   C1 S CHLDT =$O(^CHMDI C(741002.4 ,VC,1,CHLD T)) G PF:C HLDT'?7N
  7805   "RTN","CHF BC2A",224, 0)
  7806    G PF:'$D( ^CHMDIC(74 1002.4,VC, 1,CHLDT,0) ) S CHLOC= $P(^(0),"^ ",2)
  7807   "RTN","CHF BC2A",225, 0)
  7808    S CHMSPN= $O(^CHMCPF ("B",CHMSP C,0)) G PF :'CHMSPN S  CHX=0
  7809   "RTN","CHF BC2A",226, 0)
  7810   C2 S CHX=$ O(^CHMCPF( CHMSPN,CHX )) G C1:'C HX
  7811   "RTN","CHF BC2A",227, 0)
  7812    G:CHX+8>1 000 C1
  7813   "RTN","CHF BC2A",228, 0)
  7814    G:CHX+8>C HLOC C22
  7815   "RTN","CHF BC2A",229, 0)
  7816    G C2
  7817   "RTN","CHF BC2A",230, 0)
  7818   C22 S CHCM DT=9999999 -CHADOS-1
  7819   "RTN","CHF BC2A",231, 0)
  7820   C3 S CHCMD T=$O(^CHMC PF(CHMSPN, CHX,CHCMDT )) G PF:CH CMDT'?7N
  7821   "RTN","CHF BC2A",232, 0)
  7822    G PF:'$D( ^CHMCPF(CH MSPN,CHX,C HCMDT,0))
  7823   "RTN","CHF BC2A",233, 0)
  7824    S CHLNM=C HLOC#8 S:C HLOC#8=0 C HLNM=8
  7825   "RTN","CHF BC2A",234, 0)
  7826    S CHMREC= $P(^CHMCPF (CHMSPN,CH X,CHCMDT,0 ),"^",2)
  7827   "RTN","CHF BC2A",235, 0)
  7828    S CHPNM=$ P(CHMREC," ,",CHLNM)
  7829   "RTN","CHF BC2A",236, 0)
  7830    D:CHADOS> 3070131 GE TCLP   ; J EH 2/1/07   CUT-OVER  DATE (2/1/ 07) TO NEW  CMAC FORM AT
  7831   "RTN","CHF BC2A",237, 0)
  7832    S CHMPF=$ P(CHPNM,"; ",CHCLS),M OD=""
  7833   "RTN","CHF BC2A",238, 0)
  7834    I K2="OPT -PROC" D       ;JEH 2 /13/09  TT  ENC004843
  7835   "RTN","CHF BC2A",239, 0)
  7836    .S MOD=$$ GTMOD^CHFB C2A(CI,K2, NM,CHMSPC)          ; JEH 2/13/0 9  TT ENC0 04843  ADD ED SUBROUT INE
  7837   "RTN","CHF BC2A",240, 0)
  7838    ;S:K2="OP T-PROC" MO D=$P(@(GLP AY_"CI,K2, NM,0)"),"^ ",4)   ;JE H 2/13/09   TT ENC004 843
  7839   "RTN","CHF BC2A",241, 0)
  7840    S:K2="DEN -PROC" MOD =$P(@(GLPA Y_"CI,K2,N M,0)"),"^" ,6)
  7841   "RTN","CHF BC2A",242, 0)
  7842    D:MOD'=""
  7843   "RTN","CHF BC2A",243, 0)
  7844    .Q:CHADOS <2970701
  7845   "RTN","CHF BC2A",244, 0)
  7846    .Q:('$D(^ CHMDIC(741 002.98,"B" ,MOD)))&(' $D(^CHMDIC (741002.99 ,"B",MOD)) )
  7847   "RTN","CHF BC2A",245, 0)
  7848    .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:"")
  7849   "RTN","CHF BC2A",246, 0)
  7850    .Q:FILEPT =""
  7851   "RTN","CHF BC2A",247, 0)
  7852    .I '$D(^C HMCPF(CHMS PN,CHX,CHC MDT,1)) D   Q         ;PRO/TECH
  7853   "RTN","CHF BC2A",248, 0)
  7854    ..S REA=" ",PERC=""
  7855   "RTN","CHF BC2A",249, 0)
  7856    ..S MODI= $O(^CHMDIC (FILEPT,"B ",MOD,0))
  7857   "RTN","CHF BC2A",250, 0)
  7858    ..I MODI' ="" S:$D(^ CHMDIC(FIL EPT,MODI,0 )) REA=$P( ^(0),"^",2 ),PERC=$P( ^(0),"^",3 )
  7859   "RTN","CHF BC2A",251, 0)
  7860    ..S CHMPF =CHMPF*PER C
  7861   "RTN","CHF BC2A",252, 0)
  7862    ..S X1=CI  D PROGTYP ^CHFCD001
  7863   "RTN","CHF BC2A",253, 0)
  7864    ..S $P(@( GLPAY_"CI, K1,NM,0)") ,"^",2)=RE A
  7865   "RTN","CHF BC2A",254, 0)
  7866    ..;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
  7867   "RTN","CHF BC2A",255, 0)
  7868    ..;S $P(@ (GLPAY_"CI ,""RULE-PR OC"",NM,0) "),U,2)=RE A
  7869   "RTN","CHF BC2A",256, 0)
  7870    .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
  7871   "RTN","CHF BC2A",257, 0)
  7872    ..S PERC= "",REA=""
  7873   "RTN","CHF BC2A",258, 0)
  7874    ..S MODI= $O(^CHMDIC (FILEPT,"B ",MOD,0))
  7875   "RTN","CHF BC2A",259, 0)
  7876    ..I MODI' ="" S:$D(^ CHMDIC(FIL EPT,MODI,0 )) REA=$P( ^(0),"^",2 ),PERC=$P( ^(0),"^",3 )
  7877   "RTN","CHF BC2A",260, 0)
  7878    ..S CHMPF =CHMPF*PER C
  7879   "RTN","CHF BC2A",261, 0)
  7880    ..S X1=CI  D PROGTYP ^CHFCD001
  7881   "RTN","CHF BC2A",262, 0)
  7882    ..S $P(@( GLPAY_"CI, K1,NM,0)") ,"^",2)=RE A
  7883   "RTN","CHF BC2A",263, 0)
  7884    ..;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
  7885   "RTN","CHF BC2A",264, 0)
  7886    ..;S $P(@ (GLPAY_"CI ,""RULE-PR OC"",NM,0) "),U,2)=RE A
  7887   "RTN","CHF BC2A",265, 0)
  7888    .S CHMREC 1=$P(^CHMC PF(CHMSPN, CHX,CHCMDT ,1),"^",2)
  7889   "RTN","CHF BC2A",266, 0)
  7890    .S CHPNM1 =$P(CHMREC 1,",",CHLN M)
  7891   "RTN","CHF BC2A",267, 0)
  7892    .;S:FILEP T=741002.9 8 PT1=CHCL S                        ;CHAMPV A PROF COM PONENT MOD IFIERS
  7893   "RTN","CHF BC2A",268, 0)
  7894    .;S:FILEP T=741002.9 9 PT1=$S(C HCLS=1:2,C HCLS=3:4)     ;CHAMPV A TECH COM PONENT MOD IFIERS
  7895   "RTN","CHF BC2A",269, 0)
  7896    .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
  7897   "RTN","CHF BC2A",270, 0)
  7898    ..I CHADO S<3070201  D
  7899   "RTN","CHF BC2A",271, 0)
  7900    ...S PT1= CHCLS
  7901   "RTN","CHF BC2A",272, 0)
  7902    ..E  D
  7903   "RTN","CHF BC2A",273, 0)
  7904    ...S PT1= $S(CHCLS=1 :1,CHCLS=2 :1,CHCLS=3 :3,CHCLS=4 :3)
  7905   "RTN","CHF BC2A",274, 0)
  7906    .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
  7907   "RTN","CHF BC2A",275, 0)
  7908    ..I CHADO S<3070201  D
  7909   "RTN","CHF BC2A",276, 0)
  7910    ...S PT1= $S(CHCLS=1 :2,CHCLS=3 :4)
  7911   "RTN","CHF BC2A",277, 0)
  7912    ..E  D
  7913   "RTN","CHF BC2A",278, 0)
  7914    ...S PT1= $S(CHCLS=1 :2,CHCLS=2 :2,CHCLS=3 :4,CHCLS=4 :4)
  7915   "RTN","CHF BC2A",279, 0)
  7916    .S CHMPF= $P(CHPNM1, ";",PT1)
  7917   "RTN","CHF BC2A",280, 0)
  7918    .S REA=""
  7919   "RTN","CHF BC2A",281, 0)
  7920    .S MODI=$ O(^CHMDIC( FILEPT,"B" ,MOD,0))
  7921   "RTN","CHF BC2A",282, 0)
  7922    .I MODI'= "" S:$D(^C HMDIC(FILE PT,MODI,0) ) REA=$P(^ (0),"^",2)
  7923   "RTN","CHF BC2A",283, 0)
  7924    .S X1=CI  D PROGTYP^ CHFCD001
  7925   "RTN","CHF BC2A",284, 0)
  7926    .S $P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=REA
  7927   "RTN","CHF BC2A",285, 0)
  7928    .;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
  7929   "RTN","CHF BC2A",286, 0)
  7930    .;S $P(@( GLPAY_"CI, ""RULE-PRO C"",NM,0)" ),U,2)=REA
  7931   "RTN","CHF BC2A",287, 0)
  7932    G PF:+CHM PF=0
  7933   "RTN","CHF BC2A",288, 0)
  7934    S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=1
  7935   "RTN","CHF BC2A",289, 0)
  7936    ;I WRT=1  S $P(@(GLP AY_"CI,""R ULE-PROC"" ,NM,0)")," ^",9)=1  ; DEV004651  2/11/14 EW  TEST FOR  WRITE FLAG
  7937   "RTN","CHF BC2A",290, 0)
  7938    S CMAC(NM )=CHMPF
  7939   "RTN","CHF BC2A",291, 0)
  7940    G END
  7941   "RTN","CHF BC2A",292, 0)
  7942   PF S CHMPF =0,CHMDOS= $P(REC0,"^ ",8),CHMRD T=9999999- CHMDOS,CHM RSD=CHMRDT -1
  7943   "RTN","CHF BC2A",293, 0)
  7944    ; Y2K fix
  7945   "RTN","CHF BC2A",294, 0)
  7946    ;S YR=$E( CHMDOS,2,3 ) I $E(YR, 2)="0" S Y R=$E(YR,1)
  7947   "RTN","CHF BC2A",295, 0)
  7948    ;S FN="74 1012."_YR
  7949   "RTN","CHF BC2A",296, 0)
  7950    S YR=$E(C HMDOS,1,3)
  7951   "RTN","CHF BC2A",297, 0)
  7952    S FN=$$FN SET^CHFBC2 A(CHMDOS)
  7953   "RTN","CHF BC2A",298, 0)
  7954    ;
  7955   "RTN","CHF BC2A",299, 0)
  7956    S CHMSPC= $P(@(GLPAY _"CI,K2,NM ,0)"),"^")
  7957   "RTN","CHF BC2A",300, 0)
  7958    S VI=$P(R EC0,"^",3)
  7959   "RTN","CHF BC2A",301, 0)
  7960    I VI="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": V ENDOR ID M ISSING" G  END
  7961   "RTN","CHF BC2A",302, 0)
  7962    ;CPE VEND OR STREAML INING repl ace Provid er Zip w/  PL-ZIP gef
  7963   "RTN","CHF BC2A",303, 0)
  7964    ;I '$D(^C HMVEN(VI,2 )) S VZ=""  G A0
  7965   "RTN","CHF BC2A",304, 0)
  7966    ;S VZ=$E( $P(^CHMVEN (VI,2),"^" ,5),1,5)
  7967   "RTN","CHF BC2A",305, 0)
  7968    S VZ=$E($ P($G(^CHMP AY(CI,"VEN -II")),"^" ,15),1,5)
  7969   "RTN","CHF BC2A",306, 0)
  7970    ;Defect 8 32284 STAR T
  7971   "RTN","CHF BC2A",307, 0)
  7972    ;A0 I VZ= "" S CHMFQ UE=10,CHMM DP=CHMMDP_ ": PL-ZIP  MISSING" G  END
  7973   "RTN","CHF BC2A",308, 0)
  7974   A0 ;
  7975   "RTN","CHF BC2A",309, 0)
  7976    I VZ="" D  CHKPLZIP  G END
  7977   "RTN","CHF BC2A",310, 0)
  7978    ;Defect 8 32284 END
  7979   "RTN","CHF BC2A",311, 0)
  7980    S VST=$P( ^CHMVEN(VI ,2),"^",4)   ;CPE001- 119 CFS -  Fix undefi ned error.
  7981   "RTN","CHF BC2A",312, 0)
  7982    I VST=""  S CHMFQUE= 10,CHMMDP= CHMMDP_":  VENDOR STA TE MISSING  " G END
  7983   "RTN","CHF BC2A",313, 0)
  7984    S VC=$O(^ CHMSMSA("Z IP",VZ,VST ,0))
  7985   "RTN","CHF BC2A",314, 0)
  7986    ;SBB 05/0 3/18 Fix N DC issue -  Defect 73 0459
  7987   "RTN","CHF BC2A",315, 0)
  7988    I VC="" S  VST=$O(^C HMSMSA("ZI P",VZ,0))
  7989   "RTN","CHF BC2A",316, 0)
  7990    I VST'=""  S VC=$O(^ CHMSMSA("Z IP",VZ,VST ,0))
  7991   "RTN","CHF BC2A",317, 0)
  7992    I VC="" S  CHMFQUE=1 0,CHMMDP=C HMMDP_": P L-ZIP UNKN OWN OR INC OMPATIBLE  WITH STATE " G END
  7993   "RTN","CHF BC2A",318, 0)
  7994    S CHMSPN= $O(^CHMSPF (FN,"B",CH MSPC,0)) G :CHMSPN=""  END
  7995   "RTN","CHF BC2A",319, 0)
  7996    I $D(^CHM SPF(FN,CHM SPN,"DEL") ),$P(^("DE L"),"^",1) =1 G END
  7997   "RTN","CHF BC2A",320, 0)
  7998    S CHSMDT= $O(^CHMSMS A(VST,1,VC ,3,CHMRSD) )
  7999   "RTN","CHF BC2A",321, 0)
  8000    I CHSMDT' ?1N.N D GS TSM G A1
  8001   "RTN","CHF BC2A",322, 0)
  8002    S CHMSNUM =$P(^CHMSM SA(VST,1,V C,3,CHSMDT ,0),"^",2)
  8003   "RTN","CHF BC2A",323, 0)
  8004    I (CHMSNU M=0)!(CHMS NUM="") D  GSTSM G A1
  8005   "RTN","CHF BC2A",324, 0)
  8006    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)
  8007   "RTN","CHF BC2A",325, 0)
  8008    I PF=6 D  GSTSM G A1
  8009   "RTN","CHF BC2A",326, 0)
  8010    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 )
  8011   "RTN","CHF BC2A",327, 0)
  8012    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)
  8013   "RTN","CHF BC2A",328, 0)
  8014    I CHMPF=0  D GSTSM:Y R>293 G EN D:YR<294 G  END:CHMPF =0
  8015   "RTN","CHF BC2A",329, 0)
  8016    S MOD=""
  8017   "RTN","CHF BC2A",330, 0)
  8018    I K2="OPT -PROC" D       ;JEH 2 /13/09  TT  ENC004843
  8019   "RTN","CHF BC2A",331, 0)
  8020    .S TMPSPC =$P(^CHMSE RV(CHMSPC, 0),"^",1)    ;GET COD E
  8021   "RTN","CHF BC2A",332, 0)
  8022    .S MOD=$$ GTMOD^CHFB C2A(CI,K2, NM,TMPSPC)          ; JEH 2/13/0 9  TT ENC0 04843  ADD ED SUBROUT INE
  8023   "RTN","CHF BC2A",333, 0)
  8024    ;S:K2="OP T-PROC" MO D=$P(@(GLP AY_"CI,K2, NM,0)"),"^ ",4)   ;JE H 2/13/09   TT ENC004 843
  8025   "RTN","CHF BC2A",334, 0)
  8026    S:K2="DEN -PROC" MOD =$P(@(GLPA Y_"CI,K2,N M,0)"),"^" ,6)
  8027   "RTN","CHF BC2A",335, 0)
  8028    D:MOD'=""
  8029   "RTN","CHF BC2A",336, 0)
  8030    .Q:CHADOS <2970701
  8031   "RTN","CHF BC2A",337, 0)
  8032    .Q:('$D(^ CHMDIC(741 002.98,"B" ,MOD)))&(' $D(^CHMDIC (741002.99 ,"B",MOD)) )
  8033   "RTN","CHF BC2A",338, 0)
  8034    .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:"")
  8035   "RTN","CHF BC2A",339, 0)
  8036    .Q:FILEPT =""
  8037   "RTN","CHF BC2A",340, 0)
  8038    .S PERC=" ",REA=""
  8039   "RTN","CHF BC2A",341, 0)
  8040    .S MODI=$ O(^CHMDIC( FILEPT,"B" ,MOD,0))
  8041   "RTN","CHF BC2A",342, 0)
  8042    .I MODI'= "" S:$D(^C HMDIC(FILE PT,MODI,0) ) REA=$P(^ (0),"^",2) ,PERC=$P(^ (0),"^",3)
  8043   "RTN","CHF BC2A",343, 0)
  8044    .S CHMPF= CHMPF*PERC
  8045   "RTN","CHF BC2A",344, 0)
  8046    .S X1=CI  D PROGTYP^ CHFCD001
  8047   "RTN","CHF BC2A",345, 0)
  8048    .S $P(@(G LPAY_"CI,K 1,NM,0)"), "^",2)=REA
  8049   "RTN","CHF BC2A",346, 0)
  8050    .;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
  8051   "RTN","CHF BC2A",347, 0)
  8052    .;S $P(@( GLPAY_"CI, ""RULE-PRO C"",NM,0)" ),U,2)=REA
  8053   "RTN","CHF BC2A",348, 0)
  8054   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
  8055   "RTN","CHF BC2A",349, 0)
  8056    S $P(@(GL PAY_"CI,"" RULE-PROC" ",NM,0)"), "^",9)=2
  8057   "RTN","CHF BC2A",350, 0)
  8058    S CMAC(NM )=CHMPF
  8059   "RTN","CHF BC2A",351, 0)
  8060   END I (K2= "DME-SUPPL Y")!(K2="O PT-PROC")  D
  8061   "RTN","CHF BC2A",352, 0)
  8062    .Q:$P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=19 6  ;DEF016 763 DPT
  8063   "RTN","CHF BC2A",353, 0)
  8064    .Q:$P(@(G LPAY_"CI,K 2,NM,0)"), "^",5)=""
  8065   "RTN","CHF BC2A",354, 0)
  8066    .S CHMPF= $P(^(0),"^ ",5),CMAC( NM)=CHMPF
  8067   "RTN","CHF BC2A",355, 0)
  8068    .S $P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=4
  8069   "RTN","CHF BC2A",356, 0)
  8070    .;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
  8071   "RTN","CHF BC2A",357, 0)
  8072    .S ALLOW= 1
  8073   "RTN","CHF BC2A",358, 0)
  8074    I K2="DEN -PROC" D
  8075   "RTN","CHF BC2A",359, 0)
  8076    .Q:$P(@(G LPAY_"CI,K 2,NM,0)"), "^",7)=""
  8077   "RTN","CHF BC2A",360, 0)
  8078    .S CHMPF= $P(^(0),"^ ",7),CMAC( NM)=CHMPF
  8079   "RTN","CHF BC2A",361, 0)
  8080    .S $P(@(G LPAY_"CI," "RULE-PROC "",NM,0)") ,"^",9)=4
  8081   "RTN","CHF BC2A",362, 0)
  8082    .;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
  8083   "RTN","CHF BC2A",363, 0)
  8084    .S ALLOW= 1
  8085   "RTN","CHF BC2A",364, 0)
  8086    K CHMPFD, CHMSPN,CHM SNUM,CHSMD T,VST,VC,V I,VZ,CHMSP ,CHMSPC,CH LDT
  8087   "RTN","CHF BC2A",365, 0)
  8088    K CHMSA,C HMGPN,CHGR DT,CHMMPN, CHMSDT,CHG RP,CHFAC,H OSPAMT Q
  8089   "RTN","CHF BC2A",366, 0)
  8090   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'=""
  8091   "RTN","CHF BC2A",367, 0)
  8092    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'=""
  8093   "RTN","CHF BC2A",368, 0)
  8094    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' =""
  8095   "RTN","CHF BC2A",369, 0)
  8096    Q
  8097   "RTN","CHF BC2A",370, 0)
  8098   GETCLP ;DE TERMINE CM AC RATE PO SITION
  8099   "RTN","CHF BC2A",371, 0)
  8100    Q:$D(^CHM SERV(CHMSP ,4))    ;Q UIT IF ANE THESIA COD E    ; JEH  12/5/06
  8101   "RTN","CHF BC2A",372, 0)
  8102    S CHMFAC= 0   ; Set  default to  Non-facil ity
  8103   "RTN","CHF BC2A",373, 0)
  8104    S CHMPOS= 99  ; Set  default to  Other loc ation
  8105   "RTN","CHF BC2A",374, 0)
  8106    S PTR=""   ;AEB 4/17 /2007
  8107   "RTN","CHF BC2A",375, 0)
  8108    S:$D(@(GL PAY_"CI,"" COMMON"")" )) I=$P(@( GLPAY_"CI, ""COMMON"" )"),"^",2)
  8109   "RTN","CHF BC2A",376, 0)
  8110    ;I I I $D (^CHMDIC(7 41002.11,I ,0)) S PTR =$P(^(0)," ^",5)   ;J EH 3/25/08
  8111   "RTN","CHF BC2A",377, 0)
  8112    ;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
  8113   "RTN","CHF BC2A",378, 0)
  8114    I I I $D( ^CHMDIC(74 1002.11,I, 0)) S CHMF AC=$P(^(0) ,"^",7)    ;JEH 3/25/ 08
  8115   "RTN","CHF BC2A",379, 0)
  8116    S CHCLS=C HCLS+CHMFA C
  8117   "RTN","CHF BC2A",380, 0)
  8118    Q
  8119   "RTN","CHF BC2A",381, 0)
  8120   FNSET(FMDT ) ;Sets th e correct  FN for pre vailing fe e global ( CHMSPF)
  8121   "RTN","CHF BC2A",382, 0)
  8122    ; FMDT mu st be a fi leman date  (2990101)  or at lea st the
  8123   "RTN","CHF BC2A",383, 0)
  8124    ;      fi rst three  positions  of the fil eman dt (2 99)
  8125   "RTN","CHF BC2A",384, 0)
  8126    ; Y2K - T his was ad ded to mak e global Y 2K complia nt (FN was  741012.99
  8127   "RTN","CHF BC2A",385, 0)
  8128    ;       a nd now is  741012.299 ).  Traili ng zeros w ill be tru ncated in
  8129   "RTN","CHF BC2A",386, 0)
  8130    ;       o rder to be  compatiab le with Fi leman.
  8131   "RTN","CHF BC2A",387, 0)
  8132    ;
  8133   "RTN","CHF BC2A",388, 0)
  8134    N X,Y
  8135   "RTN","CHF BC2A",389, 0)
  8136    S Y=""
  8137   "RTN","CHF BC2A",390, 0)
  8138    I $L(FMDT )>2 D
  8139   "RTN","CHF BC2A",391, 0)
  8140    .S X=$E(F MDT,1,3)
  8141   "RTN","CHF BC2A",392, 0)
  8142    .I $E(X,3 )=0 S X=$E (X,1,2) D
  8143   "RTN","CHF BC2A",393, 0)
  8144    ..I $E(X, 2)=0 S X=$ E(X,1)
  8145   "RTN","CHF BC2A",394, 0)
  8146    .S Y="741 012."_X
  8147   "RTN","CHF BC2A",395, 0)
  8148    Q Y
  8149   "RTN","CHF BC2A",396, 0)
  8150   GTMOD(GCI, GK2,GNM,GC HMSPC)  ;S UBROUTINE  TO DETERMI NE/GET MOD IFIERS FOR  OUTPATIEN T CLAIMS
  8151   "RTN","CHF BC2A",397, 0)
  8152    ;JEH 4/13 /10 ENC004 843
  8153   "RTN","CHF BC2A",398, 0)
  8154    ;GCI = CL AIM POINTE R
  8155   "RTN","CHF BC2A",399, 0)
  8156    ;GK2 = GL OBAL NODE  INDICATOR  - "OPT-PRO C"
  8157   "RTN","CHF BC2A",400, 0)
  8158    ;GNM = J  VALUE FROM  PAY FILE
  8159   "RTN","CHF BC2A",401, 0)
  8160    N MOD,TOB ,POS,TOC,C HMREC,CHPN M,CHMREC1, CHPNM1
  8161   "RTN","CHF BC2A",402, 0)
  8162    S MOD=""  S MOD=$P(@ (GLPAY_"GC I,GK2,GNM, 0)"),"^",4 )
  8163   "RTN","CHF BC2A",403, 0)
  8164    Q:'$D(^CH MCPF("B",G CHMSPC)) M OD   ;QUIT  IF CODE N OT IN CMAC  GLOBAL
  8165   "RTN","CHF BC2A",404, 0)
  8166    Q:MOD=4!( MOD=83) MO D  ;4=26/8 3=TC
  8167   "RTN","CHF BC2A",405, 0)
  8168    S TOC=""  S TOC=$P(@ (GLPAY_"GC I,0)"),"^" ,7)      ; TYPE OF CL AIM 2=OUTP ATIENT
  8169   "RTN","CHF BC2A",406, 0)
  8170    Q:TOC'=2  MOD
  8171   "RTN","CHF BC2A",407, 0)
  8172    Q:CHCMDT= "" MOD                            ; RFE 6/3 0/16 DEV02 5633
  8173   "RTN","CHF BC2A",408, 0)
  8174    I (GCHMSP C>=70000)& (GCHMSPC<= 90000) {
  8175   "RTN","CHF BC2A",409, 0)
  8176       S TOB= ""   ;BILL  TYPE BILL  (013x-HOS P OUTPATIE NT, 014x-H OSP OTHER  PART B)
  8177   "RTN","CHF BC2A",410, 0)
  8178       S:$D(@ (GLPAY_"GC I,7)")) TO B=$P(@(GLP AY_"GCI,7) "),"^",6)
  8179   "RTN","CHF BC2A",411, 0)
  8180       S POS= 0 S POS=$P (@(GLPAY_" GCI,""COMM ON"")"),"^ ",2)  ;PLA CE OF SERV ICE
  8181   "RTN","CHF BC2A",412, 0)
  8182       I TOB' ="" {
  8183   "RTN","CHF BC2A",413, 0)
  8184           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
  8185   "RTN","CHF BC2A",414, 0)
  8186                I $D(^CH MCPF(CHMSP N,CHX,CHCM DT,0)) {
  8187   "RTN","CHF BC2A",415, 0)
  8188                    S CH MREC=$P(^C HMCPF(CHMS PN,CHX,CHC MDT,0),"^" ,2)   ;TEC H
  8189   "RTN","CHF BC2A",416, 0)
  8190                    S CH PNM=$P(CHM REC,",",CH LNM)
  8191   "RTN","CHF BC2A",417, 0)
  8192                    I $P (CHPNM,";" ,4)'=""&($ P(CHPNM,"; ",4)>0) S  MOD=83     ;83=TC
  8193   "RTN","CHF BC2A",418, 0)
  8194                }
  8195   "RTN","CHF BC2A",419, 0)
  8196           }
  8197   "RTN","CHF BC2A",420, 0)
  8198       }
  8199   "RTN","CHF BC2A",421, 0)
  8200       I (TOB =""&(POS=2 ))!(POS=86 ) {   ;2-O P,86-IPP
  8201   "RTN","CHF BC2A",422, 0)
  8202           I  $D(^CHMCPF (CHMSPN,CH X,CHCMDT,1 )) {
  8203   "RTN","CHF BC2A",423, 0)
  8204                S CHMREC 1=$P(^CHMC PF(CHMSPN, CHX,CHCMDT ,1),"^",2)    ;PRO
  8205   "RTN","CHF BC2A",424, 0)
  8206                S CHPNM1 =$P(CHMREC 1,",",CHLN M)
  8207   "RTN","CHF BC2A",425, 0)
  8208                I $P(CHP NM1,";",3) '=""&($P(C HPNM1,";", 3)>0) S MO D=4    ;4= 26
  8209   "RTN","CHF BC2A",426, 0)
  8210           }
  8211   "RTN","CHF BC2A",427, 0)
  8212       }
  8213   "RTN","CHF BC2A",428, 0)
  8214    }
  8215   "RTN","CHF BC2A",429, 0)
  8216    Q MOD
  8217   "RTN","CHF BC2A",430, 0)
  8218   CHKPLZIP ; DEFECT 832 284
  8219   "RTN","CHF BC2A",431, 0)
  8220    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
  8221   "RTN","CHF BC2A",432, 0)
  8222    S CHMFQUE =10,CHMMDP =CHMMDP_":  PL-ZIP MI SSING"
  8223   "RTN","CHF BC2A",433, 0)
  8224    Q
  8225   "RTN","CHF BCQ")
  8226   0^22^B2067 00247
  8227   "RTN","CHF BCQ",1,0)
  8228   CHFBCQ ;HA C/CR;SETS  UP QUEUES; Feb 05, 20 19@09:31:3 6
  8229   "RTN","CHF BCQ",2,0)
  8230    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  8231   "RTN","CHF BCQ",3,0)
  8232    ;CPTS - 1 0920  (AEB ), #11014  BY RLC, 13 920/JLR
  8233   "RTN","CHF BCQ",4,0)
  8234    ;CPTS 158 90 (AEB)
  8235   "RTN","CHF BCQ",5,0)
  8236    ;JSG;06/0 2/08;DEV00 4754-02;Ad d high dol lar reason  (with sec urity) for  Audit Sup port Queue
  8237   "RTN","CHF BCQ",6,0)
  8238    ;DEV00480 5 1/20/201 0 AEB
  8239   "RTN","CHF BCQ",7,0)
  8240    ;DEV01001 8-01 YJK 1 1/26/2010  - Paid Fil e Date Com pleted Ind ex
  8241   "RTN","CHF BCQ",8,0)
  8242    ;DEV01106 9 1/5/2011  AEB
  8243   "RTN","CHF BCQ",9,0)
  8244    ;Producti on fix 1/3 /12 DPT -  looping on  deleted c laims
  8245   "RTN","CHF BCQ",10,0)
  8246    ;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
  8247   "RTN","CHF BCQ",11,0)
  8248    ;ENC01586 3: EDI - C ODE 58 sto p and repl ace - keep  current s ystem logi c  BMJ 10/ 22/13
  8249   "RTN","CHF BCQ",12,0)
  8250    ;CPE005-1 00,102 BDB  12/27/201 7
  8251   "RTN","CHF BCQ",13,0)
  8252   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
  8253   "RTN","CHF BCQ",14,0)
  8254   LDQA1 S DF N=$P(REC0, "^",21),BF N=$P(REC0, "^",22)
  8255   "RTN","CHF BCQ",15,0)
  8256    D NOW^%DT C S CHDT=%  I $D(^CHM ASQ("B",CH DT)) G LDQ A1
  8257   "RTN","CHF BCQ",16,0)
  8258    S (DIC,DL AYGO)=7410 10.05,DIC( 0)="ML",X= CHDT D ^DI C K DIC
  8259   "RTN","CHF BCQ",17,0)
  8260    G LDQA1:$ P(Y,"^",3) '=1
  8261   "RTN","CHF BCQ",18,0)
  8262    S CHMQNAM ="CHMASQ(" ,CHMIN=""  K CHMOUT D  ^CHMIS041
  8263   "RTN","CHF BCQ",19,0)
  8264    S ZJ=$O(@ (GLPAY_"CI ,""PDI"",9 99)"),-1)  Q:'ZJ
  8265   "RTN","CHF BCQ",20,0)
  8266    S:$D(@(GL PAY_"CI,"" PDI"",ZJ,0 )")) CHMFP DI=$P(^(0) ,"^",1)
  8267   "RTN","CHF BCQ",21,0)
  8268    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"
  8269   "RTN","CHF BCQ",22,0)
  8270    D ^DIE K  DIE S:'$D( ^CHMASQ(DA ,1,0)) ^CH MASQ(DA,1, 0)="^74101 0.08SA^0^0 "
  8271   "RTN","CHF BCQ",23,0)
  8272    ;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
  8273   "RTN","CHF BCQ",24,0)
  8274    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
  8275   "RTN","CHF BCQ",25,0)
  8276    D REVCCD^ CHTFLIBC(C I)                ;re verse & cl ear ded/c. s./cat cap  from clai m DEV02124 4 JAK 08/2 6/14
  8277   "RTN","CHF BCQ",26,0)
  8278    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
  8279   "RTN","CHF BCQ",27,0)
  8280    D REASON  K HIDOLLAR                 ;JSG; DEV004754; Make sure  high $ fla g good for  only 1 cl aim
  8281   "RTN","CHF BCQ",28,0)
  8282    D ADDASQ
  8283   "RTN","CHF BCQ",29,0)
  8284    K DIC S C HMFPP="SQA UD",CHMFI= CI D ^CHMF WK02
  8285   "RTN","CHF BCQ",30,0)
  8286    Q
  8287   "RTN","CHF BCQ",31,0)
  8288   ADDASQ ; T HE FOLLOWI NG LINES R ETRIEVE TH E IMAGE *C R*
  8289   "RTN","CHF BCQ",32,0)
  8290    ;N (CHCLM ,DUZ)
  8291   "RTN","CHF BCQ",33,0)
  8292    S CHSS=""  I $D(^CHM IMD(741020 .02,"B","P ARAMETER") ) D
  8293   "RTN","CHF BCQ",34,0)
  8294    .S Y=$O(^ CHMIMD(741 020.02,"B" ,"PARAMETE R",0)) Q:Y =""
  8295   "RTN","CHF BCQ",35,0)
  8296    .Q:'$D(^C HMIMD(7410 20.02,Y,11 ))  S CHSS =$P(^(11), "^",4)
  8297   "RTN","CHF BCQ",36,0)
  8298    .Q:CHSS=" "  Q:'$D(^ VA(200,"ZV MS",CHSS))
  8299   "RTN","CHF BCQ",37,0)
  8300    .S CHDUZ= $O(^VA(200 ,"ZVMS",CH SS,0)) Q
  8301   "RTN","CHF BCQ",38,0)
  8302    Q:'$D(CHS S)  Q:CHSS =""  Q:'$D (CI)  Q:CI =""
  8303   "RTN","CHF BCQ",39,0)
  8304    S CHPDIJ= 0,CHDOCID= "",CHMIMFL =1,CHIMMVE =1,CHOPER= "CHIMMVE"
  8305   "RTN","CHF BCQ",40,0)
  8306    F  S CHPD IJ=$O(@(GL PAY_"CI,"" PDI"",CHPD IJ)")) Q:' CHPDIJ  D
  8307   "RTN","CHF BCQ",41,0)
  8308    .Q:'$D(^( CHPDIJ,0))   S CHPDI= $P(^(0),"^ ",1)
  8309   "RTN","CHF BCQ",42,0)
  8310    .Q:'$D(^C HMIMG(CHPD I,"DOC"))   S CHDOCID =$P(^("DOC "),"^",1)  D ADD^CHMM F
  8311   "RTN","CHF BCQ",43,0)
  8312    K CHSS,Y, CHDUZ,CHPD IJ,CHDOCID ,CHIMFL,CH IMMVE,CHOP ER,CHPDI Q
  8313   "RTN","CHF BCQ",44,0)
  8314    ;
  8315   "RTN","CHF BCQ",45,0)
  8316   REASON S D A(1)=DA,(D IC,DLAYGO) ="^CHMASQ( DA(1),1,", DIC(0)="ML " D ^DIC K  DIC Q
  8317   "RTN","CHF BCQ",46,0)
  8318    ;
  8319   "RTN","CHF BCQ",47,0)
  8320   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
  8321   "RTN","CHF BCQ",48,0)
  8322    S CHINHCL =CI D ^CHM G281 I $D( CHIHFLG) K  CHIHFLG Q
  8323   "RTN","CHF BCQ",49,0)
  8324    ;
  8325   "RTN","CHF BCQ",50,0)
  8326   LDQB2 S:'$ D(CHPGPT)  CHPGPT=$P( ^CHMINDEX( CI,0),U,1)
  8327   "RTN","CHF BCQ",51,0)
  8328    I CHPGPT= 5 S CLMPT= CI D S2^CH FBCQ1 Q
  8329   "RTN","CHF BCQ",52,0)
  8330    I (CHPGPT =6)!(CHPGP T=7) S REA S=$P(^CHMD IC(741002. 34,1,3),"^ ",15) D RO REAS
  8331   "RTN","CHF BCQ",53,0)
  8332    I CHPGPT< 3 S REAS=3 19 D ROREA S S REAS=3 22 D ROREA S
  8333   "RTN","CHF BCQ",54,0)
  8334    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
  8335   "RTN","CHF BCQ",55,0)
  8336    I $P(@(GL PAY_"CI,0) "),"^",5)' =1 S CHOUT ="741008.0 5",CHEND=" 01P" D  Q
  8337   "RTN","CHF BCQ",56,0)
  8338    .S $P(@(G LPAY_"CI,0 )"),"^",12 )=0,$P(@(G LPAY_"CI,0 )"),"^",11 )=1 D SSNA Q Q
  8339   "RTN","CHF BCQ",57,0)
  8340    I ($P(@(G LPAY_"CI,0 )"),"^",5) =1)&(+$P(@ (GLPAY_"CI ,1)"),"^", 14)=0) D   Q
  8341   "RTN","CHF BCQ",58,0)
  8342    .S CHOUT= "741008.05 ",CHEND="0 1P",$P(@(G LPAY_"CI,0 )"),"^",12 )=0
  8343   "RTN","CHF BCQ",59,0)
  8344    .S $P(@(G LPAY_"CI,0 )"),"^",11 )=1 D SSNA Q Q
  8345   "RTN","CHF BCQ",60,0)
  8346    I ($P(@(G LPAY_"CI,0 )"),"^",5) =1)&(+$P(@ (GLPAY_"CI ,1)"),"^", 15)=0) D   Q
  8347   "RTN","CHF BCQ",61,0)
  8348    .S CHOUT= "741008.03 ",CHEND="0 1PA",$P(@( GLPAY_"CI, 0)"),"^",1 2)=1
  8349   "RTN","CHF BCQ",62,0)
  8350    .S $P(@(G LPAY_"CI,0 )"),"^",11 )=0 D SSNA Q Q
  8351   "RTN","CHF BCQ",63,0)
  8352    I ($P(@(G LPAY_"CI,0 )"),"^",5) =1)&(+$P(@ (GLPAY_"CI ,1)"),"^", 14)'=0)&($ P(@(GLPAY_ "CI,1)")," ^",15)'=0)  D  Q
  8353   "RTN","CHF BCQ",64,0)
  8354    .S CHOUT= "741008.05 ",CHEND="0 1P",$P(@(G LPAY_"CI,0 )"),"^",12 )=1
  8355   "RTN","CHF BCQ",65,0)
  8356    .S $P(@(G LPAY_"CI,0 )"),"^",11 )=1 D SSNA Q S CHOUT= "741008.03 ",CHEND="0 1PA" D SSN AQ Q
  8357   "RTN","CHF BCQ",66,0)
  8358   SSNAQ I ($ D(^CHMSNA( CHOUT,"C", CI)))!($D( ^CHMSNA(CH OUT,"ARCHI VE",CI)))  D ^CHMFBCC R Q:CHREJ
  8359   "RTN","CHF BCQ",67,0)
  8360    I $P(@(GL PAY_"CI,0) "),"^",2)= 10 Q ;PROD  1/3/12 DP T
  8361   "RTN","CHF BCQ",68,0)
  8362    L ^CHMSNA (CHOUT) S  CHMBTCH=$P (^CHMSNA(C HOUT,0),"^ ",3)
  8363   "RTN","CHF BCQ",69,0)
  8364    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 )
  8365   "RTN","CHF BCQ",70,0)
  8366    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 )
  8367   "RTN","CHF BCQ",71,0)
  8368    S:'$D(^CH MSNA(CHOUT ,CHMBTCH,1 ,0)) ^CHMS NA(CHOUT,C HMBTCH,1,0 )="^"_CHOU T_CHEND_"^ 0^0"
  8369   "RTN","CHF BCQ",72,0)
  8370    S DA(1)=C HMBTCH,DLA YGO=CHOUT
  8371   "RTN","CHF BCQ",73,0)
  8372    S DIC="^C HMSNA("_CH OUT_","_DA (1)_",1,", X=CN,DIC(0 )="ML" D ^ DIC K DIC, DLAYGO L
  8373   "RTN","CHF BCQ",74,0)
  8374    G:$P(Y,"^ ",3)'=1 SS NAQ I $D(C HRSUB) D
  8375   "RTN","CHF BCQ",75,0)
  8376    .Q:'CHRSU B
  8377   "RTN","CHF BCQ",76,0)
  8378    .S I=0,I= $O(^CHMSNA (741008.03 ,"C",CI,I) ) Q:'I  S  J=0
  8379   "RTN","CHF BCQ",77,0)
  8380    .S J=$O(^ CHMSNA(741 008.03,"C" ,CI,I,J))  Q:'J
  8381   "RTN","CHF BCQ",78,0)
  8382    .;S ^CHMS NA(741008. 05,DA(1),1 ,+Y,10)="1 ^"_I_"^"_J
  8383   "RTN","CHF BCQ",79,0)
  8384    .;S ^CHMS NA(741008. 03,I,1,J,1 0)="1^"_DA (1)_"^"_+Y  K CHRSUB  Q
  8385   "RTN","CHF BCQ",80,0)
  8386    ;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:
  8387   "RTN","CHF BCQ",81,0)
  8388    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
  8389   "RTN","CHF BCQ",82,0)
  8390    D PAIDRVS L(CI)   ;D EV005311,  SKD, 7-23- 08
  8391   "RTN","CHF BCQ",83,0)
  8392    S:CHOUT=" 741008.05"  CHMFPP="S QCALO" S:C HOUT="7410 08.03" CHM FPP="SQCAP O" S CHMFI =CI D ^CHM FWK02
  8393   "RTN","CHF BCQ",84,0)
  8394    S CHMQNAM ="CHMSNA(" _CHOUT_"," ,CHMIN=""  K CHMOUT D  ^CHMIS041
  8395   "RTN","CHF BCQ",85,0)
  8396    Q
  8397   "RTN","CHF BCQ",86,0)
  8398    ;
  8399   "RTN","CHF BCQ",87,0)
  8400   LDQE I $D( ^CHNVPAY(C I)) I '$D( ^CHMQAQ("D ",CI)) D   Q
  8401   "RTN","CHF BCQ",88,0)
  8402    .S $P(^CH NVPAY(CI,0 ),"^",2)=1
  8403   "RTN","CHF BCQ",89,0)
  8404    .S CHMFQU E=38 D LDQ Q Q
  8405   "RTN","CHF BCQ",90,0)
  8406    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
  8407   "RTN","CHF BCQ",91,0)
  8408    .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" )
  8409   "RTN","CHF BCQ",92,0)
  8410    .I (CHMFQ UE=12)!(CH MFQUE=13)! (CHMFQUE=1 5)!(CHMFQU E=16)!(CHM FQUE=25)!( CHMFQUE=32 )!(CHMFQUE =35) S CHR JFG=""
  8411   "RTN","CHF BCQ",93,0)
  8412    S CHINHCL =CI D ^CHM G280 I $D( CHIHFLG) K  CHIHFLG Q
  8413   "RTN","CHF BCQ",94,0)
  8414   LDQEE1 ;
  8415   "RTN","CHF BCQ",95,0)
  8416   LDQEE11 ;A LL OF THIS  WAS COMME NTED OFF I N CHMFBCQ
  8417   "RTN","CHF BCQ",96,0)
  8418   LDQEE2 I $ D(@(GLPAY_ "CI,6)"))  D CKRO
  8419   "RTN","CHF BCQ",97,0)
  8420    I $D(@(GL PAY_"CI,6) ")) D CKRO EDI ;BDB 1 2/27/2017
  8421   "RTN","CHF BCQ",98,0)
  8422    I $D(CHMF RQUE) S CH RSN="REB"  G LDQE1
  8423   "RTN","CHF BCQ",99,0)
  8424    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")
  8425   "RTN","CHF BCQ",100,0 )
  8426   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
  8427   "RTN","CHF BCQ",101,0 )
  8428    .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" )
  8429   "RTN","CHF BCQ",102,0 )
  8430    .I (CHMFQ UE=12)!(CH MFQUE=13)! (CHMFQUE=1 5)!(CHMFQU E=16)!(CHM FQUE=25)!( CHMFQUE=32 )!(CHMFQUE =35) S CHR JFG=""
  8431   "RTN","CHF BCQ",103,0 )
  8432    D NOW^%DT C S CHDT=%  I $D(^CHM EOBQ("B",C HDT)) G LD QE1
  8433   "RTN","CHF BCQ",104,0 )
  8434    S CHRES=" "
  8435   "RTN","CHF BCQ",105,0 )
  8436    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
  8437   "RTN","CHF BCQ",106,0 )
  8438    G:$D(CHMF RQUE) LDQE 2
  8439   "RTN","CHF BCQ",107,0 )
  8440    S:CHMFQUE =12 CHRES= CHRES_": " _$P(^CHMDI C(741002.3 4,1,2),"^" ,7)
  8441   "RTN","CHF BCQ",108,0 )
  8442    S:CHMFQUE =13 CHRES= CHRES_": " _$P(^CHMDI C(741002.3 4,1,2),"^" ,3)
  8443   "RTN","CHF BCQ",109,0 )
  8444    S:CHMFQUE =35 CHRES= CHRES_": " _$P(^CHMDI C(741002.3 4,1,3),"^" ,8)
  8445   "RTN","CHF BCQ",110,0 )
  8446   LDQE2 S X1 =CI D PROG TYP^CHFCD0 01
  8447   "RTN","CHF BCQ",111,0 )
  8448    S DLAYGO= +$P(@(GLEO B_"0)"),"^ ",2)
  8449   "RTN","CHF BCQ",112,0 )
  8450    S DIC=GLE OB,DIC(0)= "ML",X=CHD T D ^DIC K  DIC
  8451   "RTN","CHF BCQ",113,0 )
  8452    G LDQE1:$ P(Y,"^",3) '=1
  8453   "RTN","CHF BCQ",114,0 )
  8454    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
  8455   "RTN","CHF BCQ",115,0 )
  8456    I $D(@(GL PAY_"CI,"" ZEMC"")"))  S CHMQNAM ="CHMEDIQ( ",CHMOUT=" " K CHMIN  D ^CHMIS04 1
  8457   "RTN","CHF BCQ",116,0 )
  8458    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
  8459   "RTN","CHF BCQ",117,0 )
  8460    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
  8461   "RTN","CHF BCQ",118,0 )
  8462    S:(CHRSN= "DX")!(CHR SN="CH")!( CHRSN="AS" )!(CHRSN=" QA")!(CHRS N="DRG")!( CHRSN="REB ") $P(@(GL PAY_"CI,0) "),"^",2)= 0
  8463   "RTN","CHF BCQ",119,0 )
  8464    S CHMFPP= "SQEOB",CH MFI=CI D ^ CHMFWK02 K  CHRES
  8465   "RTN","CHF BCQ",120,0 )
  8466    S CHMQNAM ="CHMEOBQ( ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  8467   "RTN","CHF BCQ",121,0 )
  8468    Q
  8469   "RTN","CHF BCQ",122,0 )
  8470    ;
  8471   "RTN","CHF BCQ",123,0 )
  8472   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
  8473   "RTN","CHF BCQ",124,0 )
  8474    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
  8475   "RTN","CHF BCQ",125,0 )
  8476    Q:CHEX=1
  8477   "RTN","CHF BCQ",126,0 )
  8478    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
  8479   "RTN","CHF BCQ",127,0 )
  8480    ;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
  8481   "RTN","CHF BCQ",128,0 )
  8482    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
  8483   "RTN","CHF BCQ",129,0 )
  8484    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
  8485   "RTN","CHF BCQ",130,0 )
  8486    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
  8487   "RTN","CHF BCQ",131,0 )
  8488    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)
  8489   "RTN","CHF BCQ",132,0 )
  8490    I $P(^CHM PAY(CI,"CO MMON"),"^" ,9)=5 S CH MMDR=8,CHM MDP="POA I S MISSING  OR INVALID "
  8491   "RTN","CHF BCQ",133,0 )
  8492   LDQM1 D NO W^%DTC S C HDT=% I $D (^CHMMDQ(" B",CHDT))  G LDQM1
  8493   "RTN","CHF BCQ",134,0 )
  8494    S (DIC,DL AYGO)=7410 10.11,DIC( 0)="ML",X= CHDT D ^DI C K DIC
  8495   "RTN","CHF BCQ",135,0 )
  8496    G LDQM1:$ P(Y,"^",3) '=1
  8497   "RTN","CHF BCQ",136,0 )
  8498    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
  8499   "RTN","CHF BCQ",137,0 )
  8500    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
  8501   "RTN","CHF BCQ",138,0 )
  8502    D REVCCD^ CHTFLIBC(C I)  ;rever se & clear  ded/c.s./ cat cap fr om claim D EV021244 J AK 09/03/1 4
  8503   "RTN","CHF BCQ",139,0 )
  8504    D CLRPMT^ CHTFLIB2(C I)  ;clear  payment d ata from c laim DEV02 1244 JAK 0 9/03/14
  8505   "RTN","CHF BCQ",140,0 )
  8506    S CHMFPP= "SQMSD",CH MFI=CI D ^ CHMFWK02
  8507   "RTN","CHF BCQ",141,0 )
  8508    S CHMQNAM ="CHMMDQ(" ,CHMIN=""  K CHMOUT D  ^CHMIS041
  8509   "RTN","CHF BCQ",142,0 )
  8510    Q
  8511   "RTN","CHF BCQ",143,0 )
  8512    ;
  8513   "RTN","CHF BCQ",144,0 )
  8514    ;skd, 1-2 5-06 to re direct fro m MDQ to V Q per IDME  project
  8515   "RTN","CHF BCQ",145,0 )
  8516    ;ADD A NE W ENTRY TO  VQ
  8517   "RTN","CHF BCQ",146,0 )
  8518   LDQV ;ADD  A NEW ENTR Y TO VQ
  8519   "RTN","CHF BCQ",147,0 )
  8520    D NOW^%DT C S X=%
  8521   "RTN","CHF BCQ",148,0 )
  8522    S DIC(0)= "LM"
  8523   "RTN","CHF BCQ",149,0 )
  8524    S (DIC,DL AYGO)=7410 50.01
  8525   "RTN","CHF BCQ",150,0 )
  8526    D ^DIC
  8527   "RTN","CHF BCQ",151,0 )
  8528    I $P(Y,U, 3)'=1 G LD QV
  8529   "RTN","CHF BCQ",152,0 )
  8530    S CHI=+Y
  8531   "RTN","CHF BCQ",153,0 )
  8532    D GVDTA
  8533   "RTN","CHF BCQ",154,0 )
  8534    S STATUS= 0,DA=CHI,D IE=741050. 01
  8535   "RTN","CHF BCQ",155,0 )
  8536    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) "
  8537   "RTN","CHF BCQ",156,0 )
  8538    D ^DIE K  DIE,DR
  8539   "RTN","CHF BCQ",157,0 )
  8540    D SETVDTA ,STKCLM
  8541   "RTN","CHF BCQ",158,0 )
  8542    D REVCCD^ CHTFLIBC(C I)  ;rever se & clear  ded/c.s./ cat cap fr om claim D EV021244 J AK 09/03/1 4
  8543   "RTN","CHF BCQ",159,0 )
  8544    D CLRPMT^ CHTFLIB2(C I)  ;clear  payment d ata from c laim DEV02 1244 JAK 0 9/03/14
  8545   "RTN","CHF BCQ",160,0 )
  8546    S CHMFPP= "SQVEN",CH MFI=CI D ^ CHMFWK02
  8547   "RTN","CHF BCQ",161,0 )
  8548    S CHMQNAM ="CHMQVN(" ,CHMIN=""  K CHMOUT D  ^CHMIS041
  8549   "RTN","CHF BCQ",162,0 )
  8550    Q
  8551   "RTN","CHF BCQ",163,0 )
  8552    ;
  8553   "RTN","CHF BCQ",164,0 )
  8554   GVDTA ;GET  DATA FROM  VENDOR FI LE
  8555   "RTN","CHF BCQ",165,0 )
  8556    S (REC0,R EC1)=""
  8557   "RTN","CHF BCQ",166,0 )
  8558    S VFN=CHV X   ;=VI   ;SKD, 2-21 -06
  8559   "RTN","CHF BCQ",167,0 )
  8560    S REC0=$G (^CHMVEN(V FN,0))
  8561   "RTN","CHF BCQ",168,0 )
  8562    S REC1=$G (^CHMVEN(V FN,1))
  8563   "RTN","CHF BCQ",169,0 )
  8564    F R=1:1:2 1 S PV(R)= ""
  8565   "RTN","CHF BCQ",170,0 )
  8566    S PV(1)=$ G(VFN) ; V ENDOR POIN TER
  8567   "RTN","CHF BCQ",171,0 )
  8568    S PV(2)=$ P(REC0,U,1 4) ; VENDO RIZATION P OINTER
  8569   "RTN","CHF BCQ",172,0 )
  8570    S PV(3)=" " ; VENDOR IZATION ST RING
  8571   "RTN","CHF BCQ",173,0 )
  8572    S PV(4)=$ P(REC0,U,1 ) ; VENDOR  NAME
  8573   "RTN","CHF BCQ",174,0 )
  8574    S PV(5)=$ P(REC0,U,3 ) ; VENDOR  TAX ID
  8575   "RTN","CHF BCQ",175,0 )
  8576    S PV(6)=$ P(REC0,U,7 ) ; SSN
  8577   "RTN","CHF BCQ",176,0 )
  8578    S PV(7)=$ P(REC1,U,1 ) ; ADDR1
  8579   "RTN","CHF BCQ",177,0 )
  8580    S PV(8)=$ P(REC1,U,2 ) ; ADDR2
  8581   "RTN","CHF BCQ",178,0 )
  8582    S PV(9)=$ P(REC1,U,3 ) ; CITY
  8583   "RTN","CHF BCQ",179,0 )
  8584    S PV(10)= $P(REC1,U, 4) ; STATE
  8585   "RTN","CHF BCQ",180,0 )
  8586    S PV(11)= $P(REC1,U, 5) ; ZIP
  8587   "RTN","CHF BCQ",181,0 )
  8588    S PV(12)= $P(REC1,U, 7) ; FACIL ITY TYPE
  8589   "RTN","CHF BCQ",182,0 )
  8590    S PV(13)= $P(REC1,U, 13) ; CLAS SIF. TYPE
  8591   "RTN","CHF BCQ",183,0 )
  8592    S PV(14)= $P(REC1,U, 11) ; SPEC IALTY
  8593   "RTN","CHF BCQ",184,0 )
  8594    S PV(15)= $P(REC1,U, 6) ; PHONE
  8595   "RTN","CHF BCQ",185,0 )
  8596    S PV(16)= $P(REC1,U, 9) ; AUSTI N VERIFY
  8597   "RTN","CHF BCQ",186,0 )
  8598    S PV(17)= $P(REC0,U, 19) ; DISC RETE PSYCH
  8599   "RTN","CHF BCQ",187,0 )
  8600    S PV(18)= $P(REC0,U, 21) ; DISC RETE REHAB
  8601   "RTN","CHF BCQ",188,0 )
  8602    S PV(19)= $P(REC0,U, 22) ; DISC RETE RTC
  8603   "RTN","CHF BCQ",189,0 )
  8604    S PV(20)= $P(REC1,U, 8) ; NON-P PS
  8605   "RTN","CHF BCQ",190,0 )
  8606    I $D(^CHM VEN(VFN,40 )) S PV(21 )=$P(^CHMV EN(VFN,40) ,U,1) ; CM AC
  8607   "RTN","CHF BCQ",191,0 )
  8608    Q
  8609   "RTN","CHF BCQ",192,0 )
  8610    ;
  8611   "RTN","CHF BCQ",193,0 )
  8612   SETVDTA ;S ET DATA FR OM VENDOR  FILE INTO  VQ WORK FI LE
  8613   "RTN","CHF BCQ",194,0 )
  8614    S $P(^CHM QVN(CHI,1) ,U,1)=PV(4 )
  8615   "RTN","CHF BCQ",195,0 )
  8616    S $P(^CHM QVN(CHI,1) ,U,2)=PV(5 )
  8617   "RTN","CHF BCQ",196,0 )
  8618    S $P(^CHM QVN(CHI,1) ,U,3)=PV(6 )
  8619   "RTN","CHF BCQ",197,0 )
  8620    S $P(^CHM QVN(CHI,1) ,U,4)=PV(7 )
  8621   "RTN","CHF BCQ",198,0 )
  8622    S $P(^CHM QVN(CHI,1) ,U,5)=PV(8 )
  8623   "RTN","CHF BCQ",199,0 )
  8624    S $P(^CHM QVN(CHI,1) ,U,6)=PV(9 )
  8625   "RTN","CHF BCQ",200,0 )
  8626    S $P(^CHM QVN(CHI,1) ,U,7)=PV(1 0)
  8627   "RTN","CHF BCQ",201,0 )
  8628    S $P(^CHM QVN(CHI,1) ,U,8)=PV(1 1)
  8629   "RTN","CHF BCQ",202,0 )
  8630    S $P(^CHM QVN(CHI,1) ,U,09)=PV( 15)
  8631   "RTN","CHF BCQ",203,0 )
  8632    S $P(^CHM QVN(CHI,1) ,U,10)=PV( 12)
  8633   "RTN","CHF BCQ",204,0 )
  8634    S $P(^CHM QVN(CHI,1) ,U,11)=PV( 13)
  8635   "RTN","CHF BCQ",205,0 )
  8636    S $P(^CHM QVN(CHI,1) ,U,12)=PV( 14)
  8637   "RTN","CHF BCQ",206,0 )
  8638    S $P(^CHM QVN(CHI,1) ,U,13)=PV( 16)
  8639   "RTN","CHF BCQ",207,0 )
  8640    I PV(17)= "" S $P(^C HMQVN(CHI, 1),U,15)=0
  8641   "RTN","CHF BCQ",208,0 )
  8642    E  S $P(^ CHMQVN(CHI ,1),U,15)= PV(17)
  8643   "RTN","CHF BCQ",209,0 )
  8644    I PV(18)= "" S $P(^C HMQVN(CHI, 1),U,16)=0
  8645   "RTN","CHF BCQ",210,0 )
  8646    E  S $P(^ CHMQVN(CHI ,1),U,16)= PV(18)
  8647   "RTN","CHF BCQ",211,0 )
  8648    I PV(19)= "" S $P(^C HMQVN(CHI, 1),U,17)=0
  8649   "RTN","CHF BCQ",212,0 )
  8650    E  S $P(^ CHMQVN(CHI ,1),U,17)= PV(19)
  8651   "RTN","CHF BCQ",213,0 )
  8652    I PV(20)= "" S $P(^C HMQVN(CHI, 1),U,18)=0
  8653   "RTN","CHF BCQ",214,0 )
  8654    E  S $P(^ CHMQVN(CHI ,1),U,18)= PV(20)
  8655   "RTN","CHF BCQ",215,0 )
  8656    I PV(21)= "" S $P(^C HMQVN(CHI, 1),U,19)=3
  8657   "RTN","CHF BCQ",216,0 )
  8658    E  S $P(^ CHMQVN(CHI ,1),U,19)= PV(21)
  8659   "RTN","CHF BCQ",217,0 )
  8660    Q
  8661   "RTN","CHF BCQ",218,0 )
  8662    ;
  8663   "RTN","CHF BCQ",219,0 )
  8664   STKCLM ;SE T CLAIM IN TO THE VEN DOR QUEUE
  8665   "RTN","CHF BCQ",220,0 )
  8666    Q:CHI=""   Q:'$G(CI)
  8667   "RTN","CHF BCQ",221,0 )
  8668    I '$D(^CH MQVN(CHI,1 0,0)) S ^C HMQVN(CHI, 10,0)="^74 1050.02^0^ 0"
  8669   "RTN","CHF BCQ",222,0 )
  8670    S X=$P(^C HMPAY(CI,0 ),"^",1)
  8671   "RTN","CHF BCQ",223,0 )
  8672    S DA(1)=C HI
  8673   "RTN","CHF BCQ",224,0 )
  8674    S DIC="^C HMQVN("_DA (1)_",10,"
  8675   "RTN","CHF BCQ",225,0 )
  8676    S DIC(0)= "LM"
  8677   "RTN","CHF BCQ",226,0 )
  8678    S DLAYGO= 741050.02
  8679   "RTN","CHF BCQ",227,0 )
  8680    D ^DIC
  8681   "RTN","CHF BCQ",228,0 )
  8682    I $P(Y,U, 3)'=1 G ST KCLM
  8683   "RTN","CHF BCQ",229,0 )
  8684    S DA=+Y
  8685   "RTN","CHF BCQ",230,0 )
  8686    D NOW^%DT C S CHDTTM =%
  8687   "RTN","CHF BCQ",231,0 )
  8688    S (CHI3,C HJ3)=""
  8689   "RTN","CHF BCQ",232,0 )
  8690    S DA(1)=C HI S DIE=" ^CHMQVN("_ DA(1)_",10 ,",CHI3=DA (1),CHJ3=D A
  8691   "RTN","CHF BCQ",233,0 )
  8692    S DR=".02 ///^S X=CH DTTM;.06// /^S X=0;.0 7///^S X=C HMMDP" D ^ DIE
  8693   "RTN","CHF BCQ",234,0 )
  8694    Q
  8695   "RTN","CHF BCQ",235,0 )
  8696    ;
  8697   "RTN","CHF BCQ",236,0 )
  8698   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
  8699   "RTN","CHF BCQ",237,0 )
  8700    .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:"" )
  8701   "RTN","CHF BCQ",238,0 )
  8702    S CHQI=$O (^CHMQAQ(" D",CI,0))
  8703   "RTN","CHF BCQ",239,0 )
  8704   LDQQ1 S CH MFPDI="" D :$D(@(GLPA Y_"CI,""PD I"")"))
  8705   "RTN","CHF BCQ",240,0 )
  8706    .S X=$O(@ (GLPAY_"CI ,""PDI"",9 99)"),-1)  Q:'X  Q:'$ D(^(X,0))
  8707   "RTN","CHF BCQ",241,0 )
  8708    .S CHMFPD I=$P(^(0), "^",1) Q
  8709   "RTN","CHF BCQ",242,0 )
  8710    D NOW^%DT C S CHDT=%  I $D(^CHM QAQ("B",CH DT)) G LDQ Q1
  8711   "RTN","CHF BCQ",243,0 )
  8712    S (DIC,DL AYGO)=7410 10.07,DIC( 0)="ML",X= CHDT D ^DI C K DIC
  8713   "RTN","CHF BCQ",244,0 )
  8714    G LDQQ1:$ P(Y,"^",3) '=1
  8715   "RTN","CHF BCQ",245,0 )
  8716    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"
  8717   "RTN","CHF BCQ",246,0 )
  8718    D ^DIE K  DIE S:CHMF PDI'="" ^C HMQAQ("G", 1,CHMFPDI, DA)=""
  8719   "RTN","CHF BCQ",247,0 )
  8720    S:'$D(^CH MQAQ(DA,1, 0)) ^CHMQA Q(DA,1,0)= "^741010.7 SA^0^0"
  8721   "RTN","CHF BCQ",248,0 )
  8722   Q1 S DA(1) =DA,(DIC,D LAYGO)="^C HMQAQ(DA(1 ),1,",DIC( 0)="ML"
  8723   "RTN","CHF BCQ",249,0 )
  8724    S:CHMFQUE =5 X=1 S:C HMFQUE=20  X=2
  8725   "RTN","CHF BCQ",250,0 )
  8726    S:CHMFQUE =21 X=3 S: CHMFQUE=22  X=4
  8727   "RTN","CHF BCQ",251,0 )
  8728    S:CHMFQUE =23 X=5 S: CHMFQUE=24  X=6
  8729   "RTN","CHF BCQ",252,0 )
  8730    S:CHMFQUE =28 X=7 S: CHMFQUE=33  X=8
  8731   "RTN","CHF BCQ",253,0 )
  8732    S:CHMFQUE =37 X=9 S: CHMFQUE=38  X=10
  8733   "RTN","CHF BCQ",254,0 )
  8734    S:CHMFQUE =40 X=11 S :CHMFQUE=3 9 X=12
  8735   "RTN","CHF BCQ",255,0 )
  8736    S:CHMFQUE =44 X=13   ;AEB 12/20 /2006
  8737   "RTN","CHF BCQ",256,0 )
  8738    S:CHMFQUE =45 X=14   ;AEB 5/9/2 007
  8739   "RTN","CHF BCQ",257,0 )
  8740    D ^DIC K  DIC,DR
  8741   "RTN","CHF BCQ",258,0 )
  8742    I (CHMFQU E'=28)&(CH MFQUE'=37) &(CHMFQUE' =38)&(CHMF QUE'=39)&( CHMFQUE'=4 4) D
  8743   "RTN","CHF BCQ",259,0 )
  8744     .S CHMQN AM="CHMQA1 (",CHMIN=" " K CHMOUT  D ^CHMIS0 41  ;AEB 6 /14/2007 A DDED SNF C LAIMS TO Q AQ P&c
  8745   "RTN","CHF BCQ",260,0 )
  8746    I (CHMFQU E=28)!(CHM FQUE=37)!( CHMFQUE=38 )!(CHMFQUE =40)!(CHMF QUE=39)!(C HMFQUE=45)  D
  8747   "RTN","CHF BCQ",261,0 )
  8748     .D REVCC D^CHTFLIBC (CI)  ;rev erse & cle ar ded/c.s ./cat cap  from claim  DEV021244  JAK 09/03 /14
  8749   "RTN","CHF BCQ",262,0 )
  8750     .D CLRPM T^CHTFLIB2 (CI)  ;cle ar payment  data from  claim DEV 021244 JAK  09/03/14
  8751   "RTN","CHF BCQ",263,0 )
  8752     .S CHMQN AM="CHMQA2 (",CHMIN=" " K CHMOUT  D ^CHMIS0 41  ;AEB 6 /14/2007 A DDED UNIT  CHECK CLAI M TO QAQ C PD
  8753   "RTN","CHF BCQ",264,0 )
  8754    S CHMFPP= "SQQA",CHM FI=CI D ^C HMFWK02
  8755   "RTN","CHF BCQ",265,0 )
  8756    D ADDQA
  8757   "RTN","CHF BCQ",266,0 )
  8758    Q
  8759   "RTN","CHF BCQ",267,0 )
  8760    ;
  8761   "RTN","CHF BCQ",268,0 )
  8762   LDQMCR D M AILMES
  8763   "RTN","CHF BCQ",269,0 )
  8764    Q
  8765   "RTN","CHF BCQ",270,0 )
  8766    I $D(^CHN VPAY(CI))  I '$D(^CHM QAQ("D",CI )) D  Q
  8767   "RTN","CHF BCQ",271,0 )
  8768    .S $P(^CH NVPAY(CI,0 ),"^",2)=1
  8769   "RTN","CHF BCQ",272,0 )
  8770    .S CHMFQU E=38 D LDQ Q Q
  8771   "RTN","CHF BCQ",273,0 )
  8772    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
  8773   "RTN","CHF BCQ",274,0 )
  8774   LDQMCR1 D  NOW^%DTC S  CHDT=% I  $D(^CHMCCR ("B",CHDT) ) G LDQMCR 1
  8775   "RTN","CHF BCQ",275,0 )
  8776    S (DIC,DL AYGO)=7410 10.01,DIC( 0)="ML",X= CHDT D ^DI C K DIC
  8777   "RTN","CHF BCQ",276,0 )
  8778    G LDQMCR1 :$P(Y,"^", 3)'=1
  8779   "RTN","CHF BCQ",277,0 )
  8780    S CHMQNAM ="CHMCCR(" ,CHMIN=""  K CHMOUT D  ^CHMIS041
  8781   "RTN","CHF BCQ",278,0 )
  8782    S DA=+Y,D IE=741010. 01,DR=".02 ////^S X=C I;.03///^S  X=0" D ^D IE K DIE
  8783   "RTN","CHF BCQ",279,0 )
  8784    S:'$D(^CH MCCR(DA,1, 0)) ^CHMCC R(DA,1,0)= "^741010.0 2SA^0^0"
  8785   "RTN","CHF BCQ",280,0 )
  8786   MCR1 S DA( 1)=DA,(DIC ,DLAYGO)=" ^CHMCCR(DA (1),1,",DI C(0)="ML"
  8787   "RTN","CHF BCQ",281,0 )
  8788    S X=4 D ^ DIC K DIC
  8789   "RTN","CHF BCQ",282,0 )
  8790    S CHMFPP= "SQMCCR",C HMFI=CI D  ^CHMFWK02
  8791   "RTN","CHF BCQ",283,0 )
  8792    K DIC,DIE ,DA,DR,XL, CHDIFDED,C HDIFCS Q
  8793   "RTN","CHF BCQ",284,0 )
  8794    ;
  8795   "RTN","CHF BCQ",285,0 )
  8796   CKRO ;CPT  4418 *CR*  8/4/93
  8797   "RTN","CHF BCQ",286,0 )
  8798    Q:$P(@(GL PAY_"CI,6) "),"^",2)= ""
  8799   "RTN","CHF BCQ",287,0 )
  8800    Q:'$D(@(G LPAY_"CI,1 )"))
  8801   "RTN","CHF BCQ",288,0 )
  8802    Q:$P(@(GL PAY_"CI,1) "),"^",1)= ""
  8803   "RTN","CHF BCQ",289,0 )
  8804    S REAS=$P (^CHMDIC(7 41002.34,1 ,2),"^",13 ) D ROREAS
  8805   "RTN","CHF BCQ",290,0 )
  8806    S CIO=$P( @(GLPAY_"C I,6)"),"^" ,2)
  8807   "RTN","CHF BCQ",291,0 )
  8808    Q:'$D(@(G LPAY_"CIO, 1)"))
  8809   "RTN","CHF BCQ",292,0 )
  8810    Q:$P(@(GL PAY_"CIO,1 )"),"^",1) =""
  8811   "RTN","CHF BCQ",293,0 )
  8812    I +$P(@(G LPAY_"CI,1 )"),"^",1) =0 S REAS= $P(^CHMDIC (741002.34 ,1,2),"^", 4) D ROREA S
  8813   "RTN","CHF BCQ",294,0 )
  8814    E  I +$P( @(GLPAY_"C IO,1)"),"^ ",1)>0 S R EAS=$P(^CH MDIC(74100 2.34,1,2), "^",5) D R OREAS
  8815   "RTN","CHF BCQ",295,0 )
  8816    K CIO Q
  8817   "RTN","CHF BCQ",296,0 )
  8818    ;
  8819   "RTN","CHF BCQ",297,0 )
  8820   CKROEDI ;C PE005-100,  CPE005-10 2
  8821   "RTN","CHF BCQ",298,0 )
  8822    ;Q:$P(@(G LPAY_"CI,6 )"),"^",2) =""
  8823   "RTN","CHF BCQ",299,0 )
  8824    ;Q:'$D(@( GLPAY_"CI, 1)"))
  8825   "RTN","CHF BCQ",300,0 )
  8826    ;BDB 1229 2017 Q:$P( @(GLPAY_"C I,1)"),"^" ,1)=""
  8827   "RTN","CHF BCQ",301,0 )
  8828    N CPDI
  8829   "RTN","CHF BCQ",302,0 )
  8830    S CPDI=$O (@(GLPAY_" CI,""PDI"" ,99)"),-1)
  8831   "RTN","CHF BCQ",303,0 )
  8832    Q:'$D(@(G LPAY_"CI," "PDI"",CPD I,0)"))
  8833   "RTN","CHF BCQ",304,0 )
  8834    S CPDI=$P ($G(@(GLPA Y_"CI,""PD I"",CPDI,0 )")),"^",1 )
  8835   "RTN","CHF BCQ",305,0 )
  8836    Q:'CPDI
  8837   "RTN","CHF BCQ",306,0 )
  8838    Q:(($E(CP DI,8,9)'=" 97")&($E(C PDI,8,9)'= "90"))
  8839   "RTN","CHF BCQ",307,0 )
  8840    S CIO=$P( @(GLPAY_"C I,6)"),"^" ,2)
  8841   "RTN","CHF BCQ",308,0 )
  8842    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
  8843   "RTN","CHF BCQ",309,0 )
  8844    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
  8845   "RTN","CHF BCQ",310,0 )
  8846    S REAS=$P (^CHMDIC(7 41002.34,1 ,3),"^",18 ) D ROREAS
  8847   "RTN","CHF BCQ",311,0 )
  8848    S REAS=$P (^CHMDIC(7 41002.34,1 ,3),"^",19 ) D ROREAS
  8849   "RTN","CHF BCQ",312,0 )
  8850    K CIO Q
  8851   "RTN","CHF BCQ",313,0 )
  8852    ;
  8853   "RTN","CHF BCQ",314,0 )
  8854   ROREAS S:' $D(@(GLPAY _"CI,4,0)" )) @(GLPAY _"CI,4,0)" )="^741000 .701P^0^0"
  8855   "RTN","CHF BCQ",315,0 )
  8856    S CHMNEXT =$P(@(GLPA Y_"CI,4,0) "),"^",3), CHMNEXT=CH MNEXT+1,$P (@(GLPAY_" CI,4,0)"), "^",3)=CHM NEXT
  8857   "RTN","CHF BCQ",316,0 )
  8858    S $P(@(GL PAY_"CI,4, CHMNEXT,0) "),"^",1)= REAS
  8859   "RTN","CHF BCQ",317,0 )
  8860    S @(GLPAY _"CI,4,""B "",REAS,CH MNEXT)")=" "
  8861   "RTN","CHF BCQ",318,0 )
  8862    I CHMNEXT =1 S $P(@( GLPAY_"CI, 4,CHMNEXT, 0)"),"^",2 )="OTH"
  8863   "RTN","CHF BCQ",319,0 )
  8864    K CHMNEXT ,REAS Q
  8865   "RTN","CHF BCQ",320,0 )
  8866    ;
  8867   "RTN","CHF BCQ",321,0 )
  8868   ADDQA ;N ( CI,DUZ)
  8869   "RTN","CHF BCQ",322,0 )
  8870    S CHSS=""  I $D(^CHM IMD(741020 .02,"B","P ARAMETER") ) D
  8871   "RTN","CHF BCQ",323,0 )
  8872    .S Y=$O(^ CHMIMD(741 020.02,"B" ,"PARAMETE R",0)) Q:Y =""
  8873   "RTN","CHF BCQ",324,0 )
  8874    .Q:'$D(^C HMIMD(7410 20.02,Y,11 ))  S CHSS =$P(^(11), "^",3) Q:C HSS=""
  8875   "RTN","CHF BCQ",325,0 )
  8876    .Q:'$D(^V A(200,"ZVM S",CHSS))   S CHDUZ=$ O(^VA(200, "ZVMS",CHS S,0)) Q
  8877   "RTN","CHF BCQ",326,0 )
  8878    Q:'$D(CHS S)  Q:CHSS =""  Q:'$D (CI)  Q:CI =""
  8879   "RTN","CHF BCQ",327,0 )
  8880    S CHPDIJ= 0,CHDOCID= "",CHMIMFL =1,CHIMMVE =1,CHOPER= "CHIMMVE"
  8881   "RTN","CHF BCQ",328,0 )
  8882    F  S CHPD IJ=$O(@(GL PAY_"CI,"" PDI"",CHPD IJ)")) Q:' CHPDIJ  D
  8883   "RTN","CHF BCQ",329,0 )
  8884    .Q:'$D(^( CHPDIJ,0))   S CHPDI= $P(^(0),"^ ",1)
  8885   "RTN","CHF BCQ",330,0 )
  8886    .Q:'$D(^C HMIMG(CHPD I,"DOC"))   S CHDOCID =$P(^("DOC "),"^",1)  D ADD^CHMM F
  8887   "RTN","CHF BCQ",331,0 )
  8888    K CHSS,Y, CHDUZ,CHPD IJ,CHDOCID ,CHIMFL,CH IMMVE,CHOP ER,CHPDI Q
  8889   "RTN","CHF BCQ",332,0 )
  8890   MAILMES S  $P(@(GLPAY _"CI,0)"), "^",2)=4
  8891   "RTN","CHF BCQ",333,0 )
  8892    S ^UTILIT Y($J,"MCCR -OVER-PAY" ,1,1,0)="C laim "_CN_ " has calc ulated as  an overpay ment."
  8893   "RTN","CHF BCQ",334,0 )
  8894    S ^UTILIT Y($J,"MCCR -OVER-PAY" ,1,2,0)="P lease rese arch for p otential r ecoupment. "
  8895   "RTN","CHF BCQ",335,0 )
  8896    S XMDUZ=. 5
  8897   "RTN","CHF BCQ",336,0 )
  8898    S XMSUB=" Possible M CCR Recoup ment"
  8899   "RTN","CHF BCQ",337,0 )
  8900    S XMTEXT= "^UTILITY( $J,""MCCR- OVER-PAY"" ,1,"
  8901   "RTN","CHF BCQ",338,0 )
  8902    D RECIP
  8903   "RTN","CHF BCQ",339,0 )
  8904    M ^TMP("R EV-MAIL",$ J)=^UTILIT Y($J,"MCCR -OVER-PAY" )
  8905   "RTN","CHF BCQ",340,0 )
  8906    S U="^" D  ^XMD
  8907   "RTN","CHF BCQ",341,0 )
  8908    Q
  8909   "RTN","CHF BCQ",342,0 )
  8910   RECIP K XM Y
  8911   "RTN","CHF BCQ",343,0 )
  8912    S JJ=0 F   S JJ=$O(^ CHMDIC(741 002.17,1,8 0,JJ)) Q:' JJ  D
  8913   "RTN","CHF BCQ",344,0 )
  8914    .Q:'$D(^C HMDIC(7410 02.17,1,80 ,JJ,0))
  8915   "RTN","CHF BCQ",345,0 )
  8916    .S MMDUZ= $P(^CHMDIC (741002.17 ,1,80,JJ,0 ),"^",1)
  8917   "RTN","CHF BCQ",346,0 )
  8918    .S XMY(MM DUZ)=""
  8919   "RTN","CHF BCQ",347,0 )
  8920    Q
  8921   "RTN","CHF BCQ",348,0 )
  8922    ;
  8923   "RTN","CHF BCQ",349,0 )
  8924   PAIDRVSL(C ) ;DEV0053 11, SKD, 7 -23-08
  8925   "RTN","CHF BCQ",350,0 )
  8926    ;If MMI r eversed cl aim is pai d by anoth er claim,  set the MM I Reversal  Paid Flag  to 1
  8927   "RTN","CHF BCQ",351,0 )
  8928    ;so that  the next d upe claim  won't bypa ss the dup e check
  8929   "RTN","CHF BCQ",352,0 )
  8930    ;
  8931   "RTN","CHF BCQ",353,0 )
  8932    Q:$G(C)=" "
  8933   "RTN","CHF BCQ",354,0 )
  8934    S CLI=C
  8935   "RTN","CHF BCQ",355,0 )
  8936    I $D(^CHM ZHOLD("ZRK MRDUPE",CL I)) D
  8937   "RTN","CHF BCQ",356,0 )
  8938    .S CHMMIO CL=0,CHMMI OCL=$O(^CH MZHOLD("ZR KMRDUPE",C LI,CHMMIOC L))
  8939   "RTN","CHF BCQ",357,0 )
  8940    .Q:'CHMMI OCL
  8941   "RTN","CHF BCQ",358,0 )
  8942    .Q:'$D(^C HMPAY(CHMM IOCL))
  8943   "RTN","CHF BCQ",359,0 )
  8944    .Q:'$D(^C HMPAY(CHMM IOCL,5))
  8945   "RTN","CHF BCQ",360,0 )
  8946    .S $P(^CH MPAY(CHMMI OCL,5),U,1 1)=1
  8947   "RTN","CHF BCQ",361,0 )
  8948    Q
  8949   "RTN","CHF BCUTL")
  8950   0^23^B1756 30513
  8951   "RTN","CHF BCUTL",1,0 )
  8952   CHFBCUTL ; HAC/CR;UTI LITY TO SE T UP FILE  REFERENCES ;Aug 30, 2 018@08:14: 49
  8953   "RTN","CHF BCUTL",2,0 )
  8954    ;;1.0;CHA MPVA SYSTE M;**1**;JU LY 4, 1990 ;Build 5
  8955   "RTN","CHF BCUTL",3,0 )
  8956    ;NODE=ALP HA SUBSCRI PT,CLJ=J V ALUE IF AP PLICABLE,G LPAY=PAY F ILE
  8957   "RTN","CHF BCUTL",4,0 )
  8958    ;CI=CLAIM  INTERNAL  NUMBER
  8959   "RTN","CHF BCUTL",5,0 )
  8960    ;DEV00782 0 - JAK -  08/3/11  S LA - utili ty DISTCU  to distrib ute from l ine to cla im and uni t
  8961   "RTN","CHF BCUTL",6,0 )
  8962    ;DEV00782 0 - JAK -  08/23/11   SLA - util ity SORT t o create l ines for c alculation s
  8963   "RTN","CHF BCUTL",7,0 )
  8964    ; 7/17/20 13 DLB REM OVED INITI ALIZATION  FOR SORT A RRAY FIELD  20 WITHIN  FOR LOOP
  8965   "RTN","CHF BCUTL",8,0 )
  8966    ;MTN01913 9 - JAK -  10/23/13   distributi on without  regard to  order of  rejected u nits withi n a servic e line
  8967   "RTN","CHF BCUTL",9,0 )
  8968   CLAIM K FI LE S FILE= GLPAY_CI_" ,"""_NODE_ """)"
  8969   "RTN","CHF BCUTL",10, 0)
  8970    K NODE,CL J
  8971   "RTN","CHF BCUTL",11, 0)
  8972    Q
  8973   "RTN","CHF BCUTL",12, 0)
  8974    ;
  8975   "RTN","CHF BCUTL",13, 0)
  8976   CLAIM1 K F ILE1 S FIL E1=GLPAY_C I_","""_NO DE_""","_C LJ_",0)"
  8977   "RTN","CHF BCUTL",14, 0)
  8978    K NODE,CL J
  8979   "RTN","CHF BCUTL",15, 0)
  8980    Q
  8981   "RTN","CHF BCUTL",16, 0)
  8982    ;******** ********** ********** ********** ********** *******
  8983   "RTN","CHF BCUTL",17, 0)
  8984    ;WVDEDCS  Function:  DETERMINE  IF DEDUCTI BLE/COST S HARE     C RU JAK
  8985   "RTN","CHF BCUTL",18, 0)
  8986    ; IS ELIG IBLE TO BE  WAIVED                                   C RU JAK
  8987   "RTN","CHF BCUTL",19, 0)
  8988    ;Input pa rameters:
  8989   "RTN","CHF BCUTL",20, 0)
  8990    ;  TOC -  TYPE OF CL AIM
  8991   "RTN","CHF BCUTL",21, 0)
  8992    ;  DOS -  DATE OF SE RVICE OF T HE CLAIM
  8993   "RTN","CHF BCUTL",22, 0)
  8994    ;  PROCCD  - PROCEDU RE CODE
  8995   "RTN","CHF BCUTL",23, 0)
  8996    ;Result:
  8997   "RTN","CHF BCUTL",24, 0)
  8998    ;  1 - TR UE THIS PR OCEDURE DE D/COST SHA RE TO BE W AIVED
  8999   "RTN","CHF BCUTL",25, 0)
  9000    ;  0 - FA LSE THIS P ROCEDURE D ED/COST SH ARE WILL N OT BE WAIV ED
  9001   "RTN","CHF BCUTL",26, 0)
  9002    ;******** ********** ********** ********** ********** *******
  9003   "RTN","CHF BCUTL",27, 0)
  9004   WVDEDCS(TO C,DOS,PROC CD,CLMPTR)                                  ;CRU JAK
  9005   "RTN","CHF BCUTL",28, 0)
  9006    S RETURN= 0
  9007   "RTN","CHF BCUTL",29, 0)
  9008    Q:TOC=1 R ETURN ; in patient cl aims are n ot waived
  9009   "RTN","CHF BCUTL",30, 0)
  9010    Q:PROCCD= "" RETURN    ;procedu re code eq ual to nil
  9011   "RTN","CHF BCUTL",31, 0)
  9012    ;FOR LINE  LEVEL WAI VE CAT/CAP  AJUDICATI ON
  9013   "RTN","CHF BCUTL",32, 0)
  9014    ;Q:'$D(^C HMDIC(7417 17.1,"B",P ROCCD)) RE TURN  ;pro cedure cod e does not  exist in  waiver lis t
  9015   "RTN","CHF BCUTL",33, 0)
  9016    ;S PROCPT =0 S PROCP T=$O(^CHMD IC(741717. 1,"B",PROC CD,PROCPT) ) ; find p roc pointe r
  9017   "RTN","CHF BCUTL",34, 0)
  9018    ;I $D(^CH MDIC(74171 7.1,PROCPT ,0)) D
  9019   "RTN","CHF BCUTL",35, 0)
  9020    ; .S WLST =$P($G(^CH MDIC(74171 7.1,PROCPT ,0)),"^",4 ) ;waitlis t start da te
  9021   "RTN","CHF BCUTL",36, 0)
  9022    ; .Q:WLST =""
  9023   "RTN","CHF BCUTL",37, 0)
  9024    ;  .S WLE N=$P($G(^C HMDIC(7417 17.1,PROCP T,0)),"^", 5) ;waitli st end dat e
  9025   "RTN","CHF BCUTL",38, 0)
  9026    ;  .I WLE N="" S WLE N=9999999
  9027   "RTN","CHF BCUTL",39, 0)
  9028    ;  .I ((D OS>=WLST)& &(DOS<=WLE N)) D  ; c laim date  of service  within wa iving date s
  9029   "RTN","CHF BCUTL",40, 0)
  9030    ;      .. S RETURN=1
  9031   "RTN","CHF BCUTL",41, 0)
  9032    ;FOR CLAI M LEVEL WA IVE CAT/CA P AJUDICAT ION
  9033   "RTN","CHF BCUTL",42, 0)
  9034    N J,TMPCD
  9035   "RTN","CHF BCUTL",43, 0)
  9036    S J=0 F   S J=$O(^CH MPAY(CI,"O PT-PROC",J )) Q:'J  D
  9037   "RTN","CHF BCUTL",44, 0)
  9038    .S PROCCD =$P(^CHMPA Y(CI,"OPT- PROC",J,0) ,U,1)
  9039   "RTN","CHF BCUTL",45, 0)
  9040    .S PROCPT =0 S PROCP T=$O(^CHMD IC(741717. 1,"B",PROC CD,PROCPT) ) ; find p roc pointe r
  9041   "RTN","CHF BCUTL",46, 0)
  9042    .Q:PROCPT =""
  9043   "RTN","CHF BCUTL",47, 0)
  9044    .I $D(^CH MDIC(74171 7.1,PROCPT ,0)) D
  9045   "RTN","CHF BCUTL",48, 0)
  9046    ..S WLST= $P($G(^CHM DIC(741717 .1,PROCPT, 0)),"^",4)  ;waitlist  start dat e
  9047   "RTN","CHF BCUTL",49, 0)
  9048    ..Q:WLST= ""
  9049   "RTN","CHF BCUTL",50, 0)
  9050    ..S WLEN= $P($G(^CHM DIC(741717 .1,PROCPT, 0)),"^",5)  ;waitlist  end date
  9051   "RTN","CHF BCUTL",51, 0)
  9052    ..I WLEN= "" S WLEN= 9999999
  9053   "RTN","CHF BCUTL",52, 0)
  9054    ..I ((DOS >=WLST)&&( DOS<=WLEN) ) D  ; cla im date of  service w ithin waiv ing dates
  9055   "RTN","CHF BCUTL",53, 0)
  9056    ...S RETU RN=1
  9057   "RTN","CHF BCUTL",54, 0)
  9058    Q RETURN
  9059   "RTN","CHF BCUTL",55, 0)
  9060    ;******** ********** ********** ********** ********** *******
  9061   "RTN","CHF BCUTL",56, 0)
  9062    ;SORT Fun ction: CRE ATES LINES  FOR BENE  CALC
  9063   "RTN","CHF BCUTL",57, 0)
  9064    ;Input pa rameters:
  9065   "RTN","CHF BCUTL",58, 0)
  9066    ;  none
  9067   "RTN","CHF BCUTL",59, 0)
  9068    ;  CI and  CHMFTP sh ould be de fined
  9069   "RTN","CHF BCUTL",60, 0)
  9070    ;Result:
  9071   "RTN","CHF BCUTL",61, 0)
  9072    ;  creati on of LINE S (^TMP($J ,"LINE",CI )) for BEN E CALC
  9073   "RTN","CHF BCUTL",62, 0)
  9074    ;******** ********** ********** ********** ********** *******
  9075   "RTN","CHF BCUTL",63, 0)
  9076   SORT(CI)    ;
  9077   "RTN","CHF BCUTL",64, 0)
  9078    ;CHMFTP -   TYPE OF  SERVICE
  9079   "RTN","CHF BCUTL",65, 0)
  9080    ;CHMFTP=1  INPATINT
  9081   "RTN","CHF BCUTL",66, 0)
  9082    ;CHMFTP=2  OUTPATIEN T
  9083   "RTN","CHF BCUTL",67, 0)
  9084    ;CHMFTP=3  PHARMACY
  9085   "RTN","CHF BCUTL",68, 0)
  9086    ;CHMFTP=4  DME
  9087   "RTN","CHF BCUTL",69, 0)
  9088    ;CHMFTP=5  DENTAL
  9089   "RTN","CHF BCUTL",70, 0)
  9090    ;CHMFTP=6  TRAVEL
  9091   "RTN","CHF BCUTL",71, 0)
  9092    ;AAMT - U NIT LEVEL  ALLOWED AM T
  9093   "RTN","CHF BCUTL",72, 0)
  9094    ;TMP($J," LINE",CI,S ORTV)  SOR TV LINE EN TRY IN ^CH MIMAGE OR  GROUP INDI CATOR FROM  CEU
  9095   "RTN","CHF BCUTL",73, 0)
  9096    ;                     1  -  OHI  PAID
  9097   "RTN","CHF BCUTL",74, 0)
  9098    ;                     2  - OHI  PATIENT RE SPON
  9099   "RTN","CHF BCUTL",75, 0)
  9100    ;                     3  - ALL  OTHER OHI  PAYMENTS
  9101   "RTN","CHF BCUTL",76, 0)
  9102    ;                     4  - OHI  OHI PR BAL ANCE
  9103   "RTN","CHF BCUTL",77, 0)
  9104    ;                     5  - MEDI CAD PAYMEN TS
  9105   "RTN","CHF BCUTL",78, 0)
  9106    ;                     6  - TPL
  9107   "RTN","CHF BCUTL",79, 0)
  9108    ;                     7  - ALLO WED AMOUNT
  9109   "RTN","CHF BCUTL",80, 0)
  9110    ;                     8  - BILL ED AMOUNT
  9111   "RTN","CHF BCUTL",81, 0)
  9112    ;                     9  - DED  AMT
  9113   "RTN","CHF BCUTL",82, 0)
  9114    ;                     10 - CAT  CAP AMT
  9115   "RTN","CHF BCUTL",83, 0)
  9116    ;                     11 - COST  SHARE
  9117   "RTN","CHF BCUTL",84, 0)
  9118    ;                     12 - AMT  TO PAY
  9119   "RTN","CHF BCUTL",85, 0)
  9120    ;                     13 - AMT  TO PAY BEN E
  9121   "RTN","CHF BCUTL",86, 0)
  9122    ;                     14 - AMT  TO PAY PRO VIDER
  9123   "RTN","CHF BCUTL",87, 0)
  9124    ;                     15 - PATI ENT PAID A MT
  9125   "RTN","CHF BCUTL",88, 0)
  9126    ;                     16 - # OF  UNITS
  9127   "RTN","CHF BCUTL",89, 0)
  9128    ;                     17 - # AC CEPTED UNI TS
  9129   "RTN","CHF BCUTL",90, 0)
  9130    ;                     18 - CITI  MAX RATE  - POPULATE D IN CHFBC 8A
  9131   "RTN","CHF BCUTL",91, 0)
  9132    ;                                  19 - SP ARE
  9133   "RTN","CHF BCUTL",92, 0)
  9134    ;                                  20 - #  OF UNITS W ITH HAC PA YMENT
  9135   "RTN","CHF BCUTL",93, 0)
  9136    ;                     21 - WAIV ED DED                  JAK CRU  - POPULATE D IN CHFBC 4
  9137   "RTN","CHF BCUTL",94, 0)
  9138    ;                     22 - WAIV ED COST SH ARE          JAK CRU  - POPULATE D IN CHFBC 4
  9139   "RTN","CHF BCUTL",95, 0)
  9140    ;                     23 - WAIV ED CAT CAP              JAK CRU  - POPULATE D IN CHFBC 4
  9141   "RTN","CHF BCUTL",96, 0)
  9142       S CHMF PP="SCLINE " D ^CHMFW K02
  9143   "RTN","CHF BCUTL",97, 0)
  9144       K SORT V K ^TMP($ J,"LINE",C I),^REJ($J ,CI)
  9145   "RTN","CHF BCUTL",98, 0)
  9146       N REC, REC,REC110 ,K2,JJJ,AA MT,BAMT,K3
  9147   "RTN","CHF BCUTL",99, 0)
  9148       I '$D( GLPAY) S X 1=CI D PRO GTYP^CHFCD 001  ;AEB  4 20/2012  DEV007820  SETS GLPAY  IF NOT DE FINED.
  9149   "RTN","CHF BCUTL",100 ,0)
  9150       I GLPA Y="" S X1= CI D PROGT YP^CHFCD00 1  ;AEB 4  20/2012 DE V007820 SE TS GLPAY I F NOT DEFI NED.
  9151   "RTN","CHF BCUTL",101 ,0)
  9152       Q:'$D( @(GLPAY_"C I,0)"))
  9153   "RTN","CHF BCUTL",102 ,0)
  9154       F K2=" OPT-PROC", "DEN-PROC" ,"DME-SUPP LY","PHARM " D
  9155   "RTN","CHF BCUTL",103 ,0)
  9156       .S JJJ =0 F  S JJ J=$O(@(GLP AY_"CI,K2, JJJ)")) Q: 'JJJ  D
  9157   "RTN","CHF BCUTL",104 ,0)
  9158       ..S RE C=@(GLPAY_ "CI,K2,JJJ ,0)") Q:'$ D(REC)
  9159   "RTN","CHF BCUTL",105 ,0)
  9160       ..S RE C110=@(GLP AY_"CI,K2, JJJ,1,1,0) ") Q:'$D(R EC110)
  9161   "RTN","CHF BCUTL",106 ,0)
  9162       ..S SO RTV=$P(REC 110,"^",17 ) Q:SORTV= ""                                 ; DLB  F IELD 17 IS  ^CHMIMAGE  "L" INDEX
  9163   "RTN","CHF BCUTL",107 ,0)
  9164       ..I '$ D(^TMP($J, "LINE",CI, SORTV)) S  ^TMP($J,"L INE",CI,SO RTV)="^^^^ ^^",$P(^TM P($J,"LINE ",CI,SORTV ),"^",20)= 0
  9165   "RTN","CHF BCUTL",108 ,0)
  9166       ..S:$P (REC110,"^ ",1)'="" $ P(^TMP($J, "LINE",CI, SORTV),"^" ,1)=$P(^TM P($J,"LINE ",CI,SORTV ),"^",1)+$ P(REC110," ^",1)  ;OH I PAID
  9167   "RTN","CHF BCUTL",109 ,0)
  9168       ..S:$P (REC110,"^ ",2)'="" $ P(^TMP($J, "LINE",CI, SORTV),"^" ,2)=$P(^TM P($J,"LINE ",CI,SORTV ),"^",2)+$ P(REC110," ^",2)  ;OH I PATIENT  RESPON
  9169   "RTN","CHF BCUTL",110 ,0)
  9170       ..S:$P (REC110,"^ ",3)'="" $ P(^TMP($J, "LINE",CI, SORTV),"^" ,3)=$P(^TM P($J,"LINE ",CI,SORTV ),"^",3)+$ P(REC110," ^",3)  ;AL L OTHER OH I PAYMENTS
  9171   "RTN","CHF BCUTL",111 ,0)
  9172       ..S:$P (REC110,"^ ",4)'="" $ P(^TMP($J, "LINE",CI, SORTV),"^" ,4)=$P(^TM P($J,"LINE ",CI,SORTV ),"^",4)+$ P(REC110," ^",4)  ;OH I PR BALAN CE
  9173   "RTN","CHF BCUTL",112 ,0)
  9174       ..S:$P (REC110,"^ ",5)'="" $ P(^TMP($J, "LINE",CI, SORTV),"^" ,5)=$P(^TM P($J,"LINE ",CI,SORTV ),"^",5)+$ P(REC110," ^",5)  ;ME DICAD PAYM ENTS
  9175   "RTN","CHF BCUTL",113 ,0)
  9176       ..S:$P (REC110,"^ ",6)'="" $ P(^TMP($J, "LINE",CI, SORTV),"^" ,6)=$P(^TM P($J,"LINE ",CI,SORTV ),"^",6)+$ P(REC110," ^",6)  ;TP L
  9177   "RTN","CHF BCUTL",114 ,0)
  9178       ..S:$P (REC110,"^ ",10)'=""  $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",9)=$P(^T MP($J,"LIN E",CI,SORT V),"^",9)+ $P(REC110, "^",10)  ; DED
  9179   "RTN","CHF BCUTL",115 ,0)
  9180       ..S:$P (REC110,"^ ",14)'=""  $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",10)=$P(^ TMP($J,"LI NE",CI,SOR TV),"^",10 )+$P(REC11 0,"^",14)   ;CAT CAP
  9181   "RTN","CHF BCUTL",116 ,0)
  9182       ..S:$P (REC110,"^ ",11)'=""  $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",11)=$P(^ TMP($J,"LI NE",CI,SOR TV),"^",11 )+$P(REC11 0,"^",11)   ;COST SHA RE
  9183   "RTN","CHF BCUTL",117 ,0)
  9184       ..S:$P (REC110,"^ ",12)'=""  $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",12)=$P(^ TMP($J,"LI NE",CI,SOR TV),"^",12 )+$P(REC11 0,"^",12)   ;clm amt  to pay
  9185   "RTN","CHF BCUTL",118 ,0)
  9186       ..S:$P (REC110,"^ ",16)'=""  $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",13)=$P(^ TMP($J,"LI NE",CI,SOR TV),"^",13 )+$P(REC11 0,"^",16)   ;bene amt  to pay
  9187   "RTN","CHF BCUTL",119 ,0)
  9188       ..S:$P (REC110,"^ ",15)'=""  $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",14)=$P(^ TMP($J,"LI NE",CI,SOR TV),"^",14 )+$P(REC11 0,"^",15)   ;vendor a mt to pay
  9189   "RTN","CHF BCUTL",120 ,0)
  9190       ..S:$P (REC110,"^ ",13)'=""  $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",15)=$P(^ TMP($J,"LI NE",CI,SOR TV),"^",15 )+$P(REC11 0,"^",13)   ;BENE PAI D AMT
  9191   "RTN","CHF BCUTL",121 ,0)
  9192       ..S $P (^TMP($J," LINE",CI,S ORTV),"^", 16)=$P(^TM P($J,"LINE ",CI,SORTV ),"^",16)+ 1  ;COUNT#  OF UNITS
  9193   "RTN","CHF BCUTL",122 ,0)
  9194       ..S LN PROC(CI,SO RTV)=$P(RE C,"^",1) ; STORE PROC EDURE AT L INE LEVEL  CRU JAK
  9195   "RTN","CHF BCUTL",123 ,0)
  9196       ..I K2 ="OPT-PROC " D
  9197   "RTN","CHF BCUTL",124 ,0)
  9198       ...S A AMT=$S($P( REC,"^",5) '="":$P(RE C,"^",5),1 :$P(REC,"^ ",3))  ; d etermine a llowed amo unt or adj usted allo wed amount
  9199   "RTN","CHF BCUTL",125 ,0)
  9200       ...S B AMT=$P(REC ,"^",2)
  9201   "RTN","CHF BCUTL",126 ,0)
  9202       ..I K2 ="PHARM" D
  9203   "RTN","CHF BCUTL",127 ,0)
  9204       ...S A AMT=$S($P( REC,"^",10 )'="":$P(R EC,"^",10) ,1:$P(REC, "^",5))  ;  determine  allowed a mount or a djusted al lowed amou nt
  9205   "RTN","CHF BCUTL",128 ,0)
  9206       ...S B AMT=$P(REC ,"^",4)
  9207   "RTN","CHF BCUTL",129 ,0)
  9208       ..I K2 ="DME-SUPP LY" D
  9209   "RTN","CHF BCUTL",130 ,0)
  9210       ...S A AMT=$S($P( REC,"^",5) '="":$P(RE C,"^",5),1 :$P(REC,"^ ",4))  ; d etermine a llowed amo unt or adj usted allo wed amount
  9211   "RTN","CHF BCUTL",131 ,0)
  9212       ...S B AMT=$P(REC ,"^",2)
  9213   "RTN","CHF BCUTL",132 ,0)
  9214       ..I K2 ="DEN-PROC " D
  9215   "RTN","CHF BCUTL",133 ,0)
  9216       ...S A AMT=$S($P( REC,"^",7) '="":$P(RE C,"^",7),1 :$P(REC,"^ ",5))  ; d etermine a llowed amo unt or adj usted allo wed amount
  9217   "RTN","CHF BCUTL",134 ,0)
  9218       ...S B AMT=$P(REC ,"^",2)
  9219   "RTN","CHF BCUTL",135 ,0)
  9220       ..S $P (^TMP($J," LINE",CI,S ORTV),"^", 8)=$P(^TMP ($J,"LINE" ,CI,SORTV) ,"^",8)+BA MT ;BILLED  AMT
  9221   "RTN","CHF BCUTL",136 ,0)
  9222       ..I '$ $ISREJ^CHT FLIB2(CI,K 2,JJJ) I A AMT'="" S  $P(^TMP($J ,"LINE",CI ,SORTV),"^ ",7)=$P(^T MP($J,"LIN E",CI,SORT V),"^",7)+ AAMT  ;ALL OWED AMOUN T
  9223   "RTN","CHF BCUTL",137 ,0)
  9224       ..I '$ $ISREJ^CHT FLIB2(CI,K 2,JJJ) S $ P(^TMP($J, "LINE",CI, SORTV),"^" ,17)=$P(^T MP($J,"LIN E",CI,SORT V),"^",17) +1 ;# UNIT S ACCEPTED
  9225   "RTN","CHF BCUTL",138 ,0)
  9226       ..I '$ $ISREJ^CHT FLIB2(CI,K 2,JJJ)&($P (REC110,"^ ",12)>0) S  $P(^TMP($ J,"LINE",C I,SORTV)," ^",20)=$P( ^TMP($J,"L INE",CI,SO RTV),"^",2 0)+1 ; DLB  6/6/2013  # UNITS W/ HAC PMT
  9227   "RTN","CHF BCUTL",139 ,0)
  9228       Q
  9229   "RTN","CHF BCUTL",140 ,0)
  9230    ;******** ********** ********** ********** ********** *******
  9231   "RTN","CHF BCUTL",141 ,0)
  9232    ;DISTCU F unction: I TERATE THR OUGH PSEUD O LINE LEV EL INFO
  9233   "RTN","CHF BCUTL",142 ,0)
  9234    ;  DISTRI BUTING DOW N TO THE U NIT LEVEL  AND UP TO  CLAIM
  9235   "RTN","CHF BCUTL",143 ,0)
  9236    ;Input pa rameters:
  9237   "RTN","CHF BCUTL",144 ,0)
  9238    ;  INCLM  - Ivalue f rom CHMPAY
  9239   "RTN","CHF BCUTL",145 ,0)
  9240    ;Result:
  9241   "RTN","CHF BCUTL",146 ,0)
  9242    ;  UPDATE  ^CHMPAY g lobal at t he unit le vel and cl aim level
  9243   "RTN","CHF BCUTL",147 ,0)
  9244    ;******** ********** ********** ********** ********** *******
  9245   "RTN","CHF BCUTL",148 ,0)
  9246   DISTCU(INC LM) ;distr ibution to  claim and  unit from  line leve l DEV00782 0
  9247   "RTN","CHF BCUTL",149 ,0)
  9248    S CHMFPP= "SLCU" D ^ CHMFWK02
  9249   "RTN","CHF BCUTL",150 ,0)
  9250    S U="^"
  9251   "RTN","CHF BCUTL",151 ,0)
  9252    I '$D(GLP AY) S X1=I NCLM D PRO GTYP^CHFCD 001  ;JAK  7/5/2012 D EV007820 S ETS GLPAY  IF NOT DEF INED.
  9253   "RTN","CHF BCUTL",152 ,0)
  9254    I GLPAY=" " S X1=INC LM D PROGT YP^CHFCD00 1    ;JAK  7/5/2012 D EV007820 S ETS GLPAY  IF NOT DEF INED.
  9255   "RTN","CHF BCUTL",153 ,0)
  9256    N LINEID, TC,TUI,CHT MP,UNITS,C T,CHBILL,C HAA,CHAAA, CHCAMT,REC
  9257   "RTN","CHF BCUTL",154 ,0)
  9258    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
  9259   "RTN","CHF BCUTL",155 ,0)
  9260     .S TUI=0  F  S TUI= $O(@(GLPAY _"INCLM,TC ,TUI)")) Q :'TUI  D
  9261   "RTN","CHF BCUTL",156 ,0)
  9262           .. S REC=(@(G LPAY_"INCL M,TC,TUI,0 )"))
  9263   "RTN","CHF BCUTL",157 ,0)
  9264           .. I TC="OPT- PROC" S CH BILL=$P(RE C,U,2),CHA A=$P(REC,U ,3),CHAAA= $P(REC,U,5 )
  9265   "RTN","CHF BCUTL",158 ,0)
  9266           .. I TC="DEN- PROC" S CH BILL=$P(RE C,U,2),CHA A=$P(REC,U ,5),CHAAA= $P(REC,U,7 )
  9267   "RTN","CHF BCUTL",159 ,0)
  9268           .. I TC="DME- SUPPLY" S  CHBILL=$P( REC,U,2),C HAA=$P(REC ,U,4),CHAA A=$P(REC,U ,5)
  9269   "RTN","CHF BCUTL",160 ,0)
  9270           .. I TC="PHAR M" S CHBIL L=$P(REC,U ,4),CHAA=$ P(REC,U,5) ,CHAAA=$P( REC,U,10)
  9271   "RTN","CHF BCUTL",161 ,0)
  9272           .. S $P(@(GLP AY_"INCLM, TC,TUI,1,1 ,0)"),"^", 7)=CHBILL           ; populate t he billed  amount
  9273   "RTN","CHF BCUTL",162 ,0)
  9274           .. I CHAAA'=" " D
  9275   "RTN","CHF BCUTL",163 ,0)
  9276                    ...S  $P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",9 )=CHAAA         ;popu late the a djusted al lowable am ount
  9277   "RTN","CHF BCUTL",164 ,0)
  9278           .. E  D
  9279   "RTN","CHF BCUTL",165 ,0)
  9280                    ...S  $P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",9 )=CHAA          ;popu late the a llowable a mount
  9281   "RTN","CHF BCUTL",166 ,0)
  9282           .. F P=1:1:6, 10:1:16 D
  9283   "RTN","CHF BCUTL",167 ,0)
  9284                    ...S  $P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",P )=""        ; clear o ut pieces  for accept ed units s o that the  lines can  be distri buted
  9285   "RTN","CHF BCUTL",168 ,0)
  9286    S LINEID= 0 F  S LIN EID=$O(^TM P($J,"LINE ",INCLM,LI NEID)) Q:' LINEID  D     ;ITERAT E THROUGH  PSEUDO LIN ES
  9287   "RTN","CHF BCUTL",169 ,0)
  9288     .N CHOPR ,CHOTPD,CH MEDI,CHTPL ,UNITS,TUN ITS,AUNITS
  9289   "RTN","CHF BCUTL",170 ,0)
  9290     .N CHDED ,CHCATCAP, CHCSTSH,CH AMTPAY,CHA MTBEN,CHAM TPRO,CHPPA IDA,CHTPRB AL
  9291   "RTN","CHF BCUTL",171 ,0)
  9292     .S CHTMP =^TMP($J," LINE",INCL M,LINEID), TUNITS=$P( CHTMP,"^", 16),AUNITS =$P(CHTMP, "^",17)     ;TUNITS=  # TOTAL UN ITS AT LIN E LEVEL ;  AUNITS= #  ACCEPTED u nits
  9293   "RTN","CHF BCUTL",172 ,0)
  9294     .F P=1:1 :15 D
  9295   "RTN","CHF BCUTL",173 ,0)
  9296           .. I $P(^TMP( $J,"LINE", INCLM,LINE ID),"^",P) '="" D
  9297   "RTN","CHF BCUTL",174 ,0)
  9298                    ...S  CHCAMT(P) =($G(CHCAM T(P)))+$P( ^TMP($J,"L INE",INCLM ,LINEID)," ^",P)  ;ac cumulate c laim amoun ts from li nes
  9299   "RTN","CHF BCUTL",175 ,0)
  9300     .I $G(AU NITS)'>0 D
  9301   "RTN","CHF BCUTL",176 ,0)
  9302           .. S UNITS=TU NITS ;if a ll lines r ejected th en distrib ute OHI in formation  to all uni ts
  9303   "RTN","CHF BCUTL",177 ,0)
  9304     .E  D
  9305   "RTN","CHF BCUTL",178 ,0)
  9306           .. S UNITS=AU NITS ;if n ot all uni ts on line  are rejec ted then o nly distri bute to ac cepted uni ts
  9307   "RTN","CHF BCUTL",179 ,0)
  9308     .;merge  contents o f ^utility  into sepa rate array
  9309   "RTN","CHF BCUTL",180 ,0)
  9310     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",2), UNITS) M:R TN=1 CHOPR =^UTILITY( $J,"UNITS" )
  9311   "RTN","CHF BCUTL",181 ,0)
  9312     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",3), UNITS) M:R TN=1 CHOTP D=^UTILITY ($J,"UNITS ")
  9313   "RTN","CHF BCUTL",182 ,0)
  9314     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",5), UNITS) M:R TN=1 CHMED I=^UTILITY ($J,"UNITS ")
  9315   "RTN","CHF BCUTL",183 ,0)
  9316     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",6), UNITS) M:R TN=1 CHTPL =^UTILITY( $J,"UNITS" )
  9317   "RTN","CHF BCUTL",184 ,0)
  9318     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",9), UNITS) M:R TN=1 CHDED =^UTILITY( $J,"UNITS" )
  9319   "RTN","CHF BCUTL",185 ,0)
  9320     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",10) ,UNITS) M: RTN=1 CHCA TCAP=^UTIL ITY($J,"UN ITS")
  9321   "RTN","CHF BCUTL",186 ,0)
  9322     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",11) ,UNITS) M: RTN=1 CHCS TSH=^UTILI TY($J,"UNI TS")
  9323   "RTN","CHF BCUTL",187 ,0)
  9324     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",12) ,UNITS) M: RTN=1 CHAM TPAY=^UTIL ITY($J,"UN ITS")
  9325   "RTN","CHF BCUTL",188 ,0)
  9326     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",13) ,UNITS) M: RTN=1 CHAM TBEN=^UTIL ITY($J,"UN ITS")
  9327   "RTN","CHF BCUTL",189 ,0)
  9328     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",14) ,UNITS) M: RTN=1 CHAM TPRO=^UTIL ITY($J,"UN ITS")
  9329   "RTN","CHF BCUTL",190 ,0)
  9330     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",15) ,UNITS) M: RTN=1 CHPP AIDA=^UTIL ITY($J,"UN ITS")
  9331   "RTN","CHF BCUTL",191 ,0)
  9332     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",21) ,UNITS) M: RTN=1 CHWV DED=^UTILI TY($J,"UNI TS") ;JAK  CRU - waiv ed deducti ble
  9333   "RTN","CHF BCUTL",192 ,0)
  9334     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",22) ,UNITS) M: RTN=1 CHWV CS=^UTILIT Y($J,"UNIT S") ;JAK C RU - waive d cost sha re
  9335   "RTN","CHF BCUTL",193 ,0)
  9336     .S RTN=$ $UNIT^CHTF LIB($P(CHT MP,"^",23) ,UNITS) M: RTN=1 CHWV CC=^UTILIT Y($J,"UNIT S") ;JAK C RU - waive d cat cap
  9337   "RTN","CHF BCUTL",194 ,0)
  9338     .F TC="O PT-PROC"," DEN-PROC", "DME-SUPPL Y","PHARM"  D             ;itera te through  units
  9339   "RTN","CHF BCUTL",195 ,0)
  9340           .. S CT=0,TUI =0 F  S TU I=$O(^CHMP AY(INCLM,T C,TUI)) Q: 'TUI  D
  9341   "RTN","CHF BCUTL",196 ,0)
  9342                    ...I  $P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",1 7)=LINEID  D
  9343   "RTN","CHF BCUTL",197 ,0)
  9344                             ....I  $P(@(GLPAY _"INCLM,TC ,TUI,1,1,0 )"),"^",9) =0 D
  9345   "RTN","CHF BCUTL",198 ,0)
  9346                                      .....S $ P(@(GLPAY_ "INCLM,TC, TUI,1,1,0) "),"^",8)= 0 ;unit re jected ind icator
  9347   "RTN","CHF BCUTL",199 ,0)
  9348                             ....E   D
  9349   "RTN","CHF BCUTL",200 ,0)
  9350                                      .....S $ P(@(GLPAY_ "INCLM,TC, TUI,1,1,0) "),"^",8)= 1 ;unit al lowed indi cator
  9351   "RTN","CHF BCUTL",201 ,0)
  9352                             ....I  '$$ISREJ^C HTFLIB2(IN CLM,TC,TUI )!($$ISREJ ^CHTFLIB2( INCLM,TC,T UI)&($G(AU NITS)'>0))  D ;if acc epted OR ( rejected A ND all are  rejected)  then dist ribute OHI  info ;MTN 019139 - J AK - 10/23 /13
  9353   "RTN","CHF BCUTL",202 ,0)
  9354                                      .....S C T=CT+1 ; o nly accumu late on ac cepted or  if all rej ected ;MTN 019139 - J AK - 10/23 /13
  9355   "RTN","CHF BCUTL",203 ,0)
  9356                                      .....I $ G(CHOPR(CT ))'="" S $ P(@(GLPAY_ "INCLM,TC, TUI,1,1,0) "),"^",2)= $P(@(GLPAY _"INCLM,TC ,TUI,1,1,0 )"),"^",2) +CHOPR(CT)
  9357   "RTN","CHF BCUTL",204 ,0)
  9358                                      .....I $ G(CHOPR(CT ))'="" S $ P(@(GLPAY_ "INCLM,TC, TUI,1,1,0) "),"^",1)= $P(@(GLPAY _"INCLM,TC ,TUI,1,1,0 )"),"^",7) -$P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",2 )
  9359   "RTN","CHF BCUTL",205 ,0)
  9360                                      .....I $ G(CHOTPD(C T))'="" S  $P(@(GLPAY _"INCLM,TC ,TUI,1,1,0 )"),"^",3) =$P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",3 )+CHOTPD(C T)
  9361   "RTN","CHF BCUTL",206 ,0)
  9362                                      .....I $ G(CHOPR(CT ))'=""!($G (CHOTPD(CT ))'="") D
  9363   "RTN","CHF BCUTL",207 ,0)
  9364                                               ......S CH TPRBAL=$P( @(GLPAY_"I NCLM,TC,TU I,1,1,0)") ,"^",2)-$P (@(GLPAY_" INCLM,TC,T UI,1,1,0)" ),"^",3)
  9365   "RTN","CHF BCUTL",208 ,0)
  9366                                               ......I CH TPRBAL<0 S  CHTPRBAL= 0
  9367   "RTN","CHF BCUTL",209 ,0)
  9368                                               ......S $P (@(GLPAY_" INCLM,TC,T UI,1,1,0)" ),"^",4)=C HTPRBAL
  9369   "RTN","CHF BCUTL",210 ,0)
  9370                                      .....I $ G(CHMEDI(C T))'="" S  $P(@(GLPAY _"INCLM,TC ,TUI,1,1,0 )"),"^",5) =$P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",5 )+CHMEDI(C T)
  9371   "RTN","CHF BCUTL",211 ,0)
  9372                                      .....I $ G(CHTPL(CT ))'="" S $ P(@(GLPAY_ "INCLM,TC, TUI,1,1,0) "),"^",6)= $P(@(GLPAY _"INCLM,TC ,TUI,1,1,0 )"),"^",6) +CHTPL(CT)
  9373   "RTN","CHF BCUTL",212 ,0)
  9374                    .... I $$ISREJ^ CHTFLIB2(I NCLM,TC,TU I) D
  9375   "RTN","CHF BCUTL",213 ,0)
  9376                             .....F  P=10:1:16  D
  9377   "RTN","CHF BCUTL",214 ,0)
  9378                                               ......S $P (@(GLPAY_" INCLM,TC,T UI,1,1,0)" ),"^",P)=0     ;zero  out catcap , deductib le, paymen t info
  9379   "RTN","CHF BCUTL",215 ,0)
  9380                             ....E   D  ;accep ted lines  must distr ibute rest  of inform ation to u nit level
  9381   "RTN","CHF BCUTL",216 ,0)
  9382                                      .....I $ G(CHDED(CT ))'="" S $ P(@(GLPAY_ "INCLM,TC, TUI,1,1,0) "),"^",10) =$P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",1 0)+CHDED(C T)
  9383   "RTN","CHF BCUTL",217 ,0)
  9384                                      .....I $ G(CHCSTSH( CT))'="" S  $P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",1 1)=$P(@(GL PAY_"INCLM ,TC,TUI,1, 1,0)"),"^" ,11)+CHCST SH(CT)
  9385   "RTN","CHF BCUTL",218 ,0)
  9386                                      .....I $ G(CHAMTPAY (CT))'=""  S $P(@(GLP AY_"INCLM, TC,TUI,1,1 ,0)"),"^", 12)=$P(@(G LPAY_"INCL M,TC,TUI,1 ,1,0)"),"^ ",12)+CHAM TPAY(CT)
  9387   "RTN","CHF BCUTL",219 ,0)
  9388                                      .....I $ G(CHPPAIDA (CT))'=""  S $P(@(GLP AY_"INCLM, TC,TUI,1,1 ,0)"),"^", 13)=$P(@(G LPAY_"INCL M,TC,TUI,1 ,1,0)"),"^ ",13)+CHPP AIDA(CT)
  9389   "RTN","CHF BCUTL",220 ,0)
  9390                                      .....I $ G(CHCATCAP (CT))'=""  S $P(@(GLP AY_"INCLM, TC,TUI,1,1 ,0)"),"^", 14)=$P(@(G LPAY_"INCL M,TC,TUI,1 ,1,0)"),"^ ",14)+CHCA TCAP(CT)
  9391   "RTN","CHF BCUTL",221 ,0)
  9392                                      .....I $ G(CHAMTPRO (CT))'=""  S $P(@(GLP AY_"INCLM, TC,TUI,1,1 ,0)"),"^", 15)=$P(@(G LPAY_"INCL M,TC,TUI,1 ,1,0)"),"^ ",15)+CHAM TPRO(CT)
  9393   "RTN","CHF BCUTL",222 ,0)
  9394                                      .....I $ G(CHAMTBEN (CT))'=""  S $P(@(GLP AY_"INCLM, TC,TUI,1,1 ,0)"),"^", 16)=$P(@(G LPAY_"INCL M,TC,TUI,1 ,1,0)"),"^ ",16)+CHAM TBEN(CT)
  9395   "RTN","CHF BCUTL",223 ,0)
  9396                                      .....I $ G(CHWVDED( CT))'="" S  $P(@(GLPA Y_"INCLM,T C,TUI,1,1, 0)"),"^",1 8)=$P(@(GL PAY_"INCLM ,TC,TUI,1, 1,0)"),"^" ,18)+CHAMT BEN(CT) ;J AK CRU
  9397   "RTN","CHF BCUTL",224 ,0)
  9398                                      .....I $ G(CHWVCS(C T))'="" S  $P(@(GLPAY _"INCLM,TC ,TUI,1,1,0 )"),"^",19 )=$P(@(GLP AY_"INCLM, TC,TUI,1,1 ,0)"),"^", 19)+CHAMTB EN(CT) ; J AK CRU
  9399   "RTN","CHF BCUTL",225 ,0)
  9400                                      .....I $ G(CHWVCC(C T))'="" S  $P(@(GLPAY _"INCLM,TC ,TUI,1,1,0 )"),"^",20 )=$P(@(GLP AY_"INCLM, TC,TUI,1,1 ,0)"),"^", 20)+CHAMTB EN(CT)  ;J AK CRU
  9401   "RTN","CHF BCUTL",226 ,0)
  9402    ; populat e the clai m level in formation
  9403   "RTN","CHF BCUTL",227 ,0)
  9404    I $G(CHCA MT(1))'=""  S $P(@(GL PAY_"INCLM ,1)"),U,7) =$FN(CHCAM T(1),"",2)                   ;pr imary ohi  paid amt
  9405   "RTN","CHF BCUTL",228 ,0)
  9406    I $G(CHCA MT(2))'=""  S $P(@(GL PAY_"INCLM ,1)"),U,29 )=$FN(CHCA MT(2),"",2 )                 ;pr imary ohi  pr (patien t reponsib ility)
  9407   "RTN","CHF BCUTL",229 ,0)
  9408    I $G(CHCA MT(3))'=""  S $P(@(GL PAY_"INCLM ,7)"),U,10 )=$FN(CHCA MT(3),"",2 )                 ;ad ditional o hi amts
  9409   "RTN","CHF BCUTL",230 ,0)
  9410    I $G(CHCA MT(4))'=""  S $P(@(GL PAY_"INCLM ,7)"),U,11 )=$FN(CHCA MT(4),"",2 )                 ;oh i pr balan ce
  9411   "RTN","CHF BCUTL",231 ,0)
  9412    I $G(CHCA MT(5))'=""  S $P(@(GL PAY_"INCLM ,7)"),U,2) =$FN(CHCAM T(5),"",2)                   ;me dicaid pai d amt
  9413   "RTN","CHF BCUTL",232 ,0)
  9414    I $G(CHCA MT(6))'=""  S $P(@(GL PAY_"INCLM ,7)"),U,9) =$FN(CHCAM T(6),"",2)                   ;tp l amt
  9415   "RTN","CHF BCUTL",233 ,0)
  9416    I $G(CHCA MT(7))'=""  S $P(@(GL PAY_"INCLM ,""COMMON" ")"),U,7)= $FN(CHCAMT (7),"",2)         ;al lowed amou nt
  9417   "RTN","CHF BCUTL",234 ,0)
  9418    I $G(CHCA MT(8))'=""  S $P(@(GL PAY_"INCLM ,""COMMON" ")"),U,1)= $FN(CHCAMT (8),"",2)         ;bi lled amoun t
  9419   "RTN","CHF BCUTL",235 ,0)
  9420    I $G(CHCA MT(9))'=""  S $P(@(GL PAY_"INCLM ,1)"),U,5) =$FN(CHCAM T(9),"",2)                   ;de ductible a mt
  9421   "RTN","CHF BCUTL",236 ,0)
  9422    I $G(CHCA MT(10))'=" " S $P(@(G LPAY_"INCL M,1)"),U,1 8)=$FN(CHC AMT(10),"" ,2)               ;ca t cap amt
  9423   "RTN","CHF BCUTL",237 ,0)
  9424    I $G(CHCA MT(11))'=" " S $P(@(G LPAY_"INCL M,1)"),U,6 )=$FN(CHCA MT(11),"", 2)                ;co st share a mt
  9425   "RTN","CHF BCUTL",238 ,0)
  9426    I $G(CHCA MT(12))'=" " S $P(@(G LPAY_"INCL M,1)"),U,1 )=$FN(CHCA MT(12),"", 2)                ;pa yment amt  (total amo unt paid)
  9427   "RTN","CHF BCUTL",239 ,0)
  9428    I $G(CHCA MT(13))'=" " S $P(@(G LPAY_"INCL M,1)"),U,1 5)=$FN(CHC AMT(13),"" ,2)               ;am ount paid  to bene
  9429   "RTN","CHF BCUTL",240 ,0)
  9430    I $G(CHCA MT(14))'=" " S $P(@(G LPAY_"INCL M,1)"),U,1 4)=$FN(CHC AMT(14),"" ,2)               ;am ount paid  to vendor
  9431   "RTN","CHF BCUTL",241 ,0)
  9432    I $G(CHCA MT(15))'=" " S $P(@(G LPAY_"INCL M,""COMMON "")"),U,3) =$FN(CHCAM T(15),"",2 )      ;pa tient paid  amt (bene  paid amt)
  9433   "RTN","CHF BCUTL",242 ,0)
  9434    Q
  9435   "RTN","CHG AS22")
  9436   0^24^B7343 1822
  9437   "RTN","CHG AS22",1,0)
  9438   CHGAS22 ;C VA/RLC;ASQ  SCREEN DI SPLAY CALC  - PART 2  ;Feb 05, 2 019@09:51: 25
  9439   "RTN","CHG AS22",2,0)
  9440    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  9441   "RTN","CHG AS22",3,0)
  9442    ;;V2.0;;
  9443   "RTN","CHG AS22",4,0)
  9444    ; PT #161 10 (Y2K)
  9445   "RTN","CHG AS22",5,0)
  9446    ; PT #168 65 (JBM) F ixed indir ection
  9447   "RTN","CHG AS22",6,0)
  9448    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  9449   "RTN","CHG AS22",7,0)
  9450    ;             CHZONE  - SCREEN  REGION
  9451   "RTN","CHG AS22",8,0)
  9452    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 *-RLC, #12 197 (RLC)
  9453   "RTN","CHG AS22",9,0)
  9454    ; MC284 J EH 9/5/06  Change OHI  Paid amou nt to Pati ent Respon sibility
  9455   "RTN","CHG AS22",10,0 )
  9456    ; DEV7820  EW 1/25/1 1 Add paid  by TPL an d totals f or OHI and  MEDICAID
  9457   "RTN","CHG AS22",11,0 )
  9458    ;CFS 07/2 4/2017 - A dd PL ZIP  for User S tory CPE00 1-005.
  9459   "RTN","CHG AS22",12,0 )
  9460    ;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.
  9461   "RTN","CHG AS22",13,0 )
  9462    ;
  9463   "RTN","CHG AS22",14,0 )
  9464    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  9465   "RTN","CHG AS22",15,0 )
  9466   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"
  9467   "RTN","CHG AS22",16,0 )
  9468    ; Y2K - C hg'd date  format for  CHDT
  9469   "RTN","CHG AS22",17,0 )
  9470    ;D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= X_U_$$FMTE ^XLFDT(CHD T,"2D")_U_ CHRSN_U_CH MM
  9471   "RTN","CHG AS22",18,0 )
  9472    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_$$FMTE^ XLFDT(+CHD T,"5D")_U_ CHRSN_U_CH MM
  9473   "RTN","CHG AS22",19,0 )
  9474    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"
  9475   "RTN","CHG AS22",20,0 )
  9476    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHDOS_U _CHPOS_U_C HEDI
  9477   "RTN","CHG AS22",21,0 )
  9478    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"
  9479   "RTN","CHG AS22",22,0 )
  9480    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHMCCR_ U_CHTOB_U_ $E(CHPCN,1 ,20)
  9481   "RTN","CHG AS22",23,0 )
  9482    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"
  9483   "RTN","CHG AS22",24,0 )
  9484    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_$E(CHOH TP,1,15)_U _CHOHBP_U_ CHOHEP
  9485   "RTN","CHG AS22",25,0 )
  9486    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"
  9487   "RTN","CHG AS22",26,0 )
  9488    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHOHI_U _CHBAMT    ; JEH 9/5/ 06
  9489   "RTN","CHG AS22",27,0 )
  9490    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
  9491   "RTN","CHG AS22",28,0 )
  9492    I CHPZIP= "" D UPCT  S ^UTILITY ($J,"ASQ", CHZONE,CT) =X_U_CHOHI PR_U_CHTPL   ;DEV7820  EW 1/25/1 1
  9493   "RTN","CHG AS22",29,0 )
  9494    E  D
  9495   "RTN","CHG AS22",30,0 )
  9496    .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
  9497   "RTN","CHG AS22",31,0 )
  9498    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= X_U_CHOHIP R_U_CHTPL_ U_CHPZIP   ;DEV7820 E W 1/25/11
  9499   "RTN","CHG AS22",32,0 )
  9500    ;Defect 8 32284 Star t
  9501   "RTN","CHG AS22",33,0 )
  9502    S CHPLZIP =$P($G(^CH MPAY(CHCLM ,"VEN-II") ),U,15)
  9503   "RTN","CHG AS22",34,0 )
  9504    ;Display  PL ZIP fie ld for OPT  INP and D NT claims  only.
  9505   "RTN","CHG AS22",35,0 )
  9506    I (CHTOS= "OPT")!(CH TOS="IPT") !(CHTOS="D NT") D
  9507   "RTN","CHG AS22",36,0 )
  9508    . S X="X  XY W @CHBO N,""PL ZIP : "",@CHBO FF,P1 S DX =28,$X=DX, $Y=DY"  ;C FS 001-005
  9509   "RTN","CHG AS22",37,0 )
  9510    . D UPCT  S ^UTILITY ($J,"ASQ", CHZONE,CT) =X_U_CHPLZ IP
  9511   "RTN","CHG AS22",38,0 )
  9512    ;
  9513   "RTN","CHG AS22",39,0 )
  9514    ;S CHPLZI P=$P($G(^C HMPAY(CHCL M,"VEN-II" )),U,15)
  9515   "RTN","CHG AS22",40,0 )
  9516    ;Defect 8 32284 End
  9517   "RTN","CHG AS22",41,0 )
  9518    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  9519   "RTN","CHG AS22",42,0 )
  9520    S (CHMODS ,CHMEDPT,C HOHIPDT,CH OHIPRT,CHO HIADT,CHOH IPBT)=""
  9521   "RTN","CHG AS22",43,0 )
  9522    S:CHTOS=" OPT" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  9523   "RTN","CHG AS22",44,0 )
  9524    S:CHTOS=" DUR" CHTDX ="DME-DX", CHTPRC="DM E-SUPPLY"
  9525   "RTN","CHG AS22",45,0 )
  9526    S:CHTOS=" DNT" CHTDX ="DEN-DX", CHTPRC="DE N-PROC"
  9527   "RTN","CHG AS22",46,0 )
  9528    S:CHTOS=" TRV" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  9529   "RTN","CHG AS22",47,0 )
  9530    S CHTOSP= $S(CHTOS=" IPT":CHTOS ,CHTOS="DU R":CHTOS,C HTOS="RXT" :CHTOS,1:" OPT")
  9531   "RTN","CHG AS22",48,0 )
  9532    D:CHTOSP' ="" @CHTOS P^CHGAS3
  9533   "RTN","CHG AS22",49,0 )
  9534    ;-------- ---------- ----DEV782 0 EW 1/25/ 11
  9535   "RTN","CHG AS22",50,0 )
  9536    ;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  ""-------- --"""
  9537   "RTN","CHG AS22",51,0 )
  9538    ;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)"
  9539   "RTN","CHG AS22",52,0 )
  9540    ;D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= X_U_CHTCB_ U_CHTAA
  9541   "RTN","CHG AS22",53,0 )
  9542    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
  9543   "RTN","CHG AS22",54,0 )
  9544    I CHOHIPD T'="" S CH OHIPDT=$FN (CHOHIPDT, "",2)
  9545   "RTN","CHG AS22",55,0 )
  9546    I CHOHIPR T'="" S CH OHIPRT=$FN (CHOHIPRT, "",2)
  9547   "RTN","CHG AS22",56,0 )
  9548    I CHMEDPT '="" S CHM EDPT=$FN(C HMEDPT,"", 2)
  9549   "RTN","CHG AS22",57,0 )
  9550    I CHOHIAD T'="" S CH OHIADT=$FN (CHOHIADT, "",2)
  9551   "RTN","CHG AS22",58,0 )
  9552    I CHOHIPB T'="" S CH OHIPBT=$FN (CHOHIPBT, "",2)
  9553   "RTN","CHG AS22",59,0 )
  9554    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
  9555   "RTN","CHG AS22",60,0 )
  9556    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
  9557   "RTN","CHG AS22",61,0 )
  9558    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
  9559   "RTN","CHG AS22",62,0 )
  9560    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHOHIAD T_U_CHOHIP BT  ;MTN01 3163F  EW   BUG ASQ13  10/15/12
  9561   "RTN","CHG AS22",63,0 )
  9562    ;-------- ---------- -----DEV78 20 EW 1/25 /11
  9563   "RTN","CHG AS22",64,0 )
  9564    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  9565   "RTN","CHG AS22",65,0 )
  9566    D REOPEN^ CHGAS24
  9567   "RTN","CHG AS22",66,0 )
  9568    S X="X XY  W @CHBON, ""Benefici ary Data:" ",@CHBOFF"
  9569   "RTN","CHG AS22",67,0 )
  9570    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X
  9571   "RTN","CHG AS22",68,0 )
  9572    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"
  9573   "RTN","CHG AS22",69,0 )
  9574    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHDOB_U _CHAGE_U_C HSEX_U_CHS SN
  9575   "RTN","CHG AS22",70,0 )
  9576    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"
  9577   "RTN","CHG AS22",71,0 )
  9578    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBAD1_ U_CHREL
  9579   "RTN","CHG AS22",72,0 )
  9580    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1"
  9581   "RTN","CHG AS22",73,0 )
  9582    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBAD2
  9583   "RTN","CHG AS22",74,0 )
  9584    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"
  9585   "RTN","CHG AS22",75,0 )
  9586    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHBCTY_ U_CHBST_U_ CHBZIP
  9587   "RTN","CHG AS22",76,0 )
  9588    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" W "" """
  9589   "RTN","CHG AS22",77,0 )
  9590    S VPTR=""
  9591   "RTN","CHG AS22",78,0 )
  9592    S:$D(@(GL PAY_"CHCLM ,0)")) VPT R=$P(@(GLP AY_"CHCLM, 0)"),U,3)
  9593   "RTN","CHG AS22",79,0 )
  9594    I VPTR'=" " I $D(^CH MVEN(VPTR, 20)) D
  9595   "RTN","CHG AS22",80,0 )
  9596    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9597   "RTN","CHG AS22",81,0 )
  9598    .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"
  9599   "RTN","CHG AS22",82,0 )
  9600    ;NEXT FEW  LINES DIS PLAY BOTH  THE VENDOR  REMIT-TO  AND PL ADD RESSES
  9601   "RTN","CHG AS22",83,0 )
  9602    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"
  9603   "RTN","CHG AS22",84,0 )
  9604    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHVTIDP _U_CHAOB_U _CHVNPG_U_ CHCMAC
  9605   "RTN","CHG AS22",85,0 )
  9606    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"
  9607   "RTN","CHG AS22",86,0 )
  9608    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHVEN_U _CHPLVEN
  9609   "RTN","CHG AS22",87,0 )
  9610    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""A ddr1: "",@ CHBOFF,P2"
  9611   "RTN","CHG AS22",88,0 )
  9612    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTAD1 _U_CHVAD1
  9613   "RTN","CHG AS22",89,0 )
  9614    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""A ddr2: "",@ CHBOFF,P2"
  9615   "RTN","CHG AS22",90,0 )
  9616    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTAD2 _U_CHVAD2
  9617   "RTN","CHG AS22",91,0 )
  9618    S X="X XY  W @CHBON, ""City:  " ",@CHBOFF, P1 S DX=42 ,$X=DX,$Y= DY X XY W  @CHBON,""C ity:  "",@ CHBOFF,P2"
  9619   "RTN","CHG AS22",92,0 )
  9620    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTVCT Y_U_CHVCTY
  9621   "RTN","CHG AS22",93,0 )
  9622    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"
  9623   "RTN","CHG AS22",94,0 )
  9624    D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=X _U_CHRTVST _U_CHRTVZI P_U_CHVST_ U_CHVZIP
  9625   "RTN","CHG AS22",95,0 )
  9626    I CHMED'= "" D MED^C HGAS24
  9627   "RTN","CHG AS22",96,0 )
  9628    D QUECHK^ CHGAS24
  9629   "RTN","CHG AS22",97,0 )
  9630    S CHPTR=C HCLM D ^CH GASHST,^CH GAS2PP
  9631   "RTN","CHG AS22",98,0 )
  9632    I $D(^CHM CLCOM("B", CHCLMO)) D   S CHCOM= CHCLMO D ^ CHGAS3AA K  CHCOM
  9633   "RTN","CHG AS22",99,0 )
  9634    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9635   "RTN","CHG AS22",100, 0)
  9636    .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"
  9637   "RTN","CHG AS22",101, 0)
  9638    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9639   "RTN","CHG AS22",102, 0)
  9640    I CHPDI'= "" I $D(^C HMCLCOM("B ",$P(CHPDI ,"-",1)))  D  S CHCOM =$P(CHPDI, "-",1) D ^ CHGAS3AB K  CHCOM
  9641   "RTN","CHG AS22",103, 0)
  9642    .I '$D(^C HMCLCOM("B ",CHCLMO))  D UPCT S  ^UTILITY($ J,"ASQ",CH ZONE,CT)=" "
  9643   "RTN","CHG AS22",104, 0)
  9644    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= "W "" """
  9645   "RTN","CHG AS22",105, 0)
  9646    .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"
  9647   "RTN","CHG AS22",106, 0)
  9648    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9649   "RTN","CHG AS22",107, 0)
  9650    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D  D ^ CHGAS17
  9651   "RTN","CHG AS22",108, 0)
  9652    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9653   "RTN","CHG AS22",109, 0)
  9654    .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"
  9655   "RTN","CHG AS22",110, 0)
  9656    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9657   "RTN","CHG AS22",111, 0)
  9658    I $D(CHMW AT("BENWAT ")) D  D B ENWAT^CHGA S17
  9659   "RTN","CHG AS22",112, 0)
  9660    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9661   "RTN","CHG AS22",113, 0)
  9662    .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"
  9663   "RTN","CHG AS22",114, 0)
  9664    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9665   "RTN","CHG AS22",115, 0)
  9666    I VPTR'=" " I $D(^CH MVEN(VPTR, 20)) D  D  ^CHGAS18
  9667   "RTN","CHG AS22",116, 0)
  9668    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9669   "RTN","CHG AS22",117, 0)
  9670    .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"
  9671   "RTN","CHG AS22",118, 0)
  9672    .D UPCT S  ^UTILITY( $J,"ASQ",C HZONE,CT)= ""
  9673   "RTN","CHG AS22",119, 0)
  9674    D ^CHGASO HI
  9675   "RTN","CHG AS22",120, 0)
  9676    K I,J,L,U ,X,Z,CT,CH S,RCT,II,J J,CHDT,CHB A,CHBTL,CH BATCH,CHRL
  9677   "RTN","CHG AS22",121, 0)
  9678    K CHPS,CH POS,CHME,C HMETH,CHME D,CHMAD1,C HMAD2,CHMC TY,CHMST,C HMZIP,CHID
  9679   "RTN","CHG AS22",122, 0)
  9680    K CHZONE, CHTYP,REC0 ,REC1,REC2 ,REC3,REC4 ,REC5,CHCL MO,CHAOB
  9681   "RTN","CHG AS22",123, 0)
  9682    K CHSTAT, CHDOCID,CH PITY,CHPDI TY,CHPD,CH SPON,CHBEN E,CHDOB,CH SSN
  9683   "RTN","CHG AS22",124, 0)
  9684    K CHBAD1, CHBAD2,CHB CTY,CHSTA, CHSTE,CHBS T,CHBZIP,C HDOS,CHTOS ,CHTOSS
  9685   "RTN","CHG AS22",125, 0)
  9686    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
  9687   "RTN","CHG AS22",126, 0)
  9688    K CHTAA,C HEDI,CHVEN ,CHVTIDP,C HVAD1,CHVA D2,CHVST,C HVCTY,CHVZ IP,CHMTAX
  9689   "RTN","CHG AS22",127, 0)
  9690    K CHDT,CH RSN,CHRS,C HVE,CHDUZ, CHROPEN,CH TDX,CHTOSP ,CHTPRC,CH CODE,CHDAT A
  9691   "RTN","CHG AS22",128, 0)
  9692    K CHDESC, CHRULEJ,CH TYPE,CHPTR ,CHFLAG,CH COM,CHDC,F LG
  9693   "RTN","CHG AS22",129, 0)
  9694    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
  9695   "RTN","CHG AS22",130, 0)
  9696    Q
  9697   "RTN","CHG AS22",131, 0)
  9698    ;
  9699   "RTN","CHG AS22",132, 0)
  9700   UPCT S (CT ,^UTILITY( $J,"ASQ",C HZONE,0))= CT+1 Q
  9701   "RTN","CHG ASIP")
  9702   0^70^B6071 6419
  9703   "RTN","CHG ASIP",1,0)
  9704   CHGASIP ;C VA/RLC;ASQ  WIP REPOR T PRINT -  IN-PAT CLA IMS ;Feb 0 5, 2019@09 :58:51
  9705   "RTN","CHG ASIP",2,0)
  9706    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  9707   "RTN","CHG ASIP",3,0)
  9708    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 *, #13310  (RLC)
  9709   "RTN","CHG ASIP",4,0)
  9710    ;NOIS CP2 -0203-1017 7 (JEH) Fi xed bene c omments pr inting for  all claim s
  9711   "RTN","CHG ASIP",5,0)
  9712    ;MC284 JE H 9/5/06 C hange OHI  Paid amoun t to Patie nt Respons ibility
  9713   "RTN","CHG ASIP",6,0)
  9714    ;DEV00480 5 1/20/201 0 AEB
  9715   "RTN","CHG ASIP",7,0)
  9716    ;MTN01316 3 11/1/201 1 DGC
  9717   "RTN","CHG ASIP",8,0)
  9718    ;CPE001-0 06 ;05/03/ 2017; AJF
  9719   "RTN","CHG ASIP",9,0)
  9720    ;CPE001-0 08 5/12/20 17 wtc
  9721   "RTN","CHG ASIP",10,0 )
  9722    ;DEFECT 8 61585 - TG H - 11/26/ 18 Correct  PL Zip va riable
  9723   "RTN","CHG ASIP",11,0 )
  9724    ;DEFECT 8 77425 - TG H - 12/4/1 8 Display  PL ZIP onl y if Inpat ient, Outp atient, or  Dental
  9725   "RTN","CHG ASIP",12,0 )
  9726    D HEAD
  9727   "RTN","CHG ASIP",13,0 )
  9728    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)
  9729   "RTN","CHG ASIP",14,0 )
  9730    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)
  9731   "RTN","CHG ASIP",15,0 )
  9732    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)
  9733   "RTN","CHG ASIP",16,0 )
  9734    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
  9735   "RTN","CHG ASIP",17,0 )
  9736    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)
  9737   "RTN","CHG ASIP",18,0 )
  9738    ;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)
  9739   "RTN","CHG ASIP",19,0 )
  9740    ;CJM LINE  LENGTH FO R MIGRATIO N R1 20170 719
  9741   "RTN","CHG ASIP",20,0 )
  9742    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 )
  9743   "RTN","CHG ASIP",21,0 )
  9744    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
  9745   "RTN","CHG ASIP",22,0 )
  9746    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)
  9747   "RTN","CHG ASIP",23,0 )
  9748    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)
  9749   "RTN","CHG ASIP",24,0 )
  9750    N CHCLMNU M ;
  9751   "RTN","CHG ASIP",25,0 )
  9752    S CHCLMNU M=$O(^CHMP AY("B",CHC LM,0)),PLZ IP="" ; Ge t pointer  to claim h m 5/17
  9753   "RTN","CHG ASIP",26,0 )
  9754    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
  9755   "RTN","CHG ASIP",27,0 )
  9756    D INP^CHG ASPU
  9757   "RTN","CHG ASIP",28,0 )
  9758    S:CHCMAC= "" CHCMAC= 3
  9759   "RTN","CHG ASIP",29,0 )
  9760    ;
  9761   "RTN","CHG ASIP",30,0 )
  9762   PRINT W !! ,"PDI:  ", CHPDI,"-", CHPDITY,?2 8,"Claim # : ",CHCLM, ?53,"Bene:  ",CHBENE
  9763   "RTN","CHG ASIP",31,0 )
  9764    W !,"Batc h #:  ",CH BATCH,?28, "TOS:  ",C HTOS,?53," Spon: ",CH SPON
  9765   "RTN","CHG ASIP",32,0 )
  9766    W !,"Doc  Id#:  ",CH DOC,?28,"S tatus:  ", CHSTS,?55, "VE: ",CHV E
  9767   "RTN","CHG ASIP",33,0 )
  9768    W !,"Prog ram:  ",CH PROG
  9769   "RTN","CHG ASIP",34,0 )
  9770    W !!,"Dat e in ASQ:  ",$$FMTE^X LFDT(CHDT, "2D"),?28, "Rsn in AS Q: ",CHRSN ,?53,"Mail man #: ",C HMM
  9771   "RTN","CHG ASIP",35,0 )
  9772    W !,"Admi ssion: ",$ $FMTE^XLFD T(CHDOS,"2 D"),?28,"D ischarge:  ",$$FMTE^X LFDT(CHDIS ,"2D"),?53 ,"Dis Stat us: ",CHDS TAT
  9773   "RTN","CHG ASIP",36,0 )
  9774    W !,"Fac  Disch to:  ",CHFAC,?2 8,"Type of  Bill: ",C HTOB,?53," MCCR Revie w: ",CHMCC R
  9775   "RTN","CHG ASIP",37,0 )
  9776    D OHI^CHG ASP
  9777   "RTN","CHG ASIP",38,0 )
  9778    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")
  9779   "RTN","CHG ASIP",39,0 )
  9780    W !,"EDI  Claim: ",C HEDI
  9781   "RTN","CHG ASIP",40,0 )
  9782    I CHOHI'= "" W ?28," OHI Paymt:  ","$ ",$J ($FN(CHOHI ,",",2),9)
  9783   "RTN","CHG ASIP",41,0 )
  9784    E  W ?28, "OHI Paymt : ",CHOHI
  9785   "RTN","CHG ASIP",42,0 )
  9786    I CHOHIPR '="" D   ;  JEH 9/5/0 6 ADDED PA TIENT RESP  LOGIC
  9787   "RTN","CHG ASIP",43,0 )
  9788    .W !,"OHI  PR Bal: " ,"$ ",$J($ FN(CHOHIPR ,",",2),9)  ;MTN01316 3F  EW  BU G ASQ20 2/ 17/13
  9789   "RTN","CHG ASIP",44,0 )
  9790    E  I CHOH I'="" D
  9791   "RTN","CHG ASIP",45,0 )
  9792    .S CHOHIP R=CHAMT-CH OHI
  9793   "RTN","CHG ASIP",46,0 )
  9794    .W !,"OHI  PR Bal: " ,"$ ",$J($ FN(CHOHIPR ,",",2),9)  ; MTN0131 63F  EW  B UG ASQ20 2 /17/13
  9795   "RTN","CHG ASIP",47,0 )
  9796    E  I (CHO HI="")!(CH OHIPR="")  D          ;DGC 3/7/2 013 MTN013 163 ASQWIP  2
  9797   "RTN","CHG ASIP",48,0 )
  9798    .W !,"OHI  PR Bal: "                               ;D GC 3/7/201 3 MTN01316 3 ASQWIP 2
  9799   "RTN","CHG ASIP",49,0 )
  9800    I CHBAMT' ="" W ?53, "Bene Paym t:  ","$ " ,$J($FN(CH BAMT,",",2 ),9)
  9801   "RTN","CHG ASIP",50,0 )
  9802    E  W ?53, "Bene Paym t: ",CHBAM T
  9803   "RTN","CHG ASIP",51,0 )
  9804    W !,"TPL  Paymt: "                                                                                      ;DGC  2/20/2013  MTN013163
  9805   "RTN","CHG ASIP",52,0 )
  9806    I CHSTPLT '="" W "$  ",$J($FN(C HSTPLT,"," ,2),9)                             ;DGC 2/2 0/2013 MTN 013163
  9807   "RTN","CHG ASIP",53,0 )
  9808    W !,"Drg:  ",CHDRG,? 28,"Paymt  Method: ", CHMETH,?53 ,"PCN: ",$ E(CHPCN,1, 20)
  9809   "RTN","CHG ASIP",54,0 )
  9810    ;DEFECT 8 77425 - TG H - 12/4/1 8 Display  PL ZIP onl y if Inpat ient, Outp atient, or  Dental
  9811   "RTN","CHG ASIP",55,0 )
  9812    ;W !,?53, "PL ZIP: " ,PLZIP ; w tc 4/25/17
  9813   "RTN","CHG ASIP",56,0 )
  9814    I (CHTOS[ "INPATIENT "!(CHTOS[" OUTPATIENT ")!(CHTOS[ "DENTAL"))  W !,?53," PL ZIP: ", PLZIP ; wt c 4/25/17
  9815   "RTN","CHG ASIP",57,0 )
  9816    W !!,"Adm itting Dx:  ",CHADXCD ,"-",CHADX
  9817   "RTN","CHG ASIP",58,0 )
  9818    W !!,"Cod e/POA",?12 ,"Descript ion",?55," Total Chg" ,?69,"Tota l AA"   ;D GC 11/1/20 11 MTN0131 63
  9819   "RTN","CHG ASIP",59,0 )
  9820    W !,"---- ---------- ---------- ---------- --------", ?54,"----- ------",?6 8,"------- ----"
  9821   "RTN","CHG ASIP",60,0 )
  9822    D DIAG^CH GASPU
  9823   "RTN","CHG ASIP",61,0 )
  9824    D PROC^CH GASPU
  9825   "RTN","CHG ASIP",62,0 )
  9826    D ITEM^CH GASPU
  9827   "RTN","CHG ASIP",63,0 )
  9828    D NC^CHGA SPU
  9829   "RTN","CHG ASIP",64,0 )
  9830    D ROOM^CH GASPU
  9831   "RTN","CHG ASIP",65,0 )
  9832    W !,?54," ---------- -",?68,"-- ---------"
  9833   "RTN","CHG ASIP",66,0 )
  9834    W !,?44," Totals"
  9835   "RTN","CHG ASIP",67,0 )
  9836    I CHAMT'= "" W ?54,$ J($FN(CHAM T,",",2),1 1)
  9837   "RTN","CHG ASIP",68,0 )
  9838    I CHALW'= "" W ?68,$ J($FN(CHAL W,",",2),1 1)
  9839   "RTN","CHG ASIP",69,0 )
  9840    E  S CHAL W="Und" W  ?68,$J(CHA LW,11)
  9841   "RTN","CHG ASIP",70,0 )
  9842    D REOPEN^ CHGASPU
  9843   "RTN","CHG ASIP",71,0 )
  9844    W !!,"Ben eficiary D ata:"
  9845   "RTN","CHG ASIP",72,0 )
  9846    W !,"DOB:  ",$$FMTE^ XLFDT(CHDO B,"2D"),?1 8,"Age: ", CHAGE,?30, "Sex: ",CH SEX,?50,"S SN: ",CHSS N
  9847   "RTN","CHG ASIP",73,0 )
  9848    W !,"Addr 1: ",CHBAD 1,?50,"Rel ationship:  ",CHREL
  9849   "RTN","CHG ASIP",74,0 )
  9850    W !,"Addr 2: ",CHBAD 2
  9851   "RTN","CHG ASIP",75,0 )
  9852    W !,"City : ",CHBCTY ,?28,"Stat e: ",CHBST ,?50,"Zip:  ",CHBZIP
  9853   "RTN","CHG ASIP",76,0 )
  9854    D WATCHK^ CHGASCOM
  9855   "RTN","CHG ASIP",77,0 )
  9856    W:LNFEED= 1 ! W:LNFE ED=2 !!
  9857   "RTN","CHG ASIP",78,0 )
  9858    I CHTOS'= "INPATIENT " W "Tax I D: ",CHTAX P,?28,"PI:  ",CHAOB,? 40,"Vendor  Page: ",C HVNPG,?59, "CMAC: ",C HCMAC
  9859   "RTN","CHG ASIP",79,0 )
  9860    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
  9861   "RTN","CHG ASIP",80,0 )
  9862    ;W "Tax I D: ",CHTAX P,?28,"PI:  ",CHAOB,? 40,"Vendor  Page: ",C HVNPG,?59, "CMAC: ",C HCMAC
  9863   "RTN","CHG ASIP",81,0 )
  9864    W !,"RT V endor: ",C HVEN,?42," PL Vendor:  ",CHPLVEN
  9865   "RTN","CHG ASIP",82,0 )
  9866    W !,"Addr 1: ",CHRTA D1,?42,"Ad dr1: ",CHV AD1
  9867   "RTN","CHG ASIP",83,0 )
  9868    W !,"Addr 2: ",CHRTA D2,?42,"Ad dr2: ",CHV AD2
  9869   "RTN","CHG ASIP",84,0 )
  9870    W !,"City :  ",CHRTV CTY,?42,"C ity:  ",CH VCTY
  9871   "RTN","CHG ASIP",85,0 )
  9872    W !,"Stat e: ",CHRTV ST,?13,"Zi p: ",CHRTV ZIP,?42,"S tate: ",CH VST,?55,"Z ip: ",CHVZ IP
  9873   "RTN","CHG ASIP",86,0 )
  9874    ; DEFECT  861585 - T GH - 11/27 /18 Correc t PL Zip v ariable
  9875   "RTN","CHG ASIP",87,0 )
  9876    ; AJF ;CP E001-006
  9877   "RTN","CHG ASIP",88,0 )
  9878    ;W !,"PL  Zip: ",CHP LZIP
  9879   "RTN","CHG ASIP",89,0 )
  9880    I (CHTOS[ "INPATIENT "!(CHTOS[" OUTPATIENT ")!(CHTOS[ "DENTAL"))  W !,"PL Z ip: ",PLZI P
  9881   "RTN","CHG ASIP",90,0 )
  9882    I CHMED'= "" D MED^C HGASPU
  9883   "RTN","CHG ASIP",91,0 )
  9884    D ^CHGASQ P
  9885   "RTN","CHG ASIP",92,0 )
  9886    D ^CHGASH IP
  9887   "RTN","CHG ASIP",93,0 )
  9888    D:$D(^CHM CLCOM("B", CHCLM)) CL AIM^CHGASC OM
  9889   "RTN","CHG ASIP",94,0 )
  9890    D:$D(^CHM CLCOM("B", CHPDI)) PD I^CHGASCOM
  9891   "RTN","CHG ASIP",95,0 )
  9892    ;CHECK FO R BENE WAT CH COMMENT S
  9893   "RTN","CHG ASIP",96,0 )
  9894    D BWATCH^ CHGAS17
  9895   "RTN","CHG ASIP",97,0 )
  9896    I $D(CHMW AT) D
  9897   "RTN","CHG ASIP",98,0 )
  9898    .D BENWAT ^CHGASCOM
  9899   "RTN","CHG ASIP",99,0 )
  9900    .S CHDFN= DFN,CHBFN= BFN
  9901   "RTN","CHG ASIP",100, 0)
  9902    .D BNWATC M^CHGASCOM
  9903   "RTN","CHG ASIP",101, 0)
  9904    I $D(BI)  I BI'="" I  $D(WATCOM ("BENWAT", BI)) D
  9905   "RTN","CHG ASIP",102, 0)
  9906    .S BJ=$P( CHMWAT("BE NWAT"),U,2 )
  9907   "RTN","CHG ASIP",103, 0)
  9908    .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
  9909   "RTN","CHG ASIP",104, 0)
  9910    ..F  S BL =$O(WATCOM ("BENWAT", BI,BJ,BK,B L)) Q:'BL   W !,"      ",WATCOM( "BENWAT",B I,BJ,BK,BL )
  9911   "RTN","CHG ASIP",105, 0)
  9912    ;CHECK FO R BENE COM MENTS
  9913   "RTN","CHG ASIP",106, 0)
  9914    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D
  9915   "RTN","CHG ASIP",107, 0)
  9916    .D BENE^C HGASCOM
  9917   "RTN","CHG ASIP",108, 0)
  9918    .S CHDFN= DFN,CHBFN= BFN
  9919   "RTN","CHG ASIP",109, 0)
  9920    .D BENCOM ^CHGASCOM
  9921   "RTN","CHG ASIP",110, 0)
  9922    .D:$D(BEN COM("BEN") )
  9923   "RTN","CHG ASIP",111, 0)
  9924    ..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
  9925   "RTN","CHG ASIP",112, 0)
  9926    ...F  S I 2=$O(BENCO M("BEN",CH DFN,CHBFN, I1,I2)) Q: 'I2  W !,"      ",BEN COM("BEN", CHDFN,CHBF N,I1,I2)
  9927   "RTN","CHG ASIP",113, 0)
  9928    S CHVPT=" "
  9929   "RTN","CHG ASIP",114, 0)
  9930    I CHVEN'= "" I $D(^C HMVEN("B", CHVEN)) D
  9931   "RTN","CHG ASIP",115, 0)
  9932    .S CHVPT= 0
  9933   "RTN","CHG ASIP",116, 0)
  9934    .S CHVPT= $O(^CHMVEN ("B",CHVEN ,CHVPT))
  9935   "RTN","CHG ASIP",117, 0)
  9936    .Q
  9937   "RTN","CHG ASIP",118, 0)
  9938    ;CHECK TO  SEE IF VE NDOR IS ON  WATCH
  9939   "RTN","CHG ASIP",119, 0)
  9940    I CHVPT'= "" I $D(^C HMVEN(CHVP T,20)) D
  9941   "RTN","CHG ASIP",120, 0)
  9942    .D VEND^C HGASCOM
  9943   "RTN","CHG ASIP",121, 0)
  9944    .D VENCOM ^CHGASCOM
  9945   "RTN","CHG ASIP",122, 0)
  9946    I CHVPT'= "" I $D(VE NCOM("VEND ",CHVPT))  D
  9947   "RTN","CHG ASIP",123, 0)
  9948    .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
  9949   "RTN","CHG ASIP",124, 0)
  9950    ..F  S VK =$O(VENCOM ("VEND",CH VPT,VJ,VK) ) Q:'VK  W  !,"     " ,VENCOM("V END",CHVPT ,VJ,VK)
  9951   "RTN","CHG ASIP",125, 0)
  9952    D OHI^CHG ASPU
  9953   "RTN","CHG ASIP",126, 0)
  9954    D PART2^C HGASGOP
  9955   "RTN","CHG ASIP",127, 0)
  9956    Q
  9957   "RTN","CHG ASIP",128, 0)
  9958    ;
  9959   "RTN","CHG ASIP",129, 0)
  9960   NODATA I C HDUZ'="" W  !!!,"THER E ARE NO A CTIVE CLAI MS IN THE  AUDIT SUPP ORT QUEUE  FOR ",CHDZ ,"."
  9961   "RTN","CHG ASIP",130, 0)
  9962    I CHREAS' ="" W !!!, "THERE ARE  NO ACTIVE  ",CHREASN ," IN THE  AUDIT SUPP ORT QUEUE. "
  9963   "RTN","CHG ASIP",131, 0)
  9964   END K REC1 ,REC2,REC3 ,REC4,REC5 ,REC6,REC7 ,REC8,HREC ,CHBENE,CH DOB
  9965   "RTN","CHG ASIP",132, 0)
  9966    K CHSPON, CHREL,CHSS N,CHDOS,CH AOB,CHALL, CHBAMT,CHI D,CHBAD1,C HBAD2,CHBS T
  9967   "RTN","CHG ASIP",133, 0)
  9968    K CHBCTY, CHBZIP,CHV E,CHPDITY, CHBATCH,CH DOC,CHDT,C HSTS,CHRSN ,CHTOS,CHP OS
  9969   "RTN","CHG ASIP",134, 0)
  9970    K CHAMT,C HEDI,CHALW ,CHVEN,CHT AX,CHVNPG, CHCMAC,CHO HIF,CHOHI, CHVAD1,CHV ST,CHOHIPR    ; JEH 9 /5/06 ADDE D CHOHIPR
  9971   "RTN","CHG ASIP",135, 0)
  9972    K CHVAD2, CHVCTY,CHV ZIP,CHMED, CHMAD1,CHM AD2,CHMCTY ,CHMST,CHM ZIP,CHDRG
  9973   "RTN","CHG ASIP",136, 0)
  9974    K CHMETH, CHPSVEN,CH PSTAX,CHPS AD1,CHPSAD 2,CHPSCTY, CHPST,CHPS ZIP,CHDSBE N
  9975   "RTN","CHG ASIP",137, 0)
  9976    K CHDSSN, CHDAD1,CHD AD2,CHDCTY ,CHDST,CHD ZIP,CHDSDO B,CHDSREL, CHNAM,CHTY PE
  9977   "RTN","CHG ASIP",138, 0)
  9978    K CHDIS,C HDSTAT,CHA DX,CHADXCD ,CHFAC,X,C HREC,CHDX, CHDIAG,N,C HRC,CHPROC
  9979   "RTN","CHG ASIP",139, 0)
  9980    K CHDES,C HCHG,CHMOD ,CHPL,CHAL L,CT,CHFLA G,CHFLG1,C HFLG2,CHR, CHIDT,CHIT EM
  9981   "RTN","CHG ASIP",140, 0)
  9982    K CHITAMT ,CHANES,CH ANCST,CHAN ECST,CHPSC D,CHDSC,CN T,CHR1,CHN TEM,CHNAMT
  9983   "RTN","CHG ASIP",141, 0)
  9984    K CHANS,C HPNC,CHDSC R,XX,CHR2, CHRTP,CHRM RT,CHRMDAY ,^TMP($J," WIP")
  9985   "RTN","CHG ASIP",142, 0)
  9986    K PLZIP ;  wtc 5/2/1 7
  9987   "RTN","CHG ASIP",143, 0)
  9988    Q
  9989   "RTN","CHG ASIP",144, 0)
  9990    ;
  9991   "RTN","CHG ASIP",145, 0)
  9992   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  9993   "RTN","CHG ASIP",146, 0)
  9994    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  9995   "RTN","CHG ASIP",147, 0)
  9996    Q
  9997   "RTN","CHG ASIP",148, 0)
  9998   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  9999   "RTN","CHG ASIP",149, 0)
  10000   HEAD W #,D UZ,?33,"CH AMPVA CENT ER",?72,"P age:  ",PG  S PG=PG+1
  10001   "RTN","CHG ASIP",150, 0)
  10002    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
  10003   "RTN","CHG ASIP",151, 0)
  10004    E  W !,TI ME,?25,"Au dit Suppor t Queue WI P Report", !,$E(DT,4, 7),?80-$L( DATE)/2,DA TE
  10005   "RTN","CHG ASIP",152, 0)
  10006    Q
  10007   "RTN","CHG ASP")
  10008   0^8^B86304 290
  10009   "RTN","CHG ASP",1,0)
  10010   CHGASP ;CV A/RLC;ASQ  WIP REPORT  PRINT - P ART 1 ;Feb  05, 2019@ 10:00:01
  10011   "RTN","CHG ASP",2,0)
  10012    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  10013   "RTN","CHG ASP",3,0)
  10014    ;;V2.0;;
  10015   "RTN","CHG ASP",4,0)
  10016    ;PRINTS M AIN BODY O F WIP REPO RT FOR ALL  CLAIMS EX CEPT IN-PA TIENT.
  10017   "RTN","CHG ASP",5,0)
  10018    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 * (RLC), # 12197* (RL C)
  10019   "RTN","CHG ASP",6,0)
  10020    ;CPTS #13 310 (RLC),  #13477 (R LC)
  10021   "RTN","CHG ASP",7,0)
  10022    ;CPTS #16 865 (JBM)  Fixed indi rection
  10023   "RTN","CHG ASP",8,0)
  10024    ;NOIS CP2 -0203-1017 7 (JEH) Fi xed bene c omments pr inting for  all claim s
  10025   "RTN","CHG ASP",9,0)
  10026    ;MC284 JE H 9/5/06 C hange OHI  Paid amoun t to Patie nt Respons ibility
  10027   "RTN","CHG ASP",10,0)
  10028    ;DEV00782 0 03/15/20 11 DGC SLL A project
  10029   "RTN","CHG ASP",11,0)
  10030    ;MTN01316 3 10/13/20 11 DGC SLL A PROJECT
  10031   "RTN","CHG ASP",12,0)
  10032    ;CPE001-0 08 6/19/20 17 WTC CCS E
  10033   "RTN","CHG ASP",13,0)
  10034    ;DEFECT 8 77425 - TG H- 12/6/18  - Print P L ZIP only  if TOS is  Inpatient , Outpatie nt, or Den tal
  10035   "RTN","CHG ASP",14,0)
  10036    S X=DT D  DTPRT S DA TE=Y,PG=1, X=$P($H,", ",2),H=X\3 600,M=X#36 00\60
  10037   "RTN","CHG ASP",15,0)
  10038    S:M<10 M= 0_M S:H<10  H=0_H S T IME=H_M
  10039   "RTN","CHG ASP",16,0)
  10040    ;
  10041   "RTN","CHG ASP",17,0)
  10042    I CHCNT=0  D HEAD G  NODATA
  10043   "RTN","CHG ASP",18,0)
  10044    S CHPDI=" ",U="^"
  10045   "RTN","CHG ASP",19,0)
  10046   A1 S CHPDI =$O(^TMP($ J,"WIP",CH PDI)) G:CH PDI="" END
  10047   "RTN","CHG ASP",20,0)
  10048    S CHPROG= ""
  10049   "RTN","CHG ASP",21,0)
  10050   A2 S CHPRO G=$O(^TMP( $J,"WIP",C HPDI,CHPRO G)) G:CHPR OG="" A1
  10051   "RTN","CHG ASP",22,0)
  10052    S CHCLM=" "
  10053   "RTN","CHG ASP",23,0)
  10054   A3 S CHCLM =$O(^TMP($ J,"WIP",CH PDI,CHPROG ,CHCLM)) G :CHCLM=""  A2
  10055   "RTN","CHG ASP",24,0)
  10056    S REC1=^( CHCLM,1)
  10057   "RTN","CHG ASP",25,0)
  10058    S U="^"
  10059   "RTN","CHG ASP",26,0)
  10060    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)
  10061   "RTN","CHG ASP",27,0)
  10062    S REC5=^T MP($J,"WIP ",CHPDI,CH PROG,CHCLM ,5),REC6=^ TMP($J,"WI P",CHPDI,C HPROG,CHCL M,6)
  10063   "RTN","CHG ASP",28,0)
  10064    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)
  10065   "RTN","CHG ASP",29,0)
  10066    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)
  10067   "RTN","CHG ASP",30,0)
  10068    S XDOS=""  S:CHDOS'= "" XDOS=CH DOS
  10069   "RTN","CHG ASP",31,0)
  10070    I CHTY=1  D ^CHGASIP  G A3
  10071   "RTN","CHG ASP",32,0)
  10072    ;
  10073   "RTN","CHG ASP",33,0)
  10074    D HEAD
  10075   "RTN","CHG ASP",34,0)
  10076    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
  10077   "RTN","CHG ASP",35,0)
  10078    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)
  10079   "RTN","CHG ASP",36,0)
  10080    ;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)
  10081   "RTN","CHG ASP",37,0)
  10082    ;CJM LINE  LENGTH FO R MIGRATIO N R1 20170 719
  10083   "RTN","CHG ASP",38,0)
  10084    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)
  10085   "RTN","CHG ASP",39,0)
  10086    S CHVZIP= $P(REC4,U, 11),CHPLVE N=$P(REC4, U,12),CHTO PRB=$P(REC 4,U,13)    ; JEH 9/5/ 06
  10087   "RTN","CHG ASP",40,0)
  10088    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)
  10089   "RTN","CHG ASP",41,0)
  10090    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)
  10091   "RTN","CHG ASP",42,0)
  10092    S:CHCMAC= "" CHCMAC= 3
  10093   "RTN","CHG ASP",43,0)
  10094    S CHVEN=$ E(CHVEN,1, 25)
  10095   "RTN","CHG ASP",44,0)
  10096    ;
  10097   "RTN","CHG ASP",45,0)
  10098   PRINT W !! ,"PDI:  ", CHPDI,"-", CHPDITY,?2 8,"Claim # : ",CHCLM, ?53,"Bene:  ",CHBENE
  10099   "RTN","CHG ASP",46,0)
  10100    W !,"Batc h #:  ",CH BATCH,?28, "TOS:  ",C HTOS,?53," Spon: ",CH SPON
  10101   "RTN","CHG ASP",47,0)
  10102    W !,"Doc  Id#:  ",CH DOC,?28,"S tatus:  ", CHSTS,?55, "VE: ",CHV E
  10103   "RTN","CHG ASP",48,0)
  10104    W !,"Prog ram:  ",CH PROG
  10105   "RTN","CHG ASP",49,0)
  10106    W !!,"Dat e in ASQ:  ",$$FMTE^X LFDT(CHDT, "2D"),?28, "Rsn in AS Q: ",CHRSN ,?53,"Mail man #: ",C HMM
  10107   "RTN","CHG ASP",50,0)
  10108    W !,"DOS:  ",$$FMTE^ XLFDT(CHDO S,"2D"),?2 8,"POS:  " ,CHPOS,?53 ,"EDI Clai m: ",CHEDI
  10109   "RTN","CHG ASP",51,0)
  10110    W !,"MCCR  Review: " ,CHMCCR,?2 8,"Type of  Bill: ",C HTOB,?53," PCN: ",$E( CHPCN,1,20 )
  10111   "RTN","CHG ASP",52,0)
  10112    D OHI
  10113   "RTN","CHG ASP",53,0)
  10114    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")
  10115   "RTN","CHG ASP",54,0)
  10116    I CHOHI'= "" W !,"OH I Paymt:   ","$ ",$J( $FN(CHOHI, ",",2),9)
  10117   "RTN","CHG ASP",55,0)
  10118    E  W !,"O HI Paymt:   ",CHOHI
  10119   "RTN","CHG ASP",56,0)
  10120    I CHTOPRB '="" D   ;  JEH 9/5/0 6 ADDED PA TIENT RESP  LOGIC
  10121   "RTN","CHG ASP",57,0)
  10122    .W !,"OHI  PR BAL: " ,"$ ",$J($ FN(CHTOPRB ,",",2),9)  ;DGC 8/10 /2011 DEV0 07820
  10123   "RTN","CHG ASP",58,0)
  10124    E  I CHOH I'="" D
  10125   "RTN","CHG ASP",59,0)
  10126    .S CHTOPR B=CHAMT-CH OHI
  10127   "RTN","CHG ASP",60,0)
  10128    .W !,"OHI  PR BAL: " ,"$ ",$J($ FN(CHTOPRB ,",",2),9)  ;DGC 8/10 /2011 DEV0 07820
  10129   "RTN","CHG ASP",61,0)
  10130    I CHBAMT' ="" W ?28, "Bene Paym t:  ","$ " ,$J($FN(CH BAMT,",",2 ),9)
  10131   "RTN","CHG ASP",62,0)
  10132    E  W ?28, "Bene Paym t: ",CHBAM T
  10133   "RTN","CHG ASP",63,0)
  10134    I CHSTPLT '="" W ?53 ,"TPL Paym t: ","$ ", $J($FN(CHS TPLT,",",2 ),10)  ;DG C 03/15/11  DEV007820
  10135   "RTN","CHG ASP",64,0)
  10136    E  W ?53, "TPL Paymt : "                         ;DGC  03/15/11  DEV007820
  10137   "RTN","CHG ASP",65,0)
  10138    I CHSPOP' ="" W !,?8 ,"POP: ",C HSPOP            ;DGC  10/25/201 1 MTN01316 3
  10139   "RTN","CHG ASP",66,0)
  10140    ;
  10141   "RTN","CHG ASP",67,0)
  10142    ;  Extrac t PL ZIP f rom Claim  file and d isplay.  w tc 6/19/17
  10143   "RTN","CHG ASP",68,0)
  10144    ;
  10145   "RTN","CHG ASP",69,0)
  10146    S CHCLMNU M=$O(^CHMP AY("B",CHC LM,0)) ;
  10147   "RTN","CHG ASP",70,0)
  10148    ;DEFECT 8 77425 - TG H- 12/6/18  - Print P L ZIP only  if TOS is  Inpatient , Outpatie nt, or Den tal
  10149   "RTN","CHG ASP",71,0)
  10150    ;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
  10151   "RTN","CHG ASP",72,0)
  10152    I CHCLMNU M'="" I (C HTOS["INPA TIENT"!(CH TOS["OUTPA TIENT")!(C HTOS["DENT AL")) D
  10153   "RTN","CHG ASP",73,0)
  10154    . S PLZIP =$P($G(^CH MPAY(CHCLM NUM,"VEN-I I")),"^",1 5) W !?53, "PL ZIP: " ,PLZIP ; W TC 5/19/17
  10155   "RTN","CHG ASP",74,0)
  10156    D COLHEAD
  10157   "RTN","CHG ASP",75,0)
  10158    D DIAG^CH GASPU
  10159   "RTN","CHG ASP",76,0)
  10160    D PROC^CH GASPU
  10161   "RTN","CHG ASP",77,0)
  10162    D DMESUP^ CHGASPU
  10163   "RTN","CHG ASP",78,0)
  10164    D DME^CHG ASPU
  10165   "RTN","CHG ASP",79,0)
  10166    D PHARM^C HGASPU
  10167   "RTN","CHG ASP",80,0)
  10168    ;W !,?56, "--------- --",?68,"- ---------- "  DGC 03/ 15/11 DEV0 07820 BEGI N
  10169   "RTN","CHG ASP",81,0)
  10170    S DC1="-"  W "Totals " F DC2=8: 1:80 W ?DC 2,DC1
  10171   "RTN","CHG ASP",82,0)
  10172    I CHAMT'= "" W !,?47 ,$J($FN(CH AMT,",",2) ,10)
  10173   "RTN","CHG ASP",83,0)
  10174    E  W !
  10175   "RTN","CHG ASP",84,0)
  10176    I CHTOPD' =0 W ?59,$ J($FN(CHTO PD,",",2), 10)
  10177   "RTN","CHG ASP",85,0)
  10178    I CHTOPR' =0 W ?70,$ J($FN(CHTO PR,",",2), 10) ;DGC 1 0/24/2011  MTN013163
  10179   "RTN","CHG ASP",86,0)
  10180    I CHTMEDP '=0 W !,$J ($FN(CHTME DP,",",2), 10)
  10181   "RTN","CHG ASP",87,0)
  10182    E  W !
  10183   "RTN","CHG ASP",88,0)
  10184    I CHALW'= "" W ?47,$ J($FN(CHAL W,",",2),1 0)
  10185   "RTN","CHG ASP",89,0)
  10186    ;E  S CHA LW="Und" W  ?47,$J(CH ALW,10)
  10187   "RTN","CHG ASP",90,0)
  10188    I CHTOHI' =0 W ?59,$ J($FN(CHTO HI,",",2), 10)
  10189   "RTN","CHG ASP",91,0)
  10190    I CHTOPB' =0 W ?70,$ J($FN(CHTO PB,",",2), 10) ;DGC 1 0/24/2011  MTN013163
  10191   "RTN","CHG ASP",92,0)
  10192    ;DGC 03/1 5/11 DEV00 7820 END
  10193   "RTN","CHG ASP",93,0)
  10194    D REOPEN^ CHGASPU
  10195   "RTN","CHG ASP",94,0)
  10196    W !!,"Ben eficiary D ata:"
  10197   "RTN","CHG ASP",95,0)
  10198    W !,"DOB:  ",$$FMTE^ XLFDT(CHDO B,"2D"),?1 8,"Age: ", CHAGE,?30, "Sex: ",CH SEX,?50,"S SN: ",CHSS N
  10199   "RTN","CHG ASP",96,0)
  10200    W !,"Addr 1: ",CHBAD 1,?50,"Rel ationship:  ",CHREL
  10201   "RTN","CHG ASP",97,0)
  10202    W !,"Addr 2: ",CHBAD 2
  10203   "RTN","CHG ASP",98,0)
  10204    W !,"City : ",CHBCTY ,?28,"Stat e: ",CHBST ,?50,"Zip:  ",CHBZIP
  10205   "RTN","CHG ASP",99,0)
  10206    D WATCHK^ CHGASCOM
  10207   "RTN","CHG ASP",100,0 )
  10208    W:LNFEED= 1 ! W:LNFE ED=2 !!
  10209   "RTN","CHG ASP",101,0 )
  10210    W "Tax ID : ",CHTAXP ,?28,"PI:  ",CHAOB,?4 0,"Vendor  Page: ",CH VNPG,?59," CMAC: ",CH CMAC
  10211   "RTN","CHG ASP",102,0 )
  10212    W !,"RT V endor: ",C HVEN,?42," PL Vendor:  ",CHPLVEN
  10213   "RTN","CHG ASP",103,0 )
  10214    W !,"Addr 1: ",CHRTA D1,?42,"Ad dr1: ",CHV AD1
  10215   "RTN","CHG ASP",104,0 )
  10216    W !,"Addr 2: ",CHRTA D2,?42,"Ad dr2: ",CHV AD2
  10217   "RTN","CHG ASP",105,0 )
  10218    W !,"City :  ",CHRTV CTY,?42,"C ity:  ",CH VCTY
  10219   "RTN","CHG ASP",106,0 )
  10220    W !,"Stat e: ",CHRTV ST,?13,"Zi p: ",CHRTV ZIP,?42,"S tate: ",CH VST,?55,"Z ip: ",CHVZ IP
  10221   "RTN","CHG ASP",107,0 )
  10222    I CHMED'= "" D MED^C HGASPU
  10223   "RTN","CHG ASP",108,0 )
  10224    D ^CHGASQ P
  10225   "RTN","CHG ASP",109,0 )
  10226    D ^CHGASH SP
  10227   "RTN","CHG ASP",110,0 )
  10228    ;CHECK FO R CLAIM AN D PDI COMM ENTS
  10229   "RTN","CHG ASP",111,0 )
  10230    I $D(^CHM CLCOM("B", CHCLM)) D  CLAIM^CHGA SCOM
  10231   "RTN","CHG ASP",112,0 )
  10232    I $D(^CHM CLCOM("B", CHPDI)) D  PDI^CHGASC OM
  10233   "RTN","CHG ASP",113,0 )
  10234    ;CHECK FO R BENE COM MENTS
  10235   "RTN","CHG ASP",114,0 )
  10236    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D
  10237   "RTN","CHG ASP",115,0 )
  10238    .D BENE^C HGASCOM
  10239   "RTN","CHG ASP",116,0 )
  10240    .S CHDFN= DFN,CHBFN= BFN
  10241   "RTN","CHG ASP",117,0 )
  10242    .D BENCOM ^CHGASCOM
  10243   "RTN","CHG ASP",118,0 )
  10244    .D:$D(BEN COM("BEN") )
  10245   "RTN","CHG ASP",119,0 )
  10246    ..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
  10247   "RTN","CHG ASP",120,0 )
  10248    ...F  S I 2=$O(BENCO M("BEN",CH DFN,CHBFN, I1,I2)) Q: 'I2  W !,"      ",BEN COM("BEN", CHDFN,CHBF N,I1,I2)
  10249   "RTN","CHG ASP",121,0 )
  10250    ;CHECK FO R BENE WAT CH COMMENT S
  10251   "RTN","CHG ASP",122,0 )
  10252    D BWATCH^ CHGAS17
  10253   "RTN","CHG ASP",123,0 )
  10254    I $D(CHMW AT) D
  10255   "RTN","CHG ASP",124,0 )
  10256    .D BENWAT ^CHGASCOM
  10257   "RTN","CHG ASP",125,0 )
  10258    .S CHDFN= DFN,CHBFN= BFN
  10259   "RTN","CHG ASP",126,0 )
  10260    .D BNWATC M^CHGASCOM
  10261   "RTN","CHG ASP",127,0 )
  10262    I $D(BI)  I BI'="" I  $D(WATCOM ("BENWAT", BI)) D
  10263   "RTN","CHG ASP",128,0 )
  10264    .S BJ=$P( CHMWAT("BE NWAT"),U,2 )
  10265   "RTN","CHG ASP",129,0 )
  10266    .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
  10267   "RTN","CHG ASP",130,0 )
  10268    ..F  S BL =$O(WATCOM ("BENWAT", BI,BJ,BK,B L)) Q:'BL   W !,"      ",WATCOM( "BENWAT",B I,BJ,BK,BL )
  10269   "RTN","CHG ASP",131,0 )
  10270    S CHVPT=" "
  10271   "RTN","CHG ASP",132,0 )
  10272    I CHVEN'= "" I $D(^C HMVEN("B", CHVEN)) D
  10273   "RTN","CHG ASP",133,0 )
  10274    .S CHVPT= 0
  10275   "RTN","CHG ASP",134,0 )
  10276    .S CHVPT= $O(^CHMVEN ("B",CHVEN ,CHVPT))
  10277   "RTN","CHG ASP",135,0 )
  10278    .Q
  10279   "RTN","CHG ASP",136,0 )
  10280    ;CHECK TO  SEE IF VE NDOR IS ON  WATCH
  10281   "RTN","CHG ASP",137,0 )
  10282    I CHVPT'= "" I $D(^C HMVEN(CHVP T,20)) D
  10283   "RTN","CHG ASP",138,0 )
  10284    .D VEND^C HGASCOM
  10285   "RTN","CHG ASP",139,0 )
  10286    .D VENCOM ^CHGASCOM
  10287   "RTN","CHG ASP",140,0 )
  10288    I CHVPT'= "" I $D(VE NCOM("VEND ",CHVPT))  D
  10289   "RTN","CHG ASP",141,0 )
  10290    .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
  10291   "RTN","CHG ASP",142,0 )
  10292    ..F  S VK =$O(VENCOM ("VEND",CH VPT,VJ,VK) ) Q:'VK  W  !,"     " ,VENCOM("V END",CHVPT ,VJ,VK)
  10293   "RTN","CHG ASP",143,0 )
  10294    D OHI^CHG ASPU
  10295   "RTN","CHG ASP",144,0 )
  10296    D PART2^C HGASGOP
  10297   "RTN","CHG ASP",145,0 )
  10298    G A3
  10299   "RTN","CHG ASP",146,0 )
  10300    ;
  10301   "RTN","CHG ASP",147,0 )
  10302   NODATA W ! !!,"THERE  ARE NO ACT IVE CLAIMS  IN THE AU DIT SUPPOR T QUEUE FO R ",CHDZ," ."
  10303   "RTN","CHG ASP",148,0 )
  10304    I CHREAS' ="" W !!!, "THERE ARE  NO ACTIVE  ",CHREASN ," IN THE  AUDIT SUPP ORT QUEUE. "
  10305   "RTN","CHG ASP",149,0 )
  10306   END K CHAC C,CHALL,CH ALW,CHAMT, CHAOB,CHAR GE,CHBAD1, CHBAD2,CHB AMT,CHBAT, CHBCTY
  10307   "RTN","CHG ASP",150,0 )
  10308    K CHBATCH ,CHBENE,CH BST,CHBZIP ,CHCHG,CHC LN,CHCMAC, CHCNT,CHDA D1,CHDAD2
  10309   "RTN","CHG ASP",151,0 )
  10310    K CHDC,CH DCTY,CHDES ,CHDIAG,CH DOB,CHDOC, CHDOS,CHDR G,CHDRUG,C HDSBEN,CHD X
  10311   "RTN","CHG ASP",152,0 )
  10312    K CHDSDOB ,CHDSREL,C HDSSN,CHDS T,CHDT,CHD UZ,CHDZ,CH DZIP,CHEDI ,CHID,CHMO D
  10313   "RTN","CHG ASP",153,0 )
  10314    K CHMAD1, CHMAD2,CHM AMT,CHMCTY ,CHMED,CHM ETH,CHMMAC ,CHMST,CHM TAX,CHMZIP
  10315   "RTN","CHG ASP",154,0 )
  10316    K CHNAM,C HNDC,CHOHI ,CHOHIF,CH PDITY,CHPL ,CHPOS,CHP ROC,CHPSAD 1,CHPSAD2, CHTOPRB    ; JEH 9/5/ 06 ADDED C HTOPRB
  10317   "RTN","CHG ASP",155,0 )
  10318    K CHPSCTY ,CHPST,CHP STAX,CHPSV EN,CHPSZIP ,CHRC,CHRC 1,CHREAS,C HREASN,CHR EC
  10319   "RTN","CHG ASP",156,0 )
  10320    K CHREL,C HRSN,CHSPO N,CHSSN,CH STS,CHTAX, CHTOS,CHTY PE,CHVAD1, CHVAD2
  10321   "RTN","CHG ASP",157,0 )
  10322    K CHVCTY, CHVE,CHVEN ,CHVNPG,CH VST,CHVZIP ,FLG,HREC, J,M,N,PG,R EC1
  10323   "RTN","CHG ASP",158,0 )
  10324    K REC2,RE C3,REC4,RE C5,REC6,RE C7,X,Y,ZZ  ;,^TMP($J, "WIP")
  10325   "RTN","CHG ASP",159,0 )
  10326    K CHCLMNU M,PLZIP ;  WTC 6/19/1 7
  10327   "RTN","CHG ASP",160,0 )
  10328    Q
  10329   "RTN","CHG ASP",161,0 )
  10330    ;
  10331   "RTN","CHG ASP",162,0 )
  10332   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  10333   "RTN","CHG ASP",163,0 )
  10334    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  10335   "RTN","CHG ASP",164,0 )
  10336    Q
  10337   "RTN","CHG ASP",165,0 )
  10338   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  10339   "RTN","CHG ASP",166,0 )
  10340   HEAD W #,D UZ,?33,"CH AMPVA CENT ER",?72,"P age:  ",PG  S PG=PG+1
  10341   "RTN","CHG ASP",167,0 )
  10342    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
  10343   "RTN","CHG ASP",168,0 )
  10344    E  W !,TI ME,?25,"Au dit Suppor t Queue WI P Report", !,$E(DT,4, 7),?80-$L( DATE)/2,DA TE
  10345   "RTN","CHG ASP",169,0 )
  10346    Q
  10347   "RTN","CHG ASP",170,0 )
  10348   COLHEAD ;K KAEILL  ;D GC 6/05/11  MTN013163  Begin
  10349   "RTN","CHG ASP",171,0 )
  10350    I CHTY=4  D  Q
  10351   "RTN","CHG ASP",172,0 )
  10352    .W !!,"Co de",?18,"D escription ",?47,"Tot al Chg",?5 9,"OHI #1  PD",?70,"O HI #1 PR"
  10353   "RTN","CHG ASP",173,0 )
  10354    .W !,"Mca id",?18,"U nt/Qty",?2 7,"AlwUnt" ,?33,?47," Total AA", ?59,"Addl  OHI",?70," OHI PR Bal "
  10355   "RTN","CHG ASP",174,0 )
  10356    .W !,"--- ---------- ---------- ---------- ---------- ---",?47," ---------- ",?59,"--- -------",? 70,"------ ----"
  10357   "RTN","CHG ASP",175,0 )
  10358    .Q
  10359   "RTN","CHG ASP",176,0 )
  10360    I CHTY=3  D RXCOL Q
  10361   "RTN","CHG ASP",177,0 )
  10362    W !!,"Cod e",?18,"De scription" ,?47,"Tota l Chg",?59 ,"OHI #1 P D",?70,"OH I #1 PR"
  10363   "RTN","CHG ASP",178,0 )
  10364    W !,"Mcai d",?18,"Un t/Qty",?27 ,"AlwUnt", ?47,"Total  AA",?59," Addl OHI", ?70,"OHI P R Bal"
  10365   "RTN","CHG ASP",179,0 )
  10366    W !,"---- ---------- ---------- ---------- ---------- --",?47,"- ---------" ,?59,"---- ------",?7 0,"------- ---"
  10367   "RTN","CHG ASP",180,0 )
  10368    Q
  10369   "RTN","CHG ASP",181,0 )
  10370   RXCOL I CH PROG'="SPI NA BIFIDA"  D  Q
  10371   "RTN","CHG ASP",182,0 )
  10372    .W !!,"Co de",?18,"D escription ",?47,"Tot al Chg",?5 9,"OHI #1  PD",?70,"O HI #1 PR"
  10373   "RTN","CHG ASP",183,0 )
  10374    .W !,"Mca id",?18,"U nt/Qty",?2 7,"AlwUnt" ,?47,"Tota l AA",?59, "Addl OHI" ,?70,"OHI  PR Bal"
  10375   "RTN","CHG ASP",184,0 )
  10376    .W !,"--- ---------- ---------- ---------- ---------- ---",?47," ---------- ",?59,"--- -------",? 70,"------ ----"
  10377   "RTN","CHG ASP",185,0 )
  10378    I CHPROG= "SPINA BIF IDA" D  Q
  10379   "RTN","CHG ASP",186,0 )
  10380    .W !!,"Co de",?18,"D escription ",?39,"DX  Code",?47, "Total Chg ",?59,"OHI  #1 PD",?7 0,"OHI #1  PR"
  10381   "RTN","CHG ASP",187,0 )
  10382    .W !,"Mca id",?18,"U nt/Qty",?2 7,"AlwUnt" ,?47,"Tota l AA",?59, "Addl OHI" ,?70,"OHI  PR Bal"
  10383   "RTN","CHG ASP",188,0 )
  10384    .W !,"--- ---------- ---------- ---------- ------",?3 6,"------- ",?47,"--- -------",? 59,"------ ----",?70, "--------- -"
  10385   "RTN","CHG ASP",189,0 )
  10386    Q
  10387   "RTN","CHG ASP",190,0 )
  10388    ;DGC 6/05 /11 MTN013 163 End
  10389   "RTN","CHG ASP",191,0 )
  10390   OHI S I1=0
  10391   "RTN","CHG ASP",192,0 )
  10392    S (CHOHBP ,CHOHEP,CH OH,CHOHTP) =""
  10393   "RTN","CHG ASP",193,0 )
  10394   O1 S I1=$O (@(GLDFN_" ""B"",DFN, I1)")) Q:' I1
  10395   "RTN","CHG ASP",194,0 )
  10396    G:'$D(@(G LDFN_"I1,1 00)")) O1
  10397   "RTN","CHG ASP",195,0 )
  10398    S J1=0
  10399   "RTN","CHG ASP",196,0 )
  10400   O2 S J1=$O (@(GLDFN_" I1,100,""B "",BFN,J1) ")) G:'J1  O1
  10401   "RTN","CHG ASP",197,0 )
  10402    G:'$D(@(G LDFN_"I1,1 00,J1,2)") ) O2
  10403   "RTN","CHG ASP",198,0 )
  10404    S K1=XDOS
  10405   "RTN","CHG ASP",199,0 )
  10406   O3 S K1=$O (@(GLDFN_" I1,100,J1, 2,""B"",K1 )"),-1) G: 'K1 O2
  10407   "RTN","CHG ASP",200,0 )
  10408    S K2=0
  10409   "RTN","CHG ASP",201,0 )
  10410   O4 S K2=$O (@(GLDFN_" I1,100,J1, 2,""B"",K1 ,K2)")) G: 'K2 O3
  10411   "RTN","CHG ASP",202,0 )
  10412    G:'$D(@(G LDFN_"I1,1 00,J1,2,K2 ,0)")) O4
  10413   "RTN","CHG ASP",203,0 )
  10414    S RC=@(GL DFN_"I1,10 0,J1,2,K2, 0)")
  10415   "RTN","CHG ASP",204,0 )
  10416    S CHOHBP= $P(RC,U,1) ,CHOHEP=$P (RC,U,2),C HOH=$P(RC, U,3)
  10417   "RTN","CHG ASP",205,0 )
  10418    S CHOHTP= "NO OHI"
  10419   "RTN","CHG ASP",206,0 )
  10420    I CHOH I  $D(^CHMDIC (741002.76 ,CHOH,0))  S CHOHTP=$ P(^(0),"^" ,1)
  10421   "RTN","CHG ASP",207,0 )
  10422    ;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 :"")
  10423   "RTN","CHG ASP",208,0 )
  10424    Q
  10425   "RTN","CHG ASP1")
  10426   0^25^B4051 7172
  10427   "RTN","CHG ASP1",1,0)
  10428   CHGASP1 ;C VA/RLC;ASQ  WIP REPOR T PRINT -  PART 1 ;Fe b 05, 2019 @10:32:56
  10429   "RTN","CHG ASP1",2,0)
  10430    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  10431   "RTN","CHG ASP1",3,0)
  10432    ;;V1.0;;
  10433   "RTN","CHG ASP1",4,0)
  10434    ;PRINTS M AIN BODY O F WIP REPO RT FOR ALL  CLAIMS EX CEPT IN-PA TIENT.
  10435   "RTN","CHG ASP1",5,0)
  10436    ;CALLS RO UTINE ^CHG ASP2 TO PR INT IN-PAT IENT CLAIM S.
  10437   "RTN","CHG ASP1",6,0)
  10438    ;MC284 JE H 9/5/06 C hange OHI  Paid amoun t to Patie nt Respons ibility
  10439   "RTN","CHG ASP1",7,0)
  10440    ;CPE001-0 08 6/19/20 17 WTC CCS E
  10441   "RTN","CHG ASP1",8,0)
  10442    ;DEFECT 8 77425 - TG H- 12/6/18  - Print P L ZIP only  if TOS is  Inpatient , Outpatie nt, or Den tal
  10443   "RTN","CHG ASP1",9,0)
  10444    S X=DT D  DTPRT S DA TE=Y,PG=1, X=$P($H,", ",2),H=X\3 600,M=X#36 00\60
  10445   "RTN","CHG ASP1",10,0 )
  10446    S:M<10 M= 0_M S:H<10  H=0_M S T IME=H_M
  10447   "RTN","CHG ASP1",11,0 )
  10448    ;
  10449   "RTN","CHG ASP1",12,0 )
  10450    I CHCNT=0  D HEAD,NO DATA G END
  10451   "RTN","CHG ASP1",13,0 )
  10452    S CHPDI=" ",U="^"
  10453   "RTN","CHG ASP1",14,0 )
  10454   A1 S CHPDI =$O(^TMP($ J,"WIP",CH PDI)) G:CH PDI="" END
  10455   "RTN","CHG ASP1",15,0 )
  10456    S CHCLM=" "
  10457   "RTN","CHG ASP1",16,0 )
  10458   A2 S CHCLM =$O(^TMP($ J,"WIP",CH PDI,CHCLM) ) G:CHCLM= "" A1
  10459   "RTN","CHG ASP1",17,0 )
  10460    I CHTY=1  D ^CHGASP2  G A2
  10461   "RTN","CHG ASP1",18,0 )
  10462    S REC1=^( CHCLM,1) D  HEAD
  10463   "RTN","CHG ASP1",19,0 )
  10464    S U="^"
  10465   "RTN","CHG ASP1",20,0 )
  10466    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)
  10467   "RTN","CHG ASP1",21,0 )
  10468    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)
  10469   "RTN","CHG ASP1",22,0 )
  10470    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)
  10471   "RTN","CHG ASP1",23,0 )
  10472    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)
  10473   "RTN","CHG ASP1",24,0 )
  10474    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)
  10475   "RTN","CHG ASP1",25,0 )
  10476    ;CJM LINE  LENGTH FO R MIGRATIO N R1 20170 719
  10477   "RTN","CHG ASP1",26,0 )
  10478    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)
  10479   "RTN","CHG ASP1",27,0 )
  10480    S CHVST=$ P(REC4,U,1 0),CHVZIP= $P(REC4,U, 11),CHOHIP R=$P(REC4, U,13)   ;  JEH 9/5/06
  10481   "RTN","CHG ASP1",28,0 )
  10482    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)
  10483   "RTN","CHG ASP1",29,0 )
  10484    S CHOHT=$ P(REC6,U,1 ),CHOHB=$P (REC6,U,2) ,CHOHE=$P( REC6,U,3)
  10485   "RTN","CHG ASP1",30,0 )
  10486    S:CHCMAC= "" CHCMAC= 3
  10487   "RTN","CHG ASP1",31,0 )
  10488    S CHVEN=$ E(CHVEN,1, 25)
  10489   "RTN","CHG ASP1",32,0 )
  10490    ;
  10491   "RTN","CHG ASP1",33,0 )
  10492   PRINT W !! ,"PDI:  ", CHPDI,"-", CHPDITY,?2 8,"Claim # : ",CHCLM, ?53,"Bene:  ",CHBENE
  10493   "RTN","CHG ASP1",34,0 )
  10494    W !,"Batc h #:  ",CH BATCH,?28, "TOS:  ",C HTOS,?53," Spon: ",CH SPON
  10495   "RTN","CHG ASP1",35,0 )
  10496    W !,"Doc  Id#:  ",CH DOC,?28,"S tatus:  ", CHSTS,?55, "VE: ",CHV E
  10497   "RTN","CHG ASP1",36,0 )
  10498    W !!,"Dat e in ASQ:  ",$$FMTE^X LFDT(CHDT, "2D"),?28, "Rsn in AS Q: ",CHRSN ,?53,"Mail man #: ",C HMM
  10499   "RTN","CHG ASP1",37,0 )
  10500    W !,"DOS:  ",$$FMTE^ XLFDT(CHDO S,"2D"),?2 8,"POS:  " ,CHPOS,?53 ,"EDI Clai m: ",CHEDI
  10501   "RTN","CHG ASP1",38,0 )
  10502    W !,"Inj/ Acc: ",CHA CC,?28,"MC CR Review:  ",CHMCCR
  10503   "RTN","CHG ASP1",39,0 )
  10504    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")
  10505   "RTN","CHG ASP1",40,0 )
  10506    I CHOHI'= "" W !,"OH I Paymt:   ","$ ",$J( $FN(CHOHI, ",",2),9)
  10507   "RTN","CHG ASP1",41,0 )
  10508    E  W !,"O HI Paymt:   ",CHOHI
  10509   "RTN","CHG ASP1",42,0 )
  10510    I CHOHIPR '="" D   ;  JEH 9/5/0 6 ADDED PA TIENT RESP  LOGIC
  10511   "RTN","CHG ASP1",43,0 )
  10512    .W !,"OHI  PR Bal: " ,"$ ",$J($ FN(CHOHIPR ,",",2),9)  ; MTN0131 63F  EW  B UG ASQ20 2 /17/13
  10513   "RTN","CHG ASP1",44,0 )
  10514    E  D
  10515   "RTN","CHG ASP1",45,0 )
  10516    .S CHOHIP R=CHAMT-CH OHI
  10517   "RTN","CHG ASP1",46,0 )
  10518    .W !,"OHI  PR Bal: " ,"$ ",$J($ FN(CHOHIPR ,",",2),9)  ; MTN0131 63F  EW  B UG ASQ20 2 /17/13
  10519   "RTN","CHG ASP1",47,0 )
  10520    I CHBAMT' ="" W ?28, "Bene Paym t:  ","$ " ,$J($FN(CH BAMT,",",2 ),9)
  10521   "RTN","CHG ASP1",48,0 )
  10522    E  W ?28, "Bene Paym t: ",CHBAM T
  10523   "RTN","CHG ASP1",49,0 )
  10524    ;
  10525   "RTN","CHG ASP1",50,0 )
  10526    ;  Extrac t PL ZIP f rom Claim  file and d isplay.  w tc 6/19/17
  10527   "RTN","CHG ASP1",51,0 )
  10528    ;
  10529   "RTN","CHG ASP1",52,0 )
  10530    S CHCLMNU M=$O(^CHMP AY("B",CHC LM,0)) ;
  10531   "RTN","CHG ASP1",53,0 )
  10532    ;DEFECT 8 77425 - TG H- 12/6/18  - Print P L ZIP only  if TOS is  Inpatient , Outpatie nt, or Den tal
  10533   "RTN","CHG ASP1",54,0 )
  10534    ;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
  10535   "RTN","CHG ASP1",55,0 )
  10536    I CHCLMNU M'="" I (C HTOS["INPA TIENT"!(CH TOS["OUTPA TIENT")!(C HTOS["DENT AL")) D
  10537   "RTN","CHG ASP1",56,0 )
  10538    . S PLZIP =$P($G(^CH MPAY(CHCLM NUM,"VEN-I I")),"^",1 5) W !?53, "PL ZIP: " ,PLZIP ; W TC 5/19/17
  10539   "RTN","CHG ASP1",57,0 )
  10540    D COLHEAD
  10541   "RTN","CHG ASP1",58,0 )
  10542    D DIAG^CH GASP3,PROC ^CHGASP3
  10543   "RTN","CHG ASP1",59,0 )
  10544    D DMESUP, DME,PHARM
  10545   "RTN","CHG ASP1",60,0 )
  10546    W !,?54," ---------- -",?68,"-- ---------"
  10547   "RTN","CHG ASP1",61,0 )
  10548    W !,?44," Totals"
  10549   "RTN","CHG ASP1",62,0 )
  10550    I CHAMT'= "" W ?54,$ J($FN(CHAM T,",",2),1 1)
  10551   "RTN","CHG ASP1",63,0 )
  10552    I CHALW'= "" W ?68,$ J($FN(CHAL W,",",2),1 1)
  10553   "RTN","CHG ASP1",64,0 )
  10554    E  S CHAL W="Und" W  ?68,$J(CHA LW,11)
  10555   "RTN","CHG ASP1",65,0 )
  10556    D ^CHGASP 3
  10557   "RTN","CHG ASP1",66,0 )
  10558    ;
  10559   "RTN","CHG ASP1",67,0 )
  10560   END K CHAC C,CHALL,CH ALW,CHAMT, CHAOB,CHAR GE,CHBAD1, CHBAD2,CHB AMT,CHBAT, CHBCTY
  10561   "RTN","CHG ASP1",68,0 )
  10562    K CHBATCH ,CHBENE,CH BST,CHBZIP ,CHCHG,CHC LN,CHCMAC, CHCNT,CHDA D1,CHDAD2
  10563   "RTN","CHG ASP1",69,0 )
  10564    K CHDC,CH DCTY,CHDES ,CHDIAG,CH DOB,CHDOC, CHDOS,CHDR G,CHDRUG,C HDSBEN,CHD X
  10565   "RTN","CHG ASP1",70,0 )
  10566    K CHDSDOB ,CHDSREL,C HDSSN,CHDS T,CHDT,CHD UZ,CHDZ,CH DZIP,CHEDI ,CHID,CHMO D
  10567   "RTN","CHG ASP1",71,0 )
  10568    K CHMAD1, CHMAD2,CHM AMT,CHMCTY ,CHMED,CHM ETH,CHMMAC ,CHMST,CHM TAX,CHMZIP
  10569   "RTN","CHG ASP1",72,0 )
  10570    K CHNAM,C HNDC,CHOHI ,CHOHIF,CH PDITY,CHPL ,CHPOS,CHP ROC,CHPSAD 1,CHPSAD2, CHOHIPR    ; JEH 9/5/ 06 ADD CHO HIPR
  10571   "RTN","CHG ASP1",73,0 )
  10572    K CHPSCTY ,CHPST,CHP STAX,CHPSV EN,CHPSZIP ,CHRC,CHRC 1,CHREAS,C HREASN,CHR EC
  10573   "RTN","CHG ASP1",74,0 )
  10574    K CHREL,C HRSN,CHSPO N,CHSSN,CH STS,CHTAX, CHTOS,CHTY PE,CHVAD1, CHVAD2
  10575   "RTN","CHG ASP1",75,0 )
  10576    K CHVCTY, CHVE,CHVEN ,CHVNPG,CH VST,CHVZIP ,FLG,HREC, J,M,N,PG,R EC1
  10577   "RTN","CHG ASP1",76,0 )
  10578    K REC2,RE C3,REC4,RE C5,REC6,RE C7,X,Y,ZZ, ^TMP($J,"W IP")
  10579   "RTN","CHG ASP1",77,0 )
  10580    K CHCLMNU M,PLZIP ;  WTC 6/19/1 7
  10581   "RTN","CHG ASP1",78,0 )
  10582    Q
  10583   "RTN","CHG ASP1",79,0 )
  10584    ;
  10585   "RTN","CHG ASP1",80,0 )
  10586   DMESUP S D ST=""
  10587   "RTN","CHG ASP1",81,0 )
  10588   DM1 S DST= $O(^TMP($J ,"WIP",CHP DI,CHCLM," DMESUP",DS T)) Q:'DST
  10589   "RTN","CHG ASP1",82,0 )
  10590    S DREC=^T MP($J,"WIP ",CHPDI,CH CLM,"DMESU P",DST)
  10591   "RTN","CHG ASP1",83,0 )
  10592    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)
  10593   "RTN","CHG ASP1",84,0 )
  10594    W !,CHSPC DE,?14,CHS PDES,?47,C HPL
  10595   "RTN","CHG ASP1",85,0 )
  10596    I CHSPAMT '="" W ?54 ,$J($FN(CH SPAMT,",", 2),11)
  10597   "RTN","CHG ASP1",86,0 )
  10598    I CHSPALL '="" W ?68 ,$J($FN(CH SPALL,",", 2),11)
  10599   "RTN","CHG ASP1",87,0 )
  10600    E  S CHSP ALL="Und"  W ?68,$J(C HSPALL,11)
  10601   "RTN","CHG ASP1",88,0 )
  10602    G DM1
  10603   "RTN","CHG ASP1",89,0 )
  10604    ;
  10605   "RTN","CHG ASP1",90,0 )
  10606   DME Q:'$D( ^TMP($J,"W IP",CHPDI, CHCLM,"DME "))
  10607   "RTN","CHG ASP1",91,0 )
  10608    S DLEC=^T MP($J,"WIP ",CHPDI,CH CLM,"DME")
  10609   "RTN","CHG ASP1",92,0 )
  10610    S CHSPCD= $P(DLEC,U, 1),CHSPDS= $P(DLEC,U, 2),CHSPCHG =$P(DLEC,U ,3),CHSPAL W=$P(DLEC, U,4)
  10611   "RTN","CHG ASP1",93,0 )
  10612    W !,CHSPC D,?14,CHSP DS
  10613   "RTN","CHG ASP1",94,0 )
  10614    I CHSPCHG '="" W ?54 ,$J($FN(CH SPCHG,",", 2),11)
  10615   "RTN","CHG ASP1",95,0 )
  10616    I CHSPALW '="" W ?68 ,$J($FN(CH SPALW,",", 2),11)
  10617   "RTN","CHG ASP1",96,0 )
  10618    E  S CHSP ALW="Und"  W ?68,$J(C HSPALW,11)
  10619   "RTN","CHG ASP1",97,0 )
  10620    Q
  10621   "RTN","CHG ASP1",98,0 )
  10622    ;
  10623   "RTN","CHG ASP1",99,0 )
  10624   PHARM S ZZ =""
  10625   "RTN","CHG ASP1",100, 0)
  10626   PH1 S ZZ=$ O(^TMP($J, "WIP",CHPD I,CHCLM,"R X",ZZ)) Q: ZZ=""
  10627   "RTN","CHG ASP1",101, 0)
  10628    S CHRC1=^ (ZZ)
  10629   "RTN","CHG ASP1",102, 0)
  10630    S CHNDC=$ P(CHRC1,U, 1),CHDRUG= $P(CHRC1,U ,2),CHARGE =$P(CHRC1, U,3),CHALL =$P(CHRC1, U,4)
  10631   "RTN","CHG ASP1",103, 0)
  10632    W !,CHNDC ,?14,CHDRU G
  10633   "RTN","CHG ASP1",104, 0)
  10634    I CHARGE' ="" W ?54, $J($FN(CHA RGE,",",2) ,11)
  10635   "RTN","CHG ASP1",105, 0)
  10636    I CHALL'= "" W ?68,$ J($FN(CHAL L,",",2),1 1)
  10637   "RTN","CHG ASP1",106, 0)
  10638    E  S CHAL L="Und" W  ?68,$J(CHA LL,11)
  10639   "RTN","CHG ASP1",107, 0)
  10640    G PH1
  10641   "RTN","CHG ASP1",108, 0)
  10642    ;
  10643   "RTN","CHG ASP1",109, 0)
  10644   PRT S N=0, LCT=1,TAB= 5
  10645   "RTN","CHG ASP1",110, 0)
  10646   PT1 S N=$O (PX(N)) I  N="" K PX, LABEL,PC,N ,TAB,LCT Q
  10647   "RTN","CHG ASP1",111, 0)
  10648    S LABEL(L CT)=$P(PX( N),U,1),PC (LCT)=$P(P X(N),U,2)
  10649   "RTN","CHG ASP1",112, 0)
  10650    G:(LABEL( LCT)="")!( PC(LCT)="" ) PT1
  10651   "RTN","CHG ASP1",113, 0)
  10652    W ?TAB,LA BEL,PC
  10653   "RTN","CHG ASP1",114, 0)
  10654    I LCT=3 I  $O(PX(N))  S TAB=5,L CT=1 W !
  10655   "RTN","CHG ASP1",115, 0)
  10656    E  S TAB= TAB+21,LCT =LCT+1
  10657   "RTN","CHG ASP1",116, 0)
  10658    G PT1
  10659   "RTN","CHG ASP1",117, 0)
  10660    ;
  10661   "RTN","CHG ASP1",118, 0)
  10662   NODATA I C HDUZ'="" W  !!!,"THER E ARE NO A CTIVE CLAI MS IN THE  AUDIT SUPP ORT QUEUE  FOR ",CHDZ ,"."
  10663   "RTN","CHG ASP1",119, 0)
  10664    I CHREAS' ="" W !!!, "THERE ARE  NO ACTIVE  ",CHREASN ," IN THE  AUDIT SUPP ORT QUEUE. "
  10665   "RTN","CHG ASP1",120, 0)
  10666    Q
  10667   "RTN","CHG ASP1",121, 0)
  10668    ;
  10669   "RTN","CHG ASP1",122, 0)
  10670   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  10671   "RTN","CHG ASP1",123, 0)
  10672    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  10673   "RTN","CHG ASP1",124, 0)
  10674    Q
  10675   "RTN","CHG ASP1",125, 0)
  10676   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  10677   "RTN","CHG ASP1",126, 0)
  10678   HEAD W #,D UZ,?33,"CH AMPVA CENT ER",?72,"P age:  ",PG  S PG=PG+1
  10679   "RTN","CHG ASP1",127, 0)
  10680    W !,TIME, ?25,"Audit  Support Q ueue WIP R eport",!,$ E(DT,4,7), ?80-$L(DAT E)/2,DATE
  10681   "RTN","CHG ASP1",128, 0)
  10682    Q
  10683   "RTN","CHG ASP1",129, 0)
  10684   COLHEAD I  CHTY=4 D   Q
  10685   "RTN","CHG ASP1",130, 0)
  10686    .W !!,"Co de",?14,"D escription ",?46,"P/L ",?59,"Bil led",?72," Allowed"
  10687   "RTN","CHG ASP1",131, 0)
  10688    .W !,"--- ---------- ---------- ---------- ---------- -",?46,"-- -",?54,"-- ---------" ,?68,"---- -------"
  10689   "RTN","CHG ASP1",132, 0)
  10690    .Q
  10691   "RTN","CHG ASP1",133, 0)
  10692    W !!,"Cod e",?14,"De scription" ,?59,"Bill ed",?72,"A llowed"
  10693   "RTN","CHG ASP1",134, 0)
  10694    W !,"---- ---------- ---------- ---------- ---------- ",?54,"--- --------", ?68,"----- ------"
  10695   "RTN","CHG ASP1",135, 0)
  10696    Q
  10697   "RTN","CHG CDC7")
  10698   0^26^B1808 7010
  10699   "RTN","CHG CDC7",1,0)
  10700   CHGCDC7 ;C VA/RLC;CCD  EDIT HIST ORY DATA C ALC-MODULE  7 - INPAT IENT ;08/0 2/99  4:20  PM
  10701   "RTN","CHG CDC7",2,0)
  10702    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  10703   "RTN","CHG CDC7",3,0)
  10704    ;V1.0;;
  10705   "RTN","CHG CDC7",4,0)
  10706    ;CPTS #11 673* (RLC) , #11832*  (RLC), #15 437* (RLC)
  10707   "RTN","CHG CDC7",5,0)
  10708    ; PT $161 82 (Y2K)
  10709   "RTN","CHG CDC7",6,0)
  10710    ; MTN0183 20-01 06/2 0/13 JSE -  FIX UNDEF INED ERROR  IN CHGCDV 70 PR1+13  & CHGCDP70  (PR1+9)
  10711   "RTN","CHG CDC7",7,0)
  10712    ;
  10713   "RTN","CHG CDC7",8,0)
  10714    I CHTYPE' =1 D ^CHGC DC74 G END
  10715   "RTN","CHG CDC7",9,0)
  10716    D RESET G  END:IVL=" "
  10717   "RTN","CHG CDC7",10,0 )
  10718    G END:'$D (@(GLPAYH_ "IVL,101)" ))
  10719   "RTN","CHG CDC7",11,0 )
  10720   A1 S JX=$O (@(GLPAYH_ "IVL,101,J X)")) G:'J X END I IN TFL=0 D ^C HGCDC71 S  INTFL=1 G  A1
  10721   "RTN","CHG CDC7",12,0 )
  10722    G:$D(@(GL PAYH_"IVL, 101,JX,50) ")) A1
  10723   "RTN","CHG CDC7",13,0 )
  10724    ; Y2K chg 'd all 2 d ig yr to 4  dig yr 
  10725   "RTN","CHG CDC7",14,0 )
  10726    S CHHSDT= JX,CHHSDT= $$FMTE^XLF DT(CHHSDT, 5),CHDZZ=" ",(HDFN,HB FN,HVEN)=" "
  10727   "RTN","CHG CDC7",15,0 )
  10728    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:"")
  10729   "RTN","CHG CDC7",16,0 )
  10730    S CHSB1=$ S(CHTY=1:" INP-PROC", CHTY=2:"OP T-PROC",CH TY=5:"DEN- PROC",CHTY =6:"OPT-PR OC",1:"")
  10731   "RTN","CHG CDC7",17,0 )
  10732    S:$D(@(GL PAYH_"IVL, 101,JX,99) ")) CHDZZ= $P(@(GLPAY H_"IVL,101 ,JX,99)"), U,1)
  10733   "RTN","CHG CDC7",18,0 )
  10734    S CHDZHS= "UNK"
  10735   "RTN","CHG CDC7",19,0 )
  10736    I CHDZZ'= "" I $D(^V A(200,CHDZ Z,0)) S CH DZHS=$P(^( 0),U,2)
  10737   "RTN","CHG CDC7",20,0 )
  10738    S CHDZHS= CHDZHS_"-" _CHDZZ
  10739   "RTN","CHG CDC7",21,0 )
  10740    F SUB=0,1 ,7,9,10,27 ,"COMMON", "DME","INP " D
  10741   "RTN","CHG CDC7",22,0 )
  10742    .K FILE1
  10743   "RTN","CHG CDC7",23,0 )
  10744    .;I SUB?1 .2N S FILE 1="^"_GLPA YH_IVL_",1 01,"_JX_", "_SUB_")"
  10745   "RTN","CHG CDC7",24,0 )
  10746    .;E  S FI LE1="^"_GL PAYH_IVL_" ,101,"_JX_ ","""_SUB_ """)"
  10747   "RTN","CHG CDC7",25,0 )
  10748    .;Q:'$D(@ FILE1)  Q
  10749   "RTN","CHG CDC7",26,0 )
  10750    I '$D(@(G LPAYH_"IVL ,101,JX,SU B)")) I '$ D(@(GLPAYH _"IVL,101, JX,"""_SUB _""")")) Q
  10751   "RTN","CHG CDC7",27,0 )
  10752    .I SUB?1. 2N S FILE1 =@(GLPAYH_ "IVL,101,J X,SUB)")
  10753   "RTN","CHG CDC7",28,0 )
  10754    .E  S FIL E1=@(GLPAY H_"IVL,101 ,JX,"""_SU B_""")")
  10755   "RTN","CHG CDC7",29,0 )
  10756    .Q:'$D(FI LE1)  Q
  10757   "RTN","CHG CDC7",30,0 )
  10758    .S OTHFL= 1
  10759   "RTN","CHG CDC7",31,0 )
  10760    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"HIST ",JX)) ^(J X)=CHDZHS_ U_CHHSDT
  10761   "RTN","CHG CDC7",32,0 )
  10762    .I SUB=0  F X=3,5,7, 8,9,21,22  S PC=$P(FI LE1,U,X) D :PC'=""
  10763   "RTN","CHG CDC7",33,0 )
  10764    ..S LABEL =$S(X=5:"P ay Provide r: ",X=7:" Type Servi ce: ",X=8: "DOS: ",X= 9:"Claim C reation: " ,1:"")
  10765   "RTN","CHG CDC7",34,0 )
  10766    ..I X=3 S  HVEN=PC
  10767   "RTN","CHG CDC7",35,0 )
  10768    ..I X=7 I  $D(^CHMDI C(741002.0 5,PC,0)) S  PC=$P(^(0 ),U,1)
  10769   "RTN","CHG CDC7",36,0 )
  10770    ..I X=8 I  PC=1 S LA BEL="Admis sion: "
  10771   "RTN","CHG CDC7",37,0 )
  10772    ..I X=8 S  PC=$$FMTE ^XLFDT(PC, "5D")
  10773   "RTN","CHG CDC7",38,0 )
  10774    ..I X=21  S HDFN=PC
  10775   "RTN","CHG CDC7",39,0 )
  10776    ..I X=22  S HBFN=PC
  10777   "RTN","CHG CDC7",40,0 )
  10778    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  10779   "RTN","CHG CDC7",41,0 )
  10780    .I SUB=1  F X=7 S PC =$P(FILE1, U,X) D
  10781   "RTN","CHG CDC7",42,0 )
  10782    ..S LABEL ="OHI Paym t: "
  10783   "RTN","CHG CDC7",43,0 )
  10784    ..I PC'=" " S PC=$J( PC,",",2)
  10785   "RTN","CHG CDC7",44,0 )
  10786    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  10787   "RTN","CHG CDC7",45,0 )
  10788    .I SUB=7  F X=1,5,6  S PC=$P(FI LE1,U,X) D :PC'=""
  10789   "RTN","CHG CDC7",46,0 )
  10790    ..S LABEL =$S(X=1:"M edicaid Ag ency: ",X= 5:"PCN/PAN : ",X=6:"T ype of Bil l: ",1:"")
  10791   "RTN","CHG CDC7",47,0 )
  10792    ..;MTN018 320 JSE -  Commented  out line.  Code shoul d set # no t name ^TM P. Name ca uses error  UNDEF-PR1 +13^CHGCDV 70
  10793   "RTN","CHG CDC7",48,0 )
  10794    ..;I X=1  I PC'="" I  $D(^CHMVE N(PC,0)) S  PC=$P(^(0 ),U,1),PC= $E(PC,1,20 )
  10795   "RTN","CHG CDC7",49,0 )
  10796    ..I X=5 I  PC'="" S  LABEL=$E(P C,1,20)
  10797   "RTN","CHG CDC7",50,0 )
  10798    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  10799   "RTN","CHG CDC7",51,0 )
  10800    .I SUB=10  F X=20 S  PC=$P(FILE 1,U,X) D:P C'=""
  10801   "RTN","CHG CDC7",52,0 )
  10802    ..S LABEL ="MCCR Rev iew: "
  10803   "RTN","CHG CDC7",53,0 )
  10804    ..S:PC=0  PC="NO" S: PC=1 PC="Y ES"
  10805   "RTN","CHG CDC7",54,0 )
  10806    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  10807   "RTN","CHG CDC7",55,0 )
  10808    .I SUB=27  F X=1,2,3  S PC=$P(F ILE1,U,X)  D:PC'=""
  10809   "RTN","CHG CDC7",56,0 )
  10810    ..S LABEL =$S(X=1:"O HI Begin:  ",X=2:"OHI  End: ",X= 3:"OHI Typ e: ",1:"")
  10811   "RTN","CHG CDC7",57,0 )
  10812    ..I (X=1) !(X=2) S P C=$$FMTE^X LFDT(PC,"5 D")
  10813   "RTN","CHG CDC7",58,0 )
  10814    ..I X=3 I  PC I $D(^ CHMDIC(741 002.76,PC, 0)) S PC=$ P(^(0),"^" ,1)
  10815   "RTN","CHG CDC7",59,0 )
  10816    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  10817   "RTN","CHG CDC7",60,0 )
  10818    .I SUB="C OMMON" F X =1,2,3,8 S  PC=$P(FIL E1,U,X) D: PC'=""
  10819   "RTN","CHG CDC7",61,0 )
  10820    ..S LABEL =$S(X=1:"T otal Charg e: ",X=2:" POS: ",X=3 :"Bene Pay mt: ",1:"" )
  10821   "RTN","CHG CDC7",62,0 )
  10822    ..I X=2 I  PC'="" I  $D(^CHMDIC (741002.11 ,PC,0)) S  PC=$P(^(0) ,U,2),PC=$ E(PC,1,15)
  10823   "RTN","CHG CDC7",63,0 )
  10824    ..I X=3 I  PC>0 S PC =$J(PC,"," ,2)
  10825   "RTN","CHG CDC7",64,0 )
  10826    ..I X=3 I  PC'>0 S P C=""
  10827   "RTN","CHG CDC7",65,0 )
  10828    ..I X=8 I  CHTY=1 S  LABEL="DRG : "
  10829   "RTN","CHG CDC7",66,0 )
  10830    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  10831   "RTN","CHG CDC7",67,0 )
  10832    .I SUB="D ME" F X=1  S PC=$P(FI LE1,U,X) D   
  10833   "RTN","CHG CDC7",68,0 )
  10834    ..S LABEL ="Delivery  Chg: "
  10835   "RTN","CHG CDC7",69,0 )
  10836    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"DMEHST" ,JX)=PC_U_ LABEL
  10837   "RTN","CHG CDC7",70,0 )
  10838    .I SUB="I NP" F X=1, 2,3,7 S PC =$P(FILE1, U,X) D:PC' =""
  10839   "RTN","CHG CDC7",71,0 )
  10840    ..S LABEL =$S(X=1:"D ischarge:  ",X=2:"Dis  Status: " ,X=3:"Admi tting DX:  ",X=7:"Fac  Discharge d to: ",1: "")
  10841   "RTN","CHG CDC7",72,0 )
  10842    ..I X=1 S  PC=$$FMTE ^XLFDT(PC, "5D")
  10843   "RTN","CHG CDC7",73,0 )
  10844    ..I X=2 I  PC'="" I  $D(^CHMDIC (741002.12 ,PC,0)) S  PC=$P(^(0) ,U,1)
  10845   "RTN","CHG CDC7",74,0 )
  10846    ..I X=3 I  PC'="" I  $D(^CHMICD X(PC,0)) S  PC=$P(^(0 ),U,2)
  10847   "RTN","CHG CDC7",75,0 )
  10848    ..I X=7 I  PC'="" I  $D(^CHMDIC (741002.11 ,PC,0)) S  PC=$P(^(0) ,U,1)
  10849   "RTN","CHG CDC7",76,0 )
  10850    ..S ^TMP( $J,"CCD",C HCLM,CHTYP E,"HIST",J X,SUB,X)=P C_U_LABEL
  10851   "RTN","CHG CDC7",77,0 )
  10852    S (BFLAG, VFLAG)=0
  10853   "RTN","CHG CDC7",78,0 )
  10854    D ^CHGCDC 72  ;BENE/ VENDOR DEM OGRAPHICS  INITIAL IN PUT & EDIT S
  10855   "RTN","CHG CDC7",79,0 )
  10856    D ^CHGCDC 73  ;LINE- ITEM DATA  INITIAL IN PUT & EDIT S
  10857   "RTN","CHG CDC7",80,0 )
  10858    G A1
  10859   "RTN","CHG CDC7",81,0 )
  10860    ;
  10861   "RTN","CHG CDC7",82,0 )
  10862   END K CHDZ Z,CHDZHS,C HHSDT,CHSB ,CHSB1,HBF N,HDFN,HVE N,LABEL,PC ,SUB
  10863   "RTN","CHG CDC7",83,0 )
  10864    Q
  10865   "RTN","CHG CDC7",84,0 )
  10866    ;
  10867   "RTN","CHG CDC7",85,0 )
  10868   RESET S U= "^"
  10869   "RTN","CHG CDC7",86,0 )
  10870    S (JX,OTH FL,BDDPT,V DDPT,INTFL )=0,(NN,DC T)=1
  10871   "RTN","CHG CDC7",87,0 )
  10872    S (CHDZHS ,CHDZZ,CHH SDT,CHSB,C HSB1,HBFN, HDFN,HVEN, LABEL,PC,S UB)=""
  10873   "RTN","CHG CDC7",88,0 )
  10874    Q
  10875   "RTN","CHG CDC72")
  10876   0^27^B8485 5070
  10877   "RTN","CHG CDC72",1,0 )
  10878   CHGCDC72 ; CVA/RLC;CC D DEMO INI T INPUT/ED IT CALC-MO DULE 7-ALL  TOS ;08/0 4/99  3:37  PM
  10879   "RTN","CHG CDC72",2,0 )
  10880    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  10881   "RTN","CHG CDC72",3,0 )
  10882    ;INCLUDES  CHANGES M ADE TO VIN IT 8/4/99  - IN TRN O NLY
  10883   "RTN","CHG CDC72",4,0 )
  10884    ;CPTS #11 673* (RLC) , #11832*  (RLC), #15 437* (RLC)
  10885   "RTN","CHG CDC72",5,0 )
  10886    ;CALLED B Y ^CHGCDC7 /71.  LOOP S THRU AND  GATHERS A LL INITIAL  INPUT AND
  10887   "RTN","CHG CDC72",6,0 )
  10888    ;EDIT HIS TORY FOR B ENE AND VE NDOR DEMOG RAPHIC DAT A.
  10889   "RTN","CHG CDC72",7,0 )
  10890    ;jsg;DEV0 02841-02;0 5/12/09;Au to Vendor  Selection  Process; D isplay "AV S" on CCD;
  10891   "RTN","CHG CDC72",8,0 )
  10892    ;DEV01938 8 EW  11/0 7/13  POA
  10893   "RTN","CHG CDC72",9,0 )
  10894    ;DEV02115 7 SBB 05/2 9/14  Fix  ICQ Data e rrors.
  10895   "RTN","CHG CDC72",10, 0)
  10896    ;CFS 03/0 8/2018 - D efect 6863 82 add CHR PLZII PL Z IP variabl e.
  10897   "RTN","CHG CDC72",11, 0)
  10898    ;
  10899   "RTN","CHG CDC72",12, 0)
  10900    I BFLAG=0  D BINIT G  A1
  10901   "RTN","CHG CDC72",13, 0)
  10902    D BENDD
  10903   "RTN","CHG CDC72",14, 0)
  10904   A1 I VFLAG =0 D VINIT  G END
  10905   "RTN","CHG CDC72",15, 0)
  10906    D VENDD
  10907   "RTN","CHG CDC72",16, 0)
  10908    G END
  10909   "RTN","CHG CDC72",17, 0)
  10910    ;
  10911   "RTN","CHG CDC72",18, 0)
  10912   BINIT Q:(H DFN="")!(H BFN="")
  10913   "RTN","CHG CDC72",19, 0)
  10914    I '$D(@(G LPAYH_"IVL ,101)")) D  NOCHG Q
  10915   "RTN","CHG CDC72",20, 0)
  10916    S REC=@(G LELG_"HDFN ,100,HBFN, 0)")
  10917   "RTN","CHG CDC72",21, 0)
  10918    S (CHBNAM ,CHBNDOB,C HBNREL,CHB SSN,CHBNAD 1,CHBNAD2, CHBNCTY,CH BNST,CHBNZ IP)=""
  10919   "RTN","CHG CDC72",22, 0)
  10920    S (CHBSEX ,CHBAGE,CH TDDT,CHBRD T)=""
  10921   "RTN","CHG CDC72",23, 0)
  10922    S CHBNAM= $P(REC,U,1 ),CHBSEX=$ P(REC,U,2) ,CHBNDOB=$ P(REC,U,3) ,CHBNREL=$ P(REC,U,4) ,CHBSSN=$P (REC,U,9)
  10923   "RTN","CHG CDC72",24, 0)
  10924    D NOW^%DT C S CHTDDT =$P(%H,"," ,1)
  10925   "RTN","CHG CDC72",25, 0)
  10926    I CHBNDOB ="" S CHBA GE="UNK" G  BI1
  10927   "RTN","CHG CDC72",26, 0)
  10928    S X=CHBND OB D H^%DT C S CHBRDT =%H
  10929   "RTN","CHG CDC72",27, 0)
  10930    S CHBAGE= ((CHTDDT-C HBRDT)/365 .25\1)
  10931   "RTN","CHG CDC72",28, 0)
  10932    S YR="" S :$E(CHBNDO B,1)=2 YR= 19 S:$E(CH BNDOB,1)=3  YR=20
  10933   "RTN","CHG CDC72",29, 0)
  10934    S CHBNDOB =$E(CHBNDO B,4,5)_"/" _$E(CHBNDO B,6,7)_"/" _YR_$E(CHB NDOB,2,3)
  10935   "RTN","CHG CDC72",30, 0)
  10936   BI1 S REC1 =@(GLELG_" HDFN,100,H BFN,1)")
  10937   "RTN","CHG CDC72",31, 0)
  10938    S CHBNAD1 =$P(REC1,U ,1),CHBNAD 2=$P(REC1, U,2),CHBNC TY=$P(REC1 ,U,3),CHBN STE=$P(REC 1,U,4),CHB NZIP=$P(RE C1,U,5)
  10939   "RTN","CHG CDC72",32, 0)
  10940    S CHBNREL =$S(CHBNRE L="S":"SPO USE",CHBNR EL="C":"CH ILD",CHBNR EL="XS":"E X-SPOUSE", 1:"")
  10941   "RTN","CHG CDC72",33, 0)
  10942    S CHBNST= "" I CHBNS TE'="" I $ D(^DIC(5,C HBNSTE,0))  S CHBNST= $P(^(0),U, 2)
  10943   "RTN","CHG CDC72",34, 0)
  10944    D SETII
  10945   "RTN","CHG CDC72",35, 0)
  10946    D:$D(@(GL PAY_"IVL," "BENE"",HD FN,HBFN)") ) BNDD
  10947   "RTN","CHG CDC72",36, 0)
  10948    S BFLAG=1
  10949   "RTN","CHG CDC72",37, 0)
  10950    Q
  10951   "RTN","CHG CDC72",38, 0)
  10952    ;
  10953   "RTN","CHG CDC72",39, 0)
  10954   BNDD S DT1 =0
  10955   "RTN","CHG CDC72",40, 0)
  10956   BD1 S DT1= $O(@(GLPAY _"IVL,""BE NE"",HDFN, HBFN,DT1)" )) Q:'DT1
  10957   "RTN","CHG CDC72",41, 0)
  10958    G:'$D(@(G LPAY_"IVL, ""BENE"",H DFN,HBFN,D T1,0)")) B D1 S REC=@ (GLPAY_"IV L,""BENE"" ,HDFN,HBFN ,DT1,0)")
  10959   "RTN","CHG CDC72",42, 0)
  10960    S CHDDZ=$ P(REC,U,11 )
  10961   "RTN","CHG CDC72",43, 0)
  10962    I CHDDZ=" " S CHDDZ= $P(@(GLPAY _"IVL,3)") ,U,1)
  10963   "RTN","CHG CDC72",44, 0)
  10964    S LAB=""  K PIC
  10965   "RTN","CHG CDC72",45, 0)
  10966    F DCT=1:1 :10 S:$P(R EC,U,DCT)' ="" PIC(DC T)=$P(REC, U,DCT)
  10967   "RTN","CHG CDC72",46, 0)
  10968    F DCT=1:1 :10 I $D(P IC(DCT)) D
  10969   "RTN","CHG CDC72",47, 0)
  10970    .S LAB=$S (DCT=1:"Be ne: ",DCT= 2:"SSN: ", DCT=3:"Add r1: ",DCT= 4:"Addr2:  ",DCT=5:"C ity: ",DCT =6:"State:  ",DCT=7:" Zip: ",DCT =9:"DOB: " ,DCT=10:"R elation: " ,1:"")
  10971   "RTN","CHG CDC72",48, 0)
  10972    .S $P(PIC (DCT),U,2) =LAB
  10973   "RTN","CHG CDC72",49, 0)
  10974    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"BENE -DD",DT1,0 )) ^(0)=CH DDZ
  10975   "RTN","CHG CDC72",50, 0)
  10976    .S ^TMP($ J,"CCD",CH CLM,CHTYPE ,"BENE-DD" ,DT1,DCT)= PIC(DCT)
  10977   "RTN","CHG CDC72",51, 0)
  10978    G BD1
  10979   "RTN","CHG CDC72",52, 0)
  10980    ;
  10981   "RTN","CHG CDC72",53, 0)
  10982   BENDD Q:(D FN="")!(BF N="")
  10983   "RTN","CHG CDC72",54, 0)
  10984    Q:'$D(@(G LPAY_"IVL, ""BENE"",D FN,BFN)"))
  10985   "RTN","CHG CDC72",55, 0)
  10986    S DT1=0
  10987   "RTN","CHG CDC72",56, 0)
  10988   BEN1 S DT1 =$O(@(GLPA Y_"IVL,""B ENE"",DFN, BFN,DT1)") ) Q:'DT1
  10989   "RTN","CHG CDC72",57, 0)
  10990    S REC=@(G LPAY_"IVL, ""BENE"",D FN,BFN,DT1 ,0)")
  10991   "RTN","CHG CDC72",58, 0)
  10992    S CHDDZ=$ P(REC,U,11 )
  10993   "RTN","CHG CDC72",59, 0)
  10994    I CHDDZ=" " S CHDDZ= $P(@(GLPAY _"IVL,3)") ,U,1)
  10995   "RTN","CHG CDC72",60, 0)
  10996    S LAB=""  K PIC
  10997   "RTN","CHG CDC72",61, 0)
  10998    F DCT=1:1 :10 S:$P(R EC,U,DCT)' ="" PIC(DC T)=$P(REC, U,DCT)
  10999   "RTN","CHG CDC72",62, 0)
  11000    F DCT=1:1 :10 I $D(P IC(DCT)) D
  11001   "RTN","CHG CDC72",63, 0)
  11002    .S LAB=$S (DCT=1:"Be ne: ",DCT= 2:"SSN: ", DCT=3:"Add r1: ",DCT= 4:"Addr2:  ",DCT=5:"C ity: ",DCT =6:"State:  ",DCT=7:" Zip: ",DCT =9:"DOB: " ,DCT=10:"R elation: " ,1:"")
  11003   "RTN","CHG CDC72",64, 0)
  11004    .S $P(PIC (DCT),U,2) =LAB
  11005   "RTN","CHG CDC72",65, 0)
  11006    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"BENE -DD",DT1,0 )) ^(0)=CH DDZ
  11007   "RTN","CHG CDC72",66, 0)
  11008    .S ^TMP($ J,"CCD",CH CLM,CHTYPE ,"BENE-DD" ,DT1,DCT)= PIC(DCT)
  11009   "RTN","CHG CDC72",67, 0)
  11010    G BEN1
  11011   "RTN","CHG CDC72",68, 0)
  11012    ;
  11013   "RTN","CHG CDC72",69, 0)
  11014   NOCHG Q:'$ D(@(GLELG_ "DFN,100,B FN,0)"))   S REC=@(GL ELG_"DFN,1 00,BFN,0)" )
  11015   "RTN","CHG CDC72",70, 0)
  11016    S CHBNAM= $P(REC,U,1 ),CHBNDOB= $P(REC,U,3 ),CHBNREL= $P(REC,U,4 ),CHBSSN=$ P(REC,U,9)
  11017   "RTN","CHG CDC72",71, 0)
  11018    S REC1=@( GLELG_"DFN ,100,BFN,1 )")
  11019   "RTN","CHG CDC72",72, 0)
  11020    S CHBNAD1 =$P(REC1,U ,1),CHBNAD 2=$P(REC1, U,2),CHBNC TY=$P(REC1 ,U,3),CHBN STE=$P(REC 1,U,4),CHB NZIP=$P(RE C1,U,5)
  11021   "RTN","CHG CDC72",73, 0)
  11022    S CHBNREL =$S(CHBNRE L="S":"SPO USE",CHBNR EL="C":"CH ILD",CHBNR EL="XS":"E X-SPOUSE", 1:"")
  11023   "RTN","CHG CDC72",74, 0)
  11024    S CHBNST= ""
  11025   "RTN","CHG CDC72",75, 0)
  11026    I CHBNSTE '="" I $D( ^DIC(5,CHB NSTE,0)) S  CHBNST=$P (^(0),U,2)
  11027   "RTN","CHG CDC72",76, 0)
  11028    D SETII
  11029   "RTN","CHG CDC72",77, 0)
  11030    Q
  11031   "RTN","CHG CDC72",78, 0)
  11032    ;
  11033   "RTN","CHG CDC72",79, 0)
  11034   SETII S ^T MP($J,"CCD ",CHCLM,CH TYPE,"BEN- II")=CHBNA M_U_CHBSSN _U_CHBNDOB _U_CHBNREL _U_CHBNAD1 _U_CHBNAD2 _U_CHBNCTY _U_CHBNST_ U_CHBNZIP_ U_CHBSEX_U _CHBAGE
  11035   "RTN","CHG CDC72",80, 0)
  11036    Q
  11037   "RTN","CHG CDC72",81, 0)
  11038    ;
  11039   "RTN","CHG CDC72",82, 0)
  11040   VINIT D VA RSET
  11041   "RTN","CHG CDC72",83, 0)
  11042    K X1
  11043   "RTN","CHG CDC72",84, 0)
  11044    I '$D(@(G LPAY_"IVL, ""VEN-II"" )")) D PSB LD Q
  11045   "RTN","CHG CDC72",85, 0)
  11046    S X1=@(GL PAY_"IVL," "VEN-II"") ") K PSFLG ,RTFLG D
  11047   "RTN","CHG CDC72",86, 0)
  11048    .S CHVRTI I=$P(X1,U, 1),CHTXII= $P(X1,U,2) ,CHRAD1II= $P(X1,U,3)
  11049   "RTN","CHG CDC72",87, 0)
  11050    .S CHRAD2 II=$P(X1,U ,4),CHRCTY II=$P(X1,U ,5),CHRST= $P(X1,U,6)
  11051   "RTN","CHG CDC72",88, 0)
  11052    .S CHRTZP II=$P(X1,U ,7),CHRTPN II=$P(X1,U ,8),CHRPLZ II=$P(X1,U ,15)  ;--  Defect 686 382 add CH RPLZII PL  ZIP variab le.
  11053   "RTN","CHG CDC72",89, 0)
  11054    .I CHRST' ="" S:$D(^ DIC(5,CHRS T,0)) CHRT STII=$P(^( 0),U,2)
  11055   "RTN","CHG CDC72",90, 0)
  11056    .S RTFLG= ""
  11057   "RTN","CHG CDC72",91, 0)
  11058    .K X1
  11059   "RTN","CHG CDC72",92, 0)
  11060    .Q
  11061   "RTN","CHG CDC72",93, 0)
  11062    Q:'$D(@(G LPAY_"IVL, 0)"))  S R EC0=@(GLPA Y_"IVL,0)" )
  11063   "RTN","CHG CDC72",94, 0)
  11064    S VNPT=$P (REC0,U,3) ,XDOS=$P(R EC0,U,8)
  11065   "RTN","CHG CDC72",95, 0)
  11066    Q:VNPT=""   Q:XDOS=" "
  11067   "RTN","CHG CDC72",96, 0)
  11068    I $D(^CHM VEN(VNPT,0 )) S X1=^( 0) D
  11069   "RTN","CHG CDC72",97, 0)
  11070    .S PL23=" ",PTR=VNPT
  11071   "RTN","CHG CDC72",98, 0)
  11072    .S PL23=$ P(X1,U,23)
  11073   "RTN","CHG CDC72",99, 0)
  11074    .D CKVHIS 0^CHGCDC79
  11075   "RTN","CHG CDC72",100 ,0)
  11076    .S:CHADCD II="" CHAD CDII=PL23
  11077   "RTN","CHG CDC72",101 ,0)
  11078    .K X1,PTR ,VREC,PL23 ,P23,PF23
  11079   "RTN","CHG CDC72",102 ,0)
  11080    .Q
  11081   "RTN","CHG CDC72",103 ,0)
  11082    I $D(^CHM VEN(VNPT,1 4)) S X1=^ (14) D
  11083   "RTN","CHG CDC72",104 ,0)
  11084    .S PL1="" ,PL1=$P(X1 ,U,1),PTR= VNPT
  11085   "RTN","CHG CDC72",105 ,0)
  11086    .D CKVHS1 4^CHGCDC79
  11087   "RTN","CHG CDC72",106 ,0)
  11088    .S:CHMDCD II="" CHMD CDII=PL1
  11089   "RTN","CHG CDC72",107 ,0)
  11090    .K X1,PTR ,VREC,PL1, P1,PF1
  11091   "RTN","CHG CDC72",108 ,0)
  11092    .Q
  11093   "RTN","CHG CDC72",109 ,0)
  11094    S:(CHADCD II="")!(CH ADCDII="@" ) CHADCDII =" "
  11095   "RTN","CHG CDC72",110 ,0)
  11096    S:(CHMDCD II="")!(CH MDCDII="@" ) CHMDCDII =" "
  11097   "RTN","CHG CDC72",111 ,0)
  11098    S CHTINII =CHTXII_"- "_CHADCDII _"-"_CHMDC DII
  11099   "RTN","CHG CDC72",112 ,0)
  11100    I $D(CHMF PDI) I $D( ^CHMIMAGE( CHMFPDI,10 0,0)) { S  CHTINII=CH TINII_"(AV S)" } ;jsg ;DEV002841 ;5/12/09;
  11101   "RTN","CHG CDC72",113 ,0)
  11102    ;-- Defec t 686382 A dd CHRPLZI I PL ZIP v ariable.
  11103   "RTN","CHG CDC72",114 ,0)
  11104    I $D(RTFL G) S ^TMP( $J,"CCD",C HCLM,CHTYP E,"VEN-II" ,"RT-VEN") =CHVRTII_U _CHTINII_U _CHRAD1II_ U_CHRAD2II _U_CHRCTYI I_U_CHRTST II_U_CHRTZ PII_U_CHRT PNII_U_CHR PLZII K RT FLG
  11105   "RTN","CHG CDC72",115 ,0)
  11106    I $D(^CHM VEN(VNPT,2 )) S X1=^( 2) D
  11107   "RTN","CHG CDC72",116 ,0)
  11108    .S (PLN,P L1,PL2,PL3 ,PL4,PL5,P L6)=""
  11109   "RTN","CHG CDC72",117 ,0)
  11110    .S PLN=$P (X1,U,8),P L1=$P(X1,U ,1),PL2=$P (X1,U,2),P L3=$P(X1,U ,3)
  11111   "RTN","CHG CDC72",118 ,0)
  11112    .S PL4=$P (X1,U,4),P L5=$P(X1,U ,5),PL6=$P (X1,U,6),P TR=VNPT
  11113   "RTN","CHG CDC72",119 ,0)
  11114    .D CKVHIS 2^CHGCDC79
  11115   "RTN","CHG CDC72",120 ,0)
  11116    .S:CHVPLI I="" CHVPL II=PLN
  11117   "RTN","CHG CDC72",121 ,0)
  11118    .S:CHPAD1 II="" CHPA D1II=PL1
  11119   "RTN","CHG CDC72",122 ,0)
  11120    .S:CHPAD2 II="" CHPA D2II=PL2
  11121   "RTN","CHG CDC72",123 ,0)
  11122    .S:CHPCTY II="" CHPC TYII=PL3
  11123   "RTN","CHG CDC72",124 ,0)
  11124    .S:CHPST= "" CHPST=P L4
  11125   "RTN","CHG CDC72",125 ,0)
  11126    .S:CHPLZP II="" CHPL ZPII=PL5
  11127   "RTN","CHG CDC72",126 ,0)
  11128    .S:CHPLPN II="" CHPL PNII=PL6
  11129   "RTN","CHG CDC72",127 ,0)
  11130    .I CHPST' ="" S:$D(^ DIC(5,CHPS T,0)) CHPL STII=$P(^( 0),U,2)
  11131   "RTN","CHG CDC72",128 ,0)
  11132    .K X1,PTR ,PLN,PL1,P L2,PL3,PL4 ,PL5,PL6
  11133   "RTN","CHG CDC72",129 ,0)
  11134    .K PN,P1, P2,P3,P4,P 5,P6,PFN,P F1,PF2,PF3 ,PF4,PF5,P F6
  11135   "RTN","CHG CDC72",130 ,0)
  11136    .Q
  11137   "RTN","CHG CDC72",131 ,0)
  11138    D VENPG
  11139   "RTN","CHG CDC72",132 ,0)
  11140    S ^TMP($J ,"CCD",CHC LM,CHTYPE, "VEN-II"," PL-VEN")=C HVPLII_U_C HPAD1II_U_ CHPAD2II_U _CHPCTYII_ U_CHPLSTII _U_CHPLZPI I_U_CHPLPN II_U_CHVPO AII_U_CHCM ACII  ;DEV 019388  EW   11/13/13
  11141   "RTN","CHG CDC72",133 ,0)
  11142    Q
  11143   "RTN","CHG CDC72",134 ,0)
  11144    ;
  11145   "RTN","CHG CDC72",135 ,0)
  11146   VARSET S ( CHVRTII,CH RAD1II,CHR AD2II,CHRC TYII,CHRST ,CHRTSTII, CHRTZPII,C HRPLZII)=" "  ;Defect  686382 ad d CHRPLZII  PL ZIP va riable.
  11147   "RTN","CHG CDC72",136 ,0)
  11148    S (CHRTPN II,CHTXII, CHTINII,CH ADCDII,CHM DCDII,CHVP LII,CHPAD1 II)=""
  11149   "RTN","CHG CDC72",137 ,0)
  11150    S (CHPAD2 II,CHPCTYI I,CHPST,CH PLSTII,CHP LZPII,CHPL PNII,CHCMA CII)=""
  11151   "RTN","CHG CDC72",138 ,0)
  11152    S CHVPOAI I=""  ;DEV 019388  EW   11/13/13
  11153   "RTN","CHG CDC72",139 ,0)
  11154    Q
  11155   "RTN","CHG CDC72",140 ,0)
  11156    ;
  11157   "RTN","CHG CDC72",141 ,0)
  11158   VENPG S VN =0
  11159   "RTN","CHG CDC72",142 ,0)
  11160   V1 S VN=$O (@(GLPAYH_ "IVL,101,V N)")) Q:'V N
  11161   "RTN","CHG CDC72",143 ,0)
  11162    ;I $D(@(G LPAYH_"IVL ,101,VN,9) ")) S CHVP GII=$P(@(G LPAYH_"IVL ,101,VN,9) "),U,1)
  11163   "RTN","CHG CDC72",144 ,0)
  11164    ;DEV02115 7 SBB 05/2 9/14
  11165   "RTN","CHG CDC72",145 ,0)
  11166    S:'$D(VNP T) VNPT=""
  11167   "RTN","CHG CDC72",146 ,0)
  11168    S CHVPOAI I="N" S CH VPOAII=$$P OACK^CHTFL IB3(VNPT)  S:CHVPOAII =0 CHVPOAI I="N" S:CH VPOAII=1 C HVPOAII="Y "  ;DEV019 388  EW  1 1/13/13
  11169   "RTN","CHG CDC72",147 ,0)
  11170    S:'$D(HVF N) HVFN=$P (@(GLPAYH_ "IVL,101,V N,0)"),U,3 )
  11171   "RTN","CHG CDC72",148 ,0)
  11172    S:HVFN=""  HVFN=$P(@ (GLPAYH_"I VL,101,VN, 0)"),U,3)
  11173   "RTN","CHG CDC72",149 ,0)
  11174    D CMAC
  11175   "RTN","CHG CDC72",150 ,0)
  11176    Q
  11177   "RTN","CHG CDC72",151 ,0)
  11178    ;
  11179   "RTN","CHG CDC72",152 ,0)
  11180   CMAC Q:'$D (HVFN)  Q: HVFN=""
  11181   "RTN","CHG CDC72",153 ,0)
  11182    Q:'$D(^CH MVEN(HVFN, 41))
  11183   "RTN","CHG CDC72",154 ,0)
  11184    S CJ=XDOS
  11185   "RTN","CHG CDC72",155 ,0)
  11186   C1 S CJ=$O (^CHMVEN(H VFN,41,"B" ,CJ),-1) Q :'CJ
  11187   "RTN","CHG CDC72",156 ,0)
  11188    S CJ1=0
  11189   "RTN","CHG CDC72",157 ,0)
  11190   C2 S CJ1=$ O(^CHMVEN( HVFN,41,"B ",CJ,CJ1))  G:'CJ1 C1
  11191   "RTN","CHG CDC72",158 ,0)
  11192    G:'$D(^CH MVEN(HVFN, 41,CJ1,0))  C2 S CHCM ACII=$P(^( 0),U,3)
  11193   "RTN","CHG CDC72",159 ,0)
  11194    Q
  11195   "RTN","CHG CDC72",160 ,0)
  11196    ;
  11197   "RTN","CHG CDC72",161 ,0)
  11198   VNDD Q:HVE N=""
  11199   "RTN","CHG CDC72",162 ,0)
  11200    S CHDT1=0
  11201   "RTN","CHG CDC72",163 ,0)
  11202   V1D S CHDT 1=$O(@(GLP AY_"IVL,"" VEN"",HVEN ,CHDT1)"))  Q:'CHDT1
  11203   "RTN","CHG CDC72",164 ,0)
  11204    G:'$D(@(G LPAY_"IVL, ""VEN"",HV EN,CHDT1,0 )")) VN1
  11205   "RTN","CHG CDC72",165 ,0)
  11206    S RCC="", RCC=@(GLPA Y_"IVL,""V EN"",HVEN, CHDT1,0)")
  11207   "RTN","CHG CDC72",166 ,0)
  11208    S CHVENDZ =$P(RCC,U, 12)
  11209   "RTN","CHG CDC72",167 ,0)
  11210    I CHVENDZ ="" S CHVE NDZ=$P(@(G LPAY_"IVL, 3)"),U,1)
  11211   "RTN","CHG CDC72",168 ,0)
  11212    S LABL=""  K PIZ
  11213   "RTN","CHG CDC72",169 ,0)
  11214    F VCT=4:1 :11 S:$P(R CC,U,VCT)' ="" PIZ(VC T)=$P(RCC, U,VCT)
  11215   "RTN","CHG CDC72",170 ,0)
  11216    F VCT=4:1 :11 I $D(P IZ(VCT)) D
  11217   "RTN","CHG CDC72",171 ,0)
  11218    .S LABL=$ S(VCT=4:"V endor Name : ",VCT=5: "Tax ID: " ,VCT=7:"Ad dr1: ",VCT =8:"Addr2:  ",VCT=9:" City: ",VC T=10:"Stat e: ",VCT=1 1:"Zip: ", 1:"")
  11219   "RTN","CHG CDC72",172 ,0)
  11220    .S $P(PIZ (VCT),U,2) =LABL
  11221   "RTN","CHG CDC72",173 ,0)
  11222    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"VEN- DD",CHDT1, 0)) ^(0)=C HVENDZ
  11223   "RTN","CHG CDC72",174 ,0)
  11224    .S ^TMP($ J,"CCD",CH CLM,CHTYPE ,"VEN-DD", CHDT1,VCT) =PIZ(VCT)
  11225   "RTN","CHG CDC72",175 ,0)
  11226    G V1D
  11227   "RTN","CHG CDC72",176 ,0)
  11228    ;
  11229   "RTN","CHG CDC72",177 ,0)
  11230   PSBLD S CH DTT=0 K PS FLG
  11231   "RTN","CHG CDC72",178 ,0)
  11232   PS1 S CHDT T=$O(@(GLP AY_"IVL,"" VEN"",""PS "",CHDTT)" )) Q:CHDTT =""
  11233   "RTN","CHG CDC72",179 ,0)
  11234    G:'$D(@(G LPAY_"IVL, ""VEN"","" PS"",CHDTT ,0)")) PS1
  11235   "RTN","CHG CDC72",180 ,0)
  11236    S RXX=@(G LPAY_"IVL, ""VEN"","" PS"",CHDTT ,0)")
  11237   "RTN","CHG CDC72",181 ,0)
  11238    S CHVENII =$P(RXX,U, 4),CHTAXIP =$P(RXX,U, 5),CHVADR1 =$P(RXX,U, 7),CHVADR2 =$P(RXX,U, 8),CHVADRC Y=$P(RXX,U ,9),CHRTST =$P(RXX,U, 10),CHVNRZ P=$P(RXX,U ,11)
  11239   "RTN","CHG CDC72",182 ,0)
  11240    I CHRTST' ="" I $D(^ DIC(5,CHRT ST,0)) S C HRSTP=$P(^ (0),U,2)
  11241   "RTN","CHG CDC72",183 ,0)
  11242    S CHVPHS= "" I $D(@( GLPAY_"IVL ,9)")) S C HVPHS=$P(@ (GLPAY_"IV L,9)"),U,1 )
  11243   "RTN","CHG CDC72",184 ,0)
  11244    S STRING= " - (Pseud o)"
  11245   "RTN","CHG CDC72",185 ,0)
  11246    S CHVENII =CHVENII_S TRING,CHVN PHN=""
  11247   "RTN","CHG CDC72",186 ,0)
  11248    D VENPG
  11249   "RTN","CHG CDC72",187 ,0)
  11250    ;******** *****D SET VII
  11251   "RTN","CHG CDC72",188 ,0)
  11252    D:$D(@(GL PAY_"IVL," "VEN"",""P S"")")) PS VNDD
  11253   "RTN","CHG CDC72",189 ,0)
  11254    S PSFLG=" ",VFLAG=1
  11255   "RTN","CHG CDC72",190 ,0)
  11256    Q
  11257   "RTN","CHG CDC72",191 ,0)
  11258    ;
  11259   "RTN","CHG CDC72",192 ,0)
  11260   VENDD I $D (@(GLPAY_" IVL,""VEN" ",""PS"")" )) D PSVND D I '$D(@( GLPAY_"IVL ,""VEN"")" )) Q
  11261   "RTN","CHG CDC72",193 ,0)
  11262    Q:HVFN=""
  11263   "RTN","CHG CDC72",194 ,0)
  11264    S CHDT1=0
  11265   "RTN","CHG CDC72",195 ,0)
  11266   VN1 S CHDT 1=$O(@(GLP AY_"IVL,"" VEN"",HVFN ,CHDT1)"))  Q:'CHDT1
  11267   "RTN","CHG CDC72",196 ,0)
  11268    G:'$D(@(G LPAY_"IVL, ""VEN"",HV FN,CHDT1)" )) VN1
  11269   "RTN","CHG CDC72",197 ,0)
  11270    S RCC="", RCC=@(GLPA Y_"IVL,""V EN"",HVFN, CHDT1,0)")
  11271   "RTN","CHG CDC72",198 ,0)
  11272    S CHVENDZ =$P(RCC,U, 12)
  11273   "RTN","CHG CDC72",199 ,0)
  11274    I CHVENDZ ="" S CHVE NDZ=$P(@(G LPAY_"IVL, 3)"),U,1)
  11275   "RTN","CHG CDC72",200 ,0)
  11276    S LABL=""  K PIZ
  11277   "RTN","CHG CDC72",201 ,0)
  11278    F VCT=4:1 :11 S:$P(R CC,U,VCT)' ="" PIZ(VC T)=$P(RCC, U,VCT)
  11279   "RTN","CHG CDC72",202 ,0)
  11280    F VCT=4:1 :11 I $D(P IZ(VCT)) D
  11281   "RTN","CHG CDC72",203 ,0)
  11282    .S LABL=$ S(VCT=4:"V endor Name : ",VCT=5: "Tax ID: " ,VCT=7:"Ad dr1: ",VCT =8:"Addr2:  ",VCT=9:" City: ",VC T=10:"Stat e: ",VCT=1 1:"Zip: ", 1:"")
  11283   "RTN","CHG CDC72",204 ,0)
  11284    .S $P(PIZ (VCT),U,2) =LABL
  11285   "RTN","CHG CDC72",205 ,0)
  11286    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"VEN- DD",CHDT1, 0)) ^(0)=C HVENDZ
  11287   "RTN","CHG CDC72",206 ,0)
  11288    .S ^TMP($ J,"CCD",CH CLM,CHTYPE ,"VEN-DD", CHDT1,VCT) =PIZ(VCT)
  11289   "RTN","CHG CDC72",207 ,0)
  11290    G VN1
  11291   "RTN","CHG CDC72",208 ,0)
  11292    ;
  11293   "RTN","CHG CDC72",209 ,0)
  11294   PSVNDD S C HDTT=0
  11295   "RTN","CHG CDC72",210 ,0)
  11296   PSV1 S CHD TT=$O(@(GL PAY_"IVL," "VEN"",""P S"",CHDTT) ")) Q:'CHD TT
  11297   "RTN","CHG CDC72",211 ,0)
  11298    G:'$D(@(G LPAY_"IVL, ""VEN"","" PS"",CHDTT ,0)")) PSV 1
  11299   "RTN","CHG CDC72",212 ,0)
  11300    S RCC="", RCC=@(GLPA Y_"IVL,""V EN"",""PS" ",CHDTT,0) ")
  11301   "RTN","CHG CDC72",213 ,0)
  11302    S CHVENDZ =$P(RCC,U, 12)
  11303   "RTN","CHG CDC72",214 ,0)
  11304    I CHVENDZ ="" S CHVE NDZ=$P(@(G LPAY_"IVL, 3)"),U,1)
  11305   "RTN","CHG CDC72",215 ,0)
  11306    S LABL=""  K PIZ
  11307   "RTN","CHG CDC72",216 ,0)
  11308    F VCT=4:1 :11 S:$P(R CC,U,VCT)' ="" PIZ(VC T)=$P(RCC, U,VCT)
  11309   "RTN","CHG CDC72",217 ,0)
  11310    F VCT=4:1 :11 I $D(P IZ(VCT)) D
  11311   "RTN","CHG CDC72",218 ,0)
  11312    .S LABL=$ S(VCT=4:"V endor Name : ",VCT=5: "Tax ID: " ,VCT=7:"Ad dr1: ",VCT =8:"Addr2:  ",VCT=9:" City: ",VC T=10:"Stat e: ",VCT=1 1:"Zip: ", 1:"")
  11313   "RTN","CHG CDC72",219 ,0)
  11314    .S $P(PIZ (VCT),U,2) =LABL
  11315   "RTN","CHG CDC72",220 ,0)
  11316    .S:'$D(^T MP($J,"CCD ",CHCLM,CH TYPE,"PSEU DO-DD",CHD TT,0)) ^(0 )=CHVENDZ
  11317   "RTN","CHG CDC72",221 ,0)
  11318    .S ^TMP($ J,"CCD",CH CLM,CHTYPE ,"PSEUDO-D D",CHDTT,V CT)=PIZ(VC T)
  11319   "RTN","CHG CDC72",222 ,0)
  11320    G PSV1
  11321   "RTN","CHG CDC72",223 ,0)
  11322    ;
  11323   "RTN","CHG CDC72",224 ,0)
  11324   END K RCC, REC,RXX,CH BNAM,CHBSS N,CHBNDOB, CHBNREL,CH BNAD1,CHBN AD2,CHBNCT Y
  11325   "RTN","CHG CDC72",225 ,0)
  11326    K CHBNSTE ,CHBNZIP,C HBNST,CHDD Z,LAB,PIC, DCT,LABL,P IZ,VCT,CHV ENII
  11327   "RTN","CHG CDC72",226 ,0)
  11328    K CHTAXI, CHVADI,CHV ADII,CHVCT I,CHVSTII, CHVZPI,CHV PHS,CHDTT, STRING
  11329   "RTN","CHG CDC72",227 ,0)
  11330    K PSFLG,V N,CHAOBHS, CHVPGHS,CH CMACII,CHD T1,CHVENDZ ,FILE,FILE 1,FILE0
  11331   "RTN","CHG CDC72",228 ,0)
  11332    K FIL,FIL 0,FILV,FIL H
  11333   "RTN","CHG CDC72",229 ,0)
  11334    Q
  11335   "RTN","CHG CDV70")
  11336   0^28^B8023 3452
  11337   "RTN","CHG CDV70",1,0 )
  11338   CHGCDV70 ; CVA/RLC;CC D INITIAL  INPUT/EDIT S-MODULE 7  VIEW - AL L OTHER TO S ;Feb 05,  2019@10:4 2:17
  11339   "RTN","CHG CDV70",2,0 )
  11340    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  11341   "RTN","CHG CDV70",3,0 )
  11342    ;CPTS #11 834 (RLC)
  11343   "RTN","CHG CDV70",4,0 )
  11344    ;DEV00369 8 4/20/201 0 AEB
  11345   "RTN","CHG CDV70",5,0 )
  11346    ;DEV01938 8 EW 11/7/ 13  POA an d PL Phone
  11347   "RTN","CHG CDV70",6,0 )
  11348    ;CFS 03/0 8/2018 - D efect 6863 82 Display  PL ZIP.
  11349   "RTN","CHG CDV70",7,0 )
  11350    ;CFS 11/2 9/2018 - D efect 8322 80 Do not  display PL  ZIP for D ME, Travel  or Pharma cy.
  11351   "RTN","CHG CDV70",8,0 )
  11352    S U="^",( JX,CHFL)=0  F Z=1:1:1 5 S ARRAY( Z)=""
  11353   "RTN","CHG CDV70",9,0 )
  11354   A1 S JX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX))  G:JX="" EN D
  11355   "RTN","CHG CDV70",10, 0)
  11356    S RCZ=^(J X) K HDFL, EDFLG
  11357   "RTN","CHG CDV70",11, 0)
  11358    S CHDZHS= $P(RCZ,U,1 ),CHHSDT=$ P(RCZ,U,2)
  11359   "RTN","CHG CDV70",12, 0)
  11360    D:CHFL=0  HEADING
  11361   "RTN","CHG CDV70",13, 0)
  11362    D:CHFL=1  HDG
  11363   "RTN","CHG CDV70",14, 0)
  11364    S SUB=""
  11365   "RTN","CHG CDV70",15, 0)
  11366   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
  11367   "RTN","CHG CDV70",16, 0)
  11368    S XX=0
  11369   "RTN","CHG CDV70",17, 0)
  11370   A3 S XX=$O (^TMP($J," CCD",CHCLM ,CHTYPE,"H IST",JX,SU B,XX)) G:X X="" A2
  11371   "RTN","CHG CDV70",18, 0)
  11372    S RCZZ=^( XX)
  11373   "RTN","CHG CDV70",19, 0)
  11374    I CHFL=0  D BLDII^CH GCDV73 G A 3
  11375   "RTN","CHG CDV70",20, 0)
  11376    I ('$D(HD FL))&(CHFL >0) D HD1  S HDFL=1
  11377   "RTN","CHG CDV70",21, 0)
  11378    S PC=$P(R CZZ,U,1),L ABEL=$P(RC ZZ,U,2)
  11379   "RTN","CHG CDV70",22, 0)
  11380    D ARRIPT^ CHGCDV73
  11381   "RTN","CHG CDV70",23, 0)
  11382    G A3
  11383   "RTN","CHG CDV70",24, 0)
  11384    ;
  11385   "RTN","CHG CDV70",25, 0)
  11386   DEMO S LNF LG=0
  11387   "RTN","CHG CDV70",26, 0)
  11388    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"BENE-D D")) D BEN DD^CHGCDV7 6 S LNFLG= 1
  11389   "RTN","CHG CDV70",27, 0)
  11390    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"PSEUDO -DD")) D P SVNDD^CHGC DV76 S LNF LG=1
  11391   "RTN","CHG CDV70",28, 0)
  11392    I $D(^TMP ($J,"CCD", CHCLM,CHTY PE,"VEN-DD ")) D VEND D^CHGCDV76  S LNFLG=1
  11393   "RTN","CHG CDV70",29, 0)
  11394    Q
  11395   "RTN","CHG CDV70",30, 0)
  11396    ;
  11397   "RTN","CHG CDV70",31, 0)
  11398   HEADING D  UPCT S ^UT ILITY($J," CCD",CHZON E,CT)=""
  11399   "RTN","CHG CDV70",32, 0)
  11400    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"
  11401   "RTN","CHG CDV70",33, 0)
  11402    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=" "
  11403   "RTN","CHG CDV70",34, 0)
  11404    S X="X XY  W @CHBON, ""Date: "" ,@CHBOFF,P 1 S DX=32  X XY W @CH BON,""VE:  "",@CHBOFF ,P2"
  11405   "RTN","CHG CDV70",35, 0)
  11406    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHHSDT_ U_CHDZHS
  11407   "RTN","CHG CDV70",36, 0)
  11408    Q
  11409   "RTN","CHG CDV70",37, 0)
  11410    ;
  11411   "RTN","CHG CDV70",38, 0)
  11412   HDG D UPCT  S ^UTILIT Y($J,"CCD" ,CHZONE,CT )=""
  11413   "RTN","CHG CDV70",39, 0)
  11414    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"
  11415   "RTN","CHG CDV70",40, 0)
  11416    Q
  11417   "RTN","CHG CDV70",41, 0)
  11418   HD1 D UPCT  S ^UTILIT Y($J,"CCD" ,CHZONE,CT )=""
  11419   "RTN","CHG CDV70",42, 0)
  11420    S X="X XY  W @CHBON, ""Date: "" ,@CHBOFF,P 1 S DX=32  X XY W @CH BON,""User : "",@CHBO FF,P2"
  11421   "RTN","CHG CDV70",43, 0)
  11422    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHHSDT_ U_CHDZHS
  11423   "RTN","CHG CDV70",44, 0)
  11424    Q
  11425   "RTN","CHG CDV70",45, 0)
  11426    ;
  11427   "RTN","CHG CDV70",46, 0)
  11428   PRINT S (Z ,CHCHGHS)= 0,LCT=1 K  XTMP
  11429   "RTN","CHG CDV70",47, 0)
  11430    N TMPLABE L,TMPPC  ; CFS add ne w variable s for Defe ct 686382
  11431   "RTN","CHG CDV70",48, 0)
  11432   PR1 S Z=$O (ARRAY(Z))  I Z="" D: $D(LABEL)  BUILD,SPAC E K ARRAY, LABEL,PC,Z ,LCT,TMPLA BEL,TMPPC  Q
  11433   "RTN","CHG CDV70",49, 0)
  11434    S LABEL(L CT)=$P(ARR AY(Z),U,1) ,PC(LCT)=$ P(ARRAY(Z) ,U,2)
  11435   "RTN","CHG CDV70",50, 0)
  11436    G:'$D(LAB EL) PR1
  11437   "RTN","CHG CDV70",51, 0)
  11438    I LABEL(L CT)="Total  Charge: "  D  ;G PR1    Defect  686382
  11439   "RTN","CHG CDV70",52, 0)
  11440    .S CHCHGH S=PC(LCT)
  11441   "RTN","CHG CDV70",53, 0)
  11442    .;K LABEL (2),PC(2), LABEL(3),P C(3)  ;AEB  7/19/2010  DEV003698   REMOVED  LINE TO AL LOW POP TO  PRINT
  11443   "RTN","CHG CDV70",54, 0)
  11444    .S EDFLG= ""
  11445   "RTN","CHG CDV70",55, 0)
  11446    .Q
  11447   "RTN","CHG CDV70",56, 0)
  11448    ;-- Begin  Defect 68 6382 --
  11449   "RTN","CHG CDV70",57, 0)
  11450    I LABEL(L CT)="PL ZI P: " D  G  PR1
  11451   "RTN","CHG CDV70",58, 0)
  11452    .I CHTOS= "DURABLE M EDICAL"!(C HTOS="TRAV EL")!(CHTO S="PHARMAC Y") K LABE L Q  ;cfs  Defect 832 280
  11453   "RTN","CHG CDV70",59, 0)
  11454    .S LABEL( 2)=LABEL(L CT),PC(2)= PC(LCT),LA BEL(1)="", PC(1)="",L ABEL(3)="" ,PC(3)=""  ;
  11455   "RTN","CHG CDV70",60, 0)
  11456    .D BUILD  K LABEL,PC
  11457   "RTN","CHG CDV70",61, 0)
  11458    .S EDFLG= ""
  11459   "RTN","CHG CDV70",62, 0)
  11460    ;-- End D efect 6863 82 --
  11461   "RTN","CHG CDV70",63, 0)
  11462    I LABEL(L CT)="Medic aid Agency : " K XTEM P D  G PR1
  11463   "RTN","CHG CDV70",64, 0)
  11464    .S (CHMDN M,MTAX,CHM DTX,MDAD,M DMD,MAD1,M AD2,MCTY,M ST,MSTP,MZ IP)=""
  11465   "RTN","CHG CDV70",65, 0)
  11466    .Q:'$D(PC (LCT))  Q: PC(LCT)=""
  11467   "RTN","CHG CDV70",66, 0)
  11468    .S PC=PC( LCT)
  11469   "RTN","CHG CDV70",67, 0)
  11470    .Q:PC=""   Q:PC=" "   ;AEB 4/13 /2009  DEV 007079 ADD ED QUIT TO  ALLOW ROU TINE TO CO NTINUE
  11471   "RTN","CHG CDV70",68, 0)
  11472    .Q:'$D(^C HMVEN(PC,0 ))   ;DTF  FEB 2013 S LLA7820
  11473   "RTN","CHG CDV70",69, 0)
  11474    .S RC=^CH MVEN(PC,0)   ; Undefi ned error  9/2/05 mlr
  11475   "RTN","CHG CDV70",70, 0)
  11476    .S CHMDNM =$P(RC,U,1 ),MTAX=$P( RC,U,3),MD AD=$P(RC,U ,23)
  11477   "RTN","CHG CDV70",71, 0)
  11478    .S:MDAD=" " MDAD="   "
  11479   "RTN","CHG CDV70",72, 0)
  11480    .S:$D(^CH MVEN(RC,14 )) MDMD=$P (^(14),U,1 )
  11481   "RTN","CHG CDV70",73, 0)
  11482    .S:MDMD=" " MDMD="   "
  11483   "RTN","CHG CDV70",74, 0)
  11484    .S CHMDTX =MTAX_"-"_ MDAD_"-"_M DMD
  11485   "RTN","CHG CDV70",75, 0)
  11486    .I $D(^CH MVEN(PC,1) ) S RC=^(1 ) D
  11487   "RTN","CHG CDV70",76, 0)
  11488    ..S MAD1= $P(RC,U,1) ,MAD2=$P(R C,U,2),MCT Y=$P(RC,U, 3)
  11489   "RTN","CHG CDV70",77, 0)
  11490    ..S MST=$ P(RC,U,4), MZIP=$P(RC ,U,5)
  11491   "RTN","CHG CDV70",78, 0)
  11492    ..I MST'= "" I $D(^D IC(5,MST,0 )) S MSTP= $P(^(0),U, 2)
  11493   "RTN","CHG CDV70",79, 0)
  11494    .S XTEMP( CHMDNM)=CH MDTX_U_MAD 1_U_MAD2_U _MCTY_U_MS TP_U_MZIP
  11495   "RTN","CHG CDV70",80, 0)
  11496    .;-- Begi n Defect 6 86382 fix  Medicaid o verwriting  Bene Paym nt and POP 1 --
  11497   "RTN","CHG CDV70",81, 0)
  11498    .I LCT=3  D
  11499   "RTN","CHG CDV70",82, 0)
  11500    ..S TMPLA BEL=LABEL( LCT),TMPPC =PC(LCT)
  11501   "RTN","CHG CDV70",83, 0)
  11502    ..S LABEL (LCT)="",P C(LCT)=""  D BUILD
  11503   "RTN","CHG CDV70",84, 0)
  11504    ..S LABEL (1)=TMPLAB EL,PC(1)=T MPPC,LCT=2
  11505   "RTN","CHG CDV70",85, 0)
  11506    .;-- End  Defect 686 382 --
  11507   "RTN","CHG CDV70",86, 0)
  11508    .S EDFLG= ""
  11509   "RTN","CHG CDV70",87, 0)
  11510    .Q
  11511   "RTN","CHG CDV70",88, 0)
  11512    I LABEL(L CT)="Medic aid Paid:  " S RC=""  D  G PR1
  11513   "RTN","CHG CDV70",89, 0)
  11514    .S MEDPAI D=PC(LCT)
  11515   "RTN","CHG CDV70",90, 0)
  11516    .S CHMDNM =""
  11517   "RTN","CHG CDV70",91, 0)
  11518    .S CHMDNM =$O(XTEMP( CHMDNM)) Q :CHMDNM=""
  11519   "RTN","CHG CDV70",92, 0)
  11520    .S RC=XTE MP(CHMDNM)
  11521   "RTN","CHG CDV70",93, 0)
  11522    .S CHMDTX =$P(RC,U,1 ),MAD1=$P( RC,U,2),MA D2=$P(RC,U ,3)
  11523   "RTN","CHG CDV70",94, 0)
  11524    .S MCTY=$ P(RC,U,4), MSTP=$P(RC ,U,5),MZIP =$P(RC,U,6 )
  11525   "RTN","CHG CDV70",95, 0)
  11526    .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"
  11527   "RTN","CHG CDV70",96, 0)
  11528    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHMDTX _U_MEDPAID
  11529   "RTN","CHG CDV70",97, 0)
  11530    .S X="X X Y W @CHBON ,""Medicai d Agency:  "",@CHBOFF ,P1"
  11531   "RTN","CHG CDV70",98, 0)
  11532    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_CHMDNM
  11533   "RTN","CHG CDV70",99, 0)
  11534    .S X="X X Y W @CHBON ,""Addr1:  "",@CHBOFF ,P1"
  11535   "RTN","CHG CDV70",100 ,0)
  11536    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MAD1
  11537   "RTN","CHG CDV70",101 ,0)
  11538    .S X="X X Y W @CHBON ,""Addr2:  "",@CHBOFF ,P2"
  11539   "RTN","CHG CDV70",102 ,0)
  11540    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MAD2
  11541   "RTN","CHG CDV70",103 ,0)
  11542    .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 "
  11543   "RTN","CHG CDV70",104 ,0)
  11544    .D UPCT S  ^UTILITY( $J,"CCD",C HZONE,CT)= X_U_MCTY_U _MSTP_U_MZ IP
  11545   "RTN","CHG CDV70",105 ,0)
  11546    .S TAB=0, CNTR=1
  11547   "RTN","CHG CDV70",106 ,0)
  11548    .S LCT=1  K LABEL,PC
  11549   "RTN","CHG CDV70",107 ,0)
  11550    .S EDFLG= ""
  11551   "RTN","CHG CDV70",108 ,0)
  11552    .Q
  11553   "RTN","CHG CDV70",109 ,0)
  11554    S SP=""""
  11555   "RTN","CHG CDV70",110 ,0)
  11556   PR2 I LCT= 3 I $O(ARR AY(Z)) D B UILD S LCT =1,EDFLG=" " G PR1
  11557   "RTN","CHG CDV70",111 ,0)
  11558    S LCT=LCT +1
  11559   "RTN","CHG CDV70",112 ,0)
  11560    S EDFLG=" "
  11561   "RTN","CHG CDV70",113 ,0)
  11562    G PR1
  11563   "RTN","CHG CDV70",114 ,0)
  11564    ;
  11565   "RTN","CHG CDV70",115 ,0)
  11566   BINIT Q:'$ D(^TMP($J, "CCD",CHCL M,CHTYPE," BEN-II"))
  11567   "RTN","CHG CDV70",116 ,0)
  11568    S RCX=^(" BEN-II")
  11569   "RTN","CHG CDV70",117 ,0)
  11570    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)
  11571   "RTN","CHG CDV70",118 ,0)
  11572    D WRTLINE
  11573   "RTN","CHG CDV70",119 ,0)
  11574    S X="X XY  W @CHBON, ""Patient:  "",@CHBOF F,P1 S DX= 42 X XY W  @CHBON,""S SN: "",@CH BOFF,P2"
  11575   "RTN","CHG CDV70",120 ,0)
  11576    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAM_ U_CHBSSN
  11577   "RTN","CHG CDV70",121 ,0)
  11578    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"
  11579   "RTN","CHG CDV70",122 ,0)
  11580    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNDOB _U_CHBAGE_ U_CHBSEX_U _CHBNREL
  11581   "RTN","CHG CDV70",123 ,0)
  11582    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1"
  11583   "RTN","CHG CDV70",124 ,0)
  11584    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAD1
  11585   "RTN","CHG CDV70",125 ,0)
  11586    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1"
  11587   "RTN","CHG CDV70",126 ,0)
  11588    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNAD2
  11589   "RTN","CHG CDV70",127 ,0)
  11590    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"
  11591   "RTN","CHG CDV70",128 ,0)
  11592    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHBNCTY _U_CHBNST_ U_CHBNZIP
  11593   "RTN","CHG CDV70",129 ,0)
  11594    Q
  11595   "RTN","CHG CDV70",130 ,0)
  11596    ;
  11597   "RTN","CHG CDV70",131 ,0)
  11598   VINIT S (R TC,RPC)=""
  11599   "RTN","CHG CDV70",132 ,0)
  11600    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 ")
  11601   "RTN","CHG CDV70",133 ,0)
  11602    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 ")
  11603   "RTN","CHG CDV70",134 ,0)
  11604    I RTC=""  D  G VIN
  11605   "RTN","CHG CDV70",135 ,0)
  11606    .S (CHVEN RI,CHTAXIP ,CHVADR1,C HVADR2,CHV ADRCY,CHRS TP,CHVNRZP )=""
  11607   "RTN","CHG CDV70",136 ,0)
  11608    .S (CHVPH S,CHVNPHN, CHVPGHS)=" "
  11609   "RTN","CHG CDV70",137 ,0)
  11610    .Q
  11611   "RTN","CHG CDV70",138 ,0)
  11612    S CHVENRI =$P(RTC,U, 1),CHTAXIP =$P(RTC,U, 2),CHVADR1 =$P(RTC,U, 3)
  11613   "RTN","CHG CDV70",139 ,0)
  11614    S CHVADR2 =$P(RTC,U, 4),CHVADRC Y=$P(RTC,U ,5),CHRSTP =$P(RTC,U, 6)
  11615   "RTN","CHG CDV70",140 ,0)
  11616    S CHVNRZP =$P(RTC,U, 7),CHVNPHN =$P(RTC,U, 8)
  11617   "RTN","CHG CDV70",141 ,0)
  11618   VIN I RPC= "" D  G VI NP
  11619   "RTN","CHG CDV70",142 ,0)
  11620    .S (CHVEN PI,CHVADP1 ,CHVADP2,C HVADPCY,CH PSTP,CHVNP ZP,CHVPGHS ,CHCMACII) =""
  11621   "RTN","CHG CDV70",143 ,0)
  11622    .S (CHCMA CII,CHTAXI P,CHVNPHN, CHVPOA,CHV PPPN)=""   ;DEV019388   EW  11/1 3/13
  11623   "RTN","CHG CDV70",144 ,0)
  11624    .Q
  11625   "RTN","CHG CDV70",145 ,0)
  11626    S CHVENPI =$P(RPC,U, 1),CHVADP1 =$P(RPC,U, 2),CHVADP2 =$P(RPC,U, 3)
  11627   "RTN","CHG CDV70",146 ,0)
  11628    S CHVADPC Y=$P(RPC,U ,4),CHPSTP =$P(RPC,U, 5),CHVNPZP =$P(RPC,U, 6)
  11629   "RTN","CHG CDV70",147 ,0)
  11630    S CHVPPPN =$P(RPC,U, 7),CHVPOA= $P(RPC,U,8 ),CHCMACII =$P(RPC,U, 9)  ;DEV01 9388  EW   11/13/13
  11631   "RTN","CHG CDV70",148 ,0)
  11632   VINP D WRT LINE
  11633   "RTN","CHG CDV70",149 ,0)
  11634    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
  11635   "RTN","CHG CDV70",150 ,0)
  11636    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHTAXIP _U_CHVPOA_ U_CHCMACII   ;DEV0193 88  EW  11 /13/13
  11637   "RTN","CHG CDV70",151 ,0)
  11638    S X="X XY  W @CHBON, ""RT Ven:  "",@CHBOFF ,P1 S DX=4 0 X XY W @ CHBON,""PL  Ven: "",@ CHBOFF,P2"
  11639   "RTN","CHG CDV70",152 ,0)
  11640    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVENRI _U_CHVENPI
  11641   "RTN","CHG CDV70",153 ,0)
  11642    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
  11643   "RTN","CHG CDV70",154 ,0)
  11644    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVNPHN _U_CHVPPPN   ;DEV0193 88  EW  11 /13/13
  11645   "RTN","CHG CDV70",155 ,0)
  11646    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=40  X XY W @C HBON,""Add r1: "",@CH BOFF,P2"
  11647   "RTN","CHG CDV70",156 ,0)
  11648    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADR1 _U_CHVADP1
  11649   "RTN","CHG CDV70",157 ,0)
  11650    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1 S DX=40  X XY W @C HBON,""Add r2: "",@CH BOFF,P2"
  11651   "RTN","CHG CDV70",158 ,0)
  11652    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADR2 _U_CHVADP2
  11653   "RTN","CHG CDV70",159 ,0)
  11654    S X="X XY  W @CHBON, ""City: "" ,@CHBOFF,P 1 S DX=40  X XY W @CH BON,""City : "",@CHBO FF,P2"
  11655   "RTN","CHG CDV70",160 ,0)
  11656    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHVADRC Y_U_CHVADP CY
  11657   "RTN","CHG CDV70",161 ,0)
  11658    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"
  11659   "RTN","CHG CDV70",162 ,0)
  11660    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHRSTP_ U_CHVNRZP_ U_CHPSTP_U _CHVNPZP
  11661   "RTN","CHG CDV70",163 ,0)
  11662    D WRTLINE
  11663   "RTN","CHG CDV70",164 ,0)
  11664    Q
  11665   "RTN","CHG CDV70",165 ,0)
  11666    ;
  11667   "RTN","CHG CDV70",166 ,0)
  11668   SPACE I CH FL=0 D UPC T S ^UTILI TY($J,"CCD ",CHZONE,C T)=""
  11669   "RTN","CHG CDV70",167 ,0)
  11670    Q
  11671   "RTN","CHG CDV70",168 ,0)
  11672    ;
  11673   "RTN","CHG CDV70",169 ,0)
  11674   PRT S N=0, LCT=1
  11675   "RTN","CHG CDV70",170 ,0)
  11676   PT1 S N=$O (PX(N)) I  N="" D:$D( LABEL) BUI LD K PX,LA BEL,PC,N,L CT Q
  11677   "RTN","CHG CDV70",171 ,0)
  11678    S LABEL(L CT)=$P(PX( N),U,1),PC (LCT)=$P(P X(N),U,2)
  11679   "RTN","CHG CDV70",172 ,0)
  11680    I LABEL(L CT)="Px Ch arge: " S  LCT=3
  11681   "RTN","CHG CDV70",173 ,0)
  11682    I LCT=3 I  $O(PX(N))  D BUILD S  LCT=1 K L ABEL,PC G  PT1
  11683   "RTN","CHG CDV70",174 ,0)
  11684    S LCT=LCT +1
  11685   "RTN","CHG CDV70",175 ,0)
  11686    G PT1
  11687   "RTN","CHG CDV70",176 ,0)
  11688    ;
  11689   "RTN","CHG CDV70",177 ,0)
  11690   BUILD S X1 ="X XY W @ CHBON,"
  11691   "RTN","CHG CDV70",178 ,0)
  11692    S X2=" S  DX=32 X XY  W @CHBON, "
  11693   "RTN","CHG CDV70",179 ,0)
  11694    S X3=" S  DX=56 X XY  W @CHBON, "
  11695   "RTN","CHG CDV70",180 ,0)
  11696    S X4=",@C HBOFF,P1", X5=",@CHBO FF,P2",X6= ",@CHBOFF, P3"
  11697   "RTN","CHG CDV70",181 ,0)
  11698    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
  11699   "RTN","CHG CDV70",182 ,0)
  11700    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
  11701   "RTN","CHG CDV70",183 ,0)
  11702    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)
  11703   "RTN","CHG CDV70",184 ,0)
  11704    Q
  11705   "RTN","CHG CDV70",185 ,0)
  11706    ;
  11707   "RTN","CHG CDV70",186 ,0)
  11708   WRTLINE I  CHFL=0 D U PCT S ^UTI LITY($J,"C CD",CHZONE ,CT)="" Q
  11709   "RTN","CHG CDV70",187 ,0)
  11710   UPCT S (CT ,^UTILITY( $J,"CCD",C HZONE,0))= CT+1 Q
  11711   "RTN","CHG CDV70",188 ,0)
  11712    ;
  11713   "RTN","CHG CDV70",189 ,0)
  11714   END K N,Z, JX,X1,X2,X 3,X4,PC,PX ,SP,RCZ,RC ZZ,SUB,CHD ZHS,CHHSDT ,LABEL,HDF L
  11715   "RTN","CHG CDV70",190 ,0)
  11716    K LCT,ARR AY,CHFL
  11717   "RTN","CHG CDV70",191 ,0)
  11718    Q
  11719   "RTN","CHG CDV73")
  11720   0^29^B4105 7918
  11721   "RTN","CHG CDV73",1,0 )
  11722   CHGCDV73 ; CVA/RLC;CC D EDIT HIS TORY-MODUL E 7 VIEW-2  - ALL OTH ER TOS ;Fe b 05, 2019 @11:20:56
  11723   "RTN","CHG CDV73",2,0 )
  11724    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  11725   "RTN","CHG CDV73",3,0 )
  11726    ;CPTS #11 834 (RLC)
  11727   "RTN","CHG CDV73",4,0 )
  11728    ;DEV00369 8 4/20/201 0 AEB
  11729   "RTN","CHG CDV73",5,0 )
  11730    ;CFS 03/0 7/2018 - D efect 6863 82 Add PL  ZIP.
  11731   "RTN","CHG CDV73",6,0 )
  11732   BLDII S PC =$P(RCZZ,U ,1),LABEL= $P(RCZZ,U, 2)
  11733   "RTN","CHG CDV73",7,0 )
  11734    S:LABEL=" Type Servi ce: " ARRA Y(1)=LABEL _U_PC
  11735   "RTN","CHG CDV73",8,0 )
  11736    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  11737   "RTN","CHG CDV73",9,0 )
  11738    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  11739   "RTN","CHG CDV73",10, 0)
  11740    S:LABEL=" DOS: " ARR AY(4)=LABE L_U_PC
  11741   "RTN","CHG CDV73",11, 0)
  11742    S:LABEL=" POS: " ARR AY(5)=LABE L_U_PC
  11743   "RTN","CHG CDV73",12, 0)
  11744    S:LABEL=" Pay Provid er: " ARRA Y(6)=LABEL _U_PC
  11745   "RTN","CHG CDV73",13, 0)
  11746    S:LABEL=" MCCR Revie w: " ARRAY (7)=LABEL_ U_PC
  11747   "RTN","CHG CDV73",14, 0)
  11748    S:LABEL=" OHI Type:  " ARRAY(8) =LABEL_U_P C
  11749   "RTN","CHG CDV73",15, 0)
  11750    S:LABEL=" OHI Begin:  " ARRAY(9 )=LABEL_U_ PC
  11751   "RTN","CHG CDV73",16, 0)
  11752    S:LABEL=" OHI End: "  ARRAY(10) =LABEL_U_P C
  11753   "RTN","CHG CDV73",17, 0)
  11754    S:LABEL=" OHI Name:  " ARRAY(11 )=LABEL_U_ PC
  11755   "RTN","CHG CDV73",18, 0)
  11756    S:LABEL=" OHI Paymt:  " ARRAY(1 2)=LABEL_U _PC
  11757   "RTN","CHG CDV73",19, 0)
  11758    S:LABEL=" Bene Paymt : " ARRAY( 13)=LABEL_ U_PC
  11759   "RTN","CHG CDV73",20, 0)
  11760    S:LABEL=" POP1: " AR RAY(14)=LA BEL_U_PC   ;AEB 7/19/ 2010 DEV00 3698
  11761   "RTN","CHG CDV73",21, 0)
  11762    S:LABEL=" Medicaid A gency: " A RRAY(15)=L ABEL_U_PC
  11763   "RTN","CHG CDV73",22, 0)
  11764    S:LABEL=" Medicaid P aid: " ARR AY(16)=LAB EL_U_PC
  11765   "RTN","CHG CDV73",23, 0)
  11766    S:LABEL=" Total Char ge: " ARRA Y(17)=LABE L_U_PC
  11767   "RTN","CHG CDV73",24, 0)
  11768    S:LABEL=" PL ZIP: "  ARRAY(18)= LABEL_U_PC   ;Defect  686382 Add  PL ZIP.
  11769   "RTN","CHG CDV73",25, 0)
  11770    K PC,LABE L
  11771   "RTN","CHG CDV73",26, 0)
  11772    Q
  11773   "RTN","CHG CDV73",27, 0)
  11774    ;
  11775   "RTN","CHG CDV73",28, 0)
  11776   ARRIPT S:L ABEL="Type  Service:  " ARRAY(1) =LABEL_U_P C
  11777   "RTN","CHG CDV73",29, 0)
  11778    S:LABEL=" Type of Bi ll: " ARRA Y(2)=LABEL _U_PC
  11779   "RTN","CHG CDV73",30, 0)
  11780    S:LABEL=" PCN/PAN: "  ARRAY(3)= LABEL_U_PC
  11781   "RTN","CHG CDV73",31, 0)
  11782    S:LABEL=" DOS: " ARR AY(4)=LABE L_U_PC
  11783   "RTN","CHG CDV73",32, 0)
  11784    S:LABEL=" POS: " ARR AY(5)=LABE L_U_PC
  11785   "RTN","CHG CDV73",33, 0)
  11786    S:LABEL=" Pay Provid er: " ARRA Y(6)=LABEL _U_PC
  11787   "RTN","CHG CDV73",34, 0)
  11788    S:LABEL=" MCCR Revie w: " ARRAY (7)=LABEL_ U_PC
  11789   "RTN","CHG CDV73",35, 0)
  11790    S:LABEL=" OHI Type:  " ARRAY(8) =LABEL_U_P C
  11791   "RTN","CHG CDV73",36, 0)
  11792    S:LABEL=" OHI Begin:  " ARRAY(9 )=LABEL_U_ PC
  11793   "RTN","CHG CDV73",37, 0)
  11794    S:LABEL=" OHI End: "  ARRAY(10) =LABEL_U_P C
  11795   "RTN","CHG CDV73",38, 0)
  11796    S:LABEL=" OHI Name:  " ARRAY(11 )=LABEL_U_ PC
  11797   "RTN","CHG CDV73",39, 0)
  11798    S:LABEL=" OHI Paymt:  " ARRAY(1 2)=LABEL_U _PC
  11799   "RTN","CHG CDV73",40, 0)
  11800    S:LABEL=" Bene Paymt : " ARRAY( 13)=LABEL_ U_PC
  11801   "RTN","CHG CDV73",41, 0)
  11802    S:LABEL=" Medicaid A gency: " A RRAY(14)=L ABEL_U_PC
  11803   "RTN","CHG CDV73",42, 0)
  11804    S:LABEL=" Medicaid P aid: " ARR AY(15)=LAB EL_U_PC
  11805   "RTN","CHG CDV73",43, 0)
  11806    S:LABEL=" Total Char ge: " ARRA Y(16)=LABE L_U_PC
  11807   "RTN","CHG CDV73",44, 0)
  11808    K PC,LABE L
  11809   "RTN","CHG CDV73",45, 0)
  11810    Q
  11811   "RTN","CHG CDV73",46, 0)
  11812   LOOP K VEN FLG
  11813   "RTN","CHG CDV73",47, 0)
  11814    D VENHIS  D:$D(VENFL G) PRT
  11815   "RTN","CHG CDV73",48, 0)
  11816    D ^CHGCDV 74
  11817   "RTN","CHG CDV73",49, 0)
  11818    D EDICLM
  11819   "RTN","CHG CDV73",50, 0)
  11820    G END
  11821   "RTN","CHG CDV73",51, 0)
  11822    ;
  11823   "RTN","CHG CDV73",52, 0)
  11824   END Q
  11825   "RTN","CHG CDV73",53, 0)
  11826    ;
  11827   "RTN","CHG CDV73",54, 0)
  11828   VENHIS Q:' $D(^TMP($J ,"CCD",CHC LM,CHTYPE, "VENPTHS", JX))
  11829   "RTN","CHG CDV73",55, 0)
  11830    I CHFL=0  D HDG^CHGC DV70 S CHF L=1
  11831   "RTN","CHG CDV73",56, 0)
  11832    S VX=0,N= 1
  11833   "RTN","CHG CDV73",57, 0)
  11834   VEN1 S VX= $O(^TMP($J ,"CCD",CHC LM,CHTYPE, "VENPTHS", JX,VX)) I  VX="" Q
  11835   "RTN","CHG CDV73",58, 0)
  11836    S CHVENHS =$P(^TMP($ J,"CCD",CH CLM,CHTYPE ,"VENPTHS" ,JX,VX),U, 1)
  11837   "RTN","CHG CDV73",59, 0)
  11838    D  I ($D( PX))&('$D( HDFL))&(CH FL>0) D HD 1^CHGCDP7  S HDFL=1
  11839   "RTN","CHG CDV73",60, 0)
  11840    .I CHVENH S'="" S LA BEL="Vendo r: ",PC=CH VENHS,PX(N )=LABEL_U_ PC,N=N+1
  11841   "RTN","CHG CDV73",61, 0)
  11842    S VENFLG= ""
  11843   "RTN","CHG CDV73",62, 0)
  11844    G VEN1
  11845   "RTN","CHG CDV73",63, 0)
  11846    ;
  11847   "RTN","CHG CDV73",64, 0)
  11848   EDICLM S C HOHTYCD=""
  11849   "RTN","CHG CDV73",65, 0)
  11850   E1 S CHOHT YCD=$O(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD)) Q :CHOHTYCD= ""
  11851   "RTN","CHG CDV73",66, 0)
  11852    S CHEDOHN M=""
  11853   "RTN","CHG CDV73",67, 0)
  11854   E2 S CHEDO HNM=$O(^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM)) G: CHEDOHNM=" " E1
  11855   "RTN","CHG CDV73",68, 0)
  11856    D EDIPRT
  11857   "RTN","CHG CDV73",69, 0)
  11858    S CLADJGR P=""
  11859   "RTN","CHG CDV73",70, 0)
  11860   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
  11861   "RTN","CHG CDV73",71, 0)
  11862    W !!,"OHI  Claim Adj ustment Gr oup: ",CLA DJGRP
  11863   "RTN","CHG CDV73",72, 0)
  11864    S REC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM,CLAD JGRP,1)
  11865   "RTN","CHG CDV73",73, 0)
  11866    S RCC=^TM P($J,"CCD" ,CHCLM,CHT YPE,"EDI-I I","BB",CH OHTYCD,CHE DOHNM,CLAD JGRP,2)
  11867   "RTN","CHG CDV73",74, 0)
  11868    S CLAJCD1 =$P(REC,U, 1),CLADJAM 1=$P(REC,U ,2),CLADJQ T1=$P(REC, U,3)
  11869   "RTN","CHG CDV73",75, 0)
  11870    D:CLAJCD1 '=""
  11871   "RTN","CHG CDV73",76, 0)
  11872    .S CDI=0, CREC=""
  11873   "RTN","CHG CDV73",77, 0)
  11874   E31 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD1,CDI))  Q:'CDI
  11875   "RTN","CHG CDV73",78, 0)
  11876    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E31 S  CREC=^(0)
  11877   "RTN","CHG CDV73",79, 0)
  11878    .S CLAJCD 1C=$P(CREC ,U,1),CLAJ CD1P=$P(CR EC,U,2)
  11879   "RTN","CHG CDV73",80, 0)
  11880    .W !?4,"A dj Reason  Code: (",C LAJCD1C,") -"
  11881   "RTN","CHG CDV73",81, 0)
  11882    .I $L(CLA JCD1P)>55  W ?28,$E(C LAJCD1P,1, 55),!?28,$ E(CLAJCD1P ,56,100)
  11883   "RTN","CHG CDV73",82, 0)
  11884    .E  W ?28 ,CLAJCD1P
  11885   "RTN","CHG CDV73",83, 0)
  11886    .W !?4,"A dj Quantit y: ",CLADJ QT1
  11887   "RTN","CHG CDV73",84, 0)
  11888    .W !?4,"A dj Amount:    ",CLADJ AM1
  11889   "RTN","CHG CDV73",85, 0)
  11890    .Q
  11891   "RTN","CHG CDV73",86, 0)
  11892    S CLAJCD2 =$P(REC,U, 4),CLADJAM 2=$P(REC,U ,5),CLADJQ T2=$P(REC, U,6)
  11893   "RTN","CHG CDV73",87, 0)
  11894    D:CLAJCD2 '=""
  11895   "RTN","CHG CDV73",88, 0)
  11896    .S CDI=0, CREC=""
  11897   "RTN","CHG CDV73",89, 0)
  11898   E32 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD2,CDI))  Q:'CDI
  11899   "RTN","CHG CDV73",90, 0)
  11900    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E32 S  CREC=^(0)
  11901   "RTN","CHG CDV73",91, 0)
  11902    .S CLAJCD 2C=$P(CREC ,U,1),CLAJ CD2P=$P(CR EC,U,2)
  11903   "RTN","CHG CDV73",92, 0)
  11904    .W !?4,"A dj Reason  Code: (",C LAJCD2C,") -"
  11905   "RTN","CHG CDV73",93, 0)
  11906    .I $L(CLA JCD2P)>55  W ?28,$E(C LAJCD2P,1, 55),!?28,$ E(CLAJCD2P ,56,100)
  11907   "RTN","CHG CDV73",94, 0)
  11908    .E  W ?28 ,CLAJCD2P
  11909   "RTN","CHG CDV73",95, 0)
  11910    .W !?4,"A dj Quantit y: ",CLADJ QT2
  11911   "RTN","CHG CDV73",96, 0)
  11912    .W !?4,"A dj Amount:    ",CLADJ AM2
  11913   "RTN","CHG CDV73",97, 0)
  11914    .Q
  11915   "RTN","CHG CDV73",98, 0)
  11916    S CLAJCD3 =$P(REC,U, 7),CLADJAM 3=$P(REC,U ,8),CLADJQ T3=$P(REC, U,9)
  11917   "RTN","CHG CDV73",99, 0)
  11918    D:CLAJCD3 '=""
  11919   "RTN","CHG CDV73",100 ,0)
  11920    .S CDI=0, CREC=""
  11921   "RTN","CHG CDV73",101 ,0)
  11922   E33 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD3,CDI))  Q:'CDI
  11923   "RTN","CHG CDV73",102 ,0)
  11924    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E33 S  CREC=^(0)
  11925   "RTN","CHG CDV73",103 ,0)
  11926    .S CLAJCD 3C=$P(CREC ,U,1),CLAJ CD3P=$P(CR EC,U,2)
  11927   "RTN","CHG CDV73",104 ,0)
  11928    .W !?4,"A dj Reason  Code: (",C LAJCD3C,") -"
  11929   "RTN","CHG CDV73",105 ,0)
  11930    .I $L(CLA JCD3P)>55  W ?28,$E(C LAJCD3P,1, 55),!?28,$ E(CLAJCD3P ,56,100)
  11931   "RTN","CHG CDV73",106 ,0)
  11932    .E  W ?28 ,CLAJCD3P
  11933   "RTN","CHG CDV73",107 ,0)
  11934    .W !?4,"A dj Quantit y: ",CLADJ QT3
  11935   "RTN","CHG CDV73",108 ,0)
  11936    .W !?4,"A dj Amount:    ",CLADJ AM3
  11937   "RTN","CHG CDV73",109 ,0)
  11938    .Q
  11939   "RTN","CHG CDV73",110 ,0)
  11940    S CLAJCD4 =$P(RCC,U, 1),CLADJAM 4=$P(RCC,U ,2),CLADJQ T4=$P(RCC, U,3)
  11941   "RTN","CHG CDV73",111 ,0)
  11942    D:CLAJCD4 '=""
  11943   "RTN","CHG CDV73",112 ,0)
  11944    .S CDI=0, CREC=""
  11945   "RTN","CHG CDV73",113 ,0)
  11946   E34 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD4,CDI))  Q:'CDI
  11947   "RTN","CHG CDV73",114 ,0)
  11948    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E34 S  CREC=^(0)
  11949   "RTN","CHG CDV73",115 ,0)
  11950    .S CLAJCD 4C=$P(CREC ,U,1),CLAJ CD4P=$P(CR EC,U,2)
  11951   "RTN","CHG CDV73",116 ,0)
  11952    .W !?4,"A dj Reason  Code: (",C LAJCD4C,") -"
  11953   "RTN","CHG CDV73",117 ,0)
  11954    .I $L(CLA JCD4P)>55  W ?28,$E(C LAJCD4P,1, 55),!?28,$ E(CLAJCD4P ,56,100)
  11955   "RTN","CHG CDV73",118 ,0)
  11956    .E  W ?28 ,CLAJCD4P
  11957   "RTN","CHG CDV73",119 ,0)
  11958    .W !?4,"A dj Quantit y: ",CLADJ QT4
  11959   "RTN","CHG CDV73",120 ,0)
  11960    .W !?4,"A dj Amount:    ",CLADJ AM4
  11961   "RTN","CHG CDV73",121 ,0)
  11962    .Q
  11963   "RTN","CHG CDV73",122 ,0)
  11964    S CLAJCD5 =$P(RCC,U, 4),CLADJAM 5=$P(RCC,U ,5),CLADJQ T5=$P(RCC, U,6)
  11965   "RTN","CHG CDV73",123 ,0)
  11966    D:CLAJCD5 '=""
  11967   "RTN","CHG CDV73",124 ,0)
  11968    .S CDI=0, CREC=""
  11969   "RTN","CHG CDV73",125 ,0)
  11970   E35 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD5,CDI))  Q:'CDI
  11971   "RTN","CHG CDV73",126 ,0)
  11972    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E35 S  CREC=^(0)
  11973   "RTN","CHG CDV73",127 ,0)
  11974    .S CLAJCD 5C=$P(CREC ,U,1),CLAJ CD5P=$P(CR EC,U,2)
  11975   "RTN","CHG CDV73",128 ,0)
  11976    .W !?4,"A dj Reason  Code: (",C LAJCD5C,") -"
  11977   "RTN","CHG CDV73",129 ,0)
  11978    .I $L(CLA JCD5P)>55  W ?28,$E(C LAJCD5P,1, 55),!?28,$ E(CLAJCD5P ,56,100)
  11979   "RTN","CHG CDV73",130 ,0)
  11980    .E  W ?28 ,CLAJCD5P
  11981   "RTN","CHG CDV73",131 ,0)
  11982    .W !?4,"A dj Quantit y: ",CLADJ QT5
  11983   "RTN","CHG CDV73",132 ,0)
  11984    .W !?4,"A dj Amount:    ",CLADJ AM5
  11985   "RTN","CHG CDV73",133 ,0)
  11986    .Q
  11987   "RTN","CHG CDV73",134 ,0)
  11988    S CLAJCD6 =$P(RCC,U, 7),CLADJAM 6=$P(RCC,U ,8),CLADJQ T6=$P(RCC, U,9)
  11989   "RTN","CHG CDV73",135 ,0)
  11990    D:CLAJCD6 '=""
  11991   "RTN","CHG CDV73",136 ,0)
  11992    .S CDI=0, CREC=""
  11993   "RTN","CHG CDV73",137 ,0)
  11994   E36 .S CDI =$O(^CHMXD IC(741201. 16,"B",CLA JCD6,CDI))  Q:'CDI
  11995   "RTN","CHG CDV73",138 ,0)
  11996    .G:'$D(^C HMXDIC(741 201.16,CDI ,0)) E36 S  CREC=^(0)
  11997   "RTN","CHG CDV73",139 ,0)
  11998    .S CLAJCD 6C=$P(CREC ,U,1),CLAJ CD6P=$P(CR EC,U,2)
  11999   "RTN","CHG CDV73",140 ,0)
  12000    .W !?4,"A dj Reason  Code: (",C LAJCD6C,") -"
  12001   "RTN","CHG CDV73",141 ,0)
  12002    .I $L(CLA JCD6P)>55  W ?28,$E(C LAJCD6P,1, 55),!?28,$ E(CLAJCD6P ,56,100)
  12003   "RTN","CHG CDV73",142 ,0)
  12004    .E  W ?28 ,CLAJCD6P
  12005   "RTN","CHG CDV73",143 ,0)
  12006    .W !?4,"A dj Quantit y: ",CLADJ QT6
  12007   "RTN","CHG CDV73",144 ,0)
  12008    .W !?4,"A dj Amount:    ",CLADJ AM6
  12009   "RTN","CHG CDV73",145 ,0)
  12010    .Q
  12011   "RTN","CHG CDV73",146 ,0)
  12012    G E3
  12013   "RTN","CHG CDV73",147 ,0)
  12014    ;
  12015   "RTN","CHG CDV73",148 ,0)
  12016   EDIPRT S X ="X XY W @ CHBON,""OH I Insuranc e Type Cod e: "",@CHB OFF,P1"
  12017   "RTN","CHG CDV73",149 ,0)
  12018    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHOHTYC D
  12019   "RTN","CHG CDV73",150 ,0)
  12020    S X="S DX =15 X XY W  @CHBON,"" OHI Name:  "",@CHBOFF ,P1"
  12021   "RTN","CHG CDV73",151 ,0)
  12022    D UPCT S  ^UTILITY($ J,"CCD",CH ZONE,CT)=X _U_CHEDOHN M
  12023   "RTN","CHG CDV73",152 ,0)
  12024    Q
  12025   "RTN","CHG CDV73",153 ,0)
  12026    ;
  12027   "RTN","CHG CDV73",154 ,0)
  12028   PRT S N=0, CNT=1
  12029   "RTN","CHG CDV73",155 ,0)
  12030   P1 S N=$O( PX(N)) I N ="" D:$D(L ABEL) BUIL D K PX,LAB EL,PC,N,CN T Q
  12031   "RTN","CHG CDV73",156 ,0)
  12032    S LABEL(C NT)=$P(PX( N),U,1),PC (CNT)=$P(P X(N),U,2)
  12033   "RTN","CHG CDV73",157 ,0)
  12034    G:(LABEL( CNT)="")!( PC(CNT)="" ) P1
  12035   "RTN","CHG CDV73",158 ,0)
  12036   P2 I CNT=3  D BUILD S  CNT=1 W !  K LABEL,P C G P1
  12037   "RTN","CHG CDV73",159 ,0)
  12038    S CNT=CNT +1
  12039   "RTN","CHG CDV73",160 ,0)
  12040    G P1
  12041   "RTN","CHG CDV73",161 ,0)
  12042    ;
  12043   "RTN","CHG CDV73",162 ,0)
  12044   BUILD I $D (LABEL(3))  W LABEL(1 ),PC(1),?2 8,LABEL(2) ,PC(2),?56 ,LABEL(3), PC(3) Q
  12045   "RTN","CHG CDV73",163 ,0)
  12046    I $D(LABE L(2)) W LA BEL(1),PC( 1),?28,LAB EL(2),PC(2 ) W:(CNT<3 ) ! Q
  12047   "RTN","CHG CDV73",164 ,0)
  12048    I $D(LABE L(1)) W LA BEL(1),PC( 1) W:(CNT< 3) !
  12049   "RTN","CHG CDV73",165 ,0)
  12050    Q
  12051   "RTN","CHG CDV73",166 ,0)
  12052    ;
  12053   "RTN","CHG CDV73",167 ,0)
  12054   WRTLINE D  UPCT S ^UT ILITY($J," CCD",CHZON E,CT)="" Q
  12055   "RTN","CHG CDV73",168 ,0)
  12056   UPCT S (CT ,^UTILITY( $J,"CCD",C HZONE,0))= CT+1 Q
  12057   "RTN","CHG CP2")
  12058   0^30^B1156 11366
  12059   "RTN","CHG CP2",1,0)
  12060   CHGCP2 ;CV A/CR;FORMA T QAQ CPD  CLAIM OUTP UT FOR DIS PLAY IN QU E ;Aug 30,  2018@08:1 5:26
  12061   "RTN","CHG CP2",2,0)
  12062    ;;1.0;CHA MPVA SYSTE M;**11**;J ULY 4, 199 0;Build 5
  12063   "RTN","CHG CP2",3,0)
  12064    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  12065   "RTN","CHG CP2",4,0)
  12066    ;             CHZONE  - SCREEN  REGION
  12067   "RTN","CHG CP2",5,0)
  12068    ;CPTS #10 857* BY RL C, CPTS #1 0873* BY R LC, #11567 *-RLC 2/20 /97, #1219 6*
  12069   "RTN","CHG CP2",6,0)
  12070    ;CPTS #13 310* (RLC) , #13610*  (RLC), #15 191* (RLC) , PT 16110  (Y2K)
  12071   "RTN","CHG CP2",7,0)
  12072    ;CPTS #16 432 (RLC)  - MODIFICA TIONS MADE  FOR IPS S CREEN SCRA PING
  12073   "RTN","CHG CP2",8,0)
  12074    ;DEV00480 5 1/20/201 0 AEB
  12075   "RTN","CHG CP2",9,0)
  12076    ;DEV00782 0 EW 4/18/ 11
  12077   "RTN","CHG CP2",10,0)
  12078    ;SBB 03/0 8/2018 cpe 001-006 De fect 69437 0 PLZIP AD DITION
  12079   "RTN","CHG CP2",11,0)
  12080    ;NCD 11/2 9/2018 DEF ECT 832284  PL ZIP sh owing up o n all queu es for DME , TRV and  RXT
  12081   "RTN","CHG CP2",12,0)
  12082    ;
  12083   "RTN","CHG CP2",13,0)
  12084   EN1 N (DFN ,BFN,CHZON E,CHCLM,CH TYP,CHI,XY ,GLPAY,GLD FN,GLELG,C HPROG,CHPG PT)
  12085   "RTN","CHG CP2",14,0)
  12086    S (CHDB,C HDOB,CHSEX ,CHAGE,CHT DDT,CHBRDT ,CHVNPG)=" "
  12087   "RTN","CHG CP2",15,0)
  12088    S:'$D(^UT ILITY($J," QAQ",CHZON E,0)) ^UTI LITY($J,"Q AQ",CHZONE ,0)=0
  12089   "RTN","CHG CP2",16,0)
  12090    S CT=^UTI LITY($J,"Q AQ",CHZONE ,0),U="^"
  12091   "RTN","CHG CP2",17,0)
  12092    D CHECK^C HGCPU2 S X 1=CHCLM D  PROGTYP^CH FCD001
  12093   "RTN","CHG CP2",18,0)
  12094    Q:'$D(@(G LPAY_"CHCL M,0)"))
  12095   "RTN","CHG CP2",19,0)
  12096    S CHVE=""
  12097   "RTN","CHG CP2",20,0)
  12098    D CLM^CHG CP21
  12099   "RTN","CHG CP2",21,0)
  12100    D BENE^CH GCP21
  12101   "RTN","CHG CP2",22,0)
  12102    D VEN^CHG CP21 D DUZ
  12103   "RTN","CHG CP2",23,0)
  12104    ;S:'CHTAA  CHTAA="Un d"  ;DEV78 20 EW 4/18 /11
  12105   "RTN","CHG CP2",24,0)
  12106    S X="X XY  W @CHBON, ""PDI: "", @CHBOFF,P1  S DX=28 X  XY W @CHB ON,""Claim  #: "",@CH BOFF,P2 S  DX=53 X XY  W @CHBON, ""Bene: "" ,@CHBOFF,P 3"
  12107   "RTN","CHG CP2",25,0)
  12108    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHPDI_U _CHCLMO_U_ CHBENE
  12109   "RTN","CHG CP2",26,0)
  12110    S X="X XY  W @CHBON, ""PROGRAM:  "",@CHBOF F,P1 S DX= 28 X XY W  @CHBON,""T OS: "",@CH BOFF,P2 S  DX=53 X XY  W @CHBON, ""SPONSOR:  "",@CHBOF F,P3"
  12111   "RTN","CHG CP2",27,0)
  12112    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHPROG_ U_CHTOS_U_ CHSPON
  12113   "RTN","CHG CP2",28,0)
  12114    S X="S DX =28 X XY W  @CHBON,"" STATUS: "" ,@CHBOFF,P 1 S DX=53  X XY W @CH BON,""VE:  "",@CHBOFF ,P2"
  12115   "RTN","CHG CP2",29,0)
  12116    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHSTAT_ U_CHVE
  12117   "RTN","CHG CP2",30,0)
  12118    S X="X XY  W """""
  12119   "RTN","CHG CP2",31,0)
  12120    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X
  12121   "RTN","CHG CP2",32,0)
  12122    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X
  12123   "RTN","CHG CP2",33,0)
  12124    S X="X XY  W @CHBON, ""DOS: "", @CHBOFF,P1  S DX=28 X  XY W @CHB ON,""POS:  "",@CHBOFF ,P2 S DX=5 3 X XY W @ CHBON,""ED I Claim: " ",@CHBOFF, P3"
  12125   "RTN","CHG CP2",34,0)
  12126    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHDOS_U _CHPOS_U_C HEDI
  12127   "RTN","CHG CP2",35,0)
  12128    S X="X XY  W @CHBON, ""MCCR Rev iew: "",@C HBOFF,P1 S  DX=28 X X Y W @CHBON ,""Type of  Bill: "", @CHBOFF,P2  S DX=53 X  XY W @CHB ON,""PCN:  "",@CHBOFF ,P3"
  12129   "RTN","CHG CP2",36,0)
  12130    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHMCCR_ U_CHTOB_U_ $E(CHPCN,1 ,20)
  12131   "RTN","CHG CP2",37,0)
  12132    S X="X XY  W @CHBON, ""OHI Type : "",@CHBO FF,P1 S DX =28 X XY W  @CHBON,"" OHI Begin:  "",@CHBOF F,P2 S DX= 53 X XY W  @CHBON,""O HI End: "" ,@CHBOFF,P 3"
  12133   "RTN","CHG CP2",38,0)
  12134    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_$E(CHOH TP,1,15)_U _CHOHBP_U_ CHOHEP
  12135   "RTN","CHG CP2",39,0)
  12136    S X="X XY  W @CHBON, ""OHI Paym t: "",@CHB OFF,P1 S D X=28 X XY  W @CHBON," "Bene Paym t: "",@CHB OFF,P2 S D X=53 X XY  W @CHBON," "TPL Paymt : "",@CHBO FF,P3"  ;D EV7820 EW  4/18/11
  12137   "RTN","CHG CP2",40,0)
  12138    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHOHI_U _CHBAMT_U_ CHTPL  ;DE V7820 EW 4 /18/11
  12139   "RTN","CHG CP2",41,0)
  12140    S XVENPT= $P(@(GLPAY _"CHCLM,0) "),U,3)
  12141   "RTN","CHG CP2",42,0)
  12142    I $D(^CHM VEN(XVENPT ,20)) D
  12143   "RTN","CHG CP2",43,0)
  12144    .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"
  12145   "RTN","CHG CP2",44,0)
  12146    S X="X XY  W @CHBON, ""Facility  Type: "", @CHBOFF,P1  S DX=26 X  XY W @CHB ON,""Discr ete Psych:  "",@CHBOF F,P2 S DX= 52 X XY W  @CHBON,""D iscrete Re hab: "",@C HBOFF,P3"
  12147   "RTN","CHG CP2",45,0)
  12148    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHFAC_U _UNT1_U_UN T2
  12149   "RTN","CHG CP2",46,0)
  12150    I $P(@(GL PAY_"CHCLM ,0)"),U,7) =1 D  ;AEB  1/20/2010  DEV004805
  12151   "RTN","CHG CP2",47,0)
  12152    .S X="X X Y W @CHBON ,""DRG Ass igned: "", @CHBOFF,P1  S DX=28 X  XY W @CHB ON,""Ven P OA Exempt:  "",@CHBOF F,P2"  ;AE B 1/20/201 0 DEV00480 5
  12153   "RTN","CHG CP2",48,0)
  12154    .I $D(@(G LPAY_"CHCL M,7)")) I  $P(@(GLPAY _"CHCLM,7) "),U,8)'=" " D  Q  ;A EB 7/20/20 10 DEV0036 98
  12155   "RTN","CHG CP2",49,0)
  12156    ..S CHPZI P="" S CHP ZIP=$P(@(G LPAY_"CHCL M,7)"),U,8 )  ;AEB 7/ 20/2010 DE V003698
  12157   "RTN","CHG CP2",50,0)
  12158    ..S X=X_"  S DX=53 X  XY W @CHB ON,""POP1:  "",@CHBOF F,P3"  ;AE B 7/20/201 0 DEV00369 8
  12159   "RTN","CHG CP2",51,0)
  12160    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) =X_U_CHDRG _U_CHEXP_U _CHPZIP  ; AEB 7/20/2 010 DEV003 698
  12161   "RTN","CHG CP2",52,0)
  12162    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_CHDRG_ U_CHEXP  ; AEB 1/20/2 010 DEV004 805
  12163   "RTN","CHG CP2",53,0)
  12164    I $P(@(GL PAY_"CHCLM ,0)"),U,7) '=1 D  ;AE B 1/20/201 0 DEV00480 5
  12165   "RTN","CHG CP2",54,0)
  12166    .I $D(@(G LPAY_"CHCL M,7)")) I  $P(@(GLPAY _"CHCLM,7) "),U,8)'=" " D  Q  ;A EB 7/20/20 10 DEV0036 98
  12167   "RTN","CHG CP2",55,0)
  12168    ..S CHPZI P="" S CHP ZIP=$P(@(G LPAY_"CHCL M,7)"),U,8 )  ;AEB 7/ 20/2010 DE V003698
  12169   "RTN","CHG CP2",56,0)
  12170    ..S X="X  XY W @CHBO N,""POP1:  "",@CHBOFF ,P1"  ;AEB  7/20/2010  DEV003698
  12171   "RTN","CHG CP2",57,0)
  12172    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) =X_U_CHPZI P  ;AEB 7/ 20/2010 DE V003698
  12173   "RTN","CHG CP2",58,0)
  12174    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) ="W "" """    ;AEB 7/ 20/2010 DE V003698
  12175   "RTN","CHG CP2",59,0)
  12176    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "W "" """   ;AEB 1/20 /2010 DEV0 04805
  12177   "RTN","CHG CP2",60,0)
  12178    ;S X="X X Y W @CHBON ,""DRG Ass igned: "", @CHBOFF,P1 "
  12179   "RTN","CHG CP2",61,0)
  12180    ;I $P(@(G LPAY_"CHCL M,0)"),U,7 )=1 S X="X  XY W @CHB ON,""DRG A ssigned: " ",@CHBOFF, P1 S DX=28  X XY W @C HBON,""Ven  POA Exemp t: "",@CHB OFF,P2"  ; AEB 1/20/2 010 DEV004 805
  12181   "RTN","CHG CP2",62,0)
  12182    ;D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_CHDRG
  12183   "RTN","CHG CP2",63,0)
  12184    ;I $P(@(G LPAY_"CHCL M,0)"),U,7 )=1 S ^UTI LITY($J,"Q AQ",CHZONE ,CT)=^UTIL ITY($J,"QA Q",CHZONE, CT)_U_CHEX P
  12185   "RTN","CHG CP2",64,0)
  12186    ;D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "W "" """
  12187   "RTN","CHG CP2",65,0)
  12188    ;-------- ----  STAR T DEV7820  EW 4/18/11  --------- ---------- ----
  12189   "RTN","CHG CP2",66,0)
  12190    I (CHTOS= "IPT") D   G EN21
  12191   "RTN","CHG CP2",67,0)
  12192    .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"
  12193   "RTN","CHG CP2",68,0)
  12194    I (CHTOS= "RXT")&(CH PGPT=6) D   G EN21
  12195   "RTN","CHG CP2",69,0)
  12196    .;CJM LIN E LENGTH F OR MIGRATI ON R1 2017 0719
  12197   "RTN","CHG CP2",70,0)
  12198    .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(""Total  Chg"",10)   S DX=87  "
  12199   "RTN","CHG CP2",71,0)
  12200    .S X=X_"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"",10) S  DX=123 X  XY W $J("" Mcaid"",10 ),@CHBOFF, @CHULOFF"
  12201   "RTN","CHG CP2",72,0)
  12202    .Q
  12203   "RTN","CHG CP2",73,0)
  12204    ;CJM LINE  LENGTH FO R MIGRATIO N R1 20170 719
  12205   "RTN","CHG CP2",74,0)
  12206    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 D X=75 X XY  W $J(""Tot al Chg"",1 0)"
  12207   "RTN","CHG CP2",75,0)
  12208    S X=X_"   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 P R"",10) S  DX=123 X X Y W $J(""M caid"",10) ,@CHBOFF,@ CHULOFF"
  12209   "RTN","CHG CP2",76,0)
  12210    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X
  12211   "RTN","CHG CP2",77,0)
  12212    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"
  12213   "RTN","CHG CP2",78,0)
  12214    ;-------- ----  END  DEV7820 EW  4/18/11 - ---------- ---------- --
  12215   "RTN","CHG CP2",79,0)
  12216   EN21 D UPC T S ^UTILI TY($J,"QAQ ",CHZONE,C T)=X
  12217   "RTN","CHG CP2",80,0)
  12218    S:CHTOS=" OPT" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  12219   "RTN","CHG CP2",81,0)
  12220    S:CHTOS=" DUR" CHTDX ="DME-DX", CHTPRC="DM E-SUPPLY"
  12221   "RTN","CHG CP2",82,0)
  12222    S:CHTOS=" DNT" CHTDX ="DEN-DX", CHTPRC="DE N-PROC"
  12223   "RTN","CHG CP2",83,0)
  12224    S:CHTOS=" TRV" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  12225   "RTN","CHG CP2",84,0)
  12226    S:CHTOS=" RXT" CHTPR C="PHARM"
  12227   "RTN","CHG CP2",85,0)
  12228    S CHTOSP= $S(CHTOS=" IPT":CHTOS ,CHTOS="RX T":CHTOS,1 :"OPT")
  12229   "RTN","CHG CP2",86,0)
  12230    D:CHTOSP' ="" @CHTOS P^CHGQA3
  12231   "RTN","CHG CP2",87,0)
  12232    ;-------- ----  STAR T DEV7820  EW 4/18/11  --------- ---------- ----
  12233   "RTN","CHG CP2",88,0)
  12234    I CHTOSP= "IPT" D
  12235   "RTN","CHG CP2",89,0)
  12236    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "S DX=58 X  XY W ""== ========""  S DX=69 X  XY W ""== ========"" "
  12237   "RTN","CHG CP2",90,0)
  12238    .S X="S D X=58 X XY  W $J(P1,10 ) S DX=69  X XY W $J( P2,10)"
  12239   "RTN","CHG CP2",91,0)
  12240    .S ALFL=" " I CHTOS= "IPT" S:$P (@(GLPAY_" CHCLM,""IN P"")"),U,1 0)'="" ALF L="A"
  12241   "RTN","CHG CP2",92,0)
  12242    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_$FN(CH BAT,"",2)_ ALFL_U_CHT AA
  12243   "RTN","CHG CP2",93,0)
  12244    E  D
  12245   "RTN","CHG CP2",94,0)
  12246    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "S DX=60 X  XY W ""TO TALS  ---- ---------- ---------- ---------- ---------- ---------- ---------- -"""
  12247   "RTN","CHG CP2",95,0)
  12248    .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)"
  12249   "RTN","CHG CP2",96,0)
  12250    .S ALFL=" " I CHTOS= "IPT" S:$P (@(GLPAY_" CHCLM,""IN P"")"),U,1 0)'="" ALF L="A"
  12251   "RTN","CHG CP2",97,0)
  12252    .;S:CHOHI PDT'="" CH OHIPDT=$J( $FN(CHOHIP DT,"",2),1 0)
  12253   "RTN","CHG CP2",98,0)
  12254    .;S:CHOHI ADT'="" CH OHIADT=$J( $FN(CHOHIA DT,"",2),1 0)
  12255   "RTN","CHG CP2",99,0)
  12256    .;S:CHMED PT'="" CHM EDPT=$J($F N(CHMEDPT, "",2),10)
  12257   "RTN","CHG CP2",100,0 )
  12258    .;S:CHBAT '="" CHBAT =$FN(CHBAT ,"",2)
  12259   "RTN","CHG CP2",101,0 )
  12260    .;S:CHTAA '="" CHTAA =$FN(CHTAA ,"",2)
  12261   "RTN","CHG CP2",102,0 )
  12262    .;S:CHOHI PRT'="" CH OHIPRT=$J( $FN(CHOHIP RT,"",2),1 0)
  12263   "RTN","CHG CP2",103,0 )
  12264    .;S:CHOHI PBT'="" CH OHIPBT=$J( $FN(CHOHIP BT,"",2),1 0)
  12265   "RTN","CHG CP2",104,0 )
  12266    .S (CHOHI PRT,CHOHIP DT,CHOHIAD T,CHOHIPBT ,CHMEDPT,C HBAT,CHTAA )="" ;MTN0 13163: BUG  FIX QAQ12  SLA EW 10 /4/12
  12267   "RTN","CHG CP2",105,0 )
  12268    .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 QAQ12  SLA EW 10/ 4/12
  12269   "RTN","CHG CP2",106,0 )
  12270    .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 QAQ1 2 SLA EW 1 0/4/12
  12271   "RTN","CHG CP2",107,0 )
  12272    .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 QAQ12 S LA EW 10/4 /12
  12273   "RTN","CHG CP2",108,0 )
  12274    .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 AQ12 SLA E W 10/4/12
  12275   "RTN","CHG CP2",109,0 )
  12276    .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 AQ12 SLA E W 10/4/12
  12277   "RTN","CHG CP2",110,0 )
  12278    .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 QAQ1 2 SLA EW 1 0/4/12
  12279   "RTN","CHG CP2",111,0 )
  12280    .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  QAQ12 SLA  EW 10/4/1 2
  12281   "RTN","CHG CP2",112,0 )
  12282    .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
  12283   "RTN","CHG CP2",113,0 )
  12284    .S X="S D X=99 X XY  W $J(P1,10 ) S DX=111  X XY W $J (P2,10)"
  12285   "RTN","CHG CP2",114,0 )
  12286    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_CHOHIA DT_U_CHOHI PBT
  12287   "RTN","CHG CP2",115,0 )
  12288    ;-------- ----  END  DEV7820 EW  4/18/11 - ---------- ---------- --
  12289   "RTN","CHG CP2",116,0 )
  12290    D REOPEN
  12291   "RTN","CHG CP2",117,0 )
  12292    S X="X XY  W @CHBON, ""Benefici ary Data:" ",@CHBOFF"
  12293   "RTN","CHG CP2",118,0 )
  12294    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X
  12295   "RTN","CHG CP2",119,0 )
  12296    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=50 X XY  W @CHBON," "SSN: "",@ CHBOFF,P4"
  12297   "RTN","CHG CP2",120,0 )
  12298    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHDOB_U _CHAGE_U_C HSEX_U_CHS SN
  12299   "RTN","CHG CP2",121,0 )
  12300    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=50  X XY W @C HBON,""Rel ationship:  "",@CHBOF F,P2"
  12301   "RTN","CHG CP2",122,0 )
  12302    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHBAD1_ U_CHREL
  12303   "RTN","CHG CP2",123,0 )
  12304    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1"
  12305   "RTN","CHG CP2",124,0 )
  12306    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHBAD2
  12307   "RTN","CHG CP2",125,0 )
  12308    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"
  12309   "RTN","CHG CP2",126,0 )
  12310    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHBCTY_ U_CHBST_U_ CHBZIP
  12311   "RTN","CHG CP2",127,0 )
  12312    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=" W "" """
  12313   "RTN","CHG CP2",128,0 )
  12314    S X="X XY  W @CHBON, ""Tax ID:  "",@CHBOFF ,P1 S DX=2 8 X XY W @ CHBON,""PI : "",@CHBO FF,P2 S DX =40 X XY W  @CHBON,"" Vendor Pag e: "",@CHB OFF,P3 S D X=59 X XY  W @CHBON," "CMAC: "", @CHBOFF,P4 "
  12315   "RTN","CHG CP2",129,0 )
  12316    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHVTIDP _U_CHAOB_U _CHVNPG_U_ CHCMAC
  12317   "RTN","CHG CP2",130,0 )
  12318    S X="X XY  W @CHBON, ""RT Vendo r: "",@CHB OFF,P1 S D X=42 X XY  W @CHBON," "PLVendor:  "",@CHBOF F,P2"
  12319   "RTN","CHG CP2",131,0 )
  12320    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHVEN_U _CHPLVEN
  12321   "RTN","CHG CP2",132,0 )
  12322    S X="X XY  W @CHBON, ""Addr1: " ",@CHBOFF, P1 S DX=42  X XY W @C HBON,""Add r1:"",@CHB OFF,P2"
  12323   "RTN","CHG CP2",133,0 )
  12324    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHRTAD1 _U_CHVAD1
  12325   "RTN","CHG CP2",134,0 )
  12326    S X="X XY  W @CHBON, ""Addr2: " ",@CHBOFF, P1 S DX=42  X XY W @C HBON,""Add r2:"",@CHB OFF,P2"
  12327   "RTN","CHG CP2",135,0 )
  12328    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHRTAD2 _U_CHVAD2
  12329   "RTN","CHG CP2",136,0 )
  12330    S X="X XY  W @CHBON, ""City:  " ",@CHBOFF, P1 S DX=42  X XY W @C HBON,""Cit y:"",@CHBO FF,P2"
  12331   "RTN","CHG CP2",137,0 )
  12332    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHRTVCT Y_U_CHVCTY
  12333   "RTN","CHG CP2",138,0 )
  12334    S X="X XY  W @CHBON, ""State: " ",@CHBOFF, P1 S DX=13  X XY W @C HBON,""Zip : "",@CHBO FF,P2 S DX =42 X XY W  @CHBON,"" State: "", @CHBOFF,P3  S DX=55 X  XY W @CHB ON,""Zip:  "",@CHBOFF ,P4"
  12335   "RTN","CHG CP2",139,0 )
  12336    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHRTVST _U_CHRTVZI P_U_CHVST_ U_CHVZIP
  12337   "RTN","CHG CP2",140,0 )
  12338    ;BEGIN SB B 03/08/20 18 cpe001- 006 Defect  694370 PL ZIP ADDITI ON
  12339   "RTN","CHG CP2",141,0 )
  12340    S CHPLZIP =$P($G(^CH MPAY(CHCLM ,"VEN-II") ),U,15)
  12341   "RTN","CHG CP2",142,0 )
  12342    ; Defect  832284 - B egins
  12343   "RTN","CHG CP2",143,0 )
  12344    I "IPT,OP T,DNT"[CHT OS D     ;  Added che ck for TOS  to displa y PL ZIP,  only for I npatient,  Outpatient  or Dental  
  12345   "RTN","CHG CP2",144,0 )
  12346    . S X="X  XY W @CHBO N,""PL ZIP : "",@CHBO FF,P1"
  12347   "RTN","CHG CP2",145,0 )
  12348    . D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) =X_U_CHPLZ IP
  12349   "RTN","CHG CP2",146,0 )
  12350    ;Defect 8 32284 - En ds 
  12351   "RTN","CHG CP2",147,0 )
  12352    ;END SBB  03/08/2018  cpe001-00 6 Defect 6 94370 PLZI P ADDITION
  12353   "RTN","CHG CP2",148,0 )
  12354    I $D(^CHM CLCOM("B", CHCLMO)) D   S CHCOM= CHCLMO D ^ CHGCP3A K  CHCOM
  12355   "RTN","CHG CP2",149,0 )
  12356    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12357   "RTN","CHG CP2",150,0 )
  12358    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Claim Comm ents"",@CH BOFF"
  12359   "RTN","CHG CP2",151,0 )
  12360    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12361   "RTN","CHG CP2",152,0 )
  12362    I CHPDI'= "" I $D(^C HMCLCOM("B ",$P(CHPDI ,"-",1)))  D  S CHCOM =$P(CHPDI, "-",1) D ^ CHGCP3A K  CHCOM
  12363   "RTN","CHG CP2",153,0 )
  12364    .I '$D(^C HMCLCOM("B ",CHCLMO))  D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=" "
  12365   "RTN","CHG CP2",154,0 )
  12366    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" PDI Commen ts"",@CHBO FF"
  12367   "RTN","CHG CP2",155,0 )
  12368    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12369   "RTN","CHG CP2",156,0 )
  12370    I CHPGPT= 5 I $D(^CH NVBNCM(741 3002.5,DFN ,100,BFN,2 00)) D  D  NVACOM^CHG CP16 G EN3
  12371   "RTN","CHG CP2",157,0 )
  12372    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12373   "RTN","CHG CP2",158,0 )
  12374    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =30 X XY W  @CHBON,"" Non-VA Ben e Comments "",@CHBOFF "
  12375   "RTN","CHG CP2",159,0 )
  12376    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12377   "RTN","CHG CP2",160,0 )
  12378    I CHPGPT' =5 I $D(^C HBENCOM(DF N,100,BFN, 200)) D  D  ^CHGQA17
  12379   "RTN","CHG CP2",161,0 )
  12380    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12381   "RTN","CHG CP2",162,0 )
  12382    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Bene Comme nts"",@CHB OFF"
  12383   "RTN","CHG CP2",163,0 )
  12384    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12385   "RTN","CHG CP2",164,0 )
  12386   EN3 I $D(^ CHMVEN(VNP T,20)) D   D VWATCH^C HGQA17
  12387   "RTN","CHG CP2",165,0 )
  12388    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12389   "RTN","CHG CP2",166,0 )
  12390    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Vendor Wat ch"",@CHBO FF"
  12391   "RTN","CHG CP2",167,0 )
  12392    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  12393   "RTN","CHG CP2",168,0 )
  12394    D ^CHGQAO HI
  12395   "RTN","CHG CP2",169,0 )
  12396    K BFN,CHB ENE,CHCLMO ,CHDOCID,C HDOS,CHPDI ,CHROPEN,C HSTAT,FILE
  12397   "RTN","CHG CP2",170,0 )
  12398    K CHSTAT, CHTCB,CHTD X,CHTOS,CH TOSP,CHTPR C,CHVEN,CH VTID,CT,I, J,RCT
  12399   "RTN","CHG CP2",171,0 )
  12400    K CHANS,C HBA,CHBAT, CHCODE,CHD ATA,CHDESC ,CHRULEJ,C HTYPE,RECO ,X,L Q
  12401   "RTN","CHG CP2",172,0 )
  12402   STATUS ;;P END,INPROG ,CMPLTE,RE J,ADM SUS, SB REV,NVA  SUS
  12403   "RTN","CHG CP2",173,0 )
  12404   REOPEN S O LDPDI="",( J,FLG)=0,( FRSTPDI,CH CLPT,CHCLM R)=""
  12405   "RTN","CHG CP2",174,0 )
  12406   RE1 S J=$O (@(GLPAY_" CHCLM,""PD I"",J)"))  I 'J Q
  12407   "RTN","CHG CP2",175,0 )
  12408    G:'$D(@(G LPAY_"CHCL M,""PDI"", J,0)")) RE 1
  12409   "RTN","CHG CP2",176,0 )
  12410    S OLDPDI= $P(@(GLPAY _"CHCLM,"" PDI"",J,0) "),U,1)
  12411   "RTN","CHG CP2",177,0 )
  12412    I $D(@(GL PAY_"CHCLM ,6)")) S C HCLPT=$P(@ (GLPAY_"CH CLM,6)"),U ,2)
  12413   "RTN","CHG CP2",178,0 )
  12414    I CHCLPT' ="" S CHCL MR=$P(@(GL PAY_"CHCLP T,0)"),U,1 )
  12415   "RTN","CHG CP2",179,0 )
  12416    S:FRSTPDI ="" FRSTPD I=OLDPDI
  12417   "RTN","CHG CP2",180,0 )
  12418    G:OLDPDI= $P(CHPDI," -",1) RE1
  12419   "RTN","CHG CP2",181,0 )
  12420    G:'$D(^CH MIMG(OLDPD I,0)) RE1
  12421   "RTN","CHG CP2",182,0 )
  12422    S CHBAT=" ",CHBAT=$P (^CHMIMG(O LDPDI,0),U ,19)
  12423   "RTN","CHG CP2",183,0 )
  12424    S CHDC=""
  12425   "RTN","CHG CP2",184,0 )
  12426    S:$D(^CHM IMG(OLDPDI ,"DOC")) C HDC=$P(^CH MIMG(OLDPD I,"DOC"),U ,1)
  12427   "RTN","CHG CP2",185,0 )
  12428    S:CHBAT=" " CHBAT=0  S:CHDC=""  CHDC="UNK"
  12429   "RTN","CHG CP2",186,0 )
  12430    S OLDPDI= OLDPDI_"-" _CHDC
  12431   "RTN","CHG CP2",187,0 )
  12432    D:FLG=0 R E2
  12433   "RTN","CHG CP2",188,0 )
  12434    S X="X XY  W P1 S DX =22 X XY W  ""Batch:  "",P2"
  12435   "RTN","CHG CP2",189,0 )
  12436    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_OLDPDI_ U_CHBAT
  12437   "RTN","CHG CP2",190,0 )
  12438    S X="X XY  W P1"
  12439   "RTN","CHG CP2",191,0 )
  12440    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHCLMR
  12441   "RTN","CHG CP2",192,0 )
  12442    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=" "
  12443   "RTN","CHG CP2",193,0 )
  12444    G RE1
  12445   "RTN","CHG CP2",194,0 )
  12446    ;
  12447   "RTN","CHG CP2",195,0 )
  12448   RE2 D UPCT  S ^UTILIT Y($J,"QAQ" ,CHZONE,CT )=""
  12449   "RTN","CHG CP2",196,0 )
  12450    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"
  12451   "RTN","CHG CP2",197,0 )
  12452    S FLG=1
  12453   "RTN","CHG CP2",198,0 )
  12454    Q
  12455   "RTN","CHG CP2",199,0 )
  12456   UPCT S (CT ,^UTILITY( $J,"QAQ",C HZONE,0))= CT+1 Q
  12457   "RTN","CHG CP2",200,0 )
  12458   DUZ S II=0 ,CHVE="UNK "
  12459   "RTN","CHG CP2",201,0 )
  12460   DUZ1 S II= $O(^CHMIMG ("B",CHPDI ,II)) Q:'I I
  12461   "RTN","CHG CP2",202,0 )
  12462    G:'$D(^CH MIMG(II,0) ) DUZ1
  12463   "RTN","CHG CP2",203,0 )
  12464    S CHDUZ=$ P(^CHMIMG( II,0),U,3)
  12465   "RTN","CHG CP2",204,0 )
  12466    G:CHDUZ=" " DUZ1
  12467   "RTN","CHG CP2",205,0 )
  12468    I CHDUZ'= "" I $D(^V A(200,CHDU Z,0)) S CH VE=$P(^VA( 200,CHDUZ, 0),U,2)
  12469   "RTN","CHG CP2",206,0 )
  12470    S CHVE=CH VE_"-"_CHD UZ
  12471   "RTN","CHG CP2",207,0 )
  12472    Q
  12473   "RTN","CHG CU130")
  12474   0^31^B1382 7194
  12475   "RTN","CHG CU130",1,0 )
  12476   CHGCU130 ; CVA/CR;CEU  BENE ZIP  ;02/04/98   4:17 PM
  12477   "RTN","CHG CU130",2,0 )
  12478    ;;1.0;CHA MPVA SYSTE M;**9**;De cember 20,  2010;Buil d 5
  12479   "RTN","CHG CU130",3,0 )
  12480    ;;2.0;
  12481   "RTN","CHG CU130",4,0 )
  12482    ;CPTS #11 090 - PEJ  2/7/97
  12483   "RTN","CHG CU130",5,0 )
  12484    ;;DEF0110 20 DRW - C hange the  position o f the DISP  and the B OX on the  screen
  12485   "RTN","CHG CU130",6,0 )
  12486    ;; in ord er to rect ify the sc rolling is sue presen ted in thi s problem  - 12/20/10
  12487   "RTN","CHG CU130",7,0 )
  12488    ;CFS 03/0 6/2018 - D efect 6863 77 Add hel p text for  PL ZIP.
  12489   "RTN","CHG CU130",8,0 )
  12490    ;CFS 09/2 5/2018 - D efect 8285 26 Create  validation s for zip  codes.
  12491   "RTN","CHG CU130",9,0 )
  12492   ZIP ;
  12493   "RTN","CHG CU130",10, 0)
  12494    N CHLD1,C HLD2
  12495   "RTN","CHG CU130",11, 0)
  12496    S ZNO=0
  12497   "RTN","CHG CU130",12, 0)
  12498    I $D(DQOU T) D BOX,D ISP S Y="" ,ZNO=1 S D X=CHLD1,DY =CHLD2 G E ND
  12499   "RTN","CHG CU130",13, 0)
  12500    ;
  12501   "RTN","CHG CU130",14, 0)
  12502    S:Y="@" Y =""
  12503   "RTN","CHG CU130",15, 0)
  12504    G E2:Y=""
  12505   "RTN","CHG CU130",16, 0)
  12506    S CHLD1=D X,CHLD2=DY
  12507   "RTN","CHG CU130",17, 0)
  12508    D CLEAR
  12509   "RTN","CHG CU130",18, 0)
  12510    S DX=CHLD 1,DY=CHLD2
  12511   "RTN","CHG CU130",19, 0)
  12512    I (Y'?5N) &(Y'?9N)&( Y'?5N1"-"4 N) D  G E2   ;CFS Def ect 828526
  12513   "RTN","CHG CU130",20, 0)
  12514    .S DY=19, DX=12 X XY  W "RT Zip  must be i n the form at NNNNN o r NNNNNNNN N or NNNNN -NNNN."
  12515   "RTN","CHG CU130",21, 0)
  12516    .S ZNO=1
  12517   "RTN","CHG CU130",22, 0)
  12518    .S DX=CHL D1,DY=CHLD 2
  12519   "RTN","CHG CU130",23, 0)
  12520    G E2
  12521   "RTN","CHG CU130",24, 0)
  12522    ;
  12523   "RTN","CHG CU130",25, 0)
  12524   PLZIP  ; 
  12525   "RTN","CHG CU130",26, 0)
  12526    N CHLD1,C HLD2,ZIPY
  12527   "RTN","CHG CU130",27, 0)
  12528    S ZNO=0
  12529   "RTN","CHG CU130",28, 0)
  12530    I $D(DQOU T) D BOX,D ISP S Y="" ,ZNO=1 S D X=CHLD1,DY =CHLD2 G E ND
  12531   "RTN","CHG CU130",29, 0)
  12532    ;
  12533   "RTN","CHG CU130",30, 0)
  12534    S:Y="@" Y =""
  12535   "RTN","CHG CU130",31, 0)
  12536    G E2:Y=""
  12537   "RTN","CHG CU130",32, 0)
  12538    S CHLD1=D X,CHLD2=DY   ;Keep DX  and DY in  temp vari ables to p revent und efined err ors.
  12539   "RTN","CHG CU130",33, 0)
  12540    D CLEAR
  12541   "RTN","CHG CU130",34, 0)
  12542    S DX=CHLD 1,DY=CHLD2
  12543   "RTN","CHG CU130",35, 0)
  12544    I Y'?5N D   G E2  ;C FS Defect  828526
  12545   "RTN","CHG CU130",36, 0)
  12546    .S DY=19, DX=12 X XY  W "PL ZIP  must be a  length of  5 numbers ."
  12547   "RTN","CHG CU130",37, 0)
  12548    .S DX=CHL D1,DY=CHLD 2  ;Set DX  and DY va riables ba ck to orig inal value s to preve nt undefin ed errors.
  12549   "RTN","CHG CU130",38, 0)
  12550    .S ZNO=1
  12551   "RTN","CHG CU130",39, 0)
  12552    S ZIPY=$E (Y,1,5)
  12553   "RTN","CHG CU130",40, 0)
  12554    Q:$D(^CHM DIC(741002 .4,"B",ZIP Y))!(ZNO)   ;CFS Defe ct 828526
  12555   "RTN","CHG CU130",41, 0)
  12556    D CLEAR S  DY=19,DX= 1 X XY
  12557   "RTN","CHG CU130",42, 0)
  12558    W "     P L ZIP DOES  NOT EXIST  IN THE CH AMPVA CMAC  ZIP CODES  FILE.  Yo u may:"
  12559   "RTN","CHG CU130",43, 0)
  12560    W !,"      (T)ry aga in with a  new PL ZIP  - or - (C )ontinue w ith this o ne:"
  12561   "RTN","CHG CU130",44, 0)
  12562    W !,"                        (T )ry again  or (C)onti nue: C// "
  12563   "RTN","CHG CU130",45, 0)
  12564    R ANS:25
  12565   "RTN","CHG CU130",46, 0)
  12566    I ANS'="C ",ANS'="T" ,ANS'="" D   G PLZIP
  12567   "RTN","CHG CU130",47, 0)
  12568    .S DY=22, DX=14 X XY  W "Please  enter 'C'  for Conti nue or 'T'  to Try Ag ain." H 4
  12569   "RTN","CHG CU130",48, 0)
  12570    .S DX=CHL D1,DY=CHLD 2
  12571   "RTN","CHG CU130",49, 0)
  12572    I ANS="T"  S ZNO=1
  12573   "RTN","CHG CU130",50, 0)
  12574    D CLEAR
  12575   "RTN","CHG CU130",51, 0)
  12576    S DX=CHLD 1,DY=CHLD2   ;Set DX  and DY var iables bac k to origi nal values  to preven t undefine d errors.
  12577   "RTN","CHG CU130",52, 0)
  12578    G E2
  12579   "RTN","CHG CU130",53, 0)
  12580    ;;DEF0110 20 DRW - A dded DX an d DY coord inates DY  displays t he first r ow of cont ents on ro w 18 - 12/ 20/10
  12581   "RTN","CHG CU130",54, 0)
  12582   DISP ;
  12583   "RTN","CHG CU130",55, 0)
  12584    N CHTEXT, CHTEXT1
  12585   "RTN","CHG CU130",56, 0)
  12586    S CHTEXT= $S($G(PLZI PFLG):"Ent er the cor rect PL ZI P,",1:"Ent er the cor rect ZIP," )
  12587   "RTN","CHG CU130",57, 0)
  12588    S CHTEXT1 =$S($G(PLZ IPFLG):"5  digits.",1 :"5 or 9 d igits.")
  12589   "RTN","CHG CU130",58, 0)
  12590    ;S DX=8,D Y=18 X XY  W "Enter t he correct  ZIP,"
  12591   "RTN","CHG CU130",59, 0)
  12592    S DX=8,DY =18 X XY W  CHTEXT
  12593   "RTN","CHG CU130",60, 0)
  12594    ;S DX=7,D Y=17 X XY  W "5 or 9  characters ."
  12595   "RTN","CHG CU130",61, 0)
  12596    ;S DX=8,D Y=19 X XY  W "5 or 9  characters ."           ;;DEF011 020 DRW -  Changed DY  from 18 t o 19 for t he second  row of con tents row  19 - 12/20 /10
  12597   "RTN","CHG CU130",62, 0)
  12598    S DX=8,DY =19 X XY W  CHTEXT1
  12599   "RTN","CHG CU130",63, 0)
  12600    R X:3 Q
  12601   "RTN","CHG CU130",64, 0)
  12602    ;
  12603   "RTN","CHG CU130",65, 0)
  12604   BOX S CHLD 1=DX,CHLD2 =DY
  12605   "RTN","CHG CU130",66, 0)
  12606    ;S TX=3,T Y=15,BX=65 ,BY=20,VON ="",VOFF=" "
  12607   "RTN","CHG CU130",67, 0)
  12608    S TX=4,TY =17,BX=66, BY=21,VON= "",VOFF=""              ;;DEF011 020 DRW -  Changed TY  from 16 t o 17 displ ays the to p line on  row 17 and  BY=21 for  bottom ro w - 12/20/ 10
  12609   "RTN","CHG CU130",68, 0)
  12610    N TLP D B OXF^CHSC1( TX,TY,BX,B Y)
  12611   "RTN","CHG CU130",69, 0)
  12612    ;D CLRBOX I^CHSC1(TX ,TY,BX,BY, XY,VON,VOF F) S DX=7, DY=16 X XY
  12613   "RTN","CHG CU130",70, 0)
  12614    D CLRBOXI ^CHSC1(TX, TY,BX,BY,X Y,VON,VOFF ) S DX=8,D Y=20 X XY        ;;DE F011020 DR W - Change d DY from  18 to 20 d isplays th e bottom l ine on row  20 - 12/2 0/10
  12615   "RTN","CHG CU130",71, 0)
  12616    Q
  12617   "RTN","CHG CU130",72, 0)
  12618    ;
  12619   "RTN","CHG CU130",73, 0)
  12620   CLEAR  ;CF S Defect 8 28526
  12621   "RTN","CHG CU130",74, 0)
  12622    F DY=19:1 :22 S DX=1 ,$X=DX X X Y W @CHEOL
  12623   "RTN","CHG CU130",75, 0)
  12624    Q
  12625   "RTN","CHG CU130",76, 0)
  12626   END D REDO LNS^CHSC1( CHFUNC,CHZ ONE,DTM,DB M,TY,BY,.C HSCRN) X X Y
  12627   "RTN","CHG CU130",77, 0)
  12628    K CHTEXT
  12629   "RTN","CHG CU130",78, 0)
  12630   E2 Q
  12631   "RTN","CHG CU130",79, 0)
  12632    ;
  12633   "RTN","CHG CU133")
  12634   0^32^B4083 8286
  12635   "RTN","CHG CU133",1,0 )
  12636   CHGCU133 ; CVA/CR;CEU  VENDOR DA TA SCREEN  ;Nov 30, 2 018@09:12: 01
  12637   "RTN","CHG CU133",2,0 )
  12638    ;;1.0;CHA MPVA SYSTE M;**11**;J ULY 4, 199 0;Build 5
  12639   "RTN","CHG CU133",3,0 )
  12640    ;;2.0
  12641   "RTN","CHG CU133",4,0 )
  12642    ;CPTS #10 846 - PEJ  8/15/96
  12643   "RTN","CHG CU133",5,0 )
  12644    ;CPTS #11 090 - PEJ  2/7/97
  12645   "RTN","CHG CU133",6,0 )
  12646    ;CPTS #12 599 BY DTP  (12-SEP-9 7)
  12647   "RTN","CHG CU133",7,0 )
  12648    ;CPTS #14 813 BY JLR
  12649   "RTN","CHG CU133",8,0 )
  12650    ;DEF01102 0 DRW/JAK  - Vendor D ata Screen  Scrolling  Issue cha nged +3
  12651   "RTN","CHG CU133",9,0 )
  12652    ;DEFECT 8 61813 - TG H - 11/28/ 18 - Add T op of disp lay to Ven dor Screen
  12653   "RTN","CHG CU133",10, 0)
  12654    ;original  to +4 to  resolve cu rsor place ment  - 12 /23/10.
  12655   "RTN","CHG CU133",11, 0)
  12656    S CHSCNAM ="CEU BENE  OPTIONS", CHTITLE="V ENDOR DATA  SCREEN"
  12657   "RTN","CHG CU133",12, 0)
  12658    D ^CHGCU1 49
  12659   "RTN","CHG CU133",13, 0)
  12660    ;S DTM=1, DBM=24 X C HMAR D TOP ^CHGCUU2
  12661   "RTN","CHG CU133",14, 0)
  12662    S DTM=2,D BM=25 X CH MAR D TOP^ CHGCUU2    ; JEH
  12663   "RTN","CHG CU133",15, 0)
  12664    D SHOW,SC REEN
  12665   "RTN","CHG CU133",16, 0)
  12666    ;S DTM=6, DBM=22
  12667   "RTN","CHG CU133",17, 0)
  12668    S DTM=7,D BM=23                            ; JEH
  12669   "RTN","CHG CU133",18, 0)
  12670   ASK D ASK^ CHGCUU2
  12671   "RTN","CHG CU133",19, 0)
  12672    G:$D(DUOU T)!($D(DFO UT))!($D(D TOUT)) END
  12673   "RTN","CHG CU133",20, 0)
  12674    ;INSERT K EY - TO IN QUERIES
  12675   "RTN","CHG CU133",21, 0)
  12676    I $D(DFK2 2) S CHLD1 =DY,CHLD2= DX D  S DX =CHLD2,DY= CHLD1 G AS K
  12677   "RTN","CHG CU133",22, 0)
  12678    .D TOINQ^ CHGCUU2 D  SHOW,SCREE N
  12679   "RTN","CHG CU133",23, 0)
  12680    G:Y="" EN D
  12681   "RTN","CHG CU133",24, 0)
  12682    G:Y=1 END
  12683   "RTN","CHG CU133",25, 0)
  12684    I Y=2 D   G ASK
  12685   "RTN","CHG CU133",26, 0)
  12686    .;
  12687   "RTN","CHG CU133",27, 0)
  12688    .;added t o prevent  editing if  edit-flag  is off
  12689   "RTN","CHG CU133",28, 0)
  12690    .S VFN=$P (@(GLPAY_" CHCLM,0)") ,"^",3)
  12691   "RTN","CHG CU133",29, 0)
  12692    .I VFN I  $P(^CHMVEN (VFN,0),U, 25)'=1 D U NEDCK Q
  12693   "RTN","CHG CU133",30, 0)
  12694    .;
  12695   "RTN","CHG CU133",31, 0)
  12696    .;S CHFUN C="CEU",DT M=3,DBM=22 ,CHSCRN("C EU",CHZONE ,"BEG")=1  X CHMAR
  12697   "RTN","CHG CU133",32, 0)
  12698    .S CHFUNC ="CEU",DTM =5,DBM=23, CHSCRN("CE U",CHZONE, "BEG")=1 X  CHMAR   ;  BUG011020 -07-02 DRW  Changed D TM=4 from  DTM=5 for  cursor pos itioning
  12699   "RTN","CHG CU133",33, 0)
  12700    .;S CHSCR N(CHFUNC,C HZONE,"LAS T")=^UTILI TY($J,CHFU NC,CHZONE, 0)+1     ;  this allo ws for the  cursor to  stay on t he same li ne for the  detail.   01/13/11
  12701   "RTN","CHG CU133",34, 0)
  12702    .S CHSCRN (CHFUNC,CH ZONE,"LAST ")=^UTILIT Y($J,CHFUN C,CHZONE,0 )+4      ;  DEF011020  DRW/JAK -  Change +3  to +4 - 1 2/23/10
  12703   "RTN","CHG CU133",35, 0)
  12704    .S CHTYPI NT=$P(@(GL PAY_"CHCLM ,0)"),"^", 27) S:CHTY PINT=2 PIF L=1      ;  BUG011020 -07-01 DRW  - Change  global to  look at pi ece 27 fro m piece 2  - 01/10/11
  12705   "RTN","CHG CU133",36, 0)
  12706    .S CHVNST R=""
  12707   "RTN","CHG CU133",37, 0)
  12708    .D:$D(PIF L) ^CHGCU1 66                      ;;BUG011 020-07-01  DRW - This  routine w ill displa y (10 item s) only wh en there's  a CHAMPVA  Foreign c laim -  01 /11/11
  12709   "RTN","CHG CU133",38, 0)
  12710    .D:'$D(PI FL) ^CHGCU 137                     ;;BUG011 020-07-01  DRW - This  routine w ill displa y (13 item s) on dome stic claim s - 01/11/ 11
  12711   "RTN","CHG CU133",39, 0)
  12712    .I $D(EDI T) D
  12713   "RTN","CHG CU133",40, 0)
  12714    ..D NOW^% DTC S CHDA TE=%,@(GLP AY_"CHCLM, ""VEN"",CH VPT,CHDATE ,0)")=EDIT
  12715   "RTN","CHG CU133",41, 0)
  12716    ..S $P(@( GLPAY_"CHC LM,""VEN"" ,CHVPT,CHD ATE,0)")," ^",20)=DUZ
  12717   "RTN","CHG CU133",42, 0)
  12718    ..S $P(@( GLPAY_"CHC LM,""VEN"" ,CHVPT,CHD ATE,0)")," ^",3)=CHVN STR ;***** ***
  12719   "RTN","CHG CU133",43, 0)
  12720    ..S CHVNS TR=$P(@(GL PAY_"CHCLM ,0)"),"^", 18),CHVNPT =$P(^(0)," ^",4)
  12721   "RTN","CHG CU133",44, 0)
  12722    ..F CT=4, 5 I $P(EDI T,"^",CT)' ="" S $P(C HVNSTR,"*" ,(CT-3))=1
  12723   "RTN","CHG CU133",45, 0)
  12724    ..F CT=6: 1:15 I $P( EDIT,"^",C T)'="" S $ P(CHVNSTR, "*",(CT-4) )=1
  12725   "RTN","CHG CU133",46, 0)
  12726    ..S $P(@( GLPAY_"CHC LM,""VEN"" ,CHVPT,CHD ATE,0)")," ^",1)=CHVP T
  12727   "RTN","CHG CU133",47, 0)
  12728    ..S $P(^( 0),"^",2)= CHVNPT ;** ***,$P(^(0 ),"^",3)=C HVNSTR
  12729   "RTN","CHG CU133",48, 0)
  12730    ..S $P(@( GLPAY_"CHC LM,0)"),"^ ",18)=CHVN STR,HVFN=$ P(^(0),"^" ,3) D IMAG E
  12731   "RTN","CHG CU133",49, 0)
  12732    ..K EDIT, PTR,CHREC, CNT,HVFN
  12733   "RTN","CHG CU133",50, 0)
  12734    ..D CHXCH G^CHGCU170  ; cpt#110 90
  12735   "RTN","CHG CU133",51, 0)
  12736    . ; DEFEC T 861813 -  TGH - 11/ 28/18 - Ad d Top of d isplay to  Vendor Scr een
  12737   "RTN","CHG CU133",52, 0)
  12738    . S CHSCN AM="CEU BE NE OPTIONS ",CHTITLE= "VENDOR DA TA SCREEN"
  12739   "RTN","CHG CU133",53, 0)
  12740    . S DTM=2 ,DBM=25 X  CHMAR D TO P^CHGCUU2
  12741   "RTN","CHG CU133",54, 0)
  12742    .D SHOW,S CREEN
  12743   "RTN","CHG CU133",55, 0)
  12744    I Y=3 D   G ASK
  12745   "RTN","CHG CU133",56, 0)
  12746    .;S CHFUN C="CEU",DT M=3,DBM=22 ,CHSCRN("C EU",CHZONE ,"BEG")=1  X CHMAR
  12747   "RTN","CHG CU133",57, 0)
  12748    .S CHFUNC ="CEU",DTM =4,DBM=23, CHSCRN("CE U",CHZONE, "BEG")=1 X  CHMAR
  12749   "RTN","CHG CU133",58, 0)
  12750    .;S CHSCR N(CHFUNC,C HZONE,"LAS T")=^UTILI TY($J,CHFU NC,CHZONE, 0)+1
  12751   "RTN","CHG CU133",59, 0)
  12752    .S CHSCRN (CHFUNC,CH ZONE,"LAST ")=^UTILIT Y($J,CHFUN C,CHZONE,0 )+4      ; ;DEF011020  DRW/JAK -  Change +3  (original ) to +4 -  12/23/10
  12753   "RTN","CHG CU133",60, 0)
  12754    .S CHCHG3 =$P(@(GLPA Y_"CHCLM,0 )"),U,3) ;  cpt#11090
  12755   "RTN","CHG CU133",61, 0)
  12756    .D ^CHGCU 150
  12757   "RTN","CHG CU133",62, 0)
  12758    .S CI=CHC LM
  12759   "RTN","CHG CU133",63, 0)
  12760    .I CHCHG3 '=$P(@(GLP AY_"CHCLM, 0)"),U,3)  S CHNOSEND =1 D CHXFR ^CHGCU170
  12761   "RTN","CHG CU133",64, 0)
  12762    .D SHOW,S CREEN
  12763   "RTN","CHG CU133",65, 0)
  12764   END Q
  12765   "RTN","CHG CU133",66, 0)
  12766    ;
  12767   "RTN","CHG CU133",67, 0)
  12768   SHOW ;S DT M=3,DBM=22  X CHMAR D  RNGECLR^C HSC1(2,24, XY,CHEOL)
  12769   "RTN","CHG CU133",68, 0)
  12770    S DTM=4,D BM=23 X CH MAR D RNGE CLR^CHSC1( 3,25,XY,CH EOL)
  12771   "RTN","CHG CU133",69, 0)
  12772    K ^UTILIT Y($J,"CEU" ) S CHZONE =0
  12773   "RTN","CHG CU133",70, 0)
  12774    S:'$D(CHC LM) CHCLM= CHMFI
  12775   "RTN","CHG CU133",71, 0)
  12776    S:CHCLM=" " CHCLM=CH MFI
  12777   "RTN","CHG CU133",72, 0)
  12778    S CHTYPIN T=$P(@(GLP AY_"CHCLM, 0)"),"^",2 7) S:CHTYP INT=2 PIFL =1
  12779   "RTN","CHG CU133",73, 0)
  12780    D:$D(PIFL ) ^CHGCU16 5
  12781   "RTN","CHG CU133",74, 0)
  12782    D:'$D(PIF L) ^CHGCU1 36
  12783   "RTN","CHG CU133",75, 0)
  12784    S CHZONE= 0,CHFUNC=" CEU"
  12785   "RTN","CHG CU133",76, 0)
  12786    ;D SHOW^C HSC1(CHFUN C,CHZONE,D TM,DBM)
  12787   "RTN","CHG CU133",77, 0)
  12788    D SHOW^CH SC1(CHFUNC ,CHZONE,DT M+1,DBM)    ; JEH
  12789   "RTN","CHG CU133",78, 0)
  12790    Q
  12791   "RTN","CHG CU133",79, 0)
  12792    ;
  12793   "RTN","CHG CU133",80, 0)
  12794   SCREEN S C HSCREEN=""  S:$D(^CHM SCRN("B"," CEU BENE O PTIONS"))  CHSCREEN=$ O(^CHMSCRN ("B","CEU  BENE OPTIO NS",0))
  12795   "RTN","CHG CU133",81, 0)
  12796    ;S DTM=3, DBM=22 X C HMAR D CHO ICE^CHGCUU 2
  12797   "RTN","CHG CU133",82, 0)
  12798    S DTM=4,D BM=23 X CH MAR D CHOI CE^CHGCUU2    ;;BUG01 1020 DRW
  12799   "RTN","CHG CU133",83, 0)
  12800    D PRMPT^C HGCUU2
  12801   "RTN","CHG CU133",84, 0)
  12802    ;S DTM=3, DBM=22
  12803   "RTN","CHG CU133",85, 0)
  12804    S DTM=4,D BM=23   ;; BUG011020  DRW
  12805   "RTN","CHG CU133",86, 0)
  12806    Q
  12807   "RTN","CHG CU133",87, 0)
  12808    ;
  12809   "RTN","CHG CU133",88, 0)
  12810   IMAGE S CH PDI=$P(CHV NPT,"*",1) ,CHPAGE=$P (CHVNPT,"* ",2),CHIMA G=$P(CHVNP T,"*",3)
  12811   "RTN","CHG CU133",89, 0)
  12812    Q:CHPDI=" "  Q:CHPAG E=""  Q:CH IMAG=""
  12813   "RTN","CHG CU133",90, 0)
  12814    Q:'$D(^CH MIMAGE(CHP DI,1,CHPAG E,2,CHIMAG ,"VEN"))
  12815   "RTN","CHG CU133",91, 0)
  12816    S PTR=$P( ^CHMIMAGE( CHPDI,1,CH PAGE,2,CHI MAG,"VEN") ,"^",14)
  12817   "RTN","CHG CU133",92, 0)
  12818    Q:PTR=""   Q:'$D(^CH MIMAGE(CHP DI,"P-VEN" ,PTR,0))
  12819   "RTN","CHG CU133",93, 0)
  12820    S CHREC=^ CHMIMAGE(C HPDI,"P-VE N",PTR,0)
  12821   "RTN","CHG CU133",94, 0)
  12822    S OLDREC= ^CHMIMAGE( CHPDI,"P-V EN",PTR,0)
  12823   "RTN","CHG CU133",95, 0)
  12824    S $P(CHRE C,"^",3)=C HVNSTR
  12825   "RTN","CHG CU133",96, 0)
  12826    S $P(OLDR EC,"^",3)= CHVNSTR
  12827   "RTN","CHG CU133",97, 0)
  12828    S:$P(EDIT ,"^",4)'=" " $P(CHREC ,"^",4)=$P (EDIT,"^", 4)
  12829   "RTN","CHG CU133",98, 0)
  12830    S:$P(EDIT ,"^",5)'=" " $P(CHREC ,"^",5)=$P (EDIT,"^", 5)
  12831   "RTN","CHG CU133",99, 0)
  12832    S:$P(EDIT ,"^",7)'=" " $P(CHREC ,"^",7)=$P (EDIT,"^", 7)
  12833   "RTN","CHG CU133",100 ,0)
  12834    S:$P(EDIT ,"^",8)'=" " $P(CHREC ,"^",8)=$P (EDIT,"^", 8)
  12835   "RTN","CHG CU133",101 ,0)
  12836    S:$P(EDIT ,"^",9)'=" " $P(CHREC ,"^",9)=$P (EDIT,"^", 9)
  12837   "RTN","CHG CU133",102 ,0)
  12838    S:$P(EDIT ,"^",10)'= "" $P(CHRE C,"^",10)= $P(EDIT,"^ ",10)
  12839   "RTN","CHG CU133",103 ,0)
  12840    S:$P(EDIT ,"^",11)'= "" $P(CHRE C,"^",11)= $P(EDIT,"^ ",11)
  12841   "RTN","CHG CU133",104 ,0)
  12842    S:$P(EDIT ,"^",12)'= "" $P(CHRE C,"^",12)= $P(EDIT,"^ ",12)
  12843   "RTN","CHG CU133",105 ,0)
  12844    S:$P(EDIT ,"^",13)'= "" $P(CHRE C,"^",13)= $P(EDIT,"^ ",13)
  12845   "RTN","CHG CU133",106 ,0)
  12846    S:$P(EDIT ,"^",14)'= "" $P(CHRE C,"^",14)= $P(EDIT,"^ ",14)
  12847   "RTN","CHG CU133",107 ,0)
  12848    S:$P(EDIT ,"^",15)'= "" $P(CHRE C,"^",15)= $P(EDIT,"^ ",15)
  12849   "RTN","CHG CU133",108 ,0)
  12850    S:$P(EDIT ,"^",16)'= "" $P(CHRE C,"^",16)= $P(EDIT,"^ ",16)
  12851   "RTN","CHG CU133",109 ,0)
  12852    S:$P(EDIT ,"^",17)'= "" $P(CHRE C,"^",17)= $P(EDIT,"^ ",17)
  12853   "RTN","CHG CU133",110 ,0)
  12854    S ^CHMIMA GE(CHPDI," P-VEN",PTR ,0)=CHREC
  12855   "RTN","CHG CU133",111 ,0)
  12856    Q:HVFN=""
  12857   "RTN","CHG CU133",112 ,0)
  12858    S CNT="", CNT=$O(^CH MIMAGE(CHP DI,"VEN-DD ",HVFN,CNT ),-1) S:'C NT CNT=0
  12859   "RTN","CHG CU133",113 ,0)
  12860    S CNT=CNT +1
  12861   "RTN","CHG CU133",114 ,0)
  12862    D NOW^%DT C
  12863   "RTN","CHG CU133",115 ,0)
  12864    F X=1,2 S  X1=X+3 S: $P(EDIT,"^ ",X1)'=""  $P(^CHMIMA GE(CHPDI," VEN-DD",HV FN,CNT),"^ ",X)=$P(ED IT,"^",X1)
  12865   "RTN","CHG CU133",116 ,0)
  12866    F X=3:1:1 3 S X1=X+4  S:$P(EDIT ,"^",X1)'= "" $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",X)=$P (EDIT,"^", X1)
  12867   "RTN","CHG CU133",117 ,0)
  12868    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",13)=$ P(OLDREC," ^",4)
  12869   "RTN","CHG CU133",118 ,0)
  12870    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",14)=$ P(OLDREC," ^",5)
  12871   "RTN","CHG CU133",119 ,0)
  12872    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",15)=$ P(OLDREC," ^",7)
  12873   "RTN","CHG CU133",120 ,0)
  12874    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",16)=$ P(OLDREC," ^",8)
  12875   "RTN","CHG CU133",121 ,0)
  12876    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",17)=$ P(OLDREC," ^",9)
  12877   "RTN","CHG CU133",122 ,0)
  12878    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",18)=$ P(OLDREC," ^",10)
  12879   "RTN","CHG CU133",123 ,0)
  12880    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",19)=$ P(OLDREC," ^",11)
  12881   "RTN","CHG CU133",124 ,0)
  12882    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",20)=$ P(OLDREC," ^",12)
  12883   "RTN","CHG CU133",125 ,0)
  12884    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",21)=$ P(OLDREC," ^",13)
  12885   "RTN","CHG CU133",126 ,0)
  12886    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",22)=$ P(OLDREC," ^",14)
  12887   "RTN","CHG CU133",127 ,0)
  12888    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",23)=$ P(OLDREC," ^",15)
  12889   "RTN","CHG CU133",128 ,0)
  12890    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",24)=$ P(OLDREC," ^",16)
  12891   "RTN","CHG CU133",129 ,0)
  12892    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",25)=$ P(OLDREC," ^",17)
  12893   "RTN","CHG CU133",130 ,0)
  12894    S:$D(EDIT ) $P(^CHMI MAGE(CHPDI ,"VEN-DD", HVFN,CNT), "^",26)=DU Z
  12895   "RTN","CHG CU133",131 ,0)
  12896    S:$D(EDIT ) $P(^CHMI MAGE(CHPDI ,"VEN-DD", HVFN,CNT), "^",27)=%
  12897   "RTN","CHG CU133",132 ,0)
  12898    Q
  12899   "RTN","CHG CU133",133 ,0)
  12900   UNEDCK ;ad ded to pre vent editi ng vendor  if edit-fl ag is off
  12901   "RTN","CHG CU133",134 ,0)
  12902    Q:'$D(VFN )
  12903   "RTN","CHG CU133",135 ,0)
  12904    Q:VFN<1
  12905   "RTN","CHG CU133",136 ,0)
  12906    Q:'$D(^CH MVEN(VFN,0 ))
  12907   "RTN","CHG CU133",137 ,0)
  12908    Q:$P(^CHM VEN(VFN,0) ,U,25)>0
  12909   "RTN","CHG CU133",138 ,0)
  12910    ;S DX=0,D Y=21 X XY
  12911   "RTN","CHG CU133",139 ,0)
  12912    S DX=1,DY =22 X XY    ; JEH
  12913   "RTN","CHG CU133",140 ,0)
  12914    W "VENDOR  CANNOT BE  EDITED. S EE YOUR SU PERVISOR.  PRESS RETU RN TO CONT INUE "
  12915   "RTN","CHG CU133",141 ,0)
  12916    R XIX
  12917   "RTN","CHG CU133",142 ,0)
  12918    X XY W @C HEOL
  12919   "RTN","CHG CU133",143 ,0)
  12920    Q
  12921   "RTN","CHG CU136")
  12922   0^33^B3819 5134
  12923   "RTN","CHG CU136",1,0 )
  12924   CHGCU136 ; CVA/CR;FOR MAT CEU VE NDOR DATA  SCREEN ;Fe b 06, 2019 @08:43:17
  12925   "RTN","CHG CU136",2,0 )
  12926    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  12927   "RTN","CHG CU136",3,0 )
  12928    ;;2.0
  12929   "RTN","CHG CU136",4,0 )
  12930    ;PT'S - 1 0462*
  12931   "RTN","CHG CU136",5,0 )
  12932    ;CPTS #10 846* 11575 *  #11915
  12933   "RTN","CHG CU136",6,0 )
  12934    ;CPTS #12 599 BY DTP  (12-SEP-9 7)
  12935   "RTN","CHG CU136",7,0 )
  12936    ;BUG7991- 08-01 DRW  - Change o ne line (p hone #) fo r cosmetic  appearanc e for vend or data sc reen - 01/ 28/11.
  12937   "RTN","CHG CU136",8,0 )
  12938    ;CFS 07/2 0/2017 - P L ZIP adde d for User  Story CPE 001-005
  12939   "RTN","CHG CU136",9,0 )
  12940    ;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.
  12941   "RTN","CHG CU136",10, 0)
  12942    ;CFS 09/2 0/2018 - D efect 8280 50 Change  Vendor Nam e, Address , City, St ate and Zi p
  12943   "RTN","CHG CU136",11, 0)
  12944    ;                  f rom Physic al Locatio n to Remit  To
  12945   "RTN","CHG CU136",12, 0)
  12946    ;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
  12947   "RTN","CHG CU136",13, 0)
  12948   EN1 N (CHN OSEND,CHVP T,DFN,BFN, CHZONE,CHC LM,CHTYP,E DIT,GLPAY, GLDFN,GLEL G,GLPAYW,G LPAYH)
  12949   "RTN","CHG CU136",14, 0)
  12950    S CHTOT=0 ,CHCT=0 K  EDIT
  12951   "RTN","CHG CU136",15, 0)
  12952    S:'$D(^UT ILITY($J," CEU",CHZON E,0)) ^UTI LITY($J,"C EU",CHZONE ,0)=0
  12953   "RTN","CHG CU136",16, 0)
  12954    S CT=^UTI LITY($J,"C EU",CHZONE ,0),U="^"  Q:$D(@(GLP AY_"CHCLM, ""ARCHIVE" ")"))
  12955   "RTN","CHG CU136",17, 0)
  12956    Q:'$D(@(G LPAY_"CHCL M,0)"))  S  REC0=@(GL PAY_"CHCLM ,0)")
  12957   "RTN","CHG CU136",18, 0)
  12958    S REC7=""  S:$D(@(GL PAY_"CHCLM ,7)")) REC 7=^(7)
  12959   "RTN","CHG CU136",19, 0)
  12960    S CHVPT=$ P(REC0,"^" ,3) S:CHVP T="" CHVPT ="PS"
  12961   "RTN","CHG CU136",20, 0)
  12962    S PDIJ=99 99,PDIJ=$O (@(GLPAY_" CHCLM,""PD I"",PDIJ)" ),-1)
  12963   "RTN","CHG CU136",21, 0)
  12964    I PDIJ'=" " S:$D(@(G LPAY_"CHCL M,""PDI"", PDIJ,0)"))  CHPDI=$P( ^(0),"^",1 )
  12965   "RTN","CHG CU136",22, 0)
  12966    I $D(^CHM IMAGE(CHPD I,"P-VEN") ) D:'$D(@( GLPAY_"CHC LM,""VEN"" )"))
  12967   "RTN","CHG CU136",23, 0)
  12968    .S STR=$P (@(GLPAY_" CHCLM,0)") ,"^",4) Q: STR=""
  12969   "RTN","CHG CU136",24, 0)
  12970    .S CHPAGE =$P(STR,"* ",2),CHIMA G=$P(STR," *",3)
  12971   "RTN","CHG CU136",25, 0)
  12972    .Q:'$D(^C HMIMAGE(CH PDI,1,CHPA GE,2,CHIMA G,"VEN"))
  12973   "RTN","CHG CU136",26, 0)
  12974    .S PTR=$P (^("VEN"), "^",14)
  12975   "RTN","CHG CU136",27, 0)
  12976    .Q:PTR=""   Q:'$D(^C HMAGE(CHPD I,"P-VEN", PTR,0))
  12977   "RTN","CHG CU136",28, 0)
  12978    .D NOW^%D TC
  12979   "RTN","CHG CU136",29, 0)
  12980    .S @(GLPA Y_"CHCLM," "VEN"",CHV PT,%,0)")= ^CHMIMAGE( CHPDI,"P-V EN",PTR,0)
  12981   "RTN","CHG CU136",30, 0)
  12982    S REC1=""  S:$D(^CHM VEN(CHVPT, 2)) REC1=^ CHMVEN(CHV PT,2)
  12983   "RTN","CHG CU136",31, 0)
  12984    N RECRT S  RECRT=""  S:$D(^CHMV EN(CHVPT,1 )) RECRT=^ CHMVEN(CHV PT,1)  ;CF S - Defect  828050
  12985   "RTN","CHG CU136",32, 0)
  12986    S RECV=""  S:$D(^CHM VEN(CHVPT, 1)) RECV=^ (0)
  12987   "RTN","CHG CU136",33, 0)
  12988    S CHVEN=" " S:$D(^CH MVEN(CHVPT ,2)) CHVEN =$P(^(2)," ^",8)
  12989   "RTN","CHG CU136",34, 0)
  12990    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  12991   "RTN","CHG CU136",35, 0)
  12992    .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
  12993   "RTN","CHG CU136",36, 0)
  12994    ;S CHPRT= $J("Vendor :",20),CHF LD=CHVEN D  SET
  12995   "RTN","CHG CU136",37, 0)
  12996    S CHPRT=$ J("Remit-t o Vendor:" ,20),CHFLD =$P(RECV," ^") D SET   ;CFS - De fect 82805 0
  12997   "RTN","CHG CU136",38, 0)
  12998    S CHTID=$ P(RECV,"^" ,3) I $D(@ (GLPAY_"CH CLM,""VEN" ",CHVPT)") ) D
  12999   "RTN","CHG CU136",39, 0)
  13000    .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
  13001   "RTN","CHG CU136",40, 0)
  13002    S CHPRT=$ J("Tax ID: ",20),CHFL D=CHTID D  SET
  13003   "RTN","CHG CU136",41, 0)
  13004    I '$D(^CH MVEN(CHVPT ,2)) D:$D( ^CHMVEN(CH VPT,1))
  13005   "RTN","CHG CU136",42, 0)
  13006    .F CC=1:1 :6 S $P(^C HMVEN(CHVP T,2),"^",C C)=$P(^CHM VEN(CHVPT, 1),"^",CC)
  13007   "RTN","CHG CU136",43, 0)
  13008    .S $P(^CH MVEN(CHVPT ,2),"^",10 )=$P(^CHMV EN(CHVPT,1 ),"^",17)
  13009   "RTN","CHG CU136",44, 0)
  13010    .S $P(^CH MVEN(CHVPT ,2),"^",11 )=$P(^CHMV EN(CHVPT,1 ),"^",18)
  13011   "RTN","CHG CU136",45, 0)
  13012    S CHADD1= $P(REC1,"^ ",1)
  13013   "RTN","CHG CU136",46, 0)
  13014    N CHADD1C  S CHADD1C =""
  13015   "RTN","CHG CU136",47, 0)
  13016    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13017   "RTN","CHG CU136",48, 0)
  13018    .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
  13019   "RTN","CHG CU136",49, 0)
  13020    ;S CHPRT= $J("Addres s Line 1:" ,20),CHFLD =CHADD1 D  SET
  13021   "RTN","CHG CU136",50, 0)
  13022    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
  13023   "RTN","CHG CU136",51, 0)
  13024    S CHADD2= $P(REC1,"^ ",2)
  13025   "RTN","CHG CU136",52, 0)
  13026    N CHADD2C  S CHADD2C =""
  13027   "RTN","CHG CU136",53, 0)
  13028    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13029   "RTN","CHG CU136",54, 0)
  13030    .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
  13031   "RTN","CHG CU136",55, 0)
  13032    ;S CHPRT= $J("Addres s Line 2:" ,20),CHFLD =CHADD2 D  SET
  13033   "RTN","CHG CU136",56, 0)
  13034    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
  13035   "RTN","CHG CU136",57, 0)
  13036    S CHCITY= $P(REC1,"^ ",3)
  13037   "RTN","CHG CU136",58, 0)
  13038    N CHCITYC  S CHCITYC =""
  13039   "RTN","CHG CU136",59, 0)
  13040    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13041   "RTN","CHG CU136",60, 0)
  13042    .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
  13043   "RTN","CHG CU136",61, 0)
  13044    ;---CFS B egin Defec t 828050
  13045   "RTN","CHG CU136",62, 0)
  13046    ;S CHPRT= $J("City:" ,20),CHFLD =CHCITY D  SET
  13047   "RTN","CHG CU136",63, 0)
  13048    S CHPRT=$ J("RT City :",20),CHF LD=$S(CHCI TYC'="":CH CITYC,1:$P (RECRT,"^" ,3)) D SET   ;CFS - D efect 8280 50
  13049   "RTN","CHG CU136",64, 0)
  13050    S PLST=$P (REC1,"^", 4)
  13051   "RTN","CHG CU136",65, 0)
  13052    N RTST S  RTST=$P(RE CRT,"^",4)
  13053   "RTN","CHG CU136",66, 0)
  13054    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13055   "RTN","CHG CU136",67, 0)
  13056    .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
  13057   "RTN","CHG CU136",68, 0)
  13058    S CHSTATE ="" I PLST '="" S:$D( ^DIC(5,PLS T,0)) CHST ATE=$P(^(0 ),"^",1)
  13059   "RTN","CHG CU136",69, 0)
  13060    ;S CHPRT= $J("State: ",20),CHFL D=CHSTATE  D SET
  13061   "RTN","CHG CU136",70, 0)
  13062    N RTSTATE
  13063   "RTN","CHG CU136",71, 0)
  13064    S RTSTATE ="" I RTST '="" S:$D( ^DIC(5,RTS T,0)) RTST ATE=$P(^DI C(5,RTST,0 ),"^",1)
  13065   "RTN","CHG CU136",72, 0)
  13066    S CHPRT=$ J("RT Stat e:",20),CH FLD=$S(RTS TATE'="":R TSTATE,1:$ P(RECRT,"^ ",4)) D SE T
  13067   "RTN","CHG CU136",73, 0)
  13068    S CHZIP=$ P(REC1,"^" ,5)
  13069   "RTN","CHG CU136",74, 0)
  13070    N CHZIPC  S CHZIPC=" "
  13071   "RTN","CHG CU136",75, 0)
  13072    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13073   "RTN","CHG CU136",76, 0)
  13074    .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
  13075   "RTN","CHG CU136",77, 0)
  13076    ;S CHPRT= $J("Zip:", 20),CHFLD= CHZIP D SE T
  13077   "RTN","CHG CU136",78, 0)
  13078    S CHPRT=$ J("RT Zip: ",20),CHFL D=$S(CHZIP C'="":CHZI PC,1:$P(RE CRT,"^",5) ) D SET  ; CFS - Defe ct 828050
  13079   "RTN","CHG CU136",79, 0)
  13080    ;---CFS E nd Defect  828050
  13081   "RTN","CHG CU136",80, 0)
  13082    S CHCMAC= "" D:$D(^C HMVEN(CHVP T,41))
  13083   "RTN","CHG CU136",81, 0)
  13084    .S CJ=$O( ^CHMVEN(CH VPT,41,999 9999),-1)  Q:'CJ
  13085   "RTN","CHG CU136",82, 0)
  13086    .S CHCMAC =$P(^(CJ,0 ),"^",3)
  13087   "RTN","CHG CU136",83, 0)
  13088    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D
  13089   "RTN","CHG CU136",84, 0)
  13090    .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
  13091   "RTN","CHG CU136",85, 0)
  13092    S CHPRT=$ J("CMAC Co de:",20),C HFLD=CHCMA C D SET
  13093   "RTN","CHG CU136",86, 0)
  13094    S CHVNPG= "" S:$D(@( GLPAY_"CHC LM,9)")) C HVNPG=$P(^ (9),"^",6)
  13095   "RTN","CHG CU136",87, 0)
  13096    S CHPRT=$ J("Vendor  Page:",20) ,CHFLD=CHV NPG D SET
  13097   "RTN","CHG CU136",88, 0)
  13098    S CHASN=$ P(REC0,"^" ,5),CHASN= $S(CHASN=0 :"No",CHAS N=1:"Yes", 1:"No")
  13099   "RTN","CHG CU136",89, 0)
  13100    S CHPRT=$ J("Assignm ent:",20), CHFLD=CHAS N D SET
  13101   "RTN","CHG CU136",90, 0)
  13102    S CHPCN=$ P(REC7,"^" ,5)
  13103   "RTN","CHG CU136",91, 0)
  13104    S CHPRT=$ J("PCN:",2 0),CHFLD=C HPCN D SET
  13105   "RTN","CHG CU136",92, 0)
  13106    S CHTOB=$ P(REC7,"^" ,6)
  13107   "RTN","CHG CU136",93, 0)
  13108    S CHPRT=$ J("TOB:",2 0),CHFLD=C HTOB D SET
  13109   "RTN","CHG CU136",94, 0)
  13110    ;S CHDAMT =$P(REC0," ^",16)
  13111   "RTN","CHG CU136",95, 0)
  13112    ;S CHPRT= $J("Discou nt Amt:",2 0)
  13113   "RTN","CHG CU136",96, 0)
  13114    ;S:CHDAMT '="" CHDAM T="$"_$J($ FN(CHDAMT, "",2),9)
  13115   "RTN","CHG CU136",97, 0)
  13116    ;S CHFLD= CHDAMT D S ET
  13117   "RTN","CHG CU136",98, 0)
  13118    ;S CHFAC= "",RECF=""  S:$D(^CHM VEN(CHVPT, 1)) RECF=^ (1)
  13119   "RTN","CHG CU136",99, 0)
  13120    ;S CHFAC= $P(RECF,"^ ",7)
  13121   "RTN","CHG CU136",100 ,0)
  13122    ;I CHFAC' ="" S:$D(^ CHMDIC(741 002.11,CHF AC,0)) CHF AC=$P(^(0) ,"^",2)
  13123   "RTN","CHG CU136",101 ,0)
  13124    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  13125   "RTN","CHG CU136",102 ,0)
  13126    ;;.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
  13127   "RTN","CHG CU136",103 ,0)
  13128    ;S CHPRT= $J("Facili ty Type:", 20),CHFLD= CHFAC D SE T
  13129   "RTN","CHG CU136",104 ,0)
  13130    ;S CHSP=$ P(RECF,"^" ,11)
  13131   "RTN","CHG CU136",105 ,0)
  13132    ;I CHSP'= "" S:$D(^C HMDIC(7410 02.26,CHSP ,0)) CHSP= $P(^(0),"^ ",1)
  13133   "RTN","CHG CU136",106 ,0)
  13134    ;I $D(@(G LPAY_"CHCL M,""VEN"", CHVPT)"))  D
  13135   "RTN","CHG CU136",107 ,0)
  13136    ;;.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
  13137   "RTN","CHG CU136",108 ,0)
  13138    ;S CHPRT= $J("Specia lty Type:" ,20),CHFLD =CHSP D SE T
  13139   "RTN","CHG CU136",109 ,0)
  13140    S CHPHON= $P(RECV,"^ ",6) I $D( @(GLPAY_"C HCLM,""VEN "",CHVPT)" )) D
  13141   "RTN","CHG CU136",110 ,0)
  13142    .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
  13143   "RTN","CHG CU136",111 ,0)
  13144    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.
  13145   "RTN","CHG CU136",112 ,0)
  13146    ;--Begin  Defect 686 377
  13147   "RTN","CHG CU136",113 ,0)
  13148    S CHPLZIP =""
  13149   "RTN","CHG CU136",114 ,0)
  13150    I $D(@(GL PAY_"CHCLM ,""VEN"",C HVPT)")) D   ;Add PL  ZIP CPE001 -005
  13151   "RTN","CHG CU136",115 ,0)
  13152    .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
  13153   "RTN","CHG CU136",116 ,0)
  13154    I CHPLZIP ="" D  ;Ge t PL Zip
  13155   "RTN","CHG CU136",117 ,0)
  13156    .I $D(^CH MPAY(CHCLM ,"VEN-II") ) S CHPLZI P=$P(^CHMP AY(CHCLM," VEN-II")," ^",15)
  13157   "RTN","CHG CU136",118 ,0)
  13158    S $P(^CHM PAY(CHCLM, "VEN-II"), U,15)=CHPL ZIP
  13159   "RTN","CHG CU136",119 ,0)
  13160    ;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
  13161   "RTN","CHG CU136",120 ,0)
  13162    ;S CHPRT= $J("PL ZIP :",20),CHF LD=CHPLZIP  D SET
  13163   "RTN","CHG CU136",121 ,0)
  13164    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
  13165   "RTN","CHG CU136",122 ,0)
  13166    ;--End De fect 68637 7
  13167   "RTN","CHG CU136",123 ,0)
  13168   END K PDIJ ,ZK,CHPRT, CHFLD,CHAS N,CHDPER,C HDDAY,CHDA MT,CHCMAC, CHVNPG
  13169   "RTN","CHG CU136",124 ,0)
  13170    K CHCITY, CHADD1,CHA DD2,CHTID, CHVEN,ST,C HSTATE Q
  13171   "RTN","CHG CU136",125 ,0)
  13172    ;
  13173   "RTN","CHG CU136",126 ,0)
  13174   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  13175   "RTN","CHG CU136",127 ,0)
  13176    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  13177   "RTN","CHG CU136",128 ,0)
  13178    Q
  13179   "RTN","CHG CU136",129 ,0)
  13180   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  13181   "RTN","CHG CU136",130 ,0)
  13182    ;
  13183   "RTN","CHG CU136",131 ,0)
  13184   SET S CHCT =CHCT+1
  13185   "RTN","CHG CU136",132 ,0)
  13186    ;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"
  13187   "RTN","CHG CU136",133 ,0)
  13188    S X="X XY  W @CHBON, P1,@CHBOFF  S DX=4 X  XY W P2 S  DX=26 X XY  W P3"   ;  JEH
  13189   "RTN","CHG CU136",134 ,0)
  13190    D UPCT S  ^UTILITY($ J,"CEU",CH ZONE,CT)=X _U_CHCT_U_ CHPRT_U_CH FLD
  13191   "RTN","CHG CU136",135 ,0)
  13192    ;I CT=14  S ABC=ABD
  13193   "RTN","CHG CU136",136 ,0)
  13194    Q
  13195   "RTN","CHG CU136",137 ,0)
  13196    ;
  13197   "RTN","CHG CU136",138 ,0)
  13198   UPCT  ;
  13199   "RTN","CHG CU136",139 ,0)
  13200    ;I CT=14  S ABC=ABD
  13201   "RTN","CHG CU136",140 ,0)
  13202    S (CT,^UT ILITY($J," CEU",CHZON E,0))=CT+1  Q
  13203   "RTN","CHG CU137")
  13204   0^34^B9099 2077
  13205   "RTN","CHG CU137",1,0 )
  13206   CHGCU137 ; CVA/CR;CEU  VENDOR CH ANGE IN SC ROLL ZONE  ;09/13/97   10:15 AM
  13207   "RTN","CHG CU137",2,0 )
  13208    ;;1.0;CHA MPVA SYSTE M;**9**;De cember 20,  2010;Buil d 5
  13209   "RTN","CHG CU137",3,0 )
  13210    ;;2.0
  13211   "RTN","CHG CU137",4,0 )
  13212    ;CPTS #10 846* - PEJ  8/15/96
  13213   "RTN","CHG CU137",5,0 )
  13214    ;CPTS #11 090 11575
  13215   "RTN","CHG CU137",6,0 )
  13216    ;CPTS #12 599 BY DTP  (12-SEP-9 7)
  13217   "RTN","CHG CU137",7,0 )
  13218    ;DEF01102 0 DRW/JAK  - Changed  DY to refl ect 4 on l ine tag EN 1 to stop 
  13219   "RTN","CHG CU137",8,0 )
  13220    ;vendor s creen roll ing issue  - 12/23/10 .
  13221   "RTN","CHG CU137",9,0 )
  13222    ;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.
  13223   "RTN","CHG CU137",10, 0)
  13224    ;CFS 09/2 4/2018 - D efect 8285 26 Validat e RT ZIP a nd PL ZIP.  
  13225   "RTN","CHG CU137",11, 0)
  13226   EN1 ;S DX= 25,DY=2,CH FUNC="CEU"  K EDIT           
  13227   "RTN","CHG CU137",12, 0)
  13228    S DX=26,D Y=4,CHFUNC ="CEU" K E DIT           ;;DEF01 1020 DRW/J AK - Chang e DY from  3 to 4 - 1 2/23/10
  13229   "RTN","CHG CU137",13, 0)
  13230   EN ;S DX=2 5 X XY S I =CHSCRN(CH FUNC,CHZON E,"BEG")+( $Y-2)
  13231   "RTN","CHG CU137",14, 0)
  13232    S DX=26 X  XY S I=CH SCRN(CHFUN C,CHZONE," BEG")+($Y- 4)   ;;DEF 011020 DRW /JAK - Cha nge (y-3)  to ($y-4)  - 12/23/10
  13233   "RTN","CHG CU137",15, 0)
  13234    S CHCT=$P (^UTILITY( $J,"CEU",0 ,I),"^",2)
  13235   "RTN","CHG CU137",16, 0)
  13236    G EN:'$D( ^UTILITY($ J,CHFUNC,C HZONE,I))
  13237   "RTN","CHG CU137",17, 0)
  13238    N FL
  13239   "RTN","CHG CU137",18, 0)
  13240    S FL=$S(I =7:10,I=14 :5,1:256)
  13241   "RTN","CHG CU137",19, 0)
  13242    X XY D CS BRS^CHSC2  Q:$D(DTOUT )  Q:$D(DD OUT)
  13243   "RTN","CHG CU137",20, 0)
  13244    ;NEXT SCR EEN KEY
  13245   "RTN","CHG CU137",21, 0)
  13246    ;I $D(DNO UT) D DNOU T^CHSC1(CH FUNC,CHZON E,DTM,DBM, .DY,.CHSCR N) G EN
  13247   "RTN","CHG CU137",22, 0)
  13248    ;ARROW UP  KEY
  13249   "RTN","CHG CU137",23, 0)
  13250    I $D(D1OU T) D D1OUT ^CHSC1(CHF UNC,CHZONE ,DTM,DBM,. DY,.CHSCRN ) G EN
  13251   "RTN","CHG CU137",24, 0)
  13252    ; PREV PA GE KEY
  13253   "RTN","CHG CU137",25, 0)
  13254    I $D(DPOU T) D DPOUT ^CHSC1(CHF UNC,CHZONE ,DTM,DBM,. DY,.CHSCRN ) G EN
  13255   "RTN","CHG CU137",26, 0)
  13256    ;ARROW DO WN KEY
  13257   "RTN","CHG CU137",27, 0)
  13258    I $D(D2OU T) D D2OUT ^CHSC1(CHF UNC,CHZONE ,DTM,DBM,. DY,.CHSCRN ) G EN
  13259   "RTN","CHG CU137",28, 0)
  13260    D @CHCT Q :$D(DTOUT)   Q:$D(DDO UT)
  13261   "RTN","CHG CU137",29, 0)
  13262    G EN
  13263   "RTN","CHG CU137",30, 0)
  13264   1 ;VENDOR  NAME
  13265   "RTN","CHG CU137",31, 0)
  13266    Q:$D(DTOU T)  Q:$D(D DOUT)
  13267   "RTN","CHG CU137",32, 0)
  13268    D ^CHGCU1 38 I ZNO D   G EN
  13269   "RTN","CHG CU137",33, 0)
  13270    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13271   "RTN","CHG CU137",34, 0)
  13272    .;X XY W  "                                  " S DX=2 5 X XY W P 3 S DX=25  Q
  13273   "RTN","CHG CU137",35, 0)
  13274    .X XY W "                                   " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13275   "RTN","CHG CU137",36, 0)
  13276    I Y="" D  D2OUT^CHSC 1(CHFUNC,C HZONE,DTM, DBM,.DY,.C HSCRN) Q
  13277   "RTN","CHG CU137",37, 0)
  13278    D  G EN
  13279   "RTN","CHG CU137",38, 0)
  13280    .S J=4,X= "P3" S $P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)=$P(Y ,"^",1)
  13281   "RTN","CHG CU137",39, 0)
  13282    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13283   "RTN","CHG CU137",40, 0)
  13284    .X XY W "                                  " X XY W P 3
  13285   "RTN","CHG CU137",41, 0)
  13286    .S $P(EDI T,"^",4)=P 3
  13287   "RTN","CHG CU137",42, 0)
  13288    .S $P(CHV NSTR,"*",1 )=1
  13289   "RTN","CHG CU137",43, 0)
  13290   2 ;TAX ID
  13291   "RTN","CHG CU137",44, 0)
  13292    Q:$D(DTOU T)  Q:$D(D DOUT)
  13293   "RTN","CHG CU137",45, 0)
  13294    D ^CHGCU1 39 I ZNO D   G EN
  13295   "RTN","CHG CU137",46, 0)
  13296    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13297   "RTN","CHG CU137",47, 0)
  13298    .;X XY W  "             " S DX= 25 X XY W  P3 S DX=25  Q
  13299   "RTN","CHG CU137",48, 0)
  13300    .X XY W "              " S DX=2 6 X XY W P 3 S DX=26  Q   ; JEH
  13301   "RTN","CHG CU137",49, 0)
  13302    I Y="" D   Q
  13303   "RTN","CHG CU137",50, 0)
  13304    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13305   "RTN","CHG CU137",51, 0)
  13306    D  G EN
  13307   "RTN","CHG CU137",52, 0)
  13308    .S SSN=Y
  13309   "RTN","CHG CU137",53, 0)
  13310    .F J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=$P(Y,"^ ",1)
  13311   "RTN","CHG CU137",54, 0)
  13312    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13313   "RTN","CHG CU137",55, 0)
  13314    .;X XY W  "              " S DX =25 X XY W  P3
  13315   "RTN","CHG CU137",56, 0)
  13316    .X XY W "               " S DX= 26 X XY W  P3   ; JEH
  13317   "RTN","CHG CU137",57, 0)
  13318    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13319   "RTN","CHG CU137",58, 0)
  13320    .S $P(EDI T,"^",5)=P 3
  13321   "RTN","CHG CU137",59, 0)
  13322    .S $P(CHV NSTR,"*",2 )=1
  13323   "RTN","CHG CU137",60, 0)
  13324   3 ;ADDR LI NE 1
  13325   "RTN","CHG CU137",61, 0)
  13326    Q:$D(DTOU T)  Q:$D(D DOUT)
  13327   "RTN","CHG CU137",62, 0)
  13328    D ^CHGCU1 40 I ZNO D   G EN
  13329   "RTN","CHG CU137",63, 0)
  13330    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13331   "RTN","CHG CU137",64, 0)
  13332    .;X XY W  "                                 " S DX=25  X XY W P3  S DX=25 Q
  13333   "RTN","CHG CU137",65, 0)
  13334    .X XY W "                                  " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13335   "RTN","CHG CU137",66, 0)
  13336    I Y="" D   Q
  13337   "RTN","CHG CU137",67, 0)
  13338    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13339   "RTN","CHG CU137",68, 0)
  13340    D  G EN
  13341   "RTN","CHG CU137",69, 0)
  13342    .S:Y="@"  Y=" "
  13343   "RTN","CHG CU137",70, 0)
  13344    .F J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=$P(Y,"^ ",1)
  13345   "RTN","CHG CU137",71, 0)
  13346    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13347   "RTN","CHG CU137",72, 0)
  13348    .;X XY W  "                                 " S DX=25  X XY W P3
  13349   "RTN","CHG CU137",73, 0)
  13350    .X XY W "                                  " S DX=26  X XY W P3    ; JEH
  13351   "RTN","CHG CU137",74, 0)
  13352    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13353   "RTN","CHG CU137",75, 0)
  13354    .S $P(EDI T,"^",7)=P 3
  13355   "RTN","CHG CU137",76, 0)
  13356    .S $P(CHV NSTR,"*",3 )=1
  13357   "RTN","CHG CU137",77, 0)
  13358   4 ;ADDR LI NE 2
  13359   "RTN","CHG CU137",78, 0)
  13360    Q:$D(DTOU T)  Q:$D(D DOUT)
  13361   "RTN","CHG CU137",79, 0)
  13362    D ^CHGCU1 40 I ZNO D   G EN
  13363   "RTN","CHG CU137",80, 0)
  13364    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13365   "RTN","CHG CU137",81, 0)
  13366    .;X XY W  "                                 " S DX=25  X XY W P3  S DX=25 Q
  13367   "RTN","CHG CU137",82, 0)
  13368    .X XY W "                                  " S DX=25  X XY W P3  S DX=25 Q    ; JEH
  13369   "RTN","CHG CU137",83, 0)
  13370    I Y="" D   Q
  13371   "RTN","CHG CU137",84, 0)
  13372    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13373   "RTN","CHG CU137",85, 0)
  13374    D  G EN
  13375   "RTN","CHG CU137",86, 0)
  13376    .S:Y="@"  Y=" "
  13377   "RTN","CHG CU137",87, 0)
  13378    .F J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=$P(Y,"^ ",1)
  13379   "RTN","CHG CU137",88, 0)
  13380    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13381   "RTN","CHG CU137",89, 0)
  13382    .;X XY W  "                                 " S DX=25  X XY W P3
  13383   "RTN","CHG CU137",90, 0)
  13384    .X XY W "                                  " S DX=26  X XY W P3    ; JEH
  13385   "RTN","CHG CU137",91, 0)
  13386    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13387   "RTN","CHG CU137",92, 0)
  13388    .S $P(EDI T,"^",8)=P 3
  13389   "RTN","CHG CU137",93, 0)
  13390    .S $P(CHV NSTR,"*",4 )=1
  13391   "RTN","CHG CU137",94, 0)
  13392   5 ;CITY
  13393   "RTN","CHG CU137",95, 0)
  13394    Q:$D(DTOU T)  Q:$D(D DOUT)
  13395   "RTN","CHG CU137",96, 0)
  13396    D ^CHGCU1 41 I ZNO D   G EN
  13397   "RTN","CHG CU137",97, 0)
  13398    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13399   "RTN","CHG CU137",98, 0)
  13400    .;X XY W  "                                 " S DX=25  X XY W P3  S DX=25 Q
  13401   "RTN","CHG CU137",99, 0)
  13402    .X XY W "                                  " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13403   "RTN","CHG CU137",100 ,0)
  13404    I Y="" D   Q
  13405   "RTN","CHG CU137",101 ,0)
  13406    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13407   "RTN","CHG CU137",102 ,0)
  13408    D  G EN
  13409   "RTN","CHG CU137",103 ,0)
  13410    .F J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=$P(Y,"^ ",1)
  13411   "RTN","CHG CU137",104 ,0)
  13412    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13413   "RTN","CHG CU137",105 ,0)
  13414    .;X XY W  "                                 " S DX=25  X XY W P3
  13415   "RTN","CHG CU137",106 ,0)
  13416    .X XY W "                                  " S DX=26  X XY W P3    ; JEH
  13417   "RTN","CHG CU137",107 ,0)
  13418    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13419   "RTN","CHG CU137",108 ,0)
  13420    .S $P(EDI T,"^",9)=P 3
  13421   "RTN","CHG CU137",109 ,0)
  13422    .S $P(CHV NSTR,"*",5 )=1
  13423   "RTN","CHG CU137",110 ,0)
  13424   6 ;STATE
  13425   "RTN","CHG CU137",111 ,0)
  13426    Q:$D(DTOU T)  Q:$D(D DOUT)
  13427   "RTN","CHG CU137",112 ,0)
  13428    D ^CHGCU1 42 I ZNO D   G EN
  13429   "RTN","CHG CU137",113 ,0)
  13430    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13431   "RTN","CHG CU137",114 ,0)
  13432    .;X XY W  "                       " S DX=2 5 X XY W P 3 S DX=25  Q
  13433   "RTN","CHG CU137",115 ,0)
  13434    .X XY W "                        " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13435   "RTN","CHG CU137",116 ,0)
  13436    I Y="" D   Q
  13437   "RTN","CHG CU137",117 ,0)
  13438    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13439   "RTN","CHG CU137",118 ,0)
  13440    D  G EN
  13441   "RTN","CHG CU137",119 ,0)
  13442    .S $P(EDI T,"^",10)= $P(Y,"^",1 )
  13443   "RTN","CHG CU137",120 ,0)
  13444    .S $P(CHV NSTR,"*",6 )=1
  13445   "RTN","CHG CU137",121 ,0)
  13446    .F J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=$P(Y,"^ ",2)
  13447   "RTN","CHG CU137",122 ,0)
  13448    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13449   "RTN","CHG CU137",123 ,0)
  13450    .;X XY W  "                       " S DX=2 5 X XY W P 3
  13451   "RTN","CHG CU137",124 ,0)
  13452    .X XY W "                        " S DX=26  X XY W P3    ; JEH
  13453   "RTN","CHG CU137",125 ,0)
  13454    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13455   "RTN","CHG CU137",126 ,0)
  13456   7 ;ZIP COD E
  13457   "RTN","CHG CU137",127 ,0)
  13458    Q:$D(DTOU T)  Q:$D(D DOUT)
  13459   "RTN","CHG CU137",128 ,0)
  13460    D ZIP^CHG CU130 I ZN O D  G EN   ;CFS Defe ct 828526
  13461   "RTN","CHG CU137",129 ,0)
  13462    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13463   "RTN","CHG CU137",130 ,0)
  13464    .;X XY W  "           " S DX=25  X XY W P3  S DX=25 Q
  13465   "RTN","CHG CU137",131 ,0)
  13466    .X XY W "            " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13467   "RTN","CHG CU137",132 ,0)
  13468    I Y="" D   Q
  13469   "RTN","CHG CU137",133 ,0)
  13470    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13471   "RTN","CHG CU137",134 ,0)
  13472    D  G EN
  13473   "RTN","CHG CU137",135 ,0)
  13474    .S J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=Y
  13475   "RTN","CHG CU137",136 ,0)
  13476    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13477   "RTN","CHG CU137",137 ,0)
  13478    .;X XY W  "            " S DX=2 5 X XY W P 3
  13479   "RTN","CHG CU137",138 ,0)
  13480    .X XY W "             " S DX=26  X XY W P3    ; JEH
  13481   "RTN","CHG CU137",139 ,0)
  13482    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13483   "RTN","CHG CU137",140 ,0)
  13484    .S $P(EDI T,"^",11)= P3
  13485   "RTN","CHG CU137",141 ,0)
  13486    .S $P(CHV NSTR,"*",7 )=1
  13487   "RTN","CHG CU137",142 ,0)
  13488   8 ;CMAC CO DE
  13489   "RTN","CHG CU137",143 ,0)
  13490    Q:$D(DTOU T)  Q:$D(D DOUT)
  13491   "RTN","CHG CU137",144 ,0)
  13492    D ^CHGCU1 43 I ZNO D   G EN
  13493   "RTN","CHG CU137",145 ,0)
  13494    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13495   "RTN","CHG CU137",146 ,0)
  13496    .;X XY W  "      " S  DX=25 X X Y W P3 S D X=25 Q
  13497   "RTN","CHG CU137",147 ,0)
  13498    .X XY W "       " S  DX=26 X XY  W P3 S DX =26 Q   ;  JEH
  13499   "RTN","CHG CU137",148 ,0)
  13500    I Y="" D   Q
  13501   "RTN","CHG CU137",149 ,0)
  13502    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13503   "RTN","CHG CU137",150 ,0)
  13504    D  G EN
  13505   "RTN","CHG CU137",151 ,0)
  13506    .S J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=Y
  13507   "RTN","CHG CU137",152 ,0)
  13508    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13509   "RTN","CHG CU137",153 ,0)
  13510    .;X XY W  "            " S DX=2 5 X XY W P 3
  13511   "RTN","CHG CU137",154 ,0)
  13512    .X XY W "             " S DX=26  X XY W P3    ; JEH
  13513   "RTN","CHG CU137",155 ,0)
  13514    .S $P(EDI T,"^",12)= P3
  13515   "RTN","CHG CU137",156 ,0)
  13516    .S $P(CHV NSTR,"*",8 )=1
  13517   "RTN","CHG CU137",157 ,0)
  13518    .;D NOW^% DTC I $P(@ (GLPAY_"CH CLM,0)")," ^",3)'=""  D
  13519   "RTN","CHG CU137",158 ,0)
  13520    ..S PT=$P (^(0),"^", 3)
  13521   "RTN","CHG CU137",159 ,0)
  13522    ..S $P(^C HMVEN(PT,4 1,%,0),"^" ,1)=%
  13523   "RTN","CHG CU137",160 ,0)
  13524    ..S $P(^C HMVEN(PT,4 1,%,0),"^" ,2)=DUZ
  13525   "RTN","CHG CU137",161 ,0)
  13526    ..S $P(^C HMVEN(PT,4 1,%,0),"^" ,3)=P3
  13527   "RTN","CHG CU137",162 ,0)
  13528    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13529   "RTN","CHG CU137",163 ,0)
  13530    ;VENDOR P AGE
  13531   "RTN","CHG CU137",164 ,0)
  13532   9 Q:$D(DTO UT)  Q:$D( DDOUT)
  13533   "RTN","CHG CU137",165 ,0)
  13534    D ^CHGCU1 44 I ZNO D   G EN
  13535   "RTN","CHG CU137",166 ,0)
  13536    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13537   "RTN","CHG CU137",167 ,0)
  13538    .;X XY W  "        "  S DX=25 X  XY W P3 S  DX=25 Q
  13539   "RTN","CHG CU137",168 ,0)
  13540    .X XY W "         "  S DX=26 X  XY W P3 S  DX=26 Q    ; JEH
  13541   "RTN","CHG CU137",169 ,0)
  13542    I Y="" D   Q
  13543   "RTN","CHG CU137",170 ,0)
  13544    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13545   "RTN","CHG CU137",171 ,0)
  13546    D  G EN
  13547   "RTN","CHG CU137",172 ,0)
  13548    .S J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=Y
  13549   "RTN","CHG CU137",173 ,0)
  13550    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13551   "RTN","CHG CU137",174 ,0)
  13552    .;X XY W  "            " S DX=2 5 X XY W P 3
  13553   "RTN","CHG CU137",175 ,0)
  13554    .X XY W "             " S DX=26  X XY W P3    ;  JEH
  13555   "RTN","CHG CU137",176 ,0)
  13556    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13557   "RTN","CHG CU137",177 ,0)
  13558    .S $P(@(G LPAY_"CHCL M,9)"),"^" ,6)=P3
  13559   "RTN","CHG CU137",178 ,0)
  13560    ;Assignme nt
  13561   "RTN","CHG CU137",179 ,0)
  13562   10 Q:$D(DT OUT)  Q:$D (DDOUT)
  13563   "RTN","CHG CU137",180 ,0)
  13564    D ^CHGCU1 45 I ZNO D   G EN
  13565   "RTN","CHG CU137",181 ,0)
  13566    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13567   "RTN","CHG CU137",182 ,0)
  13568    .;X XY W  "        "  S DX=25 X  XY W P3 S  DX=25 Q
  13569   "RTN","CHG CU137",183 ,0)
  13570    .X XY W "         "  S DX=26 X  XY W P3 S  DX=26 Q    ; JEH
  13571   "RTN","CHG CU137",184 ,0)
  13572    I Y="" D   Q
  13573   "RTN","CHG CU137",185 ,0)
  13574    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13575   "RTN","CHG CU137",186 ,0)
  13576    D  G EN
  13577   "RTN","CHG CU137",187 ,0)
  13578    .S $P(@(G LPAY_"CHCL M,0)"),"^" ,5)=Y
  13579   "RTN","CHG CU137",188 ,0)
  13580    .S Y=$S(Y =0:"No",Y= 1:"Yes",1: "No")
  13581   "RTN","CHG CU137",189 ,0)
  13582    .S J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=Y
  13583   "RTN","CHG CU137",190 ,0)
  13584    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13585   "RTN","CHG CU137",191 ,0)
  13586    .X XY W "             " S DX=25  X XY W P3
  13587   "RTN","CHG CU137",192 ,0)
  13588    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13589   "RTN","CHG CU137",193 ,0)
  13590    ;PATIENT  CONTROL NU MBER
  13591   "RTN","CHG CU137",194 ,0)
  13592   11 Q:$D(DT OUT)  Q:$D (DDOUT)
  13593   "RTN","CHG CU137",195 ,0)
  13594    D ^CHGCU1 46 I ZNO D   G EN
  13595   "RTN","CHG CU137",196 ,0)
  13596    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13597   "RTN","CHG CU137",197 ,0)
  13598    .;X XY W  "                                  " S DX=2 5 X XY W P 3 S DX=25  Q
  13599   "RTN","CHG CU137",198 ,0)
  13600    .X XY W "                                   " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13601   "RTN","CHG CU137",199 ,0)
  13602    I Y="" D   Q
  13603   "RTN","CHG CU137",200 ,0)
  13604    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13605   "RTN","CHG CU137",201 ,0)
  13606    D  G EN
  13607   "RTN","CHG CU137",202 ,0)
  13608    .S:Y="@"  Y=""
  13609   "RTN","CHG CU137",203 ,0)
  13610    .S J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=Y
  13611   "RTN","CHG CU137",204 ,0)
  13612    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13613   "RTN","CHG CU137",205 ,0)
  13614    .;X XY W  "                                  " S DX=2 5 X XY W P 3
  13615   "RTN","CHG CU137",206 ,0)
  13616    .X XY W "                                   " S DX=26  X XY W P3    ; JEH
  13617   "RTN","CHG CU137",207 ,0)
  13618    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13619   "RTN","CHG CU137",208 ,0)
  13620    .S $P(@(G LPAY_"CHCL M,7)"),"^" ,5)=Y
  13621   "RTN","CHG CU137",209 ,0)
  13622    ;TYPE OF  BILL
  13623   "RTN","CHG CU137",210 ,0)
  13624   12 Q:$D(DT OUT)  Q:$D (DDOUT)
  13625   "RTN","CHG CU137",211 ,0)
  13626    D ^CHGCU1 47 I ZNO D   G EN
  13627   "RTN","CHG CU137",212 ,0)
  13628    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13629   "RTN","CHG CU137",213 ,0)
  13630    .;X XY W  "        "  S DX=25 X  XY W P3 S  DX=25 Q
  13631   "RTN","CHG CU137",214 ,0)
  13632    .X XY W "         "  S DX=26 X  XY W P3 S  DX=26 Q    ; JEH
  13633   "RTN","CHG CU137",215 ,0)
  13634    I Y="" D   Q
  13635   "RTN","CHG CU137",216 ,0)
  13636    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13637   "RTN","CHG CU137",217 ,0)
  13638    D  G EN
  13639   "RTN","CHG CU137",218 ,0)
  13640    .S:Y="@"  Y=""
  13641   "RTN","CHG CU137",219 ,0)
  13642    .S J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=Y
  13643   "RTN","CHG CU137",220 ,0)
  13644    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13645   "RTN","CHG CU137",221 ,0)
  13646    .;X XY W  "            " S DX=2 5 X XY W P 3
  13647   "RTN","CHG CU137",222 ,0)
  13648    .X XY W "             " S DX=26  X XY W P3    ; JEH
  13649   "RTN","CHG CU137",223 ,0)
  13650    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13651   "RTN","CHG CU137",224 ,0)
  13652    .S $P(@(G LPAY_"CHCL M,7)"),"^" ,6)=Y
  13653   "RTN","CHG CU137",225 ,0)
  13654    ;DISCOUNT  AMT 
  13655   "RTN","CHG CU137",226 ,0)
  13656    ;DEF01102 0 DRW/JAK  - DISCOUNT  AMT Secti on not bei ng used, c omment out  the entir e area - 1 2/23/10
  13657   "RTN","CHG CU137",227 ,0)
  13658    ;13 ;Q:$D (DTOUT)  Q :$D(DDOUT)
  13659   "RTN","CHG CU137",228 ,0)
  13660    ;D ^CHGCU 148 I ZNO  D  G EN
  13661   "RTN","CHG CU137",229 ,0)
  13662    ;.S J=4 S  P3=$P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)
  13663   "RTN","CHG CU137",230 ,0)
  13664    ;.;X XY W  "         " S DX=25  X XY W P3  S DX=25 Q
  13665   "RTN","CHG CU137",231 ,0)
  13666    ;.X XY W  "        "  S DX=26 X  XY W P3 S  DX=26 Q    ; JEH
  13667   "RTN","CHG CU137",232 ,0)
  13668    ;I Y="" D   Q
  13669   "RTN","CHG CU137",233 ,0)
  13670    ;.D D2OUT ^CHSC1(CHF UNC,CHZONE ,DTM,DBM,. DY,.CHSCRN )
  13671   "RTN","CHG CU137",234 ,0)
  13672    ;D  G EN
  13673   "RTN","CHG CU137",235 ,0)
  13674    ;.S:Y="@"  $P(@(GLPA Y_"CHCLM,0 )"),"^",16 )=""
  13675   "RTN","CHG CU137",236 ,0)
  13676    ;.S J=4 S  X="P"_(J- 1) S:Y'=""  $P(^UTILI TY($J,CHFU NC,CHZONE, I),"^",J)= "$"_$J($FN (Y,"",2),9 )
  13677   "RTN","CHG CU137",237 ,0)
  13678    ;.S:Y="@"  $P(^UTILI TY($J,CHFU NC,CHZONE, I),"^",J)= ""
  13679   "RTN","CHG CU137",238 ,0)
  13680    ;.S @X=$P (^UTILITY( $J,CHFUNC, CHZONE,I), "^",J)
  13681   "RTN","CHG CU137",239 ,0)
  13682    ;.;X XY W  "            " S DX= 25 X XY W  P3
  13683   "RTN","CHG CU137",240 ,0)
  13684    ;.X XY W  "            " S DX=2 6 X XY W P 3   ; JEH
  13685   "RTN","CHG CU137",241 ,0)
  13686    ;.D D2OUT ^CHSC1(CHF UNC,CHZONE ,DTM,DBM,. DY,.CHSCRN )
  13687   "RTN","CHG CU137",242 ,0)
  13688    ;.S:Y'="@ " $P(@(GLP AY_"CHCLM, 0)"),"^",1 6)=Y   ;;D EF011020 D RW/JAK - E nd of sect ion 13 DIS COUNT AMT  - 12/23/10
  13689   "RTN","CHG CU137",243 ,0)
  13690    ;-- Begin  Defect 68 6377
  13691   "RTN","CHG CU137",244 ,0)
  13692   13 ;PHONE  NUMBER
  13693   "RTN","CHG CU137",245 ,0)
  13694    Q:$D(DTOU T)  Q:$D(D DOUT)
  13695   "RTN","CHG CU137",246 ,0)
  13696    D ^CHGCU1 68 I ZNO D   G EN
  13697   "RTN","CHG CU137",247 ,0)
  13698    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13699   "RTN","CHG CU137",248 ,0)
  13700    .;X XY W  "             " S DX= 25 X XY W  P3 S DX=25  Q
  13701   "RTN","CHG CU137",249 ,0)
  13702    .X XY W "              " S DX=2 6 X XY W P 3 S DX=26  Q   ; JEH
  13703   "RTN","CHG CU137",250 ,0)
  13704    I Y="" D   Q
  13705   "RTN","CHG CU137",251 ,0)
  13706    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13707   "RTN","CHG CU137",252 ,0)
  13708    D  G EN
  13709   "RTN","CHG CU137",253 ,0)
  13710    .S PHONE= Y
  13711   "RTN","CHG CU137",254 ,0)
  13712    .F J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=$P(Y,"^ ",1)
  13713   "RTN","CHG CU137",255 ,0)
  13714    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13715   "RTN","CHG CU137",256 ,0)
  13716    .;X XY W  "              " S DX =25 X XY W  P3
  13717   "RTN","CHG CU137",257 ,0)
  13718    .X XY W "               " S DX= 26 X XY W  P3    ; JE H
  13719   "RTN","CHG CU137",258 ,0)
  13720    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13721   "RTN","CHG CU137",259 ,0)
  13722    .S $P(EDI T,"^",13)= P3
  13723   "RTN","CHG CU137",260 ,0)
  13724    .S $P(CHV NSTR,"*",9 )=1
  13725   "RTN","CHG CU137",261 ,0)
  13726   14 ;PL ZIP
  13727   "RTN","CHG CU137",262 ,0)
  13728    Q:$D(DTOU T)  Q:$D(D DOUT)
  13729   "RTN","CHG CU137",263 ,0)
  13730    D PLZIP^C HGCU130 I  ZNO D  G E N  ;CFS De fect 82852 6
  13731   "RTN","CHG CU137",264 ,0)
  13732    .S J=4 S  P3=$P(^UTI LITY($J,CH FUNC,CHZON E,I),"^",J )
  13733   "RTN","CHG CU137",265 ,0)
  13734    .;X XY W  "           " S DX=25  X XY W P3  S DX=25 Q
  13735   "RTN","CHG CU137",266 ,0)
  13736    .X XY W "            " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13737   "RTN","CHG CU137",267 ,0)
  13738    I Y="" D   Q
  13739   "RTN","CHG CU137",268 ,0)
  13740    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13741   "RTN","CHG CU137",269 ,0)
  13742    D  G EN
  13743   "RTN","CHG CU137",270 ,0)
  13744    .S J=4 S  X="P"_(J-1 ) S $P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)=Y
  13745   "RTN","CHG CU137",271 ,0)
  13746    .S @X=$P( ^UTILITY($ J,CHFUNC,C HZONE,I)," ^",J)
  13747   "RTN","CHG CU137",272 ,0)
  13748    .;X XY W  "            " S DX=2 5 X XY W P 3
  13749   "RTN","CHG CU137",273 ,0)
  13750    .X XY W "             " S DX=26  X XY W P3    ; JEH
  13751   "RTN","CHG CU137",274 ,0)
  13752    .D D2OUT^ CHSC1(CHFU NC,CHZONE, DTM,DBM,.D Y,.CHSCRN)
  13753   "RTN","CHG CU137",275 ,0)
  13754    .S $P(EDI T,"^",16)= P3
  13755   "RTN","CHG CU137",276 ,0)
  13756    .S $P(CHV NSTR,"*",1 2)=1
  13757   "RTN","CHG CU137",277 ,0)
  13758    ;FACILITY  TYPE and  SPECIALTY  TYPE Secti on not bei ng used, c omment out  the entir e area - 0 3/07/2018.
  13759   "RTN","CHG CU137",278 ,0)
  13760    ;15 ;FACI LITY TYPE
  13761   "RTN","CHG CU137",279 ,0)
  13762    ;Q:$D(DTO UT)  Q:$D( DDOUT)
  13763   "RTN","CHG CU137",280 ,0)
  13764    ;D ^CHGCU 163 I ZNO  D  G EN
  13765   "RTN","CHG CU137",281 ,0)
  13766    ;.S J=4 S  P3=$P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)
  13767   "RTN","CHG CU137",282 ,0)
  13768    ;.;X XY W  "                                            " S DX=2 5 X XY W P 3 S DX=25  Q
  13769   "RTN","CHG CU137",283 ,0)
  13770    ;.X XY W  "                                            " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13771   "RTN","CHG CU137",284 ,0)
  13772    ;I Y="" D   Q
  13773   "RTN","CHG CU137",285 ,0)
  13774    ;.D D2OUT ^CHSC1(CHF UNC,CHZONE ,DTM,DBM,. DY,.CHSCRN )
  13775   "RTN","CHG CU137",286 ,0)
  13776    ;D  G EN
  13777   "RTN","CHG CU137",287 ,0)
  13778    ;.S:Y="@"  Y=""
  13779   "RTN","CHG CU137",288 ,0)
  13780    ;.S J=4 S  X="P"_(J- 1) S:Y'=""  $P(^UTILI TY($J,CHFU NC,CHZONE, I),"^",J)= $P(Y,"^",2 )
  13781   "RTN","CHG CU137",289 ,0)
  13782    ;.S @X=$P (^UTILITY( $J,CHFUNC, CHZONE,I), "^",J)
  13783   "RTN","CHG CU137",290 ,0)
  13784    ;.;X XY W  "                                            " S DX=2 5 X XY W P 3
  13785   "RTN","CHG CU137",291 ,0)
  13786    ;.X XY W  "                                            " S DX=26  X XY W P3    ; JEH
  13787   "RTN","CHG CU137",292 ,0)
  13788    ;.S $P(ED IT,"^",14) =$P(Y,"^", 2)
  13789   "RTN","CHG CU137",293 ,0)
  13790    ;.S $P(CH VNSTR,"*", 10)=1
  13791   "RTN","CHG CU137",294 ,0)
  13792    ;16 ;SPEC IALTY
  13793   "RTN","CHG CU137",295 ,0)
  13794    ;Q:$D(DTO UT)  Q:$D( DDOUT)
  13795   "RTN","CHG CU137",296 ,0)
  13796    ;D ^CHGCU 164 I ZNO  D  G EN
  13797   "RTN","CHG CU137",297 ,0)
  13798    ;.S J=4 S  P3=$P(^UT ILITY($J,C HFUNC,CHZO NE,I),"^", J)
  13799   "RTN","CHG CU137",298 ,0)
  13800    ;.;X XY W  "                                            " S DX=2 5 X XY W P 3 S DX=25  Q
  13801   "RTN","CHG CU137",299 ,0)
  13802    ;.X XY W  "                                            " S DX=26  X XY W P3  S DX=26 Q    ; JEH
  13803   "RTN","CHG CU137",300 ,0)
  13804    ;I Y="" D   Q
  13805   "RTN","CHG CU137",301 ,0)
  13806    ;.D D2OUT ^CHSC1(CHF UNC,CHZONE ,DTM,DBM,. DY,.CHSCRN )
  13807   "RTN","CHG CU137",302 ,0)
  13808    ;D  G EN
  13809   "RTN","CHG CU137",303 ,0)
  13810    ;.S:Y="@"  Y=""
  13811   "RTN","CHG CU137",304 ,0)
  13812    ;.S J=4 S  X="P"_(J- 1) S:Y'=""  $P(^UTILI TY($J,CHFU NC,CHZONE, I),"^",J)= $P(Y,"^",1 )
  13813   "RTN","CHG CU137",305 ,0)
  13814    ;.S @X=$P (^UTILITY( $J,CHFUNC, CHZONE,I), "^",J)
  13815   "RTN","CHG CU137",306 ,0)
  13816    ;.;X XY W  "                                            " S DX=2 5 X XY W P 3
  13817   "RTN","CHG CU137",307 ,0)
  13818    ;.X XY W  "                                            " S DX=26  X XY W P3    ; JEH
  13819   "RTN","CHG CU137",308 ,0)
  13820    ;.S $P(ED IT,"^",15) =$P(Y,"^", 1)
  13821   "RTN","CHG CU137",309 ,0)
  13822    ;.S $P(CH VNSTR,"*", 11)=1
  13823   "RTN","CHG CU137",310 ,0)
  13824    ;-- End D efect 6863 77
  13825   "RTN","CHG CU137",311 ,0)
  13826   END Q
  13827   "RTN","CHG CU137",312 ,0)
  13828    ;
  13829   "RTN","CHG CU137",313 ,0)
  13830   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  13831   "RTN","CHG CU137",314 ,0)
  13832    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  13833   "RTN","CHG CU137",315 ,0)
  13834    Q
  13835   "RTN","CHG CU137",316 ,0)
  13836   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  13837   "RTN","CHG CU137",317 ,0)
  13838    ;
  13839   "RTN","CHG DQ2")
  13840   0^35^B1560 01132
  13841   "RTN","CHG DQ2",1,0)
  13842   CHGDQ2 ;HB G/DEN;FORM AT DUP CLA IM OUTPUT  FOR DISPLA Y IN QUE;F eb 06, 201 9@09:02:12
  13843   "RTN","CHG DQ2",2,0)
  13844    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  13845   "RTN","CHG DQ2",3,0)
  13846    ;V2.0
  13847   "RTN","CHG DQ2",4,0)
  13848    ; PT 1611 0 (Y2K)
  13849   "RTN","CHG DQ2",5,0)
  13850    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  13851   "RTN","CHG DQ2",6,0)
  13852    ;             CHZONE  - SCREEN  REGION
  13853   "RTN","CHG DQ2",7,0)
  13854    ;CPTS #10 795* BY RL C, CPTS #1 0857* BY R LC, #11567 *-RLC, #12 202* (RLC)
  13855   "RTN","CHG DQ2",8,0)
  13856    ;CPTS #12 881* BY DT P, #13310*  (RLC)
  13857   "RTN","CHG DQ2",9,0)
  13858    ;CPTS #16 432 (RLC)  - MODIFICA TIONS MADE  FOR IPS S CREEN SCRA PING
  13859   "RTN","CHG DQ2",10,0)
  13860    ;DEV00782 0 5/15/201 1 DGC
  13861   "RTN","CHG DQ2",11,0)
  13862    ;MTN01316 3 11/1/201 1 DGC
  13863   "RTN","CHG DQ2",12,0)
  13864    ;CPE001-0 07 ;05/11/ 2017; AJF
  13865   "RTN","CHG DQ2",13,0)
  13866    ;Defect 8 32284 11/2 8/2018 DYO  Not displ ay PL ZIP  filed for  DME TRV an d RX claim s
  13867   "RTN","CHG DQ2",14,0)
  13868    ;
  13869   "RTN","CHG DQ2",15,0)
  13870    K ^UTILIT Y($J) S CH ZONE=1 D E N1
  13871   "RTN","CHG DQ2",16,0)
  13872    G:'$D(CHC LM) AEND G :'$D(^CHMD PCL(741010 .13,"D",CH CLM)) AEND
  13873   "RTN","CHG DQ2",17,0)
  13874    S I=$O(^C HMDPCL(741 010.13,"D" ,CHCLM,0))
  13875   "RTN","CHG DQ2",18,0)
  13876    G:'$D(^CH MDPCL(7410 10.13,I,1) ) AEND S J =0
  13877   "RTN","CHG DQ2",19,0)
  13878   A S J=$O(^ CHMDPCL(74 1010.13,I, 1,J)) G:'J  AEND
  13879   "RTN","CHG DQ2",20,0)
  13880    G:'$D(^CH MDPCL(7410 10.13,I,1, J,0)) A S  CHCLM=$P(^ (0),"^",1)  D EN1
  13881   "RTN","CHG DQ2",21,0)
  13882   AEND Q
  13883   "RTN","CHG DQ2",22,0)
  13884   EN1 N (CHZ ONE,CHCLM, CHOHIP,GLP AY,GLELG,G LDFN,CHPRO G)
  13885   "RTN","CHG DQ2",23,0)
  13886    ;D CHECK^ CHGDQU2
  13887   "RTN","CHG DQ2",24,0)
  13888    K @(GLPAY _"CHCLM,"" RULE-DUP"" )")
  13889   "RTN","CHG DQ2",25,0)
  13890    S (VNPT,C HTDDT,CHBR DT,CHAGE,C HDB,CHDOB, CHSEX)=""
  13891   "RTN","CHG DQ2",26,0)
  13892    S:'$D(^UT ILITY($J," DUP",CHZON E,0)) ^UTI LITY($J,"D UP",CHZONE ,0)=0
  13893   "RTN","CHG DQ2",27,0)
  13894    S CT=^UTI LITY($J,"D UP",CHZONE ,0),U="^"
  13895   "RTN","CHG DQ2",28,0)
  13896    Q:'$D(@(G LPAY_"CHCL M,0)"))  S  REC0=@(GL PAY_"CHCLM ,0)")
  13897   "RTN","CHG DQ2",29,0)
  13898    S CHCLMO= $P(REC0,"^ ",1),VNPT= $P(REC0,"^ ",3)
  13899   "RTN","CHG DQ2",30,0)
  13900    S (CHBNPY ,CHTLPD,CH VAMT,CHBAM T,RC1)=""  ;DGC 5/15/ 2011 DEV00 7820
  13901   "RTN","CHG DQ2",31,0)
  13902    S:$D(@(GL PAY_"CHCLM ,""COMMON" ")")) CHBN PY=$P(@(GL PAY_"CHCLM ,""COMMON" ")"),U,3)
  13903   "RTN","CHG DQ2",32,0)
  13904    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
  13905   "RTN","CHG DQ2",33,0)
  13906    S CHVNPG= "" S:$D(@( GLPAY_"CHC LM,9)")) C HVNPG=$P(@ (GLPAY_"CH CLM,9)"),U ,6)
  13907   "RTN","CHG DQ2",34,0)
  13908    S CHCLM(C HZONE,CHCL M)="" S:'$ D(CHCLM(CH ZONE,"CT") ) CHCLM(CH ZONE,"CT") =""
  13909   "RTN","CHG DQ2",35,0)
  13910    S CHCLM(C HZONE,"CT" )=CHCLM(CH ZONE,"CT") +1
  13911   "RTN","CHG DQ2",36,0)
  13912    S (CHPCN, CHTOB,CHST PLB,CHSOHI PB)="" ;DG C 5/15/201 1 DEV00782 0
  13913   "RTN","CHG DQ2",37,0)
  13914    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
  13915   "RTN","CHG DQ2",38,0)
  13916    S CHPDI=" "
  13917   "RTN","CHG DQ2",39,0)
  13918    S J=$O(@( GLPAY_"CHC LM,""PDI"" ,99999)"), -1)
  13919   "RTN","CHG DQ2",40,0)
  13920    I J'="" S :$D(@(GLPA Y_"CHCLM," "PDI"",J,0 )")) CHPDI =$P(@(GLPA Y_"CHCLM," "PDI"",J,0 )"),U,1)
  13921   "RTN","CHG DQ2",41,0)
  13922    S CHDOCID ="" I CHPD I'="" S:$D (^CHMIMG(C HPDI,"DOC" )) CHDOCID =$P(^("DOC "),"^",1)
  13923   "RTN","CHG DQ2",42,0)
  13924    S:CHDOCID '="" CHPDI =CHPDI_"-" _CHDOCID
  13925   "RTN","CHG DQ2",43,0)
  13926    S DFN=$P( REC0,"^",2 1),BFN=$P( REC0,"^",2 2),CHBENE= ""
  13927   "RTN","CHG DQ2",44,0)
  13928    ;THE NEXT  LINE CHEC KS FOR THE  EXISTENCE  OF BENE W ATCH INFO
  13929   "RTN","CHG DQ2",45,0)
  13930    D BWATCH^ CHGDQ3B
  13931   "RTN","CHG DQ2",46,0)
  13932    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)
  13933   "RTN","CHG DQ2",47,0)
  13934    ; Y2K Cha nged DOB t o display  4 dig year
  13935   "RTN","CHG DQ2",48,0)
  13936    S:CHDB'=" " CHDOB=$$ FMTE^XLFDT (CHDB,5)
  13937   "RTN","CHG DQ2",49,0)
  13938    D NOW^%DT C S CHTDDT =$P(%H,"," ,1)
  13939   "RTN","CHG DQ2",50,0)
  13940    I CHDB=""  S CHAGE=" UNK" G EN2
  13941   "RTN","CHG DQ2",51,0)
  13942    S X=CHDB  D H^%DTC S  CHBRDT=%H
  13943   "RTN","CHG DQ2",52,0)
  13944    S CHAGE=( (CHTDDT-CH BRDT)/365. 25)\1
  13945   "RTN","CHG DQ2",53,0)
  13946   EN2 S X=$P (REC0,"^", 8) S CHDOS ="" I X'=" " D
  13947   "RTN","CHG DQ2",54,0)
  13948    .S CHDOS= $E(X,4,5)_ $E(X,6,7)_ $E(X,2,3)
  13949   "RTN","CHG DQ2",55,0)
  13950    K CMOP S: $D(@(GLPAY _"CHCLM,"" ZEMC"",""C MOP"")"))  CMOP="Yes"
  13951   "RTN","CHG DQ2",56,0)
  13952    S CHTOS=" " S X=$P(R EC0,"^",7)  I $D(^CHM DIC(741002 .05,X,0))  D
  13953   "RTN","CHG DQ2",57,0)
  13954    .S CHTOS= $P(^(0),"^ ",2)
  13955   "RTN","CHG DQ2",58,0)
  13956    I CHTOS=" IPT" S X=" " I $D(@(G LPAY_"CHCL M,""INP"") ")) D  S C HDOS=CHDOS _"-"_X
  13957   "RTN","CHG DQ2",59,0)
  13958    .S X=$P(@ (GLPAY_"CH CLM,""INP" ")"),"^",1 ),X=$E(X,4 ,5)_$E(X,6 ,7)_$E(X,2 ,3)
  13959   "RTN","CHG DQ2",60,0)
  13960    S CHASS=$ S($P(REC0, "^",5):"Y" ,1:"N")
  13961   "RTN","CHG DQ2",61,0)
  13962    S (CHVEN, CHVTID,CHV AC,CHVIM,C HVTIDP)="" ,X=$P(REC0 ,"^",3) I  X'="" D:$D (^CHMVEN(X ,0))
  13963   "RTN","CHG DQ2",62,0)
  13964    .S CHVEN= $P(^(0),"^ ",1),CHVTI D=$P(^(0), "^",3)
  13965   "RTN","CHG DQ2",63,0)
  13966    .;
  13967   "RTN","CHG DQ2",64,0)
  13968    .;8/16/96  - PEJ - m odified to  include V AC and IM  on the dis play.
  13969   "RTN","CHG DQ2",65,0)
  13970    .S CHVAC= $P(^(0),"^ ",23)
  13971   "RTN","CHG DQ2",66,0)
  13972    .S:$D(^CH MVEN(X,14) ) CHVIM=$P (^CHMVEN(X ,14),U,1)
  13973   "RTN","CHG DQ2",67,0)
  13974    .;
  13975   "RTN","CHG DQ2",68,0)
  13976    S:CHVAC=" " CHVAC="   "
  13977   "RTN","CHG DQ2",69,0)
  13978    S:CHVIM=" " CHVIM="   "
  13979   "RTN","CHG DQ2",70,0)
  13980    S CHVTIDP =CHVTID_"- "_CHVAC_"- "_CHVIM
  13981   "RTN","CHG DQ2",71,0)
  13982    S X=$P(RE C0,"^",2)  S CHSTAT=$ P($P($T(ST ATUS),";;" ,2),",",(X +1))
  13983   "RTN","CHG DQ2",72,0)
  13984    S PC1=""
  13985   "RTN","CHG DQ2",73,0)
  13986    S:$D(@(GL PAY_"CHCLM ,""COMMON" ")")) PC1= $P(@(GLPAY _"CHCLM,"" COMMON"")" ),"^",1)
  13987   "RTN","CHG DQ2",74,0)
  13988    S CHTCB=" " S:PC1'=" " CHTCB=$F N(PC1,"",2 )
  13989   "RTN","CHG DQ2",75,0)
  13990    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"
  13991   "RTN","CHG DQ2",76,0)
  13992    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"
  13993   "RTN","CHG DQ2",77,0)
  13994    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
  13995   "RTN","CHG DQ2",78,0)
  13996    S VFLG=""  I VNPT I  $D(^CHMVEN (VNPT,20))  S VFLG="* **VENDOR W ATCH DATA  EXISTS***"
  13997   "RTN","CHG DQ2",79,0)
  13998    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"
  13999   "RTN","CHG DQ2",80,0)
  14000    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHVNPG_ U_CHSEX_U_ CHDOB_U_CH AGE_U_VFLG
  14001   "RTN","CHG DQ2",81,0)
  14002    I $D(CMOP ) D
  14003   "RTN","CHG DQ2",82,0)
  14004    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14005   "RTN","CHG DQ2",83,0)
  14006    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "S DX=35 X  XY W @CHB ON,""CMOP  CLAIM"""
  14007   "RTN","CHG DQ2",84,0)
  14008    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14009   "RTN","CHG DQ2",85,0)
  14010    ;
  14011   "RTN","CHG DQ2",86,0)
  14012    ;Y2K move d "PI:"/CH ASS one li ne down to  make room  for large r PDI
  14013   "RTN","CHG DQ2",87,0)
  14014    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"
  14015   "RTN","CHG DQ2",88,0)
  14016    ;AJF Vend or DQ 007  - PL ZIP
  14017   "RTN","CHG DQ2",89,0)
  14018    S PLZIP=" "
  14019   "RTN","CHG DQ2",90,0)
  14020    S:$D(@(GL PAY_"CHCLM ,""VEN-II" ")")) PLZI P=$P(@(GLP AY_"CHCLM, ""VEN-II"" )"),U,15)
  14021   "RTN","CHG DQ2",91,0)
  14022    S X="X XY  W @CHBON, ""PDI: "", @CHBOFF,P1  S DX=31 X  XY W @CHB ON,""Ven:" ",@CHBOFF, P2 "
  14023   "RTN","CHG DQ2",92,0)
  14024    ;Defect 8 32284 Star t
  14025   "RTN","CHG DQ2",93,0)
  14026    ;Display  PL ZIP for  INP OUT a nd DNT cla ims only
  14027   "RTN","CHG DQ2",94,0)
  14028    I (CHTOS= "OPT")!(CH TOS="IPT") !(CHTOS="D NT") D
  14029   "RTN","CHG DQ2",95,0)
  14030    .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"
  14031   "RTN","CHG DQ2",96,0)
  14032    .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
  14033   "RTN","CHG DQ2",97,0)
  14034    E  D
  14035   "RTN","CHG DQ2",98,0)
  14036    .S X=X_"S  DX=58 X X Y W @CHBON ,""TIN: "" ,@CHBOFF,P 3"
  14037   "RTN","CHG DQ2",99,0)
  14038    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_CHPDI_ U_$E(CHVEN ,1,20)_U_C HVTIDP ;_U _CHASS
  14039   "RTN","CHG DQ2",100,0 )
  14040    ;
  14041   "RTN","CHG DQ2",101,0 )
  14042    ;S DX=75  X XY W@CHB ON,""PI: " ",@CHBOFF, P4"
  14043   "RTN","CHG DQ2",102,0 )
  14044    ;
  14045   "RTN","CHG DQ2",103,0 )
  14046    ;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
  14047   "RTN","CHG DQ2",104,0 )
  14048    ;Defect 8 32284 End
  14049   "RTN","CHG DQ2",105,0 )
  14050    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"
  14051   "RTN","CHG DQ2",106,0 )
  14052    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHPROG_ U_CHTOB_U_ CHPCN_U_CH ASS
  14053   "RTN","CHG DQ2",107,0 )
  14054    ;DGC 11/1 /2011 MTN0 13163 BEGI N
  14055   "RTN","CHG DQ2",108,0 )
  14056    S:CHSOHIP B'="" CHSO HIPB=$J($F N(CHSOHIPB ,",",2),10 )
  14057   "RTN","CHG DQ2",109,0 )
  14058    S:CHSTPLB '="" CHSTP LB=$J($FN( CHSTPLB,", ",2),10)
  14059   "RTN","CHG DQ2",110,0 )
  14060    S X="X XY  W @CHBON, ""OHI PR B AL: "",@CH BOFF,P1 S  DX=26 X XY  W @CHBON, ""TPL PD:  "",@CHBOFF ,P2"
  14061   "RTN","CHG DQ2",111,0 )
  14062    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHSOHIP B_U_CHSTPL B
  14063   "RTN","CHG DQ2",112,0 )
  14064    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=" W """""
  14065   "RTN","CHG DQ2",113,0 )
  14066    I CHTOS=" RXT" I CHP ROG'="SPIN A BIFIDA"  D  G EN3
  14067   "RTN","CHG DQ2",114,0 )
  14068    .;CJM LIN E LENGTH F OR MIGRATI ON R1 2017 0719
  14069   "RTN","CHG DQ2",115,0 )
  14070    .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)"
  14071   "RTN","CHG DQ2",116,0 )
  14072    .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"
  14073   "RTN","CHG DQ2",117,0 )
  14074    .I 'CHZON E D
  14075   "RTN","CHG DQ2",118,0 )
  14076    ..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)"
  14077   "RTN","CHG DQ2",119,0 )
  14078    ..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"
  14079   "RTN","CHG DQ2",120,0 )
  14080    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X
  14081   "RTN","CHG DQ2",121,0 )
  14082    .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"
  14083   "RTN","CHG DQ2",122,0 )
  14084    I CHPROG= "SPINA BIF IDA" I CHT OS="RXT" D   G EN3
  14085   "RTN","CHG DQ2",123,0 )
  14086    .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)"
  14087   "RTN","CHG DQ2",124,0 )
  14088    .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"
  14089   "RTN","CHG DQ2",125,0 )
  14090    .I 'CHZON E D
  14091   "RTN","CHG DQ2",126,0 )
  14092    ..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)"
  14093   "RTN","CHG DQ2",127,0 )
  14094    ..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"
  14095   "RTN","CHG DQ2",128,0 )
  14096    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X
  14097   "RTN","CHG DQ2",129,0 )
  14098    .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"
  14099   "RTN","CHG DQ2",130,0 )
  14100    I CHTOS=" IPT" D  G  EN3
  14101   "RTN","CHG DQ2",131,0 )
  14102    .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
  14103   "RTN","CHG DQ2",132,0 )
  14104    .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
  14105   "RTN","CHG DQ2",133,0 )
  14106    I CHZONE  D
  14107   "RTN","CHG DQ2",134,0 )
  14108    .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)"
  14109   "RTN","CHG DQ2",135,0 )
  14110    .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"
  14111   "RTN","CHG DQ2",136,0 )
  14112    I 'CHZONE  D
  14113   "RTN","CHG DQ2",137,0 )
  14114    .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)"
  14115   "RTN","CHG DQ2",138,0 )
  14116    .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"
  14117   "RTN","CHG DQ2",139,0 )
  14118    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X
  14119   "RTN","CHG DQ2",140,0 )
  14120    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"
  14121   "RTN","CHG DQ2",141,0 )
  14122    ;DGC 11/1 /2011 MTN0 13163 END
  14123   "RTN","CHG DQ2",142,0 )
  14124   EN3 D UPCT  S ^UTILIT Y($J,"DUP" ,CHZONE,CT )=X
  14125   "RTN","CHG DQ2",143,0 )
  14126    S:CHTOS=" OPT" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  14127   "RTN","CHG DQ2",144,0 )
  14128    S:CHTOS=" DUR" CHTDX ="DME-DX", CHTPRC="DM E-SUPPLY"
  14129   "RTN","CHG DQ2",145,0 )
  14130    S:CHTOS=" DNT" CHTDX ="DEN-DX", CHTPRC="DE N-PROC"
  14131   "RTN","CHG DQ2",146,0 )
  14132    S:CHTOS=" TRV" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  14133   "RTN","CHG DQ2",147,0 )
  14134    S CHTOSP= $S(CHTOS=" IPT":CHTOS ,CHTOS="RX T":CHTOS,1 :"OPT")
  14135   "RTN","CHG DQ2",148,0 )
  14136    S (CHQTY, CHRXDX)=""
  14137   "RTN","CHG DQ2",149,0 )
  14138    D:CHTOSP' ="" @CHTOS P^CHGDQ3
  14139   "RTN","CHG DQ2",150,0 )
  14140    ;DGC 5/15 /2011 DEV0 07820 BEGI N
  14141   "RTN","CHG DQ2",151,0 )
  14142    I CHTOS=" IPT" D
  14143   "RTN","CHG DQ2",152,0 )
  14144    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "S DX=57 X  XY W ""== ========"" "
  14145   "RTN","CHG DQ2",153,0 )
  14146    .S X="S D X=57 X XY  W $J(P1,10 )"
  14147   "RTN","CHG DQ2",154,0 )
  14148    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_CHTCB
  14149   "RTN","CHG DQ2",155,0 )
  14150    I CHTOS'= "IPT" D
  14151   "RTN","CHG DQ2",156,0 )
  14152    .S OPRBT= ^TEMP($J," OPRBT",CHC LM)
  14153   "RTN","CHG DQ2",157,0 )
  14154    .S:OPRBT' ="" OPRBT= $J($FN(OPR BT,"",2),1 0)
  14155   "RTN","CHG DQ2",158,0 )
  14156    .S MEDPDT =^TEMP($J, "MEDPDT",C HCLM)
  14157   "RTN","CHG DQ2",159,0 )
  14158    .S:MEDPDT '="" MEDPD T=$J(MEDPD T,10,2)
  14159   "RTN","CHG DQ2",160,0 )
  14160    .S DEDUCT =^TEMP($J, "DEDUCT",C HCLM)
  14161   "RTN","CHG DQ2",161,0 )
  14162    .S:DEDUCT '="" DEDUC T=$J($FN(D EDUCT,"",2 ),10)
  14163   "RTN","CHG DQ2",162,0 )
  14164    .S OHIPRT =^TEMP($J, "OHIPRT",C HCLM)
  14165   "RTN","CHG DQ2",163,0 )
  14166    .S:OHIPRT '="" OHIPR T=$J($FN(O HIPRT,"",2 ),10)
  14167   "RTN","CHG DQ2",164,0 )
  14168    .S OHIPDT =^TEMP($J, "OHIPDT",C HCLM)
  14169   "RTN","CHG DQ2",165,0 )
  14170    .S:OHIPDT '="" OHIPD T=$J($FN(O HIPDT,"",2 ),10)
  14171   "RTN","CHG DQ2",166,0 )
  14172    .S OHIADT =^TEMP($J, "OHIADT",C HCLM)
  14173   "RTN","CHG DQ2",167,0 )
  14174    .S:OHIADT '="" OHIAD T=$J($FN(O HIADT,"",2 ),10)
  14175   "RTN","CHG DQ2",168,0 )
  14176    .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 "" ========== """
  14177   "RTN","CHG DQ2",169,0 )
  14178    .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"
  14179   "RTN","CHG DQ2",170,0 )
  14180    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_CHTCB_ U_DEDUCT_U _OPRBT_U_O HIPDT_U_ME DPDT
  14181   "RTN","CHG DQ2",171,0 )
  14182    .;
  14183   "RTN","CHG DQ2",172,0 )
  14184    .S X="S D X=99 X XY  W P1 S DX= 111 X XY W  P2"
  14185   "RTN","CHG DQ2",173,0 )
  14186    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_OHIPRT _U_OHIADT
  14187   "RTN","CHG DQ2",174,0 )
  14188    ;DGC 5/15 /2011 DEV0 07820 END
  14189   "RTN","CHG DQ2",175,0 )
  14190    I CHBNPY' ="" D
  14191   "RTN","CHG DQ2",176,0 )
  14192    .S X="X X Y W @CHBON ,""Amount  Paid by Be neficiary  to Vendor:  "",@CHBOF F,P1"
  14193   "RTN","CHG DQ2",177,0 )
  14194    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14195   "RTN","CHG DQ2",178,0 )
  14196    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_$J($FN (CHBNPY,", ",2),10)
  14197   "RTN","CHG DQ2",179,0 )
  14198    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14199   "RTN","CHG DQ2",180,0 )
  14200    I CHTLPD' ="" D
  14201   "RTN","CHG DQ2",181,0 )
  14202    .S X="S D X=17 X XY  W @CHBON," "Total Pai d on Claim : "",@CHBO FF,P1"
  14203   "RTN","CHG DQ2",182,0 )
  14204    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_$J($FN (CHTLPD,", ",2),10)
  14205   "RTN","CHG DQ2",183,0 )
  14206    I CHBAMT' ="" D
  14207   "RTN","CHG DQ2",184,0 )
  14208    .S X="S D X=10 X XY  W @CHBON," "Amount Pa id to Bene ficiary: " ",@CHBOFF, P1"
  14209   "RTN","CHG DQ2",185,0 )
  14210    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_$J($FN (CHBAMT,", ",2),10)
  14211   "RTN","CHG DQ2",186,0 )
  14212    I CHVAMT' ="" D
  14213   "RTN","CHG DQ2",187,0 )
  14214    .S X="S D X=15 X XY  W @CHBON," "Amount Pa id to Vend or: "",@CH BOFF,P1"
  14215   "RTN","CHG DQ2",188,0 )
  14216    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= X_U_$J($FN (CHVAMT,", ",2),10)
  14217   "RTN","CHG DQ2",189,0 )
  14218    D REOPEN
  14219   "RTN","CHG DQ2",190,0 )
  14220    I $D(^CHM CLCOM("B", CHCLMO)) D   S CHCOM= CHCLMO D ^ CHGDQ3A K  CHCOM
  14221   "RTN","CHG DQ2",191,0 )
  14222    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14223   "RTN","CHG DQ2",192,0 )
  14224    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Claim Comm ents"",@CH BOFF"
  14225   "RTN","CHG DQ2",193,0 )
  14226    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14227   "RTN","CHG DQ2",194,0 )
  14228    I CHPDI'= "" I $D(^C HMCLCOM("B ",$P(CHPDI ,"-",1)))  D  S CHCOM =$P(CHPDI, "-",1) D ^ CHGDQ3A K  CHCOM
  14229   "RTN","CHG DQ2",195,0 )
  14230    .I '$D(^C HMCLCOM("B ",CHCLMO))  D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=" "
  14231   "RTN","CHG DQ2",196,0 )
  14232    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" PDI Commen ts"",@CHBO FF"
  14233   "RTN","CHG DQ2",197,0 )
  14234    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14235   "RTN","CHG DQ2",198,0 )
  14236    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D  D ^ CHGDQ3B
  14237   "RTN","CHG DQ2",199,0 )
  14238    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14239   "RTN","CHG DQ2",200,0 )
  14240    .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"
  14241   "RTN","CHG DQ2",201,0 )
  14242    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14243   "RTN","CHG DQ2",202,0 )
  14244    I $D(CHMW AT("BENWAT ")) D  D B ENWAT^CHGD Q3B
  14245   "RTN","CHG DQ2",203,0 )
  14246    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14247   "RTN","CHG DQ2",204,0 )
  14248    .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 "
  14249   "RTN","CHG DQ2",205,0 )
  14250    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14251   "RTN","CHG DQ2",206,0 )
  14252    I VNPT'=" " I $D(^CH MVEN(VNPT, 20)) D  D  VWATCH^CHG DQ3B
  14253   "RTN","CHG DQ2",207,0 )
  14254    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14255   "RTN","CHG DQ2",208,0 )
  14256    .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"
  14257   "RTN","CHG DQ2",209,0 )
  14258    .D UPCT S  ^UTILITY( $J,"DUP",C HZONE,CT)= ""
  14259   "RTN","CHG DQ2",210,0 )
  14260    K BFN,CHA SS,CHBENE, CHCLMO,CHD OCID,CHDOS ,CHPDI,CHR OPEN,CHSTA T,CHOHIP
  14261   "RTN","CHG DQ2",211,0 )
  14262    K CHSTAT, CHTCB,CHTD X,CHTOS,CH TOSP,CHTPR C,CHVEN,CH VTID,CT,DF N,I,J,RCT
  14263   "RTN","CHG DQ2",212,0 )
  14264    K CHANS,C HBA,CHBAT, CHCODE,CHD ATA,CHDESC ,CHRULEJ,C HTYPE,RECO ,X,L
  14265   "RTN","CHG DQ2",213,0 )
  14266    K ^TEMP($ J,"DEDUCT" ),^TEMP($J ,"OHIPRT") ,^TEMP($J, "OHIPDT"), ^TEMP($J," OHIADT"),^ TEMP($J,"M EDPDT") Q  ;DGC 5/15/ 2011 DEV00 7820
  14267   "RTN","CHG DQ2",214,0 )
  14268   STATUS ;;R EJ,INPROG, PAY REQ,EO B REQ,CMPL TE,ADJUD,C P REQ,ADM  SUS,CC APR V,MANUAL,D ELETED
  14269   "RTN","CHG DQ2",215,0 )
  14270   REOPEN S O LDPDI="",( J,FLG)=0,( FRSTPDI,CH CLPT,CHCLM R)=""
  14271   "RTN","CHG DQ2",216,0 )
  14272   RE1 S J=$O (@(GLPAY_" CHCLM,""PD I"",J)"))  Q:'J
  14273   "RTN","CHG DQ2",217,0 )
  14274    G:'$D(@(G LPAY_"CHCL M,""PDI"", J,0)")) RE 1 S OLDPDI =$P(@(GLPA Y_"CHCLM," "PDI"",J,0 )"),U,1)
  14275   "RTN","CHG DQ2",218,0 )
  14276    I $D(@(GL PAY_"CHCLM ,6)")) S C HCLPT=$P(@ (GLPAY_"CH CLM,6)"),U ,2)
  14277   "RTN","CHG DQ2",219,0 )
  14278    ;I $D(@(G LPAY_"CHCL M,6)")) S  X1=CHCLPT  D PROGTYP2 ^CHFCD001
  14279   "RTN","CHG DQ2",220,0 )
  14280    I CHCLPT' ="" S X1=C HCLPT D PR OGTYP2^CHF CD001
  14281   "RTN","CHG DQ2",221,0 )
  14282    I CHCLPT' ="" S CHCL MR=$P(@(GL PAY2_"CHCL PT,0)"),U, 1)  ; Unde fined erro r on 8/5/0 5  mlr
  14283   "RTN","CHG DQ2",222,0 )
  14284    S:FRSTPDI ="" FRSTPD I=OLDPDI
  14285   "RTN","CHG DQ2",223,0 )
  14286    G:OLDPDI= $P(CHPDI," -",1) RE1
  14287   "RTN","CHG DQ2",224,0 )
  14288    G:'$D(^CH MIMG(OLDPD I,0)) RE1
  14289   "RTN","CHG DQ2",225,0 )
  14290    S CHBAT=" ",CHBAT=$P (^CHMIMG(O LDPDI,0),U ,19)
  14291   "RTN","CHG DQ2",226,0 )
  14292    S CHDC=""
  14293   "RTN","CHG DQ2",227,0 )
  14294    S:$D(^CHM IMG(OLDPDI ,"DOC")) C HDC=$P(^CH MIMG(OLDPD I,"DOC"),U ,1)
  14295   "RTN","CHG DQ2",228,0 )
  14296    S:CHBAT=" " CHBAT=0  S:CHDC=""  CHDC="UNK"
  14297   "RTN","CHG DQ2",229,0 )
  14298    S OLDPDI= OLDPDI_"-" _CHDC
  14299   "RTN","CHG DQ2",230,0 )
  14300    D:FLG=0 R E2
  14301   "RTN","CHG DQ2",231,0 )
  14302    S X="X XY  W P1 S DX =22 X XY W  ""Batch:  "",P2"
  14303   "RTN","CHG DQ2",232,0 )
  14304    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_OLDPDI_ U_CHBAT
  14305   "RTN","CHG DQ2",233,0 )
  14306    S X="X XY  W P1"
  14307   "RTN","CHG DQ2",234,0 )
  14308    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=X _U_CHCLMR
  14309   "RTN","CHG DQ2",235,0 )
  14310    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=" "
  14311   "RTN","CHG DQ2",236,0 )
  14312    G RE1
  14313   "RTN","CHG DQ2",237,0 )
  14314    ;
  14315   "RTN","CHG DQ2",238,0 )
  14316   RE2 D UPCT  S ^UTILIT Y($J,"DUP" ,CHZONE,CT )=""
  14317   "RTN","CHG DQ2",239,0 )
  14318    D UPCT S  ^UTILITY($ J,"DUP",CH ZONE,CT)=" X XY W @CH BON,@CHULO N,""Associ ated PDIs/ Claims:"", @CHULOFF,@ CHBOFF"
  14319   "RTN","CHG DQ2",240,0 )
  14320    S FLG=1
  14321   "RTN","CHG DQ2",241,0 )
  14322    Q
  14323   "RTN","CHG DQ2",242,0 )
  14324   UPCT S (CT ,^UTILITY( $J,"DUP",C HZONE,0))= CT+1 Q
  14325   "RTN","CHG QA2")
  14326   0^71^B1056 35204
  14327   "RTN","CHG QA2",1,0)
  14328   CHGQA2 ;CV A/CR;FORMA T QAQ AI1  CLAIM OUTP UT FOR DIS PLAY IN QU E;Feb 06,  2019@09:04 :16
  14329   "RTN","CHG QA2",2,0)
  14330    ;;1.0;CHA MPVA SYSTE M;**1,11,1 4**;JULY 4 , 1990;Bui ld 5
  14331   "RTN","CHG QA2",3,0)
  14332    ; MUST HA VE: CHCLM  - CLAIM FI LE PTR
  14333   "RTN","CHG QA2",4,0)
  14334    ;             CHZONE  - SCREEN  REGION
  14335   "RTN","CHG QA2",5,0)
  14336    ;CPTS #10 857* (RLC) , CPTS #10 873* (RLC) , #11567*  (RLC), #12 195* (RLC)
  14337   "RTN","CHG QA2",6,0)
  14338    ;CPTS #13 561* (RLC) , #16110 ( Y2K)
  14339   "RTN","CHG QA2",7,0)
  14340    ;CPTS #16 432 (RLC)  - MODIFICA TIONS MADE  FOR IPS S CREEN SCRA PING
  14341   "RTN","CHG QA2",8,0)
  14342    ;DEV00480 5 1/20/201 0 AEB
  14343   "RTN","CHG QA2",9,0)
  14344    ;DEV00369 8 4/20/201 0 AEB
  14345   "RTN","CHG QA2",10,0)
  14346    ;DEV00782 0 EW 4/18/ 11
  14347   "RTN","CHG QA2",11,0)
  14348    ;DEFECT 8 32284 PL Z IP showing  up on all  queues fo r DME, TRV  and RXT   11/29/2018  NCD
  14349   "RTN","CHG QA2",12,0)
  14350   EN1 ;N (DF N,CHZONE,C HCLM,CHTYP ,CHI,GLPAY ,GLDFN,GLE LG,GLPAYH, GLPAYW,CHP ROG)
  14351   "RTN","CHG QA2",13,0)
  14352    I '$D(CHP ROG) D GTP ROG Q:'$D( PRGFLG)
  14353   "RTN","CHG QA2",14,0)
  14354    S (CHDB,C HDOB,CHSEX ,CHAGE,CHT DDT,CHBRDT ,CHVNPG,CH EXP)=""  ; AEB 1/20/2 010 DEV004 805
  14355   "RTN","CHG QA2",15,0)
  14356    S:'$D(^UT ILITY($J," QAQ",CHZON E,0)) ^UTI LITY($J,"Q AQ",CHZONE ,0)=0
  14357   "RTN","CHG QA2",16,0)
  14358    S CT=^UTI LITY($J,"Q AQ",CHZONE ,0),U="^"
  14359   "RTN","CHG QA2",17,0)
  14360    Q:'$D(@(G LPAY_"CHCL M,0)"))  S  REC0=@(GL PAY_"CHCLM ,0)")
  14361   "RTN","CHG QA2",18,0)
  14362    S CHCLMO= $P(@(GLPAY _"CHCLM,0) "),U,1)
  14363   "RTN","CHG QA2",19,0)
  14364    S:$D(@(GL PAY_"CHCLM ,9)")) CHV NPG=$P(@(G LPAY_"CHCL M,9)"),U,6 )
  14365   "RTN","CHG QA2",20,0)
  14366    S CHCLM(C HZONE,CHCL M)="" S:'$ D(CHCLM(CH ZONE,"CT") ) CHCLM(CH ZONE,"CT") =""
  14367   "RTN","CHG QA2",21,0)
  14368    S CHCLM(C HZONE,"CT" )=CHCLM(CH ZONE,"CT") +1
  14369   "RTN","CHG QA2",22,0)
  14370    S CHPDI=" " S:$D(@(G LPAY_"CHCL M,""PDI"", 1,0)")) CH PDI=$P(@(G LPAY_"CHCL M,""PDI"", 1,0)"),U,1 )
  14371   "RTN","CHG QA2",23,0)
  14372    S CHDOCID ="" I CHPD I'="" S:$D (^CHMIMG(C HPDI,"DOC" )) CHDOCID =$P(^("DOC "),"^",1)
  14373   "RTN","CHG QA2",24,0)
  14374    S:CHDOCID '="" CHPDI =CHPDI_"-" _CHDOCID
  14375   "RTN","CHG QA2",25,0)
  14376    S DFN=$P( REC0,"^",2 1),BFN=$P( REC0,"^",2 2),CHBENE= ""
  14377   "RTN","CHG QA2",26,0)
  14378    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)
  14379   "RTN","CHG QA2",27,0)
  14380    I CHDB'=" " S CHDOB= $$FMTE^XLF DT(CHDB,5)
  14381   "RTN","CHG QA2",28,0)
  14382    E  S CHDO B=""
  14383   "RTN","CHG QA2",29,0)
  14384    D NOW^%DT C S CHTDDT =$P(%H,"," ,1)
  14385   "RTN","CHG QA2",30,0)
  14386    I CHDB=""  S CHAGE=" UNK" G EN2
  14387   "RTN","CHG QA2",31,0)
  14388    S X=CHDB  D H^%DTC S  CHBRDT=%H
  14389   "RTN","CHG QA2",32,0)
  14390    S CHAGE=( (CHTDDT-CH BRDT)/365. 25)\1
  14391   "RTN","CHG QA2",33,0)
  14392   EN2 S X=$P (REC0,"^", 8) S CHDOS ="" I X'=" " D
  14393   "RTN","CHG QA2",34,0)
  14394    .S CHDOS= $E(X,4,5)_ $E(X,6,7)_ $E(X,2,3)
  14395   "RTN","CHG QA2",35,0)
  14396    S CHTOS=" " S X=$P(R EC0,"^",7)  I $D(^CHM DIC(741002 .05,X,0))  D
  14397   "RTN","CHG QA2",36,0)
  14398    .S CHTOS= $P(^(0),"^ ",2)
  14399   "RTN","CHG QA2",37,0)
  14400    I CHTOS=" IPT" S X=" " I $D(@(G LPAY_"CHCL M,""INP"") ")) D  S C HDOS=CHDOS _"-"_X
  14401   "RTN","CHG QA2",38,0)
  14402    .S X=$P(@ (GLPAY_"CH CLM,""INP" ")"),U,1), X=$E(X,4,5 )_$E(X,6,7 )_$E(X,2,3 )
  14403   "RTN","CHG QA2",39,0)
  14404    S (VNPT,C HVEN,CHVTI D,CHVTIDP, CHADCD,CHM DCD)="",(X ,VNPT)=$P( REC0,"^",3 ) I X'=""  D:$D(^CHMV EN(X,0))
  14405   "RTN","CHG QA2",40,0)
  14406    .S CHVEN= $P(^(0),"^ ",1),CHVTI D=$P(^(0), "^",3),CHA DCD=$P(^(0 ),"^",23)
  14407   "RTN","CHG QA2",41,0)
  14408    .S CHMDCD =""
  14409   "RTN","CHG QA2",42,0)
  14410    .S:$D(^CH MVEN(X,14) ) CHMDCD=$ P(^(14),"^ ",1)
  14411   "RTN","CHG QA2",43,0)
  14412    S CHEXP=$ $POACK^CHT FLIB3(X) S :CHEXP=0 C HEXP="N" S :CHEXP=1 C HEXP="Y"   ;AEB 1/20/ 2010 DEV00 4805
  14413   "RTN","CHG QA2",44,0)
  14414    S:CHADCD= "" CHADCD= "  " S:CHM DCD="" CHM DCD="  "
  14415   "RTN","CHG QA2",45,0)
  14416    S CHVTIDP =CHVTID_"- "_CHADCD_" -"_CHMDCD
  14417   "RTN","CHG QA2",46,0)
  14418    S X=$P(^C HMQAQ(CHI, 0),"^",3)  S CHSTAT=$ P($P($T(ST ATUS),";;" ,2),",",(X +1))
  14419   "RTN","CHG QA2",47,0)
  14420    S (CHPCN, CHTOB)=""
  14421   "RTN","CHG QA2",48,0)
  14422    S:$D(@(GL PAY_"CHCLM ,7)")) CHP CN=$P(@(GL PAY_"CHCLM ,7)"),U,5) ,CHTOB=$P( @(GLPAY_"C HCLM,7)"), U,6)
  14423   "RTN","CHG QA2",49,0)
  14424    S TCB=$P( @(GLPAY_"C HCLM,""COM MON"")"),U ,1),TAA=$P (@(GLPAY_" CHCLM,""CO MMON"")"), U,7)
  14425   "RTN","CHG QA2",50,0)
  14426    S CHTCB=$ FN(TCB,"", 2),CHTAA=$ FN(TAA,"", 2)
  14427   "RTN","CHG QA2",51,0)
  14428    S:'CHTAA  CHTAA="Und "
  14429   "RTN","CHG QA2",52,0)
  14430    I $D(@(GL PAY_"CHCLM ,7)")) S C HTPL=$P(@( GLPAY_"CHC LM,7)"),U, 9)  ;DEV78 20 EW 4/18 /11
  14431   "RTN","CHG QA2",53,0)
  14432    E  S CHTP L=""  ;DEV 7820 EW 4/ 18/11
  14433   "RTN","CHG QA2",54,0)
  14434    S:CHTPL'= "" CHTPL=" $"_$J($FN( CHTPL,",", 2),9)  ;DE V7820 EW 4 /18/11
  14435   "RTN","CHG QA2",55,0)
  14436    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"
  14437   "RTN","CHG QA2",56,0)
  14438    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHCLMO_ U_CHPROG_U _CHDOS_U_C HTOS_U_CHS TAT
  14439   "RTN","CHG QA2",57,0)
  14440    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"
  14441   "RTN","CHG QA2",58,0)
  14442    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHVNPG_ U_CHTOB_U_ CHPCN_U_CH TPL
  14443   "RTN","CHG QA2",59,0)
  14444    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"
  14445   "RTN","CHG QA2",60,0)
  14446    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHBENE_ U_CHSEX_U_ CHDOB_U_CH AGE_U_CHTY P
  14447   "RTN","CHG QA2",61,0)
  14448    S XVEN=$P (REC0,U,3)
  14449   "RTN","CHG QA2",62,0)
  14450    I XVEN'=" " I $D(^CH MVEN(XVEN, 20)) D
  14451   "RTN","CHG QA2",63,0)
  14452    .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"
  14453   "RTN","CHG QA2",64,0)
  14454    ; Y2K - m oved Tp: u p one line  to make r oom for ne w PDI size
  14455   "RTN","CHG QA2",65,0)
  14456    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"
  14457   "RTN","CHG QA2",66,0)
  14458    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHPDI_U _$E(CHVEN, 1,20)_U_CH VTIDP
  14459   "RTN","CHG QA2",67,0)
  14460    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
  14461   "RTN","CHG QA2",68,0)
  14462    S CHPLZIP =$P($G(^CH MPAY(CHCLM ,"VEN-II") ),U,15)  ; HM 08/14/2 017 001-00 6 PLZIP AD DITION
  14463   "RTN","CHG QA2",69,0)
  14464    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
  14465   "RTN","CHG QA2",70,0)
  14466    I $P(@(GL PAY_"CHCLM ,0)"),U,7) =1 D  ;AEB  1/20/2010  DEV004805
  14467   "RTN","CHG QA2",71,0)
  14468    .S X="X X Y W @CHBON ,""Vendor  POA Exempt : "",@CHBO FF,P1"  ;A EB 1/20/20 10 DEV0048 05
  14469   "RTN","CHG QA2",72,0)
  14470    .I $D(@(G LPAY_"CHCL M,7)")) I  $P(@(GLPAY _"CHCLM,7) "),U,8)'=" " D  Q  ;A EB 7/20/20 10 DEV0036 98
  14471   "RTN","CHG QA2",73,0)
  14472    ..S CHPZI P="" S CHP ZIP=$P(@(G LPAY_"CHCL M,7)"),U,8 )  ;AEB 7/ 20/2010 DE V003698
  14473   "RTN","CHG QA2",74,0)
  14474    ..S X=" S  DX=37 X X Y W @CHBON ,""POP1: " ",@CHBOFF, P2"  ;AEB  7/20/2010  DEV003698
  14475   "RTN","CHG QA2",75,0)
  14476    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) =X_U_CHEXP _U_CHPZIP   ;AEB 7/20 /2010 DEV0 03698
  14477   "RTN","CHG QA2",76,0)
  14478    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_CHEXP   ;AEB 1/20 /2010 DEV0 04805
  14479   "RTN","CHG QA2",77,0)
  14480    I $P(@(GL PAY_"CHCLM ,0)"),U,7) '=1 D  ;AE B 1/20/201 0 DEV00480 5
  14481   "RTN","CHG QA2",78,0)
  14482    .I $D(@(G LPAY_"CHCL M,7)")) I  $P(@(GLPAY _"CHCLM,7) "),U,8)'=" " D  Q  ;A EB 7/20/20 10 DEV0036 98
  14483   "RTN","CHG QA2",79,0)
  14484    ..S CHPZI P="" S CHP ZIP=$P(@(G LPAY_"CHCL M,7)"),U,8 )  ;AEB 7/ 20/2010 DE V003698
  14485   "RTN","CHG QA2",80,0)
  14486    ..S X="X  XY W @CHBO N,""POP1:  "",@CHBOFF ,P1"  ;AEB  7/20/2010  DEV003698
  14487   "RTN","CHG QA2",81,0)
  14488    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) =X_U_CHPZI P  ;AEB 7/ 20/2010 DE V003698
  14489   "RTN","CHG QA2",82,0)
  14490    ..D UPCT  S ^UTILITY ($J,"QAQ", CHZONE,CT) ="W "" """    ;AEB 7/ 20/2010 DE V003698
  14491   "RTN","CHG QA2",83,0)
  14492    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "W "" """   ;AEB 1/20 /2010 DEV0 04805
  14493   "RTN","CHG QA2",84,0)
  14494    ;-------- ----  STAR T DEV7820  EW 7/11/11  --------- ---------- ----
  14495   "RTN","CHG QA2",85,0)
  14496    I (CHTOS= "IPT") D   G EN21
  14497   "RTN","CHG QA2",86,0)
  14498    .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"
  14499   "RTN","CHG QA2",87,0)
  14500    I (CHTOS= "RXT")&(CH PGPT=6) D   G EN21
  14501   "RTN","CHG QA2",88,0)
  14502    .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"
  14503   "RTN","CHG QA2",89,0)
  14504    .Q
  14505   "RTN","CHG QA2",90,0)
  14506    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"
  14507   "RTN","CHG QA2",91,0)
  14508    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X
  14509   "RTN","CHG QA2",92,0)
  14510    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"
  14511   "RTN","CHG QA2",93,0)
  14512    ;-------- ----  END  DEV7820 EW  7/11/11 - ---------- ---------- --
  14513   "RTN","CHG QA2",94,0)
  14514   EN21 D UPC T S ^UTILI TY($J,"QAQ ",CHZONE,C T)=X
  14515   "RTN","CHG QA2",95,0)
  14516    S:CHTOS=" OPT" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  14517   "RTN","CHG QA2",96,0)
  14518    S:CHTOS=" DUR" CHTDX ="DME-DX", CHTPRC="DM E-SUPPLY"
  14519   "RTN","CHG QA2",97,0)
  14520    S:CHTOS=" DNT" CHTDX ="DEN-DX", CHTPRC="DE N-PROC"
  14521   "RTN","CHG QA2",98,0)
  14522    S:CHTOS=" TRV" CHTDX ="OPT-DX", CHTPRC="OP T-PROC"
  14523   "RTN","CHG QA2",99,0)
  14524    S:CHTOS=" RXT" CHTPR C="PHARM"   ;DEV00782 0 EW 8/2/1 1
  14525   "RTN","CHG QA2",100,0 )
  14526    S CHTOSP= $S(CHTOS=" IPT":CHTOS ,CHTOS="RX T":CHTOS,1 :"OPT")
  14527   "RTN","CHG QA2",101,0 )
  14528    D:CHTOSP' ="" @CHTOS P^CHGQA3
  14529   "RTN","CHG QA2",102,0 )
  14530    ;-------- ----  STAR T DEV7820  EW 7/11/11  --------- ---------- ----
  14531   "RTN","CHG QA2",103,0 )
  14532    I CHTOSP= "IPT" D
  14533   "RTN","CHG QA2",104,0 )
  14534    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "S DX=58 X  XY W ""== ========""  S DX=69 X  XY W ""== ========"" "
  14535   "RTN","CHG QA2",105,0 )
  14536    .S X="S D X=58 X XY  W $J(P1,10 ) S DX=69  X XY W $J( P2,10)"
  14537   "RTN","CHG QA2",106,0 )
  14538    .S ALFL=" " I CHTOS= "IPT" S:$P (@(GLPAY_" CHCLM,""IN P"")"),U,1 0)'="" ALF L="A"
  14539   "RTN","CHG QA2",107,0 )
  14540    .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
  14541   "RTN","CHG QA2",108,0 )
  14542    E  D
  14543   "RTN","CHG QA2",109,0 )
  14544    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "S DX=60 X  XY W ""TO TALS  ---- ---------- ---------- ---------- ---------- ---------- ---------- -"""
  14545   "RTN","CHG QA2",110,0 )
  14546    .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)"
  14547   "RTN","CHG QA2",111,0 )
  14548    .S ALFL=" " I CHTOS= "IPT" S:$P (@(GLPAY_" CHCLM,""IN P"")"),U,1 0)'="" ALF L="A"
  14549   "RTN","CHG QA2",112,0 )
  14550    .;S:CHOHI PDT'="" CH OHIPDT=$J( $FN(CHOHIP DT,"",2),1 0)
  14551   "RTN","CHG QA2",113,0 )
  14552    .;S:CHOHI ADT'="" CH OHIADT=$J( $FN(CHOHIA DT,"",2),1 0)
  14553   "RTN","CHG QA2",114,0 )
  14554    .;S:CHMED PT'="" CHM EDPT=$J($F N(CHMEDPT, "",2),10)
  14555   "RTN","CHG QA2",115,0 )
  14556    .;S:CHBAT '="" CHBAT =$FN(CHBAT ,"",2)
  14557   "RTN","CHG QA2",116,0 )
  14558    .;S:CHTAA '="" CHTAA =$FN(CHTAA ,"",2)
  14559   "RTN","CHG QA2",117,0 )
  14560    .;S:CHOHI PRT'="" CH OHIPRT=$J( $FN(CHOHIP RT,"",2),1 0)
  14561   "RTN","CHG QA2",118,0 )
  14562    .;S:CHOHI PBT'="" CH OHIPBT=$J( $FN(CHOHIP BT,"",2),1 0)
  14563   "RTN","CHG QA2",119,0 )
  14564    .S (CHOHI PRT,CHOHIP DT,CHOHIAD T,CHOHIPBT ,CHMEDPT,C HBAT,CHTAA )="" ;MTN0 13163: BUG  FIX QAQ3  SLA EW 6/2 9/12
  14565   "RTN","CHG QA2",120,0 )
  14566    .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
  14567   "RTN","CHG QA2",121,0 )
  14568    .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
  14569   "RTN","CHG QA2",122,0 )
  14570    .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
  14571   "RTN","CHG QA2",123,0 )
  14572    .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
  14573   "RTN","CHG QA2",124,0 )
  14574    .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
  14575   "RTN","CHG QA2",125,0 )
  14576    .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
  14577   "RTN","CHG QA2",126,0 )
  14578    .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
  14579   "RTN","CHG QA2",127,0 )
  14580    .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
  14581   "RTN","CHG QA2",128,0 )
  14582    .S X="S D X=99 X XY  W $J(P1,10 ) S DX=111  X XY W $J (P2,10)"
  14583   "RTN","CHG QA2",129,0 )
  14584    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= X_U_CHOHIA DT_U_CHOHI PBT
  14585   "RTN","CHG QA2",130,0 )
  14586    ;-------- ----  END  DEV7820 EW  7/11/11 - ---------- ---------- --
  14587   "RTN","CHG QA2",131,0 )
  14588    D REOPEN
  14589   "RTN","CHG QA2",132,0 )
  14590    I $D(^CHM CLCOM("B", CHCLMO)) D   S CHCOM= CHCLMO D ^ CHGQA3A K  CHCOM
  14591   "RTN","CHG QA2",133,0 )
  14592    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  14593   "RTN","CHG QA2",134,0 )
  14594    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Claim Comm ents"",@CH BOFF"
  14595   "RTN","CHG QA2",135,0 )
  14596    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  14597   "RTN","CHG QA2",136,0 )
  14598    I CHPDI'= "" I $D(^C HMCLCOM("B ",$P(CHPDI ,"-",1)))  D  S CHCOM =$P(CHPDI, "-",1) D ^ CHGQA3A K  CHCOM
  14599   "RTN","CHG QA2",137,0 )
  14600    .I '$D(^C HMCLCOM("B ",CHCLMO))  D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=" "
  14601   "RTN","CHG QA2",138,0 )
  14602    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" PDI Commen ts"",@CHBO FF"
  14603   "RTN","CHG QA2",139,0 )
  14604    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  14605   "RTN","CHG QA2",140,0 )
  14606    I $D(^CHB ENCOM(DFN, 100,BFN,20 0)) D  D ^ CHGQA17
  14607   "RTN","CHG QA2",141,0 )
  14608    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  14609   "RTN","CHG QA2",142,0 )
  14610    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Bene  Comm ents"",@CH BOFF"
  14611   "RTN","CHG QA2",143,0 )
  14612    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  14613   "RTN","CHG QA2",144,0 )
  14614    I VNPT'=" " I $D(^CH MVEN(VNPT, 20)) D  D  VWATCH^CHG QA17
  14615   "RTN","CHG QA2",145,0 )
  14616    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  14617   "RTN","CHG QA2",146,0 )
  14618    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= "X XY S DX =33 X XY W  @CHBON,"" Vendor Wat ch"",@CHBO FF"
  14619   "RTN","CHG QA2",147,0 )
  14620    .D UPCT S  ^UTILITY( $J,"QAQ",C HZONE,CT)= ""
  14621   "RTN","CHG QA2",148,0 )
  14622    D ^CHGQAO HI
  14623   "RTN","CHG QA2",149,0 )
  14624    K BFN,CHB ENE,CHCLMO ,CHDOCID,C HDOS,CHPDI ,CHROPEN,C HSTAT
  14625   "RTN","CHG QA2",150,0 )
  14626    K CHSTAT, CHTCB,CHTD X,CHTOS,CH TOSP,CHTPR C,CHVEN,CH VTID,CT,I, J,RCT
  14627   "RTN","CHG QA2",151,0 )
  14628    K CHANS,C HBA,CHBAT, CHCODE,CHD ATA,CHDESC ,CHRULEJ,C HTYPE,RECO ,X,L Q
  14629   "RTN","CHG QA2",152,0 )
  14630   STATUS ;;P END,INPROG ,CMPLTE,RE J,ADM SUS
  14631   "RTN","CHG QA2",153,0 )
  14632   REOPEN S O LDPDI="",( J,FLG)=0,( FRSTPDI,CH CLPT,CHCLM R)=""
  14633   "RTN","CHG QA2",154,0 )
  14634   RE1 S J=$O (@(GLPAY_" CHCLM,""PD I"",J)"))  I 'J Q
  14635   "RTN","CHG QA2",155,0 )
  14636    G:'$D(@(G LPAY_"CHCL M,""PDI"", J,0)")) RE 1 S OLDPDI =$P(@(GLPA Y_"CHCLM," "PDI"",J,0 )"),U,1)
  14637   "RTN","CHG QA2",156,0 )
  14638    I $D(@(GL PAY_"CHCLM ,6)")) S C HCLPT=$P(@ (GLPAY_"CH CLM,6)"),U ,2)
  14639   "RTN","CHG QA2",157,0 )
  14640    I CHCLPT' ="" S X1=C HCLPT D PR OGTYP2^CHF CD001 S CH CLMR=$P(@( GLPAY2_"CH CLPT,0)"), U,1)
  14641   "RTN","CHG QA2",158,0 )
  14642    S:FRSTPDI ="" FRSTPD I=OLDPDI
  14643   "RTN","CHG QA2",159,0 )
  14644    G:OLDPDI= $P(CHPDI," -",1) RE1
  14645   "RTN","CHG QA2",160,0 )
  14646    G:'$D(^CH MIMG(OLDPD I,0)) RE1
  14647   "RTN","CHG QA2",161,0 )
  14648    S CHBAT=" ",CHBAT=$P (^CHMIMG(O LDPDI,0),U ,19)
  14649   "RTN","CHG QA2",162,0 )
  14650    S CHDC=""
  14651   "RTN","CHG QA2",163,0 )
  14652    S:$D(^CHM IMG(OLDPDI ,"DOC")) C HDC=$P(^CH MIMG(OLDPD I,"DOC"),U ,1)
  14653   "RTN","CHG QA2",164,0 )
  14654    S:CHBAT=" " CHBAT=0  S:CHDC=""  CHDC="UNK"
  14655   "RTN","CHG QA2",165,0 )
  14656    S OLDPDI= OLDPDI_"-" _CHDC
  14657   "RTN","CHG QA2",166,0 )
  14658    D:FLG=0 R E2
  14659   "RTN","CHG QA2",167,0 )
  14660    S X="X XY  W P1 S DX =22 X XY W  ""Batch:  "",P2"
  14661   "RTN","CHG QA2",168,0 )
  14662    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_OLDPDI_ U_CHBAT
  14663   "RTN","CHG QA2",169,0 )
  14664    S X="X XY  W P1"
  14665   "RTN","CHG QA2",170,0 )
  14666    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=X _U_CHCLMR
  14667   "RTN","CHG QA2",171,0 )
  14668    D UPCT S  ^UTILITY($ J,"QAQ",CH ZONE,CT)=" "
  14669   "RTN","CHG QA2",172,0 )
  14670    G RE1
  14671   "RTN","CHG QA2",173,0 )
  14672    ;
  14673   "RTN","CHG QA2",174,0 )
  14674   RE2 D UPCT  S ^UTILIT Y($J,"QAQ" ,CHZONE,CT )=""
  14675   "RTN","CHG QA2",175,0 )
  14676    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"
  14677   "RTN","CHG QA2",176,0 )
  14678    S FLG=1
  14679   "RTN","CHG QA2",177,0 )
  14680    Q
  14681   "RTN","CHG QA2",178,0 )
  14682   UPCT S (CT ,^UTILITY( $J,"QAQ",C HZONE,0))= CT+1 Q
  14683   "RTN","CHG QA2",179,0 )
  14684   GTPROG K P RGFLG
  14685   "RTN","CHG QA2",180,0 )
  14686    I $D(CHCL MP)!($D(CH CLM)) D  Q
  14687   "RTN","CHG QA2",181,0 )
  14688    .I $D(^CH MINDEX(CHC LMP,0)) S  CHPGPT=$P( ^(0),U,2)  D GT2 Q
  14689   "RTN","CHG QA2",182,0 )
  14690    .I $D(^CH MINDEX(CHC LM,0)) S C HPGPT=$P(^ (0),U,2) D  GT2 Q
  14691   "RTN","CHG QA2",183,0 )
  14692    .Q
  14693   "RTN","CHG QA2",184,0 )
  14694    I $D(CHCL MO) D  Q
  14695   "RTN","CHG QA2",185,0 )
  14696    .Q:'$D(^C HMINDEX("B ",CHCLMO))
  14697   "RTN","CHG QA2",186,0 )
  14698    .S CI=0
  14699   "RTN","CHG QA2",187,0 )
  14700   GT1 .S CI= $O(^CHMIND EX("B",CHC LMO,CI)) Q :'CI
  14701   "RTN","CHG QA2",188,0 )
  14702    .G:'$D(^C HMINDEX(CI ,0)) GT1 S  CHPGPT=$P (^(0),U,2)
  14703   "RTN","CHG QA2",189,0 )
  14704    .D GT2
  14705   "RTN","CHG QA2",190,0 )
  14706    .Q
  14707   "RTN","CHG QA2",191,0 )
  14708   GT2 Q:CHPG PT=""
  14709   "RTN","CHG QA2",192,0 )
  14710    Q:'$D(^CH MDIC(74100 2.94,CHPGP T,0))  S C HPROG=$P(^ (0),U,2)
  14711   "RTN","CHG QA2",193,0 )
  14712    Q:'$D(^CH MDIC(74100 2.94,CHPGP T,1))  S G LREC=^(1)
  14713   "RTN","CHG QA2",194,0 )
  14714    ;S GLPAY= $P(GLREC,U ,1),GLELG= $P(GLREC,U ,2),GLDFN= $P(GLREC,U ,3)
  14715   "RTN","CHG QA2",195,0 )
  14716    S PRGFLG= ""
  14717   "RTN","CHG QA2",196,0 )
  14718    Q
  14719   "RTN","CHG VQ370")
  14720   0^36^B1935 88907
  14721   "RTN","CHG VQ370",1,0 )
  14722   CHGVQ370 ; CVA/PEJ; V F SELECT -  MAIN SCRE EN;Feb 06,  2019@09:5 5:33
  14723   "RTN","CHG VQ370",2,0 )
  14724    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  14725   "RTN","CHG VQ370",3,0 )
  14726    ;CPTS #10 846 - PEJ  8/15/96
  14727   "RTN","CHG VQ370",4,0 )
  14728    ;CPTS #11 158 - PEJ  10/30/96
  14729   "RTN","CHG VQ370",5,0 )
  14730    ;CPTS #15 932 - (Y2K ) 12/17/98
  14731   "RTN","CHG VQ370",6,0 )
  14732    ;DEV00799 1 10/08/20 10 JAK -VE NDOR LOOKU P utilizin g NPI
  14733   "RTN","CHG VQ370",7,0 )
  14734    ;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
  14735   "RTN","CHG VQ370",8,0 )
  14736    ;routine.  Need to i nitialize  field CHXR ZIP (remit  zip) befo re being u sed - 01/2 6/11.
  14737   "RTN","CHG VQ370",9,0 )
  14738    ;CPE001-0 09  HM 06/ 30/2017
  14739   "RTN","CHG VQ370",10, 0)
  14740    ;CPE001-0 09  HM 08/ 01/2017
  14741   "RTN","CHG VQ370",11, 0)
  14742    ;CPE001-0 17 SBB 01/ 18/2018 Ch ange REMIT -TO ADDRES S to BILLI NG/REMIT-T O ADDRESS
  14743   "RTN","CHG VQ370",12, 0)
  14744    ;
  14745   "RTN","CHG VQ370",13, 0)
  14746    ;******** ROUTINE DE SCRIPTION* ****
  14747   "RTN","CHG VQ370",14, 0)
  14748    ;$Y,DX,DY        0 -  23
  14749   "RTN","CHG VQ370",15, 0)
  14750    ;DTM,DBM         1 -  n
  14751   "RTN","CHG VQ370",16, 0)
  14752    ;^ZPEJT10  CONTAINS  FIELD LABE LS
  14753   "RTN","CHG VQ370",17, 0)
  14754    ;^UTILITY ($J CONTAI NS THE SCR EEN CODE I NCLUDING F IELD EXTER NAL DATA
  14755   "RTN","CHG VQ370",18, 0)
  14756    ;CHMVAR(n ) CONTAINS  FIELD INT ERNAL DATA
  14757   "RTN","CHG VQ370",19, 0)
  14758    ;       T HESE FIELD S SHOULD C ONTAIN THE  SAME # OF  ELEMENTS  = SCRLEN
  14759   "RTN","CHG VQ370",20, 0)
  14760    ;THERE SH OULD BE AN  EVAL AND  HELP ROUTI NE FOR EAC H FIELD
  14761   "RTN","CHG VQ370",21, 0)
  14762    ; DISPLAY  LENGTH =  (DBM - DTM ) + 1
  14763   "RTN","CHG VQ370",22, 0)
  14764    ;*
  14765   "RTN","CHG VQ370",23, 0)
  14766    ;INPUT VA RS: SCRLTO P,SCRLBOT
  14767   "RTN","CHG VQ370",24, 0)
  14768    ;RETURN V ARS: CHFVP TR
  14769   "RTN","CHG VQ370",25, 0)
  14770    ;*
  14771   "RTN","CHG VQ370",26, 0)
  14772    ;HM 8/1/2 017 ADDED  LOGIC FIX  VV SCREEN  LOOKUP
  14773   "RTN","CHG VQ370",27, 0)
  14774    ;
  14775   "RTN","CHG VQ370",28, 0)
  14776   LOOKUP ;
  14777   "RTN","CHG VQ370",29, 0)
  14778    NEW CHFUN C,CHFLD,DT M,DBM,SCRL EN,DX,DY,C HPOS
  14779   "RTN","CHG VQ370",30, 0)
  14780    K CHPI
  14781   "RTN","CHG VQ370",31, 0)
  14782    S CHFUNC= "VLKUP"
  14783   "RTN","CHG VQ370",32, 0)
  14784    S SCRLTOP =4
  14785   "RTN","CHG VQ370",33, 0)
  14786    S SCRLBOT =22
  14787   "RTN","CHG VQ370",34, 0)
  14788    S DTM=SCR LTOP+2
  14789   "RTN","CHG VQ370",35, 0)
  14790    S DBM=SCR LBOT
  14791   "RTN","CHG VQ370",36, 0)
  14792    S SCRLEN= DBM-DTM
  14793   "RTN","CHG VQ370",37, 0)
  14794    ;
  14795   "RTN","CHG VQ370",38, 0)
  14796    D ^CHSC3
  14797   "RTN","CHG VQ370",39, 0)
  14798    K ^UTILIT Y($J,"VLUL IST")
  14799   "RTN","CHG VQ370",40, 0)
  14800    K ^UTILIT Y($J,"VLKU P")
  14801   "RTN","CHG VQ370",41, 0)
  14802    S CHVDONE =0
  14803   "RTN","CHG VQ370",42, 0)
  14804    S CHFVPTR =0
  14805   "RTN","CHG VQ370",43, 0)
  14806    ;
  14807   "RTN","CHG VQ370",44, 0)
  14808    D RNGECLR ^CHSCH1(SC RLTOP+5,SC RLBOT,XY,C HEOL) ;PEJ
  14809   "RTN","CHG VQ370",45, 0)
  14810    S CHFLAG= 0
  14811   "RTN","CHG VQ370",46, 0)
  14812    D GETXTID ^CHGVQ371
  14813   "RTN","CHG VQ370",47, 0)
  14814    G:CHFLAG= 2 LU2
  14815   "RTN","CHG VQ370",48, 0)
  14816    S LLEN=0
  14817   "RTN","CHG VQ370",49, 0)
  14818    I CHXTID' ="" D LU1^ CHGVQ529     ;CHXTID  = TAX IDEN TIFICATION
  14819   "RTN","CHG VQ370",50, 0)
  14820    I CHXNPI' ="" D NPI^ CHGVQ529     ;CHXNPI  = NATIONAL  PROVIDER  IDENTIFICA TION        ;DEV00799 1 10/08/20 10 JAK
  14821   "RTN","CHG VQ370",51, 0)
  14822    I CHXPRN' ="" D LOOK 2^CHGVQ529   ;CHXPRN  = REMIT-TO  NAME
  14823   "RTN","CHG VQ370",52, 0)
  14824    D ADDLIST ^CHGVQ529  G LU2  ;HM  8/1/2017  ADDED LOGI C FIX VV S CREEN LOOK UP
  14825   "RTN","CHG VQ370",53, 0)
  14826    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  14827   "RTN","CHG VQ370",54, 0)
  14828    Q
  14829   "RTN","CHG VQ370",55, 0)
  14830    ;
  14831   "RTN","CHG VQ370",56, 0)
  14832   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
  14833   "RTN","CHG VQ370",57, 0)
  14834    I LLEN=0  D  G END1
  14835   "RTN","CHG VQ370",58, 0)
  14836    .S:$D(^UT ILITY($J," VLULIST"))  CHFVPTR=$ P(^UTILITY ($J,"VLULI ST",LLEN), U,1)
  14837   "RTN","CHG VQ370",59, 0)
  14838    I LLEN=0  S CHFVPTR= "" G END1
  14839   "RTN","CHG VQ370",60, 0)
  14840    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
  14841   "RTN","CHG VQ370",61, 0)
  14842    D SCSET ; SET UP SCR EEN PARAME TERS
  14843   "RTN","CHG VQ370",62, 0)
  14844    D GLOBSET  ;SET UP S CREEN GLOB AL
  14845   "RTN","CHG VQ370",63, 0)
  14846    D RDCHSCR
  14847   "RTN","CHG VQ370",64, 0)
  14848    K ^UTILIT Y($J,CHFUN C,CHZONE," CHFLD")
  14849   "RTN","CHG VQ370",65, 0)
  14850    S CHFLD=" " D SETFLD ^CHSCH2(CH FUNC,CHZON E,.CHFLD)
  14851   "RTN","CHG VQ370",66, 0)
  14852    ;
  14853   "RTN","CHG VQ370",67, 0)
  14854    ;******** DISPLAY SC REEN GLOBA L********* ********** ********** ********** **
  14855   "RTN","CHG VQ370",68, 0)
  14856   LU3 ;
  14857   "RTN","CHG VQ370",69, 0)
  14858    S DTM=SCR LTOP+2
  14859   "RTN","CHG VQ370",70, 0)
  14860    S DBM=SCR LBOT X CHM AR
  14861   "RTN","CHG VQ370",71, 0)
  14862    D SHOW^CH SCH2(CHFUN C,CHZONE,D TM,DBM)
  14863   "RTN","CHG VQ370",72, 0)
  14864    D TOP2
  14865   "RTN","CHG VQ370",73, 0)
  14866    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)
  14867   "RTN","CHG VQ370",74, 0)
  14868    ;
  14869   "RTN","CHG VQ370",75, 0)
  14870    S DX=1,DY =SCRLTOP+1  S $X=$G(D X),$Y=$G(D Y)
  14871   "RTN","CHG VQ370",76, 0)
  14872    D EN1^CHG VQ372 ;EDI T
  14873   "RTN","CHG VQ370",77, 0)
  14874    D SCSET
  14875   "RTN","CHG VQ370",78, 0)
  14876    ;RETURN P OINTER ...
  14877   "RTN","CHG VQ370",79, 0)
  14878    S ^DISV(D UZ,"VENDOR ","VLU1")= CHFVPTR ;S AVE FOR SP ACEBAR/RET URN
  14879   "RTN","CHG VQ370",80, 0)
  14880    ;
  14881   "RTN","CHG VQ370",81, 0)
  14882   END1 ;
  14883   "RTN","CHG VQ370",82, 0)
  14884    ;S DX=0 F  DY=SCRLTO P-1:1:SCRL BOT S $X=$ G(DX),$Y=$ G(DY) X XY  W @CHEOL
  14885   "RTN","CHG VQ370",83, 0)
  14886    S DX=1 F  DY=SCRLTOP -2:1:SCRLB OT S $X=$G (DX),$Y=$G (DY) X XY  W @CHEOL    ; JEH
  14887   "RTN","CHG VQ370",84, 0)
  14888    K ^UTILIT Y($J,"VLUL IST"),CHFI OUT,CHLUOU T Q
  14889   "RTN","CHG VQ370",85, 0)
  14890    ;
  14891   "RTN","CHG VQ370",86, 0)
  14892   UPCT S CT= CT+1 ;UPDA TE LINE CO UNTER
  14893   "RTN","CHG VQ370",87, 0)
  14894    S $P(^UTI LITY($J,CH FUNC,CHZON E,0),U,1)= CT
  14895   "RTN","CHG VQ370",88, 0)
  14896    S CHUPT=" ",CHUPT=$O (^UTILITY( $J,CHFUNC, CHZONE,CHU PT),-1)
  14897   "RTN","CHG VQ370",89, 0)
  14898    S $P(^UTI LITY($J,CH FUNC,CHZON E,0),U,2)= CHUPT
  14899   "RTN","CHG VQ370",90, 0)
  14900    Q
  14901   "RTN","CHG VQ370",91, 0)
  14902    ;
  14903   "RTN","CHG VQ370",92, 0)
  14904   END Q
  14905   "RTN","CHG VQ370",93, 0)
  14906    ;
  14907   "RTN","CHG VQ370",94, 0)
  14908    ;  SUBROU TINES
  14909   "RTN","CHG VQ370",95, 0)
  14910    ;
  14911   "RTN","CHG VQ370",96, 0)
  14912    ;
  14913   "RTN","CHG VQ370",97, 0)
  14914    ;******** FIELD EVAL UATION**** ********** ********** ********** ********** **
  14915   "RTN","CHG VQ370",98, 0)
  14916   EVAL1 S:$E (Y,1)="@"  Y="" ;TID
  14917   "RTN","CHG VQ370",99, 0)
  14918    S:$E(Y,1) =" " Y=""
  14919   "RTN","CHG VQ370",100 ,0)
  14920    S $P(^UTI LITY($J,"V ","CHVVAR" ,I),U,1)=Y ,$P(^UTILI TY($J,"V", "CHVVAR",I ),U,2)=1
  14921   "RTN","CHG VQ370",101 ,0)
  14922    S $P(^UTI LITY($J,CH FUNC,CHZON E,I),U,3)= Y
  14923   "RTN","CHG VQ370",102 ,0)
  14924    S DX=1 S  $X=$G(DX), $Y=$G(DY)  D REDOLNE^ CHSC2
  14925   "RTN","CHG VQ370",103 ,0)
  14926    Q
  14927   "RTN","CHG VQ370",104 ,0)
  14928    ;
  14929   "RTN","CHG VQ370",105 ,0)
  14930    ;******** FIELD HELP ********** ********** ********** ********** ********** **
  14931   "RTN","CHG VQ370",106 ,0)
  14932   HELP ;TID
  14933   "RTN","CHG VQ370",107 ,0)
  14934    S TX=5,TY =3,BX=75,B Y=9,VON="" ,VOFF=""
  14935   "RTN","CHG VQ370",108 ,0)
  14936    D BOXF^CH SC1(TX,TY, BX,BY)
  14937   "RTN","CHG VQ370",109 ,0)
  14938    D CLRBOXI ^CHSC1(TX, TY,BX,BY,X Y,VON,VOFF )
  14939   "RTN","CHG VQ370",110 ,0)
  14940    S DX=10,D Y=4 S $X=$ G(DX),$Y=$ G(DY) X XY  W "       Enter TAX  ID:   9 ch aracters"
  14941   "RTN","CHG VQ370",111 ,0)
  14942    S DY=5,DX =(40-($L(X )\2)) S $X =$G(DX),$Y =$G(DY) X  XY W "Pres s <RETURN>  to contin ue..."
  14943   "RTN","CHG VQ370",112 ,0)
  14944    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"
  14945   "RTN","CHG VQ370",113 ,0)
  14946    R X:10
  14947   "RTN","CHG VQ370",114 ,0)
  14948    D REDOLNS ^CHSCH1(CH FUNC,CHZON E,DTM,DBM, TY,BY,.CHS CRN) Q  X  XY Q
  14949   "RTN","CHG VQ370",115 ,0)
  14950    ;
  14951   "RTN","CHG VQ370",116 ,0)
  14952    ;
  14953   "RTN","CHG VQ370",117 ,0)
  14954   RDCHSCR S  CHRDCNT=0, CHRDPTR=0
  14955   "RTN","CHG VQ370",118 ,0)
  14956   RD1 S CHRD PTR=$O(^UT ILITY($J,C HFUNC,CHZO NE,CHRDPTR )) Q:'CHRD PTR
  14957   "RTN","CHG VQ370",119 ,0)
  14958    S CHRDCNT =CHRDCNT+1
  14959   "RTN","CHG VQ370",120 ,0)
  14960    S ^UTILIT Y($J,"CHSC RN",CHFUNC ,CHZONE,CH RDCNT)=CHR DPTR
  14961   "RTN","CHG VQ370",121 ,0)
  14962    G RD1
  14963   "RTN","CHG VQ370",122 ,0)
  14964    ;
  14965   "RTN","CHG VQ370",123 ,0)
  14966   DSPHDR ;
  14967   "RTN","CHG VQ370",124 ,0)
  14968    ;S DX=1,D Y=SCRLTOP- 2 S $X=$G( DX),$Y=$G( DY) X XY W  "LIST LEN GTH: "_LLE N
  14969   "RTN","CHG VQ370",125 ,0)
  14970    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
  14971   "RTN","CHG VQ370",126 ,0)
  14972    ;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
  14973   "RTN","CHG VQ370",127 ,0)
  14974    ;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
  14975   "RTN","CHG VQ370",128 ,0)
  14976    ;HM 06/30 /2017 - CP E001-009
  14977   "RTN","CHG VQ370",129 ,0)
  14978    ;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
  14979   "RTN","CHG VQ370",130 ,0)
  14980    ;SBB 1/18 /2018 - CP E001-017
  14981   "RTN","CHG VQ370",131 ,0)
  14982    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
  14983   "RTN","CHG VQ370",132 ,0)
  14984    Q
  14985   "RTN","CHG VQ370",133 ,0)
  14986   DSPHDR1 ;
  14987   "RTN","CHG VQ370",134 ,0)
  14988    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
  14989   "RTN","CHG VQ370",135 ,0)
  14990    ;HM 08/1/ 2017 - CPE 001-009 VV  SCREEN
  14991   "RTN","CHG VQ370",136 ,0)
  14992    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
  14993   "RTN","CHG VQ370",137 ,0)
  14994    Q
  14995   "RTN","CHG VQ370",138 ,0)
  14996   LOOK1 ;
  14997   "RTN","CHG VQ370",139 ,0)
  14998    NEW CHFUN C,CHFLD,DT M,DBM,SCRL EN,DX,DY,C HPOS
  14999   "RTN","CHG VQ370",140 ,0)
  15000    ;S CHPI=$ E(CHMFPDI, 6,7),ZICN= "",ZSTN=""   ;Y2K
  15001   "RTN","CHG VQ370",141 ,0)
  15002    S CHPI=$$ TYPE^CHMFP DI2(CHMFPD I),ZICN="" ,ZSTN=""
  15003   "RTN","CHG VQ370",142 ,0)
  15004    S CHFUNC= "VLKUP"
  15005   "RTN","CHG VQ370",143 ,0)
  15006    S DTM=SCR LTOP+2
  15007   "RTN","CHG VQ370",144 ,0)
  15008    S DBM=SCR LBOT
  15009   "RTN","CHG VQ370",145 ,0)
  15010    S SCRLEN= DBM-DTM
  15011   "RTN","CHG VQ370",146 ,0)
  15012    S CHXACT= ""
  15013   "RTN","CHG VQ370",147 ,0)
  15014    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.
  15015   "RTN","CHG VQ370",148 ,0)
  15016    D ^CHSC3
  15017   "RTN","CHG VQ370",149 ,0)
  15018    K ^UTILIT Y($J,"VLUL IST")
  15019   "RTN","CHG VQ370",150 ,0)
  15020    K ^UTILIT Y($J,"VLKU P")
  15021   "RTN","CHG VQ370",151 ,0)
  15022    K ^UTILIT Y("VEN",$J )
  15023   "RTN","CHG VQ370",152 ,0)
  15024    S (ZPSCT, ZOUT,ZC,ZN S,ZPSTOT,Z NO)=0,(ZPS N,X)="",(Z PS,ZPS1)=- 1
  15025   "RTN","CHG VQ370",153 ,0)
  15026    S LLEN=0
  15027   "RTN","CHG VQ370",154 ,0)
  15028    S CHVDONE =0
  15029   "RTN","CHG VQ370",155 ,0)
  15030    S CHFVPTR =0
  15031   "RTN","CHG VQ370",156 ,0)
  15032    ;
  15033   "RTN","CHG VQ370",157 ,0)
  15034    S CHBOGID =$E(Y,1,9)  I CHBOGID '="" I $D( ^CHMVEN("D ",CHBOGID) ) S Y=$E(Y ,1,9)_"*"_ $E(Y,10,11 )
  15035   "RTN","CHG VQ370",158 ,0)
  15036    ;
  15037   "RTN","CHG VQ370",159 ,0)
  15038    S CHXTMP= $P(Y,"/",1 )
  15039   "RTN","CHG VQ370",160 ,0)
  15040    S CHSTATE =""
  15041   "RTN","CHG VQ370",161 ,0)
  15042    S Y=$P(Y, "/",2)
  15043   "RTN","CHG VQ370",162 ,0)
  15044    I Y'="" D
  15045   "RTN","CHG VQ370",163 ,0)
  15046    .S DTMSAV =DTM,DBMSA V=DBM
  15047   "RTN","CHG VQ370",164 ,0)
  15048    .D ^CHMFS ET
  15049   "RTN","CHG VQ370",165 ,0)
  15050    .D ^CHGVQ 034
  15051   "RTN","CHG VQ370",166 ,0)
  15052    .S DTM=DT MSAV,DBM=D BMSAV
  15053   "RTN","CHG VQ370",167 ,0)
  15054    .S:'$D(ZS TN) ZSTN=" "
  15055   "RTN","CHG VQ370",168 ,0)
  15056    .D ^CHSC3
  15057   "RTN","CHG VQ370",169 ,0)
  15058    .S CHTMPS T=$P(ZSTN, U,3)
  15059   "RTN","CHG VQ370",170 ,0)
  15060    .S CHSTAT E=$P(ZSTN, U,1)
  15061   "RTN","CHG VQ370",171 ,0)
  15062    ;
  15063   "RTN","CHG VQ370",172 ,0)
  15064    I CHXTMP= "?" D SN0^ CHGVQ529 I  LLEN>0 G  LOOK1F
  15065   "RTN","CHG VQ370",173 ,0)
  15066    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
  15067   "RTN","CHG VQ370",174 ,0)
  15068    S CHXPLN= CHXTMP D R N0^CHGVQ52 9
  15069   "RTN","CHG VQ370",175 ,0)
  15070   LOOK1F ;
  15071   "RTN","CHG VQ370",176 ,0)
  15072    I '$D(^UT ILITY($J," VLULIST"))  S ZPSN="" ,Y="" D ^C HMFSET Q
  15073   "RTN","CHG VQ370",177 ,0)
  15074    D LU2
  15075   "RTN","CHG VQ370",178 ,0)
  15076    S ZPSN=""
  15077   "RTN","CHG VQ370",179 ,0)
  15078    G:'CHFVPT R LOOK1E
  15079   "RTN","CHG VQ370",180 ,0)
  15080    S:$D(^CHM VEN(CHFVPT R,0)) REC0 =^CHMVEN(C HFVPTR,0)
  15081   "RTN","CHG VQ370",181 ,0)
  15082    S:$D(^CHM VEN(CHFVPT R,1)) REC1 =^CHMVEN(C HFVPTR,1)
  15083   "RTN","CHG VQ370",182 ,0)
  15084    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"
  15085   "RTN","CHG VQ370",183 ,0)
  15086    S $P(ZICN ,U,3)=CHFV PTR
  15087   "RTN","CHG VQ370",184 ,0)
  15088   LOOK1E K C HLUOUT,CHF IOUT
  15089   "RTN","CHG VQ370",185 ,0)
  15090    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
  15091   "RTN","CHG VQ370",186 ,0)
  15092    Q
  15093   "RTN","CHG VQ370",187 ,0)
  15094   CHKPI ;
  15095   "RTN","CHG VQ370",188 ,0)
  15096    S CHPIPTR =0,CHPIFLG =0
  15097   "RTN","CHG VQ370",189 ,0)
  15098    F  S CHPI PTR=$O(^CH MVEN(CHFVP TR,12,CHPI PTR)) Q:'C HPIPTR  D
  15099   "RTN","CHG VQ370",190 ,0)
  15100    .Q:CHXPI' =$P(^CHMVE N(CHFVPTR, 12,CHPIPTR ,0),U,1)
  15101   "RTN","CHG VQ370",191 ,0)
  15102    .S CHPIFL G=1
  15103   "RTN","CHG VQ370",192 ,0)
  15104    Q
  15105   "RTN","CHG VQ370",193 ,0)
  15106   SCSET ;S S CRLEN=14
  15107   "RTN","CHG VQ370",194 ,0)
  15108    N CHFUNC
  15109   "RTN","CHG VQ370",195 ,0)
  15110    S DSPLEN= SCRLEN+1
  15111   "RTN","CHG VQ370",196 ,0)
  15112    ;S DTM=4  ;TOP MARGI N +1
  15113   "RTN","CHG VQ370",197 ,0)
  15114    ;S DBM=19  ;BOTTOM M ARGIN
  15115   "RTN","CHG VQ370",198 ,0)
  15116    S DTM=5 ; SKD
  15117   "RTN","CHG VQ370",199 ,0)
  15118    S DBM=20  ;SKD
  15119   "RTN","CHG VQ370",200 ,0)
  15120    S CHFUNC= "VLKUP"
  15121   "RTN","CHG VQ370",201 ,0)
  15122    S CHZONE= 0
  15123   "RTN","CHG VQ370",202 ,0)
  15124    S ^UTILIT Y($J,"CHSC RN",CHFUNC ,CHZONE,"B EG")=1
  15125   "RTN","CHG VQ370",203 ,0)
  15126    D ^CHSC3  ;SCREEN SE TUP (INSTE AD OF ^CHM FSET)
  15127   "RTN","CHG VQ370",204 ,0)
  15128    ;D RNGECL R^CHSCH1(S CRLTOP,SCR LBOT,XY,CH EOL)
  15129   "RTN","CHG VQ370",205 ,0)
  15130    D RNGECLR ^CHSCH1(3, 19,XY,CHEO L)
  15131   "RTN","CHG VQ370",206 ,0)
  15132    X CHMAR
  15133   "RTN","CHG VQ370",207 ,0)
  15134    D DSPHDR1
  15135   "RTN","CHG VQ370",208 ,0)
  15136    Q
  15137   "RTN","CHG VQ370",209 ,0)
  15138    ;
  15139   "RTN","CHG VQ370",210 ,0)
  15140   TOP2 S:'$D (CHTITLE)  CHTITLE="V endor File  Lookup"
  15141   "RTN","CHG VQ370",211 ,0)
  15142    S:CHTITLE ="" CHTITL E="Vendor  File Looku p"
  15143   "RTN","CHG VQ370",212 ,0)
  15144    S TL="CHA MPVA Payme nt Center  - "_CHTITL E
  15145   "RTN","CHG VQ370",213 ,0)
  15146    S CHTSP=7 9-($L(TL)) \2
  15147   "RTN","CHG VQ370",214 ,0)
  15148    F I=1:1:C HTSP S TL= " "_TL
  15149   "RTN","CHG VQ370",215 ,0)
  15150    F I=1:1:8 0-$L(TL) S  TL=TL_" "
  15151   "RTN","CHG VQ370",216 ,0)
  15152    S DY=1 S  DX=1 S $X= $G(DX),$Y= $G(DY) X X Y W @CHREV ON,TL,@CHR EVOFF
  15153   "RTN","CHG VQ370",217 ,0)
  15154    Q
  15155   "RTN","CHG VQ370",218 ,0)
  15156   GLOBSET S: '$D(^UTILI TY($J,CHFU NC,CHZONE, 0)) ^UTILI TY($J,CHFU NC,CHZONE, 0)=0
  15157   "RTN","CHG VQ370",219 ,0)
  15158    S CT=^UTI LITY($J,CH FUNC,CHZON E,0)
  15159   "RTN","CHG VQ370",220 ,0)
  15160    S X="X XY  W @CHBON, P1,@CHBOFF  S DX=29 S  $X=$G(DX) ,$Y=$G(DY)  X XY W P2 "
  15161   "RTN","CHG VQ370",221 ,0)
  15162    S LPTR=0
  15163   "RTN","CHG VQ370",222 ,0)
  15164   A1 S LPTR= $O(^UTILIT Y($J,"VLUL IST",LPTR) ) G:'LPTR  A2
  15165   "RTN","CHG VQ370",223 ,0)
  15166    F XIX=1:1 :22 S ^UTI LITY($J,"V ","CHVVAR" ,XIX)=""
  15167   "RTN","CHG VQ370",224 ,0)
  15168    F XIX=1:1 :22 S ^UTI LITY($J,"V ","CHVVAR" ,XIX)=$P(^ UTILITY($J ,"VLULIST" ,LPTR),U,X IX)
  15169   "RTN","CHG VQ370",225 ,0)
  15170    ;AEB 7/10 /2007 SWIT CH PHY INF O WITH REM IT INFO
  15171   "RTN","CHG VQ370",226 ,0)
  15172    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
  15173   "RTN","CHG VQ370",227 ,0)
  15174    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
  15175   "RTN","CHG VQ370",228 ,0)
  15176    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
  15177   "RTN","CHG VQ370",229 ,0)
  15178    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
  15179   "RTN","CHG VQ370",230 ,0)
  15180    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
  15181   "RTN","CHG VQ370",231 ,0)
  15182    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
  15183   "RTN","CHG VQ370",232 ,0)
  15184    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
  15185   "RTN","CHG VQ370",233 ,0)
  15186    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
  15187   "RTN","CHG VQ370",234 ,0)
  15188    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)
  15189   "RTN","CHG VQ370",235 ,0)
  15190    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
  15191   "RTN","CHG VQ370",236 ,0)
  15192    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
  15193   "RTN","CHG VQ370",237 ,0)
  15194    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
  15195   "RTN","CHG VQ370",238 ,0)
  15196    ;
  15197   "RTN","CHG VQ370",239 ,0)
  15198    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)
  15199   "RTN","CHG VQ370",240 ,0)
  15200    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)
  15201   "RTN","CHG VQ370",241 ,0)
  15202    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)
  15203   "RTN","CHG VQ370",242 ,0)
  15204    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)
  15205   "RTN","CHG VQ370",243 ,0)
  15206    S:$L(^UTI LITY($J,"V ","CHVVAR" ,11))>25 ^ UTILITY($J ,"V","CHVV AR",11)=$E (^UTILITY( $J,"V","CH VVAR",11), 1,25)
  15207   "RTN","CHG VQ370",244 ,0)
  15208    S:$L(^UTI LITY($J,"V ","CHVVAR" ,12))>25 ^ UTILITY($J ,"V","CHVV AR",12)=$E (^UTILITY( $J,"V","CH VVAR",12), 1,25)
  15209   "RTN","CHG VQ370",245 ,0)
  15210    S:$L(^UTI LITY($J,"V ","CHVVAR" ,13))>25 ^ UTILITY($J ,"V","CHVV AR",13)=$E (^UTILITY( $J,"V","CH VVAR",13), 1,25)
  15211   "RTN","CHG VQ370",246 ,0)
  15212    S:$L(^UTI LITY($J,"V ","CHVVAR" ,14))>15 ^ UTILITY($J ,"V","CHVV AR",14)=$E (^UTILITY( $J,"V","CH VVAR",14), 1,15)
  15213   "RTN","CHG VQ370",247 ,0)
  15214    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)
  15215   "RTN","CHG VQ370",248 ,0)
  15216    S AUSVER= ^UTILITY($ J,"V","CHV VAR",10)
  15217   "RTN","CHG VQ370",249 ,0)
  15218    S AUSVER= $S(AUSVER= 0:"N",AUSV ER=1:"Y",1 :"N")
  15219   "RTN","CHG VQ370",250 ,0)
  15220    S PRVER=^ UTILITY($J ,"V","CHVV AR",17)
  15221   "RTN","CHG VQ370",251 ,0)
  15222    S PRVER=$ S(PRVER=0: "UNVERIFIE D",PRVER=1 :"VERIFIED ",1:"UNVER IFIED")
  15223   "RTN","CHG VQ370",252 ,0)
  15224    S CHLVPTR =^UTILITY( $J,"V","CH VVAR",1)
  15225   "RTN","CHG VQ370",253 ,0)
  15226    S CHLSTAT =$P(^CHMVE N(CHLVPTR, 0),U,8)
  15227   "RTN","CHG VQ370",254 ,0)
  15228    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
  15229   "RTN","CHG VQ370",255 ,0)
  15230    S CHLSTAT =$S(CHLSTA T=0:"A",CH LSTAT=1:"I ",CHLSTAT= 2:"M",CHLS TAT=3:"W", 1:"A")
  15231   "RTN","CHG VQ370",256 ,0)
  15232    S VCOM=""  S:$D(^CHM VCOMM(CHLV PTR,101))  VCOM="Y" D  EFTCHECK         ;;D EV011835 - - DRW -- n ew line ta g see belo w
  15233   "RTN","CHG VQ370",257 ,0)
  15234    ;
  15235   "RTN","CHG VQ370",258 ,0)
  15236    S LSPACE= " " I LPTR <10 S LSPA CE="  "
  15237   "RTN","CHG VQ370",259 ,0)
  15238    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)
  15239   "RTN","CHG VQ370",260 ,0)
  15240    S L2="",$ P(L2," ",5 0-$L(L1))= "" S L1=L1 _L2_"| "_^ UTILITY($J ,"V","CHVV AR",11)
  15241   "RTN","CHG VQ370",261 ,0)
  15242    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_L1
  15243   "RTN","CHG VQ370",262 ,0)
  15244    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15245   "RTN","CHG VQ370",263 ,0)
  15246    S TST=CT, TEND=CT+6
  15247   "RTN","CHG VQ370",264 ,0)
  15248    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15249   "RTN","CHG VQ370",265 ,0)
  15250    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15251   "RTN","CHG VQ370",266 ,0)
  15252    I CHLNPI= ""  D             ;DE V007991a D RW - check  to see if  NPI is pr esent
  15253   "RTN","CHG VQ370",267 ,0)
  15254    .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.
  15255   "RTN","CHG VQ370",268 ,0)
  15256    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.
  15257   "RTN","CHG VQ370",269 ,0)
  15258    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.
  15259   "RTN","CHG VQ370",270 ,0)
  15260    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
  15261   "RTN","CHG VQ370",271 ,0)
  15262    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15263   "RTN","CHG VQ370",272 ,0)
  15264    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15265   "RTN","CHG VQ370",273 ,0)
  15266    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15267   "RTN","CHG VQ370",274 ,0)
  15268    ;
  15269   "RTN","CHG VQ370",275 ,0)
  15270    S L1="STA TUS = "_CH LSTAT_"  " _^UTILITY( $J,"V","CH VVAR",6)
  15271   "RTN","CHG VQ370",276 ,0)
  15272    S L2="",$ P(L2," ",4 1-$L(L1))= "" S L1=L1 _L2_"| "_^ UTILITY($J ,"V","CHVV AR",13)
  15273   "RTN","CHG VQ370",277 ,0)
  15274    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"          "_L1
  15275   "RTN","CHG VQ370",278 ,0)
  15276    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15277   "RTN","CHG VQ370",279 ,0)
  15278    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15279   "RTN","CHG VQ370",280 ,0)
  15280    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15281   "RTN","CHG VQ370",281 ,0)
  15282    ;
  15283   "RTN","CHG VQ370",282 ,0)
  15284    S LPSTATE ="" S LPST ATE1=^UTIL ITY($J,"V" ,"CHVVAR", 8)
  15285   "RTN","CHG VQ370",283 ,0)
  15286    I LPSTATE 1>0 I $D(^ DIC(5,LPST ATE1,0)) D
  15287   "RTN","CHG VQ370",284 ,0)
  15288    .S LPSTAT E=$P(^DIC( 5,LPSTATE1 ,0),U,2)
  15289   "RTN","CHG VQ370",285 ,0)
  15290    .I $D(^DI C(5,LPSTAT E1,741001) ) S LPSTAT E=^DIC(5,L PSTATE1,74 1001)_" "_ $P(^DIC(5, LPSTATE1,0 ),U,1)
  15291   "RTN","CHG VQ370",286 ,0)
  15292    S PRSTATE =""  S PRS TATE1=^UTI LITY($J,"V ","CHVVAR" ,15)
  15293   "RTN","CHG VQ370",287 ,0)
  15294    I PRSTATE 1>0 I $D(^ DIC(5,PRST ATE1,0)) D
  15295   "RTN","CHG VQ370",288 ,0)
  15296    .S PRSTAT E=$P(^DIC( 5,PRSTATE1 ,0),U,2)
  15297   "RTN","CHG VQ370",289 ,0)
  15298    .I $D(^DI C(5,PRSTAT E1,741001) ) S PRSTAT E=^DIC(5,P RSTATE1,74 1001)_" "_ $P(^DIC(5, PRSTATE1,0 ),U,1)
  15299   "RTN","CHG VQ370",290 ,0)
  15300    ;
  15301   "RTN","CHG VQ370",291 ,0)
  15302    S L1="AUS T VER = "_ AUSVER_"   "_^UTILITY ($J,"V","C HVVAR",7)_ "  "_LPSTA TE_" "_^UT ILITY($J," V","CHVVAR ",9)
  15303   "RTN","CHG VQ370",292 ,0)
  15304    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)
  15305   "RTN","CHG VQ370",293 ,0)
  15306    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"        "_L1
  15307   "RTN","CHG VQ370",294 ,0)
  15308    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15309   "RTN","CHG VQ370",295 ,0)
  15310    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15311   "RTN","CHG VQ370",296 ,0)
  15312    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15313   "RTN","CHG VQ370",297 ,0)
  15314    ;
  15315   "RTN","CHG VQ370",298 ,0)
  15316    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
  15317   "RTN","CHG VQ370",299 ,0)
  15318    ; 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
  15319   "RTN","CHG VQ370",300 ,0)
  15320    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"        "_L1
  15321   "RTN","CHG VQ370",301 ,0)
  15322    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15323   "RTN","CHG VQ370",302 ,0)
  15324    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15325   "RTN","CHG VQ370",303 ,0)
  15326    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15327   "RTN","CHG VQ370",304 ,0)
  15328    ;
  15329   "RTN","CHG VQ370",305 ,0)
  15330    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"------ ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---"
  15331   "RTN","CHG VQ370",306 ,0)
  15332    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15333   "RTN","CHG VQ370",307 ,0)
  15334    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15335   "RTN","CHG VQ370",308 ,0)
  15336    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15337   "RTN","CHG VQ370",309 ,0)
  15338    G A1
  15339   "RTN","CHG VQ370",310 ,0)
  15340    ;
  15341   "RTN","CHG VQ370",311 ,0)
  15342   A2 S DX=0, DY=DTM-1 S  $X=$G(DX) ,$Y=$G(DY)  X XY
  15343   "RTN","CHG VQ370",312 ,0)
  15344    Q
  15345   "RTN","CHG VQ370",313 ,0)
  15346   EFTCHECK   ;;this are a will che ck if the  EFT is pre sent for t he vendor   DEV011836  DRW
  15347   "RTN","CHG VQ370",314 ,0)
  15348    N EFTBNKN ,EFTFLG,EF TACCTN,CNT
  15349   "RTN","CHG VQ370",315 ,0)
  15350    S EFTBNKN =0,EFTFLG= 0,EFTACCTN =0
  15351   "RTN","CHG VQ370",316 ,0)
  15352    S CNT=0
  15353   "RTN","CHG VQ370",317 ,0)
  15354    I '$D(^CH MVEN(CHLVP TR,3)) Q
  15355   "RTN","CHG VQ370",318 ,0)
  15356    S EFTBNKN =$P(^CHMVE N(CHLVPTR, 3),"^",1), EFTFLG=$P( ^CHMVEN(CH LVPTR,3)," ^",2),EFTA CCTN=$P(^C HMVEN(CHLV PTR,3),"^" ,3)
  15357   "RTN","CHG VQ370",319 ,0)
  15358    I EFTBNKN '="" S CNT =CNT+1
  15359   "RTN","CHG VQ370",320 ,0)
  15360    I EFTFLG= 1 S CNT=CN T+1
  15361   "RTN","CHG VQ370",321 ,0)
  15362    I EFTACCT N'="" S CN T=CNT+1
  15363   "RTN","CHG VQ370",322 ,0)
  15364    I CNT=3,V COM="" S V COM="EFT"  Q                   ; ;check cou nter for a ll positiv es and the n set the  display
  15365   "RTN","CHG VQ370",323 ,0)
  15366    I CNT=3,V COM'="" S  VCOM=VCOM_ "/EFT"                   ;;if th ere is som ething in  VCOM alrea dy, append  EFT comme nt
  15367   "RTN","CHG VQ370",324 ,0)
  15368    Q
  15369   "RTN","CHG VQ374")
  15370   0^37^B5243 0920
  15371   "RTN","CHG VQ374",1,0 )
  15372   CHGVQ374 ; CVA/PEJ; V F SELECT -  SCREEN PA RAMS/GLOBA L;08/07/96   2:56 PM   ; Compile d October  5, 2010 10 :02:59
  15373   "RTN","CHG VQ374",2,0 )
  15374    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  15375   "RTN","CHG VQ374",3,0 )
  15376    ;;V3.0;
  15377   "RTN","CHG VQ374",4,0 )
  15378    ;CPTS #10 846 - PEJ  8/15/96
  15379   "RTN","CHG VQ374",5,0 )
  15380    ;DEV 0079 91a Vendor  Lookup; D RW - 10/05 /2010 User  has reque sted that  the NPI
  15381   "RTN","CHG VQ374",6,0 )
  15382    ;(Nationa l Provider  Identifie r) be part  of the Ve ndor Resul t Screen.    
  15383   "RTN","CHG VQ374",7,0 )
  15384    ;NPI alon g with one  space and  ten digit s makes it  14 charac ters in le ngth.
  15385   "RTN","CHG VQ374",8,0 )
  15386    ;;DEV0118 35 Vendor  Comment; D RW - 05/18 /2012:  Us er request ed that an  identifie r of 
  15387   "RTN","CHG VQ374",9,0 )
  15388    ;;"EFT" ( Electronic  Funds Tra nsfer) be  place in t he VCOM fi eld on the  display w hen
  15389   "RTN","CHG VQ374",10, 0)
  15390    ;;a vendo r is selec ted that h as both th e EFT flag  of Yes (1 ) and an E FT account  number.
  15391   "RTN","CHG VQ374",11, 0)
  15392    ;;
  15393   "RTN","CHG VQ374",12, 0)
  15394    ;;SBB 06/ 20/17 CPE0 01-001-T3- 522242 Mod ify code t o not disp lay PL inf o in the s earch resu lt.
  15395   "RTN","CHG VQ374",13, 0)
  15396    ;
  15397   "RTN","CHG VQ374",14, 0)
  15398    ;******** SET UP SCR EEN GLOBAL ********** ********** ********** ********** **
  15399   "RTN","CHG VQ374",15, 0)
  15400   GLOBSET S: '$D(^UTILI TY($J,CHFU NC,CHZONE, 0)) ^UTILI TY($J,CHFU NC,CHZONE, 0)=0
  15401   "RTN","CHG VQ374",16, 0)
  15402    S CT=^UTI LITY($J,CH FUNC,CHZON E,0)
  15403   "RTN","CHG VQ374",17, 0)
  15404    S X="X XY  W @CHBON, P1,@CHBOFF  S DX=29 S  $X=$G(DX) ,$Y=$G(DY)  X XY W P2 "
  15405   "RTN","CHG VQ374",18, 0)
  15406    S LPTR=0
  15407   "RTN","CHG VQ374",19, 0)
  15408   A1 S LPTR= $O(^UTILIT Y($J,"VLUL IST",LPTR) ) G:'LPTR  A2
  15409   "RTN","CHG VQ374",20, 0)
  15410    F XIX=1:1 :22 S ^UTI LITY($J,"V ","CHVVAR" ,XIX)=""
  15411   "RTN","CHG VQ374",21, 0)
  15412    F XIX=1:1 :22 S ^UTI LITY($J,"V ","CHVVAR" ,XIX)=$P(^ UTILITY($J ,"VLULIST" ,LPTR),U,X IX)
  15413   "RTN","CHG VQ374",22, 0)
  15414    ;AEB 7/10 /2007 SWIT CH PHY INF O WITH REM IT INFO
  15415   "RTN","CHG VQ374",23, 0)
  15416    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
  15417   "RTN","CHG VQ374",24, 0)
  15418    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
  15419   "RTN","CHG VQ374",25, 0)
  15420    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
  15421   "RTN","CHG VQ374",26, 0)
  15422    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
  15423   "RTN","CHG VQ374",27, 0)
  15424    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
  15425   "RTN","CHG VQ374",28, 0)
  15426    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
  15427   "RTN","CHG VQ374",29, 0)
  15428    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
  15429   "RTN","CHG VQ374",30, 0)
  15430    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
  15431   "RTN","CHG VQ374",31, 0)
  15432    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)
  15433   "RTN","CHG VQ374",32, 0)
  15434    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
  15435   "RTN","CHG VQ374",33, 0)
  15436    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
  15437   "RTN","CHG VQ374",34, 0)
  15438    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
  15439   "RTN","CHG VQ374",35, 0)
  15440    ;
  15441   "RTN","CHG VQ374",36, 0)
  15442    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)
  15443   "RTN","CHG VQ374",37, 0)
  15444    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)
  15445   "RTN","CHG VQ374",38, 0)
  15446    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)
  15447   "RTN","CHG VQ374",39, 0)
  15448    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)
  15449   "RTN","CHG VQ374",40, 0)
  15450    S:$L(^UTI LITY($J,"V ","CHVVAR" ,11))>25 ^ UTILITY($J ,"V","CHVV AR",11)=$E (^UTILITY( $J,"V","CH VVAR",11), 1,25)
  15451   "RTN","CHG VQ374",41, 0)
  15452    S:$L(^UTI LITY($J,"V ","CHVVAR" ,12))>25 ^ UTILITY($J ,"V","CHVV AR",12)=$E (^UTILITY( $J,"V","CH VVAR",12), 1,25)
  15453   "RTN","CHG VQ374",42, 0)
  15454    S:$L(^UTI LITY($J,"V ","CHVVAR" ,13))>25 ^ UTILITY($J ,"V","CHVV AR",13)=$E (^UTILITY( $J,"V","CH VVAR",13), 1,25)
  15455   "RTN","CHG VQ374",43, 0)
  15456    S:$L(^UTI LITY($J,"V ","CHVVAR" ,14))>15 ^ UTILITY($J ,"V","CHVV AR",14)=$E (^UTILITY( $J,"V","CH VVAR",14), 1,15)
  15457   "RTN","CHG VQ374",44, 0)
  15458    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)
  15459   "RTN","CHG VQ374",45, 0)
  15460    S AUSVER= ^UTILITY($ J,"V","CHV VAR",10)
  15461   "RTN","CHG VQ374",46, 0)
  15462    S AUSVER= $S(AUSVER= 0:"N",AUSV ER=1:"Y",1 :"N")
  15463   "RTN","CHG VQ374",47, 0)
  15464    S PRVER=^ UTILITY($J ,"V","CHVV AR",17)
  15465   "RTN","CHG VQ374",48, 0)
  15466    S PRVER=$ S(PRVER=0: "UNVERIFIE D",PRVER=1 :"VERIFIED ",1:"UNVER IFIED")
  15467   "RTN","CHG VQ374",49, 0)
  15468    S CHLVPTR =^UTILITY( $J,"V","CH VVAR",1)
  15469   "RTN","CHG VQ374",50, 0)
  15470    S CHLSTAT =$P(^CHMVE N(CHLVPTR, 0),U,8)
  15471   "RTN","CHG VQ374",51, 0)
  15472    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 
  15473   "RTN","CHG VQ374",52, 0)
  15474    S CHLSTAT =$S(CHLSTA T=0:"A",CH LSTAT=1:"I ",CHLSTAT= 2:"M",CHLS TAT=3:"W", 1:"A")
  15475   "RTN","CHG VQ374",53, 0)
  15476    S VCOM=""  S:$D(^CHM VCOMM(CHLV PTR,101))  VCOM="Y" D  EFTCHECK         ;;D EV011835 - - DRW -- n ew line ta g see belo w
  15477   "RTN","CHG VQ374",54, 0)
  15478    ;
  15479   "RTN","CHG VQ374",55, 0)
  15480    S LSPACE= " " I LPTR <10 S LSPA CE="  "
  15481   "RTN","CHG VQ374",56, 0)
  15482    ;SBB 06/3 0/17 CPE00 1-001-T3-5 22242
  15483   "RTN","CHG VQ374",57, 0)
  15484    ;S L1=LSP ACE_LPTR_" ) "_^UTILI TY($J,"V", "CHVVAR",3 )_" "_^UTI LITY($J,"V ","CHVVAR" ,4)_" "_^U TILITY($J, "V","CHVVA R",22)_" " _^UTILITY( $J,"V","CH VVAR",2)
  15485   "RTN","CHG VQ374",58, 0)
  15486    S L1=LSPA CE_LPTR_")  "_^UTILIT Y($J,"V"," CHVVAR",3) _" "_^UTIL ITY($J,"V" ,"CHVVAR", 4)_" "_^UT ILITY($J," V","CHVVAR ",22)   ;_ " "_^UTILI TY($J,"V", "CHVVAR",2 )
  15487   "RTN","CHG VQ374",59, 0)
  15488    S L2="",$ P(L2," ",5 0-$L(L1))= "" S L1=L1 _L2_"| "_^ UTILITY($J ,"V","CHVV AR",11)
  15489   "RTN","CHG VQ374",60, 0)
  15490    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_L1
  15491   "RTN","CHG VQ374",61, 0)
  15492    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15493   "RTN","CHG VQ374",62, 0)
  15494    S TST=CT, TEND=CT+6
  15495   "RTN","CHG VQ374",63, 0)
  15496    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15497   "RTN","CHG VQ374",64, 0)
  15498    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15499   "RTN","CHG VQ374",65, 0)
  15500    I CHLNPI= ""  D             ;DE V007991a D RW - check  to see if  NPI is pr esent 
  15501   "RTN","CHG VQ374",66, 0)
  15502    .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.
  15503   "RTN","CHG VQ374",67, 0)
  15504    ;SBB 06/3 0/17 CPE00 1-001-T3-5 22242
  15505   "RTN","CHG VQ374",68, 0)
  15506    ;S L1="NP I "_CHLNPI _" "_^UTIL ITY($J,"V" ,"CHVVAR", 5)    ;DEV  007991a 1 0/05/10 DR W - append s NPI alon g with a s pace and t en digits  in front o f vendor a ddress.  
  15507   "RTN","CHG VQ374",69, 0)
  15508    S L1="NPI  "_CHLNPI    ;_" "_^U TILITY($J, "V","CHVVA R",5)    ; DEV 007991 a 10/05/10  DRW - app ends NPI a long with  a space an d ten digi ts in fron t of vendo r address.   
  15509   "RTN","CHG VQ374",70, 0)
  15510    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.
  15511   "RTN","CHG VQ374",71, 0)
  15512    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
  15513   "RTN","CHG VQ374",72, 0)
  15514    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15515   "RTN","CHG VQ374",73, 0)
  15516    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15517   "RTN","CHG VQ374",74, 0)
  15518    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15519   "RTN","CHG VQ374",75, 0)
  15520    ;
  15521   "RTN","CHG VQ374",76, 0)
  15522    S L1="STA TUS = "_CH LSTAT_"  " _^UTILITY( $J,"V","CH VVAR",6)
  15523   "RTN","CHG VQ374",77, 0)
  15524    S L2="",$ P(L2," ",4 1-$L(L1))= "" S L1=L1 _L2_"| "_^ UTILITY($J ,"V","CHVV AR",13)
  15525   "RTN","CHG VQ374",78, 0)
  15526    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"          "_L1
  15527   "RTN","CHG VQ374",79, 0)
  15528    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15529   "RTN","CHG VQ374",80, 0)
  15530    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15531   "RTN","CHG VQ374",81, 0)
  15532    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15533   "RTN","CHG VQ374",82, 0)
  15534    ;
  15535   "RTN","CHG VQ374",83, 0)
  15536    S LPSTATE ="" S LPST ATE1=^UTIL ITY($J,"V" ,"CHVVAR", 8)
  15537   "RTN","CHG VQ374",84, 0)
  15538    I LPSTATE 1>0 I $D(^ DIC(5,LPST ATE1,0)) D
  15539   "RTN","CHG VQ374",85, 0)
  15540    .S LPSTAT E=$P(^DIC( 5,LPSTATE1 ,0),U,2)
  15541   "RTN","CHG VQ374",86, 0)
  15542    .I $D(^DI C(5,LPSTAT E1,741001) ) S LPSTAT E=^DIC(5,L PSTATE1,74 1001)_" "_ $P(^DIC(5, LPSTATE1,0 ),U,1)
  15543   "RTN","CHG VQ374",87, 0)
  15544    S PRSTATE =""  S PRS TATE1=^UTI LITY($J,"V ","CHVVAR" ,15)
  15545   "RTN","CHG VQ374",88, 0)
  15546    I PRSTATE 1>0 I $D(^ DIC(5,PRST ATE1,0)) D
  15547   "RTN","CHG VQ374",89, 0)
  15548    .S PRSTAT E=$P(^DIC( 5,PRSTATE1 ,0),U,2)
  15549   "RTN","CHG VQ374",90, 0)
  15550    .I $D(^DI C(5,PRSTAT E1,741001) ) S PRSTAT E=^DIC(5,P RSTATE1,74 1001)_" "_ $P(^DIC(5, PRSTATE1,0 ),U,1)
  15551   "RTN","CHG VQ374",91, 0)
  15552    ;
  15553   "RTN","CHG VQ374",92, 0)
  15554    ;SBB 06/3 0/17 CPE00 1-001-T3-5 22242
  15555   "RTN","CHG VQ374",93, 0)
  15556    ;S L1="AU ST VER = " _AUSVER_"   "_^UTILIT Y($J,"V"," CHVVAR",7) _"  "_LPST ATE_" "_^U TILITY($J, "V","CHVVA R",9)
  15557   "RTN","CHG VQ374",94, 0)
  15558    S L1="AUS T VER = "_ AUSVER   ; _"  "_^UTI LITY($J,"V ","CHVVAR" ,7)_"  "_L PSTATE_" " _^UTILITY( $J,"V","CH VVAR",9)
  15559   "RTN","CHG VQ374",95, 0)
  15560    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)
  15561   "RTN","CHG VQ374",96, 0)
  15562    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"        "_L1
  15563   "RTN","CHG VQ374",97, 0)
  15564    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15565   "RTN","CHG VQ374",98, 0)
  15566    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15567   "RTN","CHG VQ374",99, 0)
  15568    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15569   "RTN","CHG VQ374",100 ,0)
  15570    ;
  15571   "RTN","CHG VQ374",101 ,0)
  15572    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
  15573   "RTN","CHG VQ374",102 ,0)
  15574    ; 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
  15575   "RTN","CHG VQ374",103 ,0)
  15576    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"        "_L1
  15577   "RTN","CHG VQ374",104 ,0)
  15578    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15579   "RTN","CHG VQ374",105 ,0)
  15580    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15581   "RTN","CHG VQ374",106 ,0)
  15582    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15583   "RTN","CHG VQ374",107 ,0)
  15584    ;
  15585   "RTN","CHG VQ374",108 ,0)
  15586    D UPCT^CH GVQ010 S ^ UTILITY($J ,CHFUNC,CH ZONE,CT)=X _U_"------ ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---"
  15587   "RTN","CHG VQ374",109 ,0)
  15588    S ^UTILIT Y($J,CHFUN C,CHZONE,C T,"FIELDS" ,CT)="1^0^ 30^^^"
  15589   "RTN","CHG VQ374",110 ,0)
  15590    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,12 )=CHLVPTR
  15591   "RTN","CHG VQ374",111 ,0)
  15592    S $P(^UTI LITY($J,CH FUNC,CHZON E,CT),U,24 )="1^0"
  15593   "RTN","CHG VQ374",112 ,0)
  15594    G A1
  15595   "RTN","CHG VQ374",113 ,0)
  15596    ;
  15597   "RTN","CHG VQ374",114 ,0)
  15598   A2 S DX=0, DY=DTM-1 S  $X=$G(DX) ,$Y=$G(DY)  X XY
  15599   "RTN","CHG VQ374",115 ,0)
  15600    Q
  15601   "RTN","CHG VQ374",116 ,0)
  15602   EFTCHECK   ;;this are a will che ck if the  EFT is pre sent for t he vendor   DEV011836  DRW
  15603   "RTN","CHG VQ374",117 ,0)
  15604    N EFTBNKN ,EFTFLG,EF TACCTN,CNT
  15605   "RTN","CHG VQ374",118 ,0)
  15606    S EFTBNKN =0,EFTFLG= 0,EFTACCTN =0
  15607   "RTN","CHG VQ374",119 ,0)
  15608    S CNT=0
  15609   "RTN","CHG VQ374",120 ,0)
  15610    I '$D(^CH MVEN(CHLVP TR,3)) G F IN
  15611   "RTN","CHG VQ374",121 ,0)
  15612    S EFTBNKN =$P(^CHMVE N(CHLVPTR, 3),"^",1), EFTFLG=$P( ^CHMVEN(CH LVPTR,3)," ^",2),EFTA CCTN=$P(^C HMVEN(CHLV PTR,3),"^" ,3)
  15613   "RTN","CHG VQ374",122 ,0)
  15614    I EFTBNKN '="" S CNT =CNT+1
  15615   "RTN","CHG VQ374",123 ,0)
  15616    I EFTFLG= 1 S CNT=CN T+1 
  15617   "RTN","CHG VQ374",124 ,0)
  15618    I EFTACCT N'="" S CN T=CNT+1
  15619   "RTN","CHG VQ374",125 ,0)
  15620    I CNT=3,V COM="" S V COM="EFT"  G FIN                    ;;check  counter f or all pos itives and  then set  the displa
  15621   "RTN","CHG VQ374",126 ,0)
  15622    I CNT=3,V COM'="" S  VCOM=VCOM_ "/EFT"                   ;;if th ere is som ething in  VCOM alrea dy, append  EFT comme nt
  15623   "RTN","CHG VQ374",127 ,0)
  15624   FIN;
  15625   "RTN","CHG VQ374",128 ,0)
  15626    Q 
  15627   "RTN","CHG VQ374",129 ,0)
  15628    ;
  15629   "RTN","CHG VQ529")
  15630   0^38^B9657 3340
  15631   "RTN","CHG VQ529",1,0 )
  15632   CHGVQ529 ; CVA/PEJ; V F SELECT -  MAIN SCRE EN;Feb 06,  2019@09:5 6:35
  15633   "RTN","CHG VQ529",2,0 )
  15634    ;;1.0;CHA MPVA SYSTE M;**1,8,14 **;JULY 4,  1990;Buil d 5
  15635   "RTN","CHG VQ529",3,0 )
  15636    ;CPTS #10 846* - PEJ  8/15/96
  15637   "RTN","CHG VQ529",4,0 )
  15638    ;CPTS #11 158* - PEJ  10/30/96
  15639   "RTN","CHG VQ529",5,0 )
  15640    ;CPTS #11 294* - PEJ  12/5/96,  #16483* (R LC)
  15641   "RTN","CHG VQ529",6,0 )
  15642    ;jsg;DEV0 02841-02;0 5/12/09;Au to Vendor  Selection  Process;
  15643   "RTN","CHG VQ529",7,0 )
  15644    ;DEV00799 1 10/08/20 10 JAK --V ENDOR LOOK UP utilizi ng NPI
  15645   "RTN","CHG VQ529",8,0 )
  15646    ;BUG00799 1-07 DRW -  Added com ment on th e Fileman  search ind ex 12/15/1 0
  15647   "RTN","CHG VQ529",9,0 )
  15648    ;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
  15649   "RTN","CHG VQ529",10, 0)
  15650    ;HM 06/30 /17 CPE001 -001-T3-52 2242 Modif y code to  use vendor  result if  only one  is returne d.
  15651   "RTN","CHG VQ529",11, 0)
  15652    ;BDB 01/2 5/18 CPE00 1-010 Add  label LU2
  15653   "RTN","CHG VQ529",12, 0)
  15654    ;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
  15655   "RTN","CHG VQ529",13, 0)
  15656    ;TGH - 3/ 8/18 Defec t 693971 F ix Inactiv e Vendor S earch
  15657   "RTN","CHG VQ529",14, 0)
  15658    ;BDB - 9/ 17/18 Defe ct 824319  - CPE001-0 01 - Vendo r Search r eturns ONE  result -- > use corr ect vendor  result
  15659   "RTN","CHG VQ529",15, 0)
  15660   LU1 ;; loo kup based  on Tax Ide ntificatio n Number   ;DEV007991  10/08/201 0 JAK
  15661   "RTN","CHG VQ529",16, 0)
  15662    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  15663   "RTN","CHG VQ529",17, 0)
  15664   LU2 ;;D RN GECLR^CHSC H1(4,22,XY ,CHEOL)    ;SKD ; ;BD B 01/25/18  CPE001-01 0
  15665   "RTN","CHG VQ529",18, 0)
  15666    S CHLID=C HXTID
  15667   "RTN","CHG VQ529",19, 0)
  15668    S:'$D(CHX PI) CHXPI= ""
  15669   "RTN","CHG VQ529",20, 0)
  15670    S:'$D(CHX NPI) CHXNP I=""  ;AEB  9/18/2007
  15671   "RTN","CHG VQ529",21, 0)
  15672    S:'$D(CHX PRN) CHXPR N=""  ;AEB  9/18/2007
  15673   "RTN","CHG VQ529",22, 0)
  15674    S CHXPI=$ P(CHXPI,U, 2)
  15675   "RTN","CHG VQ529",23, 0)
  15676    ;I $L(CHL ID)>13 G L U2^CHGVQ37 0                  ;D EV007991 1 0/08/2010  JAK -comme nted out
  15677   "RTN","CHG VQ529",24, 0)
  15678    ;
  15679   "RTN","CHG VQ529",25, 0)
  15680    S CHLID1= CHLID
  15681   "RTN","CHG VQ529",26, 0)
  15682    K ^UTILIT Y($J,"CHLU OUT")
  15683   "RTN","CHG VQ529",27, 0)
  15684    ;jsg;5/14 /09;DEV002 841;If AVS , pull lis t of vendo rs from ^C HMIMAGE(PD I,100) AVS  index:  ;
  15685   "RTN","CHG VQ529",28, 0)
  15686    IF $D(CHM FPDI),$D(A SVFLG),$D( ^CHMIMAGE( CHMFPDI,10 0,0)),$P(^ (0),U,3)>1  {
  15687   "RTN","CHG VQ529",29, 0)
  15688        D MUL TIASV^CHMX V005(CHMFP DI,0) K AS VFLG }
  15689   "RTN","CHG VQ529",30, 0)
  15690    ELSE { D  FIND^DIC(7 41001,,,"" ,CHLID1,," H",,,"^UTI LITY($J,"" CHLUOUT"") ") }
  15691   "RTN","CHG VQ529",31, 0)
  15692    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  15693   "RTN","CHG VQ529",32, 0)
  15694    I $P(^UTI LITY($J,"C HLUOUT","D ILIST",0), U,1)<1 Q
  15695   "RTN","CHG VQ529",33, 0)
  15696    D RESORTF ^CHGVQ535              ;DEV00799 1 10/08/20 10 JAK
  15697   "RTN","CHG VQ529",34, 0)
  15698    Q
  15699   "RTN","CHG VQ529",35, 0)
  15700   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
  15701   "RTN","CHG VQ529",36, 0)
  15702    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  15703   "RTN","CHG VQ529",37, 0)
  15704    S CHLID=C HXNPI,CHLI D1=CHXNPI
  15705   "RTN","CHG VQ529",38, 0)
  15706    S:'$D(CHX PI) CHXPI= ""
  15707   "RTN","CHG VQ529",39, 0)
  15708    S:'$D(CHX PRN) CHXPR N=""  ;AEB  9/18/2007
  15709   "RTN","CHG VQ529",40, 0)
  15710    S CHXPI=$ P(CHXPI,U, 2)
  15711   "RTN","CHG VQ529",41, 0)
  15712    ;
  15713   "RTN","CHG VQ529",42, 0)
  15714    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.
  15715   "RTN","CHG VQ529",43, 0)
  15716    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.
  15717   "RTN","CHG VQ529",44, 0)
  15718    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  15719   "RTN","CHG VQ529",45, 0)
  15720    I $P(^UTI LITY($J,"C HLUOUT","D ILIST",0), U,1)<1 Q   ;; IF NO N PI MATCHES  FOUND THE N QUIT
  15721   "RTN","CHG VQ529",46, 0)
  15722    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  15723   "RTN","CHG VQ529",47, 0)
  15724    Q
  15725   "RTN","CHG VQ529",48, 0)
  15726   LOOK2 ; lo okup based  on remit- to name  ; DEV007991  10/08/2010  JAK
  15727   "RTN","CHG VQ529",49, 0)
  15728    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  15729   "RTN","CHG VQ529",50, 0)
  15730    S CHLID=C HXPRN
  15731   "RTN","CHG VQ529",51, 0)
  15732    S:'$D(CHX PI) CHXPI= ""
  15733   "RTN","CHG VQ529",52, 0)
  15734    S CHXPI=$ P(CHXPI,U, 2)
  15735   "RTN","CHG VQ529",53, 0)
  15736    ;
  15737   "RTN","CHG VQ529",54, 0)
  15738    S CHLID1= CHLID
  15739   "RTN","CHG VQ529",55, 0)
  15740    K ^UTILIT Y($J,"CHLU OUT")
  15741   "RTN","CHG VQ529",56, 0)
  15742    D FIND^DI C(741001,, ,"M",CHLID 1,,"B",,," ^UTILITY($ J,""CHLUOU T"")")
  15743   "RTN","CHG VQ529",57, 0)
  15744    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  15745   "RTN","CHG VQ529",58, 0)
  15746    I $P(^UTI LITY($J,"C HLUOUT","D ILIST",0), U,1)<1 Q
  15747   "RTN","CHG VQ529",59, 0)
  15748    D RESORTF ^CHGVQ535
  15749   "RTN","CHG VQ529",60, 0)
  15750    ;
  15751   "RTN","CHG VQ529",61, 0)
  15752    ;S CHLUPT R=0  S:'$D (CHTZIP) C HTZIP=""   ;AEB 4/9/2 008 DEF004 723 DEFINE D CHTZIP I F MISSING
  15753   "RTN","CHG VQ529",62, 0)
  15754    ;F  S CHL UPTR=$O(^U TILITY($J, "CHLUOUT", "DILIST",2 ,CHLUPTR))  Q:'CHLUPT R  D
  15755   "RTN","CHG VQ529",63, 0)
  15756    ;.S CHLPT R=^UTILITY ($J,"CHLUO UT","DILIS T",2,CHLUP TR)
  15757   "RTN","CHG VQ529",64, 0)
  15758    ;.Q:'$D(^ CHMVEN(CHL PTR,0))
  15759   "RTN","CHG VQ529",65, 0)
  15760    ;.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
  15761   "RTN","CHG VQ529",66, 0)
  15762    ;.I CHXIM '="" Q:CHA CIM'=CHXIM                                                    ;;  AUSTIN MOD IFIER: QUI T IF '= A. M. PROVIDE D  ;DEV007 991 10/08/ 2010 JAK
  15763   "RTN","CHG VQ529",67, 0)
  15764    ;.S CHSTA T=$P(^CHMV EN(CHLPTR, 0),U,8)                                            ;;  DETERMINE  STATUS  ;D EV007991 1 0/08/2010  JAK
  15765   "RTN","CHG VQ529",68, 0)
  15766    ;.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
  15767   "RTN","CHG VQ529",69, 0)
  15768    ;.I CHXPI '="" D CHK PI^CHGVQ37 0 Q:CHPIFL G=0                                     ;;  DETERMINE  PROGRAM IN DICATOR  ; DEV007991  10/08/2010  JAK
  15769   "RTN","CHG VQ529",70, 0)
  15770    ;.S:$D(^C HMVEN(CHLP TR,2)) CHT ZIP=$P(^CH MVEN(CHLPT R,2),U,5)
  15771   "RTN","CHG VQ529",71, 0)
  15772    ;.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
  15773   "RTN","CHG VQ529",72, 0)
  15774    ;.S:$D(^C HMVEN(CHLP TR,1)) CHT RZIP=$P(^C HMVEN(CHLP TR,1),U,5)
  15775   "RTN","CHG VQ529",73, 0)
  15776    ;.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
  15777   "RTN","CHG VQ529",74, 0)
  15778    ;.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
  15779   "RTN","CHG VQ529",75, 0)
  15780    ;.D ADDLI ST^CHGVQ52 8
  15781   "RTN","CHG VQ529",76, 0)
  15782    Q
  15783   "RTN","CHG VQ529",77, 0)
  15784   RN0 ; ; lo okup based  on physic al locatio n name
  15785   "RTN","CHG VQ529",78, 0)
  15786    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  15787   "RTN","CHG VQ529",79, 0)
  15788    S CHLID=C HXPLN
  15789   "RTN","CHG VQ529",80, 0)
  15790    S:'$D(CHX PI) CHXPI= ""
  15791   "RTN","CHG VQ529",81, 0)
  15792    S CHXPI=$ P(CHXPI,U, 2)
  15793   "RTN","CHG VQ529",82, 0)
  15794    S CHLID1= CHLID
  15795   "RTN","CHG VQ529",83, 0)
  15796    K ^UTILIT Y($J,"CHLU OUT")
  15797   "RTN","CHG VQ529",84, 0)
  15798    D FIND^DI C(741001,, ,"M",CHLID 1,,"J",,," ^UTILITY($ J,""CHLUOU T"")")
  15799   "RTN","CHG VQ529",85, 0)
  15800    I '$D(^UT ILITY($J," CHLUOUT"))  Q
  15801   "RTN","CHG VQ529",86, 0)
  15802    I $P(^UTI LITY($J,"C HLUOUT","D ILIST",0), U,1)<1 Q
  15803   "RTN","CHG VQ529",87, 0)
  15804    D RESORTF ^CHGVQ535
  15805   "RTN","CHG VQ529",88, 0)
  15806    ;S CHLUPT R=0
  15807   "RTN","CHG VQ529",89, 0)
  15808    ;F  S CHL UPTR=$O(^U TILITY($J, "CHLUOUT", "DILIST",2 ,CHLUPTR))  Q:'CHLUPT R  D
  15809   "RTN","CHG VQ529",90, 0)
  15810    ;.S CHLPT R=^UTILITY ($J,"CHLUO UT","DILIS T",2,CHLUP TR)
  15811   "RTN","CHG VQ529",91, 0)
  15812    ;.Q:'$D(^ CHMVEN(CHL PTR,0))
  15813   "RTN","CHG VQ529",92, 0)
  15814    ;.S CHSTA T=$P(^CHMV EN(CHLPTR, 0),U,8)
  15815   "RTN","CHG VQ529",93, 0)
  15816    ;.I $D(CH XACT) I CH XACT'="Y"  Q:((CHSTAT =1)!(CHSTA T=2))
  15817   "RTN","CHG VQ529",94, 0)
  15818    ;.I $D(CH XPI) I CHX PI'="" D C HKPI^CHGVQ 370 Q:CHPI FLG=0
  15819   "RTN","CHG VQ529",95, 0)
  15820    ;.S CHTZI P=$P(^CHMV EN(CHLPTR, 2),U,5)
  15821   "RTN","CHG VQ529",96, 0)
  15822    ;.I $D(CH XZIP) I CH XZIP'="" Q :$E(CHTZIP ,1,$L(CHXZ IP))'=CHXZ IP
  15823   "RTN","CHG VQ529",97, 0)
  15824    ;.I CHSTA TE>0 Q:$P( ^CHMVEN(CH LPTR,2),U, 4)'=CHSTAT E
  15825   "RTN","CHG VQ529",98, 0)
  15826    ;.I $D(CH XPLN) I CH XPLN'="" D   Q:TMPPRI D'=CHXPLN   ;PROV LOC  QUALIFIER
  15827   "RTN","CHG VQ529",99, 0)
  15828    ;..S:'$D( ^CHMVEN(CH LPTR,2)) ^ CHMVEN(CHL PTR,2)=""
  15829   "RTN","CHG VQ529",100 ,0)
  15830    ;..S TMPP RID=$P(^CH MVEN(CHLPT R,2),U,8)
  15831   "RTN","CHG VQ529",101 ,0)
  15832    ;..S TMPP RID=$E(TMP PRID,1,$L( CHXPLN))
  15833   "RTN","CHG VQ529",102 ,0)
  15834    ;.D ADDLI ST^CHGVQ52 8
  15835   "RTN","CHG VQ529",103 ,0)
  15836    Q
  15837   "RTN","CHG VQ529",104 ,0)
  15838   SN0 ;
  15839   "RTN","CHG VQ529",105 ,0)
  15840    D RNGECLR ^CHSCH1(SC RLTOP,SCRL BOT,XY,CHE OL)
  15841   "RTN","CHG VQ529",106 ,0)
  15842    S DY=SCRL TOP+2,DX=0  S $X=$G(D X),$Y=$G(D Y) X XY
  15843   "RTN","CHG VQ529",107 ,0)
  15844    W "THIS L IST WILL T AKE A VERY  LONG TIME . DO YOU W ANT TO CON TINUE? "
  15845   "RTN","CHG VQ529",108 ,0)
  15846    D CSBRS^C HSC2
  15847   "RTN","CHG VQ529",109 ,0)
  15848    I $E(Y,1) '="Y" Q
  15849   "RTN","CHG VQ529",110 ,0)
  15850    K ^TMP("D ILIST",$J)
  15851   "RTN","CHG VQ529",111 ,0)
  15852    D LIST^DI C(741001,, ,,,,,,"I $ P(^CHMVEN( Y,0),U,8)< 1")
  15853   "RTN","CHG VQ529",112 ,0)
  15854    I '$D(^TM P("DILIST" ,$J)) Q
  15855   "RTN","CHG VQ529",113 ,0)
  15856    I $P(^TMP ("DILIST", $J,0),U,1) <1 Q
  15857   "RTN","CHG VQ529",114 ,0)
  15858    D RESORT1 ^CHGVQ535
  15859   "RTN","CHG VQ529",115 ,0)
  15860    ;
  15861   "RTN","CHG VQ529",116 ,0)
  15862    S CHLUPTR =0
  15863   "RTN","CHG VQ529",117 ,0)
  15864    F  S CHLU PTR=$O(^TM P("DILIST" ,$J,2,CHLU PTR)) Q:'C HLUPTR  D
  15865   "RTN","CHG VQ529",118 ,0)
  15866    .S CHLPTR =^TMP("DIL IST",$J,2, CHLUPTR) Q :'$D(^CHMV EN(CHLPTR, 0))
  15867   "RTN","CHG VQ529",119 ,0)
  15868    .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
  15869   "RTN","CHG VQ529",120 ,0)
  15870    .D ADDLIS T^CHGVQ528
  15871   "RTN","CHG VQ529",121 ,0)
  15872    Q
  15873   "RTN","CHG VQ529",122 ,0)
  15874    ;
  15875   "RTN","CHG VQ529",123 ,0)
  15876    ;******** SET UP SCR EEN PARAME TERS****** ********** ********** ********** **
  15877   "RTN","CHG VQ529",124 ,0)
  15878   SCSET ;S S CRLEN=14
  15879   "RTN","CHG VQ529",125 ,0)
  15880    N CHFUNC
  15881   "RTN","CHG VQ529",126 ,0)
  15882    S DSPLEN= SCRLEN+1
  15883   "RTN","CHG VQ529",127 ,0)
  15884    ;S DTM=4  ;TOP MARGI N +1
  15885   "RTN","CHG VQ529",128 ,0)
  15886    ;S DBM=19  ;BOTTOM M ARGIN
  15887   "RTN","CHG VQ529",129 ,0)
  15888    S DTM=5     ;SKD
  15889   "RTN","CHG VQ529",130 ,0)
  15890    S DBM=20     ;SKD
  15891   "RTN","CHG VQ529",131 ,0)
  15892    S CHFUNC= "VLKUP"
  15893   "RTN","CHG VQ529",132 ,0)
  15894    S CHZONE= 0
  15895   "RTN","CHG VQ529",133 ,0)
  15896    S ^UTILIT Y($J,"CHSC RN",CHFUNC ,CHZONE,"B EG")=1
  15897   "RTN","CHG VQ529",134 ,0)
  15898    D ^CHSC3  ;SCREEN SE TUP (INSTE AD OF ^CHM FSET)
  15899   "RTN","CHG VQ529",135 ,0)
  15900    ;D RNGECL R^CHSCH1(S CRLTOP,SCR LBOT,XY,CH EOL)
  15901   "RTN","CHG VQ529",136 ,0)
  15902    D RNGECLR ^CHSCH1(3, 19,XY,CHEO L)
  15903   "RTN","CHG VQ529",137 ,0)
  15904    X CHMAR
  15905   "RTN","CHG VQ529",138 ,0)
  15906    D DSPHDR^ CHGVQ370
  15907   "RTN","CHG VQ529",139 ,0)
  15908    Q
  15909   "RTN","CHG VQ529",140 ,0)
  15910    ;
  15911   "RTN","CHG VQ529",141 ,0)
  15912   ADDLIST ;H M 7/11/201 7 CALL LOC AL LABEL T O POPULATE  ^UTILITY  GLOBAL TO  GET CORREC T COUNTS
  15913   "RTN","CHG VQ529",142 ,0)
  15914    S CA=0,CL LEN=0,LLEN =0
  15915   "RTN","CHG VQ529",143 ,0)
  15916    S:'$D(CHT ZIP) CHTZI P=""
  15917   "RTN","CHG VQ529",144 ,0)
  15918    S:'$D(CHT RZIP) CHTR ZIP=""
  15919   "RTN","CHG VQ529",145 ,0)
  15920    F  S CA=$ O(^UTILITY ($J,"CHLUO UT","DILIS T",2,CA))  Q:'CA  D
  15921   "RTN","CHG VQ529",146 ,0)
  15922    .S CHL=^U TILITY($J, "CHLUOUT", "DILIST",2 ,CA) Q:'$D (^CHMVEN(C HL,0))
  15923   "RTN","CHG VQ529",147 ,0)
  15924    .S CHSTAT =$P(^CHMVE N(CHL,0),U ,8) ;; SET  VENDOR ST ATUS ;DEV0 07991 10/0 8/2010 JAK
  15925   "RTN","CHG VQ529",148 ,0)
  15926    .I CHSTAT ="" S CHST AT=0
  15927   "RTN","CHG VQ529",149 ,0)
  15928    .; Begin  Defect 693 971
  15929   "RTN","CHG VQ529",150 ,0)
  15930    .;S CHXAC T=$S(CHSTA T=0:"Y",CH STAT=1:"N" ,1:0)
  15931   "RTN","CHG VQ529",151 ,0)
  15932    .;I CHSTA T'=0 Q
  15933   "RTN","CHG VQ529",152 ,0)
  15934    .I $G(CHX ACT)'="Y", CHSTAT'=0  Q
  15935   "RTN","CHG VQ529",153 ,0)
  15936    .I $G(CHX ACT)="Y",C HSTAT>1 Q
  15937   "RTN","CHG VQ529",154 ,0)
  15938    .; End De fect 69397 1
  15939   "RTN","CHG VQ529",155 ,0)
  15940    .;.K ^UTI LITY($J,"C HLUOUT","D ILIST",2,C A),^UTILIT Y($J,"CHLU OUT","DILI ST",1,CA)
  15941   "RTN","CHG VQ529",156 ,0)
  15942    .;.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
  15943   "RTN","CHG VQ529",157 ,0)
  15944    .; Begin  Defect 693 971
  15945   "RTN","CHG VQ529",158 ,0)
  15946    .;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
  15947   "RTN","CHG VQ529",159 ,0)
  15948    .;---End  Defect 693 971
  15949   "RTN","CHG VQ529",160 ,0)
  15950    .I CHXPI' ="" D CHKP I^CHGVQ370  Q:CHPIFLG =0 ;; DETE RMINE PROG RAM INDICA TOR ;DEV00 7991 10/08 /2010 JAK
  15951   "RTN","CHG VQ529",161 ,0)
  15952    .S:$D(^CH MVEN(CHL,2 )) CHTZIP= $P(^CHMVEN (CHL,2),U, 5)
  15953   "RTN","CHG VQ529",162 ,0)
  15954    .I CHXZIP '="" Q:$E( CHTZIP,1,$ L(CHXZIP)) '=CHXZIP                   ;; PR OVIDER ZIP : QUIT IF  '= PL ZIP  PROVIDED ; DEV007991  10/08/2010  JAK
  15955   "RTN","CHG VQ529",163 ,0)
  15956    .S:$D(^CH MVEN(CHL,1 )) CHTRZIP =$P(^CHMVE N(CHL,1),U ,5)
  15957   "RTN","CHG VQ529",164 ,0)
  15958    .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
  15959   "RTN","CHG VQ529",165 ,0)
  15960    .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
  15961   "RTN","CHG VQ529",166 ,0)
  15962    .I CHXPRN '="" D  Q: TMPPRID'=C HXPRN                                 ;; RE MIT NAME:  QUIT IF '=  REMIT NAM E PROVIDED  ;DEV00799 1 10/08/20 10 JAK
  15963   "RTN","CHG VQ529",167 ,0)
  15964    ..S:'$D(^ CHMVEN(CHL ,0)) ^CHMV EN(CHL,0)= ""
  15965   "RTN","CHG VQ529",168 ,0)
  15966    ..S TMPPR ID=$E($P(^ CHMVEN(CHL ,0),U,1),1 ,$L(CHXPRN ))
  15967   "RTN","CHG VQ529",169 ,0)
  15968    .F XI=1:1 :22 S CHLV AR(XI)=""
  15969   "RTN","CHG VQ529",170 ,0)
  15970    .S:'$D(^C HMVEN(CHL, 0)) ^CHMVE N(CHL,0)=" "
  15971   "RTN","CHG VQ529",171 ,0)
  15972    .S:'$D(^C HMVEN(CHL, 1)) ^CHMVE N(CHL,1)=" "
  15973   "RTN","CHG VQ529",172 ,0)
  15974    .S:'$D(^C HMVEN(CHL, 2)) ^CHMVE N(CHL,2)=" "
  15975   "RTN","CHG VQ529",173 ,0)
  15976    .S CHLVAR (1)=CHL
  15977   "RTN","CHG VQ529",174 ,0)
  15978    .S CHLVAR (2)=$P(^CH MVEN(CHL,0 ),U,1) ;RE MIT NAME
  15979   "RTN","CHG VQ529",175 ,0)
  15980    .S CHLVAR (3)=$P(^CH MVEN(CHL,0 ),U,3) ;TI D
  15981   "RTN","CHG VQ529",176 ,0)
  15982    .S CHLVAR (4)=$P(^CH MVEN(CHL,0 ),U,23) ;V AC
  15983   "RTN","CHG VQ529",177 ,0)
  15984    .; ;TGH -  3/1/18 CP E001-019 S et CHLVAR  items 5 th ru 9 in BI LLREMT
  15985   "RTN","CHG VQ529",178 ,0)
  15986    .D BILLRE MT(CHL,.CH LVAR)
  15987   "RTN","CHG VQ529",179 ,0)
  15988    .;S CHLVA R(5)=$P(^C HMVEN(CHL, 1),U,1) ;R EMIT ADDR  1
  15989   "RTN","CHG VQ529",180 ,0)
  15990    .;S CHLVA R(6)=$P(^C HMVEN(CHL, 1),U,2) ;R EMIT ADDR  2
  15991   "RTN","CHG VQ529",181 ,0)
  15992    .;S CHRTF AF=$P(^CHM VEN(CHL,1) ,U,18)
  15993   "RTN","CHG VQ529",182 ,0)
  15994    .;S:CHRTF AF="" CHRT FAF=0
  15995   "RTN","CHG VQ529",183 ,0)
  15996    .;I CHRTF AF=0 D
  15997   "RTN","CHG VQ529",184 ,0)
  15998    .;.S CHLV AR(7)=$P(^ CHMVEN(CHL ,1),U,3) ; REMIT CITY
  15999   "RTN","CHG VQ529",185 ,0)
  16000    .;.S CHLV AR(8)=$P(^ CHMVEN(CHL ,1),U,4) ; REMIT STAT E
  16001   "RTN","CHG VQ529",186 ,0)
  16002    .;.S CHLV AR(9)=$P(^ CHMVEN(CHL ,1),U,5) ; REMIT ZIP
  16003   "RTN","CHG VQ529",187 ,0)
  16004    .;I CHRTF AF=1 D
  16005   "RTN","CHG VQ529",188 ,0)
  16006    .;.S CHTM P=$P(^CHMV EN(CHL,1), U,17) ;REM IT COUNTRY
  16007   "RTN","CHG VQ529",189 ,0)
  16008    .;.S CHLV AR(8)=CHTM P
  16009   "RTN","CHG VQ529",190 ,0)
  16010    .S CHLVAR (10)=$P(^C HMVEN(CHL, 1),U,9) ;A USTIN VERI FY
  16011   "RTN","CHG VQ529",191 ,0)
  16012    .S CHLVAR (11)=$P(^C HMVEN(CHL, 2),U,8) ;P R NAME
  16013   "RTN","CHG VQ529",192 ,0)
  16014    .S CHLVAR (12)=$P(^C HMVEN(CHL, 2),U,1) ;P R ADDR1
  16015   "RTN","CHG VQ529",193 ,0)
  16016    .S CHLVAR (13)=$P(^C HMVEN(CHL, 2),U,2) ;P R ADDR2
  16017   "RTN","CHG VQ529",194 ,0)
  16018    .S CHPRFA F=$P(^CHMV EN(CHL,2), U,11)
  16019   "RTN","CHG VQ529",195 ,0)
  16020    .S CHPRFA F=$P(^CHMV EN(CHL,2), U,11)
  16021   "RTN","CHG VQ529",196 ,0)
  16022    .S:CHPRFA F="" CHPRF AF=0
  16023   "RTN","CHG VQ529",197 ,0)
  16024    .I CHPRFA F=0 D
  16025   "RTN","CHG VQ529",198 ,0)
  16026    ..S CHLVA R(14)=$P(^ CHMVEN(CHL ,2),U,3) ; PR CITY
  16027   "RTN","CHG VQ529",199 ,0)
  16028    ..S CHLVA R(15)=$P(^ CHMVEN(CHL ,2),U,4) ; PR STATE
  16029   "RTN","CHG VQ529",200 ,0)
  16030    ..S CHLVA R(16)=$P(^ CHMVEN(CHL ,2),U,5) ; PR ZIP
  16031   "RTN","CHG VQ529",201 ,0)
  16032    .I CHPRFA F=1 D
  16033   "RTN","CHG VQ529",202 ,0)
  16034    ..S CHTMP =$P(^CHMVE N(CHL,2),U ,10) ;PR C OUNTRY
  16035   "RTN","CHG VQ529",203 ,0)
  16036    ..S CHLVA R(15)=CHTM P
  16037   "RTN","CHG VQ529",204 ,0)
  16038    .S CHLVAR (17)=$P(^C HMVEN(CHL, 2),U,9) ;P R VERIFY
  16039   "RTN","CHG VQ529",205 ,0)
  16040    .S CHLVAR (18)=" " ; MEDICARE #
  16041   "RTN","CHG VQ529",206 ,0)
  16042    .S CHLVAR (19)="" I  $D(^CHMVEN (CHL,41))  D  ;CMAC
  16043   "RTN","CHG VQ529",207 ,0)
  16044    ..S CMACP TR=9999999 .999999
  16045   "RTN","CHG VQ529",208 ,0)
  16046    ..S CMACP TR=$O(^CHM VEN(CHL,41 ,CMACPTR), -1)
  16047   "RTN","CHG VQ529",209 ,0)
  16048    ..Q:'CMAC PTR
  16049   "RTN","CHG VQ529",210 ,0)
  16050    ..S CHLVA R(19)=$P(^ CHMVEN(CHL ,41,CMACPT R,0),U,3)
  16051   "RTN","CHG VQ529",211 ,0)
  16052    .S CHLVAR (20)=" " I  $D(^CHMVE N(CHL,80))  D  ;DRG
  16053   "RTN","CHG VQ529",212 ,0)
  16054    ..S CMACP TR=9999999 .999999
  16055   "RTN","CHG VQ529",213 ,0)
  16056    ..S CMACP TR=$O(^CHM VEN(CHL,80 ,CMACPTR), -1)
  16057   "RTN","CHG VQ529",214 ,0)
  16058    ..Q:'CMAC PTR
  16059   "RTN","CHG VQ529",215 ,0)
  16060    ..S CHTMP DT=$P(^CHM VEN(CHL,80 ,CMACPTR,0 ),U,1)
  16061   "RTN","CHG VQ529",216 ,0)
  16062    ..S CHLVA R(20)=$P(^ CHMVEN(CHL ,80,CMACPT R,0),U,2)
  16063   "RTN","CHG VQ529",217 ,0)
  16064    ..S CHLVA R(20)=CHLV AR(20)_" "
  16065   "RTN","CHG VQ529",218 ,0)
  16066    ..S CHLVA R(20)=$E(C HLVAR(20), 1,7)
  16067   "RTN","CHG VQ529",219 ,0)
  16068    ..I $E(CH LVAR(20),1 )=" " I CH TMPDT'=""  S CHLVAR(2 0)="NO "
  16069   "RTN","CHG VQ529",220 ,0)
  16070    .S CHLVAR (21)=" " I  $P(^CHMVE N(CHL,1),U ,7)'="" D   ;FACILITY  TYPE
  16071   "RTN","CHG VQ529",221 ,0)
  16072    ..S CHTMP =$P(^CHMVE N(CHL,1),U ,7)
  16073   "RTN","CHG VQ529",222 ,0)
  16074    ..S CHLVA R(21)=$P(^ CHMDIC(741 002.11,CHT MP,0),U,2)
  16075   "RTN","CHG VQ529",223 ,0)
  16076    ..S CHLVA R(21)=CHLV AR(21)_" "
  16077   "RTN","CHG VQ529",224 ,0)
  16078    ..S CHLVA R(21)=$E(C HLVAR(21), 1,20)
  16079   "RTN","CHG VQ529",225 ,0)
  16080    .S CHLVAR (22)="" ;I NTERNAL MO DIFIER
  16081   "RTN","CHG VQ529",226 ,0)
  16082    .S:$D(^CH MVEN(CHL,1 4)) CHLVAR (22)=$P(^C HMVEN(CHL, 14),U,1)
  16083   "RTN","CHG VQ529",227 ,0)
  16084    .S:$L(CHL VAR(22))=' 2 CHLVAR(2 2)=" "
  16085   "RTN","CHG VQ529",228 ,0)
  16086    .S CLLEN= CLLEN+1,LL EN=CLLEN
  16087   "RTN","CHG VQ529",229 ,0)
  16088    .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)
  16089   "RTN","CHG VQ529",230 ,0)
  16090    .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)
  16091   "RTN","CHG VQ529",231 ,0)
  16092    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
  16093   "RTN","CHG VQ529",232 ,0)
  16094    Q
  16095   "RTN","CHG VQ529",233 ,0)
  16096    ;
  16097   "RTN","CHG VQ529",234 ,0)
  16098   BILLREMT(C HL,CHLVAR)   ;TGH - 3 /1/18 CPE0 01-019 Add  logic to  use Billin g Address  if availab le.
  16099   "RTN","CHG VQ529",235 ,0)
  16100    ; Default  to "Remit  to" Addre ss if no B illing Add ress
  16101   "RTN","CHG VQ529",236 ,0)
  16102    N BILL,RE MT,REMIT,C HRTFAF
  16103   "RTN","CHG VQ529",237 ,0)
  16104    S REMT=0
  16105   "RTN","CHG VQ529",238 ,0)
  16106    ; Gather  Billing in fo.  If no  Address s et to use  Remit to A ddress
  16107   "RTN","CHG VQ529",239 ,0)
  16108    S BILL=$P ($G(^CHMVE N(CHL,4)), U,1,8)
  16109   "RTN","CHG VQ529",240 ,0)
  16110    I $P(BILL ,U,2)="" S  REMT=1
  16111   "RTN","CHG VQ529",241 ,0)
  16112    S REMIT=$ G(^CHMVEN( CHL,1))
  16113   "RTN","CHG VQ529",242 ,0)
  16114    ; Gather  Foreign Ad dress Flag
  16115   "RTN","CHG VQ529",243 ,0)
  16116    S CHRTFAF =$S('REMT: $P(BILL,U, 7),1:$P(RE MIT,U,18))   ;Foreign  Address F lag
  16117   "RTN","CHG VQ529",244 ,0)
  16118    S:CHRTFAF ="" CHRTFA F=0
  16119   "RTN","CHG VQ529",245 ,0)
  16120    ; Set dis play varia bles based  upon REMT  variable
  16121   "RTN","CHG VQ529",246 ,0)
  16122    ; Include  Billing N ame instea d of Remit -to Name
  16123   "RTN","CHG VQ529",247 ,0)
  16124    S CHLVAR( 2)=$S('REM T&($P(BILL ,U,1)'="") :$P(BILL,U ,1),1:CHLV AR(2)) ;BI LL/REMIT N AME
  16125   "RTN","CHG VQ529",248 ,0)
  16126    S CHLVAR( 5)=$S('REM T:$P(BILL, U,2),1:$P( REMIT,U,1) ) ;BILL/RE MIT ADDR 1
  16127   "RTN","CHG VQ529",249 ,0)
  16128    S CHLVAR( 6)=$S('REM T:$P(BILL, U,3),1:$P( REMIT,U,2) ) ;BILL/RE MIT ADDR 2
  16129   "RTN","CHG VQ529",250 ,0)
  16130    I CHRTFAF =0 D
  16131   "RTN","CHG VQ529",251 ,0)
  16132    .S CHLVAR (7)=$S('RE MT:$P(BILL ,U,4),1:$P (REMIT,U,3 )) ;BILL/R EMIT CITY
  16133   "RTN","CHG VQ529",252 ,0)
  16134    .S CHLVAR (8)=$S('RE MT:$P(BILL ,U,5),1:$P (REMIT,U,4 )) ;BILL/R EMIT STATE
  16135   "RTN","CHG VQ529",253 ,0)
  16136    .S CHLVAR (9)=$S('RE MT:$P(BILL ,U,6),1:$P (REMIT,U,5 )) ;BILL/R EMIT ZIP
  16137   "RTN","CHG VQ529",254 ,0)
  16138    I CHRTFAF =1 D
  16139   "RTN","CHG VQ529",255 ,0)
  16140    .S CHLVAR (8)=$S('RE MT:$P(BILL ,U,7),1:$P (REMIT,U,1 7)) ;BILL/ REMIT COUN TRY
  16141   "RTN","CHG VQ529",256 ,0)
  16142    Q
  16143   "RTN","CHG VQ600")
  16144   0^39^B5007 7321
  16145   "RTN","CHG VQ600",1,0 )
  16146   CHGVQ600 ; CVA/BDB/NC D; INACTIV ATE DUPLIC ATE VENDOR  RECORDS ; 01/19/18   2:49 PM
  16147   "RTN","CHG VQ600",2,0 )
  16148    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  16149   "RTN","CHG VQ600",3,0 )
  16150    ;CPE001-0 10,011,012 ,013 - BDB ,NCD,OW 01 /19/18
  16151   "RTN","CHG VQ600",4,0 )
  16152    ;
  16153   "RTN","CHG VQ600",5,0 )
  16154    Q
  16155   "RTN","CHG VQ600",6,0 )
  16156    ;
  16157   "RTN","CHG VQ600",7,0 )
  16158   START ;
  16159   "RTN","CHG VQ600",8,0 )
  16160    U 0 W !!, "Duplicate  Vendor Cl eanup - Pr ocessing D ata...",!
  16161   "RTN","CHG VQ600",9,0 )
  16162    S DIR(0)= "S^P:132 C OLUMN PRIN TER;F:FS3B IG FILE"
  16163   "RTN","CHG VQ600",10, 0)
  16164    S DIR("A" )="QUEUE D UPLICATE V ENDOR CLEA N UP REPOR T TO (P/F) " D ^DIR
  16165   "RTN","CHG VQ600",11, 0)
  16166    I (X'="F" )&(X'="P")  Q
  16167   "RTN","CHG VQ600",12, 0)
  16168    S CHRPT=X
  16169   "RTN","CHG VQ600",13, 0)
  16170    I CHRPT=" F" D  Q
  16171   "RTN","CHG VQ600",14, 0)
  16172    .W !!,"A  DELIMITED  EXCEL TEXT  FILE WILL  NOW BE CR EATED."
  16173   "RTN","CHG VQ600",15, 0)
  16174    .W !,"THE  FILE NAME  IS :  DUP VENCU_"_$E (DT,4,5)_$ E(DT,6,7)_ $E(DT,2,3) _".TXT"
  16175   "RTN","CHG VQ600",16, 0)
  16176    .W !,"THI S FILE SHO ULD BE IMP ORTED TO T HE GFE FOR  EXCEL PRO CESSING."
  16177   "RTN","CHG VQ600",17, 0)
  16178    .S ZTRTN= "RUN^CHGVQ 600",ZTDES C="INACTIV ATE DUPLIC ATE VENDOR  RECORDS"
  16179   "RTN","CHG VQ600",18, 0)
  16180    .S ZTIO=" ",ZTSAVE(" CHRPT")=""  D ^%ZTLOA D
  16181   "RTN","CHG VQ600",19, 0)
  16182    I CHRPT=" P" D  Q
  16183   "RTN","CHG VQ600",20, 0)
  16184     .S %ZIS= "PQM",IOP= "Q"
  16185   "RTN","CHG VQ600",21, 0)
  16186     .D ^%ZIS
  16187   "RTN","CHG VQ600",22, 0)
  16188     .I POP Q
  16189   "RTN","CHG VQ600",23, 0)
  16190     .I IOST' ["P-" Q
  16191   "RTN","CHG VQ600",24, 0)
  16192     .I $G(IO ("Q")) D
  16193   "RTN","CHG VQ600",25, 0)
  16194     .S ZTRTN ="RUN^CHGV Q600",ZTDE SC="INACTI VATE DUPLI CATE VENDO R RECORDS"
  16195   "RTN","CHG VQ600",26, 0)
  16196     .S ZTSAV E("*")=""
  16197   "RTN","CHG VQ600",27, 0)
  16198     .D ^%ZTL OAD
  16199   "RTN","CHG VQ600",28, 0)
  16200     .D HOME^ %ZIS K IO( "Q")
  16201   "RTN","CHG VQ600",29, 0)
  16202     .W !,"IN ACTIVATE D UPLICATE V ENDOR RECO RDS REPORT  HAS BEEN  QUEUED."
  16203   "RTN","CHG VQ600",30, 0)
  16204    Q
  16205   "RTN","CHG VQ600",31, 0)
  16206    ;
  16207   "RTN","CHG VQ600",32, 0)
  16208   RUN ;
  16209   "RTN","CHG VQ600",33, 0)
  16210    N CHXTID
  16211   "RTN","CHG VQ600",34, 0)
  16212    K ^UTILIT Y($J,"REPO RT")
  16213   "RTN","CHG VQ600",35, 0)
  16214    S U="^"
  16215   "RTN","CHG VQ600",36, 0)
  16216    S CHXTID= (100000000 -1) F  S C HXTID=$O(^ CHMVEN("D" ,CHXTID))  Q:CHXTID=" "  D
  16217   "RTN","CHG VQ600",37, 0)
  16218    .N CHXZIP ,CHSTATE,C HXRZIP,CHI NIT,CHNXT, VCOMINIT,V COMNXT,IEN INIT,IENNX T
  16219   "RTN","CHG VQ600",38, 0)
  16220    .D LU2^CH GVQ529
  16221   "RTN","CHG VQ600",39, 0)
  16222    .K ^UTILI TY($J,"VLU LIST")
  16223   "RTN","CHG VQ600",40, 0)
  16224    .S CHXZIP =""
  16225   "RTN","CHG VQ600",41, 0)
  16226    .S CHSTAT E=""
  16227   "RTN","CHG VQ600",42, 0)
  16228    .S CHXRZI P=""
  16229   "RTN","CHG VQ600",43, 0)
  16230    .D ADDLIS T^CHGVQ529
  16231   "RTN","CHG VQ600",44, 0)
  16232    .S CHINIT =0 F  S CH INIT=$O(^U TILITY($J, "VLULIST", CHINIT)) Q :CHINIT=""   D
  16233   "RTN","CHG VQ600",45, 0)
  16234    ..S CHINI TD=^UTILIT Y($J,"VLUL IST",CHINI T)
  16235   "RTN","CHG VQ600",46, 0)
  16236    ..S IENIN IT=+CHINIT D Q:(($P(^ CHMVEN(IEN INIT,0),U, 8)'=0)&($P (^CHMVEN(I ENINIT,0), U,8)'=""))
  16237   "RTN","CHG VQ600",47, 0)
  16238    ..I $P(CH INITD,U,22 )="CG" Q
  16239   "RTN","CHG VQ600",48, 0)
  16240    ..N CHLVP TR,VCOM S  CHLVPTR=+$ G(^UTILITY ($J,"VLULI ST",CHINIT )) D
  16241   "RTN","CHG VQ600",49, 0)
  16242    ...S VCOM ="" S:$D(^ CHMVCOMM(C HLVPTR,101 )) VCOM="Y " D EFTCHE CK^CHGVQ37 0 S VCOMIN IT=VCOM
  16243   "RTN","CHG VQ600",50, 0)
  16244    ..S CHNXT =CHINIT F   S CHNXT=$ O(^UTILITY ($J,"VLULI ST",CHNXT) ) Q:CHNXT= ""  D
  16245   "RTN","CHG VQ600",51, 0)
  16246    ...S CHNX TD=^UTILIT Y($J,"VLUL IST",CHNXT )
  16247   "RTN","CHG VQ600",52, 0)
  16248    ...S IENN XT=+CHNXTD   Q:(($P(^ CHMVEN(IEN NXT,0),U,8 )'=0)&($P( ^CHMVEN(IE NNXT,0),U, 8)'=""))
  16249   "RTN","CHG VQ600",53, 0)
  16250    ...N CHLV PTR,VCOM S  CHLVPTR=+ $G(^UTILIT Y($J,"VLUL IST",CHNXT )) D
  16251   "RTN","CHG VQ600",54, 0)
  16252    ....S VCO M="" S:$D( ^CHMVCOMM( CHLVPTR,10 1)) VCOM=" Y" D EFTCH ECK^CHGVQ3 70 S VCOMN XT=VCOM
  16253   "RTN","CHG VQ600",55, 0)
  16254    ...I $P(C HINITD,U,2 )'=$P(CHNX TD,U,2) Q   ;Remit to  Name
  16255   "RTN","CHG VQ600",56, 0)
  16256    ...I $P(C HINITD,U,3 ,4)'=$P(CH NXTD,U,3,4 ) Q
  16257   "RTN","CHG VQ600",57, 0)
  16258    ...I $P(C HINITD,U,5 )'=$P(CHNX TD,U,5) Q   ;Remit to  Address 1
  16259   "RTN","CHG VQ600",58, 0)
  16260    ...I $P(C HINITD,U,6 )'=$P(CHNX TD,U,6) Q   ;Remit to  Address 2
  16261   "RTN","CHG VQ600",59, 0)
  16262    ...I $P(C HINITD,U,7 )'=$P(CHNX TD,U,7) Q   ;Remit to  Address C ity
  16263   "RTN","CHG VQ600",60, 0)
  16264    ...I $P(C HINITD,U,8 )'=$P(CHNX TD,U,8) Q   ;Remit to  Address S tate
  16265   "RTN","CHG VQ600",61, 0)
  16266    ...I $P(C HINITD,U,9 )'=$P(CHNX TD,U,9) Q   ;Remit to  Address Z IP
  16267   "RTN","CHG VQ600",62, 0)
  16268    ...I $P(C HINITD,U,2 1)'=$P(CHN XTD,U,21)  Q  ;FAC Ty pe (Facili ty Type) 
  16269   "RTN","CHG VQ600",63, 0)
  16270    ...I $P(C HINITD,U,2 0)'=$P(CHN XTD,U,20)  Q  ;DRG (D iagnostic  Related Gr oup) 
  16271   "RTN","CHG VQ600",64, 0)
  16272    ...I $P(C HINITD,U,1 9)'=$P(CHN XTD,U,19)  Q  ;CMAC ( CHAMPVA Ma ximum Allo wable Calc ulation)
  16273   "RTN","CHG VQ600",65, 0)
  16274    ...I VCOM INIT'=VCOM NXT Q  ;VC OM (Vendor  Comments)
  16275   "RTN","CHG VQ600",66, 0)
  16276    ...I $P(C HNXTD,U,22 )="CG" Q   ;CG in the  modifier
  16277   "RTN","CHG VQ600",67, 0)
  16278    ...D
  16279   "RTN","CHG VQ600",68, 0)
  16280    ....S CHM VNIEN=+^UT ILITY($J," VLULIST",C HNXT)
  16281   "RTN","CHG VQ600",69, 0)
  16282    ....Q:'$D (^CHMVEN(C HMVNIEN,0) )
  16283   "RTN","CHG VQ600",70, 0)
  16284    ....S $P( ^CHMVEN(CH MVNIEN,0), U,8)=1
  16285   "RTN","CHG VQ600",71, 0)
  16286    ....S ^CH MVEN(CHMVN IEN,8)=DT
  16287   "RTN","CHG VQ600",72, 0)
  16288    ....I $G( DUZ)>1,$D( ^VA(200,DU Z)) S $P(^ CHMVEN(CHM VNIEN,8),U ,2)=DUZ
  16289   "RTN","CHG VQ600",73, 0)
  16290    ....S ^UT ILITY($J," REPORT",CH MVNIEN)=CH NXTD_"^"_$ G(VCOMNXT) _"^"_DT I  $G(DUZ)>1, $D(^VA(200 ,DUZ)) D
  16291   "RTN","CHG VQ600",74, 0)
  16292    .....S ^U TILITY($J, "REPORT",C HMVNIEN)=^ UTILITY($J ,"REPORT", CHMVNIEN)_ "^"_$G(DUZ )
  16293   "RTN","CHG VQ600",75, 0)
  16294    I CHRPT=" F" D REPOR TF
  16295   "RTN","CHG VQ600",76, 0)
  16296    I CHRPT=" P" D REPOR TP
  16297   "RTN","CHG VQ600",77, 0)
  16298    D MSG
  16299   "RTN","CHG VQ600",78, 0)
  16300    Q
  16301   "RTN","CHG VQ600",79, 0)
  16302    ;
  16303   "RTN","CHG VQ600",80, 0)
  16304   REPORTF ;  create del imited tex t file for  excel imp ort
  16305   "RTN","CHG VQ600",81, 0)
  16306    N FILENM, FIO,UCI,LA BEL,CHDUP, CHDUPDT,CH STRN
  16307   "RTN","CHG VQ600",82, 0)
  16308    S T=$C(9)
  16309   "RTN","CHG VQ600",83, 0)
  16310    X ^%ZOSF( "UCI") S U CI=$P(Y,", ",1)
  16311   "RTN","CHG VQ600",84, 0)
  16312    S FILENM= "DUPVENCU_ "_$E(DT,4, 5)_$E(DT,6 ,7)_$E(DT, 2,3)_".TXT "
  16313   "RTN","CHG VQ600",85, 0)
  16314    S FIO="HA C_HFS$:[SC R.TEMP_FIL ES]"_FILEN M
  16315   "RTN","CHG VQ600",86, 0)
  16316    I UCI'="H AC" S FIO= "HAC_HFS$: [DSMMANAG. CHAMPVA]"_ FILENM
  16317   "RTN","CHG VQ600",87, 0)
  16318    X "D $SYS TEM.Proces s.SetZEOF( 1)"
  16319   "RTN","CHG VQ600",88, 0)
  16320    I '$$OPEN FIWR^CHTFL IB9(.FIO," FIO") X "D  $SYSTEM.P rocess.Set ZEOF(0)" Q
  16321   "RTN","CHG VQ600",89, 0)
  16322    U FIO W " DUPLICATE  VENDOR CLE ANUP REPOR T",!
  16323   "RTN","CHG VQ600",90, 0)
  16324    U FIO W $ E(DT,4,5)_ "/"_$E(DT, 6,7)_"/"_" 20"_$E(DT, 2,3),!
  16325   "RTN","CHG VQ600",91, 0)
  16326    U FIO W "  "_T_"INAC TIVATED VE NDOR INFOR MATION"_T_ " PHYSICAL  LOCATION" ,!
  16327   "RTN","CHG VQ600",92, 0)
  16328    S LABEL=" ACTIVE VEN DOR TIN"_T _"INACTIVA TED VENDOR  NAME"_T
  16329   "RTN","CHG VQ600",93, 0)
  16330    S LABEL=L ABEL_"DATE  INACTIVE" _T_"DUZ"_T _"ADDR LIN E 1"_T
  16331   "RTN","CHG VQ600",94, 0)
  16332    S LABEL=L ABEL_"ADDR  LINE 2"_T _"CITY"_T_ "ST"_T_"ZI P"_T
  16333   "RTN","CHG VQ600",95, 0)
  16334    S LABEL=L ABEL_"FACT YPE"_T_"DR G"_T_"CMAC "_T_"VCOM"
  16335   "RTN","CHG VQ600",96, 0)
  16336    U FIO W L ABEL,!
  16337   "RTN","CHG VQ600",97, 0)
  16338    S CHDUP=0  F  S CHDU P=$O(^UTIL ITY($J,"RE PORT",CHDU P)) Q:CHDU P=""  D
  16339   "RTN","CHG VQ600",98, 0)
  16340    .S CHDUPD T=^UTILITY ($J,"REPOR T",CHDUP)
  16341   "RTN","CHG VQ600",99, 0)
  16342    .S CHSTRN =$E($P(CHD UPDT,U,3)_ $S($P(CHDU PDT,U,4)?1 N.N:"-"_$P (CHDUPDT,U ,4),1:""), 1,17)_T_$E ($P(CHDUPD T,U,11),1, 23)_T
  16343   "RTN","CHG VQ600",100 ,0)
  16344    .S CHSTRN =CHSTRN_$E ($E($P(CHD UPDT,U,24) ,4,5)_"/"_ $E($P(CHDU PDT,U,24), 6,7)_"/"_$ E($P(CHDUP DT,U,24),2 ,3),1,13)_ T
  16345   "RTN","CHG VQ600",101 ,0)
  16346    .S CHSTRN =CHSTRN_$P (CHDUPDT,U ,25)_T_$E( $P(CHDUPDT ,U,12),1,1 1)_T_" "_T _$E($P(CHD UPDT,U,14) ,1,6)_T_$E ($S($P(CHD UPDT,U,15) :$P(^DIC(5 ,$P(CHDUPD T,U,15),0) ,"^",2),1: ""),1,2)_T
  16347   "RTN","CHG VQ600",102 ,0)
  16348    .S CHSTRN =CHSTRN_$E ($P(CHDUPD T,U,16),1, 5)_$S($L($ P(CHDUPDT, U,16))>5:" -"_$E($P(C HDUPDT,U,1 6),6,9),1: "")
  16349   "RTN","CHG VQ600",103 ,0)
  16350    .S CHSTRN =CHSTRN_T_ $E($P(CHDU PDT,U,21), 1,7)_T_$E( $P(CHDUPDT ,U,20),1,5 )_T_$E($P( CHDUPDT,U, 19),1,4)_T _$E($P(CHD UPDT,U,23) ,1,3)
  16351   "RTN","CHG VQ600",104 ,0)
  16352    .W CHSTRN ,!
  16353   "RTN","CHG VQ600",105 ,0)
  16354    D CLOSEF^ CHTFLIB9(F IO,"FIO")
  16355   "RTN","CHG VQ600",106 ,0)
  16356    X "D $SYS TEM.Proces s.SetZEOF( 0)"
  16357   "RTN","CHG VQ600",107 ,0)
  16358    D FTPFILE ^CHTFLIB9( FIO," DNS . URL             ","/FS3BIG ","PUT")
  16359   "RTN","CHG VQ600",108 ,0)
  16360    Q
  16361   "RTN","CHG VQ600",109 ,0)
  16362    ;
  16363   "RTN","CHG VQ600",110 ,0)
  16364   REPORTP ;s end report  to printe r
  16365   "RTN","CHG VQ600",111 ,0)
  16366    S T=" "
  16367   "RTN","CHG VQ600",112 ,0)
  16368    S FIO=IO
  16369   "RTN","CHG VQ600",113 ,0)
  16370    O FIO
  16371   "RTN","CHG VQ600",114 ,0)
  16372    U FIO W " DUPLICATE  VENDOR CLE ANUP REPOR T",!
  16373   "RTN","CHG VQ600",115 ,0)
  16374    U FIO W $ E(DT,4,5)_ "/"_$E(DT, 6,7)_"/"_" 20"_$E(DT, 2,3),!
  16375   "RTN","CHG VQ600",116 ,0)
  16376    U FIO W "  "_T_"INAC TIVATED VE NDOR INFOR MATION"_T_ " PHYSICAL  LOCATION" ,!
  16377   "RTN","CHG VQ600",117 ,0)
  16378    S LABEL=" ACTIVE VEN DOR TIN"_T _"INACTIVA TED VENDOR  NAME"_T
  16379   "RTN","CHG VQ600",118 ,0)
  16380    S LABEL=L ABEL_"DATE  INACTIVE" _T_"DUZ    "_T_"ADDR  LINE 1"_T
  16381   "RTN","CHG VQ600",119 ,0)
  16382    S LABEL=L ABEL_"ADDR  LINE 2"_T _"CITY  "_ T_"ST"_T_" ZIP        "_T
  16383   "RTN","CHG VQ600",120 ,0)
  16384    S LABEL=L ABEL_"FACT YPE"_T_"DR G  "_T_"CM AC"_T_"VCO M"
  16385   "RTN","CHG VQ600",121 ,0)
  16386    U FIO W L ABEL,!
  16387   "RTN","CHG VQ600",122 ,0)
  16388    S CHDUP=0  F  S CHDU P=$O(^UTIL ITY($J,"RE PORT",CHDU P)) Q:CHDU P=""  D
  16389   "RTN","CHG VQ600",123 ,0)
  16390    .S CHDUPD T=^UTILITY ($J,"REPOR T",CHDUP)
  16391   "RTN","CHG VQ600",124 ,0)
  16392    .S CHSTRN =$E($P(CHD UPDT,U,3)_ $S($P(CHDU PDT,U,4)?1 N.N:"-"_$P (CHDUPDT,U ,4),1:"")_ "           ",1,17)_T _$E($P(CHD UPDT,U,11) _"                ",1 ,23)_T
  16393   "RTN","CHG VQ600",125 ,0)
  16394    .S CHSTRN =CHSTRN_$E ($E($P(CHD UPDT,U,24) ,4,5)_"/"_ $E($P(CHDU PDT,U,24), 6,7)_"/"_$ E($P(CHDUP DT,U,24),2 ,3)_"       ",1,13)_T
  16395   "RTN","CHG VQ600",126 ,0)
  16396    .S CHSTRN =CHSTRN_$P (CHDUPDT,U ,25)_T_$E( $P(CHDUPDT ,U,12)_"            " ,1,11)_T_"             "_T_$E($P (CHDUPDT,U ,14)_"       ",1,6)_T _$E($S($P( CHDUPDT,U, 15):$P(^DI C(5,$P(CHD UPDT,U,15) ,0),"^",2) ,1:"")_"      ",1,2)_ T
  16397   "RTN","CHG VQ600",127 ,0)
  16398    .S CHSTRN =CHSTRN_$E ($P(CHDUPD T,U,16),1, 5)_$S($L($ P(CHDUPDT, U,16))>5:" -"_$E($P(C HDUPDT,U,1 6),6,9),1: "     ")
  16399   "RTN","CHG VQ600",128 ,0)
  16400    .S CHSTRN =CHSTRN_T_ $E($P(CHDU PDT,U,21), 1,7)_T_$E( $P(CHDUPDT ,U,20)_"      ",1,5)_ T_$E($P(CH DUPDT,U,19 )_"    ",1 ,4)_T_$E($ P(CHDUPDT, U,23),1,3)
  16401   "RTN","CHG VQ600",129 ,0)
  16402    .W CHSTRN ,!
  16403   "RTN","CHG VQ600",130 ,0)
  16404    C FIO
  16405   "RTN","CHG VQ600",131 ,0)
  16406    Q
  16407   "RTN","CHG VQ600",132 ,0)
  16408    ;
  16409   "RTN","CHG VQ600",133 ,0)
  16410   BACKOUT ;b ackout the  duplicate  vendor in activation s
  16411   "RTN","CHG VQ600",134 ,0)
  16412    N CHMVN
  16413   "RTN","CHG VQ600",135 ,0)
  16414    U 0 W !!, "Backout o f Duplicat e Vendors  - Processi ng Data... ",!
  16415   "RTN","CHG VQ600",136 ,0)
  16416    S U="^"
  16417   "RTN","CHG VQ600",137 ,0)
  16418    S CHMVN=8  F  S CHMV N=$O(^CHMV EN(CHMVN))  Q:'CHMVN   D
  16419   "RTN","CHG VQ600",138 ,0)
  16420    .I $D(^CH MVEN(CHMVN ,8)),(+^CH MVEN(CHMVN ,8)) S $P( ^CHMVEN(CH MVN,0),U,8 )=0 K ^CHM VEN(CHMVN, 8)
  16421   "RTN","CHG VQ600",139 ,0)
  16422    Q
  16423   "RTN","CHG VQ600",140 ,0)
  16424    ;
  16425   "RTN","CHG VQ600",141 ,0)
  16426   MSG ;MESSA GE THAT IN ACTIVATE D UPLICATE V ENDOR RECO RDS IS COM PLETE
  16427   "RTN","CHG VQ600",142 ,0)
  16428    S CNT=1,^ TMP($J,"IN ACTIVATE_D UPS",CNT)= "",CNT=CNT +1
  16429   "RTN","CHG VQ600",143 ,0)
  16430    S ^TMP($J ,"INACTIVA TE_DUPS",C NT)="Inact ivation of  duplicate  vendor re cord compl ete."
  16431   "RTN","CHG VQ600",144 ,0)
  16432    S XMTEXT= "^TMP($J," "INACTIVAT E_DUPS"","
  16433   "RTN","CHG VQ600",145 ,0)
  16434    S XMDUZ=. 5 I $D(DUZ ),$D(^VA(2 00,DUZ)) S  XMDUZ=DUZ
  16435   "RTN","CHG VQ600",146 ,0)
  16436    I $D(DUZ) ,$D(^VA(20 0,DUZ)) S  XMY(DUZ)=" "
  16437   "RTN","CHG VQ600",147 ,0)
  16438    S XMSUB=" INACTIVATE  DUPLICATE  VENDOR RE CORDS COMP LETED" D ^ XMD
  16439   "RTN","CHG VQ600",148 ,0)
  16440    Q
  16441   "RTN","CHG VQ600",149 ,0)
  16442    ;
  16443   "RTN","CHI CDAA")
  16444   0^40^B2179 5998
  16445   "RTN","CHI CDAA",1,0)
  16446   CHICDAA ;; lg/Harris; Auto-Adjud ication
  16447   "RTN","CHI CDAA",2,0)
  16448    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  16449   "RTN","CHI CDAA",3,0)
  16450    ;;V1.0
  16451   "RTN","CHI CDAA",4,0)
  16452    ;;
  16453   "RTN","CHI CDAA",5,0)
  16454    ;; commen ted out se ction of c ode that m odifies In stitutiona l claims T OS -lg 5/5 /14
  16455   "RTN","CHI CDAA",6,0)
  16456    ;; remove d ZW CHMFR S near end  of routin e that pri nted claim  array to  screen. -l g 5/21/14
  16457   "RTN","CHI CDAA",7,0)
  16458    ;; BUG #2 0 call tak en from MA IN^CHMFA14 0 -lg 7/13 /14
  16459   "RTN","CHI CDAA",8,0)
  16460    ; CCSE CP E005-009 G EF 5/2/17  - add orig inal PDI c harge line s if frequ ency code  = 5
  16461   "RTN","CHI CDAA",9,0)
  16462   AAF ; star t of auto- adjudicati on logic
  16463   "RTN","CHI CDAA",10,0 )
  16464    ; PDI mus t be defin ed to proc eed
  16465   "RTN","CHI CDAA",11,0 )
  16466       Q:'$G( PDI)
  16467   "RTN","CHI CDAA",12,0 )
  16468    I '$G(DUZ ) S DUZ=99 44 ; USER, EDI
  16469   "RTN","CHI CDAA",13,0 )
  16470    I '$D(DUZ (0)) S DUZ (0)=$P(^VA (200,DUZ,0 ),"^",4) ;  FileMan a ccess code
  16471   "RTN","CHI CDAA",14,0 )
  16472    D HOME^%Z IS
  16473   "RTN","CHI CDAA",15,0 )
  16474    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",5)=PD I ;require d (last im age collec tion PDI)
  16475   "RTN","CHI CDAA",16,0 )
  16476    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=2   ;require d 2 signif ies 'CHV E DI/OCR' (c urrent pro cessing ty pe)
  16477   "RTN","CHI CDAA",17,0 )
  16478    ;
  16479   "RTN","CHI CDAA",18,0 )
  16480    ; from OC R^CHMFADR4
  16481   "RTN","CHI CDAA",19,0 )
  16482    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  16483   "RTN","CHI CDAA",20,0 )
  16484    ; clear s ome data t hat can po tentially  come from  the previo us claim
  16485   "RTN","CHI CDAA",21,0 )
  16486    ; yg UFT- 04 cross-P DI contami nation, cl ear data f rom previo us PDI
  16487   "RTN","CHI CDAA",22,0 )
  16488    K CHEQP,C HPHPAY,CHO PRX
  16489   "RTN","CHI CDAA",23,0 )
  16490       K CHTO BIL,CHHOLD ,CHHOLDPY, DDTOTAL,TO TSUM,CHSUM ,FL
  16491   "RTN","CHI CDAA",24,0 )
  16492    ;
  16493   "RTN","CHI CDAA",25,0 )
  16494    S CHMFPDI =""
  16495   "RTN","CHI CDAA",26,0 )
  16496    D LSTPDI^ CHMFADR1 ;  Move the  value of L STPDI to C HMFPDI als o removes  PDI from ^ CHMIMG que ue cross r eferences
  16497   "RTN","CHI CDAA",27,0 )
  16498    ;
  16499   "RTN","CHI CDAA",28,0 )
  16500    S ZZPDI=C HMFPDI
  16501   "RTN","CHI CDAA",29,0 )
  16502    S CHDOCID =$P(^CHMIM G(CHMFPDI, "DOC"),"^" ,1)
  16503   "RTN","CHI CDAA",30,0 )
  16504    ;
  16505   "RTN","CHI CDAA",31,0 )
  16506    S CHMFPP= "SIP" ; D  ^CHMFWK01  this work  flow call  isn't nece ssary. the re already  is at lea st one of  these in ^ CHMIMG(PDI ,"WF"
  16507   "RTN","CHI CDAA",32,0 )
  16508    ; ^CHMFA0 03 makes a  call to ^ CHMFWK01 b elow. CHMF PP is requ ired for ^ CHMGWK01 s o will lea ve the abo ve setting  of varibl e.
  16509   "RTN","CHI CDAA",33,0 )
  16510    ;
  16511   "RTN","CHI CDAA",34,0 )
  16512    S $P(^CHM IMG(CHMFPD I,0),"^",1 7)=4  ; ^D D(741000.2 ,10,0)="TY PE OF PDI  PROCESSING ^S^1:IMAGE  ONLY (IO) ;2:MAN SCA NNED (MS); 3:MAN MANU AL (MM);4: EDI MANUAL  (EDI);^0; 17^Q"
  16513   "RTN","CHI CDAA",35,0 )
  16514    S $P(^CHM IMAGE(CHMF PDI,0),"^" ,8)=1 ; ^D D(741000.1 ,10,0)="TY PE OF PROC ESSING^S^1 :IMAGE ONL Y (IO);2:M AN SCANNED  (MS);3:MA N MANUAL ( MM);4:EDI  MANUAL (ED I);^0;8^Q"
  16515   "RTN","CHI CDAA",36,0 )
  16516    ;
  16517   "RTN","CHI CDAA",37,0 )
  16518    ; this ne xt section  is the gu ts of the  operation  and a work -in-progre ss
  16519   "RTN","CHI CDAA",38,0 )
  16520   B D GETDAT A^CHMFA008  ; this ca ll sets CH MFIMTY. CH MFIMTY=1 r epresents  Image Type  1:BILL/IN VOICE refe rence CHMF A101C for  additional  defs
  16521   "RTN","CHI CDAA",39,0 )
  16522    D ^CHMFA0 03         ; SETTING  OF PDI IMA GE GLOBAL
  16523   "RTN","CHI CDAA",40,0 )
  16524    S PC=1 D  BENERTN^CH MFA007 ; I P SET PROG RAM INDICA TOR
  16525   "RTN","CHI CDAA",41,0 )
  16526    ;
  16527   "RTN","CHI CDAA",42,0 )
  16528    I $D(^CHM IMG(CHMFPD I,"TRACK") ) S DFN=$P (^("TRACK" ),"^",1),B FN=$P(^("T RACK"),"^" ,2)
  16529   "RTN","CHI CDAA",43,0 )
  16530   B1 I $G(DF N),$G(BFN)  D  ;
  16531   "RTN","CHI CDAA",44,0 )
  16532    . D BEND^ CHICDAA1   ; gets BEN E data and  sets "BEN -II" node  in ^CHMIMA GE
  16533   "RTN","CHI CDAA",45,0 )
  16534    . D BUPDT ^CHMFA020  ; CHANGE T HE NODES I N ^CHMIMAG E GLOBAL T O SHOW CUR RENT SELEC TED BENE
  16535   "RTN","CHI CDAA",46,0 )
  16536    . Q
  16537   "RTN","CHI CDAA",47,0 )
  16538    ;
  16539   "RTN","CHI CDAA",48,0 )
  16540    D ^CHMFA0 06         ; DETERMIN E TYPE OF  CLAIM INDI CATOR
  16541   "RTN","CHI CDAA",49,0 )
  16542    ;
  16543   "RTN","CHI CDAA",50,0 )
  16544    S CHPDIPR L=$$PDITYP ^CHMFAUT1( CHMFPDI)
  16545   "RTN","CHI CDAA",51,0 )
  16546   B2 D CVFN1 ^CHICDAA1  ; CHECKS E XISTANCE O F VENDOR I D
  16547   "RTN","CHI CDAA",52,0 )
  16548    D SET^CHI CDAA1
  16549   "RTN","CHI CDAA",53,0 )
  16550    ;
  16551   "RTN","CHI CDAA",54,0 )
  16552   B3 ; *STAR T BUG #20  fix* -lg 7 /13/14
  16553   "RTN","CHI CDAA",55,0 )
  16554    I '$G(CHM FSRVC) S C HMFSRVC=CH MFSERV
  16555   "RTN","CHI CDAA",56,0 )
  16556    I CHPDIPR L=1 D         ;JEH 2/ 1/11 DEV00 7820
  16557   "RTN","CHI CDAA",57,0 )
  16558       .;CCSE  CPE005-00 9 GEF 5/2/ 17 - add o riginal PD I charge l ines if ty pe of bill  = 135/fre q code=5
  16559   "RTN","CHI CDAA",58,0 )
  16560       .; set  this flag  so that C HMFAUT1 kn ows this i s the AA r outine and  not a bil l/invoice  screen
  16561   "RTN","CHI CDAA",59,0 )
  16562       .; thi s will ski p the addi tion of th e original  PDI charg e lines wh en called  from CHICD AA
  16563   "RTN","CHI CDAA",60,0 )
  16564       .N CHF LG S CHFLG ="AA"
  16565   "RTN","CHI CDAA",61,0 )
  16566    .D:CHMFSR VC=2 PREOU T^CHMFAUT1    ;OUTPAT IENT
  16567   "RTN","CHI CDAA",62,0 )
  16568    .D:CHMFSR VC=4 PREDM E^CHMFAUT1    ;DME
  16569   "RTN","CHI CDAA",63,0 )
  16570    .D:CHMFSR VC=5 PREDN T^CHMFAUT1    ;DENTAL
  16571   "RTN","CHI CDAA",64,0 )
  16572    .D:CHMFSR VC=6 PRETR V^CHMFAUT1    ;TRAVEL
  16573   "RTN","CHI CDAA",65,0 )
  16574    D KILSTF^ CHMFA140(C HMFSRVC) ;  BUG #20 " ASSOCIATED  LINE ITEM " not corr ect in ^CH MIMAGE(PDI  global -  call taken  from MAIN ^CHMFA140  -lg 7/13/1 4
  16575   "RTN","CHI CDAA",66,0 )
  16576    ; *END BU G #20 CHAN GES* -lg 7 /13/14
  16577   "RTN","CHI CDAA",67,0 )
  16578    ;
  16579   "RTN","CHI CDAA",68,0 )
  16580    ; from CH ECK^CHMFAD RV
  16581   "RTN","CHI CDAA",69,0 )
  16582    D CMPLT^C HMFIMG
  16583   "RTN","CHI CDAA",70,0 )
  16584    S CHMFPP= "CIP"
  16585   "RTN","CHI CDAA",71,0 )
  16586    D ^CHMFWK 01 ; this  call updat es ^CHMIMG  work flow  nodes "WF "
  16587   "RTN","CHI CDAA",72,0 )
  16588    D KLOCK^C HMFADR1
  16589   "RTN","CHI CDAA",73,0 )
  16590    D DELST1^ CHMFADR1
  16591   "RTN","CHI CDAA",74,0 )
  16592    S CHMFPP= "SST"
  16593   "RTN","CHI CDAA",75,0 )
  16594    D ^CHMFWK 01 ; this  call updat es ^CHMIMG  work flow  nodes "WF "
  16595   "RTN","CHI CDAA",76,0 )
  16596    ;
  16597   "RTN","CHI CDAA",77,0 )
  16598   B4 D ^CHMF SRT  ;SEND S CLAIMS T O CLAIM SO RT
  16599   "RTN","CHI CDAA",78,0 )
  16600    ;
  16601   "RTN","CHI CDAA",79,0 )
  16602    ; next 3  lines belo w taken fr om above l ogic in CH ECK^CHMFAD RV
  16603   "RTN","CHI CDAA",80,0 )
  16604    S CHMQNAM ="OCR(",CH MOUT=1,IPS UB="OCR^CH MFADR4"
  16605   "RTN","CHI CDAA",81,0 )
  16606    K CHMIN
  16607   "RTN","CHI CDAA",82,0 )
  16608   B5 D ^CHMI S041 ; CHM IS041 ;JEA /DEN;CHAMP VA QUEUE U PDATES TO  IN/OUT; ** *
  16609   "RTN","CHI CDAA",83,0 )
  16610    ;
  16611   "RTN","CHI CDAA",84,0 )
  16612    S CHMFPP= "CST"
  16613   "RTN","CHI CDAA",85,0 )
  16614    D ^CHMFWK 01 ; this  call updat es ^CHMIMG  work flow  nodes "WF "
  16615   "RTN","CHI CDAA",86,0 )
  16616    ;
  16617   "RTN","CHI CDAA",87,0 )
  16618    ; next li ne is sett ing 'curre nt process ing type'  back to ma nual, from  CHV EDI/O CR (#2) ** * do we ne ed to do t his? ***
  16619   "RTN","CHI CDAA",88,0 )
  16620    S $P(^CHM IMAGE(CHMF PDI,0),"^" ,10)=1
  16621   "RTN","CHI CDAA",89,0 )
  16622    K CHMFCLM S,CHMFCL,C HMFREJ
  16623   "RTN","CHI CDAA",90,0 )
  16624    D SORT^CH FCDUTL ;CH FCDUTL ;CV A/JLR;CHEC K DATA UTI LITY PROGR AM - (QUEU ES for che ck data an d Bene Cal c)
  16625   "RTN","CHI CDAA",91,0 )
  16626    ;
  16627   "RTN","CHI CDAA",92,0 )
  16628    ;
  16629   "RTN","CHI CDAA",93,0 )
  16630    S VQAURLF G="" ; if  set ($D) C HFCCDRV wi ll not cal l CHMFA801  (screen s tuff)
  16631   "RTN","CHI CDAA",94,0 )
  16632    D ^CHFCDD RV   ; sor ts and que ues claim
  16633   "RTN","CHI CDAA",95,0 )
  16634    ;ZW CHMFR S ; displa ys claim n umber(s) ;  removed Z W 5/21/14  -lg
  16635   "RTN","CHI CDAA",96,0 )
  16636    ;
  16637   "RTN","CHI CDAA",97,0 )
  16638    Q
  16639   "RTN","CHM EAE5")
  16640   0^9^B66632 491
  16641   "RTN","CHM EAE5",1,0)
  16642   CHMEAE5 ;C SW/DEN;BEN E VIEW MOD ULES (SCRE EN 1);Feb  06, 2019@1 0:01:52
  16643   "RTN","CHM EAE5",2,0)
  16644    ;;1.0;CHA MPVA SYSTE M;**1,7,14 **;JULY 4,  1990;Buil d 5
  16645   "RTN","CHM EAE5",3,0)
  16646    ;CPTS 100 42 BY CAM
  16647   "RTN","CHM EAE5",4,0)
  16648    ;CPTS 162 82 BY AEB
  16649   "RTN","CHM EAE5",5,0)
  16650    ;AGEFLG -  FLAG THAT  PROVIDES  30DAYS WIN DOW TO 65T H BIRTHDAY  FOR PROJ  188
  16651   "RTN","CHM EAE5",6,0)
  16652    ;DEV01219 7-01 YJK 4 /6/11 CARE GIVER
  16653   "RTN","CHM EAE5",7,0)
  16654    ;DEV01223 8-01 YJK 7 /11/11 <UN DEFINED> M DCR 2^CHME AE5
  16655   "RTN","CHM EAE5",8,0)
  16656    ;GEF 06/0 5/2017 Ben eficiary E dit/Enter  MBI Screen  changes
  16657   "RTN","CHM EAE5",9,0)
  16658    ;JSE 09/1 4/2017 Ben eficiary D elete MBI  for Edit h istory (FT C - 923776 )
  16659   "RTN","CHM EAE5",10,0 )
  16660    ;CFS 02/0 7/2018 Def ect Ration al #653997  Fix Undef ined error .
  16661   "RTN","CHM EAE5",11,0 )
  16662    ;CFS 06/2 8/2018 Rem ove modifi cations -  Rational # 763342.
  16663   "RTN","CHM EAE5",12,0 )
  16664    S DY=2,DX =20 X XY W  @CHEEL,@C HBON,"Ente r/Edit Ben eficiary", @CHBOFF
  16665   "RTN","CHM EAE5",13,0 )
  16666    S DX=1 F  DY=3:1:18  X XY W @CH EOL
  16667   "RTN","CHM EAE5",14,0 )
  16668    S BL="                      " ; 20 SPACES
  16669   "RTN","CHM EAE5",15,0 )
  16670    S BL26="                             " ;26  SPACES
  16671   "RTN","CHM EAE5",16,0 )
  16672   STA ;
  16673   "RTN","CHM EAE5",17,0 )
  16674    S X=$P(CH CD,"^",5)
  16675   "RTN","CHM EAE5",18,0 )
  16676    I X'="" S  X=$P($P(^ DD(554801. 01,.05,0), X_":",2)," ;")
  16677   "RTN","CHM EAE5",19,0 )
  16678    E  S X="I NVALID"
  16679   "RTN","CHM EAE5",20,0 )
  16680    S DY=2,DX =45 X XY W  @CHBON,"S tatus:",@C HBOFF,"  " ,X
  16681   "RTN","CHM EAE5",21,0 )
  16682   NAME ;
  16683   "RTN","CHM EAE5",22,0 )
  16684    S X=$P($P (CHCD,"^") ,"(SN)")_"  "_$P($P(C HCD,"^")," (SN)",2)
  16685   "RTN","CHM EAE5",23,0 )
  16686    S L=$P(X, ","),F1=$T R($P($P(X, ",",2)," " )," ")
  16687   "RTN","CHM EAE5",24,0 )
  16688    ;S F2=$TR ($P($P(X," ,",2)," ", 2,99)," ")
  16689   "RTN","CHM EAE5",25,0 )
  16690    S F2=$$TR IM^CHTFLIB ($P($P(X," ,",2)," ", 2,99))  ;A EB 1-5-201 6
  16691   "RTN","CHM EAE5",26,0 )
  16692    K SPEC S  SP="" F I= 1:1:10 S S P=SP_" " S  SPEC(SP)= " "  ;AEB  1-5-2016
  16693   "RTN","CHM EAE5",27,0 )
  16694    S F2=$$RE PLACE^XLFS TR(F2,.SPE C)  ;AEB 1 -5-2016
  16695   "RTN","CHM EAE5",28,0 )
  16696    S X=F1 S: F2'="" X=X _" "_F2 S  X=X_" "_L
  16697   "RTN","CHM EAE5",29,0 )
  16698    S:$P(CHCD ,"^")["(SN )" X=X_"   (SN)"
  16699   "RTN","CHM EAE5",30,0 )
  16700    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
  16701   "RTN","CHM EAE5",31,0 )
  16702    S DY=3,DX =5 X XY W  @CHBON,"Na me:",@CHBO FF,"  ",X
  16703   "RTN","CHM EAE5",32,0 )
  16704   ADDR ;
  16705   "RTN","CHM EAE5",33,0 )
  16706    S X=$P(CH CD1,"^")
  16707   "RTN","CHM EAE5",34,0 )
  16708    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
  16709   "RTN","CHM EAE5",35,0 )
  16710    S DY=4,DX =2 X XY W  @CHBON,"Ad dress:",@C HBOFF,"  " ,X
  16711   "RTN","CHM EAE5",36,0 )
  16712   ADDR1 ;
  16713   "RTN","CHM EAE5",37,0 )
  16714    S X=$P(CH CD1,"^",2)
  16715   "RTN","CHM EAE5",38,0 )
  16716    I (EE)!(E E1) S DY=5 ,DX=12,Y=" ",$P(Y," " ,20-$L(X)) ="" X XY W  X,Y Q
  16717   "RTN","CHM EAE5",39,0 )
  16718    S DY=5,DX =12 X XY W  @CHEEL,X
  16719   "RTN","CHM EAE5",40,0 )
  16720   ADDR2 ;
  16721   "RTN","CHM EAE5",41,0 )
  16722    I $P(CHCD 1,"^",11)= 1 D  Q:(EE )!(EE1)  G  PHONE ;FO REIGN
  16723   "RTN","CHM EAE5",42,0 )
  16724    .S X=$P(C HCD1,"^",1 2)
  16725   "RTN","CHM EAE5",43,0 )
  16726    .S X1=$P( CHCD1,"^", 13),X2=""  D:X1
  16727   "RTN","CHM EAE5",44,0 )
  16728    ..Q:'$D(^ DIC(5,X1,0 ))
  16729   "RTN","CHM EAE5",45,0 )
  16730    ..S X2=$P (^DIC(5,X1 ,0),"^",1)  Q
  16731   "RTN","CHM EAE5",46,0 )
  16732    .I '$D(X2 ) S X2="", $P(CHCD1," ^",13)=""
  16733   "RTN","CHM EAE5",47,0 )
  16734    .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
  16735   "RTN","CHM EAE5",48,0 )
  16736    .Q
  16737   "RTN","CHM EAE5",49,0 )
  16738    S X=$P(CH CD1,"^",3)  ;DOMESTIC
  16739   "RTN","CHM EAE5",50,0 )
  16740    S X1=$S($ D(^DIC(5,+ $P(CHCD1," ^",4),0)): $P(^(0),"^ ",2),1:"")
  16741   "RTN","CHM EAE5",51,0 )
  16742    S X2=$P(C HCD1,"^",5 ) D
  16743   "RTN","CHM EAE5",52,0 )
  16744    .I X2?9N  S X3=$E(X2 ,1,5)_"-"_ $E(X2,6,9)  Q
  16745   "RTN","CHM EAE5",53,0 )
  16746    .S X3=X2
  16747   "RTN","CHM EAE5",54,0 )
  16748    S X4=$P(C HCD1,"^",1 3),X5="" D :X4
  16749   "RTN","CHM EAE5",55,0 )
  16750    .Q:'$D(^D IC(5,X4,0) )
  16751   "RTN","CHM EAE5",56,0 )
  16752    .S X5=$P( ^DIC(5,X4, 0),"^",1)  Q
  16753   "RTN","CHM EAE5",57,0 )
  16754    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
  16755   "RTN","CHM EAE5",58,0 )
  16756    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
  16757   "RTN","CHM EAE5",59,0 )
  16758   PHONE ;
  16759   "RTN","CHM EAE5",60,0 )
  16760    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)
  16761   "RTN","CHM EAE5",61,0 )
  16762    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
  16763   "RTN","CHM EAE5",62,0 )
  16764    S DY=8,DX =4 X XY W  @CHBON,"Ph one:",@CHB OFF,"  ",X
  16765   "RTN","CHM EAE5",63,0 )
  16766   APDT ;
  16767   "RTN","CHM EAE5",64,0 )
  16768   SSN ;
  16769   "RTN","CHM EAE5",65,0 )
  16770    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)
  16771   "RTN","CHM EAE5",66,0 )
  16772    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
  16773   "RTN","CHM EAE5",67,0 )
  16774    S DY=9,DX =6 X XY W  @CHBON,"SS N:",@CHBOF F,"  ",X
  16775   "RTN","CHM EAE5",68,0 )
  16776   REL ;
  16777   "RTN","CHM EAE5",69,0 )
  16778    S X=$P(CH CD,"^",4), Y=$P(CHCD, "^",26)
  16779   "RTN","CHM EAE5",70,0 )
  16780    ;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
  16781   "RTN","CHM EAE5",71,0 )
  16782    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
  16783   "RTN","CHM EAE5",72,0 )
  16784    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")
  16785   "RTN","CHM EAE5",73,0 )
  16786    I X'="CHI LD" S Y=""
  16787   "RTN","CHM EAE5",74,0 )
  16788    I (EE)!(E E1) S DY=1 0,DX=6 X X Y D  Q  ;W AS D  D SE X Q
  16789   "RTN","CHM EAE5",75,0 )
  16790    .I X="CHI LD" S X=X_ " ("_Y_")"
  16791   "RTN","CHM EAE5",76,0 )
  16792    .S $P(X,"  ",20-$L(X ))="" W @C HREVON,"Re l:",@CHREV OFF,"  "
  16793   "RTN","CHM EAE5",77,0 )
  16794    .W BL_"    " S DY=10 ,DX=12 X X Y W X Q
  16795   "RTN","CHM EAE5",78,0 )
  16796    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 ,")"
  16797   "RTN","CHM EAE5",79,0 )
  16798   SEX ;
  16799   "RTN","CHM EAE5",80,0 )
  16800    S X=$P(CH CD,"^",2), X=$S(X="F" :"Female", X="M":"Mal e",1:X)
  16801   "RTN","CHM EAE5",81,0 )
  16802    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
  16803   "RTN","CHM EAE5",82,0 )
  16804    S DY=10,D X=35 X XY  W @CHBON," Sex:",@CHB OFF,"  ",X
  16805   "RTN","CHM EAE5",83,0 )
  16806   DOB ;
  16807   "RTN","CHM EAE5",84,0 )
  16808    S X=$P(CH CD,"^",3)  S:X'="" X= $E(X,4,5)_ "/"_$E(X,6 ,7)_"/"_$E (X,2,3)
  16809   "RTN","CHM EAE5",85,0 )
  16810    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
  16811   "RTN","CHM EAE5",86,0 )
  16812    S DY=11,D X=6 X XY W  @CHBON,"D OB:",@CHBO FF,"  ",X
  16813   "RTN","CHM EAE5",87,0 )
  16814   DOD ;
  16815   "RTN","CHM EAE5",88,0 )
  16816    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)
  16817   "RTN","CHM EAE5",89,0 )
  16818    ;D DTPRT  S X=Y
  16819   "RTN","CHM EAE5",90,0 )
  16820    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
  16821   "RTN","CHM EAE5",91,0 )
  16822    S DY=11,D X=35 X XY  W @CHBON," DOD:",@CHB OFF,"  ",X
  16823   "RTN","CHM EAE5",92,0 )
  16824   EFF ;
  16825   "RTN","CHM EAE5",93,0 )
  16826   R1 ;
  16827   "RTN","CHM EAE5",94,0 )
  16828   MDCR ;
  16829   "RTN","CHM EAE5",95,0 )
  16830    S X=$P(CH CD,"^",3)  S:$E(X,4,7 )="0229" $ E(X,4,7)=" 0228"
  16831   "RTN","CHM EAE5",96,0 )
  16832    ;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
  16833   "RTN","CHM EAE5",97,0 )
  16834    S CHAGE=$ E(DT,1,3)- $E(X,1,3)  S:$E(X,4,7 )>$E(DT,4, 7) CHAGE=C HAGE-1
  16835   "RTN","CHM EAE5",98,0 )
  16836    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 ")
  16837   "RTN","CHM EAE5",99,0 )
  16838    ;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
  16839   "RTN","CHM EAE5",100, 0)
  16840    G MDCR2
  16841   "RTN","CHM EAE5",101, 0)
  16842   MDCR1 ;
  16843   "RTN","CHM EAE5",102, 0)
  16844    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")
  16845   "RTN","CHM EAE5",103, 0)
  16846    ;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
  16847   "RTN","CHM EAE5",104, 0)
  16848   MDCR2 ;
  16849   "RTN","CHM EAE5",105, 0)
  16850    D MDDT S  DY=12,DX=3  X XY W @C HBON,"MDca re:",@CHBO FF,"  ",X
  16851   "RTN","CHM EAE5",106, 0)
  16852   CMPUS ;
  16853   "RTN","CHM EAE5",107, 0)
  16854    S X=$S($P (CHCD,"^", 15)=0:"NO" ,$P(CHCD," ^",15)=1:" YES",1:"")
  16855   "RTN","CHM EAE5",108, 0)
  16856    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
  16857   "RTN","CHM EAE5",109, 0)
  16858    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
  16859   "RTN","CHM EAE5",110, 0)
  16860   CORRES ;
  16861   "RTN","CHM EAE5",111, 0)
  16862    S DY=14,D X=2,U="^"  X XY W @CH BON,"Alt A dd:",@CHBO FF,"  "
  16863   "RTN","CHM EAE5",112, 0)
  16864    S DY=18,D X=1 X XY W  @CHBON,"A ltPhone:", @CHBOFF,"   "
  16865   "RTN","CHM EAE5",113, 0)
  16866    G:'$D(CHC D9) CONT
  16867   "RTN","CHM EAE5",114, 0)
  16868    S DY=14,D X=12 X XY  W:$P(CHCD9 ,U,1)'=""  $P(CHCD9,U ,1)
  16869   "RTN","CHM EAE5",115, 0)
  16870    S DY=15,D X=12 X XY  W:$P(CHCD9 ,U,2)'=""  $P(CHCD9,U ,2)
  16871   "RTN","CHM EAE5",116, 0)
  16872    I $P(CHCD 9,U,9)=1 D   G CONT ; address fl ag says it  is foreig n
  16873   "RTN","CHM EAE5",117, 0)
  16874    .S DY=16, DX=12 X XY  I $P(CHCD 9,U,3)'=""  W $P(CHCD 9,U,3)
  16875   "RTN","CHM EAE5",118, 0)
  16876    .I $P(CHC D9,U,5)'=" " D
  16877   "RTN","CHM EAE5",119, 0)
  16878    ..S CCODE 9=$P(CHCD9 ,U,5) Q:CC ODE9=""
  16879   "RTN","CHM EAE5",120, 0)
  16880    ..Q:'$D(^ DIC(5,CCOD E9,0))
  16881   "RTN","CHM EAE5",121, 0)
  16882    ..S DY=17 ,DX=12 X X Y W $P(^DI C(5,CCODE9 ,0),U,1) Q
  16883   "RTN","CHM EAE5",122, 0)
  16884    .S DY=18, DX=12 X XY  W $P(CHCD 9,U,10) ;F REE TEXT P HONE NUMBE R
  16885   "RTN","CHM EAE5",123, 0)
  16886    S DY=16,D X=12 X XY
  16887   "RTN","CHM EAE5",124, 0)
  16888    I $P(CHCD 9,U,6)'=""  W $P(CHCD 9,U,6),",  "
  16889   "RTN","CHM EAE5",125, 0)
  16890    I $P(CHCD 9,U,7)'=""  D
  16891   "RTN","CHM EAE5",126, 0)
  16892    .S STCODE 9=$P(CHCD9 ,U,7)
  16893   "RTN","CHM EAE5",127, 0)
  16894    .Q:'$D(^D IC(5,STCOD E9,0))
  16895   "RTN","CHM EAE5",128, 0)
  16896    .W $P(^DI C(5,STCODE 9,0),"^",2 )," "
  16897   "RTN","CHM EAE5",129, 0)
  16898    I $P(CHCD 9,U,8)'?9N  W $P(CHCD 9,U,8) G D OMCNTR
  16899   "RTN","CHM EAE5",130, 0)
  16900    W $E($P(C HCD9,U,8), 1,5),"-",$ E($P(CHCD9 ,U,8),6,9)
  16901   "RTN","CHM EAE5",131, 0)
  16902   DOMCNTR ;
  16903   "RTN","CHM EAE5",132, 0)
  16904    ;DOMESTIC  COUNTRY P RINTED HER E
  16905   "RTN","CHM EAE5",133, 0)
  16906    I $P(CHCD 9,U,5)'=""  D  ;COUNT RY
  16907   "RTN","CHM EAE5",134, 0)
  16908    .S CCODE9 =$P(CHCD9, U,5) Q:CCO DE9=""
  16909   "RTN","CHM EAE5",135, 0)
  16910    .Q:'$D(^D IC(5,CCODE 9,0))
  16911   "RTN","CHM EAE5",136, 0)
  16912    .S DY=17, DX=12 X XY  W $P(^DIC (5,CCODE9, 0),U,1)
  16913   "RTN","CHM EAE5",137, 0)
  16914   ALTPHON ;
  16915   "RTN","CHM EAE5",138, 0)
  16916    S DY=18,D X=12,X=$P( CHCD9,U,10 ) X XY
  16917   "RTN","CHM EAE5",139, 0)
  16918    I X?10N W  "(",$E(X, 1,3),")-", $E(X,4,6), "-",$E(X,7 ,10) G CON T
  16919   "RTN","CHM EAE5",140, 0)
  16920    W X
  16921   "RTN","CHM EAE5",141, 0)
  16922   CONT S DY= 18,DX=2 X  XY
  16923   "RTN","CHM EAE5",142, 0)
  16924    Q
  16925   "RTN","CHM EAE5",143, 0)
  16926    ;
  16927   "RTN","CHM EAE5",144, 0)
  16928    ;beg new  code PER D EV004223-0 1, SKD 1-2 8-08
  16929   "RTN","CHM EAE5",145, 0)
  16930   HICN ; don 't display  the HICN  field if w e are past  the imple mentation  date
  16931   "RTN","CHM EAE5",146, 0)
  16932    ;Remove d ate checks .
  16933   "RTN","CHM EAE5",147, 0)
  16934    ;Q:DT>$P( CHMDT,"^")
  16935   "RTN","CHM EAE5",148, 0)
  16936    ;Q:DT>$P( $G(CHMDT), "^") ;Defe ct Task #6 53997 - Pr event UNDE F Error wi th a $G ar ound CHMDT  variable.
  16937   "RTN","CHM EAE5",149, 0)
  16938    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
  16939   "RTN","CHM EAE5",150, 0)
  16940    S X=$TR(X ,"abcdefgh ijklmnopqr stuvwxyz", "ABCDEFGHI JKLMNOPQRS TUVWXYZ")    ;DP; Tra nslate low er case to  upper.
  16941   "RTN","CHM EAE5",151, 0)
  16942    ; move HI CN up to l ine 5 duri ng phase-i n period
  16943   "RTN","CHM EAE5",152, 0)
  16944    I (EE)!(E E1) S DY=1 4,DX=64,Y= "" X XY W  @CHREVON," HICN:",@CH REVOFF W X ,Y Q
  16945   "RTN","CHM EAE5",153, 0)
  16946    S DY=14,D X=64 X XY  W @CHBON," HICN:",@CH BOFF,X
  16947   "RTN","CHM EAE5",154, 0)
  16948    Q
  16949   "RTN","CHM EAE5",155, 0)
  16950    ;end new  code PER D EV004223-0 1, SKD 1-2 8-08
  16951   "RTN","CHM EAE5",156, 0)
  16952   MBI ; Repl ace HICN w ith MBI
  16953   "RTN","CHM EAE5",157, 0)
  16954    ;S X=$P(C HCD,"^",40 ) S:X'?.11 AN X="??"                                                            ;JSE 09 /14/2017
  16955   "RTN","CHM EAE5",158, 0)
  16956    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
  16957   "RTN","CHM EAE5",159, 0)
  16958    S:X'?.11A N X="??"
  16959   "RTN","CHM EAE5",160, 0)
  16960    S X=$TR(X ,"abcdefgh ijklmnopqr stuvwxyz", "ABCDEFGHI JKLMNOPQRS TUVWXYZ")    ; Transl ate lower  case to up per.
  16961   "RTN","CHM EAE5",161, 0)
  16962    I (EE)!(E E1) S DY=1 6,DX=64,Y= "" X XY W  @CHREVON," MBI:",@CHR EVOFF W X, Y Q
  16963   "RTN","CHM EAE5",162, 0)
  16964    S DY=16,D X=64 X XY  W @CHBON," MBI:",@CHB OFF,X
  16965   "RTN","CHM EAE5",163, 0)
  16966    Q
  16967   "RTN","CHM EAE5",164, 0)
  16968    ;
  16969   "RTN","CHM EAE5",165, 0)
  16970   3884SD ;S  X="NONE",T SNT=0,RTN= "" I '$D(^ AHCHVA("RO -3884",DFN )) G 3884S
  16971   "RTN","CHM EAE5",166, 0)
  16972    ;S PT=0,P T=$O(^AHCH VA("RO-388 4",DFN,PT) ) I 'PT S  X="NONE" G  3884S
  16973   "RTN","CHM EAE5",167, 0)
  16974    ;S:$D(^AH CHVA(DFN,1 09,PT,0))  REC=^AHCHV A(DFN,109, PT,0),RTN= $P(REC,"^" ,4)
  16975   "RTN","CHM EAE5",168, 0)
  16976    ;S SDT=$P (REC,"^",8 ) G:$P(SDT ,".",1)'?7 N 3884S S  TSNT=$P(RE C,"^",7)
  16977   "RTN","CHM EAE5",169, 0)
  16978    ;S X=$$FM TE^XLFDT(S DT,"2D")
  16979   "RTN","CHM EAE5",170, 0)
  16980   3884S ;S D Y=15,DX=1  X XY W @CH BON,"3884  Snd:",@CHB OFF,"  ",X ,"  (",TSN T,")"
  16981   "RTN","CHM EAE5",171, 0)
  16982   3884RD ;G: RTN="" 388 4R
  16983   "RTN","CHM EAE5",172, 0)
  16984    ;S RTN=$$ FMTE^XLFDT (RTN,"2D")
  16985   "RTN","CHM EAE5",173, 0)
  16986   3884R ;S D Y=16,DX=1  X XY W @CH BON,"3884  Rcd:",@CHB OFF,"  ",R TN
  16987   "RTN","CHM EAE5",174, 0)
  16988   REA ;S (X, Z)=""
  16989   "RTN","CHM EAE5",175, 0)
  16990    ;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)
  16991   "RTN","CHM EAE5",176, 0)
  16992    ;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)
  16993   "RTN","CHM EAE5",177, 0)
  16994    ;S:X="" X =""
  16995   "RTN","CHM EAE5",178, 0)
  16996    ;S DY=17, DX=1 X XY  W @CHBON," Stat Rsn:" ,@CHBOFF,"   ",X
  16997   "RTN","CHM EAE5",179, 0)
  16998    ;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
  16999   "RTN","CHM EAE5",180, 0)
  17000    ;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
  17001   "RTN","CHM EAE5",181, 0)
  17002    ;I X="REM ARRIED WID OW" S X=$P (CHCD,"^", 8) D DTPRT  W "  (",Y  W:Y="" "N O DATE ON  FILE" W ") "
  17003   "RTN","CHM EAE5",182, 0)
  17004   STDT ;S X= "" S:$P(CH CD,U,11)'= "" X=$$FMT E^XLFDT($P (CHCD,U,11 ),"2D")
  17005   "RTN","CHM EAE5",183, 0)
  17006    ;S DY=18, DX=2 X XY  W @CHBON," Stat Dt:", @CHBOFF,"   ",X
  17007   "RTN","CHM EAE5",184, 0)
  17008   MDDT ;
  17009   "RTN","CHM EAE5",185, 0)
  17010    S (XB,XA) =""
  17011   "RTN","CHM EAE5",186, 0)
  17012    ;I X="MED  B ONLY"!( X="MED A&B ") D   ;SK D 4-9-08 D EV004223-0 1
  17013   "RTN","CHM EAE5",187, 0)
  17014    D MDDDATE ^CHMEAE6F  I 'CHMDD S  X="MED D"   ;SKD 4-9 -08 DEV004 223-01
  17015   "RTN","CHM EAE5",188, 0)
  17016    I X="MED  B ONLY"!(X ="MED A&B" )!(X="MED  D") D   ;S KD 4-9-08  DEV004223- 01
  17017   "RTN","CHM EAE5",189, 0)
  17018    .I '$D(^A HCHVA(DFN, 100,BFN,11 2)) Q
  17019   "RTN","CHM EAE5",190, 0)
  17020    .S MDBDT= 999999999
  17021   "RTN","CHM EAE5",191, 0)
  17022    .S MDBDT= $O(^AHCHVA (DFN,100,B FN,112,MDB DT),-1) Q: 'MDBDT
  17023   "RTN","CHM EAE5",192, 0)
  17024    .I '$D(^A HCHVA(DFN, 100,BFN,11 2,MDBDT))  S X="" Q
  17025   "RTN","CHM EAE5",193, 0)
  17026    .S MDBDT= $P(^AHCHVA (DFN,100,B FN,112,MDB DT,0),"^", 1)
  17027   "RTN","CHM EAE5",194, 0)
  17028    .S MN=$E( MDBDT,4,5) ,YR=$E(MDB DT,2,3)
  17029   "RTN","CHM EAE5",195, 0)
  17030    .I X="MED  B ONLY" S  X="B ONLY  "_MN_"/"_ YR Q
  17031   "RTN","CHM EAE5",196, 0)
  17032    .S XB="B  "_MN_"/"_Y R Q
  17033   "RTN","CHM EAE5",197, 0)
  17034    I X["B ON LY" Q
  17035   "RTN","CHM EAE5",198, 0)
  17036    ;I X="MED  A ONLY"!( X="MED A&B ") D    ;S KD 4-9-08  DEV004223- 01
  17037   "RTN","CHM EAE5",199, 0)
  17038    I X="MED  A ONLY"!(X ="MED A&B" )!(X="MED  D") D   ;S KD 4-9-08  DEV004223- 01
  17039   "RTN","CHM EAE5",200, 0)
  17040    .I '$D(^A HCHVA(DFN, 100,BFN,11 1)) Q
  17041   "RTN","CHM EAE5",201, 0)
  17042    .S MDADT= 999999999
  17043   "RTN","CHM EAE5",202, 0)
  17044    .S MDADT= $O(^AHCHVA (DFN,100,B FN,111,MDA DT),-1) Q: 'MDADT
  17045   "RTN","CHM EAE5",203, 0)
  17046    .I '$D(^A HCHVA(DFN, 100,BFN,11 1,MDADT))  S X="" Q
  17047   "RTN","CHM EAE5",204, 0)
  17048    .S MDADT= $P(^AHCHVA (DFN,100,B FN,111,MDA DT,0),"^", 1)
  17049   "RTN","CHM EAE5",205, 0)
  17050    .S MN=$E( MDADT,4,5) ,YR=$E(MDA DT,2,3)
  17051   "RTN","CHM EAE5",206, 0)
  17052    .I X="MED  A ONLY" S  X="A ONLY  "_MN_"/"_ YR Q
  17053   "RTN","CHM EAE5",207, 0)
  17054    .S XA="A  "_MN_"/"_Y R Q
  17055   "RTN","CHM EAE5",208, 0)
  17056    I X="MED  A&B" D
  17057   "RTN","CHM EAE5",209, 0)
  17058    .S X=XA_"   "_XB Q
  17059   "RTN","CHM EAE5",210, 0)
  17060    ;BEG SKD  4-9-08 DEV 004223-01
  17061   "RTN","CHM EAE5",211, 0)
  17062    I X="MED  D" D    ;S KD 4-9-08  DEV004223- 01
  17063   "RTN","CHM EAE5",212, 0)
  17064    .I '$D(^A HCHVA(DFN, 100,BFN,11 7)) Q
  17065   "RTN","CHM EAE5",213, 0)
  17066    .S MDDDT= 999999999
  17067   "RTN","CHM EAE5",214, 0)
  17068    .S MDDDT= $O(^AHCHVA (DFN,100,B FN,117,MDD DT),-1) Q: 'MDDDT
  17069   "RTN","CHM EAE5",215, 0)
  17070    .I '$D(^A HCHVA(DFN, 100,BFN,11 7,MDDDT))  S X="" Q
  17071   "RTN","CHM EAE5",216, 0)
  17072    .S MDDDT= $P(^AHCHVA (DFN,100,B FN,117,MDD DT,0),"^", 1)
  17073   "RTN","CHM EAE5",217, 0)
  17074    .S MN=$E( MDDDT,4,5) ,YR=$E(MDD DT,2,3)
  17075   "RTN","CHM EAE5",218, 0)
  17076    .S X=$S(X A'="":XA_"   ",1:"")_ $S(XB'="": XB_"  ",1: "")_"D "_M N_"/"_YR Q
  17077   "RTN","CHM EAE5",219, 0)
  17078    ;END SKD  4-9-08 DEV 004223-01
  17079   "RTN","CHM EAE5",220, 0)
  17080    K MDBDT,M N,YR,MDADT ,XB,XA,MDD DT
  17081   "RTN","CHM EAE5",221, 0)
  17082    Q
  17083   "RTN","CHM EAE5",222, 0)
  17084   DTPRT ;
  17085   "RTN","CHM EAE5",223, 0)
  17086    S Y="" Q: X'?7N  S Y =$E(X,1,3) +1700,%M=+ $E(X,4,5), %D=+$E(X,6 ,7)
  17087   "RTN","CHM EAE5",224, 0)
  17088    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  17089   "RTN","CHM EAE5",225, 0)
  17090    Q
  17091   "RTN","CHM EAE5",226, 0)
  17092   JAN ;
  17093   "RTN","CHM EAE5",227, 0)
  17094    ;;JAN FEB  MAR APR M AY JUN JUL  AUG SEP O CT NOV DEC
  17095   "RTN","CHM F211")
  17096   0^41^B1943 7100
  17097   "RTN","CHM F211",1,0)
  17098   CHMF211 ;H BG/DEN;CHE CK DATA E/ E CLAIM SC REEN;07/21 /94  12:55  PM
  17099   "RTN","CHM F211",2,0)
  17100    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  17101   "RTN","CHM F211",3,0)
  17102    ;CPE001-0 13 ; 05/03 /2017 ; AJ F
  17103   "RTN","CHM F211",4,0)
  17104    ;
  17105   "RTN","CHM F211",5,0)
  17106   ZSET S:'$D (DUZ) DUZ= 1,DUZ(0)=" " I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  17107   "RTN","CHM F211",6,0)
  17108    S:'$D(IOZ FO) IOZFO= "^^" S:'$D (IOZBK) IO ZBK="^" S: '$D(DTIME)  DTIME=60
  17109   "RTN","CHM F211",7,0)
  17110    ;I '$D(IO Z) S %IS=" N",IOP=$I  D ^%ZIS K  IOP S IOZ= IO,IOZL=IO SL,IOZW=IO M,IOZF=IOF ,IOZT=IOST ,IOZN=ION, IOZS=IOS
  17111   "RTN","CHM F211",8,0)
  17112   ZNAM ;
  17113   "RTN","CHM F211",9,0)
  17114   START S CH MFCLNM=0,C =1,U="^" K  ^UTILITY( "CHK",$J)
  17115   "RTN","CHM F211",10,0 )
  17116   CUTIL S CH MFCLNM=$O( CHMFCLMS(C HMFCLNM))  I CHMFCLNM ="" G:C=1  END G DISP
  17117   "RTN","CHM F211",11,0 )
  17118    S CL=CHMF CLMS(CHMFC LNM) G:'$D (^CHMPAY(C L,0)) CUTI L
  17119   "RTN","CHM F211",12,0 )
  17120    S REC=^(0 ),TY=$P(RE C,U,7),VN= $P(REC,U,3 ),DOS=$P(R EC,U,8)
  17121   "RTN","CHM F211",13,0 )
  17122    S DFN=$P( REC,U,21), BFN=$P(REC ,U,22) D T YPE,VENDOR ,DOS,BENE
  17123   "RTN","CHM F211",14,0 )
  17124    G:BFN=""  CUTIL
  17125   "RTN","CHM F211",15,0 )
  17126    S ^UTILIT Y("CHK",$J ,C,BFN,TY) =CHMFCLNM_ "^"_VN_"^" _DOS_"^"_C L,A(C)="", C=C+1
  17127   "RTN","CHM F211",16,0 )
  17128    G CUTIL
  17129   "RTN","CHM F211",17,0 )
  17130   DISP D HDR  S LN="" S  $P(LN,"-" ,54)=""
  17131   "RTN","CHM F211",18,0 )
  17132   D0 D CLEAR 2 S I="",C T=0,CT1=0  S DY=19,DX =1 X XY W  LN
  17133   "RTN","CHM F211",19,0 )
  17134    S DTM=9,D BM=18 X CH MAR S DY=9 ,DX=1 X XY
  17135   "RTN","CHM F211",20,0 )
  17136   D1 S I=$O( ^UTILITY(" CHK",$J,I) ) G:'I D4  S BFN=""
  17137   "RTN","CHM F211",21,0 )
  17138   D2 S BFN=$ O(^UTILITY ("CHK",$J, I,BFN)) G  D1:BFN=""  S TY=""
  17139   "RTN","CHM F211",22,0 )
  17140   D3 S TY=$O (^UTILITY( "CHK",$J,I ,BFN,TY))  G D2:TY=""  S REC=^(T Y),CHMFCLN M=$P(REC,U ,1) K FL S  A(I)=""
  17141   "RTN","CHM F211",23,0 )
  17142    W !,I,")" ,?5,$E(BFN ,1,10),?17 ,$E(TY,1,3 ),?22,$E($ P(REC,U,2) ,1,10),?34 ,$P(REC,U, 3)
  17143   "RTN","CHM F211",24,0 )
  17144    G D31:CHM CL(CHMFCLN M)="" S L= $L(CHMCL(C HMFCLNM)," *")
  17145   "RTN","CHM F211",25,0 )
  17146    F P=1:1:L  W:$D(FL)  ! W ?46,$P (CHMCL(CHM FCLNM),"*" ,P) S CT=C T+1,FL=1 D :CT#10=0
  17147   "RTN","CHM F211",26,0 )
  17148    .Q:$P(CHM CL(CHMFCLN M),"*",P+1 )=""  D AS K D CLEAR2  S DY=7,DX =1 X XY K  FL
  17149   "RTN","CHM F211",27,0 )
  17150    .W !,I,") ",?5,BFN,? 17,$E(TY,1 ,3),?22,$E ($P(REC,U, 2),1,10),? 34,$P(REC, U,3)
  17151   "RTN","CHM F211",28,0 )
  17152    .Q
  17153   "RTN","CHM F211",29,0 )
  17154   D31 S CT1= CT1+1 D:'( CT1#10) AS K G D3
  17155   "RTN","CHM F211",30,0 )
  17156   D4 K QFL,C HNEWPG
  17157   "RTN","CHM F211",31,0 )
  17158    D ASK2 D  ASK2:$D(DQ OUT) G:(Y= 2)!($D(DFO UT)) END G :$D(DUOUT)  D4
  17159   "RTN","CHM F211",32,0 )
  17160    I Y=3 D ^ CHMFKILL G :'$D(CHNEW PG) D4 K C HMCL G END
  17161   "RTN","CHM F211",33,0 )
  17162   D5 D EDIT  G:$D(DFOUT ) END G:$D (QFL) D4
  17163   "RTN","CHM F211",34,0 )
  17164    D ^CHMF21 0 G DISP
  17165   "RTN","CHM F211",35,0 )
  17166   END Q
  17167   "RTN","CHM F211",36,0 )
  17168   ASK D CLEA R S HY=DY, HX=DX,DY=2 0,DX=1 X X Y
  17169   "RTN","CHM F211",37,0 )
  17170    W "PRESS  RETURN TO  CONTINUE"  D SBRS D C LEAR2
  17171   "RTN","CHM F211",38,0 )
  17172    S DTM=9,D BM=18 X CH MAR S DY=9 ,DX=1 X XY  Q
  17173   "RTN","CHM F211",39,0 )
  17174   ASK2 G:$D( CHREOPN) A SK3
  17175   "RTN","CHM F211",40,0 )
  17176    D CLEAR S  DY=20,DX= 1 X XY W " Select:  1 ) Edit",!, "          2) Continu e"
  17177   "RTN","CHM F211",41,0 )
  17178    W !,"          3) Pr ocess New  Page",!!," Choose:  "
  17179   "RTN","CHM F211",42,0 )
  17180    D SBRS G: $D(DQOUT)  ASK2 Q:$D( DFOUT)!$D( DUOUT)  G: Y="" ASK2
  17181   "RTN","CHM F211",43,0 )
  17182    G:"123"'[ Y ASK2 Q
  17183   "RTN","CHM F211",44,0 )
  17184   ASK3 D CLE AR S DY=20 ,DX=1 X XY  W "Select :  1) Edit ",!,"          2) Con tinue"
  17185   "RTN","CHM F211",45,0 )
  17186    W !!,"Cho ose:  " D  SBRS G:$D( DQOUT) ASK 3 Q:$D(DFO UT)!$D(DUO UT)
  17187   "RTN","CHM F211",46,0 )
  17188    G:Y="" AS K3 G:"12"' [Y ASK3 Q
  17189   "RTN","CHM F211",47,0 )
  17190   HDR W @IOF  W @CHREVO N,@CHBON S  DY=1,DX=1  X XY
  17191   "RTN","CHM F211",48,0 )
  17192    W "                                                          "
  17193   "RTN","CHM F211",49,0 )
  17194    W !,"                [Edit Clai m Data Scr een]                "
  17195   "RTN","CHM F211",50,0 )
  17196    W !,"                                                          "
  17197   "RTN","CHM F211",51,0 )
  17198    ;AJF;CPE0 01-013
  17199   "RTN","CHM F211",52,0 )
  17200    W @CHREVO FF W @CHBO N,!!,"Orig inal PDI N umber: ",C HMOPDI 
  17201   "RTN","CHM F211",53,0 )
  17202    W @CHREVO FF W @CHBO N,!!,"Curr ent PDI Nu mber:  ",  CHMFPDI
  17203   "RTN","CHM F211",54,0 )
  17204    W !," Rel ated Claim s:",@CHBOF F
  17205   "RTN","CHM F211",55,0 )
  17206    W !!,"No. ",?8,"Bene ",?17,"Typ ",?24,"Ven dor",?36," D.O.S",?46 ,"D/C",!
  17207   "RTN","CHM F211",56,0 )
  17208    W "---",? 5,"------- ---",?17," ---",?22," ---------- ",?34,"--- ------",?4 6,"---" Q
  17209   "RTN","CHM F211",57,0 )
  17210   TYPE I '$D (^CHMDIC(7 41002.05,T Y,0)) S TY ="UNKNOWN"  Q
  17211   "RTN","CHM F211",58,0 )
  17212    S TY=$P(^ (0),U,1) Q
  17213   "RTN","CHM F211",59,0 )
  17214   VENDOR I V N="" S VN= "UNKNOWN"  Q
  17215   "RTN","CHM F211",60,0 )
  17216    I '$D(^CH MVEN(VN,0) ) S VN="UN KNOWN" Q
  17217   "RTN","CHM F211",61,0 )
  17218    S VN=$E($ P(^(0),U), 1,10) Q
  17219   "RTN","CHM F211",62,0 )
  17220   DOS Q:DOS= ""  S DOS= $E(DOS,4,5 )_"/"_$E(D OS,6,7)_"/ "_$E(DOS,2 ,3) Q
  17221   "RTN","CHM F211",63,0 )
  17222   BENE I '$D (^AHCHVA(D FN,100,BFN ,0)) S BFN ="" Q
  17223   "RTN","CHM F211",64,0 )
  17224    S BFN=$P( ^(0),U) Q
  17225   "RTN","CHM F211",65,0 )
  17226   EDIT K B,C
  17227   "RTN","CHM F211",66,0 )
  17228   E1 K B D C LEAR S DY= 20,DX=1 X  XY W "Edit : " D SBRS
  17229   "RTN","CHM F211",67,0 )
  17230    I $D(DFOU T)!$D(DUOU T) S QFL=1  Q
  17231   "RTN","CHM F211",68,0 )
  17232    S STR=Y G  E6:+STR
  17233   "RTN","CHM F211",69,0 )
  17234   E5 G E1:Y' ?1"A".E F  II=0:0 S I I=$O(A(II) ) Q:'II  S  B(II)=""
  17235   "RTN","CHM F211",70,0 )
  17236    G E10
  17237   "RTN","CHM F211",71,0 )
  17238   E6 G E1:Y[ "+",E1:Y[" =",E1:Y["  "
  17239   "RTN","CHM F211",72,0 )
  17240    F II=1:1: $L(Y,",")  S:$P(Y,"," ,II)]"" B( $P(Y,",",I I))=""
  17241   "RTN","CHM F211",73,0 )
  17242   E7 S II=$O (B(II)) G  E8:II="" I  II["-" K  B(II)
  17243   "RTN","CHM F211",74,0 )
  17244    F J=$P(II ,"-"):1:$P (II,"-",2)  S B(J)=""
  17245   "RTN","CHM F211",75,0 )
  17246    G E7
  17247   "RTN","CHM F211",76,0 )
  17248   E8 S II=0
  17249   "RTN","CHM F211",77,0 )
  17250   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
  17251   "RTN","CHM F211",78,0 )
  17252    G E9
  17253   "RTN","CHM F211",79,0 )
  17254   E10 S II=0
  17255   "RTN","CHM F211",80,0 )
  17256   E11 S II=$ O(B(II)) G :'II E15 S  BFN=""
  17257   "RTN","CHM F211",81,0 )
  17258   E12 S BFN= $O(^UTILIT Y("CHK",$J ,II,BFN))  G:BFN="" E 11 S TY=""
  17259   "RTN","CHM F211",82,0 )
  17260   E13 S TY=$ O(^UTILITY ("CHK",$J, II,BFN,TY) ) G:TY=""  E12 S REC= ^(TY)
  17261   "RTN","CHM F211",83,0 )
  17262    S CL=$P(R EC,"^"),DO S=$P(REC," ^",3),VN=$ P(REC,"^", 2),IN=$P(R EC,"^",4)
  17263   "RTN","CHM F211",84,0 )
  17264    S CHMED(C L)=IN_"^"_ BFN_"^"_VN _"^"_TY_"^ "_DOS G E1 3
  17265   "RTN","CHM F211",85,0 )
  17266   E15 I CHMC L(CL)="" D  E16 Q
  17267   "RTN","CHM F211",86,0 )
  17268    I CHMCL(C L)="NCL" D  E17 Q
  17269   "RTN","CHM F211",87,0 )
  17270    S DA=IN D  ^CHMG211  K CHMED,B, C,CHDISC S  FL2=0 Q
  17271   "RTN","CHM F211",88,0 )
  17272   E16 W *7,! !,"Claim i s complete , editing  is not all owed!!" H  3 Q
  17273   "RTN","CHM F211",89,0 )
  17274    ;
  17275   "RTN","CHM F211",90,0 )
  17276   E17 W *7,! !,"Claim f orm is mis sing, edit ing is not  allowed!! " H 3 Q
  17277   "RTN","CHM F211",91,0 )
  17278    ;
  17279   "RTN","CHM F211",92,0 )
  17280   CLEAR F DY =20:1:24 S  DX=1 X XY  W @CHEOL
  17281   "RTN","CHM F211",93,0 )
  17282    Q
  17283   "RTN","CHM F211",94,0 )
  17284   CLEAR2 F D Y=9:1:18 S  DX=1 X XY  W @CHEOL
  17285   "RTN","CHM F211",95,0 )
  17286    Q
  17287   "RTN","CHM F211",96,0 )
  17288   SBRS R Y:$ S($D(DTIME ):DTIME,1: 60)
  17289   "RTN","CHM F211",97,0 )
  17290    I '$T W * 7 R Y:5 G  SBRS:Y="."  S:'$T Y=I OZFO
  17291   "RTN","CHM F211",98,0 )
  17292   SBRS1 K DF OUT,DUOUT, DQOUT S:'$ D(IOZFO) I OZFO="^^"  S:'$D(IOZB K) IOZBK=" ^"
  17293   "RTN","CHM F211",99,0 )
  17294    I IOZFO=Y  W:$D(IOZF ) # S (DFO UT,Y)="" Q
  17295   "RTN","CHM F211",100, 0)
  17296    S:Y=IOZBK  (DUOUT,Y) ="" S:Y?1" ?".E!(Y["^ ") (DQOUT, Y)=""
  17297   "RTN","CHM F211",101, 0)
  17298    Q
  17299   "RTN","CHM F351D")
  17300   0^42^B9200 5416
  17301   "RTN","CHM F351D",1,0 )
  17302   CHMF351D ; DEH/DEN;CH AMPVA POST -PROC CLAI M REPORT C ALC;Feb 06 , 2019@10: 02:33
  17303   "RTN","CHM F351D",2,0 )
  17304    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  17305   "RTN","CHM F351D",3,0 )
  17306    ;CPT(S) -  11008*, # 12621 (RLC )
  17307   "RTN","CHM F351D",4,0 )
  17308    ;CPTS #12 531 BY DTP  (5-SEP-97 )
  17309   "RTN","CHM F351D",5,0 )
  17310    ;DEV01106 9 1/13/201 1 AEB
  17311   "RTN","CHM F351D",6,0 )
  17312    ;CR# DEV0 09373 - Mo dified rou tine to fa ctor COB P ART D  5/1 1/2011
  17313   "RTN","CHM F351D",7,0 )
  17314    ;ENC#0093 75 ADDED " CITISXC" E DITYPE AS  PART OF CI TI IMPLEME NTATION
  17315   "RTN","CHM F351D",8,0 )
  17316    ;DEV00782 0  EW 10/6 /11 ADDING  AUTO DIST RIBUTION F LAG
  17317   "RTN","CHM F351D",9,0 )
  17318    ;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.
  17319   "RTN","CHM F351D",10, 0)
  17320    ;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.
  17321   "RTN","CHM F351D",11, 0)
  17322   VIEW D RES ET K CHPDI K,FILE
  17323   "RTN","CHM F351D",12, 0)
  17324    S X1=I D  PROGTYP^CH FCD001
  17325   "RTN","CHM F351D",13, 0)
  17326    G:'$D(@(G LPAY_"I,0) ")) END S  X=@(GLPAY_ "I,0)")
  17327   "RTN","CHM F351D",14, 0)
  17328    S CHCLN=$ P(X,"^",1) ,CHCLST=$P (X,"^",2)
  17329   "RTN","CHM F351D",15, 0)
  17330    G END:'$D (^CHMDIC(7 41002.94,C HPGPT,0))  S CHPROG=$ P(^(0),"^" ,2)
  17331   "RTN","CHM F351D",16, 0)
  17332    S VFN=$P( X,"^",3),C HASOB=$P(X ,"^",5),CH TYPE=$P(X, "^",7)
  17333   "RTN","CHM F351D",17, 0)
  17334    S CHDATSE R=$P(X,"^" ,8),DFN=$P (X,"^",21) ,BFN=$P(X, "^",22)
  17335   "RTN","CHM F351D",18, 0)
  17336    S:DFN=""  DFN=-1 S:B FN="" BFN= -1
  17337   "RTN","CHM F351D",19, 0)
  17338    S CHPOS=" " ;,AUTODI ST=""
  17339   "RTN","CHM F351D",20, 0)
  17340    I $D(@(GL PAY_"I,""C OMMON"")") ) D
  17341   "RTN","CHM F351D",21, 0)
  17342    .S POS=$P (@(GLPAY_" I,""COMMON "")"),"^", 2)
  17343   "RTN","CHM F351D",22, 0)
  17344    .;S AUTOD IST=$P(@(G LPAY_"I,"" COMMON"")" ),"^",18)  ;DEV007820   EW 10/6/ 11
  17345   "RTN","CHM F351D",23, 0)
  17346    .;I $$DSL A^CHTFLIB2 (I)=0 S AU TODIST=1 ; IF PRE SLA
  17347   "RTN","CHM F351D",24, 0)
  17348    .I POS I  $D(^CHMDIC (741002.11 ,POS,0)) S  CHPOS=$E( $P(^(0),"^ ",2),1,14)
  17349   "RTN","CHM F351D",25, 0)
  17350    ; UP TO T HIS POINT  HAVE THE 0  NODE
  17351   "RTN","CHM F351D",26, 0)
  17352    ;FOLLOWIN G GET CLAI M #,DED,CO ST,OTHER I NS,TOTAL,C ALC
  17353   "RTN","CHM F351D",27, 0)
  17354    S X=""
  17355   "RTN","CHM F351D",28, 0)
  17356    S:$D(@(GL PAY_"I,1)" )) X=@(GLP AY_"I,1)")
  17357   "RTN","CHM F351D",29, 0)
  17358    S CHPR="" ,CHPR=$P(X ,"^",29)    ;SKD 11-1 -06 MC284
  17359   "RTN","CHM F351D",30, 0)
  17360    S CHCLAMT =$P(X,"^", 1),CHAMTDE D=$P(X,"^" ,5)
  17361   "RTN","CHM F351D",31, 0)
  17362    S CHCOST= $P(X,"^",6 ),CHOTHER= $P(X,"^",7 ),CHVPMT=$ P(X,"^",14 ),CHBPMT=$ P(X,"^",15 ),CHCCA=$P (X,"^",18)
  17363   "RTN","CHM F351D",32, 0)
  17364    ;GETS DED  AND CAT C AP INFO FR OM CLAIM F ORM IF PRE SENT
  17365   "RTN","CHM F351D",33, 0)
  17366    S (CHBDYT D,CHFDYTD, CHFCYTD,CH BDYTDO,CHF DYTDO,CHFC YTDO)="",( CHBDM,CHFD M,CHFCM,CH ICF)=0
  17367   "RTN","CHM F351D",34, 0)
  17368    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)
  17369   "RTN","CHM F351D",35, 0)
  17370    I (CHBDYT DO'="")!(C HBDYTD'="" )!(CHFDYTD O'="")!(CH FDYTD'="") !(CHFCYTDO '="")!(CHF CYTD'="")  S CHICF=0
  17371   "RTN","CHM F351D",36, 0)
  17372    S XCOM=""  S:$D(@(GL PAY_"I,""C OMMON"")") ) XCOM=@(G LPAY_"I,"" COMMON"")" )
  17373   "RTN","CHM F351D",37, 0)
  17374    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)
  17375   "RTN","CHM F351D",38, 0)
  17376    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
  17377   "RTN","CHM F351D",39, 0)
  17378    ;FOLLOWIN G GETS THE  PDI NUMBE RS
  17379   "RTN","CHM F351D",40, 0)
  17380    S J=0
  17381   "RTN","CHM F351D",41, 0)
  17382    F K=0:0 S  J=$O(@(GL PAY_"I,""P DI"",J)"))  Q:J'?1N.N   D
  17383   "RTN","CHM F351D",42, 0)
  17384    .Q:'$D(@( GLPAY_"I," "PDI"",J,0 )"))
  17385   "RTN","CHM F351D",43, 0)
  17386    .S ZPDI=$ P(@(GLPAY_ "I,""PDI"" ,J,0)"),"^ ",1) Q:ZPD I=""  S BA T=""
  17387   "RTN","CHM F351D",44, 0)
  17388    .I '$D(PA IDARY) D G ETPYMNT(ZP DI,.PAIDAR Y) ;CPE005 -095
  17389   "RTN","CHM F351D",45, 0)
  17390    .S BI=$O( ^CHMIMPB(" C",ZPDI,0) ) I BI'=""  S:$D(^CHM IMPB(BI,0) ) BAT=$P(^ (0),"^",1)
  17391   "RTN","CHM F351D",46, 0)
  17392    .S CHPDI( J)=ZPDI_"   Batch: "_ BAT
  17393   "RTN","CHM F351D",47, 0)
  17394    ;FOLLOWIN G GETS BEN EFICIARY &  FAMILY DE DUCT & CAT  CAP FROM  DFN FILE I F NEEDED
  17395   "RTN","CHM F351D",48, 0)
  17396    S CHDEDDT =CHDATSER
  17397   "RTN","CHM F351D",49, 0)
  17398    S:$D(@(GL PAY_"I,""I NP"")")) C HDEDDT=$P( @(GLPAY_"I ,""INP"")" ),"^",1)
  17399   "RTN","CHM F351D",50, 0)
  17400    D OLDCAT
  17401   "RTN","CHM F351D",51, 0)
  17402    S CHCYR=+ $E(CHDEDDT ,1,3)+1700
  17403   "RTN","CHM F351D",52, 0)
  17404    G:CHICF=1  L2
  17405   "RTN","CHM F351D",53, 0)
  17406    S (CHBDYT D,CHFDYTD, CHFCYTD,CH BDYTDO,CHF DYTDO,CHFC YTDO)="",( CHBDM,CHFD M,CHFCM)=0
  17407   "RTN","CHM F351D",54, 0)
  17408    S CHRSYR= (9999999-( $E(CHDEDDT ,1,3)_"000 0")) G:CHR SYR="" L2
  17409   "RTN","CHM F351D",55, 0)
  17410    S CHDFNI= 0
  17411   "RTN","CHM F351D",56, 0)
  17412    S CHDFNI= $O(@(GLDFN _"""C"",I, CHDFNI)"))  G:CHDFNI= "" L2
  17413   "RTN","CHM F351D",57, 0)
  17414    S CHDFNJ= 0
  17415   "RTN","CHM F351D",58, 0)
  17416    S CHDFNJ= $O(@(GLDFN _"""C"",I, CHDFNI,CHD FNJ)")) G: CHDFNJ=""  L2
  17417   "RTN","CHM F351D",59, 0)
  17418    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)
  17419   "RTN","CHM F351D",60, 0)
  17420    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)
  17421   "RTN","CHM F351D",61, 0)
  17422    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)
  17423   "RTN","CHM F351D",62, 0)
  17424    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)
  17425   "RTN","CHM F351D",63, 0)
  17426    ;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)
  17427   "RTN","CHM F351D",64, 0)
  17428    S:$D(@(GL DFN_"CHDFN I,100,CHDF NJ,10,CHRS YR,0)")) C HBDYTDO=$P (@(GLDFN_" CHDFNI,100 ,CHDFNJ,10 ,CHRSYR,0) "),"^",2)
  17429   "RTN","CHM F351D",65, 0)
  17430    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)
  17431   "RTN","CHM F351D",66, 0)
  17432   L2 ;FOLLOW ING GET NA MES,STATUS ,ASG BENE, DATE
  17433   "RTN","CHM F351D",67, 0)
  17434    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
  17435   "RTN","CHM F351D",68, 0)
  17436    I VFN'=""  S:$D(^CHM VEN(VFN,0) ) CHVFNAM= $P(^(0),"^ ",1)
  17437   "RTN","CHM F351D",69, 0)
  17438    D:$D(@(GL PAY_"I,7)" ))
  17439   "RTN","CHM F351D",70, 0)
  17440    .S:$P(@(G LPAY_"I,7) "),"^",11) '="" CHOHI PB=$P(@(GL PAY_"I,7)" ),"^",11)   ;MTN01316 3F  EW  BU G BEN39 6/ 29/12
  17441   "RTN","CHM F351D",71, 0)
  17442    .S:$P(@(G LPAY_"I,7) "),"^",10) '="" CHOHI AD=$P(@(GL PAY_"I,7)" ),"^",10)   ;MTN01316 3F  EW  BU G BEN39 6/ 29/12
  17443   "RTN","CHM F351D",72, 0)
  17444    .S:$P(@(G LPAY_"I,7) "),"^",9)' ="" CHTPL= $P(@(GLPAY _"I,7)")," ^",9)
  17445   "RTN","CHM F351D",73, 0)
  17446    .S:$P(@(G LPAY_"I,7) "),"^",8)' ="" CHPZIP =$P(@(GLPA Y_"I,7)"), "^",8)
  17447   "RTN","CHM F351D",74, 0)
  17448    .S:$P(@(G LPAY_"I,7) "),"^",2)' ="" CHMED= $P(@(GLPAY _"I,7)")," ^",2)  ;MT N013163F   EW  BUG BE N39 6/29/1 2
  17449   "RTN","CHM F351D",75, 0)
  17450    .Q:$P(@(G LPAY_"I,7) "),"^",1)= ""  S MDPT =$P(@(GLPA Y_"I,7)"), "^",1)
  17451   "RTN","CHM F351D",76, 0)
  17452    .S:$D(^CH MVEN(MDPT, 0)) CHMEDN AM=$P(^(0) ,"^",1)
  17453   "RTN","CHM F351D",77, 0)
  17454    I $D(@(GL PAY_"I,""V EN-II"")") ) D  ;CPE0 01-020, 02 1 and 022
  17455   "RTN","CHM F351D",78, 0)
  17456    .S ^TMP($ J,"VEN-II" )=@(GLPAY_ "I,""VEN-I I"")")
  17457   "RTN","CHM F351D",79, 0)
  17458    S:$D(@(GL ELG_"DFN,0 )")) CHDFN AM=$P(@(GL ELG_"DFN,0 )"),"^",1)
  17459   "RTN","CHM F351D",80, 0)
  17460    S (CHBFNA M,CHBSEX,C HBDOB)=""
  17461   "RTN","CHM F351D",81, 0)
  17462    I $D(@(GL ELG_"DFN,1 00,BFN,0)" )) D
  17463   "RTN","CHM F351D",82, 0)
  17464    .S BENREC ="",BENREC =@(GLELG_" DFN,100,BF N,0)")
  17465   "RTN","CHM F351D",83, 0)
  17466    .S CHBFNA M=$P(BENRE C,"^",1)
  17467   "RTN","CHM F351D",84, 0)
  17468    .S CHBSEX =$P(BENREC ,"^",2)
  17469   "RTN","CHM F351D",85, 0)
  17470    .S CHBDOB =$P(BENREC ,"^",3)
  17471   "RTN","CHM F351D",86, 0)
  17472    .S CHBDOB =$E(CHBDOB ,4,5)_"/"_ $E(CHBDOB, 6,7)_"/"_$ E(CHBDOB,2 ,3)
  17473   "RTN","CHM F351D",87, 0)
  17474    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:"")
  17475   "RTN","CHM F351D",88, 0)
  17476    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:"" )
  17477   "RTN","CHM F351D",89, 0)
  17478    S CHASOB= $S(CHASOB= 1:"Yes",1: "No")
  17479   "RTN","CHM F351D",90, 0)
  17480    S Y=CHDAT SER X ^DD( "DD") S CH DATSER=Y
  17481   "RTN","CHM F351D",91, 0)
  17482    ; HAVE TH E 1 NODE,  COMMON NOD E. GET THE  TYPE AND  THAT WILL
  17483   "RTN","CHM F351D",92, 0)
  17484    ; DETERMI NE WHAT NO DE TO $O O N TO SET U P THE OTHE R ^%ZTSK N ODE.
  17485   "RTN","CHM F351D",93, 0)
  17486    S (CHTYPE P,CHT,CHS) =""
  17487   "RTN","CHM F351D",94, 0)
  17488    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")
  17489   "RTN","CHM F351D",95, 0)
  17490    ;LOOPING  THRU THE A PPROPRIATE  NODE.
  17491   "RTN","CHM F351D",96, 0)
  17492    S J1=0
  17493   "RTN","CHM F351D",97, 0)
  17494    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:"" )
  17495   "RTN","CHM F351D",98, 0)
  17496    I CHT="OP T" S CHS=" OPT-DX" D  GETJ S CHS ="OPT-PROC " D GETJ S  CHS="PHAR M" D GETJ  G L5
  17497   "RTN","CHM F351D",99, 0)
  17498    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
  17499   "RTN","CHM F351D",100 ,0)
  17500    I CHT="DE N" S CHS=" DEN-PROC"  D GETJ S C HS="DEN-DX " D GETJ G  L5
  17501   "RTN","CHM F351D",101 ,0)
  17502    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
  17503   "RTN","CHM F351D",102 ,0)
  17504    I CHT="PH AR" S CHS= "PHARM" D  GETJ G L5
  17505   "RTN","CHM F351D",103 ,0)
  17506   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
  17507   "RTN","CHM F351D",104 ,0)
  17508    ;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)
  17509   "RTN","CHM F351D",105 ,0)
  17510    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
  17511   "RTN","CHM F351D",106 ,0)
  17512    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
  17513   "RTN","CHM F351D",107 ,0)
  17514    S DISCH=" "
  17515   "RTN","CHM F351D",108 ,0)
  17516    I CHTYPE= 1 S DISCH= ""
  17517   "RTN","CHM F351D",109 ,0)
  17518    S:$D(@(GL PAY_"I,""I NP"")")) D ISCH=$P(@( GLPAY_"I," "INP"")"), "^",1)
  17519   "RTN","CHM F351D",110 ,0)
  17520    S:DISCH'= "" ^TMP($J ,"DISCH",C HCLN)=DISC H
  17521   "RTN","CHM F351D",111 ,0)
  17522    S (METH,C HMETH)=""
  17523   "RTN","CHM F351D",112 ,0)
  17524    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:"")
  17525   "RTN","CHM F351D",113 ,0)
  17526    S:CHTYPE= 1 ^TMP($J, "INP",CHCL N)=CHDRG_" ^"_CHDRGST AT_"^"_CHM ETH_"^"_ME TH
  17527   "RTN","CHM F351D",114 ,0)
  17528    S J=0 F K =0:0 S J=$ O(CHPDI(J) ) Q:'J  S  ^TMP($J,"P DI",CHCLN, J)=CHPDI(J )
  17529   "RTN","CHM F351D",115 ,0)
  17530    ;D:$P(^TM P($J,1),"^ ",4)'="" Q UE
  17531   "RTN","CHM F351D",116 ,0)
  17532    D ^CHMF35 1F  ;CHECK S FOR AUDI T SUP,EOB, MCCR,MISS  DATA,PROB  SUP,QA
  17533   "RTN","CHM F351D",117 ,0)
  17534    D ^CHMF35 1G  ;CHECK S VENDOR,E LEGIB,SNA  CALM,SNA C APP,REOPEN ,DUPLICATE
  17535   "RTN","CHM F351D",118 ,0)
  17536    D ^CHMF35 1H  ;CHECK S REOPEN Q UEUE,WORKM ANS COMP,G ROUPER OUT ,OBLIGATIO N
  17537   "RTN","CHM F351D",119 ,0)
  17538    D ^CHMF35 1J  ;CHECK S ALL REJE CTION PIEC ES
  17539   "RTN","CHM F351D",120 ,0)
  17540    D EDI
  17541   "RTN","CHM F351D",121 ,0)
  17542   END K I,X, CHCLN,CHCL ST,CHASOB, CHTYPE,CHD ATSER,DFN, BFN,VFN
  17543   "RTN","CHM F351D",122 ,0)
  17544    K CHTOTAL ,CHCALCT,C HVFNAM,CHD FNAM,CHBFN AM,CHCLSTP ,CHDMEDEL
  17545   "RTN","CHM F351D",123 ,0)
  17546    K CHCLAMT ,CHAMTDED, CHCOST,CHO THER,Y,CHT YPEP,CHT,C HS,CHIN,J, J1,J2
  17547   "RTN","CHM F351D",124 ,0)
  17548    K CHPROCE D,CHNDC,CH DIAG,CHCHA RGE,CHALLO W,CHRES,CH RESULT,CHI CF,CHCCA
  17549   "RTN","CHM F351D",125 ,0)
  17550    K CHQSTAT ,CHQNAM,CH DMEDEL,CHD ELAA,CHDRG ,CHDRGOK,C HDRGSTAT,C HVPMT,CHBP MT
  17551   "RTN","CHM F351D",126 ,0)
  17552    K CHBDYDT ,CHFDYDT,C HFCYDT,CHB DM,CHFDM,C HFCM,CHRYR ,CHRSYR,CH DFNI,CHDFN J
  17553   "RTN","CHM F351D",127 ,0)
  17554    K CHSERV, CHPLZIP
  17555   "RTN","CHM F351D",128 ,0)
  17556   Q5 Q
  17557   "RTN","CHM F351D",129 ,0)
  17558    Q:$D(VIEW FL)
  17559   "RTN","CHM F351D",130 ,0)
  17560    S %ZIS="Q ",IOP="Q;" _CHMFION D  ^%ZIS Q:P OP
  17561   "RTN","CHM F351D",131 ,0)
  17562    S ZTRTN=" ^CHMF351P" ,ZTDTH=$H, ZTIO=CHMFI ON,ZTSAVE( "^TMP($J," )=""
  17563   "RTN","CHM F351D",132 ,0)
  17564    D ^%ZTLOA D Q
  17565   "RTN","CHM F351D",133 ,0)
  17566   RESET S (D FN,BFN,VFN ,X)=-1 S V FN=""
  17567   "RTN","CHM F351D",134 ,0)
  17568    S (CHCLN, CHCLST,CHA SOB,CHTYPE ,CHDATSER) =""
  17569   "RTN","CHM F351D",135 ,0)
  17570    S (CHTOTA L,CHCALCT, CHVFNAM,CH DFNAM,CHBF NAM,CHCLST P,CHDMEDEL )="" Q
  17571   "RTN","CHM F351D",136 ,0)
  17572   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
  17573   "RTN","CHM F351D",137 ,0)
  17574    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
  17575   "RTN","CHM F351D",138 ,0)
  17576    ;^CHMF351 E GETS PRO CED CODE,C HARGES,DIA GNOS,RESUL T AND SETS  TASK
  17577   "RTN","CHM F351D",139 ,0)
  17578    Q
  17579   "RTN","CHM F351D",140 ,0)
  17580   OLDCAT S P GDT=0
  17581   "RTN","CHM F351D",141 ,0)
  17582    S PGDT=$O (@(GLELG_" DFN,100,BF N,108,PGDT )")) Q:'PG DT
  17583   "RTN","CHM F351D",142 ,0)
  17584    Q:'$D(@(G LELG_"DFN, 100,BFN,10 8,PGDT,0)" ))
  17585   "RTN","CHM F351D",143 ,0)
  17586    S PGDAT=$ P(@(GLELG_ "DFN,100,B FN,108,PGD T,0)"),"^" ,1)
  17587   "RTN","CHM F351D",144 ,0)
  17588    Q:PGDAT<2 921001  Q: PGDAT>2931 232
  17589   "RTN","CHM F351D",145 ,0)
  17590    S PGDOS=$ P(@(GLPAY_ "I,0)"),"^ ",8)
  17591   "RTN","CHM F351D",146 ,0)
  17592    I $P(@(GL PAY_"I,0)" ),"^",7)=1
  17593   "RTN","CHM F351D",147 ,0)
  17594    S:$D(@(GL PAY_"I,""I NP"")")) P GDOS=$P(@( GLPAY_"I," "INP"")"), "^",1)
  17595   "RTN","CHM F351D",148 ,0)
  17596    S:'$D(PGD OS) PGDOS= ""
  17597   "RTN","CHM F351D",149 ,0)
  17598    Q:PGDOS<2 921001  Q: PGDOS>2931 232  S PGD OS=2930101
  17599   "RTN","CHM F351D",150 ,0)
  17600    I PGDAT<2 931001 D   Q
  17601   "RTN","CHM F351D",151 ,0)
  17602    .I (PGDOS >2920930)& (PGDOS<293 1001) S PG DOS=293010 1
  17603   "RTN","CHM F351D",152 ,0)
  17604    .S CHDEDD T=PGDOS
  17605   "RTN","CHM F351D",153 ,0)
  17606    I PGDOS>2 930930 S P GDOS=29401 01,CHDEDDT =PGDOS
  17607   "RTN","CHM F351D",154 ,0)
  17608    Q
  17609   "RTN","CHM F351D",155 ,0)
  17610    ;
  17611   "RTN","CHM F351D",156 ,0)
  17612   EDI S:'$D( ZHI) ZHI=0
  17613   "RTN","CHM F351D",157 ,0)
  17614    n ZRX
  17615   "RTN","CHM F351D",158 ,0)
  17616    S ZCL=""
  17617   "RTN","CHM F351D",159 ,0)
  17618    S ZCL=$O( @(GLPAY_"" "B"",CHCLN ,0)")) Q:' ZCL
  17619   "RTN","CHM F351D",160 ,0)
  17620    Q:'$D(@(G LPAY_"ZCL, ""ZEMC"")" ))
  17621   "RTN","CHM F351D",161 ,0)
  17622    S EDITYP= ""
  17623   "RTN","CHM F351D",162 ,0)
  17624    S EDITYP= $O(@(GLPAY _"ZCL,""ZE MC"",EDITY P)")) S:ED ITYP="" ED ITYP="Unkn own"
  17625   "RTN","CHM F351D",163 ,0)
  17626    ;Start CR # DEV00937 3
  17627   "RTN","CHM F351D",164 ,0)
  17628    ; Determi ne if it's  a COB SXC  Claim
  17629   "RTN","CHM F351D",165 ,0)
  17630    I EDITYP= "SXC" D
  17631   "RTN","CHM F351D",166 ,0)
  17632    .S ZRX=$O (@(GLPAY_" ZCL,""ZEMC "",EDITYP, """")")) Q :ZRX=""
  17633   "RTN","CHM F351D",167 ,0)
  17634    .S ZRX=+$ G(@(GLPAY_ "ZCL,""ZEM C"",EDITYP ,ZRX)"))
  17635   "RTN","CHM F351D",168 ,0)
  17636    .Q:ZRX="" !(ZRX=0)
  17637   "RTN","CHM F351D",169 ,0)
  17638    .I $P($G( ^CHMXRX(ZR X,0)),"^", 8)="Y" S E DITYP="SXC COB"
  17639   "RTN","CHM F351D",170 ,0)
  17640    .I $P($G( ^CHMXRX(ZR X,0)),"^", 8)="K" S E DITYP="MCD SXC"
  17641   "RTN","CHM F351D",171 ,0)
  17642    .I $P($G( ^CHMXRX(ZR X,0)),"^", 8)="Z" S E DITYP="CIT ISXC"  ; A DDED "CITI SXC" EDITY PE 3/8/201 2
  17643   "RTN","CHM F351D",172 ,0)
  17644    ;End CR#  DEV009373
  17645   "RTN","CHM F351D",173 ,0)
  17646    F ZI=0:0  S ZI=$O(^T MP($J,"QUE ",CHCLN,ZI )) Q:'ZI   S ZHI=ZI
  17647   "RTN","CHM F351D",174 ,0)
  17648    S ZI=ZHI+ 1,^TMP($J, "QUE",CHCL N,ZI)="EDI : "_EDITYP
  17649   "RTN","CHM F351D",175 ,0)
  17650    Q
  17651   "RTN","CHM F351D",176 ,0)
  17652    ;
  17653   "RTN","CHM F351D",177 ,0)
  17654   GETPYMNT(P DI,PAIDARY ) ;Get the  total pay ment amoun t of all c laims for  Original &  Current P DIs. CPE00 5-095.
  17655   "RTN","CHM F351D",178 ,0)
  17656    S PDI=$G( PDI),PAIDA RY=$G(PAID ARY)
  17657   "RTN","CHM F351D",179 ,0)
  17658    N ARYCNT, IEN,CHMFPD I,CHMPDI,C HSUM,CHTOT SUM,CURRPD I
  17659   "RTN","CHM F351D",180 ,0)
  17660    I $D(^CHM IMG("A-FIR ST",PDI))  D
  17661   "RTN","CHM F351D",181 ,0)
  17662    .S CHMPDI =$O(^CHMIM G("A-FIRST ",PDI,""))
  17663   "RTN","CHM F351D",182 ,0)
  17664    .S CURRPD I=$O(^CHMI MG("A-ALL" ,CHMPDI,"" ),-1)
  17665   "RTN","CHM F351D",183 ,0)
  17666    .S PAIDAR Y(1)=CURRP DI  ;Curre nt PDI alw ays first.
  17667   "RTN","CHM F351D",184 ,0)
  17668    .I $D(^CH MIMG("A-AL L",CHMPDI) ) D
  17669   "RTN","CHM F351D",185 ,0)
  17670    ..S CHMFP DI=0,ARYCN T=2
  17671   "RTN","CHM F351D",186 ,0)
  17672    ..F  S CH MFPDI=$O(^ CHMIMG("A- ALL",CHMPD I,CHMFPDI) ) Q:CHMFPD I=""  D
  17673   "RTN","CHM F351D",187 ,0)
  17674    ...D TOTP YMNT(CHMFP DI,.ARYCNT ,.PAIDARY)
  17675   "RTN","CHM F351D",188 ,0)
  17676    ...I ARYC NT'=^CHMIM G("A-ALL", CHMPDI,0)  S ARYCNT=A RYCNT+1
  17677   "RTN","CHM F351D",189 ,0)
  17678    ..S PAIDA RY=ARYCNT
  17679   "RTN","CHM F351D",190 ,0)
  17680    I '$D(^CH MIMG("A-FI RST",PDI))  D
  17681   "RTN","CHM F351D",191 ,0)
  17682    .S PAIDAR Y(1)=PDI
  17683   "RTN","CHM F351D",192 ,0)
  17684    .D TOTPYM NT(PDI,.AR YCNT,.PAID ARY)
  17685   "RTN","CHM F351D",193 ,0)
  17686    .S PAIDAR Y=1
  17687   "RTN","CHM F351D",194 ,0)
  17688    Q
  17689   "RTN","CHM F351D",195 ,0)
  17690    ;
  17691   "RTN","CHM F351D",196 ,0)
  17692   TOTPYMNT(C HMFPDI,ARY CNT,PAIDAR Y) ;CPE005 -095
  17693   "RTN","CHM F351D",197 ,0)
  17694    N IEN,CHS UM,CHTOTSU M
  17695   "RTN","CHM F351D",198 ,0)
  17696    S CHTOTSU M=0
  17697   "RTN","CHM F351D",199 ,0)
  17698    S IEN=""  F  S IEN=$ O(^CHMPAY( "C",CHMFPD I,IEN)) Q: IEN=""  D
  17699   "RTN","CHM F351D",200 ,0)
  17700    .S CHSUM= $P($G(^CHM PAY(IEN,1) ),"^")
  17701   "RTN","CHM F351D",201 ,0)
  17702    .S CHTOTS UM=CHTOTSU M+CHSUM  ; Get the su m of all c laims for  this PDI.
  17703   "RTN","CHM F351D",202 ,0)
  17704    I CHMFPDI =$P(PAIDAR Y(1),"^")  S PAIDARY( 1)=PAIDARY (1)_"^"_CH TOTSUM Q   ;Always pu t Current  PDI on top .
  17705   "RTN","CHM F351D",203 ,0)
  17706    S PAIDARY (ARYCNT)=C HMFPDI_"^" _CHTOTSUM
  17707   "RTN","CHM F351D",204 ,0)
  17708    Q
  17709   "RTN","CHM F351P")
  17710   0^10^B1605 83754
  17711   "RTN","CHM F351P",1,0 )
  17712   CHMF351P ; DEH/DEN;CH AMVPA POST -PROC CLAI M REPORT P RINT;Feb 0 6, 2019@10 :03:10
  17713   "RTN","CHM F351P",2,0 )
  17714    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  17715   "RTN","CHM F351P",3,0 )
  17716    ;CPTS #10 846* - PEJ  8/15/96,  11008* - J LR, #12621 * (RLC), # 13367* (RL C)
  17717   "RTN","CHM F351P",4,0 )
  17718    ;CPTS #13 739* (RLC) , #13782*  (RLC), #15 358 (RLC)
  17719   "RTN","CHM F351P",5,0 )
  17720    ;TT 00010 8 JEH 1/4/ 10 - SPLIT  TOS INCID ENTAL DRUG S
  17721   "RTN","CHM F351P",6,0 )
  17722    ;DEV00480 5 1/20/201 0 AEB
  17723   "RTN","CHM F351P",7,0 )
  17724    ;DEV7820  EW 2/23/11  Add line  level data
  17725   "RTN","CHM F351P",8,0 )
  17726    ;DEV00369 6 EW 4/4/1 1
  17727   "RTN","CHM F351P",9,0 )
  17728    ;DEV01938 8 11/5/13  DGC - Chan ge in INP  processing
  17729   "RTN","CHM F351P",10, 0)
  17730    ;CFS 02/2 0/2018 - C PE001-020,  021 and 0 22 Write P L ZIP info rmation.
  17731   "RTN","CHM F351P",11, 0)
  17732   ENTER ;
  17733   "RTN","CHM F351P",12, 0)
  17734   V1 I $D(VI EWFL) X CH RESET S EX FLG=0
  17735   "RTN","CHM F351P",13, 0)
  17736    S (CHCLN, CHTTT)="", (CHPG,NTNU M)=0 S %H= $H D YX^%D TC S CHDAT E=$P(Y,"@" ,1)
  17737   "RTN","CHM F351P",14, 0)
  17738   L1 S CHCLN =$O(^TMP($ J,"CL",CHC LN)) G END :CHCLN=""  W:'$D(VIEW FL) #
  17739   "RTN","CHM F351P",15, 0)
  17740    G:'$D(^CH MINDEX("B" ,CHCLN)) L 1 S CHCCLM =""
  17741   "RTN","CHM F351P",16, 0)
  17742    S CHCCLM= $O(^CHMIND EX("B",CHC LN,CHCCLM) ) G:CHCCLM ="" L1
  17743   "RTN","CHM F351P",17, 0)
  17744    ;D GTPTR^ CHMKPPR1
  17745   "RTN","CHM F351P",18, 0)
  17746    S X1=CHCC LM D PROGT YP^CHFCD00 1
  17747   "RTN","CHM F351P",19, 0)
  17748    G:'$D(@(G LPAY_"""B" ",CHCLN)") ) L1
  17749   "RTN","CHM F351P",20, 0)
  17750    S AUTODIS T=0
  17751   "RTN","CHM F351P",21, 0)
  17752    I $D(@(GL PAY_"CHCCL M,""COMMON "")")) S A UTODIST=$P (@(GLPAY_" CHCCLM,""C OMMON"")") ,"^",18)
  17753   "RTN","CHM F351P",22, 0)
  17754    K LIREAS, LNREAS,CLR EAS,RESON, CHECKS S ( PAMT1,PCHM LN,RND)=""
  17755   "RTN","CHM F351P",23, 0)
  17756    D HEAD ;D GC 11/4/13  DEV019388 8 - ADDED
  17757   "RTN","CHM F351P",24, 0)
  17758    ;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
  17759   "RTN","CHM F351P",25, 0)
  17760    ;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
  17761   "RTN","CHM F351P",26, 0)
  17762    S X=^TMP( $J,"CL",CH CLN),CHPRO G=$P(X,"^" ,23)  ;MTN 013163F  E W  BUG PPR 35 10/5/12
  17763   "RTN","CHM F351P",27, 0)
  17764    S CHTTT=$ P(X,"^",3)
  17765   "RTN","CHM F351P",28, 0)
  17766    ;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
  17767   "RTN","CHM F351P",29, 0)
  17768    S INP=""  S:$D(^TMP( $J,"INP",C HCLN)) INP =(^(CHCLN) )  ;DGC 11 /6/13 DEV0 19388
  17769   "RTN","CHM F351P",30, 0)
  17770    S DISCH=" " S:$D(^TM P($J,"DISC H",CHCLN))  DISCH=(^( CHCLN))  ; DGC 11/6/1 3 DEV01938 8
  17771   "RTN","CHM F351P",31, 0)
  17772    I DISCH'= "" S Y=DIS CH X ^DD(" DD") S DIS CH=Y  ;DGC  11/6/13 D EV019388
  17773   "RTN","CHM F351P",32, 0)
  17774    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)
  17775   "RTN","CHM F351P",33, 0)
  17776    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
  17777   "RTN","CHM F351P",34, 0)
  17778    .D TOP
  17779   "RTN","CHM F351P",35, 0)
  17780    .D MIDHED ^CHMF351Q
  17781   "RTN","CHM F351P",36, 0)
  17782    .D L3^CHM F351Q
  17783   "RTN","CHM F351P",37, 0)
  17784    .D BOT^CH MF351U
  17785   "RTN","CHM F351P",38, 0)
  17786    .D L7
  17787   "RTN","CHM F351P",39, 0)
  17788    D TOP S J =0 D MIDHE D Q:EXFLG= 1  K CODES
  17789   "RTN","CHM F351P",40, 0)
  17790   L3 S J=$O( ^TMP($J,"M P",CHCLN,J )) G L5:'J
  17791   "RTN","CHM F351P",41, 0)
  17792    S X1=^TMP ($J,"MP",C HCLN,J)
  17793   "RTN","CHM F351P",42, 0)
  17794    D SORT Q: EXFLG=1  G  L3
  17795   "RTN","CHM F351P",43, 0)
  17796   L5 D MID D  BOT^CHMF3 51U Q:EXFL G=1
  17797   "RTN","CHM F351P",44, 0)
  17798   L6 G:'$D(^ TMP($J,"DE D",CHCLN))  L7
  17799   "RTN","CHM F351P",45, 0)
  17800    S X3=^TMP ($J,"DED", CHCLN) D D EDT S J=0
  17801   "RTN","CHM F351P",46, 0)
  17802    ;D MULTI
  17803   "RTN","CHM F351P",47, 0)
  17804   L7 S J=$O( ^TMP($J,"Q UE",CHCLN, J)) G:'J L 8
  17805   "RTN","CHM F351P",48, 0)
  17806    S X2=^TMP ($J,"QUE", CHCLN,J) D  QUEUE Q:E XFLG=1  G  L7
  17807   "RTN","CHM F351P",49, 0)
  17808   L8 D REASO N,CHECKS G  L1
  17809   "RTN","CHM F351P",50, 0)
  17810   END K CHCL N,CHPG,CHD ATE,X,X1,X 2,Y,J,CHTI ME Q
  17811   "RTN","CHM F351P",51, 0)
  17812   MULTI S ZC L=""
  17813   "RTN","CHM F351P",52, 0)
  17814    S ZCL=$O( @(GLPAY_"" "B"",CHCLN ,0)")) Q:' ZCL
  17815   "RTN","CHM F351P",53, 0)
  17816    Q:'$D(@(G LPAY_"ZCL, 4)"))  S Z I=""
  17817   "RTN","CHM F351P",54, 0)
  17818    S ZI=$O(@ (GLPAY_"ZC L,4,0)"))  Q:'ZI
  17819   "RTN","CHM F351P",55, 0)
  17820    Q:'$O(@(G LPAY_"ZCL, 4,ZI)"))   S ZI="",ZH I=0
  17821   "RTN","CHM F351P",56, 0)
  17822    F ZI=0:0  S ZI=$O(^T MP($J,"QUE ",CHCLN,ZI )) Q:'ZI   S ZHI=ZI
  17823   "RTN","CHM F351P",57, 0)
  17824    S ZI=ZHI+ 1,^TMP($J, "QUE",CHCL N,ZI)="Mul tiple Reas " Q
  17825   "RTN","CHM F351P",58, 0)
  17826   HEAD S CHP G=CHPG+1
  17827   "RTN","CHM F351P",59, 0)
  17828    ;-------- ---------- --------DE V7820 EW 2 /23/11  ST ART
  17829   "RTN","CHM F351P",60, 0)
  17830    S TITLE=" Health Adm inistratio n Center"  S TAB=((13 2-$L(TITLE ))/2)
  17831   "RTN","CHM F351P",61, 0)
  17832    W "DUZ: " ,DUZ,?TAB, TITLE,?123 ,"Page: ", CHPG
  17833   "RTN","CHM F351P",62, 0)
  17834    W !,"Date : ",CHDATE ,?TAB,"Pos t-Processi ng Claim R eport" K T AB,TITLE
  17835   "RTN","CHM F351P",63, 0)
  17836    ;-------- ---------- --------DE V7820 EW 2 /23/11  EN D
  17837   "RTN","CHM F351P",64, 0)
  17838    W !,"Time : " D TIME  W CHTIME  Q
  17839   "RTN","CHM F351P",65, 0)
  17840   HEADI S CH PG=CHPG+1   ;MTN01316 3F  EW  BU G PPR35 10 /5/12
  17841   "RTN","CHM F351P",66, 0)
  17842    S TITLE=" Health Adm inistratio n Center"  S TAB=((80 -$L(TITLE) )/2)  ;MTN 013163F  E W  BUG PPR 35 10/5/12
  17843   "RTN","CHM F351P",67, 0)
  17844    W "DUZ: " ,DUZ,?TAB, TITLE,?73, "Page: ",C HPG  ;MTN0 13163F  EW   BUG PPR3 5 10/5/12
  17845   "RTN","CHM F351P",68, 0)
  17846    W !,"Date : ",CHDATE ,?TAB,"Pos t-Processi ng Claim R eport" K T AB,TITLE   ;MTN013163 F  EW  BUG  PPR35 10/ 5/12
  17847   "RTN","CHM F351P",69, 0)
  17848    W !,"Time : " D TIME  W CHTIME  Q  ;MTN013 163F  EW   BUG PPR35  10/5/12
  17849   "RTN","CHM F351P",70, 0)
  17850   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)
  17851   "RTN","CHM F351P",71, 0)
  17852    ;
  17853   "RTN","CHM F351P",72, 0)
  17854    S CHPVPTR ="",CHPTID ="",CHPVAC ="",CHPIM= "",CHEXP=" UNK"  ;DGC  11/6/13 D EV019388
  17855   "RTN","CHM F351P",73, 0)
  17856    S CHPPTR= 0
  17857   "RTN","CHM F351P",74, 0)
  17858    S CHPPTR= $O(@(GLPAY _"""B"",CH CLN,CHPPTR )"))
  17859   "RTN","CHM F351P",75, 0)
  17860    S CHPVPTR =$P(@(GLPA Y_"CHPPTR, 0)"),U,3)
  17861   "RTN","CHM F351P",76, 0)
  17862    I CHPVPTR  I $D(^CHM VEN(CHPVPT R,0)) D
  17863   "RTN","CHM F351P",77, 0)
  17864    .S CHPTID =$P(^CHMVE N(CHPVPTR, 0),U,3)
  17865   "RTN","CHM F351P",78, 0)
  17866    .S CHPVAC =$P(^CHMVE N(CHPVPTR, 0),U,23)
  17867   "RTN","CHM F351P",79, 0)
  17868    .S CHPIM= "" S:$D(^C HMVEN(CHPV PTR,14)) C HPIM=$P(^C HMVEN(CHPV PTR,14),U, 1)
  17869   "RTN","CHM F351P",80, 0)
  17870    .S CHEXP= $$POACK^CH TFLIB3(CHP VPTR)  ;DG C 11/6/13  DEV019388  - BEGIN
  17871   "RTN","CHM F351P",81, 0)
  17872    S:CHEXP=0  CHEXP="N"  S:CHEXP=1  CHEXP="Y"
  17873   "RTN","CHM F351P",82, 0)
  17874    S CHTOB=" " I $D(@(G LPAY_"CHPP TR,7)")) D   ;DGC 11/ 6/13 DEV01 9388
  17875   "RTN","CHM F351P",83, 0)
  17876    .S CHTOB= $P(@(GLPAY _"CHPPTR,7 )"),U,6)   ;DGC 11/6/ 13 DEV0193 88
  17877   "RTN","CHM F351P",84, 0)
  17878    S CHDISST P="" I $D( @(GLPAY_"C HPPTR,""IN P"")")) D
  17879   "RTN","CHM F351P",85, 0)
  17880    .S CHDISS T=$P(@(GLP AY_"CHPPTR ,""INP"")" ),"^",2)
  17881   "RTN","CHM F351P",86, 0)
  17882    .I CHDISS T I $D(^CH MDIC(74100 2.12,CHDIS ST,0)) D
  17883   "RTN","CHM F351P",87, 0)
  17884    ..S CHDIS STP=$P(^(0 ),"^",1)_"  - "_$E($P (^(0),"^", 2),1,9)  ; DGC 11/6/1 3 DEV01938 8 - END
  17885   "RTN","CHM F351P",88, 0)
  17886    S PDICPT= CHPPTR D P DIS
  17887   "RTN","CHM F351P",89, 0)
  17888    ;COLUMN S ETUP ONLY  NEED TO CH ANGE HERE  FOR TOP DG C 1/15/14  BUG019388  - BEGIN
  17889   "RTN","CHM F351P",90, 0)
  17890    S COL1=10 ,COL2=11,C OL3=40,COL 4=41,COL5= 116,COL6=1 17
  17891   "RTN","CHM F351P",91, 0)
  17892    W !!,?(CO L1-$L("PDI :")),"PDI: ",?COL2,CH PDI_"-"_CH DOC,?(COL3 -$L("BATCH :")),"BATC H:",?COL4, CHBATCH
  17893   "RTN","CHM F351P",92, 0)
  17894    W ?(COL5- $L("Claim  #:")),"Cla im #:",?CO L6,CHCLN
  17895   "RTN","CHM F351P",93, 0)
  17896    I $D(@(GL PAY_"CHPPT R,6)")) W  ! D REOPEN
  17897   "RTN","CHM F351P",94, 0)
  17898    W !,?(COL 1-$L("EIN: ")),"EIN:" ,?COL2,CHP TID_"-"_CH PVAC_"-"_C HPIM
  17899   "RTN","CHM F351P",95, 0)
  17900    W ?(COL5- $L("Status :")),"Stat us:",?COL6 ,$P(X,"^", 1)
  17901   "RTN","CHM F351P",96, 0)
  17902    I $P(^TMP ($J,"CL",C HCLN),"^", 3)="Inpati ent" D
  17903   "RTN","CHM F351P",97, 0)
  17904    .W !,?(CO L1-$L("Pro gram:"))," Program:", ?COL2,CHPR OG,?(COL5- $L("Type:" )),"Type:" ,?COL6,$P( X,"^",3)
  17905   "RTN","CHM F351P",98, 0)
  17906    E  W !,?( COL1-$L("P rogram:")) ,"Program: ",?COL2,CH PROG
  17907   "RTN","CHM F351P",99, 0)
  17908    I $P(^TMP ($J,"CL",C HCLN),"^", 3)="Inpati ent" D
  17909   "RTN","CHM F351P",100 ,0)
  17910    .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
  17911   "RTN","CHM F351P",101 ,0)
  17912    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
  17913   "RTN","CHM F351P",102 ,0)
  17914    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)
  17915   "RTN","CHM F351P",103 ,0)
  17916    S CHCMPDT ="" I $P(@ (GLPAY_"CH PPTR,0)"), "^",10)'=" " D
  17917   "RTN","CHM F351P",104 ,0)
  17918    .S Y=$P(@ (GLPAY_"CH PPTR,0)"), "^",10) X  ^DD("DD")  S CHCMPDT= $P(Y,"@",1 )
  17919   "RTN","CHM F351P",105 ,0)
  17920    I $P(^TMP ($J,"CL",C HCLN),"^", 3)="Inpati ent" D
  17921   "RTN","CHM F351P",106 ,0)
  17922    .W !,?(CO L1-$L("Spo nsor:"))," Sponsor:", ?COL2,$P(X ,"^",6),?( COL5-$L("     Disch.  Date:")),"     Disch.  Date:",?C OL6,DISCH
  17923   "RTN","CHM F351P",107 ,0)
  17924    .W !,?(CO L1-$L("Ben e:")),"Ben e:",?COL2, $P(X,"^",7 ),?(COL5-$ L("Disch.  Stat:"))," Disch. Sta t:",?COL6, CHDISSTP
  17925   "RTN","CHM F351P",108 ,0)
  17926    E  D
  17927   "RTN","CHM F351P",109 ,0)
  17928    .W !,?(CO L1-$L("Spo nsor:"))," Sponsor:", ?COL2,$P(X ,"^",6),?( COL5-$L("C omp. Date: ")),"Comp.  Date: ",? COL6
  17929   "RTN","CHM F351P",110 ,0)
  17930    .W:($P(@( GLPAY_"CHP PTR,0)")," ^",2)=0)!( $P(@(GLPAY _"CHPPTR,0 )"),"^",2) =4) CHCMPD T
  17931   "RTN","CHM F351P",111 ,0)
  17932    .W !,?(CO L1-$L("Ben e:")),"Ben e:",?COL2, $P(X,"^",7 ),?(COL5-$ L("POS:")) ,"POS:",?C OL6,$P(X," ^",20)
  17933   "RTN","CHM F351P",112 ,0)
  17934    N CHPLZIP ,CHSERV  ; CPE001-020 , 021 and  022
  17935   "RTN","CHM F351P",113 ,0)
  17936    S CHSERV= $P(^TMP($J ,"CL",CHCL N),"^",3)
  17937   "RTN","CHM F351P",114 ,0)
  17938    I CHSERV= "Inpatient " D
  17939   "RTN","CHM F351P",115 ,0)
  17940    .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
  17941   "RTN","CHM F351P",116 ,0)
  17942    .W:($P(@( GLPAY_"CHP PTR,0)")," ^",2)=0)!( $P(@(GLPAY _"CHPPTR,0 )"),"^",2) =4) CHCMPD T
  17943   "RTN","CHM F351P",117 ,0)
  17944    .I $P(X," ^",19)'="" ,$P(X,"^", 26)'="" D
  17945   "RTN","CHM F351P",118 ,0)
  17946    ..W !,?1, "Medicaid:  ",$P(X,"^ ",19),?(CO L5-$L("POP 1:")),"POP 1:",?COL6, $P(X,"^",2 6)
  17947   "RTN","CHM F351P",119 ,0)
  17948    ..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
  17949   "RTN","CHM F351P",120 ,0)
  17950    .I $P(X," ^",26)'="" ,'$G(CHPLZ IP) W !,?( COL5-$L("P OP1:")),"P OP1:",?COL 6,$P(X,"^" ,26)
  17951   "RTN","CHM F351P",121 ,0)
  17952    .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
  17953   "RTN","CHM F351P",122 ,0)
  17954    .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
  17955   "RTN","CHM F351P",123 ,0)
  17956    E  D
  17957   "RTN","CHM F351P",124 ,0)
  17958    .W !,?(CO L1-$L("Ben e Sex:")), "Bene Sex: ",?COL2,$P (X,"^",21) ,?(COL3-$L ("Bene DOB :")),"Bene  DOB:",?CO L4,$P(X,"^ ",22)
  17959   "RTN","CHM F351P",125 ,0)
  17960    .I $P(X," ^",19)'="" ,$P(X,"^", 26)'="" D
  17961   "RTN","CHM F351P",126 ,0)
  17962    ..W ?(COL 5-$L("POP1 :")),"POP1 :",?COL6,$ P(X,"^",26 ),!,?1,"Me dicaid: ", $P(X,"^",1 9) S CHPLZ IP=1
  17963   "RTN","CHM F351P",127 ,0)
  17964    ..I CHSER V'="Pharma cy",CHSERV '="Durable  Medj.",CH SERV'="Tra vel" D
  17965   "RTN","CHM F351P",128 ,0)
  17966    ...W ?(CO L5-$L("PL  ZIP:")),"P L ZIP:",?C OL6,$E($P( $G(^TMP($J ,"VEN-II") ),"^",15), 1,5)
  17967   "RTN","CHM F351P",129 ,0)
  17968    .I $P(X," ^",26)'="" ,'$G(CHPLZ IP) W ?(CO L5-$L("POP 1:")),"POP 1:",?COL6, $P(X,"^",2 6),!
  17969   "RTN","CHM F351P",130 ,0)
  17970    .I $P(X," ^",19)'="" ,$P(X,"^", 26)="" D
  17971   "RTN","CHM F351P",131 ,0)
  17972    ..I CHSER V'="Pharma cy",CHSERV '="Durable  Medj.",CH SERV'="Tra vel",'$G(C HPLZIP) D
  17973   "RTN","CHM F351P",132 ,0)
  17974    ...W ?(CO L5-$L("PL  ZIP:")),"P L ZIP:",?C OL6,$E($P( $G(^TMP($J ,"VEN-II") ),"^",15), 1,5)
  17975   "RTN","CHM F351P",133 ,0)
  17976    ..W !,?1, "Medicaid:  ",$P(X,"^ ",19) S CH PLZIP=1
  17977   "RTN","CHM F351P",134 ,0)
  17978    .I CHSERV '="Pharmac y",CHSERV' ="Durable  Medj.",CHS ERV'="Trav el",'$G(CH PLZIP) D
  17979   "RTN","CHM F351P",135 ,0)
  17980    ..W ?(COL 5-$L("PL Z IP:")),"PL  ZIP:",?CO L6,$E($P($ G(^TMP($J, "VEN-II")) ,"^",15),1 ,5)
  17981   "RTN","CHM F351P",136 ,0)
  17982    W !!! Q   ;DGC 1/15/ 14 BUG0193 88 - END
  17983   "RTN","CHM F351P",137 ,0)
  17984   MIDHED I $ D(VIEWFL)  W !!,"Pres s <RETURN>  to contin ue, <^> to  exit." R  XXX S:XXX= "^" EXFLG= 1 W !
  17985   "RTN","CHM F351P",138 ,0)
  17986    ;-------- ---------- --DEV7820  EW 2/23/11  START
  17987   "RTN","CHM F351P",139 ,0)
  17988    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"
  17989   "RTN","CHM F351P",140 ,0)
  17990    W !,?21," AlwUnt",?3 0,"Chg/Unt ",?43,"AA/ Unt",?69," Addl OHI", ?82,"OHI P R Bal",?95 ,"Cst Shar e" ;,?108, "Payments"
  17991   "RTN","CHM F351P",141 ,0)
  17992    W !,"---- ---------- -----  --- ----  ---- -------  - ----------   -------- ---  ----- ------  -- ---------   --------- --  ------ -----  --  ----" Q
  17993   "RTN","CHM F351P",142 ,0)
  17994   MID S SORT ="",CHSOHI PDT="",CHS OHIPRT="", CHSDEDUCTT ="",CHSMED PDT="",CHS OHIADT="", CHSOHIPBT= "",CHSCSAT ="",CHSPAY AT="",SPBI F=0,TCHARG E="",TALLO W=""
  17995   "RTN","CHM F351P",143 ,0)
  17996   MID1 S SOR T=$O(CODES (SORT)) Q: SORT=""  S  USEJ=""
  17997   "RTN","CHM F351P",144 ,0)
  17998   MID11 S US EJ=$O(CODE S(SORT,USE J)) G:USEJ ="" MID1 S  CODE=""
  17999   "RTN","CHM F351P",145 ,0)
  18000   MID2 S COD E=$O(CODES (SORT,USEJ ,CODE)) G: CODE="" MI D11 S AMT1 =""
  18001   "RTN","CHM F351P",146 ,0)
  18002   MID3 S AMT 1=$O(CODES (SORT,USEJ ,CODE,AMT1 )) G:AMT1= "" MID2 S  CHQTY1=""
  18003   "RTN","CHM F351P",147 ,0)
  18004   MID55 S CH QTY1=$O(CO DES(SORT,U SEJ,CODE,A MT1,CHQTY1 )) G:CHQTY 1="" MID3
  18005   "RTN","CHM F351P",148 ,0)
  18006    S X1=CODE S(SORT,USE J,CODE,AMT 1,CHQTY1)
  18007   "RTN","CHM F351P",149 ,0)
  18008    D PARSE
  18009   "RTN","CHM F351P",150 ,0)
  18010    S ADJNUM= 0
  18011   "RTN","CHM F351P",151 ,0)
  18012    I $D(REJL N($J,CODE, AMT1,2)) D
  18013   "RTN","CHM F351P",152 ,0)
  18014    .S (RL,LN )=0,NTNUM= NTNUM+1
  18015   "RTN","CHM F351P",153 ,0)
  18016    .F  S RL= $O(REJLN($ J,CODE,AMT 1,RL)) Q:R L=""  D
  18017   "RTN","CHM F351P",154 ,0)
  18018    ..S REJLN ($J,"NOTE" ,NTNUM,RL) =REJLN($J, CODE,AMT1, RL)
  18019   "RTN","CHM F351P",155 ,0)
  18020    ..I $P(RE JLN($J,COD E,AMT1,RL) ,"^",4)'=0  S ADJNUM= ADJNUM+1
  18021   "RTN","CHM F351P",156 ,0)
  18022    ..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
  18023   "RTN","CHM F351P",157 ,0)
  18024    .S CHRESU LT="NOTE " _NTNUM,CHR EASN=""
  18025   "RTN","CHM F351P",158 ,0)
  18026    I CHPROCE DM="Deliv"  D  G DSP  ;G MID55
  18027   "RTN","CHM F351P",159 ,0)
  18028    .S CHSCST UT=CHCHARG E,CHSCAA=C HALLOW
  18029   "RTN","CHM F351P",160 ,0)
  18030    .Q
  18031   "RTN","CHM F351P",161 ,0)
  18032    I CHDIAG' ="" G MID6
  18033   "RTN","CHM F351P",162 ,0)
  18034    I CHTTT=" Pharmacy"  I CHPROG=" SPINA BIFI DA" D  G M ID6
  18035   "RTN","CHM F351P",163 ,0)
  18036    .I CHRXDX '="" S CHD IAG=CHRXDX ,SPBIF=1,C HPROCEDM=C HNDC
  18037   "RTN","CHM F351P",164 ,0)
  18038    .E  I CHN DC'="" S C HPROCEDM=C HNDC
  18039   "RTN","CHM F351P",165 ,0)
  18040    .Q
  18041   "RTN","CHM F351P",166 ,0)
  18042    I CHNDC'= "" S CHPRO CEDM=CHNDC
  18043   "RTN","CHM F351P",167 ,0)
  18044   MID6 ;
  18045   "RTN","CHM F351P",168 ,0)
  18046    ;I CHALLO W="" I (CH TTT="Inpat ient")!(CH TTT="Pharm acy") S CH ALLOW="und tr."
  18047   "RTN","CHM F351P",169 ,0)
  18048    I CHALLOW ="" I (CHT TT="Inpati ent") S CH ALLOW="und tr." ;remo ved check  for pharma cy
  18049   "RTN","CHM F351P",170 ,0)
  18050    I CHRESUL T="" S CHR ESULT="un"
  18051   "RTN","CHM F351P",171 ,0)
  18052   DSP I CHRE ASN'="" S  LNREAS(CHR EASN_"*"_C HPROCEDM)= CHCCK
  18053   "RTN","CHM F351P",172 ,0)
  18054    ;CHECK FO R ALLOWABL E AMOUNT D O NOT DISP LAY OHI IF  NULL AND  AUTO DISTR IBUTION
  18055   "RTN","CHM F351P",173 ,0)
  18056    I (CHSCAA ="")&(CHAL LOW="")&(A UTODIST=1)  S (CHSOHI PD,CHSOHIP R,CHSDEDUC T,CHSMEDPD ,CHSOHIAD, CHSOHIPB,C HSPAYA,CHS CSA)=""
  18057   "RTN","CHM F351P",174 ,0)
  18058    ;NO SLA C HARGE PER  UNIT USE U NIT CHARGE   FOR PHAR MACY DO NO T SHOW CHA RGE PER UN IT
  18059   "RTN","CHM F351P",175 ,0)
  18060    ;I (CHSCS TUT="")&(A MT1'="")&( CHTTT'="Ph armacy") S  CHSCSTUT= AMT1
  18061   "RTN","CHM F351P",176 ,0)
  18062    ;TOTAL LI NE ITEMS
  18063   "RTN","CHM F351P",177 ,0)
  18064    I CHSOHIP D'="" S CH SOHIPDT=CH SOHIPDT+CH SOHIPD
  18065   "RTN","CHM F351P",178 ,0)
  18066    I CHSOHIP R'="" S CH SOHIPRT=CH SOHIPRT+CH SOHIPR
  18067   "RTN","CHM F351P",179 ,0)
  18068    I CHSDEDU CT'="" S C HSDEDUCTT= CHSDEDUCTT +CHSDEDUCT
  18069   "RTN","CHM F351P",180 ,0)
  18070    I CHSMEDP D'="" S CH SMEDPDT=CH SMEDPDT+CH SMEDPD
  18071   "RTN","CHM F351P",181 ,0)
  18072    I CHSOHIA D'="" S CH SOHIADT=CH SOHIADT+CH SOHIAD
  18073   "RTN","CHM F351P",182 ,0)
  18074    I CHSOHIP B'="" S CH SOHIPBT=CH SOHIPBT+CH SOHIPB
  18075   "RTN","CHM F351P",183 ,0)
  18076    I CHSCSA' ="" S CHSC SAT=CHSCSA T+CHSCSA
  18077   "RTN","CHM F351P",184 ,0)
  18078    I CHSPAYA '="" S CHS PAYAT=CHSP AYAT+CHSPA YA
  18079   "RTN","CHM F351P",185 ,0)
  18080    I CHCHARG E'="" S TC HARGE=TCHA RGE+CHCHAR GE
  18081   "RTN","CHM F351P",186 ,0)
  18082    I CHALLOW '="" S TAL LOW=TALLOW +CHALLOW ; DGC 11/6/1 3 DEV01938 8
  18083   "RTN","CHM F351P",187 ,0)
  18084    ;FORMAT V ALUES FOR  DISPLAY
  18085   "RTN","CHM F351P",188 ,0)
  18086    I CHCHARG E'["A" S:C HCHARGE'=" " CHCHARGE =$J($FN(CH CHARGE,"," ,2),11)
  18087   "RTN","CHM F351P",189 ,0)
  18088    S:CHCHARG E["A" CHCH ARGE=$J($F N(CHCHARGE ,",",2),11 )_"A"
  18089   "RTN","CHM F351P",190 ,0)
  18090    S:CHSCSTU T'="" CHSC STUT=$J($F N(CHSCSTUT ,",",2),11 )
  18091   "RTN","CHM F351P",191 ,0)
  18092    S:CHSCAA' ="" CHSCAA =$J($FN(CH SCAA,",",2 ),11)
  18093   "RTN","CHM F351P",192 ,0)
  18094    S:CHSOHIP D'="" CHSO HIPD=$J($F N(CHSOHIPD ,",",2),11 )
  18095   "RTN","CHM F351P",193 ,0)
  18096    S:CHSOHIP R'="" CHSO HIPR=$J($F N(CHSOHIPR ,",",2),11 )
  18097   "RTN","CHM F351P",194 ,0)
  18098    S:CHSDEDU CT'="" CHS DEDUCT=$J( $FN(CHSDED UCT,",",2) ,11)
  18099   "RTN","CHM F351P",195 ,0)
  18100    I (CHALLO W'="")&(CH ALLOW'="un dtr.") S C HALLOW=$J( $FN(CHALLO W,",",2),1 1) ;DGC 11 /6/13 DEV0 19388
  18101   "RTN","CHM F351P",196 ,0)
  18102    S ADJAAFL AG="" I CH ADJAA'=""  S ADJAAFLA G="A"
  18103   "RTN","CHM F351P",197 ,0)
  18104    I ADJNUM> 1 S CHSCAA =$J("NOTE  "_NTNUM,11 )
  18105   "RTN","CHM F351P",198 ,0)
  18106    S:CHSMEDP D'="" CHSM EDPD=$J($F N(CHSMEDPD ,",",2),11 )
  18107   "RTN","CHM F351P",199 ,0)
  18108    S:CHSOHIA D'="" CHSO HIAD=$J($F N(CHSOHIAD ,",",2),11 )
  18109   "RTN","CHM F351P",200 ,0)
  18110    S:CHSOHIP B'="" CHSO HIPB=$J($F N(CHSOHIPB ,",",2),11 )
  18111   "RTN","CHM F351P",201 ,0)
  18112    S:CHSCSA' ="" CHSCSA =$J($FN(CH SCSA,",",2 ),11)
  18113   "RTN","CHM F351P",202 ,0)
  18114    S:CHSPAYA '="" CHSPA YA=$J($FN( CHSPAYA,", ",2),11)
  18115   "RTN","CHM F351P",203 ,0)
  18116    S:CHQTY'= "" CHQTY=$ J(CHQTY,7)
  18117   "RTN","CHM F351P",204 ,0)
  18118    S:CHSNAU' ="" CHSNAU =$J(CHSNAU ,7)
  18119   "RTN","CHM F351P",205 ,0)
  18120    S NOBKLIN E=0
  18121   "RTN","CHM F351P",206 ,0)
  18122    I CHSCSTU T="" S CHS CSTUT=CHCH ARGE  ;DEV 007820 PPR  BUG 21 EW   6/1/12
  18123   "RTN","CHM F351P",207 ,0)
  18124    I CHDIAG= "" S CHDIA G=CHPROCED M,NOBKLINE =1
  18125   "RTN","CHM F351P",208 ,0)
  18126    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)
  18127   "RTN","CHM F351P",209 ,0)
  18128    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
  18129   "RTN","CHM F351P",210 ,0)
  18130    E  W !,CH PROCEDM,?2 1,CHSNAU,? 30,CHSCSTU T,?43,CHSC AA,?69,CHS OHIAD,?82, CHSOHIPB,? 95,CHSCSA  ;,?108,CHS PAYA
  18131   "RTN","CHM F351P",211 ,0)
  18132    I NOBKLIN E=1 W !
  18133   "RTN","CHM F351P",212 ,0)
  18134    G MID55
  18135   "RTN","CHM F351P",213 ,0)
  18136    ;-------- ---------- --------DE V7820 EW 2 /23/11  EN D
  18137   "RTN","CHM F351P",214 ,0)
  18138   SORT S (CO DE,SORT)=" "
  18139   "RTN","CHM F351P",215 ,0)
  18140    S RESON=$ P(X1,"^",8 ) S:RESON= "" RESON="  "
  18141   "RTN","CHM F351P",216 ,0)
  18142    S TEST=$P (X1,"^",6)  S:TEST=""  TEST=" "   ;DEV7820  EW 4/4/11
  18143   "RTN","CHM F351P",217 ,0)
  18144    S ADJAA=$ P(X1,"^",1 0) I ADJAA ="" S ADJA A=$P(X1,"^ ",5)
  18145   "RTN","CHM F351P",218 ,0)
  18146    S AMT1=$P (X1,"^",4) ,AMT2=$P(X 1,"^",5),C HQTY=$P(X1 ,"^",25),C HMLN=$P(X1 ,"^",27)
  18147   "RTN","CHM F351P",219 ,0)
  18148    I (PAMT1' =AMT1)&(PC HMLN=CHMLN )&(CHMLN'= "") S RND= "R" ;TEST  TO SEE IF  CHARGE HAS  CHANGED I N LINE
  18149   "RTN","CHM F351P",220 ,0)
  18150    I CHMLN'= "" S AMT1= CHMLN
  18151   "RTN","CHM F351P",221 ,0)
  18152    I PCHMLN' =CHMLN S R ND=""
  18153   "RTN","CHM F351P",222 ,0)
  18154    S PAMT1=$ P(X1,"^",4 ),PCHMLN=C HMLN
  18155   "RTN","CHM F351P",223 ,0)
  18156    S:AMT1=""  AMT1=0 S: AMT2="" AM T2=0 S:CHQ TY="" CHQT Y="BLNK"
  18157   "RTN","CHM F351P",224 ,0)
  18158    I $P(X1," ^",1)'=""  S CODE=$P( X1,"^",1), SORT=3 G S RT1
  18159   "RTN","CHM F351P",225 ,0)
  18160    I $P(X1," ^",2)'=""  S CODE=$P( X1,"^",2), AMT1=0,SOR T=1,AMT2=0  G SRT1
  18161   "RTN","CHM F351P",226 ,0)
  18162    I $P(X1," ^",3)'=""  S CODE=$P( X1,"^",3), SORT=2
  18163   "RTN","CHM F351P",227 ,0)
  18164   SRT1 ;Q:CO DE=""  DEV 7820 EW 4/ 4/11
  18165   "RTN","CHM F351P",228 ,0)
  18166    S USEJ=0, FLAG=0
  18167   "RTN","CHM F351P",229 ,0)
  18168    F  S USEJ =$O(CODES( SORT,USEJ) ) Q:'USEJ   D
  18169   "RTN","CHM F351P",230 ,0)
  18170    .;------- ---------- ---DEV7820  EW 2/23/1 1 START
  18171   "RTN","CHM F351P",231 ,0)
  18172    .I $D(COD ES(SORT,US EJ,CODE,AM T1,CHQTY))  D
  18173   "RTN","CHM F351P",232 ,0)
  18174    ..;CLAIM  LINES WHIC H HAVE THE  SAME CODE S,AMOUNTS  AND QUANTI ES (IF THE Y OCCURE)
  18175   "RTN","CHM F351P",233 ,0)
  18176    ..;THESE  LINES ARE  ROLLED UP
  18177   "RTN","CHM F351P",234 ,0)
  18178    ..S FLAG= 1
  18179   "RTN","CHM F351P",235 ,0)
  18180    ..S FLD=$ LISTBUILD( 4,5,10,11, 12,13,14,1 5,17,19,20 ,21,22,23, 24,25)
  18181   "RTN","CHM F351P",236 ,0)
  18182    ..F LCNT= 1:1:16 D
  18183   "RTN","CHM F351P",237 ,0)
  18184    ...S FLDN UM=$LIST(F LD,LCNT)
  18185   "RTN","CHM F351P",238 ,0)
  18186    ...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)
  18187   "RTN","CHM F351P",239 ,0)
  18188    ..S $P(CO DES(SORT,U SEJ,CODE,A MT1,CHQTY) ,"^",28)=R ND ;SET CH AGE/UNIT R OUND INDIC ATOR
  18189   "RTN","CHM F351P",240 ,0)
  18190    ..S (RL,N REJ,LN,DON E)=0
  18191   "RTN","CHM F351P",241 ,0)
  18192    ..F  S RL =$O(REJLN( $J,CODE,AM T1,RL)) Q: (RL="")!(D ONE=1)  D
  18193   "RTN","CHM F351P",242 ,0)
  18194    ...S CHRE SULT1=$P(R EJLN($J,CO DE,AMT1,RL ),"^",1)
  18195   "RTN","CHM F351P",243 ,0)
  18196    ...S CHRE ASN1=$P(RE JLN($J,COD E,AMT1,RL) ,"^",2)
  18197   "RTN","CHM F351P",244 ,0)
  18198    ...S CHAD JAA1=$P(RE JLN($J,COD E,AMT1,RL) ,"^",4)
  18199   "RTN","CHM F351P",245 ,0)
  18200    ...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
  18201   "RTN","CHM F351P",246 ,0)
  18202    ...I (TES T'=CHRESUL T1)!(RESON '=CHREASN1 )!(ADJAA'= CHADJAA1)  S NREJ=1,L N=RL
  18203   "RTN","CHM F351P",247 ,0)
  18204    ..I NREJ= 1 D  ;TEST  FOR NEW T EST OR RES ULT IF SO  ADD TO LIS T
  18205   "RTN","CHM F351P",248 ,0)
  18206    ...S REJL N($J,CODE, AMT1,LN+1) =TEST_"^"_ RESON_"^"_ 1_"^"_ADJA A   ;3 PIE CE IS FOR  QUANTITY
  18207   "RTN","CHM F351P",249 ,0)
  18208    I FLAG=0  S CODES(SO RT,J,CODE, AMT1,CHQTY )=X1,$P(CO DES(SORT,J ,CODE,AMT1 ,CHQTY),"^ ",23)=1 D
  18209   "RTN","CHM F351P",250 ,0)
  18210    .I $P(X1, "^",25)'=" " S $P(COD ES(SORT,J, CODE,AMT1, CHQTY),"^" ,25)=$P(X1 ,"^",25)
  18211   "RTN","CHM F351P",251 ,0)
  18212    .I $P(X1, "^",26)'=" " S $P(COD ES(SORT,J, CODE,AMT1, CHQTY),"^" ,26)=$P(X1 ,"^",26)
  18213   "RTN","CHM F351P",252 ,0)
  18214    .S REJLN( $J,CODE,AM T1,1)=TEST _"^"_RESON _"^"_CHQTY _"^"_ADJAA
  18215   "RTN","CHM F351P",253 ,0)
  18216    Q
  18217   "RTN","CHM F351P",254 ,0)
  18218    ;-------- ---------- -------DEV 7820 EW 2/ 23/11 END
  18219   "RTN","CHM F351P",255 ,0)
  18220   DEDT D DED T^CHMF351U  Q
  18221   "RTN","CHM F351P",256 ,0)
  18222   REOPEN D R EOPEN^CHMF 351U Q
  18223   "RTN","CHM F351P",257 ,0)
  18224   PDIS D PDI S^CHMF351U  Q
  18225   "RTN","CHM F351P",258 ,0)
  18226   REASON D R EASON^CHMF 351U Q
  18227   "RTN","CHM F351P",259 ,0)
  18228   CHECKS D C HECKS^CHMF 351U Q
  18229   "RTN","CHM F351P",260 ,0)
  18230   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
  18231   "RTN","CHM F351P",261 ,0)
  18232    I '$D(DT)   D
  18233   "RTN","CHM F351P",262 ,0)
  18234    .D NOW^%D TC  S DT=X   ; GET CU RRENT DATE
  18235   "RTN","CHM F351P",263 ,0)
  18236    S CHDT=$E (DT,4,7),X =$P($H,"," ,2),H=X\36 00,M=X#360 0\60
  18237   "RTN","CHM F351P",264 ,0)
  18238    S:M<10 M= "0"_M S CH TIME=H_M Q
  18239   "RTN","CHM F351P",265 ,0)
  18240   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 !
  18241   "RTN","CHM F351P",266 ,0)
  18242    ;E  I (($ Y>52)&(J=1 )) W @IOF  D HEAD
  18243   "RTN","CHM F351P",267 ,0)
  18244    S CHTIL=" Actions fo r Claim:"
  18245   "RTN","CHM F351P",268 ,0)
  18246    W:J=1 !!! ,CHTIL,!
  18247   "RTN","CHM F351P",269 ,0)
  18248    W:J#2=1 ! ,?3,J,") " ,X2 Q:J#2= 1
  18249   "RTN","CHM F351P",270 ,0)
  18250    W:J#2'=1  ?43,J,") " ,X2
  18251   "RTN","CHM F351P",271 ,0)
  18252    I '$D(VIE WFL),$Y>59  W @IOF D  HEAD W !!! ,?(40-($L( CHTIL)\2)) ,CHTIL,!
  18253   "RTN","CHM F351P",272 ,0)
  18254    Q
  18255   "RTN","CHM F351P",273 ,0)
  18256    ;-------- ---DEV7820  EW 2/23/1 1 START
  18257   "RTN","CHM F351P",274 ,0)
  18258   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=" "
  18259   "RTN","CHM F351P",275 ,0)
  18260    F LCNT=1: 1:28 D
  18261   "RTN","CHM F351P",276 ,0)
  18262    .S @$LIST (FLD,LCNT) =$P(X1,"^" ,LCNT)
  18263   "RTN","CHM F351P",277 ,0)
  18264    Q
  18265   "RTN","CHM F351P",278 ,0)
  18266    ;-------- ---DEV7820  EW 2/23/1 1 END
  18267   "RTN","CHM FA001")
  18268   0^11^B7272 8138
  18269   "RTN","CHM FA001",1,0 )
  18270   CHMFA001 ; JLR/DEN;DO CUMENT IDE NTIFICATIO N SCREEN;F eb 06, 201 9@10:04:52
  18271   "RTN","CHM FA001",2,0 )
  18272    ;;1.0;CHA MPVA SYSTE M;**1,8,14 **;JULY 4,  1990;Buil d 5
  18273   "RTN","CHM FA001",3,0 )
  18274    ;;CPTS #1 4989 (RLC)
  18275   "RTN","CHM FA001",4,0 )
  18276    ;;MODIFIE D BY RLC O N 4/13/95  - ADDED OP TION 11) P PR
  18277   "RTN","CHM FA001",5,0 )
  18278    ;;MODIFIE D BY RLC O N 4/28/95  - ADDED OP TION 12) P PRs-PDI
  18279   "RTN","CHM FA001",6,0 )
  18280    ; Clear S creen and  establish  values for  screen ou tput varia bles
  18281   "RTN","CHM FA001",7,0 )
  18282    ;CFS 10/0 1/2017 - C PE005-069  Add logic  for Origin al and Cur rent PDI N umber prom pts. The
  18283   "RTN","CHM FA001",8,0 )
  18284    ; menu op tion "ER"  was added  to allow M anual EDI  Re-open pr ocessing.
  18285   "RTN","CHM FA001",9,0 )
  18286    ;CFS 10/0 1/2017 - C PE005-070  Make Origi nal and Cu rrent PDI  Numbers pr ompts Read  Only
  18287   "RTN","CHM FA001",10, 0)
  18288    ; when ne xt screen  is chosen  from the b ottom menu  in Doc ID  Screen
  18289   "RTN","CHM FA001",11, 0)
  18290    ;BDB 01/0 9/2018 CPE 005-121 Au toload ori ginal PDI  to Current  PDI for M anual EDI
  18291   "RTN","CHM FA001",12, 0)
  18292    ;CFS 01/1 3/2018 CPE 005-122 an d 123 Add  call for b ene check  validation .
  18293   "RTN","CHM FA001",13, 0)
  18294    ;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
  18295   "RTN","CHM FA001",14, 0)
  18296    D CLEAR^C HMFADR2 S  CHTITLE="D OCUMENT ID ENTIFICATI ON SCREEN" ,CHSCREEN= ""
  18297   "RTN","CHM FA001",15, 0)
  18298    ; Query C HMSCRN to  return the  screen nu mber based  on the ab ove title
  18299   "RTN","CHM FA001",16, 0)
  18300    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN))
  18301   "RTN","CHM FA001",17, 0)
  18302    ; If ther e is no id entified s creen numb er, output  message t o user and  quit.
  18303   "RTN","CHM FA001",18, 0)
  18304    I 'CHSCRE EN D NOSCR ^CHMFADR2  G END
  18305   "RTN","CHM FA001",19, 0)
  18306    D TITLE^C HMFA100,LI NE^CHMFA10 0,CHOICE^C HMFA100
  18307   "RTN","CHM FA001",20, 0)
  18308    D SCREEN^ CHMFADR2,E RRORS^CHMF A100
  18309   "RTN","CHM FA001",21, 0)
  18310    D NOW^%DT C S CHMFTM BG=%
  18311   "RTN","CHM FA001",22, 0)
  18312   A0 K CHMFC ,CHMFBAD,C HNOFLAG,CH YESFLG,CHM NNUM,CHMFQ UIT
  18313   "RTN","CHM FA001",23, 0)
  18314    ;---Begin  CPE005-06 9
  18315   "RTN","CHM FA001",24, 0)
  18316   A01 I $G(C HOSEN)'=8, $P(^CHMDIC (741002.21 ,DUZ,0),"^ ",10)=0 D  ^CHMFABTH  G:$D(DDOUT ) END
  18317   "RTN","CHM FA001",25, 0)
  18318    K Y
  18319   "RTN","CHM FA001",26, 0)
  18320   ORIGPDI ;C PE005-069  Original P DI Prompt
  18321   "RTN","CHM FA001",27, 0)
  18322    ;I $D(CHM FPREV)!($D (CHMFNEXT) ),$G(CHMOP DI)'="" G  A1
  18323   "RTN","CHM FA001",28, 0)
  18324    I '$D(NEX TPAGE) S N EXTPAGE=0
  18325   "RTN","CHM FA001",29, 0)
  18326    K F1
  18327   "RTN","CHM FA001",30, 0)
  18328    S QU=8
  18329   "RTN","CHM FA001",31, 0)
  18330    I $G(CHOS EN)'=8 G A 1
  18331   "RTN","CHM FA001",32, 0)
  18332    I $G(CHMO PDI)="",'$ G(VALOPDI) ,'$G(VALBE NE) S CHMO PDI=$P(^CH MDIC(74100 2.21,DUZ,0 ),"^",2)
  18333   "RTN","CHM FA001",33, 0)
  18334    I $G(CHMO PDI)'="",' $G(VALOPDI ) D  I '$G (VALOPDI), '$G(VALBEN E) S CHMFI MAG=1 I NE XTPAGE G A 1
  18335   "RTN","CHM FA001",34, 0)
  18336    .S VALOPD I=$$CHKOPD I^CHMFADR2 ($G(CHMFPD I),CHMOPDI ,CHOSEN,1)
  18337   "RTN","CHM FA001",35, 0)
  18338    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
  18339   "RTN","CHM FA001",36, 0)
  18340    G:$D(DFOU T) END
  18341   "RTN","CHM FA001",37, 0)
  18342    I $D(DQOU T) S Y="?"  D QUES^CH MFADR2,WTO PDI^CHMFAD R2 G ORIGP DI
  18343   "RTN","CHM FA001",38, 0)
  18344    I $D(DUOU T) D WTOPD I^CHMFADR2  G END
  18345   "RTN","CHM FA001",39, 0)
  18346    I $D(D1OU T) G ORIGP DI
  18347   "RTN","CHM FA001",40, 0)
  18348    I $D(DDOU T),$D(CHMO PDI) D WTO PDI^CHMFAD R2 G END
  18349   "RTN","CHM FA001",41, 0)
  18350    I $D(DDOU T) G END
  18351   "RTN","CHM FA001",42, 0)
  18352    ;I Y="",$ G(CHMOPDI) '="" S Y=C HMOPDI
  18353   "RTN","CHM FA001",43, 0)
  18354    ;I Y'=""  S CHMOPDI= Y
  18355   "RTN","CHM FA001",44, 0)
  18356    D CHECK^C HMFADR2 I  $G(F1)=1 G  ORIGPDI
  18357   "RTN","CHM FA001",45, 0)
  18358    I $G(CHMO PDI)'="",' $G(VALOPDI ) D WTOPDI ^CHMFADR2  G A1
  18359   "RTN","CHM FA001",46, 0)
  18360    I CHMOPDI ="",'$G(VA LOPDI) D C LEARB^CHMF ADR2 G ORI GPDI
  18361   "RTN","CHM FA001",47, 0)
  18362   A1 K F0,F1  G:$P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=1  A2
  18363   "RTN","CHM FA001",48, 0)
  18364    ;I $D(CHM FPREV)!($D (CHMFNEXT) ),$G(CHMFP DI)'="" G  A2
  18365   "RTN","CHM FA001",49, 0)
  18366    I $G(CHMF PDI)'="",' $G(VALOPDI ) D  I '$G (VALOPDI), '$G(VALBEN E) S CHMFI MAG=1 I NE XTPAGE G A 2
  18367   "RTN","CHM FA001",50, 0)
  18368    .S VALOPD I=$$CHKOPD I^CHMFADR2 ($G(CHMFPD I),CHMOPDI ,CHOSEN,1)
  18369   "RTN","CHM FA001",51, 0)
  18370    I CHOSEN' =8 D  ;Not  needed fo r Manual R e-open. Ba tch number  not used.
  18371   "RTN","CHM FA001",52, 0)
  18372    .I $D(CHB TCHNO) I C HBTCHNO I  $D(^CHMIMP B(CHBTCHNO )) D ^CHMF A004
  18373   "RTN","CHM FA001",53, 0)
  18374    ;I $D(CHM FPDI) I CH MFPDI'=""  D WTPDI^CH MFADR2 G A 2
  18375   "RTN","CHM FA001",54, 0)
  18376    S QU=$S(C HOSEN=8:9, 1:1)
  18377   "RTN","CHM FA001",55, 0)
  18378    ;---End C PE005-069
  18379   "RTN","CHM FA001",56, 0)
  18380    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
  18381   "RTN","CHM FA001",57, 0)
  18382    I $D(DQOU T) D QUES^ CHMFADR2,W TPDI^CHMFA DR2 G A1
  18383   "RTN","CHM FA001",58, 0)
  18384    I $D(DUOU T) D WTPDI ^CHMFADR2  G END
  18385   "RTN","CHM FA001",59, 0)
  18386    I CHOSEN' =8,$D(D1OU T) D WTPDI ^CHMFADR2  S $P(^CHMD IC(741002. 21,DUZ,0), "^",10)=0  G A01
  18387   "RTN","CHM FA001",60, 0)
  18388    I $D(DDOU T) G END
  18389   "RTN","CHM FA001",61, 0)
  18390    I CHOSEN' =8,Y="" D  CLEARB^CHM FADR2 G A1
  18391   "RTN","CHM FA001",62, 0)
  18392    I CHOSEN= 8,Y="",$G( CHMFPDI)'= "" S Y=CHM FPDI
  18393   "RTN","CHM FA001",63, 0)
  18394    D CHECK^C HMFADR2 I  $G(F1)=1 S  CHMFPDI=Y  G A1
  18395   "RTN","CHM FA001",64, 0)
  18396    I $P($G(^ CHMIMAGE(" LOCK",CHMF PDI)),"^") =DUZ K ^CH MIMAGE("LO CK",CHMFPD I)
  18397   "RTN","CHM FA001",65, 0)
  18398    I CHOSEN' =8 D
  18399   "RTN","CHM FA001",66, 0)
  18400    .D CLEARB ^CHMFADR2  I '$D(^CHM IMG(Y)) S  CHMFPDI=""  D ERR3^CH MFADR2 G A 1
  18401   "RTN","CHM FA001",67, 0)
  18402    .I $D(^CH MPAY("C",Y )) D ERR1^ CHMFADR2 S  CHMFPDI=" " K CHMNNU M S CHMFNM PG="" G A1
  18403   "RTN","CHM FA001",68, 0)
  18404    .I $D(^CH NVPAY("C", Y)) D ERR1 ^CHMFADR2  S CHMFPDI= "" K CHMNN UM S CHMFN MPG="" G A 1
  18405   "RTN","CHM FA001",69, 0)
  18406    .S ZIMGST ="" S:$D(^ CHMIMG(Y,0 )) ZIMGST= $P(^(0),"^ ",6)
  18407   "RTN","CHM FA001",70, 0)
  18408    .I ZIMGST >2 D ERR1^ CHMFADR2 S  CHMFPDI=" " K CHMNNU M S CHMFNM PG="" G A1
  18409   "RTN","CHM FA001",71, 0)
  18410    I CHMFPDI '="" I $D( ^CHMIMAGE( "LOCK",CHM FPDI)) D L OCK^CHMFAD R2 K CHMNN UM S CHMFN MPG="" G A 1
  18411   "RTN","CHM FA001",72, 0)
  18412    S:CHMFPDI '="" ^CHMI MAGE("LOCK ",CHMFPDI) =DUZ D WTP DI^CHMFADR 2,CLEARB^C HMFADR2
  18413   "RTN","CHM FA001",73, 0)
  18414    D INPRC^C HMFIMG
  18415   "RTN","CHM FA001",74, 0)
  18416   A2 D IMAGE ^CHMFADR2
  18417   "RTN","CHM FA001",75, 0)
  18418    ;I $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",10)= 1 S:CHMFNM PG="" CHMF NMPG="UNK"  D WTNP^CH MFADR2 G A 3
  18419   "RTN","CHM FA001",76, 0)
  18420    S:'$D(CHM FNMPG) CHM FNMPG=""
  18421   "RTN","CHM FA001",77, 0)
  18422    I $G(CHMF PDI)'="",$ D(^CHMIMG( CHMFPDI,0) ) S:CHMFNM PG="" CHMF NMPG=$P(^( 0),"^",2)
  18423   "RTN","CHM FA001",78, 0)
  18424    I $D(CHMF NMPG) I CH MFNMPG'=""  D WTNP^CH MFADR2 G A 3
  18425   "RTN","CHM FA001",79, 0)
  18426    S:'$D(CHM FNMPG) CHM FNMPG=""
  18427   "RTN","CHM FA001",80, 0)
  18428    S:CHMFNMP G="" CHMFN MPG="UNK"
  18429   "RTN","CHM FA001",81, 0)
  18430    S QU=2 D  WTNP^CHMFA DR2 S DX=4 1,$X=DX X  XY D CSBRS ^CHSC2 W:Y '="" @CHEO L
  18431   "RTN","CHM FA001",82, 0)
  18432    G:$D(DFOU T) END I $ D(DQOUT) D  QUES^CHMF ADR2,WTNP^ CHMFADR2 G  A1
  18433   "RTN","CHM FA001",83, 0)
  18434    I $D(DUOU T) D WTNP^ CHMFADR2 G  END
  18435   "RTN","CHM FA001",84, 0)
  18436    I $D(D1OU T) D CHECK ^CHMFADR2, WTNP^CHMFA DR2 G A1
  18437   "RTN","CHM FA001",85, 0)
  18438    I $D(DDOU T) D WTNP^ CHMFADR2 G  END
  18439   "RTN","CHM FA001",86, 0)
  18440    I Y="" D  CLEARB^CHM FADR2 G A3
  18441   "RTN","CHM FA001",87, 0)
  18442    D CHECK^C HMFADR2 G: $D(F1) A2  D WTNP^CHM FADR2,CLEA RB^CHMFADR 2
  18443   "RTN","CHM FA001",88, 0)
  18444   A3 S QU=3  D WTPG^CHM FADR2 S DX =41,$X=DX  X XY D CSB RS^CHSC2 W :Y'="" @CH EOL
  18445   "RTN","CHM FA001",89, 0)
  18446    G:$D(DFOU T) END I $ D(DQOUT) D  QUES^CHMF ADR2,WTPG^ CHMFADR2 G  A1
  18447   "RTN","CHM FA001",90, 0)
  18448    I $D(DUOU T) D WTPG^ CHMFADR2 G  A3
  18449   "RTN","CHM FA001",91, 0)
  18450    I $D(D1OU T) D CHECK ^CHMFADR2, WTPG^CHMFA DR2 G A3
  18451   "RTN","CHM FA001",92, 0)
  18452    I $D(DDOU T) D CHECK ^CHMFADR2  G:$D(F1) A 3 D WTPG^C HMFADR2 G  END
  18453   "RTN","CHM FA001",93, 0)
  18454    D CHECK^C HMFADR2 G: $D(F1) A3  D WTPG^CHM FADR2,CLEA RB^CHMFADR 2
  18455   "RTN","CHM FA001",94, 0)
  18456   A4 S CHMFI MAG=1
  18457   "RTN","CHM FA001",95, 0)
  18458    N VALBENE
  18459   "RTN","CHM FA001",96, 0)
  18460    S VALBENE =$$BENECHK ^CHMFADR2( CHMOPDI,CH MFPDI,CHOS EN,1)  ;CP E005-122 a nd 123
  18461   "RTN","CHM FA001",97, 0)
  18462    I VALBENE  G ORIGPDI
  18463   "RTN","CHM FA001",98, 0)
  18464    ;S QU=4 D  WTIM^CHMF ADR2 S DX= 41 X XY D  CSBRS^CHSC 2
  18465   "RTN","CHM FA001",99, 0)
  18466    ;G:$D(DFO UT) END I  $D(DQOUT)  D QUES^CHM FADR2,WTIM ^CHMFADR2  G A4
  18467   "RTN","CHM FA001",100 ,0)
  18468    ;I $D(DUO UT) D WTIM ^CHMFADR2  G A3
  18469   "RTN","CHM FA001",101 ,0)
  18470    ;I $D(D1O UT) D CHEC K^CHMFADR2  G:$D(F1)  A4 D WTIM^ CHMFADR2 G  A3
  18471   "RTN","CHM FA001",102 ,0)
  18472    ;I $D(DDO UT) D CHEC K^CHMFADR2  G:$D(F1)  A4 D WTIM^ CHMFADR2 G  END
  18473   "RTN","CHM FA001",103 ,0)
  18474    ;D CHECK^ CHMFADR2 G :$D(F1) A4  D WTIM^CH MFADR2,CLE ARB^CHMFAD R2
  18475   "RTN","CHM FA001",104 ,0)
  18476   A6 S QU=6  D WTTYPE^C HMFADR2 S  DX=41,$X=D X X XY D C SBRS^CHSC2
  18477   "RTN","CHM FA001",105 ,0)
  18478    G:$D(DFOU T) END I $ D(DQOUT) S  Y="?" D C HECK^CHMFA DR2 G A6
  18479   "RTN","CHM FA001",106 ,0)
  18480    I $D(DUOU T) D WTTYP E^CHMFADR2  G A3
  18481   "RTN","CHM FA001",107 ,0)
  18482    I $D(D1OU T) D CHECK ^CHMFADR2  G:$D(F1) A 6 D WTTYPE ^CHMFADR2  G A3
  18483   "RTN","CHM FA001",108 ,0)
  18484    I $D(DDOU T) D CHECK ^CHMFADR2  G:$D(F1) A 6 D WTTYPE ^CHMFADR2  G END
  18485   "RTN","CHM FA001",109 ,0)
  18486    D CHECK^C HMFADR2 G: $D(F1) A6  D WTTYPE^C HMFADR2,CL EARB^CHMFA DR2 G ORIG PDI
  18487   "RTN","CHM FA001",110 ,0)
  18488   END D CLEA RB^CHMFADR 2
  18489   "RTN","CHM FA001",111 ,0)
  18490   E1 K NP,CH MFBAD,CHYE SFLG,CHMFK IL,CHMFSOR T,CHMFPRV, CHMFPS,CHM FPAUS,CHMF EXIT,CHMFB DBK
  18491   "RTN","CHM FA001",112 ,0)
  18492    N VALBENE ,VALOPDI
  18493   "RTN","CHM FA001",113 ,0)
  18494    D PRMPT^C HMFA100,AS K^CHMFA100  D CLEARB^ CHMFADR2 S  CHOICE=Y  G:CHOICE=1  A0
  18495   "RTN","CHM FA001",114 ,0)
  18496    G:CHOICE= 5 E1
  18497   "RTN","CHM FA001",115 ,0)
  18498    I CHOICE= 7 D  G E1
  18499   "RTN","CHM FA001",116 ,0)
  18500    .S DY=22, DX=10,$Y=D Y,$X=DX X  XY W @CHEO L
  18501   "RTN","CHM FA001",117 ,0)
  18502    .S DY=22, DX=22,$Y=D Y,$X=DX X  XY W "**** * This opt ion is not  available . *****" R  X:5
  18503   "RTN","CHM FA001",118 ,0)
  18504    .S DY=22, DX=10,$Y=D Y,$X=DX X  XY W @CHEO L
  18505   "RTN","CHM FA001",119 ,0)
  18506    S:CHOICE= 4 CHMFKIL= 1
  18507   "RTN","CHM FA001",120 ,0)
  18508    I CHOICE= 8 I CHMFPD I="" D NOP AUS^CHMFAD R2 G E1
  18509   "RTN","CHM FA001",121 ,0)
  18510    I CHOICE= 8 I CHMFPD I'=""  S C HMFPAUS=1
  18511   "RTN","CHM FA001",122 ,0)
  18512    I CHOICE= 9 D  G:$G( VALOPDI)!$ G(VALBENE)  E1 D ^CHM FA005 G EN D
  18513   "RTN","CHM FA001",123 ,0)
  18514    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q   ;CPE005-06 9
  18515   "RTN","CHM FA001",124 ,0)
  18516    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1)  ;C PE005-122  and 123
  18517   "RTN","CHM FA001",125 ,0)
  18518    I CHOICE= 6 D BDIMCK  G:$D(CHMF BDBK) E1 S  CHMFBAD=1  D ^CHMFAB IM
  18519   "RTN","CHM FA001",126 ,0)
  18520    I CHOICE= 10 D  G:$G (VALOPDI)! ($G(VALBEN E)) E1
  18521   "RTN","CHM FA001",127 ,0)
  18522    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q   ;CPE005-06 9
  18523   "RTN","CHM FA001",128 ,0)
  18524    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1)  ;C PE005-122  and 123
  18525   "RTN","CHM FA001",129 ,0)
  18526    I CHOICE= 10 I '$D(C HBTCHNO) D  NOBTCH^CH MFADR2 G E 1
  18527   "RTN","CHM FA001",130 ,0)
  18528    I CHOICE= 10 I CHBTC HNO="" D N OBTCH^CHMF ADR2 G E1
  18529   "RTN","CHM FA001",131 ,0)
  18530    I CHOICE= 10 D ^CHMF AB2 D  G E 1
  18531   "RTN","CHM FA001",132 ,0)
  18532    .I $D(CHB TCHNO) I C HBTCHNO'=" " I $$BTCH ST^CHMFABU 3(CHBTCHNO )=1 D
  18533   "RTN","CHM FA001",133 ,0)
  18534    ..S $P(^C HMDIC(7410 02.21,DUZ, 0),"^",6)= ""
  18535   "RTN","CHM FA001",134 ,0)
  18536    ..S $P(^C HMIMPB(CHB TCHNO,0)," ^",6)=""
  18537   "RTN","CHM FA001",135 ,0)
  18538    ..S CHMFP P="BATCLSD ",CHMFI=CH BTCHNO D ^ CHMFWK03
  18539   "RTN","CHM FA001",136 ,0)
  18540    ..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
  18541   "RTN","CHM FA001",137 ,0)
  18542    ..S CHBTC HNO="",CHM FPDI=""
  18543   "RTN","CHM FA001",138 ,0)
  18544    .S CHMFPD I="",CHMFN MPG="" D L INE^CHMFA1 00,SCREEN^ CHMFADR2
  18545   "RTN","CHM FA001",139 ,0)
  18546    I CHOICE= 3 I CHMFPD I'="" D  G :$G(VALOPD I)!$G(VALB ENE) E1 S  CHMFSORT=1
  18547   "RTN","CHM FA001",140 ,0)
  18548    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q   ;CPE005-06 9
  18549   "RTN","CHM FA001",141 ,0)
  18550    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1) I V ALBENE Q   ;CPE005-12 2 and 123
  18551   "RTN","CHM FA001",142 ,0)
  18552    .S X="" S :$D(^CHMIM AGE(CHMFPD I,0)) X=^( 0)
  18553   "RTN","CHM FA001",143 ,0)
  18554    .S $P(X," ^",1)=CHMF PDI,$P(X," ^",2)=CHMF NMPG,$P(X, "^",3)=DUZ
  18555   "RTN","CHM FA001",144 ,0)
  18556    .S $P(X," ^",4)=CHMF TMBG,PDIFL =1
  18557   "RTN","CHM FA001",145 ,0)
  18558    .S ^CHMIM AGE(CHMFPD I,0)=X,^CH MIMAGE("B" ,CHMFPDI,C HMFPDI)=""
  18559   "RTN","CHM FA001",146 ,0)
  18560    .I $P(^CH MIMG(CHMFP DI,0),"^", 4)="" S $P (^CHMIMG(C HMFPDI,0), "^",3)=DUZ ,$P(^CHMIM G(CHMFPDI, 0),"^",4)= CHMFTMBG
  18561   "RTN","CHM FA001",147 ,0)
  18562    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=DUZ
  18563   "RTN","CHM FA001",148 ,0)
  18564    .I '$D(^C HMIMG(CHMF PDI,"PAUSE ")) S $P(^ CHMIMG(CHM FPDI,0),"^ ",4)=CHMFT MBG
  18565   "RTN","CHM FA001",149 ,0)
  18566    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
  18567   "RTN","CHM FA001",150 ,0)
  18568    .I CHOSEN '=8 S CHMO PDI="XXXX"
  18569   "RTN","CHM FA001",151 ,0)
  18570    .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
  18571   "RTN","CHM FA001",152 ,0)
  18572    .K NP I ( CHMFPDI="" )!(CHMOPDI ="")!(CHMF IMAG="")!( CHMFIMTY=" ")!(CHMFPG NM="") S N P="" D NOD ATA^CHMFAD R2 Q
  18573   "RTN","CHM FA001",153 ,0)
  18574    .I CHOSEN '=8,CHMOPD I="XXXX" S  CHMOPDI=" "
  18575   "RTN","CHM FA001",154 ,0)
  18576    .S VALOPD I=$$CHKOPD I^CHMFADR2 (CHMFPDI,C HMOPDI,CHO SEN,1) I V ALOPDI Q   ;CPE005-06 9
  18577   "RTN","CHM FA001",155 ,0)
  18578    .S VALBEN E=$$BENECH K^CHMFADR2 (CHMOPDI,C HMFPDI,CHO SEN,1) I V ALBENE Q   ;CPE005-12 2 and 123
  18579   "RTN","CHM FA001",156 ,0)
  18580    .I CHOSEN =8 D LOADI MG^CHMFADR 2 ;CPE005- 121 BDB 1/ 9/2018
  18581   "RTN","CHM FA001",157 ,0)
  18582    I CHOICE= 11 D  G E1
  18583   "RTN","CHM FA001",158 ,0)
  18584    .S HCHMFP DI=CHMFPDI
  18585   "RTN","CHM FA001",159 ,0)
  18586    .D ^CHMKP PR1
  18587   "RTN","CHM FA001",160 ,0)
  18588    .S CHMFPD I=HCHMFPDI
  18589   "RTN","CHM FA001",161 ,0)
  18590    .D RNGECL R^CHSC1(1, 18,XY,CHEO L)
  18591   "RTN","CHM FA001",162 ,0)
  18592    .D SETUP^ CHMFADR1
  18593   "RTN","CHM FA001",163 ,0)
  18594    .S CHTITL E="DOCUMEN T IDENTIFI CATION SCR EEN",CHSCR EEN=""
  18595   "RTN","CHM FA001",164 ,0)
  18596    .S CHSCRE EN=$O(^CHM SCRN("B",C HTITLE,CHS CREEN))
  18597   "RTN","CHM FA001",165 ,0)
  18598    .D TITLE^ CHMFA100,L INE^CHMFA1 00,CHOICE^ CHMFA100
  18599   "RTN","CHM FA001",166 ,0)
  18600    .D SCREEN ^CHMFADR2, ERRORS^CHM FA100
  18601   "RTN","CHM FA001",167 ,0)
  18602    I CHOICE= 12 D  G E1
  18603   "RTN","CHM FA001",168 ,0)
  18604    .S HCHMFP DI=CHMFPDI
  18605   "RTN","CHM FA001",169 ,0)
  18606    .D ^CHMKP DI1
  18607   "RTN","CHM FA001",170 ,0)
  18608    .S CHMFPD I=HCHMFPDI
  18609   "RTN","CHM FA001",171 ,0)
  18610    .D RNGECL R^CHSC1(1, 18,XY,CHEO L)
  18611   "RTN","CHM FA001",172 ,0)
  18612    .D SETUP^ CHMFADR1
  18613   "RTN","CHM FA001",173 ,0)
  18614    .S CHTITL E="DOCUMEN T IDENTIFI CATION SCR EEN",CHSCR EEN=""
  18615   "RTN","CHM FA001",174 ,0)
  18616    .S CHSCRE EN=$O(^CHM SCRN("B",C HTITLE,CHS CREEN))
  18617   "RTN","CHM FA001",175 ,0)
  18618    .D TITLE^ CHMFA100,L INE^CHMFA1 00,CHOICE^ CHMFA100
  18619   "RTN","CHM FA001",176 ,0)
  18620    .D SCREEN ^CHMFADR2, ERRORS^CHM FA100
  18621   "RTN","CHM FA001",177 ,0)
  18622    Q
  18623   "RTN","CHM FA001",178 ,0)
  18624    ;
  18625   "RTN","CHM FA001",179 ,0)
  18626   BDIMCK K C HMFBDBK
  18627   "RTN","CHM FA001",180 ,0)
  18628    I $D(^CHM DIC(741002 .21,DUZ,0) ) I $P(^(0 ),"^",10)= 1 Q
  18629   "RTN","CHM FA001",181 ,0)
  18630    S DY=22,D X=10,$Y=DY ,$X=DX X X Y W @CHEOL
  18631   "RTN","CHM FA001",182 ,0)
  18632    S DY=22,D X=22,$Y=DY ,$X=DX X X Y W "***** This optio n is not a vailable.* ****" R X: 5
  18633   "RTN","CHM FA001",183 ,0)
  18634    S DY=22,D X=10,$Y=DY ,$X=DX X X Y W @CHEOL
  18635   "RTN","CHM FA001",184 ,0)
  18636    S CHMFBDB K=""
  18637   "RTN","CHM FA001",185 ,0)
  18638    Q
  18639   "RTN","CHM FA001",186 ,0)
  18640    ;
  18641   "RTN","CHM FA001",187 ,0)
  18642    D CSBRS^C HSC2   S Y ="" U $I X  ^%ZOSF("E OFF") K TL
  18643   "RTN","CHM FA001",188 ,0)
  18644    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)
  18645   "RTN","CHM FA001",189 ,0)
  18646    .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
  18647   "RTN","CHM FA001",190 ,0)
  18648    D CSBRS^C HSC21  K D FOUT,DUOUT ,DQOUT,DDO UT,D1OUT,D 2OUT
  18649   "RTN","CHM FA001",191 ,0)
  18650    I X=27 F  I=1:1:2 R  *X D:I=2
  18651   "RTN","CHM FA001",192 ,0)
  18652    .S:X=65 D 1OUT="" S: X=66 D2OUT =""
  18653   "RTN","CHM FA001",193 ,0)
  18654    S:X=9 DDO UT="" S:X= 9 DTOUT=""  I Y="^^"  S (DFOUT,Y )=""
  18655   "RTN","CHM FA001",194 ,0)
  18656    S:Y="^" ( DUOUT,Y)=" " S:Y?1"?" .E!(Y["^")  (DQOUT,Y) =""
  18657   "RTN","CHM FA001",195 ,0)
  18658    U $I X ^% ZOSF("EON" ) Q
  18659   "RTN","CHM FA010")
  18660   0^43^B1832 88112
  18661   "RTN","CHM FA010",1,0 )
  18662   CHMFA010 ; JLR/DEN;VE NDOR/INVOI CE DATA SC REEN;Feb 0 6, 2019@10 :09:48
  18663   "RTN","CHM FA010",2,0 )
  18664    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  18665   "RTN","CHM FA010",3,0 )
  18666    ;;2;Vendo r Invoice; ;Dec 21,20 09
  18667   "RTN","CHM FA010",4,0 )
  18668    ;PT'S - 1 0513*
  18669   "RTN","CHM FA010",5,0 )
  18670    ;CPTS #10 846* - PEJ  8/15/96
  18671   "RTN","CHM FA010",6,0 )
  18672    ;TEAM TRA CK #312 RK N 12/11/20 06....SEE  LINE TAGS  CVFN1 AND  CVFN2
  18673   "RTN","CHM FA010",7,0 )
  18674    ;TT MTN00 1142 JEH 1 2/16/06 -  FIX FOR NO  VALUE IN  VTAXID
  18675   "RTN","CHM FA010",8,0 )
  18676    ;jsg;DEV0 02841-02;0 5/12/09;Au to Vendor  Selection  Process;
  18677   "RTN","CHM FA010",9,0 )
  18678    ;DEV00369 8 4/30/201 0 AEB
  18679   "RTN","CHM FA010",10, 0)
  18680    ;DEV00799 1 10/08/20 10 JAK --V ENDOR LOOK UP utilizi ng NPI
  18681   "RTN","CHM FA010",11, 0)
  18682    ;BUG00487 4 12/09/10  DRW - cha nge POP-UP  for user  action (2  places).   The first  pop-up is  associated
  18683   "RTN","CHM FA010",12, 0)
  18684    ;;with an y OCR clai ms and the  second po p-up is fo r any-non  OCR.
  18685   "RTN","CHM FA010",13, 0)
  18686    ;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
  18687   "RTN","CHM FA010",14, 0)
  18688    ;DEF01373 6 2/14/201 2 BMJ
  18689   "RTN","CHM FA010",15, 0)
  18690    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  18691   "RTN","CHM FA010",16, 0)
  18692    ;CPE001-0 02 7/27/17  & 8/3/17  WTC
  18693   "RTN","CHM FA010",17, 0)
  18694    ;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.
  18695   "RTN","CHM FA010",18, 0)
  18696   A   ;LINE  TAG ADDED  BY PAT WIL L NEED TO  TAKE OUT
  18697   "RTN","CHM FA010",19, 0)
  18698    K CHMVEN, DSPFLG,CHS UM
  18699   "RTN","CHM FA010",20, 0)
  18700    D CLEAR
  18701   "RTN","CHM FA010",21, 0)
  18702    D ^CHMFA0 06
  18703   "RTN","CHM FA010",22, 0)
  18704    I CHTYPIN T=2 D ^CHM FA030 G EN D
  18705   "RTN","CHM FA010",23, 0)
  18706    S CHPDIPR L=$$PDITYP ^CHMFAUT1( CHMFPDI)
  18707   "RTN","CHM FA010",24, 0)
  18708       ;
  18709   "RTN","CHM FA010",25, 0)
  18710   CVFN1   ;  ////////// /////////  CHECKS EXI STANCE OF  VENDOR ID  ////////// //////  12 /12/2006 T T # 312 RK N
  18711   "RTN","CHM FA010",26, 0)
  18712       ;CODE  REMARKED O UT PER CPD  (CHARLES  GUSTAFSON)  12/26/200 6 RKN
  18713   "RTN","CHM FA010",27, 0)
  18714       ;TT #  MTN001137- 01: 6875 -  OCR SELEC TING WRONG  VENDOR  1 2/26/2006  RKN
  18715   "RTN","CHM FA010",28, 0)
  18716       ;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
  18717   "RTN","CHM FA010",29, 0)
  18718       ;I $D( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN")) D
  18719   "RTN","CHM FA010",30, 0)
  18720       ;.I $P (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"VEN"),"^ ",1)'>"0"  D CVFN2
  18721   "RTN","CHM FA010",31, 0)
  18722       ;.Q
  18723   "RTN","CHM FA010",32, 0)
  18724       ;
  18725   "RTN","CHM FA010",33, 0)
  18726    K ASVFLG    ;jbm; CR #9223; Nee d this var ibles init ialized
  18727   "RTN","CHM FA010",34, 0)
  18728    I CHPDIPR L D  G:VFN  A4
  18729   "RTN","CHM FA010",35, 0)
  18730    .S VFN="" ,CHXTID=""
  18731   "RTN","CHM FA010",36, 0)
  18732    .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
  18733   "RTN","CHM FA010",37, 0)
  18734    .I $D(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"VE N")) D
  18735   "RTN","CHM FA010",38, 0)
  18736    ..S VFN=$ P(^("VEN") ,"^",1)
  18737   "RTN","CHM FA010",39, 0)
  18738    ..S CHXTI DPT=$P(^(" VEN"),"^", 14)
  18739   "RTN","CHM FA010",40, 0)
  18740    ..S CHXTI D=$P(^CHMI MAGE(CHMFP DI,"P-VEN" ,CHXTIDPT, 0),"^",5)
  18741   "RTN","CHM FA010",41, 0)
  18742    .;jsg;DEV 002841;5/1 2/09;Was 1  vendor au to selecte d?  If so,  get vendo r data:
  18743   "RTN","CHM FA010",42, 0)
  18744    .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;
  18745   "RTN","CHM FA010",43, 0)
  18746    ..S VFN=^ CHMIMAGE(C HMFPDI,100 ,1,0),ASVF LG=VFN K D SPFLG        ;jsg;DEV 002841;5/1 2/09;
  18747   "RTN","CHM FA010",44, 0)
  18748    .I VFN=""  I $D(CHXT ID) I CHXT ID'="" D   Q
  18749   "RTN","CHM FA010",45, 0)
  18750    ..S:$L(CH XTID)>9 CH XTID=$E(CH XTID,1,9)_ "*"_$E(CHX TID,10,11)
  18751   "RTN","CHM FA010",46, 0)
  18752    ..D GETDA TA
  18753   "RTN","CHM FA010",47, 0)
  18754    ..D ^CHMF A01D
  18755   "RTN","CHM FA010",48, 0)
  18756    ..I $P(RE C1,"^",7)= 88 D    ;J PN CR 4874  ELIMENATE  OPTION FO R MEDICADE
  18757   "RTN","CHM FA010",49, 0)
  18758    ...S TX=2 5,TY=11,BX =75,BY=20, VON="",VOF F="" D BOX F^CHSC1(TX ,TY,BX,BY)
  18759   "RTN","CHM FA010",50, 0)
  18760    ...D CLRB OXI^CHSC1( TX,TY,BX,B Y,XY,VON,V OFF)
  18761   "RTN","CHM FA010",51, 0)
  18762    ...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
  18763   "RTN","CHM FA010",52, 0)
  18764    ...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
  18765   "RTN","CHM FA010",53, 0)
  18766    ...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
  18767   "RTN","CHM FA010",54, 0)
  18768    ...S MEDT EST=""                                                               ;BUG004 874 DRW/BM J - set ME DTEST trig ger to pos itvie - 05 /17/11
  18769   "RTN","CHM FA010",55, 0)
  18770    ...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
  18771   "RTN","CHM FA010",56, 0)
  18772    ..Q
  18773   "RTN","CHM FA010",57, 0)
  18774    .I VFN=""  D  I VFN  S DSPFLG=" "
  18775   "RTN","CHM FA010",58, 0)
  18776    ..S OLDPG NM=$O(^CHM IMAGE(CHMF PDI,1,CHMF PGNM),-1)
  18777   "RTN","CHM FA010",59, 0)
  18778    ..I OLDPG NM'="" I $ D(^CHMIMAG E(CHMFPDI, 1,OLDPGNM, 2,CHMFIMAG ,"VEN")) D
  18779   "RTN","CHM FA010",60, 0)
  18780    ...S VFN= $P(^("VEN" ),"^",1)
  18781   "RTN","CHM FA010",61, 0)
  18782    ...S CHMF BASC(6)=$P (^("VEN"), "^",7)
  18783   "RTN","CHM FA010",62, 0)
  18784    ...S CHMF BASC(7)=$P (^("VEN"), "^",17)
  18785   "RTN","CHM FA010",63, 0)
  18786    ...S CHMF BASC(2)=$P (^("VEN"), "^",2)
  18787   "RTN","CHM FA010",64, 0)
  18788    ...;CPE V ENDOR STRE AMLINING U SER STORY  2 PL-ZIP 0 6/01/2017  - default  PL-ZIP for  EDI claim s GEF
  18789   "RTN","CHM FA010",65, 0)
  18790    ...S:$G(C HMFBASC(8) )="" CHMFB ASC(8)=$$Z IPDF(CHMFP DI,$G(VFN) )
  18791   "RTN","CHM FA010",66, 0)
  18792    ...S X=$P (^CHMIMAGE (CHMFPDI,1 ,OLDPGNM,2 ,CHMFIMAG, "VEN"),"^" ,1)
  18793   "RTN","CHM FA010",67, 0)
  18794    ...I 'X S  CHMFBASC( 1)="" G A0 0
  18795   "RTN","CHM FA010",68, 0)
  18796    ...I '$D( ^CHMVEN(X, 0)) S CHMF BASC(1)=""  G A00
  18797   "RTN","CHM FA010",69, 0)
  18798    ...S CHMF BASC(1)=$P (^CHMVEN(X ,0),"^",1) _"^"_X
  18799   "RTN","CHM FA010",70, 0)
  18800   A00 ...I $ D(^CHMIMAG E(CHMFPDI, 1,OLDPGNM, 2,CHMFIMAG ,"AII")) D
  18801   "RTN","CHM FA010",71, 0)
  18802    ....S CHM FBASC(3)=$ P(^("AII") ,"^",4),CH MFBASC(4)= ""
  18803   "RTN","CHM FA010",72, 0)
  18804    .I VFN D
  18805   "RTN","CHM FA010",73, 0)
  18806    ..D ^CHMF SET X CHRE SET D HEAD ^CHMFA100
  18807   "RTN","CHM FA010",74, 0)
  18808    ..S DTM=9 ,DBM=20 X  CHMAR D TI TLE K PV
  18809   "RTN","CHM FA010",75, 0)
  18810    ..F DY=4: 1:20 S DX= 1,$X=DX X  XY W @CHEO L
  18811   "RTN","CHM FA010",76, 0)
  18812    ..D VEN S  DY=4,DX=1 8,$Y=DY,$X =DX X XY W  @CHBON
  18813   "RTN","CHM FA010",77, 0)
  18814    ..D:'$D(D SPFLG) GET DATA
  18815   "RTN","CHM FA010",78, 0)
  18816    ..;D CLEA R
  18817   "RTN","CHM FA010",79, 0)
  18818    ..D DISP
  18819   "RTN","CHM FA010",80, 0)
  18820    ..D DISP^ CHMFA013
  18821   "RTN","CHM FA010",81, 0)
  18822    ..D DATA^ CHMFA013
  18823   "RTN","CHM FA010",82, 0)
  18824    ..S BLNK2 ="" S $P(B LNK2," ",3 1)=""
  18825   "RTN","CHM FA010",83, 0)
  18826    ..K DSPFL G
  18827   "RTN","CHM FA010",84, 0)
  18828   A0 D TITLE  K PV
  18829   "RTN","CHM FA010",85, 0)
  18830   A1 F DY=4: 1:20 S DX= 1,$X=DX X  XY W @CHEO L
  18831   "RTN","CHM FA010",86, 0)
  18832    D VEN S D Y=4,DX=18, $Y=DY,$X=D X X XY W @ CHBON
  18833   "RTN","CHM FA010",87, 0)
  18834    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
  18835   "RTN","CHM FA010",88, 0)
  18836   A2 W @CHBO FF S VFN=$ P(CHMFBASC (1),"^",2)
  18837   "RTN","CHM FA010",89, 0)
  18838    D DISP,DI SP^CHMFA01 3,DATA^CHM FA013
  18839   "RTN","CHM FA010",90, 0)
  18840   A3 D ^CHMF A01D
  18841   "RTN","CHM FA010",91, 0)
  18842    ;I $D(MED TEST) K ME DTEST G A4      ;Remo ve line DE F013736 2/ 24/2012 BM J
  18843   "RTN","CHM FA010",92, 0)
  18844    I $P(REC1 ,"^",7)=88  D  G A ;J PN CR 4874  ELIMENATE  OPTION FO R MEDICADE
  18845   "RTN","CHM FA010",93, 0)
  18846    .S TX=25, TY=11,BX=7 5,BY=17,VO N="",VOFF= "" D BOXF^ CHSC1(TX,T Y,BX,BY)
  18847   "RTN","CHM FA010",94, 0)
  18848    .D CLRBOX I^CHSC1(TX ,TY,BX,BY, XY,VON,VOF F)
  18849   "RTN","CHM FA010",95, 0)
  18850    .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
  18851   "RTN","CHM FA010",96, 0)
  18852    .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
  18853   "RTN","CHM FA010",97, 0)
  18854    .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
  18855   "RTN","CHM FA010",98, 0)
  18856    .;S DY=13 ,DX=26 X X Y W " "
  18857   "RTN","CHM FA010",99, 0)
  18858    .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
  18859   "RTN","CHM FA010",100 ,0)
  18860    .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
  18861   "RTN","CHM FA010",101 ,0)
  18862    ..S VFN=" ",CHMFBASC (1)="",CHV ENNM=""
  18863   "RTN","CHM FA010",102 ,0)
  18864   A4 D ^CHMF A011
  18865   "RTN","CHM FA010",103 ,0)
  18866    G:$D(D4OU T) A3
  18867   "RTN","CHM FA010",104 ,0)
  18868    K:$D(CHMF PREV)!$D(C HMFKILL) C HMFBASC
  18869   "RTN","CHM FA010",105 ,0)
  18870    D:$D(CHMF NEXT) SET
  18871   "RTN","CHM FA010",106 ,0)
  18872    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
  18873   "RTN","CHM FA010",107 ,0)
  18874   END ;
  18875   "RTN","CHM FA010",108 ,0)
  18876    K CHMFDCV N,CHTITLE, DX,DY,HJ,I ,J,LN,PTR, QU,REC,REC 1,STR,X,DU OUT,D1OUT
  18877   "RTN","CHM FA010",109 ,0)
  18878    K D2OUT,D QOUT,DFOUT ,DTOUT,FLD ,F1,HY,HX, I,NODAT,TL ,TYP,X,X1, X2,ZPSN,ZX
  18879   "RTN","CHM FA010",110 ,0)
  18880    K YY,Y,CH CLRFG,BLNK ,REC0,ST,P ST,PFT,PCL T,FT,CHK,D IC,%DT,ZPS J,ZPSN,ZPS NM
  18881   "RTN","CHM FA010",111 ,0)
  18882    K ZPSTOT, ZX,ZY,ZPSD ES,ZPSCT,Z PSCA,ZPSA, ZPS1,ZPS,Z OUT,ZNS,ZN O,ZI,ZC
  18883   "RTN","CHM FA010",112 ,0)
  18884    K MVFN,ME DVEN,CHMVE N,CHSERV Q
  18885   "RTN","CHM FA010",113 ,0)
  18886   TITLE S CH TITLE="BAS IC INFORMA TION SCREE N",CHSCREE N=0
  18887   "RTN","CHM FA010",114 ,0)
  18888    S CHSCREE N=$O(^CHMS CRN("B",CH TITLE,CHSC REEN)) I ' CHSCREEN G  END
  18889   "RTN","CHM FA010",115 ,0)
  18890    D TITLE^C HMFA100,CH OICE^CHMFA 100,ERRORS ^CHMFA100  Q
  18891   "RTN","CHM FA010",116 ,0)
  18892   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
  18893   "RTN","CHM FA010",117 ,0)
  18894    Q
  18895   "RTN","CHM FA010",118 ,0)
  18896   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)
  18897   "RTN","CHM FA010",119 ,0)
  18898    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
  18899   "RTN","CHM FA010",120 ,0)
  18900    W !," TAX  ID: ",?39 ,"|    TOS : ",@CHBOF F,$P(CHMFB ASC(4),"^" ,2),@CHBON    ;DEV007 991 10/08/ 2010 JAK r eorganize  screen lab els
  18901   "RTN","CHM FA010",121 ,0)
  18902    W !,"     NPI: ",?39 ,"|   PAYP : ",@CHBOF F                                   ;DEV007 991 10/08/ 2010 JAK r eorganize  screen lab els
  18903   "RTN","CHM FA010",122 ,0)
  18904    W:$P(CHMF BASC(2),"^ ",1)="Y" " Yes"
  18905   "RTN","CHM FA010",123 ,0)
  18906    W:$P(CHMF BASC(2),"^ ",1)="N" " No" W @CHB ON
  18907   "RTN","CHM FA010",124 ,0)
  18908    W !,"RT N AME: ",?39 ,"|   MCCR : ",@CHBOF F                                   ;DEV007 991 10/08/ 2010 JAK r eorganize  screen lab els
  18909   "RTN","CHM FA010",125 ,0)
  18910    W:$P(CHMF BASC(3),"^ ",1)="Y" " Yes"
  18911   "RTN","CHM FA010",126 ,0)
  18912    W:$P(CHMF BASC(3),"^ ",1)="N" " No" W @CHB ON
  18913   "RTN","CHM FA010",127 ,0)
  18914    W !," RT  ZIP: ",?39 ,"|    PCN : ",@CHBOF F,$P(CHMFB ASC(7),"^" ,1),@CHBON    ;DEV007 991 10/08/ 2010 JAK r eorganize  screen lab els
  18915   "RTN","CHM FA010",128 ,0)
  18916    ;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
  18917   "RTN","CHM FA010",129 ,0)
  18918    W !,?39," |    TOB:  ",@CHBOFF, $P(CHMFBAS C(6),"^",1 ),@CHBON    ;SBB 05/0 2/2017
  18919   "RTN","CHM FA010",130 ,0)
  18920    N CHSERV   ;CPE001-0 20, 021 an d 022.
  18921   "RTN","CHM FA010",131 ,0)
  18922    S CHSERV= $P(CHMFBAS C(4),"^")
  18923   "RTN","CHM FA010",132 ,0)
  18924    I CHSERV= "IPT"!(CHS ERV="OPT") !(CHSERV=" DNT") D
  18925   "RTN","CHM FA010",133 ,0)
  18926    .W !,?39, "| PL ZIP:  ",@CHBOFF ,$P(CHMFBA SC(8),"^", 1),@CHBON    ;SBB 05/ 02/2017
  18927   "RTN","CHM FA010",134 ,0)
  18928    I CHSERV= "TRV" W !, ?39,"|     POP: ",@CH BOFF,$P(CH MFBASC(11) ,"^",1) ;A EB 4/30/20 10 DEV0036 98
  18929   "RTN","CHM FA010",135 ,0)
  18930    S CHXTID= ""
  18931   "RTN","CHM FA010",136 ,0)
  18932    Q
  18933   "RTN","CHM FA010",137 ,0)
  18934   SET  ;
  18935   "RTN","CHM FA010",138 ,0)
  18936    N CHCLM ;  WTC 8/3/1 7
  18937   "RTN","CHM FA010",139 ,0)
  18938    S HVFN=$P (CHMFBASC( 1),"^",2)
  18939   "RTN","CHM FA010",140 ,0)
  18940    S X="",VF N=$P(CHMFB ASC(1),"^" ,2)
  18941   "RTN","CHM FA010",141 ,0)
  18942    I VFN D
  18943   "RTN","CHM FA010",142 ,0)
  18944    .S (VREC0 ,VREC1,VRE C2,VREC5,V REC41)=""
  18945   "RTN","CHM FA010",143 ,0)
  18946    .S:$D(^CH MVEN(VFN,0 )) VREC0=^ (0) S:$D(^ CHMVEN(VFN ,1)) VREC1 =^(1)
  18947   "RTN","CHM FA010",144 ,0)
  18948    .S:$D(^CH MVEN(VFN,2 )) VREC2=^ (2) S:$D(^ CHMVEN(VFN ,5)) VREC5 =^(1)
  18949   "RTN","CHM FA010",145 ,0)
  18950    .S JJ="A" ,JJ=$O(^CH MVEN(VFN,4 1,JJ),-1)
  18951   "RTN","CHM FA010",146 ,0)
  18952    .I JJ I $ D(^CHMVEN( VFN,41,JJ, 0)) S VREC 41=^(0)
  18953   "RTN","CHM FA010",147 ,0)
  18954    .S X1=$P( VREC0,"^", 1)_"^"_$P( VREC0,"^", 3)
  18955   "RTN","CHM FA010",148 ,0)
  18956    .S X2=$P( VREC2,"^", 1)_"^"_$P( VREC2,"^", 2)_"^"_$P( VREC2,"^", 3)_"^"_$P( VREC2,"^", 4)_"^"_$P( VREC2,"^", 5)_"^"_$P( VREC2,"^", 6)
  18957   "RTN","CHM FA010",149 ,0)
  18958    .S X3=$P( VREC1,"^", 7)_"^"_$P( VREC1,"^", 11)
  18959   "RTN","CHM FA010",150 ,0)
  18960    .S X4=$P( VREC5,"^", 5),X5=$P(V REC41,"^", 3)
  18961   "RTN","CHM FA010",151 ,0)
  18962    .S ^CHMIM AGE(CHMFPD I,"VEN-II" ,VFN)=X1_" ^"_X2_"^"_ X3_"^"_X4_ "^"_X5
  18963   "RTN","CHM FA010",152 ,0)
  18964    .S $P(^CH MIMAGE(CHM FPDI,"VEN- II",VFN)," ^",15)=$P( $G(CHMFBAS C(8)),"^", 1)
  18965   "RTN","CHM FA010",153 ,0)
  18966    . ;
  18967   "RTN","CHM FA010",154 ,0)
  18968    . ;  Add  PL ZIP to  claims alr eady assoc iated with  the PDI.   wtc 8/3/1 7
  18969   "RTN","CHM FA010",155 ,0)
  18970    . ;
  18971   "RTN","CHM FA010",156 ,0)
  18972    . 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) ;
  18973   "RTN","CHM FA010",157 ,0)
  18974    S $P(X,"^ ",1)=$P(CH MFBASC(1), "^",2),$P( X,"^",7)=$ P(CHMFBASC (6),"^",1)
  18975   "RTN","CHM FA010",158 ,0)
  18976    S $P(X,"^ ",17)=$P(C HMFBASC(7) ,"^",1),$P (X,"^",3)= $P(CHMFBAS C(2),"^",1 )
  18977   "RTN","CHM FA010",159 ,0)
  18978    S CHMFSER V=$P(CHMFB ASC(4),"^" ,3)
  18979   "RTN","CHM FA010",160 ,0)
  18980    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,0)," ^",5)=CHMF SERV
  18981   "RTN","CHM FA010",161 ,0)
  18982    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
  18983   "RTN","CHM FA010",162 ,0)
  18984    S ^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"VEN")= X
  18985   "RTN","CHM FA010",163 ,0)
  18986    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN "),"^",9)= CHMFSERV
  18987   "RTN","CHM FA010",164 ,0)
  18988    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN "),"^",15) =CHMFPGNM
  18989   "RTN","CHM FA010",165 ,0)
  18990    S X=""
  18991   "RTN","CHM FA010",166 ,0)
  18992    S $P(X,"^ ",1)=$P(CH MFBASC(3), "^",1)
  18993   "RTN","CHM FA010",167 ,0)
  18994    S $P(X,"^ ",4)=$P(CH MFBASC(3), "^",1)
  18995   "RTN","CHM FA010",168 ,0)
  18996    S $P(X,"^ ",2)=$E(OH IIND,1)
  18997   "RTN","CHM FA010",169 ,0)
  18998    S ^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"AII")= X
  18999   "RTN","CHM FA010",170 ,0)
  19000    I VFN'=""  I '$D(CHM VEN) D LOA D
  19001   "RTN","CHM FA010",171 ,0)
  19002    D DSCRP
  19003   "RTN","CHM FA010",172 ,0)
  19004    I $D(MVFN ) I MVFN'= "" S $P(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"V EN"),"^",1 6)=MVFN
  19005   "RTN","CHM FA010",173 ,0)
  19006    I $D(MEDA MT) I MEDA MT'="" S $ P(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"VEN")," ^",18)=MED AMT
  19007   "RTN","CHM FA010",174 ,0)
  19008    Q
  19009   "RTN","CHM FA010",175 ,0)
  19010   DSCRP S ST R="" Q:'$D (VFN)  S S TR="0*0*0* 0*0*0*0*0* 0*0*0*0"
  19011   "RTN","CHM FA010",176 ,0)
  19012    S REC="", REC1="",RE C2="",REC5 ="",REC41= "",PTR=""
  19013   "RTN","CHM FA010",177 ,0)
  19014    S PTR=CHM FPDI_"*"_C HMFPGNM_"* "_CHMFIMAG
  19015   "RTN","CHM FA010",178 ,0)
  19016    I VFN=""  D  Q
  19017   "RTN","CHM FA010",179 ,0)
  19018    .S CT=0
  19019   "RTN","CHM FA010",180 ,0)
  19020    .F I=2:1: 19 S CT=CT +1,PV(CT)= "" S:$D(CH MVEN(I)) P V(CT)=CHMV EN(I)
  19021   "RTN","CHM FA010",181 ,0)
  19022    .S STR=""  D PSEUDO
  19023   "RTN","CHM FA010",182 ,0)
  19024    .S $P(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"VE N"),"^",14 )=J Q
  19025   "RTN","CHM FA010",183 ,0)
  19026    S:$D(^CHM VEN(VFN,0) ) REC=^(0)  S:$D(^CHM VEN(VFN,1) ) REC1=^(1 )
  19027   "RTN","CHM FA010",184 ,0)
  19028    S:$D(^CHM VEN(VFN,2) ) REC2=^(2 ) S:$D(^CH MVEN(VFN,5 )) REC5=^( 5)
  19029   "RTN","CHM FA010",185 ,0)
  19030    S JJ="A", JJ=$O(^CHM VEN(VFN,41 ,JJ),-1)
  19031   "RTN","CHM FA010",186 ,0)
  19032    I JJ I $D (^CHMVEN(V FN,41,JJ,0 )) S REC41 =^(0)
  19033   "RTN","CHM FA010",187 ,0)
  19034    I $P(REC0 ,"^",1)'=C HMVEN(2) S  $P(STR,"* ",1)=1,PV( 1)=CHMVEN( 2)
  19035   "RTN","CHM FA010",188 ,0)
  19036    I $P(REC, "^",3)'=CH MVEN(3) S  $P(STR,"*" ,2)=1,PV(2 )=CHMVEN(3 )
  19037   "RTN","CHM FA010",189 ,0)
  19038    I $P(REC1 ,"^",1)'=C HMVEN(14)  S $P(STR," *",3)=1,PV (3)=CHMVEN (14)
  19039   "RTN","CHM FA010",190 ,0)
  19040    I $P(REC1 ,"^",2)'=C HMVEN(15)  S $P(STR," *",4)=1,PV (4)=CHMVEN (15)
  19041   "RTN","CHM FA010",191 ,0)
  19042    I $P(REC1 ,"^",3)'=C HMVEN(16)  S $P(STR," *",5)=1,PV (5)=CHMVEN (16)
  19043   "RTN","CHM FA010",192 ,0)
  19044    I $P(REC1 ,"^",4)'=C HMVEN(17)  S $P(STR," *",6)=1,PV (6)=CHMVEN (17)
  19045   "RTN","CHM FA010",193 ,0)
  19046    I $P(REC1 ,"^",5)'=C HMVEN(18)  S $P(STR," *",7)=1,PV (7)=CHMVEN (18)
  19047   "RTN","CHM FA010",194 ,0)
  19048    ;I $P(REC 41,"^",3)' =CHMVEN(9)  S $P(STR, "*",8)=1,P V(8)=CHMVE N(9)
  19049   "RTN","CHM FA010",195 ,0)
  19050    ;I $P(REC 2,"^",6)'= CHMVEN(10)  S $P(STR, "*",9)=1,P V(9)=CHMVE N(10)
  19051   "RTN","CHM FA010",196 ,0)
  19052    ;I $P(REC 1,"^",7)'= CHMVEN(11)  S $P(STR, "*",10)=1, PV(10)=CHM VEN(11)
  19053   "RTN","CHM FA010",197 ,0)
  19054    ;I $P(REC 1,"^",11)' =CHMVEN(12 ) S $P(STR ,"*",11)=1 ,PV(11)=CH MVEN(12)
  19055   "RTN","CHM FA010",198 ,0)
  19056    I $P(REC2 ,"^",2)'=C HMVEN(5) S  $P(STR,"* ",12)=1,PV (12)=CHMVE N(5)
  19057   "RTN","CHM FA010",199 ,0)
  19058    S CHPDI=C HMFPDI
  19059   "RTN","CHM FA010",200 ,0)
  19060    S CNT="", CNT=$O(^CH MIMAGE(CHP DI,"VEN-DD ",HVFN,CNT ),-1) S:'C NT CNT=0
  19061   "RTN","CHM FA010",201 ,0)
  19062    S CNT=CNT +1
  19063   "RTN","CHM FA010",202 ,0)
  19064    D NOW^%DT C
  19065   "RTN","CHM FA010",203 ,0)
  19066    F X=1:1:1 2 S:$D(PV( X)) $P(^CH MIMAGE(CHP DI,"VEN-DD ",HVFN,CNT ),"^",X)=$ P(PV(X),"^ ",1)
  19067   "RTN","CHM FA010",204 ,0)
  19068    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",13)=$ P(REC,"^", 1)
  19069   "RTN","CHM FA010",205 ,0)
  19070    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",14)=$ P(REC,"^", 3)
  19071   "RTN","CHM FA010",206 ,0)
  19072    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",15)=$ P(REC2,"^" ,1)
  19073   "RTN","CHM FA010",207 ,0)
  19074    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",16)=$ P(REC2,"^" ,2)
  19075   "RTN","CHM FA010",208 ,0)
  19076    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",17)=$ P(REC2,"^" ,3)
  19077   "RTN","CHM FA010",209 ,0)
  19078    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",18)=$ P(REC2,"^" ,4)
  19079   "RTN","CHM FA010",210 ,0)
  19080    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",19)=$ P(REC2,"^" ,5)
  19081   "RTN","CHM FA010",211 ,0)
  19082    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",20)=$ P(REC41,"^ ",3)
  19083   "RTN","CHM FA010",212 ,0)
  19084    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",21)=$ P(REC2,"^" ,6)
  19085   "RTN","CHM FA010",213 ,0)
  19086    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",22)=$ P(REC1,"^" ,7)
  19087   "RTN","CHM FA010",214 ,0)
  19088    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",23)=$ P(REC1,"^" ,11)
  19089   "RTN","CHM FA010",215 ,0)
  19090    S $P(^CHM IMAGE(CHPD I,"VEN-DD" ,HVFN,CNT) ,"^",24)=$ P(REC5,"^" ,5)
  19091   "RTN","CHM FA010",216 ,0)
  19092    S:$D(PV)  $P(^CHMIMA GE(CHPDI," VEN-DD",HV FN,CNT),"^ ",26)=DUZ
  19093   "RTN","CHM FA010",217 ,0)
  19094    S:$D(PV)  $P(^CHMIMA GE(CHPDI," VEN-DD",HV FN,CNT),"^ ",27)=%
  19095   "RTN","CHM FA010",218 ,0)
  19096    S CHMFDCV N="Y" F I= 1:1:12 S:' $D(PV(I))  PV(I)=""
  19097   "RTN","CHM FA010",219 ,0)
  19098    S:STR'[1  STR="" D P 1
  19099   "RTN","CHM FA010",220 ,0)
  19100    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN "),"^",2)= "Y"
  19101   "RTN","CHM FA010",221 ,0)
  19102    S $P(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN "),"^",14) =J Q
  19103   "RTN","CHM FA010",222 ,0)
  19104   PSEUDO ;
  19105   "RTN","CHM FA010",223 ,0)
  19106   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
  19107   "RTN","CHM FA010",224 ,0)
  19108    S J=HJ+1
  19109   "RTN","CHM FA010",225 ,0)
  19110    F I=3:1:7  I $D(CHMV EN(I+11))  I CHMVEN(I +11)'="" S  PV(I)=CHM VEN(I+11)
  19111   "RTN","CHM FA010",226 ,0)
  19112    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
  19113   "RTN","CHM FA010",227 ,0)
  19114   LOAD S REC ="",REC1=" ",REC2="", REC41="" I  '$D(REC0)  S REC0=""  ;DEF01177 6 added S  REC0="" to  this line  BMJ
  19115   "RTN","CHM FA010",228 ,0)
  19116    S:$D(^CHM VEN(VFN,0) ) REC=^(0)  S:$D(^CHM VEN(VFN,1) ) REC1=^(1 )
  19117   "RTN","CHM FA010",229 ,0)
  19118    S:$D(^CHM VEN(VFN,2) ) REC2=^(2 ) S:$D(^CH MVEN(VFN,5 )) REC5=^( 5)
  19119   "RTN","CHM FA010",230 ,0)
  19120    ;S:$D(^CH MVEN(VFN,0 )) REC0=^( 0)       ; ;DEV4874 D RW - testi ng this po rtion for  undefined  REC0 - 03/ 17/11
  19121   "RTN","CHM FA010",231 ,0)
  19122    S JJ="A", JJ=$O(^CHM VEN(VFN,41 ,JJ),-1)
  19123   "RTN","CHM FA010",232 ,0)
  19124    I JJ S:$D (^CHMVEN(V FN,41,JJ,0 )) REC41=^ (0)
  19125   "RTN","CHM FA010",233 ,0)
  19126    S CHMVEN( 2)=$P(REC, "^",1),CHM VEN(3)=$P( REC,"^",3) ,CHMVEN(1) =$P(REC2," ^",8)
  19127   "RTN","CHM FA010",234 ,0)
  19128    S CHMVEN( 4)=$P(REC2 ,"^",1),CH MVEN(5)=$P (REC2,"^", 2)
  19129   "RTN","CHM FA010",235 ,0)
  19130    S CHMVEN( 6)=$P(REC2 ,"^",3),CH MVEN(7)=$P (REC2,"^", 4)
  19131   "RTN","CHM FA010",236 ,0)
  19132    S CHMVEN( 8)=$P(REC2 ,"^",5),CH MVEN(9)=$P (REC41,"^" ,3)
  19133   "RTN","CHM FA010",237 ,0)
  19134    S CHMVEN( 10)=$P(REC 2,"^",6)
  19135   "RTN","CHM FA010",238 ,0)
  19136    S CHMVEN( 11)=$P(REC 1,"^",7)
  19137   "RTN","CHM FA010",239 ,0)
  19138    S CHMVEN( 12)=$P(REC 1,"^",11), CHMVEN(13) =$P(REC5," ^",5)
  19139   "RTN","CHM FA010",240 ,0)
  19140    F I=1:1:5  I $D(REC1 ) S CHMVEN (I+13)=$P( REC1,"^",I )
  19141   "RTN","CHM FA010",241 ,0)
  19142    Q
  19143   "RTN","CHM FA010",242 ,0)
  19144   VEN S DY=1 2,DX=1,$Y= DY,$X=DX X  XY F LN=1 :1:80 W "- "
  19145   "RTN","CHM FA010",243 ,0)
  19146    ;S DY=11, DX=10,$Y=D Y,$X=DX X  XY
  19147   "RTN","CHM FA010",244 ,0)
  19148    S DY=12,D X=37,$Y=DY ,$X=DX X X Y     ;SBB  05/02/201 7
  19149   "RTN","CHM FA010",245 ,0)
  19150    ;W @CHBON ,"| Remit- to Informa tion        || Physic al Locatio n Informat ion |",@CH BOFF Q
  19151   "RTN","CHM FA010",246 ,0)
  19152    ;W @CHBON ,"| Physic al Locatio n Info      || Remit- to Informa tion           |",@CH BOFF Q  ;A EB 7/2/200 7
  19153   "RTN","CHM FA010",247 ,0)
  19154    W @CHBON, "  || Bill ing/Remit- to Informa tion |",@C HBOFF Q  ; SBB 5/2/20 17
  19155   "RTN","CHM FA010",248 ,0)
  19156       ;
  19157   "RTN","CHM FA010",249 ,0)
  19158   CVFN2   ;   ///////// //////////  SETS UP V ENDOR ID I N GLOBAL / ////////// /////  12/ 12/2006 TT  # 312 RKN
  19159   "RTN","CHM FA010",250 ,0)
  19160       ;CODE  REMARKED O UT PER CPD  (CHARLES  GUSTAFSON)  12/26/200 6 RKN
  19161   "RTN","CHM FA010",251 ,0)
  19162       ;TT #  MTN001137- 01: 6875 -  OCR SELEC TING WRONG  VENDOR  1 2/26/2006  RKN
  19163   "RTN","CHM FA010",252 ,0)
  19164       ;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
  19165   "RTN","CHM FA010",253 ,0)
  19166       ;I '$D (^CHMIMAGE (CHMFPDI," P-VEN",1,0 )) Q
  19167   "RTN","CHM FA010",254 ,0)
  19168       ;I $D( ^CHMIMAGE( CHMFPDI,"P -VEN",1,0) ) S VTAXID =$P(^CHMIM AGE(CHMFPD I,"P-VEN", 1,0),"^",5 )
  19169   "RTN","CHM FA010",255 ,0)
  19170       ;Q:VTA XID=""!(VT AXID=" ")    ;JEH 12/ 16/06
  19171   "RTN","CHM FA010",256 ,0)
  19172       ;S VFN =999999999 ,VFN=$O(^C HMVEN("D", VTAXID,VFN ),-1)
  19173   "RTN","CHM FA010",257 ,0)
  19174       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,1)=VFN
  19175   "RTN","CHM FA010",258 ,0)
  19176       ;S $P( ^CHMIMAGE( CHMFPDI,"P -VEN",1,0) ,"^",1)=VF N
  19177   "RTN","CHM FA010",259 ,0)
  19178       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,14)=CHMFP GNM
  19179   "RTN","CHM FA010",260 ,0)
  19180       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,2)="Y"
  19181   "RTN","CHM FA010",261 ,0)
  19182       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,3)="Y"
  19183   "RTN","CHM FA010",262 ,0)
  19184       ;S $P( ^CHMIMAGE( CHMFPDI,1, CHMFPGNM,2 ,CHMFIMAG, "VEN"),"^" ,9)="2"
  19185   "RTN","CHM FA010",263 ,0)
  19186       ;S ^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"AI I")="^^^"
  19187   "RTN","CHM FA010",264 ,0)
  19188       ;Q
  19189   "RTN","CHM FA010",265 ,0)
  19190       ;
  19191   "RTN","CHM FA010",266 ,0)
  19192   GETDATA F  QU=1:1:11  S CHMFBASC (QU)=""  ; AEB 4/30/2 010 DEV003 698  CHANG ED 10 TO 1 1
  19193   "RTN","CHM FA010",267 ,0)
  19194    I $D(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,0))  D
  19195   "RTN","CHM FA010",268 ,0)
  19196    .S X=$P(^ (0),"^",5)
  19197   "RTN","CHM FA010",269 ,0)
  19198    .S CHMFBA SC(4)=""
  19199   "RTN","CHM FA010",270 ,0)
  19200    .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
  19201   "RTN","CHM FA010",271 ,0)
  19202    .I X I $D (^CHMDIC(7 41002.05,X ,0)) D
  19203   "RTN","CHM FA010",272 ,0)
  19204    ..S CHMFB ASC(4)=$P( ^(0),"^",2 )_"^"_$P(^ (0),"^",1) _"^"_X_"^" _"B"
  19205   "RTN","CHM FA010",273 ,0)
  19206    I $D(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"AII ")) D
  19207   "RTN","CHM FA010",274 ,0)
  19208    .S CHMFBA SC(3)=$P(^ ("AII"),"^ ",4)
  19209   "RTN","CHM FA010",275 ,0)
  19210    I $D(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"VEN ")) D
  19211   "RTN","CHM FA010",276 ,0)
  19212    .S CHMFBA SC(2)=$P(^ ("VEN"),"^ ",2)
  19213   "RTN","CHM FA010",277 ,0)
  19214    .S CHMFBA SC(6)=$P(^ ("VEN"),"^ ",7)
  19215   "RTN","CHM FA010",278 ,0)
  19216    .S CHMFBA SC(7)=$P(^ ("VEN"),"^ ",17)
  19217   "RTN","CHM FA010",279 ,0)
  19218    .S X=$P(^ ("VEN"),"^ ",1)
  19219   "RTN","CHM FA010",280 ,0)
  19220    .I $D(ASV FLG) S X=A SVFLG                         ;j sg;DEV0028 41;5/12/09 ;
  19221   "RTN","CHM FA010",281 ,0)
  19222    .I 'X S C HMFBASC(1) ="" Q
  19223   "RTN","CHM FA010",282 ,0)
  19224    .I '$D(^C HMVEN(X,0) ) S CHMFBA SC(1)="" Q
  19225   "RTN","CHM FA010",283 ,0)
  19226    .S CHMFBA SC(1)=$P(^ CHMVEN(X,0 ),"^",1)_" ^"_X
  19227   "RTN","CHM FA010",284 ,0)
  19228     .;CPE VE NDOR STREA MLINING US ER STORY 2  PL-ZIP 06 /01/2017 -  default P L-ZIP for  EDI claims  GEF
  19229   "RTN","CHM FA010",285 ,0)
  19230    .S:$G(CHM FBASC(8))= "" CHMFBAS C(8)=$P($G (^CHMIMAGE (CHMFPDI," VEN-II",X) ),"^",15)
  19231   "RTN","CHM FA010",286 ,0)
  19232    S:$G(CHMF BASC(8))=" " CHMFBASC (8)=$$ZIPD F(CHMFPDI, $G(X))
  19233   "RTN","CHM FA010",287 ,0)
  19234    ;
  19235   "RTN","CHM FA010",288 ,0)
  19236    ;  WTC -  Shorten 9  digit zip  codes to 5  digits -  7/27/17
  19237   "RTN","CHM FA010",289 ,0)
  19238    ;
  19239   "RTN","CHM FA010",290 ,0)
  19240    I $L(CHMF BASC(8))>5  S CHMFBAS C(8)=$E(CH MFBASC(8), 1,5) ;
  19241   "RTN","CHM FA010",291 ,0)
  19242    Q
  19243   "RTN","CHM FA010",292 ,0)
  19244   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
  19245   "RTN","CHM FA010",293 ,0)
  19246    N CHMFXCL ,CHMFZPD,C HMFPTC,CHM FBE,CHSERV
  19247   "RTN","CHM FA010",294 ,0)
  19248    S CHSERV= $P(CHMFBAS C(4),"^")   ;CPE001-0 20, 021 an d 022
  19249   "RTN","CHM FA010",295 ,0)
  19250    I CHSERV' ="IPT",CHS ERV'="OPT" ,CHSERV'=" DNT" Q ""
  19251   "RTN","CHM FA010",296 ,0)
  19252    S CHMFZPD =""
  19253   "RTN","CHM FA010",297 ,0)
  19254    S:VFN'=""  CHMFZPD=$ P($G(^CHMI MAGE(CHMFP DI,"VEN-II ",VFN)),"^ ",15)
  19255   "RTN","CHM FA010",298 ,0)
  19256    Q:CHMFZPD '="" CHMFZ PD
  19257   "RTN","CHM FA010",299 ,0)
  19258    ; only de fault for  EDI claims
  19259   "RTN","CHM FA010",300 ,0)
  19260    Q:$$TYPE^ CHMFPDI2(C HMFPDI)<90
  19261   "RTN","CHM FA010",301 ,0)
  19262    S CHMFPTC ="" F  S C HMFPTC=$O( ^CHMXCLE(" PDI",CHMFP DI,CHMFPTC )) Q:CHMFP TC=""  D
  19263   "RTN","CHM FA010",302 ,0)
  19264    .S CHMFXC L="" F  S  CHMFXCL=$O (^CHMXCLE( "PDI",CHMF PDI,CHMFPT C,CHMFXCL) ) Q:CHMFXC L=""  D
  19265   "RTN","CHM FA010",303 ,0)
  19266    ..S CHMFB E=$O(^CHMX CLE("PDI", CHMFPDI,CH MFPTC,CHMF XCL,"")) Q :CHMFBE=""
  19267   "RTN","CHM FA010",304 ,0)
  19268    ..Q:CHMFB E=""
  19269   "RTN","CHM FA010",305 ,0)
  19270    ..S CHMFZ PD=$E($P($ G(^CHMXCLE (+$P(CHMFB E,"*",4),6 0)),"^",9) ,1,5) Q:CH MFZPD'=""
  19271   "RTN","CHM FA010",306 ,0)
  19272    ..S CHMFZ PD=$E($P($ G(^CHMXCLB (+$P(CHMFB E,"*",2),0 )),"^",8), 1,5)
  19273   "RTN","CHM FA010",307 ,0)
  19274    Q CHMFZPD
  19275   "RTN","CHM FA011")
  19276   0^44^B1096 41227
  19277   "RTN","CHM FA011",1,0 )
  19278   CHMFA011 ; JLR/DEN;BA SIC DATA E NTER/EDIT  SCREEN;Feb  06, 2019@ 10:10:21;  07 Jul 201 7 6:10 AM
  19279   "RTN","CHM FA011",2,0 )
  19280    ;;1.0;CHA MPVA SYSTE M;**1,8,14 **;JULY 4,  1990;Buil d 5
  19281   "RTN","CHM FA011",3,0 )
  19282    ;CPTS #10 846 - PEJ  8/15/96
  19283   "RTN","CHM FA011",4,0 )
  19284    ;CPTS #11 089 - JLR  10/17/96
  19285   "RTN","CHM FA011",5,0 )
  19286    ;CPTS #12 505 BY DTP  (3-SEP-97 )
  19287   "RTN","CHM FA011",6,0 )
  19288    ;DEV00369 8 4/20/201 0 AEB
  19289   "RTN","CHM FA011",7,0 )
  19290    ;JEH 2/1/ 11 DEV0078 20 - SLLA  - ADDED TO TAL LOGIC  FOR PRI OH I P/R, ADD L OHI PD
  19291   "RTN","CHM FA011",8,0 )
  19292    ;CPE001-0 02 PL-ZIP  05/24/2017  GEF
  19293   "RTN","CHM FA011",9,0 )
  19294    ;CFS 02/2 2/2018 CPE 001-020, 0 21 and 022  - Fix cur sor moveme nts based  on Type of  Services.
  19295   "RTN","CHM FA011",10, 0)
  19296    ;CFS 09/1 9/2018 Def ect 826304  Clean up  screen aft er user ch ooses the  Type Of Se rvice from  selection  list.
  19297   "RTN","CHM FA011",11, 0)
  19298    ;
  19299   "RTN","CHM FA011",12, 0)
  19300   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
  19301   "RTN","CHM FA011",13, 0)
  19302    W $E($P(C HMFBASC(QU ),"^",2),1 ,20) S DX= 50,$X=DX X  XY D CSBR S^CHSC2
  19303   "RTN","CHM FA011",14, 0)
  19304    I $D(DQOU T) D  G:ZP SN="?" A2  G A21
  19305   "RTN","CHM FA011",15, 0)
  19306    .D CLEAR  S Y="?" D  ^CHMFA016
  19307   "RTN","CHM FA011",16, 0)
  19308    .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)
  19309   "RTN","CHM FA011",17, 0)
  19310    .D CLEAR  D REPNT
  19311   "RTN","CHM FA011",18, 0)
  19312    I $D(DUOU T) D  G A2
  19313   "RTN","CHM FA011",19, 0)
  19314    .S DY=5,D X=50,$Y=DY ,$X=DX X X Y W BLNK2
  19315   "RTN","CHM FA011",20, 0)
  19316    .S DX=50, $X=DX X XY  W:CHMFBAS C(QU)'=""  $E($P(CHMF BASC(QU)," ^",2),1,20 )
  19317   "RTN","CHM FA011",21, 0)
  19318    .D:$D(CHC LRFG) CLEA R,REPNT
  19319   "RTN","CHM FA011",22, 0)
  19320    I $D(DDOU T)!$D(DFOU T) G SELCT
  19321   "RTN","CHM FA011",23, 0)
  19322    G:$D(D1OU T) A2
  19323   "RTN","CHM FA011",24, 0)
  19324    Q:$D(D4OU T)
  19325   "RTN","CHM FA011",25, 0)
  19326    I Y="" D: $D(CHCLRFG ) REPNT G  A3
  19327   "RTN","CHM FA011",26, 0)
  19328    I Y=" ",$ D(^DISV(DU Z,"CHTYP") ) S TYP=^( "CHTYP") D  GET1 G A2 1
  19329   "RTN","CHM FA011",27, 0)
  19330    I Y="@" S  CHMFBASC( QU)="" G A 2
  19331   "RTN","CHM FA011",28, 0)
  19332    D ^CHMFA0 16
  19333   "RTN","CHM FA011",29, 0)
  19334   A21 I ZPSN =-1 D  G A 2
  19335   "RTN","CHM FA011",30, 0)
  19336    .S DY=5,D X=50,$Y=DY ,$X=DX X X Y W BLNK2  X XY W *7, " ??"
  19337   "RTN","CHM FA011",31, 0)
  19338    .R X:2 X  XY W BLNK2
  19339   "RTN","CHM FA011",32, 0)
  19340    .X XY W:C HMFBASC(QU )'="" $E($ P(CHMFBASC (QU),"^",2 ),1,20)
  19341   "RTN","CHM FA011",33, 0)
  19342    .D:$D(CHC LRFG) CLEA R,REPNT
  19343   "RTN","CHM FA011",34, 0)
  19344   A22 G:CHMF BASC(QU)=" " A23
  19345   "RTN","CHM FA011",35, 0)
  19346    G:$P(CHMF BASC(QU)," ^",3)=$P(Z PSN,"^",3)  A23
  19347   "RTN","CHM FA011",36, 0)
  19348    S CHPDIPR L=$$PDITYP ^CHMFAUT1( CHMFPDI) G :CHPDIPRL= 0 A23
  19349   "RTN","CHM FA011",37, 0)
  19350    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
  19351   "RTN","CHM FA011",38, 0)
  19352    I ($P(CHM FBASC(QU), "^",3)=3)! ($P(ZPSN," ^",3)=3) D  TOSMSG G  A2
  19353   "RTN","CHM FA011",39, 0)
  19354    S CTFLG=" "    ;JEH  2/1/11 DEV 007820 - S LLA - ADDE D CHG TOS  FLG
  19355   "RTN","CHM FA011",40, 0)
  19356    D ^CHMFA0 1J ; DO TH E TOS CHAN GE ON OCR/ EDI (CHPDI PRL=1) SUB MISSIONS
  19357   "RTN","CHM FA011",41, 0)
  19358    K CTFLG    ;JEH 2/1/ 11 DEV0078 20 - SLLA  - ADDED CH G TOS FLG
  19359   "RTN","CHM FA011",42, 0)
  19360   A23 S DY=5 ,DX=50,$Y= DY,$X=DX X  XY W BLNK 2
  19361   "RTN","CHM FA011",43, 0)
  19362    X XY W BL NK2 X XY W  $E($P(ZPS N,"^",2),1 ,20)
  19363   "RTN","CHM FA011",44, 0)
  19364    I $P(ZPSN ,"^",3)'=$ P(CHMFBASC (QU),"^",3 ) S REFLG= ""
  19365   "RTN","CHM FA011",45, 0)
  19366    S CHMFBAS C(QU)=ZPSN
  19367   "RTN","CHM FA011",46, 0)
  19368    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
  19369   "RTN","CHM FA011",47, 0)
  19370    D:$D(CHCL RFG) REPNT
  19371   "RTN","CHM FA011",48, 0)
  19372   A3 D ASSIG N K F1,DD1 OUT
  19373   "RTN","CHM FA011",49, 0)
  19374    S QU=2,DY =6,DX=50,F LD=21,$Y=D Y,$X=DX X  XY
  19375   "RTN","CHM FA011",50, 0)
  19376    W:CHMFBAS C(QU)="" B LNK2
  19377   "RTN","CHM FA011",51, 0)
  19378    W:CHMFBAS C(QU)="N"  "No"
  19379   "RTN","CHM FA011",52, 0)
  19380    W:CHMFBAS C(QU)="Y"  "Yes"
  19381   "RTN","CHM FA011",53, 0)
  19382    G:$D(CHAS SOV) A4
  19383   "RTN","CHM FA011",54, 0)
  19384    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19385   "RTN","CHM FA011",55, 0)
  19386    I $D(DQOU T) D  G A3
  19387   "RTN","CHM FA011",56, 0)
  19388    .D QUES X  XY W BLNK 2 X XY
  19389   "RTN","CHM FA011",57, 0)
  19390    .W:CHMFBA SC(QU)="N"  "No"
  19391   "RTN","CHM FA011",58, 0)
  19392    .W:CHMFBA SC(QU)="Y"  "Yes"
  19393   "RTN","CHM FA011",59, 0)
  19394    I $D(DUOU T) D  G A2
  19395   "RTN","CHM FA011",60, 0)
  19396    .S DY=6,D X=50,$Y=DY ,$X=DX X X Y W BLNK2  S DX=50,$X =DX X XY
  19397   "RTN","CHM FA011",61, 0)
  19398    .W:CHMFBA SC(QU)="N"  "No"
  19399   "RTN","CHM FA011",62, 0)
  19400    .W:CHMFBA SC(QU)="Y"  "Yes"
  19401   "RTN","CHM FA011",63, 0)
  19402    .D:$D(CHC LRFG) CLEA R,REPNT
  19403   "RTN","CHM FA011",64, 0)
  19404    S:$D(D1OU T) DD1OUT= 1
  19405   "RTN","CHM FA011",65, 0)
  19406    Q:$D(D4OU T)
  19407   "RTN","CHM FA011",66, 0)
  19408    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A3 G SELCT
  19409   "RTN","CHM FA011",67, 0)
  19410    I Y="@" S  CHMFBASC( QU)="" G A 3
  19411   "RTN","CHM FA011",68, 0)
  19412    I Y'="" D   G:$D(F1)  A3
  19413   "RTN","CHM FA011",69, 0)
  19414    .D ^CHMFA 012
  19415   "RTN","CHM FA011",70, 0)
  19416    .I $D(F1)  S DX=50,D Y=6,$Y=DY, $X=DX X XY  W BLNK2 Q
  19417   "RTN","CHM FA011",71, 0)
  19418    .D:$D(CHC LRFG) CLEA R,REPNT
  19419   "RTN","CHM FA011",72, 0)
  19420    .S DX=50, DY=6,$Y=DY ,$X=DX X X Y W BLNK2  X XY
  19421   "RTN","CHM FA011",73, 0)
  19422    .W:Y="N"  "No" W:Y=" Y" "Yes" S  CHMFBASC( QU)=Y
  19423   "RTN","CHM FA011",74, 0)
  19424    D:$D(CHCL RFG) REPNT
  19425   "RTN","CHM FA011",75, 0)
  19426    G:$D(DD1O UT) A2
  19427   "RTN","CHM FA011",76, 0)
  19428   A4 K F1,DD 1OUT
  19429   "RTN","CHM FA011",77, 0)
  19430    S QU=3,DY =7,DX=50,F LD=21,$Y=D Y,$X=DX X  XY
  19431   "RTN","CHM FA011",78, 0)
  19432    W:CHMFBAS C(QU)="" B LNK2
  19433   "RTN","CHM FA011",79, 0)
  19434    W:CHMFBAS C(QU)="N"  "No"
  19435   "RTN","CHM FA011",80, 0)
  19436    W:CHMFBAS C(QU)="Y"  "Yes"
  19437   "RTN","CHM FA011",81, 0)
  19438    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19439   "RTN","CHM FA011",82, 0)
  19440    I $D(DQOU T) D  G A4
  19441   "RTN","CHM FA011",83, 0)
  19442    .D QUES X  XY W BLNK 2 X XY
  19443   "RTN","CHM FA011",84, 0)
  19444    .W:CHMFBA SC(QU)="N"  "No"
  19445   "RTN","CHM FA011",85, 0)
  19446    .W:CHMFBA SC(QU)="Y"  "Yes"
  19447   "RTN","CHM FA011",86, 0)
  19448    I $D(DUOU T) D  G A3
  19449   "RTN","CHM FA011",87, 0)
  19450    .S DY=7,D X=50,$Y=DY ,$X=DX X X Y W BLNK2  S DX=50,$X =DX X XY
  19451   "RTN","CHM FA011",88, 0)
  19452    .W:CHMFBA SC(QU)="N"  "No"
  19453   "RTN","CHM FA011",89, 0)
  19454    .W:CHMFBA SC(QU)="Y"  "Yes"
  19455   "RTN","CHM FA011",90, 0)
  19456    .D:$D(CHC LRFG) CLEA R,REPNT
  19457   "RTN","CHM FA011",91, 0)
  19458    S:$D(D1OU T) DD1OUT= 1
  19459   "RTN","CHM FA011",92, 0)
  19460    Q:$D(D4OU T)
  19461   "RTN","CHM FA011",93, 0)
  19462    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A4 G SELCT
  19463   "RTN","CHM FA011",94, 0)
  19464    I Y="@" S  CHMFBASC( QU)="" G A 4
  19465   "RTN","CHM FA011",95, 0)
  19466    I Y'="" D   G:$D(F1)  A4
  19467   "RTN","CHM FA011",96, 0)
  19468    .D ^CHMFA 012
  19469   "RTN","CHM FA011",97, 0)
  19470    .I $D(F1)  S DX=50,D Y=7,$Y=DY, $X=DX X XY  W BLNK2 Q
  19471   "RTN","CHM FA011",98, 0)
  19472    .D:$D(CHC LRFG) CLEA R,REPNT
  19473   "RTN","CHM FA011",99, 0)
  19474    .S DX=50, DY=7,$Y=DY ,$X=DX X X Y W BLNK2  X XY
  19475   "RTN","CHM FA011",100 ,0)
  19476    .W:Y="N"  "No" W:Y=" Y" "Yes"
  19477   "RTN","CHM FA011",101 ,0)
  19478    .S CHMFBA SC(QU)=Y
  19479   "RTN","CHM FA011",102 ,0)
  19480    D:$D(CHCL RFG) REPNT
  19481   "RTN","CHM FA011",103 ,0)
  19482    G:$D(DD1O UT) A3
  19483   "RTN","CHM FA011",104 ,0)
  19484   A6 K F1,DD 1OUT,FL
  19485   "RTN","CHM FA011",105 ,0)
  19486    S QU=7,DY =8,DX=50,F LD=30,$Y=D Y,$X=DX X  XY
  19487   "RTN","CHM FA011",106 ,0)
  19488    W BLNK2 X  XY W CHMF BASC(QU)
  19489   "RTN","CHM FA011",107 ,0)
  19490    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19491   "RTN","CHM FA011",108 ,0)
  19492    I $D(DQOU T) D  G A6
  19493   "RTN","CHM FA011",109 ,0)
  19494    .D QUES X  XY
  19495   "RTN","CHM FA011",110 ,0)
  19496    .W BLNK2  X XY W CHM FBASC(QU)
  19497   "RTN","CHM FA011",111 ,0)
  19498    I $D(DUOU T) D  G A4
  19499   "RTN","CHM FA011",112 ,0)
  19500    .S DY=8,D X=50,$Y=DY ,$X=DX X X Y W BLNK2
  19501   "RTN","CHM FA011",113 ,0)
  19502    .S DX=50, $X=DX X XY  W CHMFBAS C(QU)
  19503   "RTN","CHM FA011",114 ,0)
  19504    .D:$D(CHC LRFG) CLEA R,REPNT
  19505   "RTN","CHM FA011",115 ,0)
  19506    S:$D(D1OU T) DD1OUT= 1
  19507   "RTN","CHM FA011",116 ,0)
  19508    Q:$D(D4OU T)
  19509   "RTN","CHM FA011",117 ,0)
  19510    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A6 G SELCT
  19511   "RTN","CHM FA011",118 ,0)
  19512    I Y="@" S  CHMFBASC( QU)="" G A 6
  19513   "RTN","CHM FA011",119 ,0)
  19514    I Y'="" D   G:$D(F1)  A6
  19515   "RTN","CHM FA011",120 ,0)
  19516    .D ^CHMFA 012
  19517   "RTN","CHM FA011",121 ,0)
  19518    .I $D(F1)  S DX=50,D Y=8,$Y=DY, $X=DX X XY  W BLNK2 Q
  19519   "RTN","CHM FA011",122 ,0)
  19520    .D:$D(CHC LRFG) CLEA R,REPNT
  19521   "RTN","CHM FA011",123 ,0)
  19522    .S DX=50, DY=8,$Y=DY ,$X=DX X X Y W BLNK2  X XY W Y
  19523   "RTN","CHM FA011",124 ,0)
  19524    .S CHMFBA SC(QU)=Y
  19525   "RTN","CHM FA011",125 ,0)
  19526    D:$D(CHCL RFG) REPNT  G:$D(DD1O UT) A4
  19527   "RTN","CHM FA011",126 ,0)
  19528   A7 K F1,FL ,DD1OUT
  19529   "RTN","CHM FA011",127 ,0)
  19530    S QU=6,DY =9,DX=50,F LD=30,$Y=D Y,$X=DX X  XY
  19531   "RTN","CHM FA011",128 ,0)
  19532    W BLNK2 X  XY W CHMF BASC(QU)
  19533   "RTN","CHM FA011",129 ,0)
  19534    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19535   "RTN","CHM FA011",130 ,0)
  19536    I $D(DQOU T) D  G A7
  19537   "RTN","CHM FA011",131 ,0)
  19538    .D QUES X  XY
  19539   "RTN","CHM FA011",132 ,0)
  19540    .W BLNK2  X XY W CHM FBASC(QU)
  19541   "RTN","CHM FA011",133 ,0)
  19542    I $D(DUOU T) D  G A6
  19543   "RTN","CHM FA011",134 ,0)
  19544    .S DY=9,D X=50,$Y=DY ,$X=DX X X Y W BLNK2
  19545   "RTN","CHM FA011",135 ,0)
  19546    .S DX=50, $X=DX X XY  W CHMFBAS C(QU)
  19547   "RTN","CHM FA011",136 ,0)
  19548    .D:$D(CHC LRFG) CLEA R,REPNT
  19549   "RTN","CHM FA011",137 ,0)
  19550    S:$D(D1OU T) DD1OUT= 1
  19551   "RTN","CHM FA011",138 ,0)
  19552    Q:$D(D4OU T)
  19553   "RTN","CHM FA011",139 ,0)
  19554    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A7 G SELCT
  19555   "RTN","CHM FA011",140 ,0)
  19556    I Y="@" S  CHMFBASC( QU)="" G A 7
  19557   "RTN","CHM FA011",141 ,0)
  19558    I Y'="" D   G:$D(F1)  A7
  19559   "RTN","CHM FA011",142 ,0)
  19560    .D ^CHMFA 012
  19561   "RTN","CHM FA011",143 ,0)
  19562    .I $D(F1)  S DX=50,D Y=9,$Y=DY, $X=DX X XY  W BLNK2 Q
  19563   "RTN","CHM FA011",144 ,0)
  19564    .D:$D(CHC LRFG) CLEA R,REPNT
  19565   "RTN","CHM FA011",145 ,0)
  19566    .S DX=50, DY=9,$Y=DY ,$X=DX X X Y W BLNK2  X XY W Y
  19567   "RTN","CHM FA011",146 ,0)
  19568    .S CHMFBA SC(QU)=Y
  19569   "RTN","CHM FA011",147 ,0)
  19570    D:$D(CHCL RFG) REPNT  G:$D(DD1O UT) A6
  19571   "RTN","CHM FA011",148 ,0)
  19572   A71 ;CPE V ENDOR STRE AMLINING U SER STORY  2 PL-ZIP 0 5/24/2017  GEF
  19573   "RTN","CHM FA011",149 ,0)
  19574    N CHSERV   ;CPE001-0 20, 021 an d 022
  19575   "RTN","CHM FA011",150 ,0)
  19576    S CHSERV= $P(CHMFBAS C(4),"^")
  19577   "RTN","CHM FA011",151 ,0)
  19578    I CHSERV= "TRV" G A8
  19579   "RTN","CHM FA011",152 ,0)
  19580    I CHSERV' ="IPT",CHS ERV'="OPT" ,CHSERV'=" DNT" G A2
  19581   "RTN","CHM FA011",153 ,0)
  19582    K F1,FL,D D1OUT
  19583   "RTN","CHM FA011",154 ,0)
  19584    S QU=8,DY =10,DX=50, FLD=9,$Y=D Y,$X=DX X  XY
  19585   "RTN","CHM FA011",155 ,0)
  19586    W BLNK2 X  XY W CHMF BASC(QU)
  19587   "RTN","CHM FA011",156 ,0)
  19588    N FL S FL =5
  19589   "RTN","CHM FA011",157 ,0)
  19590    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19591   "RTN","CHM FA011",158 ,0)
  19592    I $D(DQOU T) D  G A7 1
  19593   "RTN","CHM FA011",159 ,0)
  19594    .D QUES X  XY
  19595   "RTN","CHM FA011",160 ,0)
  19596    .W BLNK2  X XY W CHM FBASC(QU)
  19597   "RTN","CHM FA011",161 ,0)
  19598    I $D(DUOU T) D  G A7 1
  19599   "RTN","CHM FA011",162 ,0)
  19600    .S DY=10, DX=50,$Y=D Y,$X=DX X  XY W BLNK2
  19601   "RTN","CHM FA011",163 ,0)
  19602    .S DX=50, $X=DX X XY  W CHMFBAS C(QU)
  19603   "RTN","CHM FA011",164 ,0)
  19604    .D:$D(CHC LRFG) CLEA R,REPNT
  19605   "RTN","CHM FA011",165 ,0)
  19606    S:$D(D1OU T) DD1OUT= 1
  19607   "RTN","CHM FA011",166 ,0)
  19608    Q:$D(D4OU T)
  19609   "RTN","CHM FA011",167 ,0)
  19610    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A71 G SELC T
  19611   "RTN","CHM FA011",168 ,0)
  19612    I Y="@" S  CHMFBASC( QU)="" G A 71
  19613   "RTN","CHM FA011",169 ,0)
  19614    I Y'="" D   G:$D(F1)  A71
  19615   "RTN","CHM FA011",170 ,0)
  19616    .D ^CHMFA 012
  19617   "RTN","CHM FA011",171 ,0)
  19618    .I $D(F1)  S DX=50,D Y=10,$Y=DY ,$X=DX X X Y W BLNK2  Q
  19619   "RTN","CHM FA011",172 ,0)
  19620    .D:$D(CHC LRFG) CLEA R,REPNT
  19621   "RTN","CHM FA011",173 ,0)
  19622    .S DX=50, DY=10,$Y=D Y,$X=DX X  XY W BLNK2  X XY W Y
  19623   "RTN","CHM FA011",174 ,0)
  19624    .S CHMFBA SC(8)=Y
  19625   "RTN","CHM FA011",175 ,0)
  19626    D:$D(CHCL RFG) REPNT  G:$D(DD1O UT) A7
  19627   "RTN","CHM FA011",176 ,0)
  19628   A8 I $P(CH MFBASC(4), "^",1)'="T RV" G A2
  19629   "RTN","CHM FA011",177 ,0)
  19630    K F1,FL,D D1OUT  ;AE B 4/30/201 0 DEV00369 8 ADDED AL L OF A8 ST ART
  19631   "RTN","CHM FA011",178 ,0)
  19632    S QU=11,D Y=10,DX=50 ,FLD=9,$Y= DY,$X=DX X  XY  ;CPE0 01-020, 02 1 and 022
  19633   "RTN","CHM FA011",179 ,0)
  19634    W BLNK2 X  XY W CHMF BASC(11)
  19635   "RTN","CHM FA011",180 ,0)
  19636    S DX=50,$ X=DX X XY  D CSBRS^CH SC2
  19637   "RTN","CHM FA011",181 ,0)
  19638    I $D(DQOU T) D  G A8
  19639   "RTN","CHM FA011",182 ,0)
  19640    .D QUES X  XY
  19641   "RTN","CHM FA011",183 ,0)
  19642    .W BLNK2  X XY W CHM FBASC(QU)
  19643   "RTN","CHM FA011",184 ,0)
  19644    I $D(DUOU T) D  G A7 1
  19645   "RTN","CHM FA011",185 ,0)
  19646    .S DY=10, DX=50,$Y=D Y,$X=DX X  XY W BLNK2
  19647   "RTN","CHM FA011",186 ,0)
  19648    .S DX=50, $X=DX X XY  W CHMFBAS C(QU)
  19649   "RTN","CHM FA011",187 ,0)
  19650    .D:$D(CHC LRFG) CLEA R,REPNT
  19651   "RTN","CHM FA011",188 ,0)
  19652    S:$D(D1OU T) DD1OUT= 1
  19653   "RTN","CHM FA011",189 ,0)
  19654    Q:$D(D4OU T)
  19655   "RTN","CHM FA011",190 ,0)
  19656    I $D(DDOU T)!$D(DFOU T) D:Y'=""  ^CHMFA012  G:$D(F1)  A8 G SELCT
  19657   "RTN","CHM FA011",191 ,0)
  19658    I Y="@" S  CHMFBASC( QU)="" G A 8
  19659   "RTN","CHM FA011",192 ,0)
  19660    I Y'="" D   G:$D(F1)  A8
  19661   "RTN","CHM FA011",193 ,0)
  19662    .D ^CHMFA 012
  19663   "RTN","CHM FA011",194 ,0)
  19664    .I $D(F1)  S DX=50,D Y=10,$Y=DY ,$X=DX X X Y W BLNK2  Q
  19665   "RTN","CHM FA011",195 ,0)
  19666    .D:$D(CHC LRFG) CLEA R,REPNT
  19667   "RTN","CHM FA011",196 ,0)
  19668    .S DX=50, DY=10,$Y=D Y,$X=DX X  XY W BLNK2  X XY W Y
  19669   "RTN","CHM FA011",197 ,0)
  19670    .S CHMFBA SC(QU)=Y
  19671   "RTN","CHM FA011",198 ,0)
  19672    D:$D(CHCL RFG) REPNT  G:$D(DD1O UT) A71
  19673   "RTN","CHM FA011",199 ,0)
  19674    ;AEB 4/30 /2010 DEV0 03698 ADDE D ALL OF A 8 END
  19675   "RTN","CHM FA011",200 ,0)
  19676    G A2
  19677   "RTN","CHM FA011",201 ,0)
  19678   END Q
  19679   "RTN","CHM FA011",202 ,0)
  19680   ERASE S DY =5,DX=50,$ Y=DY,$X=DX  X XY W BL NK2
  19681   "RTN","CHM FA011",203 ,0)
  19682    F DY=6:1: 9 F DX=50, $X=DX X XY  W BLNK2
  19683   "RTN","CHM FA011",204 ,0)
  19684    F II=2:1: 9 S CHMFBA SC(II)=""
  19685   "RTN","CHM FA011",205 ,0)
  19686    Q
  19687   "RTN","CHM FA011",206 ,0)
  19688   TOSMSG S D Y=5,DX=50, $Y=DY,$X=D X X XY W " TOS chng O PT ONLY on  EDI/OCR"
  19689   "RTN","CHM FA011",207 ,0)
  19690    R X:4 X X Y W BLNK2
  19691   "RTN","CHM FA011",208 ,0)
  19692    X XY W:CH MFBASC(QU) '="" $E($P (CHMFBASC( QU),"^",2) ,1,20)
  19693   "RTN","CHM FA011",209 ,0)
  19694    D:$D(CHCL RFG) CLEAR ,REPNT
  19695   "RTN","CHM FA011",210 ,0)
  19696    Q
  19697   "RTN","CHM FA011",211 ,0)
  19698   REPNT D CL EAR^CHMFA0 11,DISP^CH MFA010,DIS P^CHMFA013 ,DATA^CHMF A013 K CHC LRFG Q
  19699   "RTN","CHM FA011",212 ,0)
  19700   GET1 S ZPS N="" Q:'$D (^CHMDIC(7 41002.05,T YP,0))  S  X=^CHMDIC( 741002.05, TYP,0)
  19701   "RTN","CHM FA011",213 ,0)
  19702    S ZPSN=$P (X,"^",2)_ "^"_$P(X," ^",1)_"^"_ TYP_"^"_"B " Q
  19703   "RTN","CHM FA011",214 ,0)
  19704   QUES S HY= DY,HX=DX D  CLEAR S D Y=12,DX=1, $Y=DY,$X=D X X XY G @ QU
  19705   "RTN","CHM FA011",215 ,0)
  19706   2 W !?14," Enter <Y>e s to pay p rovider or  <N>o to p ay benefic iary." G E XIT
  19707   "RTN","CHM FA011",216 ,0)
  19708    G EXIT
  19709   "RTN","CHM FA011",217 ,0)
  19710   3 W !?12," Enter <Y>e s for MCCR  review or  <N>o for  MCCR not n ecessary."
  19711   "RTN","CHM FA011",218 ,0)
  19712    G EXIT
  19713   "RTN","CHM FA011",219 ,0)
  19714   6 W !?25," Enter Type  of Bill,  3 characte rs, 110-99 9"
  19715   "RTN","CHM FA011",220 ,0)
  19716    G EXIT
  19717   "RTN","CHM FA011",221 ,0)
  19718   7 W !!?19, "Enter Pat ient Contr ol Number,  1 to 30 c haracters. " G EXIT
  19719   "RTN","CHM FA011",222 ,0)
  19720   8 W !,?20, "Enter the  Physical  Location z ip code" G  EXIT
  19721   "RTN","CHM FA011",223 ,0)
  19722   11 W !,?20 ,"Enter th e point of  pickup zi p code" G  EXIT  ;AEB  4/30/2010  DEV003698
  19723   "RTN","CHM FA011",224 ,0)
  19724   EXIT S DY= HY,DX=HX,$ Y=DY,$X=DX  Q
  19725   "RTN","CHM FA011",225 ,0)
  19726   SELCT K CH MFKILL,CHM FNEXT,CHMF PREV,Y,CHM FPSUD,CHMF MEDV
  19727   "RTN","CHM FA011",226 ,0)
  19728    D PRMPT^C HMFA100,AS K^CHMFA100
  19729   "RTN","CHM FA011",227 ,0)
  19730    G:Y=1 A2
  19731   "RTN","CHM FA011",228 ,0)
  19732    I Y=2 K N ODAT D  G: $D(NODAT)  A2 D PAGE  G:$D(VNPGF G) SELCT S  CHMFNEXT= 1 Q
  19733   "RTN","CHM FA011",229 ,0)
  19734    .I '$D(CH MFBASC) D  NODAT S NO DAT=1 Q
  19735   "RTN","CHM FA011",230 ,0)
  19736    .F I=2,4  S:CHMFBASC (I)="" NOD AT=1
  19737   "RTN","CHM FA011",231 ,0)
  19738    .;CPE VEN DOR STREAM LINING USE R STORY 2  PL-ZIP 05/ 24/2017 -  make requi red field  for Dental , IP & OP  ; gef
  19739   "RTN","CHM FA011",232 ,0)
  19740    .I $P(CHM FBASC(4)," ^",3)<3!($ P(CHMFBASC (4),"^",3) =5) S:CHMF BASC(8)=""  NODAT=1
  19741   "RTN","CHM FA011",233 ,0)
  19742    .D:$D(NOD AT) NODAT  Q
  19743   "RTN","CHM FA011",234 ,0)
  19744    I Y=3 S C HMFPREV=1  Q
  19745   "RTN","CHM FA011",235 ,0)
  19746    I Y=4 S C HMFKILL=1  Q
  19747   "RTN","CHM FA011",236 ,0)
  19748    I Y=5 D ^ CHMFA014 G  A2
  19749   "RTN","CHM FA011",237 ,0)
  19750    I Y=6 S V FN="" D CL EAR D ^CHM FA015 G A2
  19751   "RTN","CHM FA011",238 ,0)
  19752    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
  19753   "RTN","CHM FA011",239 ,0)
  19754   NODAT D CL EAR S DY=1 4,DX=11,$Y =DY,$X=DX  X XY
  19755   "RTN","CHM FA011",240 ,0)
  19756    ;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
  19757   "RTN","CHM FA011",241 ,0)
  19758    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
  19759   "RTN","CHM FA011",242 ,0)
  19760    W "Vendor , Type of  Service, a nd Assignm ent must b e entered. "
  19761   "RTN","CHM FA011",243 ,0)
  19762    Q
  19763   "RTN","CHM FA011",244 ,0)
  19764   PAGE K VNP GFG Q:'$D( CHMFBASC(1 ))  Q:$P(C HMFBASC(1) ,"^",1)=""
  19765   "RTN","CHM FA011",245 ,0)
  19766    S VNPG=$P (CHMFBASC( 1),"^",1)  Q:$D(^CHMI MAGE(CHMFP DI,"VNPG", VNPG))
  19767   "RTN","CHM FA011",246 ,0)
  19768    I $D(VFN)  I VFN Q:$ D(^CHMIMAG E(CHMFPDI, "VNPG",VFN ))
  19769   "RTN","CHM FA011",247 ,0)
  19770    D CLEAR S  DY=12,DX= 20,$Y=DY,$ X=DX X XY  S VNPGFG=1
  19771   "RTN","CHM FA011",248 ,0)
  19772   PG1 ;W !!, ?11,"Enter  the page  that vendo r informat ion can be  found on:  "
  19773   "RTN","CHM FA011",249 ,0)
  19774    ;D CSBRS^ CHSC2 G:$D (DUOUT) PG 2 G:$D(DFO UT) PG2 G: $D(DQOUT)  PG1
  19775   "RTN","CHM FA011",250 ,0)
  19776    ;
  19777   "RTN","CHM FA011",251 ,0)
  19778    ;G:'Y PG1
  19779   "RTN","CHM FA011",252 ,0)
  19780    S Y=""
  19781   "RTN","CHM FA011",253 ,0)
  19782    I CHMFNMP G'="UNK" G :Y>CHMFNMP G PG1
  19783   "RTN","CHM FA011",254 ,0)
  19784    I $D(VFN)  I VFN S ^ CHMIMAGE(C HMFPDI,"VN PG",VFN)=Y  K VNPGFG  G PG2
  19785   "RTN","CHM FA011",255 ,0)
  19786    S ^CHMIMA GE(CHMFPDI ,"VNPG",VN PG)=Y K VN PGFG
  19787   "RTN","CHM FA011",256 ,0)
  19788   PG2 Q
  19789   "RTN","CHM FA011",257 ,0)
  19790   ASSIGN K C HASSOV Q:' $D(CHMFBAS C(4))  Q:C HMFBASC(4) =""
  19791   "RTN","CHM FA011",258 ,0)
  19792    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
  19793   "RTN","CHM FA011",259 ,0)
  19794    I $P(CHMF BASC(4),"^ ",3)=1 D A SSINP Q
  19795   "RTN","CHM FA011",260 ,0)
  19796    I $P(CHMF BASC(4),"^ ",3)=3 D A SSPHR Q
  19797   "RTN","CHM FA011",261 ,0)
  19798    I VFN I $ D(^CHMVEN( VFN,1)) I  $P(^CHMVEN (VFN,1),"^ ",16)=1 S  CHMFBASC(2 )="Y",CHAS SOV=1
  19799   "RTN","CHM FA011",262 ,0)
  19800    Q
  19801   "RTN","CHM FA011",263 ,0)
  19802   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
  19803   "RTN","CHM FA011",264 ,0)
  19804    S CHMFBAS C(2)="Y" Q
  19805   "RTN","CHM FA011",265 ,0)
  19806   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
  19807   "RTN","CHM FA011",266 ,0)
  19808    S CHMFBAS C(2)="Y" Q
  19809   "RTN","CHM FA011",267 ,0)
  19810    ;CFS DEFE CT 826304  change F D Y=12:1:20  to F DY=11 :1:20 to c lean up sc reen.
  19811   "RTN","CHM FA011",268 ,0)
  19812   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
  19813   "RTN","CHM FA011",269 ,0)
  19814    S DY=ZY,D X=ZX,$Y=DY ,$X=DX X X Y S CHCLRF G=1 Q
  19815   "RTN","CHM FA011",270 ,0)
  19816   SBRS D CSB RS^CHSC2 Q
  19817   "RTN","CHM FA011",271 ,0)
  19818    S Y="" S: '$D(FLD) F LD=30 S:FL D="" FLD=3 0 U $I X ^ %ZOSF("EOF F") K TL
  19819   "RTN","CHM FA011",272 ,0)
  19820    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)
  19821   "RTN","CHM FA011",273 ,0)
  19822    .S:I=1 I= 0 Q:I=0  S :I'=1 I=I- 2,Y=$E(Y,1 ,I) W *8,* 27,"[1X" Q
  19823   "RTN","CHM FA011",274 ,0)
  19824   SBRS1 K DF OUT,DUOUT, DQOUT,DDOU T,D1OUT,D2 OUT,D3OUT, D4OUT,DTOU T,DPOUT,DN OUT
  19825   "RTN","CHM FA011",275 ,0)
  19826    I X=27 F  I=1:1:2 R  *X D:I=2
  19827   "RTN","CHM FA011",276 ,0)
  19828    .S:X=65 D 1OUT="" S: X=66 D2OUT ="" S:X=67  D3OUT=""  S:X=68 D4O UT=""
  19829   "RTN","CHM FA011",277 ,0)
  19830    .I (X=54)  R *X S:X= 126 DNOUT= ""
  19831   "RTN","CHM FA011",278 ,0)
  19832    .I (X=53)  R *X S:X= 126 DPOUT= ""
  19833   "RTN","CHM FA011",279 ,0)
  19834    S:X=9 DDO UT="" S:X= 9 DTOUT=""  I Y="^^"  S (DFOUT,Y )=""
  19835   "RTN","CHM FA011",280 ,0)
  19836    S:Y="^" ( DUOUT,Y)=" " S:Y?1"?" .E!(Y["^")  (DQOUT,Y) =""
  19837   "RTN","CHM FA011",281 ,0)
  19838    U $I X ^% ZOSF("EON" ) Q
  19839   "RTN","CHM FA01D")
  19840   0^45^B5815 956
  19841   "RTN","CHM FA01D",1,0 )
  19842   CHMFA01D ; JLR/DEN;VE NDOR SELEC  SCREEN;08 /20/98  8: 16 AM
  19843   "RTN","CHM FA01D",2,0 )
  19844    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  19845   "RTN","CHM FA01D",3,0 )
  19846    ;DEV00799 1 10/08/20 10 JAK -VE NDOR LOOKU P utilizin g NPI
  19847   "RTN","CHM FA01D",4,0 )
  19848    ;TGH CPE0 01-019 Dis play Remit  to Name.
  19849   "RTN","CHM FA01D",5,0 )
  19850    S DTM=12, DBM=20,FLD ="" X CHMA R
  19851   "RTN","CHM FA01D",6,0 )
  19852    S BLNK1=" " S $P(BLN K1," ",22) ="" S BLNK 2="" S $P( BLNK2," ", 31)=""
  19853   "RTN","CHM FA01D",7,0 )
  19854   A1 S ZPSN= ""
  19855   "RTN","CHM FA01D",8,0 )
  19856    I CHPDIPR L I $D(CHX TID) I CHX TID'="" S  (CHXNPI,CH TIN,CHXPRN ,CHTMPST,C HXRZIP,CHX ZIP,CHSTAT E)="" G A1 0    ;DEV0 07991 10/0 8/2010 JAK  -VENDOR L OOKUP
  19857   "RTN","CHM FA01D",9,0 )
  19858    D ^CHMFA0 1E
  19859   "RTN","CHM FA01D",10, 0)
  19860    I $D(DDOU T) I (CHXT ID="")&(CH XNPI="")&( CHXPRN="")  Q                                           ;DEV00799 1 10/08/20 10 JAK -VE NDOR LOOKU P
  19861   "RTN","CHM FA01D",11, 0)
  19862   A10 ;
  19863   "RTN","CHM FA01D",12, 0)
  19864    S DTM=6,D BM=22 X CH MAR
  19865   "RTN","CHM FA01D",13, 0)
  19866    S SCRLTOP =4,SCRLBOT =22
  19867   "RTN","CHM FA01D",14, 0)
  19868    S CHIPVFL G=1 D ^CHM FA01F K CH IPVFLG
  19869   "RTN","CHM FA01D",15, 0)
  19870    I VFN'=""  D 
  19871   "RTN","CHM FA01D",16, 0)
  19872    .S ZPSN=" " Q:'$D(^C HMVEN(VFN, 0))  S X=^ CHMVEN(VFN ,0)
  19873   "RTN","CHM FA01D",17, 0)
  19874    .S X2=""  S:$D(^CHMV EN(VFN,1))  X1=^(1)
  19875   "RTN","CHM FA01D",18, 0)
  19876    .S ZPSN=$ P(X,"^",1) _"^"_$P(X, "^",3)_"^" _$P(X1,"^" ,1)_"^"_$P (X1,"^",2) _"^"_$P(X1 ,"^",3)_"^ "_$P(X1,"^ ",4)_"^"_$ P(X1,"^",5 )_"^"_VFN_ "^"_"B" Q
  19877   "RTN","CHM FA01D",19, 0)
  19878    D ^CHMFSE T,VEN^CHMF A010,TITLE ^CHMFA010, DISP^CHMFA 010,LINE^C HMFA100
  19879   "RTN","CHM FA01D",20, 0)
  19880    I VFN=""  D
  19881   "RTN","CHM FA01D",21, 0)
  19882    .S DY=5,D X=10,$Y=DY ,$X=DX X X Y W BLNK1  X XY W *7, "   ??"
  19883   "RTN","CHM FA01D",22, 0)
  19884    .R X:2 X  XY W BLNK1  X XY
  19885   "RTN","CHM FA01D",23, 0)
  19886    .D CLEAR^ CHMFA011,R EPNT^CHMFA 011,^CHMFA 01E Q
  19887   "RTN","CHM FA01D",24, 0)
  19888   A11 I ZPSN ="" D  G A 1
  19889   "RTN","CHM FA01D",25, 0)
  19890    .S DY=5,D X=10,$Y=DY ,$X=DX X X Y W BLNK1  X XY W *7, "   ??"
  19891   "RTN","CHM FA01D",26, 0)
  19892    .R X:2 X  XY W BLNK1  X XY
  19893   "RTN","CHM FA01D",27, 0)
  19894    .D CLEAR^ CHMFA011,R EPNT^CHMFA 011
  19895   "RTN","CHM FA01D",28, 0)
  19896    S PTR=$P( ZPSN,"^",8 )
  19897   "RTN","CHM FA01D",29, 0)
  19898    I PTR D
  19899   "RTN","CHM FA01D",30, 0)
  19900    .I $D(^CH MVEN(PTR,2 )) S $P(ZP SN,"^",1)= $P(^CHMVEN (PTR,2),"^ ",8)
  19901   "RTN","CHM FA01D",31, 0)
  19902    .I $D(^CH MVEN(PTR,0 )) D
  19903   "RTN","CHM FA01D",32, 0)
  19904    ..S PRTTA XID=$P(^(0 ),"^",3)
  19905   "RTN","CHM FA01D",33, 0)
  19906    ..S PRTTA XAC=$P(^(0 ),"^",23)
  19907   "RTN","CHM FA01D",34, 0)
  19908    ..S:$D(^C HMVEN(PTR, 14)) PRTTA XMD=$P(^(1 4),"^",1)
  19909   "RTN","CHM FA01D",35, 0)
  19910    ..S:PRTTA XAC="" PRT TAXAC="  "  S:PRTTAXM D="" PRTTA XMD="  "
  19911   "RTN","CHM FA01D",36, 0)
  19912    ..S PRTTA XID=PRTTAX ID_"-"_PRT TAXAC_"-"_ PRTTAXMD
  19913   "RTN","CHM FA01D",37, 0)
  19914    S CHMFBAS C(1)=$E($P (ZPSN,"^", 1),1,20)_" ^"_$P(ZPSN ,"^",8)
  19915   "RTN","CHM FA01D",38, 0)
  19916    S CHVENNM =$P(ZPSN," ^",1) S ^D ISV(DUZ,"C HVEN")=$P( ZPSN,"^",8 )
  19917   "RTN","CHM FA01D",39, 0)
  19918    ;---Begin  CPE001-01 9
  19919   "RTN","CHM FA01D",40, 0)
  19920    ; Reset V endor Name  to Remit- to Name
  19921   "RTN","CHM FA01D",41, 0)
  19922    S CHVENNM =$P(^CHMVE N(PTR,0)," ^",1)
  19923   "RTN","CHM FA01D",42, 0)
  19924    ;---End C PE001-019
  19925   "RTN","CHM FA01D",43, 0)
  19926    ;S DY=5,D X=10 X XY  W PRTTAXID
  19927   "RTN","CHM FA01D",44, 0)
  19928    ;S DY=6,D X=10 X XY  W BLNK1
  19929   "RTN","CHM FA01D",45, 0)
  19930    ;X XY W $ E($P(ZPSN, "^",1),1,2 0)
  19931   "RTN","CHM FA01D",46, 0)
  19932    S VFN=$P( ZPSN,"^",8 ) K CHMVEN
  19933   "RTN","CHM FA01D",47, 0)
  19934    D:'CHPDIP RL ERASE^C HMFA011 D  REPNT^CHMF A011,HEAD^ CHMFA100
  19935   "RTN","CHM FA01D",48, 0)
  19936    D:$D(CHCL RFG) REPNT ^CHMFA011
  19937   "RTN","CHM FA01D",49, 0)
  19938   END Q
  19939   "RTN","CHM FA01E")
  19940   0^46^B5618 5655
  19941   "RTN","CHM FA01E",1,0 )
  19942   CHMFA01E ; JLR/DEN;VE NDOR PROMP T E/E SCRE EN;Feb 06,  2019@10:1 3:06
  19943   "RTN","CHM FA01E",2,0 )
  19944    ;;1.0;CHA MPVA SYSTE M;**1,8,14 **;JULY 4,  1990;Buil d 5
  19945   "RTN","CHM FA01E",3,0 )
  19946    ;;V2.0
  19947   "RTN","CHM FA01E",4,0 )
  19948    ;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
  19949   "RTN","CHM FA01E",5,0 )
  19950    ;BUG00799 1-07-03 DR W - K DIC  in NPI lin e tag befo re using N PI search  12/20/10
  19951   "RTN","CHM FA01E",6,0 )
  19952    ;BUG00799 1-07-06 DR W - Cursor  placement  is shifti ng to next  field at  the end of
  19953   "RTN","CHM FA01E",7,0 )
  19954    ;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
  19955   "RTN","CHM FA01E",8,0 )
  19956    ;HM 06/30 /17 CPE001 -001-T3-52 2242 Modif y code to  use skip p zip and ps tate field s.
  19957   "RTN","CHM FA01E",9,0 )
  19958    ;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
  19959   "RTN","CHM FA01E",10, 0)
  19960    ;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
  19961   "RTN","CHM FA01E",11, 0)
  19962    S BLNK1=" " S $P(BLN K1," ",30) =""
  19963   "RTN","CHM FA01E",12, 0)
  19964    K CHXTID, CHTIN,CHXI M,CHXNPI,C HXPRN,CHST ATE,CHTMPS T,CHXZIP,C HXRZIP      ;DEV00799 1 10/08/20 10 JAK -
  19965   "RTN","CHM FA01E",13, 0)
  19966    S:'$D(CHX TID) CHXTI D=""
  19967   "RTN","CHM FA01E",14, 0)
  19968    S:'$D(CHX NPI) CHXNP I=""    ;D EV007991 1 0/08/2010  JAK -
  19969   "RTN","CHM FA01E",15, 0)
  19970    S:'$D(CHX PRN) CHXPR N=""
  19971   "RTN","CHM FA01E",16, 0)
  19972    S:'$D(CHS TATE) CHST ATE=""
  19973   "RTN","CHM FA01E",17, 0)
  19974    S:'$D(CHT MPST) CHTM PST=""
  19975   "RTN","CHM FA01E",18, 0)
  19976    S:'$D(CHX ZIP) CHXZI P=""
  19977   "RTN","CHM FA01E",19, 0)
  19978    S:'$D(CHX RZIP) CHXR ZIP=""  ;D EV007991 1 0/08/2010  JAK -
  19979   "RTN","CHM FA01E",20, 0)
  19980    S:'$D(CHB DFLG) CHBD FLG=1  ;TL H 7/6/07 D EV00374  ; TLH 9/20/0 7 BUG00037 4
  19981   "RTN","CHM FA01E",21, 0)
  19982   TID ;; TID  DATA ENTR Y
  19983   "RTN","CHM FA01E",22, 0)
  19984    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
  19985   "RTN","CHM FA01E",23, 0)
  19986    S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  19987   "RTN","CHM FA01E",24, 0)
  19988    G:$D(DUOU T) TID
  19989   "RTN","CHM FA01E",25, 0)
  19990    I $D(DQOU T) D QUES  X XY W BLN K1 W CHXTI D G TID
  19991   "RTN","CHM FA01E",26, 0)
  19992    Q:$D(DDOU T)!$D(DFOU T)
  19993   "RTN","CHM FA01E",27, 0)
  19994    G:$D(D1OU T) TID
  19995   "RTN","CHM FA01E",28, 0)
  19996    I Y="" D: $D(CHCLRFG ) REPNT G  NPI
  19997   "RTN","CHM FA01E",29, 0)
  19998    ;I Y=" ", $D(^DISV(D UZ,"CHVEN" )) S VFN=^ ("CHVEN")  D GET S VF N="" G END
  19999   "RTN","CHM FA01E",30, 0)
  20000    I Y="@" S  CHXTID="" ,VFN="" K  CHMVEN D C LEAR,DISP^ CHMFA013 G  TID
  20001   "RTN","CHM FA01E",31, 0)
  20002    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
  20003   "RTN","CHM FA01E",32, 0)
  20004    I $L(Y)<= 9 S CHTIN= Y
  20005   "RTN","CHM FA01E",33, 0)
  20006    I $L(Y)>9  S CHTIN=$ E(Y,1,9)_" *"_$E(Y,10 ,11) S CHX IM=$E(Y,12 ,13)
  20007   "RTN","CHM FA01E",34, 0)
  20008    K CHFIOUT
  20009   "RTN","CHM FA01E",35, 0)
  20010    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
  20011   "RTN","CHM FA01E",36, 0)
  20012    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
  20013   "RTN","CHM FA01E",37, 0)
  20014    .D CLEAR  S DY=14,DX =32,$Y=DY, $X=DX X XY  W *7," NO  VENDOR FO UND" S CHC LRFG=1
  20015   "RTN","CHM FA01E",38, 0)
  20016    S CHXTID= CHTIN
  20017   "RTN","CHM FA01E",39, 0)
  20018    ;
  20019   "RTN","CHM FA01E",40, 0)
  20020    N TIN837   ;CPE001-0 14 1/22/20 18 TGH - N ew variabl e and Get  TIN from 8 37
  20021   "RTN","CHM FA01E",41, 0)
  20022    S TIN837= $P($G(^CHM IMAGE(CHMF PDI,"P-VEN ",1,0)),U, 5)
  20023   "RTN","CHM FA01E",42, 0)
  20024    ;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
  20025   "RTN","CHM FA01E",43, 0)
  20026    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
  20027   "RTN","CHM FA01E",44, 0)
  20028    ;
  20029   "RTN","CHM FA01E",45, 0)
  20030    S DX=10,D Y=5,$Y=DY, $X=DX X XY
  20031   "RTN","CHM FA01E",46, 0)
  20032    I $L(Y)<1 2 W CHXTID
  20033   "RTN","CHM FA01E",47, 0)
  20034    E  W CHXT ID_"*"_CHX IM
  20035   "RTN","CHM FA01E",48, 0)
  20036    D:$D(CHCL RFG) REPNT
  20037   "RTN","CHM FA01E",49, 0)
  20038   NPI ;; NPI  DATA ENTR Y  ;DEV007 991 10/08/ 2010 JAK c hange ^uti lity to ^t mp
  20039   "RTN","CHM FA01E",50, 0)
  20040    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.
  20041   "RTN","CHM FA01E",51, 0)
  20042    S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20043   "RTN","CHM FA01E",52, 0)
  20044    I $D(DQOU T) D QUES  X XY W BLN K1 W CHXNP I G NPI
  20045   "RTN","CHM FA01E",53, 0)
  20046    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
  20047   "RTN","CHM FA01E",54, 0)
  20048    Q:$D(DDOU T)!$D(DFOU T)
  20049   "RTN","CHM FA01E",55, 0)
  20050    I $D(D1OU T) D:$D(CH CLRFG) REP NT G TID
  20051   "RTN","CHM FA01E",56, 0)
  20052    I Y="" D: $D(CHCLRFG ) REPNT G  RTNAME
  20053   "RTN","CHM FA01E",57, 0)
  20054    I Y=" ",$ D(^DISV(DU Z,"CHVEN") ) S VFN=^( "CHVEN") D  GET S VFN ="" G END
  20055   "RTN","CHM FA01E",58, 0)
  20056    I Y="@" S  CHXNPI=""  G NPI
  20057   "RTN","CHM FA01E",59, 0)
  20058    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
  20059   "RTN","CHM FA01E",60, 0)
  20060    K ^TMP($J ,"DILIST") ,DIC                                   ;DEV 007991 10/ 08/2010 JA K change ^ utility to  ^tmp
  20061   "RTN","CHM FA01E",61, 0)
  20062    ;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 .
  20063   "RTN","CHM FA01E",62, 0)
  20064    ;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
  20065   "RTN","CHM FA01E",63, 0)
  20066    ;AJF - st ory 001-00 9
  20067   "RTN","CHM FA01E",64, 0)
  20068    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
  20069   "RTN","CHM FA01E",65, 0)
  20070    I $P($D(^ TMP($J,"DI LIST","DIL IST",0)),U ,1)<1 D  G  NPI
  20071   "RTN","CHM FA01E",66, 0)
  20072    .D CLEAR  S DY=13,DX =32,$Y=DY, $X=DX X XY  W *7," NO  VENDORS F OUND" S CH CLRFG=1
  20073   "RTN","CHM FA01E",67, 0)
  20074    S CHXNPI= Y
  20075   "RTN","CHM FA01E",68, 0)
  20076    S DX=10,D Y=6,$Y=DY, $X=DX X XY  W CHXNPI
  20077   "RTN","CHM FA01E",69, 0)
  20078    D:$D(CHCL RFG) REPNT
  20079   "RTN","CHM FA01E",70, 0)
  20080   RTNAME  ;R EMIT-TO NA ME DATA EN TRY  ;DEV0 07991 10/0 8/2010 JAK
  20081   "RTN","CHM FA01E",71, 0)
  20082    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
  20083   "RTN","CHM FA01E",72, 0)
  20084    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370
  20085   "RTN","CHM FA01E",73, 0)
  20086    ;W CHXPRN  S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20087   "RTN","CHM FA01E",74, 0)
  20088    S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20089   "RTN","CHM FA01E",75, 0)
  20090    I $D(DQOU T) D QUES  X XY W BLN K1 W CHXPR N G RTNAME
  20091   "RTN","CHM FA01E",76, 0)
  20092    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
  20093   "RTN","CHM FA01E",77, 0)
  20094    Q:$D(DDOU T)!$D(DFOU T)
  20095   "RTN","CHM FA01E",78, 0)
  20096    I $D(D1OU T) D:$D(CH CLRFG) REP NT G NPI
  20097   "RTN","CHM FA01E",79, 0)
  20098    I Y="" D: $D(CHCLRFG ) REPNT G  RZIP
  20099   "RTN","CHM FA01E",80, 0)
  20100    I Y=" ",$ D(^DISV(DU Z,"CHVEN") ) S VFN=^( "CHVEN") D  GET S VFN ="" G END
  20101   "RTN","CHM FA01E",81, 0)
  20102    I Y="@" S  CHXPRN=""  G RTNAME
  20103   "RTN","CHM FA01E",82, 0)
  20104    K ^TMP("D ILIST",$J)                  ;DEV 007991 10/ 08/2010 JA K change ^ utility to  ^tmp
  20105   "RTN","CHM FA01E",83, 0)
  20106    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
  20107   "RTN","CHM FA01E",84, 0)
  20108    I $P($D(^ TMP($J,"DI LIST","DIL IST",0)),U ,1)<1 D  G  RTNAME
  20109   "RTN","CHM FA01E",85, 0)
  20110    .D CLEAR  S DY=13,DX =32,$Y=DY, $X=DX X XY  W *7," NO  VENDOR FO UND" S CHC LRFG=1
  20111   "RTN","CHM FA01E",86, 0)
  20112    S CHXPRN= Y
  20113   "RTN","CHM FA01E",87, 0)
  20114    S DX=10,D Y=7,$Y=DY, $X=DX X XY  W CHXPRN
  20115   "RTN","CHM FA01E",88, 0)
  20116    D:$D(CHCL RFG) REPNT
  20117   "RTN","CHM FA01E",89, 0)
  20118   RZIP  ; RE MIT-TO ZIP  DATA ENTR Y  ;DEV007 991 10/08/ 2010 JAK
  20119   "RTN","CHM FA01E",90, 0)
  20120    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370
  20121   "RTN","CHM FA01E",91, 0)
  20122    ;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
  20123   "RTN","CHM FA01E",92, 0)
  20124    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
  20125   "RTN","CHM FA01E",93, 0)
  20126    S DX=10,$ X=DX X XY  D CSBRS^CH SC2
  20127   "RTN","CHM FA01E",94, 0)
  20128    I $D(DQOU T) D QUES  X XY W BLN K1 X XY W  CHXRZIP G  RZIP
  20129   "RTN","CHM FA01E",95, 0)
  20130    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370
  20131   "RTN","CHM FA01E",96, 0)
  20132    ;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
  20133   "RTN","CHM FA01E",97, 0)
  20134    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
  20135   "RTN","CHM FA01E",98, 0)
  20136    I $D(D1OU T) D:$D(CH CLRFG) REP NT G RTNAM E
  20137   "RTN","CHM FA01E",99, 0)
  20138    Q:$D(DDOU T)!$D(DFOU T)
  20139   "RTN","CHM FA01E",100 ,0)
  20140    ;SBB 09/1 7/18 DEFEC T_CPE001-0 01 824370
  20141   "RTN","CHM FA01E",101 ,0)
  20142    I Y="" D: $D(CHCLRFG ) REPNT G  TID
  20143   "RTN","CHM FA01E",102 ,0)
  20144    I Y="@" S  CHXRZIP=" " G RZIP
  20145   "RTN","CHM FA01E",103 ,0)
  20146    S CHXRZIP =Y
  20147   "RTN","CHM FA01E",104 ,0)
  20148    S DX=10,D Y=8,$Y=DY, $X=DX X XY  W CHXRZIP
  20149   "RTN","CHM FA01E",105 ,0)
  20150    D:$D(CHCL RFG) REPNT
  20151   "RTN","CHM FA01E",106 ,0)
  20152    ;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
  20153   "RTN","CHM FA01E",107 ,0)
  20154    ;PZIP  ;  PHYSICAL L OCATION ZI P DATA ENT RY  ;DEV00 7991 10/08 /2010 JAK
  20155   "RTN","CHM FA01E",108 ,0)
  20156    ;S BLNK1= "" S $P(BL NK1," ",10 )=""
  20157   "RTN","CHM FA01E",109 ,0)
  20158    ;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
  20159   "RTN","CHM FA01E",110 ,0)
  20160    ;S DX=10, $X=DX X XY  D CSBRS^C HSC2
  20161   "RTN","CHM FA01E",111 ,0)
  20162    ;I $D(DQO UT) D QUES  X XY W BL NK1 X XY W  CHXZIP G  PZIP
  20163   "RTN","CHM FA01E",112 ,0)
  20164    ;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
  20165   "RTN","CHM FA01E",113 ,0)
  20166    ;I $D(D1O UT) D:$D(C HCLRFG) RE PNT G RZIP
  20167   "RTN","CHM FA01E",114 ,0)
  20168    ;Q:$D(DDO UT)!$D(DFO UT)
  20169   "RTN","CHM FA01E",115 ,0)
  20170    ;I Y="@"  S CHXZIP=" " G PZIP
  20171   "RTN","CHM FA01E",116 ,0)
  20172    ;S CHXZIP =Y
  20173   "RTN","CHM FA01E",117 ,0)
  20174    ;S DX=10, DY=9,$Y=DY ,$X=DX X X Y W CHXZIP
  20175   "RTN","CHM FA01E",118 ,0)
  20176    ;D:$D(CHC LRFG) REPN T
  20177   "RTN","CHM FA01E",119 ,0)
  20178    ;PSTATE   ; PHYSICAL  LOCATION  STATE DATA  ENTRY (LO C. DY=9 RO LLS, DX=26  COLUMNS).
  20179   "RTN","CHM FA01E",120 ,0)
  20180    ;S BLNK1= "" S $P(BL NK1," ",15 )=""     ; ;DEV 7991a  DRW 10/06 /10 BLNK1  BLANKS OUT  A 15 CHAR . FIELD
  20181   "RTN","CHM FA01E",121 ,0)
  20182    ;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
  20183   "RTN","CHM FA01E",122 ,0)
  20184    ;S DX=26, $X=DX X XY  D CSBRS^C HSC2
  20185   "RTN","CHM FA01E",123 ,0)
  20186    ;I $D(DQO UT) D QUES  X XY W BL NK1 X XY W  CHTMPST G  PSTATE
  20187   "RTN","CHM FA01E",124 ,0)
  20188    ;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
  20189   "RTN","CHM FA01E",125 ,0)
  20190    ;I $D(D1O UT) D:$D(C HCLRFG) RE PNT G PZIP
  20191   "RTN","CHM FA01E",126 ,0)
  20192    ;Q:$D(DDO UT)!$D(DFO UT)
  20193   "RTN","CHM FA01E",127 ,0)
  20194    ;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
  20195   "RTN","CHM FA01E",128 ,0)
  20196    ;I Y="@"  S CHTMPST= "",CHSTATE ="" G PSTA TE
  20197   "RTN","CHM FA01E",129 ,0)
  20198    ;;I Y=""  D:$D(CHCLR FG) REPNT  G A5
  20199   "RTN","CHM FA01E",130 ,0)
  20200    ;D ^CHGVQ 034 D ^CHM FSET,REPNT
  20201   "RTN","CHM FA01E",131 ,0)
  20202    ;I CHBDFL G=0 K CHBD FLG G PSTA TE  ;TLH 7 /6/07 DEV0 00374
  20203   "RTN","CHM FA01E",132 ,0)
  20204    ;S CHTMPS T=$P(Y,"^" ,2)            ;DEV 7 991a DRW -  CHTMPST c ontains th e state na me
  20205   "RTN","CHM FA01E",133 ,0)
  20206    ;S CHSTAT E=$P(Y,"^" ,1)            ;DEV 7 991a DRW -  CHSTATE c ontains th e numeric  country co de
  20207   "RTN","CHM FA01E",134 ,0)
  20208    ;S DX=26, DY=9,$Y=DY ,$X=DX X X Y W CHTMPS T
  20209   "RTN","CHM FA01E",135 ,0)
  20210    ;D:$D(CHC LRFG) REPN T
  20211   "RTN","CHM FA01E",136 ,0)
  20212    G TID
  20213   "RTN","CHM FA01E",137 ,0)
  20214   END ;END
  20215   "RTN","CHM FA01E",138 ,0)
  20216    Q
  20217   "RTN","CHM FA01E",139 ,0)
  20218   REPNT  ;RE PNT
  20219   "RTN","CHM FA01E",140 ,0)
  20220    D CLEAR,D ISP^CHMFA0 13,DATA^CH MFA013 K C HCLRFG Q
  20221   "RTN","CHM FA01E",141 ,0)
  20222   GET    ;GE T
  20223   "RTN","CHM FA01E",142 ,0)
  20224    S ZPSN=""  Q:'$D(^CH MVEN(VFN,0 ))  S X=^C HMVEN(VFN, 0)
  20225   "RTN","CHM FA01E",143 ,0)
  20226    S X2="" S :$D(^CHMVE N(VFN,1))  X1=^(1)
  20227   "RTN","CHM FA01E",144 ,0)
  20228    S:$D(^CHM VEN(VFN,2) ) X2=^(2)
  20229   "RTN","CHM FA01E",145 ,0)
  20230    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"
  20231   "RTN","CHM FA01E",146 ,0)
  20232    Q
  20233   "RTN","CHM FA01E",147 ,0)
  20234   QUES   ;DI SPLAYED WH EN ?
  20235   "RTN","CHM FA01E",148 ,0)
  20236    S HY=DY,H X=DX D CLE AR S DY=12 ,DX=1,$Y=D Y,$X=DX X  XY G @QU
  20237   "RTN","CHM FA01E",149 ,0)
  20238   90 W !!,?2 1,"   Ente r Tax ID a nd Vendor  Address co de.  " G E XIT
  20239   "RTN","CHM FA01E",150 ,0)
  20240   91 W !!,?2 1,"Enter t he NPI-Nat ional Prov ider Ident ifier" G E XIT     ;D EV007991 1 0/08/2010  JAK
  20241   "RTN","CHM FA01E",151 ,0)
  20242   92 W !!,?2 1,"        Enter prov ider remit -to name.       " G E XIT
  20243   "RTN","CHM FA01E",152 ,0)
  20244   93 W !!,?2 1,"    Ent er provide r remit-to  zip code.      " G E XIT     ;D EV007991 1 0/08/2010  JAK
  20245   "RTN","CHM FA01E",153 ,0)
  20246   94 W !!,?2 1,"Enter p rovider ph ysical loc ation zip  code." G E XIT
  20247   "RTN","CHM FA01E",154 ,0)
  20248   95 W !!,?2 1," Enter  provider p hysical lo cation sta te.  " G E XIT     ;D EV007991 1 0/08/2010  JAK
  20249   "RTN","CHM FA01E",155 ,0)
  20250   EXIT   ;EX IT
  20251   "RTN","CHM FA01E",156 ,0)
  20252    S DY=HY,D X=HX,$Y=DY ,$X=DX Q
  20253   "RTN","CHM FA01E",157 ,0)
  20254   CLEAR  ;CL EAR
  20255   "RTN","CHM FA01E",158 ,0)
  20256    S ZY=DY,Z X=DX F DY= 12:1:20 S  DX=1,$X=DX  X XY W @C HEOL
  20257   "RTN","CHM FA01E",159 ,0)
  20258    S DY=ZY,D X=ZX,$Y=DY ,$X=DX X X Y S CHCLRF G=1 Q
  20259   "RTN","CHM FA01E",160 ,0)
  20260   CSBRS  ;CS BRS
  20261   "RTN","CHM FA01E",161 ,0)
  20262    S Y="" S: '$D(FLD) F LD=30 S:FL D="" FLD=3 0 U $I X ^ %ZOSF("EOF F") K TL
  20263   "RTN","CHM FA01E",162 ,0)
  20264    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)
  20265   "RTN","CHM FA01E",163 ,0)
  20266    .S:I=1 I= 0 Q:I=0  S :I'=1 I=I- 2,Y=$E(Y,1 ,I) W *8,* 27,"[1X" Q
  20267   "RTN","CHM FA01E",164 ,0)
  20268   CSBRS1 ;CS BRS1
  20269   "RTN","CHM FA01E",165 ,0)
  20270    K DFOUT,D UOUT,DQOUT ,DDOUT,D1O UT,D2OUT,D 3OUT,D4OUT ,DTOUT,DPO UT,DNOUT
  20271   "RTN","CHM FA01E",166 ,0)
  20272    I X=27 F  I=1:1:2 R  *X D:I=2
  20273   "RTN","CHM FA01E",167 ,0)
  20274    .S:X=65 D 1OUT="" S: X=66 D2OUT ="" S:X=67  D3OUT=""  S:X=68 D4O UT=""
  20275   "RTN","CHM FA01E",168 ,0)
  20276    .I (X=54)  R *X S:X= 126 DNOUT= ""
  20277   "RTN","CHM FA01E",169 ,0)
  20278    .I (X=53)  R *X S:X= 126 DPOUT= ""
  20279   "RTN","CHM FA01E",170 ,0)
  20280    S:X=9 DDO UT="" S:X= 9 DTOUT=""  I Y="^^"  S (DFOUT,Y )=""
  20281   "RTN","CHM FA01E",171 ,0)
  20282    S:Y="^" ( DUOUT,Y)=" " S:Y?1"?" .E!(Y["^")  (DQOUT,Y) =""
  20283   "RTN","CHM FA01E",172 ,0)
  20284    U $I X ^% ZOSF("EON" ) Q
  20285   "RTN","CHM FA01E",173 ,0)
  20286   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
  20287   "RTN","CHM FA01E",174 ,0)
  20288    N OK,ANS
  20289   "RTN","CHM FA01E",175 ,0)
  20290    S OK=0
  20291   "RTN","CHM FA01E",176 ,0)
  20292    F  D ERRT XT Q:OK
  20293   "RTN","CHM FA01E",177 ,0)
  20294    Q ANS
  20295   "RTN","CHM FA01E",178 ,0)
  20296   ERRTXT   ; CPE001-015 ,CPE001-01 6 1/22/201 8 TGH - Pr int Popout  Question  and receiv e reply fo r Tax ID
  20297   "RTN","CHM FA01E",179 ,0)
  20298    D CLEAR S  DY=13,DX= 1,$Y=DY,$X =DX X XY
  20299   "RTN","CHM FA01E",180 ,0)
  20300    W "The Ta x ID enter ed does no t match th e TIN in t he EDI sub mission. "
  20301   "RTN","CHM FA01E",181 ,0)
  20302    W !,"             Do  you wish  to continu e? (Y/N) "
  20303   "RTN","CHM FA01E",182 ,0)
  20304    D CSBRS^C HSC2 S ANS =Y S:ANS=" " ANS=" "  D
  20305   "RTN","CHM FA01E",183 ,0)
  20306    . I $E($T R(ANS,"yes ","YES"),1 ,$L(ANS))= $E("YES",1 ,$L(ANS))  S ANS=1,OK =1 Q
  20307   "RTN","CHM FA01E",184 ,0)
  20308    . I $E($T R(ANS,"no" ,"NO"),1,$ L(ANS))=$E ("NO",1,$L (ANS)) S A NS=0,OK=1  Q
  20309   "RTN","CHM FA01E",185 ,0)
  20310    . I $D(DT OUT) S ANS ="",OK=1 Q
  20311   "RTN","CHM FA01E",186 ,0)
  20312    . W !,"          Ple ase enter  Y or N to  continue.  " H 3 Q
  20313   "RTN","CHM FA01E",187 ,0)
  20314    Q
  20315   "RTN","CHM FA117")
  20316   0^47^B1860 5118
  20317   "RTN","CHM FA117",1,0 )
  20318   CHMFA117 ; JLR/DEN;IN PATIENT UT ILITY PROG RAM;08/20/ 98  8:16 A M
  20319   "RTN","CHM FA117",2,0 )
  20320    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  20321   "RTN","CHM FA117",3,0 )
  20322    ;;V2.0
  20323   "RTN","CHM FA117",4,0 )
  20324    ;PT 11575
  20325   "RTN","CHM FA117",5,0 )
  20326    ;DEV01207 2 JEH 10/5 /11 - ADD  ICD CHECK
  20327   "RTN","CHM FA117",6,0 )
  20328    ;DEV00782 0 JEH 2/1/ 11 - SLLA
  20329   "RTN","CHM FA117",7,0 )
  20330    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if freque ncy code =  5
  20331   "RTN","CHM FA117",8,0 )
  20332   FIELD I QU >6 S FLD=5  Q
  20333   "RTN","CHM FA117",9,0 )
  20334    I '(QU#2)  S FLD=13  Q
  20335   "RTN","CHM FA117",10, 0)
  20336    S FLD=22  Q
  20337   "RTN","CHM FA117",11, 0)
  20338   SET F I=1: 1:11 S CHM FINP(DFN,B FN,"INP",I )=""
  20339   "RTN","CHM FA117",12, 0)
  20340    Q
  20341   "RTN","CHM FA117",13, 0)
  20342   GET1 S ZIC N="" Q:'$D (^CHMDIC(7 41002.12,D ISCD,0))
  20343   "RTN","CHM FA117",14, 0)
  20344    S X=^CHMD IC(741002. 12,DISCD,0 )
  20345   "RTN","CHM FA117",15, 0)
  20346    S ZICN=$P (X,"^",2)_ "^"_$P(X," ^",1)_"^"_ DISCD_"^"_ "B" Q
  20347   "RTN","CHM FA117",16, 0)
  20348   GET2 S ZIC N="" Q:'$D (^CHMDIC(7 41002.11,D ISFC,0))
  20349   "RTN","CHM FA117",17, 0)
  20350    S X=^CHMD IC(741002. 11,DISFC,0 )
  20351   "RTN","CHM FA117",18, 0)
  20352    S ZICN=$P (X,"^",2)_ "^"_$P(X," ^",1)_"^"_ DISFC_"^"_ "B" Q
  20353   "RTN","CHM FA117",19, 0)
  20354   GET3 S ZIC N="" Q:'$D (^CHMICDX( ICDCD,0))
  20355   "RTN","CHM FA117",20, 0)
  20356    S X=^CHMI CDX(ICDCD, 0)
  20357   "RTN","CHM FA117",21, 0)
  20358    S ZICN=$P (X,"^",2)_ "^"_$P(X," ^",1)_"^"_ ICDCD_"^"_ "B" Q
  20359   "RTN","CHM FA117",22, 0)
  20360   DISP S DY= 5,DX=12,$X =DX,$Y=DY  X XY W $P( CHMFINP(DF N,BFN,"INP ",1),"^",1 ) S DX=38, $X=DX,$Y=D Y X XY
  20361   "RTN","CHM FA117",23, 0)
  20362    W $P(CHMF INP(DFN,BF N,"INP",2) ,"^",1) S  DX=64,$X=D X,$Y=DY X  XY
  20363   "RTN","CHM FA117",24, 0)
  20364    W $P(CHMF INP(DFN,BF N,"INP",11 ),"^",1) S  DY=6,DX=1 2,$X=DX,$Y =DY X XY
  20365   "RTN","CHM FA117",25, 0)
  20366    W $P(CHMF INP(DFN,BF N,"INP",3) ,"^",2) S  DX=64,$X=D X,$Y=DY X  XY
  20367   "RTN","CHM FA117",26, 0)
  20368    W $E($P(C HMFINP(DFN ,BFN,"INP" ,4),"^",2) ,1,12) S D Y=7,DX=12, $X=DX,$Y=D Y X XY
  20369   "RTN","CHM FA117",27, 0)
  20370    W $P(CHMF INP(DFN,BF N,"INP",5) ,"^",1) S  DX=64,$X=D X,$Y=DY X  XY
  20371   "RTN","CHM FA117",28, 0)
  20372    W "$",$J( $FN($P(CHM FINP(DFN,B FN,"INP",6 ),"^",1)," ,",2),11)
  20373   "RTN","CHM FA117",29, 0)
  20374    S DY=9,DX =12,$X=DX, $Y=DY X XY  S ANS=$P( CHMFINP(DF N,BFN,"INP ",7),"^",1 )
  20375   "RTN","CHM FA117",30, 0)
  20376    I $P(CHMF INP(DFN,BF N,"INP",7) ,"^",2)="Y " D        ;DEV012072  JEH 10/5/ 11
  20377   "RTN","CHM FA117",31, 0)
  20378    .W "Yes"     ;DEV012 072 JEH 10 /5/11
  20379   "RTN","CHM FA117",32, 0)
  20380    .S QU=12  D QUES^CHM FA117 K QU            ;DEV012072  JEH 10/5/ 11
  20381   "RTN","CHM FA117",33, 0)
  20382    E  W:ANS= "Y" "Yes"     ;DEV012 072 JEH 10 /5/11
  20383   "RTN","CHM FA117",34, 0)
  20384    W:ANS="N"  "No" S DX =38,$X=DX  X XY    ;D EV012072 J EH 10/5/11
  20385   "RTN","CHM FA117",35, 0)
  20386    ;W:ANS="Y " "Yes" W: ANS="N" "N o" S DX=38 ,$X=DX X X Y    ;DEV0 12072 JEH  10/5/11
  20387   "RTN","CHM FA117",36, 0)
  20388    S ANS=$P( CHMFINP(DF N,BFN,"INP ",10),"^", 1)
  20389   "RTN","CHM FA117",37, 0)
  20390    W:ANS="Y"  "Yes" W:A NS="N" "No " S DX=64, $X=DX X XY
  20391   "RTN","CHM FA117",38, 0)
  20392    S ANS=$P( CHMFINP(DF N,BFN,"INP ",8),"^",1 )
  20393   "RTN","CHM FA117",39, 0)
  20394    W:ANS="Y"  "Yes" W:A NS="N" "No "
  20395   "RTN","CHM FA117",40, 0)
  20396    Q
  20397   "RTN","CHM FA117",41, 0)
  20398   QUES S HY= DY,HX=DX D  CLEAR S D TM=17,DBM= 20 X CHMAR  S DY=16,D X=1,$X=DX, $Y=DY X XY  G @QU
  20399   "RTN","CHM FA117",42, 0)
  20400   1 W !?15," Examples o f Valid Da tes:"
  20401   "RTN","CHM FA117",43, 0)
  20402    W !?15,"   -  Jan 20 , 1957, 20  Jan 57, 1 /20/57 or  012057"
  20403   "RTN","CHM FA117",44, 0)
  20404    W !?15,"   -  T (for  TODAY), T +1 (for TO MORROW), T -1 (for YE STERDAY)"
  20405   "RTN","CHM FA117",45, 0)
  20406    W !?15,"I f year is  omitted, t he Current  Year used ."
  20407   "RTN","CHM FA117",46, 0)
  20408    G EXIT
  20409   "RTN","CHM FA117",47, 0)
  20410   2 W !?15," Examples o f Valid Da tes:"
  20411   "RTN","CHM FA117",48, 0)
  20412    W !?15,"   -  Jan 20 , 1957, 20  Jan 57, 1 /20/57 or  012057"
  20413   "RTN","CHM FA117",49, 0)
  20414    W !?15,"   -  T (for  TODAY), T +1 (for TO MORROW), T -1 (for YE STERDAY)"
  20415   "RTN","CHM FA117",50, 0)
  20416    W !?15,"I f year is  omitted, t he Current  Year used ."
  20417   "RTN","CHM FA117",51, 0)
  20418    G EXIT
  20419   "RTN","CHM FA117",52, 0)
  20420   6 W !!?15, "Enter the  dollar am ount of to tal charge s without  commas."
  20421   "RTN","CHM FA117",53, 0)
  20422    G EXIT
  20423   "RTN","CHM FA117",54, 0)
  20424   7 W !!?25, "Enter <Y> es to ente r data or  <N>o for n o data ent ry." G EXI T
  20425   "RTN","CHM FA117",55, 0)
  20426   8 W !!?25, "Enter <Y> es to ente r data or  <N>o for n o data ent ry." G EXI T
  20427   "RTN","CHM FA117",56, 0)
  20428   9 W !!?25, "Enter <Y> es to ente r data or  <N>o for n o data ent ry." G EXI T
  20429   "RTN","CHM FA117",57, 0)
  20430   10 W !!?25 ,"Enter <Y >es to ent er data or  <N>o for  no data en try." G EX IT
  20431   "RTN","CHM FA117",58, 0)
  20432   11 W !?15, "Examples  of Valid D ates:"
  20433   "RTN","CHM FA117",59, 0)
  20434    W !?15,"   -  Jan 20 , 1957, 20  Jan 57, 1 /20/57 or  012057"
  20435   "RTN","CHM FA117",60, 0)
  20436    W !?15,"   -  T (for  TODAY), T +1 (for TO MORROW), T -1 (for YE STERDAY)"
  20437   "RTN","CHM FA117",61, 0)
  20438    W !?15,"I f year is  omitted, t he Current  Year used ."
  20439   "RTN","CHM FA117",62, 0)
  20440    G EXIT
  20441   "RTN","CHM FA117",63, 0)
  20442   12  S CHBL NKON="*27, *91,*53,*1 09"    ;SC REEN - BLI NKING ON                ;JEH 10/ 5/11 DEV01 2072
  20443   "RTN","CHM FA117",64, 0)
  20444    S CHBLNKO FF="*27,*9 1,*23,*109 "   ;SCREE N - BLINKI NG OFF         ;JEH 1 0/5/11 DEV 012072
  20445   "RTN","CHM FA117",65, 0)
  20446    W !!?10,@ CHBLNKON," *** DX/POA  SECTION H AS MISSING  DATA, PLE ASE CHECK.  ***",@CHB LNKOFF G E XIT   ;DEV 012072 JEH  10/5/11
  20447   "RTN","CHM FA117",66, 0)
  20448   EXIT S DY= HY,DX=HX,$ X=DX,$Y=DY  Q
  20449   "RTN","CHM FA117",67, 0)
  20450   AUTOFAC ;
  20451   "RTN","CHM FA117",68, 0)
  20452    S CHMFINP (DFN,BFN," INP",4)=""
  20453   "RTN","CHM FA117",69, 0)
  20454    Q:ZICN=""
  20455   "RTN","CHM FA117",70, 0)
  20456    Q:$P(ZICN ,"^",3)=""
  20457   "RTN","CHM FA117",71, 0)
  20458    Q:'$D(^CH MDIC(74100 2.12,$P(ZI CN,"^",3), 0))
  20459   "RTN","CHM FA117",72, 0)
  20460    Q:'$P(^CH MDIC(74100 2.12,$P(ZI CN,"^",3), 0),"^",4)= ""
  20461   "RTN","CHM FA117",73, 0)
  20462    S PTR=$P( ^CHMDIC(74 1002.12,$P (ZICN,"^", 3),0),"^", 4)
  20463   "RTN","CHM FA117",74, 0)
  20464    Q:'PTR
  20465   "RTN","CHM FA117",75, 0)
  20466    Q:'$D(^CH MDIC(74100 2.11,PTR,0 ))
  20467   "RTN","CHM FA117",76, 0)
  20468    S $P(CHMF INP(DFN,BF N,"INP",4) ,"^",1)=$P (^CHMDIC(7 41002.11,P TR,0),"^", 1)
  20469   "RTN","CHM FA117",77, 0)
  20470    S $P(CHMF INP(DFN,BF N,"INP",4) ,"^",2)=$P (^CHMDIC(7 41002.11,P TR,0),"^", 2)
  20471   "RTN","CHM FA117",78, 0)
  20472    S $P(CHMF INP(DFN,BF N,"INP",4) ,"^",3)=PT R
  20473   "RTN","CHM FA117",79, 0)
  20474    Q
  20475   "RTN","CHM FA117",80, 0)
  20476    ;
  20477   "RTN","CHM FA117",81, 0)
  20478   DTPRT S Y= "" Q:X'?7N   S Y=$E(X ,1,3)+1700 ,%M=+$E(X, 4,5),%D=+$ E(X,6,7)
  20479   "RTN","CHM FA117",82, 0)
  20480    I %M S:%D  Y=$E(" ", $L(%D))_%D _", "_Y S  Y=$P($P($T (JAN),";;" ,2)," ",%M )_" "_Y
  20481   "RTN","CHM FA117",83, 0)
  20482    Q
  20483   "RTN","CHM FA117",84, 0)
  20484   JAN ;;JAN  FEB MAR AP R MAY JUN  JUL AUG SE P OCT NOV  DEC
  20485   "RTN","CHM FA117",85, 0)
  20486   CLEAR S ZY =DY,ZX=DX  F DY=17:1: 20 S DX=1, $X=DX,$Y=D Y X XY W @ CHEOL
  20487   "RTN","CHM FA117",86, 0)
  20488    S DY=ZY,D X=ZX,$X=DX ,$Y=DY X X Y S CHCLRF G=1 Q
  20489   "RTN","CHM FA117",87, 0)
  20490   CLEAR1 S Z Y=DY,ZX=DX  F DY=11:1 :15 S DX=1 ,$X=DX,$Y= DY X XY W  @CHEOL
  20491   "RTN","CHM FA117",88, 0)
  20492    S DY=ZY,D X=ZX,$X=DX ,$Y=DY X X Y S CHCLRF G=1 Q
  20493   "RTN","CHM FA141")
  20494   0^48^B1271 109246
  20495   "RTN","CHM FA141",1,0 )
  20496   CHMFA141   ;DEN/CJM;O UTPATIENT  ENTER/EDIT ;Feb 06, 2 019@10:16: 59
  20497   "RTN","CHM FA141",2,0 )
  20498    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  20499   "RTN","CHM FA141",3,0 )
  20500    ;;V2.0;;C HAMPVA SYS TEM;;JULY  21, 1999
  20501   "RTN","CHM FA141",4,0 )
  20502    ;PT 15932  (Y2K)
  20503   "RTN","CHM FA141",5,0 )
  20504    ;PT #1606 6* (RLC)
  20505   "RTN","CHM FA141",6,0 )
  20506    ;PLEASE N OTE, FIX M ADE SEPARA TELY IN DE V & TRN FO R #16066 A ND MOVED T O
  20507   "RTN","CHM FA141",7,0 )
  20508    ;LIVE FRO M THE TRAI N ACCOUNT  DUE TO Y2K  CHANGES I N DEV.
  20509   "RTN","CHM FA141",8,0 )
  20510    ;JEH 12/1 2/06 - MOD IFIED FOR  ANESHESIA  CODE RATES
  20511   "RTN","CHM FA141",9,0 )
  20512    ;JEH 7/18 /07 - DEV0 01373-01:  Anesthesia  minute ca lc
  20513   "RTN","CHM FA141",10, 0)
  20514    ;JEH 12/1 6/07 - DEV 003971-01  Subscript  error fix  - missing  ANCDI valu e
  20515   "RTN","CHM FA141",11, 0)
  20516    ;JSG;01/3 1/08;DEV00 3956-02;Ha ndle no DO S in the R EDISP sect ion of cod e
  20517   "RTN","CHM FA141",12, 0)
  20518    ;JSG;02/2 8/08;BUG00 3956-04;Un defined RO W at ENT1+ 25
  20519   "RTN","CHM FA141",13, 0)
  20520    ;JSG;02/2 9/08;BUG00 3956-04;Ha ndle down  arrow with  deleted r ecord
  20521   "RTN","CHM FA141",14, 0)
  20522    ;TT 00010 8 JEH 1/4/ 10 - SPLIT  TOS INCID ENTAL DRUG S
  20523   "RTN","CHM FA141",15, 0)
  20524    ;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
  20525   "RTN","CHM FA141",16, 0)
  20526    ;JEH 2/1/ 11 DEV0078 20 - SLLA
  20527   "RTN","CHM FA141",17, 0)
  20528    ;DRW/JAK  09/30/11;  DEV010291  ASC POP MO DIFICATION
  20529   "RTN","CHM FA141",18, 0)
  20530    ;JEH 9/13 /13 - ENC0 04389 - PR EVENT 99XX X MULTIPLE  DOS DISCR EPANCIES
  20531   "RTN","CHM FA141",19, 0)
  20532    ;JEH 11/1 2/13 DEF01 9382 - ENT ER OHI TOT ALS BY DOS
  20533   "RTN","CHM FA141",20, 0)
  20534    ;DPT 2/24 /16 DEV241 94-02 - AD D 19 AS VA LID MODIFI Y ASC POP  UP
  20535   "RTN","CHM FA141",21, 0)
  20536    ;JEH 3/4/ 16 DEF0043 89 BUG FIX
  20537   "RTN","CHM FA141",22, 0)
  20538    ;CCSE CPE 005-012 GE F 6/7/17 -  remove pr ess return  to contin ue prompt
  20539   "RTN","CHM FA141",23, 0)
  20540    ;CPEE_ASC _Sprint 1  Task 70752 5 JEH 4/4/ 18
  20541   "RTN","CHM FA141",24, 0)
  20542    ;DEFECT 8 66501 - TG H - 8/19/2 018 - Defi ne HX and  HY for use  in displa y below
  20543   "RTN","CHM FA141",25, 0)
  20544    ;DEFECT 8 66501 - TG H - 8/19/2 018 - Also  repaired  two syntax  errors du ring compi le
  20545   "RTN","CHM FA141",26, 0)
  20546    ;DEFECT 8 66501 - TG H - 8/19/2 018 - Make  Popup ite m readable  by moving  part of l ine up to  first line
  20547   "RTN","CHM FA141",27, 0)
  20548   MAIN ;
  20549   "RTN","CHM FA141",28, 0)
  20550    I $G(RANS )="" D                     ;;BUG 010291 DRW /JAK - mod ified code  to allow  for multip le claim p rocessing
  20551   "RTN","CHM FA141",29, 0)
  20552    .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.
  20553   "RTN","CHM FA141",30, 0)
  20554    S RANS=""
  20555   "RTN","CHM FA141",31, 0)
  20556    D INIT                            ;,TOTAL   ;AEB 9/5/ 2007  ;        ;JEH 2 /1/11 DEV0 07820
  20557   "RTN","CHM FA141",32, 0)
  20558   M1 D ENTED T
  20559   "RTN","CHM FA141",33, 0)
  20560   END Q
  20561   "RTN","CHM FA141",34, 0)
  20562    ;
  20563   "RTN","CHM FA141",35, 0)
  20564   INIT ;
  20565   "RTN","CHM FA141",36, 0)
  20566    S DTM=7,D BM=14,DX=1 ,$X=DX,DY= 6 X CHMAR  X XY
  20567   "RTN","CHM FA141",37, 0)
  20568    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
  20569   "RTN","CHM FA141",38, 0)
  20570    S CHWINLR =1,CHWINHR =CHWIN,MSG FLG=0
  20571   "RTN","CHM FA141",39, 0)
  20572    S ZANSFLG =0      ;J EH 12/10/0 6 NEW FLAG  FOR ANEST H CODE CAL C
  20573   "RTN","CHM FA141",40, 0)
  20574    S CHBLNKO N="*27,*91 ,*53,*109"     ;SCREE N - BLINKI NG ON ;JEH  2/1/11 DE V007820
  20575   "RTN","CHM FA141",41, 0)
  20576    S CHBLNKO FF="*27,*9 1,*23,*109 "   ;SCREE N - BLINKI NG OFF         ;JEH 2 /1/11 DEV0 07820
  20577   "RTN","CHM FA141",42, 0)
  20578    N CHKFLG    ;JEH 9/1 3/13 - ENC 004389
  20579   "RTN","CHM FA141",43, 0)
  20580   SUBHEAD ;
  20581   "RTN","CHM FA141",44, 0)
  20582    S:'$D(TOC ORG) TOCOR G=""         ;JEH 2/1 /11 DEV007 820
  20583   "RTN","CHM FA141",45, 0)
  20584    S:'$D(TOC IPE) TOCIP E=""         ;JEH 2/1 /11 DEV007 820
  20585   "RTN","CHM FA141",46, 0)
  20586    U 0:0:"^% X364"
  20587   "RTN","CHM FA141",47, 0)
  20588    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
  20589   "RTN","CHM FA141",48, 0)
  20590    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
  20591   "RTN","CHM FA141",49, 0)
  20592    S DY=5,FL D=1 D FLDL NG S DX=CF DX,$X=DX X  XY W @CHU LON,"  DOS    "
  20593   "RTN","CHM FA141",50, 0)
  20594    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
  20595   "RTN","CHM FA141",51, 0)
  20596    E  S FLD= 2 D FLDLNG  S DX=CFDX ,$X=DX X X Y W "POS"                 ;JEH 2 /1/11 DEV0 07820
  20597   "RTN","CHM FA141",52, 0)
  20598    S FLD=3 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "  ICD    "                       ;JEH 2/1 /11 DEV007 820
  20599   "RTN","CHM FA141",53, 0)
  20600    S FLD=4 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "REV "                            ;JEH 2/1 /11 DEV007 820
  20601   "RTN","CHM FA141",54, 0)
  20602    S FLD=5 D
  20603   "RTN","CHM FA141",55, 0)
  20604    .I CHMFSR VC=4 D FLD LNG S DX=C FDX,$X=DX  X XY W "     SVCS      "  ;JEH 2 /1/11 DEV0 07820
  20605   "RTN","CHM FA141",56, 0)
  20606    .E  D FLD LNG S DX=C FDX,$X=DX  X XY W "   SVCS/NDC    "    ;JEH  2/1/11 DE V007820
  20607   "RTN","CHM FA141",57, 0)
  20608    S FLD=6 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "MODS "                           ;JEH 2/1 /11 DEV007 820
  20609   "RTN","CHM FA141",58, 0)
  20610    S FLD=7 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "UNT/QTY"                         ;JEH 2/1 /11 DEV007 820
  20611   "RTN","CHM FA141",59, 0)
  20612    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "  AMOUNT   "            ;JEH 2 /1/11 DEV0 07820
  20613   "RTN","CHM FA141",60, 0)
  20614    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
  20615   "RTN","CHM FA141",61, 0)
  20616    D TOTAL
  20617   "RTN","CHM FA141",62, 0)
  20618    S ROW=1,U ="^"
  20619   "RTN","CHM FA141",63, 0)
  20620    I $D(^UTI LITY($J,"C HDME",BEN) ) S CHLR=9 99999999,C HLR=$O(^UT ILITY($J," CHDME",BEN ,CHLR),-1)
  20621   "RTN","CHM FA141",64, 0)
  20622    I '$D(^UT ILITY($J," CHDME",BEN )) D NEWRO W
  20623   "RTN","CHM FA141",65, 0)
  20624    Q
  20625   "RTN","CHM FA141",66, 0)
  20626    ;
  20627   "RTN","CHM FA141",67, 0)
  20628   TOTAL ;
  20629   "RTN","CHM FA141",68, 0)
  20630    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)
  20631   "RTN","CHM FA141",69, 0)
  20632    F FLD=8,1 4,16 D
  20633   "RTN","CHM FA141",70, 0)
  20634    .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
  20635   "RTN","CHM FA141",71, 0)
  20636    F FLD=8,1 6 D FLDLNG  S DX=CFDX ,$X=DX X X Y D    ;JE H 2/1/11 D EV007820
  20637   "RTN","CHM FA141",72, 0)
  20638    .W @CHBON ,@CHEOL,$J ($FN(TOTSU M(FLD),"," ,2),FL),@C HBOFF
  20639   "RTN","CHM FA141",73, 0)
  20640    N MVENFLG     ;MEDIC AID VENDOR  PAYMENT F OR OUTPATI ENT FLAG
  20641   "RTN","CHM FA141",74, 0)
  20642    S MVENFLG =""   ;JEH  2/1/11 DE V007820
  20643   "RTN","CHM FA141",75, 0)
  20644    S:$D(^CHM IMAGE(CHMF PDI,1,1,2, 1,"VEN"))  MVENFLG=$P (^CHMIMAGE (CHMFPDI,1 ,1,2,1,"VE N"),"^",16 )
  20645   "RTN","CHM FA141",76, 0)
  20646    S:MVENFLG ="" MVENFL G=VFN
  20647   "RTN","CHM FA141",77, 0)
  20648    I MVENFLG ="" S CHMC FG=0 Q     ;JEH 2/1/1 1 DEV00782 0
  20649   "RTN","CHM FA141",78, 0)
  20650    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
  20651   "RTN","CHM FA141",79, 0)
  20652    I CHMCFG= 1 D
  20653   "RTN","CHM FA141",80, 0)
  20654    .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 ***
  20655   "RTN","CHM FA141",81, 0)
  20656    .S DY=15, DX=60,$X=D X X XY W @ CHBON,@CHE OL,$J($FN( TOTSUM(14) ,",",2),10 ),@CHBOFF
  20657   "RTN","CHM FA141",82, 0)
  20658    Q
  20659   "RTN","CHM FA141",83, 0)
  20660   ENTEDT ;S: '$D(DDTOTA L) DDTOTAL =0
  20661   "RTN","CHM FA141",84, 0)
  20662    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
  20663   "RTN","CHM FA141",85, 0)
  20664    I $P(^UTI LITY($J,"C HDME",BEN, 1,1),U)'=" " D REDISP  G ENT1
  20665   "RTN","CHM FA141",86, 0)
  20666    S DY=CHSD Y,MSGFLG=0  D FLDLNG  S DX=CFDX, $X=DX
  20667   "RTN","CHM FA141",87, 0)
  20668   ENT0 S $P( ^UTILITY($ J,"CHDME", BEN,ROW,FL D),U,1)=RO W
  20669   "RTN","CHM FA141",88, 0)
  20670    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)
  20671   "RTN","CHM FA141",89, 0)
  20672    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
  20673   "RTN","CHM FA141",90, 0)
  20674    E  X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)
  20675   "RTN","CHM FA141",91, 0)
  20676    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX
  20677   "RTN","CHM FA141",92, 0)
  20678   ENT1 ;
  20679   "RTN","CHM FA141",93, 0)
  20680    S CHDB=""
  20681   "RTN","CHM FA141",94, 0)
  20682    I $D(ROW)  I ROW'=""  S CHDB=^U TILITY($J, "CHDME",BE N,ROW,FLD)
  20683   "RTN","CHM FA141",95, 0)
  20684    I ROW=""  S ROW=1 D  REDISP ;JS E 3/16/11  MTN011703  <SUBSCR> e rr @ ENT1+ 10 if ROW= ""
  20685   "RTN","CHM FA141",96, 0)
  20686    S SFLD=0
  20687   "RTN","CHM FA141",97, 0)
  20688    I FLD=5 X  XY W $J($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),"* ",2),U,1), FL)
  20689   "RTN","CHM FA141",98, 0)
  20690    E  D
  20691   "RTN","CHM FA141",99, 0)
  20692    .I FLD=6  D  ;JEH 2/ 1/11 DEV00 7820
  20693   "RTN","CHM FA141",100 ,0)
  20694    ..I $L($P (^UTILITY( $J,"CHDME" ,BEN,ROW,F LD),"*",1) )>4 D
  20695   "RTN","CHM FA141",101 ,0)
  20696    ...S SPC= "  ",$P(SP C," ",11-$ L($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),"* ",1)))=""
  20697   "RTN","CHM FA141",102 ,0)
  20698    ...X XY W  $P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),"*" ,1),SPC
  20699   "RTN","CHM FA141",103 ,0)
  20700    ..E  X XY  W $J($E($ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),"*",1 ),1,4),5)
  20701   "RTN","CHM FA141",104 ,0)
  20702    .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)
  20703   "RTN","CHM FA141",105 ,0)
  20704    .E  X XY  W $J($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1),FL)
  20705   "RTN","CHM FA141",106 ,0)
  20706    I FLD=2&( CHMFSRVC=4 ) D
  20707   "RTN","CHM FA141",107 ,0)
  20708    .I $D(D4O UT) S FLD= FLD-1
  20709   "RTN","CHM FA141",108 ,0)
  20710    .E  S FLD =FLD+1
  20711   "RTN","CHM FA141",109 ,0)
  20712    .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
  20713   "RTN","CHM FA141",110 ,0)
  20714    I FLD=2&( CHMFSRVC=6 ) D  G ENT 1    ;SET  POS TO 'AM B' IF TRVL      ;JEH  2/1/11 DEV 007820
  20715   "RTN","CHM FA141",111 ,0)
  20716    .S ^UTILI TY($J,"CHD ME",BEN,RO W,FLD)="AM B^10^AMBUL ANCE"
  20717   "RTN","CHM FA141",112 ,0)
  20718    .X XY W $ J($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U, 1),FL)
  20719   "RTN","CHM FA141",113 ,0)
  20720    .I $D(D4O UT) S FLD= FLD-1
  20721   "RTN","CHM FA141",114 ,0)
  20722    .E  S FLD =FLD+1
  20723   "RTN","CHM FA141",115 ,0)
  20724    .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
  20725   "RTN","CHM FA141",116 ,0)
  20726    I ZANSFLG =1&(FLD=7)  D
  20727   "RTN","CHM FA141",117 ,0)
  20728    .D ANESCD      ;^CHM FA141         ;JEH 12 /08/06 NEW  FOR ANEST H
  20729   "RTN","CHM FA141",118 ,0)
  20730    E  D
  20731   "RTN","CHM FA141",119 ,0)
  20732    .X XY D C SBRS^CHSC2
  20733   "RTN","CHM FA141",120 ,0)
  20734    .S CHLF=8  I $D(^UTI LITY($J,"C HDME",BEN, ROW,3)) D
  20735   "RTN","CHM FA141",121 ,0)
  20736    ..S:$P(^U TILITY($J, "CHDME",BE N,ROW,3),U )'="" CHLF =3
  20737   "RTN","CHM FA141",122 ,0)
  20738    ..Q
  20739   "RTN","CHM FA141",123 ,0)
  20740    .I $D(DFO UT) W *7 G  ENT1
  20741   "RTN","CHM FA141",124 ,0)
  20742    .I $D(DUO UT) W *7 G  ENT1
  20743   "RTN","CHM FA141",125 ,0)
  20744    .I Y'=""  S CHDB=""
  20745   "RTN","CHM FA141",126 ,0)
  20746    .I Y=""&( ^UTILITY($ J,"CHDME", BEN,ROW,FL D)'="") D    ;JEH 2/1 /11 DEV007 820
  20747   "RTN","CHM FA141",127 ,0)
  20748    ..I FLD=6  S Y=$J($P (^UTILITY( $J,"CHDME" ,BEN,ROW,F LD),"*",1) ,5)   ;JEH  2/1/11 DE V007820
  20749   "RTN","CHM FA141",128 ,0)
  20750    ..E  S Y= $P(^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD),U,1)    ;JEH 2/ 1/11 DEV00 7820
  20751   "RTN","CHM FA141",129 ,0)
  20752    .S LNTAG= "GETF"_FLD _"^CHMFA14 2" D @LNTA G
  20753   "RTN","CHM FA141",130 ,0)
  20754    I FLD=6&( Y="@") S Y ="",SFLD=0  D CURSAV, CLRLN,CURR ES G ENT1    ;JEH 2/1 /11 DEV007 820
  20755   "RTN","CHM FA141",131 ,0)
  20756    I SFLD G  ENT1
  20757   "RTN","CHM FA141",132 ,0)
  20758    I $D(ROW) ,ROW'="" D     ;JSG;0 2/28/08;BU G003956 -  Insulate c ode block  from undef ined ROW
  20759   "RTN","CHM FA141",133 ,0)
  20760    .S ^UTILI TY($J,"CHD ME",BEN,RO W,FLD)=Y
  20761   "RTN","CHM FA141",134 ,0)
  20762    .I FLD=8  D
  20763   "RTN","CHM FA141",135 ,0)
  20764    ..I '$D(R PTFLG) D
  20765   "RTN","CHM FA141",136 ,0)
  20766    ...D CHKD STR   ;JEH  2/1/11 DE V007820 -  CHECK FOR  RE-DISTRIB UTION OF P /R
  20767   "RTN","CHM FA141",137 ,0)
  20768    ...D RDPL YPR   ;JEH  2/1/11 DE V007820 -  REDISPLAY  P/R BAL TO TALS
  20769   "RTN","CHM FA141",138 ,0)
  20770    .D CHSMT( 8)   ;CHEC K/DISPLAY  TOTALS
  20771   "RTN","CHM FA141",139 ,0)
  20772    .D CHSMT( 16)  ;CHEC K/DISPLAY  TOTALS
  20773   "RTN","CHM FA141",140 ,0)
  20774    .I ^UTILI TY($J,"CHD ME",BEN,RO W,FLD)'=CH DB D   ;JE H 2/1/11 D EV007820
  20775   "RTN","CHM FA141",141 ,0)
  20776    ..;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
  20777   "RTN","CHM FA141",142 ,0)
  20778    ..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
  20779   "RTN","CHM FA141",143 ,0)
  20780    ..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
  20781   "RTN","CHM FA141",144 ,0)
  20782    ..E  X XY  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),U,1),FL)
  20783   "RTN","CHM FA141",145 ,0)
  20784    ..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
  20785   "RTN","CHM FA141",146 ,0)
  20786    ..I FLD=5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U )'="" CURS AV,DES1,CU RRES,ICDFI L
  20787   "RTN","CHM FA141",147 ,0)
  20788    ..X XY
  20789   "RTN","CHM FA141",148 ,0)
  20790    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
  20791   "RTN","CHM FA141",149 ,0)
  20792    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
  20793   "RTN","CHM FA141",150 ,0)
  20794    I ROW=1&$ D(D1OUT) W  *7 G ENT1
  20795   "RTN","CHM FA141",151 ,0)
  20796    I ROW>1&$ D(D1OUT) D   D UP D F LDLNG,CLRM SG G ENT1     ;JEH 2/ 1/11 DEV00 7820
  20797   "RTN","CHM FA141",152 ,0)
  20798    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  20799   "RTN","CHM FA141",153 ,0)
  20800    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  20801   "RTN","CHM FA141",154 ,0)
  20802    I $D(D4OU T)&(FLD'>1 ) S FLD=CH LF D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  20803   "RTN","CHM FA141",155 ,0)
  20804    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
  20805   "RTN","CHM FA141",156 ,0)
  20806    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
  20807   "RTN","CHM FA141",157 ,0)
  20808    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  20809   "RTN","CHM FA141",158 ,0)
  20810    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  20811   "RTN","CHM FA141",159 ,0)
  20812    .I FLD=7, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW,5),U)," *")="RX")  S FLD=FLD- 1
  20813   "RTN","CHM FA141",160 ,0)
  20814    .S FLD=FL D-1
  20815   "RTN","CHM FA141",161 ,0)
  20816    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD-1
  20817   "RTN","CHM FA141",162 ,0)
  20818    I $D(D3OU T)&(FLD'<C HLF) S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  20819   "RTN","CHM FA141",163 ,0)
  20820    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
  20821   "RTN","CHM FA141",164 ,0)
  20822    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  20823   "RTN","CHM FA141",165 ,0)
  20824    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  20825   "RTN","CHM FA141",166 ,0)
  20826    .I FLD=5, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW,5),U)," *")="RX")  S FLD=FLD+ 1
  20827   "RTN","CHM FA141",167 ,0)
  20828    .S FLD=FL D+1
  20829   "RTN","CHM FA141",168 ,0)
  20830    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  20831   "RTN","CHM FA141",169 ,0)
  20832    I $D(DPOU T) D PREV  D FLDLNG,C LRMSG G EN T1
  20833   "RTN","CHM FA141",170 ,0)
  20834    I $D(DNOU T) D NEXT  D FLDLNG,C LRMSG G EN T1
  20835   "RTN","CHM FA141",171 ,0)
  20836    ; D2OUT O R CR
  20837   "RTN","CHM FA141",172 ,0)
  20838    I '$D(D2O UT)&(FLD<C HLF) D  D  FLDLNG,CLR MSG S DX=C FDX,$X=DX  G ENT1
  20839   "RTN","CHM FA141",173 ,0)
  20840    .I FLD=6  D CURSAV,C LRLN,CURRE S   ;JEH 2 /1/11 DEV0 07820
  20841   "RTN","CHM FA141",174 ,0)
  20842    .I FLD=5, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",BEN,R OW,5),U)," *")="RX")  S FLD=FLD+ 1
  20843   "RTN","CHM FA141",175 ,0)
  20844    .S FLD=FL D+1
  20845   "RTN","CHM FA141",176 ,0)
  20846    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  20847   "RTN","CHM FA141",177 ,0)
  20848    .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
  20849   "RTN","CHM FA141",178 ,0)
  20850    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
  20851   "RTN","CHM FA141",179 ,0)
  20852    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
  20853   "RTN","CHM FA141",180 ,0)
  20854    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
  20855   "RTN","CHM FA141",181 ,0)
  20856    Q
  20857   "RTN","CHM FA141",182 ,0)
  20858   ANESCD ;AN ESTHESIA C ODE   ;NEW  JEH 12/8/ 06
  20859   "RTN","CHM FA141",183 ,0)
  20860    I $P(^UTI LITY($J,"C HDME",BEN, ROW,3),U)' ="" S Y=""  X XY W $J (Y,FL)
  20861   "RTN","CHM FA141",184 ,0)
  20862    D CURSAV^ CHMFA141,E RAMSG^CHMF A141:MSGFL G,MARMES^C HMFA141 S  IOSL=3,DX= 1,$X=DX,DY =CHMDY X X Y
  20863   "RTN","CHM FA141",185 ,0)
  20864    ;
  20865   "RTN","CHM FA141",186 ,0)
  20866   AN2 ;LOOP
  20867   "RTN","CHM FA141",187 ,0)
  20868    S (TIMU,B ASU,TOTU)= 0
  20869   "RTN","CHM FA141",188 ,0)
  20870    D NOW^%DT C S DMYDT= X
  20871   "RTN","CHM FA141",189 ,0)
  20872    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
  20873   "RTN","CHM FA141",190 ,0)
  20874    S DIR(0)= "F",DIR("B ")="M" D ^ DIR K DIR  S ANS=Y
  20875   "RTN","CHM FA141",191 ,0)
  20876    I ANS="^"  S Y=0 G A NEND
  20877   "RTN","CHM FA141",192 ,0)
  20878    I ANS="@"  D
  20879   "RTN","CHM FA141",193 ,0)
  20880    .S ^UTILI TY($J,"CHD ME",BEN,RO W,FLD)=""
  20881   "RTN","CHM FA141",194 ,0)
  20882    .S Y=0
  20883   "RTN","CHM FA141",195 ,0)
  20884    .S SFLD=1  G ANEND
  20885   "RTN","CHM FA141",196 ,0)
  20886    I ANS=""  S Y=1 G AN END
  20887   "RTN","CHM FA141",197 ,0)
  20888    I ANS'="M "&(ANS'="U ")&(ANS'=" T") D ANHE LP G AN2      ;ESCD    ;JEH 7/18 /07 - DEV0 01373-01:  Anesthesia  minute ca lc
  20889   "RTN","CHM FA141",198 ,0)
  20890    I ANS="U"  D
  20891   "RTN","CHM FA141",199 ,0)
  20892    .S ANS2FL G=1
  20893   "RTN","CHM FA141",200 ,0)
  20894    .W !,?5," Enter the  number of  Units: " R  ANS2
  20895   "RTN","CHM FA141",201 ,0)
  20896    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D
  20897   "RTN","CHM FA141",202 ,0)
  20898    ..S TOTU= 0
  20899   "RTN","CHM FA141",203 ,0)
  20900    ..S ANS2F LG=0
  20901   "RTN","CHM FA141",204 ,0)
  20902    .E  S TIM U=+ANS2
  20903   "RTN","CHM FA141",205 ,0)
  20904    I ANS="M"  D
  20905   "RTN","CHM FA141",206 ,0)
  20906    .S ANS2FL G=1
  20907   "RTN","CHM FA141",207 ,0)
  20908    .W !,?5," Enter the  number of  Minutes: "  R ANS2
  20909   "RTN","CHM FA141",208 ,0)
  20910    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D
  20911   "RTN","CHM FA141",209 ,0)
  20912    ..S TOTU= 0
  20913   "RTN","CHM FA141",210 ,0)
  20914    ..S ANS2F LG=0
  20915   "RTN","CHM FA141",211 ,0)
  20916    .E  D ANC ALC
  20917   "RTN","CHM FA141",212 ,0)
  20918    I ANS="T"  D         ;JEH 7/18/ 07 - DEV00 1373-01: A nesthesia  minute cal c
  20919   "RTN","CHM FA141",213 ,0)
  20920    .S (STRTD T,ENDDT)=" "
  20921   "RTN","CHM FA141",214 ,0)
  20922    .S ANS2FL G=1
  20923   "RTN","CHM FA141",215 ,0)
  20924   SD1 .;STAR T DATE
  20925   "RTN","CHM FA141",216 ,0)
  20926    .W !,"Ent er the STA RT time: "  R ANS2
  20927   "RTN","CHM FA141",217 ,0)
  20928    .I (ANS2= "^") D  Q
  20929   "RTN","CHM FA141",218 ,0)
  20930    ..S TOTU= 0
  20931   "RTN","CHM FA141",219 ,0)
  20932    ..S ANS2F LG=0
  20933   "RTN","CHM FA141",220 ,0)
  20934    .G:ANS2=" "!(ANS2="  ") SD1
  20935   "RTN","CHM FA141",221 ,0)
  20936    .I ANS2=" ?" D HLP^C HTFLIB  G  SD1
  20937   "RTN","CHM FA141",222 ,0)
  20938    .I ANS2=" T" D HLP^C HTFLIB  G  SD1
  20939   "RTN","CHM FA141",223 ,0)
  20940    .I ANS2[" @" D
  20941   "RTN","CHM FA141",224 ,0)
  20942    ..S STRTD 1=$P(ANS2, "@",1)
  20943   "RTN","CHM FA141",225 ,0)
  20944    ..S X=STR TD1 D ^%DT  S:Y'=-1 S TRTD1=Y
  20945   "RTN","CHM FA141",226 ,0)
  20946    ..S STRTT 1=$P(ANS2, "@",2)
  20947   "RTN","CHM FA141",227 ,0)
  20948    ..S STRTT M=$$TIMECN V^CHTFLIB( STRTT1) S  Y=$$MIL^CH TFLIB(STRT TM)
  20949   "RTN","CHM FA141",228 ,0)
  20950    ..S:$L(Y) <4 Y="0"_Y
  20951   "RTN","CHM FA141",229 ,0)
  20952    ..S Y=STR TD1_"."_Y
  20953   "RTN","CHM FA141",230 ,0)
  20954    .E  D
  20955   "RTN","CHM FA141",231 ,0)
  20956    ..S STRTT M=$$TIMECN V^CHTFLIB( ANS2)
  20957   "RTN","CHM FA141",232 ,0)
  20958    ..I '$G(S TRTTM) S Y =-1 Q
  20959   "RTN","CHM FA141",233 ,0)
  20960    ..S Y=$$M IL^CHTFLIB (STRTTM)
  20961   "RTN","CHM FA141",234 ,0)
  20962    ..I Y=-1  Q
  20963   "RTN","CHM FA141",235 ,0)
  20964    ..S:$L(Y) <4 Y="0"_Y
  20965   "RTN","CHM FA141",236 ,0)
  20966    ..S Y=DMY DT_"."_Y      ;DUMMY  DATE
  20967   "RTN","CHM FA141",237 ,0)
  20968    .I Y=""!( Y="?") D H LP^CHTFLIB  G SD1
  20969   "RTN","CHM FA141",238 ,0)
  20970    .I Y=-1 D  HLP^CHTFL IB G SD1
  20971   "RTN","CHM FA141",239 ,0)
  20972    .S STRTDT =Y
  20973   "RTN","CHM FA141",240 ,0)
  20974   ED1 .;END  DATE
  20975   "RTN","CHM FA141",241 ,0)
  20976    .W !,"Ent er the END  time: " R  ANS2
  20977   "RTN","CHM FA141",242 ,0)
  20978    .I (ANS2= "^")!(ANS2 ="@") D  Q
  20979   "RTN","CHM FA141",243 ,0)
  20980    ..S TOTU= 0
  20981   "RTN","CHM FA141",244 ,0)
  20982    ..S ANS2F LG=0
  20983   "RTN","CHM FA141",245 ,0)
  20984    .G:ANS2=" "!(ANS2="  ") SD1
  20985   "RTN","CHM FA141",246 ,0)
  20986    .I ANS2=" ?" D HLP^C HTFLIB  G  ED1
  20987   "RTN","CHM FA141",247 ,0)
  20988    .I ANS2=" T" D HLP^C HTFLIB  G  ED1
  20989   "RTN","CHM FA141",248 ,0)
  20990    .I ANS2[" @" D
  20991   "RTN","CHM FA141",249 ,0)
  20992    ..S ENDD1 =$P(ANS2," @",1)
  20993   "RTN","CHM FA141",250 ,0)
  20994    ..S ENDT1 =$P(ANS2," @",2)
  20995   "RTN","CHM FA141",251 ,0)
  20996    ..S ENDTM =$$TIMECNV ^CHTFLIB(E NDT1) S Y= $$MIL^CHTF LIB(ENDTM)
  20997   "RTN","CHM FA141",252 ,0)
  20998    ..S:$L(Y) <4 Y="0"_Y
  20999   "RTN","CHM FA141",253 ,0)
  21000    ..S Y=END D1_"."_Y
  21001   "RTN","CHM FA141",254 ,0)
  21002    .E  D
  21003   "RTN","CHM FA141",255 ,0)
  21004    ..S ENDTM =$$TIMECNV ^CHTFLIB(A NS2)
  21005   "RTN","CHM FA141",256 ,0)
  21006    ..I '$G(E NDTM) S Y= -1 Q
  21007   "RTN","CHM FA141",257 ,0)
  21008    ..S Y=$$M IL^CHTFLIB (ENDTM)
  21009   "RTN","CHM FA141",258 ,0)
  21010    ..I Y=-1  Q
  21011   "RTN","CHM FA141",259 ,0)
  21012    ..S:$L(Y) <4 Y="0"_Y
  21013   "RTN","CHM FA141",260 ,0)
  21014    ..S Y=DMY DT_"."_Y      ;DUMMY  DATE
  21015   "RTN","CHM FA141",261 ,0)
  21016    .I Y=""!( Y="?") D H LP^CHTFLIB  G ED1
  21017   "RTN","CHM FA141",262 ,0)
  21018    .I Y=-1 D  HLP^CHTFL IB G ED1
  21019   "RTN","CHM FA141",263 ,0)
  21020    .S ENDDT= Y
  21021   "RTN","CHM FA141",264 ,0)
  21022    .I ENDDT< STRTDT D H LP2^CHTFLI B G ED1
  21023   "RTN","CHM FA141",265 ,0)
  21024    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D
  21025   "RTN","CHM FA141",266 ,0)
  21026    ..S TOTU= 0
  21027   "RTN","CHM FA141",267 ,0)
  21028    ..S ANS2F LG=0
  21029   "RTN","CHM FA141",268 ,0)
  21030    .E  D
  21031   "RTN","CHM FA141",269 ,0)
  21032    ..S ANS2= $$CALCMIN^ CHTFLIB(ST RTDT,ENDDT )
  21033   "RTN","CHM FA141",270 ,0)
  21034    ..D ANCAL C
  21035   "RTN","CHM FA141",271 ,0)
  21036    S ANCDE=$ P(^UTILITY ($J,"CHDME ",BEN,ROW, 5),"^",1)   ;GET CODE  FROM SVCS  COLUMN
  21037   "RTN","CHM FA141",272 ,0)
  21038    S ANCDI=$ P(^UTILITY ($J,"CHDME ",BEN,ROW, 5),"^",2)   ;GET CODE  I-VAL
  21039   "RTN","CHM FA141",273 ,0)
  21040    I ANS2FLG =1 D
  21041   "RTN","CHM FA141",274 ,0)
  21042    .I $D(ANC DI)&(ANCDI '="")&(ANC DI'=" ") D          ; JEH 1/2/08  BUG003971 -03-01 - L OGIC FIX F OR SUBSCRI PT ERROR
  21043   "RTN","CHM FA141",275 ,0)
  21044    ..S CHCDE FD=$P(^UTI LITY($J,"C HDME",BEN, ROW,1),"^" ,2)   ;GET  CORRECT R VU FOR DOS
  21045   "RTN","CHM FA141",276 ,0)
  21046    ..S CHCDE FD=$O(^CHM SERV(ANCDI ,4,"B",CHC DEFD),-1)
  21047   "RTN","CHM FA141",277 ,0)
  21048    ..I $G(CH CDEFD) D
  21049   "RTN","CHM FA141",278 ,0)
  21050    ...S CHCJ PTR=0 S CH CJPTR=$O(^ CHMSERV(AN CDI,4,"B", CHCDEFD,CH CJPTR))
  21051   "RTN","CHM FA141",279 ,0)
  21052    ...S BASU =$P(^CHMSE RV(ANCDI,4 ,CHCJPTR,0 ),"^",2)
  21053   "RTN","CHM FA141",280 ,0)
  21054    ...S TOTU =TIMU+BASU
  21055   "RTN","CHM FA141",281 ,0)
  21056    ..E  D
  21057   "RTN","CHM FA141",282 ,0)
  21058    ...W !!!, ?5,"Anesth esia Unit  not availa ble, setti ng default  value.",! ,?5,"Hit < enter> to  continue.. . " R XXX: 5
  21059   "RTN","CHM FA141",283 ,0)
  21060    ...S TOTU =1
  21061   "RTN","CHM FA141",284 ,0)
  21062    .E  S TOT U=0
  21063   "RTN","CHM FA141",285 ,0)
  21064    S Y=+TOTU
  21065   "RTN","CHM FA141",286 ,0)
  21066    K ANS,ANS 2,TIMU,UNI T,ANCDE,BA SU
  21067   "RTN","CHM FA141",287 ,0)
  21068    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  21069   "RTN","CHM FA141",288 ,0)
  21070    S ZANSFLG =0
  21071   "RTN","CHM FA141",289 ,0)
  21072    Q
  21073   "RTN","CHM FA141",290 ,0)
  21074   ANEND ;
  21075   "RTN","CHM FA141",291 ,0)
  21076    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  21077   "RTN","CHM FA141",292 ,0)
  21078    Q
  21079   "RTN","CHM FA141",293 ,0)
  21080   ANHELP ;
  21081   "RTN","CHM FA141",294 ,0)
  21082    W !?5,"Yo u must Ent er 'M' or  'U'."
  21083   "RTN","CHM FA141",295 ,0)
  21084    Q
  21085   "RTN","CHM FA141",296 ,0)
  21086   ANCALC ;CA LCULATE TH E NUMBER O F UNITS FR OM MINUTES  ENTERED
  21087   "RTN","CHM FA141",297 ,0)
  21088    S TIMU=0
  21089   "RTN","CHM FA141",298 ,0)
  21090    S UNIT=AN S2#15
  21091   "RTN","CHM FA141",299 ,0)
  21092    S TIMU=(A NS2-UNIT)/ 15
  21093   "RTN","CHM FA141",300 ,0)
  21094    S:UNIT'=0  TIMU=TIMU +1
  21095   "RTN","CHM FA141",301 ,0)
  21096    Q
  21097   "RTN","CHM FA141",302 ,0)
  21098   SUMDME(SUM FLD) ;SUMS  ARRAY DME  - AMOUNT
  21099   "RTN","CHM FA141",303 ,0)
  21100    N SUM,R
  21101   "RTN","CHM FA141",304 ,0)
  21102    S SUM=0
  21103   "RTN","CHM FA141",305 ,0)
  21104    I $D(ROW)  Q:ROW=""  SUM
  21105   "RTN","CHM FA141",306 ,0)
  21106    ;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
  21107   "RTN","CHM FA141",307 ,0)
  21108    S R=0
  21109   "RTN","CHM FA141",308 ,0)
  21110    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) G :'R SUMEND  D
  21111   "RTN","CHM FA141",309 ,0)
  21112    .Q:'$D(^U TILITY($J, "CHDME",BE N,R,SUMFLD ))
  21113   "RTN","CHM FA141",310 ,0)
  21114    .S SUM=SU M+^UTILITY ($J,"CHDME ",BEN,R,SU MFLD)
  21115   "RTN","CHM FA141",311 ,0)
  21116   SUMEND Q S UM
  21117   "RTN","CHM FA141",312 ,0)
  21118    ;
  21119   "RTN","CHM FA141",313 ,0)
  21120   SUMDM8() ; SUMS ARRAY  DME - AMO UNT
  21121   "RTN","CHM FA141",314 ,0)
  21122    N SUM,R
  21123   "RTN","CHM FA141",315 ,0)
  21124    S SUM=0
  21125   "RTN","CHM FA141",316 ,0)
  21126    I $D(ROW)  Q:ROW=""  SUM
  21127   "RTN","CHM FA141",317 ,0)
  21128    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,16))  Q SUM
  21129   "RTN","CHM FA141",318 ,0)
  21130    S R=0
  21131   "RTN","CHM FA141",319 ,0)
  21132    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) G :'R SUMEND 8 D
  21133   "RTN","CHM FA141",320 ,0)
  21134    .Q:'$D(^U TILITY($J, "CHDME",BE N,R,16))
  21135   "RTN","CHM FA141",321 ,0)
  21136    .S SUM=SU M+^UTILITY ($J,"CHDME ",BEN,R,16 )
  21137   "RTN","CHM FA141",322 ,0)
  21138   SUMEND8 Q  SUM
  21139   "RTN","CHM FA141",323 ,0)
  21140    ;
  21141   "RTN","CHM FA141",324 ,0)
  21142   SUMDM16()  ;SUMS ARRA Y DME - AM OUNT
  21143   "RTN","CHM FA141",325 ,0)
  21144    N SUM,R
  21145   "RTN","CHM FA141",326 ,0)
  21146    S SUM=0
  21147   "RTN","CHM FA141",327 ,0)
  21148    I $D(ROW)  Q:ROW=""  SUM
  21149   "RTN","CHM FA141",328 ,0)
  21150    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,16))  Q SUM
  21151   "RTN","CHM FA141",329 ,0)
  21152    S R=0
  21153   "RTN","CHM FA141",330 ,0)
  21154    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) G :'R SUMEND 16 D
  21155   "RTN","CHM FA141",331 ,0)
  21156    .Q:'$D(^U TILITY($J, "CHDME",BE N,R,16))
  21157   "RTN","CHM FA141",332 ,0)
  21158    .S SUM=SU M+^UTILITY ($J,"CHDME ",BEN,R,16 )
  21159   "RTN","CHM FA141",333 ,0)
  21160   SUMEND16 Q  SUM
  21161   "RTN","CHM FA141",334 ,0)
  21162    ;
  21163   "RTN","CHM FA141",335 ,0)
  21164   DESCRP ;
  21165   "RTN","CHM FA141",336 ,0)
  21166    S DX=45,$ X=DX
  21167   "RTN","CHM FA141",337 ,0)
  21168    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
  21169   "RTN","CHM FA141",338 ,0)
  21170    K BF S BF ="",$P(BF, " ",FL+1)= ""
  21171   "RTN","CHM FA141",339 ,0)
  21172    X XY W $E ($P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U,3 ),1,15)
  21173   "RTN","CHM FA141",340 ,0)
  21174    ;
  21175   "RTN","CHM FA141",341 ,0)
  21176   DES1 D ERA MSG
  21177   "RTN","CHM FA141",342 ,0)
  21178    S HOLDDY= DY
  21179   "RTN","CHM FA141",343 ,0)
  21180    S $P(STR, " ",44)=""     ;JEH 2 /1/11 DEV0 07820 CHGD  59 TO 44
  21181   "RTN","CHM FA141",344 ,0)
  21182    S DX=1,$X =DX,DY=15  X XY W STR  X XY
  21183   "RTN","CHM FA141",345 ,0)
  21184    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
  21185   "RTN","CHM FA141",346 ,0)
  21186    S MSGFLG= 1
  21187   "RTN","CHM FA141",347 ,0)
  21188    Q
  21189   "RTN","CHM FA141",348 ,0)
  21190    ;
  21191   "RTN","CHM FA141",349 ,0)
  21192   ICDFIL ;
  21193   "RTN","CHM FA141",350 ,0)
  21194    I FLD=3 S  CHLF=3 D
  21195   "RTN","CHM FA141",351 ,0)
  21196    .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
  21197   "RTN","CHM FA141",352 ,0)
  21198    .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
  21199   "RTN","CHM FA141",353 ,0)
  21200    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX
  21201   "RTN","CHM FA141",354 ,0)
  21202    I FLD=5 S  CHLF=8 D
  21203   "RTN","CHM FA141",355 ,0)
  21204    .S ^UTILI TY($J,"CHD ME",BEN,RO W,3)=""
  21205   "RTN","CHM FA141",356 ,0)
  21206    .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)
  21207   "RTN","CHM FA141",357 ,0)
  21208    .S FLD=5  D FLDLNG S  DX=CFDX,$ X=DX
  21209   "RTN","CHM FA141",358 ,0)
  21210    I FLD=6 S  CHLF=8 D
  21211   "RTN","CHM FA141",359 ,0)
  21212    .S ^UTILI TY($J,"CHD ME",BEN,RO W,3)=""
  21213   "RTN","CHM FA141",360 ,0)
  21214    .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)
  21215   "RTN","CHM FA141",361 ,0)
  21216    .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)
  21217   "RTN","CHM FA141",362 ,0)
  21218    .S FLD=6  D FLDLNG S  DX=CFDX,$ X=DX
  21219   "RTN","CHM FA141",363 ,0)
  21220    Q
  21221   "RTN","CHM FA141",364 ,0)
  21222    ;
  21223   "RTN","CHM FA141",365 ,0)
  21224   EDITOK ;MO DIFIED BY  DTP TO SKI P REV CODE  EDITS ON  PAPER, BUT  NOT EDI I N LAST LIN E OF SUBRT N
  21225   "RTN","CHM FA141",366 ,0)
  21226    Q:'$D(CHM FPDI)
  21227   "RTN","CHM FA141",367 ,0)
  21228    S X=$$TYP E^CHMFPDI2 (CHMFPDI)
  21229   "RTN","CHM FA141",368 ,0)
  21230    S PT=0,PT =$O(^CHMDI C(741002.9 3,"C",X,PT ))
  21231   "RTN","CHM FA141",369 ,0)
  21232    Q:'PT  Q: '$D(^CHMDI C(741002.9 3,PT,0))
  21233   "RTN","CHM FA141",370 ,0)
  21234    S PTR=$P( ^(0),"^",3 )
  21235   "RTN","CHM FA141",371 ,0)
  21236    Q:'PTR  Q :'$D(^CHMD IC(741002. 94,PTR,2))
  21237   "RTN","CHM FA141",372 ,0)
  21238    S:$P(^(2) ,"^",PC) N OEDIT=1
  21239   "RTN","CHM FA141",373 ,0)
  21240    I (PC=2)& ($E(X,1,1) =9) K NOED IT
  21241   "RTN","CHM FA141",374 ,0)
  21242    Q
  21243   "RTN","CHM FA141",375 ,0)
  21244   BEEPQ X XY  W BF X XY  W *7,"??"  X XY W BF
  21245   "RTN","CHM FA141",376 ,0)
  21246    Q
  21247   "RTN","CHM FA141",377 ,0)
  21248    ;
  21249   "RTN","CHM FA141",378 ,0)
  21250   FLDLNG ;
  21251   "RTN","CHM FA141",379 ,0)
  21252    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
  21253   "RTN","CHM FA141",380 ,0)
  21254    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
  21255   "RTN","CHM FA141",381 ,0)
  21256    K BF S BF ="",$P(BF, " ",FL+1)= ""
  21257   "RTN","CHM FA141",382 ,0)
  21258    Q
  21259   "RTN","CHM FA141",383 ,0)
  21260    ;
  21261   "RTN","CHM FA141",384 ,0)
  21262   REPEAT X X Y W BF
  21263   "RTN","CHM FA141",385 ,0)
  21264    I $E(Y)=" R" D RPTML T Q   ;JEH  2/1/11 DE V007820
  21265   "RTN","CHM FA141",386 ,0)
  21266    I $E(Y)=" U" D UBNDL  Q   ;JEH  2/1/11 DEV 007820
  21267   "RTN","CHM FA141",387 ,0)
  21268    I $E(Y)=" /" D DIVID E
  21269   "RTN","CHM FA141",388 ,0)
  21270    S STOP=$E (Y,2,$L(Y) )+(ROW-2), START=ROW, DY=DY-1 F  ROW1=START :1:STOP D
  21271   "RTN","CHM FA141",389 ,0)
  21272    .;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)
  21273   "RTN","CHM FA141",390 ,0)
  21274    .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
  21275   "RTN","CHM FA141",391 ,0)
  21276    .S DY=DY+ 1 I DY=(CH SDY+CHWIN)  D
  21277   "RTN","CHM FA141",392 ,0)
  21278    ..S DY=CH SDY+CHWIN- 1,CHWINLR= CHWINLR+1, CHWINHR=CH WINHR+1
  21279   "RTN","CHM FA141",393 ,0)
  21280    ..S DX=1, $X=DX X XY  W !
  21281   "RTN","CHM FA141",394 ,0)
  21282    .F FLD=0: 1:8,16,17  D FLDLNG S  DX=CFDX,$ X=DX X XY  D
  21283   "RTN","CHM FA141",395 ,0)
  21284    ..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
  21285   "RTN","CHM FA141",396 ,0)
  21286    ..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
  21287   "RTN","CHM FA141",397 ,0)
  21288    ..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
  21289   "RTN","CHM FA141",398 ,0)
  21290    ..W $J($P (^UTILITY( $J,"CHDME" ,BEN,ROW1, FLD),U,1), FL)
  21291   "RTN","CHM FA141",399 ,0)
  21292    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  21293   "RTN","CHM FA141",400 ,0)
  21294    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1
  21295   "RTN","CHM FA141",401 ,0)
  21296    S SFLD=1
  21297   "RTN","CHM FA141",402 ,0)
  21298    D CHSMT(8 )   ;CHECK /DISPLAY T OTALS
  21299   "RTN","CHM FA141",403 ,0)
  21300    D CHSMT(1 6)  ;CHECK /DISPLAY T OTALS
  21301   "RTN","CHM FA141",404 ,0)
  21302   REPEND Q
  21303   "RTN","CHM FA141",405 ,0)
  21304    ;
  21305   "RTN","CHM FA141",406 ,0)
  21306   DIVIDE S Y 1=^UTILITY ($J,"CHDME ",BEN,ROW- 1,8)/$E(Y, 2,$L(Y))
  21307   "RTN","CHM FA141",407 ,0)
  21308    S Y1=$J(Y 1,$L($P(Y1 ,".",1))+3 ,2)
  21309   "RTN","CHM FA141",408 ,0)
  21310    I ^UTILIT Y($J,"CHDM E",BEN,ROW -1,3)'=""  S Y1=""
  21311   "RTN","CHM FA141",409 ,0)
  21312    S ^UTILIT Y($J,"CHDM E",BEN,ROW -1,8)=Y1
  21313   "RTN","CHM FA141",410 ,0)
  21314    D CURSAV
  21315   "RTN","CHM FA141",411 ,0)
  21316    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX,DY=DY- 1
  21317   "RTN","CHM FA141",412 ,0)
  21318    X XY W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W-1,FLD),U ,1),FL)
  21319   "RTN","CHM FA141",413 ,0)
  21320    D CURRES
  21321   "RTN","CHM FA141",414 ,0)
  21322    X XY
  21323   "RTN","CHM FA141",415 ,0)
  21324    Q
  21325   "RTN","CHM FA141",416 ,0)
  21326   RPTMLT ;RE PEAT GROUP  OF LINES    ;JEH 2/1 /11 DEV007 820
  21327   "RTN","CHM FA141",417 ,0)
  21328    N RPRW,RP NM,RWSV,RW DX,RWSV,RC OL,START,R OW1,CTR,AF LD
  21329   "RTN","CHM FA141",418 ,0)
  21330    Q:$E(Y,1, 1)'="R"
  21331   "RTN","CHM FA141",419 ,0)
  21332    ;I $E(CHM FPDI,8,9)' ="03" S RP FLG="" Q    ;ONLY ALL OW CHAMPVA  STANDARD  {03} TO RE PEAT LINES
  21333   "RTN","CHM FA141",420 ,0)
  21334    K:$D(^UTI LITY($J,"R CHDME")) ^ UTILITY($J ,"RCHDME")
  21335   "RTN","CHM FA141",421 ,0)
  21336    S RPNM=$E (Y,2,$L(Y) )
  21337   "RTN","CHM FA141",422 ,0)
  21338    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,1)) S  RPFLG=1,Y ="" Q
  21339   "RTN","CHM FA141",423 ,0)
  21340    S START=0
  21341   "RTN","CHM FA141",424 ,0)
  21342    S LSTRW=9 9999 S LST RW=$O(^UTI LITY($J,"C HDME",BEN, LSTRW),-1)
  21343   "RTN","CHM FA141",425 ,0)
  21344    S ROW1=0  F  S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) Q:'ROW 1  D
  21345   "RTN","CHM FA141",426 ,0)
  21346    .S RWDX=$ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,3),"^",1)
  21347   "RTN","CHM FA141",427 ,0)
  21348    .S RWSV=$ P($P(^UTIL ITY($J,"CH DME",BEN,R OW1,5),"^" ,1),"*",2)
  21349   "RTN","CHM FA141",428 ,0)
  21350    .Q:RWDX=" "&(RWSV="" )
  21351   "RTN","CHM FA141",429 ,0)
  21352    .F RCOL=0 :1:18 D
  21353   "RTN","CHM FA141",430 ,0)
  21354    ..I RCOL= 0 S ^UTILI TY($J,"RCH DME",BEN,L STRW+ROW1, RCOL)=^UTI LITY($J,"C HDME",BEN, ROW1,RCOL) +LSTRW
  21355   "RTN","CHM FA141",431 ,0)
  21356    ..E  S ^U TILITY($J, "RCHDME",B EN,LSTRW+R OW1,RCOL)= ^UTILITY($ J,"CHDME", BEN,ROW1,R COL)
  21357   "RTN","CHM FA141",432 ,0)
  21358    .S START= ROW1+1         ;START  ROW
  21359   "RTN","CHM FA141",433 ,0)
  21360    I START=0  S SFLD=1  Q
  21361   "RTN","CHM FA141",434 ,0)
  21362    S ROW1=ST ART
  21363   "RTN","CHM FA141",435 ,0)
  21364    F CTR=1:1 :RPNM D
  21365   "RTN","CHM FA141",436 ,0)
  21366    .S RRW=0  F  S RRW=$ O(^UTILITY ($J,"RCHDM E",BEN,RRW )) Q:'RRW   D
  21367   "RTN","CHM FA141",437 ,0)
  21368    ..F FLD=0 :1:18 D
  21369   "RTN","CHM FA141",438 ,0)
  21370    ... ;DEFE CT 866501  - TGH - 8/ 19/2018 -  Also repai red two sy ntax error s during c ompile
  21371   "RTN","CHM FA141",439 ,0)
  21372    ... ;I FL D=0 $P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"U",1)=RO W1
  21373   "RTN","CHM FA141",440 ,0)
  21374    ...I FLD= 0 S $P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,"U",1)=RO W1
  21375   "RTN","CHM FA141",441 ,0)
  21376    ...E  S ^ UTILITY($J ,"CHDME",B EN,ROW1,FL D)=^UTILIT Y($J,"RCHD ME",BEN,RR W,FLD)
  21377   "RTN","CHM FA141",442 ,0)
  21378    ..S ROW1= ROW1+1
  21379   "RTN","CHM FA141",443 ,0)
  21380    I '$D(^UT ILITY($J," CHDME",BEN ,ROW1,0))  D
  21381   "RTN","CHM FA141",444 ,0)
  21382    .F FLD=0: 1:18 D
  21383   "RTN","CHM FA141",445 ,0)
  21384    ..I FLD=0  S $P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), "^",1)=ROW 1 Q  ;BDB  CPE005-009
  21385   "RTN","CHM FA141",446 ,0)
  21386    ..I FLD<3  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=^UT ILITY($J," CHDME",BEN ,ROW1-1,FL D) Q
  21387   "RTN","CHM FA141",447 ,0)
  21388    ..I FLD=7  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=1 Q
  21389   "RTN","CHM FA141",448 ,0)
  21390    ..I FLD>2  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=""  Q
  21391   "RTN","CHM FA141",449 ,0)
  21392    D INIT,RE DISP
  21393   "RTN","CHM FA141",450 ,0)
  21394    S RPTFLG= ""
  21395   "RTN","CHM FA141",451 ,0)
  21396    Q
  21397   "RTN","CHM FA141",452 ,0)
  21398   UBNDL ;UN- BUNDLE LIN ES   ;JEH  2/1/11 DEV 007820
  21399   "RTN","CHM FA141",453 ,0)
  21400    N UBROW,R PNM,RWDT,R WDX,RWSV,R COL,START, ROW1,CTR,A FLD,LSTRW
  21401   "RTN","CHM FA141",454 ,0)
  21402    Q:$E(Y,1, 1)'="U"
  21403   "RTN","CHM FA141",455 ,0)
  21404    I Y'?1.1A 1.N1" "1.N  S Y=Y_" 1 "
  21405   "RTN","CHM FA141",456 ,0)
  21406    K:$D(^UTI LITY($J,"R CHDME")) ^ UTILITY($J ,"RCHDME")
  21407   "RTN","CHM FA141",457 ,0)
  21408    S UBROW=$ E($P(Y," " ,1),2,$L(Y ))
  21409   "RTN","CHM FA141",458 ,0)
  21410    S RPNM=$P (Y," ",2)
  21411   "RTN","CHM FA141",459 ,0)
  21412    I '$D(^UT ILITY($J," CHDME",BEN ,UBROW,1))  S RPFLG=1 ,Y="" Q
  21413   "RTN","CHM FA141",460 ,0)
  21414    S LSTRW=9 9999 S LST RW=$O(^UTI LITY($J,"C HDME",BEN, LSTRW),-1)
  21415   "RTN","CHM FA141",461 ,0)
  21416    S RWDX=$P (^UTILITY( $J,"CHDME" ,BEN,UBROW ,3),"^",1)
  21417   "RTN","CHM FA141",462 ,0)
  21418    S RWSV=$P ($P(^UTILI TY($J,"CHD ME",BEN,UB ROW,5),"^" ,1),"*",2)
  21419   "RTN","CHM FA141",463 ,0)
  21420    Q:RWDX="" &(RWSV="")
  21421   "RTN","CHM FA141",464 ,0)
  21422    F RCOL=0: 1:18 D
  21423   "RTN","CHM FA141",465 ,0)
  21424    .I RCOL=0  S ^UTILIT Y($J,"RCHD ME",BEN,LS TRW+UBROW, RCOL)=^UTI LITY($J,"C HDME",BEN, UBROW,RCOL )+LSTRW
  21425   "RTN","CHM FA141",466 ,0)
  21426    .E  S ^UT ILITY($J," RCHDME",BE N,LSTRW+UB ROW,RCOL)= ^UTILITY($ J,"CHDME", BEN,UBROW, RCOL)
  21427   "RTN","CHM FA141",467 ,0)
  21428    S ROW1=LS TRW
  21429   "RTN","CHM FA141",468 ,0)
  21430    F CTR=1:1 :RPNM D
  21431   "RTN","CHM FA141",469 ,0)
  21432    .S RRW=0  F  S RRW=$ O(^UTILITY ($J,"RCHDM E",BEN,RRW )) Q:'RRW   D
  21433   "RTN","CHM FA141",470 ,0)
  21434    ..F FLD=0 :1:18 D
  21435   "RTN","CHM FA141",471 ,0)
  21436    ...;DEFEC T 866501 -  TGH - 8/1 9/2018 - A lso repair ed two syn tax errors  during co mpile
  21437   "RTN","CHM FA141",472 ,0)
  21438    ...;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
  21439   "RTN","CHM FA141",473 ,0)
  21440    ...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
  21441   "RTN","CHM FA141",474 ,0)
  21442    ...E  S ^ UTILITY($J ,"CHDME",B EN,ROW1,FL D)=^UTILIT Y($J,"RCHD ME",BEN,RR W,FLD)
  21443   "RTN","CHM FA141",475 ,0)
  21444    ..S ROW1= ROW1+1
  21445   "RTN","CHM FA141",476 ,0)
  21446    I '$D(^UT ILITY($J," CHDME",BEN ,ROW1,0))  D
  21447   "RTN","CHM FA141",477 ,0)
  21448    .F FLD=0: 1:18 D
  21449   "RTN","CHM FA141",478 ,0)
  21450    ..I FLD=0  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=ROW 1 Q
  21451   "RTN","CHM FA141",479 ,0)
  21452    ..I FLD<3  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=^UT ILITY($J," CHDME",BEN ,ROW1-1,FL D) Q
  21453   "RTN","CHM FA141",480 ,0)
  21454    ..I FLD=7  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=1 Q
  21455   "RTN","CHM FA141",481 ,0)
  21456    ..I FLD>2  S ^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD)=""  Q
  21457   "RTN","CHM FA141",482 ,0)
  21458    D INIT,RE DISP
  21459   "RTN","CHM FA141",483 ,0)
  21460    S RPTFLG= ""
  21461   "RTN","CHM FA141",484 ,0)
  21462    Q
  21463   "RTN","CHM FA141",485 ,0)
  21464   REDISP ;RE -DISPLAY S CREEN
  21465   "RTN","CHM FA141",486 ,0)
  21466    S DY=CHSD Y-1 F ROW1 =1:1:CHLR  D
  21467   "RTN","CHM FA141",487 ,0)
  21468    .S DY=DY+ 1 I DY=(CH SDY+CHWIN)  D
  21469   "RTN","CHM FA141",488 ,0)
  21470    .. S DY=C HSDY+CHWIN -1,CHWINLR =CHWINLR+1 ,CHWINHR=C HWINHR+1
  21471   "RTN","CHM FA141",489 ,0)
  21472    .. S DX=1 ,$X=DX X X Y W !
  21473   "RTN","CHM FA141",490 ,0)
  21474    .; CPE005 -009 Frequ ency code  5.  Add bo lding to o riginal it ems
  21475   "RTN","CHM FA141",491 ,0)
  21476    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,0)," ^",2)=1 W  @CHBON  ;C PE005-009  BDB
  21477   "RTN","CHM FA141",492 ,0)
  21478    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,0)," ^",2)'=1 W  @CHBOFF   ;CPE005-00 9 BDB
  21479   "RTN","CHM FA141",493 ,0)
  21480    .F FLD=0: 1:8,16 D F LDLNG S DX =CFDX,$X=D X X XY D
  21481   "RTN","CHM FA141",494 ,0)
  21482    ..;I FLD= 2 D CHKPOS  Q   ;JEH  8/1/13 DEV 007820 - P OST SLA FI X
  21483   "RTN","CHM FA141",495 ,0)
  21484    ..Q:'$D(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D))  ;JEH  11/12/13 D EF019382 -  ADD $D CH ECK
  21485   "RTN","CHM FA141",496 ,0)
  21486    ..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
  21487   "RTN","CHM FA141",497 ,0)
  21488    ..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
  21489   "RTN","CHM FA141",498 ,0)
  21490    ..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
  21491   "RTN","CHM FA141",499 ,0)
  21492    ..I FLD=6  D  Q   ;J EH 2/1/11  DEV007820
  21493   "RTN","CHM FA141",500 ,0)
  21494    ...I $L($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),"*", 1))>4 D
  21495   "RTN","CHM FA141",501 ,0)
  21496    ....W $J( "*"_$E($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),"*",1) ,1,4),5)
  21497   "RTN","CHM FA141",502 ,0)
  21498    ...E  W $ J($E($P(^U TILITY($J, "CHDME",BE N,ROW1,FLD ),"*",1),1 ,4),5)
  21499   "RTN","CHM FA141",503 ,0)
  21500    ..I FLD=7 &($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)[".") D  CHKUNT Q     ;JEH 2/ 1/11 DEV00 7820
  21501   "RTN","CHM FA141",504 ,0)
  21502    ..W @CHEO L,$J($P(^U TILITY($J, "CHDME",BE N,ROW1,FLD ),U,1),FL)
  21503   "RTN","CHM FA141",505 ,0)
  21504    .;JSG;01/ 31/08;DEV0 03956-02;I f DOS="",  stop displ ay and ask  user to d eal with i t
  21505   "RTN","CHM FA141",506 ,0)
  21506    .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
  21507   "RTN","CHM FA141",507 ,0)
  21508    W @CHBOFF
  21509   "RTN","CHM FA141",508 ,0)
  21510    D CHSMT(8 )   ;CHECK /DISPLAY T OTALS
  21511   "RTN","CHM FA141",509 ,0)
  21512    D CHSMT(1 6)   ;CHEC K/DISPLAY  TOTALS
  21513   "RTN","CHM FA141",510 ,0)
  21514    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  21515   "RTN","CHM FA141",511 ,0)
  21516    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1
  21517   "RTN","CHM FA141",512 ,0)
  21518    S SFLD=1
  21519   "RTN","CHM FA141",513 ,0)
  21520    Q
  21521   "RTN","CHM FA141",514 ,0)
  21522    ;
  21523   "RTN","CHM FA141",515 ,0)
  21524   RDPLYPR ;R EDISPLAY P /R TOTALS
  21525   "RTN","CHM FA141",516 ,0)
  21526    Q:$D(RPFL G)
  21527   "RTN","CHM FA141",517 ,0)
  21528    N RDY,RCH SDY,RROW1, RCHLR,RCHW IN,RCHWINL R,RCHWINHR ,RDX,RFLD
  21529   "RTN","CHM FA141",518 ,0)
  21530    S RDY=DY, RCHSDY=CHS DY,RCHLR=C HLR,RCHWIN =CHWIN,RCH WINLR=CHWI NLR,RCHWIN HR=CHWINHR ,RDX=DX,RF LD=FLD
  21531   "RTN","CHM FA141",519 ,0)
  21532    N ROWCTR
  21533   "RTN","CHM FA141",520 ,0)
  21534    S ROWCTR= CHWINHR
  21535   "RTN","CHM FA141",521 ,0)
  21536    S FLD=16  D FLDLNG S  DX=CFDX,$ X=DX X XY
  21537   "RTN","CHM FA141",522 ,0)
  21538    I ROWCTR> CHLR S ROW CTR=CHLR
  21539   "RTN","CHM FA141",523 ,0)
  21540    S DY=CHSD Y-1 F ROW1 =CHWINLR:1 :ROWCTR D
  21541   "RTN","CHM FA141",524 ,0)
  21542    .S DY=DY+ 1
  21543   "RTN","CHM FA141",525 ,0)
  21544    .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)
  21545   "RTN","CHM FA141",526 ,0)
  21546    S DY=RDY, CHSDY=RCHS DY,CHLR=RC HLR,CHWIN= RCHWIN,CHW INLR=RCHWI NLR,CHWINH R=RCHWINHR ,DX=RDX,FL D=RFLD
  21547   "RTN","CHM FA141",527 ,0)
  21548    D FLDLNG  S DX=RDX,$ X=DX,DY=RD Y,$Y=DY X  XY
  21549   "RTN","CHM FA141",528 ,0)
  21550    Q
  21551   "RTN","CHM FA141",529 ,0)
  21552   CHKPOS ;CH ECK/DISPLA Y WHEN POS  IS MISSIN G     ;JEH  8/1/13 DE V007820 -  POST FIX
  21553   "RTN","CHM FA141",530 ,0)
  21554    I CHMFSRV C=4 Q   ;D ME DOESN'T  HAVE POS
  21555   "RTN","CHM FA141",531 ,0)
  21556    I ^UTILIT Y($J,"CHDM E",BEN,ROW 1,1)="DELE TED" Q
  21557   "RTN","CHM FA141",532 ,0)
  21558    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
  21559   "RTN","CHM FA141",533 ,0)
  21560    I $P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,2)="" D
  21561   "RTN","CHM FA141",534 ,0)
  21562    .W @CHBLN KON,$J(" ?  ",FL),@CH BLNKOFF
  21563   "RTN","CHM FA141",535 ,0)
  21564    .D CURSAV ^CHMFA141, ERAMSG^CHM FA141:MSGF LG,MARMES^ CHMFA141 S  IOSL=3,DX =1,$X=DX,D Y=CHMDY X  XY
  21565   "RTN","CHM FA141",536 ,0)
  21566    .W !?2,@C HBLNKON,"* ** ISSUE * **",@CHBLN KOFF," - P LEASE CHEC K 'POS' CO LUMN."
  21567   "RTN","CHM FA141",537 ,0)
  21568    .D MARSCR ^CHMFA141, CURRES^CHM FA141 S IO SL=9,MSGFL G=1
  21569   "RTN","CHM FA141",538 ,0)
  21570    E  D
  21571   "RTN","CHM FA141",539 ,0)
  21572    .W @CHEOL ,$J($P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U,1),FL)
  21573   "RTN","CHM FA141",540 ,0)
  21574    Q
  21575   "RTN","CHM FA141",541 ,0)
  21576   CHKUNT ;CH ECK/DISPLA Y WHEN UNI TS ARE NOT  WHOLE NUM BER     ;J EH 2/1/11  DEV007820
  21577   "RTN","CHM FA141",542 ,0)
  21578    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
  21579   "RTN","CHM FA141",543 ,0)
  21580    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)
  21581   "RTN","CHM FA141",544 ,0)
  21582    E  W @CHB LNKON,$J($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,FL),@CHBL NKOFF
  21583   "RTN","CHM FA141",545 ,0)
  21584    D CURSAV^ CHMFA141,E RAMSG^CHMF A141:MSGFL G,MARMES^C HMFA141 S  IOSL=3,DX= 1,$X=DX,DY =CHMDY X X Y
  21585   "RTN","CHM FA141",546 ,0)
  21586    W !?2,@CH BLNKON,"** * ISSUE ** *",@CHBLNK OFF," - PL EASE CHECK  'UNT/QTY'  COLUMN."
  21587   "RTN","CHM FA141",547 ,0)
  21588    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  21589   "RTN","CHM FA141",548 ,0)
  21590    Q
  21591   "RTN","CHM FA141",549 ,0)
  21592   NODOS ;JSG ;01/31/08; DEV003956- 02;Ask use r to deal  with recor ds with no  DOS
  21593   "RTN","CHM FA141",550 ,0)
  21594    D F1HELP^ CHMFA142                                        ;Displ ay "Enter  DOS" messa ge
  21595   "RTN","CHM FA141",551 ,0)
  21596    ;
  21597   "RTN","CHM FA141",552 ,0)
  21598   NOJOY S FL D=1,ROW=RO W1 D FLDLN G                              ; Set field,  row & fie ld length
  21599   "RTN","CHM FA141",553 ,0)
  21600         S DX =CFDX,$X=D X X XY D C SBRS^CHSC2                     ; Position o n field an d READ Y
  21601   "RTN","CHM FA141",554 ,0)
  21602         I $D (DFOUT) W  *7 G NOJOY
  21603   "RTN","CHM FA141",555 ,0)
  21604         I $D (DUOUT) W  *7 G NOJOY
  21605   "RTN","CHM FA141",556 ,0)
  21606         D GE TF1^CHMFA1 42                                        ; Process us er entry
  21607   "RTN","CHM FA141",557 ,0)
  21608         I Y= ""!(Y=-1)  X XY W $P( ^UTILITY($ J,"CHDME", BEN,ROW1,1 ),U) G NOJ OY ;Entry  no good
  21609   "RTN","CHM FA141",558 ,0)
  21610         I $E (Y)="@" S  ^UTILITY($ J,"CHDME", BEN,ROW1,8 )=""     ; "@"=delete  record, s o zero $$s
  21611   "RTN","CHM FA141",559 ,0)
  21612         E  S  ^UTILITY( $J,"CHDME" ,BEN,ROW1, 1)=Y                ; Reset DOS  node, if n ot deleted
  21613   "RTN","CHM FA141",560 ,0)
  21614         X XY  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,1) ,U),FL)  ; WRITE upda ted field  on screen
  21615   "RTN","CHM FA141",561 ,0)
  21616         D CU RSAV,ERAMS G,CURRES                                  ; Clear "Ent er DOS" me ssage
  21617   "RTN","CHM FA141",562 ,0)
  21618         Q                                                         ; Go finish  procedure  display
  21619   "RTN","CHM FA141",563 ,0)
  21620    ;
  21621   "RTN","CHM FA141",564 ,0)
  21622   EXIT D CUR SAV,ERAMSG
  21623   "RTN","CHM FA141",565 ,0)
  21624   E1 D PRMPT ^CHMFA140, ASK^CHMFA1 40
  21625   "RTN","CHM FA141",566 ,0)
  21626    I $D(DFOU T)!$D(DUOU T) G E1
  21627   "RTN","CHM FA141",567 ,0)
  21628    K CHMFNEX T,CHMFPREV ,CHMFKILL, CHMFNEWB,C HMFOPRX
  21629   "RTN","CHM FA141",568 ,0)
  21630    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
  21631   "RTN","CHM FA141",569 ,0)
  21632    I Y=2&('$ D(DDOUT))  D
  21633   "RTN","CHM FA141",570 ,0)
  21634    .D CURSV4
  21635   "RTN","CHM FA141",571 ,0)
  21636    .I $$PSCH K^CHMFAUT3 ()=1 S Y=1  Q  ;JEH 8 /1/13  ;AD DED MISSIN G POS CHEC K
  21637   "RTN","CHM FA141",572 ,0)
  21638    .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
  21639   "RTN","CHM FA141",573 ,0)
  21640    .D CURRE4  D FLDLNG
  21641   "RTN","CHM FA141",574 ,0)
  21642    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
  21643   "RTN","CHM FA141",575 ,0)
  21644    I Y=3 D R STOR^CHMFA UT3("S",2)            ;JEH 2/1/1 1 DEV00782 0 - CALL R ESTORE FUN CTION (SAV E)
  21645   "RTN","CHM FA141",576 ,0)
  21646    I Y=5 D   Q
  21647   "RTN","CHM FA141",577 ,0)
  21648    .S UMIO=" O" D ^CHMF A14O,ERAMS G,MARSCR
  21649   "RTN","CHM FA141",578 ,0)
  21650    .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
  21651   "RTN","CHM FA141",579 ,0)
  21652    .D INIT^C HMFA140,SE TSCR^CHMFA 140,INIT,R EDISP
  21653   "RTN","CHM FA141",580 ,0)
  21654    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
  21655   "RTN","CHM FA141",581 ,0)
  21656    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
  21657   "RTN","CHM FA141",582 ,0)
  21658    I Y=9 D ^ CHMFA02B,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV     ;OPT-O HI EDIT
  21659   "RTN","CHM FA141",583 ,0)
  21660    I Y=10 D
  21661   "RTN","CHM FA141",584 ,0)
  21662    .I '$D(^U TILITY("RE STORE",$J) ) D
  21663   "RTN","CHM FA141",585 ,0)
  21664    ..D CURSV 2
  21665   "RTN","CHM FA141",586 ,0)
  21666    ..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
  21667   "RTN","CHM FA141",587 ,0)
  21668    ..D INIT^ CHMFA140,S ETSCR^CHMF A140,INIT, REDISP
  21669   "RTN","CHM FA141",588 ,0)
  21670    ..D CURRE 2 D FLDLNG
  21671   "RTN","CHM FA141",589 ,0)
  21672    .E  D
  21673   "RTN","CHM FA141",590 ,0)
  21674    ..D RSTOR ^CHMFAUT3( "R",CHMFSR VC),ERAMSG ,MARSCR
  21675   "RTN","CHM FA141",591 ,0)
  21676    ..S RSTFL =1
  21677   "RTN","CHM FA141",592 ,0)
  21678    ..K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  21679   "RTN","CHM FA141",593 ,0)
  21680    ..D INIT^ CHMFA140,S ETSCR^CHMF A140,INIT, REDISP
  21681   "RTN","CHM FA141",594 ,0)
  21682    ..D CURSA V,CURRES,F LDLNG
  21683   "RTN","CHM FA141",595 ,0)
  21684    ..I $$POS CHK^CHMFAU T3()=1 D I NIT^CHMFA1 40,SETSCR^ CHMFA140,I NIT,REDISP    ;CHECK  FOR MISSIN G POS
  21685   "RTN","CHM FA141",596 ,0)
  21686    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
  21687   "RTN","CHM FA141",597 ,0)
  21688    .;REMOVE  THE NFOR L OOP, NO LO NGER NEEDE D IF NOT A SKING THE  QUESTION
  21689   "RTN","CHM FA141",598 ,0)
  21690    .;F  D  Q :Y'=""  Q: "YNyn"'[Y   ;; DRW/JA K
  21691   "RTN","CHM FA141",599 ,0)
  21692    .;.S HY=D Y,HX=DX,DY =19,DX=20, $X=DX X XY   ;; DRW/J AK
  21693   "RTN","CHM FA141",600 ,0)
  21694    .;.W "Are  you sure  you want t o continue : " D CSBR S^CHSC2  ; ;DRW/JAK
  21695   "RTN","CHM FA141",601 ,0)
  21696    .;.Q  ;;D RW/JAK .I  $D(DUOUT)  K CHMFNEXT  Q
  21697   "RTN","CHM FA141",602 ,0)
  21698    .;I $D(DF OUT) K CHM FNEXT Q
  21699   "RTN","CHM FA141",603 ,0)
  21700    .;I "Nn"[ Y K CHMFNE XT S DY=HY ,DX=HX,$X= DX Q
  21701   "RTN","CHM FA141",604 ,0)
  21702    .;RESUME  HERE after  removing  continue p rompt
  21703   "RTN","CHM FA141",605 ,0)
  21704    .;DEFECT  866501 - T GH - 8/19/ 2018 - Def ine HX and  HY for us e in displ ay below
  21705   "RTN","CHM FA141",606 ,0)
  21706    .S HY=DY, HX=DX,DY=1 9,DX=20,$X =DX X XY
  21707   "RTN","CHM FA141",607 ,0)
  21708    .;
  21709   "RTN","CHM FA141",608 ,0)
  21710    .Q:'$D(^C HMIMAGE(CH MFPDI,1,1, 2,1,"VEN") )
  21711   "RTN","CHM FA141",609 ,0)
  21712    .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
  21713   "RTN","CHM FA141",610 ,0)
  21714    .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
  21715   "RTN","CHM FA141",611 ,0)
  21716    .S ROW=0, CHPOS=0 F   S ROW=$O( ^UTILITY($ J,"CHDME", BEN,ROW))  Q:'ROW!(CH POS=50)  D
  21717   "RTN","CHM FA141",612 ,0)
  21718    ..I ROW=" " S DY=HY, DX=HX,$X=D X Q
  21719   "RTN","CHM FA141",613 ,0)
  21720    ..S CHPOS =$P(^UTILI TY($J,"CHD ME",BEN,RO W,2),U,2)
  21721   "RTN","CHM FA141",614 ,0)
  21722    .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
  21723   "RTN","CHM FA141",615 ,0)
  21724    ..F  D  Q :(RANS="AS C"!(RANS=" OP")!(RANS ="NA"))  ; ;DRW/JAK
  21725   "RTN","CHM FA141",616 ,0)
  21726    ...S TX=2 5,TY=9,BX= 75,BY=20,V ON="",VOFF ="" D BOXF ^CHSC1(TX, TY,BX,BY)
  21727   "RTN","CHM FA141",617 ,0)
  21728    ...D CLRB OXI^CHSC1( TX,TY,BX,B Y,XY,VON,V OFF)
  21729   "RTN","CHM FA141",618 ,0)
  21730    ...S DY=1 0,DX=26 X  XY W "PLEA SE CHECK P OS SELECTI ON:"
  21731   "RTN","CHM FA141",619 ,0)
  21732    ...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
  21733   "RTN","CHM FA141",620 ,0)
  21734    ...S DY=1 2,DX=26 X  XY W " "
  21735   "RTN","CHM FA141",621 ,0)
  21736    ...;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
  21737   "RTN","CHM FA141",622 ,0)
  21738    ...;S DY= 13,DX=26 X  XY W " Ch oose POS ( ASC=24, "
  21739   "RTN","CHM FA141",623 ,0)
  21740    ...;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
  21741   "RTN","CHM FA141",624 ,0)
  21742    ...S DY=1 3,DX=26 X  XY W " Cho ose POS (A SC=24,  OP =22(ON CAM PUS),"
  21743   "RTN","CHM FA141",625 ,0)
  21744    ...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
  21745   "RTN","CHM FA141",626 ,0)
  21746    ...S Y=$$ UP^XLFSTR( Y)         ;;TT 10291  JAK/DRW 0 8/03/10 sa ve return  value in Y  to (upper case)
  21747   "RTN","CHM FA141",627 ,0)
  21748    ...I Y="0 0"!(Y="NA" ) S RANS=" NA"             ;;TT  10291 JAK/ DRW 08/03/ 10
  21749   "RTN","CHM FA141",628 ,0)
  21750    ...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
  21751   "RTN","CHM FA141",629 ,0)
  21752    ...I RANS ="ASC"!(RA NS="OP") D  RESET  ;; DRW/JAK
  21753   "RTN","CHM FA141",630 ,0)
  21754    ...S ASCS W=1
  21755   "RTN","CHM FA141",631 ,0)
  21756    ...Q  ;;D RW/JAK
  21757   "RTN","CHM FA141",632 ,0)
  21758    ..S $P(ST R," ",59)= ""                  ; DRW/JAK BU G010291-05 -02 clear  out the po s descript ion after  popup goes  away
  21759   "RTN","CHM FA141",633 ,0)
  21760    ..S DX=20 ,$X=DX F D Y=9:1:20 X  XY W @CHE OL  ;;DRW/ JAK
  21761   "RTN","CHM FA141",634 ,0)
  21762    ..S DX=1, $X=DX,DY=1 5 X XY W S TR X XY  ; JAK
  21763   "RTN","CHM FA141",635 ,0)
  21764    ..S CHMFN EXT=""
  21765   "RTN","CHM FA141",636 ,0)
  21766    ..S DX=1, DY=16 X XY  W "------ ---------- ---------- ---------- ---------- ---------- ---------- ---------- ----"  ;;D RW/JAK
  21767   "RTN","CHM FA141",637 ,0)
  21768    ..Q  ;; D RW/JAK
  21769   "RTN","CHM FA141",638 ,0)
  21770    .K:$D(^UT ILITY("RES TORE",$J))  ^UTILITY( "RESTORE", $J)
  21771   "RTN","CHM FA141",639 ,0)
  21772    .Q   ;; D RW/JAK
  21773   "RTN","CHM FA141",640 ,0)
  21774    D CURRES  D FLDLNG
  21775   "RTN","CHM FA141",641 ,0)
  21776    K CHKFLG    ;JEH 9/1 3/13 - ENC 004389
  21777   "RTN","CHM FA141",642 ,0)
  21778    Q
  21779   "RTN","CHM FA141",643 ,0)
  21780   DOWN D CUR SAV
  21781   "RTN","CHM FA141",644 ,0)
  21782    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
  21783   "RTN","CHM FA141",645 ,0)
  21784    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
  21785   "RTN","CHM FA141",646 ,0)
  21786    I FLD>5 D    ;JEH 2/ 1/11 DEV00 7820
  21787   "RTN","CHM FA141",647 ,0)
  21788    .D CURSAV ,CLRLN,CUR RES   ;JEH  2/1/11 DE V007820
  21789   "RTN","CHM FA141",648 ,0)
  21790    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
  21791   "RTN","CHM FA141",649 ,0)
  21792    S CHCF=FL D,DY=DY+1, ROW=ROW+1
  21793   "RTN","CHM FA141",650 ,0)
  21794    I '$D(^UT ILITY($J," CHDME",BEN ,ROW)) D N EWROW
  21795   "RTN","CHM FA141",651 ,0)
  21796    I DY=(CHS DY+CHWIN)  D UPSCRL
  21797   "RTN","CHM FA141",652 ,0)
  21798    D STAFLG    ;JEH 1/2 3/07
  21799   "RTN","CHM FA141",653 ,0)
  21800   DOWNEND Q
  21801   "RTN","CHM FA141",654 ,0)
  21802   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
  21803   "RTN","CHM FA141",655 ,0)
  21804    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)
  21805   "RTN","CHM FA141",656 ,0)
  21806    S CHLR=RO W
  21807   "RTN","CHM FA141",657 ,0)
  21808    Q
  21809   "RTN","CHM FA141",658 ,0)
  21810   UP D CURSA V
  21811   "RTN","CHM FA141",659 ,0)
  21812    I FLD>5 D    ;JEH 2/ 1/11 DEV00 7820
  21813   "RTN","CHM FA141",660 ,0)
  21814    .D CURSAV ,CLRLN,CUR RES   ;JEH  2/1/11 DE V007820
  21815   "RTN","CHM FA141",661 ,0)
  21816    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
  21817   "RTN","CHM FA141",662 ,0)
  21818    S CHCF=FL D,DY=DY-1, ROW=ROW-1
  21819   "RTN","CHM FA141",663 ,0)
  21820    I DY<CHSD Y D DNSCRL
  21821   "RTN","CHM FA141",664 ,0)
  21822    D STAFLG    ;JEH 1/2 3/07
  21823   "RTN","CHM FA141",665 ,0)
  21824    Q
  21825   "RTN","CHM FA141",666 ,0)
  21826   DNSCRL S D Y=CHSDY,CH WINLR=CHWI NLR-1,CHWI NHR=CHWINH R-1
  21827   "RTN","CHM FA141",667 ,0)
  21828    S ROW1=CH WINLR-1
  21829   "RTN","CHM FA141",668 ,0)
  21830   DN1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1)) G:'RO W1 DN2  G: ROW1>CHWIN HR DN2
  21831   "RTN","CHM FA141",669 ,0)
  21832    S DX=1,$X =DX,DY=CHS DY X XY W  @CHINSL
  21833   "RTN","CHM FA141",670 ,0)
  21834    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  21835   "RTN","CHM FA141",671 ,0)
  21836    .I FLD=0  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,0),"^" ,2)=1 W @C HBON ;CPE0 05-009 BDB  08202017
  21837   "RTN","CHM FA141",672 ,0)
  21838    .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
  21839   "RTN","CHM FA141",673 ,0)
  21840    .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
  21841   "RTN","CHM FA141",674 ,0)
  21842    .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
  21843   "RTN","CHM FA141",675 ,0)
  21844    .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
  21845   "RTN","CHM FA141",676 ,0)
  21846    .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
  21847   "RTN","CHM FA141",677 ,0)
  21848    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)[".") D  CHKUNT Q     ;JEH 2/1 /11 DEV007 820
  21849   "RTN","CHM FA141",678 ,0)
  21850    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  21851   "RTN","CHM FA141",679 ,0)
  21852    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1),F L)
  21853   "RTN","CHM FA141",680 ,0)
  21854   DN2 D CURR ES S FLD=C HCF
  21855   "RTN","CHM FA141",681 ,0)
  21856    Q
  21857   "RTN","CHM FA141",682 ,0)
  21858   UPSCRL S D Y=CHSDY+CH WIN-1,CHWI NLR=CHWINL R+1,CHWINH R=CHWINHR+ 1
  21859   "RTN","CHM FA141",683 ,0)
  21860    S ROW1=CH WINHR+1
  21861   "RTN","CHM FA141",684 ,0)
  21862   UP1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1),-1) G: 'ROW1 UP2   G:ROW1<CH WINLR UP2
  21863   "RTN","CHM FA141",685 ,0)
  21864    S DX=1,$X =DX X XY W  !
  21865   "RTN","CHM FA141",686 ,0)
  21866    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  21867   "RTN","CHM FA141",687 ,0)
  21868    .I FLD=0  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,0),"^" ,2)=1 W @C HBON ;CPE0 05-009 BDB  08202017
  21869   "RTN","CHM FA141",688 ,0)
  21870    .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
  21871   "RTN","CHM FA141",689 ,0)
  21872    .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
  21873   "RTN","CHM FA141",690 ,0)
  21874    .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
  21875   "RTN","CHM FA141",691 ,0)
  21876    .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
  21877   "RTN","CHM FA141",692 ,0)
  21878    .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
  21879   "RTN","CHM FA141",693 ,0)
  21880    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)[".") D  CHKUNT Q     ;JEH 2/1 /11 DEV007 820
  21881   "RTN","CHM FA141",694 ,0)
  21882    .I FLD=2  D CHKPOS Q   ;JEH 8/1 /13 DEV007 820 - POST  SLA FIX
  21883   "RTN","CHM FA141",695 ,0)
  21884    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1),F L)
  21885   "RTN","CHM FA141",696 ,0)
  21886   UP2 D CURR ES S FLD=C HCF
  21887   "RTN","CHM FA141",697 ,0)
  21888    Q
  21889   "RTN","CHM FA141",698 ,0)
  21890   PREV I CHW INLR<2 W * 7 Q
  21891   "RTN","CHM FA141",699 ,0)
  21892    S CHCDX=D X,CHCF=FLD
  21893   "RTN","CHM FA141",700 ,0)
  21894    S CHWINLR =CHWINLR-C HWIN S:CHW INLR<1 CHW INLR=1
  21895   "RTN","CHM FA141",701 ,0)
  21896    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,RO W1=CHWINLR -1
  21897   "RTN","CHM FA141",702 ,0)
  21898   P1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) G:'ROW 1 P2 G:ROW 1>CHWINHR  P2
  21899   "RTN","CHM FA141",703 ,0)
  21900    S DX=1,$X =DX X XY W  @CHEOL
  21901   "RTN","CHM FA141",704 ,0)
  21902    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  21903   "RTN","CHM FA141",705 ,0)
  21904    .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
  21905   "RTN","CHM FA141",706 ,0)
  21906    .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
  21907   "RTN","CHM FA141",707 ,0)
  21908    .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
  21909   "RTN","CHM FA141",708 ,0)
  21910    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)[".") D  CHKUNT Q     ;JEH 2/1 /11 DEV007 820
  21911   "RTN","CHM FA141",709 ,0)
  21912    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  21913   "RTN","CHM FA141",710 ,0)
  21914    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1),F L)
  21915   "RTN","CHM FA141",711 ,0)
  21916    S DY=DY+1  G P1
  21917   "RTN","CHM FA141",712 ,0)
  21918   P2 S DY=CH SDY,ROW=CH WINLR,DX=C HCDX,$X=DX ,FLD=CHCF
  21919   "RTN","CHM FA141",713 ,0)
  21920    Q
  21921   "RTN","CHM FA141",714 ,0)
  21922   NEXT I '$D (^UTILITY( $J,"CHDME" ,BEN,CHWIN HR+1)) W * 7 Q
  21923   "RTN","CHM FA141",715 ,0)
  21924    S CHCDX=D X,$X=DX,CH CF=FLD
  21925   "RTN","CHM FA141",716 ,0)
  21926    S CHWINLR =CHWINLR+C HWIN S:CHW INLR<1 CHW INLR=1
  21927   "RTN","CHM FA141",717 ,0)
  21928    I CHWINLR +CHWIN>CHL R S CHWINL R=CHLR-(CH WIN-1)
  21929   "RTN","CHM FA141",718 ,0)
  21930    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,RO W1=CHWINLR -1
  21931   "RTN","CHM FA141",719 ,0)
  21932   N1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) I 'ROW 1 D CLEAR2  G N2
  21933   "RTN","CHM FA141",720 ,0)
  21934    G:ROW1>CH WINHR N2
  21935   "RTN","CHM FA141",721 ,0)
  21936    S DX=1,$X =DX X XY W  @CHEOL
  21937   "RTN","CHM FA141",722 ,0)
  21938    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  21939   "RTN","CHM FA141",723 ,0)
  21940    .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
  21941   "RTN","CHM FA141",724 ,0)
  21942    .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
  21943   "RTN","CHM FA141",725 ,0)
  21944    .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
  21945   "RTN","CHM FA141",726 ,0)
  21946    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1)[".") D  CHKUNT Q     ;JEH 2/1 /11 DEV007 820
  21947   "RTN","CHM FA141",727 ,0)
  21948    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  21949   "RTN","CHM FA141",728 ,0)
  21950    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW1,F LD),U,1),F L)
  21951   "RTN","CHM FA141",729 ,0)
  21952    S DY=DY+1  G N1
  21953   "RTN","CHM FA141",730 ,0)
  21954   N2 S DY=CH SDY,ROW=CH WINLR,DX=C HCDX,$X=DX ,FLD=CHCF
  21955   "RTN","CHM FA141",731 ,0)
  21956    Q
  21957   "RTN","CHM FA141",732 ,0)
  21958   CLEAR2 S H Y=DY,DX=1, $X=DX F DY =HY:1:CHSD Y+CHWIN-1  X XY W @CH EOL
  21959   "RTN","CHM FA141",733 ,0)
  21960    Q
  21961   "RTN","CHM FA141",734 ,0)
  21962   CURSAV S C HCDX=DX,CH CDY=DY
  21963   "RTN","CHM FA141",735 ,0)
  21964    Q
  21965   "RTN","CHM FA141",736 ,0)
  21966   CURSV2 S C HCDX2=CHCD X,CHCDY2=C HCDY,SVFLD =FLD    ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  21967   "RTN","CHM FA141",737 ,0)
  21968    Q
  21969   "RTN","CHM FA141",738 ,0)
  21970   CURSV3 S C HCDX3=CHCD X,CHCDY3=C HCDY,SVFLD 3=FLD   ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  21971   "RTN","CHM FA141",739 ,0)
  21972    Q
  21973   "RTN","CHM FA141",740 ,0)
  21974   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
  21975   "RTN","CHM FA141",741 ,0)
  21976    Q
  21977   "RTN","CHM FA141",742 ,0)
  21978   CURSV5 S C HCDX5=DX,C HCDY5=DY
  21979   "RTN","CHM FA141",743 ,0)
  21980    Q
  21981   "RTN","CHM FA141",744 ,0)
  21982   CURRES S D X=CHCDX,$X =DX,DY=CHC DY
  21983   "RTN","CHM FA141",745 ,0)
  21984    Q
  21985   "RTN","CHM FA141",746 ,0)
  21986   CURRE2 S D X=CHCDX2,$ X=DX,DY=CH CDY2,FLD=S VFLD    ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  21987   "RTN","CHM FA141",747 ,0)
  21988    Q
  21989   "RTN","CHM FA141",748 ,0)
  21990   CURRE3 S D X=CHCDX3,$ X=DX,DY=CH CDY3,FLD=S VFLD3   ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  21991   "RTN","CHM FA141",749 ,0)
  21992    Q
  21993   "RTN","CHM FA141",750 ,0)
  21994   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
  21995   "RTN","CHM FA141",751 ,0)
  21996    Q
  21997   "RTN","CHM FA141",752 ,0)
  21998   CURRE5 S D X=CHCDX5,$ X=DX,DY=CH CDY5
  21999   "RTN","CHM FA141",753 ,0)
  22000    Q
  22001   "RTN","CHM FA141",754 ,0)
  22002   MARSCR S D TM=CHSDY+1 ,DBM=CHSDY +CHWIN X C HMAR   ;SK D, DTM=CHS DY,DBM=CHS DY+CHWIN-1
  22003   "RTN","CHM FA141",755 ,0)
  22004    Q
  22005   "RTN","CHM FA141",756 ,0)
  22006   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
  22007   "RTN","CHM FA141",757 ,0)
  22008    Q
  22009   "RTN","CHM FA141",758 ,0)
  22010   ERASCR S D X=1,$X=DX  F DY=CHSDY :1:CHSDY+C HWIN-1 X X Y W @CHEOL
  22011   "RTN","CHM FA141",759 ,0)
  22012    Q
  22013   "RTN","CHM FA141",760 ,0)
  22014   ERAMSG S D X=1,$X=DX  F DY=CHMDY :1:20 X XY  W @CHEOL
  22015   "RTN","CHM FA141",761 ,0)
  22016    Q
  22017   "RTN","CHM FA141",762 ,0)
  22018   CLRMSG I M SGFLG D CU RSAV,ERAMS G,ERROR,CU RRES S MSG FLG=0
  22019   "RTN","CHM FA141",763 ,0)
  22020    Q
  22021   "RTN","CHM FA141",764 ,0)
  22022   CLRLN ;CLE AR & REWRI TE FIELDS  6,7,8,16   ;JEH 2/1/1 1 DEV00780   ADDED SU BROUTINE
  22023   "RTN","CHM FA141",765 ,0)
  22024    N CLFLD
  22025   "RTN","CHM FA141",766 ,0)
  22026    S CLFLD=F LD
  22027   "RTN","CHM FA141",767 ,0)
  22028    ;X XY W @ CHEOL
  22029   "RTN","CHM FA141",768 ,0)
  22030    Q:'$G(ROW )
  22031   "RTN","CHM FA141",769 ,0)
  22032    F FLD=6,7 ,8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  22033   "RTN","CHM FA141",770 ,0)
  22034    .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
  22035   "RTN","CHM FA141",771 ,0)
  22036    .I FLD=6  D  Q
  22037   "RTN","CHM FA141",772 ,0)
  22038    ..I $L($P (^UTILITY( $J,"CHDME" ,BEN,ROW,F LD),"*",1) )>4 D
  22039   "RTN","CHM FA141",773 ,0)
  22040    ...W $J(" *"_$E($P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),"*",1),1 ,4),5)
  22041   "RTN","CHM FA141",774 ,0)
  22042    ..E  W $J ($E($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), "*",1),1,4 ),5)
  22043   "RTN","CHM FA141",775 ,0)
  22044    .I FLD=8  W $J($FN($ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U,1), "",2),FL)  Q
  22045   "RTN","CHM FA141",776 ,0)
  22046    .I FLD=16  W $J($FN( $P(^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD),U,1) ,"",2),FL)  Q
  22047   "RTN","CHM FA141",777 ,0)
  22048    .W $J($P( ^UTILITY($ J,"CHDME", BEN,ROW,FL D),U,1),FL ) Q
  22049   "RTN","CHM FA141",778 ,0)
  22050    S FLD=CLF LD
  22051   "RTN","CHM FA141",779 ,0)
  22052    Q
  22053   "RTN","CHM FA141",780 ,0)
  22054   ERROR Q
  22055   "RTN","CHM FA141",781 ,0)
  22056    ;
  22057   "RTN","CHM FA141",782 ,0)
  22058   STAFLG ;SE T ZANSFLG  BASED ON C ODE TYPE -  ANETHESIA  CODE - 2/ 1/2007
  22059   "RTN","CHM FA141",783 ,0)
  22060    N ZCDX ;J EH 2/1/11  DEV0078
  22061   "RTN","CHM FA141",784 ,0)
  22062    S ZCDX=$P (^UTILITY( $J,"CHDME" ,BEN,ROW,5 ),U,2)
  22063   "RTN","CHM FA141",785 ,0)
  22064    Q:'$D(ZCD X)!(ZCDX=" ")
  22065   "RTN","CHM FA141",786 ,0)
  22066    I $D(^CHM SERV(ZCDX, 4)) D
  22067   "RTN","CHM FA141",787 ,0)
  22068    .S ZANSFL G=1
  22069   "RTN","CHM FA141",788 ,0)
  22070    E  D
  22071   "RTN","CHM FA141",789 ,0)
  22072    .S ZANSFL G=0
  22073   "RTN","CHM FA141",790 ,0)
  22074    Q
  22075   "RTN","CHM FA141",791 ,0)
  22076   RESET ;SET  ASC PLACE  OF SERVIC E TO DO
  22077   "RTN","CHM FA141",792 ,0)
  22078    ;AEB 9/4/ 2007
  22079   "RTN","CHM FA141",793 ,0)
  22080    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
  22081   "RTN","CHM FA141",794 ,0)
  22082    .S TEMPCO DE="ASC",T EMPPOS=50, TEMPDESC=" AMBULATORY  SURGICAL  CENTER (AS C)"   ;DRW /JAK 5/17/ 10;DEV0076 00
  22083   "RTN","CHM FA141",795 ,0)
  22084    E  D   ;D RW/JAK 5/1 7/10;DEV00 7600
  22085   "RTN","CHM FA141",796 ,0)
  22086    .S TEMPCO DE="OP",TE MPPOS=2,TE MPDESC="OU TPATIENT H OSPITAL"    ;DRW/JAK  5/17/10;DE V007600
  22087   "RTN","CHM FA141",797 ,0)
  22088    S TMPROW= 0
  22089   "RTN","CHM FA141",798 ,0)
  22090   R2 S TMPRO W=$O(^UTIL ITY($J,"CH DME",BEN,T MPROW)) G: TMPROW=""  R3
  22091   "RTN","CHM FA141",799 ,0)
  22092    S CHPOS=$ P(^UTILITY ($J,"CHDME ",BEN,TMPR OW,2),U,2)
  22093   "RTN","CHM FA141",800 ,0)
  22094    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
  22095   "RTN","CHM FA141",801 ,0)
  22096    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 )
  22097   "RTN","CHM FA141",802 ,0)
  22098    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
  22099   "RTN","CHM FA141",803 ,0)
  22100    G R2
  22101   "RTN","CHM FA141",804 ,0)
  22102   R3 Q:'$D(C HEQP(BEN))   S TMPI=0
  22103   "RTN","CHM FA141",805 ,0)
  22104   R4 S TMPI= $O(CHEQP(B EN,TMPI))  Q:'TMPI
  22105   "RTN","CHM FA141",806 ,0)
  22106    S TMPJ=0
  22107   "RTN","CHM FA141",807 ,0)
  22108   R5 S TMPJ= $O(CHEQP(B EN,TMPI,TM PJ)) G:'TM PJ R4
  22109   "RTN","CHM FA141",808 ,0)
  22110    G:TMPJ'=2  R5        ;!($P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,2)'=50) R 5       ;; DRW/JAK 5/ 17/10;DEV0 07600
  22111   "RTN","CHM FA141",809 ,0)
  22112    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)
  22113   "RTN","CHM FA141",810 ,0)
  22114    S $P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,2)=TEMPPO S                 ;;D RW/JAK 5/1 7/10;DEV00 7600
  22115   "RTN","CHM FA141",811 ,0)
  22116    S $P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,3)=TEMPDE SC                ;;D RW/JAK 5/1 7/10;DEV00 7600
  22117   "RTN","CHM FA141",812 ,0)
  22118    G R5
  22119   "RTN","CHM FA141",813 ,0)
  22120    Q
  22121   "RTN","CHM FA141",814 ,0)
  22122   CHSMT(CHST )   ;CHECK /DISPLAY T OTALS
  22123   "RTN","CHM FA141",815 ,0)
  22124    N CHSMT,C HSDTTL
  22125   "RTN","CHM FA141",816 ,0)
  22126    I CHSUM(C HST)'=$$SU MDME(CHST)  S CHSUM(C HST)=$$SUM DME(CHST)  D
  22127   "RTN","CHM FA141",817 ,0)
  22128    .S SVFLD= FLD,FLD=CH ST D CURSA V,FLDLNG S  DX=CFDX,$ X=DX,DY=14
  22129   "RTN","CHM FA141",818 ,0)
  22130    .S:'$D(DD TOTAL(CHST )) DDTOTAL (CHST)=0 S  CHSUM(CHS T)=CHSUM(C HST)+DDTOT AL(CHST)
  22131   "RTN","CHM FA141",819 ,0)
  22132    .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
  22133   "RTN","CHM FA141",820 ,0)
  22134    .S FLD=SV FLD D FLDL NG D CURRE S X XY   ; JEH 5/3/10  ADD LINE
  22135   "RTN","CHM FA141",821 ,0)
  22136    Q
  22137   "RTN","CHM FA141",822 ,0)
  22138   AFSET() ;C HECK IF AU TOFLAG IS  SET    ;JE H 2/1/11 D EV007820
  22139   "RTN","CHM FA141",823 ,0)
  22140    N AFLD
  22141   "RTN","CHM FA141",824 ,0)
  22142    S AFLD=0
  22143   "RTN","CHM FA141",825 ,0)
  22144    S CFLD=0  F  S CFLD= $O(^UTILIT Y($J,"CHDM E",BEN,CFL D)) Q:'CFL D!(AFLD=1)   D
  22145   "RTN","CHM FA141",826 ,0)
  22146    .Q:$P(^UT ILITY($J," CHDME",BEN ,CFLD,5)," ^",1)=""
  22147   "RTN","CHM FA141",827 ,0)
  22148    .I $P(^UT ILITY($J," CHDME",BEN ,CFLD,17), "^",1)=1 S  AFLD=1
  22149   "RTN","CHM FA141",828 ,0)
  22150    Q AFLD
  22151   "RTN","CHM FA141",829 ,0)
  22152   CHKDSTR ;    ;JEH 2/1 /11 DEV007 820 - CHEC K FOR RE-D ISTRIBUTIO N OF P/R
  22153   "RTN","CHM FA141",830 ,0)
  22154    N TTLCHRG ,AROW,ARAT IO,TLNCHRG ,ADIFF,LNC HRG,CFLD,A FLD,RDFLG
  22155   "RTN","CHM FA141",831 ,0)
  22156    S CFLD=0  F  S CFLD= $O(^UTILIT Y($J,"CHDM E",BEN,CFL D)) Q:'CFL D!($D(AFLD ))  D
  22157   "RTN","CHM FA141",832 ,0)
  22158    .Q:$P(^UT ILITY($J," CHDME",BEN ,CFLD,5)," ^",1)=""
  22159   "RTN","CHM FA141",833 ,0)
  22160    .I $P(^UT ILITY($J," CHDME",BEN ,CFLD,17), "^",1)'=1  S AFLD=""
  22161   "RTN","CHM FA141",834 ,0)
  22162    Q:$D(AFLD )
  22163   "RTN","CHM FA141",835 ,0)
  22164    S TTLCHRG =""    ;SE TTING TOTA L CHARGE
  22165   "RTN","CHM FA141",836 ,0)
  22166    S (TTLPR, TTLAO)=""
  22167   "RTN","CHM FA141",837 ,0)
  22168    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  22169   "RTN","CHM FA141",838 ,0)
  22170    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  22171   "RTN","CHM FA141",839 ,0)
  22172    .S:^UTILI TY($J,"CHD ME",BEN,AR OW,11)'=""  TTLPR=TTL PR+^UTILIT Y($J,"CHDM E",BEN,ARO W,11)
  22173   "RTN","CHM FA141",840 ,0)
  22174    .S:^UTILI TY($J,"CHD ME",BEN,AR OW,12)'=""  TTLAO=TTL AO+^UTILIT Y($J,"CHDM E",BEN,ARO W,12)
  22175   "RTN","CHM FA141",841 ,0)
  22176    D AUTODST (TTLPR,11)
  22177   "RTN","CHM FA141",842 ,0)
  22178    D AUTODST (TTLAO,12)
  22179   "RTN","CHM FA141",843 ,0)
  22180    Q
  22181   "RTN","CHM FA141",844 ,0)
  22182   AUTODST(AO HIP,AFLD)  ;AUTO DIST RIBUTE TOT ALS TO LIN E ITEMS
  22183   "RTN","CHM FA141",845 ,0)
  22184    N TTLCHRG ,AROW,ARAT IO,TLNCHRG ,ADIFF,LNC HRG
  22185   "RTN","CHM FA141",846 ,0)
  22186    S TTLCHRG =0    ;GET TING TOTAL  CHARGE
  22187   "RTN","CHM FA141",847 ,0)
  22188    I AOHIP=" "!(+AOHIP= 0) D  Q
  22189   "RTN","CHM FA141",848 ,0)
  22190    .S AROW=0  F  S AROW =$O(^UTILI TY($J,"CHD ME",BEN,AR OW)) Q:'AR OW  D
  22191   "RTN","CHM FA141",849 ,0)
  22192    ..Q:$P(^U TILITY($J, "CHDME",BE N,AROW,5), "^",1)=""
  22193   "RTN","CHM FA141",850 ,0)
  22194    ..S ^UTIL ITY($J,"CH DME",BEN,A ROW,AFLD)= AOHIP
  22195   "RTN","CHM FA141",851 ,0)
  22196    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  22197   "RTN","CHM FA141",852 ,0)
  22198    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  22199   "RTN","CHM FA141",853 ,0)
  22200    .S TTLCHR G=TTLCHRG+ ^UTILITY($ J,"CHDME", BEN,AROW,8 )
  22201   "RTN","CHM FA141",854 ,0)
  22202    Q:TTLCHRG =0             ;JEH 9 /4/13 - FI X <DIVIDE>  ERROR
  22203   "RTN","CHM FA141",855 ,0)
  22204    S ARATIO= AOHIP/TTLC HRG  ;SETT ING AUTODS T RATIO
  22205   "RTN","CHM FA141",856 ,0)
  22206    S TLNCHRG =0   ;TOTA L LINE CHA RGE
  22207   "RTN","CHM FA141",857 ,0)
  22208    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  22209   "RTN","CHM FA141",858 ,0)
  22210    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  22211   "RTN","CHM FA141",859 ,0)
  22212    .S LNCHRG (AROW)=$FN (ARATIO*^U TILITY($J, "CHDME",BE N,AROW,8), "",2)
  22213   "RTN","CHM FA141",860 ,0)
  22214    .S TLNCHR G=TLNCHRG+ LNCHRG(ARO W)
  22215   "RTN","CHM FA141",861 ,0)
  22216    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  22217   "RTN","CHM FA141",862 ,0)
  22218    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  22219   "RTN","CHM FA141",863 ,0)
  22220    .S ^UTILI TY($J,"CHD ME",BEN,AR OW,AFLD)=L NCHRG(AROW )
  22221   "RTN","CHM FA141",864 ,0)
  22222    .S ^UTILI TY($J,"CHD ME",BEN,AR OW,17)=1    ;SETTING  AUTO DISTR O FLAG
  22223   "RTN","CHM FA141",865 ,0)
  22224    I TLNCHRG >0 D
  22225   "RTN","CHM FA141",866 ,0)
  22226    .I (AOHIP #TLNCHRG)' =0 D
  22227   "RTN","CHM FA141",867 ,0)
  22228    ..S ADIFF =AOHIP-TLN CHRG
  22229   "RTN","CHM FA141",868 ,0)
  22230    ..S AROW= 9999 S ARO W=$O(^UTIL ITY($J,"CH DME",BEN,A ROW),-1)
  22231   "RTN","CHM FA141",869 ,0)
  22232    ..I $P(^U TILITY($J, "CHDME",BE N,AROW,5), "^",1)=""  S AROW=$O( ^UTILITY($ J,"CHDME", BEN,AROW), -1)
  22233   "RTN","CHM FA141",870 ,0)
  22234    ..S ^UTIL ITY($J,"CH DME",BEN,A ROW,AFLD)= ^UTILITY($ J,"CHDME", BEN,AROW,A FLD)+ADIFF
  22235   "RTN","CHM FA141",871 ,0)
  22236    ..S ^UTIL ITY($J,"CH DME",BEN,A ROW,17)=1    ;SETTING  AUTO DIST RO FLAG
  22237   "RTN","CHM FA141",872 ,0)
  22238    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",BEN,ARO W)) Q:'ARO W  D
  22239   "RTN","CHM FA141",873 ,0)
  22240    .Q:$P(^UT ILITY($J," CHDME",BEN ,AROW,5)," ^",1)=""
  22241   "RTN","CHM FA141",874 ,0)
  22242    .S OPR=^U TILITY($J, "CHDME",BE N,AROW,11)
  22243   "RTN","CHM FA141",875 ,0)
  22244    .S AOP=^U TILITY($J, "CHDME",BE N,AROW,12)
  22245   "RTN","CHM FA141",876 ,0)
  22246    .I OPR<AO P D
  22247   "RTN","CHM FA141",877 ,0)
  22248    ..S TTOA= 0
  22249   "RTN","CHM FA141",878 ,0)
  22250    .E  S TTO A=OPR-AOP
  22251   "RTN","CHM FA141",879 ,0)
  22252    .I OPR="" &(AOP="")  S ^UTILITY ($J,"CHDME ",BEN,AROW ,16)=""
  22253   "RTN","CHM FA141",880 ,0)
  22254    .E  S ^UT ILITY($J," CHDME",BEN ,AROW,16)= $FN(TTOA," ",2)
  22255   "RTN","CHM FA141",881 ,0)
  22256    Q
  22257   "RTN","CHM FA14V")
  22258   0^49^B1259 638550
  22259   "RTN","CHM FA14V",1,0 )
  22260   CHMFA14V   ;DEN/CFS;D isplay E/E  SCREEN -  BILL/INVOI CE;06/28/2 017  09:08 AM
  22261   "RTN","CHM FA14V",2,0 )
  22262    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  22263   "RTN","CHM FA14V",3,0 )
  22264    ;CALLED B Y CHMFA141
  22265   "RTN","CHM FA14V",4,0 )
  22266    ;Rational  ID # 5054 66 (CPE005 -008)  06/ 28/2017  C FS (FTC)
  22267   "RTN","CHM FA14V",5,0 )
  22268    ;Display  data in Da te of Serv ice Chrono logical Or der.
  22269   "RTN","CHM FA14V",6,0 )
  22270    ;
  22271   "RTN","CHM FA14V",7,0 )
  22272   MAIN ;
  22273   "RTN","CHM FA14V",8,0 )
  22274    I $G(RANS )="" D                     ;;BUG 010291 DRW /JAK - mod ified code  to allow  for multip le claim p rocessing
  22275   "RTN","CHM FA14V",9,0 )
  22276    .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. 
  22277   "RTN","CHM FA14V",10, 0)
  22278    S RANS=""
  22279   "RTN","CHM FA14V",11, 0)
  22280    D INIT                            ;,TOTAL   ;AEB 9/5/ 2007  ;        ;JEH 2 /1/11 DEV0 07820
  22281   "RTN","CHM FA14V",12, 0)
  22282   M1 D ENTED T
  22283   "RTN","CHM FA14V",13, 0)
  22284   END Q
  22285   "RTN","CHM FA14V",14, 0)
  22286    ;
  22287   "RTN","CHM FA14V",15, 0)
  22288   INIT ;
  22289   "RTN","CHM FA14V",16, 0)
  22290    S DTM=7,D BM=14,DX=1 ,$X=DX,DY= 6 X CHMAR  X XY
  22291   "RTN","CHM FA14V",17, 0)
  22292    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
  22293   "RTN","CHM FA14V",18, 0)
  22294    S CHWINLR =1,CHWINHR =CHWIN,MSG FLG=0
  22295   "RTN","CHM FA14V",19, 0)
  22296    S ZANSFLG =0      ;J EH 12/10/0 6 NEW FLAG  FOR ANEST H CODE CAL C
  22297   "RTN","CHM FA14V",20, 0)
  22298    S CHBLNKO N="*27,*91 ,*53,*109"     ;SCREE N - BLINKI NG ON ;JEH  2/1/11 DE V007820
  22299   "RTN","CHM FA14V",21, 0)
  22300    S CHBLNKO FF="*27,*9 1,*23,*109 "   ;SCREE N - BLINKI NG OFF         ;JEH 2 /1/11 DEV0 07820
  22301   "RTN","CHM FA14V",22, 0)
  22302    N CHKFLG    ;JEH 9/1 3/13 - ENC 004389 
  22303   "RTN","CHM FA14V",23, 0)
  22304   SUBHEAD ;
  22305   "RTN","CHM FA14V",24, 0)
  22306    S:'$D(TOC ORG) TOCOR G=""         ;JEH 2/1 /11 DEV007 820
  22307   "RTN","CHM FA14V",25, 0)
  22308    S:'$D(TOC IPE) TOCIP E=""         ;JEH 2/1 /11 DEV007 820
  22309   "RTN","CHM FA14V",26, 0)
  22310    U 0:0:"^% X364"
  22311   "RTN","CHM FA14V",27, 0)
  22312    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
  22313   "RTN","CHM FA14V",28, 0)
  22314    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
  22315   "RTN","CHM FA14V",29, 0)
  22316    S DY=5,FL D=1 D FLDL NG S DX=CF DX,$X=DX X  XY W @CHU LON,"  DOS    "
  22317   "RTN","CHM FA14V",30, 0)
  22318    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
  22319   "RTN","CHM FA14V",31, 0)
  22320    E  S FLD= 2 D FLDLNG  S DX=CFDX ,$X=DX X X Y W "POS"                 ;JEH 2 /1/11 DEV0 07820
  22321   "RTN","CHM FA14V",32, 0)
  22322    S FLD=3 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "  ICD    "                       ;JEH 2/1 /11 DEV007 820
  22323   "RTN","CHM FA14V",33, 0)
  22324    S FLD=4 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "REV "                            ;JEH 2/1 /11 DEV007 820
  22325   "RTN","CHM FA14V",34, 0)
  22326    S FLD=5 D
  22327   "RTN","CHM FA14V",35, 0)
  22328    .I CHMFSR VC=4 D FLD LNG S DX=C FDX,$X=DX  X XY W "     SVCS      "  ;JEH 2 /1/11 DEV0 07820
  22329   "RTN","CHM FA14V",36, 0)
  22330    .E  D FLD LNG S DX=C FDX,$X=DX  X XY W "   SVCS/NDC    "    ;JEH  2/1/11 DE V007820
  22331   "RTN","CHM FA14V",37, 0)
  22332    S FLD=6 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "MODS "                           ;JEH 2/1 /11 DEV007 820
  22333   "RTN","CHM FA14V",38, 0)
  22334    S FLD=7 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "UNT/QTY"                         ;JEH 2/1 /11 DEV007 820
  22335   "RTN","CHM FA14V",39, 0)
  22336    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "  AMOUNT   "            ;JEH 2 /1/11 DEV0 07820
  22337   "RTN","CHM FA14V",40, 0)
  22338    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
  22339   "RTN","CHM FA14V",41, 0)
  22340    D TOTAL
  22341   "RTN","CHM FA14V",42, 0)
  22342    S ROW=1,U ="^"
  22343   "RTN","CHM FA14V",43, 0)
  22344    I '$D(^UT ILITY($J," CHDME")) D  NEWROW
  22345   "RTN","CHM FA14V",44, 0)
  22346    Q
  22347   "RTN","CHM FA14V",45, 0)
  22348    ;
  22349   "RTN","CHM FA14V",46, 0)
  22350   TOTAL ;
  22351   "RTN","CHM FA14V",47, 0)
  22352    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)  
  22353   "RTN","CHM FA14V",48, 0)
  22354    F FLD=8,1 4,16 D
  22355   "RTN","CHM FA14V",49, 0)
  22356    .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 
  22357   "RTN","CHM FA14V",50, 0)
  22358    F FLD=8,1 6 D FLDLNG  S DX=CFDX ,$X=DX X X Y D    ;JE H 2/1/11 D EV007820
  22359   "RTN","CHM FA14V",51, 0)
  22360    .W @CHBON ,@CHEOL,$J ($FN(TOTSU M(FLD),"," ,2),FL),@C HBOFF
  22361   "RTN","CHM FA14V",52, 0)
  22362    N MVENFLG     ;MEDIC AID VENDOR  PAYMENT F OR OUTPATI ENT FLAG
  22363   "RTN","CHM FA14V",53, 0)
  22364    S MVENFLG =""   ;JEH  2/1/11 DE V007820  
  22365   "RTN","CHM FA14V",54, 0)
  22366    S:$D(^CHM IMAGE(CHMF PDI,1,1,2, 1,"VEN"))  MVENFLG=$P (^CHMIMAGE (CHMFPDI,1 ,1,2,1,"VE N"),"^",16 )
  22367   "RTN","CHM FA14V",55, 0)
  22368    S:MVENFLG ="" MVENFL G=VFN
  22369   "RTN","CHM FA14V",56, 0)
  22370    I MVENFLG ="" S CHMC FG=0 Q     ;JEH 2/1/1 1 DEV00782 0
  22371   "RTN","CHM FA14V",57, 0)
  22372    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 
  22373   "RTN","CHM FA14V",58, 0)
  22374    I CHMCFG= 1 D
  22375   "RTN","CHM FA14V",59, 0)
  22376    .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 ***
  22377   "RTN","CHM FA14V",60, 0)
  22378    .S DY=15, DX=60,$X=D X X XY W @ CHBON,@CHE OL,$J($FN( TOTSUM(14) ,",",2),10 ),@CHBOFF
  22379   "RTN","CHM FA14V",61, 0)
  22380    Q
  22381   "RTN","CHM FA14V",62, 0)
  22382   ENTEDT ;S: '$D(DDTOTA L) DDTOTAL =0
  22383   "RTN","CHM FA14V",63, 0)
  22384    N FMDOS
  22385   "RTN","CHM FA14V",64, 0)
  22386    S CHWINLR =1,CHWINHR =CHWIN,ROW =1,FLD=0   ;CHVAR="^U TILITY($J, ""CHDME"", BEN,ROW,FL D)"   ;,CH SUM=0,CHSU M=CHSUM+DD TOTAL
  22387   "RTN","CHM FA14V",65, 0)
  22388    S FMDOS=" " F  S FMD OS=$O(^UTI LITY($J,"C HDME",FMDO S)) Q:FMDO S=""  D
  22389   "RTN","CHM FA14V",66, 0)
  22390    .S CHLR=9 99999999,C HLR=$O(^UT ILITY($J," CHDME",FMD OS,BEN,CHL R),-1)
  22391   "RTN","CHM FA14V",67, 0)
  22392    .S CHVAR= "^UTILITY( $J,""CHDME "",FMDOS,B EN,ROW,FLD )"
  22393   "RTN","CHM FA14V",68, 0)
  22394    .I $P(^UT ILITY($J," CHDME",FMD OS,BEN,1,1 ),U)'="" D  REDISP D  ENT1 Q 
  22395   "RTN","CHM FA14V",69, 0)
  22396    .S DY=CHS DY,MSGFLG= 0 D FLDLNG  S DX=CFDX ,$X=DX
  22397   "RTN","CHM FA14V",70, 0)
  22398    .S $P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,FLD),U,1) =ROW
  22399   "RTN","CHM FA14V",71, 0)
  22400    .I FLD=8! (FLD=16) X  XY W $J($ FN($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, FLD),U,1), "",2),FL)
  22401   "RTN","CHM FA14V",72, 0)
  22402    .E  I FLD =6 X XY W  $J($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, FLD),"*",1 ),5)   ;JE H 2/1/11 D EV007820
  22403   "RTN","CHM FA14V",73, 0)
  22404    .E  X XY  W $J($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W,FLD),U,1 ),FL)
  22405   "RTN","CHM FA14V",74, 0)
  22406    .S FLD=1  D FLDLNG S  DX=CFDX,$ X=DX
  22407   "RTN","CHM FA14V",75, 0)
  22408    .D ENT1
  22409   "RTN","CHM FA14V",76, 0)
  22410    Q
  22411   "RTN","CHM FA14V",77, 0)
  22412   ENT0 ;
  22413   "RTN","CHM FA14V",78, 0)
  22414    S $P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, FLD),U,1)= ROW
  22415   "RTN","CHM FA14V",79, 0)
  22416    I FLD=8!( FLD=16) X  XY W $J($F N($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,F LD),U,1)," ",2),FL)
  22417   "RTN","CHM FA14V",80, 0)
  22418    E  I FLD= 6 X XY W $ J($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,F LD),"*",1) ,5)   ;JEH  2/1/11 DE V007820
  22419   "RTN","CHM FA14V",81, 0)
  22420    E  X XY W  $J($P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,FLD),U,1) ,FL)
  22421   "RTN","CHM FA14V",82, 0)
  22422    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX
  22423   "RTN","CHM FA14V",83, 0)
  22424    D ENT1
  22425   "RTN","CHM FA14V",84, 0)
  22426    Q
  22427   "RTN","CHM FA14V",85, 0)
  22428   ENT1 ;
  22429   "RTN","CHM FA14V",86, 0)
  22430    S CHDB=""
  22431   "RTN","CHM FA14V",87, 0)
  22432    I $D(ROW)  I ROW'=""  S CHDB=^U TILITY($J, "CHDME",FM DOS,BEN,RO W,FLD)
  22433   "RTN","CHM FA14V",88, 0)
  22434    I ROW=""  S ROW=1 D  REDISP ;JS E 3/16/11  MTN011703  <SUBSCR> e rr @ ENT1+ 10 if ROW= ""
  22435   "RTN","CHM FA14V",89, 0)
  22436    S SFLD=0
  22437   "RTN","CHM FA14V",90, 0)
  22438    I FLD=5 X  XY W $J($ P($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,F LD),"*",2) ,U,1),FL)
  22439   "RTN","CHM FA14V",91, 0)
  22440    E  D
  22441   "RTN","CHM FA14V",92, 0)
  22442    .I FLD=6  D  ;JEH 2/ 1/11 DEV00 7820
  22443   "RTN","CHM FA14V",93, 0)
  22444    ..I $L($P (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW,FLD), "*",1))>4  D
  22445   "RTN","CHM FA14V",94, 0)
  22446    ...S SPC= "  ",$P(SP C," ",11-$ L($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,F LD),"*",1) ))=""
  22447   "RTN","CHM FA14V",95, 0)
  22448    ...X XY W  $P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,FL D),"*",1), SPC
  22449   "RTN","CHM FA14V",96, 0)
  22450    ..E  X XY  W $J($E($ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW,FLD) ,"*",1),1, 4),5)
  22451   "RTN","CHM FA14V",97, 0)
  22452    .E  I FLD =8!(FLD=16 ) I ($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W,FLD),U,1 )'="") X X Y W $J($FN ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,FL D),U,1),"" ,2),FL)
  22453   "RTN","CHM FA14V",98, 0)
  22454    .E  X XY  W $J($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W,FLD),U,1 ),FL)
  22455   "RTN","CHM FA14V",99, 0)
  22456    I FLD=2&( CHMFSRVC=4 ) D
  22457   "RTN","CHM FA14V",100 ,0)
  22458    .I $D(D4O UT) S FLD= FLD-1
  22459   "RTN","CHM FA14V",101 ,0)
  22460    .E  S FLD =FLD+1
  22461   "RTN","CHM FA14V",102 ,0)
  22462    .D FLDLNG ,CLRMSG S  DX=CFDX,$X =DX ;G ENT 1  ;D:$P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW,FLD),U) '="" CURSA V,DES1,CUR RES
  22463   "RTN","CHM FA14V",103 ,0)
  22464    I FLD=2&( CHMFSRVC=6 ) D  G ENT 1    ;SET  POS TO 'AM B' IF TRVL      ;JEH  2/1/11 DEV 007820 
  22465   "RTN","CHM FA14V",104 ,0)
  22466    .S ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,FL D)="AMB^10 ^AMBULANCE "
  22467   "RTN","CHM FA14V",105 ,0)
  22468    .X XY W $ J($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,F LD),U,1),F L)
  22469   "RTN","CHM FA14V",106 ,0)
  22470    .I $D(D4O UT) S FLD= FLD-1
  22471   "RTN","CHM FA14V",107 ,0)
  22472    .E  S FLD =FLD+1
  22473   "RTN","CHM FA14V",108 ,0)
  22474    .D FLDLNG ,CLRMSG S  DX=CFDX,$X =DX ;G ENT 1  ;D:$P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW,FLD),U) '="" CURSA V,DES1,CUR RES
  22475   "RTN","CHM FA14V",109 ,0)
  22476    I ZANSFLG =1&(FLD=7)  D
  22477   "RTN","CHM FA14V",110 ,0)
  22478    .D ANESCD      ;^CHM FA141         ;JEH 12 /08/06 NEW  FOR ANEST H
  22479   "RTN","CHM FA14V",111 ,0)
  22480    E  D
  22481   "RTN","CHM FA14V",112 ,0)
  22482    .X XY D C SBRS^CHSC2
  22483   "RTN","CHM FA14V",113 ,0)
  22484    .S CHLF=8  I $D(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, 3)) D
  22485   "RTN","CHM FA14V",114 ,0)
  22486    ..S:$P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W,3),U)'=" " CHLF=3
  22487   "RTN","CHM FA14V",115 ,0)
  22488    ..Q
  22489   "RTN","CHM FA14V",116 ,0)
  22490    .I $D(DFO UT) W *7 G  ENT1
  22491   "RTN","CHM FA14V",117 ,0)
  22492    .I $D(DUO UT) W *7 G  ENT1
  22493   "RTN","CHM FA14V",118 ,0)
  22494    .I Y'=""  S CHDB=""
  22495   "RTN","CHM FA14V",119 ,0)
  22496    .I Y=""&( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW,FLD)'= "") D   ;J EH 2/1/11  DEV007820
  22497   "RTN","CHM FA14V",120 ,0)
  22498    ..I FLD=6  S Y=$J($P (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW,FLD), "*",1),5)    ;JEH 2/1 /11 DEV007 820
  22499   "RTN","CHM FA14V",121 ,0)
  22500    ..E  S Y= $P(^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW,FLD ),U,1)   ; JEH 2/1/11  DEV007820
  22501   "RTN","CHM FA14V",122 ,0)
  22502    .S LNTAG= "GETF"_FLD _"^CHMFA14 2" D @LNTA G
  22503   "RTN","CHM FA14V",123 ,0)
  22504    I FLD=6&( Y="@") S Y ="",SFLD=0  D CURSAV, CLRLN,CURR ES G ENT1    ;JEH 2/1 /11 DEV007 820
  22505   "RTN","CHM FA14V",124 ,0)
  22506    I SFLD G  ENT1
  22507   "RTN","CHM FA14V",125 ,0)
  22508    I $D(ROW) ,ROW'="" D     ;JSG;0 2/28/08;BU G003956 -  Insulate c ode block  from undef ined ROW
  22509   "RTN","CHM FA14V",126 ,0)
  22510    .S ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,FL D)=Y
  22511   "RTN","CHM FA14V",127 ,0)
  22512    .I FLD=8  D
  22513   "RTN","CHM FA14V",128 ,0)
  22514    ..I '$D(R PTFLG) D
  22515   "RTN","CHM FA14V",129 ,0)
  22516    ...D CHKD STR   ;JEH  2/1/11 DE V007820 -  CHECK FOR  RE-DISTRIB UTION OF P /R
  22517   "RTN","CHM FA14V",130 ,0)
  22518    ...D RDPL YPR   ;JEH  2/1/11 DE V007820 -  REDISPLAY  P/R BAL TO TALS
  22519   "RTN","CHM FA14V",131 ,0)
  22520    .D CHSMT( 8)   ;CHEC K/DISPLAY  TOTALS
  22521   "RTN","CHM FA14V",132 ,0)
  22522    .D CHSMT( 16)  ;CHEC K/DISPLAY  TOTALS
  22523   "RTN","CHM FA14V",133 ,0)
  22524    .I ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,FL D)'=CHDB D    ;JEH 2/ 1/11 DEV00 7820
  22525   "RTN","CHM FA14V",134 ,0)
  22526    ..;X XY W  $J($P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,FLD),U,1) ,FL)   ;JE H 2/1/11 D EV007820   ORIG LINE,  COMMENT O UT
  22527   "RTN","CHM FA14V",135 ,0)
  22528    ..I FLD=6  X XY W $J ($E($P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,FLD),"*", 1),1,4),5) ,"  "   ;J EH 2/1/11  DEV007820
  22529   "RTN","CHM FA14V",136 ,0)
  22530    ..E  I FL D=5 X XY W  $J($P($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW,FLD)," *",2),U,1) ,FL)   ;JE H 2/1/11 D EV007820
  22531   "RTN","CHM FA14V",137 ,0)
  22532    ..E  X XY  W $J($P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW,FLD),U, 1),FL)
  22533   "RTN","CHM FA14V",138 ,0)
  22534    ..I FLD=3  D:$P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, FLD),U)'=" " ICDFIL ; CURSAV,DES CRP,CURRES ,ICDFIL    ;JEH 2/1/1 1 DEV00782 0 COMMENT  OUT CURSAV ,DESCRP,CU RRES
  22535   "RTN","CHM FA14V",139 ,0)
  22536    ..I FLD=5  D:$P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, FLD),U)'=" " CURSAV,D ES1,CURRES ,ICDFIL
  22537   "RTN","CHM FA14V",140 ,0)
  22538    ..X XY
  22539   "RTN","CHM FA14V",141 ,0)
  22540    I $G(ROW) &(FLD=8) I  $E($P($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW,5),"^" ,1),"*",2) ,1,2)=99 I  $$CDCHK^C HMFAUT4()= 1 S FLD=1  D FLDLNG,C LRMSG S DX =CFDX,$X=D X G ENT1    ;JEH 05/0 8/13 - ENC 004389
  22541   "RTN","CHM FA14V",142 ,0)
  22542    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
  22543   "RTN","CHM FA14V",143 ,0)
  22544    I ROW=1&$ D(D1OUT) W  *7 G ENT1
  22545   "RTN","CHM FA14V",144 ,0)
  22546    I ROW>1&$ D(D1OUT) D   D UP D F LDLNG,CLRM SG G ENT1     ;JEH 2/ 1/11 DEV00 7820 
  22547   "RTN","CHM FA14V",145 ,0)
  22548    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  22549   "RTN","CHM FA14V",146 ,0)
  22550    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  22551   "RTN","CHM FA14V",147 ,0)
  22552    I $D(D4OU T)&(FLD'>1 ) S FLD=CH LF D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  22553   "RTN","CHM FA14V",148 ,0)
  22554    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
  22555   "RTN","CHM FA14V",149 ,0)
  22556    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
  22557   "RTN","CHM FA14V",150 ,0)
  22558    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  22559   "RTN","CHM FA14V",151 ,0)
  22560    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  22561   "RTN","CHM FA14V",152 ,0)
  22562    .I FLD=7, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,5 ),U),"*")= "RX") S FL D=FLD-1
  22563   "RTN","CHM FA14V",153 ,0)
  22564    .S FLD=FL D-1
  22565   "RTN","CHM FA14V",154 ,0)
  22566    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD-1
  22567   "RTN","CHM FA14V",155 ,0)
  22568    I $D(D3OU T)&(FLD'<C HLF) S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  22569   "RTN","CHM FA14V",156 ,0)
  22570    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
  22571   "RTN","CHM FA14V",157 ,0)
  22572    .I FLD>5  D   ;JEH 2 /1/11 DEV0 07820
  22573   "RTN","CHM FA14V",158 ,0)
  22574    ..D CURSA V,CLRLN,CU RRES   ;JE H 2/1/11 D EV007820
  22575   "RTN","CHM FA14V",159 ,0)
  22576    .I FLD=5, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,5 ),U),"*")= "RX") S FL D=FLD+1
  22577   "RTN","CHM FA14V",160 ,0)
  22578    .S FLD=FL D+1
  22579   "RTN","CHM FA14V",161 ,0)
  22580    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  22581   "RTN","CHM FA14V",162 ,0)
  22582    I $D(DPOU T) D PREV  D FLDLNG,C LRMSG G EN T1
  22583   "RTN","CHM FA14V",163 ,0)
  22584    I $D(DNOU T) D NEXT  D FLDLNG,C LRMSG G EN T1
  22585   "RTN","CHM FA14V",164 ,0)
  22586    ; D2OUT O R CR
  22587   "RTN","CHM FA14V",165 ,0)
  22588    I '$D(D2O UT)&(FLD<C HLF) D  D  FLDLNG,CLR MSG S DX=C FDX,$X=DX  G ENT1
  22589   "RTN","CHM FA14V",166 ,0)
  22590    .I FLD=6  D CURSAV,C LRLN,CURRE S   ;JEH 2 /1/11 DEV0 07820
  22591   "RTN","CHM FA14V",167 ,0)
  22592    .I FLD=5, ROW'="",($ P($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,5 ),U),"*")= "RX") S FL D=FLD+1
  22593   "RTN","CHM FA14V",168 ,0)
  22594    .S FLD=FL D+1
  22595   "RTN","CHM FA14V",169 ,0)
  22596    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  22597   "RTN","CHM FA14V",170 ,0)
  22598    .I FLD=7, ROW'="" S: ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW,FLD)=" "&(^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW,1)= "DELETED")  ^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW,FLD)= 1
  22599   "RTN","CHM FA14V",171 ,0)
  22600    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
  22601   "RTN","CHM FA14V",172 ,0)
  22602    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
  22603   "RTN","CHM FA14V",173 ,0)
  22604    D DOWN D: FLD>5 CURS AV,CLRLN,C URRES S:^U TILITY($J, "CHDME",FM DOS,BEN,RO W,1)="" FL D=1 D FLDL NG,CLRMSG  S DX=CFDX, $X=DX G EN T1
  22605   "RTN","CHM FA14V",174 ,0)
  22606    Q
  22607   "RTN","CHM FA14V",175 ,0)
  22608   ANESCD ;AN ESTHESIA C ODE   ;NEW  JEH 12/8/ 06
  22609   "RTN","CHM FA14V",176 ,0)
  22610    I $P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, 3),U)'=""  S Y="" X X Y W $J(Y,F L)
  22611   "RTN","CHM FA14V",177 ,0)
  22612    D CURSAV^ CHMFA141,E RAMSG^CHMF A141:MSGFL G,MARMES^C HMFA141 S  IOSL=3,DX= 1,$X=DX,DY =CHMDY X X Y
  22613   "RTN","CHM FA14V",178 ,0)
  22614    ;
  22615   "RTN","CHM FA14V",179 ,0)
  22616   AN2 ;LOOP
  22617   "RTN","CHM FA14V",180 ,0)
  22618    S (TIMU,B ASU,TOTU)= 0
  22619   "RTN","CHM FA14V",181 ,0)
  22620    D NOW^%DT C S DMYDT= X
  22621   "RTN","CHM FA14V",182 ,0)
  22622    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  
  22623   "RTN","CHM FA14V",183 ,0)
  22624    S DIR(0)= "F",DIR("B ")="M" D ^ DIR K DIR  S ANS=Y
  22625   "RTN","CHM FA14V",184 ,0)
  22626    I ANS="^"  S Y=0 G A NEND
  22627   "RTN","CHM FA14V",185 ,0)
  22628    I ANS="@"  D
  22629   "RTN","CHM FA14V",186 ,0)
  22630    .S ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,FL D)=""
  22631   "RTN","CHM FA14V",187 ,0)
  22632    .S Y=0
  22633   "RTN","CHM FA14V",188 ,0)
  22634    .S SFLD=1  G ANEND
  22635   "RTN","CHM FA14V",189 ,0)
  22636    I ANS=""  S Y=1 G AN END
  22637   "RTN","CHM FA14V",190 ,0)
  22638    I ANS'="M "&(ANS'="U ")&(ANS'=" T") D ANHE LP G AN2      ;ESCD    ;JEH 7/18 /07 - DEV0 01373-01:  Anesthesia  minute ca lc  
  22639   "RTN","CHM FA14V",191 ,0)
  22640    I ANS="U"  D
  22641   "RTN","CHM FA14V",192 ,0)
  22642    .S ANS2FL G=1
  22643   "RTN","CHM FA14V",193 ,0)
  22644    .W !,?5," Enter the  number of  Units: " R  ANS2
  22645   "RTN","CHM FA14V",194 ,0)
  22646    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D
  22647   "RTN","CHM FA14V",195 ,0)
  22648    ..S TOTU= 0
  22649   "RTN","CHM FA14V",196 ,0)
  22650    ..S ANS2F LG=0
  22651   "RTN","CHM FA14V",197 ,0)
  22652    .E  S TIM U=+ANS2
  22653   "RTN","CHM FA14V",198 ,0)
  22654    I ANS="M"  D
  22655   "RTN","CHM FA14V",199 ,0)
  22656    .S ANS2FL G=1
  22657   "RTN","CHM FA14V",200 ,0)
  22658    .W !,?5," Enter the  number of  Minutes: "  R ANS2
  22659   "RTN","CHM FA14V",201 ,0)
  22660    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D 
  22661   "RTN","CHM FA14V",202 ,0)
  22662    ..S TOTU= 0
  22663   "RTN","CHM FA14V",203 ,0)
  22664    ..S ANS2F LG=0
  22665   "RTN","CHM FA14V",204 ,0)
  22666    .E  D ANC ALC
  22667   "RTN","CHM FA14V",205 ,0)
  22668    I ANS="T"  D         ;JEH 7/18/ 07 - DEV00 1373-01: A nesthesia  minute cal c
  22669   "RTN","CHM FA14V",206 ,0)
  22670    .S (STRTD T,ENDDT)=" "
  22671   "RTN","CHM FA14V",207 ,0)
  22672    .S ANS2FL G=1
  22673   "RTN","CHM FA14V",208 ,0)
  22674   SD1 .;STAR T DATE
  22675   "RTN","CHM FA14V",209 ,0)
  22676    .W !,"Ent er the STA RT time: "  R ANS2
  22677   "RTN","CHM FA14V",210 ,0)
  22678    .I (ANS2= "^") D  Q
  22679   "RTN","CHM FA14V",211 ,0)
  22680    ..S TOTU= 0
  22681   "RTN","CHM FA14V",212 ,0)
  22682    ..S ANS2F LG=0
  22683   "RTN","CHM FA14V",213 ,0)
  22684    .G:ANS2=" "!(ANS2="  ") SD1
  22685   "RTN","CHM FA14V",214 ,0)
  22686    .I ANS2=" ?" D HLP^C HTFLIB  G  SD1
  22687   "RTN","CHM FA14V",215 ,0)
  22688    .I ANS2=" T" D HLP^C HTFLIB  G  SD1
  22689   "RTN","CHM FA14V",216 ,0)
  22690    .I ANS2[" @" D
  22691   "RTN","CHM FA14V",217 ,0)
  22692    ..S STRTD 1=$P(ANS2, "@",1)
  22693   "RTN","CHM FA14V",218 ,0)
  22694    ..S X=STR TD1 D ^%DT  S:Y'=-1 S TRTD1=Y
  22695   "RTN","CHM FA14V",219 ,0)
  22696    ..S STRTT 1=$P(ANS2, "@",2)
  22697   "RTN","CHM FA14V",220 ,0)
  22698    ..S STRTT M=$$TIMECN V^CHTFLIB( STRTT1) S  Y=$$MIL^CH TFLIB(STRT TM)
  22699   "RTN","CHM FA14V",221 ,0)
  22700    ..S:$L(Y) <4 Y="0"_Y
  22701   "RTN","CHM FA14V",222 ,0)
  22702    ..S Y=STR TD1_"."_Y
  22703   "RTN","CHM FA14V",223 ,0)
  22704    .E  D
  22705   "RTN","CHM FA14V",224 ,0)
  22706    ..S STRTT M=$$TIMECN V^CHTFLIB( ANS2)
  22707   "RTN","CHM FA14V",225 ,0)
  22708    ..I '$G(S TRTTM) S Y =-1 Q
  22709   "RTN","CHM FA14V",226 ,0)
  22710    ..S Y=$$M IL^CHTFLIB (STRTTM)
  22711   "RTN","CHM FA14V",227 ,0)
  22712    ..I Y=-1  Q
  22713   "RTN","CHM FA14V",228 ,0)
  22714    ..S:$L(Y) <4 Y="0"_Y
  22715   "RTN","CHM FA14V",229 ,0)
  22716    ..S Y=DMY DT_"."_Y      ;DUMMY  DATE 
  22717   "RTN","CHM FA14V",230 ,0)
  22718    .I Y=""!( Y="?") D H LP^CHTFLIB  G SD1
  22719   "RTN","CHM FA14V",231 ,0)
  22720    .I Y=-1 D  HLP^CHTFL IB G SD1
  22721   "RTN","CHM FA14V",232 ,0)
  22722    .S STRTDT =Y
  22723   "RTN","CHM FA14V",233 ,0)
  22724   ED1 .;END  DATE
  22725   "RTN","CHM FA14V",234 ,0)
  22726    .W !,"Ent er the END  time: " R  ANS2
  22727   "RTN","CHM FA14V",235 ,0)
  22728    .I (ANS2= "^")!(ANS2 ="@") D  Q
  22729   "RTN","CHM FA14V",236 ,0)
  22730    ..S TOTU= 0
  22731   "RTN","CHM FA14V",237 ,0)
  22732    ..S ANS2F LG=0
  22733   "RTN","CHM FA14V",238 ,0)
  22734    .G:ANS2=" "!(ANS2="  ") SD1
  22735   "RTN","CHM FA14V",239 ,0)
  22736    .I ANS2=" ?" D HLP^C HTFLIB  G  ED1
  22737   "RTN","CHM FA14V",240 ,0)
  22738    .I ANS2=" T" D HLP^C HTFLIB  G  ED1
  22739   "RTN","CHM FA14V",241 ,0)
  22740    .I ANS2[" @" D
  22741   "RTN","CHM FA14V",242 ,0)
  22742    ..S ENDD1 =$P(ANS2," @",1)
  22743   "RTN","CHM FA14V",243 ,0)
  22744    ..S ENDT1 =$P(ANS2," @",2)
  22745   "RTN","CHM FA14V",244 ,0)
  22746    ..S ENDTM =$$TIMECNV ^CHTFLIB(E NDT1) S Y= $$MIL^CHTF LIB(ENDTM)
  22747   "RTN","CHM FA14V",245 ,0)
  22748    ..S:$L(Y) <4 Y="0"_Y
  22749   "RTN","CHM FA14V",246 ,0)
  22750    ..S Y=END D1_"."_Y
  22751   "RTN","CHM FA14V",247 ,0)
  22752    .E  D
  22753   "RTN","CHM FA14V",248 ,0)
  22754    ..S ENDTM =$$TIMECNV ^CHTFLIB(A NS2)
  22755   "RTN","CHM FA14V",249 ,0)
  22756    ..I '$G(E NDTM) S Y= -1 Q
  22757   "RTN","CHM FA14V",250 ,0)
  22758    ..S Y=$$M IL^CHTFLIB (ENDTM)
  22759   "RTN","CHM FA14V",251 ,0)
  22760    ..I Y=-1  Q
  22761   "RTN","CHM FA14V",252 ,0)
  22762    ..S:$L(Y) <4 Y="0"_Y
  22763   "RTN","CHM FA14V",253 ,0)
  22764    ..S Y=DMY DT_"."_Y      ;DUMMY  DATE 
  22765   "RTN","CHM FA14V",254 ,0)
  22766    .I Y=""!( Y="?") D H LP^CHTFLIB  G ED1
  22767   "RTN","CHM FA14V",255 ,0)
  22768    .I Y=-1 D  HLP^CHTFL IB G ED1
  22769   "RTN","CHM FA14V",256 ,0)
  22770    .S ENDDT= Y
  22771   "RTN","CHM FA14V",257 ,0)
  22772    .I ENDDT< STRTDT D H LP2^CHTFLI B G ED1
  22773   "RTN","CHM FA14V",258 ,0)
  22774    .I ANS2=" "!(ANS2="^ ")!(ANS2=" @") D 
  22775   "RTN","CHM FA14V",259 ,0)
  22776    ..S TOTU= 0
  22777   "RTN","CHM FA14V",260 ,0)
  22778    ..S ANS2F LG=0
  22779   "RTN","CHM FA14V",261 ,0)
  22780    .E  D
  22781   "RTN","CHM FA14V",262 ,0)
  22782    ..S ANS2= $$CALCMIN^ CHTFLIB(ST RTDT,ENDDT )
  22783   "RTN","CHM FA14V",263 ,0)
  22784    ..D ANCAL C
  22785   "RTN","CHM FA14V",264 ,0)
  22786    S ANCDE=$ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW,5)," ^",1)  ;GE T CODE FRO M SVCS COL UMN
  22787   "RTN","CHM FA14V",265 ,0)
  22788    S ANCDI=$ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW,5)," ^",2)  ;GE T CODE I-V AL
  22789   "RTN","CHM FA14V",266 ,0)
  22790    I ANS2FLG =1 D
  22791   "RTN","CHM FA14V",267 ,0)
  22792    .I $D(ANC DI)&(ANCDI '="")&(ANC DI'=" ") D          ; JEH 1/2/08  BUG003971 -03-01 - L OGIC FIX F OR SUBSCRI PT ERROR
  22793   "RTN","CHM FA14V",268 ,0)
  22794    ..S CHCDE FD=$P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, 1),"^",2)    ;GET COR RECT RVU F OR DOS
  22795   "RTN","CHM FA14V",269 ,0)
  22796    ..S CHCDE FD=$O(^CHM SERV(ANCDI ,4,"B",CHC DEFD),-1)
  22797   "RTN","CHM FA14V",270 ,0)
  22798    ..I $G(CH CDEFD) D
  22799   "RTN","CHM FA14V",271 ,0)
  22800    ...S CHCJ PTR=0 S CH CJPTR=$O(^ CHMSERV(AN CDI,4,"B", CHCDEFD,CH CJPTR))
  22801   "RTN","CHM FA14V",272 ,0)
  22802    ...S BASU =$P(^CHMSE RV(ANCDI,4 ,CHCJPTR,0 ),"^",2)
  22803   "RTN","CHM FA14V",273 ,0)
  22804    ...S TOTU =TIMU+BASU
  22805   "RTN","CHM FA14V",274 ,0)
  22806    ..E  D
  22807   "RTN","CHM FA14V",275 ,0)
  22808    ...W !!!, ?5,"Anesth esia Unit  not availa ble, setti ng default  value.",! ,?5,"Hit < enter> to  continue.. . " R XXX: 5
  22809   "RTN","CHM FA14V",276 ,0)
  22810    ...S TOTU =1
  22811   "RTN","CHM FA14V",277 ,0)
  22812    .E  S TOT U=0
  22813   "RTN","CHM FA14V",278 ,0)
  22814    S Y=+TOTU
  22815   "RTN","CHM FA14V",279 ,0)
  22816    K ANS,ANS 2,TIMU,UNI T,ANCDE,BA SU
  22817   "RTN","CHM FA14V",280 ,0)
  22818    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  22819   "RTN","CHM FA14V",281 ,0)
  22820    S ZANSFLG =0
  22821   "RTN","CHM FA14V",282 ,0)
  22822    Q
  22823   "RTN","CHM FA14V",283 ,0)
  22824   ANEND ;
  22825   "RTN","CHM FA14V",284 ,0)
  22826    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  22827   "RTN","CHM FA14V",285 ,0)
  22828    Q
  22829   "RTN","CHM FA14V",286 ,0)
  22830   ANHELP ;
  22831   "RTN","CHM FA14V",287 ,0)
  22832    W !?5,"Yo u must Ent er 'M' or  'U'."
  22833   "RTN","CHM FA14V",288 ,0)
  22834    Q 
  22835   "RTN","CHM FA14V",289 ,0)
  22836   ANCALC ;CA LCULATE TH E NUMBER O F UNITS FR OM MINUTES  ENTERED
  22837   "RTN","CHM FA14V",290 ,0)
  22838    S TIMU=0
  22839   "RTN","CHM FA14V",291 ,0)
  22840    S UNIT=AN S2#15
  22841   "RTN","CHM FA14V",292 ,0)
  22842    S TIMU=(A NS2-UNIT)/ 15
  22843   "RTN","CHM FA14V",293 ,0)
  22844    S:UNIT'=0  TIMU=TIMU +1
  22845   "RTN","CHM FA14V",294 ,0)
  22846    Q
  22847   "RTN","CHM FA14V",295 ,0)
  22848   SUMDME(SUM FLD) ;SUMS  ARRAY DME  - AMOUNT
  22849   "RTN","CHM FA14V",296 ,0)
  22850    N SUM,R
  22851   "RTN","CHM FA14V",297 ,0)
  22852    S SUM=0
  22853   "RTN","CHM FA14V",298 ,0)
  22854    I $D(ROW)  Q:ROW=""  SUM
  22855   "RTN","CHM FA14V",299 ,0)
  22856    ;I '$D(^U TILITY($J, "CHDME",FM DOS,BEN,RO W,SUMFLD)) &('$D(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,SUMFLD)))  Q SUM     ;JEH 2/1/1 1 DEV00782 0
  22857   "RTN","CHM FA14V",300 ,0)
  22858    S R=0
  22859   "RTN","CHM FA14V",301 ,0)
  22860    F  S R=$O (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,R)) G:'R  SUMEND D
  22861   "RTN","CHM FA14V",302 ,0)
  22862    .Q:'$D(^U TILITY($J, "CHDME",FM DOS,BEN,R, SUMFLD))
  22863   "RTN","CHM FA14V",303 ,0)
  22864    .S SUM=SU M+^UTILITY ($J,"CHDME ",FMDOS,BE N,R,SUMFLD )
  22865   "RTN","CHM FA14V",304 ,0)
  22866   SUMEND Q S UM
  22867   "RTN","CHM FA14V",305 ,0)
  22868    ;
  22869   "RTN","CHM FA14V",306 ,0)
  22870   SUMDM8() ; SUMS ARRAY  DME - AMO UNT
  22871   "RTN","CHM FA14V",307 ,0)
  22872    N SUM,R
  22873   "RTN","CHM FA14V",308 ,0)
  22874    S SUM=0
  22875   "RTN","CHM FA14V",309 ,0)
  22876    I $D(ROW)  Q:ROW=""  SUM
  22877   "RTN","CHM FA14V",310 ,0)
  22878    I '$D(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,16)) Q SU M
  22879   "RTN","CHM FA14V",311 ,0)
  22880    S R=0
  22881   "RTN","CHM FA14V",312 ,0)
  22882    F  S R=$O (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,R)) G:'R  SUMEND8 D
  22883   "RTN","CHM FA14V",313 ,0)
  22884    .Q:'$D(^U TILITY($J, "CHDME",FM DOS,BEN,R, 16))
  22885   "RTN","CHM FA14V",314 ,0)
  22886    .S SUM=SU M+^UTILITY ($J,"CHDME ",FMDOS,BE N,R,16)
  22887   "RTN","CHM FA14V",315 ,0)
  22888   SUMEND8 Q  SUM
  22889   "RTN","CHM FA14V",316 ,0)
  22890    ;
  22891   "RTN","CHM FA14V",317 ,0)
  22892   SUMDM16()  ;SUMS ARRA Y DME - AM OUNT
  22893   "RTN","CHM FA14V",318 ,0)
  22894    N SUM,R
  22895   "RTN","CHM FA14V",319 ,0)
  22896    S SUM=0
  22897   "RTN","CHM FA14V",320 ,0)
  22898    I $D(ROW)  Q:ROW=""  SUM
  22899   "RTN","CHM FA14V",321 ,0)
  22900    I '$D(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,16)) Q SU M
  22901   "RTN","CHM FA14V",322 ,0)
  22902    S R=0
  22903   "RTN","CHM FA14V",323 ,0)
  22904    F  S R=$O (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,R)) G:'R  SUMEND16 D
  22905   "RTN","CHM FA14V",324 ,0)
  22906    .Q:'$D(^U TILITY($J, "CHDME",FM DOS,BEN,R, 16))
  22907   "RTN","CHM FA14V",325 ,0)
  22908    .S SUM=SU M+^UTILITY ($J,"CHDME ",FMDOS,BE N,R,16)
  22909   "RTN","CHM FA14V",326 ,0)
  22910   SUMEND16 Q  SUM
  22911   "RTN","CHM FA14V",327 ,0)
  22912    ;
  22913   "RTN","CHM FA14V",328 ,0)
  22914   DESCRP ;
  22915   "RTN","CHM FA14V",329 ,0)
  22916    S DX=45,$ X=DX
  22917   "RTN","CHM FA14V",330 ,0)
  22918    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
  22919   "RTN","CHM FA14V",331 ,0)
  22920    K BF S BF ="",$P(BF, " ",FL+1)= ""
  22921   "RTN","CHM FA14V",332 ,0)
  22922    X XY W $E ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,FL D),U,3),1, 15)
  22923   "RTN","CHM FA14V",333 ,0)
  22924    ;
  22925   "RTN","CHM FA14V",334 ,0)
  22926   DES1 D ERA MSG
  22927   "RTN","CHM FA14V",335 ,0)
  22928    S HOLDDY= DY
  22929   "RTN","CHM FA14V",336 ,0)
  22930    S $P(STR, " ",44)=""     ;JEH 2 /1/11 DEV0 07820 CHGD  59 TO 44
  22931   "RTN","CHM FA14V",337 ,0)
  22932    S DX=1,$X =DX,DY=15  X XY W STR  X XY
  22933   "RTN","CHM FA14V",338 ,0)
  22934    W $E($P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW,FLD),U, 3),1,44)     ;JEH 2/1 /11 DEV007 820 CHGD d own TO 44
  22935   "RTN","CHM FA14V",339 ,0)
  22936    S MSGFLG= 1
  22937   "RTN","CHM FA14V",340 ,0)
  22938    Q
  22939   "RTN","CHM FA14V",341 ,0)
  22940    ;
  22941   "RTN","CHM FA14V",342 ,0)
  22942   ICDFIL ;
  22943   "RTN","CHM FA14V",343 ,0)
  22944    I FLD=3 S  CHLF=3 D
  22945   "RTN","CHM FA14V",344 ,0)
  22946    .F FLD=4: 1:7 S ^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, FLD)=""
  22947   "RTN","CHM FA14V",345 ,0)
  22948    .F FLD=4: 1:7 D FLDL NG S DX=CF DX,$X=DX X  XY W $J($ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW,FLD) ,U,1),FL)
  22949   "RTN","CHM FA14V",346 ,0)
  22950    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX
  22951   "RTN","CHM FA14V",347 ,0)
  22952    I FLD=5 S  CHLF=8 D
  22953   "RTN","CHM FA14V",348 ,0)
  22954    .S ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,3) =""
  22955   "RTN","CHM FA14V",349 ,0)
  22956    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX X XY  W $J($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W,FLD),U,1 ),FL)
  22957   "RTN","CHM FA14V",350 ,0)
  22958    .S FLD=5  D FLDLNG S  DX=CFDX,$ X=DX
  22959   "RTN","CHM FA14V",351 ,0)
  22960    I FLD=6 S  CHLF=8 D
  22961   "RTN","CHM FA14V",352 ,0)
  22962    .S ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,3) =""
  22963   "RTN","CHM FA14V",353 ,0)
  22964    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX X XY  W $J($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W,FLD),U,1 ),FL)
  22965   "RTN","CHM FA14V",354 ,0)
  22966    .S FLD=5  D FLDLNG S  DX=CFDX,$ X=DX X XY  W $J($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W,FLD),U,1 ),FL)
  22967   "RTN","CHM FA14V",355 ,0)
  22968    .S FLD=6  D FLDLNG S  DX=CFDX,$ X=DX
  22969   "RTN","CHM FA14V",356 ,0)
  22970    Q
  22971   "RTN","CHM FA14V",357 ,0)
  22972    ;
  22973   "RTN","CHM FA14V",358 ,0)
  22974   EDITOK ;MO DIFIED BY  DTP TO SKI P REV CODE  EDITS ON  PAPER, BUT  NOT EDI I N LAST LIN E OF SUBRT N
  22975   "RTN","CHM FA14V",359 ,0)
  22976    Q:'$D(CHM FPDI)
  22977   "RTN","CHM FA14V",360 ,0)
  22978    S X=$$TYP E^CHMFPDI2 (CHMFPDI)
  22979   "RTN","CHM FA14V",361 ,0)
  22980    S PT=0,PT =$O(^CHMDI C(741002.9 3,"C",X,PT ))
  22981   "RTN","CHM FA14V",362 ,0)
  22982    Q:'PT  Q: '$D(^CHMDI C(741002.9 3,PT,0))
  22983   "RTN","CHM FA14V",363 ,0)
  22984    S PTR=$P( ^(0),"^",3 )
  22985   "RTN","CHM FA14V",364 ,0)
  22986    Q:'PTR  Q :'$D(^CHMD IC(741002. 94,PTR,2))
  22987   "RTN","CHM FA14V",365 ,0)
  22988    S:$P(^(2) ,"^",PC) N OEDIT=1
  22989   "RTN","CHM FA14V",366 ,0)
  22990    I (PC=2)& ($E(X,1,1) =9) K NOED IT
  22991   "RTN","CHM FA14V",367 ,0)
  22992    Q
  22993   "RTN","CHM FA14V",368 ,0)
  22994   BEEPQ X XY  W BF X XY  W *7,"??"  X XY W BF
  22995   "RTN","CHM FA14V",369 ,0)
  22996    Q
  22997   "RTN","CHM FA14V",370 ,0)
  22998    ;
  22999   "RTN","CHM FA14V",371 ,0)
  23000   FLDLNG ;
  23001   "RTN","CHM FA14V",372 ,0)
  23002    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
  23003   "RTN","CHM FA14V",373 ,0)
  23004    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
  23005   "RTN","CHM FA14V",374 ,0)
  23006    K BF S BF ="",$P(BF, " ",FL+1)= ""
  23007   "RTN","CHM FA14V",375 ,0)
  23008    Q
  23009   "RTN","CHM FA14V",376 ,0)
  23010    ;
  23011   "RTN","CHM FA14V",377 ,0)
  23012   REPEAT X X Y W BF
  23013   "RTN","CHM FA14V",378 ,0)
  23014    I $E(Y)=" R" D RPTML T Q   ;JEH  2/1/11 DE V007820
  23015   "RTN","CHM FA14V",379 ,0)
  23016    I $E(Y)=" U" D UBNDL  Q   ;JEH  2/1/11 DEV 007820
  23017   "RTN","CHM FA14V",380 ,0)
  23018    I $E(Y)=" /" D DIVID E
  23019   "RTN","CHM FA14V",381 ,0)
  23020    S STOP=$E (Y,2,$L(Y) )+(ROW-2), START=ROW, DY=DY-1 F  ROW1=START :1:STOP D
  23021   "RTN","CHM FA14V",382 ,0)
  23022    .;S ^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, 0)=ROW1 F  FLD=1:1:8, 16,17 S ^U TILITY($J, "CHDME",FM DOS,BEN,RO W1,FLD)=^U TILITY($J, "CHDME",FM DOS,BEN,RO W-1,FLD)
  23023   "RTN","CHM FA14V",383 ,0)
  23024    .S ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,0 )=ROW1 F F LD=1:1:18  S ^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW1,FLD )=^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW-1,FL D)   ;JEH  2/1/11 DEV 007820
  23025   "RTN","CHM FA14V",384 ,0)
  23026    .S DY=DY+ 1 I DY=(CH SDY+CHWIN)  D
  23027   "RTN","CHM FA14V",385 ,0)
  23028    ..S DY=CH SDY+CHWIN- 1,CHWINLR= CHWINLR+1, CHWINHR=CH WINHR+1
  23029   "RTN","CHM FA14V",386 ,0)
  23030    ..S DX=1, $X=DX X XY  W !
  23031   "RTN","CHM FA14V",387 ,0)
  23032    .F FLD=0: 1:8,16,17  D FLDLNG S  DX=CFDX,$ X=DX X XY  D
  23033   "RTN","CHM FA14V",388 ,0)
  23034    ..I FLD=8 !(FLD=16)  I $P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1)' ="" W $J($ FN($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,1),"",2) ,FL) Q  ;a eb 1/10/20 08 DEF0033 67 added t o show rev  code
  23035   "RTN","CHM FA14V",389 ,0)
  23036    ..I FLD=5  X XY W $J ($P($P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,FLD),"*" ,2),U,1),F L) Q   ;JE H 2/1/11 D EV007820
  23037   "RTN","CHM FA14V",390 ,0)
  23038    ..I FLD=6  X XY W $J ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),"*",1) ,5) Q   ;J EH 2/1/11  DEV007820
  23039   "RTN","CHM FA14V",391 ,0)
  23040    ..W $J($P (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW1,FLD) ,U,1),FL)
  23041   "RTN","CHM FA14V",392 ,0)
  23042    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  23043   "RTN","CHM FA14V",393 ,0)
  23044    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1
  23045   "RTN","CHM FA14V",394 ,0)
  23046    S SFLD=1
  23047   "RTN","CHM FA14V",395 ,0)
  23048    D CHSMT(8 )   ;CHECK /DISPLAY T OTALS
  23049   "RTN","CHM FA14V",396 ,0)
  23050    D CHSMT(1 6)  ;CHECK /DISPLAY T OTALS
  23051   "RTN","CHM FA14V",397 ,0)
  23052   REPEND Q
  23053   "RTN","CHM FA14V",398 ,0)
  23054    ;
  23055   "RTN","CHM FA14V",399 ,0)
  23056   DIVIDE S Y 1=^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW-1,8) /$E(Y,2,$L (Y))
  23057   "RTN","CHM FA14V",400 ,0)
  23058    S Y1=$J(Y 1,$L($P(Y1 ,".",1))+3 ,2)
  23059   "RTN","CHM FA14V",401 ,0)
  23060    I ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW-1,3 )'="" S Y1 =""
  23061   "RTN","CHM FA14V",402 ,0)
  23062    S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW-1,8 )=Y1
  23063   "RTN","CHM FA14V",403 ,0)
  23064    D CURSAV
  23065   "RTN","CHM FA14V",404 ,0)
  23066    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX,DY=DY- 1
  23067   "RTN","CHM FA14V",405 ,0)
  23068    X XY W $J ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW-1, FLD),U,1), FL)
  23069   "RTN","CHM FA14V",406 ,0)
  23070    D CURRES
  23071   "RTN","CHM FA14V",407 ,0)
  23072    X XY
  23073   "RTN","CHM FA14V",408 ,0)
  23074    Q
  23075   "RTN","CHM FA14V",409 ,0)
  23076   RPTMLT ;RE PEAT GROUP  OF LINES    ;JEH 2/1 /11 DEV007 820
  23077   "RTN","CHM FA14V",410 ,0)
  23078    N RPRW,RP NM,RWSV,RW DX,RWSV,RC OL,START,R OW1,CTR,AF LD
  23079   "RTN","CHM FA14V",411 ,0)
  23080    Q:$E(Y,1, 1)'="R"
  23081   "RTN","CHM FA14V",412 ,0)
  23082    ;I $E(CHM FPDI,8,9)' ="03" S RP FLG="" Q    ;ONLY ALL OW CHAMPVA  STANDARD  {03} TO RE PEAT LINES
  23083   "RTN","CHM FA14V",413 ,0)
  23084    K:$D(^UTI LITY($J,"R CHDME")) ^ UTILITY($J ,"RCHDME")
  23085   "RTN","CHM FA14V",414 ,0)
  23086    S RPNM=$E (Y,2,$L(Y) )
  23087   "RTN","CHM FA14V",415 ,0)
  23088    I '$D(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,1)) S RPF LG=1,Y=""  Q
  23089   "RTN","CHM FA14V",416 ,0)
  23090    S START=0
  23091   "RTN","CHM FA14V",417 ,0)
  23092    S LSTRW=9 9999 S LST RW=$O(^UTI LITY($J,"C HDME",FMDO S,BEN,LSTR W),-1)
  23093   "RTN","CHM FA14V",418 ,0)
  23094    S ROW1=0  F  S ROW1= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1))  Q:'ROW1  D
  23095   "RTN","CHM FA14V",419 ,0)
  23096    .S RWDX=$ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW1,3), "^",1)
  23097   "RTN","CHM FA14V",420 ,0)
  23098    .S RWSV=$ P($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, 5),"^",1), "*",2)
  23099   "RTN","CHM FA14V",421 ,0)
  23100    .Q:RWDX=" "&(RWSV="" )
  23101   "RTN","CHM FA14V",422 ,0)
  23102    .F RCOL=0 :1:18 D
  23103   "RTN","CHM FA14V",423 ,0)
  23104    ..I RCOL= 0 S ^UTILI TY($J,"RCH DME",FMDOS ,BEN,LSTRW +ROW1,RCOL )=^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW1,RCO L)+LSTRW
  23105   "RTN","CHM FA14V",424 ,0)
  23106    ..E  S ^U TILITY($J, "RCHDME",F MDOS,BEN,L STRW+ROW1, RCOL)=^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,RCOL)
  23107   "RTN","CHM FA14V",425 ,0)
  23108    .S START= ROW1+1         ;START  ROW
  23109   "RTN","CHM FA14V",426 ,0)
  23110    I START=0  S SFLD=1  Q
  23111   "RTN","CHM FA14V",427 ,0)
  23112    S ROW1=ST ART
  23113   "RTN","CHM FA14V",428 ,0)
  23114    F CTR=1:1 :RPNM D
  23115   "RTN","CHM FA14V",429 ,0)
  23116    .S RRW=0  F  S RRW=$ O(^UTILITY ($J,"RCHDM E",FMDOS,B EN,RRW)) Q :'RRW  D
  23117   "RTN","CHM FA14V",430 ,0)
  23118    ..F FLD=0 :1:18 D
  23119   "RTN","CHM FA14V",431 ,0)
  23120    ...I FLD= 0 S ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD)=ROW1
  23121   "RTN","CHM FA14V",432 ,0)
  23122    ...E  S ^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW1,FLD)=^ UTILITY($J ,"RCHDME", FMDOS,BEN, RRW,FLD)
  23123   "RTN","CHM FA14V",433 ,0)
  23124    ..S ROW1= ROW1+1
  23125   "RTN","CHM FA14V",434 ,0)
  23126    I '$D(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,0)) D
  23127   "RTN","CHM FA14V",435 ,0)
  23128    .F FLD=0: 1:18 D
  23129   "RTN","CHM FA14V",436 ,0)
  23130    ..I FLD=0  S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D)=ROW1 Q
  23131   "RTN","CHM FA14V",437 ,0)
  23132    ..I FLD<3  S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D)=^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1-1, FLD) Q
  23133   "RTN","CHM FA14V",438 ,0)
  23134    ..I FLD=7  S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D)=1 Q
  23135   "RTN","CHM FA14V",439 ,0)
  23136    ..I FLD>2  S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D)="" Q
  23137   "RTN","CHM FA14V",440 ,0)
  23138    D INIT,RE DISP
  23139   "RTN","CHM FA14V",441 ,0)
  23140    S RPTFLG= ""
  23141   "RTN","CHM FA14V",442 ,0)
  23142    Q
  23143   "RTN","CHM FA14V",443 ,0)
  23144   UBNDL ;UN- BUNDLE LIN ES   ;JEH  2/1/11 DEV 007820
  23145   "RTN","CHM FA14V",444 ,0)
  23146    N UBROW,R PNM,RWDT,R WDX,RWSV,R COL,START, ROW1,CTR,A FLD,LSTRW
  23147   "RTN","CHM FA14V",445 ,0)
  23148    Q:$E(Y,1, 1)'="U"
  23149   "RTN","CHM FA14V",446 ,0)
  23150    I Y'?1.1A 1.N1" "1.N  S Y=Y_" 1 "
  23151   "RTN","CHM FA14V",447 ,0)
  23152    K:$D(^UTI LITY($J,"R CHDME")) ^ UTILITY($J ,"RCHDME")
  23153   "RTN","CHM FA14V",448 ,0)
  23154    S UBROW=$ E($P(Y," " ,1),2,$L(Y ))
  23155   "RTN","CHM FA14V",449 ,0)
  23156    S RPNM=$P (Y," ",2)
  23157   "RTN","CHM FA14V",450 ,0)
  23158    I '$D(^UT ILITY($J," CHDME",FMD OS,BEN,UBR OW,1)) S R PFLG=1,Y=" " Q
  23159   "RTN","CHM FA14V",451 ,0)
  23160    S LSTRW=9 9999 S LST RW=$O(^UTI LITY($J,"C HDME",FMDO S,BEN,LSTR W),-1)
  23161   "RTN","CHM FA14V",452 ,0)
  23162    S RWDX=$P (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,UBROW,3), "^",1)
  23163   "RTN","CHM FA14V",453 ,0)
  23164    S RWSV=$P ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,UBROW, 5),"^",1), "*",2)
  23165   "RTN","CHM FA14V",454 ,0)
  23166    Q:RWDX="" &(RWSV="")
  23167   "RTN","CHM FA14V",455 ,0)
  23168    F RCOL=0: 1:18 D
  23169   "RTN","CHM FA14V",456 ,0)
  23170    .I RCOL=0  S ^UTILIT Y($J,"RCHD ME",FMDOS, BEN,LSTRW+ UBROW,RCOL )=^UTILITY ($J,"CHDME ",FMDOS,BE N,UBROW,RC OL)+LSTRW
  23171   "RTN","CHM FA14V",457 ,0)
  23172    .E  S ^UT ILITY($J," RCHDME",FM DOS,BEN,LS TRW+UBROW, RCOL)=^UTI LITY($J,"C HDME",FMDO S,BEN,UBRO W,RCOL)
  23173   "RTN","CHM FA14V",458 ,0)
  23174    S ROW1=LS TRW
  23175   "RTN","CHM FA14V",459 ,0)
  23176    F CTR=1:1 :RPNM D
  23177   "RTN","CHM FA14V",460 ,0)
  23178    .S RRW=0  F  S RRW=$ O(^UTILITY ($J,"RCHDM E",FMDOS,B EN,RRW)) Q :'RRW  D
  23179   "RTN","CHM FA14V",461 ,0)
  23180    ..F FLD=0 :1:18 D
  23181   "RTN","CHM FA14V",462 ,0)
  23182    ...I FLD= 0 S ^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD)=ROW1
  23183   "RTN","CHM FA14V",463 ,0)
  23184    ...E  S ^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW1,FLD)=^ UTILITY($J ,"RCHDME", FMDOS,BEN, RRW,FLD)
  23185   "RTN","CHM FA14V",464 ,0)
  23186    ..S ROW1= ROW1+1
  23187   "RTN","CHM FA14V",465 ,0)
  23188    I '$D(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,0)) D
  23189   "RTN","CHM FA14V",466 ,0)
  23190    .F FLD=0: 1:18 D
  23191   "RTN","CHM FA14V",467 ,0)
  23192    ..I FLD=0  S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D)=ROW1 Q
  23193   "RTN","CHM FA14V",468 ,0)
  23194    ..I FLD<3  S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D)=^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1-1, FLD) Q
  23195   "RTN","CHM FA14V",469 ,0)
  23196    ..I FLD=7  S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D)=1 Q
  23197   "RTN","CHM FA14V",470 ,0)
  23198    ..I FLD>2  S ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D)="" Q
  23199   "RTN","CHM FA14V",471 ,0)
  23200    D INIT,RE DISP
  23201   "RTN","CHM FA14V",472 ,0)
  23202    S RPTFLG= ""
  23203   "RTN","CHM FA14V",473 ,0)
  23204    Q
  23205   "RTN","CHM FA14V",474 ,0)
  23206   REDISP ;RE -DISPLAY S CREEN
  23207   "RTN","CHM FA14V",475 ,0)
  23208    S DY=CHSD Y-1 F ROW1 =1:1:CHLR  D
  23209   "RTN","CHM FA14V",476 ,0)
  23210    .S DY=DY+ 1 I DY=(CH SDY+CHWIN)  D
  23211   "RTN","CHM FA14V",477 ,0)
  23212    .. S DY=C HSDY+CHWIN -1,CHWINLR =CHWINLR+1 ,CHWINHR=C HWINHR+1
  23213   "RTN","CHM FA14V",478 ,0)
  23214    .. S DX=1 ,$X=DX X X Y W !
  23215   "RTN","CHM FA14V",479 ,0)
  23216    .; CCSE C PE005-009  GEF 5/2/17  - add ori ginal PDI  charge lin es if freq  code=5 an d display  in bold
  23217   "RTN","CHM FA14V",480 ,0)
  23218    .; Check  the line n umber wher e the late  charges e nd and the  original  charges af ter that s hould disp lay differ ently
  23219   "RTN","CHM FA14V",481 ,0)
  23220    .I $D(^UT ILITY($J," CHDME",FMD OS,BEN,"BL ")) W:ROW1 >$G(^UTILI TY($J,"CHD ME",FMDOS, BEN,"BL"))  @CHBON
  23221   "RTN","CHM FA14V",482 ,0)
  23222    .F FLD=0: 1:8,16 D F LDLNG S DX =CFDX,$X=D X X XY D
  23223   "RTN","CHM FA14V",483 ,0)
  23224    ..;I FLD= 2 D CHKPOS  Q   ;JEH  8/1/13 DEV 007820 - P OST SLA FI X
  23225   "RTN","CHM FA14V",484 ,0)
  23226    ..;JEH 11 /12/13 DEF 019382 - A DD $D CHEC K
  23227   "RTN","CHM FA14V",485 ,0)
  23228    ..Q:'$D(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW1,FLD))
  23229   "RTN","CHM FA14V",486 ,0)
  23230    ..;JSG;01 /31/08;DEV 003956;Sho uld no lon ger error  with UNDEF
  23231   "RTN","CHM FA14V",487 ,0)
  23232    ..Q:^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD)=""
  23233   "RTN","CHM FA14V",488 ,0)
  23234    ..I FLD=8 !(FLD=16)  I $P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1)' ="" W $J($ FN($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),U,1) ,"",2),FL)  Q  ;aeb 1 /10/2008 D EF003367 a dded to sh ow rev cod e
  23235   "RTN","CHM FA14V",489 ,0)
  23236    ..I FLD=5  X XY W $J ($P($P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,FLD),"*" ,2),U,1),F L) Q   ;JE H 2/1/11 D EV007820
  23237   "RTN","CHM FA14V",490 ,0)
  23238    ..I FLD=6  D  Q   ;J EH 2/1/11  DEV007820
  23239   "RTN","CHM FA14V",491 ,0)
  23240    ...I $L($ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW1,FLD ),"*",1))> 4 D
  23241   "RTN","CHM FA14V",492 ,0)
  23242    ....W $J( "*"_$E($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW1,FLD), "*",1),1,4 ),5)
  23243   "RTN","CHM FA14V",493 ,0)
  23244    ...E  W $ J($E($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W1,FLD),"* ",1),1,4), 5)
  23245   "RTN","CHM FA14V",494 ,0)
  23246    ..I FLD=7 &($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1)[ ".") D CHK UNT Q    ; JEH 2/1/11  DEV007820
  23247   "RTN","CHM FA14V",495 ,0)
  23248    ..W @CHEO L,$J($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W1,FLD),U, 1),FL)
  23249   "RTN","CHM FA14V",496 ,0)
  23250    .;JSG;01/ 31/08;DEV0 03956-02;I f DOS="",  stop displ ay and ask  user to d eal with i t
  23251   "RTN","CHM FA14V",497 ,0)
  23252    .I $D(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,1)) D NO DOS:$E($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW1,1),U) )="_"    ; If "__/__/ __", then  no DOS  ;J EH 11/12/1 3 DEF01938 2 - ADD $D  CHECK
  23253   "RTN","CHM FA14V",498 ,0)
  23254    W @CHBOFF
  23255   "RTN","CHM FA14V",499 ,0)
  23256    D CHSMT(8 )   ;CHECK /DISPLAY T OTALS
  23257   "RTN","CHM FA14V",500 ,0)
  23258    D CHSMT(1 6)   ;CHEC K/DISPLAY  TOTALS
  23259   "RTN","CHM FA14V",501 ,0)
  23260    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  23261   "RTN","CHM FA14V",502 ,0)
  23262    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1
  23263   "RTN","CHM FA14V",503 ,0)
  23264    S SFLD=1
  23265   "RTN","CHM FA14V",504 ,0)
  23266    Q
  23267   "RTN","CHM FA14V",505 ,0)
  23268    ;
  23269   "RTN","CHM FA14V",506 ,0)
  23270   RDPLYPR ;R EDISPLAY P /R TOTALS
  23271   "RTN","CHM FA14V",507 ,0)
  23272    Q:$D(RPFL G)
  23273   "RTN","CHM FA14V",508 ,0)
  23274    N RDY,RCH SDY,RROW1, RCHLR,RCHW IN,RCHWINL R,RCHWINHR ,RDX,RFLD
  23275   "RTN","CHM FA14V",509 ,0)
  23276    S RDY=DY, RCHSDY=CHS DY,RCHLR=C HLR,RCHWIN =CHWIN,RCH WINLR=CHWI NLR,RCHWIN HR=CHWINHR ,RDX=DX,RF LD=FLD
  23277   "RTN","CHM FA14V",510 ,0)
  23278    N ROWCTR
  23279   "RTN","CHM FA14V",511 ,0)
  23280    S ROWCTR= CHWINHR
  23281   "RTN","CHM FA14V",512 ,0)
  23282    S FLD=16  D FLDLNG S  DX=CFDX,$ X=DX X XY
  23283   "RTN","CHM FA14V",513 ,0)
  23284    I ROWCTR> CHLR S ROW CTR=CHLR
  23285   "RTN","CHM FA14V",514 ,0)
  23286    S DY=CHSD Y-1 F ROW1 =CHWINLR:1 :ROWCTR D
  23287   "RTN","CHM FA14V",515 ,0)
  23288    .S DY=DY+ 1
  23289   "RTN","CHM FA14V",516 ,0)
  23290    .I $P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,FLD),U,1 )'="" X XY  W $J($FN( $P(^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,FL D),U,1),"" ,2),FL)
  23291   "RTN","CHM FA14V",517 ,0)
  23292    S DY=RDY, CHSDY=RCHS DY,CHLR=RC HLR,CHWIN= RCHWIN,CHW INLR=RCHWI NLR,CHWINH R=RCHWINHR ,DX=RDX,FL D=RFLD
  23293   "RTN","CHM FA14V",518 ,0)
  23294    D FLDLNG  S DX=RDX,$ X=DX,DY=RD Y,$Y=DY X  XY
  23295   "RTN","CHM FA14V",519 ,0)
  23296    Q
  23297   "RTN","CHM FA14V",520 ,0)
  23298   CHKPOS ;CH ECK/DISPLA Y WHEN POS  IS MISSIN G     ;JEH  8/1/13 DE V007820 -  POST FIX
  23299   "RTN","CHM FA14V",521 ,0)
  23300    I CHMFSRV C=4 Q   ;D ME DOESN'T  HAVE POS
  23301   "RTN","CHM FA14V",522 ,0)
  23302    I ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,1) ="DELETED"  Q
  23303   "RTN","CHM FA14V",523 ,0)
  23304    I ^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1,3) ="" I ^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,5)="" I ^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW1,2)=""  Q
  23305   "RTN","CHM FA14V",524 ,0)
  23306    I $P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),U,2) ="" D
  23307   "RTN","CHM FA14V",525 ,0)
  23308    .W @CHBLN KON,$J(" ?  ",FL),@CH BLNKOFF
  23309   "RTN","CHM FA14V",526 ,0)
  23310    .D CURSAV ^CHMFA141, ERAMSG^CHM FA141:MSGF LG,MARMES^ CHMFA141 S  IOSL=3,DX =1,$X=DX,D Y=CHMDY X  XY
  23311   "RTN","CHM FA14V",527 ,0)
  23312    .W !?2,@C HBLNKON,"* ** ISSUE * **",@CHBLN KOFF," - P LEASE CHEC K 'POS' CO LUMN."
  23313   "RTN","CHM FA14V",528 ,0)
  23314    .D MARSCR ^CHMFA141, CURRES^CHM FA141 S IO SL=9,MSGFL G=1
  23315   "RTN","CHM FA14V",529 ,0)
  23316    E  D
  23317   "RTN","CHM FA14V",530 ,0)
  23318    .W @CHEOL ,$J($P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,FLD),U,1 ),FL)
  23319   "RTN","CHM FA14V",531 ,0)
  23320    Q
  23321   "RTN","CHM FA14V",532 ,0)
  23322   CHKUNT ;CH ECK/DISPLA Y WHEN UNI TS ARE NOT  WHOLE NUM BER     ;J EH 2/1/11  DEV007820
  23323   "RTN","CHM FA14V",533 ,0)
  23324    I $P($P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW1,5),U), "*")="RX"  W $J($P(^U TILITY($J, "CHDME",FM DOS,BEN,RO W1,FLD),U, 1),FL) Q
  23325   "RTN","CHM FA14V",534 ,0)
  23326    E  I $L($ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW1,FLD ),U,1))<3  W @CHBLNKO N,"-->",@C HBLNKOFF,"  ",$J($P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW1,FLD),U ,1),3)
  23327   "RTN","CHM FA14V",535 ,0)
  23328    E  W @CHB LNKON,$J($ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW1,FLD ),U,1),FL) ,@CHBLNKOF F
  23329   "RTN","CHM FA14V",536 ,0)
  23330    D CURSAV^ CHMFA141,E RAMSG^CHMF A141:MSGFL G,MARMES^C HMFA141 S  IOSL=3,DX= 1,$X=DX,DY =CHMDY X X Y
  23331   "RTN","CHM FA14V",537 ,0)
  23332    W !?2,@CH BLNKON,"** * ISSUE ** *",@CHBLNK OFF," - PL EASE CHECK  'UNT/QTY'  COLUMN."
  23333   "RTN","CHM FA14V",538 ,0)
  23334    D MARSCR^ CHMFA141,C URRES^CHMF A141 S IOS L=9,MSGFLG =1
  23335   "RTN","CHM FA14V",539 ,0)
  23336    Q
  23337   "RTN","CHM FA14V",540 ,0)
  23338   NODOS ;JSG ;01/31/08; DEV003956- 02;Ask use r to deal  with recor ds with no  DOS
  23339   "RTN","CHM FA14V",541 ,0)
  23340    D F1HELP^ CHMFA142                                        ;Displ ay "Enter  DOS" messa ge
  23341   "RTN","CHM FA14V",542 ,0)
  23342    ;
  23343   "RTN","CHM FA14V",543 ,0)
  23344   NOJOY S FL D=1,ROW=RO W1 D FLDLN G                              ; Set field,  row & fie ld length
  23345   "RTN","CHM FA14V",544 ,0)
  23346         S DX =CFDX,$X=D X X XY D C SBRS^CHSC2                     ; Position o n field an d READ Y
  23347   "RTN","CHM FA14V",545 ,0)
  23348         I $D (DFOUT) W  *7 G NOJOY
  23349   "RTN","CHM FA14V",546 ,0)
  23350         I $D (DUOUT) W  *7 G NOJOY
  23351   "RTN","CHM FA14V",547 ,0)
  23352         D GE TF1^CHMFA1 42                                        ; Process us er entry
  23353   "RTN","CHM FA14V",548 ,0)
  23354         I Y= ""!(Y=-1)  X XY W $P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW1,1),U)  G NOJOY ; Entry no g ood
  23355   "RTN","CHM FA14V",549 ,0)
  23356         I $E (Y)="@" S  ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW1,8)=""      ;"@"= delete rec ord, so ze ro $$s
  23357   "RTN","CHM FA14V",550 ,0)
  23358         E  S  ^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW1,1)=Y                 ;Rese t DOS node , if not d eleted
  23359   "RTN","CHM FA14V",551 ,0)
  23360         X XY  W $J($P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW1,1),U), FL)  ;WRIT E updated  field on s creen
  23361   "RTN","CHM FA14V",552 ,0)
  23362         D CU RSAV,ERAMS G,CURRES                                  ; Clear "Ent er DOS" me ssage
  23363   "RTN","CHM FA14V",553 ,0)
  23364         Q                                                         ; Go finish  procedure  display
  23365   "RTN","CHM FA14V",554 ,0)
  23366    ;
  23367   "RTN","CHM FA14V",555 ,0)
  23368   EXIT D CUR SAV,ERAMSG
  23369   "RTN","CHM FA14V",556 ,0)
  23370   E1 D PRMPT ^CHMFA140, ASK^CHMFA1 40
  23371   "RTN","CHM FA14V",557 ,0)
  23372    I $D(DFOU T)!$D(DUOU T) G E1
  23373   "RTN","CHM FA14V",558 ,0)
  23374    K CHMFNEX T,CHMFPREV ,CHMFKILL, CHMFNEWB,C HMFOPRX
  23375   "RTN","CHM FA14V",559 ,0)
  23376    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
  23377   "RTN","CHM FA14V",560 ,0)
  23378    I Y=2&('$ D(DDOUT))  D
  23379   "RTN","CHM FA14V",561 ,0)
  23380    .D CURSV4
  23381   "RTN","CHM FA14V",562 ,0)
  23382    .I $$PSCH K^CHMFAUT3 ()=1 S Y=1  Q  ;JEH 8 /1/13  ;AD DED MISSIN G POS CHEC K
  23383   "RTN","CHM FA14V",563 ,0)
  23384    .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
  23385   "RTN","CHM FA14V",564 ,0)
  23386    .D CURRE4  D FLDLNG
  23387   "RTN","CHM FA14V",565 ,0)
  23388    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
  23389   "RTN","CHM FA14V",566 ,0)
  23390    I Y=3 D R STOR^CHMFA UT3("S",2)            ;JEH 2/1/1 1 DEV00782 0 - CALL R ESTORE FUN CTION (SAV E)
  23391   "RTN","CHM FA14V",567 ,0)
  23392    I Y=5 D   Q
  23393   "RTN","CHM FA14V",568 ,0)
  23394    .S UMIO=" O" D ^CHMF A14O,ERAMS G,MARSCR
  23395   "RTN","CHM FA14V",569 ,0)
  23396    .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
  23397   "RTN","CHM FA14V",570 ,0)
  23398    .D INIT^C HMFA140,SE TSCR^CHMFA 140,INIT,R EDISP
  23399   "RTN","CHM FA14V",571 ,0)
  23400    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
  23401   "RTN","CHM FA14V",572 ,0)
  23402    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
  23403   "RTN","CHM FA14V",573 ,0)
  23404    I Y=9 D ^ CHMFA02B,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV     ;OPT-O HI EDIT
  23405   "RTN","CHM FA14V",574 ,0)
  23406    I Y=10 D
  23407   "RTN","CHM FA14V",575 ,0)
  23408    .I '$D(^U TILITY("RE STORE",$J) ) D
  23409   "RTN","CHM FA14V",576 ,0)
  23410    ..D CURSV 2
  23411   "RTN","CHM FA14V",577 ,0)
  23412    ..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
  23413   "RTN","CHM FA14V",578 ,0)
  23414    ..D INIT^ CHMFA140,S ETSCR^CHMF A140,INIT, REDISP
  23415   "RTN","CHM FA14V",579 ,0)
  23416    ..D CURRE 2 D FLDLNG
  23417   "RTN","CHM FA14V",580 ,0)
  23418    .E  D
  23419   "RTN","CHM FA14V",581 ,0)
  23420    ..D RSTOR ^CHMFAUT3( "R",CHMFSR VC),ERAMSG ,MARSCR
  23421   "RTN","CHM FA14V",582 ,0)
  23422    ..S RSTFL =1
  23423   "RTN","CHM FA14V",583 ,0)
  23424    ..K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  23425   "RTN","CHM FA14V",584 ,0)
  23426    ..D INIT^ CHMFA140,S ETSCR^CHMF A140,INIT, REDISP
  23427   "RTN","CHM FA14V",585 ,0)
  23428    ..D CURSA V,CURRES,F LDLNG
  23429   "RTN","CHM FA14V",586 ,0)
  23430    ..I $$POS CHK^CHMFAU T3()=1 D I NIT^CHMFA1 40,SETSCR^ CHMFA140,I NIT,REDISP    ;CHECK  FOR MISSIN G POS
  23431   "RTN","CHM FA14V",587 ,0)
  23432    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
  23433   "RTN","CHM FA14V",588 ,0)
  23434    .;REMOVE  THE NFOR L OOP, NO LO NGER NEEDE D IF NOT A SKING THE  QUESTION
  23435   "RTN","CHM FA14V",589 ,0)
  23436    .;F  D  Q :Y'=""  Q: "YNyn"'[Y   ;; DRW/JA K
  23437   "RTN","CHM FA14V",590 ,0)
  23438    .;.S HY=D Y,HX=DX,DY =19,DX=20, $X=DX X XY   ;; DRW/J AK
  23439   "RTN","CHM FA14V",591 ,0)
  23440    .;.W "Are  you sure  you want t o continue : " D CSBR S^CHSC2  ; ;DRW/JAK
  23441   "RTN","CHM FA14V",592 ,0)
  23442    .;.Q  ;;D RW/JAK .I  $D(DUOUT)  K CHMFNEXT  Q
  23443   "RTN","CHM FA14V",593 ,0)
  23444    .;I $D(DF OUT) K CHM FNEXT Q
  23445   "RTN","CHM FA14V",594 ,0)
  23446    .;I "Nn"[ Y K CHMFNE XT S DY=HY ,DX=HX,$X= DX Q
  23447   "RTN","CHM FA14V",595 ,0)
  23448    .;RESUME  HERE after  removing  continue p rompt
  23449   "RTN","CHM FA14V",596 ,0)
  23450    .Q:'$D(^C HMIMAGE(CH MFPDI,1,1, 2,1,"VEN") )
  23451   "RTN","CHM FA14V",597 ,0)
  23452    .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
  23453   "RTN","CHM FA14V",598 ,0)
  23454    .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
  23455   "RTN","CHM FA14V",599 ,0)
  23456    .S ROW=0, CHPOS=0 F   S ROW=$O( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW)) Q:'R OW!(CHPOS= 50)  D
  23457   "RTN","CHM FA14V",600 ,0)
  23458    ..I ROW=" " S DY=HY, DX=HX,$X=D X Q
  23459   "RTN","CHM FA14V",601 ,0)
  23460    ..S CHPOS =$P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,2) ,U,2)
  23461   "RTN","CHM FA14V",602 ,0)
  23462    .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
  23463   "RTN","CHM FA14V",603 ,0)
  23464    ..F  D  Q :(RANS="AS C"!(RANS=" OP")!(RANS ="NA"))  ; ;DRW/JAK
  23465   "RTN","CHM FA14V",604 ,0)
  23466    ...S TX=2 5,TY=9,BX= 75,BY=20,V ON="",VOFF ="" D BOXF ^CHSC1(TX, TY,BX,BY)
  23467   "RTN","CHM FA14V",605 ,0)
  23468    ...D CLRB OXI^CHSC1( TX,TY,BX,B Y,XY,VON,V OFF)
  23469   "RTN","CHM FA14V",606 ,0)
  23470    ...S DY=1 0,DX=26 X  XY W "PLEA SE CHECK P OS SELECTI ON:"
  23471   "RTN","CHM FA14V",607 ,0)
  23472    ...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
  23473   "RTN","CHM FA14V",608 ,0)
  23474    ...S DY=1 2,DX=26 X  XY W " "
  23475   "RTN","CHM FA14V",609 ,0)
  23476    ...S DY=1 3,DX=26 X  XY W " Cho ose POS (A SC=24, "
  23477   "RTN","CHM FA14V",610 ,0)
  23478    ...S DY=1 4,DX=26 X  XY W "OP=2 2(ON CAMPU S) OR 19 ( OFF CAMPUS ), NA=00):  " D CSBRS ^CHSC2   ; ;DPT 2/24/ 16 DEV2419 4-02 DRW/J AK 5/17/10 ;DEV007600  change di splay to A SC or OP
  23479   "RTN","CHM FA14V",611 ,0)
  23480    ...S Y=$$ UP^XLFSTR( Y)         ;;TT 10291  JAK/DRW 0 8/03/10 sa ve return  value in Y  to (upper case)
  23481   "RTN","CHM FA14V",612 ,0)
  23482    ...I Y="0 0"!(Y="NA" ) S RANS=" NA"             ;;TT  10291 JAK/ DRW 08/03/ 10
  23483   "RTN","CHM FA14V",613 ,0)
  23484    ...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 
  23485   "RTN","CHM FA14V",614 ,0)
  23486    ...I RANS ="ASC"!(RA NS="OP") D  RESET  ;; DRW/JAK
  23487   "RTN","CHM FA14V",615 ,0)
  23488    ...S ASCS W=1
  23489   "RTN","CHM FA14V",616 ,0)
  23490    ...Q  ;;D RW/JAK
  23491   "RTN","CHM FA14V",617 ,0)
  23492    ..S $P(ST R," ",59)= ""                  ; DRW/JAK BU G010291-05 -02 clear  out the po s descript ion after  popup goes  away
  23493   "RTN","CHM FA14V",618 ,0)
  23494    ..S DX=20 ,$X=DX F D Y=9:1:20 X  XY W @CHE OL  ;;DRW/ JAK
  23495   "RTN","CHM FA14V",619 ,0)
  23496    ..S DX=1, $X=DX,DY=1 5 X XY W S TR X XY  ; JAK
  23497   "RTN","CHM FA14V",620 ,0)
  23498    ..S CHMFN EXT=""
  23499   "RTN","CHM FA14V",621 ,0)
  23500    ..S DX=1, DY=16 X XY  W "------ ---------- ---------- ---------- ---------- ---------- ---------- ---------- ----"  ;;D RW/JAK
  23501   "RTN","CHM FA14V",622 ,0)
  23502    ..Q  ;; D RW/JAK
  23503   "RTN","CHM FA14V",623 ,0)
  23504    .K:$D(^UT ILITY("RES TORE",$J))  ^UTILITY( "RESTORE", $J)
  23505   "RTN","CHM FA14V",624 ,0)
  23506    .Q   ;; D RW/JAK
  23507   "RTN","CHM FA14V",625 ,0)
  23508    D CURRES  D FLDLNG
  23509   "RTN","CHM FA14V",626 ,0)
  23510    K CHKFLG    ;JEH 9/1 3/13 - ENC 004389 
  23511   "RTN","CHM FA14V",627 ,0)
  23512    Q
  23513   "RTN","CHM FA14V",628 ,0)
  23514   DOWN D CUR SAV
  23515   "RTN","CHM FA14V",629 ,0)
  23516    I $P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, 1),U)'="DE LETED"&($P (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW,3),U) ="")&($P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW,4),U)=" ")&($P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,5),U)="") &($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW,6 ),U)="") D  BEEPQ G D OWNEND
  23517   "RTN","CHM FA14V",630 ,0)
  23518    I $P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, 1),U)="DEL ETED",'$D( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW+1)) D  BEEPQ G DO WNEND ;JSG ;2/29/08;B UG003956-0 4;Handle d own arrow  with delet ed record
  23519   "RTN","CHM FA14V",631 ,0)
  23520    I FLD>5 D    ;JEH 2/ 1/11 DEV00 7820
  23521   "RTN","CHM FA14V",632 ,0)
  23522    .D CURSAV ,CLRLN,CUR RES   ;JEH  2/1/11 DE V007820
  23523   "RTN","CHM FA14V",633 ,0)
  23524    I $D(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW+ 1,5)) I FL D=6&($P($P (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW+1,5), U),"*")="R X") S CHCF =FLD,DY=DY +1,ROW=ROW +1    ;JEH  2/1/11 DE V007820
  23525   "RTN","CHM FA14V",634 ,0)
  23526    S CHCF=FL D,DY=DY+1, ROW=ROW+1
  23527   "RTN","CHM FA14V",635 ,0)
  23528    I '$D(^UT ILITY($J," CHDME",FMD OS,BEN,ROW )) D NEWRO W
  23529   "RTN","CHM FA14V",636 ,0)
  23530    I DY=(CHS DY+CHWIN)  D UPSCRL
  23531   "RTN","CHM FA14V",637 ,0)
  23532    D STAFLG    ;JEH 1/2 3/07
  23533   "RTN","CHM FA14V",638 ,0)
  23534   DOWNEND Q
  23535   "RTN","CHM FA14V",639 ,0)
  23536   NEWROW ;
  23537   "RTN","CHM FA14V",640 ,0)
  23538    S FMDOS=$ $DT^XLFDT 
  23539   "RTN","CHM FA14V",641 ,0)
  23540    F FLD=0:1 :18 S ^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, FLD)="" S: FLD=7 ^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, FLD)=1        ;JEH 2/ 1/11 DEV00 7820  CHG  0:1:8 TO 0 :1:17
  23541   "RTN","CHM FA14V",642 ,0)
  23542    I $D(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW- 1)) S ^UTI LITY($J,"C HDME",FMDO S,BEN,ROW, 1)=^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW-1,1 ),^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW,2)=^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW-1,2)
  23543   "RTN","CHM FA14V",643 ,0)
  23544    S CHLR=RO W
  23545   "RTN","CHM FA14V",644 ,0)
  23546    Q
  23547   "RTN","CHM FA14V",645 ,0)
  23548   UP D CURSA V
  23549   "RTN","CHM FA14V",646 ,0)
  23550    I FLD>5 D    ;JEH 2/ 1/11 DEV00 7820
  23551   "RTN","CHM FA14V",647 ,0)
  23552    .D CURSAV ,CLRLN,CUR RES   ;JEH  2/1/11 DE V007820
  23553   "RTN","CHM FA14V",648 ,0)
  23554    I FLD=6&( $P($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW- 1,5),U),"* ")="RX") S :ROW-1'=1  CHCF=FLD,D Y=DY-1,ROW =ROW-1        ;JEH 2/ 1/11 DEV00 7820
  23555   "RTN","CHM FA14V",649 ,0)
  23556    S CHCF=FL D,DY=DY-1, ROW=ROW-1
  23557   "RTN","CHM FA14V",650 ,0)
  23558    I DY<CHSD Y D DNSCRL
  23559   "RTN","CHM FA14V",651 ,0)
  23560    D STAFLG    ;JEH 1/2 3/07
  23561   "RTN","CHM FA14V",652 ,0)
  23562    Q
  23563   "RTN","CHM FA14V",653 ,0)
  23564   DNSCRL S D Y=CHSDY,CH WINLR=CHWI NLR-1,CHWI NHR=CHWINH R-1
  23565   "RTN","CHM FA14V",654 ,0)
  23566    S ROW1=CH WINLR-1
  23567   "RTN","CHM FA14V",655 ,0)
  23568   DN1 S ROW1 =$O(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1))  G:'ROW1 D N2  G:ROW1 >CHWINHR D N2
  23569   "RTN","CHM FA14V",656 ,0)
  23570    S DX=1,$X =DX,DY=CHS DY X XY W  @CHINSL
  23571   "RTN","CHM FA14V",657 ,0)
  23572    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23573   "RTN","CHM FA14V",658 ,0)
  23574    .I $P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,FLD),"*" ,1)="" W $ J($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1), FL) Q
  23575   "RTN","CHM FA14V",659 ,0)
  23576    .I FLD=8! (FLD=16) I  $P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),U,1)'= "" W $J($F N($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1), "",2),FL)  Q  ;aeb 1/ 10/2008 DE F003367 ad ded to sho w rev code
  23577   "RTN","CHM FA14V",660 ,0)
  23578    .I FLD=5  X XY W $J( $P($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),"*", 2),U,1),FL ) Q   ;JEH  2/1/11 DE V007820
  23579   "RTN","CHM FA14V",661 ,0)
  23580    .I FLD=6  X XY W $J( $E($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),"*", 1),1,4),5)  Q   ;JEH  2/1/11 DEV 007820
  23581   "RTN","CHM FA14V",662 ,0)
  23582    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),U,1)[" .") D CHKU NT Q    ;J EH 2/1/11  DEV007820
  23583   "RTN","CHM FA14V",663 ,0)
  23584    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  23585   "RTN","CHM FA14V",664 ,0)
  23586    .W $J($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW1,FLD), U,1),FL)
  23587   "RTN","CHM FA14V",665 ,0)
  23588   DN2 D CURR ES S FLD=C HCF
  23589   "RTN","CHM FA14V",666 ,0)
  23590    Q
  23591   "RTN","CHM FA14V",667 ,0)
  23592   UPSCRL S D Y=CHSDY+CH WIN-1,CHWI NLR=CHWINL R+1,CHWINH R=CHWINHR+ 1
  23593   "RTN","CHM FA14V",668 ,0)
  23594    S ROW1=CH WINHR+1
  23595   "RTN","CHM FA14V",669 ,0)
  23596   UP1 S ROW1 =$O(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1), -1) G:'ROW 1 UP2  G:R OW1<CHWINL R UP2
  23597   "RTN","CHM FA14V",670 ,0)
  23598    S DX=1,$X =DX X XY W  !
  23599   "RTN","CHM FA14V",671 ,0)
  23600    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23601   "RTN","CHM FA14V",672 ,0)
  23602    .I $P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW 1,FLD),"*" ,1)="" W $ J($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1), FL) Q
  23603   "RTN","CHM FA14V",673 ,0)
  23604    .I FLD=8! (FLD=16) I  $P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),U,1)'= "" W $J($F N($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1), "",2),FL)  Q  ;aeb 1/ 10/2008 DE F003367 ad ded to sho w rev code
  23605   "RTN","CHM FA14V",674 ,0)
  23606    .I FLD=5  X XY W $J( $P($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),"*", 2),U,1),FL ) Q   ;JEH  2/1/11 DE V007820
  23607   "RTN","CHM FA14V",675 ,0)
  23608    .I FLD=6  X XY W $J( $E($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),"*", 1),1,4),5)  Q   ;JEH  2/1/11 DEV 007820
  23609   "RTN","CHM FA14V",676 ,0)
  23610    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),U,1)[" .") D CHKU NT Q    ;J EH 2/1/11  DEV007820
  23611   "RTN","CHM FA14V",677 ,0)
  23612    .I FLD=2  D CHKPOS Q   ;JEH 8/1 /13 DEV007 820 - POST  SLA FIX
  23613   "RTN","CHM FA14V",678 ,0)
  23614    .W $J($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW1,FLD), U,1),FL)
  23615   "RTN","CHM FA14V",679 ,0)
  23616   UP2 D CURR ES S FLD=C HCF
  23617   "RTN","CHM FA14V",680 ,0)
  23618    Q
  23619   "RTN","CHM FA14V",681 ,0)
  23620   PREV I CHW INLR<2 W * 7 Q
  23621   "RTN","CHM FA14V",682 ,0)
  23622    S CHCDX=D X,CHCF=FLD
  23623   "RTN","CHM FA14V",683 ,0)
  23624    S CHWINLR =CHWINLR-C HWIN S:CHW INLR<1 CHW INLR=1
  23625   "RTN","CHM FA14V",684 ,0)
  23626    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,RO W1=CHWINLR -1
  23627   "RTN","CHM FA14V",685 ,0)
  23628   P1 S ROW1= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1))  G:'ROW1 P2  G:ROW1>CH WINHR P2
  23629   "RTN","CHM FA14V",686 ,0)
  23630    S DX=1,$X =DX X XY W  @CHEOL
  23631   "RTN","CHM FA14V",687 ,0)
  23632    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23633   "RTN","CHM FA14V",688 ,0)
  23634    .I FLD=8! (FLD=16) I  $P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),U,1)'= "" W $J($F N($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1), "",2),FL)  Q  ;aeb 1/ 10/2008 DE F003367 ad ded to sho w rev code
  23635   "RTN","CHM FA14V",689 ,0)
  23636    .I FLD=5  X XY W $J( $P($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),"*", 2),U,1),FL ) Q   ;JEH  2/1/11 DE V007820
  23637   "RTN","CHM FA14V",690 ,0)
  23638    .I FLD=6  X XY W $J( $E($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),"*", 1),1,4),5)  Q   ;JEH  2/1/11 DEV 007820
  23639   "RTN","CHM FA14V",691 ,0)
  23640    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),U,1)[" .") D CHKU NT Q    ;J EH 2/1/11  DEV007820
  23641   "RTN","CHM FA14V",692 ,0)
  23642    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  23643   "RTN","CHM FA14V",693 ,0)
  23644    .W $J($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW1,FLD), U,1),FL)
  23645   "RTN","CHM FA14V",694 ,0)
  23646    S DY=DY+1  G P1
  23647   "RTN","CHM FA14V",695 ,0)
  23648   P2 S DY=CH SDY,ROW=CH WINLR,DX=C HCDX,$X=DX ,FLD=CHCF
  23649   "RTN","CHM FA14V",696 ,0)
  23650    Q
  23651   "RTN","CHM FA14V",697 ,0)
  23652   NEXT I '$D (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,CHWINHR+1 )) W *7 Q
  23653   "RTN","CHM FA14V",698 ,0)
  23654    S CHCDX=D X,$X=DX,CH CF=FLD
  23655   "RTN","CHM FA14V",699 ,0)
  23656    S CHWINLR =CHWINLR+C HWIN S:CHW INLR<1 CHW INLR=1
  23657   "RTN","CHM FA14V",700 ,0)
  23658    I CHWINLR +CHWIN>CHL R S CHWINL R=CHLR-(CH WIN-1)
  23659   "RTN","CHM FA14V",701 ,0)
  23660    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,RO W1=CHWINLR -1
  23661   "RTN","CHM FA14V",702 ,0)
  23662   N1 S ROW1= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW1))  I 'ROW1 D  CLEAR2 G N 2
  23663   "RTN","CHM FA14V",703 ,0)
  23664    G:ROW1>CH WINHR N2
  23665   "RTN","CHM FA14V",704 ,0)
  23666    S DX=1,$X =DX X XY W  @CHEOL
  23667   "RTN","CHM FA14V",705 ,0)
  23668    F FLD=0:1 :8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23669   "RTN","CHM FA14V",706 ,0)
  23670    .I FLD=8! (FLD=16) I  $P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),U,1)'= "" W $J($F N($P(^UTIL ITY($J,"CH DME",FMDOS ,BEN,ROW1, FLD),U,1), "",2),FL)  Q  ;aeb 1/ 10/2008 DE F003367 ad ded to sho w rev code
  23671   "RTN","CHM FA14V",707 ,0)
  23672    .I FLD=5  X XY W $J( $P($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),"*", 2),U,1),FL ) Q   ;JEH  2/1/11 DE V007820
  23673   "RTN","CHM FA14V",708 ,0)
  23674    .I FLD=6  X XY W $J( $E($P(^UTI LITY($J,"C HDME",FMDO S,BEN,ROW1 ,FLD),"*", 1),1,4),5)  Q   ;JEH  2/1/11 DEV 007820
  23675   "RTN","CHM FA14V",709 ,0)
  23676    .I FLD=7& ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW1,F LD),U,1)[" .") D CHKU NT Q    ;J EH 2/1/11  DEV007820
  23677   "RTN","CHM FA14V",710 ,0)
  23678    .I FLD=2  D CHKPOS Q    ;JEH 8/ 1/13 DEV00 7820 - POS T SLA FIX
  23679   "RTN","CHM FA14V",711 ,0)
  23680    .W $J($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW1,FLD), U,1),FL)
  23681   "RTN","CHM FA14V",712 ,0)
  23682    S DY=DY+1  G N1
  23683   "RTN","CHM FA14V",713 ,0)
  23684   N2 S DY=CH SDY,ROW=CH WINLR,DX=C HCDX,$X=DX ,FLD=CHCF
  23685   "RTN","CHM FA14V",714 ,0)
  23686    Q
  23687   "RTN","CHM FA14V",715 ,0)
  23688   CLEAR2 S H Y=DY,DX=1, $X=DX F DY =HY:1:CHSD Y+CHWIN-1  X XY W @CH EOL
  23689   "RTN","CHM FA14V",716 ,0)
  23690    Q
  23691   "RTN","CHM FA14V",717 ,0)
  23692   CURSAV S C HCDX=DX,CH CDY=DY
  23693   "RTN","CHM FA14V",718 ,0)
  23694    Q
  23695   "RTN","CHM FA14V",719 ,0)
  23696   CURSV2 S C HCDX2=CHCD X,CHCDY2=C HCDY,SVFLD =FLD    ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  23697   "RTN","CHM FA14V",720 ,0)
  23698    Q
  23699   "RTN","CHM FA14V",721 ,0)
  23700   CURSV3 S C HCDX3=CHCD X,CHCDY3=C HCDY,SVFLD 3=FLD   ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  23701   "RTN","CHM FA14V",722 ,0)
  23702    Q
  23703   "RTN","CHM FA14V",723 ,0)
  23704   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
  23705   "RTN","CHM FA14V",724 ,0)
  23706    Q
  23707   "RTN","CHM FA14V",725 ,0)
  23708   CURSV5 S C HCDX5=DX,C HCDY5=DY
  23709   "RTN","CHM FA14V",726 ,0)
  23710    Q
  23711   "RTN","CHM FA14V",727 ,0)
  23712   CURRES S D X=CHCDX,$X =DX,DY=CHC DY
  23713   "RTN","CHM FA14V",728 ,0)
  23714    Q
  23715   "RTN","CHM FA14V",729 ,0)
  23716   CURRE2 S D X=CHCDX2,$ X=DX,DY=CH CDY2,FLD=S VFLD    ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  23717   "RTN","CHM FA14V",730 ,0)
  23718    Q
  23719   "RTN","CHM FA14V",731 ,0)
  23720   CURRE3 S D X=CHCDX3,$ X=DX,DY=CH CDY3,FLD=S VFLD3   ;J EH 2/1/11  DEV00780   ADDED SUBR OUTINE
  23721   "RTN","CHM FA14V",732 ,0)
  23722    Q
  23723   "RTN","CHM FA14V",733 ,0)
  23724   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
  23725   "RTN","CHM FA14V",734 ,0)
  23726    Q
  23727   "RTN","CHM FA14V",735 ,0)
  23728   CURRE5 S D X=CHCDX5,$ X=DX,DY=CH CDY5
  23729   "RTN","CHM FA14V",736 ,0)
  23730    Q
  23731   "RTN","CHM FA14V",737 ,0)
  23732   MARSCR S D TM=CHSDY+1 ,DBM=CHSDY +CHWIN X C HMAR   ;SK D, DTM=CHS DY,DBM=CHS DY+CHWIN-1
  23733   "RTN","CHM FA14V",738 ,0)
  23734    Q
  23735   "RTN","CHM FA14V",739 ,0)
  23736   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
  23737   "RTN","CHM FA14V",740 ,0)
  23738    Q
  23739   "RTN","CHM FA14V",741 ,0)
  23740   ERASCR S D X=1,$X=DX  F DY=CHSDY :1:CHSDY+C HWIN-1 X X Y W @CHEOL
  23741   "RTN","CHM FA14V",742 ,0)
  23742    Q
  23743   "RTN","CHM FA14V",743 ,0)
  23744   ERAMSG S D X=1,$X=DX  F DY=CHMDY :1:20 X XY  W @CHEOL
  23745   "RTN","CHM FA14V",744 ,0)
  23746    Q
  23747   "RTN","CHM FA14V",745 ,0)
  23748   CLRMSG I M SGFLG D CU RSAV,ERAMS G,ERROR,CU RRES S MSG FLG=0
  23749   "RTN","CHM FA14V",746 ,0)
  23750    Q
  23751   "RTN","CHM FA14V",747 ,0)
  23752   CLRLN ;CLE AR & REWRI TE FIELDS  6,7,8,16   ;JEH 2/1/1 1 DEV00780   ADDED SU BROUTINE
  23753   "RTN","CHM FA14V",748 ,0)
  23754    N CLFLD
  23755   "RTN","CHM FA14V",749 ,0)
  23756    S CLFLD=F LD
  23757   "RTN","CHM FA14V",750 ,0)
  23758    ;X XY W @ CHEOL
  23759   "RTN","CHM FA14V",751 ,0)
  23760    Q:'$G(ROW )
  23761   "RTN","CHM FA14V",752 ,0)
  23762    F FLD=6,7 ,8,16 D FL DLNG S DX= CFDX,$X=DX  X XY D
  23763   "RTN","CHM FA14V",753 ,0)
  23764    .I $P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,FLD),"*", 1)="" W $J ($P(^UTILI TY($J,"CHD ME",FMDOS, BEN,ROW,FL D),U,1),FL ) Q
  23765   "RTN","CHM FA14V",754 ,0)
  23766    .I FLD=6  D  Q
  23767   "RTN","CHM FA14V",755 ,0)
  23768    ..I $L($P (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW,FLD), "*",1))>4  D
  23769   "RTN","CHM FA14V",756 ,0)
  23770    ...W $J(" *"_$E($P(^ UTILITY($J ,"CHDME",F MDOS,BEN,R OW,FLD),"* ",1),1,4), 5)
  23771   "RTN","CHM FA14V",757 ,0)
  23772    ..E  W $J ($E($P(^UT ILITY($J," CHDME",FMD OS,BEN,ROW ,FLD),"*", 1),1,4),5)
  23773   "RTN","CHM FA14V",758 ,0)
  23774    .I FLD=8  W $J($FN($ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,ROW,FLD) ,U,1),"",2 ),FL) Q
  23775   "RTN","CHM FA14V",759 ,0)
  23776    .I FLD=16  W $J($FN( $P(^UTILIT Y($J,"CHDM E",FMDOS,B EN,ROW,FLD ),U,1),"", 2),FL) Q
  23777   "RTN","CHM FA14V",760 ,0)
  23778    .W $J($P( ^UTILITY($ J,"CHDME", FMDOS,BEN, ROW,FLD),U ,1),FL) Q
  23779   "RTN","CHM FA14V",761 ,0)
  23780    S FLD=CLF LD
  23781   "RTN","CHM FA14V",762 ,0)
  23782    Q
  23783   "RTN","CHM FA14V",763 ,0)
  23784   ERROR Q
  23785   "RTN","CHM FA14V",764 ,0)
  23786    ;
  23787   "RTN","CHM FA14V",765 ,0)
  23788   STAFLG ;SE T ZANSFLG  BASED ON C ODE TYPE -  ANETHESIA  CODE - 2/ 1/2007
  23789   "RTN","CHM FA14V",766 ,0)
  23790    N ZCDX ;J EH 2/1/11  DEV0078
  23791   "RTN","CHM FA14V",767 ,0)
  23792    S ZCDX=$P (^UTILITY( $J,"CHDME" ,FMDOS,BEN ,ROW,5),U, 2)
  23793   "RTN","CHM FA14V",768 ,0)
  23794    Q:'$D(ZCD X)!(ZCDX=" ")
  23795   "RTN","CHM FA14V",769 ,0)
  23796    I $D(^CHM SERV(ZCDX, 4)) D
  23797   "RTN","CHM FA14V",770 ,0)
  23798    .S ZANSFL G=1
  23799   "RTN","CHM FA14V",771 ,0)
  23800    E  D
  23801   "RTN","CHM FA14V",772 ,0)
  23802    .S ZANSFL G=0
  23803   "RTN","CHM FA14V",773 ,0)
  23804    Q
  23805   "RTN","CHM FA14V",774 ,0)
  23806   RESET ;SET  ASC PLACE  OF SERVIC E TO DO
  23807   "RTN","CHM FA14V",775 ,0)
  23808    ;AEB 9/4/ 2007
  23809   "RTN","CHM FA14V",776 ,0)
  23810    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
  23811   "RTN","CHM FA14V",777 ,0)
  23812    .S TEMPCO DE="ASC",T EMPPOS=50, TEMPDESC=" AMBULATORY  SURGICAL  CENTER (AS C)"   ;DRW /JAK 5/17/ 10;DEV0076 00
  23813   "RTN","CHM FA14V",778 ,0)
  23814    E  D   ;D RW/JAK 5/1 7/10;DEV00 7600
  23815   "RTN","CHM FA14V",779 ,0)
  23816    .S TEMPCO DE="OP",TE MPPOS=2,TE MPDESC="OU TPATIENT H OSPITAL"    ;DRW/JAK  5/17/10;DE V007600
  23817   "RTN","CHM FA14V",780 ,0)
  23818    S TMPROW= 0
  23819   "RTN","CHM FA14V",781 ,0)
  23820   R2 S TMPRO W=$O(^UTIL ITY($J,"CH DME",FMDOS ,BEN,TMPRO W)) G:TMPR OW="" R3
  23821   "RTN","CHM FA14V",782 ,0)
  23822    S CHPOS=$ P(^UTILITY ($J,"CHDME ",FMDOS,BE N,TMPROW,2 ),U,2)
  23823   "RTN","CHM FA14V",783 ,0)
  23824    S $P(^UTI LITY($J,"C HDME",FMDO S,BEN,TMPR OW,2),U,1) =TEMPCODE     ;;DRW/J AK 5/17/10 ;DEV007600  ASC or OP
  23825   "RTN","CHM FA14V",784 ,0)
  23826    S $P(^UTI LITY($J,"C HDME",FMDO S,BEN,TMPR OW,2),U,2) =TEMPPOS      ;;DRW/J AK 5/17/10 ;DEV007600  2(OP) or  50(ASC)
  23827   "RTN","CHM FA14V",785 ,0)
  23828    S $P(^UTI LITY($J,"C HDME",FMDO S,BEN,TMPR OW,2),U,3) =TEMPDESC     ;;DRW/J AK 5/17/10 ;DEV007600  descripti on for ASC  or OP
  23829   "RTN","CHM FA14V",786 ,0)
  23830    G R2
  23831   "RTN","CHM FA14V",787 ,0)
  23832   R3 Q:'$D(C HEQP(BEN))   S TMPI=0
  23833   "RTN","CHM FA14V",788 ,0)
  23834   R4 S TMPI= $O(CHEQP(B EN,TMPI))  Q:'TMPI
  23835   "RTN","CHM FA14V",789 ,0)
  23836    S TMPJ=0
  23837   "RTN","CHM FA14V",790 ,0)
  23838   R5 S TMPJ= $O(CHEQP(B EN,TMPI,TM PJ)) G:'TM PJ R4
  23839   "RTN","CHM FA14V",791 ,0)
  23840    G:TMPJ'=2  R5        ;!($P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,2)'=50) R 5       ;; DRW/JAK 5/ 17/10;DEV0 07600
  23841   "RTN","CHM FA14V",792 ,0)
  23842    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)
  23843   "RTN","CHM FA14V",793 ,0)
  23844    S $P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,2)=TEMPPO S                 ;;D RW/JAK 5/1 7/10;DEV00 7600
  23845   "RTN","CHM FA14V",794 ,0)
  23846    S $P(CHEQ P(BEN,TMPI ,TMPJ),"^" ,3)=TEMPDE SC                ;;D RW/JAK 5/1 7/10;DEV00 7600
  23847   "RTN","CHM FA14V",795 ,0)
  23848    G R5
  23849   "RTN","CHM FA14V",796 ,0)
  23850    Q
  23851   "RTN","CHM FA14V",797 ,0)
  23852   CHSMT(CHST )   ;CHECK /DISPLAY T OTALS
  23853   "RTN","CHM FA14V",798 ,0)
  23854    N CHSMT,C HSDTTL
  23855   "RTN","CHM FA14V",799 ,0)
  23856    I CHSUM(C HST)'=$$SU MDME(CHST)  S CHSUM(C HST)=$$SUM DME(CHST)  D
  23857   "RTN","CHM FA14V",800 ,0)
  23858    .S SVFLD= FLD,FLD=CH ST D CURSA V,FLDLNG S  DX=CFDX,$ X=DX,DY=14
  23859   "RTN","CHM FA14V",801 ,0)
  23860    .S:'$D(DD TOTAL(CHST )) DDTOTAL (CHST)=0 S  CHSUM(CHS T)=CHSUM(C HST)+DDTOT AL(CHST)
  23861   "RTN","CHM FA14V",802 ,0)
  23862    .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
  23863   "RTN","CHM FA14V",803 ,0)
  23864    .S FLD=SV FLD D FLDL NG D CURRE S X XY   ; JEH 5/3/10  ADD LINE
  23865   "RTN","CHM FA14V",804 ,0)
  23866    Q
  23867   "RTN","CHM FA14V",805 ,0)
  23868   AFSET() ;C HECK IF AU TOFLAG IS  SET    ;JE H 2/1/11 D EV007820
  23869   "RTN","CHM FA14V",806 ,0)
  23870    N AFLD
  23871   "RTN","CHM FA14V",807 ,0)
  23872    S AFLD=0
  23873   "RTN","CHM FA14V",808 ,0)
  23874    S CFLD=0  F  S CFLD= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,CFLD))  Q:'CFLD!(A FLD=1)  D
  23875   "RTN","CHM FA14V",809 ,0)
  23876    .Q:$P(^UT ILITY($J," CHDME",FMD OS,BEN,CFL D,5),"^",1 )=""
  23877   "RTN","CHM FA14V",810 ,0)
  23878    .I $P(^UT ILITY($J," CHDME",FMD OS,BEN,CFL D,17),"^", 1)=1 S AFL D=1
  23879   "RTN","CHM FA14V",811 ,0)
  23880    Q AFLD
  23881   "RTN","CHM FA14V",812 ,0)
  23882   CHKDSTR ;    ;JEH 2/1 /11 DEV007 820 - CHEC K FOR RE-D ISTRIBUTIO N OF P/R
  23883   "RTN","CHM FA14V",813 ,0)
  23884    N TTLCHRG ,AROW,ARAT IO,TLNCHRG ,ADIFF,LNC HRG,CFLD,A FLD,RDFLG
  23885   "RTN","CHM FA14V",814 ,0)
  23886    S CFLD=0  F  S CFLD= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,CFLD))  Q:'CFLD!($ D(AFLD))   D
  23887   "RTN","CHM FA14V",815 ,0)
  23888    .Q:$P(^UT ILITY($J," CHDME",FMD OS,BEN,CFL D,5),"^",1 )=""
  23889   "RTN","CHM FA14V",816 ,0)
  23890    .I $P(^UT ILITY($J," CHDME",FMD OS,BEN,CFL D,17),"^", 1)'=1 S AF LD=""
  23891   "RTN","CHM FA14V",817 ,0)
  23892    Q:$D(AFLD )
  23893   "RTN","CHM FA14V",818 ,0)
  23894    S TTLCHRG =""    ;SE TTING TOTA L CHARGE
  23895   "RTN","CHM FA14V",819 ,0)
  23896    S (TTLPR, TTLAO)=""
  23897   "RTN","CHM FA14V",820 ,0)
  23898    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,AROW))  Q:'AROW  D
  23899   "RTN","CHM FA14V",821 ,0)
  23900    .Q:$P(^UT ILITY($J," CHDME",FMD OS,BEN,ARO W,5),"^",1 )=""
  23901   "RTN","CHM FA14V",822 ,0)
  23902    .S:^UTILI TY($J,"CHD ME",FMDOS, BEN,AROW,1 1)'="" TTL PR=TTLPR+^ UTILITY($J ,"CHDME",F MDOS,BEN,A ROW,11)
  23903   "RTN","CHM FA14V",823 ,0)
  23904    .S:^UTILI TY($J,"CHD ME",FMDOS, BEN,AROW,1 2)'="" TTL AO=TTLAO+^ UTILITY($J ,"CHDME",F MDOS,BEN,A ROW,12)
  23905   "RTN","CHM FA14V",824 ,0)
  23906    D AUTODST (TTLPR,11)
  23907   "RTN","CHM FA14V",825 ,0)
  23908    D AUTODST (TTLAO,12)
  23909   "RTN","CHM FA14V",826 ,0)
  23910    Q
  23911   "RTN","CHM FA14V",827 ,0)
  23912   AUTODST(AO HIP,AFLD)  ;AUTO DIST RIBUTE TOT ALS TO LIN E ITEMS
  23913   "RTN","CHM FA14V",828 ,0)
  23914    N TTLCHRG ,AROW,ARAT IO,TLNCHRG ,ADIFF,LNC HRG
  23915   "RTN","CHM FA14V",829 ,0)
  23916    S TTLCHRG =0    ;GET TING TOTAL  CHARGE
  23917   "RTN","CHM FA14V",830 ,0)
  23918    I AOHIP=" "!(+AOHIP= 0) D  Q
  23919   "RTN","CHM FA14V",831 ,0)
  23920    .S AROW=0  F  S AROW =$O(^UTILI TY($J,"CHD ME",FMDOS, BEN,AROW))  Q:'AROW   D
  23921   "RTN","CHM FA14V",832 ,0)
  23922    ..Q:$P(^U TILITY($J, "CHDME",FM DOS,BEN,AR OW,5),"^", 1)=""
  23923   "RTN","CHM FA14V",833 ,0)
  23924    ..S ^UTIL ITY($J,"CH DME",FMDOS ,BEN,AROW, AFLD)=AOHI P
  23925   "RTN","CHM FA14V",834 ,0)
  23926    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,AROW))  Q:'AROW  D
  23927   "RTN","CHM FA14V",835 ,0)
  23928    .Q:$P(^UT ILITY($J," CHDME",FMD OS,BEN,ARO W,5),"^",1 )=""
  23929   "RTN","CHM FA14V",836 ,0)
  23930    .S TTLCHR G=TTLCHRG+ ^UTILITY($ J,"CHDME", FMDOS,BEN, AROW,8)
  23931   "RTN","CHM FA14V",837 ,0)
  23932    Q:TTLCHRG =0             ;JEH 9 /4/13 - FI X <DIVIDE>  ERROR
  23933   "RTN","CHM FA14V",838 ,0)
  23934    S ARATIO= AOHIP/TTLC HRG  ;SETT ING AUTODS T RATIO
  23935   "RTN","CHM FA14V",839 ,0)
  23936    S TLNCHRG =0   ;TOTA L LINE CHA RGE
  23937   "RTN","CHM FA14V",840 ,0)
  23938    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,AROW))  Q:'AROW  D
  23939   "RTN","CHM FA14V",841 ,0)
  23940    .Q:$P(^UT ILITY($J," CHDME",FMD OS,BEN,ARO W,5),"^",1 )=""
  23941   "RTN","CHM FA14V",842 ,0)
  23942    .S LNCHRG (AROW)=$FN (ARATIO*^U TILITY($J, "CHDME",FM DOS,BEN,AR OW,8),"",2 )
  23943   "RTN","CHM FA14V",843 ,0)
  23944    .S TLNCHR G=TLNCHRG+ LNCHRG(ARO W)
  23945   "RTN","CHM FA14V",844 ,0)
  23946    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,AROW))  Q:'AROW  D
  23947   "RTN","CHM FA14V",845 ,0)
  23948    .Q:$P(^UT ILITY($J," CHDME",FMD OS,BEN,ARO W,5),"^",1 )=""
  23949   "RTN","CHM FA14V",846 ,0)
  23950    .S ^UTILI TY($J,"CHD ME",FMDOS, BEN,AROW,A FLD)=LNCHR G(AROW)
  23951   "RTN","CHM FA14V",847 ,0)
  23952    .S ^UTILI TY($J,"CHD ME",FMDOS, BEN,AROW,1 7)=1   ;SE TTING AUTO  DISTRO FL AG
  23953   "RTN","CHM FA14V",848 ,0)
  23954    I TLNCHRG >0 D
  23955   "RTN","CHM FA14V",849 ,0)
  23956    .I (AOHIP #TLNCHRG)' =0 D
  23957   "RTN","CHM FA14V",850 ,0)
  23958    ..S ADIFF =AOHIP-TLN CHRG
  23959   "RTN","CHM FA14V",851 ,0)
  23960    ..S AROW= 9999 S ARO W=$O(^UTIL ITY($J,"CH DME",FMDOS ,BEN,AROW) ,-1)
  23961   "RTN","CHM FA14V",852 ,0)
  23962    ..I $P(^U TILITY($J, "CHDME",FM DOS,BEN,AR OW,5),"^", 1)="" S AR OW=$O(^UTI LITY($J,"C HDME",FMDO S,BEN,AROW ),-1)
  23963   "RTN","CHM FA14V",853 ,0)
  23964    ..S ^UTIL ITY($J,"CH DME",FMDOS ,BEN,AROW, AFLD)=^UTI LITY($J,"C HDME",FMDO S,BEN,AROW ,AFLD)+ADI FF
  23965   "RTN","CHM FA14V",854 ,0)
  23966    ..S ^UTIL ITY($J,"CH DME",FMDOS ,BEN,AROW, 17)=1   ;S ETTING AUT O DISTRO F LAG
  23967   "RTN","CHM FA14V",855 ,0)
  23968    S AROW=0  F  S AROW= $O(^UTILIT Y($J,"CHDM E",FMDOS,B EN,AROW))  Q:'AROW  D
  23969   "RTN","CHM FA14V",856 ,0)
  23970    .Q:$P(^UT ILITY($J," CHDME",FMD OS,BEN,ARO W,5),"^",1 )=""
  23971   "RTN","CHM FA14V",857 ,0)
  23972    .S OPR=^U TILITY($J, "CHDME",FM DOS,BEN,AR OW,11)
  23973   "RTN","CHM FA14V",858 ,0)
  23974    .S AOP=^U TILITY($J, "CHDME",FM DOS,BEN,AR OW,12)
  23975   "RTN","CHM FA14V",859 ,0)
  23976    .I OPR<AO P D
  23977   "RTN","CHM FA14V",860 ,0)
  23978    ..S TTOA= 0
  23979   "RTN","CHM FA14V",861 ,0)
  23980    .E  S TTO A=OPR-AOP
  23981   "RTN","CHM FA14V",862 ,0)
  23982    .I OPR="" &(AOP="")  S ^UTILITY ($J,"CHDME ",FMDOS,BE N,AROW,16) =""
  23983   "RTN","CHM FA14V",863 ,0)
  23984    .E  S ^UT ILITY($J," CHDME",FMD OS,BEN,ARO W,16)=$FN( TTOA,"",2)
  23985   "RTN","CHM FA14V",864 ,0)
  23986    Q
  23987   "RTN","CHM FA161")
  23988   0^50^B1252 68710
  23989   "RTN","CHM FA161",1,0 )
  23990   CHMFA161 ; DEN/CJM;DM E ENTER/ED IT;01/13/9 9  11:42 A M
  23991   "RTN","CHM FA161",2,0 )
  23992    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  23993   "RTN","CHM FA161",3,0 )
  23994    ;;V2.0;
  23995   "RTN","CHM FA161",4,0 )
  23996    ;CPTS #16 067* (RLC)
  23997   "RTN","CHM FA161",5,0 )
  23998    ;ICD-10 R CS -lg 7/1 0/12
  23999   "RTN","CHM FA161",6,0 )
  24000    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if freque ncy code =  5
  24001   "RTN","CHM FA161",7,0 )
  24002    ;CCSE CPE 005-012 GE F 6/7/17 -  remove pr ess return  to contin ue prompt
  24003   "RTN","CHM FA161",8,0 )
  24004   MAIN D INI T,TOTAL
  24005   "RTN","CHM FA161",9,0 )
  24006   M1 D ENTED T
  24007   "RTN","CHM FA161",10, 0)
  24008   END Q
  24009   "RTN","CHM FA161",11, 0)
  24010    ;
  24011   "RTN","CHM FA161",12, 0)
  24012   INIT S DTM =7,DBM=14, DX=1,$X=DX ,DY=6,$Y=D Y X CHMAR  X XY
  24013   "RTN","CHM FA161",13, 0)
  24014    S CHSDY=6 ,CHMDY=17, CHWIN=8,CH LF=7
  24015   "RTN","CHM FA161",14, 0)
  24016    S CHWINLR =1,CHWINHR =CHWIN,MSG FLG=0
  24017   "RTN","CHM FA161",15, 0)
  24018   SUBHEAD S  DY=5,$Y=DY ,DX=6,$X=D X X XY W @ CHULON,"   DOS   "
  24019   "RTN","CHM FA161",16, 0)
  24020    S DX=16,$ X=DX X XY  W " ICD "   ; ICD-10  RCS -lg
  24021   "RTN","CHM FA161",17, 0)
  24022    S DX=24,$ X=DX X XY  W "Rev"
  24023   "RTN","CHM FA161",18, 0)
  24024    S DX=29,$ X=DX X XY  W "SVCS "
  24025   "RTN","CHM FA161",19, 0)
  24026    S DX=36,$ X=DX X XY  W "    Des cription     "
  24027   "RTN","CHM FA161",20, 0)
  24028    S DX=57,$ X=DX X XY  W "Unts"
  24029   "RTN","CHM FA161",21, 0)
  24030    S DX=63,$ X=DX X XY  W " Amount   "
  24031   "RTN","CHM FA161",22, 0)
  24032    S DX=74,$ X=DX X XY  W " P/L  " ,@CHULOFF
  24033   "RTN","CHM FA161",23, 0)
  24034    S DY=15,$ Y=DY,DX=55 ,$X=DX X X Y W @CHBON ,"TOTAL:   ",@CHBOFF
  24035   "RTN","CHM FA161",24, 0)
  24036    S ROW=1,U ="^"
  24037   "RTN","CHM FA161",25, 0)
  24038    I $D(^UTI LITY($J,"C HDME",BEN) ) S CHLR=9 99999999,C HLR=$O(^UT ILITY($J," CHDME",BEN ,CHLR),-1)
  24039   "RTN","CHM FA161",26, 0)
  24040    I '$D(^UT ILITY($J," CHDME",BEN )) D NEWRO W
  24041   "RTN","CHM FA161",27, 0)
  24042    Q
  24043   "RTN","CHM FA161",28, 0)
  24044    ;
  24045   "RTN","CHM FA161",29, 0)
  24046   TOTAL S DX =63,$X=DX, DY=15,$Y=D Y S:'$D(CH SUM) CHSUM =0
  24047   "RTN","CHM FA161",30, 0)
  24048    X XY W @C HBON,$J(CH SUM,9,2),@ CHBOFF Q
  24049   "RTN","CHM FA161",31, 0)
  24050   ENTEDT S C HWINLR=1,C HWINHR=CHW IN,ROW=1,F LD=0,CHVAR ="^UTILITY ($J,""CHDM E"",BEN,RO W,FLD)",CH SUM=0
  24051   "RTN","CHM FA161",32, 0)
  24052    I $P(^UTI LITY($J,"C HDME",BEN, 1,1),U)'=" " D REDISP  G ENT1
  24053   "RTN","CHM FA161",33, 0)
  24054    S DY=CHSD Y,$Y=DY,MS GFLG=0 D F LDLNG S DX =CFDX,$X=D X
  24055   "RTN","CHM FA161",34, 0)
  24056   ENT0 S $P( ^UTILITY($ J,"CHDME", BEN,ROW,FL D),U,1)=RO W
  24057   "RTN","CHM FA161",35, 0)
  24058    I FLD=6 X  XY W $J($ FN($P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U ,1),"",2), FL)
  24059   "RTN","CHM FA161",36, 0)
  24060    E  X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)
  24061   "RTN","CHM FA161",37, 0)
  24062    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX
  24063   "RTN","CHM FA161",38, 0)
  24064   ENT1 I CHS UM'=$$SUMD ME() S CHS UM=$$SUMDM E() D
  24065   "RTN","CHM FA161",39, 0)
  24066    . S SVFLD =FLD,FLD=6  D CURSAV, FLDLNG S D X=CFDX,$X= DX,DY=15,$ Y=DY
  24067   "RTN","CHM FA161",40, 0)
  24068    . X XY W  @CHBON,$J( CHSUM,FL,2 ),@CHBOFF  S FLD=SVFL D D FLDLNG  D CURRES  X XY
  24069   "RTN","CHM FA161",41, 0)
  24070    S CHDB=^U TILITY($J, "CHDME",BE N,ROW,FLD)
  24071   "RTN","CHM FA161",42, 0)
  24072    S SFLD=0
  24073   "RTN","CHM FA161",43, 0)
  24074    I FLD=6 X  XY W $J($ FN($P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U ,1),"",2), FL)
  24075   "RTN","CHM FA161",44, 0)
  24076    E  X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)
  24077   "RTN","CHM FA161",45, 0)
  24078    I FLD=2!( FLD=4) D:$ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U)'=" " CURSAV,D ESCRP,CURR ES
  24079   "RTN","CHM FA161",46, 0)
  24080    X XY D CS BRS^CHSC2
  24081   "RTN","CHM FA161",47, 0)
  24082    S CHLF=7  I $D(^UTIL ITY($J,"CH DME",BEN,R OW,2)) D
  24083   "RTN","CHM FA161",48, 0)
  24084    .S:$P(^UT ILITY($J," CHDME",BEN ,ROW,2),U) '="" CHLF= 2
  24085   "RTN","CHM FA161",49, 0)
  24086    .Q
  24087   "RTN","CHM FA161",50, 0)
  24088    I $D(DFOU T) W *7 G  ENT1
  24089   "RTN","CHM FA161",51, 0)
  24090    I $D(DUOU T) W *7 G  ENT1
  24091   "RTN","CHM FA161",52, 0)
  24092    I Y'="" S  CHDB=""
  24093   "RTN","CHM FA161",53, 0)
  24094    S:Y=""&(^ UTILITY($J ,"CHDME",B EN,ROW,FLD )'="") Y=$ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U,1)
  24095   "RTN","CHM FA161",54, 0)
  24096    S LNTAG=" GETF"_FLD_ "^CHMFA162 " D @LNTAG
  24097   "RTN","CHM FA161",55, 0)
  24098    I SFLD G  ENT1
  24099   "RTN","CHM FA161",56, 0)
  24100    S ^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD)=Y
  24101   "RTN","CHM FA161",57, 0)
  24102    I ^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD)'=CHD B D
  24103   "RTN","CHM FA161",58, 0)
  24104    .X XY W $ J($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U, 1),FL)
  24105   "RTN","CHM FA161",59, 0)
  24106    .I FLD=2! (FLD=4) D: $P(^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD),U)'= "" CURSAV, DESCRP,CUR RES,ICDFIL
  24107   "RTN","CHM FA161",60, 0)
  24108    .X XY
  24109   "RTN","CHM FA161",61, 0)
  24110    I $D(DDOU T) D EXIT  Q:$D(CHMFN EXT)  Q:$D (CHMFPREV)   Q:$D(CHM FKILL)  Q: $D(CHMFNEW B)  G ENT1
  24111   "RTN","CHM FA161",62, 0)
  24112    I ROW=1&$ D(D1OUT) W  *7 G ENT1
  24113   "RTN","CHM FA161",63, 0)
  24114    I ROW>1&$ D(D1OUT) D  UP D FLDL NG,CLRMSG  G ENT1
  24115   "RTN","CHM FA161",64, 0)
  24116    I $D(D4OU T)&(FLD'>1 ) S FLD=CH LF D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  24117   "RTN","CHM FA161",65, 0)
  24118    I $D(D4OU T)&(FLD>1)  S FLD=FLD -1 D  D FL DLNG,CLRMS G S DX=CFD X,$X=DX G  ENT1
  24119   "RTN","CHM FA161",66, 0)
  24120    .I FLD=3  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD-1
  24121   "RTN","CHM FA161",67, 0)
  24122    I $D(D3OU T)&(FLD'<C HLF) S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  24123   "RTN","CHM FA161",68, 0)
  24124    I $D(D3OU T)&(FLD<CH LF) S FLD= FLD+1 D  D  FLDLNG,CL RMSG S DX= CFDX,$X=DX  G ENT1
  24125   "RTN","CHM FA161",69, 0)
  24126    .I FLD=3  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  24127   "RTN","CHM FA161",70, 0)
  24128    I $D(DPOU T) D PREV  D FLDLNG,C LRMSG G EN T1
  24129   "RTN","CHM FA161",71, 0)
  24130    I $D(DNOU T) D NEXT  D FLDLNG,C LRMSG G EN T1
  24131   "RTN","CHM FA161",72, 0)
  24132    ; D2OUT O R CR
  24133   "RTN","CHM FA161",73, 0)
  24134    I '$D(D2O UT)&(FLD<C HLF) S FLD =FLD+1 D   D FLDLNG,C LRMSG S DX =CFDX,$X=D X G ENT1
  24135   "RTN","CHM FA161",74, 0)
  24136    .I FLD=3  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  24137   "RTN","CHM FA161",75, 0)
  24138    I '$D(D2O UT)&(FLD'< CHLF)&(ROW '=CHLR) D  DOWN S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  24139   "RTN","CHM FA161",76, 0)
  24140    I ROW=CHL R D DOWN S  FLD=0 D F LDLNG,CLRM SG S DX=CF DX,$X=DX G  ENT0
  24141   "RTN","CHM FA161",77, 0)
  24142    D DOWN S: ^UTILITY($ J,"CHDME", BEN,ROW,1) ="" FLD=1  D FLDLNG,C LRMSG S DX =CFDX,$X=D X G ENT1
  24143   "RTN","CHM FA161",78, 0)
  24144    Q
  24145   "RTN","CHM FA161",79, 0)
  24146    ;
  24147   "RTN","CHM FA161",80, 0)
  24148   SUMDME() ; SUMS ARRAY  DME
  24149   "RTN","CHM FA161",81, 0)
  24150    N SUM,R
  24151   "RTN","CHM FA161",82, 0)
  24152    S SUM=0
  24153   "RTN","CHM FA161",83, 0)
  24154    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,6)) Q  SUM
  24155   "RTN","CHM FA161",84, 0)
  24156    S R=0
  24157   "RTN","CHM FA161",85, 0)
  24158    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) Q :'R  S SUM =SUM+^UTIL ITY($J,"CH DME",BEN,R ,6)
  24159   "RTN","CHM FA161",86, 0)
  24160    Q SUM
  24161   "RTN","CHM FA161",87, 0)
  24162    ;
  24163   "RTN","CHM FA161",88, 0)
  24164   DESCRP S D X=36,$X=DX
  24165   "RTN","CHM FA161",89, 0)
  24166    K BF S BF ="",$P(BF, " ",20)=""  X XY W BF
  24167   "RTN","CHM FA161",90, 0)
  24168    K BF S BF ="",$P(BF, " ",FL+1)= ""
  24169   "RTN","CHM FA161",91, 0)
  24170    X XY W $E ($P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U,3 ),1,19)
  24171   "RTN","CHM FA161",92, 0)
  24172    D ERAMSG
  24173   "RTN","CHM FA161",93, 0)
  24174    S HOLDDY= DY
  24175   "RTN","CHM FA161",94, 0)
  24176    S $P(STR, " ",64)=""
  24177   "RTN","CHM FA161",95, 0)
  24178    S DX=1,$X =DX,DY=15, $Y=DY X XY  W STR X X Y
  24179   "RTN","CHM FA161",96, 0)
  24180    W $E($P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),U,3),1,6 2)
  24181   "RTN","CHM FA161",97, 0)
  24182    S MSGFLG= 1
  24183   "RTN","CHM FA161",98, 0)
  24184    Q
  24185   "RTN","CHM FA161",99, 0)
  24186    ;
  24187   "RTN","CHM FA161",100 ,0)
  24188   ICDFIL I F LD=2 S CHL F=2 D
  24189   "RTN","CHM FA161",101 ,0)
  24190    .F FLD=3: 1:7 S ^UTI LITY($J,"C HDME",BEN, ROW,FLD)=" "
  24191   "RTN","CHM FA161",102 ,0)
  24192    .F FLD=3: 1:7 D FLDL NG S DX=CF DX,$X=DX X  XY W $J($ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U,1), FL)
  24193   "RTN","CHM FA161",103 ,0)
  24194    .S FLD=2  D FLDLNG S  DX=CFDX,$ X=DX
  24195   "RTN","CHM FA161",104 ,0)
  24196    I FLD=4 S  CHLF=7 D
  24197   "RTN","CHM FA161",105 ,0)
  24198    .S ^UTILI TY($J,"CHD ME",BEN,RO W,2)=""
  24199   "RTN","CHM FA161",106 ,0)
  24200    .S FLD=2  D FLDLNG S  DX=CFDX,$ X=DX X XY  W $J($P(^U TILITY($J, "CHDME",BE N,ROW,FLD) ,U,1),FL)
  24201   "RTN","CHM FA161",107 ,0)
  24202    .S FLD=4  D FLDLNG S  DX=CFDX,$ X=DX
  24203   "RTN","CHM FA161",108 ,0)
  24204    Q
  24205   "RTN","CHM FA161",109 ,0)
  24206    ;
  24207   "RTN","CHM FA161",110 ,0)
  24208   EDITOK ;MO DIFIED BY  DTP TO SKI P REV CODE  EDITS ON  PAPER, BUT  NOT EDI I N LAST LIN E OF SUBRT N
  24209   "RTN","CHM FA161",111 ,0)
  24210    Q:'$D(CHM FPDI)
  24211   "RTN","CHM FA161",112 ,0)
  24212    S X=$$TYP E^CHMFPDI2 (CHMFPDI)
  24213   "RTN","CHM FA161",113 ,0)
  24214    S PT=0,PT =$O(^CHMDI C(741002.9 3,"C",X,PT ))
  24215   "RTN","CHM FA161",114 ,0)
  24216    Q:'PT  Q: '$D(^CHMDI C(741002.9 3,PT,0))
  24217   "RTN","CHM FA161",115 ,0)
  24218    S PTR=$P( ^(0),"^",3 )
  24219   "RTN","CHM FA161",116 ,0)
  24220    Q:'PTR  Q :'$D(^CHMD IC(741002. 94,PTR,2))
  24221   "RTN","CHM FA161",117 ,0)
  24222    S:$P(^(2) ,"^",PC) N OEDIT=1
  24223   "RTN","CHM FA161",118 ,0)
  24224    I (PC=2)& ($E(X,1,1) =9) K NOED IT
  24225   "RTN","CHM FA161",119 ,0)
  24226    Q
  24227   "RTN","CHM FA161",120 ,0)
  24228    ; 
  24229   "RTN","CHM FA161",121 ,0)
  24230   BEEPQ X XY  W BF X XY  W *7,"??"  X XY W BF
  24231   "RTN","CHM FA161",122 ,0)
  24232    Q
  24233   "RTN","CHM FA161",123 ,0)
  24234    ;
  24235   "RTN","CHM FA161",124 ,0)
  24236   FLDLNG S F L=$S(FLD=0 :3,FLD=1:8 ,FLD=2:6,F LD=3:3,FLD =4:5,FLD=5 :4,FLD=6:9 ,FLD=7:6,1 :1)
  24237   "RTN","CHM FA161",125 ,0)
  24238    S CFDX=$S (FLD=0:1,F LD=1:6,FLD =2:16,FLD= 3:24,FLD=4 :29,FLD=5: 57,FLD=6:6 3,FLD=7:74 ,1:1)
  24239   "RTN","CHM FA161",126 ,0)
  24240    K BF S BF ="",$P(BF, " ",FL+1)= ""
  24241   "RTN","CHM FA161",127 ,0)
  24242    Q
  24243   "RTN","CHM FA161",128 ,0)
  24244    ;
  24245   "RTN","CHM FA161",129 ,0)
  24246   REPEAT X X Y W BF
  24247   "RTN","CHM FA161",130 ,0)
  24248    I $E(Y)=" /" D DIVID E
  24249   "RTN","CHM FA161",131 ,0)
  24250    S STOP=$E (Y,2,$L(Y) )+(ROW-2), START=ROW, DY=DY-1,$Y =DY F ROW1 =START:1:S TOP D
  24251   "RTN","CHM FA161",132 ,0)
  24252    .S ^UTILI TY($J,"CHD ME",BEN,RO W1,0)=ROW1  F FLD=1:1 :7 S ^UTIL ITY($J,"CH DME",BEN,R OW1,FLD)=^ UTILITY($J ,"CHDME",B EN,ROW-1,F LD)
  24253   "RTN","CHM FA161",133 ,0)
  24254    .S DY=DY+ 1,$Y=DY I  DY=(CHSDY+ CHWIN) D
  24255   "RTN","CHM FA161",134 ,0)
  24256    .. S DY=C HSDY+CHWIN -1,$Y=DY,C HWINLR=CHW INLR+1,CHW INHR=CHWIN HR+1
  24257   "RTN","CHM FA161",135 ,0)
  24258    .. S DX=1 ,$X=DX X X Y W !
  24259   "RTN","CHM FA161",136 ,0)
  24260    .F FLD=0: 1:7 D FLDL NG S DX=CF DX,$X=DX X  XY W $J($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,FL)
  24261   "RTN","CHM FA161",137 ,0)
  24262    .F FLD=2, 3 D:$P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U)'=""
  24263   "RTN","CHM FA161",138 ,0)
  24264    ..S DX=36 ,$X=DX
  24265   "RTN","CHM FA161",139 ,0)
  24266    ..K BF S  BF="",$P(B F," ",20)= "" X XY W  BF
  24267   "RTN","CHM FA161",140 ,0)
  24268    ..X XY W  $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,3),1,19)
  24269   "RTN","CHM FA161",141 ,0)
  24270    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  24271   "RTN","CHM FA161",142 ,0)
  24272    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1
  24273   "RTN","CHM FA161",143 ,0)
  24274    S SFLD=1
  24275   "RTN","CHM FA161",144 ,0)
  24276   REPEND Q
  24277   "RTN","CHM FA161",145 ,0)
  24278    ;
  24279   "RTN","CHM FA161",146 ,0)
  24280   DIVIDE S Y 1=^UTILITY ($J,"CHDME ",BEN,ROW- 1,5)/$E(Y, 2,$L(Y))
  24281   "RTN","CHM FA161",147 ,0)
  24282    S Y1=$J(Y 1,$L($P(Y1 ,".",1))+3 ,2)
  24283   "RTN","CHM FA161",148 ,0)
  24284    I ^UTILIT Y($J,"CHDM E",BEN,ROW -1,2)'=""  S Y1=""
  24285   "RTN","CHM FA161",149 ,0)
  24286    S ^UTILIT Y($J,"CHDM E",BEN,ROW -1,5)=Y1
  24287   "RTN","CHM FA161",150 ,0)
  24288    D CURSAV
  24289   "RTN","CHM FA161",151 ,0)
  24290    S FLD=6 D  FLDLNG S  DX=CFDX,$X =DX,DY=DY- 1
  24291   "RTN","CHM FA161",152 ,0)
  24292    X XY W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W-1,FLD),U ,1),FL)
  24293   "RTN","CHM FA161",153 ,0)
  24294    D CURRES
  24295   "RTN","CHM FA161",154 ,0)
  24296    X XY
  24297   "RTN","CHM FA161",155 ,0)
  24298    Q
  24299   "RTN","CHM FA161",156 ,0)
  24300    ;
  24301   "RTN","CHM FA161",157 ,0)
  24302   REDISP S D Y=CHSDY-1  F ROW1=1:1 :CHLR D
  24303   "RTN","CHM FA161",158 ,0)
  24304    .S DY=DY+ 1 I DY=(CH SDY+CHWIN)  D
  24305   "RTN","CHM FA161",159 ,0)
  24306    .. S DY=C HSDY+CHWIN -1,CHWINLR =CHWINLR+1 ,CHWINHR=C HWINHR+1
  24307   "RTN","CHM FA161",160 ,0)
  24308    .. S DX=1 ,$X=DX X X Y W !
  24309   "RTN","CHM FA161",161 ,0)
  24310    .; CCSE C PE005-009  GEF 5/2/17  - add ori ginal PDI  charge lin es if freq  code=5 an d display  in bold
  24311   "RTN","CHM FA161",162 ,0)
  24312    .; Check  the line n umber wher e the late  charges e nd and the  original  charges af ter that s hould disp lay differ ently
  24313   "RTN","CHM FA161",163 ,0)
  24314    .I $D(^UT ILITY($J," CHDME",BEN ,"BL")) W: ROW1>$G(^U TILITY($J, "CHDME",BE N,"BL")) @ CHBON
  24315   "RTN","CHM FA161",164 ,0)
  24316    .F FLD=0: 1:7 D FLDL NG S DX=CF DX,$X=DX X  XY D
  24317   "RTN","CHM FA161",165 ,0)
  24318    ..Q:^UTIL ITY($J,"CH DME",BEN,R OW1,FLD)=" "
  24319   "RTN","CHM FA161",166 ,0)
  24320    ..I FLD=6  W $J($FN( $P(^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD),U,1 ),"",2),FL )
  24321   "RTN","CHM FA161",167 ,0)
  24322    ..E  W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1),FL)
  24323   "RTN","CHM FA161",168 ,0)
  24324    .F FLD=2, 4 D:$P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U)'=""
  24325   "RTN","CHM FA161",169 ,0)
  24326    ..S DX=36 ,$X=DX
  24327   "RTN","CHM FA161",170 ,0)
  24328    ..K BF S  BF="",$P(B F," ",20)= "" X XY W  BF
  24329   "RTN","CHM FA161",171 ,0)
  24330    ..X XY W  $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,3),1,19)
  24331   "RTN","CHM FA161",172 ,0)
  24332    W @CHBOFF
  24333   "RTN","CHM FA161",173 ,0)
  24334    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  24335   "RTN","CHM FA161",174 ,0)
  24336    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1
  24337   "RTN","CHM FA161",175 ,0)
  24338    S SFLD=1
  24339   "RTN","CHM FA161",176 ,0)
  24340    Q
  24341   "RTN","CHM FA161",177 ,0)
  24342    ;
  24343   "RTN","CHM FA161",178 ,0)
  24344   EXIT D CUR SAV,ERAMSG
  24345   "RTN","CHM FA161",179 ,0)
  24346   E1 D PRMPT ^CHMFA160, ASK^CHMFA1 60
  24347   "RTN","CHM FA161",180 ,0)
  24348    I $D(DFOU T)!$D(DUOU T) G E1
  24349   "RTN","CHM FA161",181 ,0)
  24350    K CHMFNEX T,CHMFPREV ,CHMFKILL, CHMFNEWB
  24351   "RTN","CHM FA161",182 ,0)
  24352    S:Y=2 CHM FNEXT=1 S: Y=3 CHMFPR EV=1 S:Y=4  CHMFKILL= 1
  24353   "RTN","CHM FA161",183 ,0)
  24354    I Y=5 D ^ CHMFA165,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  24355   "RTN","CHM FA161",184 ,0)
  24356    I Y=8 D D ELSVCLN^CH MFAUTL K:$ D(CHMFNEXT ) CHMFNEXT  K:$D(CHMF PREV) CHMF PREV D INI T^CHMFA160 ,SETSCR^CH MFA160,INI T,TOTAL,EN TEDT Q   ; SKD, 6-14- 07, DEV000 197
  24357   "RTN","CHM FA161",185 ,0)
  24358    I Y=9 D ^ CHMFA02B,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  24359   "RTN","CHM FA161",186 ,0)
  24360    I $D(CHMF NEXT) I $D (^CHMDIC(7 41002.21,D UZ,0)) I ' $P(^(0),"^ ",14) D  I  '$D(CHMFN EXT) D ERA MSG G E1
  24361   "RTN","CHM FA161",187 ,0)
  24362   E2 .S HY=D Y,HX=DX,DY =19,DX=20, $X=DX X XY
  24363   "RTN","CHM FA161",188 ,0)
  24364    .; CCSE C PE005-012  GEF 6/7/17  - remove  press retu rn to cont inue promp t
  24365   "RTN","CHM FA161",189 ,0)
  24366    .;W "Are  you sure y ou want to  continue:  " D CSBRS ^CHSC2
  24367   "RTN","CHM FA161",190 ,0)
  24368    .;I $D(DU OUT) K CHM FNEXT Q
  24369   "RTN","CHM FA161",191 ,0)
  24370    .;I $D(DF OUT) K CHM FNEXT Q
  24371   "RTN","CHM FA161",192 ,0)
  24372    .;G:Y=""  E2 S Y=$E( Y) G:"YNyn "'[Y E2
  24373   "RTN","CHM FA161",193 ,0)
  24374    .;I "Nn"[ Y K CHMFNE XT
  24375   "RTN","CHM FA161",194 ,0)
  24376    .S DY=HY, DX=HX,$X=D X
  24377   "RTN","CHM FA161",195 ,0)
  24378    D CURRES  D FLDLNG
  24379   "RTN","CHM FA161",196 ,0)
  24380    Q
  24381   "RTN","CHM FA161",197 ,0)
  24382    ;
  24383   "RTN","CHM FA161",198 ,0)
  24384   DOWN D CUR SAV
  24385   "RTN","CHM FA161",199 ,0)
  24386    I $P(^UTI LITY($J,"C HDME",BEN, ROW,1),U)' ="DELETED" &($P(^UTIL ITY($J,"CH DME",BEN,R OW,2),U)=" ")&($P(^UT ILITY($J," CHDME",BEN ,ROW,3),U) ="")&($P(^ UTILITY($J ,"CHDME",B EN,ROW,4), U)="")&($P (^UTILITY( $J,"CHDME" ,BEN,ROW,5 ),U)="") D  BEEPQ G D OWNEND
  24387   "RTN","CHM FA161",200 ,0)
  24388    S CHCF=FL D,DY=DY+1, ROW=ROW+1
  24389   "RTN","CHM FA161",201 ,0)
  24390    I '$D(^UT ILITY($J," CHDME",BEN ,ROW)) D N EWROW
  24391   "RTN","CHM FA161",202 ,0)
  24392    I DY=(CHS DY+CHWIN)  D UPSCRL
  24393   "RTN","CHM FA161",203 ,0)
  24394   DOWNEND Q
  24395   "RTN","CHM FA161",204 ,0)
  24396    ;
  24397   "RTN","CHM FA161",205 ,0)
  24398   NEWROW F F LD=0:1:7 S  ^UTILITY( $J,"CHDME" ,BEN,ROW,F LD)="" S:F LD=5 ^UTIL ITY($J,"CH DME",BEN,R OW,FLD)=1
  24399   "RTN","CHM FA161",206 ,0)
  24400    I $D(^UTI LITY($J,"C HDME",BEN, ROW-1)) S  ^UTILITY($ J,"CHDME", BEN,ROW,1) =^UTILITY( $J,"CHDME" ,BEN,ROW-1 ,1)
  24401   "RTN","CHM FA161",207 ,0)
  24402    S CHLR=RO W
  24403   "RTN","CHM FA161",208 ,0)
  24404    Q
  24405   "RTN","CHM FA161",209 ,0)
  24406    ;
  24407   "RTN","CHM FA161",210 ,0)
  24408   UP D CURSA V
  24409   "RTN","CHM FA161",211 ,0)
  24410    S CHCF=FL D,DY=DY-1, ROW=ROW-1
  24411   "RTN","CHM FA161",212 ,0)
  24412    I DY<CHSD Y D DNSCRL
  24413   "RTN","CHM FA161",213 ,0)
  24414    Q
  24415   "RTN","CHM FA161",214 ,0)
  24416    ;
  24417   "RTN","CHM FA161",215 ,0)
  24418   DNSCRL S D Y=CHSDY,CH WINLR=CHWI NLR-1,CHWI NHR=CHWINH R-1
  24419   "RTN","CHM FA161",216 ,0)
  24420    S ROW1=CH WINLR-1
  24421   "RTN","CHM FA161",217 ,0)
  24422   DN1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1)) G:'RO W1 DN2  G: ROW1>CHWIN HR DN2
  24423   "RTN","CHM FA161",218 ,0)
  24424    S DX=1,$X =DX,DY=CHS DY X XY W  @CHINSL
  24425   "RTN","CHM FA161",219 ,0)
  24426    F FLD=0:1 :7 D FLDLN G S DX=CFD X,$X=DX X  XY D
  24427   "RTN","CHM FA161",220 ,0)
  24428    .I FLD'=6  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),FL )
  24429   "RTN","CHM FA161",221 ,0)
  24430    .I FLD=6  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)'="" D
  24431   "RTN","CHM FA161",222 ,0)
  24432    ..W $J($F N($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1),"",2), FL)
  24433   "RTN","CHM FA161",223 ,0)
  24434    F FLD=2,3  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  24435   "RTN","CHM FA161",224 ,0)
  24436    .S DX=36, $X=DX
  24437   "RTN","CHM FA161",225 ,0)
  24438    .K BF S B F="",$P(BF ," ",20)=" " X XY W B F
  24439   "RTN","CHM FA161",226 ,0)
  24440    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,19)
  24441   "RTN","CHM FA161",227 ,0)
  24442   DN2 D CURR ES S FLD=C HCF
  24443   "RTN","CHM FA161",228 ,0)
  24444    Q
  24445   "RTN","CHM FA161",229 ,0)
  24446    ;
  24447   "RTN","CHM FA161",230 ,0)
  24448   UPSCRL S D Y=CHSDY+CH WIN-1,CHWI NLR=CHWINL R+1,CHWINH R=CHWINHR+ 1
  24449   "RTN","CHM FA161",231 ,0)
  24450    S ROW1=CH WINHR+1
  24451   "RTN","CHM FA161",232 ,0)
  24452   UP1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1),-1) G: 'ROW1 UP2   G:ROW1<CH WINLR UP2
  24453   "RTN","CHM FA161",233 ,0)
  24454    S DX=1,$X =DX X XY W  !
  24455   "RTN","CHM FA161",234 ,0)
  24456    F FLD=0:1 :7 D FLDLN G S DX=CFD X,$X=DX X  XY D
  24457   "RTN","CHM FA161",235 ,0)
  24458    .I FLD'=6  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),FL )
  24459   "RTN","CHM FA161",236 ,0)
  24460    .I FLD=6  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)'="" D
  24461   "RTN","CHM FA161",237 ,0)
  24462    ..W $J($F N($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1),"",2), FL)
  24463   "RTN","CHM FA161",238 ,0)
  24464    F FLD=2,3  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  24465   "RTN","CHM FA161",239 ,0)
  24466    .S DX=36, $X=DX
  24467   "RTN","CHM FA161",240 ,0)
  24468    .K BF S B F="",$P(BF ," ",20)=" " X XY W B F
  24469   "RTN","CHM FA161",241 ,0)
  24470    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,19)
  24471   "RTN","CHM FA161",242 ,0)
  24472   UP2 D CURR ES S FLD=C HCF
  24473   "RTN","CHM FA161",243 ,0)
  24474    Q
  24475   "RTN","CHM FA161",244 ,0)
  24476    ;
  24477   "RTN","CHM FA161",245 ,0)
  24478   PREV I CHW INLR<2 W * 7 Q
  24479   "RTN","CHM FA161",246 ,0)
  24480    S CHCDX=D X,CHCF=FLD
  24481   "RTN","CHM FA161",247 ,0)
  24482    S CHWINLR =CHWINLR-C HWIN S:CHW INLR<1 CHW INLR=1
  24483   "RTN","CHM FA161",248 ,0)
  24484    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,RO W1=CHWINLR -1
  24485   "RTN","CHM FA161",249 ,0)
  24486   P1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) G:'ROW 1 P2 G:ROW 1>CHWINHR  P2
  24487   "RTN","CHM FA161",250 ,0)
  24488    S DX=1,$X =DX X XY W  @CHEOL
  24489   "RTN","CHM FA161",251 ,0)
  24490    F FLD=0:1 :7 D FLDLN G S DX=CFD X,$X=DX X  XY D
  24491   "RTN","CHM FA161",252 ,0)
  24492    .I FLD'=6  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),FL )
  24493   "RTN","CHM FA161",253 ,0)
  24494    .I FLD=6  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)'="" D
  24495   "RTN","CHM FA161",254 ,0)
  24496    ..W $J($F N($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1),"",2), FL)
  24497   "RTN","CHM FA161",255 ,0)
  24498    F FLD=2,3  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  24499   "RTN","CHM FA161",256 ,0)
  24500    .S DX=36, $X=DX
  24501   "RTN","CHM FA161",257 ,0)
  24502    .K BF S B F="",$P(BF ," ",20)=" " X XY W B F
  24503   "RTN","CHM FA161",258 ,0)
  24504    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,19)
  24505   "RTN","CHM FA161",259 ,0)
  24506    S DY=DY+1  G P1
  24507   "RTN","CHM FA161",260 ,0)
  24508   P2 S DY=CH SDY,ROW=CH WINLR,DX=C HCDX,$X=DX ,FLD=CHCF
  24509   "RTN","CHM FA161",261 ,0)
  24510    Q
  24511   "RTN","CHM FA161",262 ,0)
  24512    ;
  24513   "RTN","CHM FA161",263 ,0)
  24514   NEXT I '$D (^UTILITY( $J,"CHDME" ,BEN,CHWIN HR+1)) W * 7 Q
  24515   "RTN","CHM FA161",264 ,0)
  24516    S CHCDX=D X,CHCF=FLD
  24517   "RTN","CHM FA161",265 ,0)
  24518    S CHWINLR =CHWINLR+C HWIN S:CHW INLR<1 CHW INLR=1
  24519   "RTN","CHM FA161",266 ,0)
  24520    I CHWINLR +CHWIN>CHL R S CHWINL R=CHLR-(CH WIN-1)
  24521   "RTN","CHM FA161",267 ,0)
  24522    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,RO W1=CHWINLR -1
  24523   "RTN","CHM FA161",268 ,0)
  24524   N1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) I 'ROW 1 D CLEAR2  G N2
  24525   "RTN","CHM FA161",269 ,0)
  24526    G:ROW1>CH WINHR N2
  24527   "RTN","CHM FA161",270 ,0)
  24528    S DX=1,$X =DX X XY W  @CHEOL
  24529   "RTN","CHM FA161",271 ,0)
  24530    F FLD=0:1 :7 D FLDLN G S DX=CFD X,$X=DX X  XY W $J($P (^UTILITY( $J,"CHDME" ,BEN,ROW1, FLD),U,1), FL)
  24531   "RTN","CHM FA161",272 ,0)
  24532    F FLD=2,3  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  24533   "RTN","CHM FA161",273 ,0)
  24534    .S DX=36, $X=DX
  24535   "RTN","CHM FA161",274 ,0)
  24536    .K BF S B F="",$P(BF ," ",20)=" " X XY W B F
  24537   "RTN","CHM FA161",275 ,0)
  24538    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,19)
  24539   "RTN","CHM FA161",276 ,0)
  24540    S DY=DY+1  G N1
  24541   "RTN","CHM FA161",277 ,0)
  24542   N2 S DY=CH SDY,ROW=CH WINLR,DX=C HCDX,$X=DX ,FLD=CHCF
  24543   "RTN","CHM FA161",278 ,0)
  24544    Q
  24545   "RTN","CHM FA161",279 ,0)
  24546    ;
  24547   "RTN","CHM FA161",280 ,0)
  24548   CLEAR2 S H Y=DY,DX=1, $X=DX F DY =HY:1:CHSD Y+CHWIN-1  X XY W @CH EOL
  24549   "RTN","CHM FA161",281 ,0)
  24550    Q
  24551   "RTN","CHM FA161",282 ,0)
  24552    ;
  24553   "RTN","CHM FA161",283 ,0)
  24554   CURSAV S C HCDX=DX,CH CDY=DY
  24555   "RTN","CHM FA161",284 ,0)
  24556    Q
  24557   "RTN","CHM FA161",285 ,0)
  24558    ;
  24559   "RTN","CHM FA161",286 ,0)
  24560   CURRES S D X=CHCDX,$X =DX,DY=CHC DY
  24561   "RTN","CHM FA161",287 ,0)
  24562    Q
  24563   "RTN","CHM FA161",288 ,0)
  24564    ;
  24565   "RTN","CHM FA161",289 ,0)
  24566   MARSCR ;S  DTM=CHSDY, DBM=CHSDY+ CHWIN-1 X  CHMAR  ;SK D
  24567   "RTN","CHM FA161",290 ,0)
  24568    S DTM=CHS DY+1,DBM=C HSDY+CHWIN  X CHMAR   ;SKD
  24569   "RTN","CHM FA161",291 ,0)
  24570    Q
  24571   "RTN","CHM FA161",292 ,0)
  24572    ;
  24573   "RTN","CHM FA161",293 ,0)
  24574   MARMES S D TM=CHMDY,D BM=20 X CH MAR
  24575   "RTN","CHM FA161",294 ,0)
  24576    Q
  24577   "RTN","CHM FA161",295 ,0)
  24578    ;
  24579   "RTN","CHM FA161",296 ,0)
  24580   ERASCR S D X=1,$X=DX  F DY=CHSDY :1:CHSDY+C HWIN-1 X X Y W @CHEOL
  24581   "RTN","CHM FA161",297 ,0)
  24582    Q
  24583   "RTN","CHM FA161",298 ,0)
  24584    ;
  24585   "RTN","CHM FA161",299 ,0)
  24586   ERAMSG S D X=1,$X=DX  F DY=CHMDY :1:20 X XY  W @CHEOL
  24587   "RTN","CHM FA161",300 ,0)
  24588    Q
  24589   "RTN","CHM FA161",301 ,0)
  24590    ;
  24591   "RTN","CHM FA161",302 ,0)
  24592   CLRMSG I M SGFLG D CU RSAV,ERAMS G,ERROR,CU RRES S MSG FLG=0
  24593   "RTN","CHM FA161",303 ,0)
  24594    Q
  24595   "RTN","CHM FA161",304 ,0)
  24596   ERROR Q
  24597   "RTN","CHM FA171")
  24598   0^51^B1444 62687
  24599   "RTN","CHM FA171",1,0 )
  24600   CHMFA171 ; DEN/CJM;DE NTAL ENTER /EDIT;08/2 0/98  8:16  AM
  24601   "RTN","CHM FA171",2,0 )
  24602    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  24603   "RTN","CHM FA171",3,0 )
  24604    ;;V2.0;
  24605   "RTN","CHM FA171",4,0 )
  24606    ;ICD-10 R CS -lg 7/1 0/12
  24607   "RTN","CHM FA171",5,0 )
  24608    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if freq c ode=5 and  display in  bold
  24609   "RTN","CHM FA171",6,0 )
  24610    ;CCSE CPE 005-012 GE F 6/7/17 -  remove pr ess return  to contin ue prompt
  24611   "RTN","CHM FA171",7,0 )
  24612    ;BDB CPE0 05-009 8/2 0/2017
  24613   "RTN","CHM FA171",8,0 )
  24614   MAIN D INI T,TOTAL
  24615   "RTN","CHM FA171",9,0 )
  24616   M1 D ENTED T
  24617   "RTN","CHM FA171",10, 0)
  24618   END Q
  24619   "RTN","CHM FA171",11, 0)
  24620    ;
  24621   "RTN","CHM FA171",12, 0)
  24622   INIT ;S DT M=6,DBM=13 ,DX=1,$X=D X,DY=6,$Y= DY X CHMAR  X XY   ;S KD,5-31-05    
  24623   "RTN","CHM FA171",13, 0)
  24624    U 0:0:"^% X364" S DT M=6,DBM=14 ,DX=1,$X=D X,DY=6,$Y= DY X CHMAR  X XY   ;S KD,5-31-05
  24625   "RTN","CHM FA171",14, 0)
  24626    S CHSDY=6 ,CHMDY=17, CHWIN=8,CH LF=8
  24627   "RTN","CHM FA171",15, 0)
  24628    S CHWINLR =1,CHWINHR =CHWIN,MSG FLG=0
  24629   "RTN","CHM FA171",16, 0)
  24630   SUBHEAD S  DY=5,$Y=DY ,FLD=1 D F LDLNG S DX =CFDX,$X=D X X XY W @ CHULON,"   DOS   "
  24631   "RTN","CHM FA171",17, 0)
  24632    S FLD=2 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "POS "
  24633   "RTN","CHM FA171",18, 0)
  24634    S FLD=3 D  FLDLNG S  DX=CFDX,$X =DX X XY W  " ICD "   ; ICD-10 R CS -lg
  24635   "RTN","CHM FA171",19, 0)
  24636    S FLD=4 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "Rev"
  24637   "RTN","CHM FA171",20, 0)
  24638    S FLD=5 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "SVCS "
  24639   "RTN","CHM FA171",21, 0)
  24640    S FLD=6 D  FLDLNG S  DX=CFDX,$X =DX X XY W  " MOD "
  24641   "RTN","CHM FA171",22, 0)
  24642    S DX=49,$ X=DX X XY  W "  Descr iption  "
  24643   "RTN","CHM FA171",23, 0)
  24644    S FLD=7 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "Unts"
  24645   "RTN","CHM FA171",24, 0)
  24646    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX X XY W  " Amount   ",@CHULOF F
  24647   "RTN","CHM FA171",25, 0)
  24648    S DY=15,$ Y=DY,DX=64 ,$X=DX X X Y W @CHBON ,"TOTAL:   ",@CHBOFF 
  24649   "RTN","CHM FA171",26, 0)
  24650    S ROW=1,U ="^"
  24651   "RTN","CHM FA171",27, 0)
  24652    I $D(^UTI LITY($J,"C HDME",BEN) ) S CHLR=9 99999999,C HLR=$O(^UT ILITY($J," CHDME",BEN ,CHLR),-1)
  24653   "RTN","CHM FA171",28, 0)
  24654    I '$D(^UT ILITY($J," CHDME",BEN )) D NEWRO W
  24655   "RTN","CHM FA171",29, 0)
  24656    Q
  24657   "RTN","CHM FA171",30, 0)
  24658    ;
  24659   "RTN","CHM FA171",31, 0)
  24660   TOTAL S DX =72,$X=DX, DY=15,$Y=D Y S:'$D(CH SUM) CHSUM =0
  24661   "RTN","CHM FA171",32, 0)
  24662    U 0:0:"^% X364" X XY  W @CHBON, $J(CHSUM,9 ,2),@CHBOF F Q    ;SK D,5-31-05
  24663   "RTN","CHM FA171",33, 0)
  24664   ENTEDT ; 
  24665   "RTN","CHM FA171",34, 0)
  24666    S CHWINLR =1,CHWINHR =CHWIN,ROW =1,FLD=0,C HVAR="^UTI LITY($J,"" CHDME"",BE N,ROW,FLD) ",CHSUM=0
  24667   "RTN","CHM FA171",35, 0)
  24668    I $P(^UTI LITY($J,"C HDME",BEN, 1,1),U)'=" " D REDISP  G ENT1
  24669   "RTN","CHM FA171",36, 0)
  24670    S DY=CHSD Y,$Y=DY,MS GFLG=0 D F LDLNG S DX =CFDX,$X=D X
  24671   "RTN","CHM FA171",37, 0)
  24672   ENT0 S $P( ^UTILITY($ J,"CHDME", BEN,ROW,FL D),U,1)=RO W
  24673   "RTN","CHM FA171",38, 0)
  24674    I FLD=8 X  XY W $J($ FN($P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U ,1),"",2), FL)
  24675   "RTN","CHM FA171",39, 0)
  24676    E  X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)
  24677   "RTN","CHM FA171",40, 0)
  24678    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX
  24679   "RTN","CHM FA171",41, 0)
  24680   ENT1 I CHS UM'=$$SUMD ME() S CHS UM=$$SUMDM E() D
  24681   "RTN","CHM FA171",42, 0)
  24682    . S SVFLD =FLD,FLD=8  D CURSAV, FLDLNG S D X=CFDX,$X= DX,DY=15,$ Y=DY
  24683   "RTN","CHM FA171",43, 0)
  24684    . X XY W  @CHBON,$J( CHSUM,FL,2 ),@CHBOFF  S FLD=SVFL D D FLDLNG  D CURRES  X XY
  24685   "RTN","CHM FA171",44, 0)
  24686    S CHDB=^U TILITY($J, "CHDME",BE N,ROW,FLD)
  24687   "RTN","CHM FA171",45, 0)
  24688    S SFLD=0
  24689   "RTN","CHM FA171",46, 0)
  24690    I FLD=8 X  XY W $J($ FN($P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U ,1),"",2), FL)
  24691   "RTN","CHM FA171",47, 0)
  24692    E  X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)
  24693   "RTN","CHM FA171",48, 0)
  24694    I FLD=2 D :$P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U)' ="" CURSAV ,DES1,CURR ES
  24695   "RTN","CHM FA171",49, 0)
  24696    I FLD=3!( FLD=5) D:$ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U)'=" " CURSAV,D ESCRP,CURR ES
  24697   "RTN","CHM FA171",50, 0)
  24698    I FLD=6 D :$P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U)' ="" CURSAV ,DES1,CURR ES
  24699   "RTN","CHM FA171",51, 0)
  24700    X XY D CS BRS^CHSC2
  24701   "RTN","CHM FA171",52, 0)
  24702    S CHLF=8  I $P(^UTIL ITY($J,"CH DME",BEN,R OW,3),U)'= "" S CHLF= 3
  24703   "RTN","CHM FA171",53, 0)
  24704    I $D(DFOU T) W *7 G  ENT1
  24705   "RTN","CHM FA171",54, 0)
  24706    I $D(DUOU T) W *7 G  ENT1
  24707   "RTN","CHM FA171",55, 0)
  24708    I Y'="" S  CHDB=""
  24709   "RTN","CHM FA171",56, 0)
  24710    S:Y=""&(^ UTILITY($J ,"CHDME",B EN,ROW,FLD )'="") Y=$ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U,1)
  24711   "RTN","CHM FA171",57, 0)
  24712    S LNTAG=" GETF"_FLD_ "^CHMFA172 " D @LNTAG
  24713   "RTN","CHM FA171",58, 0)
  24714    I SFLD G  ENT1
  24715   "RTN","CHM FA171",59, 0)
  24716    S ^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD)=Y
  24717   "RTN","CHM FA171",60, 0)
  24718    I ^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD)'=CHD B D
  24719   "RTN","CHM FA171",61, 0)
  24720    .X XY W $ J($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U, 1),FL)
  24721   "RTN","CHM FA171",62, 0)
  24722    .I FLD=2  D:$P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U) '="" CURSA V,DES1,CUR RES
  24723   "RTN","CHM FA171",63, 0)
  24724    .I FLD=3! (FLD=5) D: $P(^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD),U)'= "" CURSAV, DESCRP,CUR RES,ICDFIL
  24725   "RTN","CHM FA171",64, 0)
  24726    .I FLD=6  D:$P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U) '="" CURSA V,DES1,CUR RES,ICDFIL
  24727   "RTN","CHM FA171",65, 0)
  24728    .X XY
  24729   "RTN","CHM FA171",66, 0)
  24730    I $D(DDOU T) D EXIT  Q:$D(CHMFN EXT)  Q:$D (CHMFPREV)   Q:$D(CHM FKILL)  Q: $D(CHMFNEW B)  G ENT1
  24731   "RTN","CHM FA171",67, 0)
  24732    I ROW=1&$ D(D1OUT) W  *7 G ENT1
  24733   "RTN","CHM FA171",68, 0)
  24734    I ROW>1&$ D(D1OUT) D  UP D FLDL NG,CLRMSG  G ENT1
  24735   "RTN","CHM FA171",69, 0)
  24736    I $D(D4OU T)&(FLD'>1 ) S FLD=CH LF D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  24737   "RTN","CHM FA171",70, 0)
  24738    I $D(D4OU T)&(FLD>1)  S FLD=FLD -1 D  D FL DLNG,CLRMS G S DX=CFD X,$X=DX G  ENT1
  24739   "RTN","CHM FA171",71, 0)
  24740    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD-1
  24741   "RTN","CHM FA171",72, 0)
  24742    I $D(D3OU T)&(FLD'<C HLF) S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  24743   "RTN","CHM FA171",73, 0)
  24744    I $D(D3OU T)&(FLD<CH LF) S FLD= FLD+1 D  D  FLDLNG,CL RMSG S DX= CFDX,$X=DX  G ENT1
  24745   "RTN","CHM FA171",74, 0)
  24746    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  24747   "RTN","CHM FA171",75, 0)
  24748    I $D(DPOU T) D PREV  D FLDLNG,C LRMSG G EN T1
  24749   "RTN","CHM FA171",76, 0)
  24750    I $D(DNOU T) D NEXT  D FLDLNG,C LRMSG G EN T1
  24751   "RTN","CHM FA171",77, 0)
  24752    ; D2OUT O R CR
  24753   "RTN","CHM FA171",78, 0)
  24754    I '$D(D2O UT)&(FLD<C HLF) S FLD =FLD+1 D   D FLDLNG,C LRMSG S DX =CFDX,$X=D X G ENT1
  24755   "RTN","CHM FA171",79, 0)
  24756    .I FLD=4  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  24757   "RTN","CHM FA171",80, 0)
  24758    I '$D(D2O UT)&(FLD'< CHLF)&(ROW '=CHLR) D  DOWN S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  24759   "RTN","CHM FA171",81, 0)
  24760    I ROW=CHL R D DOWN S  FLD=0 D F LDLNG,CLRM SG S DX=CF DX,$X=DX G  ENT0
  24761   "RTN","CHM FA171",82, 0)
  24762    D DOWN S: ^UTILITY($ J,"CHDME", BEN,ROW,1) ="" FLD=1  D FLDLNG,C LRMSG S DX =CFDX,$X=D X G ENT1
  24763   "RTN","CHM FA171",83, 0)
  24764    Q
  24765   "RTN","CHM FA171",84, 0)
  24766    ;
  24767   "RTN","CHM FA171",85, 0)
  24768   SUMDME() ; SUMS ARRAY  DME
  24769   "RTN","CHM FA171",86, 0)
  24770    N SUM,R
  24771   "RTN","CHM FA171",87, 0)
  24772    S SUM=0
  24773   "RTN","CHM FA171",88, 0)
  24774    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,8)) Q  SUM
  24775   "RTN","CHM FA171",89, 0)
  24776    S R=0
  24777   "RTN","CHM FA171",90, 0)
  24778    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) Q :'R  S SUM =SUM+^UTIL ITY($J,"CH DME",BEN,R ,8)
  24779   "RTN","CHM FA171",91, 0)
  24780    Q SUM
  24781   "RTN","CHM FA171",92, 0)
  24782    ;
  24783   "RTN","CHM FA171",93, 0)
  24784   DESCRP S D X=49,$X=DX
  24785   "RTN","CHM FA171",94, 0)
  24786    K BF S BF ="",$P(BF, " ",16)=""  X XY W BF
  24787   "RTN","CHM FA171",95, 0)
  24788    K BF S BF ="",$P(BF, " ",FL+1)= ""
  24789   "RTN","CHM FA171",96, 0)
  24790    X XY W $E ($P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U,3 ),1,15)
  24791   "RTN","CHM FA171",97, 0)
  24792   DES1 D ERA MSG
  24793   "RTN","CHM FA171",98, 0)
  24794    S HOLDDY= DY
  24795   "RTN","CHM FA171",99, 0)
  24796    S $P(STR, " ",64)=""
  24797   "RTN","CHM FA171",100 ,0)
  24798    S DX=1,$X =DX,DY=15, $Y=DY X XY  W STR X X Y
  24799   "RTN","CHM FA171",101 ,0)
  24800    W $E($P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),U,3),1,6 2)
  24801   "RTN","CHM FA171",102 ,0)
  24802    S MSGFLG= 1
  24803   "RTN","CHM FA171",103 ,0)
  24804    Q
  24805   "RTN","CHM FA171",104 ,0)
  24806    ;
  24807   "RTN","CHM FA171",105 ,0)
  24808   ICDFIL I F LD=3 S CHL F=3 D
  24809   "RTN","CHM FA171",106 ,0)
  24810    .F FLD=4: 1:8 S ^UTI LITY($J,"C HDME",BEN, ROW,FLD)=" "
  24811   "RTN","CHM FA171",107 ,0)
  24812    .F FLD=4: 1:8 D FLDL NG S DX=CF DX,$X=DX X  XY W $J($ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U,1), FL)
  24813   "RTN","CHM FA171",108 ,0)
  24814    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX
  24815   "RTN","CHM FA171",109 ,0)
  24816    I FLD=5 S  CHLF=8 D
  24817   "RTN","CHM FA171",110 ,0)
  24818    .S ^UTILI TY($J,"CHD ME",BEN,RO W,3)=""
  24819   "RTN","CHM FA171",111 ,0)
  24820    .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)
  24821   "RTN","CHM FA171",112 ,0)
  24822    .S FLD=5  D FLDLNG S  DX=CFDX,$ X=DX
  24823   "RTN","CHM FA171",113 ,0)
  24824    I FLD=6 S  CHLF=8 D
  24825   "RTN","CHM FA171",114 ,0)
  24826    .S ^UTILI TY($J,"CHD ME",BEN,RO W,3)=""
  24827   "RTN","CHM FA171",115 ,0)
  24828    .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)
  24829   "RTN","CHM FA171",116 ,0)
  24830    .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)
  24831   "RTN","CHM FA171",117 ,0)
  24832    .S FLD=6  D FLDLNG S  DX=CFDX,$ X=DX
  24833   "RTN","CHM FA171",118 ,0)
  24834    Q
  24835   "RTN","CHM FA171",119 ,0)
  24836    ;
  24837   "RTN","CHM FA171",120 ,0)
  24838   EDITOK ;MO DIFIED BY  DTP TO SKI P REV CODE  EDITS ON  PAPER, BUT  NOT EDI I N LAST LIN E OF SUBRT N
  24839   "RTN","CHM FA171",121 ,0)
  24840    Q:'$D(CHM FPDI)
  24841   "RTN","CHM FA171",122 ,0)
  24842    S X=$$TYP E^CHMFPDI2 (CHMFPDI)
  24843   "RTN","CHM FA171",123 ,0)
  24844    S PT=0,PT =$O(^CHMDI C(741002.9 3,"C",X,PT ))
  24845   "RTN","CHM FA171",124 ,0)
  24846    Q:'PT  Q: '$D(^CHMDI C(741002.9 3,PT,0))
  24847   "RTN","CHM FA171",125 ,0)
  24848    S PTR=$P( ^(0),"^",3 )
  24849   "RTN","CHM FA171",126 ,0)
  24850    Q:'PTR  Q :'$D(^CHMD IC(741002. 94,PTR,2))
  24851   "RTN","CHM FA171",127 ,0)
  24852    S:$P(^(2) ,"^",PC) N OEDIT=1
  24853   "RTN","CHM FA171",128 ,0)
  24854    I (PC=2)& ($E(X,1,1) =9) K NOED IT
  24855   "RTN","CHM FA171",129 ,0)
  24856    Q
  24857   "RTN","CHM FA171",130 ,0)
  24858    ; 
  24859   "RTN","CHM FA171",131 ,0)
  24860   BEEPQ X XY  W BF X XY  W *7,"??"  X XY W BF
  24861   "RTN","CHM FA171",132 ,0)
  24862    Q
  24863   "RTN","CHM FA171",133 ,0)
  24864    ;
  24865   "RTN","CHM FA171",134 ,0)
  24866   FLDLNG S F L=$S(FLD=0 :3,FLD=1:8 ,FLD=2:4,F LD=3:6,FLD =4:3,FLD=5 :5,FLD=6:5 ,FLD=7:4,F LD=8:9,1:1 )
  24867   "RTN","CHM FA171",135 ,0)
  24868    S CFDX=$S (FLD=0:1,F LD=1:6,FLD =2:16,FLD= 3:22,FLD=4 :30,FLD=5: 35,FLD=6:4 2,FLD=7:66 ,FLD=8:72, 1:1)
  24869   "RTN","CHM FA171",136 ,0)
  24870    K BF S BF ="",$P(BF, " ",FL+1)= ""
  24871   "RTN","CHM FA171",137 ,0)
  24872    Q
  24873   "RTN","CHM FA171",138 ,0)
  24874    ;
  24875   "RTN","CHM FA171",139 ,0)
  24876   REPEAT X X Y W BF
  24877   "RTN","CHM FA171",140 ,0)
  24878    I $E(Y)=" /" D DIVID E
  24879   "RTN","CHM FA171",141 ,0)
  24880    S STOP=$E (Y,2,$L(Y) )+(ROW-2), START=ROW, DY=DY-1,$Y =DY F ROW1 =START:1:S TOP D
  24881   "RTN","CHM FA171",142 ,0)
  24882    .S ^UTILI TY($J,"CHD ME",BEN,RO W1,0)=ROW1  F FLD=1:1 :8 S ^UTIL ITY($J,"CH DME",BEN,R OW1,FLD)=^ UTILITY($J ,"CHDME",B EN,ROW-1,F LD)
  24883   "RTN","CHM FA171",143 ,0)
  24884    .S DY=DY+ 1,$Y=DY I  DY=(CHSDY+ CHWIN) D
  24885   "RTN","CHM FA171",144 ,0)
  24886    .. S DY=C HSDY+CHWIN -1,$Y=DY,C HWINLR=CHW INLR+1,CHW INHR=CHWIN HR+1
  24887   "RTN","CHM FA171",145 ,0)
  24888    .. S DX=1 ,$X=DX X X Y W !
  24889   "RTN","CHM FA171",146 ,0)
  24890    .F FLD=0: 1:8 D FLDL NG S DX=CF DX,$X=DX X  XY W $J($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,FL)
  24891   "RTN","CHM FA171",147 ,0)
  24892    .F FLD=3, 5 D:$P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U)'=""
  24893   "RTN","CHM FA171",148 ,0)
  24894    ..S DX=49 ,$X=DX
  24895   "RTN","CHM FA171",149 ,0)
  24896    ..K BF S  BF="",$P(B F," ",16)= "" X XY W  BF
  24897   "RTN","CHM FA171",150 ,0)
  24898    ..X XY W  $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,3),1,15)
  24899   "RTN","CHM FA171",151 ,0)
  24900    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  24901   "RTN","CHM FA171",152 ,0)
  24902    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1,$ Y=DY
  24903   "RTN","CHM FA171",153 ,0)
  24904    S SFLD=1
  24905   "RTN","CHM FA171",154 ,0)
  24906   REPEND Q
  24907   "RTN","CHM FA171",155 ,0)
  24908    ;
  24909   "RTN","CHM FA171",156 ,0)
  24910   DIVIDE S Y 1=^UTILITY ($J,"CHDME ",BEN,ROW- 1,8)/$E(Y, 2,$L(Y))
  24911   "RTN","CHM FA171",157 ,0)
  24912    S Y1=$J(Y 1,$L($P(Y1 ,".",1))+3 ,2)
  24913   "RTN","CHM FA171",158 ,0)
  24914    I ^UTILIT Y($J,"CHDM E",BEN,ROW -1,3)'=""  S Y1=""
  24915   "RTN","CHM FA171",159 ,0)
  24916    S ^UTILIT Y($J,"CHDM E",BEN,ROW -1,8)=Y1
  24917   "RTN","CHM FA171",160 ,0)
  24918    D CURSAV
  24919   "RTN","CHM FA171",161 ,0)
  24920    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX,DY=DY- 1,$Y=DY
  24921   "RTN","CHM FA171",162 ,0)
  24922    X XY W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W-1,FLD),U ,1),FL)
  24923   "RTN","CHM FA171",163 ,0)
  24924    D CURRES
  24925   "RTN","CHM FA171",164 ,0)
  24926    X XY
  24927   "RTN","CHM FA171",165 ,0)
  24928    Q
  24929   "RTN","CHM FA171",166 ,0)
  24930    ;
  24931   "RTN","CHM FA171",167 ,0)
  24932   REDISP S D Y=CHSDY-1, $Y=DY F RO W1=1:1:CHL R D
  24933   "RTN","CHM FA171",168 ,0)
  24934    .S DY=DY+ 1,$Y=DY I  DY=(CHSDY+ CHWIN) D
  24935   "RTN","CHM FA171",169 ,0)
  24936    .. S DY=C HSDY+CHWIN -1,$Y=DY,C HWINLR=CHW INLR+1,CHW INHR=CHWIN HR+1
  24937   "RTN","CHM FA171",170 ,0)
  24938    .. S DX=1 ,$X=DX X X Y W !
  24939   "RTN","CHM FA171",171 ,0)
  24940    .; CPE005 -009 Frequ ency code  5.  Add bo lding to o riginal it ems
  24941   "RTN","CHM FA171",172 ,0)
  24942    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,0)," ^",2)=1 W  @CHBON ;CP E005-009 B DB
  24943   "RTN","CHM FA171",173 ,0)
  24944    .I $P(^UT ILITY($J," CHDME",BEN ,ROW1,0)," ^",2)'=1 W  @CHBOFF ; CPE005-009  BDB
  24945   "RTN","CHM FA171",174 ,0)
  24946    .F FLD=0: 1:8 D FLDL NG S DX=CF DX,$X=DX X  XY D
  24947   "RTN","CHM FA171",175 ,0)
  24948    ..Q:^UTIL ITY($J,"CH DME",BEN,R OW1,FLD)=" "
  24949   "RTN","CHM FA171",176 ,0)
  24950    ..I FLD=8  W $J($FN( $P(^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD),U,1 ),"",2),FL )
  24951   "RTN","CHM FA171",177 ,0)
  24952    ..E  W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1),FL)
  24953   "RTN","CHM FA171",178 ,0)
  24954    .F FLD=3, 5 D:$P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U)'=""
  24955   "RTN","CHM FA171",179 ,0)
  24956    ..S DX=49 ,$X=DX
  24957   "RTN","CHM FA171",180 ,0)
  24958    ..K BF S  BF="",$P(B F," ",16)= "" X XY W  BF
  24959   "RTN","CHM FA171",181 ,0)
  24960    ..X XY W  $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,3),1,15)
  24961   "RTN","CHM FA171",182 ,0)
  24962    W @CHBOFF
  24963   "RTN","CHM FA171",183 ,0)
  24964    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  24965   "RTN","CHM FA171",184 ,0)
  24966    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1,$ Y=DY
  24967   "RTN","CHM FA171",185 ,0)
  24968    S SFLD=1
  24969   "RTN","CHM FA171",186 ,0)
  24970    Q
  24971   "RTN","CHM FA171",187 ,0)
  24972    ;
  24973   "RTN","CHM FA171",188 ,0)
  24974   EXIT D CUR SAV,ERAMSG
  24975   "RTN","CHM FA171",189 ,0)
  24976   E1 D PRMPT ^CHMFA170, ASK^CHMFA1 70
  24977   "RTN","CHM FA171",190 ,0)
  24978    I $D(DFOU T)!$D(DUOU T) G E1
  24979   "RTN","CHM FA171",191 ,0)
  24980    K CHMFNEX T,CHMFPREV ,CHMFKILL, CHMFNEWB
  24981   "RTN","CHM FA171",192 ,0)
  24982    S:Y=2 CHM FNEXT=1 S: Y=3 CHMFPR EV=1 S:Y=4  CHMFKILL= 1
  24983   "RTN","CHM FA171",193 ,0)
  24984    I Y=5 D ^ CHMFA174,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  24985   "RTN","CHM FA171",194 ,0)
  24986    I Y=8 D D ELSVCLN^CH MFAUTL K:$ D(CHMFNEXT ) CHMFNEXT  K:$D(CHMF PREV) CHMF PREV D INI T^CHMFA170 ,SETSCR^CH MFA170,INI T,TOTAL,EN TEDT Q   ; SKD, 6-14- 07, DEV000 197
  24987   "RTN","CHM FA171",195 ,0)
  24988    I Y=9 D ^ CHMFA02B,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  24989   "RTN","CHM FA171",196 ,0)
  24990    I $D(CHMF NEXT) I $D (^CHMDIC(7 41002.21,D UZ,0)) I ' $P(^(0),"^ ",14) D  I  '$D(CHMFN EXT) D ERA MSG G E1
  24991   "RTN","CHM FA171",197 ,0)
  24992   E2 .S HY=D Y,HX=DX,DY =19,$Y=DY, DX=20,$X=D X X XY
  24993   "RTN","CHM FA171",198 ,0)
  24994    .;CCSE CP E005-012 G EF 6/7/17  - remove p ress retur n to conti nue prompt
  24995   "RTN","CHM FA171",199 ,0)
  24996    .;W "Are  you sure y ou want to  continue:  " D CSBRS ^CHSC2
  24997   "RTN","CHM FA171",200 ,0)
  24998    .;I $D(DU OUT) K CHM FNEXT Q
  24999   "RTN","CHM FA171",201 ,0)
  25000    .;I $D(DF OUT) K CHM FNEXT Q
  25001   "RTN","CHM FA171",202 ,0)
  25002    .;G:Y=""  E2 S Y=$E( Y) G:"YNyn "'[Y E2
  25003   "RTN","CHM FA171",203 ,0)
  25004    .;I "Nn"[ Y K CHMFNE XT
  25005   "RTN","CHM FA171",204 ,0)
  25006    .S DY=HY, $Y=DY,DX=H X,$X=DX
  25007   "RTN","CHM FA171",205 ,0)
  25008    D CURRES  D FLDLNG
  25009   "RTN","CHM FA171",206 ,0)
  25010    Q
  25011   "RTN","CHM FA171",207 ,0)
  25012    ;
  25013   "RTN","CHM FA171",208 ,0)
  25014   DOWN D CUR SAV
  25015   "RTN","CHM FA171",209 ,0)
  25016    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
  25017   "RTN","CHM FA171",210 ,0)
  25018    S CHCF=FL D,DY=DY+1, $Y=DY,ROW= ROW+1
  25019   "RTN","CHM FA171",211 ,0)
  25020    I '$D(^UT ILITY($J," CHDME",BEN ,ROW)) D N EWROW
  25021   "RTN","CHM FA171",212 ,0)
  25022    I DY=(CHS DY+CHWIN)  D UPSCRL
  25023   "RTN","CHM FA171",213 ,0)
  25024   DOWNEND Q
  25025   "RTN","CHM FA171",214 ,0)
  25026    ;
  25027   "RTN","CHM FA171",215 ,0)
  25028   NEWROW F F LD=0:1:8 S  ^UTILITY( $J,"CHDME" ,BEN,ROW,F LD)="" S:F LD=7 ^UTIL ITY($J,"CH DME",BEN,R OW,FLD)=1
  25029   "RTN","CHM FA171",216 ,0)
  25030    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)
  25031   "RTN","CHM FA171",217 ,0)
  25032    S CHLR=RO W
  25033   "RTN","CHM FA171",218 ,0)
  25034    Q
  25035   "RTN","CHM FA171",219 ,0)
  25036    ;
  25037   "RTN","CHM FA171",220 ,0)
  25038   UP D CURSA V
  25039   "RTN","CHM FA171",221 ,0)
  25040    S CHCF=FL D,DY=DY-1, $Y=DY,ROW= ROW-1
  25041   "RTN","CHM FA171",222 ,0)
  25042    I DY<CHSD Y D DNSCRL
  25043   "RTN","CHM FA171",223 ,0)
  25044    Q
  25045   "RTN","CHM FA171",224 ,0)
  25046    ;
  25047   "RTN","CHM FA171",225 ,0)
  25048   DNSCRL S D Y=CHSDY,$Y =DY,CHWINL R=CHWINLR- 1,CHWINHR= CHWINHR-1
  25049   "RTN","CHM FA171",226 ,0)
  25050    S ROW1=CH WINLR-1
  25051   "RTN","CHM FA171",227 ,0)
  25052   DN1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1)) G:'RO W1 DN2  G: ROW1>CHWIN HR DN2
  25053   "RTN","CHM FA171",228 ,0)
  25054    S DX=1,$X =DX,DY=CHS DY,$Y=DY X  XY W @CHI NSL
  25055   "RTN","CHM FA171",229 ,0)
  25056    F FLD=0:1 :8 D FLDLN G S DX=CFD X,$X=DX X  XY D
  25057   "RTN","CHM FA171",230 ,0)
  25058    .I FLD=0  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,0),"^" ,2)=1 W @C HBON ;CPE0 05-009 BDB  08202017
  25059   "RTN","CHM FA171",231 ,0)
  25060    .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
  25061   "RTN","CHM FA171",232 ,0)
  25062    .I FLD'=8  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),FL )
  25063   "RTN","CHM FA171",233 ,0)
  25064    .I FLD=8  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)'="" D
  25065   "RTN","CHM FA171",234 ,0)
  25066    ..W $J($F N($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1),"",2), FL)
  25067   "RTN","CHM FA171",235 ,0)
  25068    F FLD=3,5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  25069   "RTN","CHM FA171",236 ,0)
  25070    .S DX=49, $X=DX
  25071   "RTN","CHM FA171",237 ,0)
  25072    .K BF S B F="",$P(BF ," ",16)=" " X XY W B F
  25073   "RTN","CHM FA171",238 ,0)
  25074    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,15)
  25075   "RTN","CHM FA171",239 ,0)
  25076   DN2 D CURR ES S FLD=C HCF
  25077   "RTN","CHM FA171",240 ,0)
  25078    Q
  25079   "RTN","CHM FA171",241 ,0)
  25080    ;
  25081   "RTN","CHM FA171",242 ,0)
  25082   UPSCRL S D Y=CHSDY+CH WIN-1,$Y=D Y,CHWINLR= CHWINLR+1, CHWINHR=CH WINHR+1
  25083   "RTN","CHM FA171",243 ,0)
  25084    S ROW1=CH WINHR+1
  25085   "RTN","CHM FA171",244 ,0)
  25086   UP1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1),-1) G: 'ROW1 UP2   G:ROW1<CH WINLR UP2
  25087   "RTN","CHM FA171",245 ,0)
  25088    S DX=1,$X =DX X XY W  !
  25089   "RTN","CHM FA171",246 ,0)
  25090    F FLD=0:1 :8 D FLDLN G S DX=CFD X,$X=DX X  XY D
  25091   "RTN","CHM FA171",247 ,0)
  25092    .I FLD=0  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,0),"^" ,2)=1 W @C HBON ;CPE0 05-009 BDB  08202017
  25093   "RTN","CHM FA171",248 ,0)
  25094    .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
  25095   "RTN","CHM FA171",249 ,0)
  25096    .I FLD'=8  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),FL )
  25097   "RTN","CHM FA171",250 ,0)
  25098    .I FLD=8  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)'="" D
  25099   "RTN","CHM FA171",251 ,0)
  25100    ..W $J($F N($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1),"",2), FL)
  25101   "RTN","CHM FA171",252 ,0)
  25102    F FLD=3,5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  25103   "RTN","CHM FA171",253 ,0)
  25104    .S DX=49, $X=DX
  25105   "RTN","CHM FA171",254 ,0)
  25106    .K BF S B F="",$P(BF ," ",16)=" " X XY W B F
  25107   "RTN","CHM FA171",255 ,0)
  25108    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,15)
  25109   "RTN","CHM FA171",256 ,0)
  25110   UP2 D CURR ES S FLD=C HCF
  25111   "RTN","CHM FA171",257 ,0)
  25112    Q
  25113   "RTN","CHM FA171",258 ,0)
  25114    ;
  25115   "RTN","CHM FA171",259 ,0)
  25116   PREV I CHW INLR<2 W * 7 Q
  25117   "RTN","CHM FA171",260 ,0)
  25118    S CHCDX=D X,CHCF=FLD
  25119   "RTN","CHM FA171",261 ,0)
  25120    S CHWINLR =CHWINLR-C HWIN S:CHW INLR<1 CHW INLR=1
  25121   "RTN","CHM FA171",262 ,0)
  25122    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,$Y =DY,ROW1=C HWINLR-1
  25123   "RTN","CHM FA171",263 ,0)
  25124   P1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) G:'ROW 1 P2 G:ROW 1>CHWINHR  P2
  25125   "RTN","CHM FA171",264 ,0)
  25126    S DX=1,$X =DX X XY W  @CHEOL
  25127   "RTN","CHM FA171",265 ,0)
  25128    F FLD=0:1 :8 D FLDLN G S DX=CFD X,$X=DX X  XY D
  25129   "RTN","CHM FA171",266 ,0)
  25130    .I FLD'=8  W $J($P(^ UTILITY($J ,"CHDME",B EN,ROW1,FL D),U,1),FL )
  25131   "RTN","CHM FA171",267 ,0)
  25132    .I FLD=8  I $P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1)'="" D
  25133   "RTN","CHM FA171",268 ,0)
  25134    ..W $J($F N($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,1),"",2), FL)
  25135   "RTN","CHM FA171",269 ,0)
  25136    F FLD=3,5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  25137   "RTN","CHM FA171",270 ,0)
  25138    .S DX=49, $X=DX
  25139   "RTN","CHM FA171",271 ,0)
  25140    .K BF S B F="",$P(BF ," ",16)=" " X XY W B F
  25141   "RTN","CHM FA171",272 ,0)
  25142    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,15)
  25143   "RTN","CHM FA171",273 ,0)
  25144    S DY=DY+1 ,$Y=DY G P 1
  25145   "RTN","CHM FA171",274 ,0)
  25146   P2 S DY=CH SDY,$Y=DY, ROW=CHWINL R,DX=CHCDX ,$X=DX,FLD =CHCF
  25147   "RTN","CHM FA171",275 ,0)
  25148    Q
  25149   "RTN","CHM FA171",276 ,0)
  25150    ;
  25151   "RTN","CHM FA171",277 ,0)
  25152   NEXT I '$D (^UTILITY( $J,"CHDME" ,BEN,CHWIN HR+1)) W * 7 Q
  25153   "RTN","CHM FA171",278 ,0)
  25154    S CHCDX=D X,CHCF=FLD
  25155   "RTN","CHM FA171",279 ,0)
  25156    S CHWINLR =CHWINLR+C HWIN S:CHW INLR<1 CHW INLR=1
  25157   "RTN","CHM FA171",280 ,0)
  25158    I CHWINLR +CHWIN>CHL R S CHWINL R=CHLR-(CH WIN-1)
  25159   "RTN","CHM FA171",281 ,0)
  25160    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,$Y =DY,ROW1=C HWINLR-1
  25161   "RTN","CHM FA171",282 ,0)
  25162   N1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) I 'ROW 1 D CLEAR2  G N2
  25163   "RTN","CHM FA171",283 ,0)
  25164    G:ROW1>CH WINHR N2
  25165   "RTN","CHM FA171",284 ,0)
  25166    S DX=1,$X =DX X XY W  @CHEOL
  25167   "RTN","CHM FA171",285 ,0)
  25168    F FLD=0:1 :8 D FLDLN G S DX=CFD X,$X=DX X  XY W $J($P (^UTILITY( $J,"CHDME" ,BEN,ROW1, FLD),U,1), FL)
  25169   "RTN","CHM FA171",286 ,0)
  25170    F FLD=3,5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  25171   "RTN","CHM FA171",287 ,0)
  25172    .S DX=49, $X=DX
  25173   "RTN","CHM FA171",288 ,0)
  25174    .K BF S B F="",$P(BF ," ",16)=" " X XY W B F
  25175   "RTN","CHM FA171",289 ,0)
  25176    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,15)
  25177   "RTN","CHM FA171",290 ,0)
  25178    S DY=DY+1 ,$Y=DY G N 1
  25179   "RTN","CHM FA171",291 ,0)
  25180   N2 S DY=CH SDY,$Y=DY, ROW=CHWINL R,DX=CHCDX ,$X=DX,FLD =CHCF
  25181   "RTN","CHM FA171",292 ,0)
  25182    Q
  25183   "RTN","CHM FA171",293 ,0)
  25184    ;
  25185   "RTN","CHM FA171",294 ,0)
  25186   CLEAR2 S H Y=DY,DX=1, $X=DX F DY =HY:1:CHSD Y+CHWIN-1  S $Y=DY X  XY W @CHEO L
  25187   "RTN","CHM FA171",295 ,0)
  25188    Q
  25189   "RTN","CHM FA171",296 ,0)
  25190    ;
  25191   "RTN","CHM FA171",297 ,0)
  25192   CURSAV S C HCDX=DX,CH CDY=DY
  25193   "RTN","CHM FA171",298 ,0)
  25194    Q
  25195   "RTN","CHM FA171",299 ,0)
  25196    ;
  25197   "RTN","CHM FA171",300 ,0)
  25198   CURRES S D X=CHCDX,$X =DX,DY=CHC DY,$Y=DY
  25199   "RTN","CHM FA171",301 ,0)
  25200    Q
  25201   "RTN","CHM FA171",302 ,0)
  25202    ;
  25203   "RTN","CHM FA171",303 ,0)
  25204   MARSCR ;S  DTM=CHSDY, DBM=CHSDY+ CHWIN-1 X  CHMAR
  25205   "RTN","CHM FA171",304 ,0)
  25206    S DTM=CHS DY,DBM=CHS DY+CHWIN X  CHMAR     ;SKD, 5-31 -05
  25207   "RTN","CHM FA171",305 ,0)
  25208    Q
  25209   "RTN","CHM FA171",306 ,0)
  25210    ;
  25211   "RTN","CHM FA171",307 ,0)
  25212   MARMES S D TM=CHMDY,D BM=20 X CH MAR
  25213   "RTN","CHM FA171",308 ,0)
  25214    Q
  25215   "RTN","CHM FA171",309 ,0)
  25216    ;
  25217   "RTN","CHM FA171",310 ,0)
  25218   ERASCR ;S  DX=1,$X=DX  F DY=CHSD Y:1:CHSDY+ CHWIN-1 S  $Y=DY X XY  W @CHEOL
  25219   "RTN","CHM FA171",311 ,0)
  25220    S DX=1,$X =DX F DY=C HSDY:1:CHS DY+CHWIN S  $Y=DY X X Y W @CHEOL    ;SKD, 5 -31-05
  25221   "RTN","CHM FA171",312 ,0)
  25222    Q
  25223   "RTN","CHM FA171",313 ,0)
  25224    ;
  25225   "RTN","CHM FA171",314 ,0)
  25226   ERAMSG S D X=1,$X=DX  F DY=CHMDY :1:20 S $Y =DY X XY W  @CHEOL
  25227   "RTN","CHM FA171",315 ,0)
  25228    Q
  25229   "RTN","CHM FA171",316 ,0)
  25230    ;
  25231   "RTN","CHM FA171",317 ,0)
  25232   CLRMSG I M SGFLG D CU RSAV,ERAMS G,ERROR,CU RRES S MSG FLG=0
  25233   "RTN","CHM FA171",318 ,0)
  25234    Q
  25235   "RTN","CHM FA171",319 ,0)
  25236   ERROR Q
  25237   "RTN","CHM FA181")
  25238   0^52^B1447 49004
  25239   "RTN","CHM FA181",1,0 )
  25240   CHMFA181 ; DEN/CJM;TR AVEL ENTER /EDIT;01/1 3/99  11:5 0 AM
  25241   "RTN","CHM FA181",2,0 )
  25242    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  25243   "RTN","CHM FA181",3,0 )
  25244    ;;V2.0;
  25245   "RTN","CHM FA181",4,0 )
  25246    ; PT 1593 2 (Y2K), # 16068* (RL C)
  25247   "RTN","CHM FA181",5,0 )
  25248    ;PLEASE N OTE, FIX M ADE SEPARA TELY IN DE V & TRN FO R #16068 A ND MOVED T O
  25249   "RTN","CHM FA181",6,0 )
  25250    ;LIVE FRO M THE TRAI NING ACCOU NT DUE TO  Y2K CHANGE S IN DEV.
  25251   "RTN","CHM FA181",7,0 )
  25252    ;ICD-10 R CS -lg 7/1 0/12
  25253   "RTN","CHM FA181",8,0 )
  25254    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if freq c ode=5 and  display in  bold
  25255   "RTN","CHM FA181",9,0 )
  25256    ;CCSE CPE 005-012 GE F 6/7/17 -  remove pr ess return  to contin ue prompt
  25257   "RTN","CHM FA181",10, 0)
  25258   MAIN D INI T,TOTAL
  25259   "RTN","CHM FA181",11, 0)
  25260   M1 D ENTED T
  25261   "RTN","CHM FA181",12, 0)
  25262   END Q
  25263   "RTN","CHM FA181",13, 0)
  25264    ;
  25265   "RTN","CHM FA181",14, 0)
  25266   INIT S DTM =7,DBM=14, DX=1,$X=DX ,DY=6,$Y=D Y X CHMAR  X XY
  25267   "RTN","CHM FA181",15, 0)
  25268    S CHSDY=6 ,CHMDY=17, CHWIN=8,CH LF=8
  25269   "RTN","CHM FA181",16, 0)
  25270    S CHWINLR =1,CHWINHR =CHWIN,MSG FLG=0
  25271   "RTN","CHM FA181",17, 0)
  25272   SUBHEAD S  DY=5,$Y=DY ,FLD=1 D F LDLNG S DX =CFDX,$X=D X X XY W @ CHULON,"   DOS   "
  25273   "RTN","CHM FA181",18, 0)
  25274    S FLD=2 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "POS "
  25275   "RTN","CHM FA181",19, 0)
  25276    S FLD=3 D  FLDLNG S  DX=CFDX,$X =DX X XY W  " ICD "   ; ICD-10 R CS -lg
  25277   "RTN","CHM FA181",20, 0)
  25278    S FLD=4 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "Rev"
  25279   "RTN","CHM FA181",21, 0)
  25280    S FLD=5 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "SVCS "
  25281   "RTN","CHM FA181",22, 0)
  25282    S FLD=6 D  FLDLNG S  DX=CFDX,$X =DX X XY W  " MOD "
  25283   "RTN","CHM FA181",23, 0)
  25284    S DX=49,$ X=DX X XY  W "  Descr iption  "
  25285   "RTN","CHM FA181",24, 0)
  25286    S FLD=7 D  FLDLNG S  DX=CFDX,$X =DX X XY W  "Unts"
  25287   "RTN","CHM FA181",25, 0)
  25288    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX X XY W  " Amount   ",@CHULOF F
  25289   "RTN","CHM FA181",26, 0)
  25290    S DY=15,$ Y=DY,DX=64 ,$X=DX X X Y W @CHBON ,"TOTAL:   ",@CHBOFF
  25291   "RTN","CHM FA181",27, 0)
  25292    S ROW=1,U ="^"
  25293   "RTN","CHM FA181",28, 0)
  25294    I $D(^UTI LITY($J,"C HDME",BEN) ) S CHLR=9 99999999,C HLR=$O(^UT ILITY($J," CHDME",BEN ,CHLR),-1)
  25295   "RTN","CHM FA181",29, 0)
  25296    I '$D(^UT ILITY($J," CHDME",BEN )) D NEWRO W
  25297   "RTN","CHM FA181",30, 0)
  25298    Q
  25299   "RTN","CHM FA181",31, 0)
  25300    ;
  25301   "RTN","CHM FA181",32, 0)
  25302   TOTAL S DX =72,$X=DX, DY=15,$Y=D Y S:'$D(CH SUM) CHSUM =0
  25303   "RTN","CHM FA181",33, 0)
  25304    X XY W @C HBON,$J(CH SUM,9,2),@ CHBOFF Q
  25305   "RTN","CHM FA181",34, 0)
  25306   ENTEDT S C HWINLR=1,C HWINHR=CHW IN,ROW=1,F LD=0,CHVAR ="^UTILITY ($J,""CHDM E"",BEN,RO W,FLD)",CH SUM=0
  25307   "RTN","CHM FA181",35, 0)
  25308    I $P(^UTI LITY($J,"C HDME",BEN, 1,1),U)'=" " D REDISP  G ENT1
  25309   "RTN","CHM FA181",36, 0)
  25310    S DY=CHSD Y,$Y=DY,MS GFLG=0 D F LDLNG S DX =CFDX,$X=D X
  25311   "RTN","CHM FA181",37, 0)
  25312   ENT0 S $P( ^UTILITY($ J,"CHDME", BEN,ROW,FL D),U,1)=RO W
  25313   "RTN","CHM FA181",38, 0)
  25314    I FLD=8 X  XY W $J($ FN($P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U ,1),"",2), FL)
  25315   "RTN","CHM FA181",39, 0)
  25316    E  X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)
  25317   "RTN","CHM FA181",40, 0)
  25318    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX
  25319   "RTN","CHM FA181",41, 0)
  25320   ENT1 I CHS UM'=$$SUMD ME() S CHS UM=$$SUMDM E() D
  25321   "RTN","CHM FA181",42, 0)
  25322    . S SVFLD =FLD,FLD=8  D CURSAV, FLDLNG S D X=CFDX,$X= DX,DY=15,$ Y=DY
  25323   "RTN","CHM FA181",43, 0)
  25324    . X XY W  @CHBON,$J( CHSUM,FL,2 ),@CHBOFF  S FLD=SVFL D D FLDLNG  D CURRES  X XY
  25325   "RTN","CHM FA181",44, 0)
  25326    S CHDB=^U TILITY($J, "CHDME",BE N,ROW,FLD)
  25327   "RTN","CHM FA181",45, 0)
  25328    S SFLD=0
  25329   "RTN","CHM FA181",46, 0)
  25330    I FLD=8 X  XY W $J($ FN($P(^UTI LITY($J,"C HDME",BEN, ROW,FLD),U ,1),"",2), FL)
  25331   "RTN","CHM FA181",47, 0)
  25332    E  X XY W  $J($P(^UT ILITY($J," CHDME",BEN ,ROW,FLD), U,1),FL)
  25333   "RTN","CHM FA181",48, 0)
  25334    I FLD=2 S  FLD=FLD+1  D FLDLNG, CLRMSG S D X=CFDX,$X= DX G ENT1
  25335   "RTN","CHM FA181",49, 0)
  25336    I FLD=2 D :$P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U)' ="" CURSAV ,DES1,CURR ES
  25337   "RTN","CHM FA181",50, 0)
  25338    I FLD=3!( FLD=5) D:$ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U)'=" " CURSAV,D ESCRP,CURR ES
  25339   "RTN","CHM FA181",51, 0)
  25340    I FLD=6 D :$P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U)' ="" CURSAV ,DES1,CURR ES
  25341   "RTN","CHM FA181",52, 0)
  25342    X XY D CS BRS^CHSC2
  25343   "RTN","CHM FA181",53, 0)
  25344    S CHLF=8  I $D(^UTIL ITY($J,"CH DME",BEN,R OW,3)) D
  25345   "RTN","CHM FA181",54, 0)
  25346    .S:$P(^UT ILITY($J," CHDME",BEN ,ROW,3),U) '="" CHLF= 3
  25347   "RTN","CHM FA181",55, 0)
  25348    .Q
  25349   "RTN","CHM FA181",56, 0)
  25350    I $D(DFOU T) W *7 G  ENT1
  25351   "RTN","CHM FA181",57, 0)
  25352    I $D(DUOU T) W *7 G  ENT1
  25353   "RTN","CHM FA181",58, 0)
  25354    I Y'="" S  CHDB=""
  25355   "RTN","CHM FA181",59, 0)
  25356    S:Y=""&(^ UTILITY($J ,"CHDME",B EN,ROW,FLD )'="") Y=$ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U,1)
  25357   "RTN","CHM FA181",60, 0)
  25358    S LNTAG=" GETF"_FLD_ "^CHMFA182 " D @LNTAG
  25359   "RTN","CHM FA181",61, 0)
  25360    I SFLD G  ENT1
  25361   "RTN","CHM FA181",62, 0)
  25362    S ^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD)=Y
  25363   "RTN","CHM FA181",63, 0)
  25364    I ^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD)'=CHD B D
  25365   "RTN","CHM FA181",64, 0)
  25366    .X XY W $ J($P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U, 1),FL)
  25367   "RTN","CHM FA181",65, 0)
  25368    .I FLD=2  D:$P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U) '="" CURSA V,DES1,CUR RES
  25369   "RTN","CHM FA181",66, 0)
  25370    .I FLD=3! (FLD=5) D: $P(^UTILIT Y($J,"CHDM E",BEN,ROW ,FLD),U)'= "" CURSAV, DESCRP,CUR RES,ICDFIL
  25371   "RTN","CHM FA181",67, 0)
  25372    .I FLD=6  D:$P(^UTIL ITY($J,"CH DME",BEN,R OW,FLD),U) '="" CURSA V,DES1,CUR RES,ICDFIL
  25373   "RTN","CHM FA181",68, 0)
  25374    .X XY
  25375   "RTN","CHM FA181",69, 0)
  25376    I $D(DDOU T) D EXIT  Q:$D(CHMFN EXT)  Q:$D (CHMFPREV)   Q:$D(CHM FKILL)  Q: $D(CHMFNEW B)  G ENT1
  25377   "RTN","CHM FA181",70, 0)
  25378    I ROW=1&$ D(D1OUT) W  *7 G ENT1
  25379   "RTN","CHM FA181",71, 0)
  25380    I ROW>1&$ D(D1OUT) D  UP D FLDL NG,CLRMSG  G ENT1
  25381   "RTN","CHM FA181",72, 0)
  25382    I $D(D4OU T)&(FLD'>1 ) S FLD=CH LF D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  25383   "RTN","CHM FA181",73, 0)
  25384    I $D(D4OU T)&(FLD>1)  S FLD=FLD -1 S:FLD=2  FLD=FLD-1  D  D FLDL NG,CLRMSG  S DX=CFDX, $X=DX G EN T1
  25385   "RTN","CHM FA181",74, 0)
  25386    .I FLD=6  K NOEDIT S  PC=5 D ED ITOK I $D( NOEDIT) S  FLD=FLD-1
  25387   "RTN","CHM FA181",75, 0)
  25388    .I FLD=3  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD-1
  25389   "RTN","CHM FA181",76, 0)
  25390    I $D(D3OU T)&(FLD'<C HLF) S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  25391   "RTN","CHM FA181",77, 0)
  25392    I $D(D3OU T)&(FLD<CH LF) S FLD= FLD+1 D  D  FLDLNG,CL RMSG S DX= CFDX,$X=DX  G ENT1
  25393   "RTN","CHM FA181",78, 0)
  25394    .I FLD=7  K NOEDIT S  PC=5 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  25395   "RTN","CHM FA181",79, 0)
  25396    .I FLD=3  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  25397   "RTN","CHM FA181",80, 0)
  25398    I $D(DPOU T) D PREV  D FLDLNG,C LRMSG G EN T1
  25399   "RTN","CHM FA181",81, 0)
  25400    I $D(DNOU T) D NEXT  D FLDLNG,C LRMSG G EN T1
  25401   "RTN","CHM FA181",82, 0)
  25402    ; D2OUT O R CR
  25403   "RTN","CHM FA181",83, 0)
  25404    I '$D(D2O UT)&(FLD<C HLF) D  S  FLD=FLD+1  D FLDLNG,C LRMSG S DX =CFDX,$X=D X G ENT1
  25405   "RTN","CHM FA181",84, 0)
  25406    .I FLD=1  S ^UTILITY ($J,"CHDME ",BEN,ROW, 2)="AMB^10 ^AMBULANCE "
  25407   "RTN","CHM FA181",85, 0)
  25408    .I FLD=6  K NOEDIT S  PC=5 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  25409   "RTN","CHM FA181",86, 0)
  25410    .I FLD=3  K NOEDIT S  PC=2 D ED ITOK I $D( NOEDIT) S  FLD=FLD+1
  25411   "RTN","CHM FA181",87, 0)
  25412    I '$D(D2O UT)&(FLD'< CHLF)&(ROW '=CHLR) D  DOWN S FLD =1 D FLDLN G,CLRMSG S  DX=CFDX,$ X=DX G ENT 1
  25413   "RTN","CHM FA181",88, 0)
  25414    I ROW=CHL R D DOWN S  FLD=0 D F LDLNG,CLRM SG S DX=CF DX,$X=DX G  ENT0
  25415   "RTN","CHM FA181",89, 0)
  25416    D DOWN S: ^UTILITY($ J,"CHDME", BEN,ROW,1) ="" FLD=1  D FLDLNG,C LRMSG S DX =CFDX,$X=D X G ENT1
  25417   "RTN","CHM FA181",90, 0)
  25418    Q
  25419   "RTN","CHM FA181",91, 0)
  25420    ;
  25421   "RTN","CHM FA181",92, 0)
  25422   SUMDME() ; SUMS ARRAY  DME
  25423   "RTN","CHM FA181",93, 0)
  25424    N SUM,R
  25425   "RTN","CHM FA181",94, 0)
  25426    S SUM=0
  25427   "RTN","CHM FA181",95, 0)
  25428    I '$D(^UT ILITY($J," CHDME",BEN ,ROW,8)) Q  SUM
  25429   "RTN","CHM FA181",96, 0)
  25430    S R=0
  25431   "RTN","CHM FA181",97, 0)
  25432    F  S R=$O (^UTILITY( $J,"CHDME" ,BEN,R)) Q :'R  S SUM =SUM+^UTIL ITY($J,"CH DME",BEN,R ,8)
  25433   "RTN","CHM FA181",98, 0)
  25434    Q SUM
  25435   "RTN","CHM FA181",99, 0)
  25436    ;
  25437   "RTN","CHM FA181",100 ,0)
  25438   DESCRP S D X=49,$X=DX
  25439   "RTN","CHM FA181",101 ,0)
  25440    K BF S BF ="",$P(BF, " ",16)=""  X XY W BF
  25441   "RTN","CHM FA181",102 ,0)
  25442    K BF S BF ="",$P(BF, " ",FL+1)= ""
  25443   "RTN","CHM FA181",103 ,0)
  25444    X XY W $E ($P(^UTILI TY($J,"CHD ME",BEN,RO W,FLD),U,3 ),1,15)
  25445   "RTN","CHM FA181",104 ,0)
  25446   DES1 D ERA MSG
  25447   "RTN","CHM FA181",105 ,0)
  25448    S HOLDDY= DY
  25449   "RTN","CHM FA181",106 ,0)
  25450    S $P(STR, " ",64)=""
  25451   "RTN","CHM FA181",107 ,0)
  25452    S DX=1,$X =DX,DY=15, $Y=DY X XY  W STR X X Y
  25453   "RTN","CHM FA181",108 ,0)
  25454    W $E($P(^ UTILITY($J ,"CHDME",B EN,ROW,FLD ),U,3),1,6 2)
  25455   "RTN","CHM FA181",109 ,0)
  25456    S MSGFLG= 1
  25457   "RTN","CHM FA181",110 ,0)
  25458    Q
  25459   "RTN","CHM FA181",111 ,0)
  25460    ;
  25461   "RTN","CHM FA181",112 ,0)
  25462   ICDFIL I F LD=3 S CHL F=3 D
  25463   "RTN","CHM FA181",113 ,0)
  25464    .F FLD=4: 1:8 S ^UTI LITY($J,"C HDME",BEN, ROW,FLD)=" "
  25465   "RTN","CHM FA181",114 ,0)
  25466    .F FLD=4: 1:8 D FLDL NG S DX=CF DX,$X=DX X  XY W $J($ P(^UTILITY ($J,"CHDME ",BEN,ROW, FLD),U,1), FL)
  25467   "RTN","CHM FA181",115 ,0)
  25468    .S FLD=3  D FLDLNG S  DX=CFDX,$ X=DX
  25469   "RTN","CHM FA181",116 ,0)
  25470    I FLD=5 S  CHLF=8 D
  25471   "RTN","CHM FA181",117 ,0)
  25472    .S ^UTILI TY($J,"CHD ME",BEN,RO W,3)=""
  25473   "RTN","CHM FA181",118 ,0)
  25474    .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)
  25475   "RTN","CHM FA181",119 ,0)
  25476    .S FLD=5  D FLDLNG S  DX=CFDX,$ X=DX
  25477   "RTN","CHM FA181",120 ,0)
  25478    I FLD=6 S  CHLF=8 D
  25479   "RTN","CHM FA181",121 ,0)
  25480    .S ^UTILI TY($J,"CHD ME",BEN,RO W,3)=""
  25481   "RTN","CHM FA181",122 ,0)
  25482    .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)
  25483   "RTN","CHM FA181",123 ,0)
  25484    .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)
  25485   "RTN","CHM FA181",124 ,0)
  25486    .S FLD=6  D FLDLNG S  DX=CFDX,$ X=DX
  25487   "RTN","CHM FA181",125 ,0)
  25488    Q
  25489   "RTN","CHM FA181",126 ,0)
  25490    ;
  25491   "RTN","CHM FA181",127 ,0)
  25492   EDITOK Q:' $D(CHMFPDI )
  25493   "RTN","CHM FA181",128 ,0)
  25494    ;S X=$E(C HMFPDI,6,7 )  ; Y2K
  25495   "RTN","CHM FA181",129 ,0)
  25496    S X=$$TYP E^CHMFPDI2 (CHMFPDI)
  25497   "RTN","CHM FA181",130 ,0)
  25498    S PT=0,PT =$O(^CHMDI C(741002.9 3,"C",X,PT ))
  25499   "RTN","CHM FA181",131 ,0)
  25500    Q:'PT  Q: '$D(^CHMDI C(741002.9 3,PT,0))
  25501   "RTN","CHM FA181",132 ,0)
  25502    S PTR=$P( ^(0),"^",3 )
  25503   "RTN","CHM FA181",133 ,0)
  25504    Q:'PTR  Q :'$D(^CHMD IC(741002. 94,PTR,2))
  25505   "RTN","CHM FA181",134 ,0)
  25506    S:$P(^(2) ,"^",PC) N OEDIT=1
  25507   "RTN","CHM FA181",135 ,0)
  25508    I (PC=2)& ($E(X,1,1) =9) K NOED IT
  25509   "RTN","CHM FA181",136 ,0)
  25510    Q
  25511   "RTN","CHM FA181",137 ,0)
  25512   BEEPQ X XY  W BF X XY  W *7,"??"  X XY W BF
  25513   "RTN","CHM FA181",138 ,0)
  25514    Q
  25515   "RTN","CHM FA181",139 ,0)
  25516    ;
  25517   "RTN","CHM FA181",140 ,0)
  25518   FLDLNG S F L=$S(FLD=0 :3,FLD=1:8 ,FLD=2:4,F LD=3:6,FLD =4:3,FLD=5 :5,FLD=6:5 ,FLD=7:4,F LD=8:9,1:1 )
  25519   "RTN","CHM FA181",141 ,0)
  25520    S CFDX=$S (FLD=0:1,F LD=1:6,FLD =2:16,FLD= 3:22,FLD=4 :30,FLD=5: 35,FLD=6:4 2,FLD=7:66 ,FLD=8:72, 1:1)
  25521   "RTN","CHM FA181",142 ,0)
  25522    K BF S BF ="",$P(BF, " ",FL+1)= ""
  25523   "RTN","CHM FA181",143 ,0)
  25524    Q
  25525   "RTN","CHM FA181",144 ,0)
  25526    ;
  25527   "RTN","CHM FA181",145 ,0)
  25528   REPEAT X X Y W BF
  25529   "RTN","CHM FA181",146 ,0)
  25530    I $E(Y)=" /" D DIVID E
  25531   "RTN","CHM FA181",147 ,0)
  25532    S STOP=$E (Y,2,$L(Y) )+(ROW-2), START=ROW, DY=DY-1,$Y =DY F ROW1 =START:1:S TOP D
  25533   "RTN","CHM FA181",148 ,0)
  25534    .S ^UTILI TY($J,"CHD ME",BEN,RO W1,0)=ROW1  F FLD=1:1 :8 S ^UTIL ITY($J,"CH DME",BEN,R OW1,FLD)=^ UTILITY($J ,"CHDME",B EN,ROW-1,F LD)
  25535   "RTN","CHM FA181",149 ,0)
  25536    .S DY=DY+ 1,$Y=DY I  DY=(CHSDY+ CHWIN) D
  25537   "RTN","CHM FA181",150 ,0)
  25538    .. S DY=C HSDY+CHWIN -1,$Y=DY,C HWINLR=CHW INLR+1,CHW INHR=CHWIN HR+1
  25539   "RTN","CHM FA181",151 ,0)
  25540    .. S DX=1 ,$X=DX X X Y W !
  25541   "RTN","CHM FA181",152 ,0)
  25542    .F FLD=0: 1:8 D FLDL NG S DX=CF DX,$X=DX X  XY W $J($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,FL)
  25543   "RTN","CHM FA181",153 ,0)
  25544    .F FLD=3, 5 D:$P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U)'=""
  25545   "RTN","CHM FA181",154 ,0)
  25546    ..S DX=49 ,$X=DX
  25547   "RTN","CHM FA181",155 ,0)
  25548    ..K BF S  BF="",$P(B F," ",16)= "" X XY W  BF
  25549   "RTN","CHM FA181",156 ,0)
  25550    ..X XY W  $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,3),1,15)
  25551   "RTN","CHM FA181",157 ,0)
  25552    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  25553   "RTN","CHM FA181",158 ,0)
  25554    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1,$ Y=DY
  25555   "RTN","CHM FA181",159 ,0)
  25556    S SFLD=1
  25557   "RTN","CHM FA181",160 ,0)
  25558   REPEND Q
  25559   "RTN","CHM FA181",161 ,0)
  25560    ;
  25561   "RTN","CHM FA181",162 ,0)
  25562   DIVIDE S Y 1=^UTILITY ($J,"CHDME ",BEN,ROW- 1,8)/$E(Y, 2,$L(Y))
  25563   "RTN","CHM FA181",163 ,0)
  25564    S Y1=$J(Y 1,$L($P(Y1 ,".",1))+3 ,2)
  25565   "RTN","CHM FA181",164 ,0)
  25566    I ^UTILIT Y($J,"CHDM E",BEN,ROW -1,3)'=""  S Y1=""
  25567   "RTN","CHM FA181",165 ,0)
  25568    S ^UTILIT Y($J,"CHDM E",BEN,ROW -1,8)=Y1
  25569   "RTN","CHM FA181",166 ,0)
  25570    D CURSAV
  25571   "RTN","CHM FA181",167 ,0)
  25572    S FLD=8 D  FLDLNG S  DX=CFDX,$X =DX,DY=DY- 1,$Y=DY
  25573   "RTN","CHM FA181",168 ,0)
  25574    X XY W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W-1,FLD),U ,1),FL)
  25575   "RTN","CHM FA181",169 ,0)
  25576    D CURRES
  25577   "RTN","CHM FA181",170 ,0)
  25578    X XY
  25579   "RTN","CHM FA181",171 ,0)
  25580    Q
  25581   "RTN","CHM FA181",172 ,0)
  25582    ;
  25583   "RTN","CHM FA181",173 ,0)
  25584   REDISP S D Y=CHSDY-1, $Y=DY F RO W1=1:1:CHL R D
  25585   "RTN","CHM FA181",174 ,0)
  25586    .S DY=DY+ 1,$Y=DY I  DY=(CHSDY+ CHWIN) D
  25587   "RTN","CHM FA181",175 ,0)
  25588    .. S DY=C HSDY+CHWIN -1,$Y=DY,C HWINLR=CHW INLR+1,CHW INHR=CHWIN HR+1
  25589   "RTN","CHM FA181",176 ,0)
  25590    .. S DX=1 ,$X=DX X X Y W !
  25591   "RTN","CHM FA181",177 ,0)
  25592    .; CCSE C PE005-009  GEF 5/2/17  - add ori ginal PDI  charge lin es if freq  code=5 an d display  in bold
  25593   "RTN","CHM FA181",178 ,0)
  25594    .; Check  line numbe r where th e late cha rges end a nd the ori ginal char ges after  that shoul d display  differentl y
  25595   "RTN","CHM FA181",179 ,0)
  25596    .I $D(^UT ILITY($J," CHDME",BEN ,"BL")) W: ROW1>$G(^U TILITY($J, "CHDME",BE N,"BL")) @ CHBON
  25597   "RTN","CHM FA181",180 ,0)
  25598    .F FLD=0: 1:8 D FLDL NG S DX=CF DX,$X=DX X  XY D
  25599   "RTN","CHM FA181",181 ,0)
  25600    ..Q:^UTIL ITY($J,"CH DME",BEN,R OW1,FLD)=" "
  25601   "RTN","CHM FA181",182 ,0)
  25602    ..I FLD=8  W $J($FN( $P(^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD),U,1 ),"",2),FL )
  25603   "RTN","CHM FA181",183 ,0)
  25604    ..E  W $J ($P(^UTILI TY($J,"CHD ME",BEN,RO W1,FLD),U, 1),FL)
  25605   "RTN","CHM FA181",184 ,0)
  25606    .F FLD=3, 5 D:$P(^UT ILITY($J," CHDME",BEN ,ROW1,FLD) ,U)'=""
  25607   "RTN","CHM FA181",185 ,0)
  25608    ..S DX=49 ,$X=DX
  25609   "RTN","CHM FA181",186 ,0)
  25610    ..K BF S  BF="",$P(B F," ",16)= "" X XY W  BF
  25611   "RTN","CHM FA181",187 ,0)
  25612    ..X XY W  $E($P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U,3),1,15)
  25613   "RTN","CHM FA181",188 ,0)
  25614    W @CHBOFF
  25615   "RTN","CHM FA181",189 ,0)
  25616    S FLD=1 D  FLDLNG S  DX=CFDX,$X =DX,ROW=RO W1,CHLR=RO W
  25617   "RTN","CHM FA181",190 ,0)
  25618    S:DY>(CHS DY+CHWIN-1 ) DY=CHSDY +CHWIN-1,$ Y=DY
  25619   "RTN","CHM FA181",191 ,0)
  25620    S SFLD=1
  25621   "RTN","CHM FA181",192 ,0)
  25622    Q
  25623   "RTN","CHM FA181",193 ,0)
  25624    ;
  25625   "RTN","CHM FA181",194 ,0)
  25626   EXIT D CUR SAV,ERAMSG
  25627   "RTN","CHM FA181",195 ,0)
  25628   E1 D PRMPT ^CHMFA180, ASK^CHMFA1 80
  25629   "RTN","CHM FA181",196 ,0)
  25630    I $D(DFOU T)!$D(DUOU T) G E1
  25631   "RTN","CHM FA181",197 ,0)
  25632    K CHMFNEX T,CHMFPREV ,CHMFKILL, CHMFNEWB
  25633   "RTN","CHM FA181",198 ,0)
  25634    S:Y=2 CHM FNEXT=1 S: Y=3 CHMFPR EV=1 S:Y=4  CHMFKILL= 1
  25635   "RTN","CHM FA181",199 ,0)
  25636    I Y=5 D ^ CHMFA184,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  25637   "RTN","CHM FA181",200 ,0)
  25638    I Y=8 D D ELSVCLN^CH MFAUTL K:$ D(CHMFNEXT ) CHMFNEXT  K:$D(CHMF PREV) CHMF PREV D INI T^CHMFA180 ,SETSCR^CH MFA180,INI T,TOTAL,EN TEDT Q   ; SKD, 6-14- 07, DEV000 197
  25639   "RTN","CHM FA181",201 ,0)
  25640    I Y=9 D ^ CHMFA02B,E RAMSG,MARS CR K:$D(CH MFNEXT) CH MFNEXT K:$ D(CHMFPREV ) CHMFPREV
  25641   "RTN","CHM FA181",202 ,0)
  25642    I $D(CHMF NEXT) I $D (^CHMDIC(7 41002.21,D UZ,0)) I ' $P(^(0),"^ ",14) D  I  '$D(CHMFN EXT) D ERA MSG G E1
  25643   "RTN","CHM FA181",203 ,0)
  25644   E2 .S HY=D Y,HX=DX,DY =19,$Y=DY, DX=20,$X=D X X XY
  25645   "RTN","CHM FA181",204 ,0)
  25646    .;CCSE CP E005-012 G EF 6/7/17  - remove p ress retur n to conti nue prompt
  25647   "RTN","CHM FA181",205 ,0)
  25648    .;W "Are  you sure y ou want to  continue:  " D CSBRS ^CHSC2
  25649   "RTN","CHM FA181",206 ,0)
  25650    .;I $D(DU OUT) K CHM FNEXT Q
  25651   "RTN","CHM FA181",207 ,0)
  25652    .;I $D(DF OUT) K CHM FNEXT Q
  25653   "RTN","CHM FA181",208 ,0)
  25654    .;G:Y=""  E2 S Y=$E( Y) G:"YNyn "'[Y E2
  25655   "RTN","CHM FA181",209 ,0)
  25656    .;I "Nn"[ Y K CHMFNE XT
  25657   "RTN","CHM FA181",210 ,0)
  25658    .S DY=HY, $Y=DY,DX=H X,$X=DX
  25659   "RTN","CHM FA181",211 ,0)
  25660    D CURRES  D FLDLNG
  25661   "RTN","CHM FA181",212 ,0)
  25662    Q
  25663   "RTN","CHM FA181",213 ,0)
  25664    ;
  25665   "RTN","CHM FA181",214 ,0)
  25666   DOWN D CUR SAV
  25667   "RTN","CHM FA181",215 ,0)
  25668    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
  25669   "RTN","CHM FA181",216 ,0)
  25670    S CHCF=FL D,DY=DY+1, $Y=DY,ROW= ROW+1
  25671   "RTN","CHM FA181",217 ,0)
  25672    I '$D(^UT ILITY($J," CHDME",BEN ,ROW)) D N EWROW
  25673   "RTN","CHM FA181",218 ,0)
  25674    I DY=(CHS DY+CHWIN)  D UPSCRL
  25675   "RTN","CHM FA181",219 ,0)
  25676   DOWNEND Q
  25677   "RTN","CHM FA181",220 ,0)
  25678    ;
  25679   "RTN","CHM FA181",221 ,0)
  25680   NEWROW F F LD=0:1:8 S  ^UTILITY( $J,"CHDME" ,BEN,ROW,F LD)="" S:F LD=7 ^UTIL ITY($J,"CH DME",BEN,R OW,FLD)=1
  25681   "RTN","CHM FA181",222 ,0)
  25682    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)
  25683   "RTN","CHM FA181",223 ,0)
  25684    S CHLR=RO W
  25685   "RTN","CHM FA181",224 ,0)
  25686    Q
  25687   "RTN","CHM FA181",225 ,0)
  25688    ;
  25689   "RTN","CHM FA181",226 ,0)
  25690   UP D CURSA V
  25691   "RTN","CHM FA181",227 ,0)
  25692    S CHCF=FL D,DY=DY-1, $Y=DY,ROW= ROW-1
  25693   "RTN","CHM FA181",228 ,0)
  25694    I DY<CHSD Y D DNSCRL
  25695   "RTN","CHM FA181",229 ,0)
  25696    Q
  25697   "RTN","CHM FA181",230 ,0)
  25698    ;
  25699   "RTN","CHM FA181",231 ,0)
  25700   DNSCRL S D Y=CHSDY,$Y =DY,CHWINL R=CHWINLR- 1,CHWINHR= CHWINHR-1
  25701   "RTN","CHM FA181",232 ,0)
  25702    S ROW1=CH WINLR-1
  25703   "RTN","CHM FA181",233 ,0)
  25704   DN1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1)) G:'RO W1 DN2  G: ROW1>CHWIN HR DN2
  25705   "RTN","CHM FA181",234 ,0)
  25706    S DX=1,$X =DX,DY=CHS DY,$Y=DY X  XY W @CHI NSL
  25707   "RTN","CHM FA181",235 ,0)
  25708    F FLD=0:1 :8 D FLDLN G S DX=CFD X,$X=DX X  XY
  25709   "RTN","CHM FA181",236 ,0)
  25710    .Q:^UTILI TY($J,"CHD ME",BEN,RO W1,FLD)=""
  25711   "RTN","CHM FA181",237 ,0)
  25712    .I FLD=8  W $J($FN($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,"",2),FL)
  25713   "RTN","CHM FA181",238 ,0)
  25714    .E  W $J( $P(^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD),U,1 ),FL)
  25715   "RTN","CHM FA181",239 ,0)
  25716    F FLD=3,5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  25717   "RTN","CHM FA181",240 ,0)
  25718    .S DX=49, $X=DX
  25719   "RTN","CHM FA181",241 ,0)
  25720    .K BF S B F="",$P(BF ," ",16)=" " X XY W B F
  25721   "RTN","CHM FA181",242 ,0)
  25722    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,15)
  25723   "RTN","CHM FA181",243 ,0)
  25724   DN2 D CURR ES S FLD=C HCF
  25725   "RTN","CHM FA181",244 ,0)
  25726    Q
  25727   "RTN","CHM FA181",245 ,0)
  25728    ;
  25729   "RTN","CHM FA181",246 ,0)
  25730   UPSCRL S D Y=CHSDY+CH WIN-1,$Y=D Y,CHWINLR= CHWINLR+1, CHWINHR=CH WINHR+1
  25731   "RTN","CHM FA181",247 ,0)
  25732    S ROW1=CH WINHR+1
  25733   "RTN","CHM FA181",248 ,0)
  25734   UP1 S ROW1 =$O(^UTILI TY($J,"CHD ME",BEN,RO W1),-1) G: 'ROW1 UP2   G:ROW1<CH WINLR UP2
  25735   "RTN","CHM FA181",249 ,0)
  25736    S DX=1,$X =DX X XY W  !
  25737   "RTN","CHM FA181",250 ,0)
  25738    F FLD=0:1 :8 D FLDLN G S DX=CFD X,$X=DX X  XY D
  25739   "RTN","CHM FA181",251 ,0)
  25740    .Q:^UTILI TY($J,"CHD ME",BEN,RO W1,FLD)=""
  25741   "RTN","CHM FA181",252 ,0)
  25742    .I FLD=8  W $J($FN($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,"",2),FL)
  25743   "RTN","CHM FA181",253 ,0)
  25744    .E  W $J( $P(^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD),U,1 ),FL)
  25745   "RTN","CHM FA181",254 ,0)
  25746    F FLD=3,5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  25747   "RTN","CHM FA181",255 ,0)
  25748    .S DX=49, $X=DX
  25749   "RTN","CHM FA181",256 ,0)
  25750    .K BF S B F="",$P(BF ," ",16)=" " X XY W B F
  25751   "RTN","CHM FA181",257 ,0)
  25752    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,15)
  25753   "RTN","CHM FA181",258 ,0)
  25754   UP2 D CURR ES S FLD=C HCF
  25755   "RTN","CHM FA181",259 ,0)
  25756    Q
  25757   "RTN","CHM FA181",260 ,0)
  25758    ;
  25759   "RTN","CHM FA181",261 ,0)
  25760   PREV I CHW INLR<2 W * 7 Q
  25761   "RTN","CHM FA181",262 ,0)
  25762    S CHCDX=D X,CHCF=FLD
  25763   "RTN","CHM FA181",263 ,0)
  25764    S CHWINLR =CHWINLR-C HWIN S:CHW INLR<1 CHW INLR=1
  25765   "RTN","CHM FA181",264 ,0)
  25766    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,$Y =DY,ROW1=C HWINLR-1
  25767   "RTN","CHM FA181",265 ,0)
  25768   P1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) G:'ROW 1 P2 G:ROW 1>CHWINHR  P2
  25769   "RTN","CHM FA181",266 ,0)
  25770    S DX=1,$X =DX X XY W  @CHEOL
  25771   "RTN","CHM FA181",267 ,0)
  25772    F FLD=0:1 :8 D FLDLN G S DX=CFD X,$X=DX X  XY
  25773   "RTN","CHM FA181",268 ,0)
  25774    .Q:^UTILI TY($J,"CHD ME",BEN,RO W1,FLD)=""
  25775   "RTN","CHM FA181",269 ,0)
  25776    .I FLD=8  W $J($FN($ P(^UTILITY ($J,"CHDME ",BEN,ROW1 ,FLD),U,1) ,"",2),FL)
  25777   "RTN","CHM FA181",270 ,0)
  25778    .E  W $J( $P(^UTILIT Y($J,"CHDM E",BEN,ROW 1,FLD),U,1 ),FL)
  25779   "RTN","CHM FA181",271 ,0)
  25780    F FLD=3,5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  25781   "RTN","CHM FA181",272 ,0)
  25782    .S DX=49, $X=DX
  25783   "RTN","CHM FA181",273 ,0)
  25784    .K BF S B F="",$P(BF ," ",16)=" " X XY W B F
  25785   "RTN","CHM FA181",274 ,0)
  25786    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,15)
  25787   "RTN","CHM FA181",275 ,0)
  25788    S DY=DY+1 ,$Y=DY G P 1
  25789   "RTN","CHM FA181",276 ,0)
  25790   P2 S DY=CH SDY,$Y=DY, ROW=CHWINL R,DX=CHCDX ,$X=DX,FLD =CHCF
  25791   "RTN","CHM FA181",277 ,0)
  25792    Q
  25793   "RTN","CHM FA181",278 ,0)
  25794    ;
  25795   "RTN","CHM FA181",279 ,0)
  25796   NEXT I '$D (^UTILITY( $J,"CHDME" ,BEN,CHWIN HR+1)) W * 7 Q
  25797   "RTN","CHM FA181",280 ,0)
  25798    S CHCDX=D X,CHCF=FLD
  25799   "RTN","CHM FA181",281 ,0)
  25800    S CHWINLR =CHWINLR+C HWIN S:CHW INLR<1 CHW INLR=1
  25801   "RTN","CHM FA181",282 ,0)
  25802    I CHWINLR +CHWIN>CHL R S CHWINL R=CHLR-(CH WIN-1)
  25803   "RTN","CHM FA181",283 ,0)
  25804    S CHWINHR =CHWINLR+( CHWIN-1),D Y=CHSDY,$Y =DY,ROW1=C HWINLR-1
  25805   "RTN","CHM FA181",284 ,0)
  25806   N1 S ROW1= $O(^UTILIT Y($J,"CHDM E",BEN,ROW 1)) I 'ROW 1 D CLEAR2  G N2
  25807   "RTN","CHM FA181",285 ,0)
  25808    G:ROW1>CH WINHR N2
  25809   "RTN","CHM FA181",286 ,0)
  25810    S DX=1,$X =DX X XY W  @CHEOL
  25811   "RTN","CHM FA181",287 ,0)
  25812    F FLD=0:1 :8 D FLDLN G S DX=CFD X,$X=DX X  XY W $J($P (^UTILITY( $J,"CHDME" ,BEN,ROW1, FLD),U,1), FL)
  25813   "RTN","CHM FA181",288 ,0)
  25814    F FLD=3,5  D:$P(^UTI LITY($J,"C HDME",BEN, ROW1,FLD), U)'=""
  25815   "RTN","CHM FA181",289 ,0)
  25816    .S DX=49, $X=DX
  25817   "RTN","CHM FA181",290 ,0)
  25818    .K BF S B F="",$P(BF ," ",16)=" " X XY W B F
  25819   "RTN","CHM FA181",291 ,0)
  25820    .X XY W $ E($P(^UTIL ITY($J,"CH DME",BEN,R OW1,FLD),U ,3),1,15)
  25821   "RTN","CHM FA181",292 ,0)
  25822    S DY=DY+1 ,$Y=DY G N 1
  25823   "RTN","CHM FA181",293 ,0)
  25824   N2 S DY=CH SDY,$Y=DY, ROW=CHWINL R,DX=CHCDX ,$X=DX,FLD =CHCF
  25825   "RTN","CHM FA181",294 ,0)
  25826    Q
  25827   "RTN","CHM FA181",295 ,0)
  25828    ;
  25829   "RTN","CHM FA181",296 ,0)
  25830   CLEAR2 S H Y=DY,DX=1, $X=DX F DY =HY:1:CHSD Y+CHWIN-1  S $Y=DY X  XY W @CHEO L
  25831   "RTN","CHM FA181",297 ,0)
  25832    Q
  25833   "RTN","CHM FA181",298 ,0)
  25834    ;
  25835   "RTN","CHM FA181",299 ,0)
  25836   CURSAV S C HCDX=DX,CH CDY=DY
  25837   "RTN","CHM FA181",300 ,0)
  25838    Q
  25839   "RTN","CHM FA181",301 ,0)
  25840    ;
  25841   "RTN","CHM FA181",302 ,0)
  25842   CURRES S D X=CHCDX,$X =DX,DY=CHC DY,$Y=DY
  25843   "RTN","CHM FA181",303 ,0)
  25844    Q
  25845   "RTN","CHM FA181",304 ,0)
  25846    ;
  25847   "RTN","CHM FA181",305 ,0)
  25848   MARSCR ;S  DTM=CHSDY, DBM=CHSDY+ CHWIN-1 X  CHMAR   ;S KD
  25849   "RTN","CHM FA181",306 ,0)
  25850    S DTM=CHS DY+1,DBM=C HSDY+CHWIN  X CHMAR    ;SKD
  25851   "RTN","CHM FA181",307 ,0)
  25852    Q
  25853   "RTN","CHM FA181",308 ,0)
  25854    ;
  25855   "RTN","CHM FA181",309 ,0)
  25856   MARMES S D TM=CHMDY,D BM=20 X CH MAR
  25857   "RTN","CHM FA181",310 ,0)
  25858    Q
  25859   "RTN","CHM FA181",311 ,0)
  25860    ;
  25861   "RTN","CHM FA181",312 ,0)
  25862   ERASCR S D X=1,$X=DX  F DY=CHSDY :1:CHSDY+C HWIN-1 S $ Y=DY X XY  W @CHEOL
  25863   "RTN","CHM FA181",313 ,0)
  25864    Q
  25865   "RTN","CHM FA181",314 ,0)
  25866    ;
  25867   "RTN","CHM FA181",315 ,0)
  25868   ERAMSG S D X=1,$X=DX  F DY=CHMDY :1:20 S $Y =DY X XY W  @CHEOL
  25869   "RTN","CHM FA181",316 ,0)
  25870    Q
  25871   "RTN","CHM FA181",317 ,0)
  25872    ;
  25873   "RTN","CHM FA181",318 ,0)
  25874   CLRMSG I M SGFLG D CU RSAV,ERAMS G,ERROR,CU RRES S MSG FLG=0
  25875   "RTN","CHM FA181",319 ,0)
  25876    Q
  25877   "RTN","CHM FA181",320 ,0)
  25878   ERROR Q
  25879   "RTN","CHM FA802")
  25880   0^53^B6512 4332
  25881   "RTN","CHM FA802",1,0 )
  25882   CHMFA802 ; HBG/DEN;CH ECK DATA E /E CLAIM S CREEN;08/2 0/98  8:16  AM
  25883   "RTN","CHM FA802",2,0 )
  25884    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  25885   "RTN","CHM FA802",3,0 )
  25886    ;;kml - C ommunity C are System  Enhancmem ents (CCSE )  Epic-St ory: 005-0 13 
  25887   "RTN","CHM FA802",4,0 )
  25888    ; Modify  Edit Claim  Data scre en to acco modate Ele ctronic Re open funct ionality
  25889   "RTN","CHM FA802",5,0 )
  25890    ;this rou tine is a  copy of CH MFA801 but  with seve ral enhanc ements to  accomodate  the
  25891   "RTN","CHM FA802",6,0 )
  25892    ; modifie d Edit Cla im Data sc reen which  displays  the Origin al PDI and  the Curre nt PDI
  25893   "RTN","CHM FA802",7,0 )
  25894   START S CH MFCLNM=0,C =1 K ^UTIL ITY("CHK", $J)
  25895   "RTN","CHM FA802",8,0 )
  25896    N ORPDI
  25897   "RTN","CHM FA802",9,0 )
  25898   CUTIL S CH MFCLNM=$O( CHMFCLMS(C HMFCLNM))  I CHMFCLNM ="" G:C=1  END G DISP
  25899   "RTN","CHM FA802",10, 0)
  25900    S CL=CHMF CLMS(CHMFC LNM) G:'$D (@(GLPAY_" CL,0)")) C UTIL
  25901   "RTN","CHM FA802",11, 0)
  25902    S REC=^(0 ),TY=$P(RE C,U,7),VN= $P(REC,U,3 ),DOS=$P(R EC,U,8)
  25903   "RTN","CHM FA802",12, 0)
  25904    S DFN=$P( REC,U,21), BFN=$P(REC ,U,22) D T YPE,VENDOR ,DOS,BENE
  25905   "RTN","CHM FA802",13, 0)
  25906     G:BFN=""  CUTIL
  25907   "RTN","CHM FA802",14, 0)
  25908    S ^UTILIT Y("CHK",$J ,C,BFN,TY) =CHMFCLNM_ "^"_VN_"^" _DOS_"^"_C L,A(C)="", C=C+1
  25909   "RTN","CHM FA802",15, 0)
  25910    G CUTIL
  25911   "RTN","CHM FA802",16, 0)
  25912   DISP K CHC ONT,CHEDT, CHKIL,CHRT N,CHQUIT,C HUPS,CHUP
  25913   "RTN","CHM FA802",17, 0)
  25914    ; Epic 5,  User Stor y 013 - km l 6/21/17  - call fun ction to r etrieve Or iginal PDI
  25915   "RTN","CHM FA802",18, 0)
  25916    S ORPDI=$ $GETOPDI(C HMFPDI)  ;  retrieve  Original P DI if it e xists
  25917   "RTN","CHM FA802",19, 0)
  25918    I 'ORPDI  S ORPDI=""   ; not a  reopened a  claim
  25919   "RTN","CHM FA802",20, 0)
  25920    S ASKFL=0  D HDR S L N="" S $P( LN,"-",81) =""
  25921   "RTN","CHM FA802",21, 0)
  25922   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
  25923   "RTN","CHM FA802",22, 0)
  25924    S DTM=12, DBM=19 X C HMAR S DY= 12,DX=1 X  XY   ;SKD,  3-15-06
  25925   "RTN","CHM FA802",23, 0)
  25926   D1 S I=$O( ^UTILITY(" CHK",$J,I) ) G:'I D4  S BFN=""
  25927   "RTN","CHM FA802",24, 0)
  25928   D2 S BFN=$ O(^UTILITY ("CHK",$J, I,BFN)) G  D1:BFN=""  S TY=""
  25929   "RTN","CHM FA802",25, 0)
  25930   D3 S TY=$O (^UTILITY( "CHK",$J,I ,BFN,TY))  G D2:TY=""
  25931   "RTN","CHM FA802",26, 0)
  25932    S REC=^(T Y),CHMFCLN M=$P(REC,U ,1),CL=$P( REC,"^",4)  K FL S A( I)=""
  25933   "RTN","CHM FA802",27, 0)
  25934    ; Epic 5,  User Stor y 013 - km l 6/21/17  - move the  write of  the curren t claim af ter the wr ite of the  Original  claim
  25935   "RTN","CHM FA802",28, 0)
  25936    ; Epic 5,  User Stor y 013 - km l 6/21/17  - retrieve  ORIGINAL  claim # fr om the FRO M CLAIM PO INTER fiel d (741000, 6.02)
  25937   "RTN","CHM FA802",29, 0)
  25938    W !,I,")"
  25939   "RTN","CHM FA802",30, 0)
  25940    I $D(@(GL PAY_"CL,6) ")) I $P(^ (6),"^",2) '="" S REC L=$P(^(6), "^",2) I R ECL'="" W  ?5,$$GET1^ DIQ(741000 ,RECL,.01)   
  25941   "RTN","CHM FA802",31, 0)
  25942    W ?15,CHM FCLNM W:$D (CHPEND(CH MFCLNM)) "  (P)"
  25943   "RTN","CHM FA802",32, 0)
  25944    W ?26,$E( BFN,1,15), ?44,$E(TY, 1,3),?50,$ E($P(REC,U ,2),1,10), ?63,$P(REC ,U,3)
  25945   "RTN","CHM FA802",33, 0)
  25946    G D31:CHM CL(CHMFCLN M)="" S L= $L(CHMCL(C HMFCLNM)," *")
  25947   "RTN","CHM FA802",34, 0)
  25948    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)
  25949   "RTN","CHM FA802",35, 0)
  25950    .Q:$P(CHM CL(CHMFCLN M),"*",P+1 )=""  K CH ANCE D ASK  Q:$D(CHAN CE)  D CLE AR2 S DY=1 2,DX=1 X X Y K FL
  25951   "RTN","CHM FA802",36, 0)
  25952    .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)
  25953   "RTN","CHM FA802",37, 0)
  25954   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
  25955   "RTN","CHM FA802",38, 0)
  25956   D32 K QFL, CHNEWPG
  25957   "RTN","CHM FA802",39, 0)
  25958    G:$D(CHCO NT)!($D(CH EDT))!($D( CHKIL)) D3 3
  25959   "RTN","CHM FA802",40, 0)
  25960    I $D(DQOU T) D ASK G  D33
  25961   "RTN","CHM FA802",41, 0)
  25962    I ASKFL=1  D ASK G:$ D(CHUPS) D 3
  25963   "RTN","CHM FA802",42, 0)
  25964   D33 I Y="2 " S HY=Y D  ASK4 S Y= HY G:$D(CH RENO) D32
  25965   "RTN","CHM FA802",43, 0)
  25966    G:(Y=2)!( $D(DFOUT))  END G:$D( DUOUT) D32
  25967   "RTN","CHM FA802",44, 0)
  25968    I Y=3 D ^ CHMFKILL G :'$D(CHNEW PG) D32 K  CHMCL G EN D
  25969   "RTN","CHM FA802",45, 0)
  25970   D34 D EDIT  G:$D(DFOU T) END G:$ D(QFL) DIS P
  25971   "RTN","CHM FA802",46, 0)
  25972    D ^CHMFA8 00 K CHCON T,CHEDT,CH KIL G STAR T
  25973   "RTN","CHM FA802",47, 0)
  25974   END K CHCO NT,CHEDT,C HKIL,CHREN O,CHREYES, CHQUIT,CHN OSEND Q
  25975   "RTN","CHM FA802",48, 0)
  25976   ASK S FL=3 0 I $D(CHR EOPN) D AS K1 Q
  25977   "RTN","CHM FA802",49, 0)
  25978    D CLEAR S  HY=DY,HX= DX,DY=20,D X=1 X XY
  25979   "RTN","CHM FA802",50, 0)
  25980    K CHCONT, CHEDT,CHKI L,CHRTN,CH QUIT,CHUPS
  25981   "RTN","CHM FA802",51, 0)
  25982    W "Choose  1-3 or Pr ess ",@CHB ON,"<RETUR N>",@CHBOF F," to Vie w next pag e...",!
  25983   "RTN","CHM FA802",52, 0)
  25984    W "          1) Edit ",!,"          2) Con tinue"
  25985   "RTN","CHM FA802",53, 0)
  25986    W !,"          3) Pr ocess New  Page",!!," Choose:  "
  25987   "RTN","CHM FA802",54, 0)
  25988    D CSBRS^C HSC2 G:$D( DQOUT) ASK
  25989   "RTN","CHM FA802",55, 0)
  25990    I $D(DFOU T)!($D(DUO UT)) S CHQ UIT="" Q
  25991   "RTN","CHM FA802",56, 0)
  25992    I Y="" D  CLEAR2,D35  S CHUPS=" " Q
  25993   "RTN","CHM FA802",57, 0)
  25994    G:"123"'[ Y ASK
  25995   "RTN","CHM FA802",58, 0)
  25996    I Y=2 S C HCONT="" Q
  25997   "RTN","CHM FA802",59, 0)
  25998    I Y=3 S C HKIL="" Q
  25999   "RTN","CHM FA802",60, 0)
  26000    I Y=1 S C HEDT=""
  26001   "RTN","CHM FA802",61, 0)
  26002   D35 S DTM= 12,DBM=18  X CHMAR S  DY=12,DX=1  X XY Q
  26003   "RTN","CHM FA802",62, 0)
  26004   ASK1 D CLE AR S HY=DY ,HX=DX,DY= 20,DX=1 X  XY
  26005   "RTN","CHM FA802",63, 0)
  26006    K CHCONT, CHEDT,CHUP S
  26007   "RTN","CHM FA802",64, 0)
  26008    W "Choose  1-2 or Pr ess ",@CHB ON,"<RETUR N>",@CHBOF F," to Vie w next pag e...",!
  26009   "RTN","CHM FA802",65, 0)
  26010    W "          1) Edit ",!,"          2) Con tinue"
  26011   "RTN","CHM FA802",66, 0)
  26012    W !!,"Cho ose: "
  26013   "RTN","CHM FA802",67, 0)
  26014    D CSBRS^C HSC2 G:$D( DQOUT) ASK 1
  26015   "RTN","CHM FA802",68, 0)
  26016    I $D(DFOU T)!$D(DUOU T) S CHQUI T="" Q
  26017   "RTN","CHM FA802",69, 0)
  26018    I Y="" D  CLEAR2,D36  S CHUPS=" " Q
  26019   "RTN","CHM FA802",70, 0)
  26020    G:"12"'[Y  ASK1
  26021   "RTN","CHM FA802",71, 0)
  26022    I Y=2 S C HCONT="" Q
  26023   "RTN","CHM FA802",72, 0)
  26024    I Y=1 S C HEDT=""
  26025   "RTN","CHM FA802",73, 0)
  26026   D36 S DTM= 12,DBM=18  X CHMAR S  DY=12,DX=1  X XY Q 
  26027   "RTN","CHM FA802",74, 0)
  26028   D4 K QFL,C HNEWPG,CHC ONT,CHEDT, CHKIL
  26029   "RTN","CHM FA802",75, 0)
  26030    D ASK2
  26031   "RTN","CHM FA802",76, 0)
  26032    G:$D(CHUP ) DISP
  26033   "RTN","CHM FA802",77, 0)
  26034    G:$D(CHCO NT)!($D(CH EDT))!($D( CHKIL)) D4 1
  26035   "RTN","CHM FA802",78, 0)
  26036    I $D(DQOU T) D ASK2  G D41
  26037   "RTN","CHM FA802",79, 0)
  26038    I ASKFL=1  D ASK2
  26039   "RTN","CHM FA802",80, 0)
  26040   D41 I Y="2 " S HY=Y D  ASK4 S Y= HY G:$D(CH RENO) D4
  26041   "RTN","CHM FA802",81, 0)
  26042    G:(Y=2)!( $D(DFOUT))  END G:$D( DUOUT) D4
  26043   "RTN","CHM FA802",82, 0)
  26044    I Y=3 D ^ CHMFKILL G :'$D(CHNEW PG) D4 K C HMCL G END
  26045   "RTN","CHM FA802",83, 0)
  26046   D42 D EDIT  G:$D(DFOU T) END G:$ D(QFL) D4
  26047   "RTN","CHM FA802",84, 0)
  26048    D ^CHMFA8 00 K CHCON T,CHEDT,CH KIL G STAR T
  26049   "RTN","CHM FA802",85, 0)
  26050   ASK2 S FL= 30 I $D(CH REOPN) D A SK3 Q
  26051   "RTN","CHM FA802",86, 0)
  26052    K CHCONT, CHEDT,CHKI L,CHUP
  26053   "RTN","CHM FA802",87, 0)
  26054    D CLEAR S  DY=20,DX= 1 X XY W " Select:  1 ) Edit",!, "          2) Continu e"
  26055   "RTN","CHM FA802",88, 0)
  26056    W !,"          3) Pr ocess New  Page",!!," Choose:  "
  26057   "RTN","CHM FA802",89, 0)
  26058    D CSBRS^C HSC2 G:$D( DQOUT) ASK 2 Q:$D(DFO UT)
  26059   "RTN","CHM FA802",90, 0)
  26060    I $D(DUOU T) S CHUP= "" Q
  26061   "RTN","CHM FA802",91, 0)
  26062    G:Y="" AS K2
  26063   "RTN","CHM FA802",92, 0)
  26064    G:"123"'[ Y ASK2
  26065   "RTN","CHM FA802",93, 0)
  26066    I Y=2 S C HCONT="" Q
  26067   "RTN","CHM FA802",94, 0)
  26068    I Y=3 S C HKIL="" Q
  26069   "RTN","CHM FA802",95, 0)
  26070    I Y=1 S C HEDT="" Q
  26071   "RTN","CHM FA802",96, 0)
  26072   ASK3 K CHC ONT,CHEDT, CHNEXT
  26073   "RTN","CHM FA802",97, 0)
  26074    D CLEAR S  DY=20,DX= 1 X XY W " Select:  1 ) Edit",!, "          2) Continu e"
  26075   "RTN","CHM FA802",98, 0)
  26076    W !!,"Cho ose:  " D  CSBRS^CHSC 2 G:$D(DQO UT) ASK3 Q :$D(DFOUT)
  26077   "RTN","CHM FA802",99, 0)
  26078    I $D(DUOU T) S CHUP= "" Q
  26079   "RTN","CHM FA802",100 ,0)
  26080    G:Y="" AS K3 G:"12"' [Y ASK3
  26081   "RTN","CHM FA802",101 ,0)
  26082    I Y=1 S C HEDT="" Q
  26083   "RTN","CHM FA802",102 ,0)
  26084    I Y=2 S C HCONT="" Q
  26085   "RTN","CHM FA802",103 ,0)
  26086   ASK4 S FL= 30 D CLEAR  I $D(CHRE OPN) G ASK 42
  26087   "RTN","CHM FA802",104 ,0)
  26088   ASK41 K CH RENO,CHREY ES S DY=19 ,DX=1 X XY
  26089   "RTN","CHM FA802",105 ,0)
  26090    W !,"Are  you sure y ou want to  continue?  " D CSBRS ^CHSC2
  26091   "RTN","CHM FA802",106 ,0)
  26092    I $D(DUOU T)!$D(DFOU T) S CHREN O="",ASKFL =1 K CHCON T,CHEDT,CH KIL D ASK4 2 Q
  26093   "RTN","CHM FA802",107 ,0)
  26094    I $D(DQOU T) W !!,"E nter <Y>es  or <N>o."  G ASK41
  26095   "RTN","CHM FA802",108 ,0)
  26096    G:Y="" AS K4 S Y=$E( Y,1) G:"Yy Nn"'[Y ASK 41
  26097   "RTN","CHM FA802",109 ,0)
  26098    I "Nn"[Y  S CHRENO=" ",ASKFL=1  K CHCONT,C HEDT,CHKIL  G ASK42
  26099   "RTN","CHM FA802",110 ,0)
  26100    S:"Yy"[Y  CHREYES=1
  26101   "RTN","CHM FA802",111 ,0)
  26102   ASK42 D CL EAR Q
  26103   "RTN","CHM FA802",112 ,0)
  26104    S DTM=12, DBM=18 X C HMAR S DY= 12,DX=1 X  XY Q
  26105   "RTN","CHM FA802",113 ,0)
  26106   HDR ;
  26107   "RTN","CHM FA802",114 ,0)
  26108    F DY=1:1: 24 S DX=1  X XY W @CH EOL
  26109   "RTN","CHM FA802",115 ,0)
  26110    W @IOF W  @CHREVON,@ CHBON S DY =1,DX=1 U  0:0:"^%X36 4" X XY    ;SKD, 6-13 -05
  26111   "RTN","CHM FA802",116 ,0)
  26112    W "                                                          "
  26113   "RTN","CHM FA802",117 ,0)
  26114    W "                              "
  26115   "RTN","CHM FA802",118 ,0)
  26116    W !,"                                [Edit  Claim Dat a Screen]"
  26117   "RTN","CHM FA802",119 ,0)
  26118    W "                              "
  26119   "RTN","CHM FA802",120 ,0)
  26120    W !,"                                                          "
  26121   "RTN","CHM FA802",121 ,0)
  26122    W "                              "
  26123   "RTN","CHM FA802",122 ,0)
  26124    W @CHREVO FF W @CHBO N,!,"Origi nal PDI Nu mber: ",$G (ORPDI)
  26125   "RTN","CHM FA802",123 ,0)
  26126    W !,"Curr ent  PDI N umber: ",$ G(CHMFPDI)
  26127   "RTN","CHM FA802",124 ,0)
  26128    W !,"Rela ted Claims :",@CHBOFF
  26129   "RTN","CHM FA802",125 ,0)
  26130    W !!,?5," Original", ?15,"Curre nt"
  26131   "RTN","CHM FA802",126 ,0)
  26132    W !,"No." ,?5,"Claim  #",?15,"C laim #",?2 6,"Bene",? 44,"Typ",? 50,"Vendor ",?63,"D.O .S",?75,"D /C",!
  26133   "RTN","CHM FA802",127 ,0)
  26134    W "---",? 5,"------- ",?15,"--- ----",?26, "--------- ------",?4 4,"---",?5 0,"------- ---",?63," ---------- ",?75,"--- "
  26135   "RTN","CHM FA802",128 ,0)
  26136    Q
  26137   "RTN","CHM FA802",129 ,0)
  26138   TYPE I '$D (^CHMDIC(7 41002.05,T Y,0)) S TY ="UNKNOWN"  Q
  26139   "RTN","CHM FA802",130 ,0)
  26140    S TY=$P(^ (0),U,1) Q
  26141   "RTN","CHM FA802",131 ,0)
  26142   VENDOR ;
  26143   "RTN","CHM FA802",132 ,0)
  26144    ;I VN=""  S VN="UNKN OWN" Q                 ;SKD 11-5 -07 DEV003 626-01,BUG 002654-05- 01
  26145   "RTN","CHM FA802",133 ,0)
  26146    ;I '$D(^C HMVEN(VN,2 )) S VN="U NKNOWN" Q   ;SKD 11-5 -07 DEV003 626-01,BUG 002654-05- 01
  26147   "RTN","CHM FA802",134 ,0)
  26148    ;S VN=$E( $P(^(2),U, 8),1,10) Q             ;SKD 11-5 -07 DEV003 626-01,BUG 002654-05- 01
  26149   "RTN","CHM FA802",135 ,0)
  26150    ;SKD 11-5 -07 DEV003 626-01,BUG 002654-05- 01 lines b elow repla ce the abo ve 3 lines
  26151   "RTN","CHM FA802",136 ,0)
  26152    I $G(VN)' ="" D
  26153   "RTN","CHM FA802",137 ,0)
  26154    .S VN=$P( $G(^CHMVEN (VN,2)),U, 8) 
  26155   "RTN","CHM FA802",138 ,0)
  26156    .Q:VN=""
  26157   "RTN","CHM FA802",139 ,0)
  26158    .S VN=$E( $P(^(2),U, 8),1,10)
  26159   "RTN","CHM FA802",140 ,0)
  26160    Q:VN'=""
  26161   "RTN","CHM FA802",141 ,0)
  26162    I VN="" D   
  26163   "RTN","CHM FA802",142 ,0)
  26164    .Q:'$G(CL )  Q:'$D(^ CHMPAY(CL, "VEN","PS" ))
  26165   "RTN","CHM FA802",143 ,0)
  26166    .I $D(^CH MPAY(CL,"V EN","PS"))  D  
  26167   "RTN","CHM FA802",144 ,0)
  26168    ..S PSVDT ="A",PSVDT =$O(^CHMPA Y(CL,"VEN" ,"PS",PSVD T),-1) Q:' PSVDT
  26169   "RTN","CHM FA802",145 ,0)
  26170    ..S VN=$P ($G(^CHMPA Y(CL,"VEN" ,"PS",PSVD T,0)),U,4)
  26171   "RTN","CHM FA802",146 ,0)
  26172    ..I VN'=" " S VN=$E( VN,1,10)
  26173   "RTN","CHM FA802",147 ,0)
  26174    Q:VN'=""
  26175   "RTN","CHM FA802",148 ,0)
  26176    I VN="" D  
  26177   "RTN","CHM FA802",149 ,0)
  26178    .Q:'$G(CL )
  26179   "RTN","CHM FA802",150 ,0)
  26180    .S VN=$P( $G(^CHMPAY (CL,"ZIMAG E")),U,1)
  26181   "RTN","CHM FA802",151 ,0)
  26182    .Q:VN=""
  26183   "RTN","CHM FA802",152 ,0)
  26184    .I VN'=""  S VN=$E(V N,1,10)
  26185   "RTN","CHM FA802",153 ,0)
  26186    Q:VN'=""
  26187   "RTN","CHM FA802",154 ,0)
  26188    I VN="" S  VN="UNKNO WN" 
  26189   "RTN","CHM FA802",155 ,0)
  26190    Q
  26191   "RTN","CHM FA802",156 ,0)
  26192    ; 
  26193   "RTN","CHM FA802",157 ,0)
  26194   DOS ;
  26195   "RTN","CHM FA802",158 ,0)
  26196    ;Y2K - Q: DOS=""  S  DOS=$E(DOS ,4,5)_"/"_ $E(DOS,6,7 )_"/"_$E(D OS,2,3) Q
  26197   "RTN","CHM FA802",159 ,0)
  26198    Q:DOS=""   S DOS=$$F MTE^XLFDT( DOS,5) Q    
  26199   "RTN","CHM FA802",160 ,0)
  26200   BENE I '$D (@(GLELG_" DFN,100,BF N,0)")) S  BFN="" Q
  26201   "RTN","CHM FA802",161 ,0)
  26202    S BFN=$P( ^(0),U) Q
  26203   "RTN","CHM FA802",162 ,0)
  26204   EDIT K B,C
  26205   "RTN","CHM FA802",163 ,0)
  26206   E1 K B D C LEAR S DY= 20,DX=1 X  XY W "Edit : " D CSBR S^CHSC2
  26207   "RTN","CHM FA802",164 ,0)
  26208    I $D(DFOU T)!$D(DUOU T) S QFL=1  K CHEDT Q
  26209   "RTN","CHM FA802",165 ,0)
  26210    S STR=Y G  E6:+STR
  26211   "RTN","CHM FA802",166 ,0)
  26212   E5 G E1:Y' ?1"A".E F  II=0:0 S I I=$O(A(II) ) Q:'II  S  B(II)=""
  26213   "RTN","CHM FA802",167 ,0)
  26214    G E10
  26215   "RTN","CHM FA802",168 ,0)
  26216   E6 G:'$D(^ UTILITY("C HK",$J,Y))  E1
  26217   "RTN","CHM FA802",169 ,0)
  26218    G E1:Y["+ ",E1:Y["=" ,E1:Y[" "
  26219   "RTN","CHM FA802",170 ,0)
  26220    F II=1:1: $L(Y,",")  S:$P(Y,"," ,II)]"" B( $P(Y,",",I I))=""
  26221   "RTN","CHM FA802",171 ,0)
  26222   E7 S II=$O (B(II)) G  E8:II="" I  II["-" K  B(II)
  26223   "RTN","CHM FA802",172 ,0)
  26224    F J=$P(II ,"-"):1:$P (II,"-",2)  S B(J)=""
  26225   "RTN","CHM FA802",173 ,0)
  26226    G E7
  26227   "RTN","CHM FA802",174 ,0)
  26228   E8 S II=0
  26229   "RTN","CHM FA802",175 ,0)
  26230   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
  26231   "RTN","CHM FA802",176 ,0)
  26232    G E9
  26233   "RTN","CHM FA802",177 ,0)
  26234   E10 S II=0
  26235   "RTN","CHM FA802",178 ,0)
  26236   E11 S II=$ O(B(II)) G :'II E15 S  BFN=""
  26237   "RTN","CHM FA802",179 ,0)
  26238   E12 S BFN= $O(^UTILIT Y("CHK",$J ,II,BFN))  G:BFN="" E 11 S TY=""
  26239   "RTN","CHM FA802",180 ,0)
  26240   E13 S TY=$ O(^UTILITY ("CHK",$J, II,BFN,TY) ) G:TY=""  E12 S REC= ^(TY)
  26241   "RTN","CHM FA802",181 ,0)
  26242    S CL=$P(R EC,"^"),DO S=$P(REC," ^",3),VN=$ P(REC,"^", 2),IN=$P(R EC,"^",4)
  26243   "RTN","CHM FA802",182 ,0)
  26244    S CHMED(C L)=IN_"^"_ BFN_"^"_VN _"^"_TY_"^ "_DOS G E1 3
  26245   "RTN","CHM FA802",183 ,0)
  26246   E15 ;I CHM CL(CL)=""  D E16 Q
  26247   "RTN","CHM FA802",184 ,0)
  26248    ;I CHMCL( CL)="NCL"  D E17 Q
  26249   "RTN","CHM FA802",185 ,0)
  26250    S DA=IN K  FL S CHNO SEND=1 D ^ CHMG211 D  ^CHMFSET K  CHMED,B,C ,CHDISC S  FL2=0 Q
  26251   "RTN","CHM FA802",186 ,0)
  26252   E16 W *7,! !,"Claim i s complete , editing  is not all owed!!" H  3 Q
  26253   "RTN","CHM FA802",187 ,0)
  26254    ;
  26255   "RTN","CHM FA802",188 ,0)
  26256   E17 W *7,! !,"Claim f orm is mis sing, edit ing is not  allowed!! " H 3 Q
  26257   "RTN","CHM FA802",189 ,0)
  26258    ;
  26259   "RTN","CHM FA802",190 ,0)
  26260   CLEAR F DY =20:1:24 S  DX=1 X XY  W @CHEOL
  26261   "RTN","CHM FA802",191 ,0)
  26262    Q
  26263   "RTN","CHM FA802",192 ,0)
  26264   CLEAR2 F D Y=11:1:18  S DX=1 X X Y W @CHEOL
  26265   "RTN","CHM FA802",193 ,0)
  26266    Q
  26267   "RTN","CHM FA802",194 ,0)
  26268    ;
  26269   "RTN","CHM FA802",195 ,0)
  26270   GETOPDI(CH MFPDI) ;   kml - user  story 005 -013 set u p ORPDI wi th origina l PDI  
  26271   "RTN","CHM FA802",196 ,0)
  26272    ; input -  CHMFPDI =  current P DI
  26273   "RTN","CHM FA802",197 ,0)
  26274    ; output  - ORPDI -  original P DI
  26275   "RTN","CHM FA802",198 ,0)
  26276    I $G(CHMO PDI)]"" Q  CHMOPDI  ;  original  PDI could  already be  available  via EDI p rocessing
  26277   "RTN","CHM FA802",199 ,0)
  26278    S ORPDI=$ $ORPDI($G( CHMFPDI))   ; get fro m CHMIMG f ile
  26279   "RTN","CHM FA802",200 ,0)
  26280    I 'ORPDI  S ORPDI=$$ OPDI(CHMFP DI)  ; get  from CHMP AY file
  26281   "RTN","CHM FA802",201 ,0)
  26282    Q ORPDI
  26283   "RTN","CHM FA802",202 ,0)
  26284    ;
  26285   "RTN","CHM FA802",203 ,0)
  26286   ORPDI(CPDI ) ; kml -  user story  005-013    get origi nal PDI
  26287   "RTN","CHM FA802",204 ,0)
  26288    ; input -  CPDI - cu rrent PDI
  26289   "RTN","CHM FA802",205 ,0)
  26290    ; output  - returns  original P DI
  26291   "RTN","CHM FA802",206 ,0)
  26292    I '$D(^CH MIMG(CPDI, "E-REOPEN" )) Q 0
  26293   "RTN","CHM FA802",207 ,0)
  26294    Q +$P(^CH MIMG(CPDI, "E-REOPEN" ),U)
  26295   "RTN","CHM FA802",208 ,0)
  26296    ;
  26297   "RTN","CHM FA802",209 ,0)
  26298   OPDI(CPDI)  ;kml - us er story 0 05-013  Ge t the orig inal PDI n umber.
  26299   "RTN","CHM FA802",210 ,0)
  26300    N ICN,IEN ,LATEST,OR PDI
  26301   "RTN","CHM FA802",211 ,0)
  26302    S CPDI=$G (CPDI)
  26303   "RTN","CHM FA802",212 ,0)
  26304    S ORPDI=" "
  26305   "RTN","CHM FA802",213 ,0)
  26306    ;Check if  the PDI #  given exi sts
  26307   "RTN","CHM FA802",214 ,0)
  26308    K LATEST
  26309   "RTN","CHM FA802",215 ,0)
  26310    I CPDI'?1 5N Q 0
  26311   "RTN","CHM FA802",216 ,0)
  26312    ;I '$D(^C HMIMG(CPDI ))&('$D(^C HMPAY("C", CPDI))) Q  0
  26313   "RTN","CHM FA802",217 ,0)
  26314    Q:'$D(^CH MIMG(CPDI) ) 0
  26315   "RTN","CHM FA802",218 ,0)
  26316    Q:'$D(^CH MPAY("C",C PDI)) 0
  26317   "RTN","CHM FA802",219 ,0)
  26318    ;Find re- opened cla im(s)
  26319   "RTN","CHM FA802",220 ,0)
  26320    S ICN=0 F   S ICN=$O (^CHMPAY(" C",CPDI,IC N)) Q:'ICN   D
  26321   "RTN","CHM FA802",221 ,0)
  26322    .I $D(^CH MPAY(ICN,6 )),$P(^(6) ,"^")="" D
  26323   "RTN","CHM FA802",222 ,0)
  26324    ..;Check  if piece 4  of 0 node  has the o riginal PD I
  26325   "RTN","CHM FA802",223 ,0)
  26326    ..I $D(^C HMPAY(ICN, 0)),$P(^(0 ),"^",4)'= "" S ORPDI =$P($P(^CH MPAY(ICN,0 ),"^",4)," *")
  26327   "RTN","CHM FA802",224 ,0)
  26328    ..;If P4  of 0 node  is null ge t ORPDI fr om ^CHMPAY (ICN,PDI,1 ,0)
  26329   "RTN","CHM FA802",225 ,0)
  26330    ..I ORPDI ="" S ORPD I=$G(^CHMP AY(ICN,"PD I",1,0))
  26331   "RTN","CHM FA802",226 ,0)
  26332    ..I ORPDI '="" S LAT EST(ORPDI) =""
  26333   "RTN","CHM FA802",227 ,0)
  26334    .I ORPDI= "" D 
  26335   "RTN","CHM FA802",228 ,0)
  26336    ..S IEN=$ P($G(^CHMP AY(ICN,9)) ,"^",8) I  IEN="" Q
  26337   "RTN","CHM FA802",229 ,0)
  26338    ..S ORPDI =$P($P($G( ^CHMPAY(IE N,0)),"^", 4),"*",1)
  26339   "RTN","CHM FA802",230 ,0)
  26340    ..I ORPDI '="" S LAT EST(ORPDI) =""
  26341   "RTN","CHM FA802",231 ,0)
  26342    I '$D(LAT EST) Q 0
  26343   "RTN","CHM FA802",232 ,0)
  26344    ;Find the  latest re -opened cl aim.
  26345   "RTN","CHM FA802",233 ,0)
  26346    S ORPDI=" " S ORPDI= $O(LATEST( ORPDI),-1)
  26347   "RTN","CHM FA802",234 ,0)
  26348    K LATEST
  26349   "RTN","CHM FA802",235 ,0)
  26350    I ORPDI=C PDI S ORPD I=""
  26351   "RTN","CHM FA802",236 ,0)
  26352    Q ORPDI
  26353   "RTN","CHM FA802",237 ,0)
  26354    
  26355   "RTN","CHM FA802",238 ,0)
  26356    
  26357   "RTN","CHM FADR1")
  26358   0^1^B12724 2208
  26359   "RTN","CHM FADR1",1,0 )
  26360   CHMFADR1 ; PJU/DEN;UT ILITY PROG RAM # 1 FO R MAIN DRI VER;Feb 06 , 2019@10: 19:49
  26361   "RTN","CHM FADR1",2,0 )
  26362    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  26363   "RTN","CHM FADR1",3,0 )
  26364    ;CPTS #14 989 (RLC)
  26365   "RTN","CHM FADR1",4,0 )
  26366    ;SUBROUTI NES CALLED  IN DRIVER
  26367   "RTN","CHM FADR1",5,0 )
  26368    ;CFS 08/1 6/2017 CPE 005-004 Ad d the "OCR R-READY" a nd "SBOCRR -READY" qu eues.
  26369   "RTN","CHM FADR1",6,0 )
  26370    ;JSE 10/0 6/2017 CPE 005-051 Re strict use rs to the  reopen men us
  26371   "RTN","CHM FADR1",7,0 )
  26372    ;CFS 10/0 8/2017 CPE 005-069 En sure globa l piece is  cleaned u p if not a  Re-open P DI.
  26373   "RTN","CHM FADR1",8,0 )
  26374    ;BDB 1/25 /2018 Adde d CHMFPDI  to the loc al variabl e kill lis t.
  26375   "RTN","CHM FADR1",9,0 )
  26376    ;BDB 2/8/ 2018 Added  CHFC8CIP  to the loc al variabl e kill lis t.
  26377   "RTN","CHM FADR1",10, 0)
  26378    ;CFS 12/2 0/2018 Def ect 888373  - Change  from using  variable  DT to vari able TMPDT  to preven t Undefine d error.
  26379   "RTN","CHM FADR1",11, 0)
  26380   BATCH ;
  26381   "RTN","CHM FADR1",12, 0)
  26382    I '$D(CHB TCHNO) S C HBTCHNO=$P (^CHMDIC(7 41002.21,D UZ,0),"^", 6)
  26383   "RTN","CHM FADR1",13, 0)
  26384    Q:CHBTCHN O=""
  26385   "RTN","CHM FADR1",14, 0)
  26386    I $$BTCHS T^CHMFABU3 (CHBTCHNO) =1 D
  26387   "RTN","CHM FADR1",15, 0)
  26388    .S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",6)=" "
  26389   "RTN","CHM FADR1",16, 0)
  26390    .S CHMFI= CHBTCHNO,C HMFPP="BAT CLSD"
  26391   "RTN","CHM FADR1",17, 0)
  26392    .S $P(^CH MIMPB(CHBT CHNO,0),"^ ",6)=""
  26393   "RTN","CHM FADR1",18, 0)
  26394    .D ^CHMFW K03
  26395   "RTN","CHM FADR1",19, 0)
  26396    .S J=0
  26397   "RTN","CHM FADR1",20, 0)
  26398    .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
  26399   "RTN","CHM FADR1",21, 0)
  26400    .S CHBTCH NO=""
  26401   "RTN","CHM FADR1",22, 0)
  26402    Q
  26403   "RTN","CHM FADR1",23, 0)
  26404   COUNT S CL CT=0
  26405   "RTN","CHM FADR1",24, 0)
  26406   CO1 S CLCT =$O(CHMFCL MS(CLCT))  Q:CLCT=""
  26407   "RTN","CHM FADR1",25, 0)
  26408    S CHMQNAM ="CHMPAY(" ,CHMIN=""
  26409   "RTN","CHM FADR1",26, 0)
  26410    K CHOUT D  ^CHMIS041
  26411   "RTN","CHM FADR1",27, 0)
  26412    G CO1
  26413   "RTN","CHM FADR1",28, 0)
  26414   LSTPDI ; I f the DUZ  is unknown , print er ror messag e to scree n and quit
  26415   "RTN","CHM FADR1",29, 0)
  26416    I '$D(^CH MDIC(74100 2.21,DUZ,0 )) D NOUSE  S CHQUIT= 1 Q
  26417   "RTN","CHM FADR1",30, 0)
  26418    ; Determi ne what th e last PDI  entered b y the user  was.
  26419   "RTN","CHM FADR1",31, 0)
  26420    S LSTPDI= $P(^CHMDIC (741002.21 ,DUZ,0),"^ ",5)
  26421   "RTN","CHM FADR1",32, 0)
  26422    ; If LSTP DI is not  nil, do th e followin g.  Otherw ise return  to MANUAL ^CHMFADR4
  26423   "RTN","CHM FADR1",33, 0)
  26424    I LSTPDI' ="" D
  26425   "RTN","CHM FADR1",34, 0)
  26426    .S CHMFPD I=LSTPDI ;  Move the  value of L STPDI to C HMFPDI
  26427   "RTN","CHM FADR1",35, 0)
  26428    .S CHMFNM PG=$P($G(^ CHMIMG(CHM FPDI,0))," ^",2)
  26429   "RTN","CHM FADR1",36, 0)
  26430    .K ^CHMIM G("READY", CHMFPDI)
  26431   "RTN","CHM FADR1",37, 0)
  26432    .K ^CHMIM G("OCR-REA DY",CHMFPD I)
  26433   "RTN","CHM FADR1",38, 0)
  26434    .K ^CHMIM G("SBOCR-R EADY",CHMF PDI)
  26435   "RTN","CHM FADR1",39, 0)
  26436    .K ^CHMIM G("OCR2-RE ADY",CHMFP DI)
  26437   "RTN","CHM FADR1",40, 0)
  26438    .K ^CHMIM G("SBOCR2- READY",CHM FPDI)
  26439   "RTN","CHM FADR1",41, 0)
  26440    .K ^CHMIM G("OCRR-RE ADY",CHMFP DI) ;CPE00 5-004
  26441   "RTN","CHM FADR1",42, 0)
  26442    .K ^CHMIM G("SBOCRR- READY",CHM FPDI) ;CPE 005-004
  26443   "RTN","CHM FADR1",43, 0)
  26444    .D PAUSE
  26445   "RTN","CHM FADR1",44, 0)
  26446    S CHMOPDI =$P($G(^CH MDIC(74100 2.21,DUZ,0 )),"^",2)
  26447   "RTN","CHM FADR1",45, 0)
  26448    S CHMOPDI =$S(CHOSEN =6:CHMOPDI ,CHOSEN=7: CHMOPDI,CH OSEN=8:CHM OPDI,1:"")
  26449   "RTN","CHM FADR1",46, 0)
  26450    I CHMOPDI ="" S $P(^ CHMDIC(741 002.21,DUZ ,0),"^",2) =""  ;CPE0 05-069 Ens ure global  piece is  cleaned up .
  26451   "RTN","CHM FADR1",47, 0)
  26452    ; ;That p iece only  needed for  a Re-open  PDI Numbe r.
  26453   "RTN","CHM FADR1",48, 0)
  26454    ; Return  to routine  CHMFADR4
  26455   "RTN","CHM FADR1",49, 0)
  26456    Q
  26457   "RTN","CHM FADR1",50, 0)
  26458   PAUSE S PA USDT=""
  26459   "RTN","CHM FADR1",51, 0)
  26460    D NOW^%DT C
  26461   "RTN","CHM FADR1",52, 0)
  26462    ; Search  for paused  PDI's
  26463   "RTN","CHM FADR1",53, 0)
  26464   P1 S PAUSD T=$O(^CHMI MG(CHMFPDI ,"PAUSE",P AUSDT)) Q: 'PAUSDT
  26465   "RTN","CHM FADR1",54, 0)
  26466    G:'$D(^CH MIMG(CHMFP DI,"PAUSE" ,PAUSDT,0) ) P1
  26467   "RTN","CHM FADR1",55, 0)
  26468    ; Set PAU SEDT to th e date/tim e stored i n piece 3  of ^CHMIMG (I,"PAUSE" ,J,0)
  26469   "RTN","CHM FADR1",56, 0)
  26470    S PAUSEDT =$P(^CHMIM G(CHMFPDI, "PAUSE",PA USDT,0),"^ ",3)
  26471   "RTN","CHM FADR1",57, 0)
  26472    ; If PAUS EDT is nil , set it t o the curr ent date/t ime retrie ved from N OW^%DTC an d quit
  26473   "RTN","CHM FADR1",58, 0)
  26474    I PAUSEDT ="" S $P(^ CHMIMG(CHM FPDI,"PAUS E",PAUSDT, 0),"^",3)= % Q
  26475   "RTN","CHM FADR1",59, 0)
  26476    G P1
  26477   "RTN","CHM FADR1",60, 0)
  26478   NOUSE W !! ,"USER NOT  DEFINED I N THE CHAM PVA USER F ILE!" Q
  26479   "RTN","CHM FADR1",61, 0)
  26480   SETUP ; Ki ll the fol lowing var iables
  26481   "RTN","CHM FADR1",62, 0)
  26482    K CHMFBN, CHNEWPG
  26483   "RTN","CHM FADR1",63, 0)
  26484    ; TOP^CHM FA100 form ats the to p of the s creen
  26485   "RTN","CHM FADR1",64, 0)
  26486    D TOP^CHM FA100
  26487   "RTN","CHM FADR1",65, 0)
  26488    ; BOTT^CH MFA100 for mats the b ottom of t he screen
  26489   "RTN","CHM FADR1",66, 0)
  26490    D BOTT^CH MFA100
  26491   "RTN","CHM FADR1",67, 0)
  26492    S DTM=4,D BM=20 X CH MAR
  26493   "RTN","CHM FADR1",68, 0)
  26494    ; If ther e is no DU Z, do ERR1  and quit
  26495   "RTN","CHM FADR1",69, 0)
  26496    I '$D(DUZ ) D ERR1 Q
  26497   "RTN","CHM FADR1",70, 0)
  26498    S CHMFDUZ =DUZ
  26499   "RTN","CHM FADR1",71, 0)
  26500    S CHUSER= "UNKNOWN"
  26501   "RTN","CHM FADR1",72, 0)
  26502    I DUZ'=""  S:$D(^VA( 200,DUZ,0) ) CHUSER=$ P(^VA(200, DUZ,0),"^" ,1)
  26503   "RTN","CHM FADR1",73, 0)
  26504    Q
  26505   "RTN","CHM FADR1",74, 0)
  26506   SETUP1 K F 6,CHMFFIN, CHNOFLAG,C HYESFLG,R1 ,R2,R3,R4, R7,CHMFKIL ,CHMFC,CHM FPS
  26507   "RTN","CHM FADR1",75, 0)
  26508    S (CHMFPD I,CHMFIMAG ,CHMFIMTY, CHMFIMNM,C HMFNMPG,CH MFPGNM,CHM FTYPE)=""
  26509   "RTN","CHM FADR1",76, 0)
  26510    S (F1,CHM FIMCT,CHMF PGCT)=""
  26511   "RTN","CHM FADR1",77, 0)
  26512    Q
  26513   "RTN","CHM FADR1",78, 0)
  26514   PSMSG Q
  26515   "RTN","CHM FADR1",79, 0)
  26516    ; SEND TO  PSQ REMOV ED.  CALL  WAS ROUTIN E CHMG172A
  26517   "RTN","CHM FADR1",80, 0)
  26518    ;
  26519   "RTN","CHM FADR1",81, 0)
  26520   KLOCK I $D (CHMFPDI)  K:CHMFPDI' ="" ^CHMIM AGE("LOCK" ,CHMFPDI)
  26521   "RTN","CHM FADR1",82, 0)
  26522    Q
  26523   "RTN","CHM FADR1",83, 0)
  26524   NEWPG D TO P^CHMFA100
  26525   "RTN","CHM FADR1",84, 0)
  26526    D BOTT^CH MFA100
  26527   "RTN","CHM FADR1",85, 0)
  26528    S DTM=4,D BM=20 X CH MAR
  26529   "RTN","CHM FADR1",86, 0)
  26530    Q
  26531   "RTN","CHM FADR1",87, 0)
  26532   REMV D REM V^CHMFPDI
  26533   "RTN","CHM FADR1",88, 0)
  26534    Q
  26535   "RTN","CHM FADR1",89, 0)
  26536   REMV1 D RE MV1^CHMFPD I
  26537   "RTN","CHM FADR1",90, 0)
  26538    Q
  26539   "RTN","CHM FADR1",91, 0)
  26540   DELST1 Q:' $D(^CHMDIC (741002.21 ,DUZ,0))
  26541   "RTN","CHM FADR1",92, 0)
  26542    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",5)=""
  26543   "RTN","CHM FADR1",93, 0)
  26544    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=""
  26545   "RTN","CHM FADR1",94, 0)
  26546    Q
  26547   "RTN","CHM FADR1",95, 0)
  26548   SETPD Q:'$ D(^CHMDIC( 741002.21, DUZ,0))
  26549   "RTN","CHM FADR1",96, 0)
  26550    Q:CHMFPDI =""
  26551   "RTN","CHM FADR1",97, 0)
  26552    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",5)=CH MFPDI
  26553   "RTN","CHM FADR1",98, 0)
  26554    I '$G(VAL OPDI) S $P (^CHMDIC(7 41002.21,D UZ,0),"^", 2)=$G(CHMO PDI)  ;CFS  CPE001-00 4
  26555   "RTN","CHM FADR1",99, 0)
  26556    I $D(CHBT CHNO) I CH BTCHNO'=""  S $P(^CHM IMPB(CHBTC HNO,0),"^" ,6)=""
  26557   "RTN","CHM FADR1",100 ,0)
  26558    S JPD=999 99
  26559   "RTN","CHM FADR1",101 ,0)
  26560    S JPD=$O( ^CHMIMG(CH MFPDI,"PAU SE",JPD),- 1)
  26561   "RTN","CHM FADR1",102 ,0)
  26562    I JPD=""  S JPD=0
  26563   "RTN","CHM FADR1",103 ,0)
  26564    S JPD=JPD +1
  26565   "RTN","CHM FADR1",104 ,0)
  26566    D NOW^%DT C
  26567   "RTN","CHM FADR1",105 ,0)
  26568    S $P(^CHM IMG(CHMFPD I,"PAUSE", JPD,0),"^" ,1)=%
  26569   "RTN","CHM FADR1",106 ,0)
  26570    S $P(^CHM IMG(CHMFPD I,"PAUSE", JPD,0),"^" ,2)=DUZ
  26571   "RTN","CHM FADR1",107 ,0)
  26572    K JPD
  26573   "RTN","CHM FADR1",108 ,0)
  26574    Q
  26575   "RTN","CHM FADR1",109 ,0)
  26576   SKIP S PDI J=0
  26577   "RTN","CHM FADR1",110 ,0)
  26578    Q:'$D(CHB TCHNO)
  26579   "RTN","CHM FADR1",111 ,0)
  26580    Q:'CHBTCH NO
  26581   "RTN","CHM FADR1",112 ,0)
  26582   SK1 S PDIJ =$O(^CHMIM PB(CHBTCHN O,100,PDIJ )) Q:'PDIJ
  26583   "RTN","CHM FADR1",113 ,0)
  26584    G:'$D(^CH MIMPB(CHBT CHNO,100,P DIJ,0)) SK 1
  26585   "RTN","CHM FADR1",114 ,0)
  26586    G:$P(^(0) ,"^",3)'=5  SK1
  26587   "RTN","CHM FADR1",115 ,0)
  26588    S $P(^(0) ,"^",3)=0
  26589   "RTN","CHM FADR1",116 ,0)
  26590    G SK1
  26591   "RTN","CHM FADR1",117 ,0)
  26592   READY Q:'$ D(CHMFPDI)
  26593   "RTN","CHM FADR1",118 ,0)
  26594    Q:CHMFPDI =""
  26595   "RTN","CHM FADR1",119 ,0)
  26596    Q:'$D(^CH MIMG(CHMFP DI,"DOC"))
  26597   "RTN","CHM FADR1",120 ,0)
  26598    S:$D(CHDO CID) ^CHMI MG("READY" ,CHMFPDI)= ""
  26599   "RTN","CHM FADR1",121 ,0)
  26600    Q
  26601   "RTN","CHM FADR1",122 ,0)
  26602   OCRRDY ;FO R CHAMPVA  EDI CLAIMS
  26603   "RTN","CHM FADR1",123 ,0)
  26604    Q:'$D(CHM FPDI)
  26605   "RTN","CHM FADR1",124 ,0)
  26606    Q:CHMFPDI =""
  26607   "RTN","CHM FADR1",125 ,0)
  26608    S ^CHMIMG ("OCR-READ Y",CHMFPDI )=""
  26609   "RTN","CHM FADR1",126 ,0)
  26610    ;NEXT LIN E FOR SYST EM STATIST ICS -- ADD  ONE TO ED I/OCR
  26611   "RTN","CHM FADR1",127 ,0)
  26612    ;S CHMQNA M="EDI/OCR ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  26613   "RTN","CHM FADR1",128 ,0)
  26614    Q
  26615   "RTN","CHM FADR1",129 ,0)
  26616   OCR2RDY ;F OR CHAMPVA  OCR CLAIM S
  26617   "RTN","CHM FADR1",130 ,0)
  26618    Q:'$D(CHM FPDI)
  26619   "RTN","CHM FADR1",131 ,0)
  26620    Q:CHMFPDI =""
  26621   "RTN","CHM FADR1",132 ,0)
  26622    S ^CHMIMG ("OCR2-REA DY",CHMFPD I)=""
  26623   "RTN","CHM FADR1",133 ,0)
  26624    ;NEXT LIN E FOR SYST EM STATIST ICS -- ADD  ONE TO ED I/OCR
  26625   "RTN","CHM FADR1",134 ,0)
  26626    ;S CHMQNA M="EDI/OCR ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  26627   "RTN","CHM FADR1",135 ,0)
  26628    Q
  26629   "RTN","CHM FADR1",136 ,0)
  26630   SBOCRDY ;F OR SB/CWVV  EDI CLAIM S
  26631   "RTN","CHM FADR1",137 ,0)
  26632    Q:'$D(CHM FPDI)  Q:C HMFPDI=""
  26633   "RTN","CHM FADR1",138 ,0)
  26634    S ^CHMIMG ("SBOCR-RE ADY",CHMFP DI)=""
  26635   "RTN","CHM FADR1",139 ,0)
  26636    ;NEXT LIN E FOR SYST EM STATIST ICS -- ADD  ONE TO ED I/OCR
  26637   "RTN","CHM FADR1",140 ,0)
  26638    ;S CHMQNA M="EDI/OCR ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  26639   "RTN","CHM FADR1",141 ,0)
  26640    Q
  26641   "RTN","CHM FADR1",142 ,0)
  26642   SBOCR2DY ; FOR SB/CWV V OCR CLAI MS
  26643   "RTN","CHM FADR1",143 ,0)
  26644    Q:'$D(CHM FPDI)  Q:C HMFPDI=""
  26645   "RTN","CHM FADR1",144 ,0)
  26646    S ^CHMIMG ("SBOCR2-R EADY",CHMF PDI)=""
  26647   "RTN","CHM FADR1",145 ,0)
  26648    ;NEXT LIN E FOR SYST EM STATIST ICS -- ADD  ONE TO ED I/OCR
  26649   "RTN","CHM FADR1",146 ,0)
  26650    ;S CHMQNA M="EDI/OCR ",CHMIN=""  K CHMOUT  D ^CHMIS04 1
  26651   "RTN","CHM FADR1",147 ,0)
  26652    Q
  26653   "RTN","CHM FADR1",148 ,0)
  26654   MANL  ;CPE 005-069 FO R MANUAL E DI REOPEN
  26655   "RTN","CHM FADR1",149 ,0)
  26656    Q:'$D(CHM FPDI)
  26657   "RTN","CHM FADR1",150 ,0)
  26658    Q:CHMFPDI =""
  26659   "RTN","CHM FADR1",151 ,0)
  26660    S ^CHMIMG ("MANUAL", CHMFPDI)=" "
  26661   "RTN","CHM FADR1",152 ,0)
  26662    Q
  26663   "RTN","CHM FADR1",153 ,0)
  26664   OCRRRDY ;C PE005-004  FOR CHAMPV A EDI REOP EN
  26665   "RTN","CHM FADR1",154 ,0)
  26666    Q:'$D(CHM FPDI)  Q:C HMFPDI=""
  26667   "RTN","CHM FADR1",155 ,0)
  26668    S ^CHMIMG ("OCRR-REA DY",CHMFPD I)=""
  26669   "RTN","CHM FADR1",156 ,0)
  26670    Q
  26671   "RTN","CHM FADR1",157 ,0)
  26672   SBOCRRDY ; CPE005-004  FOR S/B E DI REOPEN
  26673   "RTN","CHM FADR1",158 ,0)
  26674    Q:'$D(CHM FPDI)  Q:C HMFPDI=""
  26675   "RTN","CHM FADR1",159 ,0)
  26676    S ^CHMIMG ("SBOCRR-R EADY",CHMF PDI)=""
  26677   "RTN","CHM FADR1",160 ,0)
  26678    Q
  26679   "RTN","CHM FADR1",161 ,0)
  26680   ERR1 ; Pri nt out err or message  to termin al and qui t program.
  26681   "RTN","CHM FADR1",162 ,0)
  26682    S DY=5,DX =10 X XY W  "User is  unknown to  system",@ CHEOL
  26683   "RTN","CHM FADR1",163 ,0)
  26684    S DY=6,DX =10 X XY W  "Please L og onto te rminal aga in",@CHEOL
  26685   "RTN","CHM FADR1",164 ,0)
  26686    R RD:2
  26687   "RTN","CHM FADR1",165 ,0)
  26688    Q
  26689   "RTN","CHM FADR1",166 ,0)
  26690   KILALL K A ,BFN,CH,CH CTRD,CHCTR O,CHMFCLMS ,CHMCL,DFN ,CHBENNM,V FN,CHMVEN, CHMFCORR
  26691   "RTN","CHM FADR1",167 ,0)
  26692    K CHMFACC N,CHMFAMNT ,CHMFASDT, CHMFASS,CH MFBFN,CHMF C,CHMFCLIN ,CHMBEN
  26693   "RTN","CHM FADR1",168 ,0)
  26694    K CHFC8CI P,CHMFCOMM ,CHMFCONT, CHMFCOR,CH MFDATE,CHM FDAYS,CHMF DCBN,CHMFD CVN ;bdb 2 /8/2018 ad ded CHFC8C IP
  26695   "RTN","CHM FADR1",169 ,0)
  26696    K CHMFDFN ,CHMFELIG, CHMFFIN,CH MFFL,CHMFF L1,CHMFHCP C,CHMFICD9 ,CHMFIMAG
  26697   "RTN","CHM FADR1",170 ,0)
  26698    K CHMFIMC T,CHMFIMNM ,CHMFIMTY, CHMFINCT,C HMFINTC,CH MFINVD,CHM FINVN
  26699   "RTN","CHM FADR1",171 ,0)
  26700    K CHMFKIL ,CHMFLIST, CHMFLOC,CH MFNMPG,CHM FOUT,CHMFP DI,CHMFPGC T,CHMFPGNM  ;bdb 12/2 5/2017 add ed CHMFPDI
  26701   "RTN","CHM FADR1",172 ,0)
  26702    K CHMFPLA C,CHMFPLPT ,CHMFPRCT, CHMFPS,CHM FPSBN,CHMF REDO,CHMFR EF,CHMFSAM E
  26703   "RTN","CHM FADR1",173 ,0)
  26704    K CHMFSVT Y,CHMFTERM ,CHMFTMBG, CHMFTYPE,C HMFQUIT,CH NB,CHSAME, CHSDX,CHSD Y
  26705   "RTN","CHM FADR1",174 ,0)
  26706    K CHT,CHT Y,CHUP,DBM ,DF,DF1,DF N,DFOUT,DI C,DLAYGO,D R,DTM,F1,F 2,FLAG4,J
  26707   "RTN","CHM FADR1",175 ,0)
  26708    K K,HDA,H LD,HTYPE,I V,NM,NW,PD IFL,SFL,SU RFACE,CHFA RM,TOOTH,T Y,QU,VEN
  26709   "RTN","CHM FADR1",176 ,0)
  26710    K VFN,X,X PLUS,ZCT,Z ICN,CHMCCR FG,CHRXN,C HNDC,CHRXD ,CHRXDP,CH PSN,CHQNT
  26711   "RTN","CHM FADR1",177 ,0)
  26712    K CHBAMT, CHICD9,CHG NIND,CHICD S9,CHDFL,I CD,CHMFGO, CHLTG,ZY,Z X,DY,DX
  26713   "RTN","CHM FADR1",178 ,0)
  26714    K CHUP,CH UPS,CHDOWN ,CHDOWNS,C HOSEN,CHSA ME,CHOUT,C HSDX,CHSDY ,CHANSW,CH LG
  26715   "RTN","CHM FADR1",179 ,0)
  26716    K CHMFQUI T,CHT,DDOU T,X,Y,ZSTN ,CHREDO,ZS TF,ZTM,ZBM K,CHPTC,CH EKR,CHHDFN
  26717   "RTN","CHM FADR1",180 ,0)
  26718    K CHHBFN, CHOUTER,CH ENTRE,CHFC T,CHFIFLAG ,CMENTR,CH MFEDIT,CHM FENTR
  26719   "RTN","CHM FADR1",181 ,0)
  26720    K CHPPX,C HOUTR,CHGN IND,L9,M,M 1,PRXD,STE FL,Y9,TL,F LAG,FLAG1, FLAG2,FLAG 3
  26721   "RTN","CHM FADR1",182 ,0)
  26722    K FLAG4,S 1,Y1,Y2,AN ,L,N,M9,M8 ,CHMFCOT,C H9,CH99,CH CTL1,CHJ,C HJJ,CHKILR
  26723   "RTN","CHM FADR1",183 ,0)
  26724    K CHKIR,C HNUMBR,CHP ,CHPZ,CHSC T,CHSCTS,C HSCTS1,CHS T1,HIP,PCH MFH
  26725   "RTN","CHM FADR1",184 ,0)
  26726    K CHMFBAS C,PV,CHVEN NM,CHBEN,C HBTCHNO,CH TOBIL,A1,A A,ASKFL,AS S,BAD,BL
  26727   "RTN","CHM FADR1",185 ,0)
  26728    K BLNK1,B LNK2,BN,C, CFL,CHASSG N,CHCODE,C HCOMFL,CHD EF,CHDTA,C HHDT,CHIBT CH
  26729   "RTN","CHM FADR1",186 ,0)
  26730    K CHINGOR ,CHMCCR,CH FMCLNM,CHM FI,CHMFNEX T,CHMFPP,C HMFREVS,CH MFRS,CHMFR TN
  26731   "RTN","CHM FADR1",187 ,0)
  26732    K CHMFSER V,CHMFSORT ,CHMFSRVC, CHMFTY,CHM INUS,CHMNE XT,CHMNRTN ,CHNOW,CHO ICE
  26733   "RTN","CHM FADR1",188 ,0)
  26734    K CHORG,C HSUM,CHUPF L,CL,CLT,C HMAC,CNO,C NT,CT,CT1, CTY,D,D0,D A1,DA2,DDE R
  26735   "RTN","CHM FADR1",189 ,0)
  26736    K DI,DN,D OS,DQ,EX,F IPAY,FKIL, HR,HVFN,HX ,HY,I,ID,I MG,LINW,LL ,LN,MEDPTR
  26737   "RTN","CHM FADR1",190 ,0)
  26738    K MIN,NEX TPAGE,OHIA MT,OHIDOS, OHIIND,OHI NAME,OHIRE C,OHITOS,O HITYP,PAY, PG,PLS,PS
  26739   "RTN","CHM FADR1",191 ,0)
  26740    K PT,PVN, PY,REC,REC 40,RNG,RNG BD,RNGED,S DATE,SN,SP ,STR,STR1, SUB,SUB1
  26741   "RTN","CHM FADR1",192 ,0)
  26742    K SUB2,SU B3,SUB4,SU B5,SUB6,SV FLD,TAB1,T AB2,TOTSUM ,TSP,VALOP DI,VDC,VN, VNPG
  26743   "RTN","CHM FADR1",193 ,0)
  26744    K VREC0,V REC1,XX,Z, ZZPDI,ZVFN
  26745   "RTN","CHM FADR1",194 ,0)
  26746   KILPDI I $ D(CHMFPDI) ,CHMFPDI'= "" D
  26747   "RTN","CHM FADR1",195 ,0)
  26748    .K ^CHMIM AGE(CHMFPD I) ;               KI LL PDI
  26749   "RTN","CHM FADR1",196 ,0)
  26750    .K ^CHMIM AGE("AC",C HMFPDI) ;          KI LL CROSS R EF
  26751   "RTN","CHM FADR1",197 ,0)
  26752    .K ^CHMIM AGE(CHMFPD I,"AD") ;          KI LL CROSS R EF
  26753   "RTN","CHM FADR1",198 ,0)
  26754    .K ^CHMIM AGE("B",CH MFPDI) ;           KI LL CROSS R EF
  26755   "RTN","CHM FADR1",199 ,0)
  26756    .K:CHMFPD I'="" ^CHM IMAGE("LOC K",CHMFPDI )
  26757   "RTN","CHM FADR1",200 ,0)
  26758    .S $P(^CH MIMG(CHMFP DI,0),"^", 6)=0
  26759   "RTN","CHM FADR1",201 ,0)
  26760    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  26761   "RTN","CHM FADR1",202 ,0)
  26762    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  26763   "RTN","CHM FADR1",203 ,0)
  26764    I $D(CHBT CHNO) I CH BTCHNO=0 D   Q
  26765   "RTN","CHM FADR1",204 ,0)
  26766    .S:$D(^CH MDIC(74100 2.21,DUZ,0 )) $P(^(0) ,"^",6)=""
  26767   "RTN","CHM FADR1",205 ,0)
  26768    .S CHBTCH NO="" Q
  26769   "RTN","CHM FADR1",206 ,0)
  26770    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=0  I $D(CHBT CHNO) I CH BTCHNO'=""  D
  26771   "RTN","CHM FADR1",207 ,0)
  26772    .S X=$$BT CHST^CHMFA BU3(CHBTCH NO)
  26773   "RTN","CHM FADR1",208 ,0)
  26774    .S X=$$BT CHUP^CHMFA BU3(CHBTCH NO)
  26775   "RTN","CHM FADR1",209 ,0)
  26776    .I 'X S:$ D(^CHMDIC( 741002.21, DUZ,0)) $P (^(0),"^", 6)="" D
  26777   "RTN","CHM FADR1",210 ,0)
  26778    ..S CHMFI =CHBTCHNO, CHMFPP="BA TKILL" D ^ CHMFWK03
  26779   "RTN","CHM FADR1",211 ,0)
  26780    I $D(CHBT CHNO) I CH BTCHNO'=""  S $P(^CHM IMPB(CHBTC HNO,0),"^" ,6)=""
  26781   "RTN","CHM FADR1",212 ,0)
  26782    Q
  26783   "RTN","CHM FADR1",213 ,0)
  26784   SETPROD ;
  26785   "RTN","CHM FADR1",214 ,0)
  26786    S SDATE=$ P(($$HTFM^ XLFDT($H)) ,".",1)
  26787   "RTN","CHM FADR1",215 ,0)
  26788    S TMPTIME =$P(($$HTF M^XLFDT($H )),".",2)
  26789   "RTN","CHM FADR1",216 ,0)
  26790    S HR=$E(T MPTIME,1,2 ),MIN=$E(T MPTIME,3,4 )
  26791   "RTN","CHM FADR1",217 ,0)
  26792    I MIN>29  S MIN=30 G  PROD1
  26793   "RTN","CHM FADR1",218 ,0)
  26794    S MIN=+(0 0)
  26795   "RTN","CHM FADR1",219 ,0)
  26796   PROD1 S TM PDT=+(SDAT E_"."_HR_M IN)
  26797   "RTN","CHM FADR1",220 ,0)
  26798    S:'$D(FKI L) FKIL=0  S:'$D(PS)  PS=0 S:'$D (BAD) BAD= 0 S:'$D(FI PAY) FIPAY =0
  26799   "RTN","CHM FADR1",221 ,0)
  26800    ;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
  26801   "RTN","CHM FADR1",222 ,0)
  26802    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
  26803   "RTN","CHM FADR1",223 ,0)
  26804    I FKIL=1  I $D(CHMFP DI) I CHMF PDI'="" I  $D(^CHMIMA GE(CHMFPDI ,0)) I $P( ^CHMIMAGE( CHMFPDI,0) ,"^",9)=1  D
  26805   "RTN","CHM FADR1",224 ,0)
  26806    .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
  26807   "RTN","CHM FADR1",225 ,0)
  26808    .S CHMFI= CHMFPDI,CH MFPP="SKIL " D ^CHMFW K01
  26809   "RTN","CHM FADR1",226 ,0)
  26810    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
  26811   "RTN","CHM FADR1",227 ,0)
  26812    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
  26813   "RTN","CHM FADR1",228 ,0)
  26814    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
  26815   "RTN","CHM FADR1",229 ,0)
  26816    S (PS,FKI L,FIPAY,BA D)=0
  26817   "RTN","CHM FADR1",230 ,0)
  26818    Q
  26819   "RTN","CHM FADR1",231 ,0)
  26820   OCRKIL ;RE SETS VE PD I CLOCK WH EN PLACING  EDI/OCR C LAIMS IN H OLD Q -- T AB 7
  26821   "RTN","CHM FADR1",232 ,0)
  26822    ;AEB ADDE D LOGIC TO  SET PDI T O COMPLETE  AND ADD P DI COMMENT S 4/20/200 7
  26823   "RTN","CHM FADR1",233 ,0)
  26824    I $D(CHMF PDI),CHMFP DI'="" D
  26825   "RTN","CHM FADR1",234 ,0)
  26826    .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
  26827   "RTN","CHM FADR1",235 ,0)
  26828    .F I=18:1 :24 S DX=0 ,DY=I X XY  W @CHEOL
  26829   "RTN","CHM FADR1",236 ,0)
  26830    .S DX=2,D Y=18 X XY  W "WARNING : This pro cess will  DELETE EDI /OCR PDIs  from the R EADY queue !!"
  26831   "RTN","CHM FADR1",237 ,0)
  26832    .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
  26833   "RTN","CHM FADR1",238 ,0)
  26834    .S Y=$E(Y ,1) S:Y=""  Y="Y"
  26835   "RTN","CHM FADR1",239 ,0)
  26836    .S Y=$$UP ^XLFSTR(Y)  I Y="N" D
  26837   "RTN","CHM FADR1",240 ,0)
  26838    ..S $P(^C HMIMG(CHMF PDI,0),"^" ,6)=0
  26839   "RTN","CHM FADR1",241 ,0)
  26840    ..S $P(^C HMIMG(CHMF PDI,0),"^" ,3)=""
  26841   "RTN","CHM FADR1",242 ,0)
  26842    ..S $P(^C HMIMG(CHMF PDI,0),"^" ,4)=""
  26843   "RTN","CHM FADR1",243 ,0)
  26844    ..S ^CHMI MG("EDI/OC R-HOLD",CH MFPDI)=""
  26845   "RTN","CHM FADR1",244 ,0)
  26846    ..Q
  26847   "RTN","CHM FADR1",245 ,0)
  26848    .I Y="Y"  D
  26849   "RTN","CHM FADR1",246 ,0)
  26850    ..S DX=2, DY=20 X XY  W "That P DI has bee n deleted  from the R eady Queue " R X:1
  26851   "RTN","CHM FADR1",247 ,0)
  26852    ..S $P(^C HMIMG(CHMF PDI,0),"^" ,6)=4
  26853   "RTN","CHM FADR1",248 ,0)
  26854    ..D NOW^% DTC S $P(^ CHMIMG(CHM FPDI,0),"^ ",5)=%,$P( ^CHMIMG(CH MFPDI,0)," ^",3)=DUZ
  26855   "RTN","CHM FADR1",249 ,0)
  26856    ..S $P(^C HMIMAGE(CH MFPDI,0)," ^",9)=1
  26857   "RTN","CHM FADR1",250 ,0)
  26858    ..I $D(^C HMIMG("OCR -READY",CH MFPDI)) K  ^CHMIMG("O CR-READY", CHMFPDI)
  26859   "RTN","CHM FADR1",251 ,0)
  26860    ..I $D(^C HMIMG("SBO CR-READY", CHMFPDI))  K ^CHMIMG( "SBOCR-REA DY",CHMFPD I)
  26861   "RTN","CHM FADR1",252 ,0)
  26862    ..I $D(^C HMIMG("OCR 2-READY",C HMFPDI)) K  ^CHMIMG(" OCR2-READY ",CHMFPDI)
  26863   "RTN","CHM FADR1",253 ,0)
  26864    ..I $D(^C HMIMG("SBO CR2-READY" ,CHMFPDI))  K ^CHMIMG ("SBOCR2-R EADY",CHMF PDI)
  26865   "RTN","CHM FADR1",254 ,0)
  26866    ..I $D(^C HMIMG("OCR R-READY",C HMFPDI)) K  ^CHMIMG(" OCRR-READY ",CHMFPDI)  ;CPE005-0 04
  26867   "RTN","CHM FADR1",255 ,0)
  26868    ..I $D(^C HMIMG("SBO CRR-READY" ,CHMFPDI))  K ^CHMIMG ("SBOCRR-R EADY",CHMF PDI) ;CPE0 05-004
  26869   "RTN","CHM FADR1",256 ,0)
  26870    ..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
  26871   "RTN","CHM FADR1",257 ,0)
  26872    ..Q
  26873   "RTN","CHM FADR1",258 ,0)
  26874    .;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
  26875   "RTN","CHM FADR1",259 ,0)
  26876    .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
  26877   "RTN","CHM FADR1",260 ,0)
  26878    .Q
  26879   "RTN","CHM FADR1",261 ,0)
  26880    Q
  26881   "RTN","CHM FADR1",262 ,0)
  26882    ;
  26883   "RTN","CHM FADR1",263 ,0)
  26884   SCHK(DUZ)  ;SECURITY  CHECK - VA LIDATE USE R FOR RE-O PEN MENUS
  26885   "RTN","CHM FADR1",264 ,0)
  26886    ;JSE 10/0 6/2017 CPE 005-051
  26887   "RTN","CHM FADR1",265 ,0)
  26888    I '$D(DUZ ) Q 0
  26889   "RTN","CHM FADR1",266 ,0)
  26890    N ALLOW,R OLE,TITLE
  26891   "RTN","CHM FADR1",267 ,0)
  26892    S ALLOW=0
  26893   "RTN","CHM FADR1",268 ,0)
  26894    S TITLE=$ P($G(^CHMD IC(741002. 21,DUZ,0)) ,"^",3),RO LE=$P($G(^ VA(200,DUZ ,0)),"^",9 )
  26895   "RTN","CHM FADR1",269 ,0)
  26896    ;Secondar y programm er access
  26897   "RTN","CHM FADR1",270 ,0)
  26898    I ROLE=15 76 Q 1
  26899   "RTN","CHM FADR1",271 ,0)
  26900    ;CHECK RC  - CHAMPVA  EDI REOPE N
  26901   "RTN","CHM FADR1",272 ,0)
  26902    I Y="RC"  D  Q ALLOW
  26903   "RTN","CHM FADR1",273 ,0)
  26904    .;R&R VEs , PAs, Lea ds, Superv isors
  26905   "RTN","CHM FADR1",274 ,0)
  26906    .I (";R&R  SUPERVISO R;R&R PROG RAM ANALYS T;R&R LEAD ;R&R VE;"[ (";"_TITLE _";")) S A LLOW=1 Q
  26907   "RTN","CHM FADR1",275 ,0)
  26908    .W !!,*7, ?8,TITLE,"  not autho rized to p rocess CHA MPVA EDI R eopen clai ms." R XX: 5
  26909   "RTN","CHM FADR1",276 ,0)
  26910    .;CHECK R S - SB EDI  REOPEN
  26911   "RTN","CHM FADR1",277 ,0)
  26912    I Y="RS"  D  Q ALLOW
  26913   "RTN","CHM FADR1",278 ,0)
  26914    .;SB VEs,  PAs, Lead s, and Sup ervisors
  26915   "RTN","CHM FADR1",279 ,0)
  26916    .I (";PSD  SUPERVISO R;PSD PA;P SD LEAD;PS D SB VE;"[ (";"_TITLE _";")) S A LLOW=1 Q
  26917   "RTN","CHM FADR1",280 ,0)
  26918    .W !!,*7, ?8,TITLE,"  not autho rized to p rocess SB  EDI Reopen  claims."  R XX:5
  26919   "RTN","CHM FADR1",281 ,0)
  26920    ;CHECK ER  - MANUAL  EDI REOPEN
  26921   "RTN","CHM FADR1",282 ,0)
  26922    I Y="ER"  D  Q ALLOW
  26923   "RTN","CHM FADR1",283 ,0)
  26924    .I ";R&R  VE;PSD SB  VE;"[(";"_ TITLE_";")  S ALLOW=1  Q
  26925   "RTN","CHM FADR1",284 ,0)
  26926    .W !!,*7, ?8,TITLE,"  not autho rized to p rocess Man ual EDI Re open claim s." R XX:5
  26927   "RTN","CHM FADR1",285 ,0)
  26928    Q ALLOW
  26929   "RTN","CHM FADR1",286 ,0)
  26930    ;
  26931   "RTN","CHM FADR4")
  26932   0^54^B2679 34873
  26933   "RTN","CHM FADR4",1,0 )
  26934   CHMFADR4 ; CVA/JLR;UT ILITY PROG RAM #3 FOR  IP DRIVER ;Feb 06, 2 019@10:21: 07
  26935   "RTN","CHM FADR4",2,0 )
  26936    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  26937   "RTN","CHM FADR4",3,0 )
  26938    ;CFS 08/0 9/2017 CPE 005-004 Pu ll Current  and Orign al PDI Num bers. New  line tags  "OCRR" and  "SBOCRR".
  26939   "RTN","CHM FADR4",4,0 )
  26940    ;CFS 08/0 9/2017 CPE 005-004 Fi x bug with  Undefined  errors on  variable  CHDOCID.
  26941   "RTN","CHM FADR4",5,0 )
  26942    ;CFS 10/0 1/2017 CPE 005-069 Ad d the Manu al EDI Re- open Doc I D Screen.
  26943   "RTN","CHM FADR4",6,0 )
  26944    ;CFS 10/0 1/2017 CPE 005-071 De fault CHMF TYPE to BI LL/INVOICE  for the I mage Type.
  26945   "RTN","CHM FADR4",7,0 )
  26946    ;BDB 12/1 1/2017 CPE 005-033
  26947   "RTN","CHM FADR4",8,0 )
  26948    ;CFS 01/0 7/2017 CPE 005-041 Pa ss in TYPE RUN as var iable in l ine tag CH RJ1.
  26949   "RTN","CHM FADR4",9,0 )
  26950    ;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.
  26951   "RTN","CHM FADR4",10, 0)
  26952    ;CFS 02/0 8/2018 CPE 005-033 Ca ll the new  CSTAT cre ation rout ine CRCSTA T^CHMFUTLE .
  26953   "RTN","CHM FADR4",11, 0)
  26954   SCAN ;SCAN NED CLAIMS  GO HERE
  26955   "RTN","CHM FADR4",12, 0)
  26956    ;
  26957   "RTN","CHM FADR4",13, 0)
  26958    N CHOSEN
  26959   "RTN","CHM FADR4",14, 0)
  26960    S (PS,FKI L,FIPAY,BA D)=0
  26961   "RTN","CHM FADR4",15, 0)
  26962    S CHMFPDI ="",CHOSEN =1
  26963   "RTN","CHM FADR4",16, 0)
  26964    D LSTPDI^ CHMFADR1
  26965   "RTN","CHM FADR4",17, 0)
  26966    D SETUP^C HMFADR1
  26967   "RTN","CHM FADR4",18, 0)
  26968    G:CHMFPDI '="" S01
  26969   "RTN","CHM FADR4",19, 0)
  26970   S0 D SETUP 1^CHMFADR1
  26971   "RTN","CHM FADR4",20, 0)
  26972    D ^CHMFPD I Q:$D(CHQ UIT)
  26973   "RTN","CHM FADR4",21, 0)
  26974   S01 S ZZPD I=CHMFPDI
  26975   "RTN","CHM FADR4",22, 0)
  26976    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  26977   "RTN","CHM FADR4",23, 0)
  26978    S CHMFPP= "SIP" D ^C HMFWK01
  26979   "RTN","CHM FADR4",24, 0)
  26980    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=1
  26981   "RTN","CHM FADR4",25, 0)
  26982    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  26983   "RTN","CHM FADR4",26, 0)
  26984   S1 D ^CHMF A001
  26985   "RTN","CHM FADR4",27, 0)
  26986    I $D(CHYE SFLG) D  G  S0
  26987   "RTN","CHM FADR4",28, 0)
  26988    .D KLOCK^ CHMFADR1
  26989   "RTN","CHM FADR4",29, 0)
  26990    .D REMV^C HMFADR1
  26991   "RTN","CHM FADR4",30, 0)
  26992    .D DELST1 ^CHMFADR1
  26993   "RTN","CHM FADR4",31, 0)
  26994    .D KILALL ^CHMFADR1
  26995   "RTN","CHM FADR4",32, 0)
  26996    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041  Q
  26997   "RTN","CHM FADR4",33, 0)
  26998    I $D(CHMF BAD) D  G  S0
  26999   "RTN","CHM FADR4",34, 0)
  27000    .D KLOCK^ CHMFADR1
  27001   "RTN","CHM FADR4",35, 0)
  27002    .D REMV^C HMFADR1
  27003   "RTN","CHM FADR4",36, 0)
  27004    .D DELST1 ^CHMFADR1
  27005   "RTN","CHM FADR4",37, 0)
  27006    .D KILALL ^CHMFADR1
  27007   "RTN","CHM FADR4",38, 0)
  27008    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  27009   "RTN","CHM FADR4",39, 0)
  27010    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  27011   "RTN","CHM FADR4",40, 0)
  27012    I $D(CHMF PS) D  G S 0
  27013   "RTN","CHM FADR4",41, 0)
  27014    .S PS=1,C HMFI=CHMFP DI,CHMFPP= "SSPS"
  27015   "RTN","CHM FADR4",42, 0)
  27016    .D ^CHMFW K01
  27017   "RTN","CHM FADR4",43, 0)
  27018    .D SETPRO D^CHMFADR1
  27019   "RTN","CHM FADR4",44, 0)
  27020    .D PSMSG^ CHMFADR1
  27021   "RTN","CHM FADR4",45, 0)
  27022    .D KLOCK^ CHMFADR1
  27023   "RTN","CHM FADR4",46, 0)
  27024    .D REMV^C HMFADR1
  27025   "RTN","CHM FADR4",47, 0)
  27026    .D DELST1 ^CHMFADR1
  27027   "RTN","CHM FADR4",48, 0)
  27028    .D KILALL ^CHMFADR1
  27029   "RTN","CHM FADR4",49, 0)
  27030    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  27031   "RTN","CHM FADR4",50, 0)
  27032    .S CHMQNA M="CHMPSQ( ",CHMIN=1  K CHMOUT D  ^CHMIS041  Q
  27033   "RTN","CHM FADR4",51, 0)
  27034    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  27035   "RTN","CHM FADR4",52, 0)
  27036    I $D(CHMF KIL) D  Q
  27037   "RTN","CHM FADR4",53, 0)
  27038    .S FKIL=1
  27039   "RTN","CHM FADR4",54, 0)
  27040    .D SETPRO D^CHMFADR1
  27041   "RTN","CHM FADR4",55, 0)
  27042    .D KLOCK^ CHMFADR1
  27043   "RTN","CHM FADR4",56, 0)
  27044    .D KILPDI ^CHMFADR1
  27045   "RTN","CHM FADR4",57, 0)
  27046    .D DELST1 ^CHMFADR1
  27047   "RTN","CHM FADR4",58, 0)
  27048    .D READY^ CHMFADR1
  27049   "RTN","CHM FADR4",59, 0)
  27050    I $D(DUOU T) D  Q
  27051   "RTN","CHM FADR4",60, 0)
  27052    .D KLOCK^ CHMFADR1
  27053   "RTN","CHM FADR4",61, 0)
  27054    .D READY^ CHMFADR1
  27055   "RTN","CHM FADR4",62, 0)
  27056    .D DELST1 ^CHMFADR1
  27057   "RTN","CHM FADR4",63, 0)
  27058    .D REMV^C HMFADR1
  27059   "RTN","CHM FADR4",64, 0)
  27060    I $D(DFOU T) D  Q
  27061   "RTN","CHM FADR4",65, 0)
  27062    .D KLOCK^ CHMFADR1
  27063   "RTN","CHM FADR4",66, 0)
  27064    .D READY^ CHMFADR1
  27065   "RTN","CHM FADR4",67, 0)
  27066    .D DELST1 ^CHMFADR1
  27067   "RTN","CHM FADR4",68, 0)
  27068    .D REMV^C HMFADR1
  27069   "RTN","CHM FADR4",69, 0)
  27070    Q
  27071   "RTN","CHM FADR4",70, 0)
  27072   MANUAL ;Ma nually pro cessed cla ims start  here.
  27073   "RTN","CHM FADR4",71, 0)
  27074    ; Set var iables to  0 or nil
  27075   "RTN","CHM FADR4",72, 0)
  27076    N CHOSEN
  27077   "RTN","CHM FADR4",73, 0)
  27078    S (CHOSEN ,PS,FKIL,F IPAY,BAD)= 0
  27079   "RTN","CHM FADR4",74, 0)
  27080    S CHMFPDI =""
  27081   "RTN","CHM FADR4",75, 0)
  27082    ; LSTPDI^ CHMFADR1 l ooks for P DI's curre ntly in "P ause" stat us.
  27083   "RTN","CHM FADR4",76, 0)
  27084    D LSTPDI^ CHMFADR1
  27085   "RTN","CHM FADR4",77, 0)
  27086    D SETUP^C HMFADR1
  27087   "RTN","CHM FADR4",78, 0)
  27088    G:CHMFPDI '="" M1
  27089   "RTN","CHM FADR4",79, 0)
  27090   M0 D SETUP 1^CHMFADR1
  27091   "RTN","CHM FADR4",80, 0)
  27092   M1 D ^CHMF A001
  27093   "RTN","CHM FADR4",81, 0)
  27094    I $D(CHYE SFLG) D  G  M0
  27095   "RTN","CHM FADR4",82, 0)
  27096    .D KLOCK^ CHMFADR1
  27097   "RTN","CHM FADR4",83, 0)
  27098    .D REMV^C HMFADR1
  27099   "RTN","CHM FADR4",84, 0)
  27100    .D DELST1 ^CHMFADR1
  27101   "RTN","CHM FADR4",85, 0)
  27102    .D KILALL ^CHMFADR1
  27103   "RTN","CHM FADR4",86, 0)
  27104    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041  Q
  27105   "RTN","CHM FADR4",87, 0)
  27106    I $D(CHMF BAD) D  G  M0
  27107   "RTN","CHM FADR4",88, 0)
  27108    .D KLOCK^ CHMFADR1
  27109   "RTN","CHM FADR4",89, 0)
  27110    .D REMV^C HMFADR1
  27111   "RTN","CHM FADR4",90, 0)
  27112    .D DELST1 ^CHMFADR1
  27113   "RTN","CHM FADR4",91, 0)
  27114    .D KILALL ^CHMFADR1
  27115   "RTN","CHM FADR4",92, 0)
  27116    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041
  27117   "RTN","CHM FADR4",93, 0)
  27118    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  27119   "RTN","CHM FADR4",94, 0)
  27120    I $D(CHMF PS) D  G M 0
  27121   "RTN","CHM FADR4",95, 0)
  27122    .S PS=1,C HMFI=CHMFP DI,CHMFPP= "SSPS"
  27123   "RTN","CHM FADR4",96, 0)
  27124    .D ^CHMFW K01
  27125   "RTN","CHM FADR4",97, 0)
  27126    .D SETPRO D^CHMFADR1
  27127   "RTN","CHM FADR4",98, 0)
  27128    .D PSMSG^ CHMFADR1
  27129   "RTN","CHM FADR4",99, 0)
  27130    .D KLOCK^ CHMFADR1
  27131   "RTN","CHM FADR4",100 ,0)
  27132    .D REMV^C HMFADR1
  27133   "RTN","CHM FADR4",101 ,0)
  27134    .D DELST1 ^CHMFADR1
  27135   "RTN","CHM FADR4",102 ,0)
  27136    .D KILALL ^CHMFADR1
  27137   "RTN","CHM FADR4",103 ,0)
  27138    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041
  27139   "RTN","CHM FADR4",104 ,0)
  27140    .S CHMQNA M="CHMPSQ( ",CHMIN=1  K CHMOUT D  ^CHMIS041  Q
  27141   "RTN","CHM FADR4",105 ,0)
  27142    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  27143   "RTN","CHM FADR4",106 ,0)
  27144    I $D(CHMF KIL) D  Q
  27145   "RTN","CHM FADR4",107 ,0)
  27146    .S FKIL=1
  27147   "RTN","CHM FADR4",108 ,0)
  27148    .D SETPRO D^CHMFADR1
  27149   "RTN","CHM FADR4",109 ,0)
  27150    .D KLOCK^ CHMFADR1
  27151   "RTN","CHM FADR4",110 ,0)
  27152    .D KILPDI ^CHMFADR1
  27153   "RTN","CHM FADR4",111 ,0)
  27154    .D DELST1 ^CHMFADR1
  27155   "RTN","CHM FADR4",112 ,0)
  27156    .D MANL^C HMFADR1
  27157   "RTN","CHM FADR4",113 ,0)
  27158    .D SKIP^C HMFADR1
  27159   "RTN","CHM FADR4",114 ,0)
  27160    I $D(DUOU T) D  Q
  27161   "RTN","CHM FADR4",115 ,0)
  27162    .D KLOCK^ CHMFADR1
  27163   "RTN","CHM FADR4",116 ,0)
  27164    .D MANL^C HMFADR1
  27165   "RTN","CHM FADR4",117 ,0)
  27166    .D DELST1 ^CHMFADR1
  27167   "RTN","CHM FADR4",118 ,0)
  27168    .D REMV^C HMFADR1
  27169   "RTN","CHM FADR4",119 ,0)
  27170    I $D(DFOU T) D  Q
  27171   "RTN","CHM FADR4",120 ,0)
  27172    .D KLOCK^ CHMFADR1
  27173   "RTN","CHM FADR4",121 ,0)
  27174    .D MANL^C HMFADR1
  27175   "RTN","CHM FADR4",122 ,0)
  27176    .D DELST1 ^CHMFADR1
  27177   "RTN","CHM FADR4",123 ,0)
  27178    .D REMV^C HMFADR1
  27179   "RTN","CHM FADR4",124 ,0)
  27180    Q
  27181   "RTN","CHM FADR4",125 ,0)
  27182    ;
  27183   "RTN","CHM FADR4",126 ,0)
  27184   OCR ;CHAMP VA EDI cla ims start  here.
  27185   "RTN","CHM FADR4",127 ,0)
  27186    ;
  27187   "RTN","CHM FADR4",128 ,0)
  27188    N CHOSEN
  27189   "RTN","CHM FADR4",129 ,0)
  27190    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  27191   "RTN","CHM FADR4",130 ,0)
  27192    S CHMFPDI ="",CHOSEN =2
  27193   "RTN","CHM FADR4",131 ,0)
  27194    D LSTPDI^ CHMFADR1
  27195   "RTN","CHM FADR4",132 ,0)
  27196    D SETUP^C HMFADR1
  27197   "RTN","CHM FADR4",133 ,0)
  27198    G:CHMFPDI '="" O01
  27199   "RTN","CHM FADR4",134 ,0)
  27200   O0 D SETUP 1^CHMFADR1
  27201   "RTN","CHM FADR4",135 ,0)
  27202    D ^CHMFPD IO Q:$D(CH QUIT)
  27203   "RTN","CHM FADR4",136 ,0)
  27204   O01 S ZZPD I=CHMFPDI
  27205   "RTN","CHM FADR4",137 ,0)
  27206    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  27207   "RTN","CHM FADR4",138 ,0)
  27208    S CHMFPP= "SIP" D ^C HMFWK01
  27209   "RTN","CHM FADR4",139 ,0)
  27210    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  27211   "RTN","CHM FADR4",140 ,0)
  27212    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  27213   "RTN","CHM FADR4",141 ,0)
  27214    D GETDATA ^CHMFA008
  27215   "RTN","CHM FADR4",142 ,0)
  27216   O1 D ^CHMF A008
  27217   "RTN","CHM FADR4",143 ,0)
  27218    ;I $D(CHY ESFLG) D   G O0
  27219   "RTN","CHM FADR4",144 ,0)
  27220    ;.;D KLOC K^CHMFADR1
  27221   "RTN","CHM FADR4",145 ,0)
  27222    ;.;D REMV ^CHMFADR1
  27223   "RTN","CHM FADR4",146 ,0)
  27224    ;.;D DELS T1^CHMFADR 1
  27225   "RTN","CHM FADR4",147 ,0)
  27226    ;.;D KILA LL^CHMFADR 1
  27227   "RTN","CHM FADR4",148 ,0)
  27228    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1 Q
  27229   "RTN","CHM FADR4",149 ,0)
  27230    I $D(CHMF BAD) D  G  O0
  27231   "RTN","CHM FADR4",150 ,0)
  27232    .D KLOCK^ CHMFADR1
  27233   "RTN","CHM FADR4",151 ,0)
  27234    .D REMV^C HMFADR1
  27235   "RTN","CHM FADR4",152 ,0)
  27236    .D DELST1 ^CHMFADR1
  27237   "RTN","CHM FADR4",153 ,0)
  27238    .D KILALL ^CHMFADR1
  27239   "RTN","CHM FADR4",154 ,0)
  27240    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  27241   "RTN","CHM FADR4",155 ,0)
  27242    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  27243   "RTN","CHM FADR4",156 ,0)
  27244    ;I $D(CHM FPS) D  G  O0
  27245   "RTN","CHM FADR4",157 ,0)
  27246    ;.;S PS=1 ,CHMFI=CHM FPDI,CHMFP P="SSPS"
  27247   "RTN","CHM FADR4",158 ,0)
  27248    ;.;D ^CHM FWK01
  27249   "RTN","CHM FADR4",159 ,0)
  27250    ;.;D SETP ROD^CHMFAD R1
  27251   "RTN","CHM FADR4",160 ,0)
  27252    ;.;D PSMS G^CHMFADR1
  27253   "RTN","CHM FADR4",161 ,0)
  27254    ;.;D KLOC K^CHMFADR1
  27255   "RTN","CHM FADR4",162 ,0)
  27256    ;.;D REMV ^CHMFADR1
  27257   "RTN","CHM FADR4",163 ,0)
  27258    ;.;D DELS T1^CHMFADR 1
  27259   "RTN","CHM FADR4",164 ,0)
  27260    ;.;D KILA LL^CHMFADR 1
  27261   "RTN","CHM FADR4",165 ,0)
  27262    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1
  27263   "RTN","CHM FADR4",166 ,0)
  27264    ;.;S CHMQ NAM="CHMPS Q(",CHMIN= 1 K CHMOUT  D ^CHMIS0 41 Q
  27265   "RTN","CHM FADR4",167 ,0)
  27266    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  27267   "RTN","CHM FADR4",168 ,0)
  27268    ;I $D(CHM FEXIT) D   Q
  27269   "RTN","CHM FADR4",169 ,0)
  27270    ;.;S FKIL =1
  27271   "RTN","CHM FADR4",170 ,0)
  27272    ;.;D SETP ROD^CHMFAD R1
  27273   "RTN","CHM FADR4",171 ,0)
  27274    ;.;D KLOC K^CHMFADR1
  27275   "RTN","CHM FADR4",172 ,0)
  27276    ;.;D DELS T1^CHMFADR 1
  27277   "RTN","CHM FADR4",173 ,0)
  27278    ;.;D OCRR DY^CHMFADR 1
  27279   "RTN","CHM FADR4",174 ,0)
  27280    I $D(CHMF KIL) D  Q
  27281   "RTN","CHM FADR4",175 ,0)
  27282    .S FKIL=1
  27283   "RTN","CHM FADR4",176 ,0)
  27284    .D SETPRO D^CHMFADR1
  27285   "RTN","CHM FADR4",177 ,0)
  27286    .D KLOCK^ CHMFADR1
  27287   "RTN","CHM FADR4",178 ,0)
  27288    .D DELST1 ^CHMFADR1
  27289   "RTN","CHM FADR4",179 ,0)
  27290    .D OCRRDY ^CHMFADR1
  27291   "RTN","CHM FADR4",180 ,0)
  27292    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  27293   "RTN","CHM FADR4",181 ,0)
  27294    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  27295   "RTN","CHM FADR4",182 ,0)
  27296    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  27297   "RTN","CHM FADR4",183 ,0)
  27298    I $D(CHMF PDRV) D  G  O0
  27299   "RTN","CHM FADR4",184 ,0)
  27300    .D KLOCK^ CHMFADR1
  27301   "RTN","CHM FADR4",185 ,0)
  27302    .D REMV^C HMFADR1
  27303   "RTN","CHM FADR4",186 ,0)
  27304    .D DELST1 ^CHMFADR1
  27305   "RTN","CHM FADR4",187 ,0)
  27306    .D OCRKIL ^CHMFADR1
  27307   "RTN","CHM FADR4",188 ,0)
  27308    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  27309   "RTN","CHM FADR4",189 ,0)
  27310    I $D(DUOU T) D  Q
  27311   "RTN","CHM FADR4",190 ,0)
  27312    .D KLOCK^ CHMFADR1
  27313   "RTN","CHM FADR4",191 ,0)
  27314    .D OCRRDY ^CHMFADR1
  27315   "RTN","CHM FADR4",192 ,0)
  27316    .D DELST1 ^CHMFADR1
  27317   "RTN","CHM FADR4",193 ,0)
  27318    .D REMV^C HMFADR1
  27319   "RTN","CHM FADR4",194 ,0)
  27320    I $D(DFOU T) D  Q
  27321   "RTN","CHM FADR4",195 ,0)
  27322    .D KLOCK^ CHMFADR1
  27323   "RTN","CHM FADR4",196 ,0)
  27324    .D OCRRDY ^CHMFADR1
  27325   "RTN","CHM FADR4",197 ,0)
  27326    .D DELST1 ^CHMFADR1
  27327   "RTN","CHM FADR4",198 ,0)
  27328    .D REMV^C HMFADR1
  27329   "RTN","CHM FADR4",199 ,0)
  27330    Q
  27331   "RTN","CHM FADR4",200 ,0)
  27332   OCR2 ;CHAM PVA OCR cl aims start  here.
  27333   "RTN","CHM FADR4",201 ,0)
  27334    ;
  27335   "RTN","CHM FADR4",202 ,0)
  27336    N CHOSEN
  27337   "RTN","CHM FADR4",203 ,0)
  27338    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  27339   "RTN","CHM FADR4",204 ,0)
  27340    S CHMFPDI ="",CHOSEN =4
  27341   "RTN","CHM FADR4",205 ,0)
  27342    ;S $P(^CH MDIC(74100 2.21,DUZ,0 ),"^",2)=" "
  27343   "RTN","CHM FADR4",206 ,0)
  27344    D LSTPDI^ CHMFADR1
  27345   "RTN","CHM FADR4",207 ,0)
  27346    D SETUP^C HMFADR1
  27347   "RTN","CHM FADR4",208 ,0)
  27348    G:CHMFPDI '="" OCR20 1
  27349   "RTN","CHM FADR4",209 ,0)
  27350   OCR20 D SE TUP1^CHMFA DR1
  27351   "RTN","CHM FADR4",210 ,0)
  27352    D ^CHMFPD O1 Q:$D(CH QUIT)
  27353   "RTN","CHM FADR4",211 ,0)
  27354   OCR201 S Z ZPDI=CHMFP DI
  27355   "RTN","CHM FADR4",212 ,0)
  27356    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  27357   "RTN","CHM FADR4",213 ,0)
  27358    S CHMFPP= "SIP" D ^C HMFWK01
  27359   "RTN","CHM FADR4",214 ,0)
  27360    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  27361   "RTN","CHM FADR4",215 ,0)
  27362    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  27363   "RTN","CHM FADR4",216 ,0)
  27364    D GETDATA ^CHMFA008
  27365   "RTN","CHM FADR4",217 ,0)
  27366   OCR21 D ^C HMFA008
  27367   "RTN","CHM FADR4",218 ,0)
  27368    ;I $D(CHY ESFLG) D   G OCR20
  27369   "RTN","CHM FADR4",219 ,0)
  27370    ;.;D KLOC K^CHMFADR1
  27371   "RTN","CHM FADR4",220 ,0)
  27372    ;.;D REMV ^CHMFADR1
  27373   "RTN","CHM FADR4",221 ,0)
  27374    ;.;D DELS T1^CHMFADR 1
  27375   "RTN","CHM FADR4",222 ,0)
  27376    ;.;D KILA LL^CHMFADR 1
  27377   "RTN","CHM FADR4",223 ,0)
  27378    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1 Q
  27379   "RTN","CHM FADR4",224 ,0)
  27380    I $D(CHMF BAD) D  G  OCR20
  27381   "RTN","CHM FADR4",225 ,0)
  27382    .D KLOCK^ CHMFADR1
  27383   "RTN","CHM FADR4",226 ,0)
  27384    .D REMV^C HMFADR1
  27385   "RTN","CHM FADR4",227 ,0)
  27386    .D DELST1 ^CHMFADR1
  27387   "RTN","CHM FADR4",228 ,0)
  27388    .D KILALL ^CHMFADR1
  27389   "RTN","CHM FADR4",229 ,0)
  27390    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  27391   "RTN","CHM FADR4",230 ,0)
  27392    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  27393   "RTN","CHM FADR4",231 ,0)
  27394    ;I $D(CHM FPS) D  G  OCR20
  27395   "RTN","CHM FADR4",232 ,0)
  27396    ;.;S PS=1 ,CHMFI=CHM FPDI,CHMFP P="SSPS"
  27397   "RTN","CHM FADR4",233 ,0)
  27398    ;.;D ^CHM FWK01
  27399   "RTN","CHM FADR4",234 ,0)
  27400    ;.;D SETP ROD^CHMFAD R1
  27401   "RTN","CHM FADR4",235 ,0)
  27402    ;.;D PSMS G^CHMFADR1
  27403   "RTN","CHM FADR4",236 ,0)
  27404    ;.;D KLOC K^CHMFADR1
  27405   "RTN","CHM FADR4",237 ,0)
  27406    ;.;D REMV ^CHMFADR1
  27407   "RTN","CHM FADR4",238 ,0)
  27408    ;.;D DELS T1^CHMFADR 1
  27409   "RTN","CHM FADR4",239 ,0)
  27410    ;.;D KILA LL^CHMFADR 1
  27411   "RTN","CHM FADR4",240 ,0)
  27412    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1
  27413   "RTN","CHM FADR4",241 ,0)
  27414    ;.;S CHMQ NAM="CHMPS Q(",CHMIN= 1 K CHMOUT  D ^CHMIS0 41 Q
  27415   "RTN","CHM FADR4",242 ,0)
  27416    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  27417   "RTN","CHM FADR4",243 ,0)
  27418    ;I $D(CHM FEXIT) D   Q
  27419   "RTN","CHM FADR4",244 ,0)
  27420    ;.;S FKIL =1
  27421   "RTN","CHM FADR4",245 ,0)
  27422    ;.;D SETP ROD^CHMFAD R1
  27423   "RTN","CHM FADR4",246 ,0)
  27424    ;.;D KLOC K^CHMFADR1
  27425   "RTN","CHM FADR4",247 ,0)
  27426    ;.;D DELS T1^CHMFADR 1
  27427   "RTN","CHM FADR4",248 ,0)
  27428    ;.;D OCR2 RDY^CHMFAD R1
  27429   "RTN","CHM FADR4",249 ,0)
  27430    I $D(CHMF KIL) D  Q
  27431   "RTN","CHM FADR4",250 ,0)
  27432    .S FKIL=1
  27433   "RTN","CHM FADR4",251 ,0)
  27434    .D SETPRO D^CHMFADR1
  27435   "RTN","CHM FADR4",252 ,0)
  27436    .D KLOCK^ CHMFADR1
  27437   "RTN","CHM FADR4",253 ,0)
  27438    .D DELST1 ^CHMFADR1
  27439   "RTN","CHM FADR4",254 ,0)
  27440    .D OCR2RD Y^CHMFADR1
  27441   "RTN","CHM FADR4",255 ,0)
  27442    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  27443   "RTN","CHM FADR4",256 ,0)
  27444    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  27445   "RTN","CHM FADR4",257 ,0)
  27446    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  27447   "RTN","CHM FADR4",258 ,0)
  27448    I $D(CHMF PDRV) D  G  OCR20
  27449   "RTN","CHM FADR4",259 ,0)
  27450    .D KLOCK^ CHMFADR1
  27451   "RTN","CHM FADR4",260 ,0)
  27452    .D REMV^C HMFADR1
  27453   "RTN","CHM FADR4",261 ,0)
  27454    .D DELST1 ^CHMFADR1
  27455   "RTN","CHM FADR4",262 ,0)
  27456    .D OCRKIL ^CHMFADR1
  27457   "RTN","CHM FADR4",263 ,0)
  27458    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  27459   "RTN","CHM FADR4",264 ,0)
  27460    I $D(DUOU T) D  Q
  27461   "RTN","CHM FADR4",265 ,0)
  27462    .D KLOCK^ CHMFADR1
  27463   "RTN","CHM FADR4",266 ,0)
  27464    .D OCR2RD Y^CHMFADR1
  27465   "RTN","CHM FADR4",267 ,0)
  27466    .D DELST1 ^CHMFADR1
  27467   "RTN","CHM FADR4",268 ,0)
  27468    .D REMV^C HMFADR1
  27469   "RTN","CHM FADR4",269 ,0)
  27470    I $D(DFOU T) D  Q
  27471   "RTN","CHM FADR4",270 ,0)
  27472    .D KLOCK^ CHMFADR1
  27473   "RTN","CHM FADR4",271 ,0)
  27474    .D OCR2RD Y^CHMFADR1
  27475   "RTN","CHM FADR4",272 ,0)
  27476    .D DELST1 ^CHMFADR1
  27477   "RTN","CHM FADR4",273 ,0)
  27478    .D REMV^C HMFADR1
  27479   "RTN","CHM FADR4",274 ,0)
  27480    Q
  27481   "RTN","CHM FADR4",275 ,0)
  27482   SBOCR ;SB/ CWVV EDI c laims star t here.
  27483   "RTN","CHM FADR4",276 ,0)
  27484    ;
  27485   "RTN","CHM FADR4",277 ,0)
  27486    N CHOSEN
  27487   "RTN","CHM FADR4",278 ,0)
  27488    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  27489   "RTN","CHM FADR4",279 ,0)
  27490    S CHMFPDI ="",CHOSEN =3
  27491   "RTN","CHM FADR4",280 ,0)
  27492    D LSTPDI^ CHMFADR1
  27493   "RTN","CHM FADR4",281 ,0)
  27494    D SETUP^C HMFADR1
  27495   "RTN","CHM FADR4",282 ,0)
  27496    G:CHMFPDI '="" SO01
  27497   "RTN","CHM FADR4",283 ,0)
  27498   SO0 D SETU P1^CHMFADR 1
  27499   "RTN","CHM FADR4",284 ,0)
  27500    D ^CHMFPD IS Q:$D(CH QUIT)
  27501   "RTN","CHM FADR4",285 ,0)
  27502   SO01 S ZZP DI=CHMFPDI
  27503   "RTN","CHM FADR4",286 ,0)
  27504    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  27505   "RTN","CHM FADR4",287 ,0)
  27506    S CHMFPP= "SIP" D ^C HMFWK01
  27507   "RTN","CHM FADR4",288 ,0)
  27508    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  27509   "RTN","CHM FADR4",289 ,0)
  27510    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  27511   "RTN","CHM FADR4",290 ,0)
  27512    D GETDATA ^CHMFA008
  27513   "RTN","CHM FADR4",291 ,0)
  27514   SO1 D ^CHM FA008
  27515   "RTN","CHM FADR4",292 ,0)
  27516    ;I $D(CHY ESFLG) D   G SO0
  27517   "RTN","CHM FADR4",293 ,0)
  27518    ;.;D KLOC K^CHMFADR1
  27519   "RTN","CHM FADR4",294 ,0)
  27520    ;.;D REMV ^CHMFADR1
  27521   "RTN","CHM FADR4",295 ,0)
  27522    ;.;D DELS T1^CHMFADR 1
  27523   "RTN","CHM FADR4",296 ,0)
  27524    ;.;D KILA LL^CHMFADR 1
  27525   "RTN","CHM FADR4",297 ,0)
  27526    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1 Q
  27527   "RTN","CHM FADR4",298 ,0)
  27528    I $D(CHMF BAD) D  G  SO0
  27529   "RTN","CHM FADR4",299 ,0)
  27530    .D KLOCK^ CHMFADR1
  27531   "RTN","CHM FADR4",300 ,0)
  27532    .D REMV^C HMFADR1
  27533   "RTN","CHM FADR4",301 ,0)
  27534    .D DELST1 ^CHMFADR1
  27535   "RTN","CHM FADR4",302 ,0)
  27536    .D KILALL ^CHMFADR1
  27537   "RTN","CHM FADR4",303 ,0)
  27538    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  27539   "RTN","CHM FADR4",304 ,0)
  27540    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  27541   "RTN","CHM FADR4",305 ,0)
  27542    ;I $D(CHM FPS) D  G  SO0
  27543   "RTN","CHM FADR4",306 ,0)
  27544    ;.S PS=1, CHMFI=CHMF PDI,CHMFPP ="SSPS"
  27545   "RTN","CHM FADR4",307 ,0)
  27546    ;.;D ^CHM FWK01
  27547   "RTN","CHM FADR4",308 ,0)
  27548    ;.;D SETP ROD^CHMFAD R1
  27549   "RTN","CHM FADR4",309 ,0)
  27550    ;.;D PSMS G^CHMFADR1
  27551   "RTN","CHM FADR4",310 ,0)
  27552    ;.;D KLOC K^CHMFADR1
  27553   "RTN","CHM FADR4",311 ,0)
  27554    ;.;D REMV ^CHMFADR1
  27555   "RTN","CHM FADR4",312 ,0)
  27556    ;.;D DELS T1^CHMFADR 1
  27557   "RTN","CHM FADR4",313 ,0)
  27558    ;.;D KILA LL^CHMFADR 1
  27559   "RTN","CHM FADR4",314 ,0)
  27560    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1
  27561   "RTN","CHM FADR4",315 ,0)
  27562    ;.;S CHMQ NAM="CHMPS Q(",CHMIN= 1 K CHMOUT  D ^CHMIS0 41 Q
  27563   "RTN","CHM FADR4",316 ,0)
  27564    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  27565   "RTN","CHM FADR4",317 ,0)
  27566    ;I $D(CHM FEXIT) D   Q
  27567   "RTN","CHM FADR4",318 ,0)
  27568    ;.;S FKIL =1
  27569   "RTN","CHM FADR4",319 ,0)
  27570    ;.;D SETP ROD^CHMFAD R1
  27571   "RTN","CHM FADR4",320 ,0)
  27572    ;.;D KLOC K^CHMFADR1
  27573   "RTN","CHM FADR4",321 ,0)
  27574    ;.;D DELS T1^CHMFADR 1
  27575   "RTN","CHM FADR4",322 ,0)
  27576    ;.;D SBOC RDY^CHMFAD R1
  27577   "RTN","CHM FADR4",323 ,0)
  27578    I $D(CHMF KIL) D  Q
  27579   "RTN","CHM FADR4",324 ,0)
  27580    .S FKIL=1
  27581   "RTN","CHM FADR4",325 ,0)
  27582    .D SETPRO D^CHMFADR1
  27583   "RTN","CHM FADR4",326 ,0)
  27584    .D KLOCK^ CHMFADR1
  27585   "RTN","CHM FADR4",327 ,0)
  27586    .D DELST1 ^CHMFADR1
  27587   "RTN","CHM FADR4",328 ,0)
  27588    .D SBOCRD Y^CHMFADR1
  27589   "RTN","CHM FADR4",329 ,0)
  27590    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  27591   "RTN","CHM FADR4",330 ,0)
  27592    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  27593   "RTN","CHM FADR4",331 ,0)
  27594    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  27595   "RTN","CHM FADR4",332 ,0)
  27596    I $D(CHMF PDRV) D  G  SO0
  27597   "RTN","CHM FADR4",333 ,0)
  27598    .D KLOCK^ CHMFADR1
  27599   "RTN","CHM FADR4",334 ,0)
  27600    .D REMV^C HMFADR1
  27601   "RTN","CHM FADR4",335 ,0)
  27602    .D DELST1 ^CHMFADR1
  27603   "RTN","CHM FADR4",336 ,0)
  27604    .D OCRKIL ^CHMFADR1
  27605   "RTN","CHM FADR4",337 ,0)
  27606    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  27607   "RTN","CHM FADR4",338 ,0)
  27608    I $D(DUOU T) D  Q
  27609   "RTN","CHM FADR4",339 ,0)
  27610    .D KLOCK^ CHMFADR1
  27611   "RTN","CHM FADR4",340 ,0)
  27612    .D SBOCRD Y^CHMFADR1
  27613   "RTN","CHM FADR4",341 ,0)
  27614    .D DELST1 ^CHMFADR1
  27615   "RTN","CHM FADR4",342 ,0)
  27616    .D REMV^C HMFADR1
  27617   "RTN","CHM FADR4",343 ,0)
  27618    I $D(DFOU T) D  Q
  27619   "RTN","CHM FADR4",344 ,0)
  27620    .D KLOCK^ CHMFADR1
  27621   "RTN","CHM FADR4",345 ,0)
  27622    .D SBOCRD Y^CHMFADR1
  27623   "RTN","CHM FADR4",346 ,0)
  27624    .D DELST1 ^CHMFADR1
  27625   "RTN","CHM FADR4",347 ,0)
  27626    .D REMV^C HMFADR1
  27627   "RTN","CHM FADR4",348 ,0)
  27628    Q
  27629   "RTN","CHM FADR4",349 ,0)
  27630   SBOCR2 ;SB /CWVV OCR  claims sta rt here
  27631   "RTN","CHM FADR4",350 ,0)
  27632    ;
  27633   "RTN","CHM FADR4",351 ,0)
  27634    N CHOSEN
  27635   "RTN","CHM FADR4",352 ,0)
  27636    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG) =0
  27637   "RTN","CHM FADR4",353 ,0)
  27638    S CHMFPDI ="",CHOSEN =5
  27639   "RTN","CHM FADR4",354 ,0)
  27640    D LSTPDI^ CHMFADR1
  27641   "RTN","CHM FADR4",355 ,0)
  27642    D SETUP^C HMFADR1
  27643   "RTN","CHM FADR4",356 ,0)
  27644    G:CHMFPDI '="" SOCR2 01
  27645   "RTN","CHM FADR4",357 ,0)
  27646   SOCR20 D S ETUP1^CHMF ADR1
  27647   "RTN","CHM FADR4",358 ,0)
  27648    D ^CHMFPD O2 Q:$D(CH QUIT)
  27649   "RTN","CHM FADR4",359 ,0)
  27650   SOCR201 S  ZZPDI=CHMF PDI
  27651   "RTN","CHM FADR4",360 ,0)
  27652    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1) ;C PE005-004
  27653   "RTN","CHM FADR4",361 ,0)
  27654    S CHMFPP= "SIP" D ^C HMFWK01
  27655   "RTN","CHM FADR4",362 ,0)
  27656    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  27657   "RTN","CHM FADR4",363 ,0)
  27658    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  27659   "RTN","CHM FADR4",364 ,0)
  27660    D GETDATA ^CHMFA008
  27661   "RTN","CHM FADR4",365 ,0)
  27662   SOCR21 D ^ CHMFA008
  27663   "RTN","CHM FADR4",366 ,0)
  27664    ;I $D(CHY ESFLG) D   G SOCR20
  27665   "RTN","CHM FADR4",367 ,0)
  27666    ;.;D KLOC K^CHMFADR1
  27667   "RTN","CHM FADR4",368 ,0)
  27668    ;.;D REMV ^CHMFADR1
  27669   "RTN","CHM FADR4",369 ,0)
  27670    ;.;D DELS T1^CHMFADR 1
  27671   "RTN","CHM FADR4",370 ,0)
  27672    ;.;D KILA LL^CHMFADR 1
  27673   "RTN","CHM FADR4",371 ,0)
  27674    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1 Q
  27675   "RTN","CHM FADR4",372 ,0)
  27676    I $D(CHMF BAD) D  G  SOCR20
  27677   "RTN","CHM FADR4",373 ,0)
  27678    .D KLOCK^ CHMFADR1
  27679   "RTN","CHM FADR4",374 ,0)
  27680    .D REMV^C HMFADR1
  27681   "RTN","CHM FADR4",375 ,0)
  27682    .D DELST1 ^CHMFADR1
  27683   "RTN","CHM FADR4",376 ,0)
  27684    .D KILALL ^CHMFADR1
  27685   "RTN","CHM FADR4",377 ,0)
  27686    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  27687   "RTN","CHM FADR4",378 ,0)
  27688    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  27689   "RTN","CHM FADR4",379 ,0)
  27690    ;I $D(CHM FPS) D  G  SOCR20
  27691   "RTN","CHM FADR4",380 ,0)
  27692    ;.;S PS=1 ,CHMFI=CHM FPDI,CHMFP P="SSPS"
  27693   "RTN","CHM FADR4",381 ,0)
  27694    ;.;D ^CHM FWK01
  27695   "RTN","CHM FADR4",382 ,0)
  27696    ;.;D SETP ROD^CHMFAD R1
  27697   "RTN","CHM FADR4",383 ,0)
  27698    ;.;D PSMS G^CHMFADR1
  27699   "RTN","CHM FADR4",384 ,0)
  27700    ;.;D KLOC K^CHMFADR1
  27701   "RTN","CHM FADR4",385 ,0)
  27702    ;.;D REMV ^CHMFADR1
  27703   "RTN","CHM FADR4",386 ,0)
  27704    ;.;D DELS T1^CHMFADR 1
  27705   "RTN","CHM FADR4",387 ,0)
  27706    ;.;D KILA LL^CHMFADR 1
  27707   "RTN","CHM FADR4",388 ,0)
  27708    ;.;S CHMQ NAM="IMAGE (",CHMOUT= 1 K CHMIN  D ^CHMIS04 1
  27709   "RTN","CHM FADR4",389 ,0)
  27710    ;.;S CHMQ NAM="CHMPS Q(",CHMIN= 1 K CHMOUT  D ^CHMIS0 41 Q
  27711   "RTN","CHM FADR4",390 ,0)
  27712    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  27713   "RTN","CHM FADR4",391 ,0)
  27714    ;I $D(CHM FEXIT) D   Q
  27715   "RTN","CHM FADR4",392 ,0)
  27716    ;.;S FKIL =1
  27717   "RTN","CHM FADR4",393 ,0)
  27718    ;.;D SETP ROD^CHMFAD R1
  27719   "RTN","CHM FADR4",394 ,0)
  27720    ;.;D KLOC K^CHMFADR1
  27721   "RTN","CHM FADR4",395 ,0)
  27722    ;.;D DELS T1^CHMFADR 1
  27723   "RTN","CHM FADR4",396 ,0)
  27724    ;.;D SBOC R2DY^CHMFA DR1
  27725   "RTN","CHM FADR4",397 ,0)
  27726    I $D(CHMF KIL) D  Q
  27727   "RTN","CHM FADR4",398 ,0)
  27728    .S FKIL=1
  27729   "RTN","CHM FADR4",399 ,0)
  27730    .D SETPRO D^CHMFADR1
  27731   "RTN","CHM FADR4",400 ,0)
  27732    .D KLOCK^ CHMFADR1
  27733   "RTN","CHM FADR4",401 ,0)
  27734    .D DELST1 ^CHMFADR1
  27735   "RTN","CHM FADR4",402 ,0)
  27736    .D SBOCR2 DY^CHMFADR 1
  27737   "RTN","CHM FADR4",403 ,0)
  27738    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  27739   "RTN","CHM FADR4",404 ,0)
  27740    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  27741   "RTN","CHM FADR4",405 ,0)
  27742    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  27743   "RTN","CHM FADR4",406 ,0)
  27744    I $D(CHMF PDRV) D  G  SOCR20
  27745   "RTN","CHM FADR4",407 ,0)
  27746    .D KLOCK^ CHMFADR1
  27747   "RTN","CHM FADR4",408 ,0)
  27748    .D REMV^C HMFADR1
  27749   "RTN","CHM FADR4",409 ,0)
  27750    .D DELST1 ^CHMFADR1
  27751   "RTN","CHM FADR4",410 ,0)
  27752    .D OCRKIL ^CHMFADR1
  27753   "RTN","CHM FADR4",411 ,0)
  27754    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  27755   "RTN","CHM FADR4",412 ,0)
  27756    I $D(DUOU T) D  Q
  27757   "RTN","CHM FADR4",413 ,0)
  27758    .D KLOCK^ CHMFADR1
  27759   "RTN","CHM FADR4",414 ,0)
  27760    .D SBOCR2 DY^CHMFADR 1
  27761   "RTN","CHM FADR4",415 ,0)
  27762    .D DELST1 ^CHMFADR1
  27763   "RTN","CHM FADR4",416 ,0)
  27764    .D REMV^C HMFADR1
  27765   "RTN","CHM FADR4",417 ,0)
  27766    I $D(DFOU T) D  Q
  27767   "RTN","CHM FADR4",418 ,0)
  27768    .D KLOCK^ CHMFADR1
  27769   "RTN","CHM FADR4",419 ,0)
  27770    .D SBOCR2 DY^CHMFADR 1
  27771   "RTN","CHM FADR4",420 ,0)
  27772    .D DELST1 ^CHMFADR1
  27773   "RTN","CHM FADR4",421 ,0)
  27774    .D REMV^C HMFADR1
  27775   "RTN","CHM FADR4",422 ,0)
  27776    Q
  27777   "RTN","CHM FADR4",423 ,0)
  27778   OCRR ;CHV  EDI Re-Ope n Claims s tart here.  -- CPE005 -004
  27779   "RTN","CHM FADR4",424 ,0)
  27780    ;
  27781   "RTN","CHM FADR4",425 ,0)
  27782    N CHOSEN, VALOPDI,CH REJ
  27783   "RTN","CHM FADR4",426 ,0)
  27784    S CHOSEN= 6
  27785   "RTN","CHM FADR4",427 ,0)
  27786    K CHMFPRE V
  27787   "RTN","CHM FADR4",428 ,0)
  27788    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG, VALOPDI)=0
  27789   "RTN","CHM FADR4",429 ,0)
  27790    S CHMFPDI =""
  27791   "RTN","CHM FADR4",430 ,0)
  27792    D LSTPDI^ CHMFADR1
  27793   "RTN","CHM FADR4",431 ,0)
  27794    D SETUP^C HMFADR1
  27795   "RTN","CHM FADR4",432 ,0)
  27796    G:CHMFPDI '="" CR01
  27797   "RTN","CHM FADR4",433 ,0)
  27798   CRO0 D SET UP1^CHMFAD R1
  27799   "RTN","CHM FADR4",434 ,0)
  27800    D ^CHMFPD O3 Q:$D(CH QUIT)
  27801   "RTN","CHM FADR4",435 ,0)
  27802   CR01 ;
  27803   "RTN","CHM FADR4",436 ,0)
  27804    I CHMOPDI ="" S CHMO PDI=$P($G( ^CHMIMG(CH MFPDI,"E-R EOPEN"))," ^")
  27805   "RTN","CHM FADR4",437 ,0)
  27806    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=$G (CHMOPDI)
  27807   "RTN","CHM FADR4",438 ,0)
  27808    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1)
  27809   "RTN","CHM FADR4",439 ,0)
  27810    S CHMFPP= "SIP" D ^C HMFWK01
  27811   "RTN","CHM FADR4",440 ,0)
  27812    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  27813   "RTN","CHM FADR4",441 ,0)
  27814    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  27815   "RTN","CHM FADR4",442 ,0)
  27816    D GETDATA ^CHMFA008
  27817   "RTN","CHM FADR4",443 ,0)
  27818    S CHMFIMT Y=1,CHMFTY PE="BILL/I NVOICE" ;B DB 0517201 7
  27819   "RTN","CHM FADR4",444 ,0)
  27820    N NEXTPAG E
  27821   "RTN","CHM FADR4",445 ,0)
  27822   CH1 D ^CHM FA008
  27823   "RTN","CHM FADR4",446 ,0)
  27824    I $D(CHMF BAD) D  G  CRO0
  27825   "RTN","CHM FADR4",447 ,0)
  27826    .D KLOCK^ CHMFADR1
  27827   "RTN","CHM FADR4",448 ,0)
  27828    .D REMV^C HMFADR1
  27829   "RTN","CHM FADR4",449 ,0)
  27830    .D DELST1 ^CHMFADR1
  27831   "RTN","CHM FADR4",450 ,0)
  27832    .D KILALL ^CHMFADR1
  27833   "RTN","CHM FADR4",451 ,0)
  27834    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  27835   "RTN","CHM FADR4",452 ,0)
  27836    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  27837   "RTN","CHM FADR4",453 ,0)
  27838    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  27839   "RTN","CHM FADR4",454 ,0)
  27840    I $D(CHMF KIL) D  Q
  27841   "RTN","CHM FADR4",455 ,0)
  27842    .N CHMFTO B
  27843   "RTN","CHM FADR4",456 ,0)
  27844    .S CHMFTO B=$$TOB^CH MFADR2(CHM FPDI,CHMFP GNM,CHMFIM AG)
  27845   "RTN","CHM FADR4",457 ,0)
  27846    .I $E(CHM FTOB,3)=8  D  ;bdb cp e005-033 1 2/13/2017  prompt, se t the fina l cstat
  27847   "RTN","CHM FADR4",458 ,0)
  27848    ..N CHR
  27849   "RTN","CHM FADR4",459 ,0)
  27850    ..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
  27851   "RTN","CHM FADR4",460 ,0)
  27852    ..I $E($$ UP^XLFSTR( $G(CHR)),1 )'="Y" D O CRRRDY^CHM FADR1 Q
  27853   "RTN","CHM FADR4",461 ,0)
  27854    ..D CRCST AT^CHMFUTL E(CHMFPDI, "","E001a" ,"A") ;CFS  Create th e CSTAT me ssage.
  27855   "RTN","CHM FADR4",462 ,0)
  27856    ..S DIE=7 41000.2,DA =CHMFPDI,D R=".06///1 1" D ^DIE  K DIE
  27857   "RTN","CHM FADR4",463 ,0)
  27858    .S FKIL=1
  27859   "RTN","CHM FADR4",464 ,0)
  27860    .D SETPRO D^CHMFADR1
  27861   "RTN","CHM FADR4",465 ,0)
  27862    .D KLOCK^ CHMFADR1
  27863   "RTN","CHM FADR4",466 ,0)
  27864    .D DELST1 ^CHMFADR1
  27865   "RTN","CHM FADR4",467 ,0)
  27866    .I $E(CHM FTOB,3)'=8  D OCRRRDY ^CHMFADR1
  27867   "RTN","CHM FADR4",468 ,0)
  27868    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  27869   "RTN","CHM FADR4",469 ,0)
  27870    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  27871   "RTN","CHM FADR4",470 ,0)
  27872    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  27873   "RTN","CHM FADR4",471 ,0)
  27874    I $D(CHMF PDRV) D  G  CRO0
  27875   "RTN","CHM FADR4",472 ,0)
  27876    .D KLOCK^ CHMFADR1
  27877   "RTN","CHM FADR4",473 ,0)
  27878    .D REMV^C HMFADR1
  27879   "RTN","CHM FADR4",474 ,0)
  27880    .D DELST1 ^CHMFADR1
  27881   "RTN","CHM FADR4",475 ,0)
  27882    .D OCRKIL ^CHMFADR1
  27883   "RTN","CHM FADR4",476 ,0)
  27884    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  27885   "RTN","CHM FADR4",477 ,0)
  27886    I $D(DUOU T) D  Q
  27887   "RTN","CHM FADR4",478 ,0)
  27888    .D KLOCK^ CHMFADR1
  27889   "RTN","CHM FADR4",479 ,0)
  27890    .D OCRRRD Y^CHMFADR1
  27891   "RTN","CHM FADR4",480 ,0)
  27892    .D DELST1 ^CHMFADR1
  27893   "RTN","CHM FADR4",481 ,0)
  27894    .D REMV^C HMFADR1
  27895   "RTN","CHM FADR4",482 ,0)
  27896    I $D(DFOU T) D  Q
  27897   "RTN","CHM FADR4",483 ,0)
  27898    .D KLOCK^ CHMFADR1
  27899   "RTN","CHM FADR4",484 ,0)
  27900    .D OCRRRD Y^CHMFADR1
  27901   "RTN","CHM FADR4",485 ,0)
  27902    .D DELST1 ^CHMFADR1
  27903   "RTN","CHM FADR4",486 ,0)
  27904    .D REMV^C HMFADR1
  27905   "RTN","CHM FADR4",487 ,0)
  27906    Q
  27907   "RTN","CHM FADR4",488 ,0)
  27908   SBOCRR ;SB /CWVV EDI  Re-open cl aims start  here. --  CPE005-004
  27909   "RTN","CHM FADR4",489 ,0)
  27910    ;
  27911   "RTN","CHM FADR4",490 ,0)
  27912    N CHOSEN, VALOPDI,CH REJ
  27913   "RTN","CHM FADR4",491 ,0)
  27914    S CHOSEN= 7
  27915   "RTN","CHM FADR4",492 ,0)
  27916    K CHMFPRE V
  27917   "RTN","CHM FADR4",493 ,0)
  27918    S (PS,FKI L,FIPAY,BA D,CHMFPGNM ,CHMFIMAG, VALOPDI)=0
  27919   "RTN","CHM FADR4",494 ,0)
  27920    S (CHMFPD I,CHMOPDI) =""
  27921   "RTN","CHM FADR4",495 ,0)
  27922    D LSTPDI^ CHMFADR1
  27923   "RTN","CHM FADR4",496 ,0)
  27924    D SETUP^C HMFADR1
  27925   "RTN","CHM FADR4",497 ,0)
  27926    G:CHMFPDI '="" SB01
  27927   "RTN","CHM FADR4",498 ,0)
  27928   SB0 D SETU P1^CHMFADR 1
  27929   "RTN","CHM FADR4",499 ,0)
  27930    D ^CHMFPD O4 Q:$D(CH QUIT)
  27931   "RTN","CHM FADR4",500 ,0)
  27932   SB01 ;
  27933   "RTN","CHM FADR4",501 ,0)
  27934    I CHMOPDI ="" S CHMO PDI=$P($G( ^CHMIMG(CH MFPDI,"E-R EOPEN"))," ^")
  27935   "RTN","CHM FADR4",502 ,0)
  27936    S $P(^CHM DIC(741002 .21,DUZ,0) ,"^",2)=$G (CHMOPDI)
  27937   "RTN","CHM FADR4",503 ,0)
  27938    S CHDOCID =$P($G(^CH MIMG(CHMFP DI,"DOC")) ,"^",1)
  27939   "RTN","CHM FADR4",504 ,0)
  27940    S CHMFPP= "SIP" D ^C HMFWK01
  27941   "RTN","CHM FADR4",505 ,0)
  27942    I $D(^CHM IMG(CHMFPD I)) S $P(^ CHMIMG(CHM FPDI,0),"^ ",17)=4
  27943   "RTN","CHM FADR4",506 ,0)
  27944    I $D(^CHM IMAGE(CHMF PDI)) S $P (^CHMIMAGE (CHMFPDI,0 ),"^",8)=1
  27945   "RTN","CHM FADR4",507 ,0)
  27946    D GETDATA ^CHMFA008
  27947   "RTN","CHM FADR4",508 ,0)
  27948    S CHMFIMT Y=1,CHMFTY PE="BILL/I NVOICE" ;B DB 0517201 7
  27949   "RTN","CHM FADR4",509 ,0)
  27950    N NEXTPAG E
  27951   "RTN","CHM FADR4",510 ,0)
  27952   SB1 D ^CHM FA008
  27953   "RTN","CHM FADR4",511 ,0)
  27954    I $D(CHMF BAD) D  G  SB0
  27955   "RTN","CHM FADR4",512 ,0)
  27956    .D KLOCK^ CHMFADR1
  27957   "RTN","CHM FADR4",513 ,0)
  27958    .D REMV^C HMFADR1
  27959   "RTN","CHM FADR4",514 ,0)
  27960    .D DELST1 ^CHMFADR1
  27961   "RTN","CHM FADR4",515 ,0)
  27962    .D KILALL ^CHMFADR1
  27963   "RTN","CHM FADR4",516 ,0)
  27964    .S CHMQNA M="IMAGE(" ,CHMOUT=1  K CHMIN D  ^CHMIS041
  27965   "RTN","CHM FADR4",517 ,0)
  27966    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  27967   "RTN","CHM FADR4",518 ,0)
  27968    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  27969   "RTN","CHM FADR4",519 ,0)
  27970    I $D(CHMF KIL) D  Q
  27971   "RTN","CHM FADR4",520 ,0)
  27972    .N CHMFTO B
  27973   "RTN","CHM FADR4",521 ,0)
  27974    .S CHMFTO B=$$TOB^CH MFADR2(CHM FPDI,CHMFP GNM,CHMFIM AG)
  27975   "RTN","CHM FADR4",522 ,0)
  27976    .I $E(CHM FTOB,3)=8  D  ;bdb 12 /13/2017 c pe005-033  prompt, se t the fina l cstat
  27977   "RTN","CHM FADR4",523 ,0)
  27978    ..N CHR
  27979   "RTN","CHM FADR4",524 ,0)
  27980    ..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
  27981   "RTN","CHM FADR4",525 ,0)
  27982    ..I $E($$ UP^XLFSTR( $G(CHR)),1 )'="Y" D S BOCRRDY^CH MFADR1 Q
  27983   "RTN","CHM FADR4",526 ,0)
  27984    ..D CRCST AT^CHMFUTL E(CHMFPDI, "","E001a" ,"A") ;CFS  Create th e CSTAT me ssage.
  27985   "RTN","CHM FADR4",527 ,0)
  27986    ..S DIE=7 41000.2,DA =CHMFPDI,D R=".06///1 1" D ^DIE  K DIE
  27987   "RTN","CHM FADR4",528 ,0)
  27988    .S FKIL=1
  27989   "RTN","CHM FADR4",529 ,0)
  27990    .D SETPRO D^CHMFADR1
  27991   "RTN","CHM FADR4",530 ,0)
  27992    .D KLOCK^ CHMFADR1
  27993   "RTN","CHM FADR4",531 ,0)
  27994    .D DELST1 ^CHMFADR1
  27995   "RTN","CHM FADR4",532 ,0)
  27996    .I $E(CHM FTOB,3)'=8  D SBOCRRD Y^CHMFADR1
  27997   "RTN","CHM FADR4",533 ,0)
  27998    .S $P(^CH MIMG(CHMFP DI,0),"^", 3)=""
  27999   "RTN","CHM FADR4",534 ,0)
  28000    .S $P(^CH MIMG(CHMFP DI,0),"^", 4)=""
  28001   "RTN","CHM FADR4",535 ,0)
  28002    .I $D(^CH MIMG(CHMFP DI,"PAUSE" )) K ^CHMI MG(CHMFPDI ,"PAUSE")
  28003   "RTN","CHM FADR4",536 ,0)
  28004    I $D(CHMF PDRV) D  G  SB0
  28005   "RTN","CHM FADR4",537 ,0)
  28006    .D KLOCK^ CHMFADR1
  28007   "RTN","CHM FADR4",538 ,0)
  28008    .D REMV^C HMFADR1
  28009   "RTN","CHM FADR4",539 ,0)
  28010    .D DELST1 ^CHMFADR1
  28011   "RTN","CHM FADR4",540 ,0)
  28012    .D OCRKIL ^CHMFADR1
  28013   "RTN","CHM FADR4",541 ,0)
  28014    .S CHMFPP ="PDIRST2"  D ^CHMFWK 01
  28015   "RTN","CHM FADR4",542 ,0)
  28016    I $D(DUOU T) D  Q
  28017   "RTN","CHM FADR4",543 ,0)
  28018    .D KLOCK^ CHMFADR1
  28019   "RTN","CHM FADR4",544 ,0)
  28020    .D SBOCRR DY^CHMFADR 1
  28021   "RTN","CHM FADR4",545 ,0)
  28022    .D DELST1 ^CHMFADR1
  28023   "RTN","CHM FADR4",546 ,0)
  28024    .D REMV^C HMFADR1
  28025   "RTN","CHM FADR4",547 ,0)
  28026    I $D(DFOU T) D  Q
  28027   "RTN","CHM FADR4",548 ,0)
  28028    .D KLOCK^ CHMFADR1
  28029   "RTN","CHM FADR4",549 ,0)
  28030    .D SBOCRR DY^CHMFADR 1
  28031   "RTN","CHM FADR4",550 ,0)
  28032    .D DELST1 ^CHMFADR1
  28033   "RTN","CHM FADR4",551 ,0)
  28034    .D REMV^C HMFADR1
  28035   "RTN","CHM FADR4",552 ,0)
  28036    Q
  28037   "RTN","CHM FADR4",553 ,0)
  28038    ;
  28039   "RTN","CHM FADR4",554 ,0)
  28040   MANUALR ;M anual EDI  Re-Open pr ocessed cl aims start  here. CPE 005-069
  28041   "RTN","CHM FADR4",555 ,0)
  28042    ; Set var iables to  0 or nil
  28043   "RTN","CHM FADR4",556 ,0)
  28044    N CHOSEN, VALOPDI
  28045   "RTN","CHM FADR4",557 ,0)
  28046    S (PS,FKI L,FIPAY,BA D)=0
  28047   "RTN","CHM FADR4",558 ,0)
  28048    S (CHMFPD I,CHMOPDI) =""
  28049   "RTN","CHM FADR4",559 ,0)
  28050    S CHOSEN= 8
  28051   "RTN","CHM FADR4",560 ,0)
  28052    ; LSTPDI^ CHMFADR1 l ooks for P DI's curre ntly in "P ause" stat us.
  28053   "RTN","CHM FADR4",561 ,0)
  28054    D LSTPDI^ CHMFADR1
  28055   "RTN","CHM FADR4",562 ,0)
  28056    D SETUP^C HMFADR1
  28057   "RTN","CHM FADR4",563 ,0)
  28058    G:CHMFPDI '="" MR1
  28059   "RTN","CHM FADR4",564 ,0)
  28060   MR0 D SETU P1^CHMFADR 1
  28061   "RTN","CHM FADR4",565 ,0)
  28062   MR1 S CHMF IMTY=1,CHM FTYPE="BIL L/INVOICE"   ;CPE005- 071
  28063   "RTN","CHM FADR4",566 ,0)
  28064    N NEXTPAG E
  28065   "RTN","CHM FADR4",567 ,0)
  28066    D ^CHMFA0 01
  28067   "RTN","CHM FADR4",568 ,0)
  28068    I $D(CHYE SFLG) D  G  M0
  28069   "RTN","CHM FADR4",569 ,0)
  28070    .D KLOCK^ CHMFADR1
  28071   "RTN","CHM FADR4",570 ,0)
  28072    .D REMV^C HMFADR1
  28073   "RTN","CHM FADR4",571 ,0)
  28074    .D DELST1 ^CHMFADR1
  28075   "RTN","CHM FADR4",572 ,0)
  28076    .D KILALL ^CHMFADR1
  28077   "RTN","CHM FADR4",573 ,0)
  28078    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041  Q
  28079   "RTN","CHM FADR4",574 ,0)
  28080    I $D(CHMF BAD) D  G  M0
  28081   "RTN","CHM FADR4",575 ,0)
  28082    .D KLOCK^ CHMFADR1
  28083   "RTN","CHM FADR4",576 ,0)
  28084    .D REMV^C HMFADR1
  28085   "RTN","CHM FADR4",577 ,0)
  28086    .D DELST1 ^CHMFADR1
  28087   "RTN","CHM FADR4",578 ,0)
  28088    .D KILALL ^CHMFADR1
  28089   "RTN","CHM FADR4",579 ,0)
  28090    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041
  28091   "RTN","CHM FADR4",580 ,0)
  28092    .S CHMQNA M="CHMBADQ (",CHMIN=1  K CHMOUT  D ^CHMIS04 1 Q
  28093   "RTN","CHM FADR4",581 ,0)
  28094    I $D(CHMF PS) D  G M 0
  28095   "RTN","CHM FADR4",582 ,0)
  28096    .S PS=1,C HMFI=CHMFP DI,CHMFPP= "SSPS"
  28097   "RTN","CHM FADR4",583 ,0)
  28098    .D ^CHMFW K01
  28099   "RTN","CHM FADR4",584 ,0)
  28100    .D SETPRO D^CHMFADR1
  28101   "RTN","CHM FADR4",585 ,0)
  28102    .D PSMSG^ CHMFADR1
  28103   "RTN","CHM FADR4",586 ,0)
  28104    .D KLOCK^ CHMFADR1
  28105   "RTN","CHM FADR4",587 ,0)
  28106    .D REMV^C HMFADR1
  28107   "RTN","CHM FADR4",588 ,0)
  28108    .D DELST1 ^CHMFADR1
  28109   "RTN","CHM FADR4",589 ,0)
  28110    .D KILALL ^CHMFADR1
  28111   "RTN","CHM FADR4",590 ,0)
  28112    .S CHMQNA M="MANUAL( ",CHMOUT=1  K CHMIN D  ^CHMIS041
  28113   "RTN","CHM FADR4",591 ,0)
  28114    .S CHMQNA M="CHMPSQ( ",CHMIN=1  K CHMOUT D  ^CHMIS041  Q
  28115   "RTN","CHM FADR4",592 ,0)
  28116    I $D(CHMF PAUS) D SE TPD^CHMFAD R1 Q
  28117   "RTN","CHM FADR4",593 ,0)
  28118    I $D(CHMF KIL) D  Q
  28119   "RTN","CHM FADR4",594 ,0)
  28120    .S FKIL=1
  28121   "RTN","CHM FADR4",595 ,0)
  28122    .D SETPRO D^CHMFADR1
  28123   "RTN","CHM FADR4",596 ,0)
  28124    .D DELST1 ^CHMFADR1
  28125   "RTN","CHM FADR4",597 ,0)
  28126    .D MANL^C HMFADR1
  28127   "RTN","CHM FADR4",598 ,0)
  28128    I $D(DUOU T) D  Q
  28129   "RTN","CHM FADR4",599 ,0)
  28130    .D KLOCK^ CHMFADR1
  28131   "RTN","CHM FADR4",600 ,0)
  28132    .D MANL^C HMFADR1
  28133   "RTN","CHM FADR4",601 ,0)
  28134    .D DELST1 ^CHMFADR1
  28135   "RTN","CHM FADR4",602 ,0)
  28136    .D REMV^C HMFADR1
  28137   "RTN","CHM FADR4",603 ,0)
  28138    I $D(DFOU T) D  Q
  28139   "RTN","CHM FADR4",604 ,0)
  28140    .D KLOCK^ CHMFADR1
  28141   "RTN","CHM FADR4",605 ,0)
  28142    .D MANL^C HMFADR1
  28143   "RTN","CHM FADR4",606 ,0)
  28144    .D DELST1 ^CHMFADR1
  28145   "RTN","CHM FADR4",607 ,0)
  28146    .D REMV^C HMFADR1
  28147   "RTN","CHM FADR4",608 ,0)
  28148    Q
  28149   "RTN","CHM FAUT5")
  28150   0^55^B8693 73
  28151   "RTN","CHM FAUT5",1,0 )
  28152   CHMFAUT5 ; HAC/BDB; C CSE UTILIT Y PROGRAM
  28153   "RTN","CHM FAUT5",2,0 )
  28154    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  28155   "RTN","CHM FAUT5",3,0 )
  28156    ;CCSE CPE 005-009 BD B 8/20/17
  28157   "RTN","CHM FAUT5",4,0 )
  28158    ;
  28159   "RTN","CHM FAUT5",5,0 )
  28160    Q
  28161   "RTN","CHM FAUT5",6,0 )
  28162    ;
  28163   "RTN","CHM FAUT5",7,0 )
  28164   PDI(OPDI) 
  28165   "RTN","CHM FAUT5",8,0 )
  28166    ; functio n to find  original P DI # with  page# and  image #
  28167   "RTN","CHM FAUT5",9,0 )
  28168    ; OPDI =  original P DI that us er either  manually e ntered or  defaulted  from 837-  required
  28169   "RTN","CHM FAUT5",10, 0)
  28170    ; returns  original  PDI # with  page and  image# or  0 if none  found
  28171   "RTN","CHM FAUT5",11, 0)
  28172    ;
  28173   "RTN","CHM FAUT5",12, 0)
  28174    N OPG,OIM
  28175   "RTN","CHM FAUT5",13, 0)
  28176    ; if it a lready con tains the  *page#*ima ge# we are  done
  28177   "RTN","CHM FAUT5",14, 0)
  28178    Q:OPDI["* " OPDI
  28179   "RTN","CHM FAUT5",15, 0)
  28180    S OPG=$P( $G(^CHMIMA GE(OPDI,0) ),"^",2)
  28181   "RTN","CHM FAUT5",16, 0)
  28182    S:'OPG OP G=$P($G(^C HMIMG(OPDI ,0)),"^",2 )
  28183   "RTN","CHM FAUT5",17, 0)
  28184    S:'OPG OP G=$P($G(^C HMIMG(OPDI ,"DOC"))," ^",2)
  28185   "RTN","CHM FAUT5",18, 0)
  28186    S:'OPG OP G=$P($G(^C HMIMG(OPDI ,2,0)),"^" ,3)
  28187   "RTN","CHM FAUT5",19, 0)
  28188    S:'OPG OP G=$P($G(^C HMIMAGE(OP DI,1,0))," ^",3)
  28189   "RTN","CHM FAUT5",20, 0)
  28190    Q:'OPG OP DI
  28191   "RTN","CHM FAUT5",21, 0)
  28192    S OIM=$P( $G(^CHMIMG (OPDI,2,OP G,1,0)),"^ ",3)
  28193   "RTN","CHM FAUT5",22, 0)
  28194    S:OIM=""  OIM=$P($G( ^CHMIMAGE( OPDI,1,OPG ,2,0)),"^" ,3)
  28195   "RTN","CHM FAUT5",23, 0)
  28196    Q OPDI_"* "_OPG_"*"_ $G(OIM)
  28197   "RTN","CHM FAUT5",24, 0)
  28198    ;
  28199   "RTN","CHM FAUT6")
  28200   0^56^B1987 3430
  28201   "RTN","CHM FAUT6",1,0 )
  28202   CHMFAUT6 ; HAC/KML;PU LL PHARMAC Y DATA FOR  IP screen s;01/19/00   13:15 PM
  28203   "RTN","CHM FAUT6",2,0 )
  28204    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  28205   "RTN","CHM FAUT6",3,0 )
  28206    ;CPE005-0 47 kml 8/1 /17 - sort  Rx lines  by DOS
  28207   "RTN","CHM FAUT6",4,0 )
  28208    ;
  28209   "RTN","CHM FAUT6",5,0 )
  28210   PRERX ; Pr eload phar macy
  28211   "RTN","CHM FAUT6",6,0 )
  28212    N L,INFO, DOS,POS,CH G,ICD,MOD, CPT,REV,OH IPYMT,MEDP YMT,BENPYM T,SPBEN,IN FO2
  28213   "RTN","CHM FAUT6",7,0 )
  28214    N DOSOUT, POSOUT,ICD OUT,REVOUT ,MODOUT,CP TOUT,PRAMO UNT
  28215   "RTN","CHM FAUT6",8,0 )
  28216    N OHIPDAM T,OHIPRESP ,ADDOHIPY, OHIPRBAL,M EDICDPD,TP LPAID,COST UNT,NMUNTA LL
  28217   "RTN","CHM FAUT6",9,0 )
  28218    N CALLDAM T,DEDCTAMT ,CSTSHAMT, PYMNTAMT,P ATPDAMT,CC APLAMT,ADI STRO,EDILI D
  28219   "RTN","CHM FAUT6",10, 0)
  28220    N SVL
  28221   "RTN","CHM FAUT6",11, 0)
  28222    K ^UTILIT Y($J),^TMP ($J)
  28223   "RTN","CHM FAUT6",12, 0)
  28224    S (D3,RXD OS,SVL,L)= 0
  28225   "RTN","CHM FAUT6",13, 0)
  28226    ;  
  28227   "RTN","CHM FAUT6",14, 0)
  28228    ;  "B" cr oss-refere nce at "RX -NS" multi ple is not  being cre ated when  image file  is create d
  28229   "RTN","CHM FAUT6",15, 0)
  28230    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  28231   "RTN","CHM FAUT6",16, 0)
  28232    ;
  28233   "RTN","CHM FAUT6",17, 0)
  28234    F  S D3=$ O(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"RX-NS", D3)) Q:D3= ""  D  ; w tc 7/27/17
  28235   "RTN","CHM FAUT6",18, 0)
  28236    . S RXDOS =$P($G(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"RX -NS",D3,0) ),"^",1) ;
  28237   "RTN","CHM FAUT6",19, 0)
  28238    . S ^TMP( $J,CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"RX-NS" ,RXDOS,D3) ="" ;
  28239   "RTN","CHM FAUT6",20, 0)
  28240    ;
  28241   "RTN","CHM FAUT6",21, 0)
  28242    S DMEDOS= "" ;
  28243   "RTN","CHM FAUT6",22, 0)
  28244    F  S RXDO S=$O(^TMP( $J,CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"RX-NS" ,RXDOS)) Q :RXDOS=""   D
  28245   "RTN","CHM FAUT6",23, 0)
  28246    . F  S D3 =$O(^TMP($ J,CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"RX-NS", RXDOS,D3))  Q:D3=""   D
  28247   "RTN","CHM FAUT6",24, 0)
  28248    .. S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  28249   "RTN","CHM FAUT6",25, 0)
  28250    .. S (DOA OUT,DODOUT ,POSOUT,IC DOUT,DSTAT OUT,EDILID )=""
  28251   "RTN","CHM FAUT6",26, 0)
  28252    .. S INFO =$G(^CHMIM AGE(CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"RX-NS ",L,0))
  28253   "RTN","CHM FAUT6",27, 0)
  28254    .. S INFO 2=$G(^CHMI MAGE(CHMFP DI,1,CHMFP GNM,2,CHMF IMAG,"RX-N S",L,1,1,0 ))
  28255   "RTN","CHM FAUT6",28, 0)
  28256    .Q:INFO=" "&(INFO2=" ")    ;JEH  2/1/11 DE V007820
  28257   "RTN","CHM FAUT6",29, 0)
  28258    .. S SPBE N=$P(INFO, "^",2)_"/" _$P(INFO," ^",3)
  28259   "RTN","CHM FAUT6",30, 0)
  28260    .. S SPON =$P(INFO," ^",2),BEN= $P(INFO,"^ ",3)
  28261   "RTN","CHM FAUT6",31, 0)
  28262    .. S DOS= $P(INFO,"^ ",1) S:DOS ]"" DOSOUT =$$DOS^CHM FAUT0(DOS)  
  28263   "RTN","CHM FAUT6",32, 0)
  28264    .. S ICD= $P(INFO,"^ ",11) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  28265   "RTN","CHM FAUT6",33, 0)
  28266    .. S:ICDO UT]"" ICDO UT=$P(ICDO UT,"^")_"^ "_$P(ICDOU T,"^",2)
  28267   "RTN","CHM FAUT6",34, 0)
  28268    .. S EDIL ID=$P(INFO ,"^",6)          ;JEH  2/1/11 DE V007820
  28269   "RTN","CHM FAUT6",35, 0)
  28270    .. S CHG= $P(INFO,"^ ",8)
  28271   "RTN","CHM FAUT6",36, 0)
  28272    .. S PDX= $P(INFO,"^ ",7) S:PDX ]"" CPTOUT =$$PDX^CHM FAUT0(PDX)  
  28273   "RTN","CHM FAUT6",37, 0)
  28274    .. S CPTO UT="RX*"_$ E(CPTOUT,1 ,13)_"^"_$ P(CPTOUT," ^",2)_"^"_ $E(CPTOUT, 17,$L($P(C PTOUT,"^", 1)))
  28275   "RTN","CHM FAUT6",38, 0)
  28276    .. S UNT= $P(INFO,"^ ",12)
  28277   "RTN","CHM FAUT6",39, 0)
  28278    .. S (OHI PDAMT,OHIP RESP,ADDOH IPY,OHIPRB AL,MEDICDP D,TPLPAID, COSTUNT)=" "
  28279   "RTN","CHM FAUT6",40, 0)
  28280    .. S (NMU NTALL,CALL DAMT,DEDCT AMT,CSTSHA MT,PYMNTAM T,PATPDAMT ,CCAPLAMT, ADISTRO)=" "
  28281   "RTN","CHM FAUT6",41, 0)
  28282    .. S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT
  28283   "RTN","CHM FAUT6",42, 0)
  28284    .. S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y
  28285   "RTN","CHM FAUT6",43, 0)
  28286    .. S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS
  28287   "RTN","CHM FAUT6",44, 0)
  28288    .. S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE
  28289   "RTN","CHM FAUT6",45, 0)
  28290    .. S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID
  28291   "RTN","CHM FAUT6",46, 0)
  28292    .. S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D
  28293   "RTN","CHM FAUT6",47, 0)
  28294    .. S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT
  28295   "RTN","CHM FAUT6",48, 0)
  28296    .. S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED
  28297   "RTN","CHM FAUT6",49, 0)
  28298    .. S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT
  28299   "RTN","CHM FAUT6",50, 0)
  28300    .. S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT
  28301   "RTN","CHM FAUT6",51, 0)
  28302    .. S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT
  28303   "RTN","CHM FAUT6",52, 0)
  28304    .. S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT
  28305   "RTN","CHM FAUT6",53, 0)
  28306    .. S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T
  28307   "RTN","CHM FAUT6",54, 0)
  28308    .. S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT
  28309   "RTN","CHM FAUT6",55, 0)
  28310    .. S ADIS TRO=$P(^CH MIMAGE(CHM FPDI,0),"^ ",16) ;AUT O DISTRIBU TION
  28311   "RTN","CHM FAUT6",56, 0)
  28312    .. S FORL =L
  28313   "RTN","CHM FAUT6",57, 0)
  28314    .. S L=L+ SVL
  28315   "RTN","CHM FAUT6",58, 0)
  28316    .. D PRER XL
  28317   "RTN","CHM FAUT6",59, 0)
  28318    .. S L=FO RL
  28319   "RTN","CHM FAUT6",60, 0)
  28320    ;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
  28321   "RTN","CHM FAUT6",61, 0)
  28322    I $E($P($ G(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"VEN")), "^",7),3)= 5 S L=$$LA TE^CHMFAUT 5(CHMFPDI, $G(CHMOPDI ),CHMFSRVC ,$G(SPBEN) ,($G(FORL) +SVL))
  28323   "RTN","CHM FAUT6",62, 0)
  28324    Q
  28325   "RTN","CHM FAUT6",63, 0)
  28326    ;
  28327   "RTN","CHM FAUT6",64, 0)
  28328   PRERXL ;   Load outpa tient proc edure into  ^UTILITY
  28329   "RTN","CHM FAUT6",65, 0)
  28330    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 0)=L
  28331   "RTN","CHM FAUT6",66, 0)
  28332    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 1)=DOSOUT
  28333   "RTN","CHM FAUT6",67, 0)
  28334    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 2)=POSOUT
  28335   "RTN","CHM FAUT6",68, 0)
  28336    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 3)=ICDOUT
  28337   "RTN","CHM FAUT6",69, 0)
  28338    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 4)=REVOUT
  28339   "RTN","CHM FAUT6",70, 0)
  28340    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 5)=CPTOUT
  28341   "RTN","CHM FAUT6",71, 0)
  28342    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 6)=MODOUT
  28343   "RTN","CHM FAUT6",72, 0)
  28344    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 8)=CHG
  28345   "RTN","CHM FAUT6",73, 0)
  28346    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 7)=UNT
  28347   "RTN","CHM FAUT6",74, 0)
  28348    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 9)=""  ;AE B 10/27/20 10 DEV0078 20
  28349   "RTN","CHM FAUT6",75, 0)
  28350    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 10)=OHIPDA MT   ;AEB  10/27/2010  DEV007820  prim ohi  pd
  28351   "RTN","CHM FAUT6",76, 0)
  28352    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 11)=OHIPRE SP   ;AEB  10/27/2010  DEV007820  prim ohi  pr
  28353   "RTN","CHM FAUT6",77, 0)
  28354    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 12)=ADDOHI PY   ;AEB  10/27/2010  DEV007820  add ohi p d
  28355   "RTN","CHM FAUT6",78, 0)
  28356    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 13)=PATPDA MT   ;AEB  10/27/2010  DEV007820  bene pd
  28357   "RTN","CHM FAUT6",79, 0)
  28358    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 14)=MEDICD PD   ;AEB  10/27/2010  DEV007820  medicad
  28359   "RTN","CHM FAUT6",80, 0)
  28360    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 15)=TPLPAI D    ;AEB  10/27/2010  DEV007820  tpl
  28361   "RTN","CHM FAUT6",81, 0)
  28362    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 16)=OHIPRB AL   ;JEH  2/1/2011 D EV007820 p /r bal
  28363   "RTN","CHM FAUT6",82, 0)
  28364    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 17)=ADISTR O    ;JEH  2/1/2011 D EV007820 a uto calc f lag
  28365   "RTN","CHM FAUT6",83, 0)
  28366    S ^UTILIT Y($J,"CHRX ",SPBEN,L, 18)=EDILID      ;JEH  2/1/2011 D EV007820 e di line id entifier
  28367   "RTN","CHM FAUT6",84, 0)
  28368    I (ICDOUT ="")&(CPTO UT="")&(RE VOUT="") S  ^UTILITY( $J,"CHRX", SPBEN,L,2) =""
  28369   "RTN","CHM FAUT6",85, 0)
  28370    Q
  28371   "RTN","CHM FAUT7")
  28372   0^57^B5618 85712
  28373   "RTN","CHM FAUT7",1,0 )
  28374   CHMFAUT7 ; HAC/JLR;UT ILITY PROG RAM FOR DE NTAL SCREE NS;01/19/0 0  13:15 P M
  28375   "RTN","CHM FAUT7",2,0 )
  28376    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  28377   "RTN","CHM FAUT7",3,0 )
  28378    ;JSG;01/2 9/08;Modif ications f or DEV0039 56-02;Hand ling null  DOSs (see  PREOUT)
  28379   "RTN","CHM FAUT7",4,0 )
  28380    ;JSG;01/2 9/08;                                 ;OC =  Old Code,  NC = New  Code
  28381   "RTN","CHM FAUT7",5,0 )
  28382    ;JSG;03/1 4/08;DEV00 4525-01;Pr event Inva lid Subscr ipt error
  28383   "RTN","CHM FAUT7",6,0 )
  28384    ;JEH 8/29 /08 TT #DE V005596  A dded code  to prevent  undefined  error whe n missing  %
  28385   "RTN","CHM FAUT7",7,0 )
  28386    ;DEV00480 5 1/20/201 0 AEB
  28387   "RTN","CHM FAUT7",8,0 )
  28388    ;DEV00782 0 10/27/20 10 AEB
  28389   "RTN","CHM FAUT7",9,0 )
  28390    ;DEV00782 0 JEH 2/1/ 11 - SLLA
  28391   "RTN","CHM FAUT7",10, 0)
  28392    ;DEV01207 2 JEH 10/5 /11 - add  icd check
  28393   "RTN","CHM FAUT7",11, 0)
  28394    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if freque ncy code =  5
  28395   "RTN","CHM FAUT7",12, 0)
  28396    ;CPE005-0 48 wtc 7/2 6/17 - sor t DME line s by DOS
  28397   "RTN","CHM FAUT7",13, 0)
  28398    ;CPE005-0 49 kml 8/7 /17 - sort  dental in voice line s by DOS
  28399   "RTN","CHM FAUT7",14, 0)
  28400    ;CPE005-0 08/050 wtc  8/8/17 -  sort outpa tient serv ice lines  by DOS
  28401   "RTN","CHM FAUT7",15, 0)
  28402    ;CPE-005- 009 LEM 8/ 19/17 - Ad d charge l ine for TO S = Dental  and Frequ ency Code  = 5
  28403   "RTN","CHM FAUT7",16, 0)
  28404    ;
  28405   "RTN","CHM FAUT7",17, 0)
  28406   PDITYP(PDI ) ;Determi nes PDI ty pe
  28407   "RTN","CHM FAUT7",18, 0)
  28408    ; Returns  0 = not a n OCR clai m
  28409   "RTN","CHM FAUT7",19, 0)
  28410    ;          1 = is an  OCR claim
  28411   "RTN","CHM FAUT7",20, 0)
  28412    ;
  28413   "RTN","CHM FAUT7",21, 0)
  28414    ;Example:  S CHPDIPR L=$$PDITYP ^CHMFAUT1( CHMFPDI)
  28415   "RTN","CHM FAUT7",22, 0)
  28416    ;
  28417   "RTN","CHM FAUT7",23, 0)
  28418    N X,Y,CHP DITY,PTR S  X=0
  28419   "RTN","CHM FAUT7",24, 0)
  28420    ;//////// / START // ////////// ////////// /  RKN 12/ 12/2006 TT #312  this  ensures C HPDIPRL va riable wil l equal 1
  28421   "RTN","CHM FAUT7",25, 0)
  28422    I $E(PDI, 8,9)="92"  S X="1"               ;RKN 12/12 /2006 TT#3 12  this e nsures CHP DIPRL vari able will  equal 1
  28423   "RTN","CHM FAUT7",26, 0)
  28424    ;The abov e code pre vents this  eroneous  error mess age below  from being  displayed  in routin e PAG1^CHM FADR2
  28425   "RTN","CHM FAUT7",27, 0)
  28426    ;  "Page  # ",CHMFPG NM," has a lready bee n processe d.  Do you  want to k ill the da ta for thi s"
  28427   "RTN","CHM FAUT7",28, 0)
  28428    ;//////// / END //// ////////// ////////// ///// RKN  12/12/2006  TT#312  t his ensure s CHPDIPRL  variable  will equal  1
  28429   "RTN","CHM FAUT7",29, 0)
  28430    G:'$D(PDI ) TYPEXIT
  28431   "RTN","CHM FAUT7",30, 0)
  28432    G:'$D(^CH MIMG(PDI))  TYPEXIT
  28433   "RTN","CHM FAUT7",31, 0)
  28434    S CHPDITY =$$TYPE^CH MFPDI2(PDI )
  28435   "RTN","CHM FAUT7",32, 0)
  28436    G:CHPDITY ="" TYPEXI T
  28437   "RTN","CHM FAUT7",33, 0)
  28438    G:'$D(^CH MDIC(74100 2.93,"C",C HPDITY)) T YPEXIT
  28439   "RTN","CHM FAUT7",34, 0)
  28440    S PTR=$O( ^CHMDIC(74 1002.93,"C ",CHPDITY, 0))
  28441   "RTN","CHM FAUT7",35, 0)
  28442    G:'PTR TY PEXIT
  28443   "RTN","CHM FAUT7",36, 0)
  28444    G:'$D(^CH MDIC(74100 2.93,PTR,0 )) TYPEXIT
  28445   "RTN","CHM FAUT7",37, 0)
  28446    G:'$P(^CH MDIC(74100 2.93,PTR,0 ),"^",7) T YPEXIT
  28447   "RTN","CHM FAUT7",38, 0)
  28448    S X=1
  28449   "RTN","CHM FAUT7",39, 0)
  28450   TYPEXIT Q  X
  28451   "RTN","CHM FAUT7",40, 0)
  28452    ;
  28453   "RTN","CHM FAUT7",41, 0)
  28454   PREOUT ; P reload Den tal proced ures
  28455   "RTN","CHM FAUT7",42, 0)
  28456    ;D TPREOU T^CHMFAUT5  Q  ;BDB 0 8162017 TE ST cpe005- 009 outpat ient
  28457   "RTN","CHM FAUT7",43, 0)
  28458    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
  28459   "RTN","CHM FAUT7",44, 0)
  28460    N DOSOUT, POSOUT,ICD OUT,REVOUT ,MODOUT,CP TOUT,PRAMO UNT   ;SKD  9-27-07 D EV003378
  28461   "RTN","CHM FAUT7",45, 0)
  28462    N OHIPDAM T,OHIPRESP ,ADDOHIPY, OHIPRBAL,M EDICDPD,TP LPAID,COST UNT,NMUNTA LL         ;JEH 2/1/1 1 DEV00782 0
  28463   "RTN","CHM FAUT7",46, 0)
  28464    N CALLDAM T,DEDCTAMT ,CSTSHAMT, PYMNTAMT,P ATPDAMT,CC APLAMT,ADI STRO,EDILI D ;JEH 2/1 /11 DEV007 820
  28465   "RTN","CHM FAUT7",47, 0)
  28466    N SVL           ;JEH  2/1/11 DE V007820
  28467   "RTN","CHM FAUT7",48, 0)
  28468    N D3,D4,D ENDOS,CHMO PGNM,CHMOI MAG,CHMOPG IM ; wtc 8 /8/17
  28469   "RTN","CHM FAUT7",49, 0)
  28470    K ^UTILIT Y($J),^TMP ($J) ; wtc  8/8/17
  28471   "RTN","CHM FAUT7",50, 0)
  28472    S (DENDOS ,SVL)="",D 3=0,L=0 ;  wtc 8/8/17
  28473   "RTN","CHM FAUT7",51, 0)
  28474    ;
  28475   "RTN","CHM FAUT7",52, 0)
  28476    ;  wtc 8/ 8/17
  28477   "RTN","CHM FAUT7",53, 0)
  28478    ;  
  28479   "RTN","CHM FAUT7",54, 0)
  28480    ;  "B" cr oss-refere nce at "DE NTAL-NS" m ultiple is  not being  created w hen image  file is cr eated
  28481   "RTN","CHM FAUT7",55, 0)
  28482    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  28483   "RTN","CHM FAUT7",56, 0)
  28484    ;
  28485   "RTN","CHM FAUT7",57, 0)
  28486    S SVL=0        ;JEH  2/1/11 DEV 007820
  28487   "RTN","CHM FAUT7",58, 0)
  28488    ;S L=""   ; wtc 8/8/ 17
  28489   "RTN","CHM FAUT7",59, 0)
  28490    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
  28491   "RTN","CHM FAUT7",60, 0)
  28492    . S DENDO S=$P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"D ENTAL-NS", D3,0)),"^" ,1) ;
  28493   "RTN","CHM FAUT7",61, 0)
  28494    . ;S ^TMP ($J,CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"DENTA L-NS",DEND OS,D3)=""
  28495   "RTN","CHM FAUT7",62, 0)
  28496    . S ^TMP( $J,DENDOS, D3,CHMFPDI )=""
  28497   "RTN","CHM FAUT7",63, 0)
  28498    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  28499   "RTN","CHM FAUT7",64, 0)
  28500    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
  28501   "RTN","CHM FAUT7",65, 0)
  28502    . S DENDO S=$P($G(^C HMIMAGE(CH MOPDI,1,CH MOPGNM,2,C HMOIMAG,"D ENTAL-NS", D3,0)),"^" ,1) ;
  28503   "RTN","CHM FAUT7",66, 0)
  28504    . ;S ^TMP ($J,CHMOPD I,1,CHMOPG NM,2,CHMOI MAG,"DENTA L-NS",DEND OS,D3)=""
  28505   "RTN","CHM FAUT7",67, 0)
  28506    . S ^TMP( $J,DENDOS, D3,CHMOPDI )=""
  28507   "RTN","CHM FAUT7",68, 0)
  28508    ;
  28509   "RTN","CHM FAUT7",69, 0)
  28510    ;F  S L=$ O(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"DENTAL- NS",L)) Q: L=""  D S  DENDOS=""  ;  wtc 8/8 /17
  28511   "RTN","CHM FAUT7",70, 0)
  28512    S DENDOS= "" ;
  28513   "RTN","CHM FAUT7",71, 0)
  28514    ;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
  28515   "RTN","CHM FAUT7",72, 0)
  28516    ;. 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
  28517   "RTN","CHM FAUT7",73, 0)
  28518    F  S DEND OS=$O(^TMP ($J,DENDOS )) Q:DENDO S=""  D  ;  wtc 8/8/1 7
  28519   "RTN","CHM FAUT7",74, 0)
  28520    . S D3=""  F  S D3=$ O(^TMP($J, DENDOS,D3) ) Q:D3=""   D  ; wtc  8/8/17
  28521   "RTN","CHM FAUT7",75, 0)
  28522    .. S D4=" " F  S D4= $O(^TMP($J ,DENDOS,D3 ,D4)) Q:D4 =""  D  ;b db 8/15/20 176
  28523   "RTN","CHM FAUT7",76, 0)
  28524    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  28525   "RTN","CHM FAUT7",77, 0)
  28526    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=$G(CHMOP DI),CHMFPG N1=$G(CHMO PGNM),CHMF IMA1=$G(CH MOIMAG)
  28527   "RTN","CHM FAUT7",78, 0)
  28528    ...S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  28529   "RTN","CHM FAUT7",79, 0)
  28530    ...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
  28531   "RTN","CHM FAUT7",80, 0)
  28532    ...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
  28533   "RTN","CHM FAUT7",81, 0)
  28534    ...;&(INF O2="")         ;JEH 2 /1/11 DEV0 07820
  28535   "RTN","CHM FAUT7",82, 0)
  28536    ...Q:INFO =""
  28537   "RTN","CHM FAUT7",83, 0)
  28538    ...S SPBE N=$P(INFO, "^",3)_"/" _$P(INFO," ^",4)
  28539   "RTN","CHM FAUT7",84, 0)
  28540    ...; JSG; 01/29/08;D EV003956-0 2;Make DOS OUT = "__/ __/__^" fo r null DOS
  28541   "RTN","CHM FAUT7",85, 0)
  28542    ...; S DO S=$P(INFO, "^",1) S:D OS]"" DOSO UT=$$DOS^C HMFAUT0(DO S)                  ; JSG;OC
  28543   "RTN","CHM FAUT7",86, 0)
  28544    ...S DOS= $P(INFO,"^ ",1) S DOS OUT=$S(DOS ]"":$$DOS^ CHMFAUT0(D OS),1:"__/ __/__^") ; JSG;NC: St uff it, if  ""
  28545   "RTN","CHM FAUT7",87, 0)
  28546    ...S POS= $P(INFO,"^ ",2) S:POS ="" POS=3  S:POS]"" P OSOUT=$$PO S^CHMFAUT0 (POS)
  28547   "RTN","CHM FAUT7",88, 0)
  28548    ...S CHG= $P(INFO,"^ ",8)
  28549   "RTN","CHM FAUT7",89, 0)
  28550    ...S ICD= $P(INFO,"^ ",10) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  28551   "RTN","CHM FAUT7",90, 0)
  28552    ...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
  28553   "RTN","CHM FAUT7",91, 0)
  28554    ...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
  28555   "RTN","CHM FAUT7",92, 0)
  28556    ...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
  28557   "RTN","CHM FAUT7",93, 0)
  28558    ...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
  28559   "RTN","CHM FAUT7",94, 0)
  28560    ...S MODO UT=MOD_MOD 2_MOD3_MOD 4_"*"_MODO UT ;JEH 2/ 1/11 DEV00 7820
  28561   "RTN","CHM FAUT7",95, 0)
  28562    ...S:$P(M ODOUT,"*", 1)="" MODO UT="" ;JEH  2/1/11 DE V007820
  28563   "RTN","CHM FAUT7",96, 0)
  28564    ...; S CP T=$P(INFO, "^",7) S:C PT]"" CPTO UT=$$PROC^ CHMFAUT0(C PT,DOS)                  ;JSG;OC
  28565   "RTN","CHM FAUT7",97, 0)
  28566    ...D:$G(% )="" NOW^% DTC ;JEH 8 /29/08 TT  #DEV005596   ADDED LI NE
  28567   "RTN","CHM FAUT7",98, 0)
  28568    ...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
  28569   "RTN","CHM FAUT7",99, 0)
  28570    ...S REV= $P(INFO,"^ ",14) S:RE V]"" REVOU T=$$REV^CH MFAUT0(REV )
  28571   "RTN","CHM FAUT7",100 ,0)
  28572    ...S EDIL ID=$P(INFO ,"^",16) ; JEH 2/1/11  DEV007820
  28573   "RTN","CHM FAUT7",101 ,0)
  28574    ...S UNT= $P(INFO,"^ ",17)
  28575   "RTN","CHM FAUT7",102 ,0)
  28576    ...S MEDP YMT=$P(INF O,"^",18)
  28577   "RTN","CHM FAUT7",103 ,0)
  28578    ...S BENP YMT=$P(INF O,"^",6)
  28579   "RTN","CHM FAUT7",104 ,0)
  28580    ...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
  28581   "RTN","CHM FAUT7",105 ,0)
  28582    ...S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT                                       JEH 2/1/ 11 DEV0078 20
  28583   "RTN","CHM FAUT7",106 ,0)
  28584    ...S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y              JEH 2/ 1/11 DEV00 7820
  28585   "RTN","CHM FAUT7",107 ,0)
  28586    ...S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS    JEH  2/1/11 DEV 007820
  28587   "RTN","CHM FAUT7",108 ,0)
  28588    ...S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE                                     JEH 2/1/ 11 DEV0078 20
  28589   "RTN","CHM FAUT7",109 ,0)
  28590    ...S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID                                       JEH 2/1/ 11 DEV0078 20
  28591   "RTN","CHM FAUT7",110 ,0)
  28592    ...S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D                                                   JE H 2/1/11 D EV007820
  28593   "RTN","CHM FAUT7",111 ,0)
  28594    ...S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT                                                  JE H 2/1/11 D EV007820
  28595   "RTN","CHM FAUT7",112 ,0)
  28596    ...S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED                                    JEH 2/1/ 11 DEV0078 20
  28597   "RTN","CHM FAUT7",113 ,0)
  28598    ...S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT                JEH 2/ 1/11 DEV00 7820
  28599   "RTN","CHM FAUT7",114 ,0)
  28600    ...S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT                                 JEH 2/1/ 11 DEV0078 20
  28601   "RTN","CHM FAUT7",115 ,0)
  28602    ...S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT                                     JEH 2/1/ 11 DEV0078 20
  28603   "RTN","CHM FAUT7",116 ,0)
  28604    ...S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT                                     JEH 2/1/ 11 DEV0078 20
  28605   "RTN","CHM FAUT7",117 ,0)
  28606    ...S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T                                  JEH 2/1/ 11 DEV0078 20
  28607   "RTN","CHM FAUT7",118 ,0)
  28608    ...S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT                      JEH 2/ 1/11 DEV00 7820
  28609   "RTN","CHM FAUT7",119 ,0)
  28610    ...S ADIS TRO=$P(^CH MIMAGE(CHM FPDI1,0)," ^",16) ;AU TO DISTRIB UTION  JEH  2/1/11 DE V007820
  28611   "RTN","CHM FAUT7",120 ,0)
  28612    ...; I '$ L($G(DOS)) !'$G(POS)  W !,"*** D OS or POS  missing! * **" H 5 Q  ;JSG;OC;Do n't need
  28613   "RTN","CHM FAUT7",121 ,0)
  28614    ...I DOS] "" D           ;JSG;N C;We only  want to do  this sect ion if DOS  originall y not ""
  28615   "RTN","CHM FAUT7",122 ,0)
  28616    ....S:'$D (CHHOLDPY( DOS,POS))  CHHOLDPY(D OS,POS)=""
  28617   "RTN","CHM FAUT7",123 ,0)
  28618    ....I MED PYMT'="" D
  28619   "RTN","CHM FAUT7",124 ,0)
  28620    .....S $P (CHHOLDPY( DOS,POS)," ^",1)=$P(C HHOLDPY(DO S,POS),"^" ,1)+MEDPYM T
  28621   "RTN","CHM FAUT7",125 ,0)
  28622    ....;I BE NPYMT'=""  I BENPYMT  D     ;JEH  2/1/11 DE V007820
  28623   "RTN","CHM FAUT7",126 ,0)
  28624    ....I BEN PYMT'="" D         ;J EH 2/1/11  DEV007820
  28625   "RTN","CHM FAUT7",127 ,0)
  28626    .....S $P (CHHOLDPY( DOS,POS)," ^",2)=$P(C HHOLDPY(DO S,POS),"^" ,2)+BENPYM T
  28627   "RTN","CHM FAUT7",128 ,0)
  28628    ....S PRA MOUNT=""     ;SKD 9-2 7-07 DEV00 3378
  28629   "RTN","CHM FAUT7",129 ,0)
  28630    ....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
  28631   "RTN","CHM FAUT7",130 ,0)
  28632    .....;S O HIPYMT=^CH MIMAGE(CHM FPDI1,"ZOH I",DFN,BFN ,CHMFSERV, DOS,POS,VF N)  ;SKD M C284 12-15 -06
  28633   "RTN","CHM FAUT7",131 ,0)
  28634    .....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
  28635   "RTN","CHM FAUT7",132 ,0)
  28636    .....;S $ P(CHHOLDPY (DOS,POS), "^",3)=$FN (OHIPYMT," ",2)   ;SK D MC284 12 -15-06
  28637   "RTN","CHM FAUT7",133 ,0)
  28638    .....I $G (PRAMOUNT)  S $P(CHHO LDPY(DOS,P OS),"^",3) =$FN(PRAMO UNT,"",2)    ;SKD MC2 84 12-15-0 6
  28639   "RTN","CHM FAUT7",134 ,0)
  28640    ...I TPLP AID'="" I  TPLPAID D
  28641   "RTN","CHM FAUT7",135 ,0)
  28642    ....S $P( CHHOLDPY(D OS,POS),"^ ",4)=$P(CH HOLDPY(DOS ,POS),"^", 4)+TPLPAID
  28643   "RTN","CHM FAUT7",136 ,0)
  28644    ... ;
  28645   "RTN","CHM FAUT7",137 ,0)
  28646    ... ;  Do  not outpu t line if  it has nei ther diagn osis (ICD)  nor reven ue code (R EV) - wtc  8/10/17
  28647   "RTN","CHM FAUT7",138 ,0)
  28648    ... ;
  28649   "RTN","CHM FAUT7",139 ,0)
  28650    ... I ICD '=""!(REV' ="") D  ;
  28651   "RTN","CHM FAUT7",140 ,0)
  28652    ....S L=L +1 D PREOU TL^CHMFAUT 1 ; Increm ent L wtc  8/8/17
  28653   "RTN","CHM FAUT7",141 ,0)
  28654    ....S SVL =L       ; JEH 2/1/11  DEV007820
  28655   "RTN","CHM FAUT7",142 ,0)
  28656    ...Q
  28657   "RTN","CHM FAUT7",143 ,0)
  28658    ;OUTPATIE NT PHARMAC Y DATA         ;JEH 2 /1/11 DEV0 07820
  28659   "RTN","CHM FAUT7",144 ,0)
  28660    Q:SVL=""
  28661   "RTN","CHM FAUT7",145 ,0)
  28662    S L=""
  28663   "RTN","CHM FAUT7",146 ,0)
  28664    N RXDOS ;  
  28665   "RTN","CHM FAUT7",147 ,0)
  28666    S RXDOS=" ",D3=0,L=S VL ; wtc 8 /8/17
  28667   "RTN","CHM FAUT7",148 ,0)
  28668    K ^TMP($J ) ;
  28669   "RTN","CHM FAUT7",149 ,0)
  28670    ;
  28671   "RTN","CHM FAUT7",150 ,0)
  28672    ;  wtc 8/ 8/17
  28673   "RTN","CHM FAUT7",151 ,0)
  28674    ;  
  28675   "RTN","CHM FAUT7",152 ,0)
  28676    ;  "B" cr oss-refere nce at "RX -NS" multi ple is not  being cre ated when  image file  is create d
  28677   "RTN","CHM FAUT7",153 ,0)
  28678    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  28679   "RTN","CHM FAUT7",154 ,0)
  28680    ;
  28681   "RTN","CHM FAUT7",155 ,0)
  28682    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
  28683   "RTN","CHM FAUT7",156 ,0)
  28684    . S RXDOS =$P($G(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"RX -NS",D3,0) ),"^",1) ;
  28685   "RTN","CHM FAUT7",157 ,0)
  28686    . S ^TMP( $J,RXDOS,D 3,CHMFPDI) =""
  28687   "RTN","CHM FAUT7",158 ,0)
  28688    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  28689   "RTN","CHM FAUT7",159 ,0)
  28690    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
  28691   "RTN","CHM FAUT7",160 ,0)
  28692    . S RXDOS =$P($G(^CH MIMAGE(CHM OPDI,1,CHM OPGNM,2,CH MOIMAG,"RX -NS",D3,0) ),"^",1) ;
  28693   "RTN","CHM FAUT7",161 ,0)
  28694    . S ^TMP( $J,RXDOS,D 3,CHMOPDI) =""
  28695   "RTN","CHM FAUT7",162 ,0)
  28696    ;
  28697   "RTN","CHM FAUT7",163 ,0)
  28698    S RXDOS=" " ;
  28699   "RTN","CHM FAUT7",164 ,0)
  28700    F  S RXDO S=$O(^TMP( $J,RXDOS))  Q:RXDOS=" "  D  ; wt c 8/8/17
  28701   "RTN","CHM FAUT7",165 ,0)
  28702    . S D3=""  F  S D3=$ O(^TMP($J, RXDOS,D3))  Q:D3=""   D  ; wtc 8 /8/17
  28703   "RTN","CHM FAUT7",166 ,0)
  28704    .. S D4=" " F  S D4= $O(^TMP($J ,RXDOS,D3, D4)) Q:D4= ""  D  ;bd b 8/15/201 76
  28705   "RTN","CHM FAUT7",167 ,0)
  28706    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  28707   "RTN","CHM FAUT7",168 ,0)
  28708    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=$G(CHMOP DI),CHMFPG N1=$G(CHMO PGNM),CHMF IMA1=$G(CH MOIMAG) 
  28709   "RTN","CHM FAUT7",169 ,0)
  28710    ...S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  28711   "RTN","CHM FAUT7",170 ,0)
  28712    ...S (DOA OUT,DODOUT ,POSOUT,IC DOUT,DSTAT OUT,EDILID )=""       ;JEH 2/1/1 1 DEV00782 0
  28713   "RTN","CHM FAUT7",171 ,0)
  28714    ...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
  28715   "RTN","CHM FAUT7",172 ,0)
  28716    ...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
  28717   "RTN","CHM FAUT7",173 ,0)
  28718    ...Q:INFO =""&(INFO2 ="")    ;J EH 2/1/11  DEV007820
  28719   "RTN","CHM FAUT7",174 ,0)
  28720    ...S SPBE N=$P(INFO, "^",2)_"/" _$P(INFO," ^",3)
  28721   "RTN","CHM FAUT7",175 ,0)
  28722    ...S SPON =$P(INFO," ^",2),BEN= $P(INFO,"^ ",3)
  28723   "RTN","CHM FAUT7",176 ,0)
  28724    ...S DOS= $P(INFO,"^ ",1) S:DOS ]"" DOSOUT =$$DOS^CHM FAUT0(DOS)  
  28725   "RTN","CHM FAUT7",177 ,0)
  28726    ...S ICD= $P(INFO,"^ ",11) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  28727   "RTN","CHM FAUT7",178 ,0)
  28728    ...S:ICDO UT]"" ICDO UT=$P(ICDO UT,"^")_"^ "_$P(ICDOU T,"^",2)
  28729   "RTN","CHM FAUT7",179 ,0)
  28730    ...S EDIL ID=$P(INFO ,"^",6)          ;JEH  2/1/11 DE V007820
  28731   "RTN","CHM FAUT7",180 ,0)
  28732    ...S CHG= $P(INFO,"^ ",8)
  28733   "RTN","CHM FAUT7",181 ,0)
  28734    ...S PDX= $P(INFO,"^ ",7) S:PDX ]"" CPTOUT =$$PDX^CHM FAUT0(PDX)  
  28735   "RTN","CHM FAUT7",182 ,0)
  28736    ...S CPTO UT="RX*"_$ E(CPTOUT,1 ,13)_"^"_$ P(CPTOUT," ^",2)_"^"_ $E(CPTOUT, 17,$L($P(C PTOUT,"^", 1)))
  28737   "RTN","CHM FAUT7",183 ,0)
  28738    ...S UNT= $P(INFO,"^ ",12)                   ;UNT IS  SAME AS QT Y FOR PHAR MACY
  28739   "RTN","CHM FAUT7",184 ,0)
  28740    ...S (OHI PDAMT,OHIP RESP,ADDOH IPY,OHIPRB AL,MEDICDP D,TPLPAID, COSTUNT)=" "   ;JEH 2 /1/11 DEV0 07820
  28741   "RTN","CHM FAUT7",185 ,0)
  28742    ...S (NMU NTALL,CALL DAMT,DEDCT AMT,CSTSHA MT,PYMNTAM T,PATPDAMT ,CCAPLAMT, ADISTRO)=" " ;JEH 2/1 /11 DEV007 820
  28743   "RTN","CHM FAUT7",186 ,0)
  28744    ...S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT
  28745   "RTN","CHM FAUT7",187 ,0)
  28746    ...S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y
  28747   "RTN","CHM FAUT7",188 ,0)
  28748    ...S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS
  28749   "RTN","CHM FAUT7",189 ,0)
  28750    ...S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE
  28751   "RTN","CHM FAUT7",190 ,0)
  28752    ...S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID
  28753   "RTN","CHM FAUT7",191 ,0)
  28754    ...S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D
  28755   "RTN","CHM FAUT7",192 ,0)
  28756    ...S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT
  28757   "RTN","CHM FAUT7",193 ,0)
  28758    ...S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED
  28759   "RTN","CHM FAUT7",194 ,0)
  28760    ...S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT
  28761   "RTN","CHM FAUT7",195 ,0)
  28762    ...S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT
  28763   "RTN","CHM FAUT7",196 ,0)
  28764    ...S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT
  28765   "RTN","CHM FAUT7",197 ,0)
  28766    ...S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT
  28767   "RTN","CHM FAUT7",198 ,0)
  28768    ...S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T
  28769   "RTN","CHM FAUT7",199 ,0)
  28770    ...S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT
  28771   "RTN","CHM FAUT7",200 ,0)
  28772    ...S ADIS TRO=$P(^CH MIMAGE(CHM FPDI1,0)," ^",16) ;AU TO DISTRIB UTION  JEH  2/1/11 DE V007820
  28773   "RTN","CHM FAUT7",201 ,0)
  28774    .. ;
  28775   "RTN","CHM FAUT7",202 ,0)
  28776    .. ; disa bled lines  re: FORL.   Changed  how L is s et.
  28777   "RTN","CHM FAUT7",203 ,0)
  28778    .. ; wtc  8/8/17
  28779   "RTN","CHM FAUT7",204 ,0)
  28780    .. ;
  28781   "RTN","CHM FAUT7",205 ,0)
  28782    ..;S FORL =L
  28783   "RTN","CHM FAUT7",206 ,0)
  28784    ..;S L=L+ SVL
  28785   "RTN","CHM FAUT7",207 ,0)
  28786    ..S L=L+1  D PREOUTL ^CHMFAUT1
  28787   "RTN","CHM FAUT7",208 ,0)
  28788    ..;S L=FO RL
  28789   "RTN","CHM FAUT7",209 ,0)
  28790    ..Q
  28791   "RTN","CHM FAUT7",210 ,0)
  28792    S FORL=L  ;  wtc 8/8 /17
  28793   "RTN","CHM FAUT7",211 ,0)
  28794    Q
  28795   "RTN","CHM FAUT7",212 ,0)
  28796    ;
  28797   "RTN","CHM FAUT7",213 ,0)
  28798   PREOUTL ;   Load Dent al procedu re into ^U TILITY
  28799   "RTN","CHM FAUT7",214 ,0)
  28800    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,0)=L
  28801   "RTN","CHM FAUT7",215 ,0)
  28802    I CHMFPDI 1=CHMOPDI  S $P(^UTIL ITY($J,"CH DME",SPBEN ,L,0),"^", 2)=1
  28803   "RTN","CHM FAUT7",216 ,0)
  28804    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,1)=DOSOUT
  28805   "RTN","CHM FAUT7",217 ,0)
  28806    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,2)=POSOUT
  28807   "RTN","CHM FAUT7",218 ,0)
  28808    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,3)=ICDOUT
  28809   "RTN","CHM FAUT7",219 ,0)
  28810    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,4)=REVOUT
  28811   "RTN","CHM FAUT7",220 ,0)
  28812    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,5)=CPTOUT
  28813   "RTN","CHM FAUT7",221 ,0)
  28814    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,6)=MODOUT
  28815   "RTN","CHM FAUT7",222 ,0)
  28816    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,8)=CHG
  28817   "RTN","CHM FAUT7",223 ,0)
  28818    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,7)=UNT
  28819   "RTN","CHM FAUT7",224 ,0)
  28820    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,9)=""  ;A EB 10/27/2 010 DEV007 820
  28821   "RTN","CHM FAUT7",225 ,0)
  28822    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,10)=OHIPD AMT   ;AEB  10/27/201 0 DEV00782 0 prim ohi  pd
  28823   "RTN","CHM FAUT7",226 ,0)
  28824    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,11)=OHIPR ESP   ;AEB  10/27/201 0 DEV00782 0 prim ohi  pr
  28825   "RTN","CHM FAUT7",227 ,0)
  28826    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,12)=ADDOH IPY   ;AEB  10/27/201 0 DEV00782 0 add ohi  pd
  28827   "RTN","CHM FAUT7",228 ,0)
  28828    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,13)=PATPD AMT   ;AEB  10/27/201 0 DEV00782 0 bene pd
  28829   "RTN","CHM FAUT7",229 ,0)
  28830    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,14)=MEDIC DPD   ;AEB  10/27/201 0 DEV00782 0 medicad
  28831   "RTN","CHM FAUT7",230 ,0)
  28832    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,15)=TPLPA ID    ;AEB  10/27/201 0 DEV00782 0 tpl
  28833   "RTN","CHM FAUT7",231 ,0)
  28834    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,16)=OHIPR BAL   ;JEH  2/1/2011  DEV007820  p/r bal
  28835   "RTN","CHM FAUT7",232 ,0)
  28836    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,17)=ADIST RO    ;JEH  2/1/2011  DEV007820  auto calc  flag
  28837   "RTN","CHM FAUT7",233 ,0)
  28838    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,18)=EDILI D     ;JEH  2/1/2011  DEV007820  edi line i dentifier
  28839   "RTN","CHM FAUT7",234 ,0)
  28840    I (ICDOUT ="")&(CPTO UT="")&(RE VOUT="") S  ^UTILITY( $J,"CHDME" ,SPBEN,L,2 )=""
  28841   "RTN","CHM FAUT7",235 ,0)
  28842    Q
  28843   "RTN","CHM FAUT7",236 ,0)
  28844   PREIPT ;
  28845   "RTN","CHM FAUT7",237 ,0)
  28846    D TPREIPT ^CHMFAUT8  Q  ;HM 8/1 7/2017 TES T cpe005-0 09 Inpatie nt
  28847   "RTN","CHM FAUT7",238 ,0)
  28848    N L,INFO, SPON,BEN,D OA,DOD,DOA 2,DSTAT,TC HG,ICD,POS ,BENPYMT,M EDPYMT
  28849   "RTN","CHM FAUT7",239 ,0)
  28850    N DOAOUT, DODOUT,ICD OUT,DSTATO UT,POSOUT, PRAMOUNT      ;SKD 9- 27-07 DEV0 03378
  28851   "RTN","CHM FAUT7",240 ,0)
  28852    N CHAOPD, CHPOPD,CHT PTY,CHPRPA Y,CHPRBL,E DILID            ;JEH  2/1/11 DE V007820
  28853   "RTN","CHM FAUT7",241 ,0)
  28854    K CHMFINP
  28855   "RTN","CHM FAUT7",242 ,0)
  28856    S L=""
  28857   "RTN","CHM FAUT7",243 ,0)
  28858    F  S L=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L)) Q:L=""   D
  28859   "RTN","CHM FAUT7",244 ,0)
  28860    .S (DOAOU T,DODOUT,P OSOUT,ICDO UT,DSTATOU T,DOA2OUT) =""
  28861   "RTN","CHM FAUT7",245 ,0)
  28862    .S INFO=$ G(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"INP-NS" ,L,0))
  28863   "RTN","CHM FAUT7",246 ,0)
  28864    .Q:INFO=" "
  28865   "RTN","CHM FAUT7",247 ,0)
  28866    .S SPON=$ P(INFO,"^" ,1),BEN=$P (INFO,"^", 2)
  28867   "RTN","CHM FAUT7",248 ,0)
  28868    .S DOA=$P (INFO,"^", 4) S Y=DOA  D DD^%DT  I Y'="" S  DOAOUT=Y_" ^"_DOA  ;A EB DEF0042 37
  28869   "RTN","CHM FAUT7",249 ,0)
  28870    .S DOD=$P (INFO,"^", 5) S Y=DOD  D DD^%DT  I Y'="" S  DODOUT=Y_" ^"_DOD
  28871   "RTN","CHM FAUT7",250 ,0)
  28872    .S DOA2=$ P(INFO,"^" ,16) S Y=D OA2 D DD^% DT I Y'=""  S DOA2OUT =Y_"^"_DOA 2
  28873   "RTN","CHM FAUT7",251 ,0)
  28874    .S DSTAT= $P(INFO,"^ ",6)
  28875   "RTN","CHM FAUT7",252 ,0)
  28876    .S:DSTAT] "" DSTATOU T=$$DSTAT^ CHMFAUT0(D STAT)
  28877   "RTN","CHM FAUT7",253 ,0)
  28878    .S TCHG=$ P(INFO,"^" ,10)
  28879   "RTN","CHM FAUT7",254 ,0)
  28880    .S ICD=$P (INFO,"^", 7)
  28881   "RTN","CHM FAUT7",255 ,0)
  28882    .S:ICD]""  ICD=$$ICD ^CHMFAUT0( ICD)
  28883   "RTN","CHM FAUT7",256 ,0)
  28884    .S ICDOUT =$P(ICD,"^ ")_"^"_$P( ICD,"^",3) _"^"_$P(IC D,"^",2)
  28885   "RTN","CHM FAUT7",257 ,0)
  28886    .S POS=$P (INFO,"^", 11) S:POS= "" POS=1
  28887   "RTN","CHM FAUT7",258 ,0)
  28888    .S:POS]""  POS=$$POS ^CHMFAUT0( POS)
  28889   "RTN","CHM FAUT7",259 ,0)
  28890    .S POSOUT =$P(POS,"^ ")_"^"_$P( POS,"^",3) _"^"_$P(PO S,"^",2)
  28891   "RTN","CHM FAUT7",260 ,0)
  28892    .S FAC=$P (INFO,"^", 14)
  28893   "RTN","CHM FAUT7",261 ,0)
  28894    .; 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
  28895   "RTN","CHM FAUT7",262 ,0)
  28896    .;S:FAC]" " FAC=$$FA C^CHMFAUT0 (FAC)
  28897   "RTN","CHM FAUT7",263 ,0)
  28898    .S FACOUT =$P(FAC,"^ ")_$P(FAC, "^",3)_$P( FAC,"^",2)
  28899   "RTN","CHM FAUT7",264 ,0)
  28900    .S MEDPYM T=$P(INFO, "^",19)
  28901   "RTN","CHM FAUT7",265 ,0)
  28902    .S CHTPTY =$P(INFO," ^",20)       ;THIRD P ARTY PAYME NT    ;JEH  2/1/11 DE V007820
  28903   "RTN","CHM FAUT7",266 ,0)
  28904    .S CHPOPD =$P(INFO," ^",21)       ;PRIMARY  OHI PAID                 ;JEH 2 /1/11 DEV0 07820
  28905   "RTN","CHM FAUT7",267 ,0)
  28906    .S CHAOPD =$P(INFO," ^",22)       ;ADD'L O HIs PAID                  ;JEH 2 /1/11 DEV0 07820
  28907   "RTN","CHM FAUT7",268 ,0)
  28908    .S CHPRPA Y=$P(INFO, "^",23)      ;P/R PAY  (OHI)                    ;JEH 2 /1/11 DEV0 07820
  28909   "RTN","CHM FAUT7",269 ,0)
  28910    .S CHPRBL =$P(INFO," ^",24)       ;P/R BAL LANCE(OHI)                ;JEH 2 /1/11 DEV0 07820
  28911   "RTN","CHM FAUT7",270 ,0)
  28912    .S BENPYM T=$P(INFO, "^",13)
  28913   "RTN","CHM FAUT7",271 ,0)
  28914    .S OHIPYM T=""
  28915   "RTN","CHM FAUT7",272 ,0)
  28916    .S PRAMOU NT=""   ;S KD 9-27-07  DEV003378
  28917   "RTN","CHM FAUT7",273 ,0)
  28918    .I VFN'=" ",DOA'="", $D(^CHMIMA GE(CHMFPDI ,"ZOHI",DF N,BFN,CHMF SERV,DOA,V FN)) D  ;J SG;3/14/08 ;DEV004525 -01
  28919   "RTN","CHM FAUT7",274 ,0)
  28920    ..;S OHIP YMT=^CHMIM AGE(CHMFPD I,"ZOHI",D FN,BFN,CHM FSERV,DOA, VFN)   ;SK D MC284 12 -15-06
  28921   "RTN","CHM FAUT7",275 ,0)
  28922    ..S PRAMO UNT=$P($G( ^CHMIMAGE( CHMFPDI,"Z OHI",DFN,B FN,CHMFSER V,DOA,VFN) ),U,2)     ;SKD MC284  12-15-06
  28923   "RTN","CHM FAUT7",276 ,0)
  28924    .E  S PRA MOUNT=CHPR PAY          ;JEH 2/1 /11 DEV007 820
  28925   "RTN","CHM FAUT7",277 ,0)
  28926    .D PREIPT L1
  28927   "RTN","CHM FAUT7",278 ,0)
  28928    .D PREIPT L2
  28929   "RTN","CHM FAUT7",279 ,0)
  28930    .D PREIPT L3
  28931   "RTN","CHM FAUT7",280 ,0)
  28932    .D PREIPT L4
  28933   "RTN","CHM FAUT7",281 ,0)
  28934    .Q
  28935   "RTN","CHM FAUT7",282 ,0)
  28936    ;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
  28937   "RTN","CHM FAUT7",283 ,0)
  28938    I '$G(CHM OPDI) S CH MOPDI=$P($ G(^CHMIMAG E(CHMFPDI, 202)),"^", 1) ;BDB 8/ 14/17
  28939   "RTN","CHM FAUT7",284 ,0)
  28940    S:$E($P($ G(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"VEN")), "^",7),3)= 5 L=$$LATE ^CHMFAUT5( CHMFPDI,$G (CHMOPDI), CHMFSRVC,$ G(SPBEN),L )
  28941   "RTN","CHM FAUT7",285 ,0)
  28942    Q
  28943   "RTN","CHM FAUT7",286 ,0)
  28944   PREIPTL1 ;  Load "INP ","MED", a nd "PAY" i nto CHMFIN P array
  28945   "RTN","CHM FAUT7",287 ,0)
  28946    S CHMFINP (SPON,BEN, "INP",1)=D OAOUT
  28947   "RTN","CHM FAUT7",288 ,0)
  28948    S CHMFADD A=$P(DOAOU T,"^",2)
  28949   "RTN","CHM FAUT7",289 ,0)
  28950    S CHMFINP (SPON,BEN, "INP",2)=D ODOUT
  28951   "RTN","CHM FAUT7",290 ,0)
  28952    S CHMFDSD T=$P(DODOU T,"^",2)
  28953   "RTN","CHM FAUT7",291 ,0)
  28954    S CHMFINP (SPON,BEN, "INP",3)=D STATOUT
  28955   "RTN","CHM FAUT7",292 ,0)
  28956    S CHMFINP (SPON,BEN, "INP",4)=P OSOUT
  28957   "RTN","CHM FAUT7",293 ,0)
  28958    S CHMFINP (SPON,BEN, "INP",5)=I CDOUT
  28959   "RTN","CHM FAUT7",294 ,0)
  28960    S CHMFINP (SPON,BEN, "INP",6)=T CHG
  28961   "RTN","CHM FAUT7",295 ,0)
  28962    S CHMFINP (SPON,BEN, "INP",7)=" "
  28963   "RTN","CHM FAUT7",296 ,0)
  28964    S CHMFINP (SPON,BEN, "INP",8)=" "
  28965   "RTN","CHM FAUT7",297 ,0)
  28966    S CHMFINP (SPON,BEN, "INP",9)=" "
  28967   "RTN","CHM FAUT7",298 ,0)
  28968    S CHMFINP (SPON,BEN, "INP",10)= ""
  28969   "RTN","CHM FAUT7",299 ,0)
  28970    S CHMFINP (SPON,BEN, "INP",11)= DOA2OUT
  28971   "RTN","CHM FAUT7",300 ,0)
  28972    S CHMFINP (SPON,BEN, "MED")=MED PYMT
  28973   "RTN","CHM FAUT7",301 ,0)
  28974    S CHMFINP (SPON,BEN, "PAY")=BEN PYMT
  28975   "RTN","CHM FAUT7",302 ,0)
  28976    S CHMFINP (SPON,BEN, "TPTY")=CH TPTY               ;J EH 2/1/11  DEV007820
  28977   "RTN","CHM FAUT7",303 ,0)
  28978    S CHMFINP (SPON,BEN, "POPD")=CH POPD               ;J EH 2/1/11  DEV007820
  28979   "RTN","CHM FAUT7",304 ,0)
  28980    S CHMFINP (SPON,BEN, "AOPD")=CH AOPD               ;J EH 2/1/11  DEV007820
  28981   "RTN","CHM FAUT7",305 ,0)
  28982    S CHMFINP (SPON,BEN, "PRPY")=CH PRPAY              ;J EH 2/1/11  DEV007820
  28983   "RTN","CHM FAUT7",306 ,0)
  28984    S CHMFINP (SPON,BEN, "PRBL")=CH PRBL               ;J EH 2/1/11  DEV007820
  28985   "RTN","CHM FAUT7",307 ,0)
  28986    ;S CHMFIN P(SPON,BEN ,"OHI")=OH IPYMT  ;SK D MC284 12 -15-06
  28987   "RTN","CHM FAUT7",308 ,0)
  28988    S CHMFINP (SPON,BEN, "OHI")=""   ;SKD MC28 4 12-15-06
  28989   "RTN","CHM FAUT7",309 ,0)
  28990    I $G(PRAM OUNT) S CH MFINP(SPON ,BEN,"OHI" )=PRAMOUNT   ;SKD MC2 84 12-15-0 6
  28991   "RTN","CHM FAUT7",310 ,0)
  28992    Q
  28993   "RTN","CHM FAUT7",311 ,0)
  28994   PREIPTL2 ; Loads "ICD " into CHM FINP array
  28995   "RTN","CHM FAUT7",312 ,0)
  28996    N M,ICD,I CDOUT S M= ""
  28997   "RTN","CHM FAUT7",313 ,0)
  28998    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,100,M))  Q:M=""  D
  28999   "RTN","CHM FAUT7",314 ,0)
  29000    .S ICD=$P (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,100,M,0) ,"^",1)
  29001   "RTN","CHM FAUT7",315 ,0)
  29002    .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
  29003   "RTN","CHM FAUT7",316 ,0)
  29004    .S:ICD]""  ICD=$$ICD ^CHMFAUT0( ICD)
  29005   "RTN","CHM FAUT7",317 ,0)
  29006    .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
  29007   "RTN","CHM FAUT7",318 ,0)
  29008    .S ICDOUT =$P(ICD,"^ ")_"^"_$P( ICD,"^",3) _"^"_$P(IC D,"^",2)_" ^^"_CHPOA   ;AEB 1/20 /2010 DEV0 04805
  29009   "RTN","CHM FAUT7",319 ,0)
  29010    .S CHMFIN P(SPON,BEN ,"ICD",M)= ICDOUT
  29011   "RTN","CHM FAUT7",320 ,0)
  29012    .S CHMFIN P(SPON,BEN ,"INP",7)= "Y"
  29013   "RTN","CHM FAUT7",321 ,0)
  29014    .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
  29015   "RTN","CHM FAUT7",322 ,0)
  29016    .Q
  29017   "RTN","CHM FAUT7",323 ,0)
  29018    Q
  29019   "RTN","CHM FAUT7",324 ,0)
  29020   PREIPTL3 ; Loads "PRO C" into CH MFINP arra y
  29021   "RTN","CHM FAUT7",325 ,0)
  29022    N M,CPT,C PTOUT S M= ""
  29023   "RTN","CHM FAUT7",326 ,0)
  29024    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,101,M))  Q:M=""  D
  29025   "RTN","CHM FAUT7",327 ,0)
  29026    .S CPT=^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"I NP-NS",L,1 01,M,0)
  29027   "RTN","CHM FAUT7",328 ,0)
  29028    .S:CPT]""  CPT=$$PRO C^CHMFAUT0 (CPT,DOA)
  29029   "RTN","CHM FAUT7",329 ,0)
  29030    .S CPTOUT =$P(CPT,"^ ")_"^"_$P( CPT,"^",3) _"^"_$P(CP T,"^",2)
  29031   "RTN","CHM FAUT7",330 ,0)
  29032    .S CHMFIN P(SPON,BEN ,"PROC",M) =CPTOUT
  29033   "RTN","CHM FAUT7",331 ,0)
  29034    .S CHMFIN P(SPON,BEN ,"INP",8)= "Y"
  29035   "RTN","CHM FAUT7",332 ,0)
  29036    .Q
  29037   "RTN","CHM FAUT7",333 ,0)
  29038    Q
  29039   "RTN","CHM FAUT7",334 ,0)
  29040   PREIPTL4 ; Loads "REV " into CHM FINP array
  29041   "RTN","CHM FAUT7",335 ,0)
  29042    N N,REV,R EVOUT,EDIL ID S M="", EDILID=""   ;JEH 2/1/ 11 DEV0078 20
  29043   "RTN","CHM FAUT7",336 ,0)
  29044    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,102,M))  Q:M=""  D
  29045   "RTN","CHM FAUT7",337 ,0)
  29046    .S REV=^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"I NP-NS",L,1 02,M,0)
  29047   "RTN","CHM FAUT7",338 ,0)
  29048    .S:REV]""  REV=$$REV ^CHMFAUT0( REV)
  29049   "RTN","CHM FAUT7",339 ,0)
  29050    .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
  29051   "RTN","CHM FAUT7",340 ,0)
  29052    .S REVOUT =$P(REV,"^ ")_"^"_$P( REV,"^",6) _"^"_$P(RE V,"^",2)_" ^^"_$P(REV ,"^",3)_"^ "_EDILID   ;JEH 2/1/1 1 DEV00782 0
  29053   "RTN","CHM FAUT7",341 ,0)
  29054    .S CHMFIN P(SPON,BEN ,"REV",M)= REVOUT
  29055   "RTN","CHM FAUT7",342 ,0)
  29056    .S CHMFIN P(SPON,BEN ,"INP",10) ="Y"
  29057   "RTN","CHM FAUT7",343 ,0)
  29058    .Q
  29059   "RTN","CHM FAUT7",344 ,0)
  29060    Q
  29061   "RTN","CHM FAUT7",345 ,0)
  29062   PREDME ;   Load DME p rocedures
  29063   "RTN","CHM FAUT7",346 ,0)
  29064    N L,INFO, DOS,POS,CH G,ICD,CPT, MEDPYMT,BE NPYMT,DELC HG,PL,SPBE N,SVL
  29065   "RTN","CHM FAUT7",347 ,0)
  29066    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
  29067   "RTN","CHM FAUT7",348 ,0)
  29068    N D3,DMED OS ; wtc 7 /26/17
  29069   "RTN","CHM FAUT7",349 ,0)
  29070    K ^UTILIT Y($J),^TMP ($J) ; wtc  7/27/17
  29071   "RTN","CHM FAUT7",350 ,0)
  29072    S (D3,DME DOS,SVL)=" ",L=0 ; wt c 7/26/17
  29073   "RTN","CHM FAUT7",351 ,0)
  29074    ;
  29075   "RTN","CHM FAUT7",352 ,0)
  29076    ;  wtc 7/ 27/17
  29077   "RTN","CHM FAUT7",353 ,0)
  29078    ;  
  29079   "RTN","CHM FAUT7",354 ,0)
  29080    ;  "B" cr oss-refere nce at "DM E-NS" mult iple is no t being cr eated when  image fil e is creat ed
  29081   "RTN","CHM FAUT7",355 ,0)
  29082    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  29083   "RTN","CHM FAUT7",356 ,0)
  29084    ;
  29085   "RTN","CHM FAUT7",357 ,0)
  29086    F  S D3=$ O(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"DME-NS" ,D3)) Q:D3 =""  D  ;  wtc 7/27/1 7
  29087   "RTN","CHM FAUT7",358 ,0)
  29088    . S DMEDO S=$P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"D ME-NS",D3, 0)),"^",1)  ;
  29089   "RTN","CHM FAUT7",359 ,0)
  29090    . S ^TMP( $J,CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"DME-NS ",DMEDOS,D 3)="" ;
  29091   "RTN","CHM FAUT7",360 ,0)
  29092    ;
  29093   "RTN","CHM FAUT7",361 ,0)
  29094    S DMEDOS= ""
  29095   "RTN","CHM FAUT7",362 ,0)
  29096    F  S DMED OS=$O(^TMP ($J,CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"DME-N S",DMEDOS) ) Q:DMEDOS =""  D  ;  wtc 7/27/1 7
  29097   "RTN","CHM FAUT7",363 ,0)
  29098    . F  S D3 =$O(^TMP($ J,CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"DME-NS" ,DMEDOS,D3 )) Q:D3=""   D  ; wtc  7/26/17
  29099   "RTN","CHM FAUT7",364 ,0)
  29100    .. ;  All  lines bel ow indente d - wtc 7/ 26/17
  29101   "RTN","CHM FAUT7",365 ,0)
  29102    ..S (PLOU T,DOSOUT,P OSOUT,ICDO UT,REVOUT, MODOUT,CPT OUT,EDILID )=""  ;JEH  2/1/11 DE V007820
  29103   "RTN","CHM FAUT7",366 ,0)
  29104    ..S INFO= $G(^CHMIMA GE(CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"DME-NS ",D3,0)) ;  wtc 7/26/ 17
  29105   "RTN","CHM FAUT7",367 ,0)
  29106    ..;Q:INFO =""
  29107   "RTN","CHM FAUT7",368 ,0)
  29108    ..S INFO2 =$G(^CHMIM AGE(CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"DME-N S",D3,1,1, 0))  ;JEH  2/1/11 DEV 007820
  29109   "RTN","CHM FAUT7",369 ,0)
  29110    ..Q:INFO= ""&(INFO2= "")    ;JE H 2/1/11 D EV007820
  29111   "RTN","CHM FAUT7",370 ,0)
  29112    ..S SPBEN =$P(INFO," ^",2)_"/"_ $P(INFO,"^ ",3)
  29113   "RTN","CHM FAUT7",371 ,0)
  29114    ..S DOS=$ P(INFO,"^" ,1) S:DOS] "" DOSOUT= $$DOS^CHMF AUT0(DOS)
  29115   "RTN","CHM FAUT7",372 ,0)
  29116    ..S CHG=$ P(INFO,"^" ,8)
  29117   "RTN","CHM FAUT7",373 ,0)
  29118    ..S ICD=$ P(INFO,"^" ,10) S:ICD ]"" ICDOUT =$$ICD^CHM FAUT0(ICD)
  29119   "RTN","CHM FAUT7",374 ,0)
  29120    ..S DELCH G=$P(INFO, "^",6)
  29121   "RTN","CHM FAUT7",375 ,0)
  29122    ..S PL=$P (INFO,"^", 9)
  29123   "RTN","CHM FAUT7",376 ,0)
  29124    ..S:PL="P " PLOUT="P urch."
  29125   "RTN","CHM FAUT7",377 ,0)
  29126    ..S:PL="L " PLOUT="L ease"
  29127   "RTN","CHM FAUT7",378 ,0)
  29128    ..S CPT=$ P(INFO,"^" ,7) S:CPT] "" CPTOUT= $$PROC^CHM FAUT0(CPT, DOS)
  29129   "RTN","CHM FAUT7",379 ,0)
  29130    ..S UNT=$ P(INFO,"^" ,12)
  29131   "RTN","CHM FAUT7",380 ,0)
  29132    ..S REV=$ P(INFO,"^" ,13) S:REV ]"" REVOUT =$$REV^CHM FAUT0(REV)
  29133   "RTN","CHM FAUT7",381 ,0)
  29134    ..S EDILI D=$P(INFO, "^",14)  ; JEH 2/1/11  DEV007820
  29135   "RTN","CHM FAUT7",382 ,0)
  29136    ..S MEDPY MT=$P(INFO ,"^",11)
  29137   "RTN","CHM FAUT7",383 ,0)
  29138    ..S BENPY MT=$P(INFO ,"^",5)
  29139   "RTN","CHM FAUT7",384 ,0)
  29140    ..S W=$P( INFO,"^",5 )
  29141   "RTN","CHM FAUT7",385 ,0)
  29142    ..S MOD=$ P(INFO,"^" ,17) I MOD ]"" S MODO UT=$$MOD^C HMFAUT0(MO D),MOD=$P( MODOUT,"^" ,1)                                          ;JEH 2/1/ 11 DEV0078 20
  29143   "RTN","CHM FAUT7",386 ,0)
  29144    ..S MOD2= $P(INFO,"^ ",18) I MO D2]"" S MO DOUT=MODOU T_"*"_$$MO D^CHMFAUT0 (MOD2),MOD 2=$P($P(MO DOUT,"*",2 ),"^",1)      ;JEH 2/ 1/11 DEV00 7820
  29145   "RTN","CHM FAUT7",387 ,0)
  29146    ..S MOD3= $P(INFO,"^ ",19) S:MO D3]"" MODO UT=MODOUT_ "*"_$$MOD^ CHMFAUT0(M OD3),MOD3= $P($P(MODO UT,"*",3), "^",1)                 ;JEH 2/1/ 11 DEV0078 20
  29147   "RTN","CHM FAUT7",388 ,0)
  29148    ..S MOD4= $P(INFO,"^ ",20) S:MO D4]"" MODO UT=MODOUT_ "*"_$$MOD^ CHMFAUT0(M OD4),MOD4= $P($P(MODO UT,"*",4), "^",1)                 ;JEH 2/1/ 11 DEV0078 20
  29149   "RTN","CHM FAUT7",389 ,0)
  29150    ..S MODOU T=MOD_MOD2 _MOD3_MOD4 _"*"_MODOU T        ; JEH 2/1/11  DEV007820
  29151   "RTN","CHM FAUT7",390 ,0)
  29152    ..S:$P(MO DOUT,"*",1 )="" MODOU T=""        ;JEH 2/1/ 11 DEV0078 20
  29153   "RTN","CHM FAUT7",391 ,0)
  29154    ..D:$G(%) ="" NOW^%D TC  ;JEH 8 /29/08 TT  #DEV005596   ADDED LI NE
  29155   "RTN","CHM FAUT7",392 ,0)
  29156    ..S CPT=$ P(INFO,"^" ,7) S:CPT] "" CPTOUT= "SV*"_$$PR OC^CHMFAUT 0(CPT,$S(D OS]"":DOS, 1:%\1)) ;J SG;NC;Fake  DOS to ge t Procedur e
  29157   "RTN","CHM FAUT7",393 ,0)
  29158    ..S (OHIP DAMT,OHIPR ESP,ADDOHI PY,OHIPRBA L,MEDICDPD ,TPLPAID,C OSTUNT,NMU NTALL,CALL DAMT,DEDCT AMT,CSTSHA MT,PYMNTAM T,PATPDAMT ,CCAPLAMT) ="" ;JEH 2 /1/11 DEV0 07820
  29159   "RTN","CHM FAUT7",394 ,0)
  29160    ..S OHIPD AMT=$P(INF O2,"^",1)     ;OHI PA ID AMT                                       JEH 2/1/1 1 DEV00782 0
  29161   "RTN","CHM FAUT7",395 ,0)
  29162    ..S OHIPR ESP=$P(INF O2,"^",2)     ;OHI PA TIENT RESP ONSIBILITY               JEH 2/1 /11 DEV007 820
  29163   "RTN","CHM FAUT7",396 ,0)
  29164    ..S ADDOH IPY=$P(INF O2,"^",3)     ;ALL AD DITIONAL O HI PAYMENT S    JEH 2 /1/11 DEV0 07820
  29165   "RTN","CHM FAUT7",397 ,0)
  29166    ..S OHIPR BAL=$P(INF O2,"^",4)     ;OHI PR  BALANCE                                     JEH 2/1/1 1 DEV00782 0
  29167   "RTN","CHM FAUT7",398 ,0)
  29168    ..S MEDIC DPD=$P(INF O2,"^",5)     ;MEDICA D PAID                                       JEH 2/1/1 1 DEV00782 0
  29169   "RTN","CHM FAUT7",399 ,0)
  29170    ..S TPLPA ID=$P(INFO 2,"^",6)               ;TPL PAID                                                    JEH  2/1/11 DE V007820
  29171   "RTN","CHM FAUT7",400 ,0)
  29172    ..S COSTU NT=$P(INFO 2,"^",7)               ;COST/UNI T                                                  JEH  2/1/11 DE V007820
  29173   "RTN","CHM FAUT7",401 ,0)
  29174    ..S NMUNT ALL=$P(INF O2,"^",8)     ;# UNIT S ALLOWED                                    JEH 2/1/1 1 DEV00782 0
  29175   "RTN","CHM FAUT7",402 ,0)
  29176    ..S CALLD AMT=$P(INF O2,"^",9)     ;CALCUL ATED ALLOW ED AMOUNT                JEH 2/1 /11 DEV007 820
  29177   "RTN","CHM FAUT7",403 ,0)
  29178    ..S DEDCT AMT=$P(INF O2,"^",10)    ;DEDUCT IBLE AMOUN T                                 JEH 2/1/1 1 DEV00782 0
  29179   "RTN","CHM FAUT7",404 ,0)
  29180    ..S CSTSH AMT=$P(INF O2,"^",11)    ;COST S HARE AMT                                     JEH 2/1/1 1 DEV00782 0
  29181   "RTN","CHM FAUT7",405 ,0)
  29182    ..S PYMNT AMT=$P(INF O2,"^",12)    ;PAYMEN T AMOUNT                                     JEH 2/1/1 1 DEV00782 0
  29183   "RTN","CHM FAUT7",406 ,0)
  29184    ..S PATPD AMT=$P(INF O2,"^",13)    ;PATIEN T PAID AMT                                   JEH 2/1/1 1 DEV00782 0
  29185   "RTN","CHM FAUT7",407 ,0)
  29186    ..S CCAPL AMT=$P(INF O2,"^",14)    ;CAT CA P APPLIED  AMT                      JEH 2/1 /11 DEV007 820
  29187   "RTN","CHM FAUT7",408 ,0)
  29188    ..S ADIST RO=$P(^CHM IMAGE(CHMF PDI,0),"^" ,16) ;AUTO  DISTRIBUT ION  JEH 2 /1/11 DEV0 07820
  29189   "RTN","CHM FAUT7",409 ,0)
  29190    ..I DOS'= "" D                                                        ;JSG; 3/14/08;DE V004525-01
  29191   "RTN","CHM FAUT7",410 ,0)
  29192    ...S:'$D( CHHOLDPY(D OS)) CHHOL DPY(DOS)=" "                          ;JSG; Add dot
  29193   "RTN","CHM FAUT7",411 ,0)
  29194    ...I MEDP YMT'="" D                                                   ;JSG; Add dot
  29195   "RTN","CHM FAUT7",412 ,0)
  29196    ....S $P( CHHOLDPY(D OS),"^",1) =$FN(($P(C HHOLDPY(DO S),"^",1)+ MEDPYMT)," ",2) ;JSG; Add dot
  29197   "RTN","CHM FAUT7",413 ,0)
  29198    ...I BENP YMT'="" D                                                   ;JSG; Add dot     JEH 2/1/1 1 DEV00782 0 COMMNTD  OFF I BENP YMT
  29199   "RTN","CHM FAUT7",414 ,0)
  29200    ....S $P( CHHOLDPY(D OS),"^",2) =$FN(($P(C HHOLDPY(DO S),"^",2)+ BENPYMT)," ",2) ;JSG; Add dot
  29201   "RTN","CHM FAUT7",415 ,0)
  29202    ...S PRAM OUNT=""     ;SKD 9-27 -07 DEV003 378                                   ;JSG; Add dot
  29203   "RTN","CHM FAUT7",416 ,0)
  29204    ...I $P(C HHOLDPY(DO S),"^",3)= "" I VFN'= "" I $D(^C HMIMAGE(CH MFPDI,"ZOH I",DFN,BFN ,CHMFSERV, DOS,VFN))  D  ;JSG;Ad d dot
  29205   "RTN","CHM FAUT7",417 ,0)
  29206    ....;S OH IPYMT=^CHM IMAGE(CHMF PDI,"ZOHI" ,DFN,BFN,C HMFSERV,DO S,VFN)  ;s kd MC284 1 2-15-06
  29207   "RTN","CHM FAUT7",418 ,0)
  29208    ....S PRA MOUNT=$P($ G(^CHMIMAG E(CHMFPDI, "ZOHI",DFN ,BFN,CHMFS ERV,DOS,VF N)),U,2)   ;skd MC284  12-15-06; JSG;Add do t
  29209   "RTN","CHM FAUT7",419 ,0)
  29210    ....;S $P (CHHOLDPY( DOS),"^",3 )=$FN(OHIP YMT,"",2)    ;skd MC2 84 12-15-0 6
  29211   "RTN","CHM FAUT7",420 ,0)
  29212    ....I $G( PRAMOUNT)  S $P(CHHOL DPY(DOS)," ^",3)=$FN( PRAMOUNT," ",2)  ;skd  MC284 12- 15-06;JSG; Add dot
  29213   "RTN","CHM FAUT7",421 ,0)
  29214    ...I TPLP AID'="" I  TPLPAID D
  29215   "RTN","CHM FAUT7",422 ,0)
  29216    ....S $P( CHHOLDPY(D OS),"^",4) =$P(CHHOLD PY(DOS),"^ ",4)+TPLPA ID
  29217   "RTN","CHM FAUT7",423 ,0)
  29218    ..S L=L+1  D PREOUTL  ;JEH 2/1/ 11 DEV0078 20 ; wtc 7 /26/17
  29219   "RTN","CHM FAUT7",424 ,0)
  29220    ..;D PRED MEL    ;JE H 2/1/11 D EV007820
  29221   "RTN","CHM FAUT7",425 ,0)
  29222    ..S SVL=L
  29223   "RTN","CHM FAUT7",426 ,0)
  29224    ..Q
  29225   "RTN","CHM FAUT7",427 ,0)
  29226    ;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
  29227   "RTN","CHM FAUT7",428 ,0)
  29228    I '$G(CHM OPDI) S CH MOPDI=$P($ G(^CHMIMAG E(CHMFPDI, 202)),"^", 1) ;BDB 8/ 14/17
  29229   "RTN","CHM FAUT7",429 ,0)
  29230    S:$E($P($ G(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"VEN")), "^",7),3)= 5 L=$$LATE ^CHMFAUT5( CHMFPDI,$G (CHMOPDI), CHMFSRVC,$ G(SPBEN),S VL)
  29231   "RTN","CHM FAUT7",430 ,0)
  29232    K ^TMP($J ) ; wtc 7/ 27/17
  29233   "RTN","CHM FAUT7",431 ,0)
  29234    Q
  29235   "RTN","CHM FAUT7",432 ,0)
  29236   PREDMEL ;   DME load  into ^UTIL ITY and CH MDME array     ; ;JEH  2/1/11 DE V007820 -  NOT USED A FTER SLLA
  29237   "RTN","CHM FAUT7",433 ,0)
  29238    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,0)=L
  29239   "RTN","CHM FAUT7",434 ,0)
  29240    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,1)=DOSOUT
  29241   "RTN","CHM FAUT7",435 ,0)
  29242    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,2)=ICDOUT
  29243   "RTN","CHM FAUT7",436 ,0)
  29244    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,3)=REVOUT
  29245   "RTN","CHM FAUT7",437 ,0)
  29246    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,4)=CPTOUT
  29247   "RTN","CHM FAUT7",438 ,0)
  29248    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,5)=UNT
  29249   "RTN","CHM FAUT7",439 ,0)
  29250    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,6)=CHG
  29251   "RTN","CHM FAUT7",440 ,0)
  29252    S ^UTILIT Y($J,"CHDM E",SPBEN,L ,7)=PLOUT
  29253   "RTN","CHM FAUT7",441 ,0)
  29254    Q
  29255   "RTN","CHM FAUT7",442 ,0)
  29256   PRETRV ;
  29257   "RTN","CHM FAUT7",443 ,0)
  29258    ;.D PREOU TL ;JEH 2/ 1/11 DEV00 7820
  29259   "RTN","CHM FAUT7",444 ,0)
  29260    D PREOUT  Q
  29261   "RTN","CHM FAUT7",445 ,0)
  29262    ;
  29263   "RTN","CHM FAUT7",446 ,0)
  29264   PREDNT ;De ntal prelo ad
  29265   "RTN","CHM FAUT7",447 ,0)
  29266    N L,INFO, DOS,POS,CH G,ICD,MOD, CPT,MEDPYM T,BENPYMT, SPBEN,SVL
  29267   "RTN","CHM FAUT7",448 ,0)
  29268    N DOSOUT, POSOUT,ICD OUT,MODOUT ,CPTOUT,PR AMOUNT,EDI LID   ;SKD  9-27-07 D EV003378   ;JEH 2/1/1 1 DEV00782 0
  29269   "RTN","CHM FAUT7",449 ,0)
  29270    N DNTDOS, D3
  29271   "RTN","CHM FAUT7",450 ,0)
  29272    K ^UTILIT Y($J),^TMP ($J)
  29273   "RTN","CHM FAUT7",451 ,0)
  29274    S (D3,DNT DOS,SVL,L) =0
  29275   "RTN","CHM FAUT7",452 ,0)
  29276    ;  
  29277   "RTN","CHM FAUT7",453 ,0)
  29278    ;  kml -  8/7/17  us er story 0 05-049
  29279   "RTN","CHM FAUT7",454 ,0)
  29280    ; "B" cro ss-referen ce at "DEN TAL-NS" mu ltiple is  not being  created wh en image f ile is cre ated
  29281   "RTN","CHM FAUT7",455 ,0)
  29282    ;  so nee d to sort  service li nes by dat e of servi ce and sto re in temp orary glob al
  29283   "RTN","CHM FAUT7",456 ,0)
  29284    ;
  29285   "RTN","CHM FAUT7",457 ,0)
  29286    F  S D3=$ O(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"DENTAL- NS",D3)) Q :D3=""  D
  29287   "RTN","CHM FAUT7",458 ,0)
  29288    . S DNTDO S=$P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"D ENTAL-NS", D3,0)),"^" ,1)
  29289   "RTN","CHM FAUT7",459 ,0)
  29290    . S ^TMP( $J,CHMFPDI ,1,CHMFPGN M,2,CHMFIM AG,"DENTAL -NS",DNTDO S,D3)=""
  29291   "RTN","CHM FAUT7",460 ,0)
  29292    ;
  29293   "RTN","CHM FAUT7",461 ,0)
  29294    S DNTDOS= 0 F  S DNT DOS=$O(^TM P($J,CHMFP DI,1,CHMFP GNM,2,CHMF IMAG,"DENT AL-NS",DNT DOS)) Q:DN TDOS=""  D
  29295   "RTN","CHM FAUT7",462 ,0)
  29296    . F  S D3 =$O(^TMP($ J,CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"DENTAL- NS",DNTDOS ,D3)) Q:D3 =""  D
  29297   "RTN","CHM FAUT7",463 ,0)
  29298    .. S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT,E DILID)=""   ;JEH 2/1/ 11 DEV0078 20
  29299   "RTN","CHM FAUT7",464 ,0)
  29300    .. S INFO =$G(^CHMIM AGE(CHMFPD I,1,CHMFPG NM,2,CHMFI MAG,"DENTA L-NS",D3,0 ))  ;kml 8 /8/17
  29301   "RTN","CHM FAUT7",465 ,0)
  29302    .. S INFO 2=$G(^CHMI MAGE(CHMFP DI,1,CHMFP GNM,2,CHMF IMAG,"DENT AL-NS",D3, 1,1,0))  ; kml 8/8/17
  29303   "RTN","CHM FAUT7",466 ,0)
  29304    .. Q:INFO =""&(INFO2 ="")    ;J EH 2/1/11  DEV007820
  29305   "RTN","CHM FAUT7",467 ,0)
  29306    .. S SPBE N=$P(INFO, "^",2)_"/" _$P(INFO," ^",3)
  29307   "RTN","CHM FAUT7",468 ,0)
  29308    .. S DOS= $P(INFO,"^ ",1) S:DOS ]"" DOSOUT =$$DOS^CHM FAUT0(DOS)
  29309   "RTN","CHM FAUT7",469 ,0)
  29310    .. S POS= $P(INFO,"^ ",11) S:PO S]"" POSOU T=$$POS^CH MFAUT0(POS )
  29311   "RTN","CHM FAUT7",470 ,0)
  29312    .. S CHG= $P(INFO,"^ ",7)
  29313   "RTN","CHM FAUT7",471 ,0)
  29314    .. S ICD= $P(INFO,"^ ",10) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  29315   "RTN","CHM FAUT7",472 ,0)
  29316    .. S MOD= $P(INFO,"^ ",8) I MOD ]"" S MODO UT=$$MOD^C HMFAUT0(MO D),MOD=$P( MODOUT,"^" ,1)                                           ;JEH 2/1 /11 DEV007 820
  29317   "RTN","CHM FAUT7",473 ,0)
  29318    .. 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 DEV0 07820
  29319   "RTN","CHM FAUT7",474 ,0)
  29320    .. 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 DEV007 820
  29321   "RTN","CHM FAUT7",475 ,0)
  29322    .. 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 DEV007 820
  29323   "RTN","CHM FAUT7",476 ,0)
  29324    .. S MODO UT=MOD_MOD 2_MOD3_MOD 4_"*"_MODO UT         ;JEH 2/1/1 1 DEV00782 0
  29325   "RTN","CHM FAUT7",477 ,0)
  29326    .. S:$P(M ODOUT,"*", 1)="" MODO UT=""        ;JEH 2/1 /11 DEV007 820
  29327   "RTN","CHM FAUT7",478 ,0)
  29328    .. S CPT= $P(INFO,"^ ",6) S:CPT ]"" CPTOUT ="SV*"_$$P ROC^CHMFAU T0(CPT,DOS )   ;JEH 2 /1/11 DEV0 07820
  29329   "RTN","CHM FAUT7",479 ,0)
  29330    .. S EDIL ID=$P(INFO ,"^",15)   ;JEH 2/1/1 1 DEV00782 0
  29331   "RTN","CHM FAUT7",480 ,0)
  29332    .. S UNT= $P(INFO,"^ ",12)          ;JEH 2 /1/11 DEV0 07820
  29333   "RTN","CHM FAUT7",481 ,0)
  29334    .. S REV= $P(INFO,"^ ",16) S:RE V]"" REVOU T=$$REV^CH MFAUT0(REV )              ;JEH 2 /1/11 DEV0 07820
  29335   "RTN","CHM FAUT7",482 ,0)
  29336    .. S MEDP YMT=$P(INF O,"^",13)
  29337   "RTN","CHM FAUT7",483 ,0)
  29338    .. S BENP YMT=$P(INF O,"^",5)
  29339   "RTN","CHM FAUT7",484 ,0)
  29340    .. I DOS' ="" D                                        ;JSG;3/14 /08;DEV004 525-01
  29341   "RTN","CHM FAUT7",485 ,0)
  29342    ... S:'$D (CHHOLDPY( DOS,POS))  CHHOLDPY(D OS,POS)=""  ;JSG;Add  dot
  29343   "RTN","CHM FAUT7",486 ,0)
  29344    ... I MED PYMT'="" D                                   ;JSG;Add  dot
  29345   "RTN","CHM FAUT7",487 ,0)
  29346    .... 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)
  29347   "RTN","CHM FAUT7",488 ,0)
  29348    ... I BEN PYMT'="" I  BENPYMT D                        ;JSG;Add  dot
  29349   "RTN","CHM FAUT7",489 ,0)
  29350    .... S $P (CHHOLDPY( DOS,POS)," ^",2)=$FN( ($P(CHHOLD PY(DOS,POS ),"^",2)+B ENPYMT),"" ,2) ;JSG;A dd dot
  29351   "RTN","CHM FAUT7",490 ,0)
  29352    .... S PR AMOUNT=""     ;SKD 9- 27-07 DEV0 03378        ;JSG;Add  dot
  29353   "RTN","CHM FAUT7",491 ,0)
  29354    ... 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
  29355   "RTN","CHM FAUT7",492 ,0)
  29356    .... 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
  29357   "RTN","CHM FAUT7",493 ,0)
  29358    .... 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
  29359   "RTN","CHM FAUT7",494 ,0)
  29360    .. S (OHI PDAMT,OHIP RESP,ADDOH IPY,OHIPRB AL,MEDICDP D,TPLPAID, COSTUNT)=" "   ;JEH 2 /1/11 DEV0 07820
  29361   "RTN","CHM FAUT7",495 ,0)
  29362    .. S (NMU NTALL,CALL DAMT,DEDCT AMT,CSTSHA MT,PYMNTAM T,PATPDAMT ,CCAPLAMT, ADISTRO)=" " ;JEH 2/1 /11 DEV007 820
  29363   "RTN","CHM FAUT7",496 ,0)
  29364    .. S OHIP DAMT=$P(IN FO2,"^",1)     ;OHI P AID AMT
  29365   "RTN","CHM FAUT7",497 ,0)
  29366    .. S OHIP RESP=$P(IN FO2,"^",2)     ;OHI P ATIENT RES PONSIBILIT Y
  29367   "RTN","CHM FAUT7",498 ,0)
  29368    .. S ADDO HIPY=$P(IN FO2,"^",3)     ;ALL A DDITIONAL  OHI PAYMEN TS
  29369   "RTN","CHM FAUT7",499 ,0)
  29370    .. S OHIP RBAL=$P(IN FO2,"^",4)     ;OHI P R BALANCE
  29371   "RTN","CHM FAUT7",500 ,0)
  29372    .. S MEDI CDPD=$P(IN FO2,"^",5)     ;MEDIC AD PAID
  29373   "RTN","CHM FAUT7",501 ,0)
  29374    .. S TPLP AID=$P(INF O2,"^",6)               ;TPL PAI D
  29375   "RTN","CHM FAUT7",502 ,0)
  29376    .. S COST UNT=$P(INF O2,"^",7)               ;COST/UN IT
  29377   "RTN","CHM FAUT7",503 ,0)
  29378    .. S NMUN TALL=$P(IN FO2,"^",8)     ;# UNI TS ALLOWED
  29379   "RTN","CHM FAUT7",504 ,0)
  29380    .. S CALL DAMT=$P(IN FO2,"^",9)     ;CALCU LATED ALLO WED AMOUNT
  29381   "RTN","CHM FAUT7",505 ,0)
  29382    .. S DEDC TAMT=$P(IN FO2,"^",10 )   ;DEDUC TIBLE AMOU NT
  29383   "RTN","CHM FAUT7",506 ,0)
  29384    .. S CSTS HAMT=$P(IN FO2,"^",11 )   ;COST  SHARE AMT
  29385   "RTN","CHM FAUT7",507 ,0)
  29386    .. S PYMN TAMT=$P(IN FO2,"^",12 )   ;PAYME NT AMOUNT
  29387   "RTN","CHM FAUT7",508 ,0)
  29388    .. S PATP DAMT=$P(IN FO2,"^",13 )   ;PATIE NT PAID AM T
  29389   "RTN","CHM FAUT7",509 ,0)
  29390    .. S CCAP LAMT=$P(IN FO2,"^",14 )   ;CAT C AP APPLIED  AMT
  29391   "RTN","CHM FAUT7",510 ,0)
  29392    .. S ADIS TRO=$P(^CH MIMAGE(CHM FPDI,0),"^ ",16) ;AUT O DISTRIBU TION  JEH  2/1/11 DEV 007820
  29393   "RTN","CHM FAUT7",511 ,0)
  29394    .. S L=L+ 1 D PREOUT L     ;JEH  2/1/11 DE V007820
  29395   "RTN","CHM FAUT7",512 ,0)
  29396    .. S SVL= L
  29397   "RTN","CHM FAUT7",513 ,0)
  29398    ;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
  29399   "RTN","CHM FAUT7",514 ,0)
  29400    I '$G(CHM OPDI) S CH MOPDI=$P($ G(^CHMIMAG E(CHMFPDI, 202)),"^", 1) ;BDB 8/ 14/17
  29401   "RTN","CHM FAUT7",515 ,0)
  29402    S:$E($P($ G(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"VEN")), "^",7),3)= 5 L=$$LATE ^CHMFAUT5( CHMFPDI,$G (CHMOPDI), CHMFSRVC,$ G(SPBEN),S VL)
  29403   "RTN","CHM FAUT7",516 ,0)
  29404    Q
  29405   "RTN","CHM FAUT7",517 ,0)
  29406    ;
  29407   "RTN","CHM FAUT7",518 ,0)
  29408   PRERX ; Pr eload RX
  29409   "RTN","CHM FAUT7",519 ,0)
  29410    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
  29411   "RTN","CHM FAUT7",520 ,0)
  29412    N DOSOUT, CPTOUT,ICD OUT
  29413   "RTN","CHM FAUT7",521 ,0)
  29414    K CHEQP,C HPHARR
  29415   "RTN","CHM FAUT7",522 ,0)
  29416    S L=""
  29417   "RTN","CHM FAUT7",523 ,0)
  29418    F  S L=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"RX-NS",L )) Q:L=""   D
  29419   "RTN","CHM FAUT7",524 ,0)
  29420    .S (DOAOU T,DODOUT,P OSOUT,ICDO UT,DSTATOU T)=""
  29421   "RTN","CHM FAUT7",525 ,0)
  29422    .S INFO=$ G(^CHMIMAG E(CHMFPDI, 1,CHMFPGNM ,2,CHMFIMA G,"RX-NS", L,0))
  29423   "RTN","CHM FAUT7",526 ,0)
  29424    .Q:INFO=" "
  29425   "RTN","CHM FAUT7",527 ,0)
  29426    .S SPBEN= $P(INFO,"^ ",2)_"/"_$ P(INFO,"^" ,3)
  29427   "RTN","CHM FAUT7",528 ,0)
  29428    .S SPON=$ P(INFO,"^" ,2),BEN=$P (INFO,"^", 3)
  29429   "RTN","CHM FAUT7",529 ,0)
  29430    .S DOS=$P (INFO,"^", 1) S:DOS]" " DOSOUT=$ $DOS^CHMFA UT0(DOS)
  29431   "RTN","CHM FAUT7",530 ,0)
  29432    .S ICD=$P (INFO,"^", 11) S:ICD] "" ICDOUT= $$ICD^CHMF AUT0(ICD)
  29433   "RTN","CHM FAUT7",531 ,0)
  29434    .S:ICDOUT ]"" ICDOUT =$P(ICDOUT ,"^")_"^"_ $P(ICDOUT, "^",2)
  29435   "RTN","CHM FAUT7",532 ,0)
  29436    .S CHGAMT =$P(INFO," ^",8)
  29437   "RTN","CHM FAUT7",533 ,0)
  29438    .S PDX=$P (INFO,"^", 7) S:PDX]" " CPTOUT=$ $PDX^CHMFA UT0(PDX)
  29439   "RTN","CHM FAUT7",534 ,0)
  29440    .S QTY=$P (INFO,"^", 12)
  29441   "RTN","CHM FAUT7",535 ,0)
  29442    .S MEDPYM T=$P(INFO, "^",13)
  29443   "RTN","CHM FAUT7",536 ,0)
  29444    .S BENPYM T=$P(INFO, "^",5)
  29445   "RTN","CHM FAUT7",537 ,0)
  29446    .;S OHIPY MT=$P(INFO ,"^",9)        ;SKD M C284 12-15 -06
  29447   "RTN","CHM FAUT7",538 ,0)
  29448    .S PRAMOU NT=""                     ;SKD 9 -27-07 DEV 003378
  29449   "RTN","CHM FAUT7",539 ,0)
  29450    .S PRAMOU NT=$P($G(I NFO),"^",9 )   ;SKD M C284 12-15 -06
  29451   "RTN","CHM FAUT7",540 ,0)
  29452    .D PRERXL
  29453   "RTN","CHM FAUT7",541 ,0)
  29454    .Q
  29455   "RTN","CHM FAUT7",542 ,0)
  29456    Q
  29457   "RTN","CHM FAUT7",543 ,0)
  29458   PRERXL ;   RX load in to CHEQP a rray
  29459   "RTN","CHM FAUT7",544 ,0)
  29460    S CHEQP(S PBEN,L,0)= L
  29461   "RTN","CHM FAUT7",545 ,0)
  29462    S CHEQP(S PBEN,L,1)= DOSOUT
  29463   "RTN","CHM FAUT7",546 ,0)
  29464    S CHEQP(S PBEN,L,2)= MEDPYMT
  29465   "RTN","CHM FAUT7",547 ,0)
  29466    S CHEQP(S PBEN,L,3)= BENPYMT
  29467   "RTN","CHM FAUT7",548 ,0)
  29468    ;S CHEQP( SPBEN,L,4) =OHIPYMT     ;SKD MC2 84 12-15-0 6
  29469   "RTN","CHM FAUT7",549 ,0)
  29470    S CHEQP(S PBEN,L,4)= $G(PRAMOUN T)    ;SKD  MC284 12- 15-06
  29471   "RTN","CHM FAUT7",550 ,0)
  29472    S CHEQP(S PBEN,L,5)= ""  ; WHAT  NEEDS TO  BE HERE
  29473   "RTN","CHM FAUT7",551 ,0)
  29474    ;
  29475   "RTN","CHM FAUT7",552 ,0)
  29476    S CHPHARR (SPON,BEN, L)=DOSOUT_ "^"_QTY_"^ ^"_CPTOUT_ "^"_CHGAMT _"^"_ICDOU T
  29477   "RTN","CHM FAUT7",553 ,0)
  29478    Q
  29479   "RTN","CHM FAUT8")
  29480   0^58^B8244 0393
  29481   "RTN","CHM FAUT8",1,0 )
  29482   CHMFAUT8 ; HAC/JLR;UT ILITY PROG RAM FOR IP  SCREENS;0 1/19/00  1 3:15 PM
  29483   "RTN","CHM FAUT8",2,0 )
  29484    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  29485   "RTN","CHM FAUT8",3,0 )
  29486    ;JSG;01/2 9/08;Modif ications f or DEV0039 56-02;Hand ling null  DOSs (see  PREOUT)
  29487   "RTN","CHM FAUT8",4,0 )
  29488    ;JSG;01/2 9/08;                                 ;OC =  Old Code,  NC = New  Code
  29489   "RTN","CHM FAUT8",5,0 )
  29490    ;JSG;03/1 4/08;DEV00 4525-01;Pr event Inva lid Subscr ipt error
  29491   "RTN","CHM FAUT8",6,0 )
  29492    ;JEH 8/29 /08 TT #DE V005596  A dded code  to prevent  undefined  error whe n missing  %
  29493   "RTN","CHM FAUT8",7,0 )
  29494    ;DEV00480 5 1/20/201 0 AEB
  29495   "RTN","CHM FAUT8",8,0 )
  29496    ;DEV00782 0 10/27/20 10 AEB
  29497   "RTN","CHM FAUT8",9,0 )
  29498    ;DEV00782 0 JEH 2/1/ 11 - SLLA
  29499   "RTN","CHM FAUT8",10, 0)
  29500    ;DEV01207 2 JEH 10/5 /11 - add  icd check
  29501   "RTN","CHM FAUT8",11, 0)
  29502    ;CCSE CPE 005-009 GE F 5/2/17 -  add origi nal PDI ch arge lines  if freque ncy code =  5
  29503   "RTN","CHM FAUT8",12, 0)
  29504    ;CPE005-0 48 wtc 7/2 6/17 - sor t DME line s by DOS
  29505   "RTN","CHM FAUT8",13, 0)
  29506    ;CPE005-0 49 kml 8/7 /17 - sort  dental in voice line s by DOS
  29507   "RTN","CHM FAUT8",14, 0)
  29508    ;CPE005-0 08/050 wtc  8/8/17 -  sort outpa tient serv ice lines  by DOS
  29509   "RTN","CHM FAUT8",15, 0)
  29510    ;
  29511   "RTN","CHM FAUT8",16, 0)
  29512   TPREIPT1 ;  TEST FOR  TPREIPT
  29513   "RTN","CHM FAUT8",17, 0)
  29514    S CHMFPDI =201723197 033694,CHM OPDI=20150 3091039557 ,CHMFPGNM= 1,CHMFIMAG =1,VFN="", DOA2OUT=""
  29515   "RTN","CHM FAUT8",18, 0)
  29516    D TPREIPT
  29517   "RTN","CHM FAUT8",19, 0)
  29518    Q
  29519   "RTN","CHM FAUT8",20, 0)
  29520    ;
  29521   "RTN","CHM FAUT8",21, 0)
  29522   TPREIPT ;
  29523   "RTN","CHM FAUT8",22, 0)
  29524    N L,INFO, SPON,BEN,D OA,DOD,DOA 2,DSTAT,TC HG,ICD,POS ,BENPYMT,M EDPYMT
  29525   "RTN","CHM FAUT8",23, 0)
  29526    N DOAOUT, DODOUT,ICD OUT,DSTATO UT,POSOUT, PRAMOUNT      ;SKD 9- 27-07 DEV0 03378
  29527   "RTN","CHM FAUT8",24, 0)
  29528    N CHAOPD, CHPOPD,CHT PTY,CHPRPA Y,CHPRBL,E DILID            ;JEH  2/1/11 DE V007820
  29529   "RTN","CHM FAUT8",25, 0)
  29530    N SVL           ;JEH  2/1/11 DE V007820
  29531   "RTN","CHM FAUT8",26, 0)
  29532    N D3,D4,O PTDOS,CHMO PGNM,CHMOI MAG,CHMOPG IM ; wtc 8 /8/17
  29533   "RTN","CHM FAUT8",27, 0)
  29534    K ^UTILIT Y($J),^TMP ($J) ; wtc  8/8/17
  29535   "RTN","CHM FAUT8",28, 0)
  29536    S (INPDOS ,SVL)="",D 3=0,L=0 ;  wtc 8/8/17
  29537   "RTN","CHM FAUT8",29, 0)
  29538    K CHMFINP
  29539   "RTN","CHM FAUT8",30, 0)
  29540    ;S L=""
  29541   "RTN","CHM FAUT8",31, 0)
  29542    ;SBB 05/1 6/2018 Fix  update
  29543   "RTN","CHM FAUT8",32, 0)
  29544    S L=1
  29545   "RTN","CHM FAUT8",33, 0)
  29546    S SVL=0
  29547   "RTN","CHM FAUT8",34, 0)
  29548    S (DOAOUT ,DODOUT,PO SOUT,ICDOU T,DSTATOUT ,DOA2OUT)= ""
  29549   "RTN","CHM FAUT8",35, 0)
  29550    I $G(CHMF PDI) F  S  D3=$O(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"INP -NS",D3))  Q:D3=""  D   ; wtc 8/ 8/17
  29551   "RTN","CHM FAUT8",36, 0)
  29552    .S INPDOS =$P($G(^CH MIMAGE(CHM FPDI,1,CHM FPGNM,2,CH MFIMAG,"IN P-NS",D3,0 )),"^",1)  ;
  29553   "RTN","CHM FAUT8",37, 0)
  29554    .S ^TMP($ J,INPDOS,D 3,CHMFPDI) =""
  29555   "RTN","CHM FAUT8",38, 0)
  29556    S D3=0
  29557   "RTN","CHM FAUT8",39, 0)
  29558    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  29559   "RTN","CHM FAUT8",40, 0)
  29560    I $G(CHMO PGNM),$G(C HMOIMAG),$ E($P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"V EN")),"^", 7),3)=5 F   S D3=$O(^ CHMIMAGE(C HMOPDI,1,C HMOPGNM,2, CHMOIMAG," INP-NS",D3 )) Q:D3=""   D
  29561   "RTN","CHM FAUT8",41, 0)
  29562    .S INPDOS =$P($G(^CH MIMAGE(CHM OPDI,1,CHM OPGNM,2,CH MOIMAG,"IN P-NS",D3,0 )),"^",1)  ;
  29563   "RTN","CHM FAUT8",42, 0)
  29564    .S ^TMP($ J,INPDOS,D 3,CHMOPDI) =""
  29565   "RTN","CHM FAUT8",43, 0)
  29566    S INPDOS= ""
  29567   "RTN","CHM FAUT8",44, 0)
  29568    F  S INPD OS=$O(^TMP ($J,INPDOS )) Q:INPDO S=""  D  ;  wtc 8/8/1 7
  29569   "RTN","CHM FAUT8",45, 0)
  29570    .S D3=""  F  S D3=$O (^TMP($J,I NPDOS,D3))  Q:D3=""   D  ; wtc 8 /8/17
  29571   "RTN","CHM FAUT8",46, 0)
  29572    ..S D4=""  F  S D4=$ O(^TMP($J, INPDOS,D3, D4)) Q:D4= ""  D
  29573   "RTN","CHM FAUT8",47, 0)
  29574    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  29575   "RTN","CHM FAUT8",48, 0)
  29576    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=CHMOPDI, CHMFPGN1=C HMOPGNM,CH MFIMA1=CHM OIMAG
  29577   "RTN","CHM FAUT8",49, 0)
  29578    ...S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  29579   "RTN","CHM FAUT8",50, 0)
  29580    ...S INFO =$G(^CHMIM AGE(CHMFPD I1,1,CHMFP GN1,2,CHMF IMA1,"INP- NS",D3,0))
  29581   "RTN","CHM FAUT8",51, 0)
  29582    ...Q:INFO =""
  29583   "RTN","CHM FAUT8",52, 0)
  29584    ...S SPON =$P(INFO," ^",1),BEN= $P(INFO,"^ ",2)
  29585   "RTN","CHM FAUT8",53, 0)
  29586    ...S DOA= $P(INFO,"^ ",4) S Y=D OA D DD^%D T I Y'=""  S DOAOUT=Y _"^"_DOA   ;AEB DEF00 4237
  29587   "RTN","CHM FAUT8",54, 0)
  29588    ...S DOD= $P(INFO,"^ ",5) S Y=D OD D DD^%D T I Y'=""  S DODOUT=Y _"^"_DOD
  29589   "RTN","CHM FAUT8",55, 0)
  29590    ...S DOA2 =$P(INFO," ^",16) S Y =DOA2 D DD ^%DT I Y'= "" S DOA2O UT=Y_"^"_D OA2
  29591   "RTN","CHM FAUT8",56, 0)
  29592    ...S DSTA T=$P(INFO, "^",6)
  29593   "RTN","CHM FAUT8",57, 0)
  29594    ...S:DSTA T]"" DSTAT OUT=$$DSTA T^CHMFAUT0 (DSTAT)
  29595   "RTN","CHM FAUT8",58, 0)
  29596    ...S TCHG =$P(INFO," ^",10)
  29597   "RTN","CHM FAUT8",59, 0)
  29598    ...S ICD= $P(INFO,"^ ",7)
  29599   "RTN","CHM FAUT8",60, 0)
  29600    ...S:ICD] "" ICD=$$I CD^CHMFAUT 0(ICD)
  29601   "RTN","CHM FAUT8",61, 0)
  29602    ...S ICDO UT=$P(ICD, "^")_"^"_$ P(ICD,"^", 3)_"^"_$P( ICD,"^",2)
  29603   "RTN","CHM FAUT8",62, 0)
  29604    ...S POS= $P(INFO,"^ ",11) S:PO S="" POS=1
  29605   "RTN","CHM FAUT8",63, 0)
  29606    ...S:POS] "" POS=$$P OS^CHMFAUT 0(POS)
  29607   "RTN","CHM FAUT8",64, 0)
  29608    ...S POSO UT=$P(POS, "^")_"^"_$ P(POS,"^", 3)_"^"_$P( POS,"^",2)
  29609   "RTN","CHM FAUT8",65, 0)
  29610    ...S FAC= $P(INFO,"^ ",14)
  29611   "RTN","CHM FAUT8",66, 0)
  29612    ...; The  $$FAC line  tag does  not exist  in routine  CHMFAUT0  and the 14 th piece i s not Faci lity anywa y, it is a  yes/no fi eld
  29613   "RTN","CHM FAUT8",67, 0)
  29614    ...;S:FAC ]"" FAC=$$ FAC^CHMFAU T0(FAC)
  29615   "RTN","CHM FAUT8",68, 0)
  29616    ...S FACO UT=$P(FAC, "^")_$P(FA C,"^",3)_$ P(FAC,"^", 2)
  29617   "RTN","CHM FAUT8",69, 0)
  29618    ...S MEDP YMT=$P(INF O,"^",19)
  29619   "RTN","CHM FAUT8",70, 0)
  29620    ...S CHTP TY=$P(INFO ,"^",20)       ;THIRD  PARTY PAY MENT    ;J EH 2/1/11  DEV007820
  29621   "RTN","CHM FAUT8",71, 0)
  29622    ...S CHPO PD=$P(INFO ,"^",21)       ;PRIMA RY OHI PAI D                ;JEH  2/1/11 DE V007820
  29623   "RTN","CHM FAUT8",72, 0)
  29624    ...S CHAO PD=$P(INFO ,"^",22)       ;ADD'L  OHIs PAID                  ;JEH  2/1/11 DE V007820
  29625   "RTN","CHM FAUT8",73, 0)
  29626    ...S CHPR PAY=$P(INF O,"^",23)      ;P/R P AY (OHI)                    ;JEH  2/1/11 DE V007820
  29627   "RTN","CHM FAUT8",74, 0)
  29628    ...S CHPR BL=$P(INFO ,"^",24)       ;P/R B ALLANCE(OH I)               ;JEH  2/1/11 DE V007820
  29629   "RTN","CHM FAUT8",75, 0)
  29630    ...S BENP YMT=$P(INF O,"^",13)
  29631   "RTN","CHM FAUT8",76, 0)
  29632    ...S OHIP YMT=""
  29633   "RTN","CHM FAUT8",77, 0)
  29634    ...S PRAM OUNT=""    ;SKD 9-27- 07 DEV0033 78
  29635   "RTN","CHM FAUT8",78, 0)
  29636    ...I VFN' ="",DOA'=" ",$D(^CHMI MAGE(CHMFP DI,"ZOHI", DFN,BFN,CH MFSERV,DOA ,VFN)) D   ;JSG;3/14/ 08;DEV0045 25-01
  29637   "RTN","CHM FAUT8",79, 0)
  29638    ....;S OH IPYMT=^CHM IMAGE(CHMF PDI,"ZOHI" ,DFN,BFN,C HMFSERV,DO A,VFN)   ; SKD MC284  12-15-06
  29639   "RTN","CHM FAUT8",80, 0)
  29640    ....S PRA MOUNT=$P($ G(^CHMIMAG E(CHMFPDI, "ZOHI",DFN ,BFN,CHMFS ERV,DOA,VF N)),U,2)     ;SKD MC2 84 12-15-0 6
  29641   "RTN","CHM FAUT8",81, 0)
  29642    ...E  S P RAMOUNT=CH PRPAY          ;JEH 2 /1/11 DEV0 07820
  29643   "RTN","CHM FAUT8",82, 0)
  29644    ...D PREI PTL1
  29645   "RTN","CHM FAUT8",83, 0)
  29646    ...D PREI PTL2
  29647   "RTN","CHM FAUT8",84, 0)
  29648    ...D PREI PTL3
  29649   "RTN","CHM FAUT8",85, 0)
  29650    ...D PREI PTL4
  29651   "RTN","CHM FAUT8",86, 0)
  29652    ...Q
  29653   "RTN","CHM FAUT8",87, 0)
  29654    ;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
  29655   "RTN","CHM FAUT8",88, 0)
  29656    ;I '$G(CH MOPDI) S C HMOPDI=$P( $G(^CHMIMA GE(CHMFPDI ,202)),"^" ,1) ;BDB 8 /14/17
  29657   "RTN","CHM FAUT8",89, 0)
  29658    ;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)
  29659   "RTN","CHM FAUT8",90, 0)
  29660    Q
  29661   "RTN","CHM FAUT8",91, 0)
  29662   PREIPTL1 ;  Load "INP ","MED", a nd "PAY" i nto CHMFIN P array
  29663   "RTN","CHM FAUT8",92, 0)
  29664    S CHMFINP (SPON,BEN, "INP",1)=D OAOUT
  29665   "RTN","CHM FAUT8",93, 0)
  29666    S CHMFADD A=$P(DOAOU T,"^",2)
  29667   "RTN","CHM FAUT8",94, 0)
  29668    S CHMFINP (SPON,BEN, "INP",2)=D ODOUT
  29669   "RTN","CHM FAUT8",95, 0)
  29670    S CHMFDSD T=$P(DODOU T,"^",2)
  29671   "RTN","CHM FAUT8",96, 0)
  29672    S CHMFINP (SPON,BEN, "INP",3)=D STATOUT
  29673   "RTN","CHM FAUT8",97, 0)
  29674    S CHMFINP (SPON,BEN, "INP",4)=P OSOUT
  29675   "RTN","CHM FAUT8",98, 0)
  29676    S CHMFINP (SPON,BEN, "INP",5)=I CDOUT
  29677   "RTN","CHM FAUT8",99, 0)
  29678    S CHMFINP (SPON,BEN, "INP",6)=T CHG
  29679   "RTN","CHM FAUT8",100 ,0)
  29680    S CHMFINP (SPON,BEN, "INP",7)=" "
  29681   "RTN","CHM FAUT8",101 ,0)
  29682    S CHMFINP (SPON,BEN, "INP",8)=" "
  29683   "RTN","CHM FAUT8",102 ,0)
  29684    S CHMFINP (SPON,BEN, "INP",9)=" "
  29685   "RTN","CHM FAUT8",103 ,0)
  29686    S CHMFINP (SPON,BEN, "INP",10)= ""
  29687   "RTN","CHM FAUT8",104 ,0)
  29688    S CHMFINP (SPON,BEN, "INP",11)= DOA2OUT
  29689   "RTN","CHM FAUT8",105 ,0)
  29690    S CHMFINP (SPON,BEN, "MED")=MED PYMT
  29691   "RTN","CHM FAUT8",106 ,0)
  29692    S CHMFINP (SPON,BEN, "PAY")=BEN PYMT
  29693   "RTN","CHM FAUT8",107 ,0)
  29694    S CHMFINP (SPON,BEN, "TPTY")=CH TPTY               ;J EH 2/1/11  DEV007820
  29695   "RTN","CHM FAUT8",108 ,0)
  29696    S CHMFINP (SPON,BEN, "POPD")=CH POPD               ;J EH 2/1/11  DEV007820
  29697   "RTN","CHM FAUT8",109 ,0)
  29698    S CHMFINP (SPON,BEN, "AOPD")=CH AOPD               ;J EH 2/1/11  DEV007820
  29699   "RTN","CHM FAUT8",110 ,0)
  29700    S CHMFINP (SPON,BEN, "PRPY")=CH PRPAY              ;J EH 2/1/11  DEV007820
  29701   "RTN","CHM FAUT8",111 ,0)
  29702    S CHMFINP (SPON,BEN, "PRBL")=CH PRBL               ;J EH 2/1/11  DEV007820
  29703   "RTN","CHM FAUT8",112 ,0)
  29704    ;S CHMFIN P(SPON,BEN ,"OHI")=OH IPYMT  ;SK D MC284 12 -15-06
  29705   "RTN","CHM FAUT8",113 ,0)
  29706    S CHMFINP (SPON,BEN, "OHI")=""   ;SKD MC28 4 12-15-06
  29707   "RTN","CHM FAUT8",114 ,0)
  29708    I $G(PRAM OUNT) S CH MFINP(SPON ,BEN,"OHI" )=PRAMOUNT   ;SKD MC2 84 12-15-0 6
  29709   "RTN","CHM FAUT8",115 ,0)
  29710    Q
  29711   "RTN","CHM FAUT8",116 ,0)
  29712   PREIPTL2 ; Loads "ICD " into CHM FINP array
  29713   "RTN","CHM FAUT8",117 ,0)
  29714    N M,ICD,I CDOUT S M= ""
  29715   "RTN","CHM FAUT8",118 ,0)
  29716    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,100,M))  Q:M=""  D
  29717   "RTN","CHM FAUT8",119 ,0)
  29718    .S ICD=$P (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,100,M,0) ,"^",1)
  29719   "RTN","CHM FAUT8",120 ,0)
  29720    .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
  29721   "RTN","CHM FAUT8",121 ,0)
  29722    .S:ICD]""  ICD=$$ICD ^CHMFAUT0( ICD)
  29723   "RTN","CHM FAUT8",122 ,0)
  29724    .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
  29725   "RTN","CHM FAUT8",123 ,0)
  29726    .S ICDOUT =$P(ICD,"^ ")_"^"_$P( ICD,"^",3) _"^"_$P(IC D,"^",2)_" ^^"_CHPOA   ;AEB 1/20 /2010 DEV0 04805
  29727   "RTN","CHM FAUT8",124 ,0)
  29728    .S CHMFIN P(SPON,BEN ,"ICD",M)= ICDOUT
  29729   "RTN","CHM FAUT8",125 ,0)
  29730    .S CHMFIN P(SPON,BEN ,"INP",7)= "Y"
  29731   "RTN","CHM FAUT8",126 ,0)
  29732    .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
  29733   "RTN","CHM FAUT8",127 ,0)
  29734    .Q
  29735   "RTN","CHM FAUT8",128 ,0)
  29736    Q
  29737   "RTN","CHM FAUT8",129 ,0)
  29738   PREIPTL3 ; Loads "PRO C" into CH MFINP arra y
  29739   "RTN","CHM FAUT8",130 ,0)
  29740    N M,CPT,C PTOUT S M= ""
  29741   "RTN","CHM FAUT8",131 ,0)
  29742    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,101,M))  Q:M=""  D
  29743   "RTN","CHM FAUT8",132 ,0)
  29744    .S CPT=^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"I NP-NS",L,1 01,M,0)
  29745   "RTN","CHM FAUT8",133 ,0)
  29746    .S:CPT]""  CPT=$$PRO C^CHMFAUT0 (CPT,DOA)
  29747   "RTN","CHM FAUT8",134 ,0)
  29748    .S CPTOUT =$P(CPT,"^ ")_"^"_$P( CPT,"^",3) _"^"_$P(CP T,"^",2)
  29749   "RTN","CHM FAUT8",135 ,0)
  29750    .S CHMFIN P(SPON,BEN ,"PROC",M) =CPTOUT
  29751   "RTN","CHM FAUT8",136 ,0)
  29752    .S CHMFIN P(SPON,BEN ,"INP",8)= "Y"
  29753   "RTN","CHM FAUT8",137 ,0)
  29754    .Q
  29755   "RTN","CHM FAUT8",138 ,0)
  29756    Q
  29757   "RTN","CHM FAUT8",139 ,0)
  29758   PREIPTL4 ; Loads "REV " into CHM FINP array
  29759   "RTN","CHM FAUT8",140 ,0)
  29760    N N,REV,R EVOUT,EDIL ID S M="", EDILID=""   ;JEH 2/1/ 11 DEV0078 20
  29761   "RTN","CHM FAUT8",141 ,0)
  29762    F  S M=$O (^CHMIMAGE (CHMFPDI,1 ,CHMFPGNM, 2,CHMFIMAG ,"INP-NS", L,102,M))  Q:M=""  D
  29763   "RTN","CHM FAUT8",142 ,0)
  29764    .S REV=^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"I NP-NS",L,1 02,M,0)
  29765   "RTN","CHM FAUT8",143 ,0)
  29766    .S:REV]""  REV=$$REV ^CHMFAUT0( REV)
  29767   "RTN","CHM FAUT8",144 ,0)
  29768    .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
  29769   "RTN","CHM FAUT8",145 ,0)
  29770    .S REVOUT =$P(REV,"^ ")_"^"_$P( REV,"^",6) _"^"_$P(RE V,"^",2)_" ^^"_$P(REV ,"^",3)_"^ "_EDILID   ;JEH 2/1/1 1 DEV00782 0
  29771   "RTN","CHM FAUT8",146 ,0)
  29772    .S CHMFIN P(SPON,BEN ,"REV",M)= REVOUT
  29773   "RTN","CHM FAUT8",147 ,0)
  29774    .S CHMFIN P(SPON,BEN ,"INP",10) ="Y"
  29775   "RTN","CHM FAUT8",148 ,0)
  29776    .Q
  29777   "RTN","CHM FAUT8",149 ,0)
  29778    Q
  29779   "RTN","CHM FAUT8",150 ,0)
  29780    ;
  29781   "RTN","CHM FAUT8",151 ,0)
  29782   TPRERX1 ;  TEST FOR T PREIPT
  29783   "RTN","CHM FAUT8",152 ,0)
  29784    S CHMFPDI =201723103 033474,CHM OPDI=20162 5303000001 ,CHMFPGNM= 1,CHMFIMAG =1,VFN="", DOA2OUT=""
  29785   "RTN","CHM FAUT8",153 ,0)
  29786    D TPRERX
  29787   "RTN","CHM FAUT8",154 ,0)
  29788    Q
  29789   "RTN","CHM FAUT8",155 ,0)
  29790    ;
  29791   "RTN","CHM FAUT8",156 ,0)
  29792   TPRERX ; P reload RX
  29793   "RTN","CHM FAUT8",157 ,0)
  29794    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
  29795   "RTN","CHM FAUT8",158 ,0)
  29796    N DOSOUT, CPTOUT,ICD OUT
  29797   "RTN","CHM FAUT8",159 ,0)
  29798    K CHEQP,C HPHARR
  29799   "RTN","CHM FAUT8",160 ,0)
  29800    N DOAOUT, DODOUT,DST ATOUT,POSO UT     ;SK D 9-27-07  DEV003378
  29801   "RTN","CHM FAUT8",161 ,0)
  29802    N CHAOPD, CHPOPD,CHT PTY,CHPRPA Y,CHPRBL,E DILID            ;JEH  2/1/11 DE V007820
  29803   "RTN","CHM FAUT8",162 ,0)
  29804    N SVL           ;JEH  2/1/11 DE V007820
  29805   "RTN","CHM FAUT8",163 ,0)
  29806    N D3,D4,R XDOS,CHMOP GNM,CHMOIM AG,CHMOPGI M ; wtc 8/ 8/17
  29807   "RTN","CHM FAUT8",164 ,0)
  29808    K ^UTILIT Y($J),^TMP ($J) ; wtc  8/8/17
  29809   "RTN","CHM FAUT8",165 ,0)
  29810    S (RXDOS, SVL)="",D3 =0,L=0 ; w tc 8/8/17
  29811   "RTN","CHM FAUT8",166 ,0)
  29812    ;SBB 05/1 6/2018 Fix  update
  29813   "RTN","CHM FAUT8",167 ,0)
  29814    S L=1
  29815   "RTN","CHM FAUT8",168 ,0)
  29816    K CHMFINP
  29817   "RTN","CHM FAUT8",169 ,0)
  29818    S SVL=0
  29819   "RTN","CHM FAUT8",170 ,0)
  29820    S (DOAOUT ,DODOUT,PO SOUT,ICDOU T,DSTATOUT )=""
  29821   "RTN","CHM FAUT8",171 ,0)
  29822    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
  29823   "RTN","CHM FAUT8",172 ,0)
  29824    .S RXDOS= $P($G(^CHM IMAGE(CHMF PDI,1,CHMF PGNM,2,CHM FIMAG,"RX- NS",D3,0)) ,"^",1) ;
  29825   "RTN","CHM FAUT8",173 ,0)
  29826    .S ^TMP($ J,RXDOS,D3 ,CHMFPDI)= ""
  29827   "RTN","CHM FAUT8",174 ,0)
  29828    I $G(CHMO PDI) S CHM OPGIM=$$PD I^CHMFAUT5 (CHMOPDI), CHMOPGNM=$ P(CHMOPGIM ,"*",2),CH MOIMAG=$P( CHMOPGIM," *",3)
  29829   "RTN","CHM FAUT8",175 ,0)
  29830    ;ADDED LI NE BELOW F OR TESTING  8/19/2017  ONLY ONE  PHARMACY C LAIM TO TE ST WITH BA D DATA
  29831   "RTN","CHM FAUT8",176 ,0)
  29832    S CHMOIMA G=1,D3=0
  29833   "RTN","CHM FAUT8",177 ,0)
  29834    I $G(CHMO PGNM),$G(C HMOIMAG),$ E($P($G(^C HMIMAGE(CH MFPDI,1,CH MFPGNM,2,C HMFIMAG,"V EN")),"^", 7),3)=5 F   S D3=$O(^ CHMIMAGE(C HMOPDI,1,C HMOPGNM,2, CHMOIMAG," RX-NS",D3) ) Q:D3=""   D
  29835   "RTN","CHM FAUT8",178 ,0)
  29836    .S RXDOS= $P($G(^CHM IMAGE(CHMO PDI,1,CHMO PGNM,2,CHM OIMAG,"RX- NS",D3,0)) ,"^",1) ;
  29837   "RTN","CHM FAUT8",179 ,0)
  29838    .S ^TMP($ J,RXDOS,D3 ,CHMOPDI)= ""
  29839   "RTN","CHM FAUT8",180 ,0)
  29840    S RXDOS=" "
  29841   "RTN","CHM FAUT8",181 ,0)
  29842    F  S RXDO S=$O(^TMP( $J,RXDOS))  Q:RXDOS=" "  D  ; wt c 8/8/17
  29843   "RTN","CHM FAUT8",182 ,0)
  29844    .S D3=""  F  S D3=$O (^TMP($J,R XDOS,D3))  Q:D3=""  D   ; wtc 8/ 8/17
  29845   "RTN","CHM FAUT8",183 ,0)
  29846    ..S D4=""  F  S D4=$ O(^TMP($J, RXDOS,D3,D 4)) Q:D4=" "  D
  29847   "RTN","CHM FAUT8",184 ,0)
  29848    ...I D4=C HMFPDI S C HMFPDI1=CH MFPDI,CHMF PGN1=CHMFP GNM,CHMFIM A1=CHMFIMA G
  29849   "RTN","CHM FAUT8",185 ,0)
  29850    ...I D4=$ G(CHMOPDI)  S CHMFPDI 1=CHMOPDI, CHMFPGN1=C HMOPGNM,CH MFIMA1=CHM OIMAG
  29851   "RTN","CHM FAUT8",186 ,0)
  29852    ...S (DOS OUT,POSOUT ,ICDOUT,RE VOUT,MODOU T,CPTOUT)= ""
  29853   "RTN","CHM FAUT8",187 ,0)
  29854    ...S INFO =$G(^CHMIM AGE(CHMFPD I1,1,CHMFP GN1,2,CHMF IMA1,"RX-N S",D3,0))
  29855   "RTN","CHM FAUT8",188 ,0)
  29856    ...Q:INFO =""
  29857   "RTN","CHM FAUT8",189 ,0)
  29858    ...;F  S  L=$O(^CHMI MAGE(CHMFP DI,1,CHMFP GNM,2,CHMF IMAG,"RX-N S",L)) Q:L =""  D
  29859   "RTN","CHM FAUT8",190 ,0)
  29860    ...;S (DO AOUT,DODOU T,POSOUT,I CDOUT,DSTA TOUT)=""
  29861   "RTN","CHM FAUT8",191 ,0)
  29862    ...;S INF O=$G(^CHMI MAGE(CHMFP DI,1,CHMFP GNM,2,CHMF IMAG,"RX-N S",L,0))
  29863   "RTN","CHM FAUT8",192 ,0)
  29864    ...;Q:INF O=""
  29865   "RTN","CHM FAUT8",193 ,0)
  29866    ...S SPBE N=$P(INFO, "^",2)_"/" _$P(INFO," ^",3)
  29867   "RTN","CHM FAUT8",194 ,0)
  29868    ...S SPON =$P(INFO," ^",2),BEN= $P(INFO,"^ ",3)
  29869   "RTN","CHM FAUT8",195 ,0)
  29870    ...S DOS= $P(INFO,"^ ",1) S:DOS ]"" DOSOUT =$$DOS^CHM FAUT0(DOS)
  29871   "RTN","CHM FAUT8",196 ,0)
  29872    ...S ICD= $P(INFO,"^ ",11) S:IC D]"" ICDOU T=$$ICD^CH MFAUT0(ICD )
  29873   "RTN","CHM FAUT8",197 ,0)
  29874    ...S:ICDO UT]"" ICDO UT=$P(ICDO UT,"^")_"^ "_$P(ICDOU T,"^",2)
  29875   "RTN","CHM FAUT8",198 ,0)
  29876    ...S CHGA MT=$P(INFO ,"^",8)
  29877   "RTN","CHM FAUT8",199 ,0)
  29878    ...S PDX= $P(INFO,"^ ",7) S:PDX ]"" CPTOUT =$$PDX^CHM FAUT0(PDX)
  29879   "RTN","CHM FAUT8",200 ,0)
  29880    ...S QTY= $P(INFO,"^ ",12)
  29881   "RTN","CHM FAUT8",201 ,0)
  29882    ...S MEDP YMT=$P(INF O,"^",13)
  29883   "RTN","CHM FAUT8",202 ,0)
  29884    ...S BENP YMT=$P(INF O,"^",5)
  29885   "RTN","CHM FAUT8",203 ,0)
  29886    ...;S OHI PYMT=$P(IN FO,"^",9)        ;SKD  MC284 12- 15-06
  29887   "RTN","CHM FAUT8",204 ,0)
  29888    ...S PRAM OUNT=""                     ;SKD  9-27-07 D EV003378
  29889   "RTN","CHM FAUT8",205 ,0)
  29890    ...S PRAM OUNT=$P($G (INFO),"^" ,9)   ;SKD  MC284 12- 15-06
  29891   "RTN","CHM FAUT8",206 ,0)
  29892    ...D PRER XL
  29893   "RTN","CHM FAUT8",207 ,0)
  29894    ...Q
  29895   "RTN","CHM FAUT8",208 ,0)
  29896    Q
  29897   "RTN","CHM FAUT8",209 ,0)
  29898   PRERXL ;   RX load in to CHEQP a rray
  29899   "RTN","CHM FAUT8",210 ,0)
  29900    S CHEQP(S PBEN,L,0)= L
  29901   "RTN","CHM FAUT8",211 ,0)
  29902    S CHEQP(S PBEN,L,1)= DOSOUT
  29903   "RTN","CHM FAUT8",212 ,0)
  29904    S CHEQP(S PBEN,L,2)= MEDPYMT
  29905   "RTN","CHM FAUT8",213 ,0)
  29906    S CHEQP(S PBEN,L,3)= BENPYMT
  29907   "RTN","CHM FAUT8",214 ,0)
  29908    ;S CHEQP( SPBEN,L,4) =OHIPYMT     ;SKD MC2 84 12-15-0 6
  29909   "RTN","CHM FAUT8",215 ,0)
  29910    S CHEQP(S PBEN,L,4)= $G(PRAMOUN T)    ;SKD  MC284 12- 15-06
  29911   "RTN","CHM FAUT8",216 ,0)
  29912    S CHEQP(S PBEN,L,5)= ""  ; WHAT  NEEDS TO  BE HERE
  29913   "RTN","CHM FAUT8",217 ,0)
  29914    ;
  29915   "RTN","CHM FAUT8",218 ,0)
  29916    S CHPHARR (SPON,BEN, L)=DOSOUT_ "^"_QTY_"^ ^"_CPTOUT_ "^"_CHGAMT _"^"_ICDOU T
  29917   "RTN","CHM FAUT8",219 ,0)
  29918    Q
  29919   "RTN","CHM FCLNC")
  29920   0^59^B1633 009
  29921   "RTN","CHM FCLNC",1,0 )
  29922   CHMFCLNC ; HM/FTC;CLA IM LINES N OT COMPLET ED;10/03/1 7
  29923   "RTN","CHM FCLNC",2,0 )
  29924    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  29925   "RTN","CHM FCLNC",3,0 )
  29926    ;
  29927   "RTN","CHM FCLNC",4,0 )
  29928    ;CPE005-0 43 CLAIM L INES NOT C OMPLETE HM  10/03/201 7
  29929   "RTN","CHM FCLNC",5,0 )
  29930    ;Find the  original  PDI
  29931   "RTN","CHM FCLNC",6,0 )
  29932    ;Loop thr u all its  claims
  29933   "RTN","CHM FCLNC",7,0 )
  29934    ;If "in p rocess" (w ith approp riate CARC , RARC, CA GC  codes)  found the n change i t to Rejec ted
  29935   "RTN","CHM FCLNC",8,0 )
  29936    ;Call PDI FINAL^CHST AT to trig ger CSTAT  messages w ith F0:686  status
  29937   "RTN","CHM FCLNC",9,0 )
  29938    Q
  29939   "RTN","CHM FCLNC",10, 0)
  29940    ;
  29941   "RTN","CHM FCLNC",11, 0)
  29942   CMPLLN(OPD I) ; COMPL ETE CLAIM  LINES THAT  ARE NOT C OMPLETED F OR PDI
  29943   "RTN","CHM FCLNC",12, 0)
  29944    N CLMCRS, CLMSTAT,PD IFNL,CNT
  29945   "RTN","CHM FCLNC",13, 0)
  29946    S CNT=0,C LMCRS=0,CL MSTAT=0
  29947   "RTN","CHM FCLNC",14, 0)
  29948    ;S OPDI=$ P($G(^CHMI MG(CPDI,"E -REOPEN")) ,"^")
  29949   "RTN","CHM FCLNC",15, 0)
  29950    ;I $G(OPD I) D
  29951   "RTN","CHM FCLNC",16, 0)
  29952    F  S CLMC RS=$O(^CHM PAY("C",OP DI,CLMCRS) ) Q:CLMCRS =""  D
  29953   "RTN","CHM FCLNC",17, 0)
  29954    .S CLMSTA T=$P($G(^C HMPAY(CLMC RS,0)),"^" ,2)
  29955   "RTN","CHM FCLNC",18, 0)
  29956    .; TGH Ch ange from  if Complet e to if no t Pay Requ ested or C omplete -  validate i n 043 stor y and task s
  29957   "RTN","CHM FCLNC",19, 0)
  29958    .I CLMSTA T=1 D
  29959   "RTN","CHM FCLNC",20, 0)
  29960    ..S DIE=7 41000,DA=C LMCRS,DR=" .02///0" D  ^DIE K DI E
  29961   "RTN","CHM FCLNC",21, 0)
  29962    ..S DIE=7 41000,DA=C LMCRS,DR=" .13///404"  D ^DIE K  DIE
  29963   "RTN","CHM FCLNC",22, 0)
  29964    ;Call PDI FINAL^CHST AT to trig ger CSTAT  messages w ith F0:686  status
  29965   "RTN","CHM FCLNC",23, 0)
  29966    ; TGH Add  decision  if all Cla ims under  PDI are av ailable to  be filed  as a Void
  29967   "RTN","CHM FCLNC",24, 0)
  29968    ; If not  available  to be file d then use  EDI-PAUSE  to place  PDI on-hol d
  29969   "RTN","CHM FCLNC",25, 0)
  29970    ; Replace  line belo w with pro per code f or filing  CSTAT mess ages using  existing  code
  29971   "RTN","CHM FCLNC",26, 0)
  29972    ; and not  new code  in CHCSTAT
  29973   "RTN","CHM FCLNC",27, 0)
  29974    S PDIFNL= $$PDIFINAL ^CHCSTAT(O PDI,"F0:68 6")
  29975   "RTN","CHM FCLNC",28, 0)
  29976    S DIE=741 000.2,DA=O PDI,DR=".0 6///4" D ^ DIE K DIE
  29977   "RTN","CHM FCLNC",29, 0)
  29978    Q OPDI_"  "_CLMSTAT
  29979   "RTN","CHM FCLNC",30, 0)
  29980    ;
  29981   "RTN","CHM FSRT")
  29982   0^60^B2443 4762
  29983   "RTN","CHM FSRT",1,0)
  29984   CHMFSRT ;J LR/DEN;SOR TING IMAGE S TO CLAIM S;09/07/93  2:54 PM
  29985   "RTN","CHM FSRT",2,0)
  29986    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  29987   "RTN","CHM FSRT",3,0)
  29988    ;PT 11575
  29989   "RTN","CHM FSRT",4,0)
  29990    ;CFS CPE0 05-069 Rep opulate ^C HMDIC(7410 02.21 to r edisplay P DI Numbers  in Manual  EDI Re-op en 
  29991   "RTN","CHM FSRT",5,0)
  29992    ; process ing screen .
  29993   "RTN","CHM FSRT",6,0)
  29994    ;BDB CPE0 05-063a Ba ckout dedu ctible and  cat cap f or re-open ed claim
  29995   "RTN","CHM FSRT",7,0)
  29996    ;CFS 01/1 4/2018 CPE 005-034 Mo ved Revers al prompt  from CHMFA DR2 to CHM FSRT
  29997   "RTN","CHM FSRT",8,0)
  29998    ;CFS 01/1 4/2018 CPE 005-035 Fi xed defect  for CSTAT  message.  F3:686 now  going out  in CSTAT  message.
  29999   "RTN","CHM FSRT",9,0)
  30000    ;CFS 01/1 4/2018 CPE 005-041 Fi xed defect  for CSTAT  message.  F0:35 now  going out  in CSTAT m essage.
  30001   "RTN","CHM FSRT",10,0 )
  30002    ;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.
  30003   "RTN","CHM FSRT",11,0 )
  30004    ;SBB 02/0 8/2018 CPE 005-037 Ad d code for  setting t he reverse d/voided t o ZEOBq, M CCRq, and 
  30005   "RTN","CHM FSRT",12,0 )
  30006    ;                               payment cl aims to EO Bq
  30007   "RTN","CHM FSRT",13,0 )
  30008    ;SBB 02/2 6/2018 CPE 005-036 Cr eated SETV OIDN UNSET VDN for ze ro EOB and  835 creat ion.
  30009   "RTN","CHM FSRT",14,0 )
  30010    ;
  30011   "RTN","CHM FSRT",15,0 )
  30012    N REVERSE  ;CPE005-1 08
  30013   "RTN","CHM FSRT",16,0 )
  30014    G:'$D(^CH MIMAGE(CHM FPDI)) END  D ^CHMFSR 16
  30015   "RTN","CHM FSRT",17,0 )
  30016    G:'$D(^CH MIMAGE(CHM FPDI)) END  K ^UTILIT Y("CLAIMS" ,$J)
  30017   "RTN","CHM FSRT",18,0 )
  30018    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
  30019   "RTN","CHM FSRT",19,0 )
  30020    . I CHMFP GNM=""!(CH MFIMAG="")  D GETDATA ^CHMFA008
  30021   "RTN","CHM FSRT",20,0 )
  30022    . I CHMFP GNM'="",CH MFIMAG'="" ,$E(+$$TOB ^CHMFADR2( CHMFPDI,CH MFPGNM,CHM FIMAG),3)= 8 D  Q
  30023   "RTN","CHM FSRT",21,0 )
  30024    .. I '$$C MPCLAIM^CH MFADR2(CHM OPDI) Q  ; All claims  must have  a complet ed status.
  30025   "RTN","CHM FSRT",22,0 )
  30026    .. S REVE RSE=$$REV( CHMFPDI,CH MOPDI)
  30027   "RTN","CHM FSRT",23,0 )
  30028    . S DIE=7 41000.2,DA =CHMOPDI,D R=".06///1 2;.22///"_ DT D ^DIE  K DIE
  30029   "RTN","CHM FSRT",24,0 )
  30030    . N IEN
  30031   "RTN","CHM FSRT",25,0 )
  30032    . S IEN=" " F  S IEN =$O(^CHMPA Y("C",CHMO PDI,IEN))  Q:IEN=""   D
  30033   "RTN","CHM FSRT",26,0 )
  30034    .. 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")
  30035   "RTN","CHM FSRT",27,0 )
  30036    D ^CHMFSR T4,^CHMFSR T1,^CHMFSR T2,^CHMFSR T8,^CHMFSR T6,^CHMFSR T7
  30037   "RTN","CHM FSRT",28,0 )
  30038    D ^CHMFSR R1,^CHMFSR TA
  30039   "RTN","CHM FSRT",29,0 )
  30040    I '$D(^CH MPAY("C",C HMFPDI)) D  ^CHMFDOC  G END:$D(C HDOCFL) D  ^CHMG250J
  30041   "RTN","CHM FSRT",30,0 )
  30042    I $P(^CHM DIC(741002 .21,DUZ,0) ,"^",10)=8 ,'$D(^CHMP AY("C",CHM FPDI)) D   ;CPE005-06 9
  30043   "RTN","CHM FSRT",31,0 )
  30044    . S $P(^C HMDIC(7410 02.21,DUZ, 0),"^",2)= CHMOPDI
  30045   "RTN","CHM FSRT",32,0 )
  30046    . S $P(^C HMDIC(7410 02.21,DUZ, 0),"^",5)= CHMFPDI
  30047   "RTN","CHM FSRT",33,0 )
  30048   END K AII, DS,HNM,II, J,K,L,M,N, NM,TS,PDI, VN,X,XX,AD ,HM,HN,KK, X1,AC,CPT
  30049   "RTN","CHM FSRT",34,0 )
  30050    K DA,DIC, DIE,DLAYGO ,DR,EM,INP ROCESS,J1, J2,VNM,X0, X1,X2,X3,X 4,X5,X7,I
  30051   "RTN","CHM FSRT",35,0 )
  30052    K IP,IP1, IP2,IP3,IP 4,IP5,JJ,C L,OP,OP1,O P2,PN,RX,D M,DM1,DM2, BN,SN,DOS
  30053   "RTN","CHM FSRT",36,0 )
  30054    K CLM,J3, NN,S1,S2,T I,Y,ZDB,ZD A,X6,MR,P, IA,IM,IO,H DA,AI,SUPP ,CHPDI
  30055   "RTN","CHM FSRT",37,0 )
  30056    K ^UTILIT Y("CLAIMS" ,$J),CHDOC FL
  30057   "RTN","CHM FSRT",38,0 )
  30058    Q
  30059   "RTN","CHM FSRT",39,0 )
  30060   REV(CHMFPD I,CHMOPDI)  ;CFS CPE0 05-108
  30061   "RTN","CHM FSRT",40,0 )
  30062    ;CHMFPDI  = Current  PDI
  30063   "RTN","CHM FSRT",41,0 )
  30064    ;CHMOPDI  = Original  PDI
  30065   "RTN","CHM FSRT",42,0 )
  30066    S CHMFPDI =$G(CHMFPD I),CHMOPDI =$G(CHMOPD I)
  30067   "RTN","CHM FSRT",43,0 )
  30068    Q:'CHMFPD I 0
  30069   "RTN","CHM FSRT",44,0 )
  30070    Q:'CHMOPD I 0
  30071   "RTN","CHM FSRT",45,0 )
  30072    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
  30073   "RTN","CHM FSRT",46,0 )
  30074    . S DX=62 ,$X=DX X X Y D CSBRS^ CHSC2 W:Y' ="" @CHEOL
  30075   "RTN","CHM FSRT",47,0 )
  30076    . I Y'="Y ",Y'="N" S  DY=16,DX= 27 X XY W  "Please en ter 'Y','N '." H 5
  30077   "RTN","CHM FSRT",48,0 )
  30078    S REVRESP =Y
  30079   "RTN","CHM FSRT",49,0 )
  30080    I REVRESP ="Y" D  ;C PE005-035
  30081   "RTN","CHM FSRT",50,0 )
  30082    . S DIE=7 41000.2,DA =CHMOPDI,D R=".06///1 1;.22///"_ DT D ^DIE  K DIE ;BDB  09/19/201 7
  30083   "RTN","CHM FSRT",51,0 )
  30084    . S DIE=7 41000.2,DA =CHMFPDI,D R=".05///" _DT_";.06/ //4" D ^DI E K DIE ;B DB 09/19/2 017
  30085   "RTN","CHM FSRT",52,0 )
  30086    . N ADDQ, IEN
  30087   "RTN","CHM FSRT",53,0 )
  30088    . ;SBB 02 /08/2018 C PE005-037
  30089   "RTN","CHM FSRT",54,0 )
  30090    . S U="^"
  30091   "RTN","CHM FSRT",55,0 )
  30092    . S IEN=" " F  S IEN =$O(^CHMPA Y("C",CHMO PDI,IEN))  Q:IEN=""   D
  30093   "RTN","CHM FSRT",56,0 )
  30094    .. ;moved  down belo w
  30095   "RTN","CHM FSRT",57,0 )
  30096    .. D ADJ^ CHGRCCD(IE N,"SUB") ; BDB 11/22/ 2017 CPE00 5-063a BAC K OUT THE  BENE CALC
  30097   "RTN","CHM FSRT",58,0 )
  30098    .. ;SBB 0 2/08/2018  CPE005-037
  30099   "RTN","CHM FSRT",59,0 )
  30100    .. ;Voide d claim to  ZEOBq
  30101   "RTN","CHM FSRT",60,0 )
  30102    .. S CI=I EN,GLPAY=" ^CHMPAY(", CHMFQUE=1, $P(@(GLPAY _"CI,0)"), U,13)=404
  30103   "RTN","CHM FSRT",61,0 )
  30104    .. ;SBB 0 2/23/2018  CPE005-036
  30105   "RTN","CHM FSRT",62,0 )
  30106    .. ;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
  30107   "RTN","CHM FSRT",63,0 )
  30108    .. ;   va lues back  for 835 to  be balanc ed.
  30109   "RTN","CHM FSRT",64,0 )
  30110    .. D SETV OIDN
  30111   "RTN","CHM FSRT",65,0 )
  30112    .. ; Remo ve from EO B queue if  it exists  already
  30113   "RTN","CHM FSRT",66,0 )
  30114    .. S CL=C I D EOB^CH MFUTL1
  30115   "RTN","CHM FSRT",67,0 )
  30116    .. D QUE^ CHFBC
  30117   "RTN","CHM FSRT",68,0 )
  30118    .. ;Setti ng claim t o MCCR que ue:
  30119   "RTN","CHM FSRT",69,0 )
  30120    .. S CI=I EN,CN=$P(^ CHMPAY(CI, 0),U) I $P (^CHMPAY(C I,0),U,2)= 4 D 
  30121   "RTN","CHM FSRT",70,0 )
  30122    ... S CHM FQUE=19     ;19=REOPE NED CLAIM  FUNDS DUE
  30123   "RTN","CHM FSRT",71,0 )
  30124    ... D QUE ^CHFBC
  30125   "RTN","CHM FSRT",72,0 )
  30126    ... Q 
  30127   "RTN","CHM FSRT",73,0 )
  30128    .. S DIE= 741000,DA= IEN,DR=".0 2///11" D  ^DIE K DIE   ;CPE005- 108
  30129   "RTN","CHM FSRT",74,0 )
  30130    .. Q
  30131   "RTN","CHM FSRT",75,0 )
  30132    . D CRCST AT^CHMFUTL E(CHMFPDI, "","E001b" ,"A") ;Sen d out CSTA T message.
  30133   "RTN","CHM FSRT",76,0 )
  30134    . ;S ADDQ =$$ADD2QUE ^CH835TRG( CHMOPDI) ; HM 09/20/2 017 CPE005 -041
  30135   "RTN","CHM FSRT",77,0 )
  30136    . Q
  30137   "RTN","CHM FSRT",78,0 )
  30138    I REVRESP ="N" D   ; CPE005-041
  30139   "RTN","CHM FSRT",79,0 )
  30140    . S DIE=7 41000.2,DA =CHMFPDI,D R=".06///4 " D ^DIE K  DIE
  30141   "RTN","CHM FSRT",80,0 )
  30142    . D CRCST AT^CHMFUTL E(CHMFPDI, "","E001c" ,"A") ;Sen d out CSTA T message.
  30143   "RTN","CHM FSRT",81,0 )
  30144    Q 1
  30145   "RTN","CHM FSRT",82,0 )
  30146    ;
  30147   "RTN","CHM FSRT",83,0 )
  30148    ;SBB 02/2 3/2018 CPE 005-036
  30149   "RTN","CHM FSRT",84,0 )
  30150   SETVOIDN ;
  30151   "RTN","CHM FSRT",85,0 )
  30152    ;
  30153   "RTN","CHM FSRT",86,0 )
  30154    N IDX1,ID X2,XPROCX
  30155   "RTN","CHM FSRT",87,0 )
  30156    ;SET VOID  under 1 n ode and re move vendo r and bene  payment i nfo from 1  node.
  30157   "RTN","CHM FSRT",88,0 )
  30158    S ^CHMPAY (CI,1,"VOI D")=^CHMPA Y(CI,1)
  30159   "RTN","CHM FSRT",89,0 )
  30160    S $P(^CHM PAY(CI,1), U,14)=""
  30161   "RTN","CHM FSRT",90,0 )
  30162    S $P(^CHM PAY(CI,1), U,15)=""
  30163   "RTN","CHM FSRT",91,0 )
  30164    ;
  30165   "RTN","CHM FSRT",92,0 )
  30166    ;SET VOID  under INP -PROC, OUT -PROC, DEN -PROC, PHA RM, and DM E-SUPPLY n odes
  30167   "RTN","CHM FSRT",93,0 )
  30168    F XPROCX= "INP-PROC" ,"OPT-PROC ","DEN-PRO C","PHARM" ,"DME-SUPP LY" D  
  30169   "RTN","CHM FSRT",94,0 )
  30170    . S IDX1= 0 F  S IDX 1=$O(^CHMP AY(CI,XPRO CX,IDX1))  Q:IDX1=""   D  
  30171   "RTN","CHM FSRT",95,0 )
  30172    . . S IDX 2=0 F  S I DX2=$O(^CH MPAY(CI,XP ROCX,IDX1, 1,IDX2)) Q :IDX2=""   D  
  30173   "RTN","CHM FSRT",96,0 )
  30174    . . . Q:' $D(^CHMPAY (CI,XPROCX ,IDX1,1,ID X2,0))
  30175   "RTN","CHM FSRT",97,0 )
  30176    . . . S ^ CHMPAY(CI, XPROCX,IDX 1,1,IDX2," VOID")=^CH MPAY(CI,XP ROCX,IDX1, 1,IDX2,0)
  30177   "RTN","CHM FSRT",98,0 )
  30178    . . . S $ P(^CHMPAY( CI,XPROCX, IDX1,1,IDX 2,0),U,12) =""
  30179   "RTN","CHM FSRT",99,0 )
  30180    . . . S $ P(^CHMPAY( CI,XPROCX, IDX1,1,IDX 2,0),U,15) =""
  30181   "RTN","CHM FSRT",100, 0)
  30182    . . . S $ P(^CHMPAY( CI,XPROCX, IDX1,1,IDX 2,0),U,16) =""
  30183   "RTN","CHM FSRT",101, 0)
  30184    . . . Q
  30185   "RTN","CHM FSRT",102, 0)
  30186    . . Q
  30187   "RTN","CHM FSRT",103, 0)
  30188    . Q
  30189   "RTN","CHM FSRT",104, 0)
  30190    ;
  30191   "RTN","CHM FSRT",105, 0)
  30192    Q
  30193   "RTN","CHM FSRT",106, 0)
  30194    ;
  30195   "RTN","CHM FSRT",107, 0)
  30196     ;SBB 02/ 23/2018 CP E005-036
  30197   "RTN","CHM FSRT",108, 0)
  30198   UNSETVDN(C I) ;
  30199   "RTN","CHM FSRT",109, 0)
  30200    ;
  30201   "RTN","CHM FSRT",110, 0)
  30202    N IDX1,ID X2,XPROCX
  30203   "RTN","CHM FSRT",111, 0)
  30204    ;SET VOID  under 1 n ode and re move vendo r and bene  payment i nfo from 1  node.
  30205   "RTN","CHM FSRT",112, 0)
  30206    S ^CHMPAY (CI,1)=^CH MPAY(CI,1, "VOID")
  30207   "RTN","CHM FSRT",113, 0)
  30208    K ^CHMPAY (CI,1,"VOI D")
  30209   "RTN","CHM FSRT",114, 0)
  30210    ;
  30211   "RTN","CHM FSRT",115, 0)
  30212    ;SET VOID  under INP -PROC, OUT -PROC, DEN -PROC, PHA RM, and DM E-SUPPLY n odes
  30213   "RTN","CHM FSRT",116, 0)
  30214    F XPROCX= "INP-PROC" ,"OPT-PROC ","DEN-PRO C","PHARM" ,"DME-SUPP LY" D  
  30215   "RTN","CHM FSRT",117, 0)
  30216    . S IDX1= 0 F  S IDX 1=$O(^CHMP AY(CI,XPRO CX,IDX1))  Q:IDX1=""   D  
  30217   "RTN","CHM FSRT",118, 0)
  30218    . . S IDX 2=0 F  S I DX2=$O(^CH MPAY(CI,XP ROCX,IDX1, 1,IDX2)) Q :IDX2=""   D  
  30219   "RTN","CHM FSRT",119, 0)
  30220    . . . Q:' $D(^CHMPAY (CI,XPROCX ,IDX1,1,ID X2,0))
  30221   "RTN","CHM FSRT",120, 0)
  30222    . . . S ^ CHMPAY(CI, XPROCX,IDX 1,1,IDX2,0 )=^CHMPAY( CI,XPROCX, IDX1,1,IDX 2,"VOID")
  30223   "RTN","CHM FSRT",121, 0)
  30224    . . . K ^ CHMPAY(CI, XPROCX,IDX 1,1,IDX2," VOID")
  30225   "RTN","CHM FSRT",122, 0)
  30226    . . . Q
  30227   "RTN","CHM FSRT",123, 0)
  30228    . . Q
  30229   "RTN","CHM FSRT",124, 0)
  30230    . Q
  30231   "RTN","CHM FSRT",125, 0)
  30232    ;
  30233   "RTN","CHM FSRT",126, 0)
  30234    Q
  30235   "RTN","CHM FSRT",127, 0)
  30236    ;
  30237   "RTN","CHM FSTP1E")
  30238   0^12^B5054 5843
  30239   "RTN","CHM FSTP1E",1, 0)
  30240   CHMFSTP1E  ;ajf;SUBMI SSION STRI P FOR CPD; 11/17/17   1:38 PM
  30241   "RTN","CHM FSTP1E",2, 0)
  30242    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  30243   "RTN","CHM FSTP1E",3, 0)
  30244    ;AJF ; CP E005-42; T his is a c opy of CHM FSTP1 - SU BMISSION S TRIP OPTIO N
  30245   "RTN","CHM FSTP1E",4, 0)
  30246    ;    ; th is version  is withou t user inp ut
  30247   "RTN","CHM FSTP1E",5, 0)
  30248    ;
  30249   "RTN","CHM FSTP1E",6, 0)
  30250   START(OPDI ) ; OPDI =  Original  PDI to be  stripped
  30251   "RTN","CHM FSTP1E",7, 0)
  30252    ; input -  OPDI = Or iginal PDI  to be str ipped
  30253   "RTN","CHM FSTP1E",8, 0)
  30254    ;          CHMSTRIP  - passed b y referenc e,
  30255   "RTN","CHM FSTP1E",9, 0)
  30256    ;                      0 - was  not stripp ed; 1 - pd i was stri pped
  30257   "RTN","CHM FSTP1E",10 ,0)
  30258    N CHMFPDI
  30259   "RTN","CHM FSTP1E",11 ,0)
  30260    S CHMSTRI P=0
  30261   "RTN","CHM FSTP1E",12 ,0)
  30262    ;
  30263   "RTN","CHM FSTP1E",13 ,0)
  30264   A00 ;D ^CH MFSET X CH RESET
  30265   "RTN","CHM FSTP1E",14 ,0)
  30266    K EDISTRP
  30267   "RTN","CHM FSTP1E",15 ,0)
  30268    K CHLAND   ;AEB 5/7/ 2007
  30269   "RTN","CHM FSTP1E",16 ,0)
  30270    S (Y,CHMF PDI)=OPDI  D CHK^CHMF STP5  ;VER IFY CLAIM  IS NOT IN  RESOURCE D EVICE CHLO AD=0 IN R  DEVICE;CHL OAD=1 IN Q UEUE  AEB  5/7/2007
  30271   "RTN","CHM FSTP1E",17 ,0)
  30272    I CHLAND= 0 D  G A01   ;AEB 5/7 /2007
  30273   "RTN","CHM FSTP1E",18 ,0)
  30274    .;W !!,*7 ,@CHBON,"P DI CAN'T B E STRIPPED ; CLAIMS S TILL BEING  PROCESSED !",@CHBOFF   ;AEB 5/7 /2007
  30275   "RTN","CHM FSTP1E",19 ,0)
  30276    .S EDISTR P=1
  30277   "RTN","CHM FSTP1E",20 ,0)
  30278    .Q  ;AEB5 /7/2007
  30279   "RTN","CHM FSTP1E",21 ,0)
  30280    D CHECK   ;ADD THE D ELETION OF  REOPEN HE RE
  30281   "RTN","CHM FSTP1E",22 ,0)
  30282    D PROBSQ
  30283   "RTN","CHM FSTP1E",23 ,0)
  30284    I $D(PSQF L) D  G A0 1
  30285   "RTN","CHM FSTP1E",24 ,0)
  30286    .;W !!,"P DI is in t he Problem  Support Q ueue, stri pping not  allowed."
  30287   "RTN","CHM FSTP1E",25 ,0)
  30288    .S EDISTR P=1
  30289   "RTN","CHM FSTP1E",26 ,0)
  30290    D BATCH
  30291   "RTN","CHM FSTP1E",27 ,0)
  30292    I $D(BATF L) D  G A0 1
  30293   "RTN","CHM FSTP1E",28 ,0)
  30294    .;W *7,!! ,"PDI is i n an in-pr ogress bat ch, resett ing is not  allowed."
  30295   "RTN","CHM FSTP1E",29 ,0)
  30296    .S EDISTR P=1
  30297   "RTN","CHM FSTP1E",30 ,0)
  30298    ;S CHMFPD I=Y
  30299   "RTN","CHM FSTP1E",31 ,0)
  30300   A1 ;W !!," Taking thi s action w ill remove  claims fr om all que ues and de lete"
  30301   "RTN","CHM FSTP1E",32 ,0)
  30302    ;W !,"all  claims fo r this PDI ."  W !!," Do you wis h to conti nue?  NO//  "
  30303   "RTN","CHM FSTP1E",33 ,0)
  30304    ;D SBRS
  30305   "RTN","CHM FSTP1E",34 ,0)
  30306    ;G:$D(DUO UT) A01 G: $D(DFOUT)  END
  30307   "RTN","CHM FSTP1E",35 ,0)
  30308    ;I $D(DQO UT) W !!," Enter <Y>e s to conti nue or <N> o to Quit. " G A1
  30309   "RTN","CHM FSTP1E",36 ,0)
  30310    ;S:Y="" Y ="N" S Y=$ E(Y,1)
  30311   "RTN","CHM FSTP1E",37 ,0)
  30312    ;I "NYny" '[Y W !!," Enter <Y>e s to conti nue or <N> o to Quit. " G A1
  30313   "RTN","CHM FSTP1E",38 ,0)
  30314    ;G:"Nn"[Y  END
  30315   "RTN","CHM FSTP1E",39 ,0)
  30316    K CHSTAT
  30317   "RTN","CHM FSTP1E",40 ,0)
  30318    D STATUS
  30319   "RTN","CHM FSTP1E",41 ,0)
  30320    I $D(CHST AT) D  G A 01
  30321   "RTN","CHM FSTP1E",42 ,0)
  30322    .S REAS=" Claims are  completed  or paymen t requeste d" D NODEL
  30323   "RTN","CHM FSTP1E",43 ,0)
  30324    K CHEOB
  30325   "RTN","CHM FSTP1E",44 ,0)
  30326    D EOB
  30327   "RTN","CHM FSTP1E",45 ,0)
  30328    I $D(CHEO B) S REAS= "EOB's hav e been pri nted." D N ODEL G A01
  30329   "RTN","CHM FSTP1E",46 ,0)
  30330    K CHPAID
  30331   "RTN","CHM FSTP1E",47 ,0)
  30332    D ^CHMFST P2
  30333   "RTN","CHM FSTP1E",48 ,0)
  30334    I $D(CHPA ID) S REAS ="claims h ave been p aid." D NO DEL G A01
  30335   "RTN","CHM FSTP1E",49 ,0)
  30336   A01 ;
  30337   "RTN","CHM FSTP1E",50 ,0)
  30338    ;Q $S('$D (EDISTRP): 1,1:0)
  30339   "RTN","CHM FSTP1E",51 ,0)
  30340    ;Q
  30341   "RTN","CHM FSTP1E",52 ,0)
  30342    D VEPROD, BATCH1
  30343   "RTN","CHM FSTP1E",53 ,0)
  30344    ;
  30345   "RTN","CHM FSTP1E",54 ,0)
  30346    ;***IF MO DIFYING CO DE BETWEEN  EDIENTR A ND E3, USE  EDISTRP V ARIABLE TO
  30347   "RTN","CHM FSTP1E",55 ,0)
  30348    ;***EXCLU DE INTERAC TIVE PORTI ONS FROM E DI STRIP P ROCESS  (D TP)
  30349   "RTN","CHM FSTP1E",56 ,0)
  30350    ;
  30351   "RTN","CHM FSTP1E",57 ,0)
  30352   EDIENTR D  ^CHMFSTP3  S CL=0
  30353   "RTN","CHM FSTP1E",58 ,0)
  30354    F GLOB="^ CHMPAY("," ^CHNVPAY("  D
  30355   "RTN","CHM FSTP1E",59 ,0)
  30356    .I $D(@(G LOB_"""C"" ,CHMFPDI)" )) S CPDI= CHMFPDI,Y= CHMFPDI D  CLMCHK
  30357   "RTN","CHM FSTP1E",60 ,0)
  30358   A2 .S CL=$ O(@(GLOB_" ""C"",CHMF PDI,CL)"))  Q:'CL
  30359   "RTN","CHM FSTP1E",61 ,0)
  30360    .S CN=$P( @(GLOB_"CL ,0)"),"^", 1) K OHI S  CHMFCLNM= CN
  30361   "RTN","CHM FSTP1E",62 ,0)
  30362    .S X1=CL  D PROGTYP^ CHFCD001 D  ^CHMFUTL2
  30363   "RTN","CHM FSTP1E",63 ,0)
  30364    .D BENE,C LAIM G A2
  30365   "RTN","CHM FSTP1E",64 ,0)
  30366   EXIT ;
  30367   "RTN","CHM FSTP1E",65 ,0)
  30368    ;W:'$D(ED ISTRP) !!, "PDI has b een stripp ed and cla ims delete d......... .."
  30369   "RTN","CHM FSTP1E",66 ,0)
  30370    S CHMFPP= "PDIRSTCL"  D ^CHMFWK 01
  30371   "RTN","CHM FSTP1E",67 ,0)
  30372   E1 K CHREA DY
  30373   "RTN","CHM FSTP1E",68 ,0)
  30374    I ($D(NOU SER)&('$D( EDISTRP)))  D  G E2
  30375   "RTN","CHM FSTP1E",69 ,0)
  30376    .S CHMQNA M="MANUAL( ",CHMIN=1  K CHMOUT D  ^CHMIS041
  30377   "RTN","CHM FSTP1E",70 ,0)
  30378    ;D:'$D(ED ISTRP) REA DYQ  REMOV ED FOR PRO CESSING BY  IMAGE PRO JECT (zipz ap) AEB 3/ 17/2006
  30379   "RTN","CHM FSTP1E",71 ,0)
  30380    D USER  ; ADDED TO H AVE USER R EASSIGN PD I PROCESS  BY IMAGE ( zipzap) PR OJECT AEB  3/17/2006
  30381   "RTN","CHM FSTP1E",72 ,0)
  30382   E2 K ^CHMI MAGE(CHMFP DI),^CHMIM G(CHMFPDI, "PAUSE")
  30383   "RTN","CHM FSTP1E",73 ,0)
  30384    S $P(^CHM IMG(CHMFPD I,0),"^",6 )=0
  30385   "RTN","CHM FSTP1E",74 ,0)
  30386    S $P(^CHM IMG(CHMFPD I,0),"^",4 )=""
  30387   "RTN","CHM FSTP1E",75 ,0)
  30388    S $P(^CHM IMG(CHMFPD I,0),"^",5 )=""
  30389   "RTN","CHM FSTP1E",76 ,0)
  30390    K SN,BN,C P,DIK,DA,Y ,CHMFPDI
  30391   "RTN","CHM FSTP1E",77 ,0)
  30392   E3 ;
  30393   "RTN","CHM FSTP1E",78 ,0)
  30394   END K SN,B N,CP,DIK,D A,Y
  30395   "RTN","CHM FSTP1E",79 ,0)
  30396    Q $S('$D( EDISTRP):1 ,1:0)
  30397   "RTN","CHM FSTP1E",80 ,0)
  30398    ;
  30399   "RTN","CHM FSTP1E",81 ,0)
  30400   READYQ Q   ;REMOVED F OR PROCESS ING BY IMA GE PROJECT  aeb 3/17/ 2006
  30401   "RTN","CHM FSTP1E",82 ,0)
  30402    W !!,"Do  you want t o set this  PDI to th e 'READY'  Queue? " D  SBRS
  30403   "RTN","CHM FSTP1E",83 ,0)
  30404    I $D(DUOU T) D  G RE ADYQ
  30405   "RTN","CHM FSTP1E",84 ,0)
  30406    .W !!,"Ba cking out  not allowe d.  PDI ha s already  been strip ped."
  30407   "RTN","CHM FSTP1E",85 ,0)
  30408    I $D(DFOU T) D  G RE ADYQ
  30409   "RTN","CHM FSTP1E",86 ,0)
  30410    .W !!,"Ba cking out  not allowe d.  PDI ha s already  been strip ped."
  30411   "RTN","CHM FSTP1E",87 ,0)
  30412    I $D(DQOU T) D  G RE ADYQ
  30413   "RTN","CHM FSTP1E",88 ,0)
  30414    .W !!,"En ter <Y>es  to set to  ready queu e of <N>o  to continu e."
  30415   "RTN","CHM FSTP1E",89 ,0)
  30416    S:Y="" Y= "N"
  30417   "RTN","CHM FSTP1E",90 ,0)
  30418    S Y=$E(Y, 1)
  30419   "RTN","CHM FSTP1E",91 ,0)
  30420    I "YNyn"' [Y W *7 G  READYQ
  30421   "RTN","CHM FSTP1E",92 ,0)
  30422    I "Nn"[Y  K CHVOEX D  USER Q
  30423   "RTN","CHM FSTP1E",93 ,0)
  30424    D READY S  CHREADY=1
  30425   "RTN","CHM FSTP1E",94 ,0)
  30426    Q
  30427   "RTN","CHM FSTP1E",95 ,0)
  30428    ; 
  30429   "RTN","CHM FSTP1E",96 ,0)
  30430   PROBSQ K P SQFL Q:'$D (^CHMPSQ(" PDI",Y))
  30431   "RTN","CHM FSTP1E",97 ,0)
  30432    S PSQPT=0
  30433   "RTN","CHM FSTP1E",98 ,0)
  30434   PR1 S PSQP T=$O(^CHMP SQ("PDI",Y ,PSQPT)) Q :'PSQPT
  30435   "RTN","CHM FSTP1E",99 ,0)
  30436    G:'$D(^CH MPSQ(PSQPT ,0)) PR1
  30437   "RTN","CHM FSTP1E",10 0,0)
  30438    S PSSTAT= $P(^(0),"^ ",3)
  30439   "RTN","CHM FSTP1E",10 1,0)
  30440    I PSSTAT' =3 S PSQFL =1 Q
  30441   "RTN","CHM FSTP1E",10 2,0)
  30442    G PR1
  30443   "RTN","CHM FSTP1E",10 3,0)
  30444    ;
  30445   "RTN","CHM FSTP1E",10 4,0)
  30446   BATCH K BA TFL Q:'$D( ^CHMIMPB(" C",Y))
  30447   "RTN","CHM FSTP1E",10 5,0)
  30448    S J=0,J=$ O(^CHMIMPB ("C",Y,J))  Q:'J
  30449   "RTN","CHM FSTP1E",10 6,0)
  30450    S K=0,K=$ O(^CHMIMPB ("C",Y,J,K )) Q:'K
  30451   "RTN","CHM FSTP1E",10 7,0)
  30452    Q:'$D(^CH MIMPB(J,0) )  I $P(^( 0),"^",6)= 1 S BATFL= 1
  30453   "RTN","CHM FSTP1E",10 8,0)
  30454    Q
  30455   "RTN","CHM FSTP1E",10 9,0)
  30456    ;
  30457   "RTN","CHM FSTP1E",11 0,0)
  30458   BATCH1 Q:' $D(^CHMIMP B("C",CHMF PDI))
  30459   "RTN","CHM FSTP1E",11 1,0)
  30460    S J=0,J=$ O(^CHMIMPB ("C",CHMFP DI,J)) Q:' J
  30461   "RTN","CHM FSTP1E",11 2,0)
  30462    S K=0,K=$ O(^CHMIMPB ("C",CHMFP DI,J,K)) Q :'K
  30463   "RTN","CHM FSTP1E",11 3,0)
  30464    K NOUSER  Q:$P(^CHMI MPB(J,0)," ^",3)=1  S  NOUSER=1
  30465   "RTN","CHM FSTP1E",11 4,0)
  30466    S $P(^CHM IMPB(J,100 ,K,0),"^", 3)=0
  30467   "RTN","CHM FSTP1E",11 5,0)
  30468    S $P(^CHM IMG(CHMFPD I,0),"^",6 )=0
  30469   "RTN","CHM FSTP1E",11 6,0)
  30470    S ^CHMIMG ("MANUAL", CHMFPDI)=" " Q
  30471   "RTN","CHM FSTP1E",11 7,0)
  30472    ;
  30473   "RTN","CHM FSTP1E",11 8,0)
  30474   NODEL ;
  30475   "RTN","CHM FSTP1E",11 9,0)
  30476    ;W !!,"Su bmission c annot be s tripped, " ,REAS
  30477   "RTN","CHM FSTP1E",12 0,0)
  30478    ;W !!,"Pr ess <RETUR N> to cont inue...... ....." R X
  30479   "RTN","CHM FSTP1E",12 1,0)
  30480    S EDISTRP =1
  30481   "RTN","CHM FSTP1E",12 2,0)
  30482    Q
  30483   "RTN","CHM FSTP1E",12 3,0)
  30484    ;
  30485   "RTN","CHM FSTP1E",12 4,0)
  30486   EOB S CL=0
  30487   "RTN","CHM FSTP1E",12 5,0)
  30488    F GLOB="^ CHMPAY("," ^CHNVPAY("  D  Q:$D(C HEOB)
  30489   "RTN","CHM FSTP1E",12 6,0)
  30490   EOB1 .S CL =$O(@(GLOB _"""C"",CH MFPDI,CL)" )) Q:'CL
  30491   "RTN","CHM FSTP1E",12 7,0)
  30492    .S GLEOB= $S(GLOB="^ CHMPAY(":" ^CHMEOBQ(" ,GLOB="^CH NVPAY(":"^ CHNVEOBQ(" )
  30493   "RTN","CHM FSTP1E",12 8,0)
  30494    .S J=0,J= $O(@(GLEOB _"""D"",CL ,J)")) G:' J EOB1
  30495   "RTN","CHM FSTP1E",12 9,0)
  30496    .Q:'$D(@( GLEOB_"J,0 )"))
  30497   "RTN","CHM FSTP1E",13 0,0)
  30498    .I $P(@(G LEOB_"J,0) "),"^",3)= 1 S CHEOB= 1
  30499   "RTN","CHM FSTP1E",13 1,0)
  30500    .G EOB1
  30501   "RTN","CHM FSTP1E",13 2,0)
  30502    Q
  30503   "RTN","CHM FSTP1E",13 3,0)
  30504    ;
  30505   "RTN","CHM FSTP1E",13 4,0)
  30506    ;
  30507   "RTN","CHM FSTP1E",13 5,0)
  30508   STATUS S C L=0
  30509   "RTN","CHM FSTP1E",13 6,0)
  30510    F GLOB="^ CHMPAY("," ^CHNVPAY("  S CL=0 D   Q:$D(CHST AT)
  30511   "RTN","CHM FSTP1E",13 7,0)
  30512   S1 .S CL=$ O(@(GLOB_" ""C"",CHMF PDI,CL)"))  Q:'CL
  30513   "RTN","CHM FSTP1E",13 8,0)
  30514    .G:'$D(@( GLOB_"CL,0 )")) S1
  30515   "RTN","CHM FSTP1E",13 9,0)
  30516    .I $P(@(G LOB_"CL,0) "),"^",2)= 4 S CHSTAT =1 Q
  30517   "RTN","CHM FSTP1E",14 0,0)
  30518    .I GLOB=" ^CHNVPAY("  I $P(@(GL OB_"CL,0)" ),"^",2)=2  S CHSTAT= 1 Q
  30519   "RTN","CHM FSTP1E",14 1,0)
  30520    .G S1
  30521   "RTN","CHM FSTP1E",14 2,0)
  30522    Q
  30523   "RTN","CHM FSTP1E",14 3,0)
  30524    ;
  30525   "RTN","CHM FSTP1E",14 4,0)
  30526   READY Q  ; REMOVED FO R PROCESSI NG BY IMAG E PROJECT  AEB 3/17/2 006
  30527   "RTN","CHM FSTP1E",14 5,0)
  30528    S ^CHMIMG ("READY",C HMFPDI)=""
  30529   "RTN","CHM FSTP1E",14 6,0)
  30530    S CHMQNAM ="IMAGE(", CHMIN=1 K  CHMOUT D ^ CHMIS041
  30531   "RTN","CHM FSTP1E",14 7,0)
  30532    W !!,"PDI  ",CHMFPDI ," has bee n set to t he 'READY'  Queue."
  30533   "RTN","CHM FSTP1E",14 8,0)
  30534    Q
  30535   "RTN","CHM FSTP1E",14 9,0)
  30536    ;
  30537   "RTN","CHM FSTP1E",15 0,0)
  30538   USER ;
  30539   "RTN","CHM FSTP1E",15 1,0)
  30540    ;W ! S DI C=741002.2 1,DIC(0)=" AEQMN" D ^ DIC Q:Y=""   Q:Y=-1
  30541   "RTN","CHM FSTP1E",15 2,0)
  30542    ;S CHVOCH =+Y,NAME=" " S:$D(^VA (200,CHVOC H,0)) NAME =$P(^(0)," ^",1)
  30543   "RTN","CHM FSTP1E",15 3,0)
  30544    ;I $P(^CH MDIC(74100 2.21,CHVOC H,0),"^",5 )'="" D NO SET Q
  30545   "RTN","CHM FSTP1E",15 4,0)
  30546    ;S $P(^CH MDIC(74100 2.21,CHVOC H,0),"^",5 )=CHMFPDI
  30547   "RTN","CHM FSTP1E",15 5,0)
  30548    ;W !!,"PD I ",CHMFPD I," has be en assigne d to ",NAM E
  30549   "RTN","CHM FSTP1E",15 6,0)
  30550    ;S CHMQNA M="MANUAL( ",CHMIN=1  K CHMOUT D  ^CHMIS041
  30551   "RTN","CHM FSTP1E",15 7,0)
  30552    ;S CHVOEX =1
  30553   "RTN","CHM FSTP1E",15 8,0)
  30554    Q
  30555   "RTN","CHM FSTP1E",15 9,0)
  30556    ;
  30557   "RTN","CHM FSTP1E",16 0,0)
  30558   NOSET W *7 ,*7,!!,NAM E
  30559   "RTN","CHM FSTP1E",16 1,0)
  30560    W " HAS A  PDI ASSIG NED TO THE M.  RE-ASS IGNING NOT  ALLOWED."
  30561   "RTN","CHM FSTP1E",16 2,0)
  30562    Q
  30563   "RTN","CHM FSTP1E",16 3,0)
  30564    ;
  30565   "RTN","CHM FSTP1E",16 4,0)
  30566   BENE S SN= 0
  30567   "RTN","CHM FSTP1E",16 5,0)
  30568   A6 S SN=$O (@(GLDFN_" ""C"",CL,S N)")) Q:'S N
  30569   "RTN","CHM FSTP1E",16 6,0)
  30570    S BN=0
  30571   "RTN","CHM FSTP1E",16 7,0)
  30572   A7 S BN=$O (@(GLDFN_" ""C"",CL,S N,BN)")) G :'BN A6
  30573   "RTN","CHM FSTP1E",16 8,0)
  30574    S CP=0
  30575   "RTN","CHM FSTP1E",16 9,0)
  30576   A8 S CP=$O (@(GLDFN_" ""C"",CL,S N,BN,CP)") ) G:'CP A7
  30577   "RTN","CHM FSTP1E",17 0,0)
  30578    K @(GLDFN _"SN,100,B N,100,CP,0 )")
  30579   "RTN","CHM FSTP1E",17 1,0)
  30580    K @(GLDFN _"""C"",CL )")
  30581   "RTN","CHM FSTP1E",17 2,0)
  30582    K @(GLDFN _"SN,100,B N,100,""B" ",CL,CP)")
  30583   "RTN","CHM FSTP1E",17 3,0)
  30584    G A8
  30585   "RTN","CHM FSTP1E",17 4,0)
  30586    ;
  30587   "RTN","CHM FSTP1E",17 5,0)
  30588   CLAIM D:$D (@(GLPAY_" CL,6)")) R EOPN
  30589   "RTN","CHM FSTP1E",17 6,0)
  30590    S $P(@(GL PAY_"CL,0) "),"^",2)= 10
  30591   "RTN","CHM FSTP1E",17 7,0)
  30592    S VND=$P( @(GLPAY_"C L,0)"),"^" ,3)
  30593   "RTN","CHM FSTP1E",17 8,0)
  30594    K @(GLPAY _"""B"",CN )")
  30595   "RTN","CHM FSTP1E",17 9,0)
  30596    K @(GLPAY _"""C"",CH MFPDI,CL)" )
  30597   "RTN","CHM FSTP1E",18 0,0)
  30598    K ^CHMIMG (CHMFPDI," PAUSE")
  30599   "RTN","CHM FSTP1E",18 1,0)
  30600    K:VND'=""  @(GLPAY_" ""AD"",VND ,CL)")
  30601   "RTN","CHM FSTP1E",18 2,0)
  30602    D NOW^%DT C
  30603   "RTN","CHM FSTP1E",18 3,0)
  30604    S @(GLPAY _"""ZDEL"" ,CL)")=DUZ _"^"_%
  30605   "RTN","CHM FSTP1E",18 4,0)
  30606    S CHMFI=C L,CHMFPP=" DELCLM" D  ^CHMFWK02  K CHMFI,CH MFPP  ;AEB  9/2/2008  DEV003427
  30607   "RTN","CHM FSTP1E",18 5,0)
  30608    Q
  30609   "RTN","CHM FSTP1E",18 6,0)
  30610    ;
  30611   "RTN","CHM FSTP1E",18 7,0)
  30612   REOPN S CH OLDCL=$P(@ (GLPAY_"CL ,6)"),"^", 2)
  30613   "RTN","CHM FSTP1E",18 8,0)
  30614    Q:CHOLDCL =""
  30615   "RTN","CHM FSTP1E",18 9,0)
  30616    Q:'$D(@(G LPAY_"CHOL DCL,6)"))
  30617   "RTN","CHM FSTP1E",19 0,0)
  30618    S $P(@(GL PAY_"CHOLD CL,6)"),"^ ",1)=""
  30619   "RTN","CHM FSTP1E",19 1,0)
  30620    Q
  30621   "RTN","CHM FSTP1E",19 2,0)
  30622    ;
  30623   "RTN","CHM FSTP1E",19 3,0)
  30624   CHECK ;
  30625   "RTN","CHM FSTP1E",19 4,0)
  30626    S REOPPG= 0
  30627   "RTN","CHM FSTP1E",19 5,0)
  30628   C1 S REOPP G=$O(^CHMI MAGE(Y,1,R EOPPG)) Q: 'REOPPG  S  REOPIMG=0
  30629   "RTN","CHM FSTP1E",19 6,0)
  30630   C2 S REOPI MG=$O(^CHM IMAGE(Y,1, REOPPG,2,R EOPIMG)) G :'REOPIMG  C1
  30631   "RTN","CHM FSTP1E",19 7,0)
  30632    K ^CHMIMA GE(Y,1,REO PPG,2,REOP IMG,"REOP" )
  30633   "RTN","CHM FSTP1E",19 8,0)
  30634    G C2
  30635   "RTN","CHM FSTP1E",19 9,0)
  30636    ;
  30637   "RTN","CHM FSTP1E",20 0,0)
  30638   SBRS D CSB RS^CHSC2 Q    ;SKD, 8 -8-05
  30639   "RTN","CHM FSTP1E",20 1,0)
  30640    R Y:$S($D (DTIME):DT IME,1:60)
  30641   "RTN","CHM FSTP1E",20 2,0)
  30642    I '$T W * 7 R Y:5 G  SBRS:Y="."  S:'$T Y=I OZFO ; Und efined on  8/1/05
  30643   "RTN","CHM FSTP1E",20 3,0)
  30644   SBRS1 K DF OUT,DUOUT, DQOUT S:'$ D(IOZFO) I OZFO="^^"  S:'$D(IOZB K) IOZBK=" ^"
  30645   "RTN","CHM FSTP1E",20 4,0)
  30646    I IOZFO=Y  W:$D(IOZF ) @IOZF S  (DFOUT,Y)= "" Q
  30647   "RTN","CHM FSTP1E",20 5,0)
  30648    S:Y=IOZBK  (DUOUT,Y) ="" S:Y?1" ?".E!(Y["^ ") (DQOUT, Y)=""
  30649   "RTN","CHM FSTP1E",20 6,0)
  30650    Q
  30651   "RTN","CHM FSTP1E",20 7,0)
  30652    ;
  30653   "RTN","CHM FSTP1E",20 8,0)
  30654   VEPROD ;SE TS PDI INT O C X-REF  IN CHMPROD
  30655   "RTN","CHM FSTP1E",20 9,0)
  30656    S REC21=^ CHMIMG(CHM FPDI,0)
  30657   "RTN","CHM FSTP1E",21 0,0)
  30658    S TMPDUZ= $P(REC21," ^",3),SDAT E=$P(REC21 ,"^",4)
  30659   "RTN","CHM FSTP1E",21 1,0)
  30660    Q:TMPDUZ= ""
  30661   "RTN","CHM FSTP1E",21 2,0)
  30662    S TME=$E( SDATE,11,1 2) I TME<3 0 S TME=0  G VP3
  30663   "RTN","CHM FSTP1E",21 3,0)
  30664    I TME>30  S TME=3
  30665   "RTN","CHM FSTP1E",21 4,0)
  30666   VP3 S SDAT E=+$E(SDAT E,1,10)_TM E/1
  30667   "RTN","CHM FSTP1E",21 5,0)
  30668    S DODATE= $P(SDATE," .",1)
  30669   "RTN","CHM FSTP1E",21 6,0)
  30670   VEP1 S DOD ATE=$O(^CH MPROD(7410 60.01,"C", DODATE)) G :'DODATE V EP2
  30671   "RTN","CHM FSTP1E",21 7,0)
  30672    S NEWPDI= 0
  30673   "RTN","CHM FSTP1E",21 8,0)
  30674    S NEWPDI= $O(^CHMPRO D(741060.0 1,"C",DODA TE,TMPDUZ, NEWPDI)) G :'NEWPDI V EP1
  30675   "RTN","CHM FSTP1E",21 9,0)
  30676    I NEWPDI= CHMFPDI K  ^CHMPROD(7 41060.01," C",DODATE, TMPDUZ,NEW PDI)
  30677   "RTN","CHM FSTP1E",22 0,0)
  30678   VEP2 S ^CH MPROD(7410 60.01,"C", SDATE,TMPD UZ,CHMFPDI )=1
  30679   "RTN","CHM FSTP1E",22 1,0)
  30680    K TMPDUZ, SDATE,REC2 1
  30681   "RTN","CHM FSTP1E",22 2,0)
  30682    Q
  30683   "RTN","CHM FSTP1E",22 3,0)
  30684    ;
  30685   "RTN","CHM FSTP1E",22 4,0)
  30686   CLMCHK X ^ %ZOSF("UCI ")
  30687   "RTN","CHM FSTP1E",22 5,0)
  30688    S UCI=$P( Y,",",1)
  30689   "RTN","CHM FSTP1E",22 6,0)
  30690    S CPT=0
  30691   "RTN","CHM FSTP1E",22 7,0)
  30692   CLM1 S CPT =$O(@(GLOB _"""C"",CP DI,CPT)"))  Q:'CPT
  30693   "RTN","CHM FSTP1E",22 8,0)
  30694    G:'$D(@(G LOB_"CPT,0 )")) CLM1
  30695   "RTN","CHM FSTP1E",22 9,0)
  30696    I $D(^%ZS TAT("CC",U CI,CPT)) K  ^%ZSTAT(" CC",UCI,CP T)
  30697   "RTN","CHM FSTP1E",23 0,0)
  30698    G CLM1
  30699   "RTN","CHM FSTP1F")
  30700   0^13^B5031 6510
  30701   "RTN","CHM FSTP1F",1, 0)
  30702   CHMFSTP1F  ;ajf;SUBMI SSION STRI P FOR CPD; 11/17/17   1:38 PM
  30703   "RTN","CHM FSTP1F",2, 0)
  30704    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  30705   "RTN","CHM FSTP1F",3, 0)
  30706    ;AJF ; CP E005-42; T his is a c opy of CHM FSTP1 - SU BMISSION S TRIP OPTIO N
  30707   "RTN","CHM FSTP1F",4, 0)
  30708    ;    ; th is version  is withou t user inp ut
  30709   "RTN","CHM FSTP1F",5, 0)
  30710    ;
  30711   "RTN","CHM FSTP1F",6, 0)
  30712   START(OPDI ) ; OPDI =  Original  PDI to be  stripped
  30713   "RTN","CHM FSTP1F",7, 0)
  30714    ; input -  OPDI = Or iginal PDI  to be str ipped
  30715   "RTN","CHM FSTP1F",8, 0)
  30716    ;          CHMSTRIP  - passed b y referenc e,
  30717   "RTN","CHM FSTP1F",9, 0)
  30718    ;                      0 - was  not stripp ed; 1 - pd i was stri pped
  30719   "RTN","CHM FSTP1F",10 ,0)
  30720    N CHMFPDI
  30721   "RTN","CHM FSTP1F",11 ,0)
  30722    S CHMSTRI P=0
  30723   "RTN","CHM FSTP1F",12 ,0)
  30724    ;
  30725   "RTN","CHM FSTP1F",13 ,0)
  30726   A00 ;D ^CH MFSET X CH RESET
  30727   "RTN","CHM FSTP1F",14 ,0)
  30728    K EDISTRP
  30729   "RTN","CHM FSTP1F",15 ,0)
  30730    ;W !!,"En ter the PD I to strip : " D SBRS
  30731   "RTN","CHM FSTP1F",16 ,0)
  30732    ;G:$D(DFO UT) END G: $D(DUOUT)  END G:$D(D QOUT) A01  G:Y="" END
  30733   "RTN","CHM FSTP1F",17 ,0)
  30734    ;I ('$D(^ CHMPAY("C" ,Y)))&('$D (^CHNVPAY( "C",Y))) D   G A01
  30735   "RTN","CHM FSTP1F",18 ,0)
  30736    ;.W !!,*7 ,@CHBON,"P LEASE ENTE R A VALID  PDI!",@CHB OFF
  30737   "RTN","CHM FSTP1F",19 ,0)
  30738    K CHLAND   ;AEB 5/7/ 2007
  30739   "RTN","CHM FSTP1F",20 ,0)
  30740    S (Y,CHMF PDI)=OPDI  D CHK^CHMF STP5  ;VER IFY CLAIM  IS NOT IN  RESOURCE D EVICE CHLO AD=0 IN R  DEVICE;CHL OAD=1 IN Q UEUE  AEB  5/7/2007
  30741   "RTN","CHM FSTP1F",21 ,0)
  30742    I CHLAND= 0 D  G A01   ;AEB 5/7 /2007
  30743   "RTN","CHM FSTP1F",22 ,0)
  30744    .;W !!,*7 ,@CHBON,"P DI CAN'T B E STRIPPED ; CLAIMS S TILL BEING  PROCESSED !",@CHBOFF   ;AEB 5/7 /2007
  30745   "RTN","CHM FSTP1F",23 ,0)
  30746    .S EDISTR P=1
  30747   "RTN","CHM FSTP1F",24 ,0)
  30748    .Q  ;AEB5 /7/2007
  30749   "RTN","CHM FSTP1F",25 ,0)
  30750    D CHECK   ;ADD THE D ELETION OF  REOPEN HE RE
  30751   "RTN","CHM FSTP1F",26 ,0)
  30752    D PROBSQ
  30753   "RTN","CHM FSTP1F",27 ,0)
  30754    I $D(PSQF L) D  G A0 1
  30755   "RTN","CHM FSTP1F",28 ,0)
  30756    .;W !!,"P DI is in t he Problem  Support Q ueue, stri pping not  allowed."
  30757   "RTN","CHM FSTP1F",29 ,0)
  30758    .S EDISTR P=1
  30759   "RTN","CHM FSTP1F",30 ,0)
  30760    D BATCH
  30761   "RTN","CHM FSTP1F",31 ,0)
  30762    I $D(BATF L) D  G A0 1
  30763   "RTN","CHM FSTP1F",32 ,0)
  30764    .;W *7,!! ,"PDI is i n an in-pr ogress bat ch, resett ing is not  allowed."
  30765   "RTN","CHM FSTP1F",33 ,0)
  30766    .S EDISTR P=1
  30767   "RTN","CHM FSTP1F",34 ,0)
  30768    ;S CHMFPD I=Y
  30769   "RTN","CHM FSTP1F",35 ,0)
  30770   A1 ;W !!," Taking thi s action w ill remove  claims fr om all que ues and de lete"
  30771   "RTN","CHM FSTP1F",36 ,0)
  30772    ;W !,"all  claims fo r this PDI ."  W !!," Do you wis h to conti nue?  NO//  "
  30773   "RTN","CHM FSTP1F",37 ,0)
  30774    ;D SBRS
  30775   "RTN","CHM FSTP1F",38 ,0)
  30776    ;G:$D(DUO UT) A01 G: $D(DFOUT)  END
  30777   "RTN","CHM FSTP1F",39 ,0)
  30778    ;I $D(DQO UT) W !!," Enter <Y>e s to conti nue or <N> o to Quit. " G A1
  30779   "RTN","CHM FSTP1F",40 ,0)
  30780    ;S:Y="" Y ="N" S Y=$ E(Y,1)
  30781   "RTN","CHM FSTP1F",41 ,0)
  30782    ;I "NYny" '[Y W !!," Enter <Y>e s to conti nue or <N> o to Quit. " G A1
  30783   "RTN","CHM FSTP1F",42 ,0)
  30784    ;G:"Nn"[Y  END
  30785   "RTN","CHM FSTP1F",43 ,0)
  30786    K CHSTAT
  30787   "RTN","CHM FSTP1F",44 ,0)
  30788    D STATUS
  30789   "RTN","CHM FSTP1F",45 ,0)
  30790    I $D(CHST AT) D  G A 01
  30791   "RTN","CHM FSTP1F",46 ,0)
  30792    .S REAS=" Claims are  completed  or paymen t requeste d" D NODEL
  30793   "RTN","CHM FSTP1F",47 ,0)
  30794    K CHEOB
  30795   "RTN","CHM FSTP1F",48 ,0)
  30796    D EOB
  30797   "RTN","CHM FSTP1F",49 ,0)
  30798    I $D(CHEO B) S REAS= "EOB's hav e been pri nted." D N ODEL G A01
  30799   "RTN","CHM FSTP1F",50 ,0)
  30800    K CHPAID
  30801   "RTN","CHM FSTP1F",51 ,0)
  30802    D ^CHMFST P2
  30803   "RTN","CHM FSTP1F",52 ,0)
  30804    I $D(CHPA ID) S REAS ="claims h ave been p aid." D NO DEL G A01
  30805   "RTN","CHM FSTP1F",53 ,0)
  30806   A01 ;
  30807   "RTN","CHM FSTP1F",54 ,0)
  30808    ;Q $S('$D (EDISTRP): 1,1:0)
  30809   "RTN","CHM FSTP1F",55 ,0)
  30810    ;Q
  30811   "RTN","CHM FSTP1F",56 ,0)
  30812    D VEPROD, BATCH1
  30813   "RTN","CHM FSTP1F",57 ,0)
  30814    ;
  30815   "RTN","CHM FSTP1F",58 ,0)
  30816    ;***IF MO DIFYING CO DE BETWEEN  EDIENTR A ND E3, USE  EDISTRP V ARIABLE TO
  30817   "RTN","CHM FSTP1F",59 ,0)
  30818    ;***EXCLU DE INTERAC TIVE PORTI ONS FROM E DI STRIP P ROCESS  (D TP)
  30819   "RTN","CHM FSTP1F",60 ,0)
  30820    ;
  30821   "RTN","CHM FSTP1F",61 ,0)
  30822   EDIENTR D  ^CHMFSTP3  S CL=0
  30823   "RTN","CHM FSTP1F",62 ,0)
  30824    F GLOB="^ CHMPAY("," ^CHNVPAY("  D
  30825   "RTN","CHM FSTP1F",63 ,0)
  30826    .I $D(@(G LOB_"""C"" ,CHMFPDI)" )) S CPDI= CHMFPDI,Y= CHMFPDI D  CLMCHK
  30827   "RTN","CHM FSTP1F",64 ,0)
  30828   A2 .S CL=$ O(@(GLOB_" ""C"",CHMF PDI,CL)"))  Q:'CL
  30829   "RTN","CHM FSTP1F",65 ,0)
  30830    .S CN=$P( @(GLOB_"CL ,0)"),"^", 1) K OHI S  CHMFCLNM= CN
  30831   "RTN","CHM FSTP1F",66 ,0)
  30832    .S X1=CL  D PROGTYP^ CHFCD001 D  ^CHMFUTL2
  30833   "RTN","CHM FSTP1F",67 ,0)
  30834    .D BENE,C LAIM G A2
  30835   "RTN","CHM FSTP1F",68 ,0)
  30836   EXIT ;
  30837   "RTN","CHM FSTP1F",69 ,0)
  30838    ;W:'$D(ED ISTRP) !!, "PDI has b een stripp ed and cla ims delete d......... .."
  30839   "RTN","CHM FSTP1F",70 ,0)
  30840    S CHMFPP= "PDIRSTCL"  D ^CHMFWK 01
  30841   "RTN","CHM FSTP1F",71 ,0)
  30842   E1 K CHREA DY
  30843   "RTN","CHM FSTP1F",72 ,0)
  30844    I ($D(NOU SER)&('$D( EDISTRP)))  D  G E2
  30845   "RTN","CHM FSTP1F",73 ,0)
  30846    .S CHMQNA M="MANUAL( ",CHMIN=1  K CHMOUT D  ^CHMIS041
  30847   "RTN","CHM FSTP1F",74 ,0)
  30848    ;D:'$D(ED ISTRP) REA DYQ  REMOV ED FOR PRO CESSING BY  IMAGE PRO JECT (zipz ap) AEB 3/ 17/2006
  30849   "RTN","CHM FSTP1F",75 ,0)
  30850    ;D USER   ;ADDED TO  HAVE USER  REASSIGN P DI PROCESS  BY IMAGE  (zipzap) P ROJECT AEB  3/17/2006
  30851   "RTN","CHM FSTP1F",76 ,0)
  30852   E2 K ^CHMI MAGE(CHMFP DI),^CHMIM G(CHMFPDI, "PAUSE")
  30853   "RTN","CHM FSTP1F",77 ,0)
  30854    S $P(^CHM IMG(CHMFPD I,0),"^",6 )=0
  30855   "RTN","CHM FSTP1F",78 ,0)
  30856    S $P(^CHM IMG(CHMFPD I,0),"^",4 )=""
  30857   "RTN","CHM FSTP1F",79 ,0)
  30858    S $P(^CHM IMG(CHMFPD I,0),"^",5 )=""
  30859   "RTN","CHM FSTP1F",80 ,0)
  30860    K SN,BN,C P,DIK,DA,Y ,CHMFPDI
  30861   "RTN","CHM FSTP1F",81 ,0)
  30862   E3 ;
  30863   "RTN","CHM FSTP1F",82 ,0)
  30864   END K SN,B N,CP,DIK,D A,Y
  30865   "RTN","CHM FSTP1F",83 ,0)
  30866    Q $S('$D( EDISTRP):1 ,1:0)
  30867   "RTN","CHM FSTP1F",84 ,0)
  30868    ;
  30869   "RTN","CHM FSTP1F",85 ,0)
  30870   READYQ Q   ;REMOVED F OR PROCESS ING BY IMA GE PROJECT  aeb 3/17/ 2006
  30871   "RTN","CHM FSTP1F",86 ,0)
  30872    W !!,"Do  you want t o set this  PDI to th e 'READY'  Queue? " D  SBRS
  30873   "RTN","CHM FSTP1F",87 ,0)
  30874    I $D(DUOU T) D  G RE ADYQ
  30875   "RTN","CHM FSTP1F",88 ,0)
  30876    .W !!,"Ba cking out  not allowe d.  PDI ha s already  been strip ped."
  30877   "RTN","CHM FSTP1F",89 ,0)
  30878    I $D(DFOU T) D  G RE ADYQ
  30879   "RTN","CHM FSTP1F",90 ,0)
  30880    .W !!,"Ba cking out  not allowe d.  PDI ha s already  been strip ped."
  30881   "RTN","CHM FSTP1F",91 ,0)
  30882    I $D(DQOU T) D  G RE ADYQ
  30883   "RTN","CHM FSTP1F",92 ,0)
  30884    .W !!,"En ter <Y>es  to set to  ready queu e of <N>o  to continu e."
  30885   "RTN","CHM FSTP1F",93 ,0)
  30886    S:Y="" Y= "N"
  30887   "RTN","CHM FSTP1F",94 ,0)
  30888    S Y=$E(Y, 1)
  30889   "RTN","CHM FSTP1F",95 ,0)
  30890    I "YNyn"' [Y W *7 G  READYQ
  30891   "RTN","CHM FSTP1F",96 ,0)
  30892    I "Nn"[Y  K CHVOEX D  USER Q
  30893   "RTN","CHM FSTP1F",97 ,0)
  30894    D READY S  CHREADY=1
  30895   "RTN","CHM FSTP1F",98 ,0)
  30896    Q
  30897   "RTN","CHM FSTP1F",99 ,0)
  30898    ; 
  30899   "RTN","CHM FSTP1F",10 0,0)
  30900   PROBSQ K P SQFL Q:'$D (^CHMPSQ(" PDI",Y))
  30901   "RTN","CHM FSTP1F",10 1,0)
  30902    S PSQPT=0
  30903   "RTN","CHM FSTP1F",10 2,0)
  30904   PR1 S PSQP T=$O(^CHMP SQ("PDI",Y ,PSQPT)) Q :'PSQPT
  30905   "RTN","CHM FSTP1F",10 3,0)
  30906    G:'$D(^CH MPSQ(PSQPT ,0)) PR1
  30907   "RTN","CHM FSTP1F",10 4,0)
  30908    S PSSTAT= $P(^(0),"^ ",3)
  30909   "RTN","CHM FSTP1F",10 5,0)
  30910    I PSSTAT' =3 S PSQFL =1 Q
  30911   "RTN","CHM FSTP1F",10 6,0)
  30912    G PR1
  30913   "RTN","CHM FSTP1F",10 7,0)
  30914    ;
  30915   "RTN","CHM FSTP1F",10 8,0)
  30916   BATCH K BA TFL Q:'$D( ^CHMIMPB(" C",Y))
  30917   "RTN","CHM FSTP1F",10 9,0)
  30918    S J=0,J=$ O(^CHMIMPB ("C",Y,J))  Q:'J
  30919   "RTN","CHM FSTP1F",11 0,0)
  30920    S K=0,K=$ O(^CHMIMPB ("C",Y,J,K )) Q:'K
  30921   "RTN","CHM FSTP1F",11 1,0)
  30922    Q:'$D(^CH MIMPB(J,0) )  I $P(^( 0),"^",6)= 1 S BATFL= 1
  30923   "RTN","CHM FSTP1F",11 2,0)
  30924    Q
  30925   "RTN","CHM FSTP1F",11 3,0)
  30926    ;
  30927   "RTN","CHM FSTP1F",11 4,0)
  30928   BATCH1 Q:' $D(^CHMIMP B("C",CHMF PDI))
  30929   "RTN","CHM FSTP1F",11 5,0)
  30930    S J=0,J=$ O(^CHMIMPB ("C",CHMFP DI,J)) Q:' J
  30931   "RTN","CHM FSTP1F",11 6,0)
  30932    S K=0,K=$ O(^CHMIMPB ("C",CHMFP DI,J,K)) Q :'K
  30933   "RTN","CHM FSTP1F",11 7,0)
  30934    K NOUSER  Q:$P(^CHMI MPB(J,0)," ^",3)=1  S  NOUSER=1
  30935   "RTN","CHM FSTP1F",11 8,0)
  30936    S $P(^CHM IMPB(J,100 ,K,0),"^", 3)=0
  30937   "RTN","CHM FSTP1F",11 9,0)
  30938    S $P(^CHM IMG(CHMFPD I,0),"^",6 )=0
  30939   "RTN","CHM FSTP1F",12 0,0)
  30940    S ^CHMIMG ("MANUAL", CHMFPDI)=" " Q
  30941   "RTN","CHM FSTP1F",12 1,0)
  30942    ;
  30943   "RTN","CHM FSTP1F",12 2,0)
  30944   NODEL ;
  30945   "RTN","CHM FSTP1F",12 3,0)
  30946    ;W !!,"Su bmission c annot be s tripped, " ,REAS
  30947   "RTN","CHM FSTP1F",12 4,0)
  30948    ;W !!,"Pr ess <RETUR N> to cont inue...... ....." R X
  30949   "RTN","CHM FSTP1F",12 5,0)
  30950    S EDISTRP =1
  30951   "RTN","CHM FSTP1F",12 6,0)
  30952    Q
  30953   "RTN","CHM FSTP1F",12 7,0)
  30954    ;
  30955   "RTN","CHM FSTP1F",12 8,0)
  30956   EOB S CL=0
  30957   "RTN","CHM FSTP1F",12 9,0)
  30958    F GLOB="^ CHMPAY("," ^CHNVPAY("  D  Q:$D(C HEOB)
  30959   "RTN","CHM FSTP1F",13 0,0)
  30960   EOB1 .S CL =$O(@(GLOB _"""C"",CH MFPDI,CL)" )) Q:'CL
  30961   "RTN","CHM FSTP1F",13 1,0)
  30962    .S GLEOB= $S(GLOB="^ CHMPAY(":" ^CHMEOBQ(" ,GLOB="^CH NVPAY(":"^ CHNVEOBQ(" )
  30963   "RTN","CHM FSTP1F",13 2,0)
  30964    .S J=0,J= $O(@(GLEOB _"""D"",CL ,J)")) G:' J EOB1
  30965   "RTN","CHM FSTP1F",13 3,0)
  30966    .Q:'$D(@( GLEOB_"J,0 )"))
  30967   "RTN","CHM FSTP1F",13 4,0)
  30968    .I $P(@(G LEOB_"J,0) "),"^",3)= 1 S CHEOB= 1
  30969   "RTN","CHM FSTP1F",13 5,0)
  30970    .G EOB1
  30971   "RTN","CHM FSTP1F",13 6,0)
  30972    Q
  30973   "RTN","CHM FSTP1F",13 7,0)
  30974    ;
  30975   "RTN","CHM FSTP1F",13 8,0)
  30976    ;
  30977   "RTN","CHM FSTP1F",13 9,0)
  30978   STATUS S C L=0
  30979   "RTN","CHM FSTP1F",14 0,0)
  30980    F GLOB="^ CHMPAY("," ^CHNVPAY("  S CL=0 D   Q:$D(CHST AT)
  30981   "RTN","CHM FSTP1F",14 1,0)
  30982   S1 .S CL=$ O(@(GLOB_" ""C"",CHMF PDI,CL)"))  Q:'CL
  30983   "RTN","CHM FSTP1F",14 2,0)
  30984    .G:'$D(@( GLOB_"CL,0 )")) S1
  30985   "RTN","CHM FSTP1F",14 3,0)
  30986    .I $P(@(G LOB_"CL,0) "),"^",2)= 4 S CHSTAT =1 Q
  30987   "RTN","CHM FSTP1F",14 4,0)
  30988    .I GLOB=" ^CHNVPAY("  I $P(@(GL OB_"CL,0)" ),"^",2)=2  S CHSTAT= 1 Q
  30989   "RTN","CHM FSTP1F",14 5,0)
  30990    .G S1
  30991   "RTN","CHM FSTP1F",14 6,0)
  30992    Q
  30993   "RTN","CHM FSTP1F",14 7,0)
  30994    ;
  30995   "RTN","CHM FSTP1F",14 8,0)
  30996   READY Q  ; REMOVED FO R PROCESSI NG BY IMAG E PROJECT  AEB 3/17/2 006
  30997   "RTN","CHM FSTP1F",14 9,0)
  30998    S ^CHMIMG ("READY",C HMFPDI)=""
  30999   "RTN","CHM FSTP1F",15 0,0)
  31000    S CHMQNAM ="IMAGE(", CHMIN=1 K  CHMOUT D ^ CHMIS041
  31001   "RTN","CHM FSTP1F",15 1,0)
  31002    W !!,"PDI  ",CHMFPDI ," has bee n set to t he 'READY'  Queue."
  31003   "RTN","CHM FSTP1F",15 2,0)
  31004    Q
  31005   "RTN","CHM FSTP1F",15 3,0)
  31006    ;
  31007   "RTN","CHM FSTP1F",15 4,0)
  31008   USER ;
  31009   "RTN","CHM FSTP1F",15 5,0)
  31010    ;W ! S DI C=741002.2 1,DIC(0)=" AEQMN" D ^ DIC Q:Y=""   Q:Y=-1
  31011   "RTN","CHM FSTP1F",15 6,0)
  31012    ;S CHVOCH =+Y,NAME=" " S:$D(^VA (200,CHVOC H,0)) NAME =$P(^(0)," ^",1)
  31013   "RTN","CHM FSTP1F",15 7,0)
  31014    ;I $P(^CH MDIC(74100 2.21,CHVOC H,0),"^",5 )'="" D NO SET Q
  31015   "RTN","CHM FSTP1F",15 8,0)
  31016    ;S $P(^CH MDIC(74100 2.21,CHVOC H,0),"^",5 )=CHMFPDI
  31017   "RTN","CHM FSTP1F",15 9,0)
  31018    ;W !!,"PD I ",CHMFPD I," has be en assigne d to ",NAM E
  31019   "RTN","CHM FSTP1F",16 0,0)
  31020    ;S CHMQNA M="MANUAL( ",CHMIN=1  K CHMOUT D  ^CHMIS041
  31021   "RTN","CHM FSTP1F",16 1,0)
  31022    ;S CHVOEX =1
  31023   "RTN","CHM FSTP1F",16 2,0)
  31024    Q
  31025   "RTN","CHM FSTP1F",16 3,0)
  31026    ;
  31027   "RTN","CHM FSTP1F",16 4,0)
  31028   NOSET ;W * 7,*7,!!,NA ME
  31029   "RTN","CHM FSTP1F",16 5,0)
  31030    ;W " HAS  A PDI ASSI GNED TO TH EM.  RE-AS SIGNING NO T ALLOWED. "
  31031   "RTN","CHM FSTP1F",16 6,0)
  31032    Q
  31033   "RTN","CHM FSTP1F",16 7,0)
  31034    ;
  31035   "RTN","CHM FSTP1F",16 8,0)
  31036   BENE S SN= 0
  31037   "RTN","CHM FSTP1F",16 9,0)
  31038   A6 S SN=$O (@(GLDFN_" ""C"",CL,S N)")) Q:'S N
  31039   "RTN","CHM FSTP1F",17 0,0)
  31040    S BN=0
  31041   "RTN","CHM FSTP1F",17 1,0)
  31042   A7 S BN=$O (@(GLDFN_" ""C"",CL,S N,BN)")) G :'BN A6
  31043   "RTN","CHM FSTP1F",17 2,0)
  31044    S CP=0
  31045   "RTN","CHM FSTP1F",17 3,0)
  31046   A8 S CP=$O (@(GLDFN_" ""C"",CL,S N,BN,CP)") ) G:'CP A7
  31047   "RTN","CHM FSTP1F",17 4,0)
  31048    K @(GLDFN _"SN,100,B N,100,CP,0 )")
  31049   "RTN","CHM FSTP1F",17 5,0)
  31050    K @(GLDFN _"""C"",CL )")
  31051   "RTN","CHM FSTP1F",17 6,0)
  31052    K @(GLDFN _"SN,100,B N,100,""B" ",CL,CP)")
  31053   "RTN","CHM FSTP1F",17 7,0)
  31054    G A8
  31055   "RTN","CHM FSTP1F",17 8,0)
  31056    ;
  31057   "RTN","CHM FSTP1F",17 9,0)
  31058   CLAIM D:$D (@(GLPAY_" CL,6)")) R EOPN
  31059   "RTN","CHM FSTP1F",18 0,0)
  31060    S $P(@(GL PAY_"CL,0) "),"^",2)= 10
  31061   "RTN","CHM FSTP1F",18 1,0)
  31062    S VND=$P( @(GLPAY_"C L,0)"),"^" ,3)
  31063   "RTN","CHM FSTP1F",18 2,0)
  31064    K @(GLPAY _"""B"",CN )")
  31065   "RTN","CHM FSTP1F",18 3,0)
  31066    K @(GLPAY _"""C"",CH MFPDI,CL)" )
  31067   "RTN","CHM FSTP1F",18 4,0)
  31068    K ^CHMIMG (CHMFPDI," PAUSE")
  31069   "RTN","CHM FSTP1F",18 5,0)
  31070    K:VND'=""  @(GLPAY_" ""AD"",VND ,CL)")
  31071   "RTN","CHM FSTP1F",18 6,0)
  31072    D NOW^%DT C
  31073   "RTN","CHM FSTP1F",18 7,0)
  31074    S @(GLPAY _"""ZDEL"" ,CL)")=DUZ _"^"_%
  31075   "RTN","CHM FSTP1F",18 8,0)
  31076    S CHMFI=C L,CHMFPP=" DELCLM" D  ^CHMFWK02  K CHMFI,CH MFPP  ;AEB  9/2/2008  DEV003427
  31077   "RTN","CHM FSTP1F",18 9,0)
  31078    Q
  31079   "RTN","CHM FSTP1F",19 0,0)
  31080    ;
  31081   "RTN","CHM FSTP1F",19 1,0)
  31082   REOPN S CH OLDCL=$P(@ (GLPAY_"CL ,6)"),"^", 2)
  31083   "RTN","CHM FSTP1F",19 2,0)
  31084    Q:CHOLDCL =""
  31085   "RTN","CHM FSTP1F",19 3,0)
  31086    Q:'$D(@(G LPAY_"CHOL DCL,6)"))
  31087   "RTN","CHM FSTP1F",19 4,0)
  31088    S $P(@(GL PAY_"CHOLD CL,6)"),"^ ",1)=""
  31089   "RTN","CHM FSTP1F",19 5,0)
  31090    Q
  31091   "RTN","CHM FSTP1F",19 6,0)
  31092    ;
  31093   "RTN","CHM FSTP1F",19 7,0)
  31094   CHECK ;
  31095   "RTN","CHM FSTP1F",19 8,0)
  31096    S REOPPG= 0
  31097   "RTN","CHM FSTP1F",19 9,0)
  31098   C1 S REOPP G=$O(^CHMI MAGE(Y,1,R EOPPG)) Q: 'REOPPG  S  REOPIMG=0
  31099   "RTN","CHM FSTP1F",20 0,0)
  31100   C2 S REOPI MG=$O(^CHM IMAGE(Y,1, REOPPG,2,R EOPIMG)) G :'REOPIMG  C1
  31101   "RTN","CHM FSTP1F",20 1,0)
  31102    K ^CHMIMA GE(Y,1,REO PPG,2,REOP IMG,"REOP" )
  31103   "RTN","CHM FSTP1F",20 2,0)
  31104    G C2
  31105   "RTN","CHM FSTP1F",20 3,0)
  31106    ;
  31107   "RTN","CHM FSTP1F",20 4,0)
  31108   SBRS D CSB RS^CHSC2 Q    ;SKD, 8 -8-05
  31109   "RTN","CHM FSTP1F",20 5,0)
  31110    R Y:$S($D (DTIME):DT IME,1:60)
  31111   "RTN","CHM FSTP1F",20 6,0)
  31112    I '$T W * 7 R Y:5 G  SBRS:Y="."  S:'$T Y=I OZFO ; Und efined on  8/1/05
  31113   "RTN","CHM FSTP1F",20 7,0)
  31114   SBRS1 K DF OUT,DUOUT, DQOUT S:'$ D(IOZFO) I OZFO="^^"  S:'$D(IOZB K) IOZBK=" ^"
  31115   "RTN","CHM FSTP1F",20 8,0)
  31116    I IOZFO=Y  W:$D(IOZF ) @IOZF S  (DFOUT,Y)= "" Q
  31117   "RTN","CHM FSTP1F",20 9,0)
  31118    S:Y=IOZBK  (DUOUT,Y) ="" S:Y?1" ?".E!(Y["^ ") (DQOUT, Y)=""
  31119   "RTN","CHM FSTP1F",21 0,0)
  31120    Q
  31121   "RTN","CHM FSTP1F",21 1,0)
  31122    ;
  31123   "RTN","CHM FSTP1F",21 2,0)
  31124   VEPROD ;SE TS PDI INT O C X-REF  IN CHMPROD
  31125   "RTN","CHM FSTP1F",21 3,0)
  31126    S REC21=^ CHMIMG(CHM FPDI,0)
  31127   "RTN","CHM FSTP1F",21 4,0)
  31128    S TMPDUZ= $P(REC21," ^",3),SDAT E=$P(REC21 ,"^",4)
  31129   "RTN","CHM FSTP1F",21 5,0)
  31130    Q:TMPDUZ= ""
  31131   "RTN","CHM FSTP1F",21 6,0)
  31132    S TME=$E( SDATE,11,1 2) I TME<3 0 S TME=0  G VP3
  31133   "RTN","CHM FSTP1F",21 7,0)
  31134    I TME>30  S TME=3
  31135   "RTN","CHM FSTP1F",21 8,0)
  31136   VP3 S SDAT E=+$E(SDAT E,1,10)_TM E/1
  31137   "RTN","CHM FSTP1F",21 9,0)
  31138    S DODATE= $P(SDATE," .",1)
  31139   "RTN","CHM FSTP1F",22 0,0)
  31140   VEP1 S DOD ATE=$O(^CH MPROD(7410 60.01,"C", DODATE)) G :'DODATE V EP2
  31141   "RTN","CHM FSTP1F",22 1,0)
  31142    S NEWPDI= 0
  31143   "RTN","CHM FSTP1F",22 2,0)
  31144    S NEWPDI= $O(^CHMPRO D(741060.0 1,"C",DODA TE,TMPDUZ, NEWPDI)) G :'NEWPDI V EP1
  31145   "RTN","CHM FSTP1F",22 3,0)
  31146    I NEWPDI= CHMFPDI K  ^CHMPROD(7 41060.01," C",DODATE, TMPDUZ,NEW PDI)
  31147   "RTN","CHM FSTP1F",22 4,0)
  31148   VEP2 S ^CH MPROD(7410 60.01,"C", SDATE,TMPD UZ,CHMFPDI )=1
  31149   "RTN","CHM FSTP1F",22 5,0)
  31150    K TMPDUZ, SDATE,REC2 1
  31151   "RTN","CHM FSTP1F",22 6,0)
  31152    Q
  31153   "RTN","CHM FSTP1F",22 7,0)
  31154    ;
  31155   "RTN","CHM FSTP1F",22 8,0)
  31156   CLMCHK X ^ %ZOSF("UCI ")
  31157   "RTN","CHM FSTP1F",22 9,0)
  31158    S UCI=$P( Y,",",1)
  31159   "RTN","CHM FSTP1F",23 0,0)
  31160    S CPT=0
  31161   "RTN","CHM FSTP1F",23 1,0)
  31162   CLM1 S CPT =$O(@(GLOB _"""C"",CP DI,CPT)"))  Q:'CPT
  31163   "RTN","CHM FSTP1F",23 2,0)
  31164    G:'$D(@(G LOB_"CPT,0 )")) CLM1
  31165   "RTN","CHM FSTP1F",23 3,0)
  31166    I $D(^%ZS TAT("CC",U CI,CPT)) K  ^%ZSTAT(" CC",UCI,CP T)
  31167   "RTN","CHM FSTP1F",23 4,0)
  31168    G CLM1
  31169   "RTN","CHM FUTLE")
  31170   0^61^B2350 5215
  31171   "RTN","CHM FUTLE",1,0 )
  31172   CHMFUTLE ; LEG/DEN;ED I X12 ReOp en Utility  Routine;1 0/16/17  0 9:38 AM
  31173   "RTN","CHM FUTLE",2,0 )
  31174    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  31175   "RTN","CHM FUTLE",3,0 )
  31176    ;LEG 10/1 6/2017 CPE 005-001 ad ded "A-ALL " & "A-FIR ST" XREF p rocessing
  31177   "RTN","CHM FUTLE",4,0 )
  31178    ;                in  A5^CHMFADR V   and    in PR2^CHM XF001
  31179   "RTN","CHM FUTLE",5,0 )
  31180    ;CFS 01/0 2/2018 CPE 005-033, 0 35, 038, 0 41, 042 an d 043
  31181   "RTN","CHM FUTLE",6,0 )
  31182    ;                Add ed line ta gs CRCSTAT ,and GETER R for CSTA T processi ng.
  31183   "RTN","CHM FUTLE",7,0 )
  31184    ;CFS 02/0 4/2019 CPE 005-042 an d Defect 9 13649 Chec k the exis tence Orig inal Claim .
  31185   "RTN","CHM FUTLE",8,0 )
  31186    ;                If  the claim  does not e xist, don' t set up ^ CHMIMG(A-A LL or ^CHM IMG("A-FIR ST"
  31187   "RTN","CHM FUTLE",9,0 )
  31188   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
  31189   "RTN","CHM FUTLE",10, 0)
  31190    N I,NEXTP DI,PREVPDI ,PREVPDI
  31191   "RTN","CHM FUTLE",11, 0)
  31192    S FIRST=$ O(^CHMIMG( "A-FIRST", PDI,""))
  31193   "RTN","CHM FUTLE",12, 0)
  31194    ;gathers  all EDI Re Open PDI r elated XRE Fs
  31195   "RTN","CHM FUTLE",13, 0)
  31196    I FIRST M  PDI=^CHMI MG("A-ALL" ,FIRST)
  31197   "RTN","CHM FUTLE",14, 0)
  31198    S PDINUM= PDI,PDI(PD I)="" ; ge ts all pre -PDI links
  31199   "RTN","CHM FUTLE",15, 0)
  31200    F  S REOP REC=$G(^CH MIMG(PDINU M,"E-REOPE N")) Q:'$L ($P(REOPRE C,"^"))  S  PDINUM=$P (REOPREC," ^"),PDI(PD INUM)=""
  31201   "RTN","CHM FUTLE",16, 0)
  31202    Q:PDINUM= ""  ;CFS 0 2/04/2019  CPE005-042
  31203   "RTN","CHM FUTLE",17, 0)
  31204    Q:'$D(^CH MPAY("C",P DINUM))  ; CFS 02/04/ 2019 CPE00 5-042
  31205   "RTN","CHM FUTLE",18, 0)
  31206    S PDINUM= PDI ; gets  all post- PDI links
  31207   "RTN","CHM FUTLE",19, 0)
  31208    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)= ""
  31209   "RTN","CHM FUTLE",20, 0)
  31210    S FIRST=$ O(PDI(0)), LAST=$O(PD I(""),-1), PREV=$O(PD I(PDI),-1) ,NEXT=$O(P DI(PDI))
  31211   "RTN","CHM FUTLE",21, 0)
  31212    S CLMCMPL T=$$CMPCLA IM^CHMFADR 2(PDI)
  31213   "RTN","CHM FUTLE",22, 0)
  31214    ;
  31215   "RTN","CHM FUTLE",23, 0)
  31216    ;establis hes and se ts all ReO pen XREFs  for all ep isodes con taining th e given ne w PDI
  31217   "RTN","CHM FUTLE",24, 0)
  31218   S  ;
  31219   "RTN","CHM FUTLE",25, 0)
  31220    S PDINUM= 0
  31221   "RTN","CHM FUTLE",26, 0)
  31222    F I=0:1 S  PDINUM=$O (PDI(PDINU M)) Q:PDIN UM=""  D   ;
  31223   "RTN","CHM FUTLE",27, 0)
  31224    . I '$D(^ CHMIMG("A- ALL",FIRST ,PDINUM))  S ^CHMIMG( "A-ALL",FI RST,PDINUM )="" ;U 0  W "..A-",F IRST,"-",P DINUM
  31225   "RTN","CHM FUTLE",28, 0)
  31226    . I '$D(^ CHMIMG("A- FIRST",PDI NUM,FIRST) ) S ^CHMIM G("A-FIRST ",PDINUM,F IRST)="" ; U 0 W "..F -",PDINUM, "-",FIRST
  31227   "RTN","CHM FUTLE",29, 0)
  31228    S ^CHMIMG ("A-ALL",F IRST,0)=I
  31229   "RTN","CHM FUTLE",30, 0)
  31230    Q
  31231   "RTN","CHM FUTLE",31, 0)
  31232   PDIXREFS   ;resets al l PDI E-RE OPEN RELAT ED XREFS
  31233   "RTN","CHM FUTLE",32, 0)
  31234    N I,PDI
  31235   "RTN","CHM FUTLE",33, 0)
  31236    S PDI=202 0999999999 99
  31237   "RTN","CHM FUTLE",34, 0)
  31238    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)
  31239   "RTN","CHM FUTLE",35, 0)
  31240    Q
  31241   "RTN","CHM FUTLE",36, 0)
  31242   PDICNTS  ; resets/cal culates co unt of all  episodes
  31243   "RTN","CHM FUTLE",37, 0)
  31244    N I,FIRST PDI,PDICNT ,NEXTPDI
  31245   "RTN","CHM FUTLE",38, 0)
  31246    S FIRSTPD I=0
  31247   "RTN","CHM FUTLE",39, 0)
  31248    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 ;
  31249   "RTN","CHM FUTLE",40, 0)
  31250    . F  S NE XTPDI=$O(^ CHMIMG("A- ALL",FIRST PDI,NEXTPD I)) Q:NEXT PDI=""  S  PDICNT=PDI CNT+1
  31251   "RTN","CHM FUTLE",41, 0)
  31252    . S ^CHMI MG("A-ALL" ,FIRSTPDI, 0)=PDICNT
  31253   "RTN","CHM FUTLE",42, 0)
  31254    W "..",I
  31255   "RTN","CHM FUTLE",43, 0)
  31256    Q
  31257   "RTN","CHM FUTLE",44, 0)
  31258   CHKDUPS(PD I)  ; chec ks if more  than one  PDI points  back to t he same Or iginal PDI
  31259   "RTN","CHM FUTLE",45, 0)
  31260    N ALL
  31261   "RTN","CHM FUTLE",46, 0)
  31262    S ALL=0,P REVPDI=$G( PDI)
  31263   "RTN","CHM FUTLE",47, 0)
  31264    I 'PREVPD I S PREVPD I=20209999 9999999,AL L=1
  31265   "RTN","CHM FUTLE",48, 0)
  31266    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   ;
  31267   "RTN","CHM FUTLE",49, 0)
  31268    . S REORE C=^CHMIMG( PREVPDI,"E -REOPEN"), PREV=$P(RE OREC,"^"), NEXT=$P(RE OREC,"^",2 )
  31269   "RTN","CHM FUTLE",50, 0)
  31270    . 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
  31271   "RTN","CHM FUTLE",51, 0)
  31272    . 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
  31273   "RTN","CHM FUTLE",52, 0)
  31274    Q
  31275   "RTN","CHM FUTLE",53, 0)
  31276   QUECLN  ;c leans out  Queues for  PDIs that  have same  FIRST and  CURRENT P DIs
  31277   "RTN","CHM FUTLE",54, 0)
  31278    F QUE="OC RR-READY", "SBOCRR-RE ADY" D  ;
  31279   "RTN","CHM FUTLE",55, 0)
  31280    . S PDI=" "
  31281   "RTN","CHM FUTLE",56, 0)
  31282    . F  S PD I=$O(^CHMI MG(QUE,PDI )) Q:PDI=" "  D PDIFI RST^CHMFUT LE(PDI,.FI RST,.LAST)  D  Q:KCQ= "Q"
  31283   "RTN","CHM FUTLE",57, 0)
  31284    . . W !!, QUE,?15,"   PDI: ",PD I,!?15,"FI RST: ",FIR ST,!?15,"  LAST: ",LA ST
  31285   "RTN","CHM FUTLE",58, 0)
  31286    . . R !?5 ,"...(K)il l, (C)onti nue OR (Q) uit <C>",K CQ
  31287   "RTN","CHM FUTLE",59, 0)
  31288    . . I KCQ ="K" K ^CH MIMG(QUE,P DI) W "... Killed"
  31289   "RTN","CHM FUTLE",60, 0)
  31290    Q
  31291   "RTN","CHM FUTLE",61, 0)
  31292   QUESTAT  ; displays i nfo regard ing que en try PDIs
  31293   "RTN","CHM FUTLE",62, 0)
  31294    N PDI,AUE
  31295   "RTN","CHM FUTLE",63, 0)
  31296    F QUE="OC RR-READY", "SBOCRR-RE ADY" D  ;
  31297   "RTN","CHM FUTLE",64, 0)
  31298    . S PDI=" "
  31299   "RTN","CHM FUTLE",65, 0)
  31300    . W !!,QU E,?15
  31301   "RTN","CHM FUTLE",66, 0)
  31302    . 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  ;
  31303   "RTN","CHM FUTLE",67, 0)
  31304    . . 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
  31305   "RTN","CHM FUTLE",68, 0)
  31306    . . W !?1 5,"PDI: ", PDI,!?20," FIRST: ",F IRST,?45," LAST: ",LA ST
  31307   "RTN","CHM FUTLE",69, 0)
  31308    . . W !?2 0," PREV:  ",PREV,?45 ,"NEXT: ", NEXT
  31309   "RTN","CHM FUTLE",70, 0)
  31310    . . W !?2 0,"CLAIM C OMPLETE ST ATUS: ",CL MCMPLT
  31311   "RTN","CHM FUTLE",71, 0)
  31312    Q
  31313   "RTN","CHM FUTLE",72, 0)
  31314    ;
  31315   "RTN","CHM FUTLE",73, 0)
  31316   CRCSTAT(PD I,CHXREC,E RRCODE,TYP ERUN)  ;CP E005-033,  035, 038,  041, 042 a nd 043. 
  31317   "RTN","CHM FUTLE",74, 0)
  31318    ;Creates  CSTAT mess age
  31319   "RTN","CHM FUTLE",75, 0)
  31320    ;PDI       = Origina l or Curre nt PDI
  31321   "RTN","CHM FUTLE",76, 0)
  31322    ;CHXREC     = The re cord that  is being l ooked at f rom X12 pr ocessing ( ie. "C000" ,"C005,"E0 00","E015" )
  31323   "RTN","CHM FUTLE",77, 0)
  31324    ;            See the  837 Flat  File Layou t. Default  is the "E 000" recor d if not c alled from  X12 proce ssing.
  31325   "RTN","CHM FUTLE",78, 0)
  31326    ;ERRCODE   = for CST AT in form at (i.e. " F035" )
  31327   "RTN","CHM FUTLE",79, 0)
  31328    ;TYPERUN   = "A" - A cknowledge ment (Gets  created i mmediately )
  31329   "RTN","CHM FUTLE",80, 0)
  31330    ;            "P" - P ending (Go es out in  a batch ca lled by Ta skMan)
  31331   "RTN","CHM FUTLE",81, 0)
  31332    ;            "F" - F inal (Goes  out in a  batch call ed by Task Man)
  31333   "RTN","CHM FUTLE",82, 0)
  31334    ;CLAIMIEN  = The IEN  of the Or iginal PDI  claim (^C HMPAY(IEN) ); Needed  for TYPERU N "P".
  31335   "RTN","CHM FUTLE",83, 0)
  31336    N ERRIEN, PDIXREF,CH EI,ZZ,CHRJ RSN,CHGLBL ,CHFN,CHMX I,AXREF,AX REF6
  31337   "RTN","CHM FUTLE",84, 0)
  31338    S PDI=$G( PDI),CHXRE C=$G(CHXRE C),ERRCODE =$G(ERRCOD E),TYPERUN =$G(TYPERU N)
  31339   "RTN","CHM FUTLE",85, 0)
  31340    Q:('$L(PD I)!'$L(ERR CODE))
  31341   "RTN","CHM FUTLE",86, 0)
  31342    I CHXREC= "" S CHXRE C="E000"
  31343   "RTN","CHM FUTLE",87, 0)
  31344    S ERRIEN= $$GETERR(E RRCODE)
  31345   "RTN","CHM FUTLE",88, 0)
  31346    S PDIXREF =$Q(^CHMXC LE("PDI",P DI))
  31347   "RTN","CHM FUTLE",89, 0)
  31348    S CHEI=$T R($P($P(PD IXREF,"*", 2,99),"*", 3),""")"," ")
  31349   "RTN","CHM FUTLE",90, 0)
  31350    S ZZ=9999 9,ZZ=$O(^C HMXCLE(CHE I,101,ZZ), -1) S:'ZZ  ZZ=0
  31351   "RTN","CHM FUTLE",91, 0)
  31352    S CHRJRSN ="",CHIL=" CHEI",CHGL BL="^CHMXC LE(",CHFN= 741210.121 01
  31353   "RTN","CHM FUTLE",92, 0)
  31354    S CHRCERR (CHXREC,ER RIEN)=""
  31355   "RTN","CHM FUTLE",93, 0)
  31356    D C^CHMXP 003 K CHRC ERR
  31357   "RTN","CHM FUTLE",94, 0)
  31358    S CHMXI=$ P(PDIXREF, ",",4)
  31359   "RTN","CHM FUTLE",95, 0)
  31360    S AXREF=$ Q(^CHMXCLE ("A",CHMXI ))
  31361   "RTN","CHM FUTLE",96, 0)
  31362    I $P(AXRE F,",",3)=2  S AXREF6= AXREF,$P(A XREF6,",", 3)=6,@(AXR EF6)="" K  @(AXREF)
  31363   "RTN","CHM FUTLE",97, 0)
  31364    I TYPERUN ="A" D EPA CK^CHMXWB2 1(CHMXI)
  31365   "RTN","CHM FUTLE",98, 0)
  31366    Q
  31367   "RTN","CHM FUTLE",99, 0)
  31368   GETERR(COD E) ;Get th e IEN out  of Error C ode File 7 41201.32
  31369   "RTN","CHM FUTLE",100 ,0)
  31370    ; CODE =  Error code  from File  741201.32  (ie. "F03 5")
  31371   "RTN","CHM FUTLE",101 ,0)
  31372    N IEN
  31373   "RTN","CHM FUTLE",102 ,0)
  31374    S CODE=$G (CODE)
  31375   "RTN","CHM FUTLE",103 ,0)
  31376    I CODE=""  Q 0
  31377   "RTN","CHM FUTLE",104 ,0)
  31378    S IEN=""
  31379   "RTN","CHM FUTLE",105 ,0)
  31380    S IEN=$O( ^CHMXDIC(7 41201.32," B",CODE,IE N))
  31381   "RTN","CHM FUTLE",106 ,0)
  31382    I IEN=""  Q 0
  31383   "RTN","CHM FUTLE",107 ,0)
  31384    I '$D(^CH MXDIC(7412 01.32,IEN) ) Q 0
  31385   "RTN","CHM FUTLE",108 ,0)
  31386    Q IEN
  31387   "RTN","CHM FUTLE",109 ,0)
  31388    ;
  31389   "RTN","CHM FUTLE2")
  31390   0^62^B8032 653
  31391   "RTN","CHM FUTLE2",1, 0)
  31392   CHMFUTLE ; LEG/DEN;ED I X12 ReOp en Utility  Routine;1 0/16/17  0 9:38 AM
  31393   "RTN","CHM FUTLE2",2, 0)
  31394    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  31395   "RTN","CHM FUTLE2",3, 0)
  31396    ;LEG 10/1 6/2017 CPE 005-001 ad ded "A-ALL " & "A-FIR ST" XREF p rocessing 
  31397   "RTN","CHM FUTLE2",4, 0)
  31398    ;                in  A5^CHMFADR V   and    in PR2^CHM XF001
  31399   "RTN","CHM FUTLE2",5, 0)
  31400    ;
  31401   "RTN","CHM FUTLE2",6, 0)
  31402   PDIFIRST(P DI,FIRST,L AST) ; get s the firs t original  and last  PDIs and s ets xrefs  all in bet ween  
  31403   "RTN","CHM FUTLE2",7, 0)
  31404    N I,NEXTP DI,PREVPDI ,PREVPDI
  31405   "RTN","CHM FUTLE2",8, 0)
  31406    S FIRST=$ O(^CHMIMG( "A-FIRST", PDI,""))
  31407   "RTN","CHM FUTLE2",9, 0)
  31408    ;      ga thers all  EDI ReOpen  PDI relat ed XREFs
  31409   "RTN","CHM FUTLE2",10 ,0)
  31410    I FIRST M  PDI=^CHMI MG("A-ALL" ,FIRST)
  31411   "RTN","CHM FUTLE2",11 ,0)
  31412    S PDINUM= PDI,PDI(PD I)="" ; ge ts all pre -PDI links
  31413   "RTN","CHM FUTLE2",12 ,0)
  31414    F  S REOP REC=$G(^CH MIMG(PDINU M,"E-REOPE N")) Q:'$L ($P(REOPRE C,"^"))  S  PDINUM=$P (REOPREC," ^"),PDI(PD INUM)=""
  31415   "RTN","CHM FUTLE2",13 ,0)
  31416    S PDINUM= $O(PDI(0))  ; gets al l post-PDI  links
  31417   "RTN","CHM FUTLE2",14 ,0)
  31418    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)= ""
  31419   "RTN","CHM FUTLE2",15 ,0)
  31420    S FIRST=$ O(PDI(0)), LAST=$O(PD I(""),-1)
  31421   "RTN","CHM FUTLE2",16 ,0)
  31422    ;
  31423   "RTN","CHM FUTLE2",17 ,0)
  31424    ;      es tablishes  and sets a ll ReOpen  XREFs for  all episod es contain ing the gi ven new PD I
  31425   "RTN","CHM FUTLE2",18 ,0)
  31426   S S PDINUM =0
  31427   "RTN","CHM FUTLE2",19 ,0)
  31428    F I=0:1 S  PDINUM=$O (PDI(PDINU M)) Q:PDIN UM=""  D   ;
  31429   "RTN","CHM FUTLE2",20 ,0)
  31430    . I '$D(^ CHMIMG("A- ALL",FIRST ,PDINUM))  S ^CHMIMG( "A-ALL",FI RST,PDINUM )=""
  31431   "RTN","CHM FUTLE2",21 ,0)
  31432    . I '$D(^ CHMIMG("A- FIRST",PDI NUM,FIRST) ) S ^CHMIM G("A-FIRST ",PDINUM,F IRST)=""
  31433   "RTN","CHM FUTLE2",22 ,0)
  31434    S ^CHMIMG ("A-ALL",F IRST,0)=I
  31435   "RTN","CHM FUTLE2",23 ,0)
  31436    Q
  31437   "RTN","CHM FUTLE2",24 ,0)
  31438   PDIXREFS ;  resets al l PDI E-RE OPEN RELAT ED XREFS
  31439   "RTN","CHM FUTLE2",25 ,0)
  31440    N I,PDI
  31441   "RTN","CHM FUTLE2",26 ,0)
  31442    S PDI=202 0999999999 99 
  31443   "RTN","CHM FUTLE2",27 ,0)
  31444    F I=1:1 S  PDI=$O(^C HMIMG(PDI) ,-1) Q:PDI =""  I $D( ^CHMIMG(PD I,"E-REOPE N")) D PDI FIRST(PDI)  U 0 W ".. ",PDI
  31445   "RTN","CHM FUTLE2",28 ,0)
  31446    Q
  31447   "RTN","CHM FUTLE2",29 ,0)
  31448   PDICNTS ;  resets/cal culates co unt of all  episodes
  31449   "RTN","CHM FUTLE2",30 ,0)
  31450    N I,FIRST PDI,PDICNT ,NEXTPDI
  31451   "RTN","CHM FUTLE2",31 ,0)
  31452    S FIRSTPD I=0
  31453   "RTN","CHM FUTLE2",32 ,0)
  31454    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 ;
  31455   "RTN","CHM FUTLE2",33 ,0)
  31456    . F  S NE XTPDI=$O(^ CHMIMG("A- ALL",FIRST PDI,NEXTPD I)) Q:NEXT PDI=""  S  PDICNT=PDI CNT+1
  31457   "RTN","CHM FUTLE2",34 ,0)
  31458    . S ^CHMI MG("A-ALL" ,FIRSTPDI, 0)=PDICNT
  31459   "RTN","CHM FUTLE2",35 ,0)
  31460    W "..",I
  31461   "RTN","CHM FUTLE2",36 ,0)
  31462    Q
  31463   "RTN","CHM FUTLE2",37 ,0)
  31464   CHKDUPS(PD I) ; check s if more  than one P DI points  back to th e same Ori ginal PDI
  31465   "RTN","CHM FUTLE2",38 ,0)
  31466    N ALL
  31467   "RTN","CHM FUTLE2",39 ,0)
  31468    S ALL=0,P REVPDI=$G( PDI)
  31469   "RTN","CHM FUTLE2",40 ,0)
  31470    I 'PREVPD I S PREVPD I=20209999 9999999,AL L=1
  31471   "RTN","CHM FUTLE2",41 ,0)
  31472    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   ;
  31473   "RTN","CHM FUTLE2",42 ,0)
  31474    . S REORE C=^CHMIMG( PREVPDI,"E -REOPEN"), PREV=$P(RE OREC,"^"), NEXT=$P(RE OREC,"^",2 )
  31475   "RTN","CHM FUTLE2",43 ,0)
  31476    . 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
  31477   "RTN","CHM FUTLE2",44 ,0)
  31478    . 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
  31479   "RTN","CHM FUTLE2",45 ,0)
  31480    Q
  31481   "RTN","CHM KAG5P")
  31482   0^14^B4262 1823
  31483   "RTN","CHM KAG5P",1,0 )
  31484   CHMKAG5P ; CVA/CR;AGI NG OF CLAI MS REPORT  CALC/PRINT ;05/11/98   1:06 PM
  31485   "RTN","CHM KAG5P",2,0 )
  31486    ;;1.0;CHA MPVA SYSTE M;**14**;D ECEMBER 08 , 2010;Bui ld 5
  31487   "RTN","CHM KAG5P",3,0 )
  31488    ;DPT MTN0 16163 3/12 /13 ADD SX C/CATARAMA N, REMOVE  ZZ IN GRP2  
  31489   "RTN","CHM KAG5P",4,0 )
  31490    ;S CHBDT= 3020205
  31491   "RTN","CHM KAG5P",5,0 )
  31492    ;S CHEDT= 3020205
  31493   "RTN","CHM KAG5P",6,0 )
  31494    ;S MENUVA L="3^HAC S UMMARY^CHA MPVA,CITI, CFL,CVAF,C WVV,SB,FMP ^"
  31495   "RTN","CHM KAG5P",7,0 )
  31496    ;CFS 02/2 8/2019 - O riginally  done by Ka thryn Leyv a (KLM) Us er Stories  CPE005-02 4a and 024 b.
  31497   "RTN","CHM KAG5P",8,0 )
  31498    ;                     Add EDI R O as a new  category  to the rep ort.
  31499   "RTN","CHM KAG5P",9,0 )
  31500    K AGEARR
  31501   "RTN","CHM KAG5P",10, 0)
  31502    D COMPILE
  31503   "RTN","CHM KAG5P",11, 0)
  31504    D PRINT
  31505   "RTN","CHM KAG5P",12, 0)
  31506    Q
  31507   "RTN","CHM KAG5P",13, 0)
  31508   COMPILE S  CHDT=(CHBD T\1)-.0001
  31509   "RTN","CHM KAG5P",14, 0)
  31510    S CHBBEG= "",CHBEND= ""
  31511   "RTN","CHM KAG5P",15, 0)
  31512    S PRGMSTR =$P(MENUVA L,"^",3)
  31513   "RTN","CHM KAG5P",16, 0)
  31514    S SUMFLG= +$P(MENUVA L,"^",4)
  31515   "RTN","CHM KAG5P",17, 0)
  31516    F  S CHDT =$O(^CHAGE ("C",CHDT) ) Q:CHDT\1 >CHEDT  Q: 'CHDT  D
  31517   "RTN","CHM KAG5P",18, 0)
  31518    .S CHB=0
  31519   "RTN","CHM KAG5P",19, 0)
  31520    .F  S CHB =$O(^CHAGE ("C",CHDT, CHB)) Q:'C HB  D
  31521   "RTN","CHM KAG5P",20, 0)
  31522    ..S:CHBBE G="" CHBBE G=CHB
  31523   "RTN","CHM KAG5P",21, 0)
  31524    ..S CHBEN D=CHB
  31525   "RTN","CHM KAG5P",22, 0)
  31526    ..F X=1:1  S PRGM=$P (PRGMSTR," ,",X) Q:PR GM=""  D
  31527   "RTN","CHM KAG5P",23, 0)
  31528    ...S PRGM 1=PRGM
  31529   "RTN","CHM KAG5P",24, 0)
  31530    ...S:SUMF LG PRGM1=" SUMMARY"
  31531   "RTN","CHM KAG5P",25, 0)
  31532    ...S GRP= ""
  31533   "RTN","CHM KAG5P",26, 0)
  31534    ...F  S G RP=$O(^CHA GE(CHB,PRG M,GRP)) Q: GRP=""  D
  31535   "RTN","CHM KAG5P",27, 0)
  31536    ....S CAT =""
  31537   "RTN","CHM KAG5P",28, 0)
  31538    ....F  S  CAT=$O(^CH AGE(CHB,PR GM,GRP,CAT )) Q:CAT=" "  D
  31539   "RTN","CHM KAG5P",29, 0)
  31540    .....S TI ME=""
  31541   "RTN","CHM KAG5P",30, 0)
  31542    .....F  S  TIME=$O(^ CHAGE(CHB, PRGM,GRP,C AT,TIME))  Q:TIME=""   D
  31543   "RTN","CHM KAG5P",31, 0)
  31544    ......S C NT1=+$P(^C HAGE(CHB,P RGM,GRP,CA T,TIME),"^ ")
  31545   "RTN","CHM KAG5P",32, 0)
  31546    ......S C NT2=+$P(^C HAGE(CHB,P RGM,GRP,CA T,TIME),"^ ",2)
  31547   "RTN","CHM KAG5P",33, 0)
  31548    ......; D o not coun t time it  time is 0
  31549   "RTN","CHM KAG5P",34, 0)
  31550    ......I T IME I TIME <CHLOW D
  31551   "RTN","CHM KAG5P",35, 0)
  31552    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",1 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",1)+CN T1
  31553   "RTN","CHM KAG5P",36, 0)
  31554    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",4 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",4)+CN T2
  31555   "RTN","CHM KAG5P",37, 0)
  31556    .......S  $P(AGEARR( PRGM1,GRP) ,"^",1)=$P ($G(AGEARR (PRGM1,GRP )),"^",1)+ CNT1
  31557   "RTN","CHM KAG5P",38, 0)
  31558    .......S  $P(AGEARR( PRGM1,GRP) ,"^",4)=$P ($G(AGEARR (PRGM1,GRP )),"^",4)+ CNT2
  31559   "RTN","CHM KAG5P",39, 0)
  31560    ......; D o not coun t time it  time is 0
  31561   "RTN","CHM KAG5P",40, 0)
  31562    ......I T IME I TIME <CHMID D   ;TLH 6/5/0 7 DEV00027 1
  31563   "RTN","CHM KAG5P",41, 0)
  31564    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",2 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",2)+CN T1  ;TLH 6 /5/07 DEV0 00271
  31565   "RTN","CHM KAG5P",42, 0)
  31566    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",5 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",5)+CN T2  ;TLH 6 /5/07 DEV0 00271
  31567   "RTN","CHM KAG5P",43, 0)
  31568    .......S  $P(AGEARR( PRGM1,GRP) ,"^",2)=$P ($G(AGEARR (PRGM1,GRP )),"^",2)+ CNT1  ;TLH  6/5/07 DE V000271
  31569   "RTN","CHM KAG5P",44, 0)
  31570    .......S  $P(AGEARR( PRGM1,GRP) ,"^",5)=$P ($G(AGEARR (PRGM1,GRP )),"^",5)+ CNT2  ;TLH  6/5/07 DE V000271
  31571   "RTN","CHM KAG5P",45, 0)
  31572    ......; D o not coun t time it  time is 0
  31573   "RTN","CHM KAG5P",46, 0)
  31574    ......I T IME I TIME <CHHIGH D
  31575   "RTN","CHM KAG5P",47, 0)
  31576    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",3 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",3)+CN T1
  31577   "RTN","CHM KAG5P",48, 0)
  31578    .......S  $P(AGEARR( PRGM1,GRP, CAT),"^",6 )=$P($G(AG EARR(PRGM1 ,GRP,CAT)) ,"^",6)+CN T2
  31579   "RTN","CHM KAG5P",49, 0)
  31580    .......S  $P(AGEARR( PRGM1,GRP) ,"^",3)=$P ($G(AGEARR (PRGM1,GRP )),"^",3)+ CNT1
  31581   "RTN","CHM KAG5P",50, 0)
  31582    .......S  $P(AGEARR( PRGM1,GRP) ,"^",6)=$P ($G(AGEARR (PRGM1,GRP )),"^",6)+ CNT2
  31583   "RTN","CHM KAG5P",51, 0)
  31584    ......S $ P(AGEARR(P RGM1,GRP,C AT),"^",7) =$P($G(AGE ARR(PRGM1, GRP,CAT)), "^",7)+CNT 1
  31585   "RTN","CHM KAG5P",52, 0)
  31586    ......S $ P(AGEARR(P RGM1,GRP,C AT),"^",8) =$P($G(AGE ARR(PRGM1, GRP,CAT)), "^",8)+(CN T1*TIME)
  31587   "RTN","CHM KAG5P",53, 0)
  31588    ......S $ P(AGEARR(P RGM1,GRP,C AT),"^",9) =$P($G(AGE ARR(PRGM1, GRP,CAT)), "^",9)+(CN T2*TIME)
  31589   "RTN","CHM KAG5P",54, 0)
  31590    ......S $ P(AGEARR(P RGM1,GRP), "^",7)=$P( $G(AGEARR( PRGM1,GRP) ),"^",7)+C NT1
  31591   "RTN","CHM KAG5P",55, 0)
  31592    ......S $ P(AGEARR(P RGM1,GRP), "^",8)=$P( $G(AGEARR( PRGM1,GRP) ),"^",8)+( CNT1*TIME)
  31593   "RTN","CHM KAG5P",56, 0)
  31594    ......S $ P(AGEARR(P RGM1,GRP), "^",9)=$P( $G(AGEARR( PRGM1,GRP) ),"^",9)+( CNT2*TIME)
  31595   "RTN","CHM KAG5P",57, 0)
  31596    Q
  31597   "RTN","CHM KAG5P",58, 0)
  31598   PRINT ;
  31599   "RTN","CHM KAG5P",59, 0)
  31600    N PC
  31601   "RTN","CHM KAG5P",60, 0)
  31602    S PG=0
  31603   "RTN","CHM KAG5P",61, 0)
  31604    S PCNT=0
  31605   "RTN","CHM KAG5P",62, 0)
  31606    I SUMFLG  F PRGM="SU MMARY" D P 1
  31607   "RTN","CHM KAG5P",63, 0)
  31608    Q:SUMFLG
  31609   "RTN","CHM KAG5P",64, 0)
  31610    F PC=1:1  S PRGM=$P( PRGMSTR,", ",PC) Q:PR GM=""  D
  31611   "RTN","CHM KAG5P",65, 0)
  31612    .D P1
  31613   "RTN","CHM KAG5P",66, 0)
  31614    Q
  31615   "RTN","CHM KAG5P",67, 0)
  31616   P1 ;  
  31617   "RTN","CHM KAG5P",68, 0)
  31618    ;S PCNT=P CNT+1
  31619   "RTN","CHM KAG5P",69, 0)
  31620    ;I PCNT>2  D HDR S P CNT=1
  31621   "RTN","CHM KAG5P",70, 0)
  31622    D HDR
  31623   "RTN","CHM KAG5P",71, 0)
  31624    W !
  31625   "RTN","CHM KAG5P",72, 0)
  31626    W PRGM
  31627   "RTN","CHM KAG5P",73, 0)
  31628    D GRP1
  31629   "RTN","CHM KAG5P",74, 0)
  31630    D GRP2
  31631   "RTN","CHM KAG5P",75, 0)
  31632    D GRP3
  31633   "RTN","CHM KAG5P",76, 0)
  31634    D GRP4
  31635   "RTN","CHM KAG5P",77, 0)
  31636    W !
  31637   "RTN","CHM KAG5P",78, 0)
  31638    Q
  31639   "RTN","CHM KAG5P",79, 0)
  31640   GRP1 ;
  31641   "RTN","CHM KAG5P",80, 0)
  31642    S GRP=1
  31643   "RTN","CHM KAG5P",81, 0)
  31644    S VAR="AG EARR(PRGM, GRP,CAT)"
  31645   "RTN","CHM KAG5P",82, 0)
  31646    F CAT="PR OVIDER","B ENE","REJE CT" S CATN M=CAT D DE T
  31647   "RTN","CHM KAG5P",83, 0)
  31648    D SUM
  31649   "RTN","CHM KAG5P",84, 0)
  31650    Q
  31651   "RTN","CHM KAG5P",85, 0)
  31652   GRP2 ;
  31653   "RTN","CHM KAG5P",86, 0)
  31654    W !
  31655   "RTN","CHM KAG5P",87, 0)
  31656    S GRP=2
  31657   "RTN","CHM KAG5P",88, 0)
  31658    S VAR="AG EARR(PRGM, GRP,CAT)"
  31659   "RTN","CHM KAG5P",89, 0)
  31660    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
  31661   "RTN","CHM KAG5P",90, 0)
  31662    D SUM
  31663   "RTN","CHM KAG5P",91, 0)
  31664    Q
  31665   "RTN","CHM KAG5P",92, 0)
  31666   GRP3 ;
  31667   "RTN","CHM KAG5P",93, 0)
  31668    W !
  31669   "RTN","CHM KAG5P",94, 0)
  31670    S GRP=3
  31671   "RTN","CHM KAG5P",95, 0)
  31672    S VAR="AG EARR(PRGM, GRP,CAT)"
  31673   "RTN","CHM KAG5P",96, 0)
  31674    F CAT=1:1 :$P(^CHMDI C(741002.0 5,0),"^",4 ) D
  31675   "RTN","CHM KAG5P",97, 0)
  31676    .S CATNM= $P(^CHMDIC (741002.05 ,CAT,0),"^ ",2)
  31677   "RTN","CHM KAG5P",98, 0)
  31678    .D DET
  31679   "RTN","CHM KAG5P",99, 0)
  31680    D SUM
  31681   "RTN","CHM KAG5P",100 ,0)
  31682    Q
  31683   "RTN","CHM KAG5P",101 ,0)
  31684   GRP4 ;
  31685   "RTN","CHM KAG5P",102 ,0)
  31686    W !
  31687   "RTN","CHM KAG5P",103 ,0)
  31688    S GRP=4
  31689   "RTN","CHM KAG5P",104 ,0)
  31690    S VAR="AG EARR(PRGM, GRP,CAT)"
  31691   "RTN","CHM KAG5P",105 ,0)
  31692    S (CAT,CA TNM)="Not  Covered Sv c" D DET
  31693   "RTN","CHM KAG5P",106 ,0)
  31694    S (CAT,CA TNM)="Form  dt < Svc"  D DET
  31695   "RTN","CHM KAG5P",107 ,0)
  31696    S (CAT,CA TNM)="No D X/PX/NDC"  D DET
  31697   "RTN","CHM KAG5P",108 ,0)
  31698    S (CAT,CA TNM)="Clm  denied-oth " D DET
  31699   "RTN","CHM KAG5P",109 ,0)
  31700    S (CAT,CA TNM)="No O HI EOB" D  DET
  31701   "RTN","CHM KAG5P",110 ,0)
  31702    S (CAT,CA TNM)="No C VA Clm for m" D DET
  31703   "RTN","CHM KAG5P",111 ,0)
  31704    S (CAT,CA TNM)="Clm  not signed " D DET
  31705   "RTN","CHM KAG5P",112 ,0)
  31706    S (CAT,CA TNM)="Inel ig bene" D  DET
  31707   "RTN","CHM KAG5P",113 ,0)
  31708    S (CAT,CA TNM)="No p re-auth" D  DET
  31709   "RTN","CHM KAG5P",114 ,0)
  31710    S (CAT,CA TNM)="Clm  miss info"  D DET
  31711   "RTN","CHM KAG5P",115 ,0)
  31712    S (CAT,CA TNM)="Rej  0 Paid" D  DET
  31713   "RTN","CHM KAG5P",116 ,0)
  31714    S (CAT,CA TNM)="No R sn Cat Id"  D DET
  31715   "RTN","CHM KAG5P",117 ,0)
  31716    W ?8 F X= 1:1:15 W " -"
  31717   "RTN","CHM KAG5P",118 ,0)
  31718    W !
  31719   "RTN","CHM KAG5P",119 ,0)
  31720    S (CAT,CA TNM)="Paid " D DET
  31721   "RTN","CHM KAG5P",120 ,0)
  31722    S (CAT,CA TNM)="0 Pa id w/ rsn"  D DET
  31723   "RTN","CHM KAG5P",121 ,0)
  31724    S (CAT,CA TNM)="0 Pa id w/o rsn " D DET
  31725   "RTN","CHM KAG5P",122 ,0)
  31726    D SUM
  31727   "RTN","CHM KAG5P",123 ,0)
  31728    Q
  31729   "RTN","CHM KAG5P",124 ,0)
  31730   DET ;
  31731   "RTN","CHM KAG5P",125 ,0)
  31732    S (HAC14, HAC21,HAC3 0,AAC14,AA C21,AAC30, CLMTOT,HAC AVG,AACAVG )=0
  31733   "RTN","CHM KAG5P",126 ,0)
  31734    S CLMTOT= +$P($G(@VA R),"^",7)   ;TLH 6/5/ 07 DEV0002 71
  31735   "RTN","CHM KAG5P",127 ,0)
  31736    I CLMTOT> 0 D
  31737   "RTN","CHM KAG5P",128 ,0)
  31738    .S HAC14= $P(@VAR,"^ ",1)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  31739   "RTN","CHM KAG5P",129 ,0)
  31740    .S HAC21= $P(@VAR,"^ ",2)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  31741   "RTN","CHM KAG5P",130 ,0)
  31742    .S HAC30= $P(@VAR,"^ ",3)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  31743   "RTN","CHM KAG5P",131 ,0)
  31744    .S AAC14= $P(@VAR,"^ ",4)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  31745   "RTN","CHM KAG5P",132 ,0)
  31746    .S AAC21= $P(@VAR,"^ ",5)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  31747   "RTN","CHM KAG5P",133 ,0)
  31748    .S AAC30= $P(@VAR,"^ ",6)/CLMTO T*100  ;TL H 6/5/07 D EV000271
  31749   "RTN","CHM KAG5P",134 ,0)
  31750    .S HACAVG =$P(@VAR," ^",8)/CLMT OT  ;TLH 6 /5/07 DEV0 00271
  31751   "RTN","CHM KAG5P",135 ,0)
  31752    .S AACAVG =$P(@VAR," ^",9)/CLMT OT  ;TLH 6 /5/07 DEV0 00271
  31753   "RTN","CHM KAG5P",136 ,0)
  31754    W ?8,$E(C ATNM,1,15)
  31755   "RTN","CHM KAG5P",137 ,0)
  31756    W ?30,$J( HAC14,6,2)   ;TLH 6/5 /07 DEV000 271
  31757   "RTN","CHM KAG5P",138 ,0)
  31758    W ?40,$J( HAC21,6,2)   ;TLH 6/6 /07 DEV000 271
  31759   "RTN","CHM KAG5P",139 ,0)
  31760    W ?50,$J( HAC30,6,2)   ;TLH 6/6 /07 DEV002 71
  31761   "RTN","CHM KAG5P",140 ,0)
  31762    W ?65,$J( AAC14,6,2)   ;TLH 6/6 /07 DEV000 271
  31763   "RTN","CHM KAG5P",141 ,0)
  31764    W ?75,$J( AAC21,6,2)   ;TLH 6/6 /07 DEV000 271
  31765   "RTN","CHM KAG5P",142 ,0)
  31766    W ?85,$J( AAC30,6,2)   ;TLH 6/6 /07 DEV000 271
  31767   "RTN","CHM KAG5P",143 ,0)
  31768    W ?100,$J (HACAVG,6, 1)  ;TLH 6 /6/07 DEV0 00271
  31769   "RTN","CHM KAG5P",144 ,0)
  31770    W ?110,$J (AACAVG,6, 1)  ;TLH 6 /6/07 DEV0 00271
  31771   "RTN","CHM KAG5P",145 ,0)
  31772    W ?121,$J (CLMTOT,9)   ;TLH 6/6 /07 DEV000 271
  31773   "RTN","CHM KAG5P",146 ,0)
  31774    W !
  31775   "RTN","CHM KAG5P",147 ,0)
  31776    Q
  31777   "RTN","CHM KAG5P",148 ,0)
  31778   SUM ;
  31779   "RTN","CHM KAG5P",149 ,0)
  31780    W ?8
  31781   "RTN","CHM KAG5P",150 ,0)
  31782    F X=1:1:1 25 W "-"   ;TLH 6/6/0 7 DEV00027 1
  31783   "RTN","CHM KAG5P",151 ,0)
  31784    W !
  31785   "RTN","CHM KAG5P",152 ,0)
  31786    S CATNM=" TOTAL"
  31787   "RTN","CHM KAG5P",153 ,0)
  31788    S VAR="AG EARR(PRGM, GRP)"
  31789   "RTN","CHM KAG5P",154 ,0)
  31790    D DET
  31791   "RTN","CHM KAG5P",155 ,0)
  31792    Q
  31793   "RTN","CHM KAG5P",156 ,0)
  31794   HDR ;
  31795   "RTN","CHM KAG5P",157 ,0)
  31796    W @IOF
  31797   "RTN","CHM KAG5P",158 ,0)
  31798    S TITLE=" HEALTH ADM INISTRATIO N CENTER"
  31799   "RTN","CHM KAG5P",159 ,0)
  31800    S TAB1=13 2-$L(TITLE )/2  ;TLH  6/6/07 DEV 000271
  31801   "RTN","CHM KAG5P",160 ,0)
  31802    D NOW^%DT C S PG=PG+ 1,PAGE="Pa ge: "_PG
  31803   "RTN","CHM KAG5P",161 ,0)
  31804    W !,$$FMT E^XLFDT(X, "2D"),?TAB 1,TITLE,?1 22,PAGE  ; TLH 6/6/07  DEV000271
  31805   "RTN","CHM KAG5P",162 ,0)
  31806    W !,$E($P (%,".",2), 1,4),?53," Summary Ag ing of Cla ims"  ;TLH  6/6/07 DE V000271
  31807   "RTN","CHM KAG5P",163 ,0)
  31808    S TITLE2= $$FMTE^XLF DT(CHBDT,2 )_" - "_$$ FMTE^XLFDT (CHEDT\1,2 )
  31809   "RTN","CHM KAG5P",164 ,0)
  31810    S TAB1=13 2-$L(TITLE 2)/2  ;TLH  6/6/07 DE V000271
  31811   "RTN","CHM KAG5P",165 ,0)
  31812    W !,?TAB1 ,TITLE2
  31813   "RTN","CHM KAG5P",166 ,0)
  31814    S TITLE2= "Batch: "_ CHBBEG_" -  "_CHBEND
  31815   "RTN","CHM KAG5P",167 ,0)
  31816    S TAB1=13 2-$L(TITLE 2)/2  ;TLH  6/6/07 DE V000271
  31817   "RTN","CHM KAG5P",168 ,0)
  31818    W !,?TAB1 ,TITLE2
  31819   "RTN","CHM KAG5P",169 ,0)
  31820    I SUMFLG  D
  31821   "RTN","CHM KAG5P",170 ,0)
  31822    .S TITLE3 =$P(MENUVA L,"^",2)_"  ("_$P(MEN UVAL,"^",3 )_")"
  31823   "RTN","CHM KAG5P",171 ,0)
  31824    .S TAB1=1 32-$L(TITL E3)/2  ;TL H 6/6/07 D EV000271
  31825   "RTN","CHM KAG5P",172 ,0)
  31826    .W !,?TAB 1,TITLE3
  31827   "RTN","CHM KAG5P",173 ,0)
  31828    W !!,?40, "HAC % Und er",?72,"H AC/AAC % U nder",?105 ,"Avg Days "  ;TLH 6/ 6/07 DEV00 0271
  31829   "RTN","CHM KAG5P",174 ,0)
  31830    W ?124,"T otal",!  ; TLH 6/6/07  DEV000271
  31831   "RTN","CHM KAG5P",175 ,0)
  31832    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
  31833   "RTN","CHM KAG5P",176 ,0)
  31834    W ?75,CHM ID_" Days" ,?85,CHHIG H_" Days", ?103,"HAC" ,?110,"HAC /AAC",?124 ,"Claims", !  ;TLH 6/ 6/07 DEV00 0271
  31835   "RTN","CHM KAG5P",177 ,0)
  31836    F X=1:1:1 32 W "-"   ;TLH 6/6/0 7 DEV00027 1
  31837   "RTN","CHM KAG5P",178 ,0)
  31838    Q
  31839   "RTN","CHM KAG5P",179 ,0)
  31840    ;
  31841   "RTN","CHM XF001")
  31842   0^15^B8363 2900
  31843   "RTN","CHM XF001",1,0 )
  31844   CHMXF001 ; CVA/DTP;X1 2 837 CLAI M CREATION  DRIVER (H EALTH CARE  CLAIMS);0 2/05/99  8 :18 AM
  31845   "RTN","CHM XF001",2,0 )
  31846    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  31847   "RTN","CHM XF001",3,0 )
  31848    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  31849   "RTN","CHM XF001",4,0 )
  31850    ;PT 15932  (Y2K)
  31851   "RTN","CHM XF001",5,0 )
  31852    ;;CALLED  BY CHMXDR0 1-HC CLAIM  (837) MAI N DRIVER A FTER READI N/EDITS
  31853   "RTN","CHM XF001",6,0 )
  31854    ;KKAIEL
  31855   "RTN","CHM XF001",7,0 )
  31856    ;jsg;DEV0 02841-02;4 /30/09;Cre ate ^CHMIM G("VEN-EDI ") for ASV  procesing  in lieu o f "OCR-REA DY"
  31857   "RTN","CHM XF001",8,0 )
  31858    ;HR-COB-M edicare-A/ B-Begin-93 72 (22-Mar -2010)
  31859   "RTN","CHM XF001",9,0 )
  31860    ;JSG2;CPE 005-023;Ad d in new C HAMPVA SYS TEM STATUS  (EDI-REOP EN)
  31861   "RTN","CHM XF001",10, 0)
  31862    ;CFS 10/2 0/2017 - C PE005-004  Add "OCRR- READY" and  "SBOCRR-R EADY" queu es.
  31863   "RTN","CHM XF001",11, 0)
  31864    ;CFS 12/1 5/2017 - C PE005-001  Get Freque ncy Code f or Re-open  PDI gener ation.
  31865   "RTN","CHM XF001",12, 0)
  31866    ;BDB 02/0 6/2018 - C PE005-042  Set PDI st atus, bloc k ready qu eue
  31867   "RTN","CHM XF001",13, 0)
  31868    ;TGH 02/1 6/2018 - C PE005-043  Set PDI in to EDI-PAU SE and if  entered bl ock the re ady queue
  31869   "RTN","CHM XF001",14, 0)
  31870    ;TGH 02/1 6/2018 - C PE005-043  Check EDI- PAUSE entr ies for co mpletion o r changes  to claims 
  31871   "RTN","CHM XF001",15, 0)
  31872    ;                               at beginni ng of each  routine r un
  31873   "RTN","CHM XF001",16, 0)
  31874    ;BDB 01/1 6/19 Rejec t Frequenc y Code 6
  31875   "RTN","CHM XF001",17, 0)
  31876    ;Q:(CHDUZ HLD'=84)&( CHDUZHLD'= 83)
  31877   "RTN","CHM XF001",18, 0)
  31878    D DEBUG^C HMXDR01("  ARRIVED @  CHMXF001:  CHTP= ",CH TP)
  31879   "RTN","CHM XF001",19, 0)
  31880    ;CPE005-0 43 Check E DI-PAUSE q ueue for c ompletion  or changes  to claims  and remov e from Que ue
  31881   "RTN","CHM XF001",20, 0)
  31882    D PAUSECH K^CHROLIB1
  31883   "RTN","CHM XF001",21, 0)
  31884    K PDIFLG, CHXSTYP,CH XCLTYP,CHX FLVR ; PDI FLG ENSURE S PROCESSI NG FOR ONL Y PDI-ASSO CIATED REC ORDS
  31885   "RTN","CHM XF001",22, 0)
  31886   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
  31887   "RTN","CHM XF001",23, 0)
  31888    S CHMXI=C HMXCLI
  31889   "RTN","CHM XF001",24, 0)
  31890    S (CHAI,C HACLCT,CHA DLCT)=0
  31891   "RTN","CHM XF001",25, 0)
  31892   LOOP1 S CH AI=$O(^CHM XCLE("A",C HMXI,1,CHA I)) I CHAI ="" D TOTS UM G END1
  31893   "RTN","CHM XF001",26, 0)
  31894    S CHAIHLD =CHAI
  31895   "RTN","CHM XF001",27, 0)
  31896    S CHCL=0
  31897   "RTN","CHM XF001",28, 0)
  31898   LOOP2 S CH CL=$O(^CHM XCLE("A",C HMXI,1,CHA I,CHCL)) I  'CHCL D S UM G LOOP1
  31899   "RTN","CHM XF001",29, 0)
  31900    S CHID=""
  31901   "RTN","CHM XF001",30, 0)
  31902   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
  31903   "RTN","CHM XF001",31, 0)
  31904    D:$D(PDIF LG) PROCES S
  31905   "RTN","CHM XF001",32, 0)
  31906    G:CHID=""  LOOP2
  31907   "RTN","CHM XF001",33, 0)
  31908    S CHBI=$P (CHID,"*", 1),CHCI=$P (CHID,"*", 2),CHEI=$P (CHID,"*", 3),CHIDHLD =CHID
  31909   "RTN","CHM XF001",34, 0)
  31910    S:$D(^CHM XCLC(CHCI, 80)) CHPYF ILE="^"_$P (^CHMXCLC( CHCI,80)," ^",4) ; BE NE PAYMENT  FILE DEFI NED
  31911   "RTN","CHM XF001",35, 0)
  31912    S:$D(^CHM XCLA(CHAI, 80)) CHXST YP=$P(^CHM XCLA(CHAI, 80),"^",7)  ; EDI/OCR  FLAG
  31913   "RTN","CHM XF001",36, 0)
  31914    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)
  31915   "RTN","CHM XF001",37, 0)
  31916    .S CHXFLV R=$P(^CHMX CLE(CHEI,0 ),"^",5),C HMFREQ=$P( ^CHMXCLE(C HEI,0),"^" ,6)
  31917   "RTN","CHM XF001",38, 0)
  31918    ;S:$D(^CH MXCLE(CHEI ,0)) CHXFL VR=$P(^CHM XCLE(CHEI, 0),"^",5)  ; CLAIM FL AVOR DEFIN ED (INST/P ROF/DENTAL )
  31919   "RTN","CHM XF001",39, 0)
  31920    ;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)
  31921   "RTN","CHM XF001",40, 0)
  31922    S:CHXFLVR ="C" CHXCL TYP=3
  31923   "RTN","CHM XF001",41, 0)
  31924    S:(CHXFLV R="A")&(CH XSTYP=0) C HXCLTYP=1
  31925   "RTN","CHM XF001",42, 0)
  31926    S:(CHXFLV R="A")&(CH XSTYP=1) C HXCLTYP=4
  31927   "RTN","CHM XF001",43, 0)
  31928    S:(CHXFLV R="B")&(CH XSTYP=0) C HXCLTYP=2
  31929   "RTN","CHM XF001",44, 0)
  31930    S:(CHXFLV R="B")&(CH XSTYP=1) C HXCLTYP=5
  31931   "RTN","CHM XF001",45, 0)
  31932    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"))
  31933   "RTN","CHM XF001",46, 0)
  31934    ;HR-COB-M edicare-A/ B-Begin-93 72 (22-Mar -2010)
  31935   "RTN","CHM XF001",47, 0)
  31936    ;S CHTPID =$P(^CHMXC LA(CHAI,1) ,"^") I CH TPID="" S  CHVNPRB=""  G END
  31937   "RTN","CHM XF001",48, 0)
  31938    D DEBUG^C HMXDR01("B EFORE GETC HTPI(): CH TP= ",CHTP )
  31939   "RTN","CHM XF001",49, 0)
  31940    I CHTP=""  S CHVNPRB ="" G END
  31941   "RTN","CHM XF001",50, 0)
  31942    ;S VN=0,V N=$O(^CHMX TP("C",CHT PID,VN)) I  'VN S CHV NPRB="" G  END
  31943   "RTN","CHM XF001",51, 0)
  31944    S VN=$$GE TCHTPI^CHM XDR01
  31945   "RTN","CHM XF001",52, 0)
  31946    D DEBUG^C HMXDR01("D O GETCHTPI (): CHTP^V N= ",CHTP_ "^"_VN)
  31947   "RTN","CHM XF001",53, 0)
  31948    I 'VN S C HVNPRB=""  G END
  31949   "RTN","CHM XF001",54, 0)
  31950    ;HR-COB-M edicare-A/ B-End-9372
  31951   "RTN","CHM XF001",55, 0)
  31952    S CHTPID= $P(^CHMXTP (VN,0),"^" ,10)
  31953   "RTN","CHM XF001",56, 0)
  31954    ;K MXVEN, CHMXVNRC,C HVNFCTP
  31955   "RTN","CHM XF001",57, 0)
  31956    S (MXVEN, CHMXVNRC,C HVNFCTP,CH PSVNM,CHPS VTX,CHPSVA D,CHPSVCY, CHPSVST,CH PSVZP)=""
  31957   "RTN","CHM XF001",58, 0)
  31958    S:$D(^CHM XCLB(CHBI, 80)) CHMXV NRC=^CHMXC LB(CHBI,80 ),MXVEN=$P (CHMXVNRC, "^"),CHVNF CTP=$P(CHM XVNRC,"^", 2)
  31959   "RTN","CHM XF001",59, 0)
  31960    ;I MXVEN= "" S CHVNM MRS=2,^CHM XCLE("VNDR  DELT",CHM XI,CHAI,CH ID)="" K P DIFLG G LO OP3
  31961   "RTN","CHM XF001",60, 0)
  31962    D DEBUG^C HMXDR01("C HMXF001: M XVEN= ",MX VEN)
  31963   "RTN","CHM XF001",61, 0)
  31964    I MXVEN D
  31965   "RTN","CHM XF001",62, 0)
  31966    .S (VREC0 ,VREC1,VRE C2,VREC5,V REC41,X1,X 2,X3,X4,X5 )=""
  31967   "RTN","CHM XF001",63, 0)
  31968    .S:$D(^CH MVEN(MXVEN ,0)) VREC0 =^(0) S:$D (^CHMVEN(M XVEN,1)) V REC1=^(1)
  31969   "RTN","CHM XF001",64, 0)
  31970    .S:$D(^CH MVEN(MXVEN ,2)) VREC2 =^(2) S:$D (^CHMVEN(M XVEN,5)) V REC5=^(1)
  31971   "RTN","CHM XF001",65, 0)
  31972    .S JJ="A" ,JJ=$O(^CH MVEN(MXVEN ,41,JJ),-1 )
  31973   "RTN","CHM XF001",66, 0)
  31974    .I JJ I $ D(^CHMVEN( MXVEN,41,J J,0)) S VR EC41=^(0)
  31975   "RTN","CHM XF001",67, 0)
  31976    .S X1=$P( VREC0,"^", 1)_"^"_$P( VREC0,"^", 3)
  31977   "RTN","CHM XF001",68, 0)
  31978    .S X2=$P( VREC2,"^", 1)_"^"_$P( VREC2,"^", 2)_"^"_$P( VREC2,"^", 3)_"^"_$P( VREC2,"^", 4)_"^"_$P( VREC2,"^", 5)_"^"_$P( VREC2,"^", 6)
  31979   "RTN","CHM XF001",69, 0)
  31980    .S X3=$P( VREC1,"^", 7)_"^"_$P( VREC1,"^", 11)
  31981   "RTN","CHM XF001",70, 0)
  31982    .S X4=$P( VREC5,"^", 5),X5=$P(V REC41,"^", 3)
  31983   "RTN","CHM XF001",71, 0)
  31984    E  D
  31985   "RTN","CHM XF001",72, 0)
  31986    .D DEBUG^ CHMXDR01(" $D(^CHMXCL B(CHBI,0)) = ",'$D(^C HMXCLB(CHB I,0)))
  31987   "RTN","CHM XF001",73, 0)
  31988    .Q:'$D(^C HMXCLB(CHB I,0))  S V REC0=^(0)
  31989   "RTN","CHM XF001",74, 0)
  31990    .S CHPSVN M=$P(VREC0 ,"^",3),CH PSVTX=$P(V REC0,"^",2 )
  31991   "RTN","CHM XF001",75, 0)
  31992    .S CHPSVT XL=$L(CHPS VTX) I CHP SVTXL>9 S  CHPSVTXV=C HPSVTXL-9  S CHPSVTX= $E(CHPSVTX ,CHPSVTXV+ 1,999) Q
  31993   "RTN","CHM XF001",76, 0)
  31994    K CHMXSTS ,CLAIM D   G LP3NXT
  31995   "RTN","CHM XF001",77, 0)
  31996    .I $D(^CH MXCLA(CHAI ,80)) I $P (^CHMXCLA( CHAI,80)," ^",7)=1 D   Q:$D(CHMF PDI)
  31997   "RTN","CHM XF001",78, 0)
  31998    ..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
  31999   "RTN","CHM XF001",79, 0)
  32000    ..D ^CHMX MPD2
  32001   "RTN","CHM XF001",80, 0)
  32002    .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
  32003   "RTN","CHM XF001",81, 0)
  32004    ;;NEXT LI NE CONDITI ONALIZE/TU RN BACK ON  WHEN SUBM ISSIONS PA SS THROUGH  AI AND BY PASS IP SC REENS
  32005   "RTN","CHM XF001",82, 0)
  32006   LP3NXT ;S  ^CHMIMAGE( CHMFPDI,"V EN-II",MXV EN)=X1_"^" _X2_"^"_X3 _"^"_X4_"^ "_X5
  32007   "RTN","CHM XF001",83, 0)
  32008    D DEBUG^C HMXDR01("  ARRIVED @  LP3NXT:  " ,0)
  32009   "RTN","CHM XF001",84, 0)
  32010    ;
  32011   "RTN","CHM XF001",85, 0)
  32012    ;
  32013   "RTN","CHM XF001",86, 0)
  32014   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
  32015   "RTN","CHM XF001",87, 0)
  32016    ;D NOW^%D TC
  32017   "RTN","CHM XF001",88, 0)
  32018    ;I $D(^CH MIMAGE(CHM FPDI)) S ^ CHMZHOLD(" X12_DUPEPD I",CHFIO,% )=CHMFPDI_ "^"_CHFIO  D RKNMAIL^ CHMXDR01 G  LOOP3
  32019   "RTN","CHM XF001",89, 0)
  32020    ;
  32021   "RTN","CHM XF001",90, 0)
  32022    ;
  32023   "RTN","CHM XF001",91, 0)
  32024    D DEBUG^C HMXDR01("C HMXF001:RK NCPDI:  PD I= ",CHMFP DI)
  32025   "RTN","CHM XF001",92, 0)
  32026    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
  32027   "RTN","CHM XF001",93, 0)
  32028    I '$D(^CH MXCLC(CHCI ,80)) S CH BNPRB="" G  END
  32029   "RTN","CHM XF001",94, 0)
  32030    S BNREC=^ CHMXCLC(CH CI,80),CHD FN=$P(BNRE C,"^"),CHB FN=$P(BNRE C,"^",2)
  32031   "RTN","CHM XF001",95, 0)
  32032    I (CHDFN= "")!(CHBFN ="") S CHB NPRB="" G  END
  32033   "RTN","CHM XF001",96, 0)
  32034    D PDI^CHM XF010 ; IN SERT PDI I N BUFFER F ILE AND "A " XREF
  32035   "RTN","CHM XF001",97, 0)
  32036    D ^CHMXF0 02 ; FUTUR E CALL TO  AI SYSTEM  FOR EDI TO S DECISION S HERE--#1  OPTION
  32037   "RTN","CHM XF001",98, 0)
  32038    D DEBUG^C HMXDR01("R EADY TO GO  TO CHMXF0 03: ",0)
  32039   "RTN","CHM XF001",99, 0)
  32040    D ^CHMXF0 03 G:$D(CH CCPRB) END
  32041   "RTN","CHM XF001",100 ,0)
  32042    G LOOP3
  32043   "RTN","CHM XF001",101 ,0)
  32044    ;
  32045   "RTN","CHM XF001",102 ,0)
  32046   END S:($D( CHNODTA))! ($D(CHVNPR B))!($D(CH BNPRB))!($ D(CHCCPRB) ) CHMXUNCC =""
  32047   "RTN","CHM XF001",103 ,0)
  32048   END1 I $D( CHVNMMRS)  D ^CHMXMM1 0 K ^CHMXC LE("VNDR D ELT")
  32049   "RTN","CHM XF001",104 ,0)
  32050    K PDIFLG, CHMXI,CHAI ,CHACLCT,C HADLCT,CHA I,CHAIHLD, CHCL,CHID, CHIDHLD,CH BI
  32051   "RTN","CHM XF001",105 ,0)
  32052    K CHCI,CH EI,CHTPID, VN,MXVEN,C HMXVNRC,CH VNFCTP,VNR EC,CHPSVNM ,CHARGE,CH FI
  32053   "RTN","CHM XF001",106 ,0)
  32054    K CHPSVTX ,CHPSVAD,C HPSVCY,CHP SVST,CHPSV ZP,BNREC,C HDFN,CHBFN ,AI,CHTOTC L
  32055   "RTN","CHM XF001",107 ,0)
  32056    K CHTOTDL ,CHEJ,CHTO TPG,CHREL, CHREC0,CHT OSJ,CHTOS, CHADM,CHDI S,CHSTS,CH BLD
  32057   "RTN","CHM XF001",108 ,0)
  32058    K CHADMDX ,CHDCFAC,C HBNPD,CHDX ,CHPX,CHI, CHCCRL,CHT OB,CHREV,C HEJJ,SKIPF LG
  32059   "RTN","CHM XF001",109 ,0)
  32060    K CHCCNB, CHMFCLNM,C HCLFG,X12R JFG,CHMXJ, PC,CHMXLN, JJ,CHVNMMR S,CHSTI
  32061   "RTN","CHM XF001",110 ,0)
  32062    K VQAURLF G,VREC0,VR EC1,VREC2, VREC5,VREC 41,X1,X2,X 3,X4,X5
  32063   "RTN","CHM XF001",111 ,0)
  32064    K CHXSTYP ,CHXFLVR,C HXCLTYP,CH MFREQ
  32065   "RTN","CHM XF001",112 ,0)
  32066    Q
  32067   "RTN","CHM XF001",113 ,0)
  32068    ;
  32069   "RTN","CHM XF001",114 ,0)
  32070   PROCESS ;  PROCESS LA ST PDI SET  UP THRU S ORT, CHECK  DATA, BEN EFIT CALC
  32071   "RTN","CHM XF001",115 ,0)
  32072    D DEBUG^C HMXDR01("  ARRIVED @  PROCESS:   ",0)
  32073   "RTN","CHM XF001",116 ,0)
  32074    ;"EDI/OCR " QUEUE IS  NOW COUNT ING ONLY E DI SUBMISS IONS DISPL AYED ON CH V SCREENS
  32075   "RTN","CHM XF001",117 ,0)
  32076    ;"CHMEDIL (" QUEUE I S NOW COUN TING ONLY  OCR SUBMIS SIONS DISP LAYED ON C HV SCREENS
  32077   "RTN","CHM XF001",118 ,0)
  32078    S CHPDIRD Y=$$TYPE^C HMFPDI2(CH MFPDI)
  32079   "RTN","CHM XF001",119 ,0)
  32080    I CHPDIRD Y=91 D  G  PR2
  32081   "RTN","CHM XF001",120 ,0)
  32082    .;jsg;DEV 002841;Upd ate ASV qu eue rather  than "OCR -READY"
  32083   "RTN","CHM XF001",121 ,0)
  32084    .;S ^CHMI MG("OCR-RE ADY",CHMFP DI)="" ; T O PUT INTO  CHAMPVA E DI READY Q UEUE FOR S ELECTION B Y VE
  32085   "RTN","CHM XF001",122 ,0)
  32086    .X ^%ZOSF ("UCI") S  UCI=$P(Y," ,")
  32087   "RTN","CHM XF001",123 ,0)
  32088    .;S ^CHMI MG("VEN-ED I",CHMFPDI )=UCI ; YG , Submissi on Jrules
  32089   "RTN","CHM XF001",124 ,0)
  32090    .S ^CHMIM G("OCR-REA DY",CHMFPD I)=UCI
  32091   "RTN","CHM XF001",125 ,0)
  32092    .;
  32093   "RTN","CHM XF001",126 ,0)
  32094    .S CHMIN= "",CHMQNAM ="EDI/OCR"  K CHMOUT  D ^CHMIS04 1 ; SYSTEM  STATISTIC S
  32095   "RTN","CHM XF001",127 ,0)
  32096    I (CHPDIR DY=92)!(CH PDIRDY=93)  D  G PR2
  32097   "RTN","CHM XF001",128 ,0)
  32098    .S ^CHMIM G("SBOCR-R EADY",CHMF PDI)="" ;  TO PUT INT O SB/CWVV  EDI READY  QUEUE FOR  SELECTION  BY VE
  32099   "RTN","CHM XF001",129 ,0)
  32100    .S CHMIN= "",CHMQNAM ="EDI/OCR"  K CHMOUT  D ^CHMIS04 1 ; SYSTEM  STATISTIC S
  32101   "RTN","CHM XF001",130 ,0)
  32102    I CHPDIRD Y=94 D  G  PR2
  32103   "RTN","CHM XF001",131 ,0)
  32104    .S ^CHMIM G("OCR2-RE ADY",CHMFP DI)="" ; P UT INTO CH AMPVA OCR  READY QUEU E
  32105   "RTN","CHM XF001",132 ,0)
  32106    .;S ^CHMI MG("VEN-OC R2",CHMFPD I)="" ;jsg ;DEV002841 ;Update AS V queue ra ther than  "OCR2-READ Y"
  32107   "RTN","CHM XF001",133 ,0)
  32108    .S CHMIN= "",CHMQNAM ="CHMEDIL( " K CHMOUT  D ^CHMIS0 41  ;TLH 1 1/20/06 FO R DEV00011 5
  32109   "RTN","CHM XF001",134 ,0)
  32110    I (CHPDIR DY=95)!(CH PDIRDY=96)  D  G PR2
  32111   "RTN","CHM XF001",135 ,0)
  32112    .S ^CHMIM G("SBOCR2- READY",CHM FPDI)="" ;  PUT INTO  SB/CWVV OC R READY QU EUE
  32113   "RTN","CHM XF001",136 ,0)
  32114    .S CHMIN= "",CHMQNAM ="CHMEDIL( " K CHMOUT  D ^CHMIS0 41  ;TLH 1 1/20/06 FO R DEV00011 5
  32115   "RTN","CHM XF001",137 ,0)
  32116    I CHPDIRD Y=90 D  G  PR2  ;CPE0 05-001 Spi na Bifida  EDI Re-ope n.
  32117   "RTN","CHM XF001",138 ,0)
  32118    .I $G(CHF C8CIP) D   Q  ;CPE005 -042 Set s tatus to v oid
  32119   "RTN","CHM XF001",139 ,0)
  32120    ..S DIE=7 41000.2,DA =CHMFOPDI, DR=".06/// 11" D ^DIE  K DIE
  32121   "RTN","CHM XF001",140 ,0)
  32122    .;CPE005- 043 Determ ine if PDI  should be  in EDI-PA USE
  32123   "RTN","CHM XF001",141 ,0)
  32124    .N PAUSE  S PAUSE=$$ EDIPAUSE^C HROLIB1(CH MFOPDI,CHM FPDI,1,CHE I,.ERROR)
  32125   "RTN","CHM XF001",142 ,0)
  32126    .I PAUSE  Q
  32127   "RTN","CHM XF001",143 ,0)
  32128    .S ^CHMIM G("SBOCRR- READY",CHM FPDI)=""
  32129   "RTN","CHM XF001",144 ,0)
  32130    .S CHMIN= "",CHMQNAM ="CHMEREOP (" K CHMOU T D ^CHMIS 041
  32131   "RTN","CHM XF001",145 ,0)
  32132    I CHPDIRD Y=97 D  G  PR2  ;CPE0 05-001 CHA MPVA EDI R e-open.
  32133   "RTN","CHM XF001",146 ,0)
  32134    .I $G(CHF C8CIP) D   Q  ;CPE005 -042 Set s tatus to v oid
  32135   "RTN","CHM XF001",147 ,0)
  32136    ..S DIE=7 41000.2,DA =CHMFOPDI, DR=".06/// 11" D ^DIE  K DIE
  32137   "RTN","CHM XF001",148 ,0)
  32138    .;CPE005- 043 Determ ine if PDI  should be  in EDI-PA USE
  32139   "RTN","CHM XF001",149 ,0)
  32140    .N PAUSE  S PAUSE=$$ EDIPAUSE^C HROLIB1(CH MFOPDI,CHM FPDI,1,CHE I,.ERROR)
  32141   "RTN","CHM XF001",150 ,0)
  32142    .I PAUSE  Q
  32143   "RTN","CHM XF001",151 ,0)
  32144    .S ^CHMIM G("OCRR-RE ADY",CHMFP DI)=""
  32145   "RTN","CHM XF001",152 ,0)
  32146    .; CPE005 -023 Corre ct CHMQNAM
  32147   "RTN","CHM XF001",153 ,0)
  32148    .; S CHMI N="",CHMQN AM="CHMERE OP(" K CHM OUT D ^CHM IS041
  32149   "RTN","CHM XF001",154 ,0)
  32150    .S CHMIN= "",CHMQNAM ="EDI-REOP EN" K CHMO UT D ^CHMI S041
  32151   "RTN","CHM XF001",155 ,0)
  32152   PR2 S ^CHM IMG(CHMFPD I,"DOC")=" " ; NEEDED  FOR DOC I D OR INDIC ATION OF N O DOC
  32153   "RTN","CHM XF001",156 ,0)
  32154    S ^CHMIMG (CHMFPDI," TRACK")=CH DFN_"^"_CH BFN ; NEED ED TO TRAC K BENE
  32155   "RTN","CHM XF001",157 ,0)
  32156    S ^CHMIMG ("AV",CHDF N,CHBFN,CH MFPDI)=""   ;AEB adde d to allow  PDI to be  seen in D MD app  11 /3/2005
  32157   "RTN","CHM XF001",158 ,0)
  32158    I $G(CHMF OPDI)'=""  D  ;CPE005 -001 - Fil e the Orig inal PDI N umber.
  32159   "RTN","CHM XF001",159 ,0)
  32160    .S $P(^CH MIMG(CHMFP DI,"E-REOP EN"),"^")= CHMFOPDI,$ P(^CHMIMG( CHMFPDI,"E -REOPEN"), "^",3)=0
  32161   "RTN","CHM XF001",160 ,0)
  32162    .S $P(^CH MIMG(CHMFO PDI,"E-REO PEN"),"^", 2)=CHMFPDI ,$P(^CHMIM G(CHMFOPDI ,"E-REOPEN "),"^",3)= 0
  32163   "RTN","CHM XF001",161 ,0)
  32164    .; add Re Open xrefs : a) "A-FI RST" sets  1st Origin al for eac h given su bsequent R eOpen
  32165   "RTN","CHM XF001",162 ,0)
  32166    .; b) "A- ALL" sets  all ReOpen s xrefed t o 1st Orig inal occur rence
  32167   "RTN","CHM XF001",163 ,0)
  32168    .D PDIFIR ST^CHMFUTL E(CHMFPDI)  ; (CPE005 -001)
  32169   "RTN","CHM XF001",164 ,0)
  32170    ;D COMPLT  S CHMFPP= "CIP" D ^C HMFWK01
  32171   "RTN","CHM XF001",165 ,0)
  32172    ;D KLOCK  S CHMFPP=" SST" D ^CH MFWK01
  32173   "RTN","CHM XF001",166 ,0)
  32174    ;S $ZT="S RTERR^CHMX F001" D ^C HMFSRT
  32175   "RTN","CHM XF001",167 ,0)
  32176    ;;
  32177   "RTN","CHM XF001",168 ,0)
  32178    ;; AAF
  32179   "RTN","CHM XF001",169 ,0)
  32180    ;;
  32181   "RTN","CHM XF001",170 ,0)
  32182    ;; 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  
  32183   "RTN","CHM XF001",171 ,0)
  32184    ;; Howeve r, CHICDAA  is appare ntly takin g care of  it, so do  not call i t anymore
  32185   "RTN","CHM XF001",172 ,0)
  32186    ;I $P(^CH MIMAGE(CHM FPDI,0),"^ ",19)=1 D  COMPLT,KLO CK S DUZ=9 944,PDI=CH MFPDI D ^C HICDAA
  32187   "RTN","CHM XF001",173 ,0)
  32188    I $P(^CHM IMAGE(CHMF PDI,0),"^" ,19)=1 S D UZ=9944,PD I=CHMFPDI  D ^CHICDAA
  32189   "RTN","CHM XF001",174 ,0)
  32190    ;;
  32191   "RTN","CHM XF001",175 ,0)
  32192   CHKSTRT ;S  CHMFPP="C ST" D ^CHM FWK01
  32193   "RTN","CHM XF001",176 ,0)
  32194    ;;Y2K- S  CHBRTYP=$$ TYPE^CHMFP DI2(CHMFPD I),BI=0,BI =$O(^CHMDI C(741002.9 3,"C",CHBR TYP,BI)) Q :('BI)!(BI ="")
  32195   "RTN","CHM XF001",177 ,0)
  32196    ;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
  32197   "RTN","CHM XF001",178 ,0)
  32198    ;E  D ^CH MXCP09 Q:$ D(MXRJFG)   S VQAURLF G=1
  32199   "RTN","CHM XF001",179 ,0)
  32200    ;D CLM^CH MXF010 Q:$ D(X12RJFG)   S VQAURL FG=1
  32201   "RTN","CHM XF001",180 ,0)
  32202    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
  32203   "RTN","CHM XF001",181 ,0)
  32204    ;;
  32205   "RTN","CHM XF001",182 ,0)
  32206    ;***NEED  TO COUNT T HE CLAIMS  (CHCLCT) H ERE
  32207   "RTN","CHM XF001",183 ,0)
  32208   CHKNXT ;S  $ZT="CHKER R^CHMXF001 "
  32209   "RTN","CHM XF001",184 ,0)
  32210    ;K CHMFCL MS,CHMFCL, CHMFREJ
  32211   "RTN","CHM XF001",185 ,0)
  32212    ;D SORT^C HFCDUTL,^C HFCDDRV
  32213   "RTN","CHM XF001",186 ,0)
  32214    ;I '$D(DT ) S %DT="" ,X="T" D ^ %DT S DT=Y
  32215   "RTN","CHM XF001",187 ,0)
  32216    ;D NOW^%D TC S:'$D(% ) %=DT
  32217   "RTN","CHM XF001",188 ,0)
  32218    ;S $P(^CH MIMAGE(CHM FPDI,0),"^ ",5)=%
  32219   "RTN","CHM XF001",189 ,0)
  32220    ;K CHASFL G,VIEWFL,P DIFLG S CL =0
  32221   "RTN","CHM XF001",190 ,0)
  32222    ;D KILALL ^CHMXDR01
  32223   "RTN","CHM XF001",191 ,0)
  32224    K CHPDIRD Y,PDIFLG Q
  32225   "RTN","CHM XF001",192 ,0)
  32226    ;
  32227   "RTN","CHM XF001",193 ,0)
  32228   SUM ;SUMS  THE NUMBER  OF CLAIMS /DOLLAR AM NT PER TRA NSACTION B ATCH
  32229   "RTN","CHM XF001",194 ,0)
  32230    S $P(^CHM XCLA(CHAIH LD,80),"^" ,3)=CHACLC T,$P(^(80) ,"^",4)=CH ADLCT
  32231   "RTN","CHM XF001",195 ,0)
  32232    S (CHACLC T,CHADLCT) =0
  32233   "RTN","CHM XF001",196 ,0)
  32234    Q
  32235   "RTN","CHM XF001",197 ,0)
  32236    ;
  32237   "RTN","CHM XF001",198 ,0)
  32238   TOTSUM ;SU MS THE NUM BER CLAIMS /DOLLAR AM NT PER ENT IRE BATCH
  32239   "RTN","CHM XF001",199 ,0)
  32240    S (AI,CHT OTCL,CHTOT DL)=0
  32241   "RTN","CHM XF001",200 ,0)
  32242   TOTSUM1 S  AI=$O(^CHM XCLA("B",C HMXI,AI))  G:'AI TOTS UM2
  32243   "RTN","CHM XF001",201 ,0)
  32244    G:'$D(^CH MXCLA(AI,8 0)) TOTSUM 1
  32245   "RTN","CHM XF001",202 ,0)
  32246    S CHTOTCL =CHTOTCL+$ P(^CHMXCLA (AI,80),"^ ",3),CHTOT DL=CHTOTDL +$P(^CHMXC LA(AI,80), "^",4)
  32247   "RTN","CHM XF001",203 ,0)
  32248    G TOTSUM1
  32249   "RTN","CHM XF001",204 ,0)
  32250   TOTSUM2 S  $P(^CHMXCL (CHMXI,80) ,"^",3)=CH TOTCL,$P(^ CHMXCL(CHM XI,80),"^" ,4)=CHTOTD L
  32251   "RTN","CHM XF001",205 ,0)
  32252    Q
  32253   "RTN","CHM XF001",206 ,0)
  32254    ;
  32255   "RTN","CHM XF001",207 ,0)
  32256   COMPLT ; S ET STATUS  OF PDI TO  COMPLETE
  32257   "RTN","CHM XF001",208 ,0)
  32258    S U="^" Q :('$D(CHMF PDI))!(CHM FPDI="")
  32259   "RTN","CHM XF001",209 ,0)
  32260    G:$D(^CHM IMG(CHMFPD I,0)) C1
  32261   "RTN","CHM XF001",210 ,0)
  32262    L ^CHMIMG (0) S $P(^ CHMIMG(0), "^",3)=CHM FPDI,$P(^( 0),"^",4)= $P(^(0),"^ ",4)+1 L
  32263   "RTN","CHM XF001",211 ,0)
  32264    S ^CHMIMG (CHMFPDI,0 )=CHMFPDI
  32265   "RTN","CHM XF001",212 ,0)
  32266   C1 S X=^CH MIMG(CHMFP DI,0),^CHM IMG("B",CH MFPDI,CHMF PDI)=""
  32267   "RTN","CHM XF001",213 ,0)
  32268    S $P(X,"^ ",6)=4,^CH MIMG(CHMFP DI,0)=X Q
  32269   "RTN","CHM XF001",214 ,0)
  32270    ;
  32271   "RTN","CHM XF001",215 ,0)
  32272   KLOCK ; EN SURE CHMIM AGE FILE N OT LOCKED
  32273   "RTN","CHM XF001",216 ,0)
  32274    I $D(CHMF PDI) K:CHM FPDI'="" ^ CHMIMAGE(" LOCK",CHMF PDI)
  32275   "RTN","CHM XF001",217 ,0)
  32276    Q
  32277   "RTN","CHM XF001",218 ,0)
  32278    ;
  32279   "RTN","CHM XF001",219 ,0)
  32280   COUNT ; CO UNTS CLAIM S CREATED  FOR SYSTEM  STATISTIC S
  32281   "RTN","CHM XF001",220 ,0)
  32282    S CLCT=0
  32283   "RTN","CHM XF001",221 ,0)
  32284   CO1 S CLCT =$O(CHMFCL MS(CLCT))  Q:CLCT=""
  32285   "RTN","CHM XF001",222 ,0)
  32286    S CHMQNAM ="CHMPAY(" ,CHMIN=""  K CHOUT D  ^CHMIS041  G CO1
  32287   "RTN","CHM XF001",223 ,0)
  32288    ;
  32289   "RTN","CHM XF001",224 ,0)
  32290   ERROR S $Z E="X12 DRV  "_$ZE D ^ %ET,UNSET  Q
  32291   "RTN","CHM XF001",225 ,0)
  32292    ;
  32293   "RTN","CHM XF001",226 ,0)
  32294   SRTERR S $ ZE="X12 SR T "_$ZE D  ^%ET,UNSET  Q
  32295   "RTN","CHM XF001",227 ,0)
  32296    ;
  32297   "RTN","CHM XF001",228 ,0)
  32298   CHKERR S $ ZE="X12 CH K "_$ZE D  ^%ET,UNSET  Q
  32299   "RTN","CHM XF001",229 ,0)
  32300    ;
  32301   "RTN","CHM XF001",230 ,0)
  32302   UNSET S DU Z=CHDUZHLD  Q
  32303   "RTN","CHM XF001",231 ,0)
  32304    ;
  32305   "RTN","CHM XF004")
  32306   0^16^B3961 0261
  32307   "RTN","CHM XF004",1,0 )
  32308   CHMXF004 ; CVA/DTP;X1 2 837 CLM  CREATE SET  INP CLM D ATA TO IMA GE FILE (H EALTH CARE  CLAIMS);0 2/06/98  1 :26 PM
  32309   "RTN","CHM XF004",2,0 )
  32310    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  32311   "RTN","CHM XF004",3,0 )
  32312    ;;
  32313   "RTN","CHM XF004",4,0 )
  32314    ;; 03-05- 07 ajm mod ified plac e of servi ce lookup  (DEV001400 -01)
  32315   "RTN","CHM XF004",5,0 )
  32316    ;; DEV004 805 1/20/2 010
  32317   "RTN","CHM XF004",6,0 )
  32318    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  32319   "RTN","CHM XF004",7,0 )
  32320    ;;CPTS #1 6334 (Y2K)  (16-JUN-9 9)
  32321   "RTN","CHM XF004",8,0 )
  32322    ;; 03-MAR -2010 (DEV 009020 POA ) AJM
  32323   "RTN","CHM XF004",9,0 )
  32324    ;; DLB 8/ 17/2012        DEV782 0 ADDED TH E ^CHMIMAG E LOAD CAL L TO LDCHM IMG^CHMXLI MG
  32325   "RTN","CHM XF004",10, 0)
  32326    ;;                                D LDCHMI MG^CHMXLIM G(CHEI,CHF I,CHMFPDI, CHTOSJ,CHI MGK,CHIMGL ,"INP-NS")  ; DLB SLA  ^CHMIMAGE  LOAD
  32327   "RTN","CHM XF004",11, 0)
  32328    ;; DLB 9/ 5/2012         ADDED  FINAL BALA NCE CHECK  TO INPATIE NT LOAD TO  CHMIMAGE
  32329   "RTN","CHM XF004",12, 0)
  32330    ;;                                          D BALCHK^ CHMXLIMG(C HEI,CHMFPD I,CHTOSJ,C HIMGK,CHIM GL,"INP-NS ")  ; DLB  SLA FINAL  BALANCE CH ECK AGAINS T CLAIM OH OIPD
  32331   "RTN","CHM XF004",13, 0)
  32332    ;; DLB 1/ 8/2013         MOVED  FINAL BALA NCE CHECK  TO CHMXLIM G.INT
  32333   "RTN","CHM XF004",14, 0)
  32334    ;; DLB 1/ 9/2013         ADDED  GTLX(CHFI)  FUNCTION  TO RETIREV E THE LINE  ITEM CTRL  # OR SERV ICE LINE #
  32335   "RTN","CHM XF004",15, 0)
  32336    ;;                                         AND POPULA TE THE ^CH MIMAGE EDI  LINE IDEN TIFIER FIE LD WITH RE SULT
  32337   "RTN","CHM XF004",16, 0)
  32338    ;; DLB 2/ 5/2013         DEV782 0  ADDED C ALL TO BAL CHK IN CHM XLIMG.INT  FOR SLA LO AD TO ^CHM IMAGE
  32339   "RTN","CHM XF004",17, 0)
  32340    ;; BMJ 11 /27/17     User Story  CPE005-00 6 Modify D ocument Id entificati on Screen  - Type of  Bill
  32341   "RTN","CHM XF004",18, 0)
  32342    ;;
  32343   "RTN","CHM XF004",19, 0)
  32344   A S (CHADM ,CHDIS,CHS TS,CHADMDX ,CHBLD,CHD CFAC,CHBNP D,CHTOB,CH CCRL)=""
  32345   "RTN","CHM XF004",20, 0)
  32346    G:'$D(^CH MXCLE(CHEI ,1)) B
  32347   "RTN","CHM XF004",21, 0)
  32348    ;Y2K - as sumes cent ury 2 - Fi xed by the  following  two lines
  32349   "RTN","CHM XF004",22, 0)
  32350    ;Y2K S CH ADM=2_$E($ P(^CHMXCLE (CHEI,1)," ^"),3,8)
  32351   "RTN","CHM XF004",23, 0)
  32352    ;Y2K S CH DIS=2_$E($ P(^CHMXCLE (CHEI,1)," ^",2),3,8)
  32353   "RTN","CHM XF004",24, 0)
  32354    S CHADM=$ $YR8FMYR^C HTFLIB($P( ^CHMXCLE(C HEI,1),"^" ))
  32355   "RTN","CHM XF004",25, 0)
  32356    S CHDIS=$ $YR8FMYR^C HTFLIB($P( ^CHMXCLE(C HEI,1),"^" ,2))
  32357   "RTN","CHM XF004",26, 0)
  32358   B G:'$D(^C HMXCLE(CHE I,3)) C
  32359   "RTN","CHM XF004",27, 0)
  32360    S CHSTS=$ P(^CHMXCLE (CHEI,3)," ^")
  32361   "RTN","CHM XF004",28, 0)
  32362   C G:'$D(^C HMXCLE(CHE I,2)) D
  32363   "RTN","CHM XF004",29, 0)
  32364    S CHBLD=$ P(^CHMXCLE (CHEI,2)," ^"),CHBNPD =$P(^(2)," ^",2)
  32365   "RTN","CHM XF004",30, 0)
  32366   D I CHSTS= "" S CHSTI ="" G E
  32367   "RTN","CHM XF004",31, 0)
  32368    I '$D(^CH MDIC(74100 2.12,"B",C HSTS)) S C HSTI="" G  E
  32369   "RTN","CHM XF004",32, 0)
  32370    S CHSTI=0 ,CHSTI=$O( ^CHMDIC(74 1002.12,"B ",CHSTS,0) ) G:'CHSTI  E
  32371   "RTN","CHM XF004",33, 0)
  32372    S CHDCFAC =$P(^CHMDI C(741002.1 2,CHSTI,0) ,"^",4)
  32373   "RTN","CHM XF004",34, 0)
  32374    G:'$D(^CH MXCLE(CHEI ,42)) E S  CHDX=^CHMX CLE(CHEI,4 2,1,0) G:C HDX="" E D  DXCNVRT G :$D(SKIPFL G) E S CHA DMDX=CHDX
  32375   "RTN","CHM XF004",35, 0)
  32376   E S ^CHMIM AGE(CHMFPD I,1,CHTOSJ ,2,1,"INP- NS",1,0)=C HDFN_"^"_C HBFN_"^^"_ CHADM_"^"_ CHDIS_"^"_ CHSTI_"^"_ CHADMDX_"^ ^^"_CHBLD_ "^"_CHDCFA C_"^^"_CHB NPD
  32377   "RTN","CHM XF004",36, 0)
  32378    G:'$D(^CH MXCLE(CHEI ,40)) G S  CHEJJ=0
  32379   "RTN","CHM XF004",37, 0)
  32380   F S CHEJJ= $O(^CHMXCL E(CHEI,40, CHEJJ)) G: 'CHEJJ F1
  32381   "RTN","CHM XF004",38, 0)
  32382    G:'$D(^CH MXCLE(CHEI ,40,CHEJJ, 0)) F S CH DX=$P(^(0) ,"^") S CH POA=$P(^(0 ),"^",2) G :CHDX="" F   ;AJM DEV 9020 03/11 /2010
  32383   "RTN","CHM XF004",39, 0)
  32384    I $E(CHDX ,1,1)="E"  S CHEDXARY (CHEJJ)=CH DX G F
  32385   "RTN","CHM XF004",40, 0)
  32386    D DXCNVRT  G:$D(SKIP FLG) F
  32387   "RTN","CHM XF004",41, 0)
  32388    S $P(^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"IN P-NS",1,10 0,CHEJJ,0) ,"^")=CHDX      ;AJM  DEV9020 03 /11/2010
  32389   "RTN","CHM XF004",42, 0)
  32390    S $P(^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"IN P-NS",1,10 0,CHEJJ,0) ,"^",2)=CH POA  ;AJM  DEV9020 03 /11/2010
  32391   "RTN","CHM XF004",43, 0)
  32392    G F
  32393   "RTN","CHM XF004",44, 0)
  32394   F1 G:'$D(C HEDXARY) G  S CHEJJ=0
  32395   "RTN","CHM XF004",45, 0)
  32396   F2 S CHEJJ =$O(CHEDXA RY(CHEJJ))  I 'CHEJJ  K CHEDXARY  G G
  32397   "RTN","CHM XF004",46, 0)
  32398    G:'$D(CHE DXARY(CHEJ J)) F2 S C HDX=CHEDXA RY(CHEJJ)  G:CHDX=""  F2
  32399   "RTN","CHM XF004",47, 0)
  32400    D DXCNVRT  G:$D(SKIP FLG) F2
  32401   "RTN","CHM XF004",48, 0)
  32402    S CHEJJHL D=CHEJJ,CH EJJ=999999 9,CHEJJ=$O (^CHMIMAGE (CHMFPDI,1 ,CHTOSJ,2, 1,"INP-NS" ,1,100,CHE JJ),-1),CH EJJ=CHEJJ+ 1
  32403   "RTN","CHM XF004",49, 0)
  32404    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"INP-N S",1,100,C HEJJ,0)=CH DX
  32405   "RTN","CHM XF004",50, 0)
  32406    S CHEJJ=C HEJJHLD
  32407   "RTN","CHM XF004",51, 0)
  32408    G F2
  32409   "RTN","CHM XF004",52, 0)
  32410   G G:'$D(^C HMXCLE(CHE I,41)) I S  CHEJJ=0
  32411   "RTN","CHM XF004",53, 0)
  32412   H S CHEJJ= $O(^CHMXCL E(CHEI,41, CHEJJ)) G: 'CHEJJ I
  32413   "RTN","CHM XF004",54, 0)
  32414    G:'$D(^CH MXCLE(CHEI ,41,CHEJJ, 0)) H S CH PX=$P(^(0) ,"^") G:CH PX="" H D  PXCNVRT G: $D(SKIPFLG ) H
  32415   "RTN","CHM XF004",55, 0)
  32416    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"INP-N S",1,101,C HEJJ,0)=CH PX
  32417   "RTN","CHM XF004",56, 0)
  32418    G H
  32419   "RTN","CHM XF004",57, 0)
  32420   I S (CHFI, CHEJJ)=0
  32421   "RTN","CHM XF004",58, 0)
  32422   I1 S CHFI= $O(^CHMXCL F("B",CHEI ,CHFI)) G: 'CHFI END
  32423   "RTN","CHM XF004",59, 0)
  32424    G:'$D(^CH MXCLF(CHFI ,1)) I1
  32425   "RTN","CHM XF004",60, 0)
  32426    S CHREV=$ P(^CHMXCLF (CHFI,1)," ^"),CHARGE =$P(^(1)," ^",6),CHUN TS=+$P(^(1 ),"^",8)
  32427   "RTN","CHM XF004",61, 0)
  32428    S CHLINE= $$GTLX(CHF I)                                     ; RE TRIEVE THE  LINE ITEM  CTRL # OR  LINE NUMB ER FOR CHF
  32429   "RTN","CHM XF004",62, 0)
  32430    G:CHREV=" " I1 
  32431   "RTN","CHM XF004",63, 0)
  32432    I $D(CHXS TYP) G:(CH XSTYP=1)&( CHREV="001 ") I1  ; D ON'T LOAD  "001" REV  CODE FOR O CR 8-9-05  RKN IF STA TEMENT
  32433   "RTN","CHM XF004",64, 0)
  32434    G:(+CHREV '>1) I1     ;SKD 7-10 -07 DEV002 710-01, 8- 29-07 DEV0 03081-02
  32435   "RTN","CHM XF004",65, 0)
  32436    S:CHUNTS= "" CHUNTS= 1 S:CHUNTS =0 CHUNTS= 1
  32437   "RTN","CHM XF004",66, 0)
  32438    D RVCNVRT  G:CHREV=" " I1 S CHE JJ=CHEJJ+1
  32439   "RTN","CHM XF004",67, 0)
  32440    ;S ^CHMIM AGE(CHMFPD I,1,CHTOSJ ,2,1,"INP- NS",1,102, CHEJJ,0)=C HREV_"^"_C HARGE_"^"_ CHFI_"^"_C HUNTS
  32441   "RTN","CHM XF004",68, 0)
  32442    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"INP-N S",1,102,C HEJJ,0)=CH REV_"^"_CH ARGE_"^"_C HLINE_"^"_ CHUNTS
  32443   "RTN","CHM XF004",69, 0)
  32444    ;W !,"CHM XF004:I1:S ET ^CHMIMA GE(""INP-N S"",""102" ")=",^CHMI MAGE(CHMFP DI,1,CHTOS J,2,1,"INP -NS",1,102 ,CHEJJ,0)
  32445   "RTN","CHM XF004",70, 0)
  32446    S (CHIMGK ,CHIMGL)=1                                                                                                                  ; DLB S LA SET UP  INDEX VALU ES
  32447   "RTN","CHM XF004",71, 0)
  32448    D LDCHMIM G^CHMXLIMG (CHEI,CHFI ,CHMFPDI,C HTOSJ,CHIM GK,CHIMGL, "INP-NS")       ; DLB  SLA ^CHMI MAGE LOAD
  32449   "RTN","CHM XF004",72, 0)
  32450    I $D(CHRE V) I CHREV '="" S CM= $E($P(^CHM XDIC(74120 1.39,CHREV ,0),"^"),1 ,2) I (CM= 18)!(CM=99 ) D NONCOV  K CM
  32451   "RTN","CHM XF004",73, 0)
  32452    G I1
  32453   "RTN","CHM XF004",74, 0)
  32454    ;
  32455   "RTN","CHM XF004",75, 0)
  32456   END S (CHT OB,CHCCRL) =""
  32457   "RTN","CHM XF004",76, 0)
  32458    S (CHIMGK ,CHIMGL)=1                                                                                                      ; DLB SL A SET UP I NDEX VALUE S
  32459   "RTN","CHM XF004",77, 0)
  32460    D BALCHK^ CHMXLIMG(C HEI,CHMFPD I,CHTOSJ,C HIMGK,CHIM GL,"INP-NS ")           ; SLA FI NAL BALANC E CHECK AG AINST CLAI M OHOIPD 
  32461   "RTN","CHM XF004",78, 0)
  32462    ;I $D(^CH MXCLE(CHEI ,0)),($P(^ (0),"^",5) ="A")!($P( ^(0),"^",5 )="a") S C HTOB=$P(^( 0),"^",4)_ $P(^(0),"^ ",6)
  32463   "RTN","CHM XF004",79, 0)
  32464    I $D(^CHM XCLE(CHEI, 0)) S CHTO B=$P(^(0), "^",4)_$P( ^(0),"^",6 )  ; 11/27 /17 BMJ Us er Story C PE005-006  Changed th e line abo ve to this  line
  32465   "RTN","CHM XF004",80, 0)
  32466    I $D(^CHM XCLE(CHEI, 0)),$P(^(0 ),"^",2)'= "" S CHCCR L=$P(^(0), "^",2)
  32467   "RTN","CHM XF004",81, 0)
  32468    S $P(^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"VE N"),"^",7) =CHTOB,$P( ^("VEN")," ^",9)=1,$P (^("VEN"), "^",17)=CH CCRL
  32469   "RTN","CHM XF004",82, 0)
  32470    D:'$D(CHR DOIMG) BUF FND
  32471   "RTN","CHM XF004",83, 0)
  32472    K CHADM,C HDIS,CHSTS ,CHADMDX,C HBLD,CHDCF AC,CHBNPD, CHEJJ,CHDX ,CHPX,CHI, CHCCRL,CHT OB,CHREV
  32473   "RTN","CHM XF004",84, 0)
  32474    K SKIPFLG  Q
  32475   "RTN","CHM XF004",85, 0)
  32476    ; 
  32477   "RTN","CHM XF004",86, 0)
  32478   BUFFND S ^ CHMIMAGE(C HMFPDI,"BU FF")=CHTPI D_"^"_CHMX I_"^"_CHAI _"^"_CHBI_ "^"_CHCI_" ^"_CHEI
  32479   "RTN","CHM XF004",87, 0)
  32480    Q
  32481   "RTN","CHM XF004",88, 0)
  32482    ; 
  32483   "RTN","CHM XF004",89, 0)
  32484   DXCNVRT K  SKIPFLG
  32485   "RTN","CHM XF004",90, 0)
  32486    I '$D(^CH MICDX("C", CHDX)) S C HDX="" Q
  32487   "RTN","CHM XF004",91, 0)
  32488    S CHI=0,C HI=$O(^CHM ICDX("C",C HDX,0)) I  'CHI S CHD X="" Q
  32489   "RTN","CHM XF004",92, 0)
  32490    S CHDX=CH I
  32491   "RTN","CHM XF004",93, 0)
  32492    Q
  32493   "RTN","CHM XF004",94, 0)
  32494    ;
  32495   "RTN","CHM XF004",95, 0)
  32496    ; Convert  the proce dure code  to a ^CHMS ERV( i val
  32497   "RTN","CHM XF004",96, 0)
  32498   PXCNVRT K  SKIPFLG
  32499   "RTN","CHM XF004",97, 0)
  32500    I $D(^CHM SERV("BC", CHPX)) S S KIPFLG=""  Q
  32501   "RTN","CHM XF004",98, 0)
  32502    I $D(^CHM SERV("BF", CHPX_"Z"))  S SKIPFLG ="" Q
  32503   "RTN","CHM XF004",99, 0)
  32504    S CHPX=$$ PXCNVRT^CH EDILIB(CHP X,"B")
  32505   "RTN","CHM XF004",100 ,0)
  32506    Q
  32507   "RTN","CHM XF004",101 ,0)
  32508    ; 
  32509   "RTN","CHM XF004",102 ,0)
  32510   RVCNVRT K  SKIPFLG S  CHI=""  ;A EB 4/3/200 8
  32511   "RTN","CHM XF004",103 ,0)
  32512    I '$D(CHR EV) S CHRE V="" Q  ;A EB 2/4/200 8 DEV00336 7
  32513   "RTN","CHM XF004",104 ,0)
  32514    Q:CHREV=" "  ;AEB 2/ 4/2008 DEV 003367
  32515   "RTN","CHM XF004",105 ,0)
  32516    I $L(CHRE V)=4 D ;AE B 2/4/2008  DEV003367  
  32517   "RTN","CHM XF004",106 ,0)
  32518    .I '$D(^C HMXDIC(741 201.39,"B" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  32519   "RTN","CHM XF004",107 ,0)
  32520    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"B", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  32521   "RTN","CHM XF004",108 ,0)
  32522    .Q  ;AEB  2/4/2008 D EV003367
  32523   "RTN","CHM XF004",109 ,0)
  32524    I $L(CHRE V)=3 D  ;A EB 2/4/200 8 DEV00336 7
  32525   "RTN","CHM XF004",110 ,0)
  32526    .I '$D(^C HMXDIC(741 201.39,"H" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  32527   "RTN","CHM XF004",111 ,0)
  32528    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"H", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  32529   "RTN","CHM XF004",112 ,0)
  32530    .Q  ;AEB  2/4/2008 D EV003367
  32531   "RTN","CHM XF004",113 ,0)
  32532    I 'CHI S  CHREV="" Q   ;AEB 2/4 /2008 DEV0 03367
  32533   "RTN","CHM XF004",114 ,0)
  32534    S CHREV=C HI 
  32535   "RTN","CHM XF004",115 ,0)
  32536    Q
  32537   "RTN","CHM XF004",116 ,0)
  32538    ; 
  32539   "RTN","CHM XF004",117 ,0)
  32540   NONCOV I $ D(^CHMXCLC (CHCI,80))  Q:$P(^CHM XCLC(CHCI, 80),"^",3) '=1
  32541   "RTN","CHM XF004",118 ,0)
  32542    I CM=18 S  CHNCPTR=0 ,CHNCPTR=$ O(^CHMDIC( 741002.09, "B","DAY P ASS DAYS", 0)) Q:'CHN CPTR
  32543   "RTN","CHM XF004",119 ,0)
  32544    I CM=99 S  CHNCPTR=0 ,CHNCPTR=$ O(^CHMDIC( 741002.09, "B","PERSO NAL ITEMS" ,0)) Q:'CH NCPTR
  32545   "RTN","CHM XF004",120 ,0)
  32546    I '$D(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"I NP-NS",1,4 00)) S LL= 0 G NONCOV 1
  32547   "RTN","CHM XF004",121 ,0)
  32548    S LL=9999 9,LL=$O(^C HMIMAGE(CH MFPDI,1,CH TOSJ,2,1," INP-NS",1, 400,LL),-1 )
  32549   "RTN","CHM XF004",122 ,0)
  32550   NONCOV1 S  LL=LL+1,$P (^CHMIMAGE (CHMFPDI,1 ,CHTOSJ,2, 1,"INP-NS" ,1,400,LL, 0),"^")=CH NCPTR,$P(^ (0),"^",6) =CHREV
  32551   "RTN","CHM XF004",123 ,0)
  32552    S:CM=18 $ P(^CHMIMAG E(CHMFPDI, 1,CHTOSJ,2 ,1,"INP-NS ",1,400,LL ,0),"^",2) =CHUNTS
  32553   "RTN","CHM XF004",124 ,0)
  32554    S:CM=99 $ P(^CHMIMAG E(CHMFPDI, 1,CHTOSJ,2 ,1,"INP-NS ",1,400,LL ,0),"^",2) =CHARGE
  32555   "RTN","CHM XF004",125 ,0)
  32556    Q
  32557   "RTN","CHM XF004",126 ,0)
  32558    ; 
  32559   "RTN","CHM XF004",127 ,0)
  32560   GTLX(CHFI)                                                                                      ;  POPULATE T HE ^CHMIMA GE EDI LIN E IDENTIFI ER FIELD
  32561   "RTN","CHM XF004",128 ,0)
  32562    N LICTRL
  32563   "RTN","CHM XF004",129 ,0)
  32564    S LICTRL= $P(^CHMXCL F(CHFI,1), "^",23)                              ; VEND OR PROVIDE D LINE ITE M CONTROL  NUMBER
  32565   "RTN","CHM XF004",130 ,0)
  32566    I LICTRL= "" D
  32567   "RTN","CHM XF004",131 ,0)
  32568    . S LICTR L=$P(^CHMX CLF(CHFI,0 ),"^",2)                             ; HAC  ASSIGNED S ERVICE LIN E NUMBER
  32569   "RTN","CHM XF004",132 ,0)
  32570    . S $P(^C HMXCLF(CHF I,1),"^",2 3)="HAC"_L ICTRL
  32571   "RTN","CHM XF004",133 ,0)
  32572    ;W !,"CHM XF004:GTLX (",CHFI,") : RETRIEVE D: ",LICTR L
  32573   "RTN","CHM XF004",134 ,0)
  32574    Q LICTRL
  32575   "RTN","CHM XF004",135 ,0)
  32576    ;
  32577   "RTN","CHM XF005")
  32578   0^17^B6203 3224
  32579   "RTN","CHM XF005",1,0 )
  32580   CHMXF005 ; CVA/DTP;X1 2 837 CLM  CREATE SET  OPT CLM D ATA TO IMA GE FILE (I NSTITUTION AL BILLING );04/11/00   8:14 AM
  32581   "RTN","CHM XF005",2,0 )
  32582    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  32583   "RTN","CHM XF005",3,0 )
  32584    ;;LOADS T HE LINE IT EMS INTO ^ CHMIMAGE(  GLOBAL
  32585   "RTN","CHM XF005",4,0 )
  32586    ;;CALLED  BY: ^CHMFA 01K, ^CHMX F003
  32587   "RTN","CHM XF005",5,0 )
  32588    ;;
  32589   "RTN","CHM XF005",6,0 )
  32590    ;;JEH 01/ 21/07 - MO DIFIED FOR  ANESHESIA  CODE RATE S
  32591   "RTN","CHM XF005",7,0 )
  32592    ;;ajm 03- 05-07 - mo dified pla ce of serv ice lookup  (DEV00140 0-01)
  32593   "RTN","CHM XF005",8,0 )
  32594    ;;JEH 11/ 15/10 TT E NC003698 -  ADDED AMB ULANCE ZIP  CODE
  32595   "RTN","CHM XF005",9,0 )
  32596    ;;JEH 5/1 2/11 DEF01 2406 - Pos t Ambulanc e Fix - mi ssing TOS
  32597   "RTN","CHM XF005",10, 0)
  32598    ;;DLB 8/1 7/2012 DEV 7820 SLA -  ADDED LOA D FOR ^CHM IMAGE OHI
  32599   "RTN","CHM XF005",11, 0)
  32600    ;;DLB 1/8 /2013 DEV7 820 SLA -  MOVED BALA NCE CHECK  FUNCTIONAL ITY TO CHM XLIMG.INT
  32601   "RTN","CHM XF005",12, 0)
  32602    ;;DLB 1/9 /2013 DEV7 820 SLA -  ADDED FUNC TION GTLX( CHFI) TO R ETRIEVE LI NE ITEM CT RL # OR SE RVICE LINE  #
  32603   "RTN","CHM XF005",13, 0)
  32604    ;;                                AND POPU LATE THE ^ CHMIMAGE()  EDI LINE  IDENTIFIER  FIELD WIT H RESULT
  32605   "RTN","CHM XF005",14, 0)
  32606    ;; DLB 2/ 5/2013         DEV782 0  ADDED C ALL TO BAL CHK IN CHM XLIMG.INT  FOR SLA LO AD TO ^CHM IMAGE
  32607   "RTN","CHM XF005",15, 0)
  32608    ;; DLB 2/ 11/13          DEV782 0  ADDED L OAD FOR PR OCEDURE MO DIFIERS 2, 3,4 TO ^CH MIMAGE
  32609   "RTN","CHM XF005",16, 0)
  32610    ;; DLB 2/ 11/13          ADD DS TFLAG TO I NDICATE DI STRIBUTION  OCCURRED,  BALANCE C HECK REQUI RED
  32611   "RTN","CHM XF005",17, 0)
  32612    ;; DLB 2/ 13/13          CHANGE D "MODIFIE R" VALUES  TO DICTION ARY VALUES
  32613   "RTN","CHM XF005",18, 0)
  32614    ;; BMJ 11 /27/17 Use r Story CP E005-006 M odify Docu ment Ident ification  Screen - T ype of Bil l
  32615   "RTN","CHM XF005",19, 0)
  32616    ;;
  32617   "RTN","CHM XF005",20, 0)
  32618   A S (CHADM ,CHDIS,CHS TS,CHADMDX ,CHBLD,CHD CFAC,CHBNP D,CHTOB,CH CCRL)=""
  32619   "RTN","CHM XF005",21, 0)
  32620    ;G:'$D(^C HMXCLE(CHE I,1)) B
  32621   "RTN","CHM XF005",22, 0)
  32622    I '$D(^CH MXCLE(CHEI ,1)) S ^CH MZHOLD("CH MXF005",0) =CHEI Q      ;;8-9-05  RKN
  32623   "RTN","CHM XF005",23, 0)
  32624    ;Y2K - as sumes cent ury 2 - Fi xed by the  following  two lines
  32625   "RTN","CHM XF005",24, 0)
  32626    ;Y2K S CH ADM=2_$E($ P(^CHMXCLE (CHEI,1)," ^"),3,8)
  32627   "RTN","CHM XF005",25, 0)
  32628    ;Y2K S CH DIS=2_$E($ P(^CHMXCLE (CHEI,1)," ^",2),3,8)
  32629   "RTN","CHM XF005",26, 0)
  32630   B S CHADM= $$YR8FMYR^ CHTFLIB($P (^CHMXCLE( CHEI,1),"^ "))  ;STAT EMENT FROM  DATE
  32631   "RTN","CHM XF005",27, 0)
  32632    S CHDIS=$ $YR8FMYR^C HTFLIB($P( ^CHMXCLE(C HEI,1),"^" ,2))  ;STA TEMENT TO  DATE
  32633   "RTN","CHM XF005",28, 0)
  32634   C G:'$D(^C HMXCLE(CHE I,2)) D
  32635   "RTN","CHM XF005",29, 0)
  32636    S CHBLD=$ P(^CHMXCLE (CHEI,2)," ^"),CHBNPD =$P(^(2)," ^",2)  ;CH BLD -TOTAL  BILLED CH ARGES  CHB NPD - PATI ENT AMOUNT  PAID
  32637   "RTN","CHM XF005",30, 0)
  32638   D S:CHSBTY P=1 CHPOS= 2 ; ASSUME D TO BE OP T HOSP FOR  ALL INSTI TUTIONAL O PT SUBMISS IONS
  32639   "RTN","CHM XF005",31, 0)
  32640    D GETDX K  CHDXARY2
  32641   "RTN","CHM XF005",32, 0)
  32642    ;LOOP THR OUGH LINE  LEVEL, FOR  EACH NEW  DATE GO GE T ALL DX C ODES FROM  CHDXARY AN D SET THEM  UP AT FRO NT END FOR  EACH DATE , NO ADM D X CODE LOA DED
  32643   "RTN","CHM XF005",33, 0)
  32644    S CHFI=0, CHDTHLD="" ,DSTFLG=0
  32645   "RTN","CHM XF005",34, 0)
  32646   D1 S CHFI= $O(^CHMXCL F("B",CHEI ,CHFI)) G: 'CHFI BNPY MNT            ; LOOP  THRU LINE  ITEM ENTR IES
  32647   "RTN","CHM XF005",35, 0)
  32648    G:'$D(^CH MXCLF(CHFI ,0)) D1 G: '$D(^CHMXC LF(CHFI,1) ) D1
  32649   "RTN","CHM XF005",36, 0)
  32650    S CHFREC1 =^CHMXCLF( CHFI,1)
  32651   "RTN","CHM XF005",37, 0)
  32652    ;S CHREV= $P(CHFREC1 ,"^") G:CH REV="001"  D1 D RVCNV RT             ;SKD 8 -28-07 DEV 003081-02
  32653   "RTN","CHM XF005",38, 0)
  32654    S CHREV=$ P(CHFREC1, "^") G:+CH REV'>1 D1  D RVCNVRT                          ;SKD 8-2 8-07 DEV00 3081-02
  32655   "RTN","CHM XF005",39, 0)
  32656    S CHSVCDT =$$YR8FMYR ^CHTFLIB($ P(CHFREC1, "^",11))
  32657   "RTN","CHM XF005",40, 0)
  32658    S:CHSVCDT ="" CHSVCD T=CHADM
  32659   "RTN","CHM XF005",41, 0)
  32660    ;D FUTDOS ^CHMXF009  ****INSERT  FUTURE DA TE OF SERV ICE CHECK  HERE
  32661   "RTN","CHM XF005",42, 0)
  32662    I CHDTHLD ="" D DXSE T G D2
  32663   "RTN","CHM XF005",43, 0)
  32664    I CHDTHLD '=CHSVCDT  D DXSET
  32665   "RTN","CHM XF005",44, 0)
  32666    ;;NEXT NE STED DO IS  CHECK FOR  MULTIPLE  DOS WITH B ENE PAYMEN T
  32667   "RTN","CHM XF005",45, 0)
  32668   D2 G:CHDTH LD="" D3
  32669   "RTN","CHM XF005",46, 0)
  32670    I (CHDTHL D'=CHSVCDT )&(+CHBNPD >0) D
  32671   "RTN","CHM XF005",47, 0)
  32672    .S ZZ=999 99,ZZ=$O(^ CHMXCLE(CH EI,101,ZZ) ,-1) S:'ZZ  ZZ=0
  32673   "RTN","CHM XF005",48, 0)
  32674    .S CHRJRS N="",CHIL= "CHEI",CHG LBL="^CHMX CLE(",CHFN =741210.12 101
  32675   "RTN","CHM XF005",49, 0)
  32676    .S CHXREC ="E005",CH RCERR(CHXR EC,"E11x") =""
  32677   "RTN","CHM XF005",50, 0)
  32678    .D C^CHMX P003 K CHR CERR
  32679   "RTN","CHM XF005",51, 0)
  32680    .Q
  32681   "RTN","CHM XF005",52, 0)
  32682   D3 ; 
  32683   "RTN","CHM XF005",53, 0)
  32684    I $G(CHJR XCOD(CHFI) )'="" S CH PX=$$PXCNV RT^CHEDILI B(CHJRXCOD (CHFI),"B" ),CHPXO=$$ PXCNVRT^CH EDILIB($P( CHFREC1,"^ ",3),"B")
  32685   "RTN","CHM XF005",54, 0)
  32686    I $G(CHJR XCOD(CHFI) )="" S CHP X=$$PXCNVR T^CHEDILIB ($P(CHFREC 1,"^",3)," B"),CHPXO= ""
  32687   "RTN","CHM XF005",55, 0)
  32688    ;;S CHPX= $$PXCNVRT^ CHEDILIB(C HPX,"B") ; convert th e proc cod e to ^CHMS ERV I val 
  32689   "RTN","CHM XF005",56, 0)
  32690    ;;G:$G(CH PX)="" D1   ;SKD 7-11 -07 DEV002 710-01
  32691   "RTN","CHM XF005",57, 0)
  32692    S CHREV=$ P(CHFREC1, "^") G:+CH REV'>1 D1  D RVCNVRT   ;SKD 8-28 -07 DEV003 081-02  ;A EB 2/4/200 8 DEV00336 7
  32693   "RTN","CHM XF005",58, 0)
  32694    S CHPXCHR G=$P(CHFRE C1,"^",6)
  32695   "RTN","CHM XF005",59, 0)
  32696    S CHPMOD1 =$P(CHFREC 1,"^",4) S :CHPMOD1'= "" CHPMOD1 =$O(^CHMDI C(741002.3 7,"B",CHPM OD1,0))          ; DL B 2/11/13  PROCEDURE  MODIFIERS
  32697   "RTN","CHM XF005",60, 0)
  32698    S CHPMOD2 =$P(CHFREC 1,"^",5) S :CHPMOD2'= "" CHPMOD2 =$O(^CHMDI C(741002.3 7,"B",CHPM OD2,0))          ; DL B 2/13/13  SET MOD VA LUES TO DI CTIONARY V ALUES
  32699   "RTN","CHM XF005",61, 0)
  32700    S CHPMOD3 =$P(CHFREC 1,"^",14)  S:CHPMOD3' ="" CHPMOD 3=$O(^CHMD IC(741002. 37,"B",CHP MOD3,0))
  32701   "RTN","CHM XF005",62, 0)
  32702    S CHPMOD4 =$P(CHFREC 1,"^",15)  S:CHPMOD4' ="" CHPMOD 4=$O(^CHMD IC(741002. 37,"B",CHP MOD4,0))    
  32703   "RTN","CHM XF005",63, 0)
  32704    D MODSEL
  32705   "RTN","CHM XF005",64, 0)
  32706    S CHLINE= $$GTLX(CHF I)                                              ;DLB 1 /9/2013 GE T THE LINE  ITEM CTRL  # OR SERV ICE LINE #
  32707   "RTN","CHM XF005",65, 0)
  32708    S CHUNITS =$P(CHFREC 1,"^",8)
  32709   "RTN","CHM XF005",66, 0)
  32710    D ANCALC    ;CALCULA TE THE NUM BER OF UNI TS PER COD E TO INCLU DE RVU'S A ND CONVERT S MINUTES  TO UNITS
  32711   "RTN","CHM XF005",67, 0)
  32712    S:CHUNITS ="" CHUNIT S=1 S:CHUN ITS=0 CHUN ITS=1
  32713   "RTN","CHM XF005",68, 0)
  32714    S:'$G(CHT OS) CHTOS= $P(^CHMIMA GE(CHMFPDI ,1,1,2,1,0 ),"^",5)    ;JEH 5/12 /11 DEF012 406
  32715   "RTN","CHM XF005",69, 0)
  32716    I CHPOS=2  D SETAMBZ P^CHEDILIB (CHFREC1,2 ,CHTOS,CHM FPDI,CHTOS J,CHEI)     ;JEH 11/1 5/10 TT EN C003698 -  ADD SUB-RT N CALL
  32717   "RTN","CHM XF005",70, 0)
  32718    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"O PT-NS",CHI MGL),-1),C HIMGL=CHIM GL+1
  32719   "RTN","CHM XF005",71, 0)
  32720   E S ^CHMIM AGE(CHMFPD I,1,CHTOSJ ,2,1,"OPT- NS",CHIMGL ,0)=CHSVCD T_"^"_CHPO S_"^"_CHDF N_"^"_CHBF N_"^^^"_CH PX_"^"_CHP XCHRG_"^"_ CHPMOD1_"^ ^^^^"_CHRE V_"^"_CHPX CHRG_"^"_C HLINE_"^"_ CHUNITS_"^ ^"_CHPXO_" ^"_CHPMOD2 _"^"_CHPMO D3_"^"_CHP MOD4
  32721   "RTN","CHM XF005",72, 0)
  32722    ;W !,"CHM XF005:D3:I NST ""OPT- NS"" = ",^ CHMIMAGE(C HMFPDI,1,C HTOSJ,2,1, "OPT-NS",C HIMGL,0)
  32723   "RTN","CHM XF005",73, 0)
  32724    S CHDTHLD =CHSVCDT,C HIMGK=1
  32725   "RTN","CHM XF005",74, 0)
  32726    S DSTFLG= DSTFLG+$$L DCHMIMG^CH MXLIMG(CHE I,CHFI,CHM FPDI,CHTOS J,CHIMGK,C HIMGL,"OPT -NS")                     ; DLB  SLA ADDED  LOAD FOR ^ CHMIMAGE
  32727   "RTN","CHM XF005",75, 0)
  32728    G D1
  32729   "RTN","CHM XF005",76, 0)
  32730    ; 
  32731   "RTN","CHM XF005",77, 0)
  32732   BNPYMNT ;; SETS UP BE NE PAYMENT  AT END OF  IMAGE FIL E
  32733   "RTN","CHM XF005",78, 0)
  32734    D:DSTFLG  BALCHK^CHM XLIMG(CHEI ,CHMFPDI,C HTOSJ,CHIM GK,CHIMGL, "OPT-NS")                                       ; SLA  FINAL BALA NCE CHECK  AGAINST CL AIM OHOIPD  
  32735   "RTN","CHM XF005",79, 0)
  32736    G:CHBNPD= "" END
  32737   "RTN","CHM XF005",80, 0)
  32738    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"O PT-NS",CHI MGL),-1),C HIMGL=CHIM GL+1
  32739   "RTN","CHM XF005",81, 0)
  32740    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"OPT-N S",CHIMGL, 0)=CHSVCDT _"^"_CHPOS _"^"_CHDFN _"^"_CHBFN _"^^"_CHBN PD
  32741   "RTN","CHM XF005",82, 0)
  32742    ; 
  32743   "RTN","CHM XF005",83, 0)
  32744   END S (CHT OB,CHCCRL) =""
  32745   "RTN","CHM XF005",84, 0)
  32746    ;I $D(^CH MXCLE(CHEI ,0)),($P(^ (0),"^",5) ="A")!($P( ^(0),"^",5 )="a") S C HTOB=$P(^( 0),"^",4)_ $P(^(0),"^ ",6)
  32747   "RTN","CHM XF005",85, 0)
  32748    I $D(^CHM XCLE(CHEI, 0)) S CHTO B=$P(^(0), "^",4)_$P( ^(0),"^",6 )  ; 11/27 /17 BMJ Us er Story C PE005-006  Changed th e line abo ve to this  line
  32749   "RTN","CHM XF005",86, 0)
  32750    I $D(^CHM XCLE(CHEI, 0)),$P(^(0 ),"^",2)'= "" S CHCCR L=$P(^(0), "^",2)
  32751   "RTN","CHM XF005",87, 0)
  32752    S $P(^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"VE N"),"^",7) =CHTOB,$P( ^("VEN")," ^",9)=2,$P (^("VEN"), "^",17)=CH CCRL
  32753   "RTN","CHM XF005",88, 0)
  32754    D:'$D(CHR DOIMG) BUF FND
  32755   "RTN","CHM XF005",89, 0)
  32756    K CHADM,C HDIS,CHBLD ,CHBNPD,CH EJJ,CHDX,C HPX,CHI,CH CCRL,CHTOB ,CHREV,CHP OS
  32757   "RTN","CHM XF005",90, 0)
  32758    K SKIPFLG ,CHSBTYP,C HFI,CHDTHL D,CHFREC1, CHSVCDT,CH PXCHRG,CHP MOD1,CHPMO D2
  32759   "RTN","CHM XF005",91, 0)
  32760    K CHPMOD, CHLINE,CHU NITS,CHIMG L Q
  32761   "RTN","CHM XF005",92, 0)
  32762    ; 
  32763   "RTN","CHM XF005",93, 0)
  32764   BUFFND S ^ CHMIMAGE(C HMFPDI,"BU FF")=CHTPI D_"^"_CHMX I_"^"_CHAI _"^"_CHBI_ "^"_CHCI_" ^"_CHEI
  32765   "RTN","CHM XF005",94, 0)
  32766    Q
  32767   "RTN","CHM XF005",95, 0)
  32768    ; 
  32769   "RTN","CHM XF005",96, 0)
  32770   DXCNVRT K  SKIPFLG
  32771   "RTN","CHM XF005",97, 0)
  32772    I '$D(CHD X) S CHDX= "" Q
  32773   "RTN","CHM XF005",98, 0)
  32774    Q:CHDX=""
  32775   "RTN","CHM XF005",99, 0)
  32776    I '$D(^CH MICDX("C", CHDX)) S C HDX="" Q
  32777   "RTN","CHM XF005",100 ,0)
  32778    S CHI=0,C HI=$O(^CHM ICDX("C",C HDX,0)) I  'CHI S CHD X="" Q
  32779   "RTN","CHM XF005",101 ,0)
  32780    S CHDX=CH I
  32781   "RTN","CHM XF005",102 ,0)
  32782    Q
  32783   "RTN","CHM XF005",103 ,0)
  32784    ;  
  32785   "RTN","CHM XF005",104 ,0)
  32786   RVCNVRT K  SKIPFLG S  CHI=""  ;A EB 4/3/200 8
  32787   "RTN","CHM XF005",105 ,0)
  32788    I '$D(CHR EV) S CHRE V="" Q
  32789   "RTN","CHM XF005",106 ,0)
  32790    Q:CHREV=" "
  32791   "RTN","CHM XF005",107 ,0)
  32792    I $L(CHRE V)=4 D ;AE B 2/4/2008  DEV003367  
  32793   "RTN","CHM XF005",108 ,0)
  32794    .I '$D(^C HMXDIC(741 201.39,"B" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  32795   "RTN","CHM XF005",109 ,0)
  32796    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"B", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  32797   "RTN","CHM XF005",110 ,0)
  32798    .Q  ;AEB  2/4/2008 D EV003367
  32799   "RTN","CHM XF005",111 ,0)
  32800    I $L(CHRE V)=3 D  ;A EB 2/4/200 8 DEV00336 7
  32801   "RTN","CHM XF005",112 ,0)
  32802    .I '$D(^C HMXDIC(741 201.39,"H" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  32803   "RTN","CHM XF005",113 ,0)
  32804    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"H", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  32805   "RTN","CHM XF005",114 ,0)
  32806    .Q  ;AEB  2/4/2008 D EV003367
  32807   "RTN","CHM XF005",115 ,0)
  32808    I 'CHI S  CHREV="" Q   ;AEB 2/4 /2008 DEV0 03367
  32809   "RTN","CHM XF005",116 ,0)
  32810    S CHREV=C HI 
  32811   "RTN","CHM XF005",117 ,0)
  32812    Q
  32813   "RTN","CHM XF005",118 ,0)
  32814    ; 
  32815   "RTN","CHM XF005",119 ,0)
  32816   GETDX ;;LO AD ALL DX  CODES, EXC EPT ADM DX , INTO CHD XARY
  32817   "RTN","CHM XF005",120 ,0)
  32818    K CHDXARY
  32819   "RTN","CHM XF005",121 ,0)
  32820   GETDX1 Q:' $D(^CHMXCL E(CHEI,40) )
  32821   "RTN","CHM XF005",122 ,0)
  32822    S CHEJJ=0
  32823   "RTN","CHM XF005",123 ,0)
  32824   GETDXL1 S  CHEJJ=$O(^ CHMXCLE(CH EI,40,CHEJ J)) Q:'CHE JJ
  32825   "RTN","CHM XF005",124 ,0)
  32826    G:'$D(^CH MXCLE(CHEI ,40,CHEJJ, 0)) GETDXL 1 S CHDX=$ P(^CHMXCLE (CHEI,40,C HEJJ,0),"^ ",1) G:CHD X="" GETDX L1  ;AEB 1 1/4/2010
  32827   "RTN","CHM XF005",125 ,0)
  32828    D DXCNVRT  G:$D(SKIP FLG) GETDX L1
  32829   "RTN","CHM XF005",126 ,0)
  32830    S CHDXARY (CHEJJ)=CH DX
  32831   "RTN","CHM XF005",127 ,0)
  32832    G GETDXL1
  32833   "RTN","CHM XF005",128 ,0)
  32834    ; 
  32835   "RTN","CHM XF005",129 ,0)
  32836   MODSEL ;;M ODIFIER OR DER OF IMP ORTANCE:   80,81,82,A S,26,TC, T HEN FIRST  SUBMITTED
  32837   "RTN","CHM XF005",130 ,0)
  32838    I (CHPMOD 1=80)!(CHP MOD1=81)!( CHPMOD1=82 )!(CHPMOD1 ="AS") S C HPMOD=CHPM OD1 D MODC VRT Q
  32839   "RTN","CHM XF005",131 ,0)
  32840    I (CHPMOD 2=80)!(CHP MOD2=81)!( CHPMOD2=82 )!(CHPMOD2 ="AS") S C HPMOD=CHPM OD2 D MODC VRT Q
  32841   "RTN","CHM XF005",132 ,0)
  32842    I (CHPMOD 1=26)!(CHP MOD1="TC")  S CHPMOD= CHPMOD1 D  MODCVRT Q
  32843   "RTN","CHM XF005",133 ,0)
  32844    I (CHPMOD 2=26)!(CHP MOD2="TC")  S CHPMOD= CHPMOD2 D  MODCVRT Q
  32845   "RTN","CHM XF005",134 ,0)
  32846    S CHPMOD= CHPMOD1 D  MODCVRT
  32847   "RTN","CHM XF005",135 ,0)
  32848    Q
  32849   "RTN","CHM XF005",136 ,0)
  32850    ; 
  32851   "RTN","CHM XF005",137 ,0)
  32852   MODCVRT Q: '$D(CHPMOD )  Q:CHPMO D=""
  32853   "RTN","CHM XF005",138 ,0)
  32854    S:$D(^CHM DIC(741002 .37,"B",CH PMOD)) CHP MOD=$O(^CH MDIC(74100 2.37,"B",C HPMOD,0))
  32855   "RTN","CHM XF005",139 ,0)
  32856    Q
  32857   "RTN","CHM XF005",140 ,0)
  32858   DXSET ;;LO AD ALL DXS  FROM ARRA Y INTO CHM IMAGE FILE  FOR EACH  DOS
  32859   "RTN","CHM XF005",141 ,0)
  32860    S CHEJJ=" "
  32861   "RTN","CHM XF005",142 ,0)
  32862   DXS1 S CHE JJ=$O(CHDX ARY(CHEJJ) ) Q:CHEJJ' ?1N.N  Q:C HEJJ=""
  32863   "RTN","CHM XF005",143 ,0)
  32864    G:'$D(CHD XARY(CHEJJ )) DXS1
  32865   "RTN","CHM XF005",144 ,0)
  32866    S CHDXINS =CHDXARY(C HEJJ) S:CH DXINS="" C HDXINS="UN K"
  32867   "RTN","CHM XF005",145 ,0)
  32868    ;I $G(CHS VCDT)="" G  DXS1   ;S KD, 10-6-0 5, if this  field is  missing, t he system  quits and  wont proce ss the res t of PDIs  in the OCR  batch.
  32869   "RTN","CHM XF005",146 ,0)
  32870    ;I $G(CHD XINS)="" G  DXS1   ;S KD, 10-6-0 5, if this  field is  missing, t he system  quits and  wont proce ss the res t of PDIs  in the OCR  batch.
  32871   "RTN","CHM XF005",147 ,0)
  32872    G:$D(CHDX ARY2(CHSVC DT,CHDXINS )) DXS1 S  CHDXARY2(C HSVCDT,CHD XINS)=""
  32873   "RTN","CHM XF005",148 ,0)
  32874    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"O PT-NS",CHI MGL),-1),C HIMGL=CHIM GL+1
  32875   "RTN","CHM XF005",149 ,0)
  32876    S:CHDXINS ="UNK" CHD XINS=""
  32877   "RTN","CHM XF005",150 ,0)
  32878    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"OPT-N S",CHIMGL, 0)=CHSVCDT _"^"_CHPOS _"^"_CHDFN _"^"_CHBFN _"^^^^^^"_ CHDXINS
  32879   "RTN","CHM XF005",151 ,0)
  32880    G DXS1
  32881   "RTN","CHM XF005",152 ,0)
  32882    Q
  32883   "RTN","CHM XF005",153 ,0)
  32884   ANCALC ;CA LCULATE TH E NUMBER O F UNITS FR OM MINUTES +RVUs OR U NITS+RVUs  SUBMITTED
  32885   "RTN","CHM XF005",154 ,0)
  32886    Q:CHUNITS =""
  32887   "RTN","CHM XF005",155 ,0)
  32888    Q:CHUNITS =0
  32889   "RTN","CHM XF005",156 ,0)
  32890    Q:CHPX=""
  32891   "RTN","CHM XF005",157 ,0)
  32892    Q:'$D(CHP X)
  32893   "RTN","CHM XF005",158 ,0)
  32894    I $D(^CHM SERV(CHPX, 4)) D
  32895   "RTN","CHM XF005",159 ,0)
  32896    .S CHQLFY R=$P(CHFRE C1,"^",7)
  32897   "RTN","CHM XF005",160 ,0)
  32898    .Q:'$D(CH QLFYR)
  32899   "RTN","CHM XF005",161 ,0)
  32900    .Q:CHQLFY R=""
  32901   "RTN","CHM XF005",162 ,0)
  32902    .S CHCDEF D=9999999- CHSVCDT
  32903   "RTN","CHM XF005",163 ,0)
  32904    .S CHCDEF D=$O(^CHMS ERV(CHPX,4 ,"B",CHCDE FD),-1)
  32905   "RTN","CHM XF005",164 ,0)
  32906    .S CHCJPT R=0 S CHCJ PTR=$O(^CH MSERV(CHPX ,4,"B",CHC DEFD,CHCJP TR))
  32907   "RTN","CHM XF005",165 ,0)
  32908    .S BASU=$ P(^CHMSERV (CHPX,4,CH CJPTR,0)," ^",2)
  32909   "RTN","CHM XF005",166 ,0)
  32910    .I CHQLFY R="UN" D
  32911   "RTN","CHM XF005",167 ,0)
  32912    ..S CHUNI TS=CHUNITS +BASU
  32913   "RTN","CHM XF005",168 ,0)
  32914    .I CHQLFY R="MJ" D
  32915   "RTN","CHM XF005",169 ,0)
  32916    ..S TIMU= 0
  32917   "RTN","CHM XF005",170 ,0)
  32918    ..S UNIT= CHUNITS#15
  32919   "RTN","CHM XF005",171 ,0)
  32920    ..S TIMU= (CHUNITS-U NIT)/15 
  32921   "RTN","CHM XF005",172 ,0)
  32922    ..S:UNIT' =0 TIMU=TI MU+1
  32923   "RTN","CHM XF005",173 ,0)
  32924    ..S CHUNI TS=TIMU+BA SU
  32925   "RTN","CHM XF005",174 ,0)
  32926    K CHQLFYR ,BASU,TIMU ,CHCDEFD,C HCJPTR,UNI T
  32927   "RTN","CHM XF005",175 ,0)
  32928    Q
  32929   "RTN","CHM XF005",176 ,0)
  32930    ;
  32931   "RTN","CHM XF005",177 ,0)
  32932   GTLX(CHFI)                                                                                      ;  DLB 1/9/20 13 POPULAT E THE ^CHM IMAGE EDI  LINE IDENT IFIER FIEL D
  32933   "RTN","CHM XF005",178 ,0)
  32934    N LICTRL
  32935   "RTN","CHM XF005",179 ,0)
  32936    S LICTRL= $P(^CHMXCL F(CHFI,1), "^",23)                              ; VEND OR PROVIDE D LINE ITE M CONTROL  NUMBER
  32937   "RTN","CHM XF005",180 ,0)
  32938    I LICTRL= "" D
  32939   "RTN","CHM XF005",181 ,0)
  32940    . S LICTR L=$P(^CHMX CLF(CHFI,0 ),"^",2)                             ; HAC  ASSIGNED S ERVICE LIN E NUMBER
  32941   "RTN","CHM XF005",182 ,0)
  32942    . S $P(^C HMXCLF(CHF I,1),"^",2 3)="HAC"_L ICTRL
  32943   "RTN","CHM XF005",183 ,0)
  32944    ;W !,"CHM XF005:GTLX (",CHFI,") : RETRIEVE D: ",LICTR L
  32945   "RTN","CHM XF005",184 ,0)
  32946    Q LICTRL
  32947   "RTN","CHM XF006")
  32948   0^18^B7946 5935
  32949   "RTN","CHM XF006",1,0 )
  32950   CHMXF006 ; CVA/DTP;X1 2 837 CLM  CREATE SET  OPT CLM D ATA TO IMA GE FILE (P ROFESSIONA L/HCFA);08 /22/02  3: 16 PM
  32951   "RTN","CHM XF006",2,0 )
  32952    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  32953   "RTN","CHM XF006",3,0 )
  32954    ;;
  32955   "RTN","CHM XF006",4,0 )
  32956    ;;JEH 01/ 21/07 - MO DIFIED FOR  ANESHESIA  CODE RATE S
  32957   "RTN","CHM XF006",5,0 )
  32958    ;;ajm 03- 05-07 - mo dified pla ce of serv ice lookup  (DEV00140 0-01)
  32959   "RTN","CHM XF006",6,0 )
  32960    ;;JEH 11/ 15/10 TT E NC003698 -  ADDED AMB ULANCE ZIP  CODE
  32961   "RTN","CHM XF006",7,0 )
  32962    ;;DLB 8/1 7/2010 DEV 7820 SLA ^ CHMIMAGE L OAD
  32963   "RTN","CHM XF006",8,0 )
  32964    ;;DLB 1/8 /2013 DEV7 820 SLA BA LANCE CHEC K MOVED IN TO CHMXLIM G.INT
  32965   "RTN","CHM XF006",9,0 )
  32966    ;;DLB 1/9 /2013 DEV7 820 ADDED  GTLX(CHFI)  FUNCTION  TO RETRIEV E THE LINE  ITEM CTRL  # OR SERV ICE LINE #
  32967   "RTN","CHM XF006",10, 0)
  32968    ;;                                AND POPU LATE THE ^ CHMIMAGE E DI LINE ID ENTIFIER F IELD
  32969   "RTN","CHM XF006",11, 0)
  32970    ;; DLB 2/ 5/2013         DEV782 0  ADDED C ALL TO BAL CHK IN CHM XLIMG.INT  FOR SLA LO AD TO ^CHM IMAGE
  32971   "RTN","CHM XF006",12, 0)
  32972    ;; DLB 2/ 11/2013        DEV782 0  ADDED T HE MOVE FO R PROCEDUR E MODIFIER S 2,3,4 IN TO ^CHMIMA GE
  32973   "RTN","CHM XF006",13, 0)
  32974    ;; DLB 2/ 13/13          CHANGE D "MODIFIE R" VALUES  TO DICTION ARY VALUES
  32975   "RTN","CHM XF006",14, 0)
  32976    ;; BMJ 11 /27/17 Use r Story CP E005-006 M odify Docu ment Ident ification  Screen - T ype of Bil l
  32977   "RTN","CHM XF006",15, 0)
  32978    ;;
  32979   "RTN","CHM XF006",16, 0)
  32980   A S (CHADM ,CHDIS,CHS TS,CHADMDX ,CHBLD,CHD CFAC,CHBNP D,CHTOB,CH CCRL)=""
  32981   "RTN","CHM XF006",17, 0)
  32982    G:'$D(^CH MXCLE(CHEI ,1)) C
  32983   "RTN","CHM XF006",18, 0)
  32984    ;Y2K - as sumes cent ury 2 - Fi xed by the  following  two lines
  32985   "RTN","CHM XF006",19, 0)
  32986    ;Y2K S CH ADM=2_$E($ P(^CHMXCLE (CHEI,1)," ^"),3,8)
  32987   "RTN","CHM XF006",20, 0)
  32988    ;Y2K S CH DIS=2_$E($ P(^CHMXCLE (CHEI,1)," ^",2),3,8)
  32989   "RTN","CHM XF006",21, 0)
  32990   B S CHADM= $$YR8FMYR^ CHTFLIB($P (^CHMXCLE( CHEI,1),"^ ",1))          ; STAT EMENT FROM  DATE
  32991   "RTN","CHM XF006",22, 0)
  32992    S CHDIS=$ $YR8FMYR^C HTFLIB($P( ^CHMXCLE(C HEI,1),"^" ,2))           ; STAT EMENT TO D ATE
  32993   "RTN","CHM XF006",23, 0)
  32994   C S CHXSTY P=$P(^CHMX CLA(CHAI,8 0),"^",7)                                             
  32995   "RTN","CHM XF006",24, 0)
  32996    G:'$D(^CH MXCLE(CHEI ,2)) D
  32997   "RTN","CHM XF006",25, 0)
  32998    S CHBLD=$ P(^CHMXCLE (CHEI,2)," ^",1)                                                          ;  TOTAL CHAR GES BILLED
  32999   "RTN","CHM XF006",26, 0)
  33000    S CHBNPD= $P(^CHMXCL E(CHEI,2), "^",2)                                                 ; PATIENT  AMOUNT PAI D
  33001   "RTN","CHM XF006",27, 0)
  33002   D S CHPOS= $P(^CHMXCL E(CHEI,0), "^",4)                                                 ; PLACE OF  SERVICE/T OB
  33003   "RTN","CHM XF006",28, 0)
  33004    S:(CHSBTY P=2)&(CHPO S="") CHPO S=11                                                           ;  DEFAULT FO R PROF = D OCTOR'S OF FICE 
  33005   "RTN","CHM XF006",29, 0)
  33006    D POSLU
  33007   "RTN","CHM XF006",30, 0)
  33008    ;GETDX LO OPS THROUG H LINE LEV EL, FOR EA CH SERVICE  LINE GET  ALL DX COD ES, IF NO  DATA IN CH DXARY2(DT, DXCD) SET  IN CHDXARY 2 BY DATE  AND SET UP  IN IMAGE  FILE
  33009   "RTN","CHM XF006",31, 0)
  33010    ;KKAIEL
  33011   "RTN","CHM XF006",32, 0)
  33012    D GETDX
  33013   "RTN","CHM XF006",33, 0)
  33014    S CHFI=0, CHDTHLD="" ,DSTFLG=0                                                                 ;  DISTRIBUTI ON FLAG FO R ^CHMIMAG E LOAD
  33015   "RTN","CHM XF006",34, 0)
  33016   D1 S CHFI= $O(^CHMXCL F("B",CHEI ,CHFI)) G: 'CHFI BNPY MNT
  33017   "RTN","CHM XF006",35, 0)
  33018    G:'$D(^CH MXCLF(CHFI ,0)) D1 G: '$D(^CHMXC LF(CHFI,1) ) D1
  33019   "RTN","CHM XF006",36, 0)
  33020    S CHFREC1 =^CHMXCLF( CHFI,1)                                                                            ; RE VENUE CODE  NODE
  33021   "RTN","CHM XF006",37, 0)
  33022    ;S CHREV= $P(CHFREC1 ,"^") G:CH REV="001"  D1 D RVCNV RT             ; SKD  8-28-07 DE V003081-02
  33023   "RTN","CHM XF006",38, 0)
  33024    S CHREV=$ P(CHFREC1, "^") G:+CH REV'>1 D1  D RVCNVRT                          ; SKD 8- 28-07 DEV0 03081-02
  33025   "RTN","CHM XF006",39, 0)
  33026    S CHSVCDT =$$YR8FMYR ^CHTFLIB($ P(CHFREC1, "^",11))                           ; SERVIC E FROM DAT E
  33027   "RTN","CHM XF006",40, 0)
  33028    S:(CHSVCD T="")&(CHA DM'="") CH SVCDT=CHAD M
  33029   "RTN","CHM XF006",41, 0)
  33030    ;D FUTDOS ^CHMXF009  ****INSERT  FUTURE DA TE OF SERV ICE CHECK  HERE
  33031   "RTN","CHM XF006",42, 0)
  33032    ;;NEXT NE STED DO IS  CHECK FOR  MULTIPLE  DOS WITH B ENE PAYMEN T
  33033   "RTN","CHM XF006",43, 0)
  33034   D2 G:CHDTH LD="" D3
  33035   "RTN","CHM XF006",44, 0)
  33036    I (CHDTHL D'=CHSVCDT )&(+CHBNPD >0) D
  33037   "RTN","CHM XF006",45, 0)
  33038    .S ZZ=999 99,ZZ=$O(^ CHMXCLE(CH EI,101,ZZ) ,-1) S:'ZZ  ZZ=0
  33039   "RTN","CHM XF006",46, 0)
  33040    .S CHRJRS N="",CHIL= "CHEI",CHG LBL="^CHMX CLE(",CHFN =741210.12 101
  33041   "RTN","CHM XF006",47, 0)
  33042    .S CHXREC ="E005",CH RCERR(CHXR EC,"E11x") =""
  33043   "RTN","CHM XF006",48, 0)
  33044    .D C^CHMX P003 K CHR CERR
  33045   "RTN","CHM XF006",49, 0)
  33046    .Q
  33047   "RTN","CHM XF006",50, 0)
  33048   D3 ;
  33049   "RTN","CHM XF006",51, 0)
  33050    I $G(CHJR XCOD(CHFI) )'="" S CH PX=$$PXCNV RT^CHEDILI B(CHJRXCOD (CHFI),"B" ),CHPXO=$$ PXCNVRT^CH EDILIB($P( CHFREC1,"^ ",3),"B")
  33051   "RTN","CHM XF006",52, 0)
  33052    I $G(CHJR XCOD(CHFI) )="" S CHP X=$$PXCNVR T^CHEDILIB ($P(CHFREC 1,"^",3)," B"),CHPXO= ""
  33053   "RTN","CHM XF006",53, 0)
  33054    ;;S CHPX= $$PXCNVRT^ CHEDILIB(C HPX,"B") ; convert th e proc cod e to ^CHMS ERV I val 
  33055   "RTN","CHM XF006",54, 0)
  33056    ;;G:$G(CH PX)="" D1   ;SKD 7-11 -07 DEV002 710-01
  33057   "RTN","CHM XF006",55, 0)
  33058    S CHREV=$ P(CHFREC1, "^") G:+CH REV'>1 D1  D RVCNVRT                          ;SKD 8-2 8-07 DEV00 3081-02  ; AEB 2/4/20 08 DEV0033 67
  33059   "RTN","CHM XF006",56, 0)
  33060    S CHPXCHR G=$P(CHFRE C1,"^",6)                                                                 ;  SVC LINE B ILLED CHAR GE
  33061   "RTN","CHM XF006",57, 0)
  33062    S CHPMOD1 =$P(CHFREC 1,"^",4) S :CHPMOD1'= "" CHPMOD1 =$O(^CHMDI C(741002.3 7,"B",CHPM OD1,0))          ; DL B 2/11/13  PROCEDURE  MODIFIERS
  33063   "RTN","CHM XF006",58, 0)
  33064    S CHPMOD2 =$P(CHFREC 1,"^",5) S :CHPMOD2'= "" CHPMOD2 =$O(^CHMDI C(741002.3 7,"B",CHPM OD2,0))          ; DL B 2/13/13  SET MOD VA LUES TO DI CTIONARY V ALUES
  33065   "RTN","CHM XF006",59, 0)
  33066    S CHPMOD3 =$P(CHFREC 1,"^",14)  S:CHPMOD3' ="" CHPMOD 3=$O(^CHMD IC(741002. 37,"B",CHP MOD3,0))
  33067   "RTN","CHM XF006",60, 0)
  33068    S CHPMOD4 =$P(CHFREC 1,"^",15)  S:CHPMOD4' ="" CHPMOD 4=$O(^CHMD IC(741002. 37,"B",CHP MOD4,0))    
  33069   "RTN","CHM XF006",61, 0)
  33070    D MODSEL
  33071   "RTN","CHM XF006",62, 0)
  33072    S CHLINE= $$GTLX(CHF I)                                                                                 ; DL B 1/9/2013  RETRIEVE  LICTRL # O R SVC LINE  #
  33073   "RTN","CHM XF006",63, 0)
  33074    S CHUNITS =$P(CHFREC 1,"^",8)                                                                  ;  HC CODE UN ITS
  33075   "RTN","CHM XF006",64, 0)
  33076    D ANCALC    ;CALCULA TE THE NUM BER OF UNI TS PER COD E TO INCLU DE RVU'S A ND CONVERT S MINUTES  TO UNITS
  33077   "RTN","CHM XF006",65, 0)
  33078    S:CHUNITS ="" CHUNIT S=1 S:CHUN ITS=0 CHUN ITS=1
  33079   "RTN","CHM XF006",66, 0)
  33080    S:$P(CHFR EC1,"^",16 )'="" CHPO S=$P(CHFRE C1,"^",16)                         ; PLACE  OF SERVICE
  33081   "RTN","CHM XF006",67, 0)
  33082    D POSLU
  33083   "RTN","CHM XF006",68, 0)
  33084    I CHPOSI= 10 D SETAM BZP^CHEDIL IB(CHFREC1 ,10,CHTOS, CHMFPDI,CH TOSJ,CHEI)     ;JEH 1 1/15/10 TT  ENC003698  - ADD SUB -RTN CALL
  33085   "RTN","CHM XF006",69, 0)
  33086    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"O PT-NS",CHI MGL),-1),C HIMGL=CHIM GL+1
  33087   "RTN","CHM XF006",70, 0)
  33088   E S ^CHMIM AGE(CHMFPD I,1,CHTOSJ ,2,1,"OPT- NS",CHIMGL ,0)=CHSVCD T_"^"_CHPO SI_"^"_CHD FN_"^"_CHB FN_"^^^"_C HPX_"^"_CH PXCHRG_"^" _CHPMOD1_" ^^^^^"_CHR EV_"^"_CHP XCHRG_"^"_ CHLINE_"^" _CHUNITS_" ^^"_CHPXO_ "^"_CHPMOD 2_"^"_CHPM OD3_"^"_CH PMOD4
  33089   "RTN","CHM XF006",71, 0)
  33090    ;W !,"CHM XF006:E:PR OF ""OPT-N S"" = ",^C HMIMAGE(CH MFPDI,1,CH TOSJ,2,1," OPT-NS",CH IMGL,0),"   CHIMGL= " ,CHIMGL
  33091   "RTN","CHM XF006",72, 0)
  33092    S CHDTHLD =CHSVCDT,C HIMGK=1
  33093   "RTN","CHM XF006",73, 0)
  33094    ;W !,"CHM XF006:  PR OFESSIONAL /HCFA CLAI M: ",CHMFP DI
  33095   "RTN","CHM XF006",74, 0)
  33096    S DSTFLG= DSTFLG+$$L DCHMIMG^CH MXLIMG(CHE I,CHFI,CHM FPDI,CHTOS J,CHIMGK,C HIMGL,"OPT -NS")
  33097   "RTN","CHM XF006",75, 0)
  33098    G D1
  33099   "RTN","CHM XF006",76, 0)
  33100    ; 
  33101   "RTN","CHM XF006",77, 0)
  33102   BNPYMNT ;; SETS UP BE NE PAYMENT  AT END OF  IMAGE FIL E
  33103   "RTN","CHM XF006",78, 0)
  33104    D:DSTFLG  BALCHK^CHM XLIMG(CHEI ,CHMFPDI,C HTOSJ,CHIM GK,CHIMGL, "OPT-NS")             ; SLA FINA L BALANCE  CHECK AGAI NST CLAIM  OHOIPD 
  33105   "RTN","CHM XF006",79, 0)
  33106    G:CHBNPD= "" END                                                                                                                   ; NO PATIE NT PAID AM T, NO INDE X CREATED
  33107   "RTN","CHM XF006",80, 0)
  33108    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"O PT-NS",CHI MGL),-1),C HIMGL=CHIM GL+1
  33109   "RTN","CHM XF006",81, 0)
  33110    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"OPT-N S",CHIMGL, 0)=CHSVCDT _"^"_CHPOS I_"^"_CHDF N_"^"_CHBF N_"^^"_CHB NPD
  33111   "RTN","CHM XF006",82, 0)
  33112    ;W !,"CHM F006:BNPYM NT: CHIMGL = ",CHIMGL ,"  CHMIMA GE= ",^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"OP T-NS",CHIM GL,0)
  33113   "RTN","CHM XF006",83, 0)
  33114    ; 
  33115   "RTN","CHM XF006",84, 0)
  33116   END S (CHT OB,CHCCRL) =""
  33117   "RTN","CHM XF006",85, 0)
  33118    ;I $D(^CH MXCLE(CHEI ,0)),($P(^ (0),"^",5) ="A")!($P( ^(0),"^",5 )="a") S C HTOB=$P(^( 0),"^",4)_ $P(^(0),"^ ",6)
  33119   "RTN","CHM XF006",86, 0)
  33120    I $D(^CHM XCLE(CHEI, 0)) S CHTO B=$P(^(0), "^",4)_$P( ^(0),"^",6 )  ; 11/27 /17 BMJ Us er Story C PE005-006  Changed th e line abo ve to this  line
  33121   "RTN","CHM XF006",87, 0)
  33122    I $D(^CHM XCLE(CHEI, 0)),$P(^(0 ),"^",2)'= "" S CHCCR L=$P(^(0), "^",2)
  33123   "RTN","CHM XF006",88, 0)
  33124    S $P(^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"VE N"),"^",7) =CHTOB,$P( ^("VEN")," ^",9)=2,$P (^("VEN"), "^",17)=CH CCRL
  33125   "RTN","CHM XF006",89, 0)
  33126    D:'$D(CHR DOIMG) BUF FND
  33127   "RTN","CHM XF006",90, 0)
  33128    K CHADM,C HDIS,CHBLD ,CHBNPD,CH EJJ,CHDX,C HPX,CHI,CH CCRL,CHTOB ,CHREV,CHP OS
  33129   "RTN","CHM XF006",91, 0)
  33130    K SKIPFLG ,CHSBTYP,C HFI,CHDTHL D,CHFREC1, CHSVCDT,CH PXCHRG,CHP MOD1,CHPMO D2
  33131   "RTN","CHM XF006",92, 0)
  33132    K CHPMOD, CHLINE,CHU NITS,CHIMG L,CHPOSI Q
  33133   "RTN","CHM XF006",93, 0)
  33134    ; 
  33135   "RTN","CHM XF006",94, 0)
  33136   BUFFND S ^ CHMIMAGE(C HMFPDI,"BU FF")=CHTPI D_"^"_CHMX I_"^"_CHAI _"^"_CHBI_ "^"_CHCI_" ^"_CHEI
  33137   "RTN","CHM XF006",95, 0)
  33138    Q
  33139   "RTN","CHM XF006",96, 0)
  33140    ; 
  33141   "RTN","CHM XF006",97, 0)
  33142   DXCNVRT K  SKIPFLG
  33143   "RTN","CHM XF006",98, 0)
  33144    I '$D(CHD X) S CHDX= "" Q
  33145   "RTN","CHM XF006",99, 0)
  33146    Q:CHDX=""
  33147   "RTN","CHM XF006",100 ,0)
  33148    I '$D(^CH MICDX("C", CHDX)) S C HDX="" Q
  33149   "RTN","CHM XF006",101 ,0)
  33150    S CHI=0,C HI=$O(^CHM ICDX("C",C HDX,0)) I  'CHI S CHD X="" Q
  33151   "RTN","CHM XF006",102 ,0)
  33152    S CHDX=CH I
  33153   "RTN","CHM XF006",103 ,0)
  33154    Q
  33155   "RTN","CHM XF006",104 ,0)
  33156    ; 
  33157   "RTN","CHM XF006",105 ,0)
  33158   RVCNVRT K  SKIPFLG S  CHI=""  ;A EB 4/3/200 8
  33159   "RTN","CHM XF006",106 ,0)
  33160    I '$D(CHR EV) S CHRE V="" Q
  33161   "RTN","CHM XF006",107 ,0)
  33162    Q:CHREV=" "
  33163   "RTN","CHM XF006",108 ,0)
  33164    I $L(CHRE V)=4 D  ;A EB 2/4/200 8 DEV00336 7
  33165   "RTN","CHM XF006",109 ,0)
  33166    .I '$D(^C HMXDIC(741 201.39,"B" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  33167   "RTN","CHM XF006",110 ,0)
  33168    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"B", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  33169   "RTN","CHM XF006",111 ,0)
  33170    .Q  ;AEB  2/4/2008 D EV003367
  33171   "RTN","CHM XF006",112 ,0)
  33172    I $L(CHRE V)=3 D  ;A EB 2/4/200 8 DEV00336 7
  33173   "RTN","CHM XF006",113 ,0)
  33174    .I '$D(^C HMXDIC(741 201.39,"H" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  33175   "RTN","CHM XF006",114 ,0)
  33176    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"H", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  33177   "RTN","CHM XF006",115 ,0)
  33178    .Q  ;AEB  2/4/2008 D EV003367
  33179   "RTN","CHM XF006",116 ,0)
  33180    I 'CHI S  CHREV="" Q   ;AEB 2/4 /2008 DEV0 03367
  33181   "RTN","CHM XF006",117 ,0)
  33182    S CHREV=C HI 
  33183   "RTN","CHM XF006",118 ,0)
  33184    Q ; 
  33185   "RTN","CHM XF006",119 ,0)
  33186   POSLU ;LOO KS UP PLAC E OF SERVI CE CODE IN  HAC POS F ILE AND AS SIGNS THE  INTERNAL N UMBER
  33187   "RTN","CHM XF006",120 ,0)
  33188    S CHPOSI= ""
  33189   "RTN","CHM XF006",121 ,0)
  33190   POSLU1 S C HPOSI=$S(( (CHPOS=9)! (CHPOS=41) !(CHPOS=42 )):10,CHPO S=24:50,(( CHPOS=3)!( CHPOS=11)! (CHPOS=53) !(CHPOS=72 )!(CHPOS=7 1)):3,CHPO S=81:12,(( CHPOS=61)! (CHPOS=1)! (CHPOS=21) !(CHPOS=51 )!(CHPOS=3 2)!(CHPOS= 56)!(CHPOS =55)!(CHPO S=8)!(CHPO S=31)):86, 1:"")
  33191   "RTN","CHM XF006",122 ,0)
  33192    Q:CHPOSI' =""
  33193   "RTN","CHM XF006",123 ,0)
  33194    S CHPOSI= $S(((CHPOS =2)!(CHPOS =22)!(CHPO S=25)!(CHP OS=5)!(CHP OS=23)!(CH POS=65)!(C HPOS=62)!( CHPOS=26)! (CHPOS=6)! (CHPOS=50) !(CHPOS=60 )):2,CHPOS =99:11,((C HPOS=4)!(C HPOS=12)!( CHPOS=33)! (CHPOS=34) !(CHPOS=54 )!(CHPOS=7 )!(CHPOS=3 5)):4,CHPO S=52:92,1: "")
  33195   "RTN","CHM XF006",124 ,0)
  33196    Q
  33197   "RTN","CHM XF006",125 ,0)
  33198    ; 
  33199   "RTN","CHM XF006",126 ,0)
  33200   GETDX ;;LO AD ALL DX  CODES, EXC EPT ADM DX , INTO CHD XARY
  33201   "RTN","CHM XF006",127 ,0)
  33202    S CHFI=0  K CHDXARY2
  33203   "RTN","CHM XF006",128 ,0)
  33204   GETDX1 S C HFI=$O(^CH MXCLF("B", CHEI,CHFI) ) Q:'CHFI
  33205   "RTN","CHM XF006",129 ,0)
  33206    G:'$D(^CH MXCLF(CHFI ,1)) GETDX 1 G:'$D(^C HMXCLF(CHF I,0)) GETD X1
  33207   "RTN","CHM XF006",130 ,0)
  33208    S CHFREC1 =^CHMXCLF( CHFI,1)
  33209   "RTN","CHM XF006",131 ,0)
  33210    S CHSVCDT =$$YR8FMYR ^CHTFLIB($ P(CHFREC1, "^",11))                           ; FIELD  11= SERVIC E FROM DAT E
  33211   "RTN","CHM XF006",132 ,0)
  33212    S:(CHSVCD T="")&(CHA DM'="") CH SVCDT=CHAD M
  33213   "RTN","CHM XF006",133 ,0)
  33214    S:CHSVCDT ="" CHSVCD T=3500101                                                                 ;  ****SET CH SVCDT="FUT URE" HERE  ALSO
  33215   "RTN","CHM XF006",134 ,0)
  33216    S:$P(CHFR EC1,"^",16 )'="" CHPO S=$P(CHFRE C1,"^",16)                         ; FIELD  16= PLACE  OF SERVICE
  33217   "RTN","CHM XF006",135 ,0)
  33218    D POSLU                                                                                                                   ; PLACE  OF SERVICE  LOOKUP
  33219   "RTN","CHM XF006",136 ,0)
  33220    S (CHDIAG 1,CHDIAG2, CHDIAG3,CH DIAG4)=""
  33221   "RTN","CHM XF006",137 ,0)
  33222    S CHDIAG1 =$P(CHFREC 1,"^",18), CHDIAG2=$P (CHFREC1," ^",19)         ; DIAG  CODE POIN TERS 1 AND  2
  33223   "RTN","CHM XF006",138 ,0)
  33224    S CHDIAG3 =$P(CHFREC 1,"^",20), CHDIAG4=$P (CHFREC1," ^",21)         ; DIAG  CODE POIN TERS 3 AND  4
  33225   "RTN","CHM XF006",139 ,0)
  33226    F XXX=1:1 :4 S CHDIA G="CHDIAG" _XXX D:@CH DIAG'=""
  33227   "RTN","CHM XF006",140 ,0)
  33228    .D:'$D(CH DXARY2(CHS VCDT,@CHDI AG))
  33229   "RTN","CHM XF006",141 ,0)
  33230    ..S CHDXA RY2(CHSVCD T,@CHDIAG) =""
  33231   "RTN","CHM XF006",142 ,0)
  33232    ..S CHDX= @CHDIAG D  DXCNVRT
  33233   "RTN","CHM XF006",143 ,0)
  33234    ..S CHIMG L=99999,CH IMGL=+$O(^ CHMIMAGE(C HMFPDI,1,C HTOSJ,2,1, "OPT-NS",C HIMGL),-1) ,CHIMGL=CH IMGL+1
  33235   "RTN","CHM XF006",144 ,0)
  33236    ..S ^CHMI MAGE(CHMFP DI,1,CHTOS J,2,1,"OPT -NS",CHIMG L,0)=CHSVC DT_"^"_CHP OSI_"^"_CH DFN_"^"_CH BFN_"^^^^^ ^"_CHDX
  33237   "RTN","CHM XF006",145 ,0)
  33238    ..;W !,"C HMXF006:GE TDX1: CHIM GL= ",CHIM GL," CHMIM AGE= ",^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"O PT-NS",CHI MGL,0)
  33239   "RTN","CHM XF006",146 ,0)
  33240    .Q
  33241   "RTN","CHM XF006",147 ,0)
  33242    G GETDX1
  33243   "RTN","CHM XF006",148 ,0)
  33244    ;*****CON SIDER CONV ERTING NEX T 6 LINES  INTO A BAC KLOAD OF D X CODES AT  CLM LEVEL
  33245   "RTN","CHM XF006",149 ,0)
  33246    ;S CHEJJ= 0
  33247   "RTN","CHM XF006",150 ,0)
  33248   GETDXL1 ;S  CHEJJ=$O( ^CHMXCLE(C HEI,40,CHE JJ)) Q:'CH EJJ
  33249   "RTN","CHM XF006",151 ,0)
  33250    ;G:'$D(^C HMXCLE(CHE I,40,CHEJJ ,0)) GETDX L1 S CHDX= ^CHMXCLE(C HEI,40,CHE JJ,0) G:CH DX="" GETD XL1
  33251   "RTN","CHM XF006",152 ,0)
  33252    ;D DXCNVR T G:$D(SKI PFLG) GETD XL1
  33253   "RTN","CHM XF006",153 ,0)
  33254    ;S CHDXAR Y(CHEJJ)=C HDX
  33255   "RTN","CHM XF006",154 ,0)
  33256    ;G GETDXL 1
  33257   "RTN","CHM XF006",155 ,0)
  33258    ; 
  33259   "RTN","CHM XF006",156 ,0)
  33260   MODSEL ;;M ODIFIER OR DER OF IMP ORTANCE:   80,81,82,A S,26,TC, T HEN FIRST  SUBMITTED
  33261   "RTN","CHM XF006",157 ,0)
  33262    I (CHPMOD 1=80)!(CHP MOD1=81)!( CHPMOD1=82 )!(CHPMOD1 ="AS") S C HPMOD=CHPM OD1 D MODC VRT Q
  33263   "RTN","CHM XF006",158 ,0)
  33264    I (CHPMOD 2=80)!(CHP MOD2=81)!( CHPMOD2=82 )!(CHPMOD2 ="AS") S C HPMOD=CHPM OD2 D MODC VRT Q
  33265   "RTN","CHM XF006",159 ,0)
  33266    I (CHPMOD 3=80)!(CHP MOD3=81)!( CHPMOD3=82 )!(CHPMOD3 ="AS") S C HPMOD=CHPM OD3 D MODC VRT Q
  33267   "RTN","CHM XF006",160 ,0)
  33268    I (CHPMOD 4=80)!(CHP MOD4=81)!( CHPMOD4=82 )!(CHPMOD4 ="AS") S C HPMOD=CHPM OD4 D MODC VRT Q
  33269   "RTN","CHM XF006",161 ,0)
  33270    I (CHPMOD 1=26)!(CHP MOD1="TC")  S CHPMOD= CHPMOD1 D  MODCVRT Q
  33271   "RTN","CHM XF006",162 ,0)
  33272    I (CHPMOD 2=26)!(CHP MOD2="TC")  S CHPMOD= CHPMOD2 D  MODCVRT Q
  33273   "RTN","CHM XF006",163 ,0)
  33274    I (CHPMOD 3=26)!(CHP MOD3="TC")  S CHPMOD= CHPMOD3 D  MODCVRT Q
  33275   "RTN","CHM XF006",164 ,0)
  33276    I (CHPMOD 4=26)!(CHP MOD4="TC")  S CHPMOD= CHPMOD4 D  MODCVRT Q
  33277   "RTN","CHM XF006",165 ,0)
  33278    I CHPMOD1 '="" S CHP MOD=CHPMOD 1 D MODCVR T Q
  33279   "RTN","CHM XF006",166 ,0)
  33280    I CHPMOD2 '="" S CHP MOD=CHPMOD 2 D MODCVR T Q
  33281   "RTN","CHM XF006",167 ,0)
  33282    I CHPMOD3 '="" S CHP MOD=CHPMOD 3 D MODCVR T Q
  33283   "RTN","CHM XF006",168 ,0)
  33284    I CHPMOD4 '="" S CHP MOD=CHPMOD 4 D MODCVR T Q
  33285   "RTN","CHM XF006",169 ,0)
  33286    E  S CHPM OD=""
  33287   "RTN","CHM XF006",170 ,0)
  33288    Q
  33289   "RTN","CHM XF006",171 ,0)
  33290    ; 
  33291   "RTN","CHM XF006",172 ,0)
  33292   MODCVRT Q: '$D(CHPMOD )  Q:CHPMO D=""
  33293   "RTN","CHM XF006",173 ,0)
  33294    S:$D(^CHM DIC(741002 .37,"B",CH PMOD)) CHP MOD=$O(^CH MDIC(74100 2.37,"B",C HPMOD,0))
  33295   "RTN","CHM XF006",174 ,0)
  33296    Q
  33297   "RTN","CHM XF006",175 ,0)
  33298   ANCALC ;CA LCULATE TH E NUMBER O F UNITS FR OM MINUTES +RVUs OR U NITS+RVUs  SUBMITTED
  33299   "RTN","CHM XF006",176 ,0)
  33300    Q:CHUNITS =""
  33301   "RTN","CHM XF006",177 ,0)
  33302    Q:CHUNITS =0
  33303   "RTN","CHM XF006",178 ,0)
  33304    Q:CHPX=""
  33305   "RTN","CHM XF006",179 ,0)
  33306    Q:'$D(CHP X)
  33307   "RTN","CHM XF006",180 ,0)
  33308    I $D(^CHM SERV(CHPX, 4)) D
  33309   "RTN","CHM XF006",181 ,0)
  33310    .S CHQLFY R=$P(CHFRE C1,"^",7)
  33311   "RTN","CHM XF006",182 ,0)
  33312    .Q:'$D(CH QLFYR)
  33313   "RTN","CHM XF006",183 ,0)
  33314    .Q:CHQLFY R=""
  33315   "RTN","CHM XF006",184 ,0)
  33316    .S CHCDEF D=9999999- CHSVCDT
  33317   "RTN","CHM XF006",185 ,0)
  33318    .S CHCDEF D=$O(^CHMS ERV(CHPX,4 ,"B",CHCDE FD),-1)
  33319   "RTN","CHM XF006",186 ,0)
  33320    .S CHCJPT R=0 S CHCJ PTR=$O(^CH MSERV(CHPX ,4,"B",CHC DEFD,CHCJP TR))
  33321   "RTN","CHM XF006",187 ,0)
  33322    .S BASU=$ P(^CHMSERV (CHPX,4,CH CJPTR,0)," ^",2)
  33323   "RTN","CHM XF006",188 ,0)
  33324    .I CHQLFY R="UN" D
  33325   "RTN","CHM XF006",189 ,0)
  33326    ..S CHUNI TS=CHUNITS +BASU
  33327   "RTN","CHM XF006",190 ,0)
  33328    .I CHQLFY R="MJ" D
  33329   "RTN","CHM XF006",191 ,0)
  33330    ..S TIMU= 0
  33331   "RTN","CHM XF006",192 ,0)
  33332    ..S UNIT= CHUNITS#15
  33333   "RTN","CHM XF006",193 ,0)
  33334    ..S TIMU= (CHUNITS-U NIT)/15 
  33335   "RTN","CHM XF006",194 ,0)
  33336    ..S:UNIT' =0 TIMU=TI MU+1
  33337   "RTN","CHM XF006",195 ,0)
  33338    ..S CHUNI TS=TIMU+BA SU
  33339   "RTN","CHM XF006",196 ,0)
  33340    K CHQLFYR ,BASU,TIMU ,CHCDEFD,C HCJPTR,UNI T
  33341   "RTN","CHM XF006",197 ,0)
  33342    Q
  33343   "RTN","CHM XF006",198 ,0)
  33344    ;
  33345   "RTN","CHM XF006",199 ,0)
  33346   GTLX(CHFI)                                                                                      ;  DLB 1/9/20 13 POPULAT E THE ^CHM IMAGE EDI  LINE IDENT IFIER FIEL D
  33347   "RTN","CHM XF006",200 ,0)
  33348    N LICTRL
  33349   "RTN","CHM XF006",201 ,0)
  33350    S LICTRL= $P(^CHMXCL F(CHFI,1), "^",23)                              ; VEND OR PROVIDE D LINE ITE M CONTROL  NUMBER
  33351   "RTN","CHM XF006",202 ,0)
  33352    I LICTRL= "" D
  33353   "RTN","CHM XF006",203 ,0)
  33354    . S LICTR L=$P(^CHMX CLF(CHFI,0 ),"^",2)                             ; HAC  ASSIGNED S ERVICE LIN E NUMBER
  33355   "RTN","CHM XF006",204 ,0)
  33356    . S $P(^C HMXCLF(CHF I,1),"^",2 3)="HAC"_L ICTRL
  33357   "RTN","CHM XF006",205 ,0)
  33358    ;W !,"CHM XF006:GTLX (",CHFI,") : RETRIEVE D: ",LICTR L
  33359   "RTN","CHM XF006",206 ,0)
  33360    Q LICTRL
  33361   "RTN","CHM XF008")
  33362   0^19^B6731 2527
  33363   "RTN","CHM XF008",1,0 )
  33364   CHMXF008 ; CVA/DTP;X1 2 837 CLM  CREATE SET  OPT CLM D ATA TO IMA GE FILE (P ROFESSIONA L/HCFA);08 /22/02  3: 16 PM
  33365   "RTN","CHM XF008",2,0 )
  33366    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  33367   "RTN","CHM XF008",3,0 )
  33368    ;;
  33369   "RTN","CHM XF008",4,0 )
  33370    ;;JEH 01/ 21/07 - MO DIFIED FOR  ANESHESIA  CODE RATE S
  33371   "RTN","CHM XF008",5,0 )
  33372    ;;ajm 03- 05-07 - mo dified pla ce of serv ice lookup  (DEV00140 0-01)
  33373   "RTN","CHM XF008",6,0 )
  33374    ;;JEH 11/ 15/10 TT E NC003698 -  ADDED AMB ULANCE ZIP  CODE
  33375   "RTN","CHM XF008",7,0 )
  33376    ;;DLB 8/1 7/2010 DEV 7820 SLA ^ CHMIMAGE L OAD
  33377   "RTN","CHM XF008",8,0 )
  33378    ;;DLB 1/8 /2013 DEV7 820 SLA BA LANCE CHEC K MOVED IN TO CHMXLIM G.INT
  33379   "RTN","CHM XF008",9,0 )
  33380    ;;DLB 1/9 /2013 DEV7 820 ADDED  GTLX(CHFI)  FUNCTION  TO RETRIEV E THE LINE  ITEM CTRL  # OR SERV ICE LINE #
  33381   "RTN","CHM XF008",10, 0)
  33382    ;;                                AND POPU LATE THE ^ CHMIMAGE E DI LINE ID ENTIFIER F IELD
  33383   "RTN","CHM XF008",11, 0)
  33384    ;; DLB 2/ 5/2013         DEV782 0  ADDED C ALL TO BAL CHK IN CHM XLIMG.INT  FOR SLA LO AD TO ^CHM IMAGE
  33385   "RTN","CHM XF008",12, 0)
  33386    ;; DLB 2/ 11/2013        DEV782 0  ADDED T HE MOVE FO R PROCEDUR E MODIFIER S 2,3,4 IN TO ^CHMIMA GE
  33387   "RTN","CHM XF008",13, 0)
  33388    ;; DLB 2/ 13/13          CHANGE D "MODIFIE R" VALUES  TO DICTION ARY VALUES
  33389   "RTN","CHM XF008",14, 0)
  33390    ;; YG  4/ 4/2014         Making  DME load  from OPT o ne
  33391   "RTN","CHM XF008",15, 0)
  33392    ;; BMJ 11 /27/17 Use r Story CP E005-006 M odify Docu ment Ident ification  Screen - T ype of Bil l
  33393   "RTN","CHM XF008",16, 0)
  33394    ;;
  33395   "RTN","CHM XF008",17, 0)
  33396   A S (CHADM ,CHDIS,CHS TS,CHADMDX ,CHBLD,CHD CFAC,CHBNP D,CHTOB,CH CCRL)=""
  33397   "RTN","CHM XF008",18, 0)
  33398    G:'$D(^CH MXCLE(CHEI ,1)) C
  33399   "RTN","CHM XF008",19, 0)
  33400    ;Y2K - as sumes cent ury 2 - Fi xed by the  following  two lines
  33401   "RTN","CHM XF008",20, 0)
  33402    ;Y2K S CH ADM=2_$E($ P(^CHMXCLE (CHEI,1)," ^"),3,8)
  33403   "RTN","CHM XF008",21, 0)
  33404    ;Y2K S CH DIS=2_$E($ P(^CHMXCLE (CHEI,1)," ^",2),3,8)
  33405   "RTN","CHM XF008",22, 0)
  33406   B S CHADM= $$YR8FMYR^ CHTFLIB($P (^CHMXCLE( CHEI,1),"^ ",1))          ; STAT EMENT FROM  DATE
  33407   "RTN","CHM XF008",23, 0)
  33408    S CHDIS=$ $YR8FMYR^C HTFLIB($P( ^CHMXCLE(C HEI,1),"^" ,2))           ; STAT EMENT TO D ATE
  33409   "RTN","CHM XF008",24, 0)
  33410   C S CHXSTY P=$P(^CHMX CLA(CHAI,8 0),"^",7)                                             
  33411   "RTN","CHM XF008",25, 0)
  33412    G:'$D(^CH MXCLE(CHEI ,2)) D
  33413   "RTN","CHM XF008",26, 0)
  33414    S CHBLD=$ P(^CHMXCLE (CHEI,2)," ^",1)                                                          ;  TOTAL CHAR GES BILLED
  33415   "RTN","CHM XF008",27, 0)
  33416    S CHBNPD= $P(^CHMXCL E(CHEI,2), "^",2)                                                 ; PATIENT  AMOUNT PAI D
  33417   "RTN","CHM XF008",28, 0)
  33418   D S CHPOS= $P(^CHMXCL E(CHEI,0), "^",4)                                                 ; PLACE OF  SERVICE/T OB
  33419   "RTN","CHM XF008",29, 0)
  33420    ;S:(CHSBT YP=2)&(CHP OS="") CHP OS=11                                                          ;  DEFAULT FO R PROF = D OCTOR'S OF FICE 
  33421   "RTN","CHM XF008",30, 0)
  33422    ;D POSLU  ; CHECK IF  CHPOS->CH POSI trans lation mak es sense f or DME
  33423   "RTN","CHM XF008",31, 0)
  33424    ;GETDX LO OPS THROUG H LINE LEV EL, FOR EA CH SERVICE  LINE GET  ALL DX COD ES, IF NO  DATA IN CH DXARY2(DT, DXCD) SET  IN CHDXARY 2 BY DATE  AND SET UP  IN IMAGE  FILE
  33425   "RTN","CHM XF008",32, 0)
  33426    ;KKAIEL
  33427   "RTN","CHM XF008",33, 0)
  33428    D GETDX
  33429   "RTN","CHM XF008",34, 0)
  33430    S CHFI=0, CHDTHLD="" ,DSTFLG=0                                                                 ;  DISTRIBUTI ON FLAG FO R ^CHMIMAG E LOAD
  33431   "RTN","CHM XF008",35, 0)
  33432   D1 S CHFI= $O(^CHMXCL F("B",CHEI ,CHFI)) G: 'CHFI BNPY MNT
  33433   "RTN","CHM XF008",36, 0)
  33434    G:'$D(^CH MXCLF(CHFI ,0)) D1 G: '$D(^CHMXC LF(CHFI,1) ) D1
  33435   "RTN","CHM XF008",37, 0)
  33436    S CHFREC1 =^CHMXCLF( CHFI,1)                                                                            ; RE VENUE CODE  NODE
  33437   "RTN","CHM XF008",38, 0)
  33438    ;S CHREV= $P(CHFREC1 ,"^") G:CH REV="001"  D1 D RVCNV RT             ; SKD  8-28-07 DE V003081-02
  33439   "RTN","CHM XF008",39, 0)
  33440    S CHREV=$ P(CHFREC1, "^") G:+CH REV'>1 D1  D RVCNVRT                          ; SKD 8- 28-07 DEV0 03081-02
  33441   "RTN","CHM XF008",40, 0)
  33442    S CHSVCDT =$$YR8FMYR ^CHTFLIB($ P(CHFREC1, "^",11))                           ; SERVIC E FROM DAT E
  33443   "RTN","CHM XF008",41, 0)
  33444    S:(CHSVCD T="")&(CHA DM'="") CH SVCDT=CHAD M
  33445   "RTN","CHM XF008",42, 0)
  33446    ;D FUTDOS ^CHMXF009  ****INSERT  FUTURE DA TE OF SERV ICE CHECK  HERE
  33447   "RTN","CHM XF008",43, 0)
  33448    ;;NEXT NE STED DO IS  CHECK FOR  MULTIPLE  DOS WITH B ENE PAYMEN T
  33449   "RTN","CHM XF008",44, 0)
  33450    ;; Does t his makes  sense for  DME
  33451   "RTN","CHM XF008",45, 0)
  33452   D2 G:CHDTH LD="" D3
  33453   "RTN","CHM XF008",46, 0)
  33454    I (CHDTHL D'=CHSVCDT )&(+CHBNPD >0) D
  33455   "RTN","CHM XF008",47, 0)
  33456    .S ZZ=999 99,ZZ=$O(^ CHMXCLE(CH EI,101,ZZ) ,-1) S:'ZZ  ZZ=0
  33457   "RTN","CHM XF008",48, 0)
  33458    .S CHRJRS N="",CHIL= "CHEI",CHG LBL="^CHMX CLE(",CHFN =741210.12 101
  33459   "RTN","CHM XF008",49, 0)
  33460    .S CHXREC ="E005",CH RCERR(CHXR EC,"E11x") =""
  33461   "RTN","CHM XF008",50, 0)
  33462    .D C^CHMX P003 K CHR CERR
  33463   "RTN","CHM XF008",51, 0)
  33464    .Q
  33465   "RTN","CHM XF008",52, 0)
  33466   D3 ;
  33467   "RTN","CHM XF008",53, 0)
  33468    I $G(CHJR XCOD(CHFI) )'="" S CH PX=$$PXCNV RT^CHEDILI B(CHJRXCOD (CHFI),"B" ),CHPXO=$$ PXCNVRT^CH EDILIB($P( CHFREC1,"^ ",3),"B")
  33469   "RTN","CHM XF008",54, 0)
  33470    I $G(CHJR XCOD(CHFI) )="" S CHP X=$$PXCNVR T^CHEDILIB ($P(CHFREC 1,"^",3)," B"),CHPXO= ""
  33471   "RTN","CHM XF008",55, 0)
  33472    ;;S CHPX= $$PXCNVRT^ CHEDILIB(C HPX,"B") ; convert th e proc cod e to ^CHMS ERV I val 
  33473   "RTN","CHM XF008",56, 0)
  33474    ;;G:$G(CH PX)="" D1   ;SKD 7-11 -07 DEV002 710-01
  33475   "RTN","CHM XF008",57, 0)
  33476    S CHREV=$ P(CHFREC1, "^") G:+CH REV'>1 D1  D RVCNVRT                          ;SKD 8-2 8-07 DEV00 3081-02  ; AEB 2/4/20 08 DEV0033 67
  33477   "RTN","CHM XF008",58, 0)
  33478    S CHPXCHR G=$P(CHFRE C1,"^",6)                                                                 ;  SVC LINE B ILLED CHAR GE
  33479   "RTN","CHM XF008",59, 0)
  33480    S CHPMOD1 =$P(CHFREC 1,"^",4) S :CHPMOD1'= "" CHPMOD1 =$O(^CHMDI C(741002.3 7,"B",CHPM OD1,0))          ; DL B 2/11/13  PROCEDURE  MODIFIERS
  33481   "RTN","CHM XF008",60, 0)
  33482    S CHPMOD2 =$P(CHFREC 1,"^",5) S :CHPMOD2'= "" CHPMOD2 =$O(^CHMDI C(741002.3 7,"B",CHPM OD2,0))          ; DL B 2/13/13  SET MOD VA LUES TO DI CTIONARY V ALUES
  33483   "RTN","CHM XF008",61, 0)
  33484    S CHPMOD3 =$P(CHFREC 1,"^",14)  S:CHPMOD3' ="" CHPMOD 3=$O(^CHMD IC(741002. 37,"B",CHP MOD3,0))
  33485   "RTN","CHM XF008",62, 0)
  33486    S CHPMOD4 =$P(CHFREC 1,"^",15)  S:CHPMOD4' ="" CHPMOD 4=$O(^CHMD IC(741002. 37,"B",CHP MOD4,0))    
  33487   "RTN","CHM XF008",63, 0)
  33488    D MODSEL
  33489   "RTN","CHM XF008",64, 0)
  33490    S CHLINE= $$GTLX(CHF I)                                                                                 ; DL B 1/9/2013  RETRIEVE  LICTRL # O R SVC LINE  #
  33491   "RTN","CHM XF008",65, 0)
  33492    S CHUNITS =$P(CHFREC 1,"^",8)                                                                  ;  HC CODE UN ITS
  33493   "RTN","CHM XF008",66, 0)
  33494    D ANCALC    ;CALCULA TE THE NUM BER OF UNI TS PER COD E TO INCLU DE RVU'S A ND CONVERT S MINUTES  TO UNITS
  33495   "RTN","CHM XF008",67, 0)
  33496    S:CHUNITS ="" CHUNIT S=1 S:CHUN ITS=0 CHUN ITS=1
  33497   "RTN","CHM XF008",68, 0)
  33498    ;S:$P(CHF REC1,"^",1 6)'="" CHP OS=$P(CHFR EC1,"^",16 )                       ; PLACE  OF SERVICE
  33499   "RTN","CHM XF008",69, 0)
  33500    ;D POSLU
  33501   "RTN","CHM XF008",70, 0)
  33502    ;I CHPOSI =10 D SETA MBZP^CHEDI LIB(CHFREC 1,10,CHTOS ,CHMFPDI,C HTOSJ,CHEI )    ;JEH  11/15/10 T T ENC00369 8 - ADD SU B-RTN CALL
  33503   "RTN","CHM XF008",71, 0)
  33504    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"D ME-NS",CHI MGL),-1),C HIMGL=CHIM GL+1
  33505   "RTN","CHM XF008",72, 0)
  33506   E ;S ^CHMI MAGE(CHMFP DI,1,CHTOS J,2,1,"OPT -NS",CHIMG L,0)=CHSVC DT_"^"_CHP OSI_"^"_CH DFN_"^"_CH BFN_"^^^"_ CHPX_"^"_C HPXCHRG_"^ "_CHPMOD1_ "^^^^^"_CH REV_"^"_CH PXCHRG_"^" _CHLINE_"^ "_CHUNITS_ "^^"_CHPXO _"^"_CHPMO D2_"^"_CHP MOD3_"^"_C HPMOD4
  33507   "RTN","CHM XF008",73, 0)
  33508    ;W !,"CHM XF006:E:PR OF ""OPT-N S"" = ",^C HMIMAGE(CH MFPDI,1,CH TOSJ,2,1," OPT-NS",CH IMGL,0),"   CHIMGL= " ,CHIMGL
  33509   "RTN","CHM XF008",74, 0)
  33510    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"DME-N S",CHIMGL, 0)=CHSVCDT _"^"_CHDFN _"^"_CHBFN _"^^^^"_CH PX_"^"_CHP XCHRG_"^^^ ^"_CHUNITS _"^"_CHPXC HRG_"^"_CH LINE_"^"_C HREV_"^"_C HPXO_"^"_C HPMOD1_"^" _CHPMOD2_" ^"_CHPMOD3 _"^"_CHPMO D4
  33511   "RTN","CHM XF008",75, 0)
  33512    S CHDTHLD =CHSVCDT,C HIMGK=1
  33513   "RTN","CHM XF008",76, 0)
  33514    ;W !,"CHM XF006:  PR OFESSIONAL /HCFA CLAI M: ",CHMFP DI
  33515   "RTN","CHM XF008",77, 0)
  33516    S DSTFLG= DSTFLG+$$L DCHMIMG^CH MXLIMG(CHE I,CHFI,CHM FPDI,CHTOS J,CHIMGK,C HIMGL,"DME -NS")
  33517   "RTN","CHM XF008",78, 0)
  33518    G D1
  33519   "RTN","CHM XF008",79, 0)
  33520    ; 
  33521   "RTN","CHM XF008",80, 0)
  33522   BNPYMNT ;; SETS UP BE NE PAYMENT  AT END OF  IMAGE FIL E
  33523   "RTN","CHM XF008",81, 0)
  33524    D:DSTFLG  BALCHK^CHM XLIMG(CHEI ,CHMFPDI,C HTOSJ,CHIM GK,CHIMGL, "DME-NS")             ; SLA FINA L BALANCE  CHECK AGAI NST CLAIM  OHOIPD 
  33525   "RTN","CHM XF008",82, 0)
  33526    G:CHBNPD= "" END                                                                                                                   ; NO PATIE NT PAID AM T, NO INDE X CREATED
  33527   "RTN","CHM XF008",83, 0)
  33528    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"D ME-NS",CHI MGL),-1),C HIMGL=CHIM GL+1
  33529   "RTN","CHM XF008",84, 0)
  33530    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"DME-N S",CHIMGL, 0)=CHSVCDT _"^"_CHDFN _"^"_CHBFN _"^^"_CHBN PD
  33531   "RTN","CHM XF008",85, 0)
  33532    ;W !,"CHM F006:BNPYM NT: CHIMGL = ",CHIMGL ,"  CHMIMA GE= ",^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"OP T-NS",CHIM GL,0)
  33533   "RTN","CHM XF008",86, 0)
  33534    ; 
  33535   "RTN","CHM XF008",87, 0)
  33536   END S (CHT OB,CHCCRL) =""
  33537   "RTN","CHM XF008",88, 0)
  33538    ;I $D(^CH MXCLE(CHEI ,0)),($P(^ (0),"^",5) ="A")!($P( ^(0),"^",5 )="a") S C HTOB=$P(^( 0),"^",4)_ $P(^(0),"^ ",6)
  33539   "RTN","CHM XF008",89, 0)
  33540    I $D(^CHM XCLE(CHEI, 0)) S CHTO B=$P(^(0), "^",4)_$P( ^(0),"^",6 )  ; 11/27 /17 BMJ Us er Story C PE005-006  Changed th e line abo ve to this  line
  33541   "RTN","CHM XF008",90, 0)
  33542    I $D(^CHM XCLE(CHEI, 0)),$P(^(0 ),"^",2)'= "" S CHCCR L=$P(^(0), "^",2)
  33543   "RTN","CHM XF008",91, 0)
  33544    S $P(^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"VE N"),"^",7) =CHTOB,$P( ^("VEN")," ^",9)=2,$P (^("VEN"), "^",17)=CH CCRL
  33545   "RTN","CHM XF008",92, 0)
  33546    D:'$D(CHR DOIMG) BUF FND
  33547   "RTN","CHM XF008",93, 0)
  33548    K CHADM,C HDIS,CHBLD ,CHBNPD,CH EJJ,CHDX,C HPX,CHI,CH CCRL,CHTOB ,CHREV,CHP OS
  33549   "RTN","CHM XF008",94, 0)
  33550    K SKIPFLG ,CHSBTYP,C HFI,CHDTHL D,CHFREC1, CHSVCDT,CH PXCHRG,CHP MOD1,CHPMO D2
  33551   "RTN","CHM XF008",95, 0)
  33552    K CHPMOD, CHLINE,CHU NITS,CHIMG L,CHPOSI 
  33553   "RTN","CHM XF008",96, 0)
  33554    Q
  33555   "RTN","CHM XF008",97, 0)
  33556    ; 
  33557   "RTN","CHM XF008",98, 0)
  33558   BUFFND S ^ CHMIMAGE(C HMFPDI,"BU FF")=CHTPI D_"^"_CHMX I_"^"_CHAI _"^"_CHBI_ "^"_CHCI_" ^"_CHEI
  33559   "RTN","CHM XF008",99, 0)
  33560    Q
  33561   "RTN","CHM XF008",100 ,0)
  33562    ; 
  33563   "RTN","CHM XF008",101 ,0)
  33564   DXCNVRT K  SKIPFLG
  33565   "RTN","CHM XF008",102 ,0)
  33566    I '$D(CHD X) S CHDX= "" Q
  33567   "RTN","CHM XF008",103 ,0)
  33568    Q:CHDX=""
  33569   "RTN","CHM XF008",104 ,0)
  33570    I '$D(^CH MICDX("C", CHDX)) S C HDX="" Q
  33571   "RTN","CHM XF008",105 ,0)
  33572    S CHI=0,C HI=$O(^CHM ICDX("C",C HDX,0)) I  'CHI S CHD X="" Q
  33573   "RTN","CHM XF008",106 ,0)
  33574    S CHDX=CH I
  33575   "RTN","CHM XF008",107 ,0)
  33576    Q
  33577   "RTN","CHM XF008",108 ,0)
  33578    ; 
  33579   "RTN","CHM XF008",109 ,0)
  33580   RVCNVRT K  SKIPFLG S  CHI=""  ;A EB 4/3/200 8
  33581   "RTN","CHM XF008",110 ,0)
  33582    I '$D(CHR EV) S CHRE V="" Q
  33583   "RTN","CHM XF008",111 ,0)
  33584    Q:CHREV=" "
  33585   "RTN","CHM XF008",112 ,0)
  33586    I $L(CHRE V)=4 D  ;A EB 2/4/200 8 DEV00336 7
  33587   "RTN","CHM XF008",113 ,0)
  33588    .I '$D(^C HMXDIC(741 201.39,"B" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  33589   "RTN","CHM XF008",114 ,0)
  33590    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"B", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  33591   "RTN","CHM XF008",115 ,0)
  33592    .Q  ;AEB  2/4/2008 D EV003367
  33593   "RTN","CHM XF008",116 ,0)
  33594    I $L(CHRE V)=3 D  ;A EB 2/4/200 8 DEV00336 7
  33595   "RTN","CHM XF008",117 ,0)
  33596    .I '$D(^C HMXDIC(741 201.39,"H" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  33597   "RTN","CHM XF008",118 ,0)
  33598    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"H", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  33599   "RTN","CHM XF008",119 ,0)
  33600    .Q  ;AEB  2/4/2008 D EV003367
  33601   "RTN","CHM XF008",120 ,0)
  33602    I 'CHI S  CHREV="" Q   ;AEB 2/4 /2008 DEV0 03367
  33603   "RTN","CHM XF008",121 ,0)
  33604    S CHREV=C HI 
  33605   "RTN","CHM XF008",122 ,0)
  33606    Q ; 
  33607   "RTN","CHM XF008",123 ,0)
  33608    ; 
  33609   "RTN","CHM XF008",124 ,0)
  33610   GETDX ;;LO AD ALL DX  CODES, EXC EPT ADM DX , INTO CHD XARY
  33611   "RTN","CHM XF008",125 ,0)
  33612    S CHFI=0  K CHDXARY2
  33613   "RTN","CHM XF008",126 ,0)
  33614   GETDX1 S C HFI=$O(^CH MXCLF("B", CHEI,CHFI) ) Q:'CHFI
  33615   "RTN","CHM XF008",127 ,0)
  33616    G:'$D(^CH MXCLF(CHFI ,1)) GETDX 1 G:'$D(^C HMXCLF(CHF I,0)) GETD X1
  33617   "RTN","CHM XF008",128 ,0)
  33618    S CHFREC1 =^CHMXCLF( CHFI,1)
  33619   "RTN","CHM XF008",129 ,0)
  33620    S CHSVCDT =$$YR8FMYR ^CHTFLIB($ P(CHFREC1, "^",11))                           ; FIELD  11= SERVIC E FROM DAT E
  33621   "RTN","CHM XF008",130 ,0)
  33622    S:(CHSVCD T="")&(CHA DM'="") CH SVCDT=CHAD M
  33623   "RTN","CHM XF008",131 ,0)
  33624    S:CHSVCDT ="" CHSVCD T=3500101                                                                 ;  ****SET CH SVCDT="FUT URE" HERE  ALSO
  33625   "RTN","CHM XF008",132 ,0)
  33626    ;S:$P(CHF REC1,"^",1 6)'="" CHP OS=$P(CHFR EC1,"^",16 )                       ; FIELD  16= PLACE  OF SERVICE
  33627   "RTN","CHM XF008",133 ,0)
  33628    ;D POSLU                                                                                                                  ; PLACE  OF SERVICE  LOOKUP
  33629   "RTN","CHM XF008",134 ,0)
  33630    S (CHDIAG 1,CHDIAG2, CHDIAG3,CH DIAG4)=""
  33631   "RTN","CHM XF008",135 ,0)
  33632    S CHDIAG1 =$P(CHFREC 1,"^",18), CHDIAG2=$P (CHFREC1," ^",19)         ; DIAG  CODE POIN TERS 1 AND  2
  33633   "RTN","CHM XF008",136 ,0)
  33634    S CHDIAG3 =$P(CHFREC 1,"^",20), CHDIAG4=$P (CHFREC1," ^",21)         ; DIAG  CODE POIN TERS 3 AND  4
  33635   "RTN","CHM XF008",137 ,0)
  33636    F XXX=1:1 :4 S CHDIA G="CHDIAG" _XXX D:@CH DIAG'=""
  33637   "RTN","CHM XF008",138 ,0)
  33638    .D:'$D(CH DXARY2(CHS VCDT,@CHDI AG))
  33639   "RTN","CHM XF008",139 ,0)
  33640    ..S CHDXA RY2(CHSVCD T,@CHDIAG) =""
  33641   "RTN","CHM XF008",140 ,0)
  33642    ..S CHDX= @CHDIAG D  DXCNVRT
  33643   "RTN","CHM XF008",141 ,0)
  33644    ..S CHIMG L=$O(^CHMI MAGE(CHMFP DI,1,CHTOS J,2,1,"DME -NS","A"), -1)+1
  33645   "RTN","CHM XF008",142 ,0)
  33646    ..S ^CHMI MAGE(CHMFP DI,1,CHTOS J,2,1,"DME -NS",CHIMG L,0)=CHSVC DT_"^"_CHD FN_"^"_CHB FN_"^^^^^^ ^"_CHDX
  33647   "RTN","CHM XF008",143 ,0)
  33648    .Q
  33649   "RTN","CHM XF008",144 ,0)
  33650    G GETDX1
  33651   "RTN","CHM XF008",145 ,0)
  33652    ;*****CON SIDER CONV ERTING NEX T 6 LINES  INTO A BAC KLOAD OF D X CODES AT  CLM LEVEL
  33653   "RTN","CHM XF008",146 ,0)
  33654    ;S CHEJJ= 0
  33655   "RTN","CHM XF008",147 ,0)
  33656   GETDXL1 ;S  CHEJJ=$O( ^CHMXCLE(C HEI,40,CHE JJ)) Q:'CH EJJ
  33657   "RTN","CHM XF008",148 ,0)
  33658    ;G:'$D(^C HMXCLE(CHE I,40,CHEJJ ,0)) GETDX L1 S CHDX= ^CHMXCLE(C HEI,40,CHE JJ,0) G:CH DX="" GETD XL1
  33659   "RTN","CHM XF008",149 ,0)
  33660    ;D DXCNVR T G:$D(SKI PFLG) GETD XL1
  33661   "RTN","CHM XF008",150 ,0)
  33662    ;S CHDXAR Y(CHEJJ)=C HDX
  33663   "RTN","CHM XF008",151 ,0)
  33664    ;G GETDXL 1
  33665   "RTN","CHM XF008",152 ,0)
  33666    ; 
  33667   "RTN","CHM XF008",153 ,0)
  33668   MODSEL ;;M ODIFIER OR DER OF IMP ORTANCE:   80,81,82,A S,26,TC, T HEN FIRST  SUBMITTED
  33669   "RTN","CHM XF008",154 ,0)
  33670    I (CHPMOD 1=80)!(CHP MOD1=81)!( CHPMOD1=82 )!(CHPMOD1 ="AS") S C HPMOD=CHPM OD1 D MODC VRT Q
  33671   "RTN","CHM XF008",155 ,0)
  33672    I (CHPMOD 2=80)!(CHP MOD2=81)!( CHPMOD2=82 )!(CHPMOD2 ="AS") S C HPMOD=CHPM OD2 D MODC VRT Q
  33673   "RTN","CHM XF008",156 ,0)
  33674    I (CHPMOD 3=80)!(CHP MOD3=81)!( CHPMOD3=82 )!(CHPMOD3 ="AS") S C HPMOD=CHPM OD3 D MODC VRT Q
  33675   "RTN","CHM XF008",157 ,0)
  33676    I (CHPMOD 4=80)!(CHP MOD4=81)!( CHPMOD4=82 )!(CHPMOD4 ="AS") S C HPMOD=CHPM OD4 D MODC VRT Q
  33677   "RTN","CHM XF008",158 ,0)
  33678    I (CHPMOD 1=26)!(CHP MOD1="TC")  S CHPMOD= CHPMOD1 D  MODCVRT Q
  33679   "RTN","CHM XF008",159 ,0)
  33680    I (CHPMOD 2=26)!(CHP MOD2="TC")  S CHPMOD= CHPMOD2 D  MODCVRT Q
  33681   "RTN","CHM XF008",160 ,0)
  33682    I (CHPMOD 3=26)!(CHP MOD3="TC")  S CHPMOD= CHPMOD3 D  MODCVRT Q
  33683   "RTN","CHM XF008",161 ,0)
  33684    I (CHPMOD 4=26)!(CHP MOD4="TC")  S CHPMOD= CHPMOD4 D  MODCVRT Q
  33685   "RTN","CHM XF008",162 ,0)
  33686    I CHPMOD1 '="" S CHP MOD=CHPMOD 1 D MODCVR T Q
  33687   "RTN","CHM XF008",163 ,0)
  33688    I CHPMOD2 '="" S CHP MOD=CHPMOD 2 D MODCVR T Q
  33689   "RTN","CHM XF008",164 ,0)
  33690    I CHPMOD3 '="" S CHP MOD=CHPMOD 3 D MODCVR T Q
  33691   "RTN","CHM XF008",165 ,0)
  33692    I CHPMOD4 '="" S CHP MOD=CHPMOD 4 D MODCVR T Q
  33693   "RTN","CHM XF008",166 ,0)
  33694    E  S CHPM OD=""
  33695   "RTN","CHM XF008",167 ,0)
  33696    Q
  33697   "RTN","CHM XF008",168 ,0)
  33698    ; 
  33699   "RTN","CHM XF008",169 ,0)
  33700   MODCVRT Q: '$D(CHPMOD )  Q:CHPMO D=""
  33701   "RTN","CHM XF008",170 ,0)
  33702    S:$D(^CHM DIC(741002 .37,"B",CH PMOD)) CHP MOD=$O(^CH MDIC(74100 2.37,"B",C HPMOD,0))
  33703   "RTN","CHM XF008",171 ,0)
  33704    Q
  33705   "RTN","CHM XF008",172 ,0)
  33706   ANCALC ;CA LCULATE TH E NUMBER O F UNITS FR OM MINUTES +RVUs OR U NITS+RVUs  SUBMITTED
  33707   "RTN","CHM XF008",173 ,0)
  33708    Q:CHUNITS =""
  33709   "RTN","CHM XF008",174 ,0)
  33710    Q:CHUNITS =0
  33711   "RTN","CHM XF008",175 ,0)
  33712    Q:CHPX=""
  33713   "RTN","CHM XF008",176 ,0)
  33714    Q:'$D(CHP X)
  33715   "RTN","CHM XF008",177 ,0)
  33716    I $D(^CHM SERV(CHPX, 4)) D
  33717   "RTN","CHM XF008",178 ,0)
  33718    .S CHQLFY R=$P(CHFRE C1,"^",7)
  33719   "RTN","CHM XF008",179 ,0)
  33720    .Q:'$D(CH QLFYR)
  33721   "RTN","CHM XF008",180 ,0)
  33722    .Q:CHQLFY R=""
  33723   "RTN","CHM XF008",181 ,0)
  33724    .S CHCDEF D=9999999- CHSVCDT
  33725   "RTN","CHM XF008",182 ,0)
  33726    .S CHCDEF D=$O(^CHMS ERV(CHPX,4 ,"B",CHCDE FD),-1)
  33727   "RTN","CHM XF008",183 ,0)
  33728    .S CHCJPT R=0 S CHCJ PTR=$O(^CH MSERV(CHPX ,4,"B",CHC DEFD,CHCJP TR))
  33729   "RTN","CHM XF008",184 ,0)
  33730    .S BASU=$ P(^CHMSERV (CHPX,4,CH CJPTR,0)," ^",2)
  33731   "RTN","CHM XF008",185 ,0)
  33732    .I CHQLFY R="UN" D
  33733   "RTN","CHM XF008",186 ,0)
  33734    ..S CHUNI TS=CHUNITS +BASU
  33735   "RTN","CHM XF008",187 ,0)
  33736    .I CHQLFY R="MJ" D
  33737   "RTN","CHM XF008",188 ,0)
  33738    ..S TIMU= 0
  33739   "RTN","CHM XF008",189 ,0)
  33740    ..S UNIT= CHUNITS#15
  33741   "RTN","CHM XF008",190 ,0)
  33742    ..S TIMU= (CHUNITS-U NIT)/15 
  33743   "RTN","CHM XF008",191 ,0)
  33744    ..S:UNIT' =0 TIMU=TI MU+1
  33745   "RTN","CHM XF008",192 ,0)
  33746    ..S CHUNI TS=TIMU+BA SU
  33747   "RTN","CHM XF008",193 ,0)
  33748    K CHQLFYR ,BASU,TIMU ,CHCDEFD,C HCJPTR,UNI T
  33749   "RTN","CHM XF008",194 ,0)
  33750    Q
  33751   "RTN","CHM XF008",195 ,0)
  33752    ;
  33753   "RTN","CHM XF008",196 ,0)
  33754   GTLX(CHFI)                                                                                      ;  DLB 1/9/20 13 POPULAT E THE ^CHM IMAGE EDI  LINE IDENT IFIER FIEL D
  33755   "RTN","CHM XF008",197 ,0)
  33756    N LICTRL
  33757   "RTN","CHM XF008",198 ,0)
  33758    S LICTRL= $P(^CHMXCL F(CHFI,1), "^",23)                              ; VEND OR PROVIDE D LINE ITE M CONTROL  NUMBER
  33759   "RTN","CHM XF008",199 ,0)
  33760    I LICTRL= "" D
  33761   "RTN","CHM XF008",200 ,0)
  33762    . S LICTR L=$P(^CHMX CLF(CHFI,0 ),"^",2)                             ; HAC  ASSIGNED S ERVICE LIN E NUMBER
  33763   "RTN","CHM XF008",201 ,0)
  33764    . S $P(^C HMXCLF(CHF I,1),"^",2 3)="HAC"_L ICTRL
  33765   "RTN","CHM XF008",202 ,0)
  33766    ;W !,"CHM XF008:GTLX (",CHFI,") : RETRIEVE D: ",LICTR L
  33767   "RTN","CHM XF008",203 ,0)
  33768    Q LICTRL
  33769   "RTN","CHM XF009")
  33770   0^20^B6663 2527
  33771   "RTN","CHM XF009",1,0 )
  33772   CHMXF009 ; CVA/DTP;X1 2 837 CLM  CREATE SET  DNTL CLM  DATA TO IM AGE FILE ( DENTAL CLA IM);08/25/ 02  7:30 A M
  33773   "RTN","CHM XF009",2,0 )
  33774    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  33775   "RTN","CHM XF009",3,0 )
  33776    ;;JEH 1/2 1/07 - MOD IFIED FOR  ANESHESIA  CODE RATES
  33777   "RTN","CHM XF009",4,0 )
  33778    ;;DLB 8/1 7/2010- DE V7820 ADDE D ^CHMIMAG E LOAD CAL L TO LDCHM IMG^CHMXLI MG
  33779   "RTN","CHM XF009",5,0 )
  33780    ;;DLB 1/8 /2010- DEV 7820 MOVED  THE BALCH K^CHMXLIMG  FUNCTION  CALL OUT O F THIS ROU TINE
  33781   "RTN","CHM XF009",6,0 )
  33782    ;;                                BALANCE  CHECKS ARE  NOW PERFO RMED WITHI N THE CHMX LIMG.INT R OUTINE
  33783   "RTN","CHM XF009",7,0 )
  33784    ;;DLB 1/9 /2013  DEV 7820 ADDED  GTLX(CHFI ) FUNCTION  TO RETRIE VE THE LIN E OITEM CT RL # OR SE RVICE LINE  #
  33785   "RTN","CHM XF009",8,0 )
  33786    ;;                                         AND POPULA TE THE ^CH MIMAGE EDI  LINE IDEN TIFIER FIE LD.
  33787   "RTN","CHM XF009",9,0 )
  33788    ;; DLB 2/ 5/2013         DEV782 0  ADDED C ALL TO BAL CHK IN CHM XLIMG.INT  FOR SLA LO AD TO ^CHM IMAGE
  33789   "RTN","CHM XF009",10, 0)
  33790    ;;     DL B 2/11/201 3   MODIFI ED THE LOA D TO ^CHMI MAGE TO MA TCH ^CHMIM AGE DIZQF  FOR DENTAL
  33791   "RTN","CHM XF009",11, 0)
  33792    ;; DLB 2/ 13/13          CHANGE D "MODIFIE R" VALUES  TO DICTION ARY VALUES
  33793   "RTN","CHM XF009",12, 0)
  33794    ;; BMJ 11 /27/17 Use r Story CP E005-006 M odify Docu ment Ident ification  Screen - T ype of Bil l
  33795   "RTN","CHM XF009",13, 0)
  33796    ;;
  33797   "RTN","CHM XF009",14, 0)
  33798   A S (CHADM ,CHDIS,CHS TS,CHADMDX ,CHBLD,CHD CFAC,CHBNP D,CHTOB,CH CCRL)=""
  33799   "RTN","CHM XF009",15, 0)
  33800    G:'$D(^CH MXCLE(CHEI ,1)) B
  33801   "RTN","CHM XF009",16, 0)
  33802    ;Y2K - as sumes cent ury 2 - Fi xed by the  following  two lines
  33803   "RTN","CHM XF009",17, 0)
  33804    ;Y2K S CH ADM=2_$E($ P(^CHMXCLE (CHEI,1)," ^"),3,8)
  33805   "RTN","CHM XF009",18, 0)
  33806    ;Y2K S CH DIS=2_$E($ P(^CHMXCLE (CHEI,1)," ^",2),3,8)
  33807   "RTN","CHM XF009",19, 0)
  33808   B S (CHADM ,CHDIS)=""
  33809   "RTN","CHM XF009",20, 0)
  33810    G:'$D(^CH MXCLE(CHEI ,1)) B1
  33811   "RTN","CHM XF009",21, 0)
  33812    S CHADM=$ $YR8FMYR^C HTFLIB($P( ^CHMXCLE(C HEI,1),"^" ))
  33813   "RTN","CHM XF009",22, 0)
  33814    S CHDIS=$ $YR8FMYR^C HTFLIB($P( ^CHMXCLE(C HEI,1),"^" ,2))
  33815   "RTN","CHM XF009",23, 0)
  33816   B1 S CHXST YP=$P(^CHM XCLA(CHAI, 80),"^",7)
  33817   "RTN","CHM XF009",24, 0)
  33818   C G:'$D(^C HMXCLE(CHE I,2)) D
  33819   "RTN","CHM XF009",25, 0)
  33820    S CHBLD=$ P(^CHMXCLE (CHEI,2)," ^"),CHBNPD =$P(^(2)," ^",2)
  33821   "RTN","CHM XF009",26, 0)
  33822   D S CHPOS= $P(^CHMXCL E(CHEI,0), "^",4)
  33823   "RTN","CHM XF009",27, 0)
  33824    S:(CHSBTY P=2)&(CHPO S="") CHPO S=11 ; DEF AULT ASSUM ED TO BE D OCTOR'S OF FICE FOR A LL PROFESS IONAL SUBM ISSIONS IF  NOTHING S UPPLIED
  33825   "RTN","CHM XF009",28, 0)
  33826    D POSLU^C HMXF006
  33827   "RTN","CHM XF009",29, 0)
  33828    ;GETDX LO OPS THROUG H LINE LEV EL, FOR EA CH SERVICE  LINE GET  ALL DX COD ES, IF NO  DATA IN CH DXARY2(DT, DXCD) SET  IN CHDXARY 2 BY DATE  AND SET UP  IN IMAGE  FILE
  33829   "RTN","CHM XF009",30, 0)
  33830    ;D GETDX  ; CURRENTL Y DON'T GE T DX CODES  ON EDI DE NTAL CLAIM S
  33831   "RTN","CHM XF009",31, 0)
  33832    S CHFI=0, CHDTHLD="" ,DSTFLG=0                                                                 ;  DISTRIBUTI ON FLAG FO R ^CHMIMAG E LOAD
  33833   "RTN","CHM XF009",32, 0)
  33834   D1 S CHFI= $O(^CHMXCL F("B",CHEI ,CHFI)) G: 'CHFI BNPY MNT            ; LOOP  THRU LINE  ITEM ENTR IES
  33835   "RTN","CHM XF009",33, 0)
  33836    G:'$D(^CH MXCLF(CHFI ,0)) D1 G: '$D(^CHMXC LF(CHFI,1) ) D1
  33837   "RTN","CHM XF009",34, 0)
  33838    S CHFREC1 =^CHMXCLF( CHFI,1)
  33839   "RTN","CHM XF009",35, 0)
  33840    ;S CHREV= $P(CHFREC1 ,"^") G:CH REV="001"  D1 D RVCNV RT  ;SKD 8 -28-07 DEV 003081-02
  33841   "RTN","CHM XF009",36, 0)
  33842    S CHREV=$ P(CHFREC1, "^") G:+CH REV'>1 D1  D RVCNVRT   ;SKD 8-28 -07 DEV003 081-02
  33843   "RTN","CHM XF009",37, 0)
  33844    S CHSVCDT =$$YR8FMYR ^CHTFLIB($ P(CHFREC1, "^",11))
  33845   "RTN","CHM XF009",38, 0)
  33846    S:CHSVCDT ="" CHSVCD T=CHADM
  33847   "RTN","CHM XF009",39, 0)
  33848    ;D FUTDOS ^CHMXF009  ****INSERT  FUTURE DA TE OF SERV ICE CHECK  HERE
  33849   "RTN","CHM XF009",40, 0)
  33850    ;;NEXT NE STED DO IS  CHECK FOR  MULTIPLE  DOS WITH B ENE PAYMEN T
  33851   "RTN","CHM XF009",41, 0)
  33852   D2 G:CHDTH LD="" D3
  33853   "RTN","CHM XF009",42, 0)
  33854    I (CHDTHL D'=CHSVCDT )&(+CHBNPD >0) D
  33855   "RTN","CHM XF009",43, 0)
  33856    .S ZZ=999 99,ZZ=$O(^ CHMXCLE(CH EI,101,ZZ) ,-1) S:'ZZ  ZZ=0
  33857   "RTN","CHM XF009",44, 0)
  33858    .S CHRJRS N="",CHIL= "CHEI",CHG LBL="^CHMX CLE(",CHFN =741210.12 101
  33859   "RTN","CHM XF009",45, 0)
  33860    .S CHXREC ="E005",CH RCERR(CHXR EC,"E11x") =""
  33861   "RTN","CHM XF009",46, 0)
  33862    .D C^CHMX P003 K CHR CERR
  33863   "RTN","CHM XF009",47, 0)
  33864    .Q
  33865   "RTN","CHM XF009",48, 0)
  33866   D3 ;
  33867   "RTN","CHM XF009",49, 0)
  33868    I $G(CHJR XCOD(CHFI) )'="" S CH PX=$$PXCNV RT^CHEDILI B(CHJRXCOD (CHFI),"B" ),CHPXO=$$ PXCNVRT^CH EDILIB($P( CHFREC1,"^ ",3),"B")
  33869   "RTN","CHM XF009",50, 0)
  33870    I $G(CHJR XCOD(CHFI) )="" S CHP X=$$PXCNVR T^CHEDILIB ($P(CHFREC 1,"^",3)," B"),CHPXO= ""
  33871   "RTN","CHM XF009",51, 0)
  33872    ;S CHPX=$ $PXCNVRT^C HEDILIB(CH PX,"B") ;c onvert the  proc code  to ^CHMSE RV I val 
  33873   "RTN","CHM XF009",52, 0)
  33874    ;S CHPX=$ $PXCNVRT^C HEDILIB($P (CHFREC1," ^",3),"BD" )                       ; PROCED URE CODE t o ^CHMSERV  I val
  33875   "RTN","CHM XF009",53, 0)
  33876    ;G:$G(CHP X)="" D1   ;SKD 7-11- 07 DEV0027 10-01
  33877   "RTN","CHM XF009",54, 0)
  33878    S CHREV=$ P(CHFREC1, "^") G:+CH REV'>1 D1  D RVCNVRT                                   ; REVENUE  CODE ;SKD  8-28-07 DE V003081-02   ;AEB 2/4 /2008 DEV0 03367
  33879   "RTN","CHM XF009",55, 0)
  33880    S CHPXCHR G=$P(CHFRE C1,"^",6)                                                                          ; PR OCEURE CHA RGE
  33881   "RTN","CHM XF009",56, 0)
  33882    S CHPMOD1 =$P(CHFREC 1,"^",4) S :CHPMOD1'= "" CHPMOD1 =$O(^CHMDI C(741002.3 7,"B",CHPM OD1,0))          ; DL B 2/11/13  PROCEDURE  MODIFIERS
  33883   "RTN","CHM XF009",57, 0)
  33884    S CHPMOD2 =$P(CHFREC 1,"^",5) S :CHPMOD2'= "" CHPMOD2 =$O(^CHMDI C(741002.3 7,"B",CHPM OD2,0))          ; DL B 2/13/13  SET MOD VA LUES TO DI CTIONARY V ALUES
  33885   "RTN","CHM XF009",58, 0)
  33886    S CHPMOD3 =$P(CHFREC 1,"^",14)  S:CHPMOD3' ="" CHPMOD 3=$O(^CHMD IC(741002. 37,"B",CHP MOD3,0))
  33887   "RTN","CHM XF009",59, 0)
  33888    S CHPMOD4 =$P(CHFREC 1,"^",15)  S:CHPMOD4' ="" CHPMOD 4=$O(^CHMD IC(741002. 37,"B",CHP MOD4,0))    
  33889   "RTN","CHM XF009",60, 0)
  33890    D MODSEL
  33891   "RTN","CHM XF009",61, 0)
  33892    S CHLINE= $$GTLX(CHF I)                                                                                          ; DLB  1/9/2013 L INE ITEM C TRL # OR S ERVICE LIN E #
  33893   "RTN","CHM XF009",62, 0)
  33894    S CHUNITS =$P(CHFREC 1,"^",8)                                                                           ; NU MBER OF UN ITS
  33895   "RTN","CHM XF009",63, 0)
  33896    D ANCALC    ;CALCULA TE THE NUM BER OF UNI TS PER COD E TO INCLU DE RVU'S A ND CONVERT S MINUTES  TO UNITS
  33897   "RTN","CHM XF009",64, 0)
  33898    S:CHUNITS ="" CHUNIT S=1 S:CHUN ITS=0 CHUN ITS=1
  33899   "RTN","CHM XF009",65, 0)
  33900    S:$P(CHFR EC1,"^",16 )'="" CHPO S=$P(CHFRE C1,"^",16)                                  ; PLACE OF  SERVICE
  33901   "RTN","CHM XF009",66, 0)
  33902    D POSLU^C HMXF006
  33903   "RTN","CHM XF009",67, 0)
  33904    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"D ENTAL-NS", CHIMGL),-1 ),CHIMGL=C HIMGL+1
  33905   "RTN","CHM XF009",68, 0)
  33906   E S ^CHMIM AGE(CHMFPD I,1,CHTOSJ ,2,1,"DENT AL-NS",CHI MGL,0)=CHS VCDT_"^"_C HDFN_"^"_C HBFN_"^^^" _CHPX_"^"_ CHPXCHRG_" ^"_CHPMOD1 _"^^^"_CHP OSI_"^"_CH UNITS_"^^^ "_CHPXCHRG _"^"_CHLIN E_"^"_CHRE V_"^"_CHPX O_"^^"_CHP MOD2_"^"_C HPMOD3_"^" _CHPMOD4
  33907   "RTN","CHM XF009",69, 0)
  33908    ;W !,"CHM XF009:E:"" DENTAL-NS" " = ",^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"DE NTAL-NS",C HIMGL,0)
  33909   "RTN","CHM XF009",70, 0)
  33910    S CHDTHLD =CHSVCDT,C HIMGK=1                                                                                                          ; DLB S LA SET UP  INDEX VALU ES
  33911   "RTN","CHM XF009",71, 0)
  33912    S DSTFLG= DSTFLG+$$L DCHMIMG^CH MXLIMG(CHE I,CHFI,CHM FPDI,CHTOS J,CHIMGK,C HIMGL,"DEN TAL-NS")            ;  DLB SLA ^ CHMIMAGE L OAD
  33913   "RTN","CHM XF009",72, 0)
  33914    G D1
  33915   "RTN","CHM XF009",73, 0)
  33916    ; 
  33917   "RTN","CHM XF009",74, 0)
  33918   BNPYMNT ;; SETS UP BE NE PAYMENT  AT END OF  IMAGE FIL E
  33919   "RTN","CHM XF009",75, 0)
  33920    D:DSTFLG  BALCHK^CHM XLIMG(CHEI ,CHMFPDI,C HTOSJ,CHIM GK,CHIMGL, "DENTAL-NS ")                                   ; SLA  BALANCE CH ECK AGAINS T CLAIM OH OIPD 
  33921   "RTN","CHM XF009",76, 0)
  33922    G:CHBNPD= "" END
  33923   "RTN","CHM XF009",77, 0)
  33924    S CHIMGL= 99999,CHIM GL=+$O(^CH MIMAGE(CHM FPDI,1,CHT OSJ,2,1,"D ENTAL-NS", CHIMGL),-1 ),CHIMGL=C HIMGL+1
  33925   "RTN","CHM XF009",78, 0)
  33926    S ^CHMIMA GE(CHMFPDI ,1,CHTOSJ, 2,1,"DENTA L-NS",CHIM GL,0)=CHSV CDT_"^"_CH DFN_"^"_CH BFN_"^^"_C HBNPD_"^^^ ^^^"_CHPOS I
  33927   "RTN","CHM XF009",79, 0)
  33928    ; 
  33929   "RTN","CHM XF009",80, 0)
  33930   END S (CHT OB,CHCCRL) =""
  33931   "RTN","CHM XF009",81, 0)
  33932    ;I $D(^CH MXCLE(CHEI ,0)),($P(^ (0),"^",5) ="A")!($P( ^(0),"^",5 )="a") S C HTOB=$P(^( 0),"^",4)_ $P(^(0),"^ ",6)
  33933   "RTN","CHM XF009",82, 0)
  33934    I $D(^CHM XCLE(CHEI, 0)) S CHTO B=$P(^(0), "^",4)_$P( ^(0),"^",6 )  ; 11/27 /17 BMJ Us er Story C PE005-006  Changed th e line abo ve to this  line
  33935   "RTN","CHM XF009",83, 0)
  33936    I $D(^CHM XCLE(CHEI, 0)),$P(^(0 ),"^",2)'= "" S CHCCR L=$P(^(0), "^",2)
  33937   "RTN","CHM XF009",84, 0)
  33938    S $P(^CHM IMAGE(CHMF PDI,1,CHTO SJ,2,1,"VE N"),"^",7) =CHTOB,$P( ^("VEN")," ^",9)=5,$P (^("VEN"), "^",17)=CH CCRL
  33939   "RTN","CHM XF009",85, 0)
  33940    D:'$D(CHR DOIMG) BUF FND
  33941   "RTN","CHM XF009",86, 0)
  33942    K CHADM,C HDIS,CHBLD ,CHBNPD,CH EJJ,CHDX,C HPX,CHI,CH CCRL,CHTOB ,CHREV,CHP OS
  33943   "RTN","CHM XF009",87, 0)
  33944    K SKIPFLG ,CHSBTYP,C HFI,CHDTHL D,CHFREC1, CHSVCDT,CH PXCHRG,CHP MOD1,CHPMO D2
  33945   "RTN","CHM XF009",88, 0)
  33946    K CHPMOD, CHLINE,CHU NITS,CHIMG L,CHPOSI Q
  33947   "RTN","CHM XF009",89, 0)
  33948    ; 
  33949   "RTN","CHM XF009",90, 0)
  33950   BUFFND S ^ CHMIMAGE(C HMFPDI,"BU FF")=CHTPI D_"^"_CHMX I_"^"_CHAI _"^"_CHBI_ "^"_CHCI_" ^"_CHEI
  33951   "RTN","CHM XF009",91, 0)
  33952    Q
  33953   "RTN","CHM XF009",92, 0)
  33954    ; 
  33955   "RTN","CHM XF009",93, 0)
  33956   DXCNVRT K  SKIPFLG
  33957   "RTN","CHM XF009",94, 0)
  33958    I '$D(CHD X) S CHDX= "" Q
  33959   "RTN","CHM XF009",95, 0)
  33960    Q:CHDX=""
  33961   "RTN","CHM XF009",96, 0)
  33962    I '$D(^CH MICDX("C", CHDX)) S C HDX="" Q
  33963   "RTN","CHM XF009",97, 0)
  33964    S CHI=0,C HI=$O(^CHM ICDX("C",C HDX,0)) I  'CHI S CHD X="" Q
  33965   "RTN","CHM XF009",98, 0)
  33966    S CHDX=CH I
  33967   "RTN","CHM XF009",99, 0)
  33968    Q
  33969   "RTN","CHM XF009",100 ,0)
  33970    ; 
  33971   "RTN","CHM XF009",101 ,0)
  33972   RVCNVRT K  SKIPFLG S  CHI=""  ;A EB 4/3/200 8
  33973   "RTN","CHM XF009",102 ,0)
  33974    I '$D(CHR EV) S CHRE V="" Q
  33975   "RTN","CHM XF009",103 ,0)
  33976    Q:CHREV=" "
  33977   "RTN","CHM XF009",104 ,0)
  33978    I $L(CHRE V)=4 D ;AE B 2/4/2008  DEV003367  
  33979   "RTN","CHM XF009",105 ,0)
  33980    .I '$D(^C HMXDIC(741 201.39,"B" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  33981   "RTN","CHM XF009",106 ,0)
  33982    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"B", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  33983   "RTN","CHM XF009",107 ,0)
  33984    .Q  ;AEB  2/4/2008 D EV003367
  33985   "RTN","CHM XF009",108 ,0)
  33986    I $L(CHRE V)=3 D  ;A EB 2/4/200 8 DEV00336 7
  33987   "RTN","CHM XF009",109 ,0)
  33988    .I '$D(^C HMXDIC(741 201.39,"H" ,CHREV)) S  CHI="" Q   ;AEB 2/4/ 2008 DEV00 3367
  33989   "RTN","CHM XF009",110 ,0)
  33990    .S CHI=0, CHI=$O(^CH MXDIC(7412 01.39,"H", CHREV,CHI) )  ;AEB 2/ 4/2008 DEV 003367
  33991   "RTN","CHM XF009",111 ,0)
  33992    .Q  ;AEB  2/4/2008 D EV003367
  33993   "RTN","CHM XF009",112 ,0)
  33994    I 'CHI S  CHREV="" Q   ;AEB 2/4 /2008 DEV0 03367
  33995   "RTN","CHM XF009",113 ,0)
  33996    S CHREV=C HI 
  33997   "RTN","CHM XF009",114 ,0)
  33998    Q
  33999   "RTN","CHM XF009",115 ,0)
  34000    ; 
  34001   "RTN","CHM XF009",116 ,0)
  34002   GETDX ;;LO AD ALL DX  CODES, EXC EPT ADM DX , INTO CHD XARY
  34003   "RTN","CHM XF009",117 ,0)
  34004    S CHFI=0  K CHDXARY2
  34005   "RTN","CHM XF009",118 ,0)
  34006   GETDX1 S C HFI=$O(^CH MXCLF("B", CHEI,CHFI) ) Q:'CHFI
  34007   "RTN","CHM XF009",119 ,0)
  34008    G:'$D(^CH MXCLF(CHFI ,1)) GETDX 1 G:'$D(^C HMXCLF(CHF I,0)) GETD X1
  34009   "RTN","CHM XF009",120 ,0)
  34010    S CHFREC1 =^CHMXCLF( CHFI,1)
  34011   "RTN","CHM XF009",121 ,0)
  34012    S CHSVCDT =$$YR8FMYR ^CHTFLIB($ P(CHFREC1, "^",11))
  34013   "RTN","CHM XF009",122 ,0)
  34014    S:CHSVCDT ="" CHSVCD T=CHADM ;  SET TO "FU TURE" HERE  TOO IF NE CESSARY
  34015   "RTN","CHM XF009",123 ,0)
  34016    S:$P(CHFR EC1,"^",16 )'="" CHPO S=$P(CHFRE C1,"^",16)
  34017   "RTN","CHM XF009",124 ,0)
  34018    D POSLU^C HMXF006
  34019   "RTN","CHM XF009",125 ,0)
  34020    S (CHDIAG 1,CHDIAG2, CHDIAG3,CH DIAG4)=""
  34021   "RTN","CHM XF009",126 ,0)
  34022    S CHDIAG1 =$P(CHFREC 1,"^",18), CHDIAG2=$P (CHFREC1," ^",19)
  34023   "RTN","CHM XF009",127 ,0)
  34024    S CHDIAG3 =$P(CHFREC 1,"^",20), CHDIAG4=$P (CHFREC1," ^",21)
  34025   "RTN","CHM XF009",128 ,0)
  34026    F XXX=1:1 :4 S CHDIA G="CHDIAG" _XXX D:@CH DIAG'=""
  34027   "RTN","CHM XF009",129 ,0)
  34028    .D:'$D(CH DXARY2(CHS VCDT,@CHDI AG))
  34029   "RTN","CHM XF009",130 ,0)
  34030    ..S CHDXA RY2(CHSVCD T,@CHDIAG) =""
  34031   "RTN","CHM XF009",131 ,0)
  34032    ..S CHDX= @CHDIAG D  DXCNVRT
  34033   "RTN","CHM XF009",132 ,0)
  34034    ..S CHIMG L=99999,CH IMGL=+$O(^ CHMIMAGE(C HMFPDI,1,C HTOSJ,2,1, "DENTAL-NS ",CHIMGL), -1),CHIMGL =CHIMGL+1
  34035   "RTN","CHM XF009",133 ,0)
  34036    ..S ^CHMI MAGE(CHMFP DI,1,CHTOS J,2,1,"DEN TAL-NS",CH IMGL,0)=CH SVCDT_"^"_ CHPOSI_"^" _CHDFN_"^" _CHBFN_"^^ ^^^^"_CHDX
  34037   "RTN","CHM XF009",134 ,0)
  34038    .Q
  34039   "RTN","CHM XF009",135 ,0)
  34040    G GETDX1
  34041   "RTN","CHM XF009",136 ,0)
  34042    ;*****CON SIDER CONV ERTING NEX T 6 LINES  INTO A BAC KLOAD OF D X CODES AT  CLM LEVEL
  34043   "RTN","CHM XF009",137 ,0)
  34044    ;S CHEJJ= 0
  34045   "RTN","CHM XF009",138 ,0)
  34046   GETDXL1 ;S  CHEJJ=$O( ^CHMXCLE(C HEI,40,CHE JJ)) Q:'CH EJJ
  34047   "RTN","CHM XF009",139 ,0)
  34048    ;G:'$D(^C HMXCLE(CHE I,40,CHEJJ ,0)) GETDX L1 S CHDX= ^CHMXCLE(C HEI,40,CHE JJ,0) G:CH DX="" GETD XL1
  34049   "RTN","CHM XF009",140 ,0)
  34050    ;D DXCNVR T G:$D(SKI PFLG) GETD XL1
  34051   "RTN","CHM XF009",141 ,0)
  34052    ;S CHDXAR Y(CHEJJ)=C HDX
  34053   "RTN","CHM XF009",142 ,0)
  34054    ;G GETDXL 1
  34055   "RTN","CHM XF009",143 ,0)
  34056    ; 
  34057   "RTN","CHM XF009",144 ,0)
  34058   MODSEL ;;M ODIFIER OR DER OF IMP ORTANCE:   80,81,82,A S,26,TC, T HEN FIRST  SUBMITTED
  34059   "RTN","CHM XF009",145 ,0)
  34060    I (CHPMOD 1=80)!(CHP MOD1=81)!( CHPMOD1=82 )!(CHPMOD1 ="AS") S C HPMOD=CHPM OD1 D MODC VRT Q
  34061   "RTN","CHM XF009",146 ,0)
  34062    I (CHPMOD 2=80)!(CHP MOD2=81)!( CHPMOD2=82 )!(CHPMOD2 ="AS") S C HPMOD=CHPM OD2 D MODC VRT Q
  34063   "RTN","CHM XF009",147 ,0)
  34064    I (CHPMOD 3=80)!(CHP MOD3=81)!( CHPMOD3=82 )!(CHPMOD3 ="AS") S C HPMOD=CHPM OD3 D MODC VRT Q
  34065   "RTN","CHM XF009",148 ,0)
  34066    I (CHPMOD 4=80)!(CHP MOD4=81)!( CHPMOD4=82 )!(CHPMOD4 ="AS") S C HPMOD=CHPM OD4 D MODC VRT Q
  34067   "RTN","CHM XF009",149 ,0)
  34068    I (CHPMOD 1=26)!(CHP MOD1="TC")  S CHPMOD= CHPMOD1 D  MODCVRT Q
  34069   "RTN","CHM XF009",150 ,0)
  34070    I (CHPMOD 2=26)!(CHP MOD2="TC")  S CHPMOD= CHPMOD2 D  MODCVRT Q
  34071   "RTN","CHM XF009",151 ,0)
  34072    I (CHPMOD 3=26)!(CHP MOD3="TC")  S CHPMOD= CHPMOD3 D  MODCVRT Q
  34073   "RTN","CHM XF009",152 ,0)
  34074    I (CHPMOD 4=26)!(CHP MOD4="TC")  S CHPMOD= CHPMOD4 D  MODCVRT Q
  34075   "RTN","CHM XF009",153 ,0)
  34076    I CHPMOD1 '="" S CHP MOD=CHPMOD 1 D MODCVR T Q
  34077   "RTN","CHM XF009",154 ,0)
  34078    I CHPMOD2 '="" S CHP MOD=CHPMOD 2 D MODCVR T Q
  34079   "RTN","CHM XF009",155 ,0)
  34080    I CHPMOD3 '="" S CHP MOD=CHPMOD 3 D MODCVR T Q
  34081   "RTN","CHM XF009",156 ,0)
  34082    I CHPMOD4 '="" S CHP MOD=CHPMOD 4 D MODCVR T Q
  34083   "RTN","CHM XF009",157 ,0)
  34084    E  S CHPM OD=""
  34085   "RTN","CHM XF009",158 ,0)
  34086    Q
  34087   "RTN","CHM XF009",159 ,0)
  34088    ; 
  34089   "RTN","CHM XF009",160 ,0)
  34090   MODCVRT Q: '$D(CHPMOD )  Q:CHPMO D=""
  34091   "RTN","CHM XF009",161 ,0)
  34092    S:$D(^CHM DIC(741002 .37,"B",CH PMOD)) CHP MOD=$O(^CH MDIC(74100 2.37,"B",C HPMOD,0))
  34093   "RTN","CHM XF009",162 ,0)
  34094    Q
  34095   "RTN","CHM XF009",163 ,0)
  34096   FUTDOS I C HSVCDT=""  S CHSVCDT= "FUTURE" Q
  34097   "RTN","CHM XF009",164 ,0)
  34098    D NOW^%DT C S CHXCMP DT=$E(%,1, 7)
  34099   "RTN","CHM XF009",165 ,0)
  34100    I CHSVCDT '<CHXCMPDT  S CHSVCDT ="FUTURE"
  34101   "RTN","CHM XF009",166 ,0)
  34102    Q
  34103   "RTN","CHM XF009",167 ,0)
  34104   ANCALC ;CA LCULATE TH E NUMBER O F UNITS FR OM MINUTES +RVUs OR U NITS+RVUs  SUBMITTED
  34105   "RTN","CHM XF009",168 ,0)
  34106    Q:CHUNITS =""
  34107   "RTN","CHM XF009",169 ,0)
  34108    Q:CHUNITS =0
  34109   "RTN","CHM XF009",170 ,0)
  34110    Q:CHPX=""
  34111   "RTN","CHM XF009",171 ,0)
  34112    Q:'$D(CHP X)
  34113   "RTN","CHM XF009",172 ,0)
  34114    I $D(^CHM SERV(CHPX, 4)) D
  34115   "RTN","CHM XF009",173 ,0)
  34116    .S CHQLFY R=$P(CHFRE C1,"^",7)
  34117   "RTN","CHM XF009",174 ,0)
  34118    .Q:'$D(CH QLFYR)
  34119   "RTN","CHM XF009",175 ,0)
  34120    .Q:CHQLFY R=""
  34121   "RTN","CHM XF009",176 ,0)
  34122    .S CHCDEF D=9999999- CHSVCDT
  34123   "RTN","CHM XF009",177 ,0)
  34124    .S CHCDEF D=$O(^CHMS ERV(CHPX,4 ,"B",CHCDE FD),-1)
  34125   "RTN","CHM XF009",178 ,0)
  34126    .S CHCJPT R=0 S CHCJ PTR=$O(^CH MSERV(CHPX ,4,"B",CHC DEFD,CHCJP TR))
  34127   "RTN","CHM XF009",179 ,0)
  34128    .S BASU=$ P(^CHMSERV (CHPX,4,CH CJPTR,0)," ^",2)
  34129   "RTN","CHM XF009",180 ,0)
  34130    .I CHQLFY R="UN" D
  34131   "RTN","CHM XF009",181 ,0)
  34132    ..S CHUNI TS=CHUNITS +BASU
  34133   "RTN","CHM XF009",182 ,0)
  34134    .I CHQLFY R="MJ" D
  34135   "RTN","CHM XF009",183 ,0)
  34136    ..S TIMU= 0
  34137   "RTN","CHM XF009",184 ,0)
  34138    ..S UNIT= CHUNITS#15
  34139   "RTN","CHM XF009",185 ,0)
  34140    ..S TIMU= (CHUNITS-U NIT)/15 
  34141   "RTN","CHM XF009",186 ,0)
  34142    ..S:UNIT' =0 TIMU=TI MU+1
  34143   "RTN","CHM XF009",187 ,0)
  34144    ..S CHUNI TS=TIMU+BA SU
  34145   "RTN","CHM XF009",188 ,0)
  34146    K CHQLFYR ,BASU,TIMU ,CHCDEFD,C HCJPTR,UNI T
  34147   "RTN","CHM XF009",189 ,0)
  34148    Q
  34149   "RTN","CHM XF009",190 ,0)
  34150    ;
  34151   "RTN","CHM XF009",191 ,0)
  34152   GTLX(CHFI)                                                                                      ;  DLB 1/9/20 13 POPULAT E THE ^CHM IMAGE EDI  LINE IDENT IFIER FIEL D
  34153   "RTN","CHM XF009",192 ,0)
  34154    N LICTRL
  34155   "RTN","CHM XF009",193 ,0)
  34156    S LICTRL= $P(^CHMXCL F(CHFI,1), "^",23)                              ; VEND OR PROVIDE D LINE ITE M CONTROL  NUMBER
  34157   "RTN","CHM XF009",194 ,0)
  34158    I LICTRL= "" D
  34159   "RTN","CHM XF009",195 ,0)
  34160    . S LICTR L=$P(^CHMX CLF(CHFI,0 ),"^",2)                             ; HAC  ASSIGNED S ERVICE LIN E NUMBER
  34161   "RTN","CHM XF009",196 ,0)
  34162    . S $P(^C HMXCLF(CHF I,1),"^",2 3)="HAC"_L ICTRL
  34163   "RTN","CHM XF009",197 ,0)
  34164    ;W !,"CHM XF009:GTLX (",CHFI,") : RETRIEVE D: ",LICTR L
  34165   "RTN","CHM XF009",198 ,0)
  34166    Q LICTRL
  34167   "RTN","CHM XG001")
  34168   0^21^B4419 3226
  34169   "RTN","CHM XG001",1,0 )
  34170   CHMXG001 ; CVA/DTP;50 10 X12 837  277 FILE  GENERATION  DRIVER (H EALTH CARE  CLAIMS);0 2/10/98  1 2:24 PM
  34171   "RTN","CHM XG001",2,0 )
  34172    ;;1.0;CHA MPVA SYSTE M;**2**;JU LY 4, 1990 ;Build 5
  34173   "RTN","CHM XG001",3,0 )
  34174    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  34175   "RTN","CHM XG001",4,0 )
  34176    ;; UNSOLI CITED STAT US (ACKNOW LEDGEMENT  STATUS) DR IVER ROUTI NE
  34177   "RTN","CHM XG001",5,0 )
  34178    ;;HR-COB- Medicare-A /B - Setti ng up bloc ks for new  trading p artner (23 -Feb-2010)
  34179   "RTN","CHM XG001",6,0 )
  34180    ;;BDB 02/ 07/18 CPE0 05-042 FC8  CSTATS
  34181   "RTN","CHM XG001",7,0 )
  34182    ;;
  34183   "RTN","CHM XG001",8,0 )
  34184   START ;S C HRTNFRM=27 7 K CHERR  S FILE="ED I1::E:[X12 .ENVOY.OUT ]EDI_277.D AT"
  34185   "RTN","CHM XG001",9,0 )
  34186    G END
  34187   "RTN","CHM XG001",10, 0)
  34188    S CHRTNFR M=277 K CH ERR,CHXVRS N S FILE=" DHCP$SYSTE M:[DSMMGR] EDI_277.DA T"
  34189   "RTN","CHM XG001",11, 0)
  34190    ;I $D(CHN MRTN) I CH NMRTN'=""  D @CHNMRTN
  34191   "RTN","CHM XG001",12, 0)
  34192    I '$D(CH2 77FLG) O F ILE:"NWV"  G:'$T FILE PRB S CH27 7FLG="" G  S1 ; Pre-C ache -> I  '$D(CH277F LG) O FILE :(NEW:PROT ECTION=(WO RLD=RWED)) :3 G:'$T F ILEPRB S C H277FLG=""  G S1
  34193   "RTN","CHM XG001",13, 0)
  34194    I $D(CH27 7FLG) O FI LE::3 G:'$ T FILEPRB
  34195   "RTN","CHM XG001",14, 0)
  34196   S1 D NOW^% DTC S CHTR DT=%,CHTRN SDT=$P(%," .",1),CY=$ S($E(CHTRN SDT,1)=2:1 9,$E(CHTRN SDT,1)=3:2 0,$E(CHTRN SDT,1)=4:2 1,1:19),CH TRNSDT=CY_ $E(CHTRNSD T,2,7)
  34197   "RTN","CHM XG001",15, 0)
  34198   D1 I $D(^C HMXCLA(CHT RI,100)) I  $P(^(100) ,"^")=1 S  CHFLREF="^ CHMXCLA(", CHI=CHTRI, CHLVLSUB=" A" D PULLE R G D2
  34199   "RTN","CHM XG001",16, 0)
  34200    I $D(^CHM XCLA(CHTRI ,101)) S C HFLREF="^C HMXCLA(",C HI=CHTRI,C HLVLSUB="A " D PULLER
  34201   "RTN","CHM XG001",17, 0)
  34202    I $D(^CHM XCLA(CHTRI ,0)) I $P( ^CHMXCLA(C HTRI,0),"^ ",13)["401 0" S CHXVR SN=""
  34203   "RTN","CHM XG001",18, 0)
  34204   D2 S CHREC ="A000" D  ^CHMXGU01  G:$D(CHRTN QT) END D  ZA000^CHMX GU02
  34205   "RTN","CHM XG001",19, 0)
  34206    S CHREC=" A005" D ^C HMXGU01 G: $D(CHRTNQT ) END S ^C HMXCLSA(A, 2)=CHDTSTR
  34207   "RTN","CHM XG001",20, 0)
  34208    S CHREC=" A020" D ^C HMXGU01 G: $D(CHRTNQT ) END S ^C HMXCLSA(A, 20)=CHDTST R
  34209   "RTN","CHM XG001",21, 0)
  34210    S CHREC=" A030" D ^C HMXGU01 G: $D(CHRTNQT ) END S ^C HMXCLSA(A, 30)=CHDTST R
  34211   "RTN","CHM XG001",22, 0)
  34212    S CHPRI=0
  34213   "RTN","CHM XG001",23, 0)
  34214   D3 S CHPRI =$O(^CHMXC LB("B",CHT RI,CHPRI))  G:'CHPRI  END
  34215   "RTN","CHM XG001",24, 0)
  34216    F LV="B", "C","E","F " K CHERR( LV)
  34217   "RTN","CHM XG001",25, 0)
  34218    I $D(^CHM XCLB(CHPRI ,100)) I $ P(^(100)," ^")=1 S CH FLREF="^CH MXCLB(",CH I=CHPRI,CH LVLSUB="B"  D PULLER  G D31
  34219   "RTN","CHM XG001",26, 0)
  34220    I $D(^CHM XCLB(CHPRI ,101)) S C HFLREF="^C HMXCLB(",C HI=CHPRI,C HLVLSUB="B " D PULLER
  34221   "RTN","CHM XG001",27, 0)
  34222   D31 S CHRE C="B000" D  ^CHMXGU01  G:$D(CHRT NQT) END D  ZB000^CHM XGU02
  34223   "RTN","CHM XG001",28, 0)
  34224    S CHBNI=0
  34225   "RTN","CHM XG001",29, 0)
  34226   D4 S CHBNI =$O(^CHMXC LC("B",CHP RI,CHBNI))  G:'CHBNI  D3
  34227   "RTN","CHM XG001",30, 0)
  34228    F LV="C", "E","F" K  CHERR(LV)
  34229   "RTN","CHM XG001",31, 0)
  34230    I $D(^CHM XCLC(CHBNI ,100)) I $ P(^(100)," ^")=1 S CH FLREF="^CH MXCLC(",CH I=CHBNI,CH LVLSUB="C"  D PULLER  G D41
  34231   "RTN","CHM XG001",32, 0)
  34232    I $D(^CHM XCLC(CHBNI ,101)) S C HFLREF="^C HMXCLC(",C HI=CHBNI,C HLVLSUB="C " D PULLER
  34233   "RTN","CHM XG001",33, 0)
  34234   D41 S CHRE C="C000" D  ^CHMXGU01  G:$D(CHRT NQT) END D  ZC000^CHM XGU02
  34235   "RTN","CHM XG001",34, 0)
  34236    S CHCLI=0
  34237   "RTN","CHM XG001",35, 0)
  34238   D5 S CHCLI =$O(^CHMXC LE("B",CHB NI,CHCLI))  G:'CHCLI  D4
  34239   "RTN","CHM XG001",36, 0)
  34240    I '$D(^CH MXCLE(CHCL I,100)) S  CHRTNQT="" ,CHRTNRSN= 8 G END
  34241   "RTN","CHM XG001",37, 0)
  34242    S CHCLCTR L=$P(^CHMX CLE(CHCLI, 100),"^",4 ) I CHCLCT RL="" S CH RTNQT="",C HRTNRSN=8  G END
  34243   "RTN","CHM XG001",38, 0)
  34244    I ('$D(^C HMXCLE("A" ,CHMXCLI,6 ,CHTRI,CHC LCTRL,CHPR I_"*"_CHBN I_"*"_CHCL I)))&('$D( ^CHMXCLE(" A",CHMXCLI ,2,CHTRI,C HCLCTRL,CH PRI_"*"_CH BNI_"*"_CH CLI))) D   G END
  34245   "RTN","CHM XG001",39, 0)
  34246    .S CHRTNQ T="",CHRTN RSN=8 Q
  34247   "RTN","CHM XG001",40, 0)
  34248    I $D(^CHM XCLE("A",C HMXCLI,6,C HTRI,CHCLC TRL,CHPRI_ "*"_CHBNI_ "*"_CHCLI) ) S CHARFL G="R"
  34249   "RTN","CHM XG001",41, 0)
  34250    E  S CHAR FLG="A"
  34251   "RTN","CHM XG001",42, 0)
  34252    I $D(^CHM XCLE(CHCLI ,100)) G:$ P(^CHMXCLE (CHCLI,100 ),"^",3)=1  D5
  34253   "RTN","CHM XG001",43, 0)
  34254    F LV="E", "F" K CHER R(LV)
  34255   "RTN","CHM XG001",44, 0)
  34256    I $D(^CHM XCLE(CHCLI ,100)) I $ P(^(100)," ^")=1 S CH FLREF="^CH MXCLE(",CH I=CHCLI,CH LVLSUB="E"  D PULLER  G D51
  34257   "RTN","CHM XG001",45, 0)
  34258    I $D(^CHM XCLE(CHCLI ,101)) S C HFLREF="^C HMXCLE(",C HI=CHCLI,C HLVLSUB="E " D PULLER
  34259   "RTN","CHM XG001",46, 0)
  34260   D51 S CHTR NCT=CHTRNC T+1 G:CHAR FLG="A" D5 4
  34261   "RTN","CHM XG001",47, 0)
  34262    S CHERI=" " K CHERFL G
  34263   "RTN","CHM XG001",48, 0)
  34264   D52 S CHER I=$O(CHERR (CHERI)) I  CHERI=""  G:$D(CHRTN QT) END G  D59
  34265   "RTN","CHM XG001",49, 0)
  34266    S CHERJ=0
  34267   "RTN","CHM XG001",50, 0)
  34268   D53 S CHER J=$O(CHERR (CHERI,CHE RJ)) G:'CH ERJ D52
  34269   "RTN","CHM XG001",51, 0)
  34270    G:'$D(CHE RR(CHERI,C HERJ)) D53
  34271   "RTN","CHM XG001",52, 0)
  34272    S CHLVL=" E" D DSET  G:$D(CHRTN QT) END
  34273   "RTN","CHM XG001",53, 0)
  34274    G D53
  34275   "RTN","CHM XG001",54, 0)
  34276   D54 S CHRE C="E000" D  ^CHMXGU01  G:$D(CHRT NQT) END D  ZE000^CHM XGU02
  34277   "RTN","CHM XG001",55, 0)
  34278    S CHREC=" E001" D ^C HMXGU01 G: $D(CHRTNQT ) END D ZE 001^CHMXGU 02
  34279   "RTN","CHM XG001",56, 0)
  34280    S CHCOND= 2,CHREC="E 010" D ^CH MXGU01 G:$ D(CHRTNQT)  END S ^CH MXCLSE(E,1 )=CHDTSTR
  34281   "RTN","CHM XG001",57, 0)
  34282    S CHCOND= 1,CHREC="E 020" D ^CH MXGU01 G:$ D(CHRTNQT)  END D ZE0 20^CHMXGU0 2
  34283   "RTN","CHM XG001",58, 0)
  34284    S CHCOND= 2,CHREC="E 020" D ^CH MXGU01 G:$ D(CHRTNQT)  END D ZE0 20^CHMXGU0 2
  34285   "RTN","CHM XG001",59, 0)
  34286    S CHREC=" E025" D ^C HMXGU01 G: $D(CHRTNQT ) END D ZE 025^CHMXGU 02
  34287   "RTN","CHM XG001",60, 0)
  34288   D59 S CHSV I=0
  34289   "RTN","CHM XG001",61, 0)
  34290   D6 S CHSVI =$O(^CHMXC LF("B",CHC LI,CHSVI))  I 'CHSVI  D FKILL G  D5
  34291   "RTN","CHM XG001",62, 0)
  34292    G:'$D(^CH MXCLF(CHSV I,101)) D6
  34293   "RTN","CHM XG001",63, 0)
  34294    G:('$D(^C HMXCLF(CHS VI,100)))& ('$D(^CHMX CLF(CHSVI, 101))) D6  K CHERR("F ")
  34295   "RTN","CHM XG001",64, 0)
  34296    I $D(^CHM XCLF(CHSVI ,100)) I $ P(^(100)," ^")=1 S CH FLREF="^CH MXCLF(",CH I=CHSVI,CH LVLSUB="F"  D PULLER  G D61
  34297   "RTN","CHM XG001",65, 0)
  34298    I $D(^CHM XCLF(CHSVI ,101)) S C HFLREF="^C HMXCLF(",C HI=CHSVI,C HLVLSUB="F " D PULLER
  34299   "RTN","CHM XG001",66, 0)
  34300   D61 S CHER I="F",CHER J=0 K CHER FLG
  34301   "RTN","CHM XG001",67, 0)
  34302   D63 S CHER J=$O(CHERR (CHERI,CHE RJ)) I 'CH ERJ G:$D(C HRTNQT) EN D G D6
  34303   "RTN","CHM XG001",68, 0)
  34304    G:'$D(CHE RR(CHERI,C HERJ)) D63
  34305   "RTN","CHM XG001",69, 0)
  34306    S CHLVL=" F" D DSET  G:$D(CHRTN QT) END
  34307   "RTN","CHM XG001",70, 0)
  34308    G D63
  34309   "RTN","CHM XG001",71, 0)
  34310   D8 ;
  34311   "RTN","CHM XG001",72, 0)
  34312   END ;C FIL E
  34313   "RTN","CHM XG001",73, 0)
  34314    D DEBUG^C HMXDR01("C HMXG001: E ND READY T O DO CSTAT ",1)
  34315   "RTN","CHM XG001",74, 0)
  34316    K CHXVRSN
  34317   "RTN","CHM XG001",75, 0)
  34318    S CHMXI=C HMXCLI                                   ;  SET THE ^C HMXCL() IN DEX FOR CR EATING ACK  FILE 
  34319   "RTN","CHM XG001",76, 0)
  34320    Q:'$D(CHT PABBR)                                   ;  IF CHTPABB R (TP ABBR EVIATION V ARIABLE) N OT DEFINED ; QUIT  
  34321   "RTN","CHM XG001",77, 0)
  34322    Q:CHTPABB R=""                                     ;  IF CHTPABB R (TP ABBR EVIATION V ARIABLE) N OT SET; QU IT
  34323   "RTN","CHM XG001",78, 0)
  34324    D DEBUG^C HMXDR01("C HMXG001:RE ADY FOR CS TAT GENERA TION FOR =  ",$P(^CHM XCL(CHMXI, 0),"^",6))
  34325   "RTN","CHM XG001",79, 0)
  34326    ;HR-COB-M edicare-A/ B-Begin-93 72 (23-Feb -2010)
  34327   "RTN","CHM XG001",80, 0)
  34328    ;I CHTPAB BR?1(1"ENV ",1"MMIACH ",1"SXCACH ",1"MEDCOB ") S CHMXI =CHMXCLI D  EPACK^CHM XWB21(CHMX I)
  34329   "RTN","CHM XG001",81, 0)
  34330    ;I CHTPAB BR?1(1"ENV ",1"MMIACH ",1"SXCACH ",1"MEDCOB ") S CHMXI =CHMXCLI D  ^CHMXWB11
  34331   "RTN","CHM XG001",82, 0)
  34332    I CHTPABB R?1(1"ENV" ,1"MMIACH" ,1"SXCACH" ,1"MEDCOB" ) D  
  34333   "RTN","CHM XG001",83, 0)
  34334    .S CHMXI= CHMXCLI D  EPACK^CHMX WB21(CHMXI )
  34335   "RTN","CHM XG001",84, 0)
  34336    .I $G(CHF C8CIP) D   ;BDB 02/07 /18 CPE005 -042 FC8
  34337   "RTN","CHM XG001",85, 0)
  34338    ..D CRCST AT^CHMFUTL E(CHMFPDI, ,"E001d"," A") K CHFC 8CIP
  34339   "RTN","CHM XG001",86, 0)
  34340    ..S DIE=7 41000.2,DA =CHMFPDI,D R=".06///4 " D ^DIE K  DIE ;comp leted
  34341   "RTN","CHM XG001",87, 0)
  34342    ;HR-COB-M edicare-A/ B-End-9372
  34343   "RTN","CHM XG001",88, 0)
  34344    D DEBUG^C HMXDR01("C HMXG001: C STAT FILE:  ",$P(^CHM XCL(CHMXI, 80),"^",5) )
  34345   "RTN","CHM XG001",89, 0)
  34346    Q
  34347   "RTN","CHM XG001",90, 0)
  34348    ;
  34349   "RTN","CHM XG001",91, 0)
  34350   FKILL S $P (^CHMXCLE( CHCLI,100) ,"^",3)=1
  34351   "RTN","CHM XG001",92, 0)
  34352    I CHARFLG ="A" K ^CH MXCLE("A", CHMXCLI,3, CHTRI,CHCL CTRL,CHPRI _"*"_CHBNI _"*"_CHCLI ),^CHMXCLE ("A",CHMXC LI,2,CHTRI ,CHCLCTRL, CHPRI_"*"_ CHBNI_"*"_ CHCLI) S ^ CHMXCLE("A ",CHMXCLI, 4,CHTRI,CH CLCTRL,CHP RI_"*"_CHB NI_"*"_CHC LI)=""
  34353   "RTN","CHM XG001",93, 0)
  34354    ;
  34355   "RTN","CHM XG001",94, 0)
  34356    Q
  34357   "RTN","CHM XG001",95, 0)
  34358    ;
  34359   "RTN","CHM XG001",96, 0)
  34360   DSET I '$D (CHERFLG)  D  Q:$D(CH RTNQT)  Q
  34361   "RTN","CHM XG001",97, 0)
  34362    .I (CHLVL ="E")!(CHA RFLG="R")  D  Q:$D(CH RTNQT)
  34363   "RTN","CHM XG001",98, 0)
  34364    ..S CHREC ="E000",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  D ZE00 0^CHMXGU02  S:CHLVL=" E" CHARFLG ="RE"
  34365   "RTN","CHM XG001",99, 0)
  34366    ..I CHARF LG="R" S C HERIHLD=CH ERI,CHERJH LD=CHERJ,C HERI="E",C HERJ=1,CHE RR(CHERI,C HERJ)=999
  34367   "RTN","CHM XG001",100 ,0)
  34368    ..S CHREC ="E010",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSE(E,1) =CHDTSTR
  34369   "RTN","CHM XG001",101 ,0)
  34370    ..S CHREC ="E015",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSE(E,2) =CHDTSTR
  34371   "RTN","CHM XG001",102 ,0)
  34372    ..S CHCON D=1,CHREC= "E020" D ^ CHMXGU01 Q :$D(CHRTNQ T)  D ZE02 0^CHMXGU02
  34373   "RTN","CHM XG001",103 ,0)
  34374    ..S CHCON D=2,CHREC= "E020" D ^ CHMXGU01 Q :$D(CHRTNQ T)  D ZE02 0^CHMXGU02
  34375   "RTN","CHM XG001",104 ,0)
  34376    ..S CHCON D=1,CHREC= "E025" D ^ CHMXGU01 Q :$D(CHRTNQ T)  D ZE02 5^CHMXGU02
  34377   "RTN","CHM XG001",105 ,0)
  34378    ..I CHARF LG="R" S C HERI=CHERI HLD,CHERJ= CHERJHLD,C HARFLG="RE "
  34379   "RTN","CHM XG001",106 ,0)
  34380    .I CHLVL= "F" D  Q:$ D(CHRTNQT)
  34381   "RTN","CHM XG001",107 ,0)
  34382    ..S CHREC ="F000",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  D ZF00 0^CHMXGU02
  34383   "RTN","CHM XG001",108 ,0)
  34384    ..S CHREC ="F005",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSF(F,1) =CHDTSTR
  34385   "RTN","CHM XG001",109 ,0)
  34386    ..S CHREC ="F010",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSF(F,2) =CHDTSTR
  34387   "RTN","CHM XG001",110 ,0)
  34388    ..S CHCON D=4,CHREC= "F015" D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSF(F,4) =CHDTSTR
  34389   "RTN","CHM XG001",111 ,0)
  34390    ..S CHREC ="F020",CH COND=2 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSF(F,5) =CHDTSTR
  34391   "RTN","CHM XG001",112 ,0)
  34392    .S CHERFL G=""
  34393   "RTN","CHM XG001",113 ,0)
  34394    I $D(CHER FLG) D  Q: $D(CHRTNQT )
  34395   "RTN","CHM XG001",114 ,0)
  34396    .I CHLVL= "E" D  Q:$ D(CHRTNQT)
  34397   "RTN","CHM XG001",115 ,0)
  34398    ..S CHREC ="E000",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  D ZE00 0^CHMXGU02
  34399   "RTN","CHM XG001",116 ,0)
  34400    ..S CHREC ="E010",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSE(E,1) =CHDTSTR
  34401   "RTN","CHM XG001",117 ,0)
  34402    ..S CHREC ="E015",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSE(E,2) =CHDTSTR
  34403   "RTN","CHM XG001",118 ,0)
  34404    ..S CHCON D=1,CHREC= "E020" D ^ CHMXGU01 Q :$D(CHRTNQ T)  D ZE02 0^CHMXGU02
  34405   "RTN","CHM XG001",119 ,0)
  34406    .I CHLVL= "F" D  Q:$ D(CHRTNQT)
  34407   "RTN","CHM XG001",120 ,0)
  34408    ..S CHREC ="F000",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  D ZF00 0^CHMXGU02
  34409   "RTN","CHM XG001",121 ,0)
  34410    ..S CHREC ="F005",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSF(F,1) =CHDTSTR
  34411   "RTN","CHM XG001",122 ,0)
  34412    ..S CHREC ="F010",CH COND=1 D ^ CHMXGU01 Q :$D(CHRTNQ T)  S ^CHM XCLSF(F,2) =CHDTSTR
  34413   "RTN","CHM XG001",123 ,0)
  34414    Q
  34415   "RTN","CHM XG001",124 ,0)
  34416    ;
  34417   "RTN","CHM XG001",125 ,0)
  34418   PULLER S V AR=CHFLREF _CHI
  34419   "RTN","CHM XG001",126 ,0)
  34420    Q:'$D(@(V AR_",101)" ))  K CHER R(CHLVLSUB )
  34421   "RTN","CHM XG001",127 ,0)
  34422    S CHJ=0
  34423   "RTN","CHM XG001",128 ,0)
  34424   PA1 S CHJ= $O(@(VAR_" ,101,CHJ)" )) Q:'CHJ
  34425   "RTN","CHM XG001",129 ,0)
  34426    G:'$D(@(V AR_",101,C HJ,0)")) P A1
  34427   "RTN","CHM XG001",130 ,0)
  34428    S CHERR(C HLVLSUB,CH J)=@(VAR_" ,101,CHJ,0 )")
  34429   "RTN","CHM XG001",131 ,0)
  34430    G PA1
  34431   "RTN","CHM XG001",132 ,0)
  34432    ;
  34433   "RTN","CHM XG001",133 ,0)
  34434   FILEPRB S  CHRTNRSN=1 2,CHRTNQT= "" Q
  34435   "RTN","CHM XG001",134 ,0)
  34436    ;
  34437   "RTN","CHM XPU04")
  34438   0^63^B3682 07416
  34439   "RTN","CHM XPU04",1,0 )
  34440   CHMXPU04 ; CVA/DTP;X1 2 837 READ  EDIT UTIL ITY #4 (HE ALTH CARE  CLAIMS);03 /10/98  1: 50 PM
  34441   "RTN","CHM XPU04",2,0 )
  34442    ;;1.0;CHA MPVA SYSTE M;**1,14** ;JULY 4, 1 990;Build  5
  34443   "RTN","CHM XPU04",3,0 )
  34444    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  34445   "RTN","CHM XPU04",4,0 )
  34446    ;;SPECIAL  EDITS FOR  837 RECOR D READ AT  CLAIM LEVE L
  34447   "RTN","CHM XPU04",5,0 )
  34448    ;;CALLED  INDIRECTLY  BY GENREA D^CHMXPU01 +15 (CHEDR TN IS DEFI NED), CHMX PU07
  34449   "RTN","CHM XPU04",6,0 )
  34450    ;;AJM DEV 5022 (04-J UN-08)
  34451   "RTN","CHM XPU04",7,0 )
  34452    ;;Methodi cal - Chan ged CHHCQL F= TO CHHC QLF[ in or der to han dle ICD-10  or ICD-9  qualifier
  34453   "RTN","CHM XPU04",8,0 )
  34454    ;;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
  34455   "RTN","CHM XPU04",9,0 )
  34456    ;;ICD-10  RCS -lg ad ded "BBQ": "i" to $CA SE stateme nt in case  BBQ not i n file 03/ 25/13
  34457   "RTN","CHM XPU04",10, 0)
  34458    ;;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
  34459   "RTN","CHM XPU04",11, 0)
  34460    ;; 2/1/20 16 DLB MER GED UPDATE S TO THE F ORMAT ROUT INE FRO IC D-9 DIAGNO SIS CODES.
  34461   "RTN","CHM XPU04",12, 0)
  34462    ;;CPE005- 038 AJF -  Original P DI found i n Ready Qu eue (Freq  code=8)
  34463   "RTN","CHM XPU04",13, 0)
  34464    ;;CPE005- 043 SS - T OB FC 8 Al l Claims L ines Not C omplete (F req code=8 )
  34465   "RTN","CHM XPU04",14, 0)
  34466    ;;CPE005- 042 AJF -  Original P DI in proc ess and al l claims i n process  (Freq code =8)
  34467   "RTN","CHM XPU04",15, 0)
  34468    ;;OTW 11/ 28/2017 CP E005-040 -  Reject if  Original  PDI Number  is null a nd Freq co de=5.
  34469   "RTN","CHM XPU04",16, 0)
  34470    ;;BDB 12/ 4/2017 CPE 005-039 -  Reject Fre quency Cod e 6
  34471   "RTN","CHM XPU04",17, 0)
  34472    ;;BDB 2/2 /2018 CPE0 05-042 - A ll claims  in process
  34473   "RTN","CHM XPU04",18, 0)
  34474    ;;TGH 2/1 5/2018 CPD 005-043 -  Discontinu e use of I CNVOID2
  34475   "RTN","CHM XPU04",19, 0)
  34476    ;;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 
  34477   "RTN","CHM XPU04",20, 0)
  34478    ;
  34479   "RTN","CHM XPU04",21, 0)
  34480   HCCDQ ;VAL IDATION OF  HEALTH CA RE CODE QU ALIFIER
  34481   "RTN","CHM XPU04",22, 0)
  34482    D DEBUG^C HMXDR01("C HMXPU04: H CCDQ CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  34483   "RTN","CHM XPU04",23, 0)
  34484    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  34485   "RTN","CHM XPU04",24, 0)
  34486    I '$D(^CH MXDIC(7412 01.1,"B",C HFLD(CHFLP N))) D  ;G  HCCDQ1
  34487   "RTN","CHM XPU04",25, 0)
  34488    . S CHHCQ LF="",CHSU B1=49,CHSU B2=1 D SET DTA
  34489   "RTN","CHM XPU04",26, 0)
  34490    . D DEBUG ^CHMXDR01( "CHMXPU04:  HCCDQ2 CH FLD(CHFLPN )= ",CHFLD (CHFLPN))
  34491   "RTN","CHM XPU04",27, 0)
  34492    . 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 
  34493   "RTN","CHM XPU04",28, 0)
  34494    . D RCDER R^CHMXPU01 :CHEDRJ'=" E100"
  34495   "RTN","CHM XPU04",29, 0)
  34496   HCCDQ1 Q
  34497   "RTN","CHM XPU04",30, 0)
  34498    ;
  34499   "RTN","CHM XPU04",31, 0)
  34500    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  34501   "RTN","CHM XPU04",32, 0)
  34502    ; THE HEA LTH CARE C ODE QUALIF IER VALIDA TION IS US ED FOR BOT H THE ICD- 9 AND ICD- 10 CODES.
  34503   "RTN","CHM XPU04",33, 0)
  34504    ; THE USE  OF THE "[ " (CONTAIN S) VS THE  "=" (EQUAL S) ALLOWS  THE TESTIN G OF THE 
  34505   "RTN","CHM XPU04",34, 0)
  34506    ; "BK,BJ, BF,etc" AN D "ABK,ABJ ,ABF,etc"  USING THIS  SAME FUNC TION.
  34507   "RTN","CHM XPU04",35, 0)
  34508    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  34509   "RTN","CHM XPU04",36, 0)
  34510    ;
  34511   "RTN","CHM XPU04",37, 0)
  34512   HCCDV ;VAL IDATION OF  HEALTH CA RE CODE (F ILE LOOKUP  DEPENDS U PON HC QUA LIFIER)
  34513   "RTN","CHM XPU04",38, 0)
  34514    Q:'$D(CHF LD(CHFLPN) )  ; Q:CHF LD(CHFLPN) ="" 
  34515   "RTN","CHM XPU04",39, 0)
  34516    D DEBUG^C HMXDR01("C HMXPU04: H CCDV ENTRY : CHFLD(CH FLPN)=",CH FLD(CHFLPN ))
  34517   "RTN","CHM XPU04",40, 0)
  34518    S CHDIF=3 ,CHEND=1
  34519   "RTN","CHM XPU04",41, 0)
  34520    D GTHCQLF  I $D(CHED PRB) S CHP RB="E40ZA"  G HCCDV1
  34521   "RTN","CHM XPU04",42, 0)
  34522    ;FOLLOWIN G WAS FE E DIT E40ZD  - AJM DEV5 022
  34523   "RTN","CHM XPU04",43, 0)
  34524    Q:CHHCQLF =""  I CHF LD(CHFLPN) ="" S CHSU B1=49,CHSU B2=1,CHEDR J="NONE" D  SETDTA G  HCCDV1
  34525   "RTN","CHM XPU04",44, 0)
  34526    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))
  34527   "RTN","CHM XPU04",45, 0)
  34528    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CCDV1
  34529   "RTN","CHM XPU04",46, 0)
  34530    I CHHCQLF ["BJ" D  G  HCCDV1
  34531   "RTN","CHM XPU04",47, 0)
  34532    .S JZ=3 D  STFRMT  ;  SET UP TH E FORMATTI NG FOR THE  CODES 
  34533   "RTN","CHM XPU04",48, 0)
  34534    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40Z B" D SETDT A
  34535   "RTN","CHM XPU04",49, 0)
  34536    .S CHSUB1 =42,CHSUB2 =1 D SETDT A Q
  34537   "RTN","CHM XPU04",50, 0)
  34538    I CHHCQLF ["BK" D  G  HCCDV1
  34539   "RTN","CHM XPU04",51, 0)
  34540    .S JZ=3 D  STFRMT
  34541   "RTN","CHM XPU04",52, 0)
  34542    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E401 a" D SETDT A
  34543   "RTN","CHM XPU04",53, 0)
  34544    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  34545   "RTN","CHM XPU04",54, 0)
  34546    .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
  34547   "RTN","CHM XPU04",55, 0)
  34548    .S CHSUB1 =40,CHSUB2 =1 D SETDT A K ZZTOS  Q
  34549   "RTN","CHM XPU04",56, 0)
  34550    I CHHCQLF ["BF" D  G  HCCDV1
  34551   "RTN","CHM XPU04",57, 0)
  34552    .S JZ=3 D  STFRMT
  34553   "RTN","CHM XPU04",58, 0)
  34554    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40J 1" D SETDT A
  34555   "RTN","CHM XPU04",59, 0)
  34556    .S CHSUB1 =40,CHSUB2 =1 D SETDT A Q
  34557   "RTN","CHM XPU04",60, 0)
  34558    I CHHCQLF ["BN" D  G  HCCDV1
  34559   "RTN","CHM XPU04",61, 0)
  34560    .S JZ=3 D  STFRMT
  34561   "RTN","CHM XPU04",62, 0)
  34562    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40Z C" D SETDT A
  34563   "RTN","CHM XPU04",63, 0)
  34564    .S CHSUB1 =40,CHSUB2 =1 D SETDT A Q
  34565   "RTN","CHM XPU04",64, 0)
  34566    I CHHCQLF ["ZZ" D  G  HCCDV1
  34567   "RTN","CHM XPU04",65, 0)
  34568    .S JZ=3 D  STFRMT
  34569   "RTN","CHM XPU04",66, 0)
  34570    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40J 1" D SETDT A
  34571   "RTN","CHM XPU04",67, 0)
  34572    .S CHSUB1 =46,CHSUB2 =1 D SETDT A Q
  34573   "RTN","CHM XPU04",68, 0)
  34574    I CHHCQLF ["BR" D  G  HCCDV1
  34575   "RTN","CHM XPU04",69, 0)
  34576    .I CHHCQL F="BR"  D   ; "BR" IS  AN ICD-9  PROCEDURE  QUALIFIER  IN "E100", "E105","E1 10" RECORD S
  34577   "RTN","CHM XPU04",70, 0)
  34578    ..S JZ=2  D STFRMT   ;ICD-10 RC S -lg
  34579   "RTN","CHM XPU04",71, 0)
  34580    .I '$D(^C HMSERV("BE ",CHFLD(CH FLPN)_"Z") ) S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E411a" D  SETDTA
  34581   "RTN","CHM XPU04",72, 0)
  34582    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  34583   "RTN","CHM XPU04",73, 0)
  34584    .;FOLLOWI NG WAS FE  EDIT E411b   - AJM DE V5022
  34585   "RTN","CHM XPU04",74, 0)
  34586    .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
  34587   "RTN","CHM XPU04",75, 0)
  34588    .S CHSUB1 =41,CHSUB2 =1 D SETDT A K ZZTOS  Q
  34589   "RTN","CHM XPU04",76, 0)
  34590    I CHHCQLF ["BP" D  G  HCCDV1
  34591   "RTN","CHM XPU04",77, 0)
  34592    .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
  34593   "RTN","CHM XPU04",78, 0)
  34594    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  34595   "RTN","CHM XPU04",79, 0)
  34596    .;FOLLOWI NG WAS FE  EDIT E411b  - AJM DEV 5022
  34597   "RTN","CHM XPU04",80, 0)
  34598    .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
  34599   "RTN","CHM XPU04",81, 0)
  34600    .S CHSUB1 =41,CHSUB2 =1 D SETDT A K ZZTOS  Q
  34601   "RTN","CHM XPU04",82, 0)
  34602    I CHHCQLF ["BQ" D  G  HCCDV1
  34603   "RTN","CHM XPU04",83, 0)
  34604    .I CHHCQL F="BQ"  D   ; "BQ" IS  THE ICD-9  PROCEDURE  QUALIFIER  IN "E100" ,"E105","E 110" RECOR DS 
  34605   "RTN","CHM XPU04",84, 0)
  34606    ..S JZ=2  D STFRMT ;  ICD-10 RC S lg
  34607   "RTN","CHM XPU04",85, 0)
  34608    .I '$D(^C HMSERV("BE ",CHFLD(CH FLPN)_"Z") ) S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E41J1" D  SETDTA
  34609   "RTN","CHM XPU04",86, 0)
  34610    .S CHSUB1 =41,CHSUB2 =1 D SETDT A Q
  34611   "RTN","CHM XPU04",87, 0)
  34612    I CHHCQLF ["BO" D  G  HCCDV1
  34613   "RTN","CHM XPU04",88, 0)
  34614    .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
  34615   "RTN","CHM XPU04",89, 0)
  34616    .S CHSUB1 =41,CHSUB2 =1 D SETDT A Q
  34617   "RTN","CHM XPU04",90, 0)
  34618    ;Methodic al-5010 Ch ange-Begin  - Added c ode for PR  qualifier  check - P atient Rea son for Vi sit
  34619   "RTN","CHM XPU04",91, 0)
  34620    I CHHCQLF ["PR" D  G  HCCDV1
  34621   "RTN","CHM XPU04",92, 0)
  34622    .S JZ=3 D  STFRMT
  34623   "RTN","CHM XPU04",93, 0)
  34624    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E46b " D SETDTA
  34625   "RTN","CHM XPU04",94, 0)
  34626    .S CHSUB1 =46,CHSUB2 =1 D SETDT A Q
  34627   "RTN","CHM XPU04",95, 0)
  34628    ;Methodic al-5010 Ch ange-End
  34629   "RTN","CHM XPU04",96, 0)
  34630    I CHHCQLF ["BE" D  G  HCCDV1
  34631   "RTN","CHM XPU04",97, 0)
  34632    .I '$D(^C HMXDIC(741 201.4,"B", CHFLD(CHFL PN))) S CH SUB1=49,CH SUB2=1,CHE DRJ="E45a"  D SETDTA
  34633   "RTN","CHM XPU04",98, 0)
  34634    .S CHSUB1 =45,CHSUB2 =1 D SETDT A Q
  34635   "RTN","CHM XPU04",99, 0)
  34636    I CHHCQLF ["BG" D  G  HCCDV1
  34637   "RTN","CHM XPU04",100 ,0)
  34638    .I '$D(^C HMXDIC(741 201.41,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E44a " D SETDTA
  34639   "RTN","CHM XPU04",101 ,0)
  34640    .S CHSUB1 =44,CHSUB2 =1 D SETDT A Q
  34641   "RTN","CHM XPU04",102 ,0)
  34642    I CHHCQLF ["BH" D  G  HCCDV1
  34643   "RTN","CHM XPU04",103 ,0)
  34644    .I '$D(^C HMXDIC(741 201.42,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E43a " D SETDTA
  34645   "RTN","CHM XPU04",104 ,0)
  34646    .S CHSUB1 =43,CHSUB2 =1 D SETDT A Q
  34647   "RTN","CHM XPU04",105 ,0)
  34648    I CHHCQLF ["BI" D  G  HCCDV1
  34649   "RTN","CHM XPU04",106 ,0)
  34650    .I '$D(^C HMXDIC(741 201.43,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E43b " D SETDTA
  34651   "RTN","CHM XPU04",107 ,0)
  34652    .S CHSUB1 =43,CHSUB2 =1 D SETDT A Q
  34653   "RTN","CHM XPU04",108 ,0)
  34654    I CHHCQLF ["TC" D  G  HCCDV1
  34655   "RTN","CHM XPU04",109 ,0)
  34656    .D STTC ;  FORMAT "T C" CODES I F NEEDED
  34657   "RTN","CHM XPU04",110 ,0)
  34658    .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
  34659   "RTN","CHM XPU04",111 ,0)
  34660    .;S CHSUB 1=48,CHSUB 2=1 D SETD TA Q  ; CO ULD SET IN TO NODE 48  IF DESIRE D
  34661   "RTN","CHM XPU04",112 ,0)
  34662    I CHHCQLF ["DR" D  G  HCCDV1
  34663   "RTN","CHM XPU04",113 ,0)
  34664    .Q
  34665   "RTN","CHM XPU04",114 ,0)
  34666    .D STDR ;  FORMAT "D R" CODES I F NEEDED
  34667   "RTN","CHM XPU04",115 ,0)
  34668    .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
  34669   "RTN","CHM XPU04",116 ,0)
  34670    .S CHSUB1 =47,CHSUB2 =1 D SETDT A Q  ; COU LD SET INT O NODE 47  IF DESIRED
  34671   "RTN","CHM XPU04",117 ,0)
  34672   HCCDV1 K C HHCQLF,CHD IF,CHEND Q
  34673   "RTN","CHM XPU04",118 ,0)
  34674    ; 
  34675   "RTN","CHM XPU04",119 ,0)
  34676   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)
  34677   "RTN","CHM XPU04",120 ,0)
  34678    S:CHX12VR S=1 CHDIF= 13,CHEND=1 1
  34679   "RTN","CHM XPU04",121 ,0)
  34680    S:CHX12VR S=2 CHDIF= 18,CHEND=1 6
  34681   "RTN","CHM XPU04",122 ,0)
  34682    ;Methodic al-5010 Ch ange-Begin
  34683   "RTN","CHM XPU04",123 ,0)
  34684    S:CHX12VR S=3 CHDIF= 34,CHEND=3 2
  34685   "RTN","CHM XPU04",124 ,0)
  34686    ;Methodic al-5010 Ch ange-End
  34687   "RTN","CHM XPU04",125 ,0)
  34688    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTV1
  34689   "RTN","CHM XPU04",126 ,0)
  34690    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTV1
  34691   "RTN","CHM XPU04",127 ,0)
  34692    I (CHHCQL F["BR")!(C HHCQLF["BP ") D  G HC DTV1
  34693   "RTN","CHM XPU04",128 ,0)
  34694    .;I CHFLD (CHFLPN)=" " S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E412a" D  SETDTA Q
  34695   "RTN","CHM XPU04",129 ,0)
  34696    .;S CHDTF L=1 D 201^ CHMXPU01 K  CHDTFL I  Y=-1 S CHS UB1=49,CHS UB2=1,CHED RJ="E412a"  D SETDTA
  34697   "RTN","CHM XPU04",130 ,0)
  34698    .S CHSUB1 =41,CHSUB2 =2 D SETDT A Q
  34699   "RTN","CHM XPU04",131 ,0)
  34700    I (CHHCQL F["BQ")!(C HHCQLF["BO ") D  G HC DTV1
  34701   "RTN","CHM XPU04",132 ,0)
  34702    .;FOLLOWI NG WAS FE  EDIT E41J2 a - AJM DE V5022
  34703   "RTN","CHM XPU04",133 ,0)
  34704    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  34705   "RTN","CHM XPU04",134 ,0)
  34706    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="E41J2a"  D SETDTA
  34707   "RTN","CHM XPU04",135 ,0)
  34708    .S CHSUB1 =41,CHSUB2 =2 D SETDT A Q
  34709   "RTN","CHM XPU04",136 ,0)
  34710    I (CHHCQL F["BH")!(C HHCQLF["BI ") D  G HC DTV1
  34711   "RTN","CHM XPU04",137 ,0)
  34712    .;FOLLOWI NG WAS FE  EDIT E431a  - AJM DEV 5022
  34713   "RTN","CHM XPU04",138 ,0)
  34714    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  34715   "RTN","CHM XPU04",139 ,0)
  34716    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="E431a"  D SETDTA
  34717   "RTN","CHM XPU04",140 ,0)
  34718    .S CHSUB1 =43,CHSUB2 =2 D SETDT A Q
  34719   "RTN","CHM XPU04",141 ,0)
  34720   HCDTV1 K C HHCQLF,CHD IF,CHEND Q
  34721   "RTN","CHM XPU04",142 ,0)
  34722    ; 
  34723   "RTN","CHM XPU04",143 ,0)
  34724   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)
  34725   "RTN","CHM XPU04",144 ,0)
  34726    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  34727   "RTN","CHM XPU04",145 ,0)
  34728    S:CHX12VR S=1 CHDIF= 13,CHEND=1 1
  34729   "RTN","CHM XPU04",146 ,0)
  34730    S:CHX12VR S=2 CHDIF= 18,CHEND=1 6
  34731   "RTN","CHM XPU04",147 ,0)
  34732    ;Methodic al-5010 Ch ange-Begin
  34733   "RTN","CHM XPU04",148 ,0)
  34734    S:CHX12VR S=3 CHDIF= 34,CHEND=3 2
  34735   "RTN","CHM XPU04",149 ,0)
  34736    ;Methodic al-5010 Ch ange-End
  34737   "RTN","CHM XPU04",150 ,0)
  34738    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E4OZA"  G HCDTF1
  34739   "RTN","CHM XPU04",151 ,0)
  34740    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTF1
  34741   "RTN","CHM XPU04",152 ,0)
  34742    I (CHHCQL F["BR")!(C HHCQLF["BP ") D  G HC DTF1
  34743   "RTN","CHM XPU04",153 ,0)
  34744    .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
  34745   "RTN","CHM XPU04",154 ,0)
  34746    I (CHHCQL F["BQ")!(C HHCQLF["BO ") D  G HC DTF1
  34747   "RTN","CHM XPU04",155 ,0)
  34748    .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
  34749   "RTN","CHM XPU04",156 ,0)
  34750    .;I (CHHC QLF="BH")! (CHHCQLF=" BI") D  G: CHHCQLF="B H" HCDTF1
  34751   "RTN","CHM XPU04",157 ,0)
  34752    .;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
  34753   "RTN","CHM XPU04",158 ,0)
  34754    I CHHCQLF ["BI" D  G  HCDTF1
  34755   "RTN","CHM XPU04",159 ,0)
  34756    .;FOLLOWI NG WAS FE  EDIT E431b  - AJM DEV 5022
  34757   "RTN","CHM XPU04",160 ,0)
  34758    .S CHDIF= -8,CHEND=- 15 D GETHR DT Q:'$D(C HTHRDT)  Q :CHTHRDT=" "  I $D(CH EDPRB) S C HPRB="NONE " G HCDTF1
  34759   "RTN","CHM XPU04",161 ,0)
  34760    .;FOLLOWI NG WAS FE  EDIT E431b  - AJM DEV 5022
  34761   "RTN","CHM XPU04",162 ,0)
  34762    .I CHTHRD T'>CHFLD(C HFLPN) S C HSUB1=49,C HSUB2=1,CH EDRJ="NONE " D SETDTA  Q
  34763   "RTN","CHM XPU04",163 ,0)
  34764   HCDTF1 K C HHCQLF,CHD IF,CHEND,C HTHRDT Q
  34765   "RTN","CHM XPU04",164 ,0)
  34766    ; 
  34767   "RTN","CHM XPU04",165 ,0)
  34768   HCDTV2 ;HE ALTH CARE  CODE DATE2  (OCC SPAN  ONLY) MUS T BE PRESE NT/VALID F OR "BI"
  34769   "RTN","CHM XPU04",166 ,0)
  34770    S:CHX12VR S=1 CHDIF= 21,CHEND=1 9
  34771   "RTN","CHM XPU04",167 ,0)
  34772    S:CHX12VR S=2 CHDIF= 26,CHEND=2 4
  34773   "RTN","CHM XPU04",168 ,0)
  34774    ;Methodic al-5010 Ch ange-End
  34775   "RTN","CHM XPU04",169 ,0)
  34776    S:CHX12VR S=3 CHDIF= 42,CHEND=4 0
  34777   "RTN","CHM XPU04",170 ,0)
  34778    ;Methodic al-5010 Ch ange-End
  34779   "RTN","CHM XPU04",171 ,0)
  34780    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTV21
  34781   "RTN","CHM XPU04",172 ,0)
  34782    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTV21
  34783   "RTN","CHM XPU04",173 ,0)
  34784    I CHHCQLF ["BI" D  G  HCDTV21
  34785   "RTN","CHM XPU04",174 ,0)
  34786    .;FOLLOWI NG WAS FE  EDIT E432a  - AJM DEV 5022
  34787   "RTN","CHM XPU04",175 ,0)
  34788    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  34789   "RTN","CHM XPU04",176 ,0)
  34790    .;FOLLOWI NG WAS FE  EDIT E432a  - AJM DEV 5022
  34791   "RTN","CHM XPU04",177 ,0)
  34792    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="NONE" D  SETDTA
  34793   "RTN","CHM XPU04",178 ,0)
  34794    .S CHSUB1 =43,CHSUB2 =3 D SETDT A Q
  34795   "RTN","CHM XPU04",179 ,0)
  34796   HCDTV21 K  CHHCQLF,CH DIF,CHEND  Q
  34797   "RTN","CHM XPU04",180 ,0)
  34798    ; 
  34799   "RTN","CHM XPU04",181 ,0)
  34800   HCDTF2 ;HE ALTH CARE  CODE DATE  MUST NOT B E FUTURE F OR OCC SPA N THRU DAT E ("BI")
  34801   "RTN","CHM XPU04",182 ,0)
  34802    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  34803   "RTN","CHM XPU04",183 ,0)
  34804    S:CHX12VR S=1 CHDIF= 21,CHEND=1 9
  34805   "RTN","CHM XPU04",184 ,0)
  34806    S:CHX12VR S=2 CHDIF= 26,CHEND=2 4
  34807   "RTN","CHM XPU04",185 ,0)
  34808    S:CHX12VR S=3 CHDIF= 42,CHEND=4 0
  34809   "RTN","CHM XPU04",186 ,0)
  34810    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTF21
  34811   "RTN","CHM XPU04",187 ,0)
  34812    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTF21
  34813   "RTN","CHM XPU04",188 ,0)
  34814    I CHHCQLF ["BI" D  G  HCDTF21
  34815   "RTN","CHM XPU04",189 ,0)
  34816    .;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
  34817   "RTN","CHM XPU04",190 ,0)
  34818    .S CHDIF= 8,CHEND=1  D GETODT Q :'$D(CHTOD T)  Q:CHTO DT=""  I $ D(CHEDPRB)  S CHPRB=" E432b" Q
  34819   "RTN","CHM XPU04",191 ,0)
  34820    .;FOLLOWI NG WAS FE  EDIT E432b  - AJM DEV 5022
  34821   "RTN","CHM XPU04",192 ,0)
  34822    .I CHTODT '<CHFLD(CH FLPN) S CH SUB1=49,CH SUB2=1,CHE DRJ="NONE"  Q
  34823   "RTN","CHM XPU04",193 ,0)
  34824   HCDTF21 K  GETODT,CHH CQLF,CHDIF ,CHEND Q
  34825   "RTN","CHM XPU04",194 ,0)
  34826    ;
  34827   "RTN","CHM XPU04",195 ,0)
  34828     ;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  34829   "RTN","CHM XPU04",196 ,0)
  34830    ; DIAGNOS IS CODE DA TE OF SERV ICE VS ICD  CODE ACTI VE DATES C HECK FOR I NSTITUTION AL CLAIMS.
  34831   "RTN","CHM XPU04",197 ,0)
  34832    ; INSTITU TIONAL CLA IMS LOAD I NTO THE ^C HMXCLE() B UFFER, AND  THE DATE  OF SERVICE  IS REQUIR ED
  34833   "RTN","CHM XPU04",198 ,0)
  34834    ; IN LOOP  2300, WHI CH TRANSLA TES TO THE  "E005" FL AT FILE RE CORD.
  34835   "RTN","CHM XPU04",199 ,0)
  34836    ; FOR ICD -10 THERE  NEEDS TO B E A REAL T IME CHECK  FOR THE AC TIVE ICD-9 /ICD-10 DI AG CODES 
  34837   "RTN","CHM XPU04",200 ,0)
  34838    ; AGAINST  THE DATE  OF SERVICE . THIS FUN CTION WILL  PERFORM T HE CHECK A S PART OF  THE FRONT 
  34839   "RTN","CHM XPU04",201 ,0)
  34840    ; END EDI TS SO THE  CLAIM CAN  BE REJECTE D AND REPO RTED ON TH E CSTAT (U NSOLICITED  STATUS) R EPORT.
  34841   "RTN","CHM XPU04",202 ,0)
  34842    ; THE REJ ECT LOGIC  FOR THE IC D-9/ICD-10  DIAGNOSTI C CODES:
  34843   "RTN","CHM XPU04",203 ,0)
  34844    ; 1) IF D IAG CODE C ANNOT BE C ROSS-REFER ENCED (^CH MICDX("C", DIAG CODE, I), CLAIM  WILL BE RE JECTED
  34845   "RTN","CHM XPU04",204 ,0)
  34846    ; 2) IF T HE DATE OF  SERVICE ( STATEMENT  "TO" DATE)  IS NOT PO PULATED (^ CHMXCLE(CH CLEI,1),"^ ",2)) THE
  34847   "RTN","CHM XPU04",205 ,0)
  34848    ; INSTITU TIONAL CLA IM WILL BE  REJECTED.
  34849   "RTN","CHM XPU04",206 ,0)
  34850    ; 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
  34851   "RTN","CHM XPU04",207 ,0)
  34852    ; 4) IF I CD-10 CODE  TERMINATI ON DATE IS  BLANK, CH ECK AGAINS T ICD-10 " EFFECTIVE"  DATE ONLY . IF THE D OS
  34853   "RTN","CHM XPU04",208 ,0)
  34854    ; IS BEFO RE THE "EF FECTIVE" D ATE, THE C LAIM WILL  BE REJECTE D.
  34855   "RTN","CHM XPU04",209 ,0)
  34856    ; 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 
  34857   "RTN","CHM XPU04",210 ,0)
  34858    ; ^CHMICD X(I,0), FI ELD 22: EF FECTIVE DA TE AND ^CH MICDX(I,0) , FIELD 23 : TERMINAT ION DATE)  FOR THE 
  34859   "RTN","CHM XPU04",211 ,0)
  34860    ; DIAG CO DE. IF THE  DOS FALLS  OUTSIDE T HESE DATES , THE CLAI M WILL BE  REJECTED
  34861   "RTN","CHM XPU04",212 ,0)
  34862    ; 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) 
  34863   "RTN","CHM XPU04",213 ,0)
  34864    ; IF THE  DOS IS AFT ER THE TER MINATION D ATE, THE C LAIM WILL  BE REJECTE D.
  34865   "RTN","CHM XPU04",214 ,0)
  34866    ; NOTE: I N ORDER TO  VALIDATE  BOTH ICD-9  AND ICD-1 0 QUALIFIE RS IN THIS  FUNCTION,  ("BK" VS  "ABK", ETC .)
  34867   "RTN","CHM XPU04",215 ,0)
  34868    ; THE TES TING LOGIC  CANNOT US E THE "["  (CONTAINS)  OPERAND,  BECAUSE TH E FORMATTI NG FOR THE  
  34869   "RTN","CHM XPU04",216 ,0)
  34870    ; DIAGNOS TIC CODE I S DIFFEREN T BETWEEN  THE ICD-9  AND ICD-10  CODES.
  34871   "RTN","CHM XPU04",217 ,0)
  34872    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  34873   "RTN","CHM XPU04",218 ,0)
  34874    ; 
  34875   "RTN","CHM XPU04",219 ,0)
  34876   DXQUAL   ; CHECKS FOR  INSTITUTI ONAL CLAIM  DX CODES  PROVIDED ( PROF/DENTA L DIAG COD ES ARE IN  SVC LINES)
  34877   "RTN","CHM XPU04",220 ,0)
  34878    N JZ
  34879   "RTN","CHM XPU04",221 ,0)
  34880    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHMXPU 04: DXQUAL : DIAG COD E= ",CHFLD (CHFLPN)
  34881   "RTN","CHM XPU04",222 ,0)
  34882    Q:'$D(CHF LD(CHFLPN) )
  34883   "RTN","CHM XPU04",223 ,0)
  34884    S CHDIF=3 ,CHEND=1,C HSUB2=1,CH EDRJ="NONE "
  34885   "RTN","CHM XPU04",224 ,0)
  34886    D GTHCQLF  I $D(CHED PRB) S CHP RB="E40ZA"  G XDXQUAL                  ; CO DE QUALIFI ER
  34887   "RTN","CHM XPU04",225 ,0)
  34888    D DEBUG^C HMXDR01("  PU04:DXQUA L: QUALIFI ER: "_CHHC QLF_" DIAG  CODE= "_C HFLD(CHFLP N)_" CLMTY PE=",$$CLM TYPE^CHMXP 010())
  34889   "RTN","CHM XPU04",226 ,0)
  34890    Q:CHHCQLF =""                                                         ; EXI T IF NO QU ALIFIER
  34891   "RTN","CHM XPU04",227 ,0)
  34892    Q:(CHHCQL F'["BJ")&( CHHCQLF'[" BK")&(CHHC QLF'["BF") &(CHHCQLF' ["BN")&(CH HCQLF'["PR ")&(CHHCQL F'["ZZ")   ;VALID QUA LIFIERS
  34893   "RTN","CHM XPU04",228 ,0)
  34894    I CHFLD(C HFLPN)=""  S CHSUB1=4 9 D SETDTA  G XDXQUAL
  34895   "RTN","CHM XPU04",229 ,0)
  34896    S JZ=0 ;  ASSUME DIA G CODE IS  FORMATTED  ALREADY
  34897   "RTN","CHM XPU04",230 ,0)
  34898    I ($E(CHH CQLF,1,1)= "A")!(CHHC QLF="BBQ") !(CHHCQLF= "BBR") D       ; ICD- 10 QUALIFI ERS 
  34899   "RTN","CHM XPU04",231 ,0)
  34900    .I CHFLD( CHFLPN)'[" ." D                                             ; IF  NOT FORMAT TED, FORMA T THE DIAG  CODE
  34901   "RTN","CHM XPU04",232 ,0)
  34902    ..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 
  34903   "RTN","CHM XPU04",233 ,0)
  34904    E  D                                                                  ; ICD -9 QUALIFI ERS
  34905   "RTN","CHM XPU04",234 ,0)
  34906    .I CHFLD( CHFLPN)'[" ." D                                             ; IF  NOT FORMAT TED, FORMA T THE DIAG  CODE
  34907   "RTN","CHM XPU04",235 ,0)
  34908    ..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 
  34909   "RTN","CHM XPU04",236 ,0)
  34910    D:JZ STFR MT                                                          ; IF  ALREADY FO RMATTED, S KIP DIAG C ODE FORMAT TING
  34911   "RTN","CHM XPU04",237 ,0)
  34912    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"DXQUAL : FORMATTE D DIAG COD E= ",CHFLD (CHFLPN)
  34913   "RTN","CHM XPU04",238 ,0)
  34914    I '$D(^CH MICDX("C", CHFLD(CHFL PN))) D  Q                            ; DIA GNOSIS COD E NOT CROS S-REFERENC ED, REJECT
  34915   "RTN","CHM XPU04",239 ,0)
  34916    .D DEBUG^ CHMXDR01(" *****DXQUA L^CHMXPU04 : DIAG COD E "_CHFLD( CHFLPN)_",  NOT CROSS -REFERENCE D.","")
  34917   "RTN","CHM XPU04",240 ,0)
  34918    .S CHEDRJ ="E401a" D  RCDERR^CH MXPU01
  34919   "RTN","CHM XPU04",241 ,0)
  34920    N DICI S  DICI=0,DIC I=$O(^CHMI CDX("C",CH FLD(CHFLPN ),DICI)) ;  DIAGNOSIS  CODE INDE X FOR ^CHM ICDX()
  34921   "RTN","CHM XPU04",242 ,0)
  34922    S DOS=$$G ETDOS() ;  DOS IS DET ERMINED DI FFERENTLY  FOR I/P/D  CLAIM TYPE S
  34923   "RTN","CHM XPU04",243 ,0)
  34924    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))
  34925   "RTN","CHM XPU04",244 ,0)
  34926    I DOS'=""   D                                                         ; IF  WE HAVE A  VALID DOS,  COMPARE A GAINST ICD X DATES
  34927   "RTN","CHM XPU04",245 ,0)
  34928    .I $P(^CH MICDX(DICI ,0),"^",24 ) D                                  ; IF I CD-10 FLAG  IS SET
  34929   "RTN","CHM XPU04",246 ,0)
  34930    ..I $P(^C HMICDX(DIC I,0),"^",2 3)=""  D                              ; NO  TERMINATIO N DATE
  34931   "RTN","CHM XPU04",247 ,0)
  34932    ...I DOS< $P(^CHMICD X(DICI,0), "^",22) D                            ; CHEC K EFFECTIV E DATE AGA INST DOS
  34933   "RTN","CHM XPU04",248 ,0)
  34934    ....D DEB UG^CHMXDR0 1(" DXQUAL ^CHMXPU04  DOS: "_DOS _" BEFORE  ICD-10 EFF ECTIVE DAT E:",$P(^CH MICDX(DICI ,0),"^",22 ))
  34935   "RTN","CHM XPU04",249 ,0)
  34936    ....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
  34937   "RTN","CHM XPU04",250 ,0)
  34938    ..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
  34939   "RTN","CHM XPU04",251 ,0)
  34940    ...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))
  34941   "RTN","CHM XPU04",252 ,0)
  34942    ...S CHED RJ="E41J2a " D RCDERR ^CHMXPU01  ; SET EARL Y REJECT I CD-10 DIAG  OUTSIDE E FF/TERM DA TES
  34943   "RTN","CHM XPU04",253 ,0)
  34944    .E  D                                                                ; CODE  IS ICD-9  DIAG CODE
  34945   "RTN","CHM XPU04",254 ,0)
  34946    ..I DOS>$ P(^CHMICDX (DICI,0)," ^",23) D                            ; CHECK  SVC "TO"  DATE AGAIN ST ICD-9 T ERMINATION  DATE
  34947   "RTN","CHM XPU04",255 ,0)
  34948    ...D DEBU G^CHMXDR01 (" DXQUAL^ CHMXPU04 D OS: "_DOS_ " AFTER IC D-9 TERM D ATE:",$P(^ CHMICDX(DI CI,0),"^", 23))
  34949   "RTN","CHM XPU04",256 ,0)
  34950    ...S CHED RJ="E41J2a " D RCDERR ^CHMXPU01  ; SET EARL Y REJECT,  ICD-9 DOS  AFTER TERM NATION DAT E
  34951   "RTN","CHM XPU04",257 ,0)
  34952    E  D
  34953   "RTN","CHM XPU04",258 ,0)
  34954    .I ($$CLM TYPE^CHMXP 010()="A") &(CHXREC[" E") D                       ; "A "=INST,"B" =PROF,C=DN TL
  34955   "RTN","CHM XPU04",259 ,0)
  34956    ..D DEBUG ^CHMXDR01( " DXQUAL^C HMXPU04 IN VALID DOS:  ",DOS)
  34957   "RTN","CHM XPU04",260 ,0)
  34958    ..S CHEDR J="E401a"  D RCDERR^C HMXPU01 ;  SET EARLY  REJECT, IN VALID DOS
  34959   "RTN","CHM XPU04",261 ,0)
  34960   XDXQUAL  K  CHHCQLF,C HDIF,CHEND  Q
  34961   "RTN","CHM XPU04",262 ,0)
  34962    ;
  34963   "RTN","CHM XPU04",263 ,0)
  34964    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  34965   "RTN","CHM XPU04",264 ,0)
  34966    ; GET THE  DATE OF S ERVICE. IF  CLAIM LEV EL RECORDS , GET FROM  ^CHMXCLE;  
  34967   "RTN","CHM XPU04",265 ,0)
  34968    ; OTHERWI SE GET IT  FROM ^CHMX CLF
  34969   "RTN","CHM XPU04",266 ,0)
  34970    ; DETERMI NE IF CLAI M LEVEL OR  LINE LEVE L BY CHXRE C VALUE (" EXXX" VS " FXXX")
  34971   "RTN","CHM XPU04",267 ,0)
  34972    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  34973   "RTN","CHM XPU04",268 ,0)
  34974    ;
  34975   "RTN","CHM XPU04",269 ,0)
  34976   GETDOS()   ;
  34977   "RTN","CHM XPU04",270 ,0)
  34978    N CLMTYPE ,DOS,ERR,C HCLFI
  34979   "RTN","CHM XPU04",271 ,0)
  34980    S DOS="", ERR=0
  34981   "RTN","CHM XPU04",272 ,0)
  34982    S CLMTYPE =$$CLMTYPE ^CHMXP010( ) ; "A"=IN ST,"B"=PRO F,C=DNTL
  34983   "RTN","CHM XPU04",273 ,0)
  34984    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CLAIM  TYPE= ",CL MTYPE
  34985   "RTN","CHM XPU04",274 ,0)
  34986    I CLMTYPE ="A"  D
  34987   "RTN","CHM XPU04",275 ,0)
  34988    .I '$D(^C HMXCLE(CHC LEI)) D  Q                                       ; NEE D TO GET T HE DOS; IF  NO CLAIM  INDEX, REJ ECT
  34989   "RTN","CHM XPU04",276 ,0)
  34990    ..S ERR=1
  34991   "RTN","CHM XPU04",277 ,0)
  34992    ..U 0 W:$ $ENVIR^CHT FLIB'="LIV E" !,"NO ^ CHMXCLE(", CHCLEI,")  NODE"
  34993   "RTN","CHM XPU04",278 ,0)
  34994    .I $P(^CH MXCLE(CHCL EI,1),"^", 2)=""  D   Q
  34995   "RTN","CHM XPU04",279 ,0)
  34996    ..S ERR=1
  34997   "RTN","CHM XPU04",280 ,0)
  34998    ..U 0 W:$ $ENVIR^CHT FLIB'="LIV E" !,"NO S TATEMENT " "TO"" DATE  ENTRY @^C HMXCLE(",C HCLEI,",1) ,""^"",2)"
  34999   "RTN","CHM XPU04",281 ,0)
  35000    .S:'ERR D OS=$P(^CHM XCLE(CHCLE I,1),"^",2 ) ; STATEM ENT DATE F OR INSTITU TIONAL CLA IM
  35001   "RTN","CHM XPU04",282 ,0)
  35002    .S DOS=$$ YR8FMYR^CH TFLIB(DOS)  ; ^CHMXCL E() STORES  DOS AS YY YYMMDD, ^C HMICDX() S TORES AS F M DATE
  35003   "RTN","CHM XPU04",283 ,0)
  35004    E  D
  35005   "RTN","CHM XPU04",284 ,0)
  35006    .U 0 W:$$ ENVIR^CHTF LIB'="LIVE " !,"CHMXP U04: GETDO S: CHCLEI=  ",CHCLEI, " $D(^CHMX CLF(""B"", ",CHCLEI," )= ",$D(^C HMXCLF("B" ,CHCLEI))
  35007   "RTN","CHM XPU04",285 ,0)
  35008    .I CHXREC ["E"  D  Q
  35009   "RTN","CHM XPU04",286 ,0)
  35010    ..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."
  35011   "RTN","CHM XPU04",287 ,0)
  35012    .E  I CHX REC["F"  D
  35013   "RTN","CHM XPU04",288 ,0)
  35014    ..I '$D(^ CHMXCLF("B ",CHCLEI))  D  Q                               ; VERIF Y ^CHMXCLF  CROSS-REF ERENCE
  35015   "RTN","CHM XPU04",289 ,0)
  35016    ...S ERR= 1
  35017   "RTN","CHM XPU04",290 ,0)
  35018    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  ^CHMXCLF(" "B"",",CHC LEI,"(^CHM XCLE()INDE X)) XREF"
  35019   "RTN","CHM XPU04",291 ,0)
  35020    ..S CHCLF I=0,CHCLFI =$O(^CHMXC LF("B",CHC LEI,CHCLFI )) ; GET T HE ^CHMXCL F INDEX
  35021   "RTN","CHM XPU04",292 ,0)
  35022    ..I '$D(^ CHMXCLF(CH CLFI,1)) D   Q
  35023   "RTN","CHM XPU04",293 ,0)
  35024    ...S ERR= 1
  35025   "RTN","CHM XPU04",294 ,0)
  35026    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  ^CHMXCLF(" ,CHCLFI,", 1) NODE"              ; CHECK TH E DOS NODE
  35027   "RTN","CHM XPU04",295 ,0)
  35028    ..I ($P(^ CHMXCLF(CH CLFI,1),"^ ",12)="")& ($P(^CHMXC LF(CHCLFI, 1),"^",11) ="") D
  35029   "RTN","CHM XPU04",296 ,0)
  35030    ...S ERR= 1
  35031   "RTN","CHM XPU04",297 ,0)
  35032    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  STATEMENT  ""FROM/TO" " DATES @^ CHMXCLF(", CHCLFI,",1 ),""^"",11 /12)"
  35033   "RTN","CHM XPU04",298 ,0)
  35034    ..I 'ERR   D
  35035   "RTN","CHM XPU04",299 ,0)
  35036    ...S DOS= $P(^CHMXCL F(CHCLFI,1 ),"^",12)  ; SERVICE  LINE STATE MENT "TO"  DATE
  35037   "RTN","CHM XPU04",300 ,0)
  35038    ...S:DOS= "" DOS=$P( ^CHMXCLF(C HCLFI,1)," ^",11) ; S ERVICE LIN E STATEMEN T "FROM" D ATE
  35039   "RTN","CHM XPU04",301 ,0)
  35040    ...S DOS= $$YR8FMYR^ CHTFLIB(DO S) ; SVC L INE STORES  DOS AS YY YYMMDD, ^C HMICDX() S TORES AS F M DATE
  35041   "RTN","CHM XPU04",302 ,0)
  35042    Q DOS
  35043   "RTN","CHM XPU04",303 ,0)
  35044    ; 
  35045   "RTN","CHM XPU04",304 ,0)
  35046    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  35047   "RTN","CHM XPU04",305 ,0)
  35048    ; THE FOL LOWING COD E WAS DISA BLED FOR 5 010 IMPLEM ENTATION
  35049   "RTN","CHM XPU04",306 ,0)
  35050    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  35051   "RTN","CHM XPU04",307 ,0)
  35052    ;
  35053   "RTN","CHM XPU04",308 ,0)
  35054   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
  35055   "RTN","CHM XPU04",309 ,0)
  35056    Q
  35057   "RTN","CHM XPU04",310 ,0)
  35058    ;INFERS A DM DX FROM  PRINCIPAL  DX IF NO  ADM DX COD E
  35059   "RTN","CHM XPU04",311 ,0)
  35060    D DEBUG^C HMXDR01("C HMXPU04: P DXCD CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  35061   "RTN","CHM XPU04",312 ,0)
  35062    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)
  35063   "RTN","CHM XPU04",313 ,0)
  35064    I ZZTOS'= "" I ($P(^ CHMXCLE(CH CLEI,0),"^ ",5)="A")& ($D(^CHMXD IC(741201. 03,"D",1,Z ZTOS))) D   G PDXCD1
  35065   "RTN","CHM XPU04",314 ,0)
  35066    .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
  35067   "RTN","CHM XPU04",315 ,0)
  35068    .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
  35069   "RTN","CHM XPU04",316 ,0)
  35070    .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
  35071   "RTN","CHM XPU04",317 ,0)
  35072    .I '$D(^C HMXCLE(CHC LEI,42)) D
  35073   "RTN","CHM XPU04",318 ,0)
  35074    ..S:'$D(^ CHMXCLE(CH CLEI,42,0) ) ^CHMXCLE (CHCLEI,42 ,0)="^7412 10.1242^0^ 0"
  35075   "RTN","CHM XPU04",319 ,0)
  35076    ..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
  35077   "RTN","CHM XPU04",320 ,0)
  35078    ..D DEBUG ^CHMXMDRV( "CHMXPU04:  PDXCD 'J'  = ",EI)
  35079   "RTN","CHM XPU04",321 ,0)
  35080    ..S $P(^C HMXCLE(CHC LEI,42,EI, 0),"^")=$P (^CHMXCLE( CHCLEI,40, 1,0),"^",1 )
  35081   "RTN","CHM XPU04",322 ,0)
  35082    ..S ^CHMX CLE(CHCLEI ,42,"B",$P (^CHMXCLE( CHCLEI,40, 1,0),"^"), EI)=""
  35083   "RTN","CHM XPU04",323 ,0)
  35084   PDXCD1 K C HCODE,ZZTO S Q
  35085   "RTN","CHM XPU04",324 ,0)
  35086    ; 
  35087   "RTN","CHM XPU04",325 ,0)
  35088   GTHCQLF I  '$D(RCD) S  CHEDPRB=" " G GTHCQL F1
  35089   "RTN","CHM XPU04",326 ,0)
  35090    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HHCQLF=$$T RIM^CHMXPU 01(Y)
  35091   "RTN","CHM XPU04",327 ,0)
  35092    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHMXPU 04: GTHCQL F():  CHHC QLF= ",CHH CQLF
  35093   "RTN","CHM XPU04",328 ,0)
  35094    ;I CHHCQL F="" S CHE DPRB="" Q
  35095   "RTN","CHM XPU04",329 ,0)
  35096   GTHCQLF1 K  Y Q
  35097   "RTN","CHM XPU04",330 ,0)
  35098    ;
  35099   "RTN","CHM XPU04",331 ,0)
  35100    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  35101   "RTN","CHM XPU04",332 ,0)
  35102    ; FORMAT  THE DIAGNO STIC CODES  FOR ICD-9  AND ICD-1 0
  35103   "RTN","CHM XPU04",333 ,0)
  35104    ; AT ENTR Y, CHFLD(C HFLPN) CON TAINS THE  DIAGNOSTIC  CODE TO B E FORMATTE D, AND "JZ "
  35105   "RTN","CHM XPU04",334 ,0)
  35106    ; CONTAIN S THE LOCA TION (FROM  THE LEFT)  AT WHICH  TO INSERT  THE "." FO R THE CODE
  35107   "RTN","CHM XPU04",335 ,0)
  35108    ; NOTE: W HEN THE DI AG CODES A RRIVE IN C HMXPU04, T HERE IS A  LEADING "E " IN 
  35109   "RTN","CHM XPU04",336 ,0)
  35110    ; CHFLD(C HFLPN). TH E "E" CODE  IS A SPEC IAL CASE F ROM OSHA(? ) THAT IS  DIFFERENT
  35111   "RTN","CHM XPU04",337 ,0)
  35112    ; FROM AL L OTHER DI AGNOSIS CO DES, THIS  CAUSES THE  $E(CHFLD( CHFLPN)) T O LOCATE T HE 
  35113   "RTN","CHM XPU04",338 ,0)
  35114    ; "." IN  A DIFFEREN T LOCATION  FOR THESE  DIAG CODE S. FOR THI S REASON,  THERE IS A
  35115   "RTN","CHM XPU04",339 ,0)
  35116    ; ADDER T O THE "JZ"  VALUE TO  CORRECTLY  LOCATE THE  DESIRED " ." IN THE  FORMAT. DL B 9/25/201 5
  35117   "RTN","CHM XPU04",340 ,0)
  35118    ; DEBUG F OR DEF0191 58; MODIFI ED THE LOG IC TO ENSU RE THE COR RECT FORMA TTING DLB  10/23/2015   
  35119   "RTN","CHM XPU04",341 ,0)
  35120    ; 2/1/201 6 FIX THE  FORMATTING  ISSUE FOR  "BK" 311  ICD-9 DIAG NOSIS CODE S
  35121   "RTN","CHM XPU04",342 ,0)
  35122    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  35123   "RTN","CHM XPU04",343 ,0)
  35124    ; 
  35125   "RTN","CHM XPU04",344 ,0)
  35126   STFRMT ;SE TS FORMAT  FOR DX/PX  CODES
  35127   "RTN","CHM XPU04",345 ,0)
  35128    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))
  35129   "RTN","CHM XPU04",346 ,0)
  35130    I $L(CHHC QLF)=2 D   ; ICD-9 CO DE QUALIFI ERS ARE 2  DIGITS
  35131   "RTN","CHM XPU04",347 ,0)
  35132    .I $E(CHF LD(CHFLPN) ,1,1)="E"   D  ; IF T HERE IS A  LEADING "E " FOR DIAG  CODE
  35133   "RTN","CHM XPU04",348 ,0)
  35134    ..S:$L(CH FLD(CHFLPN ))>JZ+1 CH FLD(CHFLPN )=$E(CHFLD (CHFLPN),1 ,JZ+1)_"." _$E(CHFLD( CHFLPN),JZ +2,99)
  35135   "RTN","CHM XPU04",349 ,0)
  35136    .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
  35137   "RTN","CHM XPU04",350 ,0)
  35138    .I (CHFLD (CHFLPN))[ "." D  ; E NSURE THER E IS A "."  IN THE CO DE BEFORE  GOING FORW ARD
  35139   "RTN","CHM XPU04",351 ,0)
  35140    ..I $P(CH FLD(CHFLPN ),".",2)=" " D                         ; IF  NO VALUES  AFTER THE  ".", NO " ." REQUIRE D
  35141   "RTN","CHM XPU04",352 ,0)
  35142    ...S CHFL PNLG=$L(CH FLD(CHFLPN )),CHFLD(C HFLPN)=$E( CHFLD(CHFL PN),1,CHFL PNLG-1)
  35143   "RTN","CHM XPU04",353 ,0)
  35144    ...K CHFL PNLG
  35145   "RTN","CHM XPU04",354 ,0)
  35146    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
  35147   "RTN","CHM XPU04",355 ,0)
  35148    D DEBUG^C HMXDR01("  CHMXPU04:  EXIT STFRM T(): CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  35149   "RTN","CHM XPU04",356 ,0)
  35150   STFRMT1 K  JZ Q
  35151   "RTN","CHM XPU04",357 ,0)
  35152    ;
  35153   "RTN","CHM XPU04",358 ,0)
  35154   STTC ;SETS  FORMAT FO R TC CODES
  35155   "RTN","CHM XPU04",359 ,0)
  35156    Q
  35157   "RTN","CHM XPU04",360 ,0)
  35158    ; 
  35159   "RTN","CHM XPU04",361 ,0)
  35160   STDR ;SETS  FORMAT FO R DR CODES
  35161   "RTN","CHM XPU04",362 ,0)
  35162    Q
  35163   "RTN","CHM XPU04",363 ,0)
  35164    ; 
  35165   "RTN","CHM XPU04",364 ,0)
  35166   SETDTA ;SE TS APPROPR IATE HC CO DE DATA UP  IN CHDTA  ARRAYS
  35167   "RTN","CHM XPU04",365 ,0)
  35168    D DEBUG^C HMXDR01("         CHM XPU04: SET DTA CHFLD( CHFLPN)= " "",CHFLD(C HFLPN)_""" ^"_CHSUB1_ "^"_CHSUB2 )
  35169   "RTN","CHM XPU04",366 ,0)
  35170    Q:CHSUB1= "NONE"
  35171   "RTN","CHM XPU04",367 ,0)
  35172    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)
  35173   "RTN","CHM XPU04",368 ,0)
  35174    .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
  35175   "RTN","CHM XPU04",369 ,0)
  35176    S CHVAR=9 999,CHVAR= $O(CHDTA(C HSUB1,CHSU B2,CHVAR), -1)+1
  35177   "RTN","CHM XPU04",370 ,0)
  35178    I CHSUB1= 49 D  G SE TDTA1
  35179   "RTN","CHM XPU04",371 ,0)
  35180    .;S CHDTA (CHSUB1,CH SUB2,CHVAR )=CHEDRJ_" *"_CHFLD(C HFLPN)
  35181   "RTN","CHM XPU04",372 ,0)
  35182    .I $D(CHX STYP) Q:CH XSTYP=1  ;  QUIT IF O CR -- NO R EJECTS REC ORDED
  35183   "RTN","CHM XPU04",373 ,0)
  35184    .Q:$G(CHE DRJ)="NONE "        ;  QUIT NO E RRORS ARE  TO BE RECO RDED 
  35185   "RTN","CHM XPU04",374 ,0)
  35186    .S CHRCER R(CHXREC,C HEDRJ)="", CHLVLRJ("E ")=""
  35187   "RTN","CHM XPU04",375 ,0)
  35188    S CHDTA(C HSUB1,CHSU B2,CHVAR)= CHFLD(CHFL PN)
  35189   "RTN","CHM XPU04",376 ,0)
  35190   SETDTA1 K  CHSUB1,CHS UB2,CHVAR  Q
  35191   "RTN","CHM XPU04",377 ,0)
  35192    ; 
  35193   "RTN","CHM XPU04",378 ,0)
  35194   BTQICT ;MA TCH BILL T YPE QUALIF IER TO IC  TYPE
  35195   "RTN","CHM XPU04",379 ,0)
  35196    Q:$D(CHRC ERR(CHXREC ,"E05a"))   Q:'$D(^CH MXCLA(CHCL AI,0))
  35197   "RTN","CHM XPU04",380 ,0)
  35198    S CHICTYP =$E($P(^CH MXCLA(CHCL AI,0),"^", 14),7,99)  Q:CHICTYP= ""
  35199   "RTN","CHM XPU04",381 ,0)
  35200    I (CHFLD( CHFLPN)="A ")&(CHICTY P'="HOSP")  D RCDERR^ CHMXPU01 G  BTQICT1
  35201   "RTN","CHM XPU04",382 ,0)
  35202    I (CHFLD( CHFLPN)="B ")&(CHICTY P'="PHYS")  D RCDERR^ CHMXPU01 G  BTQICT1
  35203   "RTN","CHM XPU04",383 ,0)
  35204   BTQICT1 K  CHICTYP Q
  35205   "RTN","CHM XPU04",384 ,0)
  35206    ; 
  35207   "RTN","CHM XPU04",385 ,0)
  35208   GETODT ;PU LLS THE TO  DATE FOR  OCC/OCC SP AN CODES T O COMPARE  TO THRU DA TE
  35209   "RTN","CHM XPU04",386 ,0)
  35210    I '$D(RCD ) S CHEDPR B="" G GET ODT1
  35211   "RTN","CHM XPU04",387 ,0)
  35212    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HTODT=$$TR IM^CHMXPU0 1(Y)
  35213   "RTN","CHM XPU04",388 ,0)
  35214   GETODT1 Q
  35215   "RTN","CHM XPU04",389 ,0)
  35216    ; 
  35217   "RTN","CHM XPU04",390 ,0)
  35218   GETHRDT ;P ULLS THE T HROUGH DAT E FOR OCC/ OCC SPAN C ODES TO CO MPARE TO T O DATE
  35219   "RTN","CHM XPU04",391 ,0)
  35220    I '$D(RCD ) S CHEDPR B="" G GET HRDT1
  35221   "RTN","CHM XPU04",392 ,0)
  35222    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HTHRDT=$$T RIM^CHMXPU 01(Y)
  35223   "RTN","CHM XPU04",393 ,0)
  35224   GETHRDT1 Q
  35225   "RTN","CHM XPU04",394 ,0)
  35226    ; 
  35227   "RTN","CHM XPU04",395 ,0)
  35228   ICNDCNMS ; MISSING IC N/DCN # WH EN CLAIM F REQUENCY =  5,7 OR 8
  35229   "RTN","CHM XPU04",396 ,0)
  35230    Q:$D(CHRC ERR(CHXREC ,"E33a"))   Q:'$D(^CH MXCLE(CHCL EI,0))
  35231   "RTN","CHM XPU04",397 ,0)
  35232    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6) Q :'CHFREQ
  35233   "RTN","CHM XPU04",398 ,0)
  35234    I (((CHFR EQ=7)!(CHF REQ=8))&(C HFLD(CHFLP N)="")) D  RCDERR^CHM XPU01 G IC NDCN1
  35235   "RTN","CHM XPU04",399 ,0)
  35236    I CHFREQ= 8 D  G ICN DCN1
  35237   "RTN","CHM XPU04",400 ,0)
  35238    .Q:'$D(^C HMPAY("B", CHFLD(CHFL PN)))
  35239   "RTN","CHM XPU04",401 ,0)
  35240    .S CHMXCL MI=0,CHMXC LMI=$O(^CH MPAY("B",C HFLD(CHFLP N),CHMXCLM I))
  35241   "RTN","CHM XPU04",402 ,0)
  35242    .Q:CHMXCL MI=""
  35243   "RTN","CHM XPU04",403 ,0)
  35244    .S CHMXCL M=CHFLD(CH FLPN)
  35245   "RTN","CHM XPU04",404 ,0)
  35246    .D ^CHMXM M06 Q
  35247   "RTN","CHM XPU04",405 ,0)
  35248   ICNDCN1 K  CHFREQ,CHM XCLMI,CHMX CLM Q
  35249   "RTN","CHM XPU04",406 ,0)
  35250    ; 
  35251   "RTN","CHM XPU04",407 ,0)
  35252    ;Methodic al-5010 Ch ange-Begin
  35253   "RTN","CHM XPU04",408 ,0)
  35254   ICNBLANK ; BLANK OR N O MATCHING  ICN/DCN #  WHEN CLAI M FREQUENC Y = 7 OR 8
  35255   "RTN","CHM XPU04",409 ,0)
  35256    N CHFREQ
  35257   "RTN","CHM XPU04",410 ,0)
  35258    Q:'$D(^CH MXCLE(CHCL EI,0))
  35259   "RTN","CHM XPU04",411 ,0)
  35260    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6) Q :'CHFREQ
  35261   "RTN","CHM XPU04",412 ,0)
  35262    Q:CHFREQ' =7&(CHFREQ '=8)
  35263   "RTN","CHM XPU04",413 ,0)
  35264    I CHFLD(C HFLPN)=""  D RCDERR^C HMXPU01 Q
  35265   "RTN","CHM XPU04",414 ,0)
  35266    Q:$D(^CHM PAY("B",CH FLD(CHFLPN )))!($D(^C HMIMAGE(CH FLD(CHFLPN ))))
  35267   "RTN","CHM XPU04",415 ,0)
  35268    D RCDERR^ CHMXPU01
  35269   "RTN","CHM XPU04",416 ,0)
  35270    Q
  35271   "RTN","CHM XPU04",417 ,0)
  35272    ;
  35273   "RTN","CHM XPU04",418 ,0)
  35274   ICNVOID  ;  If freque ncy code e quals 8 -  check for  Original P DI in Read y Queue
  35275   "RTN","CHM XPU04",419 ,0)
  35276    ; 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.
  35277   "RTN","CHM XPU04",420 ,0)
  35278    N CHFREQ, CHMIEN,CHM STAT,CHMCL M,CHMSTRIP ,CHMNOSTP, CHMFOPDI
  35279   "RTN","CHM XPU04",421 ,0)
  35280    ;K CHFC8C IP ;CPE005 -042
  35281   "RTN","CHM XPU04",422 ,0)
  35282    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  35283   "RTN","CHM XPU04",423 ,0)
  35284    S CHMFOPD I=CHFLD(CH FLPN)
  35285   "RTN","CHM XPU04",424 ,0)
  35286    Q:CHFREQ' =8
  35287   "RTN","CHM XPU04",425 ,0)
  35288    Q:CHMFOPD I=""
  35289   "RTN","CHM XPU04",426 ,0)
  35290    Q:$D(^CHM PAY("C",CH MFOPDI))
  35291   "RTN","CHM XPU04",427 ,0)
  35292    ;***Begin  fix CFS 0 1/31/2019
  35293   "RTN","CHM XPU04",428 ,0)
  35294    ;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
  35295   "RTN","CHM XPU04",429 ,0)
  35296    ;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
  35297   "RTN","CHM XPU04",430 ,0)
  35298    ;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
  35299   "RTN","CHM XPU04",431 ,0)
  35300    ;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
  35301   "RTN","CHM XPU04",432 ,0)
  35302    ;
  35303   "RTN","CHM XPU04",433 ,0)
  35304    ;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
  35305   "RTN","CHM XPU04",434 ,0)
  35306    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")=""
  35307   "RTN","CHM XPU04",435 ,0)
  35308    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")=" "
  35309   "RTN","CHM XPU04",436 ,0)
  35310    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")=""
  35311   "RTN","CHM XPU04",437 ,0)
  35312    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") =""
  35313   "RTN","CHM XPU04",438 ,0)
  35314    S DIK="^C HMIMG(",DA =CHMFOPDI  D ^DIK K D IK
  35315   "RTN","CHM XPU04",439 ,0)
  35316    S DIK="^C HMIMAGE(", DA=CHMFOPD I D ^DIK K  DIK
  35317   "RTN","CHM XPU04",440 ,0)
  35318    K ^CHMIMG ("A-ALL",C HMFOPDI)
  35319   "RTN","CHM XPU04",441 ,0)
  35320    K ^CHMIMG ("A-FIRST" ,CHMFOPDI)
  35321   "RTN","CHM XPU04",442 ,0)
  35322    Q
  35323   "RTN","CHM XPU04",443 ,0)
  35324   ICN42 ;BDB ; CPE005-0 42; Testin g for Orig inal PDI i n process  and all cl aims in pr ocess
  35325   "RTN","CHM XPU04",444 ,0)
  35326    N CHFREQ, CHMFOPDI,C HMIEN,CHMC LM,CHMSTAT ,CHMSTRIP, CHMNOSTP
  35327   "RTN","CHM XPU04",445 ,0)
  35328    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  35329   "RTN","CHM XPU04",446 ,0)
  35330    S CHMFOPD I=CHFLD(CH FLPN)
  35331   "RTN","CHM XPU04",447 ,0)
  35332    Q:CHFREQ' =8
  35333   "RTN","CHM XPU04",448 ,0)
  35334    Q:CHMFOPD I=""
  35335   "RTN","CHM XPU04",449 ,0)
  35336    Q:'$D(^CH MIMG(CHMFO PDI,0))
  35337   "RTN","CHM XPU04",450 ,0)
  35338    Q:'$D(^CH MPAY("C",C HMFOPDI))
  35339   "RTN","CHM XPU04",451 ,0)
  35340    K CHFC8CI P
  35341   "RTN","CHM XPU04",452 ,0)
  35342    S CHMIEN= 0,CHMSTAT= 0,CHMSTRIP =1
  35343   "RTN","CHM XPU04",453 ,0)
  35344    F  S CHMI EN=$O(^CHM PAY("C",CH MFOPDI,CHM IEN)) Q:CH MIEN=""  D
  35345   "RTN","CHM XPU04",454 ,0)
  35346    .; Check  claim stat us
  35347   "RTN","CHM XPU04",455 ,0)
  35348    .S CHMSTA T=$P($G(^C HMPAY(CHMI EN,0)),"^" ,2)
  35349   "RTN","CHM XPU04",456 ,0)
  35350    .S CHMCLM (CHMIEN)=" "
  35351   "RTN","CHM XPU04",457 ,0)
  35352    .S:CHMSTA T'=1 CHMST RIP=0
  35353   "RTN","CHM XPU04",458 ,0)
  35354    Q:CHMSTRI P=0
  35355   "RTN","CHM XPU04",459 ,0)
  35356    ;STRIP Or iginal PDI
  35357   "RTN","CHM XPU04",460 ,0)
  35358    N CHMSTRI P2
  35359   "RTN","CHM XPU04",461 ,0)
  35360    ;Strip PD I as defin d by the S trip Submi ssion Opti on
  35361   "RTN","CHM XPU04",462 ,0)
  35362    S CHMSTRI P2=$$START ^CHMFSTP1E (CHMFOPDI)
  35363   "RTN","CHM XPU04",463 ,0)
  35364    Q:CHMSTRI P2=0
  35365   "RTN","CHM XPU04",464 ,0)
  35366    ;Set STAT US OF Orig inal PDI t o VOIDED
  35367   "RTN","CHM XPU04",465 ,0)
  35368    S DIE=741 000.2,DA=C HMFOPDI,DR =".06///11 " D ^DIE K  DIE ;void ed
  35369   "RTN","CHM XPU04",466 ,0)
  35370    ;Set all  Claim stat us to Void ed
  35371   "RTN","CHM XPU04",467 ,0)
  35372    S CHMIEN= 0
  35373   "RTN","CHM XPU04",468 ,0)
  35374    F  S CHMI EN=$O(CHMC LM(CHMIEN) ) Q:CHMIEN =""  D
  35375   "RTN","CHM XPU04",469 ,0)
  35376    .Q:'$D(^C HMPAY(CHMI EN,0))
  35377   "RTN","CHM XPU04",470 ,0)
  35378    .S DIE=74 1000,DA=CH MIEN,DR=". 02///11" D  ^DIE K DI E ;voided
  35379   "RTN","CHM XPU04",471 ,0)
  35380    S CHFC8CI P=1
  35381   "RTN","CHM XPU04",472 ,0)
  35382    S CHEDRJ= "E001d",CH RCERR(CHXR EC,CHEDRJ) =""
  35383   "RTN","CHM XPU04",473 ,0)
  35384    Q
  35385   "RTN","CHM XPU04",474 ,0)
  35386    ;
  35387   "RTN","CHM XPU04",475 ,0)
  35388   ICNVOID2   ; If frequ ency code  equals 8 -  check for  valid Ori ginal PDI  and reject  all claim s that are  in "in pr ocess"
  35389   "RTN","CHM XPU04",476 ,0)
  35390    ; HM/SS;  cpe005-043  TOB FC 8  All Claims  Lines Not  Complete
  35391   "RTN","CHM XPU04",477 ,0)
  35392    ; Removed  code and  added quit  to preven t use of t his Tag TG H - CPE005 -043 - 2/1 5/18
  35393   "RTN","CHM XPU04",478 ,0)
  35394    Q
  35395   "RTN","CHM XPU04",479 ,0)
  35396    ;
  35397   "RTN","CHM XPU04",480 ,0)
  35398   ICNNULL  ;  CPE005-04 0 - Correc ted claim:  If freque ncy code e quals 5 an d original  PDI is nu ll...
  35399   "RTN","CHM XPU04",481 ,0)
  35400            ;  CPE005-01 4 - Null a nd Frequen cy Code 8
  35401   "RTN","CHM XPU04",482 ,0)
  35402    N CHFREQ
  35403   "RTN","CHM XPU04",483 ,0)
  35404    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  35405   "RTN","CHM XPU04",484 ,0)
  35406    S CHMFOPD I=CHFLD(CH FLPN)
  35407   "RTN","CHM XPU04",485 ,0)
  35408    I CHFREQ' =5,CHFREQ' =7,CHFREQ' =8 Q
  35409   "RTN","CHM XPU04",486 ,0)
  35410    Q:CHMFOPD I'=""
  35411   "RTN","CHM XPU04",487 ,0)
  35412    S CHEDRJ= "E33b"
  35413   "RTN","CHM XPU04",488 ,0)
  35414    S CHRCERR (CHXREC,CH EDRJ)="",C HLVLRJ("E" )=""
  35415   "RTN","CHM XPU04",489 ,0)
  35416    Q
  35417   "RTN","CHM XPU04",490 ,0)
  35418    ;
  35419   "RTN","CHM XPU04",491 ,0)
  35420   KILL(CHMFP DI) ;cpe00 5-038
  35421   "RTN","CHM XPU04",492 ,0)
  35422    D KILPDI^ CHMFADR1
  35423   "RTN","CHM XPU04",493 ,0)
  35424    Q
  35425   "RTN","CHM XPU04",494 ,0)
  35426    ;Methodic al-5010 Ch ange-End
  35427   "RTN","CHM XPU041")
  35428   0^64^B3321 53380
  35429   "RTN","CHM XPU041",1, 0)
  35430   CHMXPU041  ;CVA/DTP;X 12 837 REA D EDIT UTI LITY #4 (H EALTH CARE  CLAIMS);0 3/10/98  1 :50 PM
  35431   "RTN","CHM XPU041",2, 0)
  35432    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  35433   "RTN","CHM XPU041",3, 0)
  35434    ;;CPTS #1 1374 BY DT P (18-DEC- 96)
  35435   "RTN","CHM XPU041",4, 0)
  35436    ;;SPECIAL  EDITS FOR  837 RECOR D READ AT  CLAIM LEVE L
  35437   "RTN","CHM XPU041",5, 0)
  35438    ;;CALLED  INDIRECTLY  BY GENREA D^CHMXPU01 +15 (CHEDR TN IS DEFI NED), CHMX PU07
  35439   "RTN","CHM XPU041",6, 0)
  35440    ;;AJM DEV 5022 (04-J UN-08)
  35441   "RTN","CHM XPU041",7, 0)
  35442    ;;Methodi cal - Chan ged CHHCQL F= TO CHHC QLF[ in or der to han dle ICD-10  or ICD-9  qualifier
  35443   "RTN","CHM XPU041",8, 0)
  35444    ;;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
  35445   "RTN","CHM XPU041",9, 0)
  35446    ;;ICD-10  RCS -lg ad ded "BBQ": "i" to $CA SE stateme nt in case  BBQ not i n file 03/ 25/13
  35447   "RTN","CHM XPU041",10 ,0)
  35448    ;;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
  35449   "RTN","CHM XPU041",11 ,0)
  35450    ;; 2/1/20 16 DLB MER GED UPDATE S TO THE F ORMAT ROUT INE FRO IC D-9 DIAGNO SIS CODES.
  35451   "RTN","CHM XPU041",12 ,0)
  35452    ;;CPE005- 033 GEF -  Original P DI is not  valid (Fre q code = 8 )
  35453   "RTN","CHM XPU041",13 ,0)
  35454    ;;CPE005- 038 GEF -  Original P DI is vali d but not  processed  (Freq code =8)
  35455   "RTN","CHM XPU041",14 ,0)
  35456    ;
  35457   "RTN","CHM XPU041",15 ,0)
  35458   HCCDQ    ; VALIDATION  OF HEALTH  CARE CODE  QUALIFIER
  35459   "RTN","CHM XPU041",16 ,0)
  35460    D DEBUG^C HMXDR01("C HMXPU04: H CCDQ CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  35461   "RTN","CHM XPU041",17 ,0)
  35462    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  35463   "RTN","CHM XPU041",18 ,0)
  35464    I '$D(^CH MXDIC(7412 01.1,"B",C HFLD(CHFLP N))) D  ;G  HCCDQ1
  35465   "RTN","CHM XPU041",19 ,0)
  35466    . S CHHCQ LF="",CHSU B1=49,CHSU B2=1 D SET DTA
  35467   "RTN","CHM XPU041",20 ,0)
  35468    . D DEBUG ^CHMXDR01( "CHMXPU04:  HCCDQ2 CH FLD(CHFLPN )= ",CHFLD (CHFLPN))
  35469   "RTN","CHM XPU041",21 ,0)
  35470    . 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 
  35471   "RTN","CHM XPU041",22 ,0)
  35472    . D RCDER R^CHMXPU01 :CHEDRJ'=" E100"
  35473   "RTN","CHM XPU041",23 ,0)
  35474   HCCDQ1   Q
  35475   "RTN","CHM XPU041",24 ,0)
  35476    ;
  35477   "RTN","CHM XPU041",25 ,0)
  35478    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  35479   "RTN","CHM XPU041",26 ,0)
  35480    ; THE HEA LTH CARE C ODE QUALIF IER VALIDA TION IS US ED FOR BOT H THE ICD- 9 AND ICD- 10 CODES.
  35481   "RTN","CHM XPU041",27 ,0)
  35482    ; THE USE  OF THE "[ " (CONTAIN S) VS THE  "=" (EQUAL S) ALLOWS  THE TESTIN G OF THE 
  35483   "RTN","CHM XPU041",28 ,0)
  35484    ; "BK,BJ, BF,etc" AN D "ABK,ABJ ,ABF,etc"  USING THIS  SAME FUNC TION.
  35485   "RTN","CHM XPU041",29 ,0)
  35486    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  35487   "RTN","CHM XPU041",30 ,0)
  35488    ;
  35489   "RTN","CHM XPU041",31 ,0)
  35490   HCCDV    ; VALIDATION  OF HEALTH  CARE CODE  (FILE LOO KUP DEPEND S UPON HC  QUALIFIER)
  35491   "RTN","CHM XPU041",32 ,0)
  35492    Q:'$D(CHF LD(CHFLPN) )  ; Q:CHF LD(CHFLPN) ="" 
  35493   "RTN","CHM XPU041",33 ,0)
  35494    D DEBUG^C HMXDR01("C HMXPU04: H CCDV ENTRY : CHFLD(CH FLPN)=",CH FLD(CHFLPN ))
  35495   "RTN","CHM XPU041",34 ,0)
  35496    S CHDIF=3 ,CHEND=1
  35497   "RTN","CHM XPU041",35 ,0)
  35498    D GTHCQLF  I $D(CHED PRB) S CHP RB="E40ZA"  G HCCDV1
  35499   "RTN","CHM XPU041",36 ,0)
  35500    ;FOLLOWIN G WAS FE E DIT E40ZD  - AJM DEV5 022
  35501   "RTN","CHM XPU041",37 ,0)
  35502    Q:CHHCQLF =""  I CHF LD(CHFLPN) ="" S CHSU B1=49,CHSU B2=1,CHEDR J="NONE" D  SETDTA G  HCCDV1
  35503   "RTN","CHM XPU041",38 ,0)
  35504    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))
  35505   "RTN","CHM XPU041",39 ,0)
  35506    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CCDV1
  35507   "RTN","CHM XPU041",40 ,0)
  35508    I CHHCQLF ["BJ" D  G  HCCDV1
  35509   "RTN","CHM XPU041",41 ,0)
  35510    .S JZ=3 D  STFRMT                                                                         ; SET U P THE FORM ATTING FOR  THE CODES
  35511   "RTN","CHM XPU041",42 ,0)
  35512    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40Z B" D SETDT A
  35513   "RTN","CHM XPU041",43 ,0)
  35514    .S CHSUB1 =42,CHSUB2 =1 D SETDT A Q
  35515   "RTN","CHM XPU041",44 ,0)
  35516    I CHHCQLF ["BK" D  G  HCCDV1
  35517   "RTN","CHM XPU041",45 ,0)
  35518    .S JZ=3 D  STFRMT
  35519   "RTN","CHM XPU041",46 ,0)
  35520    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E401 a" D SETDT A
  35521   "RTN","CHM XPU041",47 ,0)
  35522    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  35523   "RTN","CHM XPU041",48 ,0)
  35524    .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
  35525   "RTN","CHM XPU041",49 ,0)
  35526    .S CHSUB1 =40,CHSUB2 =1 D SETDT A K ZZTOS  Q
  35527   "RTN","CHM XPU041",50 ,0)
  35528    I CHHCQLF ["BF" D  G  HCCDV1
  35529   "RTN","CHM XPU041",51 ,0)
  35530    .S JZ=3 D  STFRMT
  35531   "RTN","CHM XPU041",52 ,0)
  35532    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40J 1" D SETDT A
  35533   "RTN","CHM XPU041",53 ,0)
  35534    .S CHSUB1 =40,CHSUB2 =1 D SETDT A Q
  35535   "RTN","CHM XPU041",54 ,0)
  35536    I CHHCQLF ["BN" D  G  HCCDV1
  35537   "RTN","CHM XPU041",55 ,0)
  35538    .S JZ=3 D  STFRMT
  35539   "RTN","CHM XPU041",56 ,0)
  35540    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40Z C" D SETDT A
  35541   "RTN","CHM XPU041",57 ,0)
  35542    .S CHSUB1 =40,CHSUB2 =1 D SETDT A Q
  35543   "RTN","CHM XPU041",58 ,0)
  35544    I CHHCQLF ["ZZ" D  G  HCCDV1
  35545   "RTN","CHM XPU041",59 ,0)
  35546    .S JZ=3 D  STFRMT
  35547   "RTN","CHM XPU041",60 ,0)
  35548    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E40J 1" D SETDT A
  35549   "RTN","CHM XPU041",61 ,0)
  35550    .S CHSUB1 =46,CHSUB2 =1 D SETDT A Q
  35551   "RTN","CHM XPU041",62 ,0)
  35552    I CHHCQLF ["BR" D  G  HCCDV1
  35553   "RTN","CHM XPU041",63 ,0)
  35554    .S JZ=2 D :CHHCQLF=" BR" STFRMT   ;ICD-10  RCS -lg
  35555   "RTN","CHM XPU041",64 ,0)
  35556    .I '$D(^C HMSERV("BE ",CHFLD(CH FLPN)_"Z") ) S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E411a" D  SETDTA
  35557   "RTN","CHM XPU041",65 ,0)
  35558    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  35559   "RTN","CHM XPU041",66 ,0)
  35560    .;FOLLOWI NG WAS FE  EDIT E411b   - AJM DE V5022
  35561   "RTN","CHM XPU041",67 ,0)
  35562    .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
  35563   "RTN","CHM XPU041",68 ,0)
  35564    .S CHSUB1 =41,CHSUB2 =1 D SETDT A K ZZTOS  Q
  35565   "RTN","CHM XPU041",69 ,0)
  35566    I CHHCQLF ["BP" D  G  HCCDV1
  35567   "RTN","CHM XPU041",70 ,0)
  35568    .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
  35569   "RTN","CHM XPU041",71 ,0)
  35570    .S ZZTOS= $P(^CHMXCL E(CHCLEI,0 ),"^",4)
  35571   "RTN","CHM XPU041",72 ,0)
  35572    .;FOLLOWI NG WAS FE  EDIT E411b  - AJM DEV 5022
  35573   "RTN","CHM XPU041",73 ,0)
  35574    .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
  35575   "RTN","CHM XPU041",74 ,0)
  35576    .S CHSUB1 =41,CHSUB2 =1 D SETDT A K ZZTOS  Q
  35577   "RTN","CHM XPU041",75 ,0)
  35578    I CHHCQLF ["BQ" D  G  HCCDV1
  35579   "RTN","CHM XPU041",76 ,0)
  35580    .S JZ=2 D :CHHCQLF=" BQ" STFRMT  ; ICD-10  RCS lg
  35581   "RTN","CHM XPU041",77 ,0)
  35582    .I '$D(^C HMSERV("BE ",CHFLD(CH FLPN)_"Z") ) S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E41J1" D  SETDTA
  35583   "RTN","CHM XPU041",78 ,0)
  35584    .S CHSUB1 =41,CHSUB2 =1 D SETDT A Q
  35585   "RTN","CHM XPU041",79 ,0)
  35586    I CHHCQLF ["BO" D  G  HCCDV1
  35587   "RTN","CHM XPU041",80 ,0)
  35588    .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
  35589   "RTN","CHM XPU041",81 ,0)
  35590    .S CHSUB1 =41,CHSUB2 =1 D SETDT A Q
  35591   "RTN","CHM XPU041",82 ,0)
  35592    ;Methodic al-5010 Ch ange-Begin  - Added c ode for PR  qualifier  check - P atient Rea son for Vi sit
  35593   "RTN","CHM XPU041",83 ,0)
  35594    I CHHCQLF ["PR" D  G  HCCDV1
  35595   "RTN","CHM XPU041",84 ,0)
  35596    .S JZ=3 D  STFRMT
  35597   "RTN","CHM XPU041",85 ,0)
  35598    .I '$D(^C HMICDX("C" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E46b " D SETDTA
  35599   "RTN","CHM XPU041",86 ,0)
  35600    .S CHSUB1 =46,CHSUB2 =1 D SETDT A Q
  35601   "RTN","CHM XPU041",87 ,0)
  35602    ;Methodic al-5010 Ch ange-End
  35603   "RTN","CHM XPU041",88 ,0)
  35604    I CHHCQLF ["BE" D  G  HCCDV1
  35605   "RTN","CHM XPU041",89 ,0)
  35606    .I '$D(^C HMXDIC(741 201.4,"B", CHFLD(CHFL PN))) S CH SUB1=49,CH SUB2=1,CHE DRJ="E45a"  D SETDTA
  35607   "RTN","CHM XPU041",90 ,0)
  35608    .S CHSUB1 =45,CHSUB2 =1 D SETDT A Q
  35609   "RTN","CHM XPU041",91 ,0)
  35610    I CHHCQLF ["BG" D  G  HCCDV1
  35611   "RTN","CHM XPU041",92 ,0)
  35612    .I '$D(^C HMXDIC(741 201.41,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E44a " D SETDTA
  35613   "RTN","CHM XPU041",93 ,0)
  35614    .S CHSUB1 =44,CHSUB2 =1 D SETDT A Q
  35615   "RTN","CHM XPU041",94 ,0)
  35616    I CHHCQLF ["BH" D  G  HCCDV1
  35617   "RTN","CHM XPU041",95 ,0)
  35618    .I '$D(^C HMXDIC(741 201.42,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E43a " D SETDTA
  35619   "RTN","CHM XPU041",96 ,0)
  35620    .S CHSUB1 =43,CHSUB2 =1 D SETDT A Q
  35621   "RTN","CHM XPU041",97 ,0)
  35622    I CHHCQLF ["BI" D  G  HCCDV1
  35623   "RTN","CHM XPU041",98 ,0)
  35624    .I '$D(^C HMXDIC(741 201.43,"B" ,CHFLD(CHF LPN))) S C HSUB1=49,C HSUB2=1,CH EDRJ="E43b " D SETDTA
  35625   "RTN","CHM XPU041",99 ,0)
  35626    .S CHSUB1 =43,CHSUB2 =1 D SETDT A Q
  35627   "RTN","CHM XPU041",10 0,0)
  35628    I CHHCQLF ["TC" D  G  HCCDV1
  35629   "RTN","CHM XPU041",10 1,0)
  35630    .D STTC ;  FORMAT "T C" CODES I F NEEDED
  35631   "RTN","CHM XPU041",10 2,0)
  35632    .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
  35633   "RTN","CHM XPU041",10 3,0)
  35634    .;S CHSUB 1=48,CHSUB 2=1 D SETD TA Q  ; CO ULD SET IN TO NODE 48  IF DESIRE D
  35635   "RTN","CHM XPU041",10 4,0)
  35636    I CHHCQLF ["DR" D  G  HCCDV1
  35637   "RTN","CHM XPU041",10 5,0)
  35638    .Q
  35639   "RTN","CHM XPU041",10 6,0)
  35640    .D STDR ;  FORMAT "D R" CODES I F NEEDED
  35641   "RTN","CHM XPU041",10 7,0)
  35642    .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
  35643   "RTN","CHM XPU041",10 8,0)
  35644    .S CHSUB1 =47,CHSUB2 =1 D SETDT A Q  ; COU LD SET INT O NODE 47  IF DESIRED
  35645   "RTN","CHM XPU041",10 9,0)
  35646   HCCDV1   K  CHHCQLF,C HDIF,CHEND  Q
  35647   "RTN","CHM XPU041",11 0,0)
  35648    ; 
  35649   "RTN","CHM XPU041",11 1,0)
  35650   HCDTV    ; HEALTH CAR E CODE DAT E MUST BE  PRESENT/VA LID FOR AL L PX CODES  ("BR" & " BQ" FOR IC D9 CODES A ND "BP" &  "BO" FOR H CPCS/CPT4  CODES)
  35651   "RTN","CHM XPU041",11 2,0)
  35652    S:CHX12VR S=1 CHDIF= 13,CHEND=1 1
  35653   "RTN","CHM XPU041",11 3,0)
  35654    S:CHX12VR S=2 CHDIF= 18,CHEND=1 6
  35655   "RTN","CHM XPU041",11 4,0)
  35656    ;Methodic al-5010 Ch ange-Begin
  35657   "RTN","CHM XPU041",11 5,0)
  35658    S:CHX12VR S=3 CHDIF= 34,CHEND=3 2
  35659   "RTN","CHM XPU041",11 6,0)
  35660    ;Methodic al-5010 Ch ange-End
  35661   "RTN","CHM XPU041",11 7,0)
  35662    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTV1
  35663   "RTN","CHM XPU041",11 8,0)
  35664    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTV1
  35665   "RTN","CHM XPU041",11 9,0)
  35666    I (CHHCQL F["BR")!(C HHCQLF["BP ") D  G HC DTV1
  35667   "RTN","CHM XPU041",12 0,0)
  35668    .;I CHFLD (CHFLPN)=" " S CHSUB1 =49,CHSUB2 =1,CHEDRJ= "E412a" D  SETDTA Q
  35669   "RTN","CHM XPU041",12 1,0)
  35670    .;S CHDTF L=1 D 201^ CHMXPU01 K  CHDTFL I  Y=-1 S CHS UB1=49,CHS UB2=1,CHED RJ="E412a"  D SETDTA
  35671   "RTN","CHM XPU041",12 2,0)
  35672    .S CHSUB1 =41,CHSUB2 =2 D SETDT A Q
  35673   "RTN","CHM XPU041",12 3,0)
  35674    I (CHHCQL F["BQ")!(C HHCQLF["BO ") D  G HC DTV1
  35675   "RTN","CHM XPU041",12 4,0)
  35676    .;FOLLOWI NG WAS FE  EDIT E41J2 a - AJM DE V5022
  35677   "RTN","CHM XPU041",12 5,0)
  35678    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  35679   "RTN","CHM XPU041",12 6,0)
  35680    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="E41J2a"  D SETDTA 
  35681   "RTN","CHM XPU041",12 7,0)
  35682    .S CHSUB1 =41,CHSUB2 =2 D SETDT A Q
  35683   "RTN","CHM XPU041",12 8,0)
  35684    I (CHHCQL F["BH")!(C HHCQLF["BI ") D  G HC DTV1
  35685   "RTN","CHM XPU041",12 9,0)
  35686    .;FOLLOWI NG WAS FE  EDIT E431a  - AJM DEV 5022
  35687   "RTN","CHM XPU041",13 0,0)
  35688    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  35689   "RTN","CHM XPU041",13 1,0)
  35690    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="E431a"  D SETDTA
  35691   "RTN","CHM XPU041",13 2,0)
  35692    .S CHSUB1 =43,CHSUB2 =2 D SETDT A Q
  35693   "RTN","CHM XPU041",13 3,0)
  35694   HCDTV1   K  CHHCQLF,C HDIF,CHEND  Q
  35695   "RTN","CHM XPU041",13 4,0)
  35696    ; 
  35697   "RTN","CHM XPU041",13 5,0)
  35698   HCDTF    ; HEALTH CAR E CODE DAT E MUST NOT  BE FUTURE  FOR ALL P X CODES (" BR" & "BQ"  FOR ICD9  CODES, "BP " AND "BO"  FOR HCPCS /CPT4 CODE S)
  35699   "RTN","CHM XPU041",13 6,0)
  35700    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  35701   "RTN","CHM XPU041",13 7,0)
  35702    S:CHX12VR S=1 CHDIF= 13,CHEND=1 1
  35703   "RTN","CHM XPU041",13 8,0)
  35704    S:CHX12VR S=2 CHDIF= 18,CHEND=1 6
  35705   "RTN","CHM XPU041",13 9,0)
  35706    ;Methodic al-5010 Ch ange-Begin
  35707   "RTN","CHM XPU041",14 0,0)
  35708    S:CHX12VR S=3 CHDIF= 34,CHEND=3 2
  35709   "RTN","CHM XPU041",14 1,0)
  35710    ;Methodic al-5010 Ch ange-End
  35711   "RTN","CHM XPU041",14 2,0)
  35712    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E4OZA"  G HCDTF1
  35713   "RTN","CHM XPU041",14 3,0)
  35714    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTF1
  35715   "RTN","CHM XPU041",14 4,0)
  35716    I (CHHCQL F["BR")!(C HHCQLF["BP ") D  G HC DTF1
  35717   "RTN","CHM XPU041",14 5,0)
  35718    .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
  35719   "RTN","CHM XPU041",14 6,0)
  35720    I (CHHCQL F["BQ")!(C HHCQLF["BO ") D  G HC DTF1
  35721   "RTN","CHM XPU041",14 7,0)
  35722    .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
  35723   "RTN","CHM XPU041",14 8,0)
  35724    .;I (CHHC QLF="BH")! (CHHCQLF=" BI") D  G: CHHCQLF="B H" HCDTF1
  35725   "RTN","CHM XPU041",14 9,0)
  35726    .;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
  35727   "RTN","CHM XPU041",15 0,0)
  35728    I CHHCQLF ["BI" D  G  HCDTF1
  35729   "RTN","CHM XPU041",15 1,0)
  35730    .;FOLLOWI NG WAS FE  EDIT E431b  - AJM DEV 5022
  35731   "RTN","CHM XPU041",15 2,0)
  35732    .S CHDIF= -8,CHEND=- 15 D GETHR DT Q:'$D(C HTHRDT)  Q :CHTHRDT=" "  I $D(CH EDPRB) S C HPRB="NONE " G HCDTF1
  35733   "RTN","CHM XPU041",15 3,0)
  35734    .;FOLLOWI NG WAS FE  EDIT E431b  - AJM DEV 5022
  35735   "RTN","CHM XPU041",15 4,0)
  35736    .I CHTHRD T'>CHFLD(C HFLPN) S C HSUB1=49,C HSUB2=1,CH EDRJ="NONE " D SETDTA  Q
  35737   "RTN","CHM XPU041",15 5,0)
  35738   HCDTF1   K  CHHCQLF,C HDIF,CHEND ,CHTHRDT Q
  35739   "RTN","CHM XPU041",15 6,0)
  35740    ; 
  35741   "RTN","CHM XPU041",15 7,0)
  35742   HCDTV2   ; HEALTH CAR E CODE DAT E2 (OCC SP AN ONLY) M UST BE PRE SENT/VALID  FOR "BI"
  35743   "RTN","CHM XPU041",15 8,0)
  35744    S:CHX12VR S=1 CHDIF= 21,CHEND=1 9
  35745   "RTN","CHM XPU041",15 9,0)
  35746    S:CHX12VR S=2 CHDIF= 26,CHEND=2 4
  35747   "RTN","CHM XPU041",16 0,0)
  35748    ;Methodic al-5010 Ch ange-End
  35749   "RTN","CHM XPU041",16 1,0)
  35750    S:CHX12VR S=3 CHDIF= 42,CHEND=4 0
  35751   "RTN","CHM XPU041",16 2,0)
  35752    ;Methodic al-5010 Ch ange-End
  35753   "RTN","CHM XPU041",16 3,0)
  35754    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTV21
  35755   "RTN","CHM XPU041",16 4,0)
  35756    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTV21
  35757   "RTN","CHM XPU041",16 5,0)
  35758    I CHHCQLF ["BI" D  G  HCDTV21
  35759   "RTN","CHM XPU041",16 6,0)
  35760    .;FOLLOWI NG WAS FE  EDIT E432a  - AJM DEV 5022
  35761   "RTN","CHM XPU041",16 7,0)
  35762    .I CHFLD( CHFLPN)=""  S CHSUB1= 49,CHSUB2= 1,CHEDRJ=" NONE" D SE TDTA Q
  35763   "RTN","CHM XPU041",16 8,0)
  35764    .;FOLLOWI NG WAS FE  EDIT E432a  - AJM DEV 5022
  35765   "RTN","CHM XPU041",16 9,0)
  35766    .S CHDTFL =1 D 201^C HMXPU01 K  CHDTFL I Y =-1 S CHSU B1=49,CHSU B2=1,CHEDR J="NONE" D  SETDTA
  35767   "RTN","CHM XPU041",17 0,0)
  35768    .S CHSUB1 =43,CHSUB2 =3 D SETDT A Q
  35769   "RTN","CHM XPU041",17 1,0)
  35770   HCDTV21  K  CHHCQLF,C HDIF,CHEND  Q
  35771   "RTN","CHM XPU041",17 2,0)
  35772    ; 
  35773   "RTN","CHM XPU041",17 3,0)
  35774   HCDTF2   ; HEALTH CAR E CODE DAT E MUST NOT  BE FUTURE  FOR OCC S PAN THRU D ATE ("BI")
  35775   "RTN","CHM XPU041",17 4,0)
  35776    Q:'$D(CHF LD(CHFLPN) )  Q:CHFLD (CHFLPN)=" "
  35777   "RTN","CHM XPU041",17 5,0)
  35778    S:CHX12VR S=1 CHDIF= 21,CHEND=1 9
  35779   "RTN","CHM XPU041",17 6,0)
  35780    S:CHX12VR S=2 CHDIF= 26,CHEND=2 4
  35781   "RTN","CHM XPU041",17 7,0)
  35782    S:CHX12VR S=3 CHDIF= 42,CHEND=4 0
  35783   "RTN","CHM XPU041",17 8,0)
  35784    D GTHCQLF  Q:'$D(CHH CQLF)  Q:C HHCQLF=""   I $D(CHED PRB) S CHP RB="E40ZA"  G HCDTF21
  35785   "RTN","CHM XPU041",17 9,0)
  35786    G:'$D(^CH MXDIC(7412 01.1,"B",C HHCQLF)) H CDTF21
  35787   "RTN","CHM XPU041",18 0,0)
  35788    I CHHCQLF ["BI" D  G  HCDTF21
  35789   "RTN","CHM XPU041",18 1,0)
  35790    .;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
  35791   "RTN","CHM XPU041",18 2,0)
  35792    .S CHDIF= 8,CHEND=1  D GETODT Q :'$D(CHTOD T)  Q:CHTO DT=""  I $ D(CHEDPRB)  S CHPRB=" E432b" Q
  35793   "RTN","CHM XPU041",18 3,0)
  35794    .;FOLLOWI NG WAS FE  EDIT E432b  - AJM DEV 5022
  35795   "RTN","CHM XPU041",18 4,0)
  35796    .I CHTODT '<CHFLD(CH FLPN) S CH SUB1=49,CH SUB2=1,CHE DRJ="NONE"  Q
  35797   "RTN","CHM XPU041",18 5,0)
  35798   HCDTF21  K  GETODT,CH HCQLF,CHDI F,CHEND Q
  35799   "RTN","CHM XPU041",18 6,0)
  35800    ;
  35801   "RTN","CHM XPU041",18 7,0)
  35802    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  35803   "RTN","CHM XPU041",18 8,0)
  35804    ; DIAGNOS IS CODE DA TE OF SERV ICE VS ICD  CODE ACTI VE DATES C HECK FOR I NSTITUTION AL CLAIMS.
  35805   "RTN","CHM XPU041",18 9,0)
  35806    ; INSTITU TIONAL CLA IMS LOAD I NTO THE ^C HMXCLE() B UFFER, AND  THE DATE  OF SERVICE  IS REQUIR ED
  35807   "RTN","CHM XPU041",19 0,0)
  35808    ; IN LOOP  2300, WHI CH TRANSLA TES TO THE  "E005" FL AT FILE RE CORD.
  35809   "RTN","CHM XPU041",19 1,0)
  35810    ; FOR ICD -10 THERE  NEEDS TO B E A REAL T IME CHECK  FOR THE AC TIVE ICD-9 /ICD-10 DI AG CODES 
  35811   "RTN","CHM XPU041",19 2,0)
  35812    ; AGAINST  THE DATE  OF SERVICE . THIS FUN CTION WILL  PERFORM T HE CHECK A S PART OF  THE FRONT 
  35813   "RTN","CHM XPU041",19 3,0)
  35814    ; END EDI TS SO THE  CLAIM CAN  BE REJECTE D AND REPO RTED ON TH E CSTAT (U NSOLICITED  STATUS) R EPORT.
  35815   "RTN","CHM XPU041",19 4,0)
  35816    ; THE REJ ECT LOGIC  FOR THE IC D-9/ICD-10  DIAGNOSTI C CODES:
  35817   "RTN","CHM XPU041",19 5,0)
  35818    ; 1) IF D IAG CODE C ANNOT BE C ROSS-REFER ENCED (^CH MICDX("C", DIAG CODE, I), CLAIM  WILL BE RE JECTED
  35819   "RTN","CHM XPU041",19 6,0)
  35820    ; 2) IF T HE DATE OF  SERVICE ( STATEMENT  "TO" DATE)  IS NOT PO PULATED (^ CHMXCLE(CH CLEI,1),"^ ",2)) THE
  35821   "RTN","CHM XPU041",19 7,0)
  35822    ;    INST ITUTIONAL  CLAIM WILL  BE REJECT ED.
  35823   "RTN","CHM XPU041",19 8,0)
  35824    ; 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
  35825   "RTN","CHM XPU041",19 9,0)
  35826    ; 4) IF I CD-10 CODE  TERMINATI ON DATE IS  BLANK, CH ECK AGAINS T ICD-10 " EFFECTIVE"  DATE ONLY . IF THE D OS
  35827   "RTN","CHM XPU041",20 0,0)
  35828    ;    IS B EFORE THE  "EFFECTIVE " DATE, TH E CLAIM WI LL BE REJE CTED.
  35829   "RTN","CHM XPU041",20 1,0)
  35830    ; 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 
  35831   "RTN","CHM XPU041",20 2,0)
  35832    ;    ^CHM ICDX(I,0),  FIELD 22:  EFFECTIVE  DATE AND  ^CHMICDX(I ,0), FIELD  23: TERMI NATION DAT E) FOR THE  
  35833   "RTN","CHM XPU041",20 3,0)
  35834    ;    DIAG  CODE. IF  THE DOS FA LLS OUTSID E THESE DA TES, THE C LAIM WILL  BE REJECTE D
  35835   "RTN","CHM XPU041",20 4,0)
  35836    ; 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) 
  35837   "RTN","CHM XPU041",20 5,0)
  35838    ;    IF T HE DOS IS  AFTER THE  TERMINATIO N DATE, TH E CLAIM WI LL BE REJE CTED.
  35839   "RTN","CHM XPU041",20 6,0)
  35840    ; NOTE: I N ORDER TO  VALIDATE  BOTH ICD-9  AND ICD-1 0 QUALIFIE RS IN THIS  FUNCTION,  ("BK" VS  "ABK", ETC .)
  35841   "RTN","CHM XPU041",20 7,0)
  35842    ;       T HE TESTING  LOGIC CAN NOT USE TH E "[" (CON TAINS) OPE RAND, BECA USE THE FO RMATTING F OR THE 
  35843   "RTN","CHM XPU041",20 8,0)
  35844    ;       D IAGNOSTIC  CODE IS DI FFERENT BE TWEEN THE  ICD-9 AND  ICD-10 COD ES.
  35845   "RTN","CHM XPU041",20 9,0)
  35846    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  35847   "RTN","CHM XPU041",21 0,0)
  35848    ; 
  35849   "RTN","CHM XPU041",21 1,0)
  35850   DXQUAL   ; CHECKS FOR  INSTITUTI ONAL CLAIM  DX CODES  PROVIDED ( PROF/DENTA L DIAG COD ES ARE IN  SVC LINES)
  35851   "RTN","CHM XPU041",21 2,0)
  35852    N JZ
  35853   "RTN","CHM XPU041",21 3,0)
  35854    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHMXPU 04: DXQUAL : DIAG COD E= ",CHFLD (CHFLPN)
  35855   "RTN","CHM XPU041",21 4,0)
  35856    Q:'$D(CHF LD(CHFLPN) )
  35857   "RTN","CHM XPU041",21 5,0)
  35858    S CHDIF=3 ,CHEND=1,C HSUB2=1,CH EDRJ="NONE "
  35859   "RTN","CHM XPU041",21 6,0)
  35860    D GTHCQLF  I $D(CHED PRB) S CHP RB="E40ZA"  G XDXQUAL                  ; CO DE QUALIFI ER
  35861   "RTN","CHM XPU041",21 7,0)
  35862    D DEBUG^C HMXDR01("      PU04:D XQUAL: QUA LIFIER: "_ CHHCQLF_"   DIAG CODE = "_CHFLD( CHFLPN)_"   CLMTYPE=" ,$$CLMTYPE ^CHMXP010( ))
  35863   "RTN","CHM XPU041",21 8,0)
  35864    Q:CHHCQLF =""                                                         ; EXI T IF NO QU ALIFIER
  35865   "RTN","CHM XPU041",21 9,0)
  35866    Q:(CHHCQL F'["BJ")&( CHHCQLF'[" BK")&(CHHC QLF'["BF") &(CHHCQLF' ["BN")&(CH HCQLF'["PR ")&(CHHCQL F'["ZZ")   ; VALID QU ALIFIERS
  35867   "RTN","CHM XPU041",22 0,0)
  35868    I CHFLD(C HFLPN)=""  S CHSUB1=4 9 D SETDTA  G XDXQUAL
  35869   "RTN","CHM XPU041",22 1,0)
  35870    S JZ=0                                                                ; ASS UME DIAG C ODE IS FOR MATTED ALR EADY
  35871   "RTN","CHM XPU041",22 2,0)
  35872    I ($E(CHH CQLF,1,1)= "A")!(CHHC QLF="BBQ") !(CHHCQLF= "BBR")  D       ; ICD -10 QUALIF IERS          
  35873   "RTN","CHM XPU041",22 3,0)
  35874    .I CHFLD( CHFLPN)'[" ." D                                             ; IF  NOT FORMAT TED, FORMA T THE DIAG  CODE
  35875   "RTN","CHM XPU041",22 4,0)
  35876    ..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 
  35877   "RTN","CHM XPU041",22 5,0)
  35878    E  D                                                                  ; ICD -9 QUALIFI ERS
  35879   "RTN","CHM XPU041",22 6,0)
  35880    .I CHFLD( CHFLPN)'[" ." D                                             ; IF  NOT FORMAT TED, FORMA T THE DIAG  CODE
  35881   "RTN","CHM XPU041",22 7,0)
  35882    ..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 
  35883   "RTN","CHM XPU041",22 8,0)
  35884    D:JZ STFR MT                                                          ; IF  ALREADY FO RMATTED, S KIP DIAG C ODE FORMAT TING
  35885   "RTN","CHM XPU041",22 9,0)
  35886    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"DXQUAL :  FORMATT ED DIAG CO DE= ",CHFL D(CHFLPN)
  35887   "RTN","CHM XPU041",23 0,0)
  35888    I '$D(^CH MICDX("C", CHFLD(CHFL PN))) D  Q                            ; DIA GNOSIS COD E NOT CROS S-REFERENC ED, REJECT
  35889   "RTN","CHM XPU041",23 1,0)
  35890    .D DEBUG^ CHMXDR01(" *****DXQUA L^CHMXPU04 : DIAG COD E "_CHFLD( CHFLPN)_",  NOT CROSS -REFERENCE D.","")
  35891   "RTN","CHM XPU041",23 2,0)
  35892    .S CHEDRJ ="E401a" D  RCDERR^CH MXPU01
  35893   "RTN","CHM XPU041",23 3,0)
  35894    N DICI S  DICI=0,DIC I=$O(^CHMI CDX("C",CH FLD(CHFLPN ),DICI))        ; DIA GNOSIS COD E INDEX FO R ^CHMICDX ()
  35895   "RTN","CHM XPU041",23 4,0)
  35896    S DOS=$$G ETDOS()                                                     ; DOS  IS DETERM INED DIFFE RENTLY FOR  I/P/D CLA IM TYPES
  35897   "RTN","CHM XPU041",23 5,0)
  35898    D DEBUG^C HMXDR01("     DXQUAL^ CHMXDR01:  DOS= "_DOS _"  ICD10  FLAG: "_$P (^CHMICDX( DICI,0),"^ ",24)_"  E FF DATE:"_ $P(^CHMICD X(DICI,0), "^",22)_"   TERM DATE :",$P(^CHM ICDX(DICI, 0),"^",23) )
  35899   "RTN","CHM XPU041",23 6,0)
  35900    I DOS'=""   D                                                         ; IF  WE HAVE A  VALID DOS,  COMPARE A GAINST ICD X DATES
  35901   "RTN","CHM XPU041",23 7,0)
  35902    .I $P(^CH MICDX(DICI ,0),"^",24 )  D                                  ; IF  ICD-10 FLA G IS SET
  35903   "RTN","CHM XPU041",23 8,0)
  35904    ..I $P(^C HMICDX(DIC I,0),"^",2 3)=""  D                              ; NO  TERMINATIO N DATE
  35905   "RTN","CHM XPU041",23 9,0)
  35906    ...I DOS< $P(^CHMICD X(DICI,0), "^",22)  D                            ; CHE CK EFFECTI VE DATE AG AINST DOS
  35907   "RTN","CHM XPU041",24 0,0)
  35908    ....D DEB UG^CHMXDR0 1("     DX QUAL^CHMXP U04 DOS: " _DOS_" BEF ORE ICD-10  EFFECTIVE  DATE:",$P (^CHMICDX( DICI,0),"^ ",22))
  35909   "RTN","CHM XPU041",24 1,0)
  35910    ....S CHE DRJ="E41J2 a" D RCDER R^CHMXPU01                            ; SET  EARLY REJ ECT FOR IC D-10 DIAG/ NO TERM DA TE, DOS BE FORE EFFEC TIVE DATE
  35911   "RTN","CHM XPU041",24 2,0)
  35912    ..E  I (( DOS<$P(^CH MICDX(DICI ,0),"^",22 ))!(DOS>$P (^CHMICDX( DICI,0),"^ ",23)))  D         ;  CHECK DOS  AGAINST IC D-10 CODE  EFFECTIVE/ TERMINATIO N DATES
  35913   "RTN","CHM XPU041",24 3,0)
  35914    ...D DEBU G^CHMXDR01 ("     DXQ UAL^CHMXPU 04 DOS: "_ DOS_" OUTS IDE ICD-10  EFF/TERM  DATES:",$P (^CHMICDX( DICI,0),"^ ",22)_"/"_ $P(^CHMICD X(DICI,0), "^",23))
  35915   "RTN","CHM XPU041",24 4,0)
  35916    ...S CHED RJ="E41J2a " D RCDERR ^CHMXPU01                            ; SET  EARLY REJE CT ICD-10  DIAG OUTSI DE EFF/TER M DATES
  35917   "RTN","CHM XPU041",24 5,0)
  35918    .E  D                                                                ; CODE  IS ICD-9  DIAG CODE
  35919   "RTN","CHM XPU041",24 6,0)
  35920    ..I DOS>$ P(^CHMICDX (DICI,0)," ^",23)  D                            ; CHEC K SVC "TO"  DATE AGAI NST ICD-9  TERMINATIO N DATE
  35921   "RTN","CHM XPU041",24 7,0)
  35922    ...D DEBU G^CHMXDR01 ("     DXQ UAL^CHMXPU 04 DOS: "_ DOS_" AFTE R ICD-9 TE RM DATE:", $P(^CHMICD X(DICI,0), "^",23))
  35923   "RTN","CHM XPU041",24 8,0)
  35924    ...S CHED RJ="E41J2a " D RCDERR ^CHMXPU01                               ; S ET EARLY R EJECT, ICD -9 DOS AFT ER TERMNAT ION DATE
  35925   "RTN","CHM XPU041",24 9,0)
  35926    E  D
  35927   "RTN","CHM XPU041",25 0,0)
  35928    .I ($$CLM TYPE^CHMXP 010()="A") &(CHXREC[" E")  D                       ; " A"=INST,"B "=PROF,C=D NTL
  35929   "RTN","CHM XPU041",25 1,0)
  35930    ..D DEBUG ^CHMXDR01( "     DXQU AL^CHMXPU0 4  INVALID  DOS: ",DO S)
  35931   "RTN","CHM XPU041",25 2,0)
  35932    ..S CHEDR J="E401a"  D RCDERR^C HMXPU01                                 ; S ET EARLY R EJECT, INV ALID DOS
  35933   "RTN","CHM XPU041",25 3,0)
  35934   XDXQUAL  K  CHHCQLF,C HDIF,CHEND  Q
  35935   "RTN","CHM XPU041",25 4,0)
  35936    ;
  35937   "RTN","CHM XPU041",25 5,0)
  35938    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  35939   "RTN","CHM XPU041",25 6,0)
  35940    ; GET THE  DATE OF S ERVICE. IF  CLAIM LEV EL RECORDS , GET FROM  ^CHMXCLE;  
  35941   "RTN","CHM XPU041",25 7,0)
  35942    ; OTHERWI SE GET IT  FROM ^CHMX CLF
  35943   "RTN","CHM XPU041",25 8,0)
  35944    ; DETERMI NE IF CLAI M LEVEL OR  LINE LEVE L BY CHXRE C VALUE (" EXXX" VS " FXXX")
  35945   "RTN","CHM XPU041",25 9,0)
  35946    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  35947   "RTN","CHM XPU041",26 0,0)
  35948    ;
  35949   "RTN","CHM XPU041",26 1,0)
  35950   GETDOS() 
  35951   "RTN","CHM XPU041",26 2,0)
  35952    N CLMTYPE ,DOS,ERR,C HCLFI
  35953   "RTN","CHM XPU041",26 3,0)
  35954    S DOS="", ERR=0
  35955   "RTN","CHM XPU041",26 4,0)
  35956    S CLMTYPE =$$CLMTYPE ^CHMXP010( )                                     ; "A" =INST,"B"= PROF,C=DNT L
  35957   "RTN","CHM XPU041",26 5,0)
  35958    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CLAIM  TYPE= ",CL MTYPE
  35959   "RTN","CHM XPU041",26 6,0)
  35960    I CLMTYPE ="A"  D
  35961   "RTN","CHM XPU041",26 7,0)
  35962    .I '$D(^C HMXCLE(CHC LEI)) D  Q                                       ; NEE D TO GET T HE DOS; IF  NO CLAIM  INDEX, REJ ECT
  35963   "RTN","CHM XPU041",26 8,0)
  35964    ..S ERR=1
  35965   "RTN","CHM XPU041",26 9,0)
  35966    ..U 0 W:$ $ENVIR^CHT FLIB'="LIV E" !,"NO ^ CHMXCLE(", CHCLEI,")  NODE"
  35967   "RTN","CHM XPU041",27 0,0)
  35968    .I $P(^CH MXCLE(CHCL EI,1),"^", 2)=""  D   Q
  35969   "RTN","CHM XPU041",27 1,0)
  35970    ..S ERR=1
  35971   "RTN","CHM XPU041",27 2,0)
  35972    ..U 0 W:$ $ENVIR^CHT FLIB'="LIV E" !,"NO S TATEMENT " "TO"" DATE  ENTRY @^C HMXCLE(",C HCLEI,",1) ,""^"",2)"
  35973   "RTN","CHM XPU041",27 3,0)
  35974    .S:'ERR D OS=$P(^CHM XCLE(CHCLE I,1),"^",2 )                           ; ST ATEMENT DA TE FOR INS TITUTIONAL  CLAIM
  35975   "RTN","CHM XPU041",27 4,0)
  35976    .S DOS=$$ YR8FMYR^CH TFLIB(DOS)                                        ; ^C HMXCLE() S TORES DOS  AS YYYYMMD D, ^CHMICD X() STORES  AS FM DAT E
  35977   "RTN","CHM XPU041",27 5,0)
  35978    E  D
  35979   "RTN","CHM XPU041",27 6,0)
  35980    .U 0 W:$$ ENVIR^CHTF LIB'="LIVE " !,"CHMXP U04: GETDO S: CHCLEI=  ",CHCLEI, "  $D(^CHM XCLF(""B"" ,",CHCLEI, ")= ",$D(^ CHMXCLF("B ",CHCLEI))
  35981   "RTN","CHM XPU041",27 7,0)
  35982    .I CHXREC ["E"  D  Q
  35983   "RTN","CHM XPU041",27 8,0)
  35984    ..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."
  35985   "RTN","CHM XPU041",27 9,0)
  35986    .E  I CHX REC["F"  D
  35987   "RTN","CHM XPU041",28 0,0)
  35988    ..I '$D(^ CHMXCLF("B ",CHCLEI))   D  Q                               ; VERI FY ^CHMXCL F CROSS-RE FERENCE
  35989   "RTN","CHM XPU041",28 1,0)
  35990    ...S ERR= 1
  35991   "RTN","CHM XPU041",28 2,0)
  35992    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  ^CHMXCLF(" "B"",",CHC LEI,"(^CHM XCLE()INDE X)) XREF"
  35993   "RTN","CHM XPU041",28 3,0)
  35994    ..S CHCLF I=0,CHCLFI =$O(^CHMXC LF("B",CHC LEI,CHCLFI ))                                                ; GE T THE ^CHM XCLF INDEX
  35995   "RTN","CHM XPU041",28 4,0)
  35996    ..I '$D(^ CHMXCLF(CH CLFI,1))   D  Q
  35997   "RTN","CHM XPU041",28 5,0)
  35998    ...S ERR= 1
  35999   "RTN","CHM XPU041",28 6,0)
  36000    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  ^CHMXCLF(" ,CHCLFI,", 1) NODE"              ; CHECK TH E DOS NODE
  36001   "RTN","CHM XPU041",28 7,0)
  36002    ..I ($P(^ CHMXCLF(CH CLFI,1),"^ ",12)="")& ($P(^CHMXC LF(CHCLFI, 1),"^",11) ="")  D
  36003   "RTN","CHM XPU041",28 8,0)
  36004    ...S ERR= 1
  36005   "RTN","CHM XPU041",28 9,0)
  36006    ...U 0 W: $$ENVIR^CH TFLIB'="LI VE" !,"NO  STATEMENT  ""FROM/TO" " DATES @^ CHMXCLF(", CHCLFI,",1 ),""^"",11 /12)" 
  36007   "RTN","CHM XPU041",29 0,0)
  36008    ..I 'ERR   D
  36009   "RTN","CHM XPU041",29 1,0)
  36010    ...S DOS= $P(^CHMXCL F(CHCLFI,1 ),"^",12)                           ; SERVI CE LINE ST ATEMENT "T O" DATE
  36011   "RTN","CHM XPU041",29 2,0)
  36012    ...S:DOS= "" DOS=$P( ^CHMXCLF(C HCLFI,1)," ^",11)                   ; SERVI CE LINE ST ATEMENT "F ROM" DATE
  36013   "RTN","CHM XPU041",29 3,0)
  36014    ...S DOS= $$YR8FMYR^ CHTFLIB(DO S)                                  ; SVC L INE STORES  DOS AS YY YYMMDD, ^C HMICDX() S TORES AS F M DATE
  36015   "RTN","CHM XPU041",29 4,0)
  36016    Q DOS
  36017   "RTN","CHM XPU041",29 5,0)
  36018    ;                                  
  36019   "RTN","CHM XPU041",29 6,0)
  36020    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  36021   "RTN","CHM XPU041",29 7,0)
  36022    ; THE FOL LOWING COD E WAS DISA BLED FOR 5 010 IMPLEM ENTATION
  36023   "RTN","CHM XPU041",29 8,0)
  36024    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  36025   "RTN","CHM XPU041",29 9,0)
  36026    ;
  36027   "RTN","CHM XPU041",30 0,0)
  36028   PDXCD    ; THIS CODE  INSERTS TH E PRIMARY  DIAG CODE  INTO ^CHMX CLE(I,42)- --DON'T DO  THAT IN 5 010
  36029   "RTN","CHM XPU041",30 1,0)
  36030    Q  
  36031   "RTN","CHM XPU041",30 2,0)
  36032    ;INFERS A DM DX FROM  PRINCIPAL  DX IF NO  ADM DX COD E
  36033   "RTN","CHM XPU041",30 3,0)
  36034    D DEBUG^C HMXDR01("C HMXPU04: P DXCD CHFLD (CHFLPN)=  ",CHFLD(CH FLPN))
  36035   "RTN","CHM XPU041",30 4,0)
  36036    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)
  36037   "RTN","CHM XPU041",30 5,0)
  36038    I ZZTOS'= "" I ($P(^ CHMXCLE(CH CLEI,0),"^ ",5)="A")& ($D(^CHMXD IC(741201. 03,"D",1,Z ZTOS))) D   G PDXCD1
  36039   "RTN","CHM XPU041",30 6,0)
  36040    .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
  36041   "RTN","CHM XPU041",30 7,0)
  36042    .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
  36043   "RTN","CHM XPU041",30 8,0)
  36044    .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
  36045   "RTN","CHM XPU041",30 9,0)
  36046    .I '$D(^C HMXCLE(CHC LEI,42)) D
  36047   "RTN","CHM XPU041",31 0,0)
  36048    ..S:'$D(^ CHMXCLE(CH CLEI,42,0) ) ^CHMXCLE (CHCLEI,42 ,0)="^7412 10.1242^0^ 0"
  36049   "RTN","CHM XPU041",31 1,0)
  36050    ..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
  36051   "RTN","CHM XPU041",31 2,0)
  36052    ..D DEBUG ^CHMXMDRV( "CHMXPU04:  PDXCD 'J'  = ",EI)
  36053   "RTN","CHM XPU041",31 3,0)
  36054    ..S $P(^C HMXCLE(CHC LEI,42,EI, 0),"^")=$P (^CHMXCLE( CHCLEI,40, 1,0),"^",1 )
  36055   "RTN","CHM XPU041",31 4,0)
  36056    ..S ^CHMX CLE(CHCLEI ,42,"B",$P (^CHMXCLE( CHCLEI,40, 1,0),"^"), EI)=""
  36057   "RTN","CHM XPU041",31 5,0)
  36058   PDXCD1   K  CHCODE,ZZ TOS Q
  36059   "RTN","CHM XPU041",31 6,0)
  36060    ; 
  36061   "RTN","CHM XPU041",31 7,0)
  36062   GTHCQLF  I  '$D(RCD)  S CHEDPRB= "" G GTHCQ LF1
  36063   "RTN","CHM XPU041",31 8,0)
  36064    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HHCQLF=$$T RIM^CHMXPU 01(Y)
  36065   "RTN","CHM XPU041",31 9,0)
  36066    U 0 W:$$E NVIR^CHTFL IB'="LIVE"  !,"CHMXPU 04: GTHCQL F():  CHHC QLF= ",CHH CQLF
  36067   "RTN","CHM XPU041",32 0,0)
  36068    ;I CHHCQL F="" S CHE DPRB="" Q
  36069   "RTN","CHM XPU041",32 1,0)
  36070   GTHCQLF1 K  Y Q
  36071   "RTN","CHM XPU041",32 2,0)
  36072    ;
  36073   "RTN","CHM XPU041",32 3,0)
  36074    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  36075   "RTN","CHM XPU041",32 4,0)
  36076    ; FORMAT  THE DIAGNO STIC CODES  FOR ICD-9  AND ICD-1 0
  36077   "RTN","CHM XPU041",32 5,0)
  36078    ; AT ENTR Y, CHFLD(C HFLPN) CON TAINS THE  DIAGNOSTIC  CODE TO B E FORMATTE D, AND "JZ "
  36079   "RTN","CHM XPU041",32 6,0)
  36080    ; CONTAIN S THE LOCA TION (FROM  THE LEFT)  AT WHICH  TO INSERT  THE "." FO R THE CODE
  36081   "RTN","CHM XPU041",32 7,0)
  36082    ; NOTE: W HEN THE DI AG CODES A RRIVE IN C HMXPU04, T HERE IS A  LEADING "E " IN 
  36083   "RTN","CHM XPU041",32 8,0)
  36084    ; CHFLD(C HFLPN). TH E "E" CODE  IS A SPEC IAL CASE F ROM OSHA(? ) THAT IS  DIFFERENT
  36085   "RTN","CHM XPU041",32 9,0)
  36086    ; FROM AL L OTHER DI AGNOSIS CO DES, THIS  CAUSES THE  $E(CHFLD( CHFLPN)) T O LOCATE T HE 
  36087   "RTN","CHM XPU041",33 0,0)
  36088    ; "." IN  A DIFFEREN T LOCATION  FOR THESE  DIAG CODE S. FOR THI S REASON,  THERE IS A
  36089   "RTN","CHM XPU041",33 1,0)
  36090    ; ADDER T O THE "JZ"  VALUE TO  CORRECTLY  LOCATE THE  DESIRED " ." IN THE  FORMAT. DL B 9/25/201 5
  36091   "RTN","CHM XPU041",33 2,0)
  36092    ; DEBUG F OR DEF0191 58; MODIFI ED THE LOG IC TO ENSU RE THE COR RECT FORMA TTING DLB  10/23/2015
  36093   "RTN","CHM XPU041",33 3,0)
  36094    ; 2/1/201 6 FIX THE  FORMATTING  ISSUE FOR  "BK" 311  ICD-9 DIAG NOSIS CODE S
  36095   "RTN","CHM XPU041",33 4,0)
  36096    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36097   "RTN","CHM XPU041",33 5,0)
  36098    ; 
  36099   "RTN","CHM XPU041",33 6,0)
  36100   STFRMT   ; SETS FORMA T FOR DX/P X CODES
  36101   "RTN","CHM XPU041",33 7,0)
  36102    D DEBUG^C HMXDR01("           C HMXPU04: S TFRMT(): C HFLD(CHFLP N)="""_CHF LD(CHFLPN) _"""  $L(C HFLD(CHFLP N)="_$L(CH FLD(CHFLPN ))_"  JZ=" _JZ_"  $E( CHFLD(CHFL PN),1,JZ)= ",$E(CHFLD (CHFLPN),1 ,JZ))
  36103   "RTN","CHM XPU041",33 8,0)
  36104    I $L(CHHC QLF)=2 D                                                                             ;  ICD-9 CODE  QUALIFIER S ARE 2 DI GITS
  36105   "RTN","CHM XPU041",33 9,0)
  36106    .I $E(CHF LD(CHFLPN) ,1,1)="E"   D                       ; IF TH ERE IS A L EADING "E"  FOR DIAG  CODE          
  36107   "RTN","CHM XPU041",34 0,0)
  36108    ..S:$L(CH FLD(CHFLPN ))>JZ+1 CH FLD(CHFLPN )=$E(CHFLD (CHFLPN),1 ,JZ+1)_"." _$E(CHFLD( CHFLPN),JZ +2,99)
  36109   "RTN","CHM XPU041",34 1,0)
  36110    .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
  36111   "RTN","CHM XPU041",34 2,0)
  36112    .I (CHFLD (CHFLPN))[ "." D                                                                     ;  ENSURE THE RE IS A ". " IN THE C ODE BEFORE  GOING FOR WARD
  36113   "RTN","CHM XPU041",34 3,0)
  36114    ..I $P(CH FLD(CHFLPN ),".",2)=" " D                         ; IF  NO VALUES  AFTER THE  ".", NO " ." REQUIRE D
  36115   "RTN","CHM XPU041",34 4,0)
  36116    ...S CHFL PNLG=$L(CH FLD(CHFLPN )),CHFLD(C HFLPN)=$E( CHFLD(CHFL PN),1,CHFL PNLG-1)
  36117   "RTN","CHM XPU041",34 5,0)
  36118    ...K CHFL PNLG
  36119   "RTN","CHM XPU041",34 6,0)
  36120    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
  36121   "RTN","CHM XPU041",34 7,0)
  36122    D DEBUG^C HMXDR01("           C HMXPU04: E XIT STFRMT (): CHFLD( CHFLPN)= " ,CHFLD(CHF LPN))
  36123   "RTN","CHM XPU041",34 8,0)
  36124   STFRMT1  K  JZ Q
  36125   "RTN","CHM XPU041",34 9,0)
  36126    ; 
  36127   "RTN","CHM XPU041",35 0,0)
  36128   STTC     ; SETS FORMA T FOR TC C ODES
  36129   "RTN","CHM XPU041",35 1,0)
  36130    Q
  36131   "RTN","CHM XPU041",35 2,0)
  36132    ; 
  36133   "RTN","CHM XPU041",35 3,0)
  36134   STDR     ; SETS FORMA T FOR DR C ODES
  36135   "RTN","CHM XPU041",35 4,0)
  36136    Q
  36137   "RTN","CHM XPU041",35 5,0)
  36138    ; 
  36139   "RTN","CHM XPU041",35 6,0)
  36140   SETDTA   ; SETS APPRO PRIATE HC  CODE DATA  UP IN CHDT A ARRAYS
  36141   "RTN","CHM XPU041",35 7,0)
  36142    D DEBUG^C HMXDR01("         CHM XPU04: SET DTA CHFLD( CHFLPN)= " "",CHFLD(C HFLPN)_""" ^"_CHSUB1_ "^"_CHSUB2 )
  36143   "RTN","CHM XPU041",35 8,0)
  36144    Q:CHSUB1= "NONE"
  36145   "RTN","CHM XPU041",35 9,0)
  36146    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)
  36147   "RTN","CHM XPU041",36 0,0)
  36148    .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
  36149   "RTN","CHM XPU041",36 1,0)
  36150    S CHVAR=9 999,CHVAR= $O(CHDTA(C HSUB1,CHSU B2,CHVAR), -1)+1
  36151   "RTN","CHM XPU041",36 2,0)
  36152    I CHSUB1= 49 D  G SE TDTA1
  36153   "RTN","CHM XPU041",36 3,0)
  36154    .;S CHDTA (CHSUB1,CH SUB2,CHVAR )=CHEDRJ_" *"_CHFLD(C HFLPN)
  36155   "RTN","CHM XPU041",36 4,0)
  36156    .I $D(CHX STYP) Q:CH XSTYP=1  ;  QUIT IF O CR -- NO R EJECTS REC ORDED
  36157   "RTN","CHM XPU041",36 5,0)
  36158    .Q:$G(CHE DRJ)="NONE "        ;  QUIT NO E RRORS ARE  TO BE RECO RDED 
  36159   "RTN","CHM XPU041",36 6,0)
  36160    .S CHRCER R(CHXREC,C HEDRJ)="", CHLVLRJ("E ")="" 
  36161   "RTN","CHM XPU041",36 7,0)
  36162    S CHDTA(C HSUB1,CHSU B2,CHVAR)= CHFLD(CHFL PN)
  36163   "RTN","CHM XPU041",36 8,0)
  36164   SETDTA1  K  CHSUB1,CH SUB2,CHVAR  Q
  36165   "RTN","CHM XPU041",36 9,0)
  36166    ; 
  36167   "RTN","CHM XPU041",37 0,0)
  36168   BTQICT   ; MATCH BILL  TYPE QUAL IFIER TO I C TYPE
  36169   "RTN","CHM XPU041",37 1,0)
  36170    Q:$D(CHRC ERR(CHXREC ,"E05a"))   Q:'$D(^CH MXCLA(CHCL AI,0))
  36171   "RTN","CHM XPU041",37 2,0)
  36172    S CHICTYP =$E($P(^CH MXCLA(CHCL AI,0),"^", 14),7,99)  Q:CHICTYP= ""
  36173   "RTN","CHM XPU041",37 3,0)
  36174    I (CHFLD( CHFLPN)="A ")&(CHICTY P'="HOSP")  D RCDERR^ CHMXPU01 G  BTQICT1
  36175   "RTN","CHM XPU041",37 4,0)
  36176    I (CHFLD( CHFLPN)="B ")&(CHICTY P'="PHYS")  D RCDERR^ CHMXPU01 G  BTQICT1
  36177   "RTN","CHM XPU041",37 5,0)
  36178   BTQICT1  K  CHICTYP Q
  36179   "RTN","CHM XPU041",37 6,0)
  36180    ; 
  36181   "RTN","CHM XPU041",37 7,0)
  36182   GETODT   ; PULLS THE  TO DATE FO R OCC/OCC  SPAN CODES  TO COMPAR E TO THRU  DATE
  36183   "RTN","CHM XPU041",37 8,0)
  36184    I '$D(RCD ) S CHEDPR B="" G GET ODT1
  36185   "RTN","CHM XPU041",37 9,0)
  36186    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HTODT=$$TR IM^CHMXPU0 1(Y)
  36187   "RTN","CHM XPU041",38 0,0)
  36188   GETODT1  Q
  36189   "RTN","CHM XPU041",38 1,0)
  36190    ; 
  36191   "RTN","CHM XPU041",38 2,0)
  36192   GETHRDT  ; PULLS THE  THROUGH DA TE FOR OCC /OCC SPAN  CODES TO C OMPARE TO  TO DATE
  36193   "RTN","CHM XPU041",38 3,0)
  36194    I '$D(RCD ) S CHEDPR B="" G GET HRDT1
  36195   "RTN","CHM XPU041",38 4,0)
  36196    S Y=$E(RC D,CHFLST-C HDIF,CHFLS T-CHEND),C HTHRDT=$$T RIM^CHMXPU 01(Y)
  36197   "RTN","CHM XPU041",38 5,0)
  36198   GETHRDT1 Q
  36199   "RTN","CHM XPU041",38 6,0)
  36200    ; 
  36201   "RTN","CHM XPU041",38 7,0)
  36202   ICNDCNMS ; MISSING IC N/DCN # WH EN CLAIM F REQUENCY =  5,7 OR 8
  36203   "RTN","CHM XPU041",38 8,0)
  36204    Q:$D(CHRC ERR(CHXREC ,"E33a"))   Q:'$D(^CH MXCLE(CHCL EI,0))
  36205   "RTN","CHM XPU041",38 9,0)
  36206    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6) Q :'CHFREQ
  36207   "RTN","CHM XPU041",39 0,0)
  36208    I (((CHFR EQ=7)!(CHF REQ=8))&(C HFLD(CHFLP N)="")) D  RCDERR^CHM XPU01 G IC NDCN1
  36209   "RTN","CHM XPU041",39 1,0)
  36210    I CHFREQ= 8 D  G ICN DCN1
  36211   "RTN","CHM XPU041",39 2,0)
  36212    .Q:'$D(^C HMPAY("B", CHFLD(CHFL PN)))
  36213   "RTN","CHM XPU041",39 3,0)
  36214    .S CHMXCL MI=0,CHMXC LMI=$O(^CH MPAY("B",C HFLD(CHFLP N),CHMXCLM I))
  36215   "RTN","CHM XPU041",39 4,0)
  36216    .Q:CHMXCL MI=""
  36217   "RTN","CHM XPU041",39 5,0)
  36218    .S CHMXCL M=CHFLD(CH FLPN)
  36219   "RTN","CHM XPU041",39 6,0)
  36220    .D ^CHMXM M06 Q
  36221   "RTN","CHM XPU041",39 7,0)
  36222   ICNDCN1  K  CHFREQ,CH MXCLMI,CHM XCLM Q
  36223   "RTN","CHM XPU041",39 8,0)
  36224    ; 
  36225   "RTN","CHM XPU041",39 9,0)
  36226    ;Methodic al-5010 Ch ange-Begin
  36227   "RTN","CHM XPU041",40 0,0)
  36228   ICNBLANK ; BLANK OR N O MATCHING  ICN/DCN #  WHEN CLAI M FREQUENC Y = 7 OR 8
  36229   "RTN","CHM XPU041",40 1,0)
  36230    N CHFREQ
  36231   "RTN","CHM XPU041",40 2,0)
  36232    Q:'$D(^CH MXCLE(CHCL EI,0))
  36233   "RTN","CHM XPU041",40 3,0)
  36234    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6) Q :'CHFREQ
  36235   "RTN","CHM XPU041",40 4,0)
  36236    Q:CHFREQ' =7&(CHFREQ '=8)
  36237   "RTN","CHM XPU041",40 5,0)
  36238    I CHFLD(C HFLPN)=""  D RCDERR^C HMXPU01 Q
  36239   "RTN","CHM XPU041",40 6,0)
  36240    Q:$D(^CHM PAY("B",CH FLD(CHFLPN )))!($D(^C HMIMAGE(CH FLD(CHFLPN ))))
  36241   "RTN","CHM XPU041",40 7,0)
  36242    D RCDERR^ CHMXPU01 
  36243   "RTN","CHM XPU041",40 8,0)
  36244    Q
  36245   "RTN","CHM XPU041",40 9,0)
  36246   ICNVOID  ;  New routi ne to emai l and set  claims sta tus
  36247   "RTN","CHM XPU041",41 0,0)
  36248    N CHFREQ
  36249   "RTN","CHM XPU041",41 1,0)
  36250    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  36251   "RTN","CHM XPU041",41 2,0)
  36252    Q:(CHFREQ '=7)&(CHFR EQ'=8)
  36253   "RTN","CHM XPU041",41 3,0)
  36254    ; gef cpe 005-033 in valid PDI,  if not 15  character s or does  not exist  in image f ile, rejec t with E33 a, if null  reject wi th E33b
  36255   "RTN","CHM XPU041",41 4,0)
  36256    I CHFLD(C HFLPN)=""  S CHEDRJ=" E33b" D RC DERR^CHMXP U01 Q
  36257   "RTN","CHM XPU041",41 5,0)
  36258    ; GEF CPE 005-038 -  Original P DI is vali d but not  processed  (Freq code =8), rejec t with E33 c but don' t send rec oup email.
  36259   "RTN","CHM XPU041",41 6,0)
  36260    I CHFREQ= 8,$$REMV^C HMXPUTL(CH FLD(CHFLPN )) D RCDER R^CHMXPU01  Q
  36261   "RTN","CHM XPU041",41 7,0)
  36262    I CHFREQ= 8,'$$VALD^ CHMXPUTL(C HFLD(CHFLP N)) S CHED RJ="E33a"  D RCDERR^C HMXPU01 Q
  36263   "RTN","CHM XPU041",41 8,0)
  36264    I CHFREQ= 8,CHFLD(CH FLPN)'=""  D  Q
  36265   "RTN","CHM XPU041",41 9,0)
  36266    . D RCDER R^CHMXPU01
  36267   "RTN","CHM XPU041",42 0,0)
  36268    . S CHMXC LM=CHFLD(C HFLPN) D ^ CHMXMM06
  36269   "RTN","CHM XPU041",42 1,0)
  36270    ;I CHFLD( CHFLPN)=""  S CHEDRJ= "E33b" D R CDERR^CHMX PU01
  36271   "RTN","CHM XPU041",42 2,0)
  36272    Q
  36273   "RTN","CHM XPU041",42 3,0)
  36274   ICNNULL  ;  New funct ion to rej ect for nu ll PDI and  Frequency  Code 5
  36275   "RTN","CHM XPU041",42 4,0)
  36276    N CHFREQ
  36277   "RTN","CHM XPU041",42 5,0)
  36278    S CHFREQ= $P(^CHMXCL E(CHCLEI,0 ),"^",6)
  36279   "RTN","CHM XPU041",42 6,0)
  36280    Q:(CHFREQ '=5)
  36281   "RTN","CHM XPU041",42 7,0)
  36282    ; lem cpe 005-040 nu ll PDI, re ject with  E33b
  36283   "RTN","CHM XPU041",42 8,0)
  36284    ;I CHFLD( CHFLPN)=""  S CHEDRJ= "E33b" D R CDERR^CHMX PU01 Q
  36285   "RTN","CHM XPU041",42 9,0)
  36286    I CHFLD(C HFLPN)=""  D CSTAT^CH MXPUTL5(CH MCPDI,"A6: 21:464") Q
  36287   "RTN","CHM XPU041",43 0,0)
  36288    I CHFREQ= 5,CHFLD(CH FLPN)'=""  D  Q
  36289   "RTN","CHM XPU041",43 1,0)
  36290    . D RCDER R^CHMXPU01
  36291   "RTN","CHM XPU041",43 2,0)
  36292    . S CHMXC LM=CHFLD(C HFLPN) D ^ CHMXMM06
  36293   "RTN","CHM XPU041",43 3,0)
  36294    Q ;Method ical-5010  Change-End
  36295   "RTN","CHM XPU041",43 4,0)
  36296    
  36297   "RTN","CHM XWB21")
  36298   0^65^B1706 402409
  36299   "RTN","CHM XWB21",1,0 )
  36300   CHMXWB21 ; HAC/DLB;WE B 5010 277  UNSOLICIT ED STATUS/ DRIVER PAR T 1;10/25/ 10
  36301   "RTN","CHM XWB21",2,0 )
  36302    ;;1.0;CHA MPVA SYSTE M;**003**; JULY 11,20 11;Build 5
  36303   "RTN","CHM XWB21",3,0 )
  36304    ;; 5/15/1 3 JWS:HARR IS - HAPE  POR DO#118 -11-D-1009 , TO#118-1 009-0001
  36305   "RTN","CHM XWB21",4,0 )
  36306    ;;V1.0;
  36307   "RTN","CHM XWB21",5,0 )
  36308    ;;CALLED  BY ^CHMXG0 01 TO PERF ORM THE "A CK" STATUS
  36309   "RTN","CHM XWB21",6,0 )
  36310    ;;CALLED  BY TASKMAN  TO PERFOR M THE "PEN DING" AND  "FINAL" ST ATUS
  36311   "RTN","CHM XWB21",7,0 )
  36312    ;;CALLS E NTRY POINT S TO CHMXW B22,CHMXWB UT
  36313   "RTN","CHM XWB21",8,0 )
  36314    ;HR-COB-M edicare-A/ B-Begin-93 72 (27-May -2010)
  36315   "RTN","CHM XWB21",9,0 )
  36316    ;;
  36317   "RTN","CHM XWB21",10, 0)
  36318    ;; 10/18/ 2011 ADDED  TSTBLDCLM () ENTRY P OINT TO VA LIDATE THE  REJECT
  36319   "RTN","CHM XWB21",11, 0)
  36320    ;;             VALUE S BEING RE PORTED IN  THE CSTAT  FILE
  36321   "RTN","CHM XWB21",12, 0)
  36322    ;; 10/20/ 2011 MODIF IED THE LI NE() FUNCT ION TO FIX  INCORRECT  REJECT ST ATUS
  36323   "RTN","CHM XWB21",13, 0)
  36324    ;;               REP ORTING IN  THE CSTAT  FILE
  36325   "RTN","CHM XWB21",14, 0)
  36326    ;; 10/21/ 2011 ADDED  THE SIX D ATE GATHER ING FUNCTI ONS TO SUP PORT THE R ULE 
  36327   "RTN","CHM XWB21",15, 0)
  36328    ;;               PRO VIDED BY B USINESS GR OUP FOR I/ P/D CLAIMS
  36329   "RTN","CHM XWB21",16, 0)
  36330    ;; 10/21/ 2011 ADDED  THE GETCL MTYP() FUN CTION TO D ETERMINE T HE I/P/D
  36331   "RTN","CHM XWB21",17, 0)
  36332    ;;             CLAIM  TYPE FOR  BOTH 4010  AND 5010 I NCOMING CL AIMS
  36333   "RTN","CHM XWB21",18, 0)
  36334    ;; 10/24/ 2011 CHANG ED THE DAT ERANGE FUN CTION TO A  EXISTING  DATE FUNCT ION
  36335   "RTN","CHM XWB21",19, 0)
  36336    ;;               IN  THE UTILIT Y ROUTINE:  CHMXWBUT. INT
  36337   "RTN","CHM XWB21",20, 0)
  36338    ;; 10/25/ 2011 CHANG ED THE REN DERING PHY SICIAN NPI  RETRIEVAL  TO GET TH E
  36339   "RTN","CHM XWB21",21, 0)
  36340    ;;             DATA  FROM THE C HMXCLE(I,6 4) TIN DAT A FIELD.
  36341   "RTN","CHM XWB21",22, 0)
  36342    ;; 10/25/ 2011 ADDED  A TEST FO R THE "U"  VALUE RECE IVED FROM  EMDEON TO
  36343   "RTN","CHM XWB21",23, 0)
  36344    ;;             RETUR N "" IF NO T A "M" OR  "F" (ONLY  ACCEPTED  VALUES)
  36345   "RTN","CHM XWB21",24, 0)
  36346    ;; 10/26/ 2011 REMOV ED ERROR M ESSAGE OUT PUT FOR ER ROR TRAP H ANDLER 
  36347   "RTN","CHM XWB21",25, 0)
  36348    ;; 
  36349   "RTN","CHM XWB21",26, 0)
  36350    ;; 10/26/ 2011 CHANG ED THE INS TITUTIONAL  AND DENTA L START/EN D DATES
  36351   "RTN","CHM XWB21",27, 0)
  36352    ;;             FOR C LAIM LEVEL  REPORTING  TO GET ST ART FROM ^ CHMXCLE(I, 1)
  36353   "RTN","CHM XWB21",28, 0)
  36354    ;;             ,FIEL D 1 AND EN D TO ^CHMX CLE(I,1) F IELD 2
  36355   "RTN","CHM XWB21",29, 0)
  36356    ;; 11/4/2 011  CHANG ED THE DAT E CHECK RO UTINE GETC LMI() TO R ETURN THE
  36357   "RTN","CHM XWB21",30, 0)
  36358    ;;             CORRE CT DATE FO R THE DESI RED FLAG 
  36359   "RTN","CHM XWB21",31, 0)
  36360    ;; 05/15/ 2013 HAPE  POR DO#118 -11-D-1009 , TO#118-1 009-0001 -  added
  36361   "RTN","CHM XWB21",32, 0)
  36362    ;;             FINAL  STATUS fi le creatio n.
  36363   "RTN","CHM XWB21",33, 0)
  36364    ;; 02/05/ 2014 MTN02 0286-01 -  YJK: Reduc e the Pend ing CSTAT  File Size  for 140MB  to 5 MB fo r Testing 
  36365   "RTN","CHM XWB21",34, 0)
  36366    ;;             ** TH IS CHANGE  IS ONLY FO R QA.  THI S CHANGE I S TO BE RE MOVED WHEN  GOING LIV E **
  36367   "RTN","CHM XWB21",35, 0)
  36368    ;; 02/10/ 2014 SBB D EV020322   POR: Chang e to the " E" Referen ce for RUN DATE 
  36369   "RTN","CHM XWB21",36, 0)
  36370    ;;                 t o ^CHMPAY( I,10) piec e 23 and M  cross ref erence for  FILE RUN  DATE
  36371   "RTN","CHM XWB21",37, 0)
  36372    ;; 01/18/ 2018 CFS C PE005-043  - Look for  Reopen Re ject Reaso ns and ove rride 
  36373   "RTN","CHM XWB21",38, 0)
  36374    ;;                 C HRJARR(1,1 ) with app ropriate e rror code.
  36375   "RTN","CHM XWB21",39, 0)
  36376    ;; 5/1/20 18 DLB MOD IFIED THE  EPPEND() F UNCTION TO  SKIP FILE  CREATION  IF NO RECO RD COUNT,
  36377   "RTN","CHM XWB21",40, 0)
  36378    ;;                 B UT STILL U PDATE THE  ^CHMX277 T O UPDATE T HE "TO" AN D "FROM" I NDEXES.
  36379   "RTN","CHM XWB21",41, 0)
  36380    ;;                 T HIS ELIMIN ATES REDUN DANT CHECK S ON UNREL ATED PAYME NT RECORDS .
  36381   "RTN","CHM XWB21",42, 0)
  36382    ;;
  36383   "RTN","CHM XWB21",43, 0)
  36384    ;;1.0 IS  THE INITIA L VERSION  (HIPAA Rea dy LLC) 
  36385   "RTN","CHM XWB21",44, 0)
  36386    ;;2.0 UPD ATES TO TH E STATUS R EPORT PER  HIPAA II S PECIFICATI ONS.
  36387   "RTN","CHM XWB21",45, 0)
  36388    ;;  *** F ilenames s hould not  be hard co ded in fil es. See ^C HMX277 TRA CKING
  36389   "RTN","CHM XWB21",46, 0)
  36390    ;;  GLOBA L FILE for  the desti nation dir ectory/fil enames for  the 5010  status
  36391   "RTN","CHM XWB21",47, 0)
  36392    ;;  files .
  36393   "RTN","CHM XWB21",48, 0)
  36394    Q
  36395   "RTN","CHM XWB21",49, 0)
  36396    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  36397   "RTN","CHM XWB21",50, 0)
  36398    ; PRODUCT ION ENTRY  POINTS TO  PROCESS TH E CURRENT  STATUS.         ;
  36399   "RTN","CHM XWB21",51, 0)
  36400    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  36401   "RTN","CHM XWB21",52, 0)
  36402    ;;DEF0165 54 -- REPL ACE OPEN C OMMAND WIT H EXTRINSI C FUNCTION  OPEN -- D RW 07/20/2 015
  36403   "RTN","CHM XWB21",53, 0)
  36404   EPACK(CHMX I) ; SET U P THE FILE /BATCH IND EX (PROVID ED BY CHMX G001)
  36405   "RTN","CHM XWB21",54, 0)
  36406       ;   CH MXI         I INDEX I NTO ^CHMXC L()
  36407   "RTN","CHM XWB21",55, 0)
  36408       N COUN T,DIRFILE, GRPCNT,FIL ECNT,LSTTI ME,HOLD,DA TESTAMP,ST VAL,RUNTYP E
  36409   "RTN","CHM XWB21",56, 0)
  36410       N FMDA TE,CHTPI,C HTPARR,CNT
  36411   "RTN","CHM XWB21",57, 0)
  36412       N MAXC NT,EICNT,C HA,CHMEDCO B
  36413   "RTN","CHM XWB21",58, 0)
  36414       S FILE CNT=0,RUNT YPE="A",GR PCNT=1,EIC NT=0
  36415   "RTN","CHM XWB21",59, 0)
  36416       S CHME DCOB=0  ;  ASSUME NOT  A "COB" T RADING PAR TNER
  36417   "RTN","CHM XWB21",60, 0)
  36418       D INIT
  36419   "RTN","CHM XWB21",61, 0)
  36420       ;SBB T esting
  36421   "RTN","CHM XWB21",62, 0)
  36422       S DEBU G=1
  36423   "RTN","CHM XWB21",63, 0)
  36424       S CHA= $O(^CHMXCL A("B",CHMX I,"")) Q:C HA=""
  36425   "RTN","CHM XWB21",64, 0)
  36426       S CHTP I=$P($G(^C HMXCLA(CHA ,1)),"^",1 ) Q:CHTPI= ""  ; GET  CLAIM T/P  FOR FILE B EING CHECK ED
  36427   "RTN","CHM XWB21",65, 0)
  36428       S CHTP I=$O(^CHMX TP("C",CHT PI,"")) Q: CHTPI="" D     ; GET  "LOCAL" TP  ID
  36429   "RTN","CHM XWB21",66, 0)
  36430       S IDX= $O(^CHMX27 7("B",CHTP I,0))
  36431   "RTN","CHM XWB21",67, 0)
  36432       S:$P(^ CHMX277(ID X,0),"^",4 )["COB" CH MEDCOB=1       ; TRAD ING PARTNE R 11 = "CO B" EMDEON  PARTNER
  36433   "RTN","CHM XWB21",68, 0)
  36434       D GETC HCLEI(CHMX I,CHTPI)   ; RETRIEVE  ^CHMXCLE  INDEX
  36435   "RTN","CHM XWB21",69, 0)
  36436       Q:^ZSC ($J,0)=0              ; NO RECOR DS FOUND,  CREATE NO  FILE
  36437   "RTN","CHM XWB21",70, 0)
  36438       D CREA TEFILE
  36439   "RTN","CHM XWB21",71, 0)
  36440       D FMUP DATE(CHTPI )          ; UPDATE T RACKING GL OBAL VIA F ILEMAN FUN CTION
  36441   "RTN","CHM XWB21",72, 0)
  36442       Q
  36443   "RTN","CHM XWB21",73, 0)
  36444       ;
  36445   "RTN","CHM XWB21",74, 0)
  36446   EPPENDTST  ;
  36447   "RTN","CHM XWB21",75, 0)
  36448       N TEST  S TEST=1
  36449   "RTN","CHM XWB21",76, 0)
  36450       D EPPE ND
  36451   "RTN","CHM XWB21",77, 0)
  36452       Q
  36453   "RTN","CHM XWB21",78, 0)
  36454       ;
  36455   "RTN","CHM XWB21",79, 0)
  36456       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  36457   "RTN","CHM XWB21",80, 0)
  36458       ; DLB  4_30_2018   MODIFIED  TO PERFORM  UPDATE IF  NO FILES  FOUND FOR  THE PENDIN G STATUS
  36459   "RTN","CHM XWB21",81, 0)
  36460       ; SXC  PHARMACY C LAIMS ARE  IN ^CHMPAY (), BUT WE  DO NOT RE PORT THESE  TO EMDEON
  36461   "RTN","CHM XWB21",82, 0)
  36462       ; INIT IALIZED CO UNT,DIRFIL E SO THAT  IF THE ^CH MPAY() IND EXES PRODU CE NO "PEN DING"
  36463   "RTN","CHM XWB21",83, 0)
  36464       ; STAT US RECORDS , THE FILE MAN UPDATE  WILL OCCU R. SXC PHA RMACY CLAI MS ARE NOT
  36465   "RTN","CHM XWB21",84, 0)
  36466       ; REPO RTED TO EM DEON, BUT  OCCUPY NOD ES IN ^CHM PAY(). TYP ICALLY 2 R EPORTS ARE
  36467   "RTN","CHM XWB21",85, 0)
  36468       ; GENE RATED: 1)  TRADING PA RTNER 6 (E NVOY) AND  TRADING PA RTNER 11 ( EMDEON COB )
  36469   "RTN","CHM XWB21",86, 0)
  36470       ; ^CHM XTP(6,0)=" ENVOY CORP ORATION^13 3052274^15  CENTURY B LVD^SUITE  600^NASHVI LLE^4"
  36471   "RTN","CHM XWB21",87, 0)
  36472       ; ^CHM XTP(11,0)= "EMDEON CO B^14330^15  CENTURY B LVD^SUITE  600^NASHVI LLE^47^372 14^80"
  36473   "RTN","CHM XWB21",88, 0)
  36474       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  36475   "RTN","CHM XWB21",89, 0)
  36476       ;
  36477   "RTN","CHM XWB21",90, 0)
  36478   EPPEND ;
  36479   "RTN","CHM XWB21",91, 0)
  36480       N COUN T,DIRFILE, GRPCNT,SEQ CNT,LSTTIM E,HOLD,DAT ESTAMP,STV AL,RUNTYPE ,FMDATE,CH TPI,CHTPAR R
  36481   "RTN","CHM XWB21",92, 0)
  36482       N CHNO DEDEF,BREF ,CHIJKVAL, DRDATA,TRK DATA,MAXCN T,CHMEDCOB ,IDX         ; FILEMA N UPDATE V ARIABLES
  36483   "RTN","CHM XWB21",93, 0)
  36484       N CHTO ,CHFROM,TR KI,EICNT,R ECCNT,DEBU G
  36485   "RTN","CHM XWB21",94, 0)
  36486       S RUNT YPE="P",GR PCNT=1,EIC NT=0,COUNT =0,DEBUG=0   ; INITIA LIZE FROM/ TO INDICES ,STATUS TY PE
  36487   "RTN","CHM XWB21",95, 0)
  36488       D INIT
  36489   "RTN","CHM XWB21",96, 0)
  36490       S CHTP I="A"
  36491   "RTN","CHM XWB21",97, 0)
  36492       F  S C HTPI=$O(^C HMX277("B" ,CHTPI),-1 ) Q:CHTPI= ""  D  ;EM DEON TRADI NG PARTNER  INDEX FRO M "B" XREF
  36493   "RTN","CHM XWB21",98, 0)
  36494       .S CHM EDCOB=0,RE CCNT=0,DIR FILE="NO F ILE CREATE D"     ; A SSUME NOT  A "COB" TR ADING PART NER
  36495   "RTN","CHM XWB21",99, 0)
  36496       .S IDX =$O(^CHMX2 77("B",CHT PI,0))
  36497   "RTN","CHM XWB21",100 ,0)
  36498       .U 0 W :DEBUG !," EPPEND():  IDX= ",IDX
  36499   "RTN","CHM XWB21",101 ,0)
  36500       .S:$P( ^CHMX277(I DX,0),"^", 4)["COB" C HMEDCOB=1   ; TRADING  PARTNER 1 1 = "COB"  EMDEON PAR TNER
  36501   "RTN","CHM XWB21",102 ,0)
  36502       .U 0 W :DEBUG !," ^$P(^CHMX2 77(",IDX," ,0),""^"", 4)= ",$P(^ CHMX277(ID X,0),"^",4 )
  36503   "RTN","CHM XWB21",103 ,0)
  36504       .K CHT PARR
  36505   "RTN","CHM XWB21",104 ,0)
  36506       .S (CH FROM,CHTO, FILECNT)=0                     ;  KILL TRAD ING PARTNE R ARRAY 
  36507   "RTN","CHM XWB21",105 ,0)
  36508       .S TRK I=0,TRKI=$ O(^CHMX277 ("B",CHTPI ,TRKI))  ;  GET TRACK ING GLOBAL  INDEX
  36509   "RTN","CHM XWB21",106 ,0)
  36510       .Q:($P ($G(^CHMX2 77(TRKI,0) ),"^",3)=0 )
  36511   "RTN","CHM XWB21",107 ,0)
  36512       .S CHT PARR(CHTPI )=""              ; S ET CHTPARR  UP FOR GE TPENDEI  
  36513   "RTN","CHM XWB21",108 ,0)
  36514       .D GET TOFROM(CHT PI) Q:('CH FROM)  ; R ETRIEVE FR OM/TO FROM  TRACKING  GLOBAL
  36515   "RTN","CHM XWB21",109 ,0)
  36516       .U 0 W :DEBUG !," EPPEND() F ROM: ",CHF ROM,"  TO:  ",CHTO
  36517   "RTN","CHM XWB21",110 ,0)
  36518       .D GET PENDEI(CHF ROM,CHTO)             ; GENERATE  ^ZSC($J,C HTPI,CHCLE I) ARRAY O F ^CHMXCLE (I) VALUES
  36519   "RTN","CHM XWB21",111 ,0)
  36520       .U 0 W :DEBUG !," EPPEND() N UMBER OF R ECORDS TO  PROCESS: " ,^ZSC($J,0 )
  36521   "RTN","CHM XWB21",112 ,0)
  36522       .;Q:^Z SC($J,0)=0                               ;  NO RECORDS  FOUND, CR EATE NO FI LE
  36523   "RTN","CHM XWB21",113 ,0)
  36524       .D:^ZS C($J,0)>0  CREATEFILE            ; 5/1/2018  DLB SKIP  FILE CREAT ION IF NO  RECORD COU NT
  36525   "RTN","CHM XWB21",114 ,0)
  36526       .D FMU PDATE(CHTP I)                    ; UPDATE T RACKING GL OBAL VIA F ILEMAN FUN CTION
  36527   "RTN","CHM XWB21",115 ,0)
  36528       Q
  36529   "RTN","CHM XWB21",116 ,0)
  36530       ;
  36531   "RTN","CHM XWB21",117 ,0)
  36532   EPFTESTF ;  9/24/13 T EST LABEL  FOR FULL F INAL STATU S FILE CRE ATION - IN ITIAL RUN
  36533   "RTN","CHM XWB21",118 ,0)
  36534       N FULL  S FULL=1
  36535   "RTN","CHM XWB21",119 ,0)
  36536       D EPFT EST
  36537   "RTN","CHM XWB21",120 ,0)
  36538       Q
  36539   "RTN","CHM XWB21",121 ,0)
  36540   EPFTEST ;  TEST LABEL  FOR FINAL  STATUS FI LE CREATIO N
  36541   "RTN","CHM XWB21",122 ,0)
  36542       ; 5/16 /13 HAPE P OR DO#118- 11-D-1009,  TO#118-10 09-0001
  36543   "RTN","CHM XWB21",123 ,0)
  36544       N TEST  S TEST=1
  36545   "RTN","CHM XWB21",124 ,0)
  36546       D EPFI NAL
  36547   "RTN","CHM XWB21",125 ,0)
  36548       Q
  36549   "RTN","CHM XWB21",126 ,0)
  36550   EPFFULL ;  9/24/13 HA PE POR lab el for FUL L Final St atus file  creation -  Initial r un
  36551   "RTN","CHM XWB21",127 ,0)
  36552       N FULL  S FULL=1
  36553   "RTN","CHM XWB21",128 ,0)
  36554       D EPFI NAL
  36555   "RTN","CHM XWB21",129 ,0)
  36556       Q
  36557   "RTN","CHM XWB21",130 ,0)
  36558   EPFINAL ;  6/1/13 HAP E POR DO#1 18-11-D-10 09, TO#118 -1009-0001
  36559   "RTN","CHM XWB21",131 ,0)
  36560       ; HAPE  POR - imp lement cre ation of F inal Statu s file for
  36561   "RTN","CHM XWB21",132 ,0)
  36562       ; CHAM PVA, SB, C WVV progra ms
  36563   "RTN","CHM XWB21",133 ,0)
  36564       L +^CH MXWB21:5   I '$T W !, "Process a lready run ning." Q
  36565   "RTN","CHM XWB21",134 ,0)
  36566       N RUNT YPE,GRPCNT ,EICNT,GRO UPID,CHTPI ,CHTPARR
  36567   "RTN","CHM XWB21",135 ,0)
  36568       N TRKI ,FILECNT,F MDATE,RUND ATE,CHRJAR R,CHMEDCOB ,TIME,CHCL FI
  36569   "RTN","CHM XWB21",136 ,0)
  36570       N COUN T,DIRFILE, DATESTAMP, STVAL
  36571   "RTN","CHM XWB21",137 ,0)
  36572       N BREF ,MAXCNT ;  FILEMAN UP DATE VARIA BLES
  36573   "RTN","CHM XWB21",138 ,0)
  36574       S RUNT YPE="F",EI CNT=0,RUND ATE=$H
  36575   "RTN","CHM XWB21",139 ,0)
  36576       D INIT
  36577   "RTN","CHM XWB21",140 ,0)
  36578       ;TRADI NG PARTNER S FROM "B"  XREF
  36579   "RTN","CHM XWB21",141 ,0)
  36580       S CHTP I="A"
  36581   "RTN","CHM XWB21",142 ,0)
  36582       F  S C HTPI=$O(^C HMX277("B" ,CHTPI),-1 ) Q:CHTPI= ""  D
  36583   "RTN","CHM XWB21",143 ,0)
  36584       . ;KIL L TRADING  PARTNER AR RAY
  36585   "RTN","CHM XWB21",144 ,0)
  36586       . K CH TPARR
  36587   "RTN","CHM XWB21",145 ,0)
  36588       . ;HAP E POR - 5/ 16/13 INIT IALIZE FIL E CNT AND  COB FLAG
  36589   "RTN","CHM XWB21",146 ,0)
  36590       . S (F ILECNT,CHM EDCOB)=0
  36591   "RTN","CHM XWB21",147 ,0)
  36592       . ;GET  TRACKING  GLOBAL IND EX
  36593   "RTN","CHM XWB21",148 ,0)
  36594       . S TR KI=$O(^CHM X277("B",C HTPI,0))
  36595   "RTN","CHM XWB21",149 ,0)
  36596       . I $P ($G(^CHMX2 77(TRKI,0) ),"^",3)=0  Q
  36597   "RTN","CHM XWB21",150 ,0)
  36598       . ;TRA DING PARTN ER 11 = "C OB" EMDEON  PARTNER
  36599   "RTN","CHM XWB21",151 ,0)
  36600       . I $P (^CHMX277( TRKI,0),"^ ",4)["COB"  S CHMEDCO B=1
  36601   "RTN","CHM XWB21",152 ,0)
  36602       . S CH TPARR(CHTP I)=""
  36603   "RTN","CHM XWB21",153 ,0)
  36604       . ;GEN ERATE ^ZSC  ARRAY OF  ^CHMXCLE(I ) VALUES
  36605   "RTN","CHM XWB21",154 ,0)
  36606       . D GE TFINEI
  36607   "RTN","CHM XWB21",155 ,0)
  36608       . ;NO  RECORDS FO UND, CREAT E NO FILE
  36609   "RTN","CHM XWB21",156 ,0)
  36610       . Q:^Z SC($J,0)=0
  36611   "RTN","CHM XWB21",157 ,0)
  36612       . ;CRE ATE THE FI NAL STATUS  FILE
  36613   "RTN","CHM XWB21",158 ,0)
  36614       . D CR EATEFILE
  36615   "RTN","CHM XWB21",159 ,0)
  36616       . ;HAP E POR - UP DATE ^CHMP AY("E") IN DEX AS INC LUDED IN F INAL STATU S
  36617   "RTN","CHM XWB21",160 ,0)
  36618       . D FM UPDATE(CHT PI)
  36619   "RTN","CHM XWB21",161 ,0)
  36620       L -^CH MXWB21
  36621   "RTN","CHM XWB21",162 ,0)
  36622       Q
  36623   "RTN","CHM XWB21",163 ,0)
  36624       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36625   "RTN","CHM XWB21",164 ,0)
  36626       ; HIST ORICAL STA TUS RECORD  GENERATIO N ENTRY PO INTS       ;
  36627   "RTN","CHM XWB21",165 ,0)
  36628       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36629   "RTN","CHM XWB21",166 ,0)
  36630   EPREPTST ;
  36631   "RTN","CHM XWB21",167 ,0)
  36632       N TEST  S TEST=1
  36633   "RTN","CHM XWB21",168 ,0)
  36634       D EPRE PLACEMENT
  36635   "RTN","CHM XWB21",169 ,0)
  36636       Q
  36637   "RTN","CHM XWB21",170 ,0)
  36638       ;
  36639   "RTN","CHM XWB21",171 ,0)
  36640   EPREPLACEM ENT ;
  36641   "RTN","CHM XWB21",172 ,0)
  36642       N COUN T,DIRFILE, GRPCNT,SEQ CNT,LSTTIM E,HOLD,DAT ESTAMP,STV AL,RUNTYPE ,FMDATE,MA XCNT
  36643   "RTN","CHM XWB21",173 ,0)
  36644       N POP, CHMXI,CHEN DI,FROM,TO ,TP,RUNTYP E,CHTPI,EI CNT,CHMEDC OB,IDX,CHT PX
  36645   "RTN","CHM XWB21",174 ,0)
  36646       S RUNT YPE="H",FI LECNT=0,GR PCNT=1,EIC NT=0,CHTPI =0  ; INIT IALIZE FRO M/TO INDIC ES,STATUS  TYPE
  36647   "RTN","CHM XWB21",175 ,0)
  36648       D INIT
  36649   "RTN","CHM XWB21",176 ,0)
  36650       S GROU PID="REPLA CEMENT"
  36651   "RTN","CHM XWB21",177 ,0)
  36652       S TP=$ $LISTTP^CH MXWB22  ;  SELECT TRA DING PARTN ER
  36653   "RTN","CHM XWB21",178 ,0)
  36654       S CHME DCOB=0             ;  ASSUME NOT  A "COB" T RADING PAR TNER
  36655   "RTN","CHM XWB21",179 ,0)
  36656       S IDX= $O(^CHMX27 7("B",TP,0 ))
  36657   "RTN","CHM XWB21",180 ,0)
  36658       S:$P(^ CHMX277(ID X,0),"^",4 )["COB" CH MEDCOB=1   ; TRADING  PARTNER 11  = "COB" E MDEON PART NER
  36659   "RTN","CHM XWB21",181 ,0)
  36660       D GETD TE^CHMXWBU T(.FROM,.T O)                    ; GET DATE  RANGE VAL UES
  36661   "RTN","CHM XWB21",182 ,0)
  36662       S IDAT E=FROM,EDA TE=TO_".99 9999"
  36663   "RTN","CHM XWB21",183 ,0)
  36664       F  S I DATE=$O(^C HMXCL("B", IDATE)) Q: IDATE>EDAT E  Q:IDATE =""  D
  36665   "RTN","CHM XWB21",184 ,0)
  36666       .S CHX I=""
  36667   "RTN","CHM XWB21",185 ,0)
  36668       .F  S  CHXI=$O(^C HMXCL("B", IDATE,CHXI )) Q:CHXI= ""  D
  36669   "RTN","CHM XWB21",186 ,0)
  36670       ..S CH MXI=CHXI
  36671   "RTN","CHM XWB21",187 ,0)
  36672       ..I $D (TEST) W ! ,"CHECKING :",$$DTCVR T($E(IDATE ,1,7))  ;  SHOW FILE  DATES BEIN G PROCESSE D
  36673   "RTN","CHM XWB21",188 ,0)
  36674       ..S CH A=$O(^CHMX CLA("B",CH MXI,"")) Q :CHA=""
  36675   "RTN","CHM XWB21",189 ,0)
  36676       ..S CH TPX=$P($G( ^CHMXCLA(C HA,1)),"^" ,1) Q:CHTP X=""    ;  GET CLAIM  T/P FOR FI LE BEING C HECKED
  36677   "RTN","CHM XWB21",190 ,0)
  36678       ..S CH TPX=$O(^CH MXTP("C",C HTPX,""))   ; CHECK S ELECTED VS  CLAIM TP  ID
  36679   "RTN","CHM XWB21",191 ,0)
  36680       ..I TP =CHTPX D   ; FILE MAT CHES THE S ELECTED TP   
  36681   "RTN","CHM XWB21",192 ,0)
  36682       ...S C HTPI=TP    ; CHTPI IS  USED DOWN STREAM                                              
  36683   "RTN","CHM XWB21",193 ,0)
  36684       ...I $ D(TEST) W  "  PROCESS ING:",$$DT CVRT($E(ID ATE,1,7))
  36685   "RTN","CHM XWB21",194 ,0)
  36686       ...I $ D(TEST) W  !,"  EPREP LACEMENT:  CHMXI= ",C HMXI,"  CH A= ",CHA,"   CHTPI= " ,CHTPI,"   TP= ",TP
  36687   "RTN","CHM XWB21",195 ,0)
  36688       ...S C HTPARR(TP) ="" D GETC HCLEI(CHMX I,CHTPI)                      ;  IF TP VALI D, PROCESS  FILE
  36689   "RTN","CHM XWB21",196 ,0)
  36690       I $D(T EST) W !," REPLACE: $ J= ",$J,"   REC COUNT = ",$G(^ZS C($J,0)),"   CHTPI= " ,CHTPI,"   TP= ",TP
  36691   "RTN","CHM XWB21",197 ,0)
  36692       Q:^ZSC ($J,0)=0   ; NO RECOR DS FOUND,  CREATE NO  FILE
  36693   "RTN","CHM XWB21",198 ,0)
  36694       D CREA TEFILE
  36695   "RTN","CHM XWB21",199 ,0)
  36696       Q
  36697   "RTN","CHM XWB21",200 ,0)
  36698       ;
  36699   "RTN","CHM XWB21",201 ,0)
  36700   DTCVRT(DAT E) ; CONVE RT DATE TO  EXTERNAL  FORMAT
  36701   "RTN","CHM XWB21",202 ,0)
  36702       N EXTD ATE
  36703   "RTN","CHM XWB21",203 ,0)
  36704       S EXTD ATE=$E(DAT E,4,5)_"-" _$E(DATE,6 ,7)_"-"_($ E(DATE,1,3 )+1700)
  36705   "RTN","CHM XWB21",204 ,0)
  36706       Q EXTD ATE
  36707   "RTN","CHM XWB21",205 ,0)
  36708       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36709   "RTN","CHM XWB21",206 ,0)
  36710       ; HIST ORICAL STA TUS RECORD  GENERATIO N ENTRY PO INTS                             ;
  36711   "RTN","CHM XWB21",207 ,0)
  36712       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36713   "RTN","CHM XWB21",208 ,0)
  36714   EPOVERTST  ;
  36715   "RTN","CHM XWB21",209 ,0)
  36716       N TEST  S TEST=1
  36717   "RTN","CHM XWB21",210 ,0)
  36718       D EPOV ERLAY
  36719   "RTN","CHM XWB21",211 ,0)
  36720       Q
  36721   "RTN","CHM XWB21",212 ,0)
  36722       ;
  36723   "RTN","CHM XWB21",213 ,0)
  36724   EPOVERLAY  ;
  36725   "RTN","CHM XWB21",214 ,0)
  36726       N COUN T,DIRFILE, GRPCNT,SEQ CNT,LSTTIM E,HOLD,DAT ESTAMP,STV AL,RUNTYPE ,FMDATE,MA XCNT
  36727   "RTN","CHM XWB21",215 ,0)
  36728       N POP, CHMXI,CHEN DI,FROM,TO ,TP,RUNTYP E,CHTPI,EI CNT
  36729   "RTN","CHM XWB21",216 ,0)
  36730       S RUNT YPE="O",FI LECNT=0,GR PCNT=1,EIC NT=0,CHTPI =0  ; INIT IALIZE FRO M/TO INDIC ES,STATUS  TYPE
  36731   "RTN","CHM XWB21",217 ,0)
  36732       D INIT
  36733   "RTN","CHM XWB21",218 ,0)
  36734       S GROU PID="OVERL AY"
  36735   "RTN","CHM XWB21",219 ,0)
  36736       S TP=$ $LISTTP^CH MXWB22
  36737   "RTN","CHM XWB21",220 ,0)
  36738       D GETD TE^CHMXWBU T(.FROM,.T O)  ; GET  DATE RANGE  VALUES
  36739   "RTN","CHM XWB21",221 ,0)
  36740       S IDAT E=FROM,EDA TE=TO_".99 9999"
  36741   "RTN","CHM XWB21",222 ,0)
  36742       F  S I DATE=$O(^C HMXCL("B", IDATE)) Q: IDATE>EDAT E  Q:IDATE =""  D
  36743   "RTN","CHM XWB21",223 ,0)
  36744       .S CHM XI=""
  36745   "RTN","CHM XWB21",224 ,0)
  36746       .F  S  CHMXI=$O(^ CHMXCL("B" ,IDATE,CHM XI)) Q:CHM XI=""  D
  36747   "RTN","CHM XWB21",225 ,0)
  36748       ..S CH A=$O(^CHMX CLA("B",CH MXI,"")) Q :CHA=""
  36749   "RTN","CHM XWB21",226 ,0)
  36750       ..S TP TIN=$P($G( ^CHMXCLA(C HA,1)),"^" ,1) Q:TPTI N=""
  36751   "RTN","CHM XWB21",227 ,0)
  36752       ..I TP =$O(^CHMXT P("C",TPTI N,"")) S C HTPARR(TP) ="" D GETC HCLEI(CHMX I,TP)
  36753   "RTN","CHM XWB21",228 ,0)
  36754       Q:^ZSC ($J,0)=0   ; NO RECOR DS FOUND,  CREATE NO  FILE
  36755   "RTN","CHM XWB21",229 ,0)
  36756       D CREA TEFILE
  36757   "RTN","CHM XWB21",230 ,0)
  36758       Q
  36759   "RTN","CHM XWB21",231 ,0)
  36760       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36761   "RTN","CHM XWB21",232 ,0)
  36762       ; INIT  PERFORMS  LOCAL VARI ABLE INITI ALIZATION  REQUIREMEN TS FOR THE  STATUS    ;
  36763   "RTN","CHM XWB21",233 ,0)
  36764       ; PROC ESSES.                                                                       ;
  36765   "RTN","CHM XWB21",234 ,0)
  36766       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  36767   "RTN","CHM XWB21",235 ,0)
  36768   INIT ;
  36769   "RTN","CHM XWB21",236 ,0)
  36770       K ^ZSC ($J) S ^ZS C($J,0)=0
  36771   "RTN","CHM XWB21",237 ,0)
  36772       K TMP
  36773   "RTN","CHM XWB21",238 ,0)
  36774       S GROU PID="",CHT PI=0
  36775   "RTN","CHM XWB21",239 ,0)
  36776       I '$D( DATESTAMP)  D  ; PROV IDED FOR T ESTING, PR ODUCTION S HOULD NOT  REQUIRE TH IS
  36777   "RTN","CHM XWB21",240 ,0)
  36778       .D NOW ^%DTC
  36779   "RTN","CHM XWB21",241 ,0)
  36780       .S FMD ATE=%
  36781   "RTN","CHM XWB21",242 ,0)
  36782       .S FMD ATE=$$JUST IFY^CHMXWB UT(FMDATE, 14,0,"L")
  36783   "RTN","CHM XWB21",243 ,0)
  36784       .S TIM E=$$JUSTIF Y^CHMXWBUT ($E(FMDATE ,9,14),6,0 ,"L")
  36785   "RTN","CHM XWB21",244 ,0)
  36786       .S DAT ESTAMP=($E (FMDATE,1, 7)+1700000 0)_TIME  ;  DATE/TIME  FILE CREA TED DOWN T O SECOND
  36787   "RTN","CHM XWB21",245 ,0)
  36788       Q
  36789   "RTN","CHM XWB21",246 ,0)
  36790       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36791   "RTN","CHM XWB21",247 ,0)
  36792       ; EPST AT IS THE  ENTRY POIN T FOR THE  ON-DEMAND  REPORT FOR  STATISICS            ;
  36793   "RTN","CHM XWB21",248 ,0)
  36794       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;   
  36795   "RTN","CHM XWB21",249 ,0)
  36796   EPSTAT ;
  36797   "RTN","CHM XWB21",250 ,0)
  36798       D ONDE MAND^CHMXW B22
  36799   "RTN","CHM XWB21",251 ,0)
  36800       Q
  36801   "RTN","CHM XWB21",252 ,0)
  36802       ;
  36803   "RTN","CHM XWB21",253 ,0)
  36804   EPREGEN ;
  36805   "RTN","CHM XWB21",254 ,0)
  36806       D REGE N^CHMXWB22
  36807   "RTN","CHM XWB21",255 ,0)
  36808       Q
  36809   "RTN","CHM XWB21",256 ,0)
  36810       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36811   "RTN","CHM XWB21",257 ,0)
  36812       ; FILE  CREATION  FUNCTIONS                                                         ;
  36813   "RTN","CHM XWB21",258 ,0)
  36814       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36815   "RTN","CHM XWB21",259 ,0)
  36816   CREATEFILE  ;
  36817   "RTN","CHM XWB21",260 ,0)
  36818       S MAXC NT=500000
  36819   "RTN","CHM XWB21",261 ,0)
  36820       ; HAPE  POR 11/21 /13 force  max file s ize under  150 meg
  36821   "RTN","CHM XWB21",262 ,0)
  36822       I RUNT YPE="F" S  MAXCNT=175 000
  36823   "RTN","CHM XWB21",263 ,0)
  36824       ;I RUN TYPE="P" S  MAXCNT=60 00  ; MTN0 20286-01 -  set to 5M b for TEST ing only -  little ov er 5*1024   ==> REMOV E THIS LIN E AFTER TE ST
  36825   "RTN","CHM XWB21",264 ,0)
  36826       D FILE LOOP
  36827   "RTN","CHM XWB21",265 ,0)
  36828       Q
  36829   "RTN","CHM XWB21",266 ,0)
  36830       ;
  36831   "RTN","CHM XWB21",267 ,0)
  36832   FILELOOP ;  BUILD CLA IMS FROM ^ ZSC($J) AR RAY (^CHMX CLE(I) VAL UES)
  36833   "RTN","CHM XWB21",268 ,0)
  36834       N CHCL EI,PDI,CLM COST,CLMOT H,HACCLM,I PTOHI,CLMD ED,IPTAMT, PATPAY
  36835   "RTN","CHM XWB21",269 ,0)
  36836       D GETG RPCNT  ; G ET ESTIMAT ED GROUP F ILE COUNT
  36837   "RTN","CHM XWB21",270 ,0)
  36838       Q:GRPC NT=0
  36839   "RTN","CHM XWB21",271 ,0)
  36840       D GETF ILE U DIRF ILE  ; CRE ATE ORIGIN AL FILE           
  36841   "RTN","CHM XWB21",272 ,0)
  36842       D BLDH DR              ; BLD HDR SETS C OUNT=2 (SE E EMDEON S PEC)
  36843   "RTN","CHM XWB21",273 ,0)
  36844       S CHCL EI=0
  36845   "RTN","CHM XWB21",274 ,0)
  36846       F  S C HCLEI=$O(^ ZSC($J,CHT PI,CHCLEI) ) Q:CHCLEI =""  D
  36847   "RTN","CHM XWB21",275 ,0)
  36848       .;U 0  W:DEBUG !, "FILELOOP( ): PROCESS ING CHCLEI : ",CHCLEI
  36849   "RTN","CHM XWB21",276 ,0)
  36850       .S EIC NT=EICNT+1
  36851   "RTN","CHM XWB21",277 ,0)
  36852       .S STV AL=$G(^ZSC ($J,CHTPI, CHCLEI))
  36853   "RTN","CHM XWB21",278 ,0)
  36854       .I RUN TYPE="F" D
  36855   "RTN","CHM XWB21",279 ,0)
  36856       .. S S TVAL=""
  36857   "RTN","CHM XWB21",280 ,0)
  36858       .. K I PTAMT,IPTO HI
  36859   "RTN","CHM XWB21",281 ,0)
  36860       .. ;;H APE POR -  BUILD ARRA Y OF COST  SHARE AND  DEDUCTABLE  AMTS
  36861   "RTN","CHM XWB21",282 ,0)
  36862       .. S H ACCLM="" F   S HACCLM =$O(^CHMXC LE(CHCLEI, 80,"B",HAC CLM)) Q:HA CCLM=""  D
  36863   "RTN","CHM XWB21",283 ,0)
  36864       ... I  $P($G(^CHM PAY(HACCLM ,1)),"^",7 )'="" S CL MOTH(HACCL M)=$P(^(1) ,"^",7)
  36865   "RTN","CHM XWB21",284 ,0)
  36866       ... I  $P($G(^CHM PAY(HACCLM ,1)),"^",6 )'="" S CL MCOST(HACC LM)=$P(^(1 ),"^",6)
  36867   "RTN","CHM XWB21",285 ,0)
  36868       ... I  $P($G(^CHM PAY(HACCLM ,1)),"^",5 )'="" S CL MDED(HACCL M)=$P(^(1) ,"^",5)
  36869   "RTN","CHM XWB21",286 ,0)
  36870       ... I  $P($G(^CHM PAY(HACCLM ,1)),"^",1 5)'="" S P ATPAY(HACC LM)=$P(^(1 ),"^",15)
  36871   "RTN","CHM XWB21",287 ,0)
  36872       .D BLD CLM(CHCLEI ,STVAL)  ;  GENERATE  CLAIM/STC, DTL/STC RE CORDS
  36873   "RTN","CHM XWB21",288 ,0)
  36874       .D CHK SEQ                 ;  CHECK FOR  500MB LIM IT, CREATE  NEW FILE
  36875   "RTN","CHM XWB21",289 ,0)
  36876       .K CLM COST,CLMDE D,PATPAY,C LMOTH
  36877   "RTN","CHM XWB21",290 ,0)
  36878       D BLDT RL                  ;  BUILD THE  TRAILER R ECORD
  36879   "RTN","CHM XWB21",291 ,0)
  36880       D CLOS EFILE               ;  CLOSE CUR RENT FILE
  36881   "RTN","CHM XWB21",292 ,0)
  36882       Q
  36883   "RTN","CHM XWB21",293 ,0)
  36884       ;
  36885   "RTN","CHM XWB21",294 ,0)
  36886   GETGRPCNT  ; ESTIMATE  THE TOTAL  NUMBER OF  FILES REQ UIRED
  36887   "RTN","CHM XWB21",295 ,0)
  36888       N RECC NT,X
  36889   "RTN","CHM XWB21",296 ,0)
  36890       S RECC NT=0
  36891   "RTN","CHM XWB21",297 ,0)
  36892       S X=""
  36893   "RTN","CHM XWB21",298 ,0)
  36894       F  S X =$O(^ZSC($ J,CHTPI,X) ) Q:X=""   S RECCNT=R ECCNT+1
  36895   "RTN","CHM XWB21",299 ,0)
  36896       S GRPC NT=RECCNT\ MAXCNT   ;  INTEGER D IVISION OF  RECORD CO UNT
  36897   "RTN","CHM XWB21",300 ,0)
  36898       S:RECC NT#MAXCNT> 0 GRPCNT=G RPCNT+1
  36899   "RTN","CHM XWB21",301 ,0)
  36900       ;HAPE  POR 1/6/14  - for FIN AL status,  force gro upcnt=1
  36901   "RTN","CHM XWB21",302 ,0)
  36902       ;HAPE  POR 1/20/1 4 - force  group coun t = 1 for  all cstat  types, inc luding Pen ding
  36903   "RTN","CHM XWB21",303 ,0)
  36904       S GRPC NT=1
  36905   "RTN","CHM XWB21",304 ,0)
  36906       ;; HAP E POR 1/20 /14 I RUNT YPE="F" S  GRPCNT=1
  36907   "RTN","CHM XWB21",305 ,0)
  36908       ;W !," GRPCNT= ", GRPCNT
  36909   "RTN","CHM XWB21",306 ,0)
  36910       Q
  36911   "RTN","CHM XWB21",307 ,0)
  36912       ;
  36913   "RTN","CHM XWB21",308 ,0)
  36914   CHKSEQ ; H ANDLE THE  FILE SEQUE NCE NUMBER ING REQUIR EMENTS
  36915   "RTN","CHM XWB21",309 ,0)
  36916       I EICN T>MAXCNT D
  36917   "RTN","CHM XWB21",310 ,0)
  36918       .D BLD TRL  ; OUT PUT TRAILE R RECORD
  36919   "RTN","CHM XWB21",311 ,0)
  36920       .D CLO SEFILE
  36921   "RTN","CHM XWB21",312 ,0)
  36922       .D GET FILE U DIR FILE
  36923   "RTN","CHM XWB21",313 ,0)
  36924       .D BLD HDR  ; BLD HDR RESETS  "COUNT" V ARIABLE
  36925   "RTN","CHM XWB21",314 ,0)
  36926       Q
  36927   "RTN","CHM XWB21",315 ,0)
  36928       ;
  36929   "RTN","CHM XWB21",316 ,0)
  36930   FMUPDATE(C HTPI) ; UP DATE THE T RACKING GL OBAL USING  FILEMAN
  36931   "RTN","CHM XWB21",317 ,0)
  36932       Q:"APF "'[RUNTYPE   ; A=ACK,  P=PENDING , F=FINAL
  36933   "RTN","CHM XWB21",318 ,0)
  36934       ; HAPE  POR - FOR  CHAMPVA C LAIMS THAT  ARE INCLU DED IN THE  FINAL
  36935   "RTN","CHM XWB21",319 ,0)
  36936       ; STAT US FILE, S ET ^CHMPAY ("E") = TO  DATE FILE  CREATED
  36937   "RTN","CHM XWB21",320 ,0)
  36938       I RUNT YPE="F" D   Q
  36939   "RTN","CHM XWB21",321 ,0)
  36940       . ;02/ 10/2014 SB B DEV02032 2
  36941   "RTN","CHM XWB21",322 ,0)
  36942       . ;N X ,X1,CNT,NU LL S (NULL ,X)="",CNT =0 F  S X= $O(^ZSC1($ J,X)) Q:X= ""  S X1=" " F  S X1= $O(^ZSC1($ J,X,X1)) Q :X1=""  S  CNT=CNT+1  I $D(^CHMP AY("E",X,X 1)) S ^CHM PAY("E",X, X1)=$ZD(RU NDATE)_"#" _RUNDATE
  36943   "RTN","CHM XWB21",323 ,0)
  36944       . ; Up dated code  for FILE  RUN DATE,  the new fi eld is now  at 10.23  in CHMPAY  and with a  M cross r eference
  36945   "RTN","CHM XWB21",324 ,0)
  36946       . S %H =RUNDATE D  YMD^%DTC  N RDT S RD T=X_%
  36947   "RTN","CHM XWB21",325 ,0)
  36948       . N X, X1,X2,CNT, NULL S (NU LL,X1)="", CNT=0 F  S  X1=$O(^ZS C1($J,X1))  Q:X1=""   S X2="" F   S X2=$O(^ ZSC1($J,X1 ,X2)) Q:X2 =""  S CNT =CNT+1 I $ D(^CHMPAY( "E",X1,X2) ) S DR="10 .23///^S X =RDT",DIE= "^CHMPAY(" ,DA=X2 D ^ DIE
  36949   "RTN","CHM XWB21",326 ,0)
  36950       . ;; H APE POR 1/ 20/14 adde d back cod e to updat e X12 277  STATUS TRA CKING FILE
  36951   "RTN","CHM XWB21",327 ,0)
  36952       . S CH NODEDEF="^ CHMX277(I, 30,",TRKDA TA=".02=1^ .03="_DIRF ILE_"^.04= "_NULL_"^. 05="_NULL_ "^.06="_CN T
  36953   "RTN","CHM XWB21",328 ,0)
  36954       . D FM 1 Q
  36955   "RTN","CHM XWB21",329 ,0)
  36956       N CHNO DEDEF,BREF ,CHIJKVAL, DRDATA,TRK DATA
  36957   "RTN","CHM XWB21",330 ,0)
  36958       S:RUNT YPE="A" CH NODEDEF="^ CHMX277(I, 10,",TRKDA TA=".02=1^ .03="_DIRF ILE_"^.04= "_COUNT_"^ .05="_CHMX I
  36959   "RTN","CHM XWB21",331 ,0)
  36960       S:RUNT YPE="P" CH NODEDEF="^ CHMX277(I, 20,",TRKDA TA=".02=1^ .03="_DIRF ILE_"^.04= "_CHTO_"^. 05="_CHFRO M_"^.06="_ ^ZSC($J,0)
  36961   "RTN","CHM XWB21",332 ,0)
  36962       ;HAPE  POR 7/30/1 3 - not ne eded due t o use of C HMPAY("E")  index to
  36963   "RTN","CHM XWB21",333 ,0)
  36964       ;        determin e claim in clusion in  Final Sta tus file
  36965   "RTN","CHM XWB21",334 ,0)
  36966       ;S:RUN TYPE="F" C HNODEDEF=" ^CHMX277(I ,30,",TRKD ATA=".02=1 ^.03="_DIR FILE_"^.04 ="_CHTO_"^ .05="_CHFR OM_"^.06=" _COUNT
  36967   "RTN","CHM XWB21",335 ,0)
  36968   FM1 ;
  36969   "RTN","CHM XWB21",336 ,0)
  36970       S BREF =FMDATE
  36971   "RTN","CHM XWB21",337 ,0)
  36972       S CHIJ KVAL=$O(^C HMX277("B" ,CHTPI,0))              ; ADD RE QUIRES "I" , NO "J" V ALUE
  36973   "RTN","CHM XWB21",338 ,0)
  36974       S DRDA TA=$$SETDA RR(TRKDATA )                       ; SET RE G/VALUE FO R FILEMAN  FORMAT
  36975   "RTN","CHM XWB21",339 ,0)
  36976       ;U 0 W :DEBUG !," FMUPDATE() :FM1: ",CH NODEDEF,"   ",CHIJKVA L,"  ",BRE F,"  ",DRD ATA
  36977   "RTN","CHM XWB21",340 ,0)
  36978       D ADD^ CHHRLIBFM( CHNODEDEF, CHIJKVAL,B REF,DRDATA ) ; FILEMA N UPDATE F OR TRACKIN G GLOBAL
  36979   "RTN","CHM XWB21",341 ,0)
  36980       Q
  36981   "RTN","CHM XWB21",342 ,0)
  36982       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36983   "RTN","CHM XWB21",343 ,0)
  36984       ;TEST  ENTRY POIN T TO TEST  THE BLDCLM  FUNCTION  FROM A PDI  VALUE       
  36985   "RTN","CHM XWB21",344 ,0)
  36986       ; THER E ARE MULT IPLE CROSS  REFERENCE S (SOME DO CUMENTED,  SOME
  36987   "RTN","CHM XWB21",345 ,0)
  36988       ; UNDO CUMENTED T HAT ARE UT ILIZED IN  THE CLAIM  PROCESSING  SYSTEM.
  36989   "RTN","CHM XWB21",346 ,0)
  36990       ; THE  CVTPDI AND  TSTBLDCLM  FUNCTIONS  UTILIZE T HE MAJORIT Y OF THESE
  36991   "RTN","CHM XWB21",347 ,0)
  36992       ; CROS S REFERENC ES.
  36993   "RTN","CHM XWB21",348 ,0)
  36994       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  36995   "RTN","CHM XWB21",349 ,0)
  36996       ;
  36997   "RTN","CHM XWB21",350 ,0)
  36998   CVTPDI(CHR EFN) ;
  36999   "RTN","CHM XWB21",351 ,0)
  37000       N CHPC N,CHMXCLI, CHMXID,CHC LFI,SDATE, EDATE,CHCL FI,CHCLEI, IDX
  37001   "RTN","CHM XWB21",352 ,0)
  37002       I '$D( ^CHMXCLE(" PDI",CHREF N)) W !,"N O ^CHMXCLE (""PDI""," ,CHREFN,")  XREF" Q
  37003   "RTN","CHM XWB21",353 ,0)
  37004       S CHPC N=""
  37005   "RTN","CHM XWB21",354 ,0)
  37006   S1  S CHPC N=$O(^CHMX CLE("PDI", CHREFN,CHP CN)) I CHP CN="" Q  ; VALID PDI, NO DATA
  37007   "RTN","CHM XWB21",355 ,0)
  37008       S CHMX CLI=0
  37009   "RTN","CHM XWB21",356 ,0)
  37010   S2  S CHMX CLI=$O(^CH MXCLE("PDI ",CHREFN,C HPCN,CHMXC LI)) I 'CH MXCLI  Q   ;VALID PDI , NO DATA
  37011   "RTN","CHM XWB21",357 ,0)
  37012       S CHMX ID=""
  37013   "RTN","CHM XWB21",358 ,0)
  37014   S3  S CHMX ID=$O(^CHM XCLE("PDI" ,CHREFN,CH PCN,CHMXCL I,CHMXID))  I CHMXID= ""  Q
  37015   "RTN","CHM XWB21",359 ,0)
  37016       S CHCL EI=$P(CHMX ID,"*",4)
  37017   "RTN","CHM XWB21",360 ,0)
  37018       W !!," CLM SDATE  [^CHMXCLE( I,1)),1]=" ,$P($G(^CH MXCLE(CHCL EI,1)),"^" ,1)
  37019   "RTN","CHM XWB21",361 ,0)
  37020       W !,"C LM EDATE [ ^CHMXCLE(I ,1)),2]=", $P($G(^CHM XCLE(CHCLE I,1)),"^", 2)
  37021   "RTN","CHM XWB21",362 ,0)
  37022       S CHCL FI=0
  37023   "RTN","CHM XWB21",363 ,0)
  37024       W !!," LINE ITEM  DATE VALUE S"
  37025   "RTN","CHM XWB21",364 ,0)
  37026       F IDX= 1:1 S CHCL FI=$O(^CHM XCLF("B",C HCLEI,CHCL FI)) Q:'CH CLFI  D  ;  CHECK ALL  LINE ITEM  DATES
  37027   "RTN","CHM XWB21",365 ,0)
  37028       .W !,I DX,". ","  L/I SDATE  [^CHMXCLF( I,1)),11)] =",$P($G(^ CHMXCLF(CH CLFI,1))," ^",11)
  37029   "RTN","CHM XWB21",366 ,0)
  37030       .W !,"     L/I EN D [^CHMXCL F(I,1)),12 )]=",$P($G (^CHMXCLF( CHCLFI,1)) ,"^",12)
  37031   "RTN","CHM XWB21",367 ,0)
  37032       .W !,"     THERAP Y SDATE [^ CHMXCLF(I, 2.5)),1)]= ",$P($G(^C HMXCLF(CHC LFI,2.5)), "^",1)
  37033   "RTN","CHM XWB21",368 ,0)
  37034       .W !,"     LAST C ERT DATE [ ^CHMXCLF(I ,2.5)),2)] =",$P($G(^ CHMXCLF(CH CLFI,2.5)) ,"^",2)
  37035   "RTN","CHM XWB21",369 ,0)
  37036       Q
  37037   "RTN","CHM XWB21",370 ,0)
  37038       ;
  37039   "RTN","CHM XWB21",371 ,0)
  37040   TSTBLDCLM( CHPDI) ;
  37041   "RTN","CHM XWB21",372 ,0)
  37042       N CHPC N,CHCLI,CH CLAI,CHCLE I,STVAL,CO UNT,PDI,BU FI,RUNTYPE ,CLMTYPE,T EST
  37043   "RTN","CHM XWB21",373 ,0)
  37044       S (STV AL,CHPCN)= "",(COUNT, CHCLEI,CHC LAI,PDI)=0 ,TEST=1
  37045   "RTN","CHM XWB21",374 ,0)
  37046       S CHPC N=0,CHPCN= $O(^CHMXCL E("PDI",CH PDI,CHPCN) )
  37047   "RTN","CHM XWB21",375 ,0)
  37048       I CHPC N="" W !," NO CHPCN V ALUE" Q
  37049   "RTN","CHM XWB21",376 ,0)
  37050       E  W ! ,"PATIENT  CONTROL #  [^CHMXCLE( ""PDI"",CH PDI,PCN)]=  ",CHPCN         ; PA TIENT CONT ROL NUMBER
  37051   "RTN","CHM XWB21",377 ,0)
  37052       S CHCL I=0,CHCLI= $O(^CHMXCL E("PDI",CH PDI,CHPCN, CHCLI))
  37053   "RTN","CHM XWB21",378 ,0)
  37054       I CHCL I="" W !," NO CHCLI V ALUE" Q
  37055   "RTN","CHM XWB21",379 ,0)
  37056       S STVA L=0,STVAL= $O(^CHMXCL E("A",CHCL I,STVAL))  W !,"XREF  CLAIM STAT US= ",STVA L
  37057   "RTN","CHM XWB21",380 ,0)
  37058       S BUFI ="",BUFI=$ O(^CHMXCLE ("PDI",CHP DI,CHPCN,C HCLI,BUFI) )
  37059   "RTN","CHM XWB21",381 ,0)
  37060       I BUFI ="" W !,"N O BUFFER I NDEX VALUE S" Q
  37061   "RTN","CHM XWB21",382 ,0)
  37062       W !,"X REF [$O(^C HMXCLE(""P DI"",CHPDI ,CHPCN,CHC LI,BUFI))]  BUFFER IN DICES= ",B UFI
  37063   "RTN","CHM XWB21",383 ,0)
  37064       S CHCL EI=$P(BUFI ,"*",4)
  37065   "RTN","CHM XWB21",384 ,0)
  37066       I CHCL EI="" W !, "NO CHCLEI  VALUE REC OVERED"
  37067   "RTN","CHM XWB21",385 ,0)
  37068       S RUNT YPE="H"
  37069   "RTN","CHM XWB21",386 ,0)
  37070       S PDI= $P($G(^CHM XCLE(CHCLE I,100)),"^ ",2)  ; RE TRIEVE PDI
  37071   "RTN","CHM XWB21",387 ,0)
  37072       S:PDI= "" PDI=$P( $G(^CHMXCL E(CHCLEI,1 00)),"^",4 )
  37073   "RTN","CHM XWB21",388 ,0)
  37074       W !,"P DI VALUE F ROM [^CHMX CLE(I,100) ),2 OR 4]=  ",PDI
  37075   "RTN","CHM XWB21",389 ,0)
  37076       S CHCL CI=$P(^CHM XCLE(CHCLE I,0),"^",1 )     ;GET  "I" VALUE S FOR ALL  BUFFER FIL ES
  37077   "RTN","CHM XWB21",390 ,0)
  37078       S CHCL BI=$P(^CHM XCLC(CHCLC I,0),"^",1 )
  37079   "RTN","CHM XWB21",391 ,0)
  37080       S CHCL AI=$P(^CHM XCLB(CHCLB I,0),"^",1 )
  37081   "RTN","CHM XWB21",392 ,0)
  37082       S CHCL I=$P(^CHMX CLA(CHCLAI ,0),"^",1)
  37083   "RTN","CHM XWB21",393 ,0)
  37084       W !!," X12 837 BU FFER [CHMX CL(I)= ",? 30,CHCLI
  37085   "RTN","CHM XWB21",394 ,0)
  37086       W !,"T RANSACTION  [CHMXCLA( I)]= ",?30 ,CHCLAI
  37087   "RTN","CHM XWB21",395 ,0)
  37088       W !,"P ROVIDER BU FFER [CHMX CLB(I)]= " ,?30,CHCLB I
  37089   "RTN","CHM XWB21",396 ,0)
  37090       W !,"P ATIENT BUF FER [CHMXC LC(I)= ",? 30,CHCLCI
  37091   "RTN","CHM XWB21",397 ,0)
  37092       W !,"C LM BUFFER  [CHMXCLE(I )= ",?30,C HCLEI
  37093   "RTN","CHM XWB21",398 ,0)
  37094       W !,"L /I BUFFER  [CHMXCLF(I )]= ",?30, $O(^CHMXCL F("B",CHCL EI,0))
  37095   "RTN","CHM XWB21",399 ,0)
  37096       S CLMT YPE=$$GETC LMTYP
  37097   "RTN","CHM XWB21",400 ,0)
  37098       W !,"V ERSION-FUN CTIONAL TY PE [^CHMXC LA(I,0)),1 3)]= ",$P( $G(^CHMXCL A(CHCLAI,0 )),"^",13)
  37099   "RTN","CHM XWB21",401 ,0)
  37100       W !!," CLAIM TYPE = ",$S(CLM TYPE="I":" INSTITUTIO NAL",CLMTY PE="P":"PR OFESSIONAL ",CLMTYPE= "D":"DENTA L")                   ; I/P/D CL AIM
  37101   "RTN","CHM XWB21",402 ,0)
  37102       W !,"S TATUS (ACK /PENDING)= ",$S($D(^C HMPAY("C", PDI))=0:"A CK",1:"PEN DING")
  37103   "RTN","CHM XWB21",403 ,0)
  37104       D CVTP DI(CHPDI)
  37105   "RTN","CHM XWB21",404 ,0)
  37106       W !!
  37107   "RTN","CHM XWB21",405 ,0)
  37108       D BLDC LM(CHCLEI, "")
  37109   "RTN","CHM XWB21",406 ,0)
  37110       Q
  37111   "RTN","CHM XWB21",407 ,0)
  37112       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  37113   "RTN","CHM XWB21",408 ,0)
  37114       ; BLDC LM: ENTRY  POINT TO B UILD THE C STAT RECOR DS                      
  37115   "RTN","CHM XWB21",409 ,0)
  37116       ; THIS  FUNCTION  PROVIDES A N EXTERNAL  ENTRY POI NT TO GENE RATE THE
  37117   "RTN","CHM XWB21",410 ,0)
  37118       ; EMDE ON CLAIM,C LAIM STATU S,DETAIL,A ND DETAIL  STATUS REC ORDS  
  37119   "RTN","CHM XWB21",411 ,0)
  37120       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  37121   "RTN","CHM XWB21",412 ,0)
  37122   BLDCLM(CHC LEI,STVAL)  ;BUILD UP  THE CLAIM  RECORDS
  37123   "RTN","CHM XWB21",413 ,0)
  37124       ;   CH CLEI       CLAIM NUMB ER FROM IN COMING 837  FILE
  37125   "RTN","CHM XWB21",414 ,0)
  37126       ;   ST VAL        STATUS VAL UE AFTER F ROMNT END  EDITS
  37127   "RTN","CHM XWB21",415 ,0)
  37128       N CHCL CI,CHCLBI, CHCLAI,CHC LI,STYPE,T MP,OK,HACP AY
  37129   "RTN","CHM XWB21",416 ,0)
  37130       N CHKD ATE,CHKEFT ,CHMPAY,PA YDATE,ALLO WAMT,CLTYP E,PIECE,TO C,LN,LD,ST CLICN
  37131   "RTN","CHM XWB21",417 ,0)
  37132       I '$D( DATESTAMP)  D  ; PROV IDED FOR T ESTING, PR ODUCTION S HOULD NOT  REQUIRE TH IS
  37133   "RTN","CHM XWB21",418 ,0)
  37134       .D NOW ^%DTC
  37135   "RTN","CHM XWB21",419 ,0)
  37136       .S FMD ATE=%
  37137   "RTN","CHM XWB21",420 ,0)
  37138       .S FMD ATE=$$JUST IFY^CHMXWB UT(FMDATE, 14,0,"L")
  37139   "RTN","CHM XWB21",421 ,0)
  37140       .S TIM E=$$JUSTIF Y^CHMXWBUT ($E(FMDATE ,9,14),6,0 ,"L")
  37141   "RTN","CHM XWB21",422 ,0)
  37142       .S DAT ESTAMP=($E (FMDATE,1, 7)+1700000 0)_TIME  ;  DATE/TIME  FILE CREA TED DOWN T O SECOND
  37143   "RTN","CHM XWB21",423 ,0)
  37144       S CHCL CI=$P(^CHM XCLE(CHCLE I,0),"^",1 )  ;TRAVER SE BACK TH ROUGH BUFF ER FILES
  37145   "RTN","CHM XWB21",424 ,0)
  37146       S CHCL BI=$P(^CHM XCLC(CHCLC I,0),"^",1 )  ;GET "I " VALUES F OR ALL BUF FER FILES
  37147   "RTN","CHM XWB21",425 ,0)
  37148       S CHCL AI=$P(^CHM XCLB(CHCLB I,0),"^",1 )
  37149   "RTN","CHM XWB21",426 ,0)
  37150       S CHCL I=$P(^CHMX CLA(CHCLAI ,0),"^",1)
  37151   "RTN","CHM XWB21",427 ,0)
  37152       S:'$D( COUNT) COU NT=0
  37153   "RTN","CHM XWB21",428 ,0)
  37154       K CHRJ ARR
  37155   "RTN","CHM XWB21",429 ,0)
  37156       S STYP E=$$GETSTY PE(CHCLEI)   ; "TYPE"  PENDING/A CK/FINAL
  37157   "RTN","CHM XWB21",430 ,0)
  37158       ;HAPE  POR 1/6/14  - if line  status is  different  from runt ype, do no t include
  37159   "RTN","CHM XWB21",431 ,0)
  37160       I STYP E'=RUNTYPE  S EICNT=$ G(EICNT)-1  Q
  37161   "RTN","CHM XWB21",432 ,0)
  37162       ;HAPE  POR 1/6/14  - QUIT MI SSING AT E ND OF LINE
  37163   "RTN","CHM XWB21",433 ,0)
  37164       I STYP E="P" S CH RJARR(0)=1  S CHRJARR (1,1)="P1* 45*" D  Q   ; ALL "PE NDING" = P 1/45
  37165   "RTN","CHM XWB21",434 ,0)
  37166       .D CLM
  37167   "RTN","CHM XWB21",435 ,0)
  37168       .D BLD STC("CLM")   ; EACH C LAIM GETS  CLM, STC R ECORDS
  37169   "RTN","CHM XWB21",436 ,0)
  37170       ;HAPE  POR 1/6/14  - added Q UIT to end  of STYPE= "A" do
  37171   "RTN","CHM XWB21",437 ,0)
  37172       I STYP E="A" D  Q
  37173   "RTN","CHM XWB21",438 ,0)
  37174       .D BLD ACK          ; BUILD  "ACK" REJE CT REASON  CODES ARRA Y (CHRJARR )
  37175   "RTN","CHM XWB21",439 ,0)
  37176       .I $G( STVAL)=""  S STVAL=$$ GETSTVAL(C HCLEI)  ;  GET STATUS  OF CLAIM  (6=FRONT E ND EDIT FA IL)
  37177   "RTN","CHM XWB21",440 ,0)
  37178       .I STV AL'=6 S CH RJARR(0)=1 ,CHRJARR(1 ,1)="A2*20 *"  ; NO F RONT END E DITS GET A 2/20
  37179   "RTN","CHM XWB21",441 ,0)
  37180       .D CLM
  37181   "RTN","CHM XWB21",442 ,0)
  37182       .D BLD STC("CLM")   ; ALL "A CKS" GET A  STATUS
  37183   "RTN","CHM XWB21",443 ,0)
  37184       .K CHR JARR S CHR JARR(0)=0
  37185   "RTN","CHM XWB21",444 ,0)
  37186       .S CHC LFI=0
  37187   "RTN","CHM XWB21",445 ,0)
  37188       .F  S  CHCLFI=$O( ^CHMXCLF(" B",CHCLEI, CHCLFI)) Q :CHCLFI=""   D
  37189   "RTN","CHM XWB21",446 ,0)
  37190       ..D GL INRJRSN^CH MXWBUT(CHC LFI)
  37191   "RTN","CHM XWB21",447 ,0)
  37192       .D:CHR JARR(0)>0  LINE  ; NO  LINE REJE CTS RECORD ED = NO LI NE REPORTS
  37193   "RTN","CHM XWB21",448 ,0)
  37194       I STYP E="F" D
  37195   "RTN","CHM XWB21",449 ,0)
  37196       . N CL MSTAT
  37197   "RTN","CHM XWB21",450 ,0)
  37198       . S (C HKDATE,CHK EFT,PAYDAT E,CHMPAY)= ""
  37199   "RTN","CHM XWB21",451 ,0)
  37200       . K CH RJARR S CH RJARR(0)=1
  37201   "RTN","CHM XWB21",452 ,0)
  37202       . S CH CLFI=0
  37203   "RTN","CHM XWB21",453 ,0)
  37204       . ;;HA PE POR - T HE FOLLOWI NG ATTEMPT S TO DETER MINE PROPE R STATUS C ODE
  37205   "RTN","CHM XWB21",454 ,0)
  37206       . ;; T O REPORT F OR THE CLA IM - 1ST C HECK FOR R EJECT CLAI M LINES
  37207   "RTN","CHM XWB21",455 ,0)
  37208       . ;; T HEN BUILD  CLMSTAT FR OM CHAMPVA  CLAIMS AN D WHETHER  PAYMENT WA S
  37209   "RTN","CHM XWB21",456 ,0)
  37210       . ;; R EQUESTED
  37211   "RTN","CHM XWB21",457 ,0)
  37212       . F  S  CHCLFI=$O (^CHMXCLF( "B",CHCLEI ,CHCLFI))  Q:CHCLFI=" "  D
  37213   "RTN","CHM XWB21",458 ,0)
  37214       .. I $ P($G(^CHMX CLF(CHCLFI ,100)),"^" ) D
  37215   "RTN","CHM XWB21",459 ,0)
  37216       ... I  $G(CHRJARR (1,1))=""! ($G(CHRJAR R(1,1))="F 2*1*") S C HRJARR(1,1 )="F2*1*"  Q
  37217   "RTN","CHM XWB21",460 ,0)
  37218       ... S  CHRJARR(1, 1)="F0*1*"
  37219   "RTN","CHM XWB21",461 ,0)
  37220       ... Q
  37221   "RTN","CHM XWB21",462 ,0)
  37222       . S CH MPAY="" F   S CHMPAY= $O(^CHMXCL E(CHCLEI,8 0,"B",CHMP AY)) Q:CHM PAY=""  D
  37223   "RTN","CHM XWB21",463 ,0)
  37224       .. I $ G(HACPAY(C HMPAY))=""  S HACPAY( CHMPAY)=$P ($G(^CHMPA Y(CHMPAY,1 )),"^")
  37225   "RTN","CHM XWB21",464 ,0)
  37226       .. I $ P($G(^CHMP AY(CHMPAY, 1)),"^",4) >CHKDATE S  CHKDATE=$ P(^(1),"^" ,4),CHKEFT =$P(^(1)," ^",16)
  37227   "RTN","CHM XWB21",465 ,0)
  37228       .. I $ P($G(^CHMP AY(CHMPAY, 0)),"^",10 )>PAYDATE  S PAYDATE= $P(^(0),"^ ",10)
  37229   "RTN","CHM XWB21",466 ,0)
  37230       .. I ' $D(^CHMSNA (741008.2, "AB",CHMPA Y)),'$D(^C HMSNA(7410 08.3,"D",C HMPAY)) S  CLMSTAT=$G (CLMSTAT)_ ";0" Q
  37231   "RTN","CHM XWB21",467 ,0)
  37232       .. S C LMSTAT=$G( CLMSTAT)_" ;"_$P(^CHM PAY(CHMPAY ,0),"^",2)
  37233   "RTN","CHM XWB21",468 ,0)
  37234       .. S T OC=$$TOS^C H835FU1($P ($G(^CHMPA Y(CHMPAY,0 )),"^",7))
  37235   "RTN","CHM XWB21",469 ,0)
  37236       .. S C LTYPE=$S(T OC="IPT":" INP-REV",T OC="OPT":" OPT-PROC", TOC="RXT": "PHARM",TO C="DUR":"D ME-SUPPLY" ,TOC="DNT" :"DEN-PROC ",TOC="TRV ":"OPT-PRO C",1:"OPT- PROC")
  37237   "RTN","CHM XWB21",470 ,0)
  37238       .. S P IECE=$S(TO C="DNT":"1 ;2;5",TOC= "DUR":"1;2 ;4",TOC="I PT":"1;2;5 ",TOC="OPT ":"1;2;3", TOC="RXT": "2;4;5",TO C="TRV":"1 ;2;3",1:"" )
  37239   "RTN","CHM XWB21",471 ,0)
  37240       .. I P IECE="" Q
  37241   "RTN","CHM XWB21",472 ,0)
  37242       .. I $ P($G(^CHMP AY(CHMPAY, 0)),"^",2) =4 D
  37243   "RTN","CHM XWB21",473 ,0)
  37244       ... I  TOC="IPT"  S CLMSTAT= $G(CLMSTAT )_";4" Q
  37245   "RTN","CHM XWB21",474 ,0)
  37246       ... S  LN=0,OK=0  F  S LN=$O (^CHMPAY(C HMPAY,CLTY PE,LN)) Q: 'LN  S LD= $G(^(LN,0) ) D
  37247   "RTN","CHM XWB21",475 ,0)
  37248       .... S  ALLOWAMT= $P(LD,"^", $P(PIECE," ;",3))
  37249   "RTN","CHM XWB21",476 ,0)
  37250       .... ; HAPE POR -  IF ALLOWA BLE AMOUNT  IS NOT >0 , THEN ASS UME LINE S TATUS
  37251   "RTN","CHM XWB21",477 ,0)
  37252       .... ;          S HOULD BE F 0
  37253   "RTN","CHM XWB21",478 ,0)
  37254       .... I  ALLOWAMT' >0 S CLMST AT=$G(CLMS TAT)_";0"
  37255   "RTN","CHM XWB21",479 ,0)
  37256       . I $F (CLMSTAT," ;0"),$F(CL MSTAT,";4" ) S CHRJAR R(1,1)="F0 *1*"
  37257   "RTN","CHM XWB21",480 ,0)
  37258       . I '$ F(CLMSTAT, ";0") S CH RJARR(1,1) ="F1*65*"
  37259   "RTN","CHM XWB21",481 ,0)
  37260       . I '$ F(CLMSTAT, ";4") S CH RJARR(1,1) ="F2*1*"
  37261   "RTN","CHM XWB21",482 ,0)
  37262       . S CH KDATE=$P(C HKDATE,"." ),PAYDATE= $P(PAYDATE ,".")
  37263   "RTN","CHM XWB21",483 ,0)
  37264       . I CH KDATE'=""  S CHKDATE= CHKDATE+17 000000
  37265   "RTN","CHM XWB21",484 ,0)
  37266       . I PA YDATE'=""  S PAYDATE= PAYDATE+17 000000
  37267   "RTN","CHM XWB21",485 ,0)
  37268       . ;CFS  01/18/201 8 Check if  ^CHMXCLE  has Reopen  Reject Re ason, 
  37269   "RTN","CHM XWB21",486 ,0)
  37270       . ;     if so, ov erride CHR JARR(1,1)  with Reope n Reject R eason.
  37271   "RTN","CHM XWB21",487 ,0)
  37272    . N ERRST R
  37273   "RTN","CHM XWB21",488 ,0)
  37274       . S ER RSTR="F3*6 86*;"  ;Re open Rejec t Reasons.
  37275   "RTN","CHM XWB21",489 ,0)
  37276       . D GE TRORSN^CHM XWBUT(CHCL EI,ERRSTR, .CHRJARR)
  37277   "RTN","CHM XWB21",490 ,0)
  37278       . D CL M
  37279   "RTN","CHM XWB21",491 ,0)
  37280       . D BL DSTC("CLM" )
  37281   "RTN","CHM XWB21",492 ,0)
  37282       . D LI NE
  37283   "RTN","CHM XWB21",493 ,0)
  37284       Q
  37285   "RTN","CHM XWB21",494 ,0)
  37286       ;
  37287   "RTN","CHM XWB21",495 ,0)
  37288   GETSTYPE(C HCLEI) ; T YPE OF CLA IM STATUS  FOR BLDSTC ()
  37289   "RTN","CHM XWB21",496 ,0)
  37290       N PDI
  37291   "RTN","CHM XWB21",497 ,0)
  37292       I $$FI NAL(CHCLEI ) Q "F"
  37293   "RTN","CHM XWB21",498 ,0)
  37294       S PDI= $P($G(^CHM XCLE(CHCLE I,100)),"^ ",2)  ; IF  PDI ASSIG NED, CHECK  FOR "PEND ING"
  37295   "RTN","CHM XWB21",499 ,0)
  37296       S:PDI= "" PDI=$P( $G(^CHMXCL E(CHCLEI,1 00)),"^",4 )
  37297   "RTN","CHM XWB21",500 ,0)
  37298       I PDI  I $D(^CHMP AY("C",PDI )) Q "P"
  37299   "RTN","CHM XWB21",501 ,0)
  37300       Q "A"   ; NO PDI,  MUST BE " ACK"
  37301   "RTN","CHM XWB21",502 ,0)
  37302       ;
  37303   "RTN","CHM XWB21",503 ,0)
  37304   FINAL(CHCL EI) ; HAPE  POR - FIN AL STATUS
  37305   "RTN","CHM XWB21",504 ,0)
  37306       ; ONLY  CLAIMS TH AT HAVE CL AIM STATUS  OF EITHER
  37307   "RTN","CHM XWB21",505 ,0)
  37308       ; REJE CTED(0) OR  COMPLETE( 4) OR VOID (11)
  37309   "RTN","CHM XWB21",506 ,0)
  37310       N CHMP AY,OK
  37311   "RTN","CHM XWB21",507 ,0)
  37312       S OK=0
  37313   "RTN","CHM XWB21",508 ,0)
  37314       I $O(^ CHMXCLE(CH CLEI,80,"B ",0)) D
  37315   "RTN","CHM XWB21",509 ,0)
  37316       . S CH MPAY=0,OK= 1
  37317   "RTN","CHM XWB21",510 ,0)
  37318       . F  S  CHMPAY=$O (^CHMXCLE( CHCLEI,80, "B",CHMPAY )) Q:CHMPA Y=""  D  Q :'OK
  37319   "RTN","CHM XWB21",511 ,0)
  37320       .. N C HMSTAT  ;C PE005-043  - Add Stat us of 11 c heck.
  37321   "RTN","CHM XWB21",512 ,0)
  37322       .. S C HMSTAT=$P( $G(^CHMPAY (CHMPAY,0) ),"^",2)
  37323   "RTN","CHM XWB21",513 ,0)
  37324       .. I C HMSTAT=0!( CHMSTAT=4) !(CHMSTAT= 11) Q
  37325   "RTN","CHM XWB21",514 ,0)
  37326       .. ;I  $P($G(^CHM PAY(CHMPAY ,0)),"^",2 )=4 Q
  37327   "RTN","CHM XWB21",515 ,0)
  37328       .. ;I  $P($G(^CHM PAY(CHMPAY ,0)),"^",2 )=0 Q
  37329   "RTN","CHM XWB21",516 ,0)
  37330       .. S O K=0
  37331   "RTN","CHM XWB21",517 ,0)
  37332       .. Q
  37333   "RTN","CHM XWB21",518 ,0)
  37334       Q OK
  37335   "RTN","CHM XWB21",519 ,0)
  37336       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  37337   "RTN","CHM XWB21",520 ,0)
  37338       ; FUNC TIONS TO G ATHER INFO RMATION RE GARDING RE JECT REASO NS   ;
  37339   "RTN","CHM XWB21",521 ,0)
  37340       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;   
  37341   "RTN","CHM XWB21",522 ,0)
  37342       ;
  37343   "RTN","CHM XWB21",523 ,0)
  37344   BLDACK ; P OPULATE CH RJARR REJE CT REASON/ REJECT COD E VALUES
  37345   "RTN","CHM XWB21",524 ,0)
  37346       K CHRJ ARR  S CHR JARR(0)=0
  37347   "RTN","CHM XWB21",525 ,0)
  37348       ; CLEA R THE REJE CT REASON  ARRAY
  37349   "RTN","CHM XWB21",526 ,0)
  37350       S REJC ODES=""
  37351   "RTN","CHM XWB21",527 ,0)
  37352       D GTRX RJRSN^CHMX WBUT(CHCLA I)  ; TRAN SACTION "1 01" NODE R EJECT REAS ONS
  37353   "RTN","CHM XWB21",528 ,0)
  37354       D GPRO RJRSN^CHMX WBUT(CHCLB I)  ; PROV IDER "101"  NODE REJE CT REASONS
  37355   "RTN","CHM XWB21",529 ,0)
  37356       D GPAT RJRSN^CHMX WBUT(CHCLC I)  ; PATI ENT "101"  NODE REJEC T REASONS
  37357   "RTN","CHM XWB21",530 ,0)
  37358       D GCLM RJRSN^CHMX WBUT(CHCLE I)  ; CLAI M "101" NO DE REJECT  REASONS
  37359   "RTN","CHM XWB21",531 ,0)
  37360       I CHRJ ARR(0)=0 S  CHRJARR(0 )=1,CHRJAR R(1,1)="A3 *247*"
  37361   "RTN","CHM XWB21",532 ,0)
  37362       ;I $D( TEST) W !, "BLDACK: R JCNT=",CHR JARR(0),"   RJARR(1,1 )=",CHRJAR R(1,1)
  37363   "RTN","CHM XWB21",533 ,0)
  37364       Q
  37365   "RTN","CHM XWB21",534 ,0)
  37366       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  37367   "RTN","CHM XWB21",535 ,0)
  37368       ; RECO RD BUILDIN G FUNCTION S:  $TEXT  FILES PROV IDE FIELD  DEFINTIONS       ;
  37369   "RTN","CHM XWB21",536 ,0)
  37370       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  37371   "RTN","CHM XWB21",537 ,0)
  37372   BLDHDR ;BU ILD HEADER  RECORD
  37373   "RTN","CHM XWB21",538 ,0)
  37374       N LN,R EC,STR,LOA DTYPE,PAYN AME,PAYPHO NE
  37375   "RTN","CHM XWB21",539 ,0)
  37376       S (STR ,LN,REC)=" ",COUNT=2   ; EMDEON  SPEC: REC.  COUNT STA RTS @ 2
  37377   "RTN","CHM XWB21",540 ,0)
  37378       D GETH DRVAL                  ; SET UP  HEADER VAR IABLES
  37379   "RTN","CHM XWB21",541 ,0)
  37380       F LN=1 :1 S STR=$ T(EMDEONHD R+LN) Q:ST R["END OF  RECORD"  D
  37381   "RTN","CHM XWB21",542 ,0)
  37382       .I LN= 1 S REC=RE C_$$FORMAT DATA^CHMXW BUT(STR)
  37383   "RTN","CHM XWB21",543 ,0)
  37384       .E  S  REC=REC_"| "_$$FORMAT DATA^CHMXW BUT(STR)
  37385   "RTN","CHM XWB21",544 ,0)
  37386       U DIRF ILE W REC, ! S REC=""
  37387   "RTN","CHM XWB21",545 ,0)
  37388       Q
  37389   "RTN","CHM XWB21",546 ,0)
  37390       ;
  37391   "RTN","CHM XWB21",547 ,0)
  37392   CLM ;
  37393   "RTN","CHM XWB21",548 ,0)
  37394       N BPFT I,BPPN,BPN ID,BPLNAME ,BPFNAME,B PMNAME,SPF TID
  37395   "RTN","CHM XWB21",549 ,0)
  37396       N SPPN ,SPNID,SPL NAME,SPFNA ME,EMPIDNU M,EMPNAME, SUBSCID,SU BLNAME
  37397   "RTN","CHM XWB21",550 ,0)
  37398       N SUBF NAME,SUBMN AME,SUBNAM EX,PATID,P ATLNAME,PA TFNAME,PAT MNAME,PATN AMEX,PATDO B
  37399   "RTN","CHM XWB21",551 ,0)
  37400       N PATG ENDR,ECLMN UM,CLMCHRG ,CLMPMT,CA PD,CHKEFTD ATE,CHKEFT NUM,BTYPE, PCIDNUM
  37401   "RTN","CHM XWB21",552 ,0)
  37402       N PATA CCT,PRSCNU M,VOUCHID, LOCSYSID,G RPNUM,CLMS TDT,CLMEND T
  37403   "RTN","CHM XWB21",553 ,0)
  37404       N PDI, CHMPAYI,RE C,LN,STR,S VCDATES,SP MNAME,SPNA MEX,BPNAME X
  37405   "RTN","CHM XWB21",554 ,0)
  37406       ; DO A CK AND PEN DING
  37407   "RTN","CHM XWB21",555 ,0)
  37408       ; HAPE  POR 7/8/1 3 Adding F INAL
  37409   "RTN","CHM XWB21",556 ,0)
  37410       S PDI= $P($G(^CHM XCLE(CHCLE I,100)),"^ ",2)  ; IF  PDI ASSIG NED, MUST  BE "PENDIN G"
  37411   "RTN","CHM XWB21",557 ,0)
  37412       I PDI= "" S PDI=$ P($G(^CHMX CLE(CHCLEI ,100)),"^" ,4)
  37413   "RTN","CHM XWB21",558 ,0)
  37414       I PDI' ="" S CHMP AYI=$O(^CH MPAY("C",P DI,0))
  37415   "RTN","CHM XWB21",559 ,0)
  37416       D GETC LMVAL              ;  SET UP THE  CLAIM VAL UE VARIABL ES
  37417   "RTN","CHM XWB21",560 ,0)
  37418       S REC= ""                 ;  BUILD THE  RECORD
  37419   "RTN","CHM XWB21",561 ,0)
  37420       F LN=1 :1 S STR=$ T(EMDEONCL M+LN) Q:ST R["END OF  RECORD"  D
  37421   "RTN","CHM XWB21",562 ,0)
  37422       .I LN= 1 S REC=RE C_$$FORMAT DATA^CHMXW BUT(STR)
  37423   "RTN","CHM XWB21",563 ,0)
  37424       .E  S  REC=REC_"| "_$$FORMAT DATA^CHMXW BUT(STR)
  37425   "RTN","CHM XWB21",564 ,0)
  37426       U DIRF ILE W REC, ! S REC="" ,COUNT=COU NT+1
  37427   "RTN","CHM XWB21",565 ,0)
  37428       Q
  37429   "RTN","CHM XWB21",566 ,0)
  37430       ;
  37431   "RTN","CHM XWB21",567 ,0)
  37432   LINE ; BUI LD DTL REC ORDS FOR L INE ITEMS
  37433   "RTN","CHM XWB21",568 ,0)
  37434       N CLML INK
  37435   "RTN","CHM XWB21",569 ,0)
  37436       N PCID ,LICN,SQID ,SICODE,PR CM1,PRCM2, PRCM3,PRCM 4,LICHRGA, LIPPA
  37437   "RTN","CHM XWB21",570 ,0)
  37438       N RVNU CODE,QTYUO S,SVCSTDAT E,SVCENDAT E
  37439   "RTN","CHM XWB21",571 ,0)
  37440       N LN,H ACCLM,LNDA TA,LNDATA1 ,OK,X1
  37441   "RTN","CHM XWB21",572 ,0)
  37442       N XCLF HAC,SERVLN ,ALLOWAMT, CLTYPE,ECL MNUM,PROCA MT,PROCCOD E
  37443   "RTN","CHM XWB21",573 ,0)
  37444       N PROC INT,PROCUN IT,CHECK,O RGCAMT,AGA IN,CLMCHRG ,LASTAMT
  37445   "RTN","CHM XWB21",574 ,0)
  37446       S CLMC HRG=$S($P( ^CHMXCLE(C HCLEI,2)," ^")'>0:"0. 00",1:$P(^ CHMXCLE(CH CLEI,2),"^ "))
  37447   "RTN","CHM XWB21",575 ,0)
  37448       I RUNT YPE="F" D  CHECK^CHMX WB24 I $G( CLMLINK)=0  D LINE^CH MXWB24 Q
  37449   "RTN","CHM XWB21",576 ,0)
  37450       ;HAPE  POR 7/8/13  - attempt  to put li ne items b ack togeth er after
  37451   "RTN","CHM XWB21",577 ,0)
  37452       ; CP&E  Claims pr ocessing s oftware sp lit origin al claim l ines
  37453   "RTN","CHM XWB21",578 ,0)
  37454       S (AGA IN,CHCLFI) =0
  37455   "RTN","CHM XWB21",579 ,0)
  37456       F  S C HCLFI=$O(^ CHMXCLF("B ",CHCLEI,C HCLFI)) Q: CHCLFI=""   S CHECK=0  D
  37457   "RTN","CHM XWB21",580 ,0)
  37458       . ;HAP E POR - if  no charge  amount, t hen skip S ERVICE LIN E LEVEL en try
  37459   "RTN","CHM XWB21",581 ,0)
  37460       . ; In  order to  properly r eport fina l claim st atus, orig inal 837
  37461   "RTN","CHM XWB21",582 ,0)
  37462       . ; cl aim must b e put back  together  with CHAMP VA Claims.
  37463   "RTN","CHM XWB21",583 ,0)
  37464       . ; Si nce there  is no dire ct link, t hen a logi cal proces s needs
  37465   "RTN","CHM XWB21",584 ,0)
  37466       . ; to  be used t o associat e each X12  837 BUFFE R SERVICE  LINE entry
  37467   "RTN","CHM XWB21",585 ,0)
  37468       . ; wi th the ass ociated ^C HMPAY clai ms entries .
  37469   "RTN","CHM XWB21",586 ,0)
  37470       . I RU NTYPE="F"  Q:$P($G(^C HMXCLF(CHC LFI,1)),"^ ",6)=""  D
  37471   "RTN","CHM XWB21",587 ,0)
  37472       .. S S ERVLN=$P(^ CHMXCLF(CH CLFI,0),"^ ",2)
  37473   "RTN","CHM XWB21",588 ,0)
  37474       .. S P ROCCODE=$P (^CHMXCLF( CHCLFI,1), "^",3),PRO CAMT=$P(^( 1),"^",6), ORGCAMT=""
  37475   "RTN","CHM XWB21",589 ,0)
  37476       .. S P ROCUNIT=$F N($P(^(1), "^",8)+.49 ,"",0)
  37477   "RTN","CHM XWB21",590 ,0)
  37478       .. I P ROCCODE'=" " S PROCIN T=$O(^CHMS ERV("B",PR OCCODE,"") )
  37479   "RTN","CHM XWB21",591 ,0)
  37480       .. I P ROCUNIT=""  S PROCUNI T=1
  37481   "RTN","CHM XWB21",592 ,0)
  37482       .. ;HA PE POR - i f # of uni ts is >1 t hen look f or multipl e lines
  37483   "RTN","CHM XWB21",593 ,0)
  37484       .. ;          in  the CHAMPV A CLAIMS f ile for th is same pr ocedure
  37485   "RTN","CHM XWB21",594 ,0)
  37486       .. ;          and  service d ate that t otal the o riginal #  units.
  37487   "RTN","CHM XWB21",595 ,0)
  37488       .. I P ROCUNIT>1  D
  37489   "RTN","CHM XWB21",596 ,0)
  37490       ... S  ORGCAMT=PR OCAMT,PROC AMT=PROCAM T/PROCUNIT ,PROCAMT=$ FN(PROCAMT ,"",2)
  37491   "RTN","CHM XWB21",597 ,0)
  37492       ... I  $FN(PROCAM T*PROCUNIT ,"",2)=$FN (ORGCAMT," ",2) Q
  37493   "RTN","CHM XWB21",598 ,0)
  37494       ... S  LASTAMT=PR OCAMT*(PRO CUNIT-1),L ASTAMT=ORG CAMT-LASTA MT
  37495   "RTN","CHM XWB21",599 ,0)
  37496       .. S H ACCLM="" F   S HACCLM =$O(^CHMXC LE(CHCLEI, 80,"B",HAC CLM)) Q:HA CCLM=""  D   Q:$G(OK)
  37497   "RTN","CHM XWB21",600 ,0)
  37498       ... S  TOC=$$TOS^ CH835FU1($ P($G(^CHMP AY(HACCLM, 0)),"^",7) )
  37499   "RTN","CHM XWB21",601 ,0)
  37500       ... I  TOC="IPT"  D
  37501   "RTN","CHM XWB21",602 ,0)
  37502       .... S  PROCUNIT= 1,PROCAMT= $P(^CHMXCL F(CHCLFI,1 ),"^",6)
  37503   "RTN","CHM XWB21",603 ,0)
  37504       .... I  $G(IPTOHI (HACCLM))= "" S IPTOH I(HACCLM)= $P($G(^CHM PAY(HACCLM ,1)),"^",7 )
  37505   "RTN","CHM XWB21",604 ,0)
  37506       .... I  '$D(^CHMP AY(HACCLM, "INP-ITEM" )),$G(IPTA MT(HACCLM) )="" S IPT AMT(HACCLM )=$P($G(^C HMPAY(HACC LM,1)),"^" ,14)
  37507   "RTN","CHM XWB21",605 ,0)
  37508       ... S  CLTYPE=$S( TOC="IPT": "INP-REV", TOC="OPT": "OPT-PROC" ,TOC="RXT" :"PHARM",T OC="DUR":" DME-SUPPLY ",TOC="DNT ":"DEN-PRO C",TOC="TR V":"OPT-PR OC",1:"OPT -PROC")
  37509   "RTN","CHM XWB21",606 ,0)
  37510       ... S  PIECE=$S(T OC="DNT":" 1;2;5",TOC ="DUR":"1; 2;4",TOC=" IPT":"1;2; 5",TOC="OP T":"1;2;3" ,TOC="RXT" :"2;4;5",T OC="TRV":" 1;2;3",1:" ")
  37511   "RTN","CHM XWB21",607 ,0)
  37512       ... I  PIECE="" Q
  37513   "RTN","CHM XWB21",608 ,0)
  37514       ... ;  HAPE POR -  look thru  CHMPAY li nes, looki ng for a m atch, if f ound OK=1
  37515   "RTN","CHM XWB21",609 ,0)
  37516       ... S  (AGAIN,LN, OK)=0 F  S  LN=$O(^CH MPAY(HACCL M,CLTYPE,L N)) D:'LN& ('AGAIN) A GAIN  Q:'L N  S LD=$G (^(LN,0))  D  Q:OK
  37517   "RTN","CHM XWB21",610 ,0)
  37518       .... I  TOC="OPT" ,$L(LD,"^" )'>3 Q  ;H APE POR fo r incomple te line in fo
  37519   "RTN","CHM XWB21",611 ,0)
  37520       .... ;  HAPE POR  - if X12 8 37 BUFFER  SERVICE LI NE LEVEL e ntry
  37521   "RTN","CHM XWB21",612 ,0)
  37522       .... ;  is alread y mapped t o a CHAMPV A CLAIM, s kip it.
  37523   "RTN","CHM XWB21",613 ,0)
  37524       .... I  $D(LNDATA 1(HACCLM,L N)) Q
  37525   "RTN","CHM XWB21",614 ,0)
  37526       .... I  $P(LD,"^" ,$P(PIECE, ";"))=$G(P ROCINT),$F N($P(LD,"^ ",$P(PIECE ,";",2))," ",2)=$FN(P ROCAMT,"", 2) S OK=$S ($G(CHECK) :$$CHECK(H ACCLM,CHCL FI),1:1) Q
  37527   "RTN","CHM XWB21",615 ,0)
  37528       .... I  AGAIN,$G( ORGCAMT),P ROCUNIT>1, $FN($P(LD, "^",$P(PIE CE,";",2)) ,"",2)'>$F N(ORGCAMT, "",2) D
  37529   "RTN","CHM XWB21",616 ,0)
  37530       .....  I $FN($P(L D,"^",$P(P IECE,";",2 )),"",2)=" 0.00" Q
  37531   "RTN","CHM XWB21",617 ,0)
  37532       .....  I '$F(ORGC AMT/$P(LD, "^",$P(PIE CE,";",2)) ,".") S PR OCAMT=$P(L D,"^",$P(P IECE,";",2 )),PROCUNI T=ORGCAMT/ PROCAMT S  OK=$S($G(C HECK):$$CH ECK(HACCLM ,CHCLFI),1 :1) Q
  37533   "RTN","CHM XWB21",618 ,0)
  37534       .... I  AGAIN,$FN ($P(LD,"^" ,$P(PIECE, ";",2)),"" ,2)=$FN(PR OCAMT,"",2 ),$O(^CHMP AY(HACCLM, CLTYPE,LN) )="" S OK= $S($G(CHEC K):$$CHECK (HACCLM,CH CLFI),1:1)  Q
  37535   "RTN","CHM XWB21",619 ,0)
  37536       .... I  AGAIN,$P( LD,"^",$P( PIECE,";") )=$G(PROCI NT),$O(^CH MPAY(HACCL M,CLTYPE,L N))="",$D( LNDATA1(HA CCLM)) S O K=$S($G(CH ECK):$$CHE CK(HACCLM, CHCLFI),1: 1) Q
  37537   "RTN","CHM XWB21",620 ,0)
  37538       .... I  AGAIN,$FN ($P(LD,"^" ,$P(PIECE, ";",2)),"" ,2)=$FN(PR OCAMT,"",2 ) S OK=$S( $G(CHECK): $$CHECK(HA CCLM,CHCLF I),1:1) Q
  37539   "RTN","CHM XWB21",621 ,0)
  37540       .... I  $G(ORGCAM T),$FN($P( LD,"^",$P( PIECE,";", 2)),"",2)= $FN(ORGCAM T,"",2) S  OK=$S($G(C HECK):$$CH ECK(HACCLM ,CHCLFI),1 :1),PROCUN IT=1 Q
  37541   "RTN","CHM XWB21",622 ,0)
  37542       .... I  TOC="IPT" ,$FN($P(LD ,"^",$P(PI ECE,";",2) ),"",2)=$F N(PROCAMT, "",2) D  S  OK=$S($G( CHECK):$$C HECK(HACCL M,CHCLFI), 1:1) Q
  37543   "RTN","CHM XWB21",623 ,0)
  37544       .....  I $G(IPTOH I(HACCLM)) >PROCAMT S  IPTOHI(HA CCLM,CHCLF I)=PROCAMT ,IPTOHI(HA CCLM)=IPTO HI(HACCLM) -PROCAMT Q
  37545   "RTN","CHM XWB21",624 ,0)
  37546       .....  S IPTOHI(H ACCLM,CHCL FI)=IPTOHI (HACCLM),I PTOHI(HACC LM)=0
  37547   "RTN","CHM XWB21",625 ,0)
  37548       .... ; I AGAIN,'$ O(^CHMXCLF ("B",CHCLE I,CHCLFI)) ,PROCAMT=C LMCHRG,$D( LNDATA1(HA CCLM)) S O K=$S($G(CH ECK):$$CHE CK(HACCLM, CHCLFI),1: 1) Q
  37549   "RTN","CHM XWB21",626 ,0)
  37550       ... I  LN'=+LN Q   ;HAPE POR  - reached  the end o f lines wi th no matc h
  37551   "RTN","CHM XWB21",627 ,0)
  37552       ... I  OK,$P(^CHM PAY(HACCLM ,0),"^",2) '=4 S OK=$ $CHECK(HAC CLM,CHCLFI ) I OK S C HECK=1,OK= 0
  37553   "RTN","CHM XWB21",628 ,0)
  37554       ... ;H APE POR 7/ 16/13 - PR OBLEM FOUN D WITH MUL TIPLE CHMP AY ENTRIES  FOR THE S AME LINE,U SE MOST RE CENT
  37555   "RTN","CHM XWB21",629 ,0)
  37556       ... K  LNDATA(SER VLN)
  37557   "RTN","CHM XWB21",630 ,0)
  37558       ... ;H APE POR -  LNDATA arr ay is used  to setup  mapping of  lines
  37559   "RTN","CHM XWB21",631 ,0)
  37560       ... ;    SERVLN f rom X12 83 7 BUFFER S ERVICE LIN E LEVEL FI LE
  37561   "RTN","CHM XWB21",632 ,0)
  37562       ... ;    MAPPED T O EACH CHA MPVA CLAIM S INTERNAL  VALUE (HA CCLM)
  37563   "RTN","CHM XWB21",633 ,0)
  37564       ... ;    AND THE  ASSOCIATED  LINE NUMB ER (LN).   KEEP IN MI ND THERE
  37565   "RTN","CHM XWB21",634 ,0)
  37566       ... ;    MAY BE M ULTIPLES F OR UNITS >  1
  37567   "RTN","CHM XWB21",635 ,0)
  37568       ... ;    
  37569   "RTN","CHM XWB21",636 ,0)
  37570       ... ;    LNDATA1  array is u sed to mak e sure lin es are not  mapped
  37571   "RTN","CHM XWB21",637 ,0)
  37572       ... ;             multiple t imes.
  37573   "RTN","CHM XWB21",638 ,0)
  37574       ... S  LNDATA(SER VLN,HACCLM ,LN)=LD,LN DATA1(HACC LM,LN)=""
  37575   "RTN","CHM XWB21",639 ,0)
  37576       ... S  CLMCHRG=CL MCHRG-PROC AMT
  37577   "RTN","CHM XWB21",640 ,0)
  37578       ... I  PROCUNIT>1  D
  37579   "RTN","CHM XWB21",641 ,0)
  37580       .... S  PROCUNIT= PROCUNIT-1    ;;;,PRO CUNIT=$FN( PROCUNIT+. 49,"",0)
  37581   "RTN","CHM XWB21",642 ,0)
  37582       .... F  I=1:1:PRO CUNIT S LN =$O(^CHMPA Y(HACCLM,C LTYPE,LN))  Q:'LN  S  LD=$G(^(LN ,0)) D  S  ORGCAMT=OR GCAMT-PROC AMT
  37583   "RTN","CHM XWB21",643 ,0)
  37584       .....  I ORGCAMT< PROCAMT S  PROCAMT=OR GCAMT
  37585   "RTN","CHM XWB21",644 ,0)
  37586       .....  I ORGCAMT< (PROCAMT+. 05) S PROC AMT=ORGCAM T
  37587   "RTN","CHM XWB21",645 ,0)
  37588       .....  I $P(LD,"^ ",$P(PIECE ,";"))=$G( PROCINT),$ FN($P(LD," ^",$P(PIEC E,";",2)), "",2)=$FN( PROCAMT,"" ,2) D  Q
  37589   "RTN","CHM XWB21",646 ,0)
  37590       ......  S LNDATA( SERVLN,HAC CLM,LN)=LD
  37591   "RTN","CHM XWB21",647 ,0)
  37592       ......  S LNDATA1 (HACCLM,LN )=""
  37593   "RTN","CHM XWB21",648 ,0)
  37594       .....  I I=PROCUN IT,$P(LD," ^",$P(PIEC E,";"))=$G (PROCINT)  D  Q
  37595   "RTN","CHM XWB21",649 ,0)
  37596       ......  S LNDATA( SERVLN,HAC CLM,LN)=LD
  37597   "RTN","CHM XWB21",650 ,0)
  37598       ......  S LNDATA1 (HACCLM,LN )=""
  37599   "RTN","CHM XWB21",651 ,0)
  37600       .....  I I=PROCUN IT,$G(LAST AMT),$FN($ P(LD,"^",$ P(PIECE,"; ",2)),"",2 )=$FN(LAST AMT,"",2)  D  Q
  37601   "RTN","CHM XWB21",652 ,0)
  37602       ......  S LNDATA( SERVLN,HAC CLM,LN)=LD
  37603   "RTN","CHM XWB21",653 ,0)
  37604       ......  S LNDATA1 (HACCLM,LN )=""
  37605   "RTN","CHM XWB21",654 ,0)
  37606       .....  I $FN($P(L D,"^",$P(P IECE,";",2 )),"",2)=$ FN(PROCAMT ,"",2) D   Q
  37607   "RTN","CHM XWB21",655 ,0)
  37608       ......  S LNDATA( SERVLN,HAC CLM,LN)=LD
  37609   "RTN","CHM XWB21",656 ,0)
  37610       ......  S LNDATA1 (HACCLM,LN )=""
  37611   "RTN","CHM XWB21",657 ,0)
  37612       .....  I $FN($P(L D,"^",$P(P IECE,";",2 )),"",2)=$ FN(PROCAMT -.005,"",2 ) D  Q
  37613   "RTN","CHM XWB21",658 ,0)
  37614       ......  S LNDATA( SERVLN,HAC CLM,LN)=LD
  37615   "RTN","CHM XWB21",659 ,0)
  37616       ......  S LNDATA1 (HACCLM,LN )=""
  37617   "RTN","CHM XWB21",660 ,0)
  37618       .....  Q
  37619   "RTN","CHM XWB21",661 ,0)
  37620       .... Q
  37621   "RTN","CHM XWB21",662 ,0)
  37622       ... ;H APE POR 7/ 8/13 - use d to assoc iate X12 8 37 BUFFER  LINE LEVEL  entries
  37623   "RTN","CHM XWB21",663 ,0)
  37624       ... ;                    to  HAC claim  #
  37625   "RTN","CHM XWB21",664 ,0)
  37626       ... ;       XCLFH AC array i s used to  determine  proper lin e level st atus code
  37627   "RTN","CHM XWB21",665 ,0)
  37628       ... ;       to re port in th e STC reco rd
  37629   "RTN","CHM XWB21",666 ,0)
  37630       ... I  OK D
  37631   "RTN","CHM XWB21",667 ,0)
  37632       .... K  XCLFHAC(C HCLFI)
  37633   "RTN","CHM XWB21",668 ,0)
  37634       .... ;  HAPE POR  7/31/13 -  for split  claim line s due to U nits>1
  37635   "RTN","CHM XWB21",669 ,0)
  37636       .... ;  if the la st item's  allowable  amount was  changed t o 0
  37637   "RTN","CHM XWB21",670 ,0)
  37638       .... ;  entire li ne would b e set to F 2.  so, ch ecking to  see if
  37639   "RTN","CHM XWB21",671 ,0)
  37640       .... ;  there are  any lines  with a po sitive all owable amo unt, then  F1
  37641   "RTN","CHM XWB21",672 ,0)
  37642       .... I  TOC'="IPT ",$P(LD,"^ ",$P(PIECE ,";",3))'> 0 D
  37643   "RTN","CHM XWB21",673 ,0)
  37644       .....  S X=0 F  S  X=$O(LNDA TA(SERVLN, HACCLM,X))  Q:X=""  S  X1=LNDATA (SERVLN,HA CCLM,X) I  $P(X1,"^", $P(PIECE," ;",3))>0 S  LD=X1 Q
  37645   "RTN","CHM XWB21",674 ,0)
  37646       .... I  TOC="IPT"  S XCLFHAC (CHCLFI)=$ G(^CHMPAY( HACCLM,"IN P-ITEM",LN ,0)) I XCL FHAC(CHCLF I)="" D
  37647   "RTN","CHM XWB21",675 ,0)
  37648       .....  I $P(LD,"^ ",2)-$G(IP TOHI(HACCL M,CHCLFI)) '<IPTAMT(H ACCLM) S $ P(LD,"^",5 )=IPTAMT(H ACCLM),LND ATA(SERVLN ,HACCLM,LN )=LD,IPTAM T(HACCLM)= 0,IPTAMT(H ACCLM,CHCL FI)=$P(LD, "^",5) Q
  37649   "RTN","CHM XWB21",676 ,0)
  37650       .....  S $P(LD,"^ ",5)=$P(LD ,"^",2)-$G (IPTOHI(HA CCLM,CHCLF I)),LNDATA (SERVLN,HA CCLM,LN)=L D,IPTAMT(H ACCLM)=IPT AMT(HACCLM )-$P(LD,"^ ",5),IPTAM T(HACCLM,C HCLFI)=$P( LD,"^",5)
  37651   "RTN","CHM XWB21",677 ,0)
  37652       .... S  XCLFHAC(C HCLFI)=LD, XCLFHAC(CH CLFI,HACCL M)=""
  37653   "RTN","CHM XWB21",678 ,0)
  37654       ... Q
  37655   "RTN","CHM XWB21",679 ,0)
  37656       .I RUN TYPE="F",' $D(XCLFHAC (CHCLFI))  S HACCLM=$ O(LNDATA(S ERVLN,""))  I HACCLM  S LN=$O(LN DATA(SERVL N,HACCLM," ")) I LN S  XCLFHAC(C HCLFI)=$G( LNDATA(SER VLN,HACCLM ,LN))
  37657   "RTN","CHM XWB21",680 ,0)
  37658       .; HAP E POR 7/8/ 13 - need  status val ue prior t o D GDTLVA RS
  37659   "RTN","CHM XWB21",681 ,0)
  37660       .I RUN TYPE="F" D
  37661   "RTN","CHM XWB21",682 ,0)
  37662       .. K C HRJARR S C HRJARR(0)= 1
  37663   "RTN","CHM XWB21",683 ,0)
  37664       .. I $ P($G(^CHMX CLF(CHCLFI ,100)),"^" ) S CHRJAR R(1,1)="F2 *1*" Q
  37665   "RTN","CHM XWB21",684 ,0)
  37666       .. I $ G(CHRJARR( 1,1))="" S  CHMPAY=$P ($G(^CHMXC LF(CHCLFI, 80)),"^")  I CHMPAY'= "" D
  37667   "RTN","CHM XWB21",685 ,0)
  37668       ... I  '$D(^CHMSN A(741008.2 ,"AB",CHMP AY)),'$D(^ CHMSNA(741 008.3,"D", CHMPAY)) S  CHRJARR(1 ,1)="F2*1* " Q
  37669   "RTN","CHM XWB21",686 ,0)
  37670       ... I  $P($G(^CHM PAY(CHMPAY ,0)),"^",2 )=0 S CHRJ ARR(1,1)=" F2*1*" Q
  37671   "RTN","CHM XWB21",687 ,0)
  37672       ... I  $P($G(^CHM PAY(CHMPAY ,0)),"^",2 )=4 S CHRJ ARR(1,1)=" F1*65*" Q
  37673   "RTN","CHM XWB21",688 ,0)
  37674       .. I $ G(CHRJARR( 1,1))="",$ D(XCLFHAC( CHCLFI)) S  CHMPAY=$O (XCLFHAC(C HCLFI,""))  I CHMPAY  D  I CHRJA RR(1,1)'=" " Q
  37675   "RTN","CHM XWB21",689 ,0)
  37676       ... I  '$D(^CHMSN A(741008.2 ,"AB",CHMP AY)),'$D(^ CHMSNA(741 008.3,"D", CHMPAY)) S  CHRJARR(1 ,1)="F2*1* " Q
  37677   "RTN","CHM XWB21",690 ,0)
  37678       ... I  $P($G(^CHM PAY(CHMPAY ,0)),"^",2 )=4 D  Q
  37679   "RTN","CHM XWB21",691 ,0)
  37680       .... I  TOC="IPT"  S CHRJARR (1,1)="F1* 65*" Q
  37681   "RTN","CHM XWB21",692 ,0)
  37682       .... S  ALLOWAMT= $P(XCLFHAC (CHCLFI)," ^",$P(PIEC E,";",3))
  37683   "RTN","CHM XWB21",693 ,0)
  37684       .... I  ALLOWAMT> 0 S CHRJAR R(1,1)="F1 *65*" Q
  37685   "RTN","CHM XWB21",694 ,0)
  37686       .... ; HAPE POR -  if comple te, but al lowable am t=0, then  F2 status
  37687   "RTN","CHM XWB21",695 ,0)
  37688       .... S  CHRJARR(1 ,1)="F2*1* "
  37689   "RTN","CHM XWB21",696 ,0)
  37690       ... I  $P($G(^CHM PAY(CHMPAY ,0)),"^",2 )=0 S CHRJ ARR(1,1)=" F2*1*" Q
  37691   "RTN","CHM XWB21",697 ,0)
  37692       .. I $ G(CHRJARR( 1,1))="" S  CHMPAY=""  F  S CHMP AY=$O(^CHM XCLE(CHCLE I,80,"B",C HMPAY)) Q: CHMPAY=""   D  I CHRJ ARR(1,1)'= "" Q
  37693   "RTN","CHM XWB21",698 ,0)
  37694       ... I  '$D(^CHMSN A(741008.2 ,"AB",CHMP AY)),'$D(^ CHMSNA(741 008.3,"D", CHMPAY)) S  CHRJARR(1 ,1)="F2*1* " Q
  37695   "RTN","CHM XWB21",699 ,0)
  37696       ... I  $P($G(^CHM PAY(CHMPAY ,0)),"^",2 )=4 S CHRJ ARR(1,1)=" F1*65*" Q
  37697   "RTN","CHM XWB21",700 ,0)
  37698       ... I  $P($G(^CHM PAY(CHMPAY ,0)),"^",2 )=0 S CHRJ ARR(1,1)=" F2*1*" Q
  37699   "RTN","CHM XWB21",701 ,0)
  37700       .. I $ G(CHRJARR( 1,1))="" S  CHRJARR(1 ,1)="F2*1* "
  37701   "RTN","CHM XWB21",702 ,0)
  37702       . ;CFS  01/18/201 8 Call GET RORSN^CHMX WBUT and c heck if ^C HMXCLE has  Reopen Re ject Reaso n, 
  37703   "RTN","CHM XWB21",703 ,0)
  37704       . ;                 if so, o verride CH RJARR(1,1)  with Reop en Reject  Reason.
  37705   "RTN","CHM XWB21",704 ,0)
  37706    . N ERRST R
  37707   "RTN","CHM XWB21",705 ,0)
  37708       . S ER RSTR="F3*6 86*;"  ;Re open Rejec t Reasons.
  37709   "RTN","CHM XWB21",706 ,0)
  37710       . D GE TRORSN^CHM XWBUT(CHCL EI,ERRSTR, .CHRJARR)
  37711   "RTN","CHM XWB21",707 ,0)
  37712       . D GD TLVARS
  37713   "RTN","CHM XWB21",708 ,0)
  37714       . D BL DLINE
  37715   "RTN","CHM XWB21",709 ,0)
  37716       . Q
  37717   "RTN","CHM XWB21",710 ,0)
  37718       Q
  37719   "RTN","CHM XWB21",711 ,0)
  37720   BLDLINE ;
  37721   "RTN","CHM XWB21",712 ,0)
  37722       N LN,R EC,STR
  37723   "RTN","CHM XWB21",713 ,0)
  37724       S REC= ""
  37725   "RTN","CHM XWB21",714 ,0)
  37726       F LN=1 :1 S STR=$ T(EMDEONLI +LN) Q:STR ["END OF R ECORD"  D
  37727   "RTN","CHM XWB21",715 ,0)
  37728       .I LN= 1 S REC=RE C_$$FORMAT DATA^CHMXW BUT(STR)
  37729   "RTN","CHM XWB21",716 ,0)
  37730       .E  S  REC=REC_"| "_$$FORMAT DATA^CHMXW BUT(STR)
  37731   "RTN","CHM XWB21",717 ,0)
  37732       U DIRF ILE W REC, ! S REC=""  S COUNT=C OUNT+1
  37733   "RTN","CHM XWB21",718 ,0)
  37734       I RUNT YPE'="F" D
  37735   "RTN","CHM XWB21",719 ,0)
  37736       . K CH RJARR  S C HRJARR(0)= 0     ; CL EAR THE RE JECT REASO N ARRAY
  37737   "RTN","CHM XWB21",720 ,0)
  37738       . D GL INRJRSN^CH MXWBUT(CHC LFI)  ; SE RVICE LINE  "101" NOD E REJECT R EASONS
  37739   "RTN","CHM XWB21",721 ,0)
  37740       I RUNT YPE'="F",C HRJARR(0)= 0 S CHRJAR R(0)=1,CHR JARR(1,1)= "A3*247*"
  37741   "RTN","CHM XWB21",722 ,0)
  37742       D BLDS TC("DTL")
  37743   "RTN","CHM XWB21",723 ,0)
  37744       Q
  37745   "RTN","CHM XWB21",724 ,0)
  37746       ;
  37747   "RTN","CHM XWB21",725 ,0)
  37748   BLDSTC(TYP E) ; WRITE  OUT THE S TC RECORDS  FROM CHRJ ARR REJECT  ARRAY
  37749   "RTN","CHM XWB21",726 ,0)
  37750       ;   TY PE    CLAI M OR DETAI L LEVEL EM DEON STATU S VALUES &  LINE ITEM  CONTROL N UMBER
  37751   "RTN","CHM XWB21",727 ,0)
  37752       N PCIN UM,LICNUM, DATERR,ESC ODE,ENTITY
  37753   "RTN","CHM XWB21",728 ,0)
  37754       N IDX, JDX,REJCOD ES,ECNT,RJ CODE,RJSTA TUS
  37755   "RTN","CHM XWB21",729 ,0)
  37756       N LN,S TR,REC
  37757   "RTN","CHM XWB21",730 ,0)
  37758       S REJC ODES=0
  37759   "RTN","CHM XWB21",731 ,0)
  37760       S ECNT =CHRJARR(0 )                          ; FRO NT END EDI T REJECT C OUNT
  37761   "RTN","CHM XWB21",732 ,0)
  37762       F IDX= 1:1 Q:(IDX >ECNT)  D                  ; PRO VIDE STC R ECORD FOR  EACH ERROR
  37763   "RTN","CHM XWB21",733 ,0)
  37764       .F JDX =1:1 Q:$G( CHRJARR(ID X,JDX))=""   D  ; GET  EACH REJE CT VALUE S TORED
  37765   "RTN","CHM XWB21",734 ,0)
  37766       ..S (R JCODE,RJST ATUS,ENTIT Y)=""
  37767   "RTN","CHM XWB21",735 ,0)
  37768       ..D GE TSTCVAL(TY PE)                        ; EMD EON STATUS  RECORD VA LUES FOR C LM OR DTL
  37769   "RTN","CHM XWB21",736 ,0)
  37770       ..S RE JCODES=$G( CHRJARR(ID X,JDX))
  37771   "RTN","CHM XWB21",737 ,0)
  37772       ..;W:$ D(TEST) !, "BLDSTC: R EJCODE STR =",REJCODE S,!   ; DE BUG: ONLY  OUTPUTS IF  "TEST" IS  DEFINED
  37773   "RTN","CHM XWB21",738 ,0)
  37774       ..S RJ CODE=$P(RE JCODES,"*" ,1),RJSTAT US=$P(REJC ODES,"*",2 ),ENTITY=$ P(REJCODES ,"*",3)
  37775   "RTN","CHM XWB21",739 ,0)
  37776       ..S RE C=""
  37777   "RTN","CHM XWB21",740 ,0)
  37778       ..F LN =1:1 S STR =$T(EMDEON STC+LN) Q: STR["END O F RECORD"   D  ; GENE RATE THE S TATUS (STC ) RECORD
  37779   "RTN","CHM XWB21",741 ,0)
  37780       ...I L N=1 S REC= REC_$$FORM ATDATA^CHM XWBUT(STR)
  37781   "RTN","CHM XWB21",742 ,0)
  37782       ...E   S REC=REC_ "|"_$$FORM ATDATA^CHM XWBUT(STR)
  37783   "RTN","CHM XWB21",743 ,0)
  37784       ..U DI RFILE W RE C,! S REC= "" S COUNT =COUNT+1
  37785   "RTN","CHM XWB21",744 ,0)
  37786       Q
  37787   "RTN","CHM XWB21",745 ,0)
  37788       ;
  37789   "RTN","CHM XWB21",746 ,0)
  37790   BLDTRL ; T RAILER REC ORD
  37791   "RTN","CHM XWB21",747 ,0)
  37792       N LN,R EC,STR
  37793   "RTN","CHM XWB21",748 ,0)
  37794       S COUN T=COUNT-2   ; ADJUST  COUNT FOR  START OF 2  (SEE EMDE ON SPEC)
  37795   "RTN","CHM XWB21",749 ,0)
  37796       S (STR ,LN,REC)=" "
  37797   "RTN","CHM XWB21",750 ,0)
  37798       F LN=1 :1 S STR=$ T(EMDEONTR LR+LN) Q:S TR["END OF  RECORD"   D
  37799   "RTN","CHM XWB21",751 ,0)
  37800       .I LN= 1 S REC=RE C_$$FORMAT DATA^CHMXW BUT(STR)
  37801   "RTN","CHM XWB21",752 ,0)
  37802       .E  S  REC=REC_"| "_$$FORMAT DATA^CHMXW BUT(STR)   ; 10/20/20 10 ADDED " ELSE"                         
  37803   "RTN","CHM XWB21",753 ,0)
  37804       U DIRF ILE W REC, ! S REC=""
  37805   "RTN","CHM XWB21",754 ,0)
  37806       Q
  37807   "RTN","CHM XWB21",755 ,0)
  37808       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  37809   "RTN","CHM XWB21",756 ,0)
  37810       ; GENE RIC FUNCTI ONS SUPPOR TING THE R ECORD BUIL DING                    ;
  37811   "RTN","CHM XWB21",757 ,0)
  37812       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  37813   "RTN","CHM XWB21",758 ,0)
  37814   GETFILE()  ;
  37815   "RTN","CHM XWB21",759 ,0)
  37816       N DIRP ATH,FLAG
  37817   "RTN","CHM XWB21",760 ,0)
  37818       ;HAPE  POR 1/20/1 4 force FI LECNT = 1  for all ty pes
  37819   "RTN","CHM XWB21",761 ,0)
  37820       S EICN T=0,FILECN T=1  ;; HA PE POR 1/2 0/14 =FILE CNT+1
  37821   "RTN","CHM XWB21",762 ,0)
  37822       ;HAPE  POR 1/6/14  - if FINA L status,  force file cnt=1
  37823   "RTN","CHM XWB21",763 ,0)
  37824       ;; HAP E POR 1/20 /14 I RUNT YPE="F" S  FILECNT=1
  37825   "RTN","CHM XWB21",764 ,0)
  37826       S DIRP ATH="HAC_H FS$:[KERMI T.WEBMD]"
  37827   "RTN","CHM XWB21",765 ,0)
  37828       HANG 1   ; POSITI VELY GUARA NTEE NO TW O FILES HA VE SAME TI MESTAMP
  37829   "RTN","CHM XWB21",766 ,0)
  37830       ;HAPE  POR 1/6/14  - change  for 1 file  per group
  37831   "RTN","CHM XWB21",767 ,0)
  37832       I RUNT YPE="F" S  GROUPID=""
  37833   "RTN","CHM XWB21",768 ,0)
  37834       D NOW^ %DTC
  37835   "RTN","CHM XWB21",769 ,0)
  37836       S FMDA TE=%
  37837   "RTN","CHM XWB21",770 ,0)
  37838       S FMDA TE=$$JUSTI FY^CHMXWBU T(FMDATE,1 4,0,"L")
  37839   "RTN","CHM XWB21",771 ,0)
  37840       S TIME =$$JUSTIFY ^CHMXWBUT( $E(FMDATE, 9,14),6,0, "L")
  37841   "RTN","CHM XWB21",772 ,0)
  37842       S DATE STAMP=($E( FMDATE,1,7 )+17000000 )_TIME ; D ATE/TIME F ILE CREATE D DOWN TO  SECOND
  37843   "RTN","CHM XWB21",773 ,0)
  37844       ;HAPE  POR - 11/1 3/13 GROUP ID set to  date if no t defined.
  37845   "RTN","CHM XWB21",774 ,0)
  37846       ;          - prob lem with m ulti-file  submission ,GROUPID m ust be the  same valu e
  37847   "RTN","CHM XWB21",775 ,0)
  37848       I $G(G ROUPID)=""  S GROUPID =DATESTAMP
  37849   "RTN","CHM XWB21",776 ,0)
  37850       I $D(T EST) S DIR FILE=DIRPA TH_DATESTA MP_"_VAHAC _"_$S(CHME DCOB:"COB_ ",1:"")_"t est.cstat"
  37851   "RTN","CHM XWB21",777 ,0)
  37852       E  I C HMEDCOB S  DIRFILE=DI RPATH_DATE STAMP_"_VA HAC_COB.cs tat"         ; CHMEDC OB SET IN  CHMXWT1
  37853   "RTN","CHM XWB21",778 ,0)
  37854       E  S D IRFILE=DIR PATH_DATES TAMP_"_VAH AC.cstat"    ; PROD F ILENAME
  37855   "RTN","CHM XWB21",779 ,0)
  37856       I RUNT YPE="H" S  DIRFILE=DI RFILE_"_H"
  37857   "RTN","CHM XWB21",780 ,0)
  37858       I RUNT YPE="O" S  DIRFILE=DI RFILE_"_O"
  37859   "RTN","CHM XWB21",781 ,0)
  37860       S FLAG =$$OFILE^C HMXWBUT(DI RFILE,"NWS ")
  37861   "RTN","CHM XWB21",782 ,0)
  37862       I 'FLA G D VMSERR  Q ""
  37863   "RTN","CHM XWB21",783 ,0)
  37864       I $G(C HMXI)'=""  S $P(^CHMX CL(CHMXI,8 0),"^",5)= DIRFILE  ;  RECORD TH E CSTAT FI LENAME
  37865   "RTN","CHM XWB21",784 ,0)
  37866       ;E  W  !,"OPENED  ",DIRFILE, !
  37867   "RTN","CHM XWB21",785 ,0)
  37868       Q
  37869   "RTN","CHM XWB21",786 ,0)
  37870   TST ;
  37871   "RTN","CHM XWB21",787 ,0)
  37872       N FMDA TE,TIME
  37873   "RTN","CHM XWB21",788 ,0)
  37874       S FMDA TE=3110901 .1234
  37875   "RTN","CHM XWB21",789 ,0)
  37876       W !,FM DATE
  37877   "RTN","CHM XWB21",790 ,0)
  37878       S FMDA TE=$$JUSTI FY^CHMXWBU T(FMDATE,1 4,0,"L")
  37879   "RTN","CHM XWB21",791 ,0)
  37880       W !,FM DATE
  37881   "RTN","CHM XWB21",792 ,0)
  37882       S TIME =$E(FMDATE ,9,14)
  37883   "RTN","CHM XWB21",793 ,0)
  37884       W !,TI ME
  37885   "RTN","CHM XWB21",794 ,0)
  37886       S TIME =$$JUSTIFY ^CHMXWBUT( $E(FMDATE, 9,14),6,0, "L")
  37887   "RTN","CHM XWB21",795 ,0)
  37888       W !,TI ME
  37889   "RTN","CHM XWB21",796 ,0)
  37890       Q
  37891   "RTN","CHM XWB21",797 ,0)
  37892       ;
  37893   "RTN","CHM XWB21",798 ,0)
  37894   CLOSEFILE  ;
  37895   "RTN","CHM XWB21",799 ,0)
  37896       C DIRF ILE
  37897   "RTN","CHM XWB21",800 ,0)
  37898       Q
  37899   "RTN","CHM XWB21",801 ,0)
  37900       ;
  37901   "RTN","CHM XWB21",802 ,0)
  37902   GETCHCLEI( CHCLI,CHTP I) ; BUILD  ARRAY OF  CLAIM INDI CES (CHMXC LE(I) VALU ES)
  37903   "RTN","CHM XWB21",803 ,0)
  37904       ; CHCL I     I IN DEX FOR ^C HMXCL() FI LE (CLAIM  FILE RECEI VED)
  37905   "RTN","CHM XWB21",804 ,0)
  37906       N STAT ,CHCLAI,PD I,CHIDXS,C HCLEI,RECC NT,CTPI S  CTPI=0
  37907   "RTN","CHM XWB21",805 ,0)
  37908       S STAT ="",STAT=$ O(^CHMXCLE ("A",CHCLI ,STAT)) I  $D(TEST) W :STAT="" ! ,"NULL STA T"  Q:STAT =""                ;  RETRIEVE S TATUS VALU E
  37909   "RTN","CHM XWB21",806 ,0)
  37910       S CHCL AI="",CHCL AI=$O(^CHM XCLE("A",C HCLI,STAT, CHCLAI)) I  $D(TEST)  W:CHCLAI=" " !,"NULL  CHCLAI"  Q :CHCLAI=""   ; RETRIE VE THE ^CH MXCLA(I) V ALUE
  37911   "RTN","CHM XWB21",807 ,0)
  37912       I $D(T EST) W !,"   GETCHCLE I: READING :",CHCLI,"   STATUS=  ",STAT,"   ^CHMXCLA(I )= ",CHCLA I,"  TP= " ,CTPI
  37913   "RTN","CHM XWB21",808 ,0)
  37914       S STAT =""
  37915   "RTN","CHM XWB21",809 ,0)
  37916       F  S S TAT=$O(^CH MXCLE("A", CHCLI,STAT )) Q:STAT= ""  D
  37917   "RTN","CHM XWB21",810 ,0)
  37918       .S CHC LAI=""
  37919   "RTN","CHM XWB21",811 ,0)
  37920       .F  S  CHCLAI=$O( ^CHMXCLE(" A",CHCLI,S TAT,CHCLAI )) Q:CHCLA I=""  D
  37921   "RTN","CHM XWB21",812 ,0)
  37922       ..S PD I=0
  37923   "RTN","CHM XWB21",813 ,0)
  37924       ..F  S  PDI=$O(^C HMXCLE("A" ,CHCLI,STA T,CHCLAI,P DI))  Q:'P DI  D
  37925   "RTN","CHM XWB21",814 ,0)
  37926       ...S C HIDXS=$O(^ CHMXCLE("A ",CHCLI,ST AT,CHCLAI, PDI,0))
  37927   "RTN","CHM XWB21",815 ,0)
  37928       ...Q:C HIDXS=""   ; PDI RETR IEVES BUFF ER IDXs
  37929   "RTN","CHM XWB21",816 ,0)
  37930       ...S C HCLEI=$P(C HIDXS,"*", 3)
  37931   "RTN","CHM XWB21",817 ,0)
  37932       ...S ^ ZSC($J,CHT PI,CHCLEI) =STAT,RECC NT=$I(^ZSC ($J,0))
  37933   "RTN","CHM XWB21",818 ,0)
  37934       Q
  37935   "RTN","CHM XWB21",819 ,0)
  37936       ;
  37937   "RTN","CHM XWB21",820 ,0)
  37938   GETTP(CHA)  ;
  37939   "RTN","CHM XWB21",821 ,0)
  37940       N TPID ,ID
  37941   "RTN","CHM XWB21",822 ,0)
  37942       S ID=" "
  37943   "RTN","CHM XWB21",823 ,0)
  37944       S TPID =$P($G(^CH MXCLA(CHA, 1)),"^",1)
  37945   "RTN","CHM XWB21",824 ,0)
  37946       S:TPID ]"" ID=$O( ^CHMXTP("C ",TPID,"") )
  37947   "RTN","CHM XWB21",825 ,0)
  37948       Q ID
  37949   "RTN","CHM XWB21",826 ,0)
  37950       ;
  37951   "RTN","CHM XWB21",827 ,0)
  37952       ; DLB  4/30/2018   ADDED CHE CK FOR EMD EON ^CHMIM AGE(PDI,"B UFF") BY C HECKING FO R ^CHMXCLE ()
  37953   "RTN","CHM XWB21",828 ,0)
  37954       ; SXC  PHARMACY C LAIMS ARE  NOT LOADED  INTO CLAI M BUFFER ( ^CHMXCLE() )
  37955   "RTN","CHM XWB21",829 ,0)
  37956       ;
  37957   "RTN","CHM XWB21",830 ,0)
  37958   GETPENDEI( CHFROM,CHT O) ; GET C HCLEI FROM  PENDING ^ CHMPAY(I)  FROM/TO VA LUES
  37959   "RTN","CHM XWB21",831 ,0)
  37960       K ^ZSC ($J)
  37961   "RTN","CHM XWB21",832 ,0)
  37962       ;U 0 W :DEBUG !," GETPENDEI( ): FROM: " ,CHFROM,"   TO: ",CHT O
  37963   "RTN","CHM XWB21",833 ,0)
  37964       N IDX, CHJK,PDI,C HCLEI,CHCL AI,CTPI
  37965   "RTN","CHM XWB21",834 ,0)
  37966       F IDX= CHFROM:1 Q :IDX>CHTO   D
  37967   "RTN","CHM XWB21",835 ,0)
  37968       .;U 0  W:DEBUG !, "GETPENDEI (): IDX: " ,IDX
  37969   "RTN","CHM XWB21",836 ,0)
  37970       .;S CH JK=$O(^CHM PAY(IDX,"P DI","B",0) ) Q:CHJK=" "     ; GE T THE "J"  INDEX FROM  THE CROSS -REFERENCE
  37971   "RTN","CHM XWB21",837 ,0)
  37972       .S PDI =$O(^CHMPA Y(IDX,"PDI ","B",0))  Q:PDI=""
  37973   "RTN","CHM XWB21",838 ,0)
  37974       .;U 0  W:DEBUG !, "GETPENDEI (): PDI: " ,PDI
  37975   "RTN","CHM XWB21",839 ,0)
  37976       .S LAB EL=$E(PDI, 8,9)
  37977   "RTN","CHM XWB21",840 ,0)
  37978       .I LAB EL=91  D                                                   ; 91=  X12 EDI LA BEL TYPE
  37979   "RTN","CHM XWB21",841 ,0)
  37980       ..Q:'$ D(^CHMIMAG E(PDI,"BUF F"))               ;  MUST BE AB LE TO RETR IEVE ^CHMX CLE INDEX 
  37981   "RTN","CHM XWB21",842 ,0)
  37982       ..U 0  W:DEBUG !, "GETPENDEI (): PROCES SING PDI:  ",PDI
  37983   "RTN","CHM XWB21",843 ,0)
  37984       ..S CH CLEI=$P($G (^CHMIMAGE (PDI,"BUFF ")),"^",6)  Q:CHCLEI= ""
  37985   "RTN","CHM XWB21",844 ,0)
  37986       ..S CH CLAI=$P($G (^CHMIMAGE (PDI,"BUFF ")),"^",3)  Q:CHCLAI= ""
  37987   "RTN","CHM XWB21",845 ,0)
  37988       ..S CT PI=$$GETTP (CHCLAI)                                        ; TRAD ING PARTNE R FOR CURR ENT CLAIM
  37989   "RTN","CHM XWB21",846 ,0)
  37990       ..;U 0  W:DEBUG ! ,"CHCLEI:  ",CHCLEI,"   CHCLAI:  ",CHCLAI,"   CTPI: ", CTPI
  37991   "RTN","CHM XWB21",847 ,0)
  37992       ..I CH CLEI]"" I  CTPI'="",$ D(CHTPARR( CTPI)) S ^ ZSC($J,CTP I,CHCLEI)= "",RECCNT= RECCNT+1
  37993   "RTN","CHM XWB21",848 ,0)
  37994       S ^ZSC ($J,0)=REC CNT
  37995   "RTN","CHM XWB21",849 ,0)
  37996       ;U 0 W :DEBUG !," GETPENDEI( ): RECCNT=  ",^ZSC($J ,0)
  37997   "RTN","CHM XWB21",850 ,0)
  37998       Q
  37999   "RTN","CHM XWB21",851 ,0)
  38000       ;
  38001   "RTN","CHM XWB21",852 ,0)
  38002   GETFINEI ;  HAPE POR  6/15/13 -  GET CHCLEI  FOR FINAL  CLAIM STA TUS
  38003   "RTN","CHM XWB21",853 ,0)
  38004       K ^ZSC ($J),^ZSC1 ($J)
  38005   "RTN","CHM XWB21",854 ,0)
  38006       N CHCL EI,CHCLAI, CTPI,RECCN T,CLC,CLB, CHPIDX,CHP DATE,CHPPD I,XHAC
  38007   "RTN","CHM XWB21",855 ,0)
  38008       N XHAC DT
  38009   "RTN","CHM XWB21",856 ,0)
  38010       S RECC NT=0
  38011   "RTN","CHM XWB21",857 ,0)
  38012       ; HAPE  POR - ini tial searc h date set  to today  - 6 months
  38013   "RTN","CHM XWB21",858 ,0)
  38014       ; HAPE  POR - 12/ 10/13 Cann ot go back  any furth er than 7/ 27/13
  38015   "RTN","CHM XWB21",859 ,0)
  38016       ;             thi s is the d ate SLLA w ent live a nd claims  were proce ssed
  38017   "RTN","CHM XWB21",860 ,0)
  38018       ; HAPE  POR - 1/7 /14 (2nd r el) change  initial l ook back t o only 12/ 2/13
  38019   "RTN","CHM XWB21",861 ,0)
  38020       ;S %H= $H-183
  38021   "RTN","CHM XWB21",862 ,0)
  38022       I $H<6 3247 S CHP DATE=31312 02  ;if be fore 3/1/1 4 force st art date
  38023   "RTN","CHM XWB21",863 ,0)
  38024       E  S % H=$H-7 D Y MD^%DTC S  CHPDATE=X
  38025   "RTN","CHM XWB21",864 ,0)
  38026       ;SBB 0 3/06/2014  DEV020322;  Fixed the  check for  CSTAT fin al claims.
  38027   "RTN","CHM XWB21",865 ,0)
  38028       ;F  S  CHPDATE=$O (^CHMPAY(" E",CHPDATE )) Q:CHPDA TE=""  S C HPIDX="" F   S CHPIDX =$O(^CHMPA Y("E",CHPD ATE,CHPIDX )) Q:CHPID X=""  I $G (^(CHPIDX) )="" D    
  38029   "RTN","CHM XWB21",866 ,0)
  38030       F  S C HPDATE=$O( ^CHMPAY("E ",CHPDATE) ) Q:CHPDAT E=""  S CH PIDX="" F   S CHPIDX= $O(^CHMPAY ("E",CHPDA TE,CHPIDX) ) Q:CHPIDX =""  I $P( ^CHMPAY(CH PIDX,10)," ^",23)=""  D
  38031   "RTN","CHM XWB21",867 ,0)
  38032       . S CH PPDI=$O(^C HMPAY(CHPI DX,"PDI",0 )) Q:CHPPD I=""
  38033   "RTN","CHM XWB21",868 ,0)
  38034       . S CH PPDI=$P($G (^CHMPAY(C HPIDX,"PDI ",CHPPDI,0 )),"^")
  38035   "RTN","CHM XWB21",869 ,0)
  38036       . ;HAP E POR - if  no PDI fo und, skip  the claim
  38037   "RTN","CHM XWB21",870 ,0)
  38038       . I CH PPDI="" Q
  38039   "RTN","CHM XWB21",871 ,0)
  38040       . S CH CLEI=$Q(^C HMXCLE("PD I",CHPPDI) ) I CHCLEI ="" Q
  38041   "RTN","CHM XWB21",872 ,0)
  38042       . I $P (CHCLEI,", ",2)'=CHPP DI Q
  38043   "RTN","CHM XWB21",873 ,0)
  38044       . S CH CLEI=$TR($ P($P(CHCLE I,"*",2,99 ),"*",3)," "")","")
  38045   "RTN","CHM XWB21",874 ,0)
  38046       . ;HAP E POR - $$ FINAL retu rns whethe r the clai m is to be  reported  as FINAL
  38047   "RTN","CHM XWB21",875 ,0)
  38048       . I $$ FINAL(CHCL EI) D
  38049   "RTN","CHM XWB21",876 ,0)
  38050       .. S C LC=$P(^CHM XCLE(CHCLE I,0),"^")
  38051   "RTN","CHM XWB21",877 ,0)
  38052       .. S C LB=$P(^CHM XCLC(CLC,0 ),"^")
  38053   "RTN","CHM XWB21",878 ,0)
  38054       .. S C HCLAI=$P(^ CHMXCLB(CL B,0),"^")
  38055   "RTN","CHM XWB21",879 ,0)
  38056       .. S C TPI=$$GETT P(CHCLAI)   ;TRADING  PARTNER FO R CURRENT  CLAIM
  38057   "RTN","CHM XWB21",880 ,0)
  38058       .. I $ D(CHTPARR( CTPI)) S ^ ZSC($J,CTP I,CHCLEI)= "",RECCNT= RECCNT+1,^ ZSC1($J,CH PDATE,CHPI DX)="" D
  38059   "RTN","CHM XWB21",881 ,0)
  38060       ... S  XHAC="" F   S XHAC=$O (^CHMXCLE( CHCLEI,80, "B",XHAC))  Q:XHAC=""   D
  38061   "RTN","CHM XWB21",882 ,0)
  38062       .... S  XHACDT=$P ($G(^CHMPA Y(XHAC,0)) ,"^",10)
  38063   "RTN","CHM XWB21",883 ,0)
  38064       .... I  XHACDT'=" " S ^ZSC1( $J,XHACDT, XHAC)=""
  38065   "RTN","CHM XWB21",884 ,0)
  38066       S ^ZSC ($J,0)=REC CNT
  38067   "RTN","CHM XWB21",885 ,0)
  38068       Q
  38069   "RTN","CHM XWB21",886 ,0)
  38070       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  38071   "RTN","CHM XWB21",887 ,0)
  38072       ; GETC HTPI  RETU RN THE NEX T TRADING  PARTNER IN DEX BASED  ON THE LAS T INDEX    ;
  38073   "RTN","CHM XWB21",888 ,0)
  38074       ; USED .  THIS FU NCTRION IS  CALLED BY  THE "PEND ING STATUS " PROCESS.            ;
  38075   "RTN","CHM XWB21",889 ,0)
  38076       ; FUNC TION USES  LOCAL VARU IABLE "CHT PI" AS THE  BASIS FOR  RETURNING  ALL       ;
  38077   "RTN","CHM XWB21",890 ,0)
  38078       ; TRAD ING PARTNE R INDICES.  IF TRADIN G PARTNER  IS INACTIV E, FUNCTIO N MOVES    ;
  38079   "RTN","CHM XWB21",891 ,0)
  38080       ; TO T HE NEXT TR ACKING GLO BAL TRADIN G PARTNER.                                  ;
  38081   "RTN","CHM XWB21",892 ,0)
  38082       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  38083   "RTN","CHM XWB21",893 ,0)
  38084   GETCHTPI ;
  38085   "RTN","CHM XWB21",894 ,0)
  38086       N TRKI ,CHTPI
  38087   "RTN","CHM XWB21",895 ,0)
  38088       S CHTP I=""
  38089   "RTN","CHM XWB21",896 ,0)
  38090       F  S C HTPI=$O(^C HMX277("B" ,CHTPI),-1 ) Q:CHTPI= ""  D  ;TR ADING PART NERS FROM  "B" XREF
  38091   "RTN","CHM XWB21",897 ,0)
  38092       .S TRK I=0,TRKI=$ O(^CHMX277 ("B",CHTPI ,TRKI))  ;  GET TRACK ING GLOBAL  INDEX
  38093   "RTN","CHM XWB21",898 ,0)
  38094       .I ($P ($G(^CHMX2 77(TRKI,0) ),"^",3)=1 ) S CHTPAR R(CHTPI)=" "
  38095   "RTN","CHM XWB21",899 ,0)
  38096       Q
  38097   "RTN","CHM XWB21",900 ,0)
  38098       ;
  38099   "RTN","CHM XWB21",901 ,0)
  38100   GETCLMI(DA TE,FLAG) ;  MATCH A D ATE WITH T HE ^CHMXCL (I) ENTRY              
  38101   "RTN","CHM XWB21",902 ,0)
  38102       ;   DA TE    DATE  FOR THE ^ CHMXCL() S EARCH
  38103   "RTN","CHM XWB21",903 ,0)
  38104       ;   FL AG    ">", "<","'<",O R "'>" DAT E SEARCH P OSSIBILITI ES
  38105   "RTN","CHM XWB21",904 ,0)
  38106       N CHCN T,LSTI,EXI T,WDATE,RT N
  38107   "RTN","CHM XWB21",905 ,0)
  38108       S RTN= 0,EXIT=0
  38109   "RTN","CHM XWB21",906 ,0)
  38110       S LSTI =($P(^CHMX CL(0),"^", 3))+1
  38111   "RTN","CHM XWB21",907 ,0)
  38112       F CHCN T=1:1 Q:(L STI="")!(E XIT)  S LS TI=$O(^CHM XCL(LSTI), -1)   D
  38113   "RTN","CHM XWB21",908 ,0)
  38114       .S WDA TE=$P($P($ G(^CHMXCL( LSTI,0))," ^",1),".", 1)   ; FIL E OPENED D ATE
  38115   "RTN","CHM XWB21",909 ,0)
  38116       .I ((F LAG="<")&( WDATE<DATE )) S RTN=L STI,EXIT=1      ; DAT E < SPECIF IED DATE
  38117   "RTN","CHM XWB21",910 ,0)
  38118       .E  I  ((FLAG=">" )&(WDATE>D ATE)) S RT N=LSTI,EXI T=1  ; DAT E > SPECIF IED DATE
  38119   "RTN","CHM XWB21",911 ,0)
  38120       .E  I  ((FLAG="'< ")&(WDATE' >DATE)) S  RTN=LSTI,E XIT=1  ; D ATE = OR >  SPECIFIED  DATE
  38121   "RTN","CHM XWB21",912 ,0)
  38122       .E  I  ((FLAG="'> ")&(WDATE' <DATE)) S  RTN=LSTI,E XIT=1  ; D ATE < OR =  SPECIFIED  DATE
  38123   "RTN","CHM XWB21",913 ,0)
  38124       Q RTN
  38125   "RTN","CHM XWB21",914 ,0)
  38126       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  38127   "RTN","CHM XWB21",915 ,0)
  38128       ; FILE MAN UPDATE  "DR" STRI NG BUILD F UNCTION                                     ;
  38129   "RTN","CHM XWB21",916 ,0)
  38130       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;   
  38131   "RTN","CHM XWB21",917 ,0)
  38132   SETDARR(ST R) ;
  38133   "RTN","CHM XWB21",918 ,0)
  38134       N REG, DRDATA,TMP ,IDX,DARR
  38135   "RTN","CHM XWB21",919 ,0)
  38136       S DARR ="",DRDATA =""
  38137   "RTN","CHM XWB21",920 ,0)
  38138       F IDX= 1:1 S TMP= $P(STR,"^" ,IDX) Q:TM P=""  D
  38139   "RTN","CHM XWB21",921 ,0)
  38140       .S REG =$P(TMP,"= ",1),VAL=$ P(TMP,"=", 2)
  38141   "RTN","CHM XWB21",922 ,0)
  38142       .S DAR R(REG)=VAL
  38143   "RTN","CHM XWB21",923 ,0)
  38144       S DRDA TA=$$SETDR ^CHHRLIBFM ("DARR")
  38145   "RTN","CHM XWB21",924 ,0)
  38146       Q DRDA TA
  38147   "RTN","CHM XWB21",925 ,0)
  38148       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  38149   "RTN","CHM XWB21",926 ,0)
  38150       ; RETR IEVE VALUE S FROM THE  TRACKING  GLOBAL
  38151   "RTN","CHM XWB21",927 ,0)
  38152       ; NEED S: CHTPI:  TRADING PA RTNER INDE X TO USE
  38153   "RTN","CHM XWB21",928 ,0)
  38154       ;         RUNTYPE :   STATUS  TYPE BEIN G CREATED
  38155   "RTN","CHM XWB21",929 ,0)
  38156       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;   
  38157   "RTN","CHM XWB21",930 ,0)
  38158   GETTOFROM( CHTPI) ; R ETRIEVE TO -FROM FILE S FROM TRA CKING GLOB AL
  38159   "RTN","CHM XWB21",931 ,0)
  38160       N JDX, NODE,TRKI
  38161   "RTN","CHM XWB21",932 ,0)
  38162       S TRKI =0,TRKI=$O (^CHMX277( "B",CHTPI, TRKI))  ;  CONVERT CH TPI FOR TR ACKING GLO BAL ACCESS   
  38163   "RTN","CHM XWB21",933 ,0)
  38164       S NODE =$S(RUNTYP E="P":20,R UNTYPE="F" :30)    ;  SELECT PEN DING/FINAL  STATUS NO DE
  38165   "RTN","CHM XWB21",934 ,0)
  38166       S JDX= "A",JDX=$O (^CHMX277( TRKI,NODE, JDX),-1)   ; LOOK AT  LAST ENTRY  FOR THE S TATUS
  38167   "RTN","CHM XWB21",935 ,0)
  38168       ;U 0 W :DEBUG !," GETTOFROM:  CHTPI = " ,CHTPI,"   NODE= ",NO DE,"  JDX=  ",JDX
  38169   "RTN","CHM XWB21",936 ,0)
  38170       Q:JDX= ""
  38171   "RTN","CHM XWB21",937 ,0)
  38172       S CHFR OM=($P($G( ^CHMX277(T RKI,NODE,J DX,0)),"^" ,4))  ; NE W "FROM"=  OLD "TO"
  38173   "RTN","CHM XWB21",938 ,0)
  38174       S:CHFR OM'=0 CHFR OM=CHFROM+ 1,CHTO=$P( $G(^CHMPAY (0)),"^",3 )  ; SET S TART/ END  INDEX
  38175   "RTN","CHM XWB21",939 ,0)
  38176       ;U 0 W :DEBUG !," GETTOFROM:  FROM= ",C HFROM,"  T O= ",CHTO
  38177   "RTN","CHM XWB21",940 ,0)
  38178       Q
  38179   "RTN","CHM XWB21",941 ,0)
  38180       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  38181   "RTN","CHM XWB21",942 ,0)
  38182       ; SUPP ORT FUNCTI ONS FOR TH E FILE GEN ERATION FU NCTIONS DE FINED ABOV E.             ;
  38183   "RTN","CHM XWB21",943 ,0)
  38184       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  38185   "RTN","CHM XWB21",944 ,0)
  38186   DATERANGE( FROM,TO) ; Prompt for  a FROM an d TO date  range.
  38187   "RTN","CHM XWB21",945 ,0)
  38188       N MAXT O
  38189   "RTN","CHM XWB21",946 ,0)
  38190       D NOW^ %DTC S MAX TO=$E(%,1, 7)
  38191   "RTN","CHM XWB21",947 ,0)
  38192       S (FRO M,TO)="",( DONE,POP)= 0
  38193   "RTN","CHM XWB21",948 ,0)
  38194       F  Q:( DONE)!(POP )  D
  38195   "RTN","CHM XWB21",949 ,0)
  38196       .S FRO M=$$GETDAT E^CHMXWBUT ("ENTER ST ART DATE:  ") S:FROM= -1 POP=1 Q :POP 
  38197   "RTN","CHM XWB21",950 ,0)
  38198       .I ((F ROM<1)!(FR OM>MAXTO))  W " [Inva lid date.  Try again] " Q
  38199   "RTN","CHM XWB21",951 ,0)
  38200       .S TO= $$GETDATE^ CHMXWBUT(" ENTER END  DATE: ") S :TO=-1 POP =1 Q:POP
  38201   "RTN","CHM XWB21",952 ,0)
  38202       .I ((T O<FROM)!(T O>MAXTO))  W " [Inval id date. T ry again]"  Q
  38203   "RTN","CHM XWB21",953 ,0)
  38204       .S DON E=1
  38205   "RTN","CHM XWB21",954 ,0)
  38206       Q POP
  38207   "RTN","CHM XWB21",955 ,0)
  38208   GETSTVAL(C HCLEI) ; R EVERSE POL ISH METHOD  FOR RETRI EVING CLAI M STATUS
  38209   "RTN","CHM XWB21",956 ,0)
  38210       N CHCL CI,CHCLBI, CHCLAI,CHC LI,TARGEI, STAT,PDI
  38211   "RTN","CHM XWB21",957 ,0)
  38212       S CHCL CI=$P(^CHM XCLE(CHCLE I,0),"^",1 )  ;TRAVER SE BACK TH ROUGH BUFF ER FILES
  38213   "RTN","CHM XWB21",958 ,0)
  38214       S CHCL BI=$P(^CHM XCLC(CHCLC I,0),"^",1 )
  38215   "RTN","CHM XWB21",959 ,0)
  38216       S CHCL AI=$P(^CHM XCLB(CHCLB I,0),"^",1 )
  38217   "RTN","CHM XWB21",960 ,0)
  38218       S CHCL I=$P(^CHMX CLA(CHCLAI ,0),"^",1)
  38219   "RTN","CHM XWB21",961 ,0)
  38220       S PDI= $P(^CHMXCL E(CHCLEI,1 00),"^",2)
  38221   "RTN","CHM XWB21",962 ,0)
  38222       S:PDI= "" PDI=$P( ^CHMXCLE(C HCLEI,100) ,"^",4)
  38223   "RTN","CHM XWB21",963 ,0)
  38224       I PDI= "" Q 6  ;A ssume 6 th at it was  rejected i f no PDI f ound...dat a integrit y issue
  38225   "RTN","CHM XWB21",964 ,0)
  38226       S STAT =0,TARGEI= 0
  38227   "RTN","CHM XWB21",965 ,0)
  38228       F  Q:T ARGEI=CHCL EI  D
  38229   "RTN","CHM XWB21",966 ,0)
  38230       .S STA T=$O(^CHMX CLE("A",CH CLI,STAT))
  38231   "RTN","CHM XWB21",967 ,0)
  38232       .S CHI DXS=0,CHID XS=$O(^CHM XCLE("A",C HCLI,STAT, CHCLAI,PDI ,""))
  38233   "RTN","CHM XWB21",968 ,0)
  38234       .S TAR GEI=$P(CHI DXS,"*",3)
  38235   "RTN","CHM XWB21",969 ,0)
  38236       Q STAT
  38237   "RTN","CHM XWB21",970 ,0)
  38238       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  38239   "RTN","CHM XWB21",971 ,0)
  38240       ; EMAI L STATUS T O INTEREST ED PARTIES                                              ;
  38241   "RTN","CHM XWB21",972 ,0)
  38242       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;        
  38243   "RTN","CHM XWB21",973 ,0)
  38244   AUTOMM(TYP E)  
  38245   "RTN","CHM XWB21",974 ,0)
  38246       D NOW^ %DTC
  38247   "RTN","CHM XWB21",975 ,0)
  38248       S FMDA TE=$E(%,1, 7)
  38249   "RTN","CHM XWB21",976 ,0)
  38250       S CHNB =2,ZML(CHN B)="",ZML( CHNB)=CHVM SFL_"  (To tal Record s = "_CHBR CCNT_")"
  38251   "RTN","CHM XWB21",977 ,0)
  38252       S CHNB =CHNB+1,ZM L(CHNB)=""
  38253   "RTN","CHM XWB21",978 ,0)
  38254       I TYPE ="EFILE"   S CHNB=CHN B+1,ZML(CH NB)="NOTIC E: ***ERRO R*** CREAT ING 277U S TAT file!"
  38255   "RTN","CHM XWB21",979 ,0)
  38256       E  I T YPE="OK" S  CHNB=CHNB +1,ZML(CHN B)="NOTICE : Successf ul CREATIO N 277U STA T file!"
  38257   "RTN","CHM XWB21",980 ,0)
  38258       S CHNB =CHNB+1,ZM L(CHNB)="E DI BATCH N UMBER ^CHM XCL("_CHMX I_",0)"
  38259   "RTN","CHM XWB21",981 ,0)
  38260       S XMTE XT="ZML(", XMSUB="277 U WebMD..S uccess.."_ FMDATE
  38261   "RTN","CHM XWB21",982 ,0)
  38262       S XMDU Z=.5
  38263   "RTN","CHM XWB21",983 ,0)
  38264       S XMY( "274577")= "",XMY("24 6183")=""
  38265   "RTN","CHM XWB21",984 ,0)
  38266         S XMY(" PII                   ")=""
  38267   "RTN","CHM XWB21",985 ,0)
  38268         S XMY("
P II                   ")=""
  38269   "RTN","CHM XWB21",986 ,0)
  38270       D ^XMD
  38271   "RTN","CHM XWB21",987 ,0)
  38272       Q
  38273   "RTN","CHM XWB21",988 ,0)
  38274       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  38275   "RTN","CHM XWB21",989 ,0)
  38276       ; THE  FOLLOWING  ROUTINES A RE PRESERV ED FOR HIS TORICAL PU RPOSES                        ;
  38277   "RTN","CHM XWB21",990 ,0)
  38278       ; THER E ARE COPI ES OF THES E FUNCTION S IN CHMXW B07,CHMXWB 11,CHMXWB2 1                  ;
  38279   "RTN","CHM XWB21",991 ,0)
  38280       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;; 
  38281   "RTN","CHM XWB21",992 ,0)
  38282       ;
  38283   "RTN","CHM XWB21",993 ,0)
  38284   EXFTP S CH FTPMSG=0
  38285   "RTN","CHM XWB21",994 ,0)
  38286       ;H 100 0 ;DEF4399  ajm remov ed hang, n ot needed
  38287   "RTN","CHM XWB21",995 ,0)
  38288   XCOM S X=$ ZF(-1,"SUB MIT HAC_HF S$:[DSMMAN AG]WEB_WS_ FTP.COM /N AME=WEB_WS _FTP_JOB/N OPRINTER/U SER=HACCAC HEMGR/PARA M="_CHFILE )
  38289   "RTN","CHM XWB21",996 ,0)
  38290       ;///// /////// UN REMARK/REM ARK OUT CO DE FOR PRO DUCTION // ////////
  38291   "RTN","CHM XWB21",997 ,0)
  38292       ;H 120 0 ;DEF4399  ajm remov ed hang, n ot needed
  38293   "RTN","CHM XWB21",998 ,0)
  38294       K ^CHM ZHOLD("RKN _W277")
  38295   "RTN","CHM XWB21",999 ,0)
  38296       Q  ;DE F4399 ajm  addd - fil es are cop ied, no lo nger ftp'd
  38297   "RTN","CHM XWB21",100 0,0)
  38298       ;
  38299   "RTN","CHM XWB21",100 1,0)
  38300   FTPCK S RD ="HAC_HFS$ :[DSMMANAG ]WEB_WS_FT P_JOB.LOG"     ;LIVE
  38301   "RTN","CHM XWB21",100 2,0)
  38302       ;C RD
  38303   "RTN","CHM XWB21",100 3,0)
  38304       K CHFT PTIM,CHFTP WT S ZE="" ,QFLAG=0,C HFTPWT=$P( ^CHMDIC(74 1002.17,1, 2),"^",10)
  38305   "RTN","CHM XWB21",100 4,0)
  38306       F CHFT PTIM=1:1:C HFTPWT H 6 0
  38307   "RTN","CHM XWB21",100 5,0)
  38308       O RD:" R" D  Q:(Q FLAG=1)     ;RKN, 6-2 9-05, MOD  READONLY
  38309   "RTN","CHM XWB21",100 6,0)
  38310       .I '$T  C RD Q
  38311   "RTN","CHM XWB21",100 7,0)
  38312       .F  U  RD R RDLIN E  D  Q:(Q FLAG=1)!($ ZE["ENDOFI LE")
  38313   "RTN","CHM XWB21",100 8,0)
  38314       ..I (R DLINE["226  Transfer  complete")  S CHFTPMS G=1,QFLAG= 1 Q
  38315   "RTN","CHM XWB21",100 9,0)
  38316       ..I (R DLINE["Cha rged CPU t ime:") S Q FLAG=1 Q
  38317   "RTN","CHM XWB21",101 0,0)
  38318   FTPERR;
  38319   "RTN","CHM XWB21",101 1,0)
  38320       C RD 
  38321   "RTN","CHM XWB21",101 2,0)
  38322       S CHNB =2
  38323   "RTN","CHM XWB21",101 3,0)
  38324       S ZML( CHNB)=""
  38325   "RTN","CHM XWB21",101 4,0)
  38326       S ZML( CHNB)=CHVM SFL
  38327   "RTN","CHM XWB21",101 5,0)
  38328       S CHNB =CHNB+1
  38329   "RTN","CHM XWB21",101 6,0)
  38330       S ZML( CHNB)=""
  38331   "RTN","CHM XWB21",101 7,0)
  38332       S CHNB =CHNB+1
  38333   "RTN","CHM XWB21",101 8,0)
  38334       S XMTE XT="ZML("
  38335   "RTN","CHM XWB21",101 9,0)
  38336       K CHFT PMSG,RD,RD LINE
  38337   "RTN","CHM XWB21",102 0,0)
  38338       ;
  38339   "RTN","CHM XWB21",102 1,0)
  38340       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  38341   "RTN","CHM XWB21",102 2,0)
  38342       ; CALC ULATE A DA TE 90 DAYS  IN THE PA ST                                          ;
  38343   "RTN","CHM XWB21",102 3,0)
  38344       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  38345   "RTN","CHM XWB21",102 4,0)
  38346   DOLDFLS D  NOW^%DTC
  38347   "RTN","CHM XWB21",102 5,0)
  38348       S X1=X ,X2=-90
  38349   "RTN","CHM XWB21",102 6,0)
  38350       D C^%D TC
  38351   "RTN","CHM XWB21",102 7,0)
  38352       D YX^% DTC
  38353   "RTN","CHM XWB21",102 8,0)
  38354       Q
  38355   "RTN","CHM XWB21",102 9,0)
  38356       ;
  38357   "RTN","CHM XWB21",103 0,0)
  38358       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  38359   "RTN","CHM XWB21",103 1,0)
  38360       ; Erro r Handler  / personne l notifica tion funct ions for t he 277 sta tus file           ;
  38361   "RTN","CHM XWB21",103 2,0)
  38362       ; gene ration pro cess.                                                                     ;
  38363   "RTN","CHM XWB21",103 3,0)
  38364       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  38365   "RTN","CHM XWB21",103 4,0)
  38366       ;
  38367   "RTN","CHM XWB21",103 5,0)
  38368   VMSERR ;
  38369   "RTN","CHM XWB21",103 6,0)
  38370       I $G(I O)'="" C I O      
  38371   "RTN","CHM XWB21",103 7,0)
  38372       D ^%ZT ER
  38373   "RTN","CHM XWB21",103 8,0)
  38374       ;
  38375   "RTN","CHM XWB21",103 9,0)
  38376   ERRMM ;
  38377   "RTN","CHM XWB21",104 0,0)
  38378       ;S CHE RRMSG=1,CH NB=2,ZML(C HNB)="",ZM L(CHNB)=CH VMSFL,CHNB =CHNB+1,ZM L(CHNB)="" ,CHNB=CHNB +1
  38379   "RTN","CHM XWB21",104 1,0)
  38380       ;S ZML (CHNB)="NO TICE: An e rror has o ccurred in  writing U pdate for  the",CHNB= CHNB+1
  38381   "RTN","CHM XWB21",104 2,0)
  38382       ;S ZML (CHNB)=" 2 77U WebMD  file!"
  38383   "RTN","CHM XWB21",104 3,0)
  38384       ;S XMD UZ=.5,XMY( "10722")=" " ;RKN LIV E
  38385   "RTN","CHM XWB21",104 4,0)
  38386       ;S XMT EXT="ZML(" ,XMSUB="27 7U WebMD.. Error.."_F MDATE
  38387   "RTN","CHM XWB21",104 5,0)
  38388       S CHER RMSG=1,CHN B=2,ZML(CH NB)="",ZML (CHNB)=$G( CHVMSFL),C HNB=CHNB+1 ,ZML(CHNB) ="",CHNB=C HNB+1
  38389   "RTN","CHM XWB21",104 6,0)
  38390       S ZML( CHNB)="NOT ICE: An er ror has oc curred in  writing Up date for t he",CHNB=C HNB+1
  38391   "RTN","CHM XWB21",104 7,0)
  38392       S ZML( CHNB)=" CS TAT file!"
  38393   "RTN","CHM XWB21",104 8,0)
  38394         ;S XMDUZ=. 5,XMY(" PII                    ")="" ;RKN  LIVE
  38395   "RTN","CHM XWB21",104 9,0)
  38396       ;S XMY (" PII                               ")= ""
  38397   "RTN","CHM XWB21",105 0,0)
  38398       S XMDU Z=.5,XMY(" 274577")=" ",XMY("246 183")=""
  38399   "RTN","CHM XWB21",105 1,0)
  38400         S XMY(" PII                   ")="",XMY( "
P II                   ")=""
  38401   "RTN","CHM XWB21",105 2,0)
  38402       S XMTE XT="ZML(", XMSUB="277 U..Error.. "_DATESTAM P
  38403   "RTN","CHM XWB21",105 3,0)
  38404       ; BAS  -END MOD
  38405   "RTN","CHM XWB21",105 4,0)
  38406       D ^XMD
  38407   "RTN","CHM XWB21",105 5,0)
  38408       Q
  38409   "RTN","CHM XWB21",105 6,0)
  38410       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  38411   "RTN","CHM XWB21",105 7,0)
  38412       ; $TEX T VARIABLE  SETUP ROU TINES                                                          ;
  38413   "RTN","CHM XWB21",105 8,0)
  38414       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  38415   "RTN","CHM XWB21",105 9,0)
  38416   GETHDRVAL  ;
  38417   "RTN","CHM XWB21",106 0,0)
  38418       ;HAPE  POR - 6/1/ 13 added P ayname and  Payphone  values for  Final
  38419   "RTN","CHM XWB21",106 1,0)
  38420       ;      claim stat us
  38421   "RTN","CHM XWB21",106 2,0)
  38422       ;HAPE  POR 9/24/1 3 - add ab ility to g enerated a  FULL load  type for  initial ru n
  38423   "RTN","CHM XWB21",106 3,0)
  38424       S LOAD TYPE=$S(RU NTYPE="H": "F",$G(FUL L)=1:"F",1 :"I")
  38425   "RTN","CHM XWB21",106 4,0)
  38426         S (PAYNAME , DNS     NE)=""
  38427   "RTN","CHM XWB21",106 5,0)
  38428       I RUNT YPE="F" S  PAYNAME="C HAMPVA CUS TOMER SERV ICE",PAYPH ONE="80073 38387"
  38429   "RTN","CHM XWB21",106 6,0)
  38430       Q
  38431   "RTN","CHM XWB21",106 7,0)
  38432       ;
  38433   "RTN","CHM XWB21",106 8,0)
  38434   GETCLMVAL  ;
  38435   "RTN","CHM XWB21",106 9,0)
  38436       N CHCL B0,CHCLB1, CHCLC0,CHM PAY1,CHCLE 64,CHCLB0A ,CLMTYP
  38437   "RTN","CHM XWB21",107 0,0)
  38438       N TMPD TE,HACCHRG
  38439   "RTN","CHM XWB21",107 1,0)
  38440       S TMPD TE=0
  38441   "RTN","CHM XWB21",107 2,0)
  38442       S CHCL B0=$G(^CHM XCLB(CHCLB I,0))
  38443   "RTN","CHM XWB21",107 3,0)
  38444       S CHCL B1=$G(^CHM XCLB(CHCLB I,1))
  38445   "RTN","CHM XWB21",107 4,0)
  38446       S CHCL E64=$G(^CH MXCLE(CHCL EI,64))
  38447   "RTN","CHM XWB21",107 5,0)
  38448       S:RUNT YPE="F" CH MPAY1=$G(^ CHMPAY(CHM PAYI,"COMM ON"))
  38449   "RTN","CHM XWB21",107 6,0)
  38450       S BPFT I=$P(CHCLB 0,"^",2)        ; 5.B ILLING PRO VIDER FEDE RAL TAX ID
  38451   "RTN","CHM XWB21",107 7,0)
  38452       S BPPN =""                        ; 6.B ILLING PRO VIDER PAYE R NUMBER
  38453   "RTN","CHM XWB21",107 8,0)
  38454       S BPNI D=$P(CHCLB 0,"^",13)       ; 7.B ILLING PRO VIDER NATI ONAL ID
  38455   "RTN","CHM XWB21",107 9,0)
  38456       I RUNT YPE="F" D
  38457   "RTN","CHM XWB21",108 0,0)
  38458       . S CH CLB0A=$G(^ CHMXCLB(CH CLBI,.1))
  38459   "RTN","CHM XWB21",108 1,0)
  38460       . S BP LNAME=$P(C HCLB0A,"^" )    ; 8.B ILLING PRO VIDER LAST  NAME
  38461   "RTN","CHM XWB21",108 2,0)
  38462       . I BP LNAME="",$ P(CHCLB0," ^",3)'=""  S BPLNAME= $P(CHCLB0, "^",3)
  38463   "RTN","CHM XWB21",108 3,0)
  38464       . S BP FNAME=$P(C HCLB0A,"^" ,2)  ; 9.B ILLING PRO VIDER FIRS T NAME
  38465   "RTN","CHM XWB21",108 4,0)
  38466       . S BP MNAME=$P(C HCLB0A,"^" ,3)  ; 10. BILLING PR OVIDER MID DLE NAME
  38467   "RTN","CHM XWB21",108 5,0)
  38468       E  D
  38469   "RTN","CHM XWB21",108 6,0)
  38470       . S BP LNAME=$P(C HCLB0,"^", 3)   ; 8.B ILLING PRO VIDER LAST  NAME
  38471   "RTN","CHM XWB21",108 7,0)
  38472       . S BP FNAME=""                   ; 9.B ILLING PRO VIDER FIRS T NAME
  38473   "RTN","CHM XWB21",108 8,0)
  38474       . S BP MNAME=""                   ; 10. BILLING PR OVIDER MID DLE NAME
  38475   "RTN","CHM XWB21",108 9,0)
  38476       S BPNA MEX=""                     ; 11. BILLING PR OVIDER NAM E SUFFIX
  38477   "RTN","CHM XWB21",109 0,0)
  38478       S SPFT ID=""                      ; 12. SERVICE PR OVIDER FED ERAL TAX I D
  38479   "RTN","CHM XWB21",109 1,0)
  38480       S SPPN =""                        ; 13. SERVICE PR OVIDER PAY ER NUMBER
  38481   "RTN","CHM XWB21",109 2,0)
  38482       S SPNI D=$P(CHCLE 64,"^",4)       ; 14. SERVICE PR OVIDER NAT IONAL ID
  38483   "RTN","CHM XWB21",109 3,0)
  38484       S SPLN AME=$P(CHC LE64,"^",1 )    ; 15. SERVICE PR OVIDER NAM E
  38485   "RTN","CHM XWB21",109 4,0)
  38486       S SPFN AME=$P(CHC LE64,"^",2 )    ; 16. SERVICE PR OVIDER FNA ME
  38487   "RTN","CHM XWB21",109 5,0)
  38488       S SPMN AME=$P(CHC LE64,"^",3 )    ; 17. SERVICE PR OVIDER MNA ME
  38489   "RTN","CHM XWB21",109 6,0)
  38490       S SPNA MEX=""                     ; 18. SERVICE PR OVIDER NAM E SUFFIX
  38491   "RTN","CHM XWB21",109 7,0)
  38492       S EMPI DNUM=""                    ; 19. EMPLOYER I DENTIFICAT ION NUMBER
  38493   "RTN","CHM XWB21",109 8,0)
  38494       S EMPN AME=""                     ; 20. EMPLOYER N AME
  38495   "RTN","CHM XWB21",109 9,0)
  38496       S CHCL C0=$G(^CHM XCLC(CHCLC I,0))
  38497   "RTN","CHM XWB21",110 0,0)
  38498       S SUBS CID=$P(CHC LC0,"^",4)      ; 21. SUBSCRIBER  ID
  38499   "RTN","CHM XWB21",110 1,0)
  38500       S SUBL NAME=$P(CH CLC0,"^",5 )    ; 22. SUBSCRIBER  LAST NAME
  38501   "RTN","CHM XWB21",110 2,0)
  38502       S SUBF NAME=$P(CH CLC0,"^",6 )    ; 23. SUBSCRIBER  FIRST NAM E
  38503   "RTN","CHM XWB21",110 3,0)
  38504       S SUBM NAME=$P(CH CLC0,"^",7 )    ; 24. SUBSCRIBER  MIDDLE NA ME 
  38505   "RTN","CHM XWB21",110 4,0)
  38506       S SUBN AMEX=$P(CH CLC0,"^",8 )    ; 25. SUBSCRIBER  NAME SUFF IX
  38507   "RTN","CHM XWB21",110 5,0)
  38508       S PATI D=""                       ; 26. PATIENT ID
  38509   "RTN","CHM XWB21",110 6,0)
  38510       S PATL NAME=$P(CH CLC0,"^",5 )    ; 27. PATIENT LA ST NAME
  38511   "RTN","CHM XWB21",110 7,0)
  38512       S PATF NAME=$P(CH CLC0,"^",6 )    ; 28. PATIENT FI RST NAME
  38513   "RTN","CHM XWB21",110 8,0)
  38514       S PATM NAME=$P(CH CLC0,"^",7 )    ; 29. PATIENT MI DDLE NAME
  38515   "RTN","CHM XWB21",110 9,0)
  38516       S PATN AMEX=$P(CH CLC0,"^",8 )    ; 30. PATIENT NA ME SUFFIX
  38517   "RTN","CHM XWB21",111 0,0)
  38518       S PATD OB=$P(CHCL C0,"^",9)       ; 31. PATIENT DA TE OF BIRT H  
  38519   "RTN","CHM XWB21",111 1,0)
  38520       S PATG ENDR=$P(CH CLC0,"^",1 0)   ; 32. PATIENT GE NDER
  38521   "RTN","CHM XWB21",111 2,0)
  38522       S:"MF" '[PATGENDR  PATGENDR= ""   ;   D O NOT ALLO W PATIENT  GENDER UNK NOWN
  38523   "RTN","CHM XWB21",111 3,0)
  38524       S ECLM NUM=$P(^CH MXCLE(CHCL EI,3),"^", 5)  ; 33.E MDEON CLAI M NUMBER
  38525   "RTN","CHM XWB21",111 4,0)
  38526       S CLMC HRG=$S($P( ^CHMXCLE(C HCLEI,2)," ^",1)'>0:" 0.00",1:$P (^CHMXCLE( CHCLEI,2), "^",1)) ;  34.CHARGE  AMT 
  38527   "RTN","CHM XWB21",111 5,0)
  38528       ;; HAP E POR - 7/ 8/13 added  below to  determine  payment am ount
  38529   "RTN","CHM XWB21",111 6,0)
  38530       I RUNT YPE="F" D
  38531   "RTN","CHM XWB21",111 7,0)
  38532       . N HA CCLM,HACLN CG
  38533   "RTN","CHM XWB21",111 8,0)
  38534       . S (H ACCLM,CLMP MT)="" F   S HACCLM=$ O(^CHMXCLE (CHCLEI,80 ,"B",HACCL M)) Q:HACC LM=""  D
  38535   "RTN","CHM XWB21",111 9,0)
  38536       .. S H ACLNCG=$G( HACLNCG)+$ $HACLN^CHM XWB24(HACC LM)
  38537   "RTN","CHM XWB21",112 0,0)
  38538       .. S H ACCHRG=$G( HACCHRG)+$ P($G(^CHMP AY(HACCLM, "COMMON")) ,"^")
  38539   "RTN","CHM XWB21",112 1,0)
  38540       .. I ' $D(^CHMSNA (741008.2, "AB",HACCL M)),'$D(^C HMSNA(7410 08.3,"D",H ACCLM)) S  CLMPMT=0 Q
  38541   "RTN","CHM XWB21",112 2,0)
  38542       .. ;HA PE POR 7/2 9/13 PROVI DER PAYMEN T AMOUNT
  38543   "RTN","CHM XWB21",112 3,0)
  38544       .. S C LMPMT=CLMP MT+$P($G(^ CHMPAY(HAC CLM,1)),"^ ",14)
  38545   "RTN","CHM XWB21",112 4,0)
  38546       . ; HA PE POR 8/7 /13 - if t he CLMCHRG  is differ ent from ' COMMON' no de, use 'C OMMON' val ue
  38547   "RTN","CHM XWB21",112 5,0)
  38548       . I $F N(HACCHRG, "",2)'=$FN (CLMCHRG," ",2) D
  38549   "RTN","CHM XWB21",112 6,0)
  38550       .. I H ACCHRG=(2* CLMCHRG) Q
  38551   "RTN","CHM XWB21",112 7,0)
  38552       .. S C LMCHRG=HAC CHRG
  38553   "RTN","CHM XWB21",112 8,0)
  38554       . I HA CLNCG'="NO NE",$FN(HA CLNCG,"",2 )'=$FN(CLM CHRG,"",2)  D
  38555   "RTN","CHM XWB21",112 9,0)
  38556       .. I H ACLNCG=(2* CLMCHRG) Q
  38557   "RTN","CHM XWB21",113 0,0)
  38558       .. S C LMCHRG=HAC LNCG
  38559   "RTN","CHM XWB21",113 1,0)
  38560       E  S C LMPMT=0                    ; 35. CLAIM PAYM ENT AMOUNT
  38561   "RTN","CHM XWB21",113 2,0)
  38562       S CLMC HRG=$FN(CL MCHRG,"",2 )
  38563   "RTN","CHM XWB21",113 3,0)
  38564       S CLMP MT=$FN(CLM PMT,"",2)
  38565   "RTN","CHM XWB21",113 4,0)
  38566       S CAPD =$S(RUNTYP E="F":PAYD ATE,1:"")   ; 36.CLAI M ADJ/PAYM ENT DATE
  38567   "RTN","CHM XWB21",113 5,0)
  38568       S CHKE FTDATE=$S( RUNTYPE="F ":CHKDATE, 1:"")  ; 3 7.CHECK/EF T DATE
  38569   "RTN","CHM XWB21",113 6,0)
  38570       S CHKE FTNUM=$S(R UNTYPE="F" :CHKEFT,1: "") ; 38.C HECK/EFT N UMBER   
  38571   "RTN","CHM XWB21",113 7,0)
  38572       S BTYP E=$S(RUNTY PE="F":$P( $G(^CHMPAY (CHMPAYI,7 )),"^",6), 1:"")       ; 39.BILL  TYPE 
  38573   "RTN","CHM XWB21",113 8,0)
  38574       S PCID NUM=$P($G( ^CHMXCLE(C HCLEI,100) ),"^",2)   ; 40.PAYER  CLAIM ID  NUMBER (PD I)
  38575   "RTN","CHM XWB21",113 9,0)
  38576       S:PCID NUM="" PCI DNUM=$P($G (^CHMXCLE( CHCLEI,100 )),"^",4)  ; PDI NOT  POPULATED,  DERIVED C LAIM CTL N UM
  38577   "RTN","CHM XWB21",114 0,0)
  38578       S PATA CCT=$P($G( ^CHMXCLE(C HCLEI,0)), "^",2)     ; 41.PATIE NT ACCOUNT  NUMBER 
  38579   "RTN","CHM XWB21",114 1,0)
  38580       S PRSC NUM=""                     ; 42. PHARMACY P RESCRIPTIO N NUMBER
  38581   "RTN","CHM XWB21",114 2,0)
  38582       S VOUC HID=""                     ; 43. VOUCHER ID ENTIFIER 
  38583   "RTN","CHM XWB21",114 3,0)
  38584       S LOCS YSID=""                    ; 44. APP/LOCATI ON SYSTEM  ID
  38585   "RTN","CHM XWB21",114 4,0)
  38586       S GRPN UM=""                      ; 45. GROUP NUMB ER
  38587   "RTN","CHM XWB21",114 5,0)
  38588       S CLMT YP=$$GETCL MTYP            ; GET  I/P/D CLA IM TYPE
  38589   "RTN","CHM XWB21",114 6,0)
  38590       S:CLMT YP="P" SVC DATES=$$GP STARTEND   ; 46/47. P ROFESSIONA L SERVICE  START DATE
  38591   "RTN","CHM XWB21",114 7,0)
  38592       S:CLMT YP="I" SVC DATES=$$GI STARTEND   ; 46.1/47. 1 INSTITUT IONAL STAR T/END
  38593   "RTN","CHM XWB21",114 8,0)
  38594       S:CLMT YP="D" SVC DATES=$$GD STARTEND   ; 46.2/47. 2 DENTAL S TART/END
  38595   "RTN","CHM XWB21",114 9,0)
  38596       S CLMS TDT=$P(SVC DATES,"*", 1),CLMENDT =$P(SVCDAT ES,"*",2)
  38597   "RTN","CHM XWB21",115 0,0)
  38598       Q
  38599   "RTN","CHM XWB21",115 1,0)
  38600       ;
  38601   "RTN","CHM XWB21",115 2,0)
  38602   GPSTARTEND () ; POPUL ATE EMDEON  REQUIRED  FIELD FOR  PROFESSION AL CLAIM S TART/END D ATES
  38603   "RTN","CHM XWB21",115 3,0)
  38604       N STDA TE,CHFI,TD ATE,EDATE, SVCDATES
  38605   "RTN","CHM XWB21",115 4,0)
  38606       S CHFI =0
  38607   "RTN","CHM XWB21",115 5,0)
  38608       S CHFI =$O(^CHMXC LF("B",CHC LEI,CHFI))
  38609   "RTN","CHM XWB21",115 6,0)
  38610       S STDA TE=$P($G(^ CHMXCLF(CH FI,1)),"^" ,11),TMPDT E=STDATE   ; TMPDTE I S LAST STA RT DATE
  38611   "RTN","CHM XWB21",115 7,0)
  38612       F  S C HFI=$O(^CH MXCLF("B", CHCLEI,CHF I)) Q:'CHF I  D  ; CH ECK ALL LI  "FROM" DA TES
  38613   "RTN","CHM XWB21",115 8,0)
  38614       .S TDA TE=$P($G(^ CHMXCLF(CH FI,1)),"^" ,11)
  38615   "RTN","CHM XWB21",115 9,0)
  38616       .I TDA TE<STDATE  S STDATE=T DATE   ; T RACK "OLDE ST" START  DATE
  38617   "RTN","CHM XWB21",116 0,0)
  38618       .I TDA TE>TMPDTE  S TMPDTE=T DATE   ; T RACK "MOST  RECENT" S TART DATE
  38619   "RTN","CHM XWB21",116 1,0)
  38620       S EDAT E=$$GSVCEN D
  38621   "RTN","CHM XWB21",116 2,0)
  38622       S:(EDA TE="")!(ED ATE<TMPDTE ) EDATE=TM PDTE
  38623   "RTN","CHM XWB21",116 3,0)
  38624       ;HAPE  POR - 11/1 3/13 EDATE  must have  a value
  38625   "RTN","CHM XWB21",116 4,0)
  38626       I EDAT E="" S EDA TE=STDATE
  38627   "RTN","CHM XWB21",116 5,0)
  38628       ;HAPE  POR - 11/1 3/13 some  data is in  FileMan f ormat, nee ds to be Y YYYMMDD
  38629   "RTN","CHM XWB21",116 6,0)
  38630       I $L(S TDATE)=7 S  X=STDATE  D H^%DTC I  %H'="" S  STDATE=$ZD (%H,8)
  38631   "RTN","CHM XWB21",116 7,0)
  38632       I $L(E DATE)=7 S  X=EDATE D  H^%DTC I % H'="" S ED ATE=$ZD(%H ,8)
  38633   "RTN","CHM XWB21",116 8,0)
  38634       S SVCD ATES=STDAT E_"*"_EDAT E
  38635   "RTN","CHM XWB21",116 9,0)
  38636       Q SVCD ATES
  38637   "RTN","CHM XWB21",117 0,0)
  38638       ;
  38639   "RTN","CHM XWB21",117 1,0)
  38640   GISTARTEND () ; POPUL ATE EMDEON  FIELD FOR  INSTITUTI ONAL CLAIM  START/END  DATES
  38641   "RTN","CHM XWB21",117 2,0)
  38642       N STDA TE,CHFI,TD ATE,EDATE, SVCDATES
  38643   "RTN","CHM XWB21",117 3,0)
  38644       S CHFI =0
  38645   "RTN","CHM XWB21",117 4,0)
  38646       S STDA TE=$P($G(^ CHMXCLE(CH CLEI,1))," ^",1)   ;  START DATE
  38647   "RTN","CHM XWB21",117 5,0)
  38648       S EDAT E=$P($G(^C HMXCLE(CHC LEI,1)),"^ ",2)    ;  END DATE
  38649   "RTN","CHM XWB21",117 6,0)
  38650       ;HAPE  POR - 11/1 3/13 EDATE  must have  a value
  38651   "RTN","CHM XWB21",117 7,0)
  38652       I EDAT E="" S EDA TE=STDATE
  38653   "RTN","CHM XWB21",117 8,0)
  38654       ;HAPE  POR - 11/1 3/13 some  data is in  FileMan f ormat, nee ds to be Y YYYMMDD
  38655   "RTN","CHM XWB21",117 9,0)
  38656       I $L(S TDATE)=7 S  X=STDATE  D H^%DTC I  %H'="" S  STDATE=$ZD (%H,8)
  38657   "RTN","CHM XWB21",118 0,0)
  38658       I $L(E DATE)=7 S  X=EDATE D  H^%DTC I % H'="" S ED ATE=$ZD(%H ,8)
  38659   "RTN","CHM XWB21",118 1,0)
  38660       S SVCD ATES=STDAT E_"*"_EDAT E
  38661   "RTN","CHM XWB21",118 2,0)
  38662       Q SVCD ATES
  38663   "RTN","CHM XWB21",118 3,0)
  38664       ;
  38665   "RTN","CHM XWB21",118 4,0)
  38666   GDSTARTEND () ; POPUL ATE EMDEON  FIELD FOR  DENTAL CL AIM START/ END DATES
  38667   "RTN","CHM XWB21",118 5,0)
  38668       N STDA TE,EDATE,S VCDATES
  38669   "RTN","CHM XWB21",118 6,0)
  38670       S STDA TE=$P($G(^ CHMXCLE(CH CLEI,1))," ^",1)   ;  START DATE
  38671   "RTN","CHM XWB21",118 7,0)
  38672       S EDAT E=$P($G(^C HMXCLE(CHC LEI,1)),"^ ",2)    ;  END DATE
  38673   "RTN","CHM XWB21",118 8,0)
  38674       ;HAPE  POR - 11/1 3/13 EDATE  must have  a value
  38675   "RTN","CHM XWB21",118 9,0)
  38676       I EDAT E="" S EDA TE=STDATE
  38677   "RTN","CHM XWB21",119 0,0)
  38678       ;HAPE  POR - 11/1 3/13 some  data is in  FileMan f ormat, nee ds to be Y YYYMMDD
  38679   "RTN","CHM XWB21",119 1,0)
  38680       I $L(S TDATE)=7 S  X=STDATE  D H^%DTC I  %H'="" S  STDATE=$ZD (%H,8)
  38681   "RTN","CHM XWB21",119 2,0)
  38682       I $L(E DATE)=7 S  X=EDATE D  H^%DTC I % H'="" S ED ATE=$ZD(%H ,8)
  38683   "RTN","CHM XWB21",119 3,0)
  38684       S SVCD ATES=STDAT E_"*"_EDAT E
  38685   "RTN","CHM XWB21",119 4,0)
  38686       Q SVCD ATES
  38687   "RTN","CHM XWB21",119 5,0)
  38688       ;
  38689   "RTN","CHM XWB21",119 6,0)
  38690   GETSTCVAL( TYPE) ;
  38691   "RTN","CHM XWB21",119 7,0)
  38692       S PCIN UM=$P($G(^ CHMXCLE(CH CLEI,100)) ,"^",2)     ; 4.PAYER  CLAIM ID  NUMBER(PDI )  
  38693   "RTN","CHM XWB21",119 8,0)
  38694       S:PCIN UM="" PCIN UM=$P($G(^ CHMXCLE(CH CLEI,100)) ,"^",4)  ;  PDI NOT P OPULATED,  DERIVED CL AIM CTL NU M
  38695   "RTN","CHM XWB21",119 9,0)
  38696       S DATE RR=""   ;1 0.EMDEON S PECIFIC DA TA IN ERRO R
  38697   "RTN","CHM XWB21",120 0,0)
  38698       S ESCO DE=""   ;1 1.EMDEOM S PECIFIC ST ATUS CODE
  38699   "RTN","CHM XWB21",120 1,0)
  38700       I RUNT YPE="F" D   Q
  38701   "RTN","CHM XWB21",120 2,0)
  38702       . I TY PE="CLM" S  LICNUM=""  Q
  38703   "RTN","CHM XWB21",120 3,0)
  38704       . I CH CLFI="" S  LICNUM=$G( STCLICN) Q
  38705   "RTN","CHM XWB21",120 4,0)
  38706       . I $P ($G(^CHMXC LF(CHCLFI, 1)),"^",23 )'="" S LI CNUM=$P(^( 1),"^",23)
  38707   "RTN","CHM XWB21",120 5,0)
  38708       . I $G (LICNUM)=" " S LICNUM =$P($G(^CH MXCLF(CHCL FI,0)),"^" ,2)
  38709   "RTN","CHM XWB21",120 6,0)
  38710       S:TYPE ="CLM" LIC NUM=""                            ; 5.CLM L VL LINE IT EM CONTROL  NUMBER
  38711   "RTN","CHM XWB21",120 7,0)
  38712       S:TYPE ="DTL" LIC NUM=$P($G( ^CHMXCLF(C HCLFI,0)), "^",2)   ;    SERVICE  LINE NUMB ER 
  38713   "RTN","CHM XWB21",120 8,0)
  38714       Q
  38715   "RTN","CHM XWB21",120 9,0)
  38716       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  38717   "RTN","CHM XWB21",121 0,0)
  38718       ; 9/7/ 2011: modi fied Proce dure Modif ier #1 ext ract to fi eld 4 from  field 3;
  38719   "RTN","CHM XWB21",121 1,0)
  38720       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  38721   "RTN","CHM XWB21",121 2,0)
  38722   GDTLVARS ;  DTL RECOR D DATA GAT HERING
  38723   "RTN","CHM XWB21",121 3,0)
  38724       N TOC, CLTYPE,CLL D0,CLLD1,X 1,X2,CHCLF 1,CLMTYP,C LNUM,SVCDA TES,PIECE
  38725   "RTN","CHM XWB21",121 4,0)
  38726       S (TOC ,CLTYPE,LI CN,CLLD0,C LLD1)=""
  38727   "RTN","CHM XWB21",121 5,0)
  38728       S PCID =$P($G(^CH MXCLE(CHCL EI,100))," ^",2)          ; FIRS T TRY THE  ASSIGNED P DI NUMBER
  38729   "RTN","CHM XWB21",121 6,0)
  38730       S:PCID ="" PCID=$ P($G(^CHMX CLE(CHCLEI ,100)),"^" ,4) ; PDI  NOT POPULA TED, DERIV ED CLAIM C TL NUM
  38731   "RTN","CHM XWB21",121 7,0)
  38732       S CHCL F1=$G(^CHM XCLF(CHCLF I,1))
  38733   "RTN","CHM XWB21",121 8,0)
  38734       ; HAPE  POR - set  TOC = typ e of claim
  38735   "RTN","CHM XWB21",121 9,0)
  38736       I RUNT YPE="F" D
  38737   "RTN","CHM XWB21",122 0,0)
  38738       . S CL NUM=$P($G( ^CHMXCLF(C HCLFI,0)), "^",2)
  38739   "RTN","CHM XWB21",122 1,0)
  38740       . S HA CCLM=$O(LN DATA(CLNUM ,""))
  38741   "RTN","CHM XWB21",122 2,0)
  38742       . I HA CCLM'="" S  TOC=$$TOS ^CH835FU1( $P($G(^CHM PAY(HACCLM ,0)),"^",7 ))
  38743   "RTN","CHM XWB21",122 3,0)
  38744       . I $G (TOC)'=""  S CLTYPE=$ S(TOC="IPT ":"INP-REV ",TOC="OPT ":"OPT-PRO C",TOC="RX T":"PHARM" ,TOC="DUR" :"DME-SUPP LY",TOC="D NT":"DEN-P ROC",TOC=" TRV":"OPT- PROC",1:"O PT-PROC")
  38745   "RTN","CHM XWB21",122 4,0)
  38746       . I HA CCLM'="" S  CLLD1=$G( ^CHMPAY(HA CCLM,1))
  38747   "RTN","CHM XWB21",122 5,0)
  38748       . I $P ($G(^CHMXC LF(CHCLFI, 1)),"^",23 )'="" S LI CN=$P(^(1) ,"^",23)
  38749   "RTN","CHM XWB21",122 6,0)
  38750       . Q
  38751   "RTN","CHM XWB21",122 7,0)
  38752       I LICN ="" S LICN =$P($G(^CH MXCLF(CHCL FI,0)),"^" ,2)  ; 5.S ERVICE LIN E NUMBER
  38753   "RTN","CHM XWB21",122 8,0)
  38754       S SQID =$P(CHCLF1 ,"^",2)  ;  6.SERVICE  QUALIFIER  ID
  38755   "RTN","CHM XWB21",122 9,0)
  38756       S:SQID ="" SQID=" NU"      ;     DEFAUL T VALUE IF  NOT PROVI DED
  38757   "RTN","CHM XWB21",123 0,0)
  38758       S SICO DE=$P(CHCL F1,"^",3)   ; 7.SERVI CE IDENTIF ICATION CO DE
  38759   "RTN","CHM XWB21",123 1,0)
  38760       S:SICO DE="" SICO DE=$P(^CHM XCLF(CHCLF I,1),"^",1 )  ;DEFAUL T VALUE IF  NOT PROVI DED
  38761   "RTN","CHM XWB21",123 2,0)
  38762       S PRCM 1=$P(CHCLF 1,"^",4)   ; 8.PROCED URE MODIFI ER 1
  38763   "RTN","CHM XWB21",123 3,0)
  38764       S PRCM 2=$P(CHCLF 1,"^",5)   ; 9.PROCED URE MODIFI ER 2
  38765   "RTN","CHM XWB21",123 4,0)
  38766       S PRCM 3=$P(CHCLF 1,"^",14)   ; 10.PROC EDURE MODI FIER 3
  38767   "RTN","CHM XWB21",123 5,0)
  38768       S PRCM 4=$P(CHCLF 1,"^",15)   ; 11.PROC EDURE MODI FIER 4
  38769   "RTN","CHM XWB21",123 6,0)
  38770       I RUNT YPE="F" D
  38771   "RTN","CHM XWB21",123 7,0)
  38772       . N X
  38773   "RTN","CHM XWB21",123 8,0)
  38774       . S LI CHRGA=$$LC A(TOC,CLNU M,CHCLF1,H ACCLM,.LND ATA)  ;FIN AL LINE IT EM CHARGE  AMOUNT
  38775   "RTN","CHM XWB21",123 9,0)
  38776       . S:LI CHRGA="" L ICHRGA=$P( CHCLF1,"^" ,6) S LICH RGA=$FN(LI CHRGA,"",2 )
  38777   "RTN","CHM XWB21",124 0,0)
  38778       . ;HAP E POR - 7/ 8/13 added  $$LPA for  FINAL lin e payment  amount
  38779   "RTN","CHM XWB21",124 1,0)
  38780       . S LI PPA=$FN($$ LPA(TOC,CL NUM,CHCLFI ,HACCLM,CL TYPE,.LNDA TA),"",2)   ;FINAL LI NE ITEM PR OV. PAYMEN T AMOUNT
  38781   "RTN","CHM XWB21",124 2,0)
  38782       . S QT YUOS=$$LQT Y(TOC,CLNU M,CHCLF1,H ACCLM,.LND ATA)  ;FIN AL QUANTIT Y(UNITS OF  SERVICE)
  38783   "RTN","CHM XWB21",124 3,0)
  38784       . S PI ECE=$S(TOC ="DNT":10, TOC="DUR": 8,TOC="IPT ":1,TOC="O PT":16,TOC ="RXT":0,T OC="TRV":1 6,1:0)
  38785   "RTN","CHM XWB21",124 4,0)
  38786       . I HA CCLM="" S  RVNUCODE=" " Q
  38787   "RTN","CHM XWB21",124 5,0)
  38788       . S X= $O(LNDATA( CLNUM,HACC LM,"")) I  X="" S RVN UCODE="" Q
  38789   "RTN","CHM XWB21",124 6,0)
  38790       . S RV NUCODE=$P( $G(LNDATA( CLNUM,HACC LM,X)),"^" ,PIECE) I  RVNUCODE'= "" S RVNUC ODE=$$REVC D^CHMXWB24 (RVNUCODE)
  38791   "RTN","CHM XWB21",124 7,0)
  38792       . ;HAP E POR 12/2 0/13 - pro blem with  Service Id entificati on Code wh en Service  Qualifer  ID = NU
  38793   "RTN","CHM XWB21",124 8,0)
  38794       . ;HAP E POR 1/20 /14 - made  change to  force rev enue code  = "" when  service qu alifer id  = NU and s ervice ide ntificatio n
  38795   "RTN","CHM XWB21",124 9,0)
  38796       . ;                     code  is set =  revenue co de
  38797   "RTN","CHM XWB21",125 0,0)
  38798       . I SQ ID="NU" S  SICODE=RVN UCODE,RVNU CODE=""
  38799   "RTN","CHM XWB21",125 1,0)
  38800       I RUNT YPE'="F" D
  38801   "RTN","CHM XWB21",125 2,0)
  38802       . S LI CHRGA=$P(C HCLF1,"^", 6)  ; 12.A CK/PEND LI NE ITEM CH ARGE AMOUN T
  38803   "RTN","CHM XWB21",125 3,0)
  38804       . S LI PPA="0.00"   ; 13.ACK /PEND LINE  ITEM PROV . PAYMENT  AMOUNT
  38805   "RTN","CHM XWB21",125 4,0)
  38806       . S RV NUCODE=$P( ^CHMXCLF(C HCLFI,1)," ^") ; 14.R EVENUE COD E
  38807   "RTN","CHM XWB21",125 5,0)
  38808       . S QT YUOS=$P(CH CLF1,"^",8 )  ; 15.AC K/PEND QUA NTITY(UNIT S OF SERVI CE)
  38809   "RTN","CHM XWB21",125 6,0)
  38810       I RVNU CODE="9999 " S RVNUCO DE=""          ;    D ON'T OUTPU T 9999 VAL UE
  38811   "RTN","CHM XWB21",125 7,0)
  38812       S ECLM NUM=$P(^CH MXCLE(CHCL EI,3),"^", 5)  ; 16.E MDEON CLAI M NUMBER
  38813   "RTN","CHM XWB21",125 8,0)
  38814       S CLMT YP=$$GETCL MTYP   ; G ET I/P/D C LAIM TYPE
  38815   "RTN","CHM XWB21",125 9,0)
  38816       S:CLMT YP="P" SVC DATES=$$GP DSTARTEND   ; 17. PRO FESSIONAL  SERVICE ST ART/END DA TE
  38817   "RTN","CHM XWB21",126 0,0)
  38818       S:CLMT YP="I" SVC DATES=$$GI DSTARTEND   ; 17.1 IN STITUTIONA L SERVICE  START/END  DATES
  38819   "RTN","CHM XWB21",126 1,0)
  38820       S:CLMT YP="D" SVC DATES=$$GD DSTARTEND   ; 17.2 DE NTAL SERVI CE START/E ND DATES
  38821   "RTN","CHM XWB21",126 2,0)
  38822       S SVCS TDATE=$P(S VCDATES,"* ",1),SVCEN DATE=$P(SV CDATES,"*" ,2)
  38823   "RTN","CHM XWB21",126 3,0)
  38824       Q
  38825   "RTN","CHM XWB21",126 4,0)
  38826       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  38827   "RTN","CHM XWB21",126 5,0)
  38828       ; LINE  ITEM FUNC TIONS TO G ATHER THE  SPECIFIC D ATA FIELDS              ;
  38829   "RTN","CHM XWB21",126 6,0)
  38830       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  38831   "RTN","CHM XWB21",126 7,0)
  38832       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  38833   "RTN","CHM XWB21",126 8,0)
  38834       ; EMDE ON REQUIRE S THE EARL IEST START  DATE (CLA IM OR LINE  ITEM DATE   ;
  38835   "RTN","CHM XWB21",126 9,0)
  38836       ; FOR  THE SERVIC E START DA TE. THIS F UNCTION 1)  GETS THE  CLAIM STAR T ;
  38837   "RTN","CHM XWB21",127 0,0)
  38838       ; DATE , THEN SEA RCHES THRO UGH LINE I TEMS FOR A NY EARLIER  DATES.      ;
  38839   "RTN","CHM XWB21",127 1,0)
  38840       ; THE  EARLIEST D ATE FOUND  IS RECORDE D AS THE S TART DATE.              ;
  38841   "RTN","CHM XWB21",127 2,0)
  38842       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  38843   "RTN","CHM XWB21",127 3,0)
  38844       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  38845   "RTN","CHM XWB21",127 4,0)
  38846       ; DETE RMINE THE  CLAIM TYPE , I.E. PRO FESSIONAL,  INSTITUTI ONAL, OR D ENTAL
  38847   "RTN","CHM XWB21",127 5,0)
  38848       ; 4010 /5010 VERS ION IDENTI FIERS
  38849   "RTN","CHM XWB21",127 6,0)
  38850       ;  98  / 222 PROF ESSIONAL C LAIMS
  38851   "RTN","CHM XWB21",127 7,0)
  38852       ;  96  / 223 INST ITUTIONAL  CLAIMS
  38853   "RTN","CHM XWB21",127 8,0)
  38854       ;  97  / 224 DENT AL CLAIMS
  38855   "RTN","CHM XWB21",127 9,0)
  38856       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  38857   "RTN","CHM XWB21",128 0,0)
  38858   GETCLMTYP( ) ;
  38859   "RTN","CHM XWB21",128 1,0)
  38860       N TYPE   ; VERSIO N-FUNCTION AL TYPE NU MBER FROM  ^CHMXCLA()
  38861   "RTN","CHM XWB21",128 2,0)
  38862       S TYPE =$P($G(^CH MXCLA(CHCL AI,0)),"^" ,13)
  38863   "RTN","CHM XWB21",128 3,0)
  38864       Q:(TYP E[222)!(TY PE[98) "P"
  38865   "RTN","CHM XWB21",128 4,0)
  38866       Q:(TYP E[223)!(TY PE[96) "I"
  38867   "RTN","CHM XWB21",128 5,0)
  38868       Q:(TYP E[224)!(TY PE[97) "D"
  38869   "RTN","CHM XWB21",128 6,0)
  38870       Q "U"
  38871   "RTN","CHM XWB21",128 7,0)
  38872       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  38873   "RTN","CHM XWB21",128 8,0)
  38874       ; PROF ESSIONAL S TART/END D ATES
  38875   "RTN","CHM XWB21",128 9,0)
  38876       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  38877   "RTN","CHM XWB21",129 0,0)
  38878   GPDSTARTEN D() ; POPU LATE EMDEO N REQUIRED  FIELD FOR  PROFESSIO NAL START/ END DATES
  38879   "RTN","CHM XWB21",129 1,0)
  38880       N STDA TE,CHFI,TD ATE,EDATE, SVCDATES
  38881   "RTN","CHM XWB21",129 2,0)
  38882       S STDA TE=$P($G(^ CHMXCLF(CH CLFI,1))," ^",11)  ;  START DATE
  38883   "RTN","CHM XWB21",129 3,0)
  38884       S EDAT E=$P($G(^C HMXCLF(CHC LFI,1)),"^ ",12)   ;  END DATE
  38885   "RTN","CHM XWB21",129 4,0)
  38886       S:EDAT E="" EDATE =STDATE
  38887   "RTN","CHM XWB21",129 5,0)
  38888       ;HAPE  POR - 11/1 3/13 some  data is in  FileMan f ormat, nee ds to be Y YYYMMDD
  38889   "RTN","CHM XWB21",129 6,0)
  38890       I $L(S TDATE)=7 S  X=STDATE  D H^%DTC I  %H'="" S  STDATE=$ZD (%H,8)
  38891   "RTN","CHM XWB21",129 7,0)
  38892       I $L(E DATE)=7 S  X=EDATE D  H^%DTC I % H'="" S ED ATE=$ZD(%H ,8)
  38893   "RTN","CHM XWB21",129 8,0)
  38894       S SVCD ATES=STDAT E_"*"_EDAT E
  38895   "RTN","CHM XWB21",129 9,0)
  38896       Q SVCD ATES
  38897   "RTN","CHM XWB21",130 0,0)
  38898       ;
  38899   "RTN","CHM XWB21",130 1,0)
  38900   GIDSTARTEN D() ; POPU LATE EMDEO N FIELD FO R INSTITUT IONAL DETA IL START/E ND DATES
  38901   "RTN","CHM XWB21",130 2,0)
  38902       N STDA TE,CHFI,TD ATE,EDATE, SVCDATES
  38903   "RTN","CHM XWB21",130 3,0)
  38904       S STDA TE=$P($G(^ CHMXCLF(CH CLFI,1))," ^",11)
  38905   "RTN","CHM XWB21",130 4,0)
  38906       S:STDA TE="" STDA TE=$P($G(^ CHMXCLE(CH CLEI,1))," ^",1) ; ST ART DATE
  38907   "RTN","CHM XWB21",130 5,0)
  38908       S EDAT E=$P($G(^C HMXCLF(CHC LFI,1)),"^ ",12)
  38909   "RTN","CHM XWB21",130 6,0)
  38910       S:EDAT E="" EDATE =$P($G(^CH MXCLF(CHCL FI,1)),"^" ,11)
  38911   "RTN","CHM XWB21",130 7,0)
  38912       S:EDAT E="" EDATE =$P($G(^CH MXCLE(CHCL EI,1)),"^" ,2)
  38913   "RTN","CHM XWB21",130 8,0)
  38914       I EDAT E="" S EDA TE=STDATE   ;HAPE POR  - 11/13/1 3 make sur e end date  is sent
  38915   "RTN","CHM XWB21",130 9,0)
  38916       ;HAPE  POR - 11/1 3/13 some  data is in  FileMan f ormat, nee ds to be Y YYYMMDD
  38917   "RTN","CHM XWB21",131 0,0)
  38918       I $L(S TDATE)=7 S  X=STDATE  D H^%DTC I  %H'="" S  STDATE=$ZD (%H,8)
  38919   "RTN","CHM XWB21",131 1,0)
  38920       I $L(E DATE)=7 S  X=EDATE D  H^%DTC I % H'="" S ED ATE=$ZD(%H ,8)
  38921   "RTN","CHM XWB21",131 2,0)
  38922       S SVCD ATES=STDAT E_"*"_EDAT E
  38923   "RTN","CHM XWB21",131 3,0)
  38924       Q SVCD ATES
  38925   "RTN","CHM XWB21",131 4,0)
  38926       ;
  38927   "RTN","CHM XWB21",131 5,0)
  38928   GDDSTARTEN D() ; EMDE ON DENTAL  DETAIL STA RT/END DAT ES
  38929   "RTN","CHM XWB21",131 6,0)
  38930       N STDA TE,CHFI,TD ATE,EDATE, SVCDATES
  38931   "RTN","CHM XWB21",131 7,0)
  38932       S STDA TE=$P($G(^ CHMXCLF(CH CLFI,1))," ^",11)  ;  START DATE
  38933   "RTN","CHM XWB21",131 8,0)
  38934       S EDAT E=$P($G(^C HMXCLF(CHC LFI,1)),"^ ",12)   ;  END DATE
  38935   "RTN","CHM XWB21",131 9,0)
  38936       S:EDAT E="" EDATE =STDATE
  38937   "RTN","CHM XWB21",132 0,0)
  38938       ;HAPE  POR - 11/1 3/13 some  data is in  FileMan f ormat, nee ds to be Y YYYMMDD
  38939   "RTN","CHM XWB21",132 1,0)
  38940       I $L(S TDATE)=7 S  X=STDATE  D H^%DTC I  %H'="" S  STDATE=$ZD (%H,8)
  38941   "RTN","CHM XWB21",132 2,0)
  38942       I $L(E DATE)=7 S  X=EDATE D  H^%DTC I % H'="" S ED ATE=$ZD(%H ,8)
  38943   "RTN","CHM XWB21",132 3,0)
  38944       S SVCD ATES=STDAT E_"*"_EDAT E
  38945   "RTN","CHM XWB21",132 4,0)
  38946       Q SVCD ATES
  38947   "RTN","CHM XWB21",132 5,0)
  38948       ;
  38949   "RTN","CHM XWB21",132 6,0)
  38950       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  38951   "RTN","CHM XWB21",132 7,0)
  38952       ; EMDE ON REQUIRE S THE LAST  END DATE  (CLAIM OR  LINE ITEM  DATE         ;
  38953   "RTN","CHM XWB21",132 8,0)
  38954       ; FOR  THE SERVIC E END DATE . THIS FUN CTION 1) G ETS THE CL AIM START    ;
  38955   "RTN","CHM XWB21",132 9,0)
  38956       ; DATE , THEN 2)S EARCHES TH ROUGH LINE  ITEMS FOR  ANY LATER  DATES.      ;
  38957   "RTN","CHM XWB21",133 0,0)
  38958       ; THE  LATEST DAT E FOUND IS  RECORDED  AS THE END  DATE.                  ;
  38959   "RTN","CHM XWB21",133 1,0)
  38960       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  38961   "RTN","CHM XWB21",133 2,0)
  38962       ;
  38963   "RTN","CHM XWB21",133 3,0)
  38964   GSVCEND()  ; POPULATE  EMDEON RE QUIRED FIE LD FOR SER VICE END D ATE
  38965   "RTN","CHM XWB21",133 4,0)
  38966       N ENDA TE,CHFI,TD ATE
  38967   "RTN","CHM XWB21",133 5,0)
  38968       S CHFI =0,CHFI=$O (^CHMXCLF( "B",CHCLEI ,CHFI))
  38969   "RTN","CHM XWB21",133 6,0)
  38970       S ENDA TE=$P($G(^ CHMXCLF(CH FI,1)),"^" ,12)  ; ^C HMXCLF(I)  END DATE
  38971   "RTN","CHM XWB21",133 7,0)
  38972       F  S C HFI=$O(^CH MXCLF("B", CHCLEI,CHF I)) Q:'CHF I  D  ; CH ECK ALL LI  "TO" DATE S
  38973   "RTN","CHM XWB21",133 8,0)
  38974       .S TDA TE=$P($G(^ CHMXCLF(CH FI,1)),"^" ,12)
  38975   "RTN","CHM XWB21",133 9,0)
  38976       .I TDA TE>ENDATE  S ENDATE=T DATE             ; TR ACK "YOUNG EST" END D ATE
  38977   "RTN","CHM XWB21",134 0,0)
  38978       Q ENDA TE
  38979   "RTN","CHM XWB21",134 1,0)
  38980       ;
  38981   "RTN","CHM XWB21",134 2,0)
  38982   LCA(TOC,CL NUM,CHCLF1 ,HACCLM,LN DATA) ; FI NAL LINE I TEM CHARGE  AMOUNT 
  38983   "RTN","CHM XWB21",134 3,0)
  38984       N X2,C LLD0
  38985   "RTN","CHM XWB21",134 4,0)
  38986       I HACC LM="" Q ""
  38987   "RTN","CHM XWB21",134 5,0)
  38988       S (X,X 2)=""
  38989   "RTN","CHM XWB21",134 6,0)
  38990       F  S X 2=$O(LNDAT A(CLNUM,HA CCLM,X2))  Q:X2=""  D
  38991   "RTN","CHM XWB21",134 7,0)
  38992       . S CL LD0=LNDATA (CLNUM,HAC CLM,X2)
  38993   "RTN","CHM XWB21",134 8,0)
  38994       . S X= $G(X)+$S(T OC="RXT":$ P(CLLD0,"^ ",4),TOC=" ":$P(CHCLF 1,"^",6),1 :$P(CLLD0, "^",2))
  38995   "RTN","CHM XWB21",134 9,0)
  38996       Q X
  38997   "RTN","CHM XWB21",135 0,0)
  38998       ;
  38999   "RTN","CHM XWB21",135 1,0)
  39000   LPA(TOC,CL NUM,CHCLFI ,HACCLM,CL TYPE,LNDAT A) ; FINAL  LINE ITEM  PAYMENT A MOUNT
  39001   "RTN","CHM XWB21",135 2,0)
  39002       ;
  39003   "RTN","CHM XWB21",135 3,0)
  39004       N X1,X 2,X3,X4,XL N,PIECE,CL LD0
  39005   "RTN","CHM XWB21",135 4,0)
  39006       N CHCL F70,CHCLF1 01,OHIPAY, OHIADJ,DAT A,STOP,PRA MT,NOCLOHI
  39007   "RTN","CHM XWB21",135 5,0)
  39008       I HACC LM="" Q 0
  39009   "RTN","CHM XWB21",135 6,0)
  39010       I $G(H ACPAY(HACC LM))="STOP " Q 0
  39011   "RTN","CHM XWB21",135 7,0)
  39012       S (XLN ,X1)=""
  39013   "RTN","CHM XWB21",135 8,0)
  39014       F  S X 1=$O(LNDAT A(CLNUM,HA CCLM,X1))  Q:X1=""  D
  39015   "RTN","CHM XWB21",135 9,0)
  39016       . S X2 =$O(^CHMPA Y(HACCLM,C LTYPE,X1,1 ,0)) I 'X2  Q
  39017   "RTN","CHM XWB21",136 0,0)
  39018       . S X2 =$G(^(X2,0 ))
  39019   "RTN","CHM XWB21",136 1,0)
  39020       . I +$ P(X2,"^",1 5)>0 S XLN =$G(XLN)+$ P(X2,"^",1 5) Q
  39021   "RTN","CHM XWB21",136 2,0)
  39022       . S XL N=$G(XLN)+ $P(X2,"^", 12)-$P(X2, "^",16) Q
  39023   "RTN","CHM XWB21",136 3,0)
  39024       I XLN' ="" Q XLN
  39025   "RTN","CHM XWB21",136 4,0)
  39026       S TOC= $$TOS^CH83 5FU1($P($G (^CHMPAY(H ACCLM,0)), "^",7))
  39027   "RTN","CHM XWB21",136 5,0)
  39028       ;HAPE  POR 12/12/ 13 already  have CLTY PE set
  39029   "RTN","CHM XWB21",136 6,0)
  39030       ;;S CL TYPE=$S(TO C="IPT":"I NP-REV",TO C="OPT":"O PT-PROC",T OC="RXT":" PHARM",TOC ="DUR":"DM E-SUPPLY", TOC="DNT": "DEN-PROC" ,TOC="TRV" :"OPT-PROC ",1:"OPT-P ROC")
  39031   "RTN","CHM XWB21",136 7,0)
  39032       S PIEC E=$S(TOC=" DNT":"5;7; 2",TOC="DU R":"4;5;2" ,TOC="IPT" :"2;2;2",T OC="OPT":" 3;5;2",TOC ="RXT":"5; 10;4",TOC= "TRV":"3;5 ;2",1:"")
  39033   "RTN","CHM XWB21",136 8,0)
  39034       I $G(C LMOTH(HACC LM))'="" D
  39035   "RTN","CHM XWB21",136 9,0)
  39036       . S X1 =0
  39037   "RTN","CHM XWB21",137 0,0)
  39038       . F  S  X1=$O(^CH MPAY(HACCL M,CLTYPE,X 1)) Q:X1'= +X1  S X2= ^(X1,0) D
  39039   "RTN","CHM XWB21",137 1,0)
  39040       .. S X 3=$G(X3)+$ P(X2,"^",$ P(PIECE,"; "))
  39041   "RTN","CHM XWB21",137 2,0)
  39042       . I TO C="IPT" D   Q
  39043   "RTN","CHM XWB21",137 3,0)
  39044       .. S X 4=X3-$P($G (^CHMPAY(H ACCLM,1)), "^",7)
  39045   "RTN","CHM XWB21",137 4,0)
  39046       .. I $ FN(X4,"",2 )=$FN($P($ G(^CHMPAY( HACCLM,1)) ,"^"),"",2 ) K CLMOTH (HACCLM)
  39047   "RTN","CHM XWB21",137 5,0)
  39048       . I $F N(X3,"",2) =$FN($P($G (^CHMPAY(H ACCLM,1)), "^"),"",2)  K CLMOTH( HACCLM)
  39049   "RTN","CHM XWB21",137 6,0)
  39050       . Q
  39051   "RTN","CHM XWB21",137 7,0)
  39052       I $G(C LMOTH(HACC LM))'="" D
  39053   "RTN","CHM XWB21",137 8,0)
  39054       . S X1 =0,X3=0
  39055   "RTN","CHM XWB21",137 9,0)
  39056       . F  S  X1=$O(^CH MPAY(HACCL M,CLTYPE,X 1)) Q:X1'= +X1  S X2= ^(X1,0) D
  39057   "RTN","CHM XWB21",138 0,0)
  39058       .. S X 3=$G(X3)+$ P(X2,"^",$ P(PIECE,"; ",3))
  39059   "RTN","CHM XWB21",138 1,0)
  39060       . S X4 =X3-$P($G( ^CHMPAY(HA CCLM,1))," ^",7)
  39061   "RTN","CHM XWB21",138 2,0)
  39062       . I $F N(X4,"",2) =$FN($P($G (^CHMPAY(H ACCLM,1)), "^"),"",2)  S $P(PIEC E,";")=$P( PIECE,";", 3)
  39063   "RTN","CHM XWB21",138 3,0)
  39064       . Q
  39065   "RTN","CHM XWB21",138 4,0)
  39066       I $D(^ CHMXCLF(CH CLFI,70))  D  I $G(PR AMT)="" Q  XLN
  39067   "RTN","CHM XWB21",138 5,0)
  39068       . S NO CLOHI=1
  39069   "RTN","CHM XWB21",138 6,0)
  39070       . S CH CLF70=0 F   S CHCLF70 =$O(^CHMXC LF(CHCLFI, 70,CHCLF70 )) Q:CHCLF 70'=+CHCLF 70  D  I X LN'="" Q
  39071   "RTN","CHM XWB21",138 7,0)
  39072       .. S O HIPAY=$G(O HIPAY)+$P( $G(^(CHCLF 70,0)),"^" ,2)
  39073   "RTN","CHM XWB21",138 8,0)
  39074       .. S C HCLF101=0  F  S CHCLF 101=$O(^CH MXCLF(CHCL FI,70,CHCL F70,101,CH CLF101)) Q :CHCLF101' =+CHCLF101   D  I XLN '="" Q
  39075   "RTN","CHM XWB21",138 9,0)
  39076       ... S  DATA=$G(^( CHCLF101,0 ))
  39077   "RTN","CHM XWB21",139 0,0)
  39078       ... I  $P(DATA,"^ ")="PR" S  XLN=$P(DAT A,"^",3),S TOP=1,PRAM T=XLN Q
  39079   "RTN","CHM XWB21",139 1,0)
  39080       ... F  I=3:3:18 S  OHIADJ=$G (OHIADJ)+$ P(DATA,"^" ,I)
  39081   "RTN","CHM XWB21",139 2,0)
  39082       .. Q
  39083   "RTN","CHM XWB21",139 3,0)
  39084       . I $P ($G(CHRJAR R(1,1)),"* ")="F2" S  XLN=0
  39085   "RTN","CHM XWB21",139 4,0)
  39086       . I $G (STOP) Q
  39087   "RTN","CHM XWB21",139 5,0)
  39088       . S XL N=LICHRGA- $G(OHIPAY) -$G(OHIADJ )
  39089   "RTN","CHM XWB21",139 6,0)
  39090       . I XL N<0 S XLN= 0
  39091   "RTN","CHM XWB21",139 7,0)
  39092       . Q
  39093   "RTN","CHM XWB21",139 8,0)
  39094       S (X,X 1)=""
  39095   "RTN","CHM XWB21",139 9,0)
  39096       F  S X 1=$O(LNDAT A(CLNUM,HA CCLM,X1))  Q:X1=""  D
  39097   "RTN","CHM XWB21",140 0,0)
  39098       . S CL LD0=LNDATA (CLNUM,HAC CLM,X1)
  39099   "RTN","CHM XWB21",140 1,0)
  39100       . ;S P IECE=$S(TO C="DNT":"5 ;7;2",TOC= "DUR":"4;5 ;2",TOC="I PT":"2;2;2 ",TOC="OPT ":"3;5;2", TOC="RXT": "5;10;4",T OC="TRV":" 3;5;2",1:" ")
  39101   "RTN","CHM XWB21",140 2,0)
  39102       . ;I P IECE="" Q
  39103   "RTN","CHM XWB21",140 3,0)
  39104       . I $G (NOCLOHI)  K CLMOTH(H ACCLM)
  39105   "RTN","CHM XWB21",140 4,0)
  39106       . S XL N=$P(CLLD0 ,"^",$P(PI ECE,";"))
  39107   "RTN","CHM XWB21",140 5,0)
  39108       . ;I + $G(CLMOTH( HACCLM))>0 ,XLN'>$P($ G(^CHMPAY( HACCLM,1)) ,"^")
  39109   "RTN","CHM XWB21",140 6,0)
  39110       . ;I + $G(CLMOTH( HACCLM))>0 ,XLN>$P($G (^CHMPAY(H ACCLM,1)), "^")
  39111   "RTN","CHM XWB21",140 7,0)
  39112       . ;;TE ST I +$G(C LMOTH(HACC LM))>0,XLN >$P($G(^CH MPAY(HACCL M,1)),"^")  S XLN=$P( CLLD0,"^", $P(PIECE," ;",3))
  39113   "RTN","CHM XWB21",140 8,0)
  39114       . I +$ G(CLMOTH(H ACCLM))>0, $P(CLLD0," ^",$P(PIEC E,";",3))> XLN S XLN= $P(CLLD0," ^",$P(PIEC E,";",3))
  39115   "RTN","CHM XWB21",140 9,0)
  39116       . I $P (CLLD0,"^" ,$P(PIECE, ";",2))'=" " S XLN=$P (CLLD0,"^" ,$P(PIECE, ";",2))
  39117   "RTN","CHM XWB21",141 0,0)
  39118       . ;HAP E POR - ap ply cost s hare amoun t
  39119   "RTN","CHM XWB21",141 1,0)
  39120       . I $F N($G(CLMCO ST(HACCLM) ),"",2)>0  D
  39121   "RTN","CHM XWB21",141 2,0)
  39122       .. I C LMCOST(HAC CLM)>XLN S  CLMCOST(H ACCLM)=CLM COST(HACCL M)-XLN,XLN =0 Q
  39123   "RTN","CHM XWB21",141 3,0)
  39124       .. S X LN=XLN-CLM COST(HACCL M),CLMCOST (HACCLM)=0
  39125   "RTN","CHM XWB21",141 4,0)
  39126       . ;HAP E POR - ap ply deduct ible amoun t
  39127   "RTN","CHM XWB21",141 5,0)
  39128       . I $F N($G(CLMDE D(HACCLM)) ,"",2)>0,X LN>0 D
  39129   "RTN","CHM XWB21",141 6,0)
  39130       .. I C LMDED(HACC LM)>XLN S  CLMDED(HAC CLM)=CLMDE D(HACCLM)- XLN,XLN=0  Q
  39131   "RTN","CHM XWB21",141 7,0)
  39132       .. S X LN=XLN-CLM DED(HACCLM ),CLMDED(H ACCLM)=0
  39133   "RTN","CHM XWB21",141 8,0)
  39134       . I $F N($G(PATPA Y(HACCLM)) ,"",2)>0,X LN>0 D
  39135   "RTN","CHM XWB21",141 9,0)
  39136       .. I P ATPAY(HACC LM)>XLN S  PATPAY(HAC CLM)=PATPA Y(HACCLM)- XLN,XLN=0  Q
  39137   "RTN","CHM XWB21",142 0,0)
  39138       .. S X LN=XLN-PAT PAY(HACCLM ),PATPAY(H ACCLM)=0
  39139   "RTN","CHM XWB21",142 1,0)
  39140       . I $F N($G(CLMOT H(HACCLM)) ,"",2)>0,X LN>0 D
  39141   "RTN","CHM XWB21",142 2,0)
  39142       .. I C LMOTH(HACC LM)>XLN S  CLMOTH(HAC CLM)=CLMOT H(HACCLM)- XLN,XLN=0  Q
  39143   "RTN","CHM XWB21",142 3,0)
  39144       .. S X LN=XLN-CLM OTH(HACCLM ),CLMOTH(H ACCLM)=0
  39145   "RTN","CHM XWB21",142 4,0)
  39146       . S X= $G(X)+XLN
  39147   "RTN","CHM XWB21",142 5,0)
  39148       . I TO C="IPT" S  X=$G(IPTAM T(HACCLM,C HCLFI))
  39149   "RTN","CHM XWB21",142 6,0)
  39150       I $P(C HRJARR(1,1 ),"*")="F2 " S X="0.0 0"
  39151   "RTN","CHM XWB21",142 7,0)
  39152       I $G(P RAMT)'="", PRAMT<X D   Q PRAMT
  39153   "RTN","CHM XWB21",142 8,0)
  39154       . I $G (HACPAY(HA CCLM))'="" ,HACPAY(HA CCLM)'="ST OP" S HACP AY(HACCLM) =HACPAY(HA CCLM)-PRAM T I HACPAY (HACCLM)'> 0 S HACPAY (HACCLM)=" STOP"
  39155   "RTN","CHM XWB21",142 9,0)
  39156       I $G(H ACPAY(HACC LM))="STOP " S X=0
  39157   "RTN","CHM XWB21",143 0,0)
  39158       Q X
  39159   "RTN","CHM XWB21",143 1,0)
  39160       ;
  39161   "RTN","CHM XWB21",143 2,0)
  39162   LQTY(TOC,C LNUM,CHCLF 1,HACCLM,L NDATA) ; F INAL QUANT ITY - UNIT S OF SERVC E
  39163   "RTN","CHM XWB21",143 3,0)
  39164       N X2,P IECE,XLN,C LLD0,STOP
  39165   "RTN","CHM XWB21",143 4,0)
  39166       I HACC LM="" Q 0
  39167   "RTN","CHM XWB21",143 5,0)
  39168       S (X,X 2)=""
  39169   "RTN","CHM XWB21",143 6,0)
  39170       F  S X 2=$O(LNDAT A(CLNUM,HA CCLM,X2))  Q:X2=""  Q :$G(STOP)   D
  39171   "RTN","CHM XWB21",143 7,0)
  39172       . S CL LD0=LNDATA (CLNUM,HAC CLM,X2)
  39173   "RTN","CHM XWB21",143 8,0)
  39174       . S PI ECE=$S(TOC ="DNT":13, TOC="DUR": 11,TOC="IP T":4,TOC=" OPT":19,TO C="TRV":19 ,TOC="RXT" :15,1:"")
  39175   "RTN","CHM XWB21",143 9,0)
  39176       . S XL N=$P(CLLD0 ,"^",PIECE )
  39177   "RTN","CHM XWB21",144 0,0)
  39178       . I XL N="" S X=$ P(CHCLF1," ^",8),STOP =1 Q
  39179   "RTN","CHM XWB21",144 1,0)
  39180       . S X= X+XLN
  39181   "RTN","CHM XWB21",144 2,0)
  39182       Q X
  39183   "RTN","CHM XWB21",144 3,0)
  39184       ;
  39185   "RTN","CHM XWB21",144 4,0)
  39186       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  39187   "RTN","CHM XWB21",144 5,0)
  39188       ; DOCU MENTREC (U TILITY THA T HELPS IN  DOCUMENTI NG THE REC ORD GENERA TION PROCE SS) ;
  39189   "RTN","CHM XWB21",144 6,0)
  39190       ; CREA TES A FILE  THAT CONT AINS THE R ECORD INFO RMATION FO R THE 5010  ;
  39191   "RTN","CHM XWB21",144 7,0)
  39192       ; EMDE ON STATUS  RECORDS, I NCLUDING T HE HEADER,  CLAIM, LI NE ITEM, A ND TRAILER  ;
  39193   "RTN","CHM XWB21",144 8,0)
  39194       ; RECO RDS. THIS  FUNCTION U SES THE FI ELD DESCRI PTORS TO D OCUMENT EA CH FIELD I N ;
  39195   "RTN","CHM XWB21",144 9,0)
  39196       ; THE  RECORDS, I .E.: ;
  39197   "RTN","CHM XWB21",145 0,0)
  39198       ; 1) R ECORD NAME  ;
  39199   "RTN","CHM XWB21",145 1,0)
  39200       ; 2) S TARTING LO CATION IN  THE RECORD  ;
  39201   "RTN","CHM XWB21",145 2,0)
  39202       ; 3) L ENGTH (WID TH) OF THE  FIELD ;
  39203   "RTN","CHM XWB21",145 3,0)
  39204       ; 4) J USTIFICATI ON WITHIN  THE FIELD  ;
  39205   "RTN","CHM XWB21",145 4,0)
  39206       ; 5) T HE VALUE ( HARD CODED  FIELDS) O R THE CACH E FILELOCA TION FROM  WHICH THE  ;
  39207   "RTN","CHM XWB21",145 5,0)
  39208       ; VALU E IS RETRI EVED. ;
  39209   "RTN","CHM XWB21",145 6,0)
  39210       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  39211   "RTN","CHM XWB21",145 7,0)
  39212       ;
  39213   "RTN","CHM XWB21",145 8,0)
  39214   DOCUMENTRE C ;
  39215   "RTN","CHM XWB21",145 9,0)
  39216       N DOCF ILE,TMPIO, LN,HTABS,F TABS,RTYPE ,RNAME,CHT YPE,STR,CO LNMS
  39217   "RTN","CHM XWB21",146 0,0)
  39218       S RTYP E="EMDEONH DR^EMDEONC LM^EMDEONS TC^EMDEONT RLR^EMDEON LI" ; NAME S OF $TEXT  TABLES
  39219   "RTN","CHM XWB21",146 1,0)
  39220       S COLN MS="FIELD  NAME^USE^D ESC^PAD^JU ST^VALUE"   ; COLUMN  HEADER NAM ES
  39221   "RTN","CHM XWB21",146 2,0)
  39222       S HTAB S="35^39^4 5^50^57"                          ; HEADER  TAB STOPS  FOR THE FI ELD DESCRI PTIONS
  39223   "RTN","CHM XWB21",146 3,0)
  39224       S FTAB S="36^39^4 6^52^57"                          ; FIELD T AB STOPS F OR DESCRIP TIONS
  39225   "RTN","CHM XWB21",146 4,0)
  39226       S DOCP ATH="HAC_H FS$:[KERMI T.WEBMD]"
  39227   "RTN","CHM XWB21",146 5,0)
  39228       S DOCF ILE="DOC27 7_5010_"_D ATESTAMP_" .TXT"       ; STATUS  MAPPING DO CUMENTATIO N
  39229   "RTN","CHM XWB21",146 6,0)
  39230       S DOCF ILE=DOCPAT H_DOCFILE                         ; OUTPUT  THE $TEXT  TO A PRINT ABLE FILE
  39231   "RTN","CHM XWB21",146 7,0)
  39232       S FLAG =$$OFILE^C HMXWBUT(DO CFILE,"NWS ")
  39233   "RTN","CHM XWB21",146 8,0)
  39234       S TMPI O=$IO U DO CFILE
  39235   "RTN","CHM XWB21",146 9,0)
  39236       F CHTY PE=1:1 S R NAME=$P(RT YPE,"^",CH TYPE) Q:RN AME=""  D
  39237   "RTN","CHM XWB21",147 0,0)
  39238       .W !!, ?20,"HEALT H CARE CLE ARING HOUS E """,RNAM E,""" RECO RD DEFINIT IONS"  ; T ITLE
  39239   "RTN","CHM XWB21",147 1,0)
  39240       .W !,$ P(COLNMS," ^",1),?$P( HTABS,"^", 1),$P(COLN MS,"^",2), ?$P(HTABS, "^",2),$P( COLNMS,"^" ,3),?$P(HT ABS,"^",3) ,$P(COLNMS ,"^",4),?$ P(HTABS,"^ ",4),$P(CO LNMS,"^",5 ),?$P(HTAB S,"^",5),$ P(COLNMS," ^",6),?$P( HTABS,"^", 6),$P(COLN MS,"^",7)
  39241   "RTN","CHM XWB21",147 2,0)
  39242       .F LN= 1:1 S STR= $T(@RNAME+ LN) Q:STR[ "END OF RE CORD"  D    ; READ $T EXT DESCRI PTOR
  39243   "RTN","CHM XWB21",147 3,0)
  39244       ..W !, $P(STR,";" ,3),?$P(FT ABS,"^",1) ,$P(STR,"; ",10),?$P( FTABS,"^", 2),$P(STR, ";",8),?$P (FTABS,"^" ,3),$P(STR ,";",7),?$ P(FTABS,"^ ",4),$P(ST R,";",6),? $P(FTABS," ^",5),$P(S TR,";",4)
  39245   "RTN","CHM XWB21",147 4,0)
  39246       U TMPI O
  39247   "RTN","CHM XWB21",147 5,0)
  39248       D CLOS EFILE^CHMX WBUT(DOCFI LE) ; CLOS E CURRENT  FILE
  39249   "RTN","CHM XWB21",147 6,0)
  39250       Q
  39251   "RTN","CHM XWB21",147 7,0)
  39252       ;
  39253   "RTN","CHM XWB21",147 8,0)
  39254   CHECK(HACC LM,CHCLFI)  ;final ch eck for da te of serv ice, if ma tched, but  hac claim  status =  0
  39255   "RTN","CHM XWB21",147 9,0)
  39256       N SRVD T,SRVDT2
  39257   "RTN","CHM XWB21",148 0,0)
  39258       S SRVD T=$P(^CHMP AY(HACCLM, 0),"^",8), SRVDT2=$P( ^CHMXCLF(C HCLFI,1)," ^",11)
  39259   "RTN","CHM XWB21",148 1,0)
  39260       I SRVD T2'="" S S RVDT2=$S($ E(SRVDT2,1 ,2)=19:2_$ E(SRVDT2,3 ,8),1:3_$E (SRVDT2,3, 8))
  39261   "RTN","CHM XWB21",148 2,0)
  39262       I SRVD T2=""!(SRV DT="") Q 1
  39263   "RTN","CHM XWB21",148 3,0)
  39264       I SRVD T'=SRVDT2  Q 0
  39265   "RTN","CHM XWB21",148 4,0)
  39266       Q 1
  39267   "RTN","CHM XWB21",148 5,0)
  39268       ;
  39269   "RTN","CHM XWB21",148 6,0)
  39270   AGAIN ; ch eck to see  if lines  need to be  rechecked  with diff ernt units
  39271   "RTN","CHM XWB21",148 7,0)
  39272       S AGAI N=1,LN=$O( ^CHMPAY(HA CCLM,CLTYP E,0))
  39273   "RTN","CHM XWB21",148 8,0)
  39274       Q
  39275   "RTN","CHM XWB21",148 9,0)
  39276       ;
  39277   "RTN","CHM XWB21",149 0,0)
  39278   RESET ;HAP E POR - to  reset a f ile creati on to enab le claims  to be re-s ubmitted a s Final
  39279   "RTN","CHM XWB21",149 1,0)
  39280       N XA,X B,XT,XX,XT 1,ENDDATE, CT,X,RUNDA TE
  39281   "RTN","CHM XWB21",149 2,0)
  39282       K ^XTM P($J)
  39283   "RTN","CHM XWB21",149 3,0)
  39284       S %H=$ H-730 D YM D^%DTC S E NDDATE=X
  39285   "RTN","CHM XWB21",149 4,0)
  39286       S XA=" " F  S XA= $O(^CHMPAY ("E",XA),- 1) Q:XA=""   Q:$P(XA, ".")<ENDDA TE  D
  39287   "RTN","CHM XWB21",149 5,0)
  39288       . S XB ="" F  S X B=$O(^CHMP AY("E",XA, XB)) Q:XB= ""  D
  39289   "RTN","CHM XWB21",149 6,0)
  39290       .. ;02 /10/2014 S BB DEV0203 22
  39291   "RTN","CHM XWB21",149 7,0)
  39292       .. ;I  ^(XB)'=""  S ^XTMP($J ,^CHMPAY(" E",XA,XB)) =$G(^XTMP( $J,^CHMPAY ("E",XA,XB )))+1,^XTM P($J,^CHMP AY("E",XA, XB),XB)=XA
  39293   "RTN","CHM XWB21",149 8,0)
  39294       .. S R UNDATE=$P( ^CHMPAY(XB ,10),"^",2 3) I RUNDA TE'="" S ^ XTMP($J,RU NDATE)=$G( ^XTMP($J,R UNDATE))+1 ,^XTMP($J, RUNDATE,XB )=XA
  39295   "RTN","CHM XWB21",149 9,0)
  39296       .. Q
  39297   "RTN","CHM XWB21",150 0,0)
  39298       . Q
  39299   "RTN","CHM XWB21",150 1,0)
  39300   R0  ;S XA= "" F  S XA =$O(^XTMP( $J,XA)) Q: XA=""  S C T=$G(CT)+1 ,XT1(CT)=X A,%TN=$P($ P(XA,"#",2 ),",",2) D  ^%TO W !, CT,?5,$P(X A,"#"),?20 ,%TS,?30,^ XTMP($J,XA )," CLAIMS "
  39301   "RTN","CHM XWB21",150 2,0)
  39302    S XA="" F   S XA=$O( ^XTMP($J,X A)) Q:XA=" "  S CT=$G (CT)+1,XT1 (CT)=XA N  RDT S X=XA  D H^%DTC  S %TN=%T,R DT=%H D ^% TO W !,CT, ?5,$ZD(RDT ),?20,%TS, ?30,^XTMP( $J,XA)," C LAIMS"
  39303   "RTN","CHM XWB21",150 3,0)
  39304   R1  R !!," SELECT FIL E CREATION  TO RESET:  ",XX
  39305   "RTN","CHM XWB21",150 4,0)
  39306       I XX=" " Q
  39307   "RTN","CHM XWB21",150 5,0)
  39308       I '$D( XT1(XX)) W  *7,!,"Inv alid Entry .  Please  retry." G  R1
  39309   "RTN","CHM XWB21",150 6,0)
  39310       W !!," Resetting. .."
  39311   "RTN","CHM XWB21",150 7,0)
  39312       S XB=" " F  S XB= $O(^XTMP($ J,XT1(XX), XB)) Q:XB= ""  D
  39313   "RTN","CHM XWB21",150 8,0)
  39314       . S XA =^XTMP($J, XT1(XX),XB )
  39315   "RTN","CHM XWB21",150 9,0)
  39316       . I XA ="" Q
  39317   "RTN","CHM XWB21",151 0,0)
  39318       . ;02/ 10/2014 SB B DEV02032 2
  39319   "RTN","CHM XWB21",151 1,0)
  39320       . ;I $ D(^CHMPAY( "E",XA,XB) ) S ^CHMPA Y("E",XA,X B)=""
  39321   "RTN","CHM XWB21",151 2,0)
  39322       . I $D (^CHMPAY(" E",XA,XB))  S DR="10. 23///@",DI E="^CHMPAY (",DA=XB D  ^DIE
  39323   "RTN","CHM XWB21",151 3,0)
  39324       . Q
  39325   "RTN","CHM XWB21",151 4,0)
  39326       K ^XTM P($J,XT1(X X))
  39327   "RTN","CHM XWB21",151 5,0)
  39328       K XT1  S CT=0
  39329   "RTN","CHM XWB21",151 6,0)
  39330       G R0
  39331   "RTN","CHM XWB21",151 7,0)
  39332       Q
  39333   "RTN","CHM XWB21",151 8,0)
  39334       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  39335   "RTN","CHM XWB21",151 9,0)
  39336       ; EMDE ONHDR: Com mon Header  for EMDEO N STATUS F iles ;
  39337   "RTN","CHM XWB21",152 0,0)
  39338       ; A si ngle heade r is gener ated for e ach output  file. ;
  39339   "RTN","CHM XWB21",152 1,0)
  39340       ; DESC : "FIELD N AME";"LENG TH";"JUSTI FY FLAG";" PAD CHAR"; "DATA TYPE "; ;
  39341   "RTN","CHM XWB21",152 2,0)
  39342       ; FIEL D NAME: EM DEON File  FIELD DESC RIPTOR(rec ord # and  text descr iption) ;
  39343   "RTN","CHM XWB21",152 3,0)
  39344       ; LENG TH: EMDEON  FILE SPEC IFIED FIEL D WIDTH ;
  39345   "RTN","CHM XWB21",152 4,0)
  39346       ; JUST IFY FLAG:  L=LEFT, R= RIGHT, C=  CENTER ;
  39347   "RTN","CHM XWB21",152 5,0)
  39348       ; PAD:  PAD CHARA CTER TO BE  USED TO F ILL FIELD  WIDTH (ANY  PRINTABLE  CHARACTER ) ;
  39349   "RTN","CHM XWB21",152 6,0)
  39350       ; NOTE : PAD CHAR ="" IF NO  CHARACTER  IS BETWEEN  THE SEMIC OLONS (I.E . ;;) ;
  39351   "RTN","CHM XWB21",152 7,0)
  39352       ; NO P ADDING WIL L OCCUR IF  THIS IS S ET UP THIS  WAY ;
  39353   "RTN","CHM XWB21",152 8,0)
  39354       ; DATA  PATTERN:  PATTERN MA TCH DESCRI PTOR DESCR IBING THE  VALUE ;
  39355   "RTN","CHM XWB21",152 9,0)
  39356       ; FIEL D START LO CATION: LO CATION IN  RECORD FOR  THIS FIEL D-DOCUMENT ATION ONLY  ;
  39357   "RTN","CHM XWB21",153 0,0)
  39358       ; FIEL D USE: R=R EQUIRED, C =CONDITION AL, O=OPTI ONAL ;
  39359   "RTN","CHM XWB21",153 1,0)
  39360       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  39361   "RTN","CHM XWB21",153 2,0)
  39362       ; ;
  39363   "RTN","CHM XWB21",153 3,0)
  39364       ; FORM ATDATA TRE ATS THE PA D CHAR (;; ) AS A NUL L, SO NO P ADDING OCC URS. ;
  39365   "RTN","CHM XWB21",153 4,0)
  39366       ; THIS  WILL ALLO W USE OF T HE FORMATD ATA FUNCTI ON WITHOUT  MODIFICAT ION BETWEE N ;
  39367   "RTN","CHM XWB21",153 5,0)
  39368       ; PADD ED AND NON -PADDED FI ELDS. ;
  39369   "RTN","CHM XWB21",153 6,0)
  39370       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  39371   "RTN","CHM XWB21",153 7,0)
  39372       ; 8/4/ 11 DLB "6.  CREATION  TIME" FROM  $E(DATEST AMP,9,12)  TO $E(DATE STAMP,9,14 ) ;
  39373   "RTN","CHM XWB21",153 8,0)
  39374       ; 8/15 /11 DLB "2 . FILE GRO UP ID" INS ERTED THE  DATESTAMP  VALUE TO E NSURE UNIQ UENESS ;
  39375   "RTN","CHM XWB21",153 9,0)
  39376       ; 11/1 3/13 HAPE  POR - prob lem with u sing DATES TAMP for G ROUP ID
  39377   "RTN","CHM XWB21",154 0,0)
  39378       ;           Multi -file subm ission nee ds GROUPID  to be the  same in e ach file
  39379   "RTN","CHM XWB21",154 1,0)
  39380       ; 9/7/ 2011 DLB 1 2. LOAD TY PE CHANGED  TO PROVID E "F" WHEN  HISTORICA L FILE GEN ERATED ;
  39381   "RTN","CHM XWB21",154 2,0)
  39382       ;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  39383   "RTN","CHM XWB21",154 3,0)
  39384       ;  
  39385   "RTN","CHM XWB21",154 4,0)
  39386   EMDEONHDR  ;"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
  39387   "RTN","CHM XWB21",154 5,0)
  39388              ;;1.RECORD  ID;"HDR"; 3;L;;3AN;0 ;R;
  39389   "RTN","CHM XWB21",154 6,0)
  39390              ;;2.FILE G ROUP ID;GR OUPID;20;L ;;20AN;4;R ;
  39391   "RTN","CHM XWB21",154 7,0)
  39392              ;;3.FILE G ROUP SEQUE NCE NUMBER ;FILECNT;3 ;R;;3N;24; R;
  39393   "RTN","CHM XWB21",154 8,0)
  39394              ;;4.FILE G ROUP COUNT ;GRPCNT;3; R;;3N;26;R ;
  39395   "RTN","CHM XWB21",154 9,0)
  39396              ;;5.CREATI ON DATE;$E (DATESTAMP ,1,8);8;L; ;8AN;28;R;
  39397   "RTN","CHM XWB21",155 0,0)
  39398              ;;6.CREATI ON TIME;$E (DATESTAMP ,9,14);6;L ;;6N;36;R;
  39399   "RTN","CHM XWB21",155 1,0)
  39400              ;;7.TRADIN G PARTNER  ID;"VAFNH" ;10;L;;10A N;42;R;
  39401   "RTN","CHM XWB21",155 2,0)
  39402              ;;8.SUBMIT TER NAME;" VA, HEALTH  ADMIN CEN TER";30;L; ;30AN;53;R ;
  39403   "RTN","CHM XWB21",155 3,0)
  39404              ;;9.PAYER  CONTACT NA ME;PAYNAME ;60;L;;60A N;83;O;
  39405   "RTN","CHM XWB21",155 4,0)
  39406              ;;10.PAYER  SUPPORT T ELEPHONE N UMBER;PAYP HONE;10;L; ;10N;143;O ;
  39407   "RTN","CHM XWB21",155 5,0)
  39408              ;;11.PAYER  SUPPORT E MAIL ADDRE SS;"";80;L ;;80AN;153 ;O;
  39409   "RTN","CHM XWB21",155 6,0)
  39410              ;;12.LOAD  TYPE;LOADT YPE;1;L;;1 AN;233;R;
  39411   "RTN","CHM XWB21",155 7,0)
  39412              ;;13.PAYER  UNIQUE FI LE IDENTIF IER;DATEST AMP;20;L;; 20AN;234;R ;
  39413   "RTN","CHM XWB21",155 8,0)
  39414              ;;14.FILE  TYPE;"CSta t";5;L;;5A N;254;R;
  39415   "RTN","CHM XWB21",155 9,0)
  39416              ;;15.VERSI ON CODE;"0 3";2;L;;2A N;258;R;
  39417   "RTN","CHM XWB21",156 0,0)
  39418              ;;16.RELEA SE CODE;"0 0";2;L;;2A N;260;R;
  39419   "RTN","CHM XWB21",156 1,0)
  39420              ;;17.END O F RECORD;
  39421   "RTN","CHM XWB21",156 2,0)
  39422              ;     
  39423   "RTN","CHM XWB21",156 3,0)
  39424              ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;; 
  39425   "RTN","CHM XWB21",156 4,0)
  39426              ; EMDEON C LAIM lEVEL  STATUS TA BLE: Conta ins the De scriptions  for all d ata to be 
  39427   "RTN","CHM XWB21",156 5,0)
  39428              ; gathered  for E01 F ile. Used  by $TEXT t o gather a ll data &  set up for mat ;
  39429   "RTN","CHM XWB21",156 6,0)
  39430              ; Each rec ord is des cribed in  detail for  the follo wing Param eters: ;
  39431   "RTN","CHM XWB21",156 7,0)
  39432              ; This tab le is used  as a bloc k of data( a record)  for each c laim to be  processed . ;
  39433   "RTN","CHM XWB21",156 8,0)
  39434              ; Therefor e, separat ing this f rom the he ader and t railer tab les allows  multiple  ;
  39435   "RTN","CHM XWB21",156 9,0)
  39436              ; calls to  this tabl e. ; 
  39437   "RTN","CHM XWB21",157 0,0)
  39438              ;--------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ----;
  39439   "RTN","CHM XWB21",157 1,0)
  39440              ; FIELD NA ME;LENGTH; JUSTIFY FL AG;PAD CHA R;DATA TYP E; ;
  39441   "RTN","CHM XWB21",157 2,0)
  39442              ; FIELD NA ME: EMDEON  File FIEL D DESCRIPT OR ;
  39443   "RTN","CHM XWB21",157 3,0)
  39444              ; LENGTH:  EMDEON FIL E SPECIFIE D FIELD WI DTH ;
  39445   "RTN","CHM XWB21",157 4,0)
  39446              ; JUSTIFY  FLAG: L=LE FT, R=RIGH T ;
  39447   "RTN","CHM XWB21",157 5,0)
  39448              ; PAD: PAD  CHARACTER  TO BE USE D TO FILL  FIELD WIDT H ;
  39449   "RTN","CHM XWB21",157 6,0)
  39450              ; PATTERN:  PATTERN M ATCH DESCR IPTOR DESC RIBING THE  VALUE ;
  39451   "RTN","CHM XWB21",157 7,0)
  39452              ; FIELD ST ART LOCATI ON: LOCATI ON IN RECO RD FOR THI S FIELD-DO CUMENTATIO N ONLY ;
  39453   "RTN","CHM XWB21",157 8,0)
  39454              ; FIELD US E: R=REQUI RED, C=CON DITIONAL,  O=OPTIONAL  ;
  39455   "RTN","CHM XWB21",157 9,0)
  39456              ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  39457   "RTN","CHM XWB21",158 0,0)
  39458              ; 8/4/11 D LB "3. PAY ER ID" FRO M "VAHAC"  TO $$GETPA YID^CHMXWB 21(CHMXTPI ) ;
  39459   "RTN","CHM XWB21",158 1,0)
  39460              ; 8/5/11 D LB FIELDS  12,14,15:  TYPO FIXED  FOR PROVI DER INFO ( ADDED ^ TO  CHMXCLB)  ;
  39461   "RTN","CHM XWB21",158 2,0)
  39462              ; 8/5/11 D LB FIELD 4 1: CHANGED  INDEX FRO M ^CHMXCLE (I,100 TO  ^CHMXCLE(I ,0 ; 
  39463   "RTN","CHM XWB21",158 3,0)
  39464              ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  39465   "RTN","CHM XWB21",158 4,0)
  39466             
  39467   "RTN","CHM XWB21",158 5,0)
  39468   EMDEONCLM  ;"FIELD NA ME";"TARGE T VALUE";" LENGTH";"J USTIFY FLA G";"PAD CH AR";"DATA  LENGTH/PAT TERN";FIEL D START LO CATION";FI ELD USE
  39469   "RTN","CHM XWB21",158 6,0)
  39470              ;;1.RECORD  ID;"CLM"; 3;L;;3AN;0 ;R;
  39471   "RTN","CHM XWB21",158 7,0)
  39472              ;;2.RECORD  NUMBER;CO UNT;10;R;; 10AN;4;R;
  39473   "RTN","CHM XWB21",158 8,0)
  39474              ;;3.PAYER  ID;"VAHAC" ;5;L;;5AN; 14;R;
  39475   "RTN","CHM XWB21",158 9,0)
  39476              ;;4.MAINTE NANCE TYPE  CODE;$S($ G(FULL)=1: "030",$G(R UNTYPE)="F ":"021",$G (RUNTYPE)= "A":"021", $G(RUNTYPE )="P":"021 ",$G(RUNTY PE)="H":"0 30",1:"001 ");3;L;;3A N;19;R;
  39477   "RTN","CHM XWB21",159 0,0)
  39478              ;;5.BILLIN G PROVIDER  FEDERAL T AX ID;BPFT I;9;L;;9N; 22;C;
  39479   "RTN","CHM XWB21",159 1,0)
  39480              ;;6.BILLIN G PROVIDER  PAYER NUM BER;BPPN;5 0;L;;50AN; 31;C;
  39481   "RTN","CHM XWB21",159 2,0)
  39482              ;;7.BILLIN G PROVIDER  NATIONAL  ID;BPNID;1 0;L;;10N;8 1;C;
  39483   "RTN","CHM XWB21",159 3,0)
  39484              ;;8.BILLIN G PROVIDER  LAST NAME ;BPLNAME;6 0;L;;60AN; 91;C;
  39485   "RTN","CHM XWB21",159 4,0)
  39486              ;;9.BILLIN G PROVIDER  FIRST NAM E;BPFNAME; 35;L;;35AN ;151;O;
  39487   "RTN","CHM XWB21",159 5,0)
  39488              ;;10.BILLI NG PROVIDE R MIDDLE N AME;BPMNAM E;25;L;;25 AN;186;O;
  39489   "RTN","CHM XWB21",159 6,0)
  39490              ;;11.BILLI NG PROVIDE R NAME SUF FIX;BPNAME X;10;L;;10 AN;211;O;
  39491   "RTN","CHM XWB21",159 7,0)
  39492              ;;12.SERVI CE PROVIDE R FEDERAL  TAX ID;SPF TID;9;L;;9 N;221;C;
  39493   "RTN","CHM XWB21",159 8,0)
  39494              ;;13.SERVI CE PROVIDE R PAYER NU MBER;SPPN; 50;L;;50AN ;230;C;
  39495   "RTN","CHM XWB21",159 9,0)
  39496              ;;14.SERVI CE PROVIDE R NATIONAL  ID;SPNID; 10;L;;10N; 280;C;
  39497   "RTN","CHM XWB21",160 0,0)
  39498              ;;15.SERVI CE PROVIDE R LAST NAM E;SPLNAME; 60;L;;60AN ;290;C;
  39499   "RTN","CHM XWB21",160 1,0)
  39500              ;;16.SERVI CE PROVIDE R FIRST NA ME;SPFNAME ;35;L;;35A N;350;O;
  39501   "RTN","CHM XWB21",160 2,0)
  39502              ;;17.SERVI CE PROVIDE R MIDDLE N AME;SPMNAM E;25;L;;25 AN;385;O;
  39503   "RTN","CHM XWB21",160 3,0)
  39504              ;;18.SERVI CE PROVIDE R NAME SUF FIX;SPNAME X;10;L;;10 AN;410;O;
  39505   "RTN","CHM XWB21",160 4,0)
  39506              ;;19.EMPLO YER IDENTI FICATION N UMBER;EMPI DNUM;80;L; ;80AN;420; C;
  39507   "RTN","CHM XWB21",160 5,0)
  39508              ;;20.EMPLO YER NAME;E MPNAME;60; L;;60AN;50 0;C;
  39509   "RTN","CHM XWB21",160 6,0)
  39510              ;;21.SUBSC RIBER ID;S UBSCID;80; L;;80AN;58 0;C;
  39511   "RTN","CHM XWB21",160 7,0)
  39512              ;;22.SUBSC RIBER LAST  NAME;SUBL NAME;60;L; ;60AN;660; C;
  39513   "RTN","CHM XWB21",160 8,0)
  39514              ;;23.SUBSC RIBER FIRS T NAME;SUB FNAME;35;L ;;35AN;720 ;O;
  39515   "RTN","CHM XWB21",160 9,0)
  39516              ;;24.SUBSC RIBER MIDD LE NAME;SU BMNAME;25; L;;25AN;75 5;O;
  39517   "RTN","CHM XWB21",161 0,0)
  39518              ;;25.SUBSC RIBER NAME  SUFFIX;SU BNAMEX;10; L;;10AN;78 0;O;
  39519   "RTN","CHM XWB21",161 1,0)
  39520              ;;26.PATIE NT ID;PATI D;80;L;;80 AN;790;O; 
  39521   "RTN","CHM XWB21",161 2,0)
  39522              ;;27.PATIE NT LAST NA ME;PATLNAM E;60;L;;60 AN;870;R;
  39523   "RTN","CHM XWB21",161 3,0)
  39524              ;;28.PATIE NT FIRST N AME;PATFNA ME;35;L;;3 5AN;930;R;
  39525   "RTN","CHM XWB21",161 4,0)
  39526              ;;29.PATIE NT MIDDLE  NAME;PATMN AME;25;L;; 25AN;965;O ;
  39527   "RTN","CHM XWB21",161 5,0)
  39528              ;;30.PATIE NT NAME SU FFIX;PATNA MEX;10;L;; 10AN;990;O ;
  39529   "RTN","CHM XWB21",161 6,0)
  39530              ;;31.PATIE NT DATE OF  BIRTH;PAT DOB;8;L;;8 DT;1000;R;
  39531   "RTN","CHM XWB21",161 7,0)
  39532              ;;32.PATIE NT GENDER; PATGENDR;1 ;L;;1AN;10 08;O;
  39533   "RTN","CHM XWB21",161 8,0)
  39534              ;;33.EMDEO N CLAIM NU MBER;ECLMN UM;50;L;;5 0AN;1009;O ;
  39535   "RTN","CHM XWB21",161 9,0)
  39536              ;;34.CLAIM  CHARGE AM OUNT;CLMCH RG;18;L;;1 8N;1059;R;
  39537   "RTN","CHM XWB21",162 0,0)
  39538              ;;35.CLAIM  PYMT AMT; CLMPMT;18; R;;18N;107 7;C;
  39539   "RTN","CHM XWB21",162 1,0)
  39540              ;;36.CLAIM  ADJ/PAYME NT DATE;CA PD;8;L;;8D T;1095;C;
  39541   "RTN","CHM XWB21",162 2,0)
  39542              ;;37.CHECK /EFT DATE; CHKEFTDATE ;8;L;;8DT; 1103;O;
  39543   "RTN","CHM XWB21",162 3,0)
  39544              ;;38.CHECK /EFT NUMBE R;CHKEFTNU M;16;L;;16 AN;1111;O;
  39545   "RTN","CHM XWB21",162 4,0)
  39546              ;;39.BILL  TYPE;BTYPE ;3;L;;3AN; 1127;O;
  39547   "RTN","CHM XWB21",162 5,0)
  39548              ;;40.PAYER  CLAIM ID  NUMBER;PCI DNUM;50;L; ;50AN;1130 ;R;
  39549   "RTN","CHM XWB21",162 6,0)
  39550              ;;41.PATIE NT ACCOUNT  NUMBER;PA TACCT;50;L ;;50AN;118 0;O; 
  39551   "RTN","CHM XWB21",162 7,0)
  39552              ;;42.PHARM ACY PRESCR IPTION NUM BER;PRSCNU M;50;L;;50 AN;1230;O;
  39553   "RTN","CHM XWB21",162 8,0)
  39554              ;;43.VOUCH ER IDENTIF IER;VOUCHI D;50;L;;50 AN;1280;O;
  39555   "RTN","CHM XWB21",162 9,0)
  39556              ;;44.APP/L OCATION SY STEM ID;LO CSYSID;50; L;;50AN;13 30;O;
  39557   "RTN","CHM XWB21",163 0,0)
  39558              ;;45.GROUP  NUMBER;GR PNUM;50;L; ;50AN;1380 ;O;
  39559   "RTN","CHM XWB21",163 1,0)
  39560              ;;46.CLAIM  SERVICE D ATE START; CLMSTDT;8; L;;8DT;143 0;R;
  39561   "RTN","CHM XWB21",163 2,0)
  39562              ;;47.CLAIM  SERVICE D ATE END;CL MENDT;8;L; ;8DT;1438; R;
  39563   "RTN","CHM XWB21",163 3,0)
  39564              ;;48.END O F RECORD;
  39565   "RTN","CHM XWB21",163 4,0)
  39566              ;
  39567   "RTN","CHM XWB21",163 5,0)
  39568              ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;; 
  39569   "RTN","CHM XWB21",163 6,0)
  39570              ; EMDEON C LAIM STATU S RECORD D ETAIL: Con tains the  Descriptio ns for all  data to b e ; 
  39571   "RTN","CHM XWB21",163 7,0)
  39572              ; gathered  for Claim  level and  Line Leve l records.  Used by $ TEXT to ga ther all ;
  39573   "RTN","CHM XWB21",163 8,0)
  39574              ; data & s et up form at. ;
  39575   "RTN","CHM XWB21",163 9,0)
  39576              ; Each rec ord is des cribed in  detail for  the follo wing Param eters: ;
  39577   "RTN","CHM XWB21",164 0,0)
  39578              ; NOTE: ;
  39579   "RTN","CHM XWB21",164 1,0)
  39580              ; For each  CLM recor d, there m ust be at  least one  STC record . ;
  39581   "RTN","CHM XWB21",164 2,0)
  39582              ; For a si ngle CLM r ecord, The  following  is true a bout DTL r ecords: ;
  39583   "RTN","CHM XWB21",164 3,0)
  39584              ; 1) Payer  can send  any number  of DTL re cords (inc luding NON E) ;
  39585   "RTN","CHM XWB21",164 4,0)
  39586              ; 3) Each  DTL record  sent corr esponds to  Line Leve l info for  the CLM r ecord. ;
  39587   "RTN","CHM XWB21",164 5,0)
  39588              ; 4) For e ach DTL re cord sent,  there mus t be at le ast one ST C record.  ;
  39589   "RTN","CHM XWB21",164 6,0)
  39590              ;--------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ----;
  39591   "RTN","CHM XWB21",164 7,0)
  39592              ; FIELD NA ME;LENGTH; JUSTIFY FL AG;PAD CHA R;DATA TYP E; ;
  39593   "RTN","CHM XWB21",164 8,0)
  39594              ; FIELD NA ME: EMDEON  FILE FIEL D DESCRIPT OR ;
  39595   "RTN","CHM XWB21",164 9,0)
  39596              ; LENGTH:  EMDEON FIL E SPECIFIE D FIELD WI DTH ;
  39597   "RTN","CHM XWB21",165 0,0)
  39598              ; JUSTIFY  FLAG: L=LE FT, R=RIGH T ;
  39599   "RTN","CHM XWB21",165 1,0)
  39600              ; PAD: PAD  CHARACTER  TO BE USE D TO FILL  FIELD WIDT H ;
  39601   "RTN","CHM XWB21",165 2,0)
  39602              ; DATA PAT TERN: PATT ERN MATCH  DESCRIPTOR  DESCRIBIN G THE VALU E ;
  39603   "RTN","CHM XWB21",165 3,0)
  39604              ; FIELD ST ART LOCATI ON: LOCATI ON IN RECO RD FOR THI S FIELD-DO CUMENTATIO N ONLY ;
  39605   "RTN","CHM XWB21",165 4,0)
  39606              ; FIELD US E: R=REQUI RED, C=CON DITIONAL,  O=OPTIONAL  ;
  39607   "RTN","CHM XWB21",165 5,0)
  39608              ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  39609   "RTN","CHM XWB21",165 6,0)
  39610              ; 8/4/11 D LB "3. PAY ER ID" FRO M "VAHAC"  TO $$GETPA YID^CHMXWB 21(CHMXTPI ) ; 
  39611   "RTN","CHM XWB21",165 7,0)
  39612              ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;; 
  39613   "RTN","CHM XWB21",165 8,0)
  39614             
  39615   "RTN","CHM XWB21",165 9,0)
  39616   EMDEONSTC  ;"FIELD NA ME";"TARGE T VALUE";" LENGTH";"J USTIFY FLA G";"PAD CH AR";"DATA  PATTERN";F IELD START  LOCATION; FIELD USE
  39617   "RTN","CHM XWB21",166 0,0)
  39618              ;;1.RECORD  ID;"STC"; 3;L;;3AN;0 ;R;
  39619   "RTN","CHM XWB21",166 1,0)
  39620              ;;2.RECORD  NUMBER;CO UNT;10;R;; 10AN;3;R;
  39621   "RTN","CHM XWB21",166 2,0)
  39622              ;;3.PAYER  ID;"VAHAC" ;5;L;;5AN; 13;R;
  39623   "RTN","CHM XWB21",166 3,0)
  39624              ;;4.PAYER  CLAIM ID N UMBER;PCIN UM;50;L;;5 0AN;18;R;
  39625   "RTN","CHM XWB21",166 4,0)
  39626              ;;5.LINE I TEM CONTRO L NUMBER;L ICNUM;50;L ;;50AN;68; O;
  39627   "RTN","CHM XWB21",166 5,0)
  39628              ;;6.STATUS  INFORMATI ON EFF. DA TE;DATESTA MP;14;L;;1 4N;118;R;
  39629   "RTN","CHM XWB21",166 6,0)
  39630              ;;7.CLAIM  STATUS CAT EGORY CODE ;RJCODE;3; L;;3AN;126 ;R;
  39631   "RTN","CHM XWB21",166 7,0)
  39632              ;;8.CLAIM  STATUS COD E;RJSTATUS ;3;L;;3AN; 129;R;
  39633   "RTN","CHM XWB21",166 8,0)
  39634              ;;9.ENTITY  CODE;ENTI TY;3;L;;3A N;132;O;
  39635   "RTN","CHM XWB21",166 9,0)
  39636              ;;10.DATA  IN ERROR;D ATERR;264; L;;264AN;1 35;O;
  39637   "RTN","CHM XWB21",167 0,0)
  39638              ;;11.EMDEO N STATUS C ODE;ESCODE ;5;L;;5AN; 399;O;
  39639   "RTN","CHM XWB21",167 1,0)
  39640              ;;12.END O F RECORD;
  39641   "RTN","CHM XWB21",167 2,0)
  39642              ;   
  39643   "RTN","CHM XWB21",167 3,0)
  39644              ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  39645   "RTN","CHM XWB21",167 4,0)
  39646              ; EMDEONTR LR: Common  Trailer f or EMDEON  Status Fil es ;
  39647   "RTN","CHM XWB21",167 5,0)
  39648              ; NOTE: a  single tra iler recor d is gener ated for e ach output  file. ;
  39649   "RTN","CHM XWB21",167 6,0)
  39650              ; FIELD NA ME;LENGTH; JUSTIFY FL AG;PAD CHA R;DATA TYP E; ;
  39651   "RTN","CHM XWB21",167 7,0)
  39652              ; FIELD NA ME: 277 Fi le FIELD D ESCRIPTOR  ;
  39653   "RTN","CHM XWB21",167 8,0)
  39654              ; LENGTH:  277 FILE S PECIFIED F IELD WIDTH  ;
  39655   "RTN","CHM XWB21",167 9,0)
  39656              ; JUSTIFY  FLAG: L=LE FT, R=RIGH T ;
  39657   "RTN","CHM XWB21",168 0,0)
  39658              ; PAD: PAD  CHARACTER  TO BE USE D TO FILL  FIELD WIDT H ;
  39659   "RTN","CHM XWB21",168 1,0)
  39660              ; DATA PAT TERN: PATT ERN MATCH  DESCRIPTOR  DESCRIBIN G THE VALU E ;
  39661   "RTN","CHM XWB21",168 2,0)
  39662              ; FIELD ST ART LOCATI ON: LOCATI ON IN RECO RD FOR THI S FIELD-DO CUMENTATIO N ONLY ;
  39663   "RTN","CHM XWB21",168 3,0)
  39664              ; FIELD US E: R=REQUI RED, C=CON DITIONAL,  O=OPTIONAL  ;
  39665   "RTN","CHM XWB21",168 4,0)
  39666              ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;
  39667   "RTN","CHM XWB21",168 5,0)
  39668              ;     
  39669   "RTN","CHM XWB21",168 6,0)
  39670   EMDEONTRLR  ;"FIELD N AME";"TARG ET VALUE"; "LENGTH";" JUSTIFY FL AG";"PAD C HAR";"DATA  PATTERN"; FIELD STAR T LOCATION ;FIELD USE
  39671   "RTN","CHM XWB21",168 7,0)
  39672               ;;1.RECOR D ID;"TRLR ";4;L;;4AN ;0;R;
  39673   "RTN","CHM XWB21",168 8,0)
  39674               ;;2.RECOR D COUNT;CO UNT;10;R;; 10N;4;R;
  39675   "RTN","CHM XWB21",168 9,0)
  39676               ;;3.END O F RECORD; 
  39677   "RTN","CHM XWB21",169 0,0)
  39678               ;                     
  39679   "RTN","CHM XWB21",169 1,0)
  39680               ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;; 
  39681   "RTN","CHM XWB21",169 2,0)
  39682               ; EMDEON  LINE LEVEL  STATUS TA BLE: Conta ins the De scriptions  for all d ata to be 
  39683   "RTN","CHM XWB21",169 3,0)
  39684               ; gathere d for CRF  File. Used  by $TEXT  to gather  all data &  set up fo rmat ;
  39685   "RTN","CHM XWB21",169 4,0)
  39686               ; Each re cord is de scribed in  detail fo r the foll owing Para meters: ;
  39687   "RTN","CHM XWB21",169 5,0)
  39688               ; NOTE: t here may b e multiple  line item s for each  claim rec ord. This  table ;
  39689   "RTN","CHM XWB21",169 6,0)
  39690               ; defines  the recor d to be ge nerated fo r each lin e item. ; 
  39691   "RTN","CHM XWB21",169 7,0)
  39692               ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- -----;
  39693   "RTN","CHM XWB21",169 8,0)
  39694               ; FIELD N AME;LENGTH ;JUSTIFY F LAG;PAD CH AR;DATA TY PE; ;
  39695   "RTN","CHM XWB21",169 9,0)
  39696               ; FIELD N AME: EMDEO N FILE FIE LD DESCRIP TOR ;
  39697   "RTN","CHM XWB21",170 0,0)
  39698               ; LENGTH:  EMDEON FI LE SPECIFI ED FIELD W IDTH ;
  39699   "RTN","CHM XWB21",170 1,0)
  39700               ; JUSTIFY  FLAG: L=L EFT, R=RIG HT ;
  39701   "RTN","CHM XWB21",170 2,0)
  39702               ; PAD: PA D CHARACTE R TO BE US ED TO FILL  FIELD WID TH ;
  39703   "RTN","CHM XWB21",170 3,0)
  39704               ; DATA PA TTERN: PAT TERN MATCH  DESCRIPTO R DESCRIBI NG THE VAL UE ;
  39705   "RTN","CHM XWB21",170 4,0)
  39706               ; FIELD S TART LOCAT ION: LOCAT ION IN REC ORD FOR TH IS FIELD-D OCUMENTATI ON ONLY ;
  39707   "RTN","CHM XWB21",170 5,0)
  39708               ; FIELD U SE: R=REQU IRED, C=CO NDITIONAL,  O=OPTIONA L ;
  39709   "RTN","CHM XWB21",170 6,0)
  39710               ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  39711   "RTN","CHM XWB21",170 7,0)
  39712               ;  
  39713   "RTN","CHM XWB21",170 8,0)
  39714   EMDEONLI ; "FIELD NAM E";"TARGET  VALUE";"L ENGTH";"JU STIFY FLAG ";"PAD CHA R";"DATA P ATTERN";FI ELD START  LOCATION;F IELD USE
  39715   "RTN","CHM XWB21",170 9,0)
  39716            ; ;1.RECORD  ID;"DTL";3 ;L;;3AN;0; R;
  39717   "RTN","CHM XWB21",171 0,0)
  39718            ; ;2.RECORD  NUMBER;COU NT;10;R;;1 0AN;4;R;
  39719   "RTN","CHM XWB21",171 1,0)
  39720            ; ;3.PAYER I D;"VAHAC"; 5;L;;5AN;1 4;R;
  39721   "RTN","CHM XWB21",171 2,0)
  39722            ; ;4.PAYER C LAIM ID NU MBER;PCID; 50;L;;50AN ;19;R;
  39723   "RTN","CHM XWB21",171 3,0)
  39724            ; ;5.LINE IT EM CONTROL  NUMBER;LI CN;50;L;;5 0AN;69;R;
  39725   "RTN","CHM XWB21",171 4,0)
  39726            ; ;6.SERVICE  QUALIFIER  ID;SQID;2 ;L;;2AN;11 9;R;
  39727   "RTN","CHM XWB21",171 5,0)
  39728            ; ;7.SERVICE  IDENTIFIC ATION CODE ;SICODE;48 ;L;;48AN;1 21;R;
  39729   "RTN","CHM XWB21",171 6,0)
  39730            ; ;8.PROCEDU RE MODIFIE R 1;PRCM1; 2;L;;2AN;1 31;O;
  39731   "RTN","CHM XWB21",171 7,0)
  39732            ; ;9.PROCEDU RE MODIFIE R 2;PRCM2; 2;L;;2AN;1 33;O;
  39733   "RTN","CHM XWB21",171 8,0)
  39734            ; ;10.PROCED URE MODIFI ER 3;PRCM3 ;2;L;;2AN; 135;O;
  39735   "RTN","CHM XWB21",171 9,0)
  39736            ; ;11.PROCED URE MODIFI ER 4;PRCM4 ;2;L;;2AN; 137;O;
  39737   "RTN","CHM XWB21",172 0,0)
  39738            ; ;12.LI CHA RGE AMOUNT ;LICHRGA;1 8;L;;18N;1 39;R;
  39739   "RTN","CHM XWB21",172 1,0)
  39740            ; ;13.LINE I TEM PROV.  PAYMENT AM OUNT;LIPPA ;18;L;;18N ;157;R;
  39741   "RTN","CHM XWB21",172 2,0)
  39742            ; ;14.REVENU E CODE;RVN UCODE;48;L ;;48AN;175 ;C;
  39743   "RTN","CHM XWB21",172 3,0)
  39744            ; ;15.QUANTI TY(UNITS O F SERVICE) ;QTYUOS;15 ;L;;15N;22 3;O;
  39745   "RTN","CHM XWB21",172 4,0)
  39746            ; ;16.EMDEON  CLAIM NUM BER;ECLMNU M;50;L;;50 AN;238;O;
  39747   "RTN","CHM XWB21",172 5,0)
  39748            ; ;17.SRVC S TART DATE; SVCSTDATE; 8;L;;8N;28 8;R;
  39749   "RTN","CHM XWB21",172 6,0)
  39750            ; ;18.SRVC E ND DATE;SV CENDATE;8; L;;8N;306; R;
  39751   "RTN","CHM XWB21",172 7,0)
  39752            ; ;19.END OF  RECORD;
  39753   "RTN","CHM XWB24")
  39754   0^66^B1987 79379
  39755   "RTN","CHM XWB24",1,0 )
  39756   CHMXWB24 ; HAC/JWS;WE B 5010 277  ;06/11/13
  39757   "RTN","CHM XWB24",2,0 )
  39758    ;;1.0;CHA MPVA SYSTE M;**003**; JULY 11,20 11;Build 5
  39759   "RTN","CHM XWB24",3,0 )
  39760    ;; 8/7/13  JWS:HARRI S - HAPE P OR DO#118- 11-D-1009,  TO#118-10 09-0001
  39761   "RTN","CHM XWB24",4,0 )
  39762    ;;V1.0;
  39763   "RTN","CHM XWB24",5,0 )
  39764    ;; 01/18/ 2018 CFS C PE005-043  - Look for  Reopen Re ject Reaso ns and ove rride 
  39765   "RTN","CHM XWB24",6,0 )
  39766    ;;                 C HRJARR(1,1 ) with app ropriate e rror code.
  39767   "RTN","CHM XWB24",7,0 )
  39768    Q
  39769   "RTN","CHM XWB24",8,0 )
  39770   CHECK ; HA PE POR
  39771   "RTN","CHM XWB24",9,0 )
  39772       ; CHEC K TO SEE I F X12 837  BUFFER SER VICE LINE  LEVEL FILE
  39773   "RTN","CHM XWB24",10, 0)
  39774       ; CAN  BE USED IN  CONJUNCTI ON WITH CH MPAY FILE
  39775   "RTN","CHM XWB24",11, 0)
  39776       ; IF N OT, THEN C HMPAY FILE  MUST BE U SED TO BUI LD LINE RE CORDS
  39777   "RTN","CHM XWB24",12, 0)
  39778       N LN,L NDATA1,LND ATA2,OK,TO C,LD,CHCLF I
  39779   "RTN","CHM XWB24",13, 0)
  39780       N SERV LN,CLTYPE, PROCAMT,PR OCCODE,PIE CE
  39781   "RTN","CHM XWB24",14, 0)
  39782       N PROC INT,PROCUN IT,ORGCAMT ,IPTOHI,IP TAMT,CLMOT H,CLMCOST, CLMDED
  39783   "RTN","CHM XWB24",15, 0)
  39784       N HACC LM,AGAIN,C HCLFI,CHEC K,PATPAY
  39785   "RTN","CHM XWB24",16, 0)
  39786       N OK1
  39787   "RTN","CHM XWB24",17, 0)
  39788       S HACC LM="" F  S  HACCLM=$O (^CHMXCLE( CHCLEI,80, "B",HACCLM )) Q:HACCL M=""  D
  39789   "RTN","CHM XWB24",18, 0)
  39790       . I $P ($G(^CHMPA Y(HACCLM,1 )),"^",7)' ="" S CLMO TH(HACCLM) =$P(^(1)," ^",7)
  39791   "RTN","CHM XWB24",19, 0)
  39792       . I $P ($G(^CHMPA Y(HACCLM,1 )),"^",6)' ="" S CLMC OST(HACCLM )=$P(^(1), "^",6)
  39793   "RTN","CHM XWB24",20, 0)
  39794       . I $P ($G(^CHMPA Y(HACCLM,1 )),"^",5)' ="" S CLMD ED(HACCLM) =$P(^(1)," ^",5)
  39795   "RTN","CHM XWB24",21, 0)
  39796       . I $P ($G(^CHMPA Y(HACCLM,1 )),"^",15) '="" S PAT PAY(HACCLM )=$P(^(1), "^",15)
  39797   "RTN","CHM XWB24",22, 0)
  39798       ; CP&E  Claims pr ocessing s oftware sp lit origin al claim l ines
  39799   "RTN","CHM XWB24",23, 0)
  39800       S (AGA IN,CHCLFI) =0
  39801   "RTN","CHM XWB24",24, 0)
  39802       F  S C HCLFI=$O(^ CHMXCLF("B ",CHCLEI,C HCLFI)) Q: CHCLFI=""   S CHECK=0  D
  39803   "RTN","CHM XWB24",25, 0)
  39804       . ;HAP E POR - if  no charge  amount, t hen skip S ERVICE LIN E LEVEL en try
  39805   "RTN","CHM XWB24",26, 0)
  39806       . ; In  order to  properly r eport fina l claim st atus, orig inal 837
  39807   "RTN","CHM XWB24",27, 0)
  39808       . ; cl aim must b e put back  together  with CHAMP VA Claims.
  39809   "RTN","CHM XWB24",28, 0)
  39810       . ; Si nce there  is no dire ct link, t hen a logi cal proces s needs
  39811   "RTN","CHM XWB24",29, 0)
  39812       . ; to  be used t o associat e each X12  837 BUFFE R SERVICE  LINE entry
  39813   "RTN","CHM XWB24",30, 0)
  39814       . ; wi th the ass ociated ^C HMPAY clai ms entries .
  39815   "RTN","CHM XWB24",31, 0)
  39816       . ; If  already m atched, sk ip
  39817   "RTN","CHM XWB24",32, 0)
  39818       . I $D (LNDATA2(C HCLFI)) Q
  39819   "RTN","CHM XWB24",33, 0)
  39820       . Q:$P ($G(^CHMXC LF(CHCLFI, 1)),"^",6) =""
  39821   "RTN","CHM XWB24",34, 0)
  39822       . S SE RVLN=$P(^C HMXCLF(CHC LFI,0),"^" ,2)
  39823   "RTN","CHM XWB24",35, 0)
  39824       . S PR OCCODE=$P( ^CHMXCLF(C HCLFI,1)," ^",3),PROC AMT=$P(^(1 ),"^",6),O RGCAMT=""
  39825   "RTN","CHM XWB24",36, 0)
  39826       . S PR OCUNIT=$FN ($P(^(1)," ^",8)+.49, "",0)
  39827   "RTN","CHM XWB24",37, 0)
  39828       . I PR OCCODE'=""  S PROCINT =$O(^CHMSE RV("B",PRO CCODE,""))
  39829   "RTN","CHM XWB24",38, 0)
  39830       . I PR OCUNIT=""  S PROCUNIT =1
  39831   "RTN","CHM XWB24",39, 0)
  39832       . I PR OCUNIT>1 S  ORGCAMT=P ROCAMT,PRO CAMT=PROCA MT/PROCUNI T
  39833   "RTN","CHM XWB24",40, 0)
  39834       . S HA CCLM="" F   S HACCLM= $O(^CHMXCL E(CHCLEI,8 0,"B",HACC LM)) Q:HAC CLM=""  D   Q:$G(OK)
  39835   "RTN","CHM XWB24",41, 0)
  39836       .. S T OC=$$TOS^C H835FU1($P ($G(^CHMPA Y(HACCLM,0 )),"^",7))
  39837   "RTN","CHM XWB24",42, 0)
  39838       .. I T OC="IPT" D
  39839   "RTN","CHM XWB24",43, 0)
  39840       ... S  PROCUNIT=1 ,PROCAMT=$ P(^CHMXCLF (CHCLFI,1) ,"^",6)
  39841   "RTN","CHM XWB24",44, 0)
  39842       ... I  $G(IPTOHI( HACCLM))=" " S IPTOHI (HACCLM)=$ P($G(^CHMP AY(HACCLM, 1)),"^",7)
  39843   "RTN","CHM XWB24",45, 0)
  39844       ... I  '$D(^CHMPA Y(HACCLM," INP-ITEM") ),$G(IPTAM T(HACCLM)) ="" S IPTA MT(HACCLM) =$P($G(^CH MPAY(HACCL M,1)),"^", 14)
  39845   "RTN","CHM XWB24",46, 0)
  39846       .. S C LTYPE=$S(T OC="IPT":" INP-REV",T OC="OPT":" OPT-PROC", TOC="RXT": "PHARM",TO C="DUR":"D ME-SUPPLY" ,TOC="DNT" :"DEN-PROC ",TOC="TRV ":"OPT-PRO C",1:"OPT- PROC")
  39847   "RTN","CHM XWB24",47, 0)
  39848       .. S P IECE=$S(TO C="DNT":"1 ;2;5",TOC= "DUR":"1;2 ;4",TOC="I PT":"1;2;5 ",TOC="OPT ":"1;2;3", TOC="RXT": "2;4;5",TO C="TRV":"1 ;2;3",1:"" )
  39849   "RTN","CHM XWB24",48, 0)
  39850       .. I P IECE="" Q
  39851   "RTN","CHM XWB24",49, 0)
  39852       .. ;HA PE POR - A GAIN flag  is used to  decrease  the matchi ng require ment after  the 1st p ass.
  39853   "RTN","CHM XWB24",50, 0)
  39854       .. S ( AGAIN,LN,O K)=0 F  S  LN=$O(^CHM PAY(HACCLM ,CLTYPE,LN )) D:'LN&( 'AGAIN) AG AIN^CHMXWB 21  Q:'LN   S LD=$G(^ (LN,0)) D   Q:OK
  39855   "RTN","CHM XWB24",51, 0)
  39856       ... ;  HAPE POR -  if X12 83 7 BUFFER S ERVICE LIN E LEVEL en try
  39857   "RTN","CHM XWB24",52, 0)
  39858       ... ;  is alreay  mapped to  a CHAMPVA  CLAIM, ski p it.
  39859   "RTN","CHM XWB24",53, 0)
  39860       ... I  TOC="OPT", $L(LD,"^") '>3 Q  ;HA PE POR for  incomplet e line inf o
  39861   "RTN","CHM XWB24",54, 0)
  39862       ... I  $D(LNDATA1 (HACCLM,LN )) Q
  39863   "RTN","CHM XWB24",55, 0)
  39864       ... I  $P(LD,"^", $P(PIECE," ;"))=$G(PR OCINT),$FN ($P(LD,"^" ,$P(PIECE, ";",2)),"" ,2)=$FN(PR OCAMT,"",2 ) S OK=$S( $G(CHECK): $$CHECK^CH MXWB21(HAC CLM,CHCLFI ),1:1) Q
  39865   "RTN","CHM XWB24",56, 0)
  39866       ... I  AGAIN,$G(O RGCAMT),PR OCUNIT>1,$ FN($P(LD," ^",$P(PIEC E,";",2)), "",2)'>$FN (ORGCAMT," ",2) D
  39867   "RTN","CHM XWB24",57, 0)
  39868       .... I  $FN($P(LD ,"^",$P(PI ECE,";",2) ),"",2)="0 .00" Q
  39869   "RTN","CHM XWB24",58, 0)
  39870       .... I  '$F(ORGCA MT/$P(LD," ^",$P(PIEC E,";",2)), ".") S PRO CAMT=$P(LD ,"^",$P(PI ECE,";",2) ),PROCUNIT =ORGCAMT/P ROCAMT S O K=$S($G(CH ECK):$$CHE CK^CHMXWB2 1(HACCLM,C HCLFI),1:1 ) Q
  39871   "RTN","CHM XWB24",59, 0)
  39872       ... I  AGAIN,$FN( $P(LD,"^", $P(PIECE," ;",2)),"", 2)=$FN(PRO CAMT,"",2) ,$O(^CHMPA Y(HACCLM,C LTYPE,LN)) ="" S OK=$ S($G(CHECK ):$$CHECK^ CHMXWB21(H ACCLM,CHCL FI),1:1) Q
  39873   "RTN","CHM XWB24",60, 0)
  39874       ... I  AGAIN,$P(L D,"^",$P(P IECE,";")) =$G(PROCIN T),$O(^CHM PAY(HACCLM ,CLTYPE,LN ))="",$D(L NDATA1(HAC CLM)) S OK =$S($G(CHE CK):$$CHEC K^CHMXWB21 (HACCLM,CH CLFI),1:1)  Q
  39875   "RTN","CHM XWB24",61, 0)
  39876       ... I  AGAIN,$FN( $P(LD,"^", $P(PIECE," ;",2)),"", 2)=$FN(PRO CAMT,"",2)  S OK=$S($ G(CHECK):$ $CHECK^CHM XWB21(HACC LM,CHCLFI) ,1:1) Q
  39877   "RTN","CHM XWB24",62, 0)
  39878       ... I  $G(ORGCAMT ),$FN($P(L D,"^",$P(P IECE,";",2 )),"",2)=$ FN(ORGCAMT ,"",2) S O K=$S($G(CH ECK):$$CHE CK^CHMXWB2 1(HACCLM,C HCLFI),1:1 ),PROCUNIT =1 Q
  39879   "RTN","CHM XWB24",63, 0)
  39880       ... I  TOC="IPT", $FN($P(LD, "^",$P(PIE CE,";",2)) ,"",2)=$FN (PROCAMT," ",2) D  S  OK=$S($G(C HECK):$$CH ECK^CHMXWB 21(HACCLM, CHCLFI),1: 1) Q
  39881   "RTN","CHM XWB24",64, 0)
  39882       .... I  $G(IPTOHI (HACCLM))> PROCAMT S  IPTOHI(HAC CLM,CHCLFI )=PROCAMT, IPTOHI(HAC CLM)=IPTOH I(HACCLM)- PROCAMT Q
  39883   "RTN","CHM XWB24",65, 0)
  39884       .... S  IPTOHI(HA CCLM,CHCLF I)=IPTOHI( HACCLM),IP TOHI(HACCL M)=0
  39885   "RTN","CHM XWB24",66, 0)
  39886       .. I L N'=+LN Q
  39887   "RTN","CHM XWB24",67, 0)
  39888       .. I O K,$P(^CHMP AY(HACCLM, 0),"^",2)' =4 S OK=$$ CHECK^CHMX WB21(HACCL M,CHCLFI)  I OK S CHE CK=1 S OK= 0
  39889   "RTN","CHM XWB24",68, 0)
  39890       .. ;HA PE POR 7/1 6/13 - PRO BLEM FOUND  WITH MULT IPLE CHMPA Y ENTRIES  FOR THE SA ME LINE,US E MOST REC ENT
  39891   "RTN","CHM XWB24",69, 0)
  39892       .. S L NDATA2(CHC LFI)="",LN DATA1(HACC LM,LN)=""
  39893   "RTN","CHM XWB24",70, 0)
  39894       .. S C LMCHRG=CLM CHRG-PROCA MT
  39895   "RTN","CHM XWB24",71, 0)
  39896       .. I P ROCUNIT>1  D
  39897   "RTN","CHM XWB24",72, 0)
  39898       ... S  PROCUNIT=P ROCUNIT-1, OK1=0  ;;; ,PROCUNIT= $FN(PROCUN IT+.49,"", 0)
  39899   "RTN","CHM XWB24",73, 0)
  39900       ... F  I=1:1:PROC UNIT S LN= $O(^CHMPAY (HACCLM,CL TYPE,LN))  Q:'LN  S L D=$G(^(LN, 0)) D
  39901   "RTN","CHM XWB24",74, 0)
  39902       .... S  ORGCAMT=O RGCAMT-PRO CAMT
  39903   "RTN","CHM XWB24",75, 0)
  39904       .... I  ORGCAMT<P ROCAMT S P ROCAMT=ORG CAMT
  39905   "RTN","CHM XWB24",76, 0)
  39906       .... I  ORGCAMT<( PROCAMT+.0 5) S PROCA MT=ORGCAMT
  39907   "RTN","CHM XWB24",77, 0)
  39908       .... I  $P(LD,"^" ,$P(PIECE, ";"))=$G(P ROCINT),$F N($P(LD,"^ ",$P(PIECE ,";",2))," ",2)=$FN(P ROCAMT,"", 2) D  Q
  39909   "RTN","CHM XWB24",78, 0)
  39910       .....  S LNDATA1( HACCLM,LN) ="",OK1=1
  39911   "RTN","CHM XWB24",79, 0)
  39912       .... I  I=PROCUNI T,$P(LD,"^ ",$P(PIECE ,";"))=$G( PROCINT) D   Q
  39913   "RTN","CHM XWB24",80, 0)
  39914       .....  S LNDATA1( HACCLM,LN) ="",OK1=1
  39915   "RTN","CHM XWB24",81, 0)
  39916       .... I  $FN($P(LD ,"^",$P(PI ECE,";",2) ),"",2)=$F N(PROCAMT, "",2) D  Q
  39917   "RTN","CHM XWB24",82, 0)
  39918       .....  S LNDATA1( HACCLM,LN) ="",OK1=1
  39919   "RTN","CHM XWB24",83, 0)
  39920       .... I  $FN($P(LD ,"^",$P(PI ECE,";",2) ),"",2)=$F N(PROCAMT- .005,"",2)  D  Q
  39921   "RTN","CHM XWB24",84, 0)
  39922       .....  S LNDATA1( HACCLM,LN) ="",OK1=1
  39923   "RTN","CHM XWB24",85, 0)
  39924       .... Q
  39925   "RTN","CHM XWB24",86, 0)
  39926       ... I  'OK1 K LND ATA2(CHCLF I)
  39927   "RTN","CHM XWB24",87, 0)
  39928       ... Q
  39929   "RTN","CHM XWB24",88, 0)
  39930       .. Q
  39931   "RTN","CHM XWB24",89, 0)
  39932       . Q
  39933   "RTN","CHM XWB24",90, 0)
  39934       ; HAPE  POR - if  all of the  X12 837 B UFFER SERV ICE LINE L EVEL entri es could n ot be matc hed with ^ CHMPAY lin es
  39935   "RTN","CHM XWB24",91, 0)
  39936       ; then  we must u se values  in CHAMPVA  CLAIMS fi le (^CHMPA Y) to repo rt to clea ringhouse.
  39937   "RTN","CHM XWB24",92, 0)
  39938       S CHCL FI=0,CLMLI NK=1
  39939   "RTN","CHM XWB24",93, 0)
  39940       F  S C HCLFI=$O(^ CHMXCLF("B ",CHCLEI,C HCLFI)) Q: CHCLFI=""   I '$D(LND ATA2(CHCLF I)) S CLML INK=0 Q
  39941   "RTN","CHM XWB24",94, 0)
  39942       Q
  39943   "RTN","CHM XWB24",95, 0)
  39944       ;
  39945   "RTN","CHM XWB24",96, 0)
  39946   LINE ; HAP E POR - BU ILD DTL RE CORDS FOR  LINE ITEMS  FROM ^CHM PAY file
  39947   "RTN","CHM XWB24",97, 0)
  39948       S HACC LM=0 F  S  HACCLM=$O( ^CHMXCLE(C HCLEI,80," B",HACCLM) ) Q:HACCLM =""  D
  39949   "RTN","CHM XWB24",98, 0)
  39950       . S (S VCENDATE,S VCSTDATE,E CLMNUM,QTY UOS,RVNUCO DE,LIPPA,L ICHRGA,PRC M1,PRCM2,P RCM3,PRCM4 ,SICODE,SQ ID,LICN)=" "
  39951   "RTN","CHM XWB24",99, 0)
  39952       . S TO C=$$TOS^CH 835FU1($P( $G(^CHMPAY (HACCLM,0) ),"^",7))
  39953   "RTN","CHM XWB24",100 ,0)
  39954       . I TO C="IPT" D
  39955   "RTN","CHM XWB24",101 ,0)
  39956       .. S P ROCUNIT=1
  39957   "RTN","CHM XWB24",102 ,0)
  39958       .. I $ G(IPTOHI(H ACCLM))=""  S IPTOHI( HACCLM)=$P ($G(^CHMPA Y(HACCLM,1 )),"^",7)
  39959   "RTN","CHM XWB24",103 ,0)
  39960       .. I ' $D(^CHMPAY (HACCLM,"I NP-ITEM")) ,$G(IPTAMT (HACCLM))= "" S IPTAM T(HACCLM)= $P($G(^CHM PAY(HACCLM ,1)),"^",1 4)
  39961   "RTN","CHM XWB24",104 ,0)
  39962       . ; HA PE POR - G ET PDI FRO M CHMPAY F ILE, VENDO RIZATION P OINTER
  39963   "RTN","CHM XWB24",105 ,0)
  39964       . ; SA ME VALUE F ROM 835
  39965   "RTN","CHM XWB24",106 ,0)
  39966       . S PC ID=$P($P($ G(^CHMPAY( HACCLM,0)) ,"^",4),"* ")
  39967   "RTN","CHM XWB24",107 ,0)
  39968       . ; PD I NOT POPU LATED, DER IVED CLAIM  CTL NUM
  39969   "RTN","CHM XWB24",108 ,0)
  39970       . S:PC ID="" PCID =$P($G(^CH MXCLE(CHCL EI,100))," ^",4)
  39971   "RTN","CHM XWB24",109 ,0)
  39972       . S CL TYPE=$S(TO C="IPT":"I NP-REV",TO C="OPT":"O PT-PROC",T OC="RXT":" PHARM",TOC ="DUR":"DM E-SUPPLY", TOC="DNT": "DEN-PROC" ,TOC="TRV" :"OPT-PROC ",1:"OPT-P ROC")
  39973   "RTN","CHM XWB24",110 ,0)
  39974       . I TO C="OPT",$O (^CHMPAY(H ACCLM,CLTY PE,0))="", $O(^CHMPAY (HACCLM,"P HARM",0))  S TOC="RXT ",CLTYPE=" PHARM"
  39975   "RTN","CHM XWB24",111 ,0)
  39976       . S PI ECE=$S(TOC ="DNT":"1; 6;22;23;24 ;10;13;2;5 ",TOC="DUR ":"1;13;14 ;15;16;8;1 1;2;4",TOC ="IPT":"1; ;;;;1;4;2; 5",TOC="OP T":"1;4;25 ;26;27;16; 19;2;3",TO C="RXT":"2 ;;;;;;6;4; 5",TOC="TR V":"1;4;25 ;26;27;16; 19;2;3",1: "")
  39977   "RTN","CHM XWB24",112 ,0)
  39978       . I PI ECE="" Q
  39979   "RTN","CHM XWB24",113 ,0)
  39980       . S D1 =0,LN="" F  LN=1:1 S  D1=$O(^CHM PAY(HACCLM ,CLTYPE,D1 )) Q:D1'=+ D1  S LINE D=$G(^(D1, 0)) D
  39981   "RTN","CHM XWB24",114 ,0)
  39982       .. I T OC="OPT",$ L(LINED,"^ ")'>3 Q  ; HAPE POR f or incompl ete line i nfo
  39983   "RTN","CHM XWB24",115 ,0)
  39984       .. K C HRJARR S C HRJARR(0)= 1 D
  39985   "RTN","CHM XWB24",116 ,0)
  39986       ... I  '$D(^CHMSN A(741008.2 ,"AB",HACC LM)),'$D(^ CHMSNA(741 008.3,"D", HACCLM)) S  CHRJARR(1 ,1)="F2*1* " Q
  39987   "RTN","CHM XWB24",117 ,0)
  39988       ... I  $P($G(^CHM PAY(HACCLM ,0)),"^",2 )=0 S CHRJ ARR(1,1)=" F2*1*" Q
  39989   "RTN","CHM XWB24",118 ,0)
  39990       ... I  $P($G(^CHM PAY(HACCLM ,0)),"^",2 )=4 D  Q
  39991   "RTN","CHM XWB24",119 ,0)
  39992       .... I  TOC="IPT"  S CHRJARR (1,1)="F1* 65*" Q
  39993   "RTN","CHM XWB24",120 ,0)
  39994       .... S  ALLOWAMT= $P(LINED," ^",$P(PIEC E,";",9))
  39995   "RTN","CHM XWB24",121 ,0)
  39996       .... I  ALLOWAMT> 0 S CHRJAR R(1,1)="F1 *65*" Q
  39997   "RTN","CHM XWB24",122 ,0)
  39998       .... S  CHRJARR(1 ,1)="F2*1* " Q
  39999   "RTN","CHM XWB24",123 ,0)
  40000       .. ; 5 .LINE ITEM  CONTROL N UMBER
  40001   "RTN","CHM XWB24",124 ,0)
  40002       .. S ( LICN,STCLI CN)=$$GTLI CTL(HACCLM ,D1,TOC,LN )
  40003   "RTN","CHM XWB24",125 ,0)
  40004       .. I L ICN=""!(LI CN="N/A")  S (STCLICN ,LICN)=HAC CLM_D1
  40005   "RTN","CHM XWB24",126 ,0)
  40006       .. ; 6 .SERVICE Q UALIFIER I D
  40007   "RTN","CHM XWB24",127 ,0)
  40008       .. S S QID=$$SVCQ UAL($P(LIN ED,"^",$P( PIECE,";") ))
  40009   "RTN","CHM XWB24",128 ,0)
  40010       .. ; D EFAULT VAL UE IF NOT  PROVIDED
  40011   "RTN","CHM XWB24",129 ,0)
  40012       .. S:S QID="" SQI D="NU"
  40013   "RTN","CHM XWB24",130 ,0)
  40014       .. ; 7 .SERVICE I DENTIFICAT ION CODE
  40015   "RTN","CHM XWB24",131 ,0)
  40016       .. S S ICODE=$$PR OC($P(LINE D,"^",$P(P IECE,";")) )
  40017   "RTN","CHM XWB24",132 ,0)
  40018       .. ; 8 .PROCEDURE  MODIFIER  1
  40019   "RTN","CHM XWB24",133 ,0)
  40020       .. S X =$P(LINED, "^",$P(PIE CE,";",2)) ,PRCM1=""
  40021   "RTN","CHM XWB24",134 ,0)
  40022       .. I X '="" S PRC M1=$$MOD(X )
  40023   "RTN","CHM XWB24",135 ,0)
  40024       .. ; 9 .PROCEDURE  MODIFIER  2
  40025   "RTN","CHM XWB24",136 ,0)
  40026       .. S X =$P(LINED, "^",$P(PIE CE,";",3)) ,PRCM2=""
  40027   "RTN","CHM XWB24",137 ,0)
  40028       .. I X '="" S PRC M2=$$MOD(X )
  40029   "RTN","CHM XWB24",138 ,0)
  40030       .. ; 1 0.PROCEDUR E MODIFIER  3
  40031   "RTN","CHM XWB24",139 ,0)
  40032       .. S X =$P(LINED, "^",$P(PIE CE,";",4)) ,PRCM3=""
  40033   "RTN","CHM XWB24",140 ,0)
  40034       .. I X '="" S PRC M3=$$MOD(X )
  40035   "RTN","CHM XWB24",141 ,0)
  40036       .. ; 1 1.PROCEDUR E MODIFIER  4
  40037   "RTN","CHM XWB24",142 ,0)
  40038       .. S X =$P(LINED, "^",$P(PIE CE,";",5)) ,PRCM4=""
  40039   "RTN","CHM XWB24",143 ,0)
  40040       .. I X '="" S PRC M4=$$MOD(X )
  40041   "RTN","CHM XWB24",144 ,0)
  40042       .. ; 1 2.FINAL LI NE ITEM CH ARGE AMOUN T
  40043   "RTN","CHM XWB24",145 ,0)
  40044       .. S L ICHRGA=$P( LINED,"^", $P(PIECE," ;",8))
  40045   "RTN","CHM XWB24",146 ,0)
  40046       .. S L ICHRGA=$FN (LICHRGA," ",2)
  40047   "RTN","CHM XWB24",147 ,0)
  40048       .. ; 1 3.FINAL LI NE ITEM PR OV. PAYMEN T AMOUNT
  40049   "RTN","CHM XWB24",148 ,0)
  40050       .. S L IPPA=$FN($ $LPA(TOC,H ACCLM,CLTY PE,D1,LINE D),"",2)
  40051   "RTN","CHM XWB24",149 ,0)
  40052       .. ; 1 4.REVENUE  CODE
  40053   "RTN","CHM XWB24",150 ,0)
  40054       .. S R EV=$P(LINE D,"^",$P(P IECE,";",6 )),RVNUCOD E=""
  40055   "RTN","CHM XWB24",151 ,0)
  40056       .. I R EV'="" S R VNUCODE=$$ REVCD(REV)
  40057   "RTN","CHM XWB24",152 ,0)
  40058       .. ; D ON'T OUTPU T 9999 VAL UE
  40059   "RTN","CHM XWB24",153 ,0)
  40060       .. I R VNUCODE="9 999" S RVN UCODE=""
  40061   "RTN","CHM XWB24",154 ,0)
  40062       .. ; H APE POR 12 /20/13 - i f SERVICE  QUALIFER I D='NU' the n force
  40063   "RTN","CHM XWB24",155 ,0)
  40064       .. ;                       S ervice  Id entificati on Code =  Revenue Co de
  40065   "RTN","CHM XWB24",156 ,0)
  40066       .. I S QID="NU" S  SICODE=RV NUCODE
  40067   "RTN","CHM XWB24",157 ,0)
  40068       .. ; 1 5.FINAL QU ANTITY(UNI TS OF SERV ICE) - MUS T DEFAULT  TO 1
  40069   "RTN","CHM XWB24",158 ,0)
  40070       .. S Q TYUOS=$P(L INED,"^",$ P(PIECE,"; ",7)) I QT YUOS="" S  QTYUOS=1
  40071   "RTN","CHM XWB24",159 ,0)
  40072       .. ; 1 6.EMDEON C LAIM NUMBE R
  40073   "RTN","CHM XWB24",160 ,0)
  40074       .. S E CLMNUM=$P( ^CHMXCLE(C HCLEI,3)," ^",5)
  40075   "RTN","CHM XWB24",161 ,0)
  40076       .. ; 1 7 & 18. SE RVICE STAR T/END DATE
  40077   "RTN","CHM XWB24",162 ,0)
  40078       .. S S VCSTDATE=$ P(^CHMPAY( HACCLM,0), "^",8)
  40079   "RTN","CHM XWB24",163 ,0)
  40080       .. ;HA PE POR 11/ 26/13 - pr oblem with  date form ats, in Fi leMan form at
  40081   "RTN","CHM XWB24",164 ,0)
  40082       .. I $ L(SVCSTDAT E)=7 S X=S VCSTDATE D  H^%DTC I  %H'="" S S VCSTDATE=$ ZD(%H,8)
  40083   "RTN","CHM XWB24",165 ,0)
  40084       .. S S VCENDATE=S VCSTDATE
  40085   "RTN","CHM XWB24",166 ,0)
  40086       .. ;CF S 01/18/20 18 Call GE TRORSN^CHM XWBUT and  check if ^ CHMXCLE ha s Reopen R eject Reas on, 
  40087   "RTN","CHM XWB24",167 ,0)
  40088       .. ;                 if so,  override C HRJARR(1,1 ) with Reo pen Reject  Reason.
  40089   "RTN","CHM XWB24",168 ,0)
  40090    .. N ERRS TR
  40091   "RTN","CHM XWB24",169 ,0)
  40092       .. S E RRSTR="F3* 686*;"  ;R eopen Reje ct Reasons .
  40093   "RTN","CHM XWB24",170 ,0)
  40094       .. D G ETRORSN^CH MXWBUT(CHC LEI,ERRSTR ,.CHRJARR)
  40095   "RTN","CHM XWB24",171 ,0)
  40096       .. D B LDLINE^CHM XWB21
  40097   "RTN","CHM XWB24",172 ,0)
  40098       . Q
  40099   "RTN","CHM XWB24",173 ,0)
  40100       Q
  40101   "RTN","CHM XWB24",174 ,0)
  40102       ;
  40103   "RTN","CHM XWB24",175 ,0)
  40104   LPA(TOC,HA CCLM,CLTYP E,D1,LINED ) ;
  40105   "RTN","CHM XWB24",176 ,0)
  40106       ; FINA L LINE ITE M PAYMENT  AMOUNT
  40107   "RTN","CHM XWB24",177 ,0)
  40108       N D2,X 2,X3,X4,XL N,PIECE,CL LD0,CLMPAY
  40109   "RTN","CHM XWB24",178 ,0)
  40110       N CHCL F70,CHCLF1 01,OHIPAY, OHIADJ,DAT A,STOP,PRA MT,NOCLOHI
  40111   "RTN","CHM XWB24",179 ,0)
  40112       I HACC LM="" Q 0
  40113   "RTN","CHM XWB24",180 ,0)
  40114       ; HAPE  POR - if  the SLLA e nhancement  data is a vailable,  use that f or this Cl aim
  40115   "RTN","CHM XWB24",181 ,0)
  40116       S (XLN ,X1)=""
  40117   "RTN","CHM XWB24",182 ,0)
  40118       S D2=$ O(^CHMPAY( HACCLM,CLT YPE,D1,1,0 )) I D2 D
  40119   "RTN","CHM XWB24",183 ,0)
  40120       . S X2 =$G(^(D2,0 ))
  40121   "RTN","CHM XWB24",184 ,0)
  40122       . I +$ P(X2,"^",1 5)>0 S XLN =$P(X2,"^" ,15) Q
  40123   "RTN","CHM XWB24",185 ,0)
  40124       . S XL N=$P(X2,"^ ",12)-$P(X 2,"^",16)
  40125   "RTN","CHM XWB24",186 ,0)
  40126       . I XL N<0 S XLN= $P(X2,"^", 12)
  40127   "RTN","CHM XWB24",187 ,0)
  40128       . Q
  40129   "RTN","CHM XWB24",188 ,0)
  40130       I XLN' ="" Q XLN
  40131   "RTN","CHM XWB24",189 ,0)
  40132       S PIEC E=$S(TOC=" DNT":"5;7; 2",TOC="DU R":"4;5;2" ,TOC="IPT" :"2;2;2",T OC="OPT":" 3;5;2",TOC ="RXT":"5; 10;4",TOC= "TRV":"3;5 ;2",1:"")
  40133   "RTN","CHM XWB24",190 ,0)
  40134       S CLMP AY=$P($G(^ CHMPAY(HAC CLM,1)),"^ ")
  40135   "RTN","CHM XWB24",191 ,0)
  40136       S LINA LOW=$P(^CH MPAY(HACCL M,CLTYPE,D 1,0),"^",$ P(PIECE,"; ",2))
  40137   "RTN","CHM XWB24",192 ,0)
  40138       I 'LIN ALOW S LIN ALOW=$P(^C HMPAY(HACC LM,CLTYPE, D1,0),"^", $P(PIECE," ;"))
  40139   "RTN","CHM XWB24",193 ,0)
  40140       S X2=0  F  S X2=$ O(^CHMPAY( HACCLM,CLT YPE,X2)) Q :X2'=+X2   D
  40141   "RTN","CHM XWB24",194 ,0)
  40142       . I X2 =D1 Q
  40143   "RTN","CHM XWB24",195 ,0)
  40144       . S LI NALOW1=$P( ^(X2,0),"^ ",$P(PIECE ,";",2))
  40145   "RTN","CHM XWB24",196 ,0)
  40146       . I 'L INALOW1 S  LINALOW1=$ P(^CHMPAY( HACCLM,CLT YPE,X2,0), "^",$P(PIE CE,";"))
  40147   "RTN","CHM XWB24",197 ,0)
  40148       . I LI NALOW1=0 Q
  40149   "RTN","CHM XWB24",198 ,0)
  40150       . K CL MPAY Q
  40151   "RTN","CHM XWB24",199 ,0)
  40152       I $G(C LMPAY)>0 K  CLMOTH(HA CCLM) S XL N=CLMPAY G  LPA1
  40153   "RTN","CHM XWB24",200 ,0)
  40154       ; HAPE  POR - oth er health  insurance  amount
  40155   "RTN","CHM XWB24",201 ,0)
  40156       I $G(C LMOTH(HACC LM))'="" D
  40157   "RTN","CHM XWB24",202 ,0)
  40158       . S X3 =$P(LINED, "^",$P(PIE CE,";"))
  40159   "RTN","CHM XWB24",203 ,0)
  40160       . I TO C="IPT" D   Q
  40161   "RTN","CHM XWB24",204 ,0)
  40162       .. S X 4=X3-$P($G (^CHMPAY(H ACCLM,1)), "^",7)
  40163   "RTN","CHM XWB24",205 ,0)
  40164       .. I $ FN(X4,"",2 )=$FN($P($ G(^CHMPAY( HACCLM,1)) ,"^"),"",2 ) K CLMOTH (HACCLM)
  40165   "RTN","CHM XWB24",206 ,0)
  40166       . I $F N(X3,"",2) =$FN($P($G (^CHMPAY(H ACCLM,1)), "^"),"",2)  K CLMOTH( HACCLM)
  40167   "RTN","CHM XWB24",207 ,0)
  40168       . Q
  40169   "RTN","CHM XWB24",208 ,0)
  40170       I $G(C LMOTH(HACC LM))'="" D
  40171   "RTN","CHM XWB24",209 ,0)
  40172       . S X3 =$P(LINED, "^",$P(PIE CE,";",3))
  40173   "RTN","CHM XWB24",210 ,0)
  40174       . S X4 =X3-$P($G( ^CHMPAY(HA CCLM,1))," ^",7)
  40175   "RTN","CHM XWB24",211 ,0)
  40176       . I $F N(X4,"",2) =$FN($P($G (^CHMPAY(H ACCLM,1)), "^"),"",2)  S $P(PIEC E,";")=$P( PIECE,";", 3)
  40177   "RTN","CHM XWB24",212 ,0)
  40178       . Q
  40179   "RTN","CHM XWB24",213 ,0)
  40180       ; HAPE  POR - app ly special  case(s) f ound in de v environm ent data o n whether  OHI values  affect th e payment  amount or  not.
  40181   "RTN","CHM XWB24",214 ,0)
  40182       S (X,X 1)=""
  40183   "RTN","CHM XWB24",215 ,0)
  40184       S XLN= $P(LINED," ^",$P(PIEC E,";"))
  40185   "RTN","CHM XWB24",216 ,0)
  40186       I +$G( CLMOTH(HAC CLM))>0,$P (LINED,"^" ,$P(PIECE, ";",3))>XL N S XLN=$P (LINED,"^" ,$P(PIECE, ";",3))
  40187   "RTN","CHM XWB24",217 ,0)
  40188       I $P(L INED,"^",$ P(PIECE,"; ",2))'=""  S XLN=$P(L INED,"^",$ P(PIECE,"; ",2))
  40189   "RTN","CHM XWB24",218 ,0)
  40190       ;HAPE  POR - appl y cost sha re amount
  40191   "RTN","CHM XWB24",219 ,0)
  40192       I $FN( $G(CLMCOST (HACCLM)), "",2)>0 D
  40193   "RTN","CHM XWB24",220 ,0)
  40194       . I CL MCOST(HACC LM)>XLN S  CLMCOST(HA CCLM)=CLMC OST(HACCLM )-XLN,XLN= 0 Q
  40195   "RTN","CHM XWB24",221 ,0)
  40196       . S XL N=XLN-CLMC OST(HACCLM ),CLMCOST( HACCLM)=0
  40197   "RTN","CHM XWB24",222 ,0)
  40198       ;HAPE  POR - appl y deductib le amount
  40199   "RTN","CHM XWB24",223 ,0)
  40200       I $FN( $G(CLMDED( HACCLM))," ",2)>0,XLN >0 D
  40201   "RTN","CHM XWB24",224 ,0)
  40202       . I CL MDED(HACCL M)>XLN S C LMDED(HACC LM)=CLMDED (HACCLM)-X LN,XLN=0 Q
  40203   "RTN","CHM XWB24",225 ,0)
  40204       . S XL N=XLN-CLMD ED(HACCLM) ,CLMDED(HA CCLM)=0
  40205   "RTN","CHM XWB24",226 ,0)
  40206       ;HAPE  POR - appl y patient  paid amoun t
  40207   "RTN","CHM XWB24",227 ,0)
  40208       I $FN( $G(PATPAY( HACCLM))," ",2)>0,XLN >0 D
  40209   "RTN","CHM XWB24",228 ,0)
  40210       . I PA TPAY(HACCL M)>XLN S P ATPAY(HACC LM)=PATPAY (HACCLM)-X LN,XLN=0 Q
  40211   "RTN","CHM XWB24",229 ,0)
  40212       . S XL N=XLN-PATP AY(HACCLM) ,PATPAY(HA CCLM)=0
  40213   "RTN","CHM XWB24",230 ,0)
  40214       ;HAPE  POR - appl y other he alth insur ance value s
  40215   "RTN","CHM XWB24",231 ,0)
  40216       I $FN( $G(CLMOTH( HACCLM))," ",2)>0,XLN >0 D
  40217   "RTN","CHM XWB24",232 ,0)
  40218       . I CL MOTH(HACCL M)>XLN S C LMOTH(HACC LM)=CLMOTH (HACCLM)-X LN,XLN=0 Q
  40219   "RTN","CHM XWB24",233 ,0)
  40220       . S XL N=XLN-CLMO TH(HACCLM) ,CLMOTH(HA CCLM)=0
  40221   "RTN","CHM XWB24",234 ,0)
  40222       . Q
  40223   "RTN","CHM XWB24",235 ,0)
  40224   LPA1 ;
  40225   "RTN","CHM XWB24",236 ,0)
  40226       S X=$G (X)+XLN
  40227   "RTN","CHM XWB24",237 ,0)
  40228       ;I TOC ="IPT" S X =$G(IPTAMT (HACCLM,CH CLFI))
  40229   "RTN","CHM XWB24",238 ,0)
  40230       I $P(C HRJARR(1,1 ),"*")="F2 " S X="0.0 0"
  40231   "RTN","CHM XWB24",239 ,0)
  40232       Q X
  40233   "RTN","CHM XWB24",240 ,0)
  40234       ;
  40235   "RTN","CHM XWB24",241 ,0)
  40236   GTLICTL(CI ,JI,TOS,LI NE) ; HAPE  POR - bor rowed code  form 835  create 
  40237   "RTN","CHM XWB24",242 ,0)
  40238       ;6/6/2 012 DLB  A DDED FUNCT ION TO RET RIEVE LINE  ITEM CONT ROL NUMBER  FOR ^CHMP AY CLAIM I NDEX
  40239   "RTN","CHM XWB24",243 ,0)
  40240       ; CI        "I" I NDEX FOR ^ CHMPAY
  40241   "RTN","CHM XWB24",244 ,0)
  40242       ; JI        "J" I NDEX FOR ^ CHMPAY
  40243   "RTN","CHM XWB24",245 ,0)
  40244       ; TOS       TYPE  OF SERVICE
  40245   "RTN","CHM XWB24",246 ,0)
  40246       ; SERV ICE LINE #  FOR PRE-S LA CLAIMS
  40247   "RTN","CHM XWB24",247 ,0)
  40248       N PDI, PDITYPE,LI NCTL
  40249   "RTN","CHM XWB24",248 ,0)
  40250       S (CLM TYP,PDI,KI ,IMGTYP,IM GFLD,PAYFL D)="",LINC TL="NO LIC TL"
  40251   "RTN","CHM XWB24",249 ,0)
  40252       S PDI= $P($P(^CHM PAY(CI,0), "^",4),"*" ,1)
  40253   "RTN","CHM XWB24",250 ,0)
  40254       S PDIT YPE=$E(PDI ,8,9)
  40255   "RTN","CHM XWB24",251 ,0)
  40256       I (PDI TYPE=91)!( PDITYPE=92 )!(PDITYPE =93) D
  40257   "RTN","CHM XWB24",252 ,0)
  40258       .I $$S LADATE(PDI ) S LINCTL =$$GETIMGL I(PDI,CI,J I,TOS)
  40259   "RTN","CHM XWB24",253 ,0)
  40260       .E  S  LINCTL=$$G ETCLBLI(PD I,LINE)
  40261   "RTN","CHM XWB24",254 ,0)
  40262       E  I P DITYPE=99  S LINCTL=$ $GETPHPN(P DI)
  40263   "RTN","CHM XWB24",255 ,0)
  40264       Q LINC TL
  40265   "RTN","CHM XWB24",256 ,0)
  40266       ;
  40267   "RTN","CHM XWB24",257 ,0)
  40268   SLADATE(PD I) ; BORRO WED FROM 8 35 CREATE  ROUTINES
  40269   "RTN","CHM XWB24",258 ,0)
  40270       ; PDI   CLAIM PDI  FROM ^CHM PAY
  40271   "RTN","CHM XWB24",259 ,0)
  40272       N RETU RN
  40273   "RTN","CHM XWB24",260 ,0)
  40274       S RETU RN=0
  40275   "RTN","CHM XWB24",261 ,0)
  40276       I $E(P DI,1,4)'<2 013 D
  40277   "RTN","CHM XWB24",262 ,0)
  40278       .I $E( PDI,7,9)'< 001 D
  40279   "RTN","CHM XWB24",263 ,0)
  40280       ..S RE TURN=1
  40281   "RTN","CHM XWB24",264 ,0)
  40282       Q RETU RN
  40283   "RTN","CHM XWB24",265 ,0)
  40284       ;
  40285   "RTN","CHM XWB24",266 ,0)
  40286   GETIMGLI(P DI,PAYI,PA YJ,TOS) ;  BORROWED F ROM 835 CR EATE ROUTI NES
  40287   "RTN","CHM XWB24",267 ,0)
  40288       ; PDI       HAC I NTERNAL CL AIM IDENTI FIER
  40289   "RTN","CHM XWB24",268 ,0)
  40290       ; PAYI      "I" I NDEX TO ^C HMPAY()
  40291   "RTN","CHM XWB24",269 ,0)
  40292       ; PAYJ      "J" I NDEX YO ^C HMPAY()
  40293   "RTN","CHM XWB24",270 ,0)
  40294       ; TOS       "OPT" ,"TRV","DU R","DNT" C LAIM DESCR IPTOR
  40295   "RTN","CHM XWB24",271 ,0)
  40296       N PAYK ,IMGL,IMGI NFO,PAYINF O,PAYTYP,P AYFLD,IMGT YP,IMGFLD, LINCTL
  40297   "RTN","CHM XWB24",272 ,0)
  40298       S LINC TL="N/A"
  40299   "RTN","CHM XWB24",273 ,0)
  40300       I TOS= "IPT" Q LI NCTL
  40301   "RTN","CHM XWB24",274 ,0)
  40302       ;HAPE  POR - 8/29 /13 borrow ed code di d not hand le PHARM
  40303   "RTN","CHM XWB24",275 ,0)
  40304       S PAYI NFO=$S(TOS ="OPT":"OP T-PROC*18" ,TOS="TRV" :"OPT-PROC *18",TOS=" DUR":"DME- SUPPLY*10" ,TOS="DNT" :"DEN-PROC *12",TOC=" RXT":"PHAR M*",TOS="I PT":"",1:" ") ; GET T HE ^CHMPAY  TOS INDEX
  40305   "RTN","CHM XWB24",276 ,0)
  40306       S PAYT YP=$P(PAYI NFO,"*",1) ,PAYFLD=$P (PAYINFO," *",2)
  40307   "RTN","CHM XWB24",277 ,0)
  40308       S PAYK =0
  40309   "RTN","CHM XWB24",278 ,0)
  40310       F  S P AYK=$O(^CH MPAY(PAYI, PAYTYP,JI, 1,PAYK)) Q :+(PAYK)=0   D
  40311   "RTN","CHM XWB24",279 ,0)
  40312       . S IM GL=$P(^CHM PAY(PAYI,P AYTYP,PAYJ ,1,PAYK,0) ,"^",17)
  40313   "RTN","CHM XWB24",280 ,0)
  40314       . ;HAP E POR - bo rrowed cod e missing  RXT check
  40315   "RTN","CHM XWB24",281 ,0)
  40316       . S IM GINFO=$S(T OS="OPT":" OPT-NS*16" ,TOS="TRV" :"OPT-NS*1 6",TOS="DU R":"DME-NS *14",TOS=" DNT":"DENT AL-NS*15", TOS="RXT": "RX-NS*",1 :"")
  40317   "RTN","CHM XWB24",282 ,0)
  40318       . S IM GTYP=$P(IM GINFO,"*", 1),IMGFLD= $P(IMGINFO ,"*",2)
  40319   "RTN","CHM XWB24",283 ,0)
  40320       . I IM GTYP'="",I MGL'="",$D (^CHMIMAGE (PDI,1,1,2 ,1,IMGTYP, IMGL,0)) D
  40321   "RTN","CHM XWB24",284 ,0)
  40322       .. S L INCTL=$P(^ CHMIMAGE(P DI,1,1,2,1 ,IMGTYP,IM GL,0),"^", IMGFLD)
  40323   "RTN","CHM XWB24",285 ,0)
  40324       .. I L INCTL=""
  40325   "RTN","CHM XWB24",286 ,0)
  40326       Q LINC TL
  40327   "RTN","CHM XWB24",287 ,0)
  40328       ;
  40329   "RTN","CHM XWB24",288 ,0)
  40330   GETCLBLI(P DI,LINE) ;  GET LINE  ITEM CTRL  # FROM ^CH MXCLE()
  40331   "RTN","CHM XWB24",289 ,0)
  40332       ; CLAI M BUFFER
  40333   "RTN","CHM XWB24",290 ,0)
  40334       ; PDI   TARGETED  CLAIM PDI
  40335   "RTN","CHM XWB24",291 ,0)
  40336       ; LINE  TARGETED  LINE NUMBE R
  40337   "RTN","CHM XWB24",292 ,0)
  40338       ;
  40339   "RTN","CHM XWB24",293 ,0)
  40340       N IDXS TR,CHEI,CH FI,LINCTL, MATCH
  40341   "RTN","CHM XWB24",294 ,0)
  40342       S LINC TL="N/A",M ATCH=0
  40343   "RTN","CHM XWB24",295 ,0)
  40344       S IDXS TR=$$GETCL MI(PDI)
  40345   "RTN","CHM XWB24",296 ,0)
  40346       I IDXS TR'="" D
  40347   "RTN","CHM XWB24",297 ,0)
  40348       . S CH EI=$P(IDXS TR,"*",4)  Q:+(CHEI)= 0
  40349   "RTN","CHM XWB24",298 ,0)
  40350       . S CH FI=0
  40351   "RTN","CHM XWB24",299 ,0)
  40352       . F  S  CHFI=$O(^ CHMXCLF("B ",CHEI,CHF I)) Q:+(CH FI)=0  D   I MATCH Q
  40353   "RTN","CHM XWB24",300 ,0)
  40354       .. I $ P(^CHMXCLF (CHFI,0)," ^",2)=LINE  D
  40355   "RTN","CHM XWB24",301 ,0)
  40356       ... S  MATCH=1
  40357   "RTN","CHM XWB24",302 ,0)
  40358       ... S  LINCTL=$P( ^CHMXCLF(C HFI,1),"^" ,23)
  40359   "RTN","CHM XWB24",303 ,0)
  40360       ... I  LINCTL=""  S LINCTL=$ P($G(^CHMX CLF(CHFI,0 )),"^",2)
  40361   "RTN","CHM XWB24",304 ,0)
  40362       Q LINC TL
  40363   "RTN","CHM XWB24",305 ,0)
  40364       ;
  40365   "RTN","CHM XWB24",306 ,0)
  40366   GETPHPN(PD I) ; PHARM ACY PRESC.  NUMBER
  40367   "RTN","CHM XWB24",307 ,0)
  40368       ; PDI  CLAIM PDI  ASSIGNED 
  40369   "RTN","CHM XWB24",308 ,0)
  40370       N PRNU M
  40371   "RTN","CHM XWB24",309 ,0)
  40372       S PRNU M="PHARMAC Y"
  40373   "RTN","CHM XWB24",310 ,0)
  40374       I $D(^ CHMIMAGE(P DI,1,1,2,1 ,"RXS",1,1 00)) S PRN UM=$P(^CHM IMAGE(PDI, 1,1,2,1,"R XS",1,100, 1,0),"^",4 )
  40375   "RTN","CHM XWB24",311 ,0)
  40376       Q PRNU M
  40377   "RTN","CHM XWB24",312 ,0)
  40378       ;
  40379   "RTN","CHM XWB24",313 ,0)
  40380   GETCLMI(PD I) ;
  40381   "RTN","CHM XWB24",314 ,0)
  40382       ; PDI   INTERNAL  HAC CLAIM  ID
  40383   "RTN","CHM XWB24",315 ,0)
  40384       N PCN, XI,IDXSTR
  40385   "RTN","CHM XWB24",316 ,0)
  40386       S IDXS TR=""
  40387   "RTN","CHM XWB24",317 ,0)
  40388       S PCN= $O(^CHMXCL E("PDI",PD I,""))
  40389   "RTN","CHM XWB24",318 ,0)
  40390       I PCN  D
  40391   "RTN","CHM XWB24",319 ,0)
  40392       . S XI ="",XI=$O( ^CHMXCLE(" PDI",PDI,P CN,XI))
  40393   "RTN","CHM XWB24",320 ,0)
  40394       . S:XI  IDXSTR=0, IDXSTR=$O( ^CHMXCLE(" PDI",PDI,P CN,XI,IDXS TR))
  40395   "RTN","CHM XWB24",321 ,0)
  40396       Q IDXS TR
  40397   "RTN","CHM XWB24",322 ,0)
  40398       ;
  40399   "RTN","CHM XWB24",323 ,0)
  40400   SVCQUAL(I)  ;
  40401   "RTN","CHM XWB24",324 ,0)
  40402       N X,TY PE
  40403   "RTN","CHM XWB24",325 ,0)
  40404       I I=""  Q ""
  40405   "RTN","CHM XWB24",326 ,0)
  40406       S TYPE =$P($G(^CH MSERV(I,0) ),"^",5)
  40407   "RTN","CHM XWB24",327 ,0)
  40408       I TYPE ="HCPCS" Q  "HC"
  40409   "RTN","CHM XWB24",328 ,0)
  40410       I TYPE ="CPT" Q " HC"
  40411   "RTN","CHM XWB24",329 ,0)
  40412       I TYPE ="ADA" Q " AD"
  40413   "RTN","CHM XWB24",330 ,0)
  40414       I TYPE ="ICD-9" Q  "ID"
  40415   "RTN","CHM XWB24",331 ,0)
  40416       Q ""
  40417   "RTN","CHM XWB24",332 ,0)
  40418       ;
  40419   "RTN","CHM XWB24",333 ,0)
  40420   PROC(I) ;
  40421   "RTN","CHM XWB24",334 ,0)
  40422       N X S  X=""
  40423   "RTN","CHM XWB24",335 ,0)
  40424       Q:I=""  X
  40425   "RTN","CHM XWB24",336 ,0)
  40426       S X=$P ($G(^CHMSE RV(I,0))," ^",1)
  40427   "RTN","CHM XWB24",337 ,0)
  40428       Q X
  40429   "RTN","CHM XWB24",338 ,0)
  40430   MOD(I) ;
  40431   "RTN","CHM XWB24",339 ,0)
  40432       N X S  X=""
  40433   "RTN","CHM XWB24",340 ,0)
  40434       S X=$P ($G(^CHMDI C(741002.3 7,I,0)),"^ ",1)
  40435   "RTN","CHM XWB24",341 ,0)
  40436       Q X
  40437   "RTN","CHM XWB24",342 ,0)
  40438   REVCD(I) ;
  40439   "RTN","CHM XWB24",343 ,0)
  40440       N X S  X=""
  40441   "RTN","CHM XWB24",344 ,0)
  40442       S X=$P ($G(^CHMXD IC(741201. 39,I,0))," ^",1)
  40443   "RTN","CHM XWB24",345 ,0)
  40444       Q X
  40445   "RTN","CHM XWB24",346 ,0)
  40446       ;
  40447   "RTN","CHM XWB24",347 ,0)
  40448   HACLN(HACC LM) ; HAPE  POR - cal culate the  charge am out
  40449   "RTN","CHM XWB24",348 ,0)
  40450       N TOC, CLTYPE,PIE CE,LN,LD,C HGAMT
  40451   "RTN","CHM XWB24",349 ,0)
  40452       S TOC= $$TOS^CH83 5FU1($P($G (^CHMPAY(H ACCLM,0)), "^",7))
  40453   "RTN","CHM XWB24",350 ,0)
  40454       S CLTY PE=$S(TOC= "IPT":"INP -REV",TOC= "OPT":"OPT -PROC",TOC ="RXT":"PH ARM",TOC=" DUR":"DME- SUPPLY",TO C="DNT":"D EN-PROC",T OC="TRV":" OPT-PROC", 1:"OPT-PRO C")
  40455   "RTN","CHM XWB24",351 ,0)
  40456       I TOC= "OPT",$O(^ CHMPAY(HAC CLM,CLTYPE ,0))="",$O (^CHMPAY(H ACCLM,"PHA RM",0)) S  TOC="RXT", CLTYPE="PH ARM"
  40457   "RTN","CHM XWB24",352 ,0)
  40458       S PIEC E=$S(TOC=" DNT":"2",T OC="DUR":" 2",TOC="IP T":"2",TOC ="OPT":"2" ,TOC="RXT" :"4",TOC=" TRV":"2",1 :"")
  40459   "RTN","CHM XWB24",353 ,0)
  40460       S LN=0  F  S LN=$ O(^CHMPAY( HACCLM,CLT YPE,LN)) Q :LN'=+LN   S LD=$G(^( LN,0)) D
  40461   "RTN","CHM XWB24",354 ,0)
  40462       . I TO C="OPT",$L (LD,"^")'> 3 Q  ;HAPE  POR for i ncomplete  line info
  40463   "RTN","CHM XWB24",355 ,0)
  40464       . S CH GAMT=$G(CH GAMT)+$P(L D,"^",PIEC E)
  40465   "RTN","CHM XWB24",356 ,0)
  40466       . Q
  40467   "RTN","CHM XWB24",357 ,0)
  40468       I '$D( CHGAMT) S  CHGAMT="NO NE"
  40469   "RTN","CHM XWB24",358 ,0)
  40470       Q CHGA MT
  40471   "RTN","CHM XWBUT")
  40472   0^67^B2928 193
  40473   "RTN","CHM XWBUT",1,0 )
  40474   CHMXWBUT ; HRL/dlb;WE B 277 UTIL ITY FUNCTI ONS;10/20/ 2010 2:08  PM
  40475   "RTN","CHM XWBUT",2,0 )
  40476    ;;1;5010  MODIFICATI ONS;**14** ;OCT 20,20 10;Build 5
  40477   "RTN","CHM XWBUT",3,0 )
  40478    ;; 10/24/ 2011  ADDE D THE GETD TE START/E ND DATE FU NCTION TO  UTILITY RO UTINE.
  40479   "RTN","CHM XWBUT",4,0 )
  40480    ;; 11/1/2 011   ADDE D "FMDUMP"  FUNCTION  FOR THE HC  QUALIFIER  NODES (^C HMXCLE(I,n n,J,0)
  40481   "RTN","CHM XWBUT",5,0 )
  40482    ;; 11/3/2 011  DLB       ADDED  THE "TEST"  UTILITY T HAT WILL D UMP THE CL AIM BUFFER S FOR A
  40483   "RTN","CHM XWBUT",6,0 )
  40484    ;;                                         PROVIDED P DI.
  40485   "RTN","CHM XWBUT",7,0 )
  40486    ;; 11/7/2 011   DLB      ADDED  THE BUFFER  DUMP FOR  THE ^CHMXC L() BATCH  FILE FOR T HE "TEST"  UTILITY
  40487   "RTN","CHM XWBUT",8,0 )
  40488    ;;                                WILL NOT  MOVE INTO  TEST/DEV  UNTIL LATE R DATE
  40489   "RTN","CHM XWBUT",9,0 )
  40490    ;; 11/7/2 011   DLB      ADDED  SAMPLE EXE CUTABLE FU NCTIONS FO R CREATING  A RECORD  FROM A $TE XT DESCRIP TOR
  40491   "RTN","CHM XWBUT",10, 0)
  40492    ;;                                AND TO D OCUMENT TH E $TEXT DE SCRIPTOR A UTOMATICAL LY
  40493   "RTN","CHM XWBUT",11, 0)
  40494    ;; 12/24/ 2013  DLB  MODIFIED T HE GETDTE( ) FUNCTION  TO USE FI LEMAN DATE  ENTRY SO  USER CAN'T  OMIT DATE  ENTRY
  40495   "RTN","CHM XWBUT",12, 0)
  40496    ;;CFS 01/ 24/2018 CP E005-043 -  Added lin e tag GETR ORSN.
  40497   "RTN","CHM XWBUT",13, 0)
  40498    ;;DEF9176 33 BDB 02/ 04/2019 $G (Y)
  40499   "RTN","CHM XWBUT",14, 0)
  40500    ; 
  40501   "RTN","CHM XWBUT",15, 0)
  40502    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  40503   "RTN","CHM XWBUT",16, 0)
  40504    ; TEST EN TRY POINT  FOR THE VE RIFICATION  OF THE LI NE ITEM ST ATUS RECOR DS.                
  40505   "RTN","CHM XWBUT",17, 0)
  40506    ; PROVIDE  THE "I" V ALUE                                                                                                                           
  40507   "RTN","CHM XWBUT",18, 0)
  40508    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  40509   "RTN","CHM XWBUT",19, 0)
  40510    ;DEF01655 4 - modifi ed for new  read and  write func tions -- D RW 01/30/1
  40511   "RTN","CHM XWBUT",20, 0)
  40512   TSTREJ(CHC LFI)
  40513   "RTN","CHM XWBUT",21, 0)
  40514    N IDX,JDX ,CHCLEI,CO UNT,FMDATE ,TIME,DATE STAMP
  40515   "RTN","CHM XWBUT",22, 0)
  40516    S (IDX,JD X,COUNT)=1
  40517   "RTN","CHM XWBUT",23, 0)
  40518    D NOW^%DT C
  40519   "RTN","CHM XWBUT",24, 0)
  40520    S FMDATE= %
  40521   "RTN","CHM XWBUT",25, 0)
  40522    S FMDATE= $$JUSTIFY^ CHMXWBUT(F MDATE,14,0 ,"L")
  40523   "RTN","CHM XWBUT",26, 0)
  40524    S TIME=$$ JUSTIFY^CH MXWBUT($E( FMDATE,9,1 4),6,0,"L" )
  40525   "RTN","CHM XWBUT",27, 0)
  40526    S DATESTA MP=($E(FMD ATE,1,7)+1 7000000)_T IME ; DATE /TIME FILE  CREATED D OWN TO SEC OND
  40527   "RTN","CHM XWBUT",28, 0)
  40528    K CHRJARR
  40529   "RTN","CHM XWBUT",29, 0)
  40530    W !,"TEST  REJ FOR " ,CHCLFI
  40531   "RTN","CHM XWBUT",30, 0)
  40532    S CHCLEI= $G(^CHMXCL F(CHCLFI,0 ))
  40533   "RTN","CHM XWBUT",31, 0)
  40534    D GLINRJR SN^CHMXWBU T(CHCLFI)
  40535   "RTN","CHM XWBUT",32, 0)
  40536    D BLDSTC^ CHMXWB21(" CLM")
  40537   "RTN","CHM XWBUT",33, 0)
  40538    F IDX=1:1  Q:$G(CHRJ ARR(IDX,JD X))=""  D
  40539   "RTN","CHM XWBUT",34, 0)
  40540    .F JDX=1: 1 Q:$G(CHR JARR(IDX,J DX))=""  D
  40541   "RTN","CHM XWBUT",35, 0)
  40542    ..W !,"ID X: ",IDX,"   JDX: ",J DX," = ",$ G(CHRJARR( IDX,JDX))
  40543   "RTN","CHM XWBUT",36, 0)
  40544    Q
  40545   "RTN","CHM XWBUT",37, 0)
  40546   OFILE(DIRF ILE,OFILEM )  ;Perfor ms the FIL E Open fun ction 
  40547   "RTN","CHM XWBUT",38, 0)
  40548    ; DIRFILE   Director y/Filename  to be Ope ned
  40549   "RTN","CHM XWBUT",39, 0)
  40550    ; OFILEM:  File open  descripto r (N=NEW,R =READ,W=WR ITE,L=LOCK ,etc.)       
  40551   "RTN","CHM XWBUT",40, 0)
  40552    ;RETURN:  PASS/FAIL  Indicator
  40553   "RTN","CHM XWBUT",41, 0)
  40554    ;
  40555   "RTN","CHM XWBUT",42, 0)
  40556    N FLAG,TM PIO
  40557   "RTN","CHM XWBUT",43, 0)
  40558    O DIRFILE :OFILEM:5                                ;  Open the f ile with o penfile de scriptors
  40559   "RTN","CHM XWBUT",44, 0)
  40560    S FLAG=$T EST                                      ;         Fin d out if s uccessful
  40561   "RTN","CHM XWBUT",45, 0)
  40562    Q FLAG                                                               ;Retur n Pass/Fai l                                 ;;RETURN  PASS/FAIL
  40563   "RTN","CHM XWBUT",46, 0)
  40564   CLOSEFILE( DIRFILE)
  40565   "RTN","CHM XWBUT",47, 0)
  40566    N TMPIO S  TMPIO=$IO
  40567   "RTN","CHM XWBUT",48, 0)
  40568    C DIRFILE  
  40569   "RTN","CHM XWBUT",49, 0)
  40570    W !,"CLOS ED ",DIRFI LE,!
  40571   "RTN","CHM XWBUT",50, 0)
  40572    Q
  40573   "RTN","CHM XWBUT",51, 0)
  40574           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  40575   "RTN","CHM XWBUT",52, 0)
  40576    ; SUPPORT  FUNCTIONS  FOR THE B LDACK() FU NCTION AND  ON DEMAND  STATISTIC S REPORTIN G                                                                                       ;
  40577   "RTN","CHM XWBUT",53, 0)
  40578    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  40579   "RTN","CHM XWBUT",54, 0)
  40580    ; ^CHMDIC (741201.32  FILE IS T HE DEFINIT IONS FILE  FOR THE RE JECTS                                           ;
  40581   "RTN","CHM XWBUT",55, 0)
  40582    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  40583   "RTN","CHM XWBUT",56, 0)
  40584     
  40585   "RTN","CHM XWBUT",57, 0)
  40586   GTRXRJRSN( CHCLAI)                          ; TRANSACT ION BUFFER  REJECT RE ASONS
  40587   "RTN","CHM XWBUT",58, 0)
  40588    N RJRSN,C HJVAL
  40589   "RTN","CHM XWBUT",59, 0)
  40590    Q:'CHCLAI  
  40591   "RTN","CHM XWBUT",60, 0)
  40592    S CHJVAL= 0
  40593   "RTN","CHM XWBUT",61, 0)
  40594    I $D(^CHM XCLA(CHCLA I,101,CHJV AL)) D
  40595   "RTN","CHM XWBUT",62, 0)
  40596    .F  S CHJ VAL=$O(^CH MXCLA(CHCL AI,101,CHJ VAL)) Q:'C HJVAL  D
  40597   "RTN","CHM XWBUT",63, 0)
  40598    ..S RJRSN =$P(^CHMXC LA(CHCLAI, 101,CHJVAL ,0),"^",1)
  40599   "RTN","CHM XWBUT",64, 0)
  40600           .. D SORTRJ(R JRSN)
  40601   "RTN","CHM XWBUT",65, 0)
  40602           Q 
  40603   "RTN","CHM XWBUT",66, 0)
  40604    
  40605   "RTN","CHM XWBUT",67, 0)
  40606   GPRORJRSN( CHCLBI)                          ; PROVIDER  BUFFER RE JECT REASO NS
  40607   "RTN","CHM XWBUT",68, 0)
  40608    N RJRSN,C HJVAL
  40609   "RTN","CHM XWBUT",69, 0)
  40610    Q:'CHCLBI  
  40611   "RTN","CHM XWBUT",70, 0)
  40612    S CHJVAL= 0
  40613   "RTN","CHM XWBUT",71, 0)
  40614    I $D(^CHM XCLB(CHCLB I,101,CHJV AL)) D
  40615   "RTN","CHM XWBUT",72, 0)
  40616    .F  S CHJ VAL=$O(^CH MXCLB(CHCL BI,101,CHJ VAL)) Q:'C HJVAL  D
  40617   "RTN","CHM XWBUT",73, 0)
  40618    ..S RJRSN =$P(^CHMXC LB(CHCLBI, 101,CHJVAL ,0),"^",1)
  40619   "RTN","CHM XWBUT",74, 0)
  40620           .. D SORTRJ(R JRSN)
  40621   "RTN","CHM XWBUT",75, 0)
  40622           Q
  40623   "RTN","CHM XWBUT",76, 0)
  40624   GPATRJRSN( CHCLCI)                          ; PATIENT  BUFFER REJ ECT REASON
  40625   "RTN","CHM XWBUT",77, 0)
  40626    N RJRSN,C HJVAL
  40627   "RTN","CHM XWBUT",78, 0)
  40628    Q:'CHCLCI                                                                             
  40629   "RTN","CHM XWBUT",79, 0)
  40630    S CHJVAL= 0
  40631   "RTN","CHM XWBUT",80, 0)
  40632    I $D(^CHM XCLC(CHCLC I,101,CHJV AL)) D 
  40633   "RTN","CHM XWBUT",81, 0)
  40634    .F  S CHJ VAL=$O(^CH MXCLC(CHCL CI,101,CHJ VAL)) Q:'C HJVAL  D       
  40635   "RTN","CHM XWBUT",82, 0)
  40636    ..S RJRSN =$P(^CHMXC LC(CHCLCI, 101,CHJVAL ,0),"^",1)                         
  40637   "RTN","CHM XWBUT",83, 0)
  40638           .. D SORTRJ(R JRSN)                                                            
  40639   "RTN","CHM XWBUT",84, 0)
  40640           Q 
  40641   "RTN","CHM XWBUT",85, 0)
  40642    
  40643   "RTN","CHM XWBUT",86, 0)
  40644   GCLMRJRSN( CHCLEI)                 ; CLAIM  BUFFER REJ ECT REASON
  40645   "RTN","CHM XWBUT",87, 0)
  40646    N RJRSN,C HJVAL
  40647   "RTN","CHM XWBUT",88, 0)
  40648    Q:'CHCLEI                                                                             
  40649   "RTN","CHM XWBUT",89, 0)
  40650           S  CHJVAL=0
  40651   "RTN","CHM XWBUT",90, 0)
  40652           I  $D(^CHMXCL E(CHCLEI,1 01,CHJVAL) ) D 
  40653   "RTN","CHM XWBUT",91, 0)
  40654           .F   S CHJVAL =$O(^CHMXC LE(CHCLEI, 101,CHJVAL )) Q:'CHJV AL  D        
  40655   "RTN","CHM XWBUT",92, 0)
  40656    ..S RJRSN =$P(^CHMXC LE(CHCLEI, 101,CHJVAL ,0),"^",1)                         
  40657   "RTN","CHM XWBUT",93, 0)
  40658           .. D SORTRJ(R JRSN)                                                            
  40659   "RTN","CHM XWBUT",94, 0)
  40660           Q 
  40661   "RTN","CHM XWBUT",95, 0)
  40662           
  40663   "RTN","CHM XWBUT",96, 0)
  40664   GLINRJRSN( CHCLFI)                 ; SERVIC E LINE BUF FER REJECT  REASONS
  40665   "RTN","CHM XWBUT",97, 0)
  40666    N RJRSN,C HJVAL
  40667   "RTN","CHM XWBUT",98, 0)
  40668    Q:'CHCLFI
  40669   "RTN","CHM XWBUT",99, 0)
  40670           S  CHJVAL=0
  40671   "RTN","CHM XWBUT",100 ,0)
  40672    I $D(^CHM XCLF(CHCLF I,101,CHJV AL)) D  
  40673   "RTN","CHM XWBUT",101 ,0)
  40674           .F   S CHJVAL =$O(^CHMXC LF(CHCLFI, 101,CHJVAL )) Q:'CHJV AL  D        
  40675   "RTN","CHM XWBUT",102 ,0)
  40676    ..S RJRSN =$P(^CHMXC LF(CHCLFI, 101,CHJVAL ,0),"^",1)                
  40677   "RTN","CHM XWBUT",103 ,0)
  40678           .. D SORTRJ(R JRSN)
  40679   "RTN","CHM XWBUT",104 ,0)
  40680           Q
  40681   "RTN","CHM XWBUT",105 ,0)
  40682   SORTRJ(RJR SN)  ; SOR T/BUILD RE JECT REASO N ARRAY
  40683   "RTN","CHM XWBUT",106 ,0)
  40684    ;      RJ RSN   THE  VALUE TO B E CHECKED/ ADDED
  40685   "RTN","CHM XWBUT",107 ,0)
  40686    N EXIT,TV AL,IDX,JDX ,REJCODES
  40687   "RTN","CHM XWBUT",108 ,0)
  40688    S TVAL=0, EXIT=0,REJ CODES=0
  40689   "RTN","CHM XWBUT",109 ,0)
  40690    F IDX=1:1  S TVAL=$G (CHRJARR(I DX)) Q:((T VAL="")!(E XIT=1))  D
  40691   "RTN","CHM XWBUT",110 ,0)
  40692    .I TVAL=R JRSN S EXI T=1 
  40693   "RTN","CHM XWBUT",111 ,0)
  40694    I 'EXIT   D
  40695   "RTN","CHM XWBUT",112 ,0)
  40696    .S CHRJAR R(IDX)=RJR SN                                              ; SET  THE REJECT  REASON IN DEX
  40697   "RTN","CHM XWBUT",113 ,0)
  40698    .S CHRJAR R(0)=$G(CH RJARR(0))+ 1                           ; IN CREMENT TH E COUNTER
  40699   "RTN","CHM XWBUT",114 ,0)
  40700    .F JDX=1: 1 Q:REJCOD ES=""  D
  40701   "RTN","CHM XWBUT",115 ,0)
  40702    ..S REJCO DES=$P($G( ^CHMXDIC(7 41201.32,R JRSN,0))," ^",JDX+3)
  40703   "RTN","CHM XWBUT",116 ,0)
  40704    ..S CHRJA RR(IDX,JDX )=REJCODES
  40705   "RTN","CHM XWBUT",117 ,0)
  40706    Q
  40707   "RTN","CHM XWBUT",118 ,0)
  40708   GETRORSN(C HCLEI,ERRS TR,CHRJARR )  ;Get Re open Rejec t Reason.
  40709   "RTN","CHM XWBUT",119 ,0)
  40710       ;ERRST R = Error  string con taining Re open Rejec t Codes (i e. F0*686* ;)
  40711   "RTN","CHM XWBUT",120 ,0)
  40712       N CHJV AL,ERR,REO PRSN,RSNIE N,FOUND
  40713   "RTN","CHM XWBUT",121 ,0)
  40714       S CHJV AL=0 F  S  CHJVAL=$O( ^CHMXCLE(C HCLEI,101, CHJVAL)) Q :'CHJVAL   D
  40715   "RTN","CHM XWBUT",122 ,0)
  40716       .S RSN IEN=$P($G( ^CHMXCLE(C HCLEI,101, CHJVAL,0)) ,"^")
  40717   "RTN","CHM XWBUT",123 ,0)
  40718       .I RSN IEN S REOP RSN=$P($G( ^CHMXDIC(7 41201.32,R SNIEN,0)), "^",4)
  40719   "RTN","CHM XWBUT",124 ,0)
  40720       .I REO PRSN'="" S  ERRARRAY( REOPRSN)=" "
  40721   "RTN","CHM XWBUT",125 ,0)
  40722       S FOUN D=0,REOPRS N=""
  40723   "RTN","CHM XWBUT",126 ,0)
  40724       F ERR= 1:1 S REOP RSN=$P(ERR STR,";",ER R) Q:$P(ER RSTR,";",E RR)=""!(FO UND)  D
  40725   "RTN","CHM XWBUT",127 ,0)
  40726       .I $D( ERRARRAY(R EOPRSN)) S  CHRJARR(1 ,1)=REOPRS N,FOUND=1
  40727   "RTN","CHM XWBUT",128 ,0)
  40728       Q
  40729   "RTN","CHM XWBUT",129 ,0)
  40730   GETIS(BUF, INDEX)
  40731   "RTN","CHM XWBUT",130 ,0)
  40732    N CHCLFI, CHCLEI,CHC LBI,CHCLAI ,CHCLI
  40733   "RTN","CHM XWBUT",131 ,0)
  40734    I BUF="F"   W !,"CHC LFI= ",IND EX  D
  40735   "RTN","CHM XWBUT",132 ,0)
  40736    .S CHCLEI =$P($G(^CH MXCLF(INDE X)),"^",1)  W !,"CHCL EI = ",CHC LEI
  40737   "RTN","CHM XWBUT",133 ,0)
  40738    .S CHCLCI =$P(^CHMXC LE(CHCLEI, 0),"^",1)  W !,"CHCLC I= ",CHCLC I            ;TRAVERS E BACK THR OUGH BUFFE R FILES
  40739   "RTN","CHM XWBUT",134 ,0)
  40740    .S CHCLBI =$P(^CHMXC LC(CHCLCI, 0),"^",1)  W !,"CHCLB I= ",CHCLB I
  40741   "RTN","CHM XWBUT",135 ,0)
  40742    .S CHCLAI =$P(^CHMXC LB(CHCLBI, 0),"^",1)  W !,"CHCLA I= ",CHCLA I
  40743   "RTN","CHM XWBUT",136 ,0)
  40744    .S CHCLI= $P(^CHMXCL A(CHCLAI,0 ),"^",1) W  !,"CHCLI=  ",CHCLI
  40745   "RTN","CHM XWBUT",137 ,0)
  40746    E  I BUF= "E" S CHCL FI=0 F  S  CHCLFI=$O( ^CHMXCLF(" B",CHCLEI, CHCLFI)) W  !,"CHCLFI = ",CHCLFI   D
  40747   "RTN","CHM XWBUT",138 ,0)
  40748    .W !,"CHC LEI= ",CHC LEI
  40749   "RTN","CHM XWBUT",139 ,0)
  40750    .S CHCLCI =$P(^CHMXC LE(CHCLEI, 0),"^",1)  W !,"CHCLC I= ",CHCLC I            ;TRAVERS E BACK THR OUGH BUFFE R FILES
  40751   "RTN","CHM XWBUT",140 ,0)
  40752    .S CHCLBI =$P(^CHMXC LC(CHCLCI, 0),"^",1)  W !,"CHCLB I= ",CHCLB I
  40753   "RTN","CHM XWBUT",141 ,0)
  40754    .S CHCLAI =$P(^CHMXC LB(CHCLBI, 0),"^",1)  W !,"CHCLA I= ",CHCLA I
  40755   "RTN","CHM XWBUT",142 ,0)
  40756    .S CHCLI= $P(^CHMXCL A(CHCLAI,0 ),"^",1) W  !,"CHCLI=  ",CHCLI
  40757   "RTN","CHM XWBUT",143 ,0)
  40758    E  I BUF= "C"  D
  40759   "RTN","CHM XWBUT",144 ,0)
  40760     W !,"CHC LCI= ",CHC LCI
  40761   "RTN","CHM XWBUT",145 ,0)
  40762    .S CHCLBI =$P(^CHMXC LC(CHCLCI, 0),"^",1)  W !,"CHCLB I= ",CHCLB I
  40763   "RTN","CHM XWBUT",146 ,0)
  40764    .S CHCLAI =$P(^CHMXC LB(CHCLBI, 0),"^",1)  W !,"CHCLA I= ",CHCLA I
  40765   "RTN","CHM XWBUT",147 ,0)
  40766    .S CHCLI= $P(^CHMXCL A(CHCLAI,0 ),"^",1) W  !,"CHCLI=  ",CHCLI
  40767   "RTN","CHM XWBUT",148 ,0)
  40768    E  I BUF= "B" W !,"C HCLBI= ",C HCLCI
  40769   "RTN","CHM XWBUT",149 ,0)
  40770    .S CHCLAI =$P(^CHMXC LB(CHCLBI, 0),"^",1)  W !,"CHCLA I= ",CHCLA I
  40771   "RTN","CHM XWBUT",150 ,0)
  40772    .S CHCLI= $P(^CHMXCL A(CHCLAI,0 ),"^",1) W  !,"CHCLI=  ",CHCLI
  40773   "RTN","CHM XWBUT",151 ,0)
  40774    Q
  40775   "RTN","CHM XWBUT",152 ,0)
  40776    
  40777   "RTN","CHM XWBUT",153 ,0)
  40778    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;
  40779   "RTN","CHM XWBUT",154 ,0)
  40780    ; GETDTE  THIS FUNCT ION PROMPT S THE USER  FOR START  AND END D ATES FOR A  PROCESS.          
  40781   "RTN","CHM XWBUT",155 ,0)
  40782    ; THE ROU TINE CHECK S THE USER  INPUT FOR  VALID STA RT AND END  DATES PRI OR TO RETU RNING
  40783   "RTN","CHM XWBUT",156 ,0)
  40784    ; THE VAL UES TO THE  CALLER.
  40785   "RTN","CHM XWBUT",157 ,0)
  40786    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;
  40787   "RTN","CHM XWBUT",158 ,0)
  40788    
  40789   "RTN","CHM XWBUT",159 ,0)
  40790   TESTDATES
  40791   "RTN","CHM XWBUT",160 ,0)
  40792    N FROM,TO
  40793   "RTN","CHM XWBUT",161 ,0)
  40794    D GETDTE( .FROM,.TO)
  40795   "RTN","CHM XWBUT",162 ,0)
  40796    W !,"FROM  = ",FROM, "   TO = " ,TO
  40797   "RTN","CHM XWBUT",163 ,0)
  40798    Q
  40799   "RTN","CHM XWBUT",164 ,0)
  40800    
  40801   "RTN","CHM XWBUT",165 ,0)
  40802    
  40803   "RTN","CHM XWBUT",166 ,0)
  40804    G:$D(DFOU T) END^CHM XIN01                                                            
  40805   "RTN","CHM XWBUT",167 ,0)
  40806    ;
  40807   "RTN","CHM XWBUT",168 ,0)
  40808    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  40809   "RTN","CHM XWBUT",169 ,0)
  40810    ; MODS 12 /24/2013 D LB  DATE I NPUR NOW U TILIZES TH E FILEMAN  %DT DATE I NPUT FOR
  40811   "RTN","CHM XWBUT",170 ,0)
  40812    ; GETTING  THE START /END DATES  FROM THE  USER.
  40813   "RTN","CHM XWBUT",171 ,0)
  40814    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  40815   "RTN","CHM XWBUT",172 ,0)
  40816    ;      
  40817   "RTN","CHM XWBUT",173 ,0)
  40818   GETDTE(FRO M,TO)
  40819   "RTN","CHM XWBUT",174 ,0)
  40820    ;      FR OM    MODI FIABLE VAR IABLE FOR  THE "FROM/ START" DAT E
  40821   "RTN","CHM XWBUT",175 ,0)
  40822    ;      TO                MODIFI ABLE VARIA BLE FOR TH E "TO/END"  DATE 
  40823   "RTN","CHM XWBUT",176 ,0)
  40824    N TOSEC 
  40825   "RTN","CHM XWBUT",177 ,0)
  40826    S U="^" 
  40827   "RTN","CHM XWBUT",178 ,0)
  40828    S:$D(DTIM E) TOSEC=D TIME                                            ; IF D TIME WAS V ALID, SAVE  THE ORIGI NAL TIMEOU T VALUE
  40829   "RTN","CHM XWBUT",179 ,0)
  40830    S DTIME=6 00                                                                  ; SET TI MEOUT TO 1 0 MINUTES 
  40831   "RTN","CHM XWBUT",180 ,0)
  40832   SDATE
  40833   "RTN","CHM XWBUT",181 ,0)
  40834           S  FROM=""
  40835   "RTN","CHM XWBUT",182 ,0)
  40836    ;W !!,"En ter the ST ART date:   ",! S X=Y ,%DT="AEPT ",DT(0)="- T" D ^%DT  G:Y=-1 SDA TE
  40837   "RTN","CHM XWBUT",183 ,0)
  40838    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)
  40839   "RTN","CHM XWBUT",184 ,0)
  40840       S FROM =Y                                                                  ; SET TH E "FROM" R ETURN VARI ABLE TO IN PUT VALUE
  40841   "RTN","CHM XWBUT",185 ,0)
  40842       K %DT                                                                               ; REQUIRED  BY FILEMA N
  40843   "RTN","CHM XWBUT",186 ,0)
  40844   EDATE ;
  40845   "RTN","CHM XWBUT",187 ,0)
  40846           ;W  !!,"Enter  the STOP  date: ",!  S X=Y,%DT= "AEPT",%DT (0)="-T" D  ^%DT G:Y= -1 EDATE
  40847   "RTN","CHM XWBUT",188 ,0)
  40848           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)
  40849   "RTN","CHM XWBUT",189 ,0)
  40850           S  TO=Y                                                                         ; SET THE  "TO" RETUR N VARIABLE  TO THE IN PUT VALUE
  40851   "RTN","CHM XWBUT",190 ,0)
  40852           K  %DT                                                                          ; REQUIRED  BY FILEMA N
  40853   "RTN","CHM XWBUT",191 ,0)
  40854           I  $D(TOSEC)  S DTIME=TO SEC                                  ; REST ORE ORIGIN AL TIMEOUT  VALUE
  40855   "RTN","CHM XWBUT",192 ,0)
  40856           E   K DTIME
  40857   "RTN","CHM XWBUT",193 ,0)
  40858   GETEND Q 
  40859   "RTN","CHM XWBUT",194 ,0)
  40860    
  40861   "RTN","CHM XWBUT",195 ,0)
  40862    
  40863   "RTN","CHM XWBUT",196 ,0)
  40864   DTCVRT(DAT E)
  40865   "RTN","CHM XWBUT",197 ,0)
  40866    N EXTDATE
  40867   "RTN","CHM XWBUT",198 ,0)
  40868           S  EXTDATE=$E (DATE,4,5) _"-"_$E(DA TE,6,7)_"- "_($E(DATE ,1,3)+1700 )
  40869   "RTN","CHM XWBUT",199 ,0)
  40870    Q EXTDATE       
  40871   "RTN","CHM XWBUT",200 ,0)
  40872    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  40873   "RTN","CHM XWBUT",201 ,0)
  40874    ; SUPPORT  ROUTINES  FOR BLDSTC () AND ON  DEMAND STA TISTICS RE PORT                          ;
  40875   "RTN","CHM XWBUT",202 ,0)
  40876    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  40877   "RTN","CHM XWBUT",203 ,0)
  40878    
  40879   "RTN","CHM XWBUT",204 ,0)
  40880    
  40881   "RTN","CHM XWBUT",205 ,0)
  40882    
  40883   "RTN","CHM XWBUT",206 ,0)
  40884    ;******** ********** ********** ********** ********** ********** ********** ********** *****;
  40885   "RTN","CHM XWBUT",207 ,0)
  40886    ; SUPPORT  Subroutin es;  May b e replacea ble with E xisting or  New Libra ries                        ;
  40887   "RTN","CHM XWBUT",208 ,0)
  40888    ;******** ********** ********** ********** ********** ********** ********** ********** *****;
  40889   "RTN","CHM XWBUT",209 ,0)
  40890    
  40891   "RTN","CHM XWBUT",210 ,0)
  40892           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  40893   "RTN","CHM XWBUT",211 ,0)
  40894    ; THIS FU NCTION IS  DESIGNED T O FORMAT D ATA BASED  ON THE FOL LOWING $TE XT FORMAT:                  ;
  40895   "RTN","CHM XWBUT",212 ,0)
  40896    ;                                                                                                                                                                                      ;
  40897   "RTN","CHM XWBUT",213 ,0)
  40898    ; ";;FLD  NAME;TARGE T;LENGTH;J USTIFY;PAD CHAR;DELIM ITER;DATA  DESC;FLD S TART;FLD U SE"     ;
  40899   "RTN","CHM XWBUT",214 ,0)
  40900    ;                                                                                                                                                                                      ;
  40901   "RTN","CHM XWBUT",215 ,0)
  40902    ; THE DEF INITION OF  THE MEMBE RS OF THE  FORMAT STR ING:                                                                ;
  40903   "RTN","CHM XWBUT",216 ,0)
  40904    ;                                                                                                                                                                                      ;
  40905   "RTN","CHM XWBUT",217 ,0)
  40906    ;               ;;                         THIS CONVE NTION DIFF ERENTIATES  TABLE FRO M A COMMEN T FIELD                 ;
  40907   "RTN","CHM XWBUT",218 ,0)
  40908    ;               FLD  NAME         STRING I DENTIFYING  THE FIELD , TYPICALL Y TAKEN FR OM SPEC.                  ;
  40909   "RTN","CHM XWBUT",219 ,0)
  40910    ;               TARG ET           THIS CAN  BE A FIXE D VALUE OR  A FUNCTIO N TO RETUR N THE VALU E              ;
  40911   "RTN","CHM XWBUT",220 ,0)
  40912    ;               LENG TH           FIELD WI DTH SPECIF IED (LONGE R VALUES A LWAYS TRUN CATED)                    ;
  40913   "RTN","CHM XWBUT",221 ,0)
  40914    ;               JUST IFY          SUPPORTS  "L" (LEFT ),"R" (RIG HT), AND " C" (CENTER )                                  ;
  40915   "RTN","CHM XWBUT",222 ,0)
  40916    ;               PADC HAR          ANY PRIN TABLE CHAR ACTER, OR  NO CHAR IF  PADDING N OT DESIRED                ;
  40917   "RTN","CHM XWBUT",223 ,0)
  40918    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  40919   "RTN","CHM XWBUT",224 ,0)
  40920    
  40921   "RTN","CHM XWBUT",225 ,0)
  40922   FORMATDATA (STR)          ;Pulls  and Forma ts Data in  EMDEON SP ECIFIED FI ELDS
  40923   "RTN","CHM XWBUT",226 ,0)
  40924    ;      ST R              $TEXT  String des cribing th e record 
  40925   "RTN","CHM XWBUT",227 ,0)
  40926    N VALUE,T MPIO,COLWI DTH,VAR,JU STIFY,PAD, FIELD,DELI M
  40927   "RTN","CHM XWBUT",228 ,0)
  40928    S TMPIO=$ IO,VALUE=" "
  40929   "RTN","CHM XWBUT",229 ,0)
  40930    S COLWIDT H=$P(STR," ;",5),JUST IFY=$P(STR ,";",6)                            ; Get Co lwidth & J ustify val ues
  40931   "RTN","CHM XWBUT",230 ,0)
  40932    S FIELD=$ P(STR,";", 3),PAD=$P( STR,";",7)                                                     ;  Get Field, PadChar
  40933   "RTN","CHM XWBUT",231 ,0)
  40934    S VALUE=" S VAR="_$P (STR,";",4 ) X VALUE                                              ; VAR Now  contains t he desired  value
  40935   "RTN","CHM XWBUT",232 ,0)
  40936    S:FIELD=" SEX" VAR=$ S(VAR="M": "M",VAR="F ":"F",1:"M ")                      ; Defaul t SEX=M if  Undefined
  40937   "RTN","CHM XWBUT",233 ,0)
  40938    S VALUE=$ E($$JUSTIF Y(VAR,COLW IDTH,PAD,J USTIFY),1, COLWIDTH)      ; LEFT /RIGHT/CEN TER JUSTIF ICATION
  40939   "RTN","CHM XWBUT",234 ,0)
  40940    Q VALUE
  40941   "RTN","CHM XWBUT",235 ,0)
  40942    
  40943   "RTN","CHM XWBUT",236 ,0)
  40944    
  40945   "RTN","CHM XWBUT",237 ,0)
  40946    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  40947   "RTN","CHM XWBUT",238 ,0)
  40948    ; JUSTIFY ()   A mul tipurpose  justificat ion functi on that pe rforms Rig ht/Left/Ce nter(LRC)        ;
  40949   "RTN","CHM XWBUT",239 ,0)
  40950    ;                          just ification  in additio n to the t runcation  of the spe cified str ing as                  ;
  40951   "RTN","CHM XWBUT",240 ,0)
  40952    ;                          requ ired to sa tisfy the  width spec ification.  Allows us er to spec ify ANY                 ;
  40953   "RTN","CHM XWBUT",241 ,0)
  40954    ;                          "pad " characte r to be us ed in the  Right/Left /Center ju stificatio n.                      ;
  40955   "RTN","CHM XWBUT",242 ,0)
  40956    ;  NOTE:  If the len gth of the  provided  string is  greater th an the spe cified wid th, the          ;
  40957   "RTN","CHM XWBUT",243 ,0)
  40958    ;      re turn value  is the tr uncated st ring to fi t into the  specified  width.                                       ;
  40959   "RTN","CHM XWBUT",244 ,0)
  40960    ;  NOTE2:  The origi nal MUMPS  $J functio n has some  limitatio ns, i.e. i t provides  R and L                  ;
  40961   "RTN","CHM XWBUT",245 ,0)
  40962    ;               just ification,  but no "c enter" in  field, and  there is  a problem  with the m ath            ;
  40963   "RTN","CHM XWBUT",246 ,0)
  40964    ;               in c alculating  the outpu t if the s tring leng th and col umn width  are the sa me.            ;
  40965   "RTN","CHM XWBUT",247 ,0)
  40966    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  40967   "RTN","CHM XWBUT",248 ,0)
  40968    
  40969   "RTN","CHM XWBUT",249 ,0)
  40970   JUSTIFY(ST R,COLWIDTH ,PAD,LRC)
  40971   "RTN","CHM XWBUT",250 ,0)
  40972    ;      ST R                       Value to  be format ted and ou tput
  40973   "RTN","CHM XWBUT",251 ,0)
  40974    ;      CO LWIDTH         MAX Fi eld Width  of the str ing to be  returned
  40975   "RTN","CHM XWBUT",252 ,0)
  40976    ;      PA D                       Characte r used to  "pad" the  string (Mu st be prin table char  for justi fication)
  40977   "RTN","CHM XWBUT",253 ,0)
  40978    ;      LR C                       Left/Rig ht/Center  Justify th e string i n the colu mn width
  40979   "RTN","CHM XWBUT",254 ,0)
  40980    ;RETURN                           A String  ready for  output
  40981   "RTN","CHM XWBUT",255 ,0)
  40982    N VARLEN, RETURN,PAD STR,LPAD,P DCNT       S (PADSTR, LPAD)=""
  40983   "RTN","CHM XWBUT",256 ,0)
  40984    S VARLEN= $L(STR)                                                                                                ; Get  Length of  the variab le
  40985   "RTN","CHM XWBUT",257 ,0)
  40986    I VARLEN= COLWIDTH S  RETURN=ST R                                                              ;  Same as Sp ecified wi dth
  40987   "RTN","CHM XWBUT",258 ,0)
  40988    E  I VARL EN>COLWIDT H S RETURN =$E(STR,1, COLWIDTH)                          ; IF gre ater, disc ard extra  length
  40989   "RTN","CHM XWBUT",259 ,0)
  40990    E  I (PAD ="") S RET URN=$E(STR ,1,COLWIDT H)                                          ; Else IF  PAD CHARAC TER NOT DE FINED
  40991   "RTN","CHM XWBUT",260 ,0)
  40992    E  D                                                                                                                      ; justif y the vari able in th e string
  40993   "RTN","CHM XWBUT",261 ,0)
  40994    .I LRC="C " S PDCNT= ((COLWIDTH -VARLEN/2) +(COLWIDTH -VARLEN#2) ) D  ; Cen ter the St ring in th e width
  40995   "RTN","CHM XWBUT",262 ,0)
  40996    ..S $P(PA DSTR,PAD,P DCNT)=PAD, RETURN=(PA DSTR_STR_P ADSTR)
  40997   "RTN","CHM XWBUT",263 ,0)
  40998    ..S RETUR N=$E(RETUR N,1,COLWID TH)
  40999   "RTN","CHM XWBUT",264 ,0)
  41000    .E  I LRC ="L" D                                                     ; Left  Justify w /Pad Chara cter
  41001   "RTN","CHM XWBUT",265 ,0)
  41002    ..S $P(PA DSTR,PAD,C OLWIDTH)=P AD                   
  41003   "RTN","CHM XWBUT",266 ,0)
  41004       ..S RE TURN=$E(ST R_PADSTR,1 ,COLWIDTH)
  41005   "RTN","CHM XWBUT",267 ,0)
  41006       .E  S  $P(PADSTR, PAD,(COLWI DTH-$L(STR )+1))="" D                         ; Right  Justify w/ Pad Char
  41007   "RTN","CHM XWBUT",268 ,0)
  41008       ..S RE TURN=PADST R_STR                                                                                       
  41009   "RTN","CHM XWBUT",269 ,0)
  41010    Q RETURN                                                                                                                  ; RETURN  THE FORMA TTED STRIN G
  41011   "RTN","CHM XWBUT",270 ,0)
  41012     
  41013   "RTN","CHM XWBUT",271 ,0)
  41014    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41015   "RTN","CHM XWBUT",272 ,0)
  41016    ; Right a nd Left Ju stify func tions cour tesy of JB M 7/2/2010                                                          ;
  41017   "RTN","CHM XWBUT",273 ,0)
  41018    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41019   "RTN","CHM XWBUT",274 ,0)
  41020    
  41021   "RTN","CHM XWBUT",275 ,0)
  41022   LJ(STR,SIZ E,PAD1) ;
  41023   "RTN","CHM XWBUT",276 ,0)
  41024            N  RET,PAD
  41025   "RTN","CHM XWBUT",277 ,0)
  41026            S  PAD="",RE T=""
  41027   "RTN","CHM XWBUT",278 ,0)
  41028            I  PAD1="" S  RET=$E(ST R,1,SIZE) 
  41029   "RTN","CHM XWBUT",279 ,0)
  41030            E   S $P(PAD ,PAD1,SIZE )=PAD1,RET =$E(STR_PA D,1,SIZE) 
  41031   "RTN","CHM XWBUT",280 ,0)
  41032            Q  RET
  41033   "RTN","CHM XWBUT",281 ,0)
  41034   RJ(STR,SIZ E,PAD1) 
  41035   "RTN","CHM XWBUT",282 ,0)
  41036            N  RET,PAD
  41037   "RTN","CHM XWBUT",283 ,0)
  41038            S  PAD="",RE T=""
  41039   "RTN","CHM XWBUT",284 ,0)
  41040            I  PAD1="" S  RET=$E(ST R,1,SIZE)
  41041   "RTN","CHM XWBUT",285 ,0)
  41042            E   S $P(PAD ,PAD1,(SIZ E-$L(STR)+ 1))="",RET =$E(PAD_ST R,1,SIZE)
  41043   "RTN","CHM XWBUT",286 ,0)
  41044            Q  RET
  41045   "RTN","CHM XWBUT",287 ,0)
  41046            
  41047   "RTN","CHM XWBUT",288 ,0)
  41048            
  41049   "RTN","CHM XWBUT",289 ,0)
  41050            
  41051   "RTN","CHM XWBUT",290 ,0)
  41052           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  41053   "RTN","CHM XWBUT",291 ,0)
  41054           ;        EMDE ONHDR:       Common H eader for  EMDEON STA TUS Files                                                                 ;
  41055   "RTN","CHM XWBUT",292 ,0)
  41056           ;        A si ngle heade r is gener ated for e ach output  file.                                                                    ;
  41057   "RTN","CHM XWBUT",293 ,0)
  41058           ;     DESC: " FIELD NAME ";"LENGTH" ;"JUSTIFY  FLAG";"PAD  CHAR";"DA TA TYPE";                            ;
  41059   "RTN","CHM XWBUT",294 ,0)
  41060           ;                 FIELD  NAME:  EMD EON File F IELD DESCR IPTOR(reco rd # and t ext descri ption)         ;
  41061   "RTN","CHM XWBUT",295 ,0)
  41062           ;                 LENGTH :  EMDEON  FILE SPECI FIED FIELD  WIDTH                                                                             ;
  41063   "RTN","CHM XWBUT",296 ,0)
  41064           ;                 JUSTIF Y FLAG: L= LEFT, R=RI GHT, C= CE NTER                                                                               ;
  41065   "RTN","CHM XWBUT",297 ,0)
  41066           ;                 PAD: P AD CHARACT ER TO BE U SED TO FIL L FIELD WI DTH (ANY P RINTABLE C HARACTER)      ;
  41067   "RTN","CHM XWBUT",298 ,0)
  41068           ;                          NOTE: PA D CHAR=""  IF NO CHAR ACTER IS B ETWEEN THE  SEMICOLON S (I.E. ;; )   ;
  41069   "RTN","CHM XWBUT",299 ,0)
  41070           ;                          NO PADDI NG WILL OC CUR IF THI S IS SET U P THIS WAY                                                     ;
  41071   "RTN","CHM XWBUT",300 ,0)
  41072           ;                 DATA P ATTERN: PA TTERN MATC H DESCRIPT OR DESCRIB ING THE VA LUE                                         ;
  41073   "RTN","CHM XWBUT",301 ,0)
  41074           ;                 FIELD  START LOCA TION: LOCA TION IN RE CORD FOR T HIS FIELD- DOCUMENTAT ION ONLY       ;
  41075   "RTN","CHM XWBUT",302 ,0)
  41076           ;                 FIELD  USE: R=REQ UIRED, C=C ONDITIONAL , O=OPTION AL                                                             ;
  41077   "RTN","CHM XWBUT",303 ,0)
  41078           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  41079   "RTN","CHM XWBUT",304 ,0)
  41080           ;                                                                                                                                                                                        ;
  41081   "RTN","CHM XWBUT",305 ,0)
  41082           ;  FORMATDATA  TREATS TH E PAD CHAR  (;;) AS A  NULL, SO  NO PADDING  OCCURS.                             ;
  41083   "RTN","CHM XWBUT",306 ,0)
  41084           ;  THIS WILL  ALLOW USE  OF THE FOR MATDATA FU NCTION WIT HOUT MODIF ICATION BE TWEEN            ;
  41085   "RTN","CHM XWBUT",307 ,0)
  41086           ;  PADDED AND  NON-PADDE D FIELDS.                                                                                                                    ;
  41087   "RTN","CHM XWBUT",308 ,0)
  41088           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  41089   "RTN","CHM XWBUT",309 ,0)
  41090           ;  8/4/11  DL B "6. CREA TION TIME"  FROM $E(D ATESTAMP,9 ,12) TO $E (DATESTAMP ,9,14)           ;
  41091   "RTN","CHM XWBUT",310 ,0)
  41092           ;  8/15/11 DL B "2. FILE  GROUP ID"  INSERTED  THE DATEST AMP VALUE  TO ENSURE  UNIQUENESS       ;
  41093   "RTN","CHM XWBUT",311 ,0)
  41094           ;  9/7/2011 D LB 12. LOA D TYPE CHA NGED TO PR OVIDE "F"  WHEN HISTO RICAL FILE  GENERATED       ;
  41095   "RTN","CHM XWBUT",312 ,0)
  41096           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;
  41097   "RTN","CHM XWBUT",313 ,0)
  41098           
  41099   "RTN","CHM XWBUT",314 ,0)
  41100   TSTHDR  ;B UILD HEADE R RECORD
  41101   "RTN","CHM XWBUT",315 ,0)
  41102    N LN,REC, STR,LOADTY PE,DATESTA MP,GROUPID
  41103   "RTN","CHM XWBUT",316 ,0)
  41104    S GROUPID =""
  41105   "RTN","CHM XWBUT",317 ,0)
  41106    S (STR,LN ,REC)="",C OUNT=2                        ;  EMDEON SPE C: REC. CO UNT STARTS  @ 2
  41107   "RTN","CHM XWBUT",318 ,0)
  41108    S DATESTA MP=$$FMDAT E("NOW")
  41109   "RTN","CHM XWBUT",319 ,0)
  41110    F LN=1:1  S STR=$T(S AMPLEHDR+L N) Q:STR[" END OF REC ORD"  D
  41111   "RTN","CHM XWBUT",320 ,0)
  41112    .I LN=1 S  REC=REC_$ $FORMATDAT A^CHMXWBUT (STR)            
  41113   "RTN","CHM XWBUT",321 ,0)
  41114    .E  S REC =REC_"|"_$ $FORMATDAT A^CHMXWBUT (STR)
  41115   "RTN","CHM XWBUT",322 ,0)
  41116    W REC,! S  REC=""                                                             
  41117   "RTN","CHM XWBUT",323 ,0)
  41118    Q
  41119   "RTN","CHM XWBUT",324 ,0)
  41120                      
  41121   "RTN","CHM XWBUT",325 ,0)
  41122   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
  41123   "RTN","CHM XWBUT",326 ,0)
  41124           ;; 1.RECORD I D;"HDR";3; L;;3AN;0;R ;
  41125   "RTN","CHM XWBUT",327 ,0)
  41126           ;; 2.FILE GRO UP ID;$S(G ROUPID'="" :GROUPID,1 :DATESTAMP );20;L;;20 AN;4;R;
  41127   "RTN","CHM XWBUT",328 ,0)
  41128           ;; 3.FILE GRO UP SEQUENC E NUMBER;" FILE NUMBE R";2;R;0;3 N;24;R;
  41129   "RTN","CHM XWBUT",329 ,0)
  41130           ;; 4.FILE GRO UP COUNT;" GROUP NUMB ER";2;R;0; 3N;26;R;
  41131   "RTN","CHM XWBUT",330 ,0)
  41132           ;; 5.CREATION  DATE;$E(D ATESTAMP,1 ,7);8;L;;8 AN;28;R;
  41133   "RTN","CHM XWBUT",331 ,0)
  41134           ;; 6.CREATION  TIME;$E(D ATESTAMP,9 ,14);6;L;; 6N;36;R;
  41135   "RTN","CHM XWBUT",332 ,0)
  41136           ;; 7.TRADING  PARTNER ID ;"VAFNH";1 0;L;;10AN; 42;R;
  41137   "RTN","CHM XWBUT",333 ,0)
  41138           ;; 8.SUBMITTE R NAME;"SU BMITTER NA ME";30;L;; 30AN;53;R;
  41139   "RTN","CHM XWBUT",334 ,0)
  41140           ;; 9.PAYER CO NTACT NAME ;"PAYER CO NTACT NAME ";60;L;;60 AN;83;O;
  41141   "RTN","CHM XWBUT",335 ,0)
  41142           ;; 10.PAYER S UPPORT TEL EPHONE NUM BER;"";10; L;;10N;143 ;O;
  41143   "RTN","CHM XWBUT",336 ,0)
  41144           ;; 11.PAYER S UPPORT EMA IL ADDRESS ;"";80;L;; 80AN;153;O ;
  41145   "RTN","CHM XWBUT",337 ,0)
  41146           ;; 12.LOAD TY PE;"LOADTY PE";1;L;;1 AN;233;R;
  41147   "RTN","CHM XWBUT",338 ,0)
  41148           ;; 13.PAYER U NIQUE FILE  IDENTIFIE R;DATESTAM P;20;L;;20 AN;234;R;
  41149   "RTN","CHM XWBUT",339 ,0)
  41150           ;; 14.FILE TY PE;"CStat" ;5;L;;5AN; 254;R;
  41151   "RTN","CHM XWBUT",340 ,0)
  41152           ;; 15.VERSION  CODE;"03" ;2;L;;2AN; 258;R;
  41153   "RTN","CHM XWBUT",341 ,0)
  41154           ;; 16.RELEASE  CODE;"00" ;2;L;;2AN; 260;R;
  41155   "RTN","CHM XWBUT",342 ,0)
  41156           ;; 18.END OF  RECORD;
  41157   "RTN","CHM XWBUT",343 ,0)
  41158           
  41159   "RTN","CHM XWBUT",344 ,0)
  41160    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  41161   "RTN","CHM XWBUT",345 ,0)
  41162    ; DOCUMEN TREC (UTIL ITY THAT H ELPS IN DO CUMENTING  THE RECORD  GENERATIO N PROCESS)  ;
  41163   "RTN","CHM XWBUT",346 ,0)
  41164    ; CREATES  A FILE TH AT CONTAIN S THE RECO RD INFORMA TION FOR T HE 5010                                ;
  41165   "RTN","CHM XWBUT",347 ,0)
  41166    ; EMDEON  STATUS REC ORDS, INCL UDING THE  HEADER, CL AIM, LINE  ITEM, AND  TRAILER    ;
  41167   "RTN","CHM XWBUT",348 ,0)
  41168    ; RECORDS .  THIS FU NCTION USE S THE FIEL D DESCRIPT ORS TO DOC UMENT EACH  FIELD IN  ;
  41169   "RTN","CHM XWBUT",349 ,0)
  41170    ; THE REC ORDS, I.E. :                                                                                                                              ;
  41171   "RTN","CHM XWBUT",350 ,0)
  41172    ;      1)  RECORD NA ME                                                                                                                                      ;
  41173   "RTN","CHM XWBUT",351 ,0)
  41174    ;      2)  STARTING  LOCATION I N THE RECO RD                                                                                              ;
  41175   "RTN","CHM XWBUT",352 ,0)
  41176    ;      3)  LENGTH (W IDTH) OF T HE FIELD                                                                                                   ;
  41177   "RTN","CHM XWBUT",353 ,0)
  41178    ;      4)  JUSTIFICA TION WITHI N THE FIEL D                                                                                               ;
  41179   "RTN","CHM XWBUT",354 ,0)
  41180    ;      5)  THE VALUE  (HARD COD ED FIELDS)  OR THE CA CHE FILELO CATION FRO M WHICH TH E       ;
  41181   "RTN","CHM XWBUT",355 ,0)
  41182    ;               VALU E IS RETRI EVED.                                                                                                               ;
  41183   "RTN","CHM XWBUT",356 ,0)
  41184    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  41185   "RTN","CHM XWBUT",357 ,0)
  41186    
  41187   "RTN","CHM XWBUT",358 ,0)
  41188   DOCUMENTRE C
  41189   "RTN","CHM XWBUT",359 ,0)
  41190    N DOCFILE ,TMPIO,LN, HTABS,FTAB S,RTYPE,RN AME,CHTYPE ,STR,COLNM S,DATESTAM P
  41191   "RTN","CHM XWBUT",360 ,0)
  41192    S DATESTA MP=$$FMDAT E("XDT")
  41193   "RTN","CHM XWBUT",361 ,0)
  41194    S RTYPE=" SAMPLEHDR"              ; NAMES  OF $TEXT T ABLES
  41195   "RTN","CHM XWBUT",362 ,0)
  41196    S COLNMS= "FIELD NAM E^USE^DESC ^PAD^JUST^ VALUE"           ; CO LUMN HEADE R NAMES
  41197   "RTN","CHM XWBUT",363 ,0)
  41198    S HTABS=" 35^39^45^5 0^57"                         ;  HEADER TAB  STOPS FOR  THE FIELD  DESCRIPTI ONS
  41199   "RTN","CHM XWBUT",364 ,0)
  41200    S FTABS=" 36^39^46^5 2^57"                         ;  FIELD TAB  STOPS FOR  DESCRIPTIO NS
  41201   "RTN","CHM XWBUT",365 ,0)
  41202    S DOCPATH ="SYS$LOGI N:" 
  41203   "RTN","CHM XWBUT",366 ,0)
  41204    S DOCFILE ="DOC277_5 010_"_DATE STAMP_".TX T"      ;  STATUS MAP PING DOCUM ENTATION
  41205   "RTN","CHM XWBUT",367 ,0)
  41206    S DOCFILE =DOCPATH_D OCFILE                                          ; OUTP UT THE $TE XT TO A PR INTABLE FI LE
  41207   "RTN","CHM XWBUT",368 ,0)
  41208    W !,"OUTP UT FILE=", DOCFILE
  41209   "RTN","CHM XWBUT",369 ,0)
  41210    ;S FLAG=$ $OFILE^CHM XWBUT(DOCF ILE,"NWS")
  41211   "RTN","CHM XWBUT",370 ,0)
  41212    S FLAG=$$ OPENFIWR^C HTFLIB9(.D OCFILE,"DO CFILE") 
  41213   "RTN","CHM XWBUT",371 ,0)
  41214    S TMPIO=$ IO U DOCFI LE
  41215   "RTN","CHM XWBUT",372 ,0)
  41216    F CHTYPE= 1:1  S RNA ME=$P(RTYP E,"^",CHTY PE) Q:RNAM E=""  D
  41217   "RTN","CHM XWBUT",373 ,0)
  41218    .W !!,?20 ,"HEALTH C ARE CLEARI NG HOUSE " "",RNAME," ""  RECORD  DEFINITIO NS"        ; TITLE
  41219   "RTN","CHM XWBUT",374 ,0)
  41220    .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)
  41221   "RTN","CHM XWBUT",375 ,0)
  41222    .F LN=1:1  S STR=$T( @RNAME+LN)  Q:STR["EN D OF RECOR D"  D          ; READ  $TEXT DES CRIPTOR
  41223   "RTN","CHM XWBUT",376 ,0)
  41224    ..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)
  41225   "RTN","CHM XWBUT",377 ,0)
  41226    U TMPIO 
  41227   "RTN","CHM XWBUT",378 ,0)
  41228    ;D CLOSEF ILE^CHMXWB UT(DOCFILE )                  ;  CLOSE CURR ENT FILE
  41229   "RTN","CHM XWBUT",379 ,0)
  41230    D CLOSEF^ CHTFLIB9(D OCFILE,"DO CFILE")
  41231   "RTN","CHM XWBUT",380 ,0)
  41232    Q
  41233   "RTN","CHM XWBUT",381 ,0)
  41234           
  41235   "RTN","CHM XWBUT",382 ,0)
  41236    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41237   "RTN","CHM XWBUT",383 ,0)
  41238    ; EXTDATE (FMDT) Tak es the fil eman date  and conver ts it to Y YYYMMDD fo rmat                        ;
  41239   "RTN","CHM XWBUT",384 ,0)
  41240    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;  
  41241   "RTN","CHM XWBUT",385 ,0)
  41242    
  41243   "RTN","CHM XWBUT",386 ,0)
  41244   EXTDATE(FM DT)
  41245   "RTN","CHM XWBUT",387 ,0)
  41246    ;      FM DT    The  date in fi leman form at CCYYMMD D (seconds  are ignor ed if sent )
  41247   "RTN","CHM XWBUT",388 ,0)
  41248    ;RETURNS        the  date in EX TERNAL (YY YYMMDD) fo rmat  
  41249   "RTN","CHM XWBUT",389 ,0)
  41250           Q: $G(FMDT)=" " ""
  41251   "RTN","CHM XWBUT",390 ,0)
  41252           S  FMDT=$E(FM DT,1,7)
  41253   "RTN","CHM XWBUT",391 ,0)
  41254           N  X,%H,%Y,%T
  41255   "RTN","CHM XWBUT",392 ,0)
  41256           S  X=FMDT                                   ;  X Must be  set to Fil eman Date  String
  41257   "RTN","CHM XWBUT",393 ,0)
  41258           D  H^%DTC                                   ;  Convert Fi leman to $ H
  41259   "RTN","CHM XWBUT",394 ,0)
  41260           Q  $ZD(%H,8)                                ;  Convert $H  to YYYYMM DD
  41261   "RTN","CHM XWBUT",395 ,0)
  41262    
  41263   "RTN","CHM XWBUT",396 ,0)
  41264    
  41265   "RTN","CHM XWBUT",397 ,0)
  41266   GETDATE(ST R)    ; US ER RESPONS E FOR DATE  INPUT
  41267   "RTN","CHM XWBUT",398 ,0)
  41268    ;      ST R     MESS AGE FOR TH E DATE YOU  WANT ENTE RED (I.E " ENTER STAR T DATE")
  41269   "RTN","CHM XWBUT",399 ,0)
  41270   A3 W !! S  %DT="AEPX" ,%DT("A")= STR D ^%DT  
  41271   "RTN","CHM XWBUT",400 ,0)
  41272           G: X="^" ENDX  G:X="^^"  ENDX G:Y=- 1 A3
  41273   "RTN","CHM XWBUT",401 ,0)
  41274   ENDX Q Y
  41275   "RTN","CHM XWBUT",402 ,0)
  41276    
  41277   "RTN","CHM XWBUT",403 ,0)
  41278    
  41279   "RTN","CHM XWBUT",404 ,0)
  41280    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41281   "RTN","CHM XWBUT",405 ,0)
  41282           ;  FMDATE(WHE N)  Return s ONLY the  FILEMAN f ormat Date  from the  NOW^%DTC F unction          ; 
  41283   "RTN","CHM XWBUT",406 ,0)
  41284    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;; 
  41285   "RTN","CHM XWBUT",407 ,0)
  41286    
  41287   "RTN","CHM XWBUT",408 ,0)
  41288   FMDATE(WHE N)
  41289   "RTN","CHM XWBUT",409 ,0)
  41290    ;      WH EN: Curren tly the op tions, "NO W","TIME"  ONLY,"XD:T " EXTERNAL  DATE:TIME
  41291   "RTN","CHM XWBUT",410 ,0)
  41292    ;RETURN:  Date in Fi leman Form at
  41293   "RTN","CHM XWBUT",411 ,0)
  41294    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41295   "RTN","CHM XWBUT",412 ,0)
  41296    ;Output V ariables f or the NOW ^%DTC                                                                                                               ; 
  41297   "RTN","CHM XWBUT",413 ,0)
  41298    ;      %        VA F ileMan dat e/time dow n to the s econd.                                                                               ;
  41299   "RTN","CHM XWBUT",414 ,0)
  41300    ;      %H       $H d ate/time.                                                                                                                                        ;
  41301   "RTN","CHM XWBUT",415 ,0)
  41302    ;      %I (1)   The  numeric va lue of the  month.                                                                                         ;
  41303   "RTN","CHM XWBUT",416 ,0)
  41304    ;      %I (2)   The  numeric va lue of the  day.                                                                                           ;
  41305   "RTN","CHM XWBUT",417 ,0)
  41306    ;      %I (3)   The  numeric va lue of the  year.                                                                                          ;
  41307   "RTN","CHM XWBUT",418 ,0)
  41308    ;      X                 VA Fil eMan date  only.                                                                                                             ;
  41309   "RTN","CHM XWBUT",419 ,0)
  41310    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41311   "RTN","CHM XWBUT",420 ,0)
  41312    
  41313   "RTN","CHM XWBUT",421 ,0)
  41314    N DATE,TI ME,CHHMM
  41315   "RTN","CHM XWBUT",422 ,0)
  41316    D NOW^%DT C
  41317   "RTN","CHM XWBUT",423 ,0)
  41318    S CHDT=$E (%,1,7),CH FMDTE=$E(% ,4,7)
  41319   "RTN","CHM XWBUT",424 ,0)
  41320       S CMMD D=$E(%,4,7 ),CHHMMSS= $E(%,9,14) ,CHHMM=$E( %,9,12)
  41321   "RTN","CHM XWBUT",425 ,0)
  41322       I $L(C HHMMSS)<6  S CHHMMSS= CHHMMSS_"1 11111",CHH MMSS=$E(CH HMMSS,1,6)
  41323   "RTN","CHM XWBUT",426 ,0)
  41324    S DATE=X, TIME=CHHMM SS 
  41325   "RTN","CHM XWBUT",427 ,0)
  41326           I  WHEN="NOW"     Q %                                                           ;%= FILEMA N DATE+TIM E
  41327   "RTN","CHM XWBUT",428 ,0)
  41328           I  WHEN="DAY"     Q X                                                  ;X= FILE MAN YYMMDD
  41329   "RTN","CHM XWBUT",429 ,0)
  41330    I WHEN="T IME"  S X= % D H^%DTC  Q %T                       ; Re turn the F M format d ate:time
  41331   "RTN","CHM XWBUT",430 ,0)
  41332    I WHEN="X DT"   Q $$ FMTOYYYYMM DD(DATE)_C HHMM ; EXT . DATE WIT H HOUR&MIN UTE
  41333   "RTN","CHM XWBUT",431 ,0)
  41334    I WHEN="D T"    Q:$E (%,1,7)
  41335   "RTN","CHM XWBUT",432 ,0)
  41336    I WHEN="F MD:T" Q:$E (%,4,7)
  41337   "RTN","CHM XWBUT",433 ,0)
  41338    I WHEN="H MS6"  Q:$E (%,9,14)
  41339   "RTN","CHM XWBUT",434 ,0)
  41340    I WHEN="Y EST"           S X1=D ATE,X2=-1  D C^%DTC Q  X    ;YES TERDAY
  41341   "RTN","CHM XWBUT",435 ,0)
  41342    I WHEN="T OM"   S X1 =DATE,X2=1  D C^%DTC  Q X              ;TOM ORROW
  41343   "RTN","CHM XWBUT",436 ,0)
  41344    I WHEN="B 1W"            S X1=D ATE,X2=-7  D C^%DTC Q  X    ;BAC K ONE WEEK
  41345   "RTN","CHM XWBUT",437 ,0)
  41346    I WHEN="F 1W"   S X1 =DATE,X2=7  D C^%DTC  Q X              ;FOR WARD ONE W EEK       
  41347   "RTN","CHM XWBUT",438 ,0)
  41348           Q  0                                                                                             ; 0  return for  non-speci fied "when "     
  41349   "RTN","CHM XWBUT",439 ,0)
  41350           
  41351   "RTN","CHM XWBUT",440 ,0)
  41352    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41353   "RTN","CHM XWBUT",441 ,0)
  41354    ; FMTOYYY YMMDD(FMDT ) Takes th e fileman  date and c onverts it  to yyyymm dd format          ;
  41355   "RTN","CHM XWBUT",442 ,0)
  41356    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;  
  41357   "RTN","CHM XWBUT",443 ,0)
  41358    
  41359   "RTN","CHM XWBUT",444 ,0)
  41360   FMTOYYYYMM DD(FMDT)
  41361   "RTN","CHM XWBUT",445 ,0)
  41362    ;      FM DT    The  date in fi leman form at CCYYMMD D (seconds  are ignor ed if sent )
  41363   "RTN","CHM XWBUT",446 ,0)
  41364    ;RETURN         the  date in YY YYMMDD for mat     
  41365   "RTN","CHM XWBUT",447 ,0)
  41366           Q: $G(FMDT)=" " ""
  41367   "RTN","CHM XWBUT",448 ,0)
  41368           N  X,%H,%Y,%T
  41369   "RTN","CHM XWBUT",449 ,0)
  41370           S  X=FMDT                                   ;  X Must be  set to Fil eman Date  String
  41371   "RTN","CHM XWBUT",450 ,0)
  41372           D  H^%DTC                                   ;  Convert Fi leman to $ H
  41373   "RTN","CHM XWBUT",451 ,0)
  41374           Q  $ZD(%H,8)                                ;  Convert $H  to YYYYMM DD
  41375   "RTN","CHM XWBUT",452 ,0)
  41376           
  41377   "RTN","CHM XWBUT",453 ,0)
  41378   FMTOHHMMSS (FMTIME)
  41379   "RTN","CHM XWBUT",454 ,0)
  41380    ;      FM TIME  THE  Fileman ti me to conv ert to hhm mss format
  41381   "RTN","CHM XWBUT",455 ,0)
  41382    ; RETURN:  THE CONVE RTED TIME
  41383   "RTN","CHM XWBUT",456 ,0)
  41384    N X,%F,CT
  41385   "RTN","CHM XWBUT",457 ,0)
  41386    S X=FMTIM E,%F=0,CT= $$FMTH^XLF DT(X,%F)
  41387   "RTN","CHM XWBUT",458 ,0)
  41388   GETHHMMSS( CT)
  41389   "RTN","CHM XWBUT",459 ,0)
  41390           N  HT,ZT,HH,M M,SS
  41391   "RTN","CHM XWBUT",460 ,0)
  41392           S  HT=$P(CT," ,",2)
  41393   "RTN","CHM XWBUT",461 ,0)
  41394           S  ZT=$ZT(HT, 1,9)         
  41395   "RTN","CHM XWBUT",462 ,0)
  41396           S  HH=$P(ZT," :",1)
  41397   "RTN","CHM XWBUT",463 ,0)
  41398           S  MM=$P(ZT," :",2)
  41399   "RTN","CHM XWBUT",464 ,0)
  41400           S  SS=$P($P(Z T,":",3)," .",1)
  41401   "RTN","CHM XWBUT",465 ,0)
  41402           Q  HH_MM_SS
  41403   "RTN","CHM XWBUT",466 ,0)
  41404    
  41405   "RTN","CHM XWBUT",467 ,0)
  41406    
  41407   "RTN","CHM XWBUT",468 ,0)
  41408    ; FILEMAN  PROGRAMME R MANUAL:  2.3.64 S^% DTC: Date/ Time Utili ty
  41409   "RTN","CHM XWBUT",469 ,0)
  41410    ; This en try takes  the number  of second s from mid night and  turns it 
  41411   "RTN","CHM XWBUT",470 ,0)
  41412    ; into ho urs, minut es, and se conds as a  decimal p art of a V A FileMan  date.     
  41413   "RTN","CHM XWBUT",471 ,0)
  41414   FMSDTC(SEC ONDS)
  41415   "RTN","CHM XWBUT",472 ,0)
  41416    ; SECONDS       THE  ELAPSED SE CONDS VALU E SINCE MI DNIGHT
  41417   "RTN","CHM XWBUT",473 ,0)
  41418    S %=SECON DS                                                                                   ;  USER SPECI FIED NUMBE R OF SECON DS
  41419   "RTN","CHM XWBUT",474 ,0)
  41420    S:SECONDS '>0 %=$P($ H,",",2)                                                 ; NUMBER  OF SECOND S SINCE MI DNIGHT
  41421   "RTN","CHM XWBUT",475 ,0)
  41422    D S^%DTC
  41423   "RTN","CHM XWBUT",476 ,0)
  41424    Q %
  41425   "RTN","CHM XWBUT",477 ,0)
  41426    
  41427   "RTN","CHM XWBUT",478 ,0)
  41428    
  41429   "RTN","CHM XWBUT",479 ,0)
  41430    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  41431   "RTN","CHM XWBUT",480 ,0)
  41432    ; BETWEEN  TESTS A D ATE TO BE  BETWEEN TW O OTHER DA TES.  I.E.  GIVEN TWO  DATES, ;
  41433   "RTN","CHM XWBUT",481 ,0)
  41434    ; "FROM"  DATE AND " TO" DATE,  THIS FUNCT ION RETURN S TRUE IF  THE USER D ATE         ;
  41435   "RTN","CHM XWBUT",482 ,0)
  41436    ; FALLS B ETWEEN THE  FROM AND  TO DATES.                                                                                  ;
  41437   "RTN","CHM XWBUT",483 ,0)
  41438    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  41439   "RTN","CHM XWBUT",484 ,0)
  41440    
  41441   "RTN","CHM XWBUT",485 ,0)
  41442   DATECHK(TD ATE,FDATE, UDATE)
  41443   "RTN","CHM XWBUT",486 ,0)
  41444    ;      TD ATE                     THE "TO"  BOUNDARY  DATE
  41445   "RTN","CHM XWBUT",487 ,0)
  41446    ;      FD ATE                     THE "FRO M BOUNDARY  DATE
  41447   "RTN","CHM XWBUT",488 ,0)
  41448    ;      UD ATE                     THE USER  DATE TO B E TESTED
  41449   "RTN","CHM XWBUT",489 ,0)
  41450    I UDATE>T DATE Q 0                ;FAIL IF  THE USER  DATE MORE  RECENT THA N THE "TO"  BOUNDARY
  41451   "RTN","CHM XWBUT",490 ,0)
  41452    I UDATE'> FDATE Q -1              ; FAIL I F USER DAT E IS BEFOR E/EQUAL TO  "FROM" BO UNDARY
  41453   "RTN","CHM XWBUT",491 ,0)
  41454    Q 1
  41455   "RTN","CHM XWBUT",492 ,0)
  41456    
  41457   "RTN","CHM XWBUT",493 ,0)
  41458    
  41459   "RTN","CHM XWBUT",494 ,0)
  41460    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  41461   "RTN","CHM XWBUT",495 ,0)
  41462    ; UTILITY  FUNCTION  WRITTEN TO  DUMP A ^C HMXCLE(I,n nn,J,0) NO DE.
  41463   "RTN","CHM XWBUT",496 ,0)
  41464    ; WHERE I  IS THE CL AIM INDEX  INTO THE ^ CHMXCLE FI LE
  41465   "RTN","CHM XWBUT",497 ,0)
  41466    ;               nnn  IS THE NOD E NUMBER ( i.e. 39, 4 0, 41, ETC )
  41467   "RTN","CHM XWBUT",498 ,0)
  41468    ;               J IS  THE "J" I NDEX FOR T HE FILEMAN  MULTIPLE  (DUMPS ALL  "J" NODES )
  41469   "RTN","CHM XWBUT",499 ,0)
  41470    ;               "0"  IS THE ASS UMED VALUE  FOR THE L EAST SIGNI FICANT NOD E ADDRESS
  41471   "RTN","CHM XWBUT",500 ,0)
  41472    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  41473   "RTN","CHM XWBUT",501 ,0)
  41474    ; EXAMPLE  OUTPUT 
  41475   "RTN","CHM XWBUT",502 ,0)
  41476    ; (NOTE:  ONLY POPUL ATED FIELD S ARE OUTP UT BY FILE MAN FUNCTI ON)
  41477   "RTN","CHM XWBUT",503 ,0)
  41478    ;
  41479   "RTN","CHM XWBUT",504 ,0)
  41480    ; DUMP NO DE: ^CHMXC LE(1096242 5,39,1,0)
  41481   "RTN","CHM XWBUT",505 ,0)
  41482    ;
  41483   "RTN","CHM XWBUT",506 ,0)
  41484    ; HC CODE  QUALIFIER  #1: BK                  HC CODE  #1: 338.2 9
  41485   "RTN","CHM XWBUT",507 ,0)
  41486    ; HC CODE  AMOUNT #1 : 0                    HC CODE A MOUNT #2:  0
  41487   "RTN","CHM XWBUT",508 ,0)
  41488    ; HC CODE  AMOUNT #3 : 0                    HC CODE A MOUNT #4:  0
  41489   "RTN","CHM XWBUT",509 ,0)
  41490    ; HC CODE  QTY #1: 0                        HC CODE Q TY #2: 0
  41491   "RTN","CHM XWBUT",510 ,0)
  41492    ; HC CODE  QTY #3: 0                        HC CODE Q TY #4: 0
  41493   "RTN","CHM XWBUT",511 ,0)
  41494    ;
  41495   "RTN","CHM XWBUT",512 ,0)
  41496    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41497   "RTN","CHM XWBUT",513 ,0)
  41498    
  41499   "RTN","CHM XWBUT",514 ,0)
  41500   TSTFMDUMP  ; EXAMPLE  FOR USING  THE FMDUMP  FUNCTION
  41501   "RTN","CHM XWBUT",515 ,0)
  41502    N INDEX S  I=1096242 5
  41503   "RTN","CHM XWBUT",516 ,0)
  41504    N NVAL S  N=39
  41505   "RTN","CHM XWBUT",517 ,0)
  41506    D FMDUMP( INDEX,NVAL )
  41507   "RTN","CHM XWBUT",518 ,0)
  41508    Q
  41509   "RTN","CHM XWBUT",519 ,0)
  41510    
  41511   "RTN","CHM XWBUT",520 ,0)
  41512   FMDUMP(IVA L,NODE)
  41513   "RTN","CHM XWBUT",521 ,0)
  41514    ;      IV AL    CLAI M INDEX FO R ^CHMXCLE (I)
  41515   "RTN","CHM XWBUT",522 ,0)
  41516    ;      NO DE    NODE  NUMBER (3 9,40,ETC.)
  41517   "RTN","CHM XWBUT",523 ,0)
  41518    N JVAL,NO DE1  S JVA L=0
  41519   "RTN","CHM XWBUT",524 ,0)
  41520    F  S JVAL =$O(^CHMXC LE(IVAL,NO DE,JVAL))   Q:JVAL'?1 N.N  D
  41521   "RTN","CHM XWBUT",525 ,0)
  41522    .W !,"DUM P NODE: ^C HMXCLE(",I VAL,",",NO DE,",",JVA L,",0)",!!
  41523   "RTN","CHM XWBUT",526 ,0)
  41524    .S DA(1)= IVAL,DA=JV AL 
  41525   "RTN","CHM XWBUT",527 ,0)
  41526    .S DIC="^ CHMXCLE"_" ("_IVAL_", "_NODE_","   
  41527   "RTN","CHM XWBUT",528 ,0)
  41528    .D EN^DIQ
  41529   "RTN","CHM XWBUT",529 ,0)
  41530    Q      
  41531   "RTN","CHM XWBUT",530 ,0)
  41532    
  41533   "RTN","CHM XWBUT",531 ,0)
  41534    
  41535   "RTN","CHM XWBUT",532 ,0)
  41536    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41537   "RTN","CHM XWBUT",533 ,0)
  41538    ; THE FOL LOWING FUN CTION TAKE S THE USER  PROVIDED  PDI, EXTRA CTS THE BU FFER
  41539   "RTN","CHM XWBUT",534 ,0)
  41540    ; INDEXES  FOR THE C LAIM BUFFE RS, THEN M AKES A CAL L TO FILEM AN TO DUMP  THE
  41541   "RTN","CHM XWBUT",535 ,0)
  41542    ; CONTENT S FOR EACH  OF THE CL AIM BUFFER S: ^CHMXCL A(837 TRAN SACTION, ^ CHMXCLB(
  41543   "RTN","CHM XWBUT",536 ,0)
  41544    ; PROVIDE R, ^CHMXCL C(PATIENT,  ^CHMXCLE( CLAIM, AND  ^CHMXCLF( LINE ITEM.  
  41545   "RTN","CHM XWBUT",537 ,0)
  41546    ; THIS SH OULD BE A  USEFUL TOO L FOR QA A ND PST WHE N TESTING/ VERIFYING  DATA
  41547   "RTN","CHM XWBUT",538 ,0)
  41548    ; FOR DAY  TO DAY OP ERATIONS.
  41549   "RTN","CHM XWBUT",539 ,0)
  41550    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;
  41551   "RTN","CHM XWBUT",540 ,0)
  41552    
  41553   "RTN","CHM XWBUT",541 ,0)
  41554   TEST
  41555   "RTN","CHM XWBUT",542 ,0)
  41556    N ANS,CHR EFN,CHPCN, CHMXCLI,CH MXID,CHAI, CHBTCH,CHB I,CHCI,CHE I,CHFI 
  41557   "RTN","CHM XWBUT",543 ,0)
  41558    W !!,"Ent er REFEREN CE (PDI) N UMBER:  "  D SBRS
  41559   "RTN","CHM XWBUT",544 ,0)
  41560    Q:$D(DUOU T)  Q:$D(D FOUT)
  41561   "RTN","CHM XWBUT",545 ,0)
  41562    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
  41563   "RTN","CHM XWBUT",546 ,0)
  41564    I $D(DQOU T) D HLP2  G TEST
  41565   "RTN","CHM XWBUT",547 ,0)
  41566    Q:Y=""  I  Y=" ",'$D (^DISV(DUZ ,"REFNO"))  W "No def ault Refer ence Numbe r."
  41567   "RTN","CHM XWBUT",548 ,0)
  41568    I Y'?15N  D HLP3 G T EST
  41569   "RTN","CHM XWBUT",549 ,0)
  41570    S:$D(Y) C HREFN=Y S  ^DISV(DUZ, "REFNO")=Y
  41571   "RTN","CHM XWBUT",550 ,0)
  41572    I '$D(^CH MXCLE("PDI ",CHREFN))  D MSG1 Q
  41573   "RTN","CHM XWBUT",551 ,0)
  41574    S CHPCN=" "
  41575   "RTN","CHM XWBUT",552 ,0)
  41576    S CHPCN=$ O(^CHMXCLE ("PDI",CHR EFN,CHPCN) ) I CHPCN= "" D MSG2  Q ;VALID P DI,NO DATA
  41577   "RTN","CHM XWBUT",553 ,0)
  41578    S CHMXCLI =0
  41579   "RTN","CHM XWBUT",554 ,0)
  41580    S CHMXCLI =$O(^CHMXC LE("PDI",C HREFN,CHPC N,CHMXCLI) ) I 'CHMXC LI D MSG2  Q ;VALID P DI, NO DAT A
  41581   "RTN","CHM XWBUT",555 ,0)
  41582    S CHMXID= ""
  41583   "RTN","CHM XWBUT",556 ,0)
  41584    S CHMXID= $O(^CHMXCL E("PDI",CH REFN,CHPCN ,CHMXCLI,C HMXID)) I  CHMXID=""  D MSG2 Q 
  41585   "RTN","CHM XWBUT",557 ,0)
  41586    S CHAI=$P (CHMXID,"* ",1) W !!, "A(I)= ",C HAI
  41587   "RTN","CHM XWBUT",558 ,0)
  41588    S CHBTCH= $P(^CHMXCL A(CHAI,0), "^",1) 
  41589   "RTN","CHM XWBUT",559 ,0)
  41590    S CHBI=$P (CHMXID,"* ",2) W !," B(I)= ",CH BI
  41591   "RTN","CHM XWBUT",560 ,0)
  41592    S CHCI=$P (CHMXID,"* ",3) W !," C(I)= ",CH CI
  41593   "RTN","CHM XWBUT",561 ,0)
  41594    S CHEI=$P (CHMXID,"* ",4) W !," E(I)= ",CH EI
  41595   "RTN","CHM XWBUT",562 ,0)
  41596    S CHFI=0, CHFI=$O(^C HMXCLF("B" ,CHEI,CHFI )) W !,"F( I)= ",CHFI ,!!!
  41597   "RTN","CHM XWBUT",563 ,0)
  41598    W !,"PDI:  ",CHREFN, " WAS PROC ESSED FROM  BATCH FIL E: ^CHMXCL (",CHBTCH, !!
  41599   "RTN","CHM XWBUT",564 ,0)
  41600    W !,"NOTE :  THE FOL LOWING DAT A IS EXTRA CTED FROM  THE CLAIM  BUFFERS"
  41601   "RTN","CHM XWBUT",565 ,0)
  41602    W !,"        FILEMAN  DOES NOT  OUTPUT EMP TY FIELDS,  SO THE IN FORMATION"
  41603   "RTN","CHM XWBUT",566 ,0)
  41604    W !,"        YOU SEE  REPRESENT S ALL THE  NODES/FIEL DS THAT AR E POPULATE D.",!!
  41605   "RTN","CHM XWBUT",567 ,0)
  41606    D BTCHDUM P(CHBTCH)
  41607   "RTN","CHM XWBUT",568 ,0)
  41608    Q:$D(DUOU T)
  41609   "RTN","CHM XWBUT",569 ,0)
  41610    D ABDUMP( CHAI)
  41611   "RTN","CHM XWBUT",570 ,0)
  41612    Q:$D(DUOU T)
  41613   "RTN","CHM XWBUT",571 ,0)
  41614    D BBDUMP( CHBI)
  41615   "RTN","CHM XWBUT",572 ,0)
  41616    Q:$D(DUOU T)
  41617   "RTN","CHM XWBUT",573 ,0)
  41618    D CBDUMP( CHCI)
  41619   "RTN","CHM XWBUT",574 ,0)
  41620    Q:$D(DUOU T)
  41621   "RTN","CHM XWBUT",575 ,0)
  41622    D EBDUMP( CHEI)
  41623   "RTN","CHM XWBUT",576 ,0)
  41624    Q:$D(DUOU T)
  41625   "RTN","CHM XWBUT",577 ,0)
  41626    D FBDUMP( CHFI)
  41627   "RTN","CHM XWBUT",578 ,0)
  41628    Q
  41629   "RTN","CHM XWBUT",579 ,0)
  41630    
  41631   "RTN","CHM XWBUT",580 ,0)
  41632   BTCHDUMP(I VAL)
  41633   "RTN","CHM XWBUT",581 ,0)
  41634    W !,?10," 837 CLAIM  BATCH FILE  ^CHMXCL(" ,IVAL,",0) ",!!
  41635   "RTN","CHM XWBUT",582 ,0)
  41636    S DA=IVAL
  41637   "RTN","CHM XWBUT",583 ,0)
  41638    S DIC="^C HMXCL"_"("  
  41639   "RTN","CHM XWBUT",584 ,0)
  41640    D EN^DIQ
  41641   "RTN","CHM XWBUT",585 ,0)
  41642    Q 
  41643   "RTN","CHM XWBUT",586 ,0)
  41644    
  41645   "RTN","CHM XWBUT",587 ,0)
  41646   ABDUMP(IVA L)
  41647   "RTN","CHM XWBUT",588 ,0)
  41648    W !,?10," 837 TRANSA CTION BUFF ER ^CHMXCL A(",IVAL," ,0)",!!
  41649   "RTN","CHM XWBUT",589 ,0)
  41650    S DA=IVAL
  41651   "RTN","CHM XWBUT",590 ,0)
  41652    S DIC="^C HMXCLA"_"(
  41653   "RTN","CHM XWBUT",591 ,0)
  41654    D EN^DIQ
  41655   "RTN","CHM XWBUT",592 ,0)
  41656    Q 
  41657   "RTN","CHM XWBUT",593 ,0)
  41658    
  41659   "RTN","CHM XWBUT",594 ,0)
  41660   BBDUMP(IVA L)
  41661   "RTN","CHM XWBUT",595 ,0)
  41662    N NODE  S  NODE=1
  41663   "RTN","CHM XWBUT",596 ,0)
  41664    W !?10,"P ROVIDER BU FFER  ^CHM XCLB(",IVA L,",0)",!!
  41665   "RTN","CHM XWBUT",597 ,0)
  41666    S DA=IVAL
  41667   "RTN","CHM XWBUT",598 ,0)
  41668    S DIC="^C HMXCLB"_"(
  41669   "RTN","CHM XWBUT",599 ,0)
  41670    D EN^DIQ
  41671   "RTN","CHM XWBUT",600 ,0)
  41672    Q 
  41673   "RTN","CHM XWBUT",601 ,0)
  41674    
  41675   "RTN","CHM XWBUT",602 ,0)
  41676   CBDUMP(IVA L)
  41677   "RTN","CHM XWBUT",603 ,0)
  41678    W !,?10," PATIENT BU FFER ^CHMX CLC(",IVAL ,",0)",!!
  41679   "RTN","CHM XWBUT",604 ,0)
  41680    S DA=IVAL
  41681   "RTN","CHM XWBUT",605 ,0)
  41682    S DIC="^C HMXCLC"_"(
  41683   "RTN","CHM XWBUT",606 ,0)
  41684    D EN^DIQ
  41685   "RTN","CHM XWBUT",607 ,0)
  41686    Q 
  41687   "RTN","CHM XWBUT",608 ,0)
  41688    
  41689   "RTN","CHM XWBUT",609 ,0)
  41690   EBDUMP(IVA L)
  41691   "RTN","CHM XWBUT",610 ,0)
  41692    W !,?10," CLAIM BUFF ER ^CHMXCL E(",IVAL," ,0)",!!
  41693   "RTN","CHM XWBUT",611 ,0)
  41694    S DA=IVAL
  41695   "RTN","CHM XWBUT",612 ,0)
  41696    S DIC="^C HMXCLE"_"(
  41697   "RTN","CHM XWBUT",613 ,0)
  41698    D EN^DIQ
  41699   "RTN","CHM XWBUT",614 ,0)
  41700    Q
  41701   "RTN","CHM XWBUT",615 ,0)
  41702    
  41703   "RTN","CHM XWBUT",616 ,0)
  41704   FBDUMP(IVA L)
  41705   "RTN","CHM XWBUT",617 ,0)
  41706    N CLMID,T STVAL,EXIT
  41707   "RTN","CHM XWBUT",618 ,0)
  41708    S CLMID=$ P(^CHMXCLF (IVAL,0)," ^",1),EXIT =0
  41709   "RTN","CHM XWBUT",619 ,0)
  41710    F  S TSTV AL=$P($G(^ CHMXCLF(IV AL,0)),"^" ,1) Q:EXIT   D
  41711   "RTN","CHM XWBUT",620 ,0)
  41712    .I TSTVAL '=CLMID S  EXIT=1 Q
  41713   "RTN","CHM XWBUT",621 ,0)
  41714    .W !,"LIN E ITEM BUF FER ^CHMXC LF(",IVAL, ",0)  CLM  #:",CLMID, "      LIN E NUMBER:  ",$P(^CHMX CLF(IVAL,0 ),"^",2),! !
  41715   "RTN","CHM XWBUT",622 ,0)
  41716    .S DA=IVA L
  41717   "RTN","CHM XWBUT",623 ,0)
  41718    .S DIC="^ CHMXCLF"_" (" 
  41719   "RTN","CHM XWBUT",624 ,0)
  41720    .D EN^DIQ
  41721   "RTN","CHM XWBUT",625 ,0)
  41722    .S IVAL=I VAL+1
  41723   "RTN","CHM XWBUT",626 ,0)
  41724    Q  
  41725   "RTN","CHM XWBUT",627 ,0)
  41726    
  41727   "RTN","CHM XWBUT",628 ,0)
  41728    
  41729   "RTN","CHM XWBUT",629 ,0)
  41730   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"
  41731   "RTN","CHM XWBUT",630 ,0)
  41732    Q
  41733   "RTN","CHM XWBUT",631 ,0)
  41734    ; 
  41735   "RTN","CHM XWBUT",632 ,0)
  41736   HLP2 W !!, "Enter the  HAC Refer ence Numbe r to look  up."
  41737   "RTN","CHM XWBUT",633 ,0)
  41738    Q
  41739   "RTN","CHM XWBUT",634 ,0)
  41740    ; 
  41741   "RTN","CHM XWBUT",635 ,0)
  41742   HLP3 W !!, "The HAC R eference N umber MUST  be 15 cha racters in  length, e g: 2000158 00000154"
  41743   "RTN","CHM XWBUT",636 ,0)
  41744    W !!,"Pre ss <RETURN > to Conti nue . . .  ." R X:999
  41745   "RTN","CHM XWBUT",637 ,0)
  41746    Q
  41747   "RTN","CHM XWBUT",638 ,0)
  41748    
  41749   "RTN","CHM XWBUT",639 ,0)
  41750   MSG1 W !!, "That HAC  Reference  Number cou ld NOT be  found in t he EDI Buf fer Files. "
  41751   "RTN","CHM XWBUT",640 ,0)
  41752    W !,"Plea se contact  OCIO HELP  DESK if y ou believe  this to b e an error ."
  41753   "RTN","CHM XWBUT",641 ,0)
  41754    Q
  41755   "RTN","CHM XWBUT",642 ,0)
  41756    ; 
  41757   "RTN","CHM XWBUT",643 ,0)
  41758   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."
  41759   "RTN","CHM XWBUT",644 ,0)
  41760    Q
  41761   "RTN","CHM XWBUT",645 ,0)
  41762    ; 
  41763   "RTN","CHM XWBUT",646 ,0)
  41764   SBRS R Y:$ S($D(DTIME ):DTIME,1: 999)
  41765   "RTN","CHM XWBUT",647 ,0)
  41766    I '$T W * 7 R Y:999  G SBRS:Y=" ." S:'$T Y =IOZFO
  41767   "RTN","CHM XWBUT",648 ,0)
  41768   SBRS1 K DF OUT,DUOUT, DQOUT 
  41769   "RTN","CHM XWBUT",649 ,0)
  41770    S:'$D(IOZ FO) IOZFO= "^^" 
  41771   "RTN","CHM XWBUT",650 ,0)
  41772    S:'$D(IOZ BK) IOZBK= "^"
  41773   "RTN","CHM XWBUT",651 ,0)
  41774    I IOZFO=Y  W:$D(IOZF ) @IOZF S  (DFOUT,Y)= "" Q
  41775   "RTN","CHM XWBUT",652 ,0)
  41776    S:Y=IOZBK  (DUOUT,Y) ="" 
  41777   "RTN","CHM XWBUT",653 ,0)
  41778    S:Y?1"?". E!(Y["^")  (DQOUT,Y)= ""
  41779   "RTN","CHM XWBUT",654 ,0)
  41780    Q
  41781   "RTN","CHM XWBUT",655 ,0)
  41782    ;
  41783   "RTN","CHM XWBUT",656 ,0)
  41784    
  41785   "RTN","CHM XWBUT",657 ,0)
  41786    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  41787   "RTN","CHM XWBUT",658 ,0)
  41788    ; MORE_SC ROLL_EXIT  FUNCTION P ROVIDED FO R QA IN RE SPONSE TO  THE STATIS TICS REPOR T
  41789   "RTN","CHM XWBUT",659 ,0)
  41790    ; DATA DI SPLAY.  JE FF N. REQU IRED THIS  CAPABILITY  FOR VIEWI NG THE STA TISTICS
  41791   "RTN","CHM XWBUT",660 ,0)
  41792    ; DETAIL  REPORT WHE N IT HAS B EEN SET TO  "VIEW" MO DE.
  41793   "RTN","CHM XWBUT",661 ,0)
  41794    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  41795   "RTN","CHM XWBUT",662 ,0)
  41796    
  41797   "RTN","CHM XWBUT",663 ,0)
  41798   MOSCREX(PA GE)   ; "M ORE","SCRO LL","EXIT"  ROUTINE
  41799   "RTN","CHM XWBUT",664 ,0)
  41800   GET W !!," ENTER ""M" " -OR- ""< CR>"" FOR  MORE, ""S" " FOR SCRO LL, ""^^""  TO EXIT:   "
  41801   "RTN","CHM XWBUT",665 ,0)
  41802    S Y="" D  SBRS  
  41803   "RTN","CHM XWBUT",666 ,0)
  41804    S PAGE=$S ("Mm"[Y:($ Y+20),"Ss" [Y:0,1:($Y +20))
  41805   "RTN","CHM XWBUT",667 ,0)
  41806    Q PAGE
  41807   "RTN","CHM XWBUT",668 ,0)
  41808    
  41809   "RTN","CHM XWBUT",669 ,0)
  41810    
  41811   "RTN","CHM XWBUT",670 ,0)
  41812    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;
  41813   "RTN","CHM XWBUT",671 ,0)
  41814    ; OUTPUT  DEBUG STAT EMENTS TO  A LOGFILE. TXT IN THE  TARGET DI RECTORY FO R THE 
  41815   "RTN","CHM XWBUT",672 ,0)
  41816    ; PRIMARY  STATUS. T HIS FUNCTI ON USES A  PREVIOUSLY  CREATED I O ("LOGFIL E"), OR
  41817   "RTN","CHM XWBUT",673 ,0)
  41818    ; IF "LOG FILE" IS N OT DEFINED , OPENS A  FILE AN US ES THAT IO  FOR DEBUG  LOGGING.
  41819   "RTN","CHM XWBUT",674 ,0)
  41820    ; NOTE: T HE SXC (PH ARMACY) CL AIMS ALL U SE THE SAM E OUTPUT D IRECTORY
  41821   "RTN","CHM XWBUT",675 ,0)
  41822    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  41823   "RTN","CHM XWBUT",676 ,0)
  41824    ; EXAMPLE  USAGE: D  DEBUG^CHMX MDRV("DEBU G OUTPUT=  ",VARIABLE )
  41825   "RTN","CHM XWBUT",677 ,0)
  41826    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  41827   "RTN","CHM XWBUT",678 ,0)
  41828    
  41829   "RTN","CHM XWBUT",679 ,0)
  41830    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  41831   "RTN","CHM XWBUT",680 ,0)
  41832    ; DEBUG L OGGING ROU TINE USED  TO LOG THE  FRONT END  EDIT PROC ESS, INCLU DING THE 
  41833   "RTN","CHM XWBUT",681 ,0)
  41834    ; RECORDS  READ FROM  THE CLAIM  FILE, THE  FUNCTIONS  CALLED TO  PERFORM T HE EDITS,
  41835   "RTN","CHM XWBUT",682 ,0)
  41836    ; AND THE  LOGGING O F THE ERRO RS ENCOUNT ERED FROM  THE EDIT P ROCESS.
  41837   "RTN","CHM XWBUT",683 ,0)
  41838    ; THE INT ENDED USE  FOR THIS F UNCTION IS  IN  THE D EVELOPMENT  OR TEST E NVIRONMENT S
  41839   "RTN","CHM XWBUT",684 ,0)
  41840    ; AND TO  ENSURE THA T IT IS NO T EXECUTED  IN THE "P RODUCTION"  ENVIRONME NT
  41841   "RTN","CHM XWBUT",685 ,0)
  41842    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;;
  41843   "RTN","CHM XWBUT",686 ,0)
  41844      
  41845   "RTN","CHM XWBUT",687 ,0)
  41846   DEBUG(STR, VALUE)
  41847   "RTN","CHM XWBUT",688 ,0)
  41848    ;      ST R              A USER  PROVIDED  STRING DES CRIBING TH E VALUE (I .E. "RECOR D INFORMAT ION=",
  41849   "RTN","CHM XWBUT",689 ,0)
  41850    ;   VALUE       THE  VALUE TO B E DISPLAYE D IN THE L OG FOR THE  LOGGING E NTRY.
  41851   "RTN","CHM XWBUT",690 ,0)
  41852    N ENV,TMP IO
  41853   "RTN","CHM XWBUT",691 ,0)
  41854           S  ENV=$$ENVI R^CHTFLIB(
  41855   "RTN","CHM XWBUT",692 ,0)
  41856    Q:ENV["LI VE"                                      ;  CHECK THE  CURRENT WO RKING ENVI RONMENT
  41857   "RTN","CHM XWBUT",693 ,0)
  41858    S TMPIO=$ IO                                                                           ; SAVE THE  CURRENT I O VARIABLE
  41859   "RTN","CHM XWBUT",694 ,0)
  41860    I '$D(LOG FILE) D                                                             ; IF NO  LOGFILE CR EATED, CRE ATE ONE
  41861   "RTN","CHM XWBUT",695 ,0)
  41862    .S LOGFIL E="CHAMPVA _USER:[VHA HACBUNTAD] ACCLOGFILE .TXT" ; TR AGET OUTPU T DIR/FILE NAME
  41863   "RTN","CHM XWBUT",696 ,0)
  41864           .; O LOGFILE: "NWS":5 ;  DEBUG OUTP UT FILE                            ; OPEN T HE LOGFILE
  41865   "RTN","CHM XWBUT",697 ,0)
  41866           .I  '$$OPENFI WR^CHTFLIB 9(.LOGFILE ,"LOGFILE" ) Q        ; DEF01655 4 02/04/20 14
  41867   "RTN","CHM XWBUT",698 ,0)
  41868           U  LOGFILE W  !,STR,VALU E                                                              ;  OUTPUT LOG GING STATE MENT
  41869   "RTN","CHM XWBUT",699 ,0)
  41870           U  TMPIO                                                                                                  ; REST ORE TO THE  ORIGINAL  IO
  41871   "RTN","CHM XWBUT",700 ,0)
  41872           Q
  41873   "RTN","CHM XWBUT",701 ,0)
  41874    
  41875   "RTN","CHM XWBUT",702 ,0)
  41876    
  41877   "RTN","CHM XWBUT",703 ,0)
  41878           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;
  41879   "RTN","CHM XWBUT",704 ,0)
  41880           ;  A NUMBER O F ROUTINES , IN PARTI CULAR THE  EDI BUFFER  DISPLAY R OUTINE CHM XIN01.INT
  41881   "RTN","CHM XWBUT",705 ,0)
  41882           ;  SET UP SCR EEN PARAME TERS FOR D ISPLAYING  DATA FROM  THE CACHE  GLOBAL FIL ES.  THE
  41883   "RTN","CHM XWBUT",706 ,0)
  41884           ;  PURPOSE OF  THIS ROUT INE IS TO  "RESET" TH E SCREEN T O ALLOW SC ROLLING OF  DATA IN
  41885   "RTN","CHM XWBUT",707 ,0)
  41886           ;  A NORMAL P ROCESS.  T HIS HAS BE EN ADDED T O THIS UTI LITY ROUTI NE TO TO A LLOW A MOR E
  41887   "RTN","CHM XWBUT",708 ,0)
  41888           ;  GENERIC LO CATION FOR  THE FUNCT ION.
  41889   "RTN","CHM XWBUT",709 ,0)
  41890           ;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;
  41891   "RTN","CHM XWBUT",710 ,0)
  41892           
  41893   "RTN","CHM XWBUT",711 ,0)
  41894   RESETSCR
  41895   "RTN","CHM XWBUT",712 ,0)
  41896    S (IOF,IO ZF)="#,*27 ,*91,*50,* 74,*27,*91 ,*72"
  41897   "RTN","CHM XWBUT",713 ,0)
  41898    S CHALLOF F="*27,*91 ,*48,*109"     ;SKD
  41899   "RTN","CHM XWBUT",714 ,0)
  41900    S (CHMARE SE,CHMARES ET)="*27,* 91,*114"
  41901   "RTN","CHM XWBUT",715 ,0)
  41902    S CHRESET ="W @CHMAR ESE,@CHALL OFF,#,@IOZ F"   ;SKD
  41903   "RTN","CHM XWBUT",716 ,0)
  41904    XECUTE CH RESET
  41905   "RTN","CHM XWBUT",717 ,0)
  41906    Q
  41907   "RTN","CHM XWBUT",718 ,0)
  41908    
  41909   "RTN","CHM XWBUT",719 ,0)
  41910    
  41911   "RTN","CHM XWBUT",720 ,0)
  41912    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;
  41913   "RTN","CHM XWBUT",721 ,0)
  41914    ; R2D2 (R EAD 2, DIS PLAY 2) WI LL OUTPUT  THE FIRST  2 LINES OF  THE FILES  SPECIFIED .       
  41915   "RTN","CHM XWBUT",722 ,0)
  41916    ; THIS RO UTINE WAS  PLAGIERIZE D FROM THE  INTERSYST EMS FUNCTI ON RFIRST( ), WHICH
  41917   "RTN","CHM XWBUT",723 ,0)
  41918    ; DISPLAY S THE FIRS T LINE ONL Y OF THE S PECIFIED R OUTINES.   MODIFICATI ONS WERE 
  41919   "RTN","CHM XWBUT",724 ,0)
  41920    ; MADE TO  DISPLAY T HE SECOND  LINE IN OR DER TO CHE CK THE VIS TA "KIDS"  REQUIREMEN T
  41921   "RTN","CHM XWBUT",725 ,0)
  41922    ; FOR THE  FILEMAN B UILD HEADE R. 
  41923   "RTN","CHM XWBUT",726 ,0)
  41924    ;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;;;;;; ;;;;;  
  41925   "RTN","CHM XWBUT",727 ,0)
  41926    
  41927   "RTN","CHM XWBUT",728 ,0)
  41928   R2D2 ;Prin t first 2  lines of r outines ;L FT1320 11/ 02/04
  41929   "RTN","CHM XWBUT",729 ,0)
  41930    ;in order  of direct ory, routi ne name, e xtension,  version.
  41931   "RTN","CHM XWBUT",730 ,0)
  41932    ;%sySyste m.inc ; HY Y1347 09/2 0/07
  41933   "RTN","CHM XWBUT",731 ,0)
  41934    ;%sySt.in c  ;HYY134 7 09/20/07
  41935   "RTN","CHM XWBUT",732 ,0)
  41936    ; %system .inc: comp iled for U SEDYNPIDTA B
  41937   "RTN","CHM XWBUT",733 ,0)
  41938    ; %system .inc: comp iled for U SEDYNTTYHA SH
  41939   "RTN","CHM XWBUT",734 ,0)
  41940    ; %system .inc: comp iled for U SETTYHASH
  41941   "RTN","CHM XWBUT",735 ,0)
  41942    /*
  41943   "RTN","CHM XWBUT",736 ,0)
  41944    +-------- ---------- ---------- ---------- ---------- --------+
  41945   "RTN","CHM XWBUT",737 ,0)
  41946    | Copyrig ht 1986-20 08 by Inte rSystems C orporation ,       |
  41947   "RTN","CHM XWBUT",738 ,0)
  41948    | Cambrid ge, Massac husetts, U .S.A.                         |
  41949   "RTN","CHM XWBUT",739 ,0)
  41950    | All rig hts reserv ed.                                      |
  41951   "RTN","CHM XWBUT",740 ,0)
  41952    |                                                             |
  41953   "RTN","CHM XWBUT",741 ,0)
  41954    | Confide ntial, unp ublished p roperty of  InterSyst ems.    |
  41955   "RTN","CHM XWBUT",742 ,0)
  41956    |                                                             |
  41957   "RTN","CHM XWBUT",743 ,0)
  41958    | This me dia contai ns an auth orized cop y or copie s       |
  41959   "RTN","CHM XWBUT",744 ,0)
  41960    | of mate rial copyr ighted by  InterSyste ms and is  the     |
  41961   "RTN","CHM XWBUT",745 ,0)
  41962    | confide ntial, unp ublished p roperty of  InterSyst ems.    |
  41963   "RTN","CHM XWBUT",746 ,0)
  41964    | This co pyright no tice and a ny other c opyright n otices  |
  41965   "RTN","CHM XWBUT",747 ,0)
  41966    | include d in machi ne readabl e copies m ust be rep roduced |
  41967   "RTN","CHM XWBUT",748 ,0)
  41968    | on all  authorized  copies.                                 |
  41969   "RTN","CHM XWBUT",749 ,0)
  41970    +-------- ---------- ---------- ---------- ---------- --------+
  41971   "RTN","CHM XWBUT",750 ,0)
  41972    */
  41973   "RTN","CHM XWBUT",751 ,0)
  41974   NMAX I '$G (NMAX) N N MAX S NMAX =2 ;BB007
  41975   "RTN","CHM XWBUT",752 ,0)
  41976    ;EP with  'NMAX' = #  of top li nes to pri nt
  41977   "RTN","CHM XWBUT",753 ,0)
  41978    I '$D(NMA X) N NMAX  S NMAX=1
  41979   "RTN","CHM XWBUT",754 ,0)
  41980    N POP,%ms ub,SELF,CR T,PAGE,NEW PAGE,DEFDI R
  41981   "RTN","CHM XWBUT",755 ,0)
  41982    N DIRNAM, FROMDN,THR UDN,NOW,DA TES,%TIM
  41983   "RTN","CHM XWBUT",756 ,0)
  41984    N %A,%E,% X,%ANS,IO, IOF,IOM,IO ST,IOT,IOB S,IOPAR,IO SL,RMSDF
  41985   "RTN","CHM XWBUT",757 ,0)
  41986    ;
  41987   "RTN","CHM XWBUT",758 ,0)
  41988    D INT^%T  S NOW=$ZDA TE(+$H,2,, 4)_"  "_%T IM
  41989   "RTN","CHM XWBUT",759 ,0)
  41990    W !,"Prin t first "_ $S(NMAX=1: "line",1:N MAX_" comm ent lines" )
  41991   "RTN","CHM XWBUT",760 ,0)
  41992    W " of se lected rou tines or i nclude fil es.",!
  41993   "RTN","CHM XWBUT",761 ,0)
  41994    ;
  41995   "RTN","CHM XWBUT",762 ,0)
  41996    New %NOWI LDEXT Set  %NOWILDEXT =1
  41997   "RTN","CHM XWBUT",763 ,0)
  41998    D ^%RSETN ("Routine( s): ","SD" ,"MAC,INT, INC,BAS,MV B,MVI","DN EV") G KIL L:POP              ;  DAS462,DAS 472
  41999   "RTN","CHM XWBUT",764 ,0)
  42000    I $O(^mte mp(%msub," "))="" G K ILL
  42001   "RTN","CHM XWBUT",765 ,0)
  42002    ;
  42003   "RTN","CHM XWBUT",766 ,0)
  42004    D DATES ; get FROMDN , THRUDN
  42005   "RTN","CHM XWBUT",767 ,0)
  42006    ;
  42007   "RTN","CHM XWBUT",768 ,0)
  42008    N IOMS s  IOMS=$Syst em.Device. GetRightMa rgin()
  42009   "RTN","CHM XWBUT",769 ,0)
  42010    W !!,"Out put on" D  OUT^%IS G  KILL:POP
  42011   "RTN","CHM XWBUT",770 ,0)
  42012    S SELF=($ I=IO),CRT= ($E(IOST)= "C") S:'SE LF CRT=0
  42013   "RTN","CHM XWBUT",771 ,0)
  42014    S NEWPAGE =1,PAGE="" ,DEFDIR=$$ DEFDIR()
  42015   "RTN","CHM XWBUT",772 ,0)
  42016    ;
  42017   "RTN","CHM XWBUT",773 ,0)
  42018    U IO D DO IT I 'SELF  U IO W @I OF C IO
  42019   "RTN","CHM XWBUT",774 ,0)
  42020    U:SELF IO :IOMS 
  42021   "RTN","CHM XWBUT",775 ,0)
  42022   KILL I $D( %msub) K ^ mtemp(%msu b)
  42023   "RTN","CHM XWBUT",776 ,0)
  42024    U 0 Q
  42025   "RTN","CHM XWBUT",777 ,0)
  42026   DEFDIR() N  %A,%ST,DE ND,DIRNAM, GD,RD,NUMM AP D DEFAU LT^%SYS.FI LE C 63 Q  DIRNAM
  42027   "RTN","CHM XWBUT",778 ,0)
  42028   DOIT ;go t hrough the  selected  routines a nd print o ut the fir st lines
  42029   "RTN","CHM XWBUT",779 ,0)
  42030    N SD,SYS, DIR,EXT,VE R,ROU,BRAC KET,DATE,X ,I,N,T,COU NT
  42031   "RTN","CHM XWBUT",780 ,0)
  42032    S SD=""
  42033   "RTN","CHM XWBUT",781 ,0)
  42034   SD S SD=$O (^mtemp(%m sub,SD)) I  SD="" Q
  42035   "RTN","CHM XWBUT",782 ,0)
  42036    S SYS=$P( SD,"@"),DI R=$P(SD,"@ ",2),ROU=" ",NEWPAGE= 1,COUNT=0
  42037   "RTN","CHM XWBUT",783 ,0)
  42038   ROU S ROU= $O(^mtemp( %msub,SD,R OU)) I ROU ="" G SD
  42039   "RTN","CHM XWBUT",784 ,0)
  42040    S EXT=""  F  S EXT=$ O(^mtemp(% msub,SD,RO U,EXT)) Q: EXT=""  D
  42041   "RTN","CHM XWBUT",785 ,0)
  42042    . S VER=" " F  S VER =$O(^mtemp (%msub,SD, ROU,EXT,VE R)) Q:VER= ""  D EXT
  42043   "RTN","CHM XWBUT",786 ,0)
  42044    Q:POP  G  ROU
  42045   "RTN","CHM XWBUT",787 ,0)
  42046   EXT ;for e ach extens ion, go th rough the  versions
  42047   "RTN","CHM XWBUT",788 ,0)
  42048    S BRACKET =""
  42049   "RTN","CHM XWBUT",789 ,0)
  42050    S:DIR]""  BRACKET=$S (SYS="":"| """_DIR_"" "|",1:"|"" ^"_SYS_"^" _DIR_"""|" )
  42051   "RTN","CHM XWBUT",790 ,0)
  42052    D ONEROU
  42053   "RTN","CHM XWBUT",791 ,0)
  42054    Q
  42055   "RTN","CHM XWBUT",792 ,0)
  42056   VER S VER= $O(^mtemp( %msub,SD,R OU,EXT,VER )) I VER=" " Q
  42057   "RTN","CHM XWBUT",793 ,0)
  42058    D ONEROU  G VER
  42059   "RTN","CHM XWBUT",794 ,0)
  42060   ONEROU ;fo r one rout ine, figur e it all o ut
  42061   "RTN","CHM XWBUT",795 ,0)
  42062    I EXT="IN T" N VER S  VER=0
  42063   "RTN","CHM XWBUT",796 ,0)
  42064    ;DAS351+        
  42065   "RTN","CHM XWBUT",797 ,0)
  42066    I EXT="BA S"!(EXT="M VI") N VER  S VER=0                    ; DA S462,DAS47 2
  42067   "RTN","CHM XWBUT",798 ,0)
  42068    ;DAS351-
  42069   "RTN","CHM XWBUT",799 ,0)
  42070    S DATE=$$ DATE() I F ROMDN]"",D ATE<FROMDN  Q  ;too e arly
  42071   "RTN","CHM XWBUT",800 ,0)
  42072    I THRUDN] "",DATE>TH RUDN Q  ;t oo late
  42073   "RTN","CHM XWBUT",801 ,0)
  42074    ;
  42075   "RTN","CHM XWBUT",802 ,0)
  42076    N NAME S  NAME=ROU_" ."_EXT_$S( VER>1:"."_ VER,1:"")
  42077   "RTN","CHM XWBUT",803 ,0)
  42078    D CHKDY(N MAX+4) Q:P OP
  42079   "RTN","CHM XWBUT",804 ,0)
  42080    S COUNT=C OUNT+1 ;nu mber of ro utines pri nted
  42081   "RTN","CHM XWBUT",805 ,0)
  42082    I 'SELF U  0 W:COUNT -1#5=0 ! W  ?(COUNT-1 #5*15),NAM E_" " U IO
  42083   "RTN","CHM XWBUT",806 ,0)
  42084    ;
  42085   "RTN","CHM XWBUT",807 ,0)
  42086    W !,NAME_ " " ;start  with the  routine na me
  42087   "RTN","CHM XWBUT",808 ,0)
  42088    N NL,NSP  S NSP=$P(B RACKET,"|" ,2),NL=$$L ENGTH^%R(R OU_"."_EXT _"."_VER,N SP)
  42089   "RTN","CHM XWBUT",809 ,0)
  42090    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
  42091   "RTN","CHM XWBUT",810 ,0)
  42092    I NMAX>1, $X W ! ;en d with a b lank line
  42093   "RTN","CHM XWBUT",811 ,0)
  42094    Q
  42095   "RTN","CHM XWBUT",812 ,0)
  42096   ONET I N>N MAX S N=0  Q  ;too ma ny lines a lready
  42097   "RTN","CHM XWBUT",813 ,0)
  42098    I N=1 G O UT ;force  printing i t
  42099   "RTN","CHM XWBUT",814 ,0)
  42100    I $P(T,"  ",2,999)?. " "1";".E  G OUT ;it  is a comme nt
  42101   "RTN","CHM XWBUT",815 ,0)
  42102    I T?." "1 "#"1A.E G  OUT ;it's  a compiler  directive
  42103   "RTN","CHM XWBUT",816 ,0)
  42104    S N=0 Q   ;otherwise , skip it
  42105   "RTN","CHM XWBUT",817 ,0)
  42106   OUT ;print  out T on  one or mor e lines, g iven IOM
  42107   "RTN","CHM XWBUT",818 ,0)
  42108    S X=$P(T, " "),X=$E( X_$J("",7) ,1,7)_$E(X ,8,99)_" " _$P(T," ", 2,999)
  42109   "RTN","CHM XWBUT",819 ,0)
  42110    S TB=$S($ X>15:$X,1: 15)
  42111   "RTN","CHM XWBUT",820 ,0)
  42112   LOOP W ?TB ,$E(X,1,IO M-TB-1),!  S X=$E(X,I OM-TB,*),T B=15 I X]" " G LOOP
  42113   "RTN","CHM XWBUT",821 ,0)
  42114    Q
  42115   "RTN","CHM XWBUT",822 ,0)
  42116   CHKDY(Y) I  'NEWPAGE, $Y+Y'>IOSL  Q  ;no ne ed for new  page
  42117   "RTN","CHM XWBUT",823 ,0)
  42118    I CRT,PAG E]"" N C W  ! D MORE  Q:POP  ;BB 008
  42119   "RTN","CHM XWBUT",824 ,0)
  42120    S NEWPAGE =0,COUNT=0 ,PAGE=0 W  @IOF ;skip  to new pa ge
  42121   "RTN","CHM XWBUT",825 ,0)
  42122    D CC("Fir st Line"_$ S(NMAX=1:" ",1:"s")_"  of Select ed Routine s Files")
  42123   "RTN","CHM XWBUT",826 ,0)
  42124    I DATES]" " D CC(DAT ES)
  42125   "RTN","CHM XWBUT",827 ,0)
  42126    S X=$S(DI R="":DEFDI R,1:DIR)_$ S(SYS]"":"   -  Direc tory Set:  "_SYS,1:"" )
  42127   "RTN","CHM XWBUT",828 ,0)
  42128    D CC("Dir ectory: "_ X) I 'CRT  D CC(NOW)
  42129   "RTN","CHM XWBUT",829 ,0)
  42130    W ! Q
  42131   "RTN","CHM XWBUT",830 ,0)
  42132   CC(X) W !? IOM-$L(X)\ 2,X Q
  42133   "RTN","CHM XWBUT",831 ,0)
  42134   MORE R !," --more--", *C I C'=10 ,C'=13,C'= 27,C'=32,C '=53 S POP =1 Q  ;BB0 08 ;BB151
  42135   "RTN","CHM XWBUT",832 ,0)
  42136    Q:C'=63   W "   Retu rn to cont inue ^ to  stop" G MO RE ;BB008
  42137   "RTN","CHM XWBUT",833 ,0)
  42138   DATES ;ask  a from-da te -> upto -date pair
  42139   "RTN","CHM XWBUT",834 ,0)
  42140    N %DS,%DN ,FROMDS,TH RUDS,ERR
  42141   "RTN","CHM XWBUT",835 ,0)
  42142   FROM R !," Find routi nes last m odified si nce date:  ",%DS S:%D S="" FROMD N=""
  42143   "RTN","CHM XWBUT",836 ,0)
  42144    I %DS="?"  W !!?4,"T o include  routines/i nclude fil es last mo dified"
  42145   "RTN","CHM XWBUT",837 ,0)
  42146    I  W !?4, "between s elected da tes, enter  FROM DATE  here.  To "
  42147   "RTN","CHM XWBUT",838 ,0)
  42148    I  W !?4, "include a ll routine s regardle ss of date , leave bl ank.",!
  42149   "RTN","CHM XWBUT",839 ,0)
  42150    I  G FROM
  42151   "RTN","CHM XWBUT",840 ,0)
  42152    I %DS]""  S %DS=$$UP (%DS) D Y2 D^%DATE S  FROMDN=%DN  I %DN<1 W  "  [???]"  G FROM ;B B174
  42153   "RTN","CHM XWBUT",841 ,0)
  42154    I %DS]""  S %DS=$ZDA TE(FROMDN, 2,,4) W "   ("_%DS_") "
  42155   "RTN","CHM XWBUT",842 ,0)
  42156   THRU R !,"                   and  on or bef ore date:  ",%DS S:%D S="" THRUD N=""
  42157   "RTN","CHM XWBUT",843 ,0)
  42158    I %DS="?"  W !!?4,"T o include  routines/i nclude fil es last mo dified"
  42159   "RTN","CHM XWBUT",844 ,0)
  42160    I  W !?4, "between s elected da tes, enter  THROUGH D ATE here.   To"
  42161   "RTN","CHM XWBUT",845 ,0)
  42162    I  W !?4, "include a ll routine s regardle ss of date , "
  42163   "RTN","CHM XWBUT",846 ,0)
  42164    I  W:FROM DN>0 "or s ince "_$ZD ATE(FROMDN ,2,,4)_",  " W ?4,"le ave blank. ",!
  42165   "RTN","CHM XWBUT",847 ,0)
  42166    I  G THRU
  42167   "RTN","CHM XWBUT",848 ,0)
  42168    I %DS]""  S %DS=$$UP (%DS) D Y2 D^%DATE S  THRUDN=%DN  I 1 ;BB17 4
  42169   "RTN","CHM XWBUT",849 ,0)
  42170    I  S ERR= $S(THRUDN< 1:"  [???] ",THRUDN<F ROMDN:"  [ ?backwards ]",1:"")
  42171   "RTN","CHM XWBUT",850 ,0)
  42172    I  I ERR] "" W ERR G  THRU
  42173   "RTN","CHM XWBUT",851 ,0)
  42174    I %DS]""  S %DS=$ZDA TE(THRUDN, 2,,4) W "   ("_%DS_") "
  42175   "RTN","CHM XWBUT",852 ,0)
  42176    I FROMDN_ THRUDN=""  S DATES=""  Q
  42177   "RTN","CHM XWBUT",853 ,0)
  42178    I FROMDN= "" S DATES ="Modified  on or Bef ore "_$ZDA TE(THRUDN, 2,,4) Q
  42179   "RTN","CHM XWBUT",854 ,0)
  42180    I THRUDN= "" S DATES ="Modified  on or Aft er "_$ZDAT E(FROMDN,2 ,,4) Q
  42181   "RTN","CHM XWBUT",855 ,0)
  42182    S DATES=" Modified b etween "_$ ZDATE(FROM DN,2,,4)_"  and "_$ZD ATE(THRUDN ,2,,4) Q
  42183   "RTN","CHM XWBUT",856 ,0)
  42184   DATE() ;gi ven DIR,SY S,VER; loo k for the  date of RO U/EXT
  42185   "RTN","CHM XWBUT",857 ,0)
  42186    n ENV 
  42187   "RTN","CHM XWBUT",858 ,0)
  42188    i SYS=""  s ENV=DIR
  42189   "RTN","CHM XWBUT",859 ,0)
  42190    e  s ENV= "^"_SYS_"^ "_DIR
  42191   "RTN","CHM XWBUT",860 ,0)
  42192    Q $$DATE^ %R(ROU_"." _EXT_"."_V ER,,ENV)
  42193   "RTN","CHM XWBUT",861 ,0)
  42194    Q ""
  42195   "RTN","CHM XWBUT",862 ,0)
  42196   UP(x) Q $z cvt(x,"u")
  42197   "RTN","CHM XWBUT",863 ,0)
  42198    
  42199   "RTN","CHP RD1")
  42200   0^68^B3646 2532
  42201   "RTN","CHP RD1",1,0)
  42202   CHPRD1 ;AE B/CVA;GENE RATES THE  SU PRODUCT IVITY REPO RT;10/10/9 6  3:07 PM
  42203   "RTN","CHP RD1",2,0)
  42204    ;;1.0;CHA MPVA SYSTE M;**14**;J ULY 4, 199 0;Build 5
  42205   "RTN","CHP RD1",3,0)
  42206    ;CPTS - 1 1061  AEB
  42207   "RTN","CHP RD1",4,0)
  42208    ;; US 005 -029 SBB 1 1/14/2017   - Fixing  Illegal su bscript er ror in CEN D. 
  42209   "RTN","CHP RD1",5,0)
  42210    ;;
  42211   "RTN","CHP RD1",6,0)
  42212   A2B K TMP, TMP1,^TMP1 ($J),^TMP( $J)
  42213   "RTN","CHP RD1",7,0)
  42214    S CHNDAY= 0
  42215   "RTN","CHP RD1",8,0)
  42216    S (DUPTOT ,MDQTOT,PS QTOT,QATOT ,CLMVQTOT, VNDVQTOT,E DTVQTOT,OH ITOT,ASQTO T)=0
  42217   "RTN","CHP RD1",9,0)
  42218    S (EDATE, DAT,CHDAYC K)=$P(STDA T,".",1)
  42219   "RTN","CHP RD1",10,0)
  42220    S CYR=$$F MADD^XLFDT (DAT,-364, 0,0,0),END DT1=ENDDT_ ".99999999 9"
  42221   "RTN","CHP RD1",11,0)
  42222    S EDATE=$ P(ENDDT1," .",1) D OL DCHK^CHPRD 2
  42223   "RTN","CHP RD1",12,0)
  42224   A21 S DAT= $O(^CHMPRO D(741060.0 2,DAT)) G: 'DAT CEND  G:DAT>ENDD T1 CEND
  42225   "RTN","CHP RD1",13,0)
  42226    S:'$D(SDA TE) SDATE= DAT
  42227   "RTN","CHP RD1",14,0)
  42228    S J1=0,CH TYPE="A",A NS="A"
  42229   "RTN","CHP RD1",15,0)
  42230   A22 S (DUP TOT,MDQTOT ,PSQTOT,QA TOT,CLMVQT OT,VNDVQTO T,EDTVQTOT ,OHITOT,AS QTOT)=0
  42231   "RTN","CHP RD1",16,0)
  42232    S J1=$O(^ CHMPROD(74 1060.02,DA T,1,J1)) G :'J1 A21
  42233   "RTN","CHP RD1",17,0)
  42234    I '$D(^CH MPROD(7410 60.02,DAT, 1,J1,0)) G  A22
  42235   "RTN","CHP RD1",18,0)
  42236    S REC1=^C HMPROD(741 060.02,DAT ,1,J1,0)
  42237   "RTN","CHP RD1",19,0)
  42238    S (SDUZ,E MPL)=$P(RE C1,"^",1)
  42239   "RTN","CHP RD1",20,0)
  42240    G:'$D(^CH MDIC(74100 2.21,EMPL) ) A22 G:'$ D(^CHMDIC( 741002.21, EMPL,0)) A 22
  42241   "RTN","CHP RD1",21,0)
  42242    I $P(^CHM DIC(741002 .21,EMPL,0 ),"^",16)' =1 G A22   ;MUST BE S ET AS SU Y ES
  42243   "RTN","CHP RD1",22,0)
  42244    I $P(^CHM DIC(741002 .21,EMPL,0 ),"^",21)= "" G A22   ;MUST BE P A VE OR SV E
  42245   "RTN","CHP RD1",23,0)
  42246    S CHSUCAT =$P(^CHMDI C(741002.2 1,EMPL,0), "^",21)
  42247   "RTN","CHP RD1",24,0)
  42248    I '$D(^CH MDIC(74100 2.21,EMPL, 500)) G A2 2
  42249   "RTN","CHP RD1",25,0)
  42250    S CHPRODT =99999999, CHPRODT=$O (^CHMDIC(7 41002.21,E MPL,500,CH PRODT),-1)  G:'CHPROD T A22
  42251   "RTN","CHP RD1",26,0)
  42252    I '$D(^CH MDIC(74100 2.21,EMPL, 500,CHPROD T,0)) G A2 2
  42253   "RTN","CHP RD1",27,0)
  42254    S GRD=$P( ^CHMDIC(74 1002.21,EM PL,500,CHP RODT,0),"^ ",3)
  42255   "RTN","CHP RD1",28,0)
  42256   ASQ S ASQT OT=ASQTOT+ $P(REC1,"^ ",2)+$P(RE C1,"^",3)+ $P(REC1,"^ ",4)
  42257   "RTN","CHP RD1",29,0)
  42258    S ASQTOT= ASQTOT+$P( REC1,"^",5 )+$P(REC1, "^",6)+$P( REC1,"^",7 )+$P(REC1, "^",8)
  42259   "RTN","CHP RD1",30,0)
  42260    S ASQTOT= ASQTOT+$P( REC1,"^",9 )+$P(REC1, "^",10)+$P (REC1,"^", 11)+$P(REC 1,"^",12)+ $P(REC1,"^ ",13)
  42261   "RTN","CHP RD1",31,0)
  42262    S ASQTOT= ASQTOT+$P( REC1,"^",2 7)+$P(REC1 ,"^",28)   ;aeb 12/31 /2007
  42263   "RTN","CHP RD1",32,0)
  42264   DCQ S DUPT OT=DUPTOT+ $P(REC1,"^ ",14)+$P(R EC1,"^",15 )
  42265   "RTN","CHP RD1",33,0)
  42266   MDQ S MDQT OT=MDQTOT+ $P(REC1,"^ ",25)
  42267   "RTN","CHP RD1",34,0)
  42268   PSQ S PSQT OT=PSQTOT+ $P(REC1,"^ ",26)
  42269   "RTN","CHP RD1",35,0)
  42270   QA S QATOT =QATOT+$P( REC1,"^",1 6)+$P(REC1 ,"^",17)
  42271   "RTN","CHP RD1",36,0)
  42272   CLMVQ S CL MVQTOT=CLM VQTOT+$P(R EC1,"^",20 )+$P(REC1, "^",21)
  42273   "RTN","CHP RD1",37,0)
  42274   VNDVQ S VN DVQTOT=VND VQTOT+$P(R EC1,"^",18 )+$P(REC1, "^",19)
  42275   "RTN","CHP RD1",38,0)
  42276   EDTVQ S ED TVQTOT=EDT VQTOT+$P(R EC1,"^",22 )
  42277   "RTN","CHP RD1",39,0)
  42278   OHICRT S O HITOT=OHIT OT+$P(REC1 ,"^",23)
  42279   "RTN","CHP RD1",40,0)
  42280    I '$D(^VA (200,EMPL, 0)) G A22
  42281   "RTN","CHP RD1",41,0)
  42282    S ENAME=$ P(^VA(200, EMPL,0),"^ ",1)
  42283   "RTN","CHP RD1",42,0)
  42284    ;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
  42285   "RTN","CHP RD1",43,0)
  42286    S:'$D(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME)) TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME )=""
  42287   "RTN","CHP RD1",44,0)
  42288    I '$D(^TM P1($J,EMPL ,$P(DAT,". ",1))) D   ;COUNTS TH E NUMBER O F DAYS
  42289   "RTN","CHP RD1",45,0)
  42290    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",20 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",20)+ 1
  42291   "RTN","CHP RD1",46,0)
  42292    .Q
  42293   "RTN","CHP RD1",47,0)
  42294    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
  42295   "RTN","CHP RD1",48,0)
  42296    I TMPASQ' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"AS Q")) D  ;A SQ DAY CNT
  42297   "RTN","CHP RD1",49,0)
  42298    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"ASQ")=0
  42299   "RTN","CHP RD1",50,0)
  42300    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",21 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",21)+ 1
  42301   "RTN","CHP RD1",51,0)
  42302    S TMPDCQ= $P(REC1,"^ ",14)+$P(R EC1,"^",15 )
  42303   "RTN","CHP RD1",52,0)
  42304    I TMPDCQ' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"DC Q")) D  ;D CQ DAY CNT
  42305   "RTN","CHP RD1",53,0)
  42306    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"DCQ")=0
  42307   "RTN","CHP RD1",54,0)
  42308    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",22 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",22)+ 1
  42309   "RTN","CHP RD1",55,0)
  42310    .Q
  42311   "RTN","CHP RD1",56,0)
  42312    I +$P(REC 1,"^",25)' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"MD Q")) D  ;M DQ DAY CNT
  42313   "RTN","CHP RD1",57,0)
  42314    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"MDQ")=0
  42315   "RTN","CHP RD1",58,0)
  42316    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",23 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",23)+ 1
  42317   "RTN","CHP RD1",59,0)
  42318    .Q
  42319   "RTN","CHP RD1",60,0)
  42320    I +$P(REC 1,"^",26)' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"PS Q")) D  ;p rob suppor t day cnt
  42321   "RTN","CHP RD1",61,0)
  42322    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"PSQ")=0
  42323   "RTN","CHP RD1",62,0)
  42324    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",24 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",24)+ 1
  42325   "RTN","CHP RD1",63,0)
  42326    .Q
  42327   "RTN","CHP RD1",64,0)
  42328    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
  42329   "RTN","CHP RD1",65,0)
  42330    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"QAQ")=0
  42331   "RTN","CHP RD1",66,0)
  42332    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",25 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",25)+ 1
  42333   "RTN","CHP RD1",67,0)
  42334    .Q
  42335   "RTN","CHP RD1",68,0)
  42336    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
  42337   "RTN","CHP RD1",69,0)
  42338    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"VCLM#") =0
  42339   "RTN","CHP RD1",70,0)
  42340    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",26 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",26)+ 1
  42341   "RTN","CHP RD1",71,0)
  42342    .Q
  42343   "RTN","CHP RD1",72,0)
  42344    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
  42345   "RTN","CHP RD1",73,0)
  42346    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"VNQ")=0
  42347   "RTN","CHP RD1",74,0)
  42348    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",27 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",27)+ 1
  42349   "RTN","CHP RD1",75,0)
  42350    .Q
  42351   "RTN","CHP RD1",76,0)
  42352    I +$P(REC 1,"^",22)' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"VN ED")) D  ; VEN EDITS  DAY CNT
  42353   "RTN","CHP RD1",77,0)
  42354    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"VNED")= 0
  42355   "RTN","CHP RD1",78,0)
  42356    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",28 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",28)+ 1
  42357   "RTN","CHP RD1",79,0)
  42358    .Q
  42359   "RTN","CHP RD1",80,0)
  42360    I +$P(REC 1,"^",23)' =0 I '$D(^ TMP1($J,EM PL,$P(DAT, ".",1),"CE RT")) D  ; CERY DAT C NT
  42361   "RTN","CHP RD1",81,0)
  42362    .S ^TMP1( $J,EMPL,$P (DAT,".",1 ),"CERT")= 0
  42363   "RTN","CHP RD1",82,0)
  42364    .S $P(TMP ("SU-BY-GR ADE",CHSUC AT,GRD,ENA ME),"^",29 )=$P(TMP(" SU-BY-GRAD E",CHSUCAT ,GRD,ENAME ),"^",29)+ 1
  42365   "RTN","CHP RD1",83,0)
  42366    .Q
  42367   "RTN","CHP RD1",84,0)
  42368   YTOT ;CURR ENT TOTALS
  42369   "RTN","CHP RD1",85,0)
  42370    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
  42371   "RTN","CHP RD1",86,0)
  42372    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
  42373   "RTN","CHP RD1",87,0)
  42374    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
  42375   "RTN","CHP RD1",88,0)
  42376    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
  42377   "RTN","CHP RD1",89,0)
  42378    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
  42379   "RTN","CHP RD1",90,0)
  42380    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
  42381   "RTN","CHP RD1",91,0)
  42382    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
  42383   "RTN","CHP RD1",92,0)
  42384    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
  42385   "RTN","CHP RD1",93,0)
  42386    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
  42387   "RTN","CHP RD1",94,0)
  42388    S:'$D(CHD UZL(EMPL))  CHDUZL(EM PL)=GRD_"^ "_ENAME_"^ "_CHSUCAT
  42389   "RTN","CHP RD1",95,0)
  42390    G A22
  42391   "RTN","CHP RD1",96,0)
  42392   CEND K ^TM P1($J)
  42393   "RTN","CHP RD1",97,0)
  42394    D VESTUF^ CHPRD5  ;G ETS SUBS P ROCESSED A ND CLAIMS  CREATED.
  42395   "RTN","CHP RD1",98,0)
  42396    ;SBB 11/1 4/2017 bug  fix
  42397   "RTN","CHP RD1",99,0)
  42398    ;K CHDUZL (EMPL)
  42399   "RTN","CHP RD1",100,0 )
  42400    I $G(EMPL )'="" K CH DUZL(EMPL)
  42401   "RTN","CHP RD1",101,0 )
  42402    I '$D(PFL G) G DSPLY ^CHPRD2
  42403   "RTN","CHP RD1",102,0 )
  42404    S %ZIS="Q ",IOP="Q;" _CHFIO D ^ %ZIS G:POP  END
  42405   "RTN","CHP RD1",103,0 )
  42406    S ZTRTN=" DSPLY^CHPR D2",ZTDTH= $H,ZTSAVE( "PFLG")="" ,ZTSAVE("S DATE")=""
  42407   "RTN","CHP RD1",104,0 )
  42408    S ZTSAVE( "EDATE")=" ",ZTSAVE(" TMP(""SU-B Y-GRADE"", ")="",ZTSA VE("STDAT" )=""
  42409   "RTN","CHP RD1",105,0 )
  42410    S ZTSAVE( "ENDDT1")= "" K ZTIO
  42411   "RTN","CHP RD1",106,0 )
  42412    D ^%ZTLOA D
  42413   "RTN","CHP RD1",107,0 )
  42414    Q
  42415   "RTN","CHP RD1",108,0 )
  42416   END ;
  42417   "RTN","CHP RD1",109,0 )
  42418    K TIM1,IO SUBS,IOCLM S,IOTIME,M SSUBS,MSCL MS,MSTIME, MMSUBS,MMC LMS,MMTIME
  42419   "RTN","CHP RD1",110,0 )
  42420    K DIOPDI, DIOCLM,DIO TIM,DMSPDI ,DMSCLM,DM STIM,DMMPD I,DMMCLM,D MMTIM,I1,J 1
  42421   "RTN","CHP RD1",111,0 )
  42422    Q
  42423   "RTN","CHR OLIB1")
  42424   0^72^B7079 9522
  42425   "RTN","CHR OLIB1",1,0 )
  42426   CHROLIB1   ;TGH/FTC;R EOPEN UTIL ITY LIBRAR Y;02/07/20 18 11:00 A M
  42427   "RTN","CHR OLIB1",2,0 )
  42428    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  42429   "RTN","CHR OLIB1",3,0 )
  42430    ; TGH - 2 /7/2018 -  CPE005-043
  42431   "RTN","CHR OLIB1",4,0 )
  42432   EDIPAUSE(O PDI,FPDI,S TAT,CHEI,E RROR) ; Fi nd and pro cess Reope ned PDI fo r the EDI- PAUSE
  42433   "RTN","CHR OLIB1",5,0 )
  42434    ;   INPUT  VARIABLES
  42435   "RTN","CHR OLIB1",6,0 )
  42436    ;   OPDI  = Original  PDI
  42437   "RTN","CHR OLIB1",7,0 )
  42438    ;   FPDI  = Current  PDI
  42439   "RTN","CHR OLIB1",8,0 )
  42440    ;   STAT  = 0 - Stop  EDI-PAUSE  - Set Pie ce 3
  42441   "RTN","CHR OLIB1",9,0 )
  42442    ;           1 - Star t EDI_PAUS E - Set Pi eces 1 and  2
  42443   "RTN","CHR OLIB1",10, 0)
  42444    ;   CHEI  = Buffer C laim Level  IEN
  42445   "RTN","CHR OLIB1",11, 0)
  42446    ;   RETUR N OUTPUT V ALUE
  42447   "RTN","CHR OLIB1",12, 0)
  42448    ;           1 - Star t or Stop  Performed
  42449   "RTN","CHR OLIB1",13, 0)
  42450    ;           0 - Igno red - EDI- PAUSE not  Required
  42451   "RTN","CHR OLIB1",14, 0)
  42452    ;   ERROR  - Text of  Error dur ing attemp ted Set of  Data 
  42453   "RTN","CHR OLIB1",15, 0)
  42454    ;
  42455   "RTN","CHR OLIB1",16, 0)
  42456    ; Initial  Checks
  42457   "RTN","CHR OLIB1",17, 0)
  42458    I OPDI=""  Q 0
  42459   "RTN","CHR OLIB1",18, 0)
  42460    I STAT=""  Q 0
  42461   "RTN","CHR OLIB1",19, 0)
  42462    I CHEI=""  Q 0
  42463   "RTN","CHR OLIB1",20, 0)
  42464    I '$D(^CH MIMG(OPDI, 0)) Q 0
  42465   "RTN","CHR OLIB1",21, 0)
  42466    I $D(^CHM XCLE(CHEI, 0)),$P(^CH MXCLE(CHEI ,0),"^",6) '=8 Q 0
  42467   "RTN","CHR OLIB1",22, 0)
  42468    I '$D(^CH MPAY("C",O PDI)) Q 0
  42469   "RTN","CHR OLIB1",23, 0)
  42470    I FPDI=""  Q 0
  42471   "RTN","CHR OLIB1",24, 0)
  42472    ;
  42473   "RTN","CHR OLIB1",25, 0)
  42474    ; Go thru  all claim s on Origi nal PDI an d process  if In-Proc ess and 
  42475   "RTN","CHR OLIB1",26, 0)
  42476    N IEN,STA TUS,DIE,DA ,DR,SUCCES S,CLM,ADD, FOUND
  42477   "RTN","CHR OLIB1",27, 0)
  42478    ;S (SUCCE SS,ADD,FOU ND)=0,IEN= ""
  42479   "RTN","CHR OLIB1",28, 0)
  42480    S (SUCCES S,ADD)=0,F OUND=1,IEN =""
  42481   "RTN","CHR OLIB1",29, 0)
  42482    I STAT=1  F  S IEN=$ O(^CHMPAY( "C",OPDI,I EN)) Q:IEN =""  D
  42483   "RTN","CHR OLIB1",30, 0)
  42484    .S STATUS =$P($G(^CH MPAY(IEN,0 )),"^",2)
  42485   "RTN","CHR OLIB1",31, 0)
  42486    .; If the  Status is  Rejected,  Complete,  Deleted,  Voided, or  Reversed  Do not pro cess
  42487   "RTN","CHR OLIB1",32, 0)
  42488    .I ",0,4, 5,10,11,12 ,"[(","_ST ATUS_",")  Q
  42489   "RTN","CHR OLIB1",33, 0)
  42490    .; For al l Claims s till being  processed  - Remove  Claim from  all Queue s then set  Claim to  Void
  42491   "RTN","CHR OLIB1",34, 0)
  42492    .;I STATU S'=2 D
  42493   "RTN","CHR OLIB1",35, 0)
  42494    .I STATUS '=2 D  S F OUND=0
  42495   "RTN","CHR OLIB1",36, 0)
  42496    ..N DA,DR ,DIE
  42497   "RTN","CHR OLIB1",37, 0)
  42498    ..D RMVCL M(IEN)
  42499   "RTN","CHR OLIB1",38, 0)
  42500    ..S DIE=7 41000,DA=I EN
  42501   "RTN","CHR OLIB1",39, 0)
  42502    ..S DR=". 02///11" D  ^DIE
  42503   "RTN","CHR OLIB1",40, 0)
  42504    ..S DR=". 13///404"  D ^DIE K D IE
  42505   "RTN","CHR OLIB1",41, 0)
  42506    .; If STA TUS is Pay ment Reque sted and S TAT is 1,  set START  for Curren t PDI into  EDI-PAUSE  queue
  42507   "RTN","CHR OLIB1",42, 0)
  42508    .;I STATU S=2 D  S F OUND=1
  42509   "RTN","CHR OLIB1",43, 0)
  42510    .I STATUS =2 D  
  42511   "RTN","CHR OLIB1",44, 0)
  42512    ..; If th e first ti me thru fo r this OPD I create E DI-PAUSE F ile
  42513   "RTN","CHR OLIB1",45, 0)
  42514    ..I 'ADD  S SUCCESS= $$STRTPYRQ (FPDI,.ERR OR)
  42515   "RTN","CHR OLIB1",46, 0)
  42516    ..I SUCCE SS S ADD=1
  42517   "RTN","CHR OLIB1",47, 0)
  42518    ..; If th e EDI-PAUS E was crea ted add th e Original  PDI Claim  Number to  the EDI-P AUSE File
  42519   "RTN","CHR OLIB1",48, 0)
  42520    ..I ADD S  SUCCESS(1 )=$$ADDCLM (FPDI,IEN, .ERROR)
  42521   "RTN","CHR OLIB1",49, 0)
  42522    ;
  42523   "RTN","CHR OLIB1",50, 0)
  42524    ; If none  of the cl aims on th e Original  PDI were  a 2-Paymen t Requeste d, void th e Original  PDI
  42525   "RTN","CHR OLIB1",51, 0)
  42526    I 'FOUND  D
  42527   "RTN","CHR OLIB1",52, 0)
  42528    .N CHEDRJ ,CHXREC
  42529   "RTN","CHR OLIB1",53, 0)
  42530    .S DIE=74 1000.2,DA= OPDI,DR=". 06///11" D  ^DIE K DI E
  42531   "RTN","CHR OLIB1",54, 0)
  42532    .S CHEDRJ ="E001b"
  42533   "RTN","CHR OLIB1",55, 0)
  42534    .S CHXREC =""
  42535   "RTN","CHR OLIB1",56, 0)
  42536    .D CRCSTA T^CHMFUTLE (OPDI,CHXR EC,CHEDRJ, "F")
  42537   "RTN","CHR OLIB1",57, 0)
  42538    ; 
  42539   "RTN","CHR OLIB1",58, 0)
  42540    ;If STAT  is 0, set  STOP for C urrent PDI  into EDI- PAUSE queu e
  42541   "RTN","CHR OLIB1",59, 0)
  42542    I STAT=0  D
  42543   "RTN","CHR OLIB1",60, 0)
  42544    .I FPDI'= "" S SUCCE SS=$$STOPP YRQ(FPDI,. ERROR)
  42545   "RTN","CHR OLIB1",61, 0)
  42546    Q SUCCESS
  42547   "RTN","CHR OLIB1",62, 0)
  42548    ;
  42549   "RTN","CHR OLIB1",63, 0)
  42550   STRTPYRQ(I EN,ERROR)   ; Update  EDI-PAUSE  queue for  Payment Re quest Stat us
  42551   "RTN","CHR OLIB1",64, 0)
  42552    ; If call ing this t ag from ou tside this  routine p lease New  IEN in cal ling routi ne
  42553   "RTN","CHR OLIB1",65, 0)
  42554    ; 
  42555   "RTN","CHR OLIB1",66, 0)
  42556    ; Validat e that the re is no S tarted EDI -PAUSE for  this PDI
  42557   "RTN","CHR OLIB1",67, 0)
  42558    I $D(^CHM IMG("EDIPA USE",IEN))  Q 0
  42559   "RTN","CHR OLIB1",68, 0)
  42560    ;
  42561   "RTN","CHR OLIB1",69, 0)
  42562    N DGENDA, IENS,IENA, DATA,FILE, FIELD,FDA, ERRORS,RET URN,DIERR
  42563   "RTN","CHR OLIB1",70, 0)
  42564    D NOW^%DT C
  42565   "RTN","CHR OLIB1",71, 0)
  42566    S DGENDA( 1)=IEN
  42567   "RTN","CHR OLIB1",72, 0)
  42568    S DGENDA= "+1"
  42569   "RTN","CHR OLIB1",73, 0)
  42570    S IENS=$$ IENS^DILF( .DGENDA)
  42571   "RTN","CHR OLIB1",74, 0)
  42572    S DATA(.0 1)=%
  42573   "RTN","CHR OLIB1",75, 0)
  42574    S DATA(1) =DUZ
  42575   "RTN","CHR OLIB1",76, 0)
  42576    S FILE=74 1000.35
  42577   "RTN","CHR OLIB1",77, 0)
  42578    S FIELD=0
  42579   "RTN","CHR OLIB1",78, 0)
  42580    F  S FIEL D=$O(DATA( FIELD)) Q: 'FIELD  S  FDA(FILE,I ENS,FIELD) =$G(DATA(F IELD))
  42581   "RTN","CHR OLIB1",79, 0)
  42582    D UPDATE^ DIE("","FD A","IENA", "ERRORS(1) ")
  42583   "RTN","CHR OLIB1",80, 0)
  42584    ;Collect  Errors and  return 0  if unsucce ssful
  42585   "RTN","CHR OLIB1",81, 0)
  42586    S RETURN= 1
  42587   "RTN","CHR OLIB1",82, 0)
  42588    I +$G(DIE RR) D
  42589   "RTN","CHR OLIB1",83, 0)
  42590    .S RETURN =0
  42591   "RTN","CHR OLIB1",84, 0)
  42592    .S ERROR= $G(ERRORS( 1,"DIERR", 1,"TEXT",1 ))
  42593   "RTN","CHR OLIB1",85, 0)
  42594    .S IEN=""
  42595   "RTN","CHR OLIB1",86, 0)
  42596    ;
  42597   "RTN","CHR OLIB1",87, 0)
  42598    Q RETURN
  42599   "RTN","CHR OLIB1",88, 0)
  42600    ;
  42601   "RTN","CHR OLIB1",89, 0)
  42602   ADDCLM(FPD I,CLM,ERR0 R)  ; Add  the Origin al PDI Cla im Number  to the EDI -PAUSE Fil e, 
  42603   "RTN","CHR OLIB1",90, 0)
  42604    ; allowin g for mult iples. If  calling th is tag fro m outside  this routi ne please  New 
  42605   "RTN","CHR OLIB1",91, 0)
  42606    ; and Ini tialize FP DI, CLM, a nd ERROR i n calling  routine
  42607   "RTN","CHR OLIB1",92, 0)
  42608    I '$D(^CH MIMG(FPDI, "EDI-PAUSE ",0)) Q 0
  42609   "RTN","CHR OLIB1",93, 0)
  42610    N NIEN,%
  42611   "RTN","CHR OLIB1",94, 0)
  42612    S NIEN=$P (^CHMIMG(F PDI,"EDI-P AUSE",0),U ,3)
  42613   "RTN","CHR OLIB1",95, 0)
  42614    I NIEN=""  Q 0
  42615   "RTN","CHR OLIB1",96, 0)
  42616    I $P(^CHM IMG(FPDI," EDI-PAUSE" ,NIEN,0),U ,3)'="" Q  0
  42617   "RTN","CHR OLIB1",97, 0)
  42618    ; Add Cla im Number  for Origin al PDI's P ayment Req uested in  EDI-PAUSE
  42619   "RTN","CHR OLIB1",98, 0)
  42620    N DGENDA, IENS,DATA, FILE,FIELD ,FDA,ERROR S,RETURN,D IERR
  42621   "RTN","CHR OLIB1",99, 0)
  42622    S DGENDA( 2)=FPDI
  42623   "RTN","CHR OLIB1",100 ,0)
  42624    S DGENDA( 1)=NIEN
  42625   "RTN","CHR OLIB1",101 ,0)
  42626    S DGENDA= $FN($P($G( ^CHMIMG(FP DI,"EDI-PA USE",NIEN, 1,0)),U,3) +1,"+")
  42627   "RTN","CHR OLIB1",102 ,0)
  42628    S IENS=$$ IENS^DILF( .DGENDA)
  42629   "RTN","CHR OLIB1",103 ,0)
  42630    S DATA(.0 1)=CLM
  42631   "RTN","CHR OLIB1",104 ,0)
  42632    S FILE=74 1000.353
  42633   "RTN","CHR OLIB1",105 ,0)
  42634    S FIELD=0
  42635   "RTN","CHR OLIB1",106 ,0)
  42636    F  S FIEL D=$O(DATA( FIELD)) Q: 'FIELD  S  FDA(FILE,I ENS,FIELD) =$G(DATA(F IELD))
  42637   "RTN","CHR OLIB1",107 ,0)
  42638    D UPDATE^ DIE("","FD A","IENA", "ERRORS(1) ")
  42639   "RTN","CHR OLIB1",108 ,0)
  42640    ;Collect  Errors and  return 0  if unsucce ssful
  42641   "RTN","CHR OLIB1",109 ,0)
  42642    S RETURN= 1
  42643   "RTN","CHR OLIB1",110 ,0)
  42644    I +$G(DIE RR) D
  42645   "RTN","CHR OLIB1",111 ,0)
  42646    .S RETURN =0
  42647   "RTN","CHR OLIB1",112 ,0)
  42648    .S ERROR= $G(ERRORS( 1,"DIERR", 1,"TEXT",1 ))
  42649   "RTN","CHR OLIB1",113 ,0)
  42650    .S IEN=""
  42651   "RTN","CHR OLIB1",114 ,0)
  42652    ;
  42653   "RTN","CHR OLIB1",115 ,0)
  42654    Q RETURN
  42655   "RTN","CHR OLIB1",116 ,0)
  42656    ;
  42657   "RTN","CHR OLIB1",117 ,0)
  42658   STOPPYRQ(F PDI,ERROR)   ; Update  EDI-PAUSE  queue for  Payment R equest Sta tus
  42659   "RTN","CHR OLIB1",118 ,0)
  42660    ; If call ing this t ag from ou tside this  routine p lease New  FPDI in ca lling rout ine
  42661   "RTN","CHR OLIB1",119 ,0)
  42662    I '$D(^CH MIMG(FPDI, "EDI-PAUSE ",0)) Q 0
  42663   "RTN","CHR OLIB1",120 ,0)
  42664    N NIEN,%
  42665   "RTN","CHR OLIB1",121 ,0)
  42666    S NIEN=$P (^CHMIMG(F PDI,"EDI-P AUSE",0),U ,3)
  42667   "RTN","CHR OLIB1",122 ,0)
  42668    I NIEN=""  Q 0
  42669   "RTN","CHR OLIB1",123 ,0)
  42670    I $P(^CHM IMG(FPDI," EDI-PAUSE" ,NIEN,0),U ,3)'="" Q  0
  42671   "RTN","CHR OLIB1",124 ,0)
  42672    ; Set STO P for Paym ent Reques t in EDI-P AUSE
  42673   "RTN","CHR OLIB1",125 ,0)
  42674    N DGENDA, IENS,DATA, FILE,FIELD ,FDA,ERROR S,RETURN,D IERR
  42675   "RTN","CHR OLIB1",126 ,0)
  42676    D NOW^%DT C
  42677   "RTN","CHR OLIB1",127 ,0)
  42678    S DGENDA( 1)=FPDI
  42679   "RTN","CHR OLIB1",128 ,0)
  42680    S DGENDA= NIEN
  42681   "RTN","CHR OLIB1",129 ,0)
  42682    S IENS=$$ IENS^DILF( .DGENDA)
  42683   "RTN","CHR OLIB1",130 ,0)
  42684    S DATA(2) =%
  42685   "RTN","CHR OLIB1",131 ,0)
  42686    S FILE=74 1000.35
  42687   "RTN","CHR OLIB1",132 ,0)
  42688    S FIELD=0
  42689   "RTN","CHR OLIB1",133 ,0)
  42690    F  S FIEL D=$O(DATA( FIELD)) Q: 'FIELD  S  FDA(FILE,I ENS,FIELD) =$G(DATA(F IELD))
  42691   "RTN","CHR OLIB1",134 ,0)
  42692    D FILE^DI E("","FDA" ,"ERRORS(1 )")
  42693   "RTN","CHR OLIB1",135 ,0)
  42694    ;Collect  Errors and  return 0  if unsucce ssful
  42695   "RTN","CHR OLIB1",136 ,0)
  42696    S RETURN= 1
  42697   "RTN","CHR OLIB1",137 ,0)
  42698    I +$G(DIE RR) D
  42699   "RTN","CHR OLIB1",138 ,0)
  42700    .S RETURN =0
  42701   "RTN","CHR OLIB1",139 ,0)
  42702    .S ERROR= $G(ERRORS( 1,"DIERR", 1,"TEXT",1 ))
  42703   "RTN","CHR OLIB1",140 ,0)
  42704    .S FPDI=" "
  42705   "RTN","CHR OLIB1",141 ,0)
  42706    ; If no e rror remov e EDIPAUSE  Cross Ref erence
  42707   "RTN","CHR OLIB1",142 ,0)
  42708    I RETURN  K ^CHMIMG( "EDIPAUSE" ,FPDI)
  42709   "RTN","CHR OLIB1",143 ,0)
  42710    ;
  42711   "RTN","CHR OLIB1",144 ,0)
  42712    Q RETURN
  42713   "RTN","CHR OLIB1",145 ,0)
  42714    ;
  42715   "RTN","CHR OLIB1",146 ,0)
  42716   RMVCLM(CLM )  ; Remov e Claim fr om all Que ues by set ting the S tatus to C omplete
  42717   "RTN","CHR OLIB1",147 ,0)
  42718    N QUEUE
  42719   "RTN","CHR OLIB1",148 ,0)
  42720    F QUEUE=1 ,2,3,5,6,7 ,8,11,19 D
  42721   "RTN","CHR OLIB1",149 ,0)
  42722    . I QUEUE =1,$D(^CHM PSQ("C",CL M)) D
  42723   "RTN","CHR OLIB1",150 ,0)
  42724    .. S DA=$ O(^CHMPSQ( "C",CLM,"" ))
  42725   "RTN","CHR OLIB1",151 ,0)
  42726    .. I DA'= "" S DR=". 03////3",D IE="^CHMPS Q(" D ^DIE  K DA,DR,D IE
  42727   "RTN","CHR OLIB1",152 ,0)
  42728    . I QUEUE =2,$D(^CHM QAQ("D",CL M)) D
  42729   "RTN","CHR OLIB1",153 ,0)
  42730    .. S DA=$ O(^CHMQAQ( "D",CLM,"" ))
  42731   "RTN","CHR OLIB1",154 ,0)
  42732    .. I DA'= "" S DR=". 03////2",D IE="^CHMQA Q(" D ^DIE  K DA,DR,D IE
  42733   "RTN","CHR OLIB1",155 ,0)
  42734    . I QUEUE =3,$D(^CHM ASQ("C",CL M)) D
  42735   "RTN","CHR OLIB1",156 ,0)
  42736    .. S DA=$ O(^CHMASQ( "C",CLM,"" ))
  42737   "RTN","CHR OLIB1",157 ,0)
  42738    .. I DA'= "" S DR=". 06////2",D IE="^CHMAS Q(" D ^DIE  K DA,DR,D IE
  42739   "RTN","CHR OLIB1",158 ,0)
  42740    . I QUEUE =5,$D(^CHM QVN("G",CL M)) D
  42741   "RTN","CHR OLIB1",159 ,0)
  42742    .. S DA(1 )=$O(^CHMQ VN("G",CLM ,"")) Q:DA (1)=""
  42743   "RTN","CHR OLIB1",160 ,0)
  42744    .. S DA=$ O(^CHMQVN( "G",CLM,DA (1),""))
  42745   "RTN","CHR OLIB1",161 ,0)
  42746    .. I DA'= "" S DR=". 06////1",D IE="^CHMQV N("_DA(1)_ ",10," D ^ DIE K DA,D R,DIE
  42747   "RTN","CHR OLIB1",162 ,0)
  42748    . I QUEUE =6,$D(^CHM MDQ("C",CL M)) D
  42749   "RTN","CHR OLIB1",163 ,0)
  42750    .. S DA=$ O(^CHMMDQ( "C",CLM,"" ))
  42751   "RTN","CHR OLIB1",164 ,0)
  42752    .. I DA'= "" S DR=". 03////2",D IE="^CHMMD Q(" D ^DIE  K DA,DR,D IE
  42753   "RTN","CHR OLIB1",165 ,0)
  42754    . I QUEUE =7,$D(^CHM DPCL(74101 0.13,"C",C LM)) D
  42755   "RTN","CHR OLIB1",166 ,0)
  42756    .. S DA=$ O(^CHMDPCL (741010.13 ,"D",CLM," "))
  42757   "RTN","CHR OLIB1",167 ,0)
  42758    .. I DA'= "" S DR=". 03////2",D IE="^CHMDP CL(741010. 13," D ^DI E K DA,DR, DIE
  42759   "RTN","CHR OLIB1",168 ,0)
  42760    . I QUEUE =8,$D(^CHM ELQ("C",CL M)) D
  42761   "RTN","CHR OLIB1",169 ,0)
  42762    .. S DA=$ O(^CHMELQ( "C",CLM,"" ))
  42763   "RTN","CHR OLIB1",170 ,0)
  42764    .. I DA'= "" S DR=". 06////2",D IE="^CHMEL Q(" D ^DIE  K DA,DR,D IE
  42765   "RTN","CHR OLIB1",171 ,0)
  42766    . I QUEUE =11,$D(^CH MEOBQ("D", CLM)) D
  42767   "RTN","CHR OLIB1",172 ,0)
  42768    .. S DA=$ O(^CHMEOBQ ("D",CLM," "))
  42769   "RTN","CHR OLIB1",173 ,0)
  42770    .. I DA'= "" S DR=". 03////1",D IE="^CHMEO BQ(" D ^DI E K DA,DR, DIE
  42771   "RTN","CHR OLIB1",174 ,0)
  42772    . I QUEUE =19,$D(^CH MPAY("B",C LM)) D
  42773   "RTN","CHR OLIB1",175 ,0)
  42774    .. S DA=$ O(^CHMPAY( "B",CLM,"" ))
  42775   "RTN","CHR OLIB1",176 ,0)
  42776    .. I DA'= "" S DR=". 02////4",D IE="^CHMPA Y(" D ^DIE  K DA,DR,D IE
  42777   "RTN","CHR OLIB1",177 ,0)
  42778    Q
  42779   "RTN","CHR OLIB1",178 ,0)
  42780    ;
  42781   "RTN","CHR OLIB1",179 ,0)
  42782   PAUSECHK   ; For chec king if th e Original  PDIs in E DI-PAUSE h ave had th eir Status =2 Claims
  42783   "RTN","CHR OLIB1",180 ,0)
  42784    ; updated  to anothe r status.   If in ano ther Statu s than 2,  remove fro m EDI-PAUS E
  42785   "RTN","CHR OLIB1",181 ,0)
  42786    ; and pro cess as fo llows.  Al l claims n ot in a co mplete sta tus will b e removed  from all
  42787   "RTN","CHR OLIB1",182 ,0)
  42788    ; queues  and set to  a Voided.   The orig inal PDI w ill then b e set to V oided and  a CSTAT
  42789   "RTN","CHR OLIB1",183 ,0)
  42790    ; message  sent, and  the Curre nt PDI wil l be set i nto the ap propriate  queue.
  42791   "RTN","CHR OLIB1",184 ,0)
  42792    ;
  42793   "RTN","CHR OLIB1",185 ,0)
  42794    N FPDI,CN T
  42795   "RTN","CHR OLIB1",186 ,0)
  42796    S FPDI=""
  42797   "RTN","CHR OLIB1",187 ,0)
  42798    F  S FPDI =$O(^CHMIM G("EDIPAUS E",FPDI))  Q:FPDI=""   D
  42799   "RTN","CHR OLIB1",188 ,0)
  42800    . S CNT=$ P(^CHMIMG( FPDI,"EDI- PAUSE",0), U,3) D
  42801   "RTN","CHR OLIB1",189 ,0)
  42802    . I $P(^C HMIMG(FPDI ,"EDI-PAUS E",CNT,0), U,3)'="" Q
  42803   "RTN","CHR OLIB1",190 ,0)
  42804    . N OPDI, CLM,FOUND
  42805   "RTN","CHR OLIB1",191 ,0)
  42806    . S OPDI= $P($G(^CHM IMG(FPDI," E-REOPEN") ),U,1) Q:O PDI=""
  42807   "RTN","CHR OLIB1",192 ,0)
  42808    . S CNT(2 )=0,(CLM,F OUND)=""
  42809   "RTN","CHR OLIB1",193 ,0)
  42810    . F  S CN T(2)=$O(^C HMIMG(FPDI ,"EDI-PAUS E",CNT,1,C NT(2))) Q: CNT(2)=""   D  Q:FOUN D
  42811   "RTN","CHR OLIB1",194 ,0)
  42812    .. S CLM= $G(^CHMIMG (FPDI,"EDI -PAUSE",CN T,1,CNT(2) ,0)) Q:CLM =""
  42813   "RTN","CHR OLIB1",195 ,0)
  42814    .. ; If a ny of the  Claims on  this PDI s till have  a Status o f 2 Quit o ut of 
  42815   "RTN","CHR OLIB1",196 ,0)
  42816    .. ; For  loop and t hen out of  CLM loop  as any Sta tus of 2 m eans the C laim canno t
  42817   "RTN","CHR OLIB1",197 ,0)
  42818    .. ; be p rocessed
  42819   "RTN","CHR OLIB1",198 ,0)
  42820    .. S STAT =$P(^CHMPA Y(CLM,0),U ,2) I STAT =2 S FOUND =1
  42821   "RTN","CHR OLIB1",199 ,0)
  42822    . ; If an y Claims h ave a Stat us of 2 Qu it
  42823   "RTN","CHR OLIB1",200 ,0)
  42824    . I FOUND  Q
  42825   "RTN","CHR OLIB1",201 ,0)
  42826    . ; Creat e Array of  Claims wi th Status  as Data
  42827   "RTN","CHR OLIB1",202 ,0)
  42828    . S CLM=" "
  42829   "RTN","CHR OLIB1",203 ,0)
  42830    . F  S CL M=$O(^CHMP AY("C",OPD I,CLM)) Q: CLM=""  D
  42831   "RTN","CHR OLIB1",204 ,0)
  42832    .. S STAT =$P(^CHMPA Y(CLM,0),U ,2)
  42833   "RTN","CHR OLIB1",205 ,0)
  42834    .. ; If t he Status  is Rejecte d, Complet e, Deleted , Voided,  or Reverse d Do not p rocess
  42835   "RTN","CHR OLIB1",206 ,0)
  42836    .. I ",0, 4,5,10,11, 12,"[(","_ STAT_",")  Q
  42837   "RTN","CHR OLIB1",207 ,0)
  42838    .. S FOUN D(CLM)=STA T
  42839   "RTN","CHR OLIB1",208 ,0)
  42840    . ; Proce ss all cla ims on Ori ginal PDI
  42841   "RTN","CHR OLIB1",209 ,0)
  42842    . S CLM=" "
  42843   "RTN","CHR OLIB1",210 ,0)
  42844    . F  S CL M=$O(FOUND (CLM)) Q:C LM=""  D
  42845   "RTN","CHR OLIB1",211 ,0)
  42846    .. N DA,D R,DIE
  42847   "RTN","CHR OLIB1",212 ,0)
  42848    .. ;Remov e Claim fo rm all Que ues
  42849   "RTN","CHR OLIB1",213 ,0)
  42850    .. D RMVC LM(CLM)
  42851   "RTN","CHR OLIB1",214 ,0)
  42852    .. ; Set  Claim to V oid and ad d 404 as R eason Code
  42853   "RTN","CHR OLIB1",215 ,0)
  42854    .. S DIE= 741000,DA= CLM,DR=".0 2///11" D  ^DIE
  42855   "RTN","CHR OLIB1",216 ,0)
  42856    .. S DR=" .13///404"  D ^DIE K  DIE
  42857   "RTN","CHR OLIB1",217 ,0)
  42858    . ; Remov e from EDI _PAUSE by  setting to  STOP
  42859   "RTN","CHR OLIB1",218 ,0)
  42860    . N SUCCE SS,CHEDRJ, CHXREC
  42861   "RTN","CHR OLIB1",219 ,0)
  42862    . S SUCCE SS=$$STOPP YRQ(FPDI,. ERROR)
  42863   "RTN","CHR OLIB1",220 ,0)
  42864    . ;Set ST ATUS OF Or iginal PDI  to VOIDED
  42865   "RTN","CHR OLIB1",221 ,0)
  42866    . S DIE=7 41000.2,DA =OPDI,DR=" .06///11"  D ^DIE K D IE
  42867   "RTN","CHR OLIB1",222 ,0)
  42868    . ;Send C STAT messa ge for Ori ginal PDI
  42869   "RTN","CHR OLIB1",223 ,0)
  42870    . S CHXRE C=""
  42871   "RTN","CHR OLIB1",224 ,0)
  42872    . S CHEDR J="E001b"
  42873   "RTN","CHR OLIB1",225 ,0)
  42874    . D CRCST AT^CHMFUTL E(OPDI,CHX REC,CHEDRJ ,"F")
  42875   "RTN","CHR OLIB1",226 ,0)
  42876    . ; Add C urrent PDI  to Ready  Queue base d upon Pro gram Indic ator
  42877   "RTN","CHR OLIB1",227 ,0)
  42878    . N PI,QU E
  42879   "RTN","CHR OLIB1",228 ,0)
  42880    . S PI=$E (FPDI,8,9)
  42881   "RTN","CHR OLIB1",229 ,0)
  42882    . S QUE=$ S(PI=92:"S BOCRR-READ Y",97:"OCR R-READY",1 :"")
  42883   "RTN","CHR OLIB1",230 ,0)
  42884    . I QUE'= "" S ^CHMI MG(QUE,FPD I)=""
  42885   "RTN","CHR OLIB1",231 ,0)
  42886    Q
  42887   "RTN","CHR OLIB1",232 ,0)
  42888    ;
  42889   "RTN","CHR OLIB1",233 ,0)
  42890   CMPCLAIM(P DI) ;Check  to see if  all assoc iated clai ms for Ori ginal PDI  have been  completed.
  42891   "RTN","CHR OLIB1",234 ,0)
  42892    ;If any o f the clai ms have no t been com pleted, th en a false  value is  returned.
  42893   "RTN","CHR OLIB1",235 ,0)
  42894    ;PDI = Or iginal PDI  Number
  42895   "RTN","CHR OLIB1",236 ,0)
  42896    N COMPLET E,IEN,STAT US
  42897   "RTN","CHR OLIB1",237 ,0)
  42898    S PDI=$G( PDI)
  42899   "RTN","CHR OLIB1",238 ,0)
  42900    S COMPLET E=1 ;
  42901   "RTN","CHR OLIB1",239 ,0)
  42902    I '$D(^CH MPAY("C",P DI)) Q 0
  42903   "RTN","CHR OLIB1",240 ,0)
  42904    S IEN=0 F   S IEN=$O (^CHMPAY(" C",PDI,IEN )) Q:'IEN! ('COMPLETE )  D
  42905   "RTN","CHR OLIB1",241 ,0)
  42906    .S STATUS =$P(^CHMPA Y(IEN,0)," ^",2)
  42907   "RTN","CHR OLIB1",242 ,0)
  42908    .I STATUS =1!(STATUS =2)!(STATU S=3)!(STAT US=6)!(STA TUS=7)!(ST ATUS=8)!(S TATUS=9) S  COMPLETE= 0
  42909   "RTN","CHR OLIB1",243 ,0)
  42910    Q COMPLET E
  42911   "RTN","CHR OLIB1",244 ,0)
  42912    ;
  42913   "RTN","CHR PBAR21")
  42914   0^69^B1599 3577
  42915   "RTN","CHR PBAR21",1, 0)
  42916   CHRPBAR21  ;HAC/AEB;R PC TO PRIN T PDI NUMB ER;06/24/9 9  3:07 PM
  42917   "RTN","CHR PBAR21",2, 0)
  42918    ;;1.0;CHA MPVA SYSTE M;**8**;DE CEMBER 08,  2010;Buil d 5
  42919   "RTN","CHR PBAR21",3, 0)
  42920    ;;V2.0
  42921   "RTN","CHR PBAR21",4, 0)
  42922    Q
  42923   "RTN","CHR PBAR21",5, 0)
  42924   DATA1(INPU T)  ;don't  call dire ct
  42925   "RTN","CHR PBAR21",6, 0)
  42926    ; OUTY -  Output -   sent back  thru RPC
  42927   "RTN","CHR PBAR21",7, 0)
  42928    ; INPUT -  DFN^BFN^C HTYP^PDIDT
  42929   "RTN","CHR PBAR21",8, 0)
  42930    S (CHCFIL E,CHBNAME, CHBSSN)="U NKNOWN",U= "^"
  42931   "RTN","CHR PBAR21",9, 0)
  42932    D GETHDR
  42933   "RTN","CHR PBAR21",10 ,0)
  42934    ;return a n error
  42935   "RTN","CHR PBAR21",11 ,0)
  42936    I +INPUT< 0 G EXIT
  42937   "RTN","CHR PBAR21",12 ,0)
  42938    S DUZ=$P( INPUT,"^", 5)
  42939   "RTN","CHR PBAR21",13 ,0)
  42940    S:DUZ=""  DUZ=9944
  42941   "RTN","CHR PBAR21",14 ,0)
  42942    S DUZ(0)= "" S:DUZ'= "" DUZ(0)= $P(^VA(200 ,DUZ,0),"^ ",4)
  42943   "RTN","CHR PBAR21",15 ,0)
  42944    S DFN=$P( INPUT,"^", 1)
  42945   "RTN","CHR PBAR21",16 ,0)
  42946    S BFN=$P( INPUT,"^", 2)
  42947   "RTN","CHR PBAR21",17 ,0)
  42948    S CHPTYP= $P(INPUT," ^",3)
  42949   "RTN","CHR PBAR21",18 ,0)
  42950    S CHT=0,C HT=$O(^CHM DIC(741002 .93,"C",CH PTYP,CHT))  G:'CHT EX IT
  42951   "RTN","CHR PBAR21",19 ,0)
  42952    S CHTMPPT =$P(^CHMDI C(741002.9 3,CHT,0)," ^",3)  ;PO INTER TO . 94 FILE
  42953   "RTN","CHR PBAR21",20 ,0)
  42954    G:CHTMPPT ="" EXIT G :'$D(^CHMD IC(741002. 94,CHTMPPT ,1)) EXIT
  42955   "RTN","CHR PBAR21",21 ,0)
  42956    S GLELG=" ^"_$P(^CHM DIC(741002 .94,CHTMPP T,1),"^",2 )
  42957   "RTN","CHR PBAR21",22 ,0)
  42958    S CHPDIDT =$P(INPUT, "^",4)
  42959   "RTN","CHR PBAR21",23 ,0)
  42960    S X=CHPDI DT S %DT=" X" D ^%DT  Q:Y=-1
  42961   "RTN","CHR PBAR21",24 ,0)
  42962    S CHPDIDT =Y
  42963   "RTN","CHR PBAR21",25 ,0)
  42964    I +DFN=0  G EXIT
  42965   "RTN","CHR PBAR21",26 ,0)
  42966    I (+BFN=0 )&(CHPTYP' =10) G EXI T
  42967   "RTN","CHR PBAR21",27 ,0)
  42968    I +DUZ=0  G EXIT
  42969   "RTN","CHR PBAR21",28 ,0)
  42970    D GETDATA
  42971   "RTN","CHR PBAR21",29 ,0)
  42972   EXIT ;
  42973   "RTN","CHR PBAR21",30 ,0)
  42974    Q OUTY
  42975   "RTN","CHR PBAR21",31 ,0)
  42976    ;
  42977   "RTN","CHR PBAR21",32 ,0)
  42978   GETHDR ;
  42979   "RTN","CHR PBAR21",33 ,0)
  42980    D ^CHRP
  42981   "RTN","CHR PBAR21",34 ,0)
  42982    X HDRREC
  42983   "RTN","CHR PBAR21",35 ,0)
  42984    Q
  42985   "RTN","CHR PBAR21",36 ,0)
  42986   GETDATA ;G ETS BENE/S PONSSOR/ V ET INFO PR INTS PDI
  42987   "RTN","CHR PBAR21",37 ,0)
  42988    I CHPTYP' =90!(CHPTY P'=97) D ^ CHRPBARI ; CP&E005-12 0 HM - CHE CK IF NOT  90 & 97
  42989   "RTN","CHR PBAR21",38 ,0)
  42990    I CHPTYP= 90!(CHPTYP =97) D LOA DIMG^CHMFA DR2  ;CP&E 005-120 HM  - CHECK I F 90 & 97  AND ADD LO GIC FOR ME RGING ORIG INAL PDI I NTO THE CU RRENT PDI
  42991   "RTN","CHR PBAR21",39 ,0)
  42992    S:CHPTYP' =10 CHNAME =$P(@(GLEL G_"DFN,100 ,BFN,0)"), "^",1)
  42993   "RTN","CHR PBAR21",40 ,0)
  42994    S:CHPTYP' =10 CHSSN= $P(@(GLELG _"DFN,100, BFN,0)")," ^",9)
  42995   "RTN","CHR PBAR21",41 ,0)
  42996    S:CHPTYP= 10 CHNAME= $P(@(GLELG _"DFN,0)") ,"^",1)
  42997   "RTN","CHR PBAR21",42 ,0)
  42998    S:CHPTYP= 10 CHSSN=$ P(@(GLELG_ "DFN,0)"), "^",9)
  42999   "RTN","CHR PBAR21",43 ,0)
  43000    S CHCFILE =$P(@(GLEL G_"DFN,0)" ),"^",7)
  43001   "RTN","CHR PBAR21",44 ,0)
  43002    S OUTY=CH NAME_"^"_C HSSN_"^"_C HCFILE_"^" _CHPDI
  43003   "RTN","CHR PBAR21",45 ,0)
  43004    ;X DATARE C
  43005   "RTN","CHR PBAR21",46 ,0)
  43006    Q
  43007   "RTN","CHR PBAR21",47 ,0)
  43008   FIELDS ;;F ield Name* code*line  Tag     ;; Each field  is stored  in var VA L
  43009   "RTN","CHR PBAR21",48 ,0)
  43010    ;;BENE_NA ME*CHNAME
  43011   "RTN","CHR PBAR21",49 ,0)
  43012    ;;BENE_SS N*CHSSN
  43013   "RTN","CHR PBAR21",50 ,0)
  43014    ;;SPON_CF ILE*CHCFIL E
  43015   "RTN","CHR PBAR21",51 ,0)
  43016    ;;PDI_NUM *CHPDI
  43017   "RTN","CHR PBAR21",52 ,0)
  43018   DATA2 ; TE STING
  43019   "RTN","CHR PBAR21",53 ,0)
  43020           S  (CHCFILE,C HBNAME,CHB SSN)="UNKN OWN",U="^"
  43021   "RTN","CHR PBAR21",54 ,0)
  43022           S  INPUT="391 19^1^97^31 80116^5881 88"
  43023   "RTN","CHR PBAR21",55 ,0)
  43024    ;D GETHDR
  43025   "RTN","CHR PBAR21",56 ,0)
  43026    ;return a n error
  43027   "RTN","CHR PBAR21",57 ,0)
  43028    B "S+"
  43029   "RTN","CHR PBAR21",58 ,0)
  43030    I +INPUT< 0 G EXIT
  43031   "RTN","CHR PBAR21",59 ,0)
  43032    S DUZ=$P( INPUT,"^", 5)
  43033   "RTN","CHR PBAR21",60 ,0)
  43034    S:DUZ=""  DUZ=9944
  43035   "RTN","CHR PBAR21",61 ,0)
  43036    S DUZ(0)= "" S:DUZ'= "" DUZ(0)= $P(^VA(200 ,DUZ,0),"^ ",4)
  43037   "RTN","CHR PBAR21",62 ,0)
  43038    S DFN=$P( INPUT,"^", 1)
  43039   "RTN","CHR PBAR21",63 ,0)
  43040    S BFN=$P( INPUT,"^", 2)
  43041   "RTN","CHR PBAR21",64 ,0)
  43042    S CHPTYP= $P(INPUT," ^",3)
  43043   "RTN","CHR PBAR21",65 ,0)
  43044    S CHT=0,C HT=$O(^CHM DIC(741002 .93,"C",CH PTYP,CHT))  G:'CHT EX IT
  43045   "RTN","CHR PBAR21",66 ,0)
  43046    S CHTMPPT =$P(^CHMDI C(741002.9 3,CHT,0)," ^",3)  ;PO INTER TO . 94 FILE
  43047   "RTN","CHR PBAR21",67 ,0)
  43048    G:CHTMPPT ="" EXIT G :'$D(^CHMD IC(741002. 94,CHTMPPT ,1)) EXIT
  43049   "RTN","CHR PBAR21",68 ,0)
  43050    S GLELG=" ^"_$P(^CHM DIC(741002 .94,CHTMPP T,1),"^",2 )
  43051   "RTN","CHR PBAR21",69 ,0)
  43052    S CHPDIDT =$P(INPUT, "^",4)
  43053   "RTN","CHR PBAR21",70 ,0)
  43054    S X=CHPDI DT S %DT=" X" D ^%DT  Q:Y=-1
  43055   "RTN","CHR PBAR21",71 ,0)
  43056    S CHPDIDT =Y
  43057   "RTN","CHR PBAR21",72 ,0)
  43058    I +DFN=0  G EXIT
  43059   "RTN","CHR PBAR21",73 ,0)
  43060    I (+BFN=0 )&(CHPTYP' =10) G EXI T
  43061   "RTN","CHR PBAR21",74 ,0)
  43062    I +DUZ=0  G EXIT
  43063   "RTN","CHR PBAR21",75 ,0)
  43064    S CHMFPDI =201723197 033739
  43065   "RTN","CHR PBAR21",76 ,0)
  43066    N CPDIZER O,OPDZERO, OPDIWF,CPD ZERO,CPDIW F
  43067   "RTN","CHR PBAR21",77 ,0)
  43068           Q: '$D(^CHMIM AGE(CHMFPD I,0))
  43069   "RTN","CHR PBAR21",78 ,0)
  43070           S  CPDIZERO=^ CHMIMAGE(C HMFPDI,0)
  43071   "RTN","CHR PBAR21",79 ,0)
  43072           M  ^CHMIMAGE( CHMFPDI)=^ CHMIMAGE(C HMOPDI)
  43073   "RTN","CHR PBAR21",80 ,0)
  43074           S  ^CHMIMAGE( CHMFPDI,0) =CPDIZERO
  43075   "RTN","CHR PBAR21",81 ,0)
  43076           S  X="" S:$D( ^CHMIMAGE( CHMFPDI,0) ) X=^(0)
  43077   "RTN","CHR PBAR21",82 ,0)
  43078           S  $P(X,"^",1 )=CHMFPDI, $P(X,"^",2 )=CHMFNMPG ,$P(X,"^", 3)=DUZ
  43079   "RTN","CHR PBAR21",83 ,0)
  43080           S  $P(X,"^",4 )=CHMFTMBG ,PDIFL=1
  43081   "RTN","CHR PBAR21",84 ,0)
  43082           S  ^CHMIMAGE( CHMFPDI,0) =X,^CHMIMA GE("B",CHM FPDI,CHMFP DI)=""
  43083   "RTN","CHR PBAR21",85 ,0)
  43084           S  OPDZERO=^C HMIMG(CHMO PDI,0)
  43085   "RTN","CHR PBAR21",86 ,0)
  43086           S  CPDZERO=^C HMIMG(CHMF PDI,0)
  43087   "RTN","CHR PBAR21",87 ,0)
  43088           M  CPDIWF=^CH MIMG(CHMFP DI,"WF")
  43089   "RTN","CHR PBAR21",88 ,0)
  43090           M  ^CHMIMG(CH MFPDI)=^CH MIMG(CHMOP DI)
  43091   "RTN","CHR PBAR21",89 ,0)
  43092           K  ^CHMIMG(CH MFPDI,"WF" )
  43093   "RTN","CHR PBAR21",90 ,0)
  43094           M  ^CHMIMG(CH MFPDI,"WF" )=CPDIWF
  43095   "RTN","CHR PBAR21",91 ,0)
  43096           S  ^CHMIMG(CH MFPDI,0)=C PDZERO
  43097   "RTN","CHR PBAR21",92 ,0)
  43098           S  $P(^CHMIMG (CHMFPDI,0 ),"^",2)=$ P(OPDZERO, "^",2)
  43099   "RTN","CHR PBAR21",93 ,0)
  43100           S  $P(^CHMIMG (CHMFPDI,0 ),"^",1)=C HMFPDI,^CH MIMG("B",C HMFPDI,CHM FPDI)=""
  43101   "RTN","CHR PBAR21",94 ,0)
  43102           S  $P(^CHMIMG (CHMFPDI,0 ),"^",3)=D UZ,$P(^CHM IMG(CHMFPD I,0),"^",4 )=CHMFTMBG
  43103   "RTN","CHR PBAR21",95 ,0)
  43104    ;
  43105   "RTN","CHR PBAR21",96 ,0)
  43106    ;D LOADIM G^CHMFADR2   ;CP&E005 -120 HM -  ADDED LOGI C FOR MERG ING ORIGIN AL PDI INT O THE CURR ENT PDI
  43107   "RTN","CHR PBAR21",97 ,0)
  43108    S:CHPTYP' =10 CHNAME =$P(@(GLEL G_"DFN,100 ,BFN,0)"), "^",1)
  43109   "RTN","CHR PBAR21",98 ,0)
  43110    S:CHPTYP' =10 CHSSN= $P(@(GLELG _"DFN,100, BFN,0)")," ^",9)
  43111   "RTN","CHR PBAR21",99 ,0)
  43112    S:CHPTYP= 10 CHNAME= $P(@(GLELG _"DFN,0)") ,"^",1)
  43113   "RTN","CHR PBAR21",10 0,0)
  43114    S:CHPTYP= 10 CHSSN=$ P(@(GLELG_ "DFN,0)"), "^",9)
  43115   "RTN","CHR PBAR21",10 1,0)
  43116    S CHCFILE =$P(@(GLEL G_"DFN,0)" ),"^",7)
  43117   "RTN","CHR PBAR21",10 2,0)
  43118    S OUTY=CH NAME_"^"_C HSSN_"^"_C HCFILE_"^" _CHPDI
  43119   "RTN","CHR PBAR21",10 3,0)
  43120    Q
  43121   "RTN","CHR PBAR21",10 4,0)
  43122    ;
  43123   "UP",74100 0.2,741000 .35,-1)
  43124   741000.2^E DI-PAUSE
  43125   "UP",74100 0.2,741000 .35,0)
  43126   741000.35
  43127   "UP",74100 0.2,741000 .353,-2)
  43128   741000.2^E DI-PAUSE
  43129   "UP",74100 0.2,741000 .353,-1)
  43130   741000.35^ 1
  43131   "UP",74100 0.2,741000 .353,0)
  43132   741000.353
  43133   "VER")
  43134   8.0^22.2
  43135   "^DD",7410 00,741000, 800.105,0)
  43136   PL ZIP^FJ1 0^^VEN-II; 15^K:$L(X) >10!($L(X) <5) X
  43137   "^DD",7410 00,741000, 800.105,1, 0)
  43138   ^.1
  43139   "^DD",7410 00,741000, 800.105,1, 1,0)
  43140   741000^F
  43141   "^DD",7410 00,741000, 800.105,1, 1,1)
  43142   S ^CHMPAY( "F",$E(X,1 ,30),DA)=" "
  43143   "^DD",7410 00,741000, 800.105,1, 1,2)
  43144   K ^CHMPAY( "F",$E(X,1 ,30),DA)
  43145   "^DD",7410 00,741000, 800.105,1, 1,"DT")
  43146   3170518
  43147   "^DD",7410 00,741000, 800.105,3)
  43148   Answer mus t be 5-10  characters  in length .
  43149   "^DD",7410 00,741000, 800.105,"D T")
  43150   3170620
  43151   "^DD",7410 00.2,74100 0.2,45,0)
  43152   TRACK EDI- PAUSE TIME ^741000.35 DA^^EDI-PA USE;0
  43153   "^DD",7410 00.2,74100 0.35,0)
  43154   TRACK EDI- PAUSE TIME  SUB-FIELD ^^3^4
  43155   "^DD",7410 00.2,74100 0.35,0,"DT ")
  43156   3180215
  43157   "^DD",7410 00.2,74100 0.35,0,"IX ","B",7410 00.35,.01)
  43158  
  43159   "^DD",7410 00.2,74100 0.35,0,"NM ","TRACK E DI-PAUSE T IME")
  43160  
  43161   "^DD",7410 00.2,74100 0.35,0,"UP ")
  43162   741000.2
  43163   "^DD",7410 00.2,74100 0.35,.01,0 )
  43164   TIME SET T O EDI-PAUS E^D^^0;1^S  %DT="EST"  D ^%DT S  X=Y K:Y<1  X
  43165   "^DD",7410 00.2,74100 0.35,.01,1 ,0)
  43166   ^.1
  43167   "^DD",7410 00.2,74100 0.35,.01,1 ,1,0)
  43168   741000.35^ B
  43169   "^DD",7410 00.2,74100 0.35,.01,1 ,1,1)
  43170   S ^CHMIMG( DA(1),"EDI -PAUSE","B ",$E(X,1,3 0),DA)=""
  43171   "^DD",7410 00.2,74100 0.35,.01,1 ,1,2)
  43172   K ^CHMIMG( DA(1),"EDI -PAUSE","B ",$E(X,1,3 0),DA)
  43173   "^DD",7410 00.2,74100 0.35,.01,1 ,2,0)
  43174   741000.2^E DIPAUSE^MU MPS
  43175   "^DD",7410 00.2,74100 0.35,.01,1 ,2,1)
  43176   S ^CHMIMG( "EDIPAUSE" ,DA(1))=""
  43177   "^DD",7410 00.2,74100 0.35,.01,1 ,2,2)
  43178   K ^CHMIMG( "EDIPAUSE" ,DA(1))
  43179   "^DD",7410 00.2,74100 0.35,.01,1 ,2,"DT")
  43180   3180206
  43181   "^DD",7410 00.2,74100 0.35,.01,3 )
  43182   Enter Date  and Time  of entry i nto EDI-PA USE
  43183   "^DD",7410 00.2,74100 0.35,.01," DT")
  43184   3180206
  43185   "^DD",7410 00.2,74100 0.35,1,0)
  43186   DUZ^P200'^ VA(200,^0; 2^Q
  43187   "^DD",7410 00.2,74100 0.35,1,3)
  43188   Enter the  DUZ of the  New Perso n
  43189   "^DD",7410 00.2,74100 0.35,1,"DT ")
  43190   3180206
  43191   "^DD",7410 00.2,74100 0.35,2,0)
  43192   TIME REMOV ED FROM ED I-PAUSE^DX ^^0;3^S %D T="EST" D  ^%DT S X=Y  K:X<1 X
  43193   "^DD",7410 00.2,74100 0.35,2,3)
  43194   Enter Time  Removed f rom EDI-PA USE for a  single IEN
  43195   "^DD",7410 00.2,74100 0.35,2,21, 0)
  43196   ^^1^1^3180 206^
  43197   "^DD",7410 00.2,74100 0.35,2,21, 1,0)
  43198   Date and T ime of sto p for a si ngle IEN t o "EDI-PAU SE" file
  43199   "^DD",7410 00.2,74100 0.35,2,"DT ")
  43200   3180206
  43201   "^DD",7410 00.2,74100 0.35,3,0)
  43202   ORIG PDI P AY REQ CLA IM NUMS^74 1000.353A^ ^1;0
  43203   "^DD",7410 00.2,74100 0.35,3,21, 0)
  43204   ^^3^3^3180 215^
  43205   "^DD",7410 00.2,74100 0.35,3,21, 1,0)
  43206   This is th e Original  PDI's Pay ment Reque sted Claim  Numbers f or this
  43207   "^DD",7410 00.2,74100 0.35,3,21, 2,0)
  43208   Current PD I. Origina l Claim wi ll be vali dated to a llow for r elease of
  43209   "^DD",7410 00.2,74100 0.35,3,21, 3,0)
  43210   Current PD I.
  43211   "^DD",7410 00.2,74100 0.35,3,"DT ")
  43212   3180215
  43213   "^DD",7410 00.2,74100 0.353,0)
  43214   ORIG PDI P AY REQ CLA IM NUMS SU B-FIELD^^. 01^1
  43215   "^DD",7410 00.2,74100 0.353,0,"D T")
  43216   3180215
  43217   "^DD",7410 00.2,74100 0.353,0,"I X","B",741 000.353,.0 1)
  43218  
  43219   "^DD",7410 00.2,74100 0.353,0,"N M","ORIG P DI PAY REQ  CLAIM NUM S")
  43220  
  43221   "^DD",7410 00.2,74100 0.353,0,"U P")
  43222   741000.35
  43223   "^DD",7410 00.2,74100 0.353,.01, 0)
  43224   ORIG PDI P AY REQ CLA IM NUMS^FJ 99^^0;1^K: $L(X)>99!( $L(X)<1) X
  43225   "^DD",7410 00.2,74100 0.353,.01, 1,0)
  43226   ^.1
  43227   "^DD",7410 00.2,74100 0.353,.01, 1,1,0)
  43228   741000.353 ^B
  43229   "^DD",7410 00.2,74100 0.353,.01, 1,1,1)
  43230   S ^CHMIMG( DA(2),"EDI -PAUSE",DA (1),1,"B", $E(X,1,30) ,DA)=""
  43231   "^DD",7410 00.2,74100 0.353,.01, 1,1,2)
  43232   K ^CHMIMG( DA(2),"EDI -PAUSE",DA (1),1,"B", $E(X,1,30) ,DA)
  43233   "^DD",7410 00.2,74100 0.353,.01, 3)
  43234   Enter the  Original P DI's Payme nt Request ed Claim N umber
  43235   "^DD",7410 00.2,74100 0.353,.01, "DT")
  43236   3180215
  43237   "^DD",7410 01,741001, 8.01,0)
  43238   DATE INACT IVATED^D^^ 8;1^S %DT= "EX" D ^%D T S X=Y K: Y<1 X
  43239   "^DD",7410 01,741001, 8.01,3)
  43240   ENTER THE  DATE THAT  THE VENDOR  STATUS WA S INACTIVA TED.
  43241   "^DD",7410 01,741001, 8.01,21,0)
  43242   ^^2^2^3180 122^
  43243   "^DD",7410 01,741001, 8.01,21,1, 0)
  43244   THIS IS TH E DATE THA T THE VEND OR ENTRY W AS INACTIV ATED BY TH E
  43245   "^DD",7410 01,741001, 8.01,21,2, 0)
  43246   DUPLICATE  VENDOR CLE ANUP ROUTI NE.
  43247   "^DD",7410 01,741001, 8.01,"DT")
  43248   3180122
  43249   "^DD",7410 01,741001, 8.02,0)
  43250   DUPLICATE  CLEANUP US ER^P200'^V A(200,^8;2 ^Q
  43251   "^DD",7410 01,741001, 8.02,3)
  43252   ENTER THE  NAME OF TH E USER.
  43253   "^DD",7410 01,741001, 8.02,21,0)
  43254   ^.001^2^2^ 3180122^^
  43255   "^DD",7410 01,741001, 8.02,21,1, 0)
  43256   THIS IS TH E USER WHO  IS PERFOR MING THE D UPLICATE V ENDOR
  43257   "^DD",7410 01,741001, 8.02,21,2, 0)
  43258   CLEANUP.
  43259   "^DD",7410 01,741001, 8.02,"DT")
  43260   3180122
  43261   **END**
  43262   **END**